diff --git a/src/admm_dm_methods.F b/src/admm_dm_methods.F index 8f83760aa3..e97974d185 100644 --- a/src/admm_dm_methods.F +++ b/src/admm_dm_methods.F @@ -48,12 +48,10 @@ MODULE admm_dm_methods ! ***************************************************************************** !> \brief Entry methods: Calculates auxilary density matrix from primary one. !> \param ks_env ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE admm_dm_calc_rho_aux(ks_env, error) + SUBROUTINE admm_dm_calc_rho_aux(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'admm_dm_calc_rho_aux', & routineP = moduleN//':'//routineN @@ -63,23 +61,23 @@ SUBROUTINE admm_dm_calc_rho_aux(ks_env, error) NULLIFY(admm_dm) CALL timeset(routineN,handle) - CALL get_ks_env(ks_env, admm_dm=admm_dm, error=error) + CALL get_ks_env(ks_env, admm_dm=admm_dm) SELECT CASE(admm_dm%method) CASE(do_admm_basis_projection) - CALL map_dm_projection(ks_env, error) + CALL map_dm_projection(ks_env) CASE(do_admm_blocked_projection) - CALL map_dm_blocked(ks_env, error) + CALL map_dm_blocked(ks_env) CASE DEFAULT STOP "admm_dm_calc_rho_aux: unknown method" END SELECT IF(admm_dm%purify)& - CALL purify_mcweeny(ks_env, error) + CALL purify_mcweeny(ks_env) - CALL update_rho_aux(ks_env, error) + CALL update_rho_aux(ks_env) CALL timestop(handle) END SUBROUTINE admm_dm_calc_rho_aux @@ -87,12 +85,10 @@ END SUBROUTINE admm_dm_calc_rho_aux ! ***************************************************************************** !> \brief Entry methods: Merges auxilary Kohn-Sham matrix into primary one. !> \param ks_env ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE admm_dm_merge_ks_matrix(ks_env, error) + SUBROUTINE admm_dm_merge_ks_matrix(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'admm_dm_merge_ks_matrix', & routineP = moduleN//':'//routineN @@ -105,27 +101,27 @@ SUBROUTINE admm_dm_merge_ks_matrix(ks_env, error) CALL timeset(routineN,handle) NULLIFY(admm_dm, matrix_ks_merge) - CALL get_ks_env(ks_env, admm_dm=admm_dm, error=error) + CALL get_ks_env(ks_env, admm_dm=admm_dm) IF(admm_dm%purify) THEN - CALL revert_purify_mcweeny(ks_env, matrix_ks_merge, error) + CALL revert_purify_mcweeny(ks_env, matrix_ks_merge) ELSE - CALL get_ks_env(ks_env, matrix_ks_aux_fit=matrix_ks_merge, error=error) + CALL get_ks_env(ks_env, matrix_ks_aux_fit=matrix_ks_merge) ENDIF SELECT CASE(admm_dm%method) CASE(do_admm_basis_projection) - CALL merge_dm_projection(ks_env, matrix_ks_merge, error) + CALL merge_dm_projection(ks_env, matrix_ks_merge) CASE(do_admm_blocked_projection) - CALL merge_dm_blocked(ks_env, matrix_ks_merge, error) + CALL merge_dm_blocked(ks_env, matrix_ks_merge) CASE DEFAULT STOP "admm_dm_merge_ks_matrix: unknown method" END SELECT IF(admm_dm%purify)& - CALL cp_dbcsr_deallocate_matrix_set(matrix_ks_merge,error) + CALL cp_dbcsr_deallocate_matrix_set(matrix_ks_merge) CALL timestop(handle) @@ -134,12 +130,10 @@ END SUBROUTINE admm_dm_merge_ks_matrix ! ***************************************************************************** !> \brief Calculates auxilary density matrix via basis projection. !> \param ks_env ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE map_dm_projection(ks_env, error) + SUBROUTINE map_dm_projection(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'map_dm_projection', & routineP = moduleN//':'//routineN @@ -164,50 +158,47 @@ SUBROUTINE map_dm_projection(ks_env, error) matrix_s_aux_fit_vs_orb=matrix_s_mixed,& s_mstruct_changed=s_mstruct_changed,& rho=rho,& - rho_aux_fit=rho_aux,& - error=error) + rho_aux_fit=rho_aux) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) - CALL qs_rho_get(rho_aux, rho_ao=rho_ao_aux, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) + CALL qs_rho_get(rho_aux, rho_ao=rho_ao_aux) IF(s_mstruct_changed) THEN ! Calculate A = S_aux^(-1) * S_mixed - CALL cp_dbcsr_init(matrix_s_aux_inv, error=error) - CALL cp_dbcsr_create(matrix_s_aux_inv, template=matrix_s_aux(1)%matrix, matrix_type="N", error=error) - CALL invert_Hotelling(matrix_s_aux_inv, matrix_s_aux(1)%matrix, admm_dm%eps_filter, error=error) + CALL cp_dbcsr_init(matrix_s_aux_inv) + CALL cp_dbcsr_create(matrix_s_aux_inv, template=matrix_s_aux(1)%matrix, matrix_type="N") + CALL invert_Hotelling(matrix_s_aux_inv, matrix_s_aux(1)%matrix, admm_dm%eps_filter) IF(.NOT. ASSOCIATED(admm_dm%matrix_A)) THEN ALLOCATE(admm_dm%matrix_A) - CALL cp_dbcsr_init(admm_dm%matrix_A, error=error) - CALL cp_dbcsr_create(admm_dm%matrix_A, template=matrix_s_mixed(1)%matrix, matrix_type="N", error=error) + CALL cp_dbcsr_init(admm_dm%matrix_A) + CALL cp_dbcsr_create(admm_dm%matrix_A, template=matrix_s_mixed(1)%matrix, matrix_type="N") ENDIF CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s_aux_inv, matrix_s_mixed(1)%matrix, & - 0.0_dp, admm_dm%matrix_A, error=error) - CALL cp_dbcsr_release(matrix_s_aux_inv, error) + 0.0_dp, admm_dm%matrix_A) + CALL cp_dbcsr_release(matrix_s_aux_inv) ENDIF ! Calculate P_aux = A * P * A^T - CALL cp_dbcsr_init(matrix_tmp, error=error) - CALL cp_dbcsr_create(matrix_tmp, template=admm_dm%matrix_A, error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp, template=admm_dm%matrix_A) DO ispin=1, dft_control%nspins CALL cp_dbcsr_multiply("N", "N", 1.0_dp, admm_dm%matrix_A, rho_ao(ispin)%matrix,& - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp, admm_dm%matrix_A, & - 0.0_dp, rho_ao_aux(ispin)%matrix, error=error) + 0.0_dp, rho_ao_aux(ispin)%matrix) END DO - CALL cp_dbcsr_release(matrix_tmp, error) + CALL cp_dbcsr_release(matrix_tmp) END SUBROUTINE map_dm_projection ! ***************************************************************************** !> \brief Calculates auxilary density matrix via blocking. !> \param ks_env ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE map_dm_blocked(ks_env, error) + SUBROUTINE map_dm_blocked(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: blk, iatom, ispin, jatom LOGICAL :: found @@ -225,15 +216,14 @@ SUBROUTINE map_dm_blocked(ks_env, error) admm_dm=admm_dm,& dft_control=dft_control,& rho=rho,& - rho_aux_fit=rho_aux,& - error=error) + rho_aux_fit=rho_aux) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) - CALL qs_rho_get(rho_aux, rho_ao=rho_ao_aux, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) + CALL qs_rho_get(rho_aux, rho_ao=rho_ao_aux) ! ** set blocked density matrix to 0 DO ispin=1, dft_control%nspins - CALL cp_dbcsr_set(rho_ao_aux(ispin)%matrix, 0.0_dp, error) + CALL cp_dbcsr_set(rho_ao_aux(ispin)%matrix, 0.0_dp) ! ** now loop through the list and copy corresponding blocks CALL cp_dbcsr_iterator_start(iter, rho_ao(ispin)%matrix) DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) @@ -253,11 +243,9 @@ END SUBROUTINE map_dm_blocked ! ***************************************************************************** !> \brief Call calculate_rho_elec() for auxilary density !> \param ks_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE update_rho_aux(ks_env, error) + SUBROUTINE update_rho_aux(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ispin REAL(KIND=dp), DIMENSION(:), POINTER :: tot_rho_r_aux @@ -273,15 +261,13 @@ SUBROUTINE update_rho_aux(ks_env, error) CALL get_ks_env(ks_env,& admm_dm=admm_dm,& dft_control=dft_control,& - rho_aux_fit=rho_aux,& - error=error) + rho_aux_fit=rho_aux) CALL qs_rho_get(rho_aux,& rho_ao=rho_ao_aux,& rho_r=rho_r_aux,& rho_g=rho_g_aux,& - tot_rho_r=tot_rho_r_aux,& - error=error) + tot_rho_r=tot_rho_r_aux) DO ispin=1, dft_control%nspins CALL calculate_rho_elec(ks_env=ks_env,& @@ -290,11 +276,10 @@ SUBROUTINE update_rho_aux(ks_env, error) rho_gspace=rho_g_aux(ispin),& total_rho=tot_rho_r_aux(ispin),& soft_valid=.FALSE.,& - basis_type="AUX_FIT",& - error=error) + basis_type="AUX_FIT") END DO - CALL qs_rho_set(rho_aux, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_aux, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) END SUBROUTINE update_rho_aux @@ -302,14 +287,12 @@ END SUBROUTINE update_rho_aux !> \brief Merges auxilary Kohn-Sham matrix via basis projection. !> \param ks_env ... !> \param matrix_ks_merge Input: The KS matrix to be merged -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE merge_dm_projection(ks_env, matrix_ks_merge, error) + SUBROUTINE merge_dm_projection(ks_env, matrix_ks_merge) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks_merge - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: ispin TYPE(admm_dm_type), POINTER :: admm_dm @@ -323,21 +306,20 @@ SUBROUTINE merge_dm_projection(ks_env, matrix_ks_merge, error) CALL get_ks_env(ks_env,& admm_dm=admm_dm,& dft_control=dft_control,& - matrix_ks=matrix_ks,& - error=error) + matrix_ks=matrix_ks) ! Calculate K += A^T * K_aux * A - CALL cp_dbcsr_init(matrix_tmp, error=error) - CALL cp_dbcsr_create(matrix_tmp, template=admm_dm%matrix_A, matrix_type="N", error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp, template=admm_dm%matrix_A, matrix_type="N") DO ispin=1, dft_control%nspins CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_ks_merge(ispin)%matrix, admm_dm%matrix_A, & - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, admm_dm%matrix_A, matrix_tmp, & - 1.0_dp, matrix_ks(ispin)%matrix, error=error) + 1.0_dp, matrix_ks(ispin)%matrix) END DO - CALL cp_dbcsr_release(matrix_tmp, error) + CALL cp_dbcsr_release(matrix_tmp) END SUBROUTINE merge_dm_projection @@ -345,14 +327,12 @@ END SUBROUTINE merge_dm_projection !> \brief Merges auxilary Kohn-Sham matrix via blocking. !> \param ks_env ... !> \param matrix_ks_merge Input: The KS matrix to be merged -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE merge_dm_blocked(ks_env, matrix_ks_merge, error) + SUBROUTINE merge_dm_blocked(ks_env, matrix_ks_merge) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks_merge - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: blk, iatom, ispin, jatom REAL(dp), DIMENSION(:, :), POINTER :: sparse_block @@ -367,8 +347,7 @@ SUBROUTINE merge_dm_blocked(ks_env, matrix_ks_merge, error) CALL get_ks_env(ks_env,& admm_dm=admm_dm,& dft_control=dft_control,& - matrix_ks=matrix_ks,& - error=error) + matrix_ks=matrix_ks) DO ispin=1, dft_control%nspins CALL cp_dbcsr_iterator_start(iter, matrix_ks_merge(ispin)%matrix) @@ -378,7 +357,7 @@ SUBROUTINE merge_dm_blocked(ks_env, matrix_ks_merge, error) sparse_block = 0.0_dp END DO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_merge(ispin)%matrix, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_merge(ispin)%matrix, 1.0_dp, 1.0_dp) ENDDO END SUBROUTINE merge_dm_blocked @@ -386,12 +365,10 @@ END SUBROUTINE merge_dm_blocked ! ***************************************************************************** !> \brief Apply McWeeny purification to auxilary density matrix !> \param ks_env ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE purify_mcweeny(ks_env, error) + SUBROUTINE purify_mcweeny(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'purify_mcweeny', & routineP = moduleN//':'//routineN @@ -418,18 +395,17 @@ SUBROUTINE purify_mcweeny(ks_env, error) dft_control=dft_control,& admm_dm=admm_dm,& matrix_s_aux_fit=matrix_s_aux_fit,& - rho_aux_fit=rho_aux_fit,& - error=error) + rho_aux_fit=rho_aux_fit) - CALL qs_rho_get(rho_aux_fit, rho_ao=rho_ao_aux, error=error) + CALL qs_rho_get(rho_aux_fit, rho_ao=rho_ao_aux) matrix_p => rho_ao_aux(1)%matrix - CALL cp_dbcsr_init(matrix_PS,error=error) - CALL cp_dbcsr_create(matrix_PS,template=matrix_p,matrix_type="N",error=error) - CALL cp_dbcsr_init(matrix_PSP,error=error) - CALL cp_dbcsr_create(matrix_PSP,template=matrix_p,matrix_type="S",error=error) - CALL cp_dbcsr_init(matrix_test,error=error) - CALL cp_dbcsr_create(matrix_test,template=matrix_p,matrix_type="S",error=error) + CALL cp_dbcsr_init(matrix_PS) + CALL cp_dbcsr_create(matrix_PS,template=matrix_p,matrix_type="N") + CALL cp_dbcsr_init(matrix_PSP) + CALL cp_dbcsr_create(matrix_PSP,template=matrix_p,matrix_type="S") + CALL cp_dbcsr_init(matrix_test) + CALL cp_dbcsr_create(matrix_test,template=matrix_p,matrix_type="S") nspins = dft_control%nspins DO ispin=1, nspins @@ -437,7 +413,7 @@ SUBROUTINE purify_mcweeny(ks_env, error) matrix_s => matrix_s_aux_fit(1)%matrix history => admm_dm%mcweeny_history(ispin)%p IF(ASSOCIATED(history)) STOP "purify_dm_mcweeny: history already associated" - IF(nspins==1) CALL cp_dbcsr_scale(matrix_p,0.5_dp,error=error) + IF(nspins==1) CALL cp_dbcsr_scale(matrix_p,0.5_dp) DO istep=1, admm_dm%mcweeny_max_steps ! allocate new element in linked list @@ -446,38 +422,38 @@ SUBROUTINE purify_mcweeny(ks_env, error) history => new_hist_entry history%count = istep NULLIFY(new_hist_entry) - CALL cp_dbcsr_init(history%m, error=error) - CALL cp_dbcsr_create(history%m, template=matrix_p ,matrix_type="N",error=error) - CALL cp_dbcsr_copy(history%m, matrix_p, name="P from McWeeny", error=error) + CALL cp_dbcsr_init(history%m) + CALL cp_dbcsr_create(history%m, template=matrix_p ,matrix_type="N") + CALL cp_dbcsr_copy(history%m, matrix_p, name="P from McWeeny") ! calc PS and PSP CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p, matrix_s,& - 0.0_dp, matrix_ps, error=error) + 0.0_dp, matrix_ps) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_ps, matrix_p,& - 0.0_dp, matrix_psp, error=error) + 0.0_dp, matrix_psp) !test convergence - CALL cp_dbcsr_copy(matrix_test, matrix_psp, error=error) - CALL cp_dbcsr_add(matrix_test, matrix_p, 1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_copy(matrix_test, matrix_psp) + CALL cp_dbcsr_add(matrix_test, matrix_p, 1.0_dp,-1.0_dp) frob_norm=cp_dbcsr_frobenius_norm(matrix_test) IF(unit_nr>0) WRITE(unit_nr,'(t3,a,i5,a,f16.8)')"McWeeny-Step",istep,& ": Deviation of idempotency", frob_norm IF(frob_norm < 1000_dp*admm_dm%eps_filter .AND. istep>1) EXIT ! build next P matrix - CALL cp_dbcsr_copy(matrix_p, matrix_PSP, name="P from McWeeny", error=error) + CALL cp_dbcsr_copy(matrix_p, matrix_PSP, name="P from McWeeny") CALL cp_dbcsr_multiply("N", "N", -2.0_dp, matrix_PS, matrix_PSP,& - 3.0_dp, matrix_p, error=error) + 3.0_dp, matrix_p) END DO admm_dm%mcweeny_history(ispin)%p => history - IF(nspins==1) CALL cp_dbcsr_scale(matrix_p,2.0_dp,error=error) + IF(nspins==1) CALL cp_dbcsr_scale(matrix_p,2.0_dp) END DO ! clean up - CALL cp_dbcsr_release(matrix_PS,error) - CALL cp_dbcsr_release(matrix_PSP,error) - CALL cp_dbcsr_release(matrix_test,error) + CALL cp_dbcsr_release(matrix_PS) + CALL cp_dbcsr_release(matrix_PSP) + CALL cp_dbcsr_release(matrix_test) CALL timestop(handle) END SUBROUTINE purify_mcweeny @@ -485,14 +461,12 @@ END SUBROUTINE purify_mcweeny !> \brief Prepare auxilary KS-matrix for merge using reverse McWeeny !> \param ks_env ... !> \param matrix_ks_merge Output: The KS matrix for the merge -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE revert_purify_mcweeny(ks_env, matrix_ks_merge, error) + SUBROUTINE revert_purify_mcweeny(ks_env, matrix_ks_merge) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks_merge - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'revert_purify_mcweeny', & routineP = moduleN//':'//routineN @@ -519,8 +493,7 @@ SUBROUTINE revert_purify_mcweeny(ks_env, matrix_ks_merge, error) matrix_ks=matrix_ks,& matrix_ks_aux_fit=matrix_ks_aux_fit,& matrix_s_aux_fit=matrix_s_aux_fit,& - matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb,& - error=error) + matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb) nspins = dft_control%nspins ALLOCATE(matrix_ks_merge(nspins)) @@ -528,8 +501,8 @@ SUBROUTINE revert_purify_mcweeny(ks_env, matrix_ks_merge, error) DO ispin=1, nspins ALLOCATE(matrix_ks_merge(ispin)%matrix) matrix_k => matrix_ks_merge(ispin)%matrix - CALL cp_dbcsr_init(matrix_k, error=error) - CALL cp_dbcsr_copy(matrix_k, matrix_ks_aux_fit(ispin)%matrix, name="K", error=error) + CALL cp_dbcsr_init(matrix_k) + CALL cp_dbcsr_copy(matrix_k, matrix_ks_aux_fit(ispin)%matrix, name="K") history_curr => admm_dm%mcweeny_history(ispin)%p NULLIFY(admm_dm%mcweeny_history(ispin)%p) @@ -538,9 +511,8 @@ SUBROUTINE revert_purify_mcweeny(ks_env, matrix_ks_merge, error) IF(unit_nr>1) WRITE(unit_nr,'(t3,a,i5)')"Reverse McWeeny-Step ", history_curr%count CALL reverse_mcweeny_step(matrix_k=matrix_k,& matrix_s=matrix_s_aux_fit(1)%matrix,& - matrix_p=history_curr%m,& - error=error) - CALL cp_dbcsr_release(history_curr%m,error) + matrix_p=history_curr%m) + CALL cp_dbcsr_release(history_curr%m) history_next => history_curr%next DEALLOCATE(history_curr) history_curr => history_next @@ -559,12 +531,10 @@ END SUBROUTINE revert_purify_mcweeny !> \param matrix_k ... !> \param matrix_s ... !> \param matrix_p ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE reverse_mcweeny_step(matrix_k, matrix_s, matrix_p, error) + SUBROUTINE reverse_mcweeny_step(matrix_k, matrix_s, matrix_p) TYPE(cp_dbcsr_type) :: matrix_k, matrix_s, matrix_p - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'reverse_mcweeny_step', & routineP = moduleN//':'//routineN @@ -574,48 +544,48 @@ SUBROUTINE reverse_mcweeny_step(matrix_k, matrix_s, matrix_p, error) matrix_sum, matrix_tmp CALL timeset(routineN,handle) - CALL cp_dbcsr_init(matrix_ps,error=error) - CALL cp_dbcsr_create(matrix_ps,template=matrix_p,matrix_type="N",error=error) - CALL cp_dbcsr_init(matrix_sp,error=error) - CALL cp_dbcsr_create(matrix_sp,template=matrix_p,matrix_type="N",error=error) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix_p,matrix_type="N",error=error) - CALL cp_dbcsr_init(matrix_sum,error=error) - CALL cp_dbcsr_create(matrix_sum,template=matrix_p,matrix_type="N",error=error) + CALL cp_dbcsr_init(matrix_ps) + CALL cp_dbcsr_create(matrix_ps,template=matrix_p,matrix_type="N") + CALL cp_dbcsr_init(matrix_sp) + CALL cp_dbcsr_create(matrix_sp,template=matrix_p,matrix_type="N") + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix_p,matrix_type="N") + CALL cp_dbcsr_init(matrix_sum) + CALL cp_dbcsr_create(matrix_sum,template=matrix_p,matrix_type="N") CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p, matrix_s,& - 0.0_dp, matrix_ps, error=error) + 0.0_dp, matrix_ps) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s, matrix_p,& - 0.0_dp, matrix_sp, error=error) + 0.0_dp, matrix_sp) !TODO: can we exploid more symmetry? CALL cp_dbcsr_multiply("N", "N", 3.0_dp, matrix_k, matrix_ps,& - 0.0_dp, matrix_sum, error=error) + 0.0_dp, matrix_sum) CALL cp_dbcsr_multiply("N", "N", 3.0_dp, matrix_sp, matrix_k,& - 1.0_dp, matrix_sum, error=error) + 1.0_dp, matrix_sum) !matrix_tmp = KPS CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_k, matrix_ps,& - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("N", "N", -2.0_dp, matrix_tmp, matrix_ps,& - 1.0_dp, matrix_sum, error=error) + 1.0_dp, matrix_sum) CALL cp_dbcsr_multiply("N", "N", -2.0_dp, matrix_sp, matrix_tmp,& - 1.0_dp, matrix_sum, error=error) + 1.0_dp, matrix_sum) !matrix_tmp = SPK CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_sp, matrix_k,& - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("N", "N", -2.0_dp, matrix_sp, matrix_tmp,& - 1.0_dp, matrix_sum, error=error) + 1.0_dp, matrix_sum) ! overwrite matrix_k - CALL cp_dbcsr_copy(matrix_k, matrix_sum, name="K from reverse McWeeny", error=error) + CALL cp_dbcsr_copy(matrix_k, matrix_sum, name="K from reverse McWeeny") ! clean up - CALL cp_dbcsr_release(matrix_sum,error) - CALL cp_dbcsr_release(matrix_tmp,error) - CALL cp_dbcsr_release(matrix_ps,error) - CALL cp_dbcsr_release(matrix_sp,error) + CALL cp_dbcsr_release(matrix_sum) + CALL cp_dbcsr_release(matrix_tmp) + CALL cp_dbcsr_release(matrix_ps) + CALL cp_dbcsr_release(matrix_sp) CALL timestop(handle) END SUBROUTINE reverse_mcweeny_step diff --git a/src/admm_dm_types.F b/src/admm_dm_types.F index cd51f67667..ae088eaaff 100644 --- a/src/admm_dm_types.F +++ b/src/admm_dm_types.F @@ -96,12 +96,10 @@ END SUBROUTINE admm_dm_create ! ***************************************************************************** !> \brief Release a admm_dm type !> \param admm_dm ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE admm_dm_release(admm_dm, error) + SUBROUTINE admm_dm_release(admm_dm) TYPE(admm_dm_type), POINTER :: admm_dm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'admm_dm_release', & routineP = moduleN//':'//routineN @@ -109,7 +107,7 @@ SUBROUTINE admm_dm_release(admm_dm, error) IF(.NOT. ASSOCIATED(admm_dm)) RETURN IF(ASSOCIATED(admm_dm%matrix_a)) THEN - CALL cp_dbcsr_release(admm_dm%matrix_a, error) + CALL cp_dbcsr_release(admm_dm%matrix_a) DEALLOCATE(admm_dm%matrix_a) ENDIF diff --git a/src/admm_methods.F b/src/admm_methods.F index cf1a7cefa0..7158f6eae7 100644 --- a/src/admm_methods.F +++ b/src/admm_methods.F @@ -100,11 +100,9 @@ MODULE admm_methods ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE admm_mo_calc_rho_aux(qs_env, error) + SUBROUTINE admm_mo_calc_rho_aux(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'admm_mo_calc_rho_aux', & routineP = moduleN//':'//routineN @@ -143,27 +141,25 @@ SUBROUTINE admm_mo_calc_rho_aux(qs_env, error) para_env=para_env,& s_mstruct_changed=s_mstruct_changed,& rho=rho,& - rho_aux_fit=rho_aux_fit,& - error=error) + rho_aux_fit=rho_aux_fit) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) CALL qs_rho_get(rho_aux_fit,& rho_ao=rho_ao_aux,& rho_g=rho_g_aux,& rho_r=rho_r_aux,& - tot_rho_r=tot_rho_r_aux,& - error=error) + tot_rho_r=tot_rho_r_aux) ! convert mos from full to dbcsr matrices DO ispin=1, dft_control%nspins IF(mos(ispin)%mo_set%use_mo_coeff_b) THEN - CALL copy_dbcsr_to_fm(mos(ispin)%mo_set%mo_coeff_b,mos(ispin)%mo_set%mo_coeff,error=error) + CALL copy_dbcsr_to_fm(mos(ispin)%mo_set%mo_coeff_b,mos(ispin)%mo_set%mo_coeff) ENDIF ENDDO ! fit mo coeffcients CALL admm_fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_aux_fit_vs_orb,& - mos, mos_aux_fit, s_mstruct_changed, error=error) + mos, mos_aux_fit, s_mstruct_changed) DO ispin=1,dft_control%nspins IF(admm_env%block_dm) THEN @@ -171,8 +167,7 @@ SUBROUTINE admm_mo_calc_rho_aux(qs_env, error) density_matrix=rho_ao(ispin)%matrix,& density_matrix_aux=rho_ao_aux(ispin)%matrix,& ispin=ispin,& - nspins=dft_control%nspins,& - error=error) + nspins=dft_control%nspins) ELSE @@ -183,8 +178,7 @@ SUBROUTINE admm_mo_calc_rho_aux(qs_env, error) density_matrix=rho_ao_aux(ispin)%matrix,& overlap_matrix_large=matrix_s(1)%matrix,& density_matrix_large=rho_ao(ispin)%matrix,& - ispin=ispin,& - error=error) + ispin=ispin) ENDIF @@ -195,8 +189,7 @@ SUBROUTINE admm_mo_calc_rho_aux(qs_env, error) mo_set=mos_aux_fit(ispin)%mo_set,& density_matrix=rho_ao_aux(ispin)%matrix,& ispin=ispin,& - blocked=admm_env%block_dm,& - error=error) + blocked=admm_env%block_dm) CALL calculate_rho_elec(ks_env=ks_env,& matrix_p=rho_ao_aux(ispin)%matrix,& @@ -204,8 +197,7 @@ SUBROUTINE admm_mo_calc_rho_aux(qs_env, error) rho_gspace=rho_g_aux(ispin),& total_rho=tot_rho_r_aux(ispin),& soft_valid=.FALSE.,& - basis_type="AUX_FIT",& - error=error) + basis_type="AUX_FIT") END DO IF(dft_control%nspins==1 ) THEN @@ -214,7 +206,7 @@ SUBROUTINE admm_mo_calc_rho_aux(qs_env, error) admm_env%gsi(3) = (admm_env%gsi(1)+admm_env%gsi(2))/2.0_dp END IF - CALL qs_rho_set(rho_aux_fit, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_aux_fit, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) CALL timestop(handle) @@ -223,11 +215,9 @@ END SUBROUTINE admm_mo_calc_rho_aux ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE admm_mo_merge_ks_matrix(qs_env, error) + SUBROUTINE admm_mo_merge_ks_matrix(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'admm_mo_merge_ks_matrix', & routineP = moduleN//':'//routineN @@ -238,17 +228,17 @@ SUBROUTINE admm_mo_merge_ks_matrix(qs_env, error) CALL timeset(routineN,handle) NULLIFY(admm_env) - CALL get_qs_env(qs_env, admm_env=admm_env, error=error) + CALL get_qs_env(qs_env, admm_env=admm_env) SELECT CASE(admm_env%purification_method) CASE(do_admm_purify_cauchy) - CALL merge_ks_matrix_cauchy(qs_env, error) + CALL merge_ks_matrix_cauchy(qs_env) CASE(do_admm_purify_cauchy_subspace) - CALL merge_ks_matrix_cauchy_subspace(qs_env, error) + CALL merge_ks_matrix_cauchy_subspace(qs_env) CASE(do_admm_purify_none) - CALL merge_ks_matrix_none(qs_env, error) + CALL merge_ks_matrix_none(qs_env) CASE(do_admm_purify_mo_diag, do_admm_purify_mo_no_diag) !do nothing @@ -270,10 +260,9 @@ END SUBROUTINE admm_mo_merge_ks_matrix !> \param mo_derivs ... !> \param mo_derivs_aux_fit ... !> \param matrix_ks_aux_fit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE admm_mo_merge_derivs(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_fit, mo_derivs, & - mo_derivs_aux_fit, matrix_ks_aux_fit, error) + mo_derivs_aux_fit, matrix_ks_aux_fit) INTEGER, INTENT(IN) :: ispin TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_type), POINTER :: mo_set @@ -282,7 +271,6 @@ SUBROUTINE admm_mo_merge_derivs(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ POINTER :: mo_derivs, mo_derivs_aux_fit TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks_aux_fit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'admm_mo_merge_derivs', & routineP = moduleN//':'//routineN @@ -294,10 +282,10 @@ SUBROUTINE admm_mo_merge_derivs(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ SELECT CASE(admm_env%purification_method) CASE(do_admm_purify_mo_diag) CALL merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_fit,& - mo_derivs,mo_derivs_aux_fit, matrix_ks_aux_fit, error) + mo_derivs,mo_derivs_aux_fit, matrix_ks_aux_fit) CASE(do_admm_purify_mo_no_diag) - CALL merge_mo_derivs_no_diag(ispin, admm_env, mo_set, mo_derivs, matrix_ks_aux_fit, error) + CALL merge_mo_derivs_no_diag(ispin, admm_env, mo_set, mo_derivs, matrix_ks_aux_fit) CASE(do_admm_purify_none, do_admm_purify_cauchy,do_admm_purify_cauchy_subspace) !do nothing @@ -318,10 +306,9 @@ END SUBROUTINE admm_mo_merge_derivs !> \param mos ... !> \param mos_aux_fit ... !> \param geometry_did_change ... -!> \param error ... ! ***************************************************************************** SUBROUTINE admm_fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & - mos, mos_aux_fit, geometry_did_change, error) + mos, mos_aux_fit, geometry_did_change) TYPE(admm_type), POINTER :: admm_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -330,7 +317,6 @@ SUBROUTINE admm_fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos, mos_aux_fit LOGICAL, INTENT(IN) :: geometry_did_change - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'admm_fit_mo_coeffs', & routineP = moduleN//':'//routineN @@ -341,17 +327,17 @@ SUBROUTINE admm_fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & CALL fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & mos, geometry_did_change,& - blocked=admm_env%block_fit, error=error) + blocked=admm_env%block_fit) SELECT CASE(admm_env%purification_method) CASE(do_admm_purify_mo_no_diag, do_admm_purify_cauchy_subspace) - CALL purify_mo_cholesky(admm_env, mos, mos_aux_fit, error) + CALL purify_mo_cholesky(admm_env, mos, mos_aux_fit) CASE(do_admm_purify_mo_diag) - CALL purify_mo_diag(admm_env, mos, mos_aux_fit, error) + CALL purify_mo_diag(admm_env, mos, mos_aux_fit) CASE DEFAULT - CALL purify_mo_none(admm_env, mos, mos_aux_fit, error) + CALL purify_mo_none(admm_env, mos, mos_aux_fit) END SELECT CALL timestop(handle) @@ -367,10 +353,9 @@ END SUBROUTINE admm_fit_mo_coeffs !> \param mos ... !> \param geometry_did_change ... !> \param blocked ... -!> \param error ... ! ***************************************************************************** SUBROUTINE fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & - mos, geometry_did_change, blocked, error) + mos, geometry_did_change, blocked) TYPE(admm_type), POINTER :: admm_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_s_aux_fit, & @@ -378,7 +363,6 @@ SUBROUTINE fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos LOGICAL, INTENT(IN) :: geometry_did_change, blocked - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fit_mo_coeffs', & routineP = moduleN//':'//routineN @@ -400,20 +384,19 @@ SUBROUTINE fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & IF( geometry_did_change ) THEN IF(.NOT. blocked) THEN - CALL copy_dbcsr_to_fm(matrix_s_aux_fit(1)%matrix,admm_env%S_inv,error) + CALL copy_dbcsr_to_fm(matrix_s_aux_fit(1)%matrix,admm_env%S_inv) ELSE NULLIFY(matrix_s_tilde) ALLOCATE(matrix_s_tilde) - CALL cp_dbcsr_init (matrix_s_tilde, error) + CALL cp_dbcsr_init (matrix_s_tilde) CALL cp_dbcsr_create(matrix_s_tilde, 'MATRIX s_tilde', & cp_dbcsr_distribution(matrix_s_aux_fit(1)%matrix), dbcsr_type_symmetric, & cp_dbcsr_row_block_sizes(matrix_s_aux_fit(1)%matrix),& cp_dbcsr_col_block_sizes(matrix_s_aux_fit(1)%matrix), & cp_dbcsr_get_data_size(matrix_s_aux_fit(1)%matrix),& - cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix), & - error=error) + cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix)) - CALL cp_dbcsr_copy(matrix_s_tilde, matrix_s_aux_fit(1)%matrix, error=error) + CALL cp_dbcsr_copy(matrix_s_tilde, matrix_s_aux_fit(1)%matrix) CALL cp_dbcsr_iterator_start(iter, matrix_s_tilde) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) @@ -423,34 +406,34 @@ SUBROUTINE fit_mo_coeffs(admm_env, matrix_s_aux_fit, matrix_s_mixed, & END IF END DO CALL cp_dbcsr_iterator_stop(iter) - CALL copy_dbcsr_to_fm(matrix_s_tilde,admm_env%S_inv,error) - CALL cp_dbcsr_deallocate_matrix(matrix_s_tilde,error) + CALL copy_dbcsr_to_fm(matrix_s_tilde,admm_env%S_inv) + CALL cp_dbcsr_deallocate_matrix(matrix_s_tilde) ENDIF - CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux,error=error) - CALL cp_fm_to_fm(admm_env%S_inv, admm_env%S, error=error) + CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux) + CALL cp_fm_to_fm(admm_env%S_inv, admm_env%S) - CALL copy_dbcsr_to_fm(matrix_s_mixed(1)%matrix,admm_env%Q,error) + CALL copy_dbcsr_to_fm(matrix_s_mixed(1)%matrix,admm_env%Q) !! Calculate S'_inverse - CALL cp_fm_cholesky_decompose(admm_env%S_inv,error=error) - CALL cp_fm_cholesky_invert(admm_env%S_inv,error=error) + CALL cp_fm_cholesky_decompose(admm_env%S_inv) + CALL cp_fm_cholesky_invert(admm_env%S_inv) !! Symmetrize the guy - CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux,error=error) + CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux) !! Calculate A=S'^(-1)*Q IF(blocked) THEN - CALL cp_fm_set_all(admm_env%A, 0.0_dp, 1.0_dp, error) + CALL cp_fm_set_all(admm_env%A, 0.0_dp, 1.0_dp) ELSE CALL cp_gemm('N','N',nao_aux_fit,nao_orb,nao_aux_fit,& 1.0_dp,admm_env%S_inv,admm_env%Q,0.0_dp,& - admm_env%A,error) + admm_env%A) ! this multiplication is apparent not need for purify_none !! B=Q^(T)*A CALL cp_gemm('T','N',nao_orb,nao_orb,nao_aux_fit,& 1.0_dp,admm_env%Q,admm_env%A,0.0_dp,& - admm_env%B,error) + admm_env%B) ENDIF END IF @@ -466,17 +449,15 @@ END SUBROUTINE fit_mo_coeffs !> \param admm_env The ADMM env !> \param mos the MO's of the orbital basis set !> \param mos_aux_fit the MO's of the auxiliary fitting basis set -!> \param error ... !> \par History !> 05.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE purify_mo_cholesky(admm_env, mos, mos_aux_fit, error) + SUBROUTINE purify_mo_cholesky(admm_env, mos, mos_aux_fit) TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos, mos_aux_fit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'purify_mo_cholesky', & routineP = moduleN//':'//routineN @@ -500,26 +481,26 @@ SUBROUTINE purify_mo_cholesky(admm_env, mos, mos_aux_fit, error) CALL get_mo_set(mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) CALL cp_gemm('N','N',nao_orb,nmo,nao_orb,& 1.0_dp,admm_env%B,mo_coeff,0.0_dp,& - admm_env%work_orb_nmo(ispin)%matrix,error) + admm_env%work_orb_nmo(ispin)%matrix) CALL cp_gemm('T','N',nmo,nmo,nao_orb,& 1.0_dp,mo_coeff,admm_env%work_orb_nmo(ispin)%matrix,0.0_dp,& - admm_env%lambda(ispin)%matrix,error) - CALL cp_fm_to_fm(admm_env%lambda(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix, error=error) + admm_env%lambda(ispin)%matrix) + CALL cp_fm_to_fm(admm_env%lambda(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix) - CALL cp_fm_cholesky_decompose(admm_env%work_nmo_nmo1(ispin)%matrix,error=error) - CALL cp_fm_cholesky_invert(admm_env%work_nmo_nmo1(ispin)%matrix,error=error) + CALL cp_fm_cholesky_decompose(admm_env%work_nmo_nmo1(ispin)%matrix) + CALL cp_fm_cholesky_invert(admm_env%work_nmo_nmo1(ispin)%matrix) !! Symmetrize the guy - CALL cp_fm_upper_to_full(admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%lambda_inv(ispin)%matrix,error=error) - CALL cp_fm_to_fm(admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%lambda_inv(ispin)%matrix,error=error) + CALL cp_fm_upper_to_full(admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%lambda_inv(ispin)%matrix) + CALL cp_fm_to_fm(admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%lambda_inv(ispin)%matrix) !! ** C_hat = AC CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nao_orb,& 1.0_dp,admm_env%A,mo_coeff,0.0_dp,& - admm_env%C_hat(ispin)%matrix,error) - CALL cp_fm_to_fm(admm_env%C_hat(ispin)%matrix, mo_coeff_aux_fit, error=error) + admm_env%C_hat(ispin)%matrix) + CALL cp_fm_to_fm(admm_env%C_hat(ispin)%matrix, mo_coeff_aux_fit) END DO @@ -535,17 +516,15 @@ END SUBROUTINE purify_mo_cholesky !> \param admm_env The ADMM env !> \param mos the MO's of the orbital basis set !> \param mos_aux_fit the MO's of the auxiliary fitting basis set -!> \param error ... !> \par History !> 05.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE purify_mo_diag(admm_env, mos, mos_aux_fit, error) + SUBROUTINE purify_mo_diag(admm_env, mos, mos_aux_fit) TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos, mos_aux_fit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'purify_mo_diag', & routineP = moduleN//':'//routineN @@ -571,33 +550,33 @@ SUBROUTINE purify_mo_diag(admm_env, mos, mos_aux_fit, error) CALL get_mo_set(mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) CALL cp_gemm('N','N',nao_orb,nmo,nao_orb,& 1.0_dp,admm_env%B,mo_coeff,0.0_dp,& - admm_env%work_orb_nmo(ispin)%matrix,error) + admm_env%work_orb_nmo(ispin)%matrix) CALL cp_gemm('T','N',nmo,nmo,nao_orb,& 1.0_dp,mo_coeff,admm_env%work_orb_nmo(ispin)%matrix,0.0_dp,& - admm_env%lambda(ispin)%matrix,error) - CALL cp_fm_to_fm(admm_env%lambda(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix, error=error) + admm_env%lambda(ispin)%matrix) + CALL cp_fm_to_fm(admm_env%lambda(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix) CALL cp_fm_syevd(admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%R(ispin)%matrix,& - admm_env%eigvals_lambda(ispin)%eigvals%data,error=error) + admm_env%eigvals_lambda(ispin)%eigvals%data) ALLOCATE(eig_work(nmo)) DO i=1,nmo eig_work(i) = 1.0_dp/SQRT(admm_env%eigvals_lambda(ispin)%eigvals%data(i)) END DO - CALL cp_fm_to_fm(admm_env%R(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix, error=error) + CALL cp_fm_to_fm(admm_env%R(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix) CALL cp_fm_column_scale(admm_env%work_nmo_nmo1(ispin)%matrix,eig_work) CALL cp_gemm('N','T',nmo,nmo,nmo,& 1.0_dp,admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%R(ispin)%matrix,0.0_dp,& - admm_env%lambda_inv_sqrt(ispin)%matrix,error) + admm_env%lambda_inv_sqrt(ispin)%matrix) CALL cp_gemm('N','N',nao_orb,nmo,nmo,& 1.0_dp,mo_coeff,admm_env%lambda_inv_sqrt(ispin)%matrix,0.0_dp,& - admm_env%work_orb_nmo(ispin)%matrix,error) + admm_env%work_orb_nmo(ispin)%matrix) CALL cp_gemm('N','N',nao_aux_fit,nmo,nao_orb,& 1.0_dp,admm_env%A,admm_env%work_orb_nmo(ispin)%matrix, 0.0_dp,& - mo_coeff_aux_fit,error) + mo_coeff_aux_fit) - CALL cp_fm_to_fm(mo_coeff_aux_fit, admm_env%C_hat(ispin)%matrix, error=error) - CALL cp_fm_set_all(admm_env%lambda_inv(ispin)%matrix,0.0_dp,1.0_dp,error) + CALL cp_fm_to_fm(mo_coeff_aux_fit, admm_env%C_hat(ispin)%matrix) + CALL cp_fm_set_all(admm_env%lambda_inv(ispin)%matrix,0.0_dp,1.0_dp) DEALLOCATE(eig_work) END DO @@ -611,13 +590,11 @@ END SUBROUTINE purify_mo_diag !> \param admm_env ... !> \param mos ... !> \param mos_aux_fit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE purify_mo_none(admm_env, mos, mos_aux_fit, error) + SUBROUTINE purify_mo_none(admm_env, mos, mos_aux_fit) TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos, mos_aux_fit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'purify_mo_none', & routineP = moduleN//':'//routineN @@ -641,14 +618,14 @@ SUBROUTINE purify_mo_none(admm_env, mos, mos_aux_fit, error) CALL cp_gemm('N','N',nao_aux_fit,nmo,nao_orb,& 1.0_dp,admm_env%A,mo_coeff,0.0_dp,& - mo_coeff_aux_fit,error) - CALL cp_fm_to_fm(mo_coeff_aux_fit, admm_env%C_hat(ispin)%matrix, error=error) + mo_coeff_aux_fit) + CALL cp_fm_to_fm(mo_coeff_aux_fit, admm_env%C_hat(ispin)%matrix) occ_num_aux(1:nmo) = occ_num(1:nmo) ! XXXX should only be done first time XXXX - CALL cp_fm_set_all(admm_env%lambda(ispin)%matrix,0.0_dp,1.0_dp,error) - CALL cp_fm_set_all(admm_env%lambda_inv(ispin)%matrix,0.0_dp,1.0_dp,error) - CALL cp_fm_set_all(admm_env%lambda_inv_sqrt(ispin)%matrix,0.0_dp,1.0_dp,error) + CALL cp_fm_set_all(admm_env%lambda(ispin)%matrix,0.0_dp,1.0_dp) + CALL cp_fm_set_all(admm_env%lambda_inv(ispin)%matrix,0.0_dp,1.0_dp) + CALL cp_fm_set_all(admm_env%lambda_inv_sqrt(ispin)%matrix,0.0_dp,1.0_dp) END DO CALL timestop(handle) @@ -663,16 +640,14 @@ END SUBROUTINE purify_mo_none !> \param density_matrix ... !> \param ispin ... !> \param blocked ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE purify_dm_cauchy(admm_env,mo_set,density_matrix,ispin,blocked,error) + SUBROUTINE purify_dm_cauchy(admm_env,mo_set,density_matrix,ispin,blocked) TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_dbcsr_type), POINTER :: density_matrix INTEGER :: ispin LOGICAL, INTENT(IN) :: blocked - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'purify_dm_cauchy', & routineP = moduleN//':'//routineN @@ -698,53 +673,53 @@ SUBROUTINE purify_dm_cauchy(admm_env,mo_set,density_matrix,ispin,blocked,error) IF(.NOT. blocked) THEN CALL cp_gemm('N','T',nao_aux_fit,nao_aux_fit,nmo,& 1.0_dp,mo_coeff_aux_fit,mo_coeff_aux_fit,0.0_dp,& - admm_env%P_to_be_purified(ispin)%matrix,error) + admm_env%P_to_be_purified(ispin)%matrix) ENDIF - CALL cp_fm_to_fm(admm_env%S, admm_env%work_aux_aux, error=error) - CALL cp_fm_to_fm(admm_env%P_to_be_purified(ispin)%matrix, admm_env%work_aux_aux2, error=error) + CALL cp_fm_to_fm(admm_env%S, admm_env%work_aux_aux) + CALL cp_fm_to_fm(admm_env%P_to_be_purified(ispin)%matrix, admm_env%work_aux_aux2) - CALL cp_fm_cholesky_decompose(admm_env%work_aux_aux,error=error) + CALL cp_fm_cholesky_decompose(admm_env%work_aux_aux) - CALL cp_fm_cholesky_reduce(admm_env%work_aux_aux2, admm_env%work_aux_aux, itype=3, error=error) + CALL cp_fm_cholesky_reduce(admm_env%work_aux_aux2, admm_env%work_aux_aux, itype=3) CALL cp_fm_syevd(admm_env%work_aux_aux2,admm_env%R_purify(ispin)%matrix,& - admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data,error=error) + admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data) CALL cp_fm_cholesky_restore(admm_env%R_purify(ispin)%matrix, nao_aux_fit,admm_env%work_aux_aux, & - admm_env%work_aux_aux3,op="MULTIPLY",pos="LEFT", transa="T", error=error) + admm_env%work_aux_aux3,op="MULTIPLY",pos="LEFT", transa="T") - CALL cp_fm_to_fm(admm_env%work_aux_aux3, admm_env%R_purify(ispin)%matrix, error=error) + CALL cp_fm_to_fm(admm_env%work_aux_aux3, admm_env%R_purify(ispin)%matrix) ! *** Construct Matrix M for Hadamard Product - CALL cp_fm_set_all(admm_env%M_purify(ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(admm_env%M_purify(ispin)%matrix,0.0_dp) pole = 0.0_dp DO i=1,nao_aux_fit pole = Heaviside(admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data(i)-0.5_dp) - CALL cp_fm_set_element(admm_env%M_purify(ispin)%matrix,i,i,pole,error) + CALL cp_fm_set_element(admm_env%M_purify(ispin)%matrix,i,i,pole) END DO - CALL cp_fm_upper_to_full(admm_env%M_purify(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL cp_fm_upper_to_full(admm_env%M_purify(ispin)%matrix,admm_env%work_aux_aux) - CALL copy_dbcsr_to_fm(density_matrix,admm_env%work_aux_aux3,error) - CALL cp_fm_upper_to_full(admm_env%work_aux_aux3,admm_env%work_aux_aux,error=error) + CALL copy_dbcsr_to_fm(density_matrix,admm_env%work_aux_aux3) + CALL cp_fm_upper_to_full(admm_env%work_aux_aux3,admm_env%work_aux_aux) ! ** S^(-1)*R CALL cp_gemm('N','N',nao_aux_fit,nao_aux_fit,nao_aux_fit,& 1.0_dp,admm_env%S_inv,admm_env%R_purify(ispin)%matrix,0.0_dp,& - admm_env%work_aux_aux,error) + admm_env%work_aux_aux) ! ** S^(-1)*R*M CALL cp_gemm('N','N',nao_aux_fit,nao_aux_fit,nao_aux_fit,& 1.0_dp,admm_env%work_aux_aux,admm_env%M_purify(ispin)%matrix,0.0_dp,& - admm_env%work_aux_aux2,error) + admm_env%work_aux_aux2) ! ** S^(-1)*R*M*R^T*S^(-1) CALL cp_gemm('N','T',nao_aux_fit,nao_aux_fit,nao_aux_fit,& 1.0_dp,admm_env%work_aux_aux2,admm_env%work_aux_aux,0.0_dp,& - admm_env%work_aux_aux3,error) + admm_env%work_aux_aux3) - CALL copy_fm_to_dbcsr(admm_env%work_aux_aux3, density_matrix,keep_sparsity=.TRUE., error=error) + CALL copy_fm_to_dbcsr(admm_env%work_aux_aux3, density_matrix,keep_sparsity=.TRUE.) IF( nspins == 1 ) THEN - CALL cp_dbcsr_scale(density_matrix, 2.0_dp, error=error) + CALL cp_dbcsr_scale(density_matrix, 2.0_dp) END IF CALL timestop(handle) @@ -755,11 +730,9 @@ END SUBROUTINE purify_dm_cauchy ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE merge_ks_matrix_cauchy(qs_env, error) + SUBROUTINE merge_ks_matrix_cauchy(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'merge_ks_matrix_cauchy', & routineP = moduleN//':'//routineN @@ -787,8 +760,7 @@ SUBROUTINE merge_ks_matrix_cauchy(qs_env, error) dft_control=dft_control,& matrix_ks=matrix_ks,& matrix_ks_aux_fit=matrix_ks_aux_fit,& - mos=mos,& - error=error) + mos=mos) DO ispin=1, dft_control%nspins nao_aux_fit = admm_env%nao_aux_fit @@ -800,33 +772,33 @@ SUBROUTINE merge_ks_matrix_cauchy(qs_env, error) !** Get P from mo_coeffs, otherwise we have troubles with occupation numbers ... CALL cp_gemm('N', 'T', nao_orb, nao_orb, nmo,& 1.0_dp, mo_coeff, mo_coeff, 0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) !! A*P CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_orb,& 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp,& - admm_env%work_aux_orb2,error) + admm_env%work_aux_orb2) !! A*P*A^T CALL cp_gemm('N', 'T', nao_aux_fit, nao_aux_fit, nao_orb,& 1.0_dp, admm_env%work_aux_orb2, admm_env%A, 0.0_dp,& - admm_env%P_to_be_purified(ispin)%matrix,error) + admm_env%P_to_be_purified(ispin)%matrix) ENDIF - CALL cp_fm_to_fm(admm_env%S, admm_env%work_aux_aux, error=error) - CALL cp_fm_to_fm(admm_env%P_to_be_purified(ispin)%matrix, admm_env%work_aux_aux2, error=error) + CALL cp_fm_to_fm(admm_env%S, admm_env%work_aux_aux) + CALL cp_fm_to_fm(admm_env%P_to_be_purified(ispin)%matrix, admm_env%work_aux_aux2) - CALL cp_fm_cholesky_decompose(admm_env%work_aux_aux,error=error) + CALL cp_fm_cholesky_decompose(admm_env%work_aux_aux) - CALL cp_fm_cholesky_reduce(admm_env%work_aux_aux2, admm_env%work_aux_aux, itype=3, error=error) + CALL cp_fm_cholesky_reduce(admm_env%work_aux_aux2, admm_env%work_aux_aux, itype=3) CALL cp_fm_syevd(admm_env%work_aux_aux2,admm_env%R_purify(ispin)%matrix,& - admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data,error=error) + admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data) CALL cp_fm_cholesky_restore(admm_env%R_purify(ispin)%matrix, nao_aux_fit,admm_env%work_aux_aux, & - admm_env%work_aux_aux3,op="MULTIPLY",pos="LEFT", transa="T", error=error) + admm_env%work_aux_aux3,op="MULTIPLY",pos="LEFT", transa="T") - CALL cp_fm_to_fm(admm_env%work_aux_aux3, admm_env%R_purify(ispin)%matrix, error=error) + CALL cp_fm_to_fm(admm_env%work_aux_aux3, admm_env%R_purify(ispin)%matrix) ! *** Construct Matrix M for Hadamard Product pole = 0.0_dp @@ -837,68 +809,68 @@ SUBROUTINE merge_ks_matrix_cauchy(qs_env, error) ! *** two eigenvalues could be the degenerated. In that case use 2nd order formula for the poles IF( ABS(eig_diff) == 0.0_dp ) THEN pole = delta(admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data(i)-0.5_dp) - CALL cp_fm_set_element(admm_env%M_purify(ispin)%matrix,i,j,pole,error) + CALL cp_fm_set_element(admm_env%M_purify(ispin)%matrix,i,j,pole) ELSE pole = 1.0_dp/(admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data(i)-& admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data(j)) tmp = Heaviside(admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data(i)-0.5_dp) tmp = tmp - Heaviside(admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data(j)-0.5_dp) pole = tmp*pole - CALL cp_fm_set_element(admm_env%M_purify(ispin)%matrix,i,j,pole,error) + CALL cp_fm_set_element(admm_env%M_purify(ispin)%matrix,i,j,pole) END IF END DO END DO - CALL cp_fm_upper_to_full(admm_env%M_purify(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL cp_fm_upper_to_full(admm_env%M_purify(ispin)%matrix,admm_env%work_aux_aux) - CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix,error) - CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix) + CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux) !! S^(-1)*R CALL cp_gemm('N', 'N', nao_aux_fit, nao_aux_fit, nao_aux_fit,& 1.0_dp,admm_env%S_inv,admm_env%R_purify(ispin)%matrix,0.0_dp,& - admm_env%work_aux_aux,error) + admm_env%work_aux_aux) !! K*S^(-1)*R CALL cp_gemm('N', 'N', nao_aux_fit, nao_aux_fit, nao_aux_fit,& 1.0_dp,admm_env%K(ispin)%matrix,admm_env%work_aux_aux,0.0_dp,& - admm_env%work_aux_aux2,error) + admm_env%work_aux_aux2) !! R^T*S^(-1)*K*S^(-1)*R CALL cp_gemm('T', 'N', nao_aux_fit, nao_aux_fit, nao_aux_fit,& 1.0_dp,admm_env%work_aux_aux,admm_env%work_aux_aux2,0.0_dp,& - admm_env%work_aux_aux3,error) + admm_env%work_aux_aux3) !! R^T*S^(-1)*K*S^(-1)*R x M CALL cp_fm_schur_product(admm_env%work_aux_aux3, admm_env%M_purify(ispin)%matrix,& - admm_env%work_aux_aux,error) + admm_env%work_aux_aux) !! R^T*A CALL cp_gemm('T', 'N', nao_aux_fit, nao_orb, nao_aux_fit,& 1.0_dp, admm_env%R_purify(ispin)%matrix, admm_env%A, 0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) !! (R^T*S^(-1)*K*S^(-1)*R x M) * R^T*A CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_aux_fit,& 1.0_dp, admm_env%work_aux_aux, admm_env%work_aux_orb, 0.0_dp,& - admm_env%work_aux_orb2,error) + admm_env%work_aux_orb2) !! A^T*R*(R^T*S^(-1)*K*S^(-1)*R x M) * R^T*A CALL cp_gemm('T', 'N', nao_orb, nao_orb, nao_aux_fit,& 1.0_dp, admm_env%work_aux_orb, admm_env%work_aux_orb2, 0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) NULLIFY(matrix_k_tilde) ALLOCATE(matrix_k_tilde) - CALL cp_dbcsr_init (matrix_k_tilde, error) + CALL cp_dbcsr_init (matrix_k_tilde) CALL cp_dbcsr_create(matrix_k_tilde, 'MATRIX K_tilde', & cp_dbcsr_distribution(matrix_ks(ispin)%matrix), & dbcsr_type_symmetric,& cp_dbcsr_row_block_sizes(matrix_ks(ispin)%matrix),& cp_dbcsr_col_block_sizes(matrix_ks(ispin)%matrix),& cp_dbcsr_get_data_size( matrix_ks(ispin)%matrix),& - cp_dbcsr_get_data_type(matrix_ks(ispin)%matrix), error=error) + cp_dbcsr_get_data_type(matrix_ks(ispin)%matrix)) - CALL cp_fm_to_fm(admm_env%work_orb_orb, admm_env%ks_to_be_merged(ispin)%matrix, error=error) + CALL cp_fm_to_fm(admm_env%work_orb_orb, admm_env%ks_to_be_merged(ispin)%matrix) - CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE., error=error) + CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix) + CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE.) IF(admm_env%block_dm) THEN ! ** now loop through the list and nullify blocks @@ -912,9 +884,9 @@ SUBROUTINE merge_ks_matrix_cauchy(qs_env, error) CALL cp_dbcsr_iterator_stop(iter) ENDIF - CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp) - CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde,error) + CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde) END DO !spin-loop @@ -926,11 +898,9 @@ END SUBROUTINE merge_ks_matrix_cauchy ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE merge_ks_matrix_cauchy_subspace(qs_env, error) + SUBROUTINE merge_ks_matrix_cauchy_subspace(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'merge_ks_matrix_cauchy_subspace', & @@ -957,8 +927,7 @@ SUBROUTINE merge_ks_matrix_cauchy_subspace(qs_env, error) matrix_ks=matrix_ks,& matrix_ks_aux_fit=matrix_ks_aux_fit,& mos=mos,& - mos_aux_fit=mos_aux_fit,& - error=error) + mos_aux_fit=mos_aux_fit) DO ispin=1, dft_control%nspins nao_aux_fit = admm_env%nao_aux_fit @@ -968,106 +937,105 @@ SUBROUTINE merge_ks_matrix_cauchy_subspace(qs_env, error) CALL get_mo_set(mo_set=mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) !! Calculate Lambda^{-2} - CALL cp_fm_to_fm(admm_env%lambda(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix, error=error) - CALL cp_fm_cholesky_decompose(admm_env%work_nmo_nmo1(ispin)%matrix,error=error) - CALL cp_fm_cholesky_invert(admm_env%work_nmo_nmo1(ispin)%matrix,error=error) + CALL cp_fm_to_fm(admm_env%lambda(ispin)%matrix, admm_env%work_nmo_nmo1(ispin)%matrix) + CALL cp_fm_cholesky_decompose(admm_env%work_nmo_nmo1(ispin)%matrix) + CALL cp_fm_cholesky_invert(admm_env%work_nmo_nmo1(ispin)%matrix) !! Symmetrize the guy - CALL cp_fm_upper_to_full(admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%lambda_inv2(ispin)%matrix,error=error) + CALL cp_fm_upper_to_full(admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%lambda_inv2(ispin)%matrix) !! Take square CALL cp_gemm('N', 'T', nmo, nmo, nmo,& 1.0_dp,admm_env%work_nmo_nmo1(ispin)%matrix,admm_env%work_nmo_nmo1(ispin)%matrix,0.0_dp,& - admm_env%lambda_inv2(ispin)%matrix,error) + admm_env%lambda_inv2(ispin)%matrix) !! ** C_hat = AC CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nao_orb,& 1.0_dp,admm_env%A,mo_coeff,0.0_dp,& - admm_env%C_hat(ispin)%matrix,error) + admm_env%C_hat(ispin)%matrix) !! calc P_tilde from C_hat CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nmo,& 1.0_dp,admm_env%C_hat(ispin)%matrix,admm_env%lambda_inv(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) CALL cp_gemm('N', 'T', nao_aux_fit, nao_aux_fit, nmo,& 1.0_dp,admm_env%C_hat(ispin)%matrix, admm_env%work_aux_nmo(ispin)%matrix,0.0_dp,& - admm_env%P_tilde(ispin)%matrix,error) + admm_env%P_tilde(ispin)%matrix) !! ** C_hat*Lambda^{-2} CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nmo,& 1.0_dp,admm_env%C_hat(ispin)%matrix,admm_env%lambda_inv2(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) !! ** C_hat*Lambda^{-2}*C_hat^T CALL cp_gemm('N', 'T', nao_aux_fit, nao_aux_fit, nmo,& 1.0_dp,admm_env%work_aux_nmo(ispin)%matrix,admm_env%C_hat(ispin)%matrix,0.0_dp,& - admm_env%work_aux_aux,error) + admm_env%work_aux_aux) !! ** S*C_hat*Lambda^{-2}*C_hat^T CALL cp_gemm('N', 'N', nao_aux_fit, nao_aux_fit, nao_aux_fit,& 1.0_dp,admm_env%S,admm_env%work_aux_aux,0.0_dp,& - admm_env%work_aux_aux2,error) + admm_env%work_aux_aux2) - CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix,error) - CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix) + CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux) !! ** S*C_hat*Lambda^{-2}*C_hat^T*H_tilde CALL cp_gemm('N', 'N', nao_aux_fit, nao_aux_fit, nao_aux_fit,& 1.0_dp,admm_env%work_aux_aux2,admm_env%K(ispin)%matrix,0.0_dp,& - admm_env%work_aux_aux,error) + admm_env%work_aux_aux) !! ** P_tilde*S CALL cp_gemm('N', 'N', nao_aux_fit, nao_aux_fit, nao_aux_fit,& 1.0_dp,admm_env%P_tilde(ispin)%matrix,admm_env%S,0.0_dp,& - admm_env%work_aux_aux2,error) + admm_env%work_aux_aux2) !! ** -S*C_hat*Lambda^{-2}*C_hat^T*H_tilde*P_tilde*S CALL cp_gemm('N', 'N', nao_aux_fit, nao_aux_fit, nao_aux_fit,& -1.0_dp,admm_env%work_aux_aux,admm_env%work_aux_aux2,0.0_dp,& - admm_env%work_aux_aux3,error) + admm_env%work_aux_aux3) !! ** -S*C_hat*Lambda^{-2}*C_hat^T*H_tilde*P_tilde*S+S*C_hat*Lambda^{-2}*C_hat^T*H_tilde - CALL cp_fm_scale_and_add(1.0_dp,admm_env%work_aux_aux3,1.0_dp,admm_env%work_aux_aux,error) + CALL cp_fm_scale_and_add(1.0_dp,admm_env%work_aux_aux3,1.0_dp,admm_env%work_aux_aux) !! first_part*A CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%work_aux_aux3,admm_env%A,0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) !! + first_part^T*A CALL cp_gemm('T', 'N', nao_aux_fit, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%work_aux_aux3,admm_env%A,1.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) !! A^T*(first+seccond)=H CALL cp_gemm('T', 'N', nao_orb, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%A,admm_env%work_aux_orb,0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) NULLIFY(matrix_k_tilde) ALLOCATE(matrix_k_tilde) - CALL cp_dbcsr_init (matrix_k_tilde, error) + CALL cp_dbcsr_init (matrix_k_tilde) CALL cp_dbcsr_create(matrix_k_tilde, 'MATRIX K_tilde', & cp_dbcsr_distribution(matrix_ks(ispin)%matrix),& dbcsr_type_symmetric,& cp_dbcsr_row_block_sizes(matrix_ks(ispin)%matrix),& cp_dbcsr_col_block_sizes(matrix_ks(ispin)%matrix), & cp_dbcsr_get_data_size(matrix_ks(ispin)%matrix),& - cp_dbcsr_get_data_type(matrix_ks(ispin)%matrix), error=error) + cp_dbcsr_get_data_type(matrix_ks(ispin)%matrix)) - CALL cp_fm_to_fm(admm_env%work_orb_orb, admm_env%ks_to_be_merged(ispin)%matrix, error=error) + CALL cp_fm_to_fm(admm_env%work_orb_orb, admm_env%ks_to_be_merged(ispin)%matrix) - CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE.,& - error=error) + CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix) + CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE.) CALL cp_gemm('N', 'N', nao_orb, nmo, nao_orb,& 1.0_dp,admm_env%work_orb_orb,mo_coeff,0.0_dp,& - admm_env%mo_derivs_tmp(ispin)%matrix,error) + admm_env%mo_derivs_tmp(ispin)%matrix) - CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp) - CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde,error) + CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde) ENDDO !spin loop CALL timestop(handle) @@ -1089,14 +1057,12 @@ END SUBROUTINE merge_ks_matrix_cauchy_subspace !> auxiliary basis set part !> \param mo_derivs_aux_fit ... !> \param matrix_ks_aux_fit the Kohn-Sham matrix from the auxiliary fitting basis set -!> \param error ... -!> !> \par History !> 05.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_fit, mo_derivs, & - mo_derivs_aux_fit, matrix_ks_aux_fit, error) + mo_derivs_aux_fit, matrix_ks_aux_fit) INTEGER, INTENT(IN) :: ispin TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_type), POINTER :: mo_set @@ -1105,7 +1071,6 @@ SUBROUTINE merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ POINTER :: mo_derivs, mo_derivs_aux_fit TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks_aux_fit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'merge_mo_derivs_diag', & routineP = moduleN//':'//routineN @@ -1123,12 +1088,12 @@ SUBROUTINE merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ nao_orb = admm_env%nao_orb nmo = admm_env%nmo(ispin) - CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix,error) - CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix) + CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux) CALL cp_gemm('N','N', nao_aux_fit, nmo, nao_aux_fit,& 1.0_dp,admm_env%K(ispin)%matrix,mo_coeff_aux_fit,0.0_dp,& - admm_env%H(ispin)%matrix,error) + admm_env%H(ispin)%matrix) CALL get_mo_set(mo_set=mo_set, occupation_numbers=occupation_numbers) ALLOCATE(scaling_factor(SIZE(occupation_numbers))) @@ -1136,15 +1101,15 @@ SUBROUTINE merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ CALL cp_fm_column_scale(admm_env%H(ispin)%matrix,scaling_factor) - CALL cp_fm_to_fm(admm_env%H(ispin)%matrix, mo_derivs_aux_fit(ispin)%matrix, error=error) + CALL cp_fm_to_fm(admm_env%H(ispin)%matrix, mo_derivs_aux_fit(ispin)%matrix) ! *** Add first term CALL cp_gemm('N','T', nao_aux_fit, nmo, nmo,& 1.0_dp,admm_env%H(ispin)%matrix,admm_env%lambda_inv_sqrt(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) CALL cp_gemm('T','N', nao_orb, nmo, nao_aux_fit,& 1.0_dp,admm_env%A,admm_env%work_aux_nmo(ispin)%matrix,0.0_dp,& - admm_env%mo_derivs_tmp(ispin)%matrix,error) + admm_env%mo_derivs_tmp(ispin)%matrix) ! *** Construct Matrix M for Hadamard Product @@ -1161,17 +1126,17 @@ SUBROUTINE merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ tmp92 = tmp72/admm_env%eigvals_lambda(ispin)%eigvals%data(j)*eig_diff pole = -0.5_dp*tmp32 + 3.0_dp/8.0_dp*tmp52 - 5.0_dp/16.0_dp*tmp72 + 35.0_dp/128.0_dp*tmp92 - CALL cp_fm_set_element(admm_env%M(ispin)%matrix,i,j,pole,error) + CALL cp_fm_set_element(admm_env%M(ispin)%matrix,i,j,pole) ELSE pole = 1.0_dp/SQRT(admm_env%eigvals_lambda(ispin)%eigvals%data(i)) pole = pole - 1.0_dp/SQRT(admm_env%eigvals_lambda(ispin)%eigvals%data(j)) pole = pole/(admm_env%eigvals_lambda(ispin)%eigvals%data(i)-& admm_env%eigvals_lambda(ispin)%eigvals%data(j)) - CALL cp_fm_set_element(admm_env%M(ispin)%matrix,i,j,pole,error) + CALL cp_fm_set_element(admm_env%M(ispin)%matrix,i,j,pole) END IF END DO END DO - CALL cp_fm_upper_to_full(admm_env%M(ispin)%matrix,admm_env%work_nmo_nmo1(ispin)%matrix,error=error) + CALL cp_fm_upper_to_full(admm_env%M(ispin)%matrix,admm_env%work_nmo_nmo1(ispin)%matrix) ! *** 2nd term to be added to fm_H @@ -1181,48 +1146,48 @@ SUBROUTINE merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ ! *** H'*R CALL cp_gemm('N','N', nao_aux_fit, nmo, nmo,& 1.0_dp,admm_env%H(ispin)%matrix,admm_env%R(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) ! *** A^(T)*H'*R CALL cp_gemm('T','N', nao_orb, nmo, nao_aux_fit,& 1.0_dp,admm_env%A,admm_env%work_aux_nmo(ispin)%matrix,0.0_dp,& - admm_env%work_orb_nmo(ispin)%matrix,error) + admm_env%work_orb_nmo(ispin)%matrix) ! *** c^(T)*A^(T)*H'*R CALL cp_gemm('T','N', nmo, nmo, nao_orb,& 1.0_dp,mo_coeff,admm_env%work_orb_nmo(ispin)%matrix,0.0_dp,& - admm_env%work_nmo_nmo1(ispin)%matrix,error) + admm_env%work_nmo_nmo1(ispin)%matrix) ! *** R^(T)*c^(T)*A^(T)*H'*R CALL cp_gemm('T','N', nmo, nmo, nmo,& 1.0_dp,admm_env%R(ispin)%matrix,admm_env%work_nmo_nmo1(ispin)%matrix,0.0_dp,& - admm_env%work_nmo_nmo2(ispin)%matrix,error) + admm_env%work_nmo_nmo2(ispin)%matrix) ! *** R^(T)*c^(T)*A^(T)*H'*R x M CALL cp_fm_schur_product(admm_env%work_nmo_nmo2(ispin)%matrix,& - admm_env%M(ispin)%matrix,admm_env%work_nmo_nmo1(ispin)%matrix,error) + admm_env%M(ispin)%matrix,admm_env%work_nmo_nmo1(ispin)%matrix) ! *** R* (R^(T)*c^(T)*A^(T)*H'*R x M) CALL cp_gemm('N','N', nmo, nmo, nmo,& 1.0_dp,admm_env%R(ispin)%matrix,admm_env%work_nmo_nmo1(ispin)%matrix,0.0_dp,& - admm_env%work_nmo_nmo2(ispin)%matrix,error) + admm_env%work_nmo_nmo2(ispin)%matrix) ! *** R* (R^(T)*c^(T)*A^(T)*H'*R x M) *R^(T) CALL cp_gemm('N','T', nmo, nmo, nmo,& 1.0_dp,admm_env%work_nmo_nmo2(ispin)%matrix,admm_env%R(ispin)%matrix,0.0_dp,& - admm_env%R_schur_R_t(ispin)%matrix,error) + admm_env%R_schur_R_t(ispin)%matrix) ! *** B^(T)*c CALL cp_gemm('T','N', nao_orb, nmo, nao_orb,& 1.0_dp,admm_env%B,mo_coeff,0.0_dp,& - admm_env%work_orb_nmo(ispin)%matrix,error) + admm_env%work_orb_nmo(ispin)%matrix) ! *** Add first term to fm_H ! *** B^(T)*c* R* (R^(T)*c^(T)*A^(T)*H'*R x M) *R^(T) CALL cp_gemm('N','N', nao_orb, nmo, nmo,& 1.0_dp,admm_env%work_orb_nmo(ispin)%matrix,admm_env%R_schur_R_t(ispin)%matrix,1.0_dp,& - admm_env%mo_derivs_tmp(ispin)%matrix,error) + admm_env%mo_derivs_tmp(ispin)%matrix) ! *** Add second term to fm_H ! *** B*C *[ R* (R^(T)*c^(T)*A^(T)*H'*R x M) *R^(T)]^(T) CALL cp_gemm('N','T', nao_orb, nmo, nmo,& 1.0_dp,admm_env%work_orb_nmo(ispin)%matrix,admm_env%R_schur_R_t(ispin)%matrix,1.0_dp,& - admm_env%mo_derivs_tmp(ispin)%matrix,error) + admm_env%mo_derivs_tmp(ispin)%matrix) DO i = 1,SIZE(scaling_factor) scaling_factor(i) = 1.0_dp/scaling_factor(i) @@ -1230,7 +1195,7 @@ SUBROUTINE merge_mo_derivs_diag(ispin, admm_env, mo_set, mo_coeff, mo_coeff_aux_ CALL cp_fm_column_scale(admm_env%mo_derivs_tmp(ispin)%matrix,scaling_factor) - CALL cp_fm_scale_and_add(1.0_dp,mo_derivs(ispin)%matrix,1.0_dp,admm_env%mo_derivs_tmp(ispin)%matrix,error) + CALL cp_fm_scale_and_add(1.0_dp,mo_derivs(ispin)%matrix,1.0_dp,admm_env%mo_derivs_tmp(ispin)%matrix) DEALLOCATE(scaling_factor) @@ -1242,11 +1207,9 @@ END SUBROUTINE merge_mo_derivs_diag ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE merge_ks_matrix_none(qs_env, error) + SUBROUTINE merge_ks_matrix_none(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'merge_ks_matrix_none', & routineP = moduleN//':'//routineN @@ -1290,13 +1253,11 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) matrix_s=matrix_s,& matrix_s_aux_fit=matrix_s_aux_fit,& energy=energy,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) CALL qs_rho_get(rho_aux_fit,& - rho_ao=rho_ao_aux,& - error=error) + rho_ao=rho_ao_aux) DO ispin=1, dft_control%nspins @@ -1309,7 +1270,7 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) END IF END DO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_aux_fit(ispin)%matrix, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_ks_aux_fit(ispin)%matrix, 1.0_dp, 1.0_dp) ELSE @@ -1322,54 +1283,53 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) (admm_env%scaling_model == do_admm_exch_scaling_merlot ) ) THEN NULLIFY(matrix_ks_aux_fit_admms_tmp) ALLOCATE(matrix_ks_aux_fit_admms_tmp) - CALL cp_dbcsr_init (matrix_ks_aux_fit_admms_tmp, error) + CALL cp_dbcsr_init (matrix_ks_aux_fit_admms_tmp) CALL cp_dbcsr_create(matrix_ks_aux_fit_admms_tmp,template=matrix_ks_aux_fit(ispin)%matrix,& - name='matrix_ks_aux_fit_admms_tmp', matrix_type='s', error=error) + name='matrix_ks_aux_fit_admms_tmp', matrix_type='s') ! matrix_ks_aux_fit_admms_tmp = k(d_Q) - CALL cp_dbcsr_copy(matrix_ks_aux_fit_admms_tmp, matrix_ks_aux_fit_hfx(ispin)%matrix, error=error) + CALL cp_dbcsr_copy(matrix_ks_aux_fit_admms_tmp, matrix_ks_aux_fit_hfx(ispin)%matrix) ! matrix_ks_aux_fit_admms_tmp = k(d_Q) - gsi^2/3 x(d_Q) CALL cp_dbcsr_add(matrix_ks_aux_fit_admms_tmp, matrix_ks_aux_fit_dft(ispin)%matrix, & - 1.0_dp, -(admm_env%gsi(ispin))**(2.0_dp/3.0_dp), error) - CALL copy_dbcsr_to_fm(matrix_ks_aux_fit_admms_tmp,admm_env%K(ispin)%matrix,error) - CALL cp_dbcsr_deallocate_matrix(matrix_ks_aux_fit_admms_tmp,error) + 1.0_dp, -(admm_env%gsi(ispin))**(2.0_dp/3.0_dp)) + CALL copy_dbcsr_to_fm(matrix_ks_aux_fit_admms_tmp,admm_env%K(ispin)%matrix) + CALL cp_dbcsr_deallocate_matrix(matrix_ks_aux_fit_admms_tmp) ELSE - CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix,error) + CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix) END IF - CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux) !! K*A CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%K(ispin)%matrix,admm_env%A,0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) !! A^T*K*A CALL cp_gemm('T', 'N', nao_orb, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%A,admm_env%work_aux_orb,0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) NULLIFY(matrix_k_tilde) ALLOCATE(matrix_k_tilde) - CALL cp_dbcsr_init (matrix_k_tilde, error) + CALL cp_dbcsr_init (matrix_k_tilde) CALL cp_dbcsr_create(matrix_k_tilde,template=matrix_ks(ispin)%matrix,& - name='MATRIX K_tilde', matrix_type='S', error=error) - CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE.,& - error=error) + name='MATRIX K_tilde', matrix_type='S') + CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix) + CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE.) ! Scale matrix_K_tilde here. Then, the scaling has to be done for forces seperately ! Scale matrix_K_tilde by gsi for ADMMQ and ADMMS (Eqs. (27), (37) in Merlot, 2014) IF( admm_env%charge_constrain ) THEN - CALL cp_dbcsr_scale(matrix_k_tilde, admm_env%gsi(ispin), error=error) + CALL cp_dbcsr_scale(matrix_k_tilde, admm_env%gsi(ispin)) END IF ! Scale matrix_K_tilde by gsi^2 for ADMMP (Eq. (35) in Merlot, 2014) IF( (.NOT. admm_env%charge_constrain) .AND. & (admm_env%scaling_model==do_admm_exch_scaling_merlot) ) THEN gsi_square = (admm_env%gsi(ispin))*(admm_env%gsi(ispin)) - CALL cp_dbcsr_scale(matrix_k_tilde, gsi_square, error=error) + CALL cp_dbcsr_scale(matrix_k_tilde, gsi_square) END IF admm_env%lambda_merlot(ispin) = 0 @@ -1378,7 +1338,7 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) IF( admm_env%charge_constrain .AND. & (admm_env%scaling_model == do_admm_exch_scaling_none ) ) THEN CALL cp_dbcsr_trace(matrix_ks_aux_fit(ispin)%matrix, rho_ao_aux(ispin)%matrix, & - trace_tmp, 'T', 'N', error=error) + trace_tmp, 'T', 'N') ! Factor of 2 is missing compared to Eq. 28 in Merlot due to ! Tr(ds) = N in the code \neq 2N in Merlot @@ -1388,7 +1348,7 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) (admm_env%scaling_model == do_admm_exch_scaling_merlot ) ) THEN IF(dft_control%nspins==2) THEN CALL calc_spin_dep_aux_exch_ener(qs_env=qs_env, admm_env=admm_env, ener_k_ispin=ener_k(ispin), & - ener_x_ispin=ener_x(ispin), ispin=ispin, error=error) + ener_x_ispin=ener_x(ispin), ispin=ispin) admm_env%lambda_merlot(ispin) = 2.0_dp*(admm_env%gsi(ispin))**2* & (ener_k(ispin)+ener_x(ispin))/(admm_env%n_large_basis(ispin)) @@ -1400,13 +1360,13 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) ELSE IF( admm_env%charge_constrain .AND. & (admm_env%scaling_model == do_admm_exch_scaling_merlot ) ) THEN CALL cp_dbcsr_trace(matrix_ks_aux_fit_hfx(ispin)%matrix, rho_ao_aux(ispin)%matrix, & - trace_tmp, 'T', 'N', error=error) + trace_tmp, 'T', 'N') CALL cp_dbcsr_trace(matrix_ks_aux_fit_dft(ispin)%matrix, rho_ao_aux(ispin)%matrix, & - trace_tmp_two, 'T', 'N', error=error) + trace_tmp_two, 'T', 'N') ! For ADMMS open-shell case we need k and x (Merlot) separately since gsi(a)\=gsi(b) IF(dft_control%nspins==2) THEN CALL calc_spin_dep_aux_exch_ener(qs_env=qs_env, admm_env=admm_env, ener_k_ispin=ener_k(ispin), & - ener_x_ispin=ener_x(ispin), ispin=ispin, error=error) + ener_x_ispin=ener_x(ispin), ispin=ispin) admm_env%lambda_merlot(ispin) = (trace_tmp+2.0_dp/3.0_dp*((admm_env%gsi(ispin))**(2.0_dp/3.0_dp))*ener_x(ispin)-& ((admm_env%gsi(ispin))**(2.0_dp/3.0_dp))*trace_tmp_two)/(admm_env%n_large_basis(ispin)) @@ -1425,28 +1385,27 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) (admm_env%scaling_model == do_admm_exch_scaling_merlot ) ) THEN !! T^T*s_aux*T in (27) Merlot (T=A), as calculating A^T*K*A few lines above - CALL copy_dbcsr_to_fm(matrix_s_aux_fit(1)%matrix,admm_env%work_aux_aux4,error) - CALL cp_fm_upper_to_full(admm_env%work_aux_aux4,admm_env%work_aux_aux5,error=error) + CALL copy_dbcsr_to_fm(matrix_s_aux_fit(1)%matrix,admm_env%work_aux_aux4) + CALL cp_fm_upper_to_full(admm_env%work_aux_aux4,admm_env%work_aux_aux5) ! s_aux*T CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%work_aux_aux4,admm_env%A,0.0_dp,& - admm_env%work_aux_orb3,error) + admm_env%work_aux_orb3) ! T^T*s_aux*T CALL cp_gemm('T', 'N', nao_orb, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%A,admm_env%work_aux_orb3,0.0_dp,& - admm_env%work_orb_orb3,error) + admm_env%work_orb_orb3) NULLIFY(matrix_TtsT) ALLOCATE(matrix_TtsT) - CALL cp_dbcsr_init (matrix_TtsT, error) + CALL cp_dbcsr_init (matrix_TtsT) CALL cp_dbcsr_create(matrix_TtsT,template=matrix_ks(ispin)%matrix,& - name='MATRIX TtsT', matrix_type='S', error=error) - CALL cp_dbcsr_copy(matrix_TtsT, matrix_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(matrix_TtsT, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%work_orb_orb3, matrix_TtsT, keep_sparsity=.TRUE.,& - error=error) + name='MATRIX TtsT', matrix_type='S') + CALL cp_dbcsr_copy(matrix_TtsT, matrix_ks(ispin)%matrix) + CALL cp_dbcsr_set(matrix_TtsT, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%work_orb_orb3, matrix_TtsT, keep_sparsity=.TRUE.) !Add -(gsi)*Lambda*TtsT and Lambda*S to the KS matrix according to Merlot2014 @@ -1454,19 +1413,19 @@ SUBROUTINE merge_ks_matrix_none(qs_env, error) IF( admm_env%scaling_model == do_admm_exch_scaling_merlot .OR. & admm_env%charge_constrain) THEN CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_TtsT, 1.0_dp, & - (-admm_env%lambda_merlot(ispin))*admm_env%gsi(ispin), error) + (-admm_env%lambda_merlot(ispin))*admm_env%gsi(ispin)) END IF - CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_s(1)%matrix, 1.0_dp, admm_env%lambda_merlot(ispin), error) + CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_s(1)%matrix, 1.0_dp, admm_env%lambda_merlot(ispin)) - CALL cp_dbcsr_deallocate_matrix(matrix_TtsT,error) + CALL cp_dbcsr_deallocate_matrix(matrix_TtsT) END IF - CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp) - CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde,error) + CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde) ENDIF ENDDO !spin loop @@ -1515,16 +1474,14 @@ END SUBROUTINE merge_ks_matrix_none !> \param ener_k_ispin exact ispin (Fock) exchange in auxiliary basis !> \param ener_x_ispin ispin DFT exchange in auxiliary basis !> \param ispin ... -!> \param error ... !> \author Jan Wilhelm, 12/2014 ! ***************************************************************************** SUBROUTINE calc_spin_dep_aux_exch_ener(qs_env, admm_env, ener_k_ispin, ener_x_ispin, & - ispin, error) + ispin) TYPE(qs_environment_type), POINTER :: qs_env TYPE(admm_type), POINTER :: admm_env REAL(dp), INTENT(INOUT) :: ener_k_ispin, ener_x_ispin INTEGER, INTENT(IN) :: ispin - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_spin_dep_aux_exch_ener', & routineP = moduleN//':'//routineN @@ -1558,27 +1515,24 @@ SUBROUTINE calc_spin_dep_aux_exch_ener(qs_env, admm_env, ener_k_ispin, ener_x_is rho_aux_fit=rho_aux_fit,& rho_aux_fit_buffer=rho_aux_fit_buffer,& dft_control=dft_control,& - matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx,& - error=error) + matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx) CALL qs_rho_get(rho_aux_fit,& - rho_ao=rho_ao_aux,& - error=error) + rho_ao=rho_ao_aux) CALL qs_rho_get(rho_aux_fit_buffer,& rho_ao=rho_ao_aux_buffer,& rho_g=rho_g,& rho_r=rho_r,& - tot_rho_r=tot_rho_r,& - error=error) + tot_rho_r=tot_rho_r) ! Calculate rho_buffer = rho_aux(ispin) to get exchange of ispin electrons - CALL cp_dbcsr_set(rho_ao_aux_buffer(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(rho_ao_aux_buffer(2)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(rho_ao_aux_buffer(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(rho_ao_aux_buffer(2)%matrix,0.0_dp) CALL cp_dbcsr_add(rho_ao_aux_buffer(ispin)%matrix, & - rho_ao_aux(ispin)%matrix, 0.0_dp, 1.0_dp, error) + rho_ao_aux(ispin)%matrix, 0.0_dp, 1.0_dp) ! integration for getting the spin dependent density has to done for both spins! @@ -1589,13 +1543,12 @@ SUBROUTINE calc_spin_dep_aux_exch_ener(qs_env, admm_env, ener_k_ispin, ener_x_is rho_gspace=rho_g(myspin),& total_rho=tot_rho_r(myspin),& soft_valid=.FALSE.,& - basis_type="AUX_FIT",& - error=error) + basis_type="AUX_FIT") END DO ! Write changes in buffer density matrix - CALL qs_rho_set(rho_aux_fit_buffer, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_aux_fit_buffer, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) xc_section_aux => admm_env%xc_section_aux @@ -1604,13 +1557,13 @@ SUBROUTINE calc_spin_dep_aux_exch_ener(qs_env, admm_env, ener_k_ispin, ener_x_is CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_aux_fit_buffer, xc_section=xc_section_aux, & vxc_rho=v_rspace_dummy, vxc_tau=v_tau_rspace_dummy, exc=ener_x_ispin, & - just_energy=.TRUE., error=error) + just_energy=.TRUE.) ener_k_ispin = 0.0_dp !! ** Calculate the exchange energy CALL cp_dbcsr_trace(matrix_ks_aux_fit_hfx(ispin)%matrix, rho_ao_aux_buffer(ispin)%matrix, & - ener_k_ispin, error=error) + ener_k_ispin) ! Divide exchange for indivivual spin by two, since the ener_k_ispin originally is total ! exchange of alpha and beta @@ -1625,15 +1578,13 @@ END SUBROUTINE calc_spin_dep_aux_exch_ener !> \param qs_env ... !> \param rho_ao_orb ... !> \param scale_back ... -!> \param error ... !> \author Jan Wilhelm, 12/2014 ! ***************************************************************************** - SUBROUTINE scale_dm(qs_env, rho_ao_orb, scale_back, error) + SUBROUTINE scale_dm(qs_env, rho_ao_orb, scale_back) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: rho_ao_orb LOGICAL, INTENT(IN) :: scale_back - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_dm', & routineP = moduleN//':'//routineN @@ -1648,8 +1599,7 @@ SUBROUTINE scale_dm(qs_env, rho_ao_orb, scale_back, error) CALL get_qs_env(qs_env,& admm_env=admm_env,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! only for ADMMP IF (admm_env%scaling_model == do_admm_exch_scaling_merlot .AND. & @@ -1657,9 +1607,9 @@ SUBROUTINE scale_dm(qs_env, rho_ao_orb, scale_back, error) DO ispin=1, dft_control%nspins DO img=1, dft_control%nimages IF(scale_back) THEN - CALL cp_dbcsr_scale(rho_ao_orb(ispin,img)%matrix, 1.0_dp/admm_env%gsi(ispin), error=error) + CALL cp_dbcsr_scale(rho_ao_orb(ispin,img)%matrix, 1.0_dp/admm_env%gsi(ispin)) ELSE - CALL cp_dbcsr_scale(rho_ao_orb(ispin,img)%matrix, admm_env%gsi(ispin), error=error) + CALL cp_dbcsr_scale(rho_ao_orb(ispin,img)%matrix, admm_env%gsi(ispin)) END IF END DO END DO @@ -1677,17 +1627,15 @@ END SUBROUTINE scale_dm !> \param mo_set ... !> \param mo_coeff_aux_fit ... !> \param matrix_ks_aux_fit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_aux_mo_derivs_none(ispin, admm_env, mo_set, mo_coeff_aux_fit, & - matrix_ks_aux_fit, error) + matrix_ks_aux_fit) INTEGER, INTENT(IN) :: ispin TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_fm_type), POINTER :: mo_coeff_aux_fit TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks_aux_fit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_aux_mo_derivs_none', & routineP = moduleN//':'//routineN @@ -1709,12 +1657,12 @@ SUBROUTINE calc_aux_mo_derivs_none(ispin, admm_env, mo_set, mo_coeff_aux_fit, & ! happens implicitly because the KS matrices have been already been merged ! and adding them here would be double counting. - CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix,error) - CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix) + CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux) CALL cp_gemm('N','N', nao_aux_fit, nmo, nao_aux_fit,& 1.0_dp,admm_env%K(ispin)%matrix,mo_coeff_aux_fit,0.0_dp,& - admm_env%H(ispin)%matrix,error) + admm_env%H(ispin)%matrix) CALL get_mo_set(mo_set=mo_set, occupation_numbers=occupation_numbers) ALLOCATE(scaling_factor(SIZE(occupation_numbers))) @@ -1737,9 +1685,8 @@ END SUBROUTINE calc_aux_mo_derivs_none !> \param mo_set ... !> \param mo_derivs ... !> \param matrix_ks_aux_fit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE merge_mo_derivs_no_diag(ispin, admm_env, mo_set, mo_derivs, matrix_ks_aux_fit, error) + SUBROUTINE merge_mo_derivs_no_diag(ispin, admm_env, mo_set, mo_derivs, matrix_ks_aux_fit) INTEGER, INTENT(IN) :: ispin TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_type), POINTER :: mo_set @@ -1747,7 +1694,6 @@ SUBROUTINE merge_mo_derivs_no_diag(ispin, admm_env, mo_set, mo_derivs, matrix_ks POINTER :: mo_derivs TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks_aux_fit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'merge_mo_derivs_no_diag', & routineP = moduleN//':'//routineN @@ -1763,8 +1709,8 @@ SUBROUTINE merge_mo_derivs_no_diag(ispin, admm_env, mo_set, mo_derivs, matrix_ks nao_orb = admm_env%nao_orb nmo = admm_env%nmo(ispin) - CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix,error) - CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux,error=error) + CALL copy_dbcsr_to_fm(matrix_ks_aux_fit(ispin)%matrix,admm_env%K(ispin)%matrix) + CALL cp_fm_upper_to_full(admm_env%K(ispin)%matrix,admm_env%work_aux_aux) CALL get_mo_set(mo_set=mo_set, occupation_numbers=occupation_numbers) ALLOCATE(scaling_factor(SIZE(occupation_numbers))) @@ -1774,30 +1720,30 @@ SUBROUTINE merge_mo_derivs_no_diag(ispin, admm_env, mo_set, mo_derivs, matrix_ks !! ** calculate first part CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nmo,& 1.0_dp,admm_env%C_hat(ispin)%matrix,admm_env%lambda_inv(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nao_aux_fit,& 1.0_dp,admm_env%K(ispin)%matrix,admm_env%work_aux_nmo(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo2(ispin)%matrix,error) + admm_env%work_aux_nmo2(ispin)%matrix) CALL cp_gemm('T', 'N', nao_orb, nmo, nao_aux_fit,& 2.0_dp,admm_env%A,admm_env%work_aux_nmo2(ispin)%matrix,0.0_dp,& - admm_env%mo_derivs_tmp(ispin)%matrix,error) + admm_env%mo_derivs_tmp(ispin)%matrix) !! ** calculate second part CALL cp_gemm('T', 'N', nmo, nmo, nao_aux_fit,& 1.0_dp,admm_env%work_aux_nmo(ispin)%matrix,admm_env%work_aux_nmo2(ispin)%matrix,0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nmo,& 1.0_dp,admm_env%C_hat(ispin)%matrix,admm_env%work_orb_orb,0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) CALL cp_gemm('N', 'N', nao_aux_fit, nmo, nao_aux_fit,& 1.0_dp,admm_env%S,admm_env%work_aux_orb,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) CALL cp_gemm('T', 'N', nao_orb, nmo, nao_aux_fit,& -2.0_dp,admm_env%A,admm_env%work_aux_nmo(ispin)%matrix,1.0_dp,& - admm_env%mo_derivs_tmp(ispin)%matrix,error) + admm_env%mo_derivs_tmp(ispin)%matrix) CALL cp_fm_column_scale(admm_env%mo_derivs_tmp(ispin)%matrix,scaling_factor) - CALL cp_fm_scale_and_add(1.0_dp,mo_derivs(ispin)%matrix,1.0_dp,admm_env%mo_derivs_tmp(ispin)%matrix,error) + CALL cp_fm_scale_and_add(1.0_dp,mo_derivs(ispin)%matrix,1.0_dp,admm_env%mo_derivs_tmp(ispin)%matrix) DEALLOCATE(scaling_factor) @@ -1829,15 +1775,13 @@ END SUBROUTINE merge_mo_derivs_no_diag !> xx = schur product !> !> \param qs_env the QS environment -!> \param error ... !> \par History !> 05.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE calc_mixed_overlap_force(qs_env, error) + SUBROUTINE calc_mixed_overlap_force(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_mixed_overlap_force', & routineP = moduleN//':'//routineN @@ -1896,47 +1840,44 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) sab_aux_fit_asymm=sab_aux_fit_asymm,& sab_aux_fit_vs_orb=sab_aux_fit_vs_orb,& mos=mos,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) CALL qs_rho_get(rho_aux_fit,& - rho_ao=rho_ao_aux,& - error=error) + rho_ao=rho_ao_aux) nao_aux_fit = admm_env%nao_aux_fit nao_orb = admm_env%nao_orb - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! *** forces are only implemented for mo_diag or none and basis_projection *** IF (admm_env%block_dm) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (.NOT.(admm_env%purification_method==do_admm_purify_mo_diag .OR. & admm_env%purification_method==do_admm_purify_none)) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! *** Create sparse work matrices ALLOCATE(matrix_w_s) - CALL cp_dbcsr_init (matrix_w_s, error) + CALL cp_dbcsr_init (matrix_w_s) CALL cp_dbcsr_create(matrix_w_s, 'W MATRIX AUX S', & cp_dbcsr_distribution(matrix_s_aux_fit(1)%matrix), dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(matrix_s_aux_fit(1)%matrix),& cp_dbcsr_col_block_sizes(matrix_s_aux_fit(1)%matrix), & cp_dbcsr_get_data_size(matrix_s_aux_fit(1)%matrix),& - cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix), & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_w_s,sab_aux_fit_asymm,error=error) + cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix)) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_w_s,sab_aux_fit_asymm) ALLOCATE(matrix_w_q) - CALL cp_dbcsr_init(matrix_w_q, error=error) + CALL cp_dbcsr_init(matrix_w_q) CALL cp_dbcsr_copy(matrix_w_q,matrix_s_aux_fit_vs_orb(1)%matrix,& - "W MATRIX AUX Q",error=error) + "W MATRIX AUX Q") DO ispin=1, dft_control%nspins nmo = admm_env%nmo(ispin) @@ -1946,56 +1887,56 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) IF (.NOT. admm_env%purification_method==do_admm_purify_none) THEN CALL cp_gemm('T', 'N', nao_aux_fit, nmo, nao_aux_fit,& 1.0_dp,admm_env%S_inv,qs_env%mo_derivs_aux_fit(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) ELSE CALL cp_gemm('T', 'N', nao_aux_fit, nmo, nao_aux_fit,& 1.0_dp,admm_env%S_inv,admm_env%H(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo(ispin)%matrix,error) + admm_env%work_aux_nmo(ispin)%matrix) END IF ! *** S'^(-T)*H'*Lambda^(-T/2) CALL cp_gemm('N', 'T', nao_aux_fit,nmo, nmo,& 1.0_dp,admm_env%work_aux_nmo(ispin)%matrix,admm_env%lambda_inv_sqrt(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo2(ispin)%matrix,error) + admm_env%work_aux_nmo2(ispin)%matrix) ! *** C*Lambda^(-1/2)*H'^(T)*S'^(-1) minus sign due to force = -dE/dR CALL cp_gemm('N', 'T', nao_aux_fit, nao_orb, nmo,& -1.0_dp,admm_env%work_aux_nmo2(ispin)%matrix,mo_coeff,0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) ! *** A*C*Lambda^(-1/2)*H'^(T)*S'^(-1), minus sign to recover from above CALL cp_gemm('N', 'T', nao_aux_fit, nao_aux_fit, nao_orb,& -1.0_dp,admm_env%work_aux_orb,admm_env%A,0.0_dp,& - admm_env%work_aux_aux,error) + admm_env%work_aux_aux) IF (.NOT. (admm_env%purification_method==do_admm_purify_none)) THEN ! *** C*Y CALL cp_gemm('N', 'N', nao_orb, nmo, nmo,& 1.0_dp,mo_coeff,admm_env%R_schur_R_t(ispin)%matrix,0.0_dp,& - admm_env%work_orb_nmo(ispin)%matrix,error) + admm_env%work_orb_nmo(ispin)%matrix) ! *** C*Y^(T)*C^(T) CALL cp_gemm('N', 'T', nao_orb, nao_orb, nmo,& 1.0_dp,mo_coeff,admm_env%work_orb_nmo(ispin)%matrix,0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) ! *** A*C*Y^(T)*C^(T) Add to work aux_orb, minus sign due to force = -dE/dR CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_orb,& -1.0_dp,admm_env%A,admm_env%work_orb_orb,1.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) ! *** C*Y^(T) CALL cp_gemm('N', 'T', nao_orb, nmo, nmo,& 1.0_dp,mo_coeff,admm_env%R_schur_R_t(ispin)%matrix,0.0_dp,& - admm_env%work_orb_nmo(ispin)%matrix,error) + admm_env%work_orb_nmo(ispin)%matrix) ! *** C*Y*C^(T) CALL cp_gemm('N', 'T', nao_orb, nao_orb, nmo,& 1.0_dp,mo_coeff,admm_env%work_orb_nmo(ispin)%matrix,0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) ! *** A*C*Y*C^(T) Add to work aux_orb, minus sign due to -dE/dR CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_orb,& -1.0_dp,admm_env%A,admm_env%work_orb_orb,1.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) END IF ! Add derivative contribution matrix*dQ/dR in additional last term in @@ -2004,16 +1945,16 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) IF ( admm_env%scaling_model == do_admm_exch_scaling_merlot .AND. & admm_env%charge_constrain ) THEN ! *** scale admm_env%work_aux_orb by gsi due to inner derivative - CALL cp_fm_scale(admm_env%gsi(ispin), admm_env%work_aux_orb, error) + CALL cp_fm_scale(admm_env%gsi(ispin), admm_env%work_aux_orb) ! *** as in ADMMP only with different sign CALL cp_gemm('N', 'T', nao_orb, nao_orb, nmo, & 4.0_dp*( admm_env%gsi(ispin) )*admm_env%lambda_merlot(ispin)/dft_control%nspins, & - mo_coeff,mo_coeff,0.0_dp, admm_env%work_orb_orb2,error) + mo_coeff,mo_coeff,0.0_dp, admm_env%work_orb_orb2) ! *** prefactor*A*C*C^(T) Add to work aux_orb CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_orb,& 1.0_dp, admm_env%A, admm_env%work_orb_orb2,1.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) ! ADMMP @@ -2022,50 +1963,48 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) ! *** prefactor*C*C^(T), nspins since 2/n_spin*C*C^(T)=P CALL cp_gemm('N', 'T', nao_orb, nao_orb, nmo, & -4.0_dp*( admm_env%gsi(ispin) )*admm_env%lambda_merlot(ispin)/dft_control%nspins, & - mo_coeff,mo_coeff,0.0_dp, admm_env%work_orb_orb2,error) + mo_coeff,mo_coeff,0.0_dp, admm_env%work_orb_orb2) ! *** prefactor*A*C*C^(T) Add to work aux_orb CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_orb,& 1.0_dp, admm_env%A, admm_env%work_orb_orb2,1.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) ! ADMMQ ELSE IF (admm_env%scaling_model == do_admm_exch_scaling_none .AND. & admm_env%charge_constrain ) THEN ! *** scale admm_env%work_aux_orb by gsi due to inner derivative - CALL cp_fm_scale(admm_env%gsi(ispin), admm_env%work_aux_orb, error) + CALL cp_fm_scale(admm_env%gsi(ispin), admm_env%work_aux_orb) ! *** as in ADMMP only with different sign CALL cp_gemm('N', 'T', nao_orb, nao_orb, nmo, & 4.0_dp*( admm_env%gsi(ispin) )*admm_env%lambda_merlot(ispin)/dft_control%nspins, & - mo_coeff,mo_coeff,0.0_dp, admm_env%work_orb_orb2,error) + mo_coeff,mo_coeff,0.0_dp, admm_env%work_orb_orb2) ! *** prefactor*A*C*C^(T) Add to work aux_orb CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_orb,& 1.0_dp, admm_env%A, admm_env%work_orb_orb2,1.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) END IF ! *** copy to sparse matrix - CALL copy_fm_to_dbcsr(admm_env%work_aux_orb, matrix_w_q,keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(admm_env%work_aux_orb, matrix_w_q,keep_sparsity=.TRUE.) IF (.NOT. (admm_env%purification_method==do_admm_purify_none)) THEN ! *** A*C*Y^(T)*C^(T) CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_orb,& 1.0_dp,admm_env%A,admm_env%work_orb_orb,0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) ! *** A*C*Y^(T)*C^(T)*A^(T) add to aux_aux, minus sign cancels CALL cp_gemm('N', 'T', nao_aux_fit, nao_aux_fit, nao_orb,& 1.0_dp,admm_env%work_aux_orb,admm_env%A,1.0_dp,& - admm_env%work_aux_aux,error) + admm_env%work_aux_aux) END IF ! *** copy to sparse matrix - CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_w_s,keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_w_s,keep_sparsity=.TRUE.) ! Add derivative of Eq. (33) with respect to s_aux Merlot2014 to the force IF ( admm_env%scaling_model == do_admm_exch_scaling_merlot .OR. & @@ -2074,25 +2013,24 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) !Create desymmetrized auxiliary density matrix NULLIFY(matrix_rho_aux_desymm_tmp) ALLOCATE(matrix_rho_aux_desymm_tmp) - CALL cp_dbcsr_init (matrix_rho_aux_desymm_tmp, error) + CALL cp_dbcsr_init (matrix_rho_aux_desymm_tmp) CALL cp_dbcsr_create(matrix_rho_aux_desymm_tmp, 'Rho_aux non-symm', & cp_dbcsr_distribution(matrix_s_aux_fit(1)%matrix), dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(matrix_s_aux_fit(1)%matrix),& cp_dbcsr_col_block_sizes(matrix_s_aux_fit(1)%matrix), & cp_dbcsr_get_data_size(matrix_s_aux_fit(1)%matrix),& - cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix), & - error=error) + cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix)) - CALL cp_dbcsr_desymmetrize(rho_ao_aux(ispin)%matrix, matrix_rho_aux_desymm_tmp, error=error) + CALL cp_dbcsr_desymmetrize(rho_ao_aux(ispin)%matrix, matrix_rho_aux_desymm_tmp) ! ADMMS 1. scale original matrix_w_s by gsi due to inner deriv. ! 2. add derivative of variational term with resp. to s IF ( admm_env%scaling_model == do_admm_exch_scaling_merlot .AND. & admm_env%charge_constrain ) THEN - CALL cp_dbcsr_scale(matrix_w_s, admm_env%gsi(ispin), error=error) + CALL cp_dbcsr_scale(matrix_w_s, admm_env%gsi(ispin)) CALL cp_dbcsr_add(matrix_w_s, matrix_rho_aux_desymm_tmp, 1.0_dp, & - -admm_env%lambda_merlot(ispin), error) + -admm_env%lambda_merlot(ispin)) ! ADMMP add derivative of variational term with resp. to s @@ -2100,20 +2038,20 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) .NOT. admm_env%charge_constrain ) THEN CALL cp_dbcsr_add(matrix_w_s, matrix_rho_aux_desymm_tmp, 1.0_dp, & - (admm_env%gsi(ispin))*admm_env%lambda_merlot(ispin), error) + (admm_env%gsi(ispin))*admm_env%lambda_merlot(ispin)) ! ADMMQ 1. scale original matrix_w_s by gsi due to inner deriv. ! 2. add derivative of variational term with resp. to s ELSE IF ( admm_env%scaling_model == do_admm_exch_scaling_none .AND. & admm_env%charge_constrain ) THEN - CALL cp_dbcsr_scale(matrix_w_s, admm_env%gsi(ispin), error=error) + CALL cp_dbcsr_scale(matrix_w_s, admm_env%gsi(ispin)) CALL cp_dbcsr_add(matrix_w_s, matrix_rho_aux_desymm_tmp, 1.0_dp, & - -admm_env%lambda_merlot(ispin), error) + -admm_env%lambda_merlot(ispin)) END IF - CALL cp_dbcsr_deallocate_matrix(matrix_rho_aux_desymm_tmp,error) + CALL cp_dbcsr_deallocate_matrix(matrix_rho_aux_desymm_tmp) END IF @@ -2121,41 +2059,41 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) ! allocate force vector - CALL get_qs_env(qs_env=qs_env,natom=natom,error=error) + CALL get_qs_env(qs_env=qs_env,natom=natom) ALLOCATE(admm_force(3,natom)) admm_force = 0.0_dp CALL build_overlap_force(ks_env, admm_force,& basis_type_a="AUX_FIT", basis_type_b="AUX_FIT", & - sab_nl=sab_aux_fit_asymm, matrix_p=matrix_w_s, error=error) + sab_nl=sab_aux_fit_asymm, matrix_p=matrix_w_s) CALL build_overlap_force(ks_env, admm_force,& basis_type_a="AUX_FIT", basis_type_b="ORB", & - sab_nl=sab_aux_fit_vs_orb, matrix_p=matrix_w_q, error=error) + sab_nl=sab_aux_fit_vs_orb, matrix_p=matrix_w_q) ! Add contribution of original basis set for ADMMQ IF ( .NOT. admm_env%scaling_model == do_admm_exch_scaling_merlot .AND. admm_env%charge_constrain ) THEN - CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -admm_env%lambda_merlot(ispin),error=error) + CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -admm_env%lambda_merlot(ispin)) CALL build_overlap_force(ks_env, admm_force,& basis_type_a="ORB", basis_type_b="ORB", & - sab_nl=sab_orb, matrix_p=rho_ao(ispin)%matrix, error=error) - CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -1.0_dp/admm_env%lambda_merlot(ispin), error=error) + sab_nl=sab_orb, matrix_p=rho_ao(ispin)%matrix) + CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -1.0_dp/admm_env%lambda_merlot(ispin)) END IF ! Add contribution of original basis set for ADMMP IF ( admm_env%scaling_model == do_admm_exch_scaling_merlot .AND. .NOT. admm_env%charge_constrain ) THEN - CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, admm_env%lambda_merlot(ispin),error=error) + CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, admm_env%lambda_merlot(ispin)) CALL build_overlap_force(ks_env, admm_force,& basis_type_a="ORB", basis_type_b="ORB", & - sab_nl=sab_orb, matrix_p=rho_ao(ispin)%matrix, error=error) - CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, 1.0_dp/admm_env%lambda_merlot(ispin), error=error) + sab_nl=sab_orb, matrix_p=rho_ao(ispin)%matrix) + CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, 1.0_dp/admm_env%lambda_merlot(ispin)) END IF ! Add contribution of original basis set for ADMMS IF ( admm_env%scaling_model == do_admm_exch_scaling_merlot .AND. admm_env%charge_constrain ) THEN - CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -admm_env%lambda_merlot(ispin),error=error) + CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -admm_env%lambda_merlot(ispin)) CALL build_overlap_force(ks_env, admm_force,& basis_type_a="ORB", basis_type_b="ORB", & - sab_nl=sab_orb, matrix_p=rho_ao(ispin)%matrix, error=error) - CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -1.0_dp/admm_env%lambda_merlot(ispin), error=error) + sab_nl=sab_orb, matrix_p=rho_ao(ispin)%matrix) + CALL cp_dbcsr_scale(rho_ao(ispin)%matrix, -1.0_dp/admm_env%lambda_merlot(ispin)) END IF @@ -2164,32 +2102,32 @@ SUBROUTINE calc_mixed_overlap_force(qs_env, error) ! add forces CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,& - force=force,error=error) - CALL add_qs_force(admm_force, force, "overlap_admm", atomic_kind_set, error) + force=force) + CALL add_qs_force(admm_force, force, "overlap_admm", atomic_kind_set) DEALLOCATE(admm_force) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT",& - extension=".Log",error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_w_s,4,6,qs_env,para_env,output_unit=iw,error=error) + extension=".Log") + CALL cp_dbcsr_write_sparse_matrix(matrix_w_s,4,6,qs_env,para_env,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT", error=error) + "DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT",& - extension=".Log",error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_w_q,4,6,qs_env,para_env,output_unit=iw,error=error) + extension=".Log") + CALL cp_dbcsr_write_sparse_matrix(matrix_w_q,4,6,qs_env,para_env,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT", error=error) + "DFT%PRINT%AO_MATRICES/W_MATRIX_AUX_FIT") END IF ENDDO !spin loop ! *** Deallocated weighted density matrices - CALL cp_dbcsr_deallocate_matrix(matrix_w_s,error) - CALL cp_dbcsr_deallocate_matrix(matrix_w_q,error) + CALL cp_dbcsr_deallocate_matrix(matrix_w_s) + CALL cp_dbcsr_deallocate_matrix(matrix_w_q) CALL timestop(handle) @@ -2205,10 +2143,9 @@ END SUBROUTINE calc_mixed_overlap_force !> \param density_matrix_large DM of the original basis !> \param overlap_matrix_large overlap matrix of original basis !> \param ispin ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_dm_mo_no_diag(admm_env,mo_set,density_matrix,overlap_matrix,& - density_matrix_large,overlap_matrix_large,ispin,error) + density_matrix_large,overlap_matrix_large,ispin) TYPE(admm_type), POINTER :: admm_env TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_dbcsr_type), POINTER :: density_matrix, & @@ -2216,7 +2153,6 @@ SUBROUTINE calculate_dm_mo_no_diag(admm_env,mo_set,density_matrix,overlap_matrix density_matrix_large, & overlap_matrix_large INTEGER :: ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_dm_mo_no_diag', & routineP = moduleN//':'//routineN @@ -2228,15 +2164,15 @@ SUBROUTINE calculate_dm_mo_no_diag(admm_env,mo_set,density_matrix,overlap_matrix CALL timeset(routineN,handle) - CALL cp_dbcsr_set(density_matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(density_matrix,0.0_dp) nao_aux_fit = admm_env%nao_aux_fit nmo = admm_env%nmo(ispin) - CALL cp_fm_to_fm(admm_env%C_hat(ispin)%matrix, admm_env%work_aux_nmo(ispin)%matrix, error=error) + CALL cp_fm_to_fm(admm_env%C_hat(ispin)%matrix, admm_env%work_aux_nmo(ispin)%matrix) CALL cp_fm_column_scale(admm_env%work_aux_nmo(ispin)%matrix,mo_set%occupation_numbers(1:mo_set%homo)) CALL cp_gemm('N','N',nao_aux_fit,nmo,nmo,& 1.0_dp,admm_env%work_aux_nmo(ispin)%matrix,admm_env%lambda_inv(ispin)%matrix,0.0_dp,& - admm_env%work_aux_nmo2(ispin)%matrix,error) + admm_env%work_aux_nmo2(ispin)%matrix) ! The following IF doesn't do anything unless !alpha=mo_set%maxocc is uncommented. IF ( .NOT. mo_set%uniform_occupation ) THEN ! not all orbitals 1..homo are equally occupied @@ -2245,7 +2181,7 @@ SUBROUTINE calculate_dm_mo_no_diag(admm_env,mo_set,density_matrix,overlap_matrix matrix_v=admm_env%C_hat(ispin)%matrix,& matrix_g=admm_env%work_aux_nmo2(ispin)%matrix,& ncol=mo_set%homo,& - alpha=alpha,error=error) + alpha=alpha) ELSE alpha=1.0_dp !alpha=mo_set%maxocc @@ -2253,7 +2189,7 @@ SUBROUTINE calculate_dm_mo_no_diag(admm_env,mo_set,density_matrix,overlap_matrix matrix_v=admm_env%C_hat(ispin)%matrix,& matrix_g=admm_env%work_aux_nmo2(ispin)%matrix,& ncol=mo_set%homo,& - alpha=alpha,error=error) + alpha=alpha) ENDIF @@ -2268,15 +2204,15 @@ SUBROUTINE calculate_dm_mo_no_diag(admm_env,mo_set,density_matrix,overlap_matrix ! Calculate number of electrons in the original density matrix, transposing doesn't matter ! since both matrices are symmetric - CALL cp_dbcsr_trace(density_matrix_large, overlap_matrix_large, admm_env%n_large_basis(ispin), 'T', 'N', error=error) + CALL cp_dbcsr_trace(density_matrix_large, overlap_matrix_large, admm_env%n_large_basis(ispin), 'T', 'N') admm_env%n_large_basis(3) = admm_env%n_large_basis(3) + admm_env%n_large_basis(ispin) ! Calculate number of electrons in the auxiliary density matrix - CALL cp_dbcsr_trace(density_matrix, overlap_matrix, nel_tmp_aux, 'T', 'N', error=error) + CALL cp_dbcsr_trace(density_matrix, overlap_matrix, nel_tmp_aux, 'T', 'N') admm_env%gsi(ispin) = admm_env%n_large_basis(ispin)/nel_tmp_aux IF( admm_env%charge_constrain ) THEN ! multiply aux. DM with gsi to get the scaled DM (Merlot, Eq. 21) - CALL cp_dbcsr_scale(density_matrix, admm_env%gsi(ispin), error=error) + CALL cp_dbcsr_scale(density_matrix, admm_env%gsi(ispin)) ENDIF ENDIF @@ -2294,15 +2230,13 @@ END SUBROUTINE calculate_dm_mo_no_diag !> \param density_matrix_aux ... !> \param ispin ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** SUBROUTINE blockify_density_matrix(admm_env,density_matrix, density_matrix_aux,& - ispin, nspins, error) + ispin, nspins) TYPE(admm_type), POINTER :: admm_env TYPE(cp_dbcsr_type), POINTER :: density_matrix, & density_matrix_aux INTEGER :: ispin, nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'blockify_density_matrix', & routineP = moduleN//':'//routineN @@ -2315,7 +2249,7 @@ SUBROUTINE blockify_density_matrix(admm_env,density_matrix, density_matrix_aux,& CALL timeset(routineN,handle) ! ** set blocked density matrix to 0 - CALL cp_dbcsr_set(density_matrix_aux, 0.0_dp, error) + CALL cp_dbcsr_set(density_matrix_aux, 0.0_dp) ! ** now loop through the list and copy corresponding blocks CALL cp_dbcsr_iterator_start(iter, density_matrix) @@ -2332,11 +2266,11 @@ SUBROUTINE blockify_density_matrix(admm_env,density_matrix, density_matrix_aux,& END DO CALL cp_dbcsr_iterator_stop(iter) - CALL copy_dbcsr_to_fm(density_matrix_aux,admm_env%P_to_be_purified(ispin)%matrix,error) - CALL cp_fm_upper_to_full(admm_env%P_to_be_purified(ispin)%matrix, admm_env%work_orb_orb2,error=error) + CALL copy_dbcsr_to_fm(density_matrix_aux,admm_env%P_to_be_purified(ispin)%matrix) + CALL cp_fm_upper_to_full(admm_env%P_to_be_purified(ispin)%matrix, admm_env%work_orb_orb2) IF( nspins == 1 ) THEN - CALL cp_fm_scale(0.5_dp, admm_env%P_to_be_purified(ispin)%matrix, error) + CALL cp_fm_scale(0.5_dp, admm_env%P_to_be_purified(ispin)%matrix) END IF CALL timestop(handle) diff --git a/src/admm_types.F b/src/admm_types.F index 5ea61a224f..94ff5605bd 100644 --- a/src/admm_types.F +++ b/src/admm_types.F @@ -144,19 +144,17 @@ MODULE admm_types !> \param mos_aux_fit the MO's of the auxiliary fitting basis set !> \param para_env The parallel env !> \param natoms ... -!> \param error ... !> \par History !> 05.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE admm_env_create(admm_env, admm_control, mos, mos_aux_fit, para_env, natoms, error) + SUBROUTINE admm_env_create(admm_env, admm_control, mos, mos_aux_fit, para_env, natoms) TYPE(admm_type), POINTER :: admm_env TYPE(admm_control_type), POINTER :: admm_control TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos, mos_aux_fit TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN) :: natoms - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'admm_env_create', & routineP = moduleN//':'//routineN @@ -183,43 +181,39 @@ SUBROUTINE admm_env_create(admm_env, admm_control, mos, mos_aux_fit, para_env, n context=mo_coeff%matrix_struct%context,& nrow_global=nao_aux_fit,& ncol_global=nao_aux_fit,& - para_env=para_env,& - error=error) + para_env=para_env) CALL cp_fm_struct_create(fm_struct_aux_orb,& context=mo_coeff%matrix_struct%context,& nrow_global=nao_aux_fit,& ncol_global=nao_orb,& - para_env=para_env,& - error=error) + para_env=para_env) CALL cp_fm_struct_create(fm_struct_orb_aux,& context=mo_coeff%matrix_struct%context,& nrow_global=nao_orb,& ncol_global=nao_aux_fit,& - para_env=para_env,& - error=error) + para_env=para_env) CALL cp_fm_struct_create(fm_struct_orb_orb,& context=mo_coeff%matrix_struct%context,& nrow_global=nao_orb,& ncol_global=nao_orb,& - para_env=para_env,& - error=error) - - CALL cp_fm_create(admm_env%S,fm_struct_aux_aux,name="aux_fit_overlap",error=error) - CALL cp_fm_create(admm_env%S_inv,fm_struct_aux_aux,name="aux_fit_overlap_inv",error=error) - CALL cp_fm_create(admm_env%Q,fm_struct_aux_orb,name="mixed_overlap",error=error) - CALL cp_fm_create(admm_env%A,fm_struct_aux_orb,name="work_A",error=error) - CALL cp_fm_create(admm_env%B,fm_struct_orb_orb,name="work_B",error=error) - CALL cp_fm_create(admm_env%work_orb_orb,fm_struct_orb_orb,name="work_orb_orb",error=error) - CALL cp_fm_create(admm_env%work_orb_orb2,fm_struct_orb_orb,name="work_orb_orb",error=error) - CALL cp_fm_create(admm_env%work_orb_orb3,fm_struct_orb_orb,name="work_orb_orb3",error=error) - CALL cp_fm_create(admm_env%work_aux_orb,fm_struct_aux_orb,name="work_aux_orb",error=error) - CALL cp_fm_create(admm_env%work_aux_orb2,fm_struct_aux_orb,name="work_aux_orb2",error=error) - CALL cp_fm_create(admm_env%work_aux_orb3,fm_struct_aux_orb,name="work_aux_orb3",error=error) - CALL cp_fm_create(admm_env%work_aux_aux,fm_struct_aux_aux,name="work_aux_aux",error=error) - CALL cp_fm_create(admm_env%work_aux_aux2,fm_struct_aux_aux,name="work_aux_aux2",error=error) - CALL cp_fm_create(admm_env%work_aux_aux3,fm_struct_aux_aux,name="work_aux_aux3",error=error) - CALL cp_fm_create(admm_env%work_aux_aux4,fm_struct_aux_aux,name="work_aux_aux4",error=error) - CALL cp_fm_create(admm_env%work_aux_aux5,fm_struct_aux_aux,name="work_aux_aux5",error=error) + para_env=para_env) + + CALL cp_fm_create(admm_env%S,fm_struct_aux_aux,name="aux_fit_overlap") + CALL cp_fm_create(admm_env%S_inv,fm_struct_aux_aux,name="aux_fit_overlap_inv") + CALL cp_fm_create(admm_env%Q,fm_struct_aux_orb,name="mixed_overlap") + CALL cp_fm_create(admm_env%A,fm_struct_aux_orb,name="work_A") + CALL cp_fm_create(admm_env%B,fm_struct_orb_orb,name="work_B") + CALL cp_fm_create(admm_env%work_orb_orb,fm_struct_orb_orb,name="work_orb_orb") + CALL cp_fm_create(admm_env%work_orb_orb2,fm_struct_orb_orb,name="work_orb_orb") + CALL cp_fm_create(admm_env%work_orb_orb3,fm_struct_orb_orb,name="work_orb_orb3") + CALL cp_fm_create(admm_env%work_aux_orb,fm_struct_aux_orb,name="work_aux_orb") + CALL cp_fm_create(admm_env%work_aux_orb2,fm_struct_aux_orb,name="work_aux_orb2") + CALL cp_fm_create(admm_env%work_aux_orb3,fm_struct_aux_orb,name="work_aux_orb3") + CALL cp_fm_create(admm_env%work_aux_aux,fm_struct_aux_aux,name="work_aux_aux") + CALL cp_fm_create(admm_env%work_aux_aux2,fm_struct_aux_aux,name="work_aux_aux2") + CALL cp_fm_create(admm_env%work_aux_aux3,fm_struct_aux_aux,name="work_aux_aux3") + CALL cp_fm_create(admm_env%work_aux_aux4,fm_struct_aux_aux,name="work_aux_aux4") + CALL cp_fm_create(admm_env%work_aux_aux5,fm_struct_aux_aux,name="work_aux_aux5") ALLOCATE(admm_env%lambda_inv(nspins)) ALLOCATE(admm_env%lambda(nspins)) @@ -253,45 +247,42 @@ SUBROUTINE admm_env_create(admm_env, admm_control, mos, mos_aux_fit, para_env, n context=mo_coeff%matrix_struct%context,& nrow_global=nao_aux_fit,& ncol_global=nmo,& - para_env=para_env,& - error=error) + para_env=para_env) CALL cp_fm_struct_create(fm_struct_orb_nmo,& context=mo_coeff%matrix_struct%context,& nrow_global=nao_orb,& ncol_global=nmo,& - para_env=para_env,& - error=error) + para_env=para_env) CALL cp_fm_struct_create(fm_struct_nmo_nmo,& context=mo_coeff%matrix_struct%context,& nrow_global=nmo,& ncol_global=nmo,& - para_env=para_env,& - error=error) - - CALL cp_fm_create(admm_env%work_orb_nmo(ispin)%matrix,fm_struct_orb_nmo,name="work_orb_nmo",error=error) - CALL cp_fm_create(admm_env%work_nmo_nmo1(ispin)%matrix,fm_struct_nmo_nmo,name="work_nmo_nmo1",error=error) - CALL cp_fm_create(admm_env%R_schur_R_t(ispin)%matrix,fm_struct_nmo_nmo,name="R_schur_R_t",error=error) - CALL cp_fm_create(admm_env%work_nmo_nmo2(ispin)%matrix,fm_struct_nmo_nmo,name="work_nmo_nmo2",error=error) - CALL cp_fm_create(admm_env%lambda(ispin)%matrix,fm_struct_nmo_nmo,name="lambda",error=error) - CALL cp_fm_create(admm_env%lambda_inv(ispin)%matrix,fm_struct_nmo_nmo,name="lambda_inv",error=error) - CALL cp_fm_create(admm_env%lambda_inv_sqrt(ispin)%matrix,fm_struct_nmo_nmo,name="lambda_inv_sqrt",error=error) - CALL cp_fm_create(admm_env%R(ispin)%matrix,fm_struct_nmo_nmo,name="R",error=error) - CALL cp_fm_create(admm_env%R_purify(ispin)%matrix,fm_struct_aux_aux,name="R_purify",error=error) - CALL cp_fm_create(admm_env%K(ispin)%matrix,fm_struct_aux_aux,name="K",error=error) - CALL cp_fm_create(admm_env%H(ispin)%matrix,fm_struct_aux_nmo,name="H",error=error) - CALL cp_fm_create(admm_env%H_corr(ispin)%matrix,fm_struct_orb_orb,name="H_corr",error=error) - CALL cp_fm_create(admm_env%M(ispin)%matrix,fm_struct_nmo_nmo,name="M",error=error) - CALL cp_fm_create(admm_env%M_purify(ispin)%matrix,fm_struct_aux_aux,name="M aux",error=error) - CALL cp_fm_create(admm_env%P_to_be_purified(ispin)%matrix,fm_struct_aux_aux,name="P_to_be_purified",error=error) - CALL cp_fm_create(admm_env%work_aux_nmo(ispin)%matrix,fm_struct_aux_nmo,name="work_aux_nmo",error=error) - CALL cp_fm_create(admm_env%work_aux_nmo2(ispin)%matrix,fm_struct_aux_nmo,name="work_aux_nmo2",error=error) - CALL cp_fm_create(admm_env%mo_derivs_tmp(ispin)%matrix,fm_struct_orb_nmo,name="mo_derivs_tmp",error=error) - - CALL cp_fm_create(admm_env%lambda_inv2(ispin)%matrix,fm_struct_nmo_nmo,name="lambda_inv2",error=error) - CALL cp_fm_create(admm_env%C_hat(ispin)%matrix,fm_struct_aux_nmo,name="C_hat",error=error) - CALL cp_fm_create(admm_env%P_tilde(ispin)%matrix,fm_struct_aux_aux,name="P_tilde",error=error) - - CALL cp_fm_create(admm_env%ks_to_be_merged(ispin)%matrix,fm_struct_orb_orb,name="KS_to_be_merged ",error=error) + para_env=para_env) + + CALL cp_fm_create(admm_env%work_orb_nmo(ispin)%matrix,fm_struct_orb_nmo,name="work_orb_nmo") + CALL cp_fm_create(admm_env%work_nmo_nmo1(ispin)%matrix,fm_struct_nmo_nmo,name="work_nmo_nmo1") + CALL cp_fm_create(admm_env%R_schur_R_t(ispin)%matrix,fm_struct_nmo_nmo,name="R_schur_R_t") + CALL cp_fm_create(admm_env%work_nmo_nmo2(ispin)%matrix,fm_struct_nmo_nmo,name="work_nmo_nmo2") + CALL cp_fm_create(admm_env%lambda(ispin)%matrix,fm_struct_nmo_nmo,name="lambda") + CALL cp_fm_create(admm_env%lambda_inv(ispin)%matrix,fm_struct_nmo_nmo,name="lambda_inv") + CALL cp_fm_create(admm_env%lambda_inv_sqrt(ispin)%matrix,fm_struct_nmo_nmo,name="lambda_inv_sqrt") + CALL cp_fm_create(admm_env%R(ispin)%matrix,fm_struct_nmo_nmo,name="R") + CALL cp_fm_create(admm_env%R_purify(ispin)%matrix,fm_struct_aux_aux,name="R_purify") + CALL cp_fm_create(admm_env%K(ispin)%matrix,fm_struct_aux_aux,name="K") + CALL cp_fm_create(admm_env%H(ispin)%matrix,fm_struct_aux_nmo,name="H") + CALL cp_fm_create(admm_env%H_corr(ispin)%matrix,fm_struct_orb_orb,name="H_corr") + CALL cp_fm_create(admm_env%M(ispin)%matrix,fm_struct_nmo_nmo,name="M") + CALL cp_fm_create(admm_env%M_purify(ispin)%matrix,fm_struct_aux_aux,name="M aux") + CALL cp_fm_create(admm_env%P_to_be_purified(ispin)%matrix,fm_struct_aux_aux,name="P_to_be_purified") + CALL cp_fm_create(admm_env%work_aux_nmo(ispin)%matrix,fm_struct_aux_nmo,name="work_aux_nmo") + CALL cp_fm_create(admm_env%work_aux_nmo2(ispin)%matrix,fm_struct_aux_nmo,name="work_aux_nmo2") + CALL cp_fm_create(admm_env%mo_derivs_tmp(ispin)%matrix,fm_struct_orb_nmo,name="mo_derivs_tmp") + + CALL cp_fm_create(admm_env%lambda_inv2(ispin)%matrix,fm_struct_nmo_nmo,name="lambda_inv2") + CALL cp_fm_create(admm_env%C_hat(ispin)%matrix,fm_struct_aux_nmo,name="C_hat") + CALL cp_fm_create(admm_env%P_tilde(ispin)%matrix,fm_struct_aux_aux,name="P_tilde") + + CALL cp_fm_create(admm_env%ks_to_be_merged(ispin)%matrix,fm_struct_orb_orb,name="KS_to_be_merged ") ALLOCATE(admm_env%eigvals_lambda(ispin)%eigvals) ALLOCATE(admm_env%eigvals_P_to_be_purified(ispin)%eigvals) @@ -299,15 +290,15 @@ SUBROUTINE admm_env_create(admm_env, admm_control, mos, mos_aux_fit, para_env, n ALLOCATE(admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data(nao_aux_fit)) admm_env%eigvals_lambda(ispin)%eigvals%data = 0.0_dp admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data = 0.0_dp - CALL cp_fm_struct_release(fm_struct_aux_nmo,error=error) - CALL cp_fm_struct_release(fm_struct_orb_nmo,error=error) - CALL cp_fm_struct_release(fm_struct_nmo_nmo,error=error) + CALL cp_fm_struct_release(fm_struct_aux_nmo) + CALL cp_fm_struct_release(fm_struct_orb_nmo) + CALL cp_fm_struct_release(fm_struct_nmo_nmo) END DO - CALL cp_fm_struct_release(fm_struct_aux_aux,error=error) - CALL cp_fm_struct_release(fm_struct_aux_orb,error=error) - CALL cp_fm_struct_release(fm_struct_orb_aux,error=error) - CALL cp_fm_struct_release(fm_struct_orb_orb,error=error) + CALL cp_fm_struct_release(fm_struct_aux_aux) + CALL cp_fm_struct_release(fm_struct_aux_orb) + CALL cp_fm_struct_release(fm_struct_orb_aux) + CALL cp_fm_struct_release(fm_struct_orb_orb) ! copy settings from admm_control admm_env%purification_method = admm_control%purification_method @@ -341,61 +332,58 @@ END SUBROUTINE admm_env_create !> \brief releases the ADMM environment, cleans up all types !> !> \param admm_env The ADMM env -!> \param error ... -!> !> \par History !> 05.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE admm_env_release(admm_env, error) + SUBROUTINE admm_env_release(admm_env) TYPE(admm_type), POINTER :: admm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'admm_env_release', & routineP = moduleN//':'//routineN INTEGER :: ispin - CALL cp_fm_release(admm_env%S, error=error) - CALL cp_fm_release(admm_env%S_inv, error=error) - CALL cp_fm_release(admm_env%Q, error=error) - CALL cp_fm_release(admm_env%A, error=error) - CALL cp_fm_release(admm_env%B, error=error) - CALL cp_fm_release(admm_env%work_orb_orb, error=error) - CALL cp_fm_release(admm_env%work_orb_orb2, error=error) - CALL cp_fm_release(admm_env%work_orb_orb3, error=error) - CALL cp_fm_release(admm_env%work_aux_aux, error=error) - CALL cp_fm_release(admm_env%work_aux_aux2, error=error) - CALL cp_fm_release(admm_env%work_aux_aux3, error=error) - CALL cp_fm_release(admm_env%work_aux_aux4, error=error) - CALL cp_fm_release(admm_env%work_aux_aux5, error=error) - CALL cp_fm_release(admm_env%work_aux_orb, error=error) - CALL cp_fm_release(admm_env%work_aux_orb2, error=error) - CALL cp_fm_release(admm_env%work_aux_orb3, error=error) + CALL cp_fm_release(admm_env%S) + CALL cp_fm_release(admm_env%S_inv) + CALL cp_fm_release(admm_env%Q) + CALL cp_fm_release(admm_env%A) + CALL cp_fm_release(admm_env%B) + CALL cp_fm_release(admm_env%work_orb_orb) + CALL cp_fm_release(admm_env%work_orb_orb2) + CALL cp_fm_release(admm_env%work_orb_orb3) + CALL cp_fm_release(admm_env%work_aux_aux) + CALL cp_fm_release(admm_env%work_aux_aux2) + CALL cp_fm_release(admm_env%work_aux_aux3) + CALL cp_fm_release(admm_env%work_aux_aux4) + CALL cp_fm_release(admm_env%work_aux_aux5) + CALL cp_fm_release(admm_env%work_aux_orb) + CALL cp_fm_release(admm_env%work_aux_orb2) + CALL cp_fm_release(admm_env%work_aux_orb3) DO ispin = 1,SIZE(admm_env%lambda) - CALL cp_fm_release(admm_env%lambda(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%lambda_inv(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%lambda_inv_sqrt(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%lambda_inv2(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%C_hat(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%P_tilde(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%R(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%R_purify(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%H(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%H_corr(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%K(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%M(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%M_purify(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%P_to_be_purified(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%work_orb_nmo(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%work_nmo_nmo1(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%R_schur_R_t(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%work_nmo_nmo2(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%work_aux_nmo(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%work_aux_nmo2(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%mo_derivs_tmp(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%ks_to_be_merged(ispin)%matrix, error=error) - CALL cp_fm_release(admm_env%lambda_inv2(ispin)%matrix, error=error) + CALL cp_fm_release(admm_env%lambda(ispin)%matrix) + CALL cp_fm_release(admm_env%lambda_inv(ispin)%matrix) + CALL cp_fm_release(admm_env%lambda_inv_sqrt(ispin)%matrix) + CALL cp_fm_release(admm_env%lambda_inv2(ispin)%matrix) + CALL cp_fm_release(admm_env%C_hat(ispin)%matrix) + CALL cp_fm_release(admm_env%P_tilde(ispin)%matrix) + CALL cp_fm_release(admm_env%R(ispin)%matrix) + CALL cp_fm_release(admm_env%R_purify(ispin)%matrix) + CALL cp_fm_release(admm_env%H(ispin)%matrix) + CALL cp_fm_release(admm_env%H_corr(ispin)%matrix) + CALL cp_fm_release(admm_env%K(ispin)%matrix) + CALL cp_fm_release(admm_env%M(ispin)%matrix) + CALL cp_fm_release(admm_env%M_purify(ispin)%matrix) + CALL cp_fm_release(admm_env%P_to_be_purified(ispin)%matrix) + CALL cp_fm_release(admm_env%work_orb_nmo(ispin)%matrix) + CALL cp_fm_release(admm_env%work_nmo_nmo1(ispin)%matrix) + CALL cp_fm_release(admm_env%R_schur_R_t(ispin)%matrix) + CALL cp_fm_release(admm_env%work_nmo_nmo2(ispin)%matrix) + CALL cp_fm_release(admm_env%work_aux_nmo(ispin)%matrix) + CALL cp_fm_release(admm_env%work_aux_nmo2(ispin)%matrix) + CALL cp_fm_release(admm_env%mo_derivs_tmp(ispin)%matrix) + CALL cp_fm_release(admm_env%ks_to_be_merged(ispin)%matrix) + CALL cp_fm_release(admm_env%lambda_inv2(ispin)%matrix) DEALLOCATE(admm_env%eigvals_lambda(ispin)%eigvals%data) DEALLOCATE(admm_env%eigvals_P_to_be_purified(ispin)%eigvals%data) DEALLOCATE(admm_env%eigvals_lambda(ispin)%eigvals) @@ -430,9 +418,9 @@ SUBROUTINE admm_env_release(admm_env, error) DEALLOCATE(admm_env%block_map) IF(ASSOCIATED(admm_env%xc_section_primary))& - CALL section_vals_release(admm_env%xc_section_primary,error) + CALL section_vals_release(admm_env%xc_section_primary) IF(ASSOCIATED(admm_env%xc_section_aux))& - CALL section_vals_release(admm_env%xc_section_aux,error) + CALL section_vals_release(admm_env%xc_section_aux) DEALLOCATE(admm_env) diff --git a/src/admm_utils.F b/src/admm_utils.F index 8edce99512..d63a3c0008 100644 --- a/src/admm_utils.F +++ b/src/admm_utils.F @@ -45,13 +45,11 @@ MODULE admm_utils !> \param ispin ... !> \param admm_env ... !> \param ks_matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE admm_correct_for_eigenvalues(ispin, admm_env, ks_matrix, error) + SUBROUTINE admm_correct_for_eigenvalues(ispin, admm_env, ks_matrix) INTEGER, INTENT(IN) :: ispin TYPE(admm_type), POINTER :: admm_env TYPE(cp_dbcsr_type), POINTER :: ks_matrix - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: nao_aux_fit, nao_orb TYPE(cp_dbcsr_type), POINTER :: work @@ -65,62 +63,58 @@ SUBROUTINE admm_correct_for_eigenvalues(ispin, admm_env, ks_matrix, error) !* remove what has been added and add the correction NULLIFY(work) ALLOCATE(work) - CALL cp_dbcsr_init (work, error) + CALL cp_dbcsr_init (work) CALL cp_dbcsr_create(work, 'work', & cp_dbcsr_distribution(ks_matrix), dbcsr_type_symmetric, cp_dbcsr_row_block_sizes(ks_matrix),& cp_dbcsr_col_block_sizes(ks_matrix), & cp_dbcsr_get_data_size(ks_matrix),& - cp_dbcsr_get_data_type(ks_matrix), error=error) + cp_dbcsr_get_data_type(ks_matrix)) - CALL cp_dbcsr_copy(work, ks_matrix, error=error) - CALL cp_dbcsr_set(work, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%ks_to_be_merged(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL cp_dbcsr_copy(work, ks_matrix) + CALL cp_dbcsr_set(work, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%ks_to_be_merged(ispin)%matrix, work, keep_sparsity=.TRUE.) - CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, -1.0_dp, error) + CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, -1.0_dp) ! ** calculate A^T*H_tilde*A CALL cp_gemm('N','N',nao_aux_fit,nao_orb,nao_aux_fit,& 1.0_dp, admm_env%K(ispin)%matrix,admm_env%A, 0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) CALL cp_gemm('T','N',nao_orb,nao_orb,nao_aux_fit,& 1.0_dp, admm_env%A, admm_env%work_aux_orb ,0.0_dp,& - admm_env%H_corr(ispin)%matrix,error) + admm_env%H_corr(ispin)%matrix) - CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.) - CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, 1.0_dp, error) - CALL cp_dbcsr_deallocate_matrix(work,error) + CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, 1.0_dp) + CALL cp_dbcsr_deallocate_matrix(work) CASE(do_admm_purify_mo_diag) !* remove what has been added and add the correction NULLIFY(work) ALLOCATE(work) - CALL cp_dbcsr_init (work, error) + CALL cp_dbcsr_init (work) CALL cp_dbcsr_create(work, 'work', & cp_dbcsr_distribution(ks_matrix), dbcsr_type_symmetric, cp_dbcsr_row_block_sizes(ks_matrix),& cp_dbcsr_col_block_sizes(ks_matrix), cp_dbcsr_get_data_size(ks_matrix),& - cp_dbcsr_get_data_type(ks_matrix), error=error) + cp_dbcsr_get_data_type(ks_matrix)) - CALL cp_dbcsr_copy(work, ks_matrix, error=error) - CALL cp_dbcsr_set(work, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%ks_to_be_merged(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL cp_dbcsr_copy(work, ks_matrix) + CALL cp_dbcsr_set(work, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%ks_to_be_merged(ispin)%matrix, work, keep_sparsity=.TRUE.) ! ** calculate A^T*H_tilde*A CALL cp_gemm('N','N',nao_aux_fit,nao_orb,nao_aux_fit,& 1.0_dp, admm_env%K(ispin)%matrix,admm_env%A, 0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) CALL cp_gemm('T','N',nao_orb,nao_orb,nao_aux_fit,& 1.0_dp, admm_env%A, admm_env%work_aux_orb ,0.0_dp,& - admm_env%H_corr(ispin)%matrix,error) + admm_env%H_corr(ispin)%matrix) - CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.) - CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, 1.0_dp, error) - CALL cp_dbcsr_deallocate_matrix(work,error) + CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, 1.0_dp) + CALL cp_dbcsr_deallocate_matrix(work) CASE(do_admm_purify_mo_no_diag, do_admm_purify_none, do_admm_purify_cauchy) ! do nothing @@ -135,13 +129,11 @@ END SUBROUTINE admm_correct_for_eigenvalues !> \param ispin ... !> \param admm_env ... !> \param ks_matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_matrix, error) + SUBROUTINE admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_matrix) INTEGER, INTENT(IN) :: ispin TYPE(admm_type), POINTER :: admm_env TYPE(cp_dbcsr_type), POINTER :: ks_matrix - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: nao_aux_fit, nao_orb TYPE(cp_dbcsr_type), POINTER :: work @@ -155,46 +147,42 @@ SUBROUTINE admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_matrix, error) !* remove what has been added and add the correction NULLIFY(work) ALLOCATE(work) - CALL cp_dbcsr_init (work, error) + CALL cp_dbcsr_init (work) CALL cp_dbcsr_create(work, 'work', & cp_dbcsr_distribution(ks_matrix), dbcsr_type_symmetric, cp_dbcsr_row_block_sizes(ks_matrix),& cp_dbcsr_col_block_sizes(ks_matrix), cp_dbcsr_get_data_size(ks_matrix),& - cp_dbcsr_get_data_type(ks_matrix), error=error) + cp_dbcsr_get_data_type(ks_matrix)) - CALL cp_dbcsr_copy(work, ks_matrix, error=error) - CALL cp_dbcsr_set(work, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL cp_dbcsr_copy(work, ks_matrix) + CALL cp_dbcsr_set(work, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.) - CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, -1.0_dp, error) + CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, -1.0_dp) - CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.) - CALL cp_dbcsr_set(work, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%ks_to_be_merged(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL cp_dbcsr_set(work, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%ks_to_be_merged(ispin)%matrix, work, keep_sparsity=.TRUE.) - CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, 1.0_dp, error) - CALL cp_dbcsr_deallocate_matrix(work,error) + CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, 1.0_dp) + CALL cp_dbcsr_deallocate_matrix(work) CASE(do_admm_purify_mo_diag) NULLIFY(work) ALLOCATE(work) - CALL cp_dbcsr_init (work, error) + CALL cp_dbcsr_init (work) CALL cp_dbcsr_create(work, 'work', & cp_dbcsr_distribution(ks_matrix), dbcsr_type_symmetric, cp_dbcsr_row_block_sizes(ks_matrix),& cp_dbcsr_col_block_sizes(ks_matrix), cp_dbcsr_get_data_size(ks_matrix),& - cp_dbcsr_get_data_type(ks_matrix), error=error) + cp_dbcsr_get_data_type(ks_matrix)) - CALL cp_dbcsr_copy(work, ks_matrix, error=error) - CALL cp_dbcsr_set(work, 0.0_dp, error) + CALL cp_dbcsr_copy(work, ks_matrix) + CALL cp_dbcsr_set(work, 0.0_dp) - CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(admm_env%H_corr(ispin)%matrix, work, keep_sparsity=.TRUE.) - CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, -1.0_dp, error) - CALL cp_dbcsr_deallocate_matrix(work,error) + CALL cp_dbcsr_add(ks_matrix, work, 1.0_dp, -1.0_dp) + CALL cp_dbcsr_deallocate_matrix(work) CASE(do_admm_purify_mo_no_diag, do_admm_purify_none, do_admm_purify_cauchy) ! do nothing diff --git a/src/al_system_types.F b/src/al_system_types.F index d7e16257ac..7f916b834c 100644 --- a/src/al_system_types.F +++ b/src/al_system_types.F @@ -55,15 +55,12 @@ MODULE al_system_types !> \param al ... !> \param simpar ... !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** - SUBROUTINE al_init(al, simpar, section, error) + SUBROUTINE al_init(al, simpar, section) TYPE(al_system_type), POINTER :: al TYPE(simpar_type), POINTER :: simpar TYPE(section_vals_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'al_init', & routineP = moduleN//':'//routineN @@ -75,22 +72,19 @@ SUBROUTINE al_init(al, simpar, section, error) al%dt_fact=1.0_dp al%dt=simpar%dt CALL cite_reference(Jones2011) - CALL section_vals_val_get(section,"TIMECON_NH",r_val=al%tau_nh,error=error) - CALL section_vals_val_get(section,"TIMECON_LANGEVIN",r_val=al%tau_langevin,error=error) - CALL create_map_info_type(al%map_info, error) + CALL section_vals_val_get(section,"TIMECON_NH",r_val=al%tau_nh) + CALL section_vals_val_get(section,"TIMECON_LANGEVIN",r_val=al%tau_langevin) + CALL create_map_info_type(al%map_info) END SUBROUTINE al_init ! ***************************************************************************** !> \brief Initialize NVT type for AD_LANGEVIN thermostat !> \param al ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** - SUBROUTINE al_thermo_create(al, error) + SUBROUTINE al_thermo_create(al) TYPE(al_system_type), POINTER :: al - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'al_thermo_create', & routineP = moduleN//':'//routineN @@ -101,30 +95,27 @@ SUBROUTINE al_thermo_create(al, error) DIMENSION(:, :, :) :: seed failure = .FALSE. - CPPrecondition(ASSOCIATED(al),cp_fatal_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(al%nvt),cp_fatal_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(al),cp_fatal_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(al%nvt),cp_fatal_level,routineP,failure) ALLOCATE ( al%nvt(al%loc_num_al),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, al%loc_num_al al%nvt(i)%chi = 0.0_dp END DO ! Initialize the gaussian stream random number ALLOCATE (seed(3,2,al%glob_num_al),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE al_thermo_create ! ***************************************************************************** !> \brief Deallocate type for AD_LANGEVIN thermostat !> \param al ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** - SUBROUTINE al_dealloc ( al, error ) + SUBROUTINE al_dealloc ( al) TYPE(al_system_type), POINTER :: al - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'al_dealloc', & routineP = moduleN//':'//routineN @@ -134,10 +125,10 @@ SUBROUTINE al_dealloc ( al, error ) failure = .FALSE. IF (ASSOCIATED(al)) THEN - CALL al_thermo_dealloc(al%nvt, error) - CALL release_map_info_type(al%map_info, error) + CALL al_thermo_dealloc(al%nvt) + CALL release_map_info_type(al%map_info) DEALLOCATE (al, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF END SUBROUTINE al_dealloc @@ -145,14 +136,11 @@ END SUBROUTINE al_dealloc ! ***************************************************************************** !> \brief Deallocate NVT type for AD_LANGEVIN thermostat !> \param nvt ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** - SUBROUTINE al_thermo_dealloc ( nvt, error ) + SUBROUTINE al_thermo_dealloc ( nvt) TYPE(al_thermo_type), DIMENSION(:), & POINTER :: nvt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'al_thermo_dealloc', & routineP = moduleN//':'//routineN @@ -163,7 +151,7 @@ SUBROUTINE al_thermo_dealloc ( nvt, error ) failure = .FALSE. IF (ASSOCIATED(nvt)) THEN DEALLOCATE (nvt, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF END SUBROUTINE al_thermo_dealloc diff --git a/src/almo_scf.F b/src/almo_scf.F index db298aaaac..b38e7a51ed 100644 --- a/src/almo_scf.F +++ b/src/almo_scf.F @@ -83,15 +83,13 @@ MODULE almo_scf !> \brief The entry point into ALMO SCF routines !> \param qs_env - pointer to the QS environment !> \param calc_forces - calculate forces? -!> \param error - error !> \par History !> 2011.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_entry_scf(qs_env, calc_forces, error) + SUBROUTINE almo_entry_scf(qs_env, calc_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL :: calc_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_entry_scf', & routineP = moduleN//':'//routineN @@ -109,19 +107,19 @@ SUBROUTINE almo_entry_scf(qs_env, calc_forces, error) CPSourceFileRef, only_ionode=.TRUE.) ! initialize scf - CALL almo_scf_init(qs_env,almo_scf_env,error) + CALL almo_scf_init(qs_env,almo_scf_env) ! perform SCF for block diagonal ALMOs - CALL almo_scf_main(qs_env,almo_scf_env,error) + CALL almo_scf_main(qs_env,almo_scf_env) ! allow electron delocalization - CALL almo_scf_delocalization(qs_env,almo_scf_env,error) + CALL almo_scf_delocalization(qs_env,almo_scf_env) ! return computed quantities to the qs_env - !CALL almo_return_to_qs(qs_env,almo_scf_env,error) + !CALL almo_return_to_qs(qs_env,almo_scf_env) ! do post scf processing - CALL almo_scf_clean_up(almo_scf_env,error) + CALL almo_scf_clean_up(almo_scf_env) CALL timestop(handle) @@ -131,15 +129,13 @@ END SUBROUTINE almo_entry_scf !> \brief Initialization of the almo_scf_env_type. !> \param qs_env ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) + SUBROUTINE almo_scf_init(qs_env,almo_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_init', & routineP = moduleN//':'//routineN @@ -159,7 +155,7 @@ SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) failure = .FALSE. ! define the output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -182,10 +178,9 @@ SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) has_unit_metric=almo_scf_env%orthogonal_basis,& para_env=almo_scf_env%para_env,& blacs_env=almo_scf_env%blacs_env,& - nelectron_spin=almo_scf_env%nelectrons_spin,& - error=error) - CALL cp_para_env_retain(almo_scf_env%para_env,error) - CALL cp_blacs_env_retain(almo_scf_env%blacs_env, error) + nelectron_spin=almo_scf_env%nelectrons_spin) + CALL cp_para_env_retain(almo_scf_env%para_env) + CALL cp_blacs_env_retain(almo_scf_env%blacs_env) ! copy basic quantities almo_scf_env%nspins=dft_control%nspins @@ -200,7 +195,7 @@ SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) natoms=almo_scf_env%natoms ! parse the almo_scf section and set appropriate quantities - CALL almo_scf_init_read_write_input(input,almo_scf_env,error) + CALL almo_scf_init_read_write_input(input,almo_scf_env) ! Define groups: either atomic or molecular IF (almo_scf_env%domain_layout_mos==almo_domain_layout_molecular) THEN @@ -235,8 +230,7 @@ SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) mol_to_nelectrons=almo_scf_env%nocc_of_domain(1:ndomains,1),& mol_to_nbasis=almo_scf_env%nbasis_of_domain,& mol_to_charge=almo_scf_env%charge_of_domain,& - mol_to_multiplicity=almo_scf_env%multiplicity_of_domain,& - error=error) + mol_to_multiplicity=almo_scf_env%multiplicity_of_domain) ! calculate number of alpha and beta occupied orbitals from ! the number of electrons and multiplicity of each molecule ! Na + Nb = Ne @@ -250,14 +244,14 @@ SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) IF (nelec_a.ne.nelec_b) THEN IF (nspins.eq.1) THEN WRITE(*,*) "Domain ", idomain, " out of ", ndomains, ". Electrons = ", nelec - CPErrorMessage(cp_failure_level,routineP,"odd e- -- use unrestricted methods",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"odd e- -- use unrestricted methods") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF almo_scf_env%nocc_of_domain(idomain,2)=nelec_b ! RZK-warning: open-shell procedures have not been tested yet ! Stop the program now - CPErrorMessage(cp_failure_level,routineP,"Unrestricted ALMO methods are NYI",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Unrestricted ALMO methods are NYI") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDDO DO ispin=1,nspins @@ -290,8 +284,8 @@ SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) almo_scf_env%nvirt_of_domain(idomain,ispin) ENDDO CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"illegal method for virtual space truncation",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal method for virtual space truncation") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ENDDO ! spin ELSE ! domains are atomic @@ -345,43 +339,43 @@ SUBROUTINE almo_scf_init(qs_env,almo_scf_env,error) !ENDIF ! create all matrices - CALL almo_scf_env_create_matrices(almo_scf_env,matrix_s(1)%matrix,error) + CALL almo_scf_env_create_matrices(almo_scf_env,matrix_s(1)%matrix) ! set up matrix S and all required functions of S almo_scf_env%s_inv_done=.FALSE. almo_scf_env%s_sqrt_done=.FALSE. - CALL almo_scf_init_ao_overlap(matrix_s(1)%matrix,almo_scf_env,error) + CALL almo_scf_init_ao_overlap(matrix_s(1)%matrix,almo_scf_env) ! create the quencher (imposes sparsity template) - CALL almo_scf_construct_quencher(qs_env,almo_scf_env,error) - CALL distribute_domains(almo_scf_env,error) + CALL almo_scf_construct_quencher(qs_env,almo_scf_env) + CALL distribute_domains(almo_scf_env) ! FINISH setting job parameters here, print out job info - CALL almo_scf_print_job_info(almo_scf_env,unit_nr,error) + CALL almo_scf_print_job_info(almo_scf_env,unit_nr) ! allocate and init the domain preconditioner ALLOCATE(almo_scf_env%domain_preconditioner(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_preconditioner,error) + CALL init_submatrices(almo_scf_env%domain_preconditioner) ! allocate and init projected KS for domains ALLOCATE(almo_scf_env%domain_ks_xx(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_ks_xx,error) + CALL init_submatrices(almo_scf_env%domain_ks_xx) ! init ao-overlap subblocks ALLOCATE(almo_scf_env%domain_s_inv(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_s_inv,error) + CALL init_submatrices(almo_scf_env%domain_s_inv) ALLOCATE(almo_scf_env%domain_s_sqrt_inv(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_s_sqrt_inv,error) + CALL init_submatrices(almo_scf_env%domain_s_sqrt_inv) ALLOCATE(almo_scf_env%domain_s_sqrt(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_s_sqrt,error) + CALL init_submatrices(almo_scf_env%domain_s_sqrt) ALLOCATE(almo_scf_env%domain_t(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_t,error=error) + CALL init_submatrices(almo_scf_env%domain_t) ALLOCATE(almo_scf_env%domain_err(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_err,error=error) + CALL init_submatrices(almo_scf_env%domain_err) ALLOCATE(almo_scf_env%domain_r_down_up(ndomains,nspins)) - CALL init_submatrices(almo_scf_env%domain_r_down_up,error=error) + CALL init_submatrices(almo_scf_env%domain_r_down_up) ! initialization of the QS settings with the ALMO flavor - CALL almo_scf_init_qs(qs_env,almo_scf_env,error) + CALL almo_scf_init_qs(qs_env,almo_scf_env) CALL timestop(handle) @@ -391,15 +385,13 @@ END SUBROUTINE almo_scf_init !> \brief Parses the ALMO input section !> \param input ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_init_read_write_input(input,almo_scf_env,error) + SUBROUTINE almo_scf_init_read_write_input(input,almo_scf_env) TYPE(section_vals_type), POINTER :: input TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'almo_scf_init_read_write_input', & @@ -413,13 +405,13 @@ SUBROUTINE almo_scf_init_read_write_input(input,almo_scf_env,error) CALL timeset(routineN,handle) failure=.FALSE. - almo_scf_section => section_vals_get_subs_vals(input,"DFT%ALMO_SCF",error=error) + almo_scf_section => section_vals_get_subs_vals(input,"DFT%ALMO_SCF") almo_opt_diis_section => section_vals_get_subs_vals(almo_scf_section,& - "ALMO_OPTIMIZER_DIIS",error=error) + "ALMO_OPTIMIZER_DIIS") almo_opt_pcg_section => section_vals_get_subs_vals(almo_scf_section,& - "ALMO_OPTIMIZER_PCG",error=error) + "ALMO_OPTIMIZER_PCG") xalmo_opt_pcg_section => section_vals_get_subs_vals(almo_scf_section,& - "XALMO_OPTIMIZER_PCG",error=error) + "XALMO_OPTIMIZER_PCG") ! RZK-warning the values of these keywords are hardcoded ! but ideally they should also be read from the input file @@ -430,187 +422,154 @@ SUBROUTINE almo_scf_init_read_write_input(input,almo_scf_env,error) ! read user input ! common ALMO options CALL section_vals_val_get(almo_scf_section,"EPS_FILTER",& - r_val=almo_scf_env%eps_filter,error=error) + r_val=almo_scf_env%eps_filter) CALL section_vals_val_get(almo_scf_section,"ALMO_SCF_GUESS",& - i_val=almo_scf_env%almo_scf_guess,& - error=error) + i_val=almo_scf_env%almo_scf_guess) CALL section_vals_val_get(almo_scf_section,"ALMO_ALGORITHM",& - i_val=almo_scf_env%almo_update_algorithm,& - error=error) + i_val=almo_scf_env%almo_update_algorithm) CALL section_vals_val_get(almo_scf_section,"DELOCALIZE_METHOD",& - i_val=almo_scf_env%deloc_method,error=error) + i_val=almo_scf_env%deloc_method) CALL section_vals_val_get(almo_scf_section,"XALMO_R_CUTOFF_FACTOR",& - r_val=almo_scf_env%quencher_r0_factor,& - error=error) + r_val=almo_scf_env%quencher_r0_factor) ! optimizers CALL section_vals_val_get(almo_opt_diis_section,"EPS_ERROR",& - r_val=almo_scf_env%opt_block_diag_diis%eps_error,& - error=error) + r_val=almo_scf_env%opt_block_diag_diis%eps_error) CALL section_vals_val_get(almo_opt_diis_section,"MAX_ITER",& - i_val=almo_scf_env%opt_block_diag_diis%max_iter,error=error) + i_val=almo_scf_env%opt_block_diag_diis%max_iter) CALL section_vals_val_get(almo_opt_diis_section,"N_DIIS",& - i_val=almo_scf_env%opt_block_diag_diis%ndiis,error=error) + i_val=almo_scf_env%opt_block_diag_diis%ndiis) CALL section_vals_val_get(almo_opt_pcg_section,"EPS_ERROR",& - r_val=almo_scf_env%opt_block_diag_pcg%eps_error,& - error=error) + r_val=almo_scf_env%opt_block_diag_pcg%eps_error) CALL section_vals_val_get(almo_opt_pcg_section,"MAX_ITER",& - i_val=almo_scf_env%opt_block_diag_pcg%max_iter,error=error) + i_val=almo_scf_env%opt_block_diag_pcg%max_iter) CALL section_vals_val_get(almo_opt_pcg_section,"MAX_ITER_OUTER_LOOP",& - i_val=almo_scf_env%opt_block_diag_pcg%max_iter_outer_loop,error=error) + i_val=almo_scf_env%opt_block_diag_pcg%max_iter_outer_loop) CALL section_vals_val_get(almo_opt_pcg_section,"LIN_SEARCH_EPS_ERROR",& - r_val=almo_scf_env%opt_block_diag_pcg%lin_search_eps_error,error=error) + r_val=almo_scf_env%opt_block_diag_pcg%lin_search_eps_error) CALL section_vals_val_get(almo_opt_pcg_section,"LIN_SEARCH_STEP_SIZE_GUESS",& - r_val=almo_scf_env%opt_block_diag_pcg%lin_search_step_size_guess,error=error) + r_val=almo_scf_env%opt_block_diag_pcg%lin_search_step_size_guess) CALL section_vals_val_get(almo_opt_pcg_section,"CONJUGATOR",& - i_val=almo_scf_env%opt_block_diag_pcg%conjugator,error=error) + i_val=almo_scf_env%opt_block_diag_pcg%conjugator) CALL section_vals_val_get(almo_opt_pcg_section,"PRECONDITIONER",& - i_val=almo_scf_env%opt_block_diag_pcg%preconditioner,error=error) + i_val=almo_scf_env%opt_block_diag_pcg%preconditioner) CALL section_vals_val_get(xalmo_opt_pcg_section,"EPS_ERROR",& - r_val=almo_scf_env%opt_xalmo_pcg%eps_error,& - error=error) + r_val=almo_scf_env%opt_xalmo_pcg%eps_error) CALL section_vals_val_get(xalmo_opt_pcg_section,"MAX_ITER",& - i_val=almo_scf_env%opt_xalmo_pcg%max_iter,error=error) + i_val=almo_scf_env%opt_xalmo_pcg%max_iter) CALL section_vals_val_get(xalmo_opt_pcg_section,"MAX_ITER_OUTER_LOOP",& - i_val=almo_scf_env%opt_xalmo_pcg%max_iter_outer_loop,error=error) + i_val=almo_scf_env%opt_xalmo_pcg%max_iter_outer_loop) CALL section_vals_val_get(xalmo_opt_pcg_section,"LIN_SEARCH_EPS_ERROR",& - r_val=almo_scf_env%opt_xalmo_pcg%lin_search_eps_error,error=error) + r_val=almo_scf_env%opt_xalmo_pcg%lin_search_eps_error) CALL section_vals_val_get(xalmo_opt_pcg_section,"LIN_SEARCH_STEP_SIZE_GUESS",& - r_val=almo_scf_env%opt_xalmo_pcg%lin_search_step_size_guess,error=error) + r_val=almo_scf_env%opt_xalmo_pcg%lin_search_step_size_guess) CALL section_vals_val_get(xalmo_opt_pcg_section,"CONJUGATOR",& - i_val=almo_scf_env%opt_xalmo_pcg%conjugator,error=error) + i_val=almo_scf_env%opt_xalmo_pcg%conjugator) CALL section_vals_val_get(xalmo_opt_pcg_section,"PRECONDITIONER",& - i_val=almo_scf_env%opt_xalmo_pcg%preconditioner,error=error) + i_val=almo_scf_env%opt_xalmo_pcg%preconditioner) ! do not do EDA in the official release until the output files are written ! using the proper CP2K routines almo_scf_env%almo_eda=0 !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_AOS",& - ! i_val=almo_scf_env%domain_layout_aos,error=error) + ! i_val=almo_scf_env%domain_layout_aos) !CALL section_vals_val_get(almo_scf_section,"DOMAIN_LAYOUT_MOS",& - ! i_val=almo_scf_env%domain_layout_mos,error=error) + ! i_val=almo_scf_env%domain_layout_mos) !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_AOS",& - ! i_val=almo_scf_env%mat_distr_aos,error=error) + ! i_val=almo_scf_env%mat_distr_aos) !CALL section_vals_val_get(almo_scf_section,"MATRIX_CLUSTERING_MOS",& - ! i_val=almo_scf_env%mat_distr_mos,error=error) + ! i_val=almo_scf_env%mat_distr_mos) !CALL section_vals_val_get(almo_scf_section,"CONSTRAINT_TYPE",& - ! i_val=almo_scf_env%constraint_type,error=error) + ! i_val=almo_scf_env%constraint_type) !CALL section_vals_val_get(almo_scf_section,"MU",& - ! r_val=almo_scf_env%mu,error=error) + ! r_val=almo_scf_env%mu) !CALL section_vals_val_get(almo_scf_section,"FIXED_MU",& - ! l_val=almo_scf_env%fixed_mu,error=error) + ! l_val=almo_scf_env%fixed_mu) !CALL section_vals_val_get(almo_scf_section,"EPS_USE_PREV_AS_GUESS",& - ! r_val=almo_scf_env%eps_prev_guess,error=error) + ! r_val=almo_scf_env%eps_prev_guess) !CALL section_vals_val_get(almo_scf_section,"MIXING_FRACTION",& - ! r_val=almo_scf_env%mixing_fraction,error=error) + ! r_val=almo_scf_env%mixing_fraction) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_TENSOR_TYPE",& - ! i_val=almo_scf_env%deloc_cayley_tensor_type,& - ! error=error) + ! i_val=almo_scf_env%deloc_cayley_tensor_type) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_CONJUGATOR",& - ! i_val=almo_scf_env%deloc_cayley_conjugator,& - ! error=error) + ! i_val=almo_scf_env%deloc_cayley_conjugator) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_MAX_ITER",& - ! i_val=almo_scf_env%deloc_cayley_max_iter,& - ! error=error) + ! i_val=almo_scf_env%deloc_cayley_max_iter) !CALL section_vals_val_get(almo_scf_section,"DELOC_USE_OCC_ORBS",& - ! l_val=almo_scf_env%deloc_use_occ_orbs,error=error) + ! l_val=almo_scf_env%deloc_use_occ_orbs) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_USE_VIRT_ORBS",& - ! l_val=almo_scf_env%deloc_cayley_use_virt_orbs,& - ! error=error) + ! l_val=almo_scf_env%deloc_cayley_use_virt_orbs) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_LINEAR",& - ! l_val=almo_scf_env%deloc_cayley_linear,& - ! error=error) + ! l_val=almo_scf_env%deloc_cayley_linear) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_EPS_CONVERGENCE",& - ! r_val=almo_scf_env%deloc_cayley_eps_convergence,& - ! error=error) + ! r_val=almo_scf_env%deloc_cayley_eps_convergence) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_OCC_PRECOND",& - ! l_val=almo_scf_env%deloc_cayley_occ_precond,& - ! error=error) + ! l_val=almo_scf_env%deloc_cayley_occ_precond) !CALL section_vals_val_get(almo_scf_section,"DELOC_CAYLEY_VIR_PRECOND",& - ! l_val=almo_scf_env%deloc_cayley_vir_precond,& - ! error=error) + ! l_val=almo_scf_env%deloc_cayley_vir_precond) !CALL section_vals_val_get(almo_scf_section,"ALMO_UPDATE_ALGORITHM_BD",& - ! i_val=almo_scf_env%almo_update_algorithm,& - ! error=error) + ! i_val=almo_scf_env%almo_update_algorithm) !CALL section_vals_val_get(almo_scf_section,"DELOC_TRUNCATE_VIRTUALS",& - ! i_val=almo_scf_env%deloc_truncate_virt,& - ! error=error) + ! i_val=almo_scf_env%deloc_truncate_virt) !CALL section_vals_val_get(almo_scf_section,"DELOC_VIRT_PER_DOMAIN",& - ! i_val=almo_scf_env%deloc_virt_per_domain,& - ! error=error) + ! i_val=almo_scf_env%deloc_virt_per_domain) ! !CALL section_vals_val_get(almo_scf_section,"OPT_K_EPS_CONVERGENCE",& - ! r_val=almo_scf_env%opt_k_eps_convergence,& - ! error=error) + ! r_val=almo_scf_env%opt_k_eps_convergence) !CALL section_vals_val_get(almo_scf_section,"OPT_K_MAX_ITER",& - ! i_val=almo_scf_env%opt_k_max_iter,& - ! error=error) + ! i_val=almo_scf_env%opt_k_max_iter) !CALL section_vals_val_get(almo_scf_section,"OPT_K_OUTER_MAX_ITER",& - ! i_val=almo_scf_env%opt_k_outer_max_iter,& - ! error=error) + ! i_val=almo_scf_env%opt_k_outer_max_iter) !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE",& - ! r_val=almo_scf_env%opt_k_trial_step_size,& - ! error=error) + ! r_val=almo_scf_env%opt_k_trial_step_size) !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJUGATOR",& - ! i_val=almo_scf_env%opt_k_conjugator,& - ! error=error) + ! i_val=almo_scf_env%opt_k_conjugator) !CALL section_vals_val_get(almo_scf_section,"OPT_K_TRIAL_STEP_SIZE_MULTIPLIER",& - ! r_val=almo_scf_env%opt_k_trial_step_size_multiplier,& - ! error=error) + ! r_val=almo_scf_env%opt_k_trial_step_size_multiplier) !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_START",& - ! i_val=almo_scf_env%opt_k_conj_iter_start,& - ! error=error) + ! i_val=almo_scf_env%opt_k_conj_iter_start) !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_START",& - ! i_val=almo_scf_env%opt_k_prec_iter_start,& - ! error=error) + ! i_val=almo_scf_env%opt_k_prec_iter_start) !CALL section_vals_val_get(almo_scf_section,"OPT_K_CONJ_ITER_FREQ_RESET",& - ! i_val=almo_scf_env%opt_k_conj_iter_freq,& - ! error=error) + ! i_val=almo_scf_env%opt_k_conj_iter_freq) !CALL section_vals_val_get(almo_scf_section,"OPT_K_PREC_ITER_FREQ_UPDATE",& - ! i_val=almo_scf_env%opt_k_prec_iter_freq,& - ! error=error) + ! i_val=almo_scf_env%opt_k_prec_iter_freq) ! !CALL section_vals_val_get(almo_scf_section,"QUENCHER_RADIUS_TYPE",& - ! i_val=almo_scf_env%quencher_radius_type,& - ! error=error) + ! i_val=almo_scf_env%quencher_radius_type) !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_FACTOR",& - ! r_val=almo_scf_env%quencher_r0_factor,& - ! error=error) + ! r_val=almo_scf_env%quencher_r0_factor) !CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_FACTOR",& - ! r_val=almo_scf_env%quencher_r1_factor,& - ! error=error) + ! r_val=almo_scf_env%quencher_r1_factor) !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R0_SHIFT",& - !! r_val=almo_scf_env%quencher_r0_shift,& - !! error=error) + !! r_val=almo_scf_env%quencher_r0_shift) + !! !!CALL section_vals_val_get(almo_scf_section,"QUENCHER_R1_SHIFT",& - !! r_val=almo_scf_env%quencher_r1_shift,& - !! error=error) + !! r_val=almo_scf_env%quencher_r1_shift) + !! !!almo_scf_env%quencher_r0_shift = cp_unit_to_cp2k(& - !! almo_scf_env%quencher_r0_shift,"angstrom",error=error) + !! almo_scf_env%quencher_r0_shift,"angstrom") !!almo_scf_env%quencher_r1_shift = cp_unit_to_cp2k(& - !! almo_scf_env%quencher_r1_shift,"angstrom",error=error) + !! almo_scf_env%quencher_r1_shift,"angstrom") ! !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_0",& - ! r_val=almo_scf_env%quencher_s0,& - ! error=error) + ! r_val=almo_scf_env%quencher_s0) !CALL section_vals_val_get(almo_scf_section,"QUENCHER_AO_OVERLAP_1",& - ! r_val=almo_scf_env%quencher_s1,& - ! error=error) + ! r_val=almo_scf_env%quencher_s1) !CALL section_vals_val_get(almo_scf_section,"ENVELOPE_AMPLITUDE",& - ! r_val=almo_scf_env%envelope_amplitude,& - ! error=error) + ! r_val=almo_scf_env%envelope_amplitude) !! how to read lists !CALL section_vals_val_get(almo_scf_section,"INT_LIST01", & - ! n_rep_val=n_rep,error=error) + ! n_rep_val=n_rep) !counter_i = 0 !DO k = 1,n_rep ! CALL section_vals_val_get(almo_scf_section,"INT_LIST01",& - ! i_rep_val=k,i_vals=tmplist, error=error) + ! i_rep_val=k,i_vals=tmplist) ! DO jj = 1,SIZE(tmplist) ! counter_i=counter_i+1 ! almo_scf_env%charge_of_domain(counter_i)=tmplist(jj) @@ -656,9 +615,9 @@ SUBROUTINE almo_scf_init_read_write_input(input,almo_scf_env,error) !almo_scf_env%quencher_r0_shift=0.0_dp !almo_scf_env%quencher_r1_shift=0.0_dp !almo_scf_env%quencher_r0_shift = cp_unit_to_cp2k(& - ! almo_scf_env%quencher_r0_shift,"angstrom",error=error) + ! almo_scf_env%quencher_r0_shift,"angstrom") !almo_scf_env%quencher_r1_shift = cp_unit_to_cp2k(& - ! almo_scf_env%quencher_r1_shift,"angstrom",error=error) + ! almo_scf_env%quencher_r1_shift,"angstrom") almo_scf_env%quencher_s0=1.0E-4_dp almo_scf_env%quencher_s1=1.0E-6_dp @@ -693,46 +652,46 @@ SUBROUTINE almo_scf_init_read_write_input(input,almo_scf_env,error) ! check for conflicts between options IF (almo_scf_env%deloc_truncate_virt.EQ.virt_number .AND. & almo_scf_env%deloc_virt_per_domain.LE.0) THEN - CPErrorMessage(cp_failure_level,routineP,"specify a positive number of virtual orbitals",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"specify a positive number of virtual orbitals") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (almo_scf_env%deloc_truncate_virt.EQ.virt_minimal) THEN - CPErrorMessage(cp_failure_level,routineP,"VIRT TRUNCATION TO MINIMAL BASIS IS NIY",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"VIRT TRUNCATION TO MINIMAL BASIS IS NIY") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (almo_scf_env%domain_layout_mos.NE.almo_domain_layout_molecular) THEN - CPErrorMessage(cp_failure_level,routineP,"use MOLECULAR domains",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"use MOLECULAR domains") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (almo_scf_env%domain_layout_aos.NE.almo_domain_layout_molecular) THEN - CPErrorMessage(cp_failure_level,routineP,"use MOLECULAR domains",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"use MOLECULAR domains") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (almo_scf_env%mat_distr_mos.NE.almo_mat_distr_molecular) THEN - CPErrorMessage(cp_failure_level,routineP,"use MOLECULAR distr for MOs",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"use MOLECULAR distr for MOs") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (almo_scf_env%mat_distr_aos==almo_mat_distr_molecular .AND. & almo_scf_env%domain_layout_aos==almo_domain_layout_atomic) THEN - CPErrorMessage(cp_failure_level,routineP,"AO blocks cannot be larger than domains",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"AO blocks cannot be larger than domains") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (almo_scf_env%mat_distr_mos==almo_mat_distr_molecular .AND. & almo_scf_env%domain_layout_mos==almo_domain_layout_atomic) THEN - CPErrorMessage(cp_failure_level,routineP,"MO blocks cannot be larger than domains",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"MO blocks cannot be larger than domains") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (almo_scf_env%quencher_r1_factor.gt.almo_max_cutoff_multiplier) THEN - CPErrorMessage(cp_failure_level,routineP,"XALMO_R_CUTOFF_FACTOR is larger than almo_max_cutoff_multiplier",error) - CPErrorMessage(cp_failure_level,routineP,"increase the hard-coded almo_max_cutoff_multiplier",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"XALMO_R_CUTOFF_FACTOR is larger than almo_max_cutoff_multiplier") + CPErrorMessage(cp_failure_level,routineP,"increase the hard-coded almo_max_cutoff_multiplier") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle) @@ -743,16 +702,14 @@ END SUBROUTINE almo_scf_init_read_write_input !> \brief Prints out a short summary about the ALMO SCF job !> \param almo_scf_env ... !> \param unit_nr ... -!> \param error ... !> \par History !> 2011.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_print_job_info(almo_scf_env,unit_nr,error) + SUBROUTINE almo_scf_print_job_info(almo_scf_env,unit_nr) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_print_job_info', & routineP = moduleN//':'//routineN @@ -773,10 +730,10 @@ SUBROUTINE almo_scf_print_job_info(almo_scf_env,unit_nr,error) SELECT CASE(almo_scf_env%almo_update_algorithm) CASE(almo_scf_diag) ! the DIIS algorith is the only choice for the diagonlaization-based algorithm - CALL print_optimizer_options(almo_scf_env%opt_block_diag_diis,unit_nr,error=error) + CALL print_optimizer_options(almo_scf_env%opt_block_diag_diis,unit_nr) CASE(almo_scf_pcg) ! print out PCG options - CALL print_optimizer_options(almo_scf_env%opt_block_diag_pcg,unit_nr,error=error) + CALL print_optimizer_options(almo_scf_env%opt_block_diag_pcg,unit_nr) END SELECT SELECT CASE(almo_scf_env%deloc_method) @@ -815,9 +772,9 @@ SUBROUTINE almo_scf_print_job_info(almo_scf_env,unit_nr,error) WRITE(unit_nr,'(T2,A)') "optimization of extended orbitals:" SELECT CASE(almo_scf_env%xalmo_update_algorithm) CASE(almo_scf_diag) - CALL print_optimizer_options(almo_scf_env%opt_xalmo_diis,unit_nr,error=error) + CALL print_optimizer_options(almo_scf_env%opt_xalmo_diis,unit_nr) CASE(almo_scf_pcg) - CALL print_optimizer_options(almo_scf_env%opt_xalmo_pcg,unit_nr,error=error) + CALL print_optimizer_options(almo_scf_env%opt_xalmo_pcg,unit_nr) END SELECT ENDIF @@ -934,15 +891,13 @@ END SUBROUTINE almo_scf_print_job_info !> and all necessary functions (sqrt, inverse...) !> \param matrix_s ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_init_ao_overlap(matrix_s,almo_scf_env,error) + SUBROUTINE almo_scf_init_ao_overlap(matrix_s,almo_scf_env) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_s TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_init_ao_overlap', & routineP = moduleN//':'//routineN @@ -953,7 +908,7 @@ SUBROUTINE almo_scf_init_ao_overlap(matrix_s,almo_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -963,19 +918,19 @@ SUBROUTINE almo_scf_init_ao_overlap(matrix_s,almo_scf_env,error) ! make almo copy of S ! also copy S to S_blk (i.e. to S with the domain structure imposed) IF (almo_scf_env%orthogonal_basis) THEN - CALL cp_dbcsr_set(almo_scf_env%matrix_s(1),0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(almo_scf_env%matrix_s(1),1.0_dp,error=error) - CALL cp_dbcsr_set(almo_scf_env%matrix_s_blk(1),0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(almo_scf_env%matrix_s_blk(1),1.0_dp,error=error) + CALL cp_dbcsr_set(almo_scf_env%matrix_s(1),0.0_dp) + CALL cp_dbcsr_add_on_diag(almo_scf_env%matrix_s(1),1.0_dp) + CALL cp_dbcsr_set(almo_scf_env%matrix_s_blk(1),0.0_dp) + CALL cp_dbcsr_add_on_diag(almo_scf_env%matrix_s_blk(1),1.0_dp) ELSE CALL matrix_qs_to_almo(matrix_s,almo_scf_env%matrix_s(1),& - almo_scf_env,.FALSE.,error=error) + almo_scf_env,.FALSE.) CALL matrix_qs_to_almo(matrix_s,almo_scf_env%matrix_s_blk(1),& - almo_scf_env,.TRUE.,error=error) + almo_scf_env,.TRUE.) ENDIF - CALL cp_dbcsr_filter(almo_scf_env%matrix_s(1),almo_scf_env%eps_filter,error=error) - CALL cp_dbcsr_filter(almo_scf_env%matrix_s_blk(1),almo_scf_env%eps_filter,error=error) + CALL cp_dbcsr_filter(almo_scf_env%matrix_s(1),almo_scf_env%eps_filter) + CALL cp_dbcsr_filter(almo_scf_env%matrix_s_blk(1),almo_scf_env%eps_filter) IF (almo_scf_env%almo_update_algorithm.eq.almo_scf_diag) THEN CALL matrix_sqrt_Newton_Schulz(almo_scf_env%matrix_s_blk_sqrt(1),& @@ -984,13 +939,11 @@ SUBROUTINE almo_scf_init_ao_overlap(matrix_s,almo_scf_env,error) threshold=almo_scf_env%eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) ELSE IF (almo_scf_env%almo_update_algorithm.eq.almo_scf_dm_sign) THEN CALL invert_Hotelling(almo_scf_env%matrix_s_blk_inv(1),& almo_scf_env%matrix_s_blk(1),& - threshold=almo_scf_env%eps_filter,& - error=error) + threshold=almo_scf_env%eps_filter) ENDIF CALL timestop(handle) @@ -1002,15 +955,13 @@ END SUBROUTINE almo_scf_init_ao_overlap !> Keep it short and clean. !> \param qs_env ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.11 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_main(qs_env,almo_scf_env,error) + SUBROUTINE almo_scf_main(qs_env,almo_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_main', & routineP = moduleN//':'//routineN @@ -1023,7 +974,7 @@ SUBROUTINE almo_scf_main(qs_env,almo_scf_env,error) failure=.FALSE. ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1041,23 +992,22 @@ SUBROUTINE almo_scf_main(qs_env,almo_scf_env,error) matrix_t_out=almo_scf_env%matrix_t_blk,& assume_t0_q0x=.FALSE.,& perturbation_only=.FALSE.,& - special_case=xalmo_case_block_diag,& - error=error) + special_case=xalmo_case_block_diag) - CALL almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error) + CALL almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env) ELSE ! mixing/DIIS optimizer CALL almo_scf_block_diagonal(qs_env,almo_scf_env,& - almo_scf_env%opt_block_diag_diis,error) + almo_scf_env%opt_block_diag_diis) ENDIF ! we might need a copy of the converged KS DO ispin=1,almo_scf_env%nspins CALL cp_dbcsr_copy(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& - almo_scf_env%matrix_ks(ispin),error=error) + almo_scf_env%matrix_ks(ispin)) ENDDO CALL timestop(handle) @@ -1068,16 +1018,14 @@ END SUBROUTINE almo_scf_main !> \brief selects various post scf routines !> \param qs_env ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) + SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_delocalization', & routineP = moduleN//':'//routineN @@ -1095,7 +1043,7 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) failure=.FALSE. ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1119,14 +1067,14 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) ! it is a waste of memory but since matrices are distributed ! we can tolerate it for now ALLOCATE(no_quench(almo_scf_env%nspins)) - CALL cp_dbcsr_init(no_quench(1),error=error) + CALL cp_dbcsr_init(no_quench(1)) CALL cp_dbcsr_create(no_quench(1),& template=almo_scf_env%matrix_t(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(& cp_dbcsr_distribution(no_quench(1)))) CALL cp_dbcsr_work_create(no_quench(1),& - work_mutable=.TRUE., error=error) + work_mutable=.TRUE.) nblkrows_tot = cp_dbcsr_nblkrows_total(no_quench(1)) nblkcols_tot = cp_dbcsr_nblkcols_total(no_quench(1)) ! RZK-warning: is it a quadratic-scaling routine? @@ -1144,19 +1092,19 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(no_quench(1),& iblock_row, iblock_col, p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = 1.0_dp ENDIF ENDDO ENDDO - CALL cp_dbcsr_finalize(no_quench(1),error=error) + CALL cp_dbcsr_finalize(no_quench(1)) IF (almo_scf_env%nspins.gt.1) THEN DO ispin=2,almo_scf_env%nspins - CALL cp_dbcsr_init(no_quench(ispin),error=error) + CALL cp_dbcsr_init(no_quench(ispin)) CALL cp_dbcsr_create(no_quench(ispin),& template=almo_scf_env%matrix_t(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(no_quench(ispin),no_quench(1),error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(no_quench(ispin),no_quench(1)) ENDDO ENDIF @@ -1167,7 +1115,7 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) DO ispin=1,almo_scf_env%nspins CALL cp_dbcsr_copy(almo_scf_env%matrix_t(ispin),& - almo_scf_env%matrix_t_blk(ispin),error=error) + almo_scf_env%matrix_t_blk(ispin)) ENDDO CASE (almo_deloc_x,almo_deloc_xk,almo_deloc_x_then_scf) @@ -1183,17 +1131,17 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) !!! ! simply copy virtual orbitals from matrix_v_full_blk to matrix_v_blk !!! DO ispin=1,almo_scf_env%nspins !!! CALL cp_dbcsr_copy(almo_scf_env%matrix_v_blk(ispin),& - !!! almo_scf_env%matrix_v_full_blk(ispin),error=error) + !!! almo_scf_env%matrix_v_full_blk(ispin)) !!! ENDDO !!! CASE (virt_number,virt_occ_size) - !!! CALL split_v_blk(almo_scf_env,error) - !!! !CALL truncate_subspace_v_blk(qs_env,almo_scf_env,error) + !!! CALL split_v_blk(almo_scf_env) + !!! !CALL truncate_subspace_v_blk(qs_env,almo_scf_env) !!! CASE DEFAULT - !!! CPErrorMessage(cp_failure_level,routineP,"illegal method for virtual space truncation",error) - !!! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + !!! CPErrorMessage(cp_failure_level,routineP,"illegal method for virtual space truncation") + !!! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !!! END SELECT !!!ENDIF - !!!CALL harris_foulkes_correction(qs_env,almo_scf_env,error) + !!!CALL harris_foulkes_correction(qs_env,almo_scf_env) CALL almo_scf_xalmo_pcg(qs_env=qs_env,& almo_scf_env=almo_scf_env,& @@ -1203,8 +1151,7 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) matrix_t_out=almo_scf_env%matrix_t,& assume_t0_q0x=.TRUE.,& perturbation_only=.TRUE.,& - special_case=xalmo_case_fully_deloc,& - error=error) + special_case=xalmo_case_fully_deloc) CASE (almo_deloc_xalmo_1diag) @@ -1213,15 +1160,15 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) almo_scf_env%perturbative_delocalization=.TRUE. DO ispin=1,almo_scf_env%nspins CALL cp_dbcsr_copy(almo_scf_env%matrix_t(ispin),& - almo_scf_env%matrix_t_blk(ispin),error=error) + almo_scf_env%matrix_t_blk(ispin)) ENDDO CALL almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,& - arbitrary_optimizer,error) + arbitrary_optimizer) ELSE - CPErrorMessage(cp_failure_level,routineP,"Other algorithms do not exist",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Other algorithms do not exist") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF @@ -1237,13 +1184,12 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) matrix_t_out=almo_scf_env%matrix_t,& assume_t0_q0x=.TRUE.,& perturbation_only=.TRUE.,& - special_case=xalmo_case_normal,& - error=error) + special_case=xalmo_case_normal) ELSE - CPErrorMessage(cp_failure_level,routineP,"Other algorithms do not exist",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Other algorithms do not exist") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF @@ -1251,16 +1197,16 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) IF (almo_scf_env%xalmo_update_algorithm.eq.almo_scf_diag) THEN - CPErrorMessage(cp_failure_level,routineP,"Should not be here: convergence will fail!",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Should not be here: convergence will fail!") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) almo_scf_env%perturbative_delocalization=.FALSE. DO ispin=1,almo_scf_env%nspins CALL cp_dbcsr_copy(almo_scf_env%matrix_t(ispin),& - almo_scf_env%matrix_t_blk(ispin),error=error) + almo_scf_env%matrix_t_blk(ispin)) ENDDO CALL almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,& - arbitrary_optimizer,error) + arbitrary_optimizer) ELSE IF (almo_scf_env%xalmo_update_algorithm.eq.almo_scf_pcg) THEN @@ -1272,8 +1218,7 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) matrix_t_out=almo_scf_env%matrix_t,& assume_t0_q0x=.TRUE.,& perturbation_only=.FALSE.,& - special_case=xalmo_case_normal,& - error=error) + special_case=xalmo_case_normal) ! RZK-warning THIS IS A HACK TO GET ORBITAL ENERGIES almo_experimental=.FALSE. @@ -1281,18 +1226,18 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) almo_scf_env%perturbative_delocalization=.TRUE. !DO ispin=1,almo_scf_env%nspins ! CALL cp_dbcsr_copy(almo_scf_env%matrix_t(ispin),& - ! almo_scf_env%matrix_t_blk(ispin),error=error) + ! almo_scf_env%matrix_t_blk(ispin)) !ENDDO CALL almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,& - arbitrary_optimizer,error) + arbitrary_optimizer) ENDIF ! experimental ENDIF CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"Illegal delocalization method",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Illegal delocalization method") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT @@ -1300,8 +1245,8 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) CASE (almo_deloc_scf,almo_deloc_x_then_scf) IF (almo_scf_env%deloc_truncate_virt.ne.virt_full) THEN - CPErrorMessage(cp_failure_level,routineP,"full scf is NYI for truncated virtual space",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"full scf is NYI for truncated virtual space") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL almo_scf_xalmo_pcg(qs_env=qs_env,& @@ -1312,8 +1257,7 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) matrix_t_out=almo_scf_env%matrix_t,& assume_t0_q0x=.FALSE.,& perturbation_only=.FALSE.,& - special_case=xalmo_case_fully_deloc,& - error=error) + special_case=xalmo_case_fully_deloc) END SELECT @@ -1321,7 +1265,7 @@ SUBROUTINE almo_scf_delocalization(qs_env,almo_scf_env,error) SELECT CASE (almo_scf_env%deloc_method) CASE (almo_deloc_x,almo_deloc_scf,almo_deloc_x_then_scf) DO ispin=1, almo_scf_env%nspins - CALL cp_dbcsr_release(no_quench(ispin),error=error) + CALL cp_dbcsr_release(no_quench(ispin)) ENDDO DEALLOCATE(no_quench) END SELECT @@ -1334,16 +1278,14 @@ END SUBROUTINE almo_scf_delocalization !> \brief create various matrices !> \param almo_scf_env ... !> \param matrix_s0 ... -!> \param error ... !> \par History !> 2011.07 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) + SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_s0 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_env_create_matrices', & routineP = moduleN//':'//routineN @@ -1362,8 +1304,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_symmetric,& spin_key=0,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_s_blk(1),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1371,8 +1312,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_symmetric,& spin_key=0,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) IF (almo_scf_env%almo_update_algorithm.eq.almo_scf_diag) THEN CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_s_blk_sqrt_inv(1),& matrix_qs=matrix_s0,& @@ -1381,8 +1321,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_symmetric,& spin_key=0,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_s_blk_sqrt(1),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1390,8 +1329,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_symmetric,& spin_key=0,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) ELSE IF (almo_scf_env%almo_update_algorithm.eq.almo_scf_dm_sign) THEN CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_s_blk_inv(1),& matrix_qs=matrix_s0,& @@ -1400,8 +1338,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_symmetric,& spin_key=0,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) ENDIF ! MO coeff matrices and their derivatives @@ -1425,8 +1362,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) ! create ALMO coefficient matrix CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_t_blk(ispin),& matrix_qs=matrix_s0,& @@ -1435,8 +1371,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) ! create the error matrix CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_err_blk(ispin),& matrix_qs=matrix_s0,& @@ -1445,8 +1380,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) ! create the error matrix for the quenched ALMOs CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_err_xx(ispin),& matrix_qs=matrix_s0,& @@ -1455,8 +1389,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) ! create a matrix with dimensions of a transposed mo coefficient matrix ! it might be necessary to perform the correction step using cayley CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_t_tr(ispin),& @@ -1466,8 +1399,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) ! create mo overlap matrix CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_sigma(ispin),& matrix_qs=matrix_s0,& @@ -1476,8 +1408,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) ! create blocked mo overlap matrix CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_sigma_blk(ispin),& matrix_qs=matrix_s0,& @@ -1486,8 +1417,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) ! create inverse mo overlap matrix CALL matrix_almo_create(& matrix_new=almo_scf_env%matrix_sigma_inv(ispin),& @@ -1497,8 +1427,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) ! create various templates that will be necessary later CALL matrix_almo_create(& matrix_new=almo_scf_env%matrix_t(ispin),& @@ -1508,16 +1437,15 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) - CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt(ispin),error=error) - CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt_inv(ispin),error=error) + init_domains=.FALSE.) + CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt(ispin)) + CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt_inv(ispin)) CALL cp_dbcsr_create(almo_scf_env%matrix_sigma_sqrt(ispin),& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry, error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(almo_scf_env%matrix_sigma_sqrt_inv(ispin),& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry, error=error) + matrix_type=dbcsr_type_no_symmetry) ENDDO ! create virtual orbitals if necessary @@ -1557,8 +1485,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_virt_full/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_v_blk(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1566,8 +1493,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_v(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1575,8 +1501,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_ov_full(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1584,8 +1509,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_virt_full/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_ov(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1593,8 +1517,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_vo(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1602,8 +1525,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_x(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1611,8 +1533,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_sigma_vv(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1620,8 +1541,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_vv_full_blk(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1629,8 +1549,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_full,almo_mat_dim_virt_full/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_sigma_vv_blk(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1638,16 +1557,15 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) - CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_vv_sqrt(ispin),error=error) - CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_vv_sqrt_inv(ispin),error=error) + init_domains=.TRUE.) + CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_vv_sqrt(ispin)) + CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_vv_sqrt_inv(ispin)) CALL cp_dbcsr_create(almo_scf_env%matrix_sigma_vv_sqrt(ispin),& template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry, error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(almo_scf_env%matrix_sigma_vv_sqrt_inv(ispin),& template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry, error=error) + matrix_type=dbcsr_type_no_symmetry) IF (almo_scf_env%deloc_truncate_virt.ne.virt_full) THEN CALL matrix_almo_create(matrix_new=almo_scf_env%opt_k_t_rr(ispin),& @@ -1657,8 +1575,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_vv_disc(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1666,8 +1583,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_disc,almo_mat_dim_virt_disc/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%opt_k_t_dd(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1675,8 +1591,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_disc,almo_mat_dim_virt_disc/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_vv_disc_blk(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1684,8 +1599,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_disc,almo_mat_dim_virt_disc/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_k_blk(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1693,8 +1607,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_disc,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_k_blk_ones(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1702,8 +1615,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_disc,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) CALL matrix_almo_create(matrix_new=almo_scf_env%opt_k_denom(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1711,8 +1623,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_disc,almo_mat_dim_virt/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_k_tr(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1720,8 +1631,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt,almo_mat_dim_virt_disc/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_v_disc_blk(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1729,8 +1639,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_virt_disc/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_v_disc(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1738,8 +1647,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_virt_disc/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_ov_disc(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1747,8 +1655,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_virt_disc/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) ENDIF ! end need_discarded_virtuals @@ -1767,8 +1674,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_occ,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_evv_full(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1776,8 +1682,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_virt_full,almo_mat_dim_virt_full/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) ENDDO ENDIF @@ -1789,21 +1694,20 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) IF (almo_scf_env%need_previous_ks)& ALLOCATE(almo_scf_env%matrix_ks_almo_scf_converged(nspins)) DO ispin=1,nspins - CALL cp_dbcsr_init(almo_scf_env%matrix_p(ispin),error=error) + CALL cp_dbcsr_init(almo_scf_env%matrix_p(ispin)) ! RZK-warning copy with symmery but remember that this might cause problems CALL cp_dbcsr_create(almo_scf_env%matrix_p(ispin),& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_symmetric, error=error) - CALL cp_dbcsr_init(almo_scf_env%matrix_ks(ispin),error=error) + matrix_type=dbcsr_type_symmetric) + CALL cp_dbcsr_init(almo_scf_env%matrix_ks(ispin)) CALL cp_dbcsr_create(almo_scf_env%matrix_ks(ispin),& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_symmetric, error=error) + matrix_type=dbcsr_type_symmetric) IF (almo_scf_env%need_previous_ks) THEN - CALL cp_dbcsr_init(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& - error=error) + CALL cp_dbcsr_init(almo_scf_env%matrix_ks_almo_scf_converged(ispin)) CALL cp_dbcsr_create(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_symmetric, error=error) + matrix_type=dbcsr_type_symmetric) ENDIF CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_p_blk(ispin),& matrix_qs=matrix_s0,& @@ -1812,8 +1716,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) CALL matrix_almo_create(matrix_new=almo_scf_env%matrix_ks_blk(ispin),& matrix_qs=matrix_s0,& almo_scf_env=almo_scf_env,& @@ -1821,8 +1724,7 @@ SUBROUTINE almo_scf_env_create_matrices(almo_scf_env,matrix_s0,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_aobasis/),& symmetry_new=dbcsr_type_symmetric,& spin_key=ispin,& - init_domains=.TRUE.,& - error=error) + init_domains=.TRUE.) ENDDO CALL timestop(handle) @@ -1832,15 +1734,13 @@ END SUBROUTINE almo_scf_env_create_matrices ! ***************************************************************************** !> \brief clean up procedures for almo scf !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_clean_up(almo_scf_env,error) + SUBROUTINE almo_scf_clean_up(almo_scf_env) TYPE(almo_scf_env_type) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_clean_up', & routineP = moduleN//':'//routineN @@ -1851,7 +1751,7 @@ SUBROUTINE almo_scf_clean_up(almo_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1859,65 +1759,64 @@ SUBROUTINE almo_scf_clean_up(almo_scf_env,error) ENDIF ! release matrices - CALL cp_dbcsr_release(almo_scf_env%matrix_s(1),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk(1),error=error) + CALL cp_dbcsr_release(almo_scf_env%matrix_s(1)) + CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk(1)) IF (almo_scf_env%almo_update_algorithm.eq.almo_scf_diag) THEN - CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk_sqrt_inv(1),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk_sqrt(1),error=error) + CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk_sqrt_inv(1)) + CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk_sqrt(1)) ELSE IF (almo_scf_env%almo_update_algorithm.eq.almo_scf_dm_sign) THEN - CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk_inv(1),error=error) + CALL cp_dbcsr_release(almo_scf_env%matrix_s_blk_inv(1)) ENDIF DO ispin=1,almo_scf_env%nspins - CALL cp_dbcsr_release(almo_scf_env%quench_t(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%quench_t_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_t_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_err_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_err_xx(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_t_tr(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_inv(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_t(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_sqrt(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_sqrt_inv(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_p(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_ks(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_p_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_ks_blk(ispin),error=error) + CALL cp_dbcsr_release(almo_scf_env%quench_t(ispin)) + CALL cp_dbcsr_release(almo_scf_env%quench_t_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_t_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_err_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_err_xx(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_t_tr(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_inv(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_t(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_sqrt(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_sqrt_inv(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_p(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_ks(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_p_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_ks_blk(ispin)) IF (almo_scf_env%need_previous_ks) THEN - CALL cp_dbcsr_release(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& - error=error) + CALL cp_dbcsr_release(almo_scf_env%matrix_ks_almo_scf_converged(ispin)) ENDIF IF (almo_scf_env%need_virtuals) THEN - CALL cp_dbcsr_release(almo_scf_env%matrix_v_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_v_full_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_v(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_vo(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_x(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_ov(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_ov_full(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv_sqrt(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv_sqrt_inv(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_vv_full_blk(ispin),error=error) + CALL cp_dbcsr_release(almo_scf_env%matrix_v_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_v_full_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_v(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_vo(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_x(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_ov(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_ov_full(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv_sqrt(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_sigma_vv_sqrt_inv(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_vv_full_blk(ispin)) IF (almo_scf_env%deloc_truncate_virt.ne.virt_full) THEN - CALL cp_dbcsr_release(almo_scf_env%matrix_k_tr(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_k_blk_ones(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_v_disc(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_v_disc_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_ov_disc(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_vv_disc_blk(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_vv_disc(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%opt_k_t_dd(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%opt_k_t_rr(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%opt_k_denom(ispin),error=error) + CALL cp_dbcsr_release(almo_scf_env%matrix_k_tr(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_k_blk_ones(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_v_disc(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_v_disc_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_ov_disc(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_vv_disc_blk(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_vv_disc(ispin)) + CALL cp_dbcsr_release(almo_scf_env%opt_k_t_dd(ispin)) + CALL cp_dbcsr_release(almo_scf_env%opt_k_t_rr(ispin)) + CALL cp_dbcsr_release(almo_scf_env%opt_k_denom(ispin)) ENDIF ENDIF IF (almo_scf_env%need_orbital_energies) THEN - CALL cp_dbcsr_release(almo_scf_env%matrix_eoo(ispin),error=error) - CALL cp_dbcsr_release(almo_scf_env%matrix_evv_full(ispin),error=error) + CALL cp_dbcsr_release(almo_scf_env%matrix_eoo(ispin)) + CALL cp_dbcsr_release(almo_scf_env%matrix_evv_full(ispin)) ENDIF ENDDO @@ -1976,22 +1875,14 @@ SUBROUTINE almo_scf_clean_up(almo_scf_env,error) ! clean up other variables DO ispin=1,almo_scf_env%nspins CALL release_submatrices(& - almo_scf_env%domain_preconditioner(:,ispin),& - error=error) - CALL release_submatrices(almo_scf_env%domain_s_inv(:,ispin),& - error=error) - CALL release_submatrices(almo_scf_env%domain_s_sqrt_inv(:,ispin),& - error=error) - CALL release_submatrices(almo_scf_env%domain_s_sqrt(:,ispin),& - error=error) - CALL release_submatrices(almo_scf_env%domain_ks_xx(:,ispin),& - error=error) - CALL release_submatrices(almo_scf_env%domain_t(:,ispin),& - error=error) - CALL release_submatrices(almo_scf_env%domain_err(:,ispin),& - error=error) - CALL release_submatrices(almo_scf_env%domain_r_down_up(:,ispin),& - error=error) + almo_scf_env%domain_preconditioner(:,ispin)) + CALL release_submatrices(almo_scf_env%domain_s_inv(:,ispin)) + CALL release_submatrices(almo_scf_env%domain_s_sqrt_inv(:,ispin)) + CALL release_submatrices(almo_scf_env%domain_s_sqrt(:,ispin)) + CALL release_submatrices(almo_scf_env%domain_ks_xx(:,ispin)) + CALL release_submatrices(almo_scf_env%domain_t(:,ispin)) + CALL release_submatrices(almo_scf_env%domain_err(:,ispin)) + CALL release_submatrices(almo_scf_env%domain_r_down_up(:,ispin)) ENDDO DEALLOCATE(almo_scf_env%domain_preconditioner) DEALLOCATE(almo_scf_env%domain_s_inv) @@ -2023,8 +1914,8 @@ SUBROUTINE almo_scf_clean_up(almo_scf_env,error) DEALLOCATE(almo_scf_env%domain_index_of_ao_block) DEALLOCATE(almo_scf_env%domain_index_of_mo_block) - CALL cp_para_env_release(almo_scf_env%para_env,error) - CALL cp_blacs_env_release(almo_scf_env%blacs_env,error) + CALL cp_para_env_release(almo_scf_env%para_env) + CALL cp_blacs_env_release(almo_scf_env%blacs_env) CALL timestop(handle) diff --git a/src/almo_scf_diis_types.F b/src/almo_scf_diis_types.F index 37fcc09174..0e6f420bb8 100644 --- a/src/almo_scf_diis_types.F +++ b/src/almo_scf_diis_types.F @@ -87,18 +87,16 @@ MODULE almo_scf_diis_types !> \param sample_var ... !> \param error_type ... !> \param max_length ... -!> \param error ... !> \par History !> 2011.12 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE almo_scf_diis_init_dbcsr(diis_env,sample_err,sample_var,error_type,& - max_length,error) + max_length) TYPE(almo_scf_diis_type), INTENT(INOUT) :: diis_env TYPE(cp_dbcsr_type), INTENT(IN) :: sample_err, sample_var INTEGER, INTENT(IN) :: error_type, max_length - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_diis_init_dbcsr', & routineP = moduleN//':'//routineN @@ -109,8 +107,8 @@ SUBROUTINE almo_scf_diis_init_dbcsr(diis_env,sample_err,sample_var,error_type,& CALL timeset(routineN,handle) IF( max_length.le.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DIIS: max_length is less than zero",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DIIS: max_length is less than zero") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF diis_env%diis_env_type=diis_env_dbcsr @@ -125,19 +123,19 @@ SUBROUTINE almo_scf_diis_init_dbcsr(diis_env,sample_err,sample_var,error_type,& ! create matrices DO im=1,diis_env%max_buffer_length - CALL cp_dbcsr_init(diis_env%m_err(im),error=error) + CALL cp_dbcsr_init(diis_env%m_err(im)) CALL cp_dbcsr_create(diis_env%m_err(im),& - template=sample_err,error=error) - CALL cp_dbcsr_init(diis_env%m_var(im),error=error) + template=sample_err) + CALL cp_dbcsr_init(diis_env%m_var(im)) CALL cp_dbcsr_create(diis_env%m_var(im),& - template=sample_var,error=error) + template=sample_var) ENDDO ! current B matrices are only 1-by-1, they will be expanded on-the-fly ! only one matrix is used with dbcsr version of DIIS ndomains=1 ALLOCATE(diis_env%m_b(ndomains)) - CALL init_submatrices(diis_env%m_b,error=error) + CALL init_submatrices(diis_env%m_b) ! hack into d_b structure to gain full control diis_env%m_b(:)%domain=100 ! arbitrary positive number DO idomain=1, ndomains @@ -158,19 +156,17 @@ END SUBROUTINE almo_scf_diis_init_dbcsr !> \param sample_var ... !> \param error_type ... !> \param max_length ... -!> \param error ... !> \par History !> 2011.12 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE almo_scf_diis_init_domain(diis_env,sample_err,sample_var,error_type,& - max_length,error) + max_length) TYPE(almo_scf_diis_type), INTENT(INOUT) :: diis_env TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN) :: sample_err, sample_var INTEGER, INTENT(IN) :: error_type, max_length - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_diis_init_domain', & routineP = moduleN//':'//routineN @@ -181,8 +177,8 @@ SUBROUTINE almo_scf_diis_init_domain(diis_env,sample_err,sample_var,error_type,& CALL timeset(routineN,handle) IF( max_length.le.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DIIS: max_length is less than zero",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DIIS: max_length is less than zero") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF diis_env%diis_env_type=diis_env_domain @@ -198,12 +194,12 @@ SUBROUTINE almo_scf_diis_init_domain(diis_env,sample_err,sample_var,error_type,& ALLOCATE(diis_env%d_var(diis_env%max_buffer_length,ndomains)) ! create matrices - CALL init_submatrices(diis_env%d_var,error=error) - CALL init_submatrices(diis_env%d_err,error=error) + CALL init_submatrices(diis_env%d_var) + CALL init_submatrices(diis_env%d_err) ! current B matrices are only 1-by-1, they will be expanded on-the-fly ALLOCATE(diis_env%m_b(ndomains)) - CALL init_submatrices(diis_env%m_b,error=error) + CALL init_submatrices(diis_env%m_b) ! hack into d_b structure to gain full control ! distribute matrices as the err/var matrices diis_env%m_b(:)%domain=sample_err(:)%domain @@ -225,18 +221,16 @@ END SUBROUTINE almo_scf_diis_init_domain !> \param err ... !> \param d_var ... !> \param d_err ... -!> \param error ... !> \par History !> 2011.12 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_diis_push(diis_env,var,err,d_var,d_err,error) + SUBROUTINE almo_scf_diis_push(diis_env,var,err,d_var,d_err) TYPE(almo_scf_diis_type), INTENT(INOUT) :: diis_env TYPE(cp_dbcsr_type), INTENT(IN), & OPTIONAL :: var, err TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN), OPTIONAL :: d_var, d_err - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_diis_push', & routineP = moduleN//':'//routineN @@ -253,28 +247,28 @@ SUBROUTINE almo_scf_diis_push(diis_env,var,err,d_var,d_err,error) IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN IF ( .NOT.(PRESENT(var).AND.PRESENT(err)) ) THEN - CPErrorMessage(cp_failure_level,routineP,"provide DBCSR matrices",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"provide DBCSR matrices") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN IF ( .NOT.(PRESENT(d_var).AND.PRESENT(d_err)) ) THEN - CPErrorMessage(cp_failure_level,routineP,"provide domain submatrices",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"provide domain submatrices") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE - CPErrorMessage(cp_failure_level,routineP,"illegal DIIS ENV type",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal DIIS ENV type") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF in_point=diis_env%in_point ! store a var-error pair IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN - CALL cp_dbcsr_copy(diis_env%m_var(in_point),var,error=error) - CALL cp_dbcsr_copy(diis_env%m_err(in_point),err,error=error) + CALL cp_dbcsr_copy(diis_env%m_var(in_point),var) + CALL cp_dbcsr_copy(diis_env%m_err(in_point),err) ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN - CALL copy_submatrices(d_var,diis_env%d_var(in_point,:),copy_data=.TRUE.,error=error) - CALL copy_submatrices(d_err,diis_env%d_err(in_point,:),copy_data=.TRUE.,error=error) + CALL copy_submatrices(d_var,diis_env%d_var(in_point,:),copy_data=.TRUE.) + CALL copy_submatrices(d_err,diis_env%d_err(in_point,:),copy_data=.TRUE.) ENDIF ! update the buffer length @@ -299,8 +293,8 @@ SUBROUTINE almo_scf_diis_push(diis_env,var,err,d_var,d_err,error) !!!diis_env%m_b(in_point+1,1)=-1.0_dp !!!DO irow=1,diis_env%buffer_length !!! trace0=almo_scf_diis_error_overlap(diis_env,& - !!! A=diis_env%m_err(irow),B=diis_env%m_err(in_point),& - !!! error=error) + !!! A=diis_env%m_err(irow),B=diis_env%m_err(in_point)) + !!! !!! diis_env%m_b(irow+1,in_point+1)=trace0 !!! diis_env%m_b(in_point+1,irow+1)=trace0 !!!ENDDO @@ -329,13 +323,11 @@ SUBROUTINE almo_scf_diis_push(diis_env,var,err,d_var,d_err,error) DO irow=1,diis_env%buffer_length IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN trace0=almo_scf_diis_error_overlap(diis_env,& - A=diis_env%m_err(irow),B=diis_env%m_err(in_point),& - error=error) + A=diis_env%m_err(irow),B=diis_env%m_err(in_point)) ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN trace0=almo_scf_diis_error_overlap(diis_env,& d_A=diis_env%d_err(irow,idomain),& - d_B=diis_env%d_err(in_point,idomain),& - error=error) + d_B=diis_env%d_err(in_point,idomain)) ENDIF diis_env%m_b(idomain)%mdata(irow+1,in_point+1)=trace0 diis_env%m_b(idomain)%mdata(in_point+1,irow+1)=trace0 @@ -356,18 +348,16 @@ END SUBROUTINE almo_scf_diis_push !> \param diis_env ... !> \param extr_var ... !> \param d_extr_var ... -!> \param error ... !> \par History !> 2011.12 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_diis_extrapolate(diis_env,extr_var,d_extr_var,error) + SUBROUTINE almo_scf_diis_extrapolate(diis_env,extr_var,d_extr_var) TYPE(almo_scf_diis_type), INTENT(INOUT) :: diis_env TYPE(cp_dbcsr_type), INTENT(INOUT), & OPTIONAL :: extr_var TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(INOUT), OPTIONAL :: d_extr_var - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_diis_extrapolate', & routineP = moduleN//':'//routineN @@ -384,7 +374,7 @@ SUBROUTINE almo_scf_diis_extrapolate(diis_env,extr_var,d_extr_var,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -393,17 +383,17 @@ SUBROUTINE almo_scf_diis_extrapolate(diis_env,extr_var,d_extr_var,error) IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN IF ( .NOT.PRESENT(extr_var) ) THEN - CPErrorMessage(cp_failure_level,routineP,"provide DBCSR matrix",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"provide DBCSR matrix") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN IF ( .NOT.PRESENT(d_extr_var) ) THEN - CPErrorMessage(cp_failure_level,routineP,"provide domain submatrices",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"provide domain submatrices") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE - CPErrorMessage(cp_failure_level,routineP,"illegal DIIS ENV type",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal DIIS ENV type") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! Prepare data @@ -431,8 +421,8 @@ SUBROUTINE almo_scf_diis_extrapolate(diis_env,extr_var,d_extr_var,error) CALL DSYEV('V','L',diis_env%buffer_length+1,m_b_copy,& diis_env%buffer_length+1,eigenvalues,WORK,LWORK,INFO) IF( INFO.NE.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF DEALLOCATE(WORK) @@ -459,21 +449,21 @@ SUBROUTINE almo_scf_diis_extrapolate(diis_env,extr_var,d_extr_var,error) ! extrapolate the variable checksum=0.0_dp IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN - CALL cp_dbcsr_set(extr_var,0.0_dp,error=error) + CALL cp_dbcsr_set(extr_var,0.0_dp) DO im=1,diis_env%buffer_length CALL cp_dbcsr_add(extr_var,diis_env%m_var(im),& - 1.0_dp,coeff(im+1),error=error) + 1.0_dp,coeff(im+1)) checksum=checksum+coeff(im+1) ENDDO ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN CALL copy_submatrices(diis_env%d_var(1,idomain),& d_extr_var(idomain),& - copy_data=.FALSE.,error=error) - CALL set_submatrices(d_extr_var(idomain),0.0_dp,error=error) + copy_data=.FALSE.) + CALL set_submatrices(d_extr_var(idomain),0.0_dp) DO im=1,diis_env%buffer_length CALL add_submatrices(1.0_dp,d_extr_var(idomain),& coeff(im+1),diis_env%d_var(im,idomain),& - 'N',error=error) + 'N') checksum=checksum+coeff(im+1) ENDDO ENDIF @@ -499,20 +489,18 @@ END SUBROUTINE almo_scf_diis_extrapolate !> \param B ... !> \param d_A ... !> \param d_B ... -!> \param error ... !> \retval almo_scf_diis_error_overlap ... !> \par History !> 2013.02 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - FUNCTION almo_scf_diis_error_overlap(diis_env,A,B,d_A,d_B,error) + FUNCTION almo_scf_diis_error_overlap(diis_env,A,B,d_A,d_B) TYPE(almo_scf_diis_type), INTENT(INOUT) :: diis_env TYPE(cp_dbcsr_type), INTENT(INOUT), & OPTIONAL :: A, B TYPE(domain_submatrix_type), & INTENT(INOUT), OPTIONAL :: d_A, d_B - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp) :: almo_scf_diis_error_overlap CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_diis_error_overlap', & @@ -526,34 +514,34 @@ FUNCTION almo_scf_diis_error_overlap(diis_env,A,B,d_A,d_B,error) IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN IF ( .NOT.(PRESENT(A).AND.PRESENT(B)) ) THEN - CPErrorMessage(cp_failure_level,routineP,"provide DBCSR matrices",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"provide DBCSR matrices") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN IF ( .NOT.(PRESENT(d_A).AND.PRESENT(d_B)) ) THEN - CPErrorMessage(cp_failure_level,routineP,"provide domain submatrices",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"provide domain submatrices") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE - CPErrorMessage(cp_failure_level,routineP,"illegal DIIS ENV type",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal DIIS ENV type") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF SELECT CASE(diis_env%error_type) CASE (diis_error_orthogonal) IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN - CALL cp_dbcsr_trace(A, B, trace, 'T', 'N', error=error) + CALL cp_dbcsr_trace(A, B, trace, 'T', 'N') ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN - CPPrecondition(SIZE(d_A%mdata,1).eq.SIZE(d_B%mdata,1),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(d_A%mdata,2).eq.SIZE(d_B%mdata,2),cp_failure_level,routineP,error,failure) - CPPrecondition(d_A%domain.eq.d_B%domain,cp_failure_level,routineP,error,failure) - CPPrecondition(d_A%domain.gt.0,cp_failure_level,routineP,error,failure) - CPPrecondition(d_B%domain.gt.0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(d_A%mdata,1).eq.SIZE(d_B%mdata,1),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(d_A%mdata,2).eq.SIZE(d_B%mdata,2),cp_failure_level,routineP,failure) + CPPrecondition(d_A%domain.eq.d_B%domain,cp_failure_level,routineP,failure) + CPPrecondition(d_A%domain.gt.0,cp_failure_level,routineP,failure) + CPPrecondition(d_B%domain.gt.0,cp_failure_level,routineP,failure) trace=SUM(d_A%mdata(:,:)*d_B%mdata(:,:)) ENDIF CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"Vector type is unknown",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Vector type is unknown") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT almo_scf_diis_error_overlap=trace @@ -565,14 +553,12 @@ END FUNCTION almo_scf_diis_error_overlap ! ***************************************************************************** !> \brief destroys the diis structure !> \param diis_env ... -!> \param error ... !> \par History !> 2011.12 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_diis_release(diis_env,error) + SUBROUTINE almo_scf_diis_release(diis_env) TYPE(almo_scf_diis_type), INTENT(INOUT) :: diis_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_diis_release', & routineP = moduleN//':'//routineN @@ -584,16 +570,16 @@ SUBROUTINE almo_scf_diis_release(diis_env,error) ! release matrices DO im=1,diis_env%max_buffer_length IF (diis_env%diis_env_type.eq.diis_env_dbcsr) THEN - CALL cp_dbcsr_release(diis_env%m_err(im),error=error) - CALL cp_dbcsr_release(diis_env%m_var(im),error=error) + CALL cp_dbcsr_release(diis_env%m_err(im)) + CALL cp_dbcsr_release(diis_env%m_var(im)) ELSE IF (diis_env%diis_env_type.eq.diis_env_domain) THEN - CALL release_submatrices(diis_env%d_var(im,:),error=error) - CALL release_submatrices(diis_env%d_err(im,:),error=error) + CALL release_submatrices(diis_env%d_var(im,:)) + CALL release_submatrices(diis_env%d_err(im,:)) ENDIF ENDDO IF (diis_env%diis_env_type.eq.diis_env_domain) THEN - CALL release_submatrices(diis_env%m_b(:),error=error) + CALL release_submatrices(diis_env%m_b(:)) ENDIF IF (ALLOCATED(diis_env%m_b)) DEALLOCATE(diis_env%m_b) diff --git a/src/almo_scf_methods.F b/src/almo_scf_methods.F index b8b8398c89..da92c05f45 100644 --- a/src/almo_scf_methods.F +++ b/src/almo_scf_methods.F @@ -74,15 +74,13 @@ MODULE almo_scf_methods !> \brief builds projected KS matrices for the overlapping domains !> also computes the DIIS error vector as a by-product !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_ks_to_ks_xx(almo_scf_env,error) + SUBROUTINE almo_scf_ks_to_ks_xx(almo_scf_env) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'almo_scf_ks_to_ks_xx', & routineP = moduleN//':'//routineN @@ -111,8 +109,7 @@ SUBROUTINE almo_scf_ks_to_ks_xx(almo_scf_env,error) almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row_col,& - error) + select_row_col) !!!!! RZK-warning MAKE SURE THAT YOU NEED BLOCKS OUTSIDE QUENCH_T !!!!! FOR ALL NO-MATRICES NOT COMPUTING THEM CAN SAVE LOTS OF TIME @@ -120,156 +117,140 @@ SUBROUTINE almo_scf_ks_to_ks_xx(almo_scf_env,error) ! 1. TMP1=KS.T ! Cost: NOn !matrix_tmp1 = create NxO, full - CALL cp_dbcsr_init(matrix_tmp1, error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,& - template=almo_scf_env%matrix_t(ispin),& - error=error) + template=almo_scf_env%matrix_t(ispin)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_ks(ispin),& almo_scf_env%matrix_t(ispin),& 0.0_dp, matrix_tmp1,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 2. TMP2=TMP1.SigInv=KS.T.SigInv ! Cost: NOO !matrix_tmp2 = create NxO, full - CALL cp_dbcsr_init(matrix_tmp2, error=error) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,& - template=almo_scf_env%matrix_t(ispin),& - error=error) + template=almo_scf_env%matrix_t(ispin)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1,& almo_scf_env%matrix_sigma_inv(ispin),& 0.0_dp, matrix_tmp2,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 3. TMP1=S.T ! Cost: NOn CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s(1),& almo_scf_env%matrix_t(ispin),& 0.0_dp, matrix_tmp1,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 4. TMP4=TMP2.tr(TMP1)=KS.T.SigInv.tr(T).S ! Cost: NNO !matrix_tmp4 = create NxN - CALL cp_dbcsr_init(matrix_tmp4, error=error) + CALL cp_dbcsr_init(matrix_tmp4) CALL cp_dbcsr_create(matrix_tmp4,& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp2,& matrix_tmp1,& 0.0_dp, matrix_tmp4,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 5. KS_xx=KS_xx-TMP4_xx-tr(TMP4_xx) ALLOCATE(subm_tmp1(ndomains)) - CALL init_submatrices(subm_tmp1,error) + CALL init_submatrices(subm_tmp1) CALL construct_submatrices(& matrix_tmp4,& subm_tmp1,& almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row_col,& - error) + select_row_col) CALL add_submatrices(1.0_dp,almo_scf_env%domain_ks_xx(:,ispin),& - -1.0_dp,subm_tmp1,'N',error) + -1.0_dp,subm_tmp1,'N') CALL add_submatrices(1.0_dp,almo_scf_env%domain_ks_xx(:,ispin),& - -1.0_dp,subm_tmp1,'T',error) + -1.0_dp,subm_tmp1,'T') ! 6. TMP3=tr(TMP4).T=S.T.SigInv.tr(T).KS.T ! Cost: NOn !matrix_tmp3 = create NxO, full - CALL cp_dbcsr_init(matrix_tmp3, error=error) + CALL cp_dbcsr_init(matrix_tmp3) CALL cp_dbcsr_create(matrix_tmp3,& template=almo_scf_env%matrix_t(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("T", "N", 1.0_dp,& matrix_tmp4,& almo_scf_env%matrix_t(ispin),& 0.0_dp, matrix_tmp3,& - filter_eps=eps_multiply,& - error=error) - CALL cp_dbcsr_release(matrix_tmp4,error=error) + filter_eps=eps_multiply) + CALL cp_dbcsr_release(matrix_tmp4) ! 8. TMP6=TMP3.SigInv=S.T.SigInv.tr(T).KS.T.SigInv ! Cost: NOO !matrix_tmp6 = create NxO, full - CALL cp_dbcsr_init(matrix_tmp6, error=error) + CALL cp_dbcsr_init(matrix_tmp6) CALL cp_dbcsr_create(matrix_tmp6,& template=almo_scf_env%matrix_t(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& matrix_tmp3,& almo_scf_env%matrix_sigma_inv(ispin),& 0.0_dp, matrix_tmp6,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 8A. Use intermediate matrices to evaluate the gradient/error ! Err=(TMP2-TMP6)_q=(KS.T.SigInv-S.T.SigInv.tr(T).KS.T.SigInv)_q ! error vector in AO-MO basis CALL cp_dbcsr_copy(almo_scf_env%matrix_err_xx(ispin),& - almo_scf_env%quench_t(ispin),error=error) + almo_scf_env%quench_t(ispin)) CALL cp_dbcsr_copy(almo_scf_env%matrix_err_xx(ispin),& - matrix_tmp2,keep_sparsity=.TRUE.,error=error) - CALL cp_dbcsr_init(matrix_tmp4, error=error) + matrix_tmp2,keep_sparsity=.TRUE.) + CALL cp_dbcsr_init(matrix_tmp4) CALL cp_dbcsr_create(matrix_tmp4,& template=almo_scf_env%matrix_t(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_copy(matrix_tmp4,& - almo_scf_env%quench_t(ispin),error=error) + almo_scf_env%quench_t(ispin)) CALL cp_dbcsr_copy(matrix_tmp4,& - matrix_tmp6,keep_sparsity=.TRUE.,error=error) + matrix_tmp6,keep_sparsity=.TRUE.) CALL cp_dbcsr_add(almo_scf_env%matrix_err_xx(ispin),& - matrix_tmp4,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_release(matrix_tmp4, error=error) + matrix_tmp4,1.0_dp,-1.0_dp) + CALL cp_dbcsr_release(matrix_tmp4) ! ! error vector in AO-AO basis ! RZK-warning tmp4 can be created using the sparsity pattern, ! then retain_sparsity can be used to perform the multiply ! this will save some time CALL cp_dbcsr_copy(matrix_tmp3,& - matrix_tmp2,error=error) + matrix_tmp2) CALL cp_dbcsr_add(matrix_tmp3,& - matrix_tmp6,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_init(matrix_tmp4, error=error) + matrix_tmp6,1.0_dp,-1.0_dp) + CALL cp_dbcsr_init(matrix_tmp4) CALL cp_dbcsr_create(matrix_tmp4,& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "T", 1.0_dp,& matrix_tmp3,& almo_scf_env%matrix_t(ispin),& 0.0_dp, matrix_tmp4,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) CALL construct_submatrices(& matrix_tmp4,& almo_scf_env%domain_err(:,ispin),& almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row_col,& - error) - CALL cp_dbcsr_release(matrix_tmp4, error=error) + select_row_col) + CALL cp_dbcsr_release(matrix_tmp4) ! domain_err submatrices are in down-up representation ! bring them into the orthogonalized basis ALLOCATE(subm_tmp2(ndomains)) - CALL init_submatrices(subm_tmp2,error) + CALL init_submatrices(subm_tmp2) CALL multiply_submatrices('N','N',1.0_dp,& almo_scf_env%domain_err(:,ispin),& - almo_scf_env%domain_s_sqrt(:,ispin),0.0_dp,subm_tmp2,error) + almo_scf_env%domain_s_sqrt(:,ispin),0.0_dp,subm_tmp2) CALL multiply_submatrices('N','N',1.0_dp,& almo_scf_env%domain_s_sqrt_inv(:,ispin),& - subm_tmp2,0.0_dp,almo_scf_env%domain_err(:,ispin),error) + subm_tmp2,0.0_dp,almo_scf_env%domain_err(:,ispin)) ! 9. TMP5=TMP6.tr(TMP1)=S.T.SigInv.tr(T).KS.T.SigInv.tr(T).S ! Cost: NNO @@ -277,17 +258,15 @@ SUBROUTINE almo_scf_ks_to_ks_xx(almo_scf_env,error) ! RZK-warning tmp5 can be created using the sparsity pattern, ! then retain_sparsity can be used to perform the multiply ! this will save some time - CALL cp_dbcsr_init(matrix_tmp5, error=error) + CALL cp_dbcsr_init(matrix_tmp5) CALL cp_dbcsr_create(matrix_tmp5,& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "T", 1.0_dp,& matrix_tmp6,& matrix_tmp1,& 0.0_dp, matrix_tmp5,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 10. KS_xx=KS_xx+TMP5_xx CALL construct_submatrices(& @@ -296,98 +275,86 @@ SUBROUTINE almo_scf_ks_to_ks_xx(almo_scf_env,error) almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row_col,& - error) - CALL cp_dbcsr_release(matrix_tmp5,error=error) + select_row_col) + CALL cp_dbcsr_release(matrix_tmp5) CALL add_submatrices(1.0_dp,almo_scf_env%domain_ks_xx(:,ispin),& - 1.0_dp,subm_tmp1,'N',error) + 1.0_dp,subm_tmp1,'N') ! 11. KS_xx=KS_xx + [S.T]_xx.[SigInv.tr(T).KS.(1-T.SigInv.tr(T).S)]_xx + transposed ALLOCATE(subm_tmp3(ndomains)) - CALL init_submatrices(subm_tmp3,error) + CALL init_submatrices(subm_tmp3) CALL construct_submatrices(& matrix_tmp2,& subm_tmp2,& almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row,& - error) + select_row) CALL construct_submatrices(& matrix_tmp6,& subm_tmp3,& almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row,& - error) - CALL cp_dbcsr_release(matrix_tmp6,error=error) + select_row) + CALL cp_dbcsr_release(matrix_tmp6) CALL add_submatrices(1.0_dp,subm_tmp2,& - -1.0_dp,subm_tmp3,'N',error) + -1.0_dp,subm_tmp3,'N') CALL construct_submatrices(& matrix_tmp1,& subm_tmp3,& almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row,& - error) + select_row) CALL multiply_submatrices('N','T',1.0_dp,subm_tmp2,& - subm_tmp3,0.0_dp,subm_tmp1,error) + subm_tmp3,0.0_dp,subm_tmp1) CALL add_submatrices(1.0_dp,almo_scf_env%domain_ks_xx(:,ispin),& - 1.0_dp,subm_tmp1,'N',error) + 1.0_dp,subm_tmp1,'N') CALL add_submatrices(1.0_dp,almo_scf_env%domain_ks_xx(:,ispin),& - 1.0_dp,subm_tmp1,'T',error) + 1.0_dp,subm_tmp1,'T') ! 12. TMP7=tr(T).KS.T.SigInv - CALL cp_dbcsr_init(matrix_tmp7, error=error) + CALL cp_dbcsr_init(matrix_tmp7) CALL cp_dbcsr_create(matrix_tmp7,& template=almo_scf_env%matrix_sigma_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("T", "N", 1.0_dp,& almo_scf_env%matrix_t(ispin),& matrix_tmp2,& 0.0_dp, matrix_tmp7,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 13. TMP8=[SigInv.tr(T).KS.T.SigInv]_xx - CALL cp_dbcsr_init(matrix_tmp8, error=error) + CALL cp_dbcsr_init(matrix_tmp8) CALL cp_dbcsr_create(matrix_tmp8,& template=almo_scf_env%matrix_sigma_blk(ispin),& - matrix_type=dbcsr_type_symmetric,& - error=error) - CALL cp_dbcsr_copy(matrix_tmp8,almo_scf_env%matrix_sigma_blk(ispin),& - error=error) + matrix_type=dbcsr_type_symmetric) + CALL cp_dbcsr_copy(matrix_tmp8,almo_scf_env%matrix_sigma_blk(ispin)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& almo_scf_env%matrix_sigma_inv(ispin),& matrix_tmp7,& 0.0_dp, matrix_tmp8,& retain_sparsity=.TRUE.,& - filter_eps=eps_multiply,& - error=error) - CALL cp_dbcsr_release(matrix_tmp7,error=error) + filter_eps=eps_multiply) + CALL cp_dbcsr_release(matrix_tmp7) ! 13. TMP9=[S.T]_xx - CALL cp_dbcsr_init(matrix_tmp9, error=error) + CALL cp_dbcsr_init(matrix_tmp9) CALL cp_dbcsr_create(matrix_tmp9,& template=almo_scf_env%matrix_t(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_copy(matrix_tmp9,almo_scf_env%quench_t(ispin),error=error) - CALL cp_dbcsr_copy(matrix_tmp9,matrix_tmp1,keep_sparsity=.TRUE.,& - error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(matrix_tmp9,almo_scf_env%quench_t(ispin)) + CALL cp_dbcsr_copy(matrix_tmp9,matrix_tmp1,keep_sparsity=.TRUE.) ! 14. TMP3=TMP9.TMP8=[S.T]_xx.[SigInv.tr(T).KS.T.SigInv]_xx CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& matrix_tmp9,& matrix_tmp8,& 0.0_dp, matrix_tmp3,& - filter_eps=eps_multiply,& - error=error) - CALL cp_dbcsr_release(matrix_tmp8,error=error) - CALL cp_dbcsr_release(matrix_tmp9,error=error) + filter_eps=eps_multiply) + CALL cp_dbcsr_release(matrix_tmp8) + CALL cp_dbcsr_release(matrix_tmp9) ! 15. KS_xx=KS_xx+[S.T]_xx.[SigInv.tr(T).KS.T.SigInv]_xx.[tr(T).S]_xx CALL construct_submatrices(& @@ -396,73 +363,65 @@ SUBROUTINE almo_scf_ks_to_ks_xx(almo_scf_env,error) almo_scf_env%quench_t(ispin),& almo_scf_env%domain_map(ispin),& almo_scf_env%cpu_of_domain,& - select_row,& - error) + select_row) CALL multiply_submatrices('N','T',1.0_dp,subm_tmp2,& - subm_tmp3,0.0_dp,subm_tmp1,error) + subm_tmp3,0.0_dp,subm_tmp1) CALL add_submatrices(1.0_dp,almo_scf_env%domain_ks_xx(:,ispin),& - 1.0_dp,subm_tmp1,'N',error) + 1.0_dp,subm_tmp1,'N') !!!!!!! use intermediate matrices to get the error vector !!!!!!! !!!!!!! make sure s_blk_sqrt and its inverse exist (i.e. we use diag algorithm) - !CPPrecondition(almo_scf_env%almo_update_algorithm.eq.almo_scf_diag,cp_failure_level,routineP,error,failure) + !CPPrecondition(almo_scf_env%almo_update_algorithm.eq.almo_scf_diag,cp_failure_level,routineP,failure) !! tmp_err = (1-S.T_blk.SigInv.tr(T_blk)).F.T_blk.SigInv - !CALL cp_dbcsr_init(matrix_tmp_err,error=error) + !CALL cp_dbcsr_init(matrix_tmp_err) !CALL cp_dbcsr_create(matrix_tmp_err,& - ! template=almo_scf_env%matrix_t(ispin),& - ! error=error) + ! template=almo_scf_env%matrix_t(ispin)) !CALL cp_dbcsr_copy(matrix_tmp_err,& - ! matrix_tmp2,& - ! error=error) + ! matrix_tmp2) !CALL cp_dbcsr_add(matrix_tmp_err,matrix_tmp3,& - ! 1.0_dp,-1.0_dp,error=error) + ! 1.0_dp,-1.0_dp) !! err_blk = tmp_err.tr(T_blk) !CALL cp_dbcsr_copy(almo_scf_env%matrix_err_blk(ispin),& - ! almo_scf_env%matrix_s_blk_sqrt(1),& - ! error=error) + ! almo_scf_env%matrix_s_blk_sqrt(1)) !CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp_err,& ! almo_scf_env%matrix_t(ispin),& ! 0.0_dp, almo_scf_env%matrix_err_blk(ispin),& ! retain_sparsity=.TRUE.,& - ! filter_eps=eps_multiply,& - ! error=error) - !CALL cp_dbcsr_release(matrix_tmp_err,error=error) + ! filter_eps=eps_multiply) + !CALL cp_dbcsr_release(matrix_tmp_err) !! bring to the orthogonal basis !! err_blk = (S_blk^-1/2).err_blk.(S_blk^1/2) - !CALL cp_dbcsr_init(matrix_tmp_err,error=error) + !CALL cp_dbcsr_init(matrix_tmp_err) !CALL cp_dbcsr_create(matrix_tmp_err,& - ! template=almo_scf_env%matrix_err_blk(ispin),& - ! error=error) + ! template=almo_scf_env%matrix_err_blk(ispin)) !CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& ! almo_scf_env%matrix_err_blk(ispin),& ! almo_scf_env%matrix_s_blk_sqrt(1),& ! 0.0_dp, matrix_tmp_err,& - ! filter_eps=eps_multiply,& - ! error=error) + ! filter_eps=eps_multiply) !CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& ! almo_scf_env%matrix_s_blk_sqrt_inv(1),& ! matrix_tmp_err,& ! 0.0_dp, almo_scf_env%matrix_err_blk(ispin),& - ! filter_eps=eps_multiply,& - ! error=error) + ! filter_eps=eps_multiply) !! subtract transpose !CALL cp_dbcsr_transposed(matrix_tmp_err,& - ! almo_scf_env%matrix_err_blk(ispin),error=error) + ! almo_scf_env%matrix_err_blk(ispin)) !CALL cp_dbcsr_add(almo_scf_env%matrix_err_blk(ispin),& ! matrix_tmp_err,& - ! 1.0_dp,-1.0_dp,error=error) - !CALL cp_dbcsr_release(matrix_tmp_err,error=error) + ! 1.0_dp,-1.0_dp) + !CALL cp_dbcsr_release(matrix_tmp_err) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - CALL release_submatrices(subm_tmp3,error) - CALL release_submatrices(subm_tmp2,error) - CALL release_submatrices(subm_tmp1,error) + CALL release_submatrices(subm_tmp3) + CALL release_submatrices(subm_tmp2) + CALL release_submatrices(subm_tmp1) DEALLOCATE(subm_tmp3) DEALLOCATE(subm_tmp2) DEALLOCATE(subm_tmp1) - CALL cp_dbcsr_release(matrix_tmp3,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) - CALL cp_dbcsr_release(matrix_tmp1,error=error) + CALL cp_dbcsr_release(matrix_tmp3) + CALL cp_dbcsr_release(matrix_tmp2) + CALL cp_dbcsr_release(matrix_tmp1) ENDDO ! spins @@ -474,15 +433,13 @@ END SUBROUTINE almo_scf_ks_to_ks_xx !> \brief computes the projected KS from the total KS matrix !> also computes the DIIS error vector as a by-product !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) + SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'almo_scf_ks_to_ks_blk', & routineP = moduleN//':'//routineN @@ -503,36 +460,30 @@ SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) ! 1. TMP1=KS.T_blk ! Cost: NOn !matrix_tmp1 = create NxO, full - CALL cp_dbcsr_init(matrix_tmp1, error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,& - template=almo_scf_env%matrix_t(ispin),& - error=error) + template=almo_scf_env%matrix_t(ispin)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_ks(ispin),& almo_scf_env%matrix_t_blk(ispin),& 0.0_dp, matrix_tmp1,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 2. TMP2=TMP1.SigInv=KS.T_blk.SigInv ! Cost: NOO !matrix_tmp2 = create NxO, full - CALL cp_dbcsr_init(matrix_tmp2, error=error) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,& - template=almo_scf_env%matrix_t(ispin),& - error=error) + template=almo_scf_env%matrix_t(ispin)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1,& almo_scf_env%matrix_sigma_inv(ispin),& 0.0_dp, matrix_tmp2,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) !!!!!! use intermediate matrices to get the error vector !!!!!!! !CALL cp_dbcsr_copy(almo_scf_env%matrix_err_blk(ispin),& - ! almo_scf_env%matrix_t_blk(ispin),& - ! error=error) + ! almo_scf_env%matrix_t_blk(ispin)) !CALL cp_dbcsr_copy(almo_scf_env%matrix_err_blk(ispin),& ! matrix_tmp2,& - ! keep_sparsity=.TRUE.,& - ! error=error) + ! keep_sparsity=.TRUE.) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 3. TMP1=S.T_blk @@ -540,152 +491,131 @@ SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s(1),& almo_scf_env%matrix_t_blk(ispin),& 0.0_dp, matrix_tmp1,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 4. TMP4_blk=TMP2.tr(TMP1)=KS.T_blk.SigInv.tr(T_blk).S ! Cost: NnO !matrix_tmp4 = create NxN, blk - CALL cp_dbcsr_init(matrix_tmp4, error=error) + CALL cp_dbcsr_init(matrix_tmp4) CALL cp_dbcsr_create(matrix_tmp4,& template=almo_scf_env%matrix_s_blk(1),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_copy(matrix_tmp4,almo_scf_env%matrix_s_blk(1),& - error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(matrix_tmp4,almo_scf_env%matrix_s_blk(1)) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp2,& matrix_tmp1,& 0.0_dp, matrix_tmp4,& retain_sparsity=.TRUE.,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 5. KS_blk=KS_blk-TMP4_blk CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),& matrix_tmp4,& - 1.0_dp,-1.0_dp,error=error) + 1.0_dp,-1.0_dp) ! 6. TMP5_blk=tr(TMP4_blk) ! KS_blk=KS_blk-tr(TMP4_blk) !matrix_tmp5 = create NxN, blk - CALL cp_dbcsr_init(matrix_tmp5, error=error) + CALL cp_dbcsr_init(matrix_tmp5) CALL cp_dbcsr_create(matrix_tmp5,& template=almo_scf_env%matrix_s_blk(1),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_transposed(matrix_tmp5,matrix_tmp4,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_transposed(matrix_tmp5,matrix_tmp4) CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),matrix_tmp5,& - 1.0_dp,-1.0_dp,error=error) + 1.0_dp,-1.0_dp) ! 7. TMP3=tr(T_blk).TMP2=tr(T_blk).KS.T_blk.SigInv ! Cost: OOn !matrix_tmp3 = create OxO, full - CALL cp_dbcsr_init(matrix_tmp3, error=error) + CALL cp_dbcsr_init(matrix_tmp3) CALL cp_dbcsr_create(matrix_tmp3,& template=almo_scf_env%matrix_sigma_inv(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("T", "N", 1.0_dp,& almo_scf_env%matrix_t_blk(ispin),& matrix_tmp2,& 0.0_dp, matrix_tmp3,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 8. TMP6=SigInv.TMP3=SigInv.tr(T_blk).KS.T_blk.SigInv ! Cost: OOO !matrix_tmp6 = create OxO, full - CALL cp_dbcsr_init(matrix_tmp6, error=error) + CALL cp_dbcsr_init(matrix_tmp6) CALL cp_dbcsr_create(matrix_tmp6,& template=almo_scf_env%matrix_sigma_inv(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& almo_scf_env%matrix_sigma_inv(ispin),& matrix_tmp3,& 0.0_dp, matrix_tmp6,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 9. TMP3=TMP1.TMP6=S.T_blk.SigInv.tr(T_blk).KS.T_blk.SigInv ! Cost: NOO !matrix_tmp3 = re-create NxO, full - CALL cp_dbcsr_release(matrix_tmp3,error=error) - CALL cp_dbcsr_init(matrix_tmp3, error=error) + CALL cp_dbcsr_release(matrix_tmp3) + CALL cp_dbcsr_init(matrix_tmp3) CALL cp_dbcsr_create(matrix_tmp3,& - template=almo_scf_env%matrix_t(ispin),& - error=error) + template=almo_scf_env%matrix_t(ispin)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1,& matrix_tmp6,& 0.0_dp, matrix_tmp3,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) !!!!!! use intermediate matrices to get the error vector !!!!!!! - !CALL cp_dbcsr_init(matrix_tmp_err,error=error) + !CALL cp_dbcsr_init(matrix_tmp_err) !CALL cp_dbcsr_create(matrix_tmp_err,& - ! template=almo_scf_env%matrix_t_blk(ispin),& - ! error=error) + ! template=almo_scf_env%matrix_t_blk(ispin)) !CALL cp_dbcsr_copy(matrix_tmp_err,& - ! almo_scf_env%matrix_t_blk(ispin),& - ! error=error) + ! almo_scf_env%matrix_t_blk(ispin)) !CALL cp_dbcsr_copy(matrix_tmp_err,matrix_tmp3,& - ! keep_sparsity=.TRUE.,& - ! error=error) + ! keep_sparsity=.TRUE.) !CALL cp_dbcsr_add(almo_scf_env%matrix_err_blk(ispin),matrix_tmp_err,& - ! 1.0_dp,-1.0_dp,error=error) - !CALL cp_dbcsr_release(matrix_tmp_err,error=error) + ! 1.0_dp,-1.0_dp) + !CALL cp_dbcsr_release(matrix_tmp_err) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!! use intermediate matrices to get the error vector !!!!!!! !!!!!! make sure s_blk_sqrt and its inverse exist (i.e. we use diag algorithm) - CPPrecondition(almo_scf_env%almo_update_algorithm.eq.almo_scf_diag,cp_failure_level,routineP,error,failure) + CPPrecondition(almo_scf_env%almo_update_algorithm.eq.almo_scf_diag,cp_failure_level,routineP,failure) ! tmp_err = (1-S.T_blk.SigInv.tr(T_blk)).F.T_blk.SigInv - CALL cp_dbcsr_init(matrix_tmp_err,error=error) + CALL cp_dbcsr_init(matrix_tmp_err) CALL cp_dbcsr_create(matrix_tmp_err,& - template=almo_scf_env%matrix_t_blk(ispin),& - error=error) + template=almo_scf_env%matrix_t_blk(ispin)) CALL cp_dbcsr_copy(matrix_tmp_err,& - matrix_tmp2,& - error=error) + matrix_tmp2) CALL cp_dbcsr_add(matrix_tmp_err,matrix_tmp3,& - 1.0_dp,-1.0_dp,error=error) + 1.0_dp,-1.0_dp) ! err_blk = tmp_err.tr(T_blk) CALL cp_dbcsr_copy(almo_scf_env%matrix_err_blk(ispin),& - almo_scf_env%matrix_s_blk_sqrt(1),& - error=error) + almo_scf_env%matrix_s_blk_sqrt(1)) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp_err,& almo_scf_env%matrix_t_blk(ispin),& 0.0_dp, almo_scf_env%matrix_err_blk(ispin),& retain_sparsity=.TRUE.,& - filter_eps=eps_multiply,& - error=error) - CALL cp_dbcsr_release(matrix_tmp_err,error=error) + filter_eps=eps_multiply) + CALL cp_dbcsr_release(matrix_tmp_err) ! bring to the orthogonal basis ! err_blk = (S_blk^-1/2).err_blk.(S_blk^1/2) - CALL cp_dbcsr_init(matrix_tmp_err,error=error) + CALL cp_dbcsr_init(matrix_tmp_err) CALL cp_dbcsr_create(matrix_tmp_err,& - template=almo_scf_env%matrix_err_blk(ispin),& - error=error) + template=almo_scf_env%matrix_err_blk(ispin)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& almo_scf_env%matrix_err_blk(ispin),& almo_scf_env%matrix_s_blk_sqrt(1),& 0.0_dp, matrix_tmp_err,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& almo_scf_env%matrix_s_blk_sqrt_inv(1),& matrix_tmp_err,& 0.0_dp, almo_scf_env%matrix_err_blk(ispin),& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! subtract transpose CALL cp_dbcsr_transposed(matrix_tmp_err,& - almo_scf_env%matrix_err_blk(ispin),error=error) + almo_scf_env%matrix_err_blk(ispin)) CALL cp_dbcsr_add(almo_scf_env%matrix_err_blk(ispin),& matrix_tmp_err,& - 1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_release(matrix_tmp_err,error=error) + 1.0_dp,-1.0_dp) + CALL cp_dbcsr_release(matrix_tmp_err) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! later we will need only the blk version of TMP6 @@ -693,16 +623,13 @@ SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) !matrix_tmp9 = create OxO, blk !matrix_tmp9 = copy data from matrix_tmp6, retain sparsity !matrix_tmp6 = release - CALL cp_dbcsr_init(matrix_tmp9, error=error) + CALL cp_dbcsr_init(matrix_tmp9) CALL cp_dbcsr_create(matrix_tmp9,& template=almo_scf_env%matrix_sigma_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_copy(matrix_tmp9,almo_scf_env%matrix_sigma_blk(ispin),& - error=error) - CALL cp_dbcsr_copy(matrix_tmp9,matrix_tmp6,keep_sparsity=.TRUE.,& - error=error) - CALL cp_dbcsr_release(matrix_tmp6,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(matrix_tmp9,almo_scf_env%matrix_sigma_blk(ispin)) + CALL cp_dbcsr_copy(matrix_tmp9,matrix_tmp6,keep_sparsity=.TRUE.) + CALL cp_dbcsr_release(matrix_tmp6) !10. KS_blk=KS_blk+TMP3.tr(TMP1)= ! =KS_blk+S.T_blk.SigInv.tr.(T_blk).KS.T_blk.SigInv.tr(T_blk).S @@ -711,8 +638,7 @@ SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) matrix_tmp1,& 1.0_dp, almo_scf_env%matrix_ks_blk(ispin),& retain_sparsity=.TRUE.,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 11. TMP4_blk=TMP7_blk.tr(TMP8_blk) ! Cost: Nnn @@ -722,66 +648,57 @@ SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) !matrix_tmp8 = create NxO, blk !matrix_tmp8 = copy data from matrix_tmp1, retain sparsity !matrix_tmp1 = release - CALL cp_dbcsr_init(matrix_tmp7, error=error) + CALL cp_dbcsr_init(matrix_tmp7) CALL cp_dbcsr_create(matrix_tmp7,& - template=almo_scf_env%matrix_t_blk(ispin),& - error=error) + template=almo_scf_env%matrix_t_blk(ispin)) ! transfer only the ALMO blocks from tmp3 into tmp7: ! first, copy t_blk into tmp7 to transfer the blk structure, ! then copy tmp3 into tmp7 with retain_sparsity - CALL cp_dbcsr_copy(matrix_tmp7,almo_scf_env%matrix_t_blk(ispin),& - error=error) - CALL cp_dbcsr_copy(matrix_tmp7,matrix_tmp3,keep_sparsity=.TRUE.,& - error=error) - CALL cp_dbcsr_release(matrix_tmp3,error=error) + CALL cp_dbcsr_copy(matrix_tmp7,almo_scf_env%matrix_t_blk(ispin)) + CALL cp_dbcsr_copy(matrix_tmp7,matrix_tmp3,keep_sparsity=.TRUE.) + CALL cp_dbcsr_release(matrix_tmp3) ! do the same for tmp1->tmp8 - CALL cp_dbcsr_init(matrix_tmp8, error=error) + CALL cp_dbcsr_init(matrix_tmp8) CALL cp_dbcsr_create(matrix_tmp8,& - template=almo_scf_env%matrix_t_blk(ispin),& - error=error) - CALL cp_dbcsr_copy(matrix_tmp8,almo_scf_env%matrix_t_blk(ispin),& - error=error) - CALL cp_dbcsr_copy(matrix_tmp8,matrix_tmp1,keep_sparsity=.TRUE.,& - error=error) - CALL cp_dbcsr_release(matrix_tmp1,error=error) + template=almo_scf_env%matrix_t_blk(ispin)) + CALL cp_dbcsr_copy(matrix_tmp8,almo_scf_env%matrix_t_blk(ispin)) + CALL cp_dbcsr_copy(matrix_tmp8,matrix_tmp1,keep_sparsity=.TRUE.) + CALL cp_dbcsr_release(matrix_tmp1) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp7,& matrix_tmp8,& 0.0_dp, matrix_tmp4,& filter_eps=eps_multiply,& - retain_sparsity=.TRUE.,& - error=error) + retain_sparsity=.TRUE.) ! 12. KS_blk=KS_blk-TMP4_blk CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),matrix_tmp4,& - 1.0_dp,-1.0_dp,error=error) + 1.0_dp,-1.0_dp) ! 13. TMP5_blk=tr(TMP5_blk) ! KS_blk=KS_blk-tr(TMP4_blk) - CALL cp_dbcsr_transposed(matrix_tmp5,matrix_tmp4,error=error) + CALL cp_dbcsr_transposed(matrix_tmp5,matrix_tmp4) CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),matrix_tmp5,& - 1.0_dp,-1.0_dp,error=error) + 1.0_dp,-1.0_dp) ! 14. TMP4_blk=TMP7_blk.tr(TMP8_blk) ! Cost: Nnn - CALL cp_dbcsr_copy(matrix_tmp7,matrix_tmp2,keep_sparsity=.TRUE.,& - error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_copy(matrix_tmp7,matrix_tmp2,keep_sparsity=.TRUE.) + CALL cp_dbcsr_release(matrix_tmp2) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_tmp7,& matrix_tmp8,& 0.0_dp, matrix_tmp4,& retain_sparsity=.TRUE.,& - filter_eps=eps_multiply,& - error=error) + filter_eps=eps_multiply) ! 15. KS_blk=KS_blk+TMP4_blk CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),matrix_tmp4,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) ! 16. KS_blk=KS_blk+tr(TMP4_blk) - CALL cp_dbcsr_transposed(matrix_tmp5,matrix_tmp4,error=error) - CALL cp_dbcsr_release(matrix_tmp4,error=error) + CALL cp_dbcsr_transposed(matrix_tmp5,matrix_tmp4) + CALL cp_dbcsr_release(matrix_tmp4) CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),matrix_tmp5,& - 1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_release(matrix_tmp5,error=error) + 1.0_dp,1.0_dp) + CALL cp_dbcsr_release(matrix_tmp5) ! 17. TMP10_blk=TMP8_blk.TMP9_blk ! Cost: Noo @@ -789,9 +706,8 @@ SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) matrix_tmp9,& 0.0_dp, matrix_tmp7,& retain_sparsity=.TRUE.,& - filter_eps=eps_multiply,& - error=error) - CALL cp_dbcsr_release(matrix_tmp9,error=error) + filter_eps=eps_multiply) + CALL cp_dbcsr_release(matrix_tmp9) ! 18. KS_blk=TMP7_blk.tr(TMP8_blk) ! Cost: Nno @@ -799,10 +715,9 @@ SUBROUTINE almo_scf_ks_to_ks_blk(almo_scf_env,error) matrix_tmp8,& 1.0_dp, almo_scf_env%matrix_ks_blk(ispin),& retain_sparsity=.TRUE.,& - filter_eps=eps_multiply,& - error=error) - CALL cp_dbcsr_release(matrix_tmp7,error=error) - CALL cp_dbcsr_release(matrix_tmp8,error=error) + filter_eps=eps_multiply) + CALL cp_dbcsr_release(matrix_tmp7) + CALL cp_dbcsr_release(matrix_tmp8) ENDDO ! spins @@ -814,15 +729,13 @@ END SUBROUTINE almo_scf_ks_to_ks_blk !> \brief ALMOs by diagonalizing the KS domain submatrices !> computes both the occupied and virtual orbitals !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_ks_xx_to_tv_xx(almo_scf_env,error) + SUBROUTINE almo_scf_ks_xx_to_tv_xx(almo_scf_env) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'almo_scf_ks_xx_to_tv_xx', & routineP = moduleN//':'//routineN @@ -841,8 +754,8 @@ SUBROUTINE almo_scf_ks_xx_to_tv_xx(almo_scf_env,error) IF (almo_scf_env%domain_layout_aos==almo_domain_layout_molecular .AND. & almo_scf_env%mat_distr_aos==almo_mat_distr_atomic) THEN - CPErrorMessage(cp_failure_level,routineP,"a domain must be located entirely on a CPU",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"a domain must be located entirely on a CPU") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ndomains=almo_scf_env%ndomains @@ -852,35 +765,35 @@ SUBROUTINE almo_scf_ks_xx_to_tv_xx(almo_scf_env,error) DO ispin=1,almo_scf_env%nspins - CALL init_submatrices(subm_tmp,error) - CALL init_submatrices(subm_ks_xx_orthog,error) + CALL init_submatrices(subm_tmp) + CALL init_submatrices(subm_ks_xx_orthog) ! TRY: project out T0-occupied space for each domain ! F=(1-R_du).F.(1-tr(R_du)) !CALL copy_submatrices(almo_scf_env%domain_ks_xx(:,ispin),& - ! subm_ks_xx_orthog,copy_data=.TRUE.,error=error) + ! subm_ks_xx_orthog,copy_data=.TRUE.) !CALL multiply_submatrices('N','N',1.0_dp,& ! almo_scf_env%domain_r_down_up(:,ispin),& - ! almo_scf_env%domain_ks_xx(:,ispin),0.0_dp,subm_tmp,error) - !CALL add_submatrices(1.0_dp,subm_ks_xx_orthog,-1.0_dp,subm_tmp,'N',error) - !CALL add_submatrices(1.0_dp,subm_ks_xx_orthog,-1.0_dp,subm_tmp,'T',error) + ! almo_scf_env%domain_ks_xx(:,ispin),0.0_dp,subm_tmp) + !CALL add_submatrices(1.0_dp,subm_ks_xx_orthog,-1.0_dp,subm_tmp,'N') + !CALL add_submatrices(1.0_dp,subm_ks_xx_orthog,-1.0_dp,subm_tmp,'T') !!CALL multiply_submatrices('N','T',1.0_dp,subm_tmp,& !! almo_scf_env%domain_r_down_up(:,ispin),& - !! 1.0_dp,subm_ks_xx_orthog,error) + !! 1.0_dp,subm_ks_xx_orthog) ! convert blocks to the orthogonal basis set ! TRY: replace one multiply !CALL multiply_submatrices('N','N',1.0_dp,subm_ks_xx_orthog,& - ! almo_scf_env%domain_s_sqrt_inv(:,ispin),0.0_dp,subm_tmp,error) + ! almo_scf_env%domain_s_sqrt_inv(:,ispin),0.0_dp,subm_tmp) CALL multiply_submatrices('N','N',1.0_dp,almo_scf_env%domain_ks_xx(:,ispin),& - almo_scf_env%domain_s_sqrt_inv(:,ispin),0.0_dp,subm_tmp,error) + almo_scf_env%domain_s_sqrt_inv(:,ispin),0.0_dp,subm_tmp) CALL multiply_submatrices('N','N',1.0_dp,almo_scf_env%domain_s_sqrt_inv(:,ispin),& - subm_tmp,0.0_dp,subm_ks_xx_orthog,error) - CALL release_submatrices(subm_tmp,error) + subm_tmp,0.0_dp,subm_ks_xx_orthog) + CALL release_submatrices(subm_tmp) ! create temporary matrices for occupied and virtual orbitals ! represented in the orthogonalized basis set - CALL init_submatrices(subm_t,error) + CALL init_submatrices(subm_t) ! loop over domains - perform diagonalization DO idomain = 1, ndomains @@ -906,8 +819,8 @@ SUBROUTINE almo_scf_ks_xx_to_tv_xx(almo_scf_env,error) ALLOCATE(WORK(MAX(1,LWORK))) CALL DSYEV('V','L',iblock_size,data_copy,iblock_size,eigenvalues,WORK,LWORK,INFO) IF( INFO.NE.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF !WRITE (*,*) "Domain", idomain ,"OCC energies", eigenvalues( 1:almo_scf_env%nocc_of_domain(idomain,ispin) ) @@ -916,13 +829,13 @@ SUBROUTINE almo_scf_ks_xx_to_tv_xx(almo_scf_env,error) ! Copy occupied eigenvectors IF ( almo_scf_env%domain_t(idomain,ispin)%ncols.NE.& almo_scf_env%nocc_of_domain(idomain,ispin) ) THEN - CPErrorMessage(cp_failure_level,routineP,"wrong domain structure",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"wrong domain structure") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF CALL copy_submatrices(almo_scf_env%domain_t(idomain,ispin),& - subm_t(idomain),.FALSE.,error) + subm_t(idomain),.FALSE.) CALL copy_submatrix_data(data_copy(:,1:almo_scf_env%nocc_of_domain(idomain,ispin)),& - subm_t(idomain),error) + subm_t(idomain)) DEALLOCATE(WORK) DEALLOCATE(data_copy) @@ -932,25 +845,24 @@ SUBROUTINE almo_scf_ks_xx_to_tv_xx(almo_scf_env,error) ENDDO ! loop over domains - CALL release_submatrices(subm_ks_xx_orthog,error) + CALL release_submatrices(subm_ks_xx_orthog) ! convert orbitals to the AO basis set (from orthogonalized AOs) CALL multiply_submatrices('N','N',1.0_dp,almo_scf_env%domain_s_sqrt_inv(:,ispin),& - subm_t,0.0_dp,almo_scf_env%domain_t(:,ispin),error) - CALL release_submatrices(subm_t,error) + subm_t,0.0_dp,almo_scf_env%domain_t(:,ispin)) + CALL release_submatrices(subm_t) ! convert domain orbitals to a dbcsr matrix CALL construct_dbcsr_from_submatrices(& almo_scf_env%matrix_t(ispin),& almo_scf_env%domain_t(:,ispin),& - almo_scf_env%quench_t(ispin),& - error) + almo_scf_env%quench_t(ispin)) CALL cp_dbcsr_filter(almo_scf_env%matrix_t(ispin),& - almo_scf_env%eps_filter,error=error) + almo_scf_env%eps_filter) ! TRY: add T0 component !!CALL cp_dbcsr_add(almo_scf_env%matrix_t(ispin),& - !! almo_scf_env%matrix_t_blk(ispin),1.0_dp,1.0_dp,error=error) + !! almo_scf_env%matrix_t_blk(ispin),1.0_dp,1.0_dp) ENDDO ! spins @@ -967,15 +879,13 @@ END SUBROUTINE almo_scf_ks_xx_to_tv_xx !> uses the diagonalization code for blocks !> computes both the occupied and virtual orbitals !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.07 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) + SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'almo_scf_ks_blk_to_tv_blk', & routineP = moduleN//':'//routineN @@ -997,48 +907,40 @@ SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) IF (almo_scf_env%domain_layout_aos==almo_domain_layout_molecular .AND. & almo_scf_env%mat_distr_aos==almo_mat_distr_atomic) THEN - CPErrorMessage(cp_failure_level,routineP,"a domain must be located entirely on a CPU",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"a domain must be located entirely on a CPU") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF DO ispin=1,almo_scf_env%nspins - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_init(matrix_ks_blk_orthog,error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_init(matrix_ks_blk_orthog) CALL cp_dbcsr_create(matrix_tmp,template=almo_scf_env%matrix_ks_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(matrix_ks_blk_orthog,template=almo_scf_env%matrix_ks_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) ! convert blocks to the orthogonal basis set CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_ks_blk(ispin),& almo_scf_env%matrix_s_blk_sqrt_inv(1),0.0_dp,matrix_tmp,& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_s_blk_sqrt_inv(1),& matrix_tmp,0.0_dp,matrix_ks_blk_orthog,& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) - CALL cp_dbcsr_release(matrix_tmp,error=error) + CALL cp_dbcsr_release(matrix_tmp) ! create temporary matrices for occupied and virtual orbitals ! represented in the orthogonalized AOs basis set - CALL cp_dbcsr_init(matrix_t_blk_orthog,error=error) - CALL cp_dbcsr_init(matrix_v_blk_orthog,error=error) - CALL cp_dbcsr_create(matrix_t_blk_orthog,template=almo_scf_env%matrix_t_blk(ispin),& - error=error) - CALL cp_dbcsr_create(matrix_v_blk_orthog,template=almo_scf_env%matrix_v_full_blk(ispin),& - error=error) - CALL cp_dbcsr_work_create(matrix_t_blk_orthog,work_mutable=.TRUE.,& - error=error) - CALL cp_dbcsr_work_create(matrix_v_blk_orthog,work_mutable=.TRUE.,& - error=error) + CALL cp_dbcsr_init(matrix_t_blk_orthog) + CALL cp_dbcsr_init(matrix_v_blk_orthog) + CALL cp_dbcsr_create(matrix_t_blk_orthog,template=almo_scf_env%matrix_t_blk(ispin)) + CALL cp_dbcsr_create(matrix_v_blk_orthog,template=almo_scf_env%matrix_v_full_blk(ispin)) + CALL cp_dbcsr_work_create(matrix_t_blk_orthog,work_mutable=.TRUE.) + CALL cp_dbcsr_work_create(matrix_v_blk_orthog,work_mutable=.TRUE.) - CALL cp_dbcsr_work_create(almo_scf_env%matrix_eoo(ispin),work_mutable=.TRUE.,& - error=error) - CALL cp_dbcsr_work_create(almo_scf_env%matrix_evv_full(ispin),work_mutable=.TRUE.,& - error=error) + CALL cp_dbcsr_work_create(almo_scf_env%matrix_eoo(ispin),work_mutable=.TRUE.) + CALL cp_dbcsr_work_create(almo_scf_env%matrix_evv_full(ispin),work_mutable=.TRUE.) CALL cp_dbcsr_iterator_start(iter,matrix_ks_blk_orthog) @@ -1052,8 +954,8 @@ SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) ENDIF IF (.NOT.block_needed) THEN - CPErrorMessage(cp_failure_level,routineP,"off-diagonal block found",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"off-diagonal block found") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (block_needed) THEN @@ -1074,8 +976,8 @@ SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) ALLOCATE(WORK(MAX(1,LWORK))) CALL DSYEV('V','L',iblock_size,data_copy,iblock_size,eigenvalues,WORK,LWORK,INFO) IF( INFO.NE.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF !!! RZK-warning !!! @@ -1088,22 +990,22 @@ SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(matrix_t_blk_orthog,iblock_row,iblock_col,p_new_block) nocc_of_block=SIZE(p_new_block,2) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) - CPPrecondition(nocc_of_block.gt.0,cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) + CPPrecondition(nocc_of_block.gt.0,cp_failure_level,routineP,failure) p_new_block(:,:) = data_copy(:,1:nocc_of_block) ! now virtuals NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(matrix_v_blk_orthog,iblock_row,iblock_col,p_new_block) nvirt_of_block=SIZE(p_new_block,2) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) - CPPrecondition(nvirt_of_block.gt.0,cp_failure_level,routineP,error,failure) - !CPPrecondition((nvirt_of_block+nocc_of_block.eq.iblock_size),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) + CPPrecondition(nvirt_of_block.gt.0,cp_failure_level,routineP,failure) + !CPPrecondition((nvirt_of_block+nocc_of_block.eq.iblock_size),cp_failure_level,routineP,failure) p_new_block(:,:) = data_copy(:,(nocc_of_block+1):(nocc_of_block+nvirt_of_block)) ! copy eigenvalues into two diagonal cp_dbcsr matrices - Eoo and Evv NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(almo_scf_env%matrix_eoo(ispin),iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = 0.0_dp DO orbital=1,nocc_of_block p_new_block(orbital,orbital)=eigenvalues(orbital) @@ -1111,7 +1013,7 @@ SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) ! virtual energies NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(almo_scf_env%matrix_evv_full(ispin),iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = 0.0_dp DO orbital=1,nvirt_of_block p_new_block(orbital,orbital)=eigenvalues(nocc_of_block+orbital) @@ -1126,26 +1028,26 @@ SUBROUTINE almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_finalize(matrix_t_blk_orthog,error=error) - CALL cp_dbcsr_finalize(matrix_v_blk_orthog,error=error) - CALL cp_dbcsr_finalize(almo_scf_env%matrix_eoo(ispin),error=error) - CALL cp_dbcsr_finalize(almo_scf_env%matrix_evv_full(ispin),error=error) + CALL cp_dbcsr_finalize(matrix_t_blk_orthog) + CALL cp_dbcsr_finalize(matrix_v_blk_orthog) + CALL cp_dbcsr_finalize(almo_scf_env%matrix_eoo(ispin)) + CALL cp_dbcsr_finalize(almo_scf_env%matrix_evv_full(ispin)) - CALL cp_dbcsr_filter(matrix_t_blk_orthog,almo_scf_env%eps_filter,error=error) - CALL cp_dbcsr_filter(matrix_v_blk_orthog,almo_scf_env%eps_filter,error=error) + CALL cp_dbcsr_filter(matrix_t_blk_orthog,almo_scf_env%eps_filter) + CALL cp_dbcsr_filter(matrix_v_blk_orthog,almo_scf_env%eps_filter) - CALL cp_dbcsr_release(matrix_ks_blk_orthog, error=error) + CALL cp_dbcsr_release(matrix_ks_blk_orthog) ! convert orbitals to the AO basis set (from orthogonalized AOs) CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_s_blk_sqrt_inv(1),& matrix_t_blk_orthog,0.0_dp,almo_scf_env%matrix_t_blk(ispin),& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_s_blk_sqrt_inv(1),& matrix_v_blk_orthog,0.0_dp,almo_scf_env%matrix_v_full_blk(ispin),& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) - CALL cp_dbcsr_release(matrix_t_blk_orthog, error=error) - CALL cp_dbcsr_release(matrix_v_blk_orthog, error=error) + CALL cp_dbcsr_release(matrix_t_blk_orthog) + CALL cp_dbcsr_release(matrix_v_blk_orthog) ENDDO ! spins @@ -1158,17 +1060,15 @@ END SUBROUTINE almo_scf_ks_blk_to_tv_blk !> \param matrix_in ... !> \param matrix_out ... !> \param nocc ... -!> \param error ... !> \par History !> 2012.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE pseudo_invert_diagonal_blk(matrix_in,matrix_out,nocc,error) + SUBROUTINE pseudo_invert_diagonal_blk(matrix_in,matrix_out,nocc) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_in TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_out INTEGER, DIMENSION(:) :: nocc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pseudo_invert_diagonal_blk', & routineP = moduleN//':'//routineN @@ -1184,10 +1084,8 @@ SUBROUTINE pseudo_invert_diagonal_blk(matrix_in,matrix_out,nocc,error) CALL timeset(routineN,handle) - CALL cp_dbcsr_create(matrix_out,template=matrix_in,& - error=error) - CALL cp_dbcsr_work_create(matrix_out,work_mutable=.TRUE.,& - error=error) + CALL cp_dbcsr_create(matrix_out,template=matrix_in) + CALL cp_dbcsr_work_create(matrix_out,work_mutable=.TRUE.) CALL cp_dbcsr_iterator_start(iter,matrix_in) @@ -1208,15 +1106,14 @@ SUBROUTINE pseudo_invert_diagonal_blk(matrix_in,matrix_out,nocc,error) methodID,& range1=nocc(iblock_row),range2=nocc(iblock_row),& !range1_thr,range2_thr,& - shift=1.0E-5_dp,& - error=error) + shift=1.0E-5_dp) !!! IT IS EXTREMELY IMPORTANT THAT THE BLOCKS OF THE "OUT" !!! !!! MATRIX ARE DISTRIBUTED AS THE BLOCKS OF THE "IN" MATRIX !!! NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(matrix_out,iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = data_copy(:,:) DEALLOCATE(data_copy) @@ -1226,7 +1123,7 @@ SUBROUTINE pseudo_invert_diagonal_blk(matrix_in,matrix_out,nocc,error) ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_finalize(matrix_out,error=error) + CALL cp_dbcsr_finalize(matrix_out) CALL timestop(handle) @@ -1235,15 +1132,13 @@ END SUBROUTINE pseudo_invert_diagonal_blk ! ***************************************************************************** !> \brief computes occupied ALMOs from the superimposed atomic density blocks !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_p_blk_to_t_blk(almo_scf_env,error) + SUBROUTINE almo_scf_p_blk_to_t_blk(almo_scf_env) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'almo_scf_p_blk_to_t_blk', & routineP = moduleN//':'//routineN @@ -1257,13 +1152,11 @@ SUBROUTINE almo_scf_p_blk_to_t_blk(almo_scf_env,error) DO ispin=1,almo_scf_env%nspins !! create a temporary matrix to keep the eigenvectors - !CALL cp_dbcsr_init(matrix_t_blk_tmp, error=error) + !CALL cp_dbcsr_init(matrix_t_blk_tmp) !CALL cp_dbcsr_create(matrix_t_blk_tmp,& - ! template=almo_scf_env%matrix_t_blk(ispin),& - ! error=error) + ! template=almo_scf_env%matrix_t_blk(ispin)) !CALL cp_dbcsr_work_create(matrix_t_blk_tmp,& - ! work_mutable=.TRUE.,& - ! error=error) + ! work_mutable=.TRUE.) !CALL cp_dbcsr_iterator_start(iter,almo_scf_env%matrix_p_blk(ispin)) !DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) @@ -1276,8 +1169,8 @@ SUBROUTINE almo_scf_p_blk_to_t_blk(almo_scf_env,error) ! ENDIF ! IF (.NOT.block_needed) THEN - ! CPErrorMessage(cp_failure_level,routineP,"off-diagonal block found",error) - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + ! CPErrorMessage(cp_failure_level,routineP,"off-diagonal block found") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ! ENDIF ! IF (block_needed) THEN @@ -1298,8 +1191,8 @@ SUBROUTINE almo_scf_p_blk_to_t_blk(almo_scf_env,error) ! ALLOCATE(WORK(MAX(1,LWORK))) ! CALL DSYEV('V','L',iblock_size,data_copy,iblock_size,eigenvalues,WORK,LWORK,INFO) ! IF( INFO.NE.0 ) THEN - ! CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + ! CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ! END IF ! !!! IT IS EXTREMELY IMPORTANT THAT THE DIAGONAL BLOCKS OF THE !!! @@ -1310,8 +1203,8 @@ SUBROUTINE almo_scf_p_blk_to_t_blk(almo_scf_env,error) ! CALL cp_dbcsr_reserve_block2d(matrix_t_blk_tmp,& ! iblock_row,iblock_col,p_new_block) ! nocc_of_block=SIZE(p_new_block,2) - ! CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) - ! CPPrecondition(nocc_of_block.gt.0,cp_failure_level,routineP,error,failure) + ! CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) + ! CPPrecondition(nocc_of_block.gt.0,cp_failure_level,routineP,failure) ! p_new_block(:,:) = data_copy(:,iblock_size-nocc_of_block+1:) ! DEALLOCATE(WORK) @@ -1323,39 +1216,36 @@ SUBROUTINE almo_scf_p_blk_to_t_blk(almo_scf_env,error) !ENDDO !CALL cp_dbcsr_iterator_stop(iter) - !CALL cp_dbcsr_finalize(matrix_t_blk_tmp,error=error) + !CALL cp_dbcsr_finalize(matrix_t_blk_tmp) !CALL cp_dbcsr_filter(matrix_t_blk_tmp,& - ! almo_scf_env%eps_filter,error=error) + ! almo_scf_env%eps_filter) !CALL cp_dbcsr_copy(almo_scf_env%matrix_t_blk(ispin),& - ! matrix_t_blk_tmp,error=error) - !CALL cp_dbcsr_release(matrix_t_blk_tmp,error=error) + ! matrix_t_blk_tmp) + !CALL cp_dbcsr_release(matrix_t_blk_tmp) !! generate a random set of ALMOs !! matrix_t_blk should already be initiated to the proper domain structure CALL cp_dbcsr_init_random(almo_scf_env%matrix_t_blk(ispin),& keep_sparsity=.TRUE.,error=dbcsr_error) - CALL cp_dbcsr_init(matrix_t_blk_tmp, error=error) + CALL cp_dbcsr_init(matrix_t_blk_tmp) CALL cp_dbcsr_create(matrix_t_blk_tmp,& template=almo_scf_env%matrix_t_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) ! use current ALMOs in matrix_t_blk and project them onto the blocked dm ! compute T_new = R_blk S_blk T_random CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s_blk(1),& almo_scf_env%matrix_t_blk(ispin),& 0.0_dp, matrix_t_blk_tmp,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, & almo_scf_env%matrix_p_blk(ispin), matrix_t_blk_tmp,& 0.0_dp, almo_scf_env%matrix_t_blk(ispin),& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) - CALL cp_dbcsr_release(matrix_t_blk_tmp, error=error) + CALL cp_dbcsr_release(matrix_t_blk_tmp) ENDDO @@ -1371,20 +1261,18 @@ END SUBROUTINE almo_scf_p_blk_to_t_blk !> \param metric ... !> \param retain_overlap_sparsity ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2011.08 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE get_overlap(bra,ket,overlap,metric,retain_overlap_sparsity,& - eps_filter,error) + eps_filter) TYPE(cp_dbcsr_type), INTENT(IN) :: bra, ket TYPE(cp_dbcsr_type), INTENT(INOUT) :: overlap TYPE(cp_dbcsr_type), INTENT(IN) :: metric LOGICAL, INTENT(IN), OPTIONAL :: retain_overlap_sparsity REAL(KIND=dp) :: eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_overlap', & routineP = moduleN//':'//routineN @@ -1401,23 +1289,22 @@ SUBROUTINE get_overlap(bra,ket,overlap,metric,retain_overlap_sparsity,& local_retain_sparsity=retain_overlap_sparsity ENDIF - CALL cp_dbcsr_init(tmp,error=error) + CALL cp_dbcsr_init(tmp) CALL cp_dbcsr_create(tmp,template=ket,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) ! TMP=metric*ket CALL cp_dbcsr_multiply("N","N",1.0_dp,& metric,ket,0.0_dp,tmp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! OVERLAP=tr(bra)*TMP CALL cp_dbcsr_multiply("T","N",1.0_dp,& bra,tmp,0.0_dp,overlap,& retain_sparsity=local_retain_sparsity,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) - CALL cp_dbcsr_release(tmp,error=error) + CALL cp_dbcsr_release(tmp) CALL timestop(handle) @@ -1429,10 +1316,9 @@ END SUBROUTINE get_overlap !!> 2011.07 created [Rustam Z Khaliullin] !!> \author Rustam Z Khaliullin !! ***************************************************************************** -! SUBROUTINE almo_scf_v_to_sigma_vv(almo_scf_env,error) +! SUBROUTINE almo_scf_v_to_sigma_vv(almo_scf_env) ! ! TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env -! TYPE(cp_error_type), INTENT(INOUT) :: error ! ! CHARACTER(LEN=*), PARAMETER :: & ! routineN = 'almo_scf_v_to_sigma_vv', & @@ -1445,27 +1331,26 @@ END SUBROUTINE get_overlap ! ! DO ispin=1,almo_scf_env%nspins ! -! CALL cp_dbcsr_init(tmp, error=error) +! CALL cp_dbcsr_init(tmp) ! CALL cp_dbcsr_create(tmp,& ! template=almo_scf_env%matrix_v(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! ! TMP=S.V ! CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! almo_scf_env%matrix_s(1),& ! almo_scf_env%matrix_v(ispin),& ! 0.0_dp,tmp,& -! filter_eps=almo_scf_env%eps_filter,error=error) +! filter_eps=almo_scf_env%eps_filter) ! ! ! Sig_vv=tr(V).S.V - get MO overlap ! CALL cp_dbcsr_multiply("T","N",1.0_dp,& ! almo_scf_env%matrix_v(ispin),& ! tmp,& ! 0.0_dp,almo_scf_env%matrix_sigma_vv(ispin),& -! filter_eps=almo_scf_env%eps_filter,error=error) +! filter_eps=almo_scf_env%eps_filter) ! -! CALL cp_dbcsr_release(tmp,error=error) +! CALL cp_dbcsr_release(tmp) ! ! END DO ! @@ -1479,10 +1364,9 @@ END SUBROUTINE get_overlap !!> 2011.07 created [Rustam Z Khaliullin] !!> \author Rustam Z Khaliullin !! ***************************************************************************** -! SUBROUTINE almo_scf_v_to_v_orthonormal_blk(almo_scf_env,error) +! SUBROUTINE almo_scf_v_to_v_orthonormal_blk(almo_scf_env) ! ! TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env -! TYPE(cp_error_type), INTENT(INOUT) :: error ! ! CHARACTER(LEN=*), PARAMETER :: & ! routineN = 'almo_scf_v_to_v_orthonormal_blk', & @@ -1498,17 +1382,15 @@ END SUBROUTINE get_overlap ! ! DO ispin=1,almo_scf_env%nspins ! -! CALL cp_dbcsr_init(matrix_v_tmp, error=error) +! CALL cp_dbcsr_init(matrix_v_tmp) ! CALL cp_dbcsr_create(matrix_v_tmp,& -! template=almo_scf_env%matrix_v(ispin),& -! error=error) +! template=almo_scf_env%matrix_v(ispin)) ! ! ! TMP=S.V ! CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s(1),& ! almo_scf_env%matrix_v(ispin),& ! 0.0_dp, matrix_v_tmp,& -! filter_eps=almo_scf_env%eps_filter,& -! error=error) +! filter_eps=almo_scf_env%eps_filter) ! ! ! Sig_blk=tr(V).TMP - get blocked MO overlap ! CALL cp_dbcsr_multiply("T", "N", 1.0_dp,& @@ -1516,15 +1398,14 @@ END SUBROUTINE get_overlap ! matrix_v_tmp,& ! 0.0_dp, almo_scf_env%matrix_sigma_vv_blk(ispin),& ! filter_eps=almo_scf_env%eps_filter,& -! retain_sparsity=.TRUE.,& -! error=error) +! retain_sparsity=.TRUE.) ! -! CALL cp_dbcsr_init(sigma_vv_blk_sqrt,error=error) -! CALL cp_dbcsr_init(sigma_vv_blk_sqrt_inv,error=error) +! CALL cp_dbcsr_init(sigma_vv_blk_sqrt) +! CALL cp_dbcsr_init(sigma_vv_blk_sqrt_inv) ! CALL cp_dbcsr_create(sigma_vv_blk_sqrt,template=almo_scf_env%matrix_sigma_vv_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,error=error) +! matrix_type=dbcsr_type_no_symmetry) ! CALL cp_dbcsr_create(sigma_vv_blk_sqrt_inv,template=almo_scf_env%matrix_sigma_vv_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! ! compute sqrt and sqrt_inv of the blocked MO overlap ! CALL matrix_sqrt_Newton_Schulz(sigma_vv_blk_sqrt,sigma_vv_blk_sqrt_inv,& @@ -1532,24 +1413,21 @@ END SUBROUTINE get_overlap ! threshold=almo_scf_env%eps_filter,& ! order=almo_scf_env%order_lanczos,& ! eps_lanczos=almo_scf_env%eps_lancsoz,& -! max_iter_lanczos=almo_scf_env%max_iter_lanczos,& -! error=error) +! max_iter_lanczos=almo_scf_env%max_iter_lanczos) ! ! ! TMP_blk=V.SigSQRTInv_blk ! CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& ! almo_scf_env%matrix_v(ispin),& ! sigma_vv_blk_sqrt_inv,& ! 0.0_dp, matrix_v_tmp,& -! filter_eps=almo_scf_env%eps_filter,& -! error=error) +! filter_eps=almo_scf_env%eps_filter) ! ! ! update the orbitals with the orthonormalized MOs -! CALL cp_dbcsr_copy(almo_scf_env%matrix_v(ispin),matrix_v_tmp,& -! error=error) +! CALL cp_dbcsr_copy(almo_scf_env%matrix_v(ispin),matrix_v_tmp) ! -! CALL cp_dbcsr_release (matrix_v_tmp, error=error) -! CALL cp_dbcsr_release (sigma_vv_blk_sqrt, error=error) -! CALL cp_dbcsr_release (sigma_vv_blk_sqrt_inv, error=error) +! CALL cp_dbcsr_release (matrix_v_tmp) +! CALL cp_dbcsr_release (sigma_vv_blk_sqrt) +! CALL cp_dbcsr_release (sigma_vv_blk_sqrt_inv) ! ! END DO ! @@ -1568,13 +1446,12 @@ END SUBROUTINE get_overlap !> \param order_lanczos ... !> \param eps_lanczos ... !> \param max_iter_lanczos ... -!> \param error ... !> \par History !> 2012.03 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE orthogonalize_mos(ket,overlap,metric,retain_locality,only_normalize,& - eps_filter,order_lanczos,eps_lanczos,max_iter_lanczos,error) + eps_filter,order_lanczos,eps_lanczos,max_iter_lanczos) TYPE(cp_dbcsr_type), INTENT(INOUT) :: ket, overlap TYPE(cp_dbcsr_type), INTENT(IN) :: metric @@ -1584,7 +1461,6 @@ SUBROUTINE orthogonalize_mos(ket,overlap,metric,retain_locality,only_normalize,& INTEGER, INTENT(IN) :: order_lanczos REAL(KIND=dp), INTENT(IN) :: eps_lanczos INTEGER, INTENT(IN) :: max_iter_lanczos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'orthogonalize_mos', & routineP = moduleN//':'//routineN @@ -1600,61 +1476,57 @@ SUBROUTINE orthogonalize_mos(ket,overlap,metric,retain_locality,only_normalize,& ! create block-diagonal sparsity pattern for the overlap ! in case retain_locality is set to true ! RZK-warning this will fail if distribution blocks are smaller than domains!!! - CALL cp_dbcsr_set(overlap,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(overlap,1.0_dp,error=error) - CALL cp_dbcsr_filter(overlap,eps_filter,error=error) + CALL cp_dbcsr_set(overlap,0.0_dp) + CALL cp_dbcsr_add_on_diag(overlap,1.0_dp) + CALL cp_dbcsr_filter(overlap,eps_filter) CALL get_overlap(ket,ket,overlap,metric,retain_locality,& - eps_filter,error) + eps_filter) IF (only_normalize) THEN CALL cp_dbcsr_get_info(overlap, nfullrows_total=dim0 ) ALLOCATE(diagonal(dim0)) - CALL cp_dbcsr_get_diag(overlap,diagonal,error=error) - CALL cp_dbcsr_set(overlap,0.0_dp,error=error) - CALL cp_dbcsr_set_diag(overlap,diagonal,error=error) + CALL cp_dbcsr_get_diag(overlap,diagonal) + CALL cp_dbcsr_set(overlap,0.0_dp) + CALL cp_dbcsr_set_diag(overlap,diagonal) DEALLOCATE(diagonal) - CALL cp_dbcsr_filter(overlap,eps_filter,error=error) + CALL cp_dbcsr_filter(overlap,eps_filter) ENDIF - CALL cp_dbcsr_init(matrix_sigma_blk_sqrt,error=error) - CALL cp_dbcsr_init(matrix_sigma_blk_sqrt_inv,error=error) + CALL cp_dbcsr_init(matrix_sigma_blk_sqrt) + CALL cp_dbcsr_init(matrix_sigma_blk_sqrt_inv) CALL cp_dbcsr_create(matrix_sigma_blk_sqrt,template=overlap,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(matrix_sigma_blk_sqrt_inv,template=overlap,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ! compute sqrt and sqrt_inv of the blocked MO overlap CALL matrix_sqrt_Newton_Schulz(matrix_sigma_blk_sqrt,matrix_sigma_blk_sqrt_inv,& overlap,threshold=eps_filter,& order=order_lanczos,& eps_lanczos=eps_lanczos,& - max_iter_lanczos=max_iter_lanczos,& - error=error) + max_iter_lanczos=max_iter_lanczos) - CALL cp_dbcsr_init(matrix_t_blk_tmp, error=error) + CALL cp_dbcsr_init(matrix_t_blk_tmp) CALL cp_dbcsr_create(matrix_t_blk_tmp,& template=ket,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& ket,& matrix_sigma_blk_sqrt_inv,& 0.0_dp, matrix_t_blk_tmp,& - filter_eps=eps_filter,& + filter_eps=eps_filter) !retain_sparsity=retain_locality,& - error=error) ! update the orbitals with the orthonormalized MOs - CALL cp_dbcsr_copy(ket,matrix_t_blk_tmp,& - error=error) + CALL cp_dbcsr_copy(ket,matrix_t_blk_tmp) - CALL cp_dbcsr_release (matrix_t_blk_tmp, error=error) - CALL cp_dbcsr_release (matrix_sigma_blk_sqrt, error=error) - CALL cp_dbcsr_release (matrix_sigma_blk_sqrt_inv, error=error) + CALL cp_dbcsr_release (matrix_t_blk_tmp) + CALL cp_dbcsr_release (matrix_sigma_blk_sqrt) + CALL cp_dbcsr_release (matrix_sigma_blk_sqrt_inv) CALL timestop(handle) @@ -1663,15 +1535,13 @@ END SUBROUTINE orthogonalize_mos ! ***************************************************************************** !> \brief orthogonalize ALMOs within a domain (obsolete, use orthogonalize_mos) !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error) + SUBROUTINE almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'almo_scf_t_blk_to_t_blk_orthonormal', & @@ -1686,18 +1556,16 @@ SUBROUTINE almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error) DO ispin=1,almo_scf_env%nspins - CALL cp_dbcsr_init(matrix_t_blk_tmp, error=error) + CALL cp_dbcsr_init(matrix_t_blk_tmp) CALL cp_dbcsr_create(matrix_t_blk_tmp,& template=almo_scf_env%matrix_t_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) ! TMP_blk=S_blk.T_blk CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s_blk(1),& almo_scf_env%matrix_t_blk(ispin),& 0.0_dp, matrix_t_blk_tmp,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) ! Sig_blk=tr(T_blk).TMP_blk - get blocked MO overlap CALL cp_dbcsr_multiply("T", "N", 1.0_dp,& @@ -1705,16 +1573,15 @@ SUBROUTINE almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error) matrix_t_blk_tmp,& 0.0_dp, almo_scf_env%matrix_sigma_blk(ispin),& filter_eps=almo_scf_env%eps_filter,& - retain_sparsity=.TRUE.,& - error=error) + retain_sparsity=.TRUE.) ! RZK-warning try to use symmetry of the sqrt and sqrt_inv matrices - CALL cp_dbcsr_init(matrix_sigma_blk_sqrt,error=error) - CALL cp_dbcsr_init(matrix_sigma_blk_sqrt_inv,error=error) + CALL cp_dbcsr_init(matrix_sigma_blk_sqrt) + CALL cp_dbcsr_init(matrix_sigma_blk_sqrt_inv) CALL cp_dbcsr_create(matrix_sigma_blk_sqrt,template=almo_scf_env%matrix_sigma_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(matrix_sigma_blk_sqrt_inv,template=almo_scf_env%matrix_sigma_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ! compute sqrt and sqrt_inv of the blocked MO overlap CALL matrix_sqrt_Newton_Schulz(matrix_sigma_blk_sqrt,matrix_sigma_blk_sqrt_inv,& @@ -1722,8 +1589,7 @@ SUBROUTINE almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error) threshold=almo_scf_env%eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) ! TMP_blk=T_blk.SigSQRTInv_blk CALL cp_dbcsr_multiply("N", "N", 1.0_dp,& @@ -1731,17 +1597,15 @@ SUBROUTINE almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error) matrix_sigma_blk_sqrt_inv,& 0.0_dp, matrix_t_blk_tmp,& filter_eps=almo_scf_env%eps_filter,& - retain_sparsity=.TRUE.,& - error=error) + retain_sparsity=.TRUE.) ! update the orbitals with the orthonormalized ALMOs CALL cp_dbcsr_copy(almo_scf_env%matrix_t_blk(ispin),matrix_t_blk_tmp,& - keep_sparsity=.TRUE.,& - error=error) + keep_sparsity=.TRUE.) - CALL cp_dbcsr_release (matrix_t_blk_tmp, error=error) - CALL cp_dbcsr_release (matrix_sigma_blk_sqrt, error=error) - CALL cp_dbcsr_release (matrix_sigma_blk_sqrt_inv, error=error) + CALL cp_dbcsr_release (matrix_t_blk_tmp) + CALL cp_dbcsr_release (matrix_sigma_blk_sqrt) + CALL cp_dbcsr_release (matrix_sigma_blk_sqrt_inv) END DO @@ -1760,13 +1624,12 @@ END SUBROUTINE almo_scf_t_blk_to_t_blk_orthonormal !> \param sigma ... !> \param sigma_inv ... !> \param use_guess ... -!> \param error ... !> \par History !> 2011.07 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE almo_scf_t_to_p(t,p,eps_filter,orthog_orbs,s,sigma,sigma_inv,& - use_guess,error) + use_guess) TYPE(cp_dbcsr_type), INTENT(IN) :: t TYPE(cp_dbcsr_type), INTENT(INOUT) :: p @@ -1777,7 +1640,6 @@ SUBROUTINE almo_scf_t_to_p(t,p,eps_filter,orthog_orbs,s,sigma,sigma_inv,& TYPE(cp_dbcsr_type), INTENT(INOUT), & OPTIONAL :: sigma, sigma_inv LOGICAL, INTENT(IN), OPTIONAL :: use_guess - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'almo_scf_t_to_p', & routineP = moduleN//':'//routineN @@ -1791,7 +1653,7 @@ SUBROUTINE almo_scf_t_to_p(t,p,eps_filter,orthog_orbs,s,sigma,sigma_inv,& ! make sure that S, sigma and sigma_inv are present for non-orthogonal orbitals IF (.NOT.orthog_orbs) THEN IF ((.NOT.PRESENT(s)).OR.(.NOT.PRESENT(sigma)).OR.(.NOT.PRESENT(sigma_inv))) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDIF @@ -1803,43 +1665,37 @@ SUBROUTINE almo_scf_t_to_p(t,p,eps_filter,orthog_orbs,s,sigma,sigma_inv,& IF (orthog_orbs) THEN CALL cp_dbcsr_multiply("N", "T", 1.0_dp,t,t,& - 0.0_dp,p,filter_eps=eps_filter,& - error=error) + 0.0_dp,p,filter_eps=eps_filter) ELSE - CALL cp_dbcsr_init(t_tmp, error=error) - CALL cp_dbcsr_create(t_tmp,template=t,error=error) + CALL cp_dbcsr_init(t_tmp) + CALL cp_dbcsr_create(t_tmp,template=t) ! TMP=S.T CALL cp_dbcsr_multiply("N","N",1.0_dp,s,t,0.0_dp,t_tmp,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) ! Sig=tr(T).TMP - get MO overlap CALL cp_dbcsr_multiply("T","N",1.0_dp,t,t_tmp,0.0_dp,sigma,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) ! invert MO overlap CALL invert_Hotelling(& matrix_inverse=sigma_inv,& matrix=sigma,& use_inv_as_guess=use_sigma_inv_guess,& - threshold=eps_filter,& - error=error) + threshold=eps_filter) ! TMP=T.SigInv CALL cp_dbcsr_multiply("N","N",1.0_dp,t,sigma_inv,0.0_dp,t_tmp,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) ! P=TMP.tr(T_blk) CALL cp_dbcsr_multiply("N","T",1.0_dp,t_tmp,t,0.0_dp,p,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) - CALL cp_dbcsr_release (t_tmp, error=error) + CALL cp_dbcsr_release (t_tmp) ENDIF @@ -1861,14 +1717,13 @@ END SUBROUTINE almo_scf_t_to_p !> \param eps_filter ... !> \param sig_inv_projector ... !> \param sig_inv_template ... -!> \param error ... !> \par History !> 2011.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE apply_projector(psi_in,psi_out,psi_projector,metric,project_out,& psi_projector_orthogonal,proj_in_template,eps_filter,sig_inv_projector,& - sig_inv_template,error) + sig_inv_template) TYPE(cp_dbcsr_type), INTENT(IN) :: psi_in TYPE(cp_dbcsr_type), INTENT(INOUT) :: psi_out @@ -1880,7 +1735,6 @@ SUBROUTINE apply_projector(psi_in,psi_out,psi_projector,metric,project_out,& TYPE(cp_dbcsr_type), INTENT(IN), & OPTIONAL :: sig_inv_projector, & sig_inv_template - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_projector', & routineP = moduleN//':'//routineN @@ -1893,76 +1747,69 @@ SUBROUTINE apply_projector(psi_in,psi_out,psi_projector,metric,project_out,& CALL timeset(routineN,handle) ! =S*PSI_proj - CALL cp_dbcsr_init(tmp_no, error=error) - CALL cp_dbcsr_create(tmp_no,template=psi_projector,error=error) + CALL cp_dbcsr_init(tmp_no) + CALL cp_dbcsr_create(tmp_no,template=psi_projector) CALL cp_dbcsr_multiply("N","N",1.0_dp,& metric,psi_projector,& 0.0_dp,tmp_no,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) ! =tr(S.PSI_proj)*PSI_in - CALL cp_dbcsr_init(tmp_ov,error=error) - CALL cp_dbcsr_create(tmp_ov,template=proj_in_template,error=error) + CALL cp_dbcsr_init(tmp_ov) + CALL cp_dbcsr_create(tmp_ov,template=proj_in_template) CALL cp_dbcsr_multiply("T","N",1.0_dp,& tmp_no,psi_in,& 0.0_dp,tmp_ov,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) IF (.NOT.psi_projector_orthogonal) THEN ! =SigInv_proj*Sigma_OV - CALL cp_dbcsr_init(tmp_sig_inv,error=error) - CALL cp_dbcsr_init(tmp_ov2,error=error) + CALL cp_dbcsr_init(tmp_sig_inv) + CALL cp_dbcsr_init(tmp_ov2) CALL cp_dbcsr_create(tmp_ov2,& - template=proj_in_template,error=error) + template=proj_in_template) IF (PRESENT(sig_inv_projector)) THEN CALL cp_dbcsr_create(tmp_sig_inv,& - template=sig_inv_projector,& - error=error) - CALL cp_dbcsr_copy(tmp_sig_inv,sig_inv_projector,error=error) + template=sig_inv_projector) + CALL cp_dbcsr_copy(tmp_sig_inv,sig_inv_projector) ELSE IF (.NOT.PRESENT(sig_inv_template)) THEN - CPErrorMessage(cp_failure_level,routineP,"PROGRAMMING ERROR: provide either template or sig_inv",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"PROGRAMMING ERROR: provide either template or sig_inv") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! compute inverse overlap of the projector orbitals - CALL cp_dbcsr_init(tmp_sig,error=error) + CALL cp_dbcsr_init(tmp_sig) CALL cp_dbcsr_create(tmp_sig,& template=sig_inv_template,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("T","N",1.0_dp,& psi_projector,tmp_no,0.0_dp,tmp_sig,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_create(tmp_sig_inv,& template=sig_inv_template,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL invert_Hotelling(tmp_sig_inv,tmp_sig,& - threshold=eps_filter,error=error) - CALL cp_dbcsr_release(tmp_sig,error=error) + threshold=eps_filter) + CALL cp_dbcsr_release(tmp_sig) ENDIF CALL cp_dbcsr_multiply("N","N",1.0_dp,& tmp_sig_inv,tmp_ov,0.0_dp,tmp_ov2,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(tmp_sig_inv,error=error) - CALL cp_dbcsr_copy(tmp_ov,tmp_ov2,error=error) - CALL cp_dbcsr_release(tmp_ov2,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_release(tmp_sig_inv) + CALL cp_dbcsr_copy(tmp_ov,tmp_ov2) + CALL cp_dbcsr_release(tmp_ov2) ENDIF - CALL cp_dbcsr_release(tmp_no,error=error) + CALL cp_dbcsr_release(tmp_no) ! =PSI_proj*TMP_OV CALL cp_dbcsr_multiply("N","N",1.0_dp,& psi_projector,tmp_ov,0.0_dp,psi_out,& - filter_eps=eps_filter,& - error=error) - CALL cp_dbcsr_release(tmp_ov,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_release(tmp_ov) ! V_out=V_in-V_out IF (project_out) THEN - CALL cp_dbcsr_add(psi_out,psi_in,-1.0_dp,+1.0_dp,error=error) + CALL cp_dbcsr_add(psi_out,psi_in,-1.0_dp,+1.0_dp) ENDIF CALL timestop(handle) @@ -1975,13 +1822,12 @@ END SUBROUTINE apply_projector !!> 2011.07 created [Rustam Z Khaliullin] !!> \author Rustam Z Khaliullin !! ***************************************************************************** -! SUBROUTINE almo_scf_p_out_from_v(v_in,v_out,ov_template,ispin,almo_scf_env,error) +! SUBROUTINE almo_scf_p_out_from_v(v_in,v_out,ov_template,ispin,almo_scf_env) ! ! TYPE(cp_dbcsr_type), INTENT(IN) :: v_in, ov_template ! TYPE(cp_dbcsr_type), INTENT(INOUT) :: v_out ! INTEGER, INTENT(IN) :: ispin ! TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env -! TYPE(cp_error_type), INTENT(INOUT) :: error ! ! CHARACTER(LEN=*), PARAMETER :: & ! routineN = 'almo_scf_p_out_from_v', & @@ -1994,45 +1840,41 @@ END SUBROUTINE apply_projector ! CALL timeset(routineN,handle) ! ! ! =tr(T_blk)*S -! CALL cp_dbcsr_init(tmp_on, error=error) +! CALL cp_dbcsr_init(tmp_on) ! CALL cp_dbcsr_create(tmp_on,& -! template=almo_scf_env%matrix_t_tr(ispin),error=error) +! template=almo_scf_env%matrix_t_tr(ispin)) ! CALL cp_dbcsr_multiply("T","N",1.0_dp,& ! almo_scf_env%matrix_t_blk(ispin),& ! almo_scf_env%matrix_s(1),& ! 0.0_dp,tmp_on,& -! filter_eps=almo_scf_env%eps_filter,& -! error=error) +! filter_eps=almo_scf_env%eps_filter) ! ! ! =tr(T_blk).S*V_in -! CALL cp_dbcsr_init(tmp_ov,error=error) -! CALL cp_dbcsr_create(tmp_ov,template=ov_template,error=error) +! CALL cp_dbcsr_init(tmp_ov) +! CALL cp_dbcsr_create(tmp_ov,template=ov_template) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! tmp_on,v_in,0.0_dp,tmp_ov,& -! filter_eps=almo_scf_env%eps_filter,& -! error=error) -! CALL cp_dbcsr_release(tmp_on,error=error) +! filter_eps=almo_scf_env%eps_filter) +! CALL cp_dbcsr_release(tmp_on) ! ! ! =SigmaInv*Sigma_OV -! CALL cp_dbcsr_init(tmp_ov2, error=error) -! CALL cp_dbcsr_create(tmp_ov2,template=ov_template,error=error) +! CALL cp_dbcsr_init(tmp_ov2) +! CALL cp_dbcsr_create(tmp_ov2,template=ov_template) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! almo_scf_env%matrix_sigma_inv(ispin),& ! tmp_ov,0.0_dp,tmp_ov2,& -! filter_eps=almo_scf_env%eps_filter,& -! error=error) -! CALL cp_dbcsr_release(tmp_ov,error=error) +! filter_eps=almo_scf_env%eps_filter) +! CALL cp_dbcsr_release(tmp_ov) ! ! ! =T_blk*SigmaInv.Sigma_OV ! CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! almo_scf_env%matrix_t_blk(ispin),& ! tmp_ov2,0.0_dp,v_out,& -! filter_eps=almo_scf_env%eps_filter,& -! error=error) -! CALL cp_dbcsr_release(tmp_ov2,error=error) +! filter_eps=almo_scf_env%eps_filter) +! CALL cp_dbcsr_release(tmp_ov2) ! ! ! V_out=V_in-V_out= -! CALL cp_dbcsr_add(v_out,v_in,-1.0_dp,+1.0_dp,error=error) +! CALL cp_dbcsr_add(v_out,v_in,-1.0_dp,+1.0_dp) ! ! CALL timestop(handle) ! @@ -2042,17 +1884,15 @@ END SUBROUTINE apply_projector !> \brief computes the idempotent density matrix from ALMOs !> \param almo_scf_env ... !> \param use_sigma_inv_guess ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> 2011.07 converted into a wrapper which calls almo_scf_t_to_p !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_t_blk_to_p(almo_scf_env,use_sigma_inv_guess,error) + SUBROUTINE almo_scf_t_blk_to_p(almo_scf_env,use_sigma_inv_guess) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env LOGICAL, INTENT(IN), OPTIONAL :: use_sigma_inv_guess - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'almo_scf_t_blk_to_p', & routineP = moduleN//':'//routineN @@ -2077,16 +1917,14 @@ SUBROUTINE almo_scf_t_blk_to_p(almo_scf_env,use_sigma_inv_guess,error) s=almo_scf_env%matrix_s(1),& sigma=almo_scf_env%matrix_sigma(ispin),& sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& - use_guess=use_guess,& - error=error) + use_guess=use_guess) IF (almo_scf_env%nspins == 1) THEN spin_factor = 2.0_dp ELSE spin_factor = 1.0_dp ENDIF - CALL cp_dbcsr_scale(almo_scf_env%matrix_p(ispin),spin_factor,& - error=error) + CALL cp_dbcsr_scale(almo_scf_env%matrix_p(ispin),spin_factor) END DO @@ -2100,17 +1938,15 @@ END SUBROUTINE almo_scf_t_blk_to_p !> \param X ... !> \param U ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2011.08 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE generator_to_unitary(X,U,eps_filter,error) + SUBROUTINE generator_to_unitary(X,U,eps_filter) TYPE(cp_dbcsr_type), INTENT(IN) :: X TYPE(cp_dbcsr_type), INTENT(INOUT) :: U REAL(KIND=dp), INTENT(IN) :: eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'generator_to_unitary', & routineP = moduleN//':'//routineN @@ -2126,67 +1962,67 @@ SUBROUTINE generator_to_unitary(X,U,eps_filter,error) safe_mode=.TRUE. ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE unit_nr=-1 ENDIF - CALL cp_dbcsr_init(t1,error=error) + CALL cp_dbcsr_init(t1) CALL cp_dbcsr_create(t1,template=X,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(t2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(t2) CALL cp_dbcsr_create(t2,template=X,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ! create antisymmetric Delta = -X + tr(X) - CALL cp_dbcsr_init(delta,error=error) + CALL cp_dbcsr_init(delta) CALL cp_dbcsr_create(delta,template=X,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_transposed(delta,X,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_transposed(delta,X) ! check that transposed is added correctly - CALL cp_dbcsr_add(delta,X,1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_add(delta,X,1.0_dp,-1.0_dp) ! compute (1 - Delta)^(-1) - CALL cp_dbcsr_add_on_diag(t1,1.0_dp,error=error) - CALL cp_dbcsr_add(t1,delta,1.0_dp,-1.0_dp,error=error) - CALL invert_Hotelling(t2,t1,threshold=eps_filter,error=error) + CALL cp_dbcsr_add_on_diag(t1,1.0_dp) + CALL cp_dbcsr_add(t1,delta,1.0_dp,-1.0_dp) + CALL invert_Hotelling(t2,t1,threshold=eps_filter) IF (safe_mode) THEN - CALL cp_dbcsr_init(tmp1,error=error) + CALL cp_dbcsr_init(tmp1) CALL cp_dbcsr_create(tmp1,template=X,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, t2, t1, 0.0_dp, tmp1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(tmp1) - CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(A)*A-I)",frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(tmp1,error=error) + CALL cp_dbcsr_release(tmp1) ENDIF CALL cp_dbcsr_multiply("N","N",1.0_dp,delta,t2,0.0_dp,U,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_add(U,t2,1.0_dp,1.0_dp,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_add(U,t2,1.0_dp,1.0_dp) IF (safe_mode) THEN - CALL cp_dbcsr_init(tmp1,error=error) + CALL cp_dbcsr_init(tmp1) CALL cp_dbcsr_create(tmp1,template=X,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, U, U, 0.0_dp, tmp1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(tmp1) - CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (trn(U)*U-I)",frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(tmp1,error=error) + CALL cp_dbcsr_release(tmp1) ENDIF CALL timestop(handle) @@ -2208,14 +2044,12 @@ END SUBROUTINE generator_to_unitary !> \param filter_eps ... !> \param matrix_trimmer ... !> \param use_trimmer ... -!> \param error ... !> \par History !> 2013.01 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE apply_domain_operators(matrix_in,matrix_out,operator1,operator2,& - dpattern,map,node_of_domain,my_action,filter_eps,matrix_trimmer,use_trimmer,& - error) + dpattern,map,node_of_domain,my_action,filter_eps,matrix_trimmer,use_trimmer) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_in TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_out @@ -2231,7 +2065,6 @@ SUBROUTINE apply_domain_operators(matrix_in,matrix_out,operator1,operator2,& TYPE(cp_dbcsr_type), INTENT(IN), & OPTIONAL :: matrix_trimmer LOGICAL, INTENT(IN), OPTIONAL :: use_trimmer - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_domain_operators', & routineP = moduleN//':'//routineN @@ -2258,16 +2091,16 @@ SUBROUTINE apply_domain_operators(matrix_in,matrix_out,operator1,operator2,& IF (my_use_trimmer) THEN matrix_trimmer_required=.TRUE. - CPErrorMessage(cp_failure_level,routineP,"TRIMMED PROJECTOR DISABLED!",error) + CPErrorMessage(cp_failure_level,routineP,"TRIMMED PROJECTOR DISABLED!") ENDIF IF (.NOT.PRESENT(operator2).AND.operator2_required) THEN - CPErrorMessage(cp_failure_level,routineP,"SECOND OPERATOR IS REQUIRED",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"SECOND OPERATOR IS REQUIRED") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (.NOT.PRESENT(matrix_trimmer).AND.matrix_trimmer_required) THEN - CPErrorMessage(cp_failure_level,routineP,"TRIMMER MATRIX IS REQUIRED",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"TRIMMER MATRIX IS REQUIRED") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ndomains = cp_dbcsr_nblkcols_total(dpattern) @@ -2276,43 +2109,43 @@ SUBROUTINE apply_domain_operators(matrix_in,matrix_out,operator1,operator2,& ALLOCATE(subm_temp(ndomains)) ALLOCATE(subm_out(ndomains)) !!!TRIM ALLOCATE(subm_trimmer(ndomains)) - CALL init_submatrices(subm_in,error) - CALL init_submatrices(subm_temp,error) - CALL init_submatrices(subm_out,error) + CALL init_submatrices(subm_in) + CALL init_submatrices(subm_temp) + CALL init_submatrices(subm_out) CALL construct_submatrices(matrix_in,subm_in,& - dpattern,map,node_of_domain,select_row,error) + dpattern,map,node_of_domain,select_row) !!!TRIM IF (matrix_trimmer_required) THEN !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& - !!!TRIM dpattern,map,node_of_domain,select_row,error) + !!!TRIM dpattern,map,node_of_domain,select_row) !!!TRIM ENDIF IF (my_action.eq.0) THEN ! for example, apply preconditioner CALL multiply_submatrices('N','N',1.0_dp,operator1,& - subm_in,0.0_dp,subm_out,error) + subm_in,0.0_dp,subm_out) ELSE IF (my_action.eq.1) THEN ! use for projectors - CALL copy_submatrices(subm_in,subm_out,.TRUE.,error) + CALL copy_submatrices(subm_in,subm_out,.TRUE.) CALL multiply_submatrices('N','N',1.0_dp,operator1,& - subm_in,0.0_dp,subm_temp,error) + subm_in,0.0_dp,subm_temp) CALL multiply_submatrices('N','N',-1.0_dp,operator2,& - subm_temp,1.0_dp,subm_out,error) + subm_temp,1.0_dp,subm_out) !GroupID = dbcsr_mp_group(dbcsr_distribution_mp(& ! cp_dbcsr_distribution(dpattern))) -!CALL print_submatrices(subm_out,GroupID,error) +!CALL print_submatrices(subm_out,GroupID) ELSE - CPErrorMessage(cp_failure_level,routineP,"ILLEGAL ACTION",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"ILLEGAL ACTION") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF - CALL construct_dbcsr_from_submatrices(matrix_out,subm_out,dpattern,error) - CALL cp_dbcsr_filter(matrix_out,filter_eps,error=error) + CALL construct_dbcsr_from_submatrices(matrix_out,subm_out,dpattern) + CALL cp_dbcsr_filter(matrix_out,filter_eps) - CALL release_submatrices(subm_out,error) - CALL release_submatrices(subm_temp,error) - CALL release_submatrices(subm_in,error) + CALL release_submatrices(subm_out) + CALL release_submatrices(subm_temp) + CALL release_submatrices(subm_in) DEALLOCATE(subm_out) DEALLOCATE(subm_temp) @@ -2336,14 +2169,13 @@ END SUBROUTINE apply_domain_operators !> \param preconditioner ... !> \param use_trimmer ... !> \param my_action ... -!> \param error ... !> \par History !> 2013.01 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& subm_r_down,matrix_trimmer,dpattern,map,node_of_domain,preconditioner,& - use_trimmer,my_action,error) + use_trimmer,my_action) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_main TYPE(domain_submatrix_type), & @@ -2357,7 +2189,6 @@ SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& DIMENSION(:), INTENT(INOUT) :: preconditioner LOGICAL, INTENT(IN), OPTIONAL :: use_trimmer INTEGER, INTENT(IN) :: my_action - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'construct_domain_preconditioner', & @@ -2388,20 +2219,20 @@ SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& IF (my_action.eq.-1) matrix_r_required=.TRUE. IF (my_use_trimmer) THEN matrix_trimmer_required=.TRUE. - CPErrorMessage(cp_failure_level,routineP,"TRIMMED PRECONDITIONER DISABLED!",error) + CPErrorMessage(cp_failure_level,routineP,"TRIMMED PRECONDITIONER DISABLED!") ENDIF IF (.NOT.PRESENT(subm_s_inv).AND.matrix_s_inv_required) THEN - CPErrorMessage(cp_failure_level,routineP,"S_inv SUBMATRICES ARE REQUIRED",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"S_inv SUBMATRICES ARE REQUIRED") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (.NOT.PRESENT(subm_r_down).AND.matrix_r_required) THEN - CPErrorMessage(cp_failure_level,routineP,"R SUBMATRICES ARE REQUIRED",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"R SUBMATRICES ARE REQUIRED") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (.NOT.PRESENT(matrix_trimmer).AND.matrix_trimmer_required) THEN - CPErrorMessage(cp_failure_level,routineP,"TRIMMER MATRIX IS REQUIRED",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"TRIMMER MATRIX IS REQUIRED") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ndomains = cp_dbcsr_nblkcols_total(dpattern) @@ -2409,15 +2240,15 @@ SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& nmos => cp_dbcsr_col_block_sizes(dpattern) ALLOCATE(subm_main(ndomains)) - CALL init_submatrices(subm_main,error) + CALL init_submatrices(subm_main) !!!TRIM ALLOCATE(subm_trimmer(ndomains)) CALL construct_submatrices(matrix_main,subm_main,& - dpattern,map,node_of_domain,select_row_col,error) + dpattern,map,node_of_domain,select_row_col) !!!TRIM IF (matrix_trimmer_required) THEN !!!TRIM CALL construct_submatrices(matrix_trimmer,subm_trimmer,& - !!!TRIM dpattern,map,node_of_domain,select_row,error) + !!!TRIM dpattern,map,node_of_domain,select_row) !!!TRIM ENDIF IF (my_action.eq.-1) THEN @@ -2428,18 +2259,18 @@ SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& ! Minv-TRANSPOSE(Minv)+MATMUL(Minv,TRANSPOSE(tmp)) ALLOCATE(subm_tmp(ndomains)) ALLOCATE(subm_tmp2(ndomains)) - CALL init_submatrices(subm_tmp,error) - CALL init_submatrices(subm_tmp2,error) + CALL init_submatrices(subm_tmp) + CALL init_submatrices(subm_tmp2) CALL multiply_submatrices('N','N',1.0_dp,subm_r_down,& - subm_s_inv,0.0_dp,subm_tmp,error) + subm_s_inv,0.0_dp,subm_tmp) CALL multiply_submatrices('N','N',1.0_dp,subm_tmp,& - subm_main,0.0_dp,subm_tmp2,error) - CALL add_submatrices(1.0_dp,subm_main,-1.0_dp,subm_tmp2,'N',error) - CALL add_submatrices(1.0_dp,subm_main,-1.0_dp,subm_tmp2,'T',error) + subm_main,0.0_dp,subm_tmp2) + CALL add_submatrices(1.0_dp,subm_main,-1.0_dp,subm_tmp2,'N') + CALL add_submatrices(1.0_dp,subm_main,-1.0_dp,subm_tmp2,'T') CALL multiply_submatrices('N','T',1.0_dp,subm_tmp2,& - subm_tmp,1.0_dp,subm_main,error) - CALL release_submatrices(subm_tmp,error) - CALL release_submatrices(subm_tmp2,error) + subm_tmp,1.0_dp,subm_main) + CALL release_submatrices(subm_tmp) + CALL release_submatrices(subm_tmp2) DEALLOCATE(subm_tmp2) DEALLOCATE(subm_tmp) ENDIF @@ -2489,7 +2320,7 @@ SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& !!!TRIM !range1_thr=1.0E-9_dp,range2_thr=1.0E-9_dp,& !!!TRIM shift=1.0E-5_dp,& !!!TRIM range1=nmos(idomain),range2=nmos(idomain),& - !!!TRIM error=error) + !!!TRIM !!!TRIM ! apply the inverted matrix !!!TRIM ! RZK-warning this is only possible when the preconditioner is applied !!!TRIM tmp(:,ii)=MATMUL(Minv,subm_in(idomain)%mdata(:,ii)) @@ -2498,11 +2329,11 @@ SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& !!!TRIM deallocate(tmp) !!!TRIM ELSE CALL pseudo_invert_matrix(A=subm_main(idomain)%mdata,Ainv=Minv,N=naos,method=1,& - range1=nmos(idomain),range2=n_domain_mos,error=error) + range1=nmos(idomain),range2=n_domain_mos) !!!TRIM ENDIF - CALL copy_submatrices(subm_main(idomain),preconditioner(idomain),.FALSE.,error) - CALL copy_submatrix_data(Minv,preconditioner(idomain),error) + CALL copy_submatrices(subm_main(idomain),preconditioner(idomain),.FALSE.) + CALL copy_submatrix_data(Minv,preconditioner(idomain)) DEALLOCATE(Minv) @@ -2510,15 +2341,15 @@ SUBROUTINE construct_domain_preconditioner(matrix_main,subm_s_inv,& ENDDO ! loop over domains - CALL release_submatrices(subm_main,error) + CALL release_submatrices(subm_main) DEALLOCATE(subm_main) !DEALLOCATE(subm_s) !DEALLOCATE(subm_r) !IF (matrix_r_required) THEN - ! CALL cp_dbcsr_release(m_tmp_no_1,error=error) - ! CALL cp_dbcsr_release(m_tmp_no_2,error=error) - ! CALL cp_dbcsr_release(matrix_r,error=error) + ! CALL cp_dbcsr_release(m_tmp_no_1) + ! CALL cp_dbcsr_release(m_tmp_no_2) + ! CALL cp_dbcsr_release(matrix_r) !ENDIF !RZK-warning do we need a barrier here ? @@ -2535,13 +2366,12 @@ END SUBROUTINE construct_domain_preconditioner !> \param dpattern ... !> \param map ... !> \param node_of_domain ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE construct_domain_s_sqrt(matrix_s,subm_s_sqrt,subm_s_sqrt_inv,& - dpattern,map,node_of_domain,error) + dpattern,map,node_of_domain) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_s TYPE(domain_submatrix_type), & @@ -2549,7 +2379,6 @@ SUBROUTINE construct_domain_s_sqrt(matrix_s,subm_s_sqrt,subm_s_sqrt_inv,& TYPE(cp_dbcsr_type), INTENT(IN) :: dpattern TYPE(domain_map_type), INTENT(IN) :: map INTEGER, DIMENSION(:), INTENT(IN) :: node_of_domain - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'construct_domain_s_sqrt', & routineP = moduleN//':'//routineN @@ -2565,13 +2394,13 @@ SUBROUTINE construct_domain_s_sqrt(matrix_s,subm_s_sqrt,subm_s_sqrt_inv,& CALL timeset(routineN,handle) ndomains = cp_dbcsr_nblkcols_total(dpattern) - CPPrecondition(SIZE(subm_s_sqrt).eq.ndomains,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(subm_s_sqrt_inv).eq.ndomains,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(subm_s_sqrt).eq.ndomains,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(subm_s_sqrt_inv).eq.ndomains,cp_failure_level,routineP,failure) ALLOCATE(subm_s(ndomains)) - CALL init_submatrices(subm_s,error) + CALL init_submatrices(subm_s) CALL construct_submatrices(matrix_s,subm_s,& - dpattern,map,node_of_domain,select_row_col,error) + dpattern,map,node_of_domain,select_row_col) ! loop over domains - perform inversion DO idomain = 1, ndomains @@ -2585,13 +2414,13 @@ SUBROUTINE construct_domain_s_sqrt(matrix_s,subm_s_sqrt,subm_s_sqrt_inv,& ALLOCATE(Ssqrtinv(naos,naos)) CALL matrix_sqrt(A=subm_s(idomain)%mdata,Asqrt=Ssqrt,Asqrtinv=Ssqrtinv,& - N=naos,error=error) + N=naos) - CALL copy_submatrices(subm_s(idomain),subm_s_sqrt(idomain),.FALSE.,error) - CALL copy_submatrix_data(Ssqrt,subm_s_sqrt(idomain),error) + CALL copy_submatrices(subm_s(idomain),subm_s_sqrt(idomain),.FALSE.) + CALL copy_submatrix_data(Ssqrt,subm_s_sqrt(idomain)) - CALL copy_submatrices(subm_s(idomain),subm_s_sqrt_inv(idomain),.FALSE.,error) - CALL copy_submatrix_data(Ssqrtinv,subm_s_sqrt_inv(idomain),error) + CALL copy_submatrices(subm_s(idomain),subm_s_sqrt_inv(idomain),.FALSE.) + CALL copy_submatrix_data(Ssqrtinv,subm_s_sqrt_inv(idomain)) DEALLOCATE(Ssqrtinv) DEALLOCATE(Ssqrt) @@ -2600,7 +2429,7 @@ SUBROUTINE construct_domain_s_sqrt(matrix_s,subm_s_sqrt,subm_s_sqrt_inv,& ENDDO ! loop over domains - CALL release_submatrices(subm_s,error) + CALL release_submatrices(subm_s) DEALLOCATE(subm_s) CALL timestop(handle) @@ -2614,13 +2443,12 @@ END SUBROUTINE construct_domain_s_sqrt !> \param dpattern ... !> \param map ... !> \param node_of_domain ... -!> \param error ... !> \par History !> 2013.02 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE construct_domain_s_inv(matrix_s,subm_s_inv,dpattern,map,& - node_of_domain,error) + node_of_domain) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_s TYPE(domain_submatrix_type), & @@ -2628,7 +2456,6 @@ SUBROUTINE construct_domain_s_inv(matrix_s,subm_s_inv,dpattern,map,& TYPE(cp_dbcsr_type), INTENT(IN) :: dpattern TYPE(domain_map_type), INTENT(IN) :: map INTEGER, DIMENSION(:), INTENT(IN) :: node_of_domain - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'construct_domain_s_inv', & routineP = moduleN//':'//routineN @@ -2645,16 +2472,16 @@ SUBROUTINE construct_domain_s_inv(matrix_s,subm_s_inv,dpattern,map,& ndomains = cp_dbcsr_nblkcols_total(dpattern) - CPPrecondition(SIZE(subm_s_inv).eq.ndomains,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(subm_s_inv).eq.ndomains,cp_failure_level,routineP,failure) ALLOCATE(subm_s(ndomains)) - CALL init_submatrices(subm_s,error) + CALL init_submatrices(subm_s) CALL construct_submatrices(matrix_s,subm_s,& - dpattern,map,node_of_domain,select_row_col,error) + dpattern,map,node_of_domain,select_row_col) !GroupID = dbcsr_mp_group(dbcsr_distribution_mp(& ! cp_dbcsr_distribution(dpattern))) - !CALL print_submatrices(domain_r_down(:,ispin),GroupID,error) + !CALL print_submatrices(domain_r_down(:,ispin),GroupID) ! loop over domains - perform inversion DO idomain = 1, ndomains @@ -2667,10 +2494,10 @@ SUBROUTINE construct_domain_s_inv(matrix_s,subm_s_inv,dpattern,map,& ALLOCATE(Sinv(naos,naos)) CALL pseudo_invert_matrix(A=subm_s(idomain)%mdata,Ainv=Sinv,N=naos,& - method=0,error=error) + method=0) - CALL copy_submatrices(subm_s(idomain),subm_s_inv(idomain),.FALSE.,error) - CALL copy_submatrix_data(Sinv,subm_s_inv(idomain),error) + CALL copy_submatrices(subm_s(idomain),subm_s_inv(idomain),.FALSE.) + CALL copy_submatrix_data(Sinv,subm_s_inv(idomain)) DEALLOCATE(Sinv) @@ -2678,7 +2505,7 @@ SUBROUTINE construct_domain_s_inv(matrix_s,subm_s_inv,dpattern,map,& ENDDO ! loop over domains - CALL release_submatrices(subm_s,error) + CALL release_submatrices(subm_s) DEALLOCATE(subm_s) CALL timestop(handle) @@ -2695,13 +2522,12 @@ END SUBROUTINE construct_domain_s_inv !> \param map ... !> \param node_of_domain ... !> \param filter_eps ... -!> \param error ... !> \par History !> 2013.02 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE construct_domain_r_down(matrix_t,matrix_sigma_inv,matrix_s,& - subm_r_down,dpattern,map,node_of_domain,filter_eps,error) + subm_r_down,dpattern,map,node_of_domain,filter_eps) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_t, matrix_sigma_inv, & matrix_s @@ -2711,7 +2537,6 @@ SUBROUTINE construct_domain_r_down(matrix_t,matrix_sigma_inv,matrix_s,& TYPE(domain_map_type), INTENT(IN) :: map INTEGER, DIMENSION(:), INTENT(IN) :: node_of_domain REAL(KIND=dp) :: filter_eps - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'construct_domain_r_down', & routineP = moduleN//':'//routineN @@ -2724,36 +2549,36 @@ SUBROUTINE construct_domain_r_down(matrix_t,matrix_sigma_inv,matrix_s,& CALL timeset(routineN,handle) ! compute the density matrix in the COVARIANT representation - CALL cp_dbcsr_init(matrix_r,error=error) + CALL cp_dbcsr_init(matrix_r) CALL cp_dbcsr_create(matrix_r,& template=matrix_s,& - matrix_type=dbcsr_type_symmetric,error=error) - CALL cp_dbcsr_init(m_tmp_no_1,error=error) + matrix_type=dbcsr_type_symmetric) + CALL cp_dbcsr_init(m_tmp_no_1) CALL cp_dbcsr_create(m_tmp_no_1,& template=matrix_t,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(m_tmp_no_2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(m_tmp_no_2) CALL cp_dbcsr_create(m_tmp_no_2,& template=matrix_t,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s, matrix_t,& - 0.0_dp, m_tmp_no_1, filter_eps=filter_eps, error=error) + 0.0_dp, m_tmp_no_1, filter_eps=filter_eps) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, m_tmp_no_1, matrix_sigma_inv,& - 0.0_dp, m_tmp_no_2, filter_eps=filter_eps, error=error) + 0.0_dp, m_tmp_no_2, filter_eps=filter_eps) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, m_tmp_no_2, m_tmp_no_1,& - 0.0_dp, matrix_r, filter_eps=filter_eps, error=error) + 0.0_dp, matrix_r, filter_eps=filter_eps) - CALL cp_dbcsr_release(m_tmp_no_1,error=error) - CALL cp_dbcsr_release(m_tmp_no_2,error=error) + CALL cp_dbcsr_release(m_tmp_no_1) + CALL cp_dbcsr_release(m_tmp_no_2) ndomains = cp_dbcsr_nblkcols_total(dpattern) - CPPrecondition(SIZE(subm_r_down).eq.ndomains,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(subm_r_down).eq.ndomains,cp_failure_level,routineP,failure) CALL construct_submatrices(matrix_r,subm_r_down,& - dpattern,map,node_of_domain,select_row_col,error) + dpattern,map,node_of_domain,select_row_col) - CALL cp_dbcsr_release(matrix_r,error=error) + CALL cp_dbcsr_release(matrix_r) CALL timestop(handle) @@ -2765,19 +2590,17 @@ END SUBROUTINE construct_domain_r_down !> \param Asqrt ... !> \param Asqrtinv ... !> \param N ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - SUBROUTINE matrix_sqrt(A,Asqrt,Asqrtinv,N,error) + SUBROUTINE matrix_sqrt(A,Asqrt,Asqrtinv,N) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: A REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: Asqrt, Asqrtinv INTEGER, INTENT(IN) :: N - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_sqrt', & routineP = moduleN//':'//routineN @@ -2795,13 +2618,13 @@ SUBROUTINE matrix_sqrt(A,Asqrt,Asqrtinv,N,error) !CALL DPOTRF('L', N, Ainv, N, INFO ) !IF( INFO.NE.0 ) THEN - ! CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed",error) - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + ! CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !END IF !CALL DPOTRI('L', N, Ainv, N, INFO ) !IF( INFO.NE.0 ) THEN - ! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed",error) - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + ! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !END IF !! complete the matrix !DO ii=1,N @@ -2824,8 +2647,8 @@ SUBROUTINE matrix_sqrt(A,Asqrt,Asqrtinv,N,error) CALL DSYEV('V','L',N,Asqrtinv,N,eigenvalues,WORK,LWORK,INFO) IF ( INFO.NE.0 ) THEN WRITE(*,*) 'DSYEV ERROR MESSAGE: ', INFO - CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF DEALLOCATE(WORK) @@ -2880,13 +2703,12 @@ END SUBROUTINE matrix_sqrt !> \param range1_thr ... !> \param range2_thr ... !> \param shift ... -!> \param error ... !> \par History !> 2012.04 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE pseudo_invert_matrix(A,Ainv,N,method,range1,range2,range1_thr,range2_thr,& - shift,error) + shift) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: A @@ -2895,7 +2717,6 @@ SUBROUTINE pseudo_invert_matrix(A,Ainv,N,method,range1,range2,range1_thr,range2_ INTEGER, INTENT(IN) :: N, method INTEGER, INTENT(IN), OPTIONAL :: range1, range2 REAL(KIND=dp), INTENT(IN), OPTIONAL :: range1_thr, range2_thr, shift - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pseudo_invert_matrix', & routineP = moduleN//':'//routineN @@ -2915,14 +2736,14 @@ SUBROUTINE pseudo_invert_matrix(A,Ainv,N,method,range1,range2,range1_thr,range2_ IF (PRESENT(range1)) THEN use_ranges=.TRUE. IF (.NOT.PRESENT(range2)) THEN - CPErrorMessage(cp_failure_level,routineP,"SPECIFY TWO RANGES",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"SPECIFY TWO RANGES") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE use_ranges=.FALSE. IF ((.NOT.PRESENT(range1_thr)).OR.(.NOT.PRESENT(range2_thr))) THEN - CPErrorMessage(cp_failure_level,routineP,"SPECIFY TWO THRESHOLDS",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"SPECIFY TWO THRESHOLDS") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDIF ENDIF @@ -2940,13 +2761,13 @@ SUBROUTINE pseudo_invert_matrix(A,Ainv,N,method,range1,range2,range1_thr,range2_ CALL DPOTRF('L', N, Ainv, N, INFO ) IF( INFO.NE.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF CALL DPOTRI('L', N, Ainv, N, INFO ) IF( INFO.NE.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF ! complete the matrix DO ii=1,N @@ -2971,8 +2792,8 @@ SUBROUTINE pseudo_invert_matrix(A,Ainv,N,method,range1,range2,range1_thr,range2_ CALL DSYEV('V','L',N,Ainv,N,eigenvalues,WORK,LWORK,INFO) IF ( INFO.NE.0 ) THEN WRITE(*,*) 'DSYEV ERROR MESSAGE: ', INFO - CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF DEALLOCATE(WORK) @@ -3021,8 +2842,8 @@ SUBROUTINE pseudo_invert_matrix(A,Ainv,N,method,range1,range2,range1_thr,range2_ CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"Illegal method selected for matrix inversion",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Illegal method selected for matrix inversion") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT @@ -3057,20 +2878,18 @@ END SUBROUTINE pseudo_invert_matrix !> \param quench_t ... !> \param spin_factor ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2012.02 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE newton_grad_to_step(matrix_grad,matrix_step,matrix_s,matrix_ks,& - matrix_t,matrix_sigma_inv,quench_t,spin_factor,eps_filter,error) + matrix_t,matrix_sigma_inv,quench_t,spin_factor,eps_filter) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_grad, matrix_step, & matrix_s TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_ks, matrix_t TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_sigma_inv, quench_t REAL(KIND=dp), INTENT(IN) :: spin_factor, eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'newton_grad_to_step', & routineP = moduleN//':'//routineN @@ -3082,44 +2901,39 @@ SUBROUTINE newton_grad_to_step(matrix_grad,matrix_step,matrix_s,matrix_ks,& CALL timeset(routineN,handle) - CALL cp_dbcsr_init(matrix_s_ao,error=error) + CALL cp_dbcsr_init(matrix_s_ao) CALL cp_dbcsr_create(matrix_s_ao,& template=matrix_s,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_init(matrix_f_ao,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_f_ao) CALL cp_dbcsr_create(matrix_f_ao,& template=matrix_s,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_init(matrix_f_mo,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_f_mo) CALL cp_dbcsr_create(matrix_f_mo,& template=matrix_sigma_inv,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_init(matrix_s_mo,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_s_mo) CALL cp_dbcsr_create(matrix_s_mo,& template=matrix_sigma_inv,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_init(matrix_f_vo,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_f_vo) CALL cp_dbcsr_create(matrix_f_vo,& - template=matrix_t,error=error) - CALL cp_dbcsr_init(matrix_s_vo,error=error) + template=matrix_t) + CALL cp_dbcsr_init(matrix_s_vo) CALL cp_dbcsr_create(matrix_s_vo,& - template=matrix_t,error=error) + template=matrix_t) - CALL cp_dbcsr_init(m_tmp_no_1,error=error) + CALL cp_dbcsr_init(m_tmp_no_1) CALL cp_dbcsr_create(m_tmp_no_1,& - template=matrix_t,error=error) - CALL cp_dbcsr_init(m_tmp_no_3,error=error) + template=matrix_t) + CALL cp_dbcsr_init(m_tmp_no_3) CALL cp_dbcsr_create(m_tmp_no_3,& - template=matrix_t,error=error) - CALL cp_dbcsr_init(m_tmp_oo_2,error=error) + template=matrix_t) + CALL cp_dbcsr_init(m_tmp_oo_2) CALL cp_dbcsr_create(m_tmp_oo_2,& template=matrix_sigma_inv,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) ! calculate S-SRS and (1-R)F(1-R) ! RZK-warning some optimization is ABSOLUTELY NECESSARY @@ -3127,182 +2941,161 @@ SUBROUTINE newton_grad_to_step(matrix_grad,matrix_step,matrix_s,matrix_ks,& matrix_s,& matrix_t,& 0.0_dp,m_tmp_no_1,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& m_tmp_no_1,& matrix_sigma_inv,& 0.0_dp,matrix_s_vo,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_desymmetrize(matrix_s,& - matrix_s_ao,error=error) + matrix_s_ao) CALL cp_dbcsr_multiply("N","T",-1.0_dp,& m_tmp_no_1,& matrix_s_vo,& 1.0_dp,matrix_s_ao,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& matrix_ks,& matrix_t,& 0.0_dp,m_tmp_no_1,& - filter_eps=eps_filter,& - error=error) - CALL cp_dbcsr_desymmetrize(matrix_ks,matrix_f_ao,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_desymmetrize(matrix_ks,matrix_f_ao) CALL cp_dbcsr_multiply("N","T",-1.0_dp,& m_tmp_no_1,& matrix_s_vo,& 1.0_dp,matrix_f_ao,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","T",-1.0_dp,& matrix_s_vo,& m_tmp_no_1,& 1.0_dp,matrix_f_ao,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,& matrix_t,& m_tmp_no_1,& 0.0_dp,matrix_f_mo,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& matrix_s_vo,& matrix_f_mo,& 0.0_dp,m_tmp_no_1,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","T",1.0_dp,& m_tmp_no_1,& matrix_s_vo,& 1.0_dp,matrix_f_ao,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) ! calculate F_mo CALL cp_dbcsr_multiply("N","N",1.0_dp,& matrix_sigma_inv,& matrix_f_mo,& 0.0_dp,m_tmp_oo_2,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& m_tmp_oo_2,& matrix_sigma_inv,& 1.0_dp,matrix_f_mo,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) ! calculate F_vo CALL cp_dbcsr_multiply("N","N",1.0_dp,& matrix_ks,& matrix_t,& 0.0_dp,m_tmp_no_1,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& m_tmp_no_1,& matrix_sigma_inv,& 0.0_dp,matrix_f_vo,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","T",-1.0_dp,& matrix_s_vo,& m_tmp_oo_2,& 1.0_dp,matrix_f_vo,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) - CALL cp_dbcsr_desymmetrize(matrix_sigma_inv,matrix_s_mo,error=error) + CALL cp_dbcsr_desymmetrize(matrix_sigma_inv,matrix_s_mo) !!! RZK-warning: this is HIGHLIGHTED BLOCK !!! check it first if the procedure does not function as it supposed to - !CALL cp_dbcsr_desymmetrize(matrix_s,matrix_s_ao,error=error) - CALL cp_dbcsr_add(matrix_f_ao,matrix_s_ao,1.0_dp,1.0_dp,error=error) + !CALL cp_dbcsr_desymmetrize(matrix_s,matrix_s_ao) + CALL cp_dbcsr_add(matrix_f_ao,matrix_s_ao,1.0_dp,1.0_dp) - CALL cp_dbcsr_set(matrix_f_mo,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_f_mo,1.0_dp,error=error) - CALL cp_dbcsr_filter(matrix_f_mo,eps_filter,error=error) + CALL cp_dbcsr_set(matrix_f_mo,0.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_f_mo,1.0_dp) + CALL cp_dbcsr_filter(matrix_f_mo,eps_filter) - CALL cp_dbcsr_set(matrix_s_mo,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_s_mo,1.0_dp,error=error) - CALL cp_dbcsr_filter(matrix_s_mo,eps_filter,error=error) + CALL cp_dbcsr_set(matrix_s_mo,0.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_s_mo,1.0_dp) + CALL cp_dbcsr_filter(matrix_s_mo,eps_filter) - CALL cp_dbcsr_set(matrix_s_ao,0.0_dp,error=error) - !CALL cp_dbcsr_add_on_diag(matrix_s_ao,1.0_dp,error=error) - CALL cp_dbcsr_filter(matrix_s_ao,eps_filter,error=error) + CALL cp_dbcsr_set(matrix_s_ao,0.0_dp) + !CALL cp_dbcsr_add_on_diag(matrix_s_ao,1.0_dp) + CALL cp_dbcsr_filter(matrix_s_ao,eps_filter) !!! RZK-warning: end of HIGHLIGHTED BLOCK CALL cp_dbcsr_scale(matrix_f_ao,& - 2.0_dp*spin_factor,& - error=error) + 2.0_dp*spin_factor) CALL cp_dbcsr_scale(matrix_s_ao,& - -2.0_dp*spin_factor,& - error=error) + -2.0_dp*spin_factor) CALL cp_dbcsr_scale(matrix_f_vo,& - 2.0_dp*spin_factor,& - error=error) + 2.0_dp*spin_factor) !WRITE(*,*) "INSIDE newton_grad_to_step: " - !CALL cp_dbcsr_print(matrix_s_mo,error=error) - !CALL cp_dbcsr_print(matrix_ks,error=error) - !CALL cp_dbcsr_print(matrix_s,error=error) - !CALL cp_dbcsr_print(matrix_sigma_inv,error=error) + !CALL cp_dbcsr_print(matrix_s_mo) + !CALL cp_dbcsr_print(matrix_ks) + !CALL cp_dbcsr_print(matrix_s) + !CALL cp_dbcsr_print(matrix_sigma_inv) CALL hessian_diag_apply(matrix_grad,matrix_step,matrix_s_ao,& matrix_f_ao,matrix_s_mo,matrix_f_mo,& - matrix_s_vo,matrix_f_vo,quench_t,error) + matrix_s_vo,matrix_f_vo,quench_t) ! check that the step satisfies H.step=-grad - CALL cp_dbcsr_copy(m_tmp_no_3,quench_t,error=error) - CALL cp_dbcsr_copy(m_tmp_no_1,quench_t,error=error) + CALL cp_dbcsr_copy(m_tmp_no_3,quench_t) + CALL cp_dbcsr_copy(m_tmp_no_1,quench_t) CALL cp_dbcsr_multiply("N","N",1.0_dp,& matrix_f_ao,& matrix_step,& 0.0_dp,m_tmp_no_1,& !retain_sparsity=.TRUE.,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& m_tmp_no_1,& matrix_s_mo,& 0.0_dp,m_tmp_no_3,& retain_sparsity=.TRUE.,& - filter_eps=eps_filter,& - error=error) - CALL cp_dbcsr_copy(m_tmp_no_1,quench_t,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_copy(m_tmp_no_1,quench_t) CALL cp_dbcsr_multiply("N","N",1.0_dp,& matrix_s_ao,& matrix_step,& 0.0_dp,m_tmp_no_1,& !retain_sparsity=.TRUE.,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",-1.0_dp,& m_tmp_no_1,& matrix_f_mo,& 1.0_dp,m_tmp_no_3,& retain_sparsity=.TRUE.,& - filter_eps=eps_filter,& - error=error) + filter_eps=eps_filter) CALL cp_dbcsr_add(m_tmp_no_3,matrix_grad,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) CALL cp_dbcsr_norm(m_tmp_no_3,& - dbcsr_norm_maxabsnorm, norm_scalar=res_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=res_norm) WRITE(*,*) "NEWTON step error: ", res_norm - CALL cp_dbcsr_release(m_tmp_no_3,error=error) - CALL cp_dbcsr_release(m_tmp_no_1,error=error) - CALL cp_dbcsr_release(m_tmp_oo_2,error=error) - CALL cp_dbcsr_release(matrix_s_ao,error=error) - CALL cp_dbcsr_release(matrix_s_mo,error=error) - CALL cp_dbcsr_release(matrix_f_ao,error=error) - CALL cp_dbcsr_release(matrix_f_mo,error=error) - CALL cp_dbcsr_release(matrix_s_vo,error=error) - CALL cp_dbcsr_release(matrix_f_vo,error=error) + CALL cp_dbcsr_release(m_tmp_no_3) + CALL cp_dbcsr_release(m_tmp_no_1) + CALL cp_dbcsr_release(m_tmp_oo_2) + CALL cp_dbcsr_release(matrix_s_ao) + CALL cp_dbcsr_release(matrix_s_mo) + CALL cp_dbcsr_release(matrix_f_ao) + CALL cp_dbcsr_release(matrix_f_mo) + CALL cp_dbcsr_release(matrix_s_vo) + CALL cp_dbcsr_release(matrix_f_vo) CALL timestop(handle) @@ -3319,18 +3112,16 @@ END SUBROUTINE newton_grad_to_step !> \param matrix_S_vo ... !> \param matrix_F_vo ... !> \param quench_t ... -!> \param error ... !> \par History !> 2012.02 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& - matrix_F_ao,matrix_S_mo,matrix_F_mo,matrix_S_vo,matrix_F_vo,quench_t,error) + matrix_F_ao,matrix_S_mo,matrix_F_mo,matrix_S_vo,matrix_F_vo,quench_t) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_grad, matrix_step, & matrix_S_ao, matrix_F_ao, matrix_S_mo, matrix_F_mo, matrix_S_vo, & matrix_F_vo, quench_t - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hessian_diag_apply', & routineP = moduleN//':'//routineN @@ -3362,7 +3153,7 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& nblkrows_tot = cp_dbcsr_nblkrows_total(quench_t) nblkcols_tot = cp_dbcsr_nblkcols_total(quench_t) - CPPostcondition(nblkrows_tot==nblkcols_tot,cp_failure_level,routineP,error,failure) + CPPostcondition(nblkrows_tot==nblkcols_tot,cp_failure_level,routineP,failure) mo_blk_sizes => cp_dbcsr_col_block_sizes(quench_t) ao_blk_sizes => cp_dbcsr_row_block_sizes(quench_t) ALLOCATE(mo_block_sizes(nblkcols_tot),ao_block_sizes(nblkcols_tot)) @@ -3371,35 +3162,35 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& ao_block_sizes(:)=ao_blk_sizes(:) ao_domain_sizes(:)=0 - CALL cp_dbcsr_init(matrix_S_ao_sym,error=error) + CALL cp_dbcsr_init(matrix_S_ao_sym) CALL cp_dbcsr_create(matrix_S_ao_sym,& template=matrix_S_ao,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_desymmetrize(matrix_S_ao,matrix_S_ao_sym,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_desymmetrize(matrix_S_ao,matrix_S_ao_sym) - CALL cp_dbcsr_init(matrix_F_ao_sym,error=error) + CALL cp_dbcsr_init(matrix_F_ao_sym) CALL cp_dbcsr_create(matrix_F_ao_sym,& template=matrix_F_ao,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_desymmetrize(matrix_F_ao,matrix_F_ao_sym,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_desymmetrize(matrix_F_ao,matrix_F_ao_sym) - CALL cp_dbcsr_init(matrix_S_mo_sym,error=error) + CALL cp_dbcsr_init(matrix_S_mo_sym) CALL cp_dbcsr_create(matrix_S_mo_sym,& template=matrix_S_mo,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_desymmetrize(matrix_S_mo,matrix_S_mo_sym,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_desymmetrize(matrix_S_mo,matrix_S_mo_sym) - CALL cp_dbcsr_init(matrix_F_mo_sym,error=error) + CALL cp_dbcsr_init(matrix_F_mo_sym) CALL cp_dbcsr_create(matrix_F_mo_sym,& template=matrix_F_mo,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_desymmetrize(matrix_F_mo,matrix_F_mo_sym,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_desymmetrize(matrix_F_mo,matrix_F_mo_sym) - !CALL cp_dbcsr_print(matrix_grad,error=error) - !CALL cp_dbcsr_print(matrix_F_ao_sym,error=error) - !CALL cp_dbcsr_print(matrix_S_ao_sym,error=error) - !CALL cp_dbcsr_print(matrix_F_mo_sym,error=error) - !CALL cp_dbcsr_print(matrix_S_mo_sym,error=error) + !CALL cp_dbcsr_print(matrix_grad) + !CALL cp_dbcsr_print(matrix_F_ao_sym) + !CALL cp_dbcsr_print(matrix_S_ao_sym) + !CALL cp_dbcsr_print(matrix_F_mo_sym) + !CALL cp_dbcsr_print(matrix_S_mo_sym) ! loop over domains to find the size of the Hessian H_size=0 @@ -3553,10 +3344,10 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& ENDDO ! row fragment - CALL cp_dbcsr_release(matrix_S_ao_sym,error=error) - CALL cp_dbcsr_release(matrix_F_ao_sym,error=error) - CALL cp_dbcsr_release(matrix_S_mo_sym,error=error) - CALL cp_dbcsr_release(matrix_F_mo_sym,error=error) + CALL cp_dbcsr_release(matrix_S_ao_sym) + CALL cp_dbcsr_release(matrix_F_ao_sym) + CALL cp_dbcsr_release(matrix_S_mo_sym) + CALL cp_dbcsr_release(matrix_F_mo_sym) ! two more terms of the Hessian ALLOCATE(H1(H_size,H_size)) @@ -3722,8 +3513,8 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& CALL DSYEV('V','L',H_size,Hinv,H_size,eigenvalues,WORK,LWORK,INFO) IF( INFO.NE.0 ) THEN WRITE(*,*) 'DSYEV ERROR MESSAGE: ', INFO - CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF DEALLOCATE(WORK) @@ -3748,7 +3539,7 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& !! shift to kill singularity !shift=0.0_dp !IF (eigenvalues(1).lt.0.0_dp) THEN - ! CPErrorMessage(cp_failure_level,routineP,"Negative eigenvalue(s)",error) + ! CPErrorMessage(cp_failure_level,routineP,"Negative eigenvalue(s)") ! shift=abs(eigenvalues(1)) ! WRITE(*,*) "Lowest eigenvalue: ", eigenvalues(1) !ENDIF @@ -3771,14 +3562,14 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& !!!! CALL DPOTRF('L', H_size, Hinv, H_size, INFO ) !!!! IF( INFO.NE.0 ) THEN !!!! WRITE(*,*) 'DPOTRF ERROR MESSAGE: ', INFO -!!!! CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed",error) -!!!! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) +!!!! CPErrorMessage(cp_failure_level,routineP,"DPOTRF failed") +!!!! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !!!! END IF !!!! CALL DPOTRI('L', H_size, Hinv, H_size, INFO ) !!!! IF( INFO.NE.0 ) THEN !!!! WRITE(*,*) 'DPOTRI ERROR MESSAGE: ', INFO -!!!! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed",error) -!!!! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) +!!!! CPErrorMessage(cp_failure_level,routineP,"DPOTRI failed") +!!!! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !!!! END IF !!!! ! complete the matrix !!!! DO ii=1,H_size @@ -3830,9 +3621,8 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& ! re-create the step matrix to remove all blocks CALL cp_dbcsr_create(matrix_step,& template=matrix_grad,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_work_create(matrix_step,work_mutable=.TRUE.,& - error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_work_create(matrix_step,work_mutable=.TRUE.) lev1_vert_offset=0 ! loop over all electron blocks @@ -3848,7 +3638,7 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(matrix_step,row,col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) ! copy the data column by column DO orb_i=1, mo_block_sizes(col) p_new_block(:,orb_i) = & @@ -3869,7 +3659,7 @@ SUBROUTINE hessian_diag_apply(matrix_grad,matrix_step,matrix_S_ao,& DEALLOCATE(Step_vec) - CALL cp_dbcsr_finalize(matrix_step,error=error) + CALL cp_dbcsr_finalize(matrix_step) DEALLOCATE(mo_block_sizes,ao_block_sizes) DEALLOCATE(ao_domain_sizes) @@ -3881,15 +3671,13 @@ END SUBROUTINE hessian_diag_apply ! ***************************************************************************** !> \brief Load balancing of the submatrix computations !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2013.02 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - SUBROUTINE distribute_domains(almo_scf_env,error) + SUBROUTINE distribute_domains(almo_scf_env) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribute_domains', & routineP = moduleN//':'//routineN @@ -3939,17 +3727,15 @@ END SUBROUTINE distribute_domains !> \param dpattern ... !> \param map ... !> \param node_of_domain ... -!> \param error ... !> \par History !> 2013.01 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - SUBROUTINE construct_test(matrix_no,dpattern,map,node_of_domain,error) + SUBROUTINE construct_test(matrix_no,dpattern,map,node_of_domain) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_no, dpattern TYPE(domain_map_type), INTENT(IN) :: map INTEGER, DIMENSION(:), INTENT(IN) :: node_of_domain - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'construct_test', & routineP = moduleN//':'//routineN @@ -3966,27 +3752,27 @@ SUBROUTINE construct_test(matrix_no,dpattern,map,node_of_domain,error) cp_dbcsr_distribution(dpattern))) ALLOCATE(subm_no(ndomains),subm_nn(ndomains)) - CALL init_submatrices(subm_no,error) - CALL init_submatrices(subm_nn,error) + CALL init_submatrices(subm_no) + CALL init_submatrices(subm_nn) - !CALL cp_dbcsr_print(matrix_nn,error=error) - !CALL construct_submatrices(matrix_nn,subm_nn,dpattern,map,select_row_col,error) - !CALL print_submatrices(subm_nn,GroupID,error) + !CALL cp_dbcsr_print(matrix_nn) + !CALL construct_submatrices(matrix_nn,subm_nn,dpattern,map,select_row_col) + !CALL print_submatrices(subm_nn,GroupID) - !CALL cp_dbcsr_print(matrix_no,error=error) - CALL construct_submatrices(matrix_no,subm_no,dpattern,map,node_of_domain,select_row,error) - CALL print_submatrices(subm_no,GroupID,error) + !CALL cp_dbcsr_print(matrix_no) + CALL construct_submatrices(matrix_no,subm_no,dpattern,map,node_of_domain,select_row) + CALL print_submatrices(subm_no,GroupID) - CALL cp_dbcsr_init(copy1,error=error) - CALL cp_dbcsr_create(copy1,template=matrix_no,error=error) - CALL cp_dbcsr_copy(copy1,matrix_no,error=error) - CALL cp_dbcsr_print(copy1,error=error) - CALL construct_dbcsr_from_submatrices(copy1,subm_no,dpattern,error) - CALL cp_dbcsr_print(copy1,error=error) - CALL cp_dbcsr_release(copy1,error=error) + CALL cp_dbcsr_init(copy1) + CALL cp_dbcsr_create(copy1,template=matrix_no) + CALL cp_dbcsr_copy(copy1,matrix_no) + CALL cp_dbcsr_print(copy1) + CALL construct_dbcsr_from_submatrices(copy1,subm_no,dpattern) + CALL cp_dbcsr_print(copy1) + CALL cp_dbcsr_release(copy1) - CALL release_submatrices(subm_no,error) - CALL release_submatrices(subm_nn,error) + CALL release_submatrices(subm_no) + CALL release_submatrices(subm_nn) DEALLOCATE(subm_no,subm_nn) CALL timestop(handle) diff --git a/src/almo_scf_optimizer.F b/src/almo_scf_optimizer.F index 2843ab00c8..eeb0b8a214 100644 --- a/src/almo_scf_optimizer.F +++ b/src/almo_scf_optimizer.F @@ -104,16 +104,14 @@ MODULE almo_scf_optimizer !> \param qs_env ... !> \param almo_scf_env ... !> \param optimizer ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) + SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env TYPE(optimizer_options_type) :: optimizer - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_block_diagonal', & routineP = moduleN//':'//routineN @@ -138,7 +136,7 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -157,15 +155,14 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) ALLOCATE(matrix_mixing_old_blk(nspin)) ALLOCATE(almo_diis(nspin)) DO ispin=1,nspin - CALL cp_dbcsr_init(matrix_mixing_old_blk(ispin),error=error) + CALL cp_dbcsr_init(matrix_mixing_old_blk(ispin)) CALL cp_dbcsr_create(matrix_mixing_old_blk(ispin),& - template=almo_scf_env%matrix_ks_blk(ispin),error=error) + template=almo_scf_env%matrix_ks_blk(ispin)) CALL almo_scf_diis_init(diis_env=almo_diis(ispin),& sample_err=almo_scf_env%matrix_ks_blk(ispin),& sample_var=almo_scf_env%matrix_s_blk(1),& error_type=1,& - max_length=optimizer%ndiis,& - error=error) + max_length=optimizer%ndiis) ENDDO energy_old=0.0_dp @@ -193,28 +190,27 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) iscf=iscf+1 ! get a copy of the current KS matrix - CALL get_qs_env(qs_env, matrix_ks=matrix_ks, error=error) + CALL get_qs_env(qs_env, matrix_ks=matrix_ks) DO ispin=1,nspin CALL matrix_qs_to_almo(matrix_ks(ispin)%matrix,& almo_scf_env%matrix_ks(ispin),& - almo_scf_env,.FALSE.,error=error) + almo_scf_env,.FALSE.) CALL matrix_qs_to_almo(matrix_ks(ispin)%matrix,& almo_scf_env%matrix_ks_blk(ispin),& - almo_scf_env,.TRUE.,error=error) + almo_scf_env,.TRUE.) CALL cp_dbcsr_filter(almo_scf_env%matrix_ks(ispin),& - almo_scf_env%eps_filter,error=error) + almo_scf_env%eps_filter) ENDDO ! obtain projected KS matrix and the DIIS-error vector - CALL almo_scf_ks_to_ks_blk(almo_scf_env,error=error) + CALL almo_scf_ks_to_ks_blk(almo_scf_env) ! inform the DIIS handler about the new KS matrix and its error vector IF (use_diis) THEN DO ispin=1,nspin CALL almo_scf_diis_push(diis_env=almo_diis(ispin),& var=almo_scf_env%matrix_ks_blk(ispin),& - err=almo_scf_env%matrix_err_blk(ispin),& - error=error) + err=almo_scf_env%matrix_err_blk(ispin)) ENDDO ENDIF @@ -224,7 +220,7 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) !error_norm=cp_dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) CALL cp_dbcsr_norm(almo_scf_env%matrix_err_blk(ispin),& dbcsr_norm_maxabsnorm,& - norm_scalar=error_norm_ispin, error=error) + norm_scalar=error_norm_ispin) IF (ispin.eq.1) error_norm=error_norm_ispin IF (ispin.gt.1 .AND. error_norm_ispin.gt.error_norm) & error_norm=error_norm_ispin @@ -242,7 +238,7 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) ! check other exit criteria: max SCF steps and timing CALL external_control(should_stop,"SCF",& start_time=qs_env%start_time,& - target_time=qs_env%target_time,error=error) + target_time=qs_env%target_time) IF (should_stop .OR. iscf>=optimizer%max_iter .OR. converged) THEN prepare_to_exit=.TRUE. ENDIF @@ -254,8 +250,7 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) IF (use_diis) THEN ! use diis instead of mixing DO ispin=1,nspin CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin),& - extr_var=almo_scf_env%matrix_ks_blk(ispin),& - error=error) + extr_var=almo_scf_env%matrix_ks_blk(ispin)) ENDDO ELSE ! use mixing true_mixing_fraction=almo_scf_env%mixing_fraction @@ -263,22 +258,21 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),& matrix_mixing_old_blk(ispin),& true_mixing_fraction,& - 1.0_dp-true_mixing_fraction,& - error=error) + 1.0_dp-true_mixing_fraction) END DO ENDIF ENDIF ! save the new matrix for the future mixing DO ispin=1,nspin CALL cp_dbcsr_copy(matrix_mixing_old_blk(ispin),& - almo_scf_env%matrix_ks_blk(ispin), error=error) + almo_scf_env%matrix_ks_blk(ispin)) ENDDO ! obtain ALMOs from the new KS matrix SELECT CASE (almo_scf_env%almo_update_algorithm) CASE (almo_scf_diag) - CALL almo_scf_ks_blk_to_tv_blk(almo_scf_env,error) + CALL almo_scf_ks_blk_to_tv_blk(almo_scf_env) CASE (almo_scf_dm_sign) @@ -291,7 +285,7 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) ! RZK UPDATE! it requires updating core LS_SCF routines ! RZK UPDATE! (the code exists in the CVS version) IF (unit_nr>0) WRITE(unit_nr,'(T2,A)') "Density_matrix_sign has not been tested yet" - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ! RZK UPDATE! CALL density_matrix_sign(almo_scf_env%matrix_p_blk(ispin),& ! RZK UPDATE! local_mu,& ! RZK UPDATE! almo_scf_env%fixed_mu,& @@ -301,24 +295,24 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) ! RZK UPDATE! almo_scf_env%matrix_s_blk_inv(1), & ! RZK UPDATE! local_nocc_of_domain,& ! RZK UPDATE! almo_scf_env%eps_filter,& - ! RZK UPDATE! almo_scf_env%domain_index_of_ao,& - ! RZK UPDATE! error) + ! RZK UPDATE! almo_scf_env%domain_index_of_ao) + ! RZK UPDATE! almo_scf_env%mu_of_domain(:,ispin)=local_mu(:) ENDDO ! obtain ALMOs from matrix_p_blk: T_new = P_blk S_blk T_old - CALL almo_scf_p_blk_to_t_blk(almo_scf_env,error) - CALL almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error=error) + CALL almo_scf_p_blk_to_t_blk(almo_scf_env) + CALL almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env) END SELECT ! obtain density matrix from ALMOs CALL almo_scf_t_blk_to_p(almo_scf_env,& - use_sigma_inv_guess=use_prev_as_guess,error=error) + use_sigma_inv_guess=use_prev_as_guess) ! compute the new KS matrix and new energy - CALL almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new,error) + CALL almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new) ENDIF ! prepare_to_exit @@ -343,12 +337,12 @@ SUBROUTINE almo_scf_block_diagonal(qs_env,almo_scf_env,optimizer,error) IF (unit_nr>0) WRITE(unit_nr,'(T2,A)') "SCF for block-diagonal ALMOs not converged! " ! DANGER: handle non-convergent procedures outside since other outer ! methods can be used - !CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + !CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF DO ispin=1,nspin - CALL cp_dbcsr_release(matrix_mixing_old_blk(ispin),error=error) - CALL almo_scf_diis_release(diis_env=almo_diis(ispin),error=error) + CALL cp_dbcsr_release(matrix_mixing_old_blk(ispin)) + CALL almo_scf_diis_release(diis_env=almo_diis(ispin)) ENDDO DEALLOCATE(almo_diis) DEALLOCATE(matrix_mixing_old_blk) @@ -365,16 +359,14 @@ END SUBROUTINE almo_scf_block_diagonal !> \param qs_env ... !> \param almo_scf_env ... !> \param optimizer ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) + SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env TYPE(optimizer_options_type) :: optimizer - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_xalmo_eigensolver', & routineP = moduleN//':'//routineN @@ -398,7 +390,7 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -421,16 +413,14 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) subm_s_sqrt_inv=almo_scf_env%domain_s_sqrt_inv(:,ispin),& dpattern=almo_scf_env%quench_t(ispin),& map=almo_scf_env%domain_map(ispin),& - node_of_domain=almo_scf_env%cpu_of_domain,& - error=error) + node_of_domain=almo_scf_env%cpu_of_domain) ! TRY: construct s_inv !CALL construct_domain_s_inv(& ! matrix_s=almo_scf_env%matrix_s(1),& ! subm_s_inv=almo_scf_env%domain_s_inv(:,ispin),& ! dpattern=almo_scf_env%quench_t(ispin),& ! map=almo_scf_env%domain_map(ispin),& - ! node_of_domain=almo_scf_env%cpu_of_domain,& - ! error=error) + ! node_of_domain=almo_scf_env%cpu_of_domain) ! construct the domain template for the occupied orbitals DO ispin=1,nspin @@ -443,18 +433,18 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) distr_pattern=almo_scf_env%quench_t(ispin),& domain_map=almo_scf_env%domain_map(ispin),& node_of_domain=almo_scf_env%cpu_of_domain,& - job_type=select_row,error=error) + job_type=select_row) ENDDO ! init mixing matrices ALLOCATE(submatrix_mixing_old_blk(almo_scf_env%ndomains,nspin)) - CALL init_submatrices(submatrix_mixing_old_blk,error=error) + CALL init_submatrices(submatrix_mixing_old_blk) ALLOCATE(almo_diis(nspin)) ! TRY: construct block-projector !ALLOCATE(submatrix_tmp(almo_scf_env%ndomains)) !DO ispin=1,nspin - ! CALL init_submatrices(submatrix_tmp,error=error) + ! CALL init_submatrices(submatrix_tmp) ! CALL construct_domain_r_down(& ! matrix_t=almo_scf_env%matrix_t_blk(ispin),& ! matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& @@ -463,14 +453,12 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) ! dpattern=almo_scf_env%quench_t(ispin),& ! map=almo_scf_env%domain_map(ispin),& ! node_of_domain=almo_scf_env%cpu_of_domain,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) ! CALL multiply_submatrices('N','N',1.0_dp,& ! submatrix_tmp(:),& ! almo_scf_env%domain_s_inv(:,1),0.0_dp,& - ! almo_scf_env%domain_r_down_up(:,ispin),& - ! error) - ! CALL release_submatrices(submatrix_tmp,error=error) + ! almo_scf_env%domain_r_down_up(:,ispin)) + ! CALL release_submatrices(submatrix_tmp) !ENDDO !DEALLOCATE(submatrix_tmp) @@ -481,8 +469,7 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) sample_err=almo_scf_env%domain_s_sqrt(:,ispin),& sample_var=almo_scf_env%domain_s_sqrt_inv(:,ispin),& error_type=1,& - max_length=optimizer%ndiis,& - error=error) + max_length=optimizer%ndiis) ENDDO denergy_tot=0.0_dp @@ -497,27 +484,26 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) iscf=iscf+1 ! get a copy of the current KS matrix - CALL get_qs_env(qs_env, matrix_ks=matrix_ks, error=error) + CALL get_qs_env(qs_env, matrix_ks=matrix_ks) DO ispin=1,nspin CALL matrix_qs_to_almo(matrix_ks(ispin)%matrix,& almo_scf_env%matrix_ks(ispin),& - almo_scf_env,.FALSE.,error=error) + almo_scf_env,.FALSE.) CALL matrix_qs_to_almo(matrix_ks(ispin)%matrix,& almo_scf_env%matrix_ks_blk(ispin),& - almo_scf_env,.TRUE.,error=error) + almo_scf_env,.TRUE.) CALL cp_dbcsr_filter(almo_scf_env%matrix_ks(ispin),& - almo_scf_env%eps_filter,error=error) + almo_scf_env%eps_filter) ENDDO ! obtain projected KS matrix and the DIIS-error vector - CALL almo_scf_ks_to_ks_xx(almo_scf_env,error=error) + CALL almo_scf_ks_to_ks_xx(almo_scf_env) ! inform the DIIS handler about the new KS matrix and its error vector DO ispin=1,nspin CALL almo_scf_diis_push(diis_env=almo_diis(ispin),& d_var=almo_scf_env%domain_ks_xx(:,ispin),& - d_err=almo_scf_env%domain_err(:,ispin),& - error=error) + d_err=almo_scf_env%domain_err(:,ispin)) ENDDO ! check convergence @@ -526,10 +512,9 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) !error_norm=cp_dbcsr_frobenius_norm(almo_scf_env%matrix_err_blk(ispin)) CALL cp_dbcsr_norm(almo_scf_env%matrix_err_xx(ispin),& dbcsr_norm_maxabsnorm,& - norm_scalar=error_norm, error=error) + norm_scalar=error_norm) CALL maxnorm_submatrices(almo_scf_env%domain_err(:,ispin),& - norm=error_norm_0,& - error=error) + norm=error_norm_0) IF (error_norm.gt.optimizer%eps_error) THEN converged=.FALSE. EXIT ! no need to check the other spin @@ -538,7 +523,7 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) ! check other exit criteria: max SCF steps and timing CALL external_control(should_stop,"SCF",& start_time=qs_env%start_time,& - target_time=qs_env%target_time,error=error) + target_time=qs_env%target_time) IF (should_stop .OR. iscf>=optimizer%max_iter .OR. converged) THEN prepare_to_exit=.TRUE. ENDIF @@ -554,18 +539,16 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) almo_scf_env%domain_ks_xx(:,ispin),& 1.0_dp-almo_scf_env%mixing_fraction,& submatrix_mixing_old_blk(:,ispin),& - 'N',error) + 'N') !CALL cp_dbcsr_add(almo_scf_env%matrix_ks_blk(ispin),& ! matrix_mixing_old_blk(ispin),& ! almo_scf_env%mixing_fraction,& - ! 1.0_dp-almo_scf_env%mixing_fraction,& - ! error=error) + ! 1.0_dp-almo_scf_env%mixing_fraction) END DO ELSE DO ispin=1,nspin CALL almo_scf_diis_extrapolate(diis_env=almo_diis(ispin),& - d_extr_var=almo_scf_env%domain_ks_xx(:,ispin),& - error=error) + d_extr_var=almo_scf_env%domain_ks_xx(:,ispin)) ENDDO ENDIF ENDIF @@ -574,23 +557,22 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) CALL copy_submatrices(& almo_scf_env%domain_ks_xx(:,ispin),& submatrix_mixing_old_blk(:,ispin),& - copy_data=.TRUE., error=error) + copy_data=.TRUE.) ENDDO ! obtain a new set of ALMOs from the updated KS matrix - CALL almo_scf_ks_xx_to_tv_xx(almo_scf_env,error) + CALL almo_scf_ks_xx_to_tv_xx(almo_scf_env) ! update the density matrix DO ispin=1,nspin ! save the initial density matrix (to get the perturbative energy lowering) IF (iscf.eq.1) THEN - CALL cp_dbcsr_init(matrix_p_almo_scf_converged, error=error) + CALL cp_dbcsr_init(matrix_p_almo_scf_converged) CALL cp_dbcsr_create(matrix_p_almo_scf_converged,& - template=almo_scf_env%matrix_p(ispin),& - error=error) + template=almo_scf_env%matrix_p(ispin)) CALL cp_dbcsr_copy(matrix_p_almo_scf_converged,& - almo_scf_env%matrix_p(ispin),error=error) + almo_scf_env%matrix_p(ispin)) ENDIF ! update now @@ -602,23 +584,20 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) s=almo_scf_env%matrix_s(1),& sigma=almo_scf_env%matrix_sigma(ispin),& sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& - use_guess=.TRUE.,& - error=error) - CALL cp_dbcsr_scale(almo_scf_env%matrix_p(ispin),spin_factor,& - error=error) + use_guess=.TRUE.) + CALL cp_dbcsr_scale(almo_scf_env%matrix_p(ispin),spin_factor) ! obtain perturbative estimate (at no additional cost) ! of the energy lowering relative to the block-diagonal ALMOs IF (iscf.eq.1) THEN CALL cp_dbcsr_add(matrix_p_almo_scf_converged,& - almo_scf_env%matrix_p(ispin),-1.0_dp,1.0_dp,& - error=error) + almo_scf_env%matrix_p(ispin),-1.0_dp,1.0_dp) CALL cp_dbcsr_trace(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& matrix_p_almo_scf_converged,& - denergy_spin(ispin),error=error) + denergy_spin(ispin)) - CALL cp_dbcsr_release(matrix_p_almo_scf_converged, error=error) + CALL cp_dbcsr_release(matrix_p_almo_scf_converged) denergy_tot=denergy_tot+denergy_spin(ispin) @@ -630,25 +609,21 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) ! produce orbitals with the same sign as the block-diagonal ALMOs ! Any fixes?! - !CALL cp_dbcsr_init(matrix_x, error=error) + !CALL cp_dbcsr_init(matrix_x) !CALL cp_dbcsr_create(matrix_x,& - ! template=almo_scf_env%matrix_t(ispin),& - ! error=error) + ! template=almo_scf_env%matrix_t(ispin)) ! - !CALL cp_dbcsr_init(matrix_tmp_no, error=error) + !CALL cp_dbcsr_init(matrix_tmp_no) !CALL cp_dbcsr_create(matrix_tmp_no,& - ! template=almo_scf_env%matrix_t(ispin),& - ! error=error) + ! template=almo_scf_env%matrix_t(ispin)) ! !CALL cp_dbcsr_copy(matrix_x,& - ! almo_scf_env%matrix_t_blk(ispin),error=error) + ! almo_scf_env%matrix_t_blk(ispin)) !CALL cp_dbcsr_add(matrix_x,almo_scf_env%matrix_t(ispin),& - ! -1.0_dp,1.0_dp,& - ! error=error) + ! -1.0_dp,1.0_dp) !CALL cp_dbcsr_trace(matrix_x,& - ! almo_scf_env%matrix_err_xx(ispin),denergy,"T","N",& - ! error=error) + ! almo_scf_env%matrix_err_xx(ispin),denergy,"T","N") !denergy=denergy*spin_factor @@ -659,15 +634,15 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) !ENDIF !! RZK-warning update will not work since the energy is overwritten almost immediately !!CALL almo_scf_update_ks_energy(qs_env,& - !! almo_scf_env%almo_scf_energy+denergy,& - !! error) + !! almo_scf_env%almo_scf_energy+denergy) + !! !! print out the results of the decomposition analysis !CALL cp_dbcsr_hadamard_product(matrix_x,& ! almo_scf_env%matrix_err_xx(ispin),& - ! matrix_tmp_no,error=error) - !CALL cp_dbcsr_scale(matrix_tmp_no,spin_factor,error=error) - !CALL cp_dbcsr_filter(matrix_tmp_no,almo_scf_env%eps_filter,error=error) + ! matrix_tmp_no) + !CALL cp_dbcsr_scale(matrix_tmp_no,spin_factor) + !CALL cp_dbcsr_filter(matrix_tmp_no,almo_scf_env%eps_filter) ! !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) @@ -679,11 +654,11 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) !WRITE(mynodestr,'(I6.6)') mynode !mylogfile='EDA.'//TRIM(ADJUSTL(mynodestr)) !OPEN (iunit,file=mylogfile,status='REPLACE') - !CALL cp_dbcsr_print_block_sum(matrix_tmp_no,iunit,error=error) + !CALL cp_dbcsr_print_block_sum(matrix_tmp_no,iunit) !CLOSE(iunit) ! - !CALL cp_dbcsr_release(matrix_tmp_no, error=error) - !CALL cp_dbcsr_release(matrix_x, error=error) + !CALL cp_dbcsr_release(matrix_tmp_no) + !CALL cp_dbcsr_release(matrix_x) ENDIF ! iscf.eq.1 @@ -702,13 +677,12 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) WRITE(unit_nr,*) ENDIF CALL almo_scf_update_ks_energy(qs_env,& - almo_scf_env%almo_scf_energy+denergy_tot,& - error) + almo_scf_env%almo_scf_energy+denergy_tot) ENDIF ! compute the new KS matrix and new energy IF (.NOT.almo_scf_env%perturbative_delocalization) THEN - CALL almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new,error) + CALL almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new) ENDIF ENDIF ! prepare_to_exit @@ -742,12 +716,12 @@ SUBROUTINE almo_scf_xalmo_eigensolver(qs_env,almo_scf_env,optimizer,error) IF (.NOT.converged) THEN IF (unit_nr>0) WRITE(unit_nr,'(T2,A)') "SCF for ALMOs on overlapping domains not converged! " - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF DO ispin=1,nspin - CALL release_submatrices(submatrix_mixing_old_blk(:,ispin),error=error) - CALL almo_scf_diis_release(diis_env=almo_diis(ispin),error=error) + CALL release_submatrices(submatrix_mixing_old_blk(:,ispin)) + CALL almo_scf_diis_release(diis_env=almo_diis(ispin)) ENDDO DEALLOCATE(almo_diis) DEALLOCATE(submatrix_mixing_old_blk) @@ -770,14 +744,13 @@ END SUBROUTINE almo_scf_xalmo_eigensolver !> xalmo_case_normal - no special case (i.e. xALMOs) !> xalmo_case_block_diag !> xalmo_case_fully_deloc -!> \param error ... !> \par History !> 2011.11 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& matrix_t_in,matrix_t_out,assume_t0_q0x,perturbation_only,& - special_case,error) + special_case) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env @@ -788,7 +761,6 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& LOGICAL, INTENT(IN) :: assume_t0_q0x, & perturbation_only INTEGER, INTENT(IN), OPTIONAL :: special_case - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_xalmo_pcg', & routineP = moduleN//':'//routineN @@ -826,7 +798,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& IF (PRESENT(special_case)) my_special_case=special_case ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -888,157 +860,153 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& !!!!!! TO ADAPT IT FOR UNRESTRICTED ORBITALS - UPDATE KS MATRIX WITH PARTIALLY !!!!!! OPTIMIZED ORBITALS - BOTH ALPNA AND BETA IF (almo_scf_env%nspins.gt.1) THEN - CPErrorMessage(cp_failure_level,routineP,"UNRESTRICTED ALMO SCF IS NYI(!)",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"UNRESTRICTED ALMO SCF IS NYI(!)") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF DO ispin=1,almo_scf_env%nspins ! init temporary storage - CALL cp_dbcsr_init(m_theta,error=error) - CALL cp_dbcsr_init(prec_vv,error=error) - CALL cp_dbcsr_init(fvo_0,error=error) - CALL cp_dbcsr_init(STsiginv_0,error=error) - CALL cp_dbcsr_init(m_tmp_no_1,error=error) - CALL cp_dbcsr_init(m_tmp_no_2,error=error) - CALL cp_dbcsr_init(m_tmp_no_3,error=error) - CALL cp_dbcsr_init(ST,error=error) - CALL cp_dbcsr_init(FTsiginv,error=error) - CALL cp_dbcsr_init(m_tmp_oo_1,error=error) - CALL cp_dbcsr_init(m_tmp_nn_1,error=error) - CALL cp_dbcsr_init(siginvTFTsiginv,error=error) - CALL cp_dbcsr_init(prec_oo,error=error) - CALL cp_dbcsr_init(prec_oo_inv,error=error) - CALL cp_dbcsr_init(prev_grad,error=error) - CALL cp_dbcsr_init(prev_step,error=error) - CALL cp_dbcsr_init(grad,error=error) - CALL cp_dbcsr_init(step,error=error) - CALL cp_dbcsr_init(prev_minus_prec_grad,error=error) + CALL cp_dbcsr_init(m_theta) + CALL cp_dbcsr_init(prec_vv) + CALL cp_dbcsr_init(fvo_0) + CALL cp_dbcsr_init(STsiginv_0) + CALL cp_dbcsr_init(m_tmp_no_1) + CALL cp_dbcsr_init(m_tmp_no_2) + CALL cp_dbcsr_init(m_tmp_no_3) + CALL cp_dbcsr_init(ST) + CALL cp_dbcsr_init(FTsiginv) + CALL cp_dbcsr_init(m_tmp_oo_1) + CALL cp_dbcsr_init(m_tmp_nn_1) + CALL cp_dbcsr_init(siginvTFTsiginv) + CALL cp_dbcsr_init(prec_oo) + CALL cp_dbcsr_init(prec_oo_inv) + CALL cp_dbcsr_init(prev_grad) + CALL cp_dbcsr_init(prev_step) + CALL cp_dbcsr_init(grad) + CALL cp_dbcsr_init(step) + CALL cp_dbcsr_init(prev_minus_prec_grad) CALL cp_dbcsr_create(prec_vv,& template=almo_scf_env%matrix_ks(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(prec_oo,& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(prec_oo_inv,& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(m_tmp_oo_1,& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(siginvTFTsiginv,& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(STsiginv_0,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(fvo_0,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(m_tmp_no_1,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(m_tmp_no_2,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(m_tmp_no_3,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(FTsiginv,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(ST,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(m_theta,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(prev_grad,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(grad,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(prev_step,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(step,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(prev_minus_prec_grad,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ndomains = almo_scf_env%ndomains ALLOCATE(domain_r_down(ndomains)) - CALL init_submatrices(domain_r_down,error) + CALL init_submatrices(domain_r_down) ! create matrices to store the initial state - CALL cp_dbcsr_init(matrix_t_0,error=error) - CALL cp_dbcsr_init(matrix_sigma_inv_0,error=error) - CALL cp_dbcsr_init(matrix_sigma_0,error=error) - CALL cp_dbcsr_init(matrix_p_0,error=error) + CALL cp_dbcsr_init(matrix_t_0) + CALL cp_dbcsr_init(matrix_sigma_inv_0) + CALL cp_dbcsr_init(matrix_sigma_0) + CALL cp_dbcsr_init(matrix_p_0) CALL cp_dbcsr_create(matrix_t_0,& template=matrix_t_out(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(matrix_sigma_inv_0,& template=almo_scf_env%matrix_sigma_inv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(matrix_sigma_0,& template=almo_scf_env%matrix_sigma_inv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(matrix_p_0,& - template=almo_scf_env%matrix_ks(ispin),& - error=error) - CALL cp_dbcsr_copy(matrix_t_0,matrix_t_in(ispin),& - error=error) + template=almo_scf_env%matrix_ks(ispin)) + CALL cp_dbcsr_copy(matrix_t_0,matrix_t_in(ispin)) - CALL cp_dbcsr_set(step,0.0_dp,error=error) + CALL cp_dbcsr_set(step,0.0_dp) md_in_theta_space=.FALSE. ! turn on later after several minimization steps IF (do_md) THEN - CALL cp_dbcsr_init(velocity,error=error) + CALL cp_dbcsr_init(velocity) CALL cp_dbcsr_create(velocity,& - template=matrix_t_out(ispin),error=error) - CALL cp_dbcsr_copy(velocity,quench_t(ispin),error=error) - CALL cp_dbcsr_set(velocity,0.0_dp,error=error) - CALL cp_dbcsr_copy(prev_step,quench_t(ispin),error=error) - CALL cp_dbcsr_set(prev_step,0.0_dp,error=error) + template=matrix_t_out(ispin)) + CALL cp_dbcsr_copy(velocity,quench_t(ispin)) + CALL cp_dbcsr_set(velocity,0.0_dp) + CALL cp_dbcsr_copy(prev_step,quench_t(ispin)) + CALL cp_dbcsr_set(prev_step,0.0_dp) time_step=optimizer%lin_search_step_size_guess ENDIF ! create initial guess from the initial orbitals IF (assume_t0_q0x) THEN - CALL cp_dbcsr_set(m_theta,0.0_dp,error=error) + CALL cp_dbcsr_set(m_theta,0.0_dp) ELSE IF (optimize_theta) THEN ! check that all MO coefficients of the guess are less ! than the maximum allowed amplitude CALL cp_dbcsr_norm(matrix_t_0,& - dbcsr_norm_maxabsnorm, norm_scalar=grad_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=grad_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Maximum norm of the initial guess: ", grad_norm ! WRITE(unit_nr,*) "Maximum allowed amplitude: ", almo_scf_env%envelope_amplitude !ENDIF IF (grad_norm.gt.almo_scf_env%envelope_amplitude) THEN - CPErrorMessage(cp_failure_level,routineP,"Max norm of the initial guess is too large",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Max norm of the initial guess is too large") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! use artanh of block-diagonal ALMOs as an initial guess for independent variables - CALL cp_dbcsr_copy(m_theta,matrix_t_0,error=error) + CALL cp_dbcsr_copy(m_theta,matrix_t_0) CALL cp_dbcsr_function_of_elements(m_theta,& !func=dbcsr_func_asin,& func=dbcsr_func_artanh,& a0=0.0_dp,& - a1=1.0_dp/almo_scf_env%envelope_amplitude,& - error=error) - CALL cp_dbcsr_scale(m_theta,almo_scf_env%envelope_amplitude,& - error=error) + a1=1.0_dp/almo_scf_env%envelope_amplitude) + CALL cp_dbcsr_scale(m_theta,almo_scf_env%envelope_amplitude) ELSE ! simply copy MO coefficients to m_theta - CALL cp_dbcsr_copy(m_theta,matrix_t_0,error=error) + CALL cp_dbcsr_copy(m_theta,matrix_t_0) CALL cp_dbcsr_norm(m_theta,& - dbcsr_norm_maxabsnorm, norm_scalar=grad_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=grad_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Maximum norm of the initial guess: ", grad_norm !ENDIF @@ -1053,8 +1021,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& subm_s_inv=almo_scf_env%domain_s_inv(:,ispin),& dpattern=quench_t(ispin),& map=almo_scf_env%domain_map(ispin),& - node_of_domain=almo_scf_env%cpu_of_domain,& - error=error) + node_of_domain=almo_scf_env%cpu_of_domain) ENDIF ! start the outer SCF loop @@ -1086,19 +1053,19 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! switch to MD after several minimization steps IF (iteration.eq.almo_scf_env%integer01.AND.do_md) THEN - CALL cp_dbcsr_set(velocity,0.0_dp,error=error) - CALL cp_dbcsr_set(prev_step,0.0_dp,error=error) + CALL cp_dbcsr_set(velocity,0.0_dp) + CALL cp_dbcsr_set(prev_step,0.0_dp) md_in_theta_space=.TRUE. first_md_iteration=.TRUE. ENDIF ! compute the MO coefficients from theta IF (assume_t0_q0x.AND.just_started) THEN - CALL cp_dbcsr_set(matrix_t_out(ispin),0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_t_out(ispin),0.0_dp) ENDIF IF (optimize_theta) THEN CALL cp_dbcsr_norm(m_theta,& - dbcsr_norm_maxabsnorm, norm_scalar=t_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=t_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "VAR1: |T|: ", t_norm ! !WRITE(unit_nr,*) "VAR1: SIN(|T|/A), COS(|T|/A), A*SIN(|T|/A): ",& @@ -1112,23 +1079,22 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& !ENDIF ENDIF IF (optimize_theta) THEN - CALL cp_dbcsr_copy(m_tmp_no_1,m_theta,error=error) + CALL cp_dbcsr_copy(m_tmp_no_1,m_theta) CALL cp_dbcsr_function_of_elements(m_tmp_no_1,& !func=dbcsr_func_sin,& func=dbcsr_func_tanh,& a0=0.0_dp,& - a1=1.0_dp/almo_scf_env%envelope_amplitude,& - error=error) + a1=1.0_dp/almo_scf_env%envelope_amplitude) CALL cp_dbcsr_scale(m_tmp_no_1,& - almo_scf_env%envelope_amplitude,error=error) + almo_scf_env%envelope_amplitude) ELSE - CALL cp_dbcsr_copy(m_tmp_no_1,m_theta,error=error) + CALL cp_dbcsr_copy(m_tmp_no_1,m_theta) ENDIF CALL cp_dbcsr_hadamard_product(m_tmp_no_1,& quench_t(ispin),& - matrix_t_out(ispin),error=error) + matrix_t_out(ispin)) CALL cp_dbcsr_norm(matrix_t_out(ispin),& - dbcsr_norm_maxabsnorm, norm_scalar=t_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=t_norm) !IF (optimize_theta) THEN ! IF (unit_nr>0) THEN @@ -1147,17 +1113,15 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& STsiginv_0,& matrix_t_out(ispin),& 0.0_dp,m_tmp_oo_1,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",-1.0_dp,& matrix_t_0,& m_tmp_oo_1,& 1.0_dp,matrix_t_out(ispin),& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) ELSE IF (my_special_case.eq.xalmo_case_block_diag) THEN ! cannot use projector with block-daigonal ALMOs - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ELSE ! no special case CALL apply_domain_operators(& @@ -1171,13 +1135,12 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& my_action=1,& filter_eps=almo_scf_env%eps_filter,& !matrix_trimmer=,& - use_trimmer=.FALSE.,& - error=error) + use_trimmer=.FALSE.) CALL cp_dbcsr_copy(matrix_t_out(ispin),& - m_tmp_no_1,error=error) + m_tmp_no_1) ENDIF ! special case CALL cp_dbcsr_norm(matrix_t_out(ispin),& - dbcsr_norm_maxabsnorm, norm_scalar=t_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=t_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "VAR1: |Q.X|: ", t_norm !ENDIF @@ -1185,10 +1148,9 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& IF (assume_t0_q0x) THEN CALL cp_dbcsr_add(matrix_t_out(ispin),& - matrix_t_0,1.0_dp,1.0_dp,& - error=error) + matrix_t_0,1.0_dp,1.0_dp) CALL cp_dbcsr_norm(matrix_t_out(ispin),& - dbcsr_norm_maxabsnorm, norm_scalar=t_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=t_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "VAR1: |T0+Q.X|: ", t_norm !ENDIF @@ -1203,12 +1165,10 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! eps_filter=almo_scf_env%eps_filter,& ! order_lanczos=almo_scf_env%order_lanczos,& ! eps_lanczos=almo_scf_env%eps_lanczos,& - ! max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - ! error=error) + ! max_iter_lanczos=almo_scf_env%max_iter_lanczos) CALL cp_dbcsr_filter(matrix_t_out(ispin),& - eps=almo_scf_env%eps_filter,& - error=error) + eps=almo_scf_env%eps_filter) ! compute the density matrix CALL almo_scf_t_to_p(& @@ -1219,37 +1179,35 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& s=almo_scf_env%matrix_s(1),& sigma=almo_scf_env%matrix_sigma(ispin),& sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& - use_guess=use_guess,& - error=error) + use_guess=use_guess) CALL cp_dbcsr_scale(almo_scf_env%matrix_p(ispin),& - spin_factor,error=error) + spin_factor) !! RZK-warning to debug lets see eigenvalues of the ALMO overlap !CALL cp_dbcsr_copy(almo_scf_env%matrix_sigma_blk(ispin),& ! almo_scf_env%matrix_sigma(ispin),& - ! keep_sparsity=.TRUE.,& - ! error=error) - !CALL cp_dbcsr_init(u_sigma,error=error) + ! keep_sparsity=.TRUE.) + !CALL cp_dbcsr_init(u_sigma) !CALL cp_dbcsr_create(u_sigma,template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry,error=error) + ! matrix_type=dbcsr_type_no_symmetry) !CALL cp_dbcsr_get_info(almo_scf_env%matrix_sigma_blk(ispin), nfullrows_total=occ1 ) !ALLOCATE(evals(occ1)) !CALL cp_dbcsr_syevd(almo_scf_env%matrix_sigma_blk(ispin),u_sigma,evals,& - ! almo_scf_env%para_env,almo_scf_env%blacs_env,error=error) + ! almo_scf_env%para_env,almo_scf_env%blacs_env) !WRITE(*,*) 'SIGMA_BLCK: ', evals !DEALLOCATE(evals) !CALL cp_dbcsr_create(u_sigma,template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry,error=error) + ! matrix_type=dbcsr_type_no_symmetry) !CALL cp_dbcsr_get_info(almo_scf_env%matrix_sigma(ispin), nfullrows_total=occ1 ) !ALLOCATE(evals(occ1)) - !CALL cp_dbcsr_get_diag(almo_scf_env%matrix_sigma(ispin),evals,error=error) + !CALL cp_dbcsr_get_diag(almo_scf_env%matrix_sigma(ispin),evals) !WRITE(*,*) 'TRACE: ', SUM(evals) !CALL cp_dbcsr_syevd(almo_scf_env%matrix_sigma(ispin),u_sigma,evals,& - ! almo_scf_env%para_env,almo_scf_env%blacs_env,error=error) + ! almo_scf_env%para_env,almo_scf_env%blacs_env) !WRITE(*,*) 'SIGMA_FULL: ', evals !WRITE(*,*) 'SUMEI: ', SUM(evals) !DEALLOCATE(evals) - !CALL cp_dbcsr_release(u_sigma,error=error) + !CALL cp_dbcsr_release(u_sigma) ! update the KS matrix and energy if necessary IF ( .NOT.(perturbation_only.AND.(.NOT.just_started)) ) THEN @@ -1258,25 +1216,22 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "....updating KS matrix...." !ENDIF - CALL almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new,error) - CALL get_qs_env(qs_env, matrix_ks=matrix_ks, error=error) + CALL almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new) + CALL get_qs_env(qs_env, matrix_ks=matrix_ks) CALL matrix_qs_to_almo(matrix_ks(ispin)%matrix,& almo_scf_env%matrix_ks(ispin),& - almo_scf_env,.FALSE.,error=error) + almo_scf_env,.FALSE.) CALL cp_dbcsr_filter(almo_scf_env%matrix_ks(ispin),& - almo_scf_env%eps_filter,error=error) + almo_scf_env%eps_filter) ENDIF ! save the initial state IF (just_started) THEN - CALL cp_dbcsr_copy(matrix_p_0,almo_scf_env%matrix_p(ispin),& - error=error) + CALL cp_dbcsr_copy(matrix_p_0,almo_scf_env%matrix_p(ispin)) CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& - matrix_sigma_0,& - error=error) + matrix_sigma_0) CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma_inv(ispin),& - matrix_sigma_inv_0,& - error=error) + matrix_sigma_inv_0) ENDIF IF (my_special_case.eq.xalmo_case_normal.AND.prec_type.eq.4) THEN @@ -1290,8 +1245,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& dpattern=quench_t(ispin),& map=almo_scf_env%domain_map(ispin),& node_of_domain=almo_scf_env%cpu_of_domain,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) !CALL construct_domain_r_down(& ! matrix_t=matrix_t_out(ispin),& ! matrix_sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& @@ -1300,8 +1254,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! dpattern=quench_t(ispin),& ! map=almo_scf_env%domain_map(ispin),& ! node_of_domain=almo_scf_env%cpu_of_domain,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) ENDIF ! assume_t0_q0x ENDIF ! debug condition @@ -1311,17 +1264,14 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& almo_scf_env%matrix_ks(ispin),& matrix_t_out(ispin),& 0.0_dp,m_tmp_no_1,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& m_tmp_no_1,& almo_scf_env%matrix_sigma_inv(ispin),& 0.0_dp,FTsiginv,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_trace(matrix_t_out(ispin),& - FTsiginv,energy_new,"T","N",& - error=error) + FTsiginv,energy_new,"T","N") energy_new=energy_new*spin_factor ENDIF @@ -1329,7 +1279,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! do it only if the previous grad was computed ! for .NOT.line_search IF (line_search_iteration.eq.0.AND.iteration.ne.0) & - CALL cp_dbcsr_copy(prev_grad,grad,error=error) + CALL cp_dbcsr_copy(prev_grad,grad) ! compute the energy gradient if necessary skip_grad = ( iteration.gt.0 .AND. & @@ -1348,49 +1298,41 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& almo_scf_env%matrix_ks(ispin),& matrix_t_out(ispin),& 0.0_dp,m_tmp_no_1,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& m_tmp_no_1,& almo_scf_env%matrix_sigma_inv(ispin),& 0.0_dp,FTsiginv,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) !CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! m_tmp_no_1,& ! almo_scf_env%matrix_sigma_inv(ispin),& ! 0.0_dp,m_tmp_no_2,& - ! retain_sparsity=.TRUE.,& - ! error=error) + ! retain_sparsity=.TRUE.) ENDIF - CALL cp_dbcsr_copy(m_tmp_no_2,quench_t(ispin),& - error=error) + CALL cp_dbcsr_copy(m_tmp_no_2,quench_t(ispin)) CALL cp_dbcsr_copy(m_tmp_no_2,& - FTsiginv,keep_sparsity=.TRUE.,error=error) + FTsiginv,keep_sparsity=.TRUE.) CALL cp_dbcsr_multiply("T","N",1.0_dp,& matrix_t_out(ispin),& FTsiginv,& 0.0_dp,m_tmp_oo_1,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) !CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! m_tmp_oo_1,& ! almo_scf_env%matrix_sigma_inv(ispin),& ! 0.0_dp,m_tmp_oo_2,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%matrix_sigma_inv(ispin),& m_tmp_oo_1,& 0.0_dp,siginvTFTsiginv,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%matrix_s(1),& matrix_t_out(ispin),& 0.0_dp,ST,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) ! save S*T_0*siginv_0 IF (assume_t0_q0x .AND. just_started & .AND. special_case.eq.xalmo_case_fully_deloc) THEN @@ -1398,34 +1340,30 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ST,& almo_scf_env%matrix_sigma_inv(ispin),& 0.0_dp,STsiginv_0,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) ENDIF CALL cp_dbcsr_multiply("N","N",-1.0_dp,& ST,& siginvTFTsiginv,& 1.0_dp,m_tmp_no_2,& - retain_sparsity=.TRUE.,& - error=error) + retain_sparsity=.TRUE.) CALL cp_dbcsr_scale(m_tmp_no_2,& - 2.0_dp*spin_factor,& - error=error) + 2.0_dp*spin_factor) CALL cp_dbcsr_filter(m_tmp_no_2,& - eps=almo_scf_env%eps_filter,& - error=error) + eps=almo_scf_env%eps_filter) IF (perturbation_only.AND.just_started) THEN ! save the first gradient ! it is equal to F_vo and necessary to compute ! the correction to the energy - CALL cp_dbcsr_copy(fvo_0,m_tmp_no_2,error=error) + CALL cp_dbcsr_copy(fvo_0,m_tmp_no_2) CALL cp_dbcsr_scale(fvo_0,& - 0.5_dp,error=error) + 0.5_dp) ENDIF ! a short print-out CALL cp_dbcsr_norm(m_tmp_no_2,& - dbcsr_norm_maxabsnorm, norm_scalar=t_norm, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=t_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Maximum norm of dE/dT: ", t_norm !ENDIF @@ -1433,22 +1371,20 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! project out the occupied space from the gradient IF (assume_t0_q0x) THEN IF (my_special_case.eq.xalmo_case_fully_deloc) THEN - CALL cp_dbcsr_copy(grad,m_tmp_no_2,error=error) + CALL cp_dbcsr_copy(grad,m_tmp_no_2) CALL cp_dbcsr_multiply("T","N",1.0_dp,& matrix_t_0,& grad,& 0.0_dp,m_tmp_oo_1,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",-1.0_dp,& STsiginv_0,& m_tmp_oo_1,& 1.0_dp,grad,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) ELSE IF (my_special_case.eq.xalmo_case_block_diag) THEN ! should not be here - cannot project the zero-order space from itself - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ELSE ! no special case: normal xALMOs CALL apply_domain_operators(& @@ -1462,52 +1398,44 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& my_action=1,& filter_eps=almo_scf_env%eps_filter,& !matrix_trimmer=,& - use_trimmer=.FALSE.,& - error=error) + use_trimmer=.FALSE.) ENDIF ! my_special_case - CALL cp_dbcsr_copy(m_tmp_no_2,grad,error=error) + CALL cp_dbcsr_copy(m_tmp_no_2,grad) ENDIF ! transform d_E/d_T to d_E/d_theta IF (optimize_theta) THEN - CALL cp_dbcsr_copy(m_tmp_no_1,m_theta,error=error) + CALL cp_dbcsr_copy(m_tmp_no_1,m_theta) CALL cp_dbcsr_function_of_elements(m_tmp_no_1,& !func=dbcsr_func_cos,& func=dbcsr_func_dtanh,& a0=0.0_dp,& - a1=1.0_dp/almo_scf_env%envelope_amplitude,& - error=error) + a1=1.0_dp/almo_scf_env%envelope_amplitude) CALL cp_dbcsr_scale(m_tmp_no_1,& - almo_scf_env%envelope_amplitude,& - error=error) - CALL cp_dbcsr_set(m_tmp_no_3,0.0_dp,error=error) + almo_scf_env%envelope_amplitude) + CALL cp_dbcsr_set(m_tmp_no_3,0.0_dp) CALL cp_dbcsr_filter(m_tmp_no_3,& - eps=almo_scf_env%eps_filter,& - error=error) + eps=almo_scf_env%eps_filter) CALL cp_dbcsr_hadamard_product(m_tmp_no_2,& m_tmp_no_1,& m_tmp_no_3,& - b_assume_value=1.0_dp,& - error=error) + b_assume_value=1.0_dp) CALL cp_dbcsr_hadamard_product(m_tmp_no_3,& quench_t(ispin),& - grad,& - error=error) + grad) ELSE ! simply copy CALL cp_dbcsr_hadamard_product(m_tmp_no_2,& quench_t(ispin),& - grad,& - error=error) + grad) ENDIF - CALL cp_dbcsr_filter(grad,eps=almo_scf_env%eps_filter,& - error=error) + CALL cp_dbcsr_filter(grad,eps=almo_scf_env%eps_filter) ENDIF ! skip_grad ! check convergence and other exit criteria grad_norm_frob=cp_dbcsr_frobenius_norm(grad) CALL cp_dbcsr_norm(grad, dbcsr_norm_maxabsnorm,& - norm_scalar=grad_norm, error=error) + norm_scalar=grad_norm) converged=(grad_norm.lt.optimizer%eps_error) IF (converged.OR.(iteration.ge.max_iter)) THEN prepare_to_exit=.TRUE. @@ -1519,26 +1447,26 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& IF (md_in_theta_space) THEN IF (.NOT.first_md_iteration) THEN - CALL cp_dbcsr_copy(prev_step,step,error=error) + CALL cp_dbcsr_copy(prev_step,step) ENDIF - CALL cp_dbcsr_copy(step,grad,error=error) - CALL cp_dbcsr_scale(step,-1.0_dp,error=error) + CALL cp_dbcsr_copy(step,grad) + CALL cp_dbcsr_scale(step,-1.0_dp) ! update velocities v(i) = v(i-1) + 0.5*dT*(a(i-1) + a(i)) IF (.NOT.first_md_iteration) THEN CALL cp_dbcsr_add(velocity,& - step,1.0_dp,0.5_dp*time_step,error=error) + step,1.0_dp,0.5_dp*time_step) CALL cp_dbcsr_add(velocity,& - prev_step,1.0_dp,0.5_dp*time_step,error=error) + prev_step,1.0_dp,0.5_dp*time_step) ENDIF kin_energy=cp_dbcsr_frobenius_norm(velocity) kin_energy=0.5_dp*kin_energy*kin_energy ! update positions theta(i) = theta(i-1) + dT*v(i-1) + 0.5*dT*dT*a(i-1) CALL cp_dbcsr_add(m_theta,& - velocity,1.0_dp,time_step,error=error) + velocity,1.0_dp,time_step) CALL cp_dbcsr_add(m_theta,& - step,1.0_dp,0.5_dp*time_step*time_step,error=error) + step,1.0_dp,0.5_dp*time_step*time_step) iter_type="MD" @@ -1565,19 +1493,17 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& IF (fixed_line_search_niter.eq.0) THEN CALL cp_dbcsr_trace(grad,step,line_search_error,& - "T","N",error=error) + "T","N") ! normalize the result !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Angle between step/grad: ", line_search_error !ENDIF - CALL cp_dbcsr_trace(grad,grad,denom,"T","N",& - error=error) + CALL cp_dbcsr_trace(grad,grad,denom,"T","N") !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Frobenius norm of grad: ", SQRT(denom) !ENDIF line_search_error=line_search_error/SQRT(denom) - CALL cp_dbcsr_trace(step,step,denom,"T","N",& - error=error) + CALL cp_dbcsr_trace(step,step,denom,"T","N") !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Frobenius norm of step: ", SQRT(denom) !ENDIF @@ -1644,19 +1570,17 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! almo_scf_env%matrix_s(1),& ! matrix_t_out(ispin),& ! 0.0_dp,m_tmp_no_1,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& ST,& almo_scf_env%matrix_sigma_inv(ispin),& 0.0_dp,m_tmp_no_3,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_create(m_tmp_nn_1,& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_s(1),& - m_tmp_nn_1,error=error) + m_tmp_nn_1) IF (my_special_case.eq.xalmo_case_fully_deloc) THEN ! use S instead of S-SRS ELSE @@ -1664,8 +1588,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ST,& m_tmp_no_3,& 1.0_dp,m_tmp_nn_1,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) ENDIF ! Second (1-R)F(1-R) @@ -1673,50 +1596,44 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! almo_scf_env%matrix_ks(ispin),& ! matrix_t_out(ispin),& ! 0.0_dp,m_tmp_no_1,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) ! re-create matrix because desymmetrize is buggy - ! it will create multiple copies of blocks CALL cp_dbcsr_create(prec_vv,& template=almo_scf_env%matrix_ks(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_ks(ispin),& - prec_vv,error=error) + prec_vv) CALL cp_dbcsr_multiply("N","T",-1.0_dp,& FTsiginv,& ST,& 1.0_dp,prec_vv,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","T",-1.0_dp,& ST,& FTsiginv,& 1.0_dp,prec_vv,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) !CALL cp_dbcsr_multiply("T","N",1.0_dp,& ! matrix_t_out(ispin),& ! m_tmp_no_1,& ! 0.0_dp,m_tmp_oo_1,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& ST,& siginvTFTsiginv,& 0.0_dp,m_tmp_no_3,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","T",1.0_dp,& m_tmp_no_3,& ST,& 1.0_dp,prec_vv,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_add(prec_vv,m_tmp_nn_1,& 1.0_dp-prec_sf_mixing_s,& - prec_sf_mixing_s,error=error) - CALL cp_dbcsr_scale(prec_vv,2.0_dp*spin_factor,error=error) - CALL cp_dbcsr_copy(m_tmp_nn_1,prec_vv,error=error) + prec_sf_mixing_s) + CALL cp_dbcsr_scale(prec_vv,2.0_dp*spin_factor) + CALL cp_dbcsr_copy(m_tmp_nn_1,prec_vv) ! invert using various algorithms IF (my_special_case.eq.xalmo_case_block_diag) THEN ! non-overlapping diagonal blocks @@ -1729,26 +1646,23 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! node_of_domain=almo_scf_env%cpu_of_domain,& ! preconditioner=almo_scf_env%domain_preconditioner(:,ispin),& ! use_trimmer=.FALSE.,& - ! my_action=precond_domain_projector,& - ! error=error) + ! my_action=precond_domain_projector) CALL pseudo_invert_diagonal_blk(matrix_in=m_tmp_nn_1,& matrix_out=prec_vv,& - nocc=almo_scf_env%nocc_of_domain(:,ispin),& - error=error) + nocc=almo_scf_env%nocc_of_domain(:,ispin)) ELSE IF (my_special_case.eq.xalmo_case_fully_deloc) THEN ! the entire system is a block ! invert using cholesky (works with S matrix, will not work with S-SRS matrix) CALL cp_dbcsr_cholesky_decompose(prec_vv,& para_env=almo_scf_env%para_env,& - blacs_env=almo_scf_env%blacs_env,error=error) + blacs_env=almo_scf_env%blacs_env) CALL cp_dbcsr_cholesky_invert(prec_vv,& para_env=almo_scf_env%para_env,& blacs_env=almo_scf_env%blacs_env,& - upper_to_full=.TRUE.,error=error) + upper_to_full=.TRUE.) CALL cp_dbcsr_filter(prec_vv,& - eps=almo_scf_env%eps_filter,& - error=error) + eps=almo_scf_env%eps_filter) ELSE !!! use a sophisticated domain preconditioner IF (assume_t0_q0x) THEN @@ -1770,80 +1684,75 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& node_of_domain=almo_scf_env%cpu_of_domain,& preconditioner=almo_scf_env%domain_preconditioner(:,ispin),& use_trimmer=.FALSE.,& - my_action=precond_domain_projector,& - error=error) + my_action=precond_domain_projector) ENDIF ! prec type ENDIF ! invert using cholesky (works with S matrix, will not work with S-SRS matrix) !!!CALL cp_dbcsr_cholesky_decompose(prec_vv,& !!! para_env=almo_scf_env%para_env,& - !!! blacs_env=almo_scf_env%blacs_env,error=error) + !!! blacs_env=almo_scf_env%blacs_env) !!!CALL cp_dbcsr_cholesky_invert(prec_vv,& !!! para_env=almo_scf_env%para_env,& !!! blacs_env=almo_scf_env%blacs_env,& - !!! upper_to_full=.TRUE.,error=error) + !!! upper_to_full=.TRUE.) !!!CALL cp_dbcsr_filter(prec_vv,& - !!! eps=almo_scf_env%eps_filter,& - !!! error=error) + !!! eps=almo_scf_env%eps_filter) + !!! ! re-create the matrix because desymmetrize is buggy - ! it will create multiple copies of blocks !!!DESYM!CALL cp_dbcsr_create(prec_vv,& !!!DESYM! template=almo_scf_env%matrix_s(1),& - !!!DESYM! matrix_type=dbcsr_type_no_symmetry,error=error) + !!!DESYM! matrix_type=dbcsr_type_no_symmetry) !!!DESYM!CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_s(1),& - !!!DESYM! prec_vv,error=error) + !!!DESYM! prec_vv) !CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! almo_scf_env%matrix_s(1),& ! matrix_t_out(ispin),& ! 0.0_dp,m_tmp_no_1,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) !CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! m_tmp_no_1,& ! almo_scf_env%matrix_sigma_inv(ispin),& ! 0.0_dp,m_tmp_no_3,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) !CALL cp_dbcsr_multiply("N","T",-1.0_dp,& ! m_tmp_no_3,& ! m_tmp_no_1,& ! 1.0_dp,prec_vv,& - ! filter_eps=almo_scf_env%eps_filter,& - ! error=error) + ! filter_eps=almo_scf_env%eps_filter) !CALL cp_dbcsr_add_on_diag(prec_vv,& - ! prec_sf_mixing_s,error=error) + ! prec_sf_mixing_s) !CALL cp_dbcsr_create(prec_oo,& ! template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry,error=error) + ! matrix_type=dbcsr_type_no_symmetry) !CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry,error=error) + ! matrix_type=dbcsr_type_no_symmetry) !CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma(ispin),& - ! prec_oo,error=error) + ! prec_oo) !CALL cp_dbcsr_filter(prec_oo,& - ! eps=almo_scf_env%eps_filter,& - ! error=error) + ! eps=almo_scf_env%eps_filter) !! invert using cholesky !CALL cp_dbcsr_create(prec_oo_inv,& ! template=prec_oo,& - ! matrix_type=dbcsr_type_no_symmetry,error=error) + ! matrix_type=dbcsr_type_no_symmetry) !CALL cp_dbcsr_desymmetrize(prec_oo,& - ! prec_oo_inv,error=error) + ! prec_oo_inv) !CALL cp_dbcsr_cholesky_decompose(prec_oo_inv,& ! para_env=almo_scf_env%para_env,& - ! blacs_env=almo_scf_env%blacs_env,error=error) + ! blacs_env=almo_scf_env%blacs_env) !CALL cp_dbcsr_cholesky_invert(prec_oo_inv,& ! para_env=almo_scf_env%para_env,& ! blacs_env=almo_scf_env%blacs_env,& - ! upper_to_full=.TRUE.,error=error) + ! upper_to_full=.TRUE.) ENDIF ! save the previous step - CALL cp_dbcsr_copy(prev_step,step,error=error) + CALL cp_dbcsr_copy(prev_step,step) ! compute the new step (apply preconditioner if available) IF (use_preconditioner) THEN @@ -1857,8 +1766,8 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! expensive Newton-Raphson step (the Hessian is still approximate) ! RZK-warning THIS PREC HAS NOT BEEN IMPLEMENTED FOR THETA IF (ncores.gt.1) THEN - CPErrorMessage(cp_failure_level,routineP,"serial code only",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"serial code only") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL newton_grad_to_step(& matrix_grad=m_tmp_no_2,& @@ -1872,8 +1781,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& !matrix_sigma_inv=matrix_sigma_inv_0,& quench_t=quench_t(ispin),& spin_factor=spin_factor,& - eps_filter=almo_scf_env%eps_filter,& - error=error) + eps_filter=almo_scf_env%eps_filter) CASE (3) @@ -1883,7 +1791,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& CALL cp_dbcsr_get_info(m_tmp_nn_1, nfullrows_total=dim0 ) ALLOCATE(evals(dim0)) CALL cp_dbcsr_syevd(m_tmp_nn_1,prec_vv,evals,& - almo_scf_env%para_env,almo_scf_env%blacs_env,error=error) + almo_scf_env%para_env,almo_scf_env%blacs_env) ! invert eigenvalues and use eigenvectors to compute the Hessian inverse ! take special care of zero eigenvalues zero_neg_eiv=0 @@ -1899,53 +1807,49 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& IF (unit_nr>0) THEN WRITE(*,*) 'ZERO OR NEGATIVE EIGENVALUES: ', zero_neg_eiv ENDIF - CALL cp_dbcsr_init(inv_eiv,error=error) + CALL cp_dbcsr_init(inv_eiv) CALL cp_dbcsr_create(inv_eiv,& template=m_tmp_nn_1,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_add_on_diag(inv_eiv,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(inv_eiv,evals,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_add_on_diag(inv_eiv,1.0_dp) + CALL cp_dbcsr_set_diag(inv_eiv,evals) CALL cp_dbcsr_multiply("N","N",1.0_dp,& prec_vv,& inv_eiv,& 0.0_dp,m_tmp_nn_1,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","T",1.0_dp,& m_tmp_nn_1,& prec_vv,& 0.0_dp,inv_eiv,& - filter_eps=almo_scf_env%eps_filter,& - error=error) - CALL cp_dbcsr_copy(prec_vv,inv_eiv,error=error) - CALL cp_dbcsr_release(inv_eiv,error=error) + filter_eps=almo_scf_env%eps_filter) + CALL cp_dbcsr_copy(prec_vv,inv_eiv) + CALL cp_dbcsr_release(inv_eiv) DEALLOCATE(evals) !!CALL cp_dbcsr_copy(step,& - !! quench_t(ispin),& - !! error=error) + !! quench_t(ispin)) + !! !!CALL cp_dbcsr_multiply("N","N",1.0_dp,& !! m_tmp_no_2,& !! !grad,& - this choice is worse !! prec_oo,& !! 0.0_dp,step,& !! !retain_sparsity=.TRUE.,& - !! filter_eps=almo_scf_env%eps_filter,& - !! error=error) + !! filter_eps=almo_scf_env%eps_filter) + !! CALL cp_dbcsr_copy(m_tmp_no_1,& - quench_t(ispin),& - error=error) + quench_t(ispin)) !!CALL cp_dbcsr_hadamard_product(& !! quench_t(ispin),& !! step,& - !! m_tmp_no_1,& - !! error=error) + !! m_tmp_no_1) + !! CALL cp_dbcsr_multiply("N","N",-1.0_dp,& prec_vv,& m_tmp_no_2,& 0.0_dp,m_tmp_no_1,& - retain_sparsity=.TRUE.,& - error=error) + retain_sparsity=.TRUE.) CASE (4) @@ -1956,15 +1860,14 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& prec_vv,& grad,& 0.0_dp,step,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) ELSE !!! RZK-warning Currently for non-theta only IF (optimize_theta) THEN - CPErrorMessage(cp_failure_level,routineP,"theta is NYI",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"theta is NYI") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL apply_domain_operators(& @@ -1976,41 +1879,36 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& map=almo_scf_env%domain_map(ispin),& node_of_domain=almo_scf_env%cpu_of_domain,& my_action=0,& - filter_eps=almo_scf_env%eps_filter,& + filter_eps=almo_scf_env%eps_filter) !matrix_trimmer=,& !use_trimmer=.FALSE.,& - error=error) - CALL cp_dbcsr_scale(step,-1.0_dp,error=error) + CALL cp_dbcsr_scale(step,-1.0_dp) CALL cp_dbcsr_copy(m_tmp_no_3,& - quench_t(ispin),& - error=error) + quench_t(ispin)) CALL cp_dbcsr_function_of_elements(m_tmp_no_3,& func=dbcsr_func_inverse,& a0=0.0_dp,& - a1=1.0_dp,& - error=error) - CALL cp_dbcsr_copy(m_tmp_no_2,step,error=error) + a1=1.0_dp) + CALL cp_dbcsr_copy(m_tmp_no_2,step) CALL cp_dbcsr_hadamard_product(& m_tmp_no_2,& m_tmp_no_3,& - step,& - error=error) - CALL cp_dbcsr_copy(m_tmp_no_3,quench_t(ispin),error=error) + step) + CALL cp_dbcsr_copy(m_tmp_no_3,quench_t(ispin)) !CALL cp_dbcsr_create(m_tmp_oo_1,& ! template=almo_scf_env%matrix_sigma_blk(ispin),& - ! matrix_type=dbcsr_type_no_symmetry,error=error) - !CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma_blk(ispin),m_tmp_oo_1,error=error) + ! matrix_type=dbcsr_type_no_symmetry) + !CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma_blk(ispin),m_tmp_oo_1) !CALL get_overlap(bra=matrix_t_out(ispin),& ! ket=step,& ! overlap=m_tmp_oo_1,& ! metric=almo_scf_env%matrix_s(1),& ! retain_overlap_sparsity=.TRUE.,& - ! eps_filter=almo_scf_env%eps_filter,& - ! error=error) + ! eps_filter=almo_scf_env%eps_filter) !CALL cp_dbcsr_norm(m_tmp_oo_1,& - ! dbcsr_norm_maxabsnorm, norm_scalar=t_norm, error=error) + ! dbcsr_norm_maxabsnorm, norm_scalar=t_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Step block-orthogonality error: ", t_norm !ENDIF @@ -2022,8 +1920,8 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ELSE !!!! NO PRECONDITIONER - CALL cp_dbcsr_copy(step,grad,error=error) - CALL cp_dbcsr_scale(step,-1.0_dp,error=error) + CALL cp_dbcsr_copy(step,grad) + CALL cp_dbcsr_scale(step,-1.0_dp) ENDIF @@ -2037,55 +1935,55 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& SELECT CASE (optimizer%conjugator) CASE (cg_hestenes_stiefel) - CALL cp_dbcsr_copy(m_tmp_no_1,grad,error=error) + CALL cp_dbcsr_copy(m_tmp_no_1,grad) CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,& - 1.0_dp,-1.0_dp,error=error) + 1.0_dp,-1.0_dp) CALL cp_dbcsr_trace(m_tmp_no_1,step,numer,& - "T","N",error=error) + "T","N") CALL cp_dbcsr_trace(m_tmp_no_1,prev_step,denom,& - "T","N",error=error) + "T","N") beta=-1.0_dp*numer/denom CASE (cg_fletcher_reeves) - CALL cp_dbcsr_trace(grad,step,numer,"T","N",error=error) - CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,numer,"T","N") + CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N") beta=numer/denom CASE (cg_polak_ribiere) - CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N",error=error) - CALL cp_dbcsr_copy(m_tmp_no_1,grad,error=error) - CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(m_tmp_no_1,step,numer,"T","N",error=error) + CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N") + CALL cp_dbcsr_copy(m_tmp_no_1,grad) + CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(m_tmp_no_1,step,numer,"T","N") beta=numer/denom CASE (cg_fletcher) - CALL cp_dbcsr_trace(grad,step,numer,"T","N",error=error) - CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,numer,"T","N") + CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") beta=numer/denom CASE (cg_liu_storey) - CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) - CALL cp_dbcsr_copy(m_tmp_no_1,grad,error=error) - CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(m_tmp_no_1,step,numer,"T","N",error=error) + CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") + CALL cp_dbcsr_copy(m_tmp_no_1,grad) + CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(m_tmp_no_1,step,numer,"T","N") beta=numer/denom CASE (cg_dai_yuan) - CALL cp_dbcsr_trace(grad,step,numer,"T","N",error=error) - CALL cp_dbcsr_copy(m_tmp_no_1,grad,error=error) - CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(m_tmp_no_1,prev_step,denom,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,numer,"T","N") + CALL cp_dbcsr_copy(m_tmp_no_1,grad) + CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(m_tmp_no_1,prev_step,denom,"T","N") beta=-1.0_dp*numer/denom CASE (cg_hager_zhang) - CALL cp_dbcsr_copy(m_tmp_no_1,grad,error=error) - CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(m_tmp_no_1,prev_step,denom,"T","N",error=error) - CALL cp_dbcsr_trace(m_tmp_no_1,prev_minus_prec_grad,numer,"T","N",error=error) + CALL cp_dbcsr_copy(m_tmp_no_1,grad) + CALL cp_dbcsr_add(m_tmp_no_1,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(m_tmp_no_1,prev_step,denom,"T","N") + CALL cp_dbcsr_trace(m_tmp_no_1,prev_minus_prec_grad,numer,"T","N") kappa=-2.0_dp*numer/denom - CALL cp_dbcsr_trace(m_tmp_no_1,step,numer,"T","N",error=error) + CALL cp_dbcsr_trace(m_tmp_no_1,step,numer,"T","N") tau=-1.0_dp*numer/denom - CALL cp_dbcsr_trace(prev_step,grad,numer,"T","N",error=error) + CALL cp_dbcsr_trace(prev_step,grad,numer,"T","N") beta=tau-kappa*numer/denom CASE (cg_zero) beta=0.0_dp CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"illegal conjugator",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal conjugator") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (beta.lt.0.0_dp) THEN @@ -2108,21 +2006,21 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ENDIF ! save the preconditioned gradient (useful for beta) - CALL cp_dbcsr_copy(prev_minus_prec_grad,step,error=error) + CALL cp_dbcsr_copy(prev_minus_prec_grad,step) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "....final beta....", beta !ENDIF ! conjugate the step direction - CALL cp_dbcsr_add(step,prev_step,1.0_dp,beta,error=error) + CALL cp_dbcsr_add(step,prev_step,1.0_dp,beta) ENDIF ! update the step direction ! estimate the step size IF (.NOT.line_search) THEN e0=energy_new - CALL cp_dbcsr_trace(grad,step,g0,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,g0,"T","N") ! we just changed the direction and ! we have only E and grad from the current step ! it is not enouhg to compute step_size - just guess it @@ -2140,7 +2038,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ELSE IF (fixed_line_search_niter.eq.0) THEN e1=energy_new - CALL cp_dbcsr_trace(grad,step,g1,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,g1,"T","N") ! we have accumulated some points along this direction ! use only the most recent g0 (quadratic approximation) appr_sec_der=(g1-g0)/step_size @@ -2171,7 +2069,7 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ENDIF ! update theta - CALL cp_dbcsr_add(m_theta,step,1.0_dp,step_size,error=error) + CALL cp_dbcsr_add(m_theta,step,1.0_dp,step_size) ENDIF ! not.prepare_to_exit @@ -2225,43 +2123,40 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! RZK-warning: if decide to uncomment make sure that Theta->T ! procedure is consistent with the procedure in the loop !IF (optimize_theta) THEN - ! CALL cp_dbcsr_copy(m_tmp_no_1,m_theta,error=error) + ! CALL cp_dbcsr_copy(m_tmp_no_1,m_theta) ! CALL cp_dbcsr_function_of_elements(m_tmp_no_1,& ! func=dbcsr_func_tanh,& ! a0=0.0_dp,& - ! a1=1.0_dp/almo_scf_env%envelope_amplitude,& - ! error=error) + ! a1=1.0_dp/almo_scf_env%envelope_amplitude) ! CALL cp_dbcsr_hadamard_product(m_tmp_no_1,& ! quench_t(ispin),& - ! matrix_t_out(ispin),error=error) + ! matrix_t_out(ispin)) ! CALL cp_dbcsr_scale(matrix_t_out(ispin),& - ! almo_scf_env%envelope_amplitude,error=error) + ! almo_scf_env%envelope_amplitude) !ELSE - ! CALL cp_dbcsr_copy(m_tmp_no_1,m_theta,error=error) + ! CALL cp_dbcsr_copy(m_tmp_no_1,m_theta) ! CALL cp_dbcsr_hadamard_product(m_tmp_no_1,& ! quench_t(ispin),& - ! matrix_t_out(ispin),error=error) + ! matrix_t_out(ispin)) !ENDIF !IF (perturbation_only) THEN ! CALL cp_dbcsr_add(matrix_t_out(ispin),& - ! matrix_t_0,1.0_dp,1.0_dp,& - ! error=error) + ! matrix_t_0,1.0_dp,1.0_dp) !ENDIF !CALL cp_dbcsr_filter(matrix_t_out(ispin),& - ! eps=almo_scf_env%eps_filter,& - ! error=error) + ! eps=almo_scf_env%eps_filter) !CALL cp_dbcsr_norm(matrix_t_out(ispin),& - ! dbcsr_norm_maxabsnorm, norm_scalar=grad_norm, error=error) + ! dbcsr_norm_maxabsnorm, norm_scalar=grad_norm) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Maximum norm of the ALMOs: ", grad_norm !ENDIF !!!!! experiment: bump final amplitudes and get T !!!!IF (.NOT.optimize_theta.AND.perturbation_only) THEN - !!!! CALL cp_dbcsr_copy(m_tmp_no_1,m_theta,error=error) + !!!! CALL cp_dbcsr_copy(m_tmp_no_1,m_theta) !!!! CALL cp_dbcsr_hadamard_product(m_tmp_no_1,& !!!! quench_t_saved,& - !!!! matrix_t_out(ispin),error=error) + !!!! matrix_t_out(ispin)) !!!! IF (use_projector) THEN !!!! CALL almo_scf_domain_operations(& !!!! matrix_in=matrix_t_out(ispin),& @@ -2270,31 +2165,29 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& !!!! my_action=2,& !!!! matrix_s=almo_scf_env%matrix_s(1),& !!!! matrix_sigma_inv=matrix_sigma_inv_0,& - !!!! matrix_t=matrix_t_0,& - !!!! error=error) + !!!! matrix_t=matrix_t_0) + !!!! !!!! CALL cp_dbcsr_copy(matrix_t_out(ispin),& - !!!! m_tmp_no_1,error=error) + !!!! m_tmp_no_1) !!!! ENDIF !!!! IF (perturbation_only) THEN !!!! CALL cp_dbcsr_add(matrix_t_out(ispin),& - !!!! matrix_t_0,1.0_dp,1.0_dp,& - !!!! error=error) + !!!! matrix_t_0,1.0_dp,1.0_dp) + !!!! !!!! ENDIF !!!!ENDIF !!!! !!!!IF (.NOT.optimize_theta) THEN - !!!! CALL cp_dbcsr_copy(quench_t(ispin),quench_t_saved,error=error) + !!!! CALL cp_dbcsr_copy(quench_t(ispin),quench_t_saved) !!!!ENDIF IF (perturbation_only) THEN CALL cp_dbcsr_add(matrix_t_0,matrix_t_out(ispin),& - -1.0_dp,1.0_dp,& - error=error) + -1.0_dp,1.0_dp) CALL cp_dbcsr_trace(matrix_t_0,& - fvo_0,energy_new,"T","N",& - error=error) + fvo_0,energy_new,"T","N") ! print out the energy lowering IF (unit_nr>0) THEN WRITE(unit_nr,*) @@ -2312,33 +2205,30 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& ! WRITE(unit_nr,*) "_ENERGY-F: ", almo_scf_env%almo_scf_energy+energy_new !ENDIF CALL almo_scf_update_ks_energy(qs_env,& - almo_scf_env%almo_scf_energy+energy_new,& - error) + almo_scf_env%almo_scf_energy+energy_new) ! similar method to evaluate the energy correction !CALL cp_dbcsr_add(matrix_p_0,& - ! almo_scf_env%matrix_p(ispin),-1.0_dp,1.0_dp,& - ! error=error) + ! almo_scf_env%matrix_p(ispin),-1.0_dp,1.0_dp) !CALL cp_dbcsr_trace(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& ! matrix_p_0,& - ! energy_new,error=error) + ! energy_new) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "alt-ENERGY-D: ", energy_new !ENDIF !CALL almo_scf_update_ks_energy(qs_env,& - ! almo_scf_env%almo_scf_energy+energy_new,& - ! error) + ! almo_scf_env%almo_scf_energy+energy_new) IF (almo_scf_env%almo_eda.gt.0) THEN ! print out the results of decomposition analysis CALL cp_dbcsr_hadamard_product(matrix_t_0,& - fvo_0,m_tmp_no_1,error=error) + fvo_0,m_tmp_no_1) IF (unit_nr>0) THEN WRITE(unit_nr,*) WRITE(unit_nr,'(T2,A)') "DECOMPOSITION OF THE DELOCALIZATION ENERGY" ENDIF - CALL cp_dbcsr_filter(m_tmp_no_1,almo_scf_env%eps_filter,error=error) + CALL cp_dbcsr_filter(m_tmp_no_1,almo_scf_env%eps_filter) mynode=dbcsr_mp_mynode(dbcsr_distribution_mp(& cp_dbcsr_distribution(m_tmp_no_1))) @@ -2346,57 +2236,56 @@ SUBROUTINE almo_scf_xalmo_pcg(qs_env,almo_scf_env,optimizer,quench_t,& mylogfile='EDA.'//TRIM(ADJUSTL(mynodestr)) CALL open_file(file_name=mylogfile,file_status="REPLACE",unit_number=iunit) - CALL cp_dbcsr_print_block_sum(m_tmp_no_1,iunit,error=error) + CALL cp_dbcsr_print_block_sum(m_tmp_no_1,iunit) CALL close_file(iunit) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) ! WRITE(unit_nr,'(T2,A)') "CHARGE DECOMPOSITION" !ENDIF - !CALL cp_dbcsr_print_block_sum(cta_matrix(ispin),error=error) + !CALL cp_dbcsr_print_block_sum(cta_matrix(ispin)) ENDIF ! do ALMO EDA ELSE CALL almo_scf_update_ks_energy(qs_env,& - energy_new,& - error) + energy_new) ENDIF ! if perturbation only ENDIF ! if converged IF (md_in_theta_space) THEN - CALL cp_dbcsr_release(velocity,error=error) + CALL cp_dbcsr_release(velocity) ENDIF - CALL cp_dbcsr_release(m_theta,error=error) - CALL cp_dbcsr_release(prec_vv,error=error) - CALL cp_dbcsr_release(prec_oo,error=error) - CALL cp_dbcsr_release(prec_oo_inv,error=error) - CALL cp_dbcsr_release(m_tmp_no_1,error=error) - CALL cp_dbcsr_release(fvo_0,error=error) - CALL cp_dbcsr_release(STsiginv_0,error=error) - CALL cp_dbcsr_release(m_tmp_no_2,error=error) - CALL cp_dbcsr_release(m_tmp_no_3,error=error) - CALL cp_dbcsr_release(m_tmp_oo_1,error=error) - CALL cp_dbcsr_release(ST,error=error) - CALL cp_dbcsr_release(FTsiginv,error=error) - CALL cp_dbcsr_release(siginvTFTsiginv,error=error) - CALL cp_dbcsr_release(m_tmp_nn_1,error=error) - CALL cp_dbcsr_release(prev_grad,error=error) - CALL cp_dbcsr_release(prev_step,error=error) - CALL cp_dbcsr_release(grad,error=error) - CALL cp_dbcsr_release(step,error=error) - CALL cp_dbcsr_release(prev_minus_prec_grad,error=error) - CALL cp_dbcsr_release(matrix_p_0, error=error) - CALL cp_dbcsr_release(matrix_t_0, error=error) - CALL cp_dbcsr_release(matrix_sigma_0,error=error) - CALL cp_dbcsr_release(matrix_sigma_inv_0,error=error) + CALL cp_dbcsr_release(m_theta) + CALL cp_dbcsr_release(prec_vv) + CALL cp_dbcsr_release(prec_oo) + CALL cp_dbcsr_release(prec_oo_inv) + CALL cp_dbcsr_release(m_tmp_no_1) + CALL cp_dbcsr_release(fvo_0) + CALL cp_dbcsr_release(STsiginv_0) + CALL cp_dbcsr_release(m_tmp_no_2) + CALL cp_dbcsr_release(m_tmp_no_3) + CALL cp_dbcsr_release(m_tmp_oo_1) + CALL cp_dbcsr_release(ST) + CALL cp_dbcsr_release(FTsiginv) + CALL cp_dbcsr_release(siginvTFTsiginv) + CALL cp_dbcsr_release(m_tmp_nn_1) + CALL cp_dbcsr_release(prev_grad) + CALL cp_dbcsr_release(prev_step) + CALL cp_dbcsr_release(grad) + CALL cp_dbcsr_release(step) + CALL cp_dbcsr_release(prev_minus_prec_grad) + CALL cp_dbcsr_release(matrix_p_0) + CALL cp_dbcsr_release(matrix_t_0) + CALL cp_dbcsr_release(matrix_sigma_0) + CALL cp_dbcsr_release(matrix_sigma_inv_0) IF (.NOT.converged) THEN IF (unit_nr>0) WRITE(unit_nr,'(T2,A)') "Optimization not converged! " - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(domain_r_down) @@ -2411,15 +2300,13 @@ END SUBROUTINE almo_scf_xalmo_pcg !> \brief Split the matrix of virtual orbitals into two: !> retained orbs and discarded !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.09 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE split_v_blk(almo_scf_env,error) + SUBROUTINE split_v_blk(almo_scf_env) TYPE(almo_scf_env_type) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'split_v_blk', & routineP = moduleN//':'//routineN @@ -2435,9 +2322,9 @@ SUBROUTINE split_v_blk(almo_scf_env,error) DO ispin=1,almo_scf_env%nspins CALL cp_dbcsr_work_create(almo_scf_env%matrix_v_blk(ispin),& - work_mutable=.TRUE.,error=error) + work_mutable=.TRUE.) CALL cp_dbcsr_work_create(almo_scf_env%matrix_v_disc_blk(ispin),& - work_mutable=.TRUE.,error=error) + work_mutable=.TRUE.) CALL cp_dbcsr_iterator_start(iter,almo_scf_env%matrix_v_full_blk(ispin)) @@ -2447,33 +2334,33 @@ SUBROUTINE split_v_blk(almo_scf_env,error) row_size=iblock_row_size,col_size=iblock_col_size) IF (iblock_row.ne.iblock_col) THEN - CPErrorMessage(cp_failure_level,routineP,"off-diagonal block found",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"off-diagonal block found") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF retained_v=almo_scf_env%nvirt_of_domain(iblock_col,ispin) discarded_v=almo_scf_env%nvirt_disc_of_domain(iblock_col,ispin) - CPPrecondition(retained_v.gt.0,cp_failure_level,routineP,error,failure) - CPPrecondition(discarded_v.gt.0,cp_failure_level,routineP,error,failure) + CPPrecondition(retained_v.gt.0,cp_failure_level,routineP,failure) + CPPrecondition(discarded_v.gt.0,cp_failure_level,routineP,failure) NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(almo_scf_env%matrix_v_disc_blk(ispin),& iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) - CPPrecondition((retained_v+discarded_v.eq.iblock_col_size),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) + CPPrecondition((retained_v+discarded_v.eq.iblock_col_size),cp_failure_level,routineP,failure) p_new_block(:,:) = data_p(:,(retained_v+1):iblock_col_size) NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(almo_scf_env%matrix_v_blk(ispin),& iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = data_p(:,1:retained_v) ENDDO ! iterator CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin),error=error) - CALL cp_dbcsr_finalize(almo_scf_env%matrix_v_disc_blk(ispin),error=error) + CALL cp_dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin)) + CALL cp_dbcsr_finalize(almo_scf_env%matrix_v_disc_blk(ispin)) ENDDO ! ispin @@ -2484,15 +2371,13 @@ END SUBROUTINE split_v_blk ! ***************************************************************************** !> \brief various methods for calculating the Harris-Foulkes correction !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE harris_foulkes_correction(almo_scf_env,error) + SUBROUTINE harris_foulkes_correction(almo_scf_env) TYPE(almo_scf_env_type) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'harris_foulkes_correction', & routineP = moduleN//':'//routineN @@ -2545,7 +2430,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -2575,14 +2460,14 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! rescale density matrix by spin factor ! so the orbitals and density are consistent with each other IF (almo_scf_env%nspins == 1) THEN - CALL cp_dbcsr_scale(almo_scf_env%matrix_p(1),1.0_dp/spin_factor,error=error) + CALL cp_dbcsr_scale(almo_scf_env%matrix_p(1),1.0_dp/spin_factor) ENDIF ! transform matrix_t not matrix_t_blk (we might need ALMOs later) DO ispin=1,nspin CALL cp_dbcsr_copy(almo_scf_env%matrix_t(ispin),& - almo_scf_env%matrix_t_blk(ispin),error=error) + almo_scf_env%matrix_t_blk(ispin)) ! obtain orthogonalization matrices for ALMOs ! RZK-warning - remove this sqrt(sigma) and inv(sqrt(sigma)) @@ -2592,14 +2477,14 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) IF (unit_nr>0) THEN WRITE(unit_nr,*) "sqrt and inv(sqrt) of MO overlap matrix" ENDIF - CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt(ispin),error=error) - CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt_inv(ispin),error=error) + CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt(ispin)) + CALL cp_dbcsr_init(almo_scf_env%matrix_sigma_sqrt_inv(ispin)) CALL cp_dbcsr_create(almo_scf_env%matrix_sigma_sqrt(ispin),& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(almo_scf_env%matrix_sigma_sqrt_inv(ispin),& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL matrix_sqrt_Newton_Schulz(almo_scf_env%matrix_sigma_sqrt(ispin),& almo_scf_env%matrix_sigma_sqrt_inv(ispin),& @@ -2607,35 +2492,32 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) threshold=almo_scf_env%eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_sigma_sqrt_inv(ispin),& almo_scf_env%matrix_sigma(ispin),& - 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& almo_scf_env%matrix_sigma_sqrt_inv(ispin),& - 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp2) - CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp2) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(sqrt(SIG))*SIG*inv(sqrt(SIG))-I)",frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) ENDIF ENDDO @@ -2656,7 +2538,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) outer_opt_k_iteration=0 grad_norm=0.0_dp grad_norm_frob=0.0_dp - CALL cp_dbcsr_set(almo_scf_env%matrix_x(ispin),0.0_dp,error=error) + CALL cp_dbcsr_set(almo_scf_env%matrix_x(ispin),0.0_dp) IF (almo_scf_env%deloc_truncate_virt.eq.virt_full) outer_opt_k_max_iter=0 DO @@ -2670,42 +2552,38 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) psi_projector_orthogonal=.FALSE.,& proj_in_template=almo_scf_env%matrix_ov(ispin),& eps_filter=almo_scf_env%eps_filter,& - sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin),& + sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin)) !sig_inv_template=almo_scf_env%matrix_sigma_inv(ispin),& - error=error) ! save initial retained virtuals - CALL cp_dbcsr_init(vr_fixed,error=error) + CALL cp_dbcsr_init(vr_fixed) CALL cp_dbcsr_create(vr_fixed,& - template=almo_scf_env%matrix_v(ispin),error=error) - CALL cp_dbcsr_copy(vr_fixed,almo_scf_env%matrix_v(ispin),& - error=error) + template=almo_scf_env%matrix_v(ispin)) + CALL cp_dbcsr_copy(vr_fixed,almo_scf_env%matrix_v(ispin)) ! init matrices common for optimized and non-optimized virts - CALL cp_dbcsr_init(sigma_vv_sqrt,error=error) - CALL cp_dbcsr_init(sigma_vv_sqrt_inv,error=error) + CALL cp_dbcsr_init(sigma_vv_sqrt) + CALL cp_dbcsr_init(sigma_vv_sqrt_inv) CALL cp_dbcsr_create(sigma_vv_sqrt,& template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(sigma_vv_sqrt_inv,& template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(sigma_vv_sqrt_inv_guess,error=error) - CALL cp_dbcsr_init(sigma_vv_sqrt_guess,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(sigma_vv_sqrt_inv_guess) + CALL cp_dbcsr_init(sigma_vv_sqrt_guess) CALL cp_dbcsr_create(sigma_vv_sqrt_inv_guess,& template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(sigma_vv_sqrt_guess,& template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_set(sigma_vv_sqrt_guess,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(sigma_vv_sqrt_guess,1.0_dp,error=error) - CALL cp_dbcsr_filter(sigma_vv_sqrt_guess,almo_scf_env%eps_filter,& - error=error) - CALL cp_dbcsr_set(sigma_vv_sqrt_inv_guess,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(sigma_vv_sqrt_inv_guess,1.0_dp,error=error) - CALL cp_dbcsr_filter(sigma_vv_sqrt_inv_guess,almo_scf_env%eps_filter,& - error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_set(sigma_vv_sqrt_guess,0.0_dp) + CALL cp_dbcsr_add_on_diag(sigma_vv_sqrt_guess,1.0_dp) + CALL cp_dbcsr_filter(sigma_vv_sqrt_guess,almo_scf_env%eps_filter) + CALL cp_dbcsr_set(sigma_vv_sqrt_inv_guess,0.0_dp) + CALL cp_dbcsr_add_on_diag(sigma_vv_sqrt_inv_guess,1.0_dp) + CALL cp_dbcsr_filter(sigma_vv_sqrt_inv_guess,almo_scf_env%eps_filter) ! do things required to optimize virtuals IF (almo_scf_env%deloc_truncate_virt.ne.virt_full) THEN @@ -2721,10 +2599,9 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! psi_projector_orthogonal=.FALSE.,& ! proj_in_template=almo_scf_env%matrix_k_tr(ispin),& ! eps_filter=almo_scf_env%eps_filter,& - ! sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin),& - ! error=error) + ! sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin)) !CALL cp_dbcsr_copy(almo_scf_env%matrix_v_disc_blk(ispin),& - ! almo_scf_env%matrix_v_disc(ispin),error=error) + ! almo_scf_env%matrix_v_disc(ispin)) ! construct discarded virtuals (1-R)|ALMO_vd> CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin),& @@ -2735,164 +2612,159 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) psi_projector_orthogonal=.FALSE.,& proj_in_template=almo_scf_env%matrix_ov_disc(ispin),& eps_filter=almo_scf_env%eps_filter,& - sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin),& + sig_inv_projector=almo_scf_env%matrix_sigma_inv(ispin)) !sig_inv_template=almo_scf_env%matrix_sigma_inv(ispin),& - error=error) ! save initial discarded - CALL cp_dbcsr_init(vd_fixed,error=error) + CALL cp_dbcsr_init(vd_fixed) CALL cp_dbcsr_create(vd_fixed,& - template=almo_scf_env%matrix_v_disc(ispin),error=error) - CALL cp_dbcsr_copy(vd_fixed,almo_scf_env%matrix_v_disc(ispin),& - error=error) + template=almo_scf_env%matrix_v_disc(ispin)) + CALL cp_dbcsr_copy(vd_fixed,almo_scf_env%matrix_v_disc(ispin)) !! create the down metric in the retained k-subspace - CALL cp_dbcsr_init(k_vr_index_down,error=error) + CALL cp_dbcsr_init(k_vr_index_down) CALL cp_dbcsr_create(k_vr_index_down,& template=almo_scf_env%matrix_sigma_vv_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) !CALL cp_dbcsr_copy(k_vr_index_down,& - ! almo_scf_env%matrix_sigma_vv_blk(ispin),error=error) + ! almo_scf_env%matrix_sigma_vv_blk(ispin)) !CALL get_overlap(bra=almo_scf_env%matrix_v_blk(ispin),& ! ket=almo_scf_env%matrix_v_blk(ispin),& ! overlap=k_vr_index_down,& ! metric=almo_scf_env%matrix_s_blk(1),& ! retain_overlap_sparsity=.FALSE.,& - ! eps_filter=almo_scf_env%eps_filter,& - ! error=error) + ! eps_filter=almo_scf_env%eps_filter) !! create the up metric in the discarded k-subspace - CALL cp_dbcsr_init(k_vd_index_down,error=error) + CALL cp_dbcsr_init(k_vd_index_down) CALL cp_dbcsr_create(k_vd_index_down,& template=almo_scf_env%matrix_vv_disc_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) - !CALL cp_dbcsr_init(k_vd_index_up,error=error) + matrix_type=dbcsr_type_no_symmetry) + !CALL cp_dbcsr_init(k_vd_index_up) !CALL cp_dbcsr_create(k_vd_index_up,& ! template=almo_scf_env%matrix_vv_disc_blk(ispin),& - ! matrix_type=dbcsr_type_no_symmetry,error=error) + ! matrix_type=dbcsr_type_no_symmetry) !CALL cp_dbcsr_copy(k_vd_index_down,& - ! almo_scf_env%matrix_vv_disc_blk(ispin),error=error) + ! almo_scf_env%matrix_vv_disc_blk(ispin)) !CALL get_overlap(bra=almo_scf_env%matrix_v_disc_blk(ispin),& ! ket=almo_scf_env%matrix_v_disc_blk(ispin),& ! overlap=k_vd_index_down,& ! metric=almo_scf_env%matrix_s_blk(1),& ! retain_overlap_sparsity=.FALSE.,& - ! eps_filter=almo_scf_env%eps_filter,& - ! error=error) + ! eps_filter=almo_scf_env%eps_filter) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Inverting blocked overlap matrix of discarded virtuals" !ENDIF !CALL invert_Hotelling(k_vd_index_up,& ! k_vd_index_down,& - ! almo_scf_env%eps_filter,& - ! error) + ! almo_scf_env%eps_filter) !IF (safe_mode) THEN - ! CALL cp_dbcsr_init(matrix_tmp1,error=error) + ! CALL cp_dbcsr_init(matrix_tmp1) ! CALL cp_dbcsr_create(matrix_tmp1,template=k_vd_index_down,& - ! matrix_type=dbcsr_type_no_symmetry,error=error) + ! matrix_type=dbcsr_type_no_symmetry) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,k_vd_index_up,& ! k_vd_index_down,& ! 0.0_dp, matrix_tmp1,& - ! filter_eps=almo_scf_env%eps_filter,error=error) + ! filter_eps=almo_scf_env%eps_filter) ! frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp1) - ! CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp,error=error) + ! CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) ! frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) ! IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Error for (inv(SIG)*SIG-I)",& ! frob_matrix/frob_matrix_base ! ENDIF - ! CALL cp_dbcsr_release(matrix_tmp1,error=error) + ! CALL cp_dbcsr_release(matrix_tmp1) !ENDIF ! init matrices necessary for optimization of truncated virts ! init blocked gradient before setting K to zero ! otherwise the block structure might be lost - CALL cp_dbcsr_init(grad,error=error) + CALL cp_dbcsr_init(grad) CALL cp_dbcsr_create(grad,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_copy(grad,almo_scf_env%matrix_k_blk(ispin),error=error) + template=almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_copy(grad,almo_scf_env%matrix_k_blk(ispin)) ! init MD in the k-space md_in_k_space=almo_scf_env%logical01 IF (md_in_k_space) THEN - CALL cp_dbcsr_init(velocity,error=error) + CALL cp_dbcsr_init(velocity) CALL cp_dbcsr_create(velocity,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_copy(velocity,almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_set(velocity,0.0_dp,error=error) + template=almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_copy(velocity,almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_set(velocity,0.0_dp) time_step=almo_scf_env%opt_k_trial_step_size ENDIF - CALL cp_dbcsr_init(prev_step,error=error) + CALL cp_dbcsr_init(prev_step) CALL cp_dbcsr_create(prev_step,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) + template=almo_scf_env%matrix_k_blk(ispin)) - CALL cp_dbcsr_init(prev_minus_prec_grad,error=error) + CALL cp_dbcsr_init(prev_minus_prec_grad) CALL cp_dbcsr_create(prev_minus_prec_grad,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) + template=almo_scf_env%matrix_k_blk(ispin)) ! initialize diagonal blocks of the preconditioner to 1.0_dp - CALL cp_dbcsr_init(prec,error=error) + CALL cp_dbcsr_init(prec) CALL cp_dbcsr_create(prec,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_copy(prec,almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_set(prec,1.0_dp,error=error) + template=almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_copy(prec,almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_set(prec,1.0_dp) ! generate initial K (extrapolate if previous values are available) - CALL cp_dbcsr_set(almo_scf_env%matrix_k_blk(ispin),0.0_dp,error=error) + CALL cp_dbcsr_set(almo_scf_env%matrix_k_blk(ispin),0.0_dp) ! matrix_k_central stores current k because matrix_k_blk is updated ! during linear search - CALL cp_dbcsr_init(matrix_k_central,error=error) + CALL cp_dbcsr_init(matrix_k_central) CALL cp_dbcsr_create(matrix_k_central,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) + template=almo_scf_env%matrix_k_blk(ispin)) CALL cp_dbcsr_copy(matrix_k_central,& - almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_init(tmp_k_blk,error=error) + almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_init(tmp_k_blk) CALL cp_dbcsr_create(tmp_k_blk,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_init(step,error=error) + template=almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_init(step) CALL cp_dbcsr_create(step,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_set(step,0.0_dp,error=error) - CALL cp_dbcsr_init(t_curr,error=error) + template=almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_set(step,0.0_dp) + CALL cp_dbcsr_init(t_curr) CALL cp_dbcsr_create(t_curr,& - template=almo_scf_env%matrix_t(ispin),error=error) - CALL cp_dbcsr_init(sigma_oo_curr,error=error) - CALL cp_dbcsr_init(sigma_oo_curr_inv,error=error) + template=almo_scf_env%matrix_t(ispin)) + CALL cp_dbcsr_init(sigma_oo_curr) + CALL cp_dbcsr_init(sigma_oo_curr_inv) CALL cp_dbcsr_create(sigma_oo_curr,& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(sigma_oo_curr_inv,& template=almo_scf_env%matrix_sigma(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(tmp1_n_vr,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(tmp1_n_vr) CALL cp_dbcsr_create(tmp1_n_vr,& - template=almo_scf_env%matrix_v(ispin),error=error) - CALL cp_dbcsr_init(tmp3_vd_vr,error=error) + template=almo_scf_env%matrix_v(ispin)) + CALL cp_dbcsr_init(tmp3_vd_vr) CALL cp_dbcsr_create(tmp3_vd_vr,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_init(tmp2_n_o,error=error) + template=almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_init(tmp2_n_o) CALL cp_dbcsr_create(tmp2_n_o,& - template=almo_scf_env%matrix_t(ispin),error=error) - CALL cp_dbcsr_init(tmp4_o_vr,error=error) + template=almo_scf_env%matrix_t(ispin)) + CALL cp_dbcsr_init(tmp4_o_vr) CALL cp_dbcsr_create(tmp4_o_vr,& - template=almo_scf_env%matrix_ov(ispin),error=error) - CALL cp_dbcsr_init(prev_grad,error=error) + template=almo_scf_env%matrix_ov(ispin)) + CALL cp_dbcsr_init(prev_grad) CALL cp_dbcsr_create(prev_grad,& - template=almo_scf_env%matrix_k_blk(ispin),error=error) - CALL cp_dbcsr_set(prev_grad,0.0_dp,error=error) + template=almo_scf_env%matrix_k_blk(ispin)) + CALL cp_dbcsr_set(prev_grad,0.0_dp) - !CALL cp_dbcsr_init(sigma_oo_guess,error=error) + !CALL cp_dbcsr_init(sigma_oo_guess) !CALL cp_dbcsr_create(sigma_oo_guess,& ! template=almo_scf_env%matrix_sigma(ispin),& - ! matrix_type=dbcsr_type_no_symmetry,error=error) - !CALL cp_dbcsr_set(sigma_oo_guess,0.0_dp,error=error) - !CALL cp_dbcsr_add_on_diag(sigma_oo_guess,1.0_dp,error=error) - !CALL cp_dbcsr_filter(sigma_oo_guess,almo_scf_env%eps_filter,error=error) - !CALL cp_dbcsr_print(sigma_oo_guess,error=error) + ! matrix_type=dbcsr_type_no_symmetry) + !CALL cp_dbcsr_set(sigma_oo_guess,0.0_dp) + !CALL cp_dbcsr_add_on_diag(sigma_oo_guess,1.0_dp) + !CALL cp_dbcsr_filter(sigma_oo_guess,almo_scf_env%eps_filter) + !CALL cp_dbcsr_print(sigma_oo_guess) ENDIF ! done constructing discarded virtuals @@ -2925,10 +2797,9 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) CALL cp_dbcsr_multiply("N","N",1.0_dp,vd_fixed,& almo_scf_env%matrix_k_blk(ispin),& 0.0_dp,almo_scf_env%matrix_v(ispin),& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_add(almo_scf_env%matrix_v(ispin),vr_fixed,& - +1.0_dp,+1.0_dp,error=error) + +1.0_dp,+1.0_dp) ENDIF ! decompose the overlap matrix of the current retained orbitals @@ -2940,8 +2811,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) overlap=almo_scf_env%matrix_sigma_vv(ispin),& metric=almo_scf_env%matrix_s(1),& retain_overlap_sparsity=.FALSE.,& - eps_filter=almo_scf_env%eps_filter,& - error=error) + eps_filter=almo_scf_env%eps_filter) ! use either cholesky or sqrt !! RZK-warning: strangely, cholesky does not work with k-optimization IF (almo_scf_env%deloc_truncate_virt.eq.virt_full) THEN @@ -2952,38 +2822,37 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! it will create multiple copies of blocks CALL cp_dbcsr_create(sigma_vv_sqrt,& template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma_vv(ispin),& - sigma_vv_sqrt,error=error) + sigma_vv_sqrt) CALL cp_dbcsr_cholesky_decompose(sigma_vv_sqrt,& para_env=almo_scf_env%para_env,& - blacs_env=almo_scf_env%blacs_env,error=error) - CALL cp_dbcsr_triu(sigma_vv_sqrt,error=error) - CALL cp_dbcsr_filter(sigma_vv_sqrt,almo_scf_env%eps_filter,error=error) + blacs_env=almo_scf_env%blacs_env) + CALL cp_dbcsr_triu(sigma_vv_sqrt) + CALL cp_dbcsr_filter(sigma_vv_sqrt,almo_scf_env%eps_filter) ! apply SOLVE to compute U^(-1) : U*U^(-1)=I CALL cp_dbcsr_get_info(sigma_vv_sqrt, nfullrows_total=n ) - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_set(matrix_tmp1,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_tmp1,1.0_dp,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_set(matrix_tmp1,0.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_tmp1,1.0_dp) CALL cp_dbcsr_cholesky_restore(matrix_tmp1,n,sigma_vv_sqrt,& sigma_vv_sqrt_inv,op="SOLVE",pos="RIGHT",& para_env=almo_scf_env%para_env,& - blacs_env=almo_scf_env%blacs_env,error=error) - CALL cp_dbcsr_filter(sigma_vv_sqrt_inv,almo_scf_env%eps_filter,error=error) - CALL cp_dbcsr_release(matrix_tmp1,error=error) + blacs_env=almo_scf_env%blacs_env) + CALL cp_dbcsr_filter(sigma_vv_sqrt_inv,almo_scf_env%eps_filter) + CALL cp_dbcsr_release(matrix_tmp1) IF (safe_mode) THEN CALL cp_dbcsr_create(matrix_tmp1, template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_sigma_vv(ispin),& - matrix_tmp1,error=error) + matrix_tmp1) CALL cp_dbcsr_multiply("T","N",1.0_dp,sigma_vv_sqrt,& sigma_vv_sqrt,& - -1.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& - error=error) + -1.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) - CALL cp_dbcsr_add_on_diag(matrix_tmp1,1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp1,1.0_dp) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for ( U^T * U - Sig )",& @@ -2991,16 +2860,15 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ENDIF CALL cp_dbcsr_multiply("N","N",1.0_dp,sigma_vv_sqrt_inv,& sigma_vv_sqrt,& - 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp1) - CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for ( inv(U) * U - I )",& frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) + CALL cp_dbcsr_release(matrix_tmp1) ENDIF ! safe_mode t2cholesky = m_walltime() IF (unit_nr>0) THEN @@ -3016,37 +2884,34 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) threshold=almo_scf_env%eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) - CALL cp_dbcsr_copy(sigma_vv_sqrt_inv_guess,sigma_vv_sqrt_inv,error=error) - CALL cp_dbcsr_copy(sigma_vv_sqrt_guess,sigma_vv_sqrt,error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) + CALL cp_dbcsr_copy(sigma_vv_sqrt_inv_guess,sigma_vv_sqrt_inv) + CALL cp_dbcsr_copy(sigma_vv_sqrt_guess,sigma_vv_sqrt) IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,template=almo_scf_env%matrix_sigma_vv(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,sigma_vv_sqrt_inv,& almo_scf_env%matrix_sigma_vv(ispin),& - 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& sigma_vv_sqrt_inv,& - 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp2) - CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp2) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",& frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) ENDIF ENDIF CALL timestop(handle1) @@ -3062,7 +2927,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) MAX(ABS(almo_scf_env%deloc_cayley_eps_convergence),& ABS(x_opt_eps_adaptive_factor*grad_norm)) ENDIF - CALL ct_step_env_init(ct_step_env,error) + CALL ct_step_env_init(ct_step_env) CALL ct_step_env_set(ct_step_env,& para_env=almo_scf_env%para_env,& blacs_env=almo_scf_env%blacs_env,& @@ -3091,16 +2956,14 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) matrix_qp_template=almo_scf_env%matrix_vo(ispin),& matrix_pq_template=almo_scf_env%matrix_ov(ispin),& matrix_v=almo_scf_env%matrix_v(ispin),& - matrix_x_guess=almo_scf_env%matrix_x(ispin),& - error=error) + matrix_x_guess=almo_scf_env%matrix_x(ispin)) ! perform calculations - CALL ct_step_execute(ct_step_env,error) + CALL ct_step_execute(ct_step_env) ! get the energy correction CALL ct_step_env_get(ct_step_env,& energy_correction=energy_correction(ispin),& - copy_matrix_x=almo_scf_env%matrix_x(ispin),& - error=error) - CALL ct_step_env_clean(ct_step_env,error) + copy_matrix_x=almo_scf_env%matrix_x(ispin)) + CALL ct_step_env_clean(ct_step_env) ! RZK-warning matrix_x is being transformed ! back and forth between orth and up_down representations energy_correction(1)=energy_correction(1)*spin_factor @@ -3114,10 +2977,9 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) almo_scf_env%matrix_v(ispin),& almo_scf_env%matrix_x(ispin),& 0.0_dp,t_curr,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_add(t_curr,almo_scf_env%matrix_t_blk(ispin),& - +1.0_dp,+1.0_dp,error=error) + +1.0_dp,+1.0_dp) ! calculate current occupied overlap !IF (unit_nr>0) THEN @@ -3128,59 +2990,56 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) overlap=sigma_oo_curr,& metric=almo_scf_env%matrix_s(1),& retain_overlap_sparsity=.FALSE.,& - eps_filter=almo_scf_env%eps_filter,& - error=error) + eps_filter=almo_scf_env%eps_filter) IF (iteration.eq.0) THEN CALL invert_Hotelling(sigma_oo_curr_inv,& sigma_oo_curr,& threshold=almo_scf_env%eps_filter,& - use_inv_as_guess=.FALSE.,& - error=error) + use_inv_as_guess=.FALSE.) ELSE CALL invert_Hotelling(sigma_oo_curr_inv,& sigma_oo_curr,& threshold=almo_scf_env%eps_filter,& - use_inv_as_guess=.TRUE.,& - error=error) - !CALL cp_dbcsr_copy(sigma_oo_guess,sigma_oo_curr_inv,error=error) + use_inv_as_guess=.TRUE.) + !CALL cp_dbcsr_copy(sigma_oo_guess,sigma_oo_curr_inv) ENDIF IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=sigma_oo_curr,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,sigma_oo_curr,& sigma_oo_curr_inv,& 0.0_dp, matrix_tmp1,& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp1) - CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) - !CALL cp_dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter,error=error) - !CALL cp_dbcsr_print(matrix_tmp1,error=error) + !CALL cp_dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) + !CALL cp_dbcsr_print(matrix_tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (SIG*inv(SIG)-I)",& frob_matrix/frob_matrix_base, frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) + CALL cp_dbcsr_release(matrix_tmp1) ENDIF IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=sigma_oo_curr,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,sigma_oo_curr_inv,& sigma_oo_curr,& 0.0_dp, matrix_tmp1,& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp1) - CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) - !CALL cp_dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter,error=error) - !CALL cp_dbcsr_print(matrix_tmp1,error=error) + !CALL cp_dbcsr_filter(matrix_tmp1,almo_scf_env%eps_filter) + !CALL cp_dbcsr_print(matrix_tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(SIG)*SIG-I)",& frob_matrix/frob_matrix_base, frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) + CALL cp_dbcsr_release(matrix_tmp1) ENDIF CALL timestop(handle3) @@ -3195,8 +3054,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) sigma_vv_sqrt_inv,& sigma_vv_sqrt_inv,& 0.0_dp,sigma_vv_sqrt,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL apply_projector(psi_in=almo_scf_env%matrix_v_disc_blk(ispin),& psi_out=almo_scf_env%matrix_v_disc(ispin),& psi_projector=almo_scf_env%matrix_v(ispin),& @@ -3205,11 +3063,10 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) psi_projector_orthogonal=.FALSE.,& proj_in_template=almo_scf_env%matrix_k_tr(ispin),& eps_filter=almo_scf_env%eps_filter,& - sig_inv_projector=sigma_vv_sqrt,& + sig_inv_projector=sigma_vv_sqrt) !sig_inv_template=almo_scf_env%matrix_sigma_vv(ispin),& - error=error) CALL cp_dbcsr_add(almo_scf_env%matrix_v_disc(ispin),& - vd_fixed,-1.0_dp,+1.0_dp,error=error) + vd_fixed,-1.0_dp,+1.0_dp) CALL timestop(handle4) CALL timeset('k_opt_grad',handle5) @@ -3218,39 +3075,35 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! grad_xx = c0 [ (Vd_curr^tr)*F*T_curr*sigma_oo_curr_inv*(X^tr)]_xx ! save previous gradient to calculate conjugation coef IF (line_search) THEN - CALL cp_dbcsr_copy(prev_grad,grad,error=error) + CALL cp_dbcsr_copy(prev_grad,grad) ENDIF CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%matrix_ks_almo_scf_converged(ispin),& t_curr,& 0.0_dp,tmp2_n_o,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","T",1.0_dp,& sigma_oo_curr_inv,& almo_scf_env%matrix_x(ispin),& 0.0_dp,tmp4_o_vr,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& tmp2_n_o,& tmp4_o_vr,& 0.0_dp,tmp1_n_vr,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("T","N",2.0_dp*spin_factor,& almo_scf_env%matrix_v_disc(ispin),& tmp1_n_vr,& 0.0_dp,grad,& - retain_sparsity=.TRUE.,& + retain_sparsity=.TRUE.) !filter_eps=almo_scf_env%eps_filter,& - error=error) ! keep tmp2_n_o for the next step ! keep tmp4_o_vr for the preconditioner ! check convergence and other exit criteria grad_norm_frob=cp_dbcsr_frobenius_norm(grad) - CALL cp_dbcsr_norm(grad, dbcsr_norm_maxabsnorm, norm_scalar=grad_norm, error=error) + CALL cp_dbcsr_norm(grad, dbcsr_norm_maxabsnorm, norm_scalar=grad_norm) converged=(grad_norm.lt.almo_scf_env%opt_k_eps_convergence) IF (converged.OR.(iteration.ge.opt_k_max_iter)) THEN prepare_to_exit=.TRUE. @@ -3267,12 +3120,10 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) t_curr,& tmp2_n_o,& 0.0_dp,sigma_oo_curr,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) delta_obj_function=fun0 CALL cp_dbcsr_trace(sigma_oo_curr_inv,& - sigma_oo_curr,obj_function,"T","N",& - error=error) + sigma_oo_curr,obj_function,"T","N") delta_obj_function=obj_function-delta_obj_function IF (line_search) THEN fun1=obj_function @@ -3312,25 +3163,24 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! k_vr_index_down,& ! tmp1_n_vr,& ! spin_factor,& - ! almo_scf_env%eps_filter,error) + ! almo_scf_env%eps_filter) CALL opt_k_create_preconditioner_blk(almo_scf_env,& almo_scf_env%matrix_v_disc(ispin),& tmp4_o_vr,& t_curr,& ispin,& - spin_factor,& - error) + spin_factor) ENDIF ! save the previous step - CALL cp_dbcsr_copy(prev_step,step,error=error) + CALL cp_dbcsr_copy(prev_step,step) ! compute the new step CALL opt_k_apply_preconditioner_blk(almo_scf_env,& - step,grad,ispin,error) - !CALL cp_dbcsr_hadamard_product(prec,grad,step,error=error) - CALL cp_dbcsr_scale(step,-1.0_dp,error=error) + step,grad,ispin) + !CALL cp_dbcsr_hadamard_product(prec,grad,step) + CALL cp_dbcsr_scale(step,-1.0_dp) ! check whether we need to reset conjugate directions reset_conjugator=.FALSE. @@ -3344,11 +3194,11 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ELSE ! check for the errors in the cg algorithm - !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N",error=error) - !CALL cp_dbcsr_trace(prev_grad,tmp_k_blk,denom,"T","N",error=error) - CALL cp_dbcsr_trace(grad,prev_minus_prec_grad,numer,"T","N",error=error) - CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N",error=error) + !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N") + !CALL cp_dbcsr_trace(prev_grad,tmp_k_blk,denom,"T","N") + CALL cp_dbcsr_trace(grad,prev_minus_prec_grad,numer,"T","N") + CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N") conjugacy_error=numer/denom IF (conjugacy_error.gt.MIN(0.5_dp,conjugacy_error_threshold)) THEN @@ -3360,8 +3210,8 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! check the gradient along the previous direction IF ((iteration.ne.0).AND.(.NOT.reset_conjugator)) THEN - CALL cp_dbcsr_trace(grad,prev_step,numer,"T","N",error=error) - CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) + CALL cp_dbcsr_trace(grad,prev_step,numer,"T","N") + CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") line_search_error=numer/denom IF (line_search_error.gt.line_search_error_threshold) THEN reset_conjugator=.TRUE. @@ -3378,83 +3228,83 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) SELECT CASE (almo_scf_env%opt_k_conjugator) CASE (cg_hestenes_stiefel) - CALL cp_dbcsr_copy(tmp_k_blk,grad,error=error) - CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N",error=error) - CALL cp_dbcsr_trace(tmp_k_blk,prev_step,denom,"T","N",error=error) + CALL cp_dbcsr_copy(tmp_k_blk,grad) + CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N") + CALL cp_dbcsr_trace(tmp_k_blk,prev_step,denom,"T","N") beta=-1.0_dp*numer/denom CASE (cg_fletcher_reeves) - !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(prev_grad,tmp_k_blk,denom,"T","N",error=error) - !CALL cp_dbcsr_hadamard_product(prec,grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N",error=error) + !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL cp_dbcsr_trace(prev_grad,tmp_k_blk,denom,"T","N") + !CALL cp_dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N") !beta=numer/denom - CALL cp_dbcsr_trace(grad,step,numer,"T","N",error=error) - CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,numer,"T","N") + CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N") beta=numer/denom CASE (cg_polak_ribiere) - !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(prev_grad,tmp_k_blk,denom,"T","N",error=error) - !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp,error=error) - !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(tmp_k_blk,grad,numer,"T","N",error=error) - CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N",error=error) - CALL cp_dbcsr_copy(tmp_k_blk,grad,error=error) - CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N",error=error) + !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL cp_dbcsr_trace(prev_grad,tmp_k_blk,denom,"T","N") + !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL cp_dbcsr_trace(tmp_k_blk,grad,numer,"T","N") + CALL cp_dbcsr_trace(prev_grad,prev_minus_prec_grad,denom,"T","N") + CALL cp_dbcsr_copy(tmp_k_blk,grad) + CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N") beta=numer/denom CASE (cg_fletcher) - !CALL cp_dbcsr_hadamard_product(prec,grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N",error=error) - !CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) + !CALL cp_dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N") + !CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") !beta=-1.0_dp*numer/denom - CALL cp_dbcsr_trace(grad,step,numer,"T","N",error=error) - CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,numer,"T","N") + CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") beta=numer/denom CASE (cg_liu_storey) - CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) - !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp,error=error) - !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(tmp_k_blk,grad,numer,"T","N",error=error) - CALL cp_dbcsr_copy(tmp_k_blk,grad,error=error) - CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N",error=error) + CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") + !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL cp_dbcsr_trace(tmp_k_blk,grad,numer,"T","N") + CALL cp_dbcsr_copy(tmp_k_blk,grad) + CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N") beta=numer/denom CASE (cg_dai_yuan) - !CALL cp_dbcsr_hadamard_product(prec,grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N",error=error) - !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp,error=error) - !CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) + !CALL cp_dbcsr_hadamard_product(prec,grad,tmp_k_blk) + !CALL cp_dbcsr_trace(grad,tmp_k_blk,numer,"T","N") + !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") !beta=numer/denom - CALL cp_dbcsr_trace(grad,step,numer,"T","N",error=error) - CALL cp_dbcsr_copy(tmp_k_blk,grad,error=error) - CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(tmp_k_blk,prev_step,denom,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,numer,"T","N") + CALL cp_dbcsr_copy(tmp_k_blk,grad) + CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(tmp_k_blk,prev_step,denom,"T","N") beta=-1.0_dp*numer/denom CASE (cg_hager_zhang) - !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp,error=error) - !CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N",error=error) - !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk,error=error) - !CALL cp_dbcsr_trace(tmp_k_blk,prev_grad,numer,"T","N",error=error) + !CALL cp_dbcsr_add(prev_grad,grad,-1.0_dp,1.0_dp) + !CALL cp_dbcsr_trace(prev_grad,prev_step,denom,"T","N") + !CALL cp_dbcsr_hadamard_product(prec,prev_grad,tmp_k_blk) + !CALL cp_dbcsr_trace(tmp_k_blk,prev_grad,numer,"T","N") !kappa=2.0_dp*numer/denom - !CALL cp_dbcsr_trace(tmp_k_blk,grad,numer,"T","N",error=error) + !CALL cp_dbcsr_trace(tmp_k_blk,grad,numer,"T","N") !tau=numer/denom - !CALL cp_dbcsr_trace(prev_step,grad,numer,"T","N",error=error) + !CALL cp_dbcsr_trace(prev_step,grad,numer,"T","N") !beta=tau-kappa*numer/denom - CALL cp_dbcsr_copy(tmp_k_blk,grad,error=error) - CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_trace(tmp_k_blk,prev_step,denom,"T","N",error=error) - CALL cp_dbcsr_trace(tmp_k_blk,prev_minus_prec_grad,numer,"T","N",error=error) + CALL cp_dbcsr_copy(tmp_k_blk,grad) + CALL cp_dbcsr_add(tmp_k_blk,prev_grad,1.0_dp,-1.0_dp) + CALL cp_dbcsr_trace(tmp_k_blk,prev_step,denom,"T","N") + CALL cp_dbcsr_trace(tmp_k_blk,prev_minus_prec_grad,numer,"T","N") kappa=-2.0_dp*numer/denom - CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N",error=error) + CALL cp_dbcsr_trace(tmp_k_blk,step,numer,"T","N") tau=-1.0_dp*numer/denom - CALL cp_dbcsr_trace(prev_step,grad,numer,"T","N",error=error) + CALL cp_dbcsr_trace(prev_step,grad,numer,"T","N") beta=tau-kappa*numer/denom CASE (cg_zero) beta=0.0_dp CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"illegal conjugator",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal conjugator") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (beta.lt.0.0_dp) THEN @@ -3482,10 +3332,10 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ENDIF ! save the preconditioned gradient - CALL cp_dbcsr_copy(prev_minus_prec_grad,step,error=error) + CALL cp_dbcsr_copy(prev_minus_prec_grad,step) ! conjugate the step direction - CALL cp_dbcsr_add(step,prev_step,1.0_dp,beta,error=error) + CALL cp_dbcsr_add(step,prev_step,1.0_dp,beta) CALL timestop(handle7) @@ -3496,10 +3346,10 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! compute the gradient with respect to the step size in the curr direction IF (line_search) THEN - CALL cp_dbcsr_trace(grad,step,gfun1,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,gfun1,"T","N") line_search_error=gfun1/gfun0 ELSE - CALL cp_dbcsr_trace(grad,step,gfun0,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,gfun0,"T","N") ENDIF ! make a step - update k @@ -3518,7 +3368,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ABS(gfun0),& " is smaller than the threshold",num_threshold ENDIF - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (ABS(gfun0).lt.num_threshold) THEN IF (unit_nr>0) THEN @@ -3526,7 +3376,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ABS(gfun0),& " is smaller than the threshold",num_threshold ENDIF - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF use_quadratic_approximation=.TRUE. @@ -3635,16 +3485,16 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! one more check on the step size IF (step_size.lt.0.0_dp) THEN - CPErrorMessage(cp_failure_level,routineP,"Negative step proposed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Negative step proposed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL cp_dbcsr_copy(almo_scf_env%matrix_k_blk(ispin),& - matrix_k_central,error=error) + matrix_k_central) CALL cp_dbcsr_add(almo_scf_env%matrix_k_blk(ispin),& - step,1.0_dp,step_size,error=error) + step,1.0_dp,step_size) CALL cp_dbcsr_copy(matrix_k_central,& - almo_scf_env%matrix_k_blk(ispin),error=error) + almo_scf_env%matrix_k_blk(ispin)) line_search=.FALSE. ELSE @@ -3654,18 +3504,18 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! update velocities v(i) = v(i-1) + 0.5*dT*(a(i-1) + a(i)) IF (iteration.ne.0) THEN CALL cp_dbcsr_add(velocity,& - step,1.0_dp,0.5_dp*time_step,error=error) + step,1.0_dp,0.5_dp*time_step) CALL cp_dbcsr_add(velocity,& - prev_step,1.0_dp,0.5_dp*time_step,error=error) + prev_step,1.0_dp,0.5_dp*time_step) ENDIF kin_energy=cp_dbcsr_frobenius_norm(velocity) kin_energy=0.5_dp*kin_energy*kin_energy ! update positions k(i) = k(i-1) + dT*v(i-1) + 0.5*dT*dT*a(i-1) CALL cp_dbcsr_add(almo_scf_env%matrix_k_blk(ispin),& - velocity,1.0_dp,time_step,error=error) + velocity,1.0_dp,time_step) CALL cp_dbcsr_add(almo_scf_env%matrix_k_blk(ispin),& - step,1.0_dp,0.5_dp*time_step*time_step,error=error) + step,1.0_dp,0.5_dp*time_step*time_step) ELSE @@ -3676,9 +3526,9 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) step_size=step_size*almo_scf_env%opt_k_trial_step_size_multiplier ENDIF CALL cp_dbcsr_copy(almo_scf_env%matrix_k_blk(ispin),& - matrix_k_central,error=error) + matrix_k_central) CALL cp_dbcsr_add(almo_scf_env%matrix_k_blk(ispin),& - step,1.0_dp,step_size,error=error) + step,1.0_dp,step_size) line_search=.TRUE. ENDIF @@ -3740,20 +3590,18 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) almo_scf_env%matrix_v_disc_blk(ispin),& almo_scf_env%matrix_k_blk(ispin),& 0.0_dp,vr_fixed,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_add(vr_fixed,almo_scf_env%matrix_v_blk(ispin),& - +1.0_dp,+1.0_dp,error=error) + +1.0_dp,+1.0_dp) ! update discarded ALMO virtuals to restart the cg iterations CALL cp_dbcsr_multiply("N","T",1.0_dp,& almo_scf_env%matrix_v_blk(ispin),& almo_scf_env%matrix_k_blk(ispin),& 0.0_dp,vd_fixed,& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_add(vd_fixed,almo_scf_env%matrix_v_disc_blk(ispin),& - -1.0_dp,+1.0_dp,error=error) + -1.0_dp,+1.0_dp) ! orthogonalize new orbitals on fragments CALL get_overlap(bra=vr_fixed,& @@ -3761,148 +3609,138 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) overlap=k_vr_index_down,& metric=almo_scf_env%matrix_s_blk(1),& retain_overlap_sparsity=.FALSE.,& - eps_filter=almo_scf_env%eps_filter,& - error=error) - CALL cp_dbcsr_init(vr_index_sqrt_inv,error=error) + eps_filter=almo_scf_env%eps_filter) + CALL cp_dbcsr_init(vr_index_sqrt_inv) CALL cp_dbcsr_create(vr_index_sqrt_inv,template=k_vr_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(vr_index_sqrt,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(vr_index_sqrt) CALL cp_dbcsr_create(vr_index_sqrt,template=k_vr_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL matrix_sqrt_Newton_Schulz(vr_index_sqrt,& vr_index_sqrt_inv,& k_vr_index_down,& threshold=almo_scf_env%eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=k_vr_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,template=k_vr_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,vr_index_sqrt_inv,& k_vr_index_down,& - 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& vr_index_sqrt_inv,& - 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp2) - CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp2) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",& frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) ENDIF CALL cp_dbcsr_multiply("N","N",1.0_dp,& vr_fixed,& vr_index_sqrt_inv,& 0.0_dp,almo_scf_env%matrix_v_blk(ispin),& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) CALL get_overlap(bra=vd_fixed,& ket=vd_fixed,& overlap=k_vd_index_down,& metric=almo_scf_env%matrix_s_blk(1),& retain_overlap_sparsity=.FALSE.,& - eps_filter=almo_scf_env%eps_filter,& - error=error) - CALL cp_dbcsr_init(vd_index_sqrt_inv,error=error) + eps_filter=almo_scf_env%eps_filter) + CALL cp_dbcsr_init(vd_index_sqrt_inv) CALL cp_dbcsr_create(vd_index_sqrt_inv,template=k_vd_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(vd_index_sqrt,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(vd_index_sqrt) CALL cp_dbcsr_create(vd_index_sqrt,template=k_vd_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL matrix_sqrt_Newton_Schulz(vd_index_sqrt,& vd_index_sqrt_inv,& k_vd_index_down,& threshold=almo_scf_env%eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=k_vd_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,template=k_vd_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,vd_index_sqrt_inv,& k_vd_index_down,& - 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& vd_index_sqrt_inv,& - 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp2) - CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp2) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",& frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) ENDIF CALL cp_dbcsr_multiply("N","N",1.0_dp,& vd_fixed,& vd_index_sqrt_inv,& 0.0_dp,almo_scf_env%matrix_v_disc_blk(ispin),& - filter_eps=almo_scf_env%eps_filter,& - error=error) + filter_eps=almo_scf_env%eps_filter) - CALL cp_dbcsr_release(vr_index_sqrt_inv,error=error) - CALL cp_dbcsr_release(vr_index_sqrt,error=error) - CALL cp_dbcsr_release(vd_index_sqrt_inv,error=error) - CALL cp_dbcsr_release(vd_index_sqrt,error=error) + CALL cp_dbcsr_release(vr_index_sqrt_inv) + CALL cp_dbcsr_release(vr_index_sqrt) + CALL cp_dbcsr_release(vd_index_sqrt_inv) + CALL cp_dbcsr_release(vd_index_sqrt) CALL timestop(handle8) ENDIF ! ne.virt_full ! RZK-warning released outside the outer loop - CALL cp_dbcsr_release(sigma_vv_sqrt,error=error) - CALL cp_dbcsr_release(sigma_vv_sqrt_inv,error=error) + CALL cp_dbcsr_release(sigma_vv_sqrt) + CALL cp_dbcsr_release(sigma_vv_sqrt_inv) IF (almo_scf_env%deloc_truncate_virt.ne.virt_full) THEN - CALL cp_dbcsr_release(k_vr_index_down,error=error) - CALL cp_dbcsr_release(k_vd_index_down,error=error) - !CALL cp_dbcsr_release(k_vd_index_up,error=error) - CALL cp_dbcsr_release(matrix_k_central,error=error) - CALL cp_dbcsr_release(vr_fixed,error=error) - CALL cp_dbcsr_release(vd_fixed,error=error) - CALL cp_dbcsr_release(grad,error=error) - CALL cp_dbcsr_release(prec,error=error) - CALL cp_dbcsr_release(prev_grad,error=error) - CALL cp_dbcsr_release(tmp3_vd_vr,error=error) - CALL cp_dbcsr_release(tmp1_n_vr,error=error) - CALL cp_dbcsr_release(tmp_k_blk,error=error) - CALL cp_dbcsr_release(t_curr,error=error) - CALL cp_dbcsr_release(sigma_oo_curr,error=error) - CALL cp_dbcsr_release(sigma_oo_curr_inv,error=error) - CALL cp_dbcsr_release(step,error=error) - CALL cp_dbcsr_release(tmp2_n_o,error=error) - CALL cp_dbcsr_release(tmp4_o_vr,error=error) - CALL cp_dbcsr_release(prev_step,error=error) - CALL cp_dbcsr_release(prev_minus_prec_grad,error=error) + CALL cp_dbcsr_release(k_vr_index_down) + CALL cp_dbcsr_release(k_vd_index_down) + !CALL cp_dbcsr_release(k_vd_index_up) + CALL cp_dbcsr_release(matrix_k_central) + CALL cp_dbcsr_release(vr_fixed) + CALL cp_dbcsr_release(vd_fixed) + CALL cp_dbcsr_release(grad) + CALL cp_dbcsr_release(prec) + CALL cp_dbcsr_release(prev_grad) + CALL cp_dbcsr_release(tmp3_vd_vr) + CALL cp_dbcsr_release(tmp1_n_vr) + CALL cp_dbcsr_release(tmp_k_blk) + CALL cp_dbcsr_release(t_curr) + CALL cp_dbcsr_release(sigma_oo_curr) + CALL cp_dbcsr_release(sigma_oo_curr_inv) + CALL cp_dbcsr_release(step) + CALL cp_dbcsr_release(tmp2_n_o) + CALL cp_dbcsr_release(tmp4_o_vr) + CALL cp_dbcsr_release(prev_step) + CALL cp_dbcsr_release(prev_minus_prec_grad) IF (md_in_k_space) THEN - CALL cp_dbcsr_release(velocity,error=error) + CALL cp_dbcsr_release(velocity) ENDIF ENDIF @@ -3927,14 +3765,14 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) IF (unit_nr>0) THEN WRITE(unit_nr,*) "sqrt and inv(sqrt) of AO overlap matrix" ENDIF - CALL cp_dbcsr_init(almo_scf_env%matrix_s_sqrt(1),error=error) - CALL cp_dbcsr_init(almo_scf_env%matrix_s_sqrt_inv(1),error=error) + CALL cp_dbcsr_init(almo_scf_env%matrix_s_sqrt(1)) + CALL cp_dbcsr_init(almo_scf_env%matrix_s_sqrt_inv(1)) CALL cp_dbcsr_create(almo_scf_env%matrix_s_sqrt(1),& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(almo_scf_env%matrix_s_sqrt_inv(1),& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL matrix_sqrt_Newton_Schulz(almo_scf_env%matrix_s_sqrt(1),& almo_scf_env%matrix_s_sqrt_inv(1),& @@ -3942,33 +3780,31 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) threshold=almo_scf_env%eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_s_sqrt_inv(1),& almo_scf_env%matrix_s(1),& - 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& - error=error) + 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,almo_scf_env%matrix_s_sqrt_inv(1),& - 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter,error=error) + 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp2) - CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp2) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(sqrt(S))*S*inv(sqrt(S))-I)",frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) ENDIF almo_scf_env%s_sqrt_done=.TRUE. @@ -3977,7 +3813,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) DO ispin=1,nspin - CALL ct_step_env_init(ct_step_env,error) + CALL ct_step_env_init(ct_step_env) CALL ct_step_env_set(ct_step_env,& para_env=almo_scf_env%para_env,& blacs_env=almo_scf_env%blacs_env,& @@ -4005,21 +3841,19 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) matrix_pq_template=almo_scf_env%matrix_t_tr(ispin),& matrix_t=almo_scf_env%matrix_t(ispin),& conjugator=almo_scf_env%deloc_cayley_conjugator,& - max_iter=almo_scf_env%deloc_cayley_max_iter,& - error=error) + max_iter=almo_scf_env%deloc_cayley_max_iter) ! perform calculations - CALL ct_step_execute(ct_step_env,error) + CALL ct_step_execute(ct_step_env) ! for now we do not need the new set of orbitals ! just get the energy correction CALL ct_step_env_get(ct_step_env,& - energy_correction=energy_correction(ispin),& + energy_correction=energy_correction(ispin)) !copy_da_energy_matrix=matrix_eda(ispin),& !copy_da_charge_matrix=matrix_cta(ispin),& - error=error) - CALL ct_step_env_clean(ct_step_env,error) + CALL ct_step_env_clean(ct_step_env) ENDDO @@ -4043,12 +3877,12 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) !! WRITE(unit_nr,*) !! WRITE(unit_nr,'(T2,A)') "ENERGY DECOMPOSITION" !!ENDIF - !!CALL cp_dbcsr_print_block_sum(eda_matrix(ispin),error=error) + !!CALL cp_dbcsr_print_block_sum(eda_matrix(ispin)) !!IF (unit_nr>0) THEN !! WRITE(unit_nr,*) !! WRITE(unit_nr,'(T2,A)') "CHARGE DECOMPOSITION" !!ENDIF - !!CALL cp_dbcsr_print_block_sum(cta_matrix(ispin),error=error) + !!CALL cp_dbcsr_print_block_sum(cta_matrix(ispin)) ! obtain density matrix from updated MOs ! RZK-later sigma and sigma_inv are lost here @@ -4058,12 +3892,11 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) orthog_orbs=.FALSE.,& s=almo_scf_env%matrix_s(1),& sigma=almo_scf_env%matrix_sigma(ispin),& - sigma_inv=almo_scf_env%matrix_sigma_inv(ispin),& - error=error) + sigma_inv=almo_scf_env%matrix_sigma_inv(ispin)) IF (almo_scf_env%nspins==1) & CALL cp_dbcsr_scale(almo_scf_env%matrix_p(ispin),& - spin_factor,error=error) + spin_factor) ENDDO @@ -4075,39 +3908,37 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Inverting AO overlap matrix" ENDIF - CALL cp_dbcsr_init(almo_scf_env%matrix_s_inv(1),error=error) + CALL cp_dbcsr_init(almo_scf_env%matrix_s_inv(1)) CALL cp_dbcsr_create(almo_scf_env%matrix_s_inv(1),& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) IF (.NOT.almo_scf_env%s_sqrt_done) THEN CALL invert_Hotelling(almo_scf_env%matrix_s_inv(1),& almo_scf_env%matrix_s(1),& - threshold=almo_scf_env%eps_filter,& - error=error) + threshold=almo_scf_env%eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_s_sqrt_inv(1),& almo_scf_env%matrix_s_sqrt_inv(1), & 0.0_dp,almo_scf_env%matrix_s_inv(1),& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) ENDIF IF (safe_mode) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, almo_scf_env%matrix_s_inv(1),& almo_scf_env%matrix_s(1),& 0.0_dp, matrix_tmp1,& - filter_eps=almo_scf_env%eps_filter,error=error) + filter_eps=almo_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp1) - CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(S)*S-I)",& frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) + CALL cp_dbcsr_release(matrix_tmp1) ENDIF almo_scf_env%s_inv_done=.TRUE. @@ -4119,19 +3950,19 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! IF (.FALSE.) THEN ! CALL apply_matrix_preconditioner(almo_scf_env%matrix_ks(ispin),& ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& - ! almo_scf_env%matrix_s_blk_sqrt_inv(1),error) + ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) ! ENDIF !CALL cp_dbcsr_filter(almo_scf_env%matrix_ks(ispin),& - ! almo_scf_env%eps_filter,error=error) + ! almo_scf_env%eps_filter) ENDDO ALLOCATE(matrix_p_almo_scf_converged(nspin)) DO ispin=1,nspin - CALL cp_dbcsr_init(matrix_p_almo_scf_converged(ispin),error=error) + CALL cp_dbcsr_init(matrix_p_almo_scf_converged(ispin)) CALL cp_dbcsr_create(matrix_p_almo_scf_converged(ispin),& - template=almo_scf_env%matrix_p(ispin),error=error) + template=almo_scf_env%matrix_p(ispin)) CALL cp_dbcsr_copy(matrix_p_almo_scf_converged(ispin),& - almo_scf_env%matrix_p(ispin),error=error) + almo_scf_env%matrix_p(ispin)) ENDDO ! update the density matrix @@ -4148,7 +3979,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! RZK UPDATE! it requires updating core LS_SCF routines ! RZK UPDATE! (the code exists in the CVS version) IF (unit_nr>0) WRITE(unit_nr,'(T2,A)') "CVS only: density_matrix_sign has not been updated in SVN" - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ! RZK UPDATE!CALL density_matrix_sign(almo_scf_env%matrix_p(ispin),& ! RZK UPDATE! local_mu,& ! RZK UPDATE! almo_scf_env%fixed_mu,& @@ -4157,26 +3988,26 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! RZK UPDATE! almo_scf_env%matrix_s_inv(1), & ! RZK UPDATE! nelectron_spin_real,& ! RZK UPDATE! almo_scf_env%eps_filter,& - ! RZK UPDATE! fake,& - ! RZK UPDATE! error) + ! RZK UPDATE! fake) + ! RZK UPDATE! almo_scf_env%mu=local_mu(1) !IF (almo_scf_env%has_s_preconditioner) THEN ! CALL apply_matrix_preconditioner(& ! almo_scf_env%matrix_p_blk(ispin),& ! "forward",almo_scf_env%matrix_s_blk_sqrt(1),& - ! almo_scf_env%matrix_s_blk_sqrt_inv(1),error) + ! almo_scf_env%matrix_s_blk_sqrt_inv(1)) !ENDIF !CALL cp_dbcsr_filter(almo_scf_env%matrix_p(ispin),& - ! almo_scf_env%eps_filter,error=error) + ! almo_scf_env%eps_filter) IF (almo_scf_env%nspins==1) & CALL cp_dbcsr_scale(almo_scf_env%matrix_p(ispin),& - spin_factor,error=error) + spin_factor) !CALL cp_dbcsr_trace(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& ! almo_scf_env%matrix_p(ispin),& - ! energy_correction(ispin),error=error) + ! energy_correction(ispin)) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) ! WRITE(unit_nr,'(T2,A,I6,F20.9)') "EFAKE",ispin,& @@ -4184,11 +4015,10 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ! WRITE(unit_nr,*) !ENDIF CALL cp_dbcsr_add(matrix_p_almo_scf_converged(ispin),& - almo_scf_env%matrix_p(ispin),-1.0_dp,1.0_dp,& - error=error) + almo_scf_env%matrix_p(ispin),-1.0_dp,1.0_dp) CALL cp_dbcsr_trace(almo_scf_env%matrix_ks_almo_scf_converged(ispin),& matrix_p_almo_scf_converged(ispin),& - energy_correction(ispin),error=error) + energy_correction(ispin)) energy_correction_final=energy_correction_final+energy_correction(ispin) @@ -4202,7 +4032,7 @@ SUBROUTINE harris_foulkes_correction(almo_scf_env,error) ENDDO DO ispin=1,nspin - CALL cp_dbcsr_release(matrix_p_almo_scf_converged(ispin),error=error) + CALL cp_dbcsr_release(matrix_p_almo_scf_converged(ispin)) ENDDO DEALLOCATE(matrix_p_almo_scf_converged) @@ -4240,20 +4070,18 @@ END SUBROUTINE harris_foulkes_correction !> \param template_n_vr ... !> \param spin_factor ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2011.09 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE opt_k_create_preconditioner(prec,vd_prop,f,x,oo_inv_x_tr,s,grad,& vd_blk,t,template_vd_vd_blk,template_vr_vr_blk,template_n_vr,& - spin_factor,eps_filter,error) + spin_factor,eps_filter) TYPE(cp_dbcsr_type), INTENT(INOUT) :: prec TYPE(cp_dbcsr_type), INTENT(IN) :: vd_prop, f, x, oo_inv_x_tr, s, grad, & vd_blk, t, template_vd_vd_blk, template_vr_vr_blk, template_n_vr REAL(KIND=dp), INTENT(IN) :: spin_factor, eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'opt_k_create_preconditioner', & routineP = moduleN//':'//routineN @@ -4275,130 +4103,130 @@ SUBROUTINE opt_k_create_preconditioner(prec,vd_prop,f,x,oo_inv_x_tr,s,grad,& CALL timeset(routineN,handle) ! initialize a matrix to 1.0 - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=prec,error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=prec) ! in order to use cp_dbcsr_set matrix blocks must exist - CALL cp_dbcsr_copy(tmp,prec,error=error) - CALL cp_dbcsr_set(tmp,1.0_dp,error=error) + CALL cp_dbcsr_copy(tmp,prec) + CALL cp_dbcsr_set(tmp,1.0_dp) ! compute qq = (Vd^tr)*F*Vd - CALL cp_dbcsr_init(tmp_n_vd,error=error) - CALL cp_dbcsr_create(tmp_n_vd,template=vd_prop,error=error) + CALL cp_dbcsr_init(tmp_n_vd) + CALL cp_dbcsr_create(tmp_n_vd,template=vd_prop) CALL cp_dbcsr_multiply("N","N",1.0_dp,f,vd_prop,& - 0.0_dp,tmp_n_vd,filter_eps=eps_filter,error=error) - CALL cp_dbcsr_init(tmp_vd_vd_blk,error=error) + 0.0_dp,tmp_n_vd,filter_eps=eps_filter) + CALL cp_dbcsr_init(tmp_vd_vd_blk) CALL cp_dbcsr_create(tmp_vd_vd_blk,& - template=template_vd_vd_blk,error=error) - CALL cp_dbcsr_copy(tmp_vd_vd_blk,template_vd_vd_blk,error=error) + template=template_vd_vd_blk) + CALL cp_dbcsr_copy(tmp_vd_vd_blk,template_vd_vd_blk) CALL cp_dbcsr_multiply("T","N",1.0_dp,vd_prop,tmp_n_vd,& 0.0_dp,tmp_vd_vd_blk,& retain_sparsity=.TRUE.,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! copy diagonal elements of the result into rows of a matrix CALL cp_dbcsr_get_info(tmp_vd_vd_blk, nfullrows_total=q_nrows ) ALLOCATE(q_diagonal(q_nrows)) - CALL cp_dbcsr_get_diag(tmp_vd_vd_blk,q_diagonal,error=error) - CALL cp_dbcsr_init(qq_diag,error=error) + CALL cp_dbcsr_get_diag(tmp_vd_vd_blk,q_diagonal) + CALL cp_dbcsr_init(qq_diag) CALL cp_dbcsr_create(qq_diag,& - template=template_vd_vd_blk,error=error) - CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(qq_diag,q_diagonal,error=error) - CALL cp_dbcsr_init(t1,error=error) - CALL cp_dbcsr_create(t1,template=prec,error=error) + template=template_vd_vd_blk) + CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp) + CALL cp_dbcsr_set_diag(qq_diag,q_diagonal) + CALL cp_dbcsr_init(t1) + CALL cp_dbcsr_create(t1,template=prec) CALL cp_dbcsr_multiply("N","N",1.0_dp,qq_diag,tmp,& - 0.0_dp,t1,filter_eps=eps_filter,error=error) + 0.0_dp,t1,filter_eps=eps_filter) ! compute pp = X*sigma_oo_inv*X^tr - CALL cp_dbcsr_init(tmp_vr_vr_blk,error=error) - CALL cp_dbcsr_create(tmp_vr_vr_blk,template=template_vr_vr_blk,error=error) - CALL cp_dbcsr_copy(tmp_vr_vr_blk,template_vr_vr_blk,error=error) + CALL cp_dbcsr_init(tmp_vr_vr_blk) + CALL cp_dbcsr_create(tmp_vr_vr_blk,template=template_vr_vr_blk) + CALL cp_dbcsr_copy(tmp_vr_vr_blk,template_vr_vr_blk) CALL cp_dbcsr_multiply("N","N",1.0_dp,x,oo_inv_x_tr,& 0.0_dp,tmp_vr_vr_blk,& retain_sparsity=.TRUE.,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! copy diagonal elements of the result into cols of a matrix CALL cp_dbcsr_get_info(tmp_vr_vr_blk,nfullrows_total=p_nrows) ALLOCATE(p_diagonal(p_nrows)) - CALL cp_dbcsr_get_diag(tmp_vr_vr_blk,p_diagonal,error=error) - CALL cp_dbcsr_init(pp_diag,error=error) - CALL cp_dbcsr_create(pp_diag,template=template_vr_vr_blk,error=error) - CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(pp_diag,p_diagonal,error=error) - CALL cp_dbcsr_set(tmp,1.0_dp,error=error) - CALL cp_dbcsr_init(t2,error=error) - CALL cp_dbcsr_create(t2,template=prec,error=error) + CALL cp_dbcsr_get_diag(tmp_vr_vr_blk,p_diagonal) + CALL cp_dbcsr_init(pp_diag) + CALL cp_dbcsr_create(pp_diag,template=template_vr_vr_blk) + CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp) + CALL cp_dbcsr_set_diag(pp_diag,p_diagonal) + CALL cp_dbcsr_set(tmp,1.0_dp) + CALL cp_dbcsr_init(t2) + CALL cp_dbcsr_create(t2,template=prec) CALL cp_dbcsr_multiply("N","N",1.0_dp,tmp,pp_diag,& - 0.0_dp,t2,filter_eps=eps_filter,error=error) + 0.0_dp,t2,filter_eps=eps_filter) - CALL cp_dbcsr_hadamard_product(t1,t2,prec,error=error) + CALL cp_dbcsr_hadamard_product(t1,t2,prec) ! compute qq = (Vd^tr)*S*Vd CALL cp_dbcsr_multiply("N","N",1.0_dp,s,vd_prop,& - 0.0_dp,tmp_n_vd,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_n_vd,filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,vd_prop,tmp_n_vd,& 0.0_dp,tmp_vd_vd_blk,& retain_sparsity=.TRUE.,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! copy diagonal elements of the result into rows of a matrix - CALL cp_dbcsr_get_diag(tmp_vd_vd_blk,q_diagonal,error=error) - CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(qq_diag,q_diagonal,error=error) - CALL cp_dbcsr_set(tmp,1.0_dp,error=error) + CALL cp_dbcsr_get_diag(tmp_vd_vd_blk,q_diagonal) + CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp) + CALL cp_dbcsr_set_diag(qq_diag,q_diagonal) + CALL cp_dbcsr_set(tmp,1.0_dp) CALL cp_dbcsr_multiply("N","N",1.0_dp,qq_diag,tmp,& - 0.0_dp,t1,filter_eps=eps_filter,error=error) + 0.0_dp,t1,filter_eps=eps_filter) ! compute pp = X*sig_oo_inv*(T^tr)*F*T*sig_oo_inv*(X^tr) - CALL cp_dbcsr_init(tmp1_n_vr,error=error) - CALL cp_dbcsr_create(tmp1_n_vr,template=template_n_vr,error=error) - CALL cp_dbcsr_init(tmp2_n_vr,error=error) - CALL cp_dbcsr_create(tmp2_n_vr,template=template_n_vr,error=error) + CALL cp_dbcsr_init(tmp1_n_vr) + CALL cp_dbcsr_create(tmp1_n_vr,template=template_n_vr) + CALL cp_dbcsr_init(tmp2_n_vr) + CALL cp_dbcsr_create(tmp2_n_vr,template=template_n_vr) CALL cp_dbcsr_multiply("N","N",1.0_dp,t,oo_inv_x_tr,& - 0.0_dp,tmp1_n_vr,filter_eps=eps_filter,error=error) + 0.0_dp,tmp1_n_vr,filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,f,tmp1_n_vr,& - 0.0_dp,tmp2_n_vr,filter_eps=eps_filter,error=error) + 0.0_dp,tmp2_n_vr,filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,tmp1_n_vr,tmp2_n_vr,& 0.0_dp,tmp_vr_vr_blk,& retain_sparsity=.TRUE.,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! copy diagonal elements of the result into cols of a matrix - CALL cp_dbcsr_get_diag(tmp_vr_vr_blk,p_diagonal,error=error) - CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(pp_diag,p_diagonal,error=error) - CALL cp_dbcsr_set(tmp,1.0_dp,error=error) + CALL cp_dbcsr_get_diag(tmp_vr_vr_blk,p_diagonal) + CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp) + CALL cp_dbcsr_set_diag(pp_diag,p_diagonal) + CALL cp_dbcsr_set(tmp,1.0_dp) CALL cp_dbcsr_multiply("N","N",1.0_dp,tmp,pp_diag,& - 0.0_dp,t2,filter_eps=eps_filter,error=error) + 0.0_dp,t2,filter_eps=eps_filter) - CALL cp_dbcsr_hadamard_product(t1,t2,tmp,error=error) - CALL cp_dbcsr_add(prec,tmp,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_scale(prec,2.0_dp*spin_factor,error=error) + CALL cp_dbcsr_hadamard_product(t1,t2,tmp) + CALL cp_dbcsr_add(prec,tmp,1.0_dp,-1.0_dp) + CALL cp_dbcsr_scale(prec,2.0_dp*spin_factor) ! compute qp = X*sig_oo_inv*(T^tr)*S*Vd CALL cp_dbcsr_multiply("N","N",1.0_dp,s,vd_blk,& - 0.0_dp,tmp_n_vd,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_n_vd,filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,tmp_n_vd,tmp1_n_vr,& 0.0_dp,tmp,retain_sparsity=.TRUE.,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_hadamard_product(grad,tmp,t1,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_hadamard_product(grad,tmp,t1) ! gradient already contains 2.0*spin_factor - CALL cp_dbcsr_scale(t1,-2.0_dp,error=error) + CALL cp_dbcsr_scale(t1,-2.0_dp) - CALL cp_dbcsr_add(prec,t1,1.0_dp,1.0_dp,error=error) + CALL cp_dbcsr_add(prec,t1,1.0_dp,1.0_dp) - CALL cp_dbcsr_function_of_elements(prec,dbcsr_func_inverse,error=error) - CALL cp_dbcsr_filter(prec,eps_filter,error=error) + CALL cp_dbcsr_function_of_elements(prec,dbcsr_func_inverse) + CALL cp_dbcsr_filter(prec,eps_filter) DEALLOCATE(q_diagonal) DEALLOCATE(p_diagonal) - CALL cp_dbcsr_release(tmp,error=error) - CALL cp_dbcsr_release(qq_diag,error=error) - CALL cp_dbcsr_release(t1,error=error) - CALL cp_dbcsr_release(pp_diag,error=error) - CALL cp_dbcsr_release(t2,error=error) - CALL cp_dbcsr_release(tmp_n_vd,error=error) - CALL cp_dbcsr_release(tmp_vd_vd_blk,error=error) - CALL cp_dbcsr_release(tmp_vr_vr_blk,error=error) - CALL cp_dbcsr_release(tmp1_n_vr,error=error) - CALL cp_dbcsr_release(tmp2_n_vr,error=error) + CALL cp_dbcsr_release(tmp) + CALL cp_dbcsr_release(qq_diag) + CALL cp_dbcsr_release(t1) + CALL cp_dbcsr_release(pp_diag) + CALL cp_dbcsr_release(t2) + CALL cp_dbcsr_release(tmp_n_vd) + CALL cp_dbcsr_release(tmp_vd_vd_blk) + CALL cp_dbcsr_release(tmp_vr_vr_blk) + CALL cp_dbcsr_release(tmp1_n_vr) + CALL cp_dbcsr_release(tmp2_n_vr) CALL timestop(handle) @@ -4413,19 +4241,17 @@ END SUBROUTINE opt_k_create_preconditioner !> \param t_curr ... !> \param ispin ... !> \param spin_factor ... -!> \param error ... !> \par History !> 2011.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE opt_k_create_preconditioner_blk(almo_scf_env,vd_prop,oo_inv_x_tr,& - t_curr,ispin,spin_factor,error) + t_curr,ispin,spin_factor) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env TYPE(cp_dbcsr_type), INTENT(IN) :: vd_prop, oo_inv_x_tr, t_curr INTEGER, INTENT(IN) :: ispin REAL(KIND=dp), INTENT(IN) :: spin_factor - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'opt_k_create_preconditioner_blk', & @@ -4443,208 +4269,194 @@ SUBROUTINE opt_k_create_preconditioner_blk(almo_scf_env,vd_prop,oo_inv_x_tr,& eps_filter=almo_scf_env%eps_filter ! compute S_qq = (Vd^tr)*S*Vd - CALL cp_dbcsr_init(tmp_n_vd,error=error) - CALL cp_dbcsr_create(tmp_n_vd,template=almo_scf_env%matrix_v_disc(ispin),& - error=error) - CALL cp_dbcsr_init(tmp_vd_vd_blk,error=error) + CALL cp_dbcsr_init(tmp_n_vd) + CALL cp_dbcsr_create(tmp_n_vd,template=almo_scf_env%matrix_v_disc(ispin)) + CALL cp_dbcsr_init(tmp_vd_vd_blk) CALL cp_dbcsr_create(tmp_vd_vd_blk,& template=almo_scf_env%matrix_vv_disc_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%matrix_s(1),& vd_prop,& - 0.0_dp,tmp_n_vd,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_n_vd,filter_eps=eps_filter) CALL cp_dbcsr_copy(tmp_vd_vd_blk,& - almo_scf_env%matrix_vv_disc_blk(ispin),error=error) + almo_scf_env%matrix_vv_disc_blk(ispin)) CALL cp_dbcsr_multiply("T","N",1.0_dp,vd_prop,tmp_n_vd,& 0.0_dp,tmp_vd_vd_blk,& - retain_sparsity=.TRUE.,& - error=error) + retain_sparsity=.TRUE.) - CALL cp_dbcsr_init(s_dd_sqrt,error=error) + CALL cp_dbcsr_init(s_dd_sqrt) CALL cp_dbcsr_create(s_dd_sqrt,& template=almo_scf_env%matrix_vv_disc_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL matrix_sqrt_Newton_Schulz(s_dd_sqrt,& almo_scf_env%opt_k_t_dd(ispin),& tmp_vd_vd_blk,& threshold=eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) ! compute F_qq = (Vd^tr)*F*Vd CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%matrix_ks_almo_scf_converged(ispin),& vd_prop,& - 0.0_dp,tmp_n_vd,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_n_vd,filter_eps=eps_filter) CALL cp_dbcsr_copy(tmp_vd_vd_blk,& - almo_scf_env%matrix_vv_disc_blk(ispin),error=error) + almo_scf_env%matrix_vv_disc_blk(ispin)) CALL cp_dbcsr_multiply("T","N",1.0_dp,vd_prop,tmp_n_vd,& 0.0_dp,tmp_vd_vd_blk,& - retain_sparsity=.TRUE.,& - error=error) - CALL cp_dbcsr_release(tmp_n_vd,error=error) + retain_sparsity=.TRUE.) + CALL cp_dbcsr_release(tmp_n_vd) ! bring to the blocked-orthogonalized basis CALL cp_dbcsr_multiply("N","N",1.0_dp,& tmp_vd_vd_blk,& almo_scf_env%opt_k_t_dd(ispin),& - 0.0_dp,s_dd_sqrt,filter_eps=eps_filter,error=error) + 0.0_dp,s_dd_sqrt,filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%opt_k_t_dd(ispin),& s_dd_sqrt,& - 0.0_dp,tmp_vd_vd_blk,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_vd_vd_blk,filter_eps=eps_filter) ! diagonalize the matrix - CALL cp_dbcsr_init(opt_k_e_dd,error=error) + CALL cp_dbcsr_init(opt_k_e_dd) CALL cp_dbcsr_create(opt_k_e_dd,& - template=almo_scf_env%matrix_vv_disc_blk(ispin),& - error=error) - CALL cp_dbcsr_release(s_dd_sqrt,error=error) - CALL cp_dbcsr_init(s_dd_sqrt,error=error) + template=almo_scf_env%matrix_vv_disc_blk(ispin)) + CALL cp_dbcsr_release(s_dd_sqrt) + CALL cp_dbcsr_init(s_dd_sqrt) CALL cp_dbcsr_create(s_dd_sqrt,& template=almo_scf_env%matrix_vv_disc_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL diagonalize_diagonal_blocks(tmp_vd_vd_blk,& s_dd_sqrt,& - opt_k_e_dd,& - error=error) + opt_k_e_dd) ! obtain the transformation matrix in the discarded subspace ! T = S^{-1/2}.U CALL cp_dbcsr_copy(tmp_vd_vd_blk,& - almo_scf_env%opt_k_t_dd(ispin),error=error) + almo_scf_env%opt_k_t_dd(ispin)) CALL cp_dbcsr_multiply("N","N",1.0_dp,& tmp_vd_vd_blk,& s_dd_sqrt,& 0.0_dp,almo_scf_env%opt_k_t_dd(ispin),& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(s_dd_sqrt,error=error) - CALL cp_dbcsr_release(tmp_vd_vd_blk,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_release(s_dd_sqrt) + CALL cp_dbcsr_release(tmp_vd_vd_blk) ! copy diagonal elements of the result into rows of a matrix - CALL cp_dbcsr_init(tmp,error=error) + CALL cp_dbcsr_init(tmp) CALL cp_dbcsr_create(tmp,& - template=almo_scf_env%matrix_k_blk_ones(ispin),& - error=error) + template=almo_scf_env%matrix_k_blk_ones(ispin)) CALL cp_dbcsr_copy(tmp,& - almo_scf_env%matrix_k_blk_ones(ispin),& - error=error) - CALL cp_dbcsr_init(t1,error=error) + almo_scf_env%matrix_k_blk_ones(ispin)) + CALL cp_dbcsr_init(t1) CALL cp_dbcsr_create(t1,& - template=almo_scf_env%matrix_k_blk_ones(ispin),& - error=error) + template=almo_scf_env%matrix_k_blk_ones(ispin)) CALL cp_dbcsr_multiply("N","N",1.0_dp,& opt_k_e_dd,tmp,& - 0.0_dp,t1,filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(opt_k_e_dd,error=error) + 0.0_dp,t1,filter_eps=eps_filter) + CALL cp_dbcsr_release(opt_k_e_dd) ! compute S_pp = X*sigma_oo_inv*X^tr - CALL cp_dbcsr_init(tmp_vr_vr_blk,error=error) + CALL cp_dbcsr_init(tmp_vr_vr_blk) CALL cp_dbcsr_create(tmp_vr_vr_blk,& template=almo_scf_env%matrix_sigma_vv_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_copy(tmp_vr_vr_blk,& - almo_scf_env%matrix_sigma_vv_blk(ispin),error=error) + almo_scf_env%matrix_sigma_vv_blk(ispin)) CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%matrix_x(ispin),& oo_inv_x_tr,& 0.0_dp,tmp_vr_vr_blk,& - retain_sparsity=.TRUE.,& - error=error) + retain_sparsity=.TRUE.) ! obtain the orthogonalization matrix - CALL cp_dbcsr_init(s_rr_sqrt,error=error) + CALL cp_dbcsr_init(s_rr_sqrt) CALL cp_dbcsr_create(s_rr_sqrt,& template=almo_scf_env%matrix_sigma_vv_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL matrix_sqrt_Newton_Schulz(s_rr_sqrt,& almo_scf_env%opt_k_t_rr(ispin),& tmp_vr_vr_blk,& threshold=eps_filter,& order=almo_scf_env%order_lanczos,& eps_lanczos=almo_scf_env%eps_lanczos,& - max_iter_lanczos=almo_scf_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=almo_scf_env%max_iter_lanczos) ! compute F_pp = X*sig_oo_inv*(T^tr)*F*T*sig_oo_inv*(X^tr) - CALL cp_dbcsr_init(tmp1_n_vr,error=error) + CALL cp_dbcsr_init(tmp1_n_vr) CALL cp_dbcsr_create(tmp1_n_vr,& - template=almo_scf_env%matrix_v(ispin),error=error) - CALL cp_dbcsr_init(tmp2_n_vr,error=error) + template=almo_scf_env%matrix_v(ispin)) + CALL cp_dbcsr_init(tmp2_n_vr) CALL cp_dbcsr_create(tmp2_n_vr,& - template=almo_scf_env%matrix_v(ispin),error=error) + template=almo_scf_env%matrix_v(ispin)) CALL cp_dbcsr_multiply("N","N",1.0_dp,t_curr,oo_inv_x_tr,& - 0.0_dp,tmp1_n_vr,filter_eps=eps_filter,error=error) + 0.0_dp,tmp1_n_vr,filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%matrix_ks_almo_scf_converged(ispin),& tmp1_n_vr,& - 0.0_dp,tmp2_n_vr,filter_eps=eps_filter,error=error) + 0.0_dp,tmp2_n_vr,filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,tmp1_n_vr,tmp2_n_vr,& 0.0_dp,tmp_vr_vr_blk,& - retain_sparsity=.TRUE.,& - error=error) - CALL cp_dbcsr_release(tmp1_n_vr,error=error) - CALL cp_dbcsr_release(tmp2_n_vr,error=error) + retain_sparsity=.TRUE.) + CALL cp_dbcsr_release(tmp1_n_vr) + CALL cp_dbcsr_release(tmp2_n_vr) ! bring to the blocked-orthogonalized basis CALL cp_dbcsr_multiply("N","N",1.0_dp,& tmp_vr_vr_blk,& almo_scf_env%opt_k_t_rr(ispin),& - 0.0_dp,s_rr_sqrt,filter_eps=eps_filter,error=error) + 0.0_dp,s_rr_sqrt,filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%opt_k_t_rr(ispin),& s_rr_sqrt,& - 0.0_dp,tmp_vr_vr_blk,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_vr_vr_blk,filter_eps=eps_filter) ! diagonalize the matrix - CALL cp_dbcsr_init(opt_k_e_rr,error=error) + CALL cp_dbcsr_init(opt_k_e_rr) CALL cp_dbcsr_create(opt_k_e_rr,& - template=almo_scf_env%matrix_sigma_vv_blk(ispin),& - error=error) - CALL cp_dbcsr_release(s_rr_sqrt,error=error) - CALL cp_dbcsr_init(s_rr_sqrt,error=error) + template=almo_scf_env%matrix_sigma_vv_blk(ispin)) + CALL cp_dbcsr_release(s_rr_sqrt) + CALL cp_dbcsr_init(s_rr_sqrt) CALL cp_dbcsr_create(s_rr_sqrt,& template=almo_scf_env%matrix_sigma_vv_blk(ispin),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL diagonalize_diagonal_blocks(tmp_vr_vr_blk,& s_rr_sqrt,& - opt_k_e_rr,& - error=error) + opt_k_e_rr) ! obtain the transformation matrix in the retained subspace ! T = S^{-1/2}.U CALL cp_dbcsr_copy(tmp_vr_vr_blk,& - almo_scf_env%opt_k_t_rr(ispin),error=error) + almo_scf_env%opt_k_t_rr(ispin)) CALL cp_dbcsr_multiply("N","N",1.0_dp,& tmp_vr_vr_blk,& s_rr_sqrt,& 0.0_dp,almo_scf_env%opt_k_t_rr(ispin),& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(s_rr_sqrt,error=error) - CALL cp_dbcsr_release(tmp_vr_vr_blk,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_release(s_rr_sqrt) + CALL cp_dbcsr_release(tmp_vr_vr_blk) ! copy diagonal elements of the result into cols of a matrix CALL cp_dbcsr_multiply("N","N",1.0_dp,& tmp,opt_k_e_rr,& 0.0_dp,almo_scf_env%opt_k_denom(ispin),& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(opt_k_e_rr,error=error) - CALL cp_dbcsr_release(tmp,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_release(opt_k_e_rr) + CALL cp_dbcsr_release(tmp) ! form the denominator matrix CALL cp_dbcsr_add(almo_scf_env%opt_k_denom(ispin),t1,& - -1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_release(t1,error=error) + -1.0_dp,1.0_dp) + CALL cp_dbcsr_release(t1) CALL cp_dbcsr_scale(almo_scf_env%opt_k_denom(ispin),& - 2.0_dp*spin_factor,error=error) + 2.0_dp*spin_factor) CALL cp_dbcsr_function_of_elements(almo_scf_env%opt_k_denom(ispin),& - dbcsr_func_inverse,error=error) + dbcsr_func_inverse) CALL cp_dbcsr_filter(almo_scf_env%opt_k_denom(ispin),& - eps_filter,error=error) + eps_filter) CALL timestop(handle) @@ -4658,18 +4470,16 @@ END SUBROUTINE opt_k_create_preconditioner_blk !> \param step ... !> \param grad ... !> \param ispin ... -!> \param error ... !> \par History !> 2011.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE opt_k_apply_preconditioner_blk(almo_scf_env,step,grad,ispin,error) + SUBROUTINE opt_k_apply_preconditioner_blk(almo_scf_env,step,grad,ispin) TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env TYPE(cp_dbcsr_type), INTENT(OUT) :: step TYPE(cp_dbcsr_type), INTENT(IN) :: grad INTEGER, INTENT(IN) :: ispin - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'opt_k_apply_preconditioner_blk', & @@ -4683,33 +4493,32 @@ SUBROUTINE opt_k_apply_preconditioner_blk(almo_scf_env,step,grad,ispin,error) eps_filter=almo_scf_env%eps_filter - CALL cp_dbcsr_init(tmp_k,error=error) - CALL cp_dbcsr_create(tmp_k,template=almo_scf_env%matrix_k_blk(ispin),& - error=error) + CALL cp_dbcsr_init(tmp_k) + CALL cp_dbcsr_create(tmp_k,template=almo_scf_env%matrix_k_blk(ispin)) ! transform gradient to the correct "diagonal" basis CALL cp_dbcsr_multiply("N","N",1.0_dp,& grad,almo_scf_env%opt_k_t_rr(ispin),& - 0.0_dp,tmp_k,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_k,filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,& almo_scf_env%opt_k_t_dd(ispin),tmp_k,& - 0.0_dp,step,filter_eps=eps_filter,error=error) + 0.0_dp,step,filter_eps=eps_filter) ! apply diagonal preconditioner CALL cp_dbcsr_hadamard_product(step,& - almo_scf_env%opt_k_denom(ispin),tmp_k,error=error) + almo_scf_env%opt_k_denom(ispin),tmp_k) ! back-transform the result to the initial basis CALL cp_dbcsr_multiply("N","N",1.0_dp,& almo_scf_env%opt_k_t_dd(ispin),tmp_k,& - 0.0_dp,step,filter_eps=eps_filter,error=error) + 0.0_dp,step,filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","T",1.0_dp,& step,almo_scf_env%opt_k_t_rr(ispin),& - 0.0_dp,tmp_k,filter_eps=eps_filter,error=error) + 0.0_dp,tmp_k,filter_eps=eps_filter) - CALL cp_dbcsr_copy(step,tmp_k,error=error) + CALL cp_dbcsr_copy(step,tmp_k) - CALL cp_dbcsr_release(tmp_k,error=error) + CALL cp_dbcsr_release(tmp_k) CALL timestop(handle) @@ -4723,11 +4532,10 @@ END SUBROUTINE opt_k_apply_preconditioner_blk !!> 2011.08 created [Rustam Z Khaliullin] !!> \author Rustam Z Khaliullin !! ***************************************************************************** -! SUBROUTINE truncate_subspace_v_blk(qs_env,almo_scf_env,error) +! SUBROUTINE truncate_subspace_v_blk(qs_env,almo_scf_env) ! ! TYPE(qs_environment_type), POINTER :: qs_env ! TYPE(almo_scf_env_type) :: almo_scf_env -! TYPE(cp_error_type), INTENT(INOUT) :: error ! ! CHARACTER(len=*), PARAMETER :: routineN = 'truncate_subspace_v_blk', & ! routineP = moduleN//':'//routineN @@ -4771,7 +4579,7 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! safe_mode=.TRUE. ! ! ! get a useful output_unit -! logger => cp_error_get_logger(error) +! logger => cp_get_default_logger() ! IF (logger%para_env%mepos==logger%para_env%source) THEN ! unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ! ELSE @@ -4786,36 +4594,35 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! ! 0. Orthogonalize virtuals ! ! Unfortunately, we have to do it in the FULL V subspace :( ! -! CALL cp_dbcsr_init(v_full_new,error=error) +! CALL cp_dbcsr_init(v_full_new) ! CALL cp_dbcsr_create(v_full_new,& ! template=almo_scf_env%matrix_v_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! ! project the occupied subspace out ! CALL almo_scf_p_out_from_v(almo_scf_env%matrix_v_full_blk(ispin),& ! v_full_new,almo_scf_env%matrix_ov_full(ispin),& -! ispin,almo_scf_env,error) +! ispin,almo_scf_env) ! ! ! init overlap and its functions -! CALL cp_dbcsr_init(matrix_sigma_vv_full,error=error) -! CALL cp_dbcsr_init(matrix_sigma_vv_full_sqrt,error=error) -! CALL cp_dbcsr_init(matrix_sigma_vv_full_sqrt_inv,error=error) +! CALL cp_dbcsr_init(matrix_sigma_vv_full) +! CALL cp_dbcsr_init(matrix_sigma_vv_full_sqrt) +! CALL cp_dbcsr_init(matrix_sigma_vv_full_sqrt_inv) ! CALL cp_dbcsr_create(matrix_sigma_vv_full,& ! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,error=error) +! matrix_type=dbcsr_type_no_symmetry) ! CALL cp_dbcsr_create(matrix_sigma_vv_full_sqrt,& ! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,error=error) +! matrix_type=dbcsr_type_no_symmetry) ! CALL cp_dbcsr_create(matrix_sigma_vv_full_sqrt_inv,& ! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! ! construct VV overlap ! CALL almo_scf_mo_to_sigma(v_full_new,& ! matrix_sigma_vv_full,& ! almo_scf_env%matrix_s(1),& -! almo_scf_env%eps_filter,error) +! almo_scf_env%eps_filter) ! ! IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "sqrt and inv(sqrt) of the FULL virtual MO overlap" @@ -4828,120 +4635,103 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! threshold=almo_scf_env%eps_filter,& ! order=almo_scf_env%order_lanczos,& ! eps_lanczos=almo_scf_env%eps_lanczos,& -! max_iter_lanczos=almo_scf_env%max_iter_lanczos,& -! error=error) +! max_iter_lanczos=almo_scf_env%max_iter_lanczos) ! IF (safe_mode) THEN -! CALL cp_dbcsr_init(matrix_tmp1,error=error) +! CALL cp_dbcsr_init(matrix_tmp1) ! CALL cp_dbcsr_create(matrix_tmp1,template=matrix_sigma_vv_full,& -! matrix_type=dbcsr_type_no_symmetry,error=error) -! CALL cp_dbcsr_init(matrix_tmp2,error=error) +! matrix_type=dbcsr_type_no_symmetry) +! CALL cp_dbcsr_init(matrix_tmp2) ! CALL cp_dbcsr_create(matrix_tmp2,template=matrix_sigma_vv_full,& -! matrix_type=dbcsr_type_no_symmetry,error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_sigma_vv_full_sqrt_inv,& ! matrix_sigma_vv_full,& -! 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter,& -! error=error) +! 0.0_dp,matrix_tmp1,filter_eps=almo_scf_env%eps_filter) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_tmp1,& ! matrix_sigma_vv_full_sqrt_inv,& -! 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter,& -! error=error) +! 0.0_dp,matrix_tmp2,filter_eps=almo_scf_env%eps_filter) ! ! frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp2) -! CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp,error=error) +! CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) ! frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp2) ! IF (unit_nr>0) THEN ! WRITE(unit_nr,*) "Error for (inv(sqrt(SIGVV))*SIGVV*inv(sqrt(SIGVV))-I)",frob_matrix/frob_matrix_base ! ENDIF ! -! CALL cp_dbcsr_release(matrix_tmp1,error=error) -! CALL cp_dbcsr_release(matrix_tmp2,error=error) +! CALL cp_dbcsr_release(matrix_tmp1) +! CALL cp_dbcsr_release(matrix_tmp2) ! ENDIF ! ! ! discard unnecessary overlap functions -! CALL cp_dbcsr_release(matrix_sigma_vv_full,error=error) -! CALL cp_dbcsr_release(matrix_sigma_vv_full_sqrt,error=error) +! CALL cp_dbcsr_release(matrix_sigma_vv_full) +! CALL cp_dbcsr_release(matrix_sigma_vv_full_sqrt) ! !! this can be re-written because we have (1-P)|v> ! ! !!!!!!!!!!!!!!!!!!! ! ! 1. Compute F_ov -! CALL cp_dbcsr_init(Fon,error=error) +! CALL cp_dbcsr_init(Fon) ! CALL cp_dbcsr_create(Fon,& -! template=almo_scf_env%matrix_v_full_blk(ispin),& -! error=error) -! CALL cp_dbcsr_init(Fov,error=error) +! template=almo_scf_env%matrix_v_full_blk(ispin)) +! CALL cp_dbcsr_init(Fov) ! CALL cp_dbcsr_create(Fov,& -! template=almo_scf_env%matrix_ov_full(ispin),& -! error=error) -! CALL cp_dbcsr_init(Fov_filtered,error=error) +! template=almo_scf_env%matrix_ov_full(ispin)) +! CALL cp_dbcsr_init(Fov_filtered) ! CALL cp_dbcsr_create(Fov_filtered,& -! template=almo_scf_env%matrix_ov_full(ispin),& -! error=error) -! CALL cp_dbcsr_init(temp1_oo,error=error) +! template=almo_scf_env%matrix_ov_full(ispin)) +! CALL cp_dbcsr_init(temp1_oo) ! CALL cp_dbcsr_create(temp1_oo,& ! template=almo_scf_env%matrix_sigma(ispin),& -! !matrix_type=dbcsr_type_no_symmetry,& -! error=error) -! CALL cp_dbcsr_init(temp2_oo,error=error) +! !matrix_type=dbcsr_type_no_symmetry) +! CALL cp_dbcsr_init(temp2_oo) ! CALL cp_dbcsr_create(temp2_oo,& ! template=almo_scf_env%matrix_sigma(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! CALL cp_dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& ! almo_scf_env%matrix_ks_almo_scf_converged(ispin),& -! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter,& -! error=error) +! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) ! ! CALL cp_dbcsr_multiply("N","N",1.0_dp,Fon,& ! almo_scf_env%matrix_v_full_blk(ispin),& -! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter,& -! error=error) +! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) ! ! CALL cp_dbcsr_multiply("N","N",1.0_dp,Fon,& ! almo_scf_env%matrix_t_blk(ispin),& -! 0.0_dp,temp1_oo,filter_eps=almo_scf_env%eps_filter,& -! error=error) +! 0.0_dp,temp1_oo,filter_eps=almo_scf_env%eps_filter) ! ! CALL cp_dbcsr_multiply("N","N",1.0_dp,temp1_oo,& ! almo_scf_env%matrix_sigma_inv(ispin),& -! 0.0_dp,temp2_oo,filter_eps=almo_scf_env%eps_filter,& -! error=error) -! CALL cp_dbcsr_release(temp1_oo,error=error) +! 0.0_dp,temp2_oo,filter_eps=almo_scf_env%eps_filter) +! CALL cp_dbcsr_release(temp1_oo) ! ! CALL cp_dbcsr_multiply("T","N",1.0_dp,almo_scf_env%matrix_t_blk(ispin),& ! almo_scf_env%matrix_s(1),& -! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter,& -! error=error) +! 0.0_dp,Fon,filter_eps=almo_scf_env%eps_filter) ! ! CALL cp_dbcsr_multiply("N","N",1.0_dp,Fon,& ! almo_scf_env%matrix_v_full_blk(ispin),& -! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter,& -! error=error) -! CALL cp_dbcsr_release(Fon,error=error) +! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +! CALL cp_dbcsr_release(Fon) ! ! CALL cp_dbcsr_multiply("N","N",-1.0_dp,temp2_oo,& ! Fov_filtered,& -! 1.0_dp,Fov,filter_eps=almo_scf_env%eps_filter,& -! error=error) -! CALL cp_dbcsr_release(temp2_oo,error=error) +! 1.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! CALL cp_dbcsr_release(temp2_oo) ! ! CALL cp_dbcsr_multiply("N","N",1.0_dp,almo_scf_env%matrix_sigma_inv(ispin),& -! Fov,0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter,& -! error=error) +! Fov,0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) ! ! CALL cp_dbcsr_multiply("N","N",1.0_dp,Fov_filtered,& ! matrix_sigma_vv_full_sqrt_inv,& -! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter,& -! error=error) -! !CALL cp_dbcsr_copy(Fov,Fov_filtered,error=error) -!CALL cp_dbcsr_print(Fov,error=error) +! 0.0_dp,Fov,filter_eps=almo_scf_env%eps_filter) +! !CALL cp_dbcsr_copy(Fov,Fov_filtered) +!CALL cp_dbcsr_print(Fov) ! ! IF (safe_mode) THEN -! CALL cp_dbcsr_init(Fov_original,error=error) -! CALL cp_dbcsr_create(Fov_original,template=Fov,error=error) -! CALL cp_dbcsr_copy(Fov_original,Fov,error=error) +! CALL cp_dbcsr_init(Fov_original) +! CALL cp_dbcsr_create(Fov_original,template=Fov) +! CALL cp_dbcsr_copy(Fov_original,Fov) ! ENDIF ! !!! remove diagonal blocks @@ -4955,17 +4745,17 @@ END SUBROUTINE opt_k_apply_preconditioner_blk !! !!ENDDO !!CALL cp_dbcsr_iterator_stop(iter) -!!CALL cp_dbcsr_finalize(Fov,error=error) +!!CALL cp_dbcsr_finalize(Fov) ! !!! perform svd of blocks !!!!! THIS ROUTINE WORKS ONLY ON ONE CPU AND ONLY FOR 2 MOLECULES !!! -!!CALL cp_dbcsr_init(temp_u_v_full_blk,error=error) +!!CALL cp_dbcsr_init(temp_u_v_full_blk) !!CALL cp_dbcsr_create(temp_u_v_full_blk,& !! template=almo_scf_env%matrix_vv_full_blk(ispin),& -!! matrix_type=dbcsr_type_no_symmetry,& -!! error=error) +!! matrix_type=dbcsr_type_no_symmetry) +!! !!CALL cp_dbcsr_work_create(temp_u_v_full_blk,& -!! work_mutable=.TRUE.,error=error) +!! work_mutable=.TRUE.) !!CALL cp_dbcsr_iterator_start(iter,Fov) !!DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) !! @@ -4997,14 +4787,14 @@ END SUBROUTINE opt_k_apply_preconditioner_blk !! right_vectors,iblock_col_size,WORK,LWORK,INFO) !! deallocate(WORK) !! IF( INFO.NE.0 ) THEN -!! CPErrorMessage(cp_failure_level,routineP,"DGESVD failed",error) -!! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) +!! CPErrorMessage(cp_failure_level,routineP,"DGESVD failed") +!! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !! END IF !! !! ! copy right singular vectors into a unitary matrix !! NULLIFY (p_new_block) !! CALL cp_dbcsr_reserve_block2d(temp_u_v_full_blk,iblock_col,iblock_col,p_new_block) -!! CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) +!! CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) !! p_new_block(:,:) = right_vectors(:,:) !! !! deallocate(eigenvalues) @@ -5015,66 +4805,60 @@ END SUBROUTINE opt_k_apply_preconditioner_blk !! ENDIF !!ENDDO !!CALL cp_dbcsr_iterator_stop(iter) -!!CALL cp_dbcsr_finalize(temp_u_v_full_blk,error=error) -!!!CALL cp_dbcsr_print(temp_u_v_full_blk,error=error) +!!CALL cp_dbcsr_finalize(temp_u_v_full_blk) +!!!CALL cp_dbcsr_print(temp_u_v_full_blk) !!CALL cp_dbcsr_multiply("N","T",1.0_dp,Fov,temp_u_v_full_blk,& -!! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter,& -!! error=error) -!!CALL cp_dbcsr_copy(Fov,Fov_filtered,error=error) -!!CALL cp_dbcsr_print(Fov,error=error) +!! 0.0_dp,Fov_filtered,filter_eps=almo_scf_env%eps_filter) +!! +!!CALL cp_dbcsr_copy(Fov,Fov_filtered) +!!CALL cp_dbcsr_print(Fov) ! ! !!!!!!!!!!!!!!!!!!! ! ! 2. Initialize variables ! ! ! temp space -! CALL cp_dbcsr_init(temp0_ov,error=error) +! CALL cp_dbcsr_init(temp0_ov) ! CALL cp_dbcsr_create(temp0_ov,& -! template=almo_scf_env%matrix_ov_full(ispin),& -! error=error) +! template=almo_scf_env%matrix_ov_full(ispin)) ! ! ! current unitary matrix -! CALL cp_dbcsr_init(U_blk,error=error) +! CALL cp_dbcsr_init(U_blk) ! CALL cp_dbcsr_create(U_blk,& ! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! ! unitary matrix accumulator -! CALL cp_dbcsr_init(U_blk_tot,error=error) +! CALL cp_dbcsr_init(U_blk_tot) ! CALL cp_dbcsr_create(U_blk_tot,& ! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) -! CALL cp_dbcsr_add_on_diag(U_blk_tot,1.0_dp,error=error) +! matrix_type=dbcsr_type_no_symmetry) +! CALL cp_dbcsr_add_on_diag(U_blk_tot,1.0_dp) ! -!!CALL cp_dbcsr_add_on_diag(U_blk,1.0_dp,error=error) +!!CALL cp_dbcsr_add_on_diag(U_blk,1.0_dp) !!CALL cp_dbcsr_multiply("N","T",1.0_dp,U_blk,temp_u_v_full_blk,& -!! 0.0_dp,U_blk_tot,filter_eps=almo_scf_env%eps_filter,& -!! error=error) -!!CALL cp_dbcsr_release(temp_u_v_full_blk,error=error) +!! 0.0_dp,U_blk_tot,filter_eps=almo_scf_env%eps_filter) +!! +!!CALL cp_dbcsr_release(temp_u_v_full_blk) ! ! ! init gradient -! CALL cp_dbcsr_init(grad_blk,error=error) +! CALL cp_dbcsr_init(grad_blk) ! CALL cp_dbcsr_create(grad_blk,& ! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! ! init step matrix -! CALL cp_dbcsr_init(step_blk,error=error) +! CALL cp_dbcsr_init(step_blk) ! CALL cp_dbcsr_create(step_blk,& ! template=almo_scf_env%matrix_vv_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) +! matrix_type=dbcsr_type_no_symmetry) ! ! ! "retain discarded" filter (0.0 - retain, 1.0 - discard) -! CALL cp_dbcsr_init(matrix_filter,error=error) +! CALL cp_dbcsr_init(matrix_filter) ! CALL cp_dbcsr_create(matrix_filter,& -! template=almo_scf_env%matrix_ov_full(ispin),& -! error=error) +! template=almo_scf_env%matrix_ov_full(ispin)) ! ! copy Fov into the filter matrix temporarily ! ! so we know which blocks contain significant elements -! CALL cp_dbcsr_copy(matrix_filter,Fov,error=error) +! CALL cp_dbcsr_copy(matrix_filter,Fov) ! ! ! fill out filter elements block-by-block ! CALL cp_dbcsr_iterator_start(iter,matrix_filter) @@ -5090,10 +4874,10 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! ! ENDDO ! CALL cp_dbcsr_iterator_stop(iter) -! CALL cp_dbcsr_finalize(matrix_filter,error=error) +! CALL cp_dbcsr_finalize(matrix_filter) ! ! ! apply the filter -! CALL cp_dbcsr_hadamard_product(Fov,matrix_filter,Fov_filtered,error=error) +! CALL cp_dbcsr_hadamard_product(Fov,matrix_filter,Fov_filtered) ! ! !!!!!!!!!!!!!!!!!!!!! ! ! 3. start iterative minimization of the elements to be discarded @@ -5106,16 +4890,16 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! ! !!!!!!!!!!!!!!!!!!!!!!!!! ! ! 4. compute the gradient -! CALL cp_dbcsr_set(grad_blk,0.0_dp,error) +! CALL cp_dbcsr_set(grad_blk,0.0_dp) ! ! create the diagonal blocks only -! CALL cp_dbcsr_add_on_diag(grad_blk,1.0_dp,error=error) +! CALL cp_dbcsr_add_on_diag(grad_blk,1.0_dp) ! ! CALL cp_dbcsr_multiply("T","N",2.0_dp,Fov_filtered,Fov,& ! 0.0_dp,grad_blk,retain_sparsity=.TRUE.,& -! filter_eps=almo_scf_env%eps_filter,error=error) +! filter_eps=almo_scf_env%eps_filter) ! CALL cp_dbcsr_multiply("T","N",-2.0_dp,Fov,Fov_filtered,& ! 1.0_dp,grad_blk,retain_sparsity=.TRUE.,& -! filter_eps=almo_scf_env%eps_filter,error=error) +! filter_eps=almo_scf_env%eps_filter) ! ! !!!!!!!!!!!!!!!!!!!!!!! ! ! 5. check convergence @@ -5140,21 +4924,21 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! ! get b0 <= d_f/d_alpha along grad ! !!!CALL cp_dbcsr_multiply("N","N",4.0_dp,Fov,grad_blk,& ! !!! 0.0_dp,temp0_ov,& -! !!! filter_eps=almo_scf_env%eps_filter,error=error) -! !!!CALL cp_dbcsr_trace(Fov_filtered,temp0_ov,b0,"T","N",error=error) +! !!! filter_eps=almo_scf_env%eps_filter) +! !!!CALL cp_dbcsr_trace(Fov_filtered,temp0_ov,b0,"T","N") ! ! alpha=almo_scf_env%truncate_v_trial_step_size ! ! line_search_step_last=3 ! DO line_search_step=1,line_search_step_last -! CALL cp_dbcsr_copy(step_blk,grad_blk,error=error) -! CALL cp_dbcsr_scale(step_blk,-1.0_dp*alpha,error=error) +! CALL cp_dbcsr_copy(step_blk,grad_blk) +! CALL cp_dbcsr_scale(step_blk,-1.0_dp*alpha) ! CALL generator_to_unitary(step_blk,U_blk,& -! almo_scf_env%eps_filter,error) +! almo_scf_env%eps_filter) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,Fov,U_blk,0.0_dp,temp0_ov,& -! filter_eps=almo_scf_env%eps_filter,error=error) +! filter_eps=almo_scf_env%eps_filter) ! CALL cp_dbcsr_hadamard_product(temp0_ov,matrix_filter,& -! Fov_filtered,error=error) +! Fov_filtered) ! ! obj_function_new = 0.5_dp*(cp_dbcsr_frobenius_norm(Fov_filtered))**2 ! IF (line_search_step.eq.1) THEN @@ -5196,11 +4980,11 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! ENDDO ! ! ! update Fov and U_blk_tot (use grad_blk as tmp storage) -! CALL cp_dbcsr_copy(Fov,temp0_ov,error=error) +! CALL cp_dbcsr_copy(Fov,temp0_ov) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,U_blk_tot,U_blk,& ! 0.0_dp,grad_blk,& -! filter_eps=almo_scf_env%eps_filter,error=error) -! CALL cp_dbcsr_copy(U_blk_tot,grad_blk,error=error) +! filter_eps=almo_scf_env%eps_filter) +! CALL cp_dbcsr_copy(U_blk_tot,grad_blk) ! ! ENDIF ! @@ -5229,10 +5013,10 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! IF (safe_mode) THEN ! CALL cp_dbcsr_multiply("N","N",1.0_dp,Fov_original,& ! U_blk_tot,0.0_dp,temp0_ov,& -! filter_eps=almo_scf_env%eps_filter,error=error) -!CALL cp_dbcsr_print(temp0_ov,error=error) +! filter_eps=almo_scf_env%eps_filter) +!CALL cp_dbcsr_print(temp0_ov) ! CALL cp_dbcsr_hadamard_product(temp0_ov,matrix_filter,& -! Fov_filtered,error=error) +! Fov_filtered) ! obj_function_new = 0.5_dp*(cp_dbcsr_frobenius_norm(Fov_filtered))**2 ! ! IF (unit_nr>0) THEN @@ -5242,41 +5026,40 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! CALL m_flush(unit_nr) ! ENDIF ! -! CALL cp_dbcsr_release(Fov_original,error) +! CALL cp_dbcsr_release(Fov_original) ! ENDIF ! -! CALL cp_dbcsr_release(temp0_ov,error=error) -! CALL cp_dbcsr_release(U_blk,error=error) -! CALL cp_dbcsr_release(grad_blk,error=error) -! CALL cp_dbcsr_release(step_blk,error=error) -! CALL cp_dbcsr_release(matrix_filter,error=error) -! CALL cp_dbcsr_release(Fov,error=error) -! CALL cp_dbcsr_release(Fov_filtered,error=error) +! CALL cp_dbcsr_release(temp0_ov) +! CALL cp_dbcsr_release(U_blk) +! CALL cp_dbcsr_release(grad_blk) +! CALL cp_dbcsr_release(step_blk) +! CALL cp_dbcsr_release(matrix_filter) +! CALL cp_dbcsr_release(Fov) +! CALL cp_dbcsr_release(Fov_filtered) ! ! ! compute rotated virtual orbitals -! CALL cp_dbcsr_init(v_full_tmp,error=error) +! CALL cp_dbcsr_init(v_full_tmp) ! CALL cp_dbcsr_create(v_full_tmp,& ! template=almo_scf_env%matrix_v_full_blk(ispin),& -! matrix_type=dbcsr_type_no_symmetry,& -! error=error) +! matrix_type=dbcsr_type_no_symmetry) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! v_full_new,& ! matrix_sigma_vv_full_sqrt_inv,0.0_dp,v_full_tmp,& -! filter_eps=almo_scf_env%eps_filter,error=error) +! filter_eps=almo_scf_env%eps_filter) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,& ! v_full_tmp,& ! U_blk_tot,0.0_dp,v_full_new,& -! filter_eps=almo_scf_env%eps_filter,error=error) +! filter_eps=almo_scf_env%eps_filter) ! -! CALL cp_dbcsr_release(matrix_sigma_vv_full_sqrt_inv,error=error) -! CALL cp_dbcsr_release(v_full_tmp,error=error) -! CALL cp_dbcsr_release(U_blk_tot,error=error) +! CALL cp_dbcsr_release(matrix_sigma_vv_full_sqrt_inv) +! CALL cp_dbcsr_release(v_full_tmp) +! CALL cp_dbcsr_release(U_blk_tot) ! !!!!! orthogonalized virtuals are not blocked ! ! copy new virtuals into the truncated matrix ! !CALL cp_dbcsr_work_create(almo_scf_env%matrix_v_blk(ispin),& ! CALL cp_dbcsr_work_create(almo_scf_env%matrix_v(ispin),& -! work_mutable=.TRUE.,error=error) +! work_mutable=.TRUE.) ! CALL cp_dbcsr_iterator_start(iter,v_full_new) ! DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) ! @@ -5289,16 +5072,16 @@ END SUBROUTINE opt_k_apply_preconditioner_blk ! !CALL cp_dbcsr_reserve_block2d(almo_scf_env%matrix_v_blk(ispin),& ! CALL cp_dbcsr_reserve_block2d(almo_scf_env%matrix_v(ispin),& ! iblock_row,iblock_col,p_new_block) -! CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) -! CPPrecondition(retained_v.gt.0,cp_failure_level,routineP,error,failure) +! CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) +! CPPrecondition(retained_v.gt.0,cp_failure_level,routineP,failure) ! p_new_block(:,:) = data_p(:,1:retained_v) ! ! ENDDO ! iterator ! CALL cp_dbcsr_iterator_stop(iter) -! !!CALL cp_dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin),error=error) -! CALL cp_dbcsr_finalize(almo_scf_env%matrix_v(ispin),error=error) +! !!CALL cp_dbcsr_finalize(almo_scf_env%matrix_v_blk(ispin)) +! CALL cp_dbcsr_finalize(almo_scf_env%matrix_v(ispin)) ! -! CALL cp_dbcsr_release(v_full_new,error=error) +! CALL cp_dbcsr_release(v_full_new) ! ! ENDDO ! ispin ! diff --git a/src/almo_scf_qs.F b/src/almo_scf_qs.F index dcdcdf1522..9c5f7c15df 100644 --- a/src/almo_scf_qs.F +++ b/src/almo_scf_qs.F @@ -102,14 +102,13 @@ MODULE almo_scf_qs !> \param symmetry_new ... !> \param spin_key ... !> \param init_domains ... -!> \param error ... !> \par History !> 2011.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& name_new,size_keys,symmetry_new,& - spin_key,init_domains,error) + spin_key,init_domains) TYPE(cp_dbcsr_type) :: matrix_new, matrix_qs TYPE(almo_scf_env_type), INTENT(IN) :: almo_scf_env @@ -118,7 +117,6 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& CHARACTER, INTENT(IN) :: symmetry_new INTEGER, INTENT(IN) :: spin_key LOGICAL, INTENT(IN) :: init_domains - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_almo_create', & routineP = moduleN//':'//routineN @@ -211,8 +209,8 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& ENDDO END IF ELSE - CPErrorMessage(cp_failure_level,routineP,"Illegal distribution",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Illegal distribution") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE ! this dimension is not AO @@ -248,14 +246,14 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& block_sizes_new(:)=almo_scf_env%nvirt_of_domain(:,spin_key) ENDIF ELSE - CPErrorMessage(cp_failure_level,routineP,"Illegal distribution",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Illegal distribution") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE - CPErrorMessage(cp_failure_level,routineP,"Illegal dimension",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! end choosing dim size (occ, virt) @@ -304,10 +302,10 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& reuse_arrays=.TRUE.) ! Create the matrix - CALL cp_dbcsr_init(matrix_new,error=error) + CALL cp_dbcsr_init(matrix_new) CALL cp_dbcsr_create (matrix_new, name_new,& dist_new, symmetry_new,& - row_sizes_new, col_sizes_new, reuse_arrays=.TRUE., error=error) + row_sizes_new, col_sizes_new, reuse_arrays=.TRUE.) CALL cp_dbcsr_distribution_release(dist_new) ! fill out reqired blocks with 1.0_dp to tell the dbcsr library @@ -315,7 +313,7 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& IF (init_domains) THEN mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(cp_dbcsr_distribution(matrix_new))) - CALL cp_dbcsr_work_create(matrix_new, work_mutable=.TRUE., error=error) + CALL cp_dbcsr_work_create(matrix_new, work_mutable=.TRUE.) ! startQQQ - this part of the code scales quadratically ! therefore it is replaced with a less general but linear scaling algorithm below @@ -342,8 +340,8 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& !QQQ size_keys(2)==almo_mat_dim_virt_full) then !QQQ domain_row=almo_scf_env%domain_index_of_mo_block(iblock_row) !QQQ else - !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension",error) - !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") + !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !QQQ endif !QQQ if (size_keys(2)==almo_mat_dim_aobasis) then @@ -354,8 +352,8 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& !QQQ size_keys(2)==almo_mat_dim_virt_full) then !QQQ domain_col=almo_scf_env%domain_index_of_mo_block(iblock_col) !QQQ else - !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension",error) - !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + !QQQ CPErrorMessage(cp_failure_level,routineP,"Illegal dimension") + !QQQ CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !QQQ endif !QQQ ! Finds if we need this block @@ -366,7 +364,7 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& !QQQ IF (active) THEN !QQQ NULLIFY (p_new_block) !QQQ CALL cp_dbcsr_reserve_block2d(matrix_new, iblock_row, iblock_col, p_new_block) - !QQQ CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + !QQQ CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) !QQQ p_new_block(:,:) = 1.0_dp !QQQ ENDIF @@ -390,7 +388,7 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& IF (active) THEN NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(matrix_new, iblock_row, iblock_col, p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = 1.0_dp ENDIF @@ -400,7 +398,7 @@ SUBROUTINE matrix_almo_create(matrix_new,matrix_qs,almo_scf_env,& ENDIF ! init_domains - CALL cp_dbcsr_finalize(matrix_new, error=error) + CALL cp_dbcsr_finalize(matrix_new) CALL timestop (handle) @@ -412,17 +410,15 @@ END SUBROUTINE matrix_almo_create !> \param matrix_almo ... !> \param almo_scf_env ... !> \param keep_sparsity ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE matrix_qs_to_almo(matrix_qs,matrix_almo,almo_scf_env,& - keep_sparsity,error) + keep_sparsity) TYPE(cp_dbcsr_type) :: matrix_qs, matrix_almo TYPE(almo_scf_env_type) :: almo_scf_env LOGICAL, INTENT(IN) :: keep_sparsity - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_qs_to_almo', & routineP = moduleN//':'//routineN @@ -438,14 +434,13 @@ SUBROUTINE matrix_qs_to_almo(matrix_qs,matrix_almo,almo_scf_env,& CASE(almo_mat_distr_atomic) ! automatic data_type conversion CALL cp_dbcsr_copy(matrix_almo,matrix_qs,& - keep_sparsity=keep_sparsity,error=error) + keep_sparsity=keep_sparsity) CASE(almo_mat_distr_molecular) ! desymmetrize the qs matrix - CALL cp_dbcsr_init (matrix_qs_nosym, error=error) + CALL cp_dbcsr_init (matrix_qs_nosym) CALL cp_dbcsr_create (matrix_qs_nosym, template=matrix_qs,& - matrix_type=dbcsr_type_no_symmetry, error=error) - CALL cp_dbcsr_desymmetrize (matrix_qs, matrix_qs_nosym,& - error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_desymmetrize (matrix_qs, matrix_qs_nosym) ! perform the magic complete_redistribute ! before calling complete_redistribute set all blocks to zero @@ -454,13 +449,13 @@ SUBROUTINE matrix_qs_to_almo(matrix_qs,matrix_almo,almo_scf_env,& ! in the final redistributed matrix. this is a bug in ! complete_redistribute. RZK-warning it should be later corrected by calling ! dbcsr_set to 0.0 from within complete_redistribute - CALL cp_dbcsr_set(matrix_almo, 0.0_dp, error=error) + CALL cp_dbcsr_set(matrix_almo, 0.0_dp) CALL cp_dbcsr_complete_redistribute(matrix_qs_nosym, matrix_almo,& - keep_sparsity=keep_sparsity,error=error); - CALL cp_dbcsr_release (matrix_qs_nosym, error=error) + keep_sparsity=keep_sparsity); + CALL cp_dbcsr_release (matrix_qs_nosym) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) @@ -472,15 +467,13 @@ END SUBROUTINE matrix_qs_to_almo !> \param matrix_almo ... !> \param matrix_qs ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE matrix_almo_to_qs(matrix_almo,matrix_qs,almo_scf_env,error) + SUBROUTINE matrix_almo_to_qs(matrix_almo,matrix_qs,almo_scf_env) TYPE(cp_dbcsr_type) :: matrix_almo, matrix_qs TYPE(almo_scf_env_type), INTENT(IN) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_almo_to_qs', & routineP = moduleN//':'//routineN @@ -492,32 +485,32 @@ SUBROUTINE matrix_almo_to_qs(matrix_almo,matrix_qs,almo_scf_env,error) ! RZK-warning if it's not a N(AO)xN(AO) matrix then stop ! IF (ls_mstruct%single_precision) THEN -! CALL cp_dbcsr_init (matrix_tmp, error=error) +! CALL cp_dbcsr_init (matrix_tmp) ! CALL cp_dbcsr_create (matrix_tmp, template=matrix_ls,& -! data_type=dbcsr_type_real_8, error=error) -! CALL cp_dbcsr_copy (matrix_tmp, matrix_ls, error=error) +! data_type=dbcsr_type_real_8) +! CALL cp_dbcsr_copy (matrix_tmp, matrix_ls) ! ENDIF SELECT CASE(almo_scf_env%mat_distr_aos) CASE(almo_mat_distr_atomic) ! IF (ls_mstruct%single_precision) THEN -! CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_tmp, error=error) +! CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_tmp) ! ELSE - CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_almo, error=error) + CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_almo) ! ENDIF CASE(almo_mat_distr_molecular) - CALL cp_dbcsr_set(matrix_qs,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_qs,0.0_dp) ! IF (ls_mstruct%single_precision) THEN -! CALL cp_dbcsr_complete_redistribute(matrix_tmp, matrix_qs, keep_sparsity=.TRUE., error=error) +! CALL cp_dbcsr_complete_redistribute(matrix_tmp, matrix_qs, keep_sparsity=.TRUE.) ! ELSE - CALL cp_dbcsr_complete_redistribute(matrix_almo, matrix_qs, keep_sparsity=.TRUE., error=error) + CALL cp_dbcsr_complete_redistribute(matrix_almo, matrix_qs, keep_sparsity=.TRUE.) ! ENDIF CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! IF (ls_mstruct%single_precision) THEN -! CALL cp_dbcsr_release(matrix_tmp,error=error) +! CALL cp_dbcsr_release(matrix_tmp) ! ENDIF CALL timestop(handle) @@ -530,15 +523,13 @@ END SUBROUTINE matrix_almo_to_qs !> for the other SCF methods !> \param qs_env ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_init_qs(qs_env,almo_scf_env,error) + SUBROUTINE almo_scf_init_qs(qs_env,almo_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_init_qs', & routineP = moduleN//':'//routineN @@ -569,7 +560,7 @@ SUBROUTINE almo_scf_init_qs(qs_env,almo_scf_env,error) CALL timeset(routineN,handle) NULLIFY(rho, sab_orb, rho_ao) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -592,26 +583,25 @@ SUBROUTINE almo_scf_init_qs(qs_env,almo_scf_env,error) nelectron_spin=nelectron_spin,& mscfg_env=mscfg_env,& rho=rho,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) - CPPostcondition(ASSOCIATED(mscfg_env),cp_failure_level,routineP,error,failure) + CALL qs_rho_get(rho, rho_ao=rho_ao) + CPPostcondition(ASSOCIATED(mscfg_env),cp_failure_level,routineP,failure) nspin=dft_control%nspins ! create matrix_ks if necessary IF (.NOT.ASSOCIATED(matrix_ks)) THEN - CALL cp_dbcsr_allocate_matrix_set(matrix_ks,nspin,error) + CALL cp_dbcsr_allocate_matrix_set(matrix_ks,nspin) DO ispin=1,nspin ALLOCATE(matrix_ks(ispin)%matrix) - CALL cp_dbcsr_init(matrix_ks(ispin)%matrix,error=error) + CALL cp_dbcsr_init(matrix_ks(ispin)%matrix) CALL cp_dbcsr_create(matrix_ks(ispin)%matrix,& - template=matrix_s(1)%matrix,error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks(ispin)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp,error=error) + template=matrix_s(1)%matrix) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks(ispin)%matrix,sab_orb) + CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp) ENDDO - CALL set_ks_env(ks_env,matrix_ks=matrix_ks,error=error) + CALL set_ks_env(ks_env,matrix_ks=matrix_ks) ENDIF ! create an initial guess @@ -624,34 +614,34 @@ SUBROUTINE almo_scf_init_qs(qs_env,almo_scf_env,error) ! all we need to do is convert the MOs of molecules into ! the ALMO matrix taking into account different distributions CALL get_matrix_from_submatrices(mscfg_env,& - almo_scf_env%matrix_t_blk(ispin), ispin, error) + almo_scf_env%matrix_t_blk(ispin), ispin) CALL cp_dbcsr_filter(almo_scf_env%matrix_t_blk(ispin),& - almo_scf_env%eps_filter,error=error) + almo_scf_env%eps_filter) ENDDO CASE (atomic_guess) DO ispin=1,nspin - CALL cp_dbcsr_set(rho_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(rho_ao(ispin)%matrix,0.0_dp) IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%semi_empirical) THEN CALL calculate_mopac_dm(rho_ao(ispin)%matrix,& matrix_s(1)%matrix, has_unit_metric, & dft_control, particle_set, atomic_kind_set, qs_kind_set,& nspin, nelectron_spin(ispin),& - para_env, error) + para_env) ELSE CALL calculate_atomic_block_dm(rho_ao(ispin)%matrix,& matrix_s(1)%matrix, particle_set, atomic_kind_set, qs_kind_set, & - ispin, nspin, nelectron_spin(ispin), unit_nr, error) + ispin, nspin, nelectron_spin(ispin), unit_nr) ENDIF ! copy the atomic-block dm into matrix_p_blk CALL matrix_qs_to_almo(rho_ao(ispin)%matrix,& almo_scf_env%matrix_p_blk(ispin),almo_scf_env,& - .FALSE.,error) + .FALSE.) CALL cp_dbcsr_filter(almo_scf_env%matrix_p_blk(ispin),& - almo_scf_env%eps_filter,error=error) + almo_scf_env%eps_filter) ENDDO @@ -662,24 +652,24 @@ SUBROUTINE almo_scf_init_qs(qs_env,almo_scf_env,error) ! essentially producing the ionic orbitals ! while it works for simple systems this guess ! will lead to convergence problems with complex molecules - CALL almo_scf_p_blk_to_t_blk(almo_scf_env,error) + CALL almo_scf_p_blk_to_t_blk(almo_scf_env) END SELECT - CALL almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env,error) + CALL almo_scf_t_blk_to_t_blk_orthonormal(almo_scf_env) CALL almo_scf_t_blk_to_p(almo_scf_env,& - use_sigma_inv_guess=.FALSE.,error=error) + use_sigma_inv_guess=.FALSE.) DO ispin=1,nspin CALL matrix_almo_to_qs(almo_scf_env%matrix_p(ispin),& rho_ao(ispin)%matrix,& - almo_scf_env,error) + almo_scf_env) ENDDO - CALL qs_rho_update_rho(rho,qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho,qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.,& - just_energy=.FALSE.,error=error) + just_energy=.FALSE.) IF (unit_nr>0) THEN IF (almo_scf_env%almo_scf_guess.eq.molecular_guess) THEN @@ -700,16 +690,14 @@ END SUBROUTINE almo_scf_init_qs !> \param qs_env ... !> \param almo_scf_env ... !> \param energy_new ... -!> \param error ... !> \par History !> 2011.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new,error) + SUBROUTINE almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type) :: almo_scf_env REAL(KIND=dp) :: energy_new - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_dm_to_ks', & routineP = moduleN//':'//routineN @@ -724,22 +712,21 @@ SUBROUTINE almo_scf_dm_to_ks(qs_env,almo_scf_env,energy_new,error) CALL timeset(routineN,handle) nspin=almo_scf_env%nspins - CALL get_qs_env(qs_env, energy=energy, rho=rho, error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL get_qs_env(qs_env, energy=energy, rho=rho) + CALL qs_rho_get(rho, rho_ao=rho_ao) ! set the new density matrix DO ispin=1,nspin CALL matrix_almo_to_qs(almo_scf_env%matrix_p(ispin),& rho_ao(ispin)%matrix,& - almo_scf_env,& - error) + almo_scf_env) END DO ! compute the corresponding KS matrix and new energy - CALL qs_rho_update_rho(rho,qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho,qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.FALSE.,& - print_active=.TRUE., error=error) + print_active=.TRUE.) energy_new=energy%total CALL timestop(handle) @@ -750,22 +737,20 @@ END SUBROUTINE almo_scf_dm_to_ks !> \brief update qs_env total energy !> \param qs_env ... !> \param energy ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_update_ks_energy(qs_env,energy,error) + SUBROUTINE almo_scf_update_ks_energy(qs_env,energy) TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp) :: energy - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_update_ks_energy', & routineP = moduleN//':'//routineN TYPE(qs_energy_type), POINTER :: qs_energy - CALL get_qs_env(qs_env, energy=qs_energy, error=error) + CALL get_qs_env(qs_env, energy=qs_energy) qs_energy%total=energy END SUBROUTINE almo_scf_update_ks_energy @@ -774,16 +759,14 @@ END SUBROUTINE almo_scf_update_ks_energy !> \brief Creates the matrix that imposes absolute locality on MOs !> \param qs_env ... !> \param almo_scf_env ... -!> \param error ... !> \par History !> 2011.11 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) + SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(almo_scf_env_type), INTENT(INOUT) :: almo_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'almo_scf_construct_quencher', & routineP = moduleN//':'//routineN @@ -828,7 +811,7 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -842,8 +825,7 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) molecule_set=molecule_set,& cell=cell,& matrix_s=matrix_s,& - sab_almo=sab_almo,& - error=error) + sab_almo=sab_almo) ! if we are dealing with molecules get info about them IF (almo_scf_env%domain_layout_mos==almo_domain_layout_molecular .OR. & @@ -852,22 +834,21 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ALLOCATE(last_atom_of_molecule(almo_scf_env%nmolecules)) CALL get_molecule_set_info(molecule_set,& mol_to_first_atom=first_atom_of_molecule,& - mol_to_last_atom=last_atom_of_molecule,& - error=error) + mol_to_last_atom=last_atom_of_molecule) ENDIF ! create a symmetrized copy of the ao overlap - CALL cp_dbcsr_init(matrix_s_sym,error=error) + CALL cp_dbcsr_init(matrix_s_sym) CALL cp_dbcsr_create(matrix_s_sym,& template=almo_scf_env%matrix_s(1),& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_get_info(almo_scf_env%matrix_s(1),& matrix_type=sym) IF (sym.eq.dbcsr_type_no_symmetry) THEN - CALL cp_dbcsr_copy(matrix_s_sym,almo_scf_env%matrix_s(1),error=error) + CALL cp_dbcsr_copy(matrix_s_sym,almo_scf_env%matrix_s(1)) ELSE CALL cp_dbcsr_desymmetrize(almo_scf_env%matrix_s(1),& - matrix_s_sym,error=error) + matrix_s_sym) ENDIF ALLOCATE(almo_scf_env%quench_t(almo_scf_env%nspins)) @@ -884,12 +865,11 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) size_keys=(/almo_mat_dim_aobasis,almo_mat_dim_occ/),& symmetry_new=dbcsr_type_no_symmetry,& spin_key=ispin,& - init_domains=.FALSE.,& - error=error) + init_domains=.FALSE.) ! initialize distance quencher CALL cp_dbcsr_work_create(almo_scf_env%quench_t(ispin),& - work_mutable=.TRUE., error=error) + work_mutable=.TRUE.) nblkrows_tot = cp_dbcsr_nblkrows_total(almo_scf_env%quench_t(ispin)) nblkcols_tot = cp_dbcsr_nblkcols_total(almo_scf_env%quench_t(ispin)) @@ -1057,8 +1037,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ELSE ! ao domains are atomic ! ao domains are atomic / electron groups are molecular - CPErrorMessage(cp_failure_level,routineP,"Illegal: atomic domains and molecular groups",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Illegal: atomic domains and molecular groups") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF @@ -1068,8 +1048,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) IF (almo_scf_env%domain_layout_aos==almo_domain_layout_molecular) THEN ! ao domains are molecular / electron groups are atomic - CPErrorMessage(cp_failure_level,routineP,"Illegal: molecular domains and atomic groups",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Illegal: molecular domains and atomic groups") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ELSE @@ -1087,12 +1067,12 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(almo_scf_env%quench_t(ispin),& iblock_row, iblock_col, p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = 1.0_dp IF (domain_map_local_entries.ge.max_domain_neighbors*almo_scf_env%ndomains) THEN - CPErrorMessage(cp_failure_level,routineP,"weird... max_domain_neighbors is exceeded",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"weird... max_domain_neighbors is exceeded") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries+1,1)=iblock_row almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries+1,2)=iblock_col @@ -1114,8 +1094,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) CALL cp_dbcsr_get_block_p(matrix_s_sym,& iblock_row, iblock_col, p_new_block, found) IF (found) THEN - ! CPErrorMessage(cp_failure_level,routineP,"S block not found",error) - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + ! CPErrorMessage(cp_failure_level,routineP,"S block not found") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) overlap=MAXVAL(ABS(p_new_block)) ELSE overlap=0.0_dp @@ -1125,8 +1105,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ! ao domains are atomic / electron groups are molecular ! overlap_between_atom_and_molecule(atom=domain_row,molecule=domain_col) - CPErrorMessage(cp_failure_level,routineP,"atomic domains and molecular groups - NYI",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"atomic domains and molecular groups - NYI") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF @@ -1137,8 +1117,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ! ao domains are molecular / electron groups are atomic ! overlap_between_atom_and_molecule(atom=domain_col,molecule=domain_row) - CPErrorMessage(cp_failure_level,routineP,"molecular domains and atomic groups - NYI",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"molecular domains and atomic groups - NYI") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ELSE @@ -1147,8 +1127,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) CALL cp_dbcsr_get_block_p(matrix_s_sym,& iblock_row, iblock_col, p_new_block, found) IF (found) THEN - ! CPErrorMessage(cp_failure_level,routineP,"S block not found",error) - ! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + ! CPErrorMessage(cp_failure_level,routineP,"S block not found") + ! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) overlap=MAXVAL(ABS(p_new_block)) ELSE overlap=0.0_dp @@ -1183,7 +1163,7 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(almo_scf_env%quench_t(ispin),& iblock_row, iblock_col, p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) IF ( overlap.le.s0 ) THEN p_new_block(:,:) = 1.0_dp !WRITE(*,'(A15,2I7,3F8.3,E11.3)') "INTRA-BLOCKS: ",& @@ -1196,8 +1176,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) IF (ABS(p_new_block(1,1)).gt.ABS(almo_scf_env%eps_filter)) THEN IF (domain_map_local_entries.ge.max_domain_neighbors*almo_scf_env%ndomains) THEN - CPErrorMessage(cp_failure_level,routineP,"weird... max_domain_neighbors is exceeded",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"weird... max_domain_neighbors is exceeded") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries+1,1)=iblock_row almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries+1,2)=iblock_col @@ -1238,7 +1218,7 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ENDIF ENDDO ! jatom ENDDO ! iatom - CPPrecondition(contact_atom_1.gt.0,cp_failure_level,routineP,error,failure) + CPPrecondition(contact_atom_1.gt.0,cp_failure_level,routineP,failure) distance=SQRT(distance_squared) ENDIF @@ -1246,8 +1226,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ! ao domains are atomic / electron groups are molecular !distance_between_atom_and_molecule(atom=domain_row,molecule=domain_col) - CPErrorMessage(cp_failure_level,routineP,"atomic domains and molecular groups - NYI",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"atomic domains and molecular groups - NYI") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF @@ -1258,8 +1238,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ! ao domains are molecular / electron groups are atomic !distance_between_atom_and_molecule(atom=domain_col,molecule=domain_row) - CPErrorMessage(cp_failure_level,routineP,"molecular domains and atomic groups - NYI",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"molecular domains and atomic groups - NYI") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ELSE @@ -1289,8 +1269,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) CALL stop_program(routineN,moduleN,__LINE__,& "Illegal quencher_radius_type") END IF - contact1_radius = cp_unit_to_cp2k(contact1_radius,"angstrom",error=error) - contact2_radius = cp_unit_to_cp2k(contact2_radius,"angstrom",error=error) + contact1_radius = cp_unit_to_cp2k(contact1_radius,"angstrom") + contact2_radius = cp_unit_to_cp2k(contact2_radius,"angstrom") !RZK-warning the procedure is faulty for molecules: the closest contacts should be found using ! the element specific radii @@ -1319,7 +1299,7 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(almo_scf_env%quench_t(ispin),& iblock_row, iblock_col, p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) IF ( distance.le.r0 ) THEN p_new_block(:,:) = 1.0_dp !WRITE(*,'(A15,2I7,5F8.3,E11.3)') "INTRA-BLOCKS: ",& @@ -1327,7 +1307,7 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) ! contact2_radius, r0, r1, distance, p_new_block(1,1) ELSE ! remove the intermediate values from the quencher temporarily -CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) +CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) p_new_block(:,:) = 1.0_dp/(1.0_dp+EXP((r1-r0)/(r0-distance)+(r1-r0)/(r1-distance))) !WRITE(*,'(A15,2I7,5F8.3,E11.3)') "INTER-BLOCKS: ",& ! iblock_col, iblock_row, contact1_radius,& @@ -1336,8 +1316,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) IF (ABS(p_new_block(1,1)).gt.ABS(almo_scf_env%eps_filter)) THEN IF (domain_map_local_entries.ge.max_domain_neighbors*almo_scf_env%ndomains) THEN - CPErrorMessage(cp_failure_level,routineP,"weird... max_domain_neighbors is exceeded",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"weird... max_domain_neighbors is exceeded") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries+1,1)=iblock_row almo_scf_env%domain_map(ispin)%pairs(domain_map_local_entries+1,2)=iblock_col @@ -1359,17 +1339,17 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) DEALLOCATE(domain_neighbor_list) DEALLOCATE(current_number_neighbors) - CALL cp_dbcsr_finalize(almo_scf_env%quench_t(ispin),error=error) + CALL cp_dbcsr_finalize(almo_scf_env%quench_t(ispin)) !CALL cp_dbcsr_scale(almo_scf_env%quench_t(ispin),& - ! almo_scf_env%envelope_amplitude,error=error) + ! almo_scf_env%envelope_amplitude) CALL cp_dbcsr_filter(almo_scf_env%quench_t(ispin),& - almo_scf_env%eps_filter,error=error) + almo_scf_env%eps_filter) ! check that both domain_map and quench_t have the same number of entries nblks=cp_dbcsr_get_num_blocks(almo_scf_env%quench_t(ispin)) IF (nblks.ne.domain_map_local_entries) THEN - CPErrorMessage(cp_failure_level,routineP,"number of blocks is wrong",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"number of blocks is wrong") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! communicate local parts of the domain map @@ -1459,8 +1439,8 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) domain_grid(grid1,0)=domain_grid(grid1,0)+1 ELSE ! should not be here - all records must be inserted - CPErrorMessage(cp_failure_level,routineP,"all records must be inserted",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"all records must be inserted") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDDO max_neig_fails=.FALSE. @@ -1481,14 +1461,14 @@ SUBROUTINE almo_scf_construct_quencher(qs_env,almo_scf_env,error) !ENDDO ! ispin IF (almo_scf_env%nspins.eq.2) THEN CALL cp_dbcsr_copy(almo_scf_env%quench_t(2),& - almo_scf_env%quench_t(1),error=error) + almo_scf_env%quench_t(1)) almo_scf_env%domain_map(2)%pairs(:,:)=& almo_scf_env%domain_map(1)%pairs(:,:) almo_scf_env%domain_map(2)%index1(:)=& almo_scf_env%domain_map(1)%index1(:) ENDIF - CALL cp_dbcsr_release(matrix_s_sym,error=error) + CALL cp_dbcsr_release(matrix_s_sym) IF (almo_scf_env%domain_layout_mos==almo_domain_layout_molecular .OR. & almo_scf_env%domain_layout_aos==almo_domain_layout_molecular) THEN diff --git a/src/almo_scf_types.F b/src/almo_scf_types.F index d4f191efcb..e33b8eb31f 100644 --- a/src/almo_scf_types.F +++ b/src/almo_scf_types.F @@ -362,16 +362,14 @@ MODULE almo_scf_types !> \brief Prints out the options of an optimizer !> \param optimizer - options to print !> \param unit_nr - output stream -!> \param error - error !> \par History !> 2014.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE print_optimizer_options(optimizer, unit_nr, error) + SUBROUTINE print_optimizer_options(optimizer, unit_nr) TYPE(optimizer_options_type), INTENT(IN) :: optimizer INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_optimizer_options', & routineP = moduleN//':'//routineN diff --git a/src/aobasis/ai_contraction.F b/src/aobasis/ai_contraction.F index 0f78265505..8f54a02228 100644 --- a/src/aobasis/ai_contraction.F +++ b/src/aobasis/ai_contraction.F @@ -65,9 +65,8 @@ MODULE ai_contraction !> \param mb Second dimension of cb, optional !> \param fscale Optional scaling of output !> \param trans Optional transposition of output -!> \param error CP2K error reporting ! ***************************************************************************** - SUBROUTINE contraction_ab(sab,qab,ca,na,ma,cb,nb,mb,fscale,trans,error) + SUBROUTINE contraction_ab(sab,qab,ca,na,ma,cb,nb,mb,fscale,trans) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: sab @@ -81,7 +80,6 @@ SUBROUTINE contraction_ab(sab,qab,ca,na,ma,cb,nb,mb,fscale,trans,error) INTEGER, INTENT(IN), OPTIONAL :: nb, mb REAL(KIND=dp), INTENT(IN), OPTIONAL :: fscale LOGICAL, INTENT(IN), OPTIONAL :: trans - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'contraction_ab', & routineP = moduleN//':'//routineN @@ -143,7 +141,7 @@ SUBROUTINE contraction_ab(sab,qab,ca,na,ma,cb,nb,mb,fscale,trans,error) IF(PRESENT(ca) .AND. PRESENT(cb)) THEN ! Full transform ALLOCATE(work(nal,mbl),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ldw = nal CALL dgemm("N","N",nal,mbl,nbl,1.0_dp,sab(1,1),lds,cb(1,1),ldb,0.0_dp,work(1,1),ldw) IF(my_trans) THEN @@ -152,7 +150,7 @@ SUBROUTINE contraction_ab(sab,qab,ca,na,ma,cb,nb,mb,fscale,trans,error) CALL dgemm("T","N",mal,mbl,nal,fs,ca(1,1),lda,work(1,1),ldw,0.0_dp,qab(1,1),ldq) END IF DEALLOCATE(work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE IF(PRESENT(ca)) THEN IF(PRESENT(nb)) THEN nbl = nb @@ -177,7 +175,7 @@ SUBROUTINE contraction_ab(sab,qab,ca,na,ma,cb,nb,mb,fscale,trans,error) END IF ELSE ! Copy of arrays is not covered here - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE contraction_ab @@ -198,9 +196,8 @@ END SUBROUTINE contraction_ab !> \param cc Transformation matrix (index 3), optional !> \param nc First dimension of cc, optional !> \param mc Second dimension of cc, optional -!> \param error CP2K error reporting ! ***************************************************************************** - SUBROUTINE contraction_abc(sabc,qabc,ca,na,ma,cb,nb,mb,cc,nc,mc,error) + SUBROUTINE contraction_abc(sabc,qabc,ca,na,ma,cb,nb,mb,cc,nc,mc) REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(IN) :: sabc @@ -215,7 +212,6 @@ SUBROUTINE contraction_abc(sabc,qabc,ca,na,ma,cb,nb,mb,cc,nc,mc,error) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN), OPTIONAL :: cc INTEGER, INTENT(IN), OPTIONAL :: nc, mc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'contraction_abc', & routineP = moduleN//':'//routineN @@ -272,48 +268,48 @@ SUBROUTINE contraction_abc(sabc,qabc,ca,na,ma,cb,nb,mb,cc,nc,mc,error) IF(PRESENT(ca) .AND. PRESENT(cb) .AND. PRESENT(cc)) THEN ! Full transform ALLOCATE(work1(nal,nbl,ncl),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! make sure that we have contigous memory, needed for transpose algorithm work1(1:nal,1:nbl,1:ncl) = sabc(1:nal,1:nbl,1:ncl) ! ALLOCATE(work2(nbl,ncl,mal),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL dgemm("T","N",nbl*ncl,mal,nal,1.0_dp,work1(1,1,1),nal,ca(1,1),lda,0.0_dp,work2(1,1,1),nbl*ncl) ! ALLOCATE(work3(ncl,mal,mbl),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL dgemm("T","N",ncl*mal,mbl,nbl,1.0_dp,work2(1,1,1),nbl,cb(1,1),ldb,0.0_dp,work3(1,1,1),ncl*mal) ! ALLOCATE(work4(mal,mbl,mcl),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL dgemm("T","N",mal*mbl,mcl,ncl,1.0_dp,work3(1,1,1),ncl,cc(1,1),ldc,0.0_dp,work4(1,1,1),mal*mbl) ! work4(1:mal,1:mbl,1:mcl) = qabc(1:mal,1:mbl,1:mcl) ! DEALLOCATE(work1,work2,work3,work4,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ELSE IF(PRESENT(ca) .AND. PRESENT(cb)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Not implemented", error=error, error_level=cp_failure_level) + message="Not implemented",error_level=cp_failure_level) ELSE IF(PRESENT(ca) .AND. PRESENT(cc)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Not implemented", error=error, error_level=cp_failure_level) + message="Not implemented",error_level=cp_failure_level) ELSE IF(PRESENT(cb) .AND. PRESENT(cc)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Not implemented", error=error, error_level=cp_failure_level) + message="Not implemented",error_level=cp_failure_level) ELSE IF(PRESENT(ca)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Not implemented", error=error, error_level=cp_failure_level) + message="Not implemented",error_level=cp_failure_level) ELSE IF(PRESENT(cb)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Not implemented", error=error, error_level=cp_failure_level) + message="Not implemented",error_level=cp_failure_level) ELSE IF(PRESENT(cc)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Not implemented", error=error, error_level=cp_failure_level) + message="Not implemented",error_level=cp_failure_level) ELSE ! Copy of arrays is not covered here - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE contraction_abc @@ -332,9 +328,8 @@ END SUBROUTINE contraction_abc !> \param nb First dimension of cb !> \param mb Second dimension of cb !> \param trans Optional transposition of input matrix -!> \param error CP2K error reporting ! ***************************************************************************** - SUBROUTINE decontraction_ab(sab,qab,ca,na,ma,cb,nb,mb,trans,error) + SUBROUTINE decontraction_ab(sab,qab,ca,na,ma,cb,nb,mb,trans) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: sab @@ -347,7 +342,6 @@ SUBROUTINE decontraction_ab(sab,qab,ca,na,ma,cb,nb,mb,trans,error) INTENT(IN) :: cb INTEGER, INTENT(IN) :: nb, mb LOGICAL, INTENT(IN), OPTIONAL :: trans - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'decontraction_ab', & routineP = moduleN//':'//routineN @@ -372,7 +366,7 @@ SUBROUTINE decontraction_ab(sab,qab,ca,na,ma,cb,nb,mb,trans,error) ldb = SIZE(cb,1) ALLOCATE(work(na,mb),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ldw = na IF(my_trans) THEN @@ -383,7 +377,7 @@ SUBROUTINE decontraction_ab(sab,qab,ca,na,ma,cb,nb,mb,trans,error) CALL dgemm("N","T",na,nb,mb,1.0_dp,work,ldw,cb,ldb,0.0_dp,qab,ldq) DEALLOCATE(work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE decontraction_ab @@ -397,9 +391,8 @@ END SUBROUTINE decontraction_ab !> \param nb Active second dimension !> \param m Number of matrices to be traced !> \param trans Matrices are transposed (Sab and Pab) -!> \param error CP2K errror reporting ! ***************************************************************************** - SUBROUTINE force_trace_ab(force,sab,pab,na,nb,m,trans,error) + SUBROUTINE force_trace_ab(force,sab,pab,na,nb,m,trans) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: force @@ -409,7 +402,6 @@ SUBROUTINE force_trace_ab(force,sab,pab,na,nb,m,trans,error) INTENT(IN) :: pab INTEGER, INTENT(IN) :: na, nb, m LOGICAL, INTENT(IN), OPTIONAL :: trans - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_trace_ab', & routineP = moduleN//':'//routineN @@ -418,8 +410,8 @@ SUBROUTINE force_trace_ab(force,sab,pab,na,nb,m,trans,error) LOGICAL :: failure, my_trans failure = .FALSE. - CPPrecondition(m<=SIZE(SAB,3),cp_failure_level,routineP,error,failure) - CPPrecondition(m<=SIZE(force,1),cp_failure_level,routineP,error,failure) + CPPrecondition(m<=SIZE(SAB,3),cp_failure_level,routineP,failure) + CPPrecondition(m<=SIZE(force,1),cp_failure_level,routineP,failure) ! are matrices transposed? IF(PRESENT(trans)) THEN @@ -451,9 +443,8 @@ END SUBROUTINE force_trace_ab !> \param ia Starting index in qab first dimension !> \param ib Starting index in qab second dimension !> \param trans Matrices (qab and sab) are transposed -!> \param error CP2K error reporting ! ***************************************************************************** - SUBROUTINE block_add_ab(dir,sab,na,nb,qab,ia,ib,trans,error) + SUBROUTINE block_add_ab(dir,sab,na,nb,qab,ia,ib,trans) CHARACTER(LEN=*), INTENT(IN) :: dir REAL(KIND=dp), DIMENSION(:, :), & @@ -463,7 +454,6 @@ SUBROUTINE block_add_ab(dir,sab,na,nb,qab,ia,ib,trans,error) INTENT(INOUT) :: qab INTEGER, INTENT(IN) :: ia, ib LOGICAL, INTENT(IN), OPTIONAL :: trans - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'block_add_ab', & routineP = moduleN//':'//routineN @@ -498,7 +488,7 @@ SUBROUTINE block_add_ab(dir,sab,na,nb,qab,ia,ib,trans,error) sab(1:na,1:nb) = sab(1:na,1:nb) + qab(ia:ja,ib:jb) END IF ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE block_add_ab diff --git a/src/aobasis/ai_coulomb_test.F b/src/aobasis/ai_coulomb_test.F index 9832d99bf4..68a51cdf91 100644 --- a/src/aobasis/ai_coulomb_test.F +++ b/src/aobasis/ai_coulomb_test.F @@ -36,12 +36,10 @@ MODULE ai_coulomb_test ! ***************************************************************************** !> \brief ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE eri_test (iw,error) + SUBROUTINE eri_test (iw) INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eri_test', & routineP = moduleN//':'//routineN @@ -108,7 +106,7 @@ SUBROUTINE eri_test (iw,error) n = MAX(npgfa,npgfb,npgfc,npgfd) ALLOCATE(zeta(npgfa),zetb(npgfb),zetc(npgfc),zetd(npgfd),rpgf(n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) zeta(1:npgfa) = 0.5_dp zetb(1:npgfb) = 0.4_dp @@ -134,7 +132,7 @@ SUBROUTINE eri_test (iw,error) lc_min=l ll = ncoset(l) ALLOCATE(f(0:2*l+2),v(npgfa*ll,npgfc*ll,2*l+1),vac(npgfa*ll,npgfc*ll),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vac = 0._dp ii = MAX(100/(l+1)**2,1) tstart = m_walltime ( ) @@ -146,13 +144,13 @@ SUBROUTINE eri_test (iw,error) perf = REAL(ii*nco(l)**2)*1.e-6_dp * REAL(npgfa*npgfc,dp)/t WRITE(iw,'(A,T40,A,T66,F15.3)') " Performance [Mintegrals/s] ",i2c(l),perf DEALLOCATE(f,v,vac,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO END IF DEALLOCATE(zeta,zetb,zetc,zetd,rpgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL deallocate_orbital_pointers() diff --git a/src/aobasis/ai_elec_field.F b/src/aobasis/ai_elec_field.F index 68c07498f4..2defb35734 100644 --- a/src/aobasis/ai_elec_field.F +++ b/src/aobasis/ai_elec_field.F @@ -71,14 +71,13 @@ MODULE ai_elec_field !> \param ldrr1 ... !> \param ldrr2 ... !> \param rr ... -!> \param error ... !> \date 02.03.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** SUBROUTINE efg(la_max,la_min,npgfa,rpgfa,zeta,& lb_max,lb_min,npgfb,rpgfb,zetb,& - rac,rbc,rab,vab,ldrr1,ldrr2,rr,error) + rac,rbc,rab,vab,ldrr1,ldrr2,rr) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max, lb_min, npgfb @@ -90,7 +89,6 @@ SUBROUTINE efg(la_max,la_min,npgfa,rpgfa,zeta,& REAL(KIND=dp), & DIMENSION(0:ldrr1-1, ldrr2, *), & INTENT(INOUT) :: rr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'efg', & routineP = moduleN//':'//routineN @@ -152,7 +150,7 @@ SUBROUTINE efg(la_max,la_min,npgfa,rpgfa,zeta,& ! *** Calculate the reccurence relation - CALL os_rr_coul(rap,la_max+2,rbp,lb_max+2,rcp,zet,ldrr1,ldrr2,rr,error) + CALL os_rr_coul(rap,la_max+2,rbp,lb_max+2,rcp,zet,ldrr1,ldrr2,rr) ! *** Calculate the primitive electric field gradient integrals *** diff --git a/src/aobasis/ai_kinetic.F b/src/aobasis/ai_kinetic.F index 656623ebf4..60d10a7fe1 100644 --- a/src/aobasis/ai_kinetic.F +++ b/src/aobasis/ai_kinetic.F @@ -51,13 +51,12 @@ MODULE ai_kinetic !> \param rab Distance vector between centers A and B !> \param kab Kinetic energy integrals, optional !> \param dab First derivatives of Kinetic energy integrals, optional -!> \param error CP2K error reporting !> \date 07.07.2014 !> \author JGH ! ***************************************************************************** SUBROUTINE kinetic(la_max,la_min,npgfa,rpgfa,zeta,& lb_max,lb_min,npgfb,rpgfb,zetb,& - rab,kab,dab,error) + rab,kab,dab) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max, lb_min, npgfb @@ -67,7 +66,6 @@ SUBROUTINE kinetic(la_max,la_min,npgfa,rpgfa,zeta,& INTENT(INOUT), OPTIONAL :: kab REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT), OPTIONAL :: dab - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kinetic', & routineP = moduleN//':'//routineN @@ -106,7 +104,7 @@ SUBROUTINE kinetic(la_max,la_min,npgfa,rpgfa,zeta,& ! Allocate space for auxiliary integrals ALLOCATE(rr(0:ldrr-1,0:ldrr-1,3),tt(0:ldrr-1,0:ldrr-1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Number of integrals, check size of arrays ofa = ncoset(la_min-1) @@ -114,13 +112,13 @@ SUBROUTINE kinetic(la_max,la_min,npgfa,rpgfa,zeta,& na = ncoset(la_max) - ofa nb = ncoset(lb_max) - ofb IF (PRESENT(kab)) THEN - CPPrecondition((SIZE(kab,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(kab,2) >= nb*npgfb),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(kab,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(kab,2) >= nb*npgfb),cp_failure_level,routineP,failure) END IF IF (PRESENT(dab)) THEN - CPPrecondition((SIZE(dab,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dab,2) >= nb*npgfb),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dab,3) >= 3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(dab,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dab,2) >= nb*npgfb),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dab,3) >= 3),cp_failure_level,routineP,failure) END IF ! Loops over all pairs of primitive Gaussian-type functions @@ -232,7 +230,7 @@ SUBROUTINE kinetic(la_max,la_min,npgfa,rpgfa,zeta,& END DO DEALLOCATE(rr,tt,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE kinetic diff --git a/src/aobasis/ai_moments.F b/src/aobasis/ai_moments.F index 76c61f8b43..79922ffba4 100644 --- a/src/aobasis/ai_moments.F +++ b/src/aobasis/ai_moments.F @@ -1485,12 +1485,11 @@ END SUBROUTINE diff_momop !> \param pab ... !> \param forcea ... !> \param forceb ... -!> \param error ... !> \note ! ***************************************************************************** SUBROUTINE dipole_force(la_max,npgfa,zeta,rpgfa,la_min,& lb_max,npgfb,zetb,rpgfb,lb_min,& - order,rac,rbc,pab,forcea,forceb,error) + order,rac,rbc,pab,forcea,forceb) INTEGER, INTENT(IN) :: la_max, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta, rpgfa @@ -1502,7 +1501,6 @@ SUBROUTINE dipole_force(la_max,npgfa,zeta,rpgfa,la_min,& INTENT(IN) :: pab REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: forcea, forceb - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dipole_force', & routineP = moduleN//':'//routineN @@ -1516,7 +1514,7 @@ SUBROUTINE dipole_force(la_max,npgfa,zeta,rpgfa,la_min,& DIMENSION(:, :, :) :: difmab, mab failure = .FALSE. - CPPrecondition(order==1,cp_failure_level,routineP,error,failure) + CPPrecondition(order==1,cp_failure_level,routineP,failure) rab = rbc - rac rab2= SUM( rab**2 ) diff --git a/src/aobasis/ai_oneelectron.F b/src/aobasis/ai_oneelectron.F index b2250411bb..93388a8be6 100644 --- a/src/aobasis/ai_oneelectron.F +++ b/src/aobasis/ai_oneelectron.F @@ -76,14 +76,13 @@ MODULE ai_oneelectron !> \param force_a ... !> \param force_b ... !> \param fs ... -!> \param error ... !> \date May 2011 !> \author Juerg Hutter !> \version 1.0 ! ***************************************************************************** SUBROUTINE os_3center(la_max_set,la_min_set,npgfa,rpgfa,zeta,& lb_max_set,lb_min_set,npgfb,rpgfb,zetb,auxint,rpgfc,& - rab,dab,rac,dac,rbc,dbc,vab,s,pab,force_a,force_b,fs,error) + rab,dab,rac,dac,rbc,dbc,vab,s,pab,force_a,force_b,fs) INTEGER, INTENT(IN) :: la_max_set, la_min_set, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max_set, lb_min_set, npgfb @@ -107,7 +106,6 @@ SUBROUTINE os_3center(la_max_set,la_min_set,npgfa,rpgfa,zeta,& INTENT(OUT), OPTIONAL :: force_a, force_b REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT), OPTIONAL :: fs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'os_3center', & routineP = moduleN//':'//routineN @@ -129,7 +127,7 @@ SUBROUTINE os_3center(la_max_set,la_min_set,npgfa,rpgfa,zeta,& failure = .FALSE. IF (PRESENT(pab)) THEN - CPPostcondition(PRESENT(fs),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(fs),cp_failure_level,routineP,failure) IF (PRESENT(force_a)) THEN calculate_force_a = .TRUE. ELSE @@ -169,7 +167,7 @@ SUBROUTINE os_3center(la_max_set,la_min_set,npgfa,rpgfa,zeta,& ! precalculate indices for horizontal recursion ALLOCATE (iiap(ncoset(mmax),3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ma=0,mmax DO iax=0,ma DO iay=0,ma-iax @@ -543,7 +541,7 @@ SUBROUTINE os_3center(la_max_set,la_min_set,npgfa,rpgfa,zeta,& END DO DEALLOCATE (iiap,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE os_3center ! ***************************************************************************** diff --git a/src/aobasis/ai_os_rr.F b/src/aobasis/ai_os_rr.F index 70e0d8d804..1187144cca 100644 --- a/src/aobasis/ai_os_rr.F +++ b/src/aobasis/ai_os_rr.F @@ -109,12 +109,11 @@ END SUBROUTINE os_rr_ovlp !> \param ldrr1 ... !> \param ldrr2 ... !> \param rr ... -!> \param error ... !> \date 02.03.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** - SUBROUTINE os_rr_coul(rap,la_max,rbp,lb_max,rcp,zet,ldrr1,ldrr2,rr,error) + SUBROUTINE os_rr_coul(rap,la_max,rbp,lb_max,rcp,zet,ldrr1,ldrr2,rr) REAL(dp), DIMENSION(3), INTENT(IN) :: rap INTEGER, INTENT(IN) :: la_max REAL(dp), DIMENSION(3), INTENT(IN) :: rbp @@ -125,7 +124,6 @@ SUBROUTINE os_rr_coul(rap,la_max,rbp,lb_max,rcp,zet,ldrr1,ldrr2,rr,error) REAL(dp), & DIMENSION(0:ldrr1-1, ldrr2, *), & INTENT(INOUT) :: rr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'os_rr_coul', & routineP = moduleN//':'//routineN diff --git a/src/aobasis/ai_overlap.F b/src/aobasis/ai_overlap.F index ac12a7878e..01cb4c6312 100644 --- a/src/aobasis/ai_overlap.F +++ b/src/aobasis/ai_overlap.F @@ -670,13 +670,12 @@ END SUBROUTINE overlap !> \param sab Final overlap integrals !> \param dab First derivative overlap integrals !> \param ddab Second derivative overlap integrals -!> \param error CP2K error reporting !> \date 01.07.2014 !> \author JGH ! ***************************************************************************** SUBROUTINE overlap_ab(la_max,la_min,npgfa,rpgfa,zeta,& lb_max,lb_min,npgfb,rpgfb,zetb,& - rab,sab,dab,ddab,error) + rab,sab,dab,ddab) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max, lb_min, npgfb @@ -686,7 +685,6 @@ SUBROUTINE overlap_ab(la_max,la_min,npgfa,rpgfa,zeta,& INTENT(INOUT), OPTIONAL :: sab REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT), OPTIONAL :: dab, ddab - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap_ab', & routineP = moduleN//':'//routineN @@ -725,7 +723,7 @@ SUBROUTINE overlap_ab(la_max,la_min,npgfa,rpgfa,zeta,& ! Allocate space for auxiliary integrals ALLOCATE(rr(0:ldrr-1,0:ldrr-1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Number of integrals, check size of arrays ofa = ncoset(la_min-1) @@ -733,18 +731,18 @@ SUBROUTINE overlap_ab(la_max,la_min,npgfa,rpgfa,zeta,& na = ncoset(la_max) - ofa nb = ncoset(lb_max) - ofb IF (PRESENT(sab)) THEN - CPPrecondition((SIZE(sab,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(sab,2) >= nb*npgfb),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(sab,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(sab,2) >= nb*npgfb),cp_failure_level,routineP,failure) END IF IF (PRESENT(dab)) THEN - CPPrecondition((SIZE(dab,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dab,2) >= nb*npgfb),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dab,3) >= 3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(dab,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dab,2) >= nb*npgfb),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dab,3) >= 3),cp_failure_level,routineP,failure) END IF IF (PRESENT(ddab)) THEN - CPPrecondition((SIZE(ddab,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(ddab,2) >= nb*npgfb),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(ddab,3) >= 6),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(ddab,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(ddab,2) >= nb*npgfb),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(ddab,3) >= 6),cp_failure_level,routineP,failure) END IF ! Loops over all pairs of primitive Gaussian-type functions @@ -940,7 +938,7 @@ SUBROUTINE overlap_ab(la_max,la_min,npgfa,rpgfa,zeta,& END DO DEALLOCATE(rr,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_ab @@ -965,14 +963,13 @@ END SUBROUTINE overlap_ab !> \param rab Distance vector A-B !> \param saab Final overlap integrals !> \param daab First derivative overlap integrals -!> \param error CP2K error reporting !> \date 01.07.2014 !> \author JGH ! ***************************************************************************** SUBROUTINE overlap_aab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& la2_max,la2_min,npgfa2,rpgfa2,zeta2,& lb_max,lb_min,npgfb,rpgfb,zetb,& - rab,saab,daab,error) + rab,saab,daab) INTEGER, INTENT(IN) :: la1_max, la1_min, npgfa1 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa1, zeta1 INTEGER, INTENT(IN) :: la2_max, la2_min, npgfa2 @@ -984,7 +981,6 @@ SUBROUTINE overlap_aab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& INTENT(INOUT), OPTIONAL :: saab REAL(KIND=dp), DIMENSION(:, :, :, :), & INTENT(INOUT), OPTIONAL :: daab - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap_aab', & routineP = moduleN//':'//routineN @@ -1017,7 +1013,7 @@ SUBROUTINE overlap_aab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& ! Allocate space for auxiliary integrals ALLOCATE(rr(0:ldrr-1,0:ldrr-1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Number of integrals, check size of arrays ofa1 = ncoset(la1_min-1) @@ -1027,15 +1023,15 @@ SUBROUTINE overlap_aab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& na2 = ncoset(la2_max) - ofa2 nb = ncoset(lb_max) - ofb IF (PRESENT(saab)) THEN - CPPrecondition((SIZE(saab,1) >= na1*npgfa1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saab,2) >= na2*npgfa2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saab,3) >= nb*npgfb),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(saab,1) >= na1*npgfa1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saab,2) >= na2*npgfa2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saab,3) >= nb*npgfb),cp_failure_level,routineP,failure) END IF IF (PRESENT(daab)) THEN - CPPrecondition((SIZE(daab,1) >= na1*npgfa1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daab,2) >= na2*npgfa2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daab,3) >= nb*npgfb),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daab,4) >= 3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(daab,1) >= na1*npgfa1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daab,2) >= na2*npgfa2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daab,3) >= nb*npgfb),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daab,4) >= 3),cp_failure_level,routineP,failure) END IF ! Loops over all primitive Gaussian-type functions @@ -1128,7 +1124,7 @@ SUBROUTINE overlap_aab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& END DO DEALLOCATE(rr,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_aab @@ -1153,14 +1149,13 @@ END SUBROUTINE overlap_aab !> \param rab Distance vector A-B !> \param sabb Final overlap integrals !> \param dabb First derivative overlap integrals -!> \param error CP2K error reporting !> \date 01.07.2014 !> \author JGH ! ***************************************************************************** SUBROUTINE overlap_abb(la_max,la_min,npgfa,rpgfa,zeta,& lb1_max,lb1_min,npgfb1,rpgfb1,zetb1,& lb2_max,lb2_min,npgfb2,rpgfb2,zetb2,& - rab,sabb,dabb,error) + rab,sabb,dabb) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb1_max, lb1_min, npgfb1 @@ -1172,7 +1167,6 @@ SUBROUTINE overlap_abb(la_max,la_min,npgfa,rpgfa,zeta,& INTENT(INOUT), OPTIONAL :: sabb REAL(KIND=dp), DIMENSION(:, :, :, :), & INTENT(INOUT), OPTIONAL :: dabb - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap_abb', & routineP = moduleN//':'//routineN @@ -1205,7 +1199,7 @@ SUBROUTINE overlap_abb(la_max,la_min,npgfa,rpgfa,zeta,& ! Allocate space for auxiliary integrals ALLOCATE(rr(0:ldrr-1,0:ldrr-1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Number of integrals, check size of arrays ofa = ncoset(la_min-1) @@ -1215,15 +1209,15 @@ SUBROUTINE overlap_abb(la_max,la_min,npgfa,rpgfa,zeta,& nb1 = ncoset(lb1_max) - ofb1 nb2 = ncoset(lb2_max) - ofb2 IF (PRESENT(sabb)) THEN - CPPrecondition((SIZE(sabb,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(sabb,2) >= nb1*npgfb1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(sabb,3) >= nb2*npgfb2),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(sabb,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(sabb,2) >= nb1*npgfb1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(sabb,3) >= nb2*npgfb2),cp_failure_level,routineP,failure) END IF IF (PRESENT(dabb)) THEN - CPPrecondition((SIZE(dabb,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dabb,2) >= nb1*npgfb1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dabb,3) >= nb2*npgfb2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dabb,4) >= 3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(dabb,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dabb,2) >= nb1*npgfb1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dabb,3) >= nb2*npgfb2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dabb,4) >= 3),cp_failure_level,routineP,failure) END IF ! Loops over all pairs of primitive Gaussian-type functions @@ -1316,7 +1310,7 @@ SUBROUTINE overlap_abb(la_max,la_min,npgfa,rpgfa,zeta,& END DO DEALLOCATE(rr,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_abb @@ -1346,7 +1340,6 @@ END SUBROUTINE overlap_abb !> \param rab Distance vector A-B !> \param saaab Final overlap integrals !> \param daaab First derivative overlap integrals -!> \param error CP2K error reporting !> \date 01.07.2014 !> \author JGH ! ***************************************************************************** @@ -1354,7 +1347,7 @@ SUBROUTINE overlap_aaab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& la2_max,la2_min,npgfa2,rpgfa2,zeta2,& la3_max,la3_min,npgfa3,rpgfa3,zeta3,& lb_max,lb_min,npgfb,rpgfb,zetb,& - rab,saaab,daaab,error) + rab,saaab,daaab) INTEGER, INTENT(IN) :: la1_max, la1_min, npgfa1 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa1, zeta1 INTEGER, INTENT(IN) :: la2_max, la2_min, npgfa2 @@ -1369,7 +1362,6 @@ SUBROUTINE overlap_aaab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), & INTENT(INOUT), OPTIONAL :: daaab - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap_aaab', & routineP = moduleN//':'//routineN @@ -1403,7 +1395,7 @@ SUBROUTINE overlap_aaab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& ! Allocate space for auxiliary integrals ALLOCATE(rr(0:ldrr-1,0:ldrr-1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Number of integrals, check size of arrays ofa1 = ncoset(la1_min-1) @@ -1415,17 +1407,17 @@ SUBROUTINE overlap_aaab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& na3 = ncoset(la3_max) - ofa3 nb = ncoset(lb_max) - ofb IF (PRESENT(saaab)) THEN - CPPrecondition((SIZE(saaab,1) >= na1*npgfa1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saaab,2) >= na2*npgfa2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saaab,3) >= na3*npgfa3),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saaab,4) >= nb*npgfb),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(saaab,1) >= na1*npgfa1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saaab,2) >= na2*npgfa2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saaab,3) >= na3*npgfa3),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saaab,4) >= nb*npgfb),cp_failure_level,routineP,failure) END IF IF (PRESENT(daaab)) THEN - CPPrecondition((SIZE(daaab,1) >= na1*npgfa1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daaab,2) >= na2*npgfa2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daaab,3) >= na3*npgfa3),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daaab,4) >= nb*npgfb),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daaab,5) >= 3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(daaab,1) >= na1*npgfa1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daaab,2) >= na2*npgfa2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daaab,3) >= na3*npgfa3),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daaab,4) >= nb*npgfb),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daaab,5) >= 3),cp_failure_level,routineP,failure) END IF ! Loops over all primitive Gaussian-type functions @@ -1532,7 +1524,7 @@ SUBROUTINE overlap_aaab(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& END DO DEALLOCATE(rr,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_aaab ! ***************************************************************************** @@ -1561,7 +1553,6 @@ END SUBROUTINE overlap_aaab !> \param rab Distance vector A-B !> \param saabb Final overlap integrals !> \param daabb First derivative overlap integrals -!> \param error CP2K error reporting !> \date 01.07.2014 !> \author JGH ! ***************************************************************************** @@ -1569,7 +1560,7 @@ SUBROUTINE overlap_aabb(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& la2_max,la2_min,npgfa2,rpgfa2,zeta2,& lb1_max,lb1_min,npgfb1,rpgfb1,zetb1,& lb2_max,lb2_min,npgfb2,rpgfb2,zetb2,& - rab,saabb,daabb,error) + rab,saabb,daabb) INTEGER, INTENT(IN) :: la1_max, la1_min, npgfa1 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa1, zeta1 INTEGER, INTENT(IN) :: la2_max, la2_min, npgfa2 @@ -1584,7 +1575,6 @@ SUBROUTINE overlap_aabb(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), & INTENT(INOUT), OPTIONAL :: daabb - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap_aabb', & routineP = moduleN//':'//routineN @@ -1619,7 +1609,7 @@ SUBROUTINE overlap_aabb(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& ! Allocate space for auxiliary integrals ALLOCATE(rr(0:ldrr-1,0:ldrr-1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Number of integrals, check size of arrays ofa1 = ncoset(la1_min-1) @@ -1631,17 +1621,17 @@ SUBROUTINE overlap_aabb(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& nb1 = ncoset(lb1_max) - ofb1 nb2 = ncoset(lb2_max) - ofb2 IF (PRESENT(saabb)) THEN - CPPrecondition((SIZE(saabb,1) >= na1*npgfa1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saabb,2) >= na2*npgfa2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saabb,3) >= nb1*npgfb1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(saabb,4) >= nb2*npgfb2),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(saabb,1) >= na1*npgfa1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saabb,2) >= na2*npgfa2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saabb,3) >= nb1*npgfb1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(saabb,4) >= nb2*npgfb2),cp_failure_level,routineP,failure) END IF IF (PRESENT(daabb)) THEN - CPPrecondition((SIZE(daabb,1) >= na1*npgfa1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daabb,2) >= na2*npgfa2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daabb,3) >= nb1*npgfb1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daabb,4) >= nb2*npgfb2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(daabb,5) >= 3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(daabb,1) >= na1*npgfa1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daabb,2) >= na2*npgfa2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daabb,3) >= nb1*npgfb1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daabb,4) >= nb2*npgfb2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(daabb,5) >= 3),cp_failure_level,routineP,failure) END IF ! Loops over all primitive Gaussian-type functions @@ -1752,7 +1742,7 @@ SUBROUTINE overlap_aabb(la1_max,la1_min,npgfa1,rpgfa1,zeta1,& END DO DEALLOCATE(rr,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_aabb ! ***************************************************************************** @@ -1781,7 +1771,6 @@ END SUBROUTINE overlap_aabb !> \param rab Distance vector A-B !> \param sabbb Final overlap integrals !> \param dabbb First derivative overlap integrals -!> \param error CP2K error reporting !> \date 01.07.2014 !> \author JGH ! ***************************************************************************** @@ -1789,7 +1778,7 @@ SUBROUTINE overlap_abbb(la_max,la_min,npgfa,rpgfa,zeta,& lb1_max,lb1_min,npgfb1,rpgfb1,zetb1,& lb2_max,lb2_min,npgfb2,rpgfb2,zetb2,& lb3_max,lb3_min,npgfb3,rpgfb3,zetb3,& - rab,sabbb,dabbb,error) + rab,sabbb,dabbb) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb1_max, lb1_min, npgfb1 @@ -1804,7 +1793,6 @@ SUBROUTINE overlap_abbb(la_max,la_min,npgfa,rpgfa,zeta,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), & INTENT(INOUT), OPTIONAL :: dabbb - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap_abbb', & routineP = moduleN//':'//routineN @@ -1838,7 +1826,7 @@ SUBROUTINE overlap_abbb(la_max,la_min,npgfa,rpgfa,zeta,& ! Allocate space for auxiliary integrals ALLOCATE(rr(0:ldrr-1,0:ldrr-1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Number of integrals, check size of arrays ofa = ncoset(la_min-1) @@ -1850,17 +1838,17 @@ SUBROUTINE overlap_abbb(la_max,la_min,npgfa,rpgfa,zeta,& nb2 = ncoset(lb2_max) - ofb2 nb3 = ncoset(lb3_max) - ofb3 IF (PRESENT(sabbb)) THEN - CPPrecondition((SIZE(sabbb,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(sabbb,2) >= nb1*npgfb1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(sabbb,3) >= nb2*npgfb2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(sabbb,4) >= nb3*npgfb3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(sabbb,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(sabbb,2) >= nb1*npgfb1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(sabbb,3) >= nb2*npgfb2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(sabbb,4) >= nb3*npgfb3),cp_failure_level,routineP,failure) END IF IF (PRESENT(dabbb)) THEN - CPPrecondition((SIZE(dabbb,1) >= na*npgfa),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dabbb,2) >= nb1*npgfb1),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dabbb,3) >= nb2*npgfb2),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dabbb,4) >= nb3*npgfb3),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(dabbb,5) >= 3),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(dabbb,1) >= na*npgfa),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dabbb,2) >= nb1*npgfb1),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dabbb,3) >= nb2*npgfb2),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dabbb,4) >= nb3*npgfb3),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(dabbb,5) >= 3),cp_failure_level,routineP,failure) END IF ! Loops over all pairs of primitive Gaussian-type functions @@ -1967,7 +1955,7 @@ SUBROUTINE overlap_abbb(la_max,la_min,npgfa,rpgfa,zeta,& END DO DEALLOCATE(rr,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_abbb diff --git a/src/aobasis/ai_overlap3.F b/src/aobasis/ai_overlap3.F index f1062f7200..f063155293 100644 --- a/src/aobasis/ai_overlap3.F +++ b/src/aobasis/ai_overlap3.F @@ -1002,7 +1002,6 @@ END SUBROUTINE overlap3_old !> \param sabc integrals [a|b|c] !> \param sdabc derivative [da/dAi|b|c] !> \param sabdc derivative [a|b|dc/dCi] -!> \param error ... !> \par History !> 08.2011 created (JGH) !> 04.2014 added derivatives (Dorothea Golze) @@ -1012,7 +1011,7 @@ END SUBROUTINE overlap3_old SUBROUTINE overlap3_slow(la_max_set,npgfa,zeta,rpgfa,la_min_set,& lb_max_set,npgfb,zetb,rpgfb,lb_min_set,& lc_max_set,npgfc,zetc,rpgfc,lc_min_set,& - rab,dab,rac,dac,rbc,dbc,sabc,sdabc,sabdc,error) + rab,dab,rac,dac,rbc,dbc,sabc,sdabc,sabdc) INTEGER, INTENT(IN) :: la_max_set, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta, rpgfa @@ -1031,7 +1030,6 @@ SUBROUTINE overlap3_slow(la_max_set,npgfa,zeta,rpgfa,la_min_set,& INTENT(INOUT) :: sabc REAL(KIND=dp), DIMENSION(:, :, :, :), & INTENT(INOUT), OPTIONAL :: sdabc, sabdc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap3_slow', & routineP = moduleN//':'//routineN @@ -1070,16 +1068,16 @@ SUBROUTINE overlap3_slow(la_max_set,npgfa,zeta,rpgfa,la_min_set,& lc_min = MAX(0,lc_min_set-lci) ALLOCATE(s(ncoset(la_max), ncoset(lb_max),ncoset(lc_max)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) s=0._dp IF(PRESENT(sdabc)) THEN ALLOCATE(sda(ncoset(la_max), ncoset(lb_max),ncoset(lc_max),3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sda=0._dp ENDIF IF(PRESENT(sabdc)) THEN ALLOCATE(sdc(ncoset(la_max), ncoset(lb_max),ncoset(lc_max),3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sdc=0._dp ENDIF @@ -1226,14 +1224,14 @@ SUBROUTINE overlap3_slow(la_max_set,npgfa,zeta,rpgfa,la_min_set,& END DO DEALLOCATE(s,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(PRESENT(sdabc)) THEN DEALLOCATE(sda,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(PRESENT(sabdc)) THEN DEALLOCATE(sdc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle) @@ -1315,7 +1313,6 @@ END SUBROUTINE reduce_index !> \param sabc integrals [a|b|c] !> \param sdabc derivative [da/dAi|b|c] !> \param sabdc derivative [a|b|dc/dCi] -!> \param error ... !> \par History !> 05.2014 created (Dorothea Golze) !> \author Dorothea Golze @@ -1325,7 +1322,7 @@ END SUBROUTINE reduce_index SUBROUTINE overlap3(la_max_set,npgfa,zeta,rpgfa,la_min_set,& lb_max_set,npgfb,zetb,rpgfb,lb_min_set,& lc_max_set,npgfc,zetc,rpgfc,lc_min_set,& - rab,dab,rac,dac,rbc,dbc,sabc,sdabc,sabdc,error) + rab,dab,rac,dac,rbc,dbc,sabc,sdabc,sabdc) INTEGER, INTENT(IN) :: la_max_set, npgfa @@ -1345,7 +1342,6 @@ SUBROUTINE overlap3(la_max_set,npgfa,zeta,rpgfa,la_min_set,& INTENT(INOUT) :: sabc REAL(KIND=dp), DIMENSION(:, :, :, :), & INTENT(INOUT), OPTIONAL :: sdabc, sabdc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'overlap3', & routineP = moduleN//':'//routineN @@ -1386,16 +1382,16 @@ SUBROUTINE overlap3(la_max_set,npgfa,zeta,rpgfa,la_min_set,& lc_min = MAX(0,lc_min_set-lci) ALLOCATE(s(ncoset(la_max), ncoset(lb_max),ncoset(lc_max)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) s=0._dp IF(PRESENT(sdabc)) THEN ALLOCATE(sda(ncoset(la_max), ncoset(lb_max),ncoset(lc_max),3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sda=0._dp ENDIF IF(PRESENT(sabdc)) THEN ALLOCATE(sdc(ncoset(la_max), ncoset(lb_max),ncoset(lc_max),3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sdc=0._dp ENDIF @@ -2277,14 +2273,14 @@ SUBROUTINE overlap3(la_max_set,npgfa,zeta,rpgfa,la_min_set,& END DO DEALLOCATE(s,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(PRESENT(sdabc)) THEN DEALLOCATE(sda,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(PRESENT(sabdc)) THEN DEALLOCATE(sdc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle) diff --git a/src/aobasis/ai_overlap_ppl.F b/src/aobasis/ai_overlap_ppl.F index 15b0c057c7..3634ba33a6 100644 --- a/src/aobasis/ai_overlap_ppl.F +++ b/src/aobasis/ai_overlap_ppl.F @@ -78,14 +78,13 @@ MODULE ai_overlap_ppl !> \param force_a ... !> \param force_b ... !> \param fs ... -!> \param error ... !> \date May 2011 !> \author Juerg Hutter !> \version 1.0 ! ***************************************************************************** SUBROUTINE ppl_integral(la_max_set,la_min_set,npgfa,rpgfa,zeta,& lb_max_set,lb_min_set,npgfb,rpgfb,zetb,nexp_ppl,alpha_ppl,nct_ppl,cexp_ppl,rpgfc,& - rab,dab,rac,dac,rbc,dbc,vab,s,pab,force_a,force_b,fs,error) + rab,dab,rac,dac,rbc,dbc,vab,s,pab,force_a,force_b,fs) INTEGER, INTENT(IN) :: la_max_set, la_min_set, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max_set, lb_min_set, npgfb @@ -112,7 +111,6 @@ SUBROUTINE ppl_integral(la_max_set,la_min_set,npgfa,rpgfa,zeta,& INTENT(OUT), OPTIONAL :: force_a, force_b REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT), OPTIONAL :: fs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ppl_integral', & routineP = moduleN//':'//routineN @@ -127,9 +125,9 @@ SUBROUTINE ppl_integral(la_max_set,la_min_set,npgfa,rpgfa,zeta,& failure = .FALSE. IF (PRESENT(pab)) THEN - CPPostcondition(PRESENT(force_a),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(force_b),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(fs),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(force_a),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(force_b),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(fs),cp_failure_level,routineP,failure) mmax = la_max_set + lb_max_set + 2 force_a(:) = 0.0_dp force_b(:) = 0.0_dp @@ -138,7 +136,7 @@ SUBROUTINE ppl_integral(la_max_set,la_min_set,npgfa,rpgfa,zeta,& END IF ALLOCATE (auxint(0:mmax,npgfa*npgfb),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) auxint = 0._dp ! *** Calculate auxiliary integrals *** @@ -169,10 +167,10 @@ SUBROUTINE ppl_integral(la_max_set,la_min_set,npgfa,rpgfa,zeta,& CALL os_3center(la_max_set,la_min_set,npgfa,rpgfa,zeta,& lb_max_set,lb_min_set,npgfb,rpgfb,zetb,auxint,rpgfc,& - rab,dab,rac,dac,rbc,dbc,vab,s,pab,force_a,force_b,fs,error) + rab,dab,rac,dac,rbc,dbc,vab,s,pab,force_a,force_b,fs) DEALLOCATE (auxint,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE ppl_integral ! ***************************************************************************** diff --git a/src/aobasis/ai_shg_overlap.F b/src/aobasis/ai_shg_overlap.F index 84db8c7558..c4d58cbe8b 100644 --- a/src/aobasis/ai_shg_overlap.F +++ b/src/aobasis/ai_shg_overlap.F @@ -118,10 +118,9 @@ END SUBROUTINE s_overlap_ab !> \param s uncontracted [s|r^n|s] integrals !> \param calculate_forces ... !> \param calc_aba flag if [aba] or [abb] is calculated -!> \param error ... ! ***************************************************************************** SUBROUTINE s_overlap_abx(la_max,npgfa,zeta,lb_max,npgfb,zetb,lx_max,npgfx,zetx,& - rab,s,calculate_forces,calc_aba,error) + rab,s,calculate_forces,calc_aba) INTEGER, INTENT(IN) :: la_max, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta @@ -133,7 +132,6 @@ SUBROUTINE s_overlap_abx(la_max,npgfa,zeta,lb_max,npgfb,zetb,lx_max,npgfx,zetx,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), POINTER :: s LOGICAL, INTENT(IN) :: calculate_forces, calc_aba - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 's_overlap_abx', & routineP = moduleN//':'//routineN @@ -169,7 +167,7 @@ SUBROUTINE s_overlap_abx(la_max,npgfa,zeta,lb_max,npgfb,zetb,lx_max,npgfx,zetx,& ENDIF ALLOCATE(dtemp(nl+1), dsr_int(nl+1),stat=STAT) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sqrt_pi3 = SQRT(pi**3) @@ -328,7 +326,7 @@ SUBROUTINE s_overlap_abx(la_max,npgfa,zeta,lb_max,npgfb,zetb,lx_max,npgfx,zetx,& CALL cp_unimplemented_error(fromWhere=routineP, & message="SHG integrals not implemented when sum of l quantum"//& " number of orbital and ri basis larger than 11", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT @@ -339,7 +337,7 @@ SUBROUTINE s_overlap_abx(la_max,npgfa,zeta,lb_max,npgfb,zetb,lx_max,npgfx,zetx,& END DO DEALLOCATE(dtemp, dsr_int, stat=STAT) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -576,9 +574,8 @@ END SUBROUTINE get_W_matrix !> \param dWaux_mat stores the derivatives of the angular-dependent part of !> the SHG integrals !> last dimension is (1:4): cc(1), cs(2), sc(3), ss(4) -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_dW_matrix(lamax,lbmax,Waux_mat,dWaux_mat,error) + SUBROUTINE get_dW_matrix(lamax,lbmax,Waux_mat,dWaux_mat) INTEGER, DIMENSION(:), POINTER :: lamax INTEGER, INTENT(IN) :: lbmax @@ -586,7 +583,6 @@ SUBROUTINE get_dW_matrix(lamax,lbmax,Waux_mat,dWaux_mat,error) POINTER :: Waux_mat REAL(KIND=dp), & DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_dW_matrix', & routineP = moduleN//':'//routineN @@ -607,9 +603,9 @@ SUBROUTINE get_dW_matrix(lamax,lbmax,Waux_mat,dWaux_mat,error) jmax = MIN(MAXVAL(lamax),lbmax) ALLOCATE(Wam(0:jmax,4),Wamm(0:jmax,4),Wamp(0:jmax,4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Wbm(0:jmax,4),Wbmm(0:jmax,4),Wbmp(0:jmax,4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO lb = 0,lbmax nlb = nsoset_pm(lb-1) @@ -747,9 +743,9 @@ SUBROUTINE get_dW_matrix(lamax,lbmax,Waux_mat,dWaux_mat,error) ENDDO DEALLOCATE(Wam,Wamm,Wamp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Wbm,Wbmm,Wbmp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/aobasis/ai_spin_orbit.F b/src/aobasis/ai_spin_orbit.F index b8d9a2eefd..8ad6381dee 100644 --- a/src/aobasis/ai_spin_orbit.F +++ b/src/aobasis/ai_spin_orbit.F @@ -70,13 +70,12 @@ MODULE ai_spin_orbit !> \param ldrr1 ... !> \param ldrr2 ... !> \param rr ... -!> \param error ... !> \date 02.03.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** SUBROUTINE pso(la_max,la_min,npgfa,rpgfa,zeta,lb_max,lb_min,npgfb,rpgfb,zetb,& - rac,rbc,rab,vab,ldrr1,ldrr2,rr,error) + rac,rbc,rab,vab,ldrr1,ldrr2,rr) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max, lb_min, npgfb @@ -88,7 +87,6 @@ SUBROUTINE pso(la_max,la_min,npgfa,rpgfa,zeta,lb_max,lb_min,npgfb,rpgfb,zetb,& REAL(dp), & DIMENSION(0:ldrr1-1, ldrr2, *), & INTENT(INOUT) :: rr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pso', & routineP = moduleN//':'//routineN @@ -142,7 +140,7 @@ SUBROUTINE pso(la_max,la_min,npgfa,rpgfa,zeta,lb_max,lb_min,npgfb,rpgfb,zetb,& ! *** Calculate the reccurence relation *** - CALL os_rr_coul(rap,la_max+1,rbp,lb_max+1,rcp,zet,ldrr1,ldrr2,rr,error) + CALL os_rr_coul(rap,la_max+1,rbp,lb_max+1,rcp,zet,ldrr1,ldrr2,rr) ! *** Calculate the primitive Fermi contact integrals *** diff --git a/src/aobasis/basis_set_container_types.F b/src/aobasis/basis_set_container_types.F index fb62ea77ea..01008f6180 100644 --- a/src/aobasis/basis_set_container_types.F +++ b/src/aobasis/basis_set_container_types.F @@ -54,12 +54,10 @@ MODULE basis_set_container_types ! ***************************************************************************** !> \brief ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE remove_basis_set_container(basis,error) + SUBROUTINE remove_basis_set_container(basis) TYPE(basis_set_container_type), & DIMENSION(:), INTENT(inout) :: basis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'remove_basis_set_container', & routineP = moduleN//':'//routineN @@ -70,7 +68,7 @@ SUBROUTINE remove_basis_set_container(basis,error) basis(i)%basis_type = "" basis(i)%basis_type_nr = 0 IF(ASSOCIATED(basis(i)%basis_set)) THEN - CALL deallocate_gto_basis_set(basis(i)%basis_set,error) + CALL deallocate_gto_basis_set(basis(i)%basis_set) END IF END DO @@ -79,17 +77,15 @@ END SUBROUTINE remove_basis_set_container ! ***************************************************************************** !> \brief ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_basis_set_container(basis,error) + SUBROUTINE init_basis_set_container(basis) TYPE(basis_set_container_type), & DIMENSION(:), INTENT(inout) :: basis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_basis_set_container', & routineP = moduleN//':'//routineN - CALL remove_basis_set_container(basis,error) + CALL remove_basis_set_container(basis) END SUBROUTINE init_basis_set_container @@ -158,14 +154,12 @@ END FUNCTION translate_basis_type !> \param container ... !> \param basis_set ... !> \param basis_set_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE add_basis_set_to_container(container,basis_set,basis_set_type,error) + SUBROUTINE add_basis_set_to_container(container,basis_set,basis_set_type) TYPE(basis_set_container_type), & DIMENSION(:), INTENT(inout) :: container TYPE(gto_basis_set_type), POINTER :: basis_set CHARACTER(len=*) :: basis_set_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_basis_set_to_container', & routineP = moduleN//':'//routineN @@ -183,7 +177,7 @@ SUBROUTINE add_basis_set_to_container(container,basis_set,basis_set_type,error) EXIT END IF END DO - CPPostcondition(success,cp_failure_level,routineP,error,failure) + CPPostcondition(success,cp_failure_level,routineP,failure) END SUBROUTINE add_basis_set_to_container @@ -192,14 +186,12 @@ END SUBROUTINE add_basis_set_to_container !> \param container ... !> \param inum ... !> \param basis_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE remove_basis_from_container(container,inum,basis_type,error) + SUBROUTINE remove_basis_from_container(container,inum,basis_type) TYPE(basis_set_container_type), & DIMENSION(:), INTENT(inout) :: container INTEGER, INTENT(IN), OPTIONAL :: inum CHARACTER(len=*), OPTIONAL :: basis_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'remove_basis_from_container', & routineP = moduleN//':'//routineN @@ -208,8 +200,8 @@ SUBROUTINE remove_basis_from_container(container,inum,basis_type,error) LOGICAL :: failure IF(PRESENT(inum)) THEN - CPPrecondition(inum <= SIZE(container),cp_failure_level,routineP,error,failure) - CPPrecondition(inum >= 1,cp_failure_level,routineP,error,failure) + CPPrecondition(inum <= SIZE(container),cp_failure_level,routineP,failure) + CPPrecondition(inum >= 1,cp_failure_level,routineP,failure) ibas = inum ELSE IF(PRESENT(basis_type)) THEN basis_nr = get_basis_type(basis_type) @@ -221,14 +213,14 @@ SUBROUTINE remove_basis_from_container(container,inum,basis_type,error) END IF END DO ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF ! IF(ibas /= 0) THEN container(ibas)%basis_type = "" container(ibas)%basis_type_nr = 0 IF(ASSOCIATED(container(ibas)%basis_set)) THEN - CALL deallocate_gto_basis_set(container(ibas)%basis_set,error) + CALL deallocate_gto_basis_set(container(ibas)%basis_set) END IF END IF ! shift other basis sets @@ -247,15 +239,13 @@ END SUBROUTINE remove_basis_from_container !> \param basis_set ... !> \param inumbas ... !> \param basis_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_basis_from_container(container,basis_set,inumbas,basis_type,error) + SUBROUTINE get_basis_from_container(container,basis_set,inumbas,basis_type) TYPE(basis_set_container_type), & DIMENSION(:), INTENT(inout) :: container TYPE(gto_basis_set_type), POINTER :: basis_set INTEGER, OPTIONAL :: inumbas CHARACTER(len=*), OPTIONAL :: basis_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_basis_from_container', & routineP = moduleN//':'//routineN @@ -264,8 +254,8 @@ SUBROUTINE get_basis_from_container(container,basis_set,inumbas,basis_type,error LOGICAL :: failure IF(PRESENT(inumbas)) THEN - CPPrecondition(inumbas <= SIZE(container),cp_failure_level,routineP,error,failure) - CPPrecondition(inumbas >= 1,cp_failure_level,routineP,error,failure) + CPPrecondition(inumbas <= SIZE(container),cp_failure_level,routineP,failure) + CPPrecondition(inumbas >= 1,cp_failure_level,routineP,failure) basis_set => container(inumbas)%basis_set IF(PRESENT(basis_type)) THEN basis_type = container(inumbas)%basis_type @@ -280,7 +270,7 @@ SUBROUTINE get_basis_from_container(container,basis_set,inumbas,basis_type,error END IF END DO ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE get_basis_from_container diff --git a/src/aobasis/basis_set_types.F b/src/aobasis/basis_set_types.F index 05f331d6e3..d2a3262093 100644 --- a/src/aobasis/basis_set_types.F +++ b/src/aobasis/basis_set_types.F @@ -139,16 +139,14 @@ MODULE basis_set_types ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_gto_basis_set(gto_basis_set, error) + SUBROUTINE allocate_gto_basis_set(gto_basis_set) ! Allocate a Gaussian-type orbital (GTO) basis set data set. ! - Creation (26.10.2000,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_gto_basis_set', & routineP = moduleN//':'//routineN @@ -157,10 +155,10 @@ SUBROUTINE allocate_gto_basis_set(gto_basis_set, error) LOGICAL :: failure failure = .FALSE. - CALL deallocate_gto_basis_set(gto_basis_set,error) + CALL deallocate_gto_basis_set(gto_basis_set) ALLOCATE (gto_basis_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (gto_basis_set%cgf_symbol) NULLIFY (gto_basis_set%first_cgf) @@ -195,16 +193,14 @@ END SUBROUTINE allocate_gto_basis_set ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_gto_basis_set(gto_basis_set, error) + SUBROUTINE deallocate_gto_basis_set(gto_basis_set) ! Deallocate a Gaussian-type orbital (GTO) basis set data set. ! - Creation (03.11.2000,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_gto_basis_set', & routineP = moduleN//':'//routineN @@ -216,62 +212,62 @@ SUBROUTINE deallocate_gto_basis_set(gto_basis_set, error) IF (ASSOCIATED(gto_basis_set)) THEN IF (ASSOCIATED(gto_basis_set%cgf_symbol)) THEN DEALLOCATE (gto_basis_set%cgf_symbol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(gto_basis_set%sgf_symbol)) THEN DEALLOCATE (gto_basis_set%sgf_symbol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE (gto_basis_set%norm_cgf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%set_radius,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%lmax,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%lmin,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%lx,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%ly,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%lz,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%m,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%ncgf_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%npgf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%nsgf_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%nshell,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%cphi,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%pgf_radius,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%sphi,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%scon,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%zet,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%first_cgf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%first_sgf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%l,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%last_cgf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%last_sgf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%n,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set%gcc,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gto_basis_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_gto_basis_set @@ -279,14 +275,12 @@ END SUBROUTINE deallocate_gto_basis_set !> \brief ... !> \param basis_set_in ... !> \param basis_set_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_gto_basis_set(basis_set_in, basis_set_out, error) + SUBROUTINE copy_gto_basis_set(basis_set_in, basis_set_out) ! Copy a Gaussian-type orbital (GTO) basis set data set. TYPE(gto_basis_set_type), POINTER :: basis_set_in, basis_set_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'copy_gto_basis_set', & routineP = moduleN//':'//routineN @@ -298,9 +292,9 @@ SUBROUTINE copy_gto_basis_set(basis_set_in, basis_set_out, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(basis_set_in),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(basis_set_in),cp_failure_level,routineP,failure) - CALL allocate_gto_basis_set(basis_set_out,error) + CALL allocate_gto_basis_set(basis_set_out) bin => basis_set_in bout => basis_set_out @@ -315,59 +309,59 @@ SUBROUTINE copy_gto_basis_set(basis_set_in, basis_set_out, error) ncgf = bin%ncgf nsgf = bin%nsgf ALLOCATE (bout%cgf_symbol(ncgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE (bout%sgf_symbol(nsgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%cgf_symbol = bin%cgf_symbol bout%sgf_symbol = bin%sgf_symbol ALLOCATE (bout%norm_cgf(ncgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%norm_cgf = bin%norm_cgf ALLOCATE (bout%set_radius(nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%set_radius = bin%set_radius ALLOCATE (bout%lmax(nset),bout%lmin(nset),bout%npgf(nset),bout%nshell(nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%lmax = bin%lmax bout%lmin = bin%lmin bout%npgf = bin%npgf bout%nshell = bin%nshell ALLOCATE (bout%lx(ncgf),bout%ly(ncgf),bout%lz(ncgf),bout%m(nsgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%lx = bin%lx bout%ly = bin%ly bout%lz = bin%lz bout%m = bin%m ALLOCATE (bout%ncgf_set(nset),bout%nsgf_set(nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%ncgf_set = bin%ncgf_set bout%nsgf_set = bin%nsgf_set maxco = SIZE(bin%cphi,1) ALLOCATE (bout%cphi(maxco,ncgf),bout%sphi(maxco,nsgf),bout%scon(maxco,nsgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%cphi = bin%cphi bout%sphi = bin%sphi bout%scon = bin%scon maxpgf = MAXVAL(bin%npgf) ALLOCATE (bout%pgf_radius(maxpgf,nset),bout%zet(maxpgf,nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%pgf_radius = bin%pgf_radius bout%zet = bin%zet maxshell = MAXVAL(bin%nshell) ALLOCATE (bout%first_cgf(maxshell,nset),bout%first_sgf(maxshell,nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE (bout%last_cgf(maxshell,nset),bout%last_sgf(maxshell,nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%first_cgf = bin%first_cgf bout%first_sgf = bin%first_sgf bout%last_cgf = bin%last_cgf bout%last_sgf = bin%last_sgf ALLOCATE (bout%n(maxshell,nset),bout%l(maxshell,nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%n = bin%n bout%l = bin%l ALLOCATE (bout%gcc(maxpgf,maxshell,nset),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%gcc = bin%gcc END SUBROUTINE copy_gto_basis_set @@ -376,14 +370,12 @@ END SUBROUTINE copy_gto_basis_set !> \brief ... !> \param basis_set ... !> \param basis_set_add ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE combine_basis_sets(basis_set, basis_set_add, error) + SUBROUTINE combine_basis_sets(basis_set, basis_set_add) ! Combine two Gaussian-type orbital (GTO) basis sets. TYPE(gto_basis_set_type), POINTER :: basis_set, basis_set_add - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'combine_basis_sets', & routineP = moduleN//':'//routineN @@ -397,8 +389,8 @@ SUBROUTINE combine_basis_sets(basis_set, basis_set_add, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(basis_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(basis_set_add),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(basis_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(basis_set_add),cp_failure_level,routineP,failure) bad => basis_set_add bout => basis_set @@ -433,19 +425,19 @@ SUBROUTINE combine_basis_sets(basis_set, basis_set_add, error) ncgfo = ncgf - ncgfn ALLOCATE (cgf_symbol(ncgf),sgf_symbol(nsgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) cgf_symbol(1:ncgfo) = bout%cgf_symbol(1:ncgfo) cgf_symbol(ncgfo+1:ncgf) = bad%cgf_symbol(1:ncgfn) sgf_symbol(1:nsgfo) = bout%sgf_symbol(1:nsgfo) sgf_symbol(nsgfo+1:nsgf) = bad%sgf_symbol(1:nsgfn) DEALLOCATE (bout%cgf_symbol,bout%sgf_symbol,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE (bout%cgf_symbol(ncgf),bout%sgf_symbol(nsgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) bout%cgf_symbol = cgf_symbol bout%sgf_symbol = sgf_symbol DEALLOCATE (cgf_symbol,sgf_symbol,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL reallocate(bout%lx,1,ncgf) CALL reallocate(bout%ly,1,ncgf) @@ -687,16 +679,14 @@ END SUBROUTINE get_gto_basis_set ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_aux_basis_set(gto_basis_set,error) + SUBROUTINE init_aux_basis_set(gto_basis_set) ! Initialise a Gaussian-type orbital (GTO) basis set data set. ! - Creation (06.12.2000,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_aux_basis_set', & routineP = moduleN//':'//routineN @@ -713,17 +703,17 @@ SUBROUTINE init_aux_basis_set(gto_basis_set,error) CASE ( 0 ) ! No normalisation requested CASE ( 1 ) - CALL init_norm_cgf_aux_2(gto_basis_set,error) + CALL init_norm_cgf_aux_2(gto_basis_set) CASE ( 2 ) ! WARNING this was never tested - CALL init_norm_cgf_aux(gto_basis_set,error) + CALL init_norm_cgf_aux(gto_basis_set) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,& "Normalization method not specified") END SELECT ! Initialise the transformation matrices "pgf" -> "cgf" - CALL init_cphi_and_sphi(gto_basis_set,error) + CALL init_cphi_and_sphi(gto_basis_set) CALL timestop(handle) @@ -732,9 +722,8 @@ END SUBROUTINE init_aux_basis_set ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_cphi_and_sphi(gto_basis_set,error) + SUBROUTINE init_cphi_and_sphi(gto_basis_set) ! Initialise the matrices for the transformation of primitive Cartesian ! Gaussian-type functions to contracted Cartesian (cphi) and spherical @@ -743,7 +732,6 @@ SUBROUTINE init_cphi_and_sphi(gto_basis_set,error) ! - Creation (20.09.2000,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_cphi_and_sphi', & routineP = moduleN//':'//routineN @@ -825,9 +813,8 @@ END SUBROUTINE init_cphi_and_sphi ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_norm_cgf_aux(gto_basis_set,error) + SUBROUTINE init_norm_cgf_aux(gto_basis_set) ! Initialise the normalization factors of the contracted Cartesian Gaussian ! functions, if the Gaussian functions represent charge distributions. @@ -835,7 +822,6 @@ SUBROUTINE init_norm_cgf_aux(gto_basis_set,error) ! - Creation (07.12.2000,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_norm_cgf_aux', & routineP = moduleN//':'//routineN @@ -864,11 +850,11 @@ SUBROUTINE init_norm_cgf_aux(gto_basis_set,error) END DO ALLOCATE (gaa(n,n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (vv(ncoset(ll),ncoset(ll),ll+ll+1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ff(0:ll+ll),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO iset=1,gto_basis_set%nset lmax = gto_basis_set%lmax(iset) @@ -904,18 +890,17 @@ SUBROUTINE init_norm_cgf_aux(gto_basis_set,error) END DO DEALLOCATE (vv,ff, STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gaa,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE init_norm_cgf_aux ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_norm_cgf_aux_2(gto_basis_set,error) + SUBROUTINE init_norm_cgf_aux_2(gto_basis_set) ! Initialise the normalization factors of the auxiliary Cartesian Gaussian ! functions (Kim-Gordon polarization basis) Norm = 1. @@ -923,7 +908,6 @@ SUBROUTINE init_norm_cgf_aux_2(gto_basis_set,error) ! - Creation (07.12.2000,GT) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: icgf, iset, ishell @@ -943,9 +927,8 @@ END SUBROUTINE init_norm_cgf_aux_2 ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_norm_cgf_orb(gto_basis_set,error) + SUBROUTINE init_norm_cgf_orb(gto_basis_set) ! Initialise the normalization factors of the contracted Cartesian Gaussian ! functions. @@ -953,7 +936,6 @@ SUBROUTINE init_norm_cgf_orb(gto_basis_set,error) ! - Creation (14.04.2000,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: icgf, ipgf, iset, ishell, & jpgf, l, lx, ly, lz @@ -1000,9 +982,8 @@ END SUBROUTINE init_norm_cgf_orb ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_norm_cgf_orb_den(gto_basis_set,error) + SUBROUTINE init_norm_cgf_orb_den(gto_basis_set) ! Initialise the normalization factors of the contracted Cartesian Gaussian ! functions used for frozen density representation. @@ -1010,7 +991,6 @@ SUBROUTINE init_norm_cgf_orb_den(gto_basis_set,error) ! - Creation (21.09.2002,GT) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: icgf, ipgf, iset, ishell, l REAL(KIND=dp) :: expzet, gcca, prefac, zeta @@ -1039,16 +1019,14 @@ END SUBROUTINE init_norm_cgf_orb_den ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_orb_basis_set(gto_basis_set,error) + SUBROUTINE init_orb_basis_set(gto_basis_set) ! Initialise a Gaussian-type orbital (GTO) basis set data set. ! - Creation (26.10.2000,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_orb_basis_set', & routineP = moduleN//':'//routineN @@ -1065,13 +1043,13 @@ SUBROUTINE init_orb_basis_set(gto_basis_set,error) CASE ( 0 ) ! No normalisation requested CASE ( 1 ) - CALL init_norm_cgf_orb_den(gto_basis_set,error) + CALL init_norm_cgf_orb_den(gto_basis_set) CASE ( 2 ) ! Normalise the primitive Gaussian functions - CALL normalise_gcc_orb(gto_basis_set,error) + CALL normalise_gcc_orb(gto_basis_set) ! Compute the normalization factors of the contracted Gaussian-type ! functions - CALL init_norm_cgf_orb(gto_basis_set,error) + CALL init_norm_cgf_orb(gto_basis_set) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,& "Normalization method not specified") @@ -1079,7 +1057,7 @@ SUBROUTINE init_orb_basis_set(gto_basis_set,error) ! Initialise the transformation matrices "pgf" -> "cgf" - CALL init_cphi_and_sphi(gto_basis_set,error) + CALL init_cphi_and_sphi(gto_basis_set) CALL timestop(handle) @@ -1088,9 +1066,8 @@ END SUBROUTINE init_orb_basis_set ! ***************************************************************************** !> \brief ... !> \param gto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE normalise_gcc_orb(gto_basis_set,error) + SUBROUTINE normalise_gcc_orb(gto_basis_set) ! Normalise the primitive Cartesian Gaussian functions. The normalization ! factor is included in the Gaussian contraction coefficients. @@ -1098,7 +1075,6 @@ SUBROUTINE normalise_gcc_orb(gto_basis_set,error) ! - Creation (20.08.1999,MK) TYPE(gto_basis_set_type), POINTER :: gto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ipgf, iset, ishell, l REAL(KIND=dp) :: expzet, gcca, prefac, zeta @@ -1127,10 +1103,9 @@ END SUBROUTINE normalise_gcc_orb !> \param gto_basis_set ... !> \param para_env ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& - para_env,dft_section,error) + para_env,dft_section) ! Read a Gaussian-type orbital (GTO) basis set from the database file. @@ -1140,7 +1115,6 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& TYPE(gto_basis_set_type), POINTER :: gto_basis_set TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_gto_basis_set1', & routineP = moduleN//':'//routineN @@ -1178,11 +1152,11 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& gto_basis_set%name = basis_set_name CALL section_vals_val_get(dft_section,"BASIS_SET_FILE_NAME",& - n_rep_val=nbasis,error=error) + n_rep_val=nbasis) ALLOCATE(cbasis(nbasis)) DO ibasis = 1,nbasis CALL section_vals_val_get(dft_section,"BASIS_SET_FILE_NAME",& - i_rep_val=ibasis,c_val=cbasis(ibasis),error=error) + i_rep_val=ibasis,c_val=cbasis(ibasis)) NULLIFY(parser) basis_set_file_name = cbasis(ibasis) tmp=basis_set_file_name @@ -1198,7 +1172,7 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& IF( basis_found ) EXIT basis_loop NULLIFY(parser) basis_set_file_name = cbasis(ibasis) - CALL parser_create(parser,basis_set_file_name,para_env=para_env,error=error) + CALL parser_create(parser,basis_set_file_name,para_env=para_env) bsname = basis_set_name symbol = element_symbol @@ -1245,7 +1219,7 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& IF (tmp.NE."NONE") THEN search_loop: DO - CALL parser_search_string(parser,TRIM(bsname),.TRUE.,found,line,error=error) + CALL parser_search_string(parser,TRIM(bsname),.TRUE.,found,line) IF (found) THEN CALL uppercase(symbol) CALL uppercase(bsname) @@ -1264,7 +1238,7 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& IF (match) THEN NULLIFY (gcc,l,lmax,lmin,n,npgf,nshell,zet) ! Read the basis set information - CALL parser_get_object(parser,nset,newline=.TRUE.,error=error) + CALL parser_get_object(parser,nset,newline=.TRUE.) CALL reallocate(npgf,1,nset) CALL reallocate(nshell,1,nset) @@ -1277,10 +1251,10 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& maxshell = 0 DO iset=1,nset - CALL parser_get_object(parser,n(1,iset),newline=.TRUE.,error=error) - CALL parser_get_object(parser,lmin(iset),error=error) - CALL parser_get_object(parser,lmax(iset),error=error) - CALL parser_get_object(parser,npgf(iset),error=error) + CALL parser_get_object(parser,n(1,iset),newline=.TRUE.) + CALL parser_get_object(parser,lmin(iset)) + CALL parser_get_object(parser,lmax(iset)) + CALL parser_get_object(parser,npgf(iset)) maxl = MAX(maxl,lmax(iset)) IF (npgf(iset) > maxpgf) THEN maxpgf = npgf(iset) @@ -1290,7 +1264,7 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& nshell(iset) = 0 DO lshell=lmin(iset),lmax(iset) nmin = n(1,iset) + lshell - lmin(iset) - CALL parser_get_object(parser,ishell,error=error) + CALL parser_get_object(parser,ishell) nshell(iset) = nshell(iset) + ishell IF (nshell(iset) > maxshell) THEN maxshell = nshell(iset) @@ -1304,9 +1278,9 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& END DO END DO DO ipgf=1,npgf(iset) - CALL parser_get_object(parser,zet(ipgf,iset),newline=.TRUE.,error=error) + CALL parser_get_object(parser,zet(ipgf,iset),newline=.TRUE.) DO ishell=1,nshell(iset) - CALL parser_get_object(parser,gcc(ipgf,ishell,iset),error=error) + CALL parser_get_object(parser,gcc(ipgf,ishell,iset)) END DO END DO END DO @@ -1392,10 +1366,10 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& CALL reallocate(gto_basis_set%m,1,nsgf) CALL reallocate(gto_basis_set%norm_cgf,1,ncgf) ALLOCATE (gto_basis_set%cgf_symbol(ncgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (gto_basis_set%sgf_symbol(nsgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ncgf = 0 nsgf = 0 @@ -1423,7 +1397,7 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& END DO DEALLOCATE (gcc,l,lmax,lmin,n,npgf,nshell,zet,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) basis_found = .TRUE. EXIT search_loop @@ -1435,12 +1409,12 @@ SUBROUTINE read_gto_basis_set1(element_symbol,basis_set_name,gto_basis_set,& ELSE match=.FALSE. ALLOCATE (gto_basis_set%cgf_symbol(ncgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (gto_basis_set%sgf_symbol(nsgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF - CALL parser_release(parser,error=error) + CALL parser_release(parser) END DO basis_loop @@ -1468,10 +1442,9 @@ END SUBROUTINE read_gto_basis_set1 !> \param gto_basis_set ... !> \param basis_section ... !> \param irep ... -!> \param error ... ! ***************************************************************************** SUBROUTINE read_gto_basis_set2(element_symbol,basis_type,gto_basis_set,& - basis_section,irep,error) + basis_section,irep) ! Read a Gaussian-type orbital (GTO) basis set from the database file. @@ -1483,7 +1456,6 @@ SUBROUTINE read_gto_basis_set2(element_symbol,basis_type,gto_basis_set,& TYPE(section_vals_type), OPTIONAL, & POINTER :: basis_section INTEGER :: irep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_gto_basis_set2', & routineP = moduleN//':'//routineN @@ -1555,21 +1527,21 @@ SUBROUTINE read_gto_basis_set2(element_symbol,basis_type,gto_basis_set,& CALL reallocate(gto_basis_set%norm_cgf,1,ncgf) basis_type="" - CALL section_vals_val_get(basis_section,"_SECTION_PARAMETERS_",i_rep_val=irep,c_val=basis_type,error=error) + CALL section_vals_val_get(basis_section,"_SECTION_PARAMETERS_",i_rep_val=irep,c_val=basis_type) IF(basis_type=="Orbital") basis_type="ORB" NULLIFY(list,val) - CALL section_vals_list_get(basis_section,"_DEFAULT_KEYWORD_",i_rep_section=irep,list=list,error=error) + CALL section_vals_list_get(basis_section,"_DEFAULT_KEYWORD_",i_rep_section=irep,list=list) CALL uppercase(symbol) CALL uppercase(bsname) NULLIFY (gcc,l,lmax,lmin,n,npgf,nshell,zet) ! Read the basis set information - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,& __LINE__,& "Error reading the Basis set from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)nset CALL reallocate(npgf,1,nset) @@ -1583,11 +1555,11 @@ SUBROUTINE read_gto_basis_set2(element_symbol,basis_type,gto_basis_set,& maxshell = 0 DO iset=1,nset - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,& __LINE__,& "Error reading the Basis set from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)n(1,iset) CALL remove_word(line_att) READ(line_att,*)lmin(iset) @@ -1623,11 +1595,11 @@ SUBROUTINE read_gto_basis_set2(element_symbol,basis_type,gto_basis_set,& __LINE__,& "Error reading the Basis from input file!!") DO ipgf=1,npgf(iset) - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,& __LINE__,& "Error reading the Basis set from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)zet(ipgf,iset),(gcc(ipgf,ishell,iset),ishell=1,nshell(iset)) END DO END DO @@ -1713,10 +1685,10 @@ SUBROUTINE read_gto_basis_set2(element_symbol,basis_type,gto_basis_set,& CALL reallocate(gto_basis_set%m,1,nsgf) CALL reallocate(gto_basis_set%norm_cgf,1,ncgf) ALLOCATE (gto_basis_set%cgf_symbol(ncgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (gto_basis_set%sgf_symbol(nsgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ncgf = 0 nsgf = 0 @@ -1744,7 +1716,7 @@ SUBROUTINE read_gto_basis_set2(element_symbol,basis_type,gto_basis_set,& END DO DEALLOCATE (gcc,l,lmax,lmin,n,npgf,nshell,zet,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE read_gto_basis_set2 @@ -1871,9 +1843,8 @@ END SUBROUTINE set_gto_basis_set !> \param gto_basis_set ... !> \param output_unit ... !> \param header ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_gto_basis_set(gto_basis_set,output_unit,header,error) + SUBROUTINE write_gto_basis_set(gto_basis_set,output_unit,header) ! Write a Gaussian-type orbital (GTO) basis set data set to the output ! unit. @@ -1883,7 +1854,6 @@ SUBROUTINE write_gto_basis_set(gto_basis_set,output_unit,header,error) TYPE(gto_basis_set_type), POINTER :: gto_basis_set INTEGER, INTENT(in) :: output_unit CHARACTER(len=*), OPTIONAL :: header - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ipgf, iset, ishell @@ -1939,9 +1909,8 @@ END SUBROUTINE write_gto_basis_set !> \param orb_basis_set ... !> \param output_unit ... !> \param header ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_orb_basis_set(orb_basis_set,output_unit,header,error) + SUBROUTINE write_orb_basis_set(orb_basis_set,output_unit,header) ! Write a Gaussian-type orbital (GTO) basis set data set to the output ! unit. @@ -1951,7 +1920,6 @@ SUBROUTINE write_orb_basis_set(orb_basis_set,output_unit,header,error) TYPE(gto_basis_set_type), POINTER :: orb_basis_set INTEGER, INTENT(in) :: output_unit CHARACTER(len=*), OPTIONAL :: header - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: icgf, ico, ipgf, iset, ishell @@ -2003,12 +1971,10 @@ END SUBROUTINE write_orb_basis_set ! ***************************************************************************** !> \brief ... !> \param sto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_sto_basis_set(sto_basis_set, error) + SUBROUTINE allocate_sto_basis_set(sto_basis_set) TYPE(sto_basis_set_type), POINTER :: sto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_sto_basis_set', & routineP = moduleN//':'//routineN @@ -2019,10 +1985,10 @@ SUBROUTINE allocate_sto_basis_set(sto_basis_set, error) ! ------------------------------------------------------------------------- failure = .FALSE. - CALL deallocate_sto_basis_set(sto_basis_set, error) + CALL deallocate_sto_basis_set(sto_basis_set) ALLOCATE (sto_basis_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) sto_basis_set%name="NONAME" NULLIFY (sto_basis_set%symbol) @@ -2035,12 +2001,10 @@ END SUBROUTINE allocate_sto_basis_set ! ***************************************************************************** !> \brief ... !> \param sto_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_sto_basis_set(sto_basis_set, error) + SUBROUTINE deallocate_sto_basis_set(sto_basis_set) TYPE(sto_basis_set_type), POINTER :: sto_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_sto_basis_set', & routineP = moduleN//':'//routineN @@ -2054,23 +2018,23 @@ SUBROUTINE deallocate_sto_basis_set(sto_basis_set, error) IF (ASSOCIATED(sto_basis_set)) THEN IF (ASSOCIATED(sto_basis_set%symbol)) THEN DEALLOCATE (sto_basis_set%symbol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(sto_basis_set%nq)) THEN DEALLOCATE (sto_basis_set%nq,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(sto_basis_set%lq)) THEN DEALLOCATE (sto_basis_set%lq,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(sto_basis_set%zet)) THEN DEALLOCATE (sto_basis_set%zet,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (sto_basis_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_sto_basis_set @@ -2194,14 +2158,12 @@ END SUBROUTINE set_sto_basis_set !> \param sto_basis_set ... !> \param gto_basis_set ... !> \param ngauss ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_gto_from_sto_basis(sto_basis_set,gto_basis_set,ngauss,error) + SUBROUTINE create_gto_from_sto_basis(sto_basis_set,gto_basis_set,ngauss) TYPE(sto_basis_set_type), POINTER :: sto_basis_set TYPE(gto_basis_set_type), POINTER :: gto_basis_set INTEGER, OPTIONAL :: ngauss - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gto_from_sto_basis', & routineP = moduleN//':'//routineN @@ -2222,7 +2184,7 @@ SUBROUTINE create_gto_from_sto_basis(sto_basis_set,gto_basis_set,ngauss,error) IF (ng > maxng) CALL stop_program(routineN,moduleN,__LINE__,& "Too many Gaussian primitives requested") - CALL allocate_gto_basis_set(gto_basis_set,error) + CALL allocate_gto_basis_set(gto_basis_set) CALL get_sto_basis_set(sto_basis_set,name=name,nshell=nshell,nq=nq,& lq=lq,zet=zet) @@ -2245,7 +2207,7 @@ SUBROUTINE create_gto_from_sto_basis(sto_basis_set,gto_basis_set,ngauss,error) CALL reallocate(gto_basis_set%gcc,1,ng,1,1,1,nset) DO iset=1,nset - CALL get_sto_ng ( zet(iset), ng, nq(iset), lq(iset), zetg, gcc, error ) + CALL get_sto_ng ( zet(iset), ng, nq(iset), lq(iset), zetg, gcc) gto_basis_set%lmax(iset) = lq(iset) gto_basis_set%lmin(iset) = lq(iset) gto_basis_set%npgf(iset) = ng @@ -2300,9 +2262,9 @@ SUBROUTINE create_gto_from_sto_basis(sto_basis_set,gto_basis_set,ngauss,error) CALL reallocate(gto_basis_set%m,1,nsgf) CALL reallocate(gto_basis_set%norm_cgf,1,ncgf) ALLOCATE (gto_basis_set%cgf_symbol(ncgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (gto_basis_set%sgf_symbol(nsgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ncgf = 0 nsgf = 0 diff --git a/src/aobasis/orbital_transformation_matrices.F b/src/aobasis/orbital_transformation_matrices.F index 811158fcc0..31052de87d 100644 --- a/src/aobasis/orbital_transformation_matrices.F +++ b/src/aobasis/orbital_transformation_matrices.F @@ -334,18 +334,16 @@ END SUBROUTINE deallocate_spherical_harmonics !> \brief Initialize or update the orbital transformation matrices. !> \param maxl ... !> \param output_unit ... -!> \param error ... !> \date 09.07.1999 !> \par Variables !> - maxl : Maximum angular momentum quantum number !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE init_spherical_harmonics(maxl,output_unit,error) + SUBROUTINE init_spherical_harmonics(maxl,output_unit) INTEGER, INTENT(IN) :: maxl INTEGER :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_spherical_harmonics', & routineP = moduleN//':'//routineN diff --git a/src/aobasis/soft_basis_set.F b/src/aobasis/soft_basis_set.F index d29fec6117..72591cd2b9 100644 --- a/src/aobasis/soft_basis_set.F +++ b/src/aobasis/soft_basis_set.F @@ -50,18 +50,16 @@ MODULE soft_basis_set !> \param paw_atom ... !> \param paw_type_forced ... !> \param gpw_type_forced ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** SUBROUTINE create_soft_basis(orb_basis,soft_basis,eps_fit,rc,paw_atom,& - paw_type_forced,gpw_type_forced,error) + paw_type_forced,gpw_type_forced) TYPE(gto_basis_set_type), POINTER :: orb_basis, soft_basis REAL(dp), INTENT(IN) :: eps_fit, rc LOGICAL, INTENT(OUT) :: paw_atom LOGICAL, INTENT(IN) :: paw_type_forced, & gpw_type_forced - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_soft_basis', & routineP = moduleN//':'//routineN @@ -105,7 +103,7 @@ SUBROUTINE create_soft_basis(orb_basis,soft_basis,eps_fit,rc,paw_atom,& CALL reallocate(gcc,1,maxpgf,1,maxshell,1,nset) ALLOCATE(iset_s2h(nset),stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) iset_s2h = 0 iset_s = 0 @@ -267,9 +265,9 @@ SUBROUTINE create_soft_basis(orb_basis,soft_basis,eps_fit,rc,paw_atom,& CALL reallocate(soft_basis%m,1,nsgf) CALL reallocate(soft_basis%norm_cgf,1,ncgf) ALLOCATE (soft_basis%cgf_symbol(ncgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE (soft_basis%sgf_symbol(nsgf),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ncgf = 0 nsgf = 0 @@ -300,16 +298,16 @@ SUBROUTINE create_soft_basis(orb_basis,soft_basis,eps_fit,rc,paw_atom,& soft_basis%norm_type = orb_basis%norm_type soft_basis%norm_cgf = orb_basis%norm_cgf ! *** Initialize the transformation matrices *** - CALL init_cphi_and_sphi(soft_basis,error) + CALL init_cphi_and_sphi(soft_basis) ENDIF DEALLOCATE (gcc,l,lmax,lmin,n,npgf,nshell,zet,iset_s2h,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF (.NOT. paw_atom) THEN DEALLOCATE (soft_basis,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) soft_basis => orb_basis END IF diff --git a/src/aobasis/sto_ng.F b/src/aobasis/sto_ng.F index d61a05eaf9..e2f96e83e1 100644 --- a/src/aobasis/sto_ng.F +++ b/src/aobasis/sto_ng.F @@ -43,14 +43,12 @@ MODULE sto_ng !> \param lq ... !> \param alpha ... !> \param coef ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) +SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef) REAL(KIND=dp), INTENT(IN) :: zeta INTEGER, INTENT(IN) :: n, nq, lq REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: alpha, coef - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_sto_ng', & routineP = moduleN//':'//routineN @@ -63,12 +61,12 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) na = SIZE ( alpha ) nc = SIZE ( coef ) - CPPrecondition((n >= 1 .AND. n <= 6),cp_failure_level,routineP,error,failure) - CPPrecondition((na >= n),cp_failure_level,routineP,error,failure) - CPPrecondition((nc >= n),cp_failure_level,routineP,error,failure) - CPPrecondition((zeta > 0.0_dp),cp_failure_level,routineP,error,failure) - CPPrecondition((nq >= 1),cp_failure_level,routineP,error,failure) - CPPrecondition((lq >= 0),cp_failure_level,routineP,error,failure) + CPPrecondition((n >= 1 .AND. n <= 6),cp_failure_level,routineP,failure) + CPPrecondition((na >= n),cp_failure_level,routineP,failure) + CPPrecondition((nc >= n),cp_failure_level,routineP,failure) + CPPrecondition((zeta > 0.0_dp),cp_failure_level,routineP,failure) + CPPrecondition((nq >= 1),cp_failure_level,routineP,failure) + CPPrecondition((lq >= 0),cp_failure_level,routineP,failure) m = (nq*(nq-1))/2 + lq + 1 SELECT CASE ( m ) @@ -102,7 +100,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 1.580884151e-1_dp; coef ( 5 ) = 4.164915298e-1_dp alpha( 6 ) = 6.510953954e-2_dp; coef ( 6 ) = 1.303340841e-1_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 2 ) ! 2s SELECT CASE ( n ) @@ -134,7 +132,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 9.260298399e-2_dp; coef ( 5 ) = 5.621061301e-1_dp alpha( 6 ) = 4.416183978e-2_dp; coef ( 6 ) = 1.712994697e-1_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 3 ) ! 2p SELECT CASE ( n ) @@ -166,7 +164,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 1.046655969e-1_dp; coef ( 5 ) = 4.012362861e-1_dp alpha( 6 ) = 4.948220127e-2_dp; coef ( 6 ) = 1.051855189e-1_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 4 ) ! 3s SELECT CASE ( n ) @@ -198,7 +196,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 4.797373812e-2_dp; coef ( 5 ) = 5.015351020e-1_dp alpha( 6 ) = 2.724741144e-2_dp; coef ( 6 ) = 7.223633674e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 5 ) ! 3p SELECT CASE ( n ) @@ -230,7 +228,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 6.076408893e-2_dp; coef ( 5 ) = 3.908813050e-1_dp alpha( 6 ) = 3.315424265e-2_dp; coef ( 6 ) = 7.411456232e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 6 ) ! 3d SELECT CASE ( n ) @@ -262,7 +260,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 7.877734732e-2_dp; coef ( 5 ) = 3.843100204e-1_dp alpha( 6 ) = 4.058484363e-2_dp; coef ( 6 ) = 8.902827546e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 7 ) ! 4s SELECT CASE ( n ) @@ -294,7 +292,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 3.163400284e-2_dp; coef ( 5 ) = 4.389247988e-1_dp alpha( 6 ) = 1.874093091e-2_dp; coef ( 6 ) = 2.487178756e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 8 ) ! 4p SELECT CASE ( n ) @@ -326,7 +324,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 4.958248334e-2_dp; coef ( 5 ) = 5.433958189e-1_dp alpha( 6 ) = 2.816929784e-2_dp; coef ( 6 ) = 1.204970491e-1_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 9 ) ! 4d SELECT CASE ( n ) @@ -358,7 +356,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 5.904190370e-2_dp; coef ( 5 ) = 4.621672517e-1_dp alpha( 6 ) = 3.232628887e-2_dp; coef ( 6 ) = 1.081250196e-1_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 10 ) ! 4f SELECT CASE ( n ) @@ -390,7 +388,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 6.350097171e-2_dp; coef ( 5 ) = 3.688112625e-1_dp alpha( 6 ) = 3.474556673e-2_dp; coef ( 6 ) = 7.787514504e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 11 ) ! 5s SELECT CASE ( n ) @@ -422,7 +420,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 3.669584901e-2_dp; coef ( 5 ) = 1.087619490e+0_dp alpha( 6 ) = 2.213558430e-2_dp; coef ( 6 ) = 3.103964343e-1_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 12 ) ! 5p SELECT CASE ( n ) @@ -454,7 +452,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 3.328911801e-2_dp; coef ( 5 ) = 4.768808140e-1_dp alpha( 6 ) = 2.063815019e-2_dp; coef ( 6 ) = 6.021665516e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 13 ) ! 5d SELECT CASE ( n ) @@ -486,7 +484,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 3.391202830e-2_dp; coef ( 5 ) = 2.654483467e-1_dp alpha( 6 ) = 2.108227374e-2_dp; coef ( 6 ) = 2.623132212e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 14 ) ! 5f SELECT CASE ( n ) @@ -518,7 +516,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 4.351355997e-2_dp; coef ( 5 ) = 3.205010548e-1_dp alpha( 6 ) = 2.598071843e-2_dp; coef ( 6 ) = 5.077063693e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 15 ) ! 5g SELECT CASE ( n ) @@ -550,7 +548,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 5.340032759e-2_dp; coef ( 5 ) = 3.552053926e-1_dp alpha( 6 ) = 3.057364464e-2_dp; coef ( 6 ) = 6.974153145e-2_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 16 ) ! 6s SELECT CASE ( n ) @@ -582,7 +580,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.21928060661775448_dp; coef ( 5 ) = 0.08040482815742164_dp alpha( 6 ) = 0.47255402578342814_dp; coef ( 6 ) = 0.011258177324556012_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 17 ) ! 6p SELECT CASE ( n ) @@ -614,7 +612,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.14284922158351138_dp; coef ( 5 ) = -0.1117378797434228_dp alpha( 6 ) = 0.6631101746841396_dp; coef ( 6 ) = 0.0028390610573703423_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 18 ) ! 6d SELECT CASE ( n ) @@ -646,7 +644,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.16410056143462523_dp; coef ( 5 ) = -0.065949692922377_dp alpha( 6 ) = 0.33496788346358164_dp; coef ( 6 ) = -0.01123082945384288_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 19 ) ! 6f SELECT CASE ( n ) @@ -678,7 +676,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.3258167395765562_dp; coef ( 5 ) = -0.010025342773471209_dp alpha( 6 ) = 0.7758137452357111_dp; coef ( 6 ) = -0.0013665302206626205_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 20 ) ! 6g SELECT CASE ( n ) @@ -710,7 +708,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.22639206282070937_dp; coef ( 5 ) = 0.03099725943908058_dp alpha( 6 ) = 1.4892687021530484_dp; coef ( 6 ) = -0.00018343848780163463_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 21 ) ! 6h SELECT CASE ( n ) @@ -742,7 +740,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.2621356941062822_dp; coef ( 5 ) = 0.061018224093793164_dp alpha( 6 ) = 0.5948121608710077_dp; coef ( 6 ) = 0.006618011961621055_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 22 ) ! 7s SELECT CASE ( n ) @@ -775,7 +773,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.30526699650551353_dp; coef ( 5 ) = 0.006442390493458186_dp alpha( 6 ) = 0.7613613898332257_dp; coef ( 6 ) = -0.0009736214432373223_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 23 ) ! 7p SELECT CASE ( n ) @@ -808,7 +806,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.1861966605860832_dp; coef ( 5 ) = 41.115741037337784_dp alpha( 6 ) = 0.476774875907382_dp; coef ( 6 ) = 0.0020913658772264638_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 24 ) ! 7d SELECT CASE ( n ) @@ -841,7 +839,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.15425745053701811_dp; coef ( 5 ) = -0.03241452360588799_dp alpha( 6 ) = 0.5964979973145561_dp; coef ( 6 ) = 0.0007012418324482315_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 25 ) ! 7f SELECT CASE ( n ) @@ -873,7 +871,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.15940261392199198_dp; coef ( 5 ) = -0.032377223278152595_dp alpha( 6 ) = 0.3168807735151213_dp; coef ( 6 ) = -0.004680397785899489_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 26 ) ! 7g SELECT CASE ( n ) @@ -905,7 +903,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.3353651542417124_dp; coef ( 5 ) = -0.00381264707490568_dp alpha( 6 ) = 0.8332537115987487_dp; coef ( 6 ) = -0.0002777669788215993_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 27 ) ! 7h SELECT CASE ( n ) @@ -937,7 +935,7 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.13148712880820534_dp; coef ( 5 ) = 0.09872391034903429_dp alpha( 6 ) = 0.2359872300875659_dp; coef ( 6 ) = 0.012260115931631366_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE ( 28 ) ! 7i SELECT CASE ( n ) @@ -969,10 +967,10 @@ SUBROUTINE get_sto_ng ( zeta, n, nq, lq, alpha, coef, error ) alpha( 5 ) = 0.2062966749989214_dp; coef ( 5 ) = 0.06316006418978992_dp alpha( 6 ) = 0.4401320366389093_dp; coef ( 6 ) = 0.0065607991581329616_dp CASE DEFAULT - CPErrorMessage(-100,routineP,"Illegal expansion",error) + CPErrorMessage(-100,routineP,"Illegal expansion") END SELECT CASE DEFAULT - CPErrorMessage(-101,routineP,"Illegal STO",error) + CPErrorMessage(-101,routineP,"Illegal STO") END SELECT ! scaling: a = zeta^2 * a alpha (1:n) = zeta**2 * alpha (1:n) diff --git a/src/atom.F b/src/atom.F index c23596318c..6e3784ba82 100644 --- a/src/atom.F +++ b/src/atom.F @@ -38,11 +38,9 @@ MODULE atom ! ***************************************************************************** !> \brief ... !> \param root_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_code(root_section,error) + SUBROUTINE atom_code(root_section) TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_code', & routineP = moduleN//':'//routineN @@ -56,33 +54,33 @@ SUBROUTINE atom_code(root_section,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(atom_section) - atom_section => section_vals_get_subs_vals(root_section,"ATOM",error=error) + atom_section => section_vals_get_subs_vals(root_section,"ATOM") - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log") CALL atom_header(iw) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER") - CALL atom_test(atom_section,error) + CALL atom_test(atom_section) - CALL section_vals_val_get(atom_section,"RUN_TYPE",i_val=run_type_id,error=error) + CALL section_vals_val_get(atom_section,"RUN_TYPE",i_val=run_type_id) SELECT CASE (run_type_id) CASE (atom_no_run) ! do (almost) nothing CASE (atom_energy_run) - CALL atom_energy_opt(atom_section,error) + CALL atom_energy_opt(atom_section) CASE (atom_basis_run) - CALL atom_basis_opt(atom_section,error) + CALL atom_basis_opt(atom_section) CASE (atom_pseudo_run) - CALL atom_pseudo_opt(atom_section,error) + CALL atom_pseudo_opt(atom_section) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log") CALL atom_footer(iw) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER") CALL timestop(handle) @@ -91,11 +89,9 @@ END SUBROUTINE atom_code ! ***************************************************************************** !> \brief ... !> \param atom_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_test(atom_section,error) + SUBROUTINE atom_test(atom_section) TYPE(section_vals_type), POINTER :: atom_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_test', & routineP = moduleN//':'//routineN @@ -105,8 +101,8 @@ SUBROUTINE atom_test(atom_section,error) LOGICAL :: failure failure = .FALSE. - CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=z, error=error) - CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem, error=error) + CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=z) + CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem) ie = 0 DO i=1,nelem @@ -117,7 +113,7 @@ SUBROUTINE atom_test(atom_section,error) END DO IF (ie /= z) THEN IF ( ie /= 1 .AND. z /= 1 ) THEN - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END IF END IF diff --git a/src/atom_basis.F b/src/atom_basis.F index 6ae7a612a3..e8d5fcd829 100644 --- a/src/atom_basis.F +++ b/src/atom_basis.F @@ -50,11 +50,9 @@ MODULE atom_basis ! ***************************************************************************** !> \brief ... !> \param atom_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_basis_opt(atom_section,error) + SUBROUTINE atom_basis_opt(atom_section) TYPE(section_vals_type), POINTER :: atom_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_basis_opt', & routineP = moduleN//':'//routineN @@ -86,8 +84,8 @@ SUBROUTINE atom_basis_opt(atom_section,error) CALL timeset(routineN,handle) ! What atom do we calculate - CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=zval, error=error) - CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem, error=error) + CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=zval) + CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem) zz = 0 DO i=1,nelem IF ( ptable(i)%symbol == elem ) THEN @@ -99,40 +97,40 @@ SUBROUTINE atom_basis_opt(atom_section,error) ! read and set up inofrmation on the basis sets ALLOCATE(ae_basis,pp_basis,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - basis_section => section_vals_get_subs_vals(atom_section,"AE_BASIS",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + basis_section => section_vals_get_subs_vals(atom_section,"AE_BASIS") NULLIFY(ae_basis%grid) - CALL init_atom_basis(ae_basis,basis_section,zval,"AE",error) + CALL init_atom_basis(ae_basis,basis_section,zval,"AE") NULLIFY(pp_basis%grid) - basis_section => section_vals_get_subs_vals(atom_section,"PP_BASIS",error=error) - CALL init_atom_basis(pp_basis,basis_section,zval,"PP",error) + basis_section => section_vals_get_subs_vals(atom_section,"PP_BASIS") + CALL init_atom_basis(pp_basis,basis_section,zval,"PP") ! print general and basis set information - logger => cp_error_get_logger(error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log",error=error) - IF(iw > 0) CALL atom_print_info(zval,"Atomic Basis Optimization",iw,error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER",error=error) + logger => cp_get_default_logger() + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log") + IF(iw > 0) CALL atom_print_info(zval,"Atomic Basis Optimization",iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER") ! read and setup information on the pseudopotential NULLIFY(potential_section) - potential_section => section_vals_get_subs_vals(atom_section,"POTENTIAL",error=error) + potential_section => section_vals_get_subs_vals(atom_section,"POTENTIAL") ALLOCATE(ae_pot,p_pot,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL init_atom_potential(p_pot,potential_section,zval,error) - CALL init_atom_potential(ae_pot,potential_section,-1,error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL init_atom_potential(p_pot,potential_section,zval) + CALL init_atom_potential(ae_pot,potential_section,-1) ! if the ERI's are calculated analytically, we have to precalculate them eri_c = .FALSE. - CALL section_vals_val_get(atom_section,"COULOMB_INTEGRALS", i_val=do_eric, error=error) + CALL section_vals_val_get(atom_section,"COULOMB_INTEGRALS", i_val=do_eric) IF(do_eric==do_analytic) eri_c = .TRUE. eri_e = .FALSE. - CALL section_vals_val_get(atom_section,"EXCHANGE_INTEGRALS", i_val=do_erie, error=error) + CALL section_vals_val_get(atom_section,"EXCHANGE_INTEGRALS", i_val=do_erie) IF(do_erie==do_analytic) eri_e = .TRUE. ! information on the states to be calculated - CALL section_vals_val_get(atom_section,"MAX_ANGULAR_MOMENTUM", i_val=maxl, error=error) + CALL section_vals_val_get(atom_section,"MAX_ANGULAR_MOMENTUM", i_val=maxl) maxn=0 - CALL section_vals_val_get(atom_section,"CALCULATE_STATES", i_vals=cn, error=error) + CALL section_vals_val_get(atom_section,"CALCULATE_STATES", i_vals=cn) DO in = 1, MIN(SIZE(cn),4) maxn(in-1) = cn(in) END DO @@ -142,46 +140,46 @@ SUBROUTINE atom_basis_opt(atom_section,error) END DO ! read optimization section - opt_section => section_vals_get_subs_vals(atom_section,"OPTIMIZATION",error=error) - CALL read_atom_opt_section(optimization,opt_section,error) + opt_section => section_vals_get_subs_vals(atom_section,"OPTIMIZATION") + CALL read_atom_opt_section(optimization,opt_section) had_ae = .FALSE. had_pp = .FALSE. ! Check for the total number of electron configurations to be calculated - CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", n_rep_val=n_rep) ! Check for the total number of method types to be calculated - method_section => section_vals_get_subs_vals(atom_section,"METHOD",error=error) - CALL section_vals_get(method_section,n_repetition=n_meth,error=error) + method_section => section_vals_get_subs_vals(atom_section,"METHOD") + CALL section_vals_get(method_section,n_repetition=n_meth) ! integrals ALLOCATE(ae_int, pp_int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE(atom_info(n_rep,n_meth),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DO in = 1, n_rep DO im = 1, n_meth NULLIFY(atom_info(in,im)%atom) - CALL create_atom_type(atom_info(in,im)%atom,error) + CALL create_atom_type(atom_info(in,im)%atom) atom_info(in,im)%atom%optimization = optimization atom_info(in,im)%atom%z = zval - xc_section => section_vals_get_subs_vals(method_section,"XC",i_rep_section=im,error=error) + xc_section => section_vals_get_subs_vals(method_section,"XC",i_rep_section=im) atom_info(in,im)%atom%xc_section => xc_section ALLOCATE(state,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ! get the electronic configuration CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", i_rep_val=in,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) ! set occupations - CALL atom_set_occupation(tmpstringlist,state%occ,state%occupation,state%multiplicity,error) + CALL atom_set_occupation(tmpstringlist,state%occ,state%occupation,state%multiplicity) state%maxl_occ = get_maxl_occ(state%occ) state%maxn_occ = get_maxn_occ(state%occ) @@ -197,93 +195,93 @@ SUBROUTINE atom_basis_opt(atom_section,error) pp_calc = ANY(INDEX(tmpstringlist(1:),"CORE") /= 0) IF ( pp_calc ) THEN ! get and set the core occupations - CALL section_vals_val_get(atom_section,"CORE", c_vals=tmpstringlist, error=error) - CALL atom_set_occupation(tmpstringlist,state%core,pocc,error=error) + CALL section_vals_val_get(atom_section,"CORE", c_vals=tmpstringlist) + CALL atom_set_occupation(tmpstringlist,state%core,pocc) zcore = zval - NINT(SUM(state%core)) - CALL set_atom(atom_info(in,im)%atom,zcore=zcore,pp_calc=.TRUE.,error=error) + CALL set_atom(atom_info(in,im)%atom,zcore=zcore,pp_calc=.TRUE.) had_pp = .TRUE. - CALL set_atom(atom_info(in,im)%atom,basis=pp_basis,potential=p_pot,error=error) + CALL set_atom(atom_info(in,im)%atom,basis=pp_basis,potential=p_pot) state%maxn_calc(:) = MIN( state%maxn_calc(:), pp_basis%nbas(:) ) - CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP, error, failure) + CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP,failure) ELSE state%core=0._dp - CALL set_atom(atom_info(in,im)%atom,zcore=zval,pp_calc=.FALSE.,error=error) + CALL set_atom(atom_info(in,im)%atom,zcore=zval,pp_calc=.FALSE.) had_ae = .TRUE. - CALL set_atom(atom_info(in,im)%atom,basis=ae_basis,potential=ae_pot,error=error) + CALL set_atom(atom_info(in,im)%atom,basis=ae_basis,potential=ae_pot) state%maxn_calc(:) = MIN( state%maxn_calc(:), ae_basis%nbas(:) ) - CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP, error, failure) + CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP,failure) END IF - CALL section_vals_val_get(method_section,"METHOD_TYPE",i_val=method,i_rep_val=im,error=error) - CALL section_vals_val_get(method_section,"RELATIVISTIC",i_val=reltyp,i_rep_section=im,error=error) - CALL set_atom(atom_info(in,im)%atom,method_type=method,relativistic=reltyp,error=error) - CALL set_atom(atom_info(in,im)%atom,state=state,error=error) + CALL section_vals_val_get(method_section,"METHOD_TYPE",i_val=method,i_rep_val=im) + CALL section_vals_val_get(method_section,"RELATIVISTIC",i_val=reltyp,i_rep_section=im) + CALL set_atom(atom_info(in,im)%atom,method_type=method,relativistic=reltyp) + CALL set_atom(atom_info(in,im)%atom,state=state) CALL set_atom(atom_info(in,im)%atom,coulomb_integral_type=do_eric,& - exchange_integral_type=do_erie,error=error) + exchange_integral_type=do_erie) IF (atom_consistent_method(method,state%multiplicity)) THEN - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%METHOD_INFO",extension=".log",error=error) - CALL atom_print_method(atom_info(in,im)%atom,iw,error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%METHOD_INFO",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%METHOD_INFO",extension=".log") + CALL atom_print_method(atom_info(in,im)%atom,iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%METHOD_INFO") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log") IF (pp_calc) THEN - IF (iw > 0) CALL atom_print_potential(p_pot,iw,error) + IF (iw > 0) CALL atom_print_potential(p_pot,iw) ELSE - IF (iw > 0) CALL atom_print_potential(ae_pot,iw,error) + IF (iw > 0) CALL atom_print_potential(ae_pot,iw) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL") ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "METHOD_TYPE and MULTIPLICITY are incompatible",& - only_ionode=.TRUE.,error=error) + only_ionode=.TRUE.) END IF NULLIFY(orbitals) mo = MAXVAL(state%maxn_calc) mb = MAXVAL(atom_info(in,im)%atom%basis%nbas) - CALL create_atom_orbs(orbitals,mb,mo,error) - CALL set_atom(atom_info(in,im)%atom,orbitals=orbitals,error=error) + CALL create_atom_orbs(orbitals,mb,mo) + CALL set_atom(atom_info(in,im)%atom,orbitals=orbitals) END DO END DO ! Start the Optimization - powell_section => section_vals_get_subs_vals(atom_section,"POWELL",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%SCF_INFO",extension=".log",error=error) - iunit = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_BASIS",extension=".log",error=error) + powell_section => section_vals_get_subs_vals(atom_section,"POWELL") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%SCF_INFO",extension=".log") + iunit = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_BASIS",extension=".log") IF ( had_ae ) THEN pp_calc = .FALSE. - CALL atom_fit_basis(atom_info,ae_basis,pp_calc,iunit,powell_section,error) + CALL atom_fit_basis(atom_info,ae_basis,pp_calc,iunit,powell_section) END IF IF ( had_pp ) THEN pp_calc = .TRUE. - CALL atom_fit_basis(atom_info,pp_basis,pp_calc,iunit,powell_section,error) + CALL atom_fit_basis(atom_info,pp_basis,pp_calc,iunit,powell_section) END IF - CALL cp_print_key_finished_output(iunit,logger,atom_section,"PRINT%FIT_BASIS",error=error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%SCF_INFO",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%BASIS_SET",extension=".log",error=error) + CALL cp_print_key_finished_output(iunit,logger,atom_section,"PRINT%FIT_BASIS") + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%SCF_INFO") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%BASIS_SET",extension=".log") IF(iw > 0) THEN - CALL atom_print_basis(ae_basis,iw," All Electron Basis",error) - CALL atom_print_basis(pp_basis,iw," Pseudopotential Basis",error) + CALL atom_print_basis(ae_basis,iw," All Electron Basis") + CALL atom_print_basis(pp_basis,iw," Pseudopotential Basis") END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%BASIS_SET",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%BASIS_SET") - CALL release_atom_basis(ae_basis,error) - CALL release_atom_basis(pp_basis,error) + CALL release_atom_basis(ae_basis) + CALL release_atom_basis(pp_basis) - CALL release_atom_potential(p_pot,error) - CALL release_atom_potential(ae_pot,error) + CALL release_atom_potential(p_pot) + CALL release_atom_potential(ae_pot) DO in = 1, n_rep DO im = 1, n_meth - CALL release_atom_type(atom_info(in,im)%atom,error) + CALL release_atom_type(atom_info(in,im)%atom) END DO END DO DEALLOCATE(atom_info,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(ae_pot,p_pot,ae_basis,pp_basis,ae_int,pp_int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL timestop(handle) diff --git a/src/atom_electronic_structure.F b/src/atom_electronic_structure.F index fa7882eba6..3c23e991a2 100644 --- a/src/atom_electronic_structure.F +++ b/src/atom_electronic_structure.F @@ -57,13 +57,11 @@ MODULE atom_electronic_structure !> \param atom ... !> \param iw ... !> \param noguess ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_atom(atom,iw,noguess,error) + SUBROUTINE calculate_atom(atom,iw,noguess) TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: iw LOGICAL, INTENT(IN), OPTIONAL :: noguess - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_atom', & routineP = moduleN//':'//routineN @@ -79,13 +77,13 @@ SUBROUTINE calculate_atom(atom,iw,noguess,error) SELECT CASE (method) CASE (do_rks_atom, do_rhf_atom) - CALL calculate_atom_restricted(atom,iw,noguess,error) + CALL calculate_atom_restricted(atom,iw,noguess) CASE (do_uks_atom, do_uhf_atom) - CALL calculate_atom_unrestricted(atom,iw,noguess,error) + CALL calculate_atom_unrestricted(atom,iw,noguess) CASE (do_rohf_atom) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT CALL timestop(handle) @@ -97,13 +95,11 @@ END SUBROUTINE calculate_atom !> \param atom ... !> \param iw ... !> \param noguess ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) + SUBROUTINE calculate_atom_restricted(atom,iw,noguess) TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: iw LOGICAL, INTENT(IN), OPTIONAL :: noguess - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_atom_restricted', & routineP = moduleN//':'//routineN @@ -133,10 +129,10 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) hf_frac = 0._dp IF (ASSOCIATED(atom%xc_section)) THEN xc_section => atom%xc_section - hfx_sections => section_vals_get_subs_vals(xc_section,"HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,error=error) + hfx_sections => section_vals_get_subs_vals(xc_section,"HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx) IF ( do_hfx ) THEN - CALL section_vals_val_get(hfx_sections,"FRACTION", r_val=hf_frac, error=error) + CALL section_vals_val_get(hfx_sections,"FRACTION", r_val=hf_frac) END IF ELSE NULLIFY(xc_section) @@ -149,23 +145,23 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) SELECT CASE (method) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_rks_atom) need_x = do_hfx need_xc = .TRUE. CASE (do_uks_atom) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_rhf_atom) need_x = .TRUE. need_xc = .FALSE. hf_frac = 1._dp CASE (do_uhf_atom) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_rohf_atom) need_x = .TRUE. need_xc = .FALSE. hf_frac = 1._dp - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT ! ZMP starting to read external density for the zmp calculation @@ -193,18 +189,18 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) ! check for relativistic method reltyp = atom%relativistic - IF (iw>0) CALL atom_print_state(atom%state,iw,error) + IF (iw>0) CALL atom_print_state(atom%state,iw) NULLIFY(hcore) - CALL create_opmat(hcore,atom%basis%nbas,error) + CALL create_opmat(hcore,atom%basis%nbas) ! Pseudopotentials SELECT CASE (atom%potential%ppot_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (NO_PSEUDO) SELECT CASE (reltyp) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_nonrel_atom) hcore%op = atom%integrals%kin - atom%zcore*atom%integrals%core CASE (do_zoramp_atom, do_sczoramp_atom) @@ -221,14 +217,14 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) END IF NULLIFY(fmat,jmat,kmat,xcmat) - CALL create_opmat(fmat,atom%basis%nbas,error) - CALL create_opmat(jmat,atom%basis%nbas,error) - CALL create_opmat(kmat,atom%basis%nbas,error) - CALL create_opmat(xcmat,atom%basis%nbas,error) + CALL create_opmat(fmat,atom%basis%nbas) + CALL create_opmat(jmat,atom%basis%nbas) + CALL create_opmat(kmat,atom%basis%nbas) + CALL create_opmat(xcmat,atom%basis%nbas) NULLIFY(density,cpot) - CALL create_opgrid(density,atom%basis%grid,error) - CALL create_opgrid(cpot,atom%basis%grid,error) + CALL create_opgrid(density,atom%basis%grid) + CALL create_opgrid(cpot,atom%basis%grid) ! ZMP reading the file to restart IF (atom%doread) CALL atom_read_zmp_restart(atom,doguess,iw) @@ -237,29 +233,29 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) ! initial guess ALLOCATE(tmp_dens(SIZE(density%op))) tmp_dens=0 - CALL slater_density(density%op,tmp_dens,atom%z,atom%state,atom%basis%grid,error) + CALL slater_density(density%op,tmp_dens,atom%z,atom%state,atom%basis%grid) density%op=density%op+tmp_dens DEALLOCATE(tmp_dens) - CALL coulomb_potential_numeric(cpot%op,density%op,density%grid,error) - CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0,error) - CALL wigner_slater_functional(density%op,cpot%op,error) - CALL numpot_matrix(xcmat%op,cpot%op,atom%basis,0,error) + CALL coulomb_potential_numeric(cpot%op,density%op,density%grid) + CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0) + CALL wigner_slater_functional(density%op,cpot%op) + CALL numpot_matrix(xcmat%op,cpot%op,atom%basis,0) fmat%op = hcore%op + jmat%op + xcmat%op CALL atom_solve(fmat%op,atom%integrals%utrans,atom%orbitals%wfn,atom%orbitals%ener,& - atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc,error) + atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc) END IF CALL atom_denmat(atom%orbitals%pmat,atom%orbitals%wfn,atom%basis%nbas,atom%state%occupation,& - atom%state%maxl_occ,atom%state%maxn_occ,error) + atom%state%maxl_occ,atom%state%maxn_occ) ! wavefunction history NULLIFY(history%dmat,history%hmat) - CALL atom_history_init (history,atom%optimization,fmat%op,error) + CALL atom_history_init (history,atom%optimization,fmat%op) iter = 0 DO !SCF Loop ! Kinetic energy - atom%energy%ekin = atom_trace(atom%integrals%kin,atom%orbitals%pmat,error) + atom%energy%ekin = atom_trace(atom%integrals%kin,atom%orbitals%pmat) ! Band energy atom%energy%eband = 0._dp @@ -272,22 +268,22 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) ! Pseudopotential energy SELECT CASE (atom%potential%ppot_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (NO_PSEUDO) atom%energy%eploc = 0._dp atom%energy%epnl = 0._dp CASE (GTH_PSEUDO) - atom%energy%eploc = atom_trace(atom%integrals%core,atom%orbitals%pmat,error) - atom%energy%epnl = atom_trace(atom%integrals%hnl,atom%orbitals%pmat,error) + atom%energy%eploc = atom_trace(atom%integrals%core,atom%orbitals%pmat) + atom%energy%epnl = atom_trace(atom%integrals%hnl,atom%orbitals%pmat) END SELECT atom%energy%epseudo = atom%energy%eploc + atom%energy%epnl ! Core energy - atom%energy%ecore = atom_trace(hcore%op,atom%orbitals%pmat,error) + atom%energy%ecore = atom_trace(hcore%op,atom%orbitals%pmat) ! Confinement energy IF ( atom%potential%confinement ) THEN - atom%energy%econfinement = atom_trace(atom%integrals%conf,atom%orbitals%pmat,error) + atom%energy%econfinement = atom_trace(atom%integrals%conf,atom%orbitals%pmat) ELSE atom%energy%econfinement = 0._dp END IF @@ -296,34 +292,34 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) jmat%op = 0._dp SELECT CASE (atom%coulomb_integral_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_analytic) - CALL ceri_contract(jmat%op,atom%integrals%ceri,atom%orbitals%pmat,atom%integrals%n,error=error) + CALL ceri_contract(jmat%op,atom%integrals%ceri,atom%orbitals%pmat,atom%integrals%n) CASE (do_semi_analytic) CALL coulomb_potential_analytic(cpot%op,atom%orbitals%pmat,atom%basis,atom%basis%grid,& - atom%state%maxl_occ,error) - CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0,error) + atom%state%maxl_occ) + CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0) CASE (do_numeric) - CALL atom_density(density%op,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) - CALL coulomb_potential_numeric(cpot%op,density%op,density%grid,error) - CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0,error) + CALL atom_density(density%op,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO") + CALL coulomb_potential_numeric(cpot%op,density%op,density%grid) + CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0) END SELECT - atom%energy%ecoulomb = 0.5_dp * atom_trace(jmat%op,atom%orbitals%pmat,error) + atom%energy%ecoulomb = 0.5_dp * atom_trace(jmat%op,atom%orbitals%pmat) ! Exchange Term IF (need_x) THEN kmat%op = 0._dp SELECT CASE (atom%exchange_integral_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_analytic) - CALL eeri_contract(kmat%op,atom%integrals%eeri,atom%orbitals%pmat,atom%integrals%n,error=error) + CALL eeri_contract(kmat%op,atom%integrals%eeri,atom%orbitals%pmat,atom%integrals%n) CASE (do_semi_analytic) - CALL exchange_semi_analytic(kmat%op,atom%state,atom%state%occupation,atom%orbitals%wfn,atom%basis,error=error) + CALL exchange_semi_analytic(kmat%op,atom%state,atom%state%occupation,atom%orbitals%wfn,atom%basis) CASE (do_numeric) - CALL exchange_numeric(kmat%op,atom%state,atom%state%occupation,atom%orbitals%wfn,atom%basis,error=error) + CALL exchange_numeric(kmat%op,atom%state,atom%state%occupation,atom%orbitals%wfn,atom%basis) END SELECT - atom%energy%eexchange = hf_frac * 0.5_dp * atom_trace(kmat%op,atom%orbitals%pmat,error) + atom%energy%eexchange = hf_frac * 0.5_dp * atom_trace(kmat%op,atom%orbitals%pmat) kmat%op = hf_frac*kmat%op ELSE kmat%op = 0._dp @@ -333,14 +329,14 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) ! XC IF (need_xc) THEN xcmat%op = 0._dp - CALL calculate_atom_vxc_lda(xcmat,atom,xc_section,error) + CALL calculate_atom_vxc_lda(xcmat,atom,xc_section) ! ZMP added options for the zmp calculations, building external density and vxc potential ELSEIF (need_zmp) THEN xcmat%op = 0._dp - CALL calculate_atom_zmp(ext_density=ext_density,atom=atom,lprint=.FALSE.,xcmat=xcmat,error=error) + CALL calculate_atom_zmp(ext_density=ext_density,atom=atom,lprint=.FALSE.,xcmat=xcmat) ELSEIF (need_vxc) THEN xcmat%op = 0._dp - CALL calculate_atom_ext_vxc(vxc=ext_vxc,atom=atom,lprint=.FALSE.,xcmat=xcmat,error=error) + CALL calculate_atom_ext_vxc(vxc=ext_vxc,atom=atom,lprint=.FALSE.,xcmat=xcmat) ELSE xcmat%op = 0._dp atom%energy%exc = 0._dp @@ -360,15 +356,15 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) ! calculate error matrix CALL err_matrix(jmat%op,deps,fmat%op,atom%orbitals%pmat,atom%integrals%utrans,& - atom%integrals%uptrans,atom%basis%nbas,atom%integrals%nne,error) + atom%integrals%uptrans,atom%basis%nbas,atom%integrals%nne) iter = iter + 1 IF ( iw > 0 ) THEN IF (need_zmp ) THEN - CALL atom_print_zmp_iteration(iter,deps,atom,iw,error) + CALL atom_print_zmp_iteration(iter,deps,atom,iw) ELSE - CALL atom_print_iteration(iter,deps,atom%energy%etot,iw,error) + CALL atom_print_iteration(iter,deps,atom%energy%etot,iw) ENDIF END IF @@ -381,31 +377,31 @@ SUBROUTINE calculate_atom_restricted(atom,iw,noguess,error) END IF ! update history container and extrapolate KS matrix - CALL atom_history_update (history,fmat%op,jmat%op,error) - CALL atom_opt (fmat%op,history,deps,error) + CALL atom_history_update (history,fmat%op,jmat%op) + CALL atom_opt (fmat%op,history,deps) ! Solve HF/KS equations CALL atom_solve(fmat%op,atom%integrals%utrans,atom%orbitals%wfn,atom%orbitals%ener,& - atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc,error) + atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc) CALL atom_denmat(atom%orbitals%pmat,atom%orbitals%wfn,atom%basis%nbas,atom%state%occupation,& - atom%state%maxl_occ,atom%state%maxn_occ,error) + atom%state%maxl_occ,atom%state%maxn_occ) END DO !SCF Loop IF ( iw > 0 ) THEN - CALL atom_print_energies(atom,iw,error) + CALL atom_print_energies(atom,iw) END IF - CALL atom_history_release(history,error) + CALL atom_history_release(history) - CALL release_opmat(fmat,error) - CALL release_opmat(jmat,error) - CALL release_opmat(kmat,error) - CALL release_opmat(xcmat,error) - CALL release_opmat(hcore,error) + CALL release_opmat(fmat) + CALL release_opmat(jmat) + CALL release_opmat(kmat) + CALL release_opmat(xcmat) + CALL release_opmat(hcore) - CALL release_opgrid(density,error) - CALL release_opgrid(cpot,error) + CALL release_opgrid(density) + CALL release_opgrid(cpot) ! ZMP deallocating ext_density ext_vxc IF (need_zmp) DEALLOCATE(ext_density) @@ -420,13 +416,11 @@ END SUBROUTINE calculate_atom_restricted !> \param atom ... !> \param iw ... !> \param noguess ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) + SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess) TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: iw LOGICAL, INTENT(IN), OPTIONAL :: noguess - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_atom_unrestricted', & routineP = moduleN//':'//routineN @@ -457,10 +451,10 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) hf_frac = 0._dp IF (ASSOCIATED(atom%xc_section)) THEN xc_section => atom%xc_section - hfx_sections => section_vals_get_subs_vals(xc_section,"HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,error=error) + hfx_sections => section_vals_get_subs_vals(xc_section,"HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx) IF ( do_hfx ) THEN - CALL section_vals_val_get(hfx_sections,"FRACTION", r_val=hf_frac, error=error) + CALL section_vals_val_get(hfx_sections,"FRACTION", r_val=hf_frac) END IF ELSE NULLIFY(xc_section) @@ -473,14 +467,14 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) SELECT CASE (method) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_rks_atom) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_uks_atom) need_x = do_hfx need_xc = .TRUE. CASE (do_rhf_atom) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_uhf_atom) need_x = .TRUE. need_xc = .FALSE. @@ -489,7 +483,7 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) need_x = .TRUE. need_xc = .FALSE. hf_frac = 1._dp - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT ! set alpha and beta occupations @@ -516,21 +510,21 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) ! check for relativistic method reltyp = atom%relativistic - IF (iw>0) CALL atom_print_state(atom%state,iw,error) + IF (iw>0) CALL atom_print_state(atom%state,iw) NULLIFY(hcore,hlsd) - CALL create_opmat(hcore,atom%basis%nbas,error) - CALL create_opmat(hlsd,atom%basis%nbas,error) + CALL create_opmat(hcore,atom%basis%nbas) + CALL create_opmat(hlsd,atom%basis%nbas) hlsd%op = 0._dp ! Pseudopotentials lsdpot=.FALSE. SELECT CASE (atom%potential%ppot_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (NO_PSEUDO) SELECT CASE (reltyp) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_nonrel_atom) hcore%op = atom%integrals%kin - atom%zcore*atom%integrals%core CASE (do_zoramp_atom, do_sczoramp_atom) @@ -551,58 +545,58 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) END IF NULLIFY(fmata,fmatb,jmat,kmata,kmatb,xcmata,xcmatb) - CALL create_opmat(fmata,atom%basis%nbas,error) - CALL create_opmat(fmatb,atom%basis%nbas,error) - CALL create_opmat(jmat,atom%basis%nbas,error) - CALL create_opmat(kmata,atom%basis%nbas,error) - CALL create_opmat(kmatb,atom%basis%nbas,error) - CALL create_opmat(xcmata,atom%basis%nbas,error) - CALL create_opmat(xcmatb,atom%basis%nbas,error) + CALL create_opmat(fmata,atom%basis%nbas) + CALL create_opmat(fmatb,atom%basis%nbas) + CALL create_opmat(jmat,atom%basis%nbas) + CALL create_opmat(kmata,atom%basis%nbas) + CALL create_opmat(kmatb,atom%basis%nbas) + CALL create_opmat(xcmata,atom%basis%nbas) + CALL create_opmat(xcmatb,atom%basis%nbas) NULLIFY(density,rhoa,rhob,cpot) - CALL create_opgrid(density,atom%basis%grid,error) - CALL create_opgrid(rhoa,atom%basis%grid,error) - CALL create_opgrid(rhob,atom%basis%grid,error) - CALL create_opgrid(cpot,atom%basis%grid,error) + CALL create_opgrid(density,atom%basis%grid) + CALL create_opgrid(rhoa,atom%basis%grid) + CALL create_opgrid(rhob,atom%basis%grid) + CALL create_opgrid(cpot,atom%basis%grid) IF (doguess) THEN ! initial guess - CALL slater_density(rhoa%op,rhob%op,atom%z,atom%state,atom%basis%grid,error) + CALL slater_density(rhoa%op,rhob%op,atom%z,atom%state,atom%basis%grid) density%op = rhoa%op + rhob%op - CALL coulomb_potential_numeric(cpot%op,density%op,density%grid,error) - CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0,error) + CALL coulomb_potential_numeric(cpot%op,density%op,density%grid) + CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0) ! alpha spin density%op = 2._dp*rhoa%op - CALL wigner_slater_functional(density%op,cpot%op,error) - CALL numpot_matrix(xcmata%op,cpot%op,atom%basis,0,error) + CALL wigner_slater_functional(density%op,cpot%op) + CALL numpot_matrix(xcmata%op,cpot%op,atom%basis,0) fmata%op = hcore%op + hlsd%op + jmat%op + xcmata%op CALL atom_solve(fmata%op,atom%integrals%utrans,atom%orbitals%wfna,atom%orbitals%enera,& - atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc,error) + atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc) ! beta spin density%op = 2._dp*rhob%op - CALL wigner_slater_functional(density%op,cpot%op,error) - CALL numpot_matrix(xcmatb%op,cpot%op,atom%basis,0,error) + CALL wigner_slater_functional(density%op,cpot%op) + CALL numpot_matrix(xcmatb%op,cpot%op,atom%basis,0) fmatb%op = hcore%op - hlsd%op + jmat%op + xcmatb%op CALL atom_solve(fmatb%op,atom%integrals%utrans,atom%orbitals%wfnb,atom%orbitals%enerb,& - atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc,error) + atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc) END IF CALL atom_denmat(atom%orbitals%pmata,atom%orbitals%wfna,atom%basis%nbas,atom%state%occa,& - atom%state%maxl_occ,atom%state%maxn_occ,error) + atom%state%maxl_occ,atom%state%maxn_occ) CALL atom_denmat(atom%orbitals%pmatb,atom%orbitals%wfnb,atom%basis%nbas,atom%state%occb,& - atom%state%maxl_occ,atom%state%maxn_occ,error) + atom%state%maxl_occ,atom%state%maxn_occ) atom%orbitals%pmat = atom%orbitals%pmata + atom%orbitals%pmatb ! wavefunction history NULLIFY(historya%dmat,historya%hmat) - CALL atom_history_init (historya,atom%optimization,fmata%op,error) + CALL atom_history_init (historya,atom%optimization,fmata%op) NULLIFY(historyb%dmat,historyb%hmat) - CALL atom_history_init (historyb,atom%optimization,fmatb%op,error) + CALL atom_history_init (historyb,atom%optimization,fmatb%op) iter = 0 DO !SCF Loop ! Kinetic energy - atom%energy%ekin = atom_trace(atom%integrals%kin,atom%orbitals%pmat,error) + atom%energy%ekin = atom_trace(atom%integrals%kin,atom%orbitals%pmat) ! Band energy atom%energy%eband = 0._dp @@ -616,22 +610,22 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) ! Pseudopotential energy SELECT CASE (atom%potential%ppot_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (NO_PSEUDO) atom%energy%eploc = 0._dp atom%energy%epnl = 0._dp CASE (GTH_PSEUDO) - atom%energy%eploc = atom_trace(atom%integrals%core,atom%orbitals%pmat,error) - atom%energy%epnl = atom_trace(atom%integrals%hnl,atom%orbitals%pmat,error) + atom%energy%eploc = atom_trace(atom%integrals%core,atom%orbitals%pmat) + atom%energy%epnl = atom_trace(atom%integrals%hnl,atom%orbitals%pmat) END SELECT atom%energy%epseudo = atom%energy%eploc + atom%energy%epnl ! Core energy - atom%energy%ecore = atom_trace(hcore%op,atom%orbitals%pmat,error) + atom%energy%ecore = atom_trace(hcore%op,atom%orbitals%pmat) ! Confinement energy IF ( atom%potential%confinement ) THEN - atom%energy%econfinement = atom_trace(atom%integrals%conf,atom%orbitals%pmat,error) + atom%energy%econfinement = atom_trace(atom%integrals%conf,atom%orbitals%pmat) ELSE atom%energy%econfinement = 0._dp END IF @@ -640,19 +634,19 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) jmat%op = 0._dp SELECT CASE (atom%coulomb_integral_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_analytic) - CALL ceri_contract(jmat%op,atom%integrals%ceri,atom%orbitals%pmat,atom%integrals%n,error=error) + CALL ceri_contract(jmat%op,atom%integrals%ceri,atom%orbitals%pmat,atom%integrals%n) CASE (do_semi_analytic) CALL coulomb_potential_analytic(cpot%op,atom%orbitals%pmat,atom%basis,atom%basis%grid,& - atom%state%maxl_occ,error) - CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0,error) + atom%state%maxl_occ) + CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0) CASE (do_numeric) - CALL atom_density(density%op,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) - CALL coulomb_potential_numeric(cpot%op,density%op,density%grid,error) - CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0,error) + CALL atom_density(density%op,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO") + CALL coulomb_potential_numeric(cpot%op,density%op,density%grid) + CALL numpot_matrix(jmat%op,cpot%op,atom%basis,0) END SELECT - atom%energy%ecoulomb = 0.5_dp * atom_trace(jmat%op,atom%orbitals%pmat,error) + atom%energy%ecoulomb = 0.5_dp * atom_trace(jmat%op,atom%orbitals%pmat) ! Exchange Term IF (need_x) THEN @@ -660,19 +654,19 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) kmatb%op = 0._dp SELECT CASE (atom%exchange_integral_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_analytic) - CALL eeri_contract(kmata%op,atom%integrals%eeri,atom%orbitals%pmata,atom%integrals%n,error=error) - CALL eeri_contract(kmatb%op,atom%integrals%eeri,atom%orbitals%pmatb,atom%integrals%n,error=error) + CALL eeri_contract(kmata%op,atom%integrals%eeri,atom%orbitals%pmata,atom%integrals%n) + CALL eeri_contract(kmatb%op,atom%integrals%eeri,atom%orbitals%pmatb,atom%integrals%n) CASE (do_semi_analytic) - CALL exchange_semi_analytic(kmata%op,atom%state,atom%state%occa,atom%orbitals%wfna,atom%basis,error=error) - CALL exchange_semi_analytic(kmatb%op,atom%state,atom%state%occb,atom%orbitals%wfnb,atom%basis,error=error) + CALL exchange_semi_analytic(kmata%op,atom%state,atom%state%occa,atom%orbitals%wfna,atom%basis) + CALL exchange_semi_analytic(kmatb%op,atom%state,atom%state%occb,atom%orbitals%wfnb,atom%basis) CASE (do_numeric) - CALL exchange_numeric(kmata%op,atom%state,atom%state%occa,atom%orbitals%wfna,atom%basis,error=error) - CALL exchange_numeric(kmatb%op,atom%state,atom%state%occb,atom%orbitals%wfnb,atom%basis,error=error) + CALL exchange_numeric(kmata%op,atom%state,atom%state%occa,atom%orbitals%wfna,atom%basis) + CALL exchange_numeric(kmatb%op,atom%state,atom%state%occb,atom%orbitals%wfnb,atom%basis) END SELECT - atom%energy%eexchange = hf_frac * ( atom_trace(kmata%op,atom%orbitals%pmata,error) + & - atom_trace(kmatb%op,atom%orbitals%pmatb,error) ) + atom%energy%eexchange = hf_frac * ( atom_trace(kmata%op,atom%orbitals%pmata) + & + atom_trace(kmatb%op,atom%orbitals%pmatb) ) kmata%op = 2._dp*hf_frac*kmata%op kmatb%op = 2._dp*hf_frac*kmatb%op ELSE @@ -685,7 +679,7 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) IF (need_xc) THEN xcmata%op = 0._dp xcmatb%op = 0._dp - CALL calculate_atom_vxc_lsd(xcmata,xcmatb,atom,xc_section,error) + CALL calculate_atom_vxc_lsd(xcmata,xcmatb,atom,xc_section) ELSE xcmata%op = 0._dp xcmatb%op = 0._dp @@ -693,8 +687,8 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) END IF IF(lsdpot) THEN - atom%energy%elsd = atom_trace(hlsd%op,atom%orbitals%pmata,error) - & - atom_trace(hlsd%op,atom%orbitals%pmatb,error) + atom%energy%elsd = atom_trace(hlsd%op,atom%orbitals%pmata) - & + atom_trace(hlsd%op,atom%orbitals%pmatb) atom%energy%epseudo = atom%energy%epseudo + atom%energy%elsd atom%energy%ecore = atom%energy%ecore + atom%energy%elsd ELSE @@ -713,15 +707,15 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) ! calculate error matrix CALL err_matrix(xcmata%op,depsa,fmata%op,atom%orbitals%pmata,atom%integrals%utrans,& - atom%integrals%uptrans,atom%basis%nbas,atom%integrals%nne,error) + atom%integrals%uptrans,atom%basis%nbas,atom%integrals%nne) CALL err_matrix(xcmatb%op,depsb,fmatb%op,atom%orbitals%pmatb,atom%integrals%utrans,& - atom%integrals%uptrans,atom%basis%nbas,atom%integrals%nne,error) + atom%integrals%uptrans,atom%basis%nbas,atom%integrals%nne) deps=2._dp*MAX(depsa,depsb) iter = iter + 1 IF ( iw > 0 ) THEN - CALL atom_print_iteration(iter,deps,atom%energy%etot,iw,error) + CALL atom_print_iteration(iter,deps,atom%energy%etot,iw) END IF IF ( deps < eps_scf ) EXIT @@ -733,45 +727,45 @@ SUBROUTINE calculate_atom_unrestricted(atom,iw,noguess,error) END IF ! update history container and extrapolate KS matrix - CALL atom_history_update (historya,fmata%op,xcmata%op,error) - CALL atom_history_update (historyb,fmatb%op,xcmatb%op,error) - CALL atom_opt (fmata%op,historya,depsa,error) - CALL atom_opt (fmatb%op,historyb,depsb,error) + CALL atom_history_update (historya,fmata%op,xcmata%op) + CALL atom_history_update (historyb,fmatb%op,xcmatb%op) + CALL atom_opt (fmata%op,historya,depsa) + CALL atom_opt (fmatb%op,historyb,depsb) ! Solve HF/KS equations CALL atom_solve(fmata%op,atom%integrals%utrans,atom%orbitals%wfna,atom%orbitals%enera,& - atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc,error) + atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc) CALL atom_denmat(atom%orbitals%pmata,atom%orbitals%wfna,atom%basis%nbas,atom%state%occa,& - atom%state%maxl_occ,atom%state%maxn_occ,error) + atom%state%maxl_occ,atom%state%maxn_occ) CALL atom_solve(fmatb%op,atom%integrals%utrans,atom%orbitals%wfnb,atom%orbitals%enerb,& - atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc,error) + atom%basis%nbas,atom%integrals%nne,atom%state%maxl_calc) CALL atom_denmat(atom%orbitals%pmatb,atom%orbitals%wfnb,atom%basis%nbas,atom%state%occb,& - atom%state%maxl_occ,atom%state%maxn_occ,error) + atom%state%maxl_occ,atom%state%maxn_occ) atom%orbitals%pmat = atom%orbitals%pmata + atom%orbitals%pmatb END DO !SCF Loop IF ( iw > 0 ) THEN - CALL atom_print_energies(atom,iw,error) + CALL atom_print_energies(atom,iw) END IF - CALL atom_history_release(historya,error) - CALL atom_history_release(historyb,error) - - CALL release_opgrid(density,error) - CALL release_opgrid(rhoa,error) - CALL release_opgrid(rhob,error) - CALL release_opgrid(cpot,error) - - CALL release_opmat(fmata,error) - CALL release_opmat(fmatb,error) - CALL release_opmat(jmat,error) - CALL release_opmat(kmata,error) - CALL release_opmat(kmatb,error) - CALL release_opmat(xcmata,error) - CALL release_opmat(xcmatb,error) - CALL release_opmat(hlsd,error) - CALL release_opmat(hcore,error) + CALL atom_history_release(historya) + CALL atom_history_release(historyb) + + CALL release_opgrid(density) + CALL release_opgrid(rhoa) + CALL release_opgrid(rhob) + CALL release_opgrid(cpot) + + CALL release_opmat(fmata) + CALL release_opmat(fmatb) + CALL release_opmat(jmat) + CALL release_opmat(kmata) + CALL release_opmat(kmatb) + CALL release_opmat(xcmata) + CALL release_opmat(xcmatb) + CALL release_opmat(hlsd) + CALL release_opmat(hcore) CALL timestop(handle) diff --git a/src/atom_energy.F b/src/atom_energy.F index f73a12a3b7..9ae452d50c 100644 --- a/src/atom_energy.F +++ b/src/atom_energy.F @@ -68,11 +68,9 @@ MODULE atom_energy ! ***************************************************************************** !> \brief ... !> \param atom_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_energy_opt(atom_section,error) + SUBROUTINE atom_energy_opt(atom_section) TYPE(section_vals_type), POINTER :: atom_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_energy_opt', & routineP = moduleN//':'//routineN @@ -110,8 +108,8 @@ SUBROUTINE atom_energy_opt(atom_section,error) CALL timeset(routineN,handle) ! What atom do we calculate - CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=zval, error=error) - CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem, error=error) + CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=zval) + CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem) zz = 0 DO i=1,nelem IF ( ptable(i)%symbol == elem ) THEN @@ -123,46 +121,46 @@ SUBROUTINE atom_energy_opt(atom_section,error) ! read and set up inofrmation on the basis sets ALLOCATE(ae_basis,pp_basis,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - basis_section => section_vals_get_subs_vals(atom_section,"AE_BASIS",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + basis_section => section_vals_get_subs_vals(atom_section,"AE_BASIS") NULLIFY(ae_basis%grid) - CALL init_atom_basis(ae_basis,basis_section,zval,"AE",error) + CALL init_atom_basis(ae_basis,basis_section,zval,"AE") NULLIFY(pp_basis%grid) - basis_section => section_vals_get_subs_vals(atom_section,"PP_BASIS",error=error) - CALL init_atom_basis(pp_basis,basis_section,zval,"PP",error) + basis_section => section_vals_get_subs_vals(atom_section,"PP_BASIS") + CALL init_atom_basis(pp_basis,basis_section,zval,"PP") ! print general and basis set information - logger => cp_error_get_logger(error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log",error=error) - IF(iw > 0) CALL atom_print_info(zval,"Atomic Energy Calculation",iw,error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%BASIS_SET",extension=".log",error=error) + logger => cp_get_default_logger() + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log") + IF(iw > 0) CALL atom_print_info(zval,"Atomic Energy Calculation",iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%BASIS_SET",extension=".log") IF(iw > 0) THEN - CALL atom_print_basis(ae_basis,iw," All Electron Basis",error) - CALL atom_print_basis(pp_basis,iw," Pseudopotential Basis",error) + CALL atom_print_basis(ae_basis,iw," All Electron Basis") + CALL atom_print_basis(pp_basis,iw," Pseudopotential Basis") END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%BASIS_SET",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%BASIS_SET") ! read and setup information on the pseudopotential NULLIFY(potential_section) - potential_section => section_vals_get_subs_vals(atom_section,"POTENTIAL",error=error) + potential_section => section_vals_get_subs_vals(atom_section,"POTENTIAL") ALLOCATE(ae_pot,p_pot,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL init_atom_potential(p_pot,potential_section,zval,error) - CALL init_atom_potential(ae_pot,potential_section,-1,error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL init_atom_potential(p_pot,potential_section,zval) + CALL init_atom_potential(ae_pot,potential_section,-1) ! if the ERI's are calculated analytically, we have to precalculate them eri_c = .FALSE. - CALL section_vals_val_get(atom_section,"COULOMB_INTEGRALS", i_val=do_eric, error=error) + CALL section_vals_val_get(atom_section,"COULOMB_INTEGRALS", i_val=do_eric) IF(do_eric==do_analytic) eri_c = .TRUE. eri_e = .FALSE. - CALL section_vals_val_get(atom_section,"EXCHANGE_INTEGRALS", i_val=do_erie, error=error) + CALL section_vals_val_get(atom_section,"EXCHANGE_INTEGRALS", i_val=do_erie) IF(do_erie==do_analytic) eri_e = .TRUE. ! information on the states to be calculated - CALL section_vals_val_get(atom_section,"MAX_ANGULAR_MOMENTUM", i_val=maxl, error=error) + CALL section_vals_val_get(atom_section,"MAX_ANGULAR_MOMENTUM", i_val=maxl) maxn=0 - CALL section_vals_val_get(atom_section,"CALCULATE_STATES", i_vals=cn, error=error) + CALL section_vals_val_get(atom_section,"CALCULATE_STATES", i_vals=cn) DO in = 1, MIN(SIZE(cn),4) maxn(in-1) = cn(in) END DO @@ -172,35 +170,35 @@ SUBROUTINE atom_energy_opt(atom_section,error) END DO ! read optimization section - opt_section => section_vals_get_subs_vals(atom_section,"OPTIMIZATION",error=error) - CALL read_atom_opt_section(optimization,opt_section,error) + opt_section => section_vals_get_subs_vals(atom_section,"OPTIMIZATION") + CALL read_atom_opt_section(optimization,opt_section) had_ae = .FALSE. had_pp = .FALSE. ! Check for the total number of electron configurations to be calculated - CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", n_rep_val=n_rep) ! Check for the total number of method types to be calculated - method_section => section_vals_get_subs_vals(atom_section,"METHOD",error=error) - CALL section_vals_get(method_section,n_repetition=n_meth,error=error) + method_section => section_vals_get_subs_vals(atom_section,"METHOD") + CALL section_vals_get(method_section,n_repetition=n_meth) ! integrals ALLOCATE(ae_int, pp_int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE(atom_info(n_rep,n_meth),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DO in = 1, n_rep DO im = 1, n_meth NULLIFY(atom_info(in,im)%atom) - CALL create_atom_type(atom_info(in,im)%atom,error) + CALL create_atom_type(atom_info(in,im)%atom) atom_info(in,im)%atom%optimization = optimization atom_info(in,im)%atom%z = zval - xc_section => section_vals_get_subs_vals(method_section,"XC",i_rep_section=im,error=error) + xc_section => section_vals_get_subs_vals(method_section,"XC",i_rep_section=im) atom_info(in,im)%atom%xc_section => xc_section ! ZMP Reading input sections if they are found initialize everything @@ -208,42 +206,42 @@ SUBROUTINE atom_energy_opt(atom_section,error) doread=.FALSE. read_vxc=.FALSE. - zmp_section => section_vals_get_subs_vals(method_section,"ZMP",error=error) - CALL section_vals_get(zmp_section,explicit=do_zmp,error=error) + zmp_section => section_vals_get_subs_vals(method_section,"ZMP") + CALL section_vals_get(zmp_section,explicit=do_zmp) atom_info(in,im)%atom%do_zmp=do_zmp - CALL section_vals_val_get(zmp_section,"FILE_DENSITY",c_val=filename,error=error) + CALL section_vals_val_get(zmp_section,"FILE_DENSITY",c_val=filename) atom_info(in,im)%atom%ext_file=filename CALL section_vals_val_get(zmp_section,"GRID_TOL",& - r_val= atom_info(in,im)%atom%zmpgrid_tol,error=error) - CALL section_vals_val_get(zmp_section,"LAMBDA",r_val=lambda,error=error) + r_val= atom_info(in,im)%atom%zmpgrid_tol) + CALL section_vals_val_get(zmp_section,"LAMBDA",r_val=lambda) atom_info(in,im)%atom%lambda=lambda - CALL section_vals_val_get(zmp_section,"DM",l_val=dm,error=error) + CALL section_vals_val_get(zmp_section,"DM",l_val=dm) atom_info(in,im)%atom%dm=dm - zmp_restart_section => section_vals_get_subs_vals(zmp_section,"RESTART",error=error) - CALL section_vals_get(zmp_restart_section,explicit=doread,error=error) + zmp_restart_section => section_vals_get_subs_vals(zmp_section,"RESTART") + CALL section_vals_get(zmp_restart_section,explicit=doread) atom_info(in,im)%atom%doread=doread - CALL section_vals_val_get(zmp_restart_section,"FILE_RESTART",c_val=filename,error=error) + CALL section_vals_val_get(zmp_restart_section,"FILE_RESTART",c_val=filename) atom_info(in,im)%atom%zmp_restart_file=filename ! ZMP Reading external vxc section, if found initialize - external_vxc_section => section_vals_get_subs_vals(method_section,"EXTERNAL_VXC",error=error) - CALL section_vals_get(external_vxc_section,explicit=read_vxc,error=error) + external_vxc_section => section_vals_get_subs_vals(method_section,"EXTERNAL_VXC") + CALL section_vals_get(external_vxc_section,explicit=read_vxc) atom_info(in,im)%atom%read_vxc=read_vxc - CALL section_vals_val_get(external_vxc_section,"FILE_VXC",c_val=filename,error=error) + CALL section_vals_val_get(external_vxc_section,"FILE_VXC",c_val=filename) atom_info(in,im)%atom%ext_vxc_file=filename CALL section_vals_val_get(external_vxc_section,"GRID_TOL",& - r_val= atom_info(in,im)%atom%zmpvxcgrid_tol,error=error) + r_val= atom_info(in,im)%atom%zmpvxcgrid_tol) ALLOCATE(state,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ! get the electronic configuration CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", i_rep_val=in,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) ! set occupations - CALL atom_set_occupation(tmpstringlist,state%occ,state%occupation,state%multiplicity,error) + CALL atom_set_occupation(tmpstringlist,state%occ,state%occupation,state%multiplicity) state%maxl_occ = get_maxl_occ(state%occ) state%maxn_occ = get_maxn_occ(state%occ) @@ -259,78 +257,78 @@ SUBROUTINE atom_energy_opt(atom_section,error) pp_calc = ANY(INDEX(tmpstringlist(1:),"CORE") /= 0) IF ( pp_calc ) THEN ! get and set the core occupations - CALL section_vals_val_get(atom_section,"CORE", c_vals=tmpstringlist, error=error) - CALL atom_set_occupation(tmpstringlist,state%core,pocc,error=error) + CALL section_vals_val_get(atom_section,"CORE", c_vals=tmpstringlist) + CALL atom_set_occupation(tmpstringlist,state%core,pocc) zcore = zval - NINT(SUM(state%core)) - CALL set_atom(atom_info(in,im)%atom,zcore=zcore,pp_calc=.TRUE.,error=error) + CALL set_atom(atom_info(in,im)%atom,zcore=zcore,pp_calc=.TRUE.) ELSE state%core=0._dp - CALL set_atom(atom_info(in,im)%atom,zcore=zval,pp_calc=.FALSE.,error=error) + CALL set_atom(atom_info(in,im)%atom,zcore=zval,pp_calc=.FALSE.) END IF - CALL section_vals_val_get(method_section,"METHOD_TYPE",i_val=method,i_rep_section=im,error=error) - CALL section_vals_val_get(method_section,"RELATIVISTIC",i_val=reltyp,i_rep_section=im,error=error) - CALL set_atom(atom_info(in,im)%atom,method_type=method,relativistic=reltyp,error=error) + CALL section_vals_val_get(method_section,"METHOD_TYPE",i_val=method,i_rep_section=im) + CALL section_vals_val_get(method_section,"RELATIVISTIC",i_val=reltyp,i_rep_section=im) + CALL set_atom(atom_info(in,im)%atom,method_type=method,relativistic=reltyp) IF(atom_consistent_method(method,state%multiplicity)) THEN - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%METHOD_INFO",extension=".log",error=error) - CALL atom_print_method(atom_info(in,im)%atom,iw,error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%METHOD_INFO",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%METHOD_INFO",extension=".log") + CALL atom_print_method(atom_info(in,im)%atom,iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%METHOD_INFO") - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log") IF ( pp_calc ) THEN - IF(iw > 0) CALL atom_print_potential(p_pot,iw,error) + IF(iw > 0) CALL atom_print_potential(p_pot,iw) ELSE - IF(iw > 0) CALL atom_print_potential(ae_pot,iw,error) + IF(iw > 0) CALL atom_print_potential(ae_pot,iw) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL") END IF ! calculate integrals IF ( pp_calc ) THEN ! general integrals CALL atom_int_setup(pp_int,pp_basis,& - potential=p_pot,eri_coulomb=eri_c,eri_exchange=eri_e,error=error) + potential=p_pot,eri_coulomb=eri_c,eri_exchange=eri_e) ! potential - CALL atom_ppint_setup(pp_int,pp_basis,potential=p_pot,error=error) + CALL atom_ppint_setup(pp_int,pp_basis,potential=p_pot) ! NULLIFY(pp_int%tzora,pp_int%hdkh) ! - CALL set_atom(atom_info(in,im)%atom,basis=pp_basis,integrals=pp_int,potential=p_pot,error=error) + CALL set_atom(atom_info(in,im)%atom,basis=pp_basis,integrals=pp_int,potential=p_pot) state%maxn_calc(:) = MIN( state%maxn_calc(:), pp_basis%nbas(:) ) - CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP, error, failure) + CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP,failure) had_pp = .TRUE. ELSE ! general integrals CALL atom_int_setup(ae_int,ae_basis,potential=ae_pot,& - eri_coulomb=eri_c,eri_exchange=eri_e,error=error) + eri_coulomb=eri_c,eri_exchange=eri_e) ! potential - CALL atom_ppint_setup(ae_int,ae_basis,potential=ae_pot,error=error) + CALL atom_ppint_setup(ae_int,ae_basis,potential=ae_pot) ! relativistic correction terms - CALL atom_relint_setup(ae_int,ae_basis,reltyp,zcore=REAL(zval,dp),error=error) + CALL atom_relint_setup(ae_int,ae_basis,reltyp,zcore=REAL(zval,dp)) ! - CALL set_atom(atom_info(in,im)%atom,basis=ae_basis,integrals=ae_int,potential=ae_pot,error=error) + CALL set_atom(atom_info(in,im)%atom,basis=ae_basis,integrals=ae_int,potential=ae_pot) state%maxn_calc(:) = MIN( state%maxn_calc(:), ae_basis%nbas(:) ) - CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP, error, failure) + CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP,failure) had_ae = .TRUE. END IF - CALL set_atom(atom_info(in,im)%atom,state=state,error=error) + CALL set_atom(atom_info(in,im)%atom,state=state) CALL set_atom(atom_info(in,im)%atom,coulomb_integral_type=do_eric,& - exchange_integral_type=do_erie,error=error) + exchange_integral_type=do_erie) NULLIFY(orbitals) mo = MAXVAL(state%maxn_calc) mb = MAXVAL(atom_info(in,im)%atom%basis%nbas) - CALL create_atom_orbs(orbitals,mb,mo,error) - CALL set_atom(atom_info(in,im)%atom,orbitals=orbitals,error=error) + CALL create_atom_orbs(orbitals,mb,mo) + CALL set_atom(atom_info(in,im)%atom,orbitals=orbitals) IF(atom_consistent_method(method,state%multiplicity)) THEN !Calculate the electronic structure - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%SCF_INFO",extension=".log",error=error) - CALL calculate_atom(atom_info(in,im)%atom,iw,error=error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%SCF_INFO",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%SCF_INFO",extension=".log") + CALL calculate_atom(atom_info(in,im)%atom,iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%SCF_INFO") ! ZMP If we have the external density do zmp IF (atom_info(in,im)%atom%do_zmp) THEN @@ -341,7 +339,7 @@ SUBROUTINE atom_energy_opt(atom_section,error) CALL atom_read_external_density(ext_density, atom_info(in,im)%atom,iw) CALL calculate_atom_zmp(ext_density=ext_density, & atom=atom_info(in,im)%atom, & - lprint=.TRUE.,error=error) + lprint=.TRUE.) DEALLOCATE(ext_density) ENDIF ! ZMP If we have the external v_xc calculate KS quantities @@ -351,13 +349,13 @@ SUBROUTINE atom_energy_opt(atom_section,error) CALL atom_read_external_vxc(ext_vxc, atom_info(in,im)%atom,iw) CALL calculate_atom_ext_vxc(vxc=ext_vxc, & atom=atom_info(in,im)%atom, & - lprint=.TRUE.,error=error) + lprint=.TRUE.) DEALLOCATE(ext_vxc) ENDIF ! rk: Print out the energies needed for the scptb parametrization ! (Orbital energies minus Kinetic, etc) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%ENERGIES_MINUS_KINETIC",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%ENERGIES_MINUS_KINETIC",extension=".log") IF (iw > 0) THEN WRITE(iw,'(T36,A,T61,F20.12)') " Etot-Ekin ::",atom_info(in,im)%atom%energy%etot & - atom_info(in,im)%atom%energy%ekin @@ -400,47 +398,47 @@ SUBROUTINE atom_energy_opt(atom_section,error) ! Print out the orbitals if requested - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%ORBITALS",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%ORBITALS",extension=".log") IF (iw > 0) THEN - CALL atom_print_orbitals(atom_info(in,im)%atom,iw,error=error) + CALL atom_print_orbitals(atom_info(in,im)%atom,iw) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%ORBITALS",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%ORBITALS") ! perform a fit of the total electronic density - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_DENSITY",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_DENSITY",extension=".log") IF (iw>0) THEN - CALL section_vals_val_get(atom_section,"PRINT%FIT_DENSITY%NUM_GTO", i_val=num_gto, error=error) - powell_section => section_vals_get_subs_vals(atom_section,"POWELL",error=error) - CALL atom_fit_density(atom_info(in,im)%atom,num_gto,0,iw,powell_section=powell_section,error=error) + CALL section_vals_val_get(atom_section,"PRINT%FIT_DENSITY%NUM_GTO", i_val=num_gto) + powell_section => section_vals_get_subs_vals(atom_section,"POWELL") + CALL atom_fit_density(atom_info(in,im)%atom,num_gto,0,iw,powell_section=powell_section) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_DENSITY",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_DENSITY") ! Optimize a local potential for the non-additive kinetic energy term in KG - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_KGPOT",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_KGPOT",extension=".log") IF (iw>0) THEN - CALL section_vals_val_get(atom_section,"PRINT%FIT_KGPOT%NUM_GAUSSIAN", i_val=num_gau, error=error) - CALL section_vals_val_get(atom_section,"PRINT%FIT_KGPOT%NUM_POLYNOM", i_val=num_pol, error=error) - powell_section => section_vals_get_subs_vals(atom_section,"POWELL",error=error) - CALL atom_fit_kgpot(atom_info(in,im)%atom,num_gau,num_pol,iw,powell_section=powell_section,error=error) + CALL section_vals_val_get(atom_section,"PRINT%FIT_KGPOT%NUM_GAUSSIAN", i_val=num_gau) + CALL section_vals_val_get(atom_section,"PRINT%FIT_KGPOT%NUM_POLYNOM", i_val=num_pol) + powell_section => section_vals_get_subs_vals(atom_section,"POWELL") + CALL atom_fit_kgpot(atom_info(in,im)%atom,num_gau,num_pol,iw,powell_section=powell_section) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_KGPOT",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_KGPOT") ! generate a response basis - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%RESPONSE_BASIS",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%RESPONSE_BASIS",extension=".log") IF (iw>0) THEN - CALL section_vals_val_get(atom_section,"PRINT%RESPONSE_BASIS%DELTA_CHARGE", r_val=delta, error=error) - CALL section_vals_val_get(atom_section,"PRINT%RESPONSE_BASIS%DERIVATIVES", i_val=nder, error=error) - CALL atom_response_basis(atom_info(in,im)%atom,delta,nder,iw,error) + CALL section_vals_val_get(atom_section,"PRINT%RESPONSE_BASIS%DELTA_CHARGE", r_val=delta) + CALL section_vals_val_get(atom_section,"PRINT%RESPONSE_BASIS%DERIVATIVES", i_val=nder) + CALL atom_response_basis(atom_info(in,im)%atom,delta,nder,iw) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%RESPONSE_BASIS",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%RESPONSE_BASIS") ! generate a UPF file iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%UPF_FILE",extension=".upf",& - file_position="REWIND",error=error) + file_position="REWIND") IF (iw>0) THEN - CALL atom_write_upf(atom_info(in,im)%atom,iw,error) + CALL atom_write_upf(atom_info(in,im)%atom,iw) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%UPF_FILE",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%UPF_FILE") END IF END DO @@ -448,31 +446,31 @@ SUBROUTINE atom_energy_opt(atom_section,error) ! clean up IF ( had_ae ) THEN - CALL atom_int_release(ae_int,error) - CALL atom_ppint_release(ae_int,error) - CALL atom_relint_release(ae_int,error) + CALL atom_int_release(ae_int) + CALL atom_ppint_release(ae_int) + CALL atom_relint_release(ae_int) END IF IF ( had_pp ) THEN - CALL atom_int_release(pp_int,error) - CALL atom_ppint_release(pp_int,error) - CALL atom_relint_release(pp_int,error) + CALL atom_int_release(pp_int) + CALL atom_ppint_release(pp_int) + CALL atom_relint_release(pp_int) END IF - CALL release_atom_basis(ae_basis,error) - CALL release_atom_basis(pp_basis,error) + CALL release_atom_basis(ae_basis) + CALL release_atom_basis(pp_basis) - CALL release_atom_potential(p_pot,error) - CALL release_atom_potential(ae_pot,error) + CALL release_atom_potential(p_pot) + CALL release_atom_potential(ae_pot) DO in = 1, n_rep DO im = 1, n_meth - CALL release_atom_type(atom_info(in,im)%atom,error) + CALL release_atom_type(atom_info(in,im)%atom) END DO END DO DEALLOCATE(atom_info,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(ae_pot,p_pot,ae_basis,pp_basis,ae_int,pp_int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -484,14 +482,12 @@ END SUBROUTINE atom_energy_opt !> \param delta ... !> \param nder ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_response_basis(atom,delta,nder,iw,error) + SUBROUTINE atom_response_basis(atom,delta,nder,iw) TYPE(atom_type), POINTER :: atom REAL(KIND=dp), INTENT(IN) :: delta INTEGER, INTENT(IN) :: nder, iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_response_basis', & routineP = moduleN//':'//routineN @@ -535,17 +531,17 @@ SUBROUTINE atom_response_basis(atom,delta,nder,iw,error) s1=SIZE(atom%orbitals%wfn,1) s2=SIZE(atom%orbitals%wfn,2) ALLOCATE(wfn(s1,s2,0:3,-nder:nder),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) s2=MAXVAL(state%maxn_occ)+nder ALLOCATE(rbasis(s1,s2,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) rbasis = 0._dp DO ider=-nder,nder dene = REAL(ider,KIND=dp)*delta - CPPostcondition(fhomo>ABS(dene), cp_failure_level, routineP, error, failure) + CPPostcondition(fhomo>ABS(dene), cp_failure_level, routineP,failure) state%occupation(lhomo,nhomo)=fhomo+dene - CALL calculate_atom(atom,iw=0,noguess=.TRUE.,error=error) + CALL calculate_atom(atom,iw=0,noguess=.TRUE.) wfn(:,:,:,ider) = atom%orbitals%wfn state%occupation(lhomo,nhomo)=fhomo END DO @@ -567,7 +563,7 @@ SUBROUTINE atom_response_basis(atom,delta,nder,iw,error) rbasis(:,i+3,l) = 0.125_dp*(wfn(:,i,l,3) - 3._dp*wfn(:,i,l,1) & + 3._dp*wfn(:,i,l,-1) - wfn(:,i,l,-3))/delta**3 CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT END DO @@ -585,7 +581,7 @@ SUBROUTINE atom_response_basis(atom,delta,nder,iw,error) ! check ALLOCATE(amat(n,n),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) amat(1:n,1:n) = MATMUL(TRANSPOSE(rbasis(1:m,1:n,l)),MATMUL(ovlp(1:m,1:m,l),rbasis(1:m,1:n,l))) DO i=1,n amat(i,i)=amat(i,i) - 1._dp @@ -594,7 +590,7 @@ SUBROUTINE atom_response_basis(atom,delta,nder,iw,error) WRITE(iw,'(A,G20.10)') " Orthogonality error ", MAXVAL(ABS(amat)) END IF DEALLOCATE(amat,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ! Quickstep normalization WRITE(iw,'(/,A,T30,I3)') " Angular momentum :",l @@ -611,7 +607,7 @@ SUBROUTINE atom_response_basis(atom,delta,nder,iw,error) END DO DEALLOCATE(wfn,rbasis,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) WRITE(iw,'(" ",79("*"))') @@ -620,13 +616,11 @@ END SUBROUTINE atom_response_basis !> \brief ... !> \param atom ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_write_upf(atom,iw,error) + SUBROUTINE atom_write_upf(atom,iw) TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_write_upf', & routineP = moduleN//':'//routineN @@ -646,14 +640,14 @@ SUBROUTINE atom_write_upf(atom,iw,error) IF(.NOT.atom%pp_calc) RETURN IF(atom%potential%ppot_type /= GTH_PSEUDO) RETURN pot => atom%potential%gth_pot - CPPostcondition(.NOT.pot%lsdpot, cp_failure_level, routineP, error, failure) + CPPostcondition(.NOT.pot%lsdpot, cp_failure_level, routineP,failure) WRITE(iw,'(A)') '' WRITE(iw,'(T4,A)') '' WRITE(iw,'(T8,A)') 'Converted from CP2K GTH format' WRITE(iw,'(T8,A)') '' - CALL atom_write_pseudo_param(pot,iw,error) + CALL atom_write_pseudo_param(pot,iw) WRITE(iw,'(T8,A)') '' WRITE(iw,'(T4,A)') '' WRITE(iw,'(T4,A)') '' ALLOCATE(corden(nr),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) - CALL atom_core_density(corden,pot,"RHO",atom%basis%grid%rad,error) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) + CALL atom_core_density(corden,pot,"RHO",atom%basis%grid%rad) IF(up) THEN WRITE(iw,'(T8,4ES25.12E3)') (corden(i),i=1,nr) ELSE WRITE(iw,'(T8,4ES25.12E3)') (corden(i),i=nr,1,-1) END IF DEALLOCATE(corden,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) WRITE(iw,'(T4,A)') '' END IF @@ -760,21 +754,21 @@ SUBROUTINE atom_write_upf(atom,iw,error) WRITE(iw,'(T8,A)') TRIM(string) WRITE(iw,'(T8,A)') 'columns="4">' ALLOCATE(locpot(nr),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) - CALL atom_local_potential(locpot,pot,atom%basis%grid%rad,error) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) + CALL atom_local_potential(locpot,pot,atom%basis%grid%rad) IF(up) THEN WRITE(iw,'(T8,4ES25.12E3)') (2.0_dp*locpot(i),i=1,nr) ELSE WRITE(iw,'(T8,4ES25.12E3)') (2.0_dp*locpot(i),i=nr,1,-1) END IF DEALLOCATE(locpot,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) WRITE(iw,'(T4,A)') '' ! nonlocal PP WRITE(iw,'(T4,A)') '' ALLOCATE(rp(nr),ef(nr),beta(nr),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ibeta = 0 DO l=0,3 IF(pot%nl(l) == 0) CYCLE @@ -806,10 +800,10 @@ SUBROUTINE atom_write_upf(atom,iw,error) END DO END DO DEALLOCATE(rp,ef,beta,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ! nonlocal PP matrix elements ALLOCATE(dij(nbeta,nbeta),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) dij = 0._dp DO l=0,3 IF(pot%nl(l) == 0) CYCLE @@ -822,12 +816,12 @@ SUBROUTINE atom_write_upf(atom,iw,error) WRITE(iw,'(T12,4ES25.12E3)') ((0.5_dp*dij(i,j),j=1,nbeta),i=1,nbeta) WRITE(iw,'(T8,A)') '' DEALLOCATE(dij,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) WRITE(iw,'(T4,A)') '' ! atomic wavefunctions ALLOCATE(beta(nr),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) WRITE(iw,'(T4,A)') '' nwfn=0 DO l=0,3 @@ -859,17 +853,17 @@ SUBROUTINE atom_write_upf(atom,iw,error) END DO WRITE(iw,'(T4,A)') '' DEALLOCATE(beta,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ! atomic charge ALLOCATE(dens(nr),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) WRITE(iw,'(T4,A)') '' CALL atom_density(dens,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,& - "RHO",atom%basis%grid%rad,error) + "RHO",atom%basis%grid%rad) IF(up) THEN WRITE(iw,'(T8,4ES25.12E3)') (4._dp*pi*dens(j)*atom%basis%grid%rad2(j),j=1,nr) ELSE @@ -877,7 +871,7 @@ SUBROUTINE atom_write_upf(atom,iw,error) END IF WRITE(iw,'(T4,A)') '' DEALLOCATE(dens,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) WRITE(iw,'(A)') '' diff --git a/src/atom_fit.F b/src/atom_fit.F index 5b37d42c7b..4e3d8ff214 100644 --- a/src/atom_fit.F +++ b/src/atom_fit.F @@ -62,15 +62,13 @@ MODULE atom_fit !> \param iunit ... !> \param powell_section ... !> \param results ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_fit_density (atom,num_gto,norder,iunit,powell_section,results,error) + SUBROUTINE atom_fit_density (atom,num_gto,norder,iunit,powell_section,results) TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: num_gto, norder, iunit TYPE(section_vals_type), OPTIONAL, & POINTER :: powell_section REAL(KIND=dp), DIMENSION(:), OPTIONAL :: results - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_fit_density', & routineP = moduleN//':'//routineN @@ -84,14 +82,14 @@ SUBROUTINE atom_fit_density (atom,num_gto,norder,iunit,powell_section,results,er failure = .FALSE. ALLOCATE(co(num_gto),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) co = 0._dp NULLIFY(density) - CALL create_opgrid(density,atom%basis%grid,error) + CALL create_opgrid(density,atom%basis%grid) CALL atom_denmat(atom%orbitals%pmat,atom%orbitals%wfn,atom%basis%nbas,atom%state%occupation,& - atom%state%maxl_occ,atom%state%maxn_occ,error) + atom%state%maxl_occ,atom%state%maxn_occ) CALL atom_density(density%op,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,& - typ="RHO",error=error) + typ="RHO") density%op = fourpi*density%op IF (norder /= 0) THEN density%op = density%op*atom%basis%grid%rad**norder @@ -102,9 +100,9 @@ SUBROUTINE atom_fit_density (atom,num_gto,norder,iunit,powell_section,results,er x(1) = 0.10_dp !starting point of geometric series x(2) = 2.00_dp !factor of series IF(PRESENT(powell_section)) THEN - CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend, error=error) - CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg, error=error) - CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun, error=error) + CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend) + CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg) + CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun) ELSE ostate%rhoend = 1.e-8_dp ostate%rhobeg = 5.e-2_dp @@ -122,7 +120,7 @@ SUBROUTINE atom_fit_density (atom,num_gto,norder,iunit,powell_section,results,er DO IF ( ostate%state == 2 ) THEN - CALL density_fit (density,atom,num_gto,x(1),x(2),co,ostate%f,error) + CALL density_fit (density,atom,num_gto,x(1),x(2),co,ostate%f) END IF IF ( ostate%state == -1 ) EXIT @@ -139,7 +137,7 @@ SUBROUTINE atom_fit_density (atom,num_gto,norder,iunit,powell_section,results,er ostate%state = 8 CALL powell_optimize (ostate%nvar, x, ostate) - CALL release_opgrid(density,error) + CALL release_opgrid(density) IF ( iunit > 0 ) THEN WRITE(iunit,'(" POWELL| Number of function evaluations",T71,I10)') ostate%nf @@ -152,14 +150,14 @@ SUBROUTINE atom_fit_density (atom,num_gto,norder,iunit,powell_section,results,er END IF IF(PRESENT(results)) THEN - CPPrecondition(SIZE(results)>=num_gto+2, cp_failure_level, routineP, error, failure) + CPPrecondition(SIZE(results)>=num_gto+2, cp_failure_level, routineP,failure) results(1) = x(1) results(2) = x(2) results(3:2+num_gto) = co(1:num_gto) END IF DEALLOCATE(co,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE atom_fit_density ! ***************************************************************************** @@ -169,17 +167,14 @@ END SUBROUTINE atom_fit_density !> \param pptype ... !> \param iunit ... !> \param powell_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& - error) + SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section) TYPE(atom_p_type), DIMENSION(:, :), & POINTER :: atom_info TYPE(atom_basis_type), POINTER :: basis LOGICAL, INTENT(IN) :: pptype INTEGER, INTENT(IN) :: iunit TYPE(section_vals_type), POINTER :: powell_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_fit_basis', & routineP = moduleN//':'//routineN @@ -199,22 +194,22 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& SELECT CASE (basis%basis_type) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (GTO_BASIS) IF ( basis%geometrical ) THEN ostate%nvar = 2 ALLOCATE(x(2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) x(1) = SQRT(basis%aval) x(2) = SQRT(basis%cval) ELSE ll = MAXVAL(basis%nprim(:)) ALLOCATE(xtob(ll,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) xtob = 0 ll = SUM(basis%nprim(:)) ALLOCATE(x(ll),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) x = 0._dp ll = 0 DO l=0,3 @@ -241,11 +236,11 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& CASE (STO_BASIS) ll = MAXVAL(basis%nbas(:)) ALLOCATE(xtob(ll,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) xtob = 0 ll = SUM(basis%nbas(:)) ALLOCATE(x(ll),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) x = 0._dp ll = 0 DO l=0,3 @@ -261,25 +256,25 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& END DO END SELECT - CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend, error=error) - CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg, error=error) - CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun, error=error) + CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend) + CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg) + CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun) n=SIZE(atom_info,1) m=SIZE(atom_info,2) ALLOCATE(wem(n,m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) wem = 1._dp - CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", explicit=explicit, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", explicit=explicit) IF(explicit) THEN - CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", r_vals=w, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", r_vals=w) DO i=1,MIN(SIZE(w),n) wem(i,:)=w(i)*wem(i,:) END DO END IF - CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", explicit=explicit, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", explicit=explicit) IF(explicit) THEN - CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", r_vals=w, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", r_vals=w) DO i=1,MIN(SIZE(w),m) wem(:,i)=w(i)*wem(:,i) END DO @@ -291,7 +286,7 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& END DO END DO DEALLOCATE(wem,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ostate%nf = 0 ostate%iprint = 1 @@ -311,7 +306,7 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& IF ( ostate%state == 2 ) THEN SELECT CASE (basis%basis_type) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (GTO_BASIS) IF ( basis%geometrical ) THEN basis%am = 0._dp @@ -369,7 +364,7 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& END DO END DO END SELECT - CALL basis_fit (atom_info,basis,pptype,ostate%f,0,error) + CALL basis_fit (atom_info,basis,pptype,ostate%f,0) fopt = MIN(fopt,ostate%f) END IF @@ -396,7 +391,7 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& ! x->basis SELECT CASE (basis%basis_type) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (GTO_BASIS) IF ( basis%geometrical ) THEN basis%am = 0._dp @@ -454,16 +449,16 @@ SUBROUTINE atom_fit_basis (atom_info,basis,pptype,iunit,powell_section,& END DO END DO END SELECT - CALL atom_print_basis(basis,iunit," Optimized Basis",error) - CALL atom_print_basis_file(basis,error) + CALL atom_print_basis(basis,iunit," Optimized Basis") + CALL atom_print_basis_file(basis) END IF DEALLOCATE(x,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) IF ( ALLOCATED(xtob) ) THEN DEALLOCATE(xtob,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF END SUBROUTINE atom_fit_basis @@ -474,15 +469,13 @@ END SUBROUTINE atom_fit_basis !> \param ppot ... !> \param iunit ... !> \param powell_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) + SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section) TYPE(atom_p_type), DIMENSION(:, :), & POINTER :: atom_info, atom_refs TYPE(atom_potential_type), POINTER :: ppot INTEGER, INTENT(IN) :: iunit TYPE(section_vals_type), POINTER :: powell_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_fit_pseudo', & routineP = moduleN//':'//routineN @@ -507,40 +500,40 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) failure = .FALSE. ! weights for the optimization - CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend, error=error) - CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg, error=error) - CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun, error=error) + CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend) + CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg) + CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun) - CALL section_vals_val_get(powell_section,"WEIGHT_POT_VALENCE", r_val=w_valence, error=error) - CALL section_vals_val_get(powell_section,"WEIGHT_POT_VIRTUAL", r_val=w_virt, error=error) - CALL section_vals_val_get(powell_section,"WEIGHT_POT_SEMICORE", r_val=w_semi, error=error) - CALL section_vals_val_get(powell_section,"WEIGHT_POT_NODE", r_val=w_node, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_POT_VALENCE", r_val=w_valence) + CALL section_vals_val_get(powell_section,"WEIGHT_POT_VIRTUAL", r_val=w_virt) + CALL section_vals_val_get(powell_section,"WEIGHT_POT_SEMICORE", r_val=w_semi) + CALL section_vals_val_get(powell_section,"WEIGHT_POT_NODE", r_val=w_node) - CALL section_vals_val_get(powell_section,"WEIGHT_PSIR0", r_val=w_psir0, error=error) - CALL section_vals_val_get(powell_section,"RCOV_MULTIPLICATION", r_val=rcm, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_PSIR0", r_val=w_psir0) + CALL section_vals_val_get(powell_section,"RCOV_MULTIPLICATION", r_val=rcm) - CALL section_vals_val_get(powell_section,"TARGET_POT_VALENCE", r_val=t_valence, error=error) - CALL section_vals_val_get(powell_section,"TARGET_POT_VIRTUAL", r_val=t_virt, error=error) - CALL section_vals_val_get(powell_section,"TARGET_POT_SEMICORE", r_val=t_semi, error=error) + CALL section_vals_val_get(powell_section,"TARGET_POT_VALENCE", r_val=t_valence) + CALL section_vals_val_get(powell_section,"TARGET_POT_VIRTUAL", r_val=t_virt) + CALL section_vals_val_get(powell_section,"TARGET_POT_SEMICORE", r_val=t_semi) n=SIZE(atom_info,1) m=SIZE(atom_info,2) ALLOCATE(wem(n,m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) wem = 1._dp ALLOCATE(pval(4,10,0:3,m,n),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) - CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", explicit=explicit, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", explicit=explicit) IF(explicit) THEN - CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", r_vals=w, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_ELECTRON_CONFIGURATION", r_vals=w) DO i=1,MIN(SIZE(w),n) wem(i,:)=w(i)*wem(i,:) END DO END IF - CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", explicit=explicit, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", explicit=explicit) IF(explicit) THEN - CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", r_vals=w, error=error) + CALL section_vals_val_get(powell_section,"WEIGHT_METHOD", r_vals=w) DO i=1,MIN(SIZE(w),m) wem(:,i)=w(i)*wem(:,i) END DO @@ -549,14 +542,14 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) CALL open_file(file_name="POWELL_RESULT",file_status="UNKNOWN",file_action="WRITE",unit_number=iw) ALLOCATE(xi(200),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) !decide here what to optimize - CALL get_pseudo_param(xi,ostate%nvar,ppot%gth_pot,error) + CALL get_pseudo_param(xi,ostate%nvar,ppot%gth_pot) ALLOCATE(x(ostate%nvar),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) x(1:ostate%nvar) = xi(1:ostate%nvar) DEALLOCATE(xi,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ostate%nf = 0 ostate%iprint = 1 @@ -583,10 +576,10 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) np = atom%state%maxn_calc(l) DO k=1,np CALL atom_orbital_max(rmax,atom_refs(i,j)%atom%orbitals%wfn(:,ncore(l)+k,l),& - rcov,l,atom_refs(i,j)%atom%basis,error) + rcov,l,atom_refs(i,j)%atom%basis) atom%orbitals%rcmax(k,l,1) = MAX(rcov,rmax) CALL atom_orbital_charge(charge,atom_refs(i,j)%atom%orbitals%wfn(:,ncore(l)+k,l),& - atom%orbitals%rcmax(k,l,1),l,atom_refs(i,j)%atom%basis,error) + atom%orbitals%rcmax(k,l,1),l,atom_refs(i,j)%atom%basis) atom%orbitals%refene(k,l,1) = atom_refs(i,j)%atom%orbitals%ener(ncore(l)+k,l) atom%orbitals%refchg(k,l,1) = charge IF ( k > atom%state%maxn_occ(l) ) THEN @@ -625,17 +618,17 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) np = atom%state%maxn_calc(l) DO k=1,np CALL atom_orbital_max(rmax,atom_refs(i,j)%atom%orbitals%wfna(:,ncore(l)+k,l),& - rcov,l,atom_refs(i,j)%atom%basis,error) + rcov,l,atom_refs(i,j)%atom%basis) atom%orbitals%rcmax(k,l,1) = MAX(rcov,rmax) CALL atom_orbital_max(rmax,atom_refs(i,j)%atom%orbitals%wfnb(:,ncore(l)+k,l),& - rcov,l,atom_refs(i,j)%atom%basis,error) + rcov,l,atom_refs(i,j)%atom%basis) atom%orbitals%rcmax(k,l,2) = MAX(rcov,rmax) CALL atom_orbital_charge(charge,atom_refs(i,j)%atom%orbitals%wfna(:,ncore(l)+k,l),& - atom%orbitals%rcmax(k,l,1),l,atom_refs(i,j)%atom%basis,error) + atom%orbitals%rcmax(k,l,1),l,atom_refs(i,j)%atom%basis) atom%orbitals%refene(k,l,1) = atom_refs(i,j)%atom%orbitals%enera(ncore(l)+k,l) atom%orbitals%refchg(k,l,1) = charge CALL atom_orbital_charge(charge,atom_refs(i,j)%atom%orbitals%wfnb(:,ncore(l)+k,l),& - atom%orbitals%rcmax(k,l,1),l,atom_refs(i,j)%atom%basis,error) + atom%orbitals%rcmax(k,l,1),l,atom_refs(i,j)%atom%basis) atom%orbitals%refene(k,l,2) = atom_refs(i,j)%atom%orbitals%enerb(ncore(l)+k,l) atom%orbitals%refchg(k,l,2) = charge ! the following assignments could be further specialized @@ -669,17 +662,17 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) END DO END DO END IF - CALL calculate_atom(atom,0,error=error) + CALL calculate_atom(atom,0) END IF END DO END DO DEALLOCATE(wem,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) WRITE(iunit,'(/," POWELL| Initial errors of target values")') - CALL put_pseudo_param(x,ppot%gth_pot,error) - CALL pseudo_fit(atom_info,ppot,ostate%f,pval,error) + CALL put_pseudo_param(x,ppot%gth_pot) + CALL pseudo_fit(atom_info,ppot,ostate%f,pval) DO i=1,SIZE(atom_info,1) DO j=1,SIZE(atom_info,2) atom => atom_info(i,j)%atom @@ -696,7 +689,7 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) eig = atom%orbitals%ener(k,l) deig = eig - atom%orbitals%refene(k,l,1) peig = pval(1,k,l,j,i)/ostate%f * 100._dp - CALL atom_orbital_charge(charge,atom%orbitals%wfn(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfn(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis) drho = charge - atom%orbitals%refchg(k,l,1) pchg = pval(2,k,l,j,i)/ostate%f * 100._dp WRITE(iunit,'(I5,I5,F14.2,F21.10,F14.6,"[",I2,"]",F13.6,"[",I2,"]")') & @@ -715,7 +708,7 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) eig = atom%orbitals%enera(k,l) deig = eig - atom%orbitals%refene(k,l,1) peig = pval(1,k,l,j,i)/ostate%f * 100._dp - CALL atom_orbital_charge(charge,atom%orbitals%wfna(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfna(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis) drho = charge - atom%orbitals%refchg(k,l,1) pchg = pval(2,k,l,j,i)/ostate%f * 100._dp WRITE(iunit,'(I5,I5,2X,A5,F11.2,F19.10,F13.6,"[",I2,"]",F12.6,"[",I2,"]")') & @@ -724,7 +717,7 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) eig = atom%orbitals%enerb(k,l) deig = eig - atom%orbitals%refene(k,l,2) peig = pval(3,k,l,j,i)/ostate%f * 100._dp - CALL atom_orbital_charge(charge,atom%orbitals%wfnb(:,k,l),atom%orbitals%rcmax(k,l,2),l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfnb(:,k,l),atom%orbitals%rcmax(k,l,2),l,atom%basis) drho = charge - atom%orbitals%refchg(k,l,2) pchg = pval(4,k,l,j,i)/ostate%f * 100._dp WRITE(iunit,'(I5,I5,2X,A5,F11.2,F19.10,F13.6,"[",I2,"]",F12.6,"[",I2,"]")') & @@ -743,8 +736,8 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) DO IF ( ostate%state == 2 ) THEN - CALL put_pseudo_param(x,ppot%gth_pot,error) - CALL pseudo_fit (atom_info,ppot,ostate%f,pval,error) + CALL put_pseudo_param(x,ppot%gth_pot) + CALL pseudo_fit (atom_info,ppot,ostate%f,pval) fopt = MIN(fopt,ostate%f) END IF @@ -758,8 +751,8 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) IF ( MOD(ostate%nf,n10) == 0 .AND. iunit > 0 ) THEN WRITE(iunit,'(" POWELL| Reached",i4,"% of maximal function calls",T61,F20.10)') & INT(REAL(ostate%nf,dp)/REAL(ostate%maxfun,dp)*100._dp), fopt - CALL put_pseudo_param(ostate%xopt,ppot%gth_pot,error) - CALL atom_write_pseudo_param(ppot%gth_pot,error=error) + CALL put_pseudo_param(ostate%xopt,ppot%gth_pot) + CALL atom_write_pseudo_param(ppot%gth_pot) END IF WRITE(iw,*) ostate%nf,ostate%f,x(1:ostate%nvar) @@ -768,15 +761,15 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) ostate%state = 8 CALL powell_optimize (ostate%nvar, x, ostate) - CALL put_pseudo_param(x,ppot%gth_pot,error) - CALL atom_write_pseudo_param(ppot%gth_pot,error=error) + CALL put_pseudo_param(x,ppot%gth_pot) + CALL atom_write_pseudo_param(ppot%gth_pot) IF ( iunit > 0 ) THEN WRITE(iunit,'(" POWELL| Number of function evaluations",T71,I10)') ostate%nf WRITE(iunit,'(" POWELL| Final value of function",T61,F20.10)') ostate%fopt - CALL put_pseudo_param(x,ppot%gth_pot,error) - CALL pseudo_fit(atom_info,ppot,ostate%f,pval,error) + CALL put_pseudo_param(x,ppot%gth_pot) + CALL pseudo_fit(atom_info,ppot,ostate%f,pval) WRITE(iunit,'(/," POWELL| Final errors of target values")') DO i=1,SIZE(atom_info,1) @@ -795,7 +788,7 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) eig = atom%orbitals%ener(k,l) deig = eig - atom%orbitals%refene(k,l,1) peig = pval(1,k,l,j,i)/ostate%f * 100._dp - CALL atom_orbital_charge(charge,atom%orbitals%wfn(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfn(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis) drho = charge - atom%orbitals%refchg(k,l,1) pchg = pval(2,k,l,j,i)/ostate%f * 100._dp WRITE(iunit,'(I5,I5,F14.2,F21.10,F14.6,"[",I2,"]",F13.6,"[",I2,"]")') & @@ -805,7 +798,7 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) END DO np = atom%state%maxn_calc(0) DO k=1,np - CALL atom_wfnr0(pv,atom%orbitals%wfn(:,k,0),atom%basis,error) + CALL atom_wfnr0(pv,atom%orbitals%wfn(:,k,0),atom%basis) pchg = atom%weight*atom%orbitals%wpsir0(k,1)*pv*pv/ostate%f * 100._dp WRITE(iunit,'(" s-states"," N=",I5,T40,"Wavefunction at r=0:",T64,F13.6,"[",I2,"]")') k,pv,NINT(pchg) END DO @@ -820,7 +813,7 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) eig = atom%orbitals%enera(k,l) deig = eig - atom%orbitals%refene(k,l,1) peig = pval(1,k,l,j,i)/ostate%f * 100._dp - CALL atom_orbital_charge(charge,atom%orbitals%wfna(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfna(:,k,l),atom%orbitals%rcmax(k,l,1),l,atom%basis) drho = charge - atom%orbitals%refchg(k,l,1) pchg = pval(2,k,l,j,i)/ostate%f * 100._dp WRITE(iunit,'(I5,I5,A,F11.2,F20.10,F13.6,"[",I2,"]",F11.6,"[",I2,"]")') & @@ -829,7 +822,7 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) eig = atom%orbitals%enerb(k,l) deig = eig - atom%orbitals%refene(k,l,2) peig = pval(3,k,l,j,i)/ostate%f * 100._dp - CALL atom_orbital_charge(charge,atom%orbitals%wfnb(:,k,l),atom%orbitals%rcmax(k,l,2),l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfnb(:,k,l),atom%orbitals%rcmax(k,l,2),l,atom%basis) drho = charge - atom%orbitals%refchg(k,l,2) pchg = pval(4,k,l,j,i)/ostate%f * 100._dp WRITE(iunit,'(I5,I5,A,F11.2,F20.10,F13.6,"[",I2,"]",F11.6,"[",I2,"]")') & @@ -839,10 +832,10 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) END DO np = atom%state%maxn_calc(0) DO k=1,np - CALL atom_wfnr0(pv,atom%orbitals%wfna(:,k,0),atom%basis,error) + CALL atom_wfnr0(pv,atom%orbitals%wfna(:,k,0),atom%basis) pchg = atom%weight*atom%orbitals%wpsir0(k,1)*pv*pv/ostate%f * 100._dp WRITE(iunit,'(" s-states"," N=",I5,T35,"Alpha Wavefunction at r=0:",T64,F13.6,"[",I2,"]")') k,pv,NINT(pchg) - CALL atom_wfnr0(pv,atom%orbitals%wfnb(:,k,0),atom%basis,error) + CALL atom_wfnr0(pv,atom%orbitals%wfnb(:,k,0),atom%basis) pchg = atom%weight*atom%orbitals%wpsir0(k,2)*pv*pv/ostate%f * 100._dp WRITE(iunit,'(" s-states"," N=",I5,T36,"Beta Wavefunction at r=0:",T64,F13.6,"[",I2,"]")') k,pv,NINT(pchg) END DO @@ -853,11 +846,11 @@ SUBROUTINE atom_fit_pseudo (atom_info,atom_refs,ppot,iunit,powell_section,error) END IF DEALLOCATE(x,pval,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) IF ( ALLOCATED(xtob) ) THEN DEALLOCATE(xtob,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF CALL close_file(unit_number=iw) @@ -872,16 +865,14 @@ END SUBROUTINE atom_fit_pseudo !> \param cval ... !> \param co ... !> \param aerr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE density_fit (density,atom,n,aval,cval,co,aerr,error) + SUBROUTINE density_fit (density,atom,n,aval,cval,co,aerr) TYPE(opgrid_type), POINTER :: density TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: n REAL(dp), INTENT(IN) :: aval, cval REAL(dp), DIMENSION(:), INTENT(INOUT) :: co REAL(dp), INTENT(OUT) :: aerr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'density_fit', & routineP = moduleN//':'//routineN @@ -896,10 +887,10 @@ SUBROUTINE density_fit (density,atom,n,aval,cval,co,aerr,error) failure = .FALSE. ALLOCATE(pe(n),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) nr = atom%basis%grid%nr ALLOCATE (bf(nr,n),den(nr),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) bf = 0._dp DO i=1,n @@ -916,7 +907,7 @@ SUBROUTINE density_fit (density,atom,n,aval,cval,co,aerr,error) ! allocate vectors and matrices for overlaps ALLOCATE(tval(n+1,1),uval(n),smat(n+1,n+1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DO i=1,n uval(i) = (pi/pe(i))**1.5_dp tval(i,1) = integrate_grid(density%op,bf(:,i),atom%basis%grid) @@ -933,7 +924,7 @@ SUBROUTINE density_fit (density,atom,n,aval,cval,co,aerr,error) smat(n+1,n+1) = 0._dp CALL lapack_sgesv ( n+1, 1, smat, n+1, ipiv, tval, n+1, info ) - CPPostcondition(info==0, cp_failure_level, routineP, error, failure) + CPPostcondition(info==0, cp_failure_level, routineP,failure) co(1:n) = tval(1:n,1) ! calculate density @@ -946,10 +937,10 @@ SUBROUTINE density_fit (density,atom,n,aval,cval,co,aerr,error) aerr = SQRT(integrate_grid(den,atom%basis%grid)) DEALLOCATE(pe,bf,den,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(tval,uval,smat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE density_fit ! ***************************************************************************** @@ -959,16 +950,14 @@ END SUBROUTINE density_fit !> \param pptype ... !> \param afun ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE basis_fit (atom_info,basis,pptype,afun,iw,error) + SUBROUTINE basis_fit (atom_info,basis,pptype,afun,iw) TYPE(atom_p_type), DIMENSION(:, :), & POINTER :: atom_info TYPE(atom_basis_type), POINTER :: basis LOGICAL, INTENT(IN) :: pptype REAL(dp), INTENT(OUT) :: afun INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'basis_fit', & routineP = moduleN//':'//routineN @@ -983,7 +972,7 @@ SUBROUTINE basis_fit (atom_info,basis,pptype,afun,iw,error) failure = .FALSE. ALLOCATE(atint,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) nn = SIZE(atom_info,1) nm = SIZE(atom_info,2) @@ -1010,14 +999,14 @@ SUBROUTINE basis_fit (atom_info,basis,pptype,afun,iw,error) IF(ASSOCIATED(pot)) EXIT END DO ! general integrals - CALL atom_int_setup(atint,basis,potential=pot,eri_coulomb=eri_c,eri_exchange=eri_e,error=error) + CALL atom_int_setup(atint,basis,potential=pot,eri_coulomb=eri_c,eri_exchange=eri_e) ! potential - CALL atom_ppint_setup(atint,basis,potential=pot,error=error) + CALL atom_ppint_setup(atint,basis,potential=pot) IF ( pptype ) THEN NULLIFY(atint%tzora,atint%hdkh) ELSE ! relativistic correction terms - CALL atom_relint_setup(atint,basis,reltyp,zcore=REAL(zval,dp),error=error) + CALL atom_relint_setup(atint,basis,reltyp,zcore=REAL(zval,dp)) END IF afun = 0._dp @@ -1027,21 +1016,21 @@ SUBROUTINE basis_fit (atom_info,basis,pptype,afun,iw,error) atom => atom_info(in,im)%atom IF(atom_consistent_method(atom%method_type,atom%state%multiplicity)) THEN IF ( pptype .EQV. atom%pp_calc ) THEN - CALL set_atom(atom,basis=basis,error=error) - CALL set_atom(atom,integrals=atint,error=error) - CALL calculate_atom(atom,iw,error=error) + CALL set_atom(atom,basis=basis) + CALL set_atom(atom,integrals=atint) + CALL calculate_atom(atom,iw) afun =afun + atom%energy%etot*atom%weight END IF END IF END DO END DO - CALL atom_int_release(atint,error) - CALL atom_ppint_release(atint,error) - CALL atom_relint_release(atint,error) + CALL atom_int_release(atint) + CALL atom_ppint_release(atint) + CALL atom_relint_release(atint) DEALLOCATE(atint,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE basis_fit ! ***************************************************************************** @@ -1050,16 +1039,14 @@ END SUBROUTINE basis_fit !> \param ppot ... !> \param afun ... !> \param pval ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pseudo_fit (atom_info,ppot,afun,pval,error) + SUBROUTINE pseudo_fit (atom_info,ppot,afun,pval) TYPE(atom_p_type), DIMENSION(:, :), & POINTER :: atom_info TYPE(atom_potential_type), POINTER :: ppot REAL(dp), INTENT(OUT) :: afun REAL(dp), DIMENSION(:, :, 0:, :, :), & INTENT(OUT) :: pval - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pseudo_fit', & routineP = moduleN//':'//routineN @@ -1074,15 +1061,15 @@ SUBROUTINE pseudo_fit (atom_info,ppot,afun,pval,error) pval = 0._dp pp_int => atom_info(1,1)%atom%integrals - CALL atom_ppint_release(pp_int,error) - CALL atom_ppint_setup(pp_int,atom_info(1,1)%atom%basis,potential=ppot,error=error) + CALL atom_ppint_release(pp_int) + CALL atom_ppint_setup(pp_int,atom_info(1,1)%atom%basis,potential=ppot) DO i=1,SIZE(atom_info,1) DO j=1,SIZE(atom_info,2) atom => atom_info(i,j)%atom IF(atom_consistent_method(atom%method_type,atom%state%multiplicity)) THEN - CALL set_atom(atom,integrals=pp_int,potential=ppot,error=error) - CALL calculate_atom(atom,0,noguess=.TRUE.,error=error) + CALL set_atom(atom,integrals=pp_int,potential=ppot) + CALL calculate_atom(atom,0,noguess=.TRUE.) DO l=0,atom%state%maxl_calc n = atom%state%maxn_calc(l) DO k=1,n @@ -1096,18 +1083,18 @@ SUBROUTINE pseudo_fit (atom_info,ppot,afun,pval,error) afun = afun + pv pval(1,k,l,j,i) = pv IF(atom%orbitals%wrefchg(k,l,1) > 0._dp) THEN - CALL atom_orbital_charge(charge,atom%orbitals%wfn(:,k,l),rcov,l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfn(:,k,l),rcov,l,atom%basis) pv = 0.01_dp*atom%weight*atom%orbitals%wrefchg(k,l,1)*(charge-atom%orbitals%refchg(k,l,1))**2 afun = afun + pv pval(2,k,l,j,i) = pv END IF IF(atom%orbitals%wrefnod(k,l,1) > 0._dp) THEN - CALL atom_orbital_nodes(node,atom%orbitals%wfn(:,k,l),2._dp*rcov,l,atom%basis,error) + CALL atom_orbital_nodes(node,atom%orbitals%wfn(:,k,l),2._dp*rcov,l,atom%basis) afun = afun + atom%weight*atom%orbitals%wrefnod(k,l,1)*ABS(REAL(node,dp)-atom%orbitals%refnod(k,l,1)) END IF IF ( l==0 ) THEN IF(atom%orbitals%wpsir0(k,1) > 0._dp) THEN - CALL atom_wfnr0(pv,atom%orbitals%wfn(:,k,l),atom%basis,error) + CALL atom_wfnr0(pv,atom%orbitals%wfn(:,k,l),atom%basis) pv = atom%weight*atom%orbitals%wpsir0(k,1)*pv*pv afun = afun + pv END IF @@ -1129,33 +1116,33 @@ SUBROUTINE pseudo_fit (atom_info,ppot,afun,pval,error) afun = afun + pv pval(3,k,l,j,i) = pv IF(atom%orbitals%wrefchg(k,l,1) > 0._dp) THEN - CALL atom_orbital_charge(charge,atom%orbitals%wfna(:,k,l),rcov1,l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfna(:,k,l),rcov1,l,atom%basis) pv = 0.01_dp*atom%weight*atom%orbitals%wrefchg(k,l,1)*(charge-atom%orbitals%refchg(k,l,1))**2 afun = afun + pv pval(2,k,l,j,i) = pv END IF IF(atom%orbitals%wrefchg(k,l,2) > 0._dp) THEN - CALL atom_orbital_charge(charge,atom%orbitals%wfnb(:,k,l),rcov2,l,atom%basis,error) + CALL atom_orbital_charge(charge,atom%orbitals%wfnb(:,k,l),rcov2,l,atom%basis) pv = 0.01_dp*atom%weight*atom%orbitals%wrefchg(k,l,2)*(charge-atom%orbitals%refchg(k,l,2))**2 afun = afun + pv pval(4,k,l,j,i) = pv END IF IF(atom%orbitals%wrefnod(k,l,1) > 0._dp) THEN - CALL atom_orbital_nodes(node,atom%orbitals%wfna(:,k,l),2._dp*rcov1,l,atom%basis,error) + CALL atom_orbital_nodes(node,atom%orbitals%wfna(:,k,l),2._dp*rcov1,l,atom%basis) afun = afun + atom%weight*atom%orbitals%wrefnod(k,l,1)*ABS(REAL(node,dp)-atom%orbitals%refnod(k,l,1)) END IF IF(atom%orbitals%wrefnod(k,l,2) > 0._dp) THEN - CALL atom_orbital_nodes(node,atom%orbitals%wfnb(:,k,l),2._dp*rcov2,l,atom%basis,error) + CALL atom_orbital_nodes(node,atom%orbitals%wfnb(:,k,l),2._dp*rcov2,l,atom%basis) afun = afun + atom%weight*atom%orbitals%wrefnod(k,l,2)*ABS(REAL(node,dp)-atom%orbitals%refnod(k,l,2)) END IF IF ( l==0 ) THEN IF(atom%orbitals%wpsir0(k,1) > 0._dp) THEN - CALL atom_wfnr0(pv,atom%orbitals%wfna(:,k,l),atom%basis,error) + CALL atom_wfnr0(pv,atom%orbitals%wfna(:,k,l),atom%basis) pv = atom%weight*atom%orbitals%wpsir0(k,1)*pv*pv afun = afun + pv END IF IF(atom%orbitals%wpsir0(k,2) > 0._dp) THEN - CALL atom_wfnr0(pv,atom%orbitals%wfnb(:,k,l),atom%basis,error) + CALL atom_wfnr0(pv,atom%orbitals%wfnb(:,k,l),atom%basis) pv = atom%weight*atom%orbitals%wpsir0(k,2)*pv*pv afun = afun + pv END IF @@ -1173,13 +1160,11 @@ END SUBROUTINE pseudo_fit !> \param pvec ... !> \param nval ... !> \param gthpot ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_pseudo_param (pvec,nval,gthpot,error) + SUBROUTINE get_pseudo_param (pvec,nval,gthpot) REAL(KIND=dp), DIMENSION(:), INTENT(out) :: pvec INTEGER, INTENT(out) :: nval TYPE(atom_gthpot_type), INTENT(in) :: gthpot - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_pseudo_param', & routineP = moduleN//':'//routineN @@ -1251,12 +1236,10 @@ END SUBROUTINE get_pseudo_param !> \brief ... !> \param pvec ... !> \param gthpot ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE put_pseudo_param (pvec,gthpot,error) + SUBROUTINE put_pseudo_param (pvec,gthpot) REAL(KIND=dp), DIMENSION(:), INTENT(in) :: pvec TYPE(atom_gthpot_type), INTENT(inout) :: gthpot - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'put_pseudo_param', & routineP = moduleN//':'//routineN @@ -1354,15 +1337,13 @@ END FUNCTION rcpro !> \param iunit ... !> \param powell_section ... !> \param results ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_fit_kgpot (atom,num_gau,num_pol,iunit,powell_section,results,error) + SUBROUTINE atom_fit_kgpot (atom,num_gau,num_pol,iunit,powell_section,results) TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: num_gau, num_pol, iunit TYPE(section_vals_type), OPTIONAL, & POINTER :: powell_section REAL(KIND=dp), DIMENSION(:), OPTIONAL :: results - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_fit_kgpot', & routineP = moduleN//':'//routineN @@ -1378,18 +1359,18 @@ SUBROUTINE atom_fit_kgpot (atom,num_gau,num_pol,iunit,powell_section,results,err failure = .FALSE. ! at least one parameter to be optimized - CPPrecondition(num_pol*num_gau > 0, cp_failure_level, routineP, error, failure) + CPPrecondition(num_pol*num_gau > 0, cp_failure_level, routineP,failure) ALLOCATE(co(num_pol+1,num_gau),x(num_pol*num_gau+num_gau),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) co = 0._dp ! calculate density NULLIFY(density) - CALL create_opgrid(density,atom%basis%grid,error) + CALL create_opgrid(density,atom%basis%grid) CALL atom_denmat(atom%orbitals%pmat,atom%orbitals%wfn,atom%basis%nbas,atom%state%occupation,& - atom%state%maxl_occ,atom%state%maxn_occ,error) - CALL atom_density(density%op,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) + atom%state%maxl_occ,atom%state%maxn_occ) + CALL atom_density(density%op,atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO") ! target functional density%op = t23*(0.3_dp*(3.0_dp*pi*pi)**t23)*density%op**t23 @@ -1406,9 +1387,9 @@ SUBROUTINE atom_fit_kgpot (atom,num_gau,num_pol,iunit,powell_section,results,err CALL putvar(x,co,num_pol,num_gau) IF(PRESENT(powell_section)) THEN - CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend, error=error) - CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg, error=error) - CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun, error=error) + CALL section_vals_val_get(powell_section,"ACCURACY", r_val=ostate%rhoend) + CALL section_vals_val_get(powell_section,"STEP_SIZE", r_val=ostate%rhobeg) + CALL section_vals_val_get(powell_section,"MAX_FUN", i_val=ostate%maxfun) ELSE ostate%rhoend = 1.e-8_dp ostate%rhobeg = 5.e-2_dp @@ -1428,7 +1409,7 @@ SUBROUTINE atom_fit_kgpot (atom,num_gau,num_pol,iunit,powell_section,results,err IF ( ostate%state == 2 ) THEN CALL getvar(x,co,num_pol,num_gau) - CALL kgpot_fit (density,num_gau,num_pol,co,ostate%f,error) + CALL kgpot_fit (density,num_gau,num_pol,co,ostate%f) END IF IF ( ostate%state == -1 ) EXIT @@ -1446,7 +1427,7 @@ SUBROUTINE atom_fit_kgpot (atom,num_gau,num_pol,iunit,powell_section,results,err CALL powell_optimize (ostate%nvar, x, ostate) CALL getvar(x,co,num_pol,num_gau) - CALL release_opgrid(density,error) + CALL release_opgrid(density) IF ( iunit > 0 ) THEN WRITE(iunit,'(" POWELL| Number of function evaluations",T71,I10)') ostate%nf @@ -1467,12 +1448,12 @@ SUBROUTINE atom_fit_kgpot (atom,num_gau,num_pol,iunit,powell_section,results,err CALL close_file(unit_number=iw) IF(PRESENT(results)) THEN - CPPrecondition(SIZE(results)>=SIZE(x), cp_failure_level, routineP, error, failure) + CPPrecondition(SIZE(results)>=SIZE(x), cp_failure_level, routineP,failure) results = x END IF DEALLOCATE(co,x,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE atom_fit_kgpot @@ -1483,14 +1464,12 @@ END SUBROUTINE atom_fit_kgpot !> \param np ... !> \param cval ... !> \param aerr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kgpot_fit (kgpot,ng,np,cval,aerr,error) + SUBROUTINE kgpot_fit (kgpot,ng,np,cval,aerr) TYPE(opgrid_type), POINTER :: kgpot INTEGER, INTENT(IN) :: ng, np REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: cval REAL(dp), INTENT(OUT) :: aerr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kgpot_fit', & routineP = moduleN//':'//routineN @@ -1502,7 +1481,7 @@ SUBROUTINE kgpot_fit (kgpot,ng,np,cval,aerr,error) n = kgpot%grid%nr ALLOCATE(pval(n),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) pval = 0.0_dp DO i=1,n DO ig=1,ng @@ -1518,7 +1497,7 @@ SUBROUTINE kgpot_fit (kgpot,ng,np,cval,aerr,error) aerr = fourpi*SUM(pval(1:n)*kgpot%grid%wr(1:n)) DEALLOCATE(pval,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE kgpot_fit diff --git a/src/atom_kind_orbitals.F b/src/atom_kind_orbitals.F index 56d16524dd..5fc307fbc3 100644 --- a/src/atom_kind_orbitals.F +++ b/src/atom_kind_orbitals.F @@ -72,10 +72,9 @@ MODULE atom_kind_orbitals !> \param ispin ... !> \param confine ... !> \param xc_section ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confine,& - xc_section,error) + xc_section) TYPE(atomic_kind_type), INTENT(IN) :: atomic_kind TYPE(qs_kind_type), INTENT(IN) :: qs_kind INTEGER, INTENT(IN), OPTIONAL :: iunit @@ -85,7 +84,6 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi LOGICAL, INTENT(IN), OPTIONAL :: confine TYPE(section_vals_type), OPTIONAL, & POINTER :: xc_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_atomic_orbitals', & routineP = moduleN//':'//routineN @@ -124,7 +122,7 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi failure = .FALSE. NULLIFY(atom) - CALL create_atom_type(atom,error) + CALL create_atom_type(atom) IF(PRESENT(xc_section)) THEN atom%xc_section => xc_section @@ -137,13 +135,13 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi CALL get_qs_kind(qs_kind,zeff=zeff,& basis_set=orb_basis_set,& all_potential=all_potential,& - gth_potential=gth_potential, error=error) + gth_potential=gth_potential) !!RZK CALL get_qs_kind(qs_kind,& !!RZK bs_occupation=bs_occupation,& !!RZK addel=addel,laddel=laddel,naddel=naddel) - CPPostcondition(ASSOCIATED(orb_basis_set), cp_failure_level, routineP, error, failure) + CPPostcondition(ASSOCIATED(orb_basis_set), cp_failure_level, routineP,failure) atom%z = z CALL set_atom(atom,& @@ -154,11 +152,10 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi method_type=do_rks_atom,& relativistic=do_nonrel_atom,& coulomb_integral_type=do_numeric,& - exchange_integral_type=do_numeric,& - error=error) + exchange_integral_type=do_numeric) ALLOCATE (potential,basis,integrals,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) IF ( ASSOCIATED(gth_potential) ) THEN potential%ppot_type=gth_pseudo @@ -261,7 +258,7 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi potential%gth_pot%cval_nlcc(1:4,1:nexp_nlcc) = cval_nlcc(1:4,1:nexp_nlcc) END IF - CALL set_atom(atom,zcore=NINT(zeff),potential=potential,error=error) + CALL set_atom(atom,zcore=NINT(zeff),potential=potential) ELSE potential%ppot_type=no_pseudo IF ( PRESENT(confine) ) THEN @@ -272,7 +269,7 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi potential%acon=0.1_dp potential%rcon=2.0_dp*ptable(z)%vdw_radius*bohr potential%scon=2.0_dp - CALL set_atom(atom,zcore=z,potential=potential,error=error) + CALL set_atom(atom,zcore=z,potential=potential) END IF CALL get_gto_basis_set(orb_basis_set,& @@ -282,7 +279,7 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi NULLIFY(grid) ngp = 400 quadtype = do_gapw_log - CALL allocate_grid_atom(grid,error) + CALL allocate_grid_atom(grid) CALL create_grid_atom(grid,ngp,1,1,0,quadtype) grid%nr = ngp basis%grid => grid @@ -305,7 +302,7 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi IF ( l <= 3 ) THEN basis%nbas(l) = basis%nbas(l)+1 k = basis%nbas(l) - CPPostcondition(k<=100, cp_failure_level, routineP, error, failure) + CPPostcondition(k<=100, cp_failure_level, routineP,failure) set_index(l,k) = i shell_index(l,k) = j END IF @@ -315,10 +312,10 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi nj = MAXVAL(basis%nprim) ns = MAXVAL(basis%nbas) ALLOCATE (basis%am(nj,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%am = 0._dp ALLOCATE (basis%cm(nj,ns,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%cm = 0._dp DO j=0,3 nj = 0 @@ -345,9 +342,9 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi nr = basis%grid%nr m = MAXVAL(basis%nbas) ALLOCATE (basis%bf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE (basis%dbf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%bf = 0._dp basis%dbf = 0._dp @@ -366,7 +363,7 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi END DO END DO - CALL set_atom(atom,basis=basis,error=error) + CALL set_atom(atom,basis=basis) ! optimization defaults atom%optimization%damping = 0.2_dp @@ -381,11 +378,10 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi ispin=ispin, & ncalc=ncalc, & ncore=ncore, & - nelem=nelem, & - error=error) + nelem=nelem) ALLOCATE (atom%state,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) atom%state%core = 0._dp atom%state%core(0:3,1:7) = REAL(ncore(0:3,1:7),dp) @@ -413,34 +409,34 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi ! general integrals CALL atom_int_setup(integrals,basis,potential=atom%potential,& eri_coulomb=(atom%coulomb_integral_type==do_analytic),& - eri_exchange=(atom%exchange_integral_type==do_analytic),error=error) + eri_exchange=(atom%exchange_integral_type==do_analytic)) ! potential - CALL atom_ppint_setup(integrals,basis,potential=atom%potential,error=error) + CALL atom_ppint_setup(integrals,basis,potential=atom%potential) ! relativistic correction terms NULLIFY(integrals%tzora,integrals%hdkh) - CALL atom_relint_setup(integrals,basis,atom%relativistic,zcore=REAL(atom%zcore,dp),error=error) - CALL set_atom(atom,integrals=integrals,error=error) + CALL atom_relint_setup(integrals,basis,atom%relativistic,zcore=REAL(atom%zcore,dp)) + CALL set_atom(atom,integrals=integrals) NULLIFY(orbitals) mo = MAXVAL(atom%state%maxn_calc) mb = MAXVAL(atom%basis%nbas) - CALL create_atom_orbs(orbitals,mb,mo,error) - CALL set_atom(atom,orbitals=orbitals,error=error) + CALL create_atom_orbs(orbitals,mb,mo) + CALL set_atom(atom,orbitals=orbitals) IF(PRESENT(iunit)) THEN - CALL calculate_atom(atom,iunit,error=error) + CALL calculate_atom(atom,iunit) ELSE - CALL calculate_atom(atom,-1,error=error) + CALL calculate_atom(atom,-1) END IF IF (PRESENT(pmat)) THEN ! recover density matrix in CP2K/GPW order and normalization IF(ASSOCIATED(pmat)) THEN DEALLOCATE (pmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF ALLOCATE (pmat(nsgf,nsgf),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) pmat = 0._dp DO l=0,3 ll = 2*l @@ -458,15 +454,15 @@ SUBROUTINE calculate_atomic_orbitals (atomic_kind,qs_kind,iunit,pmat,ispin,confi END IF ! clean up - CALL atom_int_release(integrals,error) - CALL atom_ppint_release(integrals,error) - CALL atom_relint_release(integrals,error) - CALL release_atom_basis(basis,error) - CALL release_atom_potential(potential,error) - CALL release_atom_type(atom,error) + CALL atom_int_release(integrals) + CALL atom_ppint_release(integrals) + CALL atom_relint_release(integrals) + CALL release_atom_basis(basis) + CALL release_atom_potential(potential) + CALL release_atom_type(atom) DEALLOCATE (potential,basis,integrals,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE calculate_atomic_orbitals @@ -481,9 +477,8 @@ END SUBROUTINE calculate_atomic_orbitals !> \param iunit ... !> \param allelectron ... !> \param confine ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,allelectron,confine,error) + SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,allelectron,confine) REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: density TYPE(atomic_kind_type), POINTER :: atomic_kind @@ -491,7 +486,6 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle INTEGER, INTENT(IN) :: ngto INTEGER, INTENT(IN), OPTIONAL :: iunit LOGICAL, INTENT(IN), OPTIONAL :: allelectron, confine - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_atomic_density', & routineP = moduleN//':'//routineN @@ -524,13 +518,13 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle failure = .FALSE. NULLIFY(atom) - CALL create_atom_type(atom,error) + CALL create_atom_type(atom) CALL get_atomic_kind(atomic_kind,z=z) NULLIFY(all_potential, gth_potential) CALL get_qs_kind(qs_kind,zeff=zeff,& all_potential=all_potential,& - gth_potential=gth_potential, error=error) + gth_potential=gth_potential) IF(PRESENT(allelectron)) THEN IF(allelectron) THEN @@ -539,7 +533,7 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle END IF END IF - CPPrecondition(ngto<=num_gto, cp_failure_level, routineP, error, failure) + CPPrecondition(ngto<=num_gto, cp_failure_level, routineP,failure) IF ( ASSOCIATED(gth_potential) ) THEN ! PP calculation are non-relativistic @@ -555,11 +549,10 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle method_type=do_rks_atom,& relativistic=relativistic,& coulomb_integral_type=do_numeric,& - exchange_integral_type=do_numeric,& - error=error) + exchange_integral_type=do_numeric) ALLOCATE (potential,basis,integrals,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) IF ( ASSOCIATED(gth_potential) ) THEN potential%ppot_type=gth_pseudo @@ -662,7 +655,7 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle potential%gth_pot%cval_nlcc(1:4,1:nexp_nlcc) = cval_nlcc(1:4,1:nexp_nlcc) END IF - CALL set_atom(atom,zcore=NINT(zeff),potential=potential,error=error) + CALL set_atom(atom,zcore=NINT(zeff),potential=potential) ELSE potential%ppot_type=no_pseudo IF ( PRESENT(confine) ) THEN @@ -673,14 +666,14 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle potential%acon=0.1_dp potential%rcon=2.0_dp*ptable(z)%vdw_radius*bohr potential%scon=2.0_dp - CALL set_atom(atom,zcore=z,potential=potential,error=error) + CALL set_atom(atom,zcore=z,potential=potential) END IF ! atomic grid NULLIFY(grid) ngp = 400 quadtype = do_gapw_log - CALL allocate_grid_atom(grid,error) + CALL allocate_grid_atom(grid) CALL create_grid_atom(grid,ngp,1,1,0,quadtype) grid%nr = ngp basis%grid => grid @@ -690,11 +683,11 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle ! fill in the basis data structures basis%eps_eig = 1.e-12_dp basis%basis_type = GTO_BASIS - CALL Clementi_geobas(z,cval,aval,basis%nbas,starti,error) + CALL Clementi_geobas(z,cval,aval,basis%nbas,starti) basis%nprim = basis%nbas m = MAXVAL(basis%nbas) ALLOCATE (basis%am(m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%am = 0._dp DO l=0,3 DO i=1,basis%nbas(l) @@ -712,9 +705,9 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle nr = basis%grid%nr m = MAXVAL(basis%nbas) ALLOCATE (basis%bf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE (basis%dbf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%bf = 0._dp basis%dbf = 0._dp DO l=0,3 @@ -729,7 +722,7 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle END DO END DO - CALL set_atom(atom,basis=basis,error=error) + CALL set_atom(atom,basis=basis) ! optimization defaults atom%optimization%damping = 0.2_dp @@ -823,7 +816,7 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle END IF ALLOCATE (atom%state,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) atom%state%core = 0._dp atom%state%core(0:3,1:7) = REAL(ncore(0:3,1:7),dp) @@ -850,26 +843,26 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle ! general integrals CALL atom_int_setup(integrals,basis,potential=atom%potential,& eri_coulomb=(atom%coulomb_integral_type==do_analytic),& - eri_exchange=(atom%exchange_integral_type==do_analytic),error=error) + eri_exchange=(atom%exchange_integral_type==do_analytic)) ! potential - CALL atom_ppint_setup(integrals,basis,potential=atom%potential,error=error) + CALL atom_ppint_setup(integrals,basis,potential=atom%potential) ! relativistic correction terms NULLIFY(integrals%tzora,integrals%hdkh) - CALL atom_relint_setup(integrals,basis,atom%relativistic,zcore=REAL(atom%zcore,dp),error=error) - CALL set_atom(atom,integrals=integrals,error=error) + CALL atom_relint_setup(integrals,basis,atom%relativistic,zcore=REAL(atom%zcore,dp)) + CALL set_atom(atom,integrals=integrals) NULLIFY(orbitals) mo = MAXVAL(atom%state%maxn_calc) mb = MAXVAL(atom%basis%nbas) - CALL create_atom_orbs(orbitals,mb,mo,error) - CALL set_atom(atom,orbitals=orbitals,error=error) + CALL create_atom_orbs(orbitals,mb,mo) + CALL set_atom(atom,orbitals=orbitals) IF(PRESENT(iunit)) THEN - CALL calculate_atom(atom,iunit,error=error) - CALL atom_fit_density (atom,ngto,0,iunit,results=results,error=error) + CALL calculate_atom(atom,iunit) + CALL atom_fit_density (atom,ngto,0,iunit,results=results) ELSE - CALL calculate_atom(atom,-1,error=error) - CALL atom_fit_density (atom,ngto,0,-1,results=results,error=error) + CALL calculate_atom(atom,-1) + CALL atom_fit_density (atom,ngto,0,-1,results=results) END IF xx = results(1) @@ -880,15 +873,15 @@ SUBROUTINE calculate_atomic_density (density,atomic_kind,qs_kind,ngto,iunit,alle END DO ! clean up - CALL atom_int_release(integrals,error) - CALL atom_ppint_release(integrals,error) - CALL atom_relint_release(integrals,error) - CALL release_atom_basis(basis,error) - CALL release_atom_potential(potential,error) - CALL release_atom_type(atom,error) + CALL atom_int_release(integrals) + CALL atom_ppint_release(integrals) + CALL atom_relint_release(integrals) + CALL release_atom_basis(basis) + CALL release_atom_potential(potential) + CALL release_atom_type(atom) DEALLOCATE (potential,basis,integrals,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE calculate_atomic_density @@ -900,14 +893,12 @@ END SUBROUTINE calculate_atomic_density !> \param qs_kind ... !> \param rel_control ... !> \param rtmat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) + SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat) TYPE(atomic_kind_type), INTENT(IN) :: atomic_kind TYPE(qs_kind_type), INTENT(IN) :: qs_kind TYPE(rel_control_type), POINTER :: rel_control REAL(KIND=dp), DIMENSION(:, :), POINTER :: rtmat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_atomic_relkin', & routineP = moduleN//':'//routineN @@ -941,17 +932,17 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) IF(rel_control%rel_method == rel_none) RETURN NULLIFY(all_potential,orb_basis_set) - CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, all_potential=all_potential, error=error) + CALL get_qs_kind(qs_kind, basis_set=orb_basis_set, all_potential=all_potential) - CPPostcondition(ASSOCIATED(orb_basis_set), cp_failure_level, routineP, error, failure) + CPPostcondition(ASSOCIATED(orb_basis_set), cp_failure_level, routineP,failure) IF ( ASSOCIATED(all_potential) ) THEN ! only all electron atoms will get the relativistic correction CALL get_atomic_kind(atomic_kind,z=z) - CALL get_qs_kind(qs_kind,zeff=zeff,error=error) + CALL get_qs_kind(qs_kind,zeff=zeff) NULLIFY(atom) - CALL create_atom_type(atom,error) + CALL create_atom_type(atom) NULLIFY(atom%xc_section) NULLIFY(atom%orbitals) atom%z = z @@ -960,11 +951,11 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) ! set the method flag SELECT CASE (rel_control%rel_method) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (rel_dkh) SELECT CASE (rel_control%rel_DKH_order) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (0) relativistic = do_dkh0_atom CASE (1) @@ -981,9 +972,9 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) CASE (rel_zora) SELECT CASE (rel_control%rel_zora_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (rel_zora_full) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (rel_zora_mp) relativistic = do_zoramp_atom CASE (rel_sczora_mp) @@ -996,14 +987,13 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) method_type=do_rks_atom,& relativistic=relativistic,& coulomb_integral_type=do_numeric,& - exchange_integral_type=do_numeric,& - error=error) + exchange_integral_type=do_numeric) ALLOCATE (potential,basis,integrals,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) potential%ppot_type=no_pseudo - CALL set_atom(atom,zcore=z,potential=potential,error=error) + CALL set_atom(atom,zcore=z,potential=potential) CALL get_gto_basis_set(orb_basis_set,& nset=nset,nshell=nshell,npgf=npgf,lmin=lmin,lmax=lmax,l=ls,nsgf=nsgf,zet=zet,gcc=gcc,& @@ -1012,7 +1002,7 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) NULLIFY(grid) ngp = 400 quadtype = do_gapw_log - CALL allocate_grid_atom(grid,error) + CALL allocate_grid_atom(grid) CALL create_grid_atom(grid,ngp,1,1,0,quadtype) grid%nr = ngp basis%grid => grid @@ -1035,7 +1025,7 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) IF ( l <= 3 ) THEN basis%nbas(l) = basis%nbas(l)+1 k = basis%nbas(l) - CPPostcondition(k<=100, cp_failure_level, routineP, error, failure) + CPPostcondition(k<=100, cp_failure_level, routineP,failure) set_index(l,k) = i shell_index(l,k) = j END IF @@ -1045,10 +1035,10 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) nj = MAXVAL(basis%nprim) ns = MAXVAL(basis%nbas) ALLOCATE (basis%am(nj,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%am = 0._dp ALLOCATE (basis%cm(nj,ns,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%cm = 0._dp DO j=0,3 nj = 0 @@ -1086,9 +1076,9 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) nr = basis%grid%nr m = MAXVAL(basis%nbas) ALLOCATE (basis%bf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE (basis%dbf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%bf = 0._dp basis%dbf = 0._dp @@ -1107,7 +1097,7 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) END DO END DO - CALL set_atom(atom,basis=basis,error=error) + CALL set_atom(atom,basis=basis) ! optimization defaults atom%optimization%damping = 0.2_dp @@ -1144,7 +1134,7 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) END IF ALLOCATE (atom%state,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) atom%state%core = 0._dp atom%state%core(0:3,1:7) = REAL(ncore(0:3,1:7),dp) @@ -1169,14 +1159,14 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) ! calculate integrals ! general integrals - CALL atom_int_setup(integrals,basis,error=error) + CALL atom_int_setup(integrals,basis) ! potential - CALL atom_ppint_setup(integrals,basis,potential=atom%potential,error=error) + CALL atom_ppint_setup(integrals,basis,potential=atom%potential) ! relativistic correction terms NULLIFY(integrals%tzora,integrals%hdkh) CALL atom_relint_setup(integrals,basis,atom%relativistic,zcore=REAL(atom%zcore,dp),& - alpha=alpha,error=error) - CALL set_atom(atom,integrals=integrals,error=error) + alpha=alpha) + CALL set_atom(atom,integrals=integrals) ! for DKH we need erfc integrals to correct non-relativistic integrals%core = 0.0_dp @@ -1184,23 +1174,23 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) n = integrals%n(l) m = basis%nprim(l) ALLOCATE (omat(m,m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL sg_erfc ( omat(1:m,1:m), l, alpha, basis%am(1:m,l), basis%am(1:m,l) ) integrals%core(1:n,1:n,l) = MATMUL(TRANSPOSE(basis%cm(1:m,1:n,l)),& MATMUL(omat(1:m,1:m),basis%cm(1:m,1:n,l))) DEALLOCATE (omat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END DO ! recover relativistic kinetic matrix in CP2K/GPW order and normalization IF(ASSOCIATED(rtmat)) THEN DEALLOCATE (rtmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF ALLOCATE (rtmat(nsgf,nsgf),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) rtmat = 0._dp DO l=0,3 ll = 2*l @@ -1210,7 +1200,7 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) j=first_sgf(shell_index(l,k2),set_index(l,k2)) SELECT CASE (atom%relativistic) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_zoramp_atom,do_sczoramp_atom) DO m=0,ll rtmat(i+m,j+m) = integrals%tzora(k1,k2,l) @@ -1231,21 +1221,21 @@ SUBROUTINE calculate_atomic_relkin (atomic_kind,qs_kind,rel_control,rtmat,error) END DO ! clean up - CALL atom_int_release(integrals,error) - CALL atom_ppint_release(integrals,error) - CALL atom_relint_release(integrals,error) - CALL release_atom_basis(basis,error) - CALL release_atom_potential(potential,error) - CALL release_atom_type(atom,error) + CALL atom_int_release(integrals) + CALL atom_ppint_release(integrals) + CALL atom_relint_release(integrals) + CALL release_atom_basis(basis) + CALL release_atom_potential(potential) + CALL release_atom_type(atom) DEALLOCATE (potential,basis,integrals,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ELSE IF(ASSOCIATED(rtmat)) THEN DEALLOCATE (rtmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF NULLIFY(rtmat) diff --git a/src/atom_operators.F b/src/atom_operators.F index e37f2068e3..d90b4ad77f 100644 --- a/src/atom_operators.F +++ b/src/atom_operators.F @@ -62,17 +62,15 @@ MODULE atom_operators !> \param eri_coulomb ... !> \param eri_exchange ... !> \param all_nu ... -!> \param error ... ! ***************************************************************************** SUBROUTINE atom_int_setup(integrals,basis,potential,& - eri_coulomb,eri_exchange,all_nu,error) + eri_coulomb,eri_exchange,all_nu) TYPE(atom_integrals), INTENT(INOUT) :: integrals TYPE(atom_basis_type), INTENT(INOUT) :: basis TYPE(atom_potential_type), INTENT(IN), & OPTIONAL :: potential LOGICAL, INTENT(IN), OPTIONAL :: eri_coulomb, eri_exchange, & all_nu - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_int_setup', & routineP = moduleN//':'//routineN @@ -118,11 +116,11 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& END DO ALLOCATE (integrals%ovlp(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%ovlp = 0._dp ALLOCATE (integrals%kin(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%kin = 0._dp integrals%status = 1 @@ -130,23 +128,23 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& IF ( PRESENT(potential) ) THEN IF ( potential%confinement ) THEN ALLOCATE (integrals%conf(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%conf = 0._dp m = basis%grid%nr ALLOCATE (cpot(1:m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) rc = potential%rcon sc = potential%scon cpot(1:m) = (basis%grid%rad(1:m)/rc)**sc - CALL numpot_matrix(integrals%conf,cpot,basis,0,error) + CALL numpot_matrix(integrals%conf,cpot,basis,0) DEALLOCATE (cpot,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF END IF SELECT CASE (basis%basis_type) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (GTO_BASIS) DO l=0,3 n = integrals%n(l) @@ -169,7 +167,7 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& DO nu = 0, nx, 2 ll = ll + 1 ALLOCATE (integrals%ceri(ll)%int(nn1,nn2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%ceri(ll)%int = 0._dp eri => integrals%ceri(ll)%int CALL sg_coulomb ( eri, nu, basis%am(1:n1,l1), l1, basis%am(1:n2,l2), l2 ) @@ -188,7 +186,7 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& DO nu = ABS(l1-l2),l1+l2,2 ll = ll + 1 ALLOCATE (integrals%eeri(ll)%int(nn1,nn2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%eeri(ll)%int = 0._dp eri => integrals%eeri(ll)%int CALL sg_exchange ( eri, nu, basis%am(1:n1,l1), l1, basis%am(1:n2,l2), l2 ) @@ -202,14 +200,14 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& m = basis%nprim(l) IF (n>0 .AND. m>0) THEN ALLOCATE (omat(m,m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL sg_overlap ( omat(1:m,1:m), l, basis%am(1:m,l), basis%am(1:m,l) ) - CALL contract2(integrals%ovlp(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l), error) + CALL contract2(integrals%ovlp(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l)) CALL sg_kinetic ( omat(1:m,1:m), l, basis%am(1:m,l), basis%am(1:m,l) ) - CALL contract2(integrals%kin(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l), error) + CALL contract2(integrals%kin(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l)) DEALLOCATE (omat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF END DO IF ( integrals%eri_coulomb ) THEN @@ -232,17 +230,17 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& DO nu = 0, nx, 2 ll = ll + 1 ALLOCATE (integrals%ceri(ll)%int(nn1,nn2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%ceri(ll)%int = 0._dp ALLOCATE (omat(mm1,mm2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) eri => integrals%ceri(ll)%int CALL sg_coulomb ( omat, nu, basis%am(1:m1,l1), l1, basis%am(1:m2,l2), l2 ) - CALL contract4 ( eri, omat, basis%cm(1:m1,1:n1,l1), basis%cm(1:m2,1:n2,l2), error ) + CALL contract4 ( eri, omat, basis%cm(1:m1,1:n1,l1), basis%cm(1:m2,1:n2,l2)) DEALLOCATE (omat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END DO END DO END DO @@ -262,17 +260,17 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& DO nu = ABS(l1-l2),l1+l2,2 ll = ll + 1 ALLOCATE (integrals%eeri(ll)%int(nn1,nn2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%eeri(ll)%int = 0._dp ALLOCATE (omat(mm1,mm2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) eri => integrals%eeri(ll)%int CALL sg_exchange ( omat, nu, basis%am(1:m1,l1), l1, basis%am(1:m2,l2), l2 ) - CALL contract4 ( eri, omat, basis%cm(1:m1,1:n1,l1), basis%cm(1:m2,1:n2,l2), error ) + CALL contract4 ( eri, omat, basis%cm(1:m1,1:n1,l1), basis%cm(1:m2,1:n2,l2)) DEALLOCATE (omat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END DO END DO END DO @@ -285,23 +283,23 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& CALL sto_kinetic ( integrals%kin(1:n,1:n,l), l, basis%ns(1:n,l), basis%as(1:n,l), & basis%ns(1:n,l), basis%as(1:n,l) ) END DO - CPAssert(.NOT.integrals%eri_coulomb,cp_failure_level,routineP,error,failure) - CPAssert(.NOT.integrals%eri_exchange,cp_failure_level,routineP,error,failure) + CPAssert(.NOT.integrals%eri_coulomb,cp_failure_level,routineP,failure) + CPAssert(.NOT.integrals%eri_exchange,cp_failure_level,routineP,failure) CASE (NUM_BASIS) - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! setup transformation matrix to get an orthogonal basis, remove linear dependencies NULLIFY(integrals%utrans,integrals%uptrans) n = MAXVAL(basis%nbas) ALLOCATE (integrals%utrans(n,n,0:3),integrals%uptrans(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%utrans = 0._dp integrals%uptrans = 0._dp integrals%nne = integrals%n lwork = 10*n ALLOCATE(omat(n,n),w(n),vmat(n,n),work(lwork),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO l = 0, 3 n = integrals%n(l) IF ( n > 0 ) THEN @@ -321,11 +319,11 @@ SUBROUTINE atom_int_setup(integrals,basis,potential,& integrals%uptrans(i,i,l)=1._dp ENDDO CALL lapack_sgesv ( ii, ii, omat(1:ii,1:ii), ii, ipiv, integrals%uptrans(1:ii,1:ii,l), ii, info ) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(omat,vmat,w,work,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF @@ -337,13 +335,11 @@ END SUBROUTINE atom_int_setup !> \param integrals ... !> \param basis ... !> \param potential ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) + SUBROUTINE atom_ppint_setup(integrals,basis,potential) TYPE(atom_integrals), INTENT(INOUT) :: integrals TYPE(atom_basis_type), INTENT(INOUT) :: basis TYPE(atom_potential_type), INTENT(IN) :: potential - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_ppint_setup', & routineP = moduleN//':'//routineN @@ -368,22 +364,22 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) NULLIFY ( integrals%core, integrals%hnl ) ALLOCATE (integrals%hnl(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%hnl = 0._dp ALLOCATE (integrals%core(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%core = 0._dp ALLOCATE (integrals%clsd(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%clsd = 0._dp integrals%ppstat = 1 SELECT CASE (basis%basis_type) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (GTO_BASIS) SELECT CASE (potential%ppot_type) @@ -397,7 +393,7 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) DO l=0,3 n = integrals%n(l) ALLOCATE (omat(n,n),spmat(n,5),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) omat = 0._dp CALL sg_erf ( omat(1:n,1:n), l, alpha, basis%am(1:n,l), basis%am(1:n,l) ) @@ -440,10 +436,10 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) MATMUL(potential%gth_pot%hnl(1:m,1:m,l),TRANSPOSE(spmat(1:n,1:m)))) DEALLOCATE (omat,spmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END DO CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT CASE (CGTO_BASIS) @@ -454,13 +450,13 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) n = integrals%n(l) m = basis%nprim(l) ALLOCATE (omat(m,m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL sg_nuclear ( omat(1:m,1:m), l, basis%am(1:m,l), basis%am(1:m,l) ) - CALL contract2(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l), error) + CALL contract2(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l)) DEALLOCATE (omat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END DO CASE (GTH_PSEUDO) alpha = 1._dp/potential%gth_pot%rc/SQRT(2._dp) @@ -469,17 +465,17 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) m = basis%nprim(l) IF(n>0 .AND. m>0) THEN ALLOCATE (omat(m,m),spmat(n,5),xmat(m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) omat = 0._dp CALL sg_erf ( omat(1:m,1:m), l, alpha, basis%am(1:m,l), basis%am(1:m,l) ) omat(1:m,1:m) = -potential%gth_pot%zion*omat(1:m,1:m) - CALL contract2(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l), error) + CALL contract2(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l)) DO i=1,potential%gth_pot%ncl omat = 0._dp CALL sg_gpot ( omat(1:m,1:m), i-1, potential%gth_pot%rc, l, basis%am(1:m,l), basis%am(1:m,l) ) omat(1:m,1:m) = potential%gth_pot%cl(i)*omat(1:m,1:m) - CALL contract2add(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l), error) + CALL contract2add(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l)) END DO IF (potential%gth_pot%lpotextended) THEN DO k=1,potential%gth_pot%nexp_lpot @@ -488,7 +484,7 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) CALL sg_gpot ( omat(1:m,1:m), i-1, potential%gth_pot%alpha_lpot(k), l, & basis%am(1:m,l), basis%am(1:m,l) ) omat(1:m,1:m) = potential%gth_pot%cval_lpot(i,k)*omat(1:m,1:m) - CALL contract2add(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l), error) + CALL contract2add(integrals%core(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l)) END DO END DO END IF @@ -499,7 +495,7 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) CALL sg_gpot ( omat(1:m,1:m), i-1, potential%gth_pot%alpha_lsd(k), l, & basis%am(1:m,l), basis%am(1:m,l) ) omat(1:m,1:m) = potential%gth_pot%cval_lsd(i,k)*omat(1:m,1:m) - CALL contract2add(integrals%clsd(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l), error) + CALL contract2add(integrals%clsd(1:n,1:n,l),omat(1:m,1:m),basis%cm(1:m,1:n,l)) END DO END DO END IF @@ -516,11 +512,11 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) END IF DEALLOCATE (omat,spmat,xmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF END DO CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT CASE (STO_BASIS) @@ -536,7 +532,7 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) rad => basis%grid%rad m = basis%grid%nr ALLOCATE (cpot(1:m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) rc = potential%gth_pot%rc alpha = 1._dp/rc/SQRT(2._dp) @@ -558,17 +554,17 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) END DO END DO END IF - CALL numpot_matrix(integrals%core,cpot,basis,0,error) + CALL numpot_matrix(integrals%core,cpot,basis,0) DO l=0,3 n = integrals%n(l) ALLOCATE (omat(n,n),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) omat = 0._dp CALL sto_nuclear ( omat(1:n,1:n), basis%ns(1:n,l), basis%as(1:n,l),& basis%ns(1:n,l), basis%as(1:n,l) ) integrals%core(1:n,1:n,l) = integrals%core(1:n,1:n,l) - potential%gth_pot%zion*omat(1:n,1:n) DEALLOCATE (omat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END DO IF (potential%gth_pot%lsdpot) THEN @@ -580,14 +576,14 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) cpot(:) = cpot + potential%gth_pot%cval_lsd(i,k)*(rad/al)**ii * EXP(-0.5_dp*(rad/al)**2) END DO END DO - CALL numpot_matrix(integrals%clsd,cpot,basis,0,error) + CALL numpot_matrix(integrals%clsd,cpot,basis,0) END IF DO l=0,3 n = integrals%n(l) ! non local pseudopotential ALLOCATE (spmat(n,5),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) spmat = 0._dp k = potential%gth_pot%nl(l) DO i=1,k @@ -601,19 +597,19 @@ SUBROUTINE atom_ppint_setup(integrals,basis,potential,error) MATMUL(potential%gth_pot%hnl(1:k,1:k,l),TRANSPOSE(spmat(1:n,1:k)))) DEALLOCATE (spmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END DO DEALLOCATE (cpot,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT CASE (NUM_BASIS) - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF @@ -628,15 +624,13 @@ END SUBROUTINE atom_ppint_setup !> \param reltyp ... !> \param zcore ... !> \param alpha ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) + SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha) TYPE(atom_integrals), INTENT(INOUT) :: integrals TYPE(atom_basis_type), INTENT(INOUT) :: basis INTEGER, INTENT(IN) :: reltyp REAL(dp), INTENT(IN) :: zcore REAL(dp), INTENT(IN), OPTIONAL :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_relint_setup', & routineP = moduleN//':'//routineN @@ -660,7 +654,7 @@ SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) SELECT CASE (reltyp) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_nonrel_atom,do_zoramp_atom,do_sczoramp_atom) dkhorder = -1 CASE (do_dkh0_atom) @@ -679,7 +673,7 @@ SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) SELECT CASE (reltyp) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_nonrel_atom) ! nothing to do NULLIFY (integrals%tzora,integrals%hdkh) @@ -690,43 +684,43 @@ SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) IF ( integrals%zorastat == 0 ) THEN n = MAXVAL(basis%nbas) ALLOCATE (integrals%tzora(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%tzora = 0._dp m = basis%grid%nr ALLOCATE (modpot(1:m),cpot(1:m),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL calculate_model_potential(modpot,basis%grid,zcore,error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL calculate_model_potential(modpot,basis%grid,zcore) ! Zora potential cpot(1:m) = modpot(1:m)/(4._dp*cspeed*cspeed - 2._dp*modpot(1:m)) cpot(1:m) = cpot(1:m)/basis%grid%rad2(1:m) - CALL numpot_matrix(integrals%tzora,cpot,basis,0,error) + CALL numpot_matrix(integrals%tzora,cpot,basis,0) DO l=0,3 nl = basis%nbas(l) integrals%tzora(1:nl,1:nl,l) = REAL(l*(l+1),dp) * integrals%tzora(1:nl,1:nl,l) END DO cpot(1:m) = cpot(1:m)*basis%grid%rad2(1:m) - CALL numpot_matrix(integrals%tzora,cpot,basis,2,error) + CALL numpot_matrix(integrals%tzora,cpot,basis,2) ! ! scaled ZORA IF( reltyp == do_sczoramp_atom ) THEN ALLOCATE (hmat(n,n,0:3),wfn(n,n,0:3),ener(n,0:3),pvp(n,n,0:3),sps(n,n),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) hmat(:,:,:) = integrals%kin + integrals%tzora ! model potential - CALL numpot_matrix(hmat,modpot,basis,0,error) + CALL numpot_matrix(hmat,modpot,basis,0) ! eigenvalues and eigenvectors - CALL atom_solve(hmat,integrals%utrans,wfn,ener,basis%nbas,integrals%nne,3,error) + CALL atom_solve(hmat,integrals%utrans,wfn,ener,basis%nbas,integrals%nne,3) ! relativistic kinetic energy cpot(1:m) = cspeed*cspeed/(2._dp*cspeed*cspeed - modpot(1:m))**2 cpot(1:m) = cpot(1:m)/basis%grid%rad2(1:m) pvp = 0.0_dp - CALL numpot_matrix(pvp,cpot,basis,0,error) + CALL numpot_matrix(pvp,cpot,basis,0) DO l=0,3 nl = basis%nbas(l) pvp(1:nl,1:nl,l) = REAL(l*(l+1),dp) * pvp(1:nl,1:nl,l) END DO cpot(1:m) = cpot(1:m)*basis%grid%rad2(1:m) - CALL numpot_matrix(pvp,cpot,basis,2,error) + CALL numpot_matrix(pvp,cpot,basis,2) ! calculate psi*pvp*psi and the scaled orbital energies ! actually, we directly calculate the energy difference DO l=0,3 @@ -759,11 +753,11 @@ SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) END DO DEALLOCATE (hmat,wfn,ener,pvp,sps,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF ! DEALLOCATE (modpot,cpot,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%zorastat = 1 @@ -776,12 +770,12 @@ SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) IF ( integrals%dkhstat == 0 ) THEN n = MAXVAL(basis%nbas) ALLOCATE (integrals%hdkh(n,n,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) integrals%hdkh = 0._dp m = MAXVAL(basis%nprim) ALLOCATE (tp(m,m,0:3),sp(m,m,0:3),vp(m,m,0:3),pvp(m,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) tp = 0._dp sp = 0._dp vp = 0._dp @@ -789,7 +783,7 @@ SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) SELECT CASE (basis%basis_type) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (GTO_BASIS, CGTO_BASIS) DO l=0,3 @@ -809,20 +803,20 @@ SUBROUTINE atom_relint_setup(integrals,basis,reltyp,zcore,alpha,error) END DO CASE (STO_BASIS) - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (NUM_BASIS) - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL dkh_integrals(integrals,basis,dkhorder,sp,tp,vp,pvp,error) + CALL dkh_integrals(integrals,basis,dkhorder,sp,tp,vp,pvp) integrals%dkhstat = 1 DEALLOCATE (tp,sp,vp,pvp,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ELSE - CPPostcondition(ASSOCIATED(integrals%hdkh), cp_failure_level, routineP, error, failure) + CPPostcondition(ASSOCIATED(integrals%hdkh), cp_failure_level, routineP,failure) END IF END SELECT @@ -839,14 +833,12 @@ END SUBROUTINE atom_relint_setup !> \param tp ... !> \param vp ... !> \param pvp ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dkh_integrals(integrals,basis,order,sp,tp,vp,pvp,error) + SUBROUTINE dkh_integrals(integrals,basis,order,sp,tp,vp,pvp) TYPE(atom_integrals), INTENT(INOUT) :: integrals TYPE(atom_basis_type), INTENT(INOUT) :: basis INTEGER, INTENT(IN) :: order REAL(dp), DIMENSION(:, :, 0:) :: sp, tp, vp, pvp - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dkh_integrals', & routineP = moduleN//':'//routineN @@ -856,7 +848,7 @@ SUBROUTINE dkh_integrals(integrals,basis,order,sp,tp,vp,pvp,error) REAL(dp), DIMENSION(:, :, :), POINTER :: hdkh failure = .FALSE. - CPPrecondition(order>=0, cp_failure_level, routineP, error, failure) + CPPrecondition(order>=0, cp_failure_level, routineP,failure) hdkh => integrals%hdkh @@ -867,17 +859,17 @@ SUBROUTINE dkh_integrals(integrals,basis,order,sp,tp,vp,pvp,error) CALL dkh_atom_transformation(sp(1:m,1:m,l),vp(1:m,1:m,l),tp(1:m,1:m,l),pvp(1:m,1:m,l),m,order) SELECT CASE (basis%basis_type) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (GTO_BASIS) - CPAssert(n==m,cp_failure_level,routineP,error,failure) + CPAssert(n==m,cp_failure_level,routineP,failure) integrals%hdkh(1:n,1:n,l) = tp(1:n,1:n,l) + vp(1:n,1:n,l) CASE (CGTO_BASIS) - CALL contract2(integrals%hdkh(1:n,1:n,l),tp(1:m,1:m,l),basis%cm(1:m,1:n,l), error) - CALL contract2add(integrals%hdkh(1:n,1:n,l),vp(1:m,1:m,l),basis%cm(1:m,1:n,l), error) + CALL contract2(integrals%hdkh(1:n,1:n,l),tp(1:m,1:m,l),basis%cm(1:m,1:n,l)) + CALL contract2add(integrals%hdkh(1:n,1:n,l),vp(1:m,1:m,l),basis%cm(1:m,1:n,l)) CASE (STO_BASIS) - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (NUM_BASIS) - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSE integrals%hdkh(1:n,1:n,l) = 0._dp @@ -888,11 +880,9 @@ END SUBROUTINE dkh_integrals ! ***************************************************************************** !> \brief ... !> \param integrals ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_int_release(integrals,error) + SUBROUTINE atom_int_release(integrals) TYPE(atom_integrals), INTENT(INOUT) :: integrals - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_int_release', & routineP = moduleN//':'//routineN @@ -904,33 +894,33 @@ SUBROUTINE atom_int_release(integrals,error) IF ( ASSOCIATED(integrals%ovlp) ) THEN DEALLOCATE (integrals%ovlp,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( ASSOCIATED(integrals%kin) ) THEN DEALLOCATE (integrals%kin,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( ASSOCIATED(integrals%conf) ) THEN DEALLOCATE (integrals%conf,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF DO ll=1,SIZE(integrals%ceri) IF ( ASSOCIATED(integrals%ceri(ll)%int) ) THEN DEALLOCATE (integrals%ceri(ll)%int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( ASSOCIATED(integrals%eeri(ll)%int) ) THEN DEALLOCATE (integrals%eeri(ll)%int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF END DO IF ( ASSOCIATED(integrals%utrans) ) THEN DEALLOCATE (integrals%utrans,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( ASSOCIATED(integrals%uptrans) ) THEN DEALLOCATE (integrals%uptrans,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF integrals%status = 0 @@ -939,11 +929,9 @@ END SUBROUTINE atom_int_release ! ***************************************************************************** !> \brief ... !> \param integrals ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_ppint_release(integrals,error) + SUBROUTINE atom_ppint_release(integrals) TYPE(atom_integrals), INTENT(INOUT) :: integrals - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_ppint_release', & routineP = moduleN//':'//routineN @@ -955,15 +943,15 @@ SUBROUTINE atom_ppint_release(integrals,error) IF ( ASSOCIATED(integrals%hnl) ) THEN DEALLOCATE (integrals%hnl,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( ASSOCIATED(integrals%core) ) THEN DEALLOCATE (integrals%core,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( ASSOCIATED(integrals%clsd) ) THEN DEALLOCATE (integrals%clsd,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF integrals%ppstat = 0 @@ -972,11 +960,9 @@ END SUBROUTINE atom_ppint_release ! ***************************************************************************** !> \brief ... !> \param integrals ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_relint_release(integrals,error) + SUBROUTINE atom_relint_release(integrals) TYPE(atom_integrals), INTENT(INOUT) :: integrals - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_relint_release', & routineP = moduleN//':'//routineN @@ -988,11 +974,11 @@ SUBROUTINE atom_relint_release(integrals,error) IF ( ASSOCIATED(integrals%tzora) ) THEN DEALLOCATE (integrals%tzora,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( ASSOCIATED(integrals%hdkh) ) THEN DEALLOCATE (integrals%hdkh,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF integrals%zorastat = 0 @@ -1004,13 +990,11 @@ END SUBROUTINE atom_relint_release !> \param modpot ... !> \param grid ... !> \param zcore ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_model_potential(modpot,grid,zcore,error) + SUBROUTINE calculate_model_potential(modpot,grid,zcore) REAL(dp), DIMENSION(:), INTENT(INOUT) :: modpot TYPE(grid_atom_type), INTENT(IN) :: grid REAL(dp), INTENT(IN) :: zcore - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_model_potential', & routineP = moduleN//':'//routineN @@ -1022,7 +1006,7 @@ SUBROUTINE calculate_model_potential(modpot,grid,zcore,error) n = SIZE(modpot) ALLOCATE(rho(n),pot(n),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ! fill default occupation state%core = 0._dp @@ -1048,16 +1032,16 @@ SUBROUTINE calculate_model_potential(modpot,grid,zcore,error) modpot = -zcore/grid%rad(:) ! Coulomb potential - CALL slater_density(rho,pot,NINT(zcore),state,grid,error) - CALL coulomb_potential_numeric(pot,rho,grid,error) + CALL slater_density(rho,pot,NINT(zcore),state,grid) + CALL coulomb_potential_numeric(pot,rho,grid) modpot = modpot + pot ! XC potential - CALL wigner_slater_functional(rho,pot,error) + CALL wigner_slater_functional(rho,pot) modpot = modpot + pot DEALLOCATE(rho,pot,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE calculate_model_potential ! ***************************************************************************** @@ -1065,12 +1049,10 @@ END SUBROUTINE calculate_model_potential !> \param int ... !> \param omat ... !> \param cm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE contract2 ( int, omat, cm, error ) + SUBROUTINE contract2 ( int, omat, cm) REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: int REAL(dp), DIMENSION(:, :), INTENT(IN) :: omat, cm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'contract2', & routineP = moduleN//':'//routineN @@ -1092,12 +1074,10 @@ END SUBROUTINE contract2 !> \param int ... !> \param omat ... !> \param cm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE contract2add ( int, omat, cm, error ) + SUBROUTINE contract2add ( int, omat, cm) REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: int REAL(dp), DIMENSION(:, :), INTENT(IN) :: omat, cm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'contract2add', & routineP = moduleN//':'//routineN @@ -1120,12 +1100,10 @@ END SUBROUTINE contract2add !> \param omat ... !> \param cm1 ... !> \param cm2 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE contract4 ( eri, omat, cm1, cm2, error ) + SUBROUTINE contract4 ( eri, omat, cm1, cm2) REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: eri REAL(dp), DIMENSION(:, :), INTENT(IN) :: omat, cm1, cm2 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'contract4', & routineP = moduleN//':'//routineN @@ -1148,26 +1126,26 @@ SUBROUTINE contract4 ( eri, omat, cm1, cm2, error ) mm2 = SIZE(omat,2) ALLOCATE(amat(m1,m1),atran(n1,n1),bmat(m2,m2),btran(n2,n2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE(hint(mm1,nn2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DO i1=1,mm1 CALL iunpack(bmat(1:m2,1:m2),omat(i1,1:mm2),m2) - CALL contract2( btran(1:n2,1:n2), bmat(1:m2,1:m2), cm2(1:m2,1:n2), error ) + CALL contract2( btran(1:n2,1:n2), bmat(1:m2,1:m2), cm2(1:m2,1:n2)) CALL ipack(btran(1:n2,1:n2),hint(i1,1:nn2),n2) END DO DO i2=1,nn2 CALL iunpack(amat(1:m1,1:m1),hint(1:mm1,i2),m1) - CALL contract2( atran(1:n1,1:n1), amat(1:m1,1:m1), cm1(1:m1,1:n1), error ) + CALL contract2( atran(1:n1,1:n1), amat(1:m1,1:m1), cm1(1:m1,1:n1)) CALL ipack(atran(1:n1,1:n1),eri(1:nn1,i2),n1) END DO DEALLOCATE(amat,atran,bmat,btran,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(hint,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL timestop(handle) diff --git a/src/atom_optimization.F b/src/atom_optimization.F index ecfbadb997..c22b8b3267 100644 --- a/src/atom_optimization.F +++ b/src/atom_optimization.F @@ -45,13 +45,11 @@ MODULE atom_optimization !> \param history ... !> \param optimization ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_history_init (history,optimization,matrix,error) + SUBROUTINE atom_history_init (history,optimization,matrix) TYPE(atom_history_type), INTENT(INOUT) :: history TYPE(atom_optimization_type), INTENT(IN) :: optimization REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_history_init', & routineP = moduleN//':'//routineN @@ -65,7 +63,7 @@ SUBROUTINE atom_history_init (history,optimization,matrix,error) eps = optimization%eps_diis damp = optimization%damping - CALL atom_history_release (history,error) + CALL atom_history_release (history) history%max_history = ndiis history%hlen = 0 @@ -73,18 +71,18 @@ SUBROUTINE atom_history_init (history,optimization,matrix,error) history%damping = damp history%eps_diis = eps ALLOCATE ( history%dmat(ndiis+1,ndiis+1), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( history%hmat(ndiis), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) n1 = SIZE(matrix,1) n2 = SIZE(matrix,2) n3 = SIZE(matrix,3) DO i=1,ndiis ALLOCATE ( history%hmat(i)%emat(n1,n2,n3), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( history%hmat(i)%fmat(n1,n2,n3), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END DO END SUBROUTINE atom_history_init @@ -93,12 +91,10 @@ END SUBROUTINE atom_history_init !> \param history ... !> \param fmat ... !> \param emat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_history_update (history,fmat,emat,error) + SUBROUTINE atom_history_update (history,fmat,emat) TYPE(atom_history_type), INTENT(INOUT) :: history REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: fmat, emat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_history_update', & routineP = moduleN//':'//routineN @@ -120,11 +116,9 @@ END SUBROUTINE atom_history_update ! ***************************************************************************** !> \brief ... !> \param history ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_history_release (history,error) + SUBROUTINE atom_history_release (history) TYPE(atom_history_type), INTENT(INOUT) :: history - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_history_release', & routineP = moduleN//':'//routineN @@ -140,24 +134,24 @@ SUBROUTINE atom_history_release (history,error) history%eps_diis = 0._dp IF ( ASSOCIATED(history%dmat) ) THEN DEALLOCATE ( history%dmat, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) NULLIFY ( history%dmat ) END IF IF ( ASSOCIATED(history%hmat) ) THEN DO i=1,SIZE(history%hmat) IF ( ASSOCIATED(history%hmat(i)%emat) ) THEN DEALLOCATE ( history%hmat(i)%emat, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) NULLIFY ( history%hmat(i)%emat ) END IF IF ( ASSOCIATED(history%hmat(i)%fmat) ) THEN DEALLOCATE ( history%hmat(i)%fmat, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) NULLIFY ( history%hmat(i)%fmat ) END IF END DO DEALLOCATE ( history%hmat, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) NULLIFY ( history%hmat ) END IF @@ -167,14 +161,12 @@ END SUBROUTINE atom_history_release !> \param fmat ... !> \param history ... !> \param err ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_opt (fmat,history,err,error) + SUBROUTINE atom_opt (fmat,history,err) REAL(dp), DIMENSION(:, :, :), & INTENT(INOUT) :: fmat TYPE(atom_history_type), INTENT(INOUT) :: history REAL(dp), INTENT(IN) :: err - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_opt', & routineP = moduleN//':'//routineN @@ -196,7 +188,7 @@ SUBROUTINE atom_opt (fmat,history,err,error) rcond = 1.e-10_dp lwork = 25*nmax ALLOCATE(vec(nmax+1,2),s(nmax+1),work(lwork),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) nlen = history%hlen vec = 0._dp vec(nlen+1,1) = 1._dp @@ -216,7 +208,7 @@ SUBROUTINE atom_opt (fmat,history,err,error) END DO CALL lapack_sgelss(nlen+1,nlen+1,1,history%dmat,nmax+1,vec,nmax+1,s,& rcond,rank,work,lwork,info) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) fmat = 0._dp DO i=1,nlen na = nnow + 1 - i @@ -225,7 +217,7 @@ SUBROUTINE atom_opt (fmat,history,err,error) END DO DEALLOCATE(vec,s,work,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ELSE ! damping nm = nnow - 1 @@ -235,7 +227,7 @@ SUBROUTINE atom_opt (fmat,history,err,error) ELSEIF ( history%hlen == 1 ) THEN fmat = history%hmat(nnow)%fmat ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE atom_opt diff --git a/src/atom_output.F b/src/atom_output.F index 862f0fbdae..4c43ed8bbf 100644 --- a/src/atom_output.F +++ b/src/atom_output.F @@ -54,13 +54,11 @@ MODULE atom_output !> \param zval ... !> \param info ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_info(zval,info,iw,error) + SUBROUTINE atom_print_info(zval,info,iw) INTEGER, INTENT(IN) :: zval CHARACTER(len=*), INTENT(IN) :: info INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_info', & routineP = moduleN//':'//routineN @@ -73,12 +71,10 @@ END SUBROUTINE atom_print_info !> \brief ... !> \param state ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_state(state,iw,error) + SUBROUTINE atom_print_state(state,iw) TYPE(atom_state) :: state INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_state', & routineP = moduleN//':'//routineN @@ -129,7 +125,7 @@ SUBROUTINE atom_print_state(state,iw,error) WRITE(iw,'(A5,T10,10F6.2)') label(l),(state%occ(l,j),j=1,mo) ELSE mc = mm(l) - CPPrecondition(SUM(state%occ(l,1:mc))==0,cp_failure_level,routineP,error,failure) + CPPrecondition(SUM(state%occ(l,1:mc))==0,cp_failure_level,routineP,failure) WRITE(iw,ADVANCE="no",FMT='(A5,T9,A1,10F6.2)') label(l),"[",(state%core(l,j),j=1,mc) WRITE(iw,FMT='(A1,F5.2,10F6.2)') "]",(state%occ(l,j),j=mc+1,mc+mo) END IF @@ -165,12 +161,10 @@ END SUBROUTINE atom_print_state !> \brief ... !> \param atom ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_energies(atom,iw,error) + SUBROUTINE atom_print_energies(atom,iw) TYPE(atom_type) :: atom INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_energies', & routineP = moduleN//':'//routineN @@ -239,15 +233,13 @@ END SUBROUTINE atom_print_energies !> \param deps ... !> \param atom ... !> \param iw ... -!> \param error ... !> \author D. Varsano [daniele.varsano@nano.cnr.it] ! ***************************************************************************** - SUBROUTINE atom_print_zmp_iteration(iter,deps,atom,iw,error) + SUBROUTINE atom_print_zmp_iteration(iter,deps,atom,iw) INTEGER, INTENT(IN) :: iter REAL(dp), INTENT(IN) :: deps TYPE(atom_type), INTENT(IN) :: atom INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_zmp_iteration', & routineP = moduleN//':'//routineN @@ -267,13 +259,11 @@ END SUBROUTINE atom_print_zmp_iteration !> \param deps ... !> \param etot ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_iteration(iter,deps,etot,iw,error) + SUBROUTINE atom_print_iteration(iter,deps,etot,iw) INTEGER, INTENT(IN) :: iter REAL(dp), INTENT(IN) :: deps, etot INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_iteration', & routineP = moduleN//':'//routineN @@ -290,13 +280,11 @@ END SUBROUTINE atom_print_iteration !> \param atom_basis ... !> \param iw ... !> \param title ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_basis(atom_basis,iw,title,error) + SUBROUTINE atom_print_basis(atom_basis,iw,title) TYPE(atom_basis_type) :: atom_basis INTEGER, INTENT(IN) :: iw CHARACTER(len=*) :: title - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_basis', & routineP = moduleN//':'//routineN @@ -363,20 +351,18 @@ SUBROUTINE atom_print_basis(atom_basis,iw,title,error) END DO WRITE(iw,'(" ",79("*"))') CASE (NUM_BASIS) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT END SUBROUTINE atom_print_basis ! ***************************************************************************** !> \brief ... !> \param atom_basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_basis_file(atom_basis,error) + SUBROUTINE atom_print_basis_file(atom_basis) TYPE(atom_basis_type) :: atom_basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_basis_file', & routineP = moduleN//':'//routineN @@ -412,7 +398,7 @@ SUBROUTINE atom_print_basis_file(atom_basis,error) "F_EXPONENTS ",(atom_basis%am(i,3),i=1,atom_basis%nbas(3)) END IF CASE (CGTO_BASIS) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (STO_BASIS) WRITE(iw,'(A)') " BASIS_TYPE SLATER" IF ( atom_basis%nbas(0) > 0 ) THEN @@ -440,9 +426,9 @@ SUBROUTINE atom_print_basis_file(atom_basis,error) "F_QUANTUM_NUMBERS ",(atom_basis%ns(i,3),i=1,atom_basis%nbas(3)) END IF CASE (NUM_BASIS) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT CALL close_file(unit_number=iw) @@ -451,12 +437,10 @@ END SUBROUTINE atom_print_basis_file !> \brief ... !> \param atom ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_method(atom,iw,error) + SUBROUTINE atom_print_method(atom,iw) TYPE(atom_type) :: atom INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_method', & routineP = moduleN//':'//routineN @@ -477,14 +461,14 @@ SUBROUTINE atom_print_method(atom,iw,error) meth = atom%method_type xc_section => atom%xc_section - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",error=error) + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") SELECT CASE (meth) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_rks_atom) - CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun,error=error) + CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun) CASE (do_uks_atom) - CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun,error=error) + CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun) CASE (do_rhf_atom) myfun = xc_none CASE (do_uhf_atom) @@ -495,7 +479,7 @@ SUBROUTINE atom_print_method(atom,iw,error) SELECT CASE (meth) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_rks_atom) IF (iw > 0) WRITE (iw, fmt="(/,' METHOD | Restricted Kohn-Sham Calculation')") CASE (do_uks_atom) @@ -533,7 +517,7 @@ SUBROUTINE atom_print_method(atom,iw,error) SELECT CASE (reltyp) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_nonrel_atom) IF (iw > 0) WRITE (iw, fmt="(' METHOD | Nonrelativistic Calculation')") CASE (do_zoramp_atom) @@ -560,17 +544,17 @@ SUBROUTINE atom_print_method(atom,iw,error) lsd = (meth==do_uks_atom) IF (myfun/=xc_none) THEN - CALL section_vals_val_get(xc_section,"FUNCTIONAL_ROUTINE",c_val=tmpStr,error=error) + CALL section_vals_val_get(xc_section,"FUNCTIONAL_ROUTINE",c_val=tmpStr) IF (iw > 0) WRITE (iw, fmt="(' FUNCTIONAL| ROUTINE=',a)") TRIM(tmpStr) - CALL xc_functionals_expand(xc_fun_section,xc_section,error=error) + CALL xc_functionals_expand(xc_fun_section,xc_section) IF (iw > 0) THEN ifun=0 DO ifun=ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT CALL xc_functional_get_info(xc_fun,lsd=lsd,reference=reference,& - shortform=shortform,ifunc_name=1,error=error) + shortform=shortform,ifunc_name=1) IF (TRIM(xc_fun%section%name) == "LIBXC") THEN CALL libxc_version_info(tmpStr) WRITE (iw, fmt="(A,A,A)") ' FUNCTIONAL| LIBXC Vers. ', TRIM(tmpStr(1:5)), & @@ -579,10 +563,10 @@ SUBROUTINE atom_print_method(atom,iw,error) DO il=1,LEN_TRIM(reference),67 WRITE (iw, fmt="(' FUNCTIONAL| ',a67)") reference(il:) END DO - CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name,error=error) + CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name) DO ifunc_name=2, SIZE(func_name) CALL xc_functional_get_info(xc_fun,lsd=lsd,reference=reference,& - shortform=shortform,ifunc_name=ifunc_name,error=error) + shortform=shortform,ifunc_name=ifunc_name) WRITE (iw, fmt="(A,A,A)") ' FUNCTIONAL| LIBXC Vers. ', TRIM(tmpStr(1:5)), & ' (Marques, Oliveira, Burnus, CPC 183, 2272 (2012))' WRITE (iw, fmt="(' FUNCTIONAL| ',a,':')") TRIM(shortform) @@ -608,12 +592,10 @@ END SUBROUTINE atom_print_method !> \brief ... !> \param potential ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_potential(potential,iw,error) + SUBROUTINE atom_print_potential(potential,iw) TYPE(atom_potential_type) :: potential INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_potential', & routineP = moduleN//':'//routineN @@ -664,7 +646,7 @@ SUBROUTINE atom_print_potential(potential,iw,error) END IF END DO CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT IF (potential%confinement) THEN WRITE(iw,'(/,T10,A,T51,F12.6," * (R /",F6.2,")**",F6.2)') & @@ -680,12 +662,10 @@ END SUBROUTINE atom_print_potential !> \brief ... !> \param gthpot ... !> \param iunit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_write_pseudo_param (gthpot,iunit,error) + SUBROUTINE atom_write_pseudo_param (gthpot,iunit) TYPE(atom_gthpot_type), INTENT(INOUT) :: gthpot INTEGER, INTENT(IN), OPTIONAL :: iunit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_write_pseudo_param', & routineP = moduleN//':'//routineN @@ -745,12 +725,10 @@ END SUBROUTINE atom_write_pseudo_param !> \brief ... !> \param atom ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_orbitals(atom,iw,error) + SUBROUTINE atom_print_orbitals(atom,iw) TYPE(atom_type), POINTER :: atom INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_orbitals', & routineP = moduleN//':'//routineN @@ -761,19 +739,19 @@ SUBROUTINE atom_print_orbitals(atom,iw,error) SELECT CASE (atom%method_type) CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) CASE (do_rks_atom) - CALL atom_print_orbitals_helper(atom,atom%orbitals%wfn,"",iw,error) + CALL atom_print_orbitals_helper(atom,atom%orbitals%wfn,"",iw) CASE (do_uks_atom) - CALL atom_print_orbitals_helper(atom,atom%orbitals%wfna,"Alpha",iw,error) - CALL atom_print_orbitals_helper(atom,atom%orbitals%wfnb,"Beta",iw,error) + CALL atom_print_orbitals_helper(atom,atom%orbitals%wfna,"Alpha",iw) + CALL atom_print_orbitals_helper(atom,atom%orbitals%wfnb,"Beta",iw) CASE (do_rhf_atom) - CALL atom_print_orbitals_helper(atom,atom%orbitals%wfn,"",iw,error) + CALL atom_print_orbitals_helper(atom,atom%orbitals%wfn,"",iw) CASE (do_uhf_atom) - CALL atom_print_orbitals_helper(atom,atom%orbitals%wfna,"Alpha",iw,error) - CALL atom_print_orbitals_helper(atom,atom%orbitals%wfnb,"Beta",iw,error) + CALL atom_print_orbitals_helper(atom,atom%orbitals%wfna,"Alpha",iw) + CALL atom_print_orbitals_helper(atom,atom%orbitals%wfnb,"Beta",iw) CASE (do_rohf_atom) - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT END SUBROUTINE atom_print_orbitals @@ -786,15 +764,13 @@ END SUBROUTINE atom_print_orbitals !> \param wfn ... !> \param description ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_print_orbitals_helper(atom,wfn,description,iw,error) + SUBROUTINE atom_print_orbitals_helper(atom,wfn,description,iw) TYPE(atom_type), POINTER :: atom REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(INOUT) :: wfn CHARACTER(len=*), INTENT(IN) :: description INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_print_orbitals_helper', & routineP = moduleN//':'//routineN diff --git a/src/atom_pseudo.F b/src/atom_pseudo.F index f6781ca903..c2e4cff2af 100644 --- a/src/atom_pseudo.F +++ b/src/atom_pseudo.F @@ -58,11 +58,9 @@ MODULE atom_pseudo ! ***************************************************************************** !> \brief ... !> \param atom_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_pseudo_opt(atom_section,error) + SUBROUTINE atom_pseudo_opt(atom_section) TYPE(section_vals_type), POINTER :: atom_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_pseudo_opt', & routineP = moduleN//':'//routineN @@ -93,8 +91,8 @@ SUBROUTINE atom_pseudo_opt(atom_section,error) CALL timeset(routineN,handle) ! What atom do we calculate - CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=zval, error=error) - CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem, error=error) + CALL section_vals_val_get(atom_section,"ATOMIC_NUMBER", i_val=zval) + CALL section_vals_val_get(atom_section,"ELEMENT", c_val=elem) zz = 0 DO i=1,nelem IF ( ptable(i)%symbol == elem ) THEN @@ -106,33 +104,33 @@ SUBROUTINE atom_pseudo_opt(atom_section,error) ! read and set up information on the basis sets ALLOCATE(ae_basis,pp_basis,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - basis_section => section_vals_get_subs_vals(atom_section,"AE_BASIS",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + basis_section => section_vals_get_subs_vals(atom_section,"AE_BASIS") NULLIFY(ae_basis%grid) - CALL init_atom_basis(ae_basis,basis_section,zval,"AA",error) + CALL init_atom_basis(ae_basis,basis_section,zval,"AA") NULLIFY(pp_basis%grid) - basis_section => section_vals_get_subs_vals(atom_section,"PP_BASIS",error=error) - CALL init_atom_basis(pp_basis,basis_section,zval,"AP",error) + basis_section => section_vals_get_subs_vals(atom_section,"PP_BASIS") + CALL init_atom_basis(pp_basis,basis_section,zval,"AP") ! print general and basis set information - logger => cp_error_get_logger(error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log",error=error) - IF(iw > 0) CALL atom_print_info(zval,"Atomic Energy Calculation",iw,error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%BASIS_SET",extension=".log",error=error) + logger => cp_get_default_logger() + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log") + IF(iw > 0) CALL atom_print_info(zval,"Atomic Energy Calculation",iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%BASIS_SET",extension=".log") IF(iw > 0) THEN - CALL atom_print_basis(ae_basis,iw," All Electron Basis",error) - CALL atom_print_basis(pp_basis,iw," Pseudopotential Basis",error) + CALL atom_print_basis(ae_basis,iw," All Electron Basis") + CALL atom_print_basis(pp_basis,iw," Pseudopotential Basis") END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%BASIS_SET",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%BASIS_SET") ! read and setup information on the pseudopotential NULLIFY(potential_section) - potential_section => section_vals_get_subs_vals(atom_section,"POTENTIAL",error=error) + potential_section => section_vals_get_subs_vals(atom_section,"POTENTIAL") ALLOCATE(ae_pot,p_pot,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL init_atom_potential(p_pot,potential_section,zval,error) - CALL init_atom_potential(ae_pot,potential_section,-1,error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL init_atom_potential(p_pot,potential_section,zval) + CALL init_atom_potential(ae_pot,potential_section,-1) IF ( .NOT.p_pot%confinement .AND. .NOT.ae_pot%confinement ) THEN !set default confinement potential p_pot%confinement = .TRUE. @@ -149,16 +147,16 @@ SUBROUTINE atom_pseudo_opt(atom_section,error) ! if the ERI's are calculated analytically, we have to precalculate them eri_c = .FALSE. - CALL section_vals_val_get(atom_section,"COULOMB_INTEGRALS", i_val=do_eric, error=error) + CALL section_vals_val_get(atom_section,"COULOMB_INTEGRALS", i_val=do_eric) IF(do_eric==do_analytic) eri_c = .TRUE. eri_e = .FALSE. - CALL section_vals_val_get(atom_section,"EXCHANGE_INTEGRALS", i_val=do_erie, error=error) + CALL section_vals_val_get(atom_section,"EXCHANGE_INTEGRALS", i_val=do_erie) IF(do_erie==do_analytic) eri_e = .TRUE. ! information on the states to be calculated - CALL section_vals_val_get(atom_section,"MAX_ANGULAR_MOMENTUM", i_val=maxl, error=error) + CALL section_vals_val_get(atom_section,"MAX_ANGULAR_MOMENTUM", i_val=maxl) maxn=0 - CALL section_vals_val_get(atom_section,"CALCULATE_STATES", i_vals=cn, error=error) + CALL section_vals_val_get(atom_section,"CALCULATE_STATES", i_vals=cn) DO in = 1, MIN(SIZE(cn),4) maxn(in-1) = cn(in) END DO @@ -167,58 +165,58 @@ SUBROUTINE atom_pseudo_opt(atom_section,error) END DO ! read optimization section - opt_section => section_vals_get_subs_vals(atom_section,"OPTIMIZATION",error=error) - CALL read_atom_opt_section(optimization,opt_section,error) + opt_section => section_vals_get_subs_vals(atom_section,"OPTIMIZATION") + CALL read_atom_opt_section(optimization,opt_section) ! Check for the total number of electron configurations to be calculated - CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", n_rep_val=n_rep) ! Check for the total number of method types to be calculated - method_section => section_vals_get_subs_vals(atom_section,"METHOD",error=error) - CALL section_vals_get(method_section,n_repetition=n_meth,error=error) + method_section => section_vals_get_subs_vals(atom_section,"METHOD") + CALL section_vals_get(method_section,n_repetition=n_meth) ! integrals ALLOCATE(ae_int, pp_int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE(atom_info(n_rep,n_meth),atom_refs(n_rep,n_meth),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%PROGRAM_BANNER",extension=".log") IF(iw > 0) THEN WRITE(iw,'(/," ",79("*"))') WRITE(iw,'(" ",26("*"),A,25("*"))') " Calculate Reference States " WRITE(iw,'(" ",79("*"))') END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%PROGRAM_BANNER") DO in = 1, n_rep DO im = 1, n_meth NULLIFY(atom_info(in,im)%atom,atom_refs(in,im)%atom) - CALL create_atom_type(atom_info(in,im)%atom,error) - CALL create_atom_type(atom_refs(in,im)%atom,error) + CALL create_atom_type(atom_info(in,im)%atom) + CALL create_atom_type(atom_refs(in,im)%atom) atom_info(in,im)%atom%optimization = optimization atom_refs(in,im)%atom%optimization = optimization atom_info(in,im)%atom%z = zval atom_refs(in,im)%atom%z = zval - xc_section => section_vals_get_subs_vals(method_section,"XC",i_rep_section=im,error=error) + xc_section => section_vals_get_subs_vals(method_section,"XC",i_rep_section=im) atom_info(in,im)%atom%xc_section => xc_section atom_refs(in,im)%atom%xc_section => xc_section ALLOCATE(state,statepp,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ! get the electronic configuration CALL section_vals_val_get(atom_section,"ELECTRON_CONFIGURATION", i_rep_val=in,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) ! all electron configurations have to be with full core pp_calc = INDEX(tmpstringlist(1),"CORE") /= 0 - CPPostcondition(.NOT.pp_calc, cp_failure_level, routineP, error, failure) + CPPostcondition(.NOT.pp_calc, cp_failure_level, routineP,failure) ! set occupations - CALL atom_set_occupation(tmpstringlist,state%occ,state%occupation,state%multiplicity,error) + CALL atom_set_occupation(tmpstringlist,state%occ,state%occupation,state%multiplicity) state%maxl_occ = get_maxl_occ(state%occ) state%maxn_occ = get_maxn_occ(state%occ) ! set number of states to be calculated @@ -232,13 +230,13 @@ SUBROUTINE atom_pseudo_opt(atom_section,error) state%maxn_calc(k) = MIN(state%maxn_calc(k),ae_basis%nbas(k)) END DO state%core=0._dp - CALL set_atom(atom_refs(in,im)%atom,zcore=zval,pp_calc=.FALSE.,error=error) + CALL set_atom(atom_refs(in,im)%atom,zcore=zval,pp_calc=.FALSE.) ! set occupations for pseudopotential calculation - CALL section_vals_val_get(atom_section,"CORE", c_vals=tmpstringlist, error=error) - CALL atom_set_occupation(tmpstringlist,statepp%core,pocc,error=error) + CALL section_vals_val_get(atom_section,"CORE", c_vals=tmpstringlist) + CALL atom_set_occupation(tmpstringlist,statepp%core,pocc) zcore = zval - NINT(SUM(statepp%core)) - CALL set_atom(atom_info(in,im)%atom,zcore=zcore,pp_calc=.TRUE.,error=error) + CALL set_atom(atom_info(in,im)%atom,zcore=zcore,pp_calc=.TRUE.) statepp%occ = state%occ - statepp%core statepp%occupation = 0._dp @@ -263,118 +261,118 @@ SUBROUTINE atom_pseudo_opt(atom_section,error) END DO statepp%multiplicity=state%multiplicity - CALL section_vals_val_get(method_section,"METHOD_TYPE",i_val=method,i_rep_val=im,error=error) - CALL section_vals_val_get(method_section,"RELATIVISTIC",i_val=reltyp,i_rep_section=im,error=error) - CALL set_atom(atom_info(in,im)%atom,method_type=method,error=error) - CALL set_atom(atom_refs(in,im)%atom,method_type=method,relativistic=reltyp,error=error) + CALL section_vals_val_get(method_section,"METHOD_TYPE",i_val=method,i_rep_val=im) + CALL section_vals_val_get(method_section,"RELATIVISTIC",i_val=reltyp,i_rep_section=im) + CALL set_atom(atom_info(in,im)%atom,method_type=method) + CALL set_atom(atom_refs(in,im)%atom,method_type=method,relativistic=reltyp) ! calculate integrals: pseudopotential basis ! general integrals - CALL atom_int_setup(pp_int,pp_basis,potential=p_pot,eri_coulomb=eri_c,eri_exchange=eri_e,error=error) + CALL atom_int_setup(pp_int,pp_basis,potential=p_pot,eri_coulomb=eri_c,eri_exchange=eri_e) ! NULLIFY(pp_int%tzora,pp_int%hdkh) ! potential - CALL atom_ppint_setup(pp_int,pp_basis,potential=p_pot,error=error) + CALL atom_ppint_setup(pp_int,pp_basis,potential=p_pot) ! - CALL set_atom(atom_info(in,im)%atom,basis=pp_basis,integrals=pp_int,potential=p_pot,error=error) + CALL set_atom(atom_info(in,im)%atom,basis=pp_basis,integrals=pp_int,potential=p_pot) statepp%maxn_calc(:) = MIN( statepp%maxn_calc(:), pp_basis%nbas(:) ) - CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP, error, failure) + CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP,failure) ! calculate integrals: all electron basis ! general integrals CALL atom_int_setup(ae_int,ae_basis,potential=ae_pot,& - eri_coulomb=eri_c,eri_exchange=eri_e,error=error) + eri_coulomb=eri_c,eri_exchange=eri_e) ! potential - CALL atom_ppint_setup(ae_int,ae_basis,potential=ae_pot,error=error) + CALL atom_ppint_setup(ae_int,ae_basis,potential=ae_pot) ! relativistic correction terms - CALL atom_relint_setup(ae_int,ae_basis,reltyp,zcore=REAL(zval,dp),error=error) + CALL atom_relint_setup(ae_int,ae_basis,reltyp,zcore=REAL(zval,dp)) ! - CALL set_atom(atom_refs(in,im)%atom,basis=ae_basis,integrals=ae_int,potential=ae_pot,error=error) + CALL set_atom(atom_refs(in,im)%atom,basis=ae_basis,integrals=ae_int,potential=ae_pot) state%maxn_calc(:) = MIN( state%maxn_calc(:), ae_basis%nbas(:) ) - CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP, error, failure) + CPPostcondition(ALL(state%maxn_calc(:) >= state%maxn_occ), cp_failure_level, routineP,failure) CALL set_atom(atom_info(in,im)%atom,coulomb_integral_type=do_eric,& - exchange_integral_type=do_erie,error=error) + exchange_integral_type=do_erie) CALL set_atom(atom_refs(in,im)%atom,coulomb_integral_type=do_eric,& - exchange_integral_type=do_erie,error=error) + exchange_integral_type=do_erie) - CALL set_atom(atom_info(in,im)%atom,state=statepp,error=error) + CALL set_atom(atom_info(in,im)%atom,state=statepp) NULLIFY(orbitals) mo = MAXVAL(statepp%maxn_calc) mb = MAXVAL(atom_info(in,im)%atom%basis%nbas) - CALL create_atom_orbs(orbitals,mb,mo,error) - CALL set_atom(atom_info(in,im)%atom,orbitals=orbitals,error=error) + CALL create_atom_orbs(orbitals,mb,mo) + CALL set_atom(atom_info(in,im)%atom,orbitals=orbitals) - CALL set_atom(atom_refs(in,im)%atom,state=state,error=error) + CALL set_atom(atom_refs(in,im)%atom,state=state) NULLIFY(orbitals) mo = MAXVAL(state%maxn_calc) mb = MAXVAL(atom_refs(in,im)%atom%basis%nbas) - CALL create_atom_orbs(orbitals,mb,mo,error) - CALL set_atom(atom_refs(in,im)%atom,orbitals=orbitals,error=error) + CALL create_atom_orbs(orbitals,mb,mo) + CALL set_atom(atom_refs(in,im)%atom,orbitals=orbitals) IF(atom_consistent_method(atom_refs(in,im)%atom%method_type,atom_refs(in,im)%atom%state%multiplicity)) THEN !Print method info - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%METHOD_INFO",extension=".log",error=error) - CALL atom_print_method(atom_refs(in,im)%atom,iw,error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%METHOD_INFO",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%METHOD_INFO",extension=".log") + CALL atom_print_method(atom_refs(in,im)%atom,iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%METHOD_INFO") !Calculate the electronic structure - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%SCF_INFO",extension=".log",error=error) - CALL calculate_atom(atom_refs(in,im)%atom,iw,error=error) - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%SCF_INFO",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%SCF_INFO",extension=".log") + CALL calculate_atom(atom_refs(in,im)%atom,iw) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%SCF_INFO") END IF END DO END DO - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_PSEUDO",extension=".log",error=error) + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_PSEUDO",extension=".log") IF(iw > 0) THEN WRITE(iw,'(/," ",79("*"))') WRITE(iw,'(" ",21("*"),A,21("*"))') " Optimize Pseudopotential Parameters " WRITE(iw,'(" ",79("*"))') END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_PSEUDO",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_PSEUDO") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log") IF (iw>0) THEN - CALL atom_print_potential(p_pot,iw,error) + CALL atom_print_potential(p_pot,iw) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_PSEUDO",extension=".log",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%FIT_PSEUDO",extension=".log") IF (iw>0) THEN - powell_section => section_vals_get_subs_vals(atom_section,"POWELL",error=error) - CALL atom_fit_pseudo (atom_info,atom_refs,p_pot,iw,powell_section,error) + powell_section => section_vals_get_subs_vals(atom_section,"POWELL") + CALL atom_fit_pseudo (atom_info,atom_refs,p_pot,iw,powell_section) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_PSEUDO",error=error) - iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%FIT_PSEUDO") + iw = cp_print_key_unit_nr(logger,atom_section,"PRINT%POTENTIAL",extension=".log") IF (iw>0) THEN - CALL atom_print_potential(p_pot,iw,error) + CALL atom_print_potential(p_pot,iw) END IF - CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL",error=error) + CALL cp_print_key_finished_output(iw,logger,atom_section,"PRINT%POTENTIAL") ! clean up - CALL atom_int_release(ae_int,error) - CALL atom_ppint_release(ae_int,error) - CALL atom_relint_release(ae_int,error) + CALL atom_int_release(ae_int) + CALL atom_ppint_release(ae_int) + CALL atom_relint_release(ae_int) - CALL atom_int_release(pp_int,error) - CALL atom_ppint_release(pp_int,error) - CALL atom_relint_release(pp_int,error) + CALL atom_int_release(pp_int) + CALL atom_ppint_release(pp_int) + CALL atom_relint_release(pp_int) - CALL release_atom_basis(ae_basis,error) - CALL release_atom_basis(pp_basis,error) + CALL release_atom_basis(ae_basis) + CALL release_atom_basis(pp_basis) - CALL release_atom_potential(p_pot,error) - CALL release_atom_potential(ae_pot,error) + CALL release_atom_potential(p_pot) + CALL release_atom_potential(ae_pot) DO in = 1, n_rep DO im = 1, n_meth - CALL release_atom_type(atom_info(in,im)%atom,error) - CALL release_atom_type(atom_refs(in,im)%atom,error) + CALL release_atom_type(atom_info(in,im)%atom) + CALL release_atom_type(atom_refs(in,im)%atom) END DO END DO DEALLOCATE(atom_info,atom_refs,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(ae_pot,p_pot,ae_basis,pp_basis,ae_int,pp_int,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL timestop(handle) diff --git a/src/atom_types.F b/src/atom_types.F index d7a24ba1b2..637d5c40a3 100644 --- a/src/atom_types.F +++ b/src/atom_types.F @@ -271,7 +271,6 @@ MODULE atom_types !> \param basis_section ... !> \param zval ... !> \param btyp ... -!> \param error ... !> \note Highly accurate relativistic universal Gaussian basis set: Dirac-Fock-Coulomb calculations !> for atomic systems up to nobelium !> J. Chem. Phys. 101, 6829 (1994); DOI:10.1063/1.468311 @@ -294,12 +293,11 @@ MODULE atom_types !> by Parpia, Mohanty, and Clementi [J. Phys. B 25, 1 (1992)]. The accuracy of our calculations is !> estimated to be within a few parts in 109 for all the atomic systems studied. ! ***************************************************************************** - SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) + SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp) TYPE(atom_basis_type), INTENT(INOUT) :: basis TYPE(section_vals_type), POINTER :: basis_section INTEGER, INTENT(IN) :: zval CHARACTER(LEN=2) :: btyp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_atom_basis', & routineP = moduleN//':'//routineN @@ -338,11 +336,11 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) NULLIFY(basis%am,basis%cm,basis%as,basis%ns,basis%bf,basis%dbf) ! get information on quadrature type and number of grid points ! allocate and initialize the atomic grid - CALL allocate_grid_atom(basis%grid,error) - CALL section_vals_val_get(basis_section,"QUADRATURE",i_val=quadtype,error=error) - CALL section_vals_val_get(basis_section,"GRID_POINTS",i_val=ngp,error=error) + CALL allocate_grid_atom(basis%grid) + CALL section_vals_val_get(basis_section,"QUADRATURE",i_val=quadtype) + CALL section_vals_val_get(basis_section,"GRID_POINTS",i_val=ngp) CALL cp_assert(ngp > 0,cp_failure_level,cp_assertion_failed,routineP,& - "# point radial grid < 0",error,failure) + "# point radial grid < 0",failure) CALL create_grid_atom(basis%grid,ngp,1,1,0,quadtype) basis%grid%nr = ngp basis%geometrical = .FALSE. @@ -350,15 +348,15 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) basis%cval = 0._dp basis%start = 0 - CALL section_vals_val_get(basis_section,"BASIS_TYPE",i_val=basistype,error=error) - CALL section_vals_val_get(basis_section,"EPS_EIGENVALUE",r_val=basis%eps_eig,error=error) + CALL section_vals_val_get(basis_section,"BASIS_TYPE",i_val=basistype) + CALL section_vals_val_get(basis_section,"EPS_EIGENVALUE",r_val=basis%eps_eig) SELECT CASE (basistype) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (gaussian) basis%basis_type = GTO_BASIS NULLIFY(num_gto) - CALL section_vals_val_get(basis_section,"NUM_GTO",i_vals=num_gto,error=error) + CALL section_vals_val_get(basis_section,"NUM_GTO",i_vals=num_gto) IF ( num_gto(1) < 1 ) THEN ! use default basis IF ( btyp == "AE" ) THEN @@ -371,7 +369,7 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) basis%nbas = nu basis%nprim = nu ALLOCATE (basis%am(nu,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%am(1:nu,0) = ugbs(1:nu) basis%am(1:nu,1) = ugbs(1:nu) basis%am(1:nu,2) = ugbs(1:nu) @@ -384,36 +382,36 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) basis%nprim = basis%nbas m = MAXVAL(basis%nbas) ALLOCATE (basis%am(m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%am = 0._dp IF ( basis%nbas(0) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"S_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(0), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"S_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(0), cp_failure_level, routineP,failure) DO i=1,basis%nbas(0) basis%am(i,0) = expo(i) END DO END IF IF ( basis%nbas(1) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"P_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(1), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"P_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(1), cp_failure_level, routineP,failure) DO i=1,basis%nbas(1) basis%am(i,1) = expo(i) END DO END IF IF ( basis%nbas(2) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"D_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(2), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"D_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(2), cp_failure_level, routineP,failure) DO i=1,basis%nbas(2) basis%am(i,2) = expo(i) END DO END IF IF ( basis%nbas(3) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"F_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(3), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"F_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(3), cp_failure_level, routineP,failure) DO i=1,basis%nbas(3) basis%am(i,3) = expo(i) END DO @@ -423,9 +421,9 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) nr = basis%grid%nr m = MAXVAL(basis%nbas) ALLOCATE (basis%bf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE (basis%dbf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%bf = 0._dp basis%dbf = 0._dp DO l=0,3 @@ -442,16 +440,16 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) CASE (geometrical_gto) basis%basis_type = GTO_BASIS NULLIFY(num_gto) - CALL section_vals_val_get(basis_section,"NUM_GTO",i_vals=num_gto,error=error) + CALL section_vals_val_get(basis_section,"NUM_GTO",i_vals=num_gto) IF ( num_gto(1) < 1 ) THEN IF ( btyp == "AE" ) THEN ! use the Clementi extra large basis - CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti,error) + CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti) ELSEIF ( btyp == "PP" ) THEN ! use the Clementi extra large basis - CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti,error) + CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti) ELSEIF ( btyp == "AA" ) THEN - CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti,error) + CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti) amax = cval**(basis%nbas(0)-1) basis%nbas(0) = NINT((LOG(amax)/LOG(1.6_dp))) cval = 1.6_dp @@ -460,14 +458,14 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) basis%nbas(2) = basis%nbas(0) - 8 basis%nbas(3) = basis%nbas(0) -12 ELSEIF ( btyp == "AP" ) THEN - CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti,error) + CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti) amax = 500._dp/aval basis%nbas = NINT((LOG(amax)/LOG(1.6_dp))) cval = 1.6_dp starti = 0 ELSE ! use the Clementi extra large basis - CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti,error) + CALL Clementi_geobas(zval,cval,aval,basis%nbas,starti) ENDIF basis%nprim = basis%nbas ELSE @@ -477,18 +475,18 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) END DO basis%nprim = basis%nbas NULLIFY(sindex) - CALL section_vals_val_get(basis_section,"START_INDEX",i_vals=sindex,error=error) + CALL section_vals_val_get(basis_section,"START_INDEX",i_vals=sindex) starti = 0 DO i=1,SIZE(sindex) starti(i-1) = sindex(i) - CPPostcondition(sindex(i)>=0, cp_failure_level, routineP, error, failure) + CPPostcondition(sindex(i)>=0, cp_failure_level, routineP,failure) END DO - CALL section_vals_val_get(basis_section,"GEOMETRICAL_FACTOR",r_val=cval,error=error) - CALL section_vals_val_get(basis_section,"GEO_START_VALUE",r_val=aval,error=error) + CALL section_vals_val_get(basis_section,"GEOMETRICAL_FACTOR",r_val=cval) + CALL section_vals_val_get(basis_section,"GEO_START_VALUE",r_val=aval) END IF m = MAXVAL(basis%nbas) ALLOCATE (basis%am(m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%am = 0._dp DO l=0,3 DO i=1,basis%nbas(l) @@ -506,9 +504,9 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) nr = basis%grid%nr m = MAXVAL(basis%nbas) ALLOCATE (basis%bf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE (basis%dbf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%bf = 0._dp basis%dbf = 0._dp DO l=0,3 @@ -524,19 +522,19 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) END DO CASE (contracted_gto) basis%basis_type = CGTO_BASIS - CALL section_vals_val_get(basis_section,"BASIS_SET_FILE_NAME",c_val=basis_fn,error=error) - CALL section_vals_val_get(basis_section,"BASIS_SET",c_val=basis_name,error=error) - gto_basis_section => section_vals_get_subs_vals(basis_section,"BASIS",error=error) + CALL section_vals_val_get(basis_section,"BASIS_SET_FILE_NAME",c_val=basis_fn) + CALL section_vals_val_get(basis_section,"BASIS_SET",c_val=basis_name) + gto_basis_section => section_vals_get_subs_vals(basis_section,"BASIS") CALL read_basis_set(ptable(zval)%symbol,basis,basis_name,basis_fn,& - gto_basis_section,error) + gto_basis_section) ! initialize basis function on a radial grid nr = basis%grid%nr m = MAXVAL(basis%nbas) ALLOCATE (basis%bf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE (basis%dbf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%bf = 0._dp basis%dbf = 0._dp DO l=0,3 @@ -556,9 +554,9 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) CASE (slater) basis%basis_type = STO_BASIS NULLIFY(num_slater) - CALL section_vals_val_get(basis_section,"NUM_SLATER",i_vals=num_slater,error=error) + CALL section_vals_val_get(basis_section,"NUM_SLATER",i_vals=num_slater) IF ( num_slater(1) < 1 ) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) ELSE basis%nbas = 0 DO i=1,SIZE(num_slater) @@ -567,61 +565,61 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) basis%nprim = basis%nbas m = MAXVAL(basis%nbas) ALLOCATE (basis%as(m,0:3),basis%ns(m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%as = 0._dp basis%ns = 0 IF ( basis%nbas(0) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"S_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(0), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"S_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(0), cp_failure_level, routineP,failure) DO i=1,basis%nbas(0) basis%as(i,0) = expo(i) END DO NULLIFY(nqm) - CALL section_vals_val_get(basis_section,"S_QUANTUM_NUMBERS",i_vals=nqm,error=error) - CPPostcondition(SIZE(nqm)>=basis%nbas(0), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"S_QUANTUM_NUMBERS",i_vals=nqm) + CPPostcondition(SIZE(nqm)>=basis%nbas(0), cp_failure_level, routineP,failure) DO i=1,basis%nbas(0) basis%ns(i,0) = nqm(i) END DO END IF IF ( basis%nbas(1) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"P_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(1), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"P_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(1), cp_failure_level, routineP,failure) DO i=1,basis%nbas(1) basis%as(i,1) = expo(i) END DO NULLIFY(nqm) - CALL section_vals_val_get(basis_section,"P_QUANTUM_NUMBERS",i_vals=nqm,error=error) - CPPostcondition(SIZE(nqm)>=basis%nbas(1), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"P_QUANTUM_NUMBERS",i_vals=nqm) + CPPostcondition(SIZE(nqm)>=basis%nbas(1), cp_failure_level, routineP,failure) DO i=1,basis%nbas(1) basis%ns(i,1) = nqm(i) END DO END IF IF ( basis%nbas(2) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"D_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(2), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"D_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(2), cp_failure_level, routineP,failure) DO i=1,basis%nbas(2) basis%as(i,2) = expo(i) END DO NULLIFY(nqm) - CALL section_vals_val_get(basis_section,"D_QUANTUM_NUMBERS",i_vals=nqm,error=error) - CPPostcondition(SIZE(nqm)>=basis%nbas(2), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"D_QUANTUM_NUMBERS",i_vals=nqm) + CPPostcondition(SIZE(nqm)>=basis%nbas(2), cp_failure_level, routineP,failure) DO i=1,basis%nbas(2) basis%ns(i,2) = nqm(i) END DO END IF IF ( basis%nbas(3) > 0 ) THEN NULLIFY(expo) - CALL section_vals_val_get(basis_section,"F_EXPONENTS",r_vals=expo,error=error) - CPPostcondition(SIZE(expo)>=basis%nbas(3), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"F_EXPONENTS",r_vals=expo) + CPPostcondition(SIZE(expo)>=basis%nbas(3), cp_failure_level, routineP,failure) DO i=1,basis%nbas(3) basis%as(i,3) = expo(i) END DO NULLIFY(nqm) - CALL section_vals_val_get(basis_section,"F_QUANTUM_NUMBERS",i_vals=nqm,error=error) - CPPostcondition(SIZE(nqm)>=basis%nbas(3), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(basis_section,"F_QUANTUM_NUMBERS",i_vals=nqm) + CPPostcondition(SIZE(nqm)>=basis%nbas(3), cp_failure_level, routineP,failure) DO i=1,basis%nbas(3) basis%ns(i,3) = nqm(i) END DO @@ -631,9 +629,9 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) nr = basis%grid%nr m = MAXVAL(basis%nbas) ALLOCATE (basis%bf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE (basis%dbf(nr,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%bf = 0._dp basis%dbf = 0._dp DO l=0,3 @@ -651,7 +649,7 @@ SUBROUTINE init_atom_basis(basis,basis_section,zval,btyp,error) END DO CASE (numerical) basis%basis_type = NUM_BASIS - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE init_atom_basis @@ -659,11 +657,9 @@ END SUBROUTINE init_atom_basis ! ***************************************************************************** !> \brief ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_atom_basis(basis,error) + SUBROUTINE release_atom_basis(basis) TYPE(atom_basis_type), INTENT(INOUT) :: basis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_atom_basis', & routineP = moduleN//':'//routineN @@ -675,30 +671,30 @@ SUBROUTINE release_atom_basis(basis,error) IF(ASSOCIATED(basis%am)) THEN DEALLOCATE (basis%am,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF(ASSOCIATED(basis%cm)) THEN DEALLOCATE (basis%cm,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF(ASSOCIATED(basis%as)) THEN DEALLOCATE (basis%as,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF(ASSOCIATED(basis%ns)) THEN DEALLOCATE (basis%ns,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF(ASSOCIATED(basis%bf)) THEN DEALLOCATE (basis%bf,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF(ASSOCIATED(basis%dbf)) THEN DEALLOCATE (basis%dbf,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF - CALL deallocate_grid_atom(basis%grid,error) + CALL deallocate_grid_atom(basis%grid) END SUBROUTINE release_atom_basis ! ***************************************************************************** @@ -706,11 +702,9 @@ END SUBROUTINE release_atom_basis ! ***************************************************************************** !> \brief ... !> \param atom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_atom_type(atom,error) + SUBROUTINE create_atom_type(atom) TYPE(atom_type), POINTER :: atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atom_type', & routineP = moduleN//':'//routineN @@ -720,10 +714,10 @@ SUBROUTINE create_atom_type(atom,error) failure = .FALSE. - CPAssert(.NOT.ASSOCIATED(atom),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.ASSOCIATED(atom),cp_failure_level,routineP,failure) ALLOCATE(atom,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(atom%zmp_section) NULLIFY(atom%xc_section) @@ -737,11 +731,9 @@ END SUBROUTINE create_atom_type ! ***************************************************************************** !> \brief ... !> \param atom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_atom_type(atom,error) + SUBROUTINE release_atom_type(atom) TYPE(atom_type), POINTER :: atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_atom_type', & routineP = moduleN//':'//routineN @@ -751,21 +743,21 @@ SUBROUTINE release_atom_type(atom,error) failure = .FALSE. - CPAssert(ASSOCIATED(atom),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(atom),cp_failure_level,routineP,failure) NULLIFY(atom%basis) NULLIFY(atom%integrals) IF(ASSOCIATED(atom%state)) THEN DEALLOCATE(atom%state,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(atom%state) END IF IF(ASSOCIATED(atom%orbitals)) THEN - CALL release_atom_orbs(atom%orbitals,error) + CALL release_atom_orbs(atom%orbitals) END IF DEALLOCATE(atom,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(atom) END SUBROUTINE release_atom_type @@ -788,10 +780,9 @@ END SUBROUTINE release_atom_type !> \param relativistic ... !> \param coulomb_integral_type ... !> \param exchange_integral_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_atom(atom,basis,state,integrals,orbitals,potential,zcore,pp_calc,do_zmp,doread,& - read_vxc,method_type,relativistic,coulomb_integral_type,exchange_integral_type,error) + read_vxc,method_type,relativistic,coulomb_integral_type,exchange_integral_type) TYPE(atom_type), POINTER :: atom TYPE(atom_basis_type), OPTIONAL, POINTER :: basis TYPE(atom_state), OPTIONAL, POINTER :: state @@ -805,7 +796,6 @@ SUBROUTINE set_atom(atom,basis,state,integrals,orbitals,potential,zcore,pp_calc, INTEGER, INTENT(IN), OPTIONAL :: method_type, relativistic, & coulomb_integral_type, & exchange_integral_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_atom', & routineP = moduleN//':'//routineN @@ -814,7 +804,7 @@ SUBROUTINE set_atom(atom,basis,state,integrals,orbitals,potential,zcore,pp_calc, failure = .FALSE. - CPAssert(ASSOCIATED(atom),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(atom),cp_failure_level,routineP,failure) IF(PRESENT(basis)) atom%basis => basis IF(PRESENT(state)) atom%state => state @@ -840,12 +830,10 @@ END SUBROUTINE set_atom !> \param orbs ... !> \param mbas ... !> \param mo ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_atom_orbs(orbs,mbas,mo,error) + SUBROUTINE create_atom_orbs(orbs,mbas,mo) TYPE(atom_orbitals), POINTER :: orbs INTEGER, INTENT(IN) :: mbas, mo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atom_orbs', & routineP = moduleN//':'//routineN @@ -855,49 +843,49 @@ SUBROUTINE create_atom_orbs(orbs,mbas,mo,error) failure = .FALSE. - CPAssert(.NOT.ASSOCIATED(orbs),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.ASSOCIATED(orbs),cp_failure_level,routineP,failure) ALLOCATE(orbs,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ALLOCATE(orbs%wfn(mbas,mo,0:3),orbs%wfna(mbas,mo,0:3),orbs%wfnb(mbas,mo,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%wfn = 0._dp orbs%wfna = 0._dp orbs%wfnb = 0._dp ALLOCATE(orbs%pmat(mbas,mbas,0:3),orbs%pmata(mbas,mbas,0:3),orbs%pmatb(mbas,mbas,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%pmat = 0._dp orbs%pmata = 0._dp orbs%pmatb = 0._dp ALLOCATE(orbs%ener(mo,0:3),orbs%enera(mo,0:3),orbs%enerb(mo,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%ener = 0._dp orbs%enera = 0._dp orbs%enerb = 0._dp ALLOCATE(orbs%refene(mo,0:3,2),orbs%refchg(mo,0:3,2),orbs%refnod(mo,0:3,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%refene = 0._dp orbs%refchg = 0._dp orbs%refnod = 0._dp ALLOCATE(orbs%wrefene(mo,0:3,2),orbs%wrefchg(mo,0:3,2),orbs%wrefnod(mo,0:3,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%wrefene = 0._dp orbs%wrefchg = 0._dp orbs%wrefnod = 0._dp ALLOCATE(orbs%crefene(mo,0:3,2),orbs%crefchg(mo,0:3,2),orbs%crefnod(mo,0:3,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%crefene = 0._dp orbs%crefchg = 0._dp orbs%crefnod = 0._dp ALLOCATE(orbs%rcmax(mo,0:3,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%rcmax = 0._dp ALLOCATE(orbs%wpsir0(mo,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) orbs%wpsir0 = 0._dp END SUBROUTINE create_atom_orbs @@ -905,11 +893,9 @@ END SUBROUTINE create_atom_orbs ! ***************************************************************************** !> \brief ... !> \param orbs ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_atom_orbs(orbs,error) + SUBROUTINE release_atom_orbs(orbs) TYPE(atom_orbitals), POINTER :: orbs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_atom_orbs', & routineP = moduleN//':'//routineN @@ -919,81 +905,81 @@ SUBROUTINE release_atom_orbs(orbs,error) failure = .FALSE. - CPAssert(ASSOCIATED(orbs),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(orbs),cp_failure_level,routineP,failure) IF(ASSOCIATED(orbs%wfn)) THEN DEALLOCATE(orbs%wfn,orbs%wfna,orbs%wfnb,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%wfn,orbs%wfna,orbs%wfnb) END IF IF(ASSOCIATED(orbs%pmat)) THEN DEALLOCATE(orbs%pmat,orbs%pmata,orbs%pmatb,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%pmat,orbs%pmata,orbs%pmatb) END IF IF(ASSOCIATED(orbs%ener)) THEN DEALLOCATE(orbs%ener,orbs%enera,orbs%enerb,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%ener,orbs%enera,orbs%enerb) END IF IF(ASSOCIATED(orbs%refene)) THEN DEALLOCATE(orbs%refene,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%refene) END IF IF(ASSOCIATED(orbs%refchg)) THEN DEALLOCATE(orbs%refchg,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%refchg) END IF IF(ASSOCIATED(orbs%refnod)) THEN DEALLOCATE(orbs%refnod,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%refnod) END IF IF(ASSOCIATED(orbs%wrefene)) THEN DEALLOCATE(orbs%wrefene,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%wrefene) END IF IF(ASSOCIATED(orbs%wrefchg)) THEN DEALLOCATE(orbs%wrefchg,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%wrefchg) END IF IF(ASSOCIATED(orbs%wrefnod)) THEN DEALLOCATE(orbs%wrefnod,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%wrefnod) END IF IF(ASSOCIATED(orbs%crefene)) THEN DEALLOCATE(orbs%crefene,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%crefene) END IF IF(ASSOCIATED(orbs%crefchg)) THEN DEALLOCATE(orbs%crefchg,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%crefchg) END IF IF(ASSOCIATED(orbs%crefnod)) THEN DEALLOCATE(orbs%crefnod,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%crefnod) END IF IF(ASSOCIATED(orbs%rcmax)) THEN DEALLOCATE(orbs%rcmax,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%rcmax) END IF IF(ASSOCIATED(orbs%wpsir0)) THEN DEALLOCATE(orbs%wpsir0,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs%wpsir0) END IF DEALLOCATE(orbs,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(orbs) END SUBROUTINE release_atom_orbs @@ -1002,12 +988,10 @@ END SUBROUTINE release_atom_orbs !> \brief ... !> \param opmat ... !> \param n ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_opmat(opmat,n,error) + SUBROUTINE create_opmat(opmat,n) TYPE(opmat_type), POINTER :: opmat INTEGER, DIMENSION(0:3), INTENT(IN) :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_opmat', & routineP = moduleN//':'//routineN @@ -1018,14 +1002,14 @@ SUBROUTINE create_opmat(opmat,n,error) failure = .FALSE. m=MAXVAL(n) - CPPrecondition(.NOT.ASSOCIATED(opmat), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(opmat), cp_failure_level, routineP,failure) ALLOCATE(opmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) opmat%n = n ALLOCATE(opmat%op(m,m,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) opmat%op = 0._dp END SUBROUTINE create_opmat @@ -1033,11 +1017,9 @@ END SUBROUTINE create_opmat ! ***************************************************************************** !> \brief ... !> \param opmat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_opmat(opmat,error) + SUBROUTINE release_opmat(opmat) TYPE(opmat_type), POINTER :: opmat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_opmat', & routineP = moduleN//':'//routineN @@ -1046,14 +1028,14 @@ SUBROUTINE release_opmat(opmat,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(opmat), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(opmat), cp_failure_level, routineP,failure) opmat%n = 0 DEALLOCATE(opmat%op,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(opmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE release_opmat @@ -1061,12 +1043,10 @@ END SUBROUTINE release_opmat !> \brief ... !> \param opgrid ... !> \param grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_opgrid(opgrid,grid,error) + SUBROUTINE create_opgrid(opgrid,grid) TYPE(opgrid_type), POINTER :: opgrid TYPE(grid_atom_type), POINTER :: grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_opgrid', & routineP = moduleN//':'//routineN @@ -1075,17 +1055,17 @@ SUBROUTINE create_opgrid(opgrid,grid,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(opgrid), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(opgrid), cp_failure_level, routineP,failure) ALLOCATE(opgrid,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) opgrid%grid => grid nr = grid%nr ALLOCATE(opgrid%op(nr),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) opgrid%op = 0._dp END SUBROUTINE create_opgrid @@ -1093,11 +1073,9 @@ END SUBROUTINE create_opgrid ! ***************************************************************************** !> \brief ... !> \param opgrid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_opgrid(opgrid,error) + SUBROUTINE release_opgrid(opgrid) TYPE(opgrid_type), POINTER :: opgrid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_opgrid', & routineP = moduleN//':'//routineN @@ -1106,14 +1084,14 @@ SUBROUTINE release_opgrid(opgrid,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(opgrid), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(opgrid), cp_failure_level, routineP,failure) NULLIFY(opgrid%grid) DEALLOCATE(opgrid%op,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(opgrid,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END SUBROUTINE release_opgrid @@ -1124,13 +1102,11 @@ END SUBROUTINE release_opgrid !> \param aval ... !> \param ngto ... !> \param ival ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE Clementi_geobas(zval,cval,aval,ngto,ival,error) + SUBROUTINE Clementi_geobas(zval,cval,aval,ngto,ival) INTEGER, INTENT(IN) :: zval REAL(dp), INTENT(OUT) :: cval, aval INTEGER, DIMENSION(0:3), INTENT(OUT) :: ngto, ival - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'Clementi_geobas', & routineP = moduleN//':'//routineN @@ -1145,7 +1121,7 @@ SUBROUTINE Clementi_geobas(zval,cval,aval,ngto,ival,error) SELECT CASE (zval) CASE DEFAULT - CPPrecondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPrecondition(.FALSE., cp_failure_level, routineP,failure) CASE (1) ! this is from the general geometrical basis and extended cval = 2.0_dp aval = 0.016_dp @@ -1889,16 +1865,14 @@ END SUBROUTINE Clementi_geobas !> \param basis_set_name ... !> \param basis_set_file ... !> \param basis_section ... -!> \param error ... ! ***************************************************************************** SUBROUTINE read_basis_set(element_symbol,basis,basis_set_name,basis_set_file,& - basis_section,error) + basis_section) CHARACTER(LEN=*), INTENT(IN) :: element_symbol TYPE(atom_basis_type), INTENT(INOUT) :: basis CHARACTER(LEN=*), INTENT(IN) :: basis_set_name, basis_set_file TYPE(section_vals_type), POINTER :: basis_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_basis_set', & routineP = moduleN//':'//routineN @@ -1943,21 +1917,21 @@ SUBROUTINE read_basis_set(element_symbol,basis,basis_set_name,basis_set_file,& gcc = 0._dp read_from_input = .FALSE. - CALL section_vals_get(basis_section,explicit=read_from_input, error=error) + CALL section_vals_get(basis_section,explicit=read_from_input) IF (read_from_input) THEN NULLIFY(list,val) - CALL section_vals_list_get(basis_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(basis_section,"_DEFAULT_KEYWORD_",list=list) CALL uppercase(symbol) CALL uppercase(bsname) - is_ok=cp_sll_val_next(list,val,error=error) - CPPrecondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPrecondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) nset - CPPrecondition(nset <= maxset, cp_failure_level, routineP, error, failure) + CPPrecondition(nset <= maxset, cp_failure_level, routineP,failure) DO iset=1,nset - is_ok=cp_sll_val_next(list,val,error=error) - CPPrecondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPrecondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) n(iset) CALL remove_word(line_att) READ(line_att,*) lmin(iset) @@ -1966,7 +1940,7 @@ SUBROUTINE read_basis_set(element_symbol,basis,basis_set_name,basis_set_file,& CALL remove_word(line_att) READ(line_att,*) npgf(iset) CALL remove_word(line_att) - CPPrecondition(npgf(iset) <= maxpri, cp_failure_level, routineP, error, failure) + CPPrecondition(npgf(iset) <= maxpri, cp_failure_level, routineP,failure) nshell(iset) = 0 DO lshell=lmin(iset),lmax(iset) nmin = n(iset) + lshell - lmin(iset) @@ -1977,21 +1951,21 @@ SUBROUTINE read_basis_set(element_symbol,basis,basis_set_name,basis_set_file,& l(nshell(iset)-ishell+i,iset) = lshell END DO END DO - CPPrecondition(LEN_TRIM(line_att)==0, cp_failure_level, routineP, error, failure) + CPPrecondition(LEN_TRIM(line_att)==0, cp_failure_level, routineP,failure) DO ipgf=1,npgf(iset) - is_ok=cp_sll_val_next(list,val,error=error) - CPPrecondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPrecondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) zet(ipgf,iset),(gcc(ipgf,ishell,iset),ishell=1,nshell(iset)) END DO END DO ELSE NULLIFY(parser) - CALL parser_create(parser,basis_set_file,error=error) + CALL parser_create(parser,basis_set_file) ! Search for the requested basis set in the basis set file ! until the basis set is found or the end of file is reached search_loop: DO - CALL parser_search_string(parser,TRIM(bsname),.TRUE.,found,line,error=error) + CALL parser_search_string(parser,TRIM(bsname),.TRUE.,found,line) IF (found) THEN CALL uppercase(symbol) CALL uppercase(bsname) @@ -2009,27 +1983,27 @@ SUBROUTINE read_basis_set(element_symbol,basis,basis_set_name,basis_set_file,& IF (match) THEN ! Read the basis set information - CALL parser_get_object(parser,nset,newline=.TRUE.,error=error) - CPPrecondition(nset <= maxset, cp_failure_level, routineP, error, failure) + CALL parser_get_object(parser,nset,newline=.TRUE.) + CPPrecondition(nset <= maxset, cp_failure_level, routineP,failure) DO iset=1,nset - CALL parser_get_object(parser,n(iset),newline=.TRUE.,error=error) - CALL parser_get_object(parser,lmin(iset),error=error) - CALL parser_get_object(parser,lmax(iset),error=error) - CALL parser_get_object(parser,npgf(iset),error=error) - CPPrecondition(npgf(iset) <= maxpri, cp_failure_level, routineP, error, failure) + CALL parser_get_object(parser,n(iset),newline=.TRUE.) + CALL parser_get_object(parser,lmin(iset)) + CALL parser_get_object(parser,lmax(iset)) + CALL parser_get_object(parser,npgf(iset)) + CPPrecondition(npgf(iset) <= maxpri, cp_failure_level, routineP,failure) nshell(iset) = 0 DO lshell=lmin(iset),lmax(iset) nmin = n(iset) + lshell - lmin(iset) - CALL parser_get_object(parser,ishell,error=error) + CALL parser_get_object(parser,ishell) nshell(iset) = nshell(iset) + ishell DO i=1,ishell l(nshell(iset)-ishell+i,iset) = lshell END DO END DO DO ipgf=1,npgf(iset) - CALL parser_get_object(parser,zet(ipgf,iset),newline=.TRUE.,error=error) + CALL parser_get_object(parser,zet(ipgf,iset),newline=.TRUE.) DO ishell=1,nshell(iset) - CALL parser_get_object(parser,gcc(ipgf,ishell,iset),error=error) + CALL parser_get_object(parser,gcc(ipgf,ishell,iset)) END DO END DO END DO @@ -2039,12 +2013,12 @@ SUBROUTINE read_basis_set(element_symbol,basis,basis_set_name,basis_set_file,& END IF ELSE ! Stop program, if the end of file is reached - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END IF END DO search_loop - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF ! fill in the basis data structures @@ -2063,10 +2037,10 @@ SUBROUTINE read_basis_set(element_symbol,basis,basis_set_name,basis_set_file,& nj = MAXVAL(basis%nprim) ns = MAXVAL(basis%nbas) ALLOCATE (basis%am(nj,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%am = 0._dp ALLOCATE (basis%cm(nj,ns,0:3),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) basis%cm = 0._dp DO j=0,3 @@ -2109,13 +2083,11 @@ END SUBROUTINE read_basis_set !> \brief ... !> \param optimization ... !> \param opt_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_atom_opt_section(optimization,opt_section,error) + SUBROUTINE read_atom_opt_section(optimization,opt_section) TYPE(atom_optimization_type), & INTENT(INOUT) :: optimization TYPE(section_vals_type), POINTER :: opt_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_atom_opt_section', & routineP = moduleN//':'//routineN @@ -2123,11 +2095,11 @@ SUBROUTINE read_atom_opt_section(optimization,opt_section,error) INTEGER :: miter, ndiis REAL(KIND=dp) :: damp, eps_diis, eps_scf - CALL section_vals_val_get(opt_section,"MAX_ITER",i_val=miter,error=error) - CALL section_vals_val_get(opt_section,"EPS_SCF",r_val=eps_scf,error=error) - CALL section_vals_val_get(opt_section,"N_DIIS",i_val=ndiis,error=error) - CALL section_vals_val_get(opt_section,"EPS_DIIS",r_val=eps_diis,error=error) - CALL section_vals_val_get(opt_section,"DAMPING",r_val=damp,error=error) + CALL section_vals_val_get(opt_section,"MAX_ITER",i_val=miter) + CALL section_vals_val_get(opt_section,"EPS_SCF",r_val=eps_scf) + CALL section_vals_val_get(opt_section,"N_DIIS",i_val=ndiis) + CALL section_vals_val_get(opt_section,"EPS_DIIS",r_val=eps_diis) + CALL section_vals_val_get(opt_section,"DAMPING",r_val=damp) optimization%max_iter = miter optimization%eps_scf = eps_scf @@ -2141,13 +2113,11 @@ END SUBROUTINE read_atom_opt_section !> \param potential ... !> \param potential_section ... !> \param zval ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_atom_potential(potential,potential_section,zval,error) + SUBROUTINE init_atom_potential(potential,potential_section,zval) TYPE(atom_potential_type), INTENT(INOUT) :: potential TYPE(section_vals_type), POINTER :: potential_section INTEGER, INTENT(IN) :: zval - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_atom_potential', & routineP = moduleN//':'//routineN @@ -2160,19 +2130,19 @@ SUBROUTINE init_atom_potential(potential,potential_section,zval,error) failure = .FALSE. IF ( zval > 0 ) THEN - CALL section_vals_val_get(potential_section,"PSEUDO_TYPE",i_val=potential%ppot_type,error=error) + CALL section_vals_val_get(potential_section,"PSEUDO_TYPE",i_val=potential%ppot_type) SELECT CASE (potential%ppot_type) CASE (gth_pseudo) - CALL section_vals_val_get(potential_section,"POTENTIAL_FILE_NAME",c_val=pseudo_fn,error=error) - CALL section_vals_val_get(potential_section,"POTENTIAL_NAME",c_val=pseudo_name,error=error) - gth_potential_section => section_vals_get_subs_vals(potential_section,"GTH_POTENTIAL",error=error) + CALL section_vals_val_get(potential_section,"POTENTIAL_FILE_NAME",c_val=pseudo_fn) + CALL section_vals_val_get(potential_section,"POTENTIAL_NAME",c_val=pseudo_name) + gth_potential_section => section_vals_get_subs_vals(potential_section,"GTH_POTENTIAL") CALL read_gth_potential(ptable(zval)%symbol,potential%gth_pot,& - pseudo_name,pseudo_fn,gth_potential_section,error) + pseudo_name,pseudo_fn,gth_potential_section) CASE (no_pseudo) ! do nothing CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT ELSE potential%ppot_type = no_pseudo @@ -2180,7 +2150,7 @@ SUBROUTINE init_atom_potential(potential,potential_section,zval,error) ! confinement NULLIFY(convals) - CALL section_vals_val_get(potential_section,"CONFINEMENT",r_vals=convals,error=error) + CALL section_vals_val_get(potential_section,"CONFINEMENT",r_vals=convals) IF ( SIZE (convals) >= 1 ) THEN IF ( convals(1) > 0.0_dp ) THEN potential%confinement = .TRUE. @@ -2206,11 +2176,9 @@ END SUBROUTINE init_atom_potential ! ***************************************************************************** !> \brief ... !> \param potential ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_atom_potential(potential,error) + SUBROUTINE release_atom_potential(potential) TYPE(atom_potential_type), INTENT(INOUT) :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_atom_potential', & routineP = moduleN//':'//routineN @@ -2225,16 +2193,14 @@ END SUBROUTINE release_atom_potential !> \param pseudo_name ... !> \param pseudo_file ... !> \param potential_section ... -!> \param error ... ! ***************************************************************************** SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& - potential_section,error) + potential_section) CHARACTER(LEN=*), INTENT(IN) :: element_symbol TYPE(atom_gthpot_type), INTENT(INOUT) :: potential CHARACTER(LEN=*), INTENT(IN) :: pseudo_name, pseudo_file TYPE(section_vals_type), POINTER :: potential_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_gth_potential', & routineP = moduleN//':'//routineN @@ -2280,16 +2246,16 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& potential%nexp_nlcc = 0 read_from_input = .FALSE. - CALL section_vals_get(potential_section,explicit=read_from_input, error=error) + CALL section_vals_get(potential_section,explicit=read_from_input) IF (read_from_input) THEN - CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list) CALL uppercase(symbol) CALL uppercase(apname) ! Read the electronic configuration, not used here l = 0 - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) elec_conf(l) CALL remove_word(line_att) DO WHILE (LEN_TRIM(line_att) /= 0) @@ -2300,9 +2266,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& potential%econf(0:3) = elec_conf(0:3) potential%zion = REAL ( SUM(elec_conf), dp ) ! Read r(loc) to define the exponent of the core charge - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) potential%rc CALL remove_word(line_att) ! Read the parameters for the local part of the GTH pseudopotential (ppl) @@ -2314,17 +2280,17 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& END DO ! Check for the next entry: LPOT, NLCC, LSD, or ppnl DO - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) IF(INDEX(line_att,"LPOT") /= 0) THEN potential%lpotextended = .TRUE. CALL remove_word(line_att) READ(line_att,*) potential%nexp_lpot DO ipot=1,potential%nexp_lpot - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) potential%alpha_lpot(ipot) CALL remove_word(line_att) READ(line_att,*) potential%nct_lpot(ipot) @@ -2339,9 +2305,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& CALL remove_word(line_att) READ(line_att,*) potential%nexp_nlcc DO ipot=1,potential%nexp_nlcc - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) potential%alpha_nlcc(ipot) CALL remove_word(line_att) READ(line_att,*) potential%nct_nlcc(ipot) @@ -2358,9 +2324,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& CALL remove_word(line_att) READ(line_att,*) potential%nexp_lsd DO ipot=1,potential%nexp_lsd - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) potential%alpha_lsd(ipot) CALL remove_word(line_att) READ(line_att,*) potential%nct_lsd(ipot) @@ -2380,9 +2346,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& IF (nlmax > 0) THEN ! Load the parameter for nlmax non-local projectors DO l=0,nlmax-1 - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) potential%rcnl(l) CALL remove_word(line_att) READ(line_att,*) potential%nl(l) @@ -2392,10 +2358,10 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& READ(line_att,*) potential%hnl(1,1,l) CALL remove_word(line_att) ELSE - CPPostcondition(LEN_TRIM(line_att)==0, cp_failure_level, routineP, error, failure) - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + CPPostcondition(LEN_TRIM(line_att)==0, cp_failure_level, routineP,failure) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) potential%hnl(i,i,l) CALL remove_word(line_att) END IF @@ -2405,15 +2371,15 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& CALL remove_word(line_att) END DO END DO - CPPostcondition(LEN_TRIM(line_att)==0, cp_failure_level, routineP, error, failure) + CPPostcondition(LEN_TRIM(line_att)==0, cp_failure_level, routineP,failure) END DO END IF ELSE NULLIFY(parser) - CALL parser_create(parser,pseudo_file,error=error) + CALL parser_create(parser,pseudo_file) search_loop: DO - CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line,error=error) + CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line) IF (found) THEN CALL uppercase(symbol) CALL uppercase(apname) @@ -2432,47 +2398,47 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& IF (match) THEN ! Read the electronic configuration l = 0 - CALL parser_get_object(parser,elec_conf(l),newline=.TRUE.,error=error) - DO WHILE (parser_test_next_token(parser,error=error) == "INT") + CALL parser_get_object(parser,elec_conf(l),newline=.TRUE.) + DO WHILE (parser_test_next_token(parser) == "INT") l = l + 1 - CALL parser_get_object(parser,elec_conf(l),error=error) + CALL parser_get_object(parser,elec_conf(l)) END DO potential%econf(0:3) = elec_conf(0:3) potential%zion = REAL ( SUM(elec_conf), dp ) ! Read r(loc) to define the exponent of the core charge - CALL parser_get_object(parser,potential%rc,newline=.TRUE.,error=error) + CALL parser_get_object(parser,potential%rc,newline=.TRUE.) ! Read the parameters for the local part of the GTH pseudopotential (ppl) - CALL parser_get_object(parser,potential%ncl,error=error) + CALL parser_get_object(parser,potential%ncl) DO i=1,potential%ncl - CALL parser_get_object(parser,potential%cl(i),error=error) + CALL parser_get_object(parser,potential%cl(i)) END DO ! Extended type input DO - CALL parser_get_next_line(parser,1,error=error) - IF(parser_test_next_token(parser,error=error) == "INT") THEN + CALL parser_get_next_line(parser,1) + IF(parser_test_next_token(parser) == "INT") THEN EXIT - ELSEIF(parser_test_next_token(parser,error=error) == "STR") THEN - CALL parser_get_object(parser,line,error=error) + ELSEIF(parser_test_next_token(parser) == "STR") THEN + CALL parser_get_object(parser,line) IF(INDEX(LINE,"LPOT") /= 0) THEN ! local potential potential%lpotextended = .TRUE. - CALL parser_get_object(parser,potential%nexp_lpot,error=error) + CALL parser_get_object(parser,potential%nexp_lpot) DO ipot=1,potential%nexp_lpot - CALL parser_get_object(parser,potential%alpha_lpot(ipot),newline=.TRUE.,error=error) - CALL parser_get_object(parser,potential%nct_lpot(ipot),error=error) + CALL parser_get_object(parser,potential%alpha_lpot(ipot),newline=.TRUE.) + CALL parser_get_object(parser,potential%nct_lpot(ipot)) DO ic=1,potential%nct_lpot(ipot) - CALL parser_get_object(parser,potential%cval_lpot(ic,ipot),error=error) + CALL parser_get_object(parser,potential%cval_lpot(ic,ipot)) END DO END DO ELSEIF(INDEX(LINE,"NLCC") /= 0) THEN ! NLCC potential%nlcc = .TRUE. - CALL parser_get_object(parser,potential%nexp_nlcc,error=error) + CALL parser_get_object(parser,potential%nexp_nlcc) DO ipot=1,potential%nexp_nlcc - CALL parser_get_object(parser,potential%alpha_nlcc(ipot),newline=.TRUE.,error=error) - CALL parser_get_object(parser,potential%nct_nlcc(ipot),error=error) + CALL parser_get_object(parser,potential%alpha_nlcc(ipot),newline=.TRUE.) + CALL parser_get_object(parser,potential%nct_nlcc(ipot)) DO ic=1,potential%nct_nlcc(ipot) - CALL parser_get_object(parser,potential%cval_nlcc(ic,ipot),error=error) + CALL parser_get_object(parser,potential%cval_nlcc(ic,ipot)) !make cp2k compatible with bigdft potential%cval_nlcc(ic,ipot)=potential%cval_nlcc(ic,ipot)/(4.0_dp*pi) END DO @@ -2480,36 +2446,36 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& ELSEIF(INDEX(LINE,"LSD") /= 0) THEN ! LSD potential potential%lsdpot = .TRUE. - CALL parser_get_object(parser,potential%nexp_lsd,error=error) + CALL parser_get_object(parser,potential%nexp_lsd) DO ipot=1,potential%nexp_lsd - CALL parser_get_object(parser,potential%alpha_lsd(ipot),newline=.TRUE.,error=error) - CALL parser_get_object(parser,potential%nct_lsd(ipot),error=error) + CALL parser_get_object(parser,potential%alpha_lsd(ipot),newline=.TRUE.) + CALL parser_get_object(parser,potential%nct_lsd(ipot)) DO ic=1,potential%nct_lsd(ipot) - CALL parser_get_object(parser,potential%cval_lsd(ic,ipot),error=error) + CALL parser_get_object(parser,potential%cval_lsd(ic,ipot)) END DO END DO ELSE - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END IF ELSE - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END IF END DO ! Read the parameters for the non-local part of the GTH pseudopotential (ppnl) - CALL parser_get_object(parser,nlmax,error=error) + CALL parser_get_object(parser,nlmax) IF (nlmax > 0) THEN ! Load the parameter for n non-local projectors DO l=0,nlmax-1 - CALL parser_get_object(parser,potential%rcnl(l),newline=.TRUE.,error=error) - CALL parser_get_object(parser,potential%nl(l),error=error) + CALL parser_get_object(parser,potential%rcnl(l),newline=.TRUE.) + CALL parser_get_object(parser,potential%nl(l)) DO i=1,potential%nl(l) IF (i == 1) THEN - CALL parser_get_object(parser,potential%hnl(i,i,l),error=error) + CALL parser_get_object(parser,potential%hnl(i,i,l)) ELSE - CALL parser_get_object(parser,potential%hnl(i,i,l),newline=.TRUE.,error=error) + CALL parser_get_object(parser,potential%hnl(i,i,l),newline=.TRUE.) END IF DO j=i+1,potential%nl(l) - CALL parser_get_object(parser,potential%hnl(i,j,l),error=error) + CALL parser_get_object(parser,potential%hnl(i,j,l)) potential%hnl(j,i,l) = potential%hnl(i,j,l) END DO END DO @@ -2519,12 +2485,12 @@ SUBROUTINE read_gth_potential(element_symbol,potential,pseudo_name,pseudo_file,& END IF ELSE ! Stop program, if the end of file is reached - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END IF END DO search_loop - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF END SUBROUTINE read_gth_potential diff --git a/src/atom_utils.F b/src/atom_utils.F index a3c97e35a7..5760e0312a 100644 --- a/src/atom_utils.F +++ b/src/atom_utils.F @@ -82,14 +82,12 @@ MODULE atom_utils !> \param occupation ... !> \param wfnocc ... !> \param multiplicity ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) + SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: ostring REAL(Kind=dp), DIMENSION(0:3, 10) :: occupation, wfnocc INTEGER, INTENT(OUT), OPTIONAL :: multiplicity - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_set_occupation', & routineP = moduleN//':'//routineN @@ -105,8 +103,8 @@ SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) occupation = 0._dp - CPPrecondition(ASSOCIATED(ostring),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ostring) > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ostring),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ostring) > 0,cp_failure_level,routineP,failure) no = SIZE(ostring) @@ -117,7 +115,7 @@ SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) IF ( INDEX(ostring(is),"(") /= 0 ) THEN i1 = INDEX(ostring(is),"(") i2 = INDEX(ostring(is),")") - CPAssert((i2-i1-1 > 0).AND.(i2-i1-1 < 3),cp_failure_level,routineP,error,failure) + CPAssert((i2-i1-1 > 0).AND.(i2-i1-1 < 3),cp_failure_level,routineP,failure) elem = ostring(is)(i1+1:i2-1) IF ( INDEX(elem,"HS") /= 0 ) THEN mult=-2 !High spin @@ -141,7 +139,7 @@ SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) ! core occupation from element [XX] i1 = INDEX(ostring(is),"[") i2 = INDEX(ostring(is),"]") - CPAssert((i2-i1-1 > 0).AND.(i2-i1-1 < 3),cp_failure_level,routineP,error,failure) + CPAssert((i2-i1-1 > 0).AND.(i2-i1-1 < 3),cp_failure_level,routineP,failure) elem = ostring(is)(i1+1:i2-1) ielem=0 DO k=1,nelem @@ -150,7 +148,7 @@ SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) EXIT END IF END DO - CPAssert(ielem /= 0,cp_failure_level,routineP,error,failure) + CPAssert(ielem /= 0,cp_failure_level,routineP,failure) DO l=0,3 el = 2._dp * (2._dp*REAL(l,dp) + 1._dp) e0 = ptable(ielem)%e_conv(l) @@ -172,41 +170,41 @@ SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) jp = INDEX(pstring,"P") jd = INDEX(pstring,"D") jf = INDEX(pstring,"F") - CPAssert(js+jp+jd+jf > 0,cp_failure_level,routineP,error,failure) + CPAssert(js+jp+jd+jf > 0,cp_failure_level,routineP,failure) IF ( js > 0 ) THEN - CPAssert(jp+jd+jf == 0,cp_failure_level,routineP,error,failure) + CPAssert(jp+jd+jf == 0,cp_failure_level,routineP,failure) READ(pstring(1:js-1),*) n READ(pstring(js+1:),*) oo - CPAssert(n > 0,cp_failure_level,routineP,error,failure) - CPAssert(oo >= 0._dp,cp_failure_level,routineP,error,failure) - CPAssert(occupation(0,n)==0,cp_failure_level,routineP,error,failure) + CPAssert(n > 0,cp_failure_level,routineP,failure) + CPAssert(oo >= 0._dp,cp_failure_level,routineP,failure) + CPAssert(occupation(0,n)==0,cp_failure_level,routineP,failure) occupation(0,n) = oo END IF IF ( jp > 0 ) THEN - CPAssert(js+jd+jf == 0,cp_failure_level,routineP,error,failure) + CPAssert(js+jd+jf == 0,cp_failure_level,routineP,failure) READ(pstring(1:jp-1),*) n READ(pstring(jp+1:),*) oo - CPAssert(n > 1,cp_failure_level,routineP,error,failure) - CPAssert(oo >= 0._dp,cp_failure_level,routineP,error,failure) - CPAssert(occupation(1,n-1)==0,cp_failure_level,routineP,error,failure) + CPAssert(n > 1,cp_failure_level,routineP,failure) + CPAssert(oo >= 0._dp,cp_failure_level,routineP,failure) + CPAssert(occupation(1,n-1)==0,cp_failure_level,routineP,failure) occupation(1,n-1) = oo END IF IF ( jd > 0 ) THEN - CPAssert(js+jp+jf == 0,cp_failure_level,routineP,error,failure) + CPAssert(js+jp+jf == 0,cp_failure_level,routineP,failure) READ(pstring(1:jd-1),*) n READ(pstring(jd+1:),*) oo - CPAssert(n > 2,cp_failure_level,routineP,error,failure) - CPAssert(oo >= 0._dp,cp_failure_level,routineP,error,failure) - CPAssert(occupation(2,n-2)==0,cp_failure_level,routineP,error,failure) + CPAssert(n > 2,cp_failure_level,routineP,failure) + CPAssert(oo >= 0._dp,cp_failure_level,routineP,failure) + CPAssert(occupation(2,n-2)==0,cp_failure_level,routineP,failure) occupation(2,n-2) = oo END IF IF ( jf > 0 ) THEN - CPAssert(js+jp+jd == 0,cp_failure_level,routineP,error,failure) + CPAssert(js+jp+jd == 0,cp_failure_level,routineP,failure) READ(pstring(1:jf-1),*) n READ(pstring(jf+1:),*) oo - CPAssert(n > 3,cp_failure_level,routineP,error,failure) - CPAssert(oo >= 0._dp,cp_failure_level,routineP,error,failure) - CPAssert(occupation(3,n-3)==0,cp_failure_level,routineP,error,failure) + CPAssert(n > 3,cp_failure_level,routineP,failure) + CPAssert(oo >= 0._dp,cp_failure_level,routineP,failure) + CPAssert(occupation(3,n-3)==0,cp_failure_level,routineP,failure) occupation(3,n-3) = oo END IF @@ -241,7 +239,7 @@ SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) IF (js==0 .AND. mult==-2) mult=1 IF (js==0 .AND. mult==-3) mult=1 IF (js==0) THEN - CPAssert(mult==1,cp_failure_level,routineP,error,failure) + CPAssert(mult==1,cp_failure_level,routineP,failure) END IF IF (js==1) THEN l=i1 @@ -250,10 +248,10 @@ SUBROUTINE atom_set_occupation(ostring,occupation,wfnocc,multiplicity,error) IF(k > (2*l+1)) k=2*(2*l+1)-k IF(mult==-2) mult=k+1 IF(mult==-3) mult=MOD(k,2)+1 - CPAssert(MOD(k+1-mult,2)==0,cp_failure_level,routineP,error,failure) + CPAssert(MOD(k+1-mult,2)==0,cp_failure_level,routineP,failure) END IF IF (js>1 .AND. mult/=-2) THEN - CPAssert(mult==-2,cp_failure_level,routineP,error,failure) + CPAssert(mult==-2,cp_failure_level,routineP,failure) END IF END IF @@ -308,9 +306,8 @@ END FUNCTION get_maxn_occ !> \param occ ... !> \param maxl ... !> \param maxn ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_denmat(pmat,wfn,nbas,occ,maxl,maxn,error) + SUBROUTINE atom_denmat(pmat,wfn,nbas,occ,maxl,maxn) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(INOUT) :: pmat REAL(KIND=dp), DIMENSION(:, :, 0:), & @@ -320,7 +317,6 @@ SUBROUTINE atom_denmat(pmat,wfn,nbas,occ,maxl,maxn,error) INTENT(IN) :: occ INTEGER, INTENT(IN) :: maxl INTEGER, DIMENSION(0:3), INTENT(IN) :: maxn - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_denmat', & routineP = moduleN//':'//routineN @@ -348,9 +344,8 @@ END SUBROUTINE atom_denmat !> \param maxl ... !> \param typ ... !> \param rr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_density(density,pmat,basis,maxl,typ,rr,error) + SUBROUTINE atom_density(density,pmat,basis,maxl,typ,rr) REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: density REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(IN) :: pmat @@ -359,7 +354,6 @@ SUBROUTINE atom_density(density,pmat,basis,maxl,typ,rr,error) CHARACTER(LEN=*), OPTIONAL :: typ REAL(KIND=dp), DIMENSION(:), & INTENT(IN), OPTIONAL :: rr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_density', & routineP = moduleN//':'//routineN @@ -373,7 +367,7 @@ SUBROUTINE atom_density(density,pmat,basis,maxl,typ,rr,error) failure = .FALSE. IF(PRESENT(typ)) my_typ = typ(1:3) IF(my_typ == "KIN") THEN - CPPrecondition(PRESENT(rr),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(rr),cp_failure_level,routineP,failure) END IF density=0._dp @@ -393,7 +387,7 @@ SUBROUTINE atom_density(density,pmat,basis,maxl,typ,rr,error) basis%dbf(:,i,l)*basis%dbf(:,j,l) + & REAL(l*(l+1),dp)*basis%bf(:,i,l)*basis%bf(:,j,l)/rr(:)) ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END DO @@ -523,7 +517,6 @@ SUBROUTINE atom_read_external_density(density,atom,iw) LOGICAL :: ldm REAL(KIND=dp) :: rr REAL(KIND=dp), ALLOCATABLE :: pmatread(:,:,:) - TYPE(cp_error_type) :: error filename=atom%ext_file ldm=atom%dm @@ -572,7 +565,7 @@ SUBROUTINE atom_read_external_density(density,atom,iw) CALL close_file(unit_number=extunit) - CALL atom_density(density,pmatread,atom%basis,maxl_occ,typ="RHO",error=error) + CALL atom_density(density,pmatread,atom%basis,maxl_occ,typ="RHO") extunit=get_unit_number() CALL open_file(file_name="rho_target.dat",file_status="UNKNOWN",& @@ -653,15 +646,13 @@ END SUBROUTINE atom_read_external_vxc !> \param rcov ... !> \param l ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_orbital_charge(charge,wfn,rcov,l,basis,error) + SUBROUTINE atom_orbital_charge(charge,wfn,rcov,l,basis) REAL(KIND=dp), INTENT(OUT) :: charge REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: wfn REAL(KIND=dp), INTENT(IN) :: rcov INTEGER, INTENT(IN) :: l TYPE(atom_basis_type), INTENT(IN) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_orbital_charge', & routineP = moduleN//':'//routineN @@ -675,7 +666,7 @@ SUBROUTINE atom_orbital_charge(charge,wfn,rcov,l,basis,error) charge=0._dp m=SIZE(basis%bf,1) ALLOCATE(den(m),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) n=basis%nbas(l) den=0._dp DO i=1,n @@ -689,7 +680,7 @@ SUBROUTINE atom_orbital_charge(charge,wfn,rcov,l,basis,error) END DO charge = SUM ( den(1:m) * basis%grid%wr(1:m) ) DEALLOCATE(den,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE atom_orbital_charge ! ***************************************************************************** @@ -698,15 +689,13 @@ END SUBROUTINE atom_orbital_charge !> \param gthpot ... !> \param typ ... !> \param rr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_core_density(corden,gthpot,typ,rr,error) + SUBROUTINE atom_core_density(corden,gthpot,typ,rr) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: corden TYPE(atom_gthpot_type), INTENT(IN) :: gthpot CHARACTER(LEN=*), OPTIONAL :: typ REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_core_density', & routineP = moduleN//':'//routineN @@ -724,7 +713,7 @@ SUBROUTINE atom_core_density(corden,gthpot,typ,rr,error) IF(gthpot%nlcc) THEN m = SIZE(corden) ALLOCATE(fe(m),rc(m),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) n=gthpot%nexp_nlcc DO i=1,n a=gthpot%alpha_nlcc(i) @@ -740,12 +729,12 @@ SUBROUTINE atom_core_density(corden,gthpot,typ,rr,error) corden(:) = corden(:) + REAL(2*j-2,dp)*fe(:)*rc**(2*j-3)*gthpot%cval_nlcc(j,i)/a END IF ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END DO DEALLOCATE(fe,rc,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE atom_core_density @@ -754,14 +743,12 @@ END SUBROUTINE atom_core_density !> \param locpot ... !> \param gthpot ... !> \param rr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_local_potential(locpot,gthpot,rr,error) + SUBROUTINE atom_local_potential(locpot,gthpot,rr) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: locpot TYPE(atom_gthpot_type), INTENT(IN) :: gthpot REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_local_potential', & routineP = moduleN//':'//routineN @@ -774,7 +761,7 @@ SUBROUTINE atom_local_potential(locpot,gthpot,rr,error) failure = .FALSE. m = SIZE(locpot) ALLOCATE(fe(m),rc(m),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) rc(:)=rr(:)/gthpot%rc DO i=1,m locpot(i) = -gthpot%zion*erf(rc(i)/SQRT(2._dp))/rr(i) @@ -796,7 +783,7 @@ SUBROUTINE atom_local_potential(locpot,gthpot,rr,error) END DO END IF DEALLOCATE(fe,rc,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE atom_local_potential ! ***************************************************************************** @@ -806,15 +793,13 @@ END SUBROUTINE atom_local_potential !> \param rcov ... !> \param l ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_orbital_max(rmax,wfn,rcov,l,basis,error) + SUBROUTINE atom_orbital_max(rmax,wfn,rcov,l,basis) REAL(KIND=dp), INTENT(OUT) :: rmax REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: wfn REAL(KIND=dp), INTENT(IN) :: rcov INTEGER, INTENT(IN) :: l TYPE(atom_basis_type), INTENT(IN) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_orbital_max', & routineP = moduleN//':'//routineN @@ -827,7 +812,7 @@ SUBROUTINE atom_orbital_max(rmax,wfn,rcov,l,basis,error) failure = .FALSE. m=SIZE(basis%bf,1) ALLOCATE(dorb(m),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) n=basis%nbas(l) dorb=0._dp DO i=1,n @@ -843,7 +828,7 @@ SUBROUTINE atom_orbital_max(rmax,wfn,rcov,l,basis,error) END IF END DO DEALLOCATE(dorb,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE atom_orbital_max ! ***************************************************************************** @@ -853,15 +838,13 @@ END SUBROUTINE atom_orbital_max !> \param rcov ... !> \param l ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_orbital_nodes(node,wfn,rcov,l,basis,error) + SUBROUTINE atom_orbital_nodes(node,wfn,rcov,l,basis) INTEGER, INTENT(OUT) :: node REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: wfn REAL(KIND=dp), INTENT(IN) :: rcov INTEGER, INTENT(IN) :: l TYPE(atom_basis_type), INTENT(IN) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_orbital_nodes', & routineP = moduleN//':'//routineN @@ -875,7 +858,7 @@ SUBROUTINE atom_orbital_nodes(node,wfn,rcov,l,basis,error) node=0 m=SIZE(basis%bf,1) ALLOCATE(orb(m),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) n=basis%nbas(l) orb=0._dp DO i=1,n @@ -888,7 +871,7 @@ SUBROUTINE atom_orbital_nodes(node,wfn,rcov,l,basis,error) END IF END DO DEALLOCATE(orb,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE atom_orbital_nodes ! ***************************************************************************** @@ -896,13 +879,11 @@ END SUBROUTINE atom_orbital_nodes !> \param value ... !> \param wfn ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_wfnr0(value,wfn,basis,error) + SUBROUTINE atom_wfnr0(value,wfn,basis) REAL(KIND=dp), INTENT(OUT) :: value REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: wfn TYPE(atom_basis_type), INTENT(IN) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_wfnr0', & routineP = moduleN//':'//routineN @@ -925,9 +906,8 @@ END SUBROUTINE atom_wfnr0 !> \param nb ... !> \param nv ... !> \param maxl ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atom_solve(hmat,umat,orb,ener,nb,nv,maxl,error) + SUBROUTINE atom_solve(hmat,umat,orb,ener,nb,nv,maxl) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(IN) :: hmat, umat REAL(KIND=dp), DIMENSION(:, :, 0:), & @@ -936,7 +916,6 @@ SUBROUTINE atom_solve(hmat,umat,orb,ener,nb,nv,maxl,error) INTENT(INOUT) :: ener INTEGER, DIMENSION(0:), INTENT(IN) :: nb, nv INTEGER, INTENT(IN) :: maxl - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_solve', & routineP = moduleN//':'//routineN @@ -948,7 +927,7 @@ SUBROUTINE atom_solve(hmat,umat,orb,ener,nb,nv,maxl,error) DIMENSION(:, :) :: a failure = .FALSE. - CPPrecondition(ALL(nb >= nv),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(nb >= nv),cp_failure_level,routineP,failure) orb = 0._dp DO l=0,maxl @@ -957,7 +936,7 @@ SUBROUTINE atom_solve(hmat,umat,orb,ener,nb,nv,maxl,error) IF ( n > 0 .AND. m > 0 ) THEN lwork = 10*m ALLOCATE(a(n,n),w(n),work(lwork),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) a(1:m,1:m) = MATMUL(TRANSPOSE(umat(1:n,1:m,l)),MATMUL(hmat(1:n,1:n,l),umat(1:n,1:m,l))) CALL lapack_ssyev ( "V", "U", m, a(1:m,1:m), m, w(1:m), work, lwork, info ) a(1:n,1:m) = MATMUL(umat(1:n,1:m,l),a(1:m,1:m)) @@ -967,7 +946,7 @@ SUBROUTINE atom_solve(hmat,umat,orb,ener,nb,nv,maxl,error) ener(1:m,l) = w(1:m) DEALLOCATE(a,w,work,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF END DO @@ -1060,14 +1039,12 @@ END FUNCTION integrate_grid_function3 !> \param cpot ... !> \param density ... !> \param grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE coulomb_potential_numeric ( cpot, density, grid, error ) + SUBROUTINE coulomb_potential_numeric ( cpot, density, grid) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: cpot REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: density TYPE(grid_atom_type), INTENT(IN) :: grid - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'coulomb_potential_numeric', & routineP = moduleN//':'//routineN @@ -1087,7 +1064,7 @@ SUBROUTINE coulomb_potential_numeric ( cpot, density, grid, error ) cpot(nc:) = int1/r(nc:) ! test that grid is decreasing - CPPostcondition(r(1)>r(nc),cp_failure_level,routineP,error,failure) + CPPostcondition(r(1)>r(nc),cp_failure_level,routineP,failure) DO i = 1, nc cpot(i) = int1/r(i) + int2 int1 = int1 - fourpi * density(i)*wr(i) @@ -1105,9 +1082,8 @@ END SUBROUTINE coulomb_potential_numeric !> \param basis ... !> \param grid ... !> \param maxl ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) + SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: cpot REAL(KIND=dp), DIMENSION(:, :, 0:), & @@ -1115,7 +1091,6 @@ SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) TYPE(atom_basis_type), INTENT(IN) :: basis TYPE(grid_atom_type) :: grid INTEGER, INTENT(IN) :: maxl - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'coulomb_potential_analytic', & routineP = moduleN//':'//routineN @@ -1130,7 +1105,7 @@ SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) failure = .FALSE. m = SIZE(cpot) ALLOCATE ( erfa(1:m), expa(1:m), z(1:m), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) cpot = 0._dp @@ -1138,7 +1113,7 @@ SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) IF ( MAXVAL(ABS(pmat(:,:,l))) < 1.e-14_dp ) CYCLE SELECT CASE ( basis%basis_type ) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE ( GTO_BASIS ) DO i = 1, basis%nbas(l) DO j = i, basis%nbas(l) @@ -1156,7 +1131,7 @@ SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) expa(:)= EXP(-z(:)**2)*ff/(a+b)**(l+1) SELECT CASE (l) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) cpot(:) = cpot(:) + 0.25_dp*erfa(:) CASE (1) @@ -1172,7 +1147,7 @@ SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) n = basis%nprim(l) m = basis%nbas(l) ALLOCATE ( unp(n,n), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) unp(1:n,1:n) = MATMUL ( MATMUL(basis%cm(1:n,1:m,l),pmat(1:m,1:m,l)),& TRANSPOSE(basis%cm(1:n,1:m,l))) @@ -1192,7 +1167,7 @@ SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) expa(:)= EXP(-z(:)**2)*ff/(a+b)**(l+1) SELECT CASE (l) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) cpot(:) = cpot(:) + 0.25_dp*erfa(:) CASE (1) @@ -1206,11 +1181,11 @@ SUBROUTINE coulomb_potential_analytic ( cpot, pmat, basis, grid, maxl, error ) END DO DEALLOCATE ( unp, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SELECT END DO DEALLOCATE ( erfa, expa, z, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE coulomb_potential_analytic @@ -1223,9 +1198,8 @@ END SUBROUTINE coulomb_potential_analytic !> \param occ ... !> \param wfn ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE exchange_numeric ( kmat, state, occ, wfn, basis, error ) + SUBROUTINE exchange_numeric ( kmat, state, occ, wfn, basis) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(INOUT) :: kmat TYPE(atom_state), INTENT(IN) :: state @@ -1234,7 +1208,6 @@ SUBROUTINE exchange_numeric ( kmat, state, occ, wfn, basis, error ) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: wfn TYPE(atom_basis_type), INTENT(IN) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'exchange_numeric', & routineP = moduleN//':'//routineN @@ -1259,7 +1232,7 @@ SUBROUTINE exchange_numeric ( kmat, state, occ, wfn, basis, error ) nr = basis%grid%nr ALLOCATE ( nai(nr), nbi(nr), cpot(nr), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO lad = 0, state%maxl_calc DO lbc = 0 , state%maxl_occ @@ -1267,7 +1240,7 @@ SUBROUTINE exchange_numeric ( kmat, state, occ, wfn, basis, error ) nbas = basis%nbas(lbc) ! calculate orbitals for angmom lbc ALLOCATE ( orb(nr,norb), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) orb = 0._dp DO i=1,norb DO k=1,nbas @@ -1281,7 +1254,7 @@ SUBROUTINE exchange_numeric ( kmat, state, occ, wfn, basis, error ) DO ia=1,basis%nbas(lad) DO i=1,norb nai(:) = orb(:,i)*basis%bf(:,ia,lad) - CALL potential_numeric(cpot,nai,nu,basis%grid,error) + CALL potential_numeric(cpot,nai,nu,basis%grid) DO ib=1,basis%nbas(lad) kmat(ia,ib,lad) = kmat(ia,ib,lad) + almn*occ(lbc,i)* & integrate_grid(cpot,orb(:,i),basis%bf(:,ib,lad),basis%grid) @@ -1291,12 +1264,12 @@ SUBROUTINE exchange_numeric ( kmat, state, occ, wfn, basis, error ) END DO DEALLOCATE ( orb, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END DO END DO DEALLOCATE ( nai, nbi, cpot, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE exchange_numeric @@ -1309,9 +1282,8 @@ END SUBROUTINE exchange_numeric !> \param occ ... !> \param wfn ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE exchange_semi_analytic ( kmat, state, occ, wfn, basis, error ) + SUBROUTINE exchange_semi_analytic ( kmat, state, occ, wfn, basis) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(INOUT) :: kmat TYPE(atom_state), INTENT(IN) :: state @@ -1320,7 +1292,6 @@ SUBROUTINE exchange_semi_analytic ( kmat, state, occ, wfn, basis, error ) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: wfn TYPE(atom_basis_type), INTENT(IN) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'exchange_semi_analytic', & routineP = moduleN//':'//routineN @@ -1348,9 +1319,9 @@ SUBROUTINE exchange_semi_analytic ( kmat, state, occ, wfn, basis, error ) nr = basis%grid%nr nbas = MAXVAL(basis%nbas) ALLOCATE ( pot(nr,nbas,nbas), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( nai(nr), nbi(nr), cpot(nr), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO lad = 0, state%maxl_calc DO lbc = 0 , state%maxl_occ @@ -1358,7 +1329,7 @@ SUBROUTINE exchange_semi_analytic ( kmat, state, occ, wfn, basis, error ) nbas = basis%nbas(lbc) ! calculate orbitals for angmom lbc ALLOCATE ( orb(nr,norb), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) orb = 0._dp DO i=1,norb DO k=1,nbas @@ -1370,7 +1341,7 @@ SUBROUTINE exchange_semi_analytic ( kmat, state, occ, wfn, basis, error ) almn = -0.5_dp*almn ! calculate potential for basis function pair (lad,lbc) pot = 0._dp - CALL potential_analytic ( pot, lad, lbc, nu, basis, error ) + CALL potential_analytic ( pot, lad, lbc, nu, basis) DO ia=1,basis%nbas(lad) DO i=1,norb cpot = 0._dp @@ -1385,14 +1356,14 @@ SUBROUTINE exchange_semi_analytic ( kmat, state, occ, wfn, basis, error ) END DO END DO DEALLOCATE ( orb, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END DO END DO DEALLOCATE ( pot, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DEALLOCATE ( nai, nbi, cpot, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE exchange_semi_analytic @@ -1402,15 +1373,13 @@ END SUBROUTINE exchange_semi_analytic !> \param density ... !> \param nu ... !> \param grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE potential_numeric ( cpot, density, nu, grid, error ) + SUBROUTINE potential_numeric ( cpot, density, nu, grid) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: cpot REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: density INTEGER, INTENT(IN) :: nu TYPE(grid_atom_type), INTENT(IN) :: grid - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'potential_numeric', & routineP = moduleN//':'//routineN @@ -1430,7 +1399,7 @@ SUBROUTINE potential_numeric ( cpot, density, nu, grid, error ) cpot(nc:) = int1/r(nc:)**(nu+1) ! test that grid is decreasing - CPPostcondition(r(1)>r(nc),cp_failure_level,routineP,error,failure) + CPPostcondition(r(1)>r(nc),cp_failure_level,routineP,failure) DO i = 1, nc cpot(i) = int1/r(i)**(nu+1) + int2*r(i)**nu int1 = int1 - r(i)**(nu)*density(i)*wr(i) @@ -1445,14 +1414,12 @@ END SUBROUTINE potential_numeric !> \param lb ... !> \param nu ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) + SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis) REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT) :: cpot INTEGER, INTENT(IN) :: la, lb, nu TYPE(atom_basis_type), INTENT(IN) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'potential_analytic', & routineP = moduleN//':'//routineN @@ -1465,7 +1432,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) failure = .FALSE. m = SIZE(cpot,1) ALLOCATE ( erfa(1:m), expa(1:m), z(1:m), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ll = la+lb @@ -1473,7 +1440,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) SELECT CASE ( basis%basis_type ) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE ( GTO_BASIS ) DO i = 1, basis%nbas(la) DO j = 1, basis%nbas(lb) @@ -1489,16 +1456,16 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) expa(:)= EXP(-z(:)**2)/(sab**(ll+2))/(2._dp**((ll+nu)/2+2)) SELECT CASE (ll) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) - CPPostcondition(nu==0,cp_failure_level,routineP,error,failure) + CPPostcondition(nu==0,cp_failure_level,routineP,failure) CASE (1) - CPPostcondition(nu==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nu==1,cp_failure_level,routineP,failure) cpot(:,i,j) = cpot(:,i,j)-6._dp*expa(:)/z(:) CASE (2) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) cpot(:,i,j) = cpot(:,i,j)-2._dp*expa(:) CASE (2) @@ -1507,7 +1474,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (3) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (1) cpot(:,i,j) = cpot(:,i,j)-expa(:)*(12._dp*z(:)+30._dp/z(:)) CASE (3) @@ -1516,7 +1483,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (4) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) cpot(:,i,j) = cpot(:,i,j)-expa(:)*(4._dp*z(:)**2+14._dp) CASE (2) @@ -1527,7 +1494,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (5) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (1) cpot(:,i,j) = cpot(:,i,j)-expa(:)*(24._dp*z(:)**3+108._dp*z(:)+210._dp/z(:)) CASE (3) @@ -1539,7 +1506,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (6) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) cpot(:,i,j) = cpot(:,i,j)-expa(:)*(8._dp*z(:)**4+44._dp*z(:)**2+114._dp) CASE (2) @@ -1568,16 +1535,16 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) expa(:)= EXP(-z(:)**2)/sab**(ll+2)/2._dp**((ll+nu)/2+2) SELECT CASE (ll) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) - CPPostcondition(nu==0,cp_failure_level,routineP,error,failure) + CPPostcondition(nu==0,cp_failure_level,routineP,failure) CASE (1) - CPPostcondition(nu==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nu==1,cp_failure_level,routineP,failure) erfa(:) = erfa(:)-6._dp*expa(:)/z(:) CASE (2) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) erfa(:) = erfa(:)-2._dp*expa(:) CASE (2) @@ -1586,7 +1553,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (3) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (1) erfa(:) = erfa(:)-expa(:)*(12._dp*z(:)+30._dp/z(:)) CASE (3) @@ -1595,7 +1562,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (4) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) erfa(:) = erfa(:)-expa(:)*(4._dp*z(:)**2+14._dp) CASE (2) @@ -1606,7 +1573,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (5) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (1) erfa(:) = erfa(:)-expa(:)*(24._dp*z(:)**3+108._dp*z(:)+210._dp/z(:)) CASE (3) @@ -1618,7 +1585,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) CASE (6) SELECT CASE (nu) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (0) erfa(:) = erfa(:)-expa(:)*(8._dp*z(:)**4+44._dp*z(:)**2+114._dp) CASE (2) @@ -1642,7 +1609,7 @@ SUBROUTINE potential_analytic ( cpot, la, lb, nu, basis, error ) END SELECT DEALLOCATE ( erfa, expa, z, STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE potential_analytic ! ***************************************************************************** @@ -1651,13 +1618,11 @@ END SUBROUTINE potential_analytic !> \brief ... !> \param opmat ... !> \param pmat ... -!> \param error ... !> \retval trace ... ! ***************************************************************************** - FUNCTION atom_trace(opmat,pmat,error) RESULT(trace) + FUNCTION atom_trace(opmat,pmat) RESULT(trace) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(IN) :: opmat, pmat - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp) :: trace CHARACTER(len=*), PARAMETER :: routineN = 'atom_trace', & @@ -1673,15 +1638,13 @@ END FUNCTION atom_trace !> \param cpot ... !> \param basis ... !> \param derivatives ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE numpot_matrix(imat,cpot,basis,derivatives,error) + SUBROUTINE numpot_matrix(imat,cpot,basis,derivatives) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(INOUT) :: imat REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: cpot TYPE(atom_basis_type), INTENT(INOUT) :: basis INTEGER, INTENT(IN) :: derivatives - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'numpot_matrix', & routineP = moduleN//':'//routineN @@ -1728,7 +1691,7 @@ SUBROUTINE numpot_matrix(imat,cpot,basis,derivatives,error) END DO END DO CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE numpot_matrix @@ -1739,9 +1702,8 @@ END SUBROUTINE numpot_matrix !> \param pmat ... !> \param nsize ... !> \param all_nu ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ceri_contract(jmat,erint,pmat,nsize,all_nu,error) + SUBROUTINE ceri_contract(jmat,erint,pmat,nsize,all_nu) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(INOUT) :: jmat TYPE(eri), DIMENSION(:), INTENT(IN) :: erint @@ -1749,7 +1711,6 @@ SUBROUTINE ceri_contract(jmat,erint,pmat,nsize,all_nu,error) INTENT(IN) :: pmat INTEGER, DIMENSION(0:), INTENT(IN) :: nsize LOGICAL, INTENT(IN), OPTIONAL :: all_nu - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ceri_contract', & routineP = moduleN//':'//routineN @@ -1818,16 +1779,14 @@ END SUBROUTINE ceri_contract !> \param erint ... !> \param pmat ... !> \param nsize ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE eeri_contract(kmat,erint,pmat,nsize,error) + SUBROUTINE eeri_contract(kmat,erint,pmat,nsize) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(INOUT) :: kmat TYPE(eri), DIMENSION(:), INTENT(IN) :: erint REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(IN) :: pmat INTEGER, DIMENSION(0:), INTENT(IN) :: nsize - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eeri_contract', & routineP = moduleN//':'//routineN @@ -1902,16 +1861,14 @@ END SUBROUTINE eeri_contract !> \param upmat ... !> \param nval ... !> \param nbs ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE err_matrix(emat,demax,kmat,pmat,umat,upmat,nval,nbs,error) + SUBROUTINE err_matrix(emat,demax,kmat,pmat,umat,upmat,nval,nbs) REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(OUT) :: emat REAL(KIND=dp), INTENT(OUT) :: demax REAL(KIND=dp), DIMENSION(:, :, 0:), & INTENT(IN) :: kmat, pmat, umat, upmat INTEGER, DIMENSION(0:), INTENT(IN) :: nval, nbs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'err_matrix', & routineP = moduleN//':'//routineN @@ -1928,7 +1885,7 @@ SUBROUTINE err_matrix(emat,demax,kmat,pmat,umat,upmat,nval,nbs,error) m = nbs(l) IF (m > 0) THEN ALLOCATE(tkmat(1:m,1:m),tpmat(1:m,1:m),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) tkmat = 0._dp tpmat = 0._dp tkmat(1:m,1:m) = MATMUL(TRANSPOSE(umat(1:n,1:m,l)),MATMUL(kmat(1:n,1:n,l),umat(1:n,1:m,l))) @@ -1938,7 +1895,7 @@ SUBROUTINE err_matrix(emat,demax,kmat,pmat,umat,upmat,nval,nbs,error) emat(1:m,1:m,l) = MATMUL(tkmat(1:m,1:m),tpmat(1:m,1:m)) - MATMUL(tpmat(1:m,1:m),tkmat(1:m,1:m)) DEALLOCATE(tkmat,tpmat,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF END DO demax = MAXVAL(ABS(emat)) @@ -1951,14 +1908,12 @@ END SUBROUTINE err_matrix !> \param zcore ... !> \param state ... !> \param grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE slater_density(density1,density2,zcore,state,grid,error) + SUBROUTINE slater_density(density1,density2,zcore,state,grid) REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: density1, density2 INTEGER, INTENT(IN) :: zcore TYPE(atom_state), INTENT(IN) :: state TYPE(grid_atom_type), INTENT(IN) :: grid - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'slater_density', & routineP = moduleN//':'//routineN @@ -1991,12 +1946,10 @@ END SUBROUTINE slater_density !> \brief ... !> \param rho ... !> \param vxc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE wigner_slater_functional(rho,vxc,error) + SUBROUTINE wigner_slater_functional(rho,vxc) REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rho REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: vxc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wigner_slater_functional', & routineP = moduleN//':'//routineN diff --git a/src/atom_xc.F b/src/atom_xc.F index 22a223b675..0ea2a8a17d 100644 --- a/src/atom_xc.F +++ b/src/atom_xc.F @@ -66,17 +66,15 @@ MODULE atom_xc !> \param atom ... !> \param lprint ... !> \param xcmat ... -!> \param error ... !> \author D. Varsano [daniele.varsano@nano.cnr.it] !> ! ***************************************************************************** - SUBROUTINE calculate_atom_zmp(ext_density,atom,lprint,xcmat,error) + SUBROUTINE calculate_atom_zmp(ext_density,atom,lprint,xcmat) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: ext_density TYPE(atom_type), INTENT(INOUT) :: atom LOGICAL :: lprint TYPE(opmat_type), OPTIONAL, POINTER :: xcmat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_atom_zmp', & routineP = moduleN//':'//routineN @@ -95,12 +93,12 @@ SUBROUTINE calculate_atom_zmp(ext_density,atom,lprint,xcmat,error) nr = atom%basis%grid%nr z = atom%z ALLOCATE(rho(nr,1),vxc(nr),vxc1(nr),vxc2(nr),rho_dum(nr),deltarho(nr),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO") !Vxc1 int1=integrate_grid(ext_density,atom%basis%grid) int1=fourpi*int1 - CALL coulomb_potential_numeric(vxc1,rho(:,1),atom%basis%grid,error) + CALL coulomb_potential_numeric(vxc1,rho(:,1),atom%basis%grid) vxc1 = -vxc1/z @@ -108,7 +106,7 @@ SUBROUTINE calculate_atom_zmp(ext_density,atom,lprint,xcmat,error) rho_dum=rho(:,1)*int1/z deltarho=rho_dum-ext_density int2=integrate_grid(deltarho,atom%basis%grid) - CALL coulomb_potential_numeric(vxc2,deltarho,atom%basis%grid,error) + CALL coulomb_potential_numeric(vxc2,deltarho,atom%basis%grid) vxc2=vxc2*atom%lambda @@ -132,10 +130,10 @@ SUBROUTINE calculate_atom_zmp(ext_density,atom,lprint,xcmat,error) CALL close_file(unit_number=extunit) ENDIF - IF(PRESENT(xcmat)) CALL numpot_matrix(xcmat%op,vxc,atom%basis,0,error) + IF(PRESENT(xcmat)) CALL numpot_matrix(xcmat%op,vxc,atom%basis,0) DEALLOCATE(rho,vxc,vxc1,vxc2,rho_dum,deltarho,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -147,17 +145,15 @@ END SUBROUTINE calculate_atom_zmp !> \param atom ... !> \param lprint ... !> \param xcmat ... -!> \param error ... !> \author D. Varsano [daniele.varsano@nano.cnr.it] !> ! ***************************************************************************** - SUBROUTINE calculate_atom_ext_vxc(vxc,atom,lprint,xcmat,error) + SUBROUTINE calculate_atom_ext_vxc(vxc,atom,lprint,xcmat) REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vxc TYPE(atom_type), INTENT(INOUT) :: atom LOGICAL, INTENT(in) :: lprint TYPE(opmat_type), INTENT(inout), & OPTIONAL, POINTER :: xcmat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_atom_ext_vxc', & routineP = moduleN//':'//routineN @@ -171,9 +167,9 @@ SUBROUTINE calculate_atom_ext_vxc(vxc,atom,lprint,xcmat,error) nr = atom%basis%grid%nr ALLOCATE(rho(nr,1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) - CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) + CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO") IF (lprint) THEN extunit=get_unit_number() @@ -190,10 +186,10 @@ SUBROUTINE calculate_atom_ext_vxc(vxc,atom,lprint,xcmat,error) ENDIF atom%energy%exc = fourpi*integrate_grid(vxc,rho(:,1),atom%basis%grid) - IF(PRESENT(xcmat)) CALL numpot_matrix(xcmat%op,vxc,atom%basis,0,error) + IF(PRESENT(xcmat)) CALL numpot_matrix(xcmat%op,vxc,atom%basis,0) DEALLOCATE(rho,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -203,13 +199,11 @@ END SUBROUTINE calculate_atom_ext_vxc !> \param xcmat ... !> \param atom ... !> \param xc_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_atom_vxc_lda(xcmat,atom,xc_section,error) + SUBROUTINE calculate_atom_vxc_lda(xcmat,atom,xc_section) TYPE(opmat_type), POINTER :: xcmat TYPE(atom_type), INTENT(INOUT) :: atom TYPE(section_vals_type), POINTER :: xc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_atom_vxc_lda', & routineP = moduleN//':'//routineN @@ -244,19 +238,19 @@ SUBROUTINE calculate_atom_vxc_lda(xcmat,atom,xc_section,error) IF ( ASSOCIATED(xc_section) ) THEN NULLIFY(rho_set) - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",error=error) - CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun,error=error) + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") + CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun) IF(myfun == xc_none) THEN atom%energy%exc = 0._dp ELSE - CALL section_vals_val_get(xc_section,"DENSITY_CUTOFF",r_val=density_cut,error=error) - CALL section_vals_val_get(xc_section,"GRADIENT_CUTOFF",r_val=gradient_cut,error=error) - CALL section_vals_val_get(xc_section,"TAU_CUTOFF",r_val=tau_cut,error=error) + CALL section_vals_val_get(xc_section,"DENSITY_CUTOFF",r_val=density_cut) + CALL section_vals_val_get(xc_section,"GRADIENT_CUTOFF",r_val=gradient_cut) + CALL section_vals_val_get(xc_section,"TAU_CUTOFF",r_val=tau_cut) lsd = .FALSE. nspins = 1 - needs = xc_functionals_get_needs(xc_fun_section,lsd=lsd,add_basic_components=.FALSE.,error=error) + needs = xc_functionals_get_needs(xc_fun_section,lsd=lsd,add_basic_components=.FALSE.) ! Prepare the structures needed to calculate and store the xc derivatives @@ -269,48 +263,48 @@ SUBROUTINE calculate_atom_vxc_lda(xcmat,atom,xc_section,error) ! create a place where to put the derivatives NULLIFY(deriv_set) - CALL xc_dset_create(deriv_set, local_bounds=bounds, error=error) + CALL xc_dset_create(deriv_set, local_bounds=bounds) ! create the place where to store the argument for the functionals CALL xc_rho_set_create(rho_set,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) ! allocate the required 3d arrays where to store rho and drho CALL xc_rho_set_atom_update(rho_set,needs,nspins,bounds) NULLIFY(rho,drho,tau) IF ( needs%rho ) THEN ALLOCATE(rho(nr,1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO") IF ( nlcc ) THEN - CALL atom_core_density(rho(:,1),atom%potential%gth_pot,typ="RHO",rr=atom%basis%grid%rad,error=error) + CALL atom_core_density(rho(:,1),atom%potential%gth_pot,typ="RHO",rr=atom%basis%grid%rad) END IF END IF IF ( needs%norm_drho ) THEN ALLOCATE(drho(nr,1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL atom_density(drho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="DER",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL atom_density(drho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="DER") IF ( nlcc ) THEN - CALL atom_core_density(drho(:,1),atom%potential%gth_pot,typ="DER",rr=atom%basis%grid%rad,error=error) + CALL atom_core_density(drho(:,1),atom%potential%gth_pot,typ="DER",rr=atom%basis%grid%rad) END IF END IF IF ( needs%tau ) THEN ALLOCATE(tau(nr,1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL atom_density(tau(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,& - typ="KIN",rr=atom%basis%grid%rad2,error=error) + typ="KIN",rr=atom%basis%grid%rad2) END IF - CALL fill_rho_set(rho_set,nspins,needs,rho,drho,tau,nr,error=error) + CALL fill_rho_set(rho_set,nspins,needs,rho,drho,tau,nr) - CALL xc_dset_zero_all(deriv_set, error) + CALL xc_dset_zero_all(deriv_set) deriv_order = 1 CALL xc_functionals_eval(xc_fun_section,lsd=lsd,rho_set=rho_set,deriv_set=deriv_set,& - deriv_order=deriv_order,error=error) + deriv_order=deriv_order) ! Integration to get the matrix elements and energy - deriv => xc_dset_get_derivative(deriv_set,"",allocate_deriv=.FALSE., error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) + deriv => xc_dset_get_derivative(deriv_set,"",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) atom%energy%exc = fourpi*integrate_grid(xcpot(:,1,1),atom%basis%grid) ! dump grid density and xcpot (xc energy?) @@ -323,46 +317,46 @@ SUBROUTINE calculate_atom_vxc_lda(xcmat,atom,xc_section,error) ENDIF IF ( needs%rho ) THEN - deriv => xc_dset_get_derivative(deriv_set,"(rho)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) - CALL numpot_matrix(xcmat%op,xcpot(:,1,1),atom%basis,0,error) + deriv => xc_dset_get_derivative(deriv_set,"(rho)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) + CALL numpot_matrix(xcmat%op,xcpot(:,1,1),atom%basis,0) DEALLOCATE(rho,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( needs%norm_drho ) THEN - deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) - CALL numpot_matrix(xcmat%op,xcpot(:,1,1),atom%basis,1,error) + deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) + CALL numpot_matrix(xcmat%op,xcpot(:,1,1),atom%basis,1) DEALLOCATE(drho,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( needs%tau ) THEN - deriv => xc_dset_get_derivative(deriv_set,"(tau)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) + deriv => xc_dset_get_derivative(deriv_set,"(tau)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) n1 = SIZE(xcmat%op,1) n2 = SIZE(xcmat%op,2) n3 = SIZE(xcmat%op,3) ALLOCATE(taumat(n1,n2,0:n3-1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) taumat = 0._dp xcpot(:,1,1) = 0.5_dp * xcpot(:,1,1) - CALL numpot_matrix(xcmat%op,xcpot(:,1,1),atom%basis,2,error) + CALL numpot_matrix(xcmat%op,xcpot(:,1,1),atom%basis,2) xcpot(:,1,1) = xcpot(:,1,1)/atom%basis%grid%rad2(:) - CALL numpot_matrix(taumat,xcpot(:,1,1),atom%basis,0,error) + CALL numpot_matrix(taumat,xcpot(:,1,1),atom%basis,0) DO l=0,3 xcmat%op(:,:,l) = xcmat%op(:,:,l) + REAL(l*(l+1),dp)*taumat(:,:,l) END DO DEALLOCATE(tau,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(taumat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF ! Release the xc structure used to store the xc derivatives - CALL xc_dset_release(deriv_set, error=error) - CALL xc_rho_set_release(rho_set,error=error) + CALL xc_dset_release(deriv_set) + CALL xc_rho_set_release(rho_set) END IF !xc_none @@ -371,19 +365,19 @@ SUBROUTINE calculate_atom_vxc_lda(xcmat,atom,xc_section,error) ! we don't have an xc_section, use a default setup nr = atom%basis%grid%nr ALLOCATE(rho(nr,1),exc(nr),vxc(nr),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) - CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) + CALL atom_density(rho(:,1),atom%orbitals%pmat,atom%basis,atom%state%maxl_occ,typ="RHO") IF ( nlcc ) THEN - CALL atom_core_density(rho(:,1),atom%potential%gth_pot,typ="RHO",rr=atom%basis%grid%rad,error=error) + CALL atom_core_density(rho(:,1),atom%potential%gth_pot,typ="RHO",rr=atom%basis%grid%rad) END IF - CALL lda_pade(rho(:,1),exc,vxc,error) + CALL lda_pade(rho(:,1),exc,vxc) atom%energy%exc = fourpi*integrate_grid(exc,atom%basis%grid) - CALL numpot_matrix(xcmat%op,vxc,atom%basis,0,error) + CALL numpot_matrix(xcmat%op,vxc,atom%basis,0) DEALLOCATE(rho,exc,vxc,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF @@ -397,13 +391,11 @@ END SUBROUTINE calculate_atom_vxc_lda !> \param xcmatb ... !> \param atom ... !> \param xc_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_atom_vxc_lsd(xcmata,xcmatb,atom,xc_section,error) + SUBROUTINE calculate_atom_vxc_lsd(xcmata,xcmatb,atom,xc_section) TYPE(opmat_type), POINTER :: xcmata, xcmatb TYPE(atom_type), INTENT(INOUT) :: atom TYPE(section_vals_type), POINTER :: xc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_atom_vxc_lsd', & routineP = moduleN//':'//routineN @@ -432,19 +424,19 @@ SUBROUTINE calculate_atom_vxc_lsd(xcmata,xcmatb,atom,xc_section,error) IF ( ASSOCIATED(xc_section) ) THEN NULLIFY(rho_set) - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",error=error) - CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun,error=error) + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") + CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun) IF(myfun == xc_none) THEN atom%energy%exc = 0._dp ELSE - CALL section_vals_val_get(xc_section,"DENSITY_CUTOFF",r_val=density_cut,error=error) - CALL section_vals_val_get(xc_section,"GRADIENT_CUTOFF",r_val=gradient_cut,error=error) - CALL section_vals_val_get(xc_section,"TAU_CUTOFF",r_val=tau_cut,error=error) + CALL section_vals_val_get(xc_section,"DENSITY_CUTOFF",r_val=density_cut) + CALL section_vals_val_get(xc_section,"GRADIENT_CUTOFF",r_val=gradient_cut) + CALL section_vals_val_get(xc_section,"TAU_CUTOFF",r_val=tau_cut) lsd = .TRUE. nspins = 2 - needs = xc_functionals_get_needs(xc_fun_section,lsd=lsd,add_basic_components=.FALSE.,error=error) + needs = xc_functionals_get_needs(xc_fun_section,lsd=lsd,add_basic_components=.FALSE.) ! Prepare the structures needed to calculate and store the xc derivatives @@ -457,118 +449,118 @@ SUBROUTINE calculate_atom_vxc_lsd(xcmata,xcmatb,atom,xc_section,error) ! create a place where to put the derivatives NULLIFY(deriv_set) - CALL xc_dset_create(deriv_set, local_bounds=bounds, error=error) + CALL xc_dset_create(deriv_set, local_bounds=bounds) ! create the place where to store the argument for the functionals CALL xc_rho_set_create(rho_set,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) ! allocate the required 3d arrays where to store rho and drho CALL xc_rho_set_atom_update(rho_set,needs,nspins,bounds) NULLIFY(rho,drho,tau) IF ( needs%rho_spin ) THEN ALLOCATE(rho(nr,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL atom_density(rho(:,1),atom%orbitals%pmata,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) - CALL atom_density(rho(:,2),atom%orbitals%pmatb,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL atom_density(rho(:,1),atom%orbitals%pmata,atom%basis,atom%state%maxl_occ,typ="RHO") + CALL atom_density(rho(:,2),atom%orbitals%pmatb,atom%basis,atom%state%maxl_occ,typ="RHO") END IF IF ( needs%norm_drho_spin ) THEN ALLOCATE(drho(nr,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) - CALL atom_density(drho(:,1),atom%orbitals%pmata,atom%basis,atom%state%maxl_occ,typ="DER",error=error) - CALL atom_density(drho(:,2),atom%orbitals%pmatb,atom%basis,atom%state%maxl_occ,typ="DER",error=error) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) + CALL atom_density(drho(:,1),atom%orbitals%pmata,atom%basis,atom%state%maxl_occ,typ="DER") + CALL atom_density(drho(:,2),atom%orbitals%pmatb,atom%basis,atom%state%maxl_occ,typ="DER") END IF IF ( needs%tau_spin ) THEN ALLOCATE(tau(nr,2),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) CALL atom_density(tau(:,1),atom%orbitals%pmata,atom%basis,atom%state%maxl_occ,& - typ="KIN",rr=atom%basis%grid%rad2,error=error) + typ="KIN",rr=atom%basis%grid%rad2) CALL atom_density(tau(:,2),atom%orbitals%pmatb,atom%basis,atom%state%maxl_occ,& - typ="KIN",rr=atom%basis%grid%rad2,error=error) + typ="KIN",rr=atom%basis%grid%rad2) END IF - CALL fill_rho_set(rho_set,nspins,needs,rho,drho,tau,nr,error=error) + CALL fill_rho_set(rho_set,nspins,needs,rho,drho,tau,nr) - CALL xc_dset_zero_all(deriv_set, error) + CALL xc_dset_zero_all(deriv_set) deriv_order = 1 CALL xc_functionals_eval(xc_fun_section,lsd=lsd,rho_set=rho_set,deriv_set=deriv_set,& - deriv_order=deriv_order,error=error) + deriv_order=deriv_order) ! Integration to get the matrix elements and energy - deriv => xc_dset_get_derivative(deriv_set,"",allocate_deriv=.FALSE., error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) + deriv => xc_dset_get_derivative(deriv_set,"",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) atom%energy%exc = fourpi*integrate_grid(xcpot(:,1,1),atom%basis%grid) IF ( needs%rho_spin ) THEN - deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) - CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,0,error) - deriv => xc_dset_get_derivative(deriv_set,"(rhob)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) - CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,0,error) + deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) + CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,0) + deriv => xc_dset_get_derivative(deriv_set,"(rhob)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) + CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,0) DEALLOCATE(rho,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( needs%norm_drho_spin ) THEN ! drhoa NULLIFY(deriv) - deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) - CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,1,error) + deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) + CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,1) ! drhob NULLIFY(deriv) - deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) - CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,1,error) + deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) + CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,1) ! Cross Terms NULLIFY(deriv) - deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",error=error) + deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)") IF(ASSOCIATED(deriv)) THEN - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) - CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,1,error) - CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,1,error) + CALL xc_derivative_get(deriv,deriv_data=xcpot) + CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,1) + CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,1) END IF DEALLOCATE(drho,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF ( needs%tau_spin ) THEN n1 = SIZE(xcmata%op,1) n2 = SIZE(xcmata%op,2) n3 = SIZE(xcmata%op,3) ALLOCATE(taumat(n1,n2,0:n3-1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) - deriv => xc_dset_get_derivative(deriv_set,"(tau_a)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) + deriv => xc_dset_get_derivative(deriv_set,"(tau_a)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) taumat = 0._dp xcpot(:,1,1) = 0.5_dp * xcpot(:,1,1) - CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,2,error) + CALL numpot_matrix(xcmata%op,xcpot(:,1,1),atom%basis,2) xcpot(:,1,1) = xcpot(:,1,1)/atom%basis%grid%rad2(:) - CALL numpot_matrix(taumat,xcpot(:,1,1),atom%basis,0,error) + CALL numpot_matrix(taumat,xcpot(:,1,1),atom%basis,0) DO l=0,3 xcmata%op(:,:,l) = xcmata%op(:,:,l) + REAL(l*(l+1),dp)*taumat(:,:,l) END DO - deriv => xc_dset_get_derivative(deriv_set,"(tau_b)",allocate_deriv=.FALSE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=xcpot,error=error) + deriv => xc_dset_get_derivative(deriv_set,"(tau_b)",allocate_deriv=.FALSE.) + CALL xc_derivative_get(deriv,deriv_data=xcpot) taumat = 0._dp xcpot(:,1,1) = 0.5_dp * xcpot(:,1,1) - CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,2,error) + CALL numpot_matrix(xcmatb%op,xcpot(:,1,1),atom%basis,2) xcpot(:,1,1) = xcpot(:,1,1)/atom%basis%grid%rad2(:) - CALL numpot_matrix(taumat,xcpot(:,1,1),atom%basis,0,error) + CALL numpot_matrix(taumat,xcpot(:,1,1),atom%basis,0) DO l=0,3 xcmatb%op(:,:,l) = xcmatb%op(:,:,l) + REAL(l*(l+1),dp)*taumat(:,:,l) END DO DEALLOCATE(tau,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DEALLOCATE(taumat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF ! Release the xc structure used to store the xc derivatives - CALL xc_dset_release(deriv_set, error=error) - CALL xc_rho_set_release(rho_set,error=error) + CALL xc_dset_release(deriv_set) + CALL xc_rho_set_release(rho_set) END IF !xc_none @@ -577,18 +569,18 @@ SUBROUTINE calculate_atom_vxc_lsd(xcmata,xcmatb,atom,xc_section,error) ! we don't have an xc_section, use a default setup nr = atom%basis%grid%nr ALLOCATE(rho(nr,2),exc(nr),vxca(nr),vxcb(nr),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) - CALL atom_density(rho(:,1),atom%orbitals%pmata,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) - CALL atom_density(rho(:,2),atom%orbitals%pmatb,atom%basis,atom%state%maxl_occ,typ="RHO",error=error) - CALL lsd_pade(rho(:,1),rho(:,2),exc,vxca,vxcb,error) + CALL atom_density(rho(:,1),atom%orbitals%pmata,atom%basis,atom%state%maxl_occ,typ="RHO") + CALL atom_density(rho(:,2),atom%orbitals%pmatb,atom%basis,atom%state%maxl_occ,typ="RHO") + CALL lsd_pade(rho(:,1),rho(:,2),exc,vxca,vxcb) atom%energy%exc = fourpi*integrate_grid(exc,atom%basis%grid) - CALL numpot_matrix(xcmata%op,vxca,atom%basis,0,error) - CALL numpot_matrix(xcmatb%op,vxcb,atom%basis,0,error) + CALL numpot_matrix(xcmata%op,vxca,atom%basis,0) + CALL numpot_matrix(xcmatb%op,vxcb,atom%basis,0) DEALLOCATE(rho,exc,vxca,vxcb,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF @@ -605,16 +597,14 @@ END SUBROUTINE calculate_atom_vxc_lsd !> \param drho ... !> \param tau ... !> \param na ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE fill_rho_set(rho_set,nspins,needs,rho,drho,tau,na,error) + SUBROUTINE fill_rho_set(rho_set,nspins,needs,rho,drho,tau,na) TYPE(xc_rho_set_type), POINTER :: rho_set INTEGER, INTENT(IN) :: nspins TYPE(xc_rho_cflags_type), INTENT(in) :: needs REAL(dp), DIMENSION(:, :), POINTER :: rho, drho, tau INTEGER, INTENT(IN) :: na - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fill_rho_set', & routineP = moduleN//':'//routineN @@ -627,13 +617,13 @@ SUBROUTINE fill_rho_set(rho_set,nspins,needs,rho,drho,tau,na,error) SELECT CASE(nspins) CASE(1) - CPPrecondition(.NOT.needs%rho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%norm_drho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%rho_spin_1_3,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%tau_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drho,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.needs%rho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%norm_drho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%rho_spin_1_3,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%tau_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drho,cp_failure_level,routineP,failure) ! Give rho to 1/3 IF (needs%rho_1_3) THEN DO ia = 1,na @@ -659,9 +649,9 @@ SUBROUTINE fill_rho_set(rho_set,nspins,needs,rho,drho,tau,na,error) rho_set%has%norm_drho=.TRUE. END IF CASE(2) - CPPrecondition(.NOT.needs%drho,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.needs%drho,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,failure) ! Give the total density IF (needs%rho) THEN DO ia = 1,na @@ -725,7 +715,7 @@ SUBROUTINE fill_rho_set(rho_set,nspins,needs,rho,drho,tau,na,error) END IF END IF IF (needs%tau_spin) THEN - CPPrecondition(nspins==2,cp_failure_level,routineP,error,failure) + CPPrecondition(nspins==2,cp_failure_level,routineP,failure) DO ia = 1,na rho_set%tau_a(ia,1,1) = tau(ia,1) rho_set%tau_b(ia,1,1) = tau(ia,2) @@ -742,12 +732,10 @@ END SUBROUTINE fill_rho_set !> \param rho ... !> \param exc ... !> \param vxc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE lda_pade(rho,exc,vxc,error) + SUBROUTINE lda_pade(rho,exc,vxc) REAL(dp), DIMENSION(:) :: rho, exc, vxc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lda_pade', & routineP = moduleN//':'//routineN @@ -795,12 +783,10 @@ END SUBROUTINE lda_pade !> \param exc ... !> \param vxca ... !> \param vxcb ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE lsd_pade ( rhoa, rhob, exc, vxca, vxcb, error ) + SUBROUTINE lsd_pade ( rhoa, rhob, exc, vxca, vxcb) REAL(dp), DIMENSION(:) :: rhoa, rhob, exc, vxca, vxcb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lsd_pade', & routineP = moduleN//':'//routineN diff --git a/src/atomic_charges.F b/src/atomic_charges.F index 2d8d92601c..916478360b 100644 --- a/src/atomic_charges.F +++ b/src/atomic_charges.F @@ -39,14 +39,13 @@ MODULE atomic_charges !> \param electronic_charges (natom,nspin), the number of electrons of (so positive) per spin !> if (nspin==1) it is the sum of alpha and beta electrons !> \param atomic_charges truely the atomic charge (taking Z into account, atoms negative, no spin) -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] !> \note !> charges are computed per spin in the LSD case ! ***************************************************************************** SUBROUTINE print_atomic_charges(particle_set, qs_kind_set, scr, title, electronic_charges,& - atomic_charges, error) + atomic_charges) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -56,7 +55,6 @@ SUBROUTINE print_atomic_charges(particle_set, qs_kind_set, scr, title, electroni CHARACTER(LEN=*) :: title REAL(KIND=dp), DIMENSION(:, :), OPTIONAL :: electronic_charges REAL(KIND=dp), DIMENSION(:), OPTIONAL :: atomic_charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_atomic_charges', & routineP = moduleN//':'//routineN @@ -97,7 +95,7 @@ SUBROUTINE print_atomic_charges(particle_set, qs_kind_set, scr, title, electroni DO iatom=1,natom CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind,& element_symbol=element_symbol, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff) SELECT CASE (nspin) CASE(0) @@ -138,9 +136,8 @@ END SUBROUTINE print_atomic_charges !> \param charge ... !> \param dipole ... !> \param quadrupole ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE print_multipoles(particle_set, qs_kind_set, scr, charge, dipole, quadrupole, error) + SUBROUTINE print_multipoles(particle_set, qs_kind_set, scr, charge, dipole, quadrupole) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -151,7 +148,6 @@ SUBROUTINE print_multipoles(particle_set, qs_kind_set, scr, charge, dipole, quad REAL(KIND=dp), DIMENSION(:, :), OPTIONAL :: dipole REAL(KIND=dp), DIMENSION(:, :, :), & OPTIONAL :: quadrupole - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_multipoles', & routineP = moduleN//':'//routineN @@ -174,7 +170,7 @@ SUBROUTINE print_multipoles(particle_set, qs_kind_set, scr, charge, dipole, quad DO iatom=1,natom CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind,& element_symbol=element_symbol, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff) WRITE(scr,'(a,i5)') ' iatom= ',iatom WRITE(scr,'(a,a2)') ' element_symbol= ',element_symbol diff --git a/src/atoms_input.F b/src/atoms_input.F index 3f5fd821d9..7ca870fa83 100644 --- a/src/atoms_input.F +++ b/src/atoms_input.F @@ -62,16 +62,14 @@ MODULE atoms_input !> \param overwrite ... !> \param subsys_section ... !> \param save_mem ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, error ) + SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem) TYPE(topology_parameters_type) :: topology LOGICAL, INTENT(IN), OPTIONAL :: overwrite TYPE(section_vals_type), POINTER :: subsys_section LOGICAL, INTENT(IN), OPTIONAL :: save_mem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_atoms_input', & routineP = moduleN//':'//routineN @@ -99,13 +97,13 @@ SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, err my_save_mem = .FALSE. error_message = "" NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) IF (PRESENT(overwrite)) my_overwrite=overwrite IF (PRESENT(save_mem)) my_save_mem=save_mem NULLIFY(coord_section) - coord_section => section_vals_get_subs_vals(subsys_section,"COORD",error=error) - CALL section_vals_get(coord_section, explicit=explicit, error=error) + coord_section => section_vals_get_subs_vals(subsys_section,"COORD") + CALL section_vals_get(coord_section, explicit=explicit) IF (.NOT.explicit) RETURN CALL timeset(routineN,handle) @@ -115,28 +113,28 @@ SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, err !----------------------------------------------------------------------------- atom_info => topology%atom_info cell => topology%cell_muc - CALL section_vals_val_get(coord_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(coord_section,"SCALED",l_val=scaled_coordinates,error=error) - unit_conv = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(coord_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(coord_section,"SCALED",l_val=scaled_coordinates) + unit_conv = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str)) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 2. Read in the coordinates from &COORD section in the input file !----------------------------------------------------------------------------- CALL section_vals_val_get(coord_section,"_DEFAULT_KEYWORD_",& - n_rep_val=natom,error=error) + n_rep_val=natom) topology%natoms = natom IF (my_overwrite) THEN - CPPostcondition(SIZE(atom_info%r,2)==natom, cp_failure_level, routineP, error, failure) + CPPostcondition(SIZE(atom_info%r,2)==natom, cp_failure_level, routineP,failure) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "Overwriting coordinates. Active coordinates read from &COORD section."//& " Active coordinates READ from &COORD section "//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL section_vals_list_get(coord_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(coord_section,"_DEFAULT_KEYWORD_",list=list) DO iatom=1,natom - is_ok=cp_sll_val_next(list,val,error=error) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CALL val_get(val,c_val=line_att) ! Read name and atomic coordinates start_c=1 DO wrd=1,4 @@ -156,7 +154,7 @@ SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, err CALL cp_assert(LEN_TRIM(line_att(start_c:end_c-1))/=0,cp_failure_level,& cp_assertion_failed,routineP,& "incorrectly formatted line in coord section'"//line_att//"'",& - error,failure) + failure) IF (wrd==1) THEN atom_info%id_atmname(iatom)=str2id(s2s(line_att(start_c:end_c-1))) ELSE @@ -178,11 +176,11 @@ SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, err CALL reallocate(atom_info%atm_mass,1,natom) CALL reallocate(atom_info%atm_charge,1,natom) - CALL section_vals_list_get(coord_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(coord_section,"_DEFAULT_KEYWORD_",list=list) DO iatom=1,natom ! we use only the first default_string_length characters of each line - is_ok=cp_sll_val_next(list,val,error=error) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CALL val_get(val,c_val=line_att) default_id = str2id(s2s("")) atom_info%id_molname(iatom) = default_id atom_info%id_resname(iatom) = default_id @@ -211,7 +209,7 @@ SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, err "Incorrectly formatted input line for atom "//& TRIM(ADJUSTL(cp_to_string(iatom)))//& " found in COORD section. Input line: <"//& - TRIM(line_att)//"> ",error,failure) + TRIM(line_att)//"> ",failure) SELECT CASE (wrd) CASE (1) atom_info%id_atmname(iatom) = str2id(s2s(line_att(start_c:end_c-1))) @@ -223,7 +221,7 @@ SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, err "Incorrectly formatted input line for atom "//& TRIM(ADJUSTL(cp_to_string(iatom)))//& " found in COORD section. "//TRIM(error_message)//& - " Input line: <"//TRIM(line_att)//"> ",error,failure) + " Input line: <"//TRIM(line_att)//"> ",failure) CASE (5) READ (line_att(start_c:end_c-1),*) strtmp atom_info%id_molname(iatom) = str2id(strtmp) @@ -259,7 +257,7 @@ SUBROUTINE read_atoms_input ( topology, overwrite, subsys_section, save_mem, err atom_info%r(:,iatom) = atom_info%r(:,iatom)*unit_conv END IF END DO - IF(my_save_mem) CALL section_vals_remove_values(coord_section, error) + IF(my_save_mem) CALL section_vals_remove_values(coord_section) CALL timestop(handle) END SUBROUTINE read_atoms_input @@ -272,11 +270,10 @@ END SUBROUTINE read_atoms_input !> \param subsys_section ... !> \param core_particle_set ... !> \param save_mem ... -!> \param error ... !> \author MI ! ***************************************************************************** SUBROUTINE read_shell_coord_input ( particle_set, shell_particle_set, cell,& - subsys_section, core_particle_set, save_mem, error ) + subsys_section, core_particle_set, save_mem) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set, & @@ -286,7 +283,6 @@ SUBROUTINE read_shell_coord_input ( particle_set, shell_particle_set, cell,& TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: core_particle_set LOGICAL, INTENT(IN), OPTIONAL :: save_mem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_shell_coord_input', & routineP = moduleN//':'//routineN @@ -317,41 +313,41 @@ SUBROUTINE read_shell_coord_input ( particle_set, shell_particle_set, cell,& failure=.FALSE. my_save_mem = .FALSE. NULLIFY(logger, atomic_kind, list, shell_coord_section, shell, val) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) IF(PRESENT(save_mem)) my_save_mem=save_mem NULLIFY(shell_coord_section, core_coord_section) - shell_coord_section => section_vals_get_subs_vals(subsys_section,"SHELL_COORD",error=error) - CALL section_vals_get(shell_coord_section, explicit=explicit, error=error) + shell_coord_section => section_vals_get_subs_vals(subsys_section,"SHELL_COORD") + CALL section_vals_get(shell_coord_section, explicit=explicit) IF (.NOT.explicit) RETURN CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 2. Read in the coordinates from &SHELL_COORD section in the input file !----------------------------------------------------------------------------- - CALL section_vals_val_get(shell_coord_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(shell_coord_section,"SCALED",l_val=shell_scaled_coordinates,error=error) - unit_conv_shell = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(shell_coord_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(shell_coord_section,"SCALED",l_val=shell_scaled_coordinates) + unit_conv_shell = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str)) CALL section_vals_val_get(shell_coord_section,"_DEFAULT_KEYWORD_",& - n_rep_val=nshell,error=error) + n_rep_val=nshell) IF (ASSOCIATED(shell_particle_set)) THEN - CPPrecondition((SIZE(shell_particle_set,1) == nshell),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(shell_particle_set,1) == nshell),cp_failure_level,routineP,failure) ALLOCATE (r(3,nshell),at_name(nshell),at_index(nshell), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "Overwriting shell coordinates. "//& "Active coordinates READ from &SHELL_COORD section. "//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL section_vals_list_get(shell_coord_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(shell_coord_section,"_DEFAULT_KEYWORD_",list=list) DO ishell=1,nshell ! we use only the first default_string_length characters of each line - is_ok=cp_sll_val_next(list,val,error=error) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CALL val_get(val,c_val=line_att) start_c=1 DO wrd=1,5 DO j=start_c,LEN(line_att) @@ -370,7 +366,7 @@ SUBROUTINE read_shell_coord_input ( particle_set, shell_particle_set, cell,& CALL cp_assert(wrd==5.OR.end_c section_vals_get_subs_vals(subsys_section,"CORE_COORD",error=error) - CALL section_vals_get(core_coord_section, explicit=explicit, error=error) + CPPrecondition(ASSOCIATED(core_particle_set),cp_failure_level,routineP,failure) + core_coord_section => section_vals_get_subs_vals(subsys_section,"CORE_COORD") + CALL section_vals_get(core_coord_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(core_coord_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(core_coord_section,"SCALED",l_val=core_scaled_coordinates,error=error) - unit_conv_core = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(core_coord_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(core_coord_section,"SCALED",l_val=core_scaled_coordinates) + unit_conv_core = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str)) CALL section_vals_val_get(core_coord_section,"_DEFAULT_KEYWORD_",& - n_rep_val=nshell,error=error) + n_rep_val=nshell) - CPPostcondition((SIZE(core_particle_set,1) == nshell),cp_failure_level,routineP,error,failure) + CPPostcondition((SIZE(core_particle_set,1) == nshell),cp_failure_level,routineP,failure) ALLOCATE (rc(3,nshell),at_name_c(nshell),at_index_c(nshell), STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "Overwriting cores coordinates. "//& " Active coordinates READ from &CORE_COORD section. "//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL section_vals_list_get(core_coord_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(core_coord_section,"_DEFAULT_KEYWORD_",list=list) DO ishell=1,nshell ! we use only the first default_string_length characters of each line - is_ok=cp_sll_val_next(list,val,error=error) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CALL val_get(val,c_val=line_att) start_c=1 DO wrd=1,5 DO j=start_c,LEN(line_att) @@ -425,7 +421,7 @@ SUBROUTINE read_shell_coord_input ( particle_set, shell_particle_set, cell,& CALL cp_assert(wrd==5.OR.end_c [CP-corrected total energy of AB] !> \param force_env ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE do_bsse_calculation(force_env, globenv, error) + SUBROUTINE do_bsse_calculation(force_env, globenv) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_bsse_calculation', & routineP = moduleN//':'//routineN @@ -94,11 +91,11 @@ SUBROUTINE do_bsse_calculation(force_env, globenv, error) failure = .FALSE. NULLIFY(bsse_section, n_frags, Em, conf) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() root_section => force_env%root_section - bsse_section => section_vals_get_subs_vals(force_env%force_env_section,"BSSE",error=error) - n_frags => section_vals_get_subs_vals(bsse_section,"FRAGMENT",error=error) - CALL section_vals_get(n_frags,n_repetition=Num_of_Frag,error=error) + bsse_section => section_vals_get_subs_vals(force_env%force_env_section,"BSSE") + n_frags => section_vals_get_subs_vals(bsse_section,"FRAGMENT") + CALL section_vals_get(n_frags,n_repetition=Num_of_Frag) ! Number of configurations num_of_conf = 0 @@ -106,49 +103,49 @@ SUBROUTINE do_bsse_calculation(force_env, globenv, error) num_of_conf = num_of_conf + FACT(Num_of_frag) / (FACT(k)*FACT(Num_of_frag-k)) END DO ALLOCATE(conf(num_of_conf,Num_of_frag),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Em(num_of_conf), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL gen_Nbody_conf(Num_of_frag, conf) should_stop = .FALSE. istart = 0 - fragment_energies_section => section_vals_get_subs_vals(bsse_section,"FRAGMENT_ENERGIES",error=error) - CALL section_vals_get(fragment_energies_section, explicit=explicit, error=error) + fragment_energies_section => section_vals_get_subs_vals(bsse_section,"FRAGMENT_ENERGIES") + CALL section_vals_get(fragment_energies_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(fragment_energies_section,"_DEFAULT_KEYWORD_",n_rep_val=istart,error=error) + CALL section_vals_val_get(fragment_energies_section,"_DEFAULT_KEYWORD_",n_rep_val=istart) DO i = 1, istart CALL section_vals_val_get(fragment_energies_section,"_DEFAULT_KEYWORD_",r_val=Em(i),& - i_rep_val=i, error=error) + i_rep_val=i) END DO END IF ! Setup the iteration level for BSSE - CALL cp_add_iter_level(logger%iter_info,"BSSE",error=error) - CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=istart,error=error) + CALL cp_add_iter_level(logger%iter_info,"BSSE") + CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=istart) ! Evaluating the energy of the N-body cluster terms DO i = istart+1, num_of_conf - CALL cp_iterate(logger%iter_info,last=(i==num_of_conf),iter_nr=i,error=error) + CALL cp_iterate(logger%iter_info,last=(i==num_of_conf),iter_nr=i) CALL eval_bsse_energy(conf(i,:),Em(i),force_env, n_frags, & - root_section,globenv, should_stop, error=error) + root_section,globenv, should_stop) IF (should_stop) EXIT ! If no signal was received in the inner loop let's check also at this stage - CALL external_control(should_stop,"BSSE",globenv=globenv,error=error) + CALL external_control(should_stop,"BSSE",globenv=globenv) IF (should_stop) EXIT ! Dump Restart info only if the calculation of the energy of a configuration ! ended nicely.. CALL section_vals_val_set(fragment_energies_section,"_DEFAULT_KEYWORD_",r_val=Em(i),& - i_rep_val=i,error=error) - CALL write_bsse_restart(bsse_section, root_section, error=error) + i_rep_val=i) + CALL write_bsse_restart(bsse_section, root_section) END DO - IF (.NOT.should_stop) CALL dump_bsse_results(conf, Em, num_of_frag, bsse_section, error) - CALL cp_rm_iter_level(logger%iter_info,"BSSE",error=error) + IF (.NOT.should_stop) CALL dump_bsse_results(conf, Em, num_of_frag, bsse_section) + CALL cp_rm_iter_level(logger%iter_info,"BSSE") DEALLOCATE(Em, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(conf, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE do_bsse_calculation @@ -161,21 +158,18 @@ END SUBROUTINE do_bsse_calculation !> \param root_section ... !> \param globenv ... !> \param should_stop ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE eval_bsse_energy(conf, Em, force_env, n_frags, root_section,& - globenv, should_stop, error) + globenv, should_stop) INTEGER, DIMENSION(:), INTENT(IN) :: conf REAL(KIND=dp), INTENT(OUT) :: Em TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: n_frags, root_section TYPE(global_environment_type), POINTER :: globenv LOGICAL, INTENT(OUT) :: should_stop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eval_bsse_energy', & routineP = moduleN//':'//routineN @@ -194,7 +188,7 @@ SUBROUTINE eval_bsse_energy(conf, Em, force_env, n_frags, root_section,& Num_of_sub_frag = COUNT(conf == 1) Num_of_sub_conf = 0 IF (Num_of_sub_frag == 1) THEN - CALL eval_bsse_energy_low(force_env, conf, conf, n_frags, root_section, globenv, Em, error) + CALL eval_bsse_energy_low(force_env, conf, conf, n_frags, root_section, globenv, Em) ELSE my_energy = 0.0_dp DO k = 1, Num_of_sub_frag @@ -202,16 +196,16 @@ SUBROUTINE eval_bsse_energy(conf, Em, force_env, n_frags, root_section,& FACT(Num_of_sub_frag) / (FACT(k)*FACT(Num_of_sub_frag-k)) END DO ALLOCATE(conf_loc(Num_of_sub_conf,Num_of_sub_frag), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Em_loc(Num_of_sub_conf), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Em_loc = 0.0_dp CALL gen_Nbody_conf(Num_of_sub_frag, conf_loc) CALL make_plan_conf(conf, conf_loc) DO i = 1, Num_of_sub_conf CALL eval_bsse_energy_low(force_env, conf, conf_loc(i,:), n_frags,& - root_section,globenv, Em_loc(i), error) - CALL external_control(should_stop,"BSSE",globenv=globenv,error=error) + root_section,globenv, Em_loc(i)) + CALL external_control(should_stop,"BSSE",globenv=globenv) IF (should_stop) EXIT END DO ! Energy @@ -222,9 +216,9 @@ SUBROUTINE eval_bsse_energy(conf, Em, force_env, n_frags, root_section,& END DO Em = my_energy DEALLOCATE(Em_loc, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(conf_loc, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE eval_bsse_energy @@ -238,21 +232,18 @@ END SUBROUTINE eval_bsse_energy !> \param root_section ... !> \param globenv ... !> \param energy ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2005 created [tlaino] !> 2014/09/17 made atom list to be read from repeated occurance of LIST [LTong] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE eval_bsse_energy_low(force_env, conf, conf_loc, n_frags, & - root_section, globenv, energy, error) + root_section, globenv, energy) TYPE(force_env_type), POINTER :: force_env INTEGER, DIMENSION(:), INTENT(IN) :: conf, conf_loc TYPE(section_vals_type), POINTER :: n_frags, root_section TYPE(global_environment_type), POINTER :: globenv REAL(KIND=dp), INTENT(OUT) :: energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eval_bsse_energy_low', & routineP = moduleN//':'//routineN @@ -276,51 +267,51 @@ SUBROUTINE eval_bsse_energy_low(force_env, conf, conf_loc, n_frags, & subsys_section failure = .FALSE. - CALL section_vals_get(n_frags,n_repetition=num_of_frag,error=error) - CPPostcondition(SIZE(conf)==num_of_frag,cp_failure_level,routineP,error,failure) + CALL section_vals_get(n_frags,n_repetition=num_of_frag) + CPPostcondition(SIZE(conf)==num_of_frag,cp_failure_level,routineP,failure) NULLIFY(subsys_loc, subsys, particles, para_env, cell, atom_index, atom_type, tmplist,& force_env_section ) - CALL force_env_get(force_env, force_env_section=force_env_section, error=error) - CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id,error=error) - bsse_section => section_vals_get_subs_vals(force_env_section,"BSSE",error=error) - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) - dft_section => section_vals_get_subs_vals(force_env_section,"DFT",error=error) + CALL force_env_get(force_env, force_env_section=force_env_section) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id) + bsse_section => section_vals_get_subs_vals(force_env_section,"BSSE") + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") + dft_section => section_vals_get_subs_vals(force_env_section,"DFT") ALLOCATE(my_conf(SIZE(conf)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_conf = conf CALL force_env_get(force_env=force_env, subsys=subsys, para_env=para_env,& - cell=cell, error=error) - CALL cp_subsys_get(subsys, particles=particles, error=error) + cell=cell) + CALL cp_subsys_get(subsys, particles=particles) isize = 0 ALLOCATE(atom_index(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, num_of_frag IF (conf(i) == 1) THEN ! ! Get the list of atoms creating the present fragment ! old_size=isize - CALL section_vals_val_get(n_frags, "LIST", i_rep_section=i, n_rep_val=n_rep, error=error) + CALL section_vals_val_get(n_frags, "LIST", i_rep_section=i, n_rep_val=n_rep) IF (n_rep /= 0) THEN DO ir = 1, n_rep - CALL section_vals_val_get(n_frags, "LIST", i_rep_section=i, i_rep_val=ir, i_vals=tmplist, error=error) + CALL section_vals_val_get(n_frags, "LIST", i_rep_section=i, i_rep_val=ir, i_vals=tmplist) CALL reallocate(atom_index,1,isize+SIZE(tmplist)) atom_index(isize+1:isize+SIZE(tmplist)) = tmplist isize = SIZE(atom_index) END DO END IF my_conf(i) = isize - old_size - CPPostcondition(conf(i)/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(conf(i)/=0,cp_failure_level,routineP,failure) END IF END DO CALL conf_info_setup(present_charge, present_multpl, conf, conf_loc, bsse_section,& - dft_section, error) + dft_section) ! ! Get names and modify the ghost ones ! ALLOCATE(atom_type(isize), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, isize my_targ = atom_index(j) DO k = 1, SIZE(particles%els) @@ -337,7 +328,7 @@ SUBROUTINE eval_bsse_energy_low(force_env, conf, conf_loc, n_frags, & END IF END DO CALL dump_bsse_info(atom_index, atom_type, conf, conf_loc, bsse_section,& - present_charge, present_multpl, error) + present_charge, present_multpl) ! ! Let's start setting up environments and calculations ! @@ -346,30 +337,30 @@ SUBROUTINE eval_bsse_energy_low(force_env, conf, conf_loc, n_frags, & CALL create_small_subsys(subsys_loc, big_subsys=subsys,& small_para_env=para_env, small_cell=cell,sub_atom_index=atom_index,& sub_atom_kind_name=atom_type,para_env=para_env,& - force_env_section=force_env_section,subsys_section=subsys_section,error=error) + force_env_section=force_env_section,subsys_section=subsys_section) - CALL qs_env_create(qs_env, globenv,error=error) + CALL qs_env_create(qs_env, globenv) CALL qs_init(qs_env, para_env, globenv, root_section, cp_subsys=subsys_loc,& force_env_section=force_env_section, subsys_section=subsys_section,& - use_motion_section=.FALSE., error=error) - CALL cp_subsys_release(subsys_loc,error=error) + use_motion_section=.FALSE.) + CALL cp_subsys_release(subsys_loc) ! ! Evaluate Energy ! - CALL qs_energies(qs_env, error=error) - CALL get_qs_env(qs_env, energy=qs_energy, error=error) + CALL qs_energies(qs_env) + CALL get_qs_env(qs_env, energy=qs_energy) energy = qs_energy%total - CALL qs_env_release(qs_env,error=error) + CALL qs_env_release(qs_env) ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF DEALLOCATE(atom_index, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(atom_type, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_conf, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE eval_bsse_energy_low @@ -382,21 +373,18 @@ END SUBROUTINE eval_bsse_energy_low !> \param bsse_section ... !> \param present_charge ... !> \param present_multpl ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE dump_bsse_info(atom_index, atom_type, conf, conf_loc, bsse_section, & - present_charge, present_multpl, error) + present_charge, present_multpl) INTEGER, DIMENSION(:), POINTER :: atom_index CHARACTER(len=default_string_length), & DIMENSION(:), POINTER :: atom_type INTEGER, DIMENSION(:), INTENT(IN) :: conf, conf_loc TYPE(section_vals_type), POINTER :: bsse_section INTEGER, INTENT(IN) :: present_charge, present_multpl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_bsse_info', & routineP = moduleN//':'//routineN @@ -408,9 +396,9 @@ SUBROUTINE dump_bsse_info(atom_index, atom_type, conf, conf_loc, bsse_section, failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw=cp_print_key_unit_nr(logger,bsse_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") IF (iw>0) THEN WRITE (conf_s,fmt="(1000I0)",iostat=istat)conf ; IF(istat.NE.0) conf_s="exceeded" @@ -434,7 +422,7 @@ SUBROUTINE dump_bsse_info(atom_index, atom_type, conf, conf_loc, bsse_section, WRITE (UNIT=iw,FMT="(T2,A)") REPEAT("-",79) CALL cp_print_key_finished_output(iw,logger,bsse_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END IF END SUBROUTINE dump_bsse_info @@ -447,18 +435,15 @@ END SUBROUTINE dump_bsse_info !> \param conf_loc ... !> \param bsse_section ... !> \param dft_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE conf_info_setup(present_charge, present_multpl, conf, conf_loc,& - bsse_section, dft_section, error) + bsse_section, dft_section) INTEGER, INTENT(OUT) :: present_charge, present_multpl INTEGER, DIMENSION(:), INTENT(IN) :: conf, conf_loc TYPE(section_vals_type), POINTER :: bsse_section, dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'conf_info_setup', & routineP = moduleN//':'//routineN @@ -473,17 +458,17 @@ SUBROUTINE conf_info_setup(present_charge, present_multpl, conf, conf_loc,& failure = .FALSE. NULLIFY(configurations, glb_conf, sub_conf) ! Loop over all configurations to pick up the right one - configurations => section_vals_get_subs_vals(bsse_section,"CONFIGURATION",error=error) - CALL section_vals_get(configurations,explicit=explicit,n_repetition=nconf,error=error) + configurations => section_vals_get_subs_vals(bsse_section,"CONFIGURATION") + CALL section_vals_get(configurations,explicit=explicit,n_repetition=nconf) IF (explicit) THEN DO i=1, nconf - CALL section_vals_val_get(configurations,"GLB_CONF", i_rep_section=i, i_vals=glb_conf, error=error) + CALL section_vals_val_get(configurations,"GLB_CONF", i_rep_section=i, i_vals=glb_conf) CALL cp_assert(SIZE(glb_conf)==SIZE(conf),cp_fatal_level,cp_assertion_failed,routineP,& "GLB_CONF requires a binary description of the configuration. Number of integer "//& "different from the number of fragments defined!"//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL section_vals_val_get(configurations,"SUB_CONF", i_rep_section=i, i_vals=sub_conf, error=error) + CALL section_vals_val_get(configurations,"SUB_CONF", i_rep_section=i, i_vals=sub_conf) CALL cp_assert(SIZE(sub_conf)==SIZE(conf),cp_fatal_level,cp_assertion_failed,routineP,& "SUB_CONF requires a binary description of the configuration. Number of integer "//& "different from the number of fragments defined!"//& @@ -491,15 +476,15 @@ SUBROUTINE conf_info_setup(present_charge, present_multpl, conf, conf_loc,& only_ionode=.TRUE.) IF (ALL(conf==glb_conf).AND.ALL(conf_loc==sub_conf)) THEN CALL section_vals_val_get(configurations,"CHARGE", i_rep_section=i,& - i_val=present_charge, error=error) + i_val=present_charge) CALL section_vals_val_get(configurations,"MULTIPLICITY", i_rep_section=i,& - i_val=present_multpl, error=error) + i_val=present_multpl) END IF END DO END IF ! Setup parameter for this configuration - CALL section_vals_val_set(dft_section,"CHARGE",i_val=present_charge, error=error) - CALL section_vals_val_set(dft_section,"MULTIPLICITY",i_val=present_multpl, error=error) + CALL section_vals_val_set(dft_section,"CHARGE",i_val=present_charge) + CALL section_vals_val_set(dft_section,"MULTIPLICITY",i_val=present_multpl) END SUBROUTINE conf_info_setup ! ***************************************************************************** @@ -508,18 +493,15 @@ END SUBROUTINE conf_info_setup !> \param Em ... !> \param num_of_frag ... !> \param bsse_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE dump_bsse_results(conf, Em, num_of_frag, bsse_section, error) + SUBROUTINE dump_bsse_results(conf, Em, num_of_frag, bsse_section) INTEGER, DIMENSION(:, :), INTENT(IN) :: conf REAL(KIND=dp), DIMENSION(:), POINTER :: Em INTEGER, INTENT(IN) :: num_of_frag TYPE(section_vals_type), POINTER :: bsse_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_bsse_results', & routineP = moduleN//':'//routineN @@ -530,9 +512,9 @@ SUBROUTINE dump_bsse_results(conf, Em, num_of_frag, bsse_section, error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw=cp_print_key_unit_nr(logger,bsse_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") IF (iw>0) THEN WRITE (UNIT=iw,FMT="(/,T2,A)") REPEAT("-",79) @@ -555,7 +537,7 @@ SUBROUTINE dump_bsse_results(conf, Em, num_of_frag, bsse_section, error) END IF CALL cp_print_key_finished_output(iw,logger,bsse_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE dump_bsse_results @@ -663,16 +645,13 @@ END SUBROUTINE make_plan_conf !> \brief Writes restart for BSSE calculations !> \param bsse_section ... !> \param root_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE write_bsse_restart(bsse_section, root_section, error) + SUBROUTINE write_bsse_restart(bsse_section, root_section) TYPE(section_vals_type), POINTER :: bsse_section, root_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_bsse_restart', & routineP = moduleN//':'//routineN @@ -682,17 +661,17 @@ SUBROUTINE write_bsse_restart(bsse_section, root_section, error) TYPE(cp_logger_type), POINTER :: logger failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ires = cp_print_key_unit_nr(logger,bsse_section,"PRINT%RESTART",& - extension=".restart", do_backup=.FALSE., file_position="REWIND",error=error) + extension=".restart", do_backup=.FALSE., file_position="REWIND") IF (ires>0) THEN CALL write_restart_header(ires) - CALL section_vals_write(root_section, unit_nr=ires, hide_root=.TRUE., error=error) + CALL section_vals_write(root_section, unit_nr=ires, hide_root=.TRUE.) ENDIF CALL cp_print_key_finished_output(ires,logger,bsse_section,& - "PRINT%RESTART", error=error) + "PRINT%RESTART") END SUBROUTINE write_bsse_restart diff --git a/src/cell_methods.F b/src/cell_methods.F index b33d785f0a..89b1e2fa94 100644 --- a/src/cell_methods.F +++ b/src/cell_methods.F @@ -62,21 +62,18 @@ MODULE cell_methods !> \param cell_section ... !> \param check_for_ref ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2005 created [teo] !> \author Teodoro Laino ! ***************************************************************************** RECURSIVE SUBROUTINE read_cell( cell, cell_ref, use_ref_cell, cell_section,& - check_for_ref, para_env, error) + check_for_ref, para_env) TYPE(cell_type), POINTER :: cell, cell_ref LOGICAL, INTENT(OUT), OPTIONAL :: use_ref_cell TYPE(section_vals_type), OPTIONAL, & POINTER :: cell_section LOGICAL, INTENT(IN), OPTIONAL :: check_for_ref TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_cell', & routineP = moduleN//':'//routineN @@ -91,8 +88,8 @@ RECURSIVE SUBROUTINE read_cell( cell, cell_ref, use_ref_cell, cell_section,& failure = .FALSE. my_check = .TRUE. NULLIFY(cell_ref_section, cell_par, multiple_unit_cell) - IF (.NOT.ASSOCIATED(cell)) CALL cell_create(cell,error=error) - IF (.NOT.ASSOCIATED(cell_ref)) CALL cell_create(cell_ref,error=error) + IF (.NOT.ASSOCIATED(cell)) CALL cell_create(cell) + IF (.NOT.ASSOCIATED(cell_ref)) CALL cell_create(cell_ref) IF (PRESENT(check_for_ref)) my_check = check_for_ref cell%deth = 0.0_dp @@ -106,25 +103,25 @@ RECURSIVE SUBROUTINE read_cell( cell, cell_ref, use_ref_cell, cell_section,& cell_read_b = .FALSE. cell_read_c = .FALSE. ! Trying to read cell info from file - CALL section_vals_val_get(cell_section,"CELL_FILE_NAME",explicit=cell_read_file,error=error) - IF (cell_read_file) CALL read_cell_from_external_file(cell_section, para_env, error) + CALL section_vals_val_get(cell_section,"CELL_FILE_NAME",explicit=cell_read_file) + IF (cell_read_file) CALL read_cell_from_external_file(cell_section, para_env) ! Trying to read cell info from the separate A, B, C vectors ! If cell information is provided through file A,B,C contain the file information.. ! a print warning is shown on screen.. - CALL section_vals_val_get(cell_section,"A",explicit=cell_read_a,error=error) + CALL section_vals_val_get(cell_section,"A",explicit=cell_read_a) IF (cell_read_a) THEN - CALL section_vals_val_get(cell_section,"A",r_vals=cell_par,error=error) + CALL section_vals_val_get(cell_section,"A",r_vals=cell_par) cell%hmat(:,1) = cell_par(:) END IF - CALL section_vals_val_get(cell_section,"B",explicit=cell_read_b,error=error) + CALL section_vals_val_get(cell_section,"B",explicit=cell_read_b) IF (cell_read_b) THEN - CALL section_vals_val_get(cell_section,"B",r_vals=cell_par,error=error) + CALL section_vals_val_get(cell_section,"B",r_vals=cell_par) cell%hmat(:,2) = cell_par(:) END IF - CALL section_vals_val_get(cell_section,"C",explicit=cell_read_c,error=error) + CALL section_vals_val_get(cell_section,"C",explicit=cell_read_c) IF (cell_read_c) THEN - CALL section_vals_val_get(cell_section,"C",r_vals=cell_par,error=error) + CALL section_vals_val_get(cell_section,"C",r_vals=cell_par) cell%hmat(:,3) = cell_par(:) END IF check = ((cell_read_a.EQV.cell_read_b).AND.(cell_read_b.EQV.cell_read_c)) @@ -135,7 +132,7 @@ RECURSIVE SUBROUTINE read_cell( cell, cell_ref, use_ref_cell, cell_section,& only_ionode=.TRUE.) ! Very last option.. Trying to read cell info from ABC keyword - CALL section_vals_val_get(cell_section,"ABC",explicit=cell_read_abc,error=error) + CALL section_vals_val_get(cell_section,"ABC",explicit=cell_read_abc) IF (cell_read_abc) THEN check = (cell_read_a.OR.cell_read_b.OR.cell_read_c) CALL cp_assert(.NOT.check,cp_warning_level,cp_assertion_failed,routineP,& @@ -144,16 +141,16 @@ RECURSIVE SUBROUTINE read_cell( cell, cell_ref, use_ref_cell, cell_section,& CPSourceFileRef,& only_ionode=.TRUE.) cell%hmat = 0.0_dp - CALL section_vals_val_get(cell_section,"ABC",r_vals=cell_par,error=error) - CALL section_vals_val_get(cell_section,"ALPHA_BETA_GAMMA",r_vals=cell_angles,error=error) - CALL set_cell_param(cell,cell_par,cell_angles,do_init_cell=.FALSE.,error=error) + CALL section_vals_val_get(cell_section,"ABC",r_vals=cell_par) + CALL section_vals_val_get(cell_section,"ALPHA_BETA_GAMMA",r_vals=cell_angles) + CALL set_cell_param(cell,cell_par,cell_angles,do_init_cell=.FALSE.) END IF ! Multiple unit cell - CALL section_vals_val_get(cell_section,"MULTIPLE_UNIT_CELL",i_vals=multiple_unit_cell,error=error) - IF (ANY(multiple_unit_cell/=1)) CALL set_multiple_unit_cell(cell, multiple_unit_cell, error) + CALL section_vals_val_get(cell_section,"MULTIPLE_UNIT_CELL",i_vals=multiple_unit_cell) + IF (ANY(multiple_unit_cell/=1)) CALL set_multiple_unit_cell(cell, multiple_unit_cell) - CALL section_vals_val_get(cell_section,"PERIODIC",i_val=my_per,error=error) + CALL section_vals_val_get(cell_section,"PERIODIC",i_val=my_per) SELECT CASE(my_per) CASE(use_perd_x) cell%perd = (/1,0,0/) @@ -172,24 +169,24 @@ RECURSIVE SUBROUTINE read_cell( cell, cell_ref, use_ref_cell, cell_section,& CASE(use_perd_none) cell%perd = (/0,0,0/) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Load requested cell symmetry - CALL section_vals_val_get(cell_section,"SYMMETRY",i_val=cell%symmetry_id,error=error) + CALL section_vals_val_get(cell_section,"SYMMETRY",i_val=cell%symmetry_id) ! Initialize cell CALL init_cell(cell) IF (.NOT.my_check) RETURN cell_ref_section => section_vals_get_subs_vals(cell_section,& - "CELL_REF",error=error) - IF (parsed_cp2k_input(cell_ref_section,check_this_section=.TRUE.,error=error)) THEN + "CELL_REF") + IF (parsed_cp2k_input(cell_ref_section,check_this_section=.TRUE.)) THEN IF(PRESENT(use_ref_cell) ) use_ref_cell = .TRUE. CALL read_cell(cell_ref, cell_ref, use_ref_cell, cell_section=cell_ref_section,& - check_for_ref=.FALSE., para_env=para_env, error=error) + check_for_ref=.FALSE., para_env=para_env) ELSE - CALL cell_clone (cell, cell_ref, error) + CALL cell_clone (cell, cell_ref) IF ( PRESENT ( use_ref_cell ) ) use_ref_cell = .FALSE. END IF @@ -200,15 +197,12 @@ END SUBROUTINE read_cell !> returns true if the new input was parsed !> \param input_file the parsed input file !> \param check_this_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION parsed_cp2k_input(input_file,check_this_section,error) RESULT(res) + FUNCTION parsed_cp2k_input(input_file,check_this_section) RESULT(res) TYPE(section_vals_type), POINTER :: input_file LOGICAL, INTENT(IN), OPTIONAL :: check_this_section - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'parsed_cp2k_input', & @@ -222,13 +216,12 @@ FUNCTION parsed_cp2k_input(input_file,check_this_section,error) RESULT(res) IF (PRESENT(check_this_section)) my_check = check_this_section res=ASSOCIATED(input_file) IF (res) THEN - CPPrecondition(input_file%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(input_file%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT.my_check) THEN - glob_section => section_vals_get_subs_vals(input_file,"GLOBAL",& - error=error) - CALL section_vals_get(glob_section,explicit=res,error=error) + glob_section => section_vals_get_subs_vals(input_file,"GLOBAL") + CALL section_vals_get(glob_section,explicit=res) ELSE - CALL section_vals_get(input_file,explicit=res,error=error) + CALL section_vals_get(input_file,explicit=res) END IF END IF END FUNCTION parsed_cp2k_input @@ -237,16 +230,14 @@ END FUNCTION parsed_cp2k_input !> \brief Setup of the multiple unit_cell !> \param cell ... !> \param multiple_unit_cell ... -!> \param error ... !> \date 05.2009 !> \author Teodoro Laino [tlaino] !> \version 1.0 ! ***************************************************************************** - SUBROUTINE set_multiple_unit_cell(cell, multiple_unit_cell, error) + SUBROUTINE set_multiple_unit_cell(cell, multiple_unit_cell) TYPE(cell_type), POINTER :: cell INTEGER, DIMENSION(:), POINTER :: multiple_unit_cell - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_multiple_unit_cell', & routineP = moduleN//':'//routineN @@ -272,16 +263,14 @@ END SUBROUTINE set_multiple_unit_cell !> \brief Read cell information from an external file !> \param cell_section ... !> \param para_env ... -!> \param error ... !> \date 02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich !> \version 1.0 ! ***************************************************************************** - SUBROUTINE read_cell_from_external_file(cell_section, para_env, error) + SUBROUTINE read_cell_from_external_file(cell_section, para_env) TYPE(section_vals_type), POINTER :: cell_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_cell_from_external_file', & routineP = moduleN//':'//routineN @@ -297,38 +286,38 @@ SUBROUTINE read_cell_from_external_file(cell_section, para_env, error) failure = .FALSE. NULLIFY(parser) - CALL section_vals_val_get(cell_section,"CELL_FILE_NAME",c_val=cell_file_name,error=error) - CALL section_vals_val_get(cell_section,"CELL_FILE_FORMAT",i_val=my_format, error=error) - CALL parser_create(parser,cell_file_name, para_env=para_env,error=error) - CALL parser_get_next_line(parser,1,error=error) + CALL section_vals_val_get(cell_section,"CELL_FILE_NAME",c_val=cell_file_name) + CALL section_vals_val_get(cell_section,"CELL_FILE_FORMAT",i_val=my_format) + CALL parser_create(parser,cell_file_name, para_env=para_env) + CALL parser_get_next_line(parser,1) SELECT CASE(my_format) CASE (do_cell_cp2k) my_end = .FALSE. DO WHILE (.NOT.my_end) READ(parser%input_line,*)idum,xdum,hmat(:,1),hmat(:,2),hmat(:,3) - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) END DO CASE (do_cell_xsc) READ(parser%input_line,*)idum,hmat(:,1),hmat(:,2),hmat(:,3) END SELECT - CALL parser_release(parser,error=error) - CALL section_vals_val_unset(cell_section,"CELL_FILE_NAME",error=error) - CALL section_vals_val_unset(cell_section,"CELL_FILE_FORMAT",error=error) + CALL parser_release(parser) + CALL section_vals_val_unset(cell_section,"CELL_FILE_NAME") + CALL section_vals_val_unset(cell_section,"CELL_FILE_FORMAT") ! Conver to CP2K units DO i = 1, 3 DO j = 1, 3 - hmat(j,i) = cp_unit_to_cp2k(hmat(j,i), "angstrom", error=error) + hmat(j,i) = cp_unit_to_cp2k(hmat(j,i), "angstrom") END DO END DO ! Check if the cell was already defined explicit = .FALSE. - CALL section_vals_val_get(cell_section,"A",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(cell_section,"A",n_rep_val=n_rep) explicit = explicit .OR. (n_rep==1) - CALL section_vals_val_get(cell_section,"B",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(cell_section,"B",n_rep_val=n_rep) explicit = explicit .OR. (n_rep==1) - CALL section_vals_val_get(cell_section,"C",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(cell_section,"C",n_rep_val=n_rep) explicit = explicit .OR. (n_rep==1) - CALL section_vals_val_get(cell_section,"ABC",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(cell_section,"ABC",n_rep_val=n_rep) explicit = explicit .OR. (n_rep==1) ! Possibly print a warning CALL cp_assert(.NOT.explicit,cp_warning_level,cp_assertion_failed,routineP,& @@ -339,20 +328,20 @@ SUBROUTINE read_cell_from_external_file(cell_section, para_env, error) only_ionode=.TRUE.) ! Copy cell information in the A, B, C fields..(we may need them later on..) ALLOCATE(cell_par(3), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cell_par = hmat(:,1) - CALL section_vals_val_set(cell_section,"A",r_vals_ptr=cell_par,error=error) + CALL section_vals_val_set(cell_section,"A",r_vals_ptr=cell_par) ALLOCATE(cell_par(3), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cell_par = hmat(:,2) - CALL section_vals_val_set(cell_section,"B",r_vals_ptr=cell_par,error=error) + CALL section_vals_val_set(cell_section,"B",r_vals_ptr=cell_par) ALLOCATE(cell_par(3), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cell_par = hmat(:,3) - CALL section_vals_val_set(cell_section,"C",r_vals_ptr=cell_par,error=error) + CALL section_vals_val_set(cell_section,"C",r_vals_ptr=cell_par) ! Unset possible keywords - CALL section_vals_val_unset(cell_section,"ABC",error=error) - CALL section_vals_val_unset(cell_section,"ALPHA_BETA_GAMMA",error=error) + CALL section_vals_val_unset(cell_section,"ABC") + CALL section_vals_val_unset(cell_section,"ALPHA_BETA_GAMMA") END SUBROUTINE read_cell_from_external_file @@ -362,20 +351,18 @@ END SUBROUTINE read_cell_from_external_file !> \param subsys_section ... !> \param cell_ref ... !> \param label ... -!> \param error ... !> \date 02.06.2000 !> \par History !> - 11.2008 Teodoro Laino [tlaino] - rewrite and enabling user driven units !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - RECURSIVE SUBROUTINE write_cell(cell,subsys_section,cell_ref,label,error) + RECURSIVE SUBROUTINE write_cell(cell,subsys_section,cell_ref,label) TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: subsys_section TYPE(cell_type), OPTIONAL, POINTER :: cell_ref CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: label - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_cell', & routineP = moduleN//':'//routineN @@ -393,19 +380,19 @@ RECURSIVE SUBROUTINE write_cell(cell,subsys_section,cell_ref,label,error) NULLIFY (keyword) NULLIFY (logger) NULLIFY (section) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_label = "CELL|" IF (PRESENT(label)) my_label = TRIM(label) output_unit = cp_print_key_unit_nr(logger,subsys_section,"PRINT%CELL",& - extension=".Log",error=error) - CALL section_vals_val_get(subsys_section,"PRINT%CELL%UNIT",c_val=unit_str,error=error) + extension=".Log") + CALL section_vals_val_get(subsys_section,"PRINT%CELL%UNIT",c_val=unit_str) IF (output_unit > 0) THEN CALL get_cell(cell=cell,abc=abc,alpha=alpha,beta=beta,gamma=gamma) WRITE (UNIT=output_unit, FMT='( )') - val = cp_unit_from_cp2k(cell%deth,TRIM(unit_str)//"^3",error=error) + val = cp_unit_from_cp2k(cell%deth,TRIM(unit_str)//"^3") WRITE (UNIT=output_unit,FMT="(T2,A,T61,F20.3)")& TRIM(my_label)//" Volume ["//TRIM(unit_str)//"^3]:",val - val = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + val = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) WRITE (UNIT=output_unit,FMT="(T2,A,T30,3F10.3,4X,A6,F11.3)")& TRIM(my_label)//" Vector a ["//TRIM(unit_str)//"]:",cell%hmat(:,1)*val,& "|a| = ",abc(1)*val,& @@ -418,13 +405,13 @@ RECURSIVE SUBROUTINE write_cell(cell,subsys_section,cell_ref,label,error) TRIM(my_label)//" Angle (a,c), beta [degree]: ",beta,& TRIM(my_label)//" Angle (a,b), gamma [degree]: ",gamma IF (cell%symmetry_id /= cell_sym_none) THEN - CALL create_cell_section(section,error=error) - keyword => section_get_keyword(section,"SYMMETRY",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + CALL create_cell_section(section) + keyword => section_get_keyword(section,"SYMMETRY") + CALL keyword_get(keyword,enum=enum) WRITE (UNIT=output_unit,FMT="(T2,A,T61,A20)")& TRIM(my_label)//" Requested initial symmetry: ",& - ADJUSTR(TRIM(enum_i2c(enum,cell%symmetry_id,error=error))) - CALL section_release(section,error=error) + ADJUSTR(TRIM(enum_i2c(enum,cell%symmetry_id))) + CALL section_release(section) END IF IF (cell%orthorhombic) THEN WRITE (UNIT=output_unit,FMT="(T2,A,T78,A3)")& @@ -435,10 +422,10 @@ RECURSIVE SUBROUTINE write_cell(cell,subsys_section,cell_ref,label,error) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%CELL",error=error) + "PRINT%CELL") IF (PRESENT(cell_ref)) THEN - CALL write_cell(cell_ref, subsys_section, label="CELL_REF|", error=error) + CALL write_cell(cell_ref, subsys_section, label="CELL_REF|") END IF END SUBROUTINE write_cell diff --git a/src/colvar_methods.F b/src/colvar_methods.F index 6d94cb2450..e3356be5ea 100644 --- a/src/colvar_methods.F +++ b/src/colvar_methods.F @@ -116,18 +116,15 @@ MODULE colvar_methods !> \param icol number of the current colvar (repetition in colvar_section) !> \param colvar_section the colvar section !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2004 created [alessandro laio and fawzi mohamed] !> \author teo ! ***************************************************************************** - RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) + RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env) TYPE(colvar_type), POINTER :: colvar INTEGER, INTENT(IN) :: icol TYPE(section_vals_type), POINTER :: colvar_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_read', & routineP = moduleN//':'//routineN @@ -168,123 +165,117 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) failure=.FALSE. CALL timeset(routineN,handle) NULLIFY(logger, c_kinds, iatms) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_subsection = .FALSE. - distance_section => section_vals_get_subs_vals(colvar_section,"DISTANCE",i_rep_section=icol,error=error) + distance_section => section_vals_get_subs_vals(colvar_section,"DISTANCE",i_rep_section=icol) dfunct_section => section_vals_get_subs_vals(colvar_section,"DISTANCE_FUNCTION",& - i_rep_section=icol,error=error) - angle_section => section_vals_get_subs_vals(colvar_section,"ANGLE",i_rep_section=icol,error=error) - torsion_section => section_vals_get_subs_vals(colvar_section,"TORSION",i_rep_section=icol,error=error) - coordination_section => section_vals_get_subs_vals(colvar_section,"COORDINATION",i_rep_section=icol,& - error=error) - plane_dist_section => section_vals_get_subs_vals(colvar_section,"DISTANCE_POINT_PLANE",i_rep_section=icol,& - error=error) + i_rep_section=icol) + angle_section => section_vals_get_subs_vals(colvar_section,"ANGLE",i_rep_section=icol) + torsion_section => section_vals_get_subs_vals(colvar_section,"TORSION",i_rep_section=icol) + coordination_section => section_vals_get_subs_vals(colvar_section,"COORDINATION",i_rep_section=icol) + plane_dist_section => section_vals_get_subs_vals(colvar_section,"DISTANCE_POINT_PLANE",i_rep_section=icol) plane_plane_angle_section & - => section_vals_get_subs_vals(colvar_section,"ANGLE_PLANE_PLANE",i_rep_section=icol,& - error=error) - rotation_section => section_vals_get_subs_vals(colvar_section,"BOND_ROTATION",i_rep_section=icol,& - error=error) - qparm_section => section_vals_get_subs_vals(colvar_section,"QPARM",i_rep_section=icol,error=error) - hydronium_section => section_vals_get_subs_vals(colvar_section,"HYDRONIUM",i_rep_section=icol,error=error) + => section_vals_get_subs_vals(colvar_section,"ANGLE_PLANE_PLANE",i_rep_section=icol) + rotation_section => section_vals_get_subs_vals(colvar_section,"BOND_ROTATION",i_rep_section=icol) + qparm_section => section_vals_get_subs_vals(colvar_section,"QPARM",i_rep_section=icol) + hydronium_section => section_vals_get_subs_vals(colvar_section,"HYDRONIUM",i_rep_section=icol) reaction_path_section => section_vals_get_subs_vals(colvar_section,"REACTION_PATH",i_rep_section=icol,& - can_return_null=.TRUE.,error=error) + can_return_null=.TRUE.) distance_from_path_section & => section_vals_get_subs_vals(colvar_section,"DISTANCE_FROM_PATH",& - i_rep_section=icol, can_return_null=.TRUE.,error=error) + i_rep_section=icol, can_return_null=.TRUE.) combine_section => section_vals_get_subs_vals(colvar_section,"COMBINE_COLVAR",i_rep_section=icol,& - can_return_null=.TRUE.,error=error) - population_section => section_vals_get_subs_vals(colvar_section,"POPULATION",i_rep_section=icol,error=error) - gyration_section => section_vals_get_subs_vals(colvar_section,"GYRATION_RADIUS",i_rep_section=icol,& - error=error) - rmsd_section => section_vals_get_subs_vals(colvar_section,"RMSD",i_rep_section=icol,error=error) - xyz_diag_section => section_vals_get_subs_vals(colvar_section,"XYZ_DIAG",i_rep_section=icol,error=error) - xyz_outerdiag_section => section_vals_get_subs_vals(colvar_section,"XYZ_OUTERDIAG",i_rep_section=icol,& - error=error) - u_section => section_vals_get_subs_vals(colvar_section,"U",i_rep_section=icol,error=error) - Wc_section => section_vals_get_subs_vals(colvar_section,"WC",i_rep_section=icol,error=error) - HBP_section => section_vals_get_subs_vals(colvar_section,"HBP",i_rep_section=icol,error=error) + can_return_null=.TRUE.) + population_section => section_vals_get_subs_vals(colvar_section,"POPULATION",i_rep_section=icol) + gyration_section => section_vals_get_subs_vals(colvar_section,"GYRATION_RADIUS",i_rep_section=icol) + rmsd_section => section_vals_get_subs_vals(colvar_section,"RMSD",i_rep_section=icol) + xyz_diag_section => section_vals_get_subs_vals(colvar_section,"XYZ_DIAG",i_rep_section=icol) + xyz_outerdiag_section => section_vals_get_subs_vals(colvar_section,"XYZ_OUTERDIAG",i_rep_section=icol) + u_section => section_vals_get_subs_vals(colvar_section,"U",i_rep_section=icol) + Wc_section => section_vals_get_subs_vals(colvar_section,"WC",i_rep_section=icol) + HBP_section => section_vals_get_subs_vals(colvar_section,"HBP",i_rep_section=icol) ring_puckering_section& - => section_vals_get_subs_vals(colvar_section,"RING_PUCKERING",i_rep_section=icol,error=error) - mindist_section => section_vals_get_subs_vals(colvar_section,"CONDITIONED_DISTANCE",i_rep_section=icol,error=error) - - CALL section_vals_get(distance_section, explicit=my_subsection( 1), error=error) - CALL section_vals_get(angle_section, explicit=my_subsection( 2), error=error) - CALL section_vals_get(torsion_section, explicit=my_subsection( 3), error=error) - CALL section_vals_get(coordination_section, explicit=my_subsection( 4), error=error) - CALL section_vals_get(plane_dist_section, explicit=my_subsection( 5), error=error) - CALL section_vals_get(rotation_section, explicit=my_subsection( 6), error=error) - CALL section_vals_get(dfunct_section, explicit=my_subsection( 7), error=error) - CALL section_vals_get(qparm_section, explicit=my_subsection( 8), error=error) - CALL section_vals_get(hydronium_section, explicit=my_subsection( 9), error=error) + => section_vals_get_subs_vals(colvar_section,"RING_PUCKERING",i_rep_section=icol) + mindist_section => section_vals_get_subs_vals(colvar_section,"CONDITIONED_DISTANCE",i_rep_section=icol) + + CALL section_vals_get(distance_section, explicit=my_subsection( 1)) + CALL section_vals_get(angle_section, explicit=my_subsection( 2)) + CALL section_vals_get(torsion_section, explicit=my_subsection( 3)) + CALL section_vals_get(coordination_section, explicit=my_subsection( 4)) + CALL section_vals_get(plane_dist_section, explicit=my_subsection( 5)) + CALL section_vals_get(rotation_section, explicit=my_subsection( 6)) + CALL section_vals_get(dfunct_section, explicit=my_subsection( 7)) + CALL section_vals_get(qparm_section, explicit=my_subsection( 8)) + CALL section_vals_get(hydronium_section, explicit=my_subsection( 9)) ! These are just special cases since they are not present in their own defition of COLVARS IF (ASSOCIATED(reaction_path_section)) THEN CALL section_vals_get(reaction_path_section,& - explicit=my_subsection(10), error=error) + explicit=my_subsection(10)) END IF IF (ASSOCIATED(distance_from_path_section)) THEN CALL section_vals_get(distance_from_path_section,& - explicit=my_subsection(16), error=error) + explicit=my_subsection(16)) END IF IF (ASSOCIATED(combine_section)) THEN - CALL section_vals_get(combine_section, explicit=my_subsection(11), error=error) + CALL section_vals_get(combine_section, explicit=my_subsection(11)) END IF - CALL section_vals_get(population_section, explicit=my_subsection(12), error=error) + CALL section_vals_get(population_section, explicit=my_subsection(12)) CALL section_vals_get(plane_plane_angle_section,& - explicit=my_subsection(13), error=error) - CALL section_vals_get(gyration_section, explicit=my_subsection(14), error=error) - CALL section_vals_get(rmsd_section, explicit=my_subsection(15), error=error) - CALL section_vals_get(xyz_diag_section, explicit=my_subsection(17), error=error) - CALL section_vals_get(xyz_outerdiag_section,explicit=my_subsection(18), error=error) - CALL section_vals_get(u_section, explicit=my_subsection(19), error=error) - CALL section_vals_get(Wc_section, explicit=my_subsection(20), error=error) - CALL section_vals_get(HBP_section, explicit=my_subsection(21), error=error) + explicit=my_subsection(13)) + CALL section_vals_get(gyration_section, explicit=my_subsection(14)) + CALL section_vals_get(rmsd_section, explicit=my_subsection(15)) + CALL section_vals_get(xyz_diag_section, explicit=my_subsection(17)) + CALL section_vals_get(xyz_outerdiag_section,explicit=my_subsection(18)) + CALL section_vals_get(u_section, explicit=my_subsection(19)) + CALL section_vals_get(Wc_section, explicit=my_subsection(20)) + CALL section_vals_get(HBP_section, explicit=my_subsection(21)) CALL section_vals_get(ring_puckering_section,& - explicit=my_subsection(22), error=error) - CALL section_vals_get(mindist_section, explicit=my_subsection(23), error=error) + explicit=my_subsection(22)) + CALL section_vals_get(mindist_section, explicit=my_subsection(23)) ! Only one colvar can be present - CPPostcondition(COUNT(my_subsection) == 1,cp_failure_level,routinep,error,failure) - CPPostcondition(.NOT.ASSOCIATED(colvar),cp_failure_level,routinep,error,failure) + CPPostcondition(COUNT(my_subsection) == 1,cp_failure_level,routinep,failure) + CPPostcondition(.NOT.ASSOCIATED(colvar),cp_failure_level,routinep,failure) IF (my_subsection(1)) THEN ! Distance wrk_section => distance_section - CALL colvar_create(colvar, dist_colvar_id, error) - CALL colvar_check_points(colvar, distance_section, error) - CALL section_vals_val_get(distance_section,"ATOMS",i_vals=iatms,error=error) + CALL colvar_create(colvar, dist_colvar_id) + CALL colvar_check_points(colvar, distance_section) + CALL section_vals_val_get(distance_section,"ATOMS",i_vals=iatms) colvar%dist_param%i_at = iatms(1) colvar%dist_param%j_at = iatms(2) - CALL section_vals_val_get(distance_section,"AXIS",i_val=colvar%dist_param%axis_id,error=error) + CALL section_vals_val_get(distance_section,"AXIS",i_val=colvar%dist_param%axis_id) ELSE IF (my_subsection(2)) THEN ! Angle wrk_section => angle_section - CALL colvar_create(colvar, angle_colvar_id, error) - CALL colvar_check_points(colvar, angle_section, error) - CALL section_vals_val_get(angle_section,"ATOMS",i_vals=iatms,error=error) + CALL colvar_create(colvar, angle_colvar_id) + CALL colvar_check_points(colvar, angle_section) + CALL section_vals_val_get(angle_section,"ATOMS",i_vals=iatms) colvar%angle_param%i_at_angle = iatms ELSE IF (my_subsection(3)) THEN ! Torsion wrk_section => torsion_section - CALL colvar_create(colvar, torsion_colvar_id, error) - CALL colvar_check_points(colvar, torsion_section, error) - CALL section_vals_val_get(torsion_section,"ATOMS",i_vals=iatms,error=error) + CALL colvar_create(colvar, torsion_colvar_id) + CALL colvar_check_points(colvar, torsion_section) + CALL section_vals_val_get(torsion_section,"ATOMS",i_vals=iatms) colvar%torsion_param%i_at_tors = iatms colvar%torsion_param%o0 = 0.0_dp ELSE IF (my_subsection(4)) THEN ! Coordination wrk_section => coordination_section - CALL colvar_create(colvar, coord_colvar_id, error) - CALL colvar_check_points(colvar, coordination_section, error) + CALL colvar_create(colvar, coord_colvar_id) + CALL colvar_check_points(colvar, coordination_section) NULLIFY(colvar%coord_param%i_at_from, colvar%coord_param%c_kinds_from) NULLIFY(colvar%coord_param%i_at_to, colvar%coord_param%c_kinds_to) NULLIFY(colvar%coord_param%i_at_to_b, colvar%coord_param%c_kinds_to_b) ! This section can be repeated - CALL section_vals_val_get(coordination_section,"ATOMS_FROM",n_rep_val=n_var,error=error) + CALL section_vals_val_get(coordination_section,"ATOMS_FROM",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(coordination_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(coordination_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%coord_param%i_at_from,1, ndim+SIZE(iatms)) colvar%coord_param%i_at_from(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -293,10 +284,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%coord_param%use_kinds_from = .FALSE. ELSE ! KINDS - CALL section_vals_val_get(coordination_section,"KINDS_FROM",n_rep_val=n_var,error=error) - CPPostcondition(n_var>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(coordination_section,"KINDS_FROM",n_rep_val=n_var) + CPPostcondition(n_var>0,cp_failure_level,routinep,failure) DO k = 1, n_var - CALL section_vals_val_get(coordination_section,"KINDS_FROM",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(coordination_section,"KINDS_FROM",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%coord_param%c_kinds_from,1, ndim+SIZE(c_kinds)) colvar%coord_param%c_kinds_from(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -309,12 +300,12 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END DO END IF ! This section can be repeated - CALL section_vals_val_get(coordination_section,"ATOMS_TO",n_rep_val=n_var,error=error) + CALL section_vals_val_get(coordination_section,"ATOMS_TO",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(coordination_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(coordination_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%coord_param%i_at_to,1, ndim+SIZE(iatms)) colvar%coord_param%i_at_to(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -323,10 +314,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%coord_param%use_kinds_to = .FALSE. ELSE ! KINDS - CALL section_vals_val_get(coordination_section,"KINDS_TO",n_rep_val=n_var,error=error) - CPPostcondition(n_var>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(coordination_section,"KINDS_TO",n_rep_val=n_var) + CPPostcondition(n_var>0,cp_failure_level,routinep,failure) DO k = 1, n_var - CALL section_vals_val_get(coordination_section,"KINDS_TO",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(coordination_section,"KINDS_TO",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%coord_param%c_kinds_to,1, ndim+SIZE(c_kinds)) colvar%coord_param%c_kinds_to(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -339,19 +330,19 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END DO END IF ! Let's finish reading the other parameters - CALL section_vals_val_get(coordination_section,"R0",r_val=colvar%coord_param%r_0,error=error) - CALL section_vals_val_get(coordination_section,"NN",i_val=colvar%coord_param%nncrd,error=error) - CALL section_vals_val_get(coordination_section,"ND",i_val=colvar%coord_param%ndcrd,error=error) + CALL section_vals_val_get(coordination_section,"R0",r_val=colvar%coord_param%r_0) + CALL section_vals_val_get(coordination_section,"NN",i_val=colvar%coord_param%nncrd) + CALL section_vals_val_get(coordination_section,"ND",i_val=colvar%coord_param%ndcrd) ! This section can be repeated - CALL section_vals_val_get(coordination_section,"ATOMS_TO_B",n_rep_val=n_var,error=error) - CALL section_vals_val_get(coordination_section,"KINDS_TO_B",n_rep_val=n_var_k,error=error) + CALL section_vals_val_get(coordination_section,"ATOMS_TO_B",n_rep_val=n_var) + CALL section_vals_val_get(coordination_section,"KINDS_TO_B",n_rep_val=n_var_k) ndim = 0 IF (n_var /= 0 .OR. n_var_k /= 0) THEN colvar%coord_param%do_chain = .TRUE. IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(coordination_section,"ATOMS_TO_B",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(coordination_section,"ATOMS_TO_B",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%coord_param%i_at_to_b,1, ndim+SIZE(iatms)) colvar%coord_param%i_at_to_b(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -360,10 +351,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%coord_param%use_kinds_to_b = .FALSE. ELSE ! KINDS - CALL section_vals_val_get(coordination_section,"KINDS_TO_B",n_rep_val=n_var_k,error=error) - CPPostcondition(n_var_k>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(coordination_section,"KINDS_TO_B",n_rep_val=n_var_k) + CPPostcondition(n_var_k>0,cp_failure_level,routinep,failure) DO k = 1, n_var_k - CALL section_vals_val_get(coordination_section,"KINDS_TO_B",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(coordination_section,"KINDS_TO_B",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%coord_param%c_kinds_to_b,1, ndim+SIZE(c_kinds)) colvar%coord_param%c_kinds_to_b(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -376,9 +367,9 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END DO END IF ! Let's finish reading the other parameters - CALL section_vals_val_get(coordination_section,"R0_B",r_val=colvar%coord_param%r_0_b,error=error) - CALL section_vals_val_get(coordination_section,"NN_B",i_val=colvar%coord_param%nncrd_b,error=error) - CALL section_vals_val_get(coordination_section,"ND_B",i_val=colvar%coord_param%ndcrd_b,error=error) + CALL section_vals_val_get(coordination_section,"R0_B",r_val=colvar%coord_param%r_0_b) + CALL section_vals_val_get(coordination_section,"NN_B",i_val=colvar%coord_param%nncrd_b) + CALL section_vals_val_get(coordination_section,"ND_B",i_val=colvar%coord_param%ndcrd_b) ELSE colvar%coord_param%do_chain = .FALSE. colvar%coord_param%n_atoms_to_b = 0 @@ -393,56 +384,56 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) ELSE IF (my_subsection(5)) THEN ! Distance point from plane wrk_section => plane_dist_section - CALL colvar_create(colvar, plane_distance_colvar_id, error) - CALL colvar_check_points(colvar, plane_dist_section, error) - CALL section_vals_val_get(plane_dist_section,"ATOMS_PLANE",i_vals=iatms,error=error) - CPPostcondition(SIZE(iatms) == 3,cp_failure_level,routinep,error,failure) + CALL colvar_create(colvar, plane_distance_colvar_id) + CALL colvar_check_points(colvar, plane_dist_section) + CALL section_vals_val_get(plane_dist_section,"ATOMS_PLANE",i_vals=iatms) + CPPostcondition(SIZE(iatms) == 3,cp_failure_level,routinep,failure) colvar%plane_distance_param%plane = iatms - CALL section_vals_val_get(plane_dist_section,"ATOM_POINT",i_val=iatm,error=error) + CALL section_vals_val_get(plane_dist_section,"ATOM_POINT",i_val=iatm) colvar%plane_distance_param%point = iatm - CALL section_vals_val_get(plane_dist_section,"PBC",l_val=colvar%plane_distance_param%use_pbc,error=error) + CALL section_vals_val_get(plane_dist_section,"PBC",l_val=colvar%plane_distance_param%use_pbc) ELSE IF (my_subsection(6)) THEN ! Rotation colvar of a segment w.r.t. another segment wrk_section => rotation_section - CALL colvar_create(colvar, rotation_colvar_id, error) - CALL colvar_check_points(colvar, rotation_section, error) - CALL section_vals_val_get(rotation_section,"P1_BOND1",i_val=colvar%rotation_param%i_at1_bond1,error=error) - CALL section_vals_val_get(rotation_section,"P2_BOND1",i_val=colvar%rotation_param%i_at2_bond1,error=error) - CALL section_vals_val_get(rotation_section,"P1_BOND2",i_val=colvar%rotation_param%i_at1_bond2,error=error) - CALL section_vals_val_get(rotation_section,"P2_BOND2",i_val=colvar%rotation_param%i_at2_bond2,error=error) + CALL colvar_create(colvar, rotation_colvar_id) + CALL colvar_check_points(colvar, rotation_section) + CALL section_vals_val_get(rotation_section,"P1_BOND1",i_val=colvar%rotation_param%i_at1_bond1) + CALL section_vals_val_get(rotation_section,"P2_BOND1",i_val=colvar%rotation_param%i_at2_bond1) + CALL section_vals_val_get(rotation_section,"P1_BOND2",i_val=colvar%rotation_param%i_at1_bond2) + CALL section_vals_val_get(rotation_section,"P2_BOND2",i_val=colvar%rotation_param%i_at2_bond2) ELSE IF (my_subsection(7)) THEN ! Difference of two distances wrk_section => dfunct_section - CALL colvar_create(colvar, dfunct_colvar_id, error) - CALL colvar_check_points(colvar, dfunct_section, error) - CALL section_vals_val_get(dfunct_section,"ATOMS",i_vals=iatms,error=error) + CALL colvar_create(colvar, dfunct_colvar_id) + CALL colvar_check_points(colvar, dfunct_section) + CALL section_vals_val_get(dfunct_section,"ATOMS",i_vals=iatms) colvar%dfunct_param%i_at_dfunct = iatms - CALL section_vals_val_get(dfunct_section,"COEFFICIENT",r_val=colvar%dfunct_param%coeff,error=error) - CALL section_vals_val_get(dfunct_section,"PBC",l_val=colvar%dfunct_param%use_pbc,error=error) + CALL section_vals_val_get(dfunct_section,"COEFFICIENT",r_val=colvar%dfunct_param%coeff) + CALL section_vals_val_get(dfunct_section,"PBC",l_val=colvar%dfunct_param%use_pbc) ELSE IF (my_subsection(8)) THEN ! Q Parameter wrk_section => qparm_section - CALL colvar_create(colvar, qparm_colvar_id, error) - CALL colvar_check_points(colvar, qparm_section, error) - CALL section_vals_val_get(qparm_section,"RCUT",r_val=colvar%qparm_param%rcut,error=error) - CALL section_vals_val_get(qparm_section,"ALPHA",r_val=colvar%qparm_param%alpha,error=error) - CALL section_vals_val_get(qparm_section,"L",i_val=colvar%qparm_param%l,error=error) + CALL colvar_create(colvar, qparm_colvar_id) + CALL colvar_check_points(colvar, qparm_section) + CALL section_vals_val_get(qparm_section,"RCUT",r_val=colvar%qparm_param%rcut) + CALL section_vals_val_get(qparm_section,"ALPHA",r_val=colvar%qparm_param%alpha) + CALL section_vals_val_get(qparm_section,"L",i_val=colvar%qparm_param%l) NULLIFY(colvar%qparm_param%i_at_from) NULLIFY(colvar%qparm_param%i_at_to) - CALL section_vals_val_get(qparm_section,"ATOMS_FROM",n_rep_val=n_var,error=error) + CALL section_vals_val_get(qparm_section,"ATOMS_FROM",n_rep_val=n_var) ndim = 0 DO k = 1, n_var - CALL section_vals_val_get(qparm_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(qparm_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%qparm_param%i_at_from,1, ndim+SIZE(iatms)) colvar%qparm_param%i_at_from(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) END DO colvar%qparm_param%n_atoms_from = ndim ! This section can be repeated - CALL section_vals_val_get(qparm_section,"ATOMS_TO",n_rep_val=n_var,error=error) + CALL section_vals_val_get(qparm_section,"ATOMS_TO",n_rep_val=n_var) ndim = 0 DO k = 1, n_var - CALL section_vals_val_get(qparm_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(qparm_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%qparm_param%i_at_to,1, ndim+SIZE(iatms)) colvar%qparm_param%i_at_to(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -450,59 +441,57 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%qparm_param%n_atoms_to = ndim ELSE IF (my_subsection(9)) THEN ! Hydronium - CALL colvar_create(colvar,hydronium_colvar_id, error) + CALL colvar_create(colvar,hydronium_colvar_id) NULLIFY(colvar%hydronium_param%i_oxygens) NULLIFY(colvar%hydronium_param%i_hydrogens) - CALL section_vals_val_get(hydronium_section,"OXYGENS",n_rep_val=n_var,error=error) + CALL section_vals_val_get(hydronium_section,"OXYGENS",n_rep_val=n_var) ndim = 0 DO k = 1, n_var - CALL section_vals_val_get(hydronium_section,"OXYGENS",i_vals=iatms,error=error) + CALL section_vals_val_get(hydronium_section,"OXYGENS",i_vals=iatms) CALL reallocate(colvar%hydronium_param%i_oxygens,1,ndim+SIZE(iatms)) colvar%hydronium_param%i_oxygens(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) END DO colvar%hydronium_param%n_oxygens = ndim - CALL section_vals_val_get(hydronium_section,"HYDROGENS",n_rep_val=n_var,error=error) + CALL section_vals_val_get(hydronium_section,"HYDROGENS",n_rep_val=n_var) ndim = 0 DO k = 1, n_var - CALL section_vals_val_get(hydronium_section,"HYDROGENS",i_vals=iatms,error=error) + CALL section_vals_val_get(hydronium_section,"HYDROGENS",i_vals=iatms) CALL reallocate(colvar%hydronium_param%i_hydrogens,1,ndim+SIZE(iatms)) colvar%hydronium_param%i_hydrogens(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) END DO colvar%hydronium_param%n_hydrogens = ndim - CALL section_vals_val_get(hydronium_section,"ROO",r_val=colvar%hydronium_param%r_OO,error=error) - CALL section_vals_val_get(hydronium_section,"ROH",r_val=colvar%hydronium_param%r_OH,error=error) - CALL section_vals_val_get(hydronium_section,"pNH",i_val=colvar%hydronium_param%pnh,error=error) - CALL section_vals_val_get(hydronium_section,"qNH",i_val=colvar%hydronium_param%qnh,error=error) - CALL section_vals_val_get(hydronium_section,"pNO",i_val=colvar%hydronium_param%pno,error=error) - CALL section_vals_val_get(hydronium_section,"qNO",i_val=colvar%hydronium_param%qno,error=error) - CALL section_vals_val_get(hydronium_section,"p",i_val=colvar%hydronium_param%p,error=error) - CALL section_vals_val_get(hydronium_section,"q",i_val=colvar%hydronium_param%q,error=error) - CALL section_vals_val_get(hydronium_section,"NH",r_val=colvar%hydronium_param%nh,error=error) - CALL section_vals_val_get(hydronium_section,"LAMBDA",r_val=colvar%hydronium_param%lambda,error=error) + CALL section_vals_val_get(hydronium_section,"ROO",r_val=colvar%hydronium_param%r_OO) + CALL section_vals_val_get(hydronium_section,"ROH",r_val=colvar%hydronium_param%r_OH) + CALL section_vals_val_get(hydronium_section,"pNH",i_val=colvar%hydronium_param%pnh) + CALL section_vals_val_get(hydronium_section,"qNH",i_val=colvar%hydronium_param%qnh) + CALL section_vals_val_get(hydronium_section,"pNO",i_val=colvar%hydronium_param%pno) + CALL section_vals_val_get(hydronium_section,"qNO",i_val=colvar%hydronium_param%qno) + CALL section_vals_val_get(hydronium_section,"p",i_val=colvar%hydronium_param%p) + CALL section_vals_val_get(hydronium_section,"q",i_val=colvar%hydronium_param%q) + CALL section_vals_val_get(hydronium_section,"NH",r_val=colvar%hydronium_param%nh) + CALL section_vals_val_get(hydronium_section,"LAMBDA",r_val=colvar%hydronium_param%lambda) ELSE IF(my_subsection(10) .OR. my_subsection(16))THEN !reaction path or distance from reaction path IF (my_subsection(10) ) THEN path_section => reaction_path_section - CALL colvar_create(colvar,reaction_path_colvar_id, error) + CALL colvar_create(colvar,reaction_path_colvar_id) fmid="POS" ifunc=1 ELSE IF (my_subsection(16) ) THEN path_section => distance_from_path_section - CALL colvar_create(colvar,distance_from_path_colvar_id, error) + CALL colvar_create(colvar,distance_from_path_colvar_id) fmid="DIS" ifunc=2 END IF colvar%use_points=.FALSE. - CALL section_vals_val_get(path_section,"LAMBDA",r_val=colvar%reaction_path_param%lambda,error=error) - CALL section_vals_val_get(path_section,"DISTANCES_RMSD",l_val=colvar%reaction_path_param%dist_rmsd,& - error=error) - CALL section_vals_val_get(path_section,"RMSD",l_val=colvar%reaction_path_param%rmsd,& - error=error) + CALL section_vals_val_get(path_section,"LAMBDA",r_val=colvar%reaction_path_param%lambda) + CALL section_vals_val_get(path_section,"DISTANCES_RMSD",l_val=colvar%reaction_path_param%dist_rmsd) + CALL section_vals_val_get(path_section,"RMSD",l_val=colvar%reaction_path_param%rmsd) IF(colvar%reaction_path_param%dist_rmsd .AND. colvar%reaction_path_param%rmsd)THEN CALL cp_assert(.FALSE.,cp_fatal_level,cp_assertion_failed,routineP,& "CV REACTION PATH: only one between DISTANCES_RMSD and RMSD can be used "//& @@ -510,28 +499,27 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END IF IF(colvar%reaction_path_param%dist_rmsd .OR. colvar%reaction_path_param%rmsd) THEN NULLIFY(colvar%reaction_path_param%i_rmsd, colvar%reaction_path_param%r_ref) - frame_section => section_vals_get_subs_vals(path_section,"FRAME",error=error) - CALL section_vals_get(frame_section,n_repetition=nr_frame,error=error) + frame_section => section_vals_get_subs_vals(path_section,"FRAME") + CALL section_vals_get(frame_section,n_repetition=nr_frame) colvar%reaction_path_param%nr_frames=nr_frame CALL read_frames(frame_section,para_env,nr_frame,colvar%reaction_path_param%r_ref,& - colvar%reaction_path_param%n_components,error=error) - CALL section_vals_val_get(path_section,"SUBSET_TYPE",i_val=colvar%reaction_path_param%subset,& - error=error) + colvar%reaction_path_param%n_components) + CALL section_vals_val_get(path_section,"SUBSET_TYPE",i_val=colvar%reaction_path_param%subset) IF (colvar%reaction_path_param%subset==rmsd_all) THEN ALLOCATE(colvar%reaction_path_param%i_rmsd(colvar%reaction_path_param%n_components),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i = 1, colvar%reaction_path_param%n_components colvar%reaction_path_param%i_rmsd(i) = i END DO ELSE IF (colvar%reaction_path_param%subset==rmsd_list) THEN ! This section can be repeated - CALL section_vals_val_get(path_section,"ATOMS",n_rep_val=n_var,error=error) + CALL section_vals_val_get(path_section,"ATOMS",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(path_section,"ATOMS",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(path_section,"ATOMS",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%reaction_path_param%i_rmsd,1, ndim+SIZE(iatms)) colvar%reaction_path_param%i_rmsd(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -544,18 +532,16 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END IF END IF - CALL section_vals_val_get(path_section,"ALIGN_FRAMES",l_val=colvar%reaction_path_param%align_frames,& - error=error) + CALL section_vals_val_get(path_section,"ALIGN_FRAMES",l_val=colvar%reaction_path_param%align_frames) ELSE - colvar_subsection => section_vals_get_subs_vals(path_section,"COLVAR",error=error) - CALL section_vals_get(colvar_subsection,n_repetition=ncol,error=error) + colvar_subsection => section_vals_get_subs_vals(path_section,"COLVAR") + CALL section_vals_get(colvar_subsection,n_repetition=ncol) ALLOCATE(colvar%reaction_path_param%colvar_p(ncol),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ncol>0) THEN DO i= 1, ncol NULLIFY(colvar%reaction_path_param%colvar_p(i)%colvar) - CALL colvar_read(colvar%reaction_path_param%colvar_p(i)%colvar,i,colvar_subsection, para_env,& - error=error) + CALL colvar_read(colvar%reaction_path_param%colvar_p(i)%colvar,i,colvar_subsection, para_env) ENDDO ELSE CALL cp_assert(.FALSE.,cp_fatal_level,cp_assertion_failed,routineP,& @@ -564,22 +550,22 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) ENDIF colvar%reaction_path_param%n_components=ncol NULLIFY(range) - CALL section_vals_val_get(path_section,"RANGE",r_vals=range,error=error) - CALL section_vals_val_get(path_section,"STEP_SIZE",r_val=colvar%reaction_path_param%step_size,error=error) + CALL section_vals_val_get(path_section,"RANGE",r_vals=range) + CALL section_vals_val_get(path_section,"STEP_SIZE",r_val=colvar%reaction_path_param%step_size) iend=CEILING(MAX(RANGE(1),RANGE(2))/colvar%reaction_path_param%step_size) istart=FLOOR(MIN(RANGE(1),RANGE(2))/colvar%reaction_path_param%step_size) colvar%reaction_path_param%function_bounds(1)=istart colvar%reaction_path_param%function_bounds(2)=iend colvar%reaction_path_param%nr_frames= 2 !iend - istart + 1 ALLOCATE(colvar%reaction_path_param%f_vals(ncol,istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) - CALL section_vals_val_get(path_section,"VARIABLE",c_vals=my_par,i_rep_val=1,error=error) - CALL section_vals_val_get(path_section,"FUNCTION",n_rep_val=ncol,error=error) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) + CALL section_vals_val_get(path_section,"VARIABLE",c_vals=my_par,i_rep_val=1) + CALL section_vals_val_get(path_section,"FUNCTION",n_rep_val=ncol) check = (ncol==SIZE(colvar%reaction_path_param%colvar_p)) - CPPostcondition(check,cp_failure_level,routinep,error,failure) + CPPostcondition(check,cp_failure_level,routinep,failure) CALL initf(ncol) DO i=1,ncol - CALL section_vals_val_get(path_section,"FUNCTION",c_val=path_function,i_rep_val=i,error=error) + CALL section_vals_val_get(path_section,"FUNCTION",c_val=path_function,i_rep_val=i) CALL compress(path_function, full=.TRUE.) CALL parsef(i,TRIM(path_function),my_par) DO j=istart,iend @@ -590,65 +576,65 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) CALL finalizef() iw1= cp_print_key_unit_nr(logger,path_section,& - "MAP",middle_name=fmid,extension=".dat",file_status="REPLACE",error=error) + "MAP",middle_name=fmid,extension=".dat",file_status="REPLACE") IF(iw1>0)THEN - CALL section_vals_val_get(path_section,"MAP%GRID_SPACING",n_rep_val=ncol,error=error) + CALL section_vals_val_get(path_section,"MAP%GRID_SPACING",n_rep_val=ncol) ALLOCATE(grid_sp(ncol),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i=1,ncol - CALL section_vals_val_get(path_section,"MAP%GRID_SPACING",r_val=grid_sp(i),error=error) + CALL section_vals_val_get(path_section,"MAP%GRID_SPACING",r_val=grid_sp(i)) END DO - CALL section_vals_val_get(path_section,"MAP%RANGE",n_rep_val=ncol,error=error) - CPPostcondition(ncol ==SIZE(grid_sp) ,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(path_section,"MAP%RANGE",n_rep_val=ncol) + CPPostcondition(ncol ==SIZE(grid_sp) ,cp_failure_level,routinep,failure) ALLOCATE(p_range(2,ncol),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(p_bounds(2,ncol),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i=1,ncol - CALL section_vals_val_get(path_section,"MAP%RANGE",r_vals=g_range,error=error) + CALL section_vals_val_get(path_section,"MAP%RANGE",r_vals=g_range) p_range(:,i)=g_range(:) p_bounds(2,i)=CEILING( MAX(p_range(1,i),p_range(2,i))/grid_sp(i)) p_bounds(1,i)=FLOOR(MIN(p_range(1,i) , p_range(2,i))/grid_sp(i)) END DO ALLOCATE(s1v(2,istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(s1(2),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(grid_point(ncol),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) v_count=0 kk=rec_eval_grid(iw1,ncol,colvar%reaction_path_param%f_vals,v_count,& grid_point,grid_sp,colvar%reaction_path_param%step_size,istart,& iend,s1v,s1,p_bounds,colvar%reaction_path_param%lambda,ifunc=ifunc,& nconf=colvar%reaction_path_param%nr_frames) DEALLOCATE(grid_sp,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(p_range,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(p_bounds,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1v,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(grid_point,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END IF CALL cp_print_key_finished_output(iw1,logger,path_section,& - "MAP", error=error) + "MAP") END IF ELSE IF(my_subsection(11))THEN ! combine colvar - CALL colvar_create(colvar,combine_colvar_id, error) + CALL colvar_create(colvar,combine_colvar_id) colvar%use_points=.FALSE. - colvar_subsection => section_vals_get_subs_vals(combine_section,"COLVAR",error=error) - CALL section_vals_get(colvar_subsection,n_repetition=ncol,error=error) + colvar_subsection => section_vals_get_subs_vals(combine_section,"COLVAR") + CALL section_vals_get(colvar_subsection,n_repetition=ncol) ALLOCATE(colvar%combine_cvs_param%colvar_p(ncol),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ! In case we need to print some information.. iw = cp_print_key_unit_nr(logger,colvar_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".colvarLog",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".colvarLog") IF (iw>0) THEN WRITE ( iw, '( A )')' '//& '**********************************************************************' @@ -656,19 +642,19 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) WRITE ( iw, '( A,T49,4I8)' ) ' COLVARS| COMBINATION OF THE FOLOWING COLVARS:' END IF CALL cp_print_key_finished_output(iw,logger,colvar_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") ! Parsing the real COLVARs DO i= 1, ncol NULLIFY(colvar%combine_cvs_param%colvar_p(i)%colvar) - CALL colvar_read(colvar%combine_cvs_param%colvar_p(i)%colvar,i,colvar_subsection, para_env, error=error) + CALL colvar_read(colvar%combine_cvs_param%colvar_p(i)%colvar,i,colvar_subsection, para_env) END DO ! Function definition - CALL section_vals_val_get(combine_section,"FUNCTION",c_val=colvar%combine_cvs_param%function,error=error) + CALL section_vals_val_get(combine_section,"FUNCTION",c_val=colvar%combine_cvs_param%function) CALL compress(colvar%combine_cvs_param%function, full=.TRUE.) ! Variables - CALL section_vals_val_get(combine_section,"VARIABLES",c_vals=my_par,error=error) + CALL section_vals_val_get(combine_section,"VARIABLES",c_vals=my_par) ALLOCATE(colvar%combine_cvs_param%variables(SIZE(my_par)),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) colvar%combine_cvs_param%variables = my_par ! Check that the number of COLVAR provided is equal to the number of variables.. CALL cp_assert(SIZE(my_par)==ncol,cp_fatal_level,cp_assertion_failed,routineP,& @@ -678,43 +664,42 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) CPSourceFileRef) ! Parameters ALLOCATE(colvar%combine_cvs_param%c_parameters(0),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) - CALL section_vals_val_get(combine_section,"PARAMETERS",n_rep_val=ncol,error=error) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) + CALL section_vals_val_get(combine_section,"PARAMETERS",n_rep_val=ncol) DO i = 1,ncol isize = SIZE(colvar%combine_cvs_param%c_parameters) - CALL section_vals_val_get(combine_section,"PARAMETERS",c_vals=my_par,i_rep_val=i,error=error) + CALL section_vals_val_get(combine_section,"PARAMETERS",c_vals=my_par,i_rep_val=i) CALL reallocate(colvar%combine_cvs_param%c_parameters,1,isize+SIZE(my_par)) colvar%combine_cvs_param%c_parameters(isize+1:isize+SIZE(my_par)) = my_par END DO ALLOCATE(colvar%combine_cvs_param%v_parameters(0),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) - CALL section_vals_val_get(combine_section,"VALUES",n_rep_val=ncol,error=error) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) + CALL section_vals_val_get(combine_section,"VALUES",n_rep_val=ncol) DO i = 1,ncol isize = SIZE(colvar%combine_cvs_param%v_parameters) - CALL section_vals_val_get(combine_section,"VALUES",r_vals=my_vals,i_rep_val=i,error=error) + CALL section_vals_val_get(combine_section,"VALUES",r_vals=my_vals,i_rep_val=i) CALL reallocate(colvar%combine_cvs_param%v_parameters,1,isize+SIZE(my_vals)) colvar%combine_cvs_param%v_parameters(isize+1:isize+SIZE(my_vals)) = my_vals END DO ! Info on derivative evaluation - CALL section_vals_val_get(combine_section,"DX",r_val=colvar%combine_cvs_param%dx,error=error) - CALL section_vals_val_get(combine_section,"ERROR_LIMIT",r_val=colvar%combine_cvs_param%lerr,& - error=error) + CALL section_vals_val_get(combine_section,"DX",r_val=colvar%combine_cvs_param%dx) + CALL section_vals_val_get(combine_section,"ERROR_LIMIT",r_val=colvar%combine_cvs_param%lerr) ELSE IF (my_subsection(12)) THEN ! Population wrk_section => population_section - CALL colvar_create(colvar, population_colvar_id, error) - CALL colvar_check_points(colvar, population_section, error) + CALL colvar_create(colvar, population_colvar_id) + CALL colvar_check_points(colvar, population_section) NULLIFY(colvar%population_param%i_at_from, colvar%population_param%c_kinds_from) NULLIFY(colvar%population_param%i_at_to, colvar%population_param%c_kinds_to) ! This section can be repeated - CALL section_vals_val_get(population_section,"ATOMS_FROM",n_rep_val=n_var,error=error) + CALL section_vals_val_get(population_section,"ATOMS_FROM",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(population_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(population_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%population_param%i_at_from,1, ndim+SIZE(iatms)) colvar%population_param%i_at_from(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -723,10 +708,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%population_param%use_kinds_from = .FALSE. ELSE ! KINDS - CALL section_vals_val_get(population_section,"KINDS_FROM",n_rep_val=n_var,error=error) - CPPostcondition(n_var>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(population_section,"KINDS_FROM",n_rep_val=n_var) + CPPostcondition(n_var>0,cp_failure_level,routinep,failure) DO k = 1, n_var - CALL section_vals_val_get(population_section,"KINDS_FROM",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(population_section,"KINDS_FROM",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%population_param%c_kinds_from,1, ndim+SIZE(c_kinds)) colvar%population_param%c_kinds_from(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -739,12 +724,12 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END DO END IF ! This section can be repeated - CALL section_vals_val_get(population_section,"ATOMS_TO",n_rep_val=n_var,error=error) + CALL section_vals_val_get(population_section,"ATOMS_TO",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(population_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(population_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%population_param%i_at_to,1, ndim+SIZE(iatms)) colvar%population_param%i_at_to(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -753,10 +738,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%population_param%use_kinds_to = .FALSE. ELSE ! KINDS - CALL section_vals_val_get(population_section,"KINDS_TO",n_rep_val=n_var,error=error) - CPPostcondition(n_var>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(population_section,"KINDS_TO",n_rep_val=n_var) + CPPostcondition(n_var>0,cp_failure_level,routinep,failure) DO k = 1, n_var - CALL section_vals_val_get(population_section,"KINDS_TO",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(population_section,"KINDS_TO",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%population_param%c_kinds_to,1, ndim+SIZE(c_kinds)) colvar%population_param%c_kinds_to(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -769,62 +754,62 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END DO END IF ! Let's finish reading the other parameters - CALL section_vals_val_get(population_section,"R0",r_val=colvar%population_param%r_0,error=error) - CALL section_vals_val_get(population_section,"NN",i_val=colvar%population_param%nncrd,error=error) - CALL section_vals_val_get(population_section,"ND",i_val=colvar%population_param%ndcrd,error=error) - CALL section_vals_val_get(population_section,"N0",i_val=colvar%population_param%n0,error=error) - CALL section_vals_val_get(population_section,"SIGMA",r_val=colvar%population_param%sigma,error=error) + CALL section_vals_val_get(population_section,"R0",r_val=colvar%population_param%r_0) + CALL section_vals_val_get(population_section,"NN",i_val=colvar%population_param%nncrd) + CALL section_vals_val_get(population_section,"ND",i_val=colvar%population_param%ndcrd) + CALL section_vals_val_get(population_section,"N0",i_val=colvar%population_param%n0) + CALL section_vals_val_get(population_section,"SIGMA",r_val=colvar%population_param%sigma) ELSE IF (my_subsection(13)) THEN ! Angle between two planes wrk_section => plane_plane_angle_section - CALL colvar_create(colvar, plane_plane_angle_colvar_id, error) - CALL colvar_check_points(colvar, plane_plane_angle_section, error) + CALL colvar_create(colvar, plane_plane_angle_colvar_id) + CALL colvar_check_points(colvar, plane_plane_angle_section) ! Read the specification of the two planes - plane_sections => section_vals_get_subs_vals(plane_plane_angle_section,"PLANE",error=error) - CALL section_vals_get(plane_sections, n_repetition=n_var, error=error) + plane_sections => section_vals_get_subs_vals(plane_plane_angle_section,"PLANE") + CALL section_vals_get(plane_sections, n_repetition=n_var) CALL cp_assert(n_var==2,cp_fatal_level,cp_assertion_failed,routineP,& "PLANE_PLANE_ANGLE Colvar section: Two PLANE sections must be provided!"//& CPSourceFileRef) ! Plane 1 CALL section_vals_val_get(plane_sections,"DEF_TYPE",i_rep_section=1,& - i_val=colvar%plane_plane_angle_param%plane1%type_of_def,error=error) + i_val=colvar%plane_plane_angle_param%plane1%type_of_def) IF (colvar%plane_plane_angle_param%plane1%type_of_def==plane_def_vec) THEN CALL section_vals_val_get(plane_sections,"NORMAL_VECTOR",i_rep_section=1,& - r_vals=s1,error=error) + r_vals=s1) colvar%plane_plane_angle_param%plane1%normal_vec = s1 ELSE CALL section_vals_val_get(plane_sections,"ATOMS",i_rep_section=1,& - i_vals=iatms,error=error) + i_vals=iatms) colvar%plane_plane_angle_param%plane1%points = iatms END IF ! Plane 2 CALL section_vals_val_get(plane_sections,"DEF_TYPE",i_rep_section=2,& - i_val=colvar%plane_plane_angle_param%plane2%type_of_def,error=error) + i_val=colvar%plane_plane_angle_param%plane2%type_of_def) IF (colvar%plane_plane_angle_param%plane2%type_of_def==plane_def_vec) THEN CALL section_vals_val_get(plane_sections,"NORMAL_VECTOR",i_rep_section=2,& - r_vals=s1,error=error) + r_vals=s1) colvar%plane_plane_angle_param%plane2%normal_vec = s1 ELSE CALL section_vals_val_get(plane_sections,"ATOMS",i_rep_section=2,& - i_vals=iatms,error=error) + i_vals=iatms) colvar%plane_plane_angle_param%plane2%points = iatms END IF ELSE IF (my_subsection(14)) THEN ! Gyration Radius wrk_section => gyration_section - CALL colvar_create(colvar, gyration_colvar_id, error) - CALL colvar_check_points(colvar, gyration_section, error) + CALL colvar_create(colvar, gyration_colvar_id) + CALL colvar_check_points(colvar, gyration_section) NULLIFY(colvar%gyration_param%i_at, colvar%gyration_param%c_kinds) ! This section can be repeated - CALL section_vals_val_get(gyration_section,"ATOMS",n_rep_val=n_var,error=error) + CALL section_vals_val_get(gyration_section,"ATOMS",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(gyration_section,"ATOMS",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(gyration_section,"ATOMS",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%gyration_param%i_at,1, ndim+SIZE(iatms)) colvar%gyration_param%i_at(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -833,10 +818,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%gyration_param%use_kinds = .FALSE. ELSE ! KINDS - CALL section_vals_val_get(gyration_section,"KINDS",n_rep_val=n_var,error=error) - CPPostcondition(n_var>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(gyration_section,"KINDS",n_rep_val=n_var) + CPPostcondition(n_var>0,cp_failure_level,routinep,failure) DO k = 1, n_var - CALL section_vals_val_get(gyration_section,"KINDS",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(gyration_section,"KINDS",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%gyration_param%c_kinds,1, ndim+SIZE(c_kinds)) colvar%gyration_param%c_kinds(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -851,38 +836,38 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) ELSE IF (my_subsection(15)) THEN ! RMSD_AB wrk_section => rmsd_section - CALL colvar_create(colvar, rmsd_colvar_id, error) + CALL colvar_create(colvar, rmsd_colvar_id) NULLIFY(colvar%rmsd_param%i_rmsd, colvar%rmsd_param%r_ref, colvar%rmsd_param%weights) - frame_section => section_vals_get_subs_vals(rmsd_section,"FRAME",error=error) - CALL section_vals_get(frame_section,n_repetition=nr_frame,error=error) + frame_section => section_vals_get_subs_vals(rmsd_section,"FRAME") + CALL section_vals_get(frame_section,n_repetition=nr_frame) colvar%rmsd_param%nr_frames=nr_frame ! Calculation is aborted if reference frame are less than 2 - CPPostcondition((nr_frame>=1.AND.nr_frame<=2),cp_failure_level,routineP,error,failure) + CPPostcondition((nr_frame>=1.AND.nr_frame<=2),cp_failure_level,routineP,failure) CALL read_frames(frame_section,para_env,nr_frame,colvar%rmsd_param%r_ref,& - colvar%rmsd_param%n_atoms,error=error) + colvar%rmsd_param%n_atoms) ALLOCATE(colvar%rmsd_param%weights(colvar%rmsd_param%n_atoms), STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) colvar%rmsd_param%weights = 0.0_dp - CALL section_vals_val_get(rmsd_section,"SUBSET_TYPE",i_val=colvar%rmsd_param%subset,error=error) + CALL section_vals_val_get(rmsd_section,"SUBSET_TYPE",i_val=colvar%rmsd_param%subset) IF (colvar%rmsd_param%subset==rmsd_all) THEN ALLOCATE(colvar%rmsd_param%i_rmsd(colvar%rmsd_param%n_atoms),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i = 1, colvar%rmsd_param%n_atoms colvar%rmsd_param%i_rmsd(i) = i END DO ELSE IF (colvar%rmsd_param%subset==rmsd_list) THEN ! This section can be repeated - CALL section_vals_val_get(rmsd_section,"ATOMS",n_rep_val=n_var,error=error) + CALL section_vals_val_get(rmsd_section,"ATOMS",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(rmsd_section,"ATOMS",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(rmsd_section,"ATOMS",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%rmsd_param%i_rmsd,1, ndim+SIZE(iatms)) colvar%rmsd_param%i_rmsd(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -894,12 +879,12 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) CPSourceFileRef) END IF ELSE IF (colvar%rmsd_param%subset==rmsd_weightlist) THEN - CALL section_vals_val_get(rmsd_section,"ATOMS",n_rep_val=n_var,error=error) + CALL section_vals_val_get(rmsd_section,"ATOMS",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(rmsd_section,"ATOMS",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(rmsd_section,"ATOMS",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%rmsd_param%i_rmsd,1, ndim+SIZE(iatms)) colvar%rmsd_param%i_rmsd(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -910,12 +895,12 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) "CV RMSD: if SUBSET_TYPE=WEIGHT_LIST a list of atoms needs to be provided "//& CPSourceFileRef) END IF - CALL section_vals_val_get(rmsd_section,"WEIGHTS",n_rep_val=n_var,error=error) + CALL section_vals_val_get(rmsd_section,"WEIGHTS",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(rmsd_section,"WEIGHTS",i_rep_val=k,r_vals=wei,error=error) + CALL section_vals_val_get(rmsd_section,"WEIGHTS",i_rep_val=k,r_vals=wei) CALL reallocate(weights,1, ndim+SIZE(wei)) weights(ndim+1:ndim+SIZE(wei)) = wei ndim = ndim + SIZE(wei) @@ -928,7 +913,7 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%rmsd_param%weights(ii) = weights(i) END DO DEALLOCATE (weights, STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ELSE CALL cp_assert(.FALSE.,cp_fatal_level,cp_assertion_failed,routineP,& "CV RMSD: if SUBSET_TYPE=WEIGHT_LIST a list of weights need to be provided. "//& @@ -941,75 +926,74 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) CPSourceFileRef) END IF - CALL section_vals_val_get(rmsd_section,"ALIGN_FRAMES",l_val=colvar%rmsd_param%align_frames,& - error=error) + CALL section_vals_val_get(rmsd_section,"ALIGN_FRAMES",l_val=colvar%rmsd_param%align_frames) ELSE IF (my_subsection(17)) THEN ! Work on XYZ positions of atoms wrk_section => xyz_diag_section - CALL colvar_create(colvar, xyz_diag_colvar_id, error) - CALL colvar_check_points(colvar, wrk_section, error) - CALL section_vals_val_get(wrk_section,"ATOM",i_val=iatm,error=error) - CALL section_vals_val_get(wrk_section,"COMPONENT",i_val=icomponent,error=error) - CALL section_vals_val_get(wrk_section,"PBC",l_val=colvar%xyz_diag_param%use_pbc,error=error) - CALL section_vals_val_get(wrk_section,"ABSOLUTE_POSITION",l_val=colvar%xyz_diag_param%use_absolute_position,error=error) + CALL colvar_create(colvar, xyz_diag_colvar_id) + CALL colvar_check_points(colvar, wrk_section) + CALL section_vals_val_get(wrk_section,"ATOM",i_val=iatm) + CALL section_vals_val_get(wrk_section,"COMPONENT",i_val=icomponent) + CALL section_vals_val_get(wrk_section,"PBC",l_val=colvar%xyz_diag_param%use_pbc) + CALL section_vals_val_get(wrk_section,"ABSOLUTE_POSITION",l_val=colvar%xyz_diag_param%use_absolute_position) colvar%xyz_diag_param%i_atom = iatm colvar%xyz_diag_param%component = icomponent ELSE IF (my_subsection(18)) THEN ! Work on the outer diagonal (two atoms A,B) XYZ positions wrk_section => xyz_outerdiag_section - CALL colvar_create(colvar, xyz_outerdiag_colvar_id, error) - CALL colvar_check_points(colvar, wrk_section, error) - CALL section_vals_val_get(wrk_section,"ATOMS",i_vals=iatms,error=error) + CALL colvar_create(colvar, xyz_outerdiag_colvar_id) + CALL colvar_check_points(colvar, wrk_section) + CALL section_vals_val_get(wrk_section,"ATOMS",i_vals=iatms) colvar%xyz_outerdiag_param%i_atoms = iatms - CALL section_vals_val_get(wrk_section,"COMPONENT_A",i_val=icomponent,error=error) + CALL section_vals_val_get(wrk_section,"COMPONENT_A",i_val=icomponent) colvar%xyz_outerdiag_param%components(1) = icomponent - CALL section_vals_val_get(wrk_section,"COMPONENT_B",i_val=icomponent,error=error) + CALL section_vals_val_get(wrk_section,"COMPONENT_B",i_val=icomponent) colvar%xyz_outerdiag_param%components(2) = icomponent - CALL section_vals_val_get(wrk_section,"PBC",l_val=colvar%xyz_outerdiag_param%use_pbc,error=error) + CALL section_vals_val_get(wrk_section,"PBC",l_val=colvar%xyz_outerdiag_param%use_pbc) ELSE IF (my_subsection(19)) THEN ! Energy wrk_section => u_section - CALL colvar_create(colvar, u_colvar_id, error) - colvar%u_param%mixed_energy_section => section_vals_get_subs_vals(wrk_section,"MIXED",error=error) - CALL section_vals_get(colvar%u_param%mixed_energy_section,explicit=use_mixed_energy,error=error) + CALL colvar_create(colvar, u_colvar_id) + colvar%u_param%mixed_energy_section => section_vals_get_subs_vals(wrk_section,"MIXED") + CALL section_vals_get(colvar%u_param%mixed_energy_section,explicit=use_mixed_energy) IF (.NOT.use_mixed_energy) NULLIFY(colvar%u_param%mixed_energy_section) ELSE IF (my_subsection(20)) THEN ! Wc hydrogen bond wrk_section => Wc_section - CALL colvar_create(colvar, Wc_colvar_id, error) - CALL colvar_check_points(colvar, Wc_section, error) - CALL section_vals_val_get(Wc_section,"ATOMS",i_vals=iatms,error=error) - CALL section_vals_val_get(wrk_section,"RCUT",r_val=my_val(1),error=error) - colvar%Wc%rcut = cp_unit_to_cp2k(my_val(1),"angstrom",error=error) + CALL colvar_create(colvar, Wc_colvar_id) + CALL colvar_check_points(colvar, Wc_section) + CALL section_vals_val_get(Wc_section,"ATOMS",i_vals=iatms) + CALL section_vals_val_get(wrk_section,"RCUT",r_val=my_val(1)) + colvar%Wc%rcut = cp_unit_to_cp2k(my_val(1),"angstrom") colvar%Wc%ids = iatms ELSE IF (my_subsection(21)) THEN ! HBP colvar wrk_section => HBP_section - CALL colvar_create(colvar, HBP_colvar_id, error) - CALL colvar_check_points(colvar, HBP_section, error) - CALL section_vals_val_get(wrk_section,"NPOINTS",i_val=colvar%HBP%nPoints,error=error) - CALL section_vals_val_get(wrk_section,"RCUT",r_val=my_val(1),error=error) - colvar%HBP%rcut = cp_unit_to_cp2k(my_val(1),"angstrom",error=error) - CALL section_vals_val_get(wrk_section,"RCUT",r_val=colvar%HBP%shift,error=error) + CALL colvar_create(colvar, HBP_colvar_id) + CALL colvar_check_points(colvar, HBP_section) + CALL section_vals_val_get(wrk_section,"NPOINTS",i_val=colvar%HBP%nPoints) + CALL section_vals_val_get(wrk_section,"RCUT",r_val=my_val(1)) + colvar%HBP%rcut = cp_unit_to_cp2k(my_val(1),"angstrom") + CALL section_vals_val_get(wrk_section,"RCUT",r_val=colvar%HBP%shift) ALLOCATE(colvar%HBP%ids(colvar%HBP%nPoints,3),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(colvar%HBP%ewc(colvar%HBP%nPoints),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i = 1, colvar%HBP%nPoints - CALL section_vals_val_get(wrk_section,"ATOMS",i_rep_val=i,i_vals=iatms,error=error) + CALL section_vals_val_get(wrk_section,"ATOMS",i_rep_val=i,i_vals=iatms) colvar%HBP%ids(i,:) = iatms ENDDO ELSE IF (my_subsection(22)) THEN ! Ring Puckering - CALL colvar_create(colvar,ring_puckering_colvar_id, error) - CALL section_vals_val_get(ring_puckering_section,"ATOMS",i_vals=iatms,error=error) + CALL colvar_create(colvar,ring_puckering_colvar_id) + CALL section_vals_val_get(ring_puckering_section,"ATOMS",i_vals=iatms) colvar%ring_puckering_param%nring = SIZE(iatms) ALLOCATE(colvar%ring_puckering_param%atoms(SIZE(iatms)),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) colvar%ring_puckering_param%atoms = iatms CALL section_vals_val_get(ring_puckering_section,"COORDINATE",& - i_val=colvar%ring_puckering_param%iq,error=error) + i_val=colvar%ring_puckering_param%iq) ! test the validity of the parameters ndim = colvar%ring_puckering_param%nring CALL cp_assert(ndim > 3,cp_fatal_level,cp_assertion_failed,routineP,& @@ -1023,21 +1007,21 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) ELSE IF (my_subsection(23)) THEN ! Minimum Distance wrk_section => mindist_section - CALL colvar_create(colvar, mindist_colvar_id, error) - CALL colvar_check_points(colvar, mindist_section, error) + CALL colvar_create(colvar, mindist_colvar_id) + CALL colvar_check_points(colvar, mindist_section) NULLIFY(colvar%mindist_param%i_dist_from,colvar%mindist_param%i_coord_from,& colvar%mindist_param%k_coord_from,colvar%mindist_param%i_coord_to,& colvar%mindist_param%k_coord_to) - CALL section_vals_val_get(mindist_section,"ATOMS_DISTANCE",i_vals=iatms,error=error) + CALL section_vals_val_get(mindist_section,"ATOMS_DISTANCE",i_vals=iatms) colvar%mindist_param%n_dist_from = SIZE(iatms) ALLOCATE(colvar%mindist_param%i_dist_from(SIZE(iatms)),stat=stat) colvar%mindist_param%i_dist_from = iatms - CALL section_vals_val_get(mindist_section,"ATOMS_FROM",n_rep_val=n_var,error=error) + CALL section_vals_val_get(mindist_section,"ATOMS_FROM",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(mindist_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(mindist_section,"ATOMS_FROM",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%mindist_param%i_coord_from,1, ndim+SIZE(iatms)) colvar%mindist_param%i_coord_from(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -1046,10 +1030,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%mindist_param%use_kinds_from = .FALSE. ELSE !KINDS - CALL section_vals_val_get(mindist_section,"KINDS_FROM",n_rep_val=n_var,error=error) - CPPostcondition(n_var>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(mindist_section,"KINDS_FROM",n_rep_val=n_var) + CPPostcondition(n_var>0,cp_failure_level,routinep,failure) DO k = 1, n_var - CALL section_vals_val_get(mindist_section,"KINDS_FROM",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(mindist_section,"KINDS_FROM",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%mindist_param%k_coord_from,1, ndim+SIZE(c_kinds)) colvar%mindist_param%k_coord_from(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -1063,12 +1047,12 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END IF - CALL section_vals_val_get(mindist_section,"ATOMS_TO",n_rep_val=n_var,error=error) + CALL section_vals_val_get(mindist_section,"ATOMS_TO",n_rep_val=n_var) ndim = 0 IF (n_var /= 0) THEN ! INDEX LIST DO k = 1, n_var - CALL section_vals_val_get(mindist_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms,error=error) + CALL section_vals_val_get(mindist_section,"ATOMS_TO",i_rep_val=k,i_vals=iatms) CALL reallocate(colvar%mindist_param%i_coord_to,1, ndim+SIZE(iatms)) colvar%mindist_param%i_coord_to(ndim+1:ndim+SIZE(iatms)) = iatms ndim = ndim + SIZE(iatms) @@ -1077,10 +1061,10 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) colvar%mindist_param%use_kinds_to = .FALSE. ELSE !KINDS - CALL section_vals_val_get(mindist_section,"KINDS_TO",n_rep_val=n_var,error=error) - CPPostcondition(n_var>0,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get(mindist_section,"KINDS_TO",n_rep_val=n_var) + CPPostcondition(n_var>0,cp_failure_level,routinep,failure) DO k = 1, n_var - CALL section_vals_val_get(mindist_section,"KINDS_TO",i_rep_val=k,c_vals=c_kinds,error=error) + CALL section_vals_val_get(mindist_section,"KINDS_TO",i_rep_val=k,c_vals=c_kinds) CALL reallocate(colvar%mindist_param%k_coord_to,1, ndim+SIZE(c_kinds)) colvar%mindist_param%k_coord_to(ndim+1:ndim+SIZE(c_kinds)) = c_kinds ndim = ndim + SIZE(c_kinds) @@ -1093,16 +1077,16 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END DO END IF - CALL section_vals_val_get(mindist_section,"R0",r_val=colvar%mindist_param%r_cut,error=error) - CALL section_vals_val_get(mindist_section,"NN",i_val=colvar%mindist_param%p_exp,error=error) - CALL section_vals_val_get(mindist_section,"ND",i_val=colvar%mindist_param%q_exp,error=error) -! CALL section_vals_val_get(mindist_section,"NC",r_val=colvar%mindist_param%n_cut,error=error) - CALL section_vals_val_get(mindist_section,"LAMBDA",r_val=colvar%mindist_param%lambda,error=error) + CALL section_vals_val_get(mindist_section,"R0",r_val=colvar%mindist_param%r_cut) + CALL section_vals_val_get(mindist_section,"NN",i_val=colvar%mindist_param%p_exp) + CALL section_vals_val_get(mindist_section,"ND",i_val=colvar%mindist_param%q_exp) +! CALL section_vals_val_get(mindist_section,"NC",r_val=colvar%mindist_param%n_cut) + CALL section_vals_val_get(mindist_section,"LAMBDA",r_val=colvar%mindist_param%lambda) END IF - CALL colvar_setup(colvar, error) + CALL colvar_setup(colvar) iw = cp_print_key_unit_nr(logger,colvar_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".colvarLog",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".colvarLog") IF (iw>0) THEN tag = "ATOMS: " IF (colvar%use_points) tag = "POINTS:" @@ -1260,39 +1244,39 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) CASE(reaction_path_colvar_id) CALL cp_unimplemented_error(fromWhere=routineP, & message="Description header for REACTION_PATH COLVAR missing!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) CASE(distance_from_path_colvar_id) CALL cp_unimplemented_error(fromWhere=routineP, & message="Description header for REACTION_PATH COLVAR missing!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) CASE(hydronium_colvar_id) CALL cp_unimplemented_error(fromWhere=routineP, & message="Description header for HYDRONIUM COLVAR missing!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) CASE(rmsd_colvar_id) CALL cp_unimplemented_error(fromWhere=routineP, & message="Description header for RMSD COLVAR missing!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) CASE(xyz_diag_colvar_id) NULLIFY(section, keyword, enum) - CALL create_colvar_xyz_d_section(section,error=error) - keyword => section_get_keyword(section,"COMPONENT",error=error) - CALL keyword_get(keyword,enum=enum,error=error) - tag_comp = enum_i2c(enum,colvar%xyz_diag_param%component,error=error) - CALL section_release(section,error=error) + CALL create_colvar_xyz_d_section(section) + keyword => section_get_keyword(section,"COMPONENT") + CALL keyword_get(keyword,enum=enum) + tag_comp = enum_i2c(enum,colvar%xyz_diag_param%component) + CALL section_release(section) WRITE ( iw, '( A,T57,3I8)' ) ' COLVARS| POSITION ('//TRIM(tag_comp)& //') >>> '//tag,colvar%xyz_diag_param%i_atom CASE(xyz_outerdiag_colvar_id) NULLIFY(section, keyword, enum) - CALL create_colvar_xyz_od_section(section,error=error) - keyword => section_get_keyword(section,"COMPONENT_A",error=error) - CALL keyword_get(keyword,enum=enum,error=error) - tag_comp1 = enum_i2c(enum,colvar%xyz_outerdiag_param%components(1),error=error) - keyword => section_get_keyword(section,"COMPONENT_B",error=error) - CALL keyword_get(keyword,enum=enum,error=error) - tag_comp2 = enum_i2c(enum,colvar%xyz_outerdiag_param%components(2),error=error) - CALL section_release(section,error=error) + CALL create_colvar_xyz_od_section(section) + keyword => section_get_keyword(section,"COMPONENT_A") + CALL keyword_get(keyword,enum=enum) + tag_comp1 = enum_i2c(enum,colvar%xyz_outerdiag_param%components(1)) + keyword => section_get_keyword(section,"COMPONENT_B") + CALL keyword_get(keyword,enum=enum) + tag_comp2 = enum_i2c(enum,colvar%xyz_outerdiag_param%components(2)) + CALL section_release(section) WRITE ( iw, '( A,T57,3I8)' ) ' COLVARS| CROSS TERM POSITION ('//TRIM(tag_comp1)& //" * "//TRIM(tag_comp2)//') >>> '//tag, colvar%xyz_outerdiag_param%i_atoms @@ -1361,8 +1345,8 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) IF (colvar%use_points) THEN WRITE ( iw, '( A)') ' COLVARS| INFORMATION ON DEFINED GEOMETRICAL POINTS' DO kk = 1, SIZE(colvar%points) - point_section => section_vals_get_subs_vals(wrk_section,"POINT",error=error) - CALL section_vals_val_get(point_section,"TYPE",i_rep_section=kk,c_val=tmpStr,error=error) + point_section => section_vals_get_subs_vals(wrk_section,"POINT") + CALL section_vals_val_get(point_section,"TYPE",i_rep_section=kk,c_val=tmpStr) tmpStr2 = cp_to_string(kk) WRITE ( iw, '( A)') ' COLVARS| POINT Nr.'//TRIM(tmpStr2)//' OF TYPE: '//TRIM(tmpStr) IF (ASSOCIATED(colvar%points(kk)%atoms)) THEN @@ -1383,7 +1367,7 @@ RECURSIVE SUBROUTINE colvar_read(colvar, icol, colvar_section, para_env, error) END IF END IF CALL cp_print_key_finished_output(iw,logger,colvar_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE colvar_read @@ -1391,14 +1375,11 @@ END SUBROUTINE colvar_read !> \brief Check and setup about the use of geometrical points instead of atoms !> \param colvar the colvat to initialize !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino, [teo] 03.2007 ! ***************************************************************************** - SUBROUTINE colvar_check_points(colvar, section, error) + SUBROUTINE colvar_check_points(colvar, section) TYPE(colvar_type), POINTER :: colvar TYPE(section_vals_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_check_points', & routineP = moduleN//':'//routineN @@ -1414,54 +1395,54 @@ SUBROUTINE colvar_check_points(colvar, section, error) NULLIFY(point_sections) NULLIFY(atoms) NULLIFY(weights) - CPPostcondition(ASSOCIATED(colvar),cp_warning_level,routineP,error,failure) - point_sections => section_vals_get_subs_vals(section,"POINT",error=error) - CALL section_vals_get(point_sections, explicit=explicit, error=error) + CPPostcondition(ASSOCIATED(colvar),cp_warning_level,routineP,failure) + point_sections => section_vals_get_subs_vals(section,"POINT") + CALL section_vals_get(point_sections, explicit=explicit) IF (explicit) THEN colvar%use_points = .TRUE. - CALL section_vals_get(point_sections,n_repetition=npoints,error=error) + CALL section_vals_get(point_sections,n_repetition=npoints) ALLOCATE(colvar%points(npoints),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Read points definition DO i = 1, npoints natoms = 0 nweights = 0 NULLIFY(colvar%points(i)%atoms) NULLIFY(colvar%points(i)%weights) - CALL section_vals_val_get(point_sections,"TYPE",i_rep_section=i,i_val=colvar%points(i)%type_id,error=error) + CALL section_vals_val_get(point_sections,"TYPE",i_rep_section=i,i_val=colvar%points(i)%type_id) SELECT CASE(colvar%points(i)%type_id) CASE(do_clv_geo_center) ! Define a point through a list of atoms.. - CALL section_vals_val_get(point_sections,"ATOMS",i_rep_section=i,n_rep_val=nrep,i_vals=atoms,error=error) + CALL section_vals_val_get(point_sections,"ATOMS",i_rep_section=i,n_rep_val=nrep,i_vals=atoms) DO irep=1,nrep - CALL section_vals_val_get(point_sections,"ATOMS",i_rep_section=i,i_rep_val=irep,i_vals=atoms,error=error) + CALL section_vals_val_get(point_sections,"ATOMS",i_rep_section=i,i_rep_val=irep,i_vals=atoms) natoms = natoms + SIZE(atoms) END DO ALLOCATE(colvar%points(i)%atoms(natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) natoms = 0 DO irep=1,nrep - CALL section_vals_val_get(point_sections,"ATOMS",i_rep_section=i,i_rep_val=irep,i_vals=atoms,error=error) + CALL section_vals_val_get(point_sections,"ATOMS",i_rep_section=i,i_rep_val=irep,i_vals=atoms) colvar%points(i)%atoms(natoms+1:) = atoms(:) natoms = natoms + SIZE(atoms) END DO ! Define weights of the list ALLOCATE(colvar%points(i)%weights(natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) colvar%points(i)%weights = 1.0_dp/REAL(natoms,KIND=dp) - CALL section_vals_val_get(point_sections,"WEIGHTS",i_rep_section=i,n_rep_val=nrep,error=error) + CALL section_vals_val_get(point_sections,"WEIGHTS",i_rep_section=i,n_rep_val=nrep) IF (nrep/=0) THEN DO irep=1,nrep CALL section_vals_val_get(point_sections,"WEIGHTS",i_rep_section=i,i_rep_val=irep,& - r_vals=weights,error=error) + r_vals=weights) colvar%points(i)%weights(nweights+1:) = weights(:) nweights = nweights + SIZE(weights) END DO - CPPostcondition(natoms==nweights,cp_failure_level,routineP,error,failure) + CPPostcondition(natoms==nweights,cp_failure_level,routineP,failure) END IF CASE(do_clv_fix_point ) ! Define the point as a fixed point in space.. - CALL section_vals_val_get(point_sections,"XYZ",i_rep_section=i,r_vals=r,error=error) + CALL section_vals_val_get(point_sections,"XYZ",i_rep_section=i,r_vals=r) colvar%points(i)%r = r END SELECT END DO @@ -1476,11 +1457,9 @@ END SUBROUTINE colvar_check_points !> \param particles ... !> \param pos ... !> \param fixd_list ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE colvar_eval_mol_f(colvar, cell, particles, pos, fixd_list, error) + SUBROUTINE colvar_eval_mol_f(colvar, cell, particles, pos, fixd_list) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(particle_type), DIMENSION(:), & @@ -1489,7 +1468,6 @@ SUBROUTINE colvar_eval_mol_f(colvar, cell, particles, pos, fixd_list, error) INTENT(IN), OPTIONAL :: pos TYPE(fixd_constraint_type), & DIMENSION(:), OPTIONAL, POINTER :: fixd_list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_eval_mol_f', & routineP = moduleN//':'//routineN @@ -1500,7 +1478,7 @@ SUBROUTINE colvar_eval_mol_f(colvar, cell, particles, pos, fixd_list, error) failure=.FALSE. colvar_ok=ASSOCIATED(colvar) - CPAssert(colvar_ok,cp_failure_level,routineP,error,failure) + CPAssert(colvar_ok,cp_failure_level,routineP,failure) IF (PRESENT(pos)) THEN DO i = 1, SIZE(colvar%i_atom) @@ -1512,56 +1490,56 @@ SUBROUTINE colvar_eval_mol_f(colvar, cell, particles, pos, fixd_list, error) colvar%dsdr=0.0_dp SELECT CASE(colvar%type_id) CASE (dist_colvar_id) - CALL dist_colvar(colvar,cell,particles=particles,error=error) + CALL dist_colvar(colvar,cell,particles=particles) CASE (coord_colvar_id) - CALL coord_colvar(colvar,cell,particles=particles, error=error) + CALL coord_colvar(colvar,cell,particles=particles) CASE (population_colvar_id) - CALL population_colvar(colvar,cell,particles=particles, error=error) + CALL population_colvar(colvar,cell,particles=particles) CASE (gyration_colvar_id) - CALL gyration_radius_colvar(colvar,cell,particles=particles, error=error) + CALL gyration_radius_colvar(colvar,cell,particles=particles) CASE (torsion_colvar_id) - CALL torsion_colvar(colvar, cell, particles=particles, error=error) + CALL torsion_colvar(colvar, cell, particles=particles) CASE (angle_colvar_id) - CALL angle_colvar(colvar, cell, particles=particles, error=error) + CALL angle_colvar(colvar, cell, particles=particles) CASE (dfunct_colvar_id) - CALL dfunct_colvar(colvar, cell, particles=particles, error=error) + CALL dfunct_colvar(colvar, cell, particles=particles) CASE (plane_distance_colvar_id) - CALL plane_distance_colvar(colvar,cell, particles=particles, error=error) + CALL plane_distance_colvar(colvar,cell, particles=particles) CASE (plane_plane_angle_colvar_id) - CALL plane_plane_angle_colvar(colvar,cell, particles=particles, error=error) + CALL plane_plane_angle_colvar(colvar,cell, particles=particles) CASE (rotation_colvar_id) - CALL rotation_colvar(colvar,cell, particles=particles, error=error) + CALL rotation_colvar(colvar,cell, particles=particles) CASE (qparm_colvar_id) - CALL qparm_colvar(colvar,cell, particles=particles, error=error) + CALL qparm_colvar(colvar,cell, particles=particles) CASE (hydronium_colvar_id) - CALL hydronium_colvar(colvar,cell,particles=particles, error=error) + CALL hydronium_colvar(colvar,cell,particles=particles) CASE(rmsd_colvar_id) - CALL rmsd_colvar(colvar,particles=particles,error=error) + CALL rmsd_colvar(colvar,particles=particles) CASE (reaction_path_colvar_id) - CALL reaction_path_colvar(colvar,cell,particles=particles, error=error) + CALL reaction_path_colvar(colvar,cell,particles=particles) CASE (distance_from_path_colvar_id) - CALL distance_from_path_colvar(colvar,cell,particles=particles, error=error) + CALL distance_from_path_colvar(colvar,cell,particles=particles) CASE (combine_colvar_id) - CALL combine_colvar(colvar,cell,particles=particles, error=error) + CALL combine_colvar(colvar,cell,particles=particles) CASE (xyz_diag_colvar_id) - CALL xyz_diag_colvar(colvar,cell,particles=particles, error=error) + CALL xyz_diag_colvar(colvar,cell,particles=particles) CASE (xyz_outerdiag_colvar_id) - CALL xyz_outerdiag_colvar(colvar,cell,particles=particles, error=error) + CALL xyz_outerdiag_colvar(colvar,cell,particles=particles) CASE (ring_puckering_colvar_id) - CALL ring_puckering_colvar(colvar,cell,particles=particles, error=error) + CALL ring_puckering_colvar(colvar,cell,particles=particles) CASE (mindist_colvar_id) - CALL mindist_colvar(colvar,cell,particles=particles, error=error) + CALL mindist_colvar(colvar,cell,particles=particles) CASE (u_colvar_id) CALL cp_unimplemented_error(fromWhere=routineP, & - message="need force_env!", error=error, error_level=cp_failure_level) + message="need force_env!",error_level=cp_failure_level) CASE (Wc_colvar_id) !!! FIXME this is rubbish at the moment as we have no force to be computed on this - CALL Wc_colvar(colvar, cell, particles=particles, error=error) + CALL Wc_colvar(colvar, cell, particles=particles) CASE (HBP_colvar_id) !!! FIXME this is rubbish at the moment as we have no force to be computed on this - CALL HBP_colvar(colvar, cell, particles=particles, error=error) + CALL HBP_colvar(colvar, cell, particles=particles) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Check for fixed atom constraints IF (PRESENT(fixd_list)) CALL check_fixed_atom_cns_colv(fixd_list, colvar) @@ -1572,17 +1550,14 @@ END SUBROUTINE colvar_eval_mol_f !> \brief evaluates the derivatives (dsdr) given and due to the given colvar !> \param icolvar the collective variable to evaluate !> \param force_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Alessandro Laio and fawzi !> \note !> The torsion that generally is defined without the continuity problem !> here (for free energy calculations) is defined only for (-pi,pi] ! ***************************************************************************** - SUBROUTINE colvar_eval_glob_f(icolvar,force_env,error) + SUBROUTINE colvar_eval_glob_f(icolvar,force_env) INTEGER :: icolvar TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_eval_glob_f', & routineP = moduleN//':'//routineN @@ -1595,62 +1570,62 @@ SUBROUTINE colvar_eval_glob_f(icolvar,force_env,error) failure=.FALSE. NULLIFY(subsys,cell,colvar,qs_env) - CALL force_env_get(force_env,subsys=subsys,cell=cell,qs_env=qs_env,error=error) + CALL force_env_get(force_env,subsys=subsys,cell=cell,qs_env=qs_env) colvar_ok=ASSOCIATED(subsys%colvar_p) - CPAssert(colvar_ok,cp_failure_level,routineP,error,failure) + CPAssert(colvar_ok,cp_failure_level,routineP,failure) colvar => subsys%colvar_p(icolvar)%colvar ! Initialize the content of the derivative colvar%dsdr=0.0_dp SELECT CASE(colvar%type_id) CASE (dist_colvar_id) - CALL dist_colvar(colvar,cell,subsys=subsys,error=error) + CALL dist_colvar(colvar,cell,subsys=subsys) CASE (coord_colvar_id) - CALL coord_colvar(colvar,cell,subsys=subsys, error=error) + CALL coord_colvar(colvar,cell,subsys=subsys) CASE (population_colvar_id) - CALL population_colvar(colvar,cell,subsys=subsys, error=error) + CALL population_colvar(colvar,cell,subsys=subsys) CASE (gyration_colvar_id) - CALL gyration_radius_colvar(colvar,cell,subsys=subsys, error=error) + CALL gyration_radius_colvar(colvar,cell,subsys=subsys) CASE (torsion_colvar_id) - CALL torsion_colvar(colvar,cell,subsys=subsys, no_riemann_sheet_op=.TRUE.,error=error) + CALL torsion_colvar(colvar,cell,subsys=subsys, no_riemann_sheet_op=.TRUE.) CASE (angle_colvar_id) - CALL angle_colvar(colvar,cell,subsys=subsys, error=error) + CALL angle_colvar(colvar,cell,subsys=subsys) CASE (dfunct_colvar_id) - CALL dfunct_colvar(colvar,cell,subsys=subsys, error=error) + CALL dfunct_colvar(colvar,cell,subsys=subsys) CASE (plane_distance_colvar_id) - CALL plane_distance_colvar(colvar,cell,subsys=subsys, error=error) + CALL plane_distance_colvar(colvar,cell,subsys=subsys) CASE (plane_plane_angle_colvar_id) - CALL plane_plane_angle_colvar(colvar,cell,subsys=subsys, error=error) + CALL plane_plane_angle_colvar(colvar,cell,subsys=subsys) CASE (rotation_colvar_id) - CALL rotation_colvar(colvar,cell,subsys=subsys, error=error) + CALL rotation_colvar(colvar,cell,subsys=subsys) CASE (qparm_colvar_id) - CALL qparm_colvar(colvar,cell,subsys=subsys, error=error) + CALL qparm_colvar(colvar,cell,subsys=subsys) CASE (hydronium_colvar_id) - CALL hydronium_colvar(colvar,cell,subsys=subsys, error=error) + CALL hydronium_colvar(colvar,cell,subsys=subsys) CASE(rmsd_colvar_id) - CALL rmsd_colvar(colvar,subsys=subsys,error=error) + CALL rmsd_colvar(colvar,subsys=subsys) CASE (reaction_path_colvar_id) - CALL reaction_path_colvar(colvar,cell,subsys=subsys, error=error) + CALL reaction_path_colvar(colvar,cell,subsys=subsys) CASE (distance_from_path_colvar_id) - CALL distance_from_path_colvar(colvar,cell, subsys=subsys, error=error) + CALL distance_from_path_colvar(colvar,cell, subsys=subsys) CASE (combine_colvar_id) - CALL combine_colvar(colvar,cell,subsys=subsys, error=error) + CALL combine_colvar(colvar,cell,subsys=subsys) CASE (xyz_diag_colvar_id) - CALL xyz_diag_colvar(colvar,cell,subsys=subsys, error=error) + CALL xyz_diag_colvar(colvar,cell,subsys=subsys) CASE (xyz_outerdiag_colvar_id) - CALL xyz_outerdiag_colvar(colvar,cell,subsys=subsys, error=error) + CALL xyz_outerdiag_colvar(colvar,cell,subsys=subsys) CASE (u_colvar_id) - CALL u_colvar(colvar,force_env=force_env,error=error) + CALL u_colvar(colvar,force_env=force_env) CASE (Wc_colvar_id) - CALL Wc_colvar(colvar,cell,subsys=subsys, qs_env=qs_env, error=error) + CALL Wc_colvar(colvar,cell,subsys=subsys, qs_env=qs_env) CASE (HBP_colvar_id) - CALL HBP_colvar(colvar,cell,subsys=subsys, qs_env=qs_env, error=error) + CALL HBP_colvar(colvar,cell,subsys=subsys, qs_env=qs_env) CASE (ring_puckering_colvar_id) - CALL ring_puckering_colvar(colvar,cell,subsys=subsys, error=error) + CALL ring_puckering_colvar(colvar,cell,subsys=subsys) CASE (mindist_colvar_id) - CALL mindist_colvar(colvar,cell,subsys=subsys , error=error) + CALL mindist_colvar(colvar,cell,subsys=subsys) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Check for fixed atom constraints CALL check_fixed_atom_cns_colv(subsys%gci%fixd_list,colvar) @@ -1662,16 +1637,13 @@ END SUBROUTINE colvar_eval_glob_f !> \param colvar the collective variable to evaluate !> \param cell ... !> \param particles ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author sfchiff ! ***************************************************************************** - SUBROUTINE colvar_recursive_eval(colvar,cell,particles,error) + SUBROUTINE colvar_recursive_eval(colvar,cell,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_recursive_eval', & routineP = moduleN//':'//routineN @@ -1684,50 +1656,50 @@ SUBROUTINE colvar_recursive_eval(colvar,cell,particles,error) colvar%dsdr=0.0_dp SELECT CASE(colvar%type_id) CASE (dist_colvar_id) - CALL dist_colvar(colvar,cell,particles=particles,error=error) + CALL dist_colvar(colvar,cell,particles=particles) CASE (coord_colvar_id) - CALL coord_colvar(colvar,cell,particles=particles, error=error) + CALL coord_colvar(colvar,cell,particles=particles) CASE (torsion_colvar_id) - CALL torsion_colvar(colvar, cell, particles=particles, error=error) + CALL torsion_colvar(colvar, cell, particles=particles) CASE (angle_colvar_id) - CALL angle_colvar(colvar, cell, particles=particles, error=error) + CALL angle_colvar(colvar, cell, particles=particles) CASE (dfunct_colvar_id) - CALL dfunct_colvar(colvar, cell, particles=particles, error=error) + CALL dfunct_colvar(colvar, cell, particles=particles) CASE (plane_distance_colvar_id) - CALL plane_distance_colvar(colvar,cell, particles=particles, error=error) + CALL plane_distance_colvar(colvar,cell, particles=particles) CASE (plane_plane_angle_colvar_id) - CALL plane_plane_angle_colvar(colvar,cell, particles=particles, error=error) + CALL plane_plane_angle_colvar(colvar,cell, particles=particles) CASE (rotation_colvar_id) - CALL rotation_colvar(colvar,cell, particles=particles, error=error) + CALL rotation_colvar(colvar,cell, particles=particles) CASE (qparm_colvar_id) - CALL qparm_colvar(colvar,cell, particles=particles, error=error) + CALL qparm_colvar(colvar,cell, particles=particles) CASE (hydronium_colvar_id) - CALL hydronium_colvar(colvar,cell,particles=particles, error=error) + CALL hydronium_colvar(colvar,cell,particles=particles) CASE(rmsd_colvar_id) - CALL rmsd_colvar(colvar,particles=particles,error=error) + CALL rmsd_colvar(colvar,particles=particles) CASE (reaction_path_colvar_id) - CALL reaction_path_colvar(colvar,cell,particles=particles, error=error) + CALL reaction_path_colvar(colvar,cell,particles=particles) CASE (distance_from_path_colvar_id) - CALL distance_from_path_colvar(colvar,cell,particles=particles, error=error) + CALL distance_from_path_colvar(colvar,cell,particles=particles) CASE (combine_colvar_id) - CALL combine_colvar(colvar,cell,particles=particles, error=error) + CALL combine_colvar(colvar,cell,particles=particles) CASE (xyz_diag_colvar_id) - CALL xyz_diag_colvar(colvar,cell,particles=particles, error=error) + CALL xyz_diag_colvar(colvar,cell,particles=particles) CASE (xyz_outerdiag_colvar_id) - CALL xyz_outerdiag_colvar(colvar,cell,particles=particles, error=error) + CALL xyz_outerdiag_colvar(colvar,cell,particles=particles) CASE (ring_puckering_colvar_id) - CALL ring_puckering_colvar(colvar,cell,particles=particles, error=error) + CALL ring_puckering_colvar(colvar,cell,particles=particles) CASE (mindist_colvar_id) - CALL mindist_colvar(colvar,cell,particles=particles, error=error) + CALL mindist_colvar(colvar,cell,particles=particles) CASE (u_colvar_id) CALL cp_unimplemented_error(fromWhere=routineP, & - message="need force_env!", error=error, error_level=cp_failure_level) + message="need force_env!",error_level=cp_failure_level) CASE (Wc_colvar_id) - CALL Wc_colvar(colvar, cell, particles=particles, error=error) + CALL Wc_colvar(colvar, cell, particles=particles) CASE (HBP_colvar_id) - CALL HBP_colvar(colvar, cell, particles=particles, error=error) + CALL HBP_colvar(colvar, cell, particles=particles) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE colvar_recursive_eval @@ -1804,16 +1776,14 @@ END SUBROUTINE put_derivative !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino 02.2010 [created] ! ***************************************************************************** - SUBROUTINE xyz_diag_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE xyz_diag_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xyz_diag_colvar', & routineP = moduleN//':'//routineN @@ -1829,12 +1799,12 @@ SUBROUTINE xyz_diag_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==xyz_diag_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==xyz_diag_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF i=colvar%xyz_diag_param%i_atom @@ -1901,7 +1871,7 @@ SUBROUTINE xyz_diag_colvar(colvar,cell,subsys,particles,error) xi(3)=1.0_dp CASE DEFAULT !Not implemented for anything which is not a single component. - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT fi(:)= xi ENDIF @@ -1917,16 +1887,14 @@ END SUBROUTINE xyz_diag_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino 02.2010 [created] ! ***************************************************************************** - SUBROUTINE xyz_outerdiag_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE xyz_outerdiag_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xyz_outerdiag_colvar', & routineP = moduleN//':'//routineN @@ -1942,12 +1910,12 @@ SUBROUTINE xyz_outerdiag_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==xyz_outerdiag_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==xyz_outerdiag_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF DO k = 1, 2 @@ -2006,15 +1974,13 @@ END SUBROUTINE xyz_outerdiag_colvar !> \brief evaluates the force due (and on) the energy as collective variable !> \param colvar ... !> \param force_env ... -!> \param error ... !> \par History Modified to allow functions of energy in a mixed_env environment !> Teodoro Laino [tlaino] - 02.2011 !> \author Sebastiano Caravati ! ***************************************************************************** - SUBROUTINE u_colvar(colvar,force_env,error) + SUBROUTINE u_colvar(colvar,force_env) TYPE(colvar_type), POINTER :: colvar TYPE(force_env_type), OPTIONAL, POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'u_colvar', & routineP = moduleN//':'//routineN @@ -2046,8 +2012,8 @@ SUBROUTINE u_colvar(colvar,force_env,error) failure = .FALSE. IF (PRESENT(force_env)) THEN NULLIFY(particles_main, subsys_main) - CALL force_env_get(force_env=force_env,subsys=subsys_main, error=error) - CALL cp_subsys_get(subsys=subsys_main, particles=particles_main,error=error) + CALL force_env_get(force_env=force_env,subsys=subsys_main) + CALL cp_subsys_get(subsys=subsys_main, particles=particles_main) natom = SIZE(particles_main%els) colvar%n_atom_s = natom colvar%u_param%natom = natom @@ -2058,7 +2024,7 @@ SUBROUTINE u_colvar(colvar,force_env,error) ENDDO IF (.NOT.ASSOCIATED(colvar%u_param%mixed_energy_section)) THEN - CALL force_env_get(force_env,potential_energy=potential_energy,error=error) + CALL force_env_get(force_env,potential_energy=potential_energy) colvar%ss = potential_energy DO iatom=1,natom @@ -2071,20 +2037,20 @@ SUBROUTINE u_colvar(colvar,force_env,error) 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& ' A combination of mixed force_eval energies has been requested as '//& ' collective variable, but the MIXED env is not in use! Aborting.',& - error=error,only_ionode=.TRUE.) - CALL force_env_get(force_env, force_env_section=force_env_section, error=error) - mapping_section => section_vals_get_subs_vals(force_env_section,"MIXED%MAPPING",error=error) + only_ionode=.TRUE.) + CALL force_env_get(force_env, force_env_section=force_env_section) + mapping_section => section_vals_get_subs_vals(force_env_section,"MIXED%MAPPING") NULLIFY(values, parameters, subsystems, particles, global_forces, map_index, glob_natoms) nforce_eval = SIZE(force_env%sub_force_env) ALLOCATE(glob_natoms(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(subsystems(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(particles(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Local Info to sync ALLOCATE(global_forces(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) glob_natoms=0 DO iforce_eval = 1, nforce_eval @@ -2092,10 +2058,10 @@ SUBROUTINE u_colvar(colvar,force_env,error) IF (.NOT.ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE ! Get all available subsys CALL force_env_get(force_env=force_env%sub_force_env(iforce_eval)%force_env,& - subsys=subsystems(iforce_eval)%subsys,error=error) + subsys=subsystems(iforce_eval)%subsys) ! Get available particles CALL cp_subsys_get(subsys=subsystems(iforce_eval)%subsys,& - particles=particles(iforce_eval)%list,error=error) + particles=particles(iforce_eval)%list) ! Get Mapping index array natom_iforce = SIZE(particles(iforce_eval)%list%els) @@ -2114,7 +2080,7 @@ SUBROUTINE u_colvar(colvar,force_env,error) ! Transfer forces DO iforce_eval = 1, nforce_eval ALLOCATE(global_forces(iforce_eval)%forces(3,glob_natoms(iforce_eval)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) global_forces(iforce_eval)%forces = 0.0_dp IF (ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) THEN IF ( force_env%sub_force_env(iforce_eval)%force_env%para_env%mepos==& @@ -2132,16 +2098,16 @@ SUBROUTINE u_colvar(colvar,force_env,error) wrk_section => colvar%u_param%mixed_energy_section ! Support any number of force_eval sections CALL get_generic_info(wrk_section, "ENERGY_FUNCTION", coupling_function, parameters,& - values, force_env%mixed_env%energies, error=error) + values, force_env%mixed_env%energies) CALL initf(1) CALL parsef(1,TRIM(coupling_function),parameters) ! Store the value of the COLVAR colvar%ss = evalf(1,values) - CPPrecondition(EvalErrType<=0,cp_failure_level,routineP,error,failure) + CPPrecondition(EvalErrType<=0,cp_failure_level,routineP,failure) DO iforce_eval = 1, nforce_eval - CALL section_vals_val_get(wrk_section,"DX",r_val=dx,error=error) - CALL section_vals_val_get(wrk_section,"ERROR_LIMIT",r_val=lerr,error=error) + CALL section_vals_val_get(wrk_section,"DX",r_val=dx) + CALL section_vals_val_get(wrk_section,"ERROR_LIMIT",r_val=lerr) dedf = evalfd(1,iforce_eval,values,dx,err) IF (ABS(err)>lerr) THEN WRITE(this_error,"(A,G12.6,A)")"(",err,")" @@ -2151,12 +2117,12 @@ SUBROUTINE u_colvar(colvar,force_env,error) CALL cp_assert(.FALSE.,cp_warning_level,-300,routineP,& 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& ' Error '//TRIM(this_error)//' in computing numerical derivatives larger then'//& - TRIM(def_error)//' .',error=error,only_ionode=.TRUE.) + TRIM(def_error)//' .',only_ionode=.TRUE.) END IF ! General Mapping of forces... ! First: Get Mapping index array CALL get_subsys_map_index(mapping_section, glob_natoms(iforce_eval), iforce_eval,& - nforce_eval, map_index, error) + nforce_eval, map_index) ! Second: store derivatives DO iparticle = 1, glob_natoms(iforce_eval) @@ -2167,30 +2133,30 @@ SUBROUTINE u_colvar(colvar,force_env,error) ! Deallocate map_index array IF (ASSOCIATED(map_index)) THEN DEALLOCATE(map_index, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL finalizef() DO iforce_eval = 1, nforce_eval DEALLOCATE(global_forces(iforce_eval)%forces,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(glob_natoms, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(values, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(parameters, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(global_forces, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(subsystems, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(particles, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ELSE CALL cp_unimplemented_error(fromWhere=routineP, & - message="need force_env!", error=error, error_level=cp_failure_level) + message="need force_env!",error_level=cp_failure_level) ENDIF END SUBROUTINE u_colvar @@ -2200,17 +2166,15 @@ END SUBROUTINE u_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino 02.2006 [created] ! ***************************************************************************** - SUBROUTINE plane_distance_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE plane_distance_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'plane_distance_colvar', & routineP = moduleN//':'//routineN @@ -2227,12 +2191,12 @@ SUBROUTINE plane_distance_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==plane_distance_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==plane_distance_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF i=colvar%plane_distance_param%plane(1) @@ -2323,17 +2287,15 @@ END SUBROUTINE plane_distance_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino 02.2009 [created] ! ***************************************************************************** - SUBROUTINE plane_plane_angle_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE plane_plane_angle_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'plane_plane_angle_colvar', & routineP = moduleN//':'//routineN @@ -2353,12 +2315,12 @@ SUBROUTINE plane_plane_angle_colvar(colvar,cell,subsys,particles,error) NULLIFY(particles_i) check = colvar%type_id==plane_plane_angle_colvar_id - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF @@ -2392,7 +2354,7 @@ SUBROUTINE plane_plane_angle_colvar(colvar,cell,subsys,particles,error) END IF a1 = DOT_PRODUCT(xpn1,xpn1) norm1 = SQRT(a1) - CPPrecondition(norm1/=0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(norm1/=0.0_dp,cp_failure_level,routineP,failure) ! Plane 2 IF (colvar%plane_plane_angle_param%plane2%type_of_def==plane_def_atoms) THEN @@ -2424,7 +2386,7 @@ SUBROUTINE plane_plane_angle_colvar(colvar,cell,subsys,particles,error) END IF a2 = DOT_PRODUCT(xpn2,xpn2) norm2 = SQRT(a2) - CPPrecondition(norm2/=0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(norm2/=0.0_dp,cp_failure_level,routineP,failure) ! The value of the angle is defined only between 0 and Pi prod_12 = DOT_PRODUCT(xpn1,xpn2) @@ -2550,16 +2512,14 @@ END SUBROUTINE plane_plane_angle_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino 02.2006 [created] ! ***************************************************************************** - SUBROUTINE rotation_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE rotation_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotation_colvar', & routineP = moduleN//':'//routineN @@ -2578,12 +2538,12 @@ SUBROUTINE rotation_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==rotation_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==rotation_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF i = colvar%rotation_param%i_at1_bond1 @@ -2641,17 +2601,15 @@ END SUBROUTINE rotation_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino 02.2006 [created] !> \note modified Florian Schiffmann 08.2008 ! ***************************************************************************** - SUBROUTINE dfunct_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE dfunct_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dfunct_colvar', & routineP = moduleN//':'//routineN @@ -2669,12 +2627,12 @@ SUBROUTINE dfunct_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==dfunct_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==dfunct_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF i=colvar%dfunct_param%i_at_dfunct(1) @@ -2722,16 +2680,14 @@ END SUBROUTINE dfunct_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino 02.2006 [created] ! ***************************************************************************** - SUBROUTINE angle_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE angle_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'angle_colvar', & routineP = moduleN//':'//routineN @@ -2749,12 +2705,12 @@ SUBROUTINE angle_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==angle_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==angle_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF i=colvar%angle_param%i_at_angle(1) @@ -2802,16 +2758,14 @@ END SUBROUTINE angle_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Alessandro Laio, Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE dist_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE dist_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dist_colvar', & routineP = moduleN//':'//routineN @@ -2827,12 +2781,12 @@ SUBROUTINE dist_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==dist_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==dist_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF i=colvar%dist_param%i_at @@ -2879,10 +2833,9 @@ END SUBROUTINE dist_colvar !> \param subsys ... !> \param particles ... !> \param no_riemann_sheet_op ... -!> \param error ... !> \author Alessandro Laio, Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE torsion_colvar(colvar,cell,subsys,particles,no_riemann_sheet_op,error) + SUBROUTINE torsion_colvar(colvar,cell,subsys,particles,no_riemann_sheet_op) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell @@ -2890,7 +2843,6 @@ SUBROUTINE torsion_colvar(colvar,cell,subsys,particles,no_riemann_sheet_op,error TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles LOGICAL, INTENT(IN), OPTIONAL :: no_riemann_sheet_op - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'torsion_colvar', & routineP = moduleN//':'//routineN @@ -2909,12 +2861,12 @@ SUBROUTINE torsion_colvar(colvar,cell,subsys,particles,no_riemann_sheet_op,error failure=.FALSE. NULLIFY(particles_i) - CPPrecondition(colvar%type_id==torsion_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==torsion_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF no_riemann_sheet = .FALSE. @@ -3045,15 +2997,13 @@ END SUBROUTINE torsion_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qparm_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE qparm_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qparm_colvar', & routineP = moduleN//':'//routineN @@ -3078,12 +3028,12 @@ SUBROUTINE qparm_colvar(colvar,cell,subsys,particles,error) l=colvar%qparm_param%l alpha=colvar%qparm_param%alpha NULLIFY(particles_i) - CPPrecondition(colvar%type_id==qparm_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==qparm_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF @@ -3188,19 +3138,16 @@ END SUBROUTINE qparm_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Marcel Baer !> \note This function needs to be extended to the POINT structure!! !> non-standard conform.. it's a breach in the colvar module. ! ***************************************************************************** - SUBROUTINE hydronium_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE hydronium_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'hydronium_colvar', & routineP = moduleN//':'//routineN @@ -3238,31 +3185,31 @@ SUBROUTINE hydronium_colvar(colvar,cell,subsys,particles,error) q=colvar%hydronium_param%q NULLIFY(particles_i) - CPPrecondition(colvar%type_id==hydronium_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==hydronium_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF ALLOCATE ( dfunc_nh ( 3, n_oxygens, n_hydrogens ), stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE ( nhcoord ( n_oxygens), stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE ( M ( n_oxygens ), stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE ( dM ( 3, n_oxygens,n_hydrogens ), stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE ( dfunc_no ( 3, n_oxygens, n_oxygens ), stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE ( no ( n_oxygens), stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE ( qloc ( n_oxygens), stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ! Zero Arrays: dfunc_nh = 0._dp @@ -3375,19 +3322,19 @@ SUBROUTINE hydronium_colvar(colvar,cell,subsys,particles,error) colvar%ss=LOG(qtot)/lambda DEALLOCATE ( dfunc_nh, stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE ( nhcoord, stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE ( M, stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE ( dM, stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE ( dfunc_no, stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE ( no, stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE ( qloc, stat=stat ) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE hydronium_colvar ! ***************************************************************************** @@ -3396,18 +3343,16 @@ END SUBROUTINE hydronium_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author MI !> \note When the third set of atoms is not defined, this variable is equivalent !> to the simple coordination number. ! ***************************************************************************** - SUBROUTINE coord_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE coord_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'coord_colvar', & routineP = moduleN//':'//routineN @@ -3430,12 +3375,12 @@ SUBROUTINE coord_colvar(colvar,cell,subsys,particles,error) ! If we defined the coordination number with KINDS then we have still ! to fill few missing informations... NULLIFY(particles_i) - CPPrecondition(colvar%type_id==coord_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==coord_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF n_atoms_to_a=colvar%coord_param%n_atoms_to @@ -3536,16 +3481,14 @@ END SUBROUTINE coord_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mindist_colvar(colvar,cell, subsys, particles, error) + SUBROUTINE mindist_colvar(colvar,cell, subsys, particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mindist_colvar', & routineP = moduleN//':'//routineN @@ -3567,12 +3510,12 @@ SUBROUTINE mindist_colvar(colvar,cell, subsys, particles, error) ! If we defined the coordination number with KINDS then we have still ! to fill few missing informations... NULLIFY(particles_i) - CPPrecondition(colvar%type_id==mindist_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==mindist_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF @@ -3587,17 +3530,17 @@ SUBROUTINE mindist_colvar(colvar,cell, subsys, particles, error) NULLIFY(nLcoord,dnLcoord,dqfunc_dr,dqfunc_dnL,expnL,sum_rij) ALLOCATE (nLcoord(n_coord_from),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE (dnLcoord(3,n_coord_from,n_coord_to),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE (expnL(n_coord_from),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE (sum_rij(n_coord_from),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE (dqfunc_dr(3,n_dist_from,n_coord_from),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE (dqfunc_dnL(n_coord_from),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ! coordination numbers nLcoord = 0.0_dp @@ -3706,17 +3649,17 @@ SUBROUTINE mindist_colvar(colvar,cell, subsys, particles, error) DEALLOCATE(nLcoord,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(dnLcoord,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE (expnL,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE (dqfunc_dr,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE (sum_rij,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE (dqfunc_dnL,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE mindist_colvar @@ -3726,16 +3669,14 @@ END SUBROUTINE mindist_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 12.2008 ! ***************************************************************************** - SUBROUTINE combine_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE combine_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'combine_colvar', & routineP = moduleN//':'//routineN @@ -3753,24 +3694,24 @@ SUBROUTINE combine_colvar(colvar,cell,subsys,particles,error) POINTER :: my_particles failure=.FALSE. - CPPrecondition(colvar%type_id==combine_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==combine_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF ncolv=SIZE(colvar%combine_cvs_param%colvar_p) ALLOCATE(ss_vals(ncolv),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(dss_vals(ncolv),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ! Evaluate the individual COLVARs DO i=1,ncolv - CALL colvar_recursive_eval(colvar%combine_cvs_param%colvar_p(i)%colvar,cell,my_particles,error) + CALL colvar_recursive_eval(colvar%combine_cvs_param%colvar_p(i)%colvar,cell,my_particles) ss_vals(i)=colvar%combine_cvs_param%colvar_p(i)%colvar%ss ENDDO @@ -3779,11 +3720,11 @@ SUBROUTINE combine_colvar(colvar,cell,subsys,particles,error) ndim = SIZE(colvar%combine_cvs_param%c_parameters)+& SIZE(colvar%combine_cvs_param%variables) ALLOCATE(my_par(ndim),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) my_par(1:SIZE(colvar%combine_cvs_param%variables)) =colvar%combine_cvs_param%variables my_par(SIZE(colvar%combine_cvs_param%variables)+1:)=colvar%combine_cvs_param%c_parameters ALLOCATE(my_val(ndim),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) my_val(1:SIZE(colvar%combine_cvs_param%variables)) =ss_vals my_val(SIZE(colvar%combine_cvs_param%variables)+1:)=colvar%combine_cvs_param%v_parameters CALL parsef(1,TRIM(colvar%combine_cvs_param%function),my_par) @@ -3804,14 +3745,14 @@ SUBROUTINE combine_colvar(colvar,cell,subsys,particles,error) END IF END DO DEALLOCATE(my_val,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(my_par,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) CALL finalizef() ! Evaluate forces ALLOCATE(fi(3,colvar%n_atom_s),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ii=0 DO i=1,ncolv DO j=1,colvar%combine_cvs_param%colvar_p(i)%colvar%n_atom_s @@ -3825,11 +3766,11 @@ SUBROUTINE combine_colvar(colvar,cell,subsys,particles,error) END DO DEALLOCATE(fi,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ss_vals,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(dss_vals,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE combine_colvar ! ***************************************************************************** @@ -3840,20 +3781,18 @@ END SUBROUTINE combine_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \par History !> extended MI 01.2010 !> \author fschiff !> \note the system is still able to move in the space spanned by the CV !> perpendicular to the path ! ***************************************************************************** - SUBROUTINE reaction_path_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE reaction_path_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reaction_path_colvar', & routineP = moduleN//':'//routineN @@ -3865,21 +3804,21 @@ SUBROUTINE reaction_path_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. - CPPrecondition(colvar%type_id==reaction_path_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==reaction_path_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF IF(colvar%reaction_path_param%dist_rmsd) THEN - CALL rpath_dist_rmsd(colvar,my_particles,error=error) + CALL rpath_dist_rmsd(colvar,my_particles) ELSEIF(colvar%reaction_path_param%rmsd) THEN - CALL rpath_rmsd(colvar,my_particles,error=error) + CALL rpath_rmsd(colvar,my_particles) ELSE - CALL rpath_colvar(colvar,cell,my_particles,error) + CALL rpath_colvar(colvar,cell,my_particles) END IF END SUBROUTINE reaction_path_colvar @@ -3891,15 +3830,13 @@ END SUBROUTINE reaction_path_colvar !> \param colvar ... !> \param cell ... !> \param particles ... -!> \param error ... !> \author fschiff ! ***************************************************************************** - SUBROUTINE rpath_colvar(colvar,cell,particles,error) + SUBROUTINE rpath_colvar(colvar,cell,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rpath_colvar', & routineP = moduleN//':'//routineN @@ -3921,25 +3858,25 @@ SUBROUTINE rpath_colvar(colvar,cell,particles,error) ncolv=colvar%reaction_path_param%n_components lambda=colvar%reaction_path_param%lambda ALLOCATE(f_vals(ncolv,istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) f_vals(:,:)=colvar%reaction_path_param%f_vals ALLOCATE(ss_vals(ncolv),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i=1,ncolv - CALL colvar_recursive_eval(colvar%reaction_path_param%colvar_p(i)%colvar,cell,particles,error) + CALL colvar_recursive_eval(colvar%reaction_path_param%colvar_p(i)%colvar,cell,particles) ss_vals(i)=colvar%reaction_path_param%colvar_p(i)%colvar%ss ENDDO ALLOCATE(s1v(2,istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1v(ncolv,2,istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(s1(2),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1(ncolv,2),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO k=istart,iend s1v(1,k)=REAL(k,kind=dp)*step_size*EXP(-lambda*DOT_PRODUCT(ss_vals(:)-f_vals(:,k),ss_vals(:)-f_vals(:,k))) @@ -3959,7 +3896,7 @@ SUBROUTINE rpath_colvar(colvar,cell,particles,error) colvar%ss=s1(1)/s1(2)/REAL(nconf-1,dp) ALLOCATE(fi(3,colvar%n_atom_s),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ii=0 DO i=1,ncolv @@ -3975,19 +3912,19 @@ SUBROUTINE rpath_colvar(colvar,cell,particles,error) END DO DEALLOCATE(fi,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(f_vals,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ss_vals,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1v,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1v,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE rpath_colvar @@ -3997,15 +3934,13 @@ END SUBROUTINE rpath_colvar !> configurations belonging to the given path. !> \param colvar ... !> \param particles ... -!> \param error ... !> \date 01.2010 !> \author MI ! ***************************************************************************** - SUBROUTINE rpath_dist_rmsd(colvar,particles,error) + SUBROUTINE rpath_dist_rmsd(colvar,particles) TYPE(colvar_type), POINTER :: colvar TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rpath_dist_rmsd', & routineP = moduleN//':'//routineN @@ -4035,21 +3970,21 @@ SUBROUTINE rpath_dist_rmsd(colvar,particles,error) natom = SIZE(particles) ALLOCATE(r0(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(r(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(riat(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(vec_dif(rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(dvec_dif(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(s1v(2,nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1v(3,rmsd_atom,2,nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1(3,rmsd_atom,2),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i = 1,natom ii = (i-1)*3 r0(ii+1) = particles(i)%r(1) @@ -4070,7 +4005,7 @@ SUBROUTINE rpath_dist_rmsd(colvar,particles,error) r(ii+3) = path_conf(ii+3,ik) END DO - CALL rmsd3(particles,r,r0,output_unit=-1,my_val=my_rmsd,rotate=.TRUE.,error=error) + CALL rmsd3(particles,r,r0,output_unit=-1,my_val=my_rmsd,rotate=.TRUE.) sum_exp = 0.0_dp DO iat = 1,rmsd_atom @@ -4108,7 +4043,7 @@ SUBROUTINE rpath_dist_rmsd(colvar,particles,error) colvar%ss = s1(1)/s1(2)/REAL(nconf-1,dp) ALLOCATE(fi(3,rmsd_atom),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO iat = 1,rmsd_atom fi(1,iat) = 2.0_dp*lambda/s1(2)/REAL(nconf-1,dp)*(ds1(1,iat,1) - ds1(1,iat,2)*s1(1)/s1(2)) @@ -4118,23 +4053,23 @@ SUBROUTINE rpath_dist_rmsd(colvar,particles,error) END DO DEALLOCATE(fi,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r0,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(riat,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(vec_dif,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(dvec_dif,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE rpath_dist_rmsd @@ -4143,13 +4078,11 @@ END SUBROUTINE rpath_dist_rmsd !> \brief ... !> \param colvar ... !> \param particles ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rpath_rmsd(colvar,particles,error) + SUBROUTINE rpath_rmsd(colvar,particles) TYPE(colvar_type), POINTER :: colvar TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rpath_rmsd', & routineP = moduleN//':'//routineN @@ -4181,22 +4114,22 @@ SUBROUTINE rpath_rmsd(colvar,particles,error) natom = SIZE(particles) ALLOCATE(r0(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(r(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(riat(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(s1v(2,nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1v(3,rmsd_atom,2,nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1(3,rmsd_atom,2),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(drmsd(3,natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) drmsd = 0.0_dp ALLOCATE (weight(natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i = 1,natom ii = (i-1)*3 @@ -4227,7 +4160,7 @@ SUBROUTINE rpath_rmsd(colvar,particles,error) END DO CALL rmsd3(particles,r0,r,output_unit=-1,weights=weight,my_val=my_rmsd,& - rotate=.FALSE.,drmsd3=drmsd,error=error) + rotate=.FALSE.,drmsd3=drmsd) s1v(1,ik) = REAL(ik-1,dp)*EXP(-lambda*my_rmsd) s1v(2,ik) = EXP(-lambda*my_rmsd) @@ -4255,7 +4188,7 @@ SUBROUTINE rpath_rmsd(colvar,particles,error) colvar%ss = s1(1)/s1(2)/REAL(nconf-1,dp) ALLOCATE(fi(3,rmsd_atom),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO iat = 1,rmsd_atom fi(1,iat) = -lambda/s1(2)/REAL(nconf-1,dp)*(ds1(1,iat,1) - ds1(1,iat,2)*s1(1)/s1(2)) @@ -4265,23 +4198,23 @@ SUBROUTINE rpath_rmsd(colvar,particles,error) END DO DEALLOCATE(fi,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r0,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(riat,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(drmsd,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(weight,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE rpath_rmsd @@ -4292,17 +4225,15 @@ END SUBROUTINE rpath_rmsd !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \date 01.2010 !> \author MI ! ***************************************************************************** - SUBROUTINE distance_from_path_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE distance_from_path_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distance_from_path_colvar', & routineP = moduleN//':'//routineN @@ -4314,21 +4245,21 @@ SUBROUTINE distance_from_path_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. - CPPrecondition(colvar%type_id==distance_from_path_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==distance_from_path_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF IF(colvar%reaction_path_param%dist_rmsd) THEN - CALL dpath_dist_rmsd(colvar,my_particles,error=error) + CALL dpath_dist_rmsd(colvar,my_particles) ELSEIF(colvar%reaction_path_param%rmsd) THEN - CALL dpath_rmsd(colvar,my_particles,error=error) + CALL dpath_rmsd(colvar,my_particles) ELSE - CALL dpath_colvar(colvar,cell,my_particles,error=error) + CALL dpath_colvar(colvar,cell,my_particles) END IF END SUBROUTINE distance_from_path_colvar @@ -4340,16 +4271,14 @@ END SUBROUTINE distance_from_path_colvar !> \param colvar ... !> \param cell ... !> \param particles ... -!> \param error ... !> \date 01.2010 !> \author MI ! ***************************************************************************** - SUBROUTINE dpath_colvar(colvar,cell,particles,error) + SUBROUTINE dpath_colvar(colvar,cell,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dpath_colvar', & routineP = moduleN//':'//routineN @@ -4367,22 +4296,22 @@ SUBROUTINE dpath_colvar(colvar,cell,particles,error) ncolv=colvar%reaction_path_param%n_components lambda=colvar%reaction_path_param%lambda ALLOCATE(f_vals(ncolv,istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) f_vals(:,:)=colvar%reaction_path_param%f_vals ALLOCATE(ss_vals(ncolv),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i=1,ncolv - CALL colvar_recursive_eval(colvar%reaction_path_param%colvar_p(i)%colvar,cell,particles,error) + CALL colvar_recursive_eval(colvar%reaction_path_param%colvar_p(i)%colvar,cell,particles) ss_vals(i)=colvar%reaction_path_param%colvar_p(i)%colvar%ss ENDDO ALLOCATE(s1v(istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1v(ncolv,istart:iend),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1(ncolv),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO k=istart,iend s1v(k)=EXP(-lambda*DOT_PRODUCT(ss_vals(:)-f_vals(:,k),ss_vals(:)-f_vals(:,k))) @@ -4398,7 +4327,7 @@ SUBROUTINE dpath_colvar(colvar,cell,particles,error) colvar%ss=-1.0_dp/lambda*LOG(s1) ALLOCATE(fi(3,colvar%n_atom_s),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ii=0 DO i=1,ncolv @@ -4414,17 +4343,17 @@ SUBROUTINE dpath_colvar(colvar,cell,particles,error) END DO DEALLOCATE(fi,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(f_vals,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ss_vals,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1v,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1v,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE dpath_colvar @@ -4434,16 +4363,14 @@ END SUBROUTINE dpath_colvar !> configurations belonging to the given path. !> \param colvar ... !> \param particles ... -!> \param error ... !> \date 01.2010 !> \author MI ! ***************************************************************************** - SUBROUTINE dpath_dist_rmsd(colvar,particles,error) + SUBROUTINE dpath_dist_rmsd(colvar,particles) TYPE(colvar_type), POINTER :: colvar TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dpath_dist_rmsd', & routineP = moduleN//':'//routineN @@ -4470,21 +4397,21 @@ SUBROUTINE dpath_dist_rmsd(colvar,particles,error) natom = SIZE(particles) ALLOCATE(r0(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(r(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(riat(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(vec_dif(rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(dvec_dif(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(s1v(nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1v(3,rmsd_atom,nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i = 1,natom ii = (i-1)*3 r0(ii+1) = particles(i)%r(1) @@ -4505,7 +4432,7 @@ SUBROUTINE dpath_dist_rmsd(colvar,particles,error) r(ii+3) = path_conf(ii+3,ik) END DO - CALL rmsd3(particles,r,r0,output_unit=-1,rotate=.TRUE.,error=error) + CALL rmsd3(particles,r,r0,output_unit=-1,rotate=.TRUE.) sum_exp = 0.0_dp DO iat = 1,rmsd_atom @@ -4534,7 +4461,7 @@ SUBROUTINE dpath_dist_rmsd(colvar,particles,error) colvar%ss=-1.0_dp/lambda*LOG(s1) ALLOCATE(fi(3,rmsd_atom),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO iat = 1,rmsd_atom fi(:,iat) = 2.0_dp*(riat(:,iat)-ds1(:,iat)/s1) @@ -4542,37 +4469,35 @@ SUBROUTINE dpath_dist_rmsd(colvar,particles,error) END DO DEALLOCATE(fi,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r0,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(riat,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(vec_dif,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(dvec_dif,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE dpath_dist_rmsd ! ***************************************************************************** !> \brief ... !> \param colvar ... !> \param particles ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dpath_rmsd(colvar,particles,error) + SUBROUTINE dpath_rmsd(colvar,particles) TYPE(colvar_type), POINTER :: colvar TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dpath_rmsd', & routineP = moduleN//':'//routineN @@ -4602,22 +4527,22 @@ SUBROUTINE dpath_rmsd(colvar,particles,error) natom = SIZE(particles) ALLOCATE(r0(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(r(3*natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(riat(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(s1v(nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1v(3,rmsd_atom,nconf),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(ds1(3,rmsd_atom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) ALLOCATE(drmsd(3,natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) drmsd = 0.0_dp ALLOCATE (weight(natom),STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO i = 1,natom @@ -4648,7 +4573,7 @@ SUBROUTINE dpath_rmsd(colvar,particles,error) END DO CALL rmsd3(particles,r0,r,output_unit=-1,weights=weight,my_val=my_rmsd,& - rotate=.FALSE.,drmsd3=drmsd,error=error) + rotate=.FALSE.,drmsd3=drmsd) s1v(ik)=EXP(-lambda*my_rmsd) DO iat = 1,rmsd_atom @@ -4668,7 +4593,7 @@ SUBROUTINE dpath_rmsd(colvar,particles,error) colvar%ss=-1.0_dp/lambda*LOG(s1) ALLOCATE(fi(3,rmsd_atom),stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DO iat = 1,rmsd_atom fi(:,iat) = ds1(:,iat)/s1 @@ -4676,23 +4601,23 @@ SUBROUTINE dpath_rmsd(colvar,particles,error) END DO DEALLOCATE(fi,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r0,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(r,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(riat,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(s1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1v,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(ds1,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(drmsd,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) DEALLOCATE(weight,STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) END SUBROUTINE dpath_rmsd @@ -4702,17 +4627,15 @@ END SUBROUTINE dpath_rmsd !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \date 01.2009 !> \author fsterpone ! ***************************************************************************** - SUBROUTINE population_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE population_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'population_colvar', & routineP = moduleN//':'//routineN @@ -4733,12 +4656,12 @@ SUBROUTINE population_colvar(colvar,cell,subsys,particles,error) ! If we defined the coordination number with KINDS then we have still ! to fill few missing informations... NULLIFY(particles_i) - CPPrecondition(colvar%type_id==population_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==population_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF n_atoms_to=colvar%population_param%n_atoms_to @@ -4811,18 +4734,16 @@ END SUBROUTINE population_colvar !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \date 03.2009 !> \author MI ! ***************************************************************************** - SUBROUTINE gyration_radius_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE gyration_radius_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gyration_radius_colvar', & routineP = moduleN//':'//routineN @@ -4840,12 +4761,12 @@ SUBROUTINE gyration_radius_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. NULLIFY(particles_i,my_particles) - CPPrecondition(colvar%type_id==gyration_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==gyration_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF n_atoms=colvar%gyration_param%n_atoms @@ -4901,17 +4822,15 @@ END SUBROUTINE gyration_radius_colvar !> \param colvar ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \date 12.2009 !> \author MI !> \note could be extended to be used with more than 2 reference structures ! ***************************************************************************** - SUBROUTINE rmsd_colvar(colvar,subsys,particles,error) + SUBROUTINE rmsd_colvar(colvar,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rmsd_colvar', & routineP = moduleN//':'//routineN @@ -4919,7 +4838,7 @@ SUBROUTINE rmsd_colvar(colvar,subsys,particles,error) LOGICAL :: failure failure = .FALSE. - CALL rmsd_colvar_low(colvar,subsys,particles,error) + CALL rmsd_colvar_low(colvar,subsys,particles) END SUBROUTINE rmsd_colvar ! ***************************************************************************** @@ -4931,18 +4850,16 @@ END SUBROUTINE rmsd_colvar !> \param colvar ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \date 12.2009 !> \par History TL 2012 (generalized to any number of frames) !> \author MI ! ***************************************************************************** - SUBROUTINE rmsd_colvar_low(colvar,subsys,particles,error) + SUBROUTINE rmsd_colvar_low(colvar,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rmsd_colvar_low', & routineP = moduleN//':'//routineN @@ -4963,29 +4880,29 @@ SUBROUTINE rmsd_colvar_low(colvar,subsys,particles,error) failure=.FALSE. NULLIFY(my_particles,particles_i,weights) - CPPrecondition(colvar%type_id==rmsd_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==rmsd_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF natom = SIZE(my_particles) nframes=colvar%rmsd_param%nr_frames ALLOCATE (drmsd(3,natom,nframes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) drmsd = 0.0_dp ALLOCATE (r0(3*natom,nframes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (rmsd(nframes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (der(nframes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (r(3*natom),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) weights => colvar%rmsd_param%weights DO i = 1,natom @@ -4997,11 +4914,10 @@ SUBROUTINE rmsd_colvar_low(colvar,subsys,particles,error) r0(:,:) = colvar%rmsd_param%r_ref rmsd = 0.0_dp - CALL rmsd3(my_particles,r,r0(:,1),output_unit=-1,weights=weights,my_val=rmsd(1),rotate=.FALSE.,drmsd3=drmsd(:,:,1),error=error) + CALL rmsd3(my_particles,r,r0(:,1),output_unit=-1,weights=weights,my_val=rmsd(1),rotate=.FALSE.,drmsd3=drmsd(:,:,1)) IF (nframes==2) THEN - CALL rmsd3(my_particles,r,r0(:,2),output_unit=-1,weights=weights,my_val=rmsd(2),rotate=.FALSE.,drmsd3=drmsd(:,:,2),& - error=error) + CALL rmsd3(my_particles,r,r0(:,2),output_unit=-1,weights=weights,my_val=rmsd(2),rotate=.FALSE.,drmsd3=drmsd(:,:,2)) f1 = 1.0_dp/(rmsd(1)+rmsd(2)) ! (rmsdA-rmsdB)/(rmsdA+rmsdB) @@ -5037,20 +4953,20 @@ SUBROUTINE rmsd_colvar_low(colvar,subsys,particles,error) END DO ELSE CALL cp_unimplemented_error(fromWhere=routineP, & - message="RMSD implemented only for 1 and 2 reference frames!", error=error, error_level=cp_failure_level) + message="RMSD implemented only for 1 and 2 reference frames!",error_level=cp_failure_level) END IF colvar%ss=cv_val DEALLOCATE(der,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r0,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(drmsd,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rmsd,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE rmsd_colvar_low @@ -5061,17 +4977,15 @@ END SUBROUTINE rmsd_colvar_low !> \param cell ... !> \param subsys ... !> \param particles ... -!> \param error ... !> \date 08.2012 !> \author JGH ! ***************************************************************************** - SUBROUTINE ring_puckering_colvar(colvar,cell,subsys,particles,error) + SUBROUTINE ring_puckering_colvar(colvar,cell,subsys,particles) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ring_puckering_colvar', & routineP = moduleN//':'//routineN @@ -5093,20 +5007,20 @@ SUBROUTINE ring_puckering_colvar(colvar,cell,subsys,particles,error) failure=.FALSE. - CPPrecondition(colvar%type_id==ring_puckering_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==ring_puckering_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF nring = colvar%ring_puckering_param%nring ALLOCATE (r(3,nring),z(nring),cosj(nring),sinj(nring),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (nforce(3,3,nring),zforce(nring,nring,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ii = 1,nring i=colvar%ring_puckering_param%atoms(ii) CALL get_coordinates(colvar, i, r(:,ii), my_particles) @@ -5188,7 +5102,7 @@ SUBROUTINE ring_puckering_colvar(colvar,cell,subsys,particles,error) END DO ELSE m = ABS(colvar%ring_puckering_param%iq) - CPPrecondition(m/=1,cp_failure_level,routineP,error,failure) + CPPrecondition(m/=1,cp_failure_level,routineP,failure) IF(MOD(nring,2)==0 .AND. colvar%ring_puckering_param%iq == nring/2) THEN ! single puckering amplitude svar = 0._dp @@ -5212,7 +5126,7 @@ SUBROUTINE ring_puckering_colvar(colvar,cell,subsys,particles,error) CALL put_derivative(colvar, ii, -ftmp) END DO ELSE - CPPrecondition(m<=(nring-1)/2,cp_failure_level,routineP,error,failure) + CPPrecondition(m<=(nring-1)/2,cp_failure_level,routineP,failure) a = 0._dp b = 0._dp DO ii = 1,nring @@ -5252,7 +5166,7 @@ SUBROUTINE ring_puckering_colvar(colvar,cell,subsys,particles,error) colvar%ss=svar DEALLOCATE (r,z,cosj,sinj,nforce,zforce,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE ring_puckering_colvar @@ -5327,18 +5241,16 @@ END FUNCTION rec_eval_grid !> \param nr_frames ... !> \param r_ref ... !> \param n_atoms ... -!> \param error ... !> \date 01.2010 !> \author MI ! ***************************************************************************** - SUBROUTINE read_frames(frame_section,para_env,nr_frames,r_ref,n_atoms,error) + SUBROUTINE read_frames(frame_section,para_env,nr_frames,r_ref,n_atoms) TYPE(section_vals_type), POINTER :: frame_section TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN) :: nr_frames REAL(dp), DIMENSION(:, :), POINTER :: r_ref INTEGER, INTENT(OUT) :: n_atoms - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_frames', & routineP = moduleN//':'//routineN @@ -5355,45 +5267,44 @@ SUBROUTINE read_frames(frame_section,para_env,nr_frames,r_ref,n_atoms,error) NULLIFY(rptr) DO i = 1,nr_frames - coord_section => section_vals_get_subs_vals(frame_section,"COORD",i_rep_section=i,error=error) - CALL section_vals_get(coord_section,explicit=explicit,error=error) + coord_section => section_vals_get_subs_vals(frame_section,"COORD",i_rep_section=i) + CALL section_vals_get(coord_section,explicit=explicit) ! Cartesian Coordinates IF (explicit) THEN CALL section_vals_val_get(coord_section,"_DEFAULT_KEYWORD_",& - n_rep_val=natom,error=error) + n_rep_val=natom) IF(i==1) THEN ALLOCATE(r_ref(3*natom,nr_frames), STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) n_atoms = natom ELSE - CPPostcondition(3*natom==SIZE(r_ref,1),cp_failure_level,routineP,error,failure) + CPPostcondition(3*natom==SIZE(r_ref,1),cp_failure_level,routineP,failure) END IF DO j = 1, natom CALL section_vals_val_get(coord_section,"_DEFAULT_KEYWORD_",& - i_rep_val=j,r_vals=rptr,error=error) + i_rep_val=j,r_vals=rptr) r_ref((j-1)*3+1:(j-1)*3+3,i) = rptr(1:3) END DO ! natom ELSE - CALL section_vals_val_get(frame_section,"COORD_FILE_NAME",i_rep_section=i,c_val=filename,error=error) - CPPostcondition(TRIM(filename)/="",cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(frame_section,"COORD_FILE_NAME",i_rep_section=i,c_val=filename) + CPPostcondition(TRIM(filename)/="",cp_failure_level,routineP,failure) NULLIFY(parser) ALLOCATE(rptr(3)) - CALL parser_create(parser,filename,para_env=para_env,parse_white_lines=.TRUE.,& - error=error) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_create(parser,filename,para_env=para_env,parse_white_lines=.TRUE.) + CALL parser_get_next_line(parser,1) ! Start parser - CALL parser_get_object(parser,natom,error=error) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_object(parser,natom) + CALL parser_get_next_line(parser,1) IF(i==1) THEN ALLOCATE(r_ref(3*natom,nr_frames), STAT=stat) - CPPostcondition(stat == 0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routinep,failure) n_atoms = natom ELSE - CPPostcondition(3*natom==SIZE(r_ref,1),cp_failure_level,routineP,error,failure) + CPPostcondition(3*natom==SIZE(r_ref,1),cp_failure_level,routineP,failure) END IF DO j = 1, natom ! Atom coordinates - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) CALL cp_assert(.NOT.my_end,cp_fatal_level,cp_assertion_failed,routineP,& "Number of lines in XYZ format not equal to the number of atoms."//& " Error in XYZ format for COORD_A (CV rmsd). Very probably the"//& @@ -5401,11 +5312,11 @@ SUBROUTINE read_frames(frame_section,para_env,nr_frames,r_ref,n_atoms,error) CPSourceFileRef,& only_ionode=.TRUE.) READ(parser%input_line,*) dummy_char,rptr(1:3) - r_ref((j-1)*3+1,i) = cp_unit_to_cp2k(rptr(1),"angstrom",error=error) - r_ref((j-1)*3+2,i) = cp_unit_to_cp2k(rptr(2),"angstrom",error=error) - r_ref((j-1)*3+3,i) = cp_unit_to_cp2k(rptr(3),"angstrom",error=error) + r_ref((j-1)*3+1,i) = cp_unit_to_cp2k(rptr(1),"angstrom") + r_ref((j-1)*3+2,i) = cp_unit_to_cp2k(rptr(2),"angstrom") + r_ref((j-1)*3+3,i) = cp_unit_to_cp2k(rptr(3),"angstrom") END DO ! natom - CALL parser_release(parser,error=error) + CALL parser_release(parser) DEALLOCATE(rptr) END IF END DO ! nr_frames @@ -5420,17 +5331,15 @@ END SUBROUTINE read_frames !> \param subsys ... !> \param particles ... !> \param qs_env ... -!> \param error ... !> \author alin m elena ! ***************************************************************************** - SUBROUTINE Wc_colvar(colvar,cell,subsys,particles,qs_env,error) + SUBROUTINE Wc_colvar(colvar,cell,subsys,particles,qs_env) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles TYPE(qs_environment_type), POINTER, OPTIONAL :: qs_env ! optional just because I am lazy... but I should get rid of it... - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'Wc_colvar', & routineP = moduleN//':'//routineN @@ -5451,15 +5360,15 @@ SUBROUTINE Wc_colvar(colvar,cell,subsys,particles,qs_env,error) failure=.FALSE. NULLIFY(particles_i,wc) - CPPrecondition(colvar%type_id==Wc_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==Wc_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF - CALL get_qs_env(qs_env,WannierCentres=wc,error=error) + CALL get_qs_env(qs_env,WannierCentres=wc) rcut =colvar%Wc%rcut ! distances are in bohr as far as I remember Od=colvar%Wc%ids(1) H=colvar%Wc%ids(2) @@ -5468,9 +5377,9 @@ SUBROUTINE Wc_colvar(colvar,cell,subsys,particles,qs_env,error) CALL get_coordinates(colvar, H, rH, my_particles) CALL get_coordinates(colvar, Oa, rOa, my_particles) ALLOCATE(wcai(SIZE(wc(1)%WannierHamDiag)),stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) ALLOCATE(wcdi(SIZE(wc(1)%WannierHamDiag)),stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) nwca=0 nwcd=0 DO j=1,SIZE(wc(1)%WannierHamDiag) @@ -5514,9 +5423,9 @@ SUBROUTINE Wc_colvar(colvar,cell,subsys,particles,qs_env,error) ! write(*,'(2(i0,1x),4(f16.8,1x))')idmin,iamin,wc(1)%WannierHamDiag(idmin),wc(1)%WannierHamDiag(iamin),dmin,amin colvar%ss = wc(1)%WannierHamDiag(idmin)-wc(1)%WannierHamDiag(iamin) DEALLOCATE(wcai,stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) DEALLOCATE(wcdi,stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) CONTAINS ! ***************************************************************************** @@ -5542,17 +5451,15 @@ END SUBROUTINE Wc_colvar !> \param subsys ... !> \param particles ... !> \param qs_env ... -!> \param error ... !> \author alin m elena ! ***************************************************************************** - SUBROUTINE HBP_colvar(colvar,cell,subsys,particles,qs_env,error) + SUBROUTINE HBP_colvar(colvar,cell,subsys,particles,qs_env) TYPE(colvar_type), POINTER :: colvar TYPE(cell_type), POINTER :: cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles TYPE(qs_environment_type), POINTER, OPTIONAL :: qs_env ! optional just because I am lazy... but I should get rid of it... - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'HBP_colvar', & routineP = moduleN//':'//routineN @@ -5577,23 +5484,23 @@ SUBROUTINE HBP_colvar(colvar,cell,subsys,particles,qs_env,error) failure=.FALSE. NULLIFY(particles_i,wc,logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(colvar%type_id==HBP_colvar_id,cp_failure_level,routineP,error,failure) + CPPrecondition(colvar%type_id==HBP_colvar_id,cp_failure_level,routineP,failure) IF (PRESENT(particles)) THEN my_particles => particles ELSE - CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_i,error=error) + CPPrecondition(PRESENT(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_i) my_particles => particles_i%els END IF - CALL get_qs_env(qs_env,WannierCentres=wc,error=error) + CALL get_qs_env(qs_env,WannierCentres=wc) rcut = colvar%HBP%rcut ! distances are in bohr as far as I remember ALLOCATE(wcai(SIZE(wc(1)%WannierHamDiag)),stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) ALLOCATE(wcdi(SIZE(wc(1)%WannierHamDiag)),stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) colvar%ss=0.0_dp DO il=1,colvar%HBP%nPoints Od=colvar%HBP%ids(il,1) @@ -5650,9 +5557,9 @@ SUBROUTINE HBP_colvar(colvar,cell,subsys,particles,qs_env,error) WRITE(output_unit,'(a,1(f16.8,1x))')"HBP|\theta(x) = ",colvar%ss ENDIF DEALLOCATE(wcai,stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) DEALLOCATE(wcdi,stat=ierror) - CPPrecondition(ierror==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierror==0,cp_failure_level,routineP,failure) CONTAINS ! ***************************************************************************** diff --git a/src/colvar_utils.F b/src/colvar_utils.F index 0a8c0c6648..0735ebda5f 100644 --- a/src/colvar_utils.F +++ b/src/colvar_utils.F @@ -64,14 +64,12 @@ MODULE colvar_utils !> \param force_env ... !> \param only_intra_colvar ... !> \param unique ... -!> \param error ... !> \retval ntot ... !> \author Teodoro Laino 05.2007 [tlaino] - Zurich University ! ***************************************************************************** - FUNCTION number_of_colvar(force_env, only_intra_colvar, unique, error) RESULT(ntot) + FUNCTION number_of_colvar(force_env, only_intra_colvar, unique) RESULT(ntot) TYPE(force_env_type), POINTER :: force_env LOGICAL, INTENT(IN), OPTIONAL :: only_intra_colvar, unique - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ntot CHARACTER(LEN=*), PARAMETER :: routineN = 'number_of_colvar', & @@ -97,9 +95,9 @@ FUNCTION number_of_colvar(force_env, only_intra_colvar, unique, error) RESULT(nt IF (PRESENT(only_intra_colvar)) skip_inter_colvar = only_intra_colvar IF (PRESENT(unique)) my_unique = unique ntot = 0 - CALL force_env_get(force_env=force_env, subsys=subsys, error=error) + CALL force_env_get(force_env=force_env, subsys=subsys) CALL cp_subsys_get(subsys=subsys, molecules_new=molecules, gci=gci,& - molecule_kinds_new=molecule_kinds, error=error) + molecule_kinds_new=molecule_kinds) molecule_set => molecules % els ! Intramolecular Colvar @@ -134,13 +132,11 @@ END FUNCTION number_of_colvar !> \brief Set the value of target for constraints/restraints !> \param targets ... !> \param force_env ... -!> \param error ... !> \author Teodoro Laino 05.2007 [tlaino] - Zurich University ! ***************************************************************************** - SUBROUTINE set_colvars_target(targets, force_env, error) + SUBROUTINE set_colvars_target(targets, force_env) REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: targets TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_colvars_target', & routineP = moduleN//':'//routineN @@ -159,9 +155,8 @@ SUBROUTINE set_colvars_target(targets, force_env, error) failure = .FALSE. NULLIFY(cell, subsys, molecule_kinds, molecule_kind, gci, colv_list) CALL timeset(routineN,handle) - CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell, error=error) - CALL cp_subsys_get(subsys=subsys, gci=gci, molecule_kinds_new=molecule_kinds,& - error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell) + CALL cp_subsys_get(subsys=subsys, gci=gci, molecule_kinds_new=molecule_kinds) nkind = molecule_kinds % n_els ! Set Target for Intramolecular Colvars @@ -199,10 +194,9 @@ END SUBROUTINE set_colvars_target !> \param Bmatrix ... !> \param MassI ... !> \param Amatrix ... -!> \param error ... !> \author Teodoro Laino 05.2007 [tlaino] - Zurich University ! ***************************************************************************** - SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix, error ) + SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:), & @@ -214,7 +208,6 @@ SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix, er POINTER :: MassI REAL(KIND=dp), DIMENSION(:, :), & OPTIONAL, POINTER :: Amatrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eval_colvar', & routineP = moduleN//':'//routineN @@ -246,14 +239,14 @@ SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix, er molecule_set, particles, particle_set, gci) IF (PRESENT(Bmatrix)) THEN check = ASSOCIATED(Bmatrix) - CPPrecondition(check, cp_failure_level, routineP, error, failure) + CPPrecondition(check, cp_failure_level, routineP,failure) Bmatrix = 0.0_dp END IF CALL timeset(routineN,handle) ALLOCATE(map(SIZE(cvalues)), stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) map=HUGE(0) ! init all, since used in a sort, but not all set in parallel. - CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell, error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell) n_tot=0 cvalues = 0.0_dp CALL cp_subsys_get(subsys=subsys,& @@ -261,14 +254,13 @@ SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix, er molecules_new=molecules,& local_molecules_new=local_molecules,& gci=gci,& - molecule_kinds_new=molecule_kinds,& - error=error) + molecule_kinds_new=molecule_kinds) nkind = molecule_kinds % n_els particle_set => particles%els molecule_set => molecules % els ! Intramolecular Colvars - IF (number_of_colvar(force_env, only_intra_colvar=.TRUE., error=error)/=0) THEN + IF (number_of_colvar(force_env, only_intra_colvar=.TRUE.)/=0) THEN MOL: DO ikind = 1, nkind nmol_per_kind = local_molecules % n_el ( ikind ) DO imol = 1, nmol_per_kind @@ -282,7 +274,7 @@ SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix, er ! Collective variables IF ( ncolv%ntot /= 0 ) THEN CALL eval_colv_int( molecule, particle_set, coords, cell, cvalues,& - Bmatrix, offset, n_tot, map, error ) + Bmatrix, offset, n_tot, map) ENDIF END DO END DO MOL @@ -295,16 +287,16 @@ SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix, er IF (ASSOCIATED(gci)) THEN IF ( gci%ncolv%ntot /= 0 ) THEN CALL eval_colv_ext( gci, particle_set, coords, cell, cvalues,& - Bmatrix, offset, n_tot, map, error ) + Bmatrix, offset, n_tot, map) ENDIF END IF - CPPrecondition(n_tot==SIZE(cvalues), cp_failure_level, routineP, error, failure) + CPPrecondition(n_tot==SIZE(cvalues), cp_failure_level, routineP,failure) ! Sort values of Collective Variables according the order of the input ! sections ALLOCATE(wrk(SIZE(cvalues)), stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(rwrk(SIZE(cvalues)), stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) CALL sort(map, SIZE(map), wrk) rwrk = cvalues DO i = 1, SIZE(wrk) @@ -313,49 +305,48 @@ SUBROUTINE eval_colvar ( force_env, coords, cvalues, Bmatrix, MassI, Amatrix, er ! check and sort on Bmatrix IF (PRESENT(Bmatrix)) THEN check = n_tot==SIZE(Bmatrix,2) - CPPrecondition(check, cp_failure_level, routineP, error, failure) + CPPrecondition(check, cp_failure_level, routineP,failure) ALLOCATE(bwrk(SIZE(Bmatrix,1),SIZE(Bmatrix,2)), stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) bwrk(:,:) = Bmatrix DO i = 1, SIZE(wrk) Bmatrix(:,i) = bwrk(:,wrk(i)) END DO DEALLOCATE(bwrk, stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) END IF DEALLOCATE(rwrk, stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(wrk, stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(map, stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) ! Construction of the Amatrix IF (PRESENT(Bmatrix).AND.PRESENT(Amatrix)) THEN - CPPrecondition(ASSOCIATED(Amatrix), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(Amatrix), cp_failure_level, routineP,failure) check = SIZE(Bmatrix,1)==SIZE(Amatrix,2) - CPPrecondition(check, cp_failure_level, routineP, error, failure) + CPPrecondition(check, cp_failure_level, routineP,failure) check = SIZE(Bmatrix,2)==SIZE(Amatrix,1) - CPPrecondition(check, cp_failure_level, routineP, error, failure) + CPPrecondition(check, cp_failure_level, routineP,failure) ALLOCATE(Gmatrix(n_tot,n_tot), stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(Gmatrix_i(n_tot,n_tot), stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) Gmatrix(:,:) = MATMUL(TRANSPOSE(Bmatrix),Bmatrix) - CALL invert_matrix(Gmatrix, Gmatrix_i, inv_error, error=error) + CALL invert_matrix(Gmatrix, Gmatrix_i, inv_error) CALL cp_assert(ABS(inv_error)<=1.0E-8_dp,cp_warning_level, cp_assertion_failed, routineP,& "Error in inverting the Gmatrix larger than 1.0E-8!"//& -CPSourceFileRef,& - error) +CPSourceFileRef) Amatrix = MATMUL(Gmatrix_i,TRANSPOSE(Bmatrix)) DEALLOCATE(Gmatrix_i, stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(Gmatrix, stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) END IF IF (PRESENT(MassI)) THEN natom = SIZE(particle_set) - CPPrecondition(ASSOCIATED(MassI), cp_failure_level, routineP, error, failure) - CPPrecondition(SIZE(MassI)==natom*3, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(MassI), cp_failure_level, routineP,failure) + CPPrecondition(SIZE(MassI)==natom*3, cp_failure_level, routineP,failure) DO i = 1, natom MassI((i-1)*3+1) = 1.0_dp/particle_set(i)%atomic_kind%mass MassI((i-1)*3+2) = 1.0_dp/particle_set(i)%atomic_kind%mass @@ -405,11 +396,10 @@ END FUNCTION get_colvar_offset !> \param offset ... !> \param n_tot ... !> \param map ... -!> \param error ... !> \author Teodoro Laino 05.2007 [tlaino] - Zurich University ! ***************************************************************************** SUBROUTINE eval_colv_int( molecule, particle_set, coords, cell, cvalues,& - Bmatrix, offset, n_tot, map, error ) + Bmatrix, offset, n_tot, map) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -423,7 +413,6 @@ SUBROUTINE eval_colv_int( molecule, particle_set, coords, cell, cvalues,& INTEGER, INTENT(IN) :: offset INTEGER, INTENT(INOUT) :: n_tot INTEGER, DIMENSION(:), POINTER :: map - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eval_colv_int', & routineP = moduleN//':'//routineN @@ -443,7 +432,7 @@ SUBROUTINE eval_colv_int( molecule, particle_set, coords, cell, cvalues,& CALL get_molecule_kind ( molecule_kind, colv_list = colv_list, fixd_list=fixd_list ) CALL get_molecule ( molecule, lcolv=lcolv ) CALL eval_colv_low( colv_list, fixd_list, lcolv, particle_set,& - coords, cell, cvalues, Bmatrix, offset, n_tot, map, error) + coords, cell, cvalues, Bmatrix, offset, n_tot, map) END SUBROUTINE eval_colv_int @@ -458,11 +447,10 @@ END SUBROUTINE eval_colv_int !> \param offset ... !> \param n_tot ... !> \param map ... -!> \param error ... !> \author Teodoro Laino 05.2007 [tlaino] - Zurich University ! ***************************************************************************** SUBROUTINE eval_colv_ext( gci, particle_set, coords, cell, cvalues,& - Bmatrix, offset, n_tot, map, error ) + Bmatrix, offset, n_tot, map) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), DIMENSION(:), & @@ -475,7 +463,6 @@ SUBROUTINE eval_colv_ext( gci, particle_set, coords, cell, cvalues,& INTEGER, INTENT(IN) :: offset INTEGER, INTENT(INOUT) :: n_tot INTEGER, DIMENSION(:), POINTER :: map - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eval_colv_ext', & routineP = moduleN//':'//routineN @@ -490,7 +477,7 @@ SUBROUTINE eval_colv_ext( gci, particle_set, coords, cell, cvalues,& fixd_list => gci%fixd_list lcolv => gci%lcolv CALL eval_colv_low( colv_list, fixd_list, lcolv, particle_set,& - coords, cell, cvalues, Bmatrix, offset, n_tot, map, error) + coords, cell, cvalues, Bmatrix, offset, n_tot, map) END SUBROUTINE eval_colv_ext @@ -509,11 +496,10 @@ END SUBROUTINE eval_colv_ext !> \param offset ... !> \param n_tot ... !> \param map ... -!> \param error ... !> \author Teodoro Laino 05.2007 [tlaino] - Zurich University ! ***************************************************************************** SUBROUTINE eval_colv_low( colv_list, fixd_list, lcolv, particle_set, coords,& - cell, cvalues, Bmatrix, offset, n_tot, map, error) + cell, cvalues, Bmatrix, offset, n_tot, map) TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -531,7 +517,6 @@ SUBROUTINE eval_colv_low( colv_list, fixd_list, lcolv, particle_set, coords,& INTEGER, INTENT(IN) :: offset INTEGER, INTENT(INOUT) :: n_tot INTEGER, DIMENSION(:), POINTER :: map - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eval_colv_low', & routineP = moduleN//':'//routineN @@ -547,11 +532,10 @@ SUBROUTINE eval_colv_low( colv_list, fixd_list, lcolv, particle_set, coords,& ! Update colvar IF (PRESENT(coords)) THEN CALL colvar_eval_mol_f(lcolv(iconst)%colvar, cell, particles=particle_set,& - pos=RESHAPE(coords,(/3,SIZE(particle_set)/)), fixd_list=fixd_list, & - error=error) + pos=RESHAPE(coords,(/3,SIZE(particle_set)/)), fixd_list=fixd_list) ELSE CALL colvar_eval_mol_f(lcolv(iconst)%colvar, cell, particles=particle_set,& - fixd_list=fixd_list, error=error) + fixd_list=fixd_list) END IF cvalues(ival) = lcolv(iconst)%colvar%ss map(ival) = colv_list(iconst)%inp_seq_num @@ -578,17 +562,15 @@ END SUBROUTINE eval_colv_low !> \param nsize_int ... !> \param cvalues ... !> \param Mmatrix ... -!> \param error ... !> \author Teodoro Laino 05.2007 ! ***************************************************************************** SUBROUTINE get_clv_force(force_env, forces, coords, nsize_xyz, nsize_int, cvalues,& - Mmatrix, error) + Mmatrix) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT), OPTIONAL :: forces, coords INTEGER, INTENT(IN) :: nsize_xyz, nsize_int REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: cvalues, Mmatrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_clv_force', & routineP = moduleN//':'//routineN @@ -601,27 +583,27 @@ SUBROUTINE get_clv_force(force_env, forces, coords, nsize_xyz, nsize_int, cvalue failure = .FALSE. ALLOCATE(Bmatrix(nsize_xyz,nsize_int),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(MassI(nsize_xyz),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Transform gradients if requested IF (PRESENT(forces)) THEN ALLOCATE(wrk(nsize_int),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Amatrix(nsize_int,nsize_xyz),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Compute the transformation matrices and the invese mass diagonal Matrix - CALL eval_colvar(force_env, coords, cvalues, Bmatrix, MassI, Amatrix, error) + CALL eval_colvar(force_env, coords, cvalues, Bmatrix, MassI, Amatrix) wrk = MATMUL(Amatrix,forces) forces = 0.0_dp forces(1:nsize_int) = wrk DEALLOCATE(Amatrix, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ! Compute the transformation matrices and the invese mass diagonal Matrix - CALL eval_colvar(force_env, coords, cvalues, Bmatrix, MassI, error=error) + CALL eval_colvar(force_env, coords, cvalues, Bmatrix, MassI) END IF ! Compute the Metric Tensor DO i = 1, nsize_int @@ -635,9 +617,9 @@ SUBROUTINE get_clv_force(force_env, forces, coords, nsize_xyz, nsize_int, cvalue END DO END DO DEALLOCATE(MassI, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Bmatrix, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE get_clv_force ! ***************************************************************************** @@ -645,17 +627,15 @@ END SUBROUTINE get_clv_force !> defined using KINDS !> \param colvar ... !> \param particles ... -!> \param error ... !> \par History !> 1.2009 Fabio Sterpone : Added a part for population !> 10.2014 Moved out of colvar_types.F [Ole Schuett] !> \author Teodoro Laino - 07.2007 ! ***************************************************************************** - SUBROUTINE post_process_colvar(colvar, particles, error) + SUBROUTINE post_process_colvar(colvar, particles) TYPE(colvar_type), POINTER :: colvar TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_process_colvar', & routineP = moduleN//':'//routineN @@ -685,7 +665,7 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%coord_param%n_atoms_from - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Atoms to IF (colvar%coord_param%use_kinds_to) THEN @@ -703,7 +683,7 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%coord_param%n_atoms_to - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Atoms to b IF (colvar%coord_param%use_kinds_to_b) THEN @@ -721,11 +701,11 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%coord_param%n_atoms_to_b - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Setup the colvar - CALL colvar_setup(colvar, error) + CALL colvar_setup(colvar) END IF END IF @@ -747,7 +727,7 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%mindist_param%n_coord_from - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Atoms to IF (colvar%mindist_param%use_kinds_to) THEN @@ -765,10 +745,10 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%mindist_param%n_coord_to - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Setup the colvar - CALL colvar_setup(colvar, error) + CALL colvar_setup(colvar) END IF END IF @@ -791,7 +771,7 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%population_param%n_atoms_from - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Atoms to IF (colvar%population_param%use_kinds_to) THEN @@ -809,10 +789,10 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%population_param%n_atoms_to - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Setup the colvar - CALL colvar_setup(colvar, error) + CALL colvar_setup(colvar) END IF END IF @@ -836,10 +816,10 @@ SUBROUTINE post_process_colvar(colvar, particles, error) END DO END DO stat=colvar%gyration_param%n_atoms - CPPostcondition(stat/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat/=0,cp_failure_level,routineP,failure) END IF ! Setup the colvar - CALL colvar_setup(colvar, error) + CALL colvar_setup(colvar) END IF END IF @@ -856,7 +836,7 @@ SUBROUTINE post_process_colvar(colvar, particles, error) nr_frame = SIZE(colvar%rmsd_param%r_ref,2) DO i = 2,nr_frame CALL rmsd3(particles, colvar%rmsd_param%r_ref(:,i), colvar%rmsd_param%r_ref(:,1), -1,& - rotate=.TRUE., error=error) + rotate=.TRUE.) END DO END IF @@ -868,7 +848,7 @@ SUBROUTINE post_process_colvar(colvar, particles, error) nr_frame = colvar%reaction_path_param%nr_frames DO i = 2,nr_frame CALL rmsd3(particles, colvar%reaction_path_param%r_ref(:,i), colvar%reaction_path_param%r_ref(:,1), -1,& - rotate=.TRUE., error=error) + rotate=.TRUE.) END DO END IF END IF diff --git a/src/common/cg_test.F b/src/common/cg_test.F index 2e2899a8df..1d1721cf4e 100644 --- a/src/common/cg_test.F +++ b/src/common/cg_test.F @@ -35,11 +35,9 @@ MODULE cg_test ! ***************************************************************************** !> \brief ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE clebsch_gordon_test (error) +SUBROUTINE clebsch_gordon_test () - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'clebsch_gordon_test', & routineP = moduleN//':'//routineN @@ -56,7 +54,7 @@ SUBROUTINE clebsch_gordon_test (error) TYPE(cp_logger_type), POINTER :: logger failure = .FALSE. - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() iw = cp_logger_get_default_io_unit(logger) IF ( iw>0 ) THEN @@ -69,11 +67,11 @@ SUBROUTINE clebsch_gordon_test (error) ll = get_number_of_lebedev_grid(n=na) na = lebedev_grid(ll)%n ALLOCATE (wa(na), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (a1(na),a2(na),a3(na), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (b1(na),b2(na),b3(na), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wa(1:na) = 4.0_dp*pi*lebedev_grid(ll)%w(1:na) @@ -161,11 +159,11 @@ SUBROUTINE clebsch_gordon_test (error) END DO DEALLOCATE ( wa, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (a1, a2, a3, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (b1, b2, b3, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL deallocate_lebedev_grids() CALL clebsch_gordon_deallocate() diff --git a/src/common/cp_array_utils_i.F b/src/common/cp_array_utils_i.F index 72b0932d39..f9818d7d55 100644 --- a/src/common/cp_array_utils_i.F +++ b/src/common/cp_array_utils_i.F @@ -106,19 +106,16 @@ MODULE cp_array_utils_i !> \param array the array to write !> \param unit_nr the unit to write to (defaults to the standard out) !> \param el_format the format of a single element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> maybe I will move to a comma separated paretized list ! ***************************************************************************** -SUBROUTINE cp_1d_i_write(array, unit_nr, el_format, error) +SUBROUTINE cp_1d_i_write(array, unit_nr, el_format) INTEGER(kind=int_4), INTENT(in) :: array(:) INTEGER, INTENT(in) :: unit_nr CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: defaultFormat = "(i6)", & routineN = 'cp_1d_i_write', routineP = moduleN//':'//routineN @@ -128,7 +125,7 @@ SUBROUTINE cp_1d_i_write(array, unit_nr, el_format, error) failure=.FALSE. WRITE(unit=unit_nr,fmt="('( ')",advance="no", iostat=iostat) - CPPrecondition(iostat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(iostat==0,cp_failure_level,routineP,failure) IF (.NOT.failure) THEN IF (PRESENT(el_format)) THEN DO i=1,SIZE(array)-1 @@ -164,19 +161,16 @@ END SUBROUTINE cp_1d_i_write !> \param array the array to write !> \param unit_nr the unit to write to (defaults to the standard out) !> \param el_format the format of a single element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> maybe I will move to a comma separated parentized list ! ***************************************************************************** -SUBROUTINE cp_2d_i_write(array, unit_nr, el_format, error) +SUBROUTINE cp_2d_i_write(array, unit_nr, el_format) INTEGER(kind=int_4), INTENT(in) :: array(:,:) INTEGER, INTENT(in) :: unit_nr CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: defaultFormat = "(i6)", & routineN = 'cp_2d_i_write', routineP = moduleN//':'//routineN @@ -197,7 +191,7 @@ SUBROUTINE cp_2d_i_write(array, unit_nr, el_format, error) fmtstr = '(" ",'//nRiga//defaultFormat//')' WRITE(unit=unit_nr,fmt=fmtstr,iostat=iostat) array(i,:) END IF - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) IF (failure) THEN EXIT END IF @@ -214,8 +208,6 @@ END SUBROUTINE cp_2d_i_write !> the realloc in the module memory_utilities) !> \param array the array to reallocate if necessary !> \param n the wanted size -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2001 first version [fawzi] !> 3.2002 templatized [fawzi] @@ -224,10 +216,9 @@ END SUBROUTINE cp_2d_i_write !> this is a different behaviour than the realloc in the module !> memory_utilities. It is quite low level ! ***************************************************************************** - SUBROUTINE cp_1d_i_guarantee_size(array, n, error) + SUBROUTINE cp_1d_i_guarantee_size(array, n) INTEGER(kind=int_4), POINTER :: array(:) INTEGER, INTENT(in) :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_1d_i_guarantee_size', & routineP = moduleN//':'//routineN @@ -237,18 +228,18 @@ SUBROUTINE cp_1d_i_guarantee_size(array, n, error) failure=.FALSE. - CPPrecondition(n>=0,cp_failure_level,routineP,error,failure) + CPPrecondition(n>=0,cp_failure_level,routineP,failure) failureIf: IF (.NOT. failure) THEN IF (ASSOCIATED(array)) THEN IF (SIZE(array) /= n) THEN - CPErrorMessage(cp_warning_level,routineP,'size has changed',error) + CPErrorMessage(cp_warning_level,routineP,'size has changed') DEALLOCATE(array, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF IF (.NOT.ASSOCIATED(array)) THEN ALLOCATE(array(n), stat=stat) - CPPostcondition(stat==0, cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0, cp_failure_level,routineP,failure) END IF END IF failureIf END SUBROUTINE cp_1d_i_guarantee_size @@ -263,8 +254,6 @@ END SUBROUTINE cp_1d_i_guarantee_size !> \param array the array to reallocate if necessary !> \param n_rows the wanted number of rows !> \param n_cols the wanted number of cols -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 5.2001 first version [fawzi] !> \author Fawzi Mohamed @@ -272,10 +261,9 @@ END SUBROUTINE cp_1d_i_guarantee_size !> this is a different behaviour than the realloc in the module !> memory_utilities. It is quite low level ! ***************************************************************************** - SUBROUTINE cp_2d_i_guarantee_size(array, n_rows, n_cols, error) + SUBROUTINE cp_2d_i_guarantee_size(array, n_rows, n_cols) INTEGER(kind=int_4), POINTER :: array(:,:) INTEGER, INTENT(in) :: n_rows, n_cols - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_2d_i_guarantee_size', & routineP = moduleN//':'//routineN @@ -285,20 +273,20 @@ SUBROUTINE cp_2d_i_guarantee_size(array, n_rows, n_cols, error) failure=.FALSE. - CPPrecondition(n_cols>=0,cp_failure_level,routineP,error,failure) - CPPrecondition(n_rows>=0,cp_failure_level,routineP,error,failure) + CPPrecondition(n_cols>=0,cp_failure_level,routineP,failure) + CPPrecondition(n_rows>=0,cp_failure_level,routineP,failure) failureIf: IF (.NOT. failure) THEN IF (ASSOCIATED(array)) THEN IF (SIZE(array,1) /= n_rows .OR. SIZE(array,2) /= n_cols) THEN - CPErrorMessage(cp_warning_level,routineP,'size has changed',error) + CPErrorMessage(cp_warning_level,routineP,'size has changed') DEALLOCATE(array, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(array) END IF END IF IF (.NOT.ASSOCIATED(array)) THEN ALLOCATE(array(n_rows,n_cols), stat=stat) - CPPostconditionNoFail(stat==0, cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0, cp_failure_level,routineP) END IF END IF failureIf END SUBROUTINE cp_2d_i_guarantee_size @@ -312,8 +300,6 @@ END SUBROUTINE cp_2d_i_guarantee_size !> \param el the element to look for !> \param l_index the lower index for binary search (defaults to 1) !> \param u_index the upper index for binary search (defaults to size(array)) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 06.2003 created [fawzi] @@ -321,11 +307,10 @@ END SUBROUTINE cp_2d_i_guarantee_size !> \note !> the array should be ordered in growing order ! ***************************************************************************** -FUNCTION cp_1d_i_bsearch(array, el, l_index, u_index, error)& +FUNCTION cp_1d_i_bsearch(array, el, l_index, u_index)& RESULT(res) INTEGER(kind=int_4), INTENT(in) :: array(:), el INTEGER, INTENT(in), OPTIONAL :: l_index, u_index - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_1d_i_bsearch', & diff --git a/src/common/cp_array_utils_logical.F b/src/common/cp_array_utils_logical.F index 48d0a47e90..8dee31397a 100644 --- a/src/common/cp_array_utils_logical.F +++ b/src/common/cp_array_utils_logical.F @@ -106,19 +106,16 @@ MODULE cp_array_utils_logical !> \param array the array to write !> \param unit_nr the unit to write to (defaults to the standard out) !> \param el_format the format of a single element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> maybe I will move to a comma separated paretized list ! ***************************************************************************** -SUBROUTINE cp_1d_logical_write(array, unit_nr, el_format, error) +SUBROUTINE cp_1d_logical_write(array, unit_nr, el_format) LOGICAL, INTENT(in) :: array(:) INTEGER, INTENT(in) :: unit_nr CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: defaultFormat = "(l1)", & routineN = 'cp_1d_logical_write', routineP = moduleN//':'//routineN @@ -128,7 +125,7 @@ SUBROUTINE cp_1d_logical_write(array, unit_nr, el_format, error) failure=.FALSE. WRITE(unit=unit_nr,fmt="('( ')",advance="no", iostat=iostat) - CPPrecondition(iostat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(iostat==0,cp_failure_level,routineP,failure) IF (.NOT.failure) THEN IF (PRESENT(el_format)) THEN DO i=1,SIZE(array)-1 @@ -164,19 +161,16 @@ END SUBROUTINE cp_1d_logical_write !> \param array the array to write !> \param unit_nr the unit to write to (defaults to the standard out) !> \param el_format the format of a single element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> maybe I will move to a comma separated parentized list ! ***************************************************************************** -SUBROUTINE cp_2d_logical_write(array, unit_nr, el_format, error) +SUBROUTINE cp_2d_logical_write(array, unit_nr, el_format) LOGICAL, INTENT(in) :: array(:,:) INTEGER, INTENT(in) :: unit_nr CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: defaultFormat = "(l1)", & routineN = 'cp_2d_logical_write', routineP = moduleN//':'//routineN @@ -197,7 +191,7 @@ SUBROUTINE cp_2d_logical_write(array, unit_nr, el_format, error) fmtstr = '(" ",'//nRiga//defaultFormat//')' WRITE(unit=unit_nr,fmt=fmtstr,iostat=iostat) array(i,:) END IF - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) IF (failure) THEN EXIT END IF @@ -214,8 +208,6 @@ END SUBROUTINE cp_2d_logical_write !> the realloc in the module memory_utilities) !> \param array the array to reallocate if necessary !> \param n the wanted size -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2001 first version [fawzi] !> 3.2002 templatized [fawzi] @@ -224,10 +216,9 @@ END SUBROUTINE cp_2d_logical_write !> this is a different behaviour than the realloc in the module !> memory_utilities. It is quite low level ! ***************************************************************************** - SUBROUTINE cp_1d_logical_guarantee_size(array, n, error) + SUBROUTINE cp_1d_logical_guarantee_size(array, n) LOGICAL, POINTER :: array(:) INTEGER, INTENT(in) :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_1d_logical_guarantee_size', & routineP = moduleN//':'//routineN @@ -237,18 +228,18 @@ SUBROUTINE cp_1d_logical_guarantee_size(array, n, error) failure=.FALSE. - CPPrecondition(n>=0,cp_failure_level,routineP,error,failure) + CPPrecondition(n>=0,cp_failure_level,routineP,failure) failureIf: IF (.NOT. failure) THEN IF (ASSOCIATED(array)) THEN IF (SIZE(array) /= n) THEN - CPErrorMessage(cp_warning_level,routineP,'size has changed',error) + CPErrorMessage(cp_warning_level,routineP,'size has changed') DEALLOCATE(array, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF IF (.NOT.ASSOCIATED(array)) THEN ALLOCATE(array(n), stat=stat) - CPPostcondition(stat==0, cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0, cp_failure_level,routineP,failure) END IF END IF failureIf END SUBROUTINE cp_1d_logical_guarantee_size @@ -263,8 +254,6 @@ END SUBROUTINE cp_1d_logical_guarantee_size !> \param array the array to reallocate if necessary !> \param n_rows the wanted number of rows !> \param n_cols the wanted number of cols -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 5.2001 first version [fawzi] !> \author Fawzi Mohamed @@ -272,10 +261,9 @@ END SUBROUTINE cp_1d_logical_guarantee_size !> this is a different behaviour than the realloc in the module !> memory_utilities. It is quite low level ! ***************************************************************************** - SUBROUTINE cp_2d_logical_guarantee_size(array, n_rows, n_cols, error) + SUBROUTINE cp_2d_logical_guarantee_size(array, n_rows, n_cols) LOGICAL, POINTER :: array(:,:) INTEGER, INTENT(in) :: n_rows, n_cols - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_2d_logical_guarantee_size', & routineP = moduleN//':'//routineN @@ -285,20 +273,20 @@ SUBROUTINE cp_2d_logical_guarantee_size(array, n_rows, n_cols, error) failure=.FALSE. - CPPrecondition(n_cols>=0,cp_failure_level,routineP,error,failure) - CPPrecondition(n_rows>=0,cp_failure_level,routineP,error,failure) + CPPrecondition(n_cols>=0,cp_failure_level,routineP,failure) + CPPrecondition(n_rows>=0,cp_failure_level,routineP,failure) failureIf: IF (.NOT. failure) THEN IF (ASSOCIATED(array)) THEN IF (SIZE(array,1) /= n_rows .OR. SIZE(array,2) /= n_cols) THEN - CPErrorMessage(cp_warning_level,routineP,'size has changed',error) + CPErrorMessage(cp_warning_level,routineP,'size has changed') DEALLOCATE(array, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(array) END IF END IF IF (.NOT.ASSOCIATED(array)) THEN ALLOCATE(array(n_rows,n_cols), stat=stat) - CPPostconditionNoFail(stat==0, cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0, cp_failure_level,routineP) END IF END IF failureIf END SUBROUTINE cp_2d_logical_guarantee_size @@ -312,8 +300,6 @@ END SUBROUTINE cp_2d_logical_guarantee_size !> \param el the element to look for !> \param l_index the lower index for binary search (defaults to 1) !> \param u_index the upper index for binary search (defaults to size(array)) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 06.2003 created [fawzi] @@ -321,11 +307,10 @@ END SUBROUTINE cp_2d_logical_guarantee_size !> \note !> the array should be ordered in growing order ! ***************************************************************************** -FUNCTION cp_1d_logical_bsearch(array, el, l_index, u_index, error)& +FUNCTION cp_1d_logical_bsearch(array, el, l_index, u_index)& RESULT(res) LOGICAL, INTENT(in) :: array(:), el INTEGER, INTENT(in), OPTIONAL :: l_index, u_index - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_1d_logical_bsearch', & diff --git a/src/common/cp_array_utils_r.F b/src/common/cp_array_utils_r.F index acd6d10058..64ec3143ae 100644 --- a/src/common/cp_array_utils_r.F +++ b/src/common/cp_array_utils_r.F @@ -106,19 +106,16 @@ MODULE cp_array_utils_r !> \param array the array to write !> \param unit_nr the unit to write to (defaults to the standard out) !> \param el_format the format of a single element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> maybe I will move to a comma separated paretized list ! ***************************************************************************** -SUBROUTINE cp_1d_r_write(array, unit_nr, el_format, error) +SUBROUTINE cp_1d_r_write(array, unit_nr, el_format) REAL(kind=dp), INTENT(in) :: array(:) INTEGER, INTENT(in) :: unit_nr CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: defaultFormat = "(es14.6)", & routineN = 'cp_1d_r_write', routineP = moduleN//':'//routineN @@ -128,7 +125,7 @@ SUBROUTINE cp_1d_r_write(array, unit_nr, el_format, error) failure=.FALSE. WRITE(unit=unit_nr,fmt="('( ')",advance="no", iostat=iostat) - CPPrecondition(iostat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(iostat==0,cp_failure_level,routineP,failure) IF (.NOT.failure) THEN IF (PRESENT(el_format)) THEN DO i=1,SIZE(array)-1 @@ -164,19 +161,16 @@ END SUBROUTINE cp_1d_r_write !> \param array the array to write !> \param unit_nr the unit to write to (defaults to the standard out) !> \param el_format the format of a single element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> maybe I will move to a comma separated parentized list ! ***************************************************************************** -SUBROUTINE cp_2d_r_write(array, unit_nr, el_format, error) +SUBROUTINE cp_2d_r_write(array, unit_nr, el_format) REAL(kind=dp), INTENT(in) :: array(:,:) INTEGER, INTENT(in) :: unit_nr CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: defaultFormat = "(es14.6)", & routineN = 'cp_2d_r_write', routineP = moduleN//':'//routineN @@ -197,7 +191,7 @@ SUBROUTINE cp_2d_r_write(array, unit_nr, el_format, error) fmtstr = '(" ",'//nRiga//defaultFormat//')' WRITE(unit=unit_nr,fmt=fmtstr,iostat=iostat) array(i,:) END IF - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) IF (failure) THEN EXIT END IF @@ -214,8 +208,6 @@ END SUBROUTINE cp_2d_r_write !> the realloc in the module memory_utilities) !> \param array the array to reallocate if necessary !> \param n the wanted size -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2001 first version [fawzi] !> 3.2002 templatized [fawzi] @@ -224,10 +216,9 @@ END SUBROUTINE cp_2d_r_write !> this is a different behaviour than the realloc in the module !> memory_utilities. It is quite low level ! ***************************************************************************** - SUBROUTINE cp_1d_r_guarantee_size(array, n, error) + SUBROUTINE cp_1d_r_guarantee_size(array, n) REAL(kind=dp), POINTER :: array(:) INTEGER, INTENT(in) :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_1d_r_guarantee_size', & routineP = moduleN//':'//routineN @@ -237,18 +228,18 @@ SUBROUTINE cp_1d_r_guarantee_size(array, n, error) failure=.FALSE. - CPPrecondition(n>=0,cp_failure_level,routineP,error,failure) + CPPrecondition(n>=0,cp_failure_level,routineP,failure) failureIf: IF (.NOT. failure) THEN IF (ASSOCIATED(array)) THEN IF (SIZE(array) /= n) THEN - CPErrorMessage(cp_warning_level,routineP,'size has changed',error) + CPErrorMessage(cp_warning_level,routineP,'size has changed') DEALLOCATE(array, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF IF (.NOT.ASSOCIATED(array)) THEN ALLOCATE(array(n), stat=stat) - CPPostcondition(stat==0, cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0, cp_failure_level,routineP,failure) END IF END IF failureIf END SUBROUTINE cp_1d_r_guarantee_size @@ -263,8 +254,6 @@ END SUBROUTINE cp_1d_r_guarantee_size !> \param array the array to reallocate if necessary !> \param n_rows the wanted number of rows !> \param n_cols the wanted number of cols -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 5.2001 first version [fawzi] !> \author Fawzi Mohamed @@ -272,10 +261,9 @@ END SUBROUTINE cp_1d_r_guarantee_size !> this is a different behaviour than the realloc in the module !> memory_utilities. It is quite low level ! ***************************************************************************** - SUBROUTINE cp_2d_r_guarantee_size(array, n_rows, n_cols, error) + SUBROUTINE cp_2d_r_guarantee_size(array, n_rows, n_cols) REAL(kind=dp), POINTER :: array(:,:) INTEGER, INTENT(in) :: n_rows, n_cols - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_2d_r_guarantee_size', & routineP = moduleN//':'//routineN @@ -285,20 +273,20 @@ SUBROUTINE cp_2d_r_guarantee_size(array, n_rows, n_cols, error) failure=.FALSE. - CPPrecondition(n_cols>=0,cp_failure_level,routineP,error,failure) - CPPrecondition(n_rows>=0,cp_failure_level,routineP,error,failure) + CPPrecondition(n_cols>=0,cp_failure_level,routineP,failure) + CPPrecondition(n_rows>=0,cp_failure_level,routineP,failure) failureIf: IF (.NOT. failure) THEN IF (ASSOCIATED(array)) THEN IF (SIZE(array,1) /= n_rows .OR. SIZE(array,2) /= n_cols) THEN - CPErrorMessage(cp_warning_level,routineP,'size has changed',error) + CPErrorMessage(cp_warning_level,routineP,'size has changed') DEALLOCATE(array, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(array) END IF END IF IF (.NOT.ASSOCIATED(array)) THEN ALLOCATE(array(n_rows,n_cols), stat=stat) - CPPostconditionNoFail(stat==0, cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0, cp_failure_level,routineP) END IF END IF failureIf END SUBROUTINE cp_2d_r_guarantee_size @@ -312,8 +300,6 @@ END SUBROUTINE cp_2d_r_guarantee_size !> \param el the element to look for !> \param l_index the lower index for binary search (defaults to 1) !> \param u_index the upper index for binary search (defaults to size(array)) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 06.2003 created [fawzi] @@ -321,11 +307,10 @@ END SUBROUTINE cp_2d_r_guarantee_size !> \note !> the array should be ordered in growing order ! ***************************************************************************** -FUNCTION cp_1d_r_bsearch(array, el, l_index, u_index, error)& +FUNCTION cp_1d_r_bsearch(array, el, l_index, u_index)& RESULT(res) REAL(kind=dp), INTENT(in) :: array(:), el INTEGER, INTENT(in), OPTIONAL :: l_index, u_index - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_1d_r_bsearch', & diff --git a/src/common/cp_common_uses.f90 b/src/common/cp_common_uses.f90 index 940825195c..775087a295 100644 --- a/src/common/cp_common_uses.f90 +++ b/src/common/cp_common_uses.f90 @@ -21,13 +21,11 @@ cp_add_default_logger,& cp_rm_default_logger,& cp_to_string - USE cp_error_handling, ONLY: cp_error_type,& - cp_debug,& + USE cp_error_handling, ONLY: cp_debug,& cp_assertion_failed,& cp_internal_error,& cp_assert,& cp_unimplemented_error,& - cp_error_get_logger,& cp_precondition_failed,& cp_caller_error,& cp_wrong_args_error,& @@ -66,24 +64,24 @@ ! We are trying to use a small amount of characters ! the test is not inlined (you have always a function call) -#define CPPrecondition(cond,level,routineP,error,failure) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error,failure) -#define CPPostcondition(cond,level,routineP,error,failure) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error,failure) -#define CPInvariant(cond,level,routineP,error,failure) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error,failure) -#define CPAssert(cond,level,routineP,error,failure) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error,failure) -#define CPErrorMessage(level,routineP,msg,error) \ -CALL cp_error_message(level,routineP,msg,error) -#define CPPreconditionNoFail(cond,level,routineP,error) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error) -#define CPPostconditionNoFail(cond,level,routineP,error) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error) -#define CPInvariantNoFail(cond,level,routineP,error) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error) -#define CPAssertNoFail(cond,level,routineP,error) \ -IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,error) +#define CPPrecondition(cond,level,routineP,failure) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,failure) +#define CPPostcondition(cond,level,routineP,failure) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,failure) +#define CPInvariant(cond,level,routineP,failure) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,failure) +#define CPAssert(cond,level,routineP,failure) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__,failure) +#define CPErrorMessage(level,routineP,msg) \ +CALL cp_error_message(level,routineP,msg) +#define CPPreconditionNoFail(cond,level,routineP) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__) +#define CPPostconditionNoFail(cond,level,routineP) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__) +#define CPInvariantNoFail(cond,level,routineP) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__) +#define CPAssertNoFail(cond,level,routineP) \ +IF(.NOT.(cond))CALL cp_a_l(level,routineP,__LINE__) #define CPPreconditionNoErr(cond, level, routineN) \ IF(.NOT.(cond))CALL cp_a_l(level,routineN,__LINE__) #define CPPostconditionNoErr(cond, level, routineN) \ diff --git a/src/common/cp_error_handling.F b/src/common/cp_error_handling.F index 2adda8e453..17c292f546 100644 --- a/src/common/cp_error_handling.F +++ b/src/common/cp_error_handling.F @@ -43,8 +43,6 @@ MODULE cp_error_handling LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.FALSE. CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_error_handling' - !API types - PUBLIC :: cp_error_type, cp_error_get_logger !API parameters var PUBLIC :: cp_debug, cp_no_error, cp_caller_error, cp_wrong_args_error,& cp_precondition_failed, cp_internal_error, cp_postcondition_failed,& @@ -83,64 +81,9 @@ MODULE cp_error_handling !! error number: not implemented INTEGER, PARAMETER :: cp_unimplemented_error_nr = -1000 -! ***************************************************************************** -!> \brief this type represent a structure that can be passed to -!> the functions to change their error behaviour. -!> It should always be initialized with cp_error_init before use -!> \param initialized true if initialized (just for bug catching) -!> \param logger a pointer to the logger where error logs should go -!> (if null they go to cp_default_logger) -!> \param stop_level the level at which the execution stops -!> \param print_level starting at which level something gets printed -!> \param level level of the error (0 = cp_note_level=no error, -!> cp_warning_level, cp_failure_level or cp_fatal_level=3). -!> Definition of these constants is in cp_log_handling. -!> \param error_nr the number of the error (0 = no error) -!> \param info some additional info to store (error message, string ...) -!> \note -!> if one of level or error_nr is different from 0 then both must be -!> different from 0. -!> \par History -!> none -!> \author Fawzi Mohamed -!> @version 2.2002 -! ***************************************************************************** - TYPE cp_error_type - ! empty :-) - PRIVATE - INTEGER :: dummy = 42 ! ifort workaround - END TYPE cp_error_type CONTAINS -! ***************************************************************************** -!> \brief gets the logger of the given error. -!> The error argument is optional, so you can get the logger -!> of an optional dummy argument. -!> If the error is not present or its logger is not associated -!> returns the default logger. -!> \param error the error you take the info from (optional) -!> \retval res ... -!> \par History -!> none -!> \author Fawzi Mohamed -!> @version 1.2002 -! ***************************************************************************** - FUNCTION cp_error_get_logger(error) RESULT(res) - TYPE(cp_error_type), INTENT(in), & - OPTIONAL :: error - TYPE(cp_logger_type), POINTER :: res - - NULLIFY(res) - res => cp_get_default_logger() - IF (.NOT.ASSOCIATED(res)) THEN - CALL cp_error_common_stop('cp_error_handling:cp_error_get_logger',& - ' cp_default_logger is not associated') - END IF - END FUNCTION cp_error_get_logger - -! =================== error handling =================== - ! ***************************************************************************** !> \brief a subroutine that call just stop, useful because all the failures !> fails calling this routine: the right point to set a breakpoint @@ -170,21 +113,18 @@ END SUBROUTINE cp_error_common_stop !> \param fromWhere a string that contains the module name and routine name !> where this test happened !> \param message the error message -!> \param error the error type that controls error reporting (optional) !> \par History !> none !> \author Fawzi Mohamed !> @version 1.2002 ! ***************************************************************************** - SUBROUTINE cp_error_message(level, fromWhere, message, error) + SUBROUTINE cp_error_message(level, fromWhere, message) INTEGER, INTENT(in) :: level CHARACTER(len=*), INTENT(in) :: fromWhere, message - TYPE(cp_error_type), INTENT(in), & - OPTIONAL :: error TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL cp_log(logger, level, fromWhere, message,local=.TRUE.) END SUBROUTINE cp_error_message @@ -199,7 +139,6 @@ END SUBROUTINE cp_error_message !> \param fromWhere a string that contains the module name and routine name !> where this test happened !> \param message the error message -!> \param error the error type that controls error reporting (optional) !> \param failure is set to true if the condition is false otherwise !> it is not changed (optional) !> \param only_ionode ... @@ -209,13 +148,11 @@ END SUBROUTINE cp_error_message !> @version 1.2002 ! ***************************************************************************** SUBROUTINE cp_assert(condition, level, error_nr, fromWhere, & - message, error,failure,only_ionode) + message,failure,only_ionode) !! the condition that is checked, if false, an error did happen LOGICAL, INTENT(in) :: condition INTEGER, INTENT(in) :: level, error_nr CHARACTER(len=*), INTENT(in) :: fromWhere, message - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error LOGICAL, INTENT(inout), OPTIONAL :: failure LOGICAL, INTENT(in), OPTIONAL :: only_ionode @@ -227,7 +164,7 @@ SUBROUTINE cp_assert(condition, level, error_nr, fromWhere, & IF (.NOT. condition) THEN IF (PRESENT(failure)) failure=.TRUE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() myonly_ionode = .FALSE. IF(PRESENT(only_ionode)) myonly_ionode = only_ionode @@ -253,19 +190,15 @@ END SUBROUTINE cp_assert !> \brief comodity call to signat that something is not implemented !> \param fromWhere routine where the error happened !> \param message the message to write out (UNIMPLEMENTED is added to it) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param error_level the error level of this error, defaults to !> cp_failure_level !> \par History !> 05.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_unimplemented_error(fromWhere, message, error, error_level) + SUBROUTINE cp_unimplemented_error(fromWhere, message,error_level) CHARACTER(len=*), INTENT(in) :: fromWhere CHARACTER(len=*), INTENT(in), OPTIONAL :: message - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error INTEGER, INTENT(in), OPTIONAL :: error_level CHARACTER(len=*), PARAMETER :: routineN = 'cp_unimplemented_error', & @@ -278,10 +211,10 @@ SUBROUTINE cp_unimplemented_error(fromWhere, message, error, error_level) IF(PRESENT(error_level)) err_l=error_level IF (PRESENT(message)) THEN CALL cp_assert(.FALSE.,err_l,cp_unimplemented_error_nr,& - fromWhere, "UNIMPLEMENTED, "//message, error=error) + fromWhere, "UNIMPLEMENTED, "//message) ELSE CALL cp_assert(.FALSE.,err_l,cp_unimplemented_error_nr,& - fromWhere, "UNIMPLEMENTED", error=error) + fromWhere, "UNIMPLEMENTED") END IF END SUBROUTINE cp_unimplemented_error @@ -291,25 +224,21 @@ END SUBROUTINE cp_unimplemented_error !> \param level ... !> \param fromWhere ... !> \param lineNr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param failure ... !> \par History !> 12.2002 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_a_l(level, fromWhere, lineNr, error, failure) + SUBROUTINE cp_a_l(level, fromWhere, lineNr,failure) INTEGER, INTENT(in) :: level CHARACTER(len=*), INTENT(in) :: fromWhere INTEGER, INTENT(in) :: lineNr - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error LOGICAL, INTENT(inout), OPTIONAL :: failure CALL cp_assert(.FALSE.,level=level,error_nr=cp_assertion_failed,& fromWhere=fromWhere,& message="condition FAILED at line "//TRIM(ADJUSTL(cp_to_string(lineNr))),& - error=error, failure=failure) + failure=failure) END SUBROUTINE cp_a_l END MODULE cp_error_handling diff --git a/src/common/cp_para_env.F b/src/common/cp_para_env.F index 0841b2bc4c..9efb1e78f9 100644 --- a/src/common/cp_para_env.F +++ b/src/common/cp_para_env.F @@ -38,19 +38,16 @@ MODULE cp_para_env !> \param mepos the id of the actual processor !> \param num_pe the number of processors in the group !> \param owns_group if the group is owned by this object (defaults to true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_para_env_create(para_env, group, source,mepos, num_pe,& - owns_group,error) + owns_group) TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(in) :: group INTEGER, INTENT(in), OPTIONAL :: source, mepos, num_pe LOGICAL, INTENT(in), OPTIONAL :: owns_group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_para_env_create', & routineP = moduleN//':'//routineN @@ -60,9 +57,9 @@ SUBROUTINE cp_para_env_create(para_env, group, source,mepos, num_pe,& failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(para_env),cp_failure_level,routineP,failure) ALLOCATE(para_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) para_env%group=group para_env%source=0 para_env%ref_count=1 @@ -70,7 +67,7 @@ SUBROUTINE cp_para_env_create(para_env, group, source,mepos, num_pe,& IF (PRESENT(source)) para_env%source=source IF (PRESENT(owns_group)) para_env%owns_group=owns_group IF (.NOT.(PRESENT(mepos).AND.PRESENT(num_pe))) THEN - CALL cp_para_env_update(para_env,error=error) + CALL cp_para_env_update(para_env) ELSE para_env%mepos=mepos para_env%num_pe=num_pe @@ -82,15 +79,12 @@ END SUBROUTINE cp_para_env_create !> \brief retains the para object (to be called when you want to keep a !> shared copy of this object) !> \param para_env the new group -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_para_env_retain(para_env, error) + SUBROUTINE cp_para_env_retain(para_env) TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_para_env_retain', & routineP = moduleN//':'//routineN @@ -99,8 +93,8 @@ SUBROUTINE cp_para_env_retain(para_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,failure) para_env%ref_count=para_env%ref_count+1 END SUBROUTINE cp_para_env_retain @@ -108,8 +102,6 @@ END SUBROUTINE cp_para_env_retain !> \brief releases the para object (to be called when you don't want anymore !> the shared copy of this object) !> \param para_env the new group -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -117,9 +109,8 @@ END SUBROUTINE cp_para_env_retain !> to avoid circular dependencies cp_log_handling has a private copy !> of this method (see cp_log_handling:my_cp_para_env_release)! ! ***************************************************************************** - SUBROUTINE cp_para_env_release(para_env, error) + SUBROUTINE cp_para_env_release(para_env) TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_para_env_release', & routineP = moduleN//':'//routineN @@ -130,14 +121,14 @@ SUBROUTINE cp_para_env_release(para_env, error) failure=.FALSE. IF (ASSOCIATED(para_env)) THEN - CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,failure) para_env%ref_count=para_env%ref_count-1 IF (para_env%ref_count<1) THEN IF (para_env%owns_group) THEN CALL mp_comm_free(para_env%group) END IF DEALLOCATE(para_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF NULLIFY(para_env) @@ -146,15 +137,12 @@ END SUBROUTINE cp_para_env_release ! ***************************************************************************** !> \brief gets again the position and size of the group from the mpi_group !> \param para_env the new group -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_para_env_update(para_env, error) + SUBROUTINE cp_para_env_update(para_env) TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_para_env_update', & routineP = moduleN//':'//routineN @@ -163,8 +151,8 @@ SUBROUTINE cp_para_env_update(para_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,failure) CALL mp_environ(taskid=para_env%mepos,numtask=para_env%num_pe,& groupid=para_env%group) para_env%ionode=para_env%mepos==para_env%source @@ -174,16 +162,13 @@ END SUBROUTINE cp_para_env_update !> \brief writes a description of the parallel environment to the given unit !> \param para_env the parallel environment to output !> \param unit_nr the unit where to output -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_para_env_write(para_env,unit_nr,error) +SUBROUTINE cp_para_env_write(para_env,unit_nr) TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_para_env_write', & routineP = moduleN//':'//routineN @@ -197,23 +182,23 @@ SUBROUTINE cp_para_env_write(para_env,unit_nr,error) WRITE (unit=unit_nr,& fmt="(' :{ owns_group=',l1,',')",& iostat=iostat) para_env%owns_group - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' group=',i10,', ref_count=',i10,',')",& iostat=iostat) para_env%group, para_env%ref_count - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' mepos=',i8,',')",& iostat=iostat) para_env%mepos - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' source=',i8,',')",& iostat=iostat) para_env%source - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' num_pe=',i8,'}')",& iostat=iostat) para_env%num_pe - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) ELSE WRITE (unit=unit_nr,& fmt="(a)", iostat=iostat) ' :*null* ' - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_para_env_write @@ -224,15 +209,12 @@ END SUBROUTINE cp_para_env_write !> \param ndims the number of dimensions of the cart !> \param owns_group if this object owns the underlying cart (and should !> free it) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE cp_cart_create(cart, group, ndims,owns_group, error) +SUBROUTINE cp_cart_create(cart, group, ndims,owns_group) TYPE(cp_para_cart_type), POINTER :: cart INTEGER, INTENT(in) :: group, ndims LOGICAL, INTENT(in), OPTIONAL :: owns_group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cart_create', & routineP = moduleN//':'//routineN @@ -242,9 +224,9 @@ SUBROUTINE cp_cart_create(cart, group, ndims,owns_group, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(cart),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(cart),cp_failure_level,routineP,failure) ALLOCATE(cart,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cart%owns_group=.TRUE. IF (PRESENT(owns_group)) cart%owns_group=owns_group cart%ndims=ndims @@ -252,26 +234,23 @@ SUBROUTINE cp_cart_create(cart, group, ndims,owns_group, error) ALLOCATE(cart%source(ndims),cart%periodic(ndims),cart%mepos(ndims),& cart%num_pe(ndims),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) cart%source=0 cart%mepos=0 cart%periodic=.FALSE. cart%ref_count=1 cart%ntask=1 - CALL cp_cart_update(cart,error=error) + CALL cp_cart_update(cart) END SUBROUTINE cp_cart_create ! ***************************************************************************** !> \brief updates the information about the given cart !> \param cart the cart to update -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE cp_cart_update(cart,error) +SUBROUTINE cp_cart_update(cart) TYPE(cp_para_cart_type), POINTER :: cart - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cart_update', & routineP = moduleN//':'//routineN @@ -280,8 +259,8 @@ SUBROUTINE cp_cart_update(cart,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(cart),cp_failure_level,routineP,error,failure) - CPPrecondition(cart%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cart),cp_failure_level,routineP,failure) + CPPrecondition(cart%ref_count>0,cp_failure_level,routineP,failure) CALL mp_environ( cart%group, cart%ndims, cart%num_pe, task_coor=cart%mepos, & periods=cart%periodic) CALL mp_environ( numtask=cart%ntask, taskid=cart%rank, groupid=cart%group) @@ -290,13 +269,10 @@ END SUBROUTINE cp_cart_update ! ***************************************************************************** !> \brief releases the given cart !> \param cart the cart to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE cp_cart_release(cart,error) +SUBROUTINE cp_cart_release(cart) TYPE(cp_para_cart_type), POINTER :: cart - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cart_release', & routineP = moduleN//':'//routineN @@ -307,16 +283,16 @@ SUBROUTINE cp_cart_release(cart,error) failure=.FALSE. IF (ASSOCIATED(cart)) THEN - CPPrecondition(cart%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(cart%ref_count>0,cp_failure_level,routineP,failure) cart%ref_count=cart%ref_count-1 IF (cart%ref_count==0) THEN IF (cart%owns_group) THEN CALL mp_comm_free(cart%group) END IF DEALLOCATE(cart%source,cart%periodic,cart%mepos,cart%num_pe,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(cart,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(cart) @@ -325,13 +301,10 @@ END SUBROUTINE cp_cart_release ! ***************************************************************************** !> \brief retains the given cart !> \param cart the cart to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE cp_cart_retain(cart,error) +SUBROUTINE cp_cart_retain(cart) TYPE(cp_para_cart_type), POINTER :: cart - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cart_retain', & routineP = moduleN//':'//routineN @@ -340,8 +313,8 @@ SUBROUTINE cp_cart_retain(cart,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(cart),cp_failure_level,routineP,error,failure) - CPPrecondition(cart%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cart),cp_failure_level,routineP,failure) + CPPrecondition(cart%ref_count>0,cp_failure_level,routineP,failure) cart%ref_count=cart%ref_count+1 END SUBROUTINE cp_cart_retain @@ -349,14 +322,11 @@ END SUBROUTINE cp_cart_retain !> \brief writes out the informations about the cart !> \param cart the parallel environment to output !> \param unit_nr the unit where to output -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_cart_write(cart,unit_nr,error) +SUBROUTINE cp_cart_write(cart,unit_nr) TYPE(cp_para_cart_type), POINTER :: cart INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cart_write', & routineP = moduleN//':'//routineN @@ -370,32 +340,32 @@ SUBROUTINE cp_cart_write(cart,unit_nr,error) WRITE (unit=unit_nr,& fmt="(' :{ owns_group=',l1,',')",& iostat=iostat) cart%owns_group - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' group=',i10,', ref_count=',i10,',')",& iostat=iostat) cart%group, cart%ref_count - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' ndims=',i8,',')",& iostat=iostat) cart%ndims - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' rank=',i8,', ntask=',i8,',')",& iostat=iostat) cart%rank, cart%ntask - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' mepos=',10i8)",& iostat=iostat) cart%mepos - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' source=',10i8,',')",& iostat=iostat) cart%source - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' num_pe=',10i8,'}')",& iostat=iostat) cart%num_pe - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' periodic=',10l2,'}')",& iostat=iostat) cart%periodic - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) ELSE WRITE (unit=unit_nr,& fmt="(a)", iostat=iostat) ' :*null* ' - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_cart_write diff --git a/src/common/cp_result_methods.F b/src/common/cp_result_methods.F index 76c67c8fa6..248b3b1c97 100644 --- a/src/common/cp_result_methods.F +++ b/src/common/cp_result_methods.F @@ -51,17 +51,15 @@ MODULE cp_result_methods !> \param results ... !> \param description ... !> \param values ... -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE put_result_r1(results,description,values,error) + SUBROUTINE put_result_r1(results,description,values) TYPE(cp_result_type), POINTER :: results CHARACTER(LEN=default_string_length) :: description REAL(KIND=dp), DIMENSION(:) :: values - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'put_result_r1', & routineP = moduleN//':'//routineN @@ -70,18 +68,18 @@ SUBROUTINE put_result_r1(results,description,values,error) LOGICAL :: check, failure failure=.FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) - CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) + CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,failure) check = SIZE(results%result_label)==SIZE(results%result_value) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) isize=SIZE(results%result_label) jsize=SIZE(values) CALL reallocate(results%result_label,1,isize+1) - CALL cp_result_value_p_reallocate(results%result_value,1,isize+1,error) + CALL cp_result_value_p_reallocate(results%result_value,1,isize+1) results%result_label(isize+1) = description - CALL cp_result_value_init(results%result_value(isize+1)%value, result_type_real, jsize, error) + CALL cp_result_value_init(results%result_value(isize+1)%value, result_type_real, jsize) results%result_value(isize+1)%value%real_type = values END SUBROUTINE put_result_r1 @@ -91,17 +89,15 @@ END SUBROUTINE put_result_r1 !> \param results ... !> \param description ... !> \param values ... -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE put_result_r2(results,description,values,error) + SUBROUTINE put_result_r2(results,description,values) TYPE(cp_result_type), POINTER :: results CHARACTER(LEN=default_string_length) :: description REAL(KIND=dp), DIMENSION(:, :) :: values - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'put_result_r2', & routineP = moduleN//':'//routineN @@ -110,18 +106,18 @@ SUBROUTINE put_result_r2(results,description,values,error) LOGICAL :: check, failure failure=.FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) - CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) + CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,failure) check = SIZE(results%result_label)==SIZE(results%result_value) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) isize=SIZE(results%result_label) jsize=SIZE(values,1)*SIZE(values,2) CALL reallocate(results%result_label,1,isize+1) - CALL cp_result_value_p_reallocate(results%result_value,1,isize+1,error) + CALL cp_result_value_p_reallocate(results%result_value,1,isize+1) results%result_label(isize+1) = description - CALL cp_result_value_init(results%result_value(isize+1)%value, result_type_real, jsize, error) + CALL cp_result_value_init(results%result_value(isize+1)%value, result_type_real, jsize) results%result_value(isize+1)%value%real_type = RESHAPE(values,(/jsize/)) END SUBROUTINE put_result_r2 @@ -130,16 +126,14 @@ END SUBROUTINE put_result_r2 !> \brief test for a certain result in the result_list !> \param results ... !> \param description ... -!> \param error ... !> \retval res_exist ... !> \par History !> 10.2013 !> \author Mandes ! ***************************************************************************** - FUNCTION test_for_result(results,description, error) RESULT(res_exist) + FUNCTION test_for_result(results,description) RESULT(res_exist) TYPE(cp_result_type), POINTER :: results CHARACTER(LEN=default_string_length) :: description - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res_exist CHARACTER(len=*), PARAMETER :: routineN = 'test_for_result', & @@ -149,7 +143,7 @@ FUNCTION test_for_result(results,description, error) RESULT(res_exist) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) nlist=SIZE(results%result_value) res_exist = .FALSE. DO i = 1, nlist @@ -170,18 +164,16 @@ END FUNCTION test_for_result !> which entry you want !> \param n_rep : integer indicating how many times the section exists in result_list !> \param n_entries : gets the number of lines used for a given description -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE get_result_r1(results,description,values,nval,n_rep,n_entries,error) + SUBROUTINE get_result_r1(results,description,values,nval,n_rep,n_entries) TYPE(cp_result_type), POINTER :: results CHARACTER(LEN=default_string_length) :: description REAL(KIND=dp), DIMENSION(:) :: values INTEGER, OPTIONAL :: nval, n_rep, n_entries - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_result_r1', & routineP = moduleN//':'//routineN @@ -191,10 +183,10 @@ SUBROUTINE get_result_r1(results,description,values,nval,n_rep,n_entries,error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) nlist=SIZE(results%result_value) - CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,error,failure) + CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,failure) + CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,failure) nrep = 0 DO i = 1, nlist IF(TRIM(results%result_label(i))==TRIM(description)) nrep = nrep + 1 @@ -224,9 +216,9 @@ SUBROUTINE get_result_r1(results,description,values,nval,n_rep,n_entries,error) IF(PRESENT(n_entries)) n_entries = size_res size_values = SIZE(values,1) IF(PRESENT(nval))THEN - CPPostcondition(size_res==size_values,cp_failure_level,routineP,error,failure) + CPPostcondition(size_res==size_values,cp_failure_level,routineP,failure) ELSE - CPPostcondition(nrep*size_res==size_values,cp_failure_level,routineP,error,failure) + CPPostcondition(nrep*size_res==size_values,cp_failure_level,routineP,failure) END IF k=0 DO i = 1,nlist @@ -254,18 +246,16 @@ END SUBROUTINE get_result_r1 !> which entry you want !> \param n_rep : integer indicating how many times the section exists in result_list !> \param n_entries : gets the number of lines used for a given description -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE get_result_r2(results,description,values,nval,n_rep,n_entries,error) + SUBROUTINE get_result_r2(results,description,values,nval,n_rep,n_entries) TYPE(cp_result_type), POINTER :: results CHARACTER(LEN=default_string_length) :: description REAL(KIND=dp), DIMENSION(:, :) :: values INTEGER, OPTIONAL :: nval, n_rep, n_entries - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_result_r2', & routineP = moduleN//':'//routineN @@ -275,10 +265,10 @@ SUBROUTINE get_result_r2(results,description,values,nval,n_rep,n_entries,error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) nlist=SIZE(results%result_value) - CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,error,failure) + CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,failure) + CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,failure) nrep = 0 DO i = 1, nlist IF(TRIM(results%result_label(i))==TRIM(description)) nrep = nrep + 1 @@ -308,9 +298,9 @@ SUBROUTINE get_result_r2(results,description,values,nval,n_rep,n_entries,error) IF(PRESENT(n_entries)) n_entries = size_res size_values = SIZE(values,1)*SIZE(values,2) IF(PRESENT(nval))THEN - CPPostcondition(size_res==size_values,cp_failure_level,routineP,error,failure) + CPPostcondition(size_res==size_values,cp_failure_level,routineP,failure) ELSE - CPPostcondition(nrep*size_res==size_values,cp_failure_level,routineP,error,failure) + CPPostcondition(nrep*size_res==size_values,cp_failure_level,routineP,failure) END IF k=0 DO i = 1,nlist @@ -337,17 +327,15 @@ END SUBROUTINE get_result_r2 !> \param n_rep : integer indicating how many times the section exists in result_list !> \param n_entries : gets the number of lines used for a given description !> \param type_in_use ... -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE get_nreps(results,description,n_rep,n_entries,type_in_use,error) + SUBROUTINE get_nreps(results,description,n_rep,n_entries,type_in_use) TYPE(cp_result_type), POINTER :: results CHARACTER(LEN=default_string_length) :: description INTEGER, OPTIONAL :: n_rep, n_entries, type_in_use - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_nreps', & routineP = moduleN//':'//routineN @@ -356,10 +344,10 @@ SUBROUTINE get_nreps(results,description,n_rep,n_entries,type_in_use,error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) nlist=SIZE(results%result_value) - CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,error,failure) + CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,failure) + CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,failure) IF(PRESENT(n_rep))THEN n_rep=0 DO i=1,nlist @@ -379,7 +367,7 @@ SUBROUTINE get_nreps(results,description,n_rep,n_entries,type_in_use,error) n_entries = n_entries + SIZE(results%result_value(i)%value%logical_type) CASE DEFAULT ! Type not implemented in cp_result_type - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT EXIT END IF @@ -401,18 +389,16 @@ END SUBROUTINE get_nreps !> \param description ... !> \param nval : if more than one entry for a given description is given you may choose !> which entry you want to delete -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE cp_results_erase(results,description,nval,error) + SUBROUTINE cp_results_erase(results,description,nval) TYPE(cp_result_type), POINTER :: results CHARACTER(LEN=default_string_length), & OPTIONAL :: description INTEGER, OPTIONAL :: nval - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_results_erase', & routineP = moduleN//':'//routineN @@ -423,10 +409,10 @@ SUBROUTINE cp_results_erase(results,description,nval,error) TYPE(cp_result_type), POINTER :: clean_results failure = .FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) new_size = 0 IF(PRESENT(description))THEN - CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) + CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,failure) nlist=SIZE(results%result_value) nrep=0 DO i=1,nlist @@ -448,18 +434,18 @@ SUBROUTINE cp_results_erase(results,description,nval,error) END IF END IF END DO - CPPostcondition(nlist-entry_deleted>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(nlist-entry_deleted>=0,cp_failure_level,routineP,failure) new_size = nlist-entry_deleted NULLIFY(clean_results) - CALL cp_result_create(clean_results, error) - CALL cp_result_clean(clean_results, error) + CALL cp_result_create(clean_results) + CALL cp_result_clean(clean_results) ALLOCATE(clean_results%result_label(new_size), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(clean_results%result_value(new_size), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, new_size NULLIFY(clean_results%result_value(i)%value) - CALL cp_result_value_create(clean_results%result_value(i)%value, error) + CALL cp_result_value_create(clean_results%result_value(i)%value) END DO k = 0 DO i =1,nlist @@ -467,18 +453,18 @@ SUBROUTINE cp_results_erase(results,description,nval,error) k = k + 1 clean_results%result_label(k) = results%result_label(i) CALL cp_result_value_copy(clean_results%result_value(k)%value,& - results%result_value(i)%value, error) + results%result_value(i)%value) END IF END DO - CALL cp_result_copy(clean_results, results, error) - CALL cp_result_release(clean_results, error) + CALL cp_result_copy(clean_results, results) + CALL cp_result_release(clean_results) END IF ELSE - CALL cp_result_clean(results, error) + CALL cp_result_clean(results) ALLOCATE(results%result_label(new_size), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(results%result_value(new_size), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_results_erase @@ -487,14 +473,12 @@ END SUBROUTINE cp_results_erase !> \param results ... !> \param source ... !> \param para_env ... -!> \param error ... !> \author 10.2008 Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE cp_results_mp_bcast(results, source, para_env, error) + SUBROUTINE cp_results_mp_bcast(results, source, para_env) TYPE(cp_result_type), POINTER :: results INTEGER, INTENT(IN) :: source TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_results_mp_bcast', & routineP = moduleN//':'//routineN @@ -504,37 +488,36 @@ SUBROUTINE cp_results_mp_bcast(results, source, para_env, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,failure) nlist = 0 IF (para_env%mepos==source) nlist = SIZE(results%result_value) CALL mp_bcast(nlist, source, para_env%group) ALLOCATE(size_value(nlist), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(type_in_use(nlist), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (para_env%mepos==source) THEN DO i = 1, nlist CALL get_nreps(results,description=results%result_label(i),& - n_entries=size_value(i),type_in_use=type_in_use(i),& - error=error) + n_entries=size_value(i),type_in_use=type_in_use(i)) END DO END IF CALL mp_bcast(size_value, source, para_env%group) CALL mp_bcast(type_in_use, source, para_env%group) IF (para_env%mepos/=source) THEN - CALL cp_result_clean(results, error) + CALL cp_result_clean(results) ALLOCATE(results%result_value(nlist),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(results%result_label(nlist),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nlist results%result_label(i) = "" NULLIFY(results%result_value(i)%value) - CALL cp_result_value_create(results%result_value(i)%value,error) + CALL cp_result_value_create(results%result_value(i)%value) CALL cp_result_value_init(results%result_value(i)%value,& - type_in_use=type_in_use(i),size_value=size_value(i), error=error) + type_in_use=type_in_use(i),size_value=size_value(i)) END DO END IF DO i = 1, nlist @@ -548,13 +531,13 @@ SUBROUTINE cp_results_mp_bcast(results, source, para_env, error) CALL mp_bcast(results%result_value(i)%value%logical_type, source, para_env%group) CASE DEFAULT ! Type not implemented in cp_result_type - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO DEALLOCATE(type_in_use, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(size_value, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE cp_results_mp_bcast END MODULE cp_result_methods diff --git a/src/common/cp_result_types.F b/src/common/cp_result_types.F index cdc71c0cf9..6664ce4598 100644 --- a/src/common/cp_result_types.F +++ b/src/common/cp_result_types.F @@ -87,15 +87,13 @@ MODULE cp_result_types ! ***************************************************************************** !> \brief Allocates and intitializes the cp_result !> \param results ... -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE cp_result_create(results,error) + SUBROUTINE cp_result_create(results) TYPE(cp_result_type), POINTER :: results - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_create', & routineP = moduleN//':'//routineN @@ -106,28 +104,26 @@ SUBROUTINE cp_result_create(results,error) CALL timeset(routineN,handle) failure=.FALSE. ALLOCATE(results, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(results%result_value, results%result_label) results%ref_count=1 ALLOCATE(results%result_label(0), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(results%result_value(0), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE cp_result_create ! ***************************************************************************** !> \brief Releases cp_result type !> \param results ... -!> \param error ... !> \par History !> 12.2007 created !> 10.2008 Teodoro Laino [tlaino] - major rewriting !> \author fschiff ! ***************************************************************************** - SUBROUTINE cp_result_release(results,error) + SUBROUTINE cp_result_release(results) TYPE(cp_result_type), POINTER :: results - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_release', & routineP = moduleN//':'//routineN @@ -138,24 +134,24 @@ SUBROUTINE cp_result_release(results,error) CALL timeset(routineN,handle) failure=.FALSE. IF(ASSOCIATED(results))THEN - CPPrecondition(results%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(results%ref_count>0,cp_failure_level,routineP,failure) results%ref_count=results%ref_count-1 IF (results%ref_count==0) THEN ! Description IF(ASSOCIATED(results%result_label))THEN DEALLOCATE(results%result_label,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Values IF(ASSOCIATED(results%result_value))THEN DO i = 1, SIZE(results%result_value) - CALL cp_result_value_release(results%result_value(i)%value, error) + CALL cp_result_value_release(results%result_value(i)%value) END DO DEALLOCATE(results%result_value,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(results,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF CALL timestop(handle) @@ -164,12 +160,10 @@ END SUBROUTINE cp_result_release ! ***************************************************************************** !> \brief Releases cp_result clean !> \param results ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2008 ! ***************************************************************************** - SUBROUTINE cp_result_clean(results,error) + SUBROUTINE cp_result_clean(results) TYPE(cp_result_type), POINTER :: results - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_clean', & routineP = moduleN//':'//routineN @@ -183,15 +177,15 @@ SUBROUTINE cp_result_clean(results,error) ! Description IF(ASSOCIATED(results%result_label))THEN DEALLOCATE(results%result_label,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Values IF(ASSOCIATED(results%result_value))THEN DO i = 1, SIZE(results%result_value) - CALL cp_result_value_release(results%result_value(i)%value, error) + CALL cp_result_value_release(results%result_value(i)%value) END DO DEALLOCATE(results%result_value,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF CALL timestop(handle) @@ -200,14 +194,12 @@ END SUBROUTINE cp_result_clean ! ***************************************************************************** !> \brief Retains cp_result type !> \param results ... -!> \param error ... !> \par History !> 12.2007 created !> \author fschiff ! ***************************************************************************** - SUBROUTINE cp_result_retain(results,error) + SUBROUTINE cp_result_retain(results) TYPE(cp_result_type), POINTER :: results - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_retain', & routineP = moduleN//':'//routineN @@ -215,20 +207,18 @@ SUBROUTINE cp_result_retain(results,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) - CPPrecondition(results%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(results),cp_failure_level,routineP,failure) + CPPrecondition(results%ref_count>0,cp_failure_level,routineP,failure) results%ref_count=results%ref_count+1 END SUBROUTINE cp_result_retain ! ***************************************************************************** !> \brief Allocates and intitializes the cp_result_value type !> \param value ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE cp_result_value_create(value,error) + SUBROUTINE cp_result_value_create(value) TYPE(cp_result_value_type), POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_value_create', & routineP = moduleN//':'//routineN @@ -239,7 +229,7 @@ SUBROUTINE cp_result_value_create(value,error) CALL timeset(routineN,handle) failure=.FALSE. ALLOCATE(value, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) value%type_in_use = -1 NULLIFY(value%real_type) NULLIFY(value%logical_type) @@ -252,13 +242,11 @@ END SUBROUTINE cp_result_value_create !> \param value ... !> \param type_in_use ... !> \param size_value ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE cp_result_value_init(value, type_in_use, size_value, error) + SUBROUTINE cp_result_value_init(value, type_in_use, size_value) TYPE(cp_result_value_type), POINTER :: value INTEGER, INTENT(IN) :: type_in_use, size_value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_value_init', & routineP = moduleN//':'//routineN @@ -268,21 +256,21 @@ SUBROUTINE cp_result_value_init(value, type_in_use, size_value, error) CALL timeset(routineN,handle) failure=.FALSE. - CPPostcondition(ASSOCIATED(value),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(value),cp_failure_level,routineP,failure) value%type_in_use = type_in_use SELECT CASE(value%type_in_use) CASE(result_type_real) ALLOCATE(value%real_type(size_value),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(result_type_integer) ALLOCATE(value%integer_type(size_value),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(result_type_logical) ALLOCATE(value%logical_type(size_value),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE DEFAULT ! Type not implemented in cp_result_type - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) END SUBROUTINE cp_result_value_init @@ -290,12 +278,10 @@ END SUBROUTINE cp_result_value_init ! ***************************************************************************** !> \brief Releases the cp_result_value type !> \param value ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE cp_result_value_release(value,error) + SUBROUTINE cp_result_value_release(value) TYPE(cp_result_value_type), POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_value_release', & routineP = moduleN//':'//routineN @@ -310,30 +296,30 @@ SUBROUTINE cp_result_value_release(value,error) CASE(result_type_real) IF (ASSOCIATED(value%real_type)) THEN DEALLOCATE(value%real_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CPPostcondition(.NOT.ASSOCIATED(value%integer_type),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(value%logical_type),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(value%integer_type),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(value%logical_type),cp_failure_level,routineP,failure) CASE(result_type_integer) IF (ASSOCIATED(value%integer_type)) THEN DEALLOCATE(value%integer_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CPPostcondition(.NOT.ASSOCIATED(value%real_type),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(value%logical_type),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(value%real_type),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(value%logical_type),cp_failure_level,routineP,failure) CASE(result_type_logical) IF (ASSOCIATED(value%logical_type)) THEN DEALLOCATE(value%logical_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CPPostcondition(.NOT.ASSOCIATED(value%integer_type),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(value%real_type),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(value%integer_type),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(value%real_type),cp_failure_level,routineP,failure) CASE DEFAULT ! Type not implemented in cp_result_type - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT DEALLOCATE(value,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE cp_result_value_release @@ -342,12 +328,10 @@ END SUBROUTINE cp_result_value_release !> \brief Copies the cp_result type !> \param results_in ... !> \param results_out ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE cp_result_copy(results_in, results_out, error) + SUBROUTINE cp_result_copy(results_in, results_out) TYPE(cp_result_type), POINTER :: results_in, results_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_copy', & routineP = moduleN//':'//routineN @@ -357,22 +341,22 @@ SUBROUTINE cp_result_copy(results_in, results_out, error) CALL timeset(routineN,handle) failure=.FALSE. - CPPostcondition(ASSOCIATED(results_in),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(results_out),cp_failure_level,routineP,error,failure) - CALL cp_result_clean(results_out,error) + CPPostcondition(ASSOCIATED(results_in),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(results_out),cp_failure_level,routineP,failure) + CALL cp_result_clean(results_out) check = SIZE(results_in%result_label)==SIZE(results_in%result_value) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ndim = SIZE(results_in%result_value) ALLOCATE(results_out%result_label(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(results_out%result_value(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, ndim results_out%result_label(i) = results_in%result_label(i) - CALL cp_result_value_create(results_out%result_value(i)%value, error) + CALL cp_result_value_create(results_out%result_value(i)%value) CALL cp_result_value_copy(results_out%result_value(i)%value,& - results_in%result_value(i)%value, error) + results_in%result_value(i)%value) END DO CALL timestop(handle) END SUBROUTINE cp_result_copy @@ -381,12 +365,10 @@ END SUBROUTINE cp_result_copy !> \brief Copies the cp_result_value type !> \param value_out ... !> \param value_in ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE cp_result_value_copy(value_out, value_in, error) + SUBROUTINE cp_result_value_copy(value_out, value_in) TYPE(cp_result_value_type), POINTER :: value_out, value_in - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_value_copy', & routineP = moduleN//':'//routineN @@ -396,28 +378,28 @@ SUBROUTINE cp_result_value_copy(value_out, value_in, error) CALL timeset(routineN,handle) failure=.FALSE. - CPPostcondition(ASSOCIATED(value_in),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(value_out),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(value_in),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(value_out),cp_failure_level,routineP,failure) value_out%type_in_use = value_in%type_in_use SELECT CASE(value_out%type_in_use) CASE(result_type_real) isize = SIZE(value_in%real_type) ALLOCATE(value_out%real_type(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) value_out%real_type = value_in%real_type CASE(result_type_integer) isize = SIZE(value_in%integer_type) ALLOCATE(value_out%integer_type(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) value_out%integer_type = value_in%integer_type CASE(result_type_logical) isize = SIZE(value_in%logical_type) ALLOCATE(value_out%logical_type(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) value_out%logical_type = value_in%logical_type CASE DEFAULT ! Type not implemented in cp_result_type - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) END SUBROUTINE cp_result_value_copy @@ -427,14 +409,12 @@ END SUBROUTINE cp_result_value_copy !> \param result_value ... !> \param istart ... !> \param iend ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE cp_result_value_p_reallocate(result_value, istart, iend, error) + SUBROUTINE cp_result_value_p_reallocate(result_value, istart, iend) TYPE(cp_result_value_p_type), & DIMENSION(:), POINTER :: result_value INTEGER, INTENT(in) :: istart, iend - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_result_value_p_reallocate', & routineP = moduleN//':'//routineN @@ -455,17 +435,17 @@ SUBROUTINE cp_result_value_p_reallocate(result_value, istart, iend, error) END IF ! Allocate and copy new values while releases old ALLOCATE(tmp_value(istart:iend), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = istart, iend NULLIFY(tmp_value(i)%value) - CALL cp_result_value_create(tmp_value(i)%value, error) + CALL cp_result_value_create(tmp_value(i)%value) IF ((i<=ub_size).AND.(i>=lb_size)) THEN - CALL cp_result_value_copy(tmp_value(i)%value, result_value(i)%value, error) - CALL cp_result_value_release(result_value(i)%value, error) + CALL cp_result_value_copy(tmp_value(i)%value, result_value(i)%value) + CALL cp_result_value_release(result_value(i)%value) END IF END DO DEALLOCATE(result_value, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) result_value => tmp_value CALL timestop(handle) END SUBROUTINE cp_result_value_p_reallocate diff --git a/src/common/cp_units.F b/src/common/cp_units.F index 23e3774781..dcd5993b4d 100644 --- a/src/common/cp_units.F +++ b/src/common/cp_units.F @@ -158,14 +158,11 @@ MODULE cp_units !> \brief creates a unit parsing a string !> \param unit the unit to initialize !> \param string the string containing the description of the unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_unit_create(unit, string, error) + SUBROUTINE cp_unit_create(unit, string) TYPE(cp_unit_type), POINTER :: unit CHARACTER(len=*), INTENT(in) :: string - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_create', & routineP = moduleN//':'//routineN @@ -203,7 +200,7 @@ SUBROUTINE cp_unit_create(unit, string, error) CALL cp_assert(.FALSE.,cp_failure_level,& cp_assertion_failed,routineP,& "Maximum number of combined units exceeded",& - error,failure) + failure) EXIT END IF ! read unit @@ -369,11 +366,11 @@ SUBROUTINE cp_unit_create(unit, string, error) cp_assertion_failed,routineP,& "au unit without specifing its kind not accepted, use "//& "(au_e, au_f, au_t, au_temp, au_l, au_m, au_p, au_pot)",& - error,failure) + failure) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Unknown unit: "//string(i_low:i_high-1),& - error,failure) + failure) END SELECT power(i_unit)=next_power ! parse op @@ -410,7 +407,7 @@ SUBROUTINE cp_unit_create(unit, string, error) CALL cp_assert(.FALSE.,cp_failure_level,& cp_assertion_failed,routineP,& "an integer number is expected after a '^'",& - error,failure) + failure) EXIT END IF formatstr="(i"//cp_to_string(i_high-i_low+1)//")" @@ -451,8 +448,8 @@ SUBROUTINE cp_unit_create(unit, string, error) ENDIF END DO CALL cp_unit_create2(unit,kind_id=kind_id, unit_id=unit_id, & - power=power, error=error) - desc=cp_unit_desc(unit,error=error) + power=power) + desc=cp_unit_desc(unit) END SUBROUTINE cp_unit_create ! ***************************************************************************** @@ -463,16 +460,13 @@ END SUBROUTINE cp_unit_create !> cp_ukind_* !> \param unit_id the actual unit (use constants cp_units_*) !> \param power ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_unit_create2(unit, kind_id, unit_id, power, error) + SUBROUTINE cp_unit_create2(unit, kind_id, unit_id, power) TYPE(cp_unit_type), POINTER :: unit INTEGER, DIMENSION(:), INTENT(in) :: kind_id, unit_id INTEGER, DIMENSION(:), INTENT(in), & OPTIONAL :: power - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_create2', & routineP = moduleN//':'//routineN @@ -482,11 +476,11 @@ SUBROUTINE cp_unit_create2(unit, kind_id, unit_id, power, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(unit),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(kind_id)<=cp_unit_max_kinds,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(unit_id)<=cp_unit_max_kinds,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(unit),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(kind_id)<=cp_unit_max_kinds,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(unit_id)<=cp_unit_max_kinds,cp_failure_level,routineP,failure) ALLOCATE(unit,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) unit%ref_count=1 last_unit_id=last_unit_id+1 unit%id_nr=last_unit_id @@ -561,22 +555,19 @@ SUBROUTINE cp_unit_create2(unit, kind_id, unit_id, power, error) END IF ! check unit failure=failure.OR..NOT.cp_basic_unit_check(basic_kind=unit%kind_id(i),& - basic_unit=unit%unit_id(i),error=error) + basic_unit=unit%unit_id(i)) END DO END SUBROUTINE cp_unit_create2 ! ***************************************************************************** !> \brief retains the given unit !> \param unit the unit to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> at the moment not needed, there for completeness ! ***************************************************************************** - SUBROUTINE cp_unit_retain(unit,error) + SUBROUTINE cp_unit_retain(unit) TYPE(cp_unit_type), POINTER :: unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_retain', & routineP = moduleN//':'//routineN @@ -585,23 +576,20 @@ SUBROUTINE cp_unit_retain(unit,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(unit),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(unit%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(unit),cp_failure_level,routineP,failure) + CPPreconditionNoFail(unit%ref_count>0,cp_failure_level,routineP) unit%ref_count=unit%ref_count+1 END SUBROUTINE cp_unit_retain ! ***************************************************************************** !> \brief releases the given unit !> \param unit the unit to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> at the moment not needed, there for completeness ! ***************************************************************************** - SUBROUTINE cp_unit_release(unit,error) + SUBROUTINE cp_unit_release(unit) TYPE(cp_unit_type), POINTER :: unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_release', & routineP = moduleN//':'//routineN @@ -612,11 +600,11 @@ SUBROUTINE cp_unit_release(unit,error) failure=.FALSE. IF (ASSOCIATED(unit)) THEN - CPPreconditionNoFail(unit%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(unit%ref_count>0,cp_failure_level,routineP) unit%ref_count=unit%ref_count-1 IF (unit%ref_count==0) THEN DEALLOCATE(unit,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE cp_unit_release @@ -627,16 +615,13 @@ END SUBROUTINE cp_unit_release !> \param basic_unit the unit to check !> \param error_level error level of the errors due to invalid values. !> Defaults to cp_failure_level -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& + FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level)& RESULT(res) INTEGER, INTENT(in) :: basic_kind, basic_unit INTEGER, INTENT(in), OPTIONAL :: error_level - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_basic_unit_check', & @@ -656,7 +641,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown undef unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_energy) SELECT CASE (basic_unit) @@ -666,7 +651,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown energy unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_length) SELECT CASE (basic_unit) @@ -675,7 +660,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown length unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_temperature) SELECT CASE (basic_unit) @@ -683,7 +668,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown temperature unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_pressure) SELECT CASE (basic_unit) @@ -691,7 +676,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown pressure unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_angle) SELECT CASE (basic_unit) @@ -699,7 +684,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown angle unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_time) SELECT CASE (basic_unit) @@ -707,7 +692,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown time unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_mass) SELECT CASE (basic_unit) @@ -715,7 +700,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown mass unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_potential) SELECT CASE (basic_unit) @@ -723,7 +708,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown potential unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_force) SELECT CASE (basic_unit) @@ -731,7 +716,7 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown force unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_none) IF(basic_unit/=cp_units_none)& @@ -739,11 +724,11 @@ FUNCTION cp_basic_unit_check(basic_kind,basic_unit,error_level,error)& cp_assertion_failed, routineP,& "if the kind of the unit is none also unit must be undefined,not:"& //TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown kind of unit:"//TRIM(cp_to_string(basic_kind)),& - error,failure) + failure) END SELECT res=.not.failure END FUNCTION cp_basic_unit_check @@ -754,16 +739,13 @@ END FUNCTION cp_basic_unit_check !> \param basic_kind the kind of the unit of the value !> \param basic_unit the unit of the value !> \param power the power of the unit (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT(res) + FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power) RESULT(res) REAL(kind=dp), INTENT(in) :: value INTEGER, INTENT(in) :: basic_kind, basic_unit INTEGER, INTENT(in), OPTIONAL :: power - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_basic_unit_to_cp2k', & @@ -780,7 +762,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CALL cp_assert(basic_kind==cp_units_none,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(cp_to_string(basic_unit)),error,failure) + TRIM(cp_to_string(basic_unit)),failure) END IF SELECT CASE(basic_kind) CASE(cp_ukind_undef) @@ -790,7 +772,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown energy unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_energy) SELECT CASE (basic_unit) @@ -817,7 +799,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown energy unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_length) SELECT CASE (basic_unit) @@ -834,7 +816,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown length unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_temperature) SELECT CASE (basic_unit) @@ -845,7 +827,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown temperature unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_pressure) SELECT CASE (basic_unit) @@ -866,7 +848,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown pressure unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_angle) SELECT CASE (basic_unit) @@ -877,7 +859,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown angle unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_time) SELECT CASE (basic_unit) @@ -894,7 +876,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown time unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_mass) SELECT CASE (basic_unit) @@ -907,7 +889,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown mass unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_potential) SELECT CASE (basic_unit) @@ -918,7 +900,7 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown potential unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_force) SELECT CASE (basic_unit) @@ -931,18 +913,18 @@ FUNCTION cp_basic_unit_to_cp2k(value,basic_kind,basic_unit,power,error) RESULT( CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown force unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_none) CALL cp_assert(.FALSE.,my_error_level,& cp_assertion_failed, routineP,& "if the kind of the unit is none also unit must be undefined,not:"& //TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown kind of unit:"//TRIM(cp_to_string(basic_kind)),& - error,failure) + failure) END SELECT END FUNCTION cp_basic_unit_to_cp2k @@ -952,17 +934,14 @@ END FUNCTION cp_basic_unit_to_cp2k !> \param basic_unit the unit of the value !> \param power the power of the unit (defaults to 1) !> \param accept_undefined ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& + FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined)& RESULT(res) INTEGER, INTENT(in) :: basic_kind, basic_unit INTEGER, INTENT(in), OPTIONAL :: power LOGICAL, INTENT(in), OPTIONAL :: accept_undefined - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=cp_unit_basic_desc_length) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_basic_unit_desc', & @@ -982,7 +961,7 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined.OR.basic_kind/=cp_units_none,& my_error_level,cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(cp_to_string(basic_kind)),error,failure) + TRIM(cp_to_string(basic_kind)),failure) END IF SELECT CASE(basic_kind) CASE(cp_ukind_undef) @@ -993,7 +972,7 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(.FALSE.,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) END SELECT CASE(cp_ukind_energy) SELECT CASE (basic_unit) @@ -1022,11 +1001,11 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown energy unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_length) SELECT CASE (basic_unit) @@ -1044,7 +1023,7 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& res="length" CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown length unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_temperature) SELECT CASE (basic_unit) @@ -1057,11 +1036,11 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown temperature unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_pressure) SELECT CASE (basic_unit) @@ -1084,11 +1063,11 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown pressure unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_angle) SELECT CASE (basic_unit) @@ -1101,11 +1080,11 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown angle unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_time) SELECT CASE (basic_unit) @@ -1124,11 +1103,11 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown time unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_mass) SELECT CASE (basic_unit) @@ -1143,11 +1122,11 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown mass unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_potential) SELECT CASE (basic_unit) @@ -1160,11 +1139,11 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown potential unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_force) SELECT CASE (basic_unit) @@ -1179,26 +1158,26 @@ FUNCTION cp_basic_unit_desc(basic_kind,basic_unit,power,accept_undefined,error)& CALL cp_assert(my_accept_undefined,my_error_level,& cp_assertion_failed,routineP,& "unit not yet fully specified, unit of kind "//& - TRIM(res),error,failure) + TRIM(res),failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown potential unit:"//TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) END SELECT CASE(cp_ukind_none) CALL cp_assert(.FALSE.,my_error_level,& cp_assertion_failed, routineP,& "if the kind of the unit is none also unit must be undefined,not:"& //TRIM(cp_to_string(basic_unit)),& - error,failure) + failure) CASE default CALL cp_assert(.FALSE.,my_error_level,cp_assertion_failed,& routineP,"unknown kind of unit:"//TRIM(cp_to_string(basic_kind)),& - error,failure) + failure) END SELECT IF (my_power/=1) THEN a=LEN_TRIM(res) - CPPrecondition(LEN(res)-a>=3,cp_failure_level,routineP,error,failure) + CPPrecondition(LEN(res)-a>=3,cp_failure_level,routineP,failure) WRITE (res(a+1:),"('^',i3)") my_power CALL compress(res,.TRUE.) END IF @@ -1210,18 +1189,15 @@ END FUNCTION cp_basic_unit_desc !> \param defaults defaults for the undefined units, optional !> \param accept_undefined if defaults is not present or is not associated !> whether undefined units should be accepted (defaults to false) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_unit_desc(unit,defaults,accept_undefined,error)& + FUNCTION cp_unit_desc(unit,defaults,accept_undefined)& RESULT(res) TYPE(cp_unit_type), POINTER :: unit TYPE(cp_unit_set_type), OPTIONAL, & POINTER :: defaults LOGICAL, INTENT(in), OPTIONAL :: accept_undefined - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=cp_unit_desc_length) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_desc', & @@ -1233,14 +1209,14 @@ FUNCTION cp_unit_desc(unit,defaults,accept_undefined,error)& failure=.FALSE. - CPPrecondition(ASSOCIATED(unit),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(unit),cp_failure_level,routineP,failure) res="" pos=1 my_accept_undefined=.FALSE. IF (PRESENT(accept_undefined)) my_accept_undefined=accept_undefined DO i=1,unit%n_kinds - CPPrecondition(unit%kind_id(i)/=0,cp_failure_level,routineP,error,failure) - CPPrecondition(pos 1) THEN @@ -1259,7 +1235,7 @@ FUNCTION cp_unit_desc(unit,defaults,accept_undefined,error)& END IF res(pos:)=TRIM(cp_basic_unit_desc(basic_kind=unit%kind_id(i),& basic_unit=my_unit,accept_undefined=my_accept_undefined,& - power=unit%power(i),error=error)) + power=unit%power(i))) pos=LEN_TRIM(res)+1 END DO @@ -1272,18 +1248,15 @@ END FUNCTION cp_unit_desc !> \param defaults the defaults unit for those that are left free !> (cp_units_none) !> \param power the power of the unit (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_unit_to_cp2k1(value,unit,defaults,power,error) RESULT(res) + FUNCTION cp_unit_to_cp2k1(value,unit,defaults,power) RESULT(res) REAL(kind=dp), INTENT(in) :: value TYPE(cp_unit_type), POINTER :: unit TYPE(cp_unit_set_type), OPTIONAL, & POINTER :: defaults INTEGER, INTENT(in), OPTIONAL :: power - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_to_cp2k1', & @@ -1297,25 +1270,25 @@ FUNCTION cp_unit_to_cp2k1(value,unit,defaults,power,error) RESULT(res) my_power=1 IF (PRESENT(power)) my_power=power res=value - CPPrecondition(ASSOCIATED(unit),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(unit),cp_failure_level,routineP,failure) DO i_unit=1,unit%n_kinds - CPPrecondition(unit%kind_id(i_unit)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(unit%kind_id(i_unit)>0,cp_failure_level,routineP,failure) my_basic_unit=unit%unit_id(i_unit) IF (my_basic_unit==0.AND.unit%kind_id(i_unit)/=cp_ukind_undef) THEN - CPPrecondition(PRESENT(defaults),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(defaults),cp_failure_level,routineP,failure) IF (failure) EXIT - CPPrecondition(ASSOCIATED(defaults),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(defaults),cp_failure_level,routineP,failure) IF (failure) EXIT CALL cp_assert(ASSOCIATED(defaults%units(unit%kind_id(i_unit))%unit),& cp_failure_level,cp_assertion_failed,routineP,& CPSourceFileRef,& - error,failure) + failure) IF (failure) EXIT my_basic_unit=defaults%units(unit%kind_id(i_unit))%unit%unit_id(1) END IF res=cp_basic_unit_to_cp2k(value=res,basic_unit=my_basic_unit,& basic_kind=unit%kind_id(i_unit),& - power=my_power*unit%power(i_unit),error=error) + power=my_power*unit%power(i_unit)) END DO END FUNCTION cp_unit_to_cp2k1 @@ -1326,18 +1299,15 @@ END FUNCTION cp_unit_to_cp2k1 !> \param defaults the defaults unit for those that are left free !> (cp_units_none) !> \param power the power of the unit (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_unit_from_cp2k1(value,unit,defaults,power,error) RESULT(res) + FUNCTION cp_unit_from_cp2k1(value,unit,defaults,power) RESULT(res) REAL(kind=dp), INTENT(in) :: value TYPE(cp_unit_type), POINTER :: unit TYPE(cp_unit_set_type), OPTIONAL, & POINTER :: defaults INTEGER, INTENT(in), OPTIONAL :: power - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_from_cp2k1', & @@ -1351,9 +1321,9 @@ FUNCTION cp_unit_from_cp2k1(value,unit,defaults,power,error) RESULT(res) IF (PRESENT(power)) my_power=power IF (PRESENT(defaults)) THEN res=cp_unit_to_cp2k1(value=value,unit=unit,defaults=defaults,& - power=-my_power,error=error) + power=-my_power) ELSE - res=cp_unit_to_cp2k1(value=value,unit=unit,power=-my_power,error=error) + res=cp_unit_to_cp2k1(value=value,unit=unit,power=-my_power) END IF END FUNCTION cp_unit_from_cp2k1 @@ -1364,18 +1334,15 @@ END FUNCTION cp_unit_from_cp2k1 !> \param defaults the defaults unit for those that are left free !> (cp_units_none) !> \param power the power of the unit (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_unit_to_cp2k(value,unit_str,defaults,power,error) RESULT(res) + FUNCTION cp_unit_to_cp2k(value,unit_str,defaults,power) RESULT(res) REAL(kind=dp), INTENT(in) :: value CHARACTER(len=*), INTENT(in) :: unit_str TYPE(cp_unit_set_type), OPTIONAL, & POINTER :: defaults INTEGER, INTENT(in), OPTIONAL :: power - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_to_cp2k', & @@ -1384,14 +1351,14 @@ FUNCTION cp_unit_to_cp2k(value,unit_str,defaults,power,error) RESULT(res) TYPE(cp_unit_type), POINTER :: my_unit NULLIFY(my_unit) - CALL cp_unit_create(my_unit,unit_str,error=error) + CALL cp_unit_create(my_unit,unit_str) IF (PRESENT(defaults)) THEN res=cp_unit_to_cp2k1(value=value,unit=my_unit,defaults=defaults,& - power=power,error=error) + power=power) ELSE - res=cp_unit_to_cp2k1(value=value,unit=my_unit,power=power,error=error) + res=cp_unit_to_cp2k1(value=value,unit=my_unit,power=power) END IF - CALL cp_unit_release(my_unit,error=error) + CALL cp_unit_release(my_unit) END FUNCTION cp_unit_to_cp2k ! ***************************************************************************** @@ -1401,18 +1368,15 @@ END FUNCTION cp_unit_to_cp2k !> \param defaults the defaults unit for those that are left free !> (cp_units_none) !> \param power the power of the unit (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_unit_from_cp2k(value,unit_str,defaults,power,error) RESULT(res) + FUNCTION cp_unit_from_cp2k(value,unit_str,defaults,power) RESULT(res) REAL(kind=dp), INTENT(in) :: value CHARACTER(len=*), INTENT(in) :: unit_str TYPE(cp_unit_set_type), OPTIONAL, & POINTER :: defaults INTEGER, INTENT(in), OPTIONAL :: power - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_from_cp2k', & @@ -1421,28 +1385,25 @@ FUNCTION cp_unit_from_cp2k(value,unit_str,defaults,power,error) RESULT(res) TYPE(cp_unit_type), POINTER :: my_unit NULLIFY(my_unit) - CALL cp_unit_create(my_unit,unit_str,error=error) + CALL cp_unit_create(my_unit,unit_str) IF (PRESENT(defaults)) THEN res=cp_unit_from_cp2k1(value=value,unit=my_unit,defaults=defaults,& - power=power,error=error) + power=power) ELSE - res=cp_unit_from_cp2k1(value=value,unit=my_unit,power=power,error=error) + res=cp_unit_from_cp2k1(value=value,unit=my_unit,power=power) END IF - CALL cp_unit_release(my_unit,error=error) + CALL cp_unit_release(my_unit) END FUNCTION cp_unit_from_cp2k ! ***************************************************************************** !> \brief returs true if the two units are compatible !> \param ref_unit ... !> \param unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author Teodoro Laino [tlaino] - 11.2007 - University of Zurich ! ***************************************************************************** - FUNCTION cp_unit_compatible(ref_unit,unit,error) RESULT(res) + FUNCTION cp_unit_compatible(ref_unit,unit) RESULT(res) TYPE(cp_unit_type), POINTER :: ref_unit, unit - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_compatible', & @@ -1465,14 +1426,11 @@ END FUNCTION cp_unit_compatible !> \param unit_set the set to initialize !> \param name the name of the set, used for the dafault initialization of !> the various units -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_unit_set_create(unit_set,name,error) + SUBROUTINE cp_unit_set_create(unit_set,name) TYPE(cp_unit_set_type), POINTER :: unit_set CHARACTER(len=*), INTENT(in) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_set_create', & routineP = moduleN//':'//routineN @@ -1482,9 +1440,9 @@ SUBROUTINE cp_unit_set_create(unit_set,name,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(unit_set),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(unit_set),cp_failure_level,routineP,failure) ALLOCATE(unit_set,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) unit_set%ref_count=1 last_unit_set_id=last_unit_set_id+1 unit_set%id_nr=last_unit_set_id @@ -1499,52 +1457,52 @@ SUBROUTINE cp_unit_set_create(unit_set,name,error) CASE('ATOM','ATOMIC','INTERNAL','CP2K') IF (i==cp_ukind_angle) THEN CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/),& - unit_id=(/cp_units_rad/), power=(/1/), error=error) + unit_id=(/cp_units_rad/), power=(/1/)) ELSE CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/),& - unit_id=(/cp_units_au/), power=(/1/), error=error) + unit_id=(/cp_units_au/), power=(/1/)) END IF CASE('OUTPUT') SELECT CASE(i) CASE(cp_ukind_undef) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_none/),& - power=(/1/), error=error) + power=(/1/)) CASE(cp_ukind_energy) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_hartree/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_length) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_angstrom/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_temperature) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_k/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_angle) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_deg/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_pressure) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_bar/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_time) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_fs/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_mass) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_amu/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_potential) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_volt/),& - power=(/1/), error=error) + power=(/1/)) CASE (cp_ukind_force) CALL cp_unit_create2(unit_set%units(i)%unit, kind_id=(/i/), unit_id=(/cp_units_newton/),& - power=(/1/), error=error) + power=(/1/)) CASE default CALL cp_assert(.FALSE.,cp_assertion_failed,cp_failure_level,routineP,& - "unhandled unit type "//TRIM(cp_to_string(i)),error,failure) + "unhandled unit type "//TRIM(cp_to_string(i)),failure) EXIT END SELECT CASE default CALL cp_assert(.FALSE.,cp_assertion_failed,cp_failure_level,& routineP,'unknown parameter set name '//TRIM(name),& - error,failure) + failure) END SELECT END DO END SUBROUTINE cp_unit_set_create @@ -1552,13 +1510,10 @@ END SUBROUTINE cp_unit_set_create ! ***************************************************************************** !> \brief retains the given unit set !> \param unit_set the unit set to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_unit_set_retain(unit_set,error) + SUBROUTINE cp_unit_set_retain(unit_set) TYPE(cp_unit_set_type), POINTER :: unit_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_set_retain', & routineP = moduleN//':'//routineN @@ -1567,21 +1522,18 @@ SUBROUTINE cp_unit_set_retain(unit_set,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(unit_set),cp_failure_level,routineP,error,failure) - CPPrecondition(unit_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(unit_set),cp_failure_level,routineP,failure) + CPPrecondition(unit_set%ref_count>0,cp_failure_level,routineP,failure) unit_set%ref_count=unit_set%ref_count+1 END SUBROUTINE cp_unit_set_retain ! ***************************************************************************** !> \brief releases the given unit set !> \param unit_set the unit set to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_unit_set_release(unit_set,error) + SUBROUTINE cp_unit_set_release(unit_set) TYPE(cp_unit_set_type), POINTER :: unit_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_set_release', & routineP = moduleN//':'//routineN @@ -1592,14 +1544,14 @@ SUBROUTINE cp_unit_set_release(unit_set,error) failure=.FALSE. IF (ASSOCIATED(unit_set)) THEN - CPPrecondition(unit_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(unit_set%ref_count>0,cp_failure_level,routineP,failure) unit_set%ref_count=unit_set%ref_count-1 IF (unit_set%ref_count == 0) THEN DO i = 1, SIZE(unit_set%units) - CALL cp_unit_release(unit_set%units(i)%unit,error) + CALL cp_unit_release(unit_set%units(i)%unit) END DO DEALLOCATE(unit_set,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE cp_unit_set_release diff --git a/src/common/distribution_1d_types.F b/src/common/distribution_1d_types.F index 182831350c..a9e43cb16d 100644 --- a/src/common/distribution_1d_types.F +++ b/src/common/distribution_1d_types.F @@ -90,21 +90,18 @@ MODULE distribution_1d_types !> (defaults to false) !> \param n_el number of elements in each list (defaults to 0) !> \param n_lists number of lists to create (defaults to 1, or size(n_el)) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE distribution_1d_create(distribution_1d,para_env,listbased_distribution,& - n_el,n_lists,error) + n_el,n_lists) TYPE(distribution_1d_type), POINTER :: distribution_1d TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(in), OPTIONAL :: listbased_distribution INTEGER, DIMENSION(:), INTENT(in), & OPTIONAL :: n_el INTEGER, INTENT(in), OPTIONAL :: n_lists - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_1d_create', & routineP = moduleN//':'//routineN @@ -118,14 +115,14 @@ SUBROUTINE distribution_1d_create(distribution_1d,para_env,listbased_distributio IF(PRESENT(n_lists)) my_n_lists=n_lists ALLOCATE(distribution_1d,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) distribution_1d_last_id_nr=distribution_1d_last_id_nr+1 distribution_1d%id_nr=distribution_1d_last_id_nr distribution_1d%ref_count=1 distribution_1d%para_env => para_env - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) NULLIFY(distribution_1d%list,distribution_1d%n_el) @@ -135,13 +132,13 @@ SUBROUTINE distribution_1d_create(distribution_1d,para_env,listbased_distributio ALLOCATE(distribution_1d%n_el(my_n_lists), distribution_1d%list(my_n_lists),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(n_el)) THEN distribution_1d%n_el(1:my_n_lists)=n_el(1:my_n_lists) DO ilist=1,my_n_lists ALLOCATE(distribution_1d%list(ilist)%array(n_el(ilist)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) distribution_1d%list(ilist)%array=-1 END DO ELSE @@ -158,15 +155,12 @@ END SUBROUTINE distribution_1d_create ! ***************************************************************************** !> \brief retains a distribution_1d !> \param distribution_1d the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE distribution_1d_retain(distribution_1d,error) +SUBROUTINE distribution_1d_retain(distribution_1d) TYPE(distribution_1d_type), POINTER :: distribution_1d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_1d_retain', & routineP = moduleN//':'//routineN @@ -175,23 +169,20 @@ SUBROUTINE distribution_1d_retain(distribution_1d,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(distribution_1d),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(distribution_1d%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(distribution_1d),cp_failure_level,routineP,failure) + CPPreconditionNoFail(distribution_1d%ref_count>0,cp_failure_level,routineP) distribution_1d%ref_count=distribution_1d%ref_count+1 END SUBROUTINE distribution_1d_retain ! ***************************************************************************** !> \brief releases the given distribution_1d !> \param distribution_1d the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE distribution_1d_release(distribution_1d,error) +SUBROUTINE distribution_1d_release(distribution_1d) TYPE(distribution_1d_type), POINTER :: distribution_1d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_1d_release', & routineP = moduleN//':'//routineN @@ -207,18 +198,18 @@ SUBROUTINE distribution_1d_release(distribution_1d,error) failure=.FALSE. IF (ASSOCIATED(distribution_1d)) THEN - CPPreconditionNoFail(distribution_1d%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(distribution_1d%ref_count>0,cp_failure_level,routineP) distribution_1d%ref_count=distribution_1d%ref_count-1 IF (distribution_1d%ref_count==0) THEN DEALLOCATE(distribution_1d%n_el,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO ilist=1,SIZE(distribution_1d%list) DEALLOCATE(distribution_1d%list(ilist)%array,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO DEALLOCATE(distribution_1d%list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) !MK Delete Wiener process @@ -233,21 +224,21 @@ SUBROUTINE distribution_1d_release(distribution_1d,error) IF (ASSOCIATED(local_particle_set(iparticle_kind)%& rng(iparticle_local)%stream)) THEN CALL delete_rng_stream(local_particle_set(iparticle_kind)%& - rng(iparticle_local)%stream,error=error) + rng(iparticle_local)%stream) END IF END DO DEALLOCATE (local_particle_set(iparticle_kind)%rng,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO DEALLOCATE(local_particle_set,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF - CALL cp_para_env_release(distribution_1d%para_env,error=error) + CALL cp_para_env_release(distribution_1d%para_env) DEALLOCATE(distribution_1d,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF @@ -257,16 +248,13 @@ END SUBROUTINE distribution_1d_release !> \brief writes a description of the local distribution to the given unit !> \param distribution_1d the list to describe !> \param unit_nr the unit to write to -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE distribution_1d_write(distribution_1d, unit_nr, error) +SUBROUTINE distribution_1d_write(distribution_1d, unit_nr) TYPE(distribution_1d_type), POINTER :: distribution_1d INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_1d_write', & routineP = moduleN//':'//routineN diff --git a/src/common/mathlib.F b/src/common/mathlib.F index 4753231fac..c7b153f613 100644 --- a/src/common/mathlib.F +++ b/src/common/mathlib.F @@ -227,7 +227,6 @@ END FUNCTION det_3x3_2 !> \param a ... !> \param eigval ... !> \param dac ... -!> \param error ... !> \date 29.03.1999 !> \par Variables !> - a : Symmetric matrix to be diagonalized (input; upper triangle) -> @@ -237,12 +236,11 @@ END FUNCTION det_3x3_2 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE diamat_all(a,eigval,dac,error) + SUBROUTINE diamat_all(a,eigval,dac) REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: a REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: eigval LOGICAL, INTENT(IN), OPTIONAL :: dac - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'diamat_all', & routineP = moduleN//':'//routineN @@ -295,10 +293,10 @@ SUBROUTINE diamat_all(a,eigval,dac,error) ! Allocate work storage ALLOCATE (work(lwork),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (divide_and_conquer) THEN ALLOCATE (iwork(liwork),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ! Diagonalize the matrix a @@ -322,11 +320,11 @@ SUBROUTINE diamat_all(a,eigval,dac,error) ! Release work storage DEALLOCATE (work,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (divide_and_conquer) THEN DEALLOCATE (iwork,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -422,12 +420,10 @@ END FUNCTION inv_3x3 !> \brief returns inverse of matrix using the lapack routines DGETRF and DGETRI !> \param a ... !> \param info ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE invmat(a,info,error) + SUBROUTINE invmat(a,info) REAL(KIND=dp), INTENT(INOUT) :: a(:,:) INTEGER, INTENT(OUT) :: info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'invmat', & routineP = moduleN//':'//routineN @@ -441,9 +437,9 @@ SUBROUTINE invmat(a,info,error) n = SIZE(a,1) lwork = 20*n ALLOCATE (ipiv(n),STAT=info) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) ALLOCATE (work(lwork),STAT=info) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) ipiv = 0 work = 0._dp info = 0 @@ -452,7 +448,7 @@ SUBROUTINE invmat(a,info,error) CALL dgetri(n,a,n,ipiv,work,lwork,info) END IF DEALLOCATE (ipiv,work,STAT=info) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) END SUBROUTINE invmat ! ***************************************************************************** @@ -462,14 +458,11 @@ END SUBROUTINE invmat !> using dpotrf, indicating if the upper or lower triangle of a is !> stored. If not given, cholesky decomposition of a will be done !> before inversion. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze [02.2015] ! ***************************************************************************** - SUBROUTINE invmat_symm(a,cholesky_triangle,error) + SUBROUTINE invmat_symm(a,cholesky_triangle) REAL(KIND=dp), INTENT(INOUT) :: a(:,:) CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: cholesky_triangle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'invmat_symm', & routineP = moduleN//':'//routineN @@ -525,7 +518,6 @@ END SUBROUTINE invmat_symm !> \param a_inverse ... !> \param eval_error ... !> \param option ... -!> \param error ... !> \param improve ... !> \date 23.03.1999 !> \par Variables @@ -541,14 +533,13 @@ END SUBROUTINE invmat_symm !> \version 1.0 !> \note NB add improve argument, used to disable call to dgerfs ! ***************************************************************************** - SUBROUTINE invert_matrix_d(a,a_inverse,eval_error,option,error,improve) + SUBROUTINE invert_matrix_d(a,a_inverse,eval_error,option,improve) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: a REAL(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: a_inverse REAL(KIND=dp), INTENT(OUT) :: eval_error CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: option - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, INTENT(IN), OPTIONAL :: improve CHARACTER(LEN=*), PARAMETER :: routineN = 'invert_matrix_d', & @@ -604,25 +595,25 @@ SUBROUTINE invert_matrix_d(a,a_inverse,eval_error,option,error,improve) ! Allocate work storage ALLOCATE (a_lu(n,n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (b(n,n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (berr(n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ferr(n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ipiv(n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (iwork(n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (work(4*n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) a_lu(1:n,1:n) = a(1:n,1:n) @@ -699,19 +690,19 @@ SUBROUTINE invert_matrix_d(a,a_inverse,eval_error,option,error,improve) ! Release work storage DEALLOCATE (work,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (iwork,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (ipiv,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (ferr,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (berr,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (b,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (a_lu,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE invert_matrix_d @@ -722,7 +713,6 @@ END SUBROUTINE invert_matrix_d !> \param a_inverse ... !> \param eval_error ... !> \param option ... -!> \param error ... !> \date 08.06.2009 !> \par Variables !> - a : Complex matrix to be inverted (input). @@ -736,14 +726,13 @@ END SUBROUTINE invert_matrix_d !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE invert_matrix_z(a,a_inverse,eval_error,option,error) + SUBROUTINE invert_matrix_z(a,a_inverse,eval_error,option) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: a COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: a_inverse REAL(KIND=dp), INTENT(OUT) :: eval_error CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: option - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'invert_matrix_z', & routineP = moduleN//':'//routineN @@ -794,25 +783,25 @@ SUBROUTINE invert_matrix_z(a,a_inverse,eval_error,option,error) ! Allocate work storage ALLOCATE (a_lu(n,n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (b(n,n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (berr(n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ferr(n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ipiv(n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (rwork(2*n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (work(2*n),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) a_lu(1:n,1:n) = a(1:n,1:n) @@ -887,19 +876,19 @@ SUBROUTINE invert_matrix_z(a,a_inverse,eval_error,option,error) ! Release work storage DEALLOCATE (work,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (rwork,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (ipiv,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (ferr,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (berr,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (b,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (a_lu,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE invert_matrix_z @@ -909,15 +898,12 @@ END SUBROUTINE invert_matrix_z !> \param a matrix a !> \param a_pinverse pseudoinverse of matrix a !> \param rskip parameter for setting small singular values to zero -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze [02.2015] ! ***************************************************************************** - SUBROUTINE get_pseudo_inverse_svd(a,a_pinverse,rskip,error) + SUBROUTINE get_pseudo_inverse_svd(a,a_pinverse,rskip) REAL(KIND=dp), DIMENSION(:, :), POINTER :: a, a_pinverse REAL(KIND=dp), INTENT(IN) :: rskip - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_pseudo_inverse_svd', & routineP = moduleN//':'//routineN @@ -935,7 +921,7 @@ SUBROUTINE get_pseudo_inverse_svd(a,a_pinverse,rskip,error) n=SIZE(a,1) ALLOCATE(u(n,n),vt(n,n),sig(n),sig_plus(n,n),iwork(8*n),work(1),temp_mat(n,n),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) u(:,:) = 0.0_dp vt(:,:) = 0.0_dp sig(:) = 0.0_dp @@ -954,9 +940,9 @@ SUBROUTINE get_pseudo_inverse_svd(a,a_pinverse,rskip,error) END IF lwork = INT(work(1)) DEALLOCATE(work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work(lwork),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! do SVD CALL dgesdd('A',n,n,a(1,1),n,sig(1),u(1,1),n,vt(1,1),n,work(1),& @@ -981,7 +967,7 @@ SUBROUTINE get_pseudo_inverse_svd(a,a_pinverse,rskip,error) CALL dgemm("T","N",n,n,n,1._dp,vt,n,temp_mat,n,0._dp,a_pinverse,n) DEALLOCATE( u,vt,sig,iwork,work,sig_plus,temp_mat,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -993,15 +979,12 @@ END SUBROUTINE get_pseudo_inverse_svd !> \param a matrix a !> \param a_pinverse pseudoinverse of matrix a !> \param rskip parameter for setting small eigenvalues to zero -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze [02.2015] ! ***************************************************************************** - SUBROUTINE get_pseudo_inverse_diag(a,a_pinverse,rskip,error) + SUBROUTINE get_pseudo_inverse_diag(a,a_pinverse,rskip) REAL(KIND=dp), DIMENSION(:, :), POINTER :: a, a_pinverse REAL(KIND=dp), INTENT(IN) :: rskip - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_pseudo_inverse_diag', & routineP = moduleN//':'//routineN @@ -1018,7 +1001,7 @@ SUBROUTINE get_pseudo_inverse_diag(a,a_pinverse,rskip,error) n=SIZE(a,1) ALLOCATE(dinv(n,n),eig(n),work(1),temp_mat(n,n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dinv(:,:) = 0.0_dp eig(:) = 0.0_dp work(:) = 0.0_dp @@ -1033,9 +1016,9 @@ SUBROUTINE get_pseudo_inverse_diag(a,a_pinverse,rskip,error) END IF lwork = INT(work(1)) DEALLOCATE(work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work(lwork),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! get eigenvalues and eigenvectors CALL dsyev('V','U',n,a(1,1),n,eig(1),work(1),lwork,info) @@ -1059,7 +1042,7 @@ SUBROUTINE get_pseudo_inverse_diag(a,a_pinverse,rskip,error) CALL dgemm("N","N",n,n,n,1._dp,a,n,temp_mat,n,0._dp,a_pinverse,n) DEALLOCATE(eig,work,dinv,temp_mat,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/common/parallel_rng_types.F b/src/common/parallel_rng_types.F index 424de8314c..723cf35efd 100644 --- a/src/common/parallel_rng_types.F +++ b/src/common/parallel_rng_types.F @@ -168,9 +168,8 @@ MODULE parallel_rng_types !> \param rng_stream ... !> \param e ... !> \param c ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE advance_rng_state(rng_stream,e,c,error) + SUBROUTINE advance_rng_state(rng_stream,e,c) ! Advance the state by n steps, i.e. jump n steps forward, if n > 0, or ! backward if n < 0. @@ -182,7 +181,6 @@ SUBROUTINE advance_rng_state(rng_stream,e,c,error) TYPE(rng_stream_type), POINTER :: rng_stream INTEGER, INTENT(IN) :: e, c - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'advance_rng_state', & routineP = moduleN//':'//routineN @@ -195,7 +193,7 @@ SUBROUTINE advance_rng_state(rng_stream,e,c,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) u1 = 0.0_dp @@ -243,15 +241,13 @@ END SUBROUTINE advance_rng_state !> \brief ... !> \param output_unit ... !> \param ionode ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE check_rng(output_unit,ionode,error) + SUBROUTINE check_rng(output_unit,ionode) ! Check the parallel (pseudo)random number generator (RNG). INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN) :: ionode - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_rng', & routineP = moduleN//':'//routineN @@ -271,91 +267,91 @@ SUBROUTINE check_rng(output_unit,ionode,error) ! Create RNG test streams - CALL create_rng_stream(g1,"g1",error=error) - CALL create_rng_stream(g2,"g2",g1,error=error) - CALL create_rng_stream(g3,"g3",g2,error=error) + CALL create_rng_stream(g1,"g1") + CALL create_rng_stream(g2,"g2",g1) + CALL create_rng_stream(g3,"g3",g2) IF (ionode) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A)")& "RESULTS OF THE PSEUDO(RANDOM) NUMBER GENERATOR TEST RUNS",& "Initial states of the (pseudo)random number streams (test 1):" - CALL write_rng_stream(g1,output_unit,error=error) - CALL write_rng_stream(g2,output_unit,error=error) - CALL write_rng_stream(g3,output_unit,error=error) + CALL write_rng_stream(g1,output_unit) + CALL write_rng_stream(g2,output_unit) + CALL write_rng_stream(g3,output_unit) END IF - sum = next_random_number(g2,error=error) + next_random_number(g3,error=error) + sum = next_random_number(g2) + next_random_number(g3) - CALL advance_rng_state(g1,5,3,error=error) - sum = sum + next_random_number(g1,error=error) + CALL advance_rng_state(g1,5,3) + sum = sum + next_random_number(g1) - CALL reset_rng_stream(g1,error=error) + CALL reset_rng_stream(g1) DO i=1,35 - CALL advance_rng_state(g1,0,1,error=error) + CALL advance_rng_state(g1,0,1) END DO - sum = sum + next_random_number(g1,error=error) + sum = sum + next_random_number(g1) - CALL reset_rng_stream(g1,error=error) + CALL reset_rng_stream(g1) sumi = 0 DO i=1,35 - sumi = sumi + next_random_number(g1,1,10,error=error) + sumi = sumi + next_random_number(g1,1,10) END DO sum = sum + sumi/100.0_dp sum3 = 0.0_dp DO i=1,100 - sum3 = sum3 + next_random_number(g3,error=error) + sum3 = sum3 + next_random_number(g3) END DO sum = sum + sum3/10.0_dp - CALL reset_rng_stream(g3,error=error) + CALL reset_rng_stream(g3) DO i=1,5 - sum = sum + next_random_number(g3,error=error) + sum = sum + next_random_number(g3) END DO - CALL reset_rng_stream(g3,error=error) + CALL reset_rng_stream(g3) DO i=1,4 - CALL reset_to_next_rng_substream(g3,error=error) + CALL reset_to_next_rng_substream(g3) END DO DO i=1,5 - sum = sum + next_random_number(g3,error=error) + sum = sum + next_random_number(g3) END DO CALL reset_rng_substream(g3) DO i=1,5 - sum = sum + next_random_number(g3,error=error) + sum = sum + next_random_number(g3) END DO - CALL reset_to_next_rng_substream(g2,error=error) + CALL reset_to_next_rng_substream(g2) sum3 = 0.0_dp DO i=1,100000 - sum3 = sum3 + next_random_number(g2,error=error) + sum3 = sum3 + next_random_number(g2) END DO sum = sum + sum3/10000.0_dp - CALL set_rng_stream(g3,antithetic=.TRUE.,error=error) + CALL set_rng_stream(g3,antithetic=.TRUE.) sum3 = 0.0_dp DO i=1,100000 - sum3 = sum3 + next_random_number(g3,error=error) + sum3 = sum3 + next_random_number(g3) END DO sum = sum + sum3/10000.0_dp IF (ionode) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A)")& "Final states of the (pseudo)random number streams (test 1):" - CALL write_rng_stream(g1,output_unit,error=error) - CALL write_rng_stream(g2,output_unit,error=error) - CALL write_rng_stream(g3,output_unit,error=error) + CALL write_rng_stream(g1,output_unit) + CALL write_rng_stream(g2,output_unit) + CALL write_rng_stream(g3,output_unit) WRITE (UNIT=output_unit,FMT="(/,(T2,A))")& "This test routine should print for test 1 the number 25.342059" WRITE (UNIT=output_unit,FMT="(T2,A,F10.6)")& "The actual result of test 1 is ",sum END IF - CALL delete_rng_stream(g1,error=error) - CALL delete_rng_stream(g2,error=error) - CALL delete_rng_stream(g3,error=error) + CALL delete_rng_stream(g1) + CALL delete_rng_stream(g2) + CALL delete_rng_stream(g3) ! ------------------------------------------------------------------------- @@ -368,82 +364,80 @@ SUBROUTINE check_rng(output_unit,ionode,error) germe(:,:) = 1 - CALL create_rng_stream(poisson,"Poisson",seed=germe,error=error) - CALL create_rng_stream(laplace,"Laplace",poisson,error=error) - CALL create_rng_stream(galois,"Galois",laplace,error=error) - CALL create_rng_stream(cantor,"Cantor",galois,error=error) + CALL create_rng_stream(poisson,"Poisson",seed=germe) + CALL create_rng_stream(laplace,"Laplace",poisson) + CALL create_rng_stream(galois,"Galois",laplace) + CALL create_rng_stream(cantor,"Cantor",galois) IF (ionode) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A)")& "Initial states of the (pseudo)random number streams (test 2):" - CALL write_rng_stream(poisson,output_unit,error=error) - CALL write_rng_stream(laplace,output_unit,error=error) - CALL write_rng_stream(galois,output_unit,error=error) - CALL write_rng_stream(cantor,output_unit,error=error) + CALL write_rng_stream(poisson,output_unit) + CALL write_rng_stream(laplace,output_unit) + CALL write_rng_stream(galois,output_unit) + CALL write_rng_stream(cantor,output_unit) END IF - sum = sum + next_random_number(poisson,error=error) +& - next_random_number(laplace,error=error) +& - next_random_number(galois,error=error) +& - next_random_number(cantor,error=error) + sum = sum + next_random_number(poisson) +& + next_random_number(laplace) +& + next_random_number(galois) +& + next_random_number(cantor) - CALL advance_rng_state(galois,-127,0,error=error) - sum = sum + next_random_number(galois,error=error) + CALL advance_rng_state(galois,-127,0) + sum = sum + next_random_number(galois) - CALL reset_to_next_rng_substream(galois,error=error) - CALL set_rng_stream(galois,extended_precision=.TRUE.,error=error) + CALL reset_to_next_rng_substream(galois) + CALL set_rng_stream(galois,extended_precision=.TRUE.) sum3 = 0.0_dp DO i=1,100000 - sum3 = sum3 + next_random_number(galois,error=error) + sum3 = sum3 + next_random_number(galois) END DO sum = sum + sum3/10000.0_dp - CALL set_rng_stream(galois,antithetic=.TRUE.,error=error) + CALL set_rng_stream(galois,antithetic=.TRUE.) sum3 = 0.0_dp DO i=1,100000 - sum3 = sum3 + next_random_number(galois,error=error) + sum3 = sum3 + next_random_number(galois) END DO sum = sum + sum3/10000.0_dp - CALL set_rng_stream(galois,antithetic=.FALSE.,error=error) + CALL set_rng_stream(galois,antithetic=.FALSE.) - CALL set_rng_stream(galois,extended_precision=.FALSE.,error=error) - sum = sum + next_random_number(poisson,error=error) +& - next_random_number(laplace,error=error) +& - next_random_number(galois,error=error) +& - next_random_number(cantor,error=error) + CALL set_rng_stream(galois,extended_precision=.FALSE.) + sum = sum + next_random_number(poisson) +& + next_random_number(laplace) +& + next_random_number(galois) +& + next_random_number(cantor) IF (ionode) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A)")& "Final states of the (pseudo)random number streams (test 2):" - CALL write_rng_stream(poisson,output_unit,error=error) - CALL write_rng_stream(laplace,output_unit,error=error) - CALL write_rng_stream(galois,output_unit,error=error) - CALL write_rng_stream(cantor,output_unit,error=error) + CALL write_rng_stream(poisson,output_unit) + CALL write_rng_stream(laplace,output_unit) + CALL write_rng_stream(galois,output_unit) + CALL write_rng_stream(cantor,output_unit) WRITE (UNIT=output_unit,FMT="(/,(T2,A))")& "This test routine should print for test 2 the number 39.697547" WRITE (UNIT=output_unit,FMT="(T2,A,F10.6)")& "The actual result of test 2 is ",sum END IF - CALL delete_rng_stream(cantor,error=error) - CALL delete_rng_stream(galois,error=error) - CALL delete_rng_stream(laplace,error=error) - CALL delete_rng_stream(poisson,error=error) + CALL delete_rng_stream(cantor) + CALL delete_rng_stream(galois) + CALL delete_rng_stream(laplace) + CALL delete_rng_stream(poisson) END SUBROUTINE check_rng ! ***************************************************************************** !> \brief ... !> \param seed ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE check_seed(seed,error) + SUBROUTINE check_seed(seed) ! Check that the seeds are legitimate values. REAL(KIND=dp), DIMENSION(3, 2), & INTENT(IN) :: seed - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: fmtstr = "(A,I1,A,ES23.14,A,ES23.14)", & routineN = 'check_seed', routineP = moduleN//':'//routineN @@ -465,14 +459,14 @@ SUBROUTINE check_seed(seed,error) "seed(",i,",1) = ",seed(i,1)," < ",0.0_dp CALL compress(message) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,message,error,failure) + routineP,message,failure) END IF IF (seed(i,1) >= m1) THEN WRITE (UNIT=message,FMT=fmtstr)& "seed(",i,",1) = ",seed(i,1)," >= ",m1 CALL compress(message) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,message,error,failure) + routineP,message,failure) END IF ! Check condition: 0 <= seed(:,2) < m2 @@ -482,14 +476,14 @@ SUBROUTINE check_seed(seed,error) "seed(",i,",2) = ",seed(i,2)," < ",0.0_dp CALL compress(message) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,message,error,failure) + routineP,message,failure) END IF IF (seed(i,2) >= m2) THEN WRITE (UNIT=message,FMT=fmtstr)& "seed(",i,",2) = ",seed(i,2)," >= ",m2 CALL compress(message) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,message,error,failure) + routineP,message,failure) END IF END DO @@ -498,12 +492,12 @@ SUBROUTINE check_seed(seed,error) IF (ALL(seed(:,1) < 1.0_dp)) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"First seed = 0",error,failure) + routineP,"First seed = 0",failure) END IF IF (ALL(seed(:,2) < 1.0_dp)) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"Second seed = 0",error,failure) + routineP,"Second seed = 0",failure) END IF END SUBROUTINE check_seed @@ -517,11 +511,10 @@ END SUBROUTINE check_seed !> \param seed ... !> \param antithetic ... !> \param extended_precision ... -!> \param error ... ! ***************************************************************************** SUBROUTINE create_rng_stream(rng_stream,name,last_rng_stream,& distribution_type,seed,antithetic,& - extended_precision,error) + extended_precision) ! Create a new RNG stream. ! last_rng_stream is used as a reference stream, if it is specified. @@ -538,7 +531,6 @@ SUBROUTINE create_rng_stream(rng_stream,name,last_rng_stream,& REAL(KIND=dp), DIMENSION(3, 2), & INTENT(IN), OPTIONAL :: seed LOGICAL, INTENT(IN), OPTIONAL :: antithetic, extended_precision - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_rng_stream', & routineP = moduleN//':'//routineN @@ -550,21 +542,21 @@ SUBROUTINE create_rng_stream(rng_stream,name,last_rng_stream,& failure = .FALSE. - IF (ASSOCIATED(rng_stream)) CALL delete_rng_stream(rng_stream,error=error) + IF (ASSOCIATED(rng_stream)) CALL delete_rng_stream(rng_stream) ALLOCATE (rng_stream,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rng_stream%name = name IF (PRESENT(seed)) THEN - CALL check_seed(seed,error) + CALL check_seed(seed) rng_stream%ig = seed ELSE IF (PRESENT(last_rng_stream)) THEN - rng_stream%ig = next_rng_seed(last_rng_stream%ig,error=error) + rng_stream%ig = next_rng_seed(last_rng_stream%ig) ELSE - rng_stream%ig = next_rng_seed(error=error) + rng_stream%ig = next_rng_seed() END IF rng_stream%cg = rng_stream%ig @@ -579,7 +571,7 @@ SUBROUTINE create_rng_stream(rng_stream,name,last_rng_stream,& CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Invalid distribution type specified",& - error,failure) + failure) END SELECT ELSE IF (PRESENT(last_rng_stream)) THEN rng_stream%distribution_type = last_rng_stream%distribution_type @@ -614,14 +606,12 @@ END SUBROUTINE create_rng_stream ! ***************************************************************************** !> \brief ... !> \param rng_stream ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE delete_rng_stream(rng_stream,error) + SUBROUTINE delete_rng_stream(rng_stream) ! Delete a random number stream. TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'delete_rng_stream', & routineP = moduleN//':'//routineN @@ -633,10 +623,10 @@ SUBROUTINE delete_rng_stream(rng_stream,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) DEALLOCATE (rng_stream,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE delete_rng_stream @@ -644,16 +634,14 @@ END SUBROUTINE delete_rng_stream !> \brief ... !> \param rng_stream ... !> \param rng_record ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dump_rng_stream(rng_stream,rng_record,error) + SUBROUTINE dump_rng_stream(rng_stream,rng_record) ! Dump a RNG stream as a record given as an internal file (string). TYPE(rng_stream_type), POINTER :: rng_stream CHARACTER(LEN=rng_record_length), & INTENT(OUT) :: rng_record - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_rng_stream', & routineP = moduleN//':'//routineN @@ -664,7 +652,7 @@ SUBROUTINE dump_rng_stream(rng_stream,rng_record,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) rng_record = " " WRITE (UNIT=rng_record,FMT=rng_record_format)& @@ -693,7 +681,6 @@ END SUBROUTINE dump_rng_stream !> \param extended_precision ... !> \param buffer ... !> \param buffer_filled ... -!> \param error ... !> \par History !> 2009-11-04 changed bg, cg and ig type from INTEGER, DIMENSION(3, 2) !> to REAL(KIND=dp), DIMENSION(3, 2) [lwalewski] @@ -702,7 +689,7 @@ END SUBROUTINE dump_rng_stream ! ***************************************************************************** SUBROUTINE get_rng_stream(rng_stream,name,distribution_type,bg,cg,ig,& antithetic,extended_precision,& - buffer,buffer_filled,error) + buffer,buffer_filled) ! Get the components of a RNG stream. @@ -714,7 +701,6 @@ SUBROUTINE get_rng_stream(rng_stream,name,distribution_type,bg,cg,ig,& LOGICAL, INTENT(OUT), OPTIONAL :: antithetic, extended_precision REAL(KIND=dp), INTENT(OUT), OPTIONAL :: buffer LOGICAL, INTENT(OUT), OPTIONAL :: buffer_filled - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_rng_stream', & routineP = moduleN//':'//routineN @@ -725,7 +711,7 @@ SUBROUTINE get_rng_stream(rng_stream,name,distribution_type,bg,cg,ig,& failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) IF (PRESENT(name)) name = rng_stream%name IF (PRESENT(distribution_type)) THEN @@ -1023,17 +1009,15 @@ END SUBROUTINE mat_vec_mod_m !> \param rng_stream ... !> \param low ... !> \param high ... -!> \param error ... !> \retval u ... ! ***************************************************************************** - FUNCTION next_integer_random_number(rng_stream,low,high,error) RESULT(u) + FUNCTION next_integer_random_number(rng_stream,low,high) RESULT(u) ! Get the next integer random number between low and high from the stream ! rng_stream. TYPE(rng_stream_type), POINTER :: rng_stream INTEGER, INTENT(IN) :: low, high - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: u CHARACTER(LEN=*), PARAMETER :: routineN = 'next_integer_random_number', & @@ -1046,10 +1030,10 @@ FUNCTION next_integer_random_number(rng_stream,low,high,error) RESULT(u) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) - CPPrecondition((rng_stream%distribution_type == UNIFORM),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) + CPPrecondition((rng_stream%distribution_type == UNIFORM),cp_failure_level,routineP,failure) - r = next_real_random_number(rng_stream,error=error) + r = next_real_random_number(rng_stream) u = low + INT(r*REAL(high - low + 1,dp)) END FUNCTION next_integer_random_number @@ -1058,17 +1042,15 @@ END FUNCTION next_integer_random_number !> \brief ... !> \param rng_stream ... !> \param variance ... -!> \param error ... !> \retval u ... ! ***************************************************************************** - FUNCTION next_real_random_number(rng_stream,variance,error) RESULT(u) + FUNCTION next_real_random_number(rng_stream,variance) RESULT(u) ! Get the next real random number from the stream rng_stream. ! variance: variance of the Gaussian distribution (defaults to 1) TYPE(rng_stream_type), POINTER :: rng_stream REAL(KIND=dp), INTENT(IN), OPTIONAL :: variance - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp) :: u CHARACTER(LEN=*), PARAMETER :: routineN = 'next_real_random_number', & @@ -1081,7 +1063,7 @@ FUNCTION next_real_random_number(rng_stream,variance,error) RESULT(u) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) SELECT CASE (rng_stream%distribution_type) CASE (GAUSSIAN) @@ -1123,10 +1105,9 @@ END FUNCTION next_real_random_number ! ***************************************************************************** !> \brief ... !> \param seed ... -!> \param error ... !> \retval next_seed ... ! ***************************************************************************** - FUNCTION next_rng_seed(seed,error) RESULT(next_seed) + FUNCTION next_rng_seed(seed) RESULT(next_seed) ! Get the seed for the next RNG stream w.r.t. a given seed. ! If the optional argument seed is missing, then the default seed is @@ -1134,13 +1115,12 @@ FUNCTION next_rng_seed(seed,error) RESULT(next_seed) REAL(KIND=dp), DIMENSION(3, 2), & INTENT(IN), OPTIONAL :: seed - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp), DIMENSION(3, 2) :: next_seed ! ------------------------------------------------------------------------- IF (PRESENT(seed)) THEN - CALL check_seed(seed,error) + CALL check_seed(seed) CALL mat_vec_mod_m(a1p127,seed(:,1),next_seed(:,1),m1) CALL mat_vec_mod_m(a2p127,seed(:,2),next_seed(:,2),m2) ELSE @@ -1153,15 +1133,13 @@ END FUNCTION next_rng_seed !> \brief ... !> \param array ... !> \param rng_stream ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE random_numbers_1(array,rng_stream,error) + SUBROUTINE random_numbers_1(array,rng_stream) ! Fill entity array with random numbers from the RNG stream rng_stream. REAL(KIND=dp), DIMENSION(:) :: array TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'random_numbers_1', & routineP = moduleN//':'//routineN @@ -1173,10 +1151,10 @@ SUBROUTINE random_numbers_1(array,rng_stream,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) DO i=1,SIZE(array) - array(i) = next_random_number(rng_stream,error=error) + array(i) = next_random_number(rng_stream) END DO END SUBROUTINE random_numbers_1 @@ -1185,15 +1163,13 @@ END SUBROUTINE random_numbers_1 !> \brief ... !> \param array ... !> \param rng_stream ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE random_numbers_2(array,rng_stream,error) + SUBROUTINE random_numbers_2(array,rng_stream) ! Fill entity array with random numbers from the RNG stream rng_stream. REAL(KIND=dp), DIMENSION(:, :) :: array TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'random_numbers_2', & routineP = moduleN//':'//routineN @@ -1205,11 +1181,11 @@ SUBROUTINE random_numbers_2(array,rng_stream,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) DO j=1,SIZE(array,2) DO i=1,SIZE(array,1) - array(i,j) = next_random_number(rng_stream,error=error) + array(i,j) = next_random_number(rng_stream) END DO END DO @@ -1219,15 +1195,13 @@ END SUBROUTINE random_numbers_2 !> \brief ... !> \param array ... !> \param rng_stream ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE random_numbers_3(array,rng_stream,error) + SUBROUTINE random_numbers_3(array,rng_stream) ! Fill entity array with random numbers from the RNG stream rng_stream. REAL(KIND=dp), DIMENSION(:, :, :) :: array TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'random_numbers_3', & routineP = moduleN//':'//routineN @@ -1239,12 +1213,12 @@ SUBROUTINE random_numbers_3(array,rng_stream,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) DO k=1,SIZE(array,3) DO j=1,SIZE(array,2) DO i=1,SIZE(array,1) - array(i,j,k) = next_random_number(rng_stream,error=error) + array(i,j,k) = next_random_number(rng_stream) END DO END DO END DO @@ -1255,16 +1229,14 @@ END SUBROUTINE random_numbers_3 !> \brief ... !> \param rng_stream ... !> \param rng_record ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_rng_stream(rng_stream,rng_record,error) + SUBROUTINE read_rng_stream(rng_stream,rng_record) ! Read a RNG stream from a record given as an internal file (string). TYPE(rng_stream_type), POINTER :: rng_stream CHARACTER(LEN=rng_record_length), & INTENT(IN) :: rng_record - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_rng_stream', & routineP = moduleN//':'//routineN @@ -1276,10 +1248,10 @@ SUBROUTINE read_rng_stream(rng_stream,rng_record,error) failure = .FALSE. - IF (ASSOCIATED(rng_stream)) CALL delete_rng_stream(rng_stream,error=error) + IF (ASSOCIATED(rng_stream)) CALL delete_rng_stream(rng_stream) ALLOCATE (rng_stream,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) READ (UNIT=rng_record,FMT=rng_record_format)& rng_stream%name,& @@ -1297,14 +1269,12 @@ END SUBROUTINE read_rng_stream ! ***************************************************************************** !> \brief ... !> \param rng_stream ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE reset_rng_stream(rng_stream,error) + SUBROUTINE reset_rng_stream(rng_stream) ! Reset a random number stream to its initial state. TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'reset_rng_stream', & routineP = moduleN//':'//routineN @@ -1315,7 +1285,7 @@ SUBROUTINE reset_rng_stream(rng_stream,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) rng_stream%cg = rng_stream%ig rng_stream%bg = rng_stream%ig @@ -1341,14 +1311,12 @@ END SUBROUTINE reset_rng_substream ! ***************************************************************************** !> \brief ... !> \param rng_stream ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE reset_to_next_rng_substream(rng_stream,error) + SUBROUTINE reset_to_next_rng_substream(rng_stream) ! Reset a random number stream to the beginning of its next substream. TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'reset_to_next_rng_substream', & routineP = moduleN//':'//routineN @@ -1360,7 +1328,7 @@ SUBROUTINE reset_to_next_rng_substream(rng_stream,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) u = 0.0_dp @@ -1464,14 +1432,13 @@ END FUNCTION rn53 !> \param extended_precision ... !> \param buffer ... !> \param buffer_filled ... -!> \param error ... !> \par History !> 2009-11-09 setting the buffer and buffer_filled components !> added [lwalewski] ! ***************************************************************************** SUBROUTINE set_rng_stream(rng_stream,name,distribution_type,bg,cg,ig,& seed,antithetic,extended_precision,& - buffer,buffer_filled,error) + buffer,buffer_filled) ! Set the components of a RNG stream. ! NOTE: The manipulation of an active RNG stream is discouraged. @@ -1484,7 +1451,6 @@ SUBROUTINE set_rng_stream(rng_stream,name,distribution_type,bg,cg,ig,& LOGICAL, INTENT(IN), OPTIONAL :: antithetic, extended_precision REAL(KIND=dp), INTENT(IN), OPTIONAL :: buffer LOGICAL, INTENT(IN), OPTIONAL :: buffer_filled - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_rng_stream', & routineP = moduleN//':'//routineN @@ -1495,7 +1461,7 @@ SUBROUTINE set_rng_stream(rng_stream,name,distribution_type,bg,cg,ig,& failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) IF (PRESENT(name)) rng_stream%name = name IF (PRESENT(distribution_type)) THEN @@ -1507,7 +1473,7 @@ SUBROUTINE set_rng_stream(rng_stream,name,distribution_type,bg,cg,ig,& IF (PRESENT(seed)) THEN ! Sets the initial seed of the stream to seed ! NOTE: The use of this method is discouraged - CALL check_seed(seed,error) + CALL check_seed(seed) rng_stream%ig = seed rng_stream%cg = seed rng_stream%bg = seed @@ -1569,9 +1535,8 @@ END SUBROUTINE write_rng_matrices !> \param rng_stream ... !> \param output_unit ... !> \param write_all ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_rng_stream(rng_stream,output_unit,write_all,error) + SUBROUTINE write_rng_stream(rng_stream,output_unit,write_all) ! write_all: if .TRUE., then print all stream informations. ! (the default is .FALSE.) @@ -1579,7 +1544,6 @@ SUBROUTINE write_rng_stream(rng_stream,output_unit,write_all,error) TYPE(rng_stream_type), POINTER :: rng_stream INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN), OPTIONAL :: write_all - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_rng_stream', & routineP = moduleN//':'//routineN @@ -1590,7 +1554,7 @@ SUBROUTINE write_rng_stream(rng_stream,output_unit,write_all,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) IF (PRESENT(write_all)) THEN my_write_all = write_all diff --git a/src/constraint.F b/src/constraint.F index 425933d686..243652a64c 100644 --- a/src/constraint.F +++ b/src/constraint.F @@ -91,13 +91,12 @@ MODULE constraint !> \param cell ... !> \param group ... !> \param local_particles ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - Extension to Intermolecular constraints ! ***************************************************************************** SUBROUTINE shake_control( gci, local_molecules, molecule_set, molecule_kind_set, & particle_set, pos, vel, dt, shake_tol, log_unit, lagrange_mult, dump_lm, & - cell, group, local_particles,error ) + cell, group, local_particles) TYPE(global_constraint_type), POINTER :: gci TYPE(distribution_1d_type), POINTER :: local_molecules @@ -111,7 +110,6 @@ SUBROUTINE shake_control( gci, local_molecules, molecule_set, molecule_kind_set, TYPE(cell_type), POINTER :: cell INTEGER, INTENT(in) :: group TYPE(distribution_1d_type), POINTER :: local_particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'shake_control', & routineP = moduleN//':'//routineN @@ -158,21 +156,21 @@ SUBROUTINE shake_control( gci, local_molecules, molecule_set, molecule_kind_set, ! 3x3 IF ( n3x3con /= 0 ) & CALL shake_3x3_int( molecule, particle_set, pos, vel, dt, ishake_int,& - int_max_sigma, error) + int_max_sigma) ! 4x6 IF ( n4x6con /= 0 ) & CALL shake_4x6_int( molecule, particle_set, pos, vel, dt, ishake_int,& - int_max_sigma, error) + int_max_sigma) ! Collective Variables IF ( ncolv%ntot /= 0 ) & CALL shake_colv_int(molecule, particle_set, pos, vel, dt, ishake_int,& - cell, imass, int_max_sigma, error ) + cell, imass, int_max_sigma) END DO Shake_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) - CALL shake_int_info(log_unit,i,ishake_int,max_sigma,error) + CALL shake_int_info(log_unit,i,ishake_int,max_sigma) ! Virtual Site IF ( nvsitecon /= 0 ) & - CALL shake_vsite_int( molecule, pos, error) + CALL shake_vsite_int( molecule, pos) END DO END DO MOL ! Intermolecular constraints @@ -181,24 +179,24 @@ SUBROUTINE shake_control( gci, local_molecules, molecule_set, molecule_kind_set, ! 3x3 IF ( gci%ng3x3 /= 0 ) & CALL shake_3x3_ext( gci, particle_set, pos, vel, dt, ishake_ext,& - max_sigma, error) + max_sigma) ! 4x6 IF ( gci%ng4x6 /= 0 ) & CALL shake_4x6_ext( gci, particle_set, pos, vel, dt, ishake_ext,& - max_sigma, error) + max_sigma) ! Collective Variables IF ( gci%ncolv%ntot /= 0 ) & CALL shake_colv_ext(gci, particle_set, pos, vel, dt, ishake_ext,& - cell, imass, max_sigma, error) + cell, imass, max_sigma) ! Virtual Site IF ( gci%nvsite /= 0 ) & - CALL shake_vsite_ext( gci, pos, error) + CALL shake_vsite_ext( gci, pos) CALL restore_temporary_set( particle_set, local_particles, pos=pos, vel=vel ) END IF - CALL shake_ext_info(log_unit,ishake_ext,max_sigma,error) + CALL shake_ext_info(log_unit,ishake_ext,max_sigma) END DO Shake_Inter_Loop CALL dump_lagrange_mult(dump_lm, lagrange_mult,local_molecules,molecule_set,gci,& - molecule_kind_set,group,"S",error) + molecule_kind_set,group,"S") CALL timestop(handle) END SUBROUTINE shake_control @@ -219,13 +217,12 @@ END SUBROUTINE shake_control !> \param cell ... !> \param group ... !> \param local_particles ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - Extension to Intermolecular constraints ! ***************************************************************************** SUBROUTINE rattle_control( gci, local_molecules, molecule_set, molecule_kind_set, & particle_set, vel, dt, rattle_tol, log_unit, lagrange_mult, dump_lm, cell, group,& - local_particles, error ) + local_particles) TYPE(global_constraint_type), POINTER :: gci TYPE(distribution_1d_type), POINTER :: local_molecules @@ -239,7 +236,6 @@ SUBROUTINE rattle_control( gci, local_molecules, molecule_set, molecule_kind_set TYPE(cell_type), POINTER :: cell INTEGER, INTENT(in) :: group TYPE(distribution_1d_type), POINTER :: local_particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rattle_control', & routineP = moduleN//':'//routineN @@ -284,17 +280,17 @@ SUBROUTINE rattle_control( gci, local_molecules, molecule_set, molecule_kind_set irattle_int = irattle_int + 1 ! 3x3 IF ( n3x3con /= 0 ) & - CALL rattle_3x3_int( molecule, particle_set, vel, dt, error) + CALL rattle_3x3_int( molecule, particle_set, vel, dt) ! 4x6 IF ( n4x6con /= 0 ) & - CALL rattle_4x6_int( molecule, particle_set, vel, dt, error) + CALL rattle_4x6_int( molecule, particle_set, vel, dt) ! Collective Variables IF ( ncolv%ntot /= 0 ) & CALL rattle_colv_int( molecule, particle_set, vel, dt, & - irattle_int, cell, imass, int_max_sigma, error ) + irattle_int, cell, imass, int_max_sigma) END DO Rattle_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) - CALL rattle_int_info(log_unit,i,irattle_int,max_sigma,error) + CALL rattle_int_info(log_unit,i,irattle_int,max_sigma) END DO END DO MOL ! Intermolecular Constraints @@ -302,20 +298,20 @@ SUBROUTINE rattle_control( gci, local_molecules, molecule_set, molecule_kind_set CALL update_temporary_set ( group, vel = vel ) ! 3x3 IF ( gci%ng3x3 /= 0 ) & - CALL rattle_3x3_ext( gci, particle_set, vel, dt, error) + CALL rattle_3x3_ext( gci, particle_set, vel, dt) ! 4x6 IF ( gci%ng4x6 /= 0 ) & - CALL rattle_4x6_ext( gci, particle_set, vel, dt, error) + CALL rattle_4x6_ext( gci, particle_set, vel, dt) ! Collective Variables IF ( gci%ncolv%ntot /= 0 ) & CALL rattle_colv_ext( gci, particle_set, vel, dt, & - irattle_ext, cell, imass, max_sigma, error ) + irattle_ext, cell, imass, max_sigma) CALL restore_temporary_set ( particle_set, local_particles, vel = vel ) END IF - CALL rattle_ext_info(log_unit,irattle_ext,max_sigma,error) + CALL rattle_ext_info(log_unit,irattle_ext,max_sigma) END DO Rattle_Inter_Loop CALL dump_lagrange_mult(dump_lm,lagrange_mult,local_molecules,molecule_set,gci,& - molecule_kind_set,group,"R",error) + molecule_kind_set,group,"R") CALL timestop(handle) END SUBROUTINE rattle_control @@ -339,13 +335,12 @@ END SUBROUTINE rattle_control !> \param u ... !> \param cell ... !> \param local_particles ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - Extension to Intermolecular constraints ! ***************************************************************************** SUBROUTINE shake_roll_control( gci, local_molecules, molecule_set,& molecule_kind_set, particle_set, pos, vel, dt, simpar, roll_tol, iroll,& - vector_r, vector_v, group, u, cell, local_particles, error ) + vector_r, vector_v, group, u, cell, local_particles) TYPE(global_constraint_type), POINTER :: gci TYPE(distribution_1d_type), POINTER :: local_molecules @@ -363,7 +358,6 @@ SUBROUTINE shake_roll_control( gci, local_molecules, molecule_set,& INTENT(IN), OPTIONAL :: u TYPE(cell_type), POINTER :: cell TYPE(distribution_1d_type), POINTER :: local_particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'shake_roll_control', & routineP = moduleN//':'//routineN @@ -423,23 +417,23 @@ SUBROUTINE shake_roll_control( gci, local_molecules, molecule_set,& ! 3x3 IF ( n3x3con /= 0 ) & CALL shake_roll_3x3_int( molecule, particle_set, pos, vel, r_shake,& - v_shake, dt, ishake_int, int_max_sigma, error) + v_shake, dt, ishake_int, int_max_sigma) ! 4x6 IF ( n4x6con /= 0 ) & CALL shake_roll_4x6_int( molecule, particle_set, pos, vel, r_shake,& - dt, ishake_int, int_max_sigma, error) + dt, ishake_int, int_max_sigma) ! Collective Variables IF ( ncolv%ntot /= 0 ) & CALL shake_roll_colv_int( molecule, particle_set, pos, vel, r_shake,& - v_shake, dt, ishake_int, cell, imass, int_max_sigma, error ) + v_shake, dt, ishake_int, cell, imass, int_max_sigma) END DO Shake_Roll_Intra_Loop max_sigma = MAX(max_sigma, int_max_sigma) - CALL shake_int_info(log_unit,i,ishake_int,max_sigma,error) + CALL shake_int_info(log_unit,i,ishake_int,max_sigma) ! Virtual Site IF ( nvsitecon /= 0 ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Virtual Site Constraint/Restraint not implemented for SHAKE_ROLL!", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO END DO MOL @@ -449,26 +443,26 @@ SUBROUTINE shake_roll_control( gci, local_molecules, molecule_set,& ! 3x3 IF ( gci%ng3x3 /= 0 ) & CALL shake_roll_3x3_ext( gci, particle_set, pos, vel, r_shake,& - v_shake, dt, ishake_ext, max_sigma, error) + v_shake, dt, ishake_ext, max_sigma) ! 4x6 IF ( gci%ng4x6 /= 0 ) & CALL shake_roll_4x6_ext( gci, particle_set, pos, vel, r_shake,& - dt, ishake_ext, max_sigma, error) + dt, ishake_ext, max_sigma) ! Collective Variables IF ( gci%ncolv%ntot /= 0 ) & CALL shake_roll_colv_ext( gci, particle_set, pos, vel, r_shake,& - v_shake, dt, ishake_ext, cell, imass, max_sigma, error ) + v_shake, dt, ishake_ext, cell, imass, max_sigma) ! Virtual Site IF ( gci%nvsite /= 0 ) & CALL cp_unimplemented_error(fromWhere=routineP, & message="Virtual Site Constraint/Restraint not implemented for SHAKE_ROLL!", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CALL restore_temporary_set ( particle_set, local_particles, pos = pos, vel = vel ) END IF - CALL shake_ext_info(log_unit,ishake_ext,max_sigma,error) + CALL shake_ext_info(log_unit,ishake_ext,max_sigma) END DO Shake_Inter_Loop CALL dump_lagrange_mult(dump_lm,lagrange_mult,local_molecules,molecule_set,gci,& - molecule_kind_set,group,"S",error) + molecule_kind_set,group,"S") CALL check_tol ( roll_tol, iroll, 'SHAKE', r_shake ) CALL timestop(handle) @@ -492,13 +486,12 @@ END SUBROUTINE shake_roll_control !> \param u ... !> \param cell ... !> \param local_particles ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - Extension to Intermolecular constraints ! ***************************************************************************** SUBROUTINE rattle_roll_control( gci, local_molecules, molecule_set, & molecule_kind_set, particle_set, vel, dt, simpar, vector,& - veps, roll_tol, iroll, para_env, u, cell, local_particles, error ) + veps, roll_tol, iroll, para_env, u, cell, local_particles) TYPE(global_constraint_type), POINTER :: gci TYPE(distribution_1d_type), POINTER :: local_molecules @@ -518,7 +511,6 @@ SUBROUTINE rattle_roll_control( gci, local_molecules, molecule_set, & INTENT(IN), OPTIONAL :: u TYPE(cell_type), POINTER :: cell TYPE(distribution_1d_type), POINTER :: local_particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rattle_roll_control', & routineP = moduleN//':'//routineN @@ -579,18 +571,18 @@ SUBROUTINE rattle_roll_control( gci, local_molecules, molecule_set, & ! 3x3 IF ( n3x3con /= 0 ) & CALL rattle_roll_3x3_int( molecule, particle_set, vel, r_rattle, dt,& - veps, error ) + veps) ! 4x6 IF ( n4x6con /= 0 ) & CALL rattle_roll_4x6_int( molecule, particle_set, vel, r_rattle, dt,& - veps, error ) + veps) ! Collective Variables IF ( ncolv%ntot /= 0 ) & CALL rattle_roll_colv_int( molecule, particle_set, vel, r_rattle, dt,& - irattle_int, veps, cell, imass, int_max_sigma, error ) + irattle_int, veps, cell, imass, int_max_sigma) END DO Rattle_Roll_Intramolecular max_sigma = MAX(max_sigma, int_max_sigma) - CALL rattle_int_info(log_unit,i,irattle_int,max_sigma,error) + CALL rattle_int_info(log_unit,i,irattle_int,max_sigma) END DO END DO MOL ! Intermolecular Constraints @@ -599,21 +591,21 @@ SUBROUTINE rattle_roll_control( gci, local_molecules, molecule_set, & ! 3x3 IF ( gci%ng3x3 /= 0 )& CALL rattle_roll_3x3_ext( gci, particle_set, vel, r_rattle, dt,& - veps, error ) + veps) ! 4x6 IF ( gci%ng4x6 /= 0 ) & CALL rattle_roll_4x6_ext( gci, particle_set, vel, r_rattle, dt,& - veps, error ) + veps) ! Collective Variables IF ( gci%ncolv%ntot /= 0 ) & CALL rattle_roll_colv_ext( gci, particle_set, vel, r_rattle, dt,& - irattle_ext, veps, cell, imass, max_sigma, error ) + irattle_ext, veps, cell, imass, max_sigma) CALL restore_temporary_set ( particle_set, local_particles, vel = vel ) END IF - CALL rattle_ext_info(log_unit,irattle_ext,max_sigma,error) + CALL rattle_ext_info(log_unit,irattle_ext,max_sigma) END DO Rattle_Inter_Loop CALL dump_lagrange_mult(dump_lm,lagrange_mult,local_molecules,molecule_set,gci,& - molecule_kind_set,para_env%group,"R",error) + molecule_kind_set,para_env%group,"R") CALL check_tol ( roll_tol, iroll, 'RATTLE', veps = veps ) CALL timestop(handle) END SUBROUTINE rattle_roll_control @@ -628,12 +620,11 @@ END SUBROUTINE rattle_roll_control !> \param molecule_kind_set ... !> \param group ... !> \param id_type ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - Dumps lagrange multipliers ! ***************************************************************************** SUBROUTINE dump_lagrange_mult(dump_lm,log_unit,local_molecules,molecule_set,gci,& - molecule_kind_set, group, id_type, error) + molecule_kind_set, group, id_type) LOGICAL, INTENT(IN) :: dump_lm INTEGER, INTENT(IN) :: log_unit TYPE(distribution_1d_type), POINTER :: local_molecules @@ -642,7 +633,6 @@ SUBROUTINE dump_lagrange_mult(dump_lm,log_unit,local_molecules,molecule_set,gci, TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) INTEGER, INTENT(IN) :: group CHARACTER(LEN=1), INTENT(IN) :: id_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_lagrange_mult', & routineP = moduleN//':'//routineN @@ -668,7 +658,7 @@ SUBROUTINE dump_lagrange_mult(dump_lm,log_unit,local_molecules,molecule_set,gci, IF (dump_lm.AND.(do_int_constraint.OR.do_ext_constraint)) THEN nkind = SIZE ( molecule_kind_set ) ALLOCATE(lagr(nconstraint),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) lagr = 0.0_dp ! Dump lagrange multipliers for Intramolecular Constraints my_index = 0 @@ -730,7 +720,7 @@ SUBROUTINE dump_lagrange_mult(dump_lm,log_unit,local_molecules,molecule_set,gci, ELSEIF (id_type=="R") THEN label = "Rattle Lagrangian Multipliers:" ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF WRITE(log_unit,FMT='(A,T40,4F15.9)')TRIM(label),lagr(1:MIN(4,SIZE(lagr))) DO j = 5, SIZE(lagr), 4 @@ -738,7 +728,7 @@ SUBROUTINE dump_lagrange_mult(dump_lm,log_unit,local_molecules,molecule_set,gci, END DO END IF DEALLOCATE(lagr,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -750,14 +740,12 @@ END SUBROUTINE dump_lagrange_mult !> \param i ... !> \param ishake_int ... !> \param max_sigma ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - University of Zurich ! ***************************************************************************** - SUBROUTINE shake_int_info(log_unit,i,ishake_int,max_sigma,error) + SUBROUTINE shake_int_info(log_unit,i,ishake_int,max_sigma) INTEGER, INTENT(IN) :: log_unit, i, ishake_int REAL(KIND=dp), INTENT(IN) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'shake_int_info', & routineP = moduleN//':'//routineN @@ -783,14 +771,12 @@ END SUBROUTINE shake_int_info !> \param log_unit ... !> \param ishake_ext ... !> \param max_sigma ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - University of Zurich ! ***************************************************************************** - SUBROUTINE shake_ext_info(log_unit,ishake_ext,max_sigma,error) + SUBROUTINE shake_ext_info(log_unit,ishake_ext,max_sigma) INTEGER, INTENT(IN) :: log_unit, ishake_ext REAL(KIND=dp), INTENT(IN) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'shake_ext_info', & routineP = moduleN//':'//routineN @@ -817,14 +803,12 @@ END SUBROUTINE shake_ext_info !> \param i ... !> \param irattle_int ... !> \param max_sigma ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - University of Zurich ! ***************************************************************************** - SUBROUTINE rattle_int_info(log_unit,i,irattle_int,max_sigma,error) + SUBROUTINE rattle_int_info(log_unit,i,irattle_int,max_sigma) INTEGER, INTENT(IN) :: log_unit, i, irattle_int REAL(KIND=dp), INTENT(IN) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rattle_int_info', & routineP = moduleN//':'//routineN @@ -850,14 +834,12 @@ END SUBROUTINE rattle_int_info !> \param log_unit ... !> \param irattle_ext ... !> \param max_sigma ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] 2007 - University of Zurich ! ***************************************************************************** - SUBROUTINE rattle_ext_info(log_unit,irattle_ext,max_sigma,error) + SUBROUTINE rattle_ext_info(log_unit,irattle_ext,max_sigma) INTEGER, INTENT(IN) :: log_unit, irattle_ext REAL(KIND=dp), INTENT(IN) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rattle_ext_info', & routineP = moduleN//':'//routineN @@ -887,12 +869,11 @@ END SUBROUTINE rattle_ext_info !> \param molecule_kind_set ... !> \param dt ... !> \param root_section ... -!> \param error ... !> \date 02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE shake_update_targets( gci, local_molecules, molecule_set, & - molecule_kind_set, dt, root_section, error ) + molecule_kind_set, dt, root_section) TYPE(global_constraint_type), POINTER :: gci TYPE(distribution_1d_type), POINTER :: local_molecules @@ -900,7 +881,6 @@ SUBROUTINE shake_update_targets( gci, local_molecules, molecule_set, & TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) REAL(kind=dp), INTENT(in) :: dt TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'shake_update_targets', & routineP = moduleN//':'//routineN @@ -914,7 +894,7 @@ SUBROUTINE shake_update_targets( gci, local_molecules, molecule_set, & TYPE(section_vals_type), POINTER :: motion_section CALL timeset(routineN,handle) - motion_section => section_vals_get_subs_vals(root_section,"MOTION",error=error) + motion_section => section_vals_get_subs_vals(root_section,"MOTION") nkind = SIZE ( molecule_kind_set ) do_ext_constraint = (gci%ntot/=0) ! Intramolecular Constraints @@ -927,13 +907,13 @@ SUBROUTINE shake_update_targets( gci, local_molecules, molecule_set, & CALL get_molecule_kind ( molecule_kind, ncolv=ncolv ) ! Updating TARGETS for Collective Variables only - IF ( ncolv%ntot /= 0 ) CALL shake_update_colv_int(molecule, dt, motion_section, error) + IF ( ncolv%ntot /= 0 ) CALL shake_update_colv_int(molecule, dt, motion_section) END DO END DO MOL ! Intermolecular constraints IF (do_ext_constraint) THEN ! Collective Variables - IF (gci%ncolv%ntot/= 0) CALL shake_update_colv_ext(gci, dt, motion_section, error) + IF (gci%ncolv%ntot/= 0) CALL shake_update_colv_ext(gci, dt, motion_section) END IF CALL timestop(handle) END SUBROUTINE shake_update_targets diff --git a/src/constraint_3x3.F b/src/constraint_3x3.F index de03dc8455..5ec9557883 100644 --- a/src/constraint_3x3.F +++ b/src/constraint_3x3.F @@ -52,12 +52,11 @@ MODULE constraint_3x3 !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_3x3_int( molecule, particle_set, pos, vel, dt, ishake,& - max_sigma, error) + max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -65,7 +64,6 @@ SUBROUTINE shake_3x3_int( molecule, particle_set, pos, vel, dt, ishake,& REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng3x3 TYPE(fixd_constraint_type), & @@ -82,7 +80,7 @@ SUBROUTINE shake_3x3_int( molecule, particle_set, pos, vel, dt, ishake,& CALL get_molecule ( molecule, first_atom = first_atom, lg3x3=lg3x3 ) ! Real Shake CALL shake_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & - particle_set, pos, vel, dt, ishake, max_sigma, error) + particle_set, pos, vel, dt, ishake, max_sigma) END SUBROUTINE shake_3x3_int @@ -97,12 +95,11 @@ END SUBROUTINE shake_3x3_int !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_roll_3x3_int( molecule, particle_set, pos, vel, r_shake, & - v_shake, dt, ishake, max_sigma, error ) + v_shake, dt, ishake, max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -112,7 +109,6 @@ SUBROUTINE shake_roll_3x3_int( molecule, particle_set, pos, vel, r_shake, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng3x3 TYPE(fixd_constraint_type), & @@ -129,8 +125,7 @@ SUBROUTINE shake_roll_3x3_int( molecule, particle_set, pos, vel, r_shake, & CALL get_molecule ( molecule, first_atom = first_atom, lg3x3=lg3x3 ) ! Real Shake CALL shake_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & - particle_set, pos, vel, r_shake, v_shake, dt, ishake, max_sigma,& - error ) + particle_set, pos, vel, r_shake, v_shake, dt, ishake, max_sigma) END SUBROUTINE shake_roll_3x3_int @@ -142,11 +137,10 @@ END SUBROUTINE shake_roll_3x3_int !> \param r_rattle ... !> \param dt ... !> \param veps ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_roll_3x3_int( molecule, particle_set, vel, r_rattle, dt, veps, error) + SUBROUTINE rattle_roll_3x3_int( molecule, particle_set, vel, r_rattle, dt, veps) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -156,7 +150,6 @@ SUBROUTINE rattle_roll_3x3_int( molecule, particle_set, vel, r_rattle, dt, veps, REAL(kind=dp), INTENT(in) :: dt REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: veps - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom TYPE(fixd_constraint_type), & @@ -173,7 +166,7 @@ SUBROUTINE rattle_roll_3x3_int( molecule, particle_set, vel, r_rattle, dt, veps, CALL get_molecule ( molecule, first_atom = first_atom, lg3x3=lg3x3 ) ! Real Rattle CALL rattle_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & - particle_set, vel, r_rattle, dt, veps, error) + particle_set, vel, r_rattle, dt, veps) END SUBROUTINE rattle_roll_3x3_int @@ -183,17 +176,15 @@ END SUBROUTINE rattle_roll_3x3_int !> \param particle_set ... !> \param vel ... !> \param dt ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_3x3_int( molecule, particle_set, vel, dt, error) + SUBROUTINE rattle_3x3_int( molecule, particle_set, vel, dt) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) REAL(kind=dp), INTENT(in) :: dt - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: first_atom TYPE(fixd_constraint_type), & @@ -210,7 +201,7 @@ SUBROUTINE rattle_3x3_int( molecule, particle_set, vel, dt, error) CALL get_molecule ( molecule, first_atom = first_atom, lg3x3=lg3x3 ) ! Real Rattle CALL rattle_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & - particle_set, vel, dt, error) + particle_set, vel, dt) END SUBROUTINE rattle_3x3_int @@ -223,12 +214,11 @@ END SUBROUTINE rattle_3x3_int !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_3x3_ext( gci, particle_set, pos, vel, dt, ishake,& - max_sigma, error) + max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -236,7 +226,6 @@ SUBROUTINE shake_3x3_ext( gci, particle_set, pos, vel, dt, ishake,& REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng3x3 TYPE(fixd_constraint_type), & @@ -252,7 +241,7 @@ SUBROUTINE shake_3x3_ext( gci, particle_set, pos, vel, dt, ishake,& lg3x3 => gci%lg3x3 ! Real Shake CALL shake_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & - particle_set, pos, vel, dt, ishake, max_sigma, error) + particle_set, pos, vel, dt, ishake, max_sigma) END SUBROUTINE shake_3x3_ext @@ -267,12 +256,11 @@ END SUBROUTINE shake_3x3_ext !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_roll_3x3_ext(gci, particle_set, pos, vel, r_shake, & - v_shake, dt, ishake, max_sigma, error ) + v_shake, dt, ishake, max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -282,7 +270,6 @@ SUBROUTINE shake_roll_3x3_ext(gci, particle_set, pos, vel, r_shake, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng3x3 TYPE(fixd_constraint_type), & @@ -298,8 +285,7 @@ SUBROUTINE shake_roll_3x3_ext(gci, particle_set, pos, vel, r_shake, & lg3x3 => gci%lg3x3 ! Real Shake CALL shake_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & - particle_set, pos, vel, r_shake, v_shake, dt, ishake, max_sigma,& - error ) + particle_set, pos, vel, r_shake, v_shake, dt, ishake, max_sigma) END SUBROUTINE shake_roll_3x3_ext @@ -311,11 +297,10 @@ END SUBROUTINE shake_roll_3x3_ext !> \param r_rattle ... !> \param dt ... !> \param veps ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_roll_3x3_ext( gci, particle_set, vel, r_rattle, dt, veps, error) + SUBROUTINE rattle_roll_3x3_ext( gci, particle_set, vel, r_rattle, dt, veps) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -325,7 +310,6 @@ SUBROUTINE rattle_roll_3x3_ext( gci, particle_set, vel, r_rattle, dt, veps, erro REAL(kind=dp), INTENT(in) :: dt REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: veps - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom TYPE(fixd_constraint_type), & @@ -340,7 +324,7 @@ SUBROUTINE rattle_roll_3x3_ext( gci, particle_set, vel, r_rattle, dt, veps, erro lg3x3 => gci%lg3x3 ! Real Rattle CALL rattle_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & - particle_set, vel, r_rattle, dt, veps, error) + particle_set, vel, r_rattle, dt, veps) END SUBROUTINE rattle_roll_3x3_ext @@ -350,17 +334,15 @@ END SUBROUTINE rattle_roll_3x3_ext !> \param particle_set ... !> \param vel ... !> \param dt ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_3x3_ext( gci, particle_set, vel, dt, error) + SUBROUTINE rattle_3x3_ext( gci, particle_set, vel, dt) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) REAL(kind=dp), INTENT(in) :: dt - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: first_atom TYPE(fixd_constraint_type), & @@ -375,7 +357,7 @@ SUBROUTINE rattle_3x3_ext( gci, particle_set, vel, dt, error) lg3x3 => gci%lg3x3 ! Real Rattle CALL rattle_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & - particle_set, vel, dt, error) + particle_set, vel, dt) END SUBROUTINE rattle_3x3_ext @@ -392,12 +374,11 @@ END SUBROUTINE rattle_3x3_ext !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & - particle_set, pos, vel, dt, ishake, max_sigma, error) + particle_set, pos, vel, dt, ishake, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -410,7 +391,6 @@ SUBROUTINE shake_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c @@ -555,12 +535,11 @@ END SUBROUTINE shake_3x3_low !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & - particle_set, pos, vel, r_shake, v_shake, dt, ishake, max_sigma, error ) + particle_set, pos, vel, r_shake, v_shake, dt, ishake, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -575,7 +554,6 @@ SUBROUTINE shake_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, ng3x3, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c @@ -735,12 +713,11 @@ END SUBROUTINE shake_roll_3x3_low !> \param r_rattle ... !> \param dt ... !> \param veps ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE rattle_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & - particle_set, vel, r_rattle, dt, veps, error) + particle_set, vel, r_rattle, dt, veps) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list TYPE(g3x3_constraint_type), POINTER :: g3x3_list( : ) @@ -754,7 +731,6 @@ SUBROUTINE rattle_roll_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & REAL(kind=dp), INTENT(in) :: dt REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: veps - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c @@ -846,12 +822,11 @@ END SUBROUTINE rattle_roll_3x3_low !> \param particle_set ... !> \param vel ... !> \param dt ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE rattle_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & - particle_set, vel, dt, error) + particle_set, vel, dt) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -862,7 +837,6 @@ SUBROUTINE rattle_3x3_low( fixd_list, g3x3_list, lg3x3, first_atom, & TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) REAL(kind=dp), INTENT(in) :: dt - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: iconst, index_a, index_b, & index_c diff --git a/src/constraint_4x6.F b/src/constraint_4x6.F index 7897bfef18..5c7159d694 100644 --- a/src/constraint_4x6.F +++ b/src/constraint_4x6.F @@ -52,19 +52,17 @@ MODULE constraint_4x6 !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_4x6_int( molecule, particle_set, pos, vel, dt, ishake,& - max_sigma, error) + max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: pos( :, : ), vel( :, : ) REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -81,7 +79,7 @@ SUBROUTINE shake_4x6_int( molecule, particle_set, pos, vel, dt, ishake,& CALL get_molecule ( molecule, first_atom = first_atom, lg4x6=lg4x6 ) ! Real Shake CALL shake_4x6_low( fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & - particle_set, pos, vel, dt, ishake, max_sigma, error) + particle_set, pos, vel, dt, ishake, max_sigma) END SUBROUTINE shake_4x6_int @@ -95,12 +93,11 @@ END SUBROUTINE shake_4x6_int !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_roll_4x6_int( molecule, particle_set, pos, vel, r_shake, & - dt, ishake, max_sigma, error) + dt, ishake, max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: pos( :, : ), vel( :, : ) @@ -109,7 +106,6 @@ SUBROUTINE shake_roll_4x6_int( molecule, particle_set, pos, vel, r_shake, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -126,8 +122,7 @@ SUBROUTINE shake_roll_4x6_int( molecule, particle_set, pos, vel, r_shake, & CALL get_molecule ( molecule, first_atom = first_atom, lg4x6=lg4x6 ) ! Real Shake CALL shake_roll_4x6_low(fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & - particle_set, pos, vel, r_shake, dt, ishake, max_sigma,& - error) + particle_set, pos, vel, r_shake, dt, ishake, max_sigma) END SUBROUTINE shake_roll_4x6_int @@ -137,16 +132,14 @@ END SUBROUTINE shake_roll_4x6_int !> \param particle_set ... !> \param vel ... !> \param dt ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_4x6_int( molecule, particle_set, vel, dt, error) + SUBROUTINE rattle_4x6_int( molecule, particle_set, vel, dt) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) REAL(kind=dp), INTENT(in) :: dt - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -163,7 +156,7 @@ SUBROUTINE rattle_4x6_int( molecule, particle_set, vel, dt, error) CALL get_molecule ( molecule, first_atom = first_atom, lg4x6=lg4x6 ) ! Real Rattle CALL rattle_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & - particle_set, vel, dt, error) + particle_set, vel, dt) END SUBROUTINE rattle_4x6_int @@ -175,11 +168,10 @@ END SUBROUTINE rattle_4x6_int !> \param r_rattle ... !> \param dt ... !> \param veps ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_roll_4x6_int( molecule, particle_set, vel, r_rattle, dt, veps, error ) + SUBROUTINE rattle_roll_4x6_int( molecule, particle_set, vel, r_rattle, dt, veps) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) @@ -188,7 +180,6 @@ SUBROUTINE rattle_roll_4x6_int( molecule, particle_set, vel, r_rattle, dt, veps, REAL(kind=dp), INTENT(in) :: dt REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: veps - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -205,7 +196,7 @@ SUBROUTINE rattle_roll_4x6_int( molecule, particle_set, vel, r_rattle, dt, veps, CALL get_molecule ( molecule, first_atom = first_atom, lg4x6=lg4x6 ) ! Real Rattle CALL rattle_roll_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & - particle_set, vel, r_rattle, dt, veps, error ) + particle_set, vel, r_rattle, dt, veps) END SUBROUTINE rattle_roll_4x6_int @@ -218,12 +209,11 @@ END SUBROUTINE rattle_roll_4x6_int !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_4x6_ext( gci, particle_set, pos, vel, dt, ishake,& - max_sigma, error) + max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -231,7 +221,6 @@ SUBROUTINE shake_4x6_ext( gci, particle_set, pos, vel, dt, ishake,& REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -247,7 +236,7 @@ SUBROUTINE shake_4x6_ext( gci, particle_set, pos, vel, dt, ishake,& lg4x6 => gci%lg4x6 ! Real Shake CALL shake_4x6_low( fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & - particle_set, pos, vel, dt, ishake, max_sigma, error) + particle_set, pos, vel, dt, ishake, max_sigma) END SUBROUTINE shake_4x6_ext @@ -261,12 +250,11 @@ END SUBROUTINE shake_4x6_ext !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_roll_4x6_ext( gci, particle_set, pos, vel, r_shake, & - dt, ishake, max_sigma, error) + dt, ishake, max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -276,7 +264,6 @@ SUBROUTINE shake_roll_4x6_ext( gci, particle_set, pos, vel, r_shake, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -292,8 +279,7 @@ SUBROUTINE shake_roll_4x6_ext( gci, particle_set, pos, vel, r_shake, & lg4x6 => gci%lg4x6 ! Real Shake CALL shake_roll_4x6_low(fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & - particle_set, pos, vel, r_shake, dt, ishake, max_sigma,& - error) + particle_set, pos, vel, r_shake, dt, ishake, max_sigma) END SUBROUTINE shake_roll_4x6_ext @@ -303,17 +289,15 @@ END SUBROUTINE shake_roll_4x6_ext !> \param particle_set ... !> \param vel ... !> \param dt ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_4x6_ext( gci, particle_set, vel, dt, error) + SUBROUTINE rattle_4x6_ext( gci, particle_set, vel, dt) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) REAL(kind=dp), INTENT(in) :: dt - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -329,7 +313,7 @@ SUBROUTINE rattle_4x6_ext( gci, particle_set, vel, dt, error) lg4x6 => gci%lg4x6 ! Real Rattle CALL rattle_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & - particle_set, vel, dt, error) + particle_set, vel, dt) END SUBROUTINE rattle_4x6_ext @@ -341,11 +325,10 @@ END SUBROUTINE rattle_4x6_ext !> \param r_rattle ... !> \param dt ... !> \param veps ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE rattle_roll_4x6_ext( gci, particle_set, vel, r_rattle, dt, veps, error ) + SUBROUTINE rattle_roll_4x6_ext( gci, particle_set, vel, r_rattle, dt, veps) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -355,7 +338,6 @@ SUBROUTINE rattle_roll_4x6_ext( gci, particle_set, vel, r_rattle, dt, veps, erro REAL(kind=dp), INTENT(in) :: dt REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: veps - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, ng4x6 TYPE(fixd_constraint_type), & @@ -371,7 +353,7 @@ SUBROUTINE rattle_roll_4x6_ext( gci, particle_set, vel, r_rattle, dt, veps, erro lg4x6 => gci%lg4x6 ! Real Rattle CALL rattle_roll_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & - particle_set, vel, r_rattle, dt, veps, error ) + particle_set, vel, r_rattle, dt, veps) END SUBROUTINE rattle_roll_4x6_ext @@ -388,12 +370,11 @@ END SUBROUTINE rattle_roll_4x6_ext !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_4x6_low( fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & - particle_set, pos, vel, dt, ishake, max_sigma, error) + particle_set, pos, vel, dt, ishake, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list TYPE(g4x6_constraint_type), POINTER :: g4x6_list( : ) @@ -405,7 +386,6 @@ SUBROUTINE shake_4x6_low( fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c, index_d @@ -656,13 +636,11 @@ END SUBROUTINE shake_4x6_low !> \param dt ... !> \param ishake ... !> \param max_sigma ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE shake_roll_4x6_low(fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & - particle_set, pos, vel, r_shake, dt, ishake, max_sigma,& - error) + particle_set, pos, vel, r_shake, dt, ishake, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list TYPE(g4x6_constraint_type), POINTER :: g4x6_list( : ) @@ -676,7 +654,6 @@ SUBROUTINE shake_roll_4x6_low(fixd_list, g4x6_list, lg4x6, ng4x6, first_atom, & REAL(kind=dp), INTENT(in) :: dt INTEGER, INTENT(IN) :: ishake REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c, index_d @@ -952,12 +929,11 @@ END SUBROUTINE shake_roll_4x6_low !> \param particle_set ... !> \param vel ... !> \param dt ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE rattle_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & - particle_set, vel, dt, error) + particle_set, vel, dt) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -968,7 +944,6 @@ SUBROUTINE rattle_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) REAL(kind=dp), INTENT(in) :: dt - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c, index_d @@ -1109,12 +1084,11 @@ END SUBROUTINE rattle_4x6_low !> \param r_rattle ... !> \param dt ... !> \param veps ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE rattle_roll_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & - particle_set, vel, r_rattle, dt, veps, error ) + particle_set, vel, r_rattle, dt, veps) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -1129,7 +1103,6 @@ SUBROUTINE rattle_roll_4x6_low( fixd_list, g4x6_list, lg4x6, first_atom, & REAL(kind=dp), INTENT(in) :: dt REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: veps - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c, index_d diff --git a/src/constraint_clv.F b/src/constraint_clv.F index d5339a89ad..de43618046 100644 --- a/src/constraint_clv.F +++ b/src/constraint_clv.F @@ -63,13 +63,12 @@ MODULE constraint_clv !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE shake_colv_int( molecule, particle_set, pos, vel, dt, ishake,& - cell, imass, max_sigma, error ) + cell, imass, max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -79,7 +78,6 @@ SUBROUTINE shake_colv_int( molecule, particle_set, pos, vel, dt, ishake,& TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shake_colv_int', & routineP = moduleN//':'//routineN @@ -99,8 +97,7 @@ SUBROUTINE shake_colv_int( molecule, particle_set, pos, vel, dt, ishake,& CALL get_molecule ( molecule, lcolv=lcolv ) ! Real Shake CALL shake_colv_low( fixd_list, colv_list, lcolv, & - particle_set, pos, vel, dt, ishake, cell, imass, max_sigma,& - error ) + particle_set, pos, vel, dt, ishake, cell, imass, max_sigma) END SUBROUTINE shake_colv_int @@ -110,15 +107,13 @@ END SUBROUTINE shake_colv_int !> \param molecule ... !> \param dt ... !> \param motion_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE shake_update_colv_int( molecule, dt, motion_section, error) + SUBROUTINE shake_update_colv_int( molecule, dt, motion_section) TYPE(molecule_type), POINTER :: molecule REAL(kind=dp), INTENT(in) :: dt TYPE(section_vals_type), POINTER :: motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shake_update_colv_int', & routineP = moduleN//':'//routineN @@ -131,7 +126,7 @@ SUBROUTINE shake_update_colv_int( molecule, dt, motion_section, error) molecule_kind => molecule % molecule_kind CALL get_molecule_kind ( molecule_kind, colv_list=colv_list) ! Real update of the Shake target - CALL shake_update_colv_low( colv_list, dt, motion_section, error) + CALL shake_update_colv_low( colv_list, dt, motion_section) END SUBROUTINE shake_update_colv_int @@ -147,13 +142,12 @@ END SUBROUTINE shake_update_colv_int !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE rattle_colv_int( molecule, particle_set, vel, dt, irattle,& - cell, imass, max_sigma, error ) + cell, imass, max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -163,7 +157,6 @@ SUBROUTINE rattle_colv_int( molecule, particle_set, vel, dt, irattle,& TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -178,7 +171,7 @@ SUBROUTINE rattle_colv_int( molecule, particle_set, vel, dt, irattle,& CALL get_molecule ( molecule, lcolv=lcolv ) ! Real Rattle CALL rattle_colv_low ( fixd_list, colv_list, lcolv, & - particle_set, vel, dt, irattle, cell, imass, max_sigma, error ) + particle_set, vel, dt, irattle, cell, imass, max_sigma) END SUBROUTINE rattle_colv_int @@ -197,13 +190,12 @@ END SUBROUTINE rattle_colv_int !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE shake_roll_colv_int( molecule, particle_set, pos, vel, r_shake, v_shake, & - dt, ishake, cell, imass, max_sigma, error ) + dt, ishake, cell, imass, max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -215,7 +207,6 @@ SUBROUTINE shake_roll_colv_int( molecule, particle_set, pos, vel, r_shake, v_sha TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -231,7 +222,7 @@ SUBROUTINE shake_roll_colv_int( molecule, particle_set, pos, vel, r_shake, v_sha ! Real Shake CALL shake_roll_colv_low( fixd_list, colv_list, lcolv, & particle_set, pos, vel, r_shake, v_shake, dt, ishake, cell,& - imass, max_sigma, error ) + imass, max_sigma) END SUBROUTINE shake_roll_colv_int @@ -249,13 +240,12 @@ END SUBROUTINE shake_roll_colv_int !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE rattle_roll_colv_int ( molecule, particle_set, vel, r_rattle, & - dt, irattle, veps, cell, imass, max_sigma, error ) + dt, irattle, veps, cell, imass, max_sigma) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -266,7 +256,6 @@ SUBROUTINE rattle_roll_colv_int ( molecule, particle_set, vel, r_rattle, & TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -282,7 +271,7 @@ SUBROUTINE rattle_roll_colv_int ( molecule, particle_set, vel, r_rattle, & ! Real Rattle CALL rattle_roll_colv_low (fixd_list, colv_list, lcolv, & particle_set, vel, r_rattle, dt, irattle, veps, cell,& - imass, max_sigma, error ) + imass, max_sigma) END SUBROUTINE rattle_roll_colv_int @@ -299,13 +288,12 @@ END SUBROUTINE rattle_roll_colv_int !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE shake_colv_ext( gci, particle_set, pos, vel, dt, ishake,& - cell, imass, max_sigma, error ) + cell, imass, max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -315,7 +303,6 @@ SUBROUTINE shake_colv_ext( gci, particle_set, pos, vel, dt, ishake,& TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shake_colv_ext', & routineP = moduleN//':'//routineN @@ -331,8 +318,7 @@ SUBROUTINE shake_colv_ext( gci, particle_set, pos, vel, dt, ishake,& lcolv => gci%lcolv ! Real Shake CALL shake_colv_low( fixd_list, colv_list, lcolv, & - particle_set, pos, vel, dt, ishake, cell, imass, max_sigma,& - error ) + particle_set, pos, vel, dt, ishake, cell, imass, max_sigma) END SUBROUTINE shake_colv_ext @@ -342,15 +328,13 @@ END SUBROUTINE shake_colv_ext !> \param gci ... !> \param dt ... !> \param motion_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE shake_update_colv_ext( gci, dt, motion_section, error) + SUBROUTINE shake_update_colv_ext( gci, dt, motion_section) TYPE(global_constraint_type), POINTER :: gci REAL(kind=dp), INTENT(in) :: dt TYPE(section_vals_type), POINTER :: motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shake_update_colv_ext', & routineP = moduleN//':'//routineN @@ -359,7 +343,7 @@ SUBROUTINE shake_update_colv_ext( gci, dt, motion_section, error) colv_list => gci%colv_list ! Real update of the Shake target - CALL shake_update_colv_low( colv_list, dt, motion_section, error) + CALL shake_update_colv_low( colv_list, dt, motion_section) END SUBROUTINE shake_update_colv_ext @@ -375,13 +359,12 @@ END SUBROUTINE shake_update_colv_ext !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE rattle_colv_ext( gci, particle_set, vel, dt, irattle,& - cell, imass, max_sigma, error ) + cell, imass, max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -391,7 +374,6 @@ SUBROUTINE rattle_colv_ext( gci, particle_set, vel, dt, irattle,& TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -404,7 +386,7 @@ SUBROUTINE rattle_colv_ext( gci, particle_set, vel, dt, irattle,& lcolv => gci%lcolv ! Real Rattle CALL rattle_colv_low ( fixd_list, colv_list, lcolv, & - particle_set, vel, dt, irattle, cell, imass, max_sigma, error ) + particle_set, vel, dt, irattle, cell, imass, max_sigma) END SUBROUTINE rattle_colv_ext @@ -423,13 +405,12 @@ END SUBROUTINE rattle_colv_ext !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE shake_roll_colv_ext( gci, particle_set, pos, vel, r_shake, v_shake, & - dt, ishake, cell, imass, max_sigma, error ) + dt, ishake, cell, imass, max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -441,7 +422,6 @@ SUBROUTINE shake_roll_colv_ext( gci, particle_set, pos, vel, r_shake, v_shake, & TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -455,7 +435,7 @@ SUBROUTINE shake_roll_colv_ext( gci, particle_set, pos, vel, r_shake, v_shake, & ! Real Shake CALL shake_roll_colv_low( fixd_list, colv_list, lcolv, & particle_set, pos, vel, r_shake, v_shake, dt, ishake, cell,& - imass, max_sigma, error ) + imass, max_sigma) END SUBROUTINE shake_roll_colv_ext @@ -473,13 +453,12 @@ END SUBROUTINE shake_roll_colv_ext !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE rattle_roll_colv_ext ( gci, particle_set, vel, r_rattle, & - dt, irattle, veps, cell, imass, max_sigma, error ) + dt, irattle, veps, cell, imass, max_sigma) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -490,7 +469,6 @@ SUBROUTINE rattle_roll_colv_ext ( gci, particle_set, vel, r_rattle, & TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -504,7 +482,7 @@ SUBROUTINE rattle_roll_colv_ext ( gci, particle_set, vel, r_rattle, & ! Real Rattle CALL rattle_roll_colv_low (fixd_list, colv_list, lcolv, & particle_set, vel, r_rattle, dt, irattle, veps, cell,& - imass, max_sigma, error ) + imass, max_sigma) END SUBROUTINE rattle_roll_colv_ext @@ -523,14 +501,12 @@ END SUBROUTINE rattle_roll_colv_ext !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE shake_colv_low( fixd_list, colv_list, lcolv, & - particle_set, pos, vel, dt, ishake, cell, imass, max_sigma,& - error ) + particle_set, pos, vel, dt, ishake, cell, imass, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list TYPE(colvar_constraint_type), POINTER :: colv_list( : ) @@ -543,7 +519,6 @@ SUBROUTINE shake_colv_low( fixd_list, colv_list, lcolv, & TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shake_colv_low', & routineP = moduleN//':'//routineN @@ -562,40 +537,40 @@ SUBROUTINE shake_colv_low( fixd_list, colv_list, lcolv, & ! Update positions CALL update_con_colv(pos, dtsqby2, lcolv(iconst), & lambda=lcolv(iconst)%lambda,& - imass=imass, error=error) + imass=imass) ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=lcolv(iconst)%lambda,& - imass=imass, error=error) + imass=imass) END DO ELSE DO iconst = 1, SIZE(colv_list) IF (colv_list(iconst)%restraint%active) CYCLE ! Update colvar CALL colvar_eval_mol_f( lcolv ( iconst ) % colvar, cell, particles=particle_set,& - pos=pos, fixd_list=fixd_list, error=error) + pos=pos, fixd_list=fixd_list) lcolv ( iconst ) % sigma = diff_colvar(lcolv(iconst)%colvar,& colv_list(iconst)%expected_value) fdotf_sum = eval_Jac_colvar(lcolv ( iconst ) % colvar,& - lcolv ( iconst ) % colvar_old, imass=imass, error=error) + lcolv ( iconst ) % colvar_old, imass=imass) del_lam = 2.0_dp*lcolv ( iconst ) % sigma/(dt*dt*fdotf_sum) lcolv ( iconst ) % lambda = lcolv ( iconst ) % lambda + del_lam ! Update positions CALL update_con_colv(pos, dtsqby2, lcolv(iconst), & lambda=del_lam,& - imass=imass, error=error) + imass=imass) ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=del_lam,& - imass=imass, error=error) + imass=imass) END DO END IF ! computing the constraint and value of tolerance DO iconst = 1, SIZE(colv_list) IF (colv_list(iconst)%restraint%active) CYCLE CALL colvar_eval_mol_f( lcolv ( iconst ) % colvar, cell, particles=particle_set,& - pos=pos, fixd_list=fixd_list, error=error) + pos=pos, fixd_list=fixd_list) lcolv ( iconst ) % sigma = diff_colvar(lcolv ( iconst ) % colvar,& colv_list ( iconst ) % expected_value) max_sigma = MAX(ABS(lcolv ( iconst ) % sigma),max_sigma) @@ -607,15 +582,13 @@ END SUBROUTINE shake_colv_low !> \param colv_list ... !> \param dt ... !> \param motion_section ... -!> \param error ... !> \date 02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE shake_update_colv_low(colv_list, dt, motion_section, error ) + SUBROUTINE shake_update_colv_low(colv_list, dt, motion_section) TYPE(colvar_constraint_type), POINTER :: colv_list( : ) REAL(kind=dp), INTENT(in) :: dt TYPE(section_vals_type), POINTER :: motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shake_update_colv_low', & routineP = moduleN//':'//routineN @@ -629,23 +602,23 @@ SUBROUTINE shake_update_colv_low(colv_list, dt, motion_section, error ) failure = .FALSE. ! Update globally for restart - collective_sections => section_vals_get_subs_vals(motion_section,"CONSTRAINT%COLLECTIVE",error=error) - CALL section_vals_get(collective_sections, n_repetition=n_rep, error=error) + collective_sections => section_vals_get_subs_vals(motion_section,"CONSTRAINT%COLLECTIVE") + CALL section_vals_get(collective_sections, n_repetition=n_rep) IF (n_rep/=0) THEN DO irep = 1, n_rep CALL section_vals_val_get(collective_sections, "TARGET_GROWTH", r_val=value,& - i_rep_section=irep, error=error) + i_rep_section=irep) IF ( value /= 0.0_dp ) THEN CALL section_vals_val_get(collective_sections, "TARGET", r_val=clv_target,& - i_rep_section=irep, error=error) + i_rep_section=irep) new_clv_target = clv_target + value * dt ! Check limits.. CALL section_vals_val_get(collective_sections, "TARGET_LIMIT", explicit=explicit,& - i_rep_section=irep, error=error) + i_rep_section=irep) do_update_colvar = .TRUE. IF (explicit) THEN CALL section_vals_val_get(collective_sections, "TARGET_LIMIT", r_val=limit,& - i_rep_section=irep, error=error) + i_rep_section=irep) IF (value>0.0_dp) THEN IF (clv_target==limit) THEN do_update_colvar = .FALSE. @@ -662,7 +635,7 @@ SUBROUTINE shake_update_colv_low(colv_list, dt, motion_section, error ) END IF IF (do_update_colvar) THEN CALL section_vals_val_set(collective_sections, "TARGET", r_val=new_clv_target,& - i_rep_section=irep, error=error) + i_rep_section=irep) END IF END IF END DO @@ -674,7 +647,7 @@ SUBROUTINE shake_update_colv_low(colv_list, dt, motion_section, error ) IF (colv_list(iconst)%expected_value_growth_speed == 0.0_dp) CYCLE CALL section_vals_val_get(collective_sections, "TARGET", & r_val=colv_list(iconst)%expected_value,& - i_rep_section=colv_list(iconst)%inp_seq_num, error=error) + i_rep_section=colv_list(iconst)%inp_seq_num) END DO END SUBROUTINE shake_update_colv_low @@ -693,13 +666,12 @@ END SUBROUTINE shake_update_colv_low !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE rattle_colv_low ( fixd_list, colv_list, lcolv, & - particle_set, vel, dt, irattle, cell, imass, max_sigma, error ) + particle_set, vel, dt, irattle, cell, imass, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -713,7 +685,6 @@ SUBROUTINE rattle_colv_low ( fixd_list, colv_list, lcolv, & TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst REAL(KIND=dp) :: del_lam, dtby2, fdotf_sum @@ -724,31 +695,31 @@ SUBROUTINE rattle_colv_low ( fixd_list, colv_list, lcolv, & IF (colv_list(iconst)%restraint%active) CYCLE ! Update colvar_old CALL colvar_eval_mol_f(lcolv ( iconst ) % colvar_old, cell,& - particles=particle_set, fixd_list=fixd_list, error=error) + particles=particle_set, fixd_list=fixd_list) ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=lcolv(iconst)%lambda,& - imass=imass,error=error) + imass=imass) END DO ELSE DO iconst = 1, SIZE(colv_list) IF (colv_list(iconst)%restraint%active) CYCLE - lcolv ( iconst ) % sigma = rattle_con_eval(lcolv ( iconst ) % colvar_old, vel,error=error) + lcolv ( iconst ) % sigma = rattle_con_eval(lcolv ( iconst ) % colvar_old, vel) fdotf_sum = eval_Jac_colvar(lcolv ( iconst ) % colvar_old,& - lcolv ( iconst ) % colvar_old, imass=imass,error=error) + lcolv ( iconst ) % colvar_old, imass=imass) del_lam = 2.0_dp*lcolv ( iconst ) % sigma/(dt*fdotf_sum) lcolv ( iconst ) % lambda = lcolv ( iconst ) % lambda + del_lam ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=del_lam,& - imass=imass,error=error) + imass=imass) END DO END IF DO iconst = 1, SIZE(colv_list) IF (colv_list(iconst)%restraint%active) CYCLE - lcolv ( iconst ) % sigma = rattle_con_eval(lcolv ( iconst ) % colvar_old, vel,error=error) + lcolv ( iconst ) % sigma = rattle_con_eval(lcolv ( iconst ) % colvar_old, vel) max_sigma = MAX(ABS(lcolv ( iconst ) % sigma),max_sigma) END DO @@ -771,14 +742,13 @@ END SUBROUTINE rattle_colv_low !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE shake_roll_colv_low( fixd_list, colv_list, lcolv, & particle_set, pos, vel, r_shake, v_shake, dt, ishake, cell,& - imass, max_sigma, error ) + imass, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -794,7 +764,6 @@ SUBROUTINE shake_roll_colv_low( fixd_list, colv_list, lcolv, & TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst REAL(KIND=dp) :: del_lam, dtby2, dtsqby2, & @@ -808,41 +777,41 @@ SUBROUTINE shake_roll_colv_low( fixd_list, colv_list, lcolv, & ! Update positions CALL update_con_colv(pos, dtsqby2, lcolv(iconst), & lambda=lcolv(iconst)%lambda,& - roll=.TRUE.,rmat=r_shake,imass=imass,error=error) + roll=.TRUE.,rmat=r_shake,imass=imass) ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=lcolv(iconst)%lambda,& - roll=.TRUE.,rmat=v_shake,imass=imass,error=error) + roll=.TRUE.,rmat=v_shake,imass=imass) END DO ELSE DO iconst = 1, SIZE(colv_list) IF (colv_list(iconst)%restraint%active) CYCLE ! Update colvar CALL colvar_eval_mol_f( lcolv ( iconst ) % colvar, cell, particles=particle_set,& - pos=pos, fixd_list=fixd_list, error=error) + pos=pos, fixd_list=fixd_list) lcolv ( iconst ) % sigma = diff_colvar(lcolv ( iconst ) % colvar,& colv_list ( iconst ) % expected_value) fdotf_sum = eval_Jac_colvar(lcolv ( iconst ) % colvar,& lcolv ( iconst ) % colvar_old, roll=.TRUE., rmat=r_shake,& - imass=imass, error=error) + imass=imass) del_lam = 2.0_dp*lcolv ( iconst ) % sigma/(dt*dt*fdotf_sum) lcolv ( iconst ) % lambda = lcolv ( iconst ) % lambda + del_lam ! Update positions CALL update_con_colv(pos, dtsqby2, lcolv(iconst), & lambda=del_lam,& - roll=.TRUE., rmat=r_shake, imass=imass,error=error) + roll=.TRUE., rmat=r_shake, imass=imass) ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=del_lam,& - roll=.TRUE., rmat=v_shake, imass=imass,error=error) + roll=.TRUE., rmat=v_shake, imass=imass) END DO END IF ! computing the constraint and value of tolerance DO iconst = 1, SIZE(colv_list) IF (colv_list(iconst)%restraint%active) CYCLE CALL colvar_eval_mol_f( lcolv ( iconst ) % colvar, cell, particles=particle_set,& - pos=pos, fixd_list=fixd_list, error=error) + pos=pos, fixd_list=fixd_list) lcolv ( iconst ) % sigma = diff_colvar(lcolv ( iconst ) % colvar,& colv_list ( iconst ) % expected_value) max_sigma = MAX(ABS(lcolv ( iconst ) % sigma),max_sigma) @@ -866,14 +835,13 @@ END SUBROUTINE shake_roll_colv_low !> \param cell ... !> \param imass ... !> \param max_sigma ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE rattle_roll_colv_low (fixd_list, colv_list, lcolv, & particle_set, vel, r_rattle, dt, irattle, veps, cell,& - imass, max_sigma, error ) + imass, max_sigma) TYPE(fixd_constraint_type), & DIMENSION(:), POINTER :: fixd_list @@ -888,7 +856,6 @@ SUBROUTINE rattle_roll_colv_low (fixd_list, colv_list, lcolv, & TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:) :: imass REAL(KIND=dp), INTENT(INOUT) :: max_sigma - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst REAL(KIND=dp) :: del_lam, dtby2, fdotf_sum @@ -899,35 +866,33 @@ SUBROUTINE rattle_roll_colv_low (fixd_list, colv_list, lcolv, & IF (colv_list(iconst)%restraint%active) CYCLE ! Update colvar_old CALL colvar_eval_mol_f(lcolv ( iconst ) % colvar_old, cell,& - particles=particle_set, fixd_list=fixd_list, error=error) + particles=particle_set, fixd_list=fixd_list) ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=lcolv(iconst)%lambda,& - imass=imass,error=error) + imass=imass) END DO ELSE DO iconst = 1, SIZE ( colv_list ) IF (colv_list(iconst)%restraint%active) CYCLE lcolv ( iconst ) % sigma = rattle_con_eval(lcolv ( iconst ) % colvar_old, vel,& - roll=.TRUE., veps=veps, rmat=r_rattle, particles=particle_set,& - error=error) + roll=.TRUE., veps=veps, rmat=r_rattle, particles=particle_set) fdotf_sum = eval_Jac_colvar(lcolv ( iconst ) % colvar_old,& lcolv ( iconst ) % colvar_old, roll=.TRUE.,& - rmat=r_rattle,imass=imass, error=error) + rmat=r_rattle,imass=imass) del_lam = 2.0_dp*lcolv ( iconst ) % sigma/(dt*fdotf_sum) lcolv ( iconst ) % lambda = lcolv ( iconst ) % lambda + del_lam ! Update velocities CALL update_con_colv(vel, dtby2, lcolv(iconst), & lambda=del_lam,& - roll=.TRUE.,rmat=r_rattle,imass=imass,error=error) + roll=.TRUE.,rmat=r_rattle,imass=imass) END DO END IF ! computing the constraint and value of the tolerance DO iconst = 1, SIZE(colv_list) IF (colv_list(iconst)%restraint%active) CYCLE lcolv ( iconst ) % sigma = rattle_con_eval(lcolv ( iconst ) % colvar_old, vel,& - roll=.TRUE., veps=veps, rmat=r_rattle, particles=particle_set,& - error=error) + roll=.TRUE., veps=veps, rmat=r_rattle, particles=particle_set) max_sigma = MAX(ABS(lcolv ( iconst ) % sigma),max_sigma) END DO @@ -942,12 +907,11 @@ END SUBROUTINE rattle_roll_colv_low !> \param roll ... !> \param rmat ... !> \param imass ... -!> \param error ... !> \par History !> Teodoro Laino [teo] created 04.2006 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE update_con_colv(wrk, fac, lcolv, lambda, roll, rmat, imass, error) + SUBROUTINE update_con_colv(wrk, fac, lcolv, lambda, roll, rmat, imass) REAL(KIND=dp), INTENT(INOUT) :: wrk( :, : ) REAL(KIND=dp), INTENT(IN) :: fac TYPE(local_colvar_constraint_type), & @@ -957,7 +921,6 @@ SUBROUTINE update_con_colv(wrk, fac, lcolv, lambda, roll, rmat, imass, error) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN), OPTIONAL :: rmat REAL(KIND=dp), DIMENSION(:) :: imass - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_con_colv', & routineP = moduleN//':'//routineN @@ -971,7 +934,7 @@ SUBROUTINE update_con_colv(wrk, fac, lcolv, lambda, roll, rmat, imass, error) IF (PRESENT(roll)) THEN my_roll = roll IF (my_roll) THEN - CPPostcondition(PRESENT(rmat),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(rmat),cp_failure_level,routineP,failure) END IF END IF DO iatm = 1, SIZE( lcolv % colvar_old % i_atom ) @@ -994,19 +957,17 @@ END SUBROUTINE update_con_colv !> \param roll ... !> \param rmat ... !> \param imass ... -!> \param error ... !> \retval res ... !> \par History !> Teodoro Laino [teo] created 04.2006 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - FUNCTION eval_Jac_colvar(colvar, colvar_old, roll, rmat, imass, error) RESULT(res) + FUNCTION eval_Jac_colvar(colvar, colvar_old, roll, rmat, imass) RESULT(res) TYPE(colvar_type), POINTER :: colvar, colvar_old LOGICAL, INTENT(IN), OPTIONAL :: roll REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN), OPTIONAL :: rmat REAL(KIND=dp), DIMENSION(:) :: imass - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'eval_Jac_colvar', & @@ -1021,7 +982,7 @@ FUNCTION eval_Jac_colvar(colvar, colvar_old, roll, rmat, imass, error) RESULT(re IF (PRESENT(roll)) THEN my_roll = roll IF (my_roll) THEN - CPPostcondition(PRESENT(rmat),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(rmat),cp_failure_level,routineP,failure) END IF END IF @@ -1048,13 +1009,12 @@ END FUNCTION eval_Jac_colvar !> \param veps ... !> \param rmat ... !> \param particles ... -!> \param error ... !> \retval res ... !> \par History !> Teodoro Laino [teo] created 04.2006 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - FUNCTION rattle_con_eval(colvar, vel, roll, veps, rmat, particles, error) RESULT(res) + FUNCTION rattle_con_eval(colvar, vel, roll, veps, rmat, particles) RESULT(res) TYPE(colvar_type), POINTER :: colvar REAL(KIND=dp), INTENT(INOUT) :: vel( :, : ) LOGICAL, INTENT(IN), OPTIONAL :: roll @@ -1062,7 +1022,6 @@ FUNCTION rattle_con_eval(colvar, vel, roll, veps, rmat, particles, error) RESULT INTENT(IN), OPTIONAL :: veps, rmat TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'rattle_con_eval', & @@ -1078,9 +1037,9 @@ FUNCTION rattle_con_eval(colvar, vel, roll, veps, rmat, particles, error) RESULT IF (PRESENT(roll)) THEN my_roll = roll IF (my_roll) THEN - CPPostcondition(PRESENT(rmat),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(veps),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(particles),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(rmat),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(veps),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(particles),cp_failure_level,routineP,failure) END IF END IF res = 0.0_dp diff --git a/src/constraint_fxd.F b/src/constraint_fxd.F index 541cb0f2fc..74a336de58 100644 --- a/src/constraint_fxd.F +++ b/src/constraint_fxd.F @@ -57,15 +57,13 @@ MODULE constraint_fxd ! ***************************************************************************** !> \brief allows for fix atom constraints !> \param force_env ... -!> \param error ... !> \param w ... !> \par History !> - optionally apply fix atom constraint to random forces (Langevin) !> (04.10.206,MK) ! ***************************************************************************** - SUBROUTINE fix_atom_control( force_env, error, w) + SUBROUTINE fix_atom_control( force_env,w) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), DIMENSION(:, :), OPTIONAL :: w CHARACTER(len=*), PARAMETER :: routineN = 'fix_atom_control', & @@ -107,8 +105,7 @@ SUBROUTINE fix_atom_control( force_env, error, w) NULLIFY(lfixd_list) CALL force_env_get(force_env=force_env,& - subsys=subsys,& - error=error) + subsys=subsys) CALL cp_subsys_get(subsys=subsys,& atomic_kinds=atomic_kinds,& core_particles=core_particles,& @@ -118,18 +115,17 @@ SUBROUTINE fix_atom_control( force_env, error, w) ncore=ncore,& nshell=nshell,& particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) CALL get_atomic_kind_set(atomic_kind_set=atomic_kinds%els,& shell_present=shell_present) particle_set => particles%els - CPPostcondition((SIZE(particle_set) == natom),cp_failure_level,routineP,error,failure) + CPPostcondition((SIZE(particle_set) == natom),cp_failure_level,routineP,failure) IF (shell_present) THEN core_particle_set => core_particles%els - CPPostcondition((SIZE(core_particle_set) == ncore),cp_failure_level,routineP,error,failure) + CPPostcondition((SIZE(core_particle_set) == ncore),cp_failure_level,routineP,failure) shell_particle_set => shell_particles%els - CPPostcondition((SIZE(shell_particle_set) == nshell),cp_failure_level,routineP,error,failure) + CPPostcondition((SIZE(shell_particle_set) == nshell),cp_failure_level,routineP,failure) END IF nparticle = natom + nshell molecule_kind_set => molecule_kinds%els @@ -146,7 +142,7 @@ SUBROUTINE fix_atom_control( force_env, error, w) IF (.NOT.PRESENT(w)) THEN ! Allocate scratch array ALLOCATE (force(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) force(:,:) = 0.0_dp DO i=1,SIZE(local_particles%n_el) nparticle_local = local_particles%n_el(i) @@ -164,7 +160,7 @@ SUBROUTINE fix_atom_control( force_env, error, w) END IF ! Create the list of locally fixed atoms - CALL create_local_fixd_list(lfixd_list,nkind,molecule_kind_set,local_particles,error) + CALL create_local_fixd_list(lfixd_list,nkind,molecule_kind_set,local_particles) ! Apply fixed atom constraint DO ifixd=1,SIZE(lfixd_list) @@ -243,7 +239,7 @@ SUBROUTINE fix_atom_control( force_env, error, w) END IF END IF END DO - CALL release_local_fixd_list(lfixd_list,error=error) + CALL release_local_fixd_list(lfixd_list) IF (.NOT.PRESENT(w)) THEN CALL mp_sum(force,force_env%para_env%group) @@ -257,7 +253,7 @@ SUBROUTINE fix_atom_control( force_env, error, w) END IF END DO DEALLOCATE (force,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -437,17 +433,15 @@ END SUBROUTINE check_fixed_atom_cns_colv !> \param nkind ... !> \param molecule_kind_set ... !> \param local_particles ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 11.2008 ! ***************************************************************************** SUBROUTINE create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, & - local_particles, error) + local_particles) TYPE(local_fixd_constraint_type), & POINTER :: lfixd_list(:) INTEGER, INTENT(IN) :: nkind TYPE(molecule_kind_type), POINTER :: molecule_kind_set(:) TYPE(distribution_1d_type), POINTER :: local_particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_local_fixd_list', & routineP = moduleN//':'//routineN @@ -465,7 +459,7 @@ SUBROUTINE create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, & CALL timeset(routineN,handle) failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(lfixd_list),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(lfixd_list),cp_failure_level,routineP,failure) nsize = 0 DO ikind = 1, nkind molecule_kind => molecule_kind_set(ikind) @@ -476,13 +470,13 @@ SUBROUTINE create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, & END DO IF (nsize/=0) THEN ALLOCATE(fixed_atom_all(nsize), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work0(nsize), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work1(nsize), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kind_index_all(nsize), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nsize = 0 DO ikind = 1, nkind molecule_kind => molecule_kind_set(ikind) @@ -505,9 +499,9 @@ SUBROUTINE create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, & nparticle_local_all = nparticle_local_all + local_particles%n_el(i) END DO ALLOCATE(local_particle_all(nparticle_local_all),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work2(nparticle_local_all),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nparticle_local_all = 0 DO i = 1, SIZE(local_particles%n_el) nparticle_local = local_particles%n_el(i) @@ -535,7 +529,7 @@ SUBROUTINE create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, & ! Allocate local fixed atom array ALLOCATE(lfixd_list(ncnst),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Fill array with constraints infos ncnst = 0 @@ -557,19 +551,19 @@ SUBROUTINE create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, & ! Deallocate working arrays DEALLOCATE(local_particle_all,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(fixed_atom_all, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work1, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kind_index_all, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ! Allocate local fixed atom array with dimension 0 ALLOCATE(lfixd_list(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE create_local_fixd_list @@ -578,12 +572,10 @@ END SUBROUTINE create_local_fixd_list !> \brief destroy the list of local atoms on which to apply constraints/restraints !> Teodoro Laino [tlaino] - 11.2008 !> \param lfixd_list ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_local_fixd_list(lfixd_list, error) + SUBROUTINE release_local_fixd_list(lfixd_list) TYPE(local_fixd_constraint_type), & POINTER :: lfixd_list(:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'release_local_fixd_list', & routineP = moduleN//':'//routineN @@ -592,9 +584,9 @@ SUBROUTINE release_local_fixd_list(lfixd_list, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(lfixd_list),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(lfixd_list),cp_failure_level,routineP,failure) DEALLOCATE(lfixd_list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_local_fixd_list END MODULE constraint_fxd diff --git a/src/constraint_util.F b/src/constraint_util.F index c3603a598b..5bc1e589e6 100644 --- a/src/constraint_util.F +++ b/src/constraint_util.F @@ -58,12 +58,11 @@ MODULE constraint_util !> \param molecule_kind_set ... !> \param particle_set ... !> \param cell ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE getold( gci, local_molecules, molecule_set, molecule_kind_set,& - particle_set , cell, error) + particle_set , cell) TYPE(global_constraint_type), POINTER :: gci TYPE(distribution_1d_type), POINTER :: local_molecules @@ -71,7 +70,6 @@ SUBROUTINE getold( gci, local_molecules, molecule_set, molecule_kind_set,& TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) TYPE(particle_type), POINTER :: particle_set( : ) TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'getold', & routineP = moduleN//':'//routineN @@ -111,7 +109,7 @@ SUBROUTINE getold( gci, local_molecules, molecule_set, molecule_kind_set,& CALL get_molecule ( molecule, first_atom=first_atom, & lcolv=lcolv, lg3x3=lg3x3, lg4x6=lg4x6 ) CALL getold_low(n3x3con, n4x6con, colv_list, g3x3_list, g4x6_list, fixd_list,& - lcolv, lg3x3, lg4x6, first_atom, particle_set, cell, error) + lcolv, lg3x3, lg4x6, first_atom, particle_set, cell) END DO END DO MOL ! Intermolecular constraints @@ -126,7 +124,7 @@ SUBROUTINE getold( gci, local_molecules, molecule_set, molecule_kind_set,& lg3x3=> gci%lg3x3 lg4x6=> gci%lg4x6 CALL getold_low(n3x3con, n4x6con, colv_list, g3x3_list, g4x6_list, fixd_list,& - lcolv, lg3x3, lg4x6, 1, particle_set, cell, error) + lcolv, lg3x3, lg4x6, 1, particle_set, cell) END IF END SUBROUTINE getold @@ -144,12 +142,11 @@ END SUBROUTINE getold !> \param first_atom ... !> \param particle_set ... !> \param cell ... -!> \param error ... !> \par History !> none ! ***************************************************************************** SUBROUTINE getold_low(n3x3con, n4x6con, colv_list, g3x3_list, g4x6_list, fixd_list,& - lcolv, lg3x3, lg4x6, first_atom, particle_set, cell, error) + lcolv, lg3x3, lg4x6, first_atom, particle_set, cell) INTEGER, INTENT(IN) :: n3x3con, n4x6con TYPE(colvar_constraint_type), POINTER :: colv_list( : ) @@ -166,7 +163,6 @@ SUBROUTINE getold_low(n3x3con, n4x6con, colv_list, g3x3_list, g4x6_list, fixd_li INTEGER, INTENT(IN) :: first_atom TYPE(particle_type), POINTER :: particle_set( : ) TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'getold_low', & routineP = moduleN//':'//routineN @@ -177,7 +173,7 @@ SUBROUTINE getold_low(n3x3con, n4x6con, colv_list, g3x3_list, g4x6_list, fixd_li ! Collective constraints DO iconst = 1, SIZE(colv_list) CALL colvar_eval_mol_f(lcolv ( iconst )%colvar_old, cell,& - particles=particle_set, fixd_list=fixd_list, error=error) + particles=particle_set, fixd_list=fixd_list) ENDDO END IF ! 3x3 constraints diff --git a/src/constraint_vsite.F b/src/constraint_vsite.F index dd7151aaea..50d67b922a 100644 --- a/src/constraint_vsite.F +++ b/src/constraint_vsite.F @@ -42,15 +42,13 @@ MODULE constraint_vsite ! ***************************************************************************** !> \brief control force distribution for virtual sites !> \param force_env ... -!> \param error ... !> \date 12.2008 !> \par History !> - none !> \author Marcel Baer ! ***************************************************************************** - SUBROUTINE vsite_force_control( force_env, error) + SUBROUTINE vsite_force_control( force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, ikind, imol, nconstraint, & nkind, nmol_per_kind, & @@ -75,12 +73,11 @@ SUBROUTINE vsite_force_control( force_env, error) NULLIFY(gci, subsys, local_molecules, local_particles,& molecule_kinds) - CALL force_env_get(force_env=force_env, subsys=subsys,error=error) + CALL force_env_get(force_env=force_env, subsys=subsys) CALL cp_subsys_get(subsys=subsys,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,& - molecule_kinds_new=molecule_kinds,gci=gci,molecules_new=molecules,& - error=error) + molecule_kinds_new=molecule_kinds,gci=gci,molecules_new=molecules) molecule_kind_set => molecule_kinds%els molecule_set => molecules%els @@ -116,14 +113,12 @@ END SUBROUTINE vsite_force_control !> \brief Intramolecular virtual site !> \param molecule ... !> \param pos ... -!> \param error ... !> \par History !> 12.2008 Marcel Baer ! ***************************************************************************** - SUBROUTINE shake_vsite_int( molecule, pos, error) + SUBROUTINE shake_vsite_int( molecule, pos) TYPE(molecule_type), POINTER :: molecule REAL(KIND=dp), INTENT(INOUT) :: pos( :, : ) - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, nvsite TYPE(molecule_kind_type), POINTER :: molecule_kind @@ -133,7 +128,7 @@ SUBROUTINE shake_vsite_int( molecule, pos, error) CALL get_molecule_kind ( molecule_kind, nvsite = nvsite, vsite_list = vsite_list ) CALL get_molecule ( molecule, first_atom = first_atom) ! Real Shake - CALL shake_vsite_low( vsite_list, nvsite, first_atom, pos, error) + CALL shake_vsite_low( vsite_list, nvsite, first_atom, pos) END SUBROUTINE shake_vsite_int @@ -141,15 +136,13 @@ END SUBROUTINE shake_vsite_int !> \brief Intramolecular virtual site !> \param gci ... !> \param pos ... -!> \param error ... !> \par History !> 12.2008 Marcel Baer ! ***************************************************************************** - SUBROUTINE shake_vsite_ext( gci, pos, error) + SUBROUTINE shake_vsite_ext( gci, pos) TYPE(global_constraint_type), POINTER :: gci REAL(KIND=dp), INTENT(INOUT) :: pos( :, : ) - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: first_atom, nvsite TYPE(vsite_constraint_type), POINTER :: vsite_list( : ) @@ -158,7 +151,7 @@ SUBROUTINE shake_vsite_ext( gci, pos, error) nvsite = gci%nvsite vsite_list => gci%vsite_list ! Real Shake - CALL shake_vsite_low( vsite_list, nvsite, first_atom, pos, error) + CALL shake_vsite_low( vsite_list, nvsite, first_atom, pos) END SUBROUTINE shake_vsite_ext @@ -168,15 +161,13 @@ END SUBROUTINE shake_vsite_ext !> \param nvsite ... !> \param first_atom ... !> \param pos ... -!> \param error ... !> \par History !> 12.2008 Marcel Bear ! ***************************************************************************** - SUBROUTINE shake_vsite_low(vsite_list, nvsite, first_atom, pos, error) + SUBROUTINE shake_vsite_low(vsite_list, nvsite, first_atom, pos) TYPE(vsite_constraint_type) :: vsite_list( : ) INTEGER, INTENT(IN) :: nvsite, first_atom REAL(KIND=dp), INTENT(INOUT) :: pos( :, : ) - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iconst, index_a, index_b, & index_c, index_d diff --git a/src/core_ae.F b/src/core_ae.F index 7b60e769f5..31228b91ff 100644 --- a/src/core_ae.F +++ b/src/core_ae.F @@ -72,10 +72,9 @@ MODULE core_ae !> \param sac_ae ... !> \param nimages ... !> \param cell_to_index ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, use_virial, nder,& - qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ae, nimages, cell_to_index, error) + qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ae, nimages, cell_to_index) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: matrix_h, matrix_p @@ -95,7 +94,6 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us DIMENSION(:), POINTER :: sab_orb, sac_ae INTEGER, INTENT(IN) :: nimages INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_core_ae', & routineP = moduleN//':'//routineN @@ -145,16 +143,16 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us dokp = (nimages > 1) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) IF (calculate_forces) THEN IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimages CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-2.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-2.0_dp, beta_scalar=1.0_dp) END DO END IF END IF @@ -162,28 +160,28 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us maxder = ncoset(nder) CALL get_qs_kind_set(qs_kind_set,& - maxco=maxco,maxlgto=maxl,maxsgf=maxsgf,maxnset=maxnset,error=error) + maxco=maxco,maxlgto=maxl,maxsgf=maxsgf,maxnset=maxnset) CALL init_orbital_pointers(maxl+nder+1) ldsab = MAX(maxco,maxsgf) ldai = ncoset(maxl+nder+1) ALLOCATE(hab(ldsab,ldsab,maxnset*maxnset),work(ldsab,ldsab),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (verf(ldai,ldai,2*maxl+nder+1),vnuc(ldai,ldai,2*maxl+nder+1),ff(0:2*maxl+nder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN ALLOCATE(pab(maxco,maxco,maxnset*maxnset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! iterator for basis/potential list CALL neighbor_list_iterator_create(ap_iterator,sac_ae,search=.TRUE.) ALLOCATE (basis_set_list(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -253,7 +251,7 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us NULLIFY(p_block) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1,img)%matrix,& row=irow,col=icol,BLOCK=p_block,found=found) - CPPostcondition(ASSOCIATED(p_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_block),cp_failure_level,routineP,failure) ! *** Decontract density matrix block *** DO iset=1,nseta ncoa = npgfa(iset)*ncoset(la_max(iset)) @@ -284,7 +282,7 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us ! loop over all kinds for pseudopotential atoms hab = 0._dp DO kkind=1,nkind - CALL get_qs_kind(qs_kind_set(kkind),all_potential=all_potential,error=error) + CALL get_qs_kind(qs_kind_set(kkind),all_potential=all_potential) IF (.NOT.ASSOCIATED(all_potential)) CYCLE CALL get_potential(potential=all_potential,& alpha_core_charge=alpha_c,zeff=zeta_c,& @@ -319,7 +317,7 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us na_plus = npgfa(iset)*ncoset(la_max(iset)+nder) nb_plus = npgfb(jset)*ncoset(lb_max(jset)) ALLOCATE(habd(na_plus,nb_plus),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) habd = 0._dp CALL verfc(& la_max(iset)+nder,npgfa(iset),zeta(:,iset),rpgfa(:,iset),la_min(iset),& @@ -333,10 +331,10 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us ! *** of the first derivatives *** CALL verfc_force(habd,pab(:,:,nij),force_a,force_b,nder,& la_max(iset),la_min(iset),npgfa(iset),zeta(:,iset),& - lb_max(jset),lb_min(jset),npgfb(jset),zetb(:,jset),rab,error) + lb_max(jset),lb_min(jset),npgfb(jset),zetb(:,jset),rab) DEALLOCATE(habd,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) atom_c = atom_of_kind(katom) force(ikind)%all_potential(1,atom_a) =force(ikind)%all_potential(1,atom_a) + f0*force_a(1) @@ -355,8 +353,8 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us - f0*force_a(3) - f0*force_b(3) IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, f0, force_a, rac, error) - CALL virial_pair_force ( virial%pv_virial, f0, force_b, rbc, error) + CALL virial_pair_force ( virial%pv_virial, f0, force_a, rac) + CALL virial_pair_force ( virial%pv_virial, f0, force_b, rbc) END IF ELSE CALL verfc(& @@ -401,13 +399,13 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us CALL neighbor_list_iterator_release(ap_iterator) DEALLOCATE (atom_of_kind,basis_set_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(hab,work,verf,vnuc,ff,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE(pab,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (calculate_forces) THEN ! *** If LSD, then recover alpha density and beta density *** @@ -415,9 +413,9 @@ SUBROUTINE build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, us IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimages CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 0.5_dp, beta_scalar=0.5_dp,error=error) + alpha_scalar= 0.5_dp, beta_scalar=0.5_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-1.0_dp, beta_scalar=1.0_dp) END DO END IF END IF @@ -443,9 +441,8 @@ END SUBROUTINE build_core_ae !> \param npgfb ... !> \param zetb ... !> \param rab ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE verfc_force(habd,pab,fa,fb,nder,la_max,la_min,npgfa,zeta,lb_max,lb_min,npgfb,zetb,rab,error) + SUBROUTINE verfc_force(habd,pab,fa,fb,nder,la_max,la_min,npgfa,zeta,lb_max,lb_min,npgfb,zetb,rab) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: habd, pab @@ -455,7 +452,6 @@ SUBROUTINE verfc_force(habd,pab,fa,fb,nder,la_max,la_min,npgfa,zeta,lb_max,lb_mi INTEGER, INTENT(IN) :: lb_max, lb_min, npgfb REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'verfc_force', & routineP = moduleN//':'//routineN diff --git a/src/core_ppl.F b/src/core_ppl.F index 154e3813eb..a79b9fe190 100644 --- a/src/core_ppl.F +++ b/src/core_ppl.F @@ -77,10 +77,9 @@ MODULE core_ppl !> \param sac_ppl ... !> \param nimages ... !> \param cell_to_index ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, use_virial, nder,& - qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ppl, nimages, cell_to_index, error) + qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ppl, nimages, cell_to_index) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: matrix_h, matrix_p @@ -100,7 +99,6 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u DIMENSION(:), POINTER :: sab_orb, sac_ppl INTEGER, INTENT(IN) :: nimages INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_core_ppl', & routineP = moduleN//':'//routineN @@ -157,16 +155,16 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u dokp = (nimages > 1) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) IF (calculate_forces) THEN IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimages CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-2.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-2.0_dp, beta_scalar=1.0_dp) END DO END IF END IF @@ -174,7 +172,7 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u maxder = ncoset(nder) CALL get_qs_kind_set(qs_kind_set, maxco=maxco,maxlgto=maxlgto,& - maxsgf=maxsgf,maxnset=maxnset, maxlppl=maxlppl,error=error) + maxsgf=maxsgf,maxnset=maxnset, maxlppl=maxlppl) maxl = MAX(maxlgto,maxlppl) CALL init_orbital_pointers(2*maxl+2*nder+1) @@ -183,9 +181,9 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u ldai = ncoset(maxl+nder+1) ALLOCATE (basis_set_list(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -215,7 +213,7 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u !$OMP nct_lpot, cval_ppl, cval_lpot, ap_iterator, rac, dac, rbc, dbc, & !$OMP set_radius_a, rpgfa, force_a, force_b, ppl_fwork, mepos, & !$OMP f0, failure, katom, ppl_work, atom_c, cellind, img, & -!$OMP error, stat, ldai) +!$OMP stat, ldai) mepos=0 !$ mepos=omp_get_thread_num() @@ -224,16 +222,16 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u CALL neighbor_list_iterator_create(ap_iterator,sac_ppl,search=.TRUE.) ALLOCATE(hab(ldsab,ldsab,maxnset,maxnset),work(ldsab,ldsab*maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ldai = ncoset(2*maxlgto+2*nder) ALLOCATE (ppl_work(ldai,ldai,MAX(maxder,2*maxlgto+2*nder+1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN ALLOCATE(pab(maxco,maxco,maxnset,maxnset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ldai = ncoset(maxlgto) ALLOCATE (ppl_fwork(ldai,ldai,maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DO WHILE (neighbor_list_iterate(nl_iterator, mepos=mepos)==0) @@ -337,7 +335,7 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u ! loop over all kinds for pseudopotential atoms DO kkind=1,nkind - CALL get_qs_kind(qs_kind_set(kkind),gth_potential=gth_potential,error=error) + CALL get_qs_kind(qs_kind_set(kkind),gth_potential=gth_potential) IF (.NOT.ASSOCIATED(gth_potential)) CYCLE CALL get_potential(potential=gth_potential,& alpha_ppl=alpha,cexp_ppl=cexp_ppl,& @@ -349,7 +347,7 @@ SUBROUTINE build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, u IF (lpotextended) THEN CALL get_potential(potential=gth_potential,& nexp_lpot=nexp_lpot,alpha_lpot=alpha_lpot,nct_lpot=nct_lpot,cval_lpot=cval_lpot) - CPPrecondition(nexp_lpot \param eps_ppnl ... !> \param nimages ... !> \param cell_to_index ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, use_virial, nder,& qs_kind_set, atomic_kind_set, particle_set, sab_orb, sap_ppnl, eps_ppnl, & - nimages, cell_to_index, error) + nimages, cell_to_index) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: matrix_h, matrix_p @@ -104,7 +103,6 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, REAL(KIND=dp), INTENT(IN) :: eps_ppnl INTEGER, INTENT(IN) :: nimages INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_core_ppnl', & routineP = moduleN//':'//routineN @@ -164,16 +162,16 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, dokp = (nimages > 1) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,atom_of_kind=atom_of_kind) IF (calculate_forces) THEN IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimages CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-2.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-2.0_dp, beta_scalar=1.0_dp) END DO END IF END IF @@ -185,7 +183,7 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, maxlgto=maxlgto,& maxsgf=maxsgf,& maxlppnl=maxlppnl,& - maxppnl=maxppnl,error=error) + maxppnl=maxppnl) maxl = MAX(maxlgto,maxlppnl) CALL init_orbital_pointers(maxl+nder+1) @@ -195,7 +193,7 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, !sap_int needs to be shared as multiple threads need to access this ALLOCATE(sap_int(nkind*nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nkind*nkind NULLIFY(sap_int(i)%alist,sap_int(i)%asort,sap_int(i)%aindex) sap_int(i)%nalist=0 @@ -203,15 +201,15 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, !set up direct access to basis and potential ALLOCATE(basis_set(nkind),potential(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set) IF (ASSOCIATED(orb_basis_set)) THEN basis_set(ikind)%gto_basis_set => orb_basis_set ELSE NULLIFY(basis_set(ikind)%gto_basis_set) END IF - CALL get_qs_kind(qs_kind_set(ikind),gth_potential=gth_potential,error=error) + CALL get_qs_kind(qs_kind_set(ikind),gth_potential=gth_potential) IF (ASSOCIATED(gth_potential)) THEN potential(ikind)%gth_potential => gth_potential ELSE @@ -233,15 +231,15 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, !$OMP sphi_a, zeta, cprj, lppnl, nppnl, nprj_ppnl, & !$OMP clist, iset, ncoa, sgfa, prjc, work, sab, ai_work, nprjc, ppnl_radius, & !$OMP ncoc, rpgfa, first_col, vprj_ppnl, failure, i, l, & -!$OMP set_radius_a, rprjc, dac, lc_max, lc_min, zetc, alpha_ppnl, error, stat) +!$OMP set_radius_a, rprjc, dac, lc_max, lc_min, zetc, alpha_ppnl,stat) mepos=0 !$ mepos=omp_get_thread_num() ALLOCATE(sab(ldsab,ldsab*maxder),work(ldsab,ldsab*maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sab=0.0_dp ALLOCATE (ai_work(ldai,ldai,ncoset(nder+1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ai_work=0.0_dp DO WHILE (neighbor_list_iterate(nl_iterator, mepos=mepos)==0) @@ -276,7 +274,7 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, sap_int(iac)%p_kind = kkind sap_int(iac)%nalist = nlist ALLOCATE(sap_int(iac)%alist(nlist),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nlist NULLIFY(sap_int(iac)%alist(i)%clist) sap_int(iac)%alist(i)%aatom = 0 @@ -287,7 +285,7 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, sap_int(iac)%alist(ilist)%aatom = iatom sap_int(iac)%alist(ilist)%nclist = nneighbor ALLOCATE(sap_int(iac)%alist(ilist)%clist(nneighbor),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nneighbor sap_int(iac)%alist(ilist)%clist(i)%catom = 0 END DO @@ -300,7 +298,7 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, clist%rac = rac ALLOCATE(clist%acint(nsgfa,nppnl,maxder),& clist%achint(nsgfa,nppnl,maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) clist%acint=0._dp clist%achint=0._dp clist%nsgf_cnt = 0 @@ -347,12 +345,12 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, END DO DEALLOCATE(sab,ai_work,work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP END PARALLEL CALL neighbor_list_iterator_release(nl_iterator) ! *** Set up a sorting index - CALL sap_sort(sap_int,error) + CALL sap_sort(sap_int) ! *** All integrals needed have been calculated and stored in sap_int ! *** We now calculate the Hamiltonian matrix elements CALL neighbor_list_iterator_create(nl_iterator,sab_orb,nthread=nthread) @@ -363,7 +361,7 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, !$OMP matrix_p, sap_int, nkind, eps_ppnl, force, virial, use_virial, calculate_forces) & !$OMP PRIVATE (mepos, ikind, jkind, iatom, jatom, nlist, ilist, nnode, inode, cell_b, rab, & !$OMP iab, atom_a, atom_b, f0, irow, icol, h_block, & -!$OMP found, error, p_block, iac, ibc, alist_ac, alist_bc, acint, bcint, & +!$OMP found,p_block, iac, ibc, alist_ac, alist_bc, acint, bcint, & !$OMP achint, bchint, na, np, nb, katom, atom_c, j, fa, fb, rbc, rac, & !$OMP kkind, kac, kbc, i, img) @@ -414,8 +412,8 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, ibc= jkind + nkind*(kkind - 1) IF (.NOT.ASSOCIATED(sap_int(iac)%alist)) CYCLE IF (.NOT.ASSOCIATED(sap_int(ibc)%alist)) CYCLE - CALL get_alist(sap_int(iac), alist_ac, iatom, error) - CALL get_alist(sap_int(ibc), alist_bc, jatom, error) + CALL get_alist(sap_int(iac), alist_ac, iatom) + CALL get_alist(sap_int(ibc), alist_bc, jatom) IF (.NOT.ASSOCIATED(alist_ac)) CYCLE IF (.NOT.ASSOCIATED(alist_bc)) CYCLE DO kac=1,alist_ac%nclist @@ -468,8 +466,8 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, rac = alist_ac%clist(kac)%rac rbc = alist_bc%clist(kbc)%rac !$OMP CRITICAL(virial_critical) - CALL virial_pair_force ( virial%pv_virial, f0, fa, rac, error) - CALL virial_pair_force ( virial%pv_virial, f0, fb, rbc, error) + CALL virial_pair_force ( virial%pv_virial, f0, fa, rac) + CALL virial_pair_force ( virial%pv_virial, f0, fb, rbc) !$OMP END CRITICAL(virial_critical) END IF ENDIF @@ -484,12 +482,12 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, !$OMP END PARALLEL CALL neighbor_list_iterator_release(nl_iterator) - CALL release_sap_int(sap_int, error) + CALL release_sap_int(sap_int) DEALLOCATE (atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_set,potential,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN ! *** If LSD, then recover alpha density and beta density *** @@ -497,9 +495,9 @@ SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimages CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 0.5_dp, beta_scalar=0.5_dp,error=error) + alpha_scalar= 0.5_dp, beta_scalar=0.5_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-1.0_dp, beta_scalar=1.0_dp) END DO END IF END IF diff --git a/src/cp2k_debug.F b/src/cp2k_debug.F index 1f8a4afa94..ee4d84cc40 100644 --- a/src/cp2k_debug.F +++ b/src/cp2k_debug.F @@ -69,12 +69,10 @@ MODULE cp2k_debug ! ***************************************************************************** !> \brief ... !> \param force_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) + SUBROUTINE cp2k_debug_energy_and_forces(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp2k_debug_energy_and_forces', & routineP = moduleN//':'//routineN @@ -109,31 +107,31 @@ SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) root_section => force_env%root_section - CALL force_env_get(force_env,para_env=para_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(force_env,para_env=para_env,subsys=subsys,cell=cell) subsys_section => section_vals_get_subs_vals(force_env%force_env_section, & - "SUBSYS",error=error) + "SUBSYS") CALL section_vals_val_get(root_section,"DEBUG%DEBUG_STRESS_TENSOR",& - l_val=debug_stress_tensor,error=error) + l_val=debug_stress_tensor) CALL section_vals_val_get(root_section,"DEBUG%DEBUG_FORCES",& - l_val=debug_forces,error=error) + l_val=debug_forces) CALL section_vals_val_get(root_section,"DEBUG%DX",& - r_val=dx,error=error) + r_val=dx) dx = ABS(dx) CALL section_vals_val_get(root_section,"DEBUG%EPS_NO_ERROR_CHECK",& - r_val=eps_no_error_check,error=error) + r_val=eps_no_error_check) eps_no_error_check = MAX(eps_no_error_check,EPSILON(0.0_dp)) CALL section_vals_val_get(root_section,"DEBUG%STOP_ON_MISMATCH",& - l_val=stop_on_mismatch,error=error) + l_val=stop_on_mismatch) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,root_section,"DEBUG%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") IF (debug_stress_tensor) THEN ! To debug stress tensor the stress tensor calculation must be ! first enabled.. CALL section_vals_val_get(force_env%force_env_section,"STRESS_TENSOR",& - i_val=stress_tensor,error=error) + i_val=stress_tensor) skip = .FALSE. SELECT CASE (stress_tensor) CASE (do_stress_analytical, do_stress_diagonal_anal) @@ -154,25 +152,24 @@ SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) IF (.NOT.skip) THEN ! Compute the analytical stress tensor - CALL cp_subsys_get(subsys,virial=virial,error=error) + CALL cp_subsys_get(subsys,virial=virial) CALL virial_set(virial,pv_numer=.FALSE.) CALL force_env_calc_energy_force(force_env,& calc_force=.TRUE.,& - calc_stress_tensor=.TRUE.,& - error=error) + calc_stress_tensor=.TRUE.) ! Retrieve the analytical virial - CALL virial_create(virial_analytical,error=error) + CALL virial_create(virial_analytical) CALL zero_virial(virial_analytical) CALL cp_virial(virial,virial_analytical) ! Debug stress tensor (numerical vs analytical) CALL virial_set(virial,pv_numer=.TRUE.) - CALL force_env_calc_num_pressure(force_env,dx=dx,error=error) + CALL force_env_calc_num_pressure(force_env,dx=dx) ! Retrieve the numerical virial - CALL cp_subsys_get(subsys,virial=virial,error=error) - CALL virial_create(virial_numerical,error=error) + CALL cp_subsys_get(subsys,virial=virial) + CALL virial_create(virial_numerical) CALL zero_virial(virial_numerical) CALL cp_virial(virial,virial_numerical) @@ -207,8 +204,8 @@ SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) END DO IF (ANY(ABS(err(1:3)) > maxerr)) check_failed = .TRUE. END DO - CALL virial_release(virial_analytical,error=error) - CALL virial_release(virial_numerical,error=error) + CALL virial_release(virial_analytical) + CALL virial_release(virial_numerical) IF (check_failed) THEN message = "A mismatch between the analytical and the numerical "//& "stress tensor has been detected. Check the implementation "//& @@ -227,28 +224,27 @@ SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) particles => subsys%particles%els SELECT CASE (force_env%in_use) CASE (use_qs_force) - CALL get_qs_env(force_env%qs_env,qs_kind_set=qs_kind_set,error=error) - CALL write_qs_particle_coordinates(particles,qs_kind_set,subsys_section,"DEBUG",error) + CALL get_qs_env(force_env%qs_env,qs_kind_set=qs_kind_set) + CALL write_qs_particle_coordinates(particles,qs_kind_set,subsys_section,"DEBUG") CASE DEFAULT - CALL write_fist_particle_coordinates(particles,subsys_section,charges=Null(),error=error) + CALL write_fist_particle_coordinates(particles,subsys_section,charges=Null()) END SELECT ! First evaluate energy and forces CALL force_env_calc_energy_force(force_env,& calc_force=.TRUE.,& - calc_stress_tensor=.FALSE.,& - error=error) + calc_stress_tensor=.FALSE.) ! Copy forces in array and start the numerical calculation IF (ASSOCIATED(analyt_forces)) DEALLOCATE(analyt_forces) np = subsys%particles%n_els ALLOCATE (analyt_forces(np,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ip=1,np analyt_forces(ip,1:3) = particles(ip)%f(1:3) END DO ! Loop on atoms and coordinates IF (ASSOCIATED(numer_forces)) DEALLOCATE (numer_forces) ALLOCATE (numer_forces(subsys%particles%n_els,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Atom: DO ip=1,np Coord: DO k=1,3 numer_energy = 0.0_dp @@ -257,18 +253,17 @@ SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) particles(ip)%r(k) = std_value - (-1.0_dp)**j*dx SELECT CASE (force_env%in_use) CASE (use_qs_force) - CALL get_qs_env(force_env%qs_env,qs_kind_set=qs_kind_set,error=error) - CALL write_qs_particle_coordinates(particles,qs_kind_set,subsys_section,"DEBUG",error) + CALL get_qs_env(force_env%qs_env,qs_kind_set=qs_kind_set) + CALL write_qs_particle_coordinates(particles,qs_kind_set,subsys_section,"DEBUG") CASE DEFAULT - CALL write_fist_particle_coordinates(particles,subsys_section,charges=Null(),error=error) + CALL write_fist_particle_coordinates(particles,subsys_section,charges=Null()) END SELECT ! Compute energy CALL force_env_calc_energy_force(force_env,& calc_force=.FALSE.,& calc_stress_tensor=.FALSE.,& - consistent_energies=.TRUE.,& - error=error) - CALL force_env_get(force_env,potential_energy=numer_energy(j),error=error) + consistent_energies=.TRUE.) + CALL force_env_get(force_env,potential_energy=numer_energy(j)) END DO particles(ip)%r(k) = std_value numer_forces(ip,k) = -0.5_dp*(numer_energy(1) - numer_energy(2))/dx @@ -285,7 +280,7 @@ SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) my_maxerr = maxerr err(1:3) = 0.0_dp DO k=1,3 - ! Calculate percentage error, but ignore very small force values + ! Calculate percentage but ignore very small force values IF (ABS(analyt_forces(ip,k)) >= eps_no_error_check) THEN err(k) = 100.0_dp*(numer_forces(ip,k) - analyt_forces(ip,k))/analyt_forces(ip,k) END IF @@ -340,7 +335,7 @@ SUBROUTINE cp2k_debug_energy_and_forces(force_env, error) IF (ASSOCIATED(numer_forces)) DEALLOCATE(numer_forces) END IF CALL cp_print_key_finished_output(iw,logger,root_section,& - "DEBUG%PROGRAM_RUN_INFO",error=error) + "DEBUG%PROGRAM_RUN_INFO") END SUBROUTINE cp2k_debug_energy_and_forces diff --git a/src/cp_control_types.F b/src/cp_control_types.F index 7ad9682e4a..0d07d6334c 100644 --- a/src/cp_control_types.F +++ b/src/cp_control_types.F @@ -459,13 +459,11 @@ MODULE cp_control_types ! ***************************************************************************** !> \brief create the mulliken_restraint_type !> \param mulliken_restraint_control ... -!> \param error ... !> \par History !> 02.2005 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE mulliken_control_create(mulliken_restraint_control,error) + SUBROUTINE mulliken_control_create(mulliken_restraint_control) TYPE(mulliken_restraint_type), POINTER :: mulliken_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_control_create', & routineP = moduleN//':'//routineN @@ -475,9 +473,9 @@ SUBROUTINE mulliken_control_create(mulliken_restraint_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(mulliken_restraint_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(mulliken_restraint_control),cp_failure_level,routineP,failure) ALLOCATE(mulliken_restraint_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mulliken_restraint_control%ref_count=1 mulliken_restraint_control%strength=0.1_dp @@ -489,13 +487,11 @@ END SUBROUTINE mulliken_control_create ! ***************************************************************************** !> \brief release the mulliken_restraint_type !> \param mulliken_restraint_control ... -!> \param error ... !> \par History !> 02.2005 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE mulliken_control_release(mulliken_restraint_control,error) + SUBROUTINE mulliken_control_release(mulliken_restraint_control) TYPE(mulliken_restraint_type), POINTER :: mulliken_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_control_release', & routineP = moduleN//':'//routineN @@ -503,8 +499,8 @@ SUBROUTINE mulliken_control_release(mulliken_restraint_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(mulliken_restraint_control),cp_failure_level,routineP,error,failure) - CPPrecondition(mulliken_restraint_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mulliken_restraint_control),cp_failure_level,routineP,failure) + CPPrecondition(mulliken_restraint_control%ref_count>0,cp_failure_level,routineP,failure) mulliken_restraint_control%ref_count=mulliken_restraint_control%ref_count-1 IF (mulliken_restraint_control%ref_count==0) THEN IF (ASSOCIATED(mulliken_restraint_control%atoms)) & @@ -520,13 +516,11 @@ END SUBROUTINE mulliken_control_release ! ***************************************************************************** !> \brief retain the mulliken_restraint_type !> \param mulliken_restraint_control ... -!> \param error ... !> \par History !> 02.2005 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE mulliken_control_retain(mulliken_restraint_control,error) + SUBROUTINE mulliken_control_retain(mulliken_restraint_control) TYPE(mulliken_restraint_type), POINTER :: mulliken_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_control_retain', & routineP = moduleN//':'//routineN @@ -534,7 +528,7 @@ SUBROUTINE mulliken_control_retain(mulliken_restraint_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(mulliken_restraint_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mulliken_restraint_control),cp_failure_level,routineP,failure) mulliken_restraint_control%ref_count=mulliken_restraint_control%ref_count+1 END SUBROUTINE mulliken_control_retain @@ -542,13 +536,11 @@ END SUBROUTINE mulliken_control_retain ! ***************************************************************************** !> \brief create the ddapc_restraint_type !> \param ddapc_restraint_control ... -!> \param error ... !> \par History !> 02.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE ddapc_control_create(ddapc_restraint_control,error) + SUBROUTINE ddapc_control_create(ddapc_restraint_control) TYPE(ddapc_restraint_type), POINTER :: ddapc_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ddapc_control_create', & routineP = moduleN//':'//routineN @@ -558,9 +550,9 @@ SUBROUTINE ddapc_control_create(ddapc_restraint_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(ddapc_restraint_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(ddapc_restraint_control),cp_failure_level,routineP,failure) ALLOCATE(ddapc_restraint_control,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ddapc_restraint_control%density_type=do_full_density ddapc_restraint_control%ref_count=1 @@ -577,13 +569,11 @@ END SUBROUTINE ddapc_control_create ! ***************************************************************************** !> \brief release the ddapc_restraint_type !> \param ddapc_restraint_control ... -!> \param error ... !> \par History !> 02.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE ddapc_control_release(ddapc_restraint_control,error) + SUBROUTINE ddapc_control_release(ddapc_restraint_control) TYPE(ddapc_restraint_type), POINTER :: ddapc_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ddapc_control_release', & routineP = moduleN//':'//routineN @@ -591,8 +581,8 @@ SUBROUTINE ddapc_control_release(ddapc_restraint_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(ddapc_restraint_control),cp_failure_level,routineP,error,failure) - CPPrecondition(ddapc_restraint_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ddapc_restraint_control),cp_failure_level,routineP,failure) + CPPrecondition(ddapc_restraint_control%ref_count>0,cp_failure_level,routineP,failure) ddapc_restraint_control%ref_count=ddapc_restraint_control%ref_count-1 IF (ddapc_restraint_control%ref_count==0) THEN IF (ASSOCIATED(ddapc_restraint_control%atoms)) & @@ -610,13 +600,11 @@ END SUBROUTINE ddapc_control_release ! ***************************************************************************** !> \brief retain the ddapc_restraint_type !> \param ddapc_restraint_control ... -!> \param error ... !> \par History !> 02.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE ddapc_control_retain(ddapc_restraint_control,error) + SUBROUTINE ddapc_control_retain(ddapc_restraint_control) TYPE(ddapc_restraint_type), POINTER :: ddapc_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ddapc_control_retain', & routineP = moduleN//':'//routineN @@ -624,7 +612,7 @@ SUBROUTINE ddapc_control_retain(ddapc_restraint_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(ddapc_restraint_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ddapc_restraint_control),cp_failure_level,routineP,failure) ddapc_restraint_control%ref_count=ddapc_restraint_control%ref_count+1 END SUBROUTINE ddapc_control_retain @@ -632,13 +620,11 @@ END SUBROUTINE ddapc_control_retain ! ***************************************************************************** !> \brief create the becke_restraint_type !> \param becke_control ... -!> \param error ... !> \par History !> 02.2007 created [Florian Schiffmann] ! ***************************************************************************** - SUBROUTINE becke_control_create(becke_control,error) + SUBROUTINE becke_control_create(becke_control) TYPE(becke_restraint_type), POINTER :: becke_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'becke_control_create', & routineP = moduleN//':'//routineN @@ -648,9 +634,9 @@ SUBROUTINE becke_control_create(becke_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(becke_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(becke_control),cp_failure_level,routineP,failure) ALLOCATE(becke_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) becke_control%ref_count=1 @@ -668,13 +654,11 @@ END SUBROUTINE becke_control_create ! ***************************************************************************** !> \brief release the becke_restraint_type !> \param becke_control ... -!> \param error ... !> \par History !> 02.2007 created [Florian Schiffmann] ! ***************************************************************************** - SUBROUTINE becke_control_release(becke_control,error) + SUBROUTINE becke_control_release(becke_control) TYPE(becke_restraint_type), POINTER :: becke_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'becke_control_release', & routineP = moduleN//':'//routineN @@ -682,8 +666,8 @@ SUBROUTINE becke_control_release(becke_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(becke_control),cp_failure_level,routineP,error,failure) - CPPrecondition(becke_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(becke_control),cp_failure_level,routineP,failure) + CPPrecondition(becke_control%ref_count>0,cp_failure_level,routineP,failure) becke_control%ref_count=becke_control%ref_count-1 IF (becke_control%ref_count==0) THEN IF (ASSOCIATED(becke_control%atoms)) & @@ -701,13 +685,11 @@ END SUBROUTINE becke_control_release ! ***************************************************************************** !> \brief retain the becke_restraint_type !> \param becke_control ... -!> \param error ... !> \par History !> 02.2007 created [Florian Schiffmann] ! ***************************************************************************** - SUBROUTINE becke_control_retain(becke_control,error) + SUBROUTINE becke_control_retain(becke_control) TYPE(becke_restraint_type), POINTER :: becke_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'becke_control_retain', & routineP = moduleN//':'//routineN @@ -715,20 +697,18 @@ SUBROUTINE becke_control_retain(becke_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(becke_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(becke_control),cp_failure_level,routineP,failure) becke_control%ref_count=becke_control%ref_count+1 END SUBROUTINE becke_control_retain ! ***************************************************************************** !> \brief create the s2_restraint_type !> \param s2_restraint_control ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE s2_control_create(s2_restraint_control,error) + SUBROUTINE s2_control_create(s2_restraint_control) TYPE(s2_restraint_type), POINTER :: s2_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 's2_control_create', & routineP = moduleN//':'//routineN @@ -738,9 +718,9 @@ SUBROUTINE s2_control_create(s2_restraint_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(s2_restraint_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(s2_restraint_control),cp_failure_level,routineP,failure) ALLOCATE(s2_restraint_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) s2_restraint_control%ref_count=1 s2_restraint_control%strength=0.1_dp @@ -752,13 +732,11 @@ END SUBROUTINE s2_control_create ! ***************************************************************************** !> \brief release the s2_restraint_type !> \param s2_restraint_control ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE s2_control_release(s2_restraint_control,error) + SUBROUTINE s2_control_release(s2_restraint_control) TYPE(s2_restraint_type), POINTER :: s2_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 's2_control_release', & routineP = moduleN//':'//routineN @@ -766,8 +744,8 @@ SUBROUTINE s2_control_release(s2_restraint_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(s2_restraint_control),cp_failure_level,routineP,error,failure) - CPPrecondition(s2_restraint_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(s2_restraint_control),cp_failure_level,routineP,failure) + CPPrecondition(s2_restraint_control%ref_count>0,cp_failure_level,routineP,failure) s2_restraint_control%ref_count=s2_restraint_control%ref_count-1 IF (s2_restraint_control%ref_count==0) THEN s2_restraint_control%ref_count=0 @@ -780,13 +758,11 @@ END SUBROUTINE s2_control_release ! ***************************************************************************** !> \brief retain the s2_restraint_type !> \param s2_restraint_control ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE s2_control_retain(s2_restraint_control,error) + SUBROUTINE s2_control_retain(s2_restraint_control) TYPE(s2_restraint_type), POINTER :: s2_restraint_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 's2_control_retain', & routineP = moduleN//':'//routineN @@ -794,22 +770,19 @@ SUBROUTINE s2_control_retain(s2_restraint_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(s2_restraint_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(s2_restraint_control),cp_failure_level,routineP,failure) s2_restraint_control%ref_count=s2_restraint_control%ref_count+1 END SUBROUTINE s2_control_retain ! ***************************************************************************** !> \brief allocates and perform a very basic initialization !> \param dft_control the object to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE dft_control_create(dft_control, error) + SUBROUTINE dft_control_create(dft_control) TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dft_control_create', & routineP = moduleN//':'//routineN @@ -819,9 +792,9 @@ SUBROUTINE dft_control_create(dft_control, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(dft_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(dft_control),cp_failure_level,routineP,failure) ALLOCATE (dft_control,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dft_control%ref_count=1 last_dft_control_id=last_dft_control_id+1 dft_control%id_nr=last_dft_control_id @@ -834,20 +807,18 @@ SUBROUTINE dft_control_create(dft_control, error) NULLIFY (dft_control%rtp_control) NULLIFY (dft_control%sccs_control) dft_control%do_sccs = .FALSE. - CALL qs_control_create(dft_control%qs_control,error=error) + CALL qs_control_create(dft_control%qs_control) END SUBROUTINE dft_control_create ! ***************************************************************************** !> \brief ... !> \param dft_control ... -!> \param error ... !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE dft_control_retain(dft_control,error) + SUBROUTINE dft_control_retain(dft_control) TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dft_control_retain', & routineP = moduleN//':'//routineN @@ -855,22 +826,20 @@ SUBROUTINE dft_control_retain(dft_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(dft_control%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,failure) + CPPreconditionNoFail(dft_control%ref_count>0,cp_failure_level,routineP) dft_control%ref_count=dft_control%ref_count+1 END SUBROUTINE dft_control_retain ! ***************************************************************************** !> \brief ... !> \param dft_control ... -!> \param error ... !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE dft_control_release(dft_control,error) + SUBROUTINE dft_control_release(dft_control) TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dft_control_release', & routineP = moduleN//':'//routineN @@ -881,27 +850,27 @@ SUBROUTINE dft_control_release(dft_control,error) failure = .FALSE. IF (ASSOCIATED(dft_control)) THEN - CPPreconditionNoFail(dft_control%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(dft_control%ref_count>0,cp_failure_level,routineP) dft_control%ref_count=dft_control%ref_count-1 IF (dft_control%ref_count==0) THEN - CALL qs_control_release(dft_control%qs_control, error=error) - CALL tddfpt_control_release(dft_control%tddfpt_control, error=error) - CALL xas_control_release(dft_control%xas_control, error=error) - CALL admm_control_release(dft_control%admm_control, error=error) - CALL efield_fields_release(dft_control%efield_fields, error=error) - CALL sccs_control_release(dft_control%sccs_control,error=error) + CALL qs_control_release(dft_control%qs_control) + CALL tddfpt_control_release(dft_control%tddfpt_control) + CALL xas_control_release(dft_control%xas_control) + CALL admm_control_release(dft_control%admm_control) + CALL efield_fields_release(dft_control%efield_fields) + CALL sccs_control_release(dft_control%sccs_control) IF (ASSOCIATED(dft_control%period_efield))THEN DEALLOCATE(dft_control%period_efield%polarisation,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(dft_control%period_efield,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(dft_control%rtp_control)) THEN DEALLOCATE(dft_control%rtp_control,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(dft_control, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF @@ -910,11 +879,9 @@ END SUBROUTINE dft_control_release ! ***************************************************************************** !> \brief ... !> \param gapw_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE gapw_control_create(gapw_control, error) + SUBROUTINE gapw_control_create(gapw_control) TYPE(gapw_control_type), POINTER :: gapw_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gapw_control_create', & routineP = moduleN//':'//routineN @@ -923,19 +890,17 @@ SUBROUTINE gapw_control_create(gapw_control, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(gapw_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(gapw_control),cp_failure_level,routineP,failure) ALLOCATE (gapw_control,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE gapw_control_create ! ***************************************************************************** !> \brief ... !> \param qs_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_control_create(qs_control, error) + SUBROUTINE qs_control_create(qs_control) TYPE(qs_control_type), POINTER :: qs_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_control_create', & routineP = moduleN//':'//routineN @@ -944,9 +909,9 @@ SUBROUTINE qs_control_create(qs_control, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(qs_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(qs_control),cp_failure_level,routineP,failure) ALLOCATE (qs_control,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(qs_control%e_cutoff) NULLIFY(qs_control%gapw_control) @@ -959,23 +924,21 @@ SUBROUTINE qs_control_create(qs_control, error) NULLIFY(qs_control%becke_control) NULLIFY(qs_control%ddapc_restraint_control) - CALL mulliken_control_create(qs_control%mulliken_restraint_control,error=error) - CALL becke_control_create(qs_control%becke_control,error=error) - CALL s2_control_create(qs_control%s2_restraint_control,error=error) - CALL gapw_control_create(qs_control%gapw_control, error=error) - CALL se_control_create(qs_control%se_control,error=error) - CALL dftb_control_create(qs_control%dftb_control,error=error) - CALL scptb_control_create(qs_control%scptb_control,error=error) + CALL mulliken_control_create(qs_control%mulliken_restraint_control) + CALL becke_control_create(qs_control%becke_control) + CALL s2_control_create(qs_control%s2_restraint_control) + CALL gapw_control_create(qs_control%gapw_control) + CALL se_control_create(qs_control%se_control) + CALL dftb_control_create(qs_control%dftb_control) + CALL scptb_control_create(qs_control%scptb_control) END SUBROUTINE qs_control_create ! ***************************************************************************** !> \brief ... !> \param qs_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_control_release(qs_control, error) + SUBROUTINE qs_control_release(qs_control) TYPE(qs_control_type), POINTER :: qs_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_control_release', & routineP = moduleN//':'//routineN @@ -985,41 +948,38 @@ SUBROUTINE qs_control_release(qs_control, error) failure = .FALSE. IF (ASSOCIATED(qs_control)) THEN - CALL mulliken_control_release(qs_control%mulliken_restraint_control,error=error) - CALL s2_control_release(qs_control%s2_restraint_control,error=error) - CALL se_control_release(qs_control%se_control,error=error) - CALL dftb_control_release(qs_control%dftb_control,error=error) - CALL scptb_control_release(qs_control%scptb_control,error=error) - CALL becke_control_release(qs_control%becke_control,error=error) + CALL mulliken_control_release(qs_control%mulliken_restraint_control) + CALL s2_control_release(qs_control%s2_restraint_control) + CALL se_control_release(qs_control%se_control) + CALL dftb_control_release(qs_control%dftb_control) + CALL scptb_control_release(qs_control%scptb_control) + CALL becke_control_release(qs_control%becke_control) IF (ASSOCIATED(qs_control%e_cutoff)) THEN DEALLOCATE(qs_control%e_cutoff,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_control%gapw_control))THEN DEALLOCATE(qs_control%gapw_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(qs_control%ddapc_restraint_control))THEN DO i = 1 , SIZE(qs_control%ddapc_restraint_control) - CALL ddapc_control_release(qs_control%ddapc_restraint_control(i)%ddapc_restraint_control,& - error=error) + CALL ddapc_control_release(qs_control%ddapc_restraint_control(i)%ddapc_restraint_control) END DO DEALLOCATE(qs_control%ddapc_restraint_control) END IF DEALLOCATE(qs_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE qs_control_release ! ***************************************************************************** !> \brief ... !> \param tddfpt_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_control_create(tddfpt_control, error) + SUBROUTINE tddfpt_control_create(tddfpt_control) TYPE(tddfpt_control_type), POINTER :: tddfpt_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tddfpt_control_create', & routineP = moduleN//':'//routineN @@ -1028,9 +988,9 @@ SUBROUTINE tddfpt_control_create(tddfpt_control, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(tddfpt_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(tddfpt_control),cp_failure_level,routineP,failure) ALLOCATE (tddfpt_control,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(tddfpt_control%lumos) NULLIFY(tddfpt_control%lumos_eigenvalues) @@ -1039,11 +999,9 @@ END SUBROUTINE tddfpt_control_create ! ***************************************************************************** !> \brief ... !> \param tddfpt_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_control_release(tddfpt_control, error) + SUBROUTINE tddfpt_control_release(tddfpt_control) TYPE(tddfpt_control_type), POINTER :: tddfpt_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tddfpt_control_release', & routineP = moduleN//':'//routineN @@ -1055,7 +1013,7 @@ SUBROUTINE tddfpt_control_release(tddfpt_control, error) IF (ASSOCIATED(tddfpt_control)) THEN IF (ASSOCIATED(tddfpt_control%lumos)) THEN DO ispin=1, SIZE(tddfpt_control%lumos) - CALL cp_fm_release(tddfpt_control%lumos(ispin)%matrix,error=error) + CALL cp_fm_release(tddfpt_control%lumos(ispin)%matrix) !MK the following line just avoids a crash of TDDFT runs using !MK the sdbg version compiled with the NAG compiler when !MK tddfpt_control%lumos is deallocated. This is most likely a @@ -1063,14 +1021,14 @@ SUBROUTINE tddfpt_control_release(tddfpt_control, error) dummy = ASSOCIATED(tddfpt_control%lumos(ispin)%matrix) END DO DEALLOCATE(tddfpt_control%lumos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(tddfpt_control%lumos_eigenvalues)) THEN DEALLOCATE(tddfpt_control%lumos_eigenvalues,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(tddfpt_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE tddfpt_control_release @@ -1078,12 +1036,10 @@ END SUBROUTINE tddfpt_control_release ! ***************************************************************************** !> \brief ... !> \param efield_fields ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE efield_fields_release(efield_fields, error) + SUBROUTINE efield_fields_release(efield_fields) TYPE(efield_p_type), DIMENSION(:), & POINTER :: efield_fields - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'efield_fields_release', & routineP = moduleN//':'//routineN @@ -1097,33 +1053,31 @@ SUBROUTINE efield_fields_release(efield_fields, error) IF(ASSOCIATED(efield_fields(i)%efield))THEN IF(ASSOCIATED(efield_fields(i)%efield%envelop_r_vars))THEN DEALLOCATE(efield_fields(i)%efield%envelop_r_vars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(efield_fields(i)%efield%envelop_i_vars))THEN DEALLOCATE(efield_fields(i)%efield%envelop_i_vars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(efield_fields(i)%efield%polarisation))THEN DEALLOCATE(efield_fields(i)%efield%polarisation,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(efield_fields(i)%efield,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(efield_fields,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE efield_fields_release ! ***************************************************************************** !> \brief ... !> \param dftb_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dftb_control_create(dftb_control,error) + SUBROUTINE dftb_control_create(dftb_control) TYPE(dftb_control_type), POINTER :: dftb_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dftb_control_create', & routineP = moduleN//':'//routineN @@ -1133,9 +1087,9 @@ SUBROUTINE dftb_control_create(dftb_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(dftb_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(dftb_control),cp_failure_level,routineP,failure) ALLOCATE(dftb_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(dftb_control%sk_pair_list) END SUBROUTINE dftb_control_create @@ -1143,11 +1097,9 @@ END SUBROUTINE dftb_control_create ! ***************************************************************************** !> \brief ... !> \param dftb_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dftb_control_release(dftb_control,error) + SUBROUTINE dftb_control_release(dftb_control) TYPE(dftb_control_type), POINTER :: dftb_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dftb_control_release', & routineP = moduleN//':'//routineN @@ -1160,21 +1112,19 @@ SUBROUTINE dftb_control_release(dftb_control,error) IF (ASSOCIATED(dftb_control)) THEN IF (ASSOCIATED(dftb_control%sk_pair_list)) THEN DEALLOCATE(dftb_control%sk_pair_list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(dftb_control,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE dftb_control_release ! ***************************************************************************** !> \brief ... !> \param scptb_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_control_create(scptb_control,error) + SUBROUTINE scptb_control_create(scptb_control) TYPE(scptb_control_type), POINTER :: scptb_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scptb_control_create', & routineP = moduleN//':'//routineN @@ -1184,20 +1134,18 @@ SUBROUTINE scptb_control_create(scptb_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(scptb_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(scptb_control),cp_failure_level,routineP,failure) ALLOCATE(scptb_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE scptb_control_create ! ***************************************************************************** !> \brief ... !> \param scptb_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_control_release(scptb_control,error) + SUBROUTINE scptb_control_release(scptb_control) TYPE(scptb_control_type), POINTER :: scptb_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scptb_control_release', & routineP = moduleN//':'//routineN @@ -1209,19 +1157,17 @@ SUBROUTINE scptb_control_release(scptb_control,error) IF (ASSOCIATED(scptb_control)) THEN DEALLOCATE(scptb_control,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE scptb_control_release ! ***************************************************************************** !> \brief ... !> \param se_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE se_control_create(se_control,error) + SUBROUTINE se_control_create(se_control) TYPE(semi_empirical_control_type), & POINTER :: se_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_control_create', & routineP = moduleN//':'//routineN @@ -1231,20 +1177,18 @@ SUBROUTINE se_control_create(se_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(se_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(se_control),cp_failure_level,routineP,failure) ALLOCATE(se_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE se_control_create ! ***************************************************************************** !> \brief ... !> \param se_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE se_control_release(se_control,error) + SUBROUTINE se_control_release(se_control) TYPE(semi_empirical_control_type), & POINTER :: se_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_control_release', & routineP = moduleN//':'//routineN @@ -1256,18 +1200,16 @@ SUBROUTINE se_control_release(se_control,error) IF (ASSOCIATED(se_control)) THEN DEALLOCATE(se_control,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE se_control_release ! ***************************************************************************** !> \brief ... !> \param admm_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE admm_control_create(admm_control,error) + SUBROUTINE admm_control_create(admm_control) TYPE(admm_control_type), POINTER :: admm_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'admm_control_create', & routineP = moduleN//':'//routineN @@ -1277,20 +1219,18 @@ SUBROUTINE admm_control_create(admm_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(admm_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(admm_control),cp_failure_level,routineP,failure) ALLOCATE(admm_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE admm_control_create ! ***************************************************************************** !> \brief ... !> \param admm_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE admm_control_release(admm_control,error) + SUBROUTINE admm_control_release(admm_control) TYPE(admm_control_type), POINTER :: admm_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'admm_control_release', & routineP = moduleN//':'//routineN @@ -1302,22 +1242,20 @@ SUBROUTINE admm_control_release(admm_control,error) IF (ASSOCIATED(admm_control)) THEN DEALLOCATE(admm_control,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE admm_control_release ! ***************************************************************************** !> \brief Create sccs_control_type !> \param sccs_control ... -!> \param error ... !> \par History !> - Creation (11.10.2013,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE sccs_control_create(sccs_control,error) + SUBROUTINE sccs_control_create(sccs_control) TYPE(sccs_control_type), POINTER :: sccs_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sccs_control_create', & routineP = moduleN//':'//routineN @@ -1327,9 +1265,9 @@ SUBROUTINE sccs_control_create(sccs_control,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(sccs_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(sccs_control),cp_failure_level,routineP,failure) ALLOCATE (sccs_control,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) sccs_control%ref_count = 1 sccs_control%derivative_method = 0 @@ -1354,15 +1292,13 @@ END SUBROUTINE sccs_control_create ! ***************************************************************************** !> \brief Release sccs_control_type !> \param sccs_control ... -!> \param error ... !> \par History !> - Creation (11.10.2013,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE sccs_control_release(sccs_control,error) + SUBROUTINE sccs_control_release(sccs_control) TYPE(sccs_control_type), POINTER :: sccs_control - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sccs_control_release', & routineP = moduleN//':'//routineN @@ -1373,11 +1309,11 @@ SUBROUTINE sccs_control_release(sccs_control,error) failure = .FALSE. IF (ASSOCIATED(sccs_control)) THEN - CPPrecondition((sccs_control%ref_count > 0),cp_failure_level,routineP,error,failure) + CPPrecondition((sccs_control%ref_count > 0),cp_failure_level,routineP,failure) sccs_control%ref_count = sccs_control%ref_count - 1 IF (sccs_control%ref_count == 0) THEN DEALLOCATE (sccs_control,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) END IF END IF diff --git a/src/cp_control_utils.F b/src/cp_control_utils.F index 31c36f1d67..8e9058462e 100644 --- a/src/cp_control_utils.F +++ b/src/cp_control_utils.F @@ -89,12 +89,10 @@ MODULE cp_control_utils !> \brief ... !> \param dft_control ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_dft_control(dft_control,dft_section,error) + SUBROUTINE read_dft_control(dft_control,dft_section) TYPE(dft_control_type), POINTER :: dft_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_dft_control', & routineP = moduleN//':'//routineN @@ -118,29 +116,29 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) failure = .FALSE. was_present = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(tmp_section,xc_fun_section,xc_section) - CALL dft_control_create(dft_control, error=error) + CALL dft_control_create(dft_control) ! determine wheather this is a semiempirical or DFTB run ! --> (no XC section needs to be provided) not_SE = .TRUE. - CALL section_vals_val_get(dft_section,"QS%METHOD",i_val=method_id,error=error) + CALL section_vals_val_get(dft_section,"QS%METHOD",i_val=method_id) SELECT CASE (method_id) CASE (do_method_dftb,do_method_scptb,do_method_mndo,do_method_am1,do_method_pm3,do_method_pnnl,& do_method_pm6,do_method_pdg,do_method_rm1,do_method_mndod) not_SE = .FALSE. END SELECT ! Check for XC section and XC_FUNCTIONAL section - xc_section => section_vals_get_subs_vals(dft_section,"XC",error=error) - CALL section_vals_get(xc_section,explicit=is_present,error=error) + xc_section => section_vals_get_subs_vals(dft_section,"XC") + CALL section_vals_get(xc_section,explicit=is_present) IF (.NOT.is_present.AND.not_SE) THEN CALL stop_program(routineN,moduleN,__LINE__,"XC section missing.") END IF IF (is_present) THEN - CALL section_vals_val_get(xc_section,"density_cutoff", r_val=density_cut,error=error) - CALL section_vals_val_get(xc_section,"gradient_cutoff", r_val=gradient_cut,error=error) - CALL section_vals_val_get(xc_section,"tau_cutoff", r_val=tau_cut,error=error) + CALL section_vals_val_get(xc_section,"density_cutoff", r_val=density_cut) + CALL section_vals_val_get(xc_section,"gradient_cutoff", r_val=gradient_cut) + CALL section_vals_val_get(xc_section,"tau_cutoff", r_val=tau_cut) ! Perform numerical stability checks and possibly correct the issues CALL cp_assert(density_cut>EPSILON(0.0_dp)*100.0_dp,cp_warning_level,cp_assertion_failed,routineP,& "DENSITY_CUTOFF lower than 100*EPSILON, where EPSILON is the machine precision. "//& @@ -160,18 +158,18 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) CPSourceFileRef,& only_ionode=.TRUE.) tau_cut = MAX(EPSILON(0.0_dp)*100.0_dp,tau_cut) - CALL section_vals_val_set(xc_section,"density_cutoff", r_val=density_cut,error=error) - CALL section_vals_val_set(xc_section,"gradient_cutoff", r_val=gradient_cut,error=error) - CALL section_vals_val_set(xc_section,"tau_cutoff", r_val=tau_cut,error=error) + CALL section_vals_val_set(xc_section,"density_cutoff", r_val=density_cut) + CALL section_vals_val_set(xc_section,"gradient_cutoff", r_val=gradient_cut) + CALL section_vals_val_set(xc_section,"tau_cutoff", r_val=tau_cut) END IF - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",error=error) - CALL section_vals_get(xc_fun_section,explicit=is_present,error=error) + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") + CALL section_vals_get(xc_fun_section,explicit=is_present) IF (.NOT.is_present.AND.not_SE) THEN CALL stop_program(routineN,moduleN,__LINE__,"XC_FUNCTIONAL section missing.") END IF - scf_section => section_vals_get_subs_vals(dft_section,"SCF",error=error) - CALL section_vals_val_get(dft_section,"UKS",l_val=dft_control%uks,error=error) - CALL section_vals_val_get(dft_section,"ROKS",l_val=dft_control%roks,error=error) + scf_section => section_vals_get_subs_vals(dft_section,"SCF") + CALL section_vals_val_get(dft_section,"UKS",l_val=dft_control%uks) + CALL section_vals_val_get(dft_section,"ROKS",l_val=dft_control%roks) IF (dft_control%uks.OR.dft_control%roks) THEN dft_control%nspins = 2 ELSE @@ -181,44 +179,43 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) dft_control%lsd = (dft_control%nspins > 1) needs = xc_functionals_get_needs(xc_fun_section,& lsd=dft_control%lsd,& - add_basic_components=.TRUE.,& - error=error) + add_basic_components=.TRUE.) dft_control%use_kinetic_energy_density = (needs%tau_spin.OR.needs%tau) - xc_deriv_method_id=section_get_ival(xc_section,"XC_GRID%XC_DERIV",error) + xc_deriv_method_id=section_get_ival(xc_section,"XC_GRID%XC_DERIV") dft_control%drho_by_collocation = (needs%norm_drho .AND. (xc_deriv_method_id==xc_deriv_collocate) ) IF (dft_control%drho_by_collocation) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives by collocation not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !! check if we do wavefunction fitting - tmp_section => section_vals_get_subs_vals(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD",error=error) - CALL section_vals_get(tmp_section,explicit=is_present,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD") + CALL section_vals_get(tmp_section,explicit=is_present) dft_control%do_admm = is_present dft_control%do_admm_mo = .FALSE. dft_control%do_admm_dm = .FALSE. IF(is_present) THEN do_ot = .FALSE. - CALL section_vals_val_get(scf_section,"OT%_SECTION_PARAMETERS_",l_val=do_ot,error=error) - CALL admm_control_create(dft_control%admm_control, error) + CALL section_vals_val_get(scf_section,"OT%_SECTION_PARAMETERS_",l_val=do_ot) + CALL admm_control_create(dft_control%admm_control) CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%EPS_FILTER",& - r_val=dft_control%admm_control%eps_filter, error=error) - CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%ADMM_PURIFICATION_METHOD",i_val=method_id,error=error) + r_val=dft_control%admm_control%eps_filter) + CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%ADMM_PURIFICATION_METHOD",i_val=method_id) dft_control%admm_control%purification_method = method_id - CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%METHOD",i_val=method_id,error=error) + CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%METHOD",i_val=method_id) dft_control%admm_control%method = method_id - CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%EXCH_SCALING_MODEL",i_val=method_id,error=error) + CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%EXCH_SCALING_MODEL",i_val=method_id) dft_control%admm_control%scaling_model = method_id - CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%EXCH_CORRECTION_FUNC",i_val=method_id,error=error) + CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%EXCH_CORRECTION_FUNC",i_val=method_id) dft_control%admm_control%aux_exch_func = method_id - CALL read_admm_block_list(dft_control%admm_control, dft_section, error) + CALL read_admm_block_list(dft_control%admm_control, dft_section) ! In the case of charge-constrained projection (e.g. according to Merlot), @@ -229,7 +226,7 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) .AND. dft_control%admm_control%scaling_model == do_admm_exch_scaling_merlot ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="ADMM: Blocking and Merlot scaling are mutually exclusive.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF @@ -238,7 +235,7 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) CALL cp_unimplemented_error(fromWhere=routineP, & message="ADMM: In the case of METHOD=CHARGE_CONSTRAINED_PROJECTION, "//& "ADMM_PURIFICATION_METHOD=NONE has to be set.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF @@ -248,11 +245,11 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) IF( dft_control%admm_control%method /= do_admm_basis_projection ) & CALL cp_unimplemented_error(fromWhere=routineP, & message="ADMM: Chosen purification requires BASIS_PROJECTION", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) IF( .NOT. do_ot) CALL cp_unimplemented_error(fromWhere=routineP, & message="ADMM: MO-based purification requires OT.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF(dft_control%admm_control%purification_method == do_admm_purify_none_dm .OR. & @@ -266,12 +263,12 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) ! Set restricted to true, if both OT and ROKS are requested !MK in principle dft_control%restricted could be dropped completely like the !MK input key by using only dft_control%roks now - CALL section_vals_val_get(scf_section,"OT%_SECTION_PARAMETERS_",l_val=l_param,error=error) + CALL section_vals_val_get(scf_section,"OT%_SECTION_PARAMETERS_",l_val=l_param) dft_control%restricted = (dft_control%roks.AND.l_param) - CALL section_vals_val_get(dft_section,"CHARGE",i_val=dft_control%charge,error=error) - CALL section_vals_val_get(dft_section,"MULTIPLICITY",i_val=dft_control%multiplicity,error=error) - CALL section_vals_val_get(dft_section,"RELAX_MULTIPLICITY",r_val=dft_control%relax_multiplicity,error=error) + CALL section_vals_val_get(dft_section,"CHARGE",i_val=dft_control%charge) + CALL section_vals_val_get(dft_section,"MULTIPLICITY",i_val=dft_control%multiplicity) + CALL section_vals_val_get(dft_section,"RELAX_MULTIPLICITY",r_val=dft_control%relax_multiplicity) IF (dft_control%relax_multiplicity > 0.0_dp) THEN CALL cp_assert(dft_control%uks,& cp_failure_level,cp_assertion_failed,routineP,& @@ -280,8 +277,8 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) END IF ! check for the presence of the low spin roks section - tmp_section => section_vals_get_subs_vals(dft_section,"LOW_SPIN_ROKS",error=error) - CALL section_vals_get(tmp_section,explicit=dft_control%low_spin_roks,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"LOW_SPIN_ROKS") + CALL section_vals_get(tmp_section,explicit=dft_control%low_spin_roks) dft_control%sic_method_id = sic_none dft_control%sic_scaling_a = 1.0_dp @@ -289,7 +286,7 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) ! DFT+U dft_control%dft_plus_u = .FALSE. - CALL section_vals_val_get(dft_section,"PLUS_U_METHOD",i_val=method_id,error=error) + CALL section_vals_val_get(dft_section,"PLUS_U_METHOD",i_val=method_id) dft_control%plus_u_method_id = method_id ! Smearing in use @@ -297,85 +294,85 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) ! Surface dipole correction dft_control%correct_surf_dip = .FALSE. - CALL section_vals_val_get(dft_section,"SURFACE_DIPOLE_CORRECTION",l_val=dft_control%correct_surf_dip,error=error) - CALL section_vals_val_get(dft_section,"SURF_DIP_DIR",i_val=dft_control%dir_surf_dip,error=error) + CALL section_vals_val_get(dft_section,"SURFACE_DIPOLE_CORRECTION",l_val=dft_control%correct_surf_dip) + CALL section_vals_val_get(dft_section,"SURF_DIP_DIR",i_val=dft_control%dir_surf_dip) CALL section_vals_val_get(dft_section,"BASIS_SET_FILE_NAME",& - c_val=basis_set_file_name , error=error) + c_val=basis_set_file_name) CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",& - c_val=potential_file_name , error=error) + c_val=potential_file_name) ! Read the input section - tmp_section => section_vals_get_subs_vals(dft_section,"sic",error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"sic") CALL section_vals_val_get(tmp_section,"SIC_METHOD",& - i_val=dft_control%sic_method_id,error=error) + i_val=dft_control%sic_method_id) CALL section_vals_val_get(tmp_section,"ORBITAL_SET",& - i_val=dft_control%sic_list_id,error=error) + i_val=dft_control%sic_list_id) CALL section_vals_val_get(tmp_section,"SIC_SCALING_A",& - r_val=dft_control%sic_scaling_a,error=error) + r_val=dft_control%sic_scaling_a) CALL section_vals_val_get(tmp_section,"SIC_SCALING_B",& - r_val=dft_control%sic_scaling_b,error=error) + r_val=dft_control%sic_scaling_b) ! Determine if this is a TDDFPT run - CALL section_vals_val_get(dft_section,"EXCITATIONS",i_val=excitations,error=error) + CALL section_vals_val_get(dft_section,"EXCITATIONS",i_val=excitations) dft_control%do_tddfpt_calculation = (excitations==tddfpt_excitations) IF (dft_control%do_tddfpt_calculation) THEN - CALL tddfpt_control_create(dft_control%tddfpt_control, error=error) + CALL tddfpt_control_create(dft_control%tddfpt_control) END IF do_rtp = .FALSE. - tmp_section => section_vals_get_subs_vals(dft_section,"REAL_TIME_PROPAGATION",error=error) - CALL section_vals_get(tmp_section,explicit=is_present,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"REAL_TIME_PROPAGATION") + CALL section_vals_get(tmp_section,explicit=is_present) IF (is_present) THEN - CALL read_rtp_section(dft_control,tmp_section,error) + CALL read_rtp_section(dft_control,tmp_section) do_rtp = .TRUE. END IF ! Read the input section - tmp_section => section_vals_get_subs_vals(dft_section,"XAS",error=error) - CALL section_vals_get(tmp_section,explicit=dft_control%do_xas_calculation,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"XAS") + CALL section_vals_get(tmp_section,explicit=dft_control%do_xas_calculation) IF (dft_control%do_xas_calculation) THEN ! Override with section parameter CALL section_vals_val_get(tmp_section,"_SECTION_PARAMETERS_",& - l_val=dft_control%do_xas_calculation,error=error) + l_val=dft_control%do_xas_calculation) END IF ! Read the finite field input section dft_control%apply_efield = .FALSE. dft_control%apply_efield_field = .FALSE. !this is for RTP - tmp_section => section_vals_get_subs_vals(dft_section,"EFIELD",error=error) - CALL section_vals_get(tmp_section,n_repetition=nrep,explicit=is_present,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"EFIELD") + CALL section_vals_get(tmp_section,n_repetition=nrep,explicit=is_present) IF (is_present) THEN ALLOCATE(dft_control%efield_fields(nrep),stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO i=1,nrep - CALL read_efield_sections(dft_control,tmp_section,error) + CALL read_efield_sections(dft_control,tmp_section) END DO IF(do_rtp) THEN dft_control%apply_efield_field = .TRUE. ELSE dft_control%apply_efield = .TRUE. - CPPostcondition(nrep==1, cp_failure_level, routineP, error, failure) + CPPostcondition(nrep==1, cp_failure_level, routineP,failure) END IF END IF ! Read the finite field input section for periodic fields - tmp_section => section_vals_get_subs_vals(dft_section,"PERIODIC_EFIELD",error=error) - CALL section_vals_get(tmp_section,explicit=dft_control%apply_period_efield,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"PERIODIC_EFIELD") + CALL section_vals_get(tmp_section,explicit=dft_control%apply_period_efield) IF (dft_control%apply_period_efield) THEN ALLOCATE(dft_control%period_efield,stat=stat) ALLOCATE(dft_control%period_efield%polarisation(3),stat=stat) CALL section_vals_val_get(tmp_section,"POLARISATION", & - r_vals=pol,error=error) + r_vals=pol) dft_control%period_efield%polarisation=pol CALL section_vals_val_get(tmp_section,"INTENSITY", & - r_val=dft_control%period_efield%strength,error=error) + r_val=dft_control%period_efield%strength) dft_control%period_efield%displacement_field = .FALSE. CALL section_vals_val_get(tmp_section,"DISPLACEMENT_FIELD", & - l_val=dft_control%period_efield%displacement_field,error=error) + l_val=dft_control%period_efield%displacement_field) ! periodic fields don't work with RTP - CPPostcondition(.NOT.do_rtp, cp_failure_level, routineP, error, failure) + CPPostcondition(.NOT.do_rtp, cp_failure_level, routineP,failure) IF(dft_control%period_efield%displacement_field) THEN CALL cite_reference(Stengel2009) ELSE @@ -385,60 +382,47 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) END IF ! Read the external potential input section - tmp_section => section_vals_get_subs_vals(dft_section,"EXTERNAL_POTENTIAL",error=error) - CALL section_vals_get(tmp_section,explicit=dft_control%apply_external_potential,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"EXTERNAL_POTENTIAL") + CALL section_vals_get(tmp_section,explicit=dft_control%apply_external_potential) !MK Read the SCCS input section if present - sccs_section => section_vals_get_subs_vals(dft_section,"SCCS",error=error) - CALL section_vals_get(sccs_section,explicit=is_present,error=error) + sccs_section => section_vals_get_subs_vals(dft_section,"SCCS") + CALL section_vals_get(sccs_section,explicit=is_present) IF (is_present) THEN ! Check section parameter if SCCS is activated CALL section_vals_val_get(sccs_section,"_SECTION_PARAMETERS_",& - l_val=dft_control%do_sccs,error=error) + l_val=dft_control%do_sccs) IF (dft_control%do_sccs) THEN - CALL sccs_control_create(dft_control%sccs_control,error=error) + CALL sccs_control_create(dft_control%sccs_control) CALL section_vals_val_get(sccs_section,"ALPHA",& - r_val=dft_control%sccs_control%alpha_solvent,& - error=error) + r_val=dft_control%sccs_control%alpha_solvent) CALL section_vals_val_get(sccs_section,"BETA",& - r_val=dft_control%sccs_control%beta_solvent,& - error=error) + r_val=dft_control%sccs_control%beta_solvent) CALL section_vals_val_get(sccs_section,"DELTA_RHO",& - r_val=dft_control%sccs_control%delta_rho,& - error=error) + r_val=dft_control%sccs_control%delta_rho) CALL section_vals_val_get(sccs_section,"DERIVATIVE_METHOD",& - i_val=dft_control%sccs_control%derivative_method,& - error=error) + i_val=dft_control%sccs_control%derivative_method) CALL section_vals_val_get(sccs_section,"METHOD",& - i_val=dft_control%sccs_control%method_id,& - error=error) + i_val=dft_control%sccs_control%method_id) CALL section_vals_val_get(sccs_section,"DIELECTRIC_CONSTANT",& - r_val=dft_control%sccs_control%epsilon_solvent,& - error=error) + r_val=dft_control%sccs_control%epsilon_solvent) CALL section_vals_val_get(sccs_section,"EPS_SCCS",& - r_val=dft_control%sccs_control%eps_sccs,& - error=error) + r_val=dft_control%sccs_control%eps_sccs) CALL section_vals_val_get(sccs_section,"EPS_SCF",& - r_val=dft_control%sccs_control%eps_scf,& - error=error) + r_val=dft_control%sccs_control%eps_scf) CALL section_vals_val_get(sccs_section,"GAMMA",& - r_val=dft_control%sccs_control%gamma_solvent,& - error=error) + r_val=dft_control%sccs_control%gamma_solvent) CALL section_vals_val_get(sccs_section,"MAX_ITER",& - i_val=dft_control%sccs_control%max_iter,& - error=error) + i_val=dft_control%sccs_control%max_iter) CALL section_vals_val_get(sccs_section,"MIXING",& - r_val=dft_control%sccs_control%mixing,& - error=error) + r_val=dft_control%sccs_control%mixing) SELECT CASE (dft_control%sccs_control%method_id) CASE (sccs_andreussi) - tmp_section => section_vals_get_subs_vals(sccs_section,"ANDREUSSI",error=error) + tmp_section => section_vals_get_subs_vals(sccs_section,"ANDREUSSI") CALL section_vals_val_get(tmp_section,"RHO_MAX",& - r_val=dft_control%sccs_control%rho_max,& - error=error) + r_val=dft_control%sccs_control%rho_max) CALL section_vals_val_get(tmp_section,"RHO_MIN",& - r_val=dft_control%sccs_control%rho_min,& - error=error) + r_val=dft_control%sccs_control%rho_min) IF (dft_control%sccs_control%rho_max < dft_control%sccs_control%rho_min) THEN CALL stop_program(routineN,moduleN,__LINE__,& "The SCCS parameter RHO_MAX is smaller than RHO_MIN. "//& @@ -446,10 +430,9 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) logger%para_env) END IF CASE (sccs_fattebert_gygi) - tmp_section => section_vals_get_subs_vals(sccs_section,"FATTEBERT-GYGI",error=error) + tmp_section => section_vals_get_subs_vals(sccs_section,"FATTEBERT-GYGI") CALL section_vals_val_get(tmp_section,"BETA",& - r_val=dft_control%sccs_control%beta,& - error=error) + r_val=dft_control%sccs_control%beta) IF (dft_control%sccs_control%beta < 0.5_dp) THEN CALL stop_program(routineN,moduleN,__LINE__,& "A value smaller than 0.5 for the SCCS parameter beta "//& @@ -457,8 +440,7 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) logger%para_env) END IF CALL section_vals_val_get(tmp_section,"RHO_ZERO",& - r_val=dft_control%sccs_control%rho_zero,& - error=error) + r_val=dft_control%sccs_control%rho_zero) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,& "Invalid SCCS model specified. Please, check your input!",& @@ -471,12 +453,12 @@ SUBROUTINE read_dft_control(dft_control,dft_section,error) ! ZMP added input sections ! Read the external density input section - tmp_section => section_vals_get_subs_vals(dft_section,"EXTERNAL_DENSITY",error=error) - CALL section_vals_get(tmp_section,explicit=dft_control%apply_external_density,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"EXTERNAL_DENSITY") + CALL section_vals_get(tmp_section,explicit=dft_control%apply_external_density) ! Read the external vxc input section - tmp_section => section_vals_get_subs_vals(dft_section,"EXTERNAL_VXC",error=error) - CALL section_vals_get(tmp_section,explicit=dft_control%apply_external_vxc,error=error) + tmp_section => section_vals_get_subs_vals(dft_section,"EXTERNAL_VXC") + CALL section_vals_get(tmp_section,explicit=dft_control%apply_external_vxc) END SUBROUTINE read_dft_control @@ -485,14 +467,12 @@ END SUBROUTINE read_dft_control !> \param qs_control ... !> \param dft_section ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_mgrid_section(qs_control,dft_section,para_env,error) + SUBROUTINE read_mgrid_section(qs_control,dft_section,para_env) TYPE(qs_control_type), INTENT(INOUT) :: qs_control TYPE(section_vals_type), POINTER :: dft_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_mgrid_section', & routineP = moduleN//':'//routineN @@ -509,17 +489,17 @@ SUBROUTINE read_mgrid_section(qs_control,dft_section,para_env,error) failure=.FALSE. NULLIFY(mgrid_section, cutofflist) - mgrid_section => section_vals_get_subs_vals(dft_section,"MGRID",error=error) - - CALL section_vals_val_get(mgrid_section,"NGRIDS",i_val=ngrid_level,error=error) - CALL section_vals_val_get(mgrid_section,"MULTIGRID_SET",l_val=multigrid_set,error=error) - CALL section_vals_val_get(mgrid_section,"CUTOFF",r_val=cutoff,error=error) - CALL section_vals_val_get(mgrid_section,"PROGRESSION_FACTOR",r_val=qs_control%progression_factor,error=error) - CALL section_vals_val_get(mgrid_section,"COMMENSURATE",l_val=qs_control%commensurate_mgrids,error=error) - CALL section_vals_val_get(mgrid_section,"REALSPACE",l_val=qs_control%realspace_mgrids,error=error) - CALL section_vals_val_get(mgrid_section,"REL_CUTOFF",r_val=qs_control%relative_cutoff,error=error) + mgrid_section => section_vals_get_subs_vals(dft_section,"MGRID") + + CALL section_vals_val_get(mgrid_section,"NGRIDS",i_val=ngrid_level) + CALL section_vals_val_get(mgrid_section,"MULTIGRID_SET",l_val=multigrid_set) + CALL section_vals_val_get(mgrid_section,"CUTOFF",r_val=cutoff) + CALL section_vals_val_get(mgrid_section,"PROGRESSION_FACTOR",r_val=qs_control%progression_factor) + CALL section_vals_val_get(mgrid_section,"COMMENSURATE",l_val=qs_control%commensurate_mgrids) + CALL section_vals_val_get(mgrid_section,"REALSPACE",l_val=qs_control%realspace_mgrids) + CALL section_vals_val_get(mgrid_section,"REL_CUTOFF",r_val=qs_control%relative_cutoff) CALL section_vals_val_get(mgrid_section,"SKIP_LOAD_BALANCE_DISTRIBUTED", & - l_val=qs_control%skip_load_balance_distributed,explicit=explicit,error=error) + l_val=qs_control%skip_load_balance_distributed,explicit=explicit) ! In the default case, we automatically switch to not optimize if the number of tasks is large, ! otherwise we run in the quadratic memory bottleneck, ! and in that case, the is likely not to be important anyway @@ -532,19 +512,19 @@ SUBROUTINE read_mgrid_section(qs_control,dft_section,para_env,error) ngrid_level = 1 multigrid_set = .FALSE. ! Override default cutoff value unless user specified an explicit argument.. - CALL section_vals_val_get(mgrid_section,"CUTOFF",explicit=explicit,r_val=cutoff,error=error) + CALL section_vals_val_get(mgrid_section,"CUTOFF",explicit=explicit,r_val=cutoff) IF (.NOT.explicit) cutoff = 1.0_dp END IF IF (qs_control%scptb) THEN ngrid_level = 1 multigrid_set = .FALSE. ! Override default cutoff value unless user specified an explicit argument.. - CALL section_vals_val_get(mgrid_section,"CUTOFF",explicit=explicit,r_val=cutoff,error=error) + CALL section_vals_val_get(mgrid_section,"CUTOFF",explicit=explicit,r_val=cutoff) IF (.NOT.explicit) cutoff = 45.0_dp END IF ALLOCATE(qs_control%e_cutoff(ngrid_level),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) qs_control%cutoff = cutoff IF (multigrid_set) THEN @@ -554,11 +534,11 @@ SUBROUTINE read_mgrid_section(qs_control,dft_section,para_env,error) "Do not specify cutoffs for the commensurate grids (NYI)") END IF - CALL section_vals_val_get(mgrid_section,"MULTIGRID_CUTOFF",r_vals=cutofflist,error=error) + CALL section_vals_val_get(mgrid_section,"MULTIGRID_CUTOFF",r_vals=cutofflist) IF(ASSOCIATED(cutofflist)) THEN CALL cp_assert(SIZE(cutofflist,1) == ngrid_level,& cp_failure_level,cp_assertion_failed,routineN,& - "Inconsistent values for number of multi grids",error,failure) + "Inconsistent values for number of multi grids",failure) DO igrid_level = 1,ngrid_level qs_control%e_cutoff(igrid_level) = cutofflist(igrid_level)*0.5_dp ENDDO @@ -596,13 +576,11 @@ END SUBROUTINE read_mgrid_section !> \brief ... !> \param qs_control ... !> \param qs_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_qs_section(qs_control,qs_section,error) + SUBROUTINE read_qs_section(qs_control,qs_section) TYPE(qs_control_type), INTENT(INOUT) :: qs_control TYPE(section_vals_type), POINTER :: qs_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_qs_section', & routineP = moduleN//':'//routineN @@ -629,19 +607,19 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) was_present = .FALSE. NULLIFY(mull_section,se_section,dftb_section,scptb_section,lri_optbas_section) - mull_section => section_vals_get_subs_vals(qs_section,"MULLIKEN_RESTRAINT", error=error) - ddapc_restraint_section => section_vals_get_subs_vals(qs_section,"DDAPC_RESTRAINT", error=error) - s2_restraint_section => section_vals_get_subs_vals(qs_section,"S2_RESTRAINT", error=error) - becke_restraint_section=> section_vals_get_subs_vals(qs_section,"BECKE_RESTRAINT", error=error) - se_section => section_vals_get_subs_vals(qs_section,"SE", error=error) - dftb_section => section_vals_get_subs_vals(qs_section,"DFTB", error=error) - dftb_parameter => section_vals_get_subs_vals(dftb_section,"PARAMETER", error=error) - scptb_section => section_vals_get_subs_vals(qs_section,"SCPTB", error=error) - lri_optbas_section => section_vals_get_subs_vals(qs_section,"OPTIMIZE_LRI_BASIS",error=error) + mull_section => section_vals_get_subs_vals(qs_section,"MULLIKEN_RESTRAINT") + ddapc_restraint_section => section_vals_get_subs_vals(qs_section,"DDAPC_RESTRAINT") + s2_restraint_section => section_vals_get_subs_vals(qs_section,"S2_RESTRAINT") + becke_restraint_section=> section_vals_get_subs_vals(qs_section,"BECKE_RESTRAINT") + se_section => section_vals_get_subs_vals(qs_section,"SE") + dftb_section => section_vals_get_subs_vals(qs_section,"DFTB") + dftb_parameter => section_vals_get_subs_vals(dftb_section,"PARAMETER") + scptb_section => section_vals_get_subs_vals(qs_section,"SCPTB") + lri_optbas_section => section_vals_get_subs_vals(qs_section,"OPTIMIZE_LRI_BASIS") ! Setup all defaults values and overwrite input parameters ! EPS_DEFAULT should set the target accuracy in the total energy (~per electron) or a closely related value - CALL section_vals_val_get(qs_section,"EPS_DEFAULT",r_val=value,error=error) + CALL section_vals_val_get(qs_section,"EPS_DEFAULT",r_val=value) tmpsqrt=SQRT(value) ! a trick to work around a NAG 5.1 optimizer bug ! random choice ? @@ -662,79 +640,79 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) ! error in the gradient, can be the sqrt of the error in the energy, ignored if map_consistent qs_control%eps_gvg_rspace = tmpsqrt ! - CALL section_vals_val_get(qs_section,"EPS_CORE_CHARGE",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_CORE_CHARGE",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_CORE_CHARGE",r_val=qs_control%eps_core_charge,error=error) + CALL section_vals_val_get(qs_section,"EPS_CORE_CHARGE",r_val=qs_control%eps_core_charge) END IF - CALL section_vals_val_get(qs_section,"EPS_GVG_RSPACE",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_GVG_RSPACE",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_GVG_RSPACE",r_val=qs_control%eps_gvg_rspace,error=error) + CALL section_vals_val_get(qs_section,"EPS_GVG_RSPACE",r_val=qs_control%eps_gvg_rspace) END IF - CALL section_vals_val_get(qs_section,"EPS_PGF_ORB",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_PGF_ORB",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_PGF_ORB",r_val=qs_control%eps_pgf_orb,error=error) + CALL section_vals_val_get(qs_section,"EPS_PGF_ORB",r_val=qs_control%eps_pgf_orb) END IF - CALL section_vals_val_get(qs_section,"EPS_KG_ORB",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_KG_ORB",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_KG_ORB",r_val=tmp,error=error) + CALL section_vals_val_get(qs_section,"EPS_KG_ORB",r_val=tmp) qs_control%eps_kg_orb=SQRT(tmp) END IF - CALL section_vals_val_get(qs_section,"EPS_PPL",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_PPL",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_PPL",r_val=qs_control%eps_ppl,error=error) + CALL section_vals_val_get(qs_section,"EPS_PPL",r_val=qs_control%eps_ppl) END IF - CALL section_vals_val_get(qs_section,"EPS_PPNL",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_PPNL",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_PPNL",r_val=qs_control%eps_ppnl,error=error) + CALL section_vals_val_get(qs_section,"EPS_PPNL",r_val=qs_control%eps_ppnl) END IF - CALL section_vals_val_get(qs_section,"EPS_RHO",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_RHO",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_RHO",r_val=qs_control%eps_rho_gspace,error=error) + CALL section_vals_val_get(qs_section,"EPS_RHO",r_val=qs_control%eps_rho_gspace) qs_control%eps_rho_rspace = qs_control%eps_rho_gspace END IF - CALL section_vals_val_get(qs_section,"EPS_RHO_RSPACE",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_RHO_RSPACE",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_RHO_RSPACE",r_val=qs_control%eps_rho_rspace,error=error) + CALL section_vals_val_get(qs_section,"EPS_RHO_RSPACE",r_val=qs_control%eps_rho_rspace) END IF - CALL section_vals_val_get(qs_section,"EPS_RHO_GSPACE",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_RHO_GSPACE",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_RHO_GSPACE",r_val=qs_control%eps_rho_gspace,error=error) + CALL section_vals_val_get(qs_section,"EPS_RHO_GSPACE",r_val=qs_control%eps_rho_gspace) END IF - CALL section_vals_val_get(qs_section,"EPS_FILTER_MATRIX",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_FILTER_MATRIX",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_FILTER_MATRIX",r_val=qs_control%eps_filter_matrix,error=error) + CALL section_vals_val_get(qs_section,"EPS_FILTER_MATRIX",r_val=qs_control%eps_filter_matrix) END IF - CALL section_vals_val_get(qs_section,"EPS_CPC",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(qs_section,"EPS_CPC",n_rep_val=n_rep) IF (n_rep /=0) THEN - CALL section_vals_val_get(qs_section,"EPS_CPC",r_val=qs_control%gapw_control%eps_cpc,error=error) + CALL section_vals_val_get(qs_section,"EPS_CPC",r_val=qs_control%gapw_control%eps_cpc) END IF - CALL section_vals_val_get(qs_section,"EPSFIT",r_val=qs_control%gapw_control%eps_fit,error=error) - CALL section_vals_val_get(qs_section,"EPSISO",r_val=qs_control%gapw_control%eps_iso,error=error) - CALL section_vals_val_get(qs_section,"EPSSVD",r_val=qs_control%gapw_control%eps_svd,error=error) - CALL section_vals_val_get(qs_section,"EPSRHO0",r_val=qs_control%gapw_control%eps_Vrho0,error=error) - CALL section_vals_val_get(qs_section,"ALPHA0_HARD",r_val=qs_control%gapw_control%alpha0_hard,error=error) + CALL section_vals_val_get(qs_section,"EPSFIT",r_val=qs_control%gapw_control%eps_fit) + CALL section_vals_val_get(qs_section,"EPSISO",r_val=qs_control%gapw_control%eps_iso) + CALL section_vals_val_get(qs_section,"EPSSVD",r_val=qs_control%gapw_control%eps_svd) + CALL section_vals_val_get(qs_section,"EPSRHO0",r_val=qs_control%gapw_control%eps_Vrho0) + CALL section_vals_val_get(qs_section,"ALPHA0_HARD",r_val=qs_control%gapw_control%alpha0_hard) qs_control%gapw_control%lrho1_eq_lrho0 = .FALSE. qs_control%gapw_control%alpha0_hard_from_input = .FALSE. IF(qs_control%gapw_control%alpha0_hard/=0.0_dp) qs_control%gapw_control%alpha0_hard_from_input = .TRUE. - CALL section_vals_val_get(qs_section,"FORCE_PAW",l_val=qs_control%gapw_control%force_paw,error=error) - CALL section_vals_val_get(qs_section,"MAX_RAD_LOCAL",r_val=qs_control%gapw_control%max_rad_local,error=error) + CALL section_vals_val_get(qs_section,"FORCE_PAW",l_val=qs_control%gapw_control%force_paw) + CALL section_vals_val_get(qs_section,"MAX_RAD_LOCAL",r_val=qs_control%gapw_control%max_rad_local) - CALL section_vals_val_get(qs_section,"LS_SCF",l_val=qs_control%do_ls_scf,error=error) - CALL section_vals_val_get(qs_section,"ALMO_SCF",l_val=qs_control%do_almo_scf,error=error) - CALL section_vals_val_get(qs_section,"KG_METHOD",l_val=qs_control%do_kg,error=error) + CALL section_vals_val_get(qs_section,"LS_SCF",l_val=qs_control%do_ls_scf) + CALL section_vals_val_get(qs_section,"ALMO_SCF",l_val=qs_control%do_almo_scf) + CALL section_vals_val_get(qs_section,"KG_METHOD",l_val=qs_control%do_kg) ! Logicals - CALL section_vals_val_get(qs_section,"MAP_CONSISTENT",l_val=qs_control%map_consistent,error=error) + CALL section_vals_val_get(qs_section,"MAP_CONSISTENT",l_val=qs_control%map_consistent) ! Integers gapw - CALL section_vals_val_get(qs_section,"LMAXN1",i_val=qs_control%gapw_control%lmax_sphere,error=error) - CALL section_vals_val_get(qs_section,"LMAXN0",i_val=qs_control%gapw_control%lmax_rho0,error=error) - CALL section_vals_val_get(qs_section,"LADDN0",i_val=qs_control%gapw_control%ladd_rho0,error=error) - CALL section_vals_val_get(qs_section,"QUADRATURE",i_val=qs_control%gapw_control%quadrature,error=error) + CALL section_vals_val_get(qs_section,"LMAXN1",i_val=qs_control%gapw_control%lmax_sphere) + CALL section_vals_val_get(qs_section,"LMAXN0",i_val=qs_control%gapw_control%lmax_rho0) + CALL section_vals_val_get(qs_section,"LADDN0",i_val=qs_control%gapw_control%ladd_rho0) + CALL section_vals_val_get(qs_section,"QUADRATURE",i_val=qs_control%gapw_control%quadrature) ! Integers grids - CALL section_vals_val_get(qs_section,"PW_GRID",i_val=itmp,error=error) + CALL section_vals_val_get(qs_section,"PW_GRID",i_val=itmp) SELECT CASE (itmp) CASE(do_pwgrid_spherical) qs_control%pw_grid_opt%spherical = .TRUE. @@ -748,25 +726,25 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) END SELECT ! Method for PPL calculation - CALL section_vals_val_get(qs_section,"CORE_PPL",i_val=itmp,error=error) + CALL section_vals_val_get(qs_section,"CORE_PPL",i_val=itmp) qs_control%do_ppl_method=itmp - CALL section_vals_val_get(qs_section,"PW_GRID_LAYOUT",i_vals=tmplist,error=error) + CALL section_vals_val_get(qs_section,"PW_GRID_LAYOUT",i_vals=tmplist) qs_control%pw_grid_opt%distribution_layout=tmplist - CALL section_vals_val_get(qs_section,"PW_GRID_BLOCKED",i_val=qs_control%pw_grid_opt%blocked,error=error) + CALL section_vals_val_get(qs_section,"PW_GRID_BLOCKED",i_val=qs_control%pw_grid_opt%blocked) !Integers extrapolation - CALL section_vals_val_get(qs_section,"EXTRAPOLATION",i_val=qs_control%wf_interpolation_method_nr,error=error) - CALL section_vals_val_get(qs_section,"EXTRAPOLATION_ORDER",i_val=qs_control%wf_extrapolation_order,error=error) + CALL section_vals_val_get(qs_section,"EXTRAPOLATION",i_val=qs_control%wf_interpolation_method_nr) + CALL section_vals_val_get(qs_section,"EXTRAPOLATION_ORDER",i_val=qs_control%wf_extrapolation_order) !Method - CALL section_vals_val_get(qs_section,"METHOD",i_val=qs_control%method_id,error=error) + CALL section_vals_val_get(qs_section,"METHOD",i_val=qs_control%method_id) NULLIFY(section,keyword,enum) - CALL create_qs_section(section,error=error) - keyword => section_get_keyword(section,"METHOD",error=error) - CALL keyword_get(keyword,enum=enum,error=error) - qs_control%method = enum_i2c(enum,qs_control%method_id,error=error) - CALL section_release(section,error=error) + CALL create_qs_section(section) + keyword => section_get_keyword(section,"METHOD") + CALL keyword_get(keyword,enum=enum) + qs_control%method = enum_i2c(enum,qs_control%method_id) + CALL section_release(section) qs_control%gapw = .FALSE. qs_control%gapw_xc = .FALSE. qs_control%gpw = .FALSE. @@ -824,16 +802,15 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) qs_control%semi_empirical = .TRUE. END SELECT - CALL section_vals_get(mull_section,explicit=qs_control%mulliken_restraint,error=error) + CALL section_vals_get(mull_section,explicit=qs_control%mulliken_restraint) IF (qs_control%mulliken_restraint) THEN - CALL section_vals_val_get(mull_section,"STRENGTH",r_val=qs_control%mulliken_restraint_control%strength,& - error=error) - CALL section_vals_val_get(mull_section,"TARGET",r_val=qs_control%mulliken_restraint_control%target,error=error) - CALL section_vals_val_get(mull_section,"ATOMS",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(mull_section,"STRENGTH",r_val=qs_control%mulliken_restraint_control%strength) + CALL section_vals_val_get(mull_section,"TARGET",r_val=qs_control%mulliken_restraint_control%target) + CALL section_vals_val_get(mull_section,"ATOMS",n_rep_val=n_rep) jj = 0 DO k = 1,n_rep - CALL section_vals_val_get(mull_section,"ATOMS",i_rep_val=k,i_vals=tmplist, error=error) + CALL section_vals_val_get(mull_section,"ATOMS",i_rep_val=k,i_vals=tmplist) jj=jj+SIZE(tmplist) END DO qs_control%mulliken_restraint_control%natoms = jj @@ -843,107 +820,107 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) ALLOCATE (qs_control%mulliken_restraint_control%atoms(qs_control%mulliken_restraint_control%natoms)) jj = 0 DO k = 1,n_rep - CALL section_vals_val_get(mull_section,"ATOMS",i_rep_val=k,i_vals=tmplist, error=error) + CALL section_vals_val_get(mull_section,"ATOMS",i_rep_val=k,i_vals=tmplist) DO j = 1,SIZE(tmplist) jj = jj+1 qs_control%mulliken_restraint_control%atoms (jj) = tmplist(j) END DO END DO ENDIF - CALL section_vals_get(ddapc_restraint_section,n_repetition=nrep,explicit=qs_control%ddapc_restraint,error=error) + CALL section_vals_get(ddapc_restraint_section,n_repetition=nrep,explicit=qs_control%ddapc_restraint) IF (qs_control%ddapc_restraint) THEN ALLOCATE (qs_control%ddapc_restraint_control(nrep)) - CALL read_ddapc_section(qs_control,qs_section=qs_section,error=error) + CALL read_ddapc_section(qs_control,qs_section=qs_section) qs_control%ddapc_restraint_is_spin = .FALSE. qs_control%ddapc_explicit_potential = .FALSE. ENDIF - CALL section_vals_get(s2_restraint_section,explicit=qs_control%s2_restraint,error=error) + CALL section_vals_get(s2_restraint_section,explicit=qs_control%s2_restraint) IF (qs_control%s2_restraint) THEN CALL section_vals_val_get(s2_restraint_section,"STRENGTH", & - r_val=qs_control%s2_restraint_control%strength,error=error) + r_val=qs_control%s2_restraint_control%strength) CALL section_vals_val_get(s2_restraint_section,"TARGET", & - r_val=qs_control%s2_restraint_control%target,error=error) + r_val=qs_control%s2_restraint_control%target) CALL section_vals_val_get(s2_restraint_section,"FUNCTIONAL_FORM", & - i_val=qs_control%s2_restraint_control%functional_form,error=error) + i_val=qs_control%s2_restraint_control%functional_form) ENDIF - CALL section_vals_get(becke_restraint_section,explicit=qs_control%becke_restraint,error=error) + CALL section_vals_get(becke_restraint_section,explicit=qs_control%becke_restraint) IF (qs_control%becke_restraint) THEN - CALL read_becke_section(qs_control,becke_restraint_section,error) + CALL read_becke_section(qs_control,becke_restraint_section) ENDIF ! Semi-empirical code IF (qs_control%semi_empirical) THEN CALL section_vals_val_get(se_section,"ORTHOGONAL_BASIS",& - l_val=qs_control%se_control%orthogonal_basis,error=error) + l_val=qs_control%se_control%orthogonal_basis) CALL section_vals_val_get(se_section,"DELTA",& - r_val=qs_control%se_control%delta,error=error) + r_val=qs_control%se_control%delta) CALL section_vals_val_get(se_section,"ANALYTICAL_GRADIENTS",& - l_val=qs_control%se_control%analytical_gradients,error=error) + l_val=qs_control%se_control%analytical_gradients) CALL section_vals_val_get(se_section,"FORCE_KDSO-D_EXCHANGE",& - l_val=qs_control%se_control%force_kdsod_EX,error=error) + l_val=qs_control%se_control%force_kdsod_EX) ! Integral Screening CALL section_vals_val_get(se_section,"INTEGRAL_SCREENING",& - i_val=qs_control%se_control%integral_screening,error=error) + i_val=qs_control%se_control%integral_screening) IF (qs_control%method_id==do_method_pnnl) THEN CALL cp_assert((qs_control%se_control%integral_screening==do_se_IS_slater),& cp_warning_level,cp_assertion_failed,routineP,& "PNNL semi-empirical parameterization supports only the Slater type "//& "integral scheme. Revert to Slater and continue the calculation.",& - error=error,failure=failure) + failure=failure) qs_control%se_control%integral_screening = do_se_IS_slater END IF ! Global Arrays variable CALL section_vals_val_get(se_section,"GA%NCELLS",& - i_val=qs_control%se_control%ga_ncells,error=error) + i_val=qs_control%se_control%ga_ncells) ! Long-Range correction CALL section_vals_val_get(se_section,"LR_CORRECTION%CUTOFF",& - r_val=qs_control%se_control%cutoff_lrc,error=error) + r_val=qs_control%se_control%cutoff_lrc) qs_control%se_control%taper_lrc = qs_control%se_control%cutoff_lrc CALL section_vals_val_get(se_section,"LR_CORRECTION%RC_TAPER",& - explicit=explicit, error=error) + explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(se_section,"LR_CORRECTION%RC_TAPER",& - r_val=qs_control%se_control%taper_lrc, error=error) + r_val=qs_control%se_control%taper_lrc) END IF CALL section_vals_val_get(se_section,"LR_CORRECTION%RC_RANGE",& - r_val=qs_control%se_control%range_lrc,error=error) + r_val=qs_control%se_control%range_lrc) ! Coulomb CALL section_vals_val_get(se_section,"COULOMB%CUTOFF",& - r_val=qs_control%se_control%cutoff_cou,error=error) + r_val=qs_control%se_control%cutoff_cou) qs_control%se_control%taper_cou = qs_control%se_control%cutoff_cou CALL section_vals_val_get(se_section,"COULOMB%RC_TAPER",& - explicit=explicit, error=error) + explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(se_section,"COULOMB%RC_TAPER",& - r_val=qs_control%se_control%taper_cou, error=error) + r_val=qs_control%se_control%taper_cou) END IF CALL section_vals_val_get(se_section,"COULOMB%RC_RANGE",& - r_val=qs_control%se_control%range_cou,error=error) + r_val=qs_control%se_control%range_cou) ! Exchange CALL section_vals_val_get(se_section,"EXCHANGE%CUTOFF",& - r_val=qs_control%se_control%cutoff_exc,error=error) + r_val=qs_control%se_control%cutoff_exc) qs_control%se_control%taper_exc = qs_control%se_control%cutoff_exc CALL section_vals_val_get(se_section,"EXCHANGE%RC_TAPER",& - explicit=explicit, error=error) + explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(se_section,"EXCHANGE%RC_TAPER",& - r_val=qs_control%se_control%taper_exc, error=error) + r_val=qs_control%se_control%taper_exc) END IF CALL section_vals_val_get(se_section,"EXCHANGE%RC_RANGE",& - r_val=qs_control%se_control%range_exc,error=error) + r_val=qs_control%se_control%range_exc) ! Screening (only if the integral scheme is of dumped type) IF (qs_control%se_control%integral_screening==do_se_IS_kdso_d) THEN CALL section_vals_val_get(se_section,"SCREENING%RC_TAPER",& - r_val=qs_control%se_control%taper_scr, error=error) + r_val=qs_control%se_control%taper_scr) CALL section_vals_val_get(se_section,"SCREENING%RC_RANGE",& - r_val=qs_control%se_control%range_scr,error=error) + r_val=qs_control%se_control%range_scr) END IF ! Periodic Type Calculation CALL section_vals_val_get(se_section,"PERIODIC",& - i_val=qs_control%se_control%periodic_type,error=error) + i_val=qs_control%se_control%periodic_type) SELECT CASE(qs_control%se_control%periodic_type) CASE(do_se_lr_none) qs_control%se_control%do_ewald = .FALSE. @@ -962,7 +939,7 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) "A periodic semi-empirical calculation was requested with a long-range "//& "summation on the single integral evaluation. This scheme is supported "//& "only by the PNNL parameterization.",& - error=error,failure=failure) + failure=failure) CASE(do_se_lr_ewald_r3) qs_control%se_control%do_ewald = .TRUE. qs_control%se_control%do_ewald_r3 = .TRUE. @@ -973,28 +950,28 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) "summation for the slowly convergent part 1/R^3, which is not congruent "//& "with the integral screening chosen. The only integral screening supported "//& "by this periodic type calculation is the standard Klopman-Dewar-Sabelli-Ohno.",& - error=error,failure=failure) + failure=failure) END SELECT ! dispersion pair potentials CALL section_vals_val_get(se_section,"DISPERSION",& - l_val=qs_control%se_control%dispersion,error=error) + l_val=qs_control%se_control%dispersion) CALL section_vals_val_get(se_section,"DISPERSION_RADIUS",& - r_val=qs_control%se_control%rcdisp,error=error) + r_val=qs_control%se_control%rcdisp) CALL section_vals_val_get(se_section,"COORDINATION_CUTOFF",& - r_val=qs_control%se_control%epscn,error=error) - CALL section_vals_val_get(se_section,"D3_SCALING",r_vals=scal,error=error) + r_val=qs_control%se_control%epscn) + CALL section_vals_val_get(se_section,"D3_SCALING",r_vals=scal) qs_control%se_control%sd3(1) = scal(1) qs_control%se_control%sd3(2) = scal(2) qs_control%se_control%sd3(3) = scal(3) CALL section_vals_val_get(se_section,"DISPERSION_PARAMETER_FILE",& - c_val=qs_control%se_control%dispersion_parameter_file,error=error) + c_val=qs_control%se_control%dispersion_parameter_file) ! Stop the execution for non-implemented features IF (qs_control%se_control%periodic_type==do_se_lr_ewald_r3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="EWALD_R3 not implemented yet! ", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF IF( qs_control %method_id == do_method_mndo .OR. & @@ -1012,50 +989,49 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) ! DFTB code IF (qs_control%dftb) THEN CALL section_vals_val_get(dftb_section,"ORTHOGONAL_BASIS",& - l_val=qs_control%dftb_control%orthogonal_basis,error=error) + l_val=qs_control%dftb_control%orthogonal_basis) CALL section_vals_val_get(dftb_section,"SELF_CONSISTENT",& - l_val=qs_control%dftb_control%self_consistent,error=error) + l_val=qs_control%dftb_control%self_consistent) CALL section_vals_val_get(dftb_section,"DISPERSION",& - l_val=qs_control%dftb_control%dispersion,error=error) + l_val=qs_control%dftb_control%dispersion) CALL section_vals_val_get(dftb_section,"DIAGONAL_DFTB3",& - l_val=qs_control%dftb_control%dftb3_diagonal,error=error) + l_val=qs_control%dftb_control%dftb3_diagonal) CALL section_vals_val_get(dftb_section,"HB_SR_GAMMA",& - l_val=qs_control%dftb_control%hb_sr_damp,error=error) + l_val=qs_control%dftb_control%hb_sr_damp) CALL section_vals_val_get(dftb_section,"EPS_DISP",& - r_val=qs_control%dftb_control%eps_disp,error=error) + r_val=qs_control%dftb_control%eps_disp) CALL section_vals_val_get(dftb_section,"DO_EWALD",& - l_val=qs_control%dftb_control%do_ewald,error=error) + l_val=qs_control%dftb_control%do_ewald) CALL section_vals_val_get(dftb_parameter,"PARAM_FILE_PATH",& - c_val=qs_control%dftb_control%sk_file_path,error=error) + c_val=qs_control%dftb_control%sk_file_path) CALL section_vals_val_get(dftb_parameter,"PARAM_FILE_NAME",& - c_val=qs_control%dftb_control%sk_file_list,error=error) + c_val=qs_control%dftb_control%sk_file_list) CALL section_vals_val_get(dftb_parameter,"HB_SR_PARAM",& - r_val=qs_control%dftb_control%hb_sr_para,error=error) - CALL section_vals_val_get(dftb_parameter,"SK_FILE",n_rep_val=n_var,& - error=error) + r_val=qs_control%dftb_control%hb_sr_para) + CALL section_vals_val_get(dftb_parameter,"SK_FILE",n_rep_val=n_var) ALLOCATE(qs_control%dftb_control%sk_pair_list(3,n_var),STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO k = 1, n_var CALL section_vals_val_get(dftb_parameter,"SK_FILE",i_rep_val=k,& - c_vals=clist,error=error) + c_vals=clist) qs_control%dftb_control%sk_pair_list(1:3,k) = clist(1:3) END DO ! Dispersion type CALL section_vals_val_get(dftb_parameter,"DISPERSION_TYPE",& - i_val=qs_control%dftb_control%dispersion_type,error=error) + i_val=qs_control%dftb_control%dispersion_type) CALL section_vals_val_get(dftb_parameter,"UFF_FORCE_FIELD",& - c_val=qs_control%dftb_control%uff_force_field,error=error) + c_val=qs_control%dftb_control%uff_force_field) ! D3 Dispersion CALL section_vals_val_get(dftb_parameter,"DISPERSION_RADIUS",& - r_val=qs_control%dftb_control%rcdisp,error=error) + r_val=qs_control%dftb_control%rcdisp) CALL section_vals_val_get(dftb_parameter,"COORDINATION_CUTOFF",& - r_val=qs_control%dftb_control%epscn,error=error) - CALL section_vals_val_get(dftb_parameter,"D3_SCALING",r_vals=scal,error=error) + r_val=qs_control%dftb_control%epscn) + CALL section_vals_val_get(dftb_parameter,"D3_SCALING",r_vals=scal) qs_control%dftb_control%sd3(1) = scal(1) qs_control%dftb_control%sd3(2) = scal(2) qs_control%dftb_control%sd3(3) = scal(3) CALL section_vals_val_get(dftb_parameter,"DISPERSION_PARAMETER_FILE",& - c_val=qs_control%dftb_control%dispersion_parameter_file,error=error) + c_val=qs_control%dftb_control%dispersion_parameter_file) IF (qs_control%dftb_control%dispersion) CALL cite_reference(Zhechkov2005) IF (qs_control%dftb_control%self_consistent) CALL cite_reference(Elstner1998) @@ -1065,33 +1041,33 @@ SUBROUTINE read_qs_section(qs_control,qs_section,error) ! SCPTB code IF (qs_control%scptb) THEN CALL section_vals_val_get(scptb_section,"DISPERSION",& - l_val=qs_control%scptb_control%dispersion,error=error) + l_val=qs_control%scptb_control%dispersion) CALL section_vals_val_get(scptb_section,"PARAMETER_FILE_NAME",& - c_val=qs_control%scptb_control%parameter_file,error=error) + c_val=qs_control%scptb_control%parameter_file) CALL section_vals_val_get(scptb_section,"DISPERSION_RADIUS",& - r_val=qs_control%scptb_control%rcdisp,error=error) + r_val=qs_control%scptb_control%rcdisp) CALL section_vals_val_get(scptb_section,"COORDINATION_CUTOFF",& - r_val=qs_control%scptb_control%epscn,error=error) - CALL section_vals_val_get(scptb_section,"D3_SCALING",r_vals=scal,error=error) + r_val=qs_control%scptb_control%epscn) + CALL section_vals_val_get(scptb_section,"D3_SCALING",r_vals=scal) qs_control%scptb_control%sd3(1) = scal(1) qs_control%scptb_control%sd3(2) = scal(2) qs_control%scptb_control%sd3(3) = scal(3) CALL section_vals_val_get(scptb_section,"STO_NG",& - i_val=qs_control%scptb_control%sto_ng,error=error) + i_val=qs_control%scptb_control%sto_ng) CALL section_vals_val_get(scptb_section,"DISPERSION_PARAMETER_FILE",& - c_val=qs_control%scptb_control%dispersion_parameter_file,error=error) + c_val=qs_control%scptb_control%dispersion_parameter_file) CALL section_vals_val_get(scptb_section,"PAIR_CUTOFF",& - r_val=qs_control%scptb_control%epspair,error=error) + r_val=qs_control%scptb_control%epspair) CALL section_vals_val_get(scptb_section,"DO_EWALD",& - l_val=qs_control%scptb_control%do_ewald,error=error) + l_val=qs_control%scptb_control%do_ewald) CALL section_vals_val_get(scptb_section,"DO_SCP",& - l_val=qs_control%scptb_control%do_scp,error=error) + l_val=qs_control%scptb_control%do_scp) CALL section_vals_val_get(scptb_section,"DO_SCC",& - l_val=qs_control%scptb_control%do_scc,error=error) + l_val=qs_control%scptb_control%do_scc) END IF ! Optimize LRI basis set - CALL section_vals_get(lri_optbas_section,explicit=qs_control%lri_optbas,error=error) + CALL section_vals_get(lri_optbas_section,explicit=qs_control%lri_optbas) CALL timestop(handle) END SUBROUTINE read_qs_section @@ -1100,12 +1076,10 @@ END SUBROUTINE read_qs_section !> \brief ... !> \param t_control ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_tddfpt_control(t_control,dft_section,error) + SUBROUTINE read_tddfpt_control(t_control,dft_section) TYPE(tddfpt_control_type) :: t_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_tddfpt_control', & routineP = moduleN//':'//routineN @@ -1116,27 +1090,27 @@ SUBROUTINE read_tddfpt_control(t_control,dft_section,error) failure=.FALSE. kenergy_den = .FALSE. NULLIFY(sic_section, t_section) - t_section => section_vals_get_subs_vals(dft_section,"TDDFPT",error=error) - - CALL section_vals_val_get(t_section,"CONVERGENCE", r_val=t_control%tolerance,error=error) - CALL section_vals_val_get(t_section,"NEV",i_val=t_control%n_ev,error=error) - CALL section_vals_val_get(t_section,"MAX_KV",i_val=t_control%max_kv,error=error) - CALL section_vals_val_get(t_section,"RESTARTS",i_val=t_control%n_restarts,error=error) - CALL section_vals_val_get(t_section,"NREORTHO",i_val=t_control%n_reortho,error=error) - CALL section_vals_val_get(t_section,"RES_ETYPE",i_val=t_control%res_etype,error=error) - CALL section_vals_val_get(t_section,"DIAG_METHOD",i_val=t_control%diag_method,error=error) - CALL section_vals_val_get(t_section,"KERNEL",l_val=t_control%do_kernel,error=error) - CALL section_vals_val_get(t_section,"LSD_SINGLETS",l_val=t_control%lsd_singlets,error=error) - CALL section_vals_val_get(t_section,"INVERT_S",l_val=t_control%invert_S,error=error) - CALL section_vals_val_get(t_section,"PRECOND",l_val=t_control%precond,error=error) - CALL section_vals_val_get(t_section,"OE_CORR",i_val=t_control%oe_corr,error=error) + t_section => section_vals_get_subs_vals(dft_section,"TDDFPT") + + CALL section_vals_val_get(t_section,"CONVERGENCE", r_val=t_control%tolerance) + CALL section_vals_val_get(t_section,"NEV",i_val=t_control%n_ev) + CALL section_vals_val_get(t_section,"MAX_KV",i_val=t_control%max_kv) + CALL section_vals_val_get(t_section,"RESTARTS",i_val=t_control%n_restarts) + CALL section_vals_val_get(t_section,"NREORTHO",i_val=t_control%n_reortho) + CALL section_vals_val_get(t_section,"RES_ETYPE",i_val=t_control%res_etype) + CALL section_vals_val_get(t_section,"DIAG_METHOD",i_val=t_control%diag_method) + CALL section_vals_val_get(t_section,"KERNEL",l_val=t_control%do_kernel) + CALL section_vals_val_get(t_section,"LSD_SINGLETS",l_val=t_control%lsd_singlets) + CALL section_vals_val_get(t_section,"INVERT_S",l_val=t_control%invert_S) + CALL section_vals_val_get(t_section,"PRECOND",l_val=t_control%precond) + CALL section_vals_val_get(t_section,"OE_CORR",i_val=t_control%oe_corr) t_control%use_kinetic_energy_density = .FALSE. - sic_section=>section_vals_get_subs_vals(t_section,"SIC",error=error) - CALL section_vals_val_get(sic_section,"SIC_METHOD",i_val=t_control%sic_method_id,error=error) - CALL section_vals_val_get(sic_section,"ORBITAL_SET",i_val=t_control%sic_list_id,error=error) - CALL section_vals_val_get(sic_section,"SIC_SCALING_A",r_val=t_control%sic_scaling_a,error=error) - CALL section_vals_val_get(sic_section,"SIC_SCALING_B",r_val=t_control%sic_scaling_b,error=error) + sic_section=>section_vals_get_subs_vals(t_section,"SIC") + CALL section_vals_val_get(sic_section,"SIC_METHOD",i_val=t_control%sic_method_id) + CALL section_vals_val_get(sic_section,"ORBITAL_SET",i_val=t_control%sic_list_id) + CALL section_vals_val_get(sic_section,"SIC_SCALING_A",r_val=t_control%sic_scaling_a) + CALL section_vals_val_get(sic_section,"SIC_SCALING_B",r_val=t_control%sic_scaling_b) END SUBROUTINE read_tddfpt_control @@ -1144,12 +1118,10 @@ END SUBROUTINE read_tddfpt_control !> \brief Write the DFT control parameters to the output unit. !> \param dft_control ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_dft_control(dft_control, dft_section, error) + SUBROUTINE write_dft_control(dft_control, dft_section) TYPE(dft_control_type), POINTER :: dft_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_dft_control', & routineP = moduleN//':'//routineN @@ -1173,14 +1145,14 @@ SUBROUTINE write_dft_control(dft_control, dft_section, error) failure = .FALSE. NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log",error=error) + "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log") IF (output_unit > 0) THEN - xc_section => section_vals_get_subs_vals(dft_section,"XC",error=error) + xc_section => section_vals_get_subs_vals(dft_section,"XC") IF (dft_control%uks) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A,T78,A)")& @@ -1238,10 +1210,10 @@ SUBROUTINE write_dft_control(dft_control, dft_section, error) ENDIF END IF - CALL section_vals_val_get(xc_section,"density_cutoff", r_val=density_cut,error=error) - CALL section_vals_val_get(xc_section,"gradient_cutoff", r_val=gradient_cut,error=error) - CALL section_vals_val_get(xc_section,"tau_cutoff", r_val=tau_cut,error=error) - CALL section_vals_val_get(xc_section,"density_smooth_cutoff_range",r_val=density_smooth_cut_range,error=error) + CALL section_vals_val_get(xc_section,"density_cutoff", r_val=density_cut) + CALL section_vals_val_get(xc_section,"gradient_cutoff", r_val=gradient_cut) + CALL section_vals_val_get(xc_section,"tau_cutoff", r_val=tau_cut) + CALL section_vals_val_get(xc_section,"density_smooth_cutoff_range",r_val=density_smooth_cut_range) WRITE (UNIT=output_unit,FMT="(T2,A,T66,ES15.6)")& "DFT| Cutoffs: density ",density_cut,& @@ -1249,32 +1221,31 @@ SUBROUTINE write_dft_control(dft_control, dft_section, error) "DFT| tau ",tau_cut,& "DFT| cutoff_smoothing_range",density_smooth_cut_range CALL section_vals_val_get(xc_section,"XC_GRID%XC_SMOOTH_RHO",& - c_val=tmpStr,error=error) + c_val=tmpStr) WRITE ( output_unit, '( A, T61, A )' ) & " DFT| XC density smoothing ",ADJUSTR(tmpStr) CALL section_vals_val_get(xc_section,"XC_GRID%XC_DERIV",& - c_val=tmpStr,error=error) + c_val=tmpStr) WRITE ( output_unit, '( A, T61, A )' ) & " DFT| XC derivatives ",ADJUSTR(tmpStr) IF (dft_control%dft_plus_u) THEN NULLIFY (enum,keyword,section) - CALL create_dft_section(section,error=error) - keyword => section_get_keyword(section,"PLUS_U_METHOD",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + CALL create_dft_section(section) + keyword => section_get_keyword(section,"PLUS_U_METHOD") + CALL keyword_get(keyword,enum=enum) WRITE (UNIT=output_unit,FMT="(/,T2,A,T41,A40)")& - "DFT+U| Method",ADJUSTR(TRIM(enum_i2c(enum,dft_control%plus_u_method_id,error=error))) + "DFT+U| Method",ADJUSTR(TRIM(enum_i2c(enum,dft_control%plus_u_method_id))) WRITE (UNIT=output_unit,FMT="(T2,A)")& "DFT+U| Check atomic kind information for details" - CALL section_release(section,error=error) + CALL section_release(section) END IF - CALL xc_write(output_unit,xc_section,dft_control%lsd,error) + CALL xc_write(output_unit,xc_section,dft_control%lsd) IF (dft_control%do_sccs) THEN IF (dft_control%qs_control%gapw) THEN CALL cp_unimplemented_error(fromWhere=routineP,& message="SCCS is not yet implemented with GAPW",& - error=error,& error_level=cp_failure_level) END IF WRITE (UNIT=output_unit,FMT="(/,T2,A)")& @@ -1316,13 +1287,13 @@ SUBROUTINE write_dft_control(dft_control, dft_section, error) END SELECT WRITE (UNIT=output_unit,FMT="(T2,A,T69,F12.3)")& "SCCS| Repulsion parameter alpha [mN/m] = [dyn/cm]",& - cp_unit_from_cp2k(dft_control%sccs_control%alpha_solvent,"mN/m",error=error) + cp_unit_from_cp2k(dft_control%sccs_control%alpha_solvent,"mN/m") WRITE (UNIT=output_unit,FMT="(T2,A,T69,F12.3)")& "SCCS| Dispersion parameter beta [GPa]",& - cp_unit_from_cp2k(dft_control%sccs_control%beta_solvent,"GPa",error=error) + cp_unit_from_cp2k(dft_control%sccs_control%beta_solvent,"GPa") WRITE (UNIT=output_unit,FMT="(T2,A,T69,F12.3)")& "SCCS| Surface tension gamma [mN/m] = [dyn/cm]",& - cp_unit_from_cp2k(dft_control%sccs_control%gamma_solvent,"mN/m",error=error) + cp_unit_from_cp2k(dft_control%sccs_control%gamma_solvent,"mN/m") WRITE (UNIT=output_unit,FMT="(T2,A,T69,F12.3)")& "SCCS| Mixing parameter applied during the iteration cycle",& dft_control%sccs_control%mixing @@ -1343,7 +1314,7 @@ SUBROUTINE write_dft_control(dft_control, dft_section, error) END IF CALL cp_print_key_finished_output(output_unit,logger,dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",error=error) + "PRINT%DFT_CONTROL_PARAMETERS") CALL timestop(handle) @@ -1353,12 +1324,10 @@ END SUBROUTINE write_dft_control !> \brief Purpose: Write the QS control parameters to the output unit. !> \param qs_control ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_qs_control(qs_control,dft_section,error) + SUBROUTINE write_qs_control(qs_control,dft_section) TYPE(qs_control_type), INTENT(IN) :: qs_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_qs_control', & routineP = moduleN//':'//routineN @@ -1378,14 +1347,14 @@ SUBROUTINE write_qs_control(qs_control,dft_section,error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger, enum, keyword, section) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL create_qs_section(section,error=error) - keyword => section_get_keyword(section,"QUADRATURE",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + CALL create_qs_section(section) + keyword => section_get_keyword(section,"QUADRATURE") + CALL keyword_get(keyword,enum=enum) output_unit = cp_print_key_unit_nr(logger, dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log",error=error) + "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log") IF (output_unit>0) THEN ngrid_level = SIZE(qs_control%e_cutoff) WRITE (UNIT=output_unit,FMT="(/,T2,A,T71,A)")& @@ -1457,7 +1426,7 @@ SUBROUTINE write_qs_control(qs_control,dft_section,error) qs_control%gapw_control%eps_cpc WRITE (UNIT=output_unit,FMT="(T2,A,T55,A30)")& "QS| GAPW| atom-r-grid: quadrature:",& - enum_i2c(enum,qs_control%gapw_control%quadrature,error=error) + enum_i2c(enum,qs_control%gapw_control%quadrature) WRITE (UNIT=output_unit,FMT="(T2,A,T71,I10)")& "QS| GAPW| atom-s-grid: max l :",& qs_control%gapw_control%lmax_sphere ,& @@ -1482,7 +1451,7 @@ SUBROUTINE write_qs_control(qs_control,dft_section,error) qs_control%gapw_control%eps_svd WRITE (UNIT=output_unit,FMT="(T2,A,T55,A30)")& "QS| GAPW_XC|atom-r-grid: quadrature:",& - enum_i2c(enum,qs_control%gapw_control%quadrature,error=error) + enum_i2c(enum,qs_control%gapw_control%quadrature) WRITE (UNIT=output_unit,FMT="(T2,A,T71,I10)")& "QS| GAPW_XC| atom-s-grid: max l :",& qs_control%gapw_control%lmax_sphere @@ -1542,8 +1511,8 @@ SUBROUTINE write_qs_control(qs_control,dft_section,error) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",error=error) - CALL section_release(section, error) + "PRINT%DFT_CONTROL_PARAMETERS") + CALL section_release(section) CALL timestop(handle) @@ -1552,16 +1521,13 @@ END SUBROUTINE write_qs_control ! ***************************************************************************** !> \brief returns a string that describes the smoothing of rho !> \param xc_rho_smooth_id the id that represent the smoothing -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 05.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION xc_get_rho_smooth_label(xc_rho_smooth_id,error) RESULT(res) + FUNCTION xc_get_rho_smooth_label(xc_rho_smooth_id) RESULT(res) INTEGER, INTENT(in) :: xc_rho_smooth_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=10) :: res CHARACTER(len=*), PARAMETER :: routineN = 'xc_get_rho_smooth_label', & @@ -1591,16 +1557,13 @@ END FUNCTION xc_get_rho_smooth_label !> \brief returns a string that describes the derivative used in the xc !> calculation !> \param xc_deriv_method_id the id that represent the derivative method -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 06.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION xc_get_deriv_method_label(xc_deriv_method_id,error) RESULT(res) + FUNCTION xc_get_deriv_method_label(xc_deriv_method_id) RESULT(res) INTEGER, INTENT(in) :: xc_deriv_method_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=20) :: res CHARACTER(len=*), PARAMETER :: routineN = 'xc_get_deriv_method_label', & @@ -1635,14 +1598,14 @@ END FUNCTION xc_get_deriv_method_label !> calculation !> \param xc_functional_routine_id the id that represent the functional !> routine -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling +!> \brief returns a string that describes the functional routine used in the xc +!> calculation +!> \param res ... !> \retval res ... !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION xc_get_routine_label(xc_functional_routine_id,error) RESULT(res) + FUNCTION xc_get_routine_label(xc_functional_routine_id) RESULT(res) INTEGER, INTENT(in) :: xc_functional_routine_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=20) :: res CHARACTER(len=*), PARAMETER :: routineN = 'xc_get_routine_label', & @@ -1671,20 +1634,18 @@ END FUNCTION xc_get_routine_label !> \param qs_control ... !> \param qs_section ... !> \param ddapc_restraint_section ... -!> \param error ... !> \author fschiff !> \note !> either reads DFT%QS%DDAPC_RESTRAINT or PROPERTIES%ET_coupling !> if(qs_section is present the DFT part is read, if ddapc_restraint_section !> is present ET_COUPLING is read. Avoid having both!!! ! ***************************************************************************** - SUBROUTINE read_ddapc_section(qs_control,qs_section,ddapc_restraint_section,error) + SUBROUTINE read_ddapc_section(qs_control,qs_section,ddapc_restraint_section) TYPE(qs_control_type), INTENT(INOUT) :: qs_control TYPE(section_vals_type), OPTIONAL, & POINTER :: qs_section, & ddapc_restraint_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_ddapc_section', & routineP = moduleN//':'//routineN @@ -1701,7 +1662,7 @@ SUBROUTINE read_ddapc_section(qs_control,qs_section,ddapc_restraint_section,erro IF(SIZE(qs_control%ddapc_restraint_control).GE.2)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "ET_COUPLING cannot be used in combination with a normal restraint",& - error=error,failure=failure) + failure=failure) ELSE ddapc_section=> ddapc_restraint_section ALLOCATE(qs_control%ddapc_restraint_control(1)) @@ -1711,30 +1672,30 @@ SUBROUTINE read_ddapc_section(qs_control,qs_section,ddapc_restraint_section,erro IF(PRESENT(qs_section))THEN NULLIFY(ddapc_section) ddapc_section => section_vals_get_subs_vals(qs_section,& - "DDAPC_RESTRAINT",error=error) + "DDAPC_RESTRAINT") END IF DO i=1,SIZE(qs_control%ddapc_restraint_control) NULLIFY(qs_control%ddapc_restraint_control(i)%ddapc_restraint_control) - CALL ddapc_control_create(qs_control%ddapc_restraint_control(i)%ddapc_restraint_control ,error) + CALL ddapc_control_create(qs_control%ddapc_restraint_control(i)%ddapc_restraint_control) ddapc_restraint_control=>qs_control%ddapc_restraint_control(i)%ddapc_restraint_control CALL section_vals_val_get(ddapc_section,"STRENGTH",i_rep_section=i, & - r_val=ddapc_restraint_control%strength,error=error) + r_val=ddapc_restraint_control%strength) CALL section_vals_val_get(ddapc_section,"TARGET",i_rep_section=i, & - r_val=ddapc_restraint_control%target,error=error) + r_val=ddapc_restraint_control%target) CALL section_vals_val_get(ddapc_section,"FUNCTIONAL_FORM",i_rep_section=i, & - i_val=ddapc_restraint_control%functional_form,error=error) + i_val=ddapc_restraint_control%functional_form) CALL section_vals_val_get(ddapc_section,"ATOMS",i_rep_section=i, & - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) CALL section_vals_val_get(ddapc_section,"TYPE_OF_DENSITY",i_rep_section=i,& - i_val=ddapc_restraint_control%density_type,error=error) + i_val=ddapc_restraint_control%density_type) jj = 0 DO k = 1,n_rep CALL section_vals_val_get(ddapc_section,"ATOMS",i_rep_section=i,& - i_rep_val=k,i_vals=tmplist, error=error) + i_rep_val=k,i_vals=tmplist) DO j = 1,SIZE(tmplist) jj = jj+1 END DO @@ -1748,7 +1709,7 @@ SUBROUTINE read_ddapc_section(qs_control,qs_section,ddapc_restraint_section,erro jj = 0 DO k = 1,n_rep CALL section_vals_val_get(ddapc_section,"ATOMS",i_rep_section=i,& - i_rep_val=k,i_vals=tmplist, error=error) + i_rep_val=k,i_vals=tmplist) DO j = 1,SIZE(tmplist) jj = jj+1 ddapc_restraint_control%atoms (jj) = tmplist(j) @@ -1761,11 +1722,11 @@ SUBROUTINE read_ddapc_section(qs_control,qs_section,ddapc_restraint_section,erro ddapc_restraint_control%coeff=1.0_dp CALL section_vals_val_get(ddapc_section,"COEFF",i_rep_section=i, & - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) jj = 0 DO k = 1,n_rep CALL section_vals_val_get(ddapc_section,"COEFF",i_rep_section=i,& - i_rep_val=k,r_vals=rtmplist, error=error) + i_rep_val=k,r_vals=rtmplist) DO j = 1,SIZE(rtmplist) jj = jj+1 IF (jj>ddapc_restraint_control%natoms) & @@ -1785,7 +1746,7 @@ SUBROUTINE read_ddapc_section(qs_control,qs_section,ddapc_restraint_section,erro END DO IF(k==2)CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Only a single constraint possible yet, try to use restraints instead ",& - error=error,failure=failure) + failure=failure) END SUBROUTINE read_ddapc_section @@ -1793,14 +1754,12 @@ END SUBROUTINE read_ddapc_section !> \brief reads the input parameters needed for evaluating a becke weight population constraint !> \param qs_control ... !> \param becke_section ... -!> \param error ... !> \author fschiff ! ***************************************************************************** - SUBROUTINE read_becke_section(qs_control,becke_section,error) + SUBROUTINE read_becke_section(qs_control,becke_section) TYPE(qs_control_type), INTENT(INOUT) :: qs_control TYPE(section_vals_type), POINTER :: becke_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_becke_section', & routineP = moduleN//':'//routineN @@ -1810,16 +1769,16 @@ SUBROUTINE read_becke_section(qs_control,becke_section,error) REAL(KIND=dp), DIMENSION(:), POINTER :: rtmplist CALL section_vals_val_get(becke_section,"STRENGTH", & - r_val=qs_control%becke_control%strength,error=error) + r_val=qs_control%becke_control%strength) CALL section_vals_val_get(becke_section,"TARGET", & - r_val=qs_control%becke_control%target,error=error) + r_val=qs_control%becke_control%target) CALL section_vals_val_get(becke_section,"TYPE_OF_DENSITY",& - i_val=qs_control%becke_control%density_type,error=error) + i_val=qs_control%becke_control%density_type) CALL section_vals_val_get(becke_section,"ATOMS", & - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) jj = 0 DO k = 1,n_rep - CALL section_vals_val_get(becke_section,"ATOMS",i_rep_val=k,i_vals=tmplist, error=error) + CALL section_vals_val_get(becke_section,"ATOMS",i_rep_val=k,i_vals=tmplist) DO j = 1,SIZE(tmplist) jj = jj+1 END DO @@ -1831,7 +1790,7 @@ SUBROUTINE read_becke_section(qs_control,becke_section,error) ALLOCATE(qs_control%becke_control%atoms(qs_control%becke_control%natoms)) jj = 0 DO k = 1,n_rep - CALL section_vals_val_get(becke_section,"ATOMS",i_rep_val=k,i_vals=tmplist, error=error) + CALL section_vals_val_get(becke_section,"ATOMS",i_rep_val=k,i_vals=tmplist) DO j = 1,SIZE(tmplist) jj = jj+1 qs_control%becke_control%atoms (jj) = tmplist(j) @@ -1844,10 +1803,10 @@ SUBROUTINE read_becke_section(qs_control,becke_section,error) qs_control%becke_control%coeff=1.0_dp CALL section_vals_val_get(becke_section,"COEFF", & - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) jj = 0 DO k = 1,n_rep - CALL section_vals_val_get(becke_section,"COEFF",i_rep_val=k,r_vals=rtmplist, error=error) + CALL section_vals_val_get(becke_section,"COEFF",i_rep_val=k,r_vals=rtmplist) DO j = 1,SIZE(rtmplist) jj = jj+1 IF (jj>qs_control%becke_control%natoms) & @@ -1865,12 +1824,10 @@ END SUBROUTINE read_becke_section !> \brief ... !> \param dft_control ... !> \param efield_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_efield_sections(dft_control,efield_section,error) + SUBROUTINE read_efield_sections(dft_control,efield_section) TYPE(dft_control_type), POINTER :: dft_control TYPE(section_vals_type), POINTER :: efield_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_efield_sections', & routineP = moduleN//':'//routineN @@ -1886,53 +1843,53 @@ SUBROUTINE read_efield_sections(dft_control,efield_section,error) DO i=1,SIZE(dft_control%efield_fields) NULLIFY(dft_control%efield_fields(i)%efield) ALLOCATE(dft_control%efield_fields(i)%efield,stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) efield => dft_control%efield_fields(i)%efield NULLIFY(efield%envelop_i_vars,efield%envelop_r_vars) CALL section_vals_val_get(efield_section,"INTENSITY",i_rep_section=i, & - r_val=efield%strength,error=error) + r_val=efield%strength) CALL section_vals_val_get(efield_section,"POLARISATION",i_rep_section=i, & - r_vals=tmp_vals,error=error) + r_vals=tmp_vals) ALLOCATE(efield%polarisation(SIZE(tmp_vals)),stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) efield%polarisation = tmp_vals CALL section_vals_val_get(efield_section,"PHASE",i_rep_section=i, & - r_val=efield%phase_offset,error=error) + r_val=efield%phase_offset) CALL section_vals_val_get(efield_section,"ENVELOP",i_rep_section=i, & - i_val=efield%envelop_id,error=error) + i_val=efield%envelop_id) CALL section_vals_val_get(efield_section,"WAVELENGTH",i_rep_section=i, & - r_val=efield%wavelength,error=error) + r_val=efield%wavelength) IF(efield%envelop_id==constant_env)THEN ALLOCATE(efield%envelop_i_vars(2),stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - tmp_section => section_vals_get_subs_vals(efield_section,"CONSTANT_ENV",i_rep_section=i,error=error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + tmp_section => section_vals_get_subs_vals(efield_section,"CONSTANT_ENV",i_rep_section=i) CALL section_vals_val_get(tmp_section,"START_STEP", & - i_val=efield%envelop_i_vars(1),error=error) + i_val=efield%envelop_i_vars(1)) CALL section_vals_val_get(tmp_section,"END_STEP", & - i_val=efield%envelop_i_vars(2),error=error) + i_val=efield%envelop_i_vars(2)) END IF IF(efield%envelop_id==gaussian_env)THEN ALLOCATE(efield%envelop_r_vars(2),stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - tmp_section => section_vals_get_subs_vals(efield_section,"GAUSSIAN_ENV",i_rep_section=i,error=error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + tmp_section => section_vals_get_subs_vals(efield_section,"GAUSSIAN_ENV",i_rep_section=i) CALL section_vals_val_get(tmp_section,"T0", & - r_val=efield%envelop_r_vars(1),error=error) + r_val=efield%envelop_r_vars(1)) CALL section_vals_val_get(tmp_section,"SIGMA", & - r_val=efield%envelop_r_vars(2),error=error) + r_val=efield%envelop_r_vars(2)) END IF IF(efield%envelop_id==ramp_env)THEN ALLOCATE(efield%envelop_i_vars(4),stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - tmp_section => section_vals_get_subs_vals(efield_section,"CONSTANT_ENV",i_rep_section=i,error=error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + tmp_section => section_vals_get_subs_vals(efield_section,"CONSTANT_ENV",i_rep_section=i) CALL section_vals_val_get(tmp_section,"START_STEP_IN", & - i_val=efield%envelop_i_vars(1),error=error) + i_val=efield%envelop_i_vars(1)) CALL section_vals_val_get(tmp_section,"END_STEP_IN", & - i_val=efield%envelop_i_vars(2),error=error) + i_val=efield%envelop_i_vars(2)) CALL section_vals_val_get(tmp_section,"START_STEP_OUT", & - i_val=efield%envelop_i_vars(3),error=error) + i_val=efield%envelop_i_vars(3)) CALL section_vals_val_get(tmp_section,"END_STEP_OUT", & - i_val=efield%envelop_i_vars(4),error=error) + i_val=efield%envelop_i_vars(4)) END IF END DO END SUBROUTINE read_efield_sections @@ -1941,14 +1898,12 @@ END SUBROUTINE read_efield_sections !> \brief reads the input parameters needed real time propagation !> \param dft_control ... !> \param rtp_section ... -!> \param error ... !> \author fschiff ! ***************************************************************************** - SUBROUTINE read_rtp_section(dft_control,rtp_section,error) + SUBROUTINE read_rtp_section(dft_control,rtp_section) TYPE(dft_control_type), INTENT(INOUT) :: dft_control TYPE(section_vals_type), POINTER :: rtp_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_rtp_section', & routineP = moduleN//':'//routineN @@ -1959,44 +1914,44 @@ SUBROUTINE read_rtp_section(dft_control,rtp_section,error) failure=.FALSE. ALLOCATE(dft_control%rtp_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL section_vals_val_get(rtp_section,"MAX_ITER",& - i_val=dft_control%rtp_control%max_iter,error=error) + i_val=dft_control%rtp_control%max_iter) CALL section_vals_val_get(rtp_section,"MAT_EXP",& - i_val=dft_control%rtp_control%mat_exp,error=error) + i_val=dft_control%rtp_control%mat_exp) CALL section_vals_val_get(rtp_section,"ASPC_ORDER",& - i_val=dft_control%rtp_control%aspc_order,error=error) + i_val=dft_control%rtp_control%aspc_order) CALL section_vals_val_get(rtp_section,"EXP_ACCURACY",& - r_val=dft_control%rtp_control%eps_exp,error=error) + r_val=dft_control%rtp_control%eps_exp) CALL section_vals_val_get(rtp_section,"PROPAGATOR",& - i_val=dft_control%rtp_control%propagator,error=error) + i_val=dft_control%rtp_control%propagator) CALL section_vals_val_get(rtp_section,"EPS_ITER",& - r_val=dft_control%rtp_control%eps_ener,error=error) + r_val=dft_control%rtp_control%eps_ener) CALL section_vals_val_get(rtp_section,"INITIAL_WFN",& - i_val=dft_control%rtp_control%initial_wfn,error=error) + i_val=dft_control%rtp_control%initial_wfn) CALL section_vals_val_get(rtp_section,"HFX_BALANCE_IN_CORE",& - l_val=dft_control%rtp_control%hfx_redistribute,error=error) + l_val=dft_control%rtp_control%hfx_redistribute) CALL section_vals_val_get(rtp_section,"APPLY_DELTA_PULSE",& - l_val=dft_control%rtp_control%apply_delta_pulse,error=error) + l_val=dft_control%rtp_control%apply_delta_pulse) CALL section_vals_val_get(rtp_section,"PERIODIC",& - l_val=dft_control%rtp_control%periodic,error=error) + l_val=dft_control%rtp_control%periodic) CALL section_vals_val_get(rtp_section,"DENSITY_PROPAGATION",& - l_val=dft_control%rtp_control%linear_scaling,error=error) + l_val=dft_control%rtp_control%linear_scaling) CALL section_vals_val_get(rtp_section,"ORTHONORMAL",& - l_val=dft_control%rtp_control%orthonormal,error=error) + l_val=dft_control%rtp_control%orthonormal) CALL section_vals_val_get(rtp_section,"MCWEENY_MAX_ITER",& - i_val=dft_control%rtp_control%mcweeny_max_iter,error=error) + i_val=dft_control%rtp_control%mcweeny_max_iter) CALL section_vals_val_get(rtp_section,"ACCURACY_REFINEMENT",& - i_val=dft_control%rtp_control%acc_ref,error=error) + i_val=dft_control%rtp_control%acc_ref) CALL section_vals_val_get(rtp_section,"MCWEENY_EPS",& - r_val=dft_control%rtp_control%mcweeny_eps,error=error) + r_val=dft_control%rtp_control%mcweeny_eps) CALL section_vals_val_get(rtp_section,"DELTA_PULSE_SCALE",& - r_val=dft_control%rtp_control%delta_pulse_scale,error=error) + r_val=dft_control%rtp_control%delta_pulse_scale) CALL section_vals_val_get(rtp_section,"DELTA_PULSE_DIRECTION",& - i_vals=tmp,error=error) + i_vals=tmp) dft_control%rtp_control%delta_pulse_direction=tmp CALL section_vals_val_get(rtp_section,"SC_CHECK_START",& - i_val=dft_control%rtp_control%sc_check_start,error=error) + i_val=dft_control%rtp_control%sc_check_start) END SUBROUTINE read_rtp_section @@ -2004,12 +1959,10 @@ END SUBROUTINE read_rtp_section !> \brief Parses the BLOCK_LIST keywords from the ADMM section !> \param admm_control ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_admm_block_list(admm_control, dft_section, error) + SUBROUTINE read_admm_block_list(admm_control, dft_section) TYPE(admm_control_type), POINTER :: admm_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_admm_block_list', & routineP = moduleN//':'//routineN @@ -2020,13 +1973,13 @@ SUBROUTINE read_admm_block_list(admm_control, dft_section, error) NULLIFY(tmplist) CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%BLOCK_LIST",& - n_rep_val=n_rep, error=error) + n_rep_val=n_rep) ALLOCATE(admm_control%blocks(n_rep)) DO irep = 1, n_rep CALL section_vals_val_get(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD%BLOCK_LIST",& - i_rep_val=irep, i_vals=tmplist, error=error) + i_rep_val=irep, i_vals=tmplist) list_size = SIZE(tmplist) ALLOCATE(admm_control%blocks(irep)%list(list_size)) admm_control%blocks(irep)%list(:) = tmplist(:) diff --git a/src/cp_dbcsr_cholesky.F b/src/cp_dbcsr_cholesky.F index 80dcda39a2..60352b3e43 100644 --- a/src/cp_dbcsr_cholesky.F +++ b/src/cp_dbcsr_cholesky.F @@ -51,19 +51,16 @@ MODULE cp_dbcsr_cholesky !> (defaults to the min(size(matrix))) !> \param para_env ... !> \param blacs_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [JVdV] !> 12.2002 updated, added n optional parm [fawzi] !> \author Joost ! ***************************************************************************** - SUBROUTINE cp_dbcsr_cholesky_decompose(matrix,n,para_env,blacs_env,error) + SUBROUTINE cp_dbcsr_cholesky_decompose(matrix,n,para_env,blacs_env) TYPE(cp_dbcsr_type) :: matrix INTEGER, INTENT(in), OPTIONAL :: n TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_cholesky_decompose', & routineP = moduleN//':'//routineN @@ -88,16 +85,16 @@ SUBROUTINE cp_dbcsr_cholesky_decompose(matrix,n,para_env,blacs_env,error) CALL cp_dbcsr_get_info(matrix,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrix, fm_matrix, error=error) + CALL copy_dbcsr_to_fm(matrix, fm_matrix) my_n = MIN(fm_matrix%matrix_struct%nrow_global,& fm_matrix%matrix_struct%ncol_global) IF (PRESENT(n)) THEN - CPPrecondition(n<=my_n,cp_failure_level,routineP,error,failure) + CPPrecondition(n<=my_n,cp_failure_level,routineP,failure) my_n=n END IF @@ -123,11 +120,11 @@ SUBROUTINE cp_dbcsr_cholesky_decompose(matrix,n,para_env,blacs_env,error) #endif - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) - CALL copy_fm_to_dbcsr(fm_matrix, matrix, error=error) + CALL copy_fm_to_dbcsr(fm_matrix, matrix) - CALL cp_fm_release(fm_matrix, error) + CALL cp_fm_release(fm_matrix) CALL timestop(handle) @@ -140,19 +137,16 @@ END SUBROUTINE cp_dbcsr_cholesky_decompose !> \param para_env ... !> \param blacs_env ... !> \param upper_to_full ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [JVdV] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_dbcsr_cholesky_invert(matrix,n,para_env,blacs_env,upper_to_full,error) + SUBROUTINE cp_dbcsr_cholesky_invert(matrix,n,para_env,blacs_env,upper_to_full) TYPE(cp_dbcsr_type) :: matrix INTEGER, INTENT(in), OPTIONAL :: n TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env LOGICAL, INTENT(IN) :: upper_to_full - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN='dbcsr_cholesky_invert',& routineP=moduleN//':'//routineN @@ -176,16 +170,16 @@ SUBROUTINE cp_dbcsr_cholesky_invert(matrix,n,para_env,blacs_env,upper_to_full,er CALL cp_dbcsr_get_info(matrix,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullrows_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullrows_total,para_env=para_env) + CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrix, fm_matrix, error=error) + CALL copy_dbcsr_to_fm(matrix, fm_matrix) my_n = MIN(fm_matrix%matrix_struct%nrow_global,& fm_matrix%matrix_struct%ncol_global) IF (PRESENT(n)) THEN - CPPrecondition(n<=my_n,cp_failure_level,routineP,error,failure) + CPPrecondition(n<=my_n,cp_failure_level,routineP,failure) my_n=n END IF @@ -212,17 +206,17 @@ SUBROUTINE cp_dbcsr_cholesky_invert(matrix,n,para_env,blacs_env,upper_to_full,er #endif - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) IF(upper_to_full) THEN - CALL cp_fm_create(fm_matrix_tmp,fm_matrix%matrix_struct,name="fm_matrix_tmp",error=error) - CALL cp_fm_upper_to_full(fm_matrix, fm_matrix_tmp, error) - CALL cp_fm_release(fm_matrix_tmp, error) + CALL cp_fm_create(fm_matrix_tmp,fm_matrix%matrix_struct,name="fm_matrix_tmp") + CALL cp_fm_upper_to_full(fm_matrix, fm_matrix_tmp) + CALL cp_fm_release(fm_matrix_tmp) ENDIF - CALL copy_fm_to_dbcsr(fm_matrix, matrix, error=error) + CALL copy_fm_to_dbcsr(fm_matrix, matrix) - CALL cp_fm_release(fm_matrix, error) + CALL cp_fm_release(fm_matrix) CALL timestop(handle) @@ -238,17 +232,14 @@ END SUBROUTINE cp_dbcsr_cholesky_invert !> \param matrixb the cholesky decomposition of matrix B !> \param para_env ... !> \param blacs_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [JVdV] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_dbcsr_cholesky_reduce(matrix,matrixb,para_env,blacs_env,error) + SUBROUTINE cp_dbcsr_cholesky_reduce(matrix,matrixb,para_env,blacs_env) TYPE(cp_dbcsr_type) :: matrix,matrixb TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN='dbcsr_cholesky_reduce',& routineP=moduleN//':'//routineN @@ -272,20 +263,20 @@ SUBROUTINE cp_dbcsr_cholesky_reduce(matrix,matrixb,para_env,blacs_env,error) CALL cp_dbcsr_get_info(matrix,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrix, fm_matrix, error=error) + CALL copy_dbcsr_to_fm(matrix, fm_matrix) CALL cp_dbcsr_get_info(matrixb,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrixb,fm_struct,name="fm_matrixb",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrixb,fm_struct,name="fm_matrixb") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrixb, fm_matrixb, error=error) + CALL copy_dbcsr_to_fm(matrixb, fm_matrixb) n = fm_matrix%matrix_struct%nrow_global itype =1 @@ -306,19 +297,19 @@ SUBROUTINE cp_dbcsr_cholesky_reduce(matrix,matrixb,para_env,blacs_env,error) routineP,& "scale not equal 1 (scale="//cp_to_string(scale)//")"//& CPSourceFileRef,& - error,failure) + failure) #else CALL dsygst(itype,'U',n,a(1,1),n,b(1,1),n,info) #endif - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) - CALL copy_fm_to_dbcsr(fm_matrix, matrix, error=error) + CALL copy_fm_to_dbcsr(fm_matrix, matrix) - CALL cp_fm_release(fm_matrix, error) - CALL cp_fm_release(fm_matrixb, error) + CALL cp_fm_release(fm_matrix) + CALL cp_fm_release(fm_matrixb) CALL timestop(handle) @@ -336,10 +327,9 @@ END SUBROUTINE cp_dbcsr_cholesky_reduce !> \param transa ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa,& - para_env,blacs_env,error) + para_env,blacs_env) TYPE(cp_dbcsr_type) :: matrix,matrixb,matrixout INTEGER, INTENT(IN) :: neig CHARACTER ( LEN = * ), INTENT ( IN ) :: op @@ -347,7 +337,6 @@ SUBROUTINE cp_dbcsr_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: transa TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN='dbcsr_cholesky_restore',& routineP=moduleN//':'//routineN @@ -377,24 +366,24 @@ SUBROUTINE cp_dbcsr_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa CALL cp_dbcsr_get_info(matrix,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix") + CALL cp_fm_struct_release(fm_struct) CALL cp_dbcsr_get_info(matrixb,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrixb,fm_struct,name="fm_matrixb",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrixb,fm_struct,name="fm_matrixb") + CALL cp_fm_struct_release(fm_struct) CALL cp_dbcsr_get_info(matrixout,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrixout,fm_struct,name="fm_matrixout",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrixout,fm_struct,name="fm_matrixout") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrix, fm_matrix, error=error) - CALL copy_dbcsr_to_fm(matrixb, fm_matrixb, error=error) + CALL copy_dbcsr_to_fm(matrix, fm_matrix) + CALL copy_dbcsr_to_fm(matrixb, fm_matrixb) !CALL copy_dbcsr_to_fm(matrixout, fm_matrixout) context => fm_matrix%matrix_struct%context @@ -406,7 +395,7 @@ SUBROUTINE cp_dbcsr_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa cp_failure_level,cp_assertion_failed,routineP,& "wrong argument op"//& CPSourceFileRef,& - error,failure) + failure) IF (PRESENT(pos)) THEN SELECT CASE(pos) @@ -419,7 +408,7 @@ SUBROUTINE cp_dbcsr_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa cp_failure_level,cp_assertion_failed,routineP,& "wrong argument pos"//& CPSourceFileRef,& - error,failure) + failure) END SELECT ELSE chol_pos='L' @@ -433,7 +422,7 @@ SUBROUTINE cp_dbcsr_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa routineP,& "not the same precision"//& CPSourceFileRef,& - error,failure) + failure) ! notice b is the cholesky guy a => fm_matrix%local_data @@ -495,11 +484,11 @@ SUBROUTINE cp_dbcsr_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa #endif - CALL copy_fm_to_dbcsr(fm_matrixout, matrixout, error=error) + CALL copy_fm_to_dbcsr(fm_matrixout, matrixout) - CALL cp_fm_release(fm_matrix, error) - CALL cp_fm_release(fm_matrixb, error) - CALL cp_fm_release(fm_matrixout, error) + CALL cp_fm_release(fm_matrix) + CALL cp_fm_release(fm_matrixb) + CALL cp_fm_release(fm_matrixout) CALL timestop(handle) diff --git a/src/cp_dbcsr_cp2k_link.F b/src/cp_dbcsr_cp2k_link.F index 864df4b2d4..466c237973 100644 --- a/src/cp_dbcsr_cp2k_link.F +++ b/src/cp_dbcsr_cp2k_link.F @@ -77,11 +77,9 @@ MODULE cp_dbcsr_cp2k_link ! ***************************************************************************** !> \brief Configures options for DBCSR !> \param root_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_config(root_section, error) + SUBROUTINE cp_dbcsr_config(root_section) TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_config', & routineP = moduleN//':'//routineN @@ -101,52 +99,52 @@ SUBROUTINE cp_dbcsr_config(root_section, error) CALL dbcsr_error_set (routineN, error_handle, dbcsr_error) dbcsr_section => section_vals_get_subs_vals(root_section,& - "GLOBAL%DBCSR",error=error) + "GLOBAL%DBCSR") CALL section_vals_val_get(dbcsr_section,& - "mm_stack_size", i_val=mm_ss, error=error) + "mm_stack_size", i_val=mm_ss) CALL section_vals_val_get(dbcsr_section,& - "mm_driver", i_val=mm_driver, error=error) + "mm_driver", i_val=mm_driver) CALL section_vals_val_get(dbcsr_section,& - "MAX_ELEMENTS_PER_BLOCK", i_val=max_ele_block, error=error) + "MAX_ELEMENTS_PER_BLOCK", i_val=max_ele_block) CALL section_vals_val_get(dbcsr_section,& - "avg_elements_images", i_val=avg_elements_images, error=error) + "avg_elements_images", i_val=avg_elements_images) CALL section_vals_val_get(dbcsr_section,& - "n_size_mnk_stacks", i_val=nstacks(1), error=error) + "n_size_mnk_stacks", i_val=nstacks(1)) nstacks(2:3) = nstacks(1) CALL section_vals_val_get(dbcsr_section,& - "use_mpi_filtering", l_val=use_mpi_filtering, error=error) + "use_mpi_filtering", l_val=use_mpi_filtering) CALL section_vals_val_get(dbcsr_section,& - "use_mpi_rma", l_val=use_mpi_rma, error=error) + "use_mpi_rma", l_val=use_mpi_rma) CALL section_vals_val_get(dbcsr_section,& - "use_comm_thread", l_val=use_comm_thread, error=error) + "use_comm_thread", l_val=use_comm_thread) CALL section_vals_val_get(dbcsr_section,& - "comm_thread_load", i_val=comm_thread_load, error=error) + "comm_thread_load", i_val=comm_thread_load) CALL section_vals_val_get(dbcsr_section,& - "multrec_limit", i_val=multrec_limit, error=error) + "multrec_limit", i_val=multrec_limit) CALL section_vals_val_get(dbcsr_section,& - "randmat_seed", i_val=randmat_seed, error=error) + "randmat_seed", i_val=randmat_seed) CALL section_vals_val_get(dbcsr_section,& - "ACC%priority_streams", i_val=accdrv_priority_streams, error=error) + "ACC%priority_streams", i_val=accdrv_priority_streams) CALL section_vals_val_get(dbcsr_section,& - "ACC%priority_buffers", i_val=accdrv_priority_buffers, error=error) + "ACC%priority_buffers", i_val=accdrv_priority_buffers) CALL section_vals_val_get(dbcsr_section,& - "ACC%posterior_streams", i_val=accdrv_posterior_streams, error=error) + "ACC%posterior_streams", i_val=accdrv_posterior_streams) CALL section_vals_val_get(dbcsr_section,& - "ACC%posterior_buffers", i_val=accdrv_posterior_buffers, error=error) + "ACC%posterior_buffers", i_val=accdrv_posterior_buffers) CALL section_vals_val_get(dbcsr_section,& - "ACC%min_flop_process", i_val=accdrv_min_flop_process, error=error) + "ACC%min_flop_process", i_val=accdrv_min_flop_process) CALL section_vals_val_get(dbcsr_section,& - "ACC%min_flop_sort", i_val=accdrv_min_flop_sort, error=error) + "ACC%min_flop_sort", i_val=accdrv_min_flop_sort) CALL section_vals_val_get(dbcsr_section,& - "ACC%process_inhomogenous", l_val=accdrv_do_inhomogenous, error=error) + "ACC%process_inhomogenous", l_val=accdrv_do_inhomogenous) CALL section_vals_val_get(dbcsr_section,& - "ACC%avoid_after_busy", l_val=accdrv_avoid_after_busy, error=error) + "ACC%avoid_after_busy", l_val=accdrv_avoid_after_busy) CALL section_vals_val_get(dbcsr_section,& - "ACC%binning_nbins", i_val=accdrv_binning_nbins, error=error) + "ACC%binning_nbins", i_val=accdrv_binning_nbins) CALL section_vals_val_get(dbcsr_section,& - "ACC%binning_binsize", i_val=accdrv_binning_binsize, error=error) + "ACC%binning_binsize", i_val=accdrv_binning_binsize) CALL dbcsr_set_conf_mm_driver (mm_driver, error=dbcsr_error) CALL dbcsr_set_conf_max_ele_block (max_ele_block, error=dbcsr_error) @@ -169,11 +167,9 @@ END SUBROUTINE cp_dbcsr_config ! ***************************************************************************** !> \brief Prints configuration for DBCSR !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_print_config(unit_nr, error) + SUBROUTINE cp_dbcsr_print_config(unit_nr) INTEGER, INTENT(IN), OPTIONAL :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_print_config', & routineP = moduleN//':'//routineN @@ -184,7 +180,7 @@ SUBROUTINE cp_dbcsr_print_config(unit_nr, error) TYPE(cp_logger_type), POINTER :: logger TYPE(dbcsr_error_type) :: dbcsr_error - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_num = cp_logger_get_default_io_unit(logger) IF (PRESENT (unit_nr)) unit_num=unit_nr @@ -273,7 +269,6 @@ END SUBROUTINE cp_dbcsr_print_config !> \brief allocate the blocks of a dbcsr based on the neighbor list !> \param matrix the matrix !> \param sab_orb the corresponding neighbor list -!> \param error ... !> \par History !> 11.2009 created vw !> 01.2014 moved here from cp_dbcsr_operations (Ole Schuett) @@ -281,12 +276,11 @@ END SUBROUTINE cp_dbcsr_print_config !> \note ! ***************************************************************************** - SUBROUTINE cp_dbcsr_alloc_block_from_nbl(matrix,sab_orb,error) + SUBROUTINE cp_dbcsr_alloc_block_from_nbl(matrix,sab_orb) TYPE(cp_dbcsr_type) :: matrix TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_orb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'cp_dbcsr_alloc_block_from_nbl', & @@ -306,9 +300,9 @@ SUBROUTINE cp_dbcsr_alloc_block_from_nbl(matrix,sab_orb,error) symmetry = cp_dbcsr_get_matrix_type(matrix) - CPPrecondition(ASSOCIATED(sab_orb),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sab_orb),cp_failure_level,routineP,failure) - CALL cp_dbcsr_finalize (matrix, error=error) + CALL cp_dbcsr_finalize (matrix) ALLOCATE (rows(1), cols(1)) blk_cnt = 0 @@ -355,11 +349,10 @@ SUBROUTINE cp_dbcsr_alloc_block_from_nbl(matrix,sab_orb,error) CALL neighbor_list_iterator_release(nl_iterator) ! - CALL cp_dbcsr_reserve_blocks (matrix, rows(1:blk_cnt), cols(1:blk_cnt),& - error=error) + CALL cp_dbcsr_reserve_blocks (matrix, rows(1:blk_cnt), cols(1:blk_cnt)) DEALLOCATE (rows) DEALLOCATE (cols) - CALL cp_dbcsr_finalize( matrix, error=error ) + CALL cp_dbcsr_finalize( matrix) CALL timestop(handle) @@ -376,15 +369,13 @@ END SUBROUTINE cp_dbcsr_alloc_block_from_nbl !> the DBCSR matrix that is used to create the CSR !> matrix. It must have symmetric DBCSR format and !> must not be filtered. -!> \param error ... !> \par History !> 02.2015 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** - SUBROUTINE cp_dbcsr_to_csr_screening(ks_env, csr_sparsity, error) + SUBROUTINE cp_dbcsr_to_csr_screening(ks_env, csr_sparsity) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_type), INTENT(INOUT) :: csr_sparsity - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_to_csr_screening', & routineP = moduleN//':'//routineN @@ -424,30 +415,29 @@ SUBROUTINE cp_dbcsr_to_csr_screening(ks_env, csr_sparsity, error) CALL timeset(routineN,handle) - CPPrecondition(cp_dbcsr_has_symmetry(csr_sparsity),cp_failure_level,routineP,error,failure) + CPPrecondition(cp_dbcsr_has_symmetry(csr_sparsity),cp_failure_level,routineP,failure) CALL get_ks_env(ks_env,& sab_orb=neighbour_list,& atomic_kind_set=atomic_kind_set,& natom=natom,& qs_kind_set=qs_kind_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) eps_pgf_orb = dft_control%qs_control%eps_pgf_orb nkind = SIZE(qs_kind_set) ALLOCATE (atom_of_kind(natom)) CALL get_atomic_kind_set(atomic_kind_set,atom_of_kind=atom_of_kind) - CPPrecondition(SIZE(neighbour_list) > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(neighbour_list) > 0,cp_failure_level,routineP,failure) CALL get_neighbor_list_set_p(neighbor_list_sets=neighbour_list,symmetric=do_symmetric) - CPPrecondition(do_symmetric,cp_failure_level,routineP,error,failure) + CPPrecondition(do_symmetric,cp_failure_level,routineP,failure) ALLOCATE (basis_set_list_a(nkind),basis_set_list_b(nkind)) - CALL basis_set_list_setup(basis_set_list_a,"ORB",qs_kind_set,error=error) - CALL basis_set_list_setup(basis_set_list_b,"ORB",qs_kind_set,error=error) + CALL basis_set_list_setup(basis_set_list_a,"ORB",qs_kind_set) + CALL basis_set_list_setup(basis_set_list_b,"ORB",qs_kind_set) ! csr_sparsity can obtain values 0 (if zero element) or 1 (if non-zero element) - CALL cp_dbcsr_set (csr_sparsity, 0.0, error) + CALL cp_dbcsr_set (csr_sparsity, 0.0) CALL neighbor_list_iterator_create(nl_iterator, neighbour_list) @@ -495,7 +485,7 @@ SUBROUTINE cp_dbcsr_to_csr_screening(ks_env, csr_sparsity, error) CALL cp_dbcsr_get_block_p(matrix=csr_sparsity,row=irow,col=icol, & block=screen_blk,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ! Distance between atoms a and b dab = SQRT(rab(1)**2+rab(2)**2+rab(3)**2) diff --git a/src/cp_dbcsr_diag.F b/src/cp_dbcsr_diag.F index baf1916451..195b7997c3 100644 --- a/src/cp_dbcsr_diag.F +++ b/src/cp_dbcsr_diag.F @@ -61,9 +61,8 @@ MODULE cp_dbcsr_diag !> \param eigenvalues ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_syevd(matrix,eigenvectors,eigenvalues,para_env,blacs_env,error) + SUBROUTINE cp_dbcsr_syevd(matrix,eigenvectors,eigenvalues,para_env,blacs_env) ! Computes all eigenvalues and vectors of a real symmetric matrix ! should be quite a bit faster than syevx for that case @@ -74,7 +73,6 @@ SUBROUTINE cp_dbcsr_syevd(matrix,eigenvectors,eigenvalues,para_env,blacs_env,err REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: eigenvalues TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_syevd', & routineP = moduleN//':'//routineN @@ -92,19 +90,19 @@ SUBROUTINE cp_dbcsr_syevd(matrix,eigenvectors,eigenvalues,para_env,blacs_env,err CALL cp_dbcsr_get_info(matrix,nfullrows_total=nfullrows_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullrows_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) - CALL cp_fm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullrows_total,para_env=para_env) + CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix") + CALL cp_fm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrix, fm_matrix, error=error) + CALL copy_dbcsr_to_fm(matrix, fm_matrix) - CALL choose_eigv_solver(fm_matrix,fm_eigenvectors,eigenvalues,error=error) + CALL choose_eigv_solver(fm_matrix,fm_eigenvectors,eigenvalues) - CALL copy_fm_to_dbcsr(fm_eigenvectors, eigenvectors, error=error) + CALL copy_fm_to_dbcsr(fm_eigenvectors, eigenvectors) - CALL cp_fm_release(fm_matrix, error) - CALL cp_fm_release(fm_eigenvectors, error) + CALL cp_fm_release(fm_matrix) + CALL cp_fm_release(fm_eigenvectors) CALL timestop(handle) @@ -121,14 +119,13 @@ END SUBROUTINE cp_dbcsr_syevd !> \param work_syevx ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... !> \par matrix is supposed to be in upper triangular form, and overwritten by this routine !> neig is the number of vectors needed (default all) !> work_syevx evec calculation only, is the fraction of the working buffer allowed (1.0 use full buffer) !> reducing this saves time, but might cause the routine to fail ! ***************************************************************************** SUBROUTINE cp_dbcsr_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,& - para_env,blacs_env,error) + para_env,blacs_env) ! Diagonalise the symmetric n by n matrix using the LAPACK library. @@ -139,7 +136,6 @@ SUBROUTINE cp_dbcsr_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,& REAL(KIND=dp), INTENT(IN), OPTIONAL :: work_syevx TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_syevx', & routineP = moduleN//':'//routineN @@ -158,20 +154,20 @@ SUBROUTINE cp_dbcsr_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,& NULLIFY(fm_matrix, fm_eigenvectors, fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=n,& - ncol_global=n,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) + ncol_global=n,para_env=para_env) + CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix") IF(PRESENT(eigenvectors)) THEN - CALL cp_fm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors",error=error) - CALL cp_fm_syevx(fm_matrix,fm_eigenvectors,eigenvalues,neig,work_syevx,error) - CALL copy_fm_to_dbcsr(fm_eigenvectors, eigenvectors, error=error) - CALL cp_fm_release(fm_eigenvectors, error) + CALL cp_fm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors") + CALL cp_fm_syevx(fm_matrix,fm_eigenvectors,eigenvalues,neig,work_syevx) + CALL copy_fm_to_dbcsr(fm_eigenvectors, eigenvectors) + CALL cp_fm_release(fm_eigenvectors) ELSE - CALL cp_fm_syevx(fm_matrix,eigenvalues=eigenvalues,neig=neig,work_syevx=work_syevx,error=error) + CALL cp_fm_syevx(fm_matrix,eigenvalues=eigenvalues,neig=neig,work_syevx=work_syevx) ENDIF - CALL cp_fm_struct_release(fm_struct,error=error) - CALL cp_fm_release(fm_matrix, error) + CALL cp_fm_struct_release(fm_struct) + CALL cp_fm_release(fm_matrix) CALL timestop(handle) @@ -189,12 +185,11 @@ END SUBROUTINE cp_dbcsr_syevx !> \param iup ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... !> \par matrix is supposed to be in upper triangular form, and overwritten by this routine !> subsets of eigenvalues/vectors can be selected by !> specifying a range of values or a range of indices for the desired eigenvalues. ! ***************************************************************************** - SUBROUTINE cp_dbcsr_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,para_env,blacs_env,error) + SUBROUTINE cp_dbcsr_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,para_env,blacs_env) TYPE(cp_dbcsr_type), POINTER :: matrix TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: eigenvectors @@ -202,7 +197,6 @@ SUBROUTINE cp_dbcsr_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,para_env,blac INTEGER, INTENT(IN), OPTIONAL :: ilow, iup TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_syevr', & routineP = moduleN//':'//routineN @@ -217,19 +211,18 @@ SUBROUTINE cp_dbcsr_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,para_env,blac CALL cp_dbcsr_get_info(matrix,nfullrows_total=n) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=n,& - ncol_global=n,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) - CALL cp_fm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=n,para_env=para_env) + CALL cp_fm_create(fm_matrix,fm_struct,name="fm_matrix") + CALL cp_fm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrix, fm_matrix, error=error) + CALL copy_dbcsr_to_fm(matrix, fm_matrix) - CALL cp_fm_syevr(fm_matrix,fm_eigenvectors,eigenvalues,ilow,iup,error) + CALL cp_fm_syevr(fm_matrix,fm_eigenvectors,eigenvalues,ilow,iup) - IF(PRESENT(eigenvectors)) CALL copy_fm_to_dbcsr(fm_eigenvectors, eigenvectors, & - error=error) - IF(PRESENT(eigenvectors)) CALL cp_fm_release(fm_eigenvectors, error) - CALL cp_fm_release(fm_matrix, error) + IF(PRESENT(eigenvectors)) CALL copy_fm_to_dbcsr(fm_eigenvectors, eigenvectors) + IF(PRESENT(eigenvectors)) CALL cp_fm_release(fm_eigenvectors) + CALL cp_fm_release(fm_matrix) CALL timestop(handle) @@ -242,16 +235,14 @@ END SUBROUTINE cp_dbcsr_syevr !> \param eigenvalues ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_heevd(matrix,eigenvectors,eigenvalues,para_env,blacs_env,error) + SUBROUTINE cp_dbcsr_heevd(matrix,eigenvectors,eigenvalues,para_env,blacs_env) TYPE(cp_dbcsr_type) :: matrix TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: eigenvectors REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: eigenvalues TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_heevd', & routineP = moduleN//':'//routineN @@ -269,19 +260,19 @@ SUBROUTINE cp_dbcsr_heevd(matrix,eigenvectors,eigenvalues,para_env,blacs_env,err CALL cp_dbcsr_get_info(matrix,nfullrows_total=nfullrows_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullrows_total,para_env=para_env,error=error) - CALL cp_cfm_create(fm_matrix,fm_struct,name="fm_matrix",error=error) - CALL cp_cfm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullrows_total,para_env=para_env) + CALL cp_cfm_create(fm_matrix,fm_struct,name="fm_matrix") + CALL cp_cfm_create(fm_eigenvectors,fm_struct,name="fm_eigenvectors") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_cfm(matrix, fm_matrix, error=error) + CALL copy_dbcsr_to_cfm(matrix, fm_matrix) - CALL cp_cfm_heevd(fm_matrix,fm_eigenvectors,eigenvalues,error) + CALL cp_cfm_heevd(fm_matrix,fm_eigenvectors,eigenvalues) - CALL copy_cfm_to_dbcsr(fm_eigenvectors, eigenvectors, error=error) + CALL copy_cfm_to_dbcsr(fm_eigenvectors, eigenvectors) - CALL cp_cfm_release(fm_matrix, error) - CALL cp_cfm_release(fm_eigenvectors, error) + CALL cp_cfm_release(fm_matrix) + CALL cp_cfm_release(fm_eigenvectors) CALL timestop(handle) diff --git a/src/cp_dbcsr_operations.F b/src/cp_dbcsr_operations.F index 132b14ebfe..1199202035 100644 --- a/src/cp_dbcsr_operations.F +++ b/src/cp_dbcsr_operations.F @@ -105,11 +105,10 @@ MODULE cp_dbcsr_operations !> \param target_start ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... !> \author vw ! ***************************************************************************** SUBROUTINE cp_dbcsr_copy_columns_hack(matrix_b, matrix_a,& - ncol, source_start, target_start, para_env, blacs_env, error) + ncol, source_start, target_start, para_env, blacs_env) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_b TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a @@ -117,7 +116,6 @@ SUBROUTINE cp_dbcsr_copy_columns_hack(matrix_b, matrix_a,& target_start TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_copy_columns_hack', & routineP = moduleN//':'//routineN @@ -130,25 +128,25 @@ SUBROUTINE cp_dbcsr_copy_columns_hack(matrix_b, matrix_a,& NULLIFY(fm_matrix_a, fm_matrix_b, fm_struct) CALL cp_dbcsr_get_info(matrix_a,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix_a,fm_struct,name="fm_matrix_a",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrix_a,fm_struct,name="fm_matrix_a") + CALL cp_fm_struct_release(fm_struct) CALL cp_dbcsr_get_info(matrix_b,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix_b,fm_struct,name="fm_matrix_b",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrix_b,fm_struct,name="fm_matrix_b") + CALL cp_fm_struct_release(fm_struct) - CALL copy_dbcsr_to_fm(matrix_a, fm_matrix_a, error=error) - CALL copy_dbcsr_to_fm(matrix_b, fm_matrix_b, error=error) + CALL copy_dbcsr_to_fm(matrix_a, fm_matrix_a) + CALL copy_dbcsr_to_fm(matrix_b, fm_matrix_b) CALL cp_fm_to_fm(fm_matrix_a, fm_matrix_b, ncol, source_start, target_start) - CALL copy_fm_to_dbcsr(fm_matrix_b, matrix_b, error=error) + CALL copy_fm_to_dbcsr(fm_matrix_b, matrix_b) - CALL cp_fm_release(fm_matrix_a, error=error) - CALL cp_fm_release(fm_matrix_b, error=error) + CALL cp_fm_release(fm_matrix_a) + CALL cp_fm_release(fm_matrix_b) END SUBROUTINE cp_dbcsr_copy_columns_hack @@ -158,18 +156,16 @@ END SUBROUTINE cp_dbcsr_copy_columns_hack !> \param[in] dist2d distribution_2d !> \param[out] dist DBCSR distribution !> \param unit_nr ... -!> \param[in,out] error cp2k error !> \param mp_obj ... !> \par History !> move form dbcsr_operation 01.2010 ! ***************************************************************************** - SUBROUTINE cp_dbcsr_dist2d_to_dist(dist2d, dist, unit_nr, error, mp_obj) + SUBROUTINE cp_dbcsr_dist2d_to_dist(dist2d, dist, unit_nr,mp_obj) TYPE(distribution_2d_type), INTENT(IN), & TARGET :: dist2d TYPE(dbcsr_distribution_obj), & INTENT(OUT) :: dist INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error TYPE(dbcsr_mp_obj), INTENT(IN), OPTIONAL :: mp_obj INTEGER :: mypcol, myproc, myprow, & @@ -185,7 +181,7 @@ SUBROUTINE cp_dbcsr_dist2d_to_dist(dist2d, dist, unit_nr, error, mp_obj) ! --------------------------------------------------------------------------- dist2d_p => dist2d - CALL distribution_2d_get(dist2d_p, error=error,& + CALL distribution_2d_get(dist2d_p,& row_distribution=row_dist_data, col_distribution=col_dist_data,& blacs_env=blacs_env) CALL get_blacs_info(blacs_env, para_env=para_env,& @@ -213,15 +209,13 @@ END SUBROUTINE cp_dbcsr_dist2d_to_dist !> \param[in] ncol nbr of columns !> \param[in] alpha alpha !> -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_multiply_local_d(matrix_a, vec_b, vec_c, ncol, alpha, error) + SUBROUTINE cp_dbcsr_multiply_local_d(matrix_a, vec_b, vec_c, ncol, alpha) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a REAL(dp), DIMENSION(:, :), INTENT(IN) :: vec_b REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: vec_c INTEGER, INTENT(in), OPTIONAL :: ncol REAL(dp), INTENT(IN), OPTIONAL :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_multiply_local_d', & routineP = moduleN//':'//routineN @@ -304,9 +298,8 @@ END SUBROUTINE cp_dbcsr_multiply_local_d !> \param vec_c ... !> \param ncol ... !> \param alpha ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_multiply_local_s(matrix_a, vec_b, vec_c, ncol, alpha, error) + SUBROUTINE cp_dbcsr_multiply_local_s(matrix_a, vec_b, vec_c, ncol, alpha) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a REAL(KIND=real_4), DIMENSION(:, :), & INTENT(IN) :: vec_b @@ -314,7 +307,6 @@ SUBROUTINE cp_dbcsr_multiply_local_s(matrix_a, vec_b, vec_c, ncol, alpha, error) INTENT(INOUT) :: vec_c INTEGER, INTENT(in), OPTIONAL :: ncol REAL(KIND=real_4), INTENT(IN), OPTIONAL :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_multiply_local_s', & routineP = moduleN//':'//routineN @@ -382,14 +374,12 @@ END SUBROUTINE cp_dbcsr_multiply_local_s !> \param[in] alpha alpha !> \param[in] beta beta !> -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta, error) + SUBROUTINE cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix TYPE(cp_fm_type), POINTER :: fm_in, fm_out INTEGER, INTENT(IN) :: ncol REAL(dp), INTENT(IN), OPTIONAL :: alpha, beta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_sm_fm_multiply', & routineP = moduleN//':'//routineN @@ -409,9 +399,9 @@ SUBROUTINE cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta, err IF (PRESENT(alpha)) my_alpha=alpha IF (PRESENT(beta)) my_beta=beta - CALL cp_fm_get_info(fm_out, ncol_global=k_out, error=error) + CALL cp_fm_get_info(fm_out, ncol_global=k_out) - CALL cp_fm_get_info(fm_in, ncol_global=k_in, error=error) + CALL cp_fm_get_info(fm_in, ncol_global=k_in) !write(*,*)routineN//" -----------------------------------" !IF (k_in .NE. k_out) & ! WRITE(*,'(3(A,I5,1X),2(A,F5.2,1X))')& @@ -422,12 +412,12 @@ SUBROUTINE cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta, err CALL dbcsr_create_dist_r_unrot (dist_right_in, cp_dbcsr_distribution(matrix), k_in, & col_blk_size_right_in) - CALL cp_dbcsr_init(in, error) + CALL cp_dbcsr_init(in) CALL cp_dbcsr_create(in, "D", dist_right_in, dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(matrix), col_blk_size_right_in,& - nze=0, error=error) + nze=0) - CALL cp_dbcsr_init(out, error) + CALL cp_dbcsr_init(out) CALL cp_dbcsr_distribution_new (product_dist,& dbcsr_distribution_mp (cp_dbcsr_distribution(matrix)),& dbcsr_distribution_row_dist (cp_dbcsr_distribution(matrix)),& @@ -445,21 +435,21 @@ SUBROUTINE cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta, err CALL cp_dbcsr_create(out, "D", product_dist, dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(matrix), col_blk_size_right_out,& - nze=0, error=error) + nze=0) - CALL copy_fm_to_dbcsr(fm_in, in, error=error) + CALL copy_fm_to_dbcsr(fm_in, in) IF(ncol.NE.k_out.OR.my_beta.NE.0.0_dp) & - CALL copy_fm_to_dbcsr(fm_out, out, error=error) + CALL copy_fm_to_dbcsr(fm_out, out) CALL timeset(routineN//'_core', timing_handle_mult) CALL cp_dbcsr_multiply("N", "N", my_alpha, matrix, in, my_beta, out,& - last_column=ncol, match_matrix_sizes=.TRUE., error=error) + last_column=ncol, match_matrix_sizes=.TRUE.) CALL timestop(timing_handle_mult) - CALL copy_dbcsr_to_fm(out, fm_out,error) + CALL copy_dbcsr_to_fm(out, fm_out) - CALL cp_dbcsr_release(in, error=error) - CALL cp_dbcsr_release(out, error=error) + CALL cp_dbcsr_release(in) + CALL cp_dbcsr_release(out) DEALLOCATE(col_blk_size_right_in,col_blk_size_right_out) CALL dbcsr_distribution_release(dist_right_in) CALL dbcsr_distribution_release(product_dist) @@ -517,17 +507,15 @@ END SUBROUTINE match_col_sizes !> \param alpha ... !> \param keep_sparsity Determines if the sparsity of sparse_matrix is retained !> by default it is TRUE -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_plus_fm_fm_t_native(sparse_matrix,matrix_v,matrix_g,ncol,& - alpha,keep_sparsity,error) + alpha,keep_sparsity) TYPE(cp_dbcsr_type), INTENT(INOUT) :: sparse_matrix TYPE(cp_fm_type), POINTER :: matrix_v TYPE(cp_fm_type), OPTIONAL, POINTER :: matrix_g INTEGER, INTENT(IN) :: ncol REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_plus_fm_fm_t_native', & routineP = moduleN//':'//routineN @@ -556,10 +544,10 @@ SUBROUTINE cp_dbcsr_plus_fm_fm_t_native(sparse_matrix,matrix_v,matrix_g,ncol,& IF (ncol .GT. 0) THEN CALL cp_assert (cp_dbcsr_valid_index (sparse_matrix), cp_fatal_level,& - cp_caller_error, routineN, "sparse_matrix must pre-exist", error) + cp_caller_error, routineN, "sparse_matrix must pre-exist") ! ! Setup matrix_v - CALL cp_fm_get_info(matrix_v, ncol_global=k, error=error) + CALL cp_fm_get_info(matrix_v, ncol_global=k) !WRITE(*,*)routineN//'truncated mult k, ncol',k,ncol,' PRESENT (matrix_g)',PRESENT (matrix_g) mp = dbcsr_distribution_mp (cp_dbcsr_distribution(sparse_matrix)) CALL cp_create_bl_distribution (col_dist_left, col_blk_size_left,& @@ -571,22 +559,22 @@ SUBROUTINE cp_dbcsr_plus_fm_fm_t_native(sparse_matrix,matrix_v,matrix_g,ncol,& dbcsr_distribution_row_clusters(cp_dbcsr_distribution(sparse_matrix)),& col_dist_cluster) DEALLOCATE(col_dist_left) - CALL cp_dbcsr_init (mat_v, error) + CALL cp_dbcsr_init (mat_v) CALL cp_dbcsr_create(mat_v, "DBCSR matrix_v", dist_left, dbcsr_type_no_symmetry,& cp_dbcsr_row_block_sizes (sparse_matrix), col_blk_size_left, nze=0,& - data_type=cp_dbcsr_get_data_type (sparse_matrix), error=error) - CALL copy_fm_to_dbcsr(matrix_v, mat_v, error=error) - CALL cp_dbcsr_verify_matrix(mat_v, error) + data_type=cp_dbcsr_get_data_type (sparse_matrix)) + CALL copy_fm_to_dbcsr(matrix_v, mat_v) + CALL cp_dbcsr_verify_matrix(mat_v) ! ! Setup matrix_g IF(PRESENT (matrix_g)) THEN - CALL cp_dbcsr_init(mat_g, error) + CALL cp_dbcsr_init(mat_g) CALL cp_dbcsr_create(mat_g, "DBCSR matrix_g", dist_left,& dbcsr_type_no_symmetry,& cp_dbcsr_row_block_sizes (sparse_matrix),& cp_dbcsr_col_block_sizes (mat_v),& - data_type=cp_dbcsr_get_data_type (sparse_matrix), error=error) - CALL copy_fm_to_dbcsr(matrix_g, mat_g, error=error) + data_type=cp_dbcsr_get_data_type (sparse_matrix)) + CALL copy_fm_to_dbcsr(matrix_g, mat_g) ENDIF ! DEALLOCATE (col_blk_size_left) @@ -595,14 +583,14 @@ SUBROUTINE cp_dbcsr_plus_fm_fm_t_native(sparse_matrix,matrix_v,matrix_g,ncol,& ! IF(check_product) THEN NULLIFY(fm_matrix) - CALL cp_fm_get_info(matrix_v,nrow_global=nao,error=error) + CALL cp_fm_get_info(matrix_v,nrow_global=nao) CALL cp_fm_struct_create(fm_struct_tmp,context=matrix_v%matrix_struct%context,nrow_global=nao,& - ncol_global=nao,para_env=matrix_v%matrix_struct%para_env,error=error) - CALL cp_fm_create(fm_matrix,fm_struct_tmp,name="fm matrix",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL copy_dbcsr_to_fm(sparse_matrix,fm_matrix, error=error) - CALL cp_dbcsr_init(sparse_matrix3, error) - CALL cp_dbcsr_copy(sparse_matrix3,sparse_matrix,error=error) + ncol_global=nao,para_env=matrix_v%matrix_struct%para_env) + CALL cp_fm_create(fm_matrix,fm_struct_tmp,name="fm matrix") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL copy_dbcsr_to_fm(sparse_matrix,fm_matrix) + CALL cp_dbcsr_init(sparse_matrix3) + CALL cp_dbcsr_copy(sparse_matrix3,sparse_matrix) ENDIF ! my_alpha = 1.0_dp @@ -611,33 +599,31 @@ SUBROUTINE cp_dbcsr_plus_fm_fm_t_native(sparse_matrix,matrix_v,matrix_g,ncol,& CALL cp_dbcsr_multiply("N", "T", my_alpha, mat_v, mat_g,& 1.0_dp, sparse_matrix,& retain_sparsity=my_keep_sparsity,& - last_k = ncol,& - error=error) + last_k = ncol) ELSE CALL cp_dbcsr_multiply("N", "T", my_alpha, mat_v, mat_v,& 1.0_dp, sparse_matrix,& retain_sparsity=my_keep_sparsity,& - last_k = ncol,& - error=error) + last_k = ncol) ENDIF IF(check_product) THEN IF(PRESENT (matrix_g)) THEN CALL cp_fm_gemm("N","T",nao,nao,ncol,my_alpha,matrix_v,matrix_g,& - 1.0_dp,fm_matrix,error=error) + 1.0_dp,fm_matrix) ELSE CALL cp_fm_gemm("N","T",nao,nao,ncol,my_alpha,matrix_v,matrix_v,& - 1.0_dp,fm_matrix,error=error) + 1.0_dp,fm_matrix) ENDIF - CALL cp_dbcsr_init(sparse_matrix2, error) - CALL cp_dbcsr_copy(sparse_matrix2,sparse_matrix,error=error) - CALL cp_dbcsr_scale(sparse_matrix2,alpha_scalar=0.0_dp,error=error) - CALL copy_fm_to_dbcsr(fm_matrix,sparse_matrix2,keep_sparsity=my_keep_sparsity, error=error) + CALL cp_dbcsr_init(sparse_matrix2) + CALL cp_dbcsr_copy(sparse_matrix2,sparse_matrix) + CALL cp_dbcsr_scale(sparse_matrix2,alpha_scalar=0.0_dp) + CALL copy_fm_to_dbcsr(fm_matrix,sparse_matrix2,keep_sparsity=my_keep_sparsity) CALL cp_dbcsr_add(sparse_matrix2,sparse_matrix,alpha_scalar=1.0_dp,& - beta_scalar=-1.0_dp,error=error) + beta_scalar=-1.0_dp) CALL cp_dbcsr_norm(sparse_matrix2,which_norm=dbcsr_norm_frobenius,& - norm_scalar=norm,error=error) + norm_scalar=norm) WRITE(*,*) 'nao=',nao,' k=',k,' ncol=',ncol,' my_alpha=',my_alpha WRITE(*,*) 'PRESENT (matrix_g)',PRESENT (matrix_g) WRITE(*,*) 'matrix_type=',cp_dbcsr_get_matrix_type(sparse_matrix) @@ -661,12 +647,12 @@ SUBROUTINE cp_dbcsr_plus_fm_fm_t_native(sparse_matrix,matrix_v,matrix_g,ncol,& !CALL cp_dbcsr_print(sparse_matrix3,matlab_format=.TRUE.) !stop ENDIF - CALL cp_dbcsr_release(sparse_matrix2, error=error) - CALL cp_dbcsr_release(sparse_matrix3, error=error) - CALL cp_fm_release(fm_matrix,error=error) + CALL cp_dbcsr_release(sparse_matrix2) + CALL cp_dbcsr_release(sparse_matrix3) + CALL cp_fm_release(fm_matrix) ENDIF - CALL cp_dbcsr_release (mat_v, error=error) - IF(PRESENT (matrix_g)) CALL cp_dbcsr_release (mat_g, error=error) + CALL cp_dbcsr_release (mat_v) + IF(PRESENT (matrix_g)) CALL cp_dbcsr_release (mat_g) ENDIF CALL timestop(timing_handle) @@ -683,19 +669,17 @@ END SUBROUTINE cp_dbcsr_plus_fm_fm_t_native !> \param[in] beta (optional) scaling of existing SM !> \param[in] keep_sparsity (optional) retains the sparsity of the input !> matrix -!> \param error ... !> \date 2009-10-13 !> \par History !> 2009-10-13 rewritten based on copy_dbcsr_to_fm !> \author Urban Borstnik !> \version 2.0 ! ***************************************************************************** - SUBROUTINE copy_fm_to_dbcsr(fm,matrix,alpha,beta,keep_sparsity,error) + SUBROUTINE copy_fm_to_dbcsr(fm,matrix,alpha,beta,keep_sparsity) TYPE(cp_fm_type), POINTER :: fm TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix REAL(kind=dp), INTENT(IN), OPTIONAL :: alpha, beta LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'copy_fm_to_dbcsr', & routineP = moduleN//':'//routineN @@ -762,10 +746,10 @@ SUBROUTINE copy_fm_to_dbcsr(fm,matrix,alpha,beta,keep_sparsity,error) row_blk_size, col_blk_size) ! block-cyclic row/col sizes ! Create the block-cyclic DBCSR matrix - CALL cp_dbcsr_init (bc_mat, error) + CALL cp_dbcsr_init (bc_mat) CALL cp_dbcsr_create (bc_mat, "Block-cyclic "//cp_dbcsr_name(matrix), bc_dist,& cp_dbcsr_get_matrix_type(matrix), row_blk_size, col_blk_size, nze=0,& - reuse_arrays=.TRUE., data_type=cp_dbcsr_get_data_type(matrix),error=error) + reuse_arrays=.TRUE., data_type=cp_dbcsr_get_data_type(matrix)) !call dbcsr_finalize (bc_mat) CALL dbcsr_distribution_release (bc_dist) @@ -812,7 +796,7 @@ SUBROUTINE copy_fm_to_dbcsr(fm,matrix,alpha,beta,keep_sparsity,error) CALL cp_dbcsr_work_create (bc_mat, nblks_guess=nblkrows_local*nblkcols_local,& sizedata_guess=nfullrows_local*nfullcols_local, work_mutable=.FALSE.,& - n=1, error=error) + n=1) blk_p = 1 bc_rows: DO row_l = 1, nblkrows_local row = local_rows (row_l) @@ -850,16 +834,16 @@ SUBROUTINE copy_fm_to_dbcsr(fm,matrix,alpha,beta,keep_sparsity,error) ENDDO bc_cols ENDDO bc_rows CALL cp_set_work_size(bc_mat, 1, blk_p - 1) - CALL cp_dbcsr_finalize (bc_mat, reshuffle=.FALSE., error=error) + CALL cp_dbcsr_finalize (bc_mat, reshuffle=.FALSE.) ! Now convert to the desired matrix distribution IF (PRESENT (alpha)) THEN CALL stop_program(routineN,moduleN,__LINE__,'no more alpha... clean me') ELSE CALL cp_dbcsr_complete_redistribute (bc_mat, matrix,& - keep_sparsity=keep_sparsity, error=error) + keep_sparsity=keep_sparsity) ENDIF - CALL cp_dbcsr_release (bc_mat, error=error) + CALL cp_dbcsr_release (bc_mat) CALL timestop(handle) CALL dbcsr_error_stop(error_handler, dbcsr_error) @@ -870,13 +854,11 @@ END SUBROUTINE copy_fm_to_dbcsr !> \param fm ... !> \param bc_mat ... !> \param beta ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_fm_to_dbcsr_bc(fm,bc_mat,beta,error) + SUBROUTINE copy_fm_to_dbcsr_bc(fm,bc_mat,beta) TYPE(cp_fm_type), POINTER :: fm TYPE(cp_dbcsr_type) :: bc_mat REAL(kind=dp), INTENT(IN), OPTIONAL :: beta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'copy_fm_to_dbcsr_bc', & routineP = moduleN//':'//routineN @@ -948,10 +930,10 @@ SUBROUTINE copy_fm_to_dbcsr_bc(fm,bc_mat,beta,error) ! Create the block-cyclic DBCSR matrix data_type=dbcsr_type_real_8 IF(fm%use_sp)data_type=dbcsr_type_real_4 - CALL cp_dbcsr_init (bc_mat, error) + CALL cp_dbcsr_init (bc_mat) CALL cp_dbcsr_create (bc_mat, "Block-cyclic ", bc_dist,& dbcsr_type_no_symmetry, row_blk_size, col_blk_size, nze=0,& - reuse_arrays=.TRUE., data_type=data_type,error=error) + reuse_arrays=.TRUE., data_type=data_type) !call dbcsr_finalize (bc_mat) CALL dbcsr_distribution_release (bc_dist) @@ -1000,7 +982,7 @@ SUBROUTINE copy_fm_to_dbcsr_bc(fm,bc_mat,beta,error) CALL cp_dbcsr_work_create (bc_mat, nblks_guess=nblkrows_local*nblkcols_local,& sizedata_guess=nfullrows_local*nfullcols_local, work_mutable=.FALSE.,& - n=1, error=error) + n=1) blk_p = 1 bc_rows: DO row_l = 1, nblkrows_local row = local_rows (row_l) @@ -1051,7 +1033,7 @@ SUBROUTINE copy_fm_to_dbcsr_bc(fm,bc_mat,beta,error) ENDDO bc_rows1 !$OMP END PARALLEL DO CALL cp_set_work_size(bc_mat, 1, blk_map(nblkrows_local*nblkcols_local) - 1) - CALL cp_dbcsr_finalize (bc_mat, reshuffle=.FALSE., error=error) + CALL cp_dbcsr_finalize (bc_mat, reshuffle=.FALSE.) DEALLOCATE(blk_map) CALL timestop(handle) @@ -1066,18 +1048,16 @@ END SUBROUTINE copy_fm_to_dbcsr_bc !> \param[out] matrix DBCSR matrix !> \param[in] keep_sparsity (optional) retains the sparsity of the input !> matrix -!> \param error ... !> \date 2010 !> \par History !> 2010 copied from copy_dbcsr_to_fm !> \author VW !> \version 2.0 ! ***************************************************************************** - SUBROUTINE copy_cfm_to_dbcsr(fm,matrix,keep_sparsity,error) + SUBROUTINE copy_cfm_to_dbcsr(fm,matrix,keep_sparsity) TYPE(cp_cfm_type), POINTER :: fm TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'copy_cfm_to_dbcsr', & routineP = moduleN//':'//routineN @@ -1135,10 +1115,10 @@ SUBROUTINE copy_cfm_to_dbcsr(fm,matrix,keep_sparsity,error) row_blk_size, col_blk_size) ! block-cyclic row/col sizes ! Create the block-cyclic DBCSR matrix - CALL cp_dbcsr_init (bc_mat, error) + CALL cp_dbcsr_init (bc_mat) CALL cp_dbcsr_create (bc_mat, "Block-cyclic "//cp_dbcsr_name(matrix), bc_dist,& cp_dbcsr_get_matrix_type(matrix), row_blk_size, col_blk_size, nze=0,& - data_type=dbcsr_type_complex_8,reuse_arrays=.TRUE.,error=error) ! type hard coded ! + data_type=dbcsr_type_complex_8,reuse_arrays=.TRUE.) ! type hard coded ! !call dbcsr_finalize (bc_mat) CALL dbcsr_distribution_release (bc_dist) NULLIFY(col_blk_size,row_blk_size) @@ -1182,7 +1162,7 @@ SUBROUTINE copy_cfm_to_dbcsr(fm,matrix,keep_sparsity,error) fm_block => fm%local_data CALL cp_dbcsr_work_create (bc_mat, nblks_guess=nblkrows_local*nblkcols_local,& sizedata_guess=nfullrows_local*nfullcols_local, work_mutable=.FALSE.,& - n=1, error=error) + n=1) blk_p = 1 bc_rows: DO row_l = 1, nblkrows_local row = local_rows (row_l) @@ -1207,12 +1187,11 @@ SUBROUTINE copy_cfm_to_dbcsr(fm,matrix,keep_sparsity,error) ENDDO bc_cols ENDDO bc_rows CALL cp_set_work_size(bc_mat, 1, blk_p - 1) - CALL cp_dbcsr_finalize (bc_mat, reshuffle=.FALSE., error=error) + CALL cp_dbcsr_finalize (bc_mat, reshuffle=.FALSE.) ! Now convert to the desired matrix distribution - CALL cp_dbcsr_complete_redistribute (bc_mat, matrix, keep_sparsity=keep_sparsity,& - error=error) - CALL cp_dbcsr_release (bc_mat, error=error) + CALL cp_dbcsr_complete_redistribute (bc_mat, matrix, keep_sparsity=keep_sparsity) + CALL cp_dbcsr_release (bc_mat) CALL timestop(handle) CALL dbcsr_error_stop(error_handler, dbcsr_error) @@ -1222,12 +1201,10 @@ END SUBROUTINE copy_cfm_to_dbcsr !> \brief Copy a DBCSR matrix to a BLACS matrix !> \param[in] matrix DBCSR matrix !> \param[out] fm full matrix -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_dbcsr_to_fm(matrix, fm, error) + SUBROUTINE copy_dbcsr_to_fm(matrix, fm) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix TYPE(cp_fm_type), POINTER :: fm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'copy_dbcsr_to_fm', & routineP = moduleN//':'//routineN @@ -1284,14 +1261,14 @@ SUBROUTINE copy_dbcsr_to_fm(matrix, fm, error) dbcsr_distribution_mp (cp_dbcsr_distribution(matrix)),& row_blk_size, col_blk_size) - CALL cp_dbcsr_init (bc_mat, error) + CALL cp_dbcsr_init (bc_mat) row_blk_size_tmp => row_blk_size col_blk_size_tmp => col_blk_size CALL cp_dbcsr_create (bc_mat, "Block-cyclic"//cp_dbcsr_name(matrix), bc_dist,& dbcsr_type_no_symmetry, row_blk_size_tmp, col_blk_size_tmp, nze=0, & - reuse_arrays=.TRUE.,error=error) + reuse_arrays=.TRUE.) CALL dbcsr_distribution_release (bc_dist) - CALL cp_dbcsr_complete_redistribute (matrix, bc_mat, error=error) + CALL cp_dbcsr_complete_redistribute (matrix, bc_mat) ! Find the local extents of the local blocked rows so that index lookups ! into the FM matrix work correctly. @@ -1358,7 +1335,7 @@ SUBROUTINE copy_dbcsr_to_fm(matrix, fm, error) ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_release (bc_mat, error=error) + CALL cp_dbcsr_release (bc_mat) CALL dbcsr_error_stop (error_handle, error=dbcsr_error) CALL timestop(handle) @@ -1368,12 +1345,10 @@ END SUBROUTINE copy_dbcsr_to_fm !> \brief Copy a DBCSR matrix to a BLACS matrix !> \param[in] matrix DBCSR matrix !> \param[out] fm full matrix -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_dbcsr_to_cfm(matrix, fm, error) + SUBROUTINE copy_dbcsr_to_cfm(matrix, fm) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix TYPE(cp_cfm_type), POINTER :: fm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'copy_dbcsr_to_cfm', & routineP = moduleN//':'//routineN @@ -1430,14 +1405,14 @@ SUBROUTINE copy_dbcsr_to_cfm(matrix, fm, error) dbcsr_distribution_mp (cp_dbcsr_distribution(matrix)),& row_blk_size, col_blk_size) - CALL cp_dbcsr_init (bc_mat, error) + CALL cp_dbcsr_init (bc_mat) row_blk_size_tmp => row_blk_size col_blk_size_tmp => col_blk_size CALL cp_dbcsr_create (bc_mat, "Block-cyclic"//cp_dbcsr_name(matrix), bc_dist,& dbcsr_type_no_symmetry, row_blk_size_tmp, col_blk_size_tmp, nze=0, data_type=cp_dbcsr_get_data_type(matrix),& - reuse_arrays=.TRUE.,error=error) + reuse_arrays=.TRUE.) CALL dbcsr_distribution_release (bc_dist) - CALL cp_dbcsr_complete_redistribute (matrix, bc_mat, error=error) + CALL cp_dbcsr_complete_redistribute (matrix, bc_mat) ! Find the local extents of the local blocked rows so that index lookups ! into the FM matrix work correctly. @@ -1494,7 +1469,7 @@ SUBROUTINE copy_dbcsr_to_cfm(matrix, fm, error) ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_release (bc_mat, error=error) + CALL cp_dbcsr_release (bc_mat) CALL dbcsr_error_stop (error_handle, error=dbcsr_error) CALL timestop(handle) @@ -1503,12 +1478,10 @@ END SUBROUTINE copy_dbcsr_to_cfm !> \brief Copy a DBCSR_BLACS matrix to a BLACS matrix !> \param bc_mat DBCSR matrix !> \param[out] fm full matrix -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_dbcsr_to_fm_bc(bc_mat, fm, error) + SUBROUTINE copy_dbcsr_to_fm_bc(bc_mat, fm) TYPE(cp_dbcsr_type), INTENT(IN) :: bc_mat TYPE(cp_fm_type), POINTER :: fm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'copy_dbcsr_to_fm_bc', & routineP = moduleN//':'//routineN @@ -1643,13 +1616,11 @@ END SUBROUTINE copy_dbcsr_to_fm_bc !> \param matrix ... !> \param fm_in ... !> \param template ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_to_dbcsr_row_template(matrix, fm_in, template, error) + SUBROUTINE cp_fm_to_dbcsr_row_template(matrix, fm_in, template) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix TYPE(cp_fm_type), POINTER :: fm_in TYPE(cp_dbcsr_type), INTENT(IN) :: template - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_to_dbcsr_row_template', & routineP = moduleN//':'//routineN @@ -1658,16 +1629,16 @@ SUBROUTINE cp_fm_to_dbcsr_row_template(matrix, fm_in, template, error) INTEGER, DIMENSION(:), POINTER :: col_blk_size_right_in TYPE(dbcsr_distribution_obj) :: dist_right_in - CALL cp_fm_get_info(fm_in, ncol_global=k_in, error=error) + CALL cp_fm_get_info(fm_in, ncol_global=k_in) CALL dbcsr_create_dist_r_unrot (dist_right_in, cp_dbcsr_distribution(template), k_in, & col_blk_size_right_in) - CALL cp_dbcsr_init(matrix, error) + CALL cp_dbcsr_init(matrix) CALL cp_dbcsr_create(matrix, "D", dist_right_in, dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(template), col_blk_size_right_in,& - nze=0, data_type=cp_dbcsr_get_data_type(template), error=error) + nze=0, data_type=cp_dbcsr_get_data_type(template)) - CALL copy_fm_to_dbcsr(fm_in, matrix, error=error) + CALL copy_fm_to_dbcsr(fm_in, matrix) DEALLOCATE(col_blk_size_right_in) CALL dbcsr_distribution_release(dist_right_in) @@ -1684,14 +1655,12 @@ END SUBROUTINE cp_fm_to_dbcsr_row_template !> \param n global col size of output matrix !> \param sym ... !> \param data_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_m_by_n_from_template(matrix,template,m,n,sym,data_type,error) + SUBROUTINE cp_dbcsr_m_by_n_from_template(matrix,template,m,n,sym,data_type) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix, template INTEGER :: m, n CHARACTER, OPTIONAL :: sym INTEGER, OPTIONAL :: data_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'cp_dbcsr_m_by_n_from_template', & @@ -1725,7 +1694,7 @@ SUBROUTINE cp_dbcsr_m_by_n_from_template(matrix,template,m,n,sym,data_type,error CALL cp_dbcsr_create(matrix, "m_n_template", dist_m_n, mysym,& row_blk_size, col_blk_size, nze=0, data_type=my_data_type,& - reuse_arrays=.TRUE.,error=error) + reuse_arrays=.TRUE.) CALL dbcsr_distribution_release(dist_m_n) END SUBROUTINE cp_dbcsr_m_by_n_from_template @@ -1740,14 +1709,12 @@ END SUBROUTINE cp_dbcsr_m_by_n_from_template !> \param n global col size of output matrix !> \param sym ... !> \param data_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_m_by_n_from_row_template(matrix,template,n,sym,data_type,error) + SUBROUTINE cp_dbcsr_m_by_n_from_row_template(matrix,template,n,sym,data_type) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix, template INTEGER :: n CHARACTER, OPTIONAL :: sym INTEGER, OPTIONAL :: data_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'cp_dbcsr_m_by_n_from_row_template', & @@ -1775,7 +1742,7 @@ SUBROUTINE cp_dbcsr_m_by_n_from_row_template(matrix,template,n,sym,data_type,err col_cluster_dist) CALL cp_dbcsr_create(matrix, "m_n_template", dist_m_n, mysym,& - cp_dbcsr_row_block_sizes(template), col_blk_size, nze=0, data_type=my_data_type, error=error) + cp_dbcsr_row_block_sizes(template), col_blk_size, nze=0, data_type=my_data_type) DEALLOCATE(col_dist,col_blk_size) CALL dbcsr_distribution_release(dist_m_n) diff --git a/src/cp_dbcsr_output.F b/src/cp_dbcsr_output.F index 0890e988cc..edbed5fb44 100644 --- a/src/cp_dbcsr_output.F +++ b/src/cp_dbcsr_output.F @@ -74,12 +74,11 @@ MODULE cp_dbcsr_output !> \param first_col ... !> \param last_col ... !> \param output_unit ... -!> \param error ... !> \author Creation (12.06.2001,MK) !> Allow for printing of a sub-matrix (01.07.2003,MK) ! ***************************************************************************** SUBROUTINE write_fm_with_basis_info(blacs_matrix,before,after,qs_env,para_env,& - first_row,last_row,first_col,last_col,output_unit,error) + first_row,last_row,first_col,last_col,output_unit) TYPE(cp_fm_type), POINTER :: blacs_matrix INTEGER, INTENT(IN) :: before, after @@ -88,7 +87,6 @@ SUBROUTINE write_fm_with_basis_info(blacs_matrix,before,after,qs_env,para_env,& INTEGER, INTENT(IN), OPTIONAL :: first_row, last_row, & first_col, last_col INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_fm_with_basis_info', & routineP = moduleN//':'//routineN @@ -106,15 +104,15 @@ SUBROUTINE write_fm_with_basis_info(blacs_matrix,before,after,qs_env,para_env,& group = para_env%group IF (.NOT.ASSOCIATED(blacs_matrix)) RETURN CALL cp_fm_get_info(blacs_matrix,name=matrix_name,nrow_global=nrow_global,& - ncol_global=ncol_global,error=error) + ncol_global=ncol_global) ALLOCATE(matrix(nrow_global,ncol_global),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_fm_get_submatrix(blacs_matrix,matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_fm_get_submatrix(blacs_matrix,matrix) ! *** Get the matrix dimension and check the optional arguments *** - CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set,error=error) - CALL get_qs_kind_set(qs_kind_set=qs_kind_set,nsgf=nsgf,error=error) + CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set) + CALL get_qs_kind_set(qs_kind_set=qs_kind_set,nsgf=nsgf) IF (PRESENT(first_row)) THEN row1 = MAX(1,first_row) @@ -141,12 +139,12 @@ SUBROUTINE write_fm_with_basis_info(blacs_matrix,before,after,qs_env,para_env,& END IF CALL write_matrix_sym(matrix,matrix_name,before,after,qs_env,para_env,& - row1,row2,col1,col2,output_unit,error=error) + row1,row2,col1,col2,output_unit) ! *** Release work storage *** IF (ASSOCIATED(matrix)) THEN DEALLOCATE (matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE write_fm_with_basis_info @@ -164,11 +162,10 @@ END SUBROUTINE write_fm_with_basis_info !> \param last_col ... !> \param scale ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_write_sparse_matrix(sparse_matrix,before,after,qs_env,para_env,& first_row,last_row,first_col,last_col,scale,& - output_unit,error) + output_unit) TYPE(cp_dbcsr_type) :: sparse_matrix INTEGER, INTENT(IN) :: before, after @@ -178,7 +175,6 @@ SUBROUTINE cp_dbcsr_write_sparse_matrix(sparse_matrix,before,after,qs_env,para_e first_col, last_col REAL(dp), INTENT(IN), OPTIONAL :: scale INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_write_sparse_matrix', & routineP = moduleN//':'//routineN @@ -196,7 +192,7 @@ SUBROUTINE cp_dbcsr_write_sparse_matrix(sparse_matrix,before,after,qs_env,para_e NULLIFY (matrix) - CALL copy_repl_dbcsr_to_repl_fm(sparse_matrix,matrix,error) + CALL copy_repl_dbcsr_to_repl_fm(sparse_matrix,matrix) CALL mp_sum(matrix,group) @@ -214,7 +210,7 @@ SUBROUTINE cp_dbcsr_write_sparse_matrix(sparse_matrix,before,after,qs_env,para_e END SELECT ! *** Get the matrix dimension and check the optional arguments *** - CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set,error=error) + CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set) dim_row = SIZE(matrix,1) dim_col = SIZE(matrix,2) @@ -249,15 +245,15 @@ SUBROUTINE cp_dbcsr_write_sparse_matrix(sparse_matrix,before,after,qs_env,para_e matrix_name = cp_dbcsr_name(sparse_matrix) IF (print_sym) THEN CALL write_matrix_sym(matrix,matrix_name,before,after,qs_env,para_env,& - row1,row2,col1,col2, output_unit,error=error) + row1,row2,col1,col2, output_unit) ELSE CALL write_matrix_gen(matrix,matrix_name,before,after,para_env,& - row1,row2,col1,col2, output_unit,error=error) + row1,row2,col1,col2, output_unit) END IF IF (ASSOCIATED(matrix)) THEN DEALLOCATE (matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_dbcsr_write_sparse_matrix @@ -266,13 +262,11 @@ END SUBROUTINE cp_dbcsr_write_sparse_matrix !> \brief ... !> \param sparse_matrix ... !> \param fm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_repl_dbcsr_to_repl_fm(sparse_matrix,fm,error) + SUBROUTINE copy_repl_dbcsr_to_repl_fm(sparse_matrix,fm) TYPE(cp_dbcsr_type) :: sparse_matrix REAL(KIND=dp), DIMENSION(:, :), POINTER :: fm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'copy_repl_dbcsr_to_repl_fm', & routineP = moduleN//':'//routineN @@ -301,7 +295,7 @@ SUBROUTINE copy_repl_dbcsr_to_repl_fm(sparse_matrix,fm,error) !> this should be precomputed somewhere else ALLOCATE(r_offset(nblkrows_total),c_offset(nblkcols_total),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) r_offset(1) = 1 DO row = 2,nblkrows_total @@ -316,7 +310,7 @@ SUBROUTINE copy_repl_dbcsr_to_repl_fm(sparse_matrix,fm,error) !< ALLOCATE (fm(nr,nc),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) fm(:,:) = 0.0_dp @@ -332,7 +326,7 @@ SUBROUTINE copy_repl_dbcsr_to_repl_fm(sparse_matrix,fm,error) CALL cp_dbcsr_iterator_stop(iter) DEALLOCATE(r_offset,c_offset,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -351,11 +345,10 @@ END SUBROUTINE copy_repl_dbcsr_to_repl_fm !> \param first_col ... !> \param last_col ... !> \param output_unit ... -!> \param error ... !> \author Creation (01.07.2003,MK) ! ***************************************************************************** SUBROUTINE write_matrix_sym(matrix,matrix_name,before,after,qs_env,para_env,& - first_row,last_row,first_col,last_col,output_unit,error) + first_row,last_row,first_col,last_col,output_unit) REAL(KIND=dp), DIMENSION(:, :), POINTER :: matrix CHARACTER(LEN=*), INTENT(IN) :: matrix_name @@ -365,7 +358,6 @@ SUBROUTINE write_matrix_sym(matrix,matrix_name,before,after,qs_env,para_env,& INTEGER, INTENT(IN) :: first_row, last_row, & first_col, last_col, & output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_matrix_sym', & routineP = moduleN//':'//routineN @@ -398,19 +390,19 @@ SUBROUTINE write_matrix_sym(matrix,matrix_name,before,after,qs_env,para_env,& CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& atomic_kind_set=atomic_kind_set,& - particle_set=particle_set,error=error) + particle_set=particle_set) natom = SIZE(particle_set) - CALL get_qs_kind_set(qs_kind_set=qs_kind_set,nsgf=nsgf,error=error) + CALL get_qs_kind_set(qs_kind_set=qs_kind_set,nsgf=nsgf) ALLOCATE (first_sgf(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ! *** Definition of the variable formats *** fmtstr1 = "(/,T2,23X, ( X,I5, X))" @@ -446,7 +438,7 @@ SUBROUTINE write_matrix_sym(matrix,matrix_name,before,after,qs_env,para_env,& NULLIFY(orb_basis_set) CALL get_atomic_kind(particle_set(iatom)%atomic_kind,& kind_number=ikind, element_symbol=element_symbol) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set) IF ( ASSOCIATED(orb_basis_set) ) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,nshell=nshell,l=lshell,sgf_symbol=sgf_symbol) @@ -486,9 +478,9 @@ SUBROUTINE write_matrix_sym(matrix,matrix_name,before,after,qs_env,para_env,& WRITE (UNIT=output_unit,FMT="(/)") DEALLOCATE (first_sgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL mp_sync(group) @@ -508,11 +500,10 @@ END SUBROUTINE write_matrix_sym !> \param first_col ... !> \param last_col ... !> \param output_unit ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE write_matrix_gen(matrix,matrix_name,before,after,para_env,& - first_row,last_row,first_col,last_col,output_unit,error) + first_row,last_row,first_col,last_col,output_unit) REAL(KIND=dp), DIMENSION(:, :), POINTER :: matrix CHARACTER(LEN=*), INTENT(IN) :: matrix_name @@ -521,7 +512,6 @@ SUBROUTINE write_matrix_gen(matrix,matrix_name,before,after,para_env,& INTEGER, INTENT(IN) :: first_row, last_row, & first_col, last_col, & output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_matrix_gen', & routineP = moduleN//':'//routineN @@ -589,15 +579,13 @@ END SUBROUTINE write_matrix_gen !> \param matrix ... !> \param output_unit ... !> \param para_env ... -!> \param error ... !> \par History !> Creation (25.06.2003,MK) ! ***************************************************************************** - SUBROUTINE cp_dbcsr_write_matrix_dist(matrix,output_unit,para_env,error) + SUBROUTINE cp_dbcsr_write_matrix_dist(matrix,output_unit,para_env) TYPE(cp_dbcsr_type) :: matrix INTEGER, INTENT(IN) :: output_unit TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_write_matrix_dist', & routineP = moduleN//':'//routineN @@ -618,7 +606,7 @@ SUBROUTINE cp_dbcsr_write_matrix_dist(matrix,output_unit,para_env,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) @@ -629,11 +617,11 @@ SUBROUTINE cp_dbcsr_write_matrix_dist(matrix,output_unit,para_env,error) ! *** Allocate work storage *** ALLOCATE (nblock(npe),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nblock(:) = 0 ALLOCATE (nelement(npe),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nelement(:) = 0 nblock(mype) = cp_dbcsr_get_num_blocks(matrix) @@ -700,10 +688,10 @@ SUBROUTINE cp_dbcsr_write_matrix_dist(matrix,output_unit,para_env,error) ! *** Release work storage *** DEALLOCATE (nblock,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (nelement,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/cp_ddapc.F b/src/cp_ddapc.F index fc0fe62ed3..0cb21f19b6 100644 --- a/src/cp_ddapc.F +++ b/src/cp_ddapc.F @@ -77,14 +77,12 @@ MODULE cp_ddapc !> \param calculate_forces ... !> \param ks_matrix ... !> \param just_energy ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> 08.2008 extended to restraint/constraint DDAPC charges [fschiff] ! ***************************************************************************** SUBROUTINE qs_ks_ddapc(qs_env,auxbas_pw_pool,rho_tot_gspace,v_hartree_gspace,& - v_spin_ddapc_rest_r,energy,calculate_forces,ks_matrix,just_energy,& - error) + v_spin_ddapc_rest_r,energy,calculate_forces,ks_matrix,just_energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_pool_type), POINTER :: auxbas_pw_pool @@ -96,7 +94,6 @@ SUBROUTINE qs_ks_ddapc(qs_env,auxbas_pw_pool,rho_tot_gspace,v_hartree_gspace,& TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: ks_matrix LOGICAL, INTENT(in) :: just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_ddapc', & routineP = moduleN//':'//routineN @@ -118,26 +115,25 @@ SUBROUTINE qs_ks_ddapc(qs_env,auxbas_pw_pool,rho_tot_gspace,v_hartree_gspace,& CALL cite_reference(Blochl1995) ! In case decouple periodic images and/or apply restraints to charges failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ddapc_restraint_is_spin =.FALSE. et_coupling_calc =.FALSE. ddapc_size=0 ! no k-points - CPPostcondition(SIZE(ks_matrix,2)==1,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(ks_matrix,2)==1,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& v_hartree_rspace=v_hartree_rspace,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF(dft_control%qs_control%ddapc_restraint)THEN ddapc_size=SIZE(dft_control%qs_control%ddapc_restraint_control) IF(SIZE(energy%ddapc_restraint).NE.ddapc_size)THEN DEALLOCATE(energy%ddapc_restraint,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(energy%ddapc_restraint(ddapc_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DO i=1,SIZE(dft_control%qs_control%ddapc_restraint_control) @@ -152,17 +148,17 @@ SUBROUTINE qs_ks_ddapc(qs_env,auxbas_pw_pool,rho_tot_gspace,v_hartree_gspace,& dft_control%qs_control%ddapc_restraint_is_spin = ddapc_restraint_is_spin IF (explicit_potential) THEN CALL pw_pool_create_pw(auxbas_pw_pool,v_spin_ddapc_rest_g%pw,& - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE,error=error) - CALL pw_zero(v_spin_ddapc_rest_g%pw, error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_zero(v_spin_ddapc_rest_g%pw) CALL pw_pool_create_pw(auxbas_pw_pool,v_spin_ddapc_rest_r%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) ENDIF - IF (calculate_forces) CALL reset_ch_pulay(qs_env, error=error) + IF (calculate_forces) CALL reset_ch_pulay(qs_env) ! Decoupling/Recoupling CALL cp_ddapc_apply_CD(qs_env, rho_tot_gspace, energy%hartree, v_hartree_gspace,& - calculate_forces, Itype_of_density="FULL DENSITY", error=error) + calculate_forces, Itype_of_density="FULL DENSITY") IF(dft_control%qs_control%ddapc_restraint)THEN ! Restraints/Constraints DO i=1,ddapc_size @@ -170,31 +166,31 @@ SUBROUTINE qs_ks_ddapc(qs_env,auxbas_pw_pool,rho_tot_gspace,v_hartree_gspace,& ddapc_restraint_control=>dft_control%qs_control%ddapc_restraint_control(i)%ddapc_restraint_control CALL cp_ddapc_apply_RS(qs_env, energy%ddapc_restraint(i), v_hartree_gspace,& - v_spin_ddapc_rest_g, ddapc_restraint_control,calculate_forces, error) + v_spin_ddapc_rest_g, ddapc_restraint_control,calculate_forces) END DO END IF CALL cp_ddapc_apply_RF(qs_env, rho_tot_gspace, energy%hartree, v_hartree_gspace,& - calculate_forces, Itype_of_density="FULL DENSITY", error=error) + calculate_forces, Itype_of_density="FULL DENSITY") ! CJM Copying the real-space Hartree potential to KS_ENV IF ((.NOT. just_energy).OR.et_coupling_calc) THEN - CALL pw_transfer(v_hartree_gspace%pw, v_hartree_rspace, error=error) - CALL pw_scale(v_hartree_rspace, v_hartree_rspace%pw_grid%dvol, error=error) + CALL pw_transfer(v_hartree_gspace%pw, v_hartree_rspace) + CALL pw_scale(v_hartree_rspace, v_hartree_rspace%pw_grid%dvol) IF (explicit_potential) THEN - CALL pw_transfer(v_spin_ddapc_rest_g%pw,v_spin_ddapc_rest_r%pw, error=error) - CALL pw_scale(v_spin_ddapc_rest_r%pw,v_spin_ddapc_rest_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(v_spin_ddapc_rest_g%pw,v_spin_ddapc_rest_r%pw) + CALL pw_scale(v_spin_ddapc_rest_r%pw,v_spin_ddapc_rest_r%pw%pw_grid%dvol) IF(et_coupling_calc)THEN IF(qs_env%et_coupling%keep_matrix)THEN IF(qs_env%et_coupling%first_run)THEN NULLIFY(qs_env%et_coupling%rest_mat(1)%matrix) ALLOCATE(qs_env%et_coupling%rest_mat(1)%matrix) - CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(1)%matrix, error=error) + CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(1)%matrix) CALL cp_dbcsr_copy(qs_env%et_coupling%rest_mat(1)%matrix, ks_matrix(1,1)%matrix, & - name="ET_RESTRAINT_MATRIX_B", error=error) - CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(1)%matrix, 0.0_dp, error=error) + name="ET_RESTRAINT_MATRIX_B") + CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(1)%matrix, 0.0_dp) CALL integrate_v_rspace(v_spin_ddapc_rest_r,& hmat=qs_env%et_coupling%rest_mat(1),& - qs_env=qs_env,calculate_forces=.FALSE.,error=error) + qs_env=qs_env,calculate_forces=.FALSE.) qs_env%et_coupling%order_p=& dft_control%qs_control%ddapc_restraint_control(1)%ddapc_restraint_control%ddapc_order_p qs_env%et_coupling%e1=dft_control%qs_control%ddapc_restraint_control(1)%ddapc_restraint_control%strength @@ -202,13 +198,13 @@ SUBROUTINE qs_ks_ddapc(qs_env,auxbas_pw_pool,rho_tot_gspace,v_hartree_gspace,& ELSE NULLIFY(qs_env%et_coupling%rest_mat(2)%matrix) ALLOCATE(qs_env%et_coupling%rest_mat(2)%matrix) - CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(2)%matrix, error=error) + CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(2)%matrix) CALL cp_dbcsr_copy(qs_env%et_coupling%rest_mat(2)%matrix, ks_matrix(1,1)%matrix, & - name="ET_RESTRAINT_MATRIX_B", error=error) - CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(2)%matrix, 0.0_dp, error=error) + name="ET_RESTRAINT_MATRIX_B") + CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(2)%matrix, 0.0_dp) CALL integrate_v_rspace(v_spin_ddapc_rest_r,& hmat=qs_env%et_coupling%rest_mat(2),& - qs_env=qs_env,calculate_forces=.FALSE.,error=error) + qs_env=qs_env,calculate_forces=.FALSE.) END IF END IF END IF @@ -216,7 +212,7 @@ SUBROUTINE qs_ks_ddapc(qs_env,auxbas_pw_pool,rho_tot_gspace,v_hartree_gspace,& ENDIF IF (explicit_potential) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_spin_ddapc_rest_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_spin_ddapc_rest_g%pw) ENDIF CALL timestop(handle) @@ -236,20 +232,18 @@ END SUBROUTINE qs_ks_ddapc !> \param v_hartree_gspace ... !> \param calculate_forces ... !> \param Itype_of_density ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE cp_ddapc_apply_CD(qs_env, rho_tot_gspace, energy, v_hartree_gspace, & - calculate_forces, Itype_of_density, error) + calculate_forces, Itype_of_density) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type) :: rho_tot_gspace REAL(KIND=dp), INTENT(INOUT) :: energy TYPE(pw_p_type) :: v_hartree_gspace LOGICAL, INTENT(IN), OPTIONAL :: calculate_forces CHARACTER(LEN=*) :: Itype_of_density - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_apply_CD', & routineP = moduleN//':'//routineN @@ -272,7 +266,7 @@ SUBROUTINE cp_ddapc_apply_CD(qs_env, rho_tot_gspace, energy, v_hartree_gspace, & failure = .FALSE. need_f = .FALSE. IF (PRESENT(calculate_forces)) need_f = calculate_forces - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() apply_decpl = qs_env%cp_ddapc_ewald%do_decoupling.OR.qs_env%cp_ddapc_ewald%do_qmmm_periodic_decpl IF ((.NOT.failure).AND.(apply_decpl)) THEN ! Initialize @@ -292,23 +286,22 @@ SUBROUTINE cp_ddapc_apply_CD(qs_env, rho_tot_gspace, energy, v_hartree_gspace, & input=force_env_section,& particle_set=particle_set,& cell=cell,& - super_cell=super_cell,& - error=error) - CPPostcondition(ASSOCIATED(qs_env%cp_ddapc_ewald),cp_failure_level,routineP,error,failure) - poisson_section => section_vals_get_subs_vals(force_env_section,"DFT%POISSON", error=error) + super_cell=super_cell) + CPPostcondition(ASSOCIATED(qs_env%cp_ddapc_ewald),cp_failure_level,routineP,failure) + poisson_section => section_vals_get_subs_vals(force_env_section,"DFT%POISSON") - density_fit_section =>section_vals_get_subs_vals(force_env_section,"DFT%DENSITY_FITTING", error=error) + density_fit_section =>section_vals_get_subs_vals(force_env_section,"DFT%DENSITY_FITTING") IF (qs_env%cp_ddapc_ewald%do_decoupling) THEN - multipole_section => section_vals_get_subs_vals(poisson_section,"MULTIPOLE", error=error) + multipole_section => section_vals_get_subs_vals(poisson_section,"MULTIPOLE") END IF IF (qs_env%cp_ddapc_ewald%do_qmmm_periodic_decpl) THEN - qmmm_periodic_section => section_vals_get_subs_vals(force_env_section,"QMMM%PERIODIC", error=error) - multipole_section => section_vals_get_subs_vals(qmmm_periodic_section,"MULTIPOLE", error=error) + qmmm_periodic_section => section_vals_get_subs_vals(force_env_section,"QMMM%PERIODIC") + multipole_section => section_vals_get_subs_vals(qmmm_periodic_section,"MULTIPOLE") END IF ! Start the real calculation iw=cp_print_key_unit_nr(logger,multipole_section,"PROGRAM_RUN_INFO",& - extension=".fitChargeLog",error=error) + extension=".fitChargeLog") ! First we evaluate the charges at the corresponding SCF STEP IF (need_f) THEN CALL get_ddapc(qs_env,& @@ -318,8 +311,7 @@ SUBROUTINE cp_ddapc_apply_CD(qs_env, rho_tot_gspace, energy, v_hartree_gspace, & out_radii=radii,& dq_out=dq,& ext_rho_tot_g=rho_tot_gspace%pw,& - Itype_of_density=Itype_of_density,& - error=error) + Itype_of_density=Itype_of_density) ELSE CALL get_ddapc(qs_env,& need_f,& @@ -327,8 +319,7 @@ SUBROUTINE cp_ddapc_apply_CD(qs_env, rho_tot_gspace, energy, v_hartree_gspace, & qout1=charges,& out_radii=radii,& ext_rho_tot_g=rho_tot_gspace%pw,& - Itype_of_density=Itype_of_density,& - error=error) + Itype_of_density=Itype_of_density) END IF ! Evaluate the Ewald contribution to the decoupling/coupling E2 and E3 IF (iw>0) THEN @@ -345,31 +336,30 @@ SUBROUTINE cp_ddapc_apply_CD(qs_env, rho_tot_gspace, energy, v_hartree_gspace, & qs_env%cp_ddapc_env%Mt,& qs_env%cp_ddapc_env%AmI,& radii,& - charges,& - error) + charges) ! Modify the Hartree potential due to the decoupling/recoupling - energy = 0.5_dp * pw_integral_ab ( rho_tot_gspace%pw, v_hartree_gspace%pw,error=error) + energy = 0.5_dp * pw_integral_ab ( rho_tot_gspace%pw, v_hartree_gspace%pw) IF (need_f) THEN CALL ewald_ddapc_force(qs_env, qs_env%cp_ddapc_ewald%coeff_qm,& .FALSE., 1.0_dp, multipole_section, cell, particle_set,& - radii, dq, charges, error=error) + radii, dq, charges) IF (qs_env%cp_ddapc_ewald%do_qmmm_periodic_decpl) THEN CALL ewald_ddapc_force(qs_env, qs_env%cp_ddapc_ewald%coeff_mm,& .TRUE., -1.0_dp, multipole_section, super_cell, particle_set, & - radii, dq, charges, error=error) + radii, dq, charges) END IF END IF ! Clean the allocated arrays DEALLOCATE(charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(radii, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(dq)) THEN DEALLOCATE(dq, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL cp_print_key_finished_output(iw,logger,multipole_section,& - "PROGRAM_RUN_INFO",error=error) + "PROGRAM_RUN_INFO") END IF CALL timestop(handle) END SUBROUTINE cp_ddapc_apply_CD @@ -383,21 +373,18 @@ END SUBROUTINE cp_ddapc_apply_CD !> \param v_spin_ddapc_rest_g ... !> \param ddapc_restraint_control ... !> \param calculate_forces ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE cp_ddapc_apply_RS(qs_env, energy_res,v_hartree_gspace,& - v_spin_ddapc_rest_g,ddapc_restraint_control,calculate_forces,& - error) + v_spin_ddapc_rest_g,ddapc_restraint_control,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: energy_res TYPE(pw_p_type) :: v_hartree_gspace, & v_spin_ddapc_rest_g TYPE(ddapc_restraint_type), POINTER :: ddapc_restraint_control LOGICAL, INTENT(IN), OPTIONAL :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_apply_RS', & routineP = moduleN//':'//routineN @@ -428,19 +415,17 @@ SUBROUTINE cp_ddapc_apply_RS(qs_env, energy_res,v_hartree_gspace,& particle_set=particle_set,& cell=cell,& super_cell=super_cell,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF (PRESENT(calculate_forces)) need_f = calculate_forces apply_restrain = dft_control%qs_control%ddapc_restraint - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF ((.NOT.failure).AND.apply_restrain) THEN ! Initialize - density_fit_section => section_vals_get_subs_vals(force_env_section,"DFT%DENSITY_FITTING",error=error) - restraint_section => section_vals_get_subs_vals(force_env_section,"DFT%QS%DDAPC_RESTRAINT",& - error=error) + density_fit_section => section_vals_get_subs_vals(force_env_section,"DFT%DENSITY_FITTING") + restraint_section => section_vals_get_subs_vals(force_env_section,"DFT%QS%DDAPC_RESTRAINT") iw=cp_print_key_unit_nr(logger,restraint_section,"PROGRAM_RUN_INFO",& - extension=".fitChargeLog",error=error) + extension=".fitChargeLog") ! First we evaluate the charges at the corresponding SCF STEP my_id= ddapc_restraint_control%density_type IF (need_f) THEN @@ -450,27 +435,25 @@ SUBROUTINE cp_ddapc_apply_RS(qs_env, energy_res,v_hartree_gspace,& density_type=my_id,& qout1=charges,& out_radii=radii,& - dq_out=dq,& - error=error) + dq_out=dq) ELSE CALL get_ddapc(qs_env,& need_f,& density_fit_section,& density_type=my_id,& qout1=charges,& - out_radii=radii,& - error=error) + out_radii=radii) END IF ! Modify the Hartree potential due to the restrain or the v_spin_ddapc_rest_g IF ((my_id==do_spin_density).OR.dft_control%qs_control%et_coupling_calc) THEN CALL restraint_functional_potential(v_spin_ddapc_rest_g, density_fit_section,& particle_set, qs_env%cp_ddapc_env%AmI, radii, charges, & - ddapc_restraint_control, energy_res, error) + ddapc_restraint_control, energy_res) ELSE CALL restraint_functional_potential(v_hartree_gspace, density_fit_section,& particle_set, qs_env%cp_ddapc_env%AmI, radii, charges, & - ddapc_restraint_control, energy_res,error) + ddapc_restraint_control, energy_res) ENDIF IF (need_f) THEN @@ -479,20 +462,19 @@ SUBROUTINE cp_ddapc_apply_RS(qs_env, energy_res,v_hartree_gspace,& dq,& charges,& SIZE(radii),& - particle_set,& - error) + particle_set) END IF ! Clean the allocated arrays DEALLOCATE(charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(radii, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(dq)) THEN DEALLOCATE(dq, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL cp_print_key_finished_output(iw,logger,restraint_section,& - "PROGRAM_RUN_INFO",error=error) + "PROGRAM_RUN_INFO") END IF CALL timestop(handle) END SUBROUTINE cp_ddapc_apply_RS @@ -505,20 +487,18 @@ END SUBROUTINE cp_ddapc_apply_RS !> \param v_hartree_gspace ... !> \param calculate_forces ... !> \param Itype_of_density ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE cp_ddapc_apply_RF(qs_env,rho_tot_gspace,energy,& - v_hartree_gspace,calculate_forces, Itype_of_density, error) + v_hartree_gspace,calculate_forces, Itype_of_density) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type) :: rho_tot_gspace REAL(KIND=dp), INTENT(INOUT) :: energy TYPE(pw_p_type) :: v_hartree_gspace LOGICAL, INTENT(IN), OPTIONAL :: calculate_forces CHARACTER(LEN=*) :: Itype_of_density - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_apply_RF', & routineP = moduleN//':'//routineN @@ -542,7 +522,7 @@ SUBROUTINE cp_ddapc_apply_RF(qs_env,rho_tot_gspace,energy,& failure = .FALSE. need_f = .FALSE. IF (PRESENT(calculate_forces)) need_f = calculate_forces - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() apply_solvation = qs_env%cp_ddapc_ewald%do_solvation IF ((.NOT.failure).AND.(apply_solvation)) THEN ! Initialize @@ -553,14 +533,13 @@ SUBROUTINE cp_ddapc_apply_RF(qs_env,rho_tot_gspace,energy,& input=force_env_section,& particle_set=particle_set,& cell=cell,& - super_cell=super_cell,& - error=error) + super_cell=super_cell) - solvation_section => section_vals_get_subs_vals(force_env_section,"DFT%SCRF", error=error) + solvation_section => section_vals_get_subs_vals(force_env_section,"DFT%SCRF") ! Start the real calculation iw=cp_print_key_unit_nr(logger,solvation_section,"PROGRAM_RUN_INFO",& - extension=".fitChargeLog",error=error) - density_fit_section => section_vals_get_subs_vals(force_env_section,"DFT%DENSITY_FITTING", error=error) + extension=".fitChargeLog") + density_fit_section => section_vals_get_subs_vals(force_env_section,"DFT%DENSITY_FITTING") ! First we evaluate the charges at the corresponding SCF STEP IF (need_f) THEN CALL get_ddapc(qs_env,& @@ -570,8 +549,7 @@ SUBROUTINE cp_ddapc_apply_RF(qs_env,rho_tot_gspace,energy,& out_radii=radii,& dq_out=dq,& ext_rho_tot_g=rho_tot_gspace%pw,& - Itype_of_density=Itype_of_density,& - error=error) + Itype_of_density=Itype_of_density) ELSE CALL get_ddapc(qs_env,& need_f,& @@ -579,8 +557,7 @@ SUBROUTINE cp_ddapc_apply_RF(qs_env,rho_tot_gspace,energy,& qout1=charges,& out_radii=radii,& ext_rho_tot_g=rho_tot_gspace%pw,& - Itype_of_density=Itype_of_density,& - error=error) + Itype_of_density=Itype_of_density) END IF ! Evaluate the Ewald contribution to the decoupling/coupling E2 and E3 IF (iw>0) THEN @@ -593,25 +570,24 @@ SUBROUTINE cp_ddapc_apply_RF(qs_env,rho_tot_gspace,energy,& qs_env%cp_ddapc_env%Ms,& qs_env%cp_ddapc_env%AmI,& radii,& - charges,& - error) + charges) ! Modify the Hartree potential due to the reaction field - energy = 0.5_dp * pw_integral_ab ( rho_tot_gspace%pw, v_hartree_gspace%pw, error=error) + energy = 0.5_dp * pw_integral_ab ( rho_tot_gspace%pw, v_hartree_gspace%pw) IF (need_f) THEN CALL solvation_ddapc_force(qs_env, solvation_section, particle_set,& - radii, dq, charges, error) + radii, dq, charges) END IF ! Clean the allocated arrays DEALLOCATE(charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(radii, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(dq)) THEN DEALLOCATE(dq, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL cp_print_key_finished_output(iw,logger,solvation_section,& - "PROGRAM_RUN_INFO",error=error) + "PROGRAM_RUN_INFO") END IF CALL timestop(handle) END SUBROUTINE cp_ddapc_apply_RF diff --git a/src/cp_ddapc_forces.F b/src/cp_ddapc_forces.F index 51c7fa4d53..a137eb33ff 100644 --- a/src/cp_ddapc_forces.F +++ b/src/cp_ddapc_forces.F @@ -69,13 +69,12 @@ MODULE cp_ddapc_forces !> \param radii ... !> \param dq ... !> \param charges ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** RECURSIVE SUBROUTINE ewald_ddapc_force(qs_env, coeff, apply_qmmm_periodic,& - factor, multipole_section, cell, particle_set, radii, dq, charges, error) + factor, multipole_section, cell, particle_set, radii, dq, charges) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_type), POINTER :: coeff LOGICAL, INTENT(IN) :: apply_qmmm_periodic @@ -89,7 +88,6 @@ RECURSIVE SUBROUTINE ewald_ddapc_force(qs_env, coeff, apply_qmmm_periodic,& OPTIONAL, POINTER :: dq REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_ddapc_force', & routineP = moduleN//':'//routineN @@ -108,15 +106,15 @@ RECURSIVE SUBROUTINE ewald_ddapc_force(qs_env, coeff, apply_qmmm_periodic,& failure = .FALSE. NULLIFY(d_el, M, para_env) CALL timeset(routineN,handle) - CALL get_qs_env(qs_env, para_env=para_env, error=error) - CPPostcondition(PRESENT(charges),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(radii),cp_failure_level,routineP,error,failure) - CPPostcondition(cell%orthorhombic,cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env, para_env=para_env) + CPPostcondition(PRESENT(charges),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(radii),cp_failure_level,routineP,failure) + CPPostcondition(cell%orthorhombic,cp_failure_level,routineP,failure) rcut = MIN(cell%hmat(1,1),cell%hmat(2,2),cell%hmat(3,3))/2.0_dp - CALL section_vals_val_get(multipole_section,"RCUT",n_rep_val=n_rep,error=error) - IF (n_rep==1) CALL section_vals_val_get(multipole_section,"RCUT",r_val=rcut,error=error) - CALL section_vals_val_get(multipole_section,"EWALD_PRECISION",r_val=eps,error=error) - CALL section_vals_val_get(multipole_section,"ANALYTICAL_GTERM",l_val=analyt,error=error) + CALL section_vals_val_get(multipole_section,"RCUT",n_rep_val=n_rep) + IF (n_rep==1) CALL section_vals_val_get(multipole_section,"RCUT",r_val=rcut) + CALL section_vals_val_get(multipole_section,"EWALD_PRECISION",r_val=eps) + CALL section_vals_val_get(multipole_section,"ANALYTICAL_GTERM",l_val=analyt) rcut2=rcut**2 ! ! Setting-up parameters for Ewald summation @@ -135,7 +133,7 @@ RECURSIVE SUBROUTINE ewald_ddapc_force(qs_env, coeff, apply_qmmm_periodic,& rmax3 = CEILING(rcut/cell%hmat(3,3)) ALLOCATE(d_el(3,SIZE(particle_set)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) d_el = 0.0_dp fac = 1.e0_dp/cell%deth fac3 = fac/8.0_dp @@ -211,7 +209,7 @@ RECURSIVE SUBROUTINE ewald_ddapc_force(qs_env, coeff, apply_qmmm_periodic,& END DO END DO ELSE - gvec = Eval_d_Interp_Spl3_pbc( rvec, coeff, error ) * q1t * q2t * factor * fourpi + gvec = Eval_d_Interp_Spl3_pbc( rvec, coeff) * q1t * q2t * factor * fourpi d_el(1:3,iparticle1) = d_el(1:3,iparticle1) - gvec d_el(1:3,iparticle2) = d_el(1:3,iparticle2) + gvec END IF @@ -229,9 +227,9 @@ RECURSIVE SUBROUTINE ewald_ddapc_force(qs_env, coeff, apply_qmmm_periodic,& CALL mp_sum(d_el, para_env%group) M => qs_env%cp_ddapc_env%Md IF (apply_qmmm_periodic) M => qs_env%cp_ddapc_env%Mr - CALL cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set, error) + CALL cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set) DEALLOCATE(d_el, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE ewald_ddapc_force @@ -243,12 +241,11 @@ END SUBROUTINE ewald_ddapc_force !> \param dq ... !> \param d_el ... !> \param particle_set ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set, error) + SUBROUTINE cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set) TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), DIMENSION(:, :), POINTER :: M REAL(KIND=dp), DIMENSION(:), POINTER :: charges @@ -257,7 +254,6 @@ SUBROUTINE cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set, err REAL(KIND=dp), DIMENSION(:, :), POINTER :: d_el TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_decpl_ddapc_forces', & routineP = moduleN//':'//routineN @@ -282,19 +278,19 @@ SUBROUTINE cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set, err CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& para_env=para_env,& - force=force,error=error) + force=force) ALLOCATE (atom_of_kind(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (kind_of(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (chf(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind,& kind_of=kind_of) ALLOCATE(uv(SIZE(M,1)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) uv(:) = MATMUL(M,charges) DO k = 1, natom DO j = 1, 3 @@ -309,27 +305,25 @@ SUBROUTINE cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set, err force(ikind)%ch_pulay(1:3,i) = force(ikind)%ch_pulay(1:3,i) + chf(1:3,iatom) + d_el(1:3,iatom) END DO DEALLOCATE(atom_of_kind, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kind_of, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(chf, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(uv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE cp_decpl_ddapc_forces ! ***************************************************************************** !> \brief Evaluation of the pulay forces due to the fitted charge density !> \param qs_env ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE reset_ch_pulay(qs_env, error) + SUBROUTINE reset_ch_pulay(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reset_ch_pulay', & routineP = moduleN//':'//routineN @@ -343,7 +337,7 @@ SUBROUTINE reset_ch_pulay(qs_env, error) CALL timeset(routineN,handle) CALL get_qs_env(qs_env=qs_env,& - force=force,error=error) + force=force) DO ind = 1, SIZE(force) force(ind)%ch_pulay = 0.0_dp END DO @@ -358,7 +352,6 @@ END SUBROUTINE reset_ch_pulay !> \param charges current value of the charges (one number for each gaussian used) !> !> \param energy_res energy due to the restraint -!> \param error ... !> \par History !> 02.2006 [Joost VandeVondele] !> modified [Teo] @@ -366,14 +359,13 @@ END SUBROUTINE reset_ch_pulay !> should be easy to adapt for other specialized cases ! ***************************************************************************** SUBROUTINE evaluate_restraint_functional(ddapc_restraint_control, n_gauss, uv,& - charges, energy_res, error) + charges, energy_res) TYPE(ddapc_restraint_type), & INTENT(INOUT) :: ddapc_restraint_control INTEGER, INTENT(in) :: n_gauss REAL(KIND=dp), DIMENSION(:) :: uv REAL(KIND=dp), DIMENSION(:), POINTER :: charges REAL(KIND=dp), INTENT(INOUT) :: energy_res - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'evaluate_restraint_functional', & @@ -414,7 +406,7 @@ SUBROUTINE evaluate_restraint_functional(ddapc_restraint_control, n_gauss, uv,& ENDDO CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE evaluate_restraint_functional @@ -427,7 +419,6 @@ END SUBROUTINE evaluate_restraint_functional !> \param charges ... !> \param n_gauss ... !> \param particle_set ... -!> \param error ... !> \par History !> 02.2006 [Joost VandeVondele] !> modified [Teo] @@ -435,7 +426,7 @@ END SUBROUTINE evaluate_restraint_functional !> should be easy to adapt for other specialized cases ! ***************************************************************************** SUBROUTINE restraint_functional_force(qs_env, ddapc_restraint_control, dq, charges,& - n_gauss, particle_set, error) + n_gauss, particle_set) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ddapc_restraint_type), & @@ -446,7 +437,6 @@ SUBROUTINE restraint_functional_force(qs_env, ddapc_restraint_control, dq, charg INTEGER, INTENT(in) :: n_gauss TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'restraint_functional_force', & routineP = moduleN//':'//routineN @@ -472,22 +462,22 @@ SUBROUTINE restraint_functional_force(qs_env, ddapc_restraint_control, dq, charg CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& para_env=para_env,& - force=force,error=error) + force=force) ALLOCATE (atom_of_kind(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (kind_of(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (chf(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind,& kind_of=kind_of) ALLOCATE(uv(SIZE(dq,1)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) uv = 0.0_dp CALL evaluate_restraint_functional(ddapc_restraint_control, n_gauss, uv,& - charges, dum, error) + charges, dum) DO k = 1, natom DO j = 1, 3 chf(j,k) = DOT_PRODUCT(uv,dq(:,k,j)) @@ -501,13 +491,13 @@ SUBROUTINE restraint_functional_force(qs_env, ddapc_restraint_control, dq, charg force(ikind)%ch_pulay(1:3,i) = force(ikind)%ch_pulay(1:3,i) + chf(1:3,iatom) END DO DEALLOCATE(atom_of_kind, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kind_of, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(chf, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(uv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE restraint_functional_force @@ -521,13 +511,12 @@ END SUBROUTINE restraint_functional_force !> \param radii ... !> \param dq ... !> \param charges ... -!> \param error ... !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE solvation_ddapc_force(qs_env, solvation_section, particle_set,& - radii, dq, charges, error) + radii, dq, charges) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: solvation_section TYPE(particle_type), DIMENSION(:), & @@ -537,7 +526,6 @@ SUBROUTINE solvation_ddapc_force(qs_env, solvation_section, particle_set,& OPTIONAL, POINTER :: dq REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'solvation_ddapc_force', & routineP = moduleN//':'//routineN @@ -557,25 +545,21 @@ SUBROUTINE solvation_ddapc_force(qs_env, solvation_section, particle_set,& fixed_center = .FALSE. NULLIFY(d_el, M) eps_in = 1.0_dp - CALL section_vals_val_get(solvation_section,"EPS_OUT",r_val=eps_out,error=error) - CALL section_vals_val_get(solvation_section,"LMAX",i_val=lmax,error=error) - CALL section_vals_val_get(solvation_section,"SPHERE%RADIUS",r_val=Rs,error=error) - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",n_rep_val=n_rep1,& - error=error) + CALL section_vals_val_get(solvation_section,"EPS_OUT",r_val=eps_out) + CALL section_vals_val_get(solvation_section,"LMAX",i_val=lmax) + CALL section_vals_val_get(solvation_section,"SPHERE%RADIUS",r_val=Rs) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",n_rep_val=n_rep1) IF (n_rep1/=0) THEN - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",r_vals=R0,& - error=error) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",r_vals=R0) center = R0 ELSE CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%ATOM_LIST",& - n_rep_val=n_rep2,error=error) + n_rep_val=n_rep2) IF (n_rep2/=0) THEN - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%ATOM_LIST",i_vals=list,& - error=error) - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%WEIGHT_TYPE",i_val=weight,& - error=error) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%ATOM_LIST",i_vals=list) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%WEIGHT_TYPE",i_val=weight) ALLOCATE(R0(SIZE(list)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE(weight) CASE (weight_type_unit) R0 = 0.0_dp @@ -594,17 +578,17 @@ SUBROUTINE solvation_ddapc_force(qs_env, solvation_section, particle_set,& END SELECT center = R0 DEALLOCATE(R0, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF - CPPostcondition(n_rep1/=0.OR.n_rep2/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(n_rep1/=0.OR.n_rep2/=0,cp_failure_level,routineP,failure) ! Potential calculation ALLOCATE(LocP(0:lmax,SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pos(SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(d_el(3,SIZE(particle_set)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) d_el = 0.0_dp ! Determining the single atomic contribution to the dielectric dipole DO i = 1, SIZE(particle_set) @@ -660,13 +644,13 @@ SUBROUTINE solvation_ddapc_force(qs_env, solvation_section, particle_set,& END DO END DO DEALLOCATE(pos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(LocP,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) M => qs_env%cp_ddapc_env%Ms - CALL cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set, error) + CALL cp_decpl_ddapc_forces(qs_env, M, charges, dq, d_el, particle_set) DEALLOCATE(d_el, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE solvation_ddapc_force END MODULE cp_ddapc_forces diff --git a/src/cp_ddapc_methods.F b/src/cp_ddapc_methods.F index 0a15db4123..44fbb76f2e 100644 --- a/src/cp_ddapc_methods.F +++ b/src/cp_ddapc_methods.F @@ -58,15 +58,13 @@ MODULE cp_ddapc_methods !> \param gcut ... !> \param rho_tot_g ... !> \param radii ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ddapc_eval_gfunc(gfunc, w, gcut, rho_tot_g, radii, error) + SUBROUTINE ddapc_eval_gfunc(gfunc, w, gcut, rho_tot_g, radii) REAL(KIND=dp), DIMENSION(:, :), POINTER :: gfunc REAL(kind=dp), DIMENSION(:), POINTER :: w REAL(KIND=dp), INTENT(IN) :: gcut TYPE(pw_type), POINTER :: rho_tot_g REAL(kind=dp), DIMENSION(:), POINTER :: radii - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ddapc_eval_gfunc', & routineP = moduleN//':'//routineN @@ -83,9 +81,9 @@ SUBROUTINE ddapc_eval_gfunc(gfunc, w, gcut, rho_tot_g, radii, error) s_dim = rho_tot_g % pw_grid % first_gne0 e_dim = rho_tot_g % pw_grid % ngpts_cut_local ALLOCATE(gfunc(s_dim:e_dim,SIZE(radii)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(w(s_dim:e_dim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gfunc = 0.0_dp w = 0.0_dp DO igauss = 1, SIZE(radii) @@ -114,12 +112,11 @@ END SUBROUTINE ddapc_eval_gfunc !> \param radii ... !> \param rho_tot_g ... !> \param gcut ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE build_b_vector(bv, gfunc, w, particle_set, radii, rho_tot_g, gcut, error) + SUBROUTINE build_b_vector(bv, gfunc, w, particle_set, radii, rho_tot_g, gcut) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: bv REAL(KIND=dp), DIMENSION(:, :), POINTER :: gfunc @@ -129,7 +126,6 @@ SUBROUTINE build_b_vector(bv, gfunc, w, particle_set, radii, rho_tot_g, gcut, er REAL(KIND=dp), DIMENSION(:), POINTER :: radii TYPE(pw_type), POINTER :: rho_tot_g REAL(KIND=dp), INTENT(IN) :: gcut - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_b_vector', & routineP = moduleN//':'//routineN @@ -156,9 +152,9 @@ SUBROUTINE build_b_vector(bv, gfunc, w, particle_set, radii, rho_tot_g, gcut, er igmax = ig ENDDO ALLOCATE(my_bv(s_dim:igmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(my_bvw(s_dim:igmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! DO iparticle = 1, SIZE(particle_set) rvec = particle_set(iparticle)%r @@ -178,9 +174,9 @@ SUBROUTINE build_b_vector(bv, gfunc, w, particle_set, radii, rho_tot_g, gcut, er END DO END DO DEALLOCATE(my_bvw,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_bv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE build_b_vector @@ -195,13 +191,12 @@ END SUBROUTINE build_b_vector !> \param gcut ... !> \param g_dot_rvec_sin ... !> \param g_dot_rvec_cos ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino !> \note NB accept g_dot_rvec_* arrays ! ***************************************************************************** - SUBROUTINE build_A_matrix(Am, gfunc, w, particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos, error) + SUBROUTINE build_A_matrix(Am, gfunc, w, particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos) REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: Am REAL(KIND=dp), DIMENSION(:, :), POINTER :: gfunc @@ -213,7 +208,6 @@ SUBROUTINE build_A_matrix(Am, gfunc, w, particle_set, radii, rho_tot_g, gcut, g_ REAL(KIND=dp), INTENT(IN) :: gcut REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: g_dot_rvec_sin, g_dot_rvec_cos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_A_matrix', & routineP = moduleN//':'//routineN @@ -241,11 +235,11 @@ SUBROUTINE build_A_matrix(Am, gfunc, w, particle_set, radii, rho_tot_g, gcut, g_ igmax = ig ENDDO ALLOCATE(my_Am(s_dim:igmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(my_Amw(s_dim:igmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gfunc_sq(s_dim:igmax,SIZE(radii),SIZE(radii)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO igauss1 = 1, SIZE(radii) DO igauss2 = 1, SIZE(radii) @@ -277,11 +271,11 @@ SUBROUTINE build_A_matrix(Am, gfunc, w, particle_set, radii, rho_tot_g, gcut, g_ END DO END DO DEALLOCATE(gfunc_sq,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_Amw,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_Am,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE build_A_matrix @@ -295,12 +289,11 @@ END SUBROUTINE build_A_matrix !> \param rho_tot_g ... !> \param gcut ... !> \param iparticle0 ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE build_der_b_vector(dbv, gfunc, w, particle_set, radii, rho_tot_g, gcut, iparticle0, error) + SUBROUTINE build_der_b_vector(dbv, gfunc, w, particle_set, radii, rho_tot_g, gcut, iparticle0) REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: dbv REAL(KIND=dp), DIMENSION(:, :), POINTER :: gfunc @@ -311,7 +304,6 @@ SUBROUTINE build_der_b_vector(dbv, gfunc, w, particle_set, radii, rho_tot_g, gcu TYPE(pw_type), POINTER :: rho_tot_g REAL(KIND=dp), INTENT(IN) :: gcut INTEGER, INTENT(IN) :: iparticle0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_der_b_vector', & routineP = moduleN//':'//routineN @@ -339,9 +331,9 @@ SUBROUTINE build_der_b_vector(dbv, gfunc, w, particle_set, radii, rho_tot_g, gcu igmax = ig ENDDO ALLOCATE(my_dbv(3,s_dim:igmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(my_dbvw(s_dim:igmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iparticle = 1, SIZE(particle_set) IF (iparticle /= iparticle0) CYCLE rvec = particle_set(iparticle)%r @@ -368,9 +360,9 @@ SUBROUTINE build_der_b_vector(dbv, gfunc, w, particle_set, radii, rho_tot_g, gcu END DO END DO DEALLOCATE(my_dbvw,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_dbv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE build_der_b_vector @@ -388,14 +380,13 @@ END SUBROUTINE build_der_b_vector !> \param nparticles ... !> \param g_dot_rvec_sin ... !> \param g_dot_rvec_cos ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino !> \note NB accept g_dot_rvec_* arrays ! ***************************************************************************** SUBROUTINE build_der_A_matrix_rows(dAm, gfunc, w, particle_set, radii,& - rho_tot_g, gcut, iparticle0, nparticles, g_dot_rvec_sin, g_dot_rvec_cos, error) + rho_tot_g, gcut, iparticle0, nparticles, g_dot_rvec_sin, g_dot_rvec_cos) REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT) :: dAm REAL(KIND=dp), DIMENSION(:, :), POINTER :: gfunc @@ -408,7 +399,6 @@ SUBROUTINE build_der_A_matrix_rows(dAm, gfunc, w, particle_set, radii,& INTEGER, INTENT(IN) :: iparticle0, nparticles REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: g_dot_rvec_sin, g_dot_rvec_cos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_der_A_matrix_rows', & routineP = moduleN//':'//routineN @@ -439,15 +429,15 @@ SUBROUTINE build_der_A_matrix_rows(dAm, gfunc, w, particle_set, radii,& igmax = ig ENDDO ALLOCATE(arg1_v_sin(s_dim:igmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Nr=SIZE(radii) Np=SIZE(particle_set) Ng=igmax-s_dim+1 ALLOCATE(lhs(nparticles*Nr,Ng), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rhs(Ng,Np*Nr), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! rhs with first term of sin(g.(rvec1-rvec2)), which used to be called arg1_v_sin() ! rhs has all parts that depend on iparticle2 @@ -505,13 +495,13 @@ SUBROUTINE build_der_A_matrix_rows(dAm, gfunc, w, particle_set, radii,& END DO DEALLOCATE(rhs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(lhs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !!! DEALLOCATE(arg1_v,stat=stat) - !!! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + !!! CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(arg1_v_sin,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE build_der_A_matrix_rows @@ -520,12 +510,10 @@ END SUBROUTINE build_der_A_matrix_rows !> \brief ... !> \param g_dot_rvec_sin ... !> \param g_dot_rvec_cos ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos, error) + SUBROUTINE cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos) REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: g_dot_rvec_sin, g_dot_rvec_cos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cleanup_g_dot_rvec_sin_cos', & routineP = moduleN//':'//routineN @@ -534,9 +522,9 @@ SUBROUTINE cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos, error) LOGICAL :: failure DEALLOCATE(g_dot_rvec_sin,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(g_dot_rvec_cos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE cleanup_g_dot_rvec_sin_cos !NB precompute sin(g.r) and cos(g.r) for quicker evaluations of sin(g.(r1-r2)) and cos(g.(r1-r2)) @@ -547,16 +535,14 @@ END SUBROUTINE cleanup_g_dot_rvec_sin_cos !> \param gcut ... !> \param g_dot_rvec_sin ... !> \param g_dot_rvec_cos ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos, error) + SUBROUTINE prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos) TYPE(pw_type), POINTER :: rho_tot_g TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set REAL(KIND=dp), INTENT(IN) :: gcut REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: g_dot_rvec_sin, g_dot_rvec_cos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'prep_g_dot_rvec_sin_cos', & routineP = moduleN//':'//routineN @@ -577,9 +563,9 @@ SUBROUTINE prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin ENDDO ALLOCATE(g_dot_rvec_sin(1:igmax-s_dim+1,SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(g_dot_rvec_cos(1:igmax-s_dim+1,SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iparticle=1, SIZE(particle_set) rvec = particle_set(iparticle)%r @@ -604,13 +590,12 @@ END SUBROUTINE prep_g_dot_rvec_sin_cos !> \param radii ... !> \param iw ... !> \param Vol ... -!> \param error ... !> \par History !> 12.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE ddapc_eval_AmI(GAmI, c0, gfunc, w, particle_set, gcut,& - rho_tot_g, radii, iw, Vol, error) + rho_tot_g, radii, iw, Vol) REAL(KIND=dp), DIMENSION(:, :), POINTER :: GAmI REAL(KIND=dp), INTENT(OUT) :: c0 REAL(KIND=dp), DIMENSION(:, :), POINTER :: gfunc @@ -622,7 +607,6 @@ SUBROUTINE ddapc_eval_AmI(GAmI, c0, gfunc, w, particle_set, gcut,& REAL(KIND=dp), DIMENSION(:), POINTER :: radii INTEGER, INTENT(IN) :: iw REAL(KIND=dp), INTENT(IN) :: Vol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ddapc_eval_AmI', & routineP = moduleN//':'//routineN @@ -641,30 +625,30 @@ SUBROUTINE ddapc_eval_AmI(GAmI, c0, gfunc, w, particle_set, gcut,& CALL timeset(routineN,handle) ndim = SIZE(particle_set)*SIZE(radii) ALLOCATE(Am(ndim, ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(AmI(ndim, ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(GAmI(ndim, ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Am = 0.0_dp AmI = 0.0_dp cv = 1.0_dp/Vol !NB precompute sin(g.r) and cos(g.r) for faster evaluation of cos(g.(r1-r2)) in build_A_matrix() - CALL prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos, error) - CALL build_A_matrix(Am, gfunc, w, particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos, error) - CALL cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos, error) + CALL prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos) + CALL build_A_matrix(Am, gfunc, w, particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos) + CALL cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos) Am(:,:) = Am(:,:) / (Vol*Vol) CALL mp_sum(Am,rho_tot_g%pw_grid%para%group) IF (iw>0) THEN ! Checking conditions numbers and eigenvalues ALLOCATE(Amw(ndim, ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(AmE(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Amw(:,:) = Am - CALL diamat_all(Amw, AmE,error=error) + CALL diamat_all(Amw, AmE) condition_number = MAXVAL(ABS(AmE))/MINVAL(ABS(AmE)) WRITE(iw,'(T3,A)')" Eigenvalues of Matrix A:" WRITE(iw,'(T3,4E15.8)') AmE @@ -674,22 +658,22 @@ SUBROUTINE ddapc_eval_AmI(GAmI, c0, gfunc, w, particle_set, gcut,& "WARNING: high condition number => possibly ill-conditioned matrix" END IF DEALLOCATE(Amw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(AmE, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL invert_matrix(Am, AmI, inv_error, "N",error=error, improve=.FALSE.) + CALL invert_matrix(Am, AmI, inv_error, "N",improve=.FALSE.) IF (iw>0) THEN WRITE(iw,'(T3,A,F15.9)')" Error inverting the A matrix: ", inv_error END IF c0 = DOT_PRODUCT(cv,MATMUL(AmI,cv)) DEALLOCATE(Am, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) GAmI = AmI DEALLOCATE(AmI, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE ddapc_eval_AmI @@ -704,14 +688,13 @@ END SUBROUTINE ddapc_eval_AmI !> \param particle_set ... !> \param M ... !> \param radii ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino !> \note NB receive cp_para_env for parallelization ! ***************************************************************************** RECURSIVE SUBROUTINE ewald_ddapc_pot(cp_para_env, coeff, factor, cell, multipole_section,& - particle_set, M, radii, error) + particle_set, M, radii) TYPE(cp_para_env_type), POINTER :: cp_para_env TYPE(pw_type), POINTER :: coeff REAL(KIND=dp), INTENT(IN) :: factor @@ -721,7 +704,6 @@ RECURSIVE SUBROUTINE ewald_ddapc_pot(cp_para_env, coeff, factor, cell, multipole POINTER :: particle_set REAL(KIND=dp), DIMENSION(:, :), POINTER :: M REAL(KIND=dp), DIMENSION(:), POINTER :: radii - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_ddapc_pot', & routineP = moduleN//':'//routineN @@ -739,14 +721,14 @@ RECURSIVE SUBROUTINE ewald_ddapc_pot(cp_para_env, coeff, factor, cell, multipole failure = .FALSE. NULLIFY(EwM) CALL timeset(routineN,handle) - CPPostcondition(.NOT.ASSOCIATED(M),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(radii),cp_failure_level,routineP,error,failure) - CPPostcondition(cell%orthorhombic,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(M),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(radii),cp_failure_level,routineP,failure) + CPPostcondition(cell%orthorhombic,cp_failure_level,routineP,failure) rcut = MIN(cell%hmat(1,1),cell%hmat(2,2),cell%hmat(3,3))/2.0_dp - CALL section_vals_val_get(multipole_section,"RCUT",n_rep_val=n_rep,error=error) - IF (n_rep==1) CALL section_vals_val_get(multipole_section,"RCUT",r_val=rcut,error=error) - CALL section_vals_val_get(multipole_section,"EWALD_PRECISION",r_val=eps,error=error) - CALL section_vals_val_get(multipole_section,"ANALYTICAL_GTERM",l_val=analyt,error=error) + CALL section_vals_val_get(multipole_section,"RCUT",n_rep_val=n_rep) + IF (n_rep==1) CALL section_vals_val_get(multipole_section,"RCUT",r_val=rcut) + CALL section_vals_val_get(multipole_section,"EWALD_PRECISION",r_val=eps) + CALL section_vals_val_get(multipole_section,"ANALYTICAL_GTERM",l_val=analyt) rcut2 = rcut**2 ! ! Setting-up parameters for Ewald summation @@ -771,9 +753,9 @@ RECURSIVE SUBROUTINE ewald_ddapc_pot(cp_para_env, coeff, factor, cell, multipole ewmdim = SIZE(particle_set) * (SIZE(particle_set)+1) / 2 ndim = SIZE(particle_set) * SIZE(radii) ALLOCATE(EwM(ewmdim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(M(ndim, ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) M = 0.0_dp ! idim = 0 @@ -839,7 +821,7 @@ RECURSIVE SUBROUTINE ewald_ddapc_pot(cp_para_env, coeff, factor, cell, multipole END DO END DO ELSE - g_ewald = Eval_Interp_Spl3_pbc(rvec, coeff, error) + g_ewald = Eval_Interp_Spl3_pbc(rvec, coeff) END IF ! ! G-EWALD, R-EWALD @@ -887,7 +869,7 @@ RECURSIVE SUBROUTINE ewald_ddapc_pot(cp_para_env, coeff, factor, cell, multipole END DO ! iparticle2 END DO ! iparticle1 DEALLOCATE(EwM, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE ewald_ddapc_pot @@ -898,18 +880,16 @@ END SUBROUTINE ewald_ddapc_pot !> \param particle_set ... !> \param M ... !> \param radii ... -!> \param error ... !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE solvation_ddapc_pot( solvation_section, particle_set, M, radii, error) + SUBROUTINE solvation_ddapc_pot( solvation_section, particle_set, M, radii) TYPE(section_vals_type), POINTER :: solvation_section TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set REAL(KIND=dp), DIMENSION(:, :), POINTER :: M REAL(KIND=dp), DIMENSION(:), POINTER :: radii - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'solvation_ddapc_pot', & routineP = moduleN//':'//routineN @@ -929,32 +909,28 @@ SUBROUTINE solvation_ddapc_pot( solvation_section, particle_set, M, radii, erro failure = .FALSE. fixed_center = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) ndim = SIZE(particle_set) * SIZE(radii) ALLOCATE(M(ndim, ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) M = 0.0_dp eps_in = 1.0_dp - CALL section_vals_val_get(solvation_section,"EPS_OUT",r_val=eps_out,error=error) - CALL section_vals_val_get(solvation_section,"LMAX",i_val=lmax,error=error) - CALL section_vals_val_get(solvation_section,"SPHERE%RADIUS",r_val=Rs,error=error) - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",n_rep_val=n_rep1,& - error=error) + CALL section_vals_val_get(solvation_section,"EPS_OUT",r_val=eps_out) + CALL section_vals_val_get(solvation_section,"LMAX",i_val=lmax) + CALL section_vals_val_get(solvation_section,"SPHERE%RADIUS",r_val=Rs) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",n_rep_val=n_rep1) IF (n_rep1/=0) THEN - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",r_vals=R0,& - error=error) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%XYZ",r_vals=R0) center = R0 ELSE CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%ATOM_LIST",& - n_rep_val=n_rep2,error=error) + n_rep_val=n_rep2) IF (n_rep2/=0) THEN - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%ATOM_LIST",i_vals=list,& - error=error) - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%WEIGHT_TYPE",i_val=weight,& - error=error) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%ATOM_LIST",i_vals=list) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%WEIGHT_TYPE",i_val=weight) ALLOCATE(R0(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE(weight) CASE (weight_type_unit) R0 = 0.0_dp @@ -972,25 +948,24 @@ SUBROUTINE solvation_ddapc_pot( solvation_section, particle_set, M, radii, erro R0 = R0 / mass END SELECT center = R0 - CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%FIXED",l_val=fixed_center,& - error=error) + CALL section_vals_val_get(solvation_section,"SPHERE%CENTER%FIXED",l_val=fixed_center) IF (fixed_center) THEN CALL section_vals_val_set(solvation_section,"SPHERE%CENTER%XYZ",& - r_vals_ptr=R0,error=error) + r_vals_ptr=R0) ELSE DEALLOCATE(R0, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END IF - CPPostcondition(n_rep1/=0.OR.n_rep2/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(n_rep1/=0.OR.n_rep2/=0,cp_failure_level,routineP,failure) ! Potential calculation ALLOCATE(LocP(0:lmax,SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pos(SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cost(SIZE(particle_set),SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Determining the single atomic contribution to the dielectric dipole DO i = 1, SIZE(particle_set) rvec = particle_set(i)%r-center @@ -1001,7 +976,7 @@ SUBROUTINE solvation_ddapc_pot( solvation_section, particle_set, M, radii, erro WRITE(output_unit,'(A,I6,A)')"Atom number :: ",i," is out of the solvation sphere" WRITE(output_unit,'(2(A,F12.6))')"Distance from the center::",r1," Radius of the sphere::",rs END IF - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF LocP(:,i) = 0.0_dp IF (r1/=0.0_dp) THEN @@ -1052,11 +1027,11 @@ SUBROUTINE solvation_ddapc_pot( solvation_section, particle_set, M, radii, erro END DO END DO DEALLOCATE(cost,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(LocP,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE solvation_ddapc_pot END MODULE cp_ddapc_methods diff --git a/src/cp_ddapc_types.F b/src/cp_ddapc_types.F index 65324c0b54..53ca473d30 100644 --- a/src/cp_ddapc_types.F +++ b/src/cp_ddapc_types.F @@ -89,13 +89,12 @@ MODULE cp_ddapc_types !> \param iw2 ... !> \param Vol ... !> \param force_env_section ... -!> \param error ... !> \author Tedoro Laino !> \note NB receive cp_para_env to pass down to parallelized ewald_ddapc_pot() ! ***************************************************************************** SUBROUTINE cp_ddapc_create(cp_para_env, cp_ddapc_env, cp_ddapc_ewald, & particle_set, radii, cell, super_cell, rho_tot_g, gcut, iw2, Vol, & - force_env_section, error) + force_env_section) TYPE(cp_para_env_type), POINTER :: cp_para_env TYPE(cp_ddapc_type), POINTER :: cp_ddapc_env TYPE(cp_ddapc_ewald_type), POINTER :: cp_ddapc_ewald @@ -108,7 +107,6 @@ SUBROUTINE cp_ddapc_create(cp_para_env, cp_ddapc_env, cp_ddapc_ewald, & INTEGER, INTENT(IN) :: iw2 REAL(KIND=dp), INTENT(IN) :: Vol TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_create', & routineP = moduleN//':'//routineN @@ -121,7 +119,7 @@ SUBROUTINE cp_ddapc_create(cp_para_env, cp_ddapc_env, cp_ddapc_ewald, & failure=.FALSE. CALL timeset(routineN,handle) ALLOCATE(cp_ddapc_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cp_ddapc_env%ref_count=1 last_cp_ddapc_id=last_cp_ddapc_id+1 cp_ddapc_env%id_nr=last_cp_ddapc_id @@ -133,7 +131,7 @@ SUBROUTINE cp_ddapc_create(cp_para_env, cp_ddapc_env, cp_ddapc_ewald, & cp_ddapc_env%gfunc,& cp_ddapc_env%w) ! Evaluates gfunc and AmI - CALL ddapc_eval_gfunc(cp_ddapc_env%gfunc, cp_ddapc_env%w, gcut, rho_tot_g, radii, error) + CALL ddapc_eval_gfunc(cp_ddapc_env%gfunc, cp_ddapc_env%w, gcut, rho_tot_g, radii) CALL ddapc_eval_AmI(cp_ddapc_env%AmI,& cp_ddapc_env%c0,& cp_ddapc_env%gfunc,& @@ -143,7 +141,7 @@ SUBROUTINE cp_ddapc_create(cp_para_env, cp_ddapc_env, cp_ddapc_ewald, & rho_tot_g,& radii,& iw2,& - Vol, error) + Vol) IF ( cp_ddapc_ewald%do_qmmm_periodic_decpl.OR.& cp_ddapc_ewald%do_decoupling) THEN ! @@ -157,10 +155,10 @@ SUBROUTINE cp_ddapc_create(cp_para_env, cp_ddapc_env, cp_ddapc_ewald, & param_section,& particle_set,& cp_ddapc_env%Md,& - radii, error) + radii) IF ( cp_ddapc_ewald%do_qmmm_periodic_decpl.OR.cp_ddapc_ewald%do_decoupling) THEN ALLOCATE(cp_ddapc_env%Mt(SIZE(cp_ddapc_env%Md,1),SIZE(cp_ddapc_env%Md,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF ( cp_ddapc_ewald%do_decoupling) THEN ! Just decoupling cp_ddapc_env%Mt = cp_ddapc_env%Md @@ -168,17 +166,16 @@ SUBROUTINE cp_ddapc_create(cp_para_env, cp_ddapc_env, cp_ddapc_ewald, & ! QMMM periodic calculation !NB parallelized ewald_ddapc_pot() needs cp_para_env CALL ewald_ddapc_pot(cp_para_env, cp_ddapc_ewald%coeff_mm,-1.0_dp, super_cell, param_section,& - particle_set, cp_ddapc_env%Mr, radii, error) + particle_set, cp_ddapc_env%Mr, radii) cp_ddapc_env%Mt = cp_ddapc_env%Md + cp_ddapc_env%Mr END IF END IF END IF IF ( cp_ddapc_ewald%do_solvation) THEN ! Spherical Solvation model - solvation_section => section_vals_get_subs_vals(force_env_section,"DFT%SCRF",& - error=error) + solvation_section => section_vals_get_subs_vals(force_env_section,"DFT%SCRF") CALL solvation_ddapc_pot(solvation_section,& - particle_set, cp_ddapc_env%Ms, radii, error) + particle_set, cp_ddapc_env%Ms, radii) END IF CALL timestop(handle) END SUBROUTINE cp_ddapc_create @@ -186,14 +183,12 @@ END SUBROUTINE cp_ddapc_create ! ***************************************************************************** !> \brief ... !> \param cp_ddapc_env ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - [tlaino] ! ***************************************************************************** - SUBROUTINE cp_ddapc_retain(cp_ddapc_env, error) + SUBROUTINE cp_ddapc_retain(cp_ddapc_env) TYPE(cp_ddapc_type), POINTER :: cp_ddapc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_retain', & routineP = moduleN//':'//routineN @@ -201,22 +196,20 @@ SUBROUTINE cp_ddapc_retain(cp_ddapc_env, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(cp_ddapc_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(cp_ddapc_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(cp_ddapc_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(cp_ddapc_env%ref_count>0,cp_failure_level,routineP) cp_ddapc_env%ref_count=cp_ddapc_env%ref_count+1 END SUBROUTINE cp_ddapc_retain ! ***************************************************************************** !> \brief ... !> \param cp_ddapc_env ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - [tlaino] ! ***************************************************************************** - SUBROUTINE cp_ddapc_release(cp_ddapc_env, error) + SUBROUTINE cp_ddapc_release(cp_ddapc_env) TYPE(cp_ddapc_type), POINTER :: cp_ddapc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_release', & routineP = moduleN//':'//routineN @@ -226,36 +219,36 @@ SUBROUTINE cp_ddapc_release(cp_ddapc_env, error) failure=.FALSE. IF (ASSOCIATED(cp_ddapc_env)) THEN - CPPreconditionNoFail(cp_ddapc_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(cp_ddapc_env%ref_count>0,cp_failure_level,routineP) cp_ddapc_env%ref_count=cp_ddapc_env%ref_count-1 IF (cp_ddapc_env%ref_count==0) THEN IF (ASSOCIATED(cp_ddapc_env%AmI)) THEN DEALLOCATE(cp_ddapc_env%AmI, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(cp_ddapc_env%Mt)) THEN DEALLOCATE(cp_ddapc_env%Mt, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(cp_ddapc_env%Md)) THEN DEALLOCATE(cp_ddapc_env%Md, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(cp_ddapc_env%Mr)) THEN DEALLOCATE(cp_ddapc_env%Mr, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(cp_ddapc_env%Ms)) THEN DEALLOCATE(cp_ddapc_env%Ms, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(cp_ddapc_env%gfunc)) THEN DEALLOCATE(cp_ddapc_env%gfunc, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(cp_ddapc_env%w)) THEN DEALLOCATE(cp_ddapc_env%w, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF NULLIFY(cp_ddapc_env%AmI,& cp_ddapc_env%Md,& @@ -264,7 +257,7 @@ SUBROUTINE cp_ddapc_release(cp_ddapc_env, error) cp_ddapc_env%gfunc,& cp_ddapc_env%w) DEALLOCATE(cp_ddapc_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(cp_ddapc_env) END IF END IF @@ -278,20 +271,18 @@ END SUBROUTINE cp_ddapc_release !> \param force_env_section ... !> \param subsys_section ... !> \param para_env ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - [tlaino] ! ***************************************************************************** SUBROUTINE cp_ddapc_ewald_create(cp_ddapc_ewald, qmmm_decoupl, qm_cell,& - force_env_section, subsys_section, para_env, error) + force_env_section, subsys_section, para_env) TYPE(cp_ddapc_ewald_type), POINTER :: cp_ddapc_ewald LOGICAL, INTENT(IN) :: qmmm_decoupl TYPE(cell_type), POINTER :: qm_cell TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_ewald_create', & routineP = moduleN//':'//routineN @@ -310,11 +301,11 @@ SUBROUTINE cp_ddapc_ewald_create(cp_ddapc_ewald, qmmm_decoupl, qm_cell,& restraint_section, restraint_sectionB, solvation_section failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(.NOT.ASSOCIATED(cp_ddapc_ewald),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(cp_ddapc_ewald),cp_failure_level,routineP,failure) ALLOCATE(cp_ddapc_ewald, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(cp_ddapc_ewald%pw_grid_mm,& cp_ddapc_ewald%pw_grid_qm,& cp_ddapc_ewald%ewald_section,& @@ -324,21 +315,21 @@ SUBROUTINE cp_ddapc_ewald_create(cp_ddapc_ewald, qmmm_decoupl, qm_cell,& cp_ddapc_ewald%coeff_qm) NULLIFY(multipole_section) - poisson_section => section_vals_get_subs_vals(force_env_section,"DFT%POISSON", error=error) - solvation_section => section_vals_get_subs_vals(force_env_section,"DFT%SCRF", error=error) - qmmm_per_section => section_vals_get_subs_vals(force_env_section,"QMMM%PERIODIC", error=error) - printC_section => section_vals_get_subs_vals(force_env_section,"PROPERTIES%FIT_CHARGE",error=error) - restraint_section => section_vals_get_subs_vals(force_env_section,"DFT%QS%DDAPC_RESTRAINT",error=error) + poisson_section => section_vals_get_subs_vals(force_env_section,"DFT%POISSON") + solvation_section => section_vals_get_subs_vals(force_env_section,"DFT%SCRF") + qmmm_per_section => section_vals_get_subs_vals(force_env_section,"QMMM%PERIODIC") + printC_section => section_vals_get_subs_vals(force_env_section,"PROPERTIES%FIT_CHARGE") + restraint_section => section_vals_get_subs_vals(force_env_section,"DFT%QS%DDAPC_RESTRAINT") restraint_sectionB => section_vals_get_subs_vals(force_env_section,& - "PROPERTIES%ET_COUPLING%DDAPC_RESTRAINT_A",error=error) - CALL section_vals_get(solvation_section,explicit=do_solvation, error=error) - CALL section_vals_get(poisson_section,explicit=decoupling, error=error) - CALL section_vals_get(restraint_section,explicit=do_restraint, error=error) - CALL section_vals_get(restraint_sectionB,explicit=do_restraintB, error=error) + "PROPERTIES%ET_COUPLING%DDAPC_RESTRAINT_A") + CALL section_vals_get(solvation_section,explicit=do_solvation) + CALL section_vals_get(poisson_section,explicit=decoupling) + CALL section_vals_get(restraint_section,explicit=do_restraint) + CALL section_vals_get(restraint_sectionB,explicit=do_restraintB) do_qmmm_periodic_decpl = qmmm_decoupl cp_ddapc_ewald%do_solvation = do_solvation cp_ddapc_ewald%do_qmmm_periodic_decpl = do_qmmm_periodic_decpl - cp_ddapc_ewald%do_property = cp_printkey_is_on(logger%iter_info,printC_section,error) + cp_ddapc_ewald%do_property = cp_printkey_is_on(logger%iter_info,printC_section) cp_ddapc_ewald%do_restraint = do_restraint.OR.do_restraintB ! Determining the tasks and further check IF (do_qmmm_periodic_decpl.AND.decoupling) THEN @@ -352,10 +343,10 @@ SUBROUTINE cp_ddapc_ewald_create(cp_ddapc_ewald, qmmm_decoupl, qm_cell,& END IF IF (decoupling) THEN ! Simple decoupling technique - CALL section_vals_val_get(poisson_section,"POISSON_SOLVER",i_val=my_val,error=error) + CALL section_vals_val_get(poisson_section,"POISSON_SOLVER",i_val=my_val) SELECT CASE (my_val) CASE (pw_poisson_multipole) - multipole_section => section_vals_get_subs_vals(poisson_section,"MULTIPOLE", error=error) + multipole_section => section_vals_get_subs_vals(poisson_section,"MULTIPOLE") CASE DEFAULT decoupling = .FALSE. END SELECT @@ -363,54 +354,54 @@ SUBROUTINE cp_ddapc_ewald_create(cp_ddapc_ewald, qmmm_decoupl, qm_cell,& cp_ddapc_ewald%do_decoupling = decoupling IF (cp_ddapc_ewald%do_qmmm_periodic_decpl) THEN ! QMMM periodic - multipole_section => section_vals_get_subs_vals(qmmm_per_section,"MULTIPOLE", error=error) + multipole_section => section_vals_get_subs_vals(qmmm_per_section,"MULTIPOLE") END IF cp_ddapc_ewald%ewald_section => multipole_section IF (cp_ddapc_ewald%do_decoupling.OR.cp_ddapc_ewald%do_qmmm_periodic_decpl) THEN ! Do we do the calculation analytically or interpolating the g-space factor? - CALL section_vals_val_get(multipole_section,"ANALYTICAL_GTERM",l_val=analyt,error=error) + CALL section_vals_val_get(multipole_section,"ANALYTICAL_GTERM",l_val=analyt) IF (.NOT.analyt) THEN - CALL section_vals_val_get(multipole_section,"ngrids", i_vals=ngrids, error=error) + CALL section_vals_val_get(multipole_section,"ngrids", i_vals=ngrids) npts = ngrids NULLIFY(LG, gx, gy, gz) hmat = qm_cell%hmat - CALL eval_lg(multipole_section, hmat, qm_cell%deth, LG, gx, gy, gz, error) - grid_print_section=> section_vals_get_subs_vals(force_env_section,"PRINT%GRID_INFORMATION",error=error) + CALL eval_lg(multipole_section, hmat, qm_cell%deth, LG, gx, gy, gz) + grid_print_section=> section_vals_get_subs_vals(force_env_section,"PRINT%GRID_INFORMATION") CALL Setup_Ewald_Spline(pw_grid=cp_ddapc_ewald%pw_grid_qm,pw_pool=cp_ddapc_ewald%pw_pool_qm,& coeff=cp_ddapc_ewald%coeff_qm, LG=LG, gx=gx, gy=gy, gz=gz, hmat=hmat, npts=npts,& - param_section=multipole_section,tag="ddapc",para_env=para_env,print_section=grid_print_section, error=error) + param_section=multipole_section,tag="ddapc",para_env=para_env,print_section=grid_print_section) DEALLOCATE(LG, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gx, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gy, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gz, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(LG, gx, gy, gz) IF (cp_ddapc_ewald%do_qmmm_periodic_decpl) THEN NULLIFY(mm_cell, dummy_cell) - cell_section => section_vals_get_subs_vals(subsys_section,"CELL",error=error) - CALL read_cell(mm_cell, dummy_cell, cell_section=cell_section, para_env=para_env, error=error) + cell_section => section_vals_get_subs_vals(subsys_section,"CELL") + CALL read_cell(mm_cell, dummy_cell, cell_section=cell_section, para_env=para_env) hmat = mm_cell%hmat - CALL eval_lg(multipole_section, hmat, mm_cell%deth, LG, gx, gy, gz, error) - grid_print_section=> section_vals_get_subs_vals(force_env_section,"PRINT%GRID_INFORMATION",error=error) + CALL eval_lg(multipole_section, hmat, mm_cell%deth, LG, gx, gy, gz) + grid_print_section=> section_vals_get_subs_vals(force_env_section,"PRINT%GRID_INFORMATION") CALL Setup_Ewald_Spline(pw_grid=cp_ddapc_ewald%pw_grid_mm,pw_pool=cp_ddapc_ewald%pw_pool_mm,& coeff=cp_ddapc_ewald%coeff_mm, LG=LG, gx=gx, gy=gy, gz=gz, hmat=hmat, npts=npts,& param_section=multipole_section,tag="ddapc",para_env=para_env, & - print_section=grid_print_section, error=error) + print_section=grid_print_section) DEALLOCATE(LG, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gx, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gy, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gz, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(LG, gx, gy, gz) - CALL cell_release(dummy_cell, error) - CALL cell_release(mm_cell, error) + CALL cell_release(dummy_cell) + CALL cell_release(mm_cell) END IF END IF END IF @@ -425,16 +416,14 @@ END SUBROUTINE cp_ddapc_ewald_create !> \param gx ... !> \param gy ... !> \param gz ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - [tlaino] ! ***************************************************************************** - SUBROUTINE eval_lg(multipole_section, hmat, deth, LG, gx, gy, gz, error) + SUBROUTINE eval_lg(multipole_section, hmat, deth, LG, gx, gy, gz) TYPE(section_vals_type), POINTER :: multipole_section REAL(KIND=dp), INTENT(IN) :: hmat(3,3), deth REAL(KIND=dp), DIMENSION(:), POINTER :: LG, gx, gy, gz - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eval_lg', & routineP = moduleN//':'//routineN @@ -448,9 +437,9 @@ SUBROUTINE eval_lg(multipole_section, hmat, deth, LG, gx, gy, gz, error) failure = .FALSE. rcut = MIN(hmat(1,1),hmat(2,2),hmat(3,3))/2.0_dp - CALL section_vals_val_get(multipole_section,"RCUT",n_rep_val=n_rep,error=error) - IF (n_rep==1) CALL section_vals_val_get(multipole_section,"RCUT",r_val=rcut,error=error) - CALL section_vals_val_get(multipole_section,"EWALD_PRECISION",r_val=eps,error=error) + CALL section_vals_val_get(multipole_section,"RCUT",n_rep_val=n_rep) + IF (n_rep==1) CALL section_vals_val_get(multipole_section,"RCUT",r_val=rcut) + CALL section_vals_val_get(multipole_section,"EWALD_PRECISION",r_val=eps) eps = MIN(ABS(eps),0.5_dp) tol = SQRT(ABS(LOG(eps*rcut))) alpha = SQRT(ABS(LOG(eps*rcut*tol)))/rcut @@ -463,13 +452,13 @@ SUBROUTINE eval_lg(multipole_section, hmat, deth, LG, gx, gy, gz, error) fvec = 2.0_dp * pi / (/hmat(1,1),hmat(2,2),hmat(3,3)/) ndim = (nmax1+1)*(2*nmax2+1)*(2*nmax3+1)-1 ALLOCATE(LG(ndim), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gx(ndim), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gy(ndim), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gz(ndim), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) i = 0 DO k1 = 0, nmax1 @@ -493,14 +482,12 @@ END SUBROUTINE eval_lg ! ***************************************************************************** !> \brief ... !> \param cp_ddapc_ewald ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - [tlaino] ! ***************************************************************************** - SUBROUTINE cp_ddapc_ewald_release(cp_ddapc_ewald, error) + SUBROUTINE cp_ddapc_ewald_release(cp_ddapc_ewald) TYPE(cp_ddapc_ewald_type), POINTER :: cp_ddapc_ewald - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_ewald_release', & routineP = moduleN//':'//routineN @@ -511,29 +498,29 @@ SUBROUTINE cp_ddapc_ewald_release(cp_ddapc_ewald, error) failure = .FALSE. IF (ASSOCIATED(cp_ddapc_ewald)) THEN IF (ASSOCIATED(cp_ddapc_ewald%coeff_qm)) THEN - CALL pw_pool_give_back_pw ( cp_ddapc_ewald%pw_pool_qm, cp_ddapc_ewald%coeff_qm ,error=error) + CALL pw_pool_give_back_pw ( cp_ddapc_ewald%pw_pool_qm, cp_ddapc_ewald%coeff_qm) END IF IF (ASSOCIATED(cp_ddapc_ewald%coeff_mm)) THEN - CALL pw_pool_give_back_pw ( cp_ddapc_ewald%pw_pool_mm, cp_ddapc_ewald%coeff_mm ,error=error) + CALL pw_pool_give_back_pw ( cp_ddapc_ewald%pw_pool_mm, cp_ddapc_ewald%coeff_mm) END IF IF (ASSOCIATED(cp_ddapc_ewald%pw_pool_qm)) THEN - CALL pw_pool_release ( cp_ddapc_ewald%pw_pool_qm, error=error) - CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_pool_qm),cp_failure_level,routineP,error) + CALL pw_pool_release ( cp_ddapc_ewald%pw_pool_qm) + CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_pool_qm),cp_failure_level,routineP) END IF IF (ASSOCIATED(cp_ddapc_ewald%pw_pool_mm)) THEN - CALL pw_pool_release ( cp_ddapc_ewald%pw_pool_mm, error=error) - CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_pool_mm),cp_failure_level,routineP,error) + CALL pw_pool_release ( cp_ddapc_ewald%pw_pool_mm) + CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_pool_mm),cp_failure_level,routineP) END IF IF (ASSOCIATED(cp_ddapc_ewald%pw_grid_qm)) THEN - CALL pw_grid_release ( cp_ddapc_ewald%pw_grid_qm, error=error) - CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_grid_qm),cp_failure_level,routineP,error) + CALL pw_grid_release ( cp_ddapc_ewald%pw_grid_qm) + CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_grid_qm),cp_failure_level,routineP) END IF IF (ASSOCIATED(cp_ddapc_ewald%pw_grid_mm)) THEN - CALL pw_grid_release ( cp_ddapc_ewald%pw_grid_mm, error=error) - CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_grid_mm),cp_failure_level,routineP,error) + CALL pw_grid_release ( cp_ddapc_ewald%pw_grid_mm) + CPPostconditionNoFail(.NOT.ASSOCIATED(cp_ddapc_ewald%pw_grid_mm),cp_failure_level,routineP) END IF DEALLOCATE(cp_ddapc_ewald, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(cp_ddapc_ewald) END IF diff --git a/src/cp_ddapc_util.F b/src/cp_ddapc_util.F index e9a60b81c8..2f13a9b5f9 100644 --- a/src/cp_ddapc_util.F +++ b/src/cp_ddapc_util.F @@ -75,14 +75,12 @@ MODULE cp_ddapc_util ! ***************************************************************************** !> \brief Initialize the cp_ddapc_environment !> \param qs_env ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE cp_ddapc_init(qs_env, error) + SUBROUTINE cp_ddapc_init(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_ddapc_init', & routineP = moduleN//':'//routineN @@ -109,11 +107,11 @@ SUBROUTINE cp_ddapc_init(qs_env, error) CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(dft_control, rho, rho_tot_g, rho_core, rho0_s_gs, pw_env,& radii, inp_radii, particle_set, qs_charges, para_env) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) allocate_ddapc_env = qs_env%cp_ddapc_ewald%do_solvation.OR.& qs_env%cp_ddapc_ewald%do_qmmm_periodic_decpl.OR.& qs_env%cp_ddapc_ewald%do_decoupling.OR.& @@ -123,7 +121,7 @@ SUBROUTINE cp_ddapc_init(qs_env, error) IF (allocate_ddapc_env.AND.unimplemented) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="DDAP charges work only with GPW/GAPW code.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF allocate_ddapc_env = allocate_ddapc_env .OR.& qs_env%cp_ddapc_ewald%do_property @@ -139,42 +137,41 @@ SUBROUTINE cp_ddapc_init(qs_env, error) particle_set=particle_set,& cell=cell,& super_cell=super_cell,& - para_env=para_env,& - error=error) - density_fit_section => section_vals_get_subs_vals(qs_env%input,"DFT%DENSITY_FITTING", error=error) + para_env=para_env) + density_fit_section => section_vals_get_subs_vals(qs_env%input,"DFT%DENSITY_FITTING") iw=cp_print_key_unit_nr(logger,density_fit_section,& - "PROGRAM_RUN_INFO",".FitCharge",error=error) + "PROGRAM_RUN_INFO",".FitCharge") IF (iw>0) THEN WRITE(iw,'(/,A)')" Initializing the DDAPC Environment" END IF - CALL pw_env_get(pw_env=pw_env,auxbas_pw_pool=auxbas_pool,error=error) + CALL pw_env_get(pw_env=pw_env,auxbas_pw_pool=auxbas_pool) CALL pw_pool_create_pw(auxbas_pool,rho_tot_g, in_space=RECIPROCALSPACE,& - use_data=COMPLEXDATA1D, error=error) + use_data=COMPLEXDATA1D) Vol = rho_tot_g%pw_grid%vol ! ! Get Input Parameters ! - CALL section_vals_val_get(density_fit_section,"RADII",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(density_fit_section,"RADII",n_rep_val=n_rep_val) IF (n_rep_val /= 0) THEN - CALL section_vals_val_get(density_fit_section,"RADII",r_vals=inp_radii,error=error) + CALL section_vals_val_get(density_fit_section,"RADII",r_vals=inp_radii) num_gauss = SIZE(inp_radii) ALLOCATE(radii(num_gauss), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) radii = inp_radii ELSE - CALL section_vals_val_get(density_fit_section,"NUM_GAUSS",i_val=num_gauss,error=error) - CALL section_vals_val_get(density_fit_section,"MIN_RADIUS",r_val=rcmin,error=error) - CALL section_vals_val_get(density_fit_section,"PFACTOR",r_val=pfact,error=error) + CALL section_vals_val_get(density_fit_section,"NUM_GAUSS",i_val=num_gauss) + CALL section_vals_val_get(density_fit_section,"MIN_RADIUS",r_val=rcmin) + CALL section_vals_val_get(density_fit_section,"PFACTOR",r_val=pfact) ALLOCATE(radii(num_gauss), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, num_gauss radii(i) = rcmin*pfact**(i-1) END DO END IF - CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut,error=error) + CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut) ! Create DDAPC environment iw2=cp_print_key_unit_nr(logger,density_fit_section,& - "PROGRAM_RUN_INFO/CONDITION_NUMBER",".FitCharge",error=error) + "PROGRAM_RUN_INFO/CONDITION_NUMBER",".FitCharge") ! Initialization of the cp_ddapc_env and of the cp_ddapc_ewald environment !NB pass qs_env%para_env for parallelization of ewald_ddapc_pot() CALL cp_ddapc_create(para_env,& @@ -188,14 +185,13 @@ SUBROUTINE cp_ddapc_init(qs_env, error) gcut,& iw2,& Vol, & - qs_env%input,& - error) + qs_env%input) CALL cp_print_key_finished_output(iw2,logger,density_fit_section,& - "PROGRAM_RUN_INFO/CONDITION_NUMBER",error=error) + "PROGRAM_RUN_INFO/CONDITION_NUMBER") DEALLOCATE(radii, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL pw_pool_give_back_pw(auxbas_pool,rho_tot_g,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) END IF CALL timestop(handle) END SUBROUTINE cp_ddapc_init @@ -213,14 +209,13 @@ END SUBROUTINE cp_ddapc_init !> \param ext_rho_tot_g ... !> \param Itype_of_density ... !> \param iwc ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& density_type,qout1, qout2, out_radii, dq_out, ext_rho_tot_g,& - Itype_of_density,iwc, error) + Itype_of_density,iwc) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in), OPTIONAL :: calc_force TYPE(section_vals_type), POINTER :: density_fit_section @@ -232,7 +227,6 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& TYPE(pw_type), OPTIONAL, POINTER :: ext_rho_tot_g CHARACTER(LEN=*), OPTIONAL :: Itype_of_density INTEGER, INTENT(IN), OPTIONAL :: iwc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_ddapc', & routineP = moduleN//':'//routineN @@ -278,7 +272,7 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& failure = .FALSE. need_f = .FALSE. IF (PRESENT(calc_force)) need_f = calc_force - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(dft_control, rho, rho_tot_g, rho_core, rho0_s_gs, pw_env, rho_g, rho_r,& radii, inp_radii, particle_set, qs_kind_set, qs_charges, cp_ddapc_env) CALL get_qs_env(qs_env=qs_env,& @@ -291,48 +285,46 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& particle_set=particle_set,& qs_kind_set=qs_kind_set,& cell=cell,& - super_cell=super_cell,& - error=error) + super_cell=super_cell) - CALL qs_rho_get(rho, rho_r=rho_r, rho_g=rho_g, error=error) + CALL qs_rho_get(rho, rho_r=rho_r, rho_g=rho_g) IF (PRESENT(iwc)) THEN iw = iwc ELSE iw=cp_print_key_unit_nr(logger,density_fit_section,& - "PROGRAM_RUN_INFO",".FitCharge",error=error) + "PROGRAM_RUN_INFO",".FitCharge") END IF CALL pw_env_get(pw_env=pw_env,& - auxbas_pw_pool=auxbas_pool,& - error=error) + auxbas_pw_pool=auxbas_pool) CALL pw_pool_create_pw(auxbas_pool,rho_tot_g, in_space=RECIPROCALSPACE,& - use_data=COMPLEXDATA1D, error=error) + use_data=COMPLEXDATA1D) IF (PRESENT(ext_rho_tot_g)) THEN ! If provided use the input density in g-space - CALL pw_transfer(ext_rho_tot_g,rho_tot_g, error=error) + CALL pw_transfer(ext_rho_tot_g,rho_tot_g) type_of_density=Itype_of_density ELSE IF(PRESENT(density_type))THEN myid=density_type ELSE CALL section_vals_val_get(qs_env%input,& - "PROPERTIES%FIT_CHARGE%TYPE_OF_DENSITY",i_val=myid,error=error) + "PROPERTIES%FIT_CHARGE%TYPE_OF_DENSITY",i_val=myid) END IF SELECT CASE(myid) CASE(do_full_density) ! Otherwise build the total QS density (electron+nuclei) in G-space IF(dft_control%qs_control%gapw) THEN - CALL pw_transfer(rho0_s_gs%pw,rho_tot_g, error=error) + CALL pw_transfer(rho0_s_gs%pw,rho_tot_g) ELSE - CALL pw_transfer(rho_core%pw,rho_tot_g, error=error) + CALL pw_transfer(rho_core%pw,rho_tot_g) END IF DO ispin=1,SIZE(rho_g) - CALL pw_axpy(rho_g(ispin)%pw,rho_tot_g, error=error) + CALL pw_axpy(rho_g(ispin)%pw,rho_tot_g) END DO type_of_density = "FULL DENSITY" CASE(do_spin_density) - CALL pw_copy (rho_g(1)%pw,rho_tot_g, error=error) - CALL pw_axpy (rho_g(2)%pw,rho_tot_g,alpha=-1._dp, error=error) + CALL pw_copy (rho_g(1)%pw,rho_tot_g) + CALL pw_axpy (rho_g(2)%pw,rho_tot_g,alpha=-1._dp) type_of_density = "SPIN DENSITY" END SELECT END IF @@ -344,19 +336,19 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& ! ! Get Input Parameters ! - CALL section_vals_val_get(density_fit_section,"RADII",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(density_fit_section,"RADII",n_rep_val=n_rep_val) IF (n_rep_val /= 0) THEN - CALL section_vals_val_get(density_fit_section,"RADII",r_vals=inp_radii,error=error) + CALL section_vals_val_get(density_fit_section,"RADII",r_vals=inp_radii) num_gauss = SIZE(inp_radii) ALLOCATE(radii(num_gauss), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) radii = inp_radii ELSE - CALL section_vals_val_get(density_fit_section,"NUM_GAUSS",i_val=num_gauss,error=error) - CALL section_vals_val_get(density_fit_section,"MIN_RADIUS",r_val=rcmin,error=error) - CALL section_vals_val_get(density_fit_section,"PFACTOR",r_val=pfact,error=error) + CALL section_vals_val_get(density_fit_section,"NUM_GAUSS",i_val=num_gauss) + CALL section_vals_val_get(density_fit_section,"MIN_RADIUS",r_val=rcmin) + CALL section_vals_val_get(density_fit_section,"PFACTOR",r_val=pfact) ALLOCATE(radii(num_gauss), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, num_gauss radii(i) = rcmin*pfact**(i-1) END DO @@ -364,31 +356,31 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& IF (PRESENT(out_radii)) THEN IF (ASSOCIATED(out_radii)) THEN DEALLOCATE(out_radii, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE(out_radii(SIZE(radii)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) out_radii = radii END IF - CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut,error=error) + CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut) cp_ddapc_env => qs_env%cp_ddapc_env ! ! Start with the linear system ! ndim = SIZE(particle_set)*SIZE(radii) ALLOCATE(bv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(qv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(qtot(SIZE(particle_set)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timeset(routineN//"-charges",handle2) bv(:) = 0.0_dp cv(:) = 1.0_dp/Vol CALL build_b_vector(bv, cp_ddapc_env%gfunc, cp_ddapc_env%w,& - particle_set, radii, rho_tot_g, gcut, error); bv(:) = bv(:) / Vol + particle_set, radii, rho_tot_g, gcut); bv(:) = bv(:) / Vol CALL mp_sum(bv,rho_tot_g%pw_grid%para%group) c1 = DOT_PRODUCT(cv,MATMUL(cp_ddapc_env%AmI,bv))-ch_dens c1 = c1 / cp_ddapc_env%c0 @@ -403,24 +395,24 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& END DO IF (PRESENT(qout1)) THEN IF (ASSOCIATED(qout1)) THEN - CPPostcondition(SIZE(qout1)==SIZE(qv),cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(qout1)==SIZE(qv),cp_failure_level,routineP,failure) ELSE ALLOCATE(qout1(SIZE(qv)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF qout1 = qv END IF IF (PRESENT(qout2)) THEN IF (ASSOCIATED(qout2)) THEN - CPPostcondition(SIZE(qout2)==SIZE(qtot),cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(qout2)==SIZE(qtot),cp_failure_level,routineP,failure) ELSE ALLOCATE(qout2(SIZE(qtot)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF qout2 = qtot END IF CALL print_atomic_charges(particle_set,qs_kind_set, iw,title=" DDAP "//& - TRIM(type_of_density)//" charges:",atomic_charges=qtot,error=error) + TRIM(type_of_density)//" charges:",atomic_charges=qtot) CALL timestop(handle2) ! ! If requested evaluate also the correction to derivatives due to Pulay Forces @@ -431,31 +423,31 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& WRITE(iw,'(T3,A)')" Evaluating DDAPC atomic derivatives .." END IF ALLOCATE(dAm(ndim, ndim,3), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dbv(ndim,3), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dqv(ndim,SIZE(particle_set),3), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !NB refactor math in inner loop - no more dqv0, but new temporaries instead ALLOCATE(cvT_AmI(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cvT_AmI_dAmj(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tv(ndim,SIZE(particle_set),3), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(AmI_cv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cvT_AmI(:) = MATMUL(cv, cp_ddapc_env%AmI) AmI_cv(:) = MATMUL(cp_ddapc_env%AmI,cv) ALLOCATE(dAmj_qv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(AmI_bv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) AmI_bv(:) = MATMUL(cp_ddapc_env%AmI,bv) !NB call routine to precompute sin(g.r) and cos(g.r), ! so it doesn't have to be done for each r_i-r_j pair in build_der_A_matrix_rows() - CALL prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos, error) + CALL prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos) !NB do build_der_A_matrix_rows in blocks, for more efficient use of DGEMM #define NPSET 100 DO iparticle0 = 1, SIZE(particle_set), NPSET @@ -465,7 +457,7 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& !NB just returns rows, since dAm is symmetric, and missing columns can be !NB reconstructed with a simple transpose, as below CALL build_der_A_matrix_rows(dAm, cp_ddapc_env%gfunc, cp_ddapc_env%w,& - particle_set, radii, rho_tot_g, gcut, iparticle0, nparticles, g_dot_rvec_sin, g_dot_rvec_cos, error); + particle_set, radii, rho_tot_g, gcut, iparticle0, nparticles, g_dot_rvec_sin, g_dot_rvec_cos); !NB no more reduction of dbv and dAm - instead we go through with each node's contribution !NB and reduce resulting charges/forces once, at the end. Intermediate speedup can be !NB had by reducing dqv after the inner loop, and then other routines don't need to know @@ -475,16 +467,16 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& DO iparticle = iparticle0, iparticle0+nparticles-1 IF (debug_this_module) THEN CALL debug_der_A_matrix(dAm, particle_set, radii, rho_tot_g,& - gcut, iparticle, Vol, qs_env, error) + gcut, iparticle, Vol, qs_env) cp_ddapc_env => qs_env%cp_ddapc_env END IF dbv(:,:) = 0.0_dp CALL build_der_b_vector(dbv, cp_ddapc_env%gfunc, cp_ddapc_env%w,& - particle_set, radii, rho_tot_g, gcut, iparticle, error) + particle_set, radii, rho_tot_g, gcut, iparticle) dbv(:,:) = dbv(:,:) / Vol IF (debug_this_module) THEN CALL debug_der_b_vector(dbv, particle_set, radii, rho_tot_g,& - gcut, iparticle, Vol, qs_env, error) + gcut, iparticle, Vol, qs_env) cp_ddapc_env => qs_env%cp_ddapc_env END IF DO j = 1, 3 @@ -520,65 +512,65 @@ RECURSIVE SUBROUTINE get_ddapc(qs_env, calc_force, density_fit_section,& CALL dgemm('N','N',SIZE(dqv,1),SIZE(dqv,2)*SIZE(dqv,3),SIZE(cp_ddapc_env%AmI,2),1.0_dp,& cp_ddapc_env%AmI,SIZE(cp_ddapc_env%AmI,1),tv,SIZE(tv,1),0.0_dp,dqv,SIZE(dqv,1)) !NB deallocate g_dot_rvec_sin and g_dot_rvec_cos - CALL cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos, error) + CALL cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos) !NB moved reduction out to where dqv is used to compute !NB a force contribution (smaller array to reduce, just size(particle_set) x 3) !NB namely ewald_ddapc_force(), cp_decl_ddapc_forces(), restraint_functional_force() - CPPostcondition(PRESENT(dq_out),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(dq_out),cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(dq_out)) THEN ALLOCATE(dq_out(SIZE(dqv,1),SIZE(dqv,2),SIZE(dqv,3)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE - CPPostcondition(SIZE(dqv,1)==SIZE(dq_out,1),cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(dqv,2)==SIZE(dq_out,2),cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(dqv,3)==SIZE(dq_out,3),cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(dqv,1)==SIZE(dq_out,1),cp_failure_level,routineP,failure) + CPPostcondition(SIZE(dqv,2)==SIZE(dq_out,2),cp_failure_level,routineP,failure) + CPPostcondition(SIZE(dqv,3)==SIZE(dq_out,3),cp_failure_level,routineP,failure) END IF dq_out = dqv IF (debug_this_module) THEN CALL debug_charge(dqv, qs_env, density_fit_section, & - particle_set, radii, rho_tot_g, type_of_density, error) + particle_set, radii, rho_tot_g, type_of_density) cp_ddapc_env => qs_env%cp_ddapc_env END IF DEALLOCATE(dqv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dAm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dbv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !NB deallocate new temporaries DEALLOCATE(cvT_AmI, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cvT_AmI_dAmj, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(AmI_cv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dAmj_qv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(AmI_bv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle3) END IF ! ! End of charge fit ! DEALLOCATE(radii, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(qv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(qtot, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (.NOT.PRESENT(iwc)) THEN CALL cp_print_key_finished_output(iw,logger,density_fit_section,& - "PROGRAM_RUN_INFO",error=error) + "PROGRAM_RUN_INFO") END IF CALL pw_pool_give_back_pw(auxbas_pool,rho_tot_g,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL timestop(handle) END SUBROUTINE get_ddapc @@ -592,13 +584,12 @@ END SUBROUTINE get_ddapc !> \param charges ... !> \param ddapc_restraint_control ... !> \param energy_res ... -!> \param error ... !> \par History !> 02.2006 modified [Teo] ! ***************************************************************************** SUBROUTINE restraint_functional_potential(v_hartree_gspace,& density_fit_section, particle_set, AmI, radii, charges,& - ddapc_restraint_control,energy_res, error) + ddapc_restraint_control,energy_res) TYPE(pw_p_type) :: v_hartree_gspace TYPE(section_vals_type), POINTER :: density_fit_section TYPE(particle_type), DIMENSION(:), & @@ -608,7 +599,6 @@ SUBROUTINE restraint_functional_potential(v_hartree_gspace,& TYPE(ddapc_restraint_type), & INTENT(INOUT) :: ddapc_restraint_control REAL(KIND=dp), INTENT(INOUT) :: energy_res - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'restraint_functional_potential', & @@ -629,14 +619,14 @@ SUBROUTINE restraint_functional_potential(v_hartree_gspace,& NULLIFY(g_hartree) n_gauss = SIZE(radii) ALLOCATE(cv(n_gauss*SIZE(particle_set)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(uv(n_gauss*SIZE(particle_set)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) uv = 0.0_dp CALL evaluate_restraint_functional(ddapc_restraint_control, n_gauss, uv,& - charges, energy_res, error) + charges, energy_res) ! - CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut,error=error) + CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut) gcut2 = gcut*gcut g_hartree => v_hartree_gspace%pw Vol = g_hartree%pw_grid%vol @@ -681,20 +671,18 @@ END SUBROUTINE restraint_functional_potential !> \param AmI ... !> \param radii ... !> \param charges ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE modify_hartree_pot(v_hartree_gspace, density_fit_section,& - particle_set, M, AmI, radii, charges, error) + particle_set, M, AmI, radii, charges) TYPE(pw_p_type) :: v_hartree_gspace TYPE(section_vals_type), POINTER :: density_fit_section TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set REAL(KIND=dp), DIMENSION(:, :), POINTER :: M, AmI REAL(KIND=dp), DIMENSION(:), POINTER :: radii, charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'modify_hartree_pot', & routineP = moduleN//':'//routineN @@ -712,14 +700,14 @@ SUBROUTINE modify_hartree_pot(v_hartree_gspace, density_fit_section,& failure=.FALSE. CALL timeset(routineN,handle) NULLIFY(g_hartree) - CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut,error=error) + CALL section_vals_val_get(density_fit_section,"GCUT",r_val=gcut) gcut2 = gcut*gcut g_hartree => v_hartree_gspace%pw Vol = g_hartree%pw_grid%vol ALLOCATE(cv(SIZE(M,1)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(uv(SIZE(M,1)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cv = 1.0_dp/Vol uv(:) = MATMUL(M,charges) sfac = -1.0_dp/Vol @@ -764,13 +752,12 @@ END SUBROUTINE modify_hartree_pot !> \param iparticle ... !> \param Vol ... !> \param qs_env ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE debug_der_b_vector(dbv, particle_set, radii,& - rho_tot_g, gcut, iparticle, Vol, qs_env, error) + rho_tot_g, gcut, iparticle, Vol, qs_env) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: dbv TYPE(particle_type), DIMENSION(:), & @@ -781,7 +768,6 @@ SUBROUTINE debug_der_b_vector(dbv, particle_set, radii,& INTEGER, INTENT(in) :: iparticle REAL(KIND=dp), INTENT(IN) :: Vol TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'debug_der_b_vector', & routineP = moduleN//':'//routineN @@ -798,11 +784,11 @@ SUBROUTINE debug_der_b_vector(dbv, particle_set, radii,& dx = 0.01_dp ndim = SIZE(particle_set)*SIZE(radii) ALLOCATE(bv1(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(bv2(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ddbv(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rvec = particle_set(iparticle)%r cp_ddapc_env => qs_env%cp_ddapc_env DO i = 1, 3 @@ -810,11 +796,11 @@ SUBROUTINE debug_der_b_vector(dbv, particle_set, radii,& bv2(:) = 0.0_dp particle_set(iparticle)%r(i) = rvec(i) + dx CALL build_b_vector(bv1, cp_ddapc_env%gfunc, cp_ddapc_env%w,& - particle_set, radii, rho_tot_g, gcut, error); bv1(:) = bv1(:) / Vol + particle_set, radii, rho_tot_g, gcut); bv1(:) = bv1(:) / Vol CALL mp_sum(bv1,rho_tot_g%pw_grid%para%group) particle_set(iparticle)%r(i) = rvec(i) - dx CALL build_b_vector(bv2, cp_ddapc_env%gfunc, cp_ddapc_env%w,& - particle_set, radii, rho_tot_g, gcut, error); bv2(:) = bv2(:) / Vol + particle_set, radii, rho_tot_g, gcut); bv2(:) = bv2(:) / Vol CALL mp_sum(bv2,rho_tot_g%pw_grid%para%group) ddbv(:) = (bv1(:) - bv2(:))/(2.0_dp*dx) DO kk = 1, SIZE(ddbv) @@ -824,18 +810,18 @@ SUBROUTINE debug_der_b_vector(dbv, particle_set, radii,& IF (v0.GT.0.1_dp) THEN WRITE(*,'(A,2I5,2F15.9)')"ERROR IN DERIVATIVE OF B VECTOR, IPARTICLE, ICOORD:",iparticle,i,& dbv(kk,i),ddbv(kk) - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF END DO particle_set(iparticle)%r = rvec END DO DEALLOCATE(bv1, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bv2, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ddbv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE debug_der_b_vector @@ -850,13 +836,12 @@ END SUBROUTINE debug_der_b_vector !> \param iparticle ... !> \param Vol ... !> \param qs_env ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE debug_der_A_matrix(dAm, particle_set, radii,& - rho_tot_g, gcut, iparticle, Vol, qs_env, error) + rho_tot_g, gcut, iparticle, Vol, qs_env) REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(IN) :: dAm TYPE(particle_type), DIMENSION(:), & @@ -867,7 +852,6 @@ SUBROUTINE debug_der_A_matrix(dAm, particle_set, radii,& INTEGER, INTENT(in) :: iparticle REAL(KIND=dp), INTENT(IN) :: Vol TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'debug_der_A_matrix', & routineP = moduleN//':'//routineN @@ -888,26 +872,26 @@ SUBROUTINE debug_der_A_matrix(dAm, particle_set, radii,& dx = 0.01_dp ndim = SIZE(particle_set)*SIZE(radii) ALLOCATE(Am1(ndim,ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Am2(ndim,ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ddAm(ndim,ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rvec = particle_set(iparticle)%r cp_ddapc_env => qs_env%cp_ddapc_env - CALL prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos, error) + CALL prep_g_dot_rvec_sin_cos(rho_tot_g, particle_set, gcut, g_dot_rvec_sin, g_dot_rvec_cos) DO i = 1, 3 Am1 = 0.0_dp Am2 = 0.0_dp particle_set(iparticle)%r(i) = rvec(i) + dx CALL build_A_matrix(Am1, cp_ddapc_env%gfunc, cp_ddapc_env%w,& - particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos, & - error); Am1(:,:) = Am1(:,:) / (Vol*Vol) + particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos) + Am1(:,:) = Am1(:,:) / (Vol*Vol) CALL mp_sum(Am1,rho_tot_g%pw_grid%para%group) particle_set(iparticle)%r(i) = rvec(i) - dx CALL build_A_matrix(Am2, cp_ddapc_env%gfunc, cp_ddapc_env%w,& - particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos, & - error); Am2(:,:) = Am2(:,:) / (Vol*Vol) + particle_set, radii, rho_tot_g, gcut, g_dot_rvec_sin, g_dot_rvec_cos) + Am2(:,:) = Am2(:,:) / (Vol*Vol) CALL mp_sum(Am2,rho_tot_g%pw_grid%para%group) ddAm(:,:) = (Am1 - Am2)/(2.0_dp*dx) DO kk = 1, SIZE(ddAm,1) @@ -918,20 +902,20 @@ SUBROUTINE debug_der_A_matrix(dAm, particle_set, radii,& IF (v0.GT.0.1_dp) THEN WRITE(*,'(A,4I5,2F15.9)')"ERROR IN DERIVATIVE OF A MATRIX, IPARTICLE, ICOORD:",iparticle,i,kk,ll,& dAm(kk,ll,i),ddAm(kk,ll) - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF END DO END DO particle_set(iparticle)%r = rvec END DO - CALL cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos, error) + CALL cleanup_g_dot_rvec_sin_cos(g_dot_rvec_sin, g_dot_rvec_cos) DEALLOCATE(Am1, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Am2, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ddAm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE debug_der_A_matrix @@ -944,13 +928,12 @@ END SUBROUTINE debug_der_A_matrix !> \param radii ... !> \param rho_tot_g ... !> \param type_of_density ... -!> \param error ... !> \par History !> 08.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE debug_charge(dqv, qs_env, density_fit_section,& - particle_set, radii, rho_tot_g, type_of_density, error) + particle_set, radii, rho_tot_g, type_of_density) REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(IN) :: dqv TYPE(qs_environment_type), POINTER :: qs_env @@ -960,7 +943,6 @@ SUBROUTINE debug_charge(dqv, qs_env, density_fit_section,& REAL(KIND=dp), DIMENSION(:), POINTER :: radii TYPE(pw_type), POINTER :: rho_tot_g CHARACTER(LEN=*) :: type_of_density - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'debug_charge', & routineP = moduleN//':'//routineN @@ -978,11 +960,11 @@ SUBROUTINE debug_charge(dqv, qs_env, density_fit_section,& ndim = SIZE(particle_set)*SIZE(radii) NULLIFY(qtot1, qtot2) ALLOCATE(qtot1(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(qtot2(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ddqv(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! dx = 0.001_dp DO iparticle = 1, SIZE(particle_set) @@ -990,10 +972,10 @@ SUBROUTINE debug_charge(dqv, qs_env, density_fit_section,& DO i = 1, 3 particle_set(iparticle)%r(i) = rvec(i) + dx CALL get_ddapc(qs_env,.FALSE.,density_fit_section, qout1=qtot1,& - ext_rho_tot_g=rho_tot_g,Itype_of_density=type_of_density,error=error) + ext_rho_tot_g=rho_tot_g,Itype_of_density=type_of_density) particle_set(iparticle)%r(i) = rvec(i) - dx CALL get_ddapc(qs_env,.FALSE.,density_fit_section, qout1=qtot2,& - ext_rho_tot_g=rho_tot_g,Itype_of_density=type_of_density,error=error) + ext_rho_tot_g=rho_tot_g,Itype_of_density=type_of_density) ddqv(:) = (qtot1 - qtot2)/(2.0_dp*dx) DO kk = 1, SIZE(qtot1)-1, SIZE(radii) IF (ANY(ddqv(kk:kk+2).GT.1.0E-8_dp)) THEN @@ -1006,11 +988,11 @@ SUBROUTINE debug_charge(dqv, qs_env, density_fit_section,& END DO ! DEALLOCATE(qtot1, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(qtot2, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ddqv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE debug_charge diff --git a/src/cp_external_control.F b/src/cp_external_control.F index 05dce52480..025ed702c4 100644 --- a/src/cp_external_control.F +++ b/src/cp_external_control.F @@ -48,22 +48,20 @@ MODULE cp_external_control !> \param in_external_master_id ... !> \param in_scf_energy_message_tag ... !> \param in_exit_tag ... -!> \param error ... !> \author Mandes 02.2013 ! ***************************************************************************** SUBROUTINE set_external_comm(comm, in_external_master_id, & - in_scf_energy_message_tag, in_exit_tag, error) + in_scf_energy_message_tag, in_exit_tag) INTEGER, INTENT(IN) :: comm, in_external_master_id INTEGER, INTENT(IN), OPTIONAL :: in_scf_energy_message_tag, & in_exit_tag - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_external_comm', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(in_external_master_id.GE.0,cp_failure_level,routineP,error,failure) + CPPrecondition(in_external_master_id.GE.0,cp_failure_level,routineP,failure) external_comm = comm external_master_id = in_external_master_id @@ -72,7 +70,7 @@ SUBROUTINE set_external_comm(comm, in_external_master_id, & scf_energy_message_tag = in_scf_energy_message_tag IF(PRESENT(in_exit_tag)) THEN ! the exit tag should be different from the mp_probe tag default - CPPrecondition(in_exit_tag.NE.-1,cp_failure_level,routineP,error,failure) + CPPrecondition(in_exit_tag.NE.-1,cp_failure_level,routineP,failure) exit_tag = in_exit_tag END IF END SUBROUTINE set_external_comm @@ -88,17 +86,15 @@ END SUBROUTINE set_external_comm !> \param globenv ... !> \param target_time ... !> \param start_time ... -!> \param error ... !> \author MI (10.03.2005) ! ***************************************************************************** - SUBROUTINE external_control(should_stop,flag,globenv,target_time,start_time,error) + SUBROUTINE external_control(should_stop,flag,globenv,target_time,start_time) LOGICAL, INTENT(OUT) :: should_stop CHARACTER(LEN=*), INTENT(IN) :: flag TYPE(global_environment_type), & OPTIONAL, POINTER :: globenv REAL(dp), OPTIONAL :: target_time, start_time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'external_control', & routineP = moduleN//':'//routineN @@ -117,7 +113,7 @@ SUBROUTINE external_control(should_stop,flag,globenv,target_time,start_time,erro CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() should_stop = .FALSE. exit_gname = "EXIT" @@ -211,7 +207,7 @@ SUBROUTINE external_control(should_stop,flag,globenv,target_time,start_time,erro my_start_time=globenv%cp2k_start_time ELSE ! If none of the two arguments is present abort.. This routine should always check about time. - CPPrecondition(.FALSE.,cp_fatal_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_fatal_level,routineP,failure) END IF IF ( (.NOT.should_stop).AND.(my_target_time > 0.0_dp)) THEN diff --git a/src/cp_gemm_interface.F b/src/cp_gemm_interface.F index ad6e7f9da2..e582cb8715 100644 --- a/src/cp_gemm_interface.F +++ b/src/cp_gemm_interface.F @@ -49,7 +49,6 @@ MODULE cp_gemm_interface !> \param matrix_b ... !> \param beta ... !> \param matrix_c ... -!> \param error ... !> \param b_first_col ... !> \param a_first_row ... !> \param b_first_row ... @@ -57,14 +56,13 @@ MODULE cp_gemm_interface !> \param c_first_row ... ! ***************************************************************************** SUBROUTINE cp_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& - matrix_c,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + matrix_c,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CHARACTER(LEN=1), INTENT(IN) :: transa, transb INTEGER, INTENT(IN) :: m, n, k REAL(KIND=dp), INTENT(IN) :: alpha TYPE(cp_fm_type), POINTER :: matrix_a, matrix_b REAL(KIND=dp), INTENT(IN) :: beta TYPE(cp_fm_type), POINTER :: matrix_c - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, INTENT(IN), OPTIONAL :: b_first_col, a_first_row, & b_first_row, c_first_col, & c_first_row @@ -84,9 +82,9 @@ SUBROUTINE cp_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& my_multi=cp_fm_get_mm_type() ! catch the special case that matrices have different blocking ! SCALAPACK can deal with it but dbcsr doesn't like it - CALL cp_fm_get_info(matrix_a,nrow_locals=a_row_loc,ncol_locals=a_col_loc,error=error) - CALL cp_fm_get_info(matrix_b,nrow_locals=b_row_loc,ncol_locals=b_col_loc,error=error) - CALL cp_fm_get_info(matrix_c,nrow_locals=c_row_loc,ncol_locals=c_col_loc,error=error) + CALL cp_fm_get_info(matrix_a,nrow_locals=a_row_loc,ncol_locals=a_col_loc) + CALL cp_fm_get_info(matrix_b,nrow_locals=b_row_loc,ncol_locals=b_col_loc) + CALL cp_fm_get_info(matrix_c,nrow_locals=c_row_loc,ncol_locals=c_col_loc) IF(PRESENT(b_first_col))my_multi=do_pdgemm IF(PRESENT(a_first_row))my_multi=do_pdgemm IF(PRESENT(b_first_row))my_multi=do_pdgemm @@ -95,12 +93,12 @@ SUBROUTINE cp_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& my_trans=transa; CALL uppercase(my_trans) IF(my_trans=='T')THEN - CALL cp_fm_get_info(matrix_a,nrow_locals=a_col_loc,ncol_locals=a_row_loc,error=error) + CALL cp_fm_get_info(matrix_a,nrow_locals=a_col_loc,ncol_locals=a_row_loc) END IF my_trans=transb; CALL uppercase(my_trans) IF(my_trans=='T')THEN - CALL cp_fm_get_info(matrix_b,nrow_locals=b_col_loc,ncol_locals=b_row_loc,error=error) + CALL cp_fm_get_info(matrix_b,nrow_locals=b_col_loc,ncol_locals=b_row_loc) END IF IF(my_multi.NE.do_pdgemm)THEN @@ -132,20 +130,20 @@ SUBROUTINE cp_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& CASE (do_pdgemm) CALL timeset("cp_gemm_fm_gemm",handle1) CALL cp_fm_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& - matrix_c,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + matrix_c,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CALL timestop(handle1) CASE (do_dbcsr) CALL timeset("cp_gemm_dbcsr_mm",handle1) - CALL copy_fm_to_dbcsr_bc(matrix_a,a_db,error=error) - CALL copy_fm_to_dbcsr_bc(matrix_b,b_db,error=error) - CALL copy_fm_to_dbcsr_bc(matrix_c,c_db,error=error) + CALL copy_fm_to_dbcsr_bc(matrix_a,a_db) + CALL copy_fm_to_dbcsr_bc(matrix_b,b_db) + CALL copy_fm_to_dbcsr_bc(matrix_c,c_db) - CALL cp_dbcsr_multiply(transa,transb,alpha, a_db, b_db, beta, c_db, last_k=k, error=error) + CALL cp_dbcsr_multiply(transa,transb,alpha, a_db, b_db, beta, c_db, last_k=k) - CALL copy_dbcsr_to_fm_bc(c_db, matrix_c, error) - CALL cp_dbcsr_release (a_db, error=error) - CALL cp_dbcsr_release (b_db, error=error) - CALL cp_dbcsr_release (c_db, error=error) + CALL copy_dbcsr_to_fm_bc(c_db, matrix_c) + CALL cp_dbcsr_release (a_db) + CALL cp_dbcsr_release (b_db) + CALL cp_dbcsr_release (c_db) CALL timestop(handle1) END SELECT CALL timestop(handle) diff --git a/src/cp_realspace_grid_cube.F b/src/cp_realspace_grid_cube.F index c568c51de9..d9eb7ed37c 100644 --- a/src/cp_realspace_grid_cube.F +++ b/src/cp_realspace_grid_cube.F @@ -33,16 +33,14 @@ MODULE cp_realspace_grid_cube !> \param particles ... !> \param stride ... !> \param zero_tails ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_pw_to_cube ( pw, unit_nr, title, particles, stride, zero_tails, error ) + SUBROUTINE cp_pw_to_cube ( pw, unit_nr, title, particles, stride, zero_tails) TYPE(pw_type), POINTER :: pw INTEGER, INTENT(IN) :: unit_nr CHARACTER(*), INTENT(IN), OPTIONAL :: title TYPE(particle_list_type), POINTER :: particles INTEGER, DIMENSION(:), OPTIONAL, POINTER :: stride LOGICAL, INTENT(IN), OPTIONAL :: zero_tails - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_pw_to_cube', & routineP = moduleN//':'//routineN @@ -66,10 +64,10 @@ SUBROUTINE cp_pw_to_cube ( pw, unit_nr, title, particles, stride, zero_tails, er CALL pw_to_cube(pw=pw, unit_nr=unit_nr, title=title, & particles_z=particles_z, particles_r=particles_r,& - stride=stride, zero_tails=zero_tails, error=error) + stride=stride, zero_tails=zero_tails) ELSE CALL pw_to_cube(pw=pw, unit_nr=unit_nr, title=title, & - stride=stride, zero_tails=zero_tails, error=error) + stride=stride, zero_tails=zero_tails) END IF END SUBROUTINE cp_pw_to_cube diff --git a/src/cp_realspace_grid_init.F b/src/cp_realspace_grid_init.F index 1bbc964eab..77600e8af4 100644 --- a/src/cp_realspace_grid_init.F +++ b/src/cp_realspace_grid_init.F @@ -38,13 +38,12 @@ MODULE cp_realspace_grid_init !> \param ilevel ... !> \param higher_grid_layout the layout of a higher level grid. layouts with !> negative or zero values are ignored -!> \param error ... !> \par History !> 01.2008 created [Joost VandeVondele] !> \note !> if rs_grid_section is not present we setup for an replicated setup ! ***************************************************************************** - SUBROUTINE init_input_type(input_settings,nsmax,rs_grid_section,ilevel,higher_grid_layout,error) + SUBROUTINE init_input_type(input_settings,nsmax,rs_grid_section,ilevel,higher_grid_layout) TYPE(realspace_grid_input_type), & INTENT(OUT) :: input_settings INTEGER, INTENT(IN) :: nsmax @@ -52,7 +51,6 @@ SUBROUTINE init_input_type(input_settings,nsmax,rs_grid_section,ilevel,higher_gr POINTER :: rs_grid_section INTEGER, INTENT(IN) :: ilevel INTEGER, DIMENSION(3), INTENT(IN) :: higher_grid_layout - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: isection, & max_distributed_level, & @@ -63,27 +61,27 @@ SUBROUTINE init_input_type(input_settings,nsmax,rs_grid_section,ilevel,higher_gr input_settings%nsmax=nsmax ! we use the section corresponding to the level, or the largest available one ! i.e. the last section defines all following ones - CALL section_vals_get(rs_grid_section,n_repetition=nsection,error=error) + CALL section_vals_get(rs_grid_section,n_repetition=nsection) isection=MAX(1,MIN(ilevel,nsection)) CALL section_vals_val_get(rs_grid_section,"DISTRIBUTION_TYPE",& i_rep_section=isection,& - i_val=input_settings%distribution_type,error=error) + i_val=input_settings%distribution_type) CALL section_vals_val_get(rs_grid_section,"DISTRIBUTION_LAYOUT",& i_rep_section=isection,& - i_vals=tmp,error=error) + i_vals=tmp) input_settings%distribution_layout=tmp CALL section_vals_val_get(rs_grid_section,"MEMORY_FACTOR",& i_rep_section=isection,& - r_val=input_settings%memory_factor,error=error) + r_val=input_settings%memory_factor) CALL section_vals_val_get(rs_grid_section,"HALO_REDUCTION_FACTOR",& i_rep_section=isection,& - r_val=input_settings%halo_reduction_factor,error=error) + r_val=input_settings%halo_reduction_factor) CALL section_vals_val_get(rs_grid_section,"LOCK_DISTRIBUTION",& i_rep_section=isection,& - l_val=input_settings%lock_distribution,error=error) + l_val=input_settings%lock_distribution) CALL section_vals_val_get(rs_grid_section,"MAX_DISTRIBUTED_LEVEL",& i_rep_section=isection,& - i_val=max_distributed_level,error=error) + i_val=max_distributed_level) ! multigrids that are to coarse are not distributed in the automatic scheme IF (input_settings%distribution_type == rsgrid_automatic) THEN diff --git a/src/cp_spline_utils.F b/src/cp_spline_utils.F index f7ef5514cb..547f265e94 100644 --- a/src/cp_spline_utils.F +++ b/src/cp_spline_utils.F @@ -50,18 +50,14 @@ MODULE cp_spline_utils !> \param pw_coarse_out the coarse grid !> \param coarse_pool ... !> \param param_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> extremely slow (but correct) version ! ***************************************************************************** - SUBROUTINE pw_restrict_s3(pw_fine_in,pw_coarse_out,coarse_pool,param_section,& - error) + SUBROUTINE pw_restrict_s3(pw_fine_in,pw_coarse_out,coarse_pool,param_section) TYPE(pw_type), POINTER :: pw_fine_in, pw_coarse_out TYPE(pw_pool_type), POINTER :: coarse_pool TYPE(section_vals_type), POINTER :: param_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_restrict_s3', & routineP = moduleN//':'//routineN @@ -81,71 +77,71 @@ SUBROUTINE pw_restrict_s3(pw_fine_in,pw_coarse_out,coarse_pool,param_section,& ifile=ifile+1 CALL timeset(routineN,handle) CALL section_vals_val_get(param_section,"safe_computation", & - l_val=safe_computation, error=error) + l_val=safe_computation) CALL section_vals_val_get(param_section,"aint_precond", & - i_val=aint_precond, error=error) + i_val=aint_precond) CALL section_vals_val_get(param_section,"precond", & - i_val=precond_kind, error=error) + i_val=precond_kind) CALL section_vals_val_get(param_section,"max_iter", & - i_val=max_iter, error=error) + i_val=max_iter) CALL section_vals_val_get(param_section,"eps_r", & - r_val=eps_r, error=error) + r_val=eps_r) CALL section_vals_val_get(param_section,"eps_x", & - r_val=eps_x, error=error) + r_val=eps_x) CALL section_vals_val_get(param_section,"kind",& - i_val=interp_kind, error=error) + i_val=interp_kind) pbc=(interp_kind==spline3_pbc_interp) - CPPrecondition(pbc.OR.interp_kind==spline3_nopbc_interp,cp_failure_level,routineP,error,failure) + CPPrecondition(pbc.OR.interp_kind==spline3_nopbc_interp,cp_failure_level,routineP,failure) bo=pw_coarse_out%pw_grid%bounds_local NULLIFY(values,coeffs) CALL pw_pool_create_pw(coarse_pool,values, use_data=REALDATA3D,& - in_space=REALSPACE,error=error) - CALL pw_zero(values,error=error) + in_space=REALSPACE) + CALL pw_zero(values) !FM nullify(tst_pw) !FM CALL pw_pool_create_pw(coarse_pool,tst_pw, use_data=REALDATA3D,& -!FM in_space=REALSPACE,error=error) -!FM call pw_copy(values,tst_pw,error=error) +!FM in_space=REALSPACE) +!FM call pw_copy(values,tst_pw) !FM call add_fine2coarse(fine_values_pw=pw_fine_in,& !FM coarse_coeffs_pw=tst_pw,& !FM weights_1d=spl3_1d_transf_coeffs/2._dp, w_border0=0.5_dp,& !FM w_border1=spl3_1d_transf_border1/2._dp,pbc=pbc,& -!FM safe_computation=.false.,error=error) +!FM safe_computation=.false.) CALL add_fine2coarse(fine_values_pw=pw_fine_in,& coarse_coeffs_pw=values,& weights_1d=spl3_1d_transf_coeffs/2._dp, w_border0=0.5_dp,& w_border1=spl3_1d_transf_border1/2._dp,pbc=pbc,& - safe_computation=safe_computation,error=error) + safe_computation=safe_computation) -!FM CALL pw_compare_debug(tst_pw,values,max_diff,error=error) +!FM CALL pw_compare_debug(tst_pw,values,max_diff) !FM WRITE(cp_logger_get_default_unit_nr(logger,.TRUE.),*)"f2cmax_diff=",max_diff -!FM CALL pw_pool_give_back_pw(coarse_pool,tst_pw,error=error) +!FM CALL pw_pool_give_back_pw(coarse_pool,tst_pw) CALL pw_pool_create_pw(coarse_pool,coeffs, use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) NULLIFY(precond) CALL pw_spline_precond_create(precond,precond_kind=aint_precond,& - pool=coarse_pool,pbc=pbc,transpose=.TRUE.,error=error) - CALL pw_spline_do_precond(precond,values,coeffs,error=error) - CALL pw_spline_precond_set_kind(precond,precond_kind,error=error) + pool=coarse_pool,pbc=pbc,transpose=.TRUE.) + CALL pw_spline_do_precond(precond,values,coeffs) + CALL pw_spline_precond_set_kind(precond,precond_kind) IF (pbc) THEN success=find_coeffs(values=values,coeffs=coeffs,& linOp=spl3_pbc,preconditioner=precond, pool=coarse_pool, & - eps_r=eps_r,eps_x=eps_x, max_iter=max_iter,error=error) + eps_r=eps_r,eps_x=eps_x, max_iter=max_iter) ELSE success=find_coeffs(values=values,coeffs=coeffs,& linOp=spl3_nopbct,preconditioner=precond, pool=coarse_pool, & - eps_r=eps_r,eps_x=eps_x, max_iter=max_iter,error=error) + eps_r=eps_r,eps_x=eps_x, max_iter=max_iter) END IF - CALL pw_spline_precond_release(precond,error=error) + CALL pw_spline_precond_release(precond) - CALL pw_zero(pw_coarse_out,error=error) - CALL pw_axpy(coeffs,pw_coarse_out,error=error) + CALL pw_zero(pw_coarse_out) + CALL pw_axpy(coeffs,pw_coarse_out) - CALL pw_pool_give_back_pw(coarse_pool,values,error=error) - CALL pw_pool_give_back_pw(coarse_pool,coeffs,error=error) + CALL pw_pool_give_back_pw(coarse_pool,values) + CALL pw_pool_give_back_pw(coarse_pool,coeffs) CALL timestop(handle) END SUBROUTINE pw_restrict_s3 @@ -155,18 +151,15 @@ END SUBROUTINE pw_restrict_s3 !> \param pw_fine_out the fine grid !> \param coarse_pool ... !> \param param_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> extremely slow (but correct) version ! ***************************************************************************** SUBROUTINE pw_prolongate_s3(pw_coarse_in,pw_fine_out,coarse_pool,& - param_section,error) + param_section) TYPE(pw_type), POINTER :: pw_coarse_in, pw_fine_out TYPE(pw_pool_type), POINTER :: coarse_pool TYPE(section_vals_type), POINTER :: param_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_prolongate_s3', & routineP = moduleN//':'//routineN @@ -188,69 +181,68 @@ SUBROUTINE pw_prolongate_s3(pw_coarse_in,pw_fine_out,coarse_pool,& CALL timeset(routineN,handle) NULLIFY(coeffs) CALL pw_pool_create_pw(coarse_pool,coeffs, use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) bo=pw_coarse_in%pw_grid%bounds_local CALL section_vals_val_get(param_section,"safe_computation", & - l_val=safe_computation, error=error) + l_val=safe_computation) CALL section_vals_val_get(param_section,"aint_precond", & - i_val=aint_precond, error=error) + i_val=aint_precond) CALL section_vals_val_get(param_section,"precond", & - i_val=precond_kind, error=error) + i_val=precond_kind) CALL section_vals_val_get(param_section,"max_iter", & - i_val=max_iter, error=error) + i_val=max_iter) CALL section_vals_val_get(param_section,"eps_r", & - r_val=eps_r, error=error) + r_val=eps_r) CALL section_vals_val_get(param_section,"eps_x", & - r_val=eps_x, error=error) + r_val=eps_x) CALL section_vals_val_get(param_section,"kind",& - i_val=interp_kind,error=error) + i_val=interp_kind) pbc=(interp_kind==spline3_pbc_interp) - CPPrecondition(pbc.OR.interp_kind==spline3_nopbc_interp,cp_failure_level,routineP,error,failure) + CPPrecondition(pbc.OR.interp_kind==spline3_nopbc_interp,cp_failure_level,routineP,failure) NULLIFY(precond) CALL pw_spline_precond_create(precond,precond_kind=aint_precond,& - pool=coarse_pool,pbc=pbc,transpose=.FALSE.,error=error) - CALL pw_spline_do_precond(precond,pw_coarse_in,coeffs,error=error) - CALL pw_spline_precond_set_kind(precond,precond_kind,error=error) + pool=coarse_pool,pbc=pbc,transpose=.FALSE.) + CALL pw_spline_do_precond(precond,pw_coarse_in,coeffs) + CALL pw_spline_precond_set_kind(precond,precond_kind) IF (pbc) THEN success=find_coeffs(values=pw_coarse_in,coeffs=coeffs,& linOp=spl3_pbc,preconditioner=precond, pool=coarse_pool, & eps_r=eps_r,eps_x=eps_x,& - max_iter=max_iter,error=error) + max_iter=max_iter) ELSE success=find_coeffs(values=pw_coarse_in,coeffs=coeffs,& linOp=spl3_nopbc,preconditioner=precond, pool=coarse_pool, & eps_r=eps_r,eps_x=eps_x,& - max_iter=max_iter,error=error) + max_iter=max_iter) END IF - CPPostconditionNoFail(success,cp_warning_level,routineP,error) - CALL pw_spline_precond_release(precond,error=error) + CPPostconditionNoFail(success,cp_warning_level,routineP) + CALL pw_spline_precond_release(precond) !FM nullify(tst_pw) !FM call pw_create(tst_pw, pw_fine_out%pw_grid, use_data=REALDATA3D,& -!FM in_space=REALSPACE, error=error) -!FM call pw_copy(pw_fine_out,tst_pw,error=error) +!FM in_space=REALSPACE) +!FM call pw_copy(pw_fine_out,tst_pw) !FM CALL add_coarse2fine(coarse_coeffs_pw=coeffs,& !FM fine_values_pw=tst_pw,& !FM weights_1d=spl3_1d_transf_coeffs,& !FM w_border0=1._dp,& !FM w_border1=spl3_1d_transf_border1,& !FM pbc=pbc,safe_computation=.false.,& -!FM error=error) +!FM CALL add_coarse2fine(coarse_coeffs_pw=coeffs,& fine_values_pw=pw_fine_out,& weights_1d=spl3_1d_transf_coeffs,& w_border0=1._dp,& w_border1=spl3_1d_transf_border1,& - pbc=pbc,safe_computation=safe_computation,& - error=error) + pbc=pbc,safe_computation=safe_computation) -!FM CALL pw_compare_debug(tst_pw,pw_fine_out,max_diff,error=error) +!FM CALL pw_compare_debug(tst_pw,pw_fine_out,max_diff) !FM WRITE(cp_logger_get_default_unit_nr(logger,.TRUE.),*)"c2fmax_diff=",max_diff -!FM CALL pw_release(tst_pw,error=error) +!FM CALL pw_release(tst_pw) - CALL pw_pool_give_back_pw(coarse_pool,coeffs,error=error) + CALL pw_pool_give_back_pw(coarse_pool,coeffs) CALL timestop(handle) END SUBROUTINE pw_prolongate_s3 diff --git a/src/cp_subsys_methods.F b/src/cp_subsys_methods.F index 7e07ac3380..b893a02138 100644 --- a/src/cp_subsys_methods.F +++ b/src/cp_subsys_methods.F @@ -87,12 +87,11 @@ MODULE cp_subsys_methods !> \param qmmm ... !> \param qmmm_env ... !> \param exclusions ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** SUBROUTINE cp_subsys_create(subsys, para_env, & root_section, force_env_section, subsys_section,& - use_motion_section, qmmm, qmmm_env, exclusions, error) + use_motion_section, qmmm, qmmm_env, exclusions) TYPE(cp_subsys_type), POINTER :: subsys TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: root_section @@ -105,7 +104,6 @@ SUBROUTINE cp_subsys_create(subsys, para_env, & POINTER :: qmmm_env TYPE(exclusion_type), DIMENSION(:), & OPTIONAL, POINTER :: exclusions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_subsys_create', & routineP = moduleN//':'//routineN @@ -129,27 +127,27 @@ SUBROUTINE cp_subsys_create(subsys, para_env, & my_force_env_section, & my_subsys_section - CPPostcondition(.NOT.ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(subsys),cp_failure_level,routineP,failure) ALLOCATE(subsys) - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) subsys%para_env => para_env my_use_motion_section = .FALSE. IF(PRESENT(use_motion_section)) & my_use_motion_section = use_motion_section - my_force_env_section => section_vals_get_subs_vals(root_section,"FORCE_EVAL",error=error) + my_force_env_section => section_vals_get_subs_vals(root_section,"FORCE_EVAL") IF(PRESENT(force_env_section)) & my_force_env_section => force_env_section - my_subsys_section => section_vals_get_subs_vals(my_force_env_section,"SUBSYS",error=error) + my_subsys_section => section_vals_get_subs_vals(my_force_env_section,"SUBSYS") IF(PRESENT(subsys_section)) & my_subsys_section => subsys_section - colvar_section => section_vals_get_subs_vals(my_subsys_section,"COLVAR",error=error) + colvar_section => section_vals_get_subs_vals(my_subsys_section,"COLVAR") - CALL cp_subsys_read_colvar(subsys, colvar_section, error=error) + CALL cp_subsys_read_colvar(subsys, colvar_section) ! *** Read the particle coordinates and allocate the atomic kind, *** ! *** the molecule kind, and the molecule data structures *** @@ -157,24 +155,23 @@ SUBROUTINE cp_subsys_create(subsys, para_env, & subsys%colvar_p, subsys%gci, root_section, para_env,& force_env_section=my_force_env_section,& subsys_section=my_subsys_section,use_motion_section=my_use_motion_section,& - qmmm=qmmm, qmmm_env=qmmm_env, exclusions=exclusions,& - error=error) + qmmm=qmmm, qmmm_env=qmmm_env, exclusions=exclusions) - CALL particle_list_create(particles,els_ptr=particle_set,error=error) - CALL atomic_kind_list_create(atomic_kinds,els_ptr=atomic_kind_set,error=error) - CALL mol_new_list_create(mols,els_ptr=molecule_set,error=error) - CALL mol_kind_new_list_create(mol_kinds,els_ptr=molecule_kind_set,error=error) + CALL particle_list_create(particles,els_ptr=particle_set) + CALL atomic_kind_list_create(atomic_kinds,els_ptr=atomic_kind_set) + CALL mol_new_list_create(mols,els_ptr=molecule_set) + CALL mol_kind_new_list_create(mol_kinds,els_ptr=molecule_kind_set) CALL cp_subsys_set(subsys,particles=particles,atomic_kinds=atomic_kinds,& - molecules_new=mols,molecule_kinds_new=mol_kinds,error=error) + molecules_new=mols,molecule_kinds_new=mol_kinds) - CALL particle_list_release(particles,error=error) - CALL atomic_kind_list_release(atomic_kinds,error=error) - CALL mol_new_list_release(mols,error=error) - CALL mol_kind_new_list_release(mol_kinds,error=error) + CALL particle_list_release(particles) + CALL atomic_kind_list_release(atomic_kinds) + CALL mol_new_list_release(mols) + CALL mol_kind_new_list_release(mol_kinds) ! Should we compute the virial? - CALL section_vals_val_get(my_force_env_section,"STRESS_TENSOR",i_val=stress_tensor,error=error) + CALL section_vals_val_get(my_force_env_section,"STRESS_TENSOR",i_val=stress_tensor) SELECT CASE(stress_tensor) CASE(do_stress_none) pv_availability=.FALSE. @@ -198,38 +195,36 @@ SUBROUTINE cp_subsys_create(subsys, para_env, & pv_diagonal=.TRUE. END SELECT - CALL virial_create(subsys%virial, error=error) + CALL virial_create(subsys%virial) CALL virial_set(virial=subsys%virial,& pv_availability=pv_availability,& pv_numer=pv_numerical,& pv_diagonal=pv_diagonal) ! Should we compute atomic properties? - CALL atprop_create(subsys%atprop,error) - CALL section_vals_val_get(my_force_env_section,"PROPERTIES%ATOMIC%ENERGY",l_val=atomic_energy,error=error) + CALL atprop_create(subsys%atprop) + CALL section_vals_val_get(my_force_env_section,"PROPERTIES%ATOMIC%ENERGY",l_val=atomic_energy) subsys%atprop%energy = atomic_energy - CALL section_vals_val_get(my_force_env_section,"PROPERTIES%ATOMIC%PRESSURE",l_val=atomic_stress,error=error) + CALL section_vals_val_get(my_force_env_section,"PROPERTIES%ATOMIC%PRESSURE",l_val=atomic_stress) IF (atomic_stress) THEN - CPPrecondition(pv_availability,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.pv_numerical,cp_failure_level,routineP,error,failure) + CPPrecondition(pv_availability,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.pv_numerical,cp_failure_level,routineP,failure) END IF subsys%atprop%stress = atomic_stress - CALL cp_result_create(subsys%results,error=error) + CALL cp_result_create(subsys%results) END SUBROUTINE cp_subsys_create ! ***************************************************************************** !> \brief reads the colvar section of the colvar !> \param subsys ... !> \param colvar_section ... -!> \param error ... !> \par History !> 2006.01 Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_subsys_read_colvar(subsys,colvar_section,error) + SUBROUTINE cp_subsys_read_colvar(subsys,colvar_section) TYPE(cp_subsys_type), POINTER :: subsys TYPE(section_vals_type), POINTER :: colvar_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_subsys_read_colvar', & routineP = moduleN//':'//routineN @@ -238,12 +233,12 @@ SUBROUTINE cp_subsys_read_colvar(subsys,colvar_section,error) LOGICAL :: failure failure=.FALSE. - CALL section_vals_get(colvar_section,n_repetition=ncol,error=error) + CALL section_vals_get(colvar_section,n_repetition=ncol) ALLOCATE(subsys%colvar_p(ncol),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ig= 1, ncol NULLIFY(subsys%colvar_p(ig)%colvar) - CALL colvar_read(subsys%colvar_p(ig)%colvar,ig,colvar_section, subsys%para_env, error=error) + CALL colvar_read(subsys%colvar_p(ig)%colvar,ig,colvar_section, subsys%para_env) ENDDO END SUBROUTINE cp_subsys_read_colvar @@ -260,8 +255,6 @@ END SUBROUTINE cp_subsys_read_colvar !> \param force_env_section ... !> \param subsys_section ... !> \param ignore_outside_box ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [fawzi] !> \author Fawzi Mohamed, Teodoro Laino @@ -271,7 +264,7 @@ END SUBROUTINE cp_subsys_read_colvar ! ***************************************************************************** SUBROUTINE create_small_subsys(small_subsys, big_subsys, small_cell,& small_para_env, sub_atom_index, sub_atom_kind_name, & - para_env, force_env_section, subsys_section, ignore_outside_box, error) + para_env, force_env_section, subsys_section, ignore_outside_box) TYPE(cp_subsys_type), POINTER :: small_subsys, big_subsys TYPE(cell_type), POINTER :: small_cell @@ -283,7 +276,6 @@ SUBROUTINE create_small_subsys(small_subsys, big_subsys, small_cell,& TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section LOGICAL, INTENT(in), OPTIONAL :: ignore_outside_box - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_small_subsys', & routineP = moduleN//':'//routineN @@ -309,24 +301,24 @@ SUBROUTINE create_small_subsys(small_subsys, big_subsys, small_cell,& NULLIFY(mol_kinds,mols,particles,atomic_kinds, atomic_kind_set, particle_set, & molecule_kind_set,molecule_set,particles,atomic_kinds) - CPPrecondition(.NOT.ASSOCIATED(small_subsys),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(big_subsys),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(small_subsys),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(big_subsys),cp_failure_level,routineP,failure) CALL cp_assert(big_subsys%para_env%group==small_para_env%group, & cp_failure_level, cp_assertion_failed, routineP, & - "big_subsys%para_env%group==small_para_env%group",error,failure) + "big_subsys%para_env%group==small_para_env%group",failure) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 1. Initialize the topology structure type !----------------------------------------------------------------------------- - CALL init_topology(topology,error) + CALL init_topology(topology) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 2. Get the cell info !----------------------------------------------------------------------------- topology%cell=> small_cell - CALL cell_retain(small_cell,error=error) + CALL cell_retain(small_cell) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -334,19 +326,19 @@ SUBROUTINE create_small_subsys(small_subsys, big_subsys, small_cell,& !----------------------------------------------------------------------------- nat=SIZE(sub_atom_index) topology%natoms=nat - CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%r),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%id_atmname),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%id_molname),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%id_resname),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%atm_mass),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%atm_charge),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%r),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%id_atmname),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%id_molname),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%id_resname),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%atm_mass),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(topology%atom_info%atm_charge),cp_failure_level,routineP,failure) ALLOCATE(topology%atom_info%r(3,nat),topology%atom_info%id_atmname(nat),& topology%atom_info%id_molname(nat),topology%atom_info%id_resname(nat),& topology%atom_info%id_element(nat), topology%atom_info%atm_mass(nat),& topology%atom_info%atm_charge(nat),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_subsys_get(big_subsys, particles=particles, error=error) + CALL cp_subsys_get(big_subsys, particles=particles) DO iat=1,nat topology%atom_info%r(:,iat)=particles%els(sub_atom_index(iat))%r topology%atom_info%id_atmname(iat)=str2id(s2s(sub_atom_kind_name(iat))) @@ -360,7 +352,7 @@ SUBROUTINE create_small_subsys(small_subsys, big_subsys, small_cell,& strtmp1=id2str(topology%atom_info%id_atmname(iat)) strtmp1=strtmp1(1:id_) CALL check_subsys_element(strtmp1,strtmp1, my_element,& - subsys_section,use_mm_map_first=.FALSE.,error=error) + subsys_section,use_mm_map_first=.FALSE.) topology%atom_info%id_element(iat)=str2id(s2s(my_element)) topology%atom_info%atm_mass(iat)=0._dp topology%atom_info%atm_charge(iat)=0._dp @@ -372,14 +364,14 @@ SUBROUTINE create_small_subsys(small_subsys, big_subsys, small_cell,& ! 4. Read in or generate the molecular connectivity !----------------------------------------------------------------------------- CALL connectivity_control(topology,para_env,subsys_section=subsys_section,& - force_env_section=force_env_section,error=error) + force_env_section=force_env_section) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 5. Pack everything into the molecular types !----------------------------------------------------------------------------- CALL topology_connectivity_pack(molecule_kind_set,molecule_set,& - topology,subsys_section=subsys_section,error=error) + topology,subsys_section=subsys_section) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -387,36 +379,35 @@ SUBROUTINE create_small_subsys(small_subsys, big_subsys, small_cell,& !----------------------------------------------------------------------------- CALL topology_coordinate_pack(particle_set,atomic_kind_set,& molecule_kind_set,molecule_set,topology,subsys_section=subsys_section,& - force_env_section=force_env_section,ignore_outside_box=ignore_outside_box,& - error=error) + force_env_section=force_env_section,ignore_outside_box=ignore_outside_box) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 7. Cleanup the topology structure type !----------------------------------------------------------------------------- - CALL deallocate_topology(topology,error=error) + CALL deallocate_topology(topology) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 8. Allocate new subsys !----------------------------------------------------------------------------- ALLOCATE(small_subsys) - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) small_subsys%para_env => para_env - CALL particle_list_create(particles,els_ptr=particle_set,error=error) - CALL atomic_kind_list_create(atomic_kinds,els_ptr=atomic_kind_set,error=error) - CALL mol_new_list_create(mols,els_ptr=molecule_set,error=error) - CALL mol_kind_new_list_create(mol_kinds,els_ptr=molecule_kind_set,error=error) + CALL particle_list_create(particles,els_ptr=particle_set) + CALL atomic_kind_list_create(atomic_kinds,els_ptr=atomic_kind_set) + CALL mol_new_list_create(mols,els_ptr=molecule_set) + CALL mol_kind_new_list_create(mol_kinds,els_ptr=molecule_kind_set) CALL cp_subsys_set(small_subsys,particles=particles,atomic_kinds=atomic_kinds,& - molecules_new=mols,molecule_kinds_new=mol_kinds,error=error) - CALL particle_list_release(particles,error=error) - CALL atomic_kind_list_release(atomic_kinds,error=error) - CALL mol_new_list_release(mols,error=error) - CALL mol_kind_new_list_release(mol_kinds,error=error) - - CALL virial_create(small_subsys%virial, error=error) - CALL atprop_create(small_subsys%atprop,error) - CALL cp_result_create(small_subsys%results,error=error) + molecules_new=mols,molecule_kinds_new=mol_kinds) + CALL particle_list_release(particles) + CALL atomic_kind_list_release(atomic_kinds) + CALL mol_new_list_release(mols) + CALL mol_kind_new_list_release(mol_kinds) + + CALL virial_create(small_subsys%virial) + CALL atprop_create(small_subsys%atprop) + CALL cp_result_create(small_subsys%results) END SUBROUTINE create_small_subsys END MODULE cp_subsys_methods diff --git a/src/cp_symmetry.F b/src/cp_symmetry.F index fc0870ec35..2a25fd6fae 100644 --- a/src/cp_symmetry.F +++ b/src/cp_symmetry.F @@ -53,16 +53,14 @@ MODULE cp_symmetry !> \param particle_set Atom coordinates and types !> \param cell Cell information !> \param input_section Input -!> \param error CP2K error handling !> \par History !> \author jgh ! ***************************************************************************** - SUBROUTINE write_symmetry(particle_set,cell,input_section,error) + SUBROUTINE write_symmetry(particle_set,cell,input_section) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: input_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_symmetry', & routineP = moduleN//':'//routineN @@ -91,27 +89,26 @@ SUBROUTINE write_symmetry(particle_set,cell,input_section,error) NULLIFY (logger) NULLIFY (section) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger=logger,& basis_section=input_section,& print_key_path="PRINT%SYMMETRY",& - extension=".symLog",& - error=error) + extension=".symLog") IF (iw > 0) THEN section => section_vals_get_subs_vals(section_vals=input_section,& - subsection_name="PRINT%SYMMETRY",error=error) + subsection_name="PRINT%SYMMETRY") CALL section_vals_val_get(section_vals=section,& - keyword_name="MOLECULE",l_val=molecular,error=error) + keyword_name="MOLECULE",l_val=molecular) CALL section_vals_val_get(section_vals=section,& - keyword_name="EPS_GEO",r_val=eps_geo,error=error) + keyword_name="EPS_GEO",r_val=eps_geo) IF ( molecular ) THEN NULLIFY(mol_sym) natom = SIZE(particle_set) ALLOCATE(coord(3,natom),z(natom),weight(natom),atype(natom),element(natom),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO i=1,natom CALL get_atomic_kind(particle_set(i)%atomic_kind, z=z(i)) @@ -121,38 +118,38 @@ SUBROUTINE write_symmetry(particle_set,cell,input_section,error) END DO weight(:) = weight(:)/massunit - CALL molecular_symmetry(mol_sym,eps_geo,coord,atype,weight,error) + CALL molecular_symmetry(mol_sym,eps_geo,coord,atype,weight) CALL section_vals_val_get(section_vals=section,& - keyword_name="STANDARD_ORIENTATION",l_val=pcoor,error=error) + keyword_name="STANDARD_ORIENTATION",l_val=pcoor) CALL section_vals_val_get(section_vals=section,& - keyword_name="INERTIA",l_val=pinertia,error=error) + keyword_name="INERTIA",l_val=pinertia) CALL section_vals_val_get(section_vals=section,& - keyword_name="SYMMETRY_ELEMENTS",l_val=psymmele,error=error) + keyword_name="SYMMETRY_ELEMENTS",l_val=psymmele) CALL section_vals_val_get(section_vals=section,& - keyword_name="ALL",l_val=pall,error=error) + keyword_name="ALL",l_val=pall) plevel = 0 IF ( pcoor ) plevel = plevel + 1 IF ( pinertia ) plevel = plevel + 10 IF ( psymmele ) plevel = plevel + 100 IF ( pall ) plevel = 1111111111 - CALL print_symmetry(mol_sym,coord,atype,element,z,weight,iw,plevel,error) + CALL print_symmetry(mol_sym,coord,atype,element,z,weight,iw,plevel) CALL section_vals_val_get(section_vals=section,& - keyword_name="CHECK_SYMMETRY",c_val=esymm,error=error) + keyword_name="CHECK_SYMMETRY",c_val=esymm) CALL uppercase(esymm) IF ( TRIM(esymm) /= "NONE" ) THEN csymm = mol_sym%point_group_symbol CALL uppercase(csymm) check = TRIM(ADJUSTL(csymm)) == TRIM(ADJUSTL(esymm)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF DEALLOCATE(coord,z,weight,atype,element,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) - CALL release_molsym(mol_sym,error) + CALL release_molsym(mol_sym) ELSE ! Crystal symmetry @@ -161,7 +158,7 @@ SUBROUTINE write_symmetry(particle_set,cell,input_section,error) natom = SIZE(particle_set) ALLOCATE(coord(3,natom),z(natom),weight(natom),atype(natom),element(natom),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO i=1,natom CALL get_atomic_kind(particle_set(i)%atomic_kind, z=z(i)) @@ -171,21 +168,21 @@ SUBROUTINE write_symmetry(particle_set,cell,input_section,error) END DO weight(:) = weight(:)/massunit - CALL kp_sym_gen(crys_sym,coord,atype,cell%hmat,delta=eps_geo,iounit=iw,error=error) + CALL kp_sym_gen(crys_sym,coord,atype,cell%hmat,delta=eps_geo,iounit=iw) CALL section_vals_val_get(section_vals=section,& - keyword_name="ROTATION_MATRICES",l_val=prmat,error=error) + keyword_name="ROTATION_MATRICES",l_val=prmat) CALL section_vals_val_get(section_vals=section,& - keyword_name="ALL",l_val=pall,error=error) + keyword_name="ALL",l_val=pall) plevel = 0 IF ( prmat ) plevel = plevel + 1 IF ( pall ) plevel = 1111111111 crys_sym%plevel = plevel - CALL print_crys_symmetry(crys_sym,error) + CALL print_crys_symmetry(crys_sym) CALL section_vals_val_get(section_vals=section,& - keyword_name="CHECK_SYMMETRY",c_val=esymm,error=error) + keyword_name="CHECK_SYMMETRY",c_val=esymm) CALL uppercase(esymm) IF ( TRIM(esymm) /= "NONE" ) THEN csym1 = pgrp(crys_sym%indpg) @@ -193,15 +190,15 @@ SUBROUTINE write_symmetry(particle_set,cell,input_section,error) csym2 = pgrd(crys_sym%indpg) CALL uppercase(csym2) check = (TRIM(ADJUSTL(csym1)) == TRIM(ADJUSTL(esymm))).OR.(TRIM(ADJUSTL(csym2)) == TRIM(ADJUSTL(esymm))) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF - CALL release_csym_type(crys_sym,error) + CALL release_csym_type(crys_sym) END IF END IF - CALL cp_print_key_finished_output(iw,logger,input_section,"PRINT%SYMMETRY", error=error) + CALL cp_print_key_finished_output(iw,logger,input_section,"PRINT%SYMMETRY") CALL timestop(handle) diff --git a/src/csvr_system_types.F b/src/csvr_system_types.F index 6809e27c35..c9b77fd00f 100644 --- a/src/csvr_system_types.F +++ b/src/csvr_system_types.F @@ -60,15 +60,12 @@ MODULE csvr_system_types !> \param csvr ... !> \param simpar ... !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE csvr_init(csvr, simpar, section, error) + SUBROUTINE csvr_init(csvr, simpar, section) TYPE(csvr_system_type), POINTER :: csvr TYPE(simpar_type), POINTER :: simpar TYPE(section_vals_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csvr_init', & routineP = moduleN//':'//routineN @@ -79,25 +76,22 @@ SUBROUTINE csvr_init(csvr, simpar, section, error) csvr%glob_num_csvr=0 csvr%dt_fact=1.0_dp CALL cite_reference(Bussi2007) - CALL section_vals_val_get(section,"TIMECON",r_val=csvr%tau_csvr,error=error) + CALL section_vals_val_get(section,"TIMECON",r_val=csvr%tau_csvr) ! The CSVR library expects the tau_csv to be in unit of integration timestep ! if applied once.. divided by two if the process is applied both to the first ! and the second verlet step csvr%tau_csvr = csvr%tau_csvr/(0.5_dp*simpar%dt) - CALL create_map_info_type(csvr%map_info, error) + CALL create_map_info_type(csvr%map_info) END SUBROUTINE csvr_init ! ***************************************************************************** !> \brief Initialize NVT type for CSVR thermostat !> \param csvr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE csvr_thermo_create(csvr, error) + SUBROUTINE csvr_thermo_create(csvr) TYPE(csvr_system_type), POINTER :: csvr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csvr_thermo_create', & routineP = moduleN//':'//routineN @@ -110,26 +104,26 @@ SUBROUTINE csvr_thermo_create(csvr, error) REAL(KIND=dp), DIMENSION(3, 2) :: initial_seed, my_seed failure = .FALSE. - CPPrecondition(ASSOCIATED(csvr),cp_fatal_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(csvr%nvt),cp_fatal_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(csvr),cp_fatal_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(csvr%nvt),cp_fatal_level,routineP,failure) ALLOCATE ( csvr%nvt(csvr%loc_num_csvr),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, csvr%loc_num_csvr csvr%nvt(i)%thermostat_energy = 0.0_dp NULLIFY(csvr%nvt(i)%gaussian_rng_stream) END DO ! Initialize the gaussian stream random number ALLOCATE (seed(3,2,csvr%glob_num_csvr),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - initial_seed = next_rng_seed(error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + initial_seed = next_rng_seed() seed(:,:,1) = initial_seed DO ithermo=2,csvr%glob_num_csvr - seed(:,:,ithermo) = next_rng_seed(seed(:,:,ithermo-1),error=error) + seed(:,:,ithermo) = next_rng_seed(seed(:,:,ithermo-1)) END DO ! Update initial seed - initial_seed = next_rng_seed(seed(:,:,csvr%glob_num_csvr),error=error) + initial_seed = next_rng_seed(seed(:,:,csvr%glob_num_csvr)) DO ithermo = 1, csvr%loc_num_csvr my_index = csvr%map_info%index(ithermo) my_seed = seed(:,:,my_index) @@ -137,23 +131,20 @@ SUBROUTINE csvr_thermo_create(csvr, error) CALL compress(name) CALL create_rng_stream(rng_stream=csvr%nvt(ithermo)%gaussian_rng_stream,& name=name,distribution_type=GAUSSIAN, extended_precision=.TRUE.,& - seed=my_seed,error=error) + seed=my_seed) END DO DEALLOCATE (seed,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE csvr_thermo_create ! ***************************************************************************** !> \brief Deallocate type for CSVR thermostat !> \param csvr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE csvr_dealloc ( csvr, error ) + SUBROUTINE csvr_dealloc ( csvr) TYPE(csvr_system_type), POINTER :: csvr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csvr_dealloc', & routineP = moduleN//':'//routineN @@ -163,10 +154,10 @@ SUBROUTINE csvr_dealloc ( csvr, error ) failure = .FALSE. IF (ASSOCIATED(csvr)) THEN - CALL csvr_thermo_dealloc(csvr%nvt, error) - CALL release_map_info_type(csvr%map_info, error) + CALL csvr_thermo_dealloc(csvr%nvt) + CALL release_map_info_type(csvr%map_info) DEALLOCATE (csvr, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF END SUBROUTINE csvr_dealloc @@ -174,14 +165,11 @@ END SUBROUTINE csvr_dealloc ! ***************************************************************************** !> \brief Deallocate NVT type for CSVR thermostat !> \param nvt ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE csvr_thermo_dealloc ( nvt, error ) + SUBROUTINE csvr_thermo_dealloc ( nvt) TYPE(csvr_thermo_type), DIMENSION(:), & POINTER :: nvt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csvr_thermo_dealloc', & routineP = moduleN//':'//routineN @@ -193,11 +181,11 @@ SUBROUTINE csvr_thermo_dealloc ( nvt, error ) IF (ASSOCIATED(nvt)) THEN DO i = 1, SIZE(nvt) IF (ASSOCIATED(nvt(i)%gaussian_rng_stream)) THEN - CALL delete_rng_stream(nvt(i)%gaussian_rng_stream,error=error) + CALL delete_rng_stream(nvt(i)%gaussian_rng_stream) ENDIF END DO DEALLOCATE (nvt, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF END SUBROUTINE csvr_thermo_dealloc diff --git a/src/csvr_system_utils.F b/src/csvr_system_utils.F index 88ea40b513..58751b4f53 100644 --- a/src/csvr_system_utils.F +++ b/src/csvr_system_utils.F @@ -73,17 +73,15 @@ MODULE csvr_system_utils !> \param ndeg ... !> \param taut ... !> \param rng_stream ... -!> \param error ... !> \retval my_res ... !> \date 09.2007 !> \author Giovanni Bussi - ETH Zurich, Lugano 10.2007 ! ***************************************************************************** - FUNCTION rescaling_factor(kk, sigma, ndeg, taut, rng_stream, error) RESULT(my_res) + FUNCTION rescaling_factor(kk, sigma, ndeg, taut, rng_stream) RESULT(my_res) REAL(KIND=dp), INTENT(IN) :: kk, sigma INTEGER, INTENT(IN) :: ndeg REAL(KIND=dp), INTENT(IN) :: taut TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp) :: my_res CHARACTER(len=*), PARAMETER :: routineN = 'rescaling_factor', & @@ -98,7 +96,7 @@ FUNCTION rescaling_factor(kk, sigma, ndeg, taut, rng_stream, error) RESULT(my_re ELSE factor=0.0_dp END IF - rr = next_random_number(rng_stream,error=error) + rr = next_random_number(rng_stream) reverse=1.0_dp ! reverse of momentum is implemented to have the correct limit to Langevin dynamics for ndeg=1 IF(rr<-SQRT(ndeg*kk*factor/(sigma*(1.0_dp-factor)))) reverse=-1.0_dp @@ -106,7 +104,7 @@ FUNCTION rescaling_factor(kk, sigma, ndeg, taut, rng_stream, error) RESULT(my_re ! in practice, it is better to skip it to avoid unnecessary slowing down of the dynamics in the small taut regime ! anyway, this should not affect the final ensemble IF(ndeg/=1) reverse=1.0_dp - resample = kk + (1.0_dp-factor)* (sigma*(sumnoises(ndeg-1, rng_stream, error)+rr**2)/REAL(ndeg,KIND=dp)-kk) & + resample = kk + (1.0_dp-factor)* (sigma*(sumnoises(ndeg-1, rng_stream)+rr**2)/REAL(ndeg,KIND=dp)-kk) & + 2.0_dp*rr*SQRT(kk*sigma/ndeg*(1.0_dp-factor)*factor) resample=MAX(0.0_dp,resample) @@ -119,15 +117,13 @@ END FUNCTION rescaling_factor !> (i.e. equivalent to summing the square of the return values of nn calls to gasdev) !> \param nn ... !> \param rng_stream ... -!> \param error ... !> \retval sum_gauss ... !> \date 09.2007 !> \author Teo - University of Zurich ! ***************************************************************************** - FUNCTION sumnoises(nn, rng_stream, error) RESULT(sum_gauss) + FUNCTION sumnoises(nn, rng_stream) RESULT(sum_gauss) INTEGER, INTENT(IN) :: nn TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp) :: sum_gauss CHARACTER(len=*), PARAMETER :: routineN = 'sumnoises', & @@ -137,7 +133,7 @@ FUNCTION sumnoises(nn, rng_stream, error) RESULT(sum_gauss) sum_gauss = 0.0_dp DO i = 1, nn - sum_gauss = sum_gauss + next_random_number(rng_stream,error=error)**2 + sum_gauss = sum_gauss + next_random_number(rng_stream)**2 END DO END FUNCTION sumnoises diff --git a/src/ct_methods.F b/src/ct_methods.F index ac1af1353c..de9ff6d50c 100644 --- a/src/ct_methods.F +++ b/src/ct_methods.F @@ -53,15 +53,13 @@ MODULE ct_methods ! ***************************************************************************** !> \brief Performs Cayley transformation !> \param cts_env ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE ct_step_execute(cts_env,error) + SUBROUTINE ct_step_execute(cts_env) TYPE(ct_step_env_type) :: cts_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ct_step_execute', & routineP = moduleN//':'//routineN @@ -85,7 +83,7 @@ SUBROUTINE ct_step_execute(cts_env,error) CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -94,83 +92,83 @@ SUBROUTINE ct_step_execute(cts_env,error) ! check if all input is in place and flags are consistent IF (cts_env%update_q.AND.(.NOT.cts_env%update_p)) THEN - CPErrorMessage(cp_failure_level,routineP,"q-update is possible only with p-update",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"q-update is possible only with p-update") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (cts_env%tensor_type.eq.tensor_up_down) THEN - CPErrorMessage(cp_failure_level,routineP,"riccati is not implemented for biorthogonal basis",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"riccati is not implemented for biorthogonal basis") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (.NOT.ASSOCIATED(cts_env%matrix_ks)) THEN - CPErrorMessage(cp_failure_level,routineP,"KS matrix is not associated",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"KS matrix is not associated") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (cts_env%use_virt_orbs.AND.(.NOT.cts_env%use_occ_orbs)) THEN - CPErrorMessage(cp_failure_level,routineP,"virtual orbs can be used only with occupied orbs",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"virtual orbs can be used only with occupied orbs") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (cts_env%use_occ_orbs) THEN IF (.NOT.ASSOCIATED(cts_env%matrix_t)) THEN - CPErrorMessage(cp_failure_level,routineP,"T matrix is not associated",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"T matrix is not associated") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (.NOT.ASSOCIATED(cts_env%matrix_qp_template)) THEN - CPErrorMessage(cp_failure_level,routineP,"QP template is not associated",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"QP template is not associated") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF (.NOT.ASSOCIATED(cts_env%matrix_pq_template)) THEN - CPErrorMessage(cp_failure_level,routineP,"PQ template is not associated",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"PQ template is not associated") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDIF IF (cts_env%use_virt_orbs) THEN IF (.NOT.ASSOCIATED(cts_env%matrix_v)) THEN - CPErrorMessage(cp_failure_level,routineP,"V matrix is not associated",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"V matrix is not associated") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ELSE IF (.NOT.ASSOCIATED(cts_env%matrix_p)) THEN - CPErrorMessage(cp_failure_level,routineP,"P matrix is not associated",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"P matrix is not associated") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDIF IF (cts_env%tensor_type.NE.tensor_up_down.AND.& cts_env%tensor_type.NE.tensor_orthogonal) THEN - CPErrorMessage(cp_failure_level,routineP,"illegal tensor flag",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal tensor flag") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! start real calculations IF (cts_env%use_occ_orbs) THEN ! create matrices for various ks blocks - CALL cp_dbcsr_init(matrix_pp,error=error) + CALL cp_dbcsr_init(matrix_pp) CALL cp_dbcsr_create(matrix_pp,& template=cts_env%p_index_up,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_qp,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_qp) CALL cp_dbcsr_create(matrix_qp,& template=cts_env%matrix_qp_template,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_qq,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_qq) CALL cp_dbcsr_create(matrix_qq,& template=cts_env%q_index_up,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_pq,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_pq) CALL cp_dbcsr_create(matrix_pq,& template=cts_env%matrix_pq_template,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ! create the residue matrix - CALL cp_dbcsr_init(cts_env%matrix_res,error=error) + CALL cp_dbcsr_init(cts_env%matrix_res) CALL cp_dbcsr_create(cts_env%matrix_res,& - template=cts_env%matrix_qp_template,error=error) + template=cts_env%matrix_qp_template) CALL assemble_ks_qp_blocks(cts_env%matrix_ks,& cts_env%matrix_p,& @@ -185,31 +183,30 @@ SUBROUTINE ct_step_execute(cts_env,error) matrix_pq,& cts_env%tensor_type,& cts_env%use_virt_orbs,& - cts_env%eps_filter,& - error) + cts_env%eps_filter) ! create a matrix of single-excitation amplitudes - CALL cp_dbcsr_init(cts_env%matrix_x,error=error) + CALL cp_dbcsr_init(cts_env%matrix_x) CALL cp_dbcsr_create(cts_env%matrix_x,& - template=cts_env%matrix_qp_template,error=error) + template=cts_env%matrix_qp_template) IF (ASSOCIATED(cts_env%matrix_x_guess)) THEN CALL cp_dbcsr_copy(cts_env%matrix_x,& - cts_env%matrix_x_guess,error=error) + cts_env%matrix_x_guess) IF (cts_env%tensor_type.eq.tensor_orthogonal) THEN ! bring x from contravariant-covariant representation ! to the orthogonal/cholesky representation ! use res as temporary storage CALL cp_dbcsr_multiply("N","N",1.0_dp,cts_env%q_index_down,& cts_env%matrix_x,0.0_dp,cts_env%matrix_res,& - filter_eps=cts_env%eps_filter,error=error) + filter_eps=cts_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,cts_env%matrix_res,& cts_env%p_index_up,0.0_dp,& cts_env%matrix_x,& - filter_eps=cts_env%eps_filter,error=error) + filter_eps=cts_env%eps_filter) ENDIF ELSE ! set amplitudes to zero - CALL cp_dbcsr_set(cts_env%matrix_x,0.0_dp,error=error) + CALL cp_dbcsr_set(cts_env%matrix_x,0.0_dp) ENDIF !SELECT CASE (cts_env%preconditioner_type) @@ -222,45 +219,45 @@ SUBROUTINE ct_step_execute(cts_env,error) !RZK-warning diagonalization works only with orthogonal tensor!!! ! find a better basis by diagonalizing diagonal blocks ! first pp - CALL cp_dbcsr_init(u_pp,error=error) + CALL cp_dbcsr_init(u_pp) CALL cp_dbcsr_create(u_pp,template=matrix_pp,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) !IF (cts_env%preconditioner_type.eq.prec_eigenvector_full) THEN IF (.TRUE.) THEN CALL cp_dbcsr_get_info(matrix_pp, nfullrows_total=n ) ALLOCATE(evals(n)) CALL cp_dbcsr_syevd(matrix_pp,u_pp,evals,& - cts_env%para_env,cts_env%blacs_env,error=error) + cts_env%para_env,cts_env%blacs_env) DEALLOCATE(evals) ELSE - CALL diagonalize_diagonal_blocks(matrix_pp,u_pp,error=error) + CALL diagonalize_diagonal_blocks(matrix_pp,u_pp) ENDIF ! and now qq - CALL cp_dbcsr_init(u_qq,error=error) + CALL cp_dbcsr_init(u_qq) CALL cp_dbcsr_create(u_qq,template=matrix_qq,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) !IF (cts_env%preconditioner_type.eq.prec_eigenvector_full) THEN IF (.TRUE.) THEN CALL cp_dbcsr_get_info(matrix_qq, nfullrows_total=n ) ALLOCATE(evals(n)) CALL cp_dbcsr_syevd(matrix_qq,u_qq,evals,& - cts_env%para_env,cts_env%blacs_env,error=error) + cts_env%para_env,cts_env%blacs_env) DEALLOCATE(evals) ELSE - CALL diagonalize_diagonal_blocks(matrix_qq,u_qq,error=error) + CALL diagonalize_diagonal_blocks(matrix_qq,u_qq) ENDIF ! apply the transformation to all matrices CALL matrix_forward_transform(matrix_pp,u_pp,u_pp,& - cts_env%eps_filter,error) + cts_env%eps_filter) CALL matrix_forward_transform(matrix_qq,u_qq,u_qq,& - cts_env%eps_filter,error) + cts_env%eps_filter) CALL matrix_forward_transform(matrix_qp,u_qq,u_pp,& - cts_env%eps_filter,error) + cts_env%eps_filter) CALL matrix_forward_transform(matrix_pq,u_pp,u_qq,& - cts_env%eps_filter,error) + cts_env%eps_filter) CALL matrix_forward_transform(cts_env%matrix_x,u_qq,u_pp,& - cts_env%eps_filter,error) + cts_env%eps_filter) IF ( cts_env%max_iter.ge.0 ) THEN @@ -276,8 +273,7 @@ SUBROUTINE ct_step_execute(cts_env,error) max_iter=cts_env%max_iter,& eps_convergence=cts_env%eps_convergence,& eps_filter=cts_env%eps_filter,& - converged=cts_env%converged,& - error=error) + converged=cts_env%converged) IF (cts_env%converged) THEN !IF (unit_nr>0) THEN @@ -291,7 +287,7 @@ SUBROUTINE ct_step_execute(cts_env,error) WRITE(unit_nr,'(T6,A)') & "RICCATI: CG algorithm has NOT converged" ENDIF - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDIF @@ -299,94 +295,94 @@ SUBROUTINE ct_step_execute(cts_env,error) IF (cts_env%calculate_energy_corr) THEN CALL cp_dbcsr_trace(matrix_qp,cts_env%matrix_x,& - cts_env%energy_correction,"T","N",error=error) + cts_env%energy_correction,"T","N") ENDIF - CALL cp_dbcsr_release(matrix_pp,error=error) - CALL cp_dbcsr_release(matrix_qp,error=error) - CALL cp_dbcsr_release(matrix_qq,error=error) - CALL cp_dbcsr_release(matrix_pq,error=error) + CALL cp_dbcsr_release(matrix_pp) + CALL cp_dbcsr_release(matrix_qp) + CALL cp_dbcsr_release(matrix_qq) + CALL cp_dbcsr_release(matrix_pq) ! back-transform to the original basis CALL matrix_backward_transform(cts_env%matrix_x,u_qq,& - u_pp,cts_env%eps_filter,error) + u_pp,cts_env%eps_filter) - CALL cp_dbcsr_release(u_qq,error=error) - CALL cp_dbcsr_release(u_pp,error=error) + CALL cp_dbcsr_release(u_qq) + CALL cp_dbcsr_release(u_pp) !CASE (prec_cholesky_inverse) CASE (3) ! RZK-warning implemented only for orthogonal tensors!!! ! generalization to up_down should be easy - CALL cp_dbcsr_init(u_pp,error=error) + CALL cp_dbcsr_init(u_pp) CALL cp_dbcsr_create(u_pp,template=matrix_pp,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(u_pp,matrix_pp,error=error) - CALL cp_dbcsr_scale(u_pp,-1.0_dp,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(u_pp,matrix_pp) + CALL cp_dbcsr_scale(u_pp,-1.0_dp) CALL cp_dbcsr_add_on_diag(u_pp,& - ABS(safety_margin*gap_estimate),error=error) + ABS(safety_margin*gap_estimate)) CALL cp_dbcsr_cholesky_decompose(u_pp,& para_env=cts_env%para_env,& - blacs_env=cts_env%blacs_env,error=error) + blacs_env=cts_env%blacs_env) CALL cp_dbcsr_cholesky_invert(u_pp,& para_env=cts_env%para_env,& blacs_env=cts_env%blacs_env,& - upper_to_full=.TRUE.,error=error) - !CALL cp_dbcsr_scale(u_pp,-1.0_dp,error=error) + upper_to_full=.TRUE.) + !CALL cp_dbcsr_scale(u_pp,-1.0_dp) - CALL cp_dbcsr_init(u_qq,error=error) + CALL cp_dbcsr_init(u_qq) CALL cp_dbcsr_create(u_qq,template=matrix_qq,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(u_qq,matrix_qq,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(u_qq,matrix_qq) CALL cp_dbcsr_add_on_diag(u_qq,& - ABS(safety_margin*gap_estimate),error=error) + ABS(safety_margin*gap_estimate)) CALL cp_dbcsr_cholesky_decompose(u_qq,& para_env=cts_env%para_env,& - blacs_env=cts_env%blacs_env,error=error) + blacs_env=cts_env%blacs_env) CALL cp_dbcsr_cholesky_invert(u_qq,& para_env=cts_env%para_env,& blacs_env=cts_env%blacs_env,& - upper_to_full=.TRUE.,error=error) + upper_to_full=.TRUE.) ! transform all riccati matrices (left-right preconditioner) - CALL cp_dbcsr_init(tmp1,error=error) + CALL cp_dbcsr_init(tmp1) CALL cp_dbcsr_create(tmp1,template=matrix_qq,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,u_qq,& matrix_qq,0.0_dp,tmp1,& - filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_copy(matrix_qq,tmp1,error=error) - CALL cp_dbcsr_release(tmp1,error=error) + filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_copy(matrix_qq,tmp1) + CALL cp_dbcsr_release(tmp1) - CALL cp_dbcsr_init(tmp1,error=error) + CALL cp_dbcsr_init(tmp1) CALL cp_dbcsr_create(tmp1,template=matrix_pp,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_pp,& u_pp,0.0_dp,tmp1,& - filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_copy(matrix_pp,tmp1,error=error) - CALL cp_dbcsr_release(tmp1,error=error) + filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_copy(matrix_pp,tmp1) + CALL cp_dbcsr_release(tmp1) - CALL cp_dbcsr_init(matrix_qp_save,error=error) + CALL cp_dbcsr_init(matrix_qp_save) CALL cp_dbcsr_create(matrix_qp_save,template=matrix_qp,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(matrix_qp_save,matrix_qp,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(matrix_qp_save,matrix_qp) - CALL cp_dbcsr_init(tmp1,error=error) + CALL cp_dbcsr_init(tmp1) CALL cp_dbcsr_create(tmp1,template=matrix_qp,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_qp,& u_pp,0.0_dp,tmp1,& - filter_eps=cts_env%eps_filter,error=error) + filter_eps=cts_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,u_qq,tmp1,& 0.0_dp,matrix_qp,& - filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_release(tmp1,error=error) -!CALL cp_dbcsr_print(matrix_qq,error=error) -!CALL cp_dbcsr_print(matrix_qp,error=error) -!CALL cp_dbcsr_print(matrix_pp,error=error) + filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_release(tmp1) +!CALL cp_dbcsr_print(matrix_qq) +!CALL cp_dbcsr_print(matrix_qp) +!CALL cp_dbcsr_print(matrix_pp) IF ( cts_env%max_iter.ge.0 ) THEN @@ -404,8 +400,7 @@ SUBROUTINE ct_step_execute(cts_env,error) max_iter=cts_env%max_iter,& eps_convergence=cts_env%eps_convergence,& eps_filter=cts_env%eps_filter,& - converged=cts_env%converged,& - error=error) + converged=cts_env%converged) IF (cts_env%converged) THEN !IF (unit_nr>0) THEN @@ -419,7 +414,7 @@ SUBROUTINE ct_step_execute(cts_env,error) WRITE(unit_nr,'(T6,A)') & "RICCATI: CG algorithm has NOT converged" ENDIF - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDIF @@ -427,50 +422,50 @@ SUBROUTINE ct_step_execute(cts_env,error) IF (cts_env%calculate_energy_corr) THEN CALL cp_dbcsr_trace(matrix_qp_save,cts_env%matrix_x,& - cts_env%energy_correction,"T","N",error=error) + cts_env%energy_correction,"T","N") ENDIF - CALL cp_dbcsr_release(matrix_qp_save,error=error) + CALL cp_dbcsr_release(matrix_qp_save) - CALL cp_dbcsr_release(matrix_pp,error=error) - CALL cp_dbcsr_release(matrix_qp,error=error) - CALL cp_dbcsr_release(matrix_qq,error=error) - CALL cp_dbcsr_release(matrix_pq,error=error) + CALL cp_dbcsr_release(matrix_pp) + CALL cp_dbcsr_release(matrix_qp) + CALL cp_dbcsr_release(matrix_qq) + CALL cp_dbcsr_release(matrix_pq) - CALL cp_dbcsr_release(u_qq,error=error) - CALL cp_dbcsr_release(u_pp,error=error) + CALL cp_dbcsr_release(u_qq) + CALL cp_dbcsr_release(u_pp) CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"illegal preconditioner type",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal preconditioner type") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! preconditioner type IF (cts_env%update_p) THEN IF (cts_env%tensor_type.eq.tensor_up_down) THEN - CPErrorMessage(cp_failure_level,routineP,"orbital update is NYI for this tensor type",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"orbital update is NYI for this tensor type") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! transform occupied orbitals ! in a way that preserves the overlap metric - CALL cp_dbcsr_init(oo1,error=error) + CALL cp_dbcsr_init(oo1) CALL cp_dbcsr_create(oo1,& template=cts_env%p_index_up,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(oo1_sqrt_inv,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(oo1_sqrt_inv) CALL cp_dbcsr_create(oo1_sqrt_inv,& - template=oo1,error=error) - CALL cp_dbcsr_init(oo1_sqrt,error=error) + template=oo1) + CALL cp_dbcsr_init(oo1_sqrt) CALL cp_dbcsr_create(oo1_sqrt,& - template=oo1,error=error) + template=oo1) ! Compute (1+tr(X).X)^(-1/2)_up_down CALL cp_dbcsr_multiply("T","N",1.0_dp,cts_env%matrix_x,& cts_env%matrix_x,0.0_dp,oo1,& - filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_add_on_diag(oo1,1.0_dp,error=error) + filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_add_on_diag(oo1,1.0_dp) CALL matrix_sqrt_Newton_Schulz(oo1_sqrt,& oo1_sqrt_inv,& oo1,& @@ -481,76 +476,74 @@ SUBROUTINE ct_step_execute(cts_env,error) threshold=cts_env%eps_filter,& order=cts_env%order_lanczos,& eps_lanczos=cts_env%eps_lancsoz,& - max_iter_lanczos=cts_env%max_iter_lanczos,& - error=error) + max_iter_lanczos=cts_env%max_iter_lanczos) CALL cp_dbcsr_multiply("N","N",1.0_dp,cts_env%p_index_up,& oo1_sqrt_inv,0.0_dp,oo1,& - filter_eps=cts_env%eps_filter,error=error) + filter_eps=cts_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,oo1,& cts_env%p_index_down,0.0_dp,oo1_sqrt,& - filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_release(oo1,error=error) - CALL cp_dbcsr_release(oo1_sqrt_inv,error=error) + filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_release(oo1) + CALL cp_dbcsr_release(oo1_sqrt_inv) ! bring x to contravariant-covariant representation now - CALL cp_dbcsr_init(matrix_qp,error=error) + CALL cp_dbcsr_init(matrix_qp) CALL cp_dbcsr_create(matrix_qp,& template=cts_env%matrix_qp_template,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,cts_env%q_index_up,& cts_env%matrix_x,0.0_dp,matrix_qp,& - filter_eps=cts_env%eps_filter,error=error) + filter_eps=cts_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_qp,& cts_env%p_index_down,0.0_dp,& cts_env%matrix_x,& - filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_release(matrix_qp,error=error) + filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_release(matrix_qp) ! update T=T+X or T=T+V.X (whichever is appropriate) - CALL cp_dbcsr_init(t_corr, error=error) - CALL cp_dbcsr_create(t_corr,template=cts_env%matrix_t,& - error=error) + CALL cp_dbcsr_init(t_corr) + CALL cp_dbcsr_create(t_corr,template=cts_env%matrix_t) IF (cts_env%use_virt_orbs) THEN CALL cp_dbcsr_multiply("N","N",1.0_dp,cts_env%matrix_v,& cts_env%matrix_x,0.0_dp,t_corr,& - filter_eps=cts_env%eps_filter,error=error) + filter_eps=cts_env%eps_filter) CALL cp_dbcsr_add(cts_env%matrix_t,t_corr,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) ELSE CALL cp_dbcsr_add(cts_env%matrix_t,cts_env%matrix_x,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) ENDIF ! adjust T so the metric is preserved: T=(T+X).(1+tr(X).X)^(-1/2) CALL cp_dbcsr_multiply("N","N",1.0_dp,cts_env%matrix_t,oo1_sqrt,& - 0.0_dp,t_corr,filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_copy(cts_env%matrix_t,t_corr,error=error) + 0.0_dp,t_corr,filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_copy(cts_env%matrix_t,t_corr) - CALL cp_dbcsr_release(t_corr,error=error) - CALL cp_dbcsr_release(oo1_sqrt,error=error) + CALL cp_dbcsr_release(t_corr) + CALL cp_dbcsr_release(oo1_sqrt) ELSE ! do not update p IF (cts_env%tensor_type.eq.tensor_orthogonal) THEN ! bring x to contravariant-covariant representation - CALL cp_dbcsr_init(matrix_qp,error=error) + CALL cp_dbcsr_init(matrix_qp) CALL cp_dbcsr_create(matrix_qp,& template=cts_env%matrix_qp_template,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,cts_env%q_index_up,& cts_env%matrix_x,0.0_dp,matrix_qp,& - filter_eps=cts_env%eps_filter,error=error) + filter_eps=cts_env%eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_qp,& cts_env%p_index_down,0.0_dp,& cts_env%matrix_x,& - filter_eps=cts_env%eps_filter,error=error) - CALL cp_dbcsr_release(matrix_qp,error=error) + filter_eps=cts_env%eps_filter) + CALL cp_dbcsr_release(matrix_qp) ENDIF ENDIF ELSE - CPErrorMessage(cp_failure_level,routineP,"illegal occ option",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal occ option") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle) @@ -573,13 +566,12 @@ END SUBROUTINE ct_step_execute !> \param tensor_type ... !> \param use_virt_orbs ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE assemble_ks_qp_blocks(ks,p,t,v,q_index_down,& - p_index_up,q_index_up,pp,qq,qp,pq,tensor_type,use_virt_orbs,eps_filter,error) + p_index_up,q_index_up,pp,qq,qp,pq,tensor_type,use_virt_orbs,eps_filter) TYPE(cp_dbcsr_type), INTENT(IN) :: ks, p, t, v, q_index_down, & p_index_up, q_index_up @@ -587,7 +579,6 @@ SUBROUTINE assemble_ks_qp_blocks(ks,p,t,v,q_index_down,& INTEGER, INTENT(IN) :: tensor_type LOGICAL, INTENT(IN) :: use_virt_orbs REAL(KIND=dp), INTENT(IN) :: eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'assemble_ks_qp_blocks', & routineP = moduleN//':'//routineN @@ -603,158 +594,156 @@ SUBROUTINE assemble_ks_qp_blocks(ks,p,t,v,q_index_down,& IF (use_virt_orbs) THEN ! orthogonalize the orbitals - CALL cp_dbcsr_init(t_or,error=error) - CALL cp_dbcsr_create(t_or,template=t,error=error) - CALL cp_dbcsr_init(v_or,error=error) - CALL cp_dbcsr_create(v_or,template=v,error=error) + CALL cp_dbcsr_init(t_or) + CALL cp_dbcsr_create(t_or,template=t) + CALL cp_dbcsr_init(v_or) + CALL cp_dbcsr_create(v_or,template=v) CALL cp_dbcsr_multiply("N","N",1.0_dp,t,p_index_up,& - 0.0_dp,t_or,filter_eps=eps_filter,error=error) + 0.0_dp,t_or,filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,v,q_index_up,& - 0.0_dp,v_or,filter_eps=eps_filter,error=error) + 0.0_dp,v_or,filter_eps=eps_filter) ! KS.T - CALL cp_dbcsr_init(kst,error=error) - CALL cp_dbcsr_create(kst,template=t,error=error) + CALL cp_dbcsr_init(kst) + CALL cp_dbcsr_create(kst,template=t) CALL cp_dbcsr_multiply("N","N",1.0_dp,ks,t_or,& - 0.0_dp,kst,filter_eps=eps_filter,error=error) + 0.0_dp,kst,filter_eps=eps_filter) ! pp=tr(T)*KS.T CALL cp_dbcsr_multiply("T","N",1.0_dp,t_or,kst,& - 0.0_dp,pp,filter_eps=eps_filter,error=error) + 0.0_dp,pp,filter_eps=eps_filter) ! qp=tr(V)*KS.T CALL cp_dbcsr_multiply("T","N",1.0_dp,v_or,kst,& - 0.0_dp,qp,filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(kst,error=error) + 0.0_dp,qp,filter_eps=eps_filter) + CALL cp_dbcsr_release(kst) ! KS.V - CALL cp_dbcsr_init(ksv,error=error) - CALL cp_dbcsr_create(ksv,template=v,error=error) + CALL cp_dbcsr_init(ksv) + CALL cp_dbcsr_create(ksv,template=v) CALL cp_dbcsr_multiply("N","N",1.0_dp,ks,v_or,& - 0.0_dp,ksv,filter_eps=eps_filter,error=error) + 0.0_dp,ksv,filter_eps=eps_filter) ! tr(T)*KS.V CALL cp_dbcsr_multiply("T","N",1.0_dp,t_or,ksv,& - 0.0_dp,pq,filter_eps=eps_filter,error=error) + 0.0_dp,pq,filter_eps=eps_filter) ! tr(V)*KS.V CALL cp_dbcsr_multiply("T","N",1.0_dp,v_or,ksv,& - 0.0_dp,qq,filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(ksv,error=error) + 0.0_dp,qq,filter_eps=eps_filter) + CALL cp_dbcsr_release(ksv) - CALL cp_dbcsr_release(t_or,error=error) - CALL cp_dbcsr_release(v_or,error=error) + CALL cp_dbcsr_release(t_or) + CALL cp_dbcsr_release(v_or) ELSE ! no virtuals, use projected AOs ! THIS PROCEDURE HAS NOT BEEN UPDATED FOR CHOLESKY p/q_index_up/down - CALL cp_dbcsr_init(sp,error=error) + CALL cp_dbcsr_init(sp) CALL cp_dbcsr_create(sp,template=q_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(spf,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(spf) CALL cp_dbcsr_create(spf,template=q_index_down,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ! qp=KS*T CALL cp_dbcsr_multiply("N","N",1.0_dp,ks,t,0.0_dp,qp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! pp=tr(T)*KS.T CALL cp_dbcsr_multiply("T","N",1.0_dp,t,qp,0.0_dp,pp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! sp=-S_*P CALL cp_dbcsr_multiply("N","N",-1.0_dp,q_index_down,p,0.0_dp,sp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! sp=1/S^-S_.P SELECT CASE (tensor_type) CASE (tensor_up_down) - CALL cp_dbcsr_add_on_diag(sp,1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(sp,1.0_dp) CASE (tensor_orthogonal) - CALL cp_dbcsr_init(q_index_up_nosym,error=error) + CALL cp_dbcsr_init(q_index_up_nosym) CALL cp_dbcsr_create(q_index_up_nosym,template=q_index_up,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_desymmetrize(q_index_up,q_index_up_nosym,error=error) - CALL cp_dbcsr_add(sp,q_index_up_nosym,1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_release(q_index_up_nosym,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_desymmetrize(q_index_up,q_index_up_nosym) + CALL cp_dbcsr_add(sp,q_index_up_nosym,1.0_dp,1.0_dp) + CALL cp_dbcsr_release(q_index_up_nosym) END SELECT ! spf=(1/S^-S_.P)*KS CALL cp_dbcsr_multiply("N","N",1.0_dp,sp,ks,0.0_dp,spf,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ! qp=spf*T CALL cp_dbcsr_multiply("N","N",1.0_dp,spf,t,0.0_dp,qp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) SELECT CASE (tensor_type) CASE (tensor_up_down) ! pq=tr(qp) - CALL cp_dbcsr_transposed(pq,qp,transpose_distribution=.FALSE.,& - error=error) + CALL cp_dbcsr_transposed(pq,qp,transpose_distribution=.FALSE.) CASE (tensor_orthogonal) ! pq=sig^.tr(qp) CALL cp_dbcsr_multiply("N","T",1.0_dp,p_index_up,qp,0.0_dp,pq,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) library_fixed=.FALSE. IF (library_fixed) THEN - CALL cp_dbcsr_transposed(qp,pq,transpose_distribution=.FALSE.,& - error=error) + CALL cp_dbcsr_transposed(qp,pq,transpose_distribution=.FALSE.) ELSE - CALL cp_dbcsr_init(no,error=error) + CALL cp_dbcsr_init(no) CALL cp_dbcsr_create(no,template=qp,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,qp,p_index_up,0.0_dp,no,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_copy(qp,no,error=error) - CALL cp_dbcsr_release(no,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_copy(qp,no) + CALL cp_dbcsr_release(no) ENDIF END SELECT ! qq=spf*tr(sp) CALL cp_dbcsr_multiply("N","T",1.0_dp,spf,sp,0.0_dp,qq,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) SELECT CASE (tensor_type) CASE (tensor_up_down) - CALL cp_dbcsr_init(oo,error=error) + CALL cp_dbcsr_init(oo) CALL cp_dbcsr_create(oo,template=pp,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(no,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(no) CALL cp_dbcsr_create(no,template=qp,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ! first index up CALL cp_dbcsr_multiply("N","N",1.0_dp,q_index_up,qq,0.0_dp,spf,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_copy(qq,spf,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_copy(qq,spf) CALL cp_dbcsr_multiply("N","N",1.0_dp,q_index_up,qp,0.0_dp,no,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_copy(qp,no,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_copy(qp,no) CALL cp_dbcsr_multiply("N","N",1.0_dp,p_index_up,pp,0.0_dp,oo,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_copy(pp,oo,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_copy(pp,oo) CALL cp_dbcsr_multiply("N","N",1.0_dp,p_index_up,pq,0.0_dp,on,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_copy(pq,on,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_copy(pq,on) - CALL cp_dbcsr_release(no,error=error) - CALL cp_dbcsr_release(oo,error=error) + CALL cp_dbcsr_release(no) + CALL cp_dbcsr_release(oo) CASE (tensor_orthogonal) - CALL cp_dbcsr_init(oo,error=error) + CALL cp_dbcsr_init(oo) CALL cp_dbcsr_create(oo,template=pp,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ! both indeces up in the pp block CALL cp_dbcsr_multiply("N","N",1.0_dp,p_index_up,pp,0.0_dp,oo,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,oo,p_index_up,0.0_dp,pp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) - CALL cp_dbcsr_release(oo,error=error) + CALL cp_dbcsr_release(oo) END SELECT - CALL cp_dbcsr_release(sp,error=error) - CALL cp_dbcsr_release(spf,error=error) + CALL cp_dbcsr_release(sp) + CALL cp_dbcsr_release(spf) ENDIF @@ -781,7 +770,6 @@ END SUBROUTINE assemble_ks_qp_blocks !> \param eps_convergence ... !> \param eps_filter ... !> \param converged ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> 2011.11 generalized [Rustam Z Khaliullin] @@ -790,7 +778,7 @@ END SUBROUTINE assemble_ks_qp_blocks RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& neglect_quadratic_term,& conjugator,max_iter,eps_convergence,eps_filter,& - converged,error) + converged) TYPE(cp_dbcsr_type), INTENT(IN) :: pp, qq TYPE(cp_dbcsr_type), INTENT(INOUT) :: qp @@ -803,7 +791,6 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& INTEGER, INTENT(IN) :: conjugator, max_iter REAL(KIND=dp), INTENT(IN) :: eps_convergence, eps_filter LOGICAL, INTENT(OUT) :: converged - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'solve_riccati_equation', & routineP = moduleN//':'//routineN @@ -829,7 +816,7 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -839,17 +826,17 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& t1 = m_walltime() !IF (level.gt.5) THEN -! CPErrorMessage(cp_failure_level,routineP,"recursion level is too high",error) -! CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) +! CPErrorMessage(cp_failure_level,routineP,"recursion level is too high") +! CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !ENDIF !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) & ! "========== LEVEL ",level,"==========" !ENDIF -!CALL cp_dbcsr_print(qq,error=error) -!CALL cp_dbcsr_print(pp,error=error) -!CALL cp_dbcsr_print(qp,error=error) -!!CALL cp_dbcsr_print(pq,error=error) +!CALL cp_dbcsr_print(qq) +!CALL cp_dbcsr_print(pp) +!CALL cp_dbcsr_print(qp) +!!CALL cp_dbcsr_print(pq) !IF (unit_nr>0) THEN ! WRITE(unit_nr,*) & ! "====== END LEVEL ",level,"==========" @@ -860,48 +847,48 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& present_vv=PRESENT(vv) ! create aux1 matrix and init - CALL cp_dbcsr_init(aux1,error=error) - CALL cp_dbcsr_create(aux1,template=pp,error=error) - CALL cp_dbcsr_copy(aux1,pp,error=error) - CALL cp_dbcsr_scale(aux1,-1.0_dp,error=error) + CALL cp_dbcsr_init(aux1) + CALL cp_dbcsr_create(aux1,template=pp) + CALL cp_dbcsr_copy(aux1,pp) + CALL cp_dbcsr_scale(aux1,-1.0_dp) ! create aux2 matrix and init - CALL cp_dbcsr_init(aux2,error=error) - CALL cp_dbcsr_create(aux2,template=qq,error=error) - CALL cp_dbcsr_copy(aux2,qq,error=error) + CALL cp_dbcsr_init(aux2) + CALL cp_dbcsr_create(aux2,template=qq) + CALL cp_dbcsr_copy(aux2,qq) ! create the gradient matrix and init - CALL cp_dbcsr_init(grad,error=error) - CALL cp_dbcsr_create(grad,template=x,error=error) - CALL cp_dbcsr_set(grad,0.0_dp,error) + CALL cp_dbcsr_init(grad) + CALL cp_dbcsr_create(grad,template=x) + CALL cp_dbcsr_set(grad,0.0_dp) ! create a preconditioner ! RZK-warning how to apply it to up_down tensor? - CALL cp_dbcsr_init(prec,error=error) - CALL cp_dbcsr_create(prec,template=x,error=error) - !CALL create_preconditioner(prec,aux1,aux2,qp,res,tensor_type,eps_filter,error) - !CALL cp_dbcsr_set(prec,1.0_dp,error) + CALL cp_dbcsr_init(prec) + CALL cp_dbcsr_create(prec,template=x) + !CALL create_preconditioner(prec,aux1,aux2,qp,res,tensor_type,eps_filter) + !CALL cp_dbcsr_set(prec,1.0_dp) ! create the step matrix and init - CALL cp_dbcsr_init(step,error=error) - CALL cp_dbcsr_create(step,template=x,error=error) - !CALL cp_dbcsr_hadamard_product(prec,grad,step,error=error) - !CALL cp_dbcsr_scale(step,-1.0_dp,error=error) - - CALL cp_dbcsr_init(n,error=error) - CALL cp_dbcsr_create(n,template=x,error=error) - CALL cp_dbcsr_init(m,error=error) - CALL cp_dbcsr_create(m,template=x,error=error) - CALL cp_dbcsr_init(oo1,error=error) - CALL cp_dbcsr_create(oo1,template=pp,error=error) - CALL cp_dbcsr_init(oo2,error=error) - CALL cp_dbcsr_create(oo2,template=pp,error=error) - CALL cp_dbcsr_init(res_trial,error=error) - CALL cp_dbcsr_create(res_trial,template=res,error=error) - CALL cp_dbcsr_init(vv_step,error=error) - CALL cp_dbcsr_create(vv_step,template=res,error=error) - CALL cp_dbcsr_init(step_oo,error=error) - CALL cp_dbcsr_create(step_oo,template=res,error=error) + CALL cp_dbcsr_init(step) + CALL cp_dbcsr_create(step,template=x) + !CALL cp_dbcsr_hadamard_product(prec,grad,step) + !CALL cp_dbcsr_scale(step,-1.0_dp) + + CALL cp_dbcsr_init(n) + CALL cp_dbcsr_create(n,template=x) + CALL cp_dbcsr_init(m) + CALL cp_dbcsr_create(m,template=x) + CALL cp_dbcsr_init(oo1) + CALL cp_dbcsr_create(oo1,template=pp) + CALL cp_dbcsr_init(oo2) + CALL cp_dbcsr_create(oo2,template=pp) + CALL cp_dbcsr_init(res_trial) + CALL cp_dbcsr_create(res_trial,template=res) + CALL cp_dbcsr_init(vv_step) + CALL cp_dbcsr_create(vv_step,template=res) + CALL cp_dbcsr_init(step_oo) + CALL cp_dbcsr_create(step_oo,template=res) ! start conjugate gradient iterations iteration=0 @@ -918,50 +905,50 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& ! (re)-compute the residuals IF (iteration.eq.0) THEN - CALL cp_dbcsr_copy(res,qp,error=error) + CALL cp_dbcsr_copy(res,qp) IF (present_oo) THEN CALL cp_dbcsr_multiply("N","N",+1.0_dp,qq,x,0.0_dp,res_trial,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",+1.0_dp,res_trial,oo,1.0_dp,res,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",+1.0_dp,qq,x,1.0_dp,res,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (present_vv) THEN CALL cp_dbcsr_multiply("N","N",-1.0_dp,x,pp,0.0_dp,res_trial,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",+1.0_dp,vv,res_trial,1.0_dp,res,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",-1.0_dp,x,pp,1.0_dp,res,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (quadratic_term) THEN IF (present_oo) THEN CALL cp_dbcsr_multiply("N","N",+1.0_dp,pq,x,0.0_dp,oo1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",+1.0_dp,oo1,oo,0.0_dp,oo2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",+1.0_dp,pq,x,0.0_dp,oo2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (present_vv) THEN CALL cp_dbcsr_multiply("N","N",-1.0_dp,x,oo2,0.0_dp,res_trial,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",+1.0_dp,vv,res_trial,1.0_dp,res,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",-1.0_dp,x,oo2,1.0_dp,res,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF ENDIF - CALL cp_dbcsr_norm(res, dbcsr_norm_maxabsnorm, norm_scalar=best_norm, error=error) + CALL cp_dbcsr_norm(res, dbcsr_norm_maxabsnorm, norm_scalar=best_norm) ELSE - CALL cp_dbcsr_add(res,m,1.0_dp,best_step_size,error=error) - CALL cp_dbcsr_add(res,n,1.0_dp,-best_step_size*best_step_size,error=error) - CALL cp_dbcsr_filter(res,eps_filter,error=error) + CALL cp_dbcsr_add(res,m,1.0_dp,best_step_size) + CALL cp_dbcsr_add(res,n,1.0_dp,-best_step_size*best_step_size) + CALL cp_dbcsr_filter(res,eps_filter) ENDIF ! check convergence and other exit criteria @@ -977,36 +964,36 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& IF (iteration.eq.0) THEN IF (present_oo) THEN CALL cp_dbcsr_multiply("N","N",-1.0_dp,pq,x,0.0_dp,oo1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",+1.0_dp,oo1,oo,1.0_dp,aux1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",-1.0_dp,pq,x,1.0_dp,aux1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (present_vv) THEN CALL cp_dbcsr_multiply("N","N",-1.0_dp,vv,x,0.0_dp,res_trial,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",+1.0_dp,res_trial,pq,1.0_dp,aux2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",-1.0_dp,x,pq,1.0_dp,aux2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF ELSE IF (present_oo) THEN CALL cp_dbcsr_multiply("N","N",-best_step_size,pq,step_oo,1.0_dp,aux1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",-best_step_size,pq,step,1.0_dp,aux1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (present_vv) THEN CALL cp_dbcsr_multiply("N","N",-best_step_size,vv_step,pq,1.0_dp,aux2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",-best_step_size,step,pq,1.0_dp,aux2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF ENDIF ENDIF @@ -1016,30 +1003,30 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& ! grad=t(vv).res.t(aux1)+t(aux2).res.t(oo) IF (present_vv) THEN CALL cp_dbcsr_multiply("N","T",1.0_dp,res,aux1,0.0_dp,res_trial,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,vv,res_trial,0.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","T",1.0_dp,res,aux1,0.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (present_oo) THEN CALL cp_dbcsr_multiply("T","N",1.0_dp,aux1,res,0.0_dp,res_trial,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","T",1.0_dp,res_trial,oo,1.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("T","N",1.0_dp,aux2,res,1.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF ! compute preconditioner !IF (iteration.eq.0.OR.(mod(iteration,update_prec_freq).eq.0)) THEN IF (iteration.eq.0) THEN - CALL create_preconditioner(prec,aux1,aux2,eps_filter,error) + CALL create_preconditioner(prec,aux1,aux2,eps_filter) !restart_conjugator=.TRUE. -!CALL cp_dbcsr_set(prec,1.0_dp,error) -!CALL cp_dbcsr_print(prec,error=error) +!CALL cp_dbcsr_set(prec,1.0_dp) +!CALL cp_dbcsr_print(prec) ENDIF ! compute the conjugation coefficient - beta @@ -1049,157 +1036,157 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& restart_conjugator=.FALSE. SELECT CASE (conjugator) CASE (cg_hestenes_stiefel) - CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_hadamard_product(prec,grad,n,error=error) - CALL cp_dbcsr_trace(n,m,numer,"T","N",error=error) - CALL cp_dbcsr_trace(grad,step,denom,"T","N",error=error) + CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp) + CALL cp_dbcsr_hadamard_product(prec,grad,n) + CALL cp_dbcsr_trace(n,m,numer,"T","N") + CALL cp_dbcsr_trace(grad,step,denom,"T","N") beta=numer/denom CASE (cg_fletcher_reeves) - CALL cp_dbcsr_hadamard_product(prec,grad,n,error=error) - CALL cp_dbcsr_trace(grad,n,denom,"T","N",error=error) - CALL cp_dbcsr_hadamard_product(prec,m,n,error=error) - CALL cp_dbcsr_trace(m,n,numer,"T","N",error=error) + CALL cp_dbcsr_hadamard_product(prec,grad,n) + CALL cp_dbcsr_trace(grad,n,denom,"T","N") + CALL cp_dbcsr_hadamard_product(prec,m,n) + CALL cp_dbcsr_trace(m,n,numer,"T","N") beta=numer/denom CASE (cg_polak_ribiere) - CALL cp_dbcsr_hadamard_product(prec,grad,n,error=error) - CALL cp_dbcsr_trace(grad,n,denom,"T","N",error=error) - CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_hadamard_product(prec,grad,n,error=error) - CALL cp_dbcsr_trace(n,m,numer,"T","N",error=error) + CALL cp_dbcsr_hadamard_product(prec,grad,n) + CALL cp_dbcsr_trace(grad,n,denom,"T","N") + CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp) + CALL cp_dbcsr_hadamard_product(prec,grad,n) + CALL cp_dbcsr_trace(n,m,numer,"T","N") beta=numer/denom CASE (cg_fletcher) - CALL cp_dbcsr_hadamard_product(prec,m,n,error=error) - CALL cp_dbcsr_trace(m,n,numer,"T","N",error=error) - CALL cp_dbcsr_trace(grad,step,denom,"T","N",error=error) + CALL cp_dbcsr_hadamard_product(prec,m,n) + CALL cp_dbcsr_trace(m,n,numer,"T","N") + CALL cp_dbcsr_trace(grad,step,denom,"T","N") beta=-1.0_dp*numer/denom CASE (cg_liu_storey) - CALL cp_dbcsr_trace(grad,step,denom,"T","N",error=error) - CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_hadamard_product(prec,grad,n,error=error) - CALL cp_dbcsr_trace(n,m,numer,"T","N",error=error) + CALL cp_dbcsr_trace(grad,step,denom,"T","N") + CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp) + CALL cp_dbcsr_hadamard_product(prec,grad,n) + CALL cp_dbcsr_trace(n,m,numer,"T","N") beta=-1.0_dp*numer/denom CASE (cg_dai_yuan) - CALL cp_dbcsr_hadamard_product(prec,m,n,error=error) - CALL cp_dbcsr_trace(m,n,numer,"T","N",error=error) - CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_trace(grad,step,denom,"T","N",error=error) + CALL cp_dbcsr_hadamard_product(prec,m,n) + CALL cp_dbcsr_trace(m,n,numer,"T","N") + CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp) + CALL cp_dbcsr_trace(grad,step,denom,"T","N") beta=numer/denom CASE (cg_hager_zhang) - CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_trace(grad,step,denom,"T","N",error=error) - CALL cp_dbcsr_hadamard_product(prec,grad,n,error=error) - CALL cp_dbcsr_trace(n,grad,numer,"T","N",error=error) + CALL cp_dbcsr_add(grad,m,-1.0_dp,1.0_dp) + CALL cp_dbcsr_trace(grad,step,denom,"T","N") + CALL cp_dbcsr_hadamard_product(prec,grad,n) + CALL cp_dbcsr_trace(n,grad,numer,"T","N") kappa=2.0_dp*numer/denom - CALL cp_dbcsr_trace(n,m,numer,"T","N",error=error) + CALL cp_dbcsr_trace(n,m,numer,"T","N") tau=numer/denom - CALL cp_dbcsr_trace(step,m,numer,"T","N",error=error) + CALL cp_dbcsr_trace(step,m,numer,"T","N") beta=tau-kappa*numer/denom CASE (cg_zero) beta=0.0_dp CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"illegal conjugator",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"illegal conjugator") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ENDIF ! iteration.eq.0 ! move the current gradient to its storage - CALL cp_dbcsr_copy(grad,m,error=error) + CALL cp_dbcsr_copy(grad,m) ! precondition new gradient (use m as tmp storage) - CALL cp_dbcsr_hadamard_product(prec,grad,m,error=error) - CALL cp_dbcsr_filter(m,eps_filter,error=error) + CALL cp_dbcsr_hadamard_product(prec,grad,m) + CALL cp_dbcsr_filter(m,eps_filter) ! recompute the step direction - CALL cp_dbcsr_add(step,m,beta,-1.0_dp,error=error) - CALL cp_dbcsr_filter(step,eps_filter,error=error) + CALL cp_dbcsr_add(step,m,beta,-1.0_dp) + CALL cp_dbcsr_filter(step,eps_filter) !! ALTERNATIVE METHOD TO OBTAIN THE STEP FROM THE GRADIENT -!CALL cp_dbcsr_init(qqqq,error=error) -!CALL cp_dbcsr_create(qqqq,template=qq,error=error) -!CALL cp_dbcsr_init(pppp,error=error) -!CALL cp_dbcsr_create(pppp,template=pp,error=error) -!CALL cp_dbcsr_init(zero_pq,error=error) -!CALL cp_dbcsr_create(zero_pq,template=pq,error=error) -!CALL cp_dbcsr_init(zero_qp,error=error) -!CALL cp_dbcsr_create(zero_qp,template=qp,error=error) +!CALL cp_dbcsr_init(qqqq) +!CALL cp_dbcsr_create(qqqq,template=qq) +!CALL cp_dbcsr_init(pppp) +!CALL cp_dbcsr_create(pppp,template=pp) +!CALL cp_dbcsr_init(zero_pq) +!CALL cp_dbcsr_create(zero_pq,template=pq) +!CALL cp_dbcsr_init(zero_qp) +!CALL cp_dbcsr_create(zero_qp,template=qp) !CALL cp_dbcsr_multiply("T","N",1.0_dp,aux2,aux2,0.0_dp,qqqq,& -! filter_eps=eps_filter,error=error) +! filter_eps=eps_filter) !CALL cp_dbcsr_multiply("N","T",-1.0_dp,aux1,aux1,0.0_dp,pppp,& -! filter_eps=eps_filter,error=error) -!CALL cp_dbcsr_set(zero_qp,0.0_dp,error=error) -!CALL cp_dbcsr_set(zero_pq,0.0_dp,error=error) +! filter_eps=eps_filter) +!CALL cp_dbcsr_set(zero_qp,0.0_dp) +!CALL cp_dbcsr_set(zero_pq,0.0_dp) !CALL solve_riccati_equation(pppp,qqqq,grad,zero_pq,zero_qp,zero_qp,& ! .TRUE.,tensor_type,& ! conjugator,max_iter,eps_convergence,eps_filter,& -! converged,level+1,error) -!CALL cp_dbcsr_release(qqqq,error=error) -!CALL cp_dbcsr_release(pppp,error=error) -!CALL cp_dbcsr_release(zero_qp,error=error) -!CALL cp_dbcsr_release(zero_pq,error=error) +! converged,level+1) +!CALL cp_dbcsr_release(qqqq) +!CALL cp_dbcsr_release(pppp) +!CALL cp_dbcsr_release(zero_qp) +!CALL cp_dbcsr_release(zero_pq) ! calculate the optimal step size ! m=step.aux1+aux2.step IF (present_vv) THEN CALL cp_dbcsr_multiply("N","N",1.0_dp,vv,step,0.0_dp,vv_step,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,vv_step,aux1,0.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",1.0_dp,step,aux1,0.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (present_oo) THEN CALL cp_dbcsr_multiply("N","N",1.0_dp,step,oo,0.0_dp,step_oo,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,aux2,step_oo,1.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",1.0_dp,aux2,step,1.0_dp,m,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (quadratic_term) THEN ! n=step.pq.step IF (present_oo) THEN CALL cp_dbcsr_multiply("N","N",1.0_dp,pq,step,0.0_dp,oo1,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,oo1,oo,0.0_dp,oo2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",1.0_dp,pq,step,0.0_dp,oo2,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF IF (present_vv) THEN CALL cp_dbcsr_multiply("N","N",1.0_dp,step,oo2,0.0_dp,res_trial,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,vv,res_trial,0.0_dp,n,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ELSE CALL cp_dbcsr_multiply("N","N",1.0_dp,step,oo2,0.0_dp,n,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) ENDIF ELSE - CALL cp_dbcsr_set(n,0.0_dp,error=error) + CALL cp_dbcsr_set(n,0.0_dp) ENDIF ! calculate coefficients of the cubic eq for alpha - step size c0 = 2.0_dp*(cp_dbcsr_frobenius_norm(n))**2 - CALL cp_dbcsr_trace(m,n,c1,"T","N",error=error) + CALL cp_dbcsr_trace(m,n,c1,"T","N") c1 = -3.0_dp*c1 - CALL cp_dbcsr_trace(res,n,c2,"T","N",error=error) + CALL cp_dbcsr_trace(res,n,c2,"T","N") c2 = -2.0_dp*c2+(cp_dbcsr_frobenius_norm(m))**2 - CALL cp_dbcsr_trace(res,m,c3,"T","N",error=error) + CALL cp_dbcsr_trace(res,m,c3,"T","N") ! find step size CALL analytic_line_search(c0,c1,c2,c3,step_size,nsteps) IF (nsteps.eq.0) THEN - CPErrorMessage(cp_failure_level,routineP,"no step sizes!",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"no step sizes!") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! if we have several possible step sizes ! choose one with the lowest objective function @@ -1207,15 +1194,14 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& best_step_size = 0.0_dp DO istep = 1,nsteps ! recompute the residues - CALL cp_dbcsr_copy(res_trial,res,error=error) - CALL cp_dbcsr_add(res_trial,m,1.0_dp,step_size(istep),error=error) - CALL cp_dbcsr_add(res_trial,n,1.0_dp,-step_size(istep)*step_size(istep),& - error=error) - CALL cp_dbcsr_filter(res_trial,eps_filter,error=error) + CALL cp_dbcsr_copy(res_trial,res) + CALL cp_dbcsr_add(res_trial,m,1.0_dp,step_size(istep)) + CALL cp_dbcsr_add(res_trial,n,1.0_dp,-step_size(istep)*step_size(istep)) + CALL cp_dbcsr_filter(res_trial,eps_filter) ! RZK-warning objective function might be different in the case of ! tensor_up_down !obj_function=0.5_dp*(cp_dbcsr_frobenius_norm(res_trial))**2 - CALL cp_dbcsr_norm(res_trial, dbcsr_norm_maxabsnorm, norm_scalar=obj_function, error=error) + CALL cp_dbcsr_norm(res_trial, dbcsr_norm_maxabsnorm, norm_scalar=obj_function) IF (obj_function.lt.best_norm) THEN best_norm=obj_function best_step_size=step_size(istep) @@ -1225,12 +1211,12 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& ENDIF ! update X along the line - CALL cp_dbcsr_add(x,step,1.0_dp,best_step_size,error=error) - CALL cp_dbcsr_filter(x,eps_filter,error=error) + CALL cp_dbcsr_add(x,step,1.0_dp,best_step_size) + CALL cp_dbcsr_filter(x,eps_filter) ! evaluate current energy correction !change_ecorr=ecorr - !CALL cp_dbcsr_trace(qp,x,ecorr,"T","N",error=error) + !CALL cp_dbcsr_trace(qp,x,ecorr,"T","N") !change_ecorr=ecorr-change_ecorr ! check convergence and other exit criteria @@ -1256,17 +1242,17 @@ RECURSIVE SUBROUTINE solve_riccati_equation(pp,qq,qp,pq,oo,vv,x,res,& ENDDO - CALL cp_dbcsr_release(aux1,error=error) - CALL cp_dbcsr_release(aux2,error=error) - CALL cp_dbcsr_release(grad,error=error) - CALL cp_dbcsr_release(step,error=error) - CALL cp_dbcsr_release(n,error=error) - CALL cp_dbcsr_release(m,error=error) - CALL cp_dbcsr_release(oo1,error=error) - CALL cp_dbcsr_release(oo2,error=error) - CALL cp_dbcsr_release(res_trial,error=error) - CALL cp_dbcsr_release(vv_step,error=error) - CALL cp_dbcsr_release(step_oo,error=error) + CALL cp_dbcsr_release(aux1) + CALL cp_dbcsr_release(aux2) + CALL cp_dbcsr_release(grad) + CALL cp_dbcsr_release(step) + CALL cp_dbcsr_release(n) + CALL cp_dbcsr_release(m) + CALL cp_dbcsr_release(oo1) + CALL cp_dbcsr_release(oo2) + CALL cp_dbcsr_release(res_trial) + CALL cp_dbcsr_release(vv_step) + CALL cp_dbcsr_release(step_oo) CALL timestop(handle) @@ -1281,17 +1267,15 @@ END SUBROUTINE solve_riccati_equation !> \param pp ... !> \param qq ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2011.07 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE create_preconditioner(prec,pp,qq,eps_filter,error) + SUBROUTINE create_preconditioner(prec,pp,qq,eps_filter) TYPE(cp_dbcsr_type), INTENT(OUT) :: prec TYPE(cp_dbcsr_type), INTENT(IN) :: pp, qq REAL(KIND=dp), INTENT(IN) :: eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_preconditioner', & routineP = moduleN//':'//routineN @@ -1309,22 +1293,22 @@ SUBROUTINE create_preconditioner(prec,pp,qq,eps_filter,error) ! ! copy diagonal elements ! CALL cp_dbcsr_get_info(pp,nfullrows_total=nrows) -! CALL cp_dbcsr_init(pp_diag,error=error) -! CALL cp_dbcsr_create(pp_diag,template=pp,error=error) +! CALL cp_dbcsr_init(pp_diag) +! CALL cp_dbcsr_create(pp_diag,template=pp) ! ALLOCATE(diagonal(nrows)) -! CALL cp_dbcsr_get_diag(pp,diagonal,error=error) -! CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp,error=error) -! CALL cp_dbcsr_set_diag(pp_diag,diagonal,error=error) +! CALL cp_dbcsr_get_diag(pp,diagonal) +! CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp) +! CALL cp_dbcsr_set_diag(pp_diag,diagonal) ! DEALLOCATE(diagonal) ! ! initialize a matrix to 1.0 - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=prec,error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=prec) ! use an ugly hack to set all elements of tmp to 1 ! because cp_dbcsr_set does not do it (despite its name) - !CALL cp_dbcsr_set(tmp,1.0_dp,error=error) + !CALL cp_dbcsr_set(tmp,1.0_dp) mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(cp_dbcsr_distribution(tmp))) - CALL cp_dbcsr_work_create(tmp, work_mutable=.TRUE., error=error) + CALL cp_dbcsr_work_create(tmp, work_mutable=.TRUE.) nblkrows_tot = cp_dbcsr_nblkrows_total(tmp) nblkcols_tot = cp_dbcsr_nblkcols_total(tmp) DO row = 1, nblkrows_tot @@ -1336,83 +1320,83 @@ SUBROUTINE create_preconditioner(prec,pp,qq,eps_filter,error) IF (hold.EQ.mynode) THEN NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(tmp,iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = 1.0_dp ENDIF ! mynode ENDDO ENDDO - CALL cp_dbcsr_finalize(tmp,error=error) + CALL cp_dbcsr_finalize(tmp) ! copy diagonal elements of pp into cols of a matrix CALL cp_dbcsr_get_info(pp,nfullrows_total=p_nrows) - CALL cp_dbcsr_init(pp_diag,error=error) - CALL cp_dbcsr_create(pp_diag,template=pp,error=error) + CALL cp_dbcsr_init(pp_diag) + CALL cp_dbcsr_create(pp_diag,template=pp) ALLOCATE(p_diagonal(p_nrows)) - CALL cp_dbcsr_get_diag(pp,p_diagonal,error=error) - CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(pp_diag,p_diagonal,error=error) + CALL cp_dbcsr_get_diag(pp,p_diagonal) + CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp) + CALL cp_dbcsr_set_diag(pp_diag,p_diagonal) ! RZK-warning is it possible to use cp_dbcsr_scale_by_vector? ! or even insert elements directly in the prev cycles - CALL cp_dbcsr_init(t2,error=error) - CALL cp_dbcsr_create(t2,template=prec,error=error) + CALL cp_dbcsr_init(t2) + CALL cp_dbcsr_create(t2,template=prec) CALL cp_dbcsr_multiply("N","N",1.0_dp,tmp,pp_diag,& - 0.0_dp,t2,filter_eps=eps_filter,error=error) + 0.0_dp,t2,filter_eps=eps_filter) ! copy diagonal elements qq into rows of a matrix CALL cp_dbcsr_get_info(qq, nfullrows_total=q_nrows ) - CALL cp_dbcsr_init(qq_diag,error=error) - CALL cp_dbcsr_create(qq_diag,template=qq,error=error) + CALL cp_dbcsr_init(qq_diag) + CALL cp_dbcsr_create(qq_diag,template=qq) ALLOCATE(q_diagonal(q_nrows)) - CALL cp_dbcsr_get_diag(qq,q_diagonal,error=error) - CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(qq_diag,q_diagonal,error=error) - CALL cp_dbcsr_set(tmp,1.0_dp,error=error) - CALL cp_dbcsr_init(t1,error=error) - CALL cp_dbcsr_create(t1,template=prec,error=error) + CALL cp_dbcsr_get_diag(qq,q_diagonal) + CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp) + CALL cp_dbcsr_set_diag(qq_diag,q_diagonal) + CALL cp_dbcsr_set(tmp,1.0_dp) + CALL cp_dbcsr_init(t1) + CALL cp_dbcsr_create(t1,template=prec) CALL cp_dbcsr_multiply("N","N",1.0_dp,qq_diag,tmp,& - 0.0_dp,t1,filter_eps=eps_filter,error=error) + 0.0_dp,t1,filter_eps=eps_filter) - CALL cp_dbcsr_hadamard_product(t1,t2,prec,error=error) - CALL cp_dbcsr_release(t1,error=error) - CALL cp_dbcsr_scale(prec,2.0_dp,error=error) + CALL cp_dbcsr_hadamard_product(t1,t2,prec) + CALL cp_dbcsr_release(t1) + CALL cp_dbcsr_scale(prec,2.0_dp) ! Get the diagonal of tr(qq).qq CALL cp_dbcsr_multiply("T","N",1.0_dp,qq,qq,& 0.0_dp,qq_diag,retain_sparsity=.TRUE.,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_get_diag(qq_diag,q_diagonal,error=error) - CALL cp_dbcsr_set(qq_diag,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(qq_diag,q_diagonal,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_get_diag(qq_diag,q_diagonal) + CALL cp_dbcsr_set(qq_diag,0.0_dp) + CALL cp_dbcsr_add_on_diag(qq_diag,1.0_dp) + CALL cp_dbcsr_set_diag(qq_diag,q_diagonal) DEALLOCATE(q_diagonal) - CALL cp_dbcsr_set(tmp,1.0_dp,error=error) + CALL cp_dbcsr_set(tmp,1.0_dp) CALL cp_dbcsr_multiply("N","N",1.0_dp,qq_diag,tmp,& - 0.0_dp,t2,filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(qq_diag,error=error) - CALL cp_dbcsr_add(prec,t2,1.0_dp,1.0_dp,error=error) + 0.0_dp,t2,filter_eps=eps_filter) + CALL cp_dbcsr_release(qq_diag) + CALL cp_dbcsr_add(prec,t2,1.0_dp,1.0_dp) ! Get the diagonal of pp.tr(pp) CALL cp_dbcsr_multiply("N","T",1.0_dp,pp,pp,& 0.0_dp,pp_diag,retain_sparsity=.TRUE.,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_get_diag(pp_diag,p_diagonal,error=error) - CALL cp_dbcsr_set(pp_diag,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp,error=error) - CALL cp_dbcsr_set_diag(pp_diag,p_diagonal,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_get_diag(pp_diag,p_diagonal) + CALL cp_dbcsr_set(pp_diag,0.0_dp) + CALL cp_dbcsr_add_on_diag(pp_diag,1.0_dp) + CALL cp_dbcsr_set_diag(pp_diag,p_diagonal) DEALLOCATE(p_diagonal) - CALL cp_dbcsr_set(tmp,1.0_dp,error=error) + CALL cp_dbcsr_set(tmp,1.0_dp) CALL cp_dbcsr_multiply("N","N",1.0_dp,tmp,pp_diag,& - 0.0_dp,t2,filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(tmp,error=error) - CALL cp_dbcsr_release(pp_diag,error=error) - CALL cp_dbcsr_add(prec,t2,1.0_dp,1.0_dp,error=error) + 0.0_dp,t2,filter_eps=eps_filter) + CALL cp_dbcsr_release(tmp) + CALL cp_dbcsr_release(pp_diag) + CALL cp_dbcsr_add(prec,t2,1.0_dp,1.0_dp) ! now add the residual component - !CALL cp_dbcsr_hadamard_product(res,qp,t2,error=error) - !CALL cp_dbcsr_add(prec,t2,1.0_dp,-2.0_dp,error=error) - CALL cp_dbcsr_release(t2,error=error) - CALL cp_dbcsr_function_of_elements(prec,func=dbcsr_func_inverse,error=error) - CALL cp_dbcsr_filter(prec,eps_filter,error=error) + !CALL cp_dbcsr_hadamard_product(res,qp,t2) + !CALL cp_dbcsr_add(prec,t2,1.0_dp,-2.0_dp) + CALL cp_dbcsr_release(t2) + CALL cp_dbcsr_function_of_elements(prec,func=dbcsr_func_inverse) + CALL cp_dbcsr_filter(prec,eps_filter) CALL timestop(handle) @@ -1585,18 +1569,16 @@ END SUBROUTINE analytic_line_search !> \param matrix ... !> \param c ... !> \param e ... -!> \param error ... !> \par History !> 2011.07 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE diagonalize_diagonal_blocks(matrix,c,e,error) + SUBROUTINE diagonalize_diagonal_blocks(matrix,c,e) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix TYPE(cp_dbcsr_type), INTENT(OUT) :: c TYPE(cp_dbcsr_type), INTENT(OUT), & OPTIONAL :: e - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'diagonalize_diagonal_blocks', & routineP = moduleN//':'//routineN @@ -1621,9 +1603,9 @@ SUBROUTINE diagonalize_diagonal_blocks(matrix,c,e,error) ENDIF ! create a matrix for eigenvectors - CALL cp_dbcsr_work_create(c,work_mutable=.TRUE.,error=error) + CALL cp_dbcsr_work_create(c,work_mutable=.TRUE.) IF (do_eigenvalues) & - CALL cp_dbcsr_work_create(e,work_mutable=.TRUE.,error=error) + CALL cp_dbcsr_work_create(e,work_mutable=.TRUE.) CALL cp_dbcsr_iterator_start(iter,matrix) @@ -1652,21 +1634,21 @@ SUBROUTINE diagonalize_diagonal_blocks(matrix,c,e,error) ALLOCATE(WORK(MAX(1,LWORK))) CALL DSYEV('V','L',iblock_size,data_copy,iblock_size,eigenvalues,WORK,LWORK,INFO) IF( INFO.NE.0 ) THEN - CPErrorMessage(cp_failure_level,routineP,"DSYEV failed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"DSYEV failed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF ! copy eigenvectors into a cp_dbcsr matrix NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(c,iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = data_copy(:,:) ! if requested copy eigenvalues into a cp_dbcsr matrix IF (do_eigenvalues) THEN NULLIFY (p_new_block) CALL cp_dbcsr_reserve_block2d(e,iblock_row,iblock_col,p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) p_new_block(:,:) = 0.0_dp DO orbital=1,iblock_size p_new_block(orbital,orbital)=eigenvalues(orbital) @@ -1683,8 +1665,8 @@ SUBROUTINE diagonalize_diagonal_blocks(matrix,c,e,error) CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_finalize(c,error=error) - IF (do_eigenvalues) CALL cp_dbcsr_finalize(e,error=error) + CALL cp_dbcsr_finalize(c) + IF (do_eigenvalues) CALL cp_dbcsr_finalize(e) CALL timestop(handle) @@ -1696,17 +1678,15 @@ END SUBROUTINE diagonalize_diagonal_blocks !> \param u1 ... !> \param u2 ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2011.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE matrix_forward_transform(matrix,u1,u2,eps_filter,error) + SUBROUTINE matrix_forward_transform(matrix,u1,u2,eps_filter) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix TYPE(cp_dbcsr_type), INTENT(IN) :: u1, u2 REAL(KIND=dp), INTENT(IN) :: eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_forward_transform', & routineP = moduleN//':'//routineN @@ -1716,14 +1696,14 @@ SUBROUTINE matrix_forward_transform(matrix,u1,u2,eps_filter,error) CALL timeset(routineN,handle) - CALL cp_dbcsr_init(tmp,error=error) + CALL cp_dbcsr_init(tmp) CALL cp_dbcsr_create(tmp,template=matrix,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix,u2,0.0_dp,tmp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("T","N",1.0_dp,u1,tmp,0.0_dp,matrix,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(tmp,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_release(tmp) CALL timestop(handle) @@ -1735,17 +1715,15 @@ END SUBROUTINE matrix_forward_transform !> \param u1 ... !> \param u2 ... !> \param eps_filter ... -!> \param error ... !> \par History !> 2011.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE matrix_backward_transform(matrix,u1,u2,eps_filter,error) + SUBROUTINE matrix_backward_transform(matrix,u1,u2,eps_filter) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix TYPE(cp_dbcsr_type), INTENT(IN) :: u1, u2 REAL(KIND=dp), INTENT(IN) :: eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_backward_transform', & routineP = moduleN//':'//routineN @@ -1755,14 +1733,14 @@ SUBROUTINE matrix_backward_transform(matrix,u1,u2,eps_filter,error) CALL timeset(routineN,handle) - CALL cp_dbcsr_init(tmp,error=error) + CALL cp_dbcsr_init(tmp) CALL cp_dbcsr_create(tmp,template=matrix,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N","T",1.0_dp,matrix,u2,0.0_dp,tmp,& - filter_eps=eps_filter,error=error) + filter_eps=eps_filter) CALL cp_dbcsr_multiply("N","N",1.0_dp,u1,tmp,0.0_dp,matrix,& - filter_eps=eps_filter,error=error) - CALL cp_dbcsr_release(tmp,error=error) + filter_eps=eps_filter) + CALL cp_dbcsr_release(tmp) CALL timestop(handle) @@ -1777,12 +1755,11 @@ END SUBROUTINE matrix_backward_transform !!> \author Rustam Z Khaliullin !! ***************************************************************************** ! SUBROUTINE transform_matrices_to_blk_diag(matrix_pp,matrix_qq,matrix_qp,& -! matrix_pq,eps_filter,error) +! matrix_pq,eps_filter) ! ! TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_pp, matrix_qq,& ! matrix_qp, matrix_pq ! REAL(KIND=dp), INTENT(IN) :: eps_filter -! TYPE(cp_error_type), INTENT(INOUT) :: error ! ! CHARACTER(len=*), PARAMETER :: routineN = 'transform_matrices_to_blk_diag',& ! routineP = moduleN//':'//routineN @@ -1796,52 +1773,52 @@ END SUBROUTINE matrix_backward_transform ! ! ! find a better basis by diagonalizing diagonal blocks ! ! first pp -! CALL cp_dbcsr_init(blk,error=error) -! CALL cp_dbcsr_create(blk,template=matrix_pp,error=error) -! CALL diagonalize_diagonal_blocks(matrix_pp,blk,error=error) +! CALL cp_dbcsr_init(blk) +! CALL cp_dbcsr_create(blk,template=matrix_pp) +! CALL diagonalize_diagonal_blocks(matrix_pp,blk) ! ! ! convert matrices to the new basis -! CALL cp_dbcsr_init(tmp_pp,error=error) -! CALL cp_dbcsr_create(tmp_pp,template=matrix_pp,error=error) +! CALL cp_dbcsr_init(tmp_pp) +! CALL cp_dbcsr_create(tmp_pp,template=matrix_pp) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_pp,blk,0.0_dp,tmp_pp,& -! filter_eps=eps_filter,error=error) +! filter_eps=eps_filter) ! CALL cp_dbcsr_multiply("T","N",1.0_dp,blk,tmp_pp,0.0_dp,matrix_pp,& -! filter_eps=eps_filter,error=error) -! CALL cp_dbcsr_release(tmp_pp,error=error) +! filter_eps=eps_filter) +! CALL cp_dbcsr_release(tmp_pp) ! ! ! now qq -! CALL cp_dbcsr_init(blk2,error=error) -! CALL cp_dbcsr_create(blk2,template=matrix_qq,error=error) -! CALL diagonalize_diagonal_blocks(matrix_qq,blk2,error=error) +! CALL cp_dbcsr_init(blk2) +! CALL cp_dbcsr_create(blk2,template=matrix_qq) +! CALL diagonalize_diagonal_blocks(matrix_qq,blk2) ! -! CALL cp_dbcsr_init(tmp_qq,error=error) -! CALL cp_dbcsr_create(tmp_qq,template=matrix_qq,error=error) +! CALL cp_dbcsr_init(tmp_qq) +! CALL cp_dbcsr_create(tmp_qq,template=matrix_qq) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_qq,blk2,0.0_dp,tmp_qq,& -! filter_eps=eps_filter,error=error) +! filter_eps=eps_filter) ! CALL cp_dbcsr_multiply("T","N",1.0_dp,blk2,tmp_qq,0.0_dp,matrix_qq,& -! filter_eps=eps_filter,error=error) -! CALL cp_dbcsr_release(tmp_qq,error=error) +! filter_eps=eps_filter) +! CALL cp_dbcsr_release(tmp_qq) ! ! ! transform pq -! CALL cp_dbcsr_init(tmp_pq,error=error) -! CALL cp_dbcsr_create(tmp_pq,template=matrix_pq,error=error) +! CALL cp_dbcsr_init(tmp_pq) +! CALL cp_dbcsr_create(tmp_pq,template=matrix_pq) ! CALL cp_dbcsr_multiply("T","N",1.0_dp,blk,matrix_pq,0.0_dp,tmp_pq,& -! filter_eps=eps_filter,error=error) +! filter_eps=eps_filter) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,tmp_pq,blk2,0.0_dp,matrix_pq,& -! filter_eps=eps_filter,error=error) -! CALL cp_dbcsr_release(tmp_pq,error=error) +! filter_eps=eps_filter) +! CALL cp_dbcsr_release(tmp_pq) ! ! ! transform qp -! CALL cp_dbcsr_init(tmp_qp,error=error) -! CALL cp_dbcsr_create(tmp_qp,template=matrix_qp,error=error) +! CALL cp_dbcsr_init(tmp_qp) +! CALL cp_dbcsr_create(tmp_qp,template=matrix_qp) ! CALL cp_dbcsr_multiply("N","N",1.0_dp,matrix_qp,blk,0.0_dp,tmp_qp,& -! filter_eps=eps_filter,error=error) +! filter_eps=eps_filter) ! CALL cp_dbcsr_multiply("T","N",1.0_dp,blk2,tmp_qp,0.0_dp,matrix_qp,& -! filter_eps=eps_filter,error=error) -! CALL cp_dbcsr_release(tmp_qp,error=error) +! filter_eps=eps_filter) +! CALL cp_dbcsr_release(tmp_qp) ! -! CALL cp_dbcsr_release(blk2,error=error) -! CALL cp_dbcsr_release(blk,error=error) +! CALL cp_dbcsr_release(blk2) +! CALL cp_dbcsr_release(blk) ! ! CALL timestop(handle) ! diff --git a/src/ct_types.F b/src/ct_types.F index 90efd39459..e0e8558861 100644 --- a/src/ct_types.F +++ b/src/ct_types.F @@ -130,12 +130,10 @@ MODULE ct_types ! ***************************************************************************** !> \brief ... !> \param env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ct_step_env_init(env,error) + SUBROUTINE ct_step_env_init(env) TYPE(ct_step_env_type) :: env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ct_step_env_init', & routineP = moduleN//':'//routineN @@ -209,7 +207,6 @@ END SUBROUTINE ct_step_env_init !> \param converged ... !> \param qq_preconditioner_full ... !> \param pp_preconditioner_full ... -!> \param error ... ! ***************************************************************************** SUBROUTINE ct_step_env_get(env,use_occ_orbs,use_virt_orbs,tensor_type,& occ_orbs_orthogonal,virt_orbs_orthogonal,neglect_quadratic_term,& @@ -217,8 +214,7 @@ SUBROUTINE ct_step_env_get(env,use_occ_orbs,use_virt_orbs,tensor_type,& p_index_up,p_index_down,q_index_up,q_index_down,matrix_ks,matrix_p,& matrix_qp_template,matrix_pq_template,& matrix_t,matrix_v,copy_matrix_x,energy_correction,calculate_energy_corr,& - converged,qq_preconditioner_full,pp_preconditioner_full,& - error) + converged,qq_preconditioner_full,pp_preconditioner_full) TYPE(ct_step_env_type) :: env LOGICAL, OPTIONAL :: use_occ_orbs, use_virt_orbs @@ -236,7 +232,6 @@ SUBROUTINE ct_step_env_get(env,use_occ_orbs,use_virt_orbs,tensor_type,& converged, & qq_preconditioner_full, & pp_preconditioner_full - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ct_step_env_get', & routineP = moduleN//':'//routineN @@ -292,8 +287,8 @@ SUBROUTINE ct_step_env_get(env,use_occ_orbs,use_virt_orbs,tensor_type,& IF (PRESENT(q_index_down)) q_index_down => env%q_index_down IF (PRESENT(copy_matrix_x)) THEN !DO ispin=1,env%nspins - !CALL cp_dbcsr_copy(copy_matrix_x(ispin),env%matrix_x(ispin),error=error) - CALL cp_dbcsr_copy(copy_matrix_x,env%matrix_x,error=error) + !CALL cp_dbcsr_copy(copy_matrix_x(ispin),env%matrix_x(ispin)) + CALL cp_dbcsr_copy(copy_matrix_x,env%matrix_x) !ENDDO ENDIF !IF (PRESENT(matrix_x)) matrix_x => env%matrix_x @@ -333,7 +328,6 @@ END SUBROUTINE ct_step_env_get !> \param conjugator ... !> \param qq_preconditioner_full ... !> \param pp_preconditioner_full ... -!> \param error ... ! ***************************************************************************** SUBROUTINE ct_step_env_set(env,para_env,blacs_env,use_occ_orbs,& use_virt_orbs,tensor_type,& @@ -342,8 +336,7 @@ SUBROUTINE ct_step_env_set(env,para_env,blacs_env,use_occ_orbs,& p_index_up,p_index_down,q_index_up,q_index_down,matrix_ks,matrix_p,& matrix_qp_template,matrix_pq_template,& matrix_t,matrix_v,matrix_x_guess,calculate_energy_corr,conjugator,& - qq_preconditioner_full,pp_preconditioner_full,& - error) + qq_preconditioner_full,pp_preconditioner_full) TYPE(ct_step_env_type) :: env TYPE(cp_para_env_type), POINTER :: para_env @@ -361,7 +354,6 @@ SUBROUTINE ct_step_env_set(env,para_env,blacs_env,use_occ_orbs,& INTEGER, OPTIONAL :: conjugator LOGICAL, OPTIONAL :: qq_preconditioner_full, & pp_preconditioner_full - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ct_step_env_set', & routineP = moduleN//':'//routineN @@ -424,12 +416,10 @@ END SUBROUTINE ct_step_env_set ! ***************************************************************************** !> \brief ... !> \param env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ct_step_env_clean(env,error) + SUBROUTINE ct_step_env_clean(env) TYPE(ct_step_env_type) :: env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ct_step_env_clean', & routineP = moduleN//':'//routineN @@ -440,10 +430,10 @@ SUBROUTINE ct_step_env_clean(env,error) NULLIFY(env%blacs_env) !DO ispin=1,env%nspins - CALL cp_dbcsr_release(env%matrix_x,error=error) - CALL cp_dbcsr_release(env%matrix_res,error=error) - !CALL cp_dbcsr_release(env%matrix_x(ispin),error=error) - !CALL cp_dbcsr_release(env%matrix_res(ispin),error=error) + CALL cp_dbcsr_release(env%matrix_x) + CALL cp_dbcsr_release(env%matrix_res) + !CALL cp_dbcsr_release(env%matrix_x(ispin)) + !CALL cp_dbcsr_release(env%matrix_res(ispin)) !ENDDO !DEALLOCATE(env%matrix_x,env%matrix_res) diff --git a/src/d3_poly.F b/src/d3_poly.F index 2947e843b2..7b68898e53 100644 --- a/src/d3_poly.F +++ b/src/d3_poly.F @@ -375,14 +375,12 @@ PURE FUNCTION mono_mult3(ii,ij) RESULT(res) !> \param pRes ... !> \param np1 ... !> \param sumUp ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_mult1(p1,p2,pRes,np1,sumUp,error) +SUBROUTINE poly_mult1(p1,p2,pRes,np1,sumUp) REAL(dp), DIMENSION(:), INTENT(in) :: p1, p2 REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: np1 LOGICAL, INTENT(in), OPTIONAL :: sumUp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_mult1', & routineP = moduleN//':'//routineN @@ -401,7 +399,7 @@ SUBROUTINE poly_mult1(p1,p2,pRes,np1,sumUp,error) size_p2=SIZE(p2) newGrad=grad_size1(size_p1)+grad_size1(size_p2) newSize=SIZE(pRes)/myNp1 - CPPreconditionNoFail(newSize>=poly_size1(newGrad),cp_failure_level,routineP,error) + CPPreconditionNoFail(newSize>=poly_size1(newGrad),cp_failure_level,routineP) IF (.not.mySumUp) pRes=0 iPos=1 resShift_0=0 @@ -425,14 +423,12 @@ SUBROUTINE poly_mult1(p1,p2,pRes,np1,sumUp,error) !> \param pRes ... !> \param np1 ... !> \param sumUp ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_mult2(p1,p2,pRes,np1,sumUp,error) +SUBROUTINE poly_mult2(p1,p2,pRes,np1,sumUp) REAL(dp), DIMENSION(:), INTENT(in) :: p1, p2 REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: np1 LOGICAL, INTENT(in), OPTIONAL :: sumUp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_mult2', & routineP = moduleN//':'//routineN @@ -453,7 +449,7 @@ SUBROUTINE poly_mult2(p1,p2,pRes,np1,sumUp,error) grad2=grad_size2(size_p2) newGrad=grad1+grad2 newSize=SIZE(pRes)/myNp1 - CPPreconditionNoFail(newSize>=poly_size2(newGrad),cp_failure_level,routineP,error) + CPPreconditionNoFail(newSize>=poly_size2(newGrad),cp_failure_level,routineP) IF (.not.mySumUp) pRes=0 iShift=0 shiftRes=0 @@ -509,14 +505,12 @@ SUBROUTINE poly_mult2(p1,p2,pRes,np1,sumUp,error) !> \param pRes ... !> \param np1 ... !> \param sumUp ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_mult3(p1,p2,pRes,np1,sumUp,error) +SUBROUTINE poly_mult3(p1,p2,pRes,np1,sumUp) REAL(dp), DIMENSION(:), INTENT(in) :: p1, p2 REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: np1 LOGICAL, INTENT(in), OPTIONAL :: sumUp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_mult3', & routineP = moduleN//':'//routineN @@ -536,7 +530,7 @@ SUBROUTINE poly_mult3(p1,p2,pRes,np1,sumUp,error) grad2=grad_size3(size_p2) newGrad=grad1+grad2 newSize=SIZE(pRes)/myNp1 - CPPreconditionNoFail(newSize>=poly_size3(newGrad),cp_failure_level,routineP,error) + CPPreconditionNoFail(newSize>=poly_size3(newGrad),cp_failure_level,routineP) CALL poly_mult3b(p1,SIZE(p1),grad1,p2,SIZE(p2),grad2,pRes,SIZE(pRes),myNp1,mySumUp) END SUBROUTINE @@ -845,14 +839,12 @@ SUBROUTINE poly_write3(p,out_f) !> \param p ... !> \param maxSize ... !> \param minSize ... -!> \param error ... !> \retval res ... ! ***************************************************************************** -FUNCTION poly_random(p,maxSize,minSize,error) RESULT(res) +FUNCTION poly_random(p,maxSize,minSize) RESULT(res) REAL(dp), DIMENSION(:), INTENT(out) :: p INTEGER, INTENT(in) :: maxSize INTEGER, INTENT(in), OPTIONAL :: minSize - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'poly_random', & @@ -866,7 +858,7 @@ FUNCTION poly_random(p,maxSize,minSize,error) RESULT(res) IF (PRESENT(minSize)) myMinSize=minSize CALL RANDOM_NUMBER(g) pSize=MIN(maxSize,myMinSize+INT((maxSize-myMinSize+1)*g)) - CPPreconditionNoFail(SIZE(p)>=pSize,cp_failure_level,routineP,error) + CPPreconditionNoFail(SIZE(p)>=pSize,cp_failure_level,routineP) CALL RANDOM_NUMBER(p) DO i=1,pSize p(i)=REAL(INT(p(i)*200.0_dp-100.0_dp),dp)/100.0_dp @@ -885,15 +877,13 @@ FUNCTION poly_random(p,maxSize,minSize,error) RESULT(res) !> \param b ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_affine_t3t(p,m,b,pRes,npoly,error) +SUBROUTINE poly_affine_t3t(p,m,b,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), DIMENSION(3, 3), INTENT(in) :: m REAL(dp), DIMENSION(3), INTENT(in) :: b REAL(dp), DIMENSION(:), INTENT(out) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_affine_t3t', & routineP = moduleN//':'//routineN @@ -918,8 +908,8 @@ SUBROUTINE poly_affine_t3t(p,m,b,pRes,npoly,error) size_res=SIZE(p)/my_npoly grad=grad_size3(size_res) minResSize=poly_size3(grad) - CPPreconditionNoFail(size_res==minResSize,cp_failure_level,routineP,error) - CPPreconditionNoFail(size_p>=minResSize,cp_failure_level,routineP,error) + CPPreconditionNoFail(size_res==minResSize,cp_failure_level,routineP) + CPPreconditionNoFail(size_p>=minResSize,cp_failure_level,routineP) pRes=0 IF (size_p==0) RETURN ii1=1 @@ -933,7 +923,7 @@ SUBROUTINE poly_affine_t3t(p,m,b,pRes,npoly,error) ALLOCATE(monoG1((grad+1)*(grad+2)/2*minResSize),& monoG2((grad+1)*(grad+2)/2*minResSize),stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) !monoG1=0 !monoG2=0 ii1=1 @@ -1043,7 +1033,7 @@ SUBROUTINE poly_affine_t3t(p,m,b,pRes,npoly,error) ! monoFullDim1=monoFullDim2 END DO DEALLOCATE(monoG1,monoG2,stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) END SUBROUTINE ! ***************************************************************************** @@ -1053,15 +1043,13 @@ SUBROUTINE poly_affine_t3t(p,m,b,pRes,npoly,error) !> \param b ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_affine_t3(p,m,b,pRes,npoly,error) +SUBROUTINE poly_affine_t3(p,m,b,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), DIMENSION(3, 3), INTENT(in) :: m REAL(dp), DIMENSION(3), INTENT(in) :: b REAL(dp), DIMENSION(:), INTENT(out) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_affine_t3', & routineP = moduleN//':'//routineN @@ -1086,7 +1074,7 @@ SUBROUTINE poly_affine_t3(p,m,b,pRes,npoly,error) grad=grad_size3(size_p) size_res=SIZE(pRes)/my_npoly minResSize=poly_size3(grad) - CPPreconditionNoFail(size_res>=minResSize,cp_failure_level,routineP,error) + CPPreconditionNoFail(size_res>=minResSize,cp_failure_level,routineP) pRes=0 IF (size_p==0) RETURN ii1=1 @@ -1100,7 +1088,7 @@ SUBROUTINE poly_affine_t3(p,m,b,pRes,npoly,error) ALLOCATE(monoG1((grad+1)*(grad+2)/2*minResSize),& monoG2((grad+1)*(grad+2)/2*minResSize),stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) monoG1=0 monoG2=0 ii1=1 @@ -1211,7 +1199,7 @@ SUBROUTINE poly_affine_t3(p,m,b,pRes,npoly,error) ! monoFullDim1=monoFullDim2 END DO DEALLOCATE(monoG1,monoG2,stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) END SUBROUTINE ! ***************************************************************************** @@ -1220,14 +1208,12 @@ SUBROUTINE poly_affine_t3(p,m,b,pRes,npoly,error) !> \param x ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_p_eval3(p,x,pRes,npoly,error) +SUBROUTINE poly_p_eval3(p,x,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), INTENT(in) :: x REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_p_eval3', & routineP = moduleN//':'//routineN @@ -1242,13 +1228,13 @@ SUBROUTINE poly_p_eval3(p,x,pRes,npoly,error) size_p=SIZE(p)/my_npoly grad=grad_size3(size_p) newSize=SIZE(pRes)/my_npoly - CPPreconditionNoFail(newSize>=poly_size2(grad),cp_failure_level,routineP,error) + CPPreconditionNoFail(newSize>=poly_size2(grad),cp_failure_level,routineP) pRes=0.0 ALLOCATE(xi(grad+1),stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) CALL poly_p_eval3b(p,SIZE(p),x,pRes,SIZE(pRes),my_npoly,grad,xi) DEALLOCATE(xi,stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) END SUBROUTINE ! ***************************************************************************** @@ -1339,14 +1325,12 @@ SUBROUTINE poly_p_eval3b(p,size_p,x,pRes,size_pRes,npoly,grad,xi) !> \param x ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_padd_uneval3(p,x,pRes,npoly,error) +SUBROUTINE poly_padd_uneval3(p,x,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(inout) :: p REAL(dp), INTENT(in) :: x REAL(dp), DIMENSION(:), INTENT(in) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_padd_uneval3', & routineP = moduleN//':'//routineN @@ -1361,13 +1345,13 @@ SUBROUTINE poly_padd_uneval3(p,x,pRes,npoly,error) size_p=SIZE(p)/my_npoly newSize=SIZE(pRes)/my_npoly grad=grad_size2(newSize) - CPPreconditionNoFail(size_p>=poly_size3(grad),cp_failure_level,routineP,error) - CPPreconditionNoFail(newSize==poly_size2(grad),cp_failure_level,routineP,error) + CPPreconditionNoFail(size_p>=poly_size3(grad),cp_failure_level,routineP) + CPPreconditionNoFail(newSize==poly_size2(grad),cp_failure_level,routineP) ALLOCATE(xi(grad+1),stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) CALL poly_padd_uneval3b(p,SIZE(p),x,pRes,SIZE(pRes),my_npoly,grad,xi) DEALLOCATE(xi,stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) END SUBROUTINE ! ***************************************************************************** @@ -1457,14 +1441,12 @@ SUBROUTINE poly_padd_uneval3b(p,size_p,x,pRes,size_pRes,npoly,grad,xi) !> \param x ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_p_eval2(p,x,pRes,npoly,error) +SUBROUTINE poly_p_eval2(p,x,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), INTENT(in) :: x REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_p_eval2', & routineP = moduleN//':'//routineN @@ -1480,12 +1462,12 @@ SUBROUTINE poly_p_eval2(p,x,pRes,npoly,error) grad=grad_size2(size_p) newSize=SIZE(pRes)/my_npoly pRes=0.0_dp - CPPreconditionNoFail(newSize>=poly_size1(grad),cp_failure_level,routineP,error) + CPPreconditionNoFail(newSize>=poly_size1(grad),cp_failure_level,routineP) ALLOCATE(xi(grad+1),stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) CALL poly_p_eval2b(p,SIZE(p),x,pRes,SIZE(pRes),my_npoly,grad,xi) DEALLOCATE(xi,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END SUBROUTINE ! ***************************************************************************** @@ -1524,7 +1506,7 @@ SUBROUTINE poly_p_eval2b(p,size_p,x,pRes,size_pRes,npoly,grad,xi) inSize=size_p/npoly newSize=size_pRes/npoly pRes(1:size_pRes)=0.0_dp - !CPPreconditionNoFail(newSize>grad,cp_failure_level,routineP,error) + !CPPreconditionNoFail(newSize>grad,cp_failure_level,routineP) xi(1)=1.0_dp DO i=1,grad xi(i+1)=xi(i)*x @@ -1570,14 +1552,12 @@ SUBROUTINE poly_p_eval2b(p,size_p,x,pRes,size_pRes,npoly,grad,xi) !> \param x ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_padd_uneval2(p,x,pRes,npoly,error) +SUBROUTINE poly_padd_uneval2(p,x,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(inout) :: p REAL(dp), INTENT(in) :: x REAL(dp), DIMENSION(:), INTENT(in) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_padd_uneval2', & routineP = moduleN//':'//routineN @@ -1592,13 +1572,13 @@ SUBROUTINE poly_padd_uneval2(p,x,pRes,npoly,error) size_p=SIZE(p)/my_npoly newSize=SIZE(pRes)/my_npoly grad=grad_size1(newSize) - CPPreconditionNoFail(size_p>=poly_size2(grad),cp_failure_level,routineP,error) - CPPreconditionNoFail(newSize==poly_size1(grad),cp_failure_level,routineP,error) + CPPreconditionNoFail(size_p>=poly_size2(grad),cp_failure_level,routineP) + CPPreconditionNoFail(newSize==poly_size1(grad),cp_failure_level,routineP) ALLOCATE(xi(grad+1),stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) CALL poly_padd_uneval2b(p,SIZE(p),x,pRes,SIZE(pRes),my_npoly,grad,xi) DEALLOCATE(xi,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END SUBROUTINE ! ***************************************************************************** @@ -1638,7 +1618,7 @@ SUBROUTINE poly_padd_uneval2b(p,size_p,x,pRes,size_pRes,npoly,grad,xi) inSize=size_p/npoly upSize=(grad+1)*(grad+2)/2 newSize=size_pRes/npoly - !CPPreconditionNoFail(newSize>grad,cp_failure_level,routineP,error) + !CPPreconditionNoFail(newSize>grad,cp_failure_level,routineP) xi(1)=1.0_dp DO i=1,grad xi(i+1)=xi(i)*x @@ -1682,14 +1662,12 @@ SUBROUTINE poly_padd_uneval2b(p,size_p,x,pRes,size_pRes,npoly,grad,xi) !> \param x ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_eval1(p,x,pRes,npoly,error) +SUBROUTINE poly_eval1(p,x,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), INTENT(in) :: x REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_eval1', & routineP = moduleN//':'//routineN @@ -1701,7 +1679,7 @@ SUBROUTINE poly_eval1(p,x,pRes,npoly,error) my_npoly=1 IF (PRESENT(npoly)) my_npoly=npoly size_p=SIZE(p)/my_npoly - CPPreconditionNoFail(SIZE(pRes)>=my_npoly,cp_failure_level,routineP,error) + CPPreconditionNoFail(SIZE(pRes)>=my_npoly,cp_failure_level,routineP) pShift=0 DO ipoly=1,my_npoly xx=1.0_dp @@ -1722,14 +1700,12 @@ SUBROUTINE poly_eval1(p,x,pRes,npoly,error) !> \param y ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_eval2(p,x,y,pRes,npoly,error) +SUBROUTINE poly_eval2(p,x,y,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), INTENT(in) :: x, y REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_eval2', & routineP = moduleN//':'//routineN @@ -1745,9 +1721,9 @@ SUBROUTINE poly_eval2(p,x,y,pRes,npoly,error) IF (PRESENT(npoly)) my_npoly=npoly size_p=SIZE(p)/my_npoly grad=grad_size2(size_p) - CPPreconditionNoFail(SIZE(pRes)>=my_npoly,cp_failure_level,routineP,error) + CPPreconditionNoFail(SIZE(pRes)>=my_npoly,cp_failure_level,routineP) ALLOCATE(xi(grad+1),yi(grad+1),stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) xi(1)=1.0_dp DO i=1,grad xi(i+1)=xi(i)*x @@ -1796,14 +1772,12 @@ SUBROUTINE poly_eval2(p,x,y,pRes,npoly,error) !> \param z ... !> \param pRes ... !> \param npoly ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_eval3(p,x,y,z,pRes,npoly,error) +SUBROUTINE poly_eval3(p,x,y,z,pRes,npoly) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), INTENT(in) :: x, y, z REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_eval3', & routineP = moduleN//':'//routineN @@ -1819,9 +1793,9 @@ SUBROUTINE poly_eval3(p,x,y,z,pRes,npoly,error) IF (PRESENT(npoly)) my_npoly=npoly size_p=SIZE(p)/my_npoly grad=grad_size3(size_p) - CPPreconditionNoFail(SIZE(pRes)>=my_npoly,cp_failure_level,routineP,error) + CPPreconditionNoFail(SIZE(pRes)>=my_npoly,cp_failure_level,routineP) ALLOCATE(xi(grad+1),yi(grad+1),zi(grad+1),stat=stat) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) xi(1)=1.0_dp DO i=1,grad xi(i+1)=xi(i)*x @@ -1876,14 +1850,12 @@ SUBROUTINE poly_eval3(p,x,y,z,pRes,npoly,error) !> \param pRes ... !> \param npoly ... !> \param sumUp ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_derive3(p,pRes,npoly,sumUp,error) +SUBROUTINE poly_derive3(p,pRes,npoly,sumUp) REAL(dp), DIMENSION(:), INTENT(in) :: p REAL(dp), DIMENSION(:), INTENT(inout) :: pRes INTEGER, INTENT(in), OPTIONAL :: npoly LOGICAL, INTENT(in), OPTIONAL :: sumUp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_derive3', & routineP = moduleN//':'//routineN @@ -1901,7 +1873,7 @@ SUBROUTINE poly_derive3(p,pRes,npoly,sumUp,error) size_p=SIZE(p)/my_npoly newSize=SIZE(pRes)/(3*my_npoly) grad=grad_size3(size_p) - CPPreconditionNoFail(newSize>=poly_size3(grad),cp_failure_level,routineP,error) + CPPreconditionNoFail(newSize>=poly_size3(grad),cp_failure_level,routineP) IF (.NOT. my_sumUp) pRes=0 xDerivShift=1 yDerivShift=my_npoly*newSize+1 @@ -1964,13 +1936,11 @@ SUBROUTINE poly_derive3(p,pRes,npoly,sumUp,error) !> \param poly_cp2k ... !> \param grad ... !> \param poly_d3 ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_cp2k2d3(poly_cp2k,grad,poly_d3,error) +SUBROUTINE poly_cp2k2d3(poly_cp2k,grad,poly_d3) REAL(dp), DIMENSION(:), INTENT(in) :: poly_cp2k INTEGER, INTENT(in) :: grad REAL(dp), DIMENSION(:), INTENT(out) :: poly_d3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_cp2k2d3', & routineP = moduleN//':'//routineN @@ -1983,8 +1953,8 @@ SUBROUTINE poly_cp2k2d3(poly_cp2k,grad,poly_d3,error) failure=.FALSE. size_p=(grad+1)*(grad+2)*(grad+3)/6 - CPPrecondition(SIZE(poly_cp2k)>=size_p,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(poly_d3)>=size_p,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(poly_cp2k)>=size_p,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(poly_d3)>=size_p,cp_failure_level,routineP,failure) cp_ii=0 sgrad2k=0 sgrad3k=0 @@ -2021,13 +1991,11 @@ SUBROUTINE poly_cp2k2d3(poly_cp2k,grad,poly_d3,error) !> \param poly_cp2k ... !> \param grad ... !> \param poly_d3 ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE poly_d32cp2k(poly_cp2k,grad,poly_d3,error) +SUBROUTINE poly_d32cp2k(poly_cp2k,grad,poly_d3) REAL(dp), DIMENSION(:), INTENT(out) :: poly_cp2k INTEGER, INTENT(in) :: grad REAL(dp), DIMENSION(:), INTENT(in) :: poly_d3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'poly_d32cp2k', & routineP = moduleN//':'//routineN @@ -2040,8 +2008,8 @@ SUBROUTINE poly_d32cp2k(poly_cp2k,grad,poly_d3,error) failure=.FALSE. size_p=(grad+1)*(grad+2)*(grad+3)/6 - CPPrecondition(SIZE(poly_cp2k)>=size_p,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(poly_d3)>=size_p,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(poly_cp2k)>=size_p,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(poly_d3)>=size_p,cp_failure_level,routineP,failure) cp_ii=0 sgrad2k=0 sgrad3k=0 diff --git a/src/dbcsrwrap/cp_dbcsr_interface.F b/src/dbcsrwrap/cp_dbcsr_interface.F index 13c8e958ce..c50b06eb49 100644 --- a/src/dbcsrwrap/cp_dbcsr_interface.F +++ b/src/dbcsrwrap/cp_dbcsr_interface.F @@ -389,10 +389,8 @@ MODULE cp_dbcsr_interface ! ***************************************************************************** !> \brief Initializes DBCSR -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_init_lib (error) - TYPE(cp_error_type), INTENT(INOUT) :: error + SUBROUTINE cp_dbcsr_init_lib () CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_init_lib', & routineP = moduleN//':'//routineN @@ -408,11 +406,9 @@ END SUBROUTINE cp_dbcsr_init_lib !> \brief Finalizes DBCSR !> \param group ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_finalize_lib (group, output_unit, error) + SUBROUTINE cp_dbcsr_finalize_lib (group, output_unit) INTEGER, INTENT(IN) :: group, output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_finalize_lib', & routineP = moduleN//':'//routineN @@ -424,10 +420,8 @@ END SUBROUTINE cp_dbcsr_finalize_lib ! ***************************************************************************** !> \brief Deallocate memory contained in mempools -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_clear_mempools(error) - TYPE(cp_error_type), INTENT(INOUT) :: error + SUBROUTINE cp_dbcsr_clear_mempools() TYPE(dbcsr_error_type) :: dbcsr_error @@ -521,13 +515,11 @@ END FUNCTION cp_dbcsr_maxabs !> \param matrix ... !> \param redist ... !> \param keep_sparsity ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_complete_redistribute(matrix, redist, keep_sparsity, error) + SUBROUTINE cp_dbcsr_complete_redistribute(matrix, redist, keep_sparsity) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix TYPE(cp_dbcsr_type), INTENT(INOUT) :: redist LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_dbcsr_complete_redistribute', & @@ -545,14 +537,12 @@ END SUBROUTINE cp_dbcsr_complete_redistribute !> \param rows ... !> \param cols ... !> \param blk_pointers ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_reserve_blocks(matrix, rows, cols, blk_pointers, error) + SUBROUTINE cp_dbcsr_reserve_blocks(matrix, rows, cols, blk_pointers) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix INTEGER, DIMENSION(:), INTENT(IN) :: rows, cols INTEGER, DIMENSION(:), INTENT(IN), & OPTIONAL :: blk_pointers - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_reserve_blocks', & routineP = moduleN//':'//routineN @@ -566,11 +556,9 @@ END SUBROUTINE cp_dbcsr_reserve_blocks ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_reserve_all_blocks(matrix, error) + SUBROUTINE cp_dbcsr_reserve_all_blocks(matrix) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_reserve_all_blocks', & routineP = moduleN//':'//routineN @@ -583,11 +571,9 @@ END SUBROUTINE cp_dbcsr_reserve_all_blocks ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_reserve_diag_blocks(matrix, error) + SUBROUTINE cp_dbcsr_reserve_diag_blocks(matrix) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_reserve_diag_blocks', & routineP = moduleN//':'//routineN @@ -1085,9 +1071,8 @@ END SUBROUTINE cp_dbcsr_get_info !> \param which_norm ... !> \param norm_scalar ... !> \param norm_vector ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_norm(matrix, which_norm, norm_scalar, norm_vector, error) + SUBROUTINE cp_dbcsr_norm(matrix, which_norm, norm_scalar, norm_vector) TYPE(cp_dbcsr_type), INTENT(INOUT), & TARGET :: matrix @@ -1095,7 +1080,6 @@ SUBROUTINE cp_dbcsr_norm(matrix, which_norm, norm_scalar, norm_vector, error) REAL(dp), INTENT(OUT), OPTIONAL :: norm_scalar REAL(dp), DIMENSION(:), INTENT(OUT), & OPTIONAL :: norm_vector - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_norm', & routineP = moduleN//':'//routineN @@ -1110,7 +1094,7 @@ SUBROUTINE cp_dbcsr_norm(matrix, which_norm, norm_scalar, norm_vector, error) error=dbcsr_error) ELSE CALL cp_assert (.FALSE., cp_wrong_args_error, cp_internal_error,& - routineN, "Must pass either scalar or vector norm.", error=error) + routineN, "Must pass either scalar or vector norm.") ENDIF END SUBROUTINE cp_dbcsr_norm @@ -1118,11 +1102,9 @@ END SUBROUTINE cp_dbcsr_norm ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_replicate_all(matrix, error) + SUBROUTINE cp_dbcsr_replicate_all(matrix) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_replicate_all', & routineP = moduleN//':'//routineN @@ -1138,15 +1120,13 @@ END SUBROUTINE cp_dbcsr_replicate_all !> \param replicate_rows ... !> \param replicate_columns ... !> \param restrict_source ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_replicate(matrix, replicate_rows, replicate_columns,& - restrict_source, error) + restrict_source) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix LOGICAL, INTENT(IN) :: replicate_rows, & replicate_columns INTEGER, INTENT(IN), OPTIONAL :: restrict_source - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_replicate', & routineP = moduleN//':'//routineN @@ -1161,12 +1141,10 @@ END SUBROUTINE cp_dbcsr_replicate !> \brief ... !> \param matrix ... !> \param fast ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_distribute(matrix, fast, error) + SUBROUTINE cp_dbcsr_distribute(matrix, fast) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix LOGICAL, INTENT(in), OPTIONAL :: fast - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_distribute', & routineP = moduleN//':'//routineN @@ -1180,17 +1158,15 @@ END SUBROUTINE cp_dbcsr_distribute ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_release_p (matrix, error) + SUBROUTINE cp_dbcsr_release_p (matrix) TYPE(cp_dbcsr_type), POINTER :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_release_p', & routineP = moduleN//':'//routineN IF(ASSOCIATED(matrix)) THEN - CALL cp_dbcsr_release (matrix, error) + CALL cp_dbcsr_release (matrix) DEALLOCATE(matrix) ENDIF @@ -1200,11 +1176,9 @@ END SUBROUTINE cp_dbcsr_release_p ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_release (matrix, error) + SUBROUTINE cp_dbcsr_release (matrix) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_release', & routineP = moduleN//':'//routineN @@ -1216,11 +1190,9 @@ END SUBROUTINE cp_dbcsr_release ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_init (matrix, error) + SUBROUTINE cp_dbcsr_init (matrix) TYPE(cp_dbcsr_type), INTENT(OUT) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_init', & routineP = moduleN//':'//routineN @@ -1233,22 +1205,20 @@ END SUBROUTINE cp_dbcsr_init ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_init_p (matrix, error) + SUBROUTINE cp_dbcsr_init_p (matrix) TYPE(cp_dbcsr_type), POINTER :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_init_p', & routineP = moduleN//':'//routineN IF(ASSOCIATED(matrix)) THEN - CALL cp_dbcsr_release(matrix, error) + CALL cp_dbcsr_release(matrix) DEALLOCATE(matrix) ENDIF ALLOCATE(matrix) - CALL cp_dbcsr_init (matrix, error) + CALL cp_dbcsr_init (matrix) END SUBROUTINE cp_dbcsr_init_p @@ -1259,14 +1229,12 @@ END SUBROUTINE cp_dbcsr_init_p !> \param matlab_format ... !> \param variable_name ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_print(matrix, nodata, matlab_format, variable_name, unit_nr, error) + SUBROUTINE cp_dbcsr_print(matrix, nodata, matlab_format, variable_name, unit_nr) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix LOGICAL, INTENT(IN), OPTIONAL :: nodata, matlab_format CHARACTER(*), INTENT(in), OPTIONAL :: variable_name INTEGER, OPTIONAL :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_print', & routineP = moduleN//':'//routineN @@ -1281,12 +1249,10 @@ END SUBROUTINE cp_dbcsr_print !> \brief Prints the sum of the elements in each block !> \param matrix ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_print_block_sum(matrix, unit_nr, error) + SUBROUTINE cp_dbcsr_print_block_sum(matrix, unit_nr) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix INTEGER, OPTIONAL :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_print_block_sum', & routineP = moduleN//':'//routineN @@ -1302,13 +1268,11 @@ END SUBROUTINE cp_dbcsr_print_block_sum !> \param matrix ... !> \param local ... !> \param pos ... -!> \param error ... !> \retval checksum ... ! ***************************************************************************** - FUNCTION cp_dbcsr_checksum(matrix, local, pos, error) RESULT(checksum) + FUNCTION cp_dbcsr_checksum(matrix, local, pos) RESULT(checksum) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix LOGICAL, INTENT(IN), OPTIONAL :: local, pos - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp) :: checksum CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_checksum', & @@ -1323,11 +1287,9 @@ END FUNCTION cp_dbcsr_checksum ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_sum_replicated (matrix, error) + SUBROUTINE cp_dbcsr_sum_replicated (matrix) TYPE(cp_dbcsr_type), INTENT(inout) :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_sum_replicated', & routineP = moduleN//':'//routineN @@ -1340,18 +1302,16 @@ END SUBROUTINE cp_dbcsr_sum_replicated ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_triu(matrix, error) + SUBROUTINE cp_dbcsr_triu(matrix) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_triu', & routineP = moduleN//':'//routineN TYPE(dbcsr_error_type) :: dbcsr_error -!CALL cluster_buffer_flush (matrix%buffers, error=error) +!CALL cluster_buffer_flush (matrix%buffers) CALL dbcsr_triu(matrix%matrix, dbcsr_error) !CALL dbcsr_index_compact(matrix%matrix, dbcsr_error) @@ -1361,13 +1321,11 @@ END SUBROUTINE cp_dbcsr_triu ! ***************************************************************************** !> \brief ... !> \param m ... -!> \param error ... !> \param verbosity ... !> \param local ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_verify_matrix(m, error, verbosity, local) + SUBROUTINE cp_dbcsr_verify_matrix(m,verbosity, local) TYPE(cp_dbcsr_type), INTENT(IN) :: m - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER, INTENT(IN), OPTIONAL :: verbosity LOGICAL, INTENT(IN), OPTIONAL :: local @@ -1490,12 +1448,10 @@ END SUBROUTINE cp_dbcsr_distribution_new_clusters2 !> \brief ... !> \param matrix ... !> \param reshuffle ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_finalize(matrix, reshuffle, error) + SUBROUTINE cp_dbcsr_finalize(matrix, reshuffle) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix LOGICAL, INTENT(IN), OPTIONAL :: reshuffle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_finalize', & routineP = moduleN//':'//routineN @@ -1511,14 +1467,12 @@ END SUBROUTINE cp_dbcsr_finalize !> \param nblks_guess ... !> \param sizedata_guess ... !> \param n ... -!> \param error ... !> \param work_mutable ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_work_create(matrix, nblks_guess, sizedata_guess, n,& - error, work_mutable) + work_mutable) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix INTEGER, INTENT(IN), OPTIONAL :: nblks_guess, sizedata_guess, n - TYPE(cp_error_type), INTENT(INOUT) :: error LOGICAL, INTENT(in), OPTIONAL :: work_mutable CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_work_create', & @@ -1544,11 +1498,10 @@ END SUBROUTINE cp_dbcsr_work_create !> \param reuse_arrays ... !> \param mutable_work ... !> \param replication_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_create_new(matrix, name, dist, matrix_type,& row_blk_size, col_blk_size, nze, data_type, reuse,& - reuse_arrays, mutable_work, replication_type, error) + reuse_arrays, mutable_work, replication_type) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix CHARACTER(len=*), INTENT(IN) :: name TYPE(dbcsr_distribution_obj), INTENT(IN) :: dist @@ -1559,7 +1512,6 @@ SUBROUTINE cp_dbcsr_create_new(matrix, name, dist, matrix_type,& LOGICAL, INTENT(IN), OPTIONAL :: reuse, reuse_arrays, & mutable_work CHARACTER, INTENT(IN), OPTIONAL :: replication_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_create_new', & routineP = moduleN//':'//routineN @@ -1592,12 +1544,11 @@ END SUBROUTINE cp_dbcsr_create_new !> \param reuse_arrays ... !> \param mutable_work ... !> \param replication_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_create_template(matrix, name, template,& dist, matrix_type,& row_blk_size, col_blk_size, nze, data_type,& - reuse_arrays, mutable_work, replication_type, error) + reuse_arrays, mutable_work, replication_type) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix CHARACTER(len=*), INTENT(IN), OPTIONAL :: name TYPE(cp_dbcsr_type), INTENT(IN) :: template @@ -1609,7 +1560,6 @@ SUBROUTINE cp_dbcsr_create_template(matrix, name, template,& INTEGER, INTENT(IN), OPTIONAL :: nze, data_type LOGICAL, INTENT(IN), OPTIONAL :: reuse_arrays, mutable_work CHARACTER, INTENT(IN), OPTIONAL :: replication_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_create_template', & routineP = moduleN//':'//routineN @@ -1635,16 +1585,14 @@ END SUBROUTINE cp_dbcsr_create_template !> \param use_absolute ... !> \param filter_diag ... !> \param thorough ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_filter(matrix, eps, method, use_absolute, filter_diag, & - thorough, error) + thorough) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix REAL(dp), INTENT(IN) :: eps INTEGER, INTENT(IN), OPTIONAL :: method LOGICAL, INTENT(in), OPTIONAL :: use_absolute, filter_diag, & thorough - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_filter', & routineP = moduleN//':'//routineN @@ -1657,7 +1605,7 @@ SUBROUTINE cp_dbcsr_filter(matrix, eps, method, use_absolute, filter_diag, & ELSE quick = .FALSE. ENDIF - CALL dbcsr_filter(matrix%matrix, cp_dbcsr_conform_scalar (eps, matrix, error),& + CALL dbcsr_filter(matrix%matrix, cp_dbcsr_conform_scalar (eps, matrix),& method, use_absolute, filter_diag,& quick=quick, error=dbcsr_error) END SUBROUTINE cp_dbcsr_filter @@ -1666,12 +1614,10 @@ END SUBROUTINE cp_dbcsr_filter !> \brief ... !> \param matrix ... !> \param diag ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_set_diag(matrix, diag, error) + SUBROUTINE cp_dbcsr_set_diag(matrix, diag) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix REAL(dp), DIMENSION(:), INTENT(IN) :: diag - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_set_diag', & routineP = moduleN//':'//routineN @@ -1685,13 +1631,11 @@ END SUBROUTINE cp_dbcsr_set_diag !> \brief ... !> \param matrix ... !> \param diag ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_get_diag(matrix, diag, error) + SUBROUTINE cp_dbcsr_get_diag(matrix, diag) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix REAL(dp), DIMENSION(:), INTENT(INOUT) :: diag - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_get_diag', & routineP = moduleN//':'//routineN @@ -1705,13 +1649,11 @@ END SUBROUTINE cp_dbcsr_get_diag !> \brief ... !> \param matrix ... !> \param diag ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_get_block_diag(matrix, diag, error) + SUBROUTINE cp_dbcsr_get_block_diag(matrix, diag) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix TYPE(cp_dbcsr_type), INTENT(INOUT) :: diag - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_get_block_diag', & routineP = moduleN//':'//routineN @@ -1719,8 +1661,7 @@ SUBROUTINE cp_dbcsr_get_block_diag(matrix, diag, error) TYPE(dbcsr_error_type) :: dbcsr_error CALL cp_dbcsr_create (diag, "Diagonal of "//TRIM(cp_dbcsr_name (matrix)),& - template=matrix,& - error=error) + template=matrix) CALL dbcsr_get_block_diag(matrix%matrix, diag%matrix, dbcsr_error) END SUBROUTINE cp_dbcsr_get_block_diag @@ -1730,13 +1671,11 @@ END SUBROUTINE cp_dbcsr_get_block_diag !> \param alpha_scalar ... !> \param first_row ... !> \param last_row ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_add_on_diag(matrix, alpha_scalar, first_row, last_row, error) + SUBROUTINE cp_dbcsr_add_on_diag(matrix, alpha_scalar, first_row, last_row) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix REAL(KIND=dp), INTENT(IN) :: alpha_scalar INTEGER, INTENT(in), OPTIONAL :: first_row, last_row - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_add_on_diag', & routineP = moduleN//':'//routineN @@ -1744,7 +1683,7 @@ SUBROUTINE cp_dbcsr_add_on_diag(matrix, alpha_scalar, first_row, last_row, error TYPE(dbcsr_error_type) :: dbcsr_error CALL dbcsr_add_on_diag(matrix%matrix,& - cp_dbcsr_conform_scalar (alpha_scalar, matrix, error),& + cp_dbcsr_conform_scalar (alpha_scalar, matrix),& first_row, last_row, dbcsr_error) END SUBROUTINE cp_dbcsr_add_on_diag @@ -1752,12 +1691,10 @@ END SUBROUTINE cp_dbcsr_add_on_diag !> \brief ... !> \param matrix ... !> \param filepath ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_binary_write(matrix, filepath, error) + SUBROUTINE cp_dbcsr_binary_write(matrix, filepath) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix CHARACTER(LEN=*), INTENT(IN) :: filepath - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_binary_write', & routineP = moduleN//':'//routineN @@ -1774,14 +1711,12 @@ END SUBROUTINE cp_dbcsr_binary_write !> \param distribution ... !> \param groupid ... !> \param matrix_new ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_binary_read(filepath, distribution, groupid, matrix_new, error) + SUBROUTINE cp_dbcsr_binary_read(filepath, distribution, groupid, matrix_new) CHARACTER(len=*), INTENT(IN) :: filepath TYPE(dbcsr_distribution_obj), INTENT(IN) :: distribution INTEGER, INTENT(IN), OPTIONAL :: groupid TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_new - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_binary_read', & routineP = moduleN//':'//routineN @@ -1797,18 +1732,16 @@ END SUBROUTINE cp_dbcsr_binary_read !> \param matrix_b ... !> \param matrix_a ... !> \param name ... -!> \param error ... !> \param keep_sparsity ... !> \param shallow_data ... !> \param keep_imaginary ... !> \param matrix_type ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_copy(matrix_b, matrix_a, name, error, keep_sparsity,& + SUBROUTINE cp_dbcsr_copy(matrix_b, matrix_a, name,keep_sparsity,& shallow_data, keep_imaginary, matrix_type) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_b TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name - TYPE(cp_error_type), INTENT(INOUT) :: error LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity, shallow_data, & keep_imaginary CHARACTER, INTENT(IN), OPTIONAL :: matrix_type @@ -1820,11 +1753,10 @@ SUBROUTINE cp_dbcsr_copy(matrix_b, matrix_a, name, error, keep_sparsity,& !call cp_assert (matrix_b%ref_count .gt. 0,& ! cp_warning_level, cp_caller_error, routineN,& -! "Matrix not created.", error=error) +! "Matrix not created.") IF (matrix_b%ref_count .EQ. 0) THEN - CALL cp_dbcsr_create (matrix_b, template=matrix_a,& - error=error) + CALL cp_dbcsr_create (matrix_b, template=matrix_a) ENDIF CALL dbcsr_copy(matrix_b%matrix, matrix_a%matrix, name, keep_sparsity,& shallow_data, keep_imaginary, matrix_type, dbcsr_error) @@ -1834,12 +1766,10 @@ END SUBROUTINE cp_dbcsr_copy !> \brief ... !> \param matrix_b ... !> \param matrix_a ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_copy_into_existing(matrix_b, matrix_a, error) + SUBROUTINE cp_dbcsr_copy_into_existing(matrix_b, matrix_a) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_b TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_copy_into_existing', & routineP = moduleN//':'//routineN @@ -1847,8 +1777,7 @@ SUBROUTINE cp_dbcsr_copy_into_existing(matrix_b, matrix_a, error) TYPE(dbcsr_error_type) :: dbcsr_error IF (matrix_b%ref_count .EQ. 0) THEN - CALL cp_dbcsr_create (matrix_b, template=matrix_a,& - error=error) + CALL cp_dbcsr_create (matrix_b, template=matrix_a) ENDIF CALL dbcsr_copy_into_existing(matrix_b%matrix, matrix_a%matrix, dbcsr_error) END SUBROUTINE cp_dbcsr_copy_into_existing @@ -1858,12 +1787,10 @@ END SUBROUTINE cp_dbcsr_copy_into_existing !> \brief ... !> \param matrix_a ... !> \param matrix_b ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_desymmetrize(matrix_a, matrix_b, error) + SUBROUTINE cp_dbcsr_desymmetrize(matrix_a, matrix_b) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_b - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_desymmetrize', & routineP = moduleN//':'//routineN @@ -1872,11 +1799,10 @@ SUBROUTINE cp_dbcsr_desymmetrize(matrix_a, matrix_b, error) !call cp_assert (matrix_b%ref_count .gt. 0,& ! cp_warning_level, cp_caller_error, routineN,& -! "Matrix not created.", error=error) +! "Matrix not created.") IF (matrix_b%ref_count .EQ. 0) THEN - CALL cp_dbcsr_create (matrix_b, template=matrix_a,& - error=error) + CALL cp_dbcsr_create (matrix_b, template=matrix_a) ENDIF CALL dbcsr_desymmetrize_deep(matrix_a%matrix, matrix_b%matrix,& untransposed_data = .TRUE., error=dbcsr_error) @@ -1891,10 +1817,9 @@ END SUBROUTINE cp_dbcsr_desymmetrize !> \param transpose_data ... !> \param transpose_distribution ... !> \param use_distribution ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_dbcsr_transposed (transposed, normal, shallow_data_copy,& - transpose_data, transpose_distribution, use_distribution, error) + transpose_data, transpose_distribution, use_distribution) TYPE(cp_dbcsr_type), INTENT(INOUT) :: transposed TYPE(cp_dbcsr_type), INTENT(IN) :: normal @@ -1903,7 +1828,6 @@ SUBROUTINE cp_dbcsr_transposed (transposed, normal, shallow_data_copy,& transpose_distribution TYPE(dbcsr_distribution_obj), & INTENT(IN), OPTIONAL :: use_distribution - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_transposed', & routineP = moduleN//':'//routineN @@ -1935,13 +1859,11 @@ END SUBROUTINE cp_dbcsr_transposed !> \param vec the vector object to create must be allocated but not initialized !> \param matrix a dbcsr matrix used as template !> \param ncol number of vectors in the dbcsr_object (1 for vector, n for skinny matrix) -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_create_col_vec_from_matrix(vec,matrix,ncol,error) + SUBROUTINE cp_dbcsr_create_col_vec_from_matrix(vec,matrix,ncol) TYPE(cp_dbcsr_type), INTENT(INOUT) :: vec TYPE(cp_dbcsr_type), INTENT(IN) :: matrix INTEGER :: ncol - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_dbcsr_create_col_vec_from_matrix', & @@ -1961,13 +1883,11 @@ END SUBROUTINE cp_dbcsr_create_col_vec_from_matrix !> \param vec the vector object to create must be allocated but not initialized !> \param matrix a dbcsr matrix used as template !> \param nrow number of vectors in the dbcsr_object (1 for vector, n for skinny matrix) -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_create_row_vec_from_matrix(vec,matrix,nrow,error) + SUBROUTINE cp_dbcsr_create_row_vec_from_matrix(vec,matrix,nrow) TYPE(cp_dbcsr_type), INTENT(INOUT) :: vec TYPE(cp_dbcsr_type), INTENT(IN) :: matrix INTEGER :: nrow - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_dbcsr_create_row_vec_from_matrix', & @@ -1987,13 +1907,11 @@ END SUBROUTINE cp_dbcsr_create_row_vec_from_matrix !> \param vec the vector object to create must be allocated but not initialized !> \param matrix a dbcsr matrix used as template !> \param ncol number of vectors in the dbcsr_object (1 for vector, n for skinny matrix) -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_create_rep_col_vec_from_matrix(vec,matrix,ncol,error) + SUBROUTINE cp_dbcsr_create_rep_col_vec_from_matrix(vec,matrix,ncol) TYPE(cp_dbcsr_type), INTENT(INOUT) :: vec TYPE(cp_dbcsr_type), INTENT(IN) :: matrix INTEGER :: ncol - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_dbcsr_create_rep_col_vec_from_matrix', & @@ -2013,13 +1931,11 @@ END SUBROUTINE cp_dbcsr_create_rep_col_vec_from_matrix !> \param vec the vector object to create must be allocated but not initialized !> \param matrix a dbcsr matrix used as template !> \param nrow number of vectors in the dbcsr_object (1 for vector, n for skinny matrix) -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_create_rep_row_vec_from_matrix(vec,matrix,nrow,error) + SUBROUTINE cp_dbcsr_create_rep_row_vec_from_matrix(vec,matrix,nrow) TYPE(cp_dbcsr_type), INTENT(INOUT) :: vec TYPE(cp_dbcsr_type), INTENT(IN) :: matrix INTEGER :: nrow - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_dbcsr_create_rep_row_vec_from_matrix', & @@ -2035,13 +1951,11 @@ END SUBROUTINE cp_dbcsr_create_rep_row_vec_from_matrix !> \brief ... !> \param matrix ... !> \param arnoldi_data ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_arnoldi_ev(matrix,arnoldi_data,error) + SUBROUTINE cp_dbcsr_arnoldi_ev(matrix,arnoldi_data) TYPE(cp_dbcsr_p_type), DIMENSION(:), & INTENT(IN) :: matrix TYPE(dbcsr_arnoldi_data) :: arnoldi_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_arnoldi_ev', & routineP = moduleN//':'//routineN @@ -2072,15 +1986,13 @@ END SUBROUTINE cp_dbcsr_arnoldi_ev !> \param converged ... !> \param threshold ... !> \param max_iter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_arnoldi_extremal(matrix, max_ev, min_ev, converged, threshold, max_iter, error) + SUBROUTINE cp_dbcsr_arnoldi_extremal(matrix, max_ev, min_ev, converged, threshold, max_iter) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix REAL(KIND=dp), INTENT(OUT) :: max_ev, min_ev LOGICAL, INTENT(OUT) :: converged REAL(KIND=dp), INTENT(IN) :: threshold INTEGER, INTENT(IN) :: max_iter - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_arnoldi_extremal', & routineP = moduleN//':'//routineN @@ -2159,13 +2071,11 @@ END SUBROUTINE cp_set_arnoldi_initial_vector !> \param ind ... !> \param matrix ... !> \param vector ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_selected_ritz_vec(arnoldi_data,ind,matrix,vector,error) + SUBROUTINE get_selected_ritz_vec(arnoldi_data,ind,matrix,vector) TYPE(dbcsr_arnoldi_data) :: arnoldi_data INTEGER :: ind TYPE(cp_dbcsr_type) :: matrix, vector - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_selected_ritz_vec', & routineP = moduleN//':'//routineN @@ -2183,13 +2093,11 @@ END SUBROUTINE get_selected_ritz_vec !> \param a0 ... !> \param a1 ... !> \param a2 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_function_of_elements(matrix_a, func, a0, a1, a2, error) + SUBROUTINE cp_dbcsr_function_of_elements(matrix_a, func, a0, a1, a2) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a INTEGER, INTENT(IN) :: func REAL(kind=dp), INTENT(IN), OPTIONAL :: a0, a1, a2 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_dbcsr_function_of_elements', & @@ -2206,14 +2114,11 @@ END SUBROUTINE cp_dbcsr_function_of_elements !> \param matrix_b ... !> \param matrix_c ... !> \param b_assume_value ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_hadamard_product(matrix_a, matrix_b, matrix_c, b_assume_value,& - error) + SUBROUTINE cp_dbcsr_hadamard_product(matrix_a, matrix_b, matrix_c, b_assume_value) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a, matrix_b TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_c REAL(KIND=dp), INTENT(IN), OPTIONAL :: b_assume_value - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_hadamard_product', & routineP = moduleN//':'//routineN @@ -2248,16 +2153,14 @@ END SUBROUTINE cp_dbcsr_hadamard_product !> \param tr_b ... !> \param new_a ... !> \param new_b ... -!> \param error ... ! ***************************************************************************** SUBROUTINE matrix_match_sizes (matrix_c, matrix_a, tr_a, matrix_b, tr_b,& - new_a, new_b, error) + new_a, new_b) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_c, matrix_a CHARACTER, INTENT(IN) :: tr_a TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_b CHARACTER, INTENT(IN) :: tr_b TYPE(cp_dbcsr_type), INTENT(OUT) :: new_a, new_b - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'matrix_match_sizes', & routineP = moduleN//':'//routineN @@ -2309,7 +2212,7 @@ SUBROUTINE matrix_match_sizes (matrix_c, matrix_a, tr_a, matrix_b, tr_b,& b_dist = cp_dbcsr_distribution (matrix_b) c_dist = cp_dbcsr_distribution (matrix_c) IF (new_b_rows .OR. new_b_cols) THEN - CALL cp_dbcsr_init (new_b, error=error) + CALL cp_dbcsr_init (new_b) IF (.NOT. btr) THEN IF (new_b_cols) THEN CALL match_1_dist (new_col_dist,& @@ -2404,13 +2307,12 @@ SUBROUTINE matrix_match_sizes (matrix_c, matrix_a, tr_a, matrix_b, tr_b,& CALL cp_dbcsr_create (new_b, template=matrix_b,& dist = new_dist,& row_blk_size = new_row_size,& - col_blk_size = new_col_size,& - error=error) + col_blk_size = new_col_size) CALL dbcsr_distribution_release (new_dist) - CALL cp_dbcsr_complete_redistribute (matrix_b, new_b, error=error) + CALL cp_dbcsr_complete_redistribute (matrix_b, new_b) ELSE - CALL cp_dbcsr_init (new_b, error=error) - CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE., error=error) + CALL cp_dbcsr_init (new_b) + CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE.) ENDIF create_col_dist = .FALSE. @@ -2420,7 +2322,7 @@ SUBROUTINE matrix_match_sizes (matrix_c, matrix_a, tr_a, matrix_b, tr_b,& ! Process matrix A new_a_rows = a_rows_total .NE. c_rows_total IF (new_a_rows) THEN - CALL cp_dbcsr_init (new_a, error=error) + CALL cp_dbcsr_init (new_a) IF (atr) THEN new_row_dist => dbcsr_distribution_row_dist (a_dist) new_row_clusters => dbcsr_distribution_row_clusters(a_dist) @@ -2460,13 +2362,12 @@ SUBROUTINE matrix_match_sizes (matrix_c, matrix_a, tr_a, matrix_b, tr_b,& CALL cp_dbcsr_create (new_a, template=matrix_a,& dist=new_dist,& row_blk_size = new_row_size,& - col_blk_size = new_col_size,& - error=error) + col_blk_size = new_col_size) CALL dbcsr_distribution_release (new_dist) - CALL cp_dbcsr_complete_redistribute (matrix_a, new_a, error=error) + CALL cp_dbcsr_complete_redistribute (matrix_a, new_a) ELSE - CALL cp_dbcsr_init (new_a, error=error) - CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE., error=error) + CALL cp_dbcsr_init (new_a) + CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE.) ENDIF END SUBROUTINE matrix_match_sizes @@ -2555,16 +2456,14 @@ END FUNCTION cp_dbcsr_col_block_sizes ! ***************************************************************************** !> \brief Deallocates a DBCSR matrix for compatibility with CP2K !> \param[in,out] matrix DBCSR matrix -!> \param[in,out] error cp2k error ! ***************************************************************************** - SUBROUTINE cp_dbcsr_deallocate_matrix(matrix, error) + SUBROUTINE cp_dbcsr_deallocate_matrix(matrix) TYPE(cp_dbcsr_type), POINTER :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_deallocate_matrix', & routineP = moduleN//':'//routineN - CALL cp_dbcsr_release (matrix, error=error) + CALL cp_dbcsr_release (matrix) CALL cp_assert (.NOT. cp_dbcsr_valid_index(matrix), cp_warning_level,& cp_caller_error, routineN,& 'You should not "deallocate" a referenced matrix. '//& @@ -2583,22 +2482,20 @@ END SUBROUTINE cp_dbcsr_deallocate_matrix !> \brief Allocate and initialize a real matrix 1-dimensional set. !> \param[in,out] matrix_set Set containing the DBCSR matrices !> \param[in] nmatrix Size of set -!> \param[in,out] error cp2k error !> \par History !> 2009-08-17 Adapted from sparse_matrix_type for DBCSR ! ***************************************************************************** - SUBROUTINE allocate_dbcsr_matrix_set(matrix_set, nmatrix, error) + SUBROUTINE allocate_dbcsr_matrix_set(matrix_set, nmatrix) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_set INTEGER, INTENT(IN) :: nmatrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_dbcsr_matrix_set', & routineP = moduleN//':'//routineN INTEGER :: imatrix - IF (ASSOCIATED(matrix_set)) CALL cp_dbcsr_deallocate_matrix_set(matrix_set,error=error) + IF (ASSOCIATED(matrix_set)) CALL cp_dbcsr_deallocate_matrix_set(matrix_set) ALLOCATE (matrix_set(nmatrix)) DO imatrix=1,nmatrix NULLIFY (matrix_set(imatrix)%matrix) @@ -2612,22 +2509,20 @@ END SUBROUTINE allocate_dbcsr_matrix_set !> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type !> \param[in] nmatrix Size of set !> \param mmatrix ... -!> \param[in,out] error cp2k error !> \par History !> 2009-08-17 Adapted from sparse_matrix_type for DBCSR ! ***************************************************************************** - SUBROUTINE allocate_dbcsr_matrix_set_2d(matrix_set,nmatrix,mmatrix,error) + SUBROUTINE allocate_dbcsr_matrix_set_2d(matrix_set,nmatrix,mmatrix) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: matrix_set INTEGER, INTENT(IN) :: nmatrix, mmatrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_dbcsr_matrix_set_2d', & routineP = moduleN//':'//routineN INTEGER :: imatrix, jmatrix - IF (ASSOCIATED(matrix_set)) CALL cp_dbcsr_deallocate_matrix_set(matrix_set,error=error) + IF (ASSOCIATED(matrix_set)) CALL cp_dbcsr_deallocate_matrix_set(matrix_set) ALLOCATE (matrix_set(nmatrix,mmatrix)) DO jmatrix=1,mmatrix DO imatrix=1,nmatrix @@ -2642,15 +2537,13 @@ END SUBROUTINE allocate_dbcsr_matrix_set_2d ! ***************************************************************************** !> \brief Deallocate a real matrix set and release all of the member matrices. !> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type -!> \param[in,out] error cp2k error !> \par History !> 2009-08-17 Adapted from sparse_matrix_type for DBCSR ! ***************************************************************************** - SUBROUTINE deallocate_dbcsr_matrix_set(matrix_set,error) + SUBROUTINE deallocate_dbcsr_matrix_set(matrix_set) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_dbcsr_matrix_set', & routineP = moduleN//':'//routineN @@ -2659,7 +2552,7 @@ SUBROUTINE deallocate_dbcsr_matrix_set(matrix_set,error) IF (ASSOCIATED(matrix_set)) THEN DO imatrix=1,SIZE(matrix_set) - CALL cp_dbcsr_deallocate_matrix(matrix_set(imatrix)%matrix,error=error) + CALL cp_dbcsr_deallocate_matrix(matrix_set(imatrix)%matrix) END DO DEALLOCATE (matrix_set) END IF @@ -2669,15 +2562,13 @@ END SUBROUTINE deallocate_dbcsr_matrix_set ! ***************************************************************************** !> \brief Deallocate a real matrix set and release all of the member matrices. !> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type -!> \param[in,out] error cp2k error !> \par History !> 2009-08-17 Adapted from sparse_matrix_type for DBCSR ! ***************************************************************************** - SUBROUTINE deallocate_dbcsr_matrix_set_2d(matrix_set,error) + SUBROUTINE deallocate_dbcsr_matrix_set_2d(matrix_set) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: matrix_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'deallocate_dbcsr_matrix_set_2d', & @@ -2688,7 +2579,7 @@ SUBROUTINE deallocate_dbcsr_matrix_set_2d(matrix_set,error) IF (ASSOCIATED(matrix_set)) THEN DO jmatrix=1,SIZE(matrix_set,2) DO imatrix=1,SIZE(matrix_set,1) - CALL cp_dbcsr_deallocate_matrix(matrix_set(imatrix,jmatrix)%matrix,error=error) + CALL cp_dbcsr_deallocate_matrix(matrix_set(imatrix,jmatrix)%matrix) END DO END DO DEALLOCATE (matrix_set) @@ -2714,9 +2605,8 @@ END FUNCTION cp_dbcsr_has_symmetry !> \param dist_format ... !> \param csr_sparsity ... !> \param numnodes ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_csr_create_from_dbcsr(dbcsr_mat, csr_mat, dist_format, csr_sparsity, numnodes, error) + SUBROUTINE cp_csr_create_from_dbcsr(dbcsr_mat, csr_mat, dist_format, csr_sparsity, numnodes) TYPE(cp_dbcsr_type), INTENT(IN) :: dbcsr_mat TYPE(csr_type), INTENT(OUT) :: csr_mat @@ -2724,7 +2614,6 @@ SUBROUTINE cp_csr_create_from_dbcsr(dbcsr_mat, csr_mat, dist_format, csr_sparsit TYPE(cp_dbcsr_type), INTENT(IN), & OPTIONAL :: csr_sparsity INTEGER, INTENT(IN), OPTIONAL :: numnodes - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_csr_create_from_dbcsr', & routineP = moduleN//':'//routineN @@ -2745,13 +2634,11 @@ END SUBROUTINE cp_csr_create_from_dbcsr !> \brief ... !> \param dbcsr_mat ... !> \param csr_mat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_convert_csr_to_dbcsr(dbcsr_mat, csr_mat, error) + SUBROUTINE cp_convert_csr_to_dbcsr(dbcsr_mat, csr_mat) TYPE(cp_dbcsr_type), INTENT(INOUT) :: dbcsr_mat TYPE(csr_type), INTENT(INOUT) :: csr_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_convert_csr_to_dbcsr', & routineP = moduleN//':'//routineN @@ -2766,12 +2653,10 @@ END SUBROUTINE cp_convert_csr_to_dbcsr !> \brief ... !> \param dbcsr_mat ... !> \param csr_mat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_convert_dbcsr_to_csr(dbcsr_mat, csr_mat, error) + SUBROUTINE cp_convert_dbcsr_to_csr(dbcsr_mat, csr_mat) TYPE(cp_dbcsr_type), INTENT(IN) :: dbcsr_mat TYPE(csr_type), INTENT(INOUT) :: csr_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_convert_dbcsr_to_csr', & routineP = moduleN//':'//routineN @@ -2785,11 +2670,9 @@ END SUBROUTINE cp_convert_dbcsr_to_csr ! ***************************************************************************** !> \brief ... !> \param csr_mat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_csr_destroy(csr_mat, error) + SUBROUTINE cp_csr_destroy(csr_mat) TYPE(csr_type), INTENT(INOUT) :: csr_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_csr_destroy', & routineP = moduleN//':'//routineN @@ -2811,10 +2694,9 @@ END SUBROUTINE cp_csr_destroy !> \param nrows_local ... !> \param mp_group ... !> \param data_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_csr_create_new(csr_mat, nrows_total, ncols_total, nze_total,& - nze_local, nrows_local, mp_group, data_type, error) + nze_local, nrows_local, mp_group, data_type) TYPE(csr_type), INTENT(OUT) :: csr_mat INTEGER, INTENT(IN) :: nrows_total, ncols_total @@ -2822,7 +2704,6 @@ SUBROUTINE cp_csr_create_new(csr_mat, nrows_total, ncols_total, nze_total,& INTEGER, INTENT(IN) :: nze_local, nrows_local, & mp_group INTEGER, INTENT(IN), OPTIONAL :: data_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_csr_create_new', & routineP = moduleN//':'//routineN @@ -2837,12 +2718,10 @@ SUBROUTINE cp_csr_create_new(csr_mat, nrows_total, ncols_total, nze_total,& !> \brief ... !> \param matrix_b ... !> \param matrix_a ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_csr_create_template(matrix_b, matrix_a, error) + SUBROUTINE cp_csr_create_template(matrix_b, matrix_a) TYPE(csr_type), INTENT(OUT) :: matrix_b TYPE(csr_type), INTENT(IN) :: matrix_a - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_csr_create_template', & routineP = moduleN//':'//routineN @@ -2857,12 +2736,10 @@ SUBROUTINE cp_csr_create_template(matrix_b, matrix_a, error) !> \brief ... !> \param csr_mat ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_csr_print_sparsity(csr_mat, unit_nr, error) + SUBROUTINE cp_csr_print_sparsity(csr_mat, unit_nr) TYPE(csr_type), INTENT(IN) :: csr_mat INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error TYPE(dbcsr_error_type) :: dbcsr_error @@ -2880,13 +2757,11 @@ SUBROUTINE cp_csr_print_sparsity(csr_mat, unit_nr, error) !> \param[in] block_row the row !> \param[in] block_col the column !> \param[in] block the block to put -!> \param[in,out] error cp2k error ! ***************************************************************************** - SUBROUTINE cp_dbcsr_add_block_node (matrix, block_row, block_col, block, error) + SUBROUTINE cp_dbcsr_add_block_node (matrix, block_row, block_col, block) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix INTEGER, INTENT(IN) :: block_row, block_col REAL(KIND=dp), DIMENSION(:, :), POINTER :: block - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_add_block_node', & routineP = moduleN//':'//routineN @@ -2901,12 +2776,12 @@ SUBROUTINE cp_dbcsr_add_block_node (matrix, block_row, block_col, block, error) ithread = 0 !$ ithread = omp_get_thread_num() IF (.NOT. ASSOCIATED (matrix%matrix%m%wms)) THEN - CALL cp_dbcsr_work_create (matrix, work_mutable=.TRUE., error=error) + CALL cp_dbcsr_work_create (matrix, work_mutable=.TRUE.) matrix%matrix%m%valid = .FALSE. ENDIF !$ CALL cp_assert (SIZE (matrix%matrix%m%wms) .GE. omp_get_num_threads(),& !$ cp_fatal_level, cp_wrong_args_error, routineN,& -!$ "Too few threads.", error=error) +!$ "Too few threads.") CALL cp_assert (dbcsr_wm_use_mutable (matrix%matrix%m%wms(ithread+1)),& cp_warning_level,& cp_unimplemented_error_nr, routineN,& @@ -2925,7 +2800,7 @@ SUBROUTINE cp_dbcsr_add_block_node (matrix, block_row, block_col, block, error) CALL cp_assert (p .EQ. dbcsr_mp_mynode (dbcsr_distribution_mp (& cp_dbcsr_distribution(matrix))),& cp_warning_level, cp_internal_error, routineN,& - "Adding non-local element", error=error) + "Adding non-local element") ENDIF CALL cp_assert (.NOT.existed, cp_warning_level, cp_wrong_args_error,& routineN, "You should not add existing blocks according to old API.") diff --git a/src/dbcsrwrap/cp_dbcsr_interface_c.f90 b/src/dbcsrwrap/cp_dbcsr_interface_c.f90 index fccf6fb877..c892347f17 100644 --- a/src/dbcsrwrap/cp_dbcsr_interface_c.f90 +++ b/src/dbcsrwrap/cp_dbcsr_interface_c.f90 @@ -11,10 +11,9 @@ !> \param error ... !> \retval encapsulated ... ! ***************************************************************************** - FUNCTION make_conformant_scalar_c (scalar, matrix, error) RESULT (encapsulated) + FUNCTION make_conformant_scalar_c (scalar, matrix) RESULT (encapsulated) COMPLEX(kind=real_4), INTENT(IN) :: scalar TYPE(cp_dbcsr_type), INTENT(IN) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_conformant_scalar_c', & routineP = moduleN//':'//routineN @@ -31,7 +30,7 @@ FUNCTION make_conformant_scalar_c (scalar, matrix, error) RESULT (encapsulated) CALL cp_assert (data_type .EQ. dbcsr_type_complex_4 .OR.& data_type .EQ. dbcsr_type_complex_8,& cp_fatal_level, cp_wrong_args_error, routineN,& - "Can not conform a complex to a real number", error=error) + "Can not conform a complex to a real number") END IF CALL dbcsr_scalar_set_type (encapsulated,data_type) END FUNCTION make_conformant_scalar_c @@ -252,10 +251,9 @@ END SUBROUTINE cp_dbcsr_get_block_p_c !> \param trace ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_a_c (matrix_a, trace, error) + SUBROUTINE cp_dbcsr_trace_a_c (matrix_a, trace) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a COMPLEX(kind=real_4), INTENT(OUT) :: trace - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_a_c', & routineP = moduleN//':'//routineN @@ -280,12 +278,11 @@ END SUBROUTINE cp_dbcsr_trace_a_c !> \param local_sum ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_ab_c (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum, error) + SUBROUTINE cp_dbcsr_trace_ab_c (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a, matrix_b COMPLEX(kind=real_4), INTENT(INOUT) :: trace CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: trans_a, trans_b LOGICAL, INTENT(IN), OPTIONAL :: local_sum - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_ab_c', & routineP = moduleN//':'//routineN @@ -323,7 +320,7 @@ SUBROUTINE cp_dbcsr_multiply_c (transa, transb,& first_row, last_row, first_column, last_column, first_k, last_k,& retain_sparsity, match_matrix_sizes, & filter_eps,& - error, flop) + flop) CHARACTER(LEN=1), INTENT(IN) :: transa, transb COMPLEX(kind=real_4), INTENT(IN) :: alpha TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a, matrix_b @@ -334,7 +331,6 @@ SUBROUTINE cp_dbcsr_multiply_c (transa, transb,& first_k, last_k LOGICAL, INTENT(IN), OPTIONAL :: retain_sparsity, match_matrix_sizes REAL(kind=real_8), INTENT(IN), OPTIONAL :: filter_eps - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER(int_8), INTENT(OUT), OPTIONAL :: flop CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_multiply_c', & @@ -358,12 +354,12 @@ SUBROUTINE cp_dbcsr_multiply_c (transa, transb,& my_match_matrix_sizes=.FALSE. IF(PRESENT(match_matrix_sizes)) my_match_matrix_sizes=match_matrix_sizes IF(my_match_matrix_sizes)THEN - CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b, error) + CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b) ELSE - CALL cp_dbcsr_init(new_a,error=error) - CALL cp_dbcsr_init(new_b,error=error) - CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE., error=error) - CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE., error=error) + CALL cp_dbcsr_init(new_a) + CALL cp_dbcsr_init(new_b) + CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE.) + CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE.) END IF CALL dbcsr_multiply(transa, transb,& @@ -373,8 +369,8 @@ SUBROUTINE cp_dbcsr_multiply_c (transa, transb,& filter_eps=filter_eps,& error=dbcsr_error, flop=flop) - CALL cp_dbcsr_release (new_a, error=error) - CALL cp_dbcsr_release (new_b, error=error) + CALL cp_dbcsr_release (new_a) + CALL cp_dbcsr_release (new_b) END SUBROUTINE cp_dbcsr_multiply_c @@ -386,11 +382,10 @@ END SUBROUTINE cp_dbcsr_multiply_c !> \param side ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_by_vector_c (matrix_a, alpha, side, error) + SUBROUTINE cp_dbcsr_scale_by_vector_c (matrix_a, alpha, side) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a COMPLEX(kind=real_4), DIMENSION(:), INTENT(IN), TARGET :: alpha CHARACTER(LEN=*), INTENT(IN) :: side - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_by_vector_c ', & routineP = moduleN//':'//routineN @@ -408,11 +403,10 @@ END SUBROUTINE cp_dbcsr_scale_by_vector_c !> \param last_column ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_c (matrix_a, alpha_scalar, last_column, error) + SUBROUTINE cp_dbcsr_scale_c (matrix_a, alpha_scalar, last_column) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a COMPLEX(kind=real_4), INTENT(IN) :: alpha_scalar INTEGER, INTENT(IN), OPTIONAL :: last_column - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_c', & routineP = moduleN//':'//routineN @@ -429,17 +423,16 @@ END SUBROUTINE cp_dbcsr_scale_c !> \param alpha ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_set_c (matrix, alpha, error) + SUBROUTINE cp_dbcsr_set_c (matrix, alpha) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix COMPLEX(kind=real_4), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_set_c', & routineP = moduleN//':'//routineN TYPE(dbcsr_error_type) :: dbcsr_error - CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix, error), dbcsr_error) + CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix), dbcsr_error) END SUBROUTINE cp_dbcsr_set_c @@ -451,11 +444,10 @@ END SUBROUTINE cp_dbcsr_set_c !> \param beta_scalar ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_add_c (matrix_a, matrix_b, alpha_scalar, beta_scalar, error) + SUBROUTINE cp_dbcsr_add_c (matrix_a, matrix_b, alpha_scalar, beta_scalar) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_b COMPLEX(kind=real_4), INTENT(IN) :: alpha_scalar, beta_scalar - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_add_c', & routineP = moduleN//':'//routineN diff --git a/src/dbcsrwrap/cp_dbcsr_interface_d.f90 b/src/dbcsrwrap/cp_dbcsr_interface_d.f90 index e94f3659ee..ee32360fb5 100644 --- a/src/dbcsrwrap/cp_dbcsr_interface_d.f90 +++ b/src/dbcsrwrap/cp_dbcsr_interface_d.f90 @@ -11,10 +11,9 @@ !> \param error ... !> \retval encapsulated ... ! ***************************************************************************** - FUNCTION make_conformant_scalar_d (scalar, matrix, error) RESULT (encapsulated) + FUNCTION make_conformant_scalar_d (scalar, matrix) RESULT (encapsulated) REAL(kind=real_8), INTENT(IN) :: scalar TYPE(cp_dbcsr_type), INTENT(IN) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_conformant_scalar_d', & routineP = moduleN//':'//routineN @@ -31,7 +30,7 @@ FUNCTION make_conformant_scalar_d (scalar, matrix, error) RESULT (encapsulated) CALL cp_assert (data_type .EQ. dbcsr_type_complex_4 .OR.& data_type .EQ. dbcsr_type_complex_8,& cp_fatal_level, cp_wrong_args_error, routineN,& - "Can not conform a complex to a real number", error=error) + "Can not conform a complex to a real number") END IF CALL dbcsr_scalar_set_type (encapsulated,data_type) END FUNCTION make_conformant_scalar_d @@ -252,10 +251,9 @@ END SUBROUTINE cp_dbcsr_get_block_p_d !> \param trace ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_a_d (matrix_a, trace, error) + SUBROUTINE cp_dbcsr_trace_a_d (matrix_a, trace) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a REAL(kind=real_8), INTENT(OUT) :: trace - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_a_d', & routineP = moduleN//':'//routineN @@ -280,12 +278,11 @@ END SUBROUTINE cp_dbcsr_trace_a_d !> \param local_sum ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_ab_d (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum, error) + SUBROUTINE cp_dbcsr_trace_ab_d (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a, matrix_b REAL(kind=real_8), INTENT(INOUT) :: trace CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: trans_a, trans_b LOGICAL, INTENT(IN), OPTIONAL :: local_sum - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_ab_d', & routineP = moduleN//':'//routineN @@ -323,7 +320,7 @@ SUBROUTINE cp_dbcsr_multiply_d (transa, transb,& first_row, last_row, first_column, last_column, first_k, last_k,& retain_sparsity, match_matrix_sizes, & filter_eps,& - error, flop) + flop) CHARACTER(LEN=1), INTENT(IN) :: transa, transb REAL(kind=real_8), INTENT(IN) :: alpha TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a, matrix_b @@ -334,7 +331,6 @@ SUBROUTINE cp_dbcsr_multiply_d (transa, transb,& first_k, last_k LOGICAL, INTENT(IN), OPTIONAL :: retain_sparsity, match_matrix_sizes REAL(kind=real_8), INTENT(IN), OPTIONAL :: filter_eps - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER(int_8), INTENT(OUT), OPTIONAL :: flop CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_multiply_d', & @@ -358,12 +354,12 @@ SUBROUTINE cp_dbcsr_multiply_d (transa, transb,& my_match_matrix_sizes=.FALSE. IF(PRESENT(match_matrix_sizes)) my_match_matrix_sizes=match_matrix_sizes IF(my_match_matrix_sizes)THEN - CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b, error) + CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b) ELSE - CALL cp_dbcsr_init(new_a,error=error) - CALL cp_dbcsr_init(new_b,error=error) - CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE., error=error) - CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE., error=error) + CALL cp_dbcsr_init(new_a) + CALL cp_dbcsr_init(new_b) + CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE.) + CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE.) END IF CALL dbcsr_multiply(transa, transb,& @@ -373,8 +369,8 @@ SUBROUTINE cp_dbcsr_multiply_d (transa, transb,& filter_eps=filter_eps,& error=dbcsr_error, flop=flop) - CALL cp_dbcsr_release (new_a, error=error) - CALL cp_dbcsr_release (new_b, error=error) + CALL cp_dbcsr_release (new_a) + CALL cp_dbcsr_release (new_b) END SUBROUTINE cp_dbcsr_multiply_d @@ -386,11 +382,10 @@ END SUBROUTINE cp_dbcsr_multiply_d !> \param side ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_by_vector_d (matrix_a, alpha, side, error) + SUBROUTINE cp_dbcsr_scale_by_vector_d (matrix_a, alpha, side) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a REAL(kind=real_8), DIMENSION(:), INTENT(IN), TARGET :: alpha CHARACTER(LEN=*), INTENT(IN) :: side - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_by_vector_d ', & routineP = moduleN//':'//routineN @@ -408,11 +403,10 @@ END SUBROUTINE cp_dbcsr_scale_by_vector_d !> \param last_column ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_d (matrix_a, alpha_scalar, last_column, error) + SUBROUTINE cp_dbcsr_scale_d (matrix_a, alpha_scalar, last_column) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a REAL(kind=real_8), INTENT(IN) :: alpha_scalar INTEGER, INTENT(IN), OPTIONAL :: last_column - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_d', & routineP = moduleN//':'//routineN @@ -429,17 +423,16 @@ END SUBROUTINE cp_dbcsr_scale_d !> \param alpha ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_set_d (matrix, alpha, error) + SUBROUTINE cp_dbcsr_set_d (matrix, alpha) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix REAL(kind=real_8), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_set_d', & routineP = moduleN//':'//routineN TYPE(dbcsr_error_type) :: dbcsr_error - CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix, error), dbcsr_error) + CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix), dbcsr_error) END SUBROUTINE cp_dbcsr_set_d @@ -451,11 +444,10 @@ END SUBROUTINE cp_dbcsr_set_d !> \param beta_scalar ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_add_d (matrix_a, matrix_b, alpha_scalar, beta_scalar, error) + SUBROUTINE cp_dbcsr_add_d (matrix_a, matrix_b, alpha_scalar, beta_scalar) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_b REAL(kind=real_8), INTENT(IN) :: alpha_scalar, beta_scalar - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_add_d', & routineP = moduleN//':'//routineN diff --git a/src/dbcsrwrap/cp_dbcsr_interface_s.f90 b/src/dbcsrwrap/cp_dbcsr_interface_s.f90 index dc82eb80cb..4539323d72 100644 --- a/src/dbcsrwrap/cp_dbcsr_interface_s.f90 +++ b/src/dbcsrwrap/cp_dbcsr_interface_s.f90 @@ -11,10 +11,9 @@ !> \param error ... !> \retval encapsulated ... ! ***************************************************************************** - FUNCTION make_conformant_scalar_s (scalar, matrix, error) RESULT (encapsulated) + FUNCTION make_conformant_scalar_s (scalar, matrix) RESULT (encapsulated) REAL(kind=real_4), INTENT(IN) :: scalar TYPE(cp_dbcsr_type), INTENT(IN) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_conformant_scalar_s', & routineP = moduleN//':'//routineN @@ -31,7 +30,7 @@ FUNCTION make_conformant_scalar_s (scalar, matrix, error) RESULT (encapsulated) CALL cp_assert (data_type .EQ. dbcsr_type_complex_4 .OR.& data_type .EQ. dbcsr_type_complex_8,& cp_fatal_level, cp_wrong_args_error, routineN,& - "Can not conform a complex to a real number", error=error) + "Can not conform a complex to a real number") END IF CALL dbcsr_scalar_set_type (encapsulated,data_type) END FUNCTION make_conformant_scalar_s @@ -252,10 +251,9 @@ END SUBROUTINE cp_dbcsr_get_block_p_s !> \param trace ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_a_s (matrix_a, trace, error) + SUBROUTINE cp_dbcsr_trace_a_s (matrix_a, trace) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a REAL(kind=real_4), INTENT(OUT) :: trace - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_a_s', & routineP = moduleN//':'//routineN @@ -280,12 +278,11 @@ END SUBROUTINE cp_dbcsr_trace_a_s !> \param local_sum ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_ab_s (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum, error) + SUBROUTINE cp_dbcsr_trace_ab_s (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a, matrix_b REAL(kind=real_4), INTENT(INOUT) :: trace CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: trans_a, trans_b LOGICAL, INTENT(IN), OPTIONAL :: local_sum - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_ab_s', & routineP = moduleN//':'//routineN @@ -323,7 +320,7 @@ SUBROUTINE cp_dbcsr_multiply_s (transa, transb,& first_row, last_row, first_column, last_column, first_k, last_k,& retain_sparsity, match_matrix_sizes, & filter_eps,& - error, flop) + flop) CHARACTER(LEN=1), INTENT(IN) :: transa, transb REAL(kind=real_4), INTENT(IN) :: alpha TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a, matrix_b @@ -334,7 +331,6 @@ SUBROUTINE cp_dbcsr_multiply_s (transa, transb,& first_k, last_k LOGICAL, INTENT(IN), OPTIONAL :: retain_sparsity, match_matrix_sizes REAL(kind=real_8), INTENT(IN), OPTIONAL :: filter_eps - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER(int_8), INTENT(OUT), OPTIONAL :: flop CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_multiply_s', & @@ -358,12 +354,12 @@ SUBROUTINE cp_dbcsr_multiply_s (transa, transb,& my_match_matrix_sizes=.FALSE. IF(PRESENT(match_matrix_sizes)) my_match_matrix_sizes=match_matrix_sizes IF(my_match_matrix_sizes)THEN - CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b, error) + CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b) ELSE - CALL cp_dbcsr_init(new_a,error=error) - CALL cp_dbcsr_init(new_b,error=error) - CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE., error=error) - CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE., error=error) + CALL cp_dbcsr_init(new_a) + CALL cp_dbcsr_init(new_b) + CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE.) + CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE.) END IF CALL dbcsr_multiply(transa, transb,& @@ -373,8 +369,8 @@ SUBROUTINE cp_dbcsr_multiply_s (transa, transb,& filter_eps=filter_eps,& error=dbcsr_error, flop=flop) - CALL cp_dbcsr_release (new_a, error=error) - CALL cp_dbcsr_release (new_b, error=error) + CALL cp_dbcsr_release (new_a) + CALL cp_dbcsr_release (new_b) END SUBROUTINE cp_dbcsr_multiply_s @@ -386,11 +382,10 @@ END SUBROUTINE cp_dbcsr_multiply_s !> \param side ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_by_vector_s (matrix_a, alpha, side, error) + SUBROUTINE cp_dbcsr_scale_by_vector_s (matrix_a, alpha, side) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a REAL(kind=real_4), DIMENSION(:), INTENT(IN), TARGET :: alpha CHARACTER(LEN=*), INTENT(IN) :: side - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_by_vector_s ', & routineP = moduleN//':'//routineN @@ -408,11 +403,10 @@ END SUBROUTINE cp_dbcsr_scale_by_vector_s !> \param last_column ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_s (matrix_a, alpha_scalar, last_column, error) + SUBROUTINE cp_dbcsr_scale_s (matrix_a, alpha_scalar, last_column) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a REAL(kind=real_4), INTENT(IN) :: alpha_scalar INTEGER, INTENT(IN), OPTIONAL :: last_column - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_s', & routineP = moduleN//':'//routineN @@ -429,17 +423,16 @@ END SUBROUTINE cp_dbcsr_scale_s !> \param alpha ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_set_s (matrix, alpha, error) + SUBROUTINE cp_dbcsr_set_s (matrix, alpha) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix REAL(kind=real_4), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_set_s', & routineP = moduleN//':'//routineN TYPE(dbcsr_error_type) :: dbcsr_error - CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix, error), dbcsr_error) + CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix), dbcsr_error) END SUBROUTINE cp_dbcsr_set_s @@ -451,11 +444,10 @@ END SUBROUTINE cp_dbcsr_set_s !> \param beta_scalar ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_add_s (matrix_a, matrix_b, alpha_scalar, beta_scalar, error) + SUBROUTINE cp_dbcsr_add_s (matrix_a, matrix_b, alpha_scalar, beta_scalar) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_b REAL(kind=real_4), INTENT(IN) :: alpha_scalar, beta_scalar - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_add_s', & routineP = moduleN//':'//routineN diff --git a/src/dbcsrwrap/cp_dbcsr_interface_z.f90 b/src/dbcsrwrap/cp_dbcsr_interface_z.f90 index 4a7f8232df..6888c2a886 100644 --- a/src/dbcsrwrap/cp_dbcsr_interface_z.f90 +++ b/src/dbcsrwrap/cp_dbcsr_interface_z.f90 @@ -11,10 +11,9 @@ !> \param error ... !> \retval encapsulated ... ! ***************************************************************************** - FUNCTION make_conformant_scalar_z (scalar, matrix, error) RESULT (encapsulated) + FUNCTION make_conformant_scalar_z (scalar, matrix) RESULT (encapsulated) COMPLEX(kind=real_8), INTENT(IN) :: scalar TYPE(cp_dbcsr_type), INTENT(IN) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_conformant_scalar_z', & routineP = moduleN//':'//routineN @@ -31,7 +30,7 @@ FUNCTION make_conformant_scalar_z (scalar, matrix, error) RESULT (encapsulated) CALL cp_assert (data_type .EQ. dbcsr_type_complex_4 .OR.& data_type .EQ. dbcsr_type_complex_8,& cp_fatal_level, cp_wrong_args_error, routineN,& - "Can not conform a complex to a real number", error=error) + "Can not conform a complex to a real number") END IF CALL dbcsr_scalar_set_type (encapsulated,data_type) END FUNCTION make_conformant_scalar_z @@ -252,10 +251,9 @@ END SUBROUTINE cp_dbcsr_get_block_p_z !> \param trace ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_a_z (matrix_a, trace, error) + SUBROUTINE cp_dbcsr_trace_a_z (matrix_a, trace) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a COMPLEX(kind=real_8), INTENT(OUT) :: trace - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_a_z', & routineP = moduleN//':'//routineN @@ -280,12 +278,11 @@ END SUBROUTINE cp_dbcsr_trace_a_z !> \param local_sum ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_trace_ab_z (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum, error) + SUBROUTINE cp_dbcsr_trace_ab_z (matrix_a, matrix_b, trace, trans_a, trans_b, local_sum) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a, matrix_b COMPLEX(kind=real_8), INTENT(INOUT) :: trace CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: trans_a, trans_b LOGICAL, INTENT(IN), OPTIONAL :: local_sum - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_trace_ab_z', & routineP = moduleN//':'//routineN @@ -323,7 +320,7 @@ SUBROUTINE cp_dbcsr_multiply_z (transa, transb,& first_row, last_row, first_column, last_column, first_k, last_k,& retain_sparsity, match_matrix_sizes, & filter_eps,& - error, flop) + flop) CHARACTER(LEN=1), INTENT(IN) :: transa, transb COMPLEX(kind=real_8), INTENT(IN) :: alpha TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_a, matrix_b @@ -334,7 +331,6 @@ SUBROUTINE cp_dbcsr_multiply_z (transa, transb,& first_k, last_k LOGICAL, INTENT(IN), OPTIONAL :: retain_sparsity, match_matrix_sizes REAL(kind=real_8), INTENT(IN), OPTIONAL :: filter_eps - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER(int_8), INTENT(OUT), OPTIONAL :: flop CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_multiply_z', & @@ -358,12 +354,12 @@ SUBROUTINE cp_dbcsr_multiply_z (transa, transb,& my_match_matrix_sizes=.FALSE. IF(PRESENT(match_matrix_sizes)) my_match_matrix_sizes=match_matrix_sizes IF(my_match_matrix_sizes)THEN - CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b, error) + CALL matrix_match_sizes (matrix_c, matrix_a, transa, matrix_b, transb, new_a, new_b) ELSE - CALL cp_dbcsr_init(new_a,error=error) - CALL cp_dbcsr_init(new_b,error=error) - CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE., error=error) - CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE., error=error) + CALL cp_dbcsr_init(new_a) + CALL cp_dbcsr_init(new_b) + CALL cp_dbcsr_copy (new_a, matrix_a, shallow_data=.TRUE.) + CALL cp_dbcsr_copy (new_b, matrix_b, shallow_data=.TRUE.) END IF CALL dbcsr_multiply(transa, transb,& @@ -373,8 +369,8 @@ SUBROUTINE cp_dbcsr_multiply_z (transa, transb,& filter_eps=filter_eps,& error=dbcsr_error, flop=flop) - CALL cp_dbcsr_release (new_a, error=error) - CALL cp_dbcsr_release (new_b, error=error) + CALL cp_dbcsr_release (new_a) + CALL cp_dbcsr_release (new_b) END SUBROUTINE cp_dbcsr_multiply_z @@ -386,11 +382,10 @@ END SUBROUTINE cp_dbcsr_multiply_z !> \param side ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_by_vector_z (matrix_a, alpha, side, error) + SUBROUTINE cp_dbcsr_scale_by_vector_z (matrix_a, alpha, side) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a COMPLEX(kind=real_8), DIMENSION(:), INTENT(IN), TARGET :: alpha CHARACTER(LEN=*), INTENT(IN) :: side - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_by_vector_z ', & routineP = moduleN//':'//routineN @@ -408,11 +403,10 @@ END SUBROUTINE cp_dbcsr_scale_by_vector_z !> \param last_column ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_scale_z (matrix_a, alpha_scalar, last_column, error) + SUBROUTINE cp_dbcsr_scale_z (matrix_a, alpha_scalar, last_column) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a COMPLEX(kind=real_8), INTENT(IN) :: alpha_scalar INTEGER, INTENT(IN), OPTIONAL :: last_column - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_scale_z', & routineP = moduleN//':'//routineN @@ -429,17 +423,16 @@ END SUBROUTINE cp_dbcsr_scale_z !> \param alpha ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_set_z (matrix, alpha, error) + SUBROUTINE cp_dbcsr_set_z (matrix, alpha) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix COMPLEX(kind=real_8), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_set_z', & routineP = moduleN//':'//routineN TYPE(dbcsr_error_type) :: dbcsr_error - CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix, error), dbcsr_error) + CALL dbcsr_set(matrix%matrix, cp_dbcsr_conform_scalar (alpha, matrix), dbcsr_error) END SUBROUTINE cp_dbcsr_set_z @@ -451,11 +444,10 @@ END SUBROUTINE cp_dbcsr_set_z !> \param beta_scalar ... !> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_add_z (matrix_a, matrix_b, alpha_scalar, beta_scalar, error) + SUBROUTINE cp_dbcsr_add_z (matrix_a, matrix_b, alpha_scalar, beta_scalar) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_a TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_b COMPLEX(kind=real_8), INTENT(IN) :: alpha_scalar, beta_scalar - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_dbcsr_add_z', & routineP = moduleN//':'//routineN diff --git a/src/dft_plus_u.F b/src/dft_plus_u.F index 2b0c6134c2..593be70407 100644 --- a/src/dft_plus_u.F +++ b/src/dft_plus_u.F @@ -90,17 +90,15 @@ MODULE dft_plus_u !> \param[in] qs_env Quickstep environment !> \param[in,out] matrix_h Hamiltonian matrices for each spin !> \param[in,out] matrix_w Energy weighted density matrices for each spin -!> \param[in] error environment !> \date 14.01.2008 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE plus_u(qs_env,matrix_h,matrix_w,error) + SUBROUTINE plus_u(qs_env,matrix_h,matrix_w) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: matrix_h, matrix_w - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'plus_u', & routineP = moduleN//':'//routineN @@ -116,16 +114,15 @@ SUBROUTINE plus_u(qs_env,matrix_h,matrix_w,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) NULLIFY (input, dft_control) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,& input=input,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) CALL cite_reference(Dudarev1997) CALL cite_reference(Dudarev1998) @@ -139,13 +136,12 @@ SUBROUTINE plus_u(qs_env,matrix_h,matrix_w,error) print_level = logger%iter_info%print_level should_output = (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%PLUS_U",error=error),cp_p_file).AND.& + "DFT%PRINT%PLUS_U"),cp_p_file).AND.& (.NOT.PRESENT(matrix_w))) output_unit = cp_print_key_unit_nr(logger,input,"DFT%PRINT%PLUS_U",& extension=".plus_u",& ignore_should_output=should_output,& - log_filename=.FALSE.,& - error=error) + log_filename=.FALSE.) ! Select DFT+U method @@ -155,25 +151,24 @@ SUBROUTINE plus_u(qs_env,matrix_h,matrix_w,error) ! For an orthonormal basis the Lowdin method and the Mulliken method ! are equivalent CALL mulliken(qs_env,orthonormal_basis,matrix_h,& - should_output,output_unit,print_level,error) + should_output,output_unit,print_level) ELSE CALL lowdin(qs_env,matrix_h,matrix_w,& - should_output,output_unit,print_level,error) + should_output,output_unit,print_level) END IF CASE (plus_u_mulliken) CALL mulliken(qs_env,orthonormal_basis,matrix_h,& - should_output,output_unit,print_level,error) + should_output,output_unit,print_level) CASE (plus_u_mulliken_charges) CALL mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& - should_output,output_unit,print_level,error) + should_output,output_unit,print_level) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Invalid DFT+U method requested",only_ionode=.TRUE.) END SELECT CALL cp_print_key_finished_output(output_unit,logger,input,"DFT%PRINT%PLUS_U",& - ignore_should_output=should_output,& - error=error) + ignore_should_output=should_output) CALL timestop(handle) @@ -191,7 +186,6 @@ END SUBROUTINE plus_u !> \param should_output ... !> \param output_unit ... !> \param print_level ... -!> \param[in] error environment !> \date 02.07.2008 !> \par !> \f{eqnarray*}{ @@ -210,14 +204,13 @@ END SUBROUTINE plus_u !> \version 1.0 ! ***************************************************************************** SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& - print_level,error) + print_level) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: matrix_h, matrix_w LOGICAL, INTENT(IN) :: should_output INTEGER, INTENT(IN) :: output_unit, print_level - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lowdin', & routineP = moduleN//':'//routineN @@ -316,18 +309,17 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& rho=rho,& scf_env=scf_env,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(energy),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(energy),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) sm_s => matrix_s(1)%matrix ! Overlap matrix in sparse format - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) ! Density matrices in sparse format + CALL qs_rho_get(rho, rho_ao=matrix_p) ! Density matrices in sparse format energy%dft_plus_u = 0.0_dp @@ -343,17 +335,16 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& ! functions, and atomic kinds CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set, nsgf=nsgf, error=error) + CALL get_qs_kind_set(qs_kind_set, nsgf=nsgf) nkind = SIZE(atomic_kind_set) ALLOCATE (first_sgf_atom(natom),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) first_sgf_atom(:) = 0 CALL get_particle_set(particle_set, qs_kind_set,& - first_sgf=first_sgf_atom,& - error=error) + first_sgf=first_sgf_atom) IF (PRESENT(matrix_h).OR.PRESENT(matrix_w)) THEN just_energy = .FALSE. @@ -364,7 +355,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& ! Retrieve S^(1/2) from the SCF environment fm_s_half => scf_env%s_half - CPPrecondition(ASSOCIATED(fm_s_half),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fm_s_half),cp_failure_level,routineP,failure) ! Try to retrieve (full) work matrices from the SCF environment and reuse ! them, if available @@ -386,36 +377,33 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& para_env=para_env,& context=blacs_env,& nrow_global=nsgf,& - ncol_global=nsgf,& - error=error) + ncol_global=nsgf) IF (.NOT.ASSOCIATED(fm_work1)) THEN CALL cp_fm_create(matrix=fm_work1,& matrix_struct=fmstruct,& - name="FULL WORK MATRIX 1",& - error=error) + name="FULL WORK MATRIX 1") fm_work1_local_alloc = .TRUE. END IF IF (.NOT.ASSOCIATED(fm_work2)) THEN CALL cp_fm_create(matrix=fm_work2,& matrix_struct=fmstruct,& - name="FULL WORK MATRIX 2",& - error=error) + name="FULL WORK MATRIX 2") fm_work2_local_alloc = .TRUE. END IF - CALL cp_fm_struct_release(fmstruct=fmstruct,error=error) + CALL cp_fm_struct_release(fmstruct=fmstruct) END IF ! Create local block diagonal matrices ALLOCATE (sm_q,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(sm_q,error=error) - CALL cp_dbcsr_get_block_diag(sm_s,sm_q,error=error) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(sm_q) + CALL cp_dbcsr_get_block_diag(sm_s,sm_q) ALLOCATE (sm_v,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(sm_v,error=error) - CALL cp_dbcsr_get_block_diag(sm_s,sm_v,error=error) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(sm_v) + CALL cp_dbcsr_get_block_diag(sm_s,sm_v) ! Loop over all spins @@ -437,12 +425,12 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& sm_p => matrix_p(ispin)%matrix ! Density matrix for spin ispin in sparse format - CALL cp_dbcsr_set(sm_q,0.0_dp,error=error) - CALL cp_dbcsr_set(sm_v,0.0_dp,error=error) + CALL cp_dbcsr_set(sm_q,0.0_dp) + CALL cp_dbcsr_set(sm_v,0.0_dp) ! Calculate S^(1/2)*P*S^(1/2) as a full matrix (Lowdin) - CALL cp_dbcsr_sm_fm_multiply(sm_p,fm_s_half,fm_work1,nsgf,error=error) + CALL cp_dbcsr_sm_fm_multiply(sm_p,fm_s_half,fm_work1,nsgf) CALL cp_gemm(transa="N",& transb="N",& m=nsgf,& @@ -452,22 +440,21 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& matrix_a=fm_s_half,& matrix_b=fm_work1,& beta=0.0_dp,& - matrix_c=fm_work2,& - error=error) + matrix_c=fm_work2) IF (debug) THEN CALL cp_dbcsr_write_sparse_matrix(sm_p,4,6,qs_env,para_env,& - output_unit=output_unit,error=error) + output_unit=output_unit) CALL write_fm_with_basis_info(fm_s_half,4,6,qs_env,para_env,& - output_unit=output_unit,error=error) + output_unit=output_unit) CALL write_fm_with_basis_info(fm_work2,4,6,qs_env,para_env,& - output_unit=output_unit,error=error) + output_unit=output_unit) END IF ! debug ! Copy occupation matrix to sparse matrix format, finally we are only ! interested in the diagonal (atomic) blocks, i.e. the previous full ! matrix product is not the most efficient choice, anyway. - CALL copy_fm_to_dbcsr(fm_work2,sm_q,keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(fm_work2,sm_q,keep_sparsity=.TRUE.) ! E[DFT+U] = E[DFT] + E[U] ! = E[DFT] + (U - J)*(Tr(q) - Tr(q*q))/2 @@ -499,7 +486,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& orbitals=orbitals,& eps_scf=eps_scf,& max_scf=max_scf,& - smear=smear, error=error) + smear=smear) ! Check, if the atoms of this atomic kind need a DFT+U correction @@ -513,7 +500,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& IF ((ispin == 1).AND.(u_ramping > 0.0_dp)) THEN IF (qs_env%scf_env%iter_delta <= eps_u_ramping) THEN u_minus_j = MIN(u_minus_j + u_ramping,u_minus_j_target) - CALL set_qs_kind(qs_kind_set(ikind), u_minus_j=u_minus_j,error=error) + CALL set_qs_kind(qs_kind_set(ikind), u_minus_j=u_minus_j) END IF IF (should_output.AND.(output_unit > 0)) THEN WRITE (UNIT=output_unit,FMT="(T3,A,3X,A,F0.3,A)")& @@ -546,7 +533,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& n = nsb*nsbsize ALLOCATE (q_matrix(n,n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_matrix(:,:) = 0.0_dp ! Print headline if requested @@ -554,7 +541,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& IF (should_output.AND.(print_level > low_print_level)) THEN IF (output_unit > 0) THEN ALLOCATE (symbol(nsbsize),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DO m=-lu,lu symbol(lu+m+1) = sgf_symbol(0,lu,m) END DO @@ -568,7 +555,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& ": "//TRIM(atomic_kind_name),& "Atom Shell ",(ADJUSTR(symbol(i)),i=1,nsbsize)," Trace" DEALLOCATE (symbol,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END IF @@ -619,12 +606,12 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& ((qs_env%scf_env%outer_scf%iter_count == 0).AND.& (qs_env%scf_env%iter_count <= max_scf))) THEN ALLOCATE (orb_occ(nsbsize),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ALLOCATE (q_eigval(n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigval(:) = 0.0_dp ALLOCATE (q_eigvec(n,n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigvec(:,:) = 0.0_dp norb = SIZE(orbitals) CALL jacobi(q_matrix,q_eigval,q_eigvec) @@ -658,7 +645,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& iorb = i0 + lu + orbitals(i) orb_occ(lu+orbitals(i)+1) = .TRUE. END IF - CPPostcondition((iorb /= -1000),cp_failure_level,routineP,error,failure) + CPPostcondition((iorb /= -1000),cp_failure_level,routineP,failure) iloc = MAXLOC(q_eigvec(iorb,:)) q_eigval(iloc(1)) = MIN(occ,trq) q_matrix(:,iloc(1)) = q_eigval(iloc(1))*q_eigvec(:,iloc(1)) ! backtransform left @@ -667,11 +654,11 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& END DO q_matrix(:,:) = MATMUL(q_matrix,TRANSPOSE(q_eigvec)) ! backtransform right DEALLOCATE (orb_occ,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigval,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigvec,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END IF ! orbitals associated @@ -701,7 +688,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& col=atom_a,& block=v_block,& found=found) - CPPostcondition(ASSOCIATED(v_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(v_block),cp_failure_level,routineP,failure) i = 0 DO iset=1,nset @@ -737,7 +724,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& CALL mp_sum(q_matrix, para_env%group) IF (output_unit > 0) THEN ALLOCATE (q_work(nsb,nsbsize),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_work(:,:) = 0.0_dp DO isb=1,nsb j = 0 @@ -754,7 +741,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& "Total",(SUM(q_work(:,i)),i=1,nsbsize),SUM(q_work) WRITE (UNIT=output_unit,FMT="(A)") "" DEALLOCATE (q_work,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) IF (debug) THEN ! Print the DFT+U occupation matrix WRITE (UNIT=output_unit,FMT="(T9,70I10)") (i,i=1,n) @@ -763,10 +750,10 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& END DO ! Print the eigenvalues and eigenvectors of the occupation matrix ALLOCATE (q_eigval(n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigval(:) = 0.0_dp ALLOCATE (q_eigvec(n,n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigvec(:,:) = 0.0_dp CALL jacobi(q_matrix,q_eigval,q_eigvec) WRITE (UNIT=output_unit,FMT="(/,T9,70I10)") (i,i=1,n) @@ -776,15 +763,15 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& WRITE (UNIT=output_unit,FMT="(T3,I6,70F10.6)") i,q_eigvec(i,:) END DO DEALLOCATE (q_eigval,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigvec,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF ! debug END IF IF (debug) THEN ! Print the full atomic occupation matrix block ALLOCATE (q_work(nsgf_kind,nsgf_kind),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_work(:,:) = 0.0_dp IF (ASSOCIATED(q_block)) q_work(:,:) = q_block(:,:) CALL mp_sum(q_work, para_env%group) @@ -795,10 +782,10 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& WRITE (UNIT=output_unit,FMT="(T3,I6,200F10.6)") i,q_work(i,:) END DO ALLOCATE (q_eigval(norb),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigval(:) = 0.0_dp ALLOCATE (q_eigvec(norb,norb),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigvec(:,:) = 0.0_dp CALL jacobi(q_work,q_eigval,q_eigvec) WRITE (UNIT=output_unit,FMT="(/,T9,200I10)") (i,i=1,norb) @@ -808,12 +795,12 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& WRITE (UNIT=output_unit,FMT="(T3,I6,200F10.6)") i,q_eigvec(i,:) END DO DEALLOCATE (q_eigval,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigvec,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF DEALLOCATE (q_work,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF ! debug END IF ! should output @@ -821,7 +808,7 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& IF (ALLOCATED(q_matrix)) THEN DEALLOCATE (q_matrix,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END DO ! next atomic kind "ikind" @@ -829,9 +816,9 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& IF (ASSOCIATED(sm_h)) THEN - CALL cp_dbcsr_sm_fm_multiply(sm_v,fm_s_half,fm_work1,nsgf,error=error) - CALL cp_fm_transpose(fm_work1,fm_work2,error=error) - CALL cp_dbcsr_plus_fm_fm_t(sm_h,fm_s_half,fm_work2,nsgf,error=error) + CALL cp_dbcsr_sm_fm_multiply(sm_v,fm_s_half,fm_work1,nsgf) + CALL cp_fm_transpose(fm_work1,fm_work2) + CALL cp_dbcsr_plus_fm_fm_t(sm_h,fm_s_half,fm_work2,nsgf) END IF ! An update of the Hamiltonian matrix is requested @@ -863,16 +850,16 @@ SUBROUTINE lowdin(qs_env,matrix_h,matrix_w,should_output,output_unit,& NULLIFY (fm_s_half) IF (fm_work1_local_alloc) THEN - CALL cp_fm_release(matrix=fm_work1,error=error) + CALL cp_fm_release(matrix=fm_work1) END IF IF (fm_work2_local_alloc) THEN - CALL cp_fm_release(matrix=fm_work2,error=error) + CALL cp_fm_release(matrix=fm_work2) END IF ! Release (local) sparse matrices - CALL cp_dbcsr_deallocate_matrix(sm_q,error=error) - CALL cp_dbcsr_deallocate_matrix(sm_v,error=error) + CALL cp_dbcsr_deallocate_matrix(sm_q) + CALL cp_dbcsr_deallocate_matrix(sm_v) CALL timestop(handle) @@ -891,7 +878,6 @@ END SUBROUTINE lowdin !> \param should_output ... !> \param output_unit ... !> \param print_level ... -!> \param[in] error environment !> \date 03.07.2008 !> \par !> \f{eqnarray*}{ @@ -910,7 +896,7 @@ END SUBROUTINE lowdin !> \version 1.0 ! ***************************************************************************** SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& - output_unit,print_level,error) + output_unit,print_level) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: orthonormal_basis @@ -918,7 +904,6 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& OPTIONAL, POINTER :: matrix_h LOGICAL, INTENT(IN) :: should_output INTEGER, INTENT(IN) :: output_unit, print_level - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mulliken', & routineP = moduleN//':'//routineN @@ -1006,29 +991,27 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& energy=energy,& particle_set=particle_set,& rho=rho,& - para_env=para_env,& - error=error) + para_env=para_env) - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(energy),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(energy),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) IF (orthonormal_basis) THEN NULLIFY (sm_s) ELSE ! Get overlap matrix in sparse format CALL get_qs_env(qs_env=qs_env,& - matrix_s=matrix_s,& - error=error) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) + matrix_s=matrix_s) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) sm_s => matrix_s(1)%matrix END IF ! Get density matrices in sparse format - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao=matrix_p) energy%dft_plus_u = 0.0_dp @@ -1049,7 +1032,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& nkind = SIZE(atomic_kind_set) ALLOCATE (is_plus_u_kind(nkind),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) is_plus_u_kind(:) = .FALSE. IF (PRESENT(matrix_h)) THEN @@ -1075,19 +1058,19 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& IF (.NOT.ASSOCIATED(sm_q)) THEN ALLOCATE (sm_q,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(sm_q,error=error) - CALL cp_dbcsr_get_block_diag(sm_p,sm_q,error=error) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(sm_q) + CALL cp_dbcsr_get_block_diag(sm_p,sm_q) END IF - CALL cp_dbcsr_set(sm_q,0.0_dp,error=error) + CALL cp_dbcsr_set(sm_q,0.0_dp) IF (.NOT.ASSOCIATED(sm_v)) THEN ALLOCATE (sm_v,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(sm_v,error=error) - CALL cp_dbcsr_get_block_diag(sm_p,sm_v,error=error) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(sm_v) + CALL cp_dbcsr_get_block_diag(sm_p,sm_v) END IF - CALL cp_dbcsr_set(sm_v,0.0_dp,error=error) + CALL cp_dbcsr_set(sm_v,0.0_dp) DO iatom=1,natom @@ -1104,7 +1087,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& col=iatom,& block=q_block,& found=found) - CPPostcondition(ASSOCIATED(q_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(q_block),cp_failure_level,routineP,failure) IF (orthonormal_basis) THEN ! S is the unit matrix @@ -1117,7 +1100,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& col=iatom,& block=s_block,& found=found) - CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) ! Exploit that P and S are symmetric DO jsgf=1,SIZE(p_block,2) DO isgf=1,SIZE(p_block,1) @@ -1158,7 +1141,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& orbitals=orbitals,& eps_scf=eps_scf,& max_scf=max_scf,& - smear=smear, error=error) + smear=smear) ! Check, if the atoms of this atomic kind need a DFT+U correction @@ -1171,7 +1154,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& IF ((ispin == 1).AND.(u_ramping > 0.0_dp)) THEN IF (qs_env%scf_env%iter_delta <= eps_u_ramping) THEN u_minus_j = MIN(u_minus_j + u_ramping,u_minus_j_target) - CALL set_qs_kind(qs_kind_set(ikind), u_minus_j=u_minus_j,error=error) + CALL set_qs_kind(qs_kind_set(ikind), u_minus_j=u_minus_j) END IF IF (should_output.AND.(output_unit > 0)) THEN WRITE (UNIT=output_unit,FMT="(T3,A,3X,A,F0.3,A)")& @@ -1206,7 +1189,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& n = nsb*nsbsize ALLOCATE (q_matrix(n,n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_matrix(:,:) = 0.0_dp ! Print headline if requested @@ -1214,7 +1197,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& IF (should_output.AND.(print_level > low_print_level)) THEN IF (output_unit > 0) THEN ALLOCATE (symbol(nsbsize),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DO m=-lu,lu symbol(lu+m+1) = sgf_symbol(0,lu,m) END DO @@ -1228,7 +1211,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& ": "//TRIM(atomic_kind_name),& "Atom Shell ",(ADJUSTR(symbol(i)),i=1,nsbsize)," Trace" DEALLOCATE (symbol,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END IF @@ -1279,12 +1262,12 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& ((qs_env%scf_env%outer_scf%iter_count == 0).AND.& (qs_env%scf_env%iter_count <= max_scf))) THEN ALLOCATE (orb_occ(nsbsize),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ALLOCATE (q_eigval(n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigval(:) = 0.0_dp ALLOCATE (q_eigvec(n,n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigvec(:,:) = 0.0_dp norb = SIZE(orbitals) CALL jacobi(q_matrix,q_eigval,q_eigvec) @@ -1318,7 +1301,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& iorb = i0 + lu + orbitals(i) orb_occ(lu+orbitals(i)+1) = .TRUE. END IF - CPPostcondition((iorb /= -1000),cp_failure_level,routineP,error,failure) + CPPostcondition((iorb /= -1000),cp_failure_level,routineP,failure) iloc = MAXLOC(q_eigvec(iorb,:)) q_eigval(iloc(1)) = MIN(occ,trq) q_matrix(:,iloc(1)) = q_eigval(iloc(1))*q_eigvec(:,iloc(1)) ! backtransform left @@ -1327,11 +1310,11 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& END DO q_matrix(:,:) = MATMUL(q_matrix,TRANSPOSE(q_eigvec)) ! backtransform right DEALLOCATE (orb_occ,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigval,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigvec,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END IF ! orbitals associated @@ -1361,7 +1344,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& col=atom_a,& block=v_block,& found=found) - CPPostcondition(ASSOCIATED(v_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(v_block),cp_failure_level,routineP,failure) i = 0 DO iset=1,nset @@ -1397,7 +1380,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& CALL mp_sum(q_matrix, para_env%group) IF (output_unit > 0) THEN ALLOCATE (q_work(nsb,nsbsize),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_work(:,:) = 0.0_dp DO isb=1,nsb j = 0 @@ -1414,7 +1397,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& "Total",(SUM(q_work(:,i)),i=1,nsbsize),SUM(q_work) WRITE (UNIT=output_unit,FMT="(A)") "" DEALLOCATE (q_work,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) IF (debug) THEN ! Print the DFT+U occupation matrix WRITE (UNIT=output_unit,FMT="(T9,70I10)") (i,i=1,n) @@ -1423,10 +1406,10 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& END DO ! Print the eigenvalues and eigenvectors of the occupation matrix ALLOCATE (q_eigval(n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigval(:) = 0.0_dp ALLOCATE (q_eigvec(n,n),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigvec(:,:) = 0.0_dp CALL jacobi(q_matrix,q_eigval,q_eigvec) WRITE (UNIT=output_unit,FMT="(/,T9,70I10)") (i,i=1,n) @@ -1436,15 +1419,15 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& WRITE (UNIT=output_unit,FMT="(T3,I6,70F10.6)") i,q_eigvec(i,:) END DO DEALLOCATE (q_eigval,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigvec,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF ! debug END IF IF (debug) THEN ! Print the full atomic occupation matrix block ALLOCATE (q_work(nsgf_kind,nsgf_kind),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_work(:,:) = 0.0_dp IF (ASSOCIATED(q_block)) q_work(:,:) = q_block(:,:) CALL mp_sum(q_work, para_env%group) @@ -1455,10 +1438,10 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& WRITE (UNIT=output_unit,FMT="(T3,I6,200F10.6)") i,q_work(i,:) END DO ALLOCATE (q_eigval(norb),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigval(:) = 0.0_dp ALLOCATE (q_eigvec(norb,norb),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) q_eigvec(:,:) = 0.0_dp CALL jacobi(q_work,q_eigval,q_eigvec) WRITE (UNIT=output_unit,FMT="(/,T9,200I10)") (i,i=1,norb) @@ -1468,12 +1451,12 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& WRITE (UNIT=output_unit,FMT="(T3,I6,200F10.6)") i,q_eigvec(i,:) END DO DEALLOCATE (q_eigval,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (q_eigvec,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF DEALLOCATE (q_work,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF ! debug END IF ! should output @@ -1481,7 +1464,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& IF (ALLOCATED(q_matrix)) THEN DEALLOCATE (q_matrix,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END DO ! next atomic kind "ikind" @@ -1517,7 +1500,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& col=atom_a,& block=v_block,& found=found) - CPPostcondition(ASSOCIATED(v_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(v_block),cp_failure_level,routineP,failure) IF (orthonormal_basis) THEN DO isgf=1,SIZE(h_block,1) @@ -1529,7 +1512,7 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& col=atom_a,& block=s_block,& found=found) - CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) DO jsgf=1,SIZE(h_block,2) DO isgf=1,SIZE(h_block,1) h_block(isgf,jsgf) = h_block(isgf,jsgf) + v_block(isgf,jsgf)*s_block(isgf,jsgf) @@ -1556,8 +1539,8 @@ SUBROUTINE mulliken(qs_env,orthonormal_basis,matrix_h,should_output,& "if this warning persists or try a different method!",& only_ionode=.TRUE.) - CALL cp_dbcsr_deallocate_matrix(sm_q,error=error) - CALL cp_dbcsr_deallocate_matrix(sm_v,error=error) + CALL cp_dbcsr_deallocate_matrix(sm_q) + CALL cp_dbcsr_deallocate_matrix(sm_v) CALL timestop(handle) @@ -1578,7 +1561,6 @@ END SUBROUTINE mulliken !> \param should_output ... !> \param output_unit ... !> \param print_level ... -!> \param[in] error environment !> \date 11.01.2008 !> \par !> \f{eqnarray*}{ @@ -1601,7 +1583,7 @@ END SUBROUTINE mulliken !> calls are performed ! ***************************************************************************** SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& - should_output,output_unit,print_level,error) + should_output,output_unit,print_level) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: orthonormal_basis @@ -1609,7 +1591,6 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& OPTIONAL, POINTER :: matrix_h, matrix_w LOGICAL, INTENT(IN) :: should_output INTEGER, INTENT(IN) :: output_unit, print_level - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mulliken_charges', & routineP = moduleN//':'//routineN @@ -1684,29 +1665,27 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& energy=energy,& particle_set=particle_set,& rho=rho,& - para_env=para_env,& - error=error) + para_env=para_env) - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(energy),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(energy),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) IF (orthonormal_basis) THEN NULLIFY (sm_s) ELSE ! Get overlap matrix in sparse format CALL get_qs_env(qs_env=qs_env,& - matrix_s=matrix_s,& - error=error) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) + matrix_s=matrix_s) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) sm_s => matrix_s(1)%matrix END IF ! Get density matrices in sparse format - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao=matrix_p) energy%dft_plus_u = 0.0_dp @@ -1722,25 +1701,24 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& ! functions, and atomic kinds CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set, nsgf=nsgf, error=error) + CALL get_qs_kind_set(qs_kind_set, nsgf=nsgf) nkind = SIZE(atomic_kind_set) ALLOCATE (first_sgf_atom(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) first_sgf_atom(:) = 0 CALL get_particle_set(particle_set, qs_kind_set,& - first_sgf=first_sgf_atom,& - error=error) + first_sgf=first_sgf_atom) ALLOCATE (trps(nsgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) trps(:) = 0.0_dp IF (PRESENT(matrix_h).OR.PRESENT(matrix_w)) THEN ALLOCATE (dEdq(nsgf),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) just_energy = .FALSE. ELSE just_energy = .TRUE. @@ -1797,7 +1775,7 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& col=jatom,& block=s_block,& found=found) - CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) sgf = first_sgf_atom(jatom) DO jsgf=1,SIZE(p_block,2) @@ -1851,7 +1829,7 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& u_minus_j=u_minus_j,& u_minus_j_target=u_minus_j_target,& u_ramping=u_ramping,& - eps_u_ramping=eps_u_ramping, error=error) + eps_u_ramping=eps_u_ramping) ! Check, if this atom needs a DFT+U correction @@ -1864,7 +1842,7 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& IF ((ispin == 1).AND.(u_ramping > 0.0_dp)) THEN IF (qs_env%scf_env%iter_delta <= eps_u_ramping) THEN u_minus_j = MIN(u_minus_j + u_ramping,u_minus_j_target) - CALL set_qs_kind(qs_kind_set(ikind), u_minus_j=u_minus_j,error=error) + CALL set_qs_kind(qs_kind_set(ikind), u_minus_j=u_minus_j) END IF IF (should_output.AND.(output_unit > 0)) THEN WRITE (UNIT=output_unit,FMT="(T3,A,3X,A,F0.3,A)")& @@ -1894,14 +1872,14 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& END DO ALLOCATE (q_ii(nsb,2*lu+1),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ! Print headline if requested IF (should_output.AND.(print_level > low_print_level)) THEN IF (output_unit > 0) THEN ALLOCATE (symbol(2*lu+1),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DO m=-lu,lu symbol(lu+m+1) = sgf_symbol(0,lu,m) END DO @@ -1915,7 +1893,7 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& ": "//TRIM(atomic_kind_name),& "Atom Shell ",(ADJUSTR(symbol(i)),i=1,2*lu+1)," Trace" DEALLOCATE (symbol,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END IF @@ -1985,7 +1963,7 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& IF (ALLOCATED(q_ii)) THEN DEALLOCATE (q_ii,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END DO ! next atomic kind "ikind" @@ -2025,7 +2003,7 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& col=jatom,& block=s_block,& found=found) - CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) ! Consider the symmetric form 1/2*(P*S + S*P) for the calculation @@ -2084,7 +2062,7 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& col=jatom,& block=w_block,& found=found) - CPPostcondition(ASSOCIATED(w_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(w_block),cp_failure_level,routineP,failure) ! Consider the symmetric form 1/2*(P*S + S*P) for the calculation @@ -2135,17 +2113,17 @@ SUBROUTINE mulliken_charges(qs_env,orthonormal_basis,matrix_h,matrix_w,& IF (ALLOCATED(first_sgf_atom)) THEN DEALLOCATE (first_sgf_atom,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ALLOCATED(trps)) THEN DEALLOCATE (trps,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ALLOCATED(dEdq)) THEN DEALLOCATE (dEdq,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF CALL timestop(handle) diff --git a/src/distribution_2d_types.F b/src/distribution_2d_types.F index 908508eb5b..f8a8d68a1e 100644 --- a/src/distribution_2d_types.F +++ b/src/distribution_2d_types.F @@ -90,7 +90,6 @@ MODULE distribution_2d_types !> \param n_local_cols ... !> \param n_row_distribution ... !> \param n_col_distribution ... -!> \param error ... !> \par History !> 09.2003 rewamped [fawzi] !> \author Joost VandeVondele @@ -100,7 +99,7 @@ MODULE distribution_2d_types SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& local_rows_ptr, n_local_rows, & local_cols_ptr, row_distribution_ptr, col_distribution_ptr,& - n_local_cols, n_row_distribution, n_col_distribution, error) + n_local_cols, n_row_distribution, n_col_distribution) TYPE(distribution_2d_type), POINTER :: distribution_2d TYPE(cp_blacs_env_type), POINTER :: blacs_env TYPE(cp_1d_i_p_type), DIMENSION(:), & @@ -116,7 +115,6 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& OPTIONAL :: n_local_cols INTEGER, INTENT(in), OPTIONAL :: n_row_distribution, & n_col_distribution - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_2d_create', & routineP = moduleN//':'//routineN @@ -125,11 +123,11 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(blacs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(distribution_2d),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(blacs_env),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(distribution_2d),cp_failure_level,routineP,failure) ALLOCATE(distribution_2d,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) distribution_2d%ref_count = 1 last_distribution_2d_id=last_distribution_2d_id+1 distribution_2d%id_nr=last_distribution_2d_id @@ -149,7 +147,7 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& IF (ASSOCIATED(distribution_2d%col_distribution)) THEN CALL cp_assert(n_col_distribution<=distribution_2d%n_col_distribution,& cp_assertion_failed,cp_failure_level,routineP,& - "n_col_distribution<=distribution_2d%n_col_distribution",error,failure) + "n_col_distribution<=distribution_2d%n_col_distribution",failure) ! else alloc col_distribution? END IF distribution_2d%n_col_distribution=n_col_distribution @@ -163,7 +161,7 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& IF (ASSOCIATED(distribution_2d%row_distribution)) THEN CALL cp_assert(n_row_distribution<=distribution_2d%n_row_distribution,& cp_failure_level,cp_assertion_failed,routineP,& - "n_row_distribution<=distribution_2d%n_row_distribution",error,failure) + "n_row_distribution<=distribution_2d%n_row_distribution",failure) ! else alloc row_distribution? END IF distribution_2d%n_row_distribution=n_row_distribution @@ -172,13 +170,13 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& IF (PRESENT(local_rows_ptr)) & distribution_2d%local_rows => local_rows_ptr IF (.NOT.ASSOCIATED(distribution_2d%local_rows)) THEN - CPPrecondition(PRESENT(n_local_rows),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(n_local_rows),cp_failure_level,routineP,failure) ALLOCATE(distribution_2d%local_rows(SIZE(n_local_rows)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(distribution_2d%local_rows) ALLOCATE(distribution_2d%local_rows(i)%array(n_local_rows(i)),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) distribution_2d%local_rows(i)%array=-HUGE(0) END DO END IF @@ -187,11 +185,11 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& IF (PRESENT(n_local_rows)) THEN CALL cp_assert(SIZE(distribution_2d%n_local_rows)==SIZE(n_local_rows),& cp_failure_level,cp_assertion_failed,routineP,& - "SIZE(distribution_2d%n_local_rows)==SIZE(n_local_rows)",error,failure) + "SIZE(distribution_2d%n_local_rows)==SIZE(n_local_rows)",failure) DO i=1,SIZE(distribution_2d%n_local_rows) CALL cp_assert(SIZE(distribution_2d%local_rows(i)%array)>=n_local_rows(i),& cp_failure_level,cp_assertion_failed,routineP,& - "SIZE(distribution_2d%local_rows(i)%array)>=n_local_rows(i)",error,failure) + "SIZE(distribution_2d%local_rows(i)%array)>=n_local_rows(i)",failure) distribution_2d%n_local_rows(i) = n_local_rows(i) END DO ELSE @@ -204,13 +202,13 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& IF (PRESENT(local_cols_ptr)) & distribution_2d%local_cols => local_cols_ptr IF (.NOT.ASSOCIATED(distribution_2d%local_cols)) THEN - CPPrecondition(PRESENT(n_local_cols),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(n_local_cols),cp_failure_level,routineP,failure) ALLOCATE(distribution_2d%local_cols(SIZE(n_local_cols)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(distribution_2d%local_cols) ALLOCATE(distribution_2d%local_cols(i)%array(n_local_cols(i)),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) distribution_2d%local_cols(i)%array=-HUGE(0) END DO END IF @@ -219,11 +217,11 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& IF (PRESENT(n_local_cols)) THEN CALL cp_assert(SIZE(distribution_2d%n_local_cols)==SIZE(n_local_cols),& cp_failure_level,cp_assertion_failed,routineP,& - "SIZE(distribution_2d%n_local_cols)==SIZE(n_local_cols)",error,failure) + "SIZE(distribution_2d%n_local_cols)==SIZE(n_local_cols)",failure) DO i=1,SIZE(distribution_2d%n_local_cols) CALL cp_assert(SIZE(distribution_2d%local_cols(i)%array)>=n_local_cols(i),& cp_failure_level,cp_assertion_failed,routineP,& - "SIZE(distribution_2d%local_cols(i)%array)>=n_local_cols(i)",error,failure) + "SIZE(distribution_2d%local_cols(i)%array)>=n_local_cols(i)",failure) distribution_2d%n_local_cols(i) = n_local_cols(i) END DO ELSE @@ -234,19 +232,17 @@ SUBROUTINE distribution_2d_create(distribution_2d, blacs_env,& END IF distribution_2d%blacs_env => blacs_env - CALL cp_blacs_env_retain(distribution_2d%blacs_env,error=error) + CALL cp_blacs_env_retain(distribution_2d%blacs_env) END SUBROUTINE distribution_2d_create ! ***************************************************************************** !> \brief ... !> \param distribution_2d ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** -SUBROUTINE distribution_2d_retain(distribution_2d,error) +SUBROUTINE distribution_2d_retain(distribution_2d) TYPE(distribution_2d_type), POINTER :: distribution_2d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_2d_retain', & routineP = moduleN//':'//routineN @@ -254,19 +250,17 @@ SUBROUTINE distribution_2d_retain(distribution_2d,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(distribution_2d),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(distribution_2d%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(distribution_2d),cp_failure_level,routineP,failure) + CPPreconditionNoFail(distribution_2d%ref_count>0,cp_failure_level,routineP) distribution_2d%ref_count=distribution_2d%ref_count+1 END SUBROUTINE distribution_2d_retain ! ***************************************************************************** !> \brief ... !> \param distribution_2d ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE distribution_2d_release(distribution_2d,error) +SUBROUTINE distribution_2d_release(distribution_2d) TYPE(distribution_2d_type), POINTER :: distribution_2d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_2d_release', & routineP = moduleN//':'//routineN @@ -276,48 +270,48 @@ SUBROUTINE distribution_2d_release(distribution_2d,error) failure=.FALSE. IF (ASSOCIATED(distribution_2d)) THEN - CPPrecondition(distribution_2d%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(distribution_2d%ref_count>0,cp_failure_level,routineP,failure) distribution_2d%ref_count=distribution_2d%ref_count-1 IF (distribution_2d%ref_count == 0 ) THEN - CALL cp_blacs_env_release(distribution_2d%blacs_env,error=error) + CALL cp_blacs_env_release(distribution_2d%blacs_env) IF (ASSOCIATED(distribution_2d%col_distribution)) THEN DEALLOCATE(distribution_2d%col_distribution,stat=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(distribution_2d%row_distribution)) THEN DEALLOCATE(distribution_2d%row_distribution,stat=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF DO i=1,SIZE(distribution_2d%local_rows) DEALLOCATE(distribution_2d%local_rows(i)%array,stat=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END DO DEALLOCATE(distribution_2d%local_rows,stat=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) DO i=1,SIZE(distribution_2d%local_cols) DEALLOCATE(distribution_2d%local_cols(i)%array,stat=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END DO DEALLOCATE(distribution_2d%local_cols,stat=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) IF (ASSOCIATED(distribution_2d%flat_local_rows)) THEN DEALLOCATE(distribution_2d%flat_local_rows,stat=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(distribution_2d%flat_local_cols)) THEN DEALLOCATE(distribution_2d%flat_local_cols,stat=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(distribution_2d%n_local_rows)) THEN DEALLOCATE(distribution_2d%n_local_rows,stat=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(distribution_2d%n_local_cols)) THEN DEALLOCATE(distribution_2d%n_local_cols,stat=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END IF DEALLOCATE(distribution_2d,stat=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) ENDIF ENDIF NULLIFY(distribution_2d) @@ -332,8 +326,6 @@ END SUBROUTINE distribution_2d_release !> logger%para_env%mepos writes), defaults to false. !> \param long_description if a long description should be given, !> defaults to false -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 adapted qs_distribution_2d_create write done by Matthias[fawzi] !> \author Fawzi Mohamed @@ -341,11 +333,10 @@ END SUBROUTINE distribution_2d_release !> to clean up, make safer wrt. grabage in distribution_2d%n_* ! ***************************************************************************** SUBROUTINE distribution_2d_write(distribution_2d, unit_nr, local,& - long_description, error) + long_description) TYPE(distribution_2d_type), POINTER :: distribution_2d INTEGER, INTENT(in) :: unit_nr LOGICAL, INTENT(in), OPTIONAL :: local, long_description - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_2d_write', & routineP = moduleN//':'//routineN @@ -356,7 +347,7 @@ SUBROUTINE distribution_2d_write(distribution_2d, unit_nr, local,& TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_long_description=.FALSE. IF (PRESENT(long_description)) my_long_description=long_description @@ -437,7 +428,7 @@ SUBROUTINE distribution_2d_write(distribution_2d, unit_nr, local,& IF (ASSOCIATED(distribution_2d%local_rows(i)%array)) THEN IF (my_long_description) THEN CALL cp_1d_i_write(array=distribution_2d%local_rows(i)%array, & - unit_nr=unit_nr, error=error) + unit_nr=unit_nr) ELSE WRITE (unit=unit_nr,fmt="(' array(',i6,':',i6,'),')")& LBOUND(distribution_2d%local_rows(i)%array),& @@ -477,7 +468,7 @@ SUBROUTINE distribution_2d_write(distribution_2d, unit_nr, local,& IF (ASSOCIATED(distribution_2d%local_cols(i)%array)) THEN IF (my_long_description) THEN CALL cp_1d_i_write(array=distribution_2d%local_cols(i)%array, & - unit_nr=unit_nr, error=error) + unit_nr=unit_nr) ELSE WRITE (unit=unit_nr,fmt="(' array(',i6,':',i6,'),')")& LBOUND(distribution_2d%local_cols(i)%array),& @@ -495,8 +486,7 @@ SUBROUTINE distribution_2d_write(distribution_2d, unit_nr, local,& IF (ASSOCIATED(distribution_2d%blacs_env)) THEN IF (my_long_description) THEN WRITE (unit=unit_nr,fmt="(' blacs_env=')",advance="no") - CALL cp_blacs_env_write(distribution_2d%blacs_env,unit_nr=unit_nr,& - error=error) + CALL cp_blacs_env_write(distribution_2d%blacs_env,unit_nr=unit_nr) ELSE WRITE (unit=unit_nr,fmt="(' blacs_env=')")& distribution_2d%blacs_env%group @@ -534,10 +524,6 @@ END SUBROUTINE distribution_2d_write !> \param n_flat_local_cols ... !> \param blacs_env ... !> \param id_nr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> see distribution_2d_type attributes for a description of the other -!> arguments !> \par History !> 09.2003 created [fawzi] !> \author Fawzi Mohamed @@ -546,8 +532,7 @@ SUBROUTINE distribution_2d_get(distribution_2d, row_distribution, & col_distribution, n_row_distribution, n_col_distribution,& n_local_rows, n_local_cols, local_rows, local_cols,& flat_local_rows, flat_local_cols, n_flat_local_rows, n_flat_local_cols,& - blacs_env, id_nr,& - error) + blacs_env, id_nr) TYPE(distribution_2d_type), POINTER :: distribution_2d INTEGER, DIMENSION(:, :), OPTIONAL, & POINTER :: row_distribution, & @@ -564,7 +549,6 @@ SUBROUTINE distribution_2d_get(distribution_2d, row_distribution, & TYPE(cp_blacs_env_type), OPTIONAL, & POINTER :: blacs_env INTEGER, INTENT(out), OPTIONAL :: id_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribution_2d_get', & routineP = moduleN//':'//routineN @@ -575,8 +559,8 @@ SUBROUTINE distribution_2d_get(distribution_2d, row_distribution, & LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(distribution_2d),cp_failure_level,routineP,error,failure) - CPPrecondition(distribution_2d%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(distribution_2d),cp_failure_level,routineP,failure) + CPPrecondition(distribution_2d%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(row_distribution)) row_distribution => distribution_2d%row_distribution IF (PRESENT(col_distribution)) col_distribution => distribution_2d%col_distribution IF (PRESENT(n_row_distribution)) n_row_distribution=distribution_2d%n_row_distribution @@ -590,7 +574,7 @@ SUBROUTINE distribution_2d_get(distribution_2d, row_distribution, & ALLOCATE(multiindex(SIZE(distribution_2d%local_rows)),& distribution_2d%flat_local_rows(SUM(distribution_2d%n_local_rows)),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) multiindex=1 DO iblock_atomic=1,SIZE(distribution_2d%flat_local_rows) iblock_min=HUGE(0) @@ -604,13 +588,13 @@ SUBROUTINE distribution_2d_get(distribution_2d, row_distribution, & END IF END IF END DO - CPPostcondition(ikind_min>0,cp_failure_level,routineP,error,failure) + CPPostcondition(ikind_min>0,cp_failure_level,routineP,failure) distribution_2d%flat_local_rows(iblock_atomic)=& distribution_2d%local_rows(ikind_min)%array(multiindex(ikind_min)) multiindex(ikind_min)=multiindex(ikind_min)+1 END DO DEALLOCATE(multiindex, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF flat_local_rows => distribution_2d%flat_local_rows END IF @@ -619,7 +603,7 @@ SUBROUTINE distribution_2d_get(distribution_2d, row_distribution, & ALLOCATE(multiindex(SIZE(distribution_2d%local_cols)),& distribution_2d%flat_local_cols(SUM(distribution_2d%n_local_cols)),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) multiindex=1 DO iblock_atomic=1,SIZE(distribution_2d%flat_local_cols) iblock_min=HUGE(0) @@ -633,13 +617,13 @@ SUBROUTINE distribution_2d_get(distribution_2d, row_distribution, & END IF END IF END DO - CPPostcondition(ikind_min>0,cp_failure_level,routineP,error,failure) + CPPostcondition(ikind_min>0,cp_failure_level,routineP,failure) distribution_2d%flat_local_cols(iblock_atomic)=& distribution_2d%local_cols(ikind_min)%array(multiindex(ikind_min)) multiindex(ikind_min)=multiindex(ikind_min)+1 END DO DEALLOCATE(multiindex, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF flat_local_cols => distribution_2d%flat_local_cols END IF diff --git a/src/distribution_methods.F b/src/distribution_methods.F index 48086a0341..a21d12e649 100644 --- a/src/distribution_methods.F +++ b/src/distribution_methods.F @@ -97,8 +97,6 @@ MODULE distribution_methods !> prev_local_molecules !> \param prev_local_molecules previous distribution of molecules, new one will !> be identical if all the prev_* arguments are present and associated -!> \param error variable to control error logging, stopping, ... -!> see module cp_error_handling !> \par History !> none !> \author MK (Jun. 2003) @@ -108,8 +106,7 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & molecule_kind_set, molecule_set, & local_molecules, force_env_section, & prev_molecule_kind_set, & - prev_local_molecules, & - error) + prev_local_molecules) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -126,7 +123,6 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & OPTIONAL, POINTER :: prev_molecule_kind_set TYPE(distribution_1d_type), OPTIONAL, & POINTER :: prev_local_molecules - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribute_molecules_1d', & routineP = moduleN//':'//routineN @@ -162,7 +158,7 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & ENDIF ENDIF - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() group = logger%para_env%group mype = logger%para_env%mepos + 1 @@ -200,19 +196,19 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & CALL heap_new (bin_heap_count, nbins, heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error creating heap.", error=error) + routineN, "Error creating heap.") CALL heap_fill (bin_heap_count, & (/(bin, bin=1, nbins)/), workload_count , heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error initially filling the heap.", error=error) + routineN, "Error initially filling the heap.") CALL heap_new (bin_heap_fill, nbins, heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error creating heap.", error=error) + routineN, "Error creating heap.") CALL heap_fill (bin_heap_fill, & (/(bin, bin=1, nbins)/), workload_fill , heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error initially filling the heap.", error=error) + routineN, "Error initially filling the heap.") DO imolecule_kind=1, nmolecule_kind @@ -248,13 +244,13 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & ELSE CALL heap_get_first (bin_heap_count, bin, bin_price, found, heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error getting topmost heap element.", error=error) + routineN, "Error getting topmost heap element.") CALL cp_assert (found, cp_fatal_level, cp_internal_error, & - routineN, "No topmost heap element found.", error=error) + routineN, "No topmost heap element found.") ipe = bin CALL cp_assert (bin_price==workload_count(ipe), cp_fatal_level, cp_internal_error, & - routineN, "inconsistent heap", error=error) + routineN, "inconsistent heap") workload_count(ipe) = workload_count(ipe) + nload IF (ipe == mype) THEN @@ -264,7 +260,7 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & bin_price = workload_count(ipe) CALL heap_reset_first (bin_heap_count, bin_price, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error, & - routineN, "Error setting price of top heap element.", error=error) + routineN, "Error setting price of top heap element.") END IF END DO @@ -296,13 +292,13 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & ELSE CALL heap_get_first (bin_heap_fill, bin, bin_price, found, heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error getting topmost heap element.", error=error) + routineN, "Error getting topmost heap element.") CALL cp_assert (found, cp_fatal_level, cp_internal_error, & - routineN, "No topmost heap element found.", error=error) + routineN, "No topmost heap element found.") ipe = bin CALL cp_assert (bin_price==workload_fill(ipe), cp_fatal_level, cp_internal_error, & - routineN, "inconsistent heap", error=error) + routineN, "inconsistent heap") workload_fill(ipe) = workload_fill(ipe) + nload is_local = (ipe == mype) @@ -323,33 +319,33 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & bin_price = workload_fill(ipe) CALL heap_reset_first (bin_heap_fill, bin_price, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error, & - routineN, "Error setting price of top heap element.", error=error) + routineN, "Error setting price of top heap element.") END IF END DO END DO CALL cp_assert (ALL(workload_fill.EQ.workload_count), cp_fatal_level, cp_internal_error, & - routineN, "Inconsistent heaps encountered", error=error) + routineN, "Inconsistent heaps encountered") CALL heap_release (bin_heap_count, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error, & - routineN, "Error releasing heap.", error=error) + routineN, "Error releasing heap.") CALL heap_release (bin_heap_fill, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error, & - routineN, "Error releasing heap.", error=error) + routineN, "Error releasing heap.") ! *** Create the local molecule structure *** CALL distribution_1d_create(local_molecules, & n_el=nmolecule_local, & - para_env=logger%para_env, error=error) + para_env=logger%para_env) ! *** Create the local particle structure *** CALL distribution_1d_create(local_particles, & n_el=nparticle_local, & - para_env=logger%para_env, error=error) + para_env=logger%para_env) ! *** Store the generated local molecule and particle distributions *** @@ -383,10 +379,10 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & ! *** Print distribution, if requested *** IF (BTEST(cp_print_key_should_output(logger%iter_info, & - force_env_section, "PRINT%DISTRIBUTION1D", error=error), cp_p_file)) THEN + force_env_section, "PRINT%DISTRIBUTION1D"), cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger, force_env_section, "PRINT%DISTRIBUTION1D", & - extension=".Log", error=error) + extension=".Log") iw = output_unit IF (output_unit<0) iw = cp_logger_get_default_unit_nr(logger, LOCAL=.TRUE.) @@ -481,7 +477,7 @@ SUBROUTINE distribute_molecules_1d(atomic_kind_set, particle_set, & IF (istat /= 0) CALL stop_memory(routineN, moduleN, __LINE__, "work") CALL cp_print_key_finished_output(output_unit, logger, force_env_section, & - "PRINT%DISTRIBUTION1D", error=error) + "PRINT%DISTRIBUTION1D") END IF ! *** Release work storage *** @@ -532,8 +528,6 @@ END SUBROUTINE distribute_molecules_1d !> \param blacs_env the parallel environement at the basis of the !> distribution !> \param force_env_section ... -!> \param error variable to control error logging, stopping, ... -!> see module cp_error_handling !> \par History !> - local_rows & cols blocksize optimizations (Aug. 2003, MK) !> - cleanup of distribution_2d (Sep. 2003, fawzi) @@ -547,8 +541,7 @@ END SUBROUTINE distribute_molecules_1d ! ***************************************************************************** SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & qs_kind_set, molecule_kind_set, molecule_set, & - distribution_2d, blacs_env, force_env_section, & - error) + distribution_2d, blacs_env, force_env_section) TYPE(cell_type), POINTER :: cell TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -563,7 +556,6 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & TYPE(distribution_2d_type), POINTER :: distribution_2d TYPE(cp_blacs_env_type), POINTER :: blacs_env TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'distribute_molecules_2d', & routineP = moduleN//':'//routineN @@ -599,17 +591,17 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & CALL timeset(routineN, handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - distribution_section => section_vals_get_subs_vals(force_env_section, "DFT%QS%DISTRIBUTION", error=error) + distribution_section => section_vals_get_subs_vals(force_env_section, "DFT%QS%DISTRIBUTION") - CALL section_vals_val_get(distribution_section, "2D_MOLECULAR_DISTRIBUTION", l_val=molecular_distribution, error=error) - CALL section_vals_val_get(distribution_section, "SKIP_OPTIMIZATION", l_val=skip_optimization, error=error) - CALL section_vals_val_get(distribution_section, "BASIC_OPTIMIZATION", l_val=basic_optimization, error=error) - CALL section_vals_val_get(distribution_section, "BASIC_SPATIAL_OPTIMIZATION", l_val=basic_spatial_optimization, error=error) - CALL section_vals_val_get(distribution_section, "BASIC_CLUSTER_OPTIMIZATION", l_val=basic_cluster_optimization, error=error) + CALL section_vals_val_get(distribution_section, "2D_MOLECULAR_DISTRIBUTION", l_val=molecular_distribution) + CALL section_vals_val_get(distribution_section, "SKIP_OPTIMIZATION", l_val=skip_optimization) + CALL section_vals_val_get(distribution_section, "BASIC_OPTIMIZATION", l_val=basic_optimization) + CALL section_vals_val_get(distribution_section, "BASIC_SPATIAL_OPTIMIZATION", l_val=basic_spatial_optimization) + CALL section_vals_val_get(distribution_section, "BASIC_CLUSTER_OPTIMIZATION", l_val=basic_cluster_optimization) - CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model, error=error) + CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model) ! group = blacs_env%para_env%group @@ -683,23 +675,23 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & ! Fill in the clusters and their prices - CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model, error=error) + CALL section_vals_val_get(distribution_section, "COST_MODEL", i_val=cost_model) IF (.NOT.molecular_distribution) THEN DO iatom = 1, natom CALL cp_assert (iatom .LE. nclusters, cp_fatal_level, & - cp_internal_error, routineN, "Bounds error", error=error) + cp_internal_error, routineN, "Bounds error") CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) cluster_list(iatom) = iatom SELECT CASE (cost_model) CASE (model_block_count) - CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, error=error) + CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf) cluster_price = nsgf CASE (model_block_lmax) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(orb_basis_set, lmax=lmax_basis) cluster_price = MAXVAL (lmax_basis) CASE default - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(orb_basis_set, lmax=lmax_basis) cluster_price = 8 + (MAXVAL (lmax_basis)**2) END SELECT @@ -719,14 +711,14 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) SELECT CASE (cost_model) CASE (model_block_count) - CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, error=error) + CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf) cluster_price = cluster_price + nsgf CASE (model_block_lmax) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(orb_basis_set, lmax=lmax_basis) cluster_price = cluster_price + MAXVAL (lmax_basis) CASE default - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(orb_basis_set, lmax=lmax_basis) cluster_price = cluster_price + 8 + (MAXVAL (lmax_basis)**2) END SELECT @@ -739,18 +731,18 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & ! And distribute IF (basic_optimization) THEN CALL make_basic_distribution (cluster_list, cluster_prices, & - nprow, cluster_row_distribution(:,1), npcol, cluster_col_distribution(:,1), error=error) + nprow, cluster_row_distribution(:,1), npcol, cluster_col_distribution(:,1)) ELSE IF(basic_cluster_optimization)THEN CALL cp_assert(.NOT. molecular_distribution,cp_failure_level,cp_assertion_failed,& - routineP,"clustering and molecular blocking NYI",error,failure) + routineP,"clustering and molecular blocking NYI",failure) ALLOCATE(pbc_scaled_coords(3, natom),coords(3, natom)) DO iatom=1, natom CALL real_to_scaled(pbc_scaled_coords(:, iatom), pbc(particle_set(iatom)%r(:), cell), cell) coords(:,iatom)=pbc(particle_set(iatom)%r(:),cell) ENDDO CALL make_cluster_distribution(coords, pbc_scaled_coords, cell, cluster_prices,& - nprow, cluster_row_distribution, npcol, cluster_col_distribution, error) + nprow, cluster_row_distribution, npcol, cluster_col_distribution) ELSE! basic_spatial_optimization ALLOCATE(pbc_scaled_coords(3, nclusters)) IF (.NOT. molecular_distribution) THEN @@ -780,7 +772,7 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & ENDIF CALL make_basic_spatial_distribution (pbc_scaled_coords, cluster_prices, & - nprow, cluster_row_distribution(:,1), npcol, cluster_col_distribution(:,1), error) + nprow, cluster_row_distribution(:,1), npcol, cluster_col_distribution(:,1)) DEALLOCATE(pbc_scaled_coords) END IF @@ -822,7 +814,7 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & ELSE ! expects nothing else - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) ENDIF @@ -873,8 +865,7 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & col_distribution_ptr=col_distribution, & local_rows_ptr=local_particle_row, & local_cols_ptr=local_particle_col, & - blacs_env=blacs_env, & - error=error) + blacs_env=blacs_env) NULLIFY (local_particle_row) NULLIFY (local_particle_col) @@ -883,10 +874,10 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & ! *** Print distribution, if requested *** IF (BTEST(cp_print_key_should_output(logger%iter_info, & - force_env_section, "PRINT%DISTRIBUTION", error=error), cp_p_file)) THEN + force_env_section, "PRINT%DISTRIBUTION"), cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger, force_env_section, "PRINT%DISTRIBUTION", & - extension=".Log", error=error) + extension=".Log") ! *** Print row distribution *** @@ -947,18 +938,17 @@ SUBROUTINE distribute_molecules_2d(cell, atomic_kind_set, particle_set, & END IF CALL cp_print_key_finished_output(output_unit, logger, force_env_section, & - "PRINT%DISTRIBUTION", error=error) + "PRINT%DISTRIBUTION") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - force_env_section, "PRINT%DISTRIBUTION2D", error=error), cp_p_file)) THEN + force_env_section, "PRINT%DISTRIBUTION2D"), cp_p_file)) THEN iw = cp_logger_get_default_unit_nr(logger, LOCAL=.TRUE.) CALL distribution_2d_write(distribution_2d, & unit_nr=iw, & local=.TRUE., & - long_description=.TRUE., & - error=error) + long_description=.TRUE.) ENDIF @@ -984,18 +974,16 @@ END SUBROUTINE distribute_molecules_2d !> \param row_distribution ... !> \param npcols ... !> \param col_distribution ... -!> \param error ... !> \par History !> - Created 2010-08-06 UB ! ***************************************************************************** SUBROUTINE make_basic_distribution (cluster_list, cluster_prices, & - nprows, row_distribution, npcols, col_distribution, error) + nprows, row_distribution, npcols, col_distribution) INTEGER, DIMENSION(:), INTENT(INOUT) :: cluster_list, cluster_prices INTEGER, INTENT(IN) :: nprows INTEGER, DIMENSION(:), INTENT(OUT) :: row_distribution INTEGER, INTENT(IN) :: npcols INTEGER, DIMENSION(:), INTENT(OUT) :: col_distribution - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_basic_distribution', & routineP = moduleN//':'//routineN @@ -1013,11 +1001,11 @@ SUBROUTINE make_basic_distribution (cluster_list, cluster_prices, & CALL sort (cluster_prices, SIZE(cluster_list), cluster_list) CALL heap_new (bin_heap, nbins, heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error creating heap.", error=error) + routineN, "Error creating heap.") CALL heap_fill (bin_heap, & (/(bin, bin=0, nbins-1)/), (/(0, bin=1, nbins)/), heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error initially filling the heap.", error=error) + routineN, "Error initially filling the heap.") ! nclusters = SIZE (cluster_list) ! Put the most expensive cluster in the bin with the smallest @@ -1026,18 +1014,18 @@ SUBROUTINE make_basic_distribution (cluster_list, cluster_prices, & cluster = cluster_list(cluster_index) CALL heap_get_first (bin_heap, bin, bin_price, found, heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error, & - routineN, "Error getting topmost heap element.", error=error) + routineN, "Error getting topmost heap element.") CALL cp_assert (found, cp_fatal_level, cp_internal_error, & - routineN, "No topmost heap element found.", error=error) + routineN, "No topmost heap element found.") ! failure = .FALSE. prow = INT (bin*pgrid_gcd / npcols) CALL cp_assert (prow .LT. nprows, cp_fatal_level, cp_internal_error, & - routineN, "Invalid process row.", failure=failure, error=error) + routineN, "Invalid process row.", failure=failure) failure = .TRUE. pcol = INT (bin*pgrid_gcd / nprows) CALL cp_assert (pcol .LT. npcols, cp_fatal_level, cp_internal_error, & - routineN, "Invalid process column.", failure=failure, error=error) + routineN, "Invalid process column.", failure=failure) row_distribution (cluster) = prow + 1 col_distribution (cluster) = pcol + 1 ! @@ -1045,11 +1033,11 @@ SUBROUTINE make_basic_distribution (cluster_list, cluster_prices, & bin_price = bin_price + cluster_price CALL heap_reset_first (bin_heap, bin_price, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error, & - routineN, "Error setting price of top heap element.", error=error) + routineN, "Error setting price of top heap element.") ENDDO CALL heap_release (bin_heap, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error, & - routineN, "Error releasing heap.", error=error) + routineN, "Error releasing heap.") CALL timestop (timing_handle) END SUBROUTINE make_basic_distribution @@ -1062,12 +1050,11 @@ END SUBROUTINE make_basic_distribution !> \param row_distribution ... !> \param npcols ... !> \param col_distribution ... -!> \param error ... !> \par History !> - Created 2010-11-11 Joost VandeVondele ! ***************************************************************************** SUBROUTINE make_basic_spatial_distribution (pbc_scaled_coords, costs, & - nprows, row_distribution, npcols, col_distribution, error) + nprows, row_distribution, npcols, col_distribution) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: pbc_scaled_coords INTEGER, DIMENSION(:), INTENT(IN) :: costs @@ -1075,7 +1062,6 @@ SUBROUTINE make_basic_spatial_distribution (pbc_scaled_coords, costs, & INTEGER, DIMENSION(:), INTENT(OUT) :: row_distribution INTEGER, INTENT(IN) :: npcols INTEGER, DIMENSION(:), INTENT(OUT) :: col_distribution - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'make_basic_spatial_distribution', & @@ -1183,10 +1169,9 @@ END SUBROUTINE spatial_recurse !> \param row_distribution the resulting distribution over proc_rows of atomic blocks !> \param npcols number of precessors per col on the 2d grid !> \param col_distribution the resulting distribution over proc_cols of atomic blocks -!> \param error ... ! ***************************************************************************** SUBROUTINE make_cluster_distribution(coords, scaled_coords, cell, costs, & - nprows, row_distribution, npcols, col_distribution, error) + nprows, row_distribution, npcols, col_distribution) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: coords, scaled_coords TYPE(cell_type), POINTER :: cell @@ -1195,7 +1180,6 @@ SUBROUTINE make_cluster_distribution(coords, scaled_coords, cell, costs, & INTEGER, DIMENSION(:, :), INTENT(OUT) :: row_distribution INTEGER, INTENT(IN) :: npcols INTEGER, DIMENSION(:, :), INTENT(OUT) :: col_distribution - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_cluster_distribution', & routineP = moduleN//':'//routineN @@ -1216,7 +1200,7 @@ SUBROUTINE make_cluster_distribution(coords, scaled_coords, cell, costs, & ALLOCATE(piv_cost(ncluster)) icluster=0 - CALL cluster_recurse(coords, scaled_coords, cell, costs, atom_to_cluster, ncluster, icluster, cluster_cost, error) + CALL cluster_recurse(coords, scaled_coords, cell, costs, atom_to_cluster, ncluster, icluster, cluster_cost) sorted_cost(:)=cluster_cost(:) CALL sort(sorted_cost,ncluster,piv_cost) @@ -1288,9 +1272,8 @@ END SUBROUTINE assign_clusters !> \param ncluster number of clusters still to be created on a given recursion level !> \param icluster the index of the current cluster to be created !> \param fin_cluster_cost total cost of the final clusters -!> \param error ... ! ***************************************************************************** - RECURSIVE SUBROUTINE cluster_recurse(coord, scaled_coord, cell, costs, cluster_inds, ncluster, icluster, fin_cluster_cost, error) + RECURSIVE SUBROUTINE cluster_recurse(coord, scaled_coord, cell, costs, cluster_inds, ncluster, icluster, fin_cluster_cost) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: coord, scaled_coord TYPE(cell_type), POINTER :: cell @@ -1298,7 +1281,6 @@ RECURSIVE SUBROUTINE cluster_recurse(coord, scaled_coord, cell, costs, cluster_i INTEGER, DIMENSION(:), INTENT(INOUT) :: cluster_inds INTEGER, INTENT(INOUT) :: ncluster, icluster INTEGER, DIMENSION(:), INTENT(INOUT) :: fin_cluster_cost - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cluster_recurse', & routineP = moduleN//':'//routineN @@ -1327,7 +1309,7 @@ RECURSIVE SUBROUTINE cluster_recurse(coord, scaled_coord, cell, costs, cluster_i ALLOCATE(cluster_cost(nsplits), ncluster_new(nsplits), inds_tmp(natoms), piv(natoms), nat_cluster(nsplits)) ! initialise some values cluster_cost=0; seed=300; found=.TRUE. ; min_seed=seed - CALL kmeans(nsplits, coord, scaled_coord, cell, cluster_inds, nat_cluster, seed, conv, error) + CALL kmeans(nsplits, coord, scaled_coord, cell, cluster_inds, nat_cluster, seed, conv) balance=MAXVAL(REAL(nat_cluster))/MINVAL(REAL(nat_cluster)) ! If the system is small enough try to do better in terms of balancing number of atoms per cluster @@ -1336,7 +1318,7 @@ RECURSIVE SUBROUTINE cluster_recurse(coord, scaled_coord, cell, costs, cluster_i found=.FALSE. DO i=1, 5 IF(balance.gt.1.1)THEN - CALL kmeans(nsplits, coord, scaled_coord, cell, cluster_inds, nat_cluster, seed+i*40, conv, error) + CALL kmeans(nsplits, coord, scaled_coord, cell, cluster_inds, nat_cluster, seed+i*40, conv) balance_new=MAXVAL(REAL(nat_cluster))/MINVAL(REAL(nat_cluster)) IF(balance_new.LT.balance)THEN balance=balance_new @@ -1349,7 +1331,7 @@ RECURSIVE SUBROUTINE cluster_recurse(coord, scaled_coord, cell, costs, cluster_i END DO END IF !If we do not match the convergence than recompute at least the best assignment - IF(.NOT.found)CALL kmeans(nsplits, coord, scaled_coord, cell, cluster_inds, nat_cluster, min_seed, conv, error) + IF(.NOT.found)CALL kmeans(nsplits, coord, scaled_coord, cell, cluster_inds, nat_cluster, min_seed, conv) ! compute the cost of each cluster to decide how many splits have to be performed on the next lower level DO i=1, natoms @@ -1394,7 +1376,7 @@ RECURSIVE SUBROUTINE cluster_recurse(coord, scaled_coord, cell, costs, cluster_i IF(nat_cluster(i)==0)CYCLE iend=iend+nat_cluster(i) CALL cluster_recurse(coord(:, piv(ibeg:iend)), scaled_coord(:, piv(ibeg:iend)), cell, costs(piv(ibeg:iend)),& - inds_tmp(ibeg:iend), ncluster_new(i), icluster, fin_cluster_cost, error) + inds_tmp(ibeg:iend), ncluster_new(i), icluster, fin_cluster_cost) ibeg=ibeg+nat_cluster(i) END DO ! copy the sorted cluster IDs on the old layout, inds_tmp gets set at the lowest level of recursion @@ -1419,16 +1401,14 @@ END SUBROUTINE cluster_recurse !> \param nat_cl atoms per cluster !> \param seed seed for the RNG. Algorithm might need multiple tries to deliver best results !> \param tot_var the total variance of the clusters around the centers -!> \param error ... ! ***************************************************************************** - SUBROUTINE kmeans(ncent,coord,scaled_coord,cell,cluster,nat_cl,seed,tot_var,error) + SUBROUTINE kmeans(ncent,coord,scaled_coord,cell,cluster,nat_cl,seed,tot_var) INTEGER :: ncent REAL(KIND=dp), DIMENSION(:, :) :: coord, scaled_coord TYPE(cell_type), POINTER :: cell INTEGER, DIMENSION(:) :: cluster, nat_cl INTEGER :: seed REAL(KIND=dp) :: tot_var - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: i, ind, itn, j, nat, oldc LOGICAL :: changed @@ -1447,15 +1427,15 @@ SUBROUTINE kmeans(ncent,coord,scaled_coord,cell,cluster,nat_cl,seed,tot_var,erro CALL create_rng_stream(rng_stream=rng_stream,& name="kmeans uniform distribution [0,1]",& - distribution_type=UNIFORM,seed=initial_seed,error=error) + distribution_type=UNIFORM,seed=initial_seed) ! try to find a clever initial guess with centers being somewhat distributed - rn=next_random_number(rng_stream,error=error) + rn=next_random_number(rng_stream) ind=CEILING(rn*nat) cent_coord(:,1)=coord(:,ind) DO i=2,ncent DO - rn=next_random_number(rng_stream,error=error) + rn=next_random_number(rng_stream) ind=CEILING(rn*nat) cent_coord(:,i)=coord(:,ind) devi=HUGE(1.0_dp) @@ -1464,7 +1444,7 @@ SUBROUTINE kmeans(ncent,coord,scaled_coord,cell,cluster,nat_cl,seed,tot_var,erro dist=SQRT(DOT_PRODUCT(dvec,dvec)) IF(dist.LT.devi)devi=dist END DO - rn=next_random_number(rng_stream,error=error) + rn=next_random_number(rng_stream) IF(rn.lt.devi**2/169.0)EXIT END DO END DO @@ -1508,7 +1488,7 @@ SUBROUTINE kmeans(ncent,coord,scaled_coord,cell,cluster,nat_cl,seed,tot_var,erro DO i=1,ncent IF(nat_cl(i)==0)THEN - rn=next_random_number(rng_stream,error=error) + rn=next_random_number(rng_stream) scaled_cent(:,i)=scaled_coord(:,CEILING(rn*nat)) ELSE average(:,i,1)=average(:,i,1)/REAL(nat_cl(i),dp) @@ -1522,7 +1502,7 @@ SUBROUTINE kmeans(ncent,coord,scaled_coord,cell,cluster,nat_cl,seed,tot_var,erro END IF END DO - CALL delete_rng_stream(rng_stream,error=error) + CALL delete_rng_stream(rng_stream) END SUBROUTINE kmeans diff --git a/src/dkh_main.F b/src/dkh_main.F index eec89dda01..02a67431e6 100644 --- a/src/dkh_main.F +++ b/src/dkh_main.F @@ -52,7 +52,6 @@ MODULE dkh_main !> \param matrix_pVp ... !> \param n ... !> \param dkh_order ... -!> \param error ... !> \par Literature !> M. Reiher, A. Wolf, J. Chem. Phys. 121 (2004) 10944-10956 !> A. Wolf, M. Reiher, B. A. Hess, J. Chem. Phys. 117 (2002) 9215-9226 @@ -100,12 +99,11 @@ MODULE dkh_main !> Markus Reiher: ETH Zurich (09/2006) !> ! ***************************************************************************** - SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp,n,dkh_order,error) + SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp,n,dkh_order) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_fm_type), POINTER :: matrix_s, matrix_v, matrix_t, & matrix_pVp INTEGER, INTENT(IN) :: n, dkh_order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'DKH_full_transformation', & routineP = moduleN//':'//routineN @@ -131,12 +129,11 @@ SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp !----------------------------------------------------------------------- ! Construct the matrix structure !----------------------------------------------------------------------- - CALL get_qs_env(qs_env, blacs_env=blacs_env, error=error) + CALL get_qs_env(qs_env, blacs_env=blacs_env) CALL cp_fm_struct_create( fmstruct = matrix_full,& context = blacs_env,& nrow_global = n,& - ncol_global = n,& - error = error) + ncol_global = n) !----------------------------------------------------------------------- ! Allocate some matrices @@ -160,32 +157,32 @@ SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp NULLIFY(matrix_sinv) NULLIFY(matrix_pe1p) - CALL cp_fm_create(matrix_eig, matrix_full, error=error) - CALL cp_fm_create(matrix_aux, matrix_full, error=error) - CALL cp_fm_create(matrix_aux2, matrix_full, error=error) - CALL cp_fm_create(matrix_rev, matrix_full, error=error) - CALL cp_fm_create(matrix_se, matrix_full, error=error) - CALL cp_fm_create(matrix_ev1, matrix_full, error=error) - CALL cp_fm_create(matrix_ev2, matrix_full, error=error) - CALL cp_fm_create(matrix_sinv, matrix_full, error=error) - CALL cp_fm_create(matrix_ev3, matrix_full, error=error) - CALL cp_fm_create(matrix_ev4, matrix_full, error=error) - CALL cp_fm_create(matrix_pe1p, matrix_full, error=error) + CALL cp_fm_create(matrix_eig, matrix_full) + CALL cp_fm_create(matrix_aux, matrix_full) + CALL cp_fm_create(matrix_aux2, matrix_full) + CALL cp_fm_create(matrix_rev, matrix_full) + CALL cp_fm_create(matrix_se, matrix_full) + CALL cp_fm_create(matrix_ev1, matrix_full) + CALL cp_fm_create(matrix_ev2, matrix_full) + CALL cp_fm_create(matrix_sinv, matrix_full) + CALL cp_fm_create(matrix_ev3, matrix_full) + CALL cp_fm_create(matrix_ev4, matrix_full) + CALL cp_fm_create(matrix_pe1p, matrix_full) !----------------------------------------------------------------------- ! Now with Cholesky decomposition !----------------------------------------------------------------------- - CALL cp_fm_to_fm(matrix_s,matrix_sinv,error) - CALL cp_fm_cholesky_decompose(matrix_sinv,n,error=error) + CALL cp_fm_to_fm(matrix_s,matrix_sinv) + CALL cp_fm_cholesky_decompose(matrix_sinv,n) !----------------------------------------------------------------------- ! Calculate matrix representation from nonrelativistic T matrix !----------------------------------------------------------------------- - CALL cp_fm_cholesky_reduce(matrix_t,matrix_sinv,error=error) - CALL cp_fm_syevd(matrix_t,matrix_eig,tt,error=error) + CALL cp_fm_cholesky_reduce(matrix_t,matrix_sinv) + CALL cp_fm_syevd(matrix_t,matrix_eig,tt) !----------------------------------------------------------------------- ! Calculate kinetic part of Hamiltonian in T-basis @@ -197,16 +194,16 @@ SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp ! Calculate reverse transformation matrix revt !----------------------------------------------------------------------- - CALL cp_fm_to_fm(matrix_eig,matrix_rev,error) - CALL cp_fm_triangular_multiply(matrix_sinv,matrix_rev,transpose_tr=.TRUE.,error=error) + CALL cp_fm_to_fm(matrix_eig,matrix_rev) + CALL cp_fm_triangular_multiply(matrix_sinv,matrix_rev,transpose_tr=.TRUE.) !----------------------------------------------------------------------- ! Calculate kinetic part of the Hamiltonian !----------------------------------------------------------------------- - CALL cp_fm_to_fm(matrix_rev,matrix_aux,error) + CALL cp_fm_to_fm(matrix_rev,matrix_aux) CALL cp_fm_column_scale(matrix_aux,ev0t) - CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_rev,matrix_aux,0.0_dp,matrix_t,error) + CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_rev,matrix_aux,0.0_dp,matrix_t) !----------------------------------------------------------------------- ! Calculate kinematical factors for DKH @@ -222,46 +219,46 @@ SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp ! Transform v integrals to T-basis (v -> v(t)) !----------------------------------------------------------------------- - CALL cp_fm_cholesky_reduce(matrix_v,matrix_sinv,error=error) - CALL cp_fm_upper_to_full(matrix_v,matrix_aux,error) - CALL cp_gemm("T","N",n,n,n,1.0_dp,matrix_eig,matrix_v,0.0_dp,matrix_aux,error) - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_aux,matrix_eig,0.0_dp,matrix_v,error) + CALL cp_fm_cholesky_reduce(matrix_v,matrix_sinv) + CALL cp_fm_upper_to_full(matrix_v,matrix_aux) + CALL cp_gemm("T","N",n,n,n,1.0_dp,matrix_eig,matrix_v,0.0_dp,matrix_aux) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_aux,matrix_eig,0.0_dp,matrix_v) !----------------------------------------------------------------------- ! Transform pVp integrals to T-basis (pVp -> pVp(t)) !----------------------------------------------------------------------- - CALL cp_fm_cholesky_reduce(matrix_pVp,matrix_sinv,error=error) - CALL cp_fm_upper_to_full(matrix_pVp,matrix_aux,error) - CALL cp_gemm("T","N",n,n,n,1.0_dp,matrix_eig,matrix_pVp,0.0_dp,matrix_aux,error) - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_aux,matrix_eig,0.0_dp,matrix_pVp,error) + CALL cp_fm_cholesky_reduce(matrix_pVp,matrix_sinv) + CALL cp_fm_upper_to_full(matrix_pVp,matrix_aux) + CALL cp_gemm("T","N",n,n,n,1.0_dp,matrix_eig,matrix_pVp,0.0_dp,matrix_aux) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_aux,matrix_eig,0.0_dp,matrix_pVp) !----------------------------------------------------------------------- ! Calculate even1 in T-basis !----------------------------------------------------------------------- - CALL even1(matrix_ev1,matrix_v,matrix_pvp,aa,rr,matrix_aux,matrix_aux2,error) + CALL even1(matrix_ev1,matrix_v,matrix_pvp,aa,rr,matrix_aux,matrix_aux2) !----------------------------------------------------------------------- ! Calculate even2 in T-basis !----------------------------------------------------------------------- - CALL even2c (n,matrix_ev2,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux,error) + CALL even2c (n,matrix_ev2,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux) !----------------------------------------------------------------------- ! Calculate even3 in T-basis, only if requested !----------------------------------------------------------------------- IF (dkh_order.ge.3) THEN - CALL peven1p(n,matrix_pe1p,matrix_v,matrix_pvp,matrix_aux,matrix_aux2,aa,rr,tt,error) - CALL even3b(n,matrix_ev3,matrix_ev1,matrix_pe1p,matrix_v,matrix_pvp,aa,rr,tt,e,matrix_aux,error) + CALL peven1p(n,matrix_pe1p,matrix_v,matrix_pvp,matrix_aux,matrix_aux2,aa,rr,tt) + CALL even3b(n,matrix_ev3,matrix_ev1,matrix_pe1p,matrix_v,matrix_pvp,aa,rr,tt,e,matrix_aux) !----------------------------------------------------------------------- ! Transform even3 back to position space !----------------------------------------------------------------------- - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev3,0.0_dp,matrix_aux,error) - CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev3,error) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev3,0.0_dp,matrix_aux) + CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev3) !----------------------------------------------------------------------- ! Calculate even4 in T-basis, only if requested @@ -270,7 +267,7 @@ SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp IF (dkh_order.ge.4) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="DKH order greater than 3 not yet available", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ! CALL even4a(n,matrix_ev4%local_data,matrix_ev2%local_data,matrix_pe1p%local_data,matrix_v%local_data,& ! matrix_pvp%local_data,aa,rr,tt,e) @@ -278,8 +275,8 @@ SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp ! Transform even4 back to position space !----------------------------------------------------------------------- - ! CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev4,0.0_dp,matrix_aux,error) - ! CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev4,error) + ! CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev4,0.0_dp,matrix_aux) + ! CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev4) END IF END IF @@ -288,46 +285,46 @@ SUBROUTINE DKH_full_transformation (qs_env,matrix_s,matrix_v,matrix_t,matrix_pVp ! Transform even1 back to position space !---------------------------------------------------------------------- - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev1,0.0_dp,matrix_aux,error) - CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev1,error) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev1,0.0_dp,matrix_aux) + CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev1) !----------------------------------------------------------------------- ! Transform even2 back to position space !----------------------------------------------------------------------- - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev2,0.0_dp,matrix_aux,error) - CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev2,error) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_rev,matrix_ev2,0.0_dp,matrix_aux) + CALL cp_gemm("N","T",n,n,n,1.0_dp,matrix_aux,matrix_rev,0.0_dp,matrix_ev2) !----------------------------------------------------------------------- ! Calculate v in position space !----------------------------------------------------------------------- ! - CALL cp_fm_scale_and_add(1.0_dp,matrix_ev1,1.0_dp,matrix_ev2,error) - CALL cp_fm_upper_to_full(matrix_ev1,matrix_aux,error) - CALL cp_fm_to_fm(matrix_ev1,matrix_v,error) + CALL cp_fm_scale_and_add(1.0_dp,matrix_ev1,1.0_dp,matrix_ev2) + CALL cp_fm_upper_to_full(matrix_ev1,matrix_aux) + CALL cp_fm_to_fm(matrix_ev1,matrix_v) IF(dkh_order.ge.3) THEN - CALL cp_fm_scale_and_add(1.0_dp,matrix_v,1.0_dp,matrix_ev3,error) + CALL cp_fm_scale_and_add(1.0_dp,matrix_v,1.0_dp,matrix_ev3) IF(dkh_order.ge.4) THEN - CALL cp_fm_scale_and_add(1.0_dp,matrix_v,1.0_dp,matrix_ev4,error) + CALL cp_fm_scale_and_add(1.0_dp,matrix_v,1.0_dp,matrix_ev4) END IF END IF !----------------------------------------------------------------------- - CALL cp_fm_release(matrix_eig, error=error) - CALL cp_fm_release(matrix_aux, error=error) - CALL cp_fm_release(matrix_aux2, error=error) - CALL cp_fm_release(matrix_rev, error=error) - CALL cp_fm_release(matrix_se, error=error) - CALL cp_fm_release(matrix_ev1, error=error) - CALL cp_fm_release(matrix_ev2, error=error) - CALL cp_fm_release(matrix_sinv, error=error) - CALL cp_fm_release(matrix_ev3, error=error) - CALL cp_fm_release(matrix_ev4, error=error) - CALL cp_fm_release(matrix_pe1p, error=error) + CALL cp_fm_release(matrix_eig) + CALL cp_fm_release(matrix_aux) + CALL cp_fm_release(matrix_aux2) + CALL cp_fm_release(matrix_rev) + CALL cp_fm_release(matrix_se) + CALL cp_fm_release(matrix_ev1) + CALL cp_fm_release(matrix_ev2) + CALL cp_fm_release(matrix_sinv) + CALL cp_fm_release(matrix_ev3) + CALL cp_fm_release(matrix_ev4) + CALL cp_fm_release(matrix_pe1p) - CALL cp_fm_struct_release(matrix_full, error=error) + CALL cp_fm_struct_release(matrix_full) DEALLOCATE(ev0t,e,aa,rr,tt) @@ -392,28 +389,26 @@ END SUBROUTINE kintegral !> \param rr R-factors (diagonal) !> \param matrix_aux ... !> \param matrix_aux2 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE even1(matrix_ev1,matrix_v,matrix_pvp,aa,rr,matrix_aux,matrix_aux2,error) + SUBROUTINE even1(matrix_ev1,matrix_v,matrix_pvp,aa,rr,matrix_aux,matrix_aux2) TYPE(cp_fm_type), POINTER :: matrix_ev1, matrix_v, & matrix_pVp REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: aa, rr TYPE(cp_fm_type), POINTER :: matrix_aux, matrix_aux2 - TYPE(cp_error_type), INTENT(inout) :: error - CALL cp_fm_to_fm(matrix_v,matrix_aux,error) + CALL cp_fm_to_fm(matrix_v,matrix_aux) CALL cp_fm_column_scale(matrix_aux,aa) - CALL cp_fm_transpose(matrix_aux,matrix_ev1,error) + CALL cp_fm_transpose(matrix_aux,matrix_ev1) CALL cp_fm_column_scale(matrix_ev1,aa) - CALL cp_fm_to_fm(matrix_pVp,matrix_aux,error) + CALL cp_fm_to_fm(matrix_pVp,matrix_aux) CALL cp_fm_column_scale(matrix_aux,aa) CALL cp_fm_column_scale(matrix_aux,rr) - CALL cp_fm_transpose(matrix_aux,matrix_aux2,error) + CALL cp_fm_transpose(matrix_aux,matrix_aux2) CALL cp_fm_column_scale(matrix_aux2,aa) CALL cp_fm_column_scale(matrix_aux2,rr) - CALL cp_fm_scale_and_add(1.0_dp,matrix_ev1,1.0_dp,matrix_aux2,error) + CALL cp_fm_scale_and_add(1.0_dp,matrix_ev1,1.0_dp,matrix_aux2) RETURN END SUBROUTINE even1 @@ -429,16 +424,14 @@ END SUBROUTINE even1 !> \param aa A-factors (diagonal) !> \param rr R-factors (diagonal) !> \param tt ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE peven1p(n,matrix_pe1p,matrix_v,matrix_pvp,matrix_aux,matrix_aux2,aa,rr,tt,error) + SUBROUTINE peven1p(n,matrix_pe1p,matrix_v,matrix_pvp,matrix_aux,matrix_aux2,aa,rr,tt) INTEGER, INTENT(IN) :: n TYPE(cp_fm_type), POINTER :: matrix_pe1p, matrix_v, & matrix_pvp, matrix_aux, & matrix_aux2 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: aa, rr, tt - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, nrow_local INTEGER, DIMENSION(:), POINTER :: row_indices @@ -452,39 +445,38 @@ SUBROUTINE peven1p(n,matrix_pe1p,matrix_v,matrix_pvp,matrix_aux,matrix_aux2,aa,r vec_arrt(i)=vec_ar(i)*rr(i)*tt(i) END DO - CALL cp_fm_struct_get(matrix_v%matrix_struct,context=context, error = error) + CALL cp_fm_struct_get(matrix_v%matrix_struct,context=context) CALL cp_fm_struct_create( fmstruct = vec_full,& context = context,& nrow_global = n,& - ncol_global = 1,& - error = error) + ncol_global = 1) NULLIFY(vec_a) - CALL cp_fm_create(vec_a, vec_full, error=error) + CALL cp_fm_create(vec_a, vec_full) CALL cp_fm_get_info(matrix_v, nrow_local=nrow_local, & - row_indices=row_indices,error=error) + row_indices=row_indices) DO i=1,nrow_local vec_a%local_data(i,1) = vec_arrt(row_indices(i)) END DO - CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux,error) - CALL cp_fm_upper_to_full(matrix_aux,matrix_aux2,error) - CALL cp_fm_schur_product(matrix_v,matrix_aux,matrix_pe1p,error) + CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux) + CALL cp_fm_upper_to_full(matrix_aux,matrix_aux2) + CALL cp_fm_schur_product(matrix_v,matrix_aux,matrix_pe1p) DO i=1,nrow_local vec_a%local_data(i,1) = vec_ar(row_indices(i)) END DO - CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux,error) - CALL cp_fm_upper_to_full(matrix_aux,matrix_aux2,error) - CALL cp_fm_schur_product(matrix_pvp,matrix_aux,matrix_aux2,error) + CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux) + CALL cp_fm_upper_to_full(matrix_aux,matrix_aux2) + CALL cp_fm_schur_product(matrix_pvp,matrix_aux,matrix_aux2) - CALL cp_fm_scale_and_add(4.0_dp,matrix_pe1p,1.0_dp,matrix_aux2,error) + CALL cp_fm_scale_and_add(4.0_dp,matrix_pe1p,1.0_dp,matrix_aux2) - CALL cp_fm_release(vec_a,error=error) - CALL cp_fm_struct_release(vec_full,error=error) + CALL cp_fm_release(vec_a) + CALL cp_fm_struct_release(vec_full) RETURN END SUBROUTINE peven1p @@ -502,9 +494,8 @@ END SUBROUTINE peven1p !> \param tt Nonrel. kinetic Energy (DIAGONAL) !> \param e Rel. Energy = SQRT(p^2*c^2 + c^4) (DIAGONAL) !> \param matrix_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE even2c (n,matrix_ev2,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux,error) + SUBROUTINE even2c (n,matrix_ev2,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux) !*********************************************************************** ! * @@ -527,7 +518,6 @@ SUBROUTINE even2c (n,matrix_ev2,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux,error) matrix_pVp REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: aa, rr, tt, e TYPE(cp_fm_type), POINTER :: matrix_aux - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_blacs_env_type), POINTER :: context TYPE(cp_fm_struct_type), POINTER :: matrix_full @@ -540,12 +530,11 @@ SUBROUTINE even2c (n,matrix_ev2,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux,error) ! 1. General Structures and Patterns for DKH2 !----------------------------------------------------------------------- - CALL cp_fm_struct_get(matrix_v%matrix_struct,context=context, error = error) + CALL cp_fm_struct_get(matrix_v%matrix_struct,context=context) CALL cp_fm_struct_create( fmstruct = matrix_full,& context = context,& nrow_global = n,& - ncol_global = n,& - error = error) + ncol_global = n) NULLIFY(matrix_aux2) NULLIFY(matrix_ava) @@ -553,68 +542,68 @@ SUBROUTINE even2c (n,matrix_ev2,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux,error) NULLIFY(matrix_apVpa) NULLIFY(matrix_apVVpa) - CALL cp_fm_create(matrix_aux2, matrix_full, error=error) - CALL cp_fm_create(matrix_ava, matrix_full, error=error) - CALL cp_fm_create(matrix_avva, matrix_full, error=error) - CALL cp_fm_create(matrix_apVpa, matrix_full, error=error) - CALL cp_fm_create(matrix_apVVpa, matrix_full, error=error) + CALL cp_fm_create(matrix_aux2, matrix_full) + CALL cp_fm_create(matrix_ava, matrix_full) + CALL cp_fm_create(matrix_avva, matrix_full) + CALL cp_fm_create(matrix_apVpa, matrix_full) + CALL cp_fm_create(matrix_apVVpa, matrix_full) - CALL cp_fm_to_fm(matrix_v,matrix_ava,error) - CALL cp_fm_to_fm(matrix_v,matrix_avva,error) - CALL cp_fm_to_fm(matrix_pVp,matrix_apVpa,error) - CALL cp_fm_to_fm(matrix_pVp,matrix_apVVpa,error) + CALL cp_fm_to_fm(matrix_v,matrix_ava) + CALL cp_fm_to_fm(matrix_v,matrix_avva) + CALL cp_fm_to_fm(matrix_pVp,matrix_apVpa) + CALL cp_fm_to_fm(matrix_pVp,matrix_apVVpa) ! Calculate v = A V A: - CALL mat_axa(matrix_v,matrix_ava,n,aa,matrix_aux,error) + CALL mat_axa(matrix_v,matrix_ava,n,aa,matrix_aux) ! Calculate pvp = A P V P A: - CALL mat_arxra(matrix_pVp,matrix_apVpa,n,aa,rr,matrix_aux,error) + CALL mat_arxra(matrix_pVp,matrix_apVpa,n,aa,rr,matrix_aux) ! Calculate vh = A V~ A: - CALL mat_1_over_h(matrix_v,matrix_avva,e,matrix_aux,error) - CALL cp_fm_to_fm(matrix_avva,matrix_aux2,error) - CALL mat_axa(matrix_aux2,matrix_avva,n,aa,matrix_aux,error) + CALL mat_1_over_h(matrix_v,matrix_avva,e,matrix_aux) + CALL cp_fm_to_fm(matrix_avva,matrix_aux2) + CALL mat_axa(matrix_aux2,matrix_avva,n,aa,matrix_aux) ! Calculate pvph = A P V~ P A: - CALL mat_1_over_h(matrix_pVp,matrix_apVVpa,e,matrix_aux,error) - CALL cp_fm_to_fm(matrix_apVVpa,matrix_aux2,error) - CALL mat_arxra(matrix_aux2,matrix_apVVpa,n,aa,rr,matrix_aux,error) + CALL mat_1_over_h(matrix_pVp,matrix_apVVpa,e,matrix_aux) + CALL cp_fm_to_fm(matrix_apVVpa,matrix_aux2) + CALL mat_arxra(matrix_aux2,matrix_apVVpa,n,aa,rr,matrix_aux) ! Calculate w1o1: - CALL cp_gemm("N","N",n,n,n,-1.0_dp,matrix_apVVpa,matrix_ava,0.0_dp,matrix_aux2,error) - CALL mat_muld(matrix_aux2,matrix_apVVpa,matrix_apVpa,n, 1.0_dp,1.0_dp,tt,rr,matrix_aux,error) - CALL mat_mulm(matrix_aux2,matrix_avva, matrix_ava,n, 1.0_dp,1.0_dp,tt,rr,matrix_aux,error) - CALL cp_gemm("N","N",n,n,n,-1.0_dp,matrix_avva,matrix_apVpa,1.0_dp,matrix_aux2,error) + CALL cp_gemm("N","N",n,n,n,-1.0_dp,matrix_apVVpa,matrix_ava,0.0_dp,matrix_aux2) + CALL mat_muld(matrix_aux2,matrix_apVVpa,matrix_apVpa,n, 1.0_dp,1.0_dp,tt,rr,matrix_aux) + CALL mat_mulm(matrix_aux2,matrix_avva, matrix_ava,n, 1.0_dp,1.0_dp,tt,rr,matrix_aux) + CALL cp_gemm("N","N",n,n,n,-1.0_dp,matrix_avva,matrix_apVpa,1.0_dp,matrix_aux2) ! Calculate o1w1 (already stored in ev2): - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_apVpa,matrix_avva,0.0_dp,matrix_ev2,error) - CALL mat_muld(matrix_ev2,matrix_apVpa,matrix_apVVpa,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux,error) - CALL mat_mulm(matrix_ev2,matrix_ava, matrix_avva,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux,error) - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_ava,matrix_apVVpa,1.0_dp,matrix_ev2,error) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_apVpa,matrix_avva,0.0_dp,matrix_ev2) + CALL mat_muld(matrix_ev2,matrix_apVpa,matrix_apVVpa,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux) + CALL mat_mulm(matrix_ev2,matrix_ava, matrix_avva,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_ava,matrix_apVVpa,1.0_dp,matrix_ev2) !----------------------------------------------------------------------- ! 2. 1/2 [W1,O1] = 1/2 W1O1 - 1/2 O1W1 !----------------------------------------------------------------------- - CALL cp_fm_scale_and_add(-0.5_dp,matrix_ev2,0.5_dp,matrix_aux2,error) + CALL cp_fm_scale_and_add(-0.5_dp,matrix_ev2,0.5_dp,matrix_aux2) !----------------------------------------------------------------------- ! 3. Finish up the stuff!! !----------------------------------------------------------------------- - CALL cp_fm_release(matrix_aux2, error=error) - CALL cp_fm_release(matrix_ava, error=error) - CALL cp_fm_release(matrix_avva, error=error) - CALL cp_fm_release(matrix_apVpa, error=error) - CALL cp_fm_release(matrix_apVVpa, error=error) + CALL cp_fm_release(matrix_aux2) + CALL cp_fm_release(matrix_ava) + CALL cp_fm_release(matrix_avva) + CALL cp_fm_release(matrix_apVpa) + CALL cp_fm_release(matrix_apVVpa) - CALL cp_fm_struct_release(matrix_full, error=error) + CALL cp_fm_struct_release(matrix_full) ! WRITE (*,*) "CAW: DKH2 with even2c (Alex)" ! WRITE (*,*) "JT: Now available in cp2k" @@ -636,9 +625,8 @@ END SUBROUTINE even2c !> \param tt ... !> \param e ... !> \param matrix_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE even3b (n,matrix_ev3,matrix_ev1,matrix_pe1p,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux,error) + SUBROUTINE even3b (n,matrix_ev3,matrix_ev1,matrix_pe1p,matrix_v,matrix_pVp,aa,rr,tt,e,matrix_aux) !*********************************************************************** ! * @@ -684,7 +672,6 @@ SUBROUTINE even3b (n,matrix_ev3,matrix_ev1,matrix_pe1p,matrix_v,matrix_pVp,aa,rr matrix_pVp REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: aa, rr, tt, e TYPE(cp_fm_type), POINTER :: matrix_aux - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_blacs_env_type), POINTER :: context TYPE(cp_fm_struct_type), POINTER :: matrix_full @@ -696,12 +683,11 @@ SUBROUTINE even3b (n,matrix_ev3,matrix_ev1,matrix_pe1p,matrix_v,matrix_pVp,aa,rr ! 1. General Structures and Patterns for DKH3 !----------------------------------------------------------------------- - CALL cp_fm_struct_get(matrix_v%matrix_struct,context=context, error = error) + CALL cp_fm_struct_get(matrix_v%matrix_struct,context=context) CALL cp_fm_struct_create( fmstruct = matrix_full,& context = context,& nrow_global = n,& - ncol_global = n,& - error = error) + ncol_global = n) NULLIFY(matrix_aux2) NULLIFY(matrix_w1w1) @@ -709,62 +695,62 @@ SUBROUTINE even3b (n,matrix_ev3,matrix_ev1,matrix_pe1p,matrix_v,matrix_pVp,aa,rr NULLIFY(matrix_avva) NULLIFY(matrix_apVVpa) - CALL cp_fm_create(matrix_aux2, matrix_full, error=error) - CALL cp_fm_create(matrix_w1w1, matrix_full, error=error) - CALL cp_fm_create(matrix_w1e1w1, matrix_full, error=error) - CALL cp_fm_create(matrix_avva, matrix_full, error=error) - CALL cp_fm_create(matrix_apVVpa, matrix_full, error=error) + CALL cp_fm_create(matrix_aux2, matrix_full) + CALL cp_fm_create(matrix_w1w1, matrix_full) + CALL cp_fm_create(matrix_w1e1w1, matrix_full) + CALL cp_fm_create(matrix_avva, matrix_full) + CALL cp_fm_create(matrix_apVVpa, matrix_full) - CALL cp_fm_to_fm(matrix_v,matrix_avva,error) - CALL cp_fm_to_fm(matrix_pVp,matrix_apVVpa,error) + CALL cp_fm_to_fm(matrix_v,matrix_avva) + CALL cp_fm_to_fm(matrix_pVp,matrix_apVVpa) ! Calculate vh = A V~ A: - CALL mat_1_over_h(matrix_v,matrix_avva,e,matrix_aux,error) - CALL cp_fm_to_fm(matrix_avva,matrix_aux2,error) - CALL mat_axa(matrix_aux2,matrix_avva,n,aa,matrix_aux,error) + CALL mat_1_over_h(matrix_v,matrix_avva,e,matrix_aux) + CALL cp_fm_to_fm(matrix_avva,matrix_aux2) + CALL mat_axa(matrix_aux2,matrix_avva,n,aa,matrix_aux) ! Calculate pvph = A P V~ P A: - CALL mat_1_over_h(matrix_pVp,matrix_apVVpa,e,matrix_aux,error) - CALL cp_fm_to_fm(matrix_apVVpa,matrix_aux2,error) - CALL mat_arxra(matrix_aux2,matrix_apVVpa,n,aa,rr,matrix_aux,error) + CALL mat_1_over_h(matrix_pVp,matrix_apVVpa,e,matrix_aux) + CALL cp_fm_to_fm(matrix_apVVpa,matrix_aux2) + CALL mat_arxra(matrix_aux2,matrix_apVVpa,n,aa,rr,matrix_aux) ! Calculate w1w1: - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_apVVpa,matrix_avva,0.0_dp,matrix_w1w1,error) - CALL mat_muld(matrix_w1w1,matrix_apVVpa,matrix_apVVpa,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux2,error) - CALL mat_mulm(matrix_w1w1,matrix_avva, matrix_avva,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux2,error) - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_avva,matrix_apVVpa,1.0_dp,matrix_w1w1,error) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_apVVpa,matrix_avva,0.0_dp,matrix_w1w1) + CALL mat_muld(matrix_w1w1,matrix_apVVpa,matrix_apVVpa,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux2) + CALL mat_mulm(matrix_w1w1,matrix_avva, matrix_avva,n, -1.0_dp,1.0_dp,tt,rr,matrix_aux2) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_avva,matrix_apVVpa,1.0_dp,matrix_w1w1) ! Calculate w1e1w1: (warning: ev3 is scratch array) - CALL mat_muld(matrix_aux,matrix_apVVpa,matrix_pe1p,n, 1.0_dp,0.0_dp,tt,rr,matrix_aux2,error) - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_avva,matrix_pe1p,0.0_dp,matrix_aux2,error) - CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_aux,matrix_avva,0.0_dp,matrix_w1e1w1,error) - CALL mat_muld(matrix_w1e1w1,matrix_aux,matrix_apVVpa,n, -1.0_dp,1.0_dp,tt,rr,matrix_ev3,error) - CALL cp_gemm("N","N",n,n,n,-1.0_dp,matrix_aux2,matrix_avva,1.0_dp,matrix_w1e1w1,error) - CALL mat_muld(matrix_w1e1w1,matrix_aux2,matrix_apVVpa,n, 1.0_dp,1.0_dp,tt,rr,matrix_ev3,error) + CALL mat_muld(matrix_aux,matrix_apVVpa,matrix_pe1p,n, 1.0_dp,0.0_dp,tt,rr,matrix_aux2) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_avva,matrix_pe1p,0.0_dp,matrix_aux2) + CALL cp_gemm("N","N",n,n,n,1.0_dp,matrix_aux,matrix_avva,0.0_dp,matrix_w1e1w1) + CALL mat_muld(matrix_w1e1w1,matrix_aux,matrix_apVVpa,n, -1.0_dp,1.0_dp,tt,rr,matrix_ev3) + CALL cp_gemm("N","N",n,n,n,-1.0_dp,matrix_aux2,matrix_avva,1.0_dp,matrix_w1e1w1) + CALL mat_muld(matrix_w1e1w1,matrix_aux2,matrix_apVVpa,n, 1.0_dp,1.0_dp,tt,rr,matrix_ev3) !----------------------------------------------------------------------- ! 2. ev3 = 1/2 (W1^2)E1 + 1/2 E1(W1^2) - W1E1W1 !----------------------------------------------------------------------- - CALL cp_gemm("N","N",n,n,n,0.5_dp,matrix_w1w1,matrix_ev1,0.0_dp,matrix_ev3,error) - CALL cp_gemm("N","N",n,n,n,0.5_dp,matrix_ev1,matrix_w1w1,1.0_dp,matrix_ev3,error) - CALL cp_fm_scale_and_add(1.0_dp,matrix_ev3,-1.0_dp,matrix_w1e1w1,error) + CALL cp_gemm("N","N",n,n,n,0.5_dp,matrix_w1w1,matrix_ev1,0.0_dp,matrix_ev3) + CALL cp_gemm("N","N",n,n,n,0.5_dp,matrix_ev1,matrix_w1w1,1.0_dp,matrix_ev3) + CALL cp_fm_scale_and_add(1.0_dp,matrix_ev3,-1.0_dp,matrix_w1e1w1) !----------------------------------------------------------------------- ! 3. Finish up the stuff!! !----------------------------------------------------------------------- - CALL cp_fm_release(matrix_aux2, error=error) - CALL cp_fm_release(matrix_avva, error=error) - CALL cp_fm_release(matrix_apVVpa, error=error) - CALL cp_fm_release(matrix_w1w1, error=error) - CALL cp_fm_release(matrix_w1e1w1, error=error) + CALL cp_fm_release(matrix_aux2) + CALL cp_fm_release(matrix_avva) + CALL cp_fm_release(matrix_apVVpa) + CALL cp_fm_release(matrix_w1w1) + CALL cp_fm_release(matrix_w1e1w1) - CALL cp_fm_struct_release(matrix_full, error=error) + CALL cp_fm_struct_release(matrix_full) ! WRITE (*,*) "CAW: DKH3 with even3b (Alex)" ! WRITE (*,*) "JT: Now available in cp2k" @@ -1059,9 +1045,8 @@ END SUBROUTINE even4a !> \param matrix_pp ... !> \param e ... !> \param matrix_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mat_1_over_h (matrix_p,matrix_pp,e,matrix_aux,error) + SUBROUTINE mat_1_over_h (matrix_p,matrix_pp,e,matrix_aux) !*********************************************************************** ! * @@ -1075,13 +1060,12 @@ SUBROUTINE mat_1_over_h (matrix_p,matrix_pp,e,matrix_aux,error) TYPE(cp_fm_type), POINTER :: matrix_p, matrix_pp REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: e TYPE(cp_fm_type), POINTER :: matrix_aux - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, j, ncol_local, nrow_local INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices CALL cp_fm_get_info(matrix_aux, nrow_local=nrow_local, ncol_local=ncol_local,& - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) DO j=1,ncol_local DO i=1,nrow_local @@ -1090,7 +1074,7 @@ SUBROUTINE mat_1_over_h (matrix_p,matrix_pp,e,matrix_aux,error) ENDDO - CALL cp_fm_schur_product(matrix_p,matrix_aux,matrix_pp,error) + CALL cp_fm_schur_product(matrix_p,matrix_aux,matrix_pp) RETURN @@ -1106,9 +1090,8 @@ END SUBROUTINE mat_1_over_h !> \param n ... !> \param a ... !> \param matrix_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mat_axa (matrix_x,matrix_axa,n,a,matrix_aux,error) + SUBROUTINE mat_axa (matrix_x,matrix_axa,n,a,matrix_aux) !C*********************************************************************** !C * @@ -1125,7 +1108,6 @@ SUBROUTINE mat_axa (matrix_x,matrix_axa,n,a,matrix_aux,error) INTEGER, INTENT(IN) :: n REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: a TYPE(cp_fm_type), POINTER :: matrix_aux - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, nrow_local INTEGER, DIMENSION(:), POINTER :: row_indices @@ -1133,26 +1115,25 @@ SUBROUTINE mat_axa (matrix_x,matrix_axa,n,a,matrix_aux,error) TYPE(cp_fm_struct_type), POINTER :: vec_full TYPE(cp_fm_type), POINTER :: vec_a - CALL cp_fm_struct_get(matrix_x%matrix_struct,context=context, error = error) + CALL cp_fm_struct_get(matrix_x%matrix_struct,context=context) CALL cp_fm_struct_create( fmstruct = vec_full,& context = context,& nrow_global = n,& - ncol_global = 1,& - error = error) + ncol_global = 1) NULLIFY(vec_a) - CALL cp_fm_create(vec_a, vec_full, error=error) + CALL cp_fm_create(vec_a, vec_full) CALL cp_fm_get_info(matrix_x, nrow_local=nrow_local, & - row_indices=row_indices,error=error) + row_indices=row_indices) DO i=1,nrow_local vec_a%local_data(i,1) = a(row_indices(i)) END DO - CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux,error) - CALL cp_fm_upper_to_full(matrix_aux,matrix_axa,error) - CALL cp_fm_schur_product(matrix_x,matrix_aux,matrix_axa,error) + CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux) + CALL cp_fm_upper_to_full(matrix_aux,matrix_axa) + CALL cp_fm_schur_product(matrix_x,matrix_aux,matrix_axa) ! DO i=1,n ! DO j=1,n @@ -1161,8 +1142,8 @@ SUBROUTINE mat_axa (matrix_x,matrix_axa,n,a,matrix_aux,error) ! ENDDO - CALL cp_fm_release(vec_a,error) - CALL cp_fm_struct_release(vec_full,error) + CALL cp_fm_release(vec_a) + CALL cp_fm_struct_release(vec_full) RETURN END SUBROUTINE mat_axa @@ -1178,9 +1159,8 @@ END SUBROUTINE mat_axa !> \param a ... !> \param r ... !> \param matrix_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mat_arxra (matrix_x,matrix_axa,n,a,r,matrix_aux,error) + SUBROUTINE mat_arxra (matrix_x,matrix_axa,n,a,r,matrix_aux) !C*********************************************************************** !C * @@ -1198,7 +1178,6 @@ SUBROUTINE mat_arxra (matrix_x,matrix_axa,n,a,r,matrix_aux,error) INTEGER, INTENT(IN) :: n REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: a, r TYPE(cp_fm_type), POINTER :: matrix_aux - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, nrow_local INTEGER, DIMENSION(:), POINTER :: row_indices @@ -1206,31 +1185,30 @@ SUBROUTINE mat_arxra (matrix_x,matrix_axa,n,a,r,matrix_aux,error) TYPE(cp_fm_struct_type), POINTER :: vec_full TYPE(cp_fm_type), POINTER :: vec_a - CALL cp_fm_struct_get(matrix_x%matrix_struct,context=context, error = error) + CALL cp_fm_struct_get(matrix_x%matrix_struct,context=context) CALL cp_fm_struct_create( fmstruct = vec_full,& context = context,& nrow_global = n,& - ncol_global = 1,& - error = error) + ncol_global = 1) CALL cp_fm_get_info(matrix_aux, nrow_local=nrow_local, & - row_indices=row_indices,error=error) + row_indices=row_indices) NULLIFY(vec_a) - CALL cp_fm_create(vec_a, vec_full, error=error) + CALL cp_fm_create(vec_a, vec_full) DO i=1,nrow_local vec_a%local_data(i,1) = a(row_indices(i))*r(row_indices(i)) END DO - CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux,error) - CALL cp_fm_upper_to_full(matrix_aux,matrix_axa,error) - CALL cp_fm_schur_product(matrix_x,matrix_aux,matrix_axa,error) + CALL cp_fm_syrk('U','N',1,1.0_dp,vec_a,1,1,0.0_dp,matrix_aux) + CALL cp_fm_upper_to_full(matrix_aux,matrix_axa) + CALL cp_fm_schur_product(matrix_x,matrix_aux,matrix_axa) - CALL cp_fm_release(vec_a,error) - CALL cp_fm_struct_release(vec_full,error) + CALL cp_fm_release(vec_a) + CALL cp_fm_struct_release(vec_full) RETURN END SUBROUTINE mat_arxra @@ -1249,9 +1227,8 @@ END SUBROUTINE mat_arxra !> \param t ... !> \param rr ... !> \param matrix_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mat_mulm (matrix_p,matrix_q,matrix_r,n,alpha,beta,t,rr,matrix_aux,error) + SUBROUTINE mat_mulm (matrix_p,matrix_q,matrix_r,n,alpha,beta,t,rr,matrix_aux) !C*********************************************************************** !C * @@ -1276,19 +1253,18 @@ SUBROUTINE mat_mulm (matrix_p,matrix_q,matrix_r,n,alpha,beta,t,rr,matrix_aux,err REAL(KIND=dp), INTENT(IN) :: alpha, beta REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: t, rr TYPE(cp_fm_type), POINTER :: matrix_aux - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i REAL(KIND=dp), DIMENSION(n) :: vec - CALL cp_fm_to_fm(matrix_q,matrix_aux,error) + CALL cp_fm_to_fm(matrix_q,matrix_aux) DO i=1,n vec(i)=2.0_dp*t(i)*rr(i)*rr(i) END DO CALL cp_fm_column_scale(matrix_aux,vec) - CALL cp_gemm("N","N",n,n,n,alpha,matrix_aux,matrix_r,beta,matrix_p,error) + CALL cp_gemm("N","N",n,n,n,alpha,matrix_aux,matrix_r,beta,matrix_p) RETURN END SUBROUTINE mat_mulm @@ -1307,9 +1283,8 @@ END SUBROUTINE mat_mulm !> \param t ... !> \param rr ... !> \param matrix_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mat_muld (matrix_p,matrix_q,matrix_r,n,alpha,beta,t,rr,matrix_aux,error) + SUBROUTINE mat_muld (matrix_p,matrix_q,matrix_r,n,alpha,beta,t,rr,matrix_aux) !C*********************************************************************** !C * @@ -1334,12 +1309,11 @@ SUBROUTINE mat_muld (matrix_p,matrix_q,matrix_r,n,alpha,beta,t,rr,matrix_aux,err REAL(KIND=dp), INTENT(IN) :: alpha, beta REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: t, rr TYPE(cp_fm_type), POINTER :: matrix_aux - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i REAL(KIND=dp), DIMENSION(n) :: vec - CALL cp_fm_to_fm(matrix_q,matrix_aux,error) + CALL cp_fm_to_fm(matrix_q,matrix_aux) DO i=1,n vec(i)=0.5_dp/(t(i)*rr(i)*rr(i)) @@ -1347,7 +1321,7 @@ SUBROUTINE mat_muld (matrix_p,matrix_q,matrix_r,n,alpha,beta,t,rr,matrix_aux,err CALL cp_fm_column_scale(matrix_aux,vec) - CALL cp_gemm("N","N",n,n,n,alpha,matrix_aux,matrix_r,beta,matrix_p,error) + CALL cp_gemm("N","N",n,n,n,alpha,matrix_aux,matrix_r,beta,matrix_p) RETURN diff --git a/src/dm_ls_chebyshev.F b/src/dm_ls_chebyshev.F index df7e6e953e..81ef461ed4 100644 --- a/src/dm_ls_chebyshev.F +++ b/src/dm_ls_chebyshev.F @@ -92,15 +92,13 @@ END SUBROUTINE kernel !> \brief compute properties based on chebyshev expansion !> \param qs_env ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2012.10 created [Jinwoong Cha] !> \author Jinwoong Cha ! ***************************************************************************** - SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) + SUBROUTINE compute_chebyshev(qs_env,ls_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_chebyshev', & routineP = moduleN//':'//routineN @@ -132,7 +130,7 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -143,15 +141,15 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) ninte=2*ncheb n_gridpoint_dos=ls_scf_env%chebyshev%n_gridpoint_dos - write_cubes=BTEST(cp_print_key_should_output(logger%iter_info,ls_scf_env%chebyshev%print_key_cube,error=error),cp_p_file) + write_cubes=BTEST(cp_print_key_should_output(logger%iter_info,ls_scf_env%chebyshev%print_key_cube),cp_p_file) IF (write_cubes) THEN IF (ASSOCIATED(ls_scf_env%chebyshev%min_energy)) DEALLOCATE(ls_scf_env%chebyshev%min_energy) - CALL section_vals_val_get(ls_scf_env%chebyshev%print_key_cube,"MIN_ENERGY",r_vals=tmp_r,error=error) + CALL section_vals_val_get(ls_scf_env%chebyshev%print_key_cube,"MIN_ENERGY",r_vals=tmp_r) ALLOCATE(ls_scf_env%chebyshev%min_energy(SIZE(tmp_r))) ls_scf_env%chebyshev%min_energy=tmp_r IF (ASSOCIATED(ls_scf_env%chebyshev%max_energy)) DEALLOCATE(ls_scf_env%chebyshev%max_energy) - CALL section_vals_val_get(ls_scf_env%chebyshev%print_key_cube,"MAX_ENERGY",r_vals=tmp_r,error=error) + CALL section_vals_val_get(ls_scf_env%chebyshev%print_key_cube,"MAX_ENERGY",r_vals=tmp_r) ALLOCATE(ls_scf_env%chebyshev%max_energy(SIZE(tmp_r))) ls_scf_env%chebyshev%max_energy=tmp_r @@ -179,33 +177,33 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) ENDIF ! create 3 temporary matrices - CALL cp_dbcsr_init(matrix_tmp1,error=error) !initialization - CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) - CALL cp_dbcsr_create(matrix_tmp2,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp3,error=error) - CALL cp_dbcsr_create(matrix_tmp3,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_F,error=error) - CALL cp_dbcsr_create(matrix_F,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_dummy1,error=error) - CALL cp_dbcsr_create(matrix_dummy1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_tmp1) !initialization + CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) + CALL cp_dbcsr_create(matrix_tmp2,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp3) + CALL cp_dbcsr_create(matrix_tmp3,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_F) + CALL cp_dbcsr_create(matrix_F,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_dummy1) + CALL cp_dbcsr_create(matrix_dummy1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) DO iwindow=1,nwindow - CALL cp_dbcsr_init(matrix_dummy2(iwindow),error=error) ! density matrix + CALL cp_dbcsr_init(matrix_dummy2(iwindow)) ! density matrix CALL cp_dbcsr_create(matrix_dummy2(iwindow),template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) END DO DO ispin=1,SIZE(ls_scf_env%matrix_ks) ! create matrix_F=inv(sqrt(S))*H*inv(sqrt(S)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt_inv, ls_scf_env%matrix_ks(ispin), & - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_s_sqrt_inv, & - 0.0_dp, matrix_F, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_F, filter_eps=ls_scf_env%eps_filter) ! find largest and smallest eigenvalues CALL cp_dbcsr_arnoldi_extremal(matrix_F, max_ev, min_ev, converged=converged, max_iter=ls_scf_env%max_iter_lanczos, & - threshold=ls_scf_env%eps_lanczos, error=error) !Lanczos algorithm to calculate eigenvalue + threshold=ls_scf_env%eps_lanczos) !Lanczos algorithm to calculate eigenvalue IF (unit_nr>0) WRITE(unit_nr,'(T2,A,2F16.8,A,L2)') "smallest largest eigenvalue", min_ev, max_ev, " converged ",converged IF (nwindow>0) THEN IF (unit_nr>0) WRITE(unit_nr,'(T2,A,1000F16.8)') "requested interval-min_energy", ev1(:) @@ -248,15 +246,15 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) END DO ! scale the matrix to get evals in the interval -1,1 - CALL cp_dbcsr_add_on_diag(matrix_F,-interval_b,error=error) - CALL cp_dbcsr_scale(matrix_F,1/interval_a,error=error) + CALL cp_dbcsr_add_on_diag(matrix_F,-interval_b) + CALL cp_dbcsr_scale(matrix_F,1/interval_a) ! compute chebyshev matrix recursion CALL cp_dbcsr_get_info(matrix=matrix_F,nfullrows_total = Nrows) !get information about a matrix - CALL cp_dbcsr_set(matrix_dummy1,0.0_dp,error=error) !empty matrix creation(for density matrix) + CALL cp_dbcsr_set(matrix_dummy1,0.0_dp) !empty matrix creation(for density matrix) DO iwindow=1,nwindow - CALL cp_dbcsr_set(matrix_dummy2(iwindow),0.0_dp,error=error) !empty matrix creation(for density matrix) + CALL cp_dbcsr_set(matrix_dummy2(iwindow),0.0_dp) !empty matrix creation(for density matrix) END DO ALLOCATE(mu(1:ncheb)) @@ -264,37 +262,37 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) CALL kernel(kernel_g(1), 1, ncheb) CALL kernel(kernel_g(2), 2, ncheb) - CALL cp_dbcsr_set(matrix_tmp1,0.0_dp,error=error) !matrix creation - CALL cp_dbcsr_add_on_diag(matrix_tmp1,1.0_dp,error=error) !add a only number to diagonal elements - CALL cp_dbcsr_trace(matrix_tmp1,trace=mu(1),error=error) - CALL cp_dbcsr_copy(matrix_tmp2,matrix_F,error=error) !make matrix_tmp2 = matrix_F - CALL cp_dbcsr_trace(matrix_tmp2,trace=mu(2),error=error) + CALL cp_dbcsr_set(matrix_tmp1,0.0_dp) !matrix creation + CALL cp_dbcsr_add_on_diag(matrix_tmp1,1.0_dp) !add a only number to diagonal elements + CALL cp_dbcsr_trace(matrix_tmp1,trace=mu(1)) + CALL cp_dbcsr_copy(matrix_tmp2,matrix_F) !make matrix_tmp2 = matrix_F + CALL cp_dbcsr_trace(matrix_tmp2,trace=mu(2)) DO iwindow=1,nwindow - CALL cp_dbcsr_copy(matrix_dummy1,matrix_tmp1,error=error) - CALL cp_dbcsr_copy(matrix_dummy2(iwindow),matrix_tmp2,error=error) !matrix_dummy2= - CALL cp_dbcsr_scale(matrix_dummy1,kernel_g(1)*aitchev_T(1,iwindow),error=error) !first term of chebyshev poly(matrix) - CALL cp_dbcsr_scale(matrix_dummy2(iwindow),2.0_dp*kernel_g(2)*aitchev_T(2,iwindow),error=error) !second term of chebyshev poly(matrix) + CALL cp_dbcsr_copy(matrix_dummy1,matrix_tmp1) + CALL cp_dbcsr_copy(matrix_dummy2(iwindow),matrix_tmp2) !matrix_dummy2= + CALL cp_dbcsr_scale(matrix_dummy1,kernel_g(1)*aitchev_T(1,iwindow)) !first term of chebyshev poly(matrix) + CALL cp_dbcsr_scale(matrix_dummy2(iwindow),2.0_dp*kernel_g(2)*aitchev_T(2,iwindow)) !second term of chebyshev poly(matrix) - CALL cp_dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp, error=error) + CALL cp_dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) END DO DO icheb=2,ncheb-1 t1 = m_walltime() CALL cp_dbcsr_multiply("N", "N", 2.0_dp, matrix_F, matrix_tmp2, & - -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) !matrix multiplication(Recursion) - CALL cp_dbcsr_copy(matrix_tmp3,matrix_tmp1,error=error) - CALL cp_dbcsr_copy(matrix_tmp1,matrix_tmp2,error=error) - CALL cp_dbcsr_copy(matrix_tmp2,matrix_tmp3,error=error) - CALL cp_dbcsr_trace(matrix_tmp2,trace=mu(icheb+1),error=error) !icheb+1 th coefficient + -1.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) !matrix multiplication(Recursion) + CALL cp_dbcsr_copy(matrix_tmp3,matrix_tmp1) + CALL cp_dbcsr_copy(matrix_tmp1,matrix_tmp2) + CALL cp_dbcsr_copy(matrix_tmp2,matrix_tmp3) + CALL cp_dbcsr_trace(matrix_tmp2,trace=mu(icheb+1)) !icheb+1 th coefficient CALL kernel(kernel_g(icheb+1), icheb+1, ncheb) DO iwindow=1,nwindow - CALL cp_dbcsr_copy(matrix_dummy1,matrix_tmp2,error=error) - CALL cp_dbcsr_scale(matrix_dummy1,2.0_dp*kernel_g(icheb+1)*aitchev_T(icheb+1,iwindow),error=error) !second term of chebyshev poly(matrix) - CALL cp_dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp, error=error) - CALL cp_dbcsr_trace(matrix_dummy2(iwindow),trace=trace_dm(iwindow),error=error) !icheb+1 th coefficient + CALL cp_dbcsr_copy(matrix_dummy1,matrix_tmp2) + CALL cp_dbcsr_scale(matrix_dummy1,2.0_dp*kernel_g(icheb+1)*aitchev_T(icheb+1,iwindow)) !second term of chebyshev poly(matrix) + CALL cp_dbcsr_add(matrix_dummy2(iwindow), matrix_dummy1, 1.0_dp, 1.0_dp) + CALL cp_dbcsr_trace(matrix_dummy2(iwindow),trace=trace_dm(iwindow)) !icheb+1 th coefficient END DO @@ -319,33 +317,32 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) orbital_occ=1.0_dp ENDIF CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt_inv, matrix_dummy2(iwindow) , & - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", orbital_occ , matrix_tmp1, ls_scf_env%matrix_s_sqrt_inv, & - 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter,error=error) - CALL cp_dbcsr_copy(matrix_dummy2(iwindow),matrix_tmp2,error=error) + 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter) + CALL cp_dbcsr_copy(matrix_dummy2(iwindow),matrix_tmp2) ! look at the difference with the density matrix from the ls routines IF (.FALSE.) THEN - CALL cp_dbcsr_copy(matrix_tmp1,matrix_tmp2,error=error) - CALL cp_dbcsr_add(matrix_tmp1, ls_scf_env%matrix_p(ispin) , 1.0_dp, -1.0_dp, error=error) !comparison + CALL cp_dbcsr_copy(matrix_tmp1,matrix_tmp2) + CALL cp_dbcsr_add(matrix_tmp1, ls_scf_env%matrix_p(ispin) , 1.0_dp, -1.0_dp) !comparison frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) IF (unit_nr>0) WRITE(unit_nr,*) "Difference between Chebyshev DM and LS DM",frob_matrix ENDIF END DO write_cubes=BTEST(cp_print_key_should_output(logger%iter_info,& - ls_scf_env%chebyshev%print_key_cube,error=error),cp_p_file) + ls_scf_env%chebyshev%print_key_cube),cp_p_file) IF (write_cubes) THEN DO iwindow=1,nwindow WRITE(middle_name,"(A,I0)") "E_DENSITY_WINDOW_",iwindow WRITE(title,"(A,1X,F16.8,1X,A,1X,F16.8)") "Energy range : ",ev1(iwindow),"to",ev2(iwindow) unit_cube =cp_print_key_unit_nr(logger, ls_scf_env%chebyshev%print_key_cube, & "",extension=".cube", & !added 01/22/2012 - middle_name=TRIM(middle_name),log_filename=.FALSE.,error=error) + middle_name=TRIM(middle_name),log_filename=.FALSE.) CALL write_matrix_to_cube(qs_env,ls_scf_env,matrix_dummy2(iwindow),unit_cube,title,& - section_get_ivals( ls_scf_env%chebyshev%print_key_cube,"STRIDE",error=error),& - error=error) - CALL cp_print_key_finished_output(unit_cube,logger,ls_scf_env%chebyshev%print_key_cube,"",error=error) + section_get_ivals( ls_scf_env%chebyshev%print_key_cube,"STRIDE")) + CALL cp_print_key_finished_output(unit_cube,logger,ls_scf_env%chebyshev%print_key_cube,"") END DO ENDIF @@ -354,7 +351,7 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) ! Chebyshev expansion with calculated coefficient ! grid construction and rescaling (by J) unit_dos=cp_print_key_unit_nr(logger,ls_scf_env%chebyshev%print_key_dos,"",extension=".xy",& - middle_name="DOS",log_filename=.FALSE.,error=error) + middle_name="DOS",log_filename=.FALSE.) IF (unit_dos>0) THEN ALLOCATE (dos(1:n_gridpoint_dos)) @@ -385,17 +382,17 @@ SUBROUTINE compute_chebyshev(qs_env,ls_scf_env,error) END DO DEALLOCATE (chev_Es_dos, chev_E, dos, gdensity) ENDIF - CALL cp_print_key_finished_output(unit_dos,logger,ls_scf_env%chebyshev%print_key_dos,"",error=error) + CALL cp_print_key_finished_output(unit_dos,logger,ls_scf_env%chebyshev%print_key_dos,"") ! free the matrices - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) - CALL cp_dbcsr_release(matrix_tmp3,error=error) - CALL cp_dbcsr_release(matrix_F,error=error) - CALL cp_dbcsr_release(matrix_dummy1,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) + CALL cp_dbcsr_release(matrix_tmp3) + CALL cp_dbcsr_release(matrix_F) + CALL cp_dbcsr_release(matrix_dummy1) DO iwindow=1,nwindow - CALL cp_dbcsr_release(matrix_dummy2(iwindow),error=error) + CALL cp_dbcsr_release(matrix_dummy2(iwindow)) END DO DEALLOCATE(ev1,ev2,sev1,sev2,matrix_dummy2) diff --git a/src/dm_ls_scf.F b/src/dm_ls_scf.F index 4e4cd9752b..d3b7e8d9b5 100644 --- a/src/dm_ls_scf.F +++ b/src/dm_ls_scf.F @@ -118,14 +118,12 @@ MODULE dm_ls_scf !> \brief perform an linear scaling scf procedure: entry point !> !> \param qs_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf(qs_env,error) + SUBROUTINE ls_scf(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf', & routineP = moduleN//':'//routineN @@ -136,16 +134,16 @@ SUBROUTINE ls_scf(qs_env,error) CALL timeset(routineN,handle) ! get scf env - CALL get_qs_env(qs_env,ls_scf_env=ls_scf_env,error=error) + CALL get_qs_env(qs_env,ls_scf_env=ls_scf_env) ! initialize the scf phase - CALL ls_scf_init_scf(qs_env,ls_scf_env,error) + CALL ls_scf_init_scf(qs_env,ls_scf_env) ! perform the actual scf - CALL ls_scf_main(qs_env,ls_scf_env,error) + CALL ls_scf_main(qs_env,ls_scf_env) ! do post scf processing - CALL ls_scf_post(qs_env,ls_scf_env,error) + CALL ls_scf_post(qs_env,ls_scf_env) CALL timestop(handle) @@ -154,14 +152,12 @@ END SUBROUTINE ls_scf ! ***************************************************************************** !> \brief Creation and basic initialization of the LS type. !> \param qs_env ... -!> \param error ... !> \par History !> 2012.11 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_create(qs_env,error) + SUBROUTINE ls_scf_create(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_create', & routineP = moduleN//':'//routineN @@ -186,7 +182,7 @@ SUBROUTINE ls_scf_create(qs_env,error) CALL cite_reference(VandeVondele2012) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -194,7 +190,7 @@ SUBROUTINE ls_scf_create(qs_env,error) ENDIF ALLOCATE(ls_scf_env,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! get basic quantities from the qs_env @@ -207,21 +203,21 @@ SUBROUTINE ls_scf_create(qs_env,error) has_unit_metric=ls_scf_env%has_unit_metric,& para_env=ls_scf_env%para_env,& do_transport=ls_scf_env%do_transport,& - nelectron_spin=ls_scf_env%nelectron_spin,error=error) + nelectron_spin=ls_scf_env%nelectron_spin) ! copy some basic stuff ls_scf_env%nspins=dft_control%nspins ls_scf_env%natoms=SIZE(particle_set,1) - CALL cp_para_env_retain(ls_scf_env%para_env,error) + CALL cp_para_env_retain(ls_scf_env%para_env) ! initialize block to group to defined molecules ALLOCATE(ls_scf_env%ls_mstruct%atom_to_molecule(ls_scf_env%natoms),stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL molecule_of_atom(molecule_set,atom_to_mol=ls_scf_env%ls_mstruct%atom_to_molecule,error=error) + CALL molecule_of_atom(molecule_set,atom_to_mol=ls_scf_env%ls_mstruct%atom_to_molecule) ! parse the ls_scf section and set derived quantities - CALL ls_scf_init_read_write_input(input,ls_scf_env,unit_nr,error) + CALL ls_scf_init_read_write_input(input,ls_scf_env,unit_nr) ! set up the buffer for the history of matrices ls_scf_env%scf_history%nstore=ls_scf_env%extrapolation_order @@ -229,22 +225,22 @@ SUBROUTINE ls_scf_create(qs_env,error) ALLOCATE(ls_scf_env%scf_history%matrix(ls_scf_env%nspins,ls_scf_env%scf_history%nstore)) NULLIFY(ls_scf_env%mixing_store) - mixing_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%RHO_MIXING",error=error) + mixing_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%RHO_MIXING") CALL mixing_storage_create(ls_scf_env%mixing_store, mixing_section, & ls_scf_env%density_mixing_method, & - dft_control%qs_control%cutoff, error) + dft_control%qs_control%cutoff) ! initialize PEXSI IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) THEN CALL cp_assert(dft_control%qs_control%eps_filter_matrix .EQ. 0.0_dp, & cp_failure_level, cp_assertion_failed, routineP, & "EPS_FILTER_MATRIX must be set to 0 for PEXSI.", & - only_ionode=.TRUE., error = error) - CALL lib_pexsi_init(ls_scf_env%pexsi, ls_scf_env%para_env%group, ls_scf_env%nspins, error) + only_ionode=.TRUE.) + CALL lib_pexsi_init(ls_scf_env%pexsi, ls_scf_env%para_env%group, ls_scf_env%nspins) ENDIF ! put the ls_scf_env in qs_env - CALL set_qs_env(qs_env,ls_scf_env=ls_scf_env,error=error) + CALL set_qs_env(qs_env,ls_scf_env=ls_scf_env) CALL timestop(handle) @@ -254,15 +250,13 @@ END SUBROUTINE ls_scf_create !> \brief initialization needed for scf !> \param qs_env ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_init_scf(qs_env,ls_scf_env,error) + SUBROUTINE ls_scf_init_scf(qs_env,ls_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_init_scf', & routineP = moduleN//':'//routineN @@ -280,7 +274,7 @@ SUBROUTINE ls_scf_init_scf(qs_env,ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -296,46 +290,46 @@ SUBROUTINE ls_scf_init_scf(qs_env,ls_scf_env,error) input=input,& has_unit_metric=ls_scf_env%has_unit_metric,& para_env=ls_scf_env%para_env,& - nelectron_spin=ls_scf_env%nelectron_spin,error=error) + nelectron_spin=ls_scf_env%nelectron_spin) ! some basic initialization of the QS side of things - CALL ls_scf_init_qs(qs_env,error) + CALL ls_scf_init_qs(qs_env) ! create the matrix template for use in the ls procedures CALL matrix_ls_create(matrix_ls=ls_scf_env%matrix_s,matrix_qs=matrix_s(1)%matrix,& - ls_mstruct=ls_scf_env%ls_mstruct,error=error) + ls_mstruct=ls_scf_env%ls_mstruct) nspin=ls_scf_env%nspins ALLOCATE(ls_scf_env%matrix_p(nspin)) DO ispin=1,nspin - CALL cp_dbcsr_init(ls_scf_env%matrix_p(ispin),error=error) + CALL cp_dbcsr_init(ls_scf_env%matrix_p(ispin)) CALL cp_dbcsr_create(ls_scf_env%matrix_p(ispin),template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry, error=error) + matrix_type=dbcsr_type_no_symmetry) ENDDO ALLOCATE(ls_scf_env%matrix_ks(nspin)) DO ispin=1,nspin - CALL cp_dbcsr_init(ls_scf_env%matrix_ks(ispin),error=error) + CALL cp_dbcsr_init(ls_scf_env%matrix_ks(ispin)) CALL cp_dbcsr_create(ls_scf_env%matrix_ks(ispin),template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry, error=error) + matrix_type=dbcsr_type_no_symmetry) ENDDO ! set up matrix S, and needed functions of S - CALL ls_scf_init_matrix_s(matrix_s(1)%matrix,ls_scf_env,error) + CALL ls_scf_init_matrix_s(matrix_s(1)%matrix,ls_scf_env) ! get the initial guess for the SCF - CALL ls_scf_initial_guess(qs_env,ls_scf_env,error) + CALL ls_scf_initial_guess(qs_env,ls_scf_env) IF (ls_scf_env%do_rho_mixing) THEN - CALL rho_mixing_ls_init(qs_env, ls_scf_env, error) + CALL rho_mixing_ls_init(qs_env, ls_scf_env) ENDIF IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) THEN - CALL pexsi_init_scf(ks_env, ls_scf_env%pexsi, matrix_s(1)%matrix, error) + CALL pexsi_init_scf(ks_env, ls_scf_env%pexsi, matrix_s(1)%matrix) ENDIF IF (qs_env%do_transport) THEN - CALL transport_initialize(ks_env,qs_env%transport_env, matrix_s(1)%matrix, error) + CALL transport_initialize(ks_env,qs_env%transport_env, matrix_s(1)%matrix) END IF CALL timestop(handle) @@ -346,15 +340,13 @@ END SUBROUTINE ls_scf_init_scf !> \brief deal with the scf initial guess !> \param qs_env ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2012.11 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_initial_guess(qs_env,ls_scf_env,error) + SUBROUTINE ls_scf_initial_guess(qs_env,ls_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_initial_guess', & routineP = moduleN//':'//routineN @@ -373,7 +365,7 @@ SUBROUTINE ls_scf_initial_guess(qs_env,ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -396,32 +388,32 @@ SUBROUTINE ls_scf_initial_guess(qs_env,ls_scf_env,error) ! how to get the initial guess SELECT CASE(initial_guess_type) CASE(atomic_guess) - CALL ls_scf_qs_atomic_guess(qs_env,ls_scf_env%energy_init,error) + CALL ls_scf_qs_atomic_guess(qs_env,ls_scf_env%energy_init) CASE(restart_guess) project_name = logger%iter_info%project_name DO ispin=1,SIZE(ls_scf_env%matrix_p) WRITE(file_name,'(A,I0,A)') TRIM(project_name)//"_LS_DM_SPIN_",ispin,"_RESTART.dm" CALL cp_dbcsr_binary_read(file_name, distribution=cp_dbcsr_distribution(ls_scf_env%matrix_p(1)), & - matrix_new=ls_scf_env%matrix_p(ispin), error=error) - cs_pos = cp_dbcsr_checksum (ls_scf_env%matrix_p(ispin), pos=.TRUE., error=error) + matrix_new=ls_scf_env%matrix_p(ispin)) + cs_pos = cp_dbcsr_checksum (ls_scf_env%matrix_p(ispin), pos=.TRUE.) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A,E20.8)') "Read restart DM "//TRIM(file_name)//" with checksum: ",cs_pos ENDIF ENDDO ! directly go to computing the corresponding energy and ks matrix - CALL ls_scf_dm_to_ks(qs_env,ls_scf_env,ls_scf_env%energy_init,iscf=0,error=error) + CALL ls_scf_dm_to_ks(qs_env,ls_scf_env,ls_scf_env%energy_init,iscf=0) CASE(aspc_guess) CALL cite_reference(Kolafa2004) naspc=MIN(ls_scf_env%scf_history%istore,ls_scf_env%scf_history%nstore) DO ispin=1,SIZE(ls_scf_env%matrix_p) ! actual extrapolation - CALL cp_dbcsr_set(ls_scf_env%matrix_p(ispin),0.0_dp,error=error) + CALL cp_dbcsr_set(ls_scf_env%matrix_p(ispin),0.0_dp) DO iaspc=1,naspc alpha=(-1.0_dp)**(iaspc + 1)*REAL(iaspc,KIND=dp)*& binomial(2*naspc,naspc - iaspc)/binomial(2*naspc - 2,naspc -1) istore=MOD(ls_scf_env%scf_history%istore-iaspc,ls_scf_env%scf_history%nstore)+1 - CALL cp_dbcsr_add(ls_scf_env%matrix_p(ispin), ls_scf_env%scf_history%matrix(ispin,istore), 1.0_dp, alpha, error=error) + CALL cp_dbcsr_add(ls_scf_env%matrix_p(ispin), ls_scf_env%scf_history%matrix(ispin,istore), 1.0_dp, alpha) ENDDO ENDDO END SELECT @@ -436,32 +428,32 @@ SUBROUTINE ls_scf_initial_guess(qs_env,ls_scf_env,error) IF (.NOT.(ls_scf_env%purification_method .EQ. ls_scf_pexsi)) THEN DO ispin=1,SIZE(ls_scf_env%matrix_p) ! linear combination of P's is not idempotent. A bit of McWeeny is needed to ensure it is again - IF(SIZE(ls_scf_env%matrix_p)==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(ispin),0.5_dp,error=error) - CALL purify_mcweeny(ls_scf_env%matrix_p(ispin:ispin),ls_scf_env%eps_filter,3,error) - IF(SIZE(ls_scf_env%matrix_p)==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(ispin),2.0_dp,error=error) + IF(SIZE(ls_scf_env%matrix_p)==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(ispin),0.5_dp) + CALL purify_mcweeny(ls_scf_env%matrix_p(ispin:ispin),ls_scf_env%eps_filter,3) + IF(SIZE(ls_scf_env%matrix_p)==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(ispin),2.0_dp) IF (ls_scf_env%use_s_sqrt) THEN ! need to get P in the non-orthogonal basis if it was stored differently - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt_inv, ls_scf_env%matrix_p(ispin),& - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_s_sqrt_inv, & 0.0_dp, ls_scf_env%matrix_p(ispin) , & - filter_eps=ls_scf_env%eps_filter,error=error) - CALL cp_dbcsr_release(matrix_tmp1,error=error) + filter_eps=ls_scf_env%eps_filter) + CALL cp_dbcsr_release(matrix_tmp1) IF (ls_scf_env%has_s_preconditioner) THEN CALL apply_matrix_preconditioner(ls_scf_env%matrix_p(ispin),"forward", & - ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv,error) + ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv) ENDIF ENDIF ENDDO ENDIF ! compute corresponding energy and ks matrix - CALL ls_scf_dm_to_ks(qs_env,ls_scf_env,ls_scf_env%energy_init,iscf=0,error=error) + CALL ls_scf_dm_to_ks(qs_env,ls_scf_env,ls_scf_env%energy_init,iscf=0) END SELECT IF (unit_nr>0) THEN @@ -476,14 +468,12 @@ END SUBROUTINE ls_scf_initial_guess ! ***************************************************************************** !> \brief store a history of matrices for later use in ls_scf_initial_guess !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2012.11 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_store_result(ls_scf_env,error) + SUBROUTINE ls_scf_store_result(ls_scf_env) TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_store_result', & routineP = moduleN//':'//routineN @@ -500,7 +490,7 @@ SUBROUTINE ls_scf_store_result(ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -511,7 +501,7 @@ SUBROUTINE ls_scf_store_result(ls_scf_env,error) DO ispin=1,SIZE(ls_scf_env%matrix_p) project_name = logger%iter_info%project_name WRITE(file_name,'(A,I0,A)') TRIM(project_name)//"_LS_DM_SPIN_",ispin,"_RESTART.dm" - cs_pos = cp_dbcsr_checksum (ls_scf_env%matrix_p(ispin), pos=.TRUE., error=error) + cs_pos = cp_dbcsr_checksum (ls_scf_env%matrix_p(ispin), pos=.TRUE.) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A,E20.8)') "Writing restart DM "//TRIM(file_name)//" with checksum: ",cs_pos ENDIF @@ -524,28 +514,28 @@ SUBROUTINE ls_scf_store_result(ls_scf_env,error) "a full DM to store in the restart file." ENDIF - CALL cp_dbcsr_init(matrix_p_tmp,error=error) - CALL cp_dbcsr_create(matrix_p_tmp,template=ls_scf_env%matrix_ks(ispin),error=error) - CALL cp_dbcsr_set(matrix_p_tmp,0.0_dp,error=error) + CALL cp_dbcsr_init(matrix_p_tmp) + CALL cp_dbcsr_create(matrix_p_tmp,template=ls_scf_env%matrix_ks(ispin)) + CALL cp_dbcsr_set(matrix_p_tmp,0.0_dp) - CALL cp_dbcsr_init(matrix_ks_deviation_tmp,error=error) - CALL cp_dbcsr_create(matrix_ks_deviation_tmp,template=ls_scf_env%matrix_ks(ispin),error=error) - CALL cp_dbcsr_set(matrix_ks_deviation_tmp,0.0_dp,error=error) + CALL cp_dbcsr_init(matrix_ks_deviation_tmp) + CALL cp_dbcsr_create(matrix_ks_deviation_tmp,template=ls_scf_env%matrix_ks(ispin)) + CALL cp_dbcsr_set(matrix_ks_deviation_tmp,0.0_dp) nelectron_spin_real=ls_scf_env%nelectron_spin(ispin) IF (ls_scf_env%nspins==1) nelectron_spin_real=nelectron_spin_real/2 CALL density_matrix_trs4(matrix_p_tmp, ls_scf_env%matrix_ks(ispin), ls_scf_env%matrix_s_sqrt_inv,& nelectron_spin_real, 1.0E-06_dp, homo_spin, lumo_spin, mu_spin, & dynamic_threshold=.FALSE., matrix_ks_deviation=matrix_ks_deviation_tmp, & - eps_lanczos=1.0E-03_dp, max_iter_lanczos=128, error=error) - IF (ls_scf_env%nspins==1) CALL cp_dbcsr_scale(matrix_p_tmp, 2.0_dp, error=error) + eps_lanczos=1.0E-03_dp, max_iter_lanczos=128) + IF (ls_scf_env%nspins==1) CALL cp_dbcsr_scale(matrix_p_tmp, 2.0_dp) - CALL cp_dbcsr_binary_write(matrix_p_tmp,file_name,error) + CALL cp_dbcsr_binary_write(matrix_p_tmp,file_name) - CALL cp_dbcsr_release(matrix_p_tmp,error=error) - CALL cp_dbcsr_release(matrix_ks_deviation_tmp,error=error) + CALL cp_dbcsr_release(matrix_p_tmp) + CALL cp_dbcsr_release(matrix_ks_deviation_tmp) ELSE - CALL cp_dbcsr_binary_write(ls_scf_env%matrix_p(ispin),file_name,error) + CALL cp_dbcsr_binary_write(ls_scf_env%matrix_p(ispin),file_name) END IF ENDDO END IF @@ -555,27 +545,27 @@ SUBROUTINE ls_scf_store_result(ls_scf_env,error) DO ispin=1,SIZE(ls_scf_env%matrix_p) istore=MOD(ls_scf_env%scf_history%istore-1,ls_scf_env%scf_history%nstore)+1 IF (ls_scf_env%scf_history%istore<=ls_scf_env%scf_history%nstore) & - CALL cp_dbcsr_init(ls_scf_env%scf_history%matrix(ispin,istore),error=error) - CALL cp_dbcsr_copy(ls_scf_env%scf_history%matrix(ispin,istore), ls_scf_env%matrix_p(ispin), error=error) + CALL cp_dbcsr_init(ls_scf_env%scf_history%matrix(ispin,istore)) + CALL cp_dbcsr_copy(ls_scf_env%scf_history%matrix(ispin,istore), ls_scf_env%matrix_p(ispin)) ! if we have the sqrt around, we use it to go to the orthogonal basis IF (ls_scf_env%use_s_sqrt) THEN ! usualy sqrt(S) * P * sqrt(S) should be available, or could be stored at least, ! so that the next multiplications could be saved. - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) IF (ls_scf_env%has_s_preconditioner) THEN CALL apply_matrix_preconditioner(ls_scf_env%scf_history%matrix(ispin,istore),"backward", & - ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv,error) + ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv) ENDIF CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt, ls_scf_env%scf_history%matrix(ispin,istore),& - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_s_sqrt, & 0.0_dp, ls_scf_env%scf_history%matrix(ispin,istore) , & - filter_eps=ls_scf_env%eps_filter,error=error) - CALL cp_dbcsr_release(matrix_tmp1,error=error) + filter_eps=ls_scf_env%eps_filter) + CALL cp_dbcsr_release(matrix_tmp1) ENDIF ENDDO @@ -590,15 +580,13 @@ END SUBROUTINE ls_scf_store_result !> Might be factored-out since this seems common code with the other SCF. !> \param matrix_s ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_init_matrix_S(matrix_s,ls_scf_env,error) + SUBROUTINE ls_scf_init_matrix_S(matrix_s,ls_scf_env) TYPE(cp_dbcsr_type) :: matrix_s TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_init_matrix_S', & routineP = moduleN//':'//routineN @@ -611,7 +599,7 @@ SUBROUTINE ls_scf_init_matrix_S(matrix_s,ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -620,100 +608,100 @@ SUBROUTINE ls_scf_init_matrix_S(matrix_s,ls_scf_env,error) ! make our own copy of S IF (ls_scf_env%has_unit_metric) THEN - CALL cp_dbcsr_set(ls_scf_env%matrix_s,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(ls_scf_env%matrix_s,1.0_dp,error=error) + CALL cp_dbcsr_set(ls_scf_env%matrix_s,0.0_dp) + CALL cp_dbcsr_add_on_diag(ls_scf_env%matrix_s,1.0_dp) ELSE - CALL matrix_qs_to_ls(ls_scf_env%matrix_s,matrix_s,ls_scf_env%ls_mstruct,error=error) + CALL matrix_qs_to_ls(ls_scf_env%matrix_s,matrix_s,ls_scf_env%ls_mstruct) ENDIF - CALL cp_dbcsr_filter(ls_scf_env%matrix_s,ls_scf_env%eps_filter,error=error) + CALL cp_dbcsr_filter(ls_scf_env%matrix_s,ls_scf_env%eps_filter) ! needs a preconditioner for S IF (ls_scf_env%has_s_preconditioner) THEN - CALL cp_dbcsr_init(ls_scf_env%matrix_bs_sqrt,error=error) + CALL cp_dbcsr_init(ls_scf_env%matrix_bs_sqrt) CALL cp_dbcsr_create(ls_scf_env%matrix_bs_sqrt,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry, error=error) - CALL cp_dbcsr_init(ls_scf_env%matrix_bs_sqrt_inv,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(ls_scf_env%matrix_bs_sqrt_inv) CALL cp_dbcsr_create(ls_scf_env%matrix_bs_sqrt_inv,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry, error=error) + matrix_type=dbcsr_type_no_symmetry) CALL compute_matrix_preconditioner(ls_scf_env%matrix_s,& ls_scf_env%s_preconditioner_type, ls_scf_env%ls_mstruct, & ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv,& ls_scf_env%eps_filter,ls_scf_env%sign_sqrt_order,& - ls_scf_env%eps_lanczos,ls_scf_env%max_iter_lanczos,error) + ls_scf_env%eps_lanczos,ls_scf_env%max_iter_lanczos) ENDIF ! precondition S IF (ls_scf_env%has_s_preconditioner) THEN CALL apply_matrix_preconditioner(ls_scf_env%matrix_s,"forward", & - ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv,error) + ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv) ENDIF ! compute sqrt(S) and inv(sqrt(S)) IF (ls_scf_env%use_s_sqrt) THEN - CALL cp_dbcsr_init(ls_scf_env%matrix_s_sqrt,error=error) - CALL cp_dbcsr_init(ls_scf_env%matrix_s_sqrt_inv,error=error) + CALL cp_dbcsr_init(ls_scf_env%matrix_s_sqrt) + CALL cp_dbcsr_init(ls_scf_env%matrix_s_sqrt_inv) CALL cp_dbcsr_create(ls_scf_env%matrix_s_sqrt,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_create(ls_scf_env%matrix_s_sqrt_inv,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL matrix_sqrt_Newton_Schulz(ls_scf_env%matrix_s_sqrt,ls_scf_env%matrix_s_sqrt_inv,& ls_scf_env%matrix_s,ls_scf_env%eps_filter,& ls_scf_env%sign_sqrt_order, & - ls_scf_env%eps_lanczos, ls_scf_env%max_iter_lanczos, error) + ls_scf_env%eps_lanczos, ls_scf_env%max_iter_lanczos) IF (.TRUE.) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) CALL cp_dbcsr_create(matrix_tmp2,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt_inv, ls_scf_env%matrix_s,& - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_s_sqrt_inv, & - 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp2) - CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp2,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp2) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(sqrt(S))*S*inv(sqrt(S))-I)",frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) ENDIF ENDIF ! compute the inverse of S IF (ls_scf_env%needs_s_inv) THEN - CALL cp_dbcsr_init(ls_scf_env%matrix_s_inv,error=error) + CALL cp_dbcsr_init(ls_scf_env%matrix_s_inv) CALL cp_dbcsr_create(ls_scf_env%matrix_s_inv,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) IF (.NOT.ls_scf_env%use_s_sqrt) THEN - CALL invert_Hotelling(ls_scf_env%matrix_s_inv,ls_scf_env%matrix_s,ls_scf_env%eps_filter,error=error) + CALL invert_Hotelling(ls_scf_env%matrix_s_inv,ls_scf_env%matrix_s,ls_scf_env%eps_filter) ELSE CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt_inv, ls_scf_env%matrix_s_sqrt_inv, & - 0.0_dp, ls_scf_env%matrix_s_inv, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, ls_scf_env%matrix_s_inv, filter_eps=ls_scf_env%eps_filter) ENDIF IF (.TRUE.) THEN - CALL cp_dbcsr_init(matrix_tmp1,error=error) + CALL cp_dbcsr_init(matrix_tmp1) CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_inv, ls_scf_env%matrix_s,& - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) frob_matrix_base=cp_dbcsr_frobenius_norm(matrix_tmp1) - CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(matrix_tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp1) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Error for (inv(S)*S-I)",frob_matrix/frob_matrix_base ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) + CALL cp_dbcsr_release(matrix_tmp1) ENDIF ENDIF @@ -726,16 +714,14 @@ END SUBROUTINE ls_scf_init_matrix_s !> \param input ... !> \param ls_scf_env ... !> \param unit_nr ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_init_read_write_input(input,ls_scf_env,unit_nr,error) + SUBROUTINE ls_scf_init_read_write_input(input,ls_scf_env,unit_nr) TYPE(section_vals_type), POINTER :: input TYPE(ls_scf_env_type), INTENT(INOUT) :: ls_scf_env INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_init_read_write_input', & routineP = moduleN//':'//routineN @@ -754,76 +740,76 @@ SUBROUTINE ls_scf_init_read_write_input(input,ls_scf_env,unit_nr,error) CALL timeset(routineN,handle) CALL cite_reference(VandeVondele2012) failure=.FALSE. - ls_scf_section => section_vals_get_subs_vals(input,"DFT%LS_SCF",error=error) - curvy_section => section_vals_get_subs_vals(ls_scf_section,"CURVY_STEPS",error=error) + ls_scf_section => section_vals_get_subs_vals(input,"DFT%LS_SCF") + curvy_section => section_vals_get_subs_vals(ls_scf_section,"CURVY_STEPS") ! should come from input - CALL section_vals_val_get(ls_scf_section,"LS_DIIS",l_val=ls_scf_env%ls_diis,error=error) - CALL section_vals_val_get(ls_scf_section,"INI_DIIS",i_val=ls_scf_env%iter_ini_diis,error=error) - CALL section_vals_val_get(ls_scf_section,"MAX_DIIS",i_val=ls_scf_env%max_diis,error=error) - CALL section_vals_val_get(ls_scf_section,"NMIXING",i_val=ls_scf_env%nmixing,error=error) - CALL section_vals_val_get(ls_scf_section,"EPS_DIIS",r_val=ls_scf_env%eps_diis,error=error) - CALL section_vals_val_get(ls_scf_section,"EPS_SCF",r_val=ls_scf_env%eps_scf,error=error) - CALL section_vals_val_get(ls_scf_section,"EPS_FILTER",r_val=ls_scf_env%eps_filter,error=error) - CALL section_vals_val_get(ls_scf_section,"MU",r_val=mu,error=error) - CALL section_vals_val_get(ls_scf_section,"FIXED_MU",l_val=ls_scf_env%fixed_mu,error=error) + CALL section_vals_val_get(ls_scf_section,"LS_DIIS",l_val=ls_scf_env%ls_diis) + CALL section_vals_val_get(ls_scf_section,"INI_DIIS",i_val=ls_scf_env%iter_ini_diis) + CALL section_vals_val_get(ls_scf_section,"MAX_DIIS",i_val=ls_scf_env%max_diis) + CALL section_vals_val_get(ls_scf_section,"NMIXING",i_val=ls_scf_env%nmixing) + CALL section_vals_val_get(ls_scf_section,"EPS_DIIS",r_val=ls_scf_env%eps_diis) + CALL section_vals_val_get(ls_scf_section,"EPS_SCF",r_val=ls_scf_env%eps_scf) + CALL section_vals_val_get(ls_scf_section,"EPS_FILTER",r_val=ls_scf_env%eps_filter) + CALL section_vals_val_get(ls_scf_section,"MU",r_val=mu) + CALL section_vals_val_get(ls_scf_section,"FIXED_MU",l_val=ls_scf_env%fixed_mu) ls_scf_env%mu_spin=mu - CALL section_vals_val_get(ls_scf_section,"MIXING_FRACTION",r_val=ls_scf_env%mixing_fraction,error=error) - CALL section_vals_val_get(ls_scf_section,"MAX_SCF",i_val=ls_scf_env%max_scf,error=error) - CALL section_vals_val_get(ls_scf_section,"S_PRECONDITIONER",i_val=ls_scf_env%s_preconditioner_type,error=error) - CALL section_vals_val_get(ls_scf_section,"MATRIX_CLUSTER_TYPE",i_val=ls_scf_env%ls_mstruct%cluster_type,error=error) - CALL section_vals_val_get(ls_scf_section,"SINGLE_PRECISION_MATRICES",l_val=ls_scf_env%ls_mstruct%single_precision,error=error) - CALL section_vals_val_get(ls_scf_section,"S_INVERSION",i_val=ls_scf_env%s_inversion_type,error=error) - CALL section_vals_val_get(ls_scf_section,"REPORT_ALL_SPARSITIES",l_val=ls_scf_env%report_all_sparsities,error=error) - CALL section_vals_val_get(ls_scf_section,"PERFORM_MU_SCAN",l_val=ls_scf_env%perform_mu_scan,error=error) - CALL section_vals_val_get(ls_scf_section,"PURIFICATION_METHOD",i_val=ls_scf_env%purification_method,error=error) - CALL section_vals_val_get(ls_scf_section,"DYNAMIC_THRESHOLD",l_val=ls_scf_env%dynamic_threshold,error=error) - CALL section_vals_val_get(ls_scf_section,"NON_MONOTONIC",l_val=ls_scf_env%non_monotonic,error=error) - CALL section_vals_val_get(ls_scf_section,"SIGN_SQRT_ORDER",i_val=ls_scf_env%sign_sqrt_order,error=error) - CALL section_vals_val_get(ls_scf_section,"EXTRAPOLATION_ORDER",i_val=ls_scf_env%extrapolation_order,error=error) - CALL section_vals_val_get(ls_scf_section,"RESTART_READ",l_val=ls_scf_env%restart_read,error=error) - CALL section_vals_val_get(ls_scf_section,"RESTART_WRITE",l_val=ls_scf_env%restart_write,error=error) - CALL section_vals_val_get(ls_scf_section,"EPS_LANCZOS",r_val=ls_scf_env%eps_lanczos,error=error) - CALL section_vals_val_get(ls_scf_section,"MAX_ITER_LANCZOS",i_val=ls_scf_env%max_iter_lanczos,error=error) - - CALL section_vals_get(curvy_section, explicit=ls_scf_env%curvy_steps, error=error) - CALL section_vals_val_get(curvy_section,"LINE_SEARCH",i_val=ls_scf_env%curvy_data%line_search_type,error=error) - CALL section_vals_val_get(curvy_section,"N_BCH_HISTORY",i_val=ls_scf_env%curvy_data%n_bch_hist,error=error) - CALL section_vals_val_get(curvy_section,"MIN_HESSIAN_SHIFT",r_val=ls_scf_env%curvy_data%min_shift,error=error) - CALL section_vals_val_get(curvy_section,"FILTER_FACTOR",r_val=ls_scf_env%curvy_data%filter_factor,error=error) - CALL section_vals_val_get(curvy_section,"FILTER_FACTOR_SCALE",r_val=ls_scf_env%curvy_data%scale_filter,error=error) - CALL section_vals_val_get(curvy_section,"MIN_FILTER",r_val=ls_scf_env%curvy_data%min_filter,error=error) + CALL section_vals_val_get(ls_scf_section,"MIXING_FRACTION",r_val=ls_scf_env%mixing_fraction) + CALL section_vals_val_get(ls_scf_section,"MAX_SCF",i_val=ls_scf_env%max_scf) + CALL section_vals_val_get(ls_scf_section,"S_PRECONDITIONER",i_val=ls_scf_env%s_preconditioner_type) + CALL section_vals_val_get(ls_scf_section,"MATRIX_CLUSTER_TYPE",i_val=ls_scf_env%ls_mstruct%cluster_type) + CALL section_vals_val_get(ls_scf_section,"SINGLE_PRECISION_MATRICES",l_val=ls_scf_env%ls_mstruct%single_precision) + CALL section_vals_val_get(ls_scf_section,"S_INVERSION",i_val=ls_scf_env%s_inversion_type) + CALL section_vals_val_get(ls_scf_section,"REPORT_ALL_SPARSITIES",l_val=ls_scf_env%report_all_sparsities) + CALL section_vals_val_get(ls_scf_section,"PERFORM_MU_SCAN",l_val=ls_scf_env%perform_mu_scan) + CALL section_vals_val_get(ls_scf_section,"PURIFICATION_METHOD",i_val=ls_scf_env%purification_method) + CALL section_vals_val_get(ls_scf_section,"DYNAMIC_THRESHOLD",l_val=ls_scf_env%dynamic_threshold) + CALL section_vals_val_get(ls_scf_section,"NON_MONOTONIC",l_val=ls_scf_env%non_monotonic) + CALL section_vals_val_get(ls_scf_section,"SIGN_SQRT_ORDER",i_val=ls_scf_env%sign_sqrt_order) + CALL section_vals_val_get(ls_scf_section,"EXTRAPOLATION_ORDER",i_val=ls_scf_env%extrapolation_order) + CALL section_vals_val_get(ls_scf_section,"RESTART_READ",l_val=ls_scf_env%restart_read) + CALL section_vals_val_get(ls_scf_section,"RESTART_WRITE",l_val=ls_scf_env%restart_write) + CALL section_vals_val_get(ls_scf_section,"EPS_LANCZOS",r_val=ls_scf_env%eps_lanczos) + CALL section_vals_val_get(ls_scf_section,"MAX_ITER_LANCZOS",i_val=ls_scf_env%max_iter_lanczos) + + CALL section_vals_get(curvy_section, explicit=ls_scf_env%curvy_steps) + CALL section_vals_val_get(curvy_section,"LINE_SEARCH",i_val=ls_scf_env%curvy_data%line_search_type) + CALL section_vals_val_get(curvy_section,"N_BCH_HISTORY",i_val=ls_scf_env%curvy_data%n_bch_hist) + CALL section_vals_val_get(curvy_section,"MIN_HESSIAN_SHIFT",r_val=ls_scf_env%curvy_data%min_shift) + CALL section_vals_val_get(curvy_section,"FILTER_FACTOR",r_val=ls_scf_env%curvy_data%filter_factor) + CALL section_vals_val_get(curvy_section,"FILTER_FACTOR_SCALE",r_val=ls_scf_env%curvy_data%scale_filter) + CALL section_vals_val_get(curvy_section,"MIN_FILTER",r_val=ls_scf_env%curvy_data%min_filter) ls_scf_env%extrapolation_order=MAX(0,ls_scf_env%extrapolation_order) - chebyshev_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%CHEBYSHEV",error=error) - CALL section_vals_get(chebyshev_section,explicit=ls_scf_env%chebyshev%compute_chebyshev,error=error) + chebyshev_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%CHEBYSHEV") + CALL section_vals_get(chebyshev_section,explicit=ls_scf_env%chebyshev%compute_chebyshev) IF (ls_scf_env%chebyshev%compute_chebyshev) THEN - CALL section_vals_val_get(chebyshev_section,"N_CHEBYSHEV",i_val=ls_scf_env%chebyshev%n_chebyshev,error=error) - CALL section_vals_val_get(chebyshev_section,"DOS%N_GRIDPOINTS",i_val=ls_scf_env%chebyshev%n_gridpoint_dos,error=error) + CALL section_vals_val_get(chebyshev_section,"N_CHEBYSHEV",i_val=ls_scf_env%chebyshev%n_chebyshev) + CALL section_vals_val_get(chebyshev_section,"DOS%N_GRIDPOINTS",i_val=ls_scf_env%chebyshev%n_gridpoint_dos) ls_scf_env%chebyshev%print_key_dos => & - section_vals_get_subs_vals(chebyshev_section,"DOS",error=error) - CALL section_vals_retain(ls_scf_env%chebyshev%print_key_dos,error=error) + section_vals_get_subs_vals(chebyshev_section,"DOS") + CALL section_vals_retain(ls_scf_env%chebyshev%print_key_dos) ls_scf_env%chebyshev%print_key_cube => & - section_vals_get_subs_vals(chebyshev_section,"PRINT_SPECIFIC_E_DENSITY_CUBE",error=error) - CALL section_vals_retain(ls_scf_env%chebyshev%print_key_cube,error=error) + section_vals_get_subs_vals(chebyshev_section,"PRINT_SPECIFIC_E_DENSITY_CUBE") + CALL section_vals_retain(ls_scf_env%chebyshev%print_key_cube) ENDIF - mixing_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%RHO_MIXING",error=error) - CALL section_vals_get(mixing_section, explicit=ls_scf_env%do_rho_mixing, error=error) + mixing_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%RHO_MIXING") + CALL section_vals_get(mixing_section, explicit=ls_scf_env%do_rho_mixing) - CALL section_vals_val_get(mixing_section,"METHOD",i_val=ls_scf_env%density_mixing_method,error=error) + CALL section_vals_val_get(mixing_section,"METHOD",i_val=ls_scf_env%density_mixing_method) CALL cp_assert(.NOT.(ls_scf_env%ls_diis.AND.ls_scf_env%do_rho_mixing),cp_failure_level,cp_assertion_failed,& routineP,"LS_DIIS and RHO_MIXING are not compatible."//& CPSourceFileRef,only_ionode=.TRUE.) - pexsi_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%PEXSI",error=error) - CALL section_vals_get(pexsi_section, error=error) + pexsi_section => section_vals_get_subs_vals(input,"DFT%LS_SCF%PEXSI") + CALL section_vals_get(pexsi_section) IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) THEN - CALL pexsi_init_read_input(pexsi_section,ls_scf_env%pexsi, error) + CALL pexsi_init_read_input(pexsi_section,ls_scf_env%pexsi) IF (.NOT. ls_scf_env%restart_write) THEN ! Turn off S inversion (not used for PEXSI). ! Methods such as purification must thus be avoided... which is OK, as the density matrix computed in pexsi is @@ -855,7 +841,7 @@ SUBROUTINE ls_scf_init_read_write_input(input,ls_scf_env,unit_nr,error) ls_scf_env%needs_s_inv=.FALSE. ls_scf_env%use_s_sqrt=.FALSE. CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT SELECT CASE(ls_scf_env%s_preconditioner_type) @@ -868,10 +854,10 @@ SUBROUTINE ls_scf_init_read_write_input(input,ls_scf_env,unit_nr,error) ! verify some requirements for the curvy steps CALL cp_assert(.NOT.(ls_scf_env%curvy_steps .AND. ls_scf_env%purification_method .EQ. ls_scf_pexsi), cp_failure_level, & cp_assertion_failed, routineP, "CURVY_STEPS can not be used together with PEXSI. ", & - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) CALL cp_assert(.NOT.(ls_scf_env%curvy_steps .AND. ls_scf_env%do_transport), cp_failure_level, & cp_assertion_failed, routineP, "CURVY_STEPS can not be used together with TRANSPORT. ", & - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) CALL cp_assert(.NOT.(ls_scf_env%curvy_steps.AND.ls_scf_env%has_s_preconditioner),cp_failure_level,cp_assertion_failed,& routineP,"S Preconditioning not implemented in combination with CURVY_STEPS. "//& CPSourceFileRef,& @@ -896,13 +882,13 @@ SUBROUTINE ls_scf_init_read_write_input(input,ls_scf_env,unit_nr,error) IF (ls_scf_env%do_rho_mixing) THEN IF (ls_scf_env%density_mixing_method>0) THEN NULLIFY(section) - CALL create_mixing_section(section,ls_scf=.TRUE.,error=error) - keyword => section_get_keyword(section,"METHOD",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + CALL create_mixing_section(section,ls_scf=.TRUE.) + keyword => section_get_keyword(section,"METHOD") + CALL keyword_get(keyword,enum=enum) WRITE (unit_nr,"(T2,A,T38,A20)")& "Density mixing in g-space:",ADJUSTR(TRIM(enum_i2c(enum,& - ls_scf_env%density_mixing_method,error=error))) - CALL section_release(section,error=error) + ls_scf_env%density_mixing_method))) + CALL section_release(section) END IF ELSE WRITE(unit_nr,'(T2,A,T38,E20.3)') "mixing_fraction:",ls_scf_env%mixing_fraction @@ -951,7 +937,7 @@ SUBROUTINE ls_scf_init_read_write_input(input,ls_scf_env,unit_nr,error) CALL cite_reference(Lin2013) WRITE(unit_nr,'(T2,A,T38,A20)') "Purification method","PEXSI" CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT SELECT CASE(ls_scf_env%ls_mstruct%cluster_type) @@ -982,15 +968,13 @@ END SUBROUTINE ls_scf_init_read_write_input !> \brief Main SCF routine. Can we keep it clean ? !> \param qs_env ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) + SUBROUTINE ls_scf_main(qs_env,ls_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_main', & routineP = moduleN//':'//routineN @@ -1015,7 +999,7 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1027,12 +1011,12 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) ! old quantities, useful for mixing ALLOCATE(matrix_mixing_old(nspin), matrix_ks_deviation(nspin)) DO ispin=1,nspin - CALL cp_dbcsr_init(matrix_mixing_old(ispin),error=error) - CALL cp_dbcsr_create(matrix_mixing_old(ispin),template=ls_scf_env%matrix_ks(ispin), error=error) + CALL cp_dbcsr_init(matrix_mixing_old(ispin)) + CALL cp_dbcsr_create(matrix_mixing_old(ispin),template=ls_scf_env%matrix_ks(ispin)) - CALL cp_dbcsr_init(matrix_ks_deviation(ispin),error=error) - CALL cp_dbcsr_create(matrix_ks_deviation(ispin),template=ls_scf_env%matrix_ks(ispin), error=error) - CALL cp_dbcsr_set(matrix_ks_deviation(ispin),0.0_dp,error=error) + CALL cp_dbcsr_init(matrix_ks_deviation(ispin)) + CALL cp_dbcsr_create(matrix_ks_deviation(ispin),template=ls_scf_env%matrix_ks(ispin)) + CALL cp_dbcsr_set(matrix_ks_deviation(ispin),0.0_dp) ENDDO ls_scf_env%homo_spin(:) = 0.0_dp ls_scf_env%lumo_spin(:) = 0.0_dp @@ -1048,20 +1032,19 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) NULLIFY(diis_buffer) IF (.NOT.ASSOCIATED(diis_buffer)) THEN CALL qs_diis_b_create_sparse(diis_buffer, & - nbuffer=ls_scf_env%max_diis, & - error=error) + nbuffer=ls_scf_env%max_diis) END IF - CALL qs_diis_b_clear_sparse(diis_buffer,error=error) - CALL get_qs_env(qs_env,matrix_s=matrix_s,error=error) + CALL qs_diis_b_clear_sparse(diis_buffer) + CALL get_qs_env(qs_env,matrix_s=matrix_s) END IF - CALL get_qs_env(qs_env, transport_env=transport_env, do_transport=do_transport, error=error) + CALL get_qs_env(qs_env, transport_env=transport_env, do_transport=do_transport) ! the real SCF loop DO ! check on max SCF or timing/exit - CALL external_control(should_stop,"SCF",start_time=qs_env%start_time,target_time=qs_env%target_time,error=error) + CALL external_control(should_stop,"SCF",start_time=qs_env%start_time,target_time=qs_env%target_time) IF (should_stop .OR. iscf>=ls_scf_env%max_scf) THEN IF (unit_nr>0) WRITE(unit_nr,'(T2,A)') "SCF not converged! " EXIT @@ -1071,27 +1054,27 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) iscf=iscf+1 ! first get a copy of the current KS matrix - CALL get_qs_env(qs_env, matrix_ks=matrix_ks, error=error) + CALL get_qs_env(qs_env, matrix_ks=matrix_ks) DO ispin=1,nspin - CALL matrix_qs_to_ls(ls_scf_env%matrix_ks(ispin),matrix_ks(ispin)%matrix,ls_scf_env%ls_mstruct,error=error) + CALL matrix_qs_to_ls(ls_scf_env%matrix_ks(ispin),matrix_ks(ispin)%matrix,ls_scf_env%ls_mstruct) IF (ls_scf_env%has_s_preconditioner) THEN CALL apply_matrix_preconditioner(ls_scf_env%matrix_ks(ispin),"forward", & - ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv,error) + ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv) ENDIF - CALL cp_dbcsr_filter(ls_scf_env%matrix_ks(ispin),ls_scf_env%eps_filter,error=error) + CALL cp_dbcsr_filter(ls_scf_env%matrix_ks(ispin),ls_scf_env%eps_filter) ENDDO ! run curvy steps if required. Needs an idempotent DM (either perification or restart) IF((iscf>1.OR.ls_scf_env%scf_history%istore>0).AND.ls_scf_env%curvy_steps)THEN - CALL dm_ls_curvy_optimization(ls_scf_env,energy_old,check_convergence,error) + CALL dm_ls_curvy_optimization(ls_scf_env,energy_old,check_convergence) ELSE ! turn the KS matrix in a density matrix DO ispin=1,nspin IF (ls_scf_env%do_rho_mixing) THEN - CALL cp_dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin), error=error) + CALL cp_dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) ELSE IF (iscf==1) THEN ! initialize the mixing matrix with the current state if needed - CALL cp_dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin), error=error) + CALL cp_dbcsr_copy(matrix_mixing_old(ispin), ls_scf_env%matrix_ks(ispin)) ELSE IF (ls_scf_env%ls_diis) THEN ! ------- IF-DIIS+MIX--- START IF (diis_step.and.(iscf-1).ge.ls_scf_env%iter_ini_diis) THEN @@ -1107,8 +1090,7 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) "*************************************************************" ENDIF CALL cp_dbcsr_copy(matrix_mixing_old(ispin), & ! out - ls_scf_env%matrix_ks(ispin),& ! in - error=error) + ls_scf_env%matrix_ks(ispin)) ! in ELSE IF (unit_nr>0) THEN WRITE(unit_nr,'(A57)') & @@ -1126,8 +1108,7 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) CALL cp_dbcsr_add(matrix_mixing_old(ispin) , & ls_scf_env%matrix_ks(ispin), & 1.0_dp-ls_scf_env%mixing_fraction, & - ls_scf_env%mixing_fraction, & - error=error) + ls_scf_env%mixing_fraction) ENDIF ELSE ! otherwise IF (unit_nr>0) THEN @@ -1146,8 +1127,7 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) CALL cp_dbcsr_add(matrix_mixing_old(ispin) , & ls_scf_env%matrix_ks(ispin), & 1.0_dp-ls_scf_env%mixing_fraction, & - ls_scf_env%mixing_fraction, & - error=error) + ls_scf_env%mixing_fraction) ENDIF ! ------- IF-DIIS+MIX--- END ENDIF ENDIF @@ -1159,66 +1139,64 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) IF (do_transport) THEN CALL cp_assert(.NOT.(ls_scf_env%has_s_preconditioner), cp_failure_level, cp_assertion_failed,& - routineP, "NOT YET IMPLEMENTED with S preconditioner. ", only_ionode=.TRUE., error=error) + routineP, "NOT YET IMPLEMENTED with S preconditioner. ", only_ionode=.TRUE.) CALL cp_assert(ls_scf_env%ls_mstruct%cluster_type .EQ. ls_cluster_atomic, cp_failure_level,& cp_assertion_failed, routineP, "NOT YET IMPLEMENTED with molecular clustering. ",& - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) ! get the current Kohn-Sham matrix (ks) and return matrix_p evaluated using an external C routine CALL external_scf_method(transport_env, ls_scf_env%matrix_s, matrix_mixing_old(ispin), & - ls_scf_env%matrix_p(ispin), nelectron_spin_real, ls_scf_env%natoms, error) + ls_scf_env%matrix_p(ispin), nelectron_spin_real, ls_scf_env%natoms) ELSE SELECT CASE(ls_scf_env%purification_method) CASE(ls_scf_ns) CALL density_matrix_sign(ls_scf_env%matrix_p(ispin),ls_scf_env%mu_spin(ispin), ls_scf_env%fixed_mu, & matrix_mixing_old(ispin),ls_scf_env%matrix_s, ls_scf_env%matrix_s_inv, & - nelectron_spin_real,ls_scf_env%eps_filter,error) + nelectron_spin_real,ls_scf_env%eps_filter) CASE(ls_scf_tc2) CALL density_matrix_tc2(ls_scf_env%matrix_p(ispin), matrix_mixing_old(ispin), ls_scf_env%matrix_s_sqrt_inv,& nelectron_spin_real, ls_scf_env%eps_filter, ls_scf_env%homo_spin(ispin),& ls_scf_env%lumo_spin(ispin), non_monotonic=ls_scf_env%non_monotonic, & - eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos,& - error=error) + eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos) CASE(ls_scf_trs4) CALL density_matrix_trs4(ls_scf_env%matrix_p(ispin), matrix_mixing_old(ispin), ls_scf_env%matrix_s_sqrt_inv,& nelectron_spin_real, ls_scf_env%eps_filter, ls_scf_env%homo_spin(ispin),& ls_scf_env%lumo_spin(ispin), ls_scf_env%mu_spin(ispin), & dynamic_threshold=ls_scf_env%dynamic_threshold,& matrix_ks_deviation=matrix_ks_deviation(ispin), & - eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos,& - error=error) + eps_lanczos=ls_scf_env%eps_lanczos, max_iter_lanczos=ls_scf_env%max_iter_lanczos) CASE(ls_scf_pexsi) CALL cp_assert(.NOT.(ls_scf_env%has_s_preconditioner),cp_failure_level,cp_assertion_failed, routineP, & "S preconditioning not implemented in combination with the PEXSI library. ", & - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) CALL cp_assert(ls_scf_env%ls_mstruct%cluster_type .EQ. ls_cluster_atomic, cp_failure_level, cp_assertion_failed, & routineP,"Molecular clustering not implemented in combination with the PEXSI library. ", & - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) CALL cp_assert(.NOT. ls_scf_env%ls_mstruct%single_precision,cp_failure_level,cp_assertion_failed, routineP, & - "PEXSI library requires double precision datatype. ", only_ionode=.TRUE.,error=error) + "PEXSI library requires double precision datatype. ", only_ionode=.TRUE.) CALL density_matrix_pexsi(ls_scf_env%pexsi, ls_scf_env%matrix_p(ispin), ls_scf_env%pexsi%matrix_w(ispin),& ls_scf_env%pexsi%kTS(ispin), matrix_mixing_old(ispin), ls_scf_env%matrix_s,& - nelectron_spin_real,ls_scf_env%mu_spin(ispin),iscf,ispin,error) + nelectron_spin_real,ls_scf_env%mu_spin(ispin),iscf,ispin) END SELECT END IF IF (ls_scf_env%has_s_preconditioner) THEN CALL apply_matrix_preconditioner(ls_scf_env%matrix_p(ispin),"forward", & - ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv,error) + ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv) ENDIF - CALL cp_dbcsr_filter(ls_scf_env%matrix_p(ispin),ls_scf_env%eps_filter,error=error) + CALL cp_dbcsr_filter(ls_scf_env%matrix_p(ispin),ls_scf_env%eps_filter) - IF (ls_scf_env%nspins==1) CALL cp_dbcsr_scale(ls_scf_env%matrix_p(ispin),2.0_dp,error=error) + IF (ls_scf_env%nspins==1) CALL cp_dbcsr_scale(ls_scf_env%matrix_p(ispin),2.0_dp) ENDDO END IF ! compute the corresponding new energy KS matrix and new energy - CALL ls_scf_dm_to_ks(qs_env,ls_scf_env,energy_new,iscf,error) + CALL ls_scf_dm_to_ks(qs_env,ls_scf_env,energy_new,iscf) IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) THEN - CALL pexsi_to_qs(ls_scf_env, qs_env, kTS = ls_scf_env%pexsi%kTS, error = error) + CALL pexsi_to_qs(ls_scf_env, qs_env, kTS = ls_scf_env%pexsi%kTS) ENDIF ! report current SCF loop @@ -1242,7 +1220,7 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) ! 3) B matrix (for finding DIIS weighting coefficients) CALL qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr, & iscf,diis_step,eps_diis,nmixing,matrix_s(1)%matrix, & - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) ENDIF IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) THEN @@ -1250,18 +1228,18 @@ SUBROUTINE ls_scf_main(qs_env,ls_scf_env,error) ls_scf_env%eps_scf*ls_scf_env%nelectron_total, & ! initialize in second scf step of first SCF cycle: (iscf.EQ.2).AND.(ls_scf_env%scf_history%istore.EQ.0), & - check_convergence, error) + check_convergence) ENDIF ENDDO ! free storage IF (ls_scf_env%ls_diis) THEN - CALL qs_diis_b_release_sparse(diis_buffer,error) + CALL qs_diis_b_release_sparse(diis_buffer) ENDIF DO ispin=1,nspin - CALL cp_dbcsr_release(matrix_mixing_old(ispin),error=error) - CALL cp_dbcsr_release(matrix_ks_deviation(ispin),error=error) + CALL cp_dbcsr_release(matrix_mixing_old(ispin)) + CALL cp_dbcsr_release(matrix_ks_deviation(ispin)) ENDDO DEALLOCATE(matrix_mixing_old, matrix_ks_deviation) @@ -1275,15 +1253,13 @@ END SUBROUTINE ls_scf_main !> analyze its properties. !> \param qs_env ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_post(qs_env,ls_scf_env,error) + SUBROUTINE ls_scf_post(qs_env,ls_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_post', & routineP = moduleN//':'//routineN @@ -1296,7 +1272,7 @@ SUBROUTINE ls_scf_post(qs_env,ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1304,68 +1280,68 @@ SUBROUTINE ls_scf_post(qs_env,ls_scf_env,error) ENDIF ! store the matrix for a next scf run - CALL ls_scf_store_result(ls_scf_env,error) + CALL ls_scf_store_result(ls_scf_env) ! write homo and lumo energy (if not already part of the output) IF (ls_scf_env%curvy_steps) THEN - CALL post_scf_homo_lumo(ls_scf_env,error) + CALL post_scf_homo_lumo(ls_scf_env) ENDIF ! compute the matrix_w if associated - CALL get_qs_env(qs_env,matrix_w=matrix_w,error=error) + CALL get_qs_env(qs_env,matrix_w=matrix_w) IF (ASSOCIATED(matrix_w)) THEN IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) THEN - CALL pexsi_to_qs(ls_scf_env, qs_env, matrix_w = ls_scf_env%pexsi%matrix_w, error=error) + CALL pexsi_to_qs(ls_scf_env, qs_env, matrix_w = ls_scf_env%pexsi%matrix_w) ELSE - CALL calculate_w_matrix(matrix_w,ls_scf_env,error=error) + CALL calculate_w_matrix(matrix_w,ls_scf_env) ENDIF ENDIF ! compute properties - IF (ls_scf_env%perform_mu_scan) CALL post_scf_mu_scan(ls_scf_env,error) + IF (ls_scf_env%perform_mu_scan) CALL post_scf_mu_scan(ls_scf_env) - IF (ls_scf_env%report_all_sparsities) CALL post_scf_sparsities(ls_scf_env,error) + IF (ls_scf_env%report_all_sparsities) CALL post_scf_sparsities(ls_scf_env) - CALL write_mo_free_results(qs_env,error) + CALL write_mo_free_results(qs_env) - IF (ls_scf_env%chebyshev%compute_chebyshev) CALL compute_chebyshev(qs_env,ls_scf_env,error) + IF (ls_scf_env%chebyshev%compute_chebyshev) CALL compute_chebyshev(qs_env,ls_scf_env) - IF (.TRUE.) CALL post_scf_experiment(ls_scf_env,error) + IF (.TRUE.) CALL post_scf_experiment(ls_scf_env) - CALL qs_scf_post_moments(qs_env%input, logger, qs_env, unit_nr, error=error) + CALL qs_scf_post_moments(qs_env%input, logger, qs_env, unit_nr) ! clean up used data - CALL cp_dbcsr_release(ls_scf_env%matrix_s,error=error) - CALL deallocate_curvy_data(ls_scf_env%curvy_data,error) + CALL cp_dbcsr_release(ls_scf_env%matrix_s) + CALL deallocate_curvy_data(ls_scf_env%curvy_data) IF (ls_scf_env%has_s_preconditioner) THEN - CALL cp_dbcsr_release(ls_scf_env%matrix_bs_sqrt,error=error) - CALL cp_dbcsr_release(ls_scf_env%matrix_bs_sqrt_inv,error=error) + CALL cp_dbcsr_release(ls_scf_env%matrix_bs_sqrt) + CALL cp_dbcsr_release(ls_scf_env%matrix_bs_sqrt_inv) ENDIF IF (ls_scf_env%needs_s_inv) THEN - CALL cp_dbcsr_release(ls_scf_env%matrix_s_inv,error=error) + CALL cp_dbcsr_release(ls_scf_env%matrix_s_inv) ENDIF IF (ls_scf_env%use_s_sqrt) THEN - CALL cp_dbcsr_release(ls_scf_env%matrix_s_sqrt,error=error) - CALL cp_dbcsr_release(ls_scf_env%matrix_s_sqrt_inv,error=error) + CALL cp_dbcsr_release(ls_scf_env%matrix_s_sqrt) + CALL cp_dbcsr_release(ls_scf_env%matrix_s_sqrt_inv) ENDIF DO ispin=1,SIZE(ls_scf_env%matrix_p) - CALL cp_dbcsr_release(ls_scf_env%matrix_p(ispin),error=error) + CALL cp_dbcsr_release(ls_scf_env%matrix_p(ispin)) ENDDO DEALLOCATE(ls_scf_env%matrix_p) DO ispin=1,SIZE(ls_scf_env%matrix_ks) - CALL cp_dbcsr_release(ls_scf_env%matrix_ks(ispin),error=error) + CALL cp_dbcsr_release(ls_scf_env%matrix_ks(ispin)) ENDDO DEALLOCATE(ls_scf_env%matrix_ks) IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) & - CALL pexsi_finalize_scf(ls_scf_env%pexsi, ls_scf_env%mu_spin, error) + CALL pexsi_finalize_scf(ls_scf_env%pexsi, ls_scf_env%mu_spin) CALL timestop(handle) @@ -1374,14 +1350,12 @@ END SUBROUTINE ls_scf_post ! ***************************************************************************** !> \brief Compute the HOMO LUMO energies post SCF !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2013.06 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE post_scf_homo_lumo(ls_scf_env,error) + SUBROUTINE post_scf_homo_lumo(ls_scf_env) TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_scf_homo_lumo', & routineP = moduleN//':'//routineN @@ -1396,7 +1370,7 @@ SUBROUTINE post_scf_homo_lumo(ls_scf_env,error) failure=.FALSE. ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1406,43 +1380,43 @@ SUBROUTINE post_scf_homo_lumo(ls_scf_env,error) IF (unit_nr>0) WRITE(unit_nr,'(T2,A)') "" ! TODO: remove these limitations - CPPrecondition(.NOT.ls_scf_env%has_s_preconditioner,cp_failure_level,routineP,error,failure) - CPPrecondition(ls_scf_env%use_s_sqrt,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ls_scf_env%has_s_preconditioner,cp_failure_level,routineP,failure) + CPPrecondition(ls_scf_env%use_s_sqrt,cp_failure_level,routineP,failure) nspin=ls_scf_env%nspins - CALL cp_dbcsr_init(matrix_p,error=error) - CALL cp_dbcsr_create(matrix_p,template=ls_scf_env%matrix_p(1), matrix_type=dbcsr_type_no_symmetry, error=error) + CALL cp_dbcsr_init(matrix_p) + CALL cp_dbcsr_create(matrix_p,template=ls_scf_env%matrix_p(1), matrix_type=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init(matrix_k,error=error) - CALL cp_dbcsr_create(matrix_k,template=ls_scf_env%matrix_p(1), matrix_type=dbcsr_type_no_symmetry, error=error) + CALL cp_dbcsr_init(matrix_k) + CALL cp_dbcsr_create(matrix_k,template=ls_scf_env%matrix_p(1), matrix_type=dbcsr_type_no_symmetry) DO ispin=1,nspin ! ortho basis ks CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt_inv, ls_scf_env%matrix_ks(ispin),& - 0.0_dp, matrix_k, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_k, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_k, ls_scf_env%matrix_s_sqrt_inv, & - 0.0_dp, matrix_k, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_k, filter_eps=ls_scf_env%eps_filter) ! extremal eigenvalues ks CALL cp_dbcsr_arnoldi_extremal(matrix_k, eps_max, eps_min, max_iter=ls_scf_env%max_iter_lanczos, & - threshold=ls_scf_env%eps_lanczos, converged=converged, error=error) + threshold=ls_scf_env%eps_lanczos, converged=converged) ! ortho basis p CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt, ls_scf_env%matrix_p(ispin),& - 0.0_dp, matrix_p, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_p, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p, ls_scf_env%matrix_s_sqrt, & - 0.0_dp, matrix_p, filter_eps=ls_scf_env%eps_filter,error=error) - IF(nspin==1)CALL cp_dbcsr_scale(matrix_p,0.5_dp,error=error) + 0.0_dp, matrix_p, filter_eps=ls_scf_env%eps_filter) + IF(nspin==1)CALL cp_dbcsr_scale(matrix_p,0.5_dp) ! go compute homo lumo CALL compute_homo_lumo(matrix_k,matrix_p,eps_min,eps_max,ls_scf_env%eps_filter, & - ls_scf_env%max_iter_lanczos,ls_scf_env%eps_lanczos,homo,lumo,unit_nr,error) + ls_scf_env%max_iter_lanczos,ls_scf_env%eps_lanczos,homo,lumo,unit_nr) ENDDO - CALL cp_dbcsr_release(matrix_p,error=error) - CALL cp_dbcsr_release(matrix_k,error=error) + CALL cp_dbcsr_release(matrix_p) + CALL cp_dbcsr_release(matrix_k) CALL timestop(handle) @@ -1451,14 +1425,12 @@ END SUBROUTINE post_scf_homo_lumo ! ***************************************************************************** !> \brief Compute the density matrix for various values of the chemical potential !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE post_scf_mu_scan(ls_scf_env,error) + SUBROUTINE post_scf_mu_scan(ls_scf_env) TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_scf_mu_scan', & routineP = moduleN//':'//routineN @@ -1473,7 +1445,7 @@ SUBROUTINE post_scf_mu_scan(ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1482,8 +1454,8 @@ SUBROUTINE post_scf_mu_scan(ls_scf_env,error) nspin=ls_scf_env%nspins - CALL cp_dbcsr_init(matrix_p,error=error) - CALL cp_dbcsr_create(matrix_p,template=ls_scf_env%matrix_p(1),error=error) + CALL cp_dbcsr_init(matrix_p) + CALL cp_dbcsr_create(matrix_p,template=ls_scf_env%matrix_p(1)) nmu=10 DO imu=0,nmu @@ -1501,7 +1473,7 @@ SUBROUTINE post_scf_mu_scan(ls_scf_env,error) CALL density_matrix_sign_fixed_mu(matrix_p,trace,mu, & ls_scf_env%matrix_ks(ispin),ls_scf_env%matrix_s,& - ls_scf_env%matrix_s_inv,ls_scf_env%eps_filter,error) + ls_scf_env%matrix_s_inv,ls_scf_env%eps_filter) ENDDO t2 = m_walltime() @@ -1510,7 +1482,7 @@ SUBROUTINE post_scf_mu_scan(ls_scf_env,error) ENDDO - CALL cp_dbcsr_release(matrix_p,error=error) + CALL cp_dbcsr_release(matrix_p) CALL timestop(handle) @@ -1520,14 +1492,12 @@ END SUBROUTINE post_scf_mu_scan !> \brief Report on the sparsities of various interesting matrices. !> !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE post_scf_sparsities(ls_scf_env,error) + SUBROUTINE post_scf_sparsities(ls_scf_env) TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_scf_sparsities', & routineP = moduleN//':'//routineN @@ -1540,7 +1510,7 @@ SUBROUTINE post_scf_sparsities(ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1556,77 +1526,77 @@ SUBROUTINE post_scf_sparsities(ls_scf_env,error) ENDIF CALL report_matrix_sparsity(ls_scf_env%matrix_s,unit_nr,"overlap matrix (S)", & - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) DO ispin=1,nspin WRITE(title,'(A,I3)') "Kohn-Sham matrix (H) for spin ",ispin CALL report_matrix_sparsity(ls_scf_env%matrix_ks(ispin),unit_nr,title, & - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) ENDDO - CALL cp_dbcsr_init(matrix_tmp1,error=error) - CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) - CALL cp_dbcsr_create(matrix_tmp2,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_tmp1) + CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) + CALL cp_dbcsr_create(matrix_tmp2,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) DO ispin=1,nspin WRITE(title,'(A,I3)') "Density matrix (P) for spin ",ispin CALL report_matrix_sparsity(ls_scf_env%matrix_p(ispin),unit_nr,title, & - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s, ls_scf_env%matrix_p(ispin), & - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) WRITE(title,'(A,I3,A)') "S * P(",ispin,")" - CALL report_matrix_sparsity(matrix_tmp1,unit_nr,title, ls_scf_env%eps_filter,error) + CALL report_matrix_sparsity(matrix_tmp1,unit_nr,title, ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_s, & - 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter, error=error) + 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter) WRITE(title,'(A,I3,A)') "S * P(",ispin,") * S" - CALL report_matrix_sparsity(matrix_tmp2,unit_nr,title, ls_scf_env%eps_filter,error) + CALL report_matrix_sparsity(matrix_tmp2,unit_nr,title, ls_scf_env%eps_filter) ENDDO IF (ls_scf_env%needs_s_inv) THEN CALL report_matrix_sparsity(ls_scf_env%matrix_s_inv,unit_nr,"inv(S)", & - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) DO ispin=1,nspin CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_inv, ls_scf_env%matrix_ks(ispin), & - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) WRITE(title,'(A,I3,A)') "inv(S) * H(",ispin,")" - CALL report_matrix_sparsity(matrix_tmp1,unit_nr,title, ls_scf_env%eps_filter,error) + CALL report_matrix_sparsity(matrix_tmp1,unit_nr,title, ls_scf_env%eps_filter) ENDDO ENDIF IF (ls_scf_env%use_s_sqrt) THEN CALL report_matrix_sparsity(ls_scf_env%matrix_s_sqrt,unit_nr,"sqrt(S)", & - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) CALL report_matrix_sparsity(ls_scf_env%matrix_s_sqrt_inv,unit_nr,"inv(sqrt(S))", & - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) DO ispin=1,nspin CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt_inv, ls_scf_env%matrix_ks(ispin), & - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_s_sqrt_inv, & - 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter) WRITE(title,'(A,I3,A)') "inv(sqrt(S)) * H(",ispin,") * inv(sqrt(S))" - CALL report_matrix_sparsity(matrix_tmp2,unit_nr,title, ls_scf_env%eps_filter,error) + CALL report_matrix_sparsity(matrix_tmp2,unit_nr,title, ls_scf_env%eps_filter) ENDDO DO ispin=1,nspin CALL cp_dbcsr_multiply("N", "N", 1.0_dp, ls_scf_env%matrix_s_sqrt, ls_scf_env%matrix_p(ispin), & - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_s_sqrt, & - 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter) WRITE(title,'(A,I3,A)') "sqrt(S) * P(",ispin,") * sqrt(S)" - CALL report_matrix_sparsity(matrix_tmp2,unit_nr,title, ls_scf_env%eps_filter,error) + CALL report_matrix_sparsity(matrix_tmp2,unit_nr,title, ls_scf_env%eps_filter) ENDDO ENDIF - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) CALL timestop(handle) @@ -1639,17 +1609,15 @@ END SUBROUTINE post_scf_sparsities !> \param unit_nr ... !> \param title ... !> \param eps ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE report_matrix_sparsity(matrix,unit_nr,title,eps,error) + SUBROUTINE report_matrix_sparsity(matrix,unit_nr,title,eps) TYPE(cp_dbcsr_type) :: matrix INTEGER :: unit_nr CHARACTER(LEN=*) :: title REAL(KIND=dp) :: eps - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'report_matrix_sparsity', & routineP = moduleN//':'//routineN @@ -1659,9 +1627,9 @@ SUBROUTINE report_matrix_sparsity(matrix,unit_nr,title,eps,error) TYPE(cp_dbcsr_type) :: matrix_tmp CALL timeset(routineN,handle) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix,name=TRIM(title),error=error) - CALL cp_dbcsr_copy(matrix_tmp,matrix,name=TRIM(title),error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix,name=TRIM(title)) + CALL cp_dbcsr_copy(matrix_tmp,matrix,name=TRIM(title)) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A)') "Sparsity for : "//TRIM(title) @@ -1670,13 +1638,13 @@ SUBROUTINE report_matrix_sparsity(matrix,unit_nr,title,eps,error) eps_local=eps DO IF (eps_local>1.1_dp) EXIT - CALL cp_dbcsr_filter(matrix_tmp,eps_local,error=error) + CALL cp_dbcsr_filter(matrix_tmp,eps_local) occ=cp_dbcsr_get_occupation(matrix_tmp) IF (unit_nr>0) WRITE(unit_nr,'(T2,F16.12,A3,F16.12)') eps_local," : ",occ eps_local=eps_local*10 ENDDO - CALL cp_dbcsr_release(matrix_tmp,error=error) + CALL cp_dbcsr_release(matrix_tmp) CALL timestop(handle) @@ -1686,16 +1654,14 @@ END SUBROUTINE report_matrix_sparsity !> \brief Compute matrix_w as needed for the forces !> \param matrix_w ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.11 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE calculate_w_matrix(matrix_w,ls_scf_env,error) + SUBROUTINE calculate_w_matrix(matrix_w,ls_scf_env) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_w TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_w_matrix', & routineP = moduleN//':'//routineN @@ -1707,12 +1673,12 @@ SUBROUTINE calculate_w_matrix(matrix_w,ls_scf_env,error) CALL timeset(routineN,handle) - CALL cp_dbcsr_init(matrix_tmp1,error=error) - CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp2,error=error) - CALL cp_dbcsr_create(matrix_tmp2,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp3,error=error) - CALL cp_dbcsr_create(matrix_tmp3,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_tmp1) + CALL cp_dbcsr_create(matrix_tmp1,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp2) + CALL cp_dbcsr_create(matrix_tmp2,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp3) + CALL cp_dbcsr_create(matrix_tmp3,template=ls_scf_env%matrix_s,matrix_type=dbcsr_type_no_symmetry) IF (ls_scf_env%nspins==1) THEN scaling=0.5_dp @@ -1723,23 +1689,23 @@ SUBROUTINE calculate_w_matrix(matrix_w,ls_scf_env,error) DO ispin=1,ls_scf_env%nspins - CALL cp_dbcsr_copy(matrix_tmp3,ls_scf_env%matrix_ks(ispin),error=error) + CALL cp_dbcsr_copy(matrix_tmp3,ls_scf_env%matrix_ks(ispin)) IF (ls_scf_env%has_s_preconditioner) THEN CALL apply_matrix_preconditioner(matrix_tmp3,"backward", & - ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv,error) + ls_scf_env%matrix_bs_sqrt,ls_scf_env%matrix_bs_sqrt_inv) ENDIF - CALL cp_dbcsr_filter(matrix_tmp3,ls_scf_env%eps_filter,error=error) + CALL cp_dbcsr_filter(matrix_tmp3,ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", scaling, ls_scf_env%matrix_p(ispin), matrix_tmp3, & - 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter,error=error) + 0.0_dp, matrix_tmp1, filter_eps=ls_scf_env%eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp1, ls_scf_env%matrix_p(ispin),& - 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter,error=error) - CALL matrix_ls_to_qs(matrix_w(ispin)%matrix, matrix_tmp2, ls_scf_env%ls_mstruct, error=error) + 0.0_dp, matrix_tmp2, filter_eps=ls_scf_env%eps_filter) + CALL matrix_ls_to_qs(matrix_w(ispin)%matrix, matrix_tmp2, ls_scf_env%ls_mstruct) ENDDO - CALL cp_dbcsr_release(matrix_tmp1,error=error) - CALL cp_dbcsr_release(matrix_tmp2,error=error) - CALL cp_dbcsr_release(matrix_tmp3,error=error) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_tmp2) + CALL cp_dbcsr_release(matrix_tmp3) CALL timestop(handle) @@ -1748,14 +1714,12 @@ END SUBROUTINE calculate_w_matrix ! ***************************************************************************** !> \brief a place for quick experiments !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2010.11 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE post_scf_experiment(ls_scf_env,error) + SUBROUTINE post_scf_experiment(ls_scf_env) TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_scf_experiment', & routineP = moduleN//':'//routineN @@ -1766,7 +1730,7 @@ SUBROUTINE post_scf_experiment(ls_scf_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE diff --git a/src/dm_ls_scf_curvy.F b/src/dm_ls_scf_curvy.F index 4b9b051c2f..b159256e2b 100644 --- a/src/dm_ls_scf_curvy.F +++ b/src/dm_ls_scf_curvy.F @@ -47,17 +47,15 @@ MODULE dm_ls_scf_curvy !> \param ls_scf_env ... !> \param energy ... !> \param check_conv ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE dm_ls_curvy_optimization(ls_scf_env,energy,check_conv,error) + SUBROUTINE dm_ls_curvy_optimization(ls_scf_env,energy,check_conv) TYPE(ls_scf_env_type) :: ls_scf_env REAL(KIND=dp) :: energy LOGICAL :: check_conv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dm_ls_curvy_optimization', & routineP = moduleN//':'//routineN @@ -77,21 +75,21 @@ SUBROUTINE dm_ls_curvy_optimization(ls_scf_env,energy,check_conv,error) ! TRS4 might give nondiempotent P therefore McWeeny purification is applied on initial P IF(.NOT.ALLOCATED(ls_scf_env%curvy_data%matrix_dp))THEN - CALL init_curvy(ls_scf_env%curvy_data,ls_scf_env%matrix_s,ls_scf_env%nspins,error) + CALL init_curvy(ls_scf_env%curvy_data,ls_scf_env%matrix_s,ls_scf_env%nspins) ls_scf_env%curvy_data%line_search_step=1 IF(ls_scf_env%curvy_data%line_search_type==ls_scf_line_search_3point_2d)THEN DO i=1,ls_scf_env%nspins CALL cp_dbcsr_copy(ls_scf_env%curvy_data%matrix_psave(i,1),& - ls_scf_env%matrix_p(i),error=error) + ls_scf_env%matrix_p(i)) END DO END IF - IF(ls_scf_env%nspins==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(1),0.5_dp,error=error) + IF(ls_scf_env%nspins==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(1),0.5_dp) CALL transform_matrix_orth(ls_scf_env%matrix_p,ls_scf_env%matrix_s_sqrt,& - ls_scf_env%eps_filter,error) - CALL purify_mcweeny(ls_scf_env%matrix_p,ls_scf_env%eps_filter,3,error) + ls_scf_env%eps_filter) + CALL purify_mcweeny(ls_scf_env%matrix_p,ls_scf_env%eps_filter,3) DO i=1,ls_scf_env%nspins - CALL cp_dbcsr_copy(ls_scf_env%curvy_data%matrix_p(i),ls_scf_env%matrix_p(i),error=error) + CALL cp_dbcsr_copy(ls_scf_env%curvy_data%matrix_p(i),ls_scf_env%matrix_p(i)) END DO END IF @@ -101,7 +99,7 @@ SUBROUTINE dm_ls_curvy_optimization(ls_scf_env,energy,check_conv,error) IF(ls_scf_env%curvy_data%line_search_step==1)& CALL transform_matrix_orth(ls_scf_env%matrix_ks,ls_scf_env%matrix_s_sqrt_inv,& - ls_scf_env%eps_filter,error) + ls_scf_env%eps_filter) ! Set the energies for the line search and make sure to give the correct energy back to scf_main ls_scf_env%curvy_data%energies(lsstep)=energy @@ -109,13 +107,13 @@ SUBROUTINE dm_ls_curvy_optimization(ls_scf_env,energy,check_conv,error) ! start the optimization by calling the driver routine or simply combine saved P(2D line search) IF(lsstep.le.2)THEN - CALL optimization_step(ls_scf_env%curvy_data,ls_scf_env,error) + CALL optimization_step(ls_scf_env%curvy_data,ls_scf_env) ELSE IF(lsstep==ls_scf_env%curvy_data%line_search_type)THEN ! line_search type has the value appropriate to the number of energy calculations needed - CALL optimization_step(ls_scf_env%curvy_data,ls_scf_env,error) + CALL optimization_step(ls_scf_env%curvy_data,ls_scf_env) ELSE CALL new_p_from_save(ls_scf_env%matrix_p,ls_scf_env%curvy_data%matrix_psave,lsstep,& - ls_scf_env%curvy_data%double_step_size,error) + ls_scf_env%curvy_data%double_step_size) ls_scf_env%curvy_data%line_search_step=ls_scf_env%curvy_data%line_search_step+1 CALL timestop(handle) RETURN @@ -125,14 +123,14 @@ SUBROUTINE dm_ls_curvy_optimization(ls_scf_env,energy,check_conv,error) ! transform new density matrix back into nonorthonormal basis (again scaling might apply) CALL transform_matrix_orth(ls_scf_env%matrix_p,ls_scf_env%matrix_s_sqrt_inv,& - ls_scf_env%eps_filter,error) - IF(ls_scf_env%nspins==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(1),2.0_dp,error=error) + ls_scf_env%eps_filter) + IF(ls_scf_env%nspins==1)CALL cp_dbcsr_scale(ls_scf_env%matrix_p(1),2.0_dp) ! P-matrices only need to be stored in case of 2D line search IF(lsstep.le.3.AND.ls_scf_env%curvy_data%line_search_type==ls_scf_line_search_3point_2d)THEN DO i=1,ls_scf_env%nspins CALL cp_dbcsr_copy(ls_scf_env%curvy_data%matrix_psave(i,lsstep),& - ls_scf_env%matrix_p(i),error=error) + ls_scf_env%matrix_p(i)) END DO END IF check_conv=lsstep==1 @@ -148,16 +146,14 @@ END SUBROUTINE dm_ls_curvy_optimization !> and evaluates the BCH series to obtain the new P matrix !> \param curvy_data ... !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE optimization_step(curvy_data,ls_scf_env,error) + SUBROUTINE optimization_step(curvy_data,ls_scf_env) TYPE(ls_scf_curvy_type) :: curvy_data TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'optimization_step', & routineP = moduleN//':'//routineN @@ -177,7 +173,7 @@ SUBROUTINE optimization_step(curvy_data,ls_scf_env,error) ls_scf_env%eps_filter*curvy_data%filter_factor) CALL compute_direction_newton(curvy_data%matrix_p, ls_scf_env%matrix_ks,& curvy_data%matrix_dp,filter, curvy_data%fix_shift, curvy_data%shift,& - curvy_data%cg_numer, curvy_data%cg_denom, curvy_data%min_shift,error) + curvy_data%cg_numer, curvy_data%cg_denom, curvy_data%min_shift) curvy_data%filter_factor=curvy_data%scale_filter*curvy_data%filter_factor step_size=curvy_data%step_size curvy_data%BCH_saved=0 @@ -192,23 +188,23 @@ SUBROUTINE optimization_step(curvy_data,ls_scf_env,error) END IF step_size=curvy_data%step_size ELSE IF(curvy_data%line_search_step==ls_scf_line_search_3point_2d)THEN - CALL line_search_2d(curvy_data%energies,curvy_data%step_size,error) + CALL line_search_2d(curvy_data%energies,curvy_data%step_size) step_size=curvy_data%step_size ELSE IF(curvy_data%line_search_step==ls_scf_line_search_3point)THEN - CALL line_search_3pnt(curvy_data%energies,curvy_data%step_size,error) + CALL line_search_3pnt(curvy_data%energies,curvy_data%step_size) step_size=curvy_data%step_size END IF CALL update_p_exp (curvy_data%matrix_p,ls_scf_env%matrix_p,curvy_data%matrix_dp,& curvy_data%matrix_BCH,ls_scf_env%eps_filter,step_size,curvy_data%BCH_saved,& - curvy_data%n_bch_hist,error) + curvy_data%n_bch_hist) ! line_search type has the value appropriate to the numeber of energy calculations needed curvy_data%line_search_step=MOD(curvy_data%line_search_step,curvy_data%line_search_type)+1 IF(curvy_data%line_search_step==1)THEN DO ispin=1,SIZE(curvy_data%matrix_p) - CALL cp_dbcsr_copy(curvy_data%matrix_p(ispin),ls_scf_env%matrix_p(ispin),error=error) + CALL cp_dbcsr_copy(curvy_data%matrix_p(ispin),ls_scf_env%matrix_p(ispin)) END DO END IF CALL timestop(handle) @@ -220,15 +216,13 @@ END SUBROUTINE optimization_step !> Fit a 2D parabolic function to 6 points !> \param energies ... !> \param step_size ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE line_search_2d(energies,step_size,error) + SUBROUTINE line_search_2d(energies,step_size) REAL(KIND=dp) :: energies(6), step_size(2) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'line_search_2d', & routineP = moduleN//':'//routineN @@ -239,7 +233,7 @@ SUBROUTINE line_search_2d(energies,step_size,error) tmp_e, v1, v2 TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF(energies(1)-energies(2).lt.0._dp)THEN tmp_e=energies(2); energies(2)=energies(3); energies(3)=tmp_e step_size=step_size*2.0_dp @@ -257,7 +251,7 @@ SUBROUTINE line_search_2d(energies,step_size,error) sys_lin_eq(5,1)=s1sq;sys_lin_eq(5,4)=s1 sys_lin_eq(6,3)=s2sq;sys_lin_eq(6,5)=s2 - CALL invmat(sys_lin_eq,info,error) + CALL invmat(sys_lin_eq,info) param=MATMUL(sys_lin_eq,energies) v1=(param(2)*param(4))/(2.0_dp*param(1))-param(5) v2=-(param(2)**2)/(2.0_dp*param(1))+2.0_dp*param(3) @@ -280,15 +274,13 @@ END SUBROUTINE line_search_2d !> \brief Perform a 3pnt line search !> \param energies ... !> \param step_size ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE line_search_3pnt(energies,step_size,error) + SUBROUTINE line_search_3pnt(energies,step_size) REAL(KIND=dp) :: energies(3), step_size(2) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'line_search_3pnt', & routineP = moduleN//':'//routineN @@ -298,7 +290,7 @@ SUBROUTINE line_search_3pnt(energies,step_size,error) step1, tmp, tmp_e TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF(energies(1)-energies(2).lt.0._dp)THEN tmp_e=energies(2); energies(2)=energies(3); energies(3)=tmp_e step_size=step_size*2.0_dp @@ -341,20 +333,18 @@ END SUBROUTINE line_search_3pnt !> \param cg_numer ... !> \param cg_denom ... !> \param min_shift ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** SUBROUTINE compute_direction_newton(matrix_p,matrix_ks,matrix_dp,eps_filter,fix_shift,& - curvy_shift,cg_numer,cg_denom,min_shift,error) + curvy_shift,cg_numer,cg_denom,min_shift) TYPE(cp_dbcsr_type), DIMENSION(:) :: matrix_p, matrix_ks, matrix_dp REAL(KIND=dp) :: eps_filter LOGICAL :: fix_shift(2) REAL(KIND=dp) :: curvy_shift(2), cg_numer(2), & cg_denom(2), min_shift - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_direction_newton', & routineP = moduleN//':'//routineN @@ -368,7 +358,7 @@ SUBROUTINE compute_direction_newton(matrix_p,matrix_ks,matrix_dp,eps_filter,fix_ matrix_PKs, matrix_res, matrix_tmp, matrix_tmp1 TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) @@ -378,43 +368,43 @@ SUBROUTINE compute_direction_newton(matrix_p,matrix_ks,matrix_dp,eps_filter,fix_ CALL timeset(routineN,handle) nspin=SIZE(matrix_p) - CALL cp_dbcsr_init(matrix_PKs,error=error) - CALL cp_dbcsr_create(matrix_PKs,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_Ax,error=error) - CALL cp_dbcsr_create(matrix_Ax,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp1,error=error) - CALL cp_dbcsr_create(matrix_tmp1,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_res,error=error) - CALL cp_dbcsr_create(matrix_res,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_cg,error=error) - CALL cp_dbcsr_create(matrix_cg,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_b,error=error) - CALL cp_dbcsr_create(matrix_b,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_dp_old,error=error) - CALL cp_dbcsr_create(matrix_dp_old,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_PKs) + CALL cp_dbcsr_create(matrix_PKs,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_Ax) + CALL cp_dbcsr_create(matrix_Ax,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp1) + CALL cp_dbcsr_create(matrix_tmp1,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_res) + CALL cp_dbcsr_create(matrix_res,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_cg) + CALL cp_dbcsr_create(matrix_cg,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_b) + CALL cp_dbcsr_create(matrix_b,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_dp_old) + CALL cp_dbcsr_create(matrix_dp_old,template=matrix_dp(1),matrix_type=dbcsr_type_no_symmetry) DO ispin=1,nspin - CALL cp_dbcsr_copy(matrix_dp_old,matrix_dp(ispin),error=error) + CALL cp_dbcsr_copy(matrix_dp_old,matrix_dp(ispin)) ! Precompute some matrices to save work during iterations CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p(ispin), matrix_ks(ispin),& - 0.0_dp, matrix_PKs, filter_eps=eps_filter,error=error) - CALL cp_dbcsr_transposed(matrix_b,matrix_PKs,error=error) - CALL cp_dbcsr_copy(matrix_cg,matrix_b,error=error) + 0.0_dp, matrix_PKs, filter_eps=eps_filter) + CALL cp_dbcsr_transposed(matrix_b,matrix_PKs) + CALL cp_dbcsr_copy(matrix_cg,matrix_b) ! Starting CG with guess 0-matrix gives -2*gradient=[Ks*P-(Ks*P)T] for cg_matrix in second step - CALL cp_dbcsr_add(matrix_cg,matrix_PKs,2.0_dp,-2.0_dp,error=error) + CALL cp_dbcsr_add(matrix_cg,matrix_PKs,2.0_dp,-2.0_dp) ! Residual matrix in first step=cg matrix. Keep Pks for later use in CG! - CALL cp_dbcsr_copy(matrix_res,matrix_cg,error=error) + CALL cp_dbcsr_copy(matrix_res,matrix_cg) ! Precompute -FP-[FP]T which will be used throughout the CG iterations - CALL cp_dbcsr_add(matrix_b,matrix_PKs, -1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_add(matrix_b,matrix_PKs, -1.0_dp,-1.0_dp) ! Setup some values to check convergence and safty checks for eigenvalue shifting - CALL cp_dbcsr_norm(matrix_res,which_norm=2,norm_scalar=old_conv,error=error) + CALL cp_dbcsr_norm(matrix_res,which_norm=2,norm_scalar=old_conv) old_conv=cp_dbcsr_frobenius_norm(matrix_res) shift=MIN(10.0_dp,MAX(min_shift,0.05_dp*old_conv)) conv_val=MAX(0.010_dp*old_conv,100.0_dp*eps_filter) @@ -425,25 +415,25 @@ SUBROUTINE compute_direction_newton(matrix_p,matrix_ks,matrix_dp,eps_filter,fix_ END IF ! Begin the real optimization loop - CALL cp_dbcsr_set(matrix_dp(ispin),0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_dp(ispin),0.0_dp) ncyc=10 DO i=1,ncyc ! One step to compute: -FPD-DPF-DFP-PFD (not obvious but symmetry allows for some tricks) - CALL commutator_symm(matrix_b,matrix_cg,matrix_Ax,eps_filter,1.0_dp,error) + CALL commutator_symm(matrix_b,matrix_cg,matrix_Ax,eps_filter,1.0_dp) ! Compute the missing bits 2*(FDP+PDF) (again use symmetry to compute as a commutator) CALL cp_dbcsr_multiply("N", "N",1.0_dp, matrix_cg,matrix_p(ispin), & - 0.0_dp, matrix_tmp, filter_eps=eps_filter,error=error) - CALL commutator_symm(matrix_ks(ispin),matrix_tmp,matrix_tmp1,eps_filter,2.0_dp,error) - CALL cp_dbcsr_add(matrix_Ax,matrix_tmp1,1.0_dp,1.0_dp,error=error) + 0.0_dp, matrix_tmp, filter_eps=eps_filter) + CALL commutator_symm(matrix_ks(ispin),matrix_tmp,matrix_tmp1,eps_filter,2.0_dp) + CALL cp_dbcsr_add(matrix_Ax,matrix_tmp1,1.0_dp,1.0_dp) ! Apply the shift and hope it's enough to stabilize the CG iterations - CALL cp_dbcsr_add(matrix_Ax,matrix_cg,1.0_dp,shift,error=error) + CALL cp_dbcsr_add(matrix_Ax,matrix_cg,1.0_dp,shift) CALL compute_cg_matrices(matrix_Ax,matrix_res,matrix_cg,matrix_dp(ispin),& - matrix_tmp,eps_filter,at_limit,error) - CALL cp_dbcsr_filter(matrix_cg,eps_filter,error=error) + matrix_tmp,eps_filter,at_limit) + CALL cp_dbcsr_filter(matrix_cg,eps_filter) ! check for convergence of the newton step maxel=cp_dbcsr_frobenius_norm(matrix_res) @@ -461,29 +451,29 @@ SUBROUTINE compute_direction_newton(matrix_p,matrix_ks,matrix_dp,eps_filter,fix_ END DO ! Refine the Newton like search direction with a preconditioned cg update - CALL cp_dbcsr_transposed(matrix_b,matrix_PKs, error=error) + CALL cp_dbcsr_transposed(matrix_b,matrix_PKs) !compute b= -2*KsP+2*PKs=-(2*gradient) - CALL cp_dbcsr_copy(matrix_cg,matrix_b,error=error) - CALL cp_dbcsr_add(matrix_cg,matrix_PKs,1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_copy(matrix_cg,matrix_b) + CALL cp_dbcsr_add(matrix_cg,matrix_PKs,1.0_dp,-1.0_dp) cg_denom(ispin)=cg_numer(ispin) - CALL cp_dbcsr_trace(matrix_cg,matrix_dp(ispin),cg_numer(ispin),error=error) + CALL cp_dbcsr_trace(matrix_cg,matrix_dp(ispin),cg_numer(ispin)) beta=cg_numer(ispin)/MAX(cg_denom(ispin),1.0E-6_dp) IF(beta.lt.1.0_dp)THEN beta=MAX(0.0_dp,beta) - CALL cp_dbcsr_add(matrix_dp(ispin),matrix_dp_old,1.0_dp,beta,error=error) + CALL cp_dbcsr_add(matrix_dp(ispin),matrix_dp_old,1.0_dp,beta) END IF IF(unit_nr.gt.0)WRITE(unit_nr,"(A)")" " END DO - CALL cp_dbcsr_release(matrix_PKs,error) - CALL cp_dbcsr_release(matrix_dp_old,error) - CALL cp_dbcsr_release(matrix_b,error) - CALL cp_dbcsr_release(matrix_Ax,error) - CALL cp_dbcsr_release(matrix_tmp,error) - CALL cp_dbcsr_release(matrix_tmp1,error) - CALL cp_dbcsr_release(matrix_b,error) - CALL cp_dbcsr_release(matrix_res,error) - CALL cp_dbcsr_release(matrix_cg,error) + CALL cp_dbcsr_release(matrix_PKs) + CALL cp_dbcsr_release(matrix_dp_old) + CALL cp_dbcsr_release(matrix_b) + CALL cp_dbcsr_release(matrix_Ax) + CALL cp_dbcsr_release(matrix_tmp) + CALL cp_dbcsr_release(matrix_tmp1) + CALL cp_dbcsr_release(matrix_b) + CALL cp_dbcsr_release(matrix_res) + CALL cp_dbcsr_release(matrix_cg) IF (unit_nr.gt.0) CALL m_flush(unit_nr) CALL timestop(handle) @@ -501,17 +491,15 @@ END SUBROUTINE compute_direction_newton !> \param tmp ... !> \param eps_filter ... !> \param at_limit ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE compute_cg_matrices(Ax,res,cg,deltp,tmp,eps_filter,at_limit,error) + SUBROUTINE compute_cg_matrices(Ax,res,cg,deltp,tmp,eps_filter,at_limit) TYPE(cp_dbcsr_type) :: Ax, res, cg, deltp, tmp REAL(KIND=dp) :: eps_filter LOGICAL :: at_limit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_cg_matrices', & routineP = moduleN//':'//routineN @@ -522,41 +510,41 @@ SUBROUTINE compute_cg_matrices(Ax,res,cg,deltp,tmp,eps_filter,at_limit,error) norm_cA, norm_rr, vec(3) at_limit=.FALSE. - CALL cp_dbcsr_trace(res,res,norm_rr,error=error) - CALL cp_dbcsr_trace(cg,Ax,norm_cA,error=error) + CALL cp_dbcsr_trace(res,res,norm_rr) + CALL cp_dbcsr_trace(cg,Ax,norm_cA) lin_eq=0.0_dp fac=norm_rr/norm_cA fac1=fac ! Use a 3point line serach and a fit to a quadratic function to determine optimal step size DO i=1,3 - CALL cp_dbcsr_copy(tmp,res,error=error) - CALL cp_dbcsr_add(tmp,Ax,1.0_dp,-fac,error=error) + CALL cp_dbcsr_copy(tmp,res) + CALL cp_dbcsr_add(tmp,Ax,1.0_dp,-fac) devi(i)=cp_dbcsr_frobenius_norm(tmp) lin_eq(i,:)=(/fac**2,fac,1.0_dp/) fac=fac1+fac1*((-1)**i)*0.5_dp END DO - CALL invmat(lin_eq,info,error) + CALL invmat(lin_eq,info) vec=MATMUL(lin_eq,devi) alpha=-vec(2)/(2.0_dp*vec(1)) fac=SQRT(norm_rr/(norm_cA*alpha)) !scale the previous matrices to match the step size - CALL cp_dbcsr_scale(Ax,fac,error=error) - CALL cp_dbcsr_scale(cg,fac,error=error) + CALL cp_dbcsr_scale(Ax,fac) + CALL cp_dbcsr_scale(cg,fac) norm_cA=norm_cA*fac**2 ! USe CG to get the new matrices alpha=norm_rr/norm_cA - CALL cp_dbcsr_add(res,Ax,1.0_dp,-alpha,error=error) - CALL cp_dbcsr_trace(res,res,new_norm,error=error) + CALL cp_dbcsr_add(res,Ax,1.0_dp,-alpha) + CALL cp_dbcsr_trace(res,res,new_norm) IF(norm_rr.lt.eps_filter*0.001_dp.OR.new_norm.lt.eps_filter*0.001_dp)THEN beta=0.0_dp at_limit=.TRUE. ELSE beta=new_norm/norm_rr - CALL cp_dbcsr_add(deltp,cg,1.0_dp,alpha,error=error) + CALL cp_dbcsr_add(deltp,cg,1.0_dp,alpha) END IF beta=new_norm/norm_rr - CALL cp_dbcsr_add(cg,res,beta,1.0_dp,error=error) + CALL cp_dbcsr_add(cg,res,beta,1.0_dp) END SUBROUTINE compute_cg_matrices @@ -568,40 +556,38 @@ END SUBROUTINE compute_cg_matrices !> \param matrix_psave ... !> \param lsstep ... !> \param DOUBLE ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE new_p_from_save(matrix_p,matrix_psave,lsstep,DOUBLE,error) + SUBROUTINE new_p_from_save(matrix_p,matrix_psave,lsstep,DOUBLE) TYPE(cp_dbcsr_type), DIMENSION(:) :: matrix_p TYPE(cp_dbcsr_type), DIMENSION(:, :) :: matrix_psave INTEGER :: lsstep LOGICAL :: DOUBLE - TYPE(cp_error_type), INTENT(INOUT) :: error SELECT CASE(lsstep) CASE(3) - CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,1),error=error) + CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,1)) IF(DOUBLE)THEN - CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,2),error=error) + CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,2)) ELSE - CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,3),error=error) + CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,3)) END IF CASE(4) IF(DOUBLE)THEN - CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,2),error=error) + CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,2)) ELSE - CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,3),error=error) + CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,3)) END IF - CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,1),error=error) + CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,1)) CASE(5) - CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,1),error=error) + CALL cp_dbcsr_copy(matrix_p(1),matrix_psave(1,1)) IF(DOUBLE)THEN - CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,3),error=error) + CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,3)) ELSE - CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,2),error=error) + CALL cp_dbcsr_copy(matrix_p(2),matrix_psave(2,2)) END IF END SELECT @@ -614,16 +600,14 @@ END SUBROUTINE new_p_from_save !> \param res ... !> \param eps_filter filtering threshold for sparse matrices !> \param prefac prefactor k in above equation -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE commutator_symm(a,b,res,eps_filter,prefac,error) + SUBROUTINE commutator_symm(a,b,res,eps_filter,prefac) TYPE(cp_dbcsr_type) :: a, b, res REAL(KIND=dp) :: eps_filter, prefac - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'commutator_symm', & routineP = moduleN//':'//routineN @@ -633,14 +617,14 @@ SUBROUTINE commutator_symm(a,b,res,eps_filter,prefac,error) CALL timeset(routineN,handle) - CALL cp_dbcsr_init(work,error=error) - CALL cp_dbcsr_create(work,template=a,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(work) + CALL cp_dbcsr_create(work,template=a,matrix_type=dbcsr_type_no_symmetry) - CALL cp_dbcsr_multiply("N", "N", prefac, a, b,0.0_dp, res, filter_eps=eps_filter,error=error) - CALL cp_dbcsr_transposed(work,res,error=error) - CALL cp_dbcsr_add(res,work,1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_multiply("N", "N", prefac, a, b,0.0_dp, res, filter_eps=eps_filter) + CALL cp_dbcsr_transposed(work,res) + CALL cp_dbcsr_add(res,work,1.0_dp,-1.0_dp) - CALL cp_dbcsr_release(work,error) + CALL cp_dbcsr_release(work) CALL timestop(handle) END SUBROUTINE commutator_symm @@ -657,20 +641,18 @@ END SUBROUTINE commutator_symm !> \param step_size ... !> \param BCH_saved ... !> \param n_bch_hist ... -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** SUBROUTINE update_p_exp(matrix_p_in,matrix_p_out,matrix_dp,matrix_BCH,threshold,step_size,& - BCH_saved,n_bch_hist,error) + BCH_saved,n_bch_hist) TYPE(cp_dbcsr_type), DIMENSION(:) :: matrix_p_in, matrix_p_out, & matrix_dp TYPE(cp_dbcsr_type), DIMENSION(:, :) :: matrix_BCH REAL(KIND=dp) :: threshold, step_size(2) INTEGER :: BCH_saved(2), n_bch_hist - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_p_exp', & routineP = moduleN//':'//routineN @@ -684,17 +666,17 @@ SUBROUTINE update_p_exp(matrix_p_in,matrix_p_out,matrix_dp,matrix_BCH,threshold, CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE unit_nr=-1 ENDIF - CALL cp_dbcsr_init(matrix,error=error) - CALL cp_dbcsr_create(matrix,template=matrix_p_in(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix_p_in(1),matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix) + CALL cp_dbcsr_create(matrix,template=matrix_p_in(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix_p_in(1),matrix_type=dbcsr_type_no_symmetry) nspin=SIZE(matrix_p_in) DO ispin=1,nspin @@ -702,15 +684,15 @@ SUBROUTINE update_p_exp(matrix_p_in,matrix_p_out,matrix_dp,matrix_BCH,threshold, frob_norm=1.0_dp nsave=0 - CALL cp_dbcsr_copy(matrix_tmp,matrix_p_in(ispin),error=error) - CALL cp_dbcsr_copy(matrix_p_out(ispin),matrix_p_in(ispin),error=error) + CALL cp_dbcsr_copy(matrix_tmp,matrix_p_in(ispin)) + CALL cp_dbcsr_copy(matrix_p_out(ispin),matrix_p_in(ispin)) ! If a BCH history is used make good use of it and do a few steps as a copy and scale update of P ! else BCH_saved will be 0 and loop is skipped DO i=1,BCH_saved(ispin) step_fac=step_fac*step_size(ispin) - CALL cp_dbcsr_copy(matrix_tmp,matrix_p_out(ispin),error=error) - CALL cp_dbcsr_add(matrix_p_out(ispin),matrix_BCH(ispin,i),1.0_dp,ifac(i)*step_fac,error=error) - CALL cp_dbcsr_add(matrix_tmp,matrix_p_out(ispin),1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_copy(matrix_tmp,matrix_p_out(ispin)) + CALL cp_dbcsr_add(matrix_p_out(ispin),matrix_BCH(ispin,i),1.0_dp,ifac(i)*step_fac) + CALL cp_dbcsr_add(matrix_tmp,matrix_p_out(ispin),1.0_dp,-1.0_dp) frob_norm=cp_dbcsr_frobenius_norm(matrix_tmp) IF(unit_nr.gt.0)WRITE(unit_nr,"(t3,a,i3,a,f16.8)")"BCH: step",i," Norm of P_old-Pnew:",frob_norm IF(frob_norm.lt.threshold) EXIT @@ -724,22 +706,22 @@ SUBROUTINE update_p_exp(matrix_p_in,matrix_p_out,matrix_dp,matrix_BCH,threshold, !allow for a bit of matrix magic here by exploiting matrix and matrix_tmp !matrix_tmp is alway the previous order of the BCH series CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp, matrix_dp(ispin),& - 0.0_dp, matrix, filter_eps=threshold, error=error) + 0.0_dp, matrix, filter_eps=threshold) !(anti)symmetry allows to sum the transposed instead of the full commutator, matrix becomes the latest result - CALL cp_dbcsr_transposed(matrix_tmp,matrix,error=error) - CALL cp_dbcsr_add(matrix,matrix_tmp,1.0_dp,1.0_dp,error=error) + CALL cp_dbcsr_transposed(matrix_tmp,matrix) + CALL cp_dbcsr_add(matrix,matrix_tmp,1.0_dp,1.0_dp) !Finally, add the new BCH order to P, but store the previous one for a convergence check - CALL cp_dbcsr_copy(matrix_tmp,matrix_p_out(ispin),error=error) - CALL cp_dbcsr_add(matrix_p_out(ispin),matrix,1.0_dp,ifac(i)*step_fac,error=error) + CALL cp_dbcsr_copy(matrix_tmp,matrix_p_out(ispin)) + CALL cp_dbcsr_add(matrix_p_out(ispin),matrix,1.0_dp,ifac(i)*step_fac) IF(save_BCH.AND.i.le.n_bch_hist)THEN - CALL cp_dbcsr_copy(matrix_BCH(ispin,i),matrix,error=error) + CALL cp_dbcsr_copy(matrix_BCH(ispin,i),matrix) nsave=i END IF - CALL cp_dbcsr_add(matrix_tmp,matrix_p_out(ispin),1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_add(matrix_tmp,matrix_p_out(ispin),1.0_dp,-1.0_dp) !Stop the BCH-series if two successive P's differ by less the threshold frob_norm=cp_dbcsr_frobenius_norm(matrix_tmp) @@ -747,17 +729,17 @@ SUBROUTINE update_p_exp(matrix_p_in,matrix_p_out,matrix_dp,matrix_BCH,threshold, IF(frob_norm.lt.threshold) EXIT !Copy the latest BCH-matrix on matrix tmp, so we can cycle with all matrices in place - CALL cp_dbcsr_copy(matrix_tmp,matrix,error=error) - CALL cp_dbcsr_filter(matrix_tmp,threshold,error=error) + CALL cp_dbcsr_copy(matrix_tmp,matrix) + CALL cp_dbcsr_filter(matrix_tmp,threshold) END DO BCH_saved(ispin)=nsave IF(unit_nr.gt.0)WRITE(unit_nr,"(A)")" " END DO - CALL purify_mcweeny(matrix_p_out,threshold,1,error) + CALL purify_mcweeny(matrix_p_out,threshold,1) IF (unit_nr.gt.0) CALL m_flush(unit_nr) - CALL cp_dbcsr_release (matrix_tmp,error) - CALL cp_dbcsr_release (matrix,error) + CALL cp_dbcsr_release (matrix_tmp) + CALL cp_dbcsr_release (matrix) CALL timestop(handle) END SUBROUTINE update_p_exp @@ -767,17 +749,15 @@ END SUBROUTINE update_p_exp !> \param matrix matrix to be transformed !> \param matrix_trafo transformation matrix !> \param eps_filter filtering threshold for sparse matrices -!> \param error ... !> \par History !> 2012.05 created [Florian Schiffmann] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE transform_matrix_orth(matrix,matrix_trafo,eps_filter,error) + SUBROUTINE transform_matrix_orth(matrix,matrix_trafo,eps_filter) TYPE(cp_dbcsr_type), DIMENSION(:) :: matrix TYPE(cp_dbcsr_type) :: matrix_trafo REAL(KIND=dp) :: eps_filter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'transform_matrix_orth', & routineP = moduleN//':'//routineN @@ -787,24 +767,24 @@ SUBROUTINE transform_matrix_orth(matrix,matrix_trafo,eps_filter,error) CALL timeset(routineN,handle) - CALL cp_dbcsr_init(matrix_work,error=error) - CALL cp_dbcsr_create(matrix_work,template=matrix(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix(1),matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_work) + CALL cp_dbcsr_create(matrix_work,template=matrix(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix(1),matrix_type=dbcsr_type_no_symmetry) DO ispin=1,SIZE(matrix) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix(ispin), matrix_trafo,& - 0.0_dp, matrix_work, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_work, filter_eps=eps_filter) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_trafo, matrix_work,& - 0.0_dp, matrix_tmp,filter_eps=eps_filter, error=error) + 0.0_dp, matrix_tmp,filter_eps=eps_filter) ! symmetrize results (this is again needed to make sure everything is stable) - CALL cp_dbcsr_transposed(matrix_work,matrix_tmp,error=error) - CALL cp_dbcsr_add(matrix_tmp,matrix_work,0.5_dp,0.5_dp,error=error) - CALL cp_dbcsr_copy(matrix(ispin),matrix_tmp,error=error) + CALL cp_dbcsr_transposed(matrix_work,matrix_tmp) + CALL cp_dbcsr_add(matrix_tmp,matrix_work,0.5_dp,0.5_dp) + CALL cp_dbcsr_copy(matrix(ispin),matrix_tmp) END DO - CALL cp_dbcsr_release(matrix_tmp,error=error) - CALL cp_dbcsr_release(matrix_work,error=error) + CALL cp_dbcsr_release(matrix_tmp) + CALL cp_dbcsr_release(matrix_work) CALL timestop(handle) END SUBROUTINE @@ -812,24 +792,22 @@ SUBROUTINE transform_matrix_orth(matrix,matrix_trafo,eps_filter,error) ! ***************************************************************************** !> \brief ... !> \param curvy_data ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_curvy_data(curvy_data,error) + SUBROUTINE deallocate_curvy_data(curvy_data) TYPE(ls_scf_curvy_type) :: curvy_data - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_curvy_data', & routineP = moduleN//':'//routineN INTEGER :: i, j - CALL release_dbcsr_array(curvy_data%matrix_dp,error) - CALL release_dbcsr_array(curvy_data%matrix_p,error) + CALL release_dbcsr_array(curvy_data%matrix_dp) + CALL release_dbcsr_array(curvy_data%matrix_p) IF(ALLOCATED(curvy_data%matrix_psave))THEN DO i=1,SIZE(curvy_data%matrix_psave,1) DO j=1,3 - CALL cp_dbcsr_release(curvy_data%matrix_psave(i,j),error) + CALL cp_dbcsr_release(curvy_data%matrix_psave(i,j)) END DO END DO DEALLOCATE(curvy_data%matrix_psave) @@ -837,7 +815,7 @@ SUBROUTINE deallocate_curvy_data(curvy_data,error) IF(ALLOCATED(curvy_data%matrix_BCH))THEN DO i=1,SIZE(curvy_data%matrix_BCH,1) DO j=1,7 - CALL cp_dbcsr_release(curvy_data%matrix_BCH(i,j),error) + CALL cp_dbcsr_release(curvy_data%matrix_BCH(i,j)) END DO END DO DEALLOCATE(curvy_data%matrix_BCH) @@ -847,12 +825,10 @@ END SUBROUTINE deallocate_curvy_data ! ***************************************************************************** !> \brief ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_dbcsr_array(matrix,error) + SUBROUTINE release_dbcsr_array(matrix) TYPE(cp_dbcsr_type), ALLOCATABLE, & DIMENSION(:) :: matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'release_dbcsr_array', & routineP = moduleN//':'//routineN @@ -861,7 +837,7 @@ SUBROUTINE release_dbcsr_array(matrix,error) IF(ALLOCATED(matrix))THEN DO i=1,SIZE(matrix) - CALL cp_dbcsr_release(matrix(i),error) + CALL cp_dbcsr_release(matrix(i)) END DO DEALLOCATE(matrix) END IF @@ -874,13 +850,11 @@ END SUBROUTINE release_dbcsr_array !> \param curvy_data ... !> \param matrix_s ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_curvy(curvy_data,matrix_s,nspins,error) + SUBROUTINE init_curvy(curvy_data,matrix_s,nspins) TYPE(ls_scf_curvy_type) :: curvy_data TYPE(cp_dbcsr_type) :: matrix_s INTEGER :: nspins - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_curvy', & routineP = moduleN//':'//routineN @@ -890,13 +864,13 @@ SUBROUTINE init_curvy(curvy_data,matrix_s,nspins,error) ALLOCATE (curvy_data%matrix_dp(nspins)) ALLOCATE (curvy_data%matrix_p(nspins)) DO ispin=1,nspins - CALL cp_dbcsr_init(curvy_data%matrix_dp(ispin),error=error) + CALL cp_dbcsr_init(curvy_data%matrix_dp(ispin)) CALL cp_dbcsr_create(curvy_data%matrix_dp(ispin),template=matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_set(curvy_data%matrix_dp(ispin),0.0_dp,error=error) - CALL cp_dbcsr_init(curvy_data%matrix_p(ispin),error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_set(curvy_data%matrix_dp(ispin),0.0_dp) + CALL cp_dbcsr_init(curvy_data%matrix_p(ispin)) CALL cp_dbcsr_create(curvy_data%matrix_p(ispin),template=matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) curvy_data%fix_shift=.FALSE. curvy_data%double_step_size=.TRUE. curvy_data%shift=1.0_dp @@ -909,9 +883,9 @@ SUBROUTINE init_curvy(curvy_data,matrix_s,nspins,error) ALLOCATE (curvy_data%matrix_psave(nspins,3)) DO ispin=1,nspins DO j=1,3 - CALL cp_dbcsr_init(curvy_data%matrix_psave(ispin,j),error=error) + CALL cp_dbcsr_init(curvy_data%matrix_psave(ispin,j)) CALL cp_dbcsr_create(curvy_data%matrix_psave(ispin,j),template=matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) END DO END DO END IF @@ -919,9 +893,9 @@ SUBROUTINE init_curvy(curvy_data,matrix_s,nspins,error) ALLOCATE (curvy_data%matrix_BCH(nspins,curvy_data%n_bch_hist)) DO ispin=1,nspins DO j=1,curvy_data%n_bch_hist - CALL cp_dbcsr_init(curvy_data%matrix_BCH(ispin,j),error=error) + CALL cp_dbcsr_init(curvy_data%matrix_BCH(ispin,j)) CALL cp_dbcsr_create(curvy_data%matrix_BCH(ispin,j),template=matrix_s,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) END DO END DO END IF diff --git a/src/dm_ls_scf_methods.F b/src/dm_ls_scf_methods.F index 0636e20000..a697ebb1cd 100644 --- a/src/dm_ls_scf_methods.F +++ b/src/dm_ls_scf_methods.F @@ -60,13 +60,12 @@ MODULE dm_ls_scf_methods !> \param order ... !> \param eps_lanczos ... !> \param max_iter_lanczos ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** SUBROUTINE compute_matrix_preconditioner(matrix_s,preconditioner_type, ls_mstruct, & - matrix_bs_sqrt,matrix_bs_sqrt_inv,threshold,order,eps_lanczos, max_iter_lanczos, error) + matrix_bs_sqrt,matrix_bs_sqrt_inv,threshold,order,eps_lanczos, max_iter_lanczos) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_s INTEGER :: preconditioner_type @@ -77,7 +76,6 @@ SUBROUTINE compute_matrix_preconditioner(matrix_s,preconditioner_type, ls_mstruc INTEGER :: order REAL(KIND=dp) :: eps_lanczos INTEGER :: max_iter_lanczos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'compute_matrix_preconditioner', & @@ -92,8 +90,8 @@ SUBROUTINE compute_matrix_preconditioner(matrix_s,preconditioner_type, ls_mstruc CALL timeset(routineN,handle) ! first generate a block diagonal copy of s - CALL cp_dbcsr_init(matrix_bs,error=error) - CALL cp_dbcsr_create(matrix_bs,template=matrix_s,error=error) + CALL cp_dbcsr_init(matrix_bs) + CALL cp_dbcsr_create(matrix_bs,template=matrix_s) CALL dbcsr_data_init (block_any) CALL dbcsr_data_new(block_any, cp_dbcsr_get_data_type(matrix_s)) @@ -136,32 +134,32 @@ SUBROUTINE compute_matrix_preconditioner(matrix_s,preconditioner_type, ls_mstruc CALL dbcsr_data_clear_pointer (block_any) CALL dbcsr_data_release (block_any) - CALL cp_dbcsr_finalize(matrix_bs,error=error) + CALL cp_dbcsr_finalize(matrix_bs) SELECT CASE(preconditioner_type) CASE(ls_s_preconditioner_none) ! for now make it a simple identity matrix - CALL cp_dbcsr_copy(matrix_bs_sqrt,matrix_bs,error=error) - CALL cp_dbcsr_set(matrix_bs_sqrt,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_bs_sqrt,1.0_dp,error=error) + CALL cp_dbcsr_copy(matrix_bs_sqrt,matrix_bs) + CALL cp_dbcsr_set(matrix_bs_sqrt,0.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_bs_sqrt,1.0_dp) ! for now make it a simple identity matrix - CALL cp_dbcsr_copy(matrix_bs_sqrt_inv,matrix_bs,error=error) - CALL cp_dbcsr_set(matrix_bs_sqrt_inv,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_bs_sqrt_inv,1.0_dp,error=error) + CALL cp_dbcsr_copy(matrix_bs_sqrt_inv,matrix_bs) + CALL cp_dbcsr_set(matrix_bs_sqrt_inv,0.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_bs_sqrt_inv,1.0_dp) CASE(ls_s_preconditioner_atomic, ls_s_preconditioner_molecular) - CALL cp_dbcsr_copy(matrix_bs_sqrt,matrix_bs,error=error) - CALL cp_dbcsr_copy(matrix_bs_sqrt_inv,matrix_bs,error=error) + CALL cp_dbcsr_copy(matrix_bs_sqrt,matrix_bs) + CALL cp_dbcsr_copy(matrix_bs_sqrt_inv,matrix_bs) ! XXXXXXXXXXX ! XXXXXXXXXXX the threshold here could be done differently, ! XXXXXXXXXXX using eps_filter is reducing accuracy for no good reason, this is cheap ! XXXXXXXXXXX CALL matrix_sqrt_Newton_Schulz(matrix_bs_sqrt,matrix_bs_sqrt_inv,matrix_bs,& threshold=MIN(threshold,1.0E-10_dp),order=order, & - eps_lanczos=eps_lanczos, max_iter_lanczos=max_iter_lanczos, error=error) + eps_lanczos=eps_lanczos, max_iter_lanczos=max_iter_lanczos) END SELECT - CALL cp_dbcsr_release(matrix_bs,error=error) + CALL cp_dbcsr_release(matrix_bs) CALL timestop(handle) @@ -175,18 +173,16 @@ END SUBROUTINE compute_matrix_preconditioner !> \param direction ... !> \param matrix_bs_sqrt ... !> \param matrix_bs_sqrt_inv ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE apply_matrix_preconditioner(matrix,direction,matrix_bs_sqrt,matrix_bs_sqrt_inv,error) + SUBROUTINE apply_matrix_preconditioner(matrix,direction,matrix_bs_sqrt,matrix_bs_sqrt_inv) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix CHARACTER(LEN=*) :: direction TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_bs_sqrt, & matrix_bs_sqrt_inv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_matrix_preconditioner', & routineP = moduleN//':'//routineN @@ -197,25 +193,25 @@ SUBROUTINE apply_matrix_preconditioner(matrix,direction,matrix_bs_sqrt,matrix_bs CALL timeset(routineN,handle) failure=.FALSE. - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix,matrix_type=dbcsr_type_no_symmetry) SELECT CASE(direction) CASE("forward") CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix, matrix_bs_sqrt_inv,& - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_bs_sqrt_inv, matrix_tmp,& - 0.0_dp, matrix, error=error) + 0.0_dp, matrix) CASE("backward") CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix, matrix_bs_sqrt,& - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_bs_sqrt, matrix_tmp,& - 0.0_dp, matrix, error=error) + 0.0_dp, matrix) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL cp_dbcsr_release(matrix_tmp,error=error) + CALL cp_dbcsr_release(matrix_tmp) CALL timestop(handle) @@ -232,12 +228,11 @@ END SUBROUTINE apply_matrix_preconditioner !> \param matrix_s_inv ... !> \param nelectron ... !> \param threshold ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE density_matrix_sign(matrix_p,mu,fixed_mu,matrix_ks,matrix_s,matrix_s_inv,nelectron,threshold,error) + SUBROUTINE density_matrix_sign(matrix_p,mu,fixed_mu,matrix_ks,matrix_s,matrix_s_inv,nelectron,threshold) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p REAL(KIND=dp), INTENT(INOUT) :: mu @@ -246,7 +241,6 @@ SUBROUTINE density_matrix_sign(matrix_p,mu,fixed_mu,matrix_ks,matrix_s,matrix_s_ matrix_s_inv INTEGER, INTENT(IN) :: nelectron REAL(KIND=dp), INTENT(IN) :: threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_matrix_sign', & routineP = moduleN//':'//routineN @@ -260,7 +254,7 @@ SUBROUTINE density_matrix_sign(matrix_p,mu,fixed_mu,matrix_ks,matrix_s,matrix_s_ CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -279,7 +273,7 @@ SUBROUTINE density_matrix_sign(matrix_p,mu,fixed_mu,matrix_ks,matrix_s,matrix_s_ IF (ABS(mu_high-mu_low)0) WRITE(unit_nr,'(T2,A,I2,1X,F13.9,1X,F15.9)') & "Density matrix: iter, mu, trace error: ", iter, mu, trace-nelectron @@ -313,12 +307,11 @@ END SUBROUTINE density_matrix_sign !> \param matrix_s ... !> \param matrix_s_inv ... !> \param threshold ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE density_matrix_sign_fixed_mu(matrix_p,trace,mu,matrix_ks,matrix_s,matrix_s_inv,threshold,error) + SUBROUTINE density_matrix_sign_fixed_mu(matrix_p,trace,mu,matrix_ks,matrix_s,matrix_s_inv,threshold) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p REAL(KIND=dp), INTENT(OUT) :: trace @@ -326,7 +319,6 @@ SUBROUTINE density_matrix_sign_fixed_mu(matrix_p,trace,mu,matrix_ks,matrix_s,mat TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_ks, matrix_s, & matrix_s_inv REAL(KIND=dp), INTENT(IN) :: threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_matrix_sign_fixed_mu', & routineP = moduleN//':'//routineN @@ -339,7 +331,7 @@ SUBROUTINE density_matrix_sign_fixed_mu(matrix_p,trace,mu,matrix_ks,matrix_s,mat CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -347,43 +339,43 @@ SUBROUTINE density_matrix_sign_fixed_mu(matrix_p,trace,mu,matrix_ks,matrix_s,mat ENDIF ! get inv(S)*H-I*mu - CALL cp_dbcsr_init(matrix_sinv_ks,error=error) - CALL cp_dbcsr_create(matrix_sinv_ks,template=matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_sinv_ks) + CALL cp_dbcsr_create(matrix_sinv_ks,template=matrix_s,matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s_inv, matrix_ks,& - 0.0_dp, matrix_sinv_ks, filter_eps=threshold,error=error) - CALL cp_dbcsr_add_on_diag(matrix_sinv_ks,-mu,error=error) + 0.0_dp, matrix_sinv_ks, filter_eps=threshold) + CALL cp_dbcsr_add_on_diag(matrix_sinv_ks,-mu) ! compute sign(inv(S)*H-I*mu) - CALL cp_dbcsr_init(matrix_sign,error=error) - CALL cp_dbcsr_create(matrix_sign,template=matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL matrix_sign_Newton_Schulz(matrix_sign,matrix_sinv_ks,threshold,error) - CALL cp_dbcsr_release(matrix_sinv_ks,error=error) + CALL cp_dbcsr_init(matrix_sign) + CALL cp_dbcsr_create(matrix_sign,template=matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL matrix_sign_Newton_Schulz(matrix_sign,matrix_sinv_ks,threshold) + CALL cp_dbcsr_release(matrix_sinv_ks) ! now construct the density matrix PS=0.5*(I-sign(inv(S)H-I*mu)) - CALL cp_dbcsr_init(matrix_p_ud,error=error) - CALL cp_dbcsr_create(matrix_p_ud,template=matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(matrix_p_ud,matrix_sign,error=error) - CALL cp_dbcsr_scale(matrix_p_ud,-0.5_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_p_ud,0.5_dp,error=error) - CALL cp_dbcsr_release(matrix_sign,error=error) + CALL cp_dbcsr_init(matrix_p_ud) + CALL cp_dbcsr_create(matrix_p_ud,template=matrix_s,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(matrix_p_ud,matrix_sign) + CALL cp_dbcsr_scale(matrix_p_ud,-0.5_dp) + CALL cp_dbcsr_add_on_diag(matrix_p_ud,0.5_dp) + CALL cp_dbcsr_release(matrix_sign) ! we now have PS, lets get its trace - CALL cp_dbcsr_trace(matrix_p_ud,trace,error=error) + CALL cp_dbcsr_trace(matrix_p_ud,trace) ! we can also check it is idempotent PS*PS=PS - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix_s,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix_s,matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p_ud, matrix_p_ud,& - 0.0_dp, matrix_tmp, filter_eps=threshold,error=error) - CALL cp_dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp, error=error) + 0.0_dp, matrix_tmp, filter_eps=threshold) + CALL cp_dbcsr_add(matrix_tmp, matrix_p_ud, 1.0_dp, -1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(matrix_tmp) - CALL cp_dbcsr_release(matrix_tmp,error=error) + CALL cp_dbcsr_release(matrix_tmp) IF (unit_nr>0) WRITE(unit_nr,'(T2,A,F20.12)') "Deviation from idempotency: ", frob_matrix ! get P=PS*inv(S) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p_ud, matrix_s_inv,& - 0.0_dp, matrix_p, filter_eps=threshold,error=error) - CALL cp_dbcsr_release(matrix_p_ud,error=error) + 0.0_dp, matrix_p, filter_eps=threshold) + CALL cp_dbcsr_release(matrix_p_ud) CALL timestop(handle) @@ -403,7 +395,6 @@ END SUBROUTINE density_matrix_sign_fixed_mu !> \param matrix_ks_deviation ... !> \param max_iter_lanczos ... !> \param eps_lanczos ... -!> \param error ... !> \par History !> 2012.06 created [Florian Thoele] !> \author Florian Thoele @@ -411,7 +402,7 @@ END SUBROUTINE density_matrix_sign_fixed_mu SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & nelectron, threshold, e_homo, e_lumo, e_mu, & dynamic_threshold, matrix_ks_deviation,& - max_iter_lanczos, eps_lanczos, error) + max_iter_lanczos, eps_lanczos) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_ks, matrix_s_sqrt_inv @@ -422,7 +413,6 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_ks_deviation INTEGER, INTENT(IN) :: max_iter_lanczos REAL(KIND=dp), INTENT(IN) :: eps_lanczos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_matrix_trs4', & routineP = moduleN//':'//routineN @@ -446,13 +436,13 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & TYPE(cp_logger_type), POINTER :: logger IF(nelectron==0) THEN - CALL cp_dbcsr_set(matrix_p,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_p,0.0_dp) RETURN ENDIF CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -463,28 +453,28 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & IF(PRESENT(dynamic_threshold)) do_dyn_threshold = dynamic_threshold ! init X = (eps_n*I - H)/(eps_n - eps_0) ... H* = S^-1/2*H*S^-1/2 - CALL cp_dbcsr_init(matrix_x,error=error) - CALL cp_dbcsr_create(matrix_x, template=matrix_ks, matrix_type="S", error=error) + CALL cp_dbcsr_init(matrix_x) + CALL cp_dbcsr_create(matrix_x, template=matrix_ks, matrix_type="S") ! at some points the non-symmetric version of x is required - CALL cp_dbcsr_init(matrix_x_nosym,error=error) - CALL cp_dbcsr_create(matrix_x_nosym, template=matrix_ks, matrix_type=dbcsr_type_no_symmetry, error=error) + CALL cp_dbcsr_init(matrix_x_nosym) + CALL cp_dbcsr_create(matrix_x_nosym, template=matrix_ks, matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_ks,& - 0.0_dp, matrix_x_nosym, filter_eps=threshold,error=error) + 0.0_dp, matrix_x_nosym, filter_eps=threshold) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_x_nosym, matrix_s_sqrt_inv, & - 0.0_dp, matrix_x, filter_eps=threshold,error=error) - CALL cp_dbcsr_desymmetrize(matrix_x,matrix_x_nosym,error=error) + 0.0_dp, matrix_x, filter_eps=threshold) + CALL cp_dbcsr_desymmetrize(matrix_x,matrix_x_nosym) - CALL cp_dbcsr_init(matrix_k0,error=error) - CALL cp_dbcsr_create(matrix_k0,template=matrix_ks,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(matrix_k0, matrix_x_nosym, error=error) + CALL cp_dbcsr_init(matrix_k0) + CALL cp_dbcsr_create(matrix_k0,template=matrix_ks,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(matrix_k0, matrix_x_nosym) ! compute the deviation in the mixed matrix, as seen in the ortho basis IF (do_dyn_threshold) THEN - CALL cp_dbcsr_add(matrix_ks_deviation, matrix_x_nosym , -1.0_dp, 1.0_dp, error=error) + CALL cp_dbcsr_add(matrix_ks_deviation, matrix_x_nosym , -1.0_dp, 1.0_dp) CALL cp_dbcsr_arnoldi_extremal(matrix_ks_deviation, maxev, minev, max_iter=max_iter_lanczos, threshold=eps_lanczos, & - converged=converged, error=error) + converged=converged) maxdev = MAX(ABS(maxev), ABS(minev)) IF (unit_nr>0) THEN WRITE(unit_nr, '(T6,A,1X,L12)') "Lanczos converged: ", converged @@ -494,21 +484,21 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & WRITE(unit_nr, '(T6,A,1X,L12)') "Predicts a gap ? ", ((e_lumo-maxdev)-(e_homo+maxdev))>0 ENDIF ! save the old mixed matrix - CALL cp_dbcsr_copy(matrix_ks_deviation, matrix_x_nosym , error=error) + CALL cp_dbcsr_copy(matrix_ks_deviation, matrix_x_nosym) ENDIF ! get largest/smallest eigenvalues for scaling CALL cp_dbcsr_arnoldi_extremal(matrix_x_nosym, max_eig, min_eig, max_iter=max_iter_lanczos, threshold=eps_lanczos,& - converged=converged, error=error) + converged=converged) IF (unit_nr>0) WRITE(unit_nr,'(T6,A,1X,2F12.5,1X,A,1X,L1)') "Est. extremal eigenvalues", & min_eig, max_eig," converged: ",converged eps_max = max_eig eps_min = min_eig ! scale KS matrix - CALL cp_dbcsr_add_on_diag(matrix_x, -eps_max, error=error) - CALL cp_dbcsr_scale(matrix_x, -1.0_dp/(eps_max-eps_min), error=error) + CALL cp_dbcsr_add_on_diag(matrix_x, -eps_max) + CALL cp_dbcsr_scale(matrix_x, -1.0_dp/(eps_max-eps_min)) current_threshold = threshold IF (do_dyn_threshold) THEN @@ -517,14 +507,14 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & scaled_lumo_bound = (eps_max-(e_lumo-maxdev))/(eps_max-eps_min) ENDIF - CALL cp_dbcsr_init(matrix_xsq,error=error) - CALL cp_dbcsr_create(matrix_xsq,template=matrix_ks,matrix_type="S",error=error) + CALL cp_dbcsr_init(matrix_xsq) + CALL cp_dbcsr_create(matrix_xsq,template=matrix_ks,matrix_type="S") - CALL cp_dbcsr_init(matrix_xidsq,error=error) - CALL cp_dbcsr_create(matrix_xidsq,template=matrix_ks,matrix_type="S",error=error) + CALL cp_dbcsr_init(matrix_xidsq) + CALL cp_dbcsr_create(matrix_xidsq,template=matrix_ks,matrix_type="S") - CALL cp_dbcsr_init(tmp_gx,error=error) - CALL cp_dbcsr_create(tmp_gx,template=matrix_ks,matrix_type="S",error=error) + CALL cp_dbcsr_init(tmp_gx) + CALL cp_dbcsr_create(tmp_gx,template=matrix_ks,matrix_type="S") ALLOCATE(gamma_values(max_iter)) @@ -535,28 +525,28 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & ! get X*X CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_x, matrix_x,& 0.0_dp, matrix_xsq, & - filter_eps=current_threshold,flop=flop1,error=error) + filter_eps=current_threshold,flop=flop1) ! intermediate use matrix_xidsq to compute = X*X-X - CALL cp_dbcsr_copy(matrix_xidsq, matrix_x,error=error) - CALL cp_dbcsr_add(matrix_xidsq, matrix_xsq, -1.0_dp, 1.0_dp, error=error) + CALL cp_dbcsr_copy(matrix_xidsq, matrix_x) + CALL cp_dbcsr_add(matrix_xidsq, matrix_xsq, -1.0_dp, 1.0_dp) frob_id = cp_dbcsr_frobenius_norm(matrix_xidsq) frob_x = cp_dbcsr_frobenius_norm(matrix_x) ! xidsq = (1-X)*(1-X) ! use (1-x)*(1-x) = 1 + x*x - 2*x - CALL cp_dbcsr_copy(matrix_xidsq, matrix_x,error=error) - CALL cp_dbcsr_add(matrix_xidsq, matrix_xsq, -2.0_dp, 1.0_dp, error=error) - CALL cp_dbcsr_add_on_diag(matrix_xidsq, 1.0_dp, error=error) + CALL cp_dbcsr_copy(matrix_xidsq, matrix_x) + CALL cp_dbcsr_add(matrix_xidsq, matrix_xsq, -2.0_dp, 1.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_xidsq, 1.0_dp) ! tmp_gx = 4X-3X*X - CALL cp_dbcsr_copy(tmp_gx, matrix_x,error=error) - CALL cp_dbcsr_add(tmp_gx, matrix_xsq, 4.0_dp, -3.0_dp, error=error) + CALL cp_dbcsr_copy(tmp_gx, matrix_x) + CALL cp_dbcsr_add(tmp_gx, matrix_xsq, 4.0_dp, -3.0_dp) ! get gamma ! Tr(F) = Tr(XX*tmp_gx) Tr(G) is equivalent - CALL cp_dbcsr_trace(matrix_xsq, matrix_xidsq, trace_gx, error=error) - CALL cp_dbcsr_trace(matrix_xsq, tmp_gx, trace_fx, error=error) + CALL cp_dbcsr_trace(matrix_xsq, matrix_xidsq, trace_gx) + CALL cp_dbcsr_trace(matrix_xsq, tmp_gx, trace_fx) ! if converged, and gam becomes noisy, fix it to 3, which results in a final McWeeny step. ! do this only if the electron count is reasonable. @@ -596,19 +586,19 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & IF (gam > gamma_max) THEN ! Xn+1 = 2X-X*X - CALL cp_dbcsr_add(matrix_x, matrix_xsq, 2.0_dp, -1.0_dp, error=error) - CALL cp_dbcsr_filter(matrix_x, current_threshold, error=error) + CALL cp_dbcsr_add(matrix_x, matrix_xsq, 2.0_dp, -1.0_dp) + CALL cp_dbcsr_filter(matrix_x, current_threshold) branch=1 ELSE IF (gam < gamma_min) THEN ! Xn+1 = X*X - CALL cp_dbcsr_copy(matrix_x, matrix_xsq, error=error) + CALL cp_dbcsr_copy(matrix_x, matrix_xsq) branch=2 ELSE ! Xn+1 = F(X) + gam*G(X) - CALL cp_dbcsr_add(tmp_gx, matrix_xidsq, 1.0_dp, gam, error=error) + CALL cp_dbcsr_add(tmp_gx, matrix_xidsq, 1.0_dp, gam) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_xsq, tmp_gx,& 0.0_dp, matrix_x, & - flop=flop2, filter_eps=current_threshold,error=error) + flop=flop2, filter_eps=current_threshold) branch=3 ENDIF @@ -632,15 +622,15 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & IF (unit_nr>0) WRITE(unit_nr, '(T6,A,I3,1X,F10.8,E12.3)') 'Final TRS4 iteration ', i, occ_matrix,ABS(trace_gx) ! free some memory - CALL cp_dbcsr_release(tmp_gx, error=error) - CALL cp_dbcsr_release(matrix_xsq, error=error) - CALL cp_dbcsr_release(matrix_xidsq, error=error) + CALL cp_dbcsr_release(tmp_gx) + CALL cp_dbcsr_release(matrix_xsq) + CALL cp_dbcsr_release(matrix_xidsq) ! output to matrix_p, P = inv(S)^0.5 X inv(S)^0.5 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_x, matrix_s_sqrt_inv,& - 0.0_dp, matrix_x_nosym, filter_eps=threshold,error=error) + 0.0_dp, matrix_x_nosym, filter_eps=threshold) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_x_nosym,& - 0.0_dp, matrix_p, filter_eps=threshold,error=error) + 0.0_dp, matrix_p, filter_eps=threshold) ! calculate the chemical potential by doing a bisection of fk(x0)-0.5, where fk is evaluated using the stored values for gamma ! E. Rubensson et al., Chem Phys Lett 432, 2006, 591-594 @@ -666,16 +656,16 @@ SUBROUTINE density_matrix_trs4(matrix_p, matrix_ks, matrix_s_sqrt_inv, & e_mu = mu IF (do_dyn_threshold) THEN - CALL cp_dbcsr_desymmetrize(matrix_x,matrix_x_nosym,error=error) + CALL cp_dbcsr_desymmetrize(matrix_x,matrix_x_nosym) CALL compute_homo_lumo(matrix_k0,matrix_x_nosym,eps_min,eps_max,& - threshold,max_iter_lanczos,eps_lanczos,homo,lumo,unit_nr,error) + threshold,max_iter_lanczos,eps_lanczos,homo,lumo,unit_nr) e_homo = homo e_lumo = lumo ENDIF - CALL cp_dbcsr_release(matrix_x, error=error) - CALL cp_dbcsr_release(matrix_x_nosym, error=error) - CALL cp_dbcsr_release(matrix_k0, error=error) + CALL cp_dbcsr_release(matrix_x) + CALL cp_dbcsr_release(matrix_x_nosym) + CALL cp_dbcsr_release(matrix_k0) CALL timestop(handle) END SUBROUTINE density_matrix_trs4 @@ -694,13 +684,11 @@ END SUBROUTINE density_matrix_trs4 !> \param non_monotonic ... !> \param eps_lanczos ... !> \param max_iter_lanczos ... -!> \param error ... !> \author Jonathan Mullin ! ***************************************************************************** SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & nelectron, threshold, e_homo, e_lumo, & - non_monotonic, eps_lanczos, max_iter_lanczos, & - error) + non_monotonic, eps_lanczos, max_iter_lanczos) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_ks, matrix_s_sqrt_inv @@ -710,7 +698,6 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & LOGICAL, INTENT(IN), OPTIONAL :: non_monotonic REAL(KIND=dp), INTENT(IN) :: eps_lanczos INTEGER, INTENT(IN) :: max_iter_lanczos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_matrix_tc2', & routineP = moduleN//':'//routineN @@ -731,7 +718,7 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -742,13 +729,13 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & IF(PRESENT(non_monotonic)) do_non_monotonic = non_monotonic ! init X = (eps_n*I - H)/(eps_n - eps_0) ... H* = S^-1/2*H*S^-1/2 - CALL cp_dbcsr_init(matrix_x,error=error) - CALL cp_dbcsr_create(matrix_x, template=matrix_ks, matrix_type=dbcsr_type_no_symmetry, error=error) + CALL cp_dbcsr_init(matrix_x) + CALL cp_dbcsr_create(matrix_x, template=matrix_ks, matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_ks,& - 0.0_dp, matrix_x, filter_eps=threshold,error=error) + 0.0_dp, matrix_x, filter_eps=threshold) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_x, matrix_s_sqrt_inv, & - 0.0_dp, matrix_x, filter_eps=threshold,error=error) + 0.0_dp, matrix_x, filter_eps=threshold) IF (unit_nr>0) THEN WRITE(unit_nr, '(T6,A,1X,F12.5)') "HOMO upper bound: ", e_homo @@ -758,7 +745,7 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & ! get largest/smallest eigenvalues for scaling CALL cp_dbcsr_arnoldi_extremal(matrix_x, max_eig, min_eig, max_iter=max_iter_lanczos, threshold=eps_lanczos,& - converged=converged, error=error) + converged=converged) IF (unit_nr>0) WRITE(unit_nr,'(T6,A,1X,2F12.5,1X,A,1X,L1)') "Est. extremal eigenvalues", & min_eig, max_eig," converged: ",converged @@ -766,16 +753,16 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & eps_min = min_eig ! scale KS matrix - CALL cp_dbcsr_scale(matrix_x, -1.0_dp, error=error) - CALL cp_dbcsr_add_on_diag(matrix_x, eps_max, error=error) - CALL cp_dbcsr_scale(matrix_x, 1/(eps_max-eps_min), error=error) + CALL cp_dbcsr_scale(matrix_x, -1.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_x, eps_max) + CALL cp_dbcsr_scale(matrix_x, 1/(eps_max-eps_min)) - CALL cp_dbcsr_init(matrix_xsq,error=error) - CALL cp_dbcsr_create(matrix_xsq,template=matrix_ks,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(matrix_xsq, matrix_x,error=error) + CALL cp_dbcsr_init(matrix_xsq) + CALL cp_dbcsr_create(matrix_xsq,template=matrix_ks,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(matrix_xsq, matrix_x) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix_ks,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix_ks,matrix_type=dbcsr_type_no_symmetry) ALLOCATE(poly(max_iter)) ALLOCATE(nu(max_iter)) @@ -817,16 +804,16 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & poly(i)=1.0_dp alpha(i)=2.0_dp/(2.0_dp-beta) - CALL cp_dbcsr_scale(matrix_x, alpha(i), error=error) - CALL cp_dbcsr_add_on_diag(matrix_x,1.0_dp-alpha(i), error=error) + CALL cp_dbcsr_scale(matrix_x, alpha(i)) + CALL cp_dbcsr_add_on_diag(matrix_x,1.0_dp-alpha(i)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_x, matrix_x,& 0.0_dp, matrix_xsq, & - filter_eps=threshold,flop=flop1,error=error) + filter_eps=threshold,flop=flop1) !save X for control variables - CALL cp_dbcsr_copy(matrix_tmp, matrix_x,error=error) + CALL cp_dbcsr_copy(matrix_tmp, matrix_x) - CALL cp_dbcsr_copy(matrix_x, matrix_xsq, error=error) + CALL cp_dbcsr_copy(matrix_x, matrix_xsq) beta=(1.0_dp-alpha(i)) + alpha(i)*beta beta = beta*beta @@ -837,15 +824,15 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & poly(i)=0.0_dp alpha(i)=2.0_dp/(1.0_dp+betaB) - CALL cp_dbcsr_scale(matrix_x, alpha(i), error=error) + CALL cp_dbcsr_scale(matrix_x, alpha(i)) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_x, matrix_x,& 0.0_dp, matrix_xsq, & - filter_eps=threshold,flop=flop1,error=error) + filter_eps=threshold,flop=flop1) !save X for control variables - CALL cp_dbcsr_copy(matrix_tmp, matrix_x,error=error) + CALL cp_dbcsr_copy(matrix_tmp, matrix_x) ! - CALL cp_dbcsr_add(matrix_x, matrix_xsq, 2.0_dp, -1.0_dp, error=error) + CALL cp_dbcsr_add(matrix_x, matrix_xsq, 2.0_dp, -1.0_dp) beta=alpha(i)*beta beta=2.0_dp*beta-beta*beta @@ -864,17 +851,17 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & ENDIF ! calculate control terms - CALL cp_dbcsr_trace(matrix_xsq, trace_fx, error=error) + CALL cp_dbcsr_trace(matrix_xsq, trace_fx) ! intermediate use matrix_xsq compute X- X*X , temorarily use trace_gx - CALL cp_dbcsr_add(matrix_xsq, matrix_tmp, -1.0_dp, 1.0_dp, error=error) - CALL cp_dbcsr_trace(matrix_xsq, trace_gx, error=error) + CALL cp_dbcsr_add(matrix_xsq, matrix_tmp, -1.0_dp, 1.0_dp) + CALL cp_dbcsr_trace(matrix_xsq, trace_gx) nu(i) = cp_dbcsr_frobenius_norm(matrix_xsq) wu(i)=trace_gx ! intermediate use matrix_xsq to compute = 2X - X*X - CALL cp_dbcsr_add(matrix_xsq, matrix_tmp, 1.0_dp, 1.0_dp, error=error) - CALL cp_dbcsr_trace(matrix_xsq, trace_gx, error=error) + CALL cp_dbcsr_add(matrix_xsq, matrix_tmp, 1.0_dp, 1.0_dp) + CALL cp_dbcsr_trace(matrix_xsq, trace_gx) ! TC2 has quadratic convergence, using the frobeniums norm as an idempotency deviation test. IF (ABS(nu(i)) < (threshold) ) EXIT END DO @@ -882,14 +869,14 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & occ_matrix = cp_dbcsr_get_occupation(matrix_x) IF (unit_nr>0) WRITE(unit_nr, '(T6,A,I3,1X,1F10.8,1X,1F10.8)') 'Final TC2 iteration ', i, occ_matrix,ABS(nu(i)) - CALL cp_dbcsr_release(matrix_xsq, error=error) - CALL cp_dbcsr_release(matrix_tmp, error=error) + CALL cp_dbcsr_release(matrix_xsq) + CALL cp_dbcsr_release(matrix_tmp) ! output to matrix_p, P = inv(S)^0.5 X inv(S)^0.5 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_x, matrix_s_sqrt_inv,& - 0.0_dp, matrix_p, filter_eps=threshold,error=error) + 0.0_dp, matrix_p, filter_eps=threshold) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_s_sqrt_inv, matrix_p,& - 0.0_dp, matrix_p, filter_eps=threshold,error=error) + 0.0_dp, matrix_p, filter_eps=threshold) ! ALGO 3 from. SIAM DOI. 10.1137/130911585 X(1)=1.0_dp @@ -941,7 +928,7 @@ SUBROUTINE density_matrix_tc2(matrix_p, matrix_ks, matrix_s_sqrt_inv, & DEALLOCATE(Y) DEALLOCATE(lambda) - CALL cp_dbcsr_release(matrix_x, error=error) + CALL cp_dbcsr_release(matrix_x) CALL timestop(handle) END SUBROUTINE density_matrix_tc2 @@ -959,19 +946,17 @@ END SUBROUTINE density_matrix_tc2 !> \param homo ... !> \param lumo ... !> \param unit_nr ... -!> \param error ... !> \par History !> 2012.06 created [Florian Thoele] !> \author Florian Thoele ! ***************************************************************************** - SUBROUTINE compute_homo_lumo(matrix_k,matrix_p,eps_min,eps_max,threshold,max_iter_lanczos,eps_lanczos,homo,lumo,unit_nr,error) + SUBROUTINE compute_homo_lumo(matrix_k,matrix_p,eps_min,eps_max,threshold,max_iter_lanczos,eps_lanczos,homo,lumo,unit_nr) TYPE(cp_dbcsr_type) :: matrix_k, matrix_p REAL(KIND=dp) :: eps_min, eps_max, threshold INTEGER, INTENT(IN) :: max_iter_lanczos REAL(KIND=dp), INTENT(IN) :: eps_lanczos REAL(KIND=dp) :: homo, lumo INTEGER :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_homo_lumo', & routineP = moduleN//':'//routineN @@ -983,49 +968,49 @@ SUBROUTINE compute_homo_lumo(matrix_k,matrix_p,eps_min,eps_max,threshold,max_ite ! temporary matrices used for HOMO/LUMO calculation - CALL cp_dbcsr_init(tmp1,error=error) - CALL cp_dbcsr_create(tmp1,template=matrix_k,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(tmp1) + CALL cp_dbcsr_create(tmp1,template=matrix_k,matrix_type=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=matrix_k,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=matrix_k,matrix_type=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init(tmp3,error=error) - CALL cp_dbcsr_create(tmp3,template=matrix_k,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(tmp3) + CALL cp_dbcsr_create(tmp3,template=matrix_k,matrix_type=dbcsr_type_no_symmetry) shift1 = -eps_min shift2 = eps_max ! find largest ev of P*(K+shift*1), where shift is the neg. val. of the smallest ev of K - CALL cp_dbcsr_copy(tmp2, matrix_k, error=error) - CALL cp_dbcsr_add_on_diag(tmp2, shift1, error=error) + CALL cp_dbcsr_copy(tmp2, matrix_k) + CALL cp_dbcsr_add_on_diag(tmp2, shift1) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p, tmp2,& - 0.0_dp, tmp1, filter_eps=threshold,error=error) + 0.0_dp, tmp1, filter_eps=threshold) CALL cp_dbcsr_arnoldi_extremal(tmp1, max_eig, min_eig, converged=converged, & - threshold=eps_lanczos, max_iter=max_iter_lanczos, error=error) + threshold=eps_lanczos, max_iter=max_iter_lanczos) homo = max_eig-shift1 IF (unit_nr > 0) THEN WRITE(unit_nr, '(T6,A,1X,L12)') "Lanczos converged: ", converged ENDIF ! -(1-P)*(K-shift*1) = (1-P)*(shift*1 - K), where shift is the largest ev of K - CALL cp_dbcsr_copy(tmp3, matrix_p, error=error) - CALL cp_dbcsr_scale(tmp3, -1.0_dp, error=error) - CALL cp_dbcsr_add_on_diag(tmp3, 1.0_dp, error=error) !tmp3 = 1-P - CALL cp_dbcsr_copy(tmp2, matrix_k, error=error) - CALL cp_dbcsr_add_on_diag(tmp2, -shift2, error=error) + CALL cp_dbcsr_copy(tmp3, matrix_p) + CALL cp_dbcsr_scale(tmp3, -1.0_dp) + CALL cp_dbcsr_add_on_diag(tmp3, 1.0_dp) !tmp3 = 1-P + CALL cp_dbcsr_copy(tmp2, matrix_k) + CALL cp_dbcsr_add_on_diag(tmp2, -shift2) CALL cp_dbcsr_multiply("N", "N", -1.0_dp, tmp3, tmp2,& - 0.0_dp, tmp1, filter_eps=threshold,error=error) + 0.0_dp, tmp1, filter_eps=threshold) CALL cp_dbcsr_arnoldi_extremal(tmp1, max_eig, min_eig, converged=converged,& - threshold=eps_lanczos, max_iter=max_iter_lanczos, error=error) + threshold=eps_lanczos, max_iter=max_iter_lanczos) lumo = -max_eig+shift2 IF (unit_nr > 0) THEN WRITE(unit_nr, '(T6,A,1X,L12)') "Lanczos converged: ", converged WRITE(unit_nr, '(T6,A,1X,3F12.5)') 'HOMO/LUMO/gap', homo, lumo, lumo-homo ENDIF - CALL cp_dbcsr_release(tmp1, error=error) - CALL cp_dbcsr_release(tmp2, error=error) - CALL cp_dbcsr_release(tmp3, error=error) + CALL cp_dbcsr_release(tmp1) + CALL cp_dbcsr_release(tmp2) + CALL cp_dbcsr_release(tmp3) END SUBROUTINE compute_homo_lumo diff --git a/src/dm_ls_scf_qs.F b/src/dm_ls_scf_qs.F index beaeb31c22..5e6d6aec1d 100644 --- a/src/dm_ls_scf_qs.F +++ b/src/dm_ls_scf_qs.F @@ -94,15 +94,13 @@ MODULE dm_ls_scf_qs !> \param matrix_ls ... !> \param matrix_qs ... !> \param ls_mstruct ... -!> \param error ... !> \par History !> 2011.03 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE matrix_ls_create(matrix_ls,matrix_qs,ls_mstruct,error) + SUBROUTINE matrix_ls_create(matrix_ls,matrix_qs,ls_mstruct) TYPE(cp_dbcsr_type) :: matrix_ls, matrix_qs TYPE(ls_mstruct_type), INTENT(IN) :: ls_mstruct - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_ls_create', & routineP = moduleN//':'//routineN @@ -130,10 +128,9 @@ SUBROUTINE matrix_ls_create(matrix_ls,matrix_qs,ls_mstruct,error) ! later, we might want to use our own format (e.g. clustered) SELECT CASE(ls_mstruct%cluster_type) CASE(ls_cluster_atomic) - CALL cp_dbcsr_init(matrix_ls,error=error) + CALL cp_dbcsr_init(matrix_ls) CALL cp_dbcsr_create(matrix_ls,template=matrix_qs, & - data_type=data_type,& - error=error) + data_type=data_type) CASE(ls_cluster_molecular) ! create format of the clustered matrix natom=cp_dbcsr_nblkrows_total(matrix_qs) @@ -204,16 +201,15 @@ SUBROUTINE matrix_ls_create(matrix_ls,matrix_qs,ls_mstruct,error) reuse_arrays=.TRUE.) ! the matrix - CALL cp_dbcsr_init (matrix_ls, error=error) + CALL cp_dbcsr_init (matrix_ls) CALL cp_dbcsr_create (matrix_ls, cp_dbcsr_name (matrix_qs),& clustered_distribution,& dbcsr_type_symmetric,& clustered_blk_sizes, clustered_blk_sizes,& - data_type=data_type,& - error=error) + data_type=data_type) DEALLOCATE(clustered_blk_sizes) CALL dbcsr_distribution_release (clustered_distribution) - CALL cp_dbcsr_finalize (matrix_ls, error=error) + CALL cp_dbcsr_finalize (matrix_ls) CASE DEFAULT STOP " BUG cluster option" END SELECT @@ -230,15 +226,13 @@ END SUBROUTINE matrix_ls_create !> \param matrix_ls ... !> \param matrix_qs ... !> \param ls_mstruct ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE matrix_qs_to_ls(matrix_ls,matrix_qs,ls_mstruct,error) + SUBROUTINE matrix_qs_to_ls(matrix_ls,matrix_qs,ls_mstruct) TYPE(cp_dbcsr_type) :: matrix_ls, matrix_qs TYPE(ls_mstruct_type), INTENT(IN) :: ls_mstruct - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_qs_to_ls', & routineP = moduleN//':'//routineN @@ -251,31 +245,30 @@ SUBROUTINE matrix_qs_to_ls(matrix_ls,matrix_qs,ls_mstruct,error) SELECT CASE(ls_mstruct%cluster_type) CASE(ls_cluster_atomic) ! takes care of an eventual data_type conversion - CALL cp_dbcsr_copy(matrix_ls,matrix_qs,error=error) + CALL cp_dbcsr_copy(matrix_ls,matrix_qs) CASE(ls_cluster_molecular) ! desymmetrize the qs matrix - CALL cp_dbcsr_init (matrix_qs_nosym, error=error) + CALL cp_dbcsr_init (matrix_qs_nosym) CALL cp_dbcsr_create (matrix_qs_nosym, template=matrix_qs,& - matrix_type=dbcsr_type_no_symmetry, error=error) - CALL cp_dbcsr_desymmetrize (matrix_qs, matrix_qs_nosym,& - error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_desymmetrize (matrix_qs, matrix_qs_nosym) ! complete_redistribute does not zero blocks that might be present in the ! target but not in the source - CALL cp_dbcsr_set(matrix_ls,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ls,0.0_dp) ! perform the magic complete redistribute copy IF (ls_mstruct%single_precision) THEN - CALL cp_dbcsr_init(matrix_tmp, error=error) + CALL cp_dbcsr_init(matrix_tmp) CALL cp_dbcsr_create(matrix_tmp,template=matrix_qs_nosym, & - data_type=dbcsr_type_real_4, error=error) - CALL cp_dbcsr_copy(matrix_tmp,matrix_qs_nosym,error=error) - CALL cp_dbcsr_complete_redistribute(matrix_tmp, matrix_ls, error=error); - CALL cp_dbcsr_release(matrix_tmp, error=error) + data_type=dbcsr_type_real_4) + CALL cp_dbcsr_copy(matrix_tmp,matrix_qs_nosym) + CALL cp_dbcsr_complete_redistribute(matrix_tmp, matrix_ls); + CALL cp_dbcsr_release(matrix_tmp) ELSE - CALL cp_dbcsr_complete_redistribute(matrix_qs_nosym, matrix_ls, error=error); + CALL cp_dbcsr_complete_redistribute(matrix_qs_nosym, matrix_ls); ENDIF - CALL cp_dbcsr_release (matrix_qs_nosym, error=error) + CALL cp_dbcsr_release (matrix_qs_nosym) CASE DEFAULT STOP @@ -292,15 +285,13 @@ SUBROUTINE matrix_qs_to_ls(matrix_ls,matrix_qs,ls_mstruct,error) !> \param matrix_qs ... !> \param matrix_ls ... !> \param ls_mstruct ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE matrix_ls_to_qs(matrix_qs,matrix_ls,ls_mstruct,error) + SUBROUTINE matrix_ls_to_qs(matrix_qs,matrix_ls,ls_mstruct) TYPE(cp_dbcsr_type) :: matrix_qs, matrix_ls TYPE(ls_mstruct_type), INTENT(IN) :: ls_mstruct - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'matrix_ls_to_qs', & routineP = moduleN//':'//routineN @@ -311,33 +302,33 @@ SUBROUTINE matrix_ls_to_qs(matrix_qs,matrix_ls,ls_mstruct,error) CALL timeset(routineN,handle) IF (ls_mstruct%single_precision) THEN - CALL cp_dbcsr_init (matrix_tmp, error=error) + CALL cp_dbcsr_init (matrix_tmp) CALL cp_dbcsr_create (matrix_tmp, template=matrix_ls,& - data_type=dbcsr_type_real_8, error=error) - CALL cp_dbcsr_copy (matrix_tmp, matrix_ls, error=error) + data_type=dbcsr_type_real_8) + CALL cp_dbcsr_copy (matrix_tmp, matrix_ls) ENDIF SELECT CASE(ls_mstruct%cluster_type) CASE(ls_cluster_atomic) IF (ls_mstruct%single_precision) THEN - CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_tmp, error=error) + CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_tmp) ELSE - CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_ls, error=error) + CALL cp_dbcsr_copy_into_existing (matrix_qs, matrix_ls) ENDIF CASE(ls_cluster_molecular) - CALL cp_dbcsr_set(matrix_qs,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_qs,0.0_dp) IF (ls_mstruct%single_precision) THEN - CALL cp_dbcsr_complete_redistribute(matrix_tmp, matrix_qs, keep_sparsity=.TRUE., error=error) + CALL cp_dbcsr_complete_redistribute(matrix_tmp, matrix_qs, keep_sparsity=.TRUE.) ELSE - CALL cp_dbcsr_complete_redistribute(matrix_ls, matrix_qs, keep_sparsity=.TRUE., error=error) + CALL cp_dbcsr_complete_redistribute(matrix_ls, matrix_qs, keep_sparsity=.TRUE.) ENDIF CASE DEFAULT STOP "BUG" END SELECT IF (ls_mstruct%single_precision) THEN - CALL cp_dbcsr_release(matrix_tmp,error=error) + CALL cp_dbcsr_release(matrix_tmp) ENDIF CALL timestop(handle) @@ -348,14 +339,12 @@ END SUBROUTINE matrix_ls_to_qs !> \brief further required initialization of QS. !> Might be factored-out since this seems common code with the other SCF. !> \param qs_env ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_init_qs(qs_env,error) + SUBROUTINE ls_scf_init_qs(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_init_qs', & routineP = moduleN//':'//routineN @@ -373,7 +362,7 @@ SUBROUTINE ls_scf_init_qs(qs_env,error) CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -385,22 +374,21 @@ SUBROUTINE ls_scf_init_qs(qs_env,error) matrix_s=matrix_s,& matrix_ks=matrix_ks,& ks_env=ks_env,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) nspin=dft_control%nspins ! we might have to create matrix_ks IF (.NOT.ASSOCIATED(matrix_ks)) THEN - CALL cp_dbcsr_allocate_matrix_set(matrix_ks,nspin,error) + CALL cp_dbcsr_allocate_matrix_set(matrix_ks,nspin) DO ispin=1,nspin ALLOCATE(matrix_ks(ispin)%matrix) - CALL cp_dbcsr_init(matrix_ks(ispin)%matrix,error=error) - CALL cp_dbcsr_create(matrix_ks(ispin)%matrix,template=matrix_s(1)%matrix,error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks(ispin)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_init(matrix_ks(ispin)%matrix) + CALL cp_dbcsr_create(matrix_ks(ispin)%matrix,template=matrix_s(1)%matrix) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks(ispin)%matrix,sab_orb) + CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp) ENDDO - CALL set_ks_env(ks_env,matrix_ks=matrix_ks,error=error) + CALL set_ks_env(ks_env,matrix_ks=matrix_ks) ENDIF CALL timestop(handle) @@ -411,15 +399,13 @@ END SUBROUTINE ls_scf_init_qs !> \brief get an atomic initial guess !> \param qs_env ... !> \param energy ... -!> \param error ... !> \par History !> 2012.11 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_qs_atomic_guess(qs_env,energy,error) + SUBROUTINE ls_scf_qs_atomic_guess(qs_env,energy) TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp) :: energy - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_qs_atomic_guess', & routineP = moduleN//':'//routineN @@ -446,7 +432,7 @@ SUBROUTINE ls_scf_qs_atomic_guess(qs_env,energy,error) NULLIFY(rho,rho_ao) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -465,32 +451,31 @@ SUBROUTINE ls_scf_qs_atomic_guess(qs_env,energy,error) has_unit_metric=has_unit_metric,& para_env=para_env,& nelectron_spin=nelectron_spin,& - rho=rho,& - error=error) + rho=rho) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) nspin=dft_control%nspins ! create an initial atomic guess DO ispin=1,nspin - CALL cp_dbcsr_set(rho_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(rho_ao(ispin)%matrix,0.0_dp) IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%semi_empirical) THEN CALL calculate_mopac_dm(rho_ao(ispin)%matrix,matrix_s(1)%matrix, has_unit_metric, & dft_control,particle_set, atomic_kind_set, qs_kind_set,& nspin, nelectron_spin(ispin),& - para_env, error) + para_env) ELSE CALL calculate_atomic_block_dm(rho_ao(ispin)%matrix,matrix_s(1)%matrix, & particle_set, atomic_kind_set, qs_kind_set, & ispin, nspin, nelectron_spin(ispin), & - unit_nr, error) + unit_nr) ENDIF ENDDO - CALL qs_rho_update_rho(rho,qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE., error=error) - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., error=error) + CALL qs_rho_update_rho(rho,qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.FALSE.) energy=qs_energy%total @@ -504,18 +489,16 @@ END SUBROUTINE ls_scf_qs_atomic_guess !> \param ls_scf_env ... !> \param energy_new ... !> \param iscf ... -!> \param error ... !> \par History !> 2011.04 created [Joost VandeVondele] !> 2015.02 added gspace density mixing [Patrick Seewald] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_dm_to_ks(qs_env,ls_scf_env,energy_new,iscf,error) + SUBROUTINE ls_scf_dm_to_ks(qs_env,ls_scf_env,energy_new,iscf) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env REAL(KIND=dp) :: energy_new INTEGER, INTENT(IN) :: iscf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_dm_to_ks', & routineP = moduleN//':'//routineN @@ -531,7 +514,7 @@ SUBROUTINE ls_scf_dm_to_ks(qs_env,ls_scf_env,energy_new,iscf,error) NULLIFY(energy, rho, rho_ao) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -539,26 +522,26 @@ SUBROUTINE ls_scf_dm_to_ks(qs_env,ls_scf_env,energy_new,iscf,error) ENDIF nspin=ls_scf_env%nspins - CALL get_qs_env(qs_env, para_env=para_env, energy=energy, rho=rho, error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL get_qs_env(qs_env, para_env=para_env, energy=energy, rho=rho) + CALL qs_rho_get(rho, rho_ao=rho_ao) ! set the new density matrix DO ispin=1,nspin - CALL matrix_ls_to_qs(rho_ao(ispin)%matrix, ls_scf_env%matrix_p(ispin), ls_scf_env%ls_mstruct, error=error) + CALL matrix_ls_to_qs(rho_ao(ispin)%matrix, ls_scf_env%matrix_p(ispin), ls_scf_env%ls_mstruct) END DO ! compute the corresponding KS matrix and new energy, mix density if requested - CALL qs_rho_update_rho(rho,qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho,qs_env=qs_env) IF(ls_scf_env%do_rho_mixing) THEN CALL cp_assert(ls_scf_env%density_mixing_method .NE. direct_mixing_nr, & cp_failure_level,cp_assertion_failed, routineP, & "Direct P mixing not implemented in linear scaling SCF. ", & - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) IF (ls_scf_env%density_mixing_method>=gspace_mixing_nr) THEN IF(iscf .GT. MAX(ls_scf_env%mixing_store%nskip_mixing,1)) THEN CALL gspace_mixing(qs_env, ls_scf_env%density_mixing_method, & ls_scf_env%mixing_store, rho, para_env, & - iscf-1, error) + iscf-1) IF(unit_nr>0) THEN WRITE(unit_nr,'(A57)') & "*********************************************************" @@ -575,9 +558,9 @@ SUBROUTINE ls_scf_dm_to_ks(qs_env,ls_scf_env,energy_new,iscf,error) ENDIF ENDIF - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE., error=error) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.,& - just_energy=.FALSE., print_active=.TRUE., error=error) + just_energy=.FALSE., print_active=.TRUE.) energy_new=energy%total CALL timestop(handle) @@ -593,16 +576,14 @@ END SUBROUTINE ls_scf_dm_to_ks !> \param unit_nr ... !> \param title ... !> \param stride ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_matrix_to_cube(qs_env,ls_scf_env,matrix_p_ls,unit_nr,title,stride,error) + SUBROUTINE write_matrix_to_cube(qs_env,ls_scf_env,matrix_p_ls,unit_nr,title,stride) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_p_ls INTEGER, INTENT(IN) :: unit_nr CHARACTER(LEN=*), INTENT(IN) :: title INTEGER, DIMENSION(:), POINTER :: stride - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_matrix_to_cube', & routineP = moduleN//':'//routineN @@ -629,50 +610,45 @@ SUBROUTINE write_matrix_to_cube(qs_env,ls_scf_env,matrix_p_ls,unit_nr,title,stri ks_env=ks_env,& subsys=subsys,& pw_env=pw_env,& - matrix_ks=matrix_ks,& - error=error) + matrix_ks=matrix_ks) - CALL qs_subsys_get(subsys,particles=particles,error=error) + CALL qs_subsys_get(subsys,particles=particles) ! convert the density matrix (ls style) to QS style ALLOCATE(matrix_p_qs) - CALL cp_dbcsr_init(matrix_p_qs,error=error) !initialization - CALL cp_dbcsr_copy(matrix_p_qs,matrix_ks(1)%matrix,error=error) - CALL cp_dbcsr_set(matrix_p_qs,0.0_dp,error=error) !zero matrix creation - CALL matrix_ls_to_qs(matrix_p_qs, matrix_p_ls,ls_scf_env%ls_mstruct,error=error) + CALL cp_dbcsr_init(matrix_p_qs) !initialization + CALL cp_dbcsr_copy(matrix_p_qs,matrix_ks(1)%matrix) + CALL cp_dbcsr_set(matrix_p_qs,0.0_dp) !zero matrix creation + CALL matrix_ls_to_qs(matrix_p_qs, matrix_p_ls,ls_scf_env%ls_mstruct) ! Print total electronic density CALL pw_env_get(pw_env=pw_env,& auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,& - error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=wf_r%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_zero(wf_r%pw,error=error) + in_space=REALSPACE) + CALL pw_zero(wf_r%pw) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=wf_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(wf_g%pw,error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero(wf_g%pw) CALL calculate_rho_elec(matrix_p=matrix_p_qs,& rho=wf_r,& rho_gspace=wf_g,& total_rho=tot_rho,& - ks_env=ks_env, & - error=error) + ks_env=ks_env) ! write this to a cube CALL cp_pw_to_cube(wf_r%pw, unit_nr=unit_nr, title=title,& - particles=particles, stride=stride, error = error) + particles=particles, stride=stride) !free memory - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw,error=error) - CALL cp_dbcsr_release(matrix_p_qs,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw) + CALL cp_dbcsr_release(matrix_p_qs) DEALLOCATE(matrix_p_qs) CALL timestop(handle) @@ -683,12 +659,10 @@ END SUBROUTINE write_matrix_to_cube !> \brief Initialize g-space density mixing !> \param qs_env ... !> \param ls_scf_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rho_mixing_ls_init(qs_env, ls_scf_env, error) + SUBROUTINE rho_mixing_ls_init(qs_env, ls_scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(ls_scf_env_type) :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rho_mixing_ls_init', & routineP = moduleN//':'//routineN @@ -702,19 +676,18 @@ SUBROUTINE rho_mixing_ls_init(qs_env, ls_scf_env, error) CALL timeset(routineN,handle) CALL get_qs_env(qs_env,dft_control=dft_control,& - rho=rho,& - error=error) + rho=rho) CALL mixing_allocate(qs_env, ls_scf_env%density_mixing_method, nspins=ls_scf_env%nspins, & - mixing_store=ls_scf_env%mixing_store,error=error) + mixing_store=ls_scf_env%mixing_store) IF(ls_scf_env%density_mixing_method>=gspace_mixing_nr) THEN IF(dft_control%qs_control%gapw) THEN - CALL get_qs_env(qs_env, rho_atom_set=rho_atom,error=error) + CALL get_qs_env(qs_env, rho_atom_set=rho_atom) CALL mixing_init(ls_scf_env%density_mixing_method, rho,ls_scf_env%mixing_store, & - ls_scf_env%para_env, rho_atom=rho_atom,error=error) + ls_scf_env%para_env, rho_atom=rho_atom) ELSE CALL mixing_init(ls_scf_env%density_mixing_method, rho,ls_scf_env%mixing_store, & - ls_scf_env%para_env,error=error) + ls_scf_env%para_env) ENDIF ENDIF CALL timestop(handle) diff --git a/src/dm_ls_scf_types.F b/src/dm_ls_scf_types.F index c9a0448d9e..03cbc7602f 100644 --- a/src/dm_ls_scf_types.F +++ b/src/dm_ls_scf_types.F @@ -149,14 +149,12 @@ MODULE dm_ls_scf_types ! ***************************************************************************** !> \brief release the LS type. !> \param ls_scf_env ... -!> \param error ... !> \par History !> 2012.11 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE ls_scf_release(ls_scf_env,error) + SUBROUTINE ls_scf_release(ls_scf_env) TYPE(ls_scf_env_type), POINTER :: ls_scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ls_scf_release', & routineP = moduleN//':'//routineN @@ -167,43 +165,43 @@ SUBROUTINE ls_scf_release(ls_scf_env,error) CALL timeset(routineN,handle) failure=.FALSE. - CALL cp_para_env_release(ls_scf_env%para_env,error) + CALL cp_para_env_release(ls_scf_env%para_env) DEALLOCATE(ls_scf_env%ls_mstruct%atom_to_molecule,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! set up the buffer for the history of matrices DO istore=1,MIN(ls_scf_env%scf_history%istore,ls_scf_env%scf_history%nstore) DO ispin=1,SIZE(ls_scf_env%scf_history%matrix,1) - CALL cp_dbcsr_release(ls_scf_env%scf_history%matrix(ispin,istore),error=error) + CALL cp_dbcsr_release(ls_scf_env%scf_history%matrix(ispin,istore)) ENDDO ENDDO DEALLOCATE(ls_scf_env%scf_history%matrix,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_dos)) & - CALL section_vals_release(ls_scf_env%chebyshev%print_key_dos,error=error) + CALL section_vals_release(ls_scf_env%chebyshev%print_key_dos) IF (ASSOCIATED(ls_scf_env%chebyshev%print_key_cube)) & - CALL section_vals_release(ls_scf_env%chebyshev%print_key_cube,error=error) + CALL section_vals_release(ls_scf_env%chebyshev%print_key_cube) IF (ASSOCIATED(ls_scf_env%chebyshev%min_energy)) THEN DEALLOCATE(ls_scf_env%chebyshev%min_energy,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(ls_scf_env%chebyshev%max_energy)) THEN DEALLOCATE(ls_scf_env%chebyshev%max_energy,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(ls_scf_env%mixing_store)) THEN - CALL mixing_storage_release(ls_scf_env%mixing_store,error) + CALL mixing_storage_release(ls_scf_env%mixing_store) ENDIF IF (ls_scf_env%purification_method .EQ. ls_scf_pexsi) THEN - CALL lib_pexsi_finalize(ls_scf_env%pexsi, error) + CALL lib_pexsi_finalize(ls_scf_env%pexsi) ENDIF DEALLOCATE(ls_scf_env,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/domain_submatrix_methods.F b/src/domain_submatrix_methods.F index a5f68e3b73..71e27d9330 100644 --- a/src/domain_submatrix_methods.F +++ b/src/domain_submatrix_methods.F @@ -83,13 +83,11 @@ MODULE domain_submatrix_methods ! ***************************************************************************** !> \brief ... !> \param subm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_submatrices_0d(subm,error) + SUBROUTINE init_submatrices_0d(subm) TYPE(domain_submatrix_type), & INTENT(INOUT) :: subm - TYPE(cp_error_type), INTENT(INOUT) :: error subm%domain=-1 subm%nbrows=-1 @@ -104,13 +102,11 @@ END SUBROUTINE init_submatrices_0d ! ***************************************************************************** !> \brief ... !> \param subm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_submatrices_1d(subm,error) + SUBROUTINE init_submatrices_1d(subm) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(INOUT) :: subm - TYPE(cp_error_type), INTENT(INOUT) :: error subm(:)%domain=-1 subm(:)%nbrows=-1 @@ -125,13 +121,11 @@ END SUBROUTINE init_submatrices_1d ! ***************************************************************************** !> \brief ... !> \param subm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_submatrices_2d(subm,error) + SUBROUTINE init_submatrices_2d(subm) TYPE(domain_submatrix_type), & DIMENSION(:, :), INTENT(INOUT) :: subm - TYPE(cp_error_type), INTENT(INOUT) :: error subm(:,:)%domain=-1 subm(:,:)%nbrows=-1 @@ -148,16 +142,14 @@ END SUBROUTINE init_submatrices_2d !> \param original ... !> \param copy ... !> \param copy_data ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_submatrix_array(original,copy,copy_data,error) + SUBROUTINE copy_submatrix_array(original,copy,copy_data) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN) :: original TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(INOUT) :: copy LOGICAL, INTENT(IN) :: copy_data - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'copy_submatrix_array', & routineP = moduleN//':'//routineN @@ -170,12 +162,12 @@ SUBROUTINE copy_submatrix_array(original,copy,copy_data,error) ndomains=SIZE(original) ndomainsB=SIZE(copy) - CPPrecondition(ndomains.eq.ndomainsB,cp_failure_level,routineP,error,failure) + CPPrecondition(ndomains.eq.ndomainsB,cp_failure_level,routineP,failure) copy(:)%nnodes=original(:)%nnodes copy(:)%groupid=original(:)%groupid DO idomain = 1, ndomains IF (original(idomain)%domain.gt.0) THEN - CALL copy_submatrix(original(idomain),copy(idomain),copy_data,error) + CALL copy_submatrix(original(idomain),copy(idomain),copy_data) ENDIF ENDDO ! loop over domains @@ -188,15 +180,13 @@ END SUBROUTINE copy_submatrix_array !> \param original ... !> \param copy ... !> \param copy_data ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_submatrix(original,copy,copy_data,error) + SUBROUTINE copy_submatrix(original,copy,copy_data) TYPE(domain_submatrix_type), INTENT(IN) :: original TYPE(domain_submatrix_type), & INTENT(INOUT) :: copy LOGICAL, INTENT(IN) :: copy_data - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'copy_submatrix', & routineP = moduleN//':'//routineN @@ -260,7 +250,7 @@ SUBROUTINE copy_submatrix(original,copy,copy_data,error) ENDDO IF (copy_data) THEN - CALL copy_submatrix_data(original%mdata,copy,error) + CALL copy_submatrix_data(original%mdata,copy) ENDIF ENDIF ! do not copy empty submatrix @@ -273,15 +263,13 @@ END SUBROUTINE copy_submatrix !> \brief ... !> \param array ... !> \param copy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE copy_submatrix_data(array,copy,error) + SUBROUTINE copy_submatrix_data(array,copy) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: array TYPE(domain_submatrix_type), & INTENT(INOUT) :: copy - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'copy_submatrix_data', & routineP = moduleN//':'//routineN @@ -291,7 +279,7 @@ SUBROUTINE copy_submatrix_data(array,copy,error) CALL timeset(routineN,handle) - CPPrecondition(copy%domain.gt.0,cp_failure_level,routineP,error,failure) + CPPrecondition(copy%domain.gt.0,cp_failure_level,routineP,failure) ds1=SIZE(array,1) ds2=SIZE(array,2) @@ -317,14 +305,12 @@ END SUBROUTINE copy_submatrix_data !> \brief ... !> \param submatrices ... !> \param scalar ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_submatrix_array(submatrices,scalar,error) + SUBROUTINE set_submatrix_array(submatrices,scalar) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(INOUT) :: submatrices REAL(KIND=dp), INTENT(IN) :: scalar - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_submatrix_array', & routineP = moduleN//':'//routineN @@ -336,7 +322,7 @@ SUBROUTINE set_submatrix_array(submatrices,scalar,error) ndomains=SIZE(submatrices) DO idomain = 1, ndomains IF (submatrices(idomain)%domain.gt.0) THEN - CALL set_submatrix(submatrices(idomain),scalar,error) + CALL set_submatrix(submatrices(idomain),scalar) ENDIF ENDDO ! loop over domains @@ -348,14 +334,12 @@ END SUBROUTINE set_submatrix_array !> \brief ... !> \param submatrix ... !> \param scalar ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_submatrix(submatrix,scalar,error) + SUBROUTINE set_submatrix(submatrix,scalar) TYPE(domain_submatrix_type), & INTENT(INOUT) :: submatrix REAL(KIND=dp), INTENT(IN) :: scalar - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_submatrix', & routineP = moduleN//':'//routineN @@ -365,9 +349,9 @@ SUBROUTINE set_submatrix(submatrix,scalar,error) CALL timeset(routineN,handle) - CPPrecondition(submatrix%domain.gt.0,cp_failure_level,routineP,error,failure) - CPPrecondition(submatrix%nrows.gt.0,cp_failure_level,routineP,error,failure) - CPPrecondition(submatrix%ncols.gt.0,cp_failure_level,routineP,error,failure) + CPPrecondition(submatrix%domain.gt.0,cp_failure_level,routineP,failure) + CPPrecondition(submatrix%nrows.gt.0,cp_failure_level,routineP,failure) + CPPrecondition(submatrix%ncols.gt.0,cp_failure_level,routineP,failure) ds1=submatrix%nrows ds2=submatrix%ncols @@ -392,13 +376,11 @@ END SUBROUTINE set_submatrix ! ***************************************************************************** !> \brief ... !> \param subm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_submatrix_array(subm,error) + SUBROUTINE release_submatrix_array(subm) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(INOUT) :: subm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_submatrix_array', & routineP = moduleN//':'//routineN @@ -409,7 +391,7 @@ SUBROUTINE release_submatrix_array(subm,error) ndomains=SIZE(subm) DO idomain = 1, ndomains - CALL release_submatrix(subm(idomain),error) + CALL release_submatrix(subm(idomain)) ENDDO ! loop over domains CALL timestop(handle) @@ -419,13 +401,11 @@ END SUBROUTINE release_submatrix_array ! ***************************************************************************** !> \brief ... !> \param subm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_submatrix(subm,error) + SUBROUTINE release_submatrix(subm) TYPE(domain_submatrix_type), & INTENT(INOUT) :: subm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_submatrix', & routineP = moduleN//':'//routineN @@ -472,9 +452,8 @@ END SUBROUTINE release_submatrix !> \param B ... !> \param beta ... !> \param C ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE multiply_submatrices_once(transA,transB,alpha,A,B,beta,C,error) + SUBROUTINE multiply_submatrices_once(transA,transB,alpha,A,B,beta,C) CHARACTER, INTENT(IN) :: transA, transB REAL(KIND=dp), INTENT(IN) :: alpha @@ -482,7 +461,6 @@ SUBROUTINE multiply_submatrices_once(transA,transB,alpha,A,B,beta,C,error) REAL(KIND=dp), INTENT(IN) :: beta TYPE(domain_submatrix_type), & INTENT(INOUT) :: C - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'multiply_submatrices_once', & routineP = moduleN//':'//routineN @@ -494,9 +472,9 @@ SUBROUTINE multiply_submatrices_once(transA,transB,alpha,A,B,beta,C,error) CALL timeset(routineN,handle) - CPPrecondition(A%domain.gt.0,cp_failure_level,routineP,error,failure) - CPPrecondition(B%domain.gt.0,cp_failure_level,routineP,error,failure) - CPPrecondition(C%domain.gt.0,cp_failure_level,routineP,error,failure) + CPPrecondition(A%domain.gt.0,cp_failure_level,routineP,failure) + CPPrecondition(B%domain.gt.0,cp_failure_level,routineP,failure) + CPPrecondition(C%domain.gt.0,cp_failure_level,routineP,failure) LDA = SIZE(A%mdata,1) LDB = SIZE(B%mdata,1) @@ -525,7 +503,7 @@ SUBROUTINE multiply_submatrices_once(transA,transB,alpha,A,B,beta,C,error) ENDIF ! these checks are for debugging only - CPPrecondition(K.eq.K1,cp_failure_level,routineP,error,failure) + CPPrecondition(K.eq.K1,cp_failure_level,routineP,failure) ! conform C matrix C%nrows=M @@ -571,14 +549,14 @@ SUBROUTINE multiply_submatrices_once(transA,transB,alpha,A,B,beta,C,error) IF (.NOT.ALLOCATED(C%mdata)) THEN !!! cannot use non-zero beta if C is not allocated - CPPrecondition(beta.eq.0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(beta.eq.0.0_dp,cp_failure_level,routineP,failure) ALLOCATE(C%mdata(C%nrows,C%ncols)) ELSE cs1=SIZE(C%mdata,1) cs2=SIZE(C%mdata,2) IF ((C%nrows.ne.cs1).OR.(C%ncols.ne.cs2)) THEN !!! cannot deallocate data if beta is non-zero - CPPrecondition(beta.eq.0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(beta.eq.0.0_dp,cp_failure_level,routineP,failure) DEALLOCATE(C%mdata) ALLOCATE(C%mdata(C%nrows,C%ncols)) ENDIF @@ -604,9 +582,8 @@ END SUBROUTINE multiply_submatrices_once !> \param B ... !> \param beta ... !> \param C ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE multiply_submatrices_array(transA,transB,alpha,A,B,beta,C,error) + SUBROUTINE multiply_submatrices_array(transA,transB,alpha,A,B,beta,C) CHARACTER, INTENT(IN) :: transA, transB REAL(KIND=dp), INTENT(IN) :: alpha @@ -615,7 +592,6 @@ SUBROUTINE multiply_submatrices_array(transA,transB,alpha,A,B,beta,C,error) REAL(KIND=dp), INTENT(IN) :: beta TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(INOUT) :: C - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'multiply_submatrices_array', & routineP = moduleN//':'//routineN @@ -631,21 +607,21 @@ SUBROUTINE multiply_submatrices_array(transA,transB,alpha,A,B,beta,C,error) ndomainsB=SIZE(B) ndomainsC=SIZE(C) - CPPrecondition(ndomains.eq.ndomainsB,cp_failure_level,routineP,error,failure) - CPPrecondition(ndomainsB.eq.ndomainsC,cp_failure_level,routineP,error,failure) + CPPrecondition(ndomains.eq.ndomainsB,cp_failure_level,routineP,failure) + CPPrecondition(ndomainsB.eq.ndomainsC,cp_failure_level,routineP,failure) DO idomain = 1, ndomains idomainA = A(idomain)%domain idomainB = B(idomain)%domain - CPPrecondition(idomainA.eq.idomainB,cp_failure_level,routineP,error,failure) + CPPrecondition(idomainA.eq.idomainB,cp_failure_level,routineP,failure) C(idomain)%domain = idomainA ! check if the submatrix exists IF (idomainA.gt.0) THEN - CALL multiply_submatrices_once(transA,transB,alpha,A(idomain),B(idomain),beta,C(idomain),error) + CALL multiply_submatrices_once(transA,transB,alpha,A(idomain),B(idomain),beta,C(idomain)) ENDIF ! submatrix for the domain exists ENDDO ! loop over domains @@ -662,9 +638,8 @@ END SUBROUTINE multiply_submatrices_array !> \param beta ... !> \param B ... !> \param transB ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE add_submatrices_once(alpha,A,beta,B,transB,error) + SUBROUTINE add_submatrices_once(alpha,A,beta,B,transB) REAL(KIND=dp), INTENT(IN) :: alpha TYPE(domain_submatrix_type), & @@ -672,7 +647,6 @@ SUBROUTINE add_submatrices_once(alpha,A,beta,B,transB,error) REAL(KIND=dp), INTENT(IN) :: beta TYPE(domain_submatrix_type), INTENT(IN) :: B CHARACTER, INTENT(IN) :: transB - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_submatrices_once', & routineP = moduleN//':'//routineN @@ -682,8 +656,8 @@ SUBROUTINE add_submatrices_once(alpha,A,beta,B,transB,error) CALL timeset(routineN,handle) - CPPrecondition(A%domain.gt.0,cp_failure_level,routineP,error,failure) - CPPrecondition(B%domain.gt.0,cp_failure_level,routineP,error,failure) + CPPrecondition(A%domain.gt.0,cp_failure_level,routineP,failure) + CPPrecondition(B%domain.gt.0,cp_failure_level,routineP,failure) R1 = A%nrows C1 = A%ncols @@ -699,8 +673,8 @@ SUBROUTINE add_submatrices_once(alpha,A,beta,B,transB,error) ENDIF ! these checks are for debugging only - CPPrecondition(C1.eq.C2,cp_failure_level,routineP,error,failure) - CPPrecondition(R1.eq.R2,cp_failure_level,routineP,error,failure) + CPPrecondition(C1.eq.C2,cp_failure_level,routineP,failure) + CPPrecondition(R1.eq.R2,cp_failure_level,routineP,failure) IF (NOTB) THEN DO icol = 1, C1 @@ -723,9 +697,8 @@ END SUBROUTINE add_submatrices_once !> \param beta ... !> \param B ... !> \param transB ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE add_submatrices_array(alpha,A,beta,B,transB,error) + SUBROUTINE add_submatrices_array(alpha,A,beta,B,transB) REAL(KIND=dp), INTENT(IN) :: alpha TYPE(domain_submatrix_type), & @@ -734,7 +707,6 @@ SUBROUTINE add_submatrices_array(alpha,A,beta,B,transB,error) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN) :: B CHARACTER, INTENT(IN) :: transB - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_submatrices_array', & routineP = moduleN//':'//routineN @@ -748,18 +720,18 @@ SUBROUTINE add_submatrices_array(alpha,A,beta,B,transB,error) ndomains=SIZE(A) ndomainsB=SIZE(B) - CPPrecondition(ndomains.eq.ndomainsB,cp_failure_level,routineP,error,failure) + CPPrecondition(ndomains.eq.ndomainsB,cp_failure_level,routineP,failure) DO idomain = 1, ndomains idomainA = A(idomain)%domain idomainB = B(idomain)%domain - CPPrecondition(idomainA.eq.idomainB,cp_failure_level,routineP,error,failure) + CPPrecondition(idomainA.eq.idomainB,cp_failure_level,routineP,failure) ! check if the submatrix exists IF (idomainA.gt.0) THEN - CALL add_submatrices_once(alpha,A(idomain),beta,B(idomain),transB,error) + CALL add_submatrices_once(alpha,A(idomain),beta,B(idomain),transB) ENDIF ! submatrix for the domain exists ENDDO ! loop over domains @@ -772,17 +744,15 @@ END SUBROUTINE add_submatrices_array !> \brief Computes the max norm of the collection of submatrices !> \param submatrices ... !> \param norm ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - SUBROUTINE maxnorm_submatrices(submatrices,norm,error) + SUBROUTINE maxnorm_submatrices(submatrices,norm) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN) :: submatrices REAL(KIND=dp), INTENT(OUT) :: norm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'maxnorm_submatrices', & routineP = moduleN//':'//routineN @@ -826,17 +796,15 @@ END SUBROUTINE maxnorm_submatrices !> \param A ... !> \param B ... !> \param trace ... -!> \param error ... !> \par History !> 2013.03 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - SUBROUTINE trace_submatrices(A,B,trace,error) + SUBROUTINE trace_submatrices(A,B,trace) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN) :: A, B REAL(KIND=dp), INTENT(OUT) :: trace - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'trace_submatrices', & routineP = moduleN//':'//routineN @@ -856,20 +824,20 @@ SUBROUTINE trace_submatrices(A,B,trace,error) ndomainsA=SIZE(A) ndomainsB=SIZE(B) - CPPrecondition(ndomainsA.eq.ndomainsB,cp_failure_level,routineP,error,failure) + CPPrecondition(ndomainsA.eq.ndomainsB,cp_failure_level,routineP,failure) DO idomain = 1, ndomainsA domainA = A(idomain)%domain domainB = B(idomain)%domain - CPPrecondition(domainA.eq.domainB,cp_failure_level,routineP,error,failure) + CPPrecondition(domainA.eq.domainB,cp_failure_level,routineP,failure) ! check if the submatrix is local IF (domainA.gt.0) THEN - CPPrecondition(A(idomain)%nrows.eq.B(idomain)%nrows,cp_failure_level,routineP,error,failure) - CPPrecondition(A(idomain)%ncols.eq.B(idomain)%ncols,cp_failure_level,routineP,error,failure) + CPPrecondition(A(idomain)%nrows.eq.B(idomain)%nrows,cp_failure_level,routineP,failure) + CPPrecondition(A(idomain)%ncols.eq.B(idomain)%ncols,cp_failure_level,routineP,failure) curr_trace=SUM(A(idomain)%mdata(:,:)*B(idomain)%mdata(:,:)) send_trace=send_trace+curr_trace @@ -899,13 +867,12 @@ END SUBROUTINE trace_submatrices !> \param domain_map ... !> \param node_of_domain ... !> \param job_type ... -!> \param error ... !> \par History !> 2013.01 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& - node_of_domain,job_type,error) + node_of_domain,job_type) TYPE(cp_dbcsr_type), INTENT(IN) :: matrix TYPE(domain_submatrix_type), & @@ -914,7 +881,6 @@ SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& TYPE(domain_map_type), INTENT(IN) :: domain_map INTEGER, DIMENSION(:), INTENT(IN) :: node_of_domain INTEGER, INTENT(IN) :: job_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'construct_submatrices', & routineP = moduleN//':'//routineN @@ -1024,11 +990,11 @@ SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& ! row_size=row_size,col_size=col_size) ! DO idomain = 1, ndomains ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain,error)& - ! .AND.qblk_exists(domain_map,row,idomain,error)) + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& + ! .AND.qblk_exists(domain_map,row,idomain)) ! ELSE ! domain_needs_block=(idomain==col& - ! .AND.qblk_exists(domain_map,row,idomain,error)) + ! .AND.qblk_exists(domain_map,row,idomain)) ! ENDIF ! IF (domain_needs_block) THEN ! transp=.FALSE. @@ -1173,11 +1139,11 @@ SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& ! row_size=row_size,col_size=col_size) ! DO idomain = 1, ndomains ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain,error)& - ! .AND.qblk_exists(domain_map,row,idomain,error)) + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)& + ! .AND.qblk_exists(domain_map,row,idomain)) ! ELSE ! domain_needs_block=(idomain==col& - ! .AND.qblk_exists(domain_map,row,idomain,error)) + ! .AND.qblk_exists(domain_map,row,idomain)) ! ENDIF ! IF (domain_needs_block) THEN ! transp=.FALSE. @@ -1228,10 +1194,10 @@ SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& ! subm_col_size(:)=0 ndomains2=SIZE(submatrix) IF (ndomains2.ne.ndomains) THEN - CPErrorMessage(cp_failure_level,routineP,"wrong submatrix size",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"wrong submatrix size") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF - CALL release_submatrices(submatrix,error) + CALL release_submatrices(submatrix) submatrix(:)%nnodes=nNodes submatrix(:)%groupID=GroupID submatrix(:)%nrows=0 @@ -1257,7 +1223,7 @@ SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& DO index_row=index_sr, index_er row = domain_map%pairs(index_row,1) !DO row = 1, nblkrows_tot - ! IF (qblk_exists(domain_map,row,idomain,error)) THEN + ! IF (qblk_exists(domain_map,row,idomain)) THEN first_row(row)=submatrix(idomain)%nrows+1 submatrix(idomain)%nrows=submatrix(idomain)%nrows+row_blk_size(row) submatrix(idomain)%nbrows=submatrix(idomain)%nbrows+1 @@ -1300,7 +1266,7 @@ SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& ENDIF !DO col = 1, nblkcols_tot ! IF (job_type==select_row_col) THEN - ! domain_needs_block=(qblk_exists(domain_map,col,idomain,error)) + ! domain_needs_block=(qblk_exists(domain_map,col,idomain)) ! ELSE ! domain_needs_block=(col==idomain) ! RZK-warning col belongs to the domain ! ENDIF @@ -1380,8 +1346,8 @@ SUBROUTINE construct_submatrices(matrix,submatrix,distr_pattern,domain_map,& ENDDO ELSE IF (matrix_type==dbcsr_type_no_symmetry) THEN ELSE - CPErrorMessage(cp_failure_level,routineP,"matrix type is NYI",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"matrix type is NYI") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ENDIF ENDIF @@ -1407,19 +1373,16 @@ END SUBROUTINE construct_submatrices !> \param matrix ... !> \param submatrix ... !> \param distr_pattern ... -!> \param error ... !> \par History !> 2013.01 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& - error) + SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN) :: submatrix TYPE(cp_dbcsr_type), INTENT(IN) :: distr_pattern - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'construct_dbcsr_from_submatrices', & @@ -1447,7 +1410,7 @@ SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -1461,8 +1424,8 @@ SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& ndomains2 = SIZE(submatrix) IF (ndomains.ne.ndomains2) THEN - CPErrorMessage(cp_failure_level,routineP,"domain mismatch",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"domain mismatch") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF nNodes = dbcsr_mp_numnodes(dbcsr_distribution_mp(& @@ -1474,8 +1437,8 @@ SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& matrix_type=cp_dbcsr_get_matrix_type(matrix) IF (matrix_type.ne.dbcsr_type_no_symmetry) THEN - CPErrorMessage(cp_failure_level,routineP,"only non-symmetric matrices so far",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"only non-symmetric matrices so far") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF ! remove all blocks from the dbcsr matrix @@ -1485,10 +1448,9 @@ SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& block_p(:,:)=0.0_dp ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_filter(matrix,0.1_dp,error=error) + CALL cp_dbcsr_filter(matrix,0.1_dp) - CALL cp_dbcsr_work_create(matrix,work_mutable=.TRUE.,& - error=error) + CALL cp_dbcsr_work_create(matrix,work_mutable=.TRUE.) ldesc=2 ALLOCATE(send_descriptor(ldesc,nNodes)) @@ -1503,16 +1465,16 @@ SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& DO irow_subm = 1, submatrix(idomain)%nbrows IF (submatrix(idomain)%nbcols.ne.1) THEN - CPErrorMessage(cp_failure_level,routineP,"corrupt submatrix structure",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"corrupt submatrix structure") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF row = submatrix(idomain)%dbcsr_row(irow_subm) col = submatrix(idomain)%dbcsr_col(1) IF (col.ne.idomain) THEN - CPErrorMessage(cp_failure_level,routineP,"corrupt submatrix structure",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"corrupt submatrix structure") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF transp=.FALSE. @@ -1657,7 +1619,7 @@ SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& !IF (.NOT.found) THEN NULLIFY (block_p) CALL cp_dbcsr_reserve_block2d(matrix,row,col,block_p) - CPPostcondition(ASSOCIATED(block_p),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(block_p),cp_failure_level,routineP,failure) !ENDIF ! copy data from the received array into the matrix block start_data=recv_offset_cpu(iNode)+block_offset+1 @@ -1675,7 +1637,7 @@ SUBROUTINE construct_dbcsr_from_submatrices(matrix,submatrix,distr_pattern,& DEALLOCATE(recv_data) DEALLOCATE(recv_data2) - CALL cp_dbcsr_finalize(matrix,error=error) + CALL cp_dbcsr_finalize(matrix) CALL timestop(handle) @@ -1685,14 +1647,12 @@ END SUBROUTINE construct_dbcsr_from_submatrices !> \brief ... !> \param submatrices ... !> \param mpgroup ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE print_submatrices(submatrices,mpgroup,error) + SUBROUTINE print_submatrices(submatrices,mpgroup) TYPE(domain_submatrix_type), & DIMENSION(:), INTENT(IN) :: submatrices INTEGER, INTENT(IN) :: mpgroup - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_submatrices', & routineP = moduleN//':'//routineN @@ -1729,17 +1689,15 @@ END SUBROUTINE print_submatrices !> \param map ... !> \param row ... !> \param col ... -!> \param error ... !> \retval qblk_exists ... !> \par History !> 2013.01 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - FUNCTION qblk_exists(map,row,col,error) + FUNCTION qblk_exists(map,row,col) TYPE(domain_map_type), INTENT(IN) :: map INTEGER, INTENT(IN) :: row, col - TYPE(cp_error_type), INTENT(INOUT) :: error LOGICAL :: qblk_exists CHARACTER(len=*), PARAMETER :: routineN = 'qblk_exists', & diff --git a/src/efield_utils.F b/src/efield_utils.F index d9a1f58f78..787f203d69 100644 --- a/src/efield_utils.F +++ b/src/efield_utils.F @@ -54,15 +54,13 @@ MODULE efield_utils !> \brief computes the time dependend potential on the grid !> \param qs_env ... !> \param v_efield_rspace ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE efield_potential(qs_env,v_efield_rspace,error) + SUBROUTINE efield_potential(qs_env,v_efield_rspace) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type) :: v_efield_rspace - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'efield_potential', & routineP = moduleN//':'//routineN @@ -86,10 +84,9 @@ SUBROUTINE efield_potential(qs_env,v_efield_rspace,error) energy=energy,& rho=rho,& dft_control=dft_control,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) v_efield_rspace%pw%cr3d=0.0_dp @@ -99,7 +96,7 @@ SUBROUTINE efield_potential(qs_env,v_efield_rspace,error) dvol=v_efield_rspace%pw%pw_grid%dvol dr=v_efield_rspace%pw%pw_grid%dr - CALL make_field(dft_control,field,qs_env%sim_step,qs_env%sim_time,error) + CALL make_field(dft_control,field,qs_env%sim_step,qs_env%sim_time) DO k=bo_local(1,3),bo_local(2,3) DO j=bo_local(1,2),bo_local(2,2) @@ -128,16 +125,14 @@ END SUBROUTINE efield_potential !> \param field ... !> \param sim_step ... !> \param sim_time ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE make_field(dft_control,field,sim_step,sim_time,error) + SUBROUTINE make_field(dft_control,field,sim_step,sim_time) TYPE(dft_control_type) :: dft_control REAL(dp) :: field(3) INTEGER :: sim_step REAL(KIND=dp) :: sim_time - TYPE(cp_error_type) :: error INTEGER :: i, nfield REAL(dp) :: c, env, nu, pol(3), strength @@ -185,14 +180,12 @@ END SUBROUTINE make_field !> \brief computes the force and the energy due to a efield on the cores !> \param qs_env ... !> \param calculate_forces ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE calculate_ecore_efield(qs_env,calculate_forces,error) + SUBROUTINE calculate_ecore_efield(qs_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, OPTIONAL :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ecore_efield', & routineP = moduleN//':'//routineN @@ -217,7 +210,7 @@ SUBROUTINE calculate_ecore_efield(qs_env,calculate_forces,error) NULLIFY(dft_control) CALL timeset(routineN,handle) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) IF(dft_control%apply_efield_field)THEN failure=.FALSE. @@ -230,15 +223,14 @@ SUBROUTINE calculate_ecore_efield(qs_env,calculate_forces,error) qs_kind_set=qs_kind_set,& energy=energy,& particle_set=particle_set,& - cell=cell,& - error=error) + cell=cell) efield_ener=0.0_dp nkind = SIZE(atomic_kind_set) - CALL make_field(dft_control,field,qs_env%sim_step,qs_env%sim_time,error) + CALL make_field(dft_control,field,qs_env%sim_step,qs_env%sim_time) DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=list,natom=natom) - CALL get_qs_kind(qs_kind_set(ikind),zeff=zeff,error=error) + CALL get_qs_kind(qs_kind_set(ikind),zeff=zeff) natom = SIZE(list) DO iatom=1,natom @@ -247,7 +239,7 @@ SUBROUTINE calculate_ecore_efield(qs_env,calculate_forces,error) r(:) = pbc(particle_set(atom_a)%r(:),cell) efield_ener=efield_ener-zeff*DOT_PRODUCT(r,field) IF(my_force)THEN - CALL get_qs_env(qs_env=qs_env,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,force=force) force(ikind)%efield(:,iatom)=force(ikind)%efield(:,iatom)-field*zeff END IF END DO diff --git a/src/eip_environment.F b/src/eip_environment.F index 8a491d1328..74ba06087f 100644 --- a/src/eip_environment.F +++ b/src/eip_environment.F @@ -64,20 +64,17 @@ MODULE eip_environment !> \param para_env ... !> \param force_env_section ... !> \param subsys_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** SUBROUTINE eip_init(eip_env, root_section, para_env, force_env_section,& - subsys_section, error) + subsys_section) TYPE(eip_environment_type), POINTER :: eip_env TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_init', & routineP = moduleN//':'//routineN @@ -94,36 +91,36 @@ SUBROUTINE eip_init(eip_env, root_section, para_env, force_env_section,& failure = .FALSE. - CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP,failure) ! nullifying pointers NULLIFY(cell_section, colvar_section, eip_section, cell, cell_ref, & subsys) IF (.NOT.ASSOCIATED(subsys_section)) THEN - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") END IF - cell_section => section_vals_get_subs_vals(subsys_section,"CELL", error=error) - colvar_section => section_vals_get_subs_vals(subsys_section,"COLVAR", error=error) - eip_section => section_vals_get_subs_vals(force_env_section,"EIP", error=error) + cell_section => section_vals_get_subs_vals(subsys_section,"CELL") + colvar_section => section_vals_get_subs_vals(subsys_section,"COLVAR") + eip_section => section_vals_get_subs_vals(force_env_section,"EIP") CALL eip_env_set(eip_env=eip_env, eip_input=eip_section, & - force_env_input=force_env_section, error=error) + force_env_input=force_env_section) CALL read_cell(cell=cell, cell_ref=cell_ref, use_ref_cell=use_ref_cell,cell_section=cell_section, & - para_env=para_env, error=error) + para_env=para_env) CALL get_cell(cell=cell, abc=abc) - CALL write_cell(cell=cell, subsys_section=subsys_section,error=error) + CALL write_cell(cell=cell, subsys_section=subsys_section) - CALL cp_subsys_create(subsys, para_env, root_section, error=error) + CALL cp_subsys_create(subsys, para_env, root_section) CALL eip_init_subsys(eip_env=eip_env, subsys=subsys, cell=cell, & cell_ref=cell_ref, use_ref_cell=use_ref_cell, & - subsys_section=subsys_section,error=error) + subsys_section=subsys_section) - CALL cell_release(cell, error=error) - CALL cell_release(cell_ref, error=error) - CALL cp_subsys_release(subsys, error=error) + CALL cell_release(cell) + CALL cell_release(cell_ref) + CALL cp_subsys_release(subsys) CALL timestop(handle) @@ -137,19 +134,16 @@ END SUBROUTINE eip_init !> \param cell_ref Pointer to the reference cell, used e.g. in NPT simulations !> \param use_ref_cell Logical which indicates if cell_ref is in use !> \param subsys_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_init_subsys(eip_env, subsys, cell, cell_ref, use_ref_cell, subsys_section, error) + SUBROUTINE eip_init_subsys(eip_env, subsys, cell, cell_ref, use_ref_cell, subsys_section) TYPE(eip_environment_type), POINTER :: eip_env TYPE(cp_subsys_type), POINTER :: subsys TYPE(cell_type), POINTER :: cell, cell_ref LOGICAL, INTENT(in) :: use_ref_cell TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_init_subsys', & routineP = moduleN//':'//routineN @@ -182,18 +176,15 @@ SUBROUTINE eip_init_subsys(eip_env, subsys, cell, cell_ref, use_ref_cell, subsys molecule_set => subsys%molecules_new%els ! *** Print the molecule kind set *** - CALL write_molecule_kind_set(molecule_kind_set, subsys_section, & - error=error) + CALL write_molecule_kind_set(molecule_kind_set, subsys_section) ! *** Print the atomic coordinates CALL write_fist_particle_coordinates(particle_set,subsys_section, & - charges=Null(), error=error) + charges=Null()) CALL write_particle_distances(particle_set, cell=cell, & - subsys_section=subsys_section, & - error=error) + subsys_section=subsys_section) CALL write_structure_data(particle_set, cell=cell, & - input_section=subsys_section, & - error=error) + input_section=subsys_section) ! *** Distribute molecules and atoms using the new data structures *** CALL distribute_molecules_1d(atomic_kind_set=atomic_kind_set, & @@ -202,26 +193,25 @@ SUBROUTINE eip_init_subsys(eip_env, subsys, cell, cell_ref, use_ref_cell, subsys molecule_kind_set=molecule_kind_set, & molecule_set=molecule_set, & local_molecules=local_molecules, & - force_env_section=eip_env%force_env_input, & - error=error) + force_env_section=eip_env%force_env_input) natom = SIZE(particle_set) ALLOCATE(eip_env%eip_forces(3,natom), stat=stat) - CPPostcondition(stat == 0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat == 0, cp_failure_level, routineP,failure) eip_env%eip_forces(:,:) = 0.0_dp - CALL cp_subsys_set(subsys, cell=cell, error=error) + CALL cp_subsys_set(subsys, cell=cell) CALL eip_env_set(eip_env=eip_env, subsys=subsys, & cell_ref=cell_ref, use_ref_cell=use_ref_cell, & local_molecules=local_molecules, & - local_particles=local_particles, error=error) + local_particles=local_particles) - CALL distribution_1d_release(local_particles, error=error) - CALL distribution_1d_release(local_molecules, error=error) + CALL distribution_1d_release(local_particles) + CALL distribution_1d_release(local_molecules) - CALL eip_init_model(eip_env=eip_env, error=error) + CALL eip_init_model(eip_env=eip_env) CALL timestop(handle) @@ -230,15 +220,12 @@ END SUBROUTINE eip_init_subsys ! ***************************************************************************** !> \brief Initialize the empirical interatomic potnetial (force field) model !> \param eip_env The eip environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_init_model(eip_env, error) + SUBROUTINE eip_init_model(eip_env) TYPE(eip_environment_type), POINTER :: eip_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_init_model', & routineP = moduleN//':'//routineN @@ -257,7 +244,7 @@ SUBROUTINE eip_init_model(eip_env, error) NULLIFY(atomic_kind_set, atomic_kind_ptr, eip_section) eip_section => section_vals_get_subs_vals(eip_env%force_env_input, & - "EIP", error=error) + "EIP") atomic_kind_set => eip_env%subsys%atomic_kinds%els @@ -270,13 +257,12 @@ SUBROUTINE eip_init_model(eip_env, error) CASE("SI", "Si") CALL section_vals_val_get(section_vals=eip_section, & keyword_name="EIP-Model", & - i_val=eip_env%eip_model, & - error=error) + i_val=eip_env%eip_model) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="EIP models for other elements" //& "than Si isn't implemented yet.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END DO diff --git a/src/eip_environment_types.F b/src/eip_environment_types.F index b3f4aa1980..e8c0675301 100644 --- a/src/eip_environment_types.F +++ b/src/eip_environment_types.F @@ -118,16 +118,13 @@ MODULE eip_environment_types ! ***************************************************************************** !> \brief Retains a eip environment (see doc/ReferenceCounting.html) !> \param eip_env The eip environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_env_retain(eip_env, error) + SUBROUTINE eip_env_retain(eip_env) TYPE(eip_environment_type), POINTER :: eip_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_env_retain', & routineP = moduleN//':'//routineN @@ -138,24 +135,21 @@ SUBROUTINE eip_env_retain(eip_env, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP, error, failure) - CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP,failure) + CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP,failure) eip_env%ref_count = eip_env%ref_count+1 END SUBROUTINE eip_env_retain ! ***************************************************************************** !> \brief Releases the given eip environment (see doc/ReferenceCounting.html) !> \param eip_env The eip environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_env_release(eip_env, error) + SUBROUTINE eip_env_release(eip_env) TYPE(eip_environment_type), POINTER :: eip_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_env_release', & routineP = moduleN//':'//routineN @@ -168,30 +162,30 @@ SUBROUTINE eip_env_release(eip_env, error) failure = .FALSE. IF (ASSOCIATED(eip_env)) THEN - CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP, error, failure) + CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP,failure) eip_env%ref_count = eip_env%ref_count-1 IF (eip_env%ref_count<1) THEN IF (ASSOCIATED(eip_env%eip_forces)) THEN DEALLOCATE(eip_env%eip_forces, stat=stat) - CPPostconditionNoFail(stat==0, cp_warning_level, routineP, error) + CPPostconditionNoFail(stat==0, cp_warning_level, routineP) END IF IF (ASSOCIATED(eip_env%subsys)) THEN - CALL cp_subsys_release(eip_env%subsys, error=error) + CALL cp_subsys_release(eip_env%subsys) END IF IF (ASSOCIATED(eip_env%subsys)) THEN - CALL cp_subsys_release(eip_env%subsys, error=error) + CALL cp_subsys_release(eip_env%subsys) END IF !IF (ASSOCIATED(eip_env%eip_input)) THEN - ! CALL section_vals_release(eip_env%eip_input, error=error) + ! CALL section_vals_release(eip_env%eip_input) !END IF !IF (ASSOCIATED(eip_env%force_env_input)) THEN - ! CALL section_vals_release(eip_env%force_env_input, error=error) + ! CALL section_vals_release(eip_env%force_env_input) !END IF IF (ASSOCIATED(eip_env%cell_ref)) THEN - CALL cell_release(eip_env%cell_ref, error=error) + CALL cell_release(eip_env%cell_ref) END IF DEALLOCATE(eip_env, stat=stat) - CPPostconditionNoFail(stat==0, cp_warning_level, routineP, error) + CPPostconditionNoFail(stat==0, cp_warning_level, routineP) END IF END IF NULLIFY(eip_env) @@ -228,8 +222,6 @@ END SUBROUTINE eip_env_release !> !> For possible missing arguments see the attributes of !> eip_environment_type -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) @@ -240,7 +232,7 @@ SUBROUTINE eip_env_get(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & molecule_kind_set, molecule_set, local_molecules, & eip_input, force_env_input, cell, cell_ref, & use_ref_cell, eip_kinetic_energy, eip_potential_energy, & - virial, error) + virial) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(OUT), OPTIONAL :: id_nr, eip_model @@ -268,7 +260,6 @@ SUBROUTINE eip_env_get(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & REAL(KIND=dp), INTENT(OUT), OPTIONAL :: eip_kinetic_energy, & eip_potential_energy TYPE(virial_type), OPTIONAL, POINTER :: virial - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_env_get', & routineP = moduleN//':'//routineN @@ -285,8 +276,8 @@ SUBROUTINE eip_env_get(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & NULLIFY(atomic_kinds, particles, molecules_new, molecule_kinds_new) - CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP, error, failure) - CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP,failure) + CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP,failure) IF (PRESENT(id_nr)) id_nr = eip_env%id_nr IF (PRESENT(eip_model)) eip_model = eip_env%eip_model @@ -311,8 +302,7 @@ SUBROUTINE eip_env_get(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & local_molecules_new=local_molecules, & local_particles=local_particles, & virial=virial, & - cell=cell, & - error=error) + cell=cell) IF (PRESENT(atomic_kind_set)) atomic_kind_set => atomic_kinds%els IF (PRESENT(particle_set)) particle_set => particles%els IF (PRESENT(molecule_kind_set)) molecule_kind_set => molecule_kinds_new%els @@ -351,8 +341,6 @@ END SUBROUTINE eip_env_get !> simulation cell is used !> \param eip_kinetic_energy The EIP kinetic energy !> \param eip_potential_energy The EIP potential energy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) @@ -364,8 +352,7 @@ SUBROUTINE eip_env_set(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & atomic_kind_set, particle_set , local_particles, & molecule_kind_set, molecule_set, local_molecules, & eip_input, force_env_input, cell_ref, & - use_ref_cell, eip_kinetic_energy, eip_potential_energy, & - error) + use_ref_cell, eip_kinetic_energy, eip_potential_energy) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(IN), OPTIONAL :: id_nr, eip_model @@ -392,7 +379,6 @@ SUBROUTINE eip_env_set(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & LOGICAL, INTENT(IN), OPTIONAL :: use_ref_cell REAL(KIND=dp), INTENT(IN), OPTIONAL :: eip_kinetic_energy, & eip_potential_energy - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_env_set', & routineP = moduleN//':'//routineN @@ -407,8 +393,8 @@ SUBROUTINE eip_env_set(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & failure = .FALSE. - CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP, error, failure) - CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP,failure) + CPPrecondition(eip_env%ref_count>0, cp_failure_level, routineP,failure) IF (PRESENT(id_nr)) eip_env%id_nr = id_nr IF (PRESENT(eip_model)) eip_env%eip_model = eip_model @@ -425,55 +411,45 @@ SUBROUTINE eip_env_set(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & IF (PRESENT(coord_var)) eip_env%coord_var = coord_var IF (PRESENT(count)) eip_env%count = count IF (PRESENT(subsys)) THEN - CALL cp_subsys_retain(subsys, error=error) - CALL cp_subsys_release(eip_env%subsys, error=error) + CALL cp_subsys_retain(subsys) + CALL cp_subsys_release(eip_env%subsys) eip_env%subsys => subsys END IF IF (PRESENT(atomic_kind_set)) THEN CALL atomic_kind_list_create(atomic_kinds, & - els_ptr=atomic_kind_set, & - error=error) + els_ptr=atomic_kind_set) CALL cp_subsys_set(eip_env%subsys, & - atomic_kinds=atomic_kinds, & - error=error) - CALL atomic_kind_list_release(atomic_kinds, error=error) + atomic_kinds=atomic_kinds) + CALL atomic_kind_list_release(atomic_kinds) END IF IF (PRESENT(particle_set)) THEN CALL particle_list_create(particles, & - els_ptr=particle_set, & - error=error) + els_ptr=particle_set) CALL cp_subsys_set(eip_env%subsys, & - particles=particles, & - error=error) - CALL particle_list_release(particles, error=error) + particles=particles) + CALL particle_list_release(particles) END IF IF (PRESENT(molecule_kind_set)) THEN CALL mol_kind_new_list_create(molecule_kinds_new, & - els_ptr=molecule_kind_set, & - error=error) + els_ptr=molecule_kind_set) CALL cp_subsys_set(eip_env%subsys, & - molecule_kinds_new=molecule_kinds_new, & - error=error) - CALL mol_kind_new_list_release(molecule_kinds_new, error=error) + molecule_kinds_new=molecule_kinds_new) + CALL mol_kind_new_list_release(molecule_kinds_new) END IF IF (PRESENT(molecule_set)) THEN CALL mol_new_list_create(molecules_new, & - els_ptr=molecule_set, & - error=error) + els_ptr=molecule_set) CALL cp_subsys_set(eip_env%subsys, & - molecules_new=molecules_new, & - error=error) - CALL mol_new_list_release(molecules_new,error=error) + molecules_new=molecules_new) + CALL mol_new_list_release(molecules_new) END IF IF (PRESENT(local_particles)) THEN CALL cp_subsys_set(eip_env%subsys, & - local_particles=local_particles, & - error=error) + local_particles=local_particles) END IF IF (PRESENT(local_molecules)) THEN CALL cp_subsys_set(eip_env%subsys, & - local_molecules_new=local_molecules, & - error=error) + local_molecules_new=local_molecules) END IF IF (PRESENT(eip_input)) eip_env%eip_input => eip_input @@ -481,8 +457,8 @@ SUBROUTINE eip_env_set(eip_env, id_nr, eip_model, eip_energy, eip_energy_var, & eip_env%force_env_input => force_env_input END IF IF (PRESENT(cell_ref)) THEN - CALL cell_retain(cell_ref, error=error) - CALL cell_release(eip_env%cell_ref,error=error) + CALL cell_retain(cell_ref) + CALL cell_release(eip_env%cell_ref) eip_env%cell_ref => cell_ref END IF IF (PRESENT(use_ref_cell)) eip_env%use_ref_cell = use_ref_cell @@ -491,19 +467,13 @@ END SUBROUTINE eip_env_set ! ***************************************************************************** !> \brief Reinitializes the eip environment !> \param eip_env The eip environment to be reinitialized -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> -!> For possible missing arguments see the attributes of -!> eip_environment_type !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_env_clear(eip_env, error) + SUBROUTINE eip_env_clear(eip_env) TYPE(eip_environment_type), POINTER :: eip_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_env_clear', & routineP = moduleN//':'//routineN @@ -514,7 +484,7 @@ SUBROUTINE eip_env_clear(eip_env, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP,failure) eip_env%eip_model = 0 eip_env%eip_kinetic_energy = 0.0_dp @@ -528,35 +498,29 @@ SUBROUTINE eip_env_clear(eip_env, error) eip_env%eip_forces(:,:) = 0.0_dp END IF IF (ASSOCIATED(eip_env%subsys)) THEN - CALL cp_subsys_release(eip_env%subsys, error=error) + CALL cp_subsys_release(eip_env%subsys) END IF IF (ASSOCIATED(eip_env%eip_input)) THEN - CALL section_vals_release(eip_env%eip_input, error=error) + CALL section_vals_release(eip_env%eip_input) END IF IF (ASSOCIATED(eip_env%force_env_input)) THEN - CALL section_vals_release(eip_env%force_env_input, error=error) + CALL section_vals_release(eip_env%force_env_input) END IF IF (ASSOCIATED(eip_env%cell_ref)) THEN - CALL cell_release(eip_env%cell_ref, error=error) + CALL cell_release(eip_env%cell_ref) END IF END SUBROUTINE eip_env_clear ! ***************************************************************************** !> \brief Creates the eip environment !> \param eip_env The eip environment to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> -!> For possible missing arguments see the attributes of -!> eip_environment_type !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_env_create(eip_env, error) + SUBROUTINE eip_env_create(eip_env) TYPE(eip_environment_type), POINTER :: eip_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_env_create', & routineP = moduleN//':'//routineN @@ -567,7 +531,7 @@ SUBROUTINE eip_env_create(eip_env, error) failure = .FALSE. ALLOCATE(eip_env, stat=stat) - CPPostcondition(stat == 0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat == 0, cp_failure_level, routineP,failure) NULLIFY(eip_env%eip_forces) NULLIFY(eip_env%subsys) @@ -579,7 +543,7 @@ SUBROUTINE eip_env_create(eip_env, error) last_eip_id=last_eip_id+1 eip_env%id_nr = last_eip_id eip_env%use_ref_cell = .FALSE. - CALL eip_env_clear(eip_env, error=error) + CALL eip_env_clear(eip_env) END SUBROUTINE eip_env_create END MODULE eip_environment_types diff --git a/src/eip_silicon.F b/src/eip_silicon.F index 1dc52d5f2c..1ecc0a51d3 100644 --- a/src/eip_silicon.F +++ b/src/eip_silicon.F @@ -56,8 +56,6 @@ MODULE eip_silicon ! ***************************************************************************** !> \brief Interface routine of Goedecker's Bazant EDIP to CP2K !> \param eip_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par Literature !> http://www-math.mit.edu/~bazant/EDIP !> M.Z. Bazant & E. Kaxiras: Modeling of Covalent Bonding in Solids by @@ -72,9 +70,8 @@ MODULE eip_silicon !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_bazant(eip_env, error) + SUBROUTINE eip_bazant(eip_env) TYPE(eip_environment_type), POINTER :: eip_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_bazant', & routineP = moduleN//':'//routineN @@ -109,23 +106,22 @@ SUBROUTINE eip_bazant(eip_env, error) ekin = 0.0_dp failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP,failure) CALL eip_env_get(eip_env=eip_env, cell=cell, particle_set=particle_set, & subsys=subsys, local_particles=local_particles, & - atomic_kind_set=atomic_kind_set, error=error) + atomic_kind_set=atomic_kind_set) CALL get_cell(cell=cell, abc=abc) - eip_section => section_vals_get_subs_vals(eip_env%force_env_input, "EIP", & - error=error) + eip_section => section_vals_get_subs_vals(eip_env%force_env_input, "EIP") natom = SIZE(particle_set) !natom = local_particles%n_el(1) ALLOCATE(rxyz(3,natom), stat=stat) - CPPostcondition(stat == 0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat == 0, cp_failure_level, routineP,failure) DO i = 1,natom !iparticle = local_particles%list(1)%array(i) @@ -138,7 +134,7 @@ SUBROUTINE eip_bazant(eip_env, error) coord_var=eip_env%coord_var, count=eip_env%count) !CALL get_part_ke(md_env, tbmd_energy%E_kinetic, int_grp=globalenv%para_env%group) - CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds,error=error) + CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds) nparticle_kind = atomic_kinds%n_els @@ -156,7 +152,7 @@ SUBROUTINE eip_bazant(eip_env, error) END DO ! sum all contributions to energy over calculated parts on all processors - CALL cp_subsys_get(subsys=subsys, para_env=para_env, error=error) + CALL cp_subsys_get(subsys=subsys, para_env=para_env) CALL mp_sum(ekin, para_env%group) eip_env%eip_kinetic_energy = ekin @@ -169,67 +165,67 @@ SUBROUTINE eip_bazant(eip_env, error) END DO DEALLOCATE(rxyz, stat=stat) - CPPostconditionNoFail(stat==0, cp_warning_level, routineP, error) + CPPostconditionNoFail(stat==0, cp_warning_level, routineP) ! Print IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%ENERGIES", error=error), cp_p_file)) THEN + eip_section, "PRINT%ENERGIES"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%ENERGIES", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_energies(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_energies(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%ENERGIES", error=error) + "PRINT%ENERGIES") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%ENERGIES_VAR", error=error), cp_p_file)) THEN + eip_section, "PRINT%ENERGIES_VAR"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%ENERGIES_VAR", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_energy_var(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_energy_var(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%ENERGIES_VAR", error=error) + "PRINT%ENERGIES_VAR") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%FORCES", error=error), cp_p_file)) THEN + eip_section, "PRINT%FORCES"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%FORCES", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_forces(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_forces(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%FORCES", error=error) + "PRINT%FORCES") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%COORD_AVG", error=error), cp_p_file)) THEN + eip_section, "PRINT%COORD_AVG"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%COORD_AVG", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_coord_avg(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_coord_avg(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%COORD_AVG", error=error) + "PRINT%COORD_AVG") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%COORD_VAR", error=error), cp_p_file)) THEN + eip_section, "PRINT%COORD_VAR"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%COORD_VAR", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_coord_var(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_coord_var(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%COORD_VAR", error=error) + "PRINT%COORD_VAR") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%COUNT", error=error), cp_p_file)) THEN + eip_section, "PRINT%COUNT"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%COUNT", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_count(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_count(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%COUNT", error=error) + "PRINT%COUNT") END IF @@ -240,8 +236,6 @@ END SUBROUTINE eip_bazant ! ***************************************************************************** !> \brief Interface routine of Goedecker's Lenosky force field to CP2K !> \param eip_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par Literature !> T. Lenosky, et. al.: Highly optimized empirical potential model of silicon; !> Modelling Simul. Sci. Eng., 8 (2000) @@ -251,9 +245,8 @@ END SUBROUTINE eip_bazant !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_lenosky(eip_env, error) + SUBROUTINE eip_lenosky(eip_env) TYPE(eip_environment_type), POINTER :: eip_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_lenosky', & routineP = moduleN//':'//routineN @@ -288,23 +281,22 @@ SUBROUTINE eip_lenosky(eip_env, error) ekin = 0.0_dp failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env), cp_failure_level, routineP,failure) CALL eip_env_get(eip_env=eip_env, cell=cell, particle_set=particle_set, & subsys=subsys, local_particles=local_particles, & - atomic_kind_set=atomic_kind_set, error=error) + atomic_kind_set=atomic_kind_set) CALL get_cell(cell=cell, abc=abc) - eip_section => section_vals_get_subs_vals(eip_env%force_env_input, "EIP", & - error=error) + eip_section => section_vals_get_subs_vals(eip_env%force_env_input, "EIP") natom = SIZE(particle_set) !natom = local_particles%n_el(1) ALLOCATE(rxyz(3,natom), stat=stat) - CPPostcondition(stat == 0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat == 0, cp_failure_level, routineP,failure) DO i = 1,natom !iparticle = local_particles%list(1)%array(i) @@ -317,7 +309,7 @@ SUBROUTINE eip_lenosky(eip_env, error) coord_var=eip_env%coord_var, count=eip_env%count) !CALL get_part_ke(md_env, tbmd_energy%E_kinetic, int_grp=globalenv%para_env%group) - CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds,error=error) + CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds) nparticle_kind = atomic_kinds%n_els @@ -335,7 +327,7 @@ SUBROUTINE eip_lenosky(eip_env, error) END DO ! sum all contributions to energy over calculated parts on all processors - CALL cp_subsys_get(subsys=subsys, para_env=para_env, error=error) + CALL cp_subsys_get(subsys=subsys, para_env=para_env) CALL mp_sum(ekin, para_env%group) eip_env%eip_kinetic_energy = ekin @@ -348,67 +340,67 @@ SUBROUTINE eip_lenosky(eip_env, error) END DO DEALLOCATE(rxyz, stat=stat) - CPPostconditionNoFail(stat==0, cp_warning_level, routineP, error) + CPPostconditionNoFail(stat==0, cp_warning_level, routineP) ! Print IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%ENERGIES", error=error), cp_p_file)) THEN + eip_section, "PRINT%ENERGIES"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%ENERGIES", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_energies(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_energies(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%ENERGIES", error=error) + "PRINT%ENERGIES") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%ENERGIES_VAR", error=error), cp_p_file)) THEN + eip_section, "PRINT%ENERGIES_VAR"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%ENERGIES_VAR", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_energy_var(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_energy_var(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%ENERGIES_VAR", error=error) + "PRINT%ENERGIES_VAR") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%FORCES", error=error), cp_p_file)) THEN + eip_section, "PRINT%FORCES"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%FORCES", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_forces(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_forces(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%FORCES", error=error) + "PRINT%FORCES") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%COORD_AVG", error=error), cp_p_file)) THEN + eip_section, "PRINT%COORD_AVG"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%COORD_AVG", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_coord_avg(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_coord_avg(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%COORD_AVG", error=error) + "PRINT%COORD_AVG") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%COORD_VAR", error=error), cp_p_file)) THEN + eip_section, "PRINT%COORD_VAR"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%COORD_VAR", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_coord_var(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_coord_var(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%COORD_VAR", error=error) + "PRINT%COORD_VAR") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info, & - eip_section, "PRINT%COUNT", error=error), cp_p_file)) THEN + eip_section, "PRINT%COUNT"), cp_p_file)) THEN iw = cp_print_key_unit_nr(logger, eip_section, "PRINT%COUNT", & - extension=".mmLog", error=error) + extension=".mmLog") - CALL eip_print_count(eip_env=eip_env, output_unit=iw, error=error) + CALL eip_print_count(eip_env=eip_env, output_unit=iw) CALL cp_print_key_finished_output(iw, logger, eip_section, & - "PRINT%COUNT", error=error) + "PRINT%COUNT") END IF @@ -420,8 +412,6 @@ END SUBROUTINE eip_lenosky !> \brief Print routine for the EIP energies !> \param eip_env The eip environment of matter !> \param output_unit The output unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) @@ -429,10 +419,9 @@ END SUBROUTINE eip_lenosky !> As usual the EIP energies differ from the DFT energies! !> Only the relative energy differneces are correctly reproduced. ! ***************************************************************************** - SUBROUTINE eip_print_energies(eip_env, output_unit, error) + SUBROUTINE eip_print_energies(eip_env, output_unit) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_print_energies', & routineP = moduleN//':'//routineN @@ -452,16 +441,13 @@ END SUBROUTINE eip_print_energies !> \brief Print routine for the variance of the energy/atom !> \param eip_env The eip environment of matter !> \param output_unit The output unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_print_energy_var(eip_env, output_unit, error) + SUBROUTINE eip_print_energy_var(eip_env, output_unit) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_print_energy_var', & routineP = moduleN//':'//routineN @@ -487,16 +473,13 @@ END SUBROUTINE eip_print_energy_var !> \brief Print routine for the forces !> \param eip_env The eip environment of matter !> \param output_unit The output unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_print_forces(eip_env, output_unit, error) + SUBROUTINE eip_print_forces(eip_env, output_unit) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_print_forces', & routineP = moduleN//':'//routineN @@ -513,7 +496,7 @@ SUBROUTINE eip_print_forces(eip_env, output_unit, error) IF (unit_nr > 0) THEN - CALL eip_env_get(eip_env=eip_env, particle_set=particle_set, error=error) + CALL eip_env_get(eip_env=eip_env, particle_set=particle_set) natom = SIZE(particle_set) @@ -533,16 +516,13 @@ END SUBROUTINE eip_print_forces !> \brief Print routine for the average coordination number !> \param eip_env The eip environment of matter !> \param output_unit The output unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_print_coord_avg(eip_env, output_unit, error) + SUBROUTINE eip_print_coord_avg(eip_env, output_unit) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_print_coord_avg', & routineP = moduleN//':'//routineN @@ -568,16 +548,13 @@ END SUBROUTINE eip_print_coord_avg !> \brief Print routine for the variance of the coordination number !> \param eip_env The eip environment of matter !> \param output_unit The output unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_print_coord_var(eip_env, output_unit, error) + SUBROUTINE eip_print_coord_var(eip_env, output_unit) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_print_coord_var', & routineP = moduleN//':'//routineN @@ -603,16 +580,13 @@ END SUBROUTINE eip_print_coord_var !> \brief Print routine for the function call counter !> \param eip_env The eip environment of matter !> \param output_unit The output unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE eip_print_count(eip_env, output_unit, error) + SUBROUTINE eip_print_count(eip_env, output_unit) TYPE(eip_environment_type), POINTER :: eip_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eip_print_count', & routineP = moduleN//':'//routineN diff --git a/src/emd/rt_delta_pulse.F b/src/emd/rt_delta_pulse.F index 604c8b157d..d56b9125fd 100644 --- a/src/emd/rt_delta_pulse.F +++ b/src/emd/rt_delta_pulse.F @@ -74,15 +74,13 @@ MODULE rt_delta_pulse !> \param qs_env ... !> \param mos_old ... !> \param mos_new ... -!> \param error ... !> \author Joost & Martin (2011) ! ***************************************************************************** - SUBROUTINE apply_delta_pulse_periodic(qs_env,mos_old,mos_new,error) + SUBROUTINE apply_delta_pulse_periodic(qs_env,mos_old,mos_new) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mos_old, mos_new - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_delta_pulse_periodic', & routineP = moduleN//':'//routineN @@ -121,49 +119,48 @@ SUBROUTINE apply_delta_pulse_periodic(qs_env,mos_old,mos_new,error) rtp=rtp,& matrix_s=matrix_s,& matrix_ks=matrix_ks,& - dft_control=dft_control,& - error=error) - CALL get_rtp(rtp=rtp,S_inv=S_inv,error=error) - CALL cp_fm_create(S_chol, matrix_struct=rtp%ao_ao_fmstruct, name="S_chol", error=error) - CALL cp_fm_create(S_inv_fm, matrix_struct=rtp%ao_ao_fmstruct, name="S_inv_fm", error=error) - CALL cp_fm_create(tmpS, matrix_struct=rtp%ao_ao_fmstruct,error=error) - CALL copy_dbcsr_to_fm(S_inv,S_inv_fm,error=error) - CALL cp_fm_upper_to_full(S_inv_fm,tmpS,error=error) - CALL cp_fm_get_info(S_inv_fm,nrow_global=nrow_global,error=error) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,S_chol,error=error) - CALL cp_fm_cholesky_decompose(S_chol,error=error) + dft_control=dft_control) + CALL get_rtp(rtp=rtp,S_inv=S_inv) + CALL cp_fm_create(S_chol, matrix_struct=rtp%ao_ao_fmstruct, name="S_chol") + CALL cp_fm_create(S_inv_fm, matrix_struct=rtp%ao_ao_fmstruct, name="S_inv_fm") + CALL cp_fm_create(tmpS, matrix_struct=rtp%ao_ao_fmstruct) + CALL copy_dbcsr_to_fm(S_inv,S_inv_fm) + CALL cp_fm_upper_to_full(S_inv_fm,tmpS) + CALL cp_fm_get_info(S_inv_fm,nrow_global=nrow_global) + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,S_chol) + CALL cp_fm_cholesky_decompose(S_chol) NULLIFY(mat_ks,eigenvectors,mat_tmp) - CALL cp_fm_create(mat_ks, matrix_struct=S_inv_fm%matrix_struct, name="mat_ks", error=error) - CALL cp_fm_create(eigenvectors, matrix_struct=S_inv_fm%matrix_struct, name="eigenvectors", error=error) + CALL cp_fm_create(mat_ks, matrix_struct=S_inv_fm%matrix_struct, name="mat_ks") + CALL cp_fm_create(eigenvectors, matrix_struct=S_inv_fm%matrix_struct, name="eigenvectors") DO ispin=1,SIZE(matrix_ks) ALLOCATE(eigenvalues(nrow_global)) - CALL cp_fm_create(mat_tmp, matrix_struct=S_inv_fm%matrix_struct, name="mat_tmp", error=error) + CALL cp_fm_create(mat_tmp, matrix_struct=S_inv_fm%matrix_struct, name="mat_tmp") - CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,mat_ks,error=error) - CALL cp_fm_cholesky_reduce(mat_ks,S_chol,error=error) - CALL cp_fm_syevd(mat_ks,mat_tmp,eigenvalues,error=error) - CALL cp_fm_cholesky_restore(mat_tmp,nrow_global,S_chol,eigenvectors,"SOLVE",error=error) + CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,mat_ks) + CALL cp_fm_cholesky_reduce(mat_ks,S_chol) + CALL cp_fm_syevd(mat_ks,mat_tmp,eigenvalues) + CALL cp_fm_cholesky_restore(mat_tmp,nrow_global,S_chol,eigenvectors,"SOLVE") ! virtuals CALL get_mo_set(mo_set=mos(ispin)%mo_set, nao=nao, nmo=nmo) nvirt=nao-nmo CALL cp_fm_struct_create(fm_struct_tmp, para_env=S_inv_fm%matrix_struct%para_env, context=S_inv_fm%matrix_struct%context,& - nrow_global=nrow_global, ncol_global=nvirt, error=error) - CALL cp_fm_create(virtuals, matrix_struct=fm_struct_tmp, name="virtuals", error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + nrow_global=nrow_global, ncol_global=nvirt) + CALL cp_fm_create(virtuals, matrix_struct=fm_struct_tmp, name="virtuals") + CALL cp_fm_struct_release(fm_struct_tmp) CALL cp_fm_to_fm(eigenvectors,virtuals,nvirt,nmo+1,1) ! occupied CALL cp_fm_to_fm(eigenvectors,mos_old(2*ispin-1)%matrix,nmo,1,1) CALL cp_fm_struct_create(fm_struct_tmp, para_env=S_inv_fm%matrix_struct%para_env, context=S_inv_fm%matrix_struct%context,& - nrow_global=nvirt, ncol_global=nmo, error=error) - CALL cp_fm_create(momentum, matrix_struct=fm_struct_tmp, name="momentum", error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + nrow_global=nvirt, ncol_global=nmo) + CALL cp_fm_create(momentum, matrix_struct=fm_struct_tmp, name="momentum") + CALL cp_fm_struct_release(fm_struct_tmp) ! the momentum operator (in a given direction) - CALL cp_fm_set_all( mos_new(2*ispin-1)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all( mos_new(2*ispin-1)%matrix,0.0_dp) ! the prefactor (strength of the electric field) kvec(:) = cell%h_inv(1,:)*dft_control%rtp_control%delta_pulse_direction(1)+& @@ -175,100 +172,100 @@ SUBROUTINE apply_delta_pulse_periodic(qs_env,mos_old,mos_new,error) factor= kvec(idir) IF (factor.NE.0.0_dp) THEN CALL cp_dbcsr_sm_fm_multiply(matrix_s(idir+1)%matrix,mos_old(2*ispin-1)%matrix,& - mos_old(2*ispin)%matrix,ncol=nmo,error=error) - CALL cp_fm_scale_and_add(1.0_dp, mos_new(2*ispin-1)%matrix,factor,mos_old(2*ispin)%matrix,error) + mos_old(2*ispin)%matrix,ncol=nmo) + CALL cp_fm_scale_and_add(1.0_dp, mos_new(2*ispin-1)%matrix,factor,mos_old(2*ispin)%matrix) ENDIF ENDDO - CALL cp_gemm('T','N',nvirt,nmo,nao,1.0_dp, virtuals, mos_new(2*ispin-1)%matrix,0.0_dp,momentum,error=error) + CALL cp_gemm('T','N',nvirt,nmo,nao,1.0_dp, virtuals, mos_new(2*ispin-1)%matrix,0.0_dp,momentum) ! the tricky bit ... rescale by the eigenvalue difference CALL cp_fm_get_info(momentum, nrow_local=nrow_local, ncol_local=ncol_local,& - row_indices=row_indices,col_indices=col_indices,local_data=local_data,error=error) + row_indices=row_indices,col_indices=col_indices,local_data=local_data) DO icol=1,ncol_local DO irow=1,nrow_local factor= 1 / (eigenvalues(col_indices(icol))-eigenvalues(nmo+row_indices(irow))) local_data(irow,icol)=factor*local_data(irow,icol) ENDDO ENDDO - CALL cp_fm_release(mat_tmp,error=error) + CALL cp_fm_release(mat_tmp) DEALLOCATE(eigenvalues) ! now obtain the initial condition in mos_old CALL cp_fm_to_fm(eigenvectors,mos_old(2*ispin-1)%matrix,nmo,1,1) - CALL cp_gemm("N","N",nao,nmo,nvirt,1.0_dp,virtuals,momentum,0.0_dp,mos_old(2*ispin)%matrix,error=error) + CALL cp_gemm("N","N",nao,nmo,nvirt,1.0_dp,virtuals,momentum,0.0_dp,mos_old(2*ispin)%matrix) - CALL cp_fm_release(virtuals, error=error) - CALL cp_fm_release(momentum, error=error) + CALL cp_fm_release(virtuals) + CALL cp_fm_release(momentum) ! orthonormalize afterwards CALL cp_fm_struct_create(fm_struct_tmp, para_env=S_inv_fm%matrix_struct%para_env, context=S_inv_fm%matrix_struct%context,& - nrow_global=nmo, ncol_global=nmo, error=error) - CALL cp_fm_create(oo_1, matrix_struct=fm_struct_tmp, name="oo_1", error=error) - CALL cp_fm_create(oo_2, matrix_struct=fm_struct_tmp, name="oo_2", error=error) - CALL cp_fm_struct_release(fm_struct_tmp, error=error) + nrow_global=nmo, ncol_global=nmo) + CALL cp_fm_create(oo_1, matrix_struct=fm_struct_tmp, name="oo_1") + CALL cp_fm_create(oo_2, matrix_struct=fm_struct_tmp, name="oo_2") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL cp_fm_create(mat_tmp, matrix_struct=mos_old(2*ispin-1)%matrix%matrix_struct, name="tmp_mat", error=error) + CALL cp_fm_create(mat_tmp, matrix_struct=mos_old(2*ispin-1)%matrix%matrix_struct, name="tmp_mat") ! get the complex overlap matrix ! x^T S x + y^T S y + i (-y^TS x+x^T S y) CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,mos_old(2*ispin-1)%matrix,& - mat_tmp,ncol=nmo,error=error) + mat_tmp,ncol=nmo) - CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*ispin-1)%matrix,mat_tmp,0.0_dp,oo_1,error=error) - CALL cp_gemm("T","N",nmo,nmo,nao,-1.0_dp,mos_old(2*ispin)%matrix,mat_tmp,0.0_dp,oo_2,error=error) + CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*ispin-1)%matrix,mat_tmp,0.0_dp,oo_1) + CALL cp_gemm("T","N",nmo,nmo,nao,-1.0_dp,mos_old(2*ispin)%matrix,mat_tmp,0.0_dp,oo_2) CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,mos_old(2*ispin)%matrix,& - mat_tmp,ncol=nmo,error=error) - CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*ispin)%matrix,mat_tmp,1.0_dp,oo_1,error=error) - CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*ispin-1)%matrix,mat_tmp,1.0_dp,oo_2,error=error) - CALL cp_fm_release(mat_tmp, error=error) - - CALL cp_cfm_create ( oo_c, oo_1 % matrix_struct,error=error) - CALL cp_cfm_create ( oo_v, oo_1 % matrix_struct,error=error) - CALL cp_cfm_create ( oo_vt, oo_1 % matrix_struct,error=error) + mat_tmp,ncol=nmo) + CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*ispin)%matrix,mat_tmp,1.0_dp,oo_1) + CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*ispin-1)%matrix,mat_tmp,1.0_dp,oo_2) + CALL cp_fm_release(mat_tmp) + + CALL cp_cfm_create ( oo_c, oo_1 % matrix_struct) + CALL cp_cfm_create ( oo_v, oo_1 % matrix_struct) + CALL cp_cfm_create ( oo_vt, oo_1 % matrix_struct) oo_c % local_data = CMPLX(oo_1%local_data,oo_2%local_data,KIND=dp) ! compute inv(sqrt(overlap)) ALLOCATE(eigenvalues(nmo)) ALLOCATE(eigenvalues_sqrt(nmo)) - CALL cp_cfm_heevd(oo_c,oo_v,eigenvalues,error) + CALL cp_cfm_heevd(oo_c,oo_v,eigenvalues) eigenvalues_sqrt=CMPLX(1.0_dp/SQRT(eigenvalues),0.0_dp,dp) - CALL cp_cfm_to_cfm(oo_v,oo_vt,error=error) + CALL cp_cfm_to_cfm(oo_v,oo_vt) CALL cp_cfm_column_scale(oo_v,eigenvalues_sqrt) DEALLOCATE(eigenvalues) DEALLOCATE(eigenvalues_sqrt) CALL cp_cfm_gemm('N','C',nmo,nmo,nmo,(1.0_dp,0.0_dp),& - oo_v,oo_vt,(0.0_dp,0.0_dp),oo_c,error=error) + oo_v,oo_vt,(0.0_dp,0.0_dp),oo_c) oo_1%local_data=REAL(oo_c%local_data,KIND=dp) oo_2%local_data=AIMAG(oo_c%local_data) - CALL cp_cfm_release(oo_c,error=error) - CALL cp_cfm_release(oo_v,error=error) - CALL cp_cfm_release(oo_vt,error=error) + CALL cp_cfm_release(oo_c) + CALL cp_cfm_release(oo_v) + CALL cp_cfm_release(oo_vt) ! use this to compute the orthonormal vectors - CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*ispin-1)%matrix,oo_1,0.0_dp,mos_new(2*ispin-1)%matrix,error=error) - CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*ispin-1)%matrix,oo_2,0.0_dp,mos_new(2*ispin)%matrix,error=error) + CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*ispin-1)%matrix,oo_1,0.0_dp,mos_new(2*ispin-1)%matrix) + CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*ispin-1)%matrix,oo_2,0.0_dp,mos_new(2*ispin)%matrix) - CALL cp_gemm("N","N",nao,nmo,nmo,-1.0_dp,mos_old(2*ispin)%matrix,oo_2,0.0_dp,mos_old(2*ispin-1)%matrix,error=error) - CALL cp_fm_scale_and_add(1.0_dp,mos_old(2*ispin-1)%matrix,1.0_dp,mos_new(2*ispin-1)%matrix,error) + CALL cp_gemm("N","N",nao,nmo,nmo,-1.0_dp,mos_old(2*ispin)%matrix,oo_2,0.0_dp,mos_old(2*ispin-1)%matrix) + CALL cp_fm_scale_and_add(1.0_dp,mos_old(2*ispin-1)%matrix,1.0_dp,mos_new(2*ispin-1)%matrix) - CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*ispin)%matrix,oo_1,1.0_dp,mos_new(2*ispin)%matrix,error=error) - CALL cp_fm_to_fm(mos_new(2*ispin)%matrix,mos_old(2*ispin)%matrix,error) + CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*ispin)%matrix,oo_1,1.0_dp,mos_new(2*ispin)%matrix) + CALL cp_fm_to_fm(mos_new(2*ispin)%matrix,mos_old(2*ispin)%matrix) - CALL cp_fm_release(oo_1,error=error) - CALL cp_fm_release(oo_2,error=error) + CALL cp_fm_release(oo_1) + CALL cp_fm_release(oo_2) END DO - CALL cp_fm_release(S_chol, error=error) - CALL cp_fm_release(mat_ks, error=error) - CALL cp_fm_release(eigenvectors, error=error) + CALL cp_fm_release(S_chol) + CALL cp_fm_release(mat_ks) + CALL cp_fm_release(eigenvectors) !*************************************************************** !remove later - CALL cp_fm_release(S_inv_fm,error=error) - CALL cp_fm_release(tmpS,error=error) + CALL cp_fm_release(S_inv_fm) + CALL cp_fm_release(tmpS) !************************************************************** CALL timestop(handle) @@ -279,15 +276,13 @@ END SUBROUTINE apply_delta_pulse_periodic !> \param qs_env ... !> \param mos_old ... !> \param mos_new ... -!> \param error ... !> \author Joost & Martin (2011) ! ***************************************************************************** - SUBROUTINE apply_delta_pulse(qs_env,mos_old,mos_new,error) + SUBROUTINE apply_delta_pulse(qs_env,mos_old,mos_new) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mos_old, mos_new - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_delta_pulse', & routineP = moduleN//':'//routineN @@ -319,27 +314,26 @@ SUBROUTINE apply_delta_pulse(qs_env,mos_old,mos_new,error) mos=mos,& rtp=rtp,& matrix_s=matrix_s,& - dft_control=dft_control,& - error=error) - CALL get_rtp(rtp=rtp,S_inv=S_inv,error=error) + dft_control=dft_control) + CALL get_rtp(rtp=rtp,S_inv=S_inv) - CALL cp_fm_create(S_inv_fm, matrix_struct=rtp%ao_ao_fmstruct, name="tmp_mat", error=error) + CALL cp_fm_create(S_inv_fm, matrix_struct=rtp%ao_ao_fmstruct, name="tmp_mat") - CALL cp_fm_create(tmp,matrix_struct=rtp%ao_ao_fmstruct, name="tmp_mat", error=error) + CALL cp_fm_create(tmp,matrix_struct=rtp%ao_ao_fmstruct, name="tmp_mat") - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,S_inv_fm,error=error) - CALL cp_fm_cholesky_decompose(S_inv_fm,error=error) - CALL cp_fm_cholesky_invert(S_inv_fm,error=error) - CALL cp_fm_upper_to_full(S_inv_fm,tmp,error=error) + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,S_inv_fm) + CALL cp_fm_cholesky_decompose(S_inv_fm) + CALL cp_fm_cholesky_invert(S_inv_fm) + CALL cp_fm_upper_to_full(S_inv_fm,tmp) - CALL cp_fm_create(mat_S, matrix_struct=S_inv_fm%matrix_struct, name="mat_S", error=error) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,mat_S,error=error) - CALL cp_fm_upper_to_full(mat_S,tmp,error=error) + CALL cp_fm_create(mat_S, matrix_struct=S_inv_fm%matrix_struct, name="mat_S") + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,mat_S) + CALL cp_fm_upper_to_full(mat_S,tmp) - CALL cp_fm_release(tmp,error=error) + CALL cp_fm_release(tmp) ! we need the berry matrix - CALL get_qs_env(qs_env, cell=cell, error=error) + CALL get_qs_env(qs_env, cell=cell) ! direction ... unscaled, this will yield a exp(ikr) that is periodic with the cell kvec(:) = cell%h_inv(1,:)*dft_control%rtp_control%delta_pulse_direction(1)+& @@ -350,86 +344,86 @@ SUBROUTINE apply_delta_pulse(qs_env,mos_old,mos_new,error) kvec(:) = dft_control%rtp_control%delta_pulse_scale * kvec ALLOCATE(cosmat, sinmat) - CALL cp_dbcsr_init(cosmat, error=error) - CALL cp_dbcsr_init(sinmat, error=error) - CALL cp_dbcsr_copy(cosmat,matrix_s(1)%matrix,'COS MOM',error=error) - CALL cp_dbcsr_copy(sinmat,matrix_s(1)%matrix,'SIN MOM',error=error) - CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) + CALL cp_dbcsr_init(cosmat) + CALL cp_dbcsr_init(sinmat) + CALL cp_dbcsr_copy(cosmat,matrix_s(1)%matrix,'COS MOM') + CALL cp_dbcsr_copy(sinmat,matrix_s(1)%matrix,'SIN MOM') + CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec) ! apply inv(S)*operator to C DO i=1,SIZE(mos) CALL get_mo_set(mos(i)%mo_set, nao=nao,nmo=nmo) - CALL cp_dbcsr_sm_fm_multiply(cosmat, mos(i)%mo_set%mo_coeff, mos_new(2*i-1)%matrix, ncol=nmo, error=error) - CALL cp_dbcsr_sm_fm_multiply(sinmat, mos(i)%mo_set%mo_coeff, mos_new(2*i)%matrix, ncol=nmo, error=error) + CALL cp_dbcsr_sm_fm_multiply(cosmat, mos(i)%mo_set%mo_coeff, mos_new(2*i-1)%matrix, ncol=nmo) + CALL cp_dbcsr_sm_fm_multiply(sinmat, mos(i)%mo_set%mo_coeff, mos_new(2*i)%matrix, ncol=nmo) - CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,S_inv_fm,mos_new(2*i-1)%matrix,0.0_dp,mos_old(2*i-1)%matrix,error=error) - CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,S_inv_fm,mos_new(2*i)%matrix,0.0_dp,mos_old(2*i)%matrix,error=error) + CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,S_inv_fm,mos_new(2*i-1)%matrix,0.0_dp,mos_old(2*i-1)%matrix) + CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,S_inv_fm,mos_new(2*i)%matrix,0.0_dp,mos_old(2*i)%matrix) ! in a finite basis, unfortunately, inv(S)*operator is not unitary, so orthonormalize afterwards CALL cp_fm_struct_create(fm_struct_tmp, para_env=S_inv_fm%matrix_struct%para_env, context=S_inv_fm%matrix_struct%context,& - nrow_global=nmo, ncol_global=nmo, error=error) - CALL cp_fm_create(oo_1, matrix_struct=fm_struct_tmp, name="oo_1", error=error) - CALL cp_fm_create(oo_2, matrix_struct=fm_struct_tmp, name="oo_2", error=error) - CALL cp_fm_struct_release(fm_struct_tmp, error=error) + nrow_global=nmo, ncol_global=nmo) + CALL cp_fm_create(oo_1, matrix_struct=fm_struct_tmp, name="oo_1") + CALL cp_fm_create(oo_2, matrix_struct=fm_struct_tmp, name="oo_2") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL cp_fm_create(tmp, matrix_struct=mos_old(2*i-1)%matrix%matrix_struct, name="tmp_mat", error=error) + CALL cp_fm_create(tmp, matrix_struct=mos_old(2*i-1)%matrix%matrix_struct, name="tmp_mat") ! get the complex overlap matrix ! x^T S x + y^T S y + i (-y^TS x+x^T S y) - CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,mat_S,mos_old(2*i-1)%matrix,0.0_dp,tmp,error=error) - CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*i-1)%matrix,tmp,0.0_dp,oo_1,error=error) - CALL cp_gemm("T","N",nmo,nmo,nao,-1.0_dp,mos_old(2*i)%matrix,tmp,0.0_dp,oo_2,error=error) - - CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,mat_S,mos_old(2*i)%matrix,0.0_dp,tmp,error=error) - CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*i)%matrix,tmp,1.0_dp,oo_1,error=error) - CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*i-1)%matrix,tmp,1.0_dp,oo_2,error=error) - CALL cp_fm_release(tmp, error=error) - - CALL cp_cfm_create ( oo_c, oo_1 % matrix_struct,error=error) - CALL cp_cfm_create ( oo_v, oo_1 % matrix_struct,error=error) - CALL cp_cfm_create ( oo_vt, oo_1 % matrix_struct,error=error) + CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,mat_S,mos_old(2*i-1)%matrix,0.0_dp,tmp) + CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*i-1)%matrix,tmp,0.0_dp,oo_1) + CALL cp_gemm("T","N",nmo,nmo,nao,-1.0_dp,mos_old(2*i)%matrix,tmp,0.0_dp,oo_2) + + CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,mat_S,mos_old(2*i)%matrix,0.0_dp,tmp) + CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*i)%matrix,tmp,1.0_dp,oo_1) + CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mos_old(2*i-1)%matrix,tmp,1.0_dp,oo_2) + CALL cp_fm_release(tmp) + + CALL cp_cfm_create ( oo_c, oo_1 % matrix_struct) + CALL cp_cfm_create ( oo_v, oo_1 % matrix_struct) + CALL cp_cfm_create ( oo_vt, oo_1 % matrix_struct) oo_c % local_data = CMPLX(oo_1%local_data,oo_2%local_data,KIND=dp) ! compute inv(sqrt(overlap)) ALLOCATE(eigenvalues(nmo)) ALLOCATE(eigenvalues_sqrt(nmo)) - CALL cp_cfm_heevd(oo_c,oo_v,eigenvalues,error) + CALL cp_cfm_heevd(oo_c,oo_v,eigenvalues) eigenvalues_sqrt=CMPLX(1.0_dp/SQRT(eigenvalues),0.0_dp,dp) - CALL cp_cfm_to_cfm(oo_v,oo_vt,error=error) + CALL cp_cfm_to_cfm(oo_v,oo_vt) CALL cp_cfm_column_scale(oo_v,eigenvalues_sqrt) DEALLOCATE(eigenvalues) DEALLOCATE(eigenvalues_sqrt) CALL cp_cfm_gemm('N','C',nmo,nmo,nmo,(1.0_dp,0.0_dp),& - oo_v,oo_vt,(0.0_dp,0.0_dp),oo_c,error=error) + oo_v,oo_vt,(0.0_dp,0.0_dp),oo_c) oo_1%local_data=REAL(oo_c%local_data,KIND=dp) oo_2%local_data=AIMAG(oo_c%local_data) - CALL cp_cfm_release(oo_c,error=error) - CALL cp_cfm_release(oo_v,error=error) - CALL cp_cfm_release(oo_vt,error=error) + CALL cp_cfm_release(oo_c) + CALL cp_cfm_release(oo_v) + CALL cp_cfm_release(oo_vt) ! use this to compute the orthonormal vectors - CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*i-1)%matrix,oo_1,0.0_dp,mos_new(2*i-1)%matrix,error=error) - CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*i-1)%matrix,oo_2,0.0_dp,mos_new(2*i)%matrix,error=error) + CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*i-1)%matrix,oo_1,0.0_dp,mos_new(2*i-1)%matrix) + CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*i-1)%matrix,oo_2,0.0_dp,mos_new(2*i)%matrix) - CALL cp_gemm("N","N",nao,nmo,nmo,-1.0_dp,mos_old(2*i)%matrix,oo_2,0.0_dp,mos_old(2*i-1)%matrix,error=error) - CALL cp_fm_scale_and_add(1.0_dp,mos_old(2*i-1)%matrix,1.0_dp,mos_new(2*i-1)%matrix,error) + CALL cp_gemm("N","N",nao,nmo,nmo,-1.0_dp,mos_old(2*i)%matrix,oo_2,0.0_dp,mos_old(2*i-1)%matrix) + CALL cp_fm_scale_and_add(1.0_dp,mos_old(2*i-1)%matrix,1.0_dp,mos_new(2*i-1)%matrix) - CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*i)%matrix,oo_1,1.0_dp,mos_new(2*i)%matrix,error=error) - CALL cp_fm_to_fm(mos_new(2*i)%matrix,mos_old(2*i)%matrix,error) + CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mos_old(2*i)%matrix,oo_1,1.0_dp,mos_new(2*i)%matrix) + CALL cp_fm_to_fm(mos_new(2*i)%matrix,mos_old(2*i)%matrix) - CALL cp_fm_release(oo_1,error=error) - CALL cp_fm_release(oo_2,error=error) + CALL cp_fm_release(oo_1) + CALL cp_fm_release(oo_2) END DO - CALL cp_fm_release(mat_S, error=error) + CALL cp_fm_release(mat_S) - CALL cp_dbcsr_deallocate_matrix(cosmat, error) - CALL cp_dbcsr_deallocate_matrix(sinmat, error) + CALL cp_dbcsr_deallocate_matrix(cosmat) + CALL cp_dbcsr_deallocate_matrix(sinmat) !*************************************************************** !remove later - CALL copy_fm_to_dbcsr(S_inv_fm,S_inv,error=error) - CALL cp_dbcsr_filter(S_inv,rtp%filter_eps,error=error) - CALL cp_fm_release(S_inv_fm,error=error) + CALL copy_fm_to_dbcsr(S_inv_fm,S_inv) + CALL cp_dbcsr_filter(S_inv,rtp%filter_eps) + CALL cp_fm_release(S_inv_fm) !************************************************************** CALL timestop(handle) diff --git a/src/emd/rt_hfx_utils.F b/src/emd/rt_hfx_utils.F index 6773a6f427..eea953f7ec 100644 --- a/src/emd/rt_hfx_utils.F +++ b/src/emd/rt_hfx_utils.F @@ -43,12 +43,10 @@ MODULE rt_hfx_utils ! ***************************************************************************** !> \brief rebuilds the structures of P and KS (imaginary) in case S changed !> \param qs_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE rtp_hfx_rebuild(qs_env,error) + SUBROUTINE rtp_hfx_rebuild(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rtp_hfx_rebuild', & routineP = moduleN//':'//routineN @@ -75,27 +73,25 @@ SUBROUTINE rtp_hfx_rebuild(qs_env,error) matrix_s=matrix_s,& rho=rho,& matrix_ks_im=matrix_ks_im,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) - CALL qs_rho_get(rho, rho_ao_im=rho_ao_im, error=error) + CALL qs_rho_get(rho, rho_ao_im=rho_ao_im) CALL rebuild_matrices(rho_ao_im, matrix_ks_im, sab_orb, matrix_s,& - dft_control%nspins, error) - CALL set_ks_env(ks_env, matrix_ks_im=matrix_ks_im, error=error) - CALL qs_rho_set(rho, rho_ao_im=rho_ao_im, error=error) + dft_control%nspins) + CALL set_ks_env(ks_env, matrix_ks_im=matrix_ks_im) + CALL qs_rho_set(rho, rho_ao_im=rho_ao_im) IF(dft_control%do_admm)THEN CALL get_qs_env(qs_env,& matrix_s_aux_fit=matrix_s_aux,& sab_aux_fit=sab_aux,& rho_aux_fit=rho_aux,& - matrix_ks_aux_fit_im=matrix_ks_aux_im,& - error=error) - CALL qs_rho_get(rho_aux, rho_ao_im=rho_aux_ao_im, error=error) + matrix_ks_aux_fit_im=matrix_ks_aux_im) + CALL qs_rho_get(rho_aux, rho_ao_im=rho_aux_ao_im) CALL rebuild_matrices(rho_aux_ao_im, matrix_ks_aux_im, sab_aux, matrix_s_aux,& - dft_control%nspins,error) - CALL set_ks_env(ks_env, matrix_ks_aux_fit_im=matrix_ks_aux_im, error=error) - CALL qs_rho_set(rho_aux, rho_ao_im=rho_aux_ao_im, error=error) + dft_control%nspins) + CALL set_ks_env(ks_env, matrix_ks_aux_fit_im=matrix_ks_aux_im) + CALL qs_rho_set(rho_aux, rho_ao_im=rho_aux_ao_im) END IF END SUBROUTINE rtp_hfx_rebuild @@ -107,11 +103,10 @@ END SUBROUTINE rtp_hfx_rebuild !> \param sab_orb ... !> \param matrix_s ... !> \param nspins ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE rebuild_matrices(matrix_p,matrix_ks,sab_orb,matrix_s,nspins,error) + SUBROUTINE rebuild_matrices(matrix_p,matrix_ks,sab_orb,matrix_s,nspins) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_p, matrix_ks TYPE(neighbor_list_set_p_type), & @@ -119,7 +114,6 @@ SUBROUTINE rebuild_matrices(matrix_p,matrix_ks,sab_orb,matrix_s,nspins,error) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_s INTEGER, INTENT(in) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rebuild_matrices', & routineP = moduleN//':'//routineN @@ -128,41 +122,41 @@ SUBROUTINE rebuild_matrices(matrix_p,matrix_ks,sab_orb,matrix_s,nspins,error) INTEGER :: i IF (ASSOCIATED(matrix_p)) THEN - CALL cp_dbcsr_deallocate_matrix_set(matrix_p,error=error) + CALL cp_dbcsr_deallocate_matrix_set(matrix_p) END IF ! Create a new density matrix set - CALL cp_dbcsr_allocate_matrix_set(matrix_p,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_p,nspins) DO i=1,nspins headline = "Imaginary density matrix" ALLOCATE(matrix_p(i)%matrix) - CALL cp_dbcsr_init(matrix_p(i)%matrix, error=error) + CALL cp_dbcsr_init(matrix_p(i)%matrix) CALL cp_dbcsr_create(matrix=matrix_p(i)%matrix,& name=TRIM(headline),& dist=cp_dbcsr_distribution(matrix_s(1)%matrix), matrix_type=dbcsr_type_antisymmetric,& row_blk_size=cp_dbcsr_row_block_sizes(matrix_s(1)%matrix),& col_blk_size=cp_dbcsr_col_block_sizes(matrix_s(1)%matrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_p(i)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(matrix_p(i)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_p(i)%matrix,sab_orb) + CALL cp_dbcsr_set(matrix_p(i)%matrix,0.0_dp) END DO IF (ASSOCIATED(matrix_ks)) THEN - CALL cp_dbcsr_deallocate_matrix_set(matrix_ks,error=error) + CALL cp_dbcsr_deallocate_matrix_set(matrix_ks) END IF ! Create a new density matrix set - CALL cp_dbcsr_allocate_matrix_set(matrix_ks,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_ks,nspins) DO i=1,nspins headline = "Imaginary Kohn-Sham matrix" ALLOCATE(matrix_ks(i)%matrix) - CALL cp_dbcsr_init(matrix_ks(i)%matrix, error=error) + CALL cp_dbcsr_init(matrix_ks(i)%matrix) CALL cp_dbcsr_create(matrix=matrix_ks(i)%matrix,& name=TRIM(headline),& dist=cp_dbcsr_distribution(matrix_s(1)%matrix), matrix_type=dbcsr_type_antisymmetric,& row_blk_size=cp_dbcsr_row_block_sizes(matrix_s(1)%matrix),& col_blk_size=cp_dbcsr_col_block_sizes(matrix_s(1)%matrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks(i)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(matrix_ks(i)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks(i)%matrix,sab_orb) + CALL cp_dbcsr_set(matrix_ks(i)%matrix,0.0_dp) END DO diff --git a/src/emd/rt_make_propagators.F b/src/emd/rt_make_propagators.F index 9937536623..c810f78db5 100644 --- a/src/emd/rt_make_propagators.F +++ b/src/emd/rt_make_propagators.F @@ -68,15 +68,13 @@ MODULE rt_make_propagators !> EM: exp[-idt/2H(t+dt/2)*MOS !> \param rtp ... !> \param rtp_control ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE propagate_exp(rtp,rtp_control,error) + SUBROUTINE propagate_exp(rtp,rtp_control) TYPE(rt_prop_type), POINTER :: rtp TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'propagate_exp', & routineP = moduleN//':'//routineN @@ -94,41 +92,41 @@ SUBROUTINE propagate_exp(rtp,rtp_control,error) CALL timeset(routineN,handle) CALL get_rtp(rtp=rtp, propagator_matrix=propagator_matrix, mos_old=mos_old, mos_new=mos_new,& - mos_next=mos_next,exp_H_new=exp_H_new,exp_H_old=exp_H_old,error=error) + mos_next=mos_next,exp_H_new=exp_H_new,exp_H_old=exp_H_old) ! Only compute exponential if a new propagator matrix is available - CALL compute_exponential(exp_H_new,propagator_matrix,rtp_control,rtp,error) + CALL compute_exponential(exp_H_new,propagator_matrix,rtp_control,rtp) DO i=1,SIZE(mos_new)/2 re=2*i-1 im=2*i - CALL cp_fm_get_info(mos_new(re)%matrix,ncol_global=nmo,error=error) + CALL cp_fm_get_info(mos_new(re)%matrix,ncol_global=nmo) !Save some work by computing the first half of the propagation only once in case of ETRS !For EM this matrix has to be the initial matrix, thus a copy is enough IF(rtp%iter==1)THEN IF(rtp_control%propagator==do_etrs)THEN CALL cp_dbcsr_sm_fm_multiply(exp_H_old(re)%matrix,mos_old(re)%matrix,& - mos_next(re)%matrix,nmo,alpha=one,beta=zero,error=error) + mos_next(re)%matrix,nmo,alpha=one,beta=zero) CALL cp_dbcsr_sm_fm_multiply(exp_H_old(im)%matrix,mos_old(im)%matrix,& - mos_next(re)%matrix,nmo,alpha=-one,beta=one,error=error) + mos_next(re)%matrix,nmo,alpha=-one,beta=one) CALL cp_dbcsr_sm_fm_multiply(exp_H_old(re)%matrix,mos_old(im)%matrix,& - mos_next(im)%matrix,nmo,alpha=one,beta=zero,error=error) + mos_next(im)%matrix,nmo,alpha=one,beta=zero) CALL cp_dbcsr_sm_fm_multiply(exp_H_old(im)%matrix,mos_old(re)%matrix,& - mos_next(im)%matrix,nmo,alpha=one,beta=one,error=error) + mos_next(im)%matrix,nmo,alpha=one,beta=one) ELSE - CALL cp_fm_to_fm(mos_old(re)%matrix,mos_next(re)%matrix,error) - CALL cp_fm_to_fm(mos_old(im)%matrix,mos_next(im)%matrix,error) + CALL cp_fm_to_fm(mos_old(re)%matrix,mos_next(re)%matrix) + CALL cp_fm_to_fm(mos_old(im)%matrix,mos_next(im)%matrix) END IF END IF CALL cp_dbcsr_sm_fm_multiply(exp_H_new(re)%matrix,mos_next(re)%matrix,& - mos_new(re)%matrix,nmo,alpha=one,beta=zero,error=error) + mos_new(re)%matrix,nmo,alpha=one,beta=zero) CALL cp_dbcsr_sm_fm_multiply(exp_H_new(im)%matrix,mos_next(im)%matrix,& - mos_new(re)%matrix,nmo,alpha=-one,beta=one,error=error) + mos_new(re)%matrix,nmo,alpha=-one,beta=one) CALL cp_dbcsr_sm_fm_multiply(exp_H_new(re)%matrix,mos_next(im)%matrix,& - mos_new(im)%matrix,nmo,alpha=one,beta=zero,error=error) + mos_new(im)%matrix,nmo,alpha=one,beta=zero) CALL cp_dbcsr_sm_fm_multiply(exp_H_new(im)%matrix,mos_next(re)%matrix,& - mos_new(im)%matrix,nmo,alpha=one,beta=one,error=error) + mos_new(im)%matrix,nmo,alpha=one,beta=one) END DO CALL timestop(handle) @@ -140,15 +138,13 @@ END SUBROUTINE propagate_exp !> via a matrix exponential !> \param rtp ... !> \param rtp_control ... -!> \param error ... !> \author Samuel Andermatt (02.2014) ! ***************************************************************************** - SUBROUTINE propagate_exp_density(rtp,rtp_control,error) + SUBROUTINE propagate_exp_density(rtp,rtp_control) TYPE(rt_prop_type), POINTER :: rtp TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'propagate_exp_density', & routineP = moduleN//':'//routineN @@ -165,21 +161,21 @@ SUBROUTINE propagate_exp_density(rtp,rtp_control,error) CALL timeset(routineN,handle) CALL get_rtp(rtp=rtp, propagator_matrix=propagator_matrix,exp_H_new=exp_H_new,& - exp_H_old=exp_H_old,rho_old=rho_old,rho_new=rho_new,rho_next=rho_next,error=error) + exp_H_old=exp_H_old,rho_old=rho_old,rho_new=rho_new,rho_next=rho_next) - CALL compute_exponential_sparse(exp_H_new,propagator_matrix,rtp_control,rtp,error) + CALL compute_exponential_sparse(exp_H_new,propagator_matrix,rtp_control,rtp) !I could store these matrices in the type NULLIFY(tmp_re) ALLOCATE(tmp_re,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp_re,error=error) - CALL cp_dbcsr_create(tmp_re,template=propagator_matrix(1)%matrix,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp_re) + CALL cp_dbcsr_create(tmp_re,template=propagator_matrix(1)%matrix,matrix_type="N") NULLIFY(tmp_im) ALLOCATE(tmp_im,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp_im,error=error) - CALL cp_dbcsr_create(tmp_im,template=propagator_matrix(1)%matrix,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp_im) + CALL cp_dbcsr_create(tmp_im,template=propagator_matrix(1)%matrix,matrix_type="N") DO i=1,SIZE(exp_H_new)/2 re=2*i-1 @@ -189,22 +185,22 @@ SUBROUTINE propagate_exp_density(rtp,rtp_control,error) IF(rtp%iter==1) THEN IF(rtp_control%propagator==do_etrs) THEN CALL cp_complex_dbcsr_gemm_3("N","N",one,exp_H_old(re)%matrix,exp_H_old(im)%matrix,& - rho_old(re)%matrix,rho_old(im)%matrix,zero,tmp_re,tmp_im,filter_eps=rtp%filter_eps,error=error) + rho_old(re)%matrix,rho_old(im)%matrix,zero,tmp_re,tmp_im,filter_eps=rtp%filter_eps) CALL cp_complex_dbcsr_gemm_3("N","C",one,tmp_re,tmp_im,exp_H_old(re)%matrix,exp_H_old(im)%matrix,& - zero,rho_next(re)%matrix,rho_next(im)%matrix,filter_eps=rtp%filter_eps,error=error) + zero,rho_next(re)%matrix,rho_next(im)%matrix,filter_eps=rtp%filter_eps) ELSE - CALL cp_dbcsr_copy(rho_next(re)%matrix,rho_old(re)%matrix,error=error) - CALL cp_dbcsr_copy(rho_next(im)%matrix,rho_old(im)%matrix,error=error) + CALL cp_dbcsr_copy(rho_next(re)%matrix,rho_old(re)%matrix) + CALL cp_dbcsr_copy(rho_next(im)%matrix,rho_old(im)%matrix) ENDIF END IF CALL cp_complex_dbcsr_gemm_3("N","N",one,exp_H_new(re)%matrix,exp_H_new(im)%matrix,& - rho_next(re)%matrix,rho_next(im)%matrix,zero,tmp_re,tmp_im,filter_eps=rtp%filter_eps,error=error) + rho_next(re)%matrix,rho_next(im)%matrix,zero,tmp_re,tmp_im,filter_eps=rtp%filter_eps) CALL cp_complex_dbcsr_gemm_3("N","C",one,tmp_re,tmp_im,exp_H_new(re)%matrix,exp_H_new(im)%matrix,& - zero,rho_new(re)%matrix,rho_new(im)%matrix,filter_eps=rtp%filter_eps,error=error) + zero,rho_new(re)%matrix,rho_new(im)%matrix,filter_eps=rtp%filter_eps) END DO - CALL cp_dbcsr_deallocate_matrix(tmp_re,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp_im,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp_re) + CALL cp_dbcsr_deallocate_matrix(tmp_im) CALL timestop(handle) @@ -214,14 +210,12 @@ END SUBROUTINE propagate_exp_density !> \brief computes U_prop*MOs using arnoldi subspace algorithm !> \param rtp ... !> \param rtp_control ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE propagate_arnoldi(rtp,rtp_control,error) + SUBROUTINE propagate_arnoldi(rtp,rtp_control) TYPE(rt_prop_type), POINTER :: rtp TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'propagate_arnoldi', & routineP = moduleN//':'//routineN @@ -238,7 +232,7 @@ SUBROUTINE propagate_arnoldi(rtp,rtp_control,error) CALL timeset(routineN,handle) CALL get_rtp(rtp=rtp,dt=t,mos_new=mos_new,mos_old=mos_old,& - mos_next=mos_next,propagator_matrix=propagator_matrix,error=error) + mos_next=mos_next,propagator_matrix=propagator_matrix) nspin=SIZE(mos_new)/2 eps_arnoldi=rtp_control%eps_exp @@ -247,7 +241,7 @@ SUBROUTINE propagate_arnoldi(rtp,rtp_control,error) ! ready on mos_old and only need to perform the second half propagatioon IF(rtp_control%propagator==do_etrs.AND.rtp%iter==1)THEN DO i=1,SIZE(mos_new) - CALL cp_fm_to_fm(mos_next(i)%matrix,mos_old(i)%matrix,error) + CALL cp_fm_to_fm(mos_next(i)%matrix,mos_old(i)%matrix) END DO END IF @@ -256,8 +250,8 @@ SUBROUTINE propagate_arnoldi(rtp,rtp_control,error) DO i=1,SIZE(propagator_matrix) CALL cp_fm_create(propagator_matrix_fm(i)%matrix,& matrix_struct=rtp%ao_ao_fmstruct,& - name="prop_fm",error=error) - CALL copy_dbcsr_to_fm(propagator_matrix(i)%matrix,propagator_matrix_fm(i)%matrix,error) + name="prop_fm") + CALL copy_dbcsr_to_fm(propagator_matrix(i)%matrix,propagator_matrix_fm(i)%matrix) END DO DO ispin=1,nspin @@ -266,19 +260,19 @@ SUBROUTINE propagate_arnoldi(rtp,rtp_control,error) IF(rtp_control%fixed_ions.AND..NOT.rtp%do_hfx)THEN CALL arnoldi(mos_old(re:im),mos_new(re:im),& eps_arnoldi,Him=propagator_matrix_fm(im)%matrix,& - mos_next=mos_next(re:im),narn_old=rtp%narn_old,error=error) + mos_next=mos_next(re:im),narn_old=rtp%narn_old) ELSE CALL arnoldi(mos_old(re:im),mos_new(re:im),& eps_arnoldi,Hre=propagator_matrix_fm(re)%matrix,& Him=propagator_matrix_fm(im)%matrix,mos_next=mos_next(re:im),& - narn_old=rtp%narn_old,error=error) + narn_old=rtp%narn_old) END IF END DO ! DO i=1,SIZE(propagator_matrix) -! CALL copy_fm_to_dbcsr(propagator_matrix_fm(i)%matrix,propagator_matrix(i)%matrix,error=error) +! CALL copy_fm_to_dbcsr(propagator_matrix_fm(i)%matrix,propagator_matrix(i)%matrix) ! END DO - CALL cp_fm_vect_dealloc(propagator_matrix_fm,error=error) + CALL cp_fm_vect_dealloc(propagator_matrix_fm) CALL timestop(handle) @@ -289,15 +283,13 @@ END SUBROUTINE propagate_arnoldi !> currently only works for rtp !> \param rtp ... !> \param rtp_control ... -!> \param error ... !> \author Samuel Andermatt (02.2014) ! ***************************************************************************** - SUBROUTINE propagate_bch(rtp,rtp_control,error) + SUBROUTINE propagate_bch(rtp,rtp_control) TYPE(rt_prop_type), POINTER :: rtp TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'propagate_bch', & routineP = moduleN//':'//routineN @@ -315,7 +307,7 @@ SUBROUTINE propagate_bch(rtp,rtp_control,error) failure= .FALSE. CALL get_rtp(rtp=rtp, propagator_matrix=propagator_matrix,rho_old=rho_old,rho_new=rho_new,& - rho_next=rho_next,error=error) + rho_next=rho_next) DO ispin=1,SIZE(propagator_matrix)/2 re=2*ispin-1 @@ -324,31 +316,31 @@ SUBROUTINE propagate_bch(rtp,rtp_control,error) IF(rtp%iter==1) THEN ! For EM I have to copy rho_old onto rho_next and for ETRS, ! this is the first term of the series of commutators that result in rho_next - CALL cp_dbcsr_copy(rho_next(re)%matrix,rho_old(re)%matrix,error=error) - CALL cp_dbcsr_copy(rho_next(im)%matrix,rho_old(im)%matrix,error=error) + CALL cp_dbcsr_copy(rho_next(re)%matrix,rho_old(re)%matrix) + CALL cp_dbcsr_copy(rho_next(im)%matrix,rho_old(im)%matrix) IF(rtp_control%propagator==do_etrs) THEN !since we never calculated the matrix exponential the old matrix exponential stores the unscalled propagator - CALL get_rtp(rtp=rtp,exp_H_old=exp_H_old,dt=dt,error=error) + CALL get_rtp(rtp=rtp,exp_H_old=exp_H_old,dt=dt) prefac=-0.5_dp*dt - CALL cp_dbcsr_scale(exp_H_old(im)%matrix,prefac,error=error) + CALL cp_dbcsr_scale(exp_H_old(im)%matrix,prefac) IF(.NOT.rtp%do_hfx.AND.rtp_control%fixed_ions)THEN CALL bch_expansion_imaginary_propagator(exp_H_old(im)%matrix,& - rho_next(re)%matrix,rho_next(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp,error=error) + rho_next(re)%matrix,rho_next(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp) ELSE - CALL cp_dbcsr_scale(exp_H_old(re)%matrix,prefac,error=error) + CALL cp_dbcsr_scale(exp_H_old(re)%matrix,prefac) CALL bch_expansion_complex_propagator(exp_H_old(re)%matrix,exp_H_old(im)%matrix,& - rho_next(re)%matrix,rho_next(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp,error=error) + rho_next(re)%matrix,rho_next(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp) ENDIF END IF END IF - CALL cp_dbcsr_copy(rho_new(re)%matrix,rho_next(re)%matrix,error=error) - CALL cp_dbcsr_copy(rho_new(im)%matrix,rho_next(im)%matrix,error=error) + CALL cp_dbcsr_copy(rho_new(re)%matrix,rho_next(re)%matrix) + CALL cp_dbcsr_copy(rho_new(im)%matrix,rho_next(im)%matrix) IF(.NOT.rtp%do_hfx.AND.rtp_control%fixed_ions)THEN CALL bch_expansion_imaginary_propagator(propagator_matrix(im)%matrix,& - rho_new(re)%matrix,rho_new(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp,error=error) + rho_new(re)%matrix,rho_new(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp) ELSE CALL bch_expansion_complex_propagator(propagator_matrix(re)%matrix,propagator_matrix(im)%matrix,& - rho_new(re)%matrix,rho_new(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp,error=error) + rho_new(re)%matrix,rho_new(im)%matrix,rtp%filter_eps,rtp%filter_eps_small,rtp_control%eps_exp) ENDIF END DO @@ -364,16 +356,14 @@ END SUBROUTINE propagate_bch !> \param propagator_matrix ... !> \param rtp_control ... !> \param rtp ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE compute_exponential(propagator,propagator_matrix,rtp_control,rtp,error) + SUBROUTINE compute_exponential(propagator,propagator_matrix,rtp_control,rtp) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: propagator, propagator_matrix TYPE(rtp_control_type), POINTER :: rtp_control TYPE(rt_prop_type), POINTER :: rtp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_exponential', & routineP = moduleN//':'//routineN @@ -390,12 +380,12 @@ SUBROUTINE compute_exponential(propagator,propagator_matrix,rtp_control,rtp,erro DO i=1,SIZE(propagator) CALL cp_fm_create(propagator_fm(i)%matrix,& matrix_struct=rtp%ao_ao_fmstruct,& - name="prop_fm",error=error) - CALL copy_dbcsr_to_fm(propagator(i)%matrix,propagator_fm(i)%matrix,error) + name="prop_fm") + CALL copy_dbcsr_to_fm(propagator(i)%matrix,propagator_fm(i)%matrix) CALL cp_fm_create(propagator_matrix_fm(i)%matrix,& matrix_struct=rtp%ao_ao_fmstruct,& - name="prop_mat_fm",error=error) - CALL copy_dbcsr_to_fm(propagator_matrix(i)%matrix,propagator_matrix_fm(i)%matrix,error) + name="prop_mat_fm") + CALL copy_dbcsr_to_fm(propagator_matrix(i)%matrix,propagator_matrix_fm(i)%matrix) END DO DO ispin=1,SIZE(propagator)/2 @@ -407,28 +397,28 @@ SUBROUTINE compute_exponential(propagator,propagator_matrix,rtp_control,rtp,erro CASE(do_taylor) IF(rtp_control%fixed_ions.AND..NOT.rtp%do_hfx)THEN CALL taylor_only_imaginary(propagator_fm(re:im),propagator_matrix_fm(im)%matrix,& - rtp%orders(1,ispin),rtp%orders(2,ispin),error) + rtp%orders(1,ispin),rtp%orders(2,ispin)) ELSE CALL taylor_full_complex(propagator_fm(re:im),propagator_matrix_fm(re)%matrix,propagator_matrix_fm(im)%matrix,& - rtp%orders(1,ispin),rtp%orders(2,ispin),error) + rtp%orders(1,ispin),rtp%orders(2,ispin)) END IF CASE(do_pade) IF(rtp_control%fixed_ions.AND..NOT.rtp%do_hfx)THEN CALL exp_pade_only_imaginary(propagator_fm(re:im),propagator_matrix_fm(im)%matrix,& - rtp%orders(1,ispin),rtp%orders(2,ispin),error) + rtp%orders(1,ispin),rtp%orders(2,ispin)) ELSE CALL exp_pade_full_complex(propagator_fm(re:im),propagator_matrix_fm(re)%matrix,propagator_matrix_fm(im)%matrix,& - rtp%orders(1,ispin),rtp%orders(2,ispin),error) + rtp%orders(1,ispin),rtp%orders(2,ispin)) END IF END SELECT END DO DO i=1,SIZE(propagator) - CALL copy_fm_to_dbcsr(propagator_fm(i)%matrix,propagator(i)%matrix,error=error) - CALL copy_fm_to_dbcsr(propagator_matrix_fm(i)%matrix,propagator_matrix(i)%matrix,error=error) + CALL copy_fm_to_dbcsr(propagator_fm(i)%matrix,propagator(i)%matrix) + CALL copy_fm_to_dbcsr(propagator_matrix_fm(i)%matrix,propagator_matrix(i)%matrix) END DO - CALL cp_fm_vect_dealloc(propagator_fm,error=error) - CALL cp_fm_vect_dealloc(propagator_matrix_fm,error=error) + CALL cp_fm_vect_dealloc(propagator_fm) + CALL cp_fm_vect_dealloc(propagator_matrix_fm) END SUBROUTINE compute_exponential @@ -438,16 +428,14 @@ END SUBROUTINE compute_exponential !> \param propagator_matrix ... !> \param rtp_control ... !> \param rtp ... -!> \param error ... !> \author Samuel Andermatt (02.14) ! ***************************************************************************** - SUBROUTINE compute_exponential_sparse(propagator,propagator_matrix,rtp_control,rtp,error) + SUBROUTINE compute_exponential_sparse(propagator,propagator_matrix,rtp_control,rtp) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: propagator, propagator_matrix TYPE(rtp_control_type), POINTER :: rtp_control TYPE(rt_prop_type), POINTER :: rtp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_exponential_sparse', & routineP = moduleN//':'//routineN @@ -461,10 +449,10 @@ SUBROUTINE compute_exponential_sparse(propagator,propagator_matrix,rtp_control,r im=2*ispin IF(rtp_control%fixed_ions.AND..NOT.rtp%do_hfx)THEN CALL taylor_only_imaginary_dbcsr(propagator(re:im),propagator_matrix(im)%matrix,& - rtp%orders(1,ispin),rtp%orders(2,ispin),rtp%filter_eps,error) + rtp%orders(1,ispin),rtp%orders(2,ispin),rtp%filter_eps) ELSE CALL taylor_full_complex_dbcsr(propagator(re:im),propagator_matrix(re)%matrix,propagator_matrix(im)%matrix,& - rtp%orders(1,ispin),rtp%orders(2,ispin),rtp%filter_eps,error) + rtp%orders(1,ispin),rtp%orders(2,ispin),rtp%filter_eps) END IF END DO diff --git a/src/emd/rt_propagation_methods.F b/src/emd/rt_propagation_methods.F index 55f2aa6bab..ea6d3fbcba 100644 --- a/src/emd/rt_propagation_methods.F +++ b/src/emd/rt_propagation_methods.F @@ -92,16 +92,14 @@ MODULE rt_propagation_methods !> \param qs_env ... !> \param rtp ... !> \param rtp_control ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE propagation_step(qs_env, rtp, rtp_control, error) + SUBROUTINE propagation_step(qs_env, rtp, rtp_control) TYPE(qs_environment_type), POINTER :: qs_env TYPE(rt_prop_type), POINTER :: rtp TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'propagation_step', & routineP = moduleN//':'//routineN @@ -119,7 +117,7 @@ SUBROUTINE propagation_step(qs_env, rtp, rtp_control, error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -129,127 +127,125 @@ SUBROUTINE propagation_step(qs_env, rtp, rtp_control, error) NULLIFY(delta_P, rho_new,delta_mos, mos_new) NULLIFY(ks_mix,ks_mix_im) ! get everything needed and set some values - CALL get_qs_env(qs_env,matrix_s=matrix_s,error=error) + CALL get_qs_env(qs_env,matrix_s=matrix_s) IF(rtp%iter==1)THEN - CALL qs_energies_init(qs_env, .FALSE. , error=error) - CALL get_qs_env(qs_env,matrix_s=matrix_s,error=error) + CALL qs_energies_init(qs_env, .FALSE.) + CALL get_qs_env(qs_env,matrix_s=matrix_s) IF(.NOT.rtp_control%fixed_ions)THEN - CALL s_matrices_create (matrix_s,rtp,error=error) + CALL s_matrices_create (matrix_s,rtp) END IF rtp%delta_iter=100.0_dp rtp%mixing_factor=1.0_dp rtp%mixing=.FALSE. aspc_order=rtp_control%aspc_order - CALL aspc_extrapolate(rtp,matrix_s,aspc_order,error=error) + CALL aspc_extrapolate(rtp,matrix_s,aspc_order) IF(rtp%linear_scaling) THEN - CALL calc_update_rho_sparse(qs_env,error=error) + CALL calc_update_rho_sparse(qs_env) ELSE - CALL calc_update_rho(qs_env,error=error) + CALL calc_update_rho(qs_env) ENDIF - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., error=error) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) END IF IF(.NOT.rtp_control%fixed_ions)THEN - CALL calc_S_derivs(qs_env,error=error) + CALL calc_S_derivs(qs_env) END IF rtp%converged=.FALSE. IF(rtp%linear_scaling) THEN ! keep temporary copy of the starting density matrix to check for convergence - CALL get_rtp(rtp=rtp,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_new=rho_new) NULLIFY(delta_P) - CALL cp_dbcsr_allocate_matrix_set(delta_P,SIZE(rho_new),error=error) + CALL cp_dbcsr_allocate_matrix_set(delta_P,SIZE(rho_new)) DO i=1,SIZE(rho_new) - CALL cp_dbcsr_init_p(delta_P(i)%matrix,error=error) - CALL cp_dbcsr_create(delta_P(i)%matrix,template=rho_new(i)%matrix,error=error) - CALL cp_dbcsr_copy(delta_P(i)%matrix,rho_new(i)%matrix,error=error) + CALL cp_dbcsr_init_p(delta_P(i)%matrix) + CALL cp_dbcsr_create(delta_P(i)%matrix,template=rho_new(i)%matrix) + CALL cp_dbcsr_copy(delta_P(i)%matrix,rho_new(i)%matrix) END DO ELSE ! keep temporary copy of the starting mos to check for convergence - CALL get_rtp(rtp=rtp, mos_new=mos_new, error=error) + CALL get_rtp(rtp=rtp, mos_new=mos_new) ALLOCATE(delta_mos(SIZE(mos_new))) DO i=1,SIZE(mos_new) CALL cp_fm_create(delta_mos(i)%matrix,& matrix_struct=mos_new(i)%matrix%matrix_struct,& - name="delta_mos"//TRIM(ADJUSTL(cp_to_string(i))),& - error=error) - CALL cp_fm_to_fm(mos_new(i)%matrix,delta_mos(i)%matrix,error) + name="delta_mos"//TRIM(ADJUSTL(cp_to_string(i)))) + CALL cp_fm_to_fm(mos_new(i)%matrix,delta_mos(i)%matrix) END DO ENDIF CALL get_qs_env(qs_env,& matrix_ks=matrix_ks,& - matrix_ks_im=matrix_ks_im,& - error=error) + matrix_ks_im=matrix_ks_im) - CALL get_rtp(rtp=rtp,H_last_iter=H_last_iter,error=error) + CALL get_rtp(rtp=rtp,H_last_iter=H_last_iter) IF(rtp%mixing) THEN IF (unit_nr>0) THEN WRITE(unit_nr,'(t3,a,2f16.8)') "Mixing the Hamiltonians to improve robustness, mixing factor: ", rtp%mixing_factor ENDIF - CALL cp_dbcsr_allocate_matrix_set(ks_mix,SIZE(matrix_ks),error=error) - CALL cp_dbcsr_allocate_matrix_set(ks_mix_im,SIZE(matrix_ks),error=error) + CALL cp_dbcsr_allocate_matrix_set(ks_mix,SIZE(matrix_ks)) + CALL cp_dbcsr_allocate_matrix_set(ks_mix_im,SIZE(matrix_ks)) DO i=1,SIZE(matrix_ks) - CALL cp_dbcsr_init_p(ks_mix(i)%matrix,error=error) - CALL cp_dbcsr_create(ks_mix(i)%matrix,template=matrix_ks(1)%matrix,error=error) - CALL cp_dbcsr_init_p(ks_mix_im(i)%matrix,error=error) - CALL cp_dbcsr_create(ks_mix_im(i)%matrix,template=matrix_ks(1)%matrix,error=error) + CALL cp_dbcsr_init_p(ks_mix(i)%matrix) + CALL cp_dbcsr_create(ks_mix(i)%matrix,template=matrix_ks(1)%matrix) + CALL cp_dbcsr_init_p(ks_mix_im(i)%matrix) + CALL cp_dbcsr_create(ks_mix_im(i)%matrix,template=matrix_ks(1)%matrix) ENDDO DO i=1,SIZE(matrix_ks) re=2*i-1 im=2*i - CALL cp_dbcsr_add(ks_mix(i)%matrix,matrix_ks(i)%matrix,0.0_dp,rtp%mixing_factor,error=error) - CALL cp_dbcsr_add(ks_mix(i)%matrix,H_last_iter(re)%matrix,1.0_dp,1.0_dp-rtp%mixing_factor,error=error) + CALL cp_dbcsr_add(ks_mix(i)%matrix,matrix_ks(i)%matrix,0.0_dp,rtp%mixing_factor) + CALL cp_dbcsr_add(ks_mix(i)%matrix,H_last_iter(re)%matrix,1.0_dp,1.0_dp-rtp%mixing_factor) IF(rtp%do_hfx)THEN - CALL cp_dbcsr_add(ks_mix_im(i)%matrix,matrix_ks_im(i)%matrix,0.0_dp,rtp%mixing_factor,error=error) - CALL cp_dbcsr_add(ks_mix_im(i)%matrix,H_last_iter(im)%matrix,1.0_dp,1.0_dp-rtp%mixing_factor,error=error) + CALL cp_dbcsr_add(ks_mix_im(i)%matrix,matrix_ks_im(i)%matrix,0.0_dp,rtp%mixing_factor) + CALL cp_dbcsr_add(ks_mix_im(i)%matrix,H_last_iter(im)%matrix,1.0_dp,1.0_dp-rtp%mixing_factor) ENDIF ENDDO - CALL calc_SinvH(rtp,ks_mix,ks_mix_im,rtp_control,error) + CALL calc_SinvH(rtp,ks_mix,ks_mix_im,rtp_control) DO i=1,SIZE(matrix_ks) re=2*i-1 im=2*i - CALL cp_dbcsr_copy(H_last_iter(re)%matrix,ks_mix(i)%matrix,error=error) + CALL cp_dbcsr_copy(H_last_iter(re)%matrix,ks_mix(i)%matrix) IF(rtp%do_hfx)THEN - CALL cp_dbcsr_copy(H_last_iter(im)%matrix,ks_mix_im(i)%matrix,error=error) + CALL cp_dbcsr_copy(H_last_iter(im)%matrix,ks_mix_im(i)%matrix) ENDIF ENDDO - CALL cp_dbcsr_deallocate_matrix_set(ks_mix,error=error) - CALL cp_dbcsr_deallocate_matrix_set(ks_mix_im,error=error) + CALL cp_dbcsr_deallocate_matrix_set(ks_mix) + CALL cp_dbcsr_deallocate_matrix_set(ks_mix_im) ELSE - CALL calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control,error) + CALL calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control) DO i=1,SIZE(matrix_ks) re=2*i-1 im=2*i - CALL cp_dbcsr_copy(H_last_iter(re)%matrix,matrix_ks(i)%matrix,error=error) + CALL cp_dbcsr_copy(H_last_iter(re)%matrix,matrix_ks(i)%matrix) IF(rtp%do_hfx)THEN - CALL cp_dbcsr_copy(H_last_iter(im)%matrix,matrix_ks_im(i)%matrix,error=error) + CALL cp_dbcsr_copy(H_last_iter(im)%matrix,matrix_ks_im(i)%matrix) ENDIF ENDDO ENDIF - CALL compute_propagator_matrix(rtp,rtp_control%propagator,error) + CALL compute_propagator_matrix(rtp,rtp_control%propagator) SELECT CASE(rtp_control%mat_exp) CASE( do_pade, do_taylor) IF(rtp%linear_scaling) THEN - CALL propagate_exp_density(rtp,rtp_control,error) - CALL calc_update_rho_sparse(qs_env,error) + CALL propagate_exp_density(rtp,rtp_control) + CALL calc_update_rho_sparse(qs_env) ELSE - CALL propagate_exp(rtp,rtp_control,error) - CALL calc_update_rho(qs_env,error) + CALL propagate_exp(rtp,rtp_control) + CALL calc_update_rho(qs_env) END IF CASE(do_arnoldi) - CALL propagate_arnoldi(rtp,rtp_control,error) - CALL calc_update_rho(qs_env,error) + CALL propagate_arnoldi(rtp,rtp_control) + CALL calc_update_rho(qs_env) CASE(do_bch) - CALL propagate_bch(rtp,rtp_control,error) - CALL calc_update_rho_sparse(qs_env,error) + CALL propagate_bch(rtp,rtp_control) + CALL calc_update_rho_sparse(qs_env) END SELECT - CALL step_finalize(qs_env,rtp_control,delta_mos,delta_P,error) + CALL step_finalize(qs_env,rtp_control,delta_mos,delta_P) IF(rtp%linear_scaling) THEN - CALL cp_dbcsr_deallocate_matrix_set(delta_P,error) + CALL cp_dbcsr_deallocate_matrix_set(delta_P) ELSE - CALL cp_fm_vect_dealloc(delta_mos,error) + CALL cp_fm_vect_dealloc(delta_mos) ENDIF CALL timestop(handle) @@ -265,18 +261,16 @@ END SUBROUTINE propagation_step !> \param rtp_control ... !> \param delta_mos ... !> \param delta_P ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE step_finalize(qs_env,rtp_control,delta_mos,delta_P,error) + SUBROUTINE step_finalize(qs_env,rtp_control,delta_mos,delta_P) TYPE(qs_environment_type), POINTER :: qs_env TYPE(rtp_control_type), POINTER :: rtp_control TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: delta_mos TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: delta_P - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'step_finalize', & routineP = moduleN//':'//routineN @@ -293,15 +287,15 @@ SUBROUTINE step_finalize(qs_env,rtp_control,delta_mos,delta_P,error) CALL timeset(routineN,handle) - CALL get_qs_env(qs_env=qs_env,rtp=rtp,matrix_s=s_mat,matrix_ks=matrix_ks,matrix_ks_im=matrix_ks_im,energy=energy,error=error) - CALL get_rtp(rtp=rtp,exp_H_old=exp_H_old,exp_H_new=exp_H_new,error=error) + CALL get_qs_env(qs_env=qs_env,rtp=rtp,matrix_s=s_mat,matrix_ks=matrix_ks,matrix_ks_im=matrix_ks_im,energy=energy) + CALL get_rtp(rtp=rtp,exp_H_old=exp_H_old,exp_H_new=exp_H_new) IF(rtp_control%sc_check_start.LT.rtp%iter) THEN rtp%delta_iter_old=rtp%delta_iter IF(rtp%linear_scaling) THEN - CALL rt_convergence_density(rtp,delta_P,rtp%delta_iter,error) + CALL rt_convergence_density(rtp,delta_P,rtp%delta_iter) ELSE - CALL rt_convergence(rtp,s_mat(1)%matrix,delta_mos,rtp%delta_iter,error) + CALL rt_convergence(rtp,s_mat(1)%matrix,delta_mos,rtp%delta_iter) END IF rtp%converged=(rtp%delta_iter.LT.rtp_control%eps_ener) !Apply mixing if scf loop is not converging @@ -318,34 +312,34 @@ SUBROUTINE step_finalize(qs_env,rtp_control,delta_mos,delta_P,error) IF(rtp%converged)THEN IF(rtp%linear_scaling) THEN - CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new) IF(rtp_control%orthonormal) THEN CALL purify_mcweeny_complex_orth(rho_new,rtp%filter_eps,rtp%filter_eps_small,& - rtp_control%mcweeny_max_iter,rtp_control%mcweeny_eps,error) + rtp_control%mcweeny_max_iter,rtp_control%mcweeny_eps) ELSE CALL purify_mcweeny_complex_nonorth(rho_new,s_mat,rtp%filter_eps,rtp%filter_eps_small,& - rtp_control%mcweeny_max_iter,rtp_control%mcweeny_eps,error) + rtp_control%mcweeny_max_iter,rtp_control%mcweeny_eps) ENDIF - IF(rtp_control%mcweeny_max_iter>0) CALL calc_update_rho_sparse(qs_env,error) - CALL report_density_occupation(rtp%filter_eps,rho_new,error=error) + IF(rtp_control%mcweeny_max_iter>0) CALL calc_update_rho_sparse(qs_env) + CALL report_density_occupation(rtp%filter_eps,rho_new) DO i=1,SIZE(rho_new) - CALL cp_dbcsr_copy(rho_old(i)%matrix,rho_new(i)%matrix,error=error) + CALL cp_dbcsr_copy(rho_old(i)%matrix,rho_new(i)%matrix) END DO ELSE - CALL get_rtp(rtp=rtp,mos_old=mos_old,mos_new=mos_new,error=error) + CALL get_rtp(rtp=rtp,mos_old=mos_old,mos_new=mos_new) DO i=1,SIZE(mos_new) - CALL cp_fm_to_fm(mos_new(i)%matrix,mos_old(i)%matrix,error) + CALL cp_fm_to_fm(mos_new(i)%matrix,mos_old(i)%matrix) END DO ENDIF - IF(rtp_control%propagator==do_em) CALL calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control,error) + IF(rtp_control%propagator==do_em) CALL calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control) DO i=1,SIZE(exp_H_new) - CALL cp_dbcsr_copy(exp_H_old(i)%matrix,exp_H_new(i)%matrix,error=error) + CALL cp_dbcsr_copy(exp_H_old(i)%matrix,exp_H_new(i)%matrix) END DO ihist=MOD(rtp%istep,rtp_control%aspc_order)+1 IF(rtp_control%fixed_ions)THEN - CALL put_data_to_history(rtp,rho=rho_new,mos=mos_new,ihist=ihist,error=error) + CALL put_data_to_history(rtp,rho=rho_new,mos=mos_new,ihist=ihist) ELSE - CALL put_data_to_history(rtp,rho=rho_new,mos=mos_new,s_mat=s_mat,ihist=ihist,error=error) + CALL put_data_to_history(rtp,rho=rho_new,mos=mos_new,s_mat=s_mat,ihist=ihist) END IF END IF @@ -359,14 +353,12 @@ END SUBROUTINE step_finalize !> \brief computes the propagator matrix for EM/ETRS, RTP/EMD !> \param rtp ... !> \param propagator ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE compute_propagator_matrix(rtp,propagator,error) + SUBROUTINE compute_propagator_matrix(rtp,propagator) TYPE(rt_prop_type), POINTER :: rtp INTEGER :: propagator - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_propagator_matrix', & routineP = moduleN//':'//routineN @@ -379,14 +371,14 @@ SUBROUTINE compute_propagator_matrix(rtp,propagator,error) CALL timeset(routineN,handle) CALL get_rtp(rtp=rtp,exp_H_new=exp_H_new,exp_H_old=exp_H_old,& - propagator_matrix=propagator_matrix,dt=dt,error=error) + propagator_matrix=propagator_matrix,dt=dt) prefac=-0.5_dp*dt DO i=1,SIZE(exp_H_new) - CALL cp_dbcsr_add(propagator_matrix(i)%matrix,exp_H_new(i)%matrix,0.0_dp,prefac,error) + CALL cp_dbcsr_add(propagator_matrix(i)%matrix,exp_H_new(i)%matrix,0.0_dp,prefac) IF(propagator==do_em)& - CALL cp_dbcsr_add(propagator_matrix(i)%matrix,exp_H_old(i)%matrix,1.0_dp,prefac,error) + CALL cp_dbcsr_add(propagator_matrix(i)%matrix,exp_H_old(i)%matrix,1.0_dp,prefac) END DO CALL timestop(handle) @@ -399,16 +391,14 @@ END SUBROUTINE compute_propagator_matrix !> \param matrix_ks ... !> \param matrix_ks_im ... !> \param rtp_control ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control,error) + SUBROUTINE calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks, matrix_ks_im TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_SinvH', & routineP = moduleN//':'//routineN @@ -422,81 +412,81 @@ SUBROUTINE calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control,error) TYPE(cp_dbcsr_type), POINTER :: B_mat, S_inv, S_minus_half CALL timeset(routineN,handle) - CALL get_rtp(rtp=rtp,S_inv=S_inv,S_minus_half=S_minus_half,exp_H_new=exp_H,dt=t,error=error) - CALL cp_dbcsr_init(matrix_ks_nosym,error=error) - CALL cp_dbcsr_create(matrix_ks_nosym,template=matrix_ks(1)%matrix,matrix_type="N",error=error) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=matrix_ks(1)%matrix,matrix_type="N",error=error) + CALL get_rtp(rtp=rtp,S_inv=S_inv,S_minus_half=S_minus_half,exp_H_new=exp_H,dt=t) + CALL cp_dbcsr_init(matrix_ks_nosym) + CALL cp_dbcsr_create(matrix_ks_nosym,template=matrix_ks(1)%matrix,matrix_type="N") + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=matrix_ks(1)%matrix,matrix_type="N") DO ispin=1,SIZE(matrix_ks) re=ispin*2-1 im=ispin*2 - CALL cp_dbcsr_desymmetrize(matrix_ks(ispin)%matrix,matrix_ks_nosym,error=error) + CALL cp_dbcsr_desymmetrize(matrix_ks(ispin)%matrix,matrix_ks_nosym) IF(rtp_control%orthonormal) THEN CALL cp_dbcsr_multiply("N","N",one,S_minus_half,matrix_ks_nosym,zero,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,tmp,S_minus_half,zero,exp_H(im)%matrix,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ELSE CALL cp_dbcsr_multiply("N","N",one,S_inv,matrix_ks_nosym,zero,exp_H(im)%matrix,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ENDIF IF(.NOT.rtp_control%fixed_ions)THEN - CALL get_rtp(rtp=rtp,SinvH=SinvH,error=error) - CALL cp_dbcsr_copy(SinvH(ispin)%matrix,exp_H(im)%matrix,error=error) + CALL get_rtp(rtp=rtp,SinvH=SinvH) + CALL cp_dbcsr_copy(SinvH(ispin)%matrix,exp_H(im)%matrix) END IF END DO IF(.NOT.rtp_control%fixed_ions.OR.rtp%do_hfx)THEN - CALL get_rtp(rtp=rtp,B_mat=B_mat,SinvB=SinvB,error=error) + CALL get_rtp(rtp=rtp,B_mat=B_mat,SinvB=SinvB) IF(rtp%do_hfx)THEN DO ispin=1,SIZE(matrix_ks) re=ispin*2-1 im=ispin*2 - CALL cp_dbcsr_set(matrix_ks_nosym,0.0_dp,error) - CALL cp_dbcsr_desymmetrize(matrix_ks_im(ispin)%matrix,matrix_ks_nosym,error=error) + CALL cp_dbcsr_set(matrix_ks_nosym,0.0_dp) + CALL cp_dbcsr_desymmetrize(matrix_ks_im(ispin)%matrix,matrix_ks_nosym) ! take care of the EMD case and add the velocity scaled S_derivative IF(.NOT.rtp_control%fixed_ions)& - CALL cp_dbcsr_add(matrix_ks_nosym,B_mat,1.0_dp,-1.0_dp,error=error) + CALL cp_dbcsr_add(matrix_ks_nosym,B_mat,1.0_dp,-1.0_dp) IF(rtp_control%orthonormal) THEN CALL cp_dbcsr_multiply("N","N",-one,S_minus_half,matrix_ks_nosym,zero,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,tmp,S_minus_half,zero,exp_H(re)%matrix,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ELSE CALL cp_dbcsr_multiply("N","N",-one,S_inv,matrix_ks_nosym,zero,exp_H(re)%matrix,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ENDIF IF(.NOT.rtp_control%fixed_ions)& - CALL cp_dbcsr_copy(SinvB(ispin)%matrix,exp_H(re)%matrix,error=error) + CALL cp_dbcsr_copy(SinvB(ispin)%matrix,exp_H(re)%matrix) END DO ELSE ! in case of pure EMD its only needed once as B is the same for both spins IF(rtp_control%orthonormal) THEN CALL cp_dbcsr_multiply("N","N",one,S_minus_half,B_mat,zero,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,tmp,S_minus_half,zero,exp_H(1)%matrix,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ELSE - CALL cp_dbcsr_multiply("N","N",one,S_inv,B_mat,zero,exp_H(1)%matrix,filter_eps=rtp%filter_eps,error=error) + CALL cp_dbcsr_multiply("N","N",one,S_inv,B_mat,zero,exp_H(1)%matrix,filter_eps=rtp%filter_eps) ENDIF - CALL cp_dbcsr_copy(SinvB(1)%matrix,exp_H(1)%matrix,error=error) + CALL cp_dbcsr_copy(SinvB(1)%matrix,exp_H(1)%matrix) - IF(SIZE(matrix_ks)==2)CALL cp_dbcsr_copy(exp_H(3)%matrix,exp_H(1)%matrix,error=error) - IF(SIZE(matrix_ks)==2)CALL cp_dbcsr_copy(SinvB(2)%matrix,SinvB(1)%matrix,error=error) + IF(SIZE(matrix_ks)==2)CALL cp_dbcsr_copy(exp_H(3)%matrix,exp_H(1)%matrix) + IF(SIZE(matrix_ks)==2)CALL cp_dbcsr_copy(SinvB(2)%matrix,SinvB(1)%matrix) END IF ELSE !set real part to zero DO ispin=1,SIZE(exp_H)/2 re=ispin*2-1 im=ispin*2 - CALL cp_dbcsr_set(exp_H(re)%matrix,zero,error=error) + CALL cp_dbcsr_set(exp_H(re)%matrix,zero) ENDDO END IF - CALL cp_dbcsr_release(matrix_ks_nosym,error) - CALL cp_dbcsr_release(tmp,error) + CALL cp_dbcsr_release(matrix_ks_nosym) + CALL cp_dbcsr_release(tmp) CALL timestop(handle) END SUBROUTINE calc_SinvH @@ -505,16 +495,14 @@ END SUBROUTINE calc_SinvH !> depending on the way the exponential is calculated, only S^-1 is needed !> \param s_mat ... !> \param rtp ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE s_matrices_create (s_mat,rtp,error) + SUBROUTINE s_matrices_create (s_mat,rtp) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: s_mat TYPE(rt_prop_type), POINTER :: rtp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 's_matrices_create', & routineP = moduleN//':'//routineN @@ -525,20 +513,20 @@ SUBROUTINE s_matrices_create (s_mat,rtp,error) CALL timeset(routineN,handle) - CALL get_rtp(rtp=rtp,S_inv=S_inv,error=error) + CALL get_rtp(rtp=rtp,S_inv=S_inv) IF(rtp%linear_scaling) THEN - CALL get_rtp(rtp=rtp,S_half=S_half,S_minus_half=S_minus_half,error=error) + CALL get_rtp(rtp=rtp,S_half=S_half,S_minus_half=S_minus_half) CALL matrix_sqrt_Newton_Schulz(S_half,S_minus_half,s_mat(1)%matrix,rtp%filter_eps,& - rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter,error=error) + rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter) CALL cp_dbcsr_multiply("N","N",one,S_minus_half,S_minus_half,zero,S_inv,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ELSE - CALL cp_dbcsr_copy(S_inv,s_mat(1)%matrix,error=error) + CALL cp_dbcsr_copy(S_inv,s_mat(1)%matrix) CALL cp_dbcsr_cholesky_decompose(S_inv,para_env=rtp%ao_ao_fmstruct%para_env,& - blacs_env=rtp%ao_ao_fmstruct%context,error=error) + blacs_env=rtp%ao_ao_fmstruct%context) CALL cp_dbcsr_cholesky_invert(S_inv,para_env=rtp%ao_ao_fmstruct%para_env,& - blacs_env=rtp%ao_ao_fmstruct%context,upper_to_full=.TRUE.,error=error) + blacs_env=rtp%ao_ao_fmstruct%context,upper_to_full=.TRUE.) ENDIF CALL timestop(handle) @@ -549,15 +537,13 @@ END SUBROUTINE s_matrices_create !> \param frob_norm ... !> \param mat_re ... !> \param mat_im ... -!> \param error ... !> \author Samuel Andermatt (04.14) ! ***************************************************************************** - SUBROUTINE complex_frobenius_norm(frob_norm,mat_re,mat_im,error) + SUBROUTINE complex_frobenius_norm(frob_norm,mat_re,mat_im) REAL(KIND=dp), INTENT(out) :: frob_norm TYPE(cp_dbcsr_type), POINTER :: mat_re, mat_im - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'complex_frobenius_norm', & routineP = moduleN//':'//routineN @@ -574,12 +560,12 @@ SUBROUTINE complex_frobenius_norm(frob_norm,mat_re,mat_im,error) NULLIFY(tmp) ALLOCATE(tmp) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=mat_re,error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=mat_re) !make sure the tmp has the same sparsity pattern as the real and the complex part combined - CALL cp_dbcsr_add(tmp,mat_re,zero,one,error=error) - CALL cp_dbcsr_add(tmp,mat_im,zero,one,error=error) - CALL cp_dbcsr_set(tmp,zero,error=error) + CALL cp_dbcsr_add(tmp,mat_re,zero,one) + CALL cp_dbcsr_add(tmp,mat_im,zero,one) + CALL cp_dbcsr_set(tmp,zero) !calculate the hadamard product CALL cp_dbcsr_iterator_start(iter, tmp) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) @@ -597,7 +583,7 @@ SUBROUTINE complex_frobenius_norm(frob_norm,mat_re,mat_im,error) CALL cp_dbcsr_iterator_stop (iter) frob_norm=cp_dbcsr_frobenius_norm(tmp) - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp) CALL timestop(handle) @@ -611,18 +597,16 @@ END SUBROUTINE complex_frobenius_norm !> \param eps_small ... !> \param max_iter ... !> \param threshold ... -!> \param error ... !> \author Samuel Andermatt (04.14) ! ***************************************************************************** - SUBROUTINE purify_mcweeny_complex_nonorth(P,s_mat,eps,eps_small,max_iter,threshold,error) + SUBROUTINE purify_mcweeny_complex_nonorth(P,s_mat,eps,eps_small,max_iter,threshold) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: P, s_mat REAL(KIND=dp), INTENT(in) :: eps, eps_small INTEGER, INTENT(in) :: max_iter REAL(KIND=dp), INTENT(in) :: threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'purify_mcweeny_complex_nonorth', & @@ -638,7 +622,7 @@ SUBROUTINE purify_mcweeny_complex_nonorth(P,s_mat,eps,eps_small,max_iter,thresho CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -646,20 +630,20 @@ SUBROUTINE purify_mcweeny_complex_nonorth(P,s_mat,eps,eps_small,max_iter,thresho ENDIF NULLIFY(tmp,PS,PSP) - CALL cp_dbcsr_allocate_matrix_set(tmp,SIZE(P),error=error) - CALL cp_dbcsr_allocate_matrix_set(PSP,SIZE(P),error=error) - CALL cp_dbcsr_allocate_matrix_set(PS,SIZE(P),error=error) + CALL cp_dbcsr_allocate_matrix_set(tmp,SIZE(P)) + CALL cp_dbcsr_allocate_matrix_set(PSP,SIZE(P)) + CALL cp_dbcsr_allocate_matrix_set(PS,SIZE(P)) DO i=1,SIZE(P) - CALL cp_dbcsr_init_p(PS(i)%matrix,error=error) - CALL cp_dbcsr_create(PS(i)%matrix,template=P(1)%matrix,error=error) - CALL cp_dbcsr_init_p(PSP(i)%matrix,error=error) - CALL cp_dbcsr_create(PSP(i)%matrix,template=P(1)%matrix,error=error) - CALL cp_dbcsr_init_p(tmp(i)%matrix,error=error) - CALL cp_dbcsr_create(tmp(i)%matrix,template=P(1)%matrix,error=error) + CALL cp_dbcsr_init_p(PS(i)%matrix) + CALL cp_dbcsr_create(PS(i)%matrix,template=P(1)%matrix) + CALL cp_dbcsr_init_p(PSP(i)%matrix) + CALL cp_dbcsr_create(PSP(i)%matrix,template=P(1)%matrix) + CALL cp_dbcsr_init_p(tmp(i)%matrix) + CALL cp_dbcsr_create(tmp(i)%matrix,template=P(1)%matrix) ENDDO IF(SIZE(P)==2) THEN - CALL cp_dbcsr_scale(P(1)%matrix,one/2,error=error) - CALL cp_dbcsr_scale(P(2)%matrix,one/2,error=error) + CALL cp_dbcsr_scale(P(1)%matrix,one/2) + CALL cp_dbcsr_scale(P(2)%matrix,one/2) ENDIF DO ispin=1,SIZE(P)/2 re=2*ispin-1 @@ -667,48 +651,48 @@ SUBROUTINE purify_mcweeny_complex_nonorth(P,s_mat,eps,eps_small,max_iter,thresho imax=MAX(max_iter,1) !if max_iter is 0 then only the deviation from idempotency needs to be calculated DO i=1,imax CALL cp_dbcsr_multiply("N", "N", one, P(re)%matrix,s_mat(1)%matrix,& - zero, PS(re)%matrix, filter_eps=eps_small,error=error) + zero, PS(re)%matrix, filter_eps=eps_small) CALL cp_dbcsr_multiply("N", "N", one, P(im)%matrix,s_mat(1)%matrix,& - zero, PS(im)%matrix, filter_eps=eps_small,error=error) + zero, PS(im)%matrix, filter_eps=eps_small) CALL cp_complex_dbcsr_gemm_3("N","N",one,PS(re)%matrix,PS(im)%matrix,& P(re)%matrix,P(im)%matrix,zero,PSP(re)%matrix,PSP(im)%matrix,& - filter_eps=eps_small,error=error) - CALL cp_dbcsr_copy(tmp(re)%matrix,PSP(re)%matrix,error=error) - CALL cp_dbcsr_copy(tmp(im)%matrix,PSP(im)%matrix,error=error) - CALL cp_dbcsr_add(tmp(re)%matrix,P(re)%matrix,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_add(tmp(im)%matrix,P(im)%matrix,1.0_dp,-1.0_dp,error=error) - CALL complex_frobenius_norm(frob_norm,tmp(re)%matrix,tmp(im)%matrix,error=error) + filter_eps=eps_small) + CALL cp_dbcsr_copy(tmp(re)%matrix,PSP(re)%matrix) + CALL cp_dbcsr_copy(tmp(im)%matrix,PSP(im)%matrix) + CALL cp_dbcsr_add(tmp(re)%matrix,P(re)%matrix,1.0_dp,-1.0_dp) + CALL cp_dbcsr_add(tmp(im)%matrix,P(im)%matrix,1.0_dp,-1.0_dp) + CALL complex_frobenius_norm(frob_norm,tmp(re)%matrix,tmp(im)%matrix) IF(unit_nr.gt.0) WRITE(unit_nr,'(t3,a,2f16.8)')"Deviation from idempotency: ",frob_norm IF(frob_norm.GT.threshold.AND.max_iter>0)THEN - CALL cp_dbcsr_copy(P(re)%matrix,PSP(re)%matrix,error=error) - CALL cp_dbcsr_copy(P(im)%matrix,PSP(im)%matrix,error=error) + CALL cp_dbcsr_copy(P(re)%matrix,PSP(re)%matrix) + CALL cp_dbcsr_copy(P(im)%matrix,PSP(im)%matrix) CALL cp_complex_dbcsr_gemm_3("N", "N", -2.0_dp, PS(re)%matrix,PS(im)%matrix,& PSP(re)%matrix,PSP(im)%matrix,3.0_dp,P(re)%matrix,P(im)%matrix,& - filter_eps=eps_small,error=error) - CALL cp_dbcsr_filter(P(re)%matrix,eps,error=error) - CALL cp_dbcsr_filter(P(im)%matrix,eps,error=error) + filter_eps=eps_small) + CALL cp_dbcsr_filter(P(re)%matrix,eps) + CALL cp_dbcsr_filter(P(im)%matrix,eps) !make sure P is exactly hermitian - CALL cp_dbcsr_transposed(tmp(re)%matrix,P(re)%matrix,error=error) - CALL cp_dbcsr_add(P(re)%matrix,tmp(re)%matrix,one/2,one/2,error=error) - CALL cp_dbcsr_transposed(tmp(im)%matrix,P(im)%matrix,error=error) - CALL cp_dbcsr_add(P(im)%matrix,tmp(im)%matrix,one/2,-one/2,error=error) + CALL cp_dbcsr_transposed(tmp(re)%matrix,P(re)%matrix) + CALL cp_dbcsr_add(P(re)%matrix,tmp(re)%matrix,one/2,one/2) + CALL cp_dbcsr_transposed(tmp(im)%matrix,P(im)%matrix) + CALL cp_dbcsr_add(P(im)%matrix,tmp(im)%matrix,one/2,-one/2) ELSE EXIT END IF END DO !make sure P is hermitian - CALL cp_dbcsr_transposed(tmp(re)%matrix,P(re)%matrix,error=error) - CALL cp_dbcsr_add(P(re)%matrix,tmp(re)%matrix,one/2,one/2,error=error) - CALL cp_dbcsr_transposed(tmp(im)%matrix,P(im)%matrix,error=error) - CALL cp_dbcsr_add(P(im)%matrix,tmp(im)%matrix,one/2,-one/2,error=error) + CALL cp_dbcsr_transposed(tmp(re)%matrix,P(re)%matrix) + CALL cp_dbcsr_add(P(re)%matrix,tmp(re)%matrix,one/2,one/2) + CALL cp_dbcsr_transposed(tmp(im)%matrix,P(im)%matrix) + CALL cp_dbcsr_add(P(im)%matrix,tmp(im)%matrix,one/2,-one/2) END DO IF(SIZE(P)==2) THEN - CALL cp_dbcsr_scale(P(1)%matrix,one*2,error=error) - CALL cp_dbcsr_scale(P(2)%matrix,one*2,error=error) + CALL cp_dbcsr_scale(P(1)%matrix,one*2) + CALL cp_dbcsr_scale(P(2)%matrix,one*2) ENDIF - CALL cp_dbcsr_deallocate_matrix_set(tmp,error) - CALL cp_dbcsr_deallocate_matrix_set(PS,error) - CALL cp_dbcsr_deallocate_matrix_set(PSP,error) + CALL cp_dbcsr_deallocate_matrix_set(tmp) + CALL cp_dbcsr_deallocate_matrix_set(PS) + CALL cp_dbcsr_deallocate_matrix_set(PSP) CALL timestop(handle) @@ -721,18 +705,16 @@ END SUBROUTINE purify_mcweeny_complex_nonorth !> \param eps_small ... !> \param max_iter ... !> \param threshold ... -!> \param error ... !> \author Samuel Andermatt (04.14) ! ***************************************************************************** - SUBROUTINE purify_mcweeny_complex_orth(P,eps,eps_small,max_iter,threshold,error) + SUBROUTINE purify_mcweeny_complex_orth(P,eps,eps_small,max_iter,threshold) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: P REAL(KIND=dp), INTENT(in) :: eps, eps_small INTEGER, INTENT(in) :: max_iter REAL(KIND=dp), INTENT(in) :: threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'purify_mcweeny_complex_orth', & routineP = moduleN//':'//routineN @@ -747,7 +729,7 @@ SUBROUTINE purify_mcweeny_complex_orth(P,eps,eps_small,max_iter,threshold,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -755,17 +737,17 @@ SUBROUTINE purify_mcweeny_complex_orth(P,eps,eps_small,max_iter,threshold,error) ENDIF NULLIFY(tmp,PP) - CALL cp_dbcsr_allocate_matrix_set(tmp,SIZE(P),error=error) - CALL cp_dbcsr_allocate_matrix_set(PP,SIZE(P),error=error) + CALL cp_dbcsr_allocate_matrix_set(tmp,SIZE(P)) + CALL cp_dbcsr_allocate_matrix_set(PP,SIZE(P)) DO i=1,SIZE(P) - CALL cp_dbcsr_init_p(PP(i)%matrix,error=error) - CALL cp_dbcsr_create(PP(i)%matrix,template=P(1)%matrix,error=error) - CALL cp_dbcsr_init_p(tmp(i)%matrix,error=error) - CALL cp_dbcsr_create(tmp(i)%matrix,template=P(1)%matrix,error=error) + CALL cp_dbcsr_init_p(PP(i)%matrix) + CALL cp_dbcsr_create(PP(i)%matrix,template=P(1)%matrix) + CALL cp_dbcsr_init_p(tmp(i)%matrix) + CALL cp_dbcsr_create(tmp(i)%matrix,template=P(1)%matrix) ENDDO IF(SIZE(P)==2) THEN - CALL cp_dbcsr_scale(P(1)%matrix,one/2,error=error) - CALL cp_dbcsr_scale(P(2)%matrix,one/2,error=error) + CALL cp_dbcsr_scale(P(1)%matrix,one/2) + CALL cp_dbcsr_scale(P(2)%matrix,one/2) ENDIF DO ispin=1,SIZE(P)/2 re=2*ispin-1 @@ -774,39 +756,39 @@ SUBROUTINE purify_mcweeny_complex_orth(P,eps,eps_small,max_iter,threshold,error) DO i=1,imax CALL cp_complex_dbcsr_gemm_3("N","N",one,P(re)%matrix,P(im)%matrix,& P(re)%matrix,P(im)%matrix,zero,PP(re)%matrix,PP(im)%matrix,& - filter_eps=eps_small,error=error) - CALL cp_dbcsr_copy(tmp(re)%matrix,PP(re)%matrix,error=error) - CALL cp_dbcsr_copy(tmp(im)%matrix,PP(im)%matrix,error=error) - CALL cp_dbcsr_add(tmp(re)%matrix,P(re)%matrix,1.0_dp,-1.0_dp,error=error) - CALL cp_dbcsr_add(tmp(im)%matrix,P(im)%matrix,1.0_dp,-1.0_dp,error=error) - CALL complex_frobenius_norm(frob_norm,tmp(re)%matrix,tmp(im)%matrix,error=error) + filter_eps=eps_small) + CALL cp_dbcsr_copy(tmp(re)%matrix,PP(re)%matrix) + CALL cp_dbcsr_copy(tmp(im)%matrix,PP(im)%matrix) + CALL cp_dbcsr_add(tmp(re)%matrix,P(re)%matrix,1.0_dp,-1.0_dp) + CALL cp_dbcsr_add(tmp(im)%matrix,P(im)%matrix,1.0_dp,-1.0_dp) + CALL complex_frobenius_norm(frob_norm,tmp(re)%matrix,tmp(im)%matrix) IF(unit_nr.gt.0) WRITE(unit_nr,'(t3,a,2f16.8)')"Deviation from idempotency: ",frob_norm IF(frob_norm.GT.threshold.AND.max_iter>0)THEN - CALL cp_dbcsr_copy(tmp(re)%matrix,P(re)%matrix,error=error) - CALL cp_dbcsr_copy(tmp(im)%matrix,P(im)%matrix,error=error) - CALL cp_dbcsr_copy(P(re)%matrix,PP(re)%matrix,error=error) - CALL cp_dbcsr_copy(P(im)%matrix,PP(im)%matrix,error=error) + CALL cp_dbcsr_copy(tmp(re)%matrix,P(re)%matrix) + CALL cp_dbcsr_copy(tmp(im)%matrix,P(im)%matrix) + CALL cp_dbcsr_copy(P(re)%matrix,PP(re)%matrix) + CALL cp_dbcsr_copy(P(im)%matrix,PP(im)%matrix) CALL cp_complex_dbcsr_gemm_3("N", "N", -2.0_dp, tmp(re)%matrix,tmp(im)%matrix,& PP(re)%matrix,PP(im)%matrix,3.0_dp,P(re)%matrix,P(im)%matrix,& - filter_eps=eps_small,error=error) - CALL cp_dbcsr_filter(P(re)%matrix,eps,error=error) - CALL cp_dbcsr_filter(P(im)%matrix,eps,error=error) + filter_eps=eps_small) + CALL cp_dbcsr_filter(P(re)%matrix,eps) + CALL cp_dbcsr_filter(P(im)%matrix,eps) !make sure P is exactly hermitian - CALL cp_dbcsr_transposed(tmp(re)%matrix,P(re)%matrix,error=error) - CALL cp_dbcsr_add(P(re)%matrix,tmp(re)%matrix,one/2,one/2,error=error) - CALL cp_dbcsr_transposed(tmp(im)%matrix,P(im)%matrix,error=error) - CALL cp_dbcsr_add(P(im)%matrix,tmp(im)%matrix,one/2,-one/2,error=error) + CALL cp_dbcsr_transposed(tmp(re)%matrix,P(re)%matrix) + CALL cp_dbcsr_add(P(re)%matrix,tmp(re)%matrix,one/2,one/2) + CALL cp_dbcsr_transposed(tmp(im)%matrix,P(im)%matrix) + CALL cp_dbcsr_add(P(im)%matrix,tmp(im)%matrix,one/2,-one/2) ELSE EXIT END IF END DO END DO IF(SIZE(P)==2) THEN - CALL cp_dbcsr_scale(P(1)%matrix,one*2,error=error) - CALL cp_dbcsr_scale(P(2)%matrix,one*2,error=error) + CALL cp_dbcsr_scale(P(1)%matrix,one*2) + CALL cp_dbcsr_scale(P(2)%matrix,one*2) ENDIF - CALL cp_dbcsr_deallocate_matrix_set(tmp,error) - CALL cp_dbcsr_deallocate_matrix_set(PP,error) + CALL cp_dbcsr_deallocate_matrix_set(tmp) + CALL cp_dbcsr_deallocate_matrix_set(PP) CALL timestop(handle) @@ -817,14 +799,12 @@ END SUBROUTINE purify_mcweeny_complex_orth !> \param rtp ... !> \param matrix_s ... !> \param aspc_order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order,error) + SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_s INTEGER, INTENT(in) :: aspc_order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'aspc_extrapolate', & routineP = moduleN//':'//routineN @@ -854,9 +834,9 @@ SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order,error) CALL cite_reference(Kolafa2004) IF(rtp%linear_scaling) THEN - CALL get_rtp(rtp=rtp,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_new=rho_new) ELSE - CALL get_rtp(rtp=rtp,mos_new=mos_new,error=error) + CALL get_rtp(rtp=rtp,mos_new=mos_new) ENDIF naspc=MIN(rtp%istep,aspc_order) @@ -869,9 +849,9 @@ SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order,error) binomial(2*naspc,naspc - iaspc)/binomial(2*naspc - 2,naspc -1) ihist=MOD(rtp%istep-iaspc,aspc_order)+1 IF(iaspc==1)THEN - CALL cp_dbcsr_add(rho_new(imat)%matrix,rho_hist(imat,ihist)%matrix,zero,alpha,error) + CALL cp_dbcsr_add(rho_new(imat)%matrix,rho_hist(imat,ihist)%matrix,zero,alpha) ELSE - CALL cp_dbcsr_add(rho_new(imat)%matrix,rho_hist(imat,ihist)%matrix,one,alpha,error) + CALL cp_dbcsr_add(rho_new(imat)%matrix,rho_hist(imat,ihist)%matrix,one,alpha) END IF END DO END DO @@ -884,9 +864,9 @@ SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order,error) binomial(2*naspc,naspc - iaspc)/binomial(2*naspc - 2,naspc -1) ihist=MOD(rtp%istep-iaspc,aspc_order)+1 IF(iaspc==1)THEN - CALL cp_fm_scale_and_add(zero,mos_new(imat)%matrix,alpha,mo_hist(imat,ihist)%matrix,error) + CALL cp_fm_scale_and_add(zero,mos_new(imat)%matrix,alpha,mo_hist(imat,ihist)%matrix) ELSE - CALL cp_fm_scale_and_add(one,mos_new(imat)%matrix,alpha,mo_hist(imat,ihist)%matrix,error) + CALL cp_fm_scale_and_add(one,mos_new(imat)%matrix,alpha,mo_hist(imat,ihist)%matrix) END IF END DO END DO @@ -901,33 +881,31 @@ SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order,error) CALL cp_fm_struct_double(matrix_struct,& mos_new(2*i)%matrix%matrix_struct,& mos_new(2*i)%matrix%matrix_struct%context,& - .TRUE.,.FALSE.,error) + .TRUE.,.FALSE.) - CALL cp_fm_create(fm_tmp,matrix_struct,error=error) - CALL cp_fm_create(fm_tmp1,matrix_struct,error=error) - CALL cp_fm_create(fm_tmp2,mos_new(2*i)%matrix%matrix_struct,error=error) - CALL cp_cfm_create(cfm_tmp,mos_new(2*i)%matrix%matrix_struct,error=error) - CALL cp_cfm_create(cfm_tmp1,mos_new(2*i)%matrix%matrix_struct,error=error) + CALL cp_fm_create(fm_tmp,matrix_struct) + CALL cp_fm_create(fm_tmp1,matrix_struct) + CALL cp_fm_create(fm_tmp2,mos_new(2*i)%matrix%matrix_struct) + CALL cp_cfm_create(cfm_tmp,mos_new(2*i)%matrix%matrix_struct) + CALL cp_cfm_create(cfm_tmp1,mos_new(2*i)%matrix%matrix_struct) CALL cp_fm_get_info(fm_tmp,& - ncol_global=kdbl,& - error=error) + ncol_global=kdbl) CALL cp_fm_get_info(mos_new(2*i)%matrix,& nrow_global=n,& ncol_global=k,& - ncol_local=ncol_local,& - error=error) + ncol_local=ncol_local) CALL cp_fm_struct_create(matrix_struct_new,& template_fmstruct=matrix_struct,& nrow_global=k,& - ncol_global=k,error=error) - CALL cp_cfm_create(csc,matrix_struct_new,error=error) + ncol_global=k) + CALL cp_cfm_create(csc,matrix_struct_new) - CALL cp_fm_struct_release(matrix_struct_new,error=error) - CALL cp_fm_struct_release(matrix_struct,error=error) + CALL cp_fm_struct_release(matrix_struct_new) + CALL cp_fm_struct_release(matrix_struct) ! first the most recent @@ -939,7 +917,7 @@ SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order,error) fm_tmp%local_data(:,icol_local+ncol_local)=mos_new(2*i)%matrix%local_data(:,icol_local) END DO - CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,fm_tmp,fm_tmp1,kdbl,error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,fm_tmp,fm_tmp1,kdbl) DO icol_local=1,ncol_local cfm_tmp%local_data(:,icol_local)=CMPLX(fm_tmp1%local_data(:,icol_local),& @@ -947,22 +925,22 @@ SUBROUTINE aspc_extrapolate(rtp,matrix_s,aspc_order,error) cfm_tmp1%local_data(:,icol_local)=CMPLX(mos_new(2*i-1)%matrix%local_data(:,icol_local),& mos_new(2*i)%matrix%local_data(:,icol_local),dp) END DO - CALL cp_cfm_gemm('C','N',k,k,n,cone,cfm_tmp1,cfm_tmp,czero,csc,error=error) - CALL cp_cfm_cholesky_decompose(csc,error=error) - CALL cp_cfm_triangular_multiply(csc,cfm_tmp1,n_cols=k,side='R',invert_tr=.TRUE.,error=error) + CALL cp_cfm_gemm('C','N',k,k,n,cone,cfm_tmp1,cfm_tmp,czero,csc) + CALL cp_cfm_cholesky_decompose(csc) + CALL cp_cfm_triangular_multiply(csc,cfm_tmp1,n_cols=k,side='R',invert_tr=.TRUE.) DO icol_local=1,ncol_local mos_new(2*i-1)%matrix%local_data(:,icol_local)=REAL(cfm_tmp1%local_data(:,icol_local),dp) mos_new(2*i)%matrix%local_data(:,icol_local)=AIMAG(cfm_tmp1%local_data(:,icol_local)) END DO ! deallocate work matrices - CALL cp_cfm_release(csc,error=error) - CALL cp_fm_release(fm_tmp,error=error) - CALL cp_fm_release(fm_tmp,error) - CALL cp_fm_release(fm_tmp1,error) - CALL cp_fm_release(fm_tmp2,error) - CALL cp_cfm_release(cfm_tmp,error) - CALL cp_cfm_release(cfm_tmp1,error) + CALL cp_cfm_release(csc) + CALL cp_fm_release(fm_tmp) + CALL cp_fm_release(fm_tmp) + CALL cp_fm_release(fm_tmp1) + CALL cp_fm_release(fm_tmp2) + CALL cp_cfm_release(cfm_tmp) + CALL cp_cfm_release(cfm_tmp1) END DO END IF @@ -978,9 +956,8 @@ END SUBROUTINE aspc_extrapolate !> \param rho ... !> \param s_mat ... !> \param ihist ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE put_data_to_history(rtp,mos,rho,s_mat,ihist,error) + SUBROUTINE put_data_to_history(rtp,mos,rho,s_mat,ihist) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mos @@ -989,7 +966,6 @@ SUBROUTINE put_data_to_history(rtp,mos,rho,s_mat,ihist,error) TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: s_mat INTEGER :: ihist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'put_data_to_history', & routineP = moduleN//':'//routineN @@ -998,20 +974,20 @@ SUBROUTINE put_data_to_history(rtp,mos,rho,s_mat,ihist,error) IF(rtp%linear_scaling) THEN DO i=1,SIZE(rho) - CALL cp_dbcsr_copy(rtp%history%rho_history(i,ihist)%matrix,rho(i)%matrix,error=error) + CALL cp_dbcsr_copy(rtp%history%rho_history(i,ihist)%matrix,rho(i)%matrix) END DO ELSE DO i=1,SIZE(mos) - CALL cp_fm_to_fm(mos(i)%matrix,rtp%history%mo_history(i,ihist)%matrix,error) + CALL cp_fm_to_fm(mos(i)%matrix,rtp%history%mo_history(i,ihist)%matrix) END DO IF(PRESENT(s_mat))THEN IF (ASSOCIATED(rtp%history%s_history(ihist)%matrix)) THEN ! the sparsity might be different ! (future struct:check) - CALL cp_dbcsr_deallocate_matrix(rtp%history%s_history(ihist)%matrix,error=error) + CALL cp_dbcsr_deallocate_matrix(rtp%history%s_history(ihist)%matrix) END IF ALLOCATE(rtp%history%s_history(ihist)%matrix) - CALL cp_dbcsr_init(rtp%history%s_history(ihist)%matrix,error=error) - CALL cp_dbcsr_copy(rtp%history%s_history(ihist)%matrix,s_mat(1)%matrix,error=error) + CALL cp_dbcsr_init(rtp%history%s_history(ihist)%matrix) + CALL cp_dbcsr_copy(rtp%history%s_history(ihist)%matrix,s_mat(1)%matrix) END IF END IF diff --git a/src/emd/rt_propagation_output.F b/src/emd/rt_propagation_output.F index c98a3a8378..21ace092df 100644 --- a/src/emd/rt_propagation_output.F +++ b/src/emd/rt_propagation_output.F @@ -107,13 +107,11 @@ MODULE rt_propagation_output !> \param run_type ... !> \param delta_iter ... !> \param used_time ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rt_prop_output(qs_env,run_type,delta_iter,used_time,error) + SUBROUTINE rt_prop_output(qs_env,run_type,delta_iter,used_time) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(in) :: run_type REAL(dp), INTENT(in), OPTIONAL :: delta_iter, used_time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_prop_output', & routineP = moduleN//':'//routineN @@ -141,7 +139,7 @@ SUBROUTINE rt_prop_output(qs_env,run_type,delta_iter,used_time,error) NULLIFY(logger, dft_control) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env,& rtp=rtp,& matrix_s=matrix_s,& @@ -150,20 +148,19 @@ SUBROUTINE rt_prop_output(qs_env,run_type,delta_iter,used_time,error) particle_set=particle_set,& atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - rtp_section => section_vals_get_subs_vals(input,"DFT%REAL_TIME_PROPAGATION",error=error) + rtp_section => section_vals_get_subs_vals(input,"DFT%REAL_TIME_PROPAGATION") - CALL get_qs_kind_set(qs_kind_set, nelectron=n_electrons, error=error) + CALL get_qs_kind_set(qs_kind_set, nelectron=n_electrons) n_electrons = n_electrons - dft_control%charge - CALL qs_rho_get(rho_struct=rho,tot_rho_r=qs_tot_rho_r,error=error) + CALL qs_rho_get(rho_struct=rho,tot_rho_r=qs_tot_rho_r) tot_rho_r = accurate_sum(qs_tot_rho_r) output_unit=cp_print_key_unit_nr(logger,rtp_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF(output_unit>0) THEN @@ -196,9 +193,9 @@ SUBROUTINE rt_prop_output(qs_env,run_type,delta_iter,used_time,error) IF(rtp%converged) THEN IF(.NOT.rtp%linear_scaling) THEN - CALL get_rtp(rtp=rtp,mos_new=mos_new,error=error) + CALL get_rtp(rtp=rtp,mos_new=mos_new) CALL rt_calculate_orthonormality(orthonormality,& - mos_new,matrix_s(1)%matrix,error) + mos_new,matrix_s(1)%matrix) IF(output_unit>0)& WRITE(output_unit,FMT="(/,(T3,A,T60,F20.10))")& "Max deviation from orthonormalization:",orthonormality @@ -208,49 +205,49 @@ SUBROUTINE rt_prop_output(qs_env,run_type,delta_iter,used_time,error) IF(output_unit>0)& CALL m_flush(output_unit) CALL cp_print_key_finished_output(output_unit,logger,rtp_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") IF(rtp%converged)THEN - CALL make_moment(qs_env,error) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + CALL make_moment(qs_env) + dft_section => section_vals_get_subs_vals(input,"DFT") IF (rtp%linear_scaling) THEN - CALL get_rtp(rtp=rtp,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_new=rho_new) IF(BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,"REAL_TIME_PROPAGATION%PRINT%RESTART",error=error),cp_p_file)) THEN - CALL write_rt_p_to_restart(rho_new,error) + dft_section,"REAL_TIME_PROPAGATION%PRINT%RESTART"),cp_p_file)) THEN + CALL write_rt_p_to_restart(rho_new) ENDIF IF(.NOT.dft_control%qs_control%dftb) THEN !Not sure if these things could also work with dftb or not - CALL write_mo_free_results(qs_env,error) + CALL write_mo_free_results(qs_env) IF(BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT",error=error),cp_p_file)) THEN + dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT"),cp_p_file)) THEN DO spin=1,SIZE(rho_new)/2 - CALL rt_current(qs_env,rho_new(2*spin)%matrix,dft_section,spin,error) + CALL rt_current(qs_env,rho_new(2*spin)%matrix,dft_section,spin) END DO ENDIF ENDIF ELSE - CALL get_rtp(rtp=rtp,mos_new=mos_new,error=error) + CALL get_rtp(rtp=rtp,mos_new=mos_new) IF(.NOT.dft_control%qs_control%dftb) THEN - CALL write_available_results(qs_env=qs_env,error=error) + CALL write_available_results(qs_env=qs_env) IF(BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT",error=error),cp_p_file)) THEN + dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT"),cp_p_file)) THEN NULLIFY(P_im) nspin=SIZE(mos_new)/2 - CALL cp_dbcsr_allocate_matrix_set(P_im,nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(P_im,nspin) DO spin=1,nspin - CALL cp_dbcsr_init_p(P_im(spin)%matrix,error=error) - CALL cp_dbcsr_create(P_im(spin)%matrix,template=matrix_s(1)%matrix,matrix_type="N",error=error) + CALL cp_dbcsr_init_p(P_im(spin)%matrix) + CALL cp_dbcsr_create(P_im(spin)%matrix,template=matrix_s(1)%matrix,matrix_type="N") END DO - CALL calculate_P_imaginary(rtp,P_im,error=error) + CALL calculate_P_imaginary(rtp,P_im) DO spin=1,nspin - CALL rt_current(qs_env,P_im(spin)%matrix,dft_section,spin,error) + CALL rt_current(qs_env,P_im(spin)%matrix,dft_section,spin) END DO - CALL cp_dbcsr_deallocate_matrix_set(P_im,error=error) + CALL cp_dbcsr_deallocate_matrix_set(P_im) ENDIF ENDIF CALL write_rt_mos_to_restart(qs_env%mos,mos_new,particle_set,& - dft_section,qs_kind_set,error) + dft_section,qs_kind_set) ENDIF ENDIF @@ -258,8 +255,7 @@ SUBROUTINE rt_prop_output(qs_env,run_type,delta_iter,used_time,error) CALL cp_assert(rtp%converged.OR.rtp%iter \param orthonormality ... !> \param mos_new ... !> \param matrix_s ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE rt_calculate_orthonormality(orthonormality,mos_new,matrix_s,error) + SUBROUTINE rt_calculate_orthonormality(orthonormality,mos_new,matrix_s) REAL(KIND=dp), INTENT(out) :: orthonormality TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mos_new TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_calculate_orthonormality', & routineP = moduleN//':'//routineN @@ -303,33 +297,33 @@ SUBROUTINE rt_calculate_orthonormality(orthonormality,mos_new,matrix_s,error) re=ispin*2-1 im=ispin*2 ! get S*C - CALL cp_fm_create(svec_re,mos_new(im)%matrix%matrix_struct,error=error) - CALL cp_fm_create(svec_im,mos_new(im)%matrix%matrix_struct,error=error) + CALL cp_fm_create(svec_re,mos_new(im)%matrix%matrix_struct) + CALL cp_fm_create(svec_im,mos_new(im)%matrix%matrix_struct) CALL cp_fm_get_info(mos_new(im)%matrix,& - nrow_global=n,ncol_global=k,error=error) + nrow_global=n,ncol_global=k) CALL cp_dbcsr_sm_fm_multiply(matrix_s,mos_new(re)%matrix,& - svec_re,k,error=error) + svec_re,k) CALL cp_dbcsr_sm_fm_multiply(matrix_s,mos_new(im)%matrix,& - svec_im,k,error=error) + svec_im,k) ! get C^T (S*C) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=k,ncol_global=k, & para_env=mos_new(re)%matrix%matrix_struct%para_env, & - context=mos_new(re)%matrix%matrix_struct%context,error=error) - CALL cp_fm_create(overlap_re,tmp_fm_struct,error=error) + context=mos_new(re)%matrix%matrix_struct%context) + CALL cp_fm_create(overlap_re,tmp_fm_struct) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_fm_struct_release(tmp_fm_struct) CALL cp_gemm('T','N',k,k,n,1.0_dp, mos_new(re)%matrix,& - svec_re,0.0_dp,overlap_re,error=error) + svec_re,0.0_dp,overlap_re) CALL cp_gemm('T','N',k,k,n,1.0_dp, mos_new(im)%matrix,& - svec_im,1.0_dp,overlap_re,error=error) + svec_im,1.0_dp,overlap_re) - CALL cp_fm_release(svec_re,error=error) - CALL cp_fm_release(svec_im,error=error) + CALL cp_fm_release(svec_re) + CALL cp_fm_release(svec_im) CALL cp_fm_get_info(overlap_re,nrow_local=nrow_local,ncol_local=ncol_local, & - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) DO i=1,nrow_local DO j=1,ncol_local alpha=overlap_re%local_data(i,j) @@ -337,7 +331,7 @@ SUBROUTINE rt_calculate_orthonormality(orthonormality,mos_new,matrix_s,error) max_alpha=MAX(max_alpha,ABS(alpha)) ENDDO ENDDO - CALL cp_fm_release(overlap_re,error=error) + CALL cp_fm_release(overlap_re) ENDDO CALL mp_max(max_alpha,mos_new(1)%matrix%matrix_struct%para_env%group) CALL mp_max(max_beta,mos_new(1)%matrix%matrix_struct%para_env%group) @@ -353,18 +347,16 @@ END SUBROUTINE rt_calculate_orthonormality !> \param matrix_s Overlap matrix without the derivatives !> \param delta_mos ... !> \param delta_eps ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE rt_convergence(rtp,matrix_s,delta_mos,delta_eps,error) + SUBROUTINE rt_convergence(rtp,matrix_s,delta_mos,delta_eps) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_type), POINTER :: matrix_s TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: delta_mos REAL(dp), INTENT(out) :: delta_eps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_convergence', & routineP = moduleN//':'//routineN @@ -385,13 +377,13 @@ SUBROUTINE rt_convergence(rtp,matrix_s,delta_mos,delta_eps,error) CALL timeset(routineN,handle) - CALL get_rtp(rtp=rtp,mos_new=mos_new,error=error) + CALL get_rtp(rtp=rtp,mos_new=mos_new) nspin=SIZE(delta_mos)/2 max_alpha=0.0_dp DO i=1,SIZE(mos_new) - CALL cp_fm_scale_and_add(-one,delta_mos(i)%matrix,one,mos_new(i)%matrix,error) + CALL cp_fm_scale_and_add(-one,delta_mos(i)%matrix,one,mos_new(i)%matrix) END DO DO ispin=1,nspin @@ -404,17 +396,16 @@ SUBROUTINE rt_convergence(rtp,matrix_s,delta_mos,delta_eps,error) delta_mos(re)%matrix%matrix_struct,& delta_mos(re)%matrix%matrix_struct%context,& double_col,& - double_row,& - error) + double_row) - CALL cp_fm_create(work,matrix_struct=newstruct,error=error) - CALL cp_fm_create(work1,matrix_struct=newstruct,error=error) + CALL cp_fm_create(work,matrix_struct=newstruct) + CALL cp_fm_create(work1,matrix_struct=newstruct) CALL cp_fm_get_info(delta_mos(re)%matrix,ncol_local=lcol,ncol_global=nmo,& - nrow_global=nao,error=error) - CALL cp_fm_get_info(work,ncol_global=newdim,error=error) + nrow_global=nao) + CALL cp_fm_get_info(work,ncol_global=newdim) - CALL cp_fm_set_all(work,zero,zero,error) + CALL cp_fm_set_all(work,zero,zero) DO icol=1,lcol work%local_data(:,icol)=delta_mos(re)%matrix%local_data(:,icol) @@ -422,31 +413,30 @@ SUBROUTINE rt_convergence(rtp,matrix_s,delta_mos,delta_eps,error) END DO - CALL cp_dbcsr_sm_fm_multiply(matrix_s, work, work1, ncol=newdim, error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_s, work, work1, ncol=newdim) - CALL cp_fm_release(work,error) + CALL cp_fm_release(work) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmo,ncol_global=nmo, & para_env=delta_mos(re)%matrix%matrix_struct%para_env, & - context=delta_mos(re)%matrix%matrix_struct%context,error=error) + context=delta_mos(re)%matrix%matrix_struct%context) CALL cp_fm_struct_double(newstruct1,& tmp_fm_struct,& delta_mos(re)%matrix%matrix_struct%context,& double_col,& - double_row,& - error) + double_row) - CALL cp_fm_create(work,matrix_struct=newstruct1,error=error) - CALL cp_fm_create(work2,matrix_struct=newstruct1,error=error) + CALL cp_fm_create(work,matrix_struct=newstruct1) + CALL cp_fm_create(work2,matrix_struct=newstruct1) CALL cp_gemm("T","N",nmo,newdim,nao,one,delta_mos(re)%matrix,& - work1,zero,work,error=error) + work1,zero,work) CALL cp_gemm("T","N",nmo,newdim,nao,one,delta_mos(im)%matrix,& - work1,zero,work2,error=error) + work1,zero,work2) - CALL cp_fm_get_info(work,nrow_local=lrow,error=error) + CALL cp_fm_get_info(work,nrow_local=lrow) DO i=1,lrow DO j=1,lcol alpha=SQRT((work%local_data(i,j)+work2%local_data(i,j+lcol))**2+& @@ -455,12 +445,12 @@ SUBROUTINE rt_convergence(rtp,matrix_s,delta_mos,delta_eps,error) ENDDO ENDDO - CALL cp_fm_release(work,error) - CALL cp_fm_release(work1,error) - CALL cp_fm_release(work2,error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) - CALL cp_fm_struct_release(newstruct,error=error) - CALL cp_fm_struct_release(newstruct1,error=error) + CALL cp_fm_release(work) + CALL cp_fm_release(work1) + CALL cp_fm_release(work2) + CALL cp_fm_struct_release(tmp_fm_struct) + CALL cp_fm_struct_release(newstruct) + CALL cp_fm_struct_release(newstruct1) ENDDO @@ -476,17 +466,15 @@ END SUBROUTINE rt_convergence !> \param rtp ... !> \param delta_P ... !> \param delta_eps ... -!> \param error ... !> \author Samuel Andermatt (02.14) ! ***************************************************************************** - SUBROUTINE rt_convergence_density(rtp,delta_P,delta_eps,error) + SUBROUTINE rt_convergence_density(rtp,delta_P,delta_eps) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: delta_P REAL(dp), INTENT(out) :: delta_eps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_convergence_density', & routineP = moduleN//':'//routineN @@ -506,10 +494,10 @@ SUBROUTINE rt_convergence_density(rtp,delta_P,delta_eps,error) failure=.FALSE. - CALL get_rtp(rtp=rtp,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_new=rho_new) DO i=1,SIZE(rho_new) - CALL cp_dbcsr_add(delta_P(i)%matrix,rho_new(i)%matrix,one,-one,error=error) + CALL cp_dbcsr_add(delta_P(i)%matrix,rho_new(i)%matrix,one,-one) ENDDO !get the maximum value of delta_P DO i=1,SIZE(delta_P) @@ -523,11 +511,11 @@ SUBROUTINE rt_convergence_density(rtp,delta_P,delta_eps,error) END DO NULLIFY(tmp) ALLOCATE(tmp) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=delta_P(1)%matrix,matrix_type="N",error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=delta_P(1)%matrix,matrix_type="N") DO ispin=1,SIZE(delta_P)/2 - CALL cp_dbcsr_desymmetrize(delta_P(2*ispin-1)%matrix,tmp,error=error) - CALL cp_dbcsr_add(delta_P(2*ispin)%matrix,tmp,one,one,error=error) + CALL cp_dbcsr_desymmetrize(delta_P(2*ispin-1)%matrix,tmp) + CALL cp_dbcsr_add(delta_P(2*ispin)%matrix,tmp,one,one) END DO !the absolute values are now in the even entries of delta_P max_alpha=zero @@ -542,7 +530,7 @@ SUBROUTINE rt_convergence_density(rtp,delta_P,delta_eps,error) END DO CALL mp_max(max_alpha,dbcsr_mp_group(dbcsr_distribution_mp(cp_dbcsr_distribution(delta_P(1)%matrix)))) delta_eps=SQRT(max_alpha) - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp) CALL timestop(handle) END SUBROUTINE rt_convergence_density @@ -550,14 +538,12 @@ END SUBROUTINE rt_convergence_density ! ***************************************************************************** !> \brief interface to qs_moments. Does only work for nonperiodic dipole !> \param qs_env ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE make_moment(qs_env,error) + SUBROUTINE make_moment(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_moment', & routineP = moduleN//':'//routineN @@ -571,14 +557,14 @@ SUBROUTINE make_moment(qs_env,error) NULLIFY(input, dft_control) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CALL get_qs_env(qs_env, input=input, dft_control=dft_control, error=error) - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) + CALL get_qs_env(qs_env, input=input, dft_control=dft_control) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") IF(dft_control%qs_control%dftb)THEN - CALL scf_post_calculation_dftb(dft_section, qs_env=qs_env, error=error) + CALL scf_post_calculation_dftb(dft_section, qs_env=qs_env) ELSE - CALL qs_scf_post_moments(input, logger, qs_env, output_unit, error) + CALL qs_scf_post_moments(input, logger, qs_env, output_unit) END IF CALL timestop(handle) @@ -588,16 +574,14 @@ END SUBROUTINE make_moment !> \brief Reports the sparsity pattern of the complex density matrix !> \param filter_eps ... !> \param rho ... -!> \param error ... !> \author Samuel Andermatt (09.14) ! ***************************************************************************** - SUBROUTINE report_density_occupation(filter_eps,rho,error) + SUBROUTINE report_density_occupation(filter_eps,rho) REAL(KIND=dp) :: filter_eps TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: rho - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'report_density_occupation', & routineP = moduleN//':'//routineN @@ -611,21 +595,21 @@ SUBROUTINE report_density_occupation(filter_eps,rho,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_nr = cp_logger_get_default_io_unit(logger) NULLIFY(tmp) - CALL cp_dbcsr_allocate_matrix_set(tmp,SIZE(rho),error=error) + CALL cp_dbcsr_allocate_matrix_set(tmp,SIZE(rho)) DO i=1,SIZE(rho) - CALL cp_dbcsr_init_p(tmp(i)%matrix,error=error) - CALL cp_dbcsr_create(tmp(i)%matrix,template=rho(i)%matrix,error=error) - CALL cp_dbcsr_copy(tmp(i)%matrix,rho(i)%matrix,error=error) + CALL cp_dbcsr_init_p(tmp(i)%matrix) + CALL cp_dbcsr_create(tmp(i)%matrix,template=rho(i)%matrix) + CALL cp_dbcsr_copy(tmp(i)%matrix,rho(i)%matrix) ENDDO DO ispin=1,SIZE(rho)/2 re=2*ispin-1 im=2*ispin eps=MAX(filter_eps,10E-12_dp) DO WHILE(eps<1.1_dp) - CALL cp_dbcsr_filter(tmp(re)%matrix,eps,error=error) + CALL cp_dbcsr_filter(tmp(re)%matrix,eps) occ=cp_dbcsr_get_occupation(tmp(re)%matrix) IF(unit_nr>0) WRITE(unit_nr,FMT="((T3,A,I1,A,F15.12,A,T61,F20.10))") "Occupation of rho spin ",& ispin," eps ", eps, " real: ", occ @@ -633,14 +617,14 @@ SUBROUTINE report_density_occupation(filter_eps,rho,error) ENDDO eps=MAX(filter_eps,10E-12_dp) DO WHILE(eps<1.1_dp) - CALL cp_dbcsr_filter(tmp(im)%matrix,eps,error=error) + CALL cp_dbcsr_filter(tmp(im)%matrix,eps) occ=cp_dbcsr_get_occupation(tmp(im)%matrix) IF(unit_nr>0) WRITE(unit_nr,FMT="((T3,A,I1,A,F15.12,A,T61,F20.10))") "Occupation of rho spin ",& ispin," eps ", eps, " imag: " ,occ eps=eps*10 ENDDO ENDDO - CALL cp_dbcsr_deallocate_matrix_set(tmp,error=error) + CALL cp_dbcsr_deallocate_matrix_set(tmp) CALL timestop(handle) END SUBROUTINE report_density_occupation @@ -648,15 +632,13 @@ END SUBROUTINE report_density_occupation ! ***************************************************************************** !> \brief Writes the density matrix and the atomic positions to a restart file !> \param rho_new ... -!> \param error ... !> \author Samuel Andermatt (09.14) ! ***************************************************************************** - SUBROUTINE write_rt_p_to_restart(rho_new,error) + SUBROUTINE write_rt_p_to_restart(rho_new) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: rho_new - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_rt_p_to_restart', & routineP = moduleN//':'//routineN @@ -669,7 +651,7 @@ SUBROUTINE write_rt_p_to_restart(rho_new,error) CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -681,17 +663,17 @@ SUBROUTINE write_rt_p_to_restart(rho_new,error) re=2*ispin-1 im=2*ispin WRITE(file_name,'(A,I0,A)') TRIM(project_name)//"_LS_DM_SPIN_RE",ispin,"_RESTART.dm" - cs_pos = cp_dbcsr_checksum (rho_new(re)%matrix, pos=.TRUE., error=error) + cs_pos = cp_dbcsr_checksum (rho_new(re)%matrix, pos=.TRUE.) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A,E20.8)') "Writing restart DM "//TRIM(file_name)//" with checksum: ",cs_pos ENDIF - CALL cp_dbcsr_binary_write(rho_new(re)%matrix,file_name,error) + CALL cp_dbcsr_binary_write(rho_new(re)%matrix,file_name) WRITE(file_name,'(A,I0,A)') TRIM(project_name)//"_LS_DM_SPIN_IM",ispin,"_RESTART.dm" - cs_pos = cp_dbcsr_checksum (rho_new(im)%matrix, pos=.TRUE., error=error) + cs_pos = cp_dbcsr_checksum (rho_new(im)%matrix, pos=.TRUE.) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A,E20.8)') "Writing restart DM "//TRIM(file_name)//" with checksum: ",cs_pos ENDIF - CALL cp_dbcsr_binary_write(rho_new(im)%matrix,file_name,error) + CALL cp_dbcsr_binary_write(rho_new(im)%matrix,file_name) ENDDO CALL timestop(handle) @@ -704,15 +686,13 @@ END SUBROUTINE write_rt_p_to_restart !> \param P_im ... !> \param dft_section ... !> \param spin ... -!> \param error ... !> \author Samuel Andermatt (06.15) ! ***************************************************************************** - SUBROUTINE rt_current(qs_env,P_im,dft_section,spin,error) + SUBROUTINE rt_current(qs_env,P_im,dft_section,spin) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_type), POINTER :: P_im TYPE(section_vals_type), POINTER :: dft_section INTEGER :: spin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_current', & routineP = moduleN//':'//routineN @@ -740,36 +720,36 @@ SUBROUTINE rt_current(qs_env,P_im,dft_section,spin,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) - CALL get_qs_env(qs_env=qs_env,subsys=subsys,pw_env=pw_env,rho=rho,ks_env=ks_env,error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) - CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,rs_grids=rs_rho,rs_descs=rs_descs,error=error) - CALL qs_rho_get(rho,rho_r=rho_r,rho_g=rho_g,error=error) + logger => cp_get_default_logger() + CALL get_qs_env(qs_env=qs_env,subsys=subsys,pw_env=pw_env,rho=rho,ks_env=ks_env) + CALL qs_subsys_get(subsys,particles=particles) + CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,rs_grids=rs_rho,rs_descs=rs_descs) + CALL qs_rho_get(rho,rho_r=rho_r,rho_g=rho_g) NULLIFY(zero,rs,gs) ALLOCATE(rs,gs) NULLIFY(rs%pw,gs%pw) ALLOCATE(zero) - CALL cp_dbcsr_init(zero,error=error) - CALL cp_dbcsr_create(zero,template=P_im,error=error) - CALL cp_dbcsr_copy(zero,P_im,error=error) - CALL cp_dbcsr_set(zero,0.0_dp,error=error) + CALL cp_dbcsr_init(zero) + CALL cp_dbcsr_create(zero,template=P_im) + CALL cp_dbcsr_copy(zero,P_im) + CALL cp_dbcsr_set(zero,0.0_dp) current_env%gauge=-1 current_env%gauge_init=.FALSE. - CALL pw_pool_create_pw(auxbas_pw_pool,rs%pw,use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool,gs%pw,use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + CALL pw_pool_create_pw(auxbas_pw_pool,rs%pw,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_pool_create_pw(auxbas_pw_pool,gs%pw,use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) NULLIFY(stride) ALLOCATE(stride(3)) DO dir=1,3 - CALL pw_zero(rs%pw,error=error) - CALL pw_zero(gs%pw,error=error) + CALL pw_zero(rs%pw) + CALL pw_zero(gs%pw) - CALL calculate_jrho_resp(zero,P_im,zero,zero,dir,dir,rs,gs,qs_env,current_env,rtp=.TRUE.,error=error) + CALL calculate_jrho_resp(zero,P_im,zero,zero,dir,dir,rs,gs,qs_env,current_env,rtp=.TRUE.) - stride=section_get_ivals(dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT%STRIDE",error=error) + stride=section_get_ivals(dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT%STRIDE") IF(dir==1) THEN sdir="-x" @@ -784,21 +764,21 @@ SUBROUTINE rt_current(qs_env,P_im,dft_section,spin,error) print_unit=cp_print_key_unit_nr(logger,dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT",& extension=ext, file_status="REPLACE", file_action="WRITE",& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) - CALL cp_pw_to_cube(rs%pw,print_unit,"EMD current",particles=particles,stride=stride,error=error) + CALL cp_pw_to_cube(rs%pw,print_unit,"EMD current",particles=particles,stride=stride) - CALL cp_print_key_finished_output(print_unit,logger,dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT",error=error) + CALL cp_print_key_finished_output(print_unit,logger,dft_section,"REAL_TIME_PROPAGATION%PRINT%CURRENT") END DO - CALL pw_pool_give_back_pw(auxbas_pw_pool,rs%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,gs%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rs%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,gs%pw) DEALLOCATE(rs) DEALLOCATE(gs) - CALL cp_dbcsr_deallocate_matrix(zero,error=error) + CALL cp_dbcsr_deallocate_matrix(zero) DEALLOCATE(stride) diff --git a/src/emd/rt_propagation_utils.F b/src/emd/rt_propagation_utils.F index d0684a3412..ee9a3c232f 100644 --- a/src/emd/rt_propagation_utils.F +++ b/src/emd/rt_propagation_utils.F @@ -78,16 +78,13 @@ MODULE rt_propagation_utils !> only needed for ehrenfest MD. !> !> \param qs_env the qs environment -!> \param error ... -!> !> \par History !> 02.2009 created [Manuel Guidon] !> 02.2014 switched to dbcsr matrices [Samuel Andermatt] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE calc_S_derivs(qs_env,error) + SUBROUTINE calc_S_derivs(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_S_derivs', & routineP = moduleN//':'//routineN @@ -136,37 +133,36 @@ SUBROUTINE calc_S_derivs(qs_env,error) sab_orb=sab_orb,& force=force,& dft_control=dft_control,& - ks_env=ks_env,& - error=error) + ks_env=ks_env) - CALL get_rtp(rtp=rtp,B_mat=B_mat,C_mat=C_mat,S_der=S_der,error=error) + CALL get_rtp(rtp=rtp,B_mat=B_mat,C_mat=C_mat,S_der=S_der) nder = 2 maxder = ncoset(nder) NULLIFY(tmp_mat) ALLOCATE(tmp_mat) - CALL cp_dbcsr_init(tmp_mat,error=error) - CALL cp_dbcsr_create(tmp_mat,template=S_der(1)%matrix,matrix_type="N",error=error) + CALL cp_dbcsr_init(tmp_mat) + CALL cp_dbcsr_create(tmp_mat,template=S_der(1)%matrix,matrix_type="N") IF(rtp%iter<2) THEN ! calculate the overlap derivative matrices IF(dft_control%qs_control%dftb)THEN - CALL build_dftb_overlap(qs_env,nder,s_derivs,error) + CALL build_dftb_overlap(qs_env,nder,s_derivs) ELSE CALL build_overlap_matrix(ks_env,nderivative=nder,matrix_s=s_derivs,& - basis_type_a="ORB",basis_type_b="ORB",sab_nl=sab_orb,error=error) + basis_type_a="ORB",basis_type_b="ORB",sab_nl=sab_orb) END IF NULLIFY(tmp_mat2) ALLOCATE(tmp_mat2) - CALL cp_dbcsr_init(tmp_mat2,error=error) - CALL cp_dbcsr_create(tmp_mat2,template=S_der(1)%matrix,matrix_type="S",error=error) + CALL cp_dbcsr_init(tmp_mat2) + CALL cp_dbcsr_create(tmp_mat2,template=S_der(1)%matrix,matrix_type="S") DO m=1,9 - CALL cp_dbcsr_copy(tmp_mat2,s_derivs(m+1)%matrix,error=error) - CALL cp_dbcsr_desymmetrize(tmp_mat2,S_der(m)%matrix,error=error) - CALL cp_dbcsr_scale(S_der(m)%matrix,-one,error=error) - CALL cp_dbcsr_filter(S_der(m)%matrix,rtp%filter_eps,error=error) + CALL cp_dbcsr_copy(tmp_mat2,s_derivs(m+1)%matrix) + CALL cp_dbcsr_desymmetrize(tmp_mat2,S_der(m)%matrix) + CALL cp_dbcsr_scale(S_der(m)%matrix,-one) + CALL cp_dbcsr_filter(S_der(m)%matrix,rtp%filter_eps) !The diagonal should be zero CALL cp_dbcsr_iterator_start(iter, S_der(m)%matrix) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) @@ -175,15 +171,15 @@ SUBROUTINE calc_S_derivs(qs_env,error) END DO CALL cp_dbcsr_iterator_stop (iter) END DO - CALL cp_dbcsr_deallocate_matrix_set(s_derivs,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp_mat2,error=error) + CALL cp_dbcsr_deallocate_matrix_set(s_derivs) + CALL cp_dbcsr_deallocate_matrix(tmp_mat2) END IF !calculate scalar product v(Rb)* (B_mat), and store the first derivatives - CALL cp_dbcsr_set(B_mat,zero,error=error) + CALL cp_dbcsr_set(B_mat,zero) DO m=1,3 - CALL cp_dbcsr_copy(tmp_mat,S_der(m)%matrix,error=error) + CALL cp_dbcsr_copy(tmp_mat,S_der(m)%matrix) CALL cp_dbcsr_iterator_start(iter, tmp_mat) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) CALL cp_dbcsr_iterator_next_block(iter, row_atom, col_atom, block_values) @@ -191,9 +187,9 @@ SUBROUTINE calc_S_derivs(qs_env,error) block_values=block_values*particle_set(col_atom)%v(m) END DO CALL cp_dbcsr_iterator_stop (iter) - CALL cp_dbcsr_add(B_mat,tmp_mat,one,one,error=error) + CALL cp_dbcsr_add(B_mat,tmp_mat,one,one) END DO - CALL cp_dbcsr_filter(B_mat,rtp%filter_eps,error=error) + CALL cp_dbcsr_filter(B_mat,rtp%filter_eps) !calculate C matrix: v(Rb)* c_map_mat=0 @@ -209,13 +205,13 @@ SUBROUTINE calc_S_derivs(qs_env,error) DO i=1,3 - CALL cp_dbcsr_set(C_mat(i)%matrix,zero,error=error) + CALL cp_dbcsr_set(C_mat(i)%matrix,zero) END DO DO m=1,6 - CALL cp_dbcsr_copy(tmp_mat,S_der(m+3)%matrix,error=error) + CALL cp_dbcsr_copy(tmp_mat,S_der(m+3)%matrix) DO j=1,2 IF(c_map_mat(m,j)==0)CYCLE - CALL cp_dbcsr_add(C_mat(c_map_mat(m,j))%matrix,tmp_mat,one,one,error) + CALL cp_dbcsr_add(C_mat(c_map_mat(m,j))%matrix,tmp_mat,one,one) END DO END DO @@ -226,25 +222,23 @@ SUBROUTINE calc_S_derivs(qs_env,error) block_values=block_values*particle_set(row_atom)%v(m) END DO CALL cp_dbcsr_iterator_stop (iter) - CALL cp_dbcsr_filter(C_mat(m)%matrix,rtp%filter_eps,error=error) + CALL cp_dbcsr_filter(C_mat(m)%matrix,rtp%filter_eps) END DO - CALL cp_dbcsr_deallocate_matrix(tmp_mat,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp_mat) CALL timestop(handle) END SUBROUTINE ! ***************************************************************************** !> \brief reads the restart file. At the moment only SCF (means only real) !> \param qs_env ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE get_restart_wfn(qs_env,error) + SUBROUTINE get_restart_wfn(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_restart_wfn', & routineP = moduleN//':'//routineN @@ -283,9 +277,8 @@ SUBROUTINE get_restart_wfn(qs_env,error) rtp=rtp,& dft_control=dft_control,& rho=rho_struct,& - para_env=para_env,& - error=error) - logger => cp_error_get_logger(error) + para_env=para_env) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -294,72 +287,71 @@ SUBROUTINE get_restart_wfn(qs_env,error) id_nr=0 nspin=SIZE(mo_array) - CALL qs_rho_get(rho_struct, rho_ao=p_rmpv, error=error) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + CALL qs_rho_get(rho_struct, rho_ao=p_rmpv) + dft_section => section_vals_get_subs_vals(input,"DFT") SELECT CASE(dft_control%rtp_control%initial_wfn) CASE(use_restart_wfn) CALL read_mo_set(mo_array,atomic_kind_set,qs_kind_set,particle_set,para_env,& - id_nr=id_nr,multiplicity=dft_control%multiplicity,dft_section=dft_section,& - error=error) + id_nr=id_nr,multiplicity=dft_control%multiplicity,dft_section=dft_section) DO ispin=1,nspin - CALL calculate_density_matrix(mo_array(ispin)%mo_set, p_rmpv(ispin)%matrix,error=error) + CALL calculate_density_matrix(mo_array(ispin)%mo_set, p_rmpv(ispin)%matrix) ENDDO IF(rtp%linear_scaling) THEN - CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new) DO ispin=1,nspin re=2*ispin-1 im=2*ispin - CALL cp_fm_get_info(mo_array(ispin)%mo_set%mo_coeff,ncol_global=ncol,error=error) + CALL cp_fm_get_info(mo_array(ispin)%mo_set%mo_coeff,ncol_global=ncol) alpha=1.0_dp IF(SIZE(mo_array)==1) alpha=2*alpha CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=rho_old(re)%matrix,& matrix_v=mo_array(ispin)%mo_set%mo_coeff,matrix_g=mo_array(ispin)%mo_set%mo_coeff,ncol=ncol,& - keep_sparsity=.FALSE.,alpha=alpha,error=error) + keep_sparsity=.FALSE.,alpha=alpha) END DO DO i=1,nspin - CALL cp_dbcsr_copy(rho_new(i)%matrix,rho_old(i)%matrix,error=error) + CALL cp_dbcsr_copy(rho_new(i)%matrix,rho_old(i)%matrix) ENDDO - CALL calc_update_rho_sparse(qs_env,error) + CALL calc_update_rho_sparse(qs_env) ELSE - CALL get_rtp(rtp=rtp,mos_old=mos_old,error=error) + CALL get_rtp(rtp=rtp,mos_old=mos_old) DO i=1,SIZE(qs_env%mos) - CALL cp_fm_to_fm(mo_array(i)%mo_set%mo_coeff,mos_old(2*i-1)%matrix,error) - CALL cp_fm_set_all(mos_old(2*i)%matrix,zero,zero,error) + CALL cp_fm_to_fm(mo_array(i)%mo_set%mo_coeff,mos_old(2*i-1)%matrix) + CALL cp_fm_set_all(mos_old(2*i)%matrix,zero,zero) END DO ENDIF CASE(use_rt_restart) IF(rtp%linear_scaling) THEN - CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new) project_name = logger%iter_info%project_name DO ispin=1,nspin re=2*ispin-1 im=2*ispin WRITE(file_name,'(A,I0,A)') TRIM(project_name)//"_LS_DM_SPIN_RE",ispin,"_RESTART.dm" CALL cp_dbcsr_binary_read(file_name, distribution=cp_dbcsr_distribution(rho_old(re)%matrix), & - matrix_new=rho_old(re)%matrix, error=error) - cs_pos = cp_dbcsr_checksum (rho_old(re)%matrix, pos=.TRUE., error=error) + matrix_new=rho_old(re)%matrix) + cs_pos = cp_dbcsr_checksum (rho_old(re)%matrix, pos=.TRUE.) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A,E20.8)') "Read restart DM "//TRIM(file_name)//" with checksum: ",cs_pos ENDIF WRITE(file_name,'(A,I0,A)') TRIM(project_name)//"_LS_DM_SPIN_IM",ispin,"_RESTART.dm" CALL cp_dbcsr_binary_read(file_name, distribution=cp_dbcsr_distribution(rho_old(im)%matrix), & - matrix_new=rho_old(im)%matrix, error=error) - cs_pos = cp_dbcsr_checksum (rho_old(im)%matrix, pos=.TRUE., error=error) + matrix_new=rho_old(im)%matrix) + cs_pos = cp_dbcsr_checksum (rho_old(im)%matrix, pos=.TRUE.) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A,E20.8)') "Read restart DM "//TRIM(file_name)//" with checksum: ",cs_pos ENDIF ENDDO DO i=1,SIZE(rho_new) - CALL cp_dbcsr_copy(rho_new(i)%matrix,rho_old(i)%matrix,error=error) + CALL cp_dbcsr_copy(rho_new(i)%matrix,rho_old(i)%matrix) ENDDO - CALL calc_update_rho_sparse(qs_env,error) + CALL calc_update_rho_sparse(qs_env) ELSE - CALL get_rtp(rtp=rtp,mos_old=mos_old,mos_new=mos_new,error=error) + CALL get_rtp(rtp=rtp,mos_old=mos_old,mos_new=mos_new) CALL read_rt_mos_from_restart(mo_array,mos_old,atomic_kind_set,qs_kind_set,particle_set,para_env,& - id_nr,dft_control%multiplicity,dft_section, error) + id_nr,dft_control%multiplicity,dft_section) DO ispin=1,nspin CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,error=error) + p_rmpv(ispin)%matrix) ENDDO ENDIF END SELECT @@ -370,15 +362,13 @@ END SUBROUTINE get_restart_wfn !> \brief calculates the density from the complex MOs and passes the density to !> qs_env. !> \param qs_env ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE calc_update_rho(qs_env,error) + SUBROUTINE calc_update_rho(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_update_rho', & routineP = moduleN//':'//routineN @@ -400,35 +390,34 @@ SUBROUTINE calc_update_rho(qs_env,error) CALL get_qs_env(qs_env,& ks_env=ks_env,& rho=rho,& - rtp=rtp,& - error=error) - CALL get_rtp(rtp=rtp,mos_new=mos,error=error) - CALL qs_rho_get(rho_struct=rho,rho_ao=rho_ao,error=error) + rtp=rtp) + CALL get_rtp(rtp=rtp,mos_new=mos) + CALL qs_rho_get(rho_struct=rho,rho_ao=rho_ao) DO i=1,SIZE(mos)/2 re=2*i-1 ; im =2*i alpha=3*one-REAL(SIZE(mos)/2,dp) - CALL cp_dbcsr_set(rho_ao(i)%matrix,zero,error=error) - CALL cp_fm_get_info(mos(re)%matrix,ncol_global=ncol,error=error) + CALL cp_dbcsr_set(rho_ao(i)%matrix,zero) + CALL cp_fm_get_info(mos(re)%matrix,ncol_global=ncol) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=rho_ao(i)%matrix,& matrix_v=mos(re)%matrix,& ncol=ncol,& - alpha=alpha,error=error) + alpha=alpha) ! It is actually complex conjugate but i*i=-1 therfore it must be added CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=rho_ao(i)%matrix,& matrix_v=mos(im)%matrix,& ncol=ncol,& - alpha=alpha,error=error) + alpha=alpha) END DO - CALL qs_rho_update_rho(rho, qs_env, error=error) + CALL qs_rho_update_rho(rho, qs_env) IF(rtp%do_hfx)THEN - CALL qs_rho_get(rho_struct=rho,rho_ao_im=rho_ao_im,error=error) - CALL calculate_P_imaginary(rtp, rho_ao_im,keep_sparsity=.TRUE.,error=error) - CALL qs_rho_set(rho, rho_ao_im=rho_ao_im, error=error) + CALL qs_rho_get(rho_struct=rho,rho_ao_im=rho_ao_im) + CALL calculate_P_imaginary(rtp, rho_ao_im,keep_sparsity=.TRUE.) + CALL qs_rho_set(rho, rho_ao_im=rho_ao_im) END IF - CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.,error=error) + CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.) CALL timestop(handle) @@ -438,15 +427,13 @@ END SUBROUTINE calc_update_rho ! ***************************************************************************** !> \brief Copies the density matrix back into the qs_env%rho%rho_ao !> \param qs_env ... -!> \param error ... !> \author Samuel Andermatt (3.14) ! ***************************************************************************** - SUBROUTINE calc_update_rho_sparse(qs_env,error) + SUBROUTINE calc_update_rho_sparse(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_update_rho_sparse', & routineP = moduleN//':'//routineN @@ -468,48 +455,47 @@ SUBROUTINE calc_update_rho_sparse(qs_env,error) ks_env=ks_env,& rho=rho,& rtp=rtp,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) rtp_control=>dft_control%rtp_control - CALL get_rtp(rtp=rtp,rho_new=rho_new,error=error) - CALL qs_rho_get(rho_struct=rho,rho_ao=rho_ao,error=error) - IF(rtp%do_hfx) CALL qs_rho_get(rho_struct=rho,rho_ao_im=rho_ao_im,error=error) + CALL get_rtp(rtp=rtp,rho_new=rho_new) + CALL qs_rho_get(rho_struct=rho,rho_ao=rho_ao) + IF(rtp%do_hfx) CALL qs_rho_get(rho_struct=rho,rho_ao_im=rho_ao_im) IF(rtp_control%orthonormal) THEN - CALL get_rtp(rtp=rtp,S_minus_half=S_minus_half,error=error) + CALL get_rtp(rtp=rtp,S_minus_half=S_minus_half) ALLOCATE(tmp) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=rho_new(1)%matrix,error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=rho_new(1)%matrix) ALLOCATE(tmp2) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=rho_new(1)%matrix,error=error) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=rho_new(1)%matrix) DO ispin=1,SIZE(rho_ao) re = 2*ispin-1 - CALL cp_dbcsr_multiply("N","N",one,S_minus_half,rho_new(re)%matrix,zero,tmp,filter_eps=rtp%filter_eps,error=error) - CALL cp_dbcsr_multiply("N","N",one,tmp,S_minus_half,zero,tmp2,filter_eps=rtp%filter_eps,error=error) - CALL cp_dbcsr_set(rho_ao(ispin)%matrix,zero,error=error) - CALL cp_dbcsr_copy_into_existing(rho_ao(ispin)%matrix,tmp2,error=error) + CALL cp_dbcsr_multiply("N","N",one,S_minus_half,rho_new(re)%matrix,zero,tmp,filter_eps=rtp%filter_eps) + CALL cp_dbcsr_multiply("N","N",one,tmp,S_minus_half,zero,tmp2,filter_eps=rtp%filter_eps) + CALL cp_dbcsr_set(rho_ao(ispin)%matrix,zero) + CALL cp_dbcsr_copy_into_existing(rho_ao(ispin)%matrix,tmp2) END DO IF(rtp%do_hfx) THEN DO ispin=1,SIZE(rho_ao_im) im = 2*ispin - CALL cp_dbcsr_multiply("N","N",one,S_minus_half,rho_new(im)%matrix,zero,tmp,filter_eps=rtp%filter_eps,error=error) - CALL cp_dbcsr_multiply("N","N",one,tmp,S_minus_half,zero,tmp2,filter_eps=rtp%filter_eps,error=error) - CALL cp_dbcsr_set(rho_ao_im(ispin)%matrix,zero,error=error) - CALL cp_dbcsr_copy_into_existing(rho_ao_im(ispin)%matrix,tmp2,error=error) + CALL cp_dbcsr_multiply("N","N",one,S_minus_half,rho_new(im)%matrix,zero,tmp,filter_eps=rtp%filter_eps) + CALL cp_dbcsr_multiply("N","N",one,tmp,S_minus_half,zero,tmp2,filter_eps=rtp%filter_eps) + CALL cp_dbcsr_set(rho_ao_im(ispin)%matrix,zero) + CALL cp_dbcsr_copy_into_existing(rho_ao_im(ispin)%matrix,tmp2) END DO ENDIF - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp2,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp) + CALL cp_dbcsr_deallocate_matrix(tmp2) ELSE DO ispin=1,SIZE(rho_ao) - CALL cp_dbcsr_set(rho_ao(ispin)%matrix,zero,error=error) - CALL cp_dbcsr_copy_into_existing(rho_ao(ispin)%matrix,rho_new(ispin*2-1)%matrix,error=error) - IF(rtp%do_hfx) CALL cp_dbcsr_copy_into_existing(rho_ao_im(ispin)%matrix,rho_new(ispin*2)%matrix,error=error) + CALL cp_dbcsr_set(rho_ao(ispin)%matrix,zero) + CALL cp_dbcsr_copy_into_existing(rho_ao(ispin)%matrix,rho_new(ispin*2-1)%matrix) + IF(rtp%do_hfx) CALL cp_dbcsr_copy_into_existing(rho_ao_im(ispin)%matrix,rho_new(ispin*2)%matrix) END DO ENDIF - CALL qs_rho_update_rho(rho, qs_env, error=error) - CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.,error=error) + CALL qs_rho_update_rho(rho, qs_env) + CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.) CALL timestop(handle) @@ -521,14 +507,12 @@ END SUBROUTINE calc_update_rho_sparse !> \param rtp ... !> \param matrix_p_im ... !> \param keep_sparsity ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_P_imaginary(rtp,matrix_p_im,keep_sparsity,error) + SUBROUTINE calculate_P_imaginary(rtp,matrix_p_im,keep_sparsity) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_p_im LOGICAL, OPTIONAL :: keep_sparsity - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_P_imaginary', & routineP = moduleN//':'//routineN @@ -539,7 +523,7 @@ SUBROUTINE calculate_P_imaginary(rtp,matrix_p_im,keep_sparsity,error) TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mos - CALL get_rtp(rtp=rtp,mos_new=mos,error=error) + CALL get_rtp(rtp=rtp,mos_new=mos) my_keep_sparsity=.FALSE. IF(PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity @@ -547,14 +531,14 @@ SUBROUTINE calculate_P_imaginary(rtp,matrix_p_im,keep_sparsity,error) DO i=1,SIZE(mos)/2 re=2*i-1 ; im =2*i alpha=3.0_dp-REAL(SIZE(matrix_p_im),dp) - CALL cp_dbcsr_set(matrix_p_im(i)%matrix,0.0_dp,error=error) - CALL cp_fm_get_info(mos(re)%matrix,ncol_global=ncol,error=error) + CALL cp_dbcsr_set(matrix_p_im(i)%matrix,0.0_dp) + CALL cp_fm_get_info(mos(re)%matrix,ncol_global=ncol) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=matrix_p_im(i)%matrix,& matrix_v=mos(im)%matrix,& matrix_g=mos(re)%matrix,& ncol=ncol,& keep_sparsity=my_keep_sparsity,& - alpha=alpha,error=error) + alpha=alpha) ! It is actually complex conjugate not only transposed alpha=-alpha CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=matrix_p_im(i)%matrix,& @@ -562,7 +546,7 @@ SUBROUTINE calculate_P_imaginary(rtp,matrix_p_im,keep_sparsity,error) matrix_g=mos(im)%matrix,& ncol=ncol,& keep_sparsity=my_keep_sparsity,& - alpha=alpha,error=error) + alpha=alpha) END DO END SUBROUTINE calculate_P_imaginary diff --git a/src/emd/rt_propagator_init.F b/src/emd/rt_propagator_init.F index 244575e91d..b63564c322 100644 --- a/src/emd/rt_propagator_init.F +++ b/src/emd/rt_propagator_init.F @@ -72,14 +72,12 @@ MODULE rt_propagator_init ! ***************************************************************************** !> \brief prepares the initial matrices for the propagators !> \param qs_env ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE init_propagators(qs_env,error) + SUBROUTINE init_propagators(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_propagators', & routineP = moduleN//':'//routineN @@ -103,30 +101,29 @@ SUBROUTINE init_propagators(qs_env,error) dft_control=dft_control,& matrix_s=s_mat,& matrix_ks=matrix_ks,& - matrix_ks_im=matrix_ks_im,& - error=error) + matrix_ks_im=matrix_ks_im) rtp_control=>dft_control%rtp_control CALL get_rtp (rtp=rtp,exp_H_old=exp_H_old,exp_H_new=exp_H_new,& - propagator_matrix=propagator_matrix,dt=dt,error=error) - CALL s_matrices_create (s_mat,rtp,error) - CALL calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control,error) + propagator_matrix=propagator_matrix,dt=dt) + CALL s_matrices_create (s_mat,rtp) + CALL calc_SinvH(rtp,matrix_ks,matrix_ks_im,rtp_control) DO i=1,SIZE(exp_H_old) - CALL cp_dbcsr_copy(exp_H_old(i)%matrix,exp_H_new(i)%matrix,error=error) + CALL cp_dbcsr_copy(exp_H_old(i)%matrix,exp_H_new(i)%matrix) END DO ! use the fact that CN propagator is a first order pade approximation on the EM propagator IF(rtp_control%propagator==do_cn)THEN rtp%orders(1,:)=0;rtp%orders(2,:)=1; rtp_control%mat_exp=do_pade; rtp_control%propagator=do_em ELSE IF(rtp_control%mat_exp==do_pade.OR.rtp_control%mat_exp==do_taylor) THEN IF(rtp%linear_scaling) THEN - CALL get_maxabs_eigval_sparse(rtp,s_mat,matrix_ks,rtp_control,error) + CALL get_maxabs_eigval_sparse(rtp,s_mat,matrix_ks,rtp_control) ELSE - CALL get_maxabs_eigval(rtp,s_mat,matrix_ks,rtp_control,error) + CALL get_maxabs_eigval(rtp,s_mat,matrix_ks,rtp_control) END IF END IF IF(rtp_control%mat_exp==do_pade.AND.rtp%linear_scaling) THEN ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) WRITE(unit_nr,*) "linear_scaling currently does not support pade exponentials, switching to taylor" @@ -142,8 +139,8 @@ SUBROUTINE init_propagators(qs_env,error) prefac=-1.0_dp*dt END SELECT DO imat=1,SIZE(exp_H_new) - CALL cp_dbcsr_copy(propagator_matrix(imat)%matrix,exp_H_new(imat)%matrix,error=error) - CALL cp_dbcsr_scale(propagator_matrix(imat)%matrix,prefac,error=error) + CALL cp_dbcsr_copy(propagator_matrix(imat)%matrix,exp_H_new(imat)%matrix) + CALL cp_dbcsr_scale(propagator_matrix(imat)%matrix,prefac) END DO ! For ETRS this bit could be avoided but it drastically simplifies the workflow afterwards. @@ -153,30 +150,30 @@ SUBROUTINE init_propagators(qs_env,error) IF(rtp_control%propagator==do_etrs)THEN IF(rtp_control%mat_exp==do_arnoldi)THEN rtp%iter=0 - CALL propagate_arnoldi(rtp,rtp_control,error) - CALL get_rtp(rtp=rtp,mos_new=mos_new,mos_next=mos_next,error=error) + CALL propagate_arnoldi(rtp,rtp_control) + CALL get_rtp(rtp=rtp,mos_new=mos_new,mos_next=mos_next) DO imat=1,SIZE(mos_new) - CALL cp_fm_to_fm(mos_new(imat)%matrix,mos_next(imat)%matrix,error) + CALL cp_fm_to_fm(mos_new(imat)%matrix,mos_next(imat)%matrix) END DO ELSEIF(rtp_control%mat_exp==do_bch) THEN ELSE IF(rtp%linear_scaling) THEN - CALL compute_exponential_sparse(exp_H_new,propagator_matrix,rtp_control,rtp,error=error) + CALL compute_exponential_sparse(exp_H_new,propagator_matrix,rtp_control,rtp) ELSE - CALL compute_exponential(exp_H_new,propagator_matrix,rtp_control,rtp,error=error) + CALL compute_exponential(exp_H_new,propagator_matrix,rtp_control,rtp) END IF DO imat=1,SIZE(exp_H_new) - CALL cp_dbcsr_copy(exp_H_old(imat)%matrix,exp_H_new(imat)%matrix,error=error) + CALL cp_dbcsr_copy(exp_H_old(imat)%matrix,exp_H_new(imat)%matrix) END DO END IF END IF IF(rtp%linear_scaling) THEN - CALL get_rtp (rtp=rtp,rho_old=rho_old,error=error) + CALL get_rtp (rtp=rtp,rho_old=rho_old) ELSE - CALL get_rtp (rtp=rtp,mos_old=mos_old,error=error) + CALL get_rtp (rtp=rtp,mos_old=mos_old) ENDIF - CALL put_data_to_history(rtp,mos=mos_old,s_mat=s_mat,ihist=1,rho=rho_old,error=error) + CALL put_data_to_history(rtp,mos=mos_old,s_mat=s_mat,ihist=1,rho=rho_old) END SUBROUTINE init_propagators @@ -188,16 +185,14 @@ END SUBROUTINE init_propagators !> \param s_mat ... !> \param matrix_ks ... !> \param rtp_control ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE get_maxabs_eigval(rtp,s_mat,matrix_ks,rtp_control,error) + SUBROUTINE get_maxabs_eigval(rtp,s_mat,matrix_ks,rtp_control) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: s_mat, matrix_ks TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_maxabs_eigval', & routineP = moduleN//':'//routineN @@ -217,33 +212,28 @@ SUBROUTINE get_maxabs_eigval(rtp,s_mat,matrix_ks,rtp_control,error) CALL timeset(routineN,handle) failure=.FALSE. - CALL get_rtp(rtp=rtp,S_inv=S_inv,dt=t,error=error) + CALL get_rtp(rtp=rtp,S_inv=S_inv,dt=t) CALL cp_fm_create(S_inv_fm,& matrix_struct=rtp%ao_ao_fmstruct,& - name="S_inv",& - error=error) - CALL copy_dbcsr_to_fm(S_inv,S_inv_fm,error=error) + name="S_inv") + CALL copy_dbcsr_to_fm(S_inv,S_inv_fm) CALL cp_fm_create(S_half,& matrix_struct=rtp%ao_ao_fmstruct,& - name="S_half",& - error=error) + name="S_half") CALL cp_fm_create(S_minus_half,& matrix_struct=rtp%ao_ao_fmstruct,& - name="S_minus_half",& - error=error) + name="S_minus_half") CALL cp_fm_create(H_fm,& matrix_struct=rtp%ao_ao_fmstruct,& - name="RTP_H_FM",& - error=error) + name="RTP_H_FM") CALL cp_fm_create(tmp_mat_H,& matrix_struct=rtp%ao_ao_fmstruct,& - name="TMP_H",& - error=error) + name="TMP_H") ndim=S_inv_fm%matrix_struct%nrow_global scale=1.0_dp @@ -254,29 +244,27 @@ SUBROUTINE get_maxabs_eigval(rtp,s_mat,matrix_ks,rtp_control,error) CALL cp_fm_create(tmp,& matrix_struct=rtp%ao_ao_fmstruct,& - name="tmp_mat",& - error=error) + name="tmp_mat") CALL cp_fm_create(eigvec_H,& matrix_struct=rtp%ao_ao_fmstruct,& - name="tmp_EVEC",& - error=error) + name="tmp_EVEC") ALLOCATE(eigval_H(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL copy_dbcsr_to_fm(s_mat(1)%matrix,tmp,error=error) - CALL cp_fm_upper_to_full(tmp,eigvec_H,error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL copy_dbcsr_to_fm(s_mat(1)%matrix,tmp) + CALL cp_fm_upper_to_full(tmp,eigvec_H) - CALL cp_fm_syevd(tmp,eigvec_H,eigval_H,error=error) + CALL cp_fm_syevd(tmp,eigvec_H,eigval_H) eigval_H(:)=one/eigval_H(:) - CALL backtransform_matrix(eigval_H,eigvec_H,S_inv_fm,error) + CALL backtransform_matrix(eigval_H,eigvec_H,S_inv_fm) eigval_H(:)=SQRT(eigval_H(:)) - CALL backtransform_matrix(eigval_H,eigvec_H,S_minus_half,error) + CALL backtransform_matrix(eigval_H,eigvec_H,S_minus_half) eigval_H(:)=one/eigval_H(:) - CALL backtransform_matrix(eigval_H,eigvec_H,S_half,error) - CALL cp_fm_release(eigvec_H,error) - CALL cp_fm_release(tmp,error) + CALL backtransform_matrix(eigval_H,eigvec_H,S_half) + CALL cp_fm_release(eigvec_H) + CALL cp_fm_release(tmp) IF(rtp_control%mat_exp==do_taylor)method=1 IF(rtp_control%mat_exp==do_pade)method=2 @@ -284,32 +272,32 @@ SUBROUTINE get_maxabs_eigval(rtp,s_mat,matrix_ks,rtp_control,error) DO ispin=1,SIZE(matrix_ks) - CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,H_fm,error=error) - CALL cp_fm_upper_to_full(H_fm,tmp_mat_H,error) - CALL cp_fm_scale(t,H_fm,error) + CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,H_fm) + CALL cp_fm_upper_to_full(H_fm,tmp_mat_H) + CALL cp_fm_scale(t,H_fm) CALL cp_gemm("N","N",ndim,ndim,ndim,one,H_fm,S_minus_half,zero,& - tmp_mat_H,error) + tmp_mat_H) CALL cp_gemm("N","N",ndim,ndim,ndim,one,S_minus_half,tmp_mat_H,zero,& - H_fm,error) + H_fm) - CALL cp_fm_syevd(H_fm,tmp_mat_H,eigval_H,error=error) + CALL cp_fm_syevd(H_fm,tmp_mat_H,eigval_H) min_eval=MINVAL(eigval_H) max_eval=MAXVAL(eigval_H) norm2=2.0_dp*MAX(ABS(min_eval),ABS(max_eval)) CALL get_nsquare_norder(norm2,rtp%orders(1,ispin),rtp%orders(2,ispin),& - rtp_control%eps_exp,method ,emd,error) + rtp_control%eps_exp,method ,emd) END DO DEALLOCATE(eigval_H,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL copy_fm_to_dbcsr(S_inv_fm,S_inv,error=error) - CALL cp_fm_release(S_inv_fm,error) - CALL cp_fm_release(S_half,error) - CALL cp_fm_release(S_minus_half,error) - CALL cp_fm_release(H_fm,error) - CALL cp_fm_release(tmp_mat_H,error) + CALL copy_fm_to_dbcsr(S_inv_fm,S_inv) + CALL cp_fm_release(S_inv_fm) + CALL cp_fm_release(S_half) + CALL cp_fm_release(S_minus_half) + CALL cp_fm_release(H_fm) + CALL cp_fm_release(tmp_mat_H) CALL timestop(handle) @@ -323,16 +311,14 @@ END SUBROUTINE get_maxabs_eigval !> \param s_mat ... !> \param matrix_ks ... !> \param rtp_control ... -!> \param error ... !> \author Samuel Andermatt (02.14) ! ***************************************************************************** - SUBROUTINE get_maxabs_eigval_sparse(rtp,s_mat,matrix_ks,rtp_control,error) + SUBROUTINE get_maxabs_eigval_sparse(rtp,s_mat,matrix_ks,rtp_control) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: s_mat, matrix_ks TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_maxabs_eigval_sparse', & routineP = moduleN//':'//routineN @@ -347,24 +333,24 @@ SUBROUTINE get_maxabs_eigval_sparse(rtp,s_mat,matrix_ks,rtp_control,error) CALL timeset(routineN,handle) - CALL get_rtp(rtp=rtp,dt=t,error=error) + CALL get_rtp(rtp=rtp,dt=t) NULLIFY(s_half) ALLOCATE(s_half) - CALL cp_dbcsr_init(s_half,error=error) - CALL cp_dbcsr_create(s_half,template=s_mat(1)%matrix,error=error) + CALL cp_dbcsr_init(s_half) + CALL cp_dbcsr_create(s_half,template=s_mat(1)%matrix) NULLIFY(s_minus_half) ALLOCATE(s_minus_half) - CALL cp_dbcsr_init(s_minus_half,error=error) - CALL cp_dbcsr_create(s_minus_half,template=s_mat(1)%matrix,error=error) + CALL cp_dbcsr_init(s_minus_half) + CALL cp_dbcsr_create(s_minus_half,template=s_mat(1)%matrix) NULLIFY(tmp) ALLOCATE(tmp) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=s_mat(1)%matrix,matrix_type="N",error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=s_mat(1)%matrix,matrix_type="N") NULLIFY(tmp2) ALLOCATE(tmp2) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=s_mat(1)%matrix,matrix_type="N",error=error) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=s_mat(1)%matrix,matrix_type="N") scale=1.0_dp IF(rtp_control%propagator==do_etrs)scale=2.0_dp t=-t/scale @@ -373,23 +359,23 @@ SUBROUTINE get_maxabs_eigval_sparse(rtp,s_mat,matrix_ks,rtp_control,error) IF(rtp_control%mat_exp==do_taylor)method=1 IF(rtp_control%mat_exp==do_pade)method=2 CALL matrix_sqrt_Newton_Schulz(s_half,s_minus_half,s_mat(1)%matrix,rtp%filter_eps,& - rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter,error=error) + rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter) DO ispin=1,SIZE(matrix_ks) CALL cp_dbcsr_multiply("N","N",t,matrix_ks(ispin)%matrix,s_minus_half,zero,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,s_minus_half,tmp,zero,tmp2,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_arnoldi_extremal(tmp2, max_ev, min_ev, threshold=rtp%lanzcos_threshold, & - max_iter=rtp%lanzcos_max_iter, converged=converged, error=error) + max_iter=rtp%lanzcos_max_iter, converged=converged) norm2=2.0_dp*MAX(ABS(min_ev),ABS(max_ev)) CALL get_nsquare_norder(norm2,rtp%orders(1,ispin),rtp%orders(2,ispin),& - rtp_control%eps_exp,method,emd,error) + rtp_control%eps_exp,method,emd) END DO - CALL cp_dbcsr_deallocate_matrix(s_half,error=error) - CALL cp_dbcsr_deallocate_matrix(s_minus_half,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp2,error=error) + CALL cp_dbcsr_deallocate_matrix(s_half) + CALL cp_dbcsr_deallocate_matrix(s_minus_half) + CALL cp_dbcsr_deallocate_matrix(tmp) + CALL cp_dbcsr_deallocate_matrix(tmp2) CALL timestop(handle) @@ -401,15 +387,13 @@ SUBROUTINE get_maxabs_eigval_sparse(rtp,s_mat,matrix_ks,rtp_control,error) !> \param Eval ... !> \param eigenvec ... !> \param matrix ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE backtransform_matrix(Eval,eigenvec,matrix,error) + SUBROUTINE backtransform_matrix(Eval,eigenvec,matrix) REAL(dp), DIMENSION(:), INTENT(in) :: Eval TYPE(cp_fm_type), POINTER :: eigenvec, matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'backtransform_matrix', & routineP = moduleN//':'//routineN @@ -423,14 +407,13 @@ SUBROUTINE backtransform_matrix(Eval,eigenvec,matrix,error) CALL timeset(routineN,handle) CALL cp_fm_create(tmp,& matrix_struct=matrix%matrix_struct,& - name="TMP_BT",& - error=error) + name="TMP_BT") CALL cp_fm_get_info(matrix, nrow_local=nrow_local, ncol_local=ncol_local,& - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) ndim=matrix%matrix_struct%nrow_global - CALL cp_fm_set_all(tmp,zero,zero,error) + CALL cp_fm_set_all(tmp,zero,zero) DO i=1,ncol_local l=col_indices(i) DO j=1,nrow_local @@ -438,9 +421,9 @@ SUBROUTINE backtransform_matrix(Eval,eigenvec,matrix,error) END DO END DO CALL cp_gemm("N","T",ndim,ndim,ndim,one,tmp,eigenvec,zero,& - matrix ,error) + matrix) - CALL cp_fm_release(tmp,error) + CALL cp_fm_release(tmp) CALL timestop(handle) END SUBROUTINE backtransform_matrix @@ -453,18 +436,16 @@ END SUBROUTINE backtransform_matrix !> \param matrix_s ... !> \param nelectron_spin ... !> \param orthonormal ... -!> \param error ... !> \author Samuel Andermatt (03.14) ! ***************************************************************************** - SUBROUTINE rt_initialize_rho_from_ks(rtp,matrix_ks,matrix_s,nelectron_spin,orthonormal,error) + SUBROUTINE rt_initialize_rho_from_ks(rtp,matrix_ks,matrix_s,nelectron_spin,orthonormal) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks, matrix_s INTEGER, DIMENSION(2) :: nelectron_spin LOGICAL :: orthonormal - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_initialize_rho_from_ks', & routineP = moduleN//':'//routineN @@ -477,14 +458,14 @@ SUBROUTINE rt_initialize_rho_from_ks(rtp,matrix_ks,matrix_s,nelectron_spin,ortho POINTER :: rho_new, rho_old TYPE(cp_dbcsr_type), POINTER :: S_half, S_minus_half, tmp - CALL get_rtp(rtp=rtp,rho_old=rho_old,S_half=S_half,S_minus_half=S_minus_half,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_old=rho_old,S_half=S_half,S_minus_half=S_minus_half,rho_new=rho_new) !The inverse of S will be calculated twice in the first step, but preventing that would make things more complicated CALL matrix_sqrt_Newton_Schulz(S_half,S_minus_half,matrix_s(1)%matrix,rtp%filter_eps,& - rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter,error=error) + rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter) NULLIFY(tmp) ALLOCATE(tmp) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=matrix_ks(1)%matrix,matrix_type="N",error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=matrix_ks(1)%matrix,matrix_type="N") e_homo = 0.0_dp e_lumo = 0.0_dp @@ -496,20 +477,20 @@ SUBROUTINE rt_initialize_rho_from_ks(rtp,matrix_ks,matrix_s,nelectron_spin,ortho IF(SIZE(matrix_ks)==1) nelectron_spin_real=nelectron_spin_real/2 CALL density_matrix_trs4(rho_old(re)%matrix, matrix_ks(ispin)%matrix, S_minus_half, & nelectron_spin_real, rtp%filter_eps, e_homo, e_lumo, e_mu, .FALSE., tmp,& - max_iter_lanczos=rtp%lanzcos_max_iter, eps_lanczos=rtp%lanzcos_threshold, error=error) - IF(SIZE(matrix_ks)==1) CALL cp_dbcsr_scale(rho_old(re)%matrix,2.0_dp,error=error) + max_iter_lanczos=rtp%lanzcos_max_iter, eps_lanczos=rtp%lanzcos_threshold) + IF(SIZE(matrix_ks)==1) CALL cp_dbcsr_scale(rho_old(re)%matrix,2.0_dp) IF(orthonormal) THEN - CALL cp_dbcsr_multiply("N","N",one,S_half,rho_old(re)%matrix,zero,tmp,filter_eps=rtp%filter_eps_small,error=error) - CALL cp_dbcsr_multiply("N","N",one,tmp,S_half,zero,rho_old(re)%matrix,filter_eps=rtp%filter_eps_small,error=error) + CALL cp_dbcsr_multiply("N","N",one,S_half,rho_old(re)%matrix,zero,tmp,filter_eps=rtp%filter_eps_small) + CALL cp_dbcsr_multiply("N","N",one,tmp,S_half,zero,rho_old(re)%matrix,filter_eps=rtp%filter_eps_small) ENDIF - CALL cp_dbcsr_filter(rho_old(re)%matrix,eps=rtp%filter_eps,error=error) + CALL cp_dbcsr_filter(rho_old(re)%matrix,eps=rtp%filter_eps) END DO DO i=1,SIZE(rho_new) - CALL cp_dbcsr_copy(rho_new(i)%matrix,rho_old(i)%matrix,error=error) + CALL cp_dbcsr_copy(rho_new(i)%matrix,rho_old(i)%matrix) ENDDO - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp) END SUBROUTINE rt_initialize_rho_from_ks ! ***************************************************************************** @@ -518,11 +499,10 @@ END SUBROUTINE rt_initialize_rho_from_ks !> \param mos ... !> \param matrix_s ... !> \param orthonormal ... -!> \param error ... !> \author Samuel Andermatt (08.15) ! ***************************************************************************** - SUBROUTINE rt_initialize_rho_from_mos(rtp,mos,matrix_s,orthonormal,error) + SUBROUTINE rt_initialize_rho_from_mos(rtp,mos,matrix_s,orthonormal) TYPE(rt_prop_type), POINTER :: rtp TYPE(mo_set_p_type), DIMENSION(:), & @@ -530,7 +510,6 @@ SUBROUTINE rt_initialize_rho_from_mos(rtp,mos,matrix_s,orthonormal,error) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_s LOGICAL :: orthonormal - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_initialize_rho_from_mos', & routineP = moduleN//':'//routineN @@ -542,34 +521,34 @@ SUBROUTINE rt_initialize_rho_from_mos(rtp,mos,matrix_s,orthonormal,error) POINTER :: rho_new, rho_old TYPE(cp_dbcsr_type), POINTER :: S_half, S_minus_half, tmp - CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new,error=error) + CALL get_rtp(rtp=rtp,rho_old=rho_old,rho_new=rho_new) IF(orthonormal) THEN - CALL get_rtp(rtp=rtp,S_half=S_half,S_minus_half=S_minus_half,error=error) + CALL get_rtp(rtp=rtp,S_half=S_half,S_minus_half=S_minus_half) NULLIFY(tmp) ALLOCATE(tmp) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=rho_old(1)%matrix,matrix_type="N",error=error) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=rho_old(1)%matrix,matrix_type="N") !The inverse of S will be calculated twice in the first step, but preventing that would make things more complicated CALL matrix_sqrt_Newton_Schulz(S_half,S_minus_half,matrix_s(1)%matrix,rtp%filter_eps,& - rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter,error=error) + rtp%newton_schulz_order,rtp%lanzcos_threshold,rtp%lanzcos_max_iter) ENDIF DO ispin=1,SIZE(mos) re=2*ispin-1 alpha=3.0_dp-REAL(SIZE(mos),dp) - CALL cp_dbcsr_set(rho_old(re)%matrix,0.0_dp,error=error) - CALL cp_fm_get_info(mos(ispin)%mo_set%mo_coeff,ncol_global=ncol,error=error) + CALL cp_dbcsr_set(rho_old(re)%matrix,0.0_dp) + CALL cp_fm_get_info(mos(ispin)%mo_set%mo_coeff,ncol_global=ncol) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=rho_old(re)%matrix,& - matrix_v=mos(ispin)%mo_set%mo_coeff,ncol=ncol,alpha=alpha,keep_sparsity=.FALSE.,error=error) + matrix_v=mos(ispin)%mo_set%mo_coeff,ncol=ncol,alpha=alpha,keep_sparsity=.FALSE.) IF(orthonormal) THEN - CALL cp_dbcsr_multiply("N","N",one,S_half,rho_old(re)%matrix,zero,tmp,filter_eps=rtp%filter_eps_small,error=error) - CALL cp_dbcsr_multiply("N","N",one,tmp,S_half,zero,rho_old(re)%matrix,filter_eps=rtp%filter_eps_small,error=error) + CALL cp_dbcsr_multiply("N","N",one,S_half,rho_old(re)%matrix,zero,tmp,filter_eps=rtp%filter_eps_small) + CALL cp_dbcsr_multiply("N","N",one,tmp,S_half,zero,rho_old(re)%matrix,filter_eps=rtp%filter_eps_small) ENDIF - CALL cp_dbcsr_filter(rho_old(re)%matrix,eps=rtp%filter_eps,error=error) - CALL cp_dbcsr_copy(rho_new(re)%matrix,rho_old(re)%matrix,error=error) + CALL cp_dbcsr_filter(rho_old(re)%matrix,eps=rtp%filter_eps) + CALL cp_dbcsr_copy(rho_new(re)%matrix,rho_old(re)%matrix) END DO - IF(orthonormal) CALL cp_dbcsr_deallocate_matrix(tmp,error=error) + IF(orthonormal) CALL cp_dbcsr_deallocate_matrix(tmp) END SUBROUTINE rt_initialize_rho_from_mos diff --git a/src/environment.F b/src/environment.F index c748e405ee..b747a68b7c 100644 --- a/src/environment.F +++ b/src/environment.F @@ -355,7 +355,6 @@ END SUBROUTINE echo_all_process_host !> \param root_section ... !> \param para_env ... !> \param globenv the globenv -!> \param error ... !> \author fawzi !> \note !> The following routines need to be synchronized wrt. adding/removing @@ -364,12 +363,11 @@ END SUBROUTINE echo_all_process_host !> f77_interface:f_env_add_defaults, f77_interface:f_env_rm_defaults, !> f77_interface:create_force_env, f77_interface:destroy_force_env ! ***************************************************************************** - SUBROUTINE cp2k_read(root_section,para_env,globenv,error) + SUBROUTINE cp2k_read(root_section,para_env,globenv) TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp2k_read', & routineP = moduleN//':'//routineN @@ -384,32 +382,32 @@ SUBROUTINE cp2k_read(root_section,para_env,globenv,error) ! try to use better names for the local log if it is not too late CALL section_vals_val_get(root_section,"GLOBAL%OUTPUT_FILE_NAME",& - c_val=c_val,error=error) + c_val=c_val) IF (c_val/="") THEN CALL cp_logger_set(logger,& local_filename=TRIM(c_val)//"_localLog") END IF - CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=c_val,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=c_val) IF (c_val/="") THEN CALL cp_logger_set(logger,local_filename=TRIM(c_val)//"_localLog") END IF logger%iter_info%project_name=c_val - CALL section_vals_val_get(root_section,"GLOBAL%PRINT_LEVEL",i_val=logger%iter_info%print_level,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%PRINT_LEVEL",i_val=logger%iter_info%print_level) ! *** Read the CP2K section *** - CALL read_cp2k_section(root_section,para_env,globenv,error=error) + CALL read_cp2k_section(root_section,para_env,globenv) iw = cp_print_key_unit_nr(logger,root_section,"GLOBAL%PRINT/BASIC_DATA_TYPES",& - extension=".Log",error=error) + extension=".Log") IF (iw>0) CALL print_kind_info(iw) CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%PRINT/BASIC_DATA_TYPES",error=error) + "GLOBAL%PRINT/BASIC_DATA_TYPES") iw = cp_print_key_unit_nr(logger,root_section,"GLOBAL%PRINT/PHYSCON",& - extension=".Log",error=error) + extension=".Log") IF (iw>0) CALL write_physcon(iw) CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%PRINT/PHYSCON",error=error) + "GLOBAL%PRINT/PHYSCON") END SUBROUTINE cp2k_read @@ -418,19 +416,16 @@ END SUBROUTINE cp2k_read !> \param root_section ... !> \param para_env ... !> \param globenv the global environment to initialize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> if possible do the initializations here as the environement !> (error,...) is setup, instaed of cp2k_init ! ***************************************************************************** - SUBROUTINE cp2k_setup(root_section,para_env,globenv,error) + SUBROUTINE cp2k_setup(root_section,para_env,globenv) TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp2k_setup', & routineP = moduleN//':'//routineN @@ -443,49 +438,45 @@ SUBROUTINE cp2k_setup(root_section,para_env,globenv,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Initialize the parallel random number generator CALL init_rng() iw = cp_print_key_unit_nr(logger,root_section,"GLOBAL%PRINT/RNG_MATRICES",& - extension=".Log",error=error) + extension=".Log") IF (iw > 0) THEN CALL write_rng_matrices(iw) END IF CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%PRINT/RNG_MATRICES",& - error=error) + "GLOBAL%PRINT/RNG_MATRICES") ! Initialize a global normally Gaussian distributed (pseudo)random number stream - CALL section_vals_val_get(root_section,"GLOBAL%SEED",i_val=input_seed,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%SEED",i_val=input_seed) initial_seed(:,:) = REAL(input_seed,KIND=dp) CALL create_rng_stream(rng_stream=globenv%gaussian_rng_stream,& name="Global Gaussian random numbers",& distribution_type=GAUSSIAN,& seed=initial_seed,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) iw = cp_print_key_unit_nr(logger,root_section,"GLOBAL%PRINT/RNG_CHECK",& - extension=".Log",error=error) + extension=".Log") IF (iw > 0) THEN - CALL check_rng(iw,para_env%ionode,error) + CALL check_rng(iw,para_env%ionode) END IF CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%PRINT/RNG_CHECK",& - error=error) + "GLOBAL%PRINT/RNG_CHECK") iw = cp_print_key_unit_nr(logger,root_section,"GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG",& - extension=".Log",error=error) + extension=".Log") IF (iw > 0) THEN - CALL write_rng_stream(globenv%gaussian_rng_stream,iw,write_all=.TRUE.,error=error) + CALL write_rng_stream(globenv%gaussian_rng_stream,iw,write_all=.TRUE.) END IF CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG",& - error=error) + "GLOBAL%PRINT/GLOBAL_GAUSSIAN_RNG") END SUBROUTINE cp2k_setup @@ -495,7 +486,6 @@ END SUBROUTINE cp2k_setup !> \param root_section ... !> \param para_env ... !> \param globenv ... -!> \param error ... !> \par History !> 06-2005 [created] !> \author MI @@ -503,12 +493,11 @@ END SUBROUTINE cp2k_setup !> Should not be required anymore once everything is converted !> to get information directly from the input structure ! ***************************************************************************** - SUBROUTINE read_global_section(root_section,para_env,globenv,error) + SUBROUTINE read_global_section(root_section,para_env,globenv) TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_global_section', & routineP = moduleN//':'//routineN, start_section_label = "GLOBAL" @@ -546,40 +535,40 @@ SUBROUTINE read_global_section(root_section,para_env,globenv,error) failure = .FALSE. NULLIFY(dft_section,global_section, i_force_eval) - global_section => section_vals_get_subs_vals(root_section,"GLOBAL",error=error) - CALL section_vals_val_get(global_section,"BLACS_GRID",i_val=globenv%blacs_grid_layout,error=error) - CALL section_vals_val_get(global_section,"BLACS_REPEATABLE",l_val=globenv%blacs_repeatable,error=error) - CALL section_vals_val_get(global_section,"PREFERRED_DIAG_LIBRARY",i_val=i_diag,error=error) - CALL section_vals_val_get(global_section,"ELPA_KERNEL",i_val=globenv%k_elpa,error=error) - CALL section_vals_val_get(global_section,"PREFERRED_FFT_LIBRARY",i_val=i_fft,error=error) - - CALL section_vals_val_get(global_section,"PRINT_LEVEL",i_val=print_level,error=error) - CALL section_vals_val_get(global_section,"PROGRAM_NAME",i_val=globenv%prog_name_id,error=error) - CALL section_vals_val_get(global_section,"FFT_POOL_SCRATCH_LIMIT",i_val=globenv%fft_pool_scratch_limit,error=error) - CALL section_vals_val_get(global_section,"FFTW_PLAN_TYPE",i_val=globenv%fftw_plan_type,error=error) - CALL section_vals_val_get(global_section,"PROJECT_NAME",c_val=project_name,error=error) - CALL section_vals_val_get(global_section,"FFTW_WISDOM_FILE_NAME",c_val=globenv%fftw_wisdom_file_name,error=error) - CALL section_vals_val_get(global_section,"RUN_TYPE",i_val=globenv%run_type_id,error=error) + global_section => section_vals_get_subs_vals(root_section,"GLOBAL") + CALL section_vals_val_get(global_section,"BLACS_GRID",i_val=globenv%blacs_grid_layout) + CALL section_vals_val_get(global_section,"BLACS_REPEATABLE",l_val=globenv%blacs_repeatable) + CALL section_vals_val_get(global_section,"PREFERRED_DIAG_LIBRARY",i_val=i_diag) + CALL section_vals_val_get(global_section,"ELPA_KERNEL",i_val=globenv%k_elpa) + CALL section_vals_val_get(global_section,"PREFERRED_FFT_LIBRARY",i_val=i_fft) + + CALL section_vals_val_get(global_section,"PRINT_LEVEL",i_val=print_level) + CALL section_vals_val_get(global_section,"PROGRAM_NAME",i_val=globenv%prog_name_id) + CALL section_vals_val_get(global_section,"FFT_POOL_SCRATCH_LIMIT",i_val=globenv%fft_pool_scratch_limit) + CALL section_vals_val_get(global_section,"FFTW_PLAN_TYPE",i_val=globenv%fftw_plan_type) + CALL section_vals_val_get(global_section,"PROJECT_NAME",c_val=project_name) + CALL section_vals_val_get(global_section,"FFTW_WISDOM_FILE_NAME",c_val=globenv%fftw_wisdom_file_name) + CALL section_vals_val_get(global_section,"RUN_TYPE",i_val=globenv%run_type_id) CALL cp2k_get_walltime(section=global_section, keyword_name="WALLTIME",& - walltime=globenv%cp2k_target_time, error=error) - CALL section_vals_val_get(global_section,"TRACE",l_val=trace,error=error) - CALL section_vals_val_get(global_section,"TRACE_MASTER",l_val=trace_MASTER,error=error) - CALL section_vals_val_get(global_section,"TRACE_MAX",i_val=trace_max,error=error) - CALL section_vals_val_get(global_section,"TRACE_ROUTINES",explicit=explicit,error=error) + walltime=globenv%cp2k_target_time) + CALL section_vals_val_get(global_section,"TRACE",l_val=trace) + CALL section_vals_val_get(global_section,"TRACE_MASTER",l_val=trace_MASTER) + CALL section_vals_val_get(global_section,"TRACE_MAX",i_val=trace_max) + CALL section_vals_val_get(global_section,"TRACE_ROUTINES",explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(global_section,"TRACE_ROUTINES",c_vals=trace_routines,error=error) + CALL section_vals_val_get(global_section,"TRACE_ROUTINES",c_vals=trace_routines) ELSE NULLIFY(trace_routines) ENDIF - CALL section_vals_val_get(global_section,"FLUSH_SHOULD_FLUSH",l_val=flush_should_flush,error=error) - CALL section_vals_val_get(global_section,"ECHO_ALL_HOSTS",l_val=do_echo_all_hosts,error=error) - force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL",error=error) - CALL section_vals_get(force_env_sections, n_repetition=nforce_eval, error=error) - logger=>cp_error_get_logger(error) + CALL section_vals_val_get(global_section,"FLUSH_SHOULD_FLUSH",l_val=flush_should_flush) + CALL section_vals_val_get(global_section,"ECHO_ALL_HOSTS",l_val=do_echo_all_hosts) + force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL") + CALL section_vals_get(force_env_sections, n_repetition=nforce_eval) + logger=>cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,global_section,"PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") - CALL fm_setup(global_section,error) + CALL fm_setup(global_section) IF(trace .AND. (.NOT. trace_master .OR. para_env%mepos==0)) THEN unit_nr = -1 @@ -593,7 +582,7 @@ SUBROUTINE read_global_section(root_section,para_env,globenv,error) END IF ENDIF - CALL section_vals_val_get(global_section,"TIMINGS%TIME_MPI",l_val=time_mpi,error=error) + CALL section_vals_val_get(global_section,"TIMINGS%TIME_MPI",l_val=time_mpi) IF (time_mpi) THEN mp_external_timeset=>timeset mp_external_timestop=>timestop @@ -632,7 +621,7 @@ SUBROUTINE read_global_section(root_section,para_env,globenv,error) ! default MD globenv%run_type_id = mol_dyn_run ELSE - CALL section_vals_val_get(force_env_sections,"METHOD",i_val=method_name_id,error=error) + CALL section_vals_val_get(force_env_sections,"METHOD",i_val=method_name_id) SELECT CASE (method_name_id) CASE (do_fist) globenv%run_type_id = mol_dyn_run @@ -720,30 +709,30 @@ SUBROUTINE read_global_section(root_section,para_env,globenv,error) !$ num_threads=omp_get_max_threads() IF (output_unit > 0 ) THEN WRITE (UNIT=output_unit,FMT=*) - CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval, error) + CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval) DO iforce_eval = 1, nforce_eval dft_section => section_vals_get_subs_vals3(force_env_sections,"DFT",& - i_rep_section=i_force_eval(iforce_eval),error=error) + i_rep_section=i_force_eval(iforce_eval)) qmmm_section => section_vals_get_subs_vals3(force_env_sections,"QMMM",& - i_rep_section=i_force_eval(iforce_eval),error=error) + i_rep_section=i_force_eval(iforce_eval)) CALL section_vals_val_get(dft_section,"BASIS_SET_FILE_NAME",& - c_val=basis_set_file_name, error=error) + c_val=basis_set_file_name) CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",& - c_val=potential_file_name, error=error) + c_val=potential_file_name) CALL section_vals_val_get(qmmm_section,"MM_POTENTIAL_FILE_NAME",& - c_val=mm_potential_file_name, error=error) + c_val=mm_potential_file_name) ! SUBSYS - If any subsys_section => section_vals_get_subs_vals3(force_env_sections,"SUBSYS",& - i_rep_section=i_force_eval(iforce_eval),error=error) - CALL section_vals_get(subsys_section, explicit=explicit, error=error) + i_rep_section=i_force_eval(iforce_eval)) + CALL section_vals_get(subsys_section, explicit=explicit) coord_file_name = "__STD_INPUT__" IF (explicit) THEN CALL section_vals_val_get(subsys_section,"TOPOLOGY%COORD_FILE_NAME",& - n_rep_val=n_rep_val, error=error) + n_rep_val=n_rep_val) IF (n_rep_val==1) THEN CALL section_vals_val_get(subsys_section,"TOPOLOGY%COORD_FILE_NAME",& - c_val=coord_file_name, error=error) + c_val=coord_file_name) END IF END IF CALL integer_to_string(i_force_eval(iforce_eval),env_num) @@ -761,15 +750,15 @@ SUBROUTINE read_global_section(root_section,para_env,globenv,error) DEALLOCATE(i_force_eval) NULLIFY (enum1,enum2,keyword,section) - CALL create_global_section(section,error=error) - keyword => section_get_keyword(section,"PROGRAM_NAME",error=error) - CALL keyword_get(keyword,enum=enum1,error=error) - keyword => section_get_keyword(section,"RUN_TYPE",error=error) - CALL keyword_get(keyword,enum=enum2,error=error) + CALL create_global_section(section) + keyword => section_get_keyword(section,"PROGRAM_NAME") + CALL keyword_get(keyword,enum=enum1) + keyword => section_get_keyword(section,"RUN_TYPE") + CALL keyword_get(keyword,enum=enum2) WRITE (UNIT=output_unit,FMT="(T2,A,T41,A40)")& start_section_label//"| Method name",& - ADJUSTR(TRIM(enum_i2c(enum1,globenv%prog_name_id,error=error))),& + ADJUSTR(TRIM(enum_i2c(enum1,globenv%prog_name_id))),& start_section_label//"| Project name",& ADJUSTR(project_name(:40)),& start_section_label//"| Preferred FFT library",& @@ -777,14 +766,14 @@ SUBROUTINE read_global_section(root_section,para_env,globenv,error) start_section_label//"| Preferred diagonalization lib.",& ADJUSTR(globenv%diag_library(:40)),& start_section_label//"| Run type",& - ADJUSTR(TRIM(enum_i2c(enum2,globenv%run_type_id,error=error))) + ADJUSTR(TRIM(enum_i2c(enum2,globenv%run_type_id))) - CALL section_release(section,error=error) + CALL section_release(section) - CALL section_vals_val_get(global_section,"ALLTOALL_SGL",l_val=ata,error=error) + CALL section_vals_val_get(global_section,"ALLTOALL_SGL",l_val=ata) WRITE (UNIT=output_unit,FMT="(T2,A,T80,L1)")& start_section_label//"| All-to-all communication in single precision",ata - CALL section_vals_val_get(global_section,"EXTENDED_FFT_LENGTHS",l_val=efl,error=error) + CALL section_vals_val_get(global_section,"EXTENDED_FFT_LENGTHS",l_val=efl) WRITE (UNIT=output_unit,FMT="(T2,A,T80,L1)")& start_section_label//"| FFTs using library dependent lengths",efl @@ -830,7 +819,7 @@ SUBROUTINE read_global_section(root_section,para_env,globenv,error) END IF CALL cp_print_key_finished_output(output_unit,logger,global_section,& - "PROGRAM_RUN_INFO", error=error) + "PROGRAM_RUN_INFO") END SUBROUTINE read_global_section @@ -839,17 +828,15 @@ END SUBROUTINE read_global_section !> \param root_section ... !> \param para_env ... !> \param globenv ... -!> \param error ... !> \par History !> 2-Dec-2000 (JGH) added default fft library !> \author JGH,MK ! ***************************************************************************** - SUBROUTINE read_cp2k_section(root_section,para_env,globenv,error) + SUBROUTINE read_cp2k_section(root_section,para_env,globenv) TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_cp2k_section', & routineP = moduleN//':'//routineN @@ -858,17 +845,17 @@ SUBROUTINE read_cp2k_section(root_section,para_env,globenv,error) TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: global_section - global_section => section_vals_get_subs_vals(root_section,"GLOBAL",error=error) - CALL read_global_section(root_section,para_env,globenv,error=error) - logger => cp_error_get_logger(error) + global_section => section_vals_get_subs_vals(root_section,"GLOBAL") + CALL read_global_section(root_section,para_env,globenv) + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,global_section,"PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") - CALL fft_setup_library(globenv, para_env, global_section, output_unit,error=error) - CALL diag_setup_library(globenv, output_unit,error=error) + CALL fft_setup_library(globenv, para_env, global_section, output_unit) + CALL diag_setup_library(globenv, output_unit) CALL cp_print_key_finished_output(output_unit,logger,global_section,& - "PROGRAM_RUN_INFO", error=error) + "PROGRAM_RUN_INFO") END SUBROUTINE read_cp2k_section @@ -878,7 +865,6 @@ END SUBROUTINE read_cp2k_section !> \param para_env ... !> \param global_section ... !> \param output_unit ... -!> \param error ... !> \par History !> 2-Dec-2000 (JGH) added default fft library !> Nov-2013 (MI) refactoring @@ -886,13 +872,12 @@ END SUBROUTINE read_cp2k_section ! ***************************************************************************** - SUBROUTINE fft_setup_library(globenv, para_env,global_section, output_unit,error) + SUBROUTINE fft_setup_library(globenv, para_env,global_section, output_unit) TYPE(global_environment_type), POINTER :: globenv TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: global_section INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fft_setup_library', & routineP = moduleN//':'//routineN @@ -919,12 +904,11 @@ SUBROUTINE fft_setup_library(globenv, para_env,global_section, output_unit,error ! *** Initialize FFT library with the user's prefered FFT library *** CALL init_fft(fftlib=TRIM(globenv%default_fft_library),& - alltoall=section_get_lval(global_section,"ALLTOALL_SGL",error), & - fftsg_sizes=.NOT.section_get_lval(global_section,"EXTENDED_FFT_LENGTHS",error), & + alltoall=section_get_lval(global_section,"ALLTOALL_SGL"), & + fftsg_sizes=.NOT.section_get_lval(global_section,"EXTENDED_FFT_LENGTHS"), & pool_limit=globenv%fft_pool_scratch_limit,& wisdom_file=globenv%fftw_wisdom_file_name,& - plan_style=globenv%fftw_plan_type,& - error=error) + plan_style=globenv%fftw_plan_type) ! *** Check for FFT library *** CALL fft3d(1,n,zz,status=stat) @@ -938,12 +922,11 @@ SUBROUTINE fft_setup_library(globenv, para_env,global_section, output_unit,error ENDIF globenv%default_fft_library="FFTW3" CALL init_fft(fftlib=TRIM(globenv%default_fft_library),& - alltoall=section_get_lval(global_section,"ALLTOALL_SGL",error), & - fftsg_sizes=.NOT.section_get_lval(global_section,"EXTENDED_FFT_LENGTHS",error), & + alltoall=section_get_lval(global_section,"ALLTOALL_SGL"), & + fftsg_sizes=.NOT.section_get_lval(global_section,"EXTENDED_FFT_LENGTHS"), & pool_limit=globenv%fft_pool_scratch_limit,& wisdom_file=globenv%fftw_wisdom_file_name,& - plan_style=globenv%fftw_plan_type,& - error=error) + plan_style=globenv%fftw_plan_type) CALL fft3d(1,n,zz,status=stat) ENDIF @@ -958,12 +941,11 @@ SUBROUTINE fft_setup_library(globenv, para_env,global_section, output_unit,error globenv%default_fft_library="FFTSG" CALL init_fft(fftlib=TRIM(globenv%default_fft_library),& - alltoall=section_get_lval(global_section,"ALLTOALL_SGL",error), & - fftsg_sizes=.NOT.section_get_lval(global_section,"EXTENDED_FFT_LENGTHS",error), & + alltoall=section_get_lval(global_section,"ALLTOALL_SGL"), & + fftsg_sizes=.NOT.section_get_lval(global_section,"EXTENDED_FFT_LENGTHS"), & pool_limit=globenv%fft_pool_scratch_limit,& wisdom_file=globenv%fftw_wisdom_file_name,& - plan_style=globenv%fftw_plan_type,& - error=error) + plan_style=globenv%fftw_plan_type) CALL fft3d(1,n,zz,status=stat) IF (stat /= 0) THEN @@ -982,13 +964,11 @@ END SUBROUTINE fft_setup_library !> !> \param globenv ... !> \param output_unit ... -!> \param error ... !> \author MI ! ***************************************************************************** - SUBROUTINE diag_setup_library(globenv, output_unit,error) + SUBROUTINE diag_setup_library(globenv, output_unit) TYPE(global_environment_type), POINTER :: globenv INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'diag_setup_library', & routineP = moduleN//':'//routineN @@ -997,7 +977,7 @@ SUBROUTINE diag_setup_library(globenv, output_unit,error) switched = .FALSE. - CALL diag_init(diag_lib=TRIM(globenv%diag_library), switched=switched,k_elpa=globenv%k_elpa,error=error) + CALL diag_init(diag_lib=TRIM(globenv%diag_library), switched=switched,k_elpa=globenv%k_elpa) IF(switched) THEN @@ -1014,11 +994,9 @@ END SUBROUTINE diag_setup_library ! ***************************************************************************** !> \brief ... !> \param glob_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE fm_setup(glob_section,error) + SUBROUTINE fm_setup(glob_section) TYPE(section_vals_type), POINTER :: glob_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_setup', & routineP = moduleN//':'//routineN @@ -1027,16 +1005,16 @@ SUBROUTINE fm_setup(glob_section,error) LOGICAL :: force_me TYPE(section_vals_type), POINTER :: fm_section - fm_section => section_vals_get_subs_vals(glob_section,"FM",error=error) + fm_section => section_vals_get_subs_vals(glob_section,"FM") - CALL section_vals_val_get(fm_section,"NROW_BLOCKS",i_val=nrb,error=error) - CALL section_vals_val_get(fm_section,"NCOL_BLOCKS",i_val=ncb,error=error) - CALL section_vals_val_get(fm_section,"FORCE_BLOCK_SIZE",l_val=force_me,error=error) + CALL section_vals_val_get(fm_section,"NROW_BLOCKS",i_val=nrb) + CALL section_vals_val_get(fm_section,"NCOL_BLOCKS",i_val=ncb) + CALL section_vals_val_get(fm_section,"FORCE_BLOCK_SIZE",l_val=force_me) CALL cp_fm_struct_config(nrow_block=nrb,ncol_block=ncb,force_block=force_me) CALL section_vals_val_get(fm_section,"TYPE_OF_MATRIX_MULTIPLICATION",& - i_val=multiplication_type,error=error) + i_val=multiplication_type) CALL cp_fm_setup(multiplication_type) @@ -1046,16 +1024,14 @@ END SUBROUTINE fm_setup !> \param section ... !> \param keyword_name ... !> \param walltime ... -!> \param error ... !> \par History !> none !> \author Mandes ! ***************************************************************************** - SUBROUTINE cp2k_get_walltime(section, keyword_name, walltime, error) + SUBROUTINE cp2k_get_walltime(section, keyword_name, walltime) TYPE(section_vals_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: keyword_name REAL(KIND=dp), INTENT(out) :: walltime - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp2k_get_walltime', & routineP = moduleN//':'//routineN @@ -1064,7 +1040,7 @@ SUBROUTINE cp2k_get_walltime(section, keyword_name, walltime, error) INTEGER :: ierr, itmp LOGICAL :: failure - CALL section_vals_val_get(section, keyword_name, c_val=ctmp, error=error) + CALL section_vals_val_get(section, keyword_name, c_val=ctmp) IF(ctmp == "") THEN walltime = -1.0_dp @@ -1073,17 +1049,17 @@ SUBROUTINE cp2k_get_walltime(section, keyword_name, walltime, error) walltime = 0 ! read seconds READ(ctmp(INDEX(ctmp,":",BACK=.TRUE.)+1:),FMT=*,IOSTAT=ierr) walltime - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ! read minutes READ(ctmp(INDEX(ctmp,":",BACK=.TRUE.)-2:INDEX(ctmp,":",BACK=.TRUE.)-1),FMT=*,IOSTAT=ierr) itmp walltime = walltime + REAL(60*itmp,KIND=dp) ! read hours READ(ctmp(1:INDEX(ctmp,":")-1),FMT=*,IOSTAT=ierr) itmp - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) walltime = walltime + REAL(3600*itmp,KIND=dp) ELSE READ(ctmp,FMT=*,IOSTAT=ierr) walltime - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF END IF END SUBROUTINE cp2k_get_walltime @@ -1094,7 +1070,6 @@ END SUBROUTINE cp2k_get_walltime !> \param para_env ... !> \param globenv ... !> \param wdir ... -!> \param error ... !> \par History !> none !> \author JGH,MK @@ -1105,13 +1080,12 @@ END SUBROUTINE cp2k_get_walltime !> f77_interface:f_env_add_defaults, f77_interface:f_env_rm_defaults, !> f77_interface:create_force_env, f77_interface:destroy_force_env ! ***************************************************************************** - SUBROUTINE cp2k_finalize(root_section,para_env,globenv,wdir,error) + SUBROUTINE cp2k_finalize(root_section,para_env,globenv,wdir) TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv CHARACTER(LEN=*), OPTIONAL :: wdir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp2k_finalize', & routineP = moduleN//':'//routineN @@ -1135,25 +1109,25 @@ SUBROUTINE cp2k_finalize(root_section,para_env,globenv,wdir,error) ! Clean up NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL deallocate_spherical_harmonics() CALL deallocate_orbital_pointers() CALL deallocate_md_ftable() ! finalize the fft (i.e. writes the wisdom if FFTW3 ) - CALL finalize_fft(para_env,globenv%fftw_wisdom_file_name, error) + CALL finalize_fft(para_env,globenv%fftw_wisdom_file_name) ! Write message passing performance info iw=cp_print_key_unit_nr(logger,root_section,"GLOBAL%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") CALL describe_mp_perf_env ( iw ) CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%PROGRAM_RUN_INFO", error=error) + "GLOBAL%PROGRAM_RUN_INFO") CALL collect_citations_from_ranks(para_env) iw = cp_print_key_unit_nr(logger,root_section,"GLOBAL%REFERENCES",& - extension=".Log",error=error) + extension=".Log") IF (iw>0) THEN WRITE (UNIT=iw,FMT="(/,T2,A)") REPEAT("-",79) WRITE (UNIT=iw,FMT="(T2,A,T80,A)") "-","-" @@ -1169,23 +1143,23 @@ SUBROUTINE cp2k_finalize(root_section,para_env,globenv,wdir,error) FORMAT=print_format_journal,unit=iw) ENDIF CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%REFERENCES",error=error) + "GLOBAL%REFERENCES") CALL timestop(globenv%handle) ! corresponding the "CP2K" in cp2k_init iw = cp_print_key_unit_nr(logger,root_section,"GLOBAL%TIMINGS",& - extension=".Log",error=error) - r_timings = section_get_rval(root_section,"GLOBAL%TIMINGS%THRESHOLD",error) - sort_by_self_time = section_get_lval(root_section,"GLOBAL%TIMINGS%SORT_BY_SELF_TIME",error) + extension=".Log") + r_timings = section_get_rval(root_section,"GLOBAL%TIMINGS%THRESHOLD") + sort_by_self_time = section_get_lval(root_section,"GLOBAL%TIMINGS%SORT_BY_SELF_TIME") IF (m_energy().NE.0.0_dp) THEN CALL timings_report_print(iw,r_timings,sort_by_self_time,cost_type_energy,para_env) ENDIF CALL timings_report_print(iw,r_timings,sort_by_self_time,cost_type_time,para_env) !Write the callgraph, if desired by user - CALL section_vals_val_get(root_section,"GLOBAL%CALLGRAPH",i_val=cg_mode,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%CALLGRAPH",i_val=cg_mode) IF(cg_mode /= CALLGRAPH_NONE) THEN - CALL section_vals_val_get(root_section,"GLOBAL%CALLGRAPH_FILE_NAME",c_val=cg_filename,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%CALLGRAPH_FILE_NAME",c_val=cg_filename) IF(LEN_TRIM(cg_filename) == 0) cg_filename=TRIM(logger%iter_info%project_name) IF(cg_mode==CALLGRAPH_ALL)& !incorporate mpi-rank into filename cg_filename = TRIM(cg_filename)//"_"//TRIM(ADJUSTL(cp_to_string(para_env%mepos))) @@ -1199,7 +1173,7 @@ SUBROUTINE cp2k_finalize(root_section,para_env,globenv,wdir,error) END IF CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%TIMINGS",error=error) + "GLOBAL%TIMINGS") CALL rm_mp_perf_env() @@ -1207,7 +1181,7 @@ SUBROUTINE cp2k_finalize(root_section,para_env,globenv,wdir,error) IF (para_env%ionode) THEN iw=cp_print_key_unit_nr(logger,root_section,"GLOBAL%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") ! Deleting (if existing) the external EXIT files delete_it = .FALSE. @@ -1232,7 +1206,7 @@ SUBROUTINE cp2k_finalize(root_section,para_env,globenv,wdir,error) IF (iw>0) CALL m_flush_internal(iw) CALL cp_print_key_finished_output(iw,logger,root_section,& - "GLOBAL%PROGRAM_RUN_INFO", error=error) + "GLOBAL%PROGRAM_RUN_INFO") END IF ! Release message passing environment CALL cp_rm_default_logger() diff --git a/src/et_coupling.F b/src/et_coupling.F index 13168ccefe..be9d7cccdb 100644 --- a/src/et_coupling.F +++ b/src/et_coupling.F @@ -68,12 +68,10 @@ MODULE et_coupling ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calc_et_coupling(qs_env,error) + SUBROUTINE calc_et_coupling(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_et_coupling', & routineP = moduleN//':'//routineN @@ -105,28 +103,25 @@ SUBROUTINE calc_et_coupling(qs_env,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() et_coupling_section => section_vals_get_subs_vals(qs_env%input,& - "PROPERTIES%ET_COUPLING",error=error) + "PROPERTIES%ET_COUPLING") - CALL get_qs_env(qs_env, dft_control=dft_control, para_env=para_env, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control, para_env=para_env) my_id=dft_control%qs_control%becke_control%density_type iw=cp_print_key_unit_nr(logger,et_coupling_section,"PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") ALLOCATE(rest_MO(2)) ALLOCATE(a(dft_control%nspins)) ALLOCATE(b(dft_control%nspins)) ALLOCATE(S_det(dft_control%nspins)) - CALL mpools_get(qs_env%mpools, mo_mo_fm_pools=mo_mo_fm_pools,& - error=error) - mo_mo_fmstruct => fm_pool_get_el_struct(mo_mo_fm_pools(1)%pool,& - error=error) + CALL mpools_get(qs_env%mpools, mo_mo_fm_pools=mo_mo_fm_pools) + mo_mo_fmstruct => fm_pool_get_el_struct(mo_mo_fm_pools(1)%pool) DO i=1, dft_control%nspins - mo_mo_fmstruct => fm_pool_get_el_struct(mo_mo_fm_pools(i)%pool,& - error=error) + mo_mo_fmstruct => fm_pool_get_el_struct(mo_mo_fm_pools(i)%pool) CALL get_mo_set(mo_set=qs_env%mos(i)%mo_set,& nao=nao,& @@ -134,61 +129,56 @@ SUBROUTINE calc_et_coupling(qs_env,error) CALL cp_fm_create(matrix=tmp2,& matrix_struct=qs_env%mos(i)%mo_set%mo_coeff%matrix_struct,& - name="ET_TMP"//TRIM(ADJUSTL(cp_to_string(2)))//"MATRIX",& - error=error) + name="ET_TMP"//TRIM(ADJUSTL(cp_to_string(2)))//"MATRIX") CALL cp_fm_create(matrix=inverse_mat,& matrix_struct=mo_mo_fmstruct,& - name="INVERSE"//TRIM(ADJUSTL(cp_to_string(2)))//"MATRIX",& - error=error) + name="INVERSE"//TRIM(ADJUSTL(cp_to_string(2)))//"MATRIX") CALL cp_fm_create(matrix=Tinverse,& matrix_struct=mo_mo_fmstruct,& - name="T_INVERSE"//TRIM(ADJUSTL(cp_to_string(2)))//"MATRIX",& - error=error) + name="T_INVERSE"//TRIM(ADJUSTL(cp_to_string(2)))//"MATRIX") CALL cp_fm_create(matrix=SMO,& matrix_struct=mo_mo_fmstruct,& - name="ET_SMO"//TRIM(ADJUSTL(cp_to_string(1)))//"MATRIX",& - error=error) + name="ET_SMO"//TRIM(ADJUSTL(cp_to_string(1)))//"MATRIX") DO j=1,2 NULLIFY(rest_MO(j)%matrix) CALL cp_fm_create(matrix=rest_MO(j)%matrix,& matrix_struct=mo_mo_fmstruct,& - name="ET_rest_MO"//TRIM(ADJUSTL(cp_to_string(j)))//"MATRIX",& - error=error) + name="ET_rest_MO"//TRIM(ADJUSTL(cp_to_string(j)))//"MATRIX") END DO ! calculate MO-overlap - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,qs_env%et_coupling%et_mo_coeff(i)%matrix,& - tmp2,nmo,1.0_dp,0.0_dp,error=error) + tmp2,nmo,1.0_dp,0.0_dp) CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,& qs_env%mos(i)%mo_set%mo_coeff,& - tmp2,0.0_dp,SMO,error=error) + tmp2,0.0_dp,SMO) ! calculate the MO-representation of the restraint matrix A CALL cp_dbcsr_sm_fm_multiply(qs_env%et_coupling%rest_mat(1)%matrix,& qs_env%et_coupling%et_mo_coeff(i)%matrix,& - tmp2,nmo,1.0_dp,0.0_dp,error=error) + tmp2,nmo,1.0_dp,0.0_dp) CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,& qs_env%mos(i)%mo_set%mo_coeff,& - tmp2,0.0_dp,rest_MO(1)%matrix,error=error) + tmp2,0.0_dp,rest_MO(1)%matrix) ! calculate the MO-representation of the restraint matrix D CALL cp_dbcsr_sm_fm_multiply(qs_env%et_coupling%rest_mat(2)%matrix,& qs_env%mos(i)%mo_set%mo_coeff,& - tmp2,nmo,1.0_dp,0.0_dp,error=error) + tmp2,nmo,1.0_dp,0.0_dp) CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,& qs_env%et_coupling%et_mo_coeff(i)%matrix,& - tmp2,0.0_dp,rest_MO(2)%matrix,error=error) + tmp2,0.0_dp,rest_MO(2)%matrix) - CALL cp_fm_invert(SMO,inverse_mat,S_det(i),error=error) + CALL cp_fm_invert(SMO,inverse_mat,S_det(i)) CALL cp_fm_get_info(inverse_mat, nrow_local=nrow_local, ncol_local=ncol_local,& - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) b(i)=0.0_dp DO j=1,ncol_local @@ -197,7 +187,7 @@ SUBROUTINE calc_et_coupling(qs_env,error) END DO END DO - CALL cp_fm_transpose(inverse_mat,Tinverse,error) + CALL cp_fm_transpose(inverse_mat,Tinverse) a(i)=0.0_dp DO j=1,ncol_local DO k=1,nrow_local @@ -212,12 +202,12 @@ SUBROUTINE calc_et_coupling(qs_env,error) CALL mp_sum(b(i), para_env%group) - CALL cp_fm_release(tmp2,error) - CALL cp_fm_release(rest_MO(1)%matrix,error) - CALL cp_fm_release(rest_MO(2)%matrix,error) - CALL cp_fm_release(SMO,error) - CALL cp_fm_release(Tinverse,error) - CALL cp_fm_release(inverse_mat,error) + CALL cp_fm_release(tmp2) + CALL cp_fm_release(rest_MO(1)%matrix) + CALL cp_fm_release(rest_MO(2)%matrix) + CALL cp_fm_release(SMO) + CALL cp_fm_release(Tinverse) + CALL cp_fm_release(inverse_mat) END DO DEALLOCATE(rest_MO) @@ -254,7 +244,7 @@ SUBROUTINE calc_et_coupling(qs_env,error) W_mat(1,2)=Wda !! solve WC=SCN - CALL diamat_all (S_mat,eigenv,.TRUE.,error=error) + CALL diamat_all (S_mat,eigenv,.TRUE.) ! U = S**(-1/2) U=0.0_dp U(1,1)=1.0_dp/SQRT(eigenv(1)) @@ -263,10 +253,10 @@ SUBROUTINE calc_et_coupling(qs_env,error) U=MATMUL(S_mat,tmp_mat) tmp_mat=MATMUL(W_mat,U) W_mat=MATMUL(U,tmp_mat) - CALL diamat_all (W_mat,eigenv,.TRUE.,error=error) + CALL diamat_all (W_mat,eigenv,.TRUE.) tmp_mat=MATMUL(U,W_mat) - CALL get_qs_env(qs_env, energy=energy, error=error) + CALL get_qs_env(qs_env, energy=energy) W_mat(1,1)=energy%total W_mat(2,2)=qs_env%et_coupling%energy a(1)=(energy%total+strength*Wbb)*Sda-strength*Wda @@ -289,10 +279,10 @@ SUBROUTINE calc_et_coupling(qs_env,error) ENDIF - CALL cp_dbcsr_deallocate_matrix_set(qs_env%et_coupling%rest_mat,error=error) + CALL cp_dbcsr_deallocate_matrix_set(qs_env%et_coupling%rest_mat) CALL cp_print_key_finished_output(iw,logger,et_coupling_section,& - "PROGRAM_RUN_INFO", error=error) + "PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE calc_et_coupling @@ -302,15 +292,13 @@ END SUBROUTINE calc_et_coupling !> \param becke_const ... !> \param calc_pot logical if potential has to be calculated or only_energy !> \param calculate_forces ... -!> \param error ... !> \author fschiff (01.2007) ! ***************************************************************************** - SUBROUTINE becke_restraint(qs_env,becke_const ,calc_pot,calculate_forces,error) + SUBROUTINE becke_restraint(qs_env,becke_const ,calc_pot,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type) :: becke_const LOGICAL :: calc_pot, calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'becke_restraint', & routineP = moduleN//':'//routineN @@ -348,10 +336,9 @@ SUBROUTINE becke_restraint(qs_env,becke_const ,calc_pot,calculate_forces,error) particle_set=particle_set,& rho=rho,& dft_control=dft_control,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) IF (dft_control%qs_control%becke_restraint) THEN target_val=dft_control%qs_control%becke_control%target @@ -468,12 +455,12 @@ SUBROUTINE becke_restraint(qs_env,becke_const ,calc_pot,calculate_forces,error) DO i=1, dft_control%nspins dE=dE+accurate_sum(becke_const%pw%cr3d*rho_r(i)%pw%cr3d)*dvol END DO - CALL get_qs_env(qs_env,energy=energy,error=error) + CALL get_qs_env(qs_env,energy=energy) CALL mp_sum(dE, para_env%group) dft_control%qs_control%becke_control%becke_order_p=dE energy%becke=(dE-target_val)*strength - IF(calculate_forces) CALL becke_force(qs_env,becke_const,error) + IF(calculate_forces) CALL becke_force(qs_env,becke_const) END IF CALL timestop(handle) @@ -483,14 +470,12 @@ END SUBROUTINE becke_restraint !> \brief calculates a becke contraint forces !> \param qs_env ... !> \param becke_const ... -!> \param error ... !> \author fschiff (01.2007) ! ***************************************************************************** - SUBROUTINE becke_force(qs_env,becke_const,error) + SUBROUTINE becke_force(qs_env,becke_const) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type) :: becke_const - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'becke_force', & routineP = moduleN//':'//routineN @@ -537,11 +522,10 @@ SUBROUTINE becke_force(qs_env,becke_const,error) rho=rho,& force=force,& dft_control=dft_control,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) th=1.0e-8_dp IF(dft_control%qs_control%becke_restraint)THEN diff --git a/src/et_coupling_types.F b/src/et_coupling_types.F index e280a412e7..f4396891ec 100644 --- a/src/et_coupling_types.F +++ b/src/et_coupling_types.F @@ -49,11 +49,9 @@ MODULE et_coupling_types ! ***************************************************************************** !> \brief ... !> \param et_coupling ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE et_coupling_create(et_coupling,error) + SUBROUTINE et_coupling_create(et_coupling) TYPE(et_coupling_type), POINTER :: et_coupling - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'et_coupling_create', & routineP = moduleN//':'//routineN @@ -64,7 +62,7 @@ SUBROUTINE et_coupling_create(et_coupling,error) failure=.FALSE. ALLOCATE(et_coupling, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(et_coupling%et_mo_coeff) NULLIFY(et_coupling%rest_mat) @@ -79,15 +77,13 @@ END SUBROUTINE et_coupling_create !> \param et_coupling ... !> \param et_mo_coeff ... !> \param rest_mat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_et_coupling_type(et_coupling,et_mo_coeff,rest_mat,error) + SUBROUTINE get_et_coupling_type(et_coupling,et_mo_coeff,rest_mat) TYPE(et_coupling_type), POINTER :: et_coupling TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: et_mo_coeff TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: rest_mat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_et_coupling_type', & routineP = moduleN//':'//routineN @@ -102,15 +98,13 @@ END SUBROUTINE get_et_coupling_type !> \param et_coupling ... !> \param et_mo_coeff ... !> \param rest_mat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_et_coupling_type(et_coupling,et_mo_coeff,rest_mat,error) + SUBROUTINE set_et_coupling_type(et_coupling,et_mo_coeff,rest_mat) TYPE(et_coupling_type), POINTER :: et_coupling TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: et_mo_coeff TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: rest_mat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_et_coupling_type', & routineP = moduleN//':'//routineN @@ -123,11 +117,9 @@ END SUBROUTINE set_et_coupling_type ! ***************************************************************************** !> \brief ... !> \param et_coupling ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE et_coupling_release(et_coupling,error) + SUBROUTINE et_coupling_release(et_coupling) TYPE(et_coupling_type), POINTER :: et_coupling - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'et_coupling_release', & routineP = moduleN//':'//routineN @@ -137,17 +129,17 @@ SUBROUTINE et_coupling_release(et_coupling,error) IF(ASSOCIATED(et_coupling%et_mo_coeff))THEN DO i=1,SIZE(et_coupling%et_mo_coeff) - CALL cp_fm_release(et_coupling%et_mo_coeff(i)%matrix,error=error) + CALL cp_fm_release(et_coupling%et_mo_coeff(i)%matrix) END DO DEALLOCATE(et_coupling%et_mo_coeff) END IF IF(ASSOCIATED(et_coupling%rest_mat))THEN -! CALL deallocate_matrix_set(et_coupling%rest_mat,error) +! CALL deallocate_matrix_set(et_coupling%rest_mat) DEALLOCATE(et_coupling%rest_mat) END IF DEALLOCATE(et_coupling,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE et_coupling_release END MODULE et_coupling_types diff --git a/src/ewald_environment_types.F b/src/ewald_environment_types.F index 8a762b8681..a19d2f84ef 100644 --- a/src/ewald_environment_types.F +++ b/src/ewald_environment_types.F @@ -120,7 +120,6 @@ MODULE ewald_environment_types !> \param max_ipol_iter ... !> \param interaction_cutoffs ... !> \param cell_hmat ... -!> \param error ... !> \par History !> 11/03 !> \author CJM @@ -128,7 +127,7 @@ MODULE ewald_environment_types SUBROUTINE ewald_env_get(ewald_env, ewald_type, alpha, eps_pol, epsilon, & gmax, ns_max, o_spline, group, para_env, id_nr, poisson_section, precs, & rcut, do_multipoles, max_multipole, do_ipol, max_ipol_iter, & - interaction_cutoffs, cell_hmat, error) + interaction_cutoffs, cell_hmat) TYPE(ewald_environment_type), POINTER :: ewald_env INTEGER, OPTIONAL :: ewald_type REAL(KIND=dp), OPTIONAL :: alpha, eps_pol, epsilon @@ -146,8 +145,6 @@ SUBROUTINE ewald_env_get(ewald_env, ewald_type, alpha, eps_pol, epsilon, & REAL(KIND=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: interaction_cutoffs REAL(KIND=dp), DIMENSION(3, 3), OPTIONAL :: cell_hmat - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_env_get', & routineP = moduleN//':'//routineN @@ -155,7 +152,7 @@ SUBROUTINE ewald_env_get(ewald_env, ewald_type, alpha, eps_pol, epsilon, & LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(ewald_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ewald_env),cp_failure_level,routineP,failure) IF (PRESENT(id_nr)) id_nr = ewald_env%id_nr IF (PRESENT(ewald_type)) ewald_type = ewald_env%ewald_type @@ -195,14 +192,13 @@ END SUBROUTINE ewald_env_get !> \param poisson_section ... !> \param interaction_cutoffs ... !> \param cell_hmat ... -!> \param error ... !> \par History !> 11/03 !> \author CJM ! ***************************************************************************** SUBROUTINE ewald_env_set(ewald_env, ewald_type, alpha, epsilon, eps_pol, & gmax, ns_max, precs, o_spline, para_env, id_nr, poisson_section, & - interaction_cutoffs, cell_hmat, error) + interaction_cutoffs, cell_hmat) TYPE(ewald_environment_type), POINTER :: ewald_env INTEGER, OPTIONAL :: ewald_type @@ -218,8 +214,6 @@ SUBROUTINE ewald_env_set(ewald_env, ewald_type, alpha, epsilon, eps_pol, & REAL(KIND=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: interaction_cutoffs REAL(KIND=dp), DIMENSION(3, 3), OPTIONAL :: cell_hmat - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_env_set', & routineP = moduleN//':'//routineN @@ -227,7 +221,7 @@ SUBROUTINE ewald_env_set(ewald_env, ewald_type, alpha, epsilon, eps_pol, & LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(ewald_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ewald_env),cp_failure_level,routineP,failure) IF (PRESENT(id_nr)) ewald_env%id_nr = id_nr IF (PRESENT(ewald_type)) ewald_env%ewald_type = ewald_type @@ -240,8 +234,8 @@ SUBROUTINE ewald_env_set(ewald_env, ewald_type, alpha, epsilon, eps_pol, & IF (PRESENT(o_spline)) ewald_env%o_spline = o_spline IF (PRESENT(para_env))ewald_env% para_env => para_env IF (PRESENT(poisson_section)) THEN - CALL section_vals_retain(poisson_section,error=error) - CALL section_vals_release(ewald_env%poisson_section,error=error) + CALL section_vals_retain(poisson_section) + CALL section_vals_release(ewald_env%poisson_section) ewald_env%poisson_section => poisson_section END IF IF (PRESENT(interaction_cutoffs)) ewald_env%interaction_cutoffs => & @@ -253,16 +247,13 @@ END SUBROUTINE ewald_env_set !> \brief allocates and intitializes a ewald_env !> \param ewald_env the object to create !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE ewald_env_create ( ewald_env, para_env, error ) + SUBROUTINE ewald_env_create ( ewald_env, para_env) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_env_create', & routineP = moduleN//':'//routineN @@ -273,12 +264,12 @@ SUBROUTINE ewald_env_create ( ewald_env, para_env, error ) failure=.FALSE. ALLOCATE( ewald_env, stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ewald_env%ref_count=1 last_ewald_env_id_nr=last_ewald_env_id_nr+1 ewald_env%id_nr=last_ewald_env_id_nr NULLIFY(ewald_env%poisson_section) - CALL cp_para_env_retain(para_env, error=error) + CALL cp_para_env_retain(para_env) ewald_env%para_env => para_env NULLIFY(ewald_env%interaction_cutoffs) ! allocated and initialized later END SUBROUTINE ewald_env_create @@ -286,15 +277,12 @@ END SUBROUTINE ewald_env_create ! ***************************************************************************** !> \brief retains the given ewald_env (see doc/ReferenceCounting.html) !> \param ewald_env the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE ewald_env_retain(ewald_env,error) + SUBROUTINE ewald_env_retain(ewald_env) TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_env_retain', & routineP = moduleN//':'//routineN @@ -303,23 +291,20 @@ SUBROUTINE ewald_env_retain(ewald_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(ewald_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ewald_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ewald_env),cp_failure_level,routineP,failure) + CPPrecondition(ewald_env%ref_count>0,cp_failure_level,routineP,failure) ewald_env%ref_count=ewald_env%ref_count+1 END SUBROUTINE ewald_env_retain ! ***************************************************************************** !> \brief releases the given ewald_env (see doc/ReferenceCounting.html) !> \param ewald_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE ewald_env_release(ewald_env,error) + SUBROUTINE ewald_env_release(ewald_env) TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_env_release', & routineP = moduleN//':'//routineN @@ -330,17 +315,17 @@ SUBROUTINE ewald_env_release(ewald_env,error) failure=.FALSE. IF (ASSOCIATED(ewald_env)) THEN - CPPrecondition(ewald_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ewald_env%ref_count>0,cp_failure_level,routineP,failure) ewald_env%ref_count=ewald_env%ref_count-1 IF (ewald_env%ref_count<1) THEN - CALL cp_para_env_release ( ewald_env%para_env, error ) - CALL section_vals_release(ewald_env%poisson_section,error=error) + CALL cp_para_env_release ( ewald_env%para_env) + CALL section_vals_release(ewald_env%poisson_section) IF (ASSOCIATED(ewald_env%interaction_cutoffs)) THEN DEALLOCATE(ewald_env%interaction_cutoffs, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE ( ewald_env, stat = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF END IF NULLIFY(ewald_env) @@ -350,13 +335,11 @@ END SUBROUTINE ewald_env_release !> \brief Purpose: read the EWALD section !> \param ewald_env the pointer to the ewald_env !> \param ewald_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] -University of Zurich - 2005 ! ***************************************************************************** - SUBROUTINE read_ewald_section ( ewald_env, ewald_section, error ) + SUBROUTINE read_ewald_section ( ewald_env, ewald_section) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(section_vals_type), POINTER :: ewald_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_ewald_section', & routineP = moduleN//':'//routineN @@ -372,40 +355,40 @@ SUBROUTINE read_ewald_section ( ewald_env, ewald_section, error ) TYPE(section_vals_type), POINTER :: multipole_section NULLIFY(enum, keyword, section, multipole_section) - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() failure = .FALSE. - CALL section_vals_val_get(ewald_section,"EWALD_TYPE",i_val=ewald_env%ewald_type,error=error) - CALL section_vals_val_get(ewald_section,"ALPHA",r_val=ewald_env%alpha,error=error) - CALL section_vals_val_get(ewald_section,"EWALD_ACCURACY",r_val=ewald_env%precs,error=error) + CALL section_vals_val_get(ewald_section,"EWALD_TYPE",i_val=ewald_env%ewald_type) + CALL section_vals_val_get(ewald_section,"ALPHA",r_val=ewald_env%alpha) + CALL section_vals_val_get(ewald_section,"EWALD_ACCURACY",r_val=ewald_env%precs) IF (ewald_env%ewald_type==do_ewald_none) THEN ewald_env%rcut = 0.0_dp ELSE - CALL section_vals_val_get(ewald_section,"RCUT",explicit=explicit,error=error) + CALL section_vals_val_get(ewald_section,"RCUT",explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(ewald_section,"RCUT",r_val=ewald_env%rcut,error=error) + CALL section_vals_val_get(ewald_section,"RCUT",r_val=ewald_env%rcut) ELSE - ewald_env%rcut = find_ewald_optimal_value(ewald_env%precs,error)/ewald_env%alpha + ewald_env%rcut = find_ewald_optimal_value(ewald_env%precs)/ewald_env%alpha ENDIF END IF ! we have no defaults for gmax, gmax is only needed for ewald and spme SELECT CASE ( ewald_env%ewald_type ) CASE (do_ewald_ewald, do_ewald_spme) - CALL section_vals_val_get(ewald_section,"GMAX",i_vals=gmax_read,error=error) + CALL section_vals_val_get(ewald_section,"GMAX",i_vals=gmax_read) SELECT CASE (SIZE(gmax_read,1)) CASE (1) ewald_env%gmax = gmax_read(1) CASE (3) ewald_env%gmax = gmax_read CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (ewald_env%ewald_type==do_ewald_spme) THEN - CALL section_vals_val_get(ewald_section,"O_SPLINE",i_val=ewald_env%o_spline,error=error) + CALL section_vals_val_get(ewald_section,"O_SPLINE",i_val=ewald_env%o_spline) END IF CASE (do_ewald_pme) - CALL section_vals_val_get(ewald_section,"NS_MAX",i_val=ewald_env%ns_max,error=error) - CALL section_vals_val_get(ewald_section,"EPSILON",r_val=ewald_env%epsilon,error=error) + CALL section_vals_val_get(ewald_section,"NS_MAX",i_val=ewald_env%ns_max) + CALL section_vals_val_get(ewald_section,"EPSILON",r_val=ewald_env%epsilon) CASE DEFAULT ! this should not be used for do_ewald_none ewald_env%gmax = HUGE(0) @@ -413,46 +396,46 @@ SUBROUTINE read_ewald_section ( ewald_env, ewald_section, error ) END SELECT ! Multipoles - multipole_section => section_vals_get_subs_vals(ewald_section,"MULTIPOLES",error=error) - CALL section_vals_val_get(multipole_section,"_SECTION_PARAMETERS_",l_val=ewald_env%do_multipoles,error=error) - CALL section_vals_val_get(multipole_section,"POL_SCF",i_val=ewald_env%do_ipol,error=error) - CALL section_vals_val_get(multipole_section,"EPS_POL",r_val=ewald_env%eps_pol,error=error) + multipole_section => section_vals_get_subs_vals(ewald_section,"MULTIPOLES") + CALL section_vals_val_get(multipole_section,"_SECTION_PARAMETERS_",l_val=ewald_env%do_multipoles) + CALL section_vals_val_get(multipole_section,"POL_SCF",i_val=ewald_env%do_ipol) + CALL section_vals_val_get(multipole_section,"EPS_POL",r_val=ewald_env%eps_pol) IF (ewald_env%do_multipoles) THEN SELECT CASE(ewald_env%ewald_type) CASE(do_ewald_ewald) - CALL section_vals_val_get(multipole_section,"MAX_MULTIPOLE_EXPANSION",i_val=ewald_env%max_multipole,error=error) - CALL section_vals_val_get(multipole_section,"MAX_IPOL_ITER",i_val=ewald_env%max_ipol_iter,error=error) + CALL section_vals_val_get(multipole_section,"MAX_MULTIPOLE_EXPANSION",i_val=ewald_env%max_multipole) + CALL section_vals_val_get(multipole_section,"MAX_IPOL_ITER",i_val=ewald_env%max_ipol_iter) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole code works at the moment only with standard EWALD sums.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END IF iw=cp_print_key_unit_nr(logger,ewald_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") IF ( iw > 0 ) THEN NULLIFY(keyword, enum) - CALL create_ewald_section(section,error=error) + CALL create_ewald_section(section) IF ( ewald_env%ewald_type /= do_ewald_none ) THEN - keyword => section_get_keyword(section,"EWALD_TYPE",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + keyword => section_get_keyword(section,"EWALD_TYPE") + CALL keyword_get(keyword,enum=enum) WRITE ( iw, '(/,T2,"EWALD| ",A,T67,A14 )')'Summation is done by:', & - ADJUSTR(TRIM(enum_i2c(enum,ewald_env%ewald_type,error=error))) + ADJUSTR(TRIM(enum_i2c(enum,ewald_env%ewald_type))) IF (ewald_env%do_multipoles) THEN NULLIFY(keyword, enum) - keyword => section_get_keyword(section,"MULTIPOLES%MAX_MULTIPOLE_EXPANSION",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + keyword => section_get_keyword(section,"MULTIPOLES%MAX_MULTIPOLE_EXPANSION") + CALL keyword_get(keyword,enum=enum) WRITE ( iw, '( T2,"EWALD| ",A )' ) 'Enabled Multipole Method' WRITE ( iw, '( T2,"EWALD| ",A,T67,A14 )' ) 'Max Term in Multipole Expansion :',& - ADJUSTR(TRIM(enum_i2c(enum,ewald_env%max_multipole,error=error))) + ADJUSTR(TRIM(enum_i2c(enum,ewald_env%max_multipole))) WRITE ( iw, '( T2,"EWALD| ",A,T67,3I10 )' ) 'Max number Iterations for IPOL :',& ewald_env%max_ipol_iter END IF - dummy = cp_unit_from_cp2k(ewald_env%alpha,"angstrom^-1",error=error) + dummy = cp_unit_from_cp2k(ewald_env%alpha,"angstrom^-1") WRITE ( iw, '( T2,"EWALD| ",A,A18,A,T71,F10.4 )' ) & 'Alpha parameter [','ANGSTROM^-1',']',dummy - dummy = cp_unit_from_cp2k(ewald_env%rcut,"angstrom",error=error) + dummy = cp_unit_from_cp2k(ewald_env%rcut,"angstrom") WRITE ( iw, '( T2,"EWALD| ",A,A18,A,T71,F10.4 )' ) & 'Real Space Cutoff [','ANGSTROM',']',dummy @@ -471,15 +454,15 @@ SUBROUTINE read_ewald_section ( ewald_env, ewald_section, error ) WRITE ( iw, '( T2,"EWALD| ",A,T71,I10 )' ) & 'Spline interpolation order ', ewald_env%o_spline CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSE WRITE ( iw, '( T2,"EWALD| ",T73, A )' ) 'not used' END IF - CALL section_release(section,error=error) + CALL section_release(section) END IF CALL cp_print_key_finished_output(iw,logger,ewald_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE read_ewald_section @@ -487,14 +470,11 @@ END SUBROUTINE read_ewald_section !> \brief triggers (by bisection) the optimal value for EWALD parameter x !> EXP(-x^2)/x^2 = EWALD_ACCURACY !> \param precs ... -!> \param error ... !> \retval value ... !> \author Teodoro Laino [tlaino] - University of Zurich - 12.2007 ! ***************************************************************************** - FUNCTION find_ewald_optimal_value(precs,error) RESULT(value) - REAL(KIND=dp) :: precs - TYPE(cp_error_type), INTENT(inout) :: error - REAL(KIND=dp) :: value + FUNCTION find_ewald_optimal_value(precs) RESULT(value) + REAL(KIND=dp) :: precs, value CHARACTER(len=*), PARAMETER :: routineN = 'find_ewald_optimal_value', & routineP = moduleN//':'//routineN @@ -505,7 +485,7 @@ FUNCTION find_ewald_optimal_value(precs,error) RESULT(value) failure = .FALSE. s = 0.1_dp func = EXP(-s**2)/s**2 - precs - CPPrecondition(func>0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(func>0.0_dp,cp_failure_level,routineP,failure) DO WHILE (func>0.0_dp) s = s + 0.1_dp func = EXP(-s**2)/s**2 - precs @@ -516,8 +496,8 @@ FUNCTION find_ewald_optimal_value(precs,error) RESULT(value) DO WHILE (.TRUE.) func2 = EXP(-s2**2)/s2**2 - precs func1 = EXP(-s1**2)/s1**2 - precs - CPPrecondition(func1>=0,cp_failure_level,routineP,error,failure) - CPPrecondition(func2<=0,cp_failure_level,routineP,error,failure) + CPPrecondition(func1>=0,cp_failure_level,routineP,failure) + CPPrecondition(func2<=0,cp_failure_level,routineP,failure) s = 0.5_dp * (s1 + s2) func = EXP(-s**2)/s**2 - precs IF (func > 0.0_dp) THEN diff --git a/src/ewald_pw_methods.F b/src/ewald_pw_methods.F index 204bba2117..52d6fdc910 100644 --- a/src/ewald_pw_methods.F +++ b/src/ewald_pw_methods.F @@ -58,16 +58,14 @@ MODULE ewald_pw_methods !> \param ewald_pw ... !> \param ewald_env ... !> \param cell_hmat ... -!> \param error ... !> \par History !> none !> \author JGH (15-Mar-2001) ! ***************************************************************************** -SUBROUTINE ewald_pw_grid_update( ewald_pw, ewald_env, cell_hmat, error ) +SUBROUTINE ewald_pw_grid_update( ewald_pw, ewald_env, cell_hmat) TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(ewald_environment_type), POINTER :: ewald_env REAL(KIND=dp), DIMENSION(3, 3) :: cell_hmat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_pw_grid_update', & routineP = moduleN//':'//routineN @@ -93,11 +91,11 @@ SUBROUTINE ewald_pw_grid_update( ewald_pw, ewald_env, cell_hmat, error ) CALL ewald_env_get ( ewald_env, ewald_type = ewald_type, & alpha = alpha, o_spline = o_spline,& poisson_section=poisson_section,& - cell_hmat=old_cell_hmat, error=error) + cell_hmat=old_cell_hmat) IF(ALL(cell_hmat==old_cell_hmat)) RETURN ! rebuild not needed - CALL ewald_env_set(ewald_env, cell_hmat=cell_hmat, error=error) + CALL ewald_env_set(ewald_env, cell_hmat=cell_hmat) SELECT CASE ( ewald_type ) @@ -105,46 +103,46 @@ SUBROUTINE ewald_pw_grid_update( ewald_pw, ewald_env, cell_hmat, error ) CALL ewald_pw_get ( ewald_pw, pw_big_pool = pw_big_pool, & dg = dg, poisson_env=poisson_env ) CALL pw_grid_change ( cell_hmat, pw_big_pool % pw_grid ) - CALL ewald_pw_rho0_setup ( ewald_env, pw_big_pool % pw_grid, dg ,error=error) - CALL pw_poisson_release(poisson_env,error=error) + CALL ewald_pw_rho0_setup ( ewald_env, pw_big_pool % pw_grid, dg) + CALL pw_poisson_release(poisson_env) CALL ewald_pw_set ( ewald_pw, pw_big_pool = pw_big_pool, dg = dg, & - poisson_env=poisson_env ,error=error) + poisson_env=poisson_env) CASE ( do_ewald_pme ) CALL ewald_pw_get ( ewald_pw, pw_big_pool = pw_big_pool, & pw_small_pool = pw_small_pool, dg = dg, & poisson_env=poisson_env ) IF (.NOT.ASSOCIATED(poisson_env)) THEN - CALL pw_poisson_create(poisson_env,error=error) - CALL ewald_pw_set(ewald_pw, poisson_env=poisson_env,error=error) + CALL pw_poisson_create(poisson_env) + CALL ewald_pw_set(ewald_pw, poisson_env=poisson_env) END IF CALL pw_grid_change ( cell_hmat, pw_big_pool % pw_grid ) - CALL dg_grid_change ( cell_hmat, pw_big_pool % pw_grid, pw_small_pool % pw_grid ,error=error) - CALL ewald_pw_rho0_setup ( ewald_env, pw_small_pool % pw_grid, dg ,error=error) + CALL dg_grid_change ( cell_hmat, pw_big_pool % pw_grid, pw_small_pool % pw_grid) + CALL ewald_pw_rho0_setup ( ewald_env, pw_small_pool % pw_grid, dg) CALL ewald_pw_set ( ewald_pw, pw_big_pool = pw_big_pool, & pw_small_pool = pw_small_pool, dg = dg, & - poisson_env=poisson_env ,error=error) + poisson_env=poisson_env) CASE ( do_ewald_spme ) CALL ewald_pw_get ( ewald_pw, pw_big_pool = pw_big_pool,& poisson_env=poisson_env) IF (.NOT.ASSOCIATED(poisson_env)) THEN - CALL pw_poisson_create(poisson_env,error=error) + CALL pw_poisson_create(poisson_env) END IF CALL pw_grid_change ( cell_hmat, pw_big_pool % pw_grid ) CALL ewald_pw_set ( ewald_pw, pw_big_pool = pw_big_pool, & - poisson_env=poisson_env ,error=error) + poisson_env=poisson_env) CASE ( do_ewald_none ) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (ASSOCIATED(poisson_env)) THEN ALLOCATE(pw_pools(1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) pw_pools(1)%pool => pw_big_pool - CALL pw_poisson_read_parameters(poisson_section, poisson_params, error) + CALL pw_poisson_read_parameters(poisson_section, poisson_params) CALL pw_poisson_set(poisson_env,cell_hmat=cell_hmat,parameters=poisson_params,& - use_level=1,pw_pools=pw_pools,error=error) + use_level=1,pw_pools=pw_pools) DEALLOCATE(pw_pools,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE ewald_pw_grid_update @@ -154,16 +152,14 @@ END SUBROUTINE ewald_pw_grid_update !> \param ewald_env ... !> \param pw_grid ... !> \param dg ... -!> \param error ... !> \par History !> none !> \author JGH (15-Mar-2001) ! ***************************************************************************** -SUBROUTINE ewald_pw_rho0_setup ( ewald_env, pw_grid, dg, error ) +SUBROUTINE ewald_pw_rho0_setup ( ewald_env, pw_grid, dg) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(pw_grid_type), POINTER :: pw_grid TYPE(dg_type), POINTER :: dg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_pw_rho0_setup', & routineP = moduleN//':'//routineN @@ -173,7 +169,7 @@ SUBROUTINE ewald_pw_rho0_setup ( ewald_env, pw_grid, dg, error ) REAL(dp), POINTER :: gcc( : ), zet( : ) TYPE(dg_rho0_type), POINTER :: dg_rho0 - CALL ewald_env_get ( ewald_env, alpha = alpha, ewald_type = ewald_type ,error=error) + CALL ewald_env_get ( ewald_env, alpha = alpha, ewald_type = ewald_type) CALL dg_get ( dg, dg_rho0 = dg_rho0 ) CALL dg_rho0_get ( dg_rho0, gcc = gcc, zet = zet ) @@ -192,9 +188,9 @@ SUBROUTINE ewald_pw_rho0_setup ( ewald_env, pw_grid, dg, error ) zet ( 1 ) = alpha CALL dg_rho0_set ( dg_rho0, TYPE = ewald_type, zet = zet ) - CALL dg_rho0_init ( dg_rho0, pw_grid ,error=error) + CALL dg_rho0_init ( dg_rho0, pw_grid) - CALL dg_set ( dg, dg_rho0 = dg_rho0, grid_index = grid_index ,error=error) + CALL dg_set ( dg, dg_rho0 = dg_rho0, grid_index = grid_index) END SUBROUTINE ewald_pw_rho0_setup diff --git a/src/ewald_pw_types.F b/src/ewald_pw_types.F index 49799d0fdd..d0ddd071a2 100644 --- a/src/ewald_pw_types.F +++ b/src/ewald_pw_types.F @@ -77,11 +77,9 @@ MODULE ewald_pw_types ! ***************************************************************************** !> \brief retains the structure ewald_pw_type !> \param ewald_pw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ewald_pw_retain(ewald_pw,error) + SUBROUTINE ewald_pw_retain(ewald_pw) TYPE(ewald_pw_type), POINTER :: ewald_pw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_pw_retain', & routineP = moduleN//':'//routineN @@ -90,8 +88,8 @@ SUBROUTINE ewald_pw_retain(ewald_pw,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(ewald_pw),cp_failure_level,routineP,error,failure) - CPPrecondition(ewald_pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ewald_pw),cp_failure_level,routineP,failure) + CPPrecondition(ewald_pw%ref_count>0,cp_failure_level,routineP,failure) ewald_pw%ref_count=ewald_pw%ref_count+1 END SUBROUTINE ewald_pw_retain @@ -102,14 +100,12 @@ END SUBROUTINE ewald_pw_retain !> \param cell ... !> \param cell_ref ... !> \param print_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ewald_pw_create ( ewald_pw, ewald_env, cell, cell_ref, print_section, error ) + SUBROUTINE ewald_pw_create ( ewald_pw, ewald_env, cell, cell_ref, print_section) TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(cell_type), POINTER :: cell, cell_ref TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_pw_create', & routineP = moduleN//':'//routineN @@ -121,18 +117,17 @@ SUBROUTINE ewald_pw_create ( ewald_pw, ewald_env, cell, cell_ref, print_section, NULLIFY ( dg ) failure=.FALSE. ALLOCATE ( ewald_pw, stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY ( ewald_pw % pw_big_pool ) NULLIFY ( ewald_pw % pw_small_pool ) NULLIFY ( ewald_pw % rs_desc ) NULLIFY ( ewald_pw % poisson_env ) - CALL dg_create ( dg, error ) + CALL dg_create ( dg) ewald_pw % dg => dg ewald_pw%ref_count=1 last_ewald_pw_id_nr=last_ewald_pw_id_nr+1 ewald_pw%id_nr=last_ewald_pw_id_nr - CALL ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section,& - error=error ) + CALL ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section) END SUBROUTINE ewald_pw_create !****f* ewald_pw_types/ewald_pw_release [1.0] * @@ -140,11 +135,9 @@ END SUBROUTINE ewald_pw_create ! ***************************************************************************** !> \brief releases the memory used by the ewald_pw !> \param ewald_pw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ewald_pw_release ( ewald_pw, error ) + SUBROUTINE ewald_pw_release ( ewald_pw) TYPE(ewald_pw_type), POINTER :: ewald_pw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_pw_release', & routineP = moduleN//':'//routineN @@ -155,16 +148,16 @@ SUBROUTINE ewald_pw_release ( ewald_pw, error ) CALL timeset(routineN,handle) failure=.FALSE. IF (ASSOCIATED(ewald_pw)) THEN - CPPrecondition(ewald_pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ewald_pw%ref_count>0,cp_failure_level,routineP,failure) ewald_pw%ref_count=ewald_pw%ref_count-1 IF (ewald_pw%ref_count<1) THEN - CALL pw_pool_release ( ewald_pw % pw_small_pool, error = error ) - CALL pw_pool_release ( ewald_pw % pw_big_pool, error = error ) - CALL rs_grid_release_descriptor ( ewald_pw % rs_desc, error = error ) - CALL pw_poisson_release ( ewald_pw % poisson_env, error = error ) - CALL dg_release ( ewald_pw % dg, error ) + CALL pw_pool_release ( ewald_pw % pw_small_pool) + CALL pw_pool_release ( ewald_pw % pw_big_pool) + CALL rs_grid_release_descriptor ( ewald_pw % rs_desc) + CALL pw_poisson_release ( ewald_pw % poisson_env) + CALL dg_release ( ewald_pw % dg) DEALLOCATE ( ewald_pw , stat = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY ( ewald_pw ) @@ -180,19 +173,17 @@ END SUBROUTINE ewald_pw_release !> \param cell ... !> \param cell_ref ... !> \param print_section ... -!> \param error ... !> \par History !> JGH (12-Jan-2001): Added SPME part !> JGH (15-Mar-2001): Work newly distributed between initialize, setup, !> and force routine !> \author CJM ! ***************************************************************************** - SUBROUTINE ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section, error ) + SUBROUTINE ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section) TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(cell_type), POINTER :: cell, cell_ref TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_pw_init', & routineP = moduleN//':'//routineN @@ -222,10 +213,10 @@ SUBROUTINE ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section, e NULLIFY ( pw_big_grid ) NULLIFY ( pw_small_grid, poisson_section ) - CPPrecondition(ASSOCIATED ( ewald_pw ),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED ( ewald_env ),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED ( cell ),cp_failure_level,routineP,error,failure) - CPPrecondition(ewald_pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED ( ewald_pw ),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED ( ewald_env ),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED ( cell ),cp_failure_level,routineP,failure) + CPPrecondition(ewald_pw%ref_count>0,cp_failure_level,routineP,failure) CALL ewald_env_get ( ewald_env = ewald_env,& para_env = para_env, & gmax = gmax, alpha = alpha,& @@ -233,16 +224,16 @@ SUBROUTINE ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section, e ewald_type = ewald_type, & o_spline=o_spline,& poisson_section=poisson_section,& - epsilon = epsilon ,error=error) + epsilon = epsilon) - rs_grid_section => section_vals_get_subs_vals(poisson_section,"EWALD%RS_GRID",error=error) + rs_grid_section => section_vals_get_subs_vals(poisson_section,"EWALD%RS_GRID") SELECT CASE ( ewald_type ) CASE ( do_ewald_ewald ) ! set up Classic EWALD sum - logger => cp_error_get_logger ( error ) - output_unit = cp_print_key_unit_nr(logger,print_section,"",extension=".Log",error=error) - CALL pw_grid_create( pw_big_grid, MPI_COMM_SELF ,error=error) + logger => cp_get_default_logger() + output_unit = cp_print_key_unit_nr(logger,print_section,"",extension=".Log") + CALL pw_grid_create( pw_big_grid, MPI_COMM_SELF) IF ( ANY(gmax == 2 * ( gmax / 2 )) ) THEN CALL stop_program(routineN,moduleN,__LINE__,"gmax has to be odd.") @@ -250,24 +241,24 @@ SUBROUTINE ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section, e bo ( 1, : ) = -gmax / 2 bo ( 2, : ) = +gmax / 2 CALL pw_grid_setup ( cell_ref%hmat, pw_big_grid, grid_span=HALFSPACE, bounds=bo, spherical=.TRUE., & - fft_usage=.FALSE., iounit=output_unit, error=error) + fft_usage=.FALSE., iounit=output_unit) NULLIFY ( pw_pool ) - CALL pw_pool_create ( pw_pool, pw_grid = pw_big_grid ,error=error) + CALL pw_pool_create ( pw_pool, pw_grid = pw_big_grid) ewald_pw % pw_big_pool => pw_pool - CALL pw_pool_retain ( ewald_pw % pw_big_pool ,error=error) - CALL pw_pool_release ( pw_pool ,error=error) - CALL pw_grid_release ( pw_big_grid, error ) - CALL cp_print_key_finished_output(output_unit,logger,print_section,"",error=error) + CALL pw_pool_retain ( ewald_pw % pw_big_pool) + CALL pw_pool_release ( pw_pool) + CALL pw_grid_release ( pw_big_grid) + CALL cp_print_key_finished_output(output_unit,logger,print_section,"") CASE ( do_ewald_pme ) ! set up Particle-Mesh EWALD sum - logger => cp_error_get_logger ( error ) - output_unit = cp_print_key_unit_nr(logger,print_section,"",extension=".Log",error=error) + logger => cp_get_default_logger() + output_unit = cp_print_key_unit_nr(logger,print_section,"",extension=".Log") IF (.NOT.ASSOCIATED(ewald_pw%poisson_env)) THEN - CALL pw_poisson_create(ewald_pw%poisson_env,error=error) + CALL pw_poisson_create(ewald_pw%poisson_env) END IF - CALL pw_grid_create( pw_small_grid, MPI_COMM_SELF ,error=error) - CALL pw_grid_create( pw_big_grid, para_env%group ,error=error) + CALL pw_grid_create( pw_small_grid, MPI_COMM_SELF) + CALL pw_grid_create( pw_big_grid, para_env%group) IF ( ns_max == 2 * ( ns_max / 2 ) ) THEN CALL stop_program(routineN,moduleN,__LINE__,"ns_max has to be odd.") END IF @@ -279,7 +270,7 @@ SUBROUTINE ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section, e CALL dg_pme_grid_setup ( cell_ref%hmat, npts_s, cutoff_radius, & pw_small_grid, pw_big_grid, rs_dims=(/para_env%num_pe,1/),& - iounit=output_unit, fft_usage=.TRUE., error=error ) + iounit=output_unit, fft_usage=.TRUE.) ! Write some useful info IF ( output_unit > 0 ) THEN WRITE ( output_unit, '( A,T71,E10.4 )' ) & @@ -292,88 +283,88 @@ SUBROUTINE ewald_pw_init ( ewald_pw, ewald_env, cell, cell_ref, print_section, e ! pw pools initialized NULLIFY ( pw_pool ) - CALL pw_pool_create( pw_pool, pw_grid = pw_big_grid ,error=error) + CALL pw_pool_create( pw_pool, pw_grid = pw_big_grid) ewald_pw % pw_big_pool => pw_pool - CALL pw_pool_retain ( ewald_pw % pw_big_pool ,error=error) - CALL pw_pool_release ( pw_pool ,error=error) + CALL pw_pool_retain ( ewald_pw % pw_big_pool) + CALL pw_pool_release ( pw_pool) NULLIFY ( pw_pool ) - CALL pw_pool_create( pw_pool, pw_grid = pw_small_grid ,error=error) + CALL pw_pool_create( pw_pool, pw_grid = pw_small_grid) ewald_pw%pw_small_pool => pw_pool - CALL pw_pool_retain ( ewald_pw % pw_small_pool ,error=error) - CALL pw_pool_release ( pw_pool ,error=error) + CALL pw_pool_retain ( ewald_pw % pw_small_pool) + CALL pw_pool_release ( pw_pool) NULLIFY ( rs_desc ) CALL init_input_type(input_settings,nsmax=MAXVAL ( pw_small_grid % npts(1:3) ),& rs_grid_section=rs_grid_section,ilevel=1, & - higher_grid_layout=(/-1,-1,-1/),error=error) - CALL rs_grid_create_descriptor(rs_desc,pw_big_grid, input_settings, error=error) + higher_grid_layout=(/-1,-1,-1/)) + CALL rs_grid_create_descriptor(rs_desc,pw_big_grid, input_settings) - CALL rs_grid_create(rs, rs_desc, error) - CALL rs_grid_print(rs,output_unit,error=error) - CALL rs_grid_release(rs, error) + CALL rs_grid_create(rs, rs_desc) + CALL rs_grid_print(rs,output_unit) + CALL rs_grid_release(rs) - CALL cp_print_key_finished_output(output_unit,logger,print_section,"",error=error) + CALL cp_print_key_finished_output(output_unit,logger,print_section,"") ewald_pw%rs_desc => rs_desc - CALL rs_grid_retain_descriptor ( ewald_pw % rs_desc, error) - CALL rs_grid_release_descriptor ( rs_desc, error) + CALL rs_grid_retain_descriptor ( ewald_pw % rs_desc) + CALL rs_grid_release_descriptor ( rs_desc) - CALL pw_grid_release ( pw_small_grid, error ) - CALL pw_grid_release ( pw_big_grid, error ) + CALL pw_grid_release ( pw_small_grid) + CALL pw_grid_release ( pw_big_grid) CASE ( do_ewald_spme ) ! set up the Smooth-Particle-Mesh EWALD sum - logger => cp_error_get_logger ( error ) - output_unit = cp_print_key_unit_nr(logger,print_section,"",extension=".Log",error=error) + logger => cp_get_default_logger() + output_unit = cp_print_key_unit_nr(logger,print_section,"",extension=".Log") IF (.NOT.ASSOCIATED(ewald_pw%poisson_env)) THEN - CALL pw_poisson_create(ewald_pw%poisson_env,error=error) + CALL pw_poisson_create(ewald_pw%poisson_env) END IF - CALL pw_grid_create( pw_big_grid, para_env%group ,error=error) + CALL pw_grid_create( pw_big_grid, para_env%group) npts_s = gmax CALL pw_grid_setup ( cell_ref%hmat, pw_big_grid, grid_span=HALFSPACE, npts=npts_s, spherical=.TRUE.,& - rs_dims=(/para_env%num_pe,1/), iounit=output_unit, fft_usage=.TRUE., error=error) + rs_dims=(/para_env%num_pe,1/), iounit=output_unit, fft_usage=.TRUE.) ! pw pools initialized NULLIFY ( pw_pool ) - CALL pw_pool_create(pw_pool, pw_grid=pw_big_grid,error=error) + CALL pw_pool_create(pw_pool, pw_grid=pw_big_grid) ewald_pw%pw_big_pool => pw_pool - CALL pw_pool_retain ( ewald_pw % pw_big_pool ,error=error) - CALL pw_pool_release ( pw_pool ,error=error) + CALL pw_pool_retain ( ewald_pw % pw_big_pool) + CALL pw_pool_release ( pw_pool) NULLIFY ( rs_desc ) CALL init_input_type(input_settings,nsmax=o_spline,& rs_grid_section=rs_grid_section,ilevel=1, & - higher_grid_layout=(/-1,-1,-1/),error=error) - CALL rs_grid_create_descriptor(rs_desc, pw_big_grid, input_settings, error=error) + higher_grid_layout=(/-1,-1,-1/)) + CALL rs_grid_create_descriptor(rs_desc, pw_big_grid, input_settings) - CALL rs_grid_create(rs, rs_desc, error) - CALL rs_grid_print(rs,output_unit,error=error) - CALL rs_grid_release(rs, error) - CALL cp_print_key_finished_output(output_unit,logger,print_section,"",error=error) + CALL rs_grid_create(rs, rs_desc) + CALL rs_grid_print(rs,output_unit) + CALL rs_grid_release(rs) + CALL cp_print_key_finished_output(output_unit,logger,print_section,"") ewald_pw%rs_desc => rs_desc - CALL rs_grid_retain_descriptor ( ewald_pw % rs_desc, error) - CALL rs_grid_release_descriptor ( rs_desc, error) + CALL rs_grid_retain_descriptor ( ewald_pw % rs_desc) + CALL rs_grid_release_descriptor ( rs_desc) - CALL pw_grid_release ( pw_big_grid, error ) + CALL pw_grid_release ( pw_big_grid) CASE ( do_ewald_none ) ! No EWALD sums.. CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Poisson Environment IF (ASSOCIATED(ewald_pw%poisson_env)) THEN ALLOCATE(pw_pools(1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) pw_pools(1)%pool => ewald_pw%pw_big_pool - CALL pw_poisson_read_parameters(poisson_section, poisson_params, error) + CALL pw_poisson_read_parameters(poisson_section, poisson_params) CALL pw_poisson_set(ewald_pw%poisson_env,cell_hmat=cell%hmat,parameters=poisson_params,& - use_level=1,pw_pools=pw_pools,error=error) + use_level=1,pw_pools=pw_pools) DEALLOCATE(pw_pools,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF CALL timestop(handle) END SUBROUTINE ewald_pw_init @@ -420,11 +411,10 @@ END SUBROUTINE ewald_pw_get !> \param rs_desc ... !> \param dg ... !> \param poisson_env ... -!> \param error ... !> \author CJM ! ***************************************************************************** SUBROUTINE ewald_pw_set (ewald_pw, pw_big_pool, pw_small_pool, rs_desc, dg,& - poisson_env, error ) + poisson_env) TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(pw_pool_type), OPTIONAL, POINTER :: pw_big_pool, pw_small_pool @@ -432,35 +422,34 @@ SUBROUTINE ewald_pw_set (ewald_pw, pw_big_pool, pw_small_pool, rs_desc, dg,& OPTIONAL, POINTER :: rs_desc TYPE(dg_type), OPTIONAL, POINTER :: dg TYPE(pw_poisson_type), OPTIONAL, POINTER :: poisson_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ewald_pw_set', & routineP = moduleN//':'//routineN IF ( PRESENT ( pw_big_pool ) ) THEN - CALL pw_pool_retain ( pw_big_pool ,error=error) - CALL pw_pool_release ( ewald_pw % pw_big_pool ,error=error) + CALL pw_pool_retain ( pw_big_pool) + CALL pw_pool_release ( ewald_pw % pw_big_pool) ewald_pw % pw_big_pool => pw_big_pool ENDIF IF ( PRESENT ( pw_small_pool ) ) THEN - CALL pw_pool_retain ( pw_small_pool ,error=error) - CALL pw_pool_release ( ewald_pw % pw_small_pool ,error=error) + CALL pw_pool_retain ( pw_small_pool) + CALL pw_pool_release ( ewald_pw % pw_small_pool) ewald_pw % pw_small_pool => pw_small_pool ENDIF IF ( PRESENT ( rs_desc ) ) THEN - CALL rs_grid_retain_descriptor (rs_desc, error=error) - CALL rs_grid_release_descriptor (ewald_pw % rs_desc, error=error) + CALL rs_grid_retain_descriptor (rs_desc) + CALL rs_grid_release_descriptor (ewald_pw % rs_desc) ewald_pw % rs_desc => rs_desc ENDIF IF ( PRESENT ( dg ) ) THEN - CALL dg_retain ( dg ,error=error) - CALL dg_release ( ewald_pw % dg, error = error ) + CALL dg_retain ( dg) + CALL dg_release ( ewald_pw % dg) ewald_pw % dg => dg ENDIF IF (PRESENT(poisson_env)) THEN IF (ASSOCIATED(poisson_env)) & - CALL pw_poisson_retain(poisson_env,error=error) - CALL pw_poisson_release(ewald_pw%poisson_env,error=error) + CALL pw_poisson_retain(poisson_env) + CALL pw_poisson_release(ewald_pw%poisson_env) ewald_pw%poisson_env => poisson_env END IF diff --git a/src/ewald_spline_util.F b/src/ewald_spline_util.F index 15f79c2e8c..7da02b37d4 100644 --- a/src/ewald_spline_util.F +++ b/src/ewald_spline_util.F @@ -68,14 +68,12 @@ MODULE ewald_spline_util !> \param tag ... !> \param print_section ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE Setup_Ewald_Spline(pw_grid, pw_pool, coeff, LG, gx, gy, gz, hmat, npts,& - param_section, tag, print_section, para_env, error) + param_section, tag, print_section, para_env) TYPE(pw_grid_type), POINTER :: pw_grid TYPE(pw_pool_type), POINTER :: pw_pool TYPE(pw_type), POINTER :: coeff @@ -86,7 +84,6 @@ SUBROUTINE Setup_Ewald_Spline(pw_grid, pw_pool, coeff, LG, gx, gy, gz, hmat, npt CHARACTER(LEN=*), INTENT(IN) :: tag TYPE(section_vals_type), POINTER :: print_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'Setup_Ewald_Spline', & routineP = moduleN//':'//routineN @@ -101,33 +98,31 @@ SUBROUTINE Setup_Ewald_Spline(pw_grid, pw_pool, coeff, LG, gx, gy, gz, hmat, npt ! ! Setting Up Fit Procedure ! - CPPrecondition(.NOT.ASSOCIATED(pw_grid),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(coeff),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(pw_grid),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(coeff),cp_failure_level,routineP,failure) NULLIFY(cell, pw) - CALL cell_create(cell, hmat=hmat, periodic=(/1,1,1/), error=error) - CALL pw_grid_create( pw_grid, para_env%group, local=.TRUE., error=error ) - logger => cp_error_get_logger(error) + CALL cell_create(cell, hmat=hmat, periodic=(/1,1,1/)) + CALL pw_grid_create( pw_grid, para_env%group, local=.TRUE.) + logger => cp_get_default_logger() iounit = cp_print_key_unit_nr(logger,print_section,"",& - extension=".Log",error=error) + extension=".Log") bo ( 1, 1:3 ) = 0 bo ( 2, 1:3 ) = npts(1:3) - 1 - CALL pw_grid_setup (cell%hmat, pw_grid, grid_span=HALFSPACE, bounds=bo, iounit=iounit, error=error) + CALL pw_grid_setup (cell%hmat, pw_grid, grid_span=HALFSPACE, bounds=bo, iounit=iounit) CALL cp_print_key_finished_output(iounit,logger,print_section,& - "",error=error) + "") ! pw_pool initialized - CALL pw_pool_create(pw_pool, pw_grid=pw_grid, error=error) - CALL pw_pool_create_pw ( pw_pool, pw, use_data = REALDATA3D, in_space = REALSPACE,& - error=error) - CALL pw_pool_create_pw ( pw_pool, coeff, use_data = REALDATA3D, in_space = REALSPACE,& - error=error) + CALL pw_pool_create(pw_pool, pw_grid=pw_grid) + CALL pw_pool_create_pw ( pw_pool, pw, use_data = REALDATA3D, in_space = REALSPACE) + CALL pw_pool_create_pw ( pw_pool, coeff, use_data = REALDATA3D, in_space = REALSPACE) ! Evaluate function on grid CALL eval_pw_TabLR ( pw, pw_pool, coeff, Lg, gx, gy, gz, hmat_mm=hmat,& - param_section=param_section, tag=tag, error=error) - CALL pw_pool_give_back_pw ( pw_pool, pw, error=error) - CALL cell_release(cell , error) + param_section=param_section, tag=tag) + CALL pw_pool_give_back_pw ( pw_pool, pw) + CALL cell_release(cell) END SUBROUTINE Setup_Ewald_Spline @@ -144,14 +139,12 @@ END SUBROUTINE Setup_Ewald_Spline !> \param hmat_mm ... !> \param param_section ... !> \param tag ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE eval_pw_TabLR( grid, pw_pool, TabLR, Lg, gx, gy, gz, hmat_mm,& - param_section, tag, error) + param_section, tag) TYPE(pw_type), POINTER :: grid TYPE(pw_pool_type), POINTER :: pw_pool TYPE(pw_type), POINTER :: TabLR @@ -159,7 +152,6 @@ SUBROUTINE eval_pw_TabLR( grid, pw_pool, TabLR, Lg, gx, gy, gz, hmat_mm,& REAL(KIND=dp), DIMENSION(3, 3) :: hmat_mm TYPE(section_vals_type), POINTER :: param_section CHARACTER(LEN=*), INTENT(IN) :: tag - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eval_pw_TabLR', & routineP = moduleN//':'//routineN @@ -198,24 +190,24 @@ SUBROUTINE eval_pw_TabLR( grid, pw_pool, TabLR, Lg, gx, gy, gz, hmat_mm,& IF (2*nxlim /= n1) is = 1 IF (2*nylim /= n2) js = 1 IF (2*nzlim /= n3) ks = 1 - CALL pw_zero(grid, error=error) + CALL pw_zero(grid) ! Used the full symmetry to reduce the evaluation to 1/64th !NB parallelization iii = 0 !NB allocate temporaries for Cos refactoring ALLOCATE(cos_gx(SIZE(Lg),gbo(1,1):gbo(2,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(sin_gx(SIZE(Lg),gbo(1,1):gbo(2,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cos_gy(SIZE(Lg),gbo(1,2):gbo(2,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(sin_gy(SIZE(Lg),gbo(1,2):gbo(2,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cos_gz(SIZE(Lg),gbo(1,3):gbo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(sin_gz(SIZE(Lg),gbo(1,3):gbo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !NB precalculate Cos(gx*xs1) etc for Cos refactoring DO k=gbo(1,3), gbo(2,3) my_k = k-gbo(1,3) @@ -262,9 +254,9 @@ SUBROUTINE eval_pw_TabLR( grid, pw_pool, TabLR, Lg, gx, gy, gz, hmat_mm,& act_ny = MIN(gbo(2,2),nylim)-gbo(1,2)+1 !NB temporaries for DGEMM use ALLOCATE(lhs(act_nx,NLg_loc),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rhs(act_ny,NLg_loc),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! do cos(gx) cos(gy+gz) term DO i=gbo(1,1), gbo(2,1) @@ -300,22 +292,22 @@ SUBROUTINE eval_pw_TabLR( grid, pw_pool, TabLR, Lg, gx, gy, gz, hmat_mm,& !NB deallocate temporaries for DGEMM use DEALLOCATE(lhs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rhs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !NB deallocate temporaries for Cos refactoring DEALLOCATE(cos_gx,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(sin_gx,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cos_gy,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(sin_gy,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cos_gz,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(sin_gz,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !NB parallelization ELSE ! no work for this node, just zero contribution grid%cr3d(gbo(1,1):nxlim,gbo(1,2):nylim,gbo(1,3):nzlim) = 0.0_dp @@ -339,30 +331,30 @@ SUBROUTINE eval_pw_TabLR( grid, pw_pool, TabLR, Lg, gx, gy, gz, hmat_mm,& ! ! Solve for spline coefficients ! - interp_section => section_vals_get_subs_vals(param_section,"INTERPOLATOR",error=error) - CALL section_vals_val_get(interp_section,"aint_precond",i_val=aint_precond, error=error) - CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind, error=error) - CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter, error=error) - CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r, error=error) - CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x, error=error) + interp_section => section_vals_get_subs_vals(param_section,"INTERPOLATOR") + CALL section_vals_val_get(interp_section,"aint_precond",i_val=aint_precond) + CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind) + CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter) + CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r) + CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x) ! ! Solve for spline coefficients ! CALL pw_spline_precond_create(precond,precond_kind=aint_precond,& - pool=pw_pool,pbc=.TRUE.,transpose=.FALSE.,error=error) - CALL pw_spline_do_precond(precond,grid,TabLR,error=error) - CALL pw_spline_precond_set_kind(precond,precond_kind,error=error) + pool=pw_pool,pbc=.TRUE.,transpose=.FALSE.) + CALL pw_spline_do_precond(precond,grid,TabLR) + CALL pw_spline_precond_set_kind(precond,precond_kind) success=find_coeffs(values=grid,coeffs=TabLR,& linOp=spl3_pbc,preconditioner=precond, pool=pw_pool, & eps_r=eps_r,eps_x=eps_x,& - max_iter=max_iter,error=error) - CPPostconditionNoFail(success,cp_warning_level,routineP,error) - CALL pw_spline_precond_release(precond,error=error) + max_iter=max_iter) + CPPostconditionNoFail(success,cp_warning_level,routineP) + CALL pw_spline_precond_release(precond) ! ! Check for the interpolation Spline ! CALL check_spline_interp_TabLR(hmat_mm, Lg, gx, gy, gz, TabLR, param_section,& - tag, error) + tag) CALL timestop(handle) END SUBROUTINE eval_pw_TabLR @@ -376,20 +368,17 @@ END SUBROUTINE eval_pw_TabLR !> \param TabLR ... !> \param param_section ... !> \param tag ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE check_spline_interp_TabLR(hmat_mm, Lg, gx, gy, gz, TabLR,& - param_section, tag, error) + param_section, tag) REAL(KIND=dp), DIMENSION(3, 3) :: hmat_mm REAL(KIND=dp), DIMENSION(:), POINTER :: Lg, gx, gy, gz TYPE(pw_type), POINTER :: TabLR TYPE(section_vals_type), POINTER :: param_section CHARACTER(LEN=*), INTENT(IN) :: tag - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'check_spline_interp_TabLR', & routineP = moduleN//':'//routineN @@ -401,9 +390,9 @@ SUBROUTINE check_spline_interp_TabLR(hmat_mm, Lg, gx, gy, gz, TabLR,& TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,param_section,"check_spline",& - extension="."//TRIM(tag)//"Log",error=error) + extension="."//TRIM(tag)//"Log") CALL timeset(routineN,handle) IF (iw > 0) THEN npoints = 100 @@ -434,9 +423,9 @@ SUBROUTINE check_spline_interp_TabLR(hmat_mm, Lg, gx, gy, gz, TabLR,& dzTerm = dzTerm - lg(kg)*SIN(vec(1)*xs1+vec(2)*xs2+vec(3)*xs3)*vec(3) END DO Na = SQRT(dxTerm*dxTerm + dyTerm*dyTerm + dzTerm*dzTerm) - dn = Eval_d_Interp_Spl3_pbc((/xs1,xs2,xs3/),TabLR,error) + dn = Eval_d_Interp_Spl3_pbc((/xs1,xs2,xs3/),TabLR) Nn = SQRT(DOT_PRODUCT(dn,dn)) - Fterm = Eval_Interp_Spl3_pbc((/xs1,xs2,xs3/),TabLR,error) + Fterm = Eval_Interp_Spl3_pbc((/xs1,xs2,xs3/),TabLR) tmp1 = ABS(Term-Fterm) tmp2 = SQRT(DOT_PRODUCT(dn-(/dxTerm,dyTerm,dzTerm/),dn-(/dxTerm,dyTerm,dzTerm/))) errf = errf + tmp1 @@ -453,7 +442,7 @@ SUBROUTINE check_spline_interp_TabLR(hmat_mm, Lg, gx, gy, gz, TabLR,& errd/REAL(npoints,kind=dp) END IF CALL timestop(handle) - CALL cp_print_key_finished_output(iw,logger,param_section,"check_spline", error=error) + CALL cp_print_key_finished_output(iw,logger,param_section,"check_spline") END SUBROUTINE check_spline_interp_TabLR diff --git a/src/ewalds.F b/src/ewalds.F index 6afff4a060..246bba2dc3 100644 --- a/src/ewalds.F +++ b/src/ewalds.F @@ -70,14 +70,13 @@ MODULE ewalds !> \param charges ... !> \param e_coulomb ... !> \param pv_coulomb ... -!> \param error ... !> \par History !> JGH (21-Feb-2001) : changed name !> \author CJM ! ***************************************************************************** SUBROUTINE ewald_evaluate (ewald_env, ewald_pw, cell, atomic_kind_set, particle_set,& local_particles, fg_coulomb, vg_coulomb, pv_g, use_virial, charges, e_coulomb,& - pv_coulomb, error ) + pv_coulomb) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(cell_type), POINTER :: cell @@ -94,7 +93,6 @@ SUBROUTINE ewald_evaluate (ewald_env, ewald_pw, cell, atomic_kind_set, particle_ POINTER :: charges, e_coulomb REAL(KIND=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: pv_coulomb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ewald_evaluate', & routineP = moduleN//':'//routineN @@ -135,7 +133,7 @@ SUBROUTINE ewald_evaluate (ewald_env, ewald_pw, cell, atomic_kind_set, particle_ IF (atstress) pv_coulomb=0._dp ! pointing - CALL ewald_env_get (ewald_env, alpha=alpha, group = group ,error=error) + CALL ewald_env_get (ewald_env, alpha=alpha, group = group) CALL ewald_pw_get (ewald_pw, pw_big_pool=pw_pool, dg = dg ) CALL dg_get ( dg, dg_rho0=dg_rho0 ) rho0 => dg_rho0 % density % pw % cr3d @@ -152,9 +150,9 @@ SUBROUTINE ewald_evaluate (ewald_env, ewald_pw, cell, atomic_kind_set, particle_ CALL structure_factor_allocate ( pw_grid % bounds, nnodes, exp_igr) ALLOCATE (summe(1:pw_grid%ngpts_cut),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (charge(1:nnodes),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ! Initializing vg_coulomb and fg_coulomb vg_coulomb = 0.0_dp @@ -293,7 +291,7 @@ SUBROUTINE ewald_evaluate (ewald_env, ewald_pw, cell, atomic_kind_set, particle_ CALL structure_factor_deallocate ( exp_igr ) DEALLOCATE ( charge, summe, STAT = isos ) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) NULLIFY ( charge ) CALL timestop(handle) @@ -310,13 +308,12 @@ END SUBROUTINE ewald_evaluate !> \param e_self ... !> \param e_neut ... !> \param charges ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** SUBROUTINE ewald_self ( ewald_env, cell, atomic_kind_set, local_particles, e_self,& - e_neut, charges, error) + e_neut, charges) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(cell_type), POINTER :: cell @@ -324,7 +321,6 @@ SUBROUTINE ewald_self ( ewald_env, cell, atomic_kind_set, local_particles, e_sel TYPE(distribution_1d_type), POINTER :: local_particles REAL(KIND=dp), INTENT(OUT) :: e_self, e_neut REAL(KIND=dp), DIMENSION(:), POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ewald_self', & routineP = moduleN//':'//routineN @@ -340,7 +336,7 @@ SUBROUTINE ewald_self ( ewald_env, cell, atomic_kind_set, local_particles, e_sel TYPE(shell_kind_type), POINTER :: shell CALL ewald_env_get ( ewald_env, ewald_type = ewald_type, & - alpha = alpha, group = group ,error=error) + alpha = alpha, group = group) q_neutg = 0.0_dp q_self = 0.0_dp q_sum = 0.0_dp @@ -355,7 +351,7 @@ SUBROUTINE ewald_self ( ewald_env, cell, atomic_kind_set, local_particles, e_sel IF(mm_radius>0.0_dp)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Array of charges not implemented for mm_radius>0.0 !!",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO ELSE @@ -365,7 +361,7 @@ SUBROUTINE ewald_self ( ewald_env, cell, atomic_kind_set, local_particles, e_sel qeff=q, shell_active=is_shell, shell=shell) nparticle_local = local_particles%n_el(iparticle_kind) IF (is_shell) THEN - CALL get_shell(shell=shell, charge_core=qcore, charge_shell=qshell, error=error) + CALL get_shell(shell=shell, charge_core=qcore, charge_shell=qshell) ! MI: the core-shell ES interaction, when core and shell belong to the same ion, is excluded ! in the nonbond correction term. Therefore, here the self interaction is computed entirely q_self = q_self + qcore*qcore*nparticle_local + qshell*qshell*nparticle_local @@ -403,13 +399,12 @@ END SUBROUTINE ewald_self !> \param local_particles ... !> \param e_self ... !> \param charges ... -!> \param error ... !> \par History !> none !> \author JHU from ewald_self ! ***************************************************************************** SUBROUTINE ewald_self_atom ( ewald_env, atomic_kind_set, local_particles, e_self,& - charges, error) + charges) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(atomic_kind_type), DIMENSION(:), & @@ -418,7 +413,6 @@ SUBROUTINE ewald_self_atom ( ewald_env, atomic_kind_set, local_particles, e_self REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: e_self(:) REAL(KIND=dp), DIMENSION(:), POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ewald_self_atom', & routineP = moduleN//':'//routineN @@ -433,7 +427,7 @@ SUBROUTINE ewald_self_atom ( ewald_env, atomic_kind_set, local_particles, e_self TYPE(atomic_kind_type), POINTER :: atomic_kind TYPE(shell_kind_type), POINTER :: shell - CALL ewald_env_get(ewald_env,ewald_type=ewald_type,alpha=alpha,error=error) + CALL ewald_env_get(ewald_env,ewald_type=ewald_type,alpha=alpha) fself = alpha*oorootpi @@ -442,7 +436,7 @@ SUBROUTINE ewald_self_atom ( ewald_env, atomic_kind_set, local_particles, e_self IF (ASSOCIATED(charges)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Atomic energy not implemented for charges",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ELSE DO iparticle_kind=1,nparticle_kind atomic_kind => atomic_kind_set(iparticle_kind) @@ -450,7 +444,7 @@ SUBROUTINE ewald_self_atom ( ewald_env, atomic_kind_set, local_particles, e_self CALL get_atomic_kind(atomic_kind=atomic_kind,qeff=q,& shell_active=is_shell,shell=shell) IF (is_shell) THEN - CALL get_shell(shell=shell,charge_core=qcore,charge_shell=qshell,error=error) + CALL get_shell(shell=shell,charge_core=qcore,charge_shell=qshell) DO iparticle_local=1,nparticle_local ii = local_particles%list(iparticle_kind)%array(iparticle_local) e_self(ii) = e_self(ii) - (qcore*qcore + qshell*qshell)*fself diff --git a/src/ewalds_multipole.F b/src/ewalds_multipole.F index b39b832f72..1d6520b8aa 100644 --- a/src/ewalds_multipole.F +++ b/src/ewalds_multipole.F @@ -101,7 +101,6 @@ MODULE ewalds_multipole !> \param do_debug ... !> \param atomic_kind_set ... !> \param mm_section ... -!> \param error ... !> \par Note !> atomic_kind_set and mm_section are between the arguments only !> for debug purpose (therefore optional) and can be avoided when this @@ -117,7 +116,7 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& cell, particle_set, local_particles, energy_local, energy_glob, e_neut, e_self,& task, do_correction_bonded, do_forces, do_stress, do_efield, radii, charges, dipoles,& quadrupoles, forces_local, forces_glob, pv_local, pv_glob, efield0, efield1,& - efield2, iw, do_debug, atomic_kind_set, mm_section, error ) + efield2, iw, do_debug, atomic_kind_set, mm_section) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(fist_nonbond_env_type), POINTER :: nonbond_env @@ -149,7 +148,6 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& OPTIONAL, POINTER :: atomic_kind_set TYPE(section_vals_type), OPTIONAL, & POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_multipole_evaluate', & routineP = moduleN//':'//routineN @@ -171,29 +169,29 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& CALL cite_reference(Aguado2003) CALL cite_reference(Laino2008) CALL timeset(routineN,handle) - CPPostcondition(ASSOCIATED(nonbond_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(nonbond_env),cp_failure_level,routineP,failure) check_debug = (debug_this_module.OR.debug_r_space.OR.debug_g_space.OR.debug_e_field.OR.debug_e_field_en)& .EQV.debug_this_module - CPPostcondition(check_debug,cp_failure_level,routineP,error,failure) + CPPostcondition(check_debug,cp_failure_level,routineP,failure) check_forces = do_forces.EQV.(PRESENT(forces_local).AND.PRESENT(forces_glob)) - CPPostcondition(check_forces,cp_failure_level,routineP,error,failure) + CPPostcondition(check_forces,cp_failure_level,routineP,failure) check_efield = do_efield.EQV.(PRESENT(efield0).OR.PRESENT(efield1).OR.PRESENT(efield2)) - CPPostcondition(check_efield,cp_failure_level,routineP,error,failure) + CPPostcondition(check_efield,cp_failure_level,routineP,failure) ! Debugging this module IF (debug_this_module.AND.do_debug) THEN ! Debug specifically real space part IF (debug_r_space) THEN CALL debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & - particle_set, local_particles, iw, debug_r_space, error) + particle_set, local_particles, iw, debug_r_space) STOP "Debug Multipole Requested: Real Part!" END IF ! Debug electric fields and gradients as pure derivatives IF (debug_e_field) THEN - CPPostcondition(PRESENT(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(mm_section),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(atomic_kind_set),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(mm_section),cp_failure_level,routineP,failure) CALL debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env,& cell, particle_set, local_particles, radii, charges, dipoles,& - quadrupoles, task, iw, atomic_kind_set, mm_section, error) + quadrupoles, task, iw, atomic_kind_set, mm_section) STOP "Debug Multipole Requested: POT+EFIELDS+GRAD!" END IF ! Debug the potential, electric fields and electric fields gradient in oder @@ -201,7 +199,7 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& IF (debug_e_field_en) THEN CALL debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env,& cell, particle_set, local_particles, radii, charges, dipoles,& - quadrupoles, task, iw, error) + quadrupoles, task, iw) STOP "Debug Multipole Requested: POT+EFIELDS+GRAD to give the correct energy!!" END IF END IF @@ -233,9 +231,9 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& IF (PRESENT(efield0)) THEN size1 = SIZE(efield0) ALLOCATE (efield0_sr(size1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (efield0_lr(size1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) efield0_sr = 0.0_dp efield0_lr = 0.0_dp END IF @@ -243,9 +241,9 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& size1 = SIZE(efield1,1) size2 = SIZE(efield1,2) ALLOCATE (efield1_sr(size1,size2), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (efield1_lr(size1,size2), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) efield1_sr = 0.0_dp efield1_lr = 0.0_dp END IF @@ -253,9 +251,9 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& size1 = SIZE(efield2,1) size2 = SIZE(efield2,2) ALLOCATE (efield2_sr(size1,size2), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (efield2_lr(size1,size2), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) efield2_sr = 0.0_dp efield2_lr = 0.0_dp END IF @@ -270,7 +268,7 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& CALL ewald_multipole_SR (nonbond_env, ewald_env, atomic_kind_set,& particle_set, cell, e_rspace, my_task,& do_forces, do_efield, do_stress, radii, charges, dipoles, quadrupoles,& - forces_glob, pv_glob, efield0_sr, efield1_sr, efield2_sr, error) + forces_glob, pv_glob, efield0_sr, efield1_sr, efield2_sr) energy_glob = energy_glob + e_rspace IF (do_correction_bonded) THEN @@ -279,7 +277,7 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& CALL ewald_multipole_bonded(nonbond_env, particle_set, ewald_env, & cell, e_bonded, my_task, do_forces, do_efield, do_stress, & charges, dipoles, quadrupoles, forces_glob, pv_glob, & - efield0_sr, efield1_sr, efield2_sr, error) + efield0_sr, efield1_sr, efield2_sr) energy_glob = energy_glob + e_bonded END IF END IF @@ -292,16 +290,16 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& CALL ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & local_particles, energy_local, my_task, do_forces, do_efield, do_stress,& charges, dipoles, quadrupoles, forces_local, pv_local, efield0_lr, efield1_lr,& - efield2_lr, error) + efield2_lr) ! Self-Interactions corrections CALL ewald_multipole_self (ewald_env, cell, local_particles, e_self, & e_neut, my_task, do_efield, radii, charges, dipoles, quadrupoles, & - efield0_lr, efield1_lr, efield2_lr, error) + efield0_lr, efield1_lr, efield2_lr) END IF ! Sumup energy contributions for possible IO - CALL ewald_env_get (ewald_env, group=group, error=error) + CALL ewald_env_get (ewald_env, group=group) energy_glob_t = energy_glob e_rspace_t = e_rspace e_bonded_t = e_bonded @@ -317,25 +315,25 @@ RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env,& efield0 = efield0_sr + efield0_lr CALL mp_sum(efield0, group) DEALLOCATE (efield0_sr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (efield0_lr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (PRESENT(efield1)) THEN efield1 = efield1_sr + efield1_lr CALL mp_sum(efield1, group) DEALLOCATE (efield1_sr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (efield1_lr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (PRESENT(efield2)) THEN efield2 = efield2_sr + efield2_lr CALL mp_sum(efield2, group) DEALLOCATE (efield2_sr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (efield2_lr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF CALL timestop(handle) @@ -363,13 +361,12 @@ END SUBROUTINE ewald_multipole_evaluate !> \param efield0 ... !> \param efield1 ... !> \param efield2 ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE ewald_multipole_SR (nonbond_env, ewald_env, atomic_kind_set,& particle_set, cell, energy, task,& do_forces, do_efield, do_stress, radii, charges, dipoles, quadrupoles,& - forces, pv, efield0, efield1, efield2, error) + forces, pv, efield0, efield1, efield2) TYPE(fist_nonbond_env_type), POINTER :: nonbond_env TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(atomic_kind_type), DIMENSION(:), & @@ -390,7 +387,6 @@ SUBROUTINE ewald_multipole_SR (nonbond_env, ewald_env, atomic_kind_set,& INTENT(INOUT), OPTIONAL :: forces, pv REAL(KIND=dp), DIMENSION(:), POINTER :: efield0 REAL(KIND=dp), DIMENSION(:, :), POINTER :: efield1, efield2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_multipole_SR', & routineP = moduleN//':'//routineN @@ -438,8 +434,8 @@ SUBROUTINE ewald_multipole_SR (nonbond_env, ewald_env, atomic_kind_set,& END IF ! Get nonbond_env info CALL fist_nonbond_env_get (nonbond_env, nonbonded=nonbonded, natom_types = nkinds,& - r_last_update=r_last_update,r_last_update_pbc=r_last_update_pbc, error=error) - CALL ewald_env_get (ewald_env, alpha=alpha, rcut=rcut, error=error) + r_last_update=r_last_update,r_last_update_pbc=r_last_update_pbc) + CALL ewald_env_get (ewald_env, alpha=alpha, rcut=rcut) rab2_max = rcut**2 IF (debug_r_space) THEN rab2_max = HUGE(0.0_dp) @@ -553,12 +549,11 @@ END SUBROUTINE ewald_multipole_SR !> \param efield0 ... !> \param efield1 ... !> \param efield2 ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 05.2009 ! ***************************************************************************** SUBROUTINE ewald_multipole_bonded (nonbond_env, particle_set, ewald_env, & cell, energy, task, do_forces, do_efield, do_stress, charges, & - dipoles, quadrupoles, forces, pv, efield0, efield1, efield2, error) + dipoles, quadrupoles, forces, pv, efield0, efield1, efield2) TYPE(fist_nonbond_env_type), POINTER :: nonbond_env TYPE(particle_type), POINTER :: particle_set( : ) @@ -578,7 +573,6 @@ SUBROUTINE ewald_multipole_bonded (nonbond_env, particle_set, ewald_env, & INTENT(INOUT), OPTIONAL :: forces, pv REAL(KIND=dp), DIMENSION(:), POINTER :: efield0 REAL(KIND=dp), DIMENSION(:, :), POINTER :: efield1, efield2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_multipole_bonded', & routineP = moduleN//':'//routineN @@ -614,8 +608,8 @@ SUBROUTINE ewald_multipole_bonded (nonbond_env, particle_set, ewald_env, & ptens21 = 0.0_dp ; ptens22 = 0.0_dp ; ptens23 = 0.0_dp ptens31 = 0.0_dp ; ptens32 = 0.0_dp ; ptens33 = 0.0_dp END IF - CALL ewald_env_get (ewald_env, alpha=alpha, error=error) - CALL fist_nonbond_env_get(nonbond_env, nonbonded=nonbonded, error=error) + CALL ewald_env_get (ewald_env, alpha=alpha) + CALL fist_nonbond_env_get(nonbond_env, nonbonded=nonbonded) ! Starting the force loop Lists: DO ilist=1,nonbonded%nlists @@ -678,13 +672,11 @@ END SUBROUTINE ewald_multipole_bonded !> \param efield0 ... !> \param efield1 ... !> \param efield2 ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & local_particles, energy, task, do_forces, do_efield, do_stress, & - charges, dipoles, quadrupoles, forces, pv, efield0, efield1, efield2,& - error) + charges, dipoles, quadrupoles, forces, pv, efield0, efield1, efield2) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(cell_type), POINTER :: cell @@ -704,7 +696,6 @@ SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & INTENT(INOUT), OPTIONAL :: forces, pv REAL(KIND=dp), DIMENSION(:), POINTER :: efield0 REAL(KIND=dp), DIMENSION(:, :), POINTER :: efield1, efield2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_multipole_LR', & routineP = moduleN//':'//routineN @@ -740,7 +731,7 @@ SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & do_efield2 = do_efield.AND.ASSOCIATED(efield2) ! Gathering data from the ewald environment - CALL ewald_env_get (ewald_env, alpha=alpha, group=group, error=error) + CALL ewald_env_get (ewald_env, alpha=alpha, group=group) CALL ewald_pw_get (ewald_pw, pw_big_pool=pw_pool, dg=dg) CALL dg_get (dg, dg_rho0=dg_rho0) rho0 => dg_rho0%density%pw%cr3d @@ -756,13 +747,13 @@ SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & CALL structure_factor_allocate(pw_grid%bounds, nnodes, exp_igr) ALLOCATE (summe_ef(1:pw_grid%ngpts_cut), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) summe_ef = CMPLX (0.0_dp, 0.0_dp,KIND=dp) ! Stress Tensor IF (do_stress) THEN pv_tmp = 0.0_dp ALLOCATE (summe_st(3,1:pw_grid%ngpts_cut), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) summe_st = CMPLX (0.0_dp, 0.0_dp,KIND=dp) END IF @@ -816,14 +807,14 @@ SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & iparticle = local_particles%list(iparticle_kind)%array(iparticle_local) ! Density for energy and forces CALL get_atom_factor(atm_factor, pw_grid, gpt, iparticle, task, charges,& - dipoles, quadrupoles, error) + dipoles, quadrupoles) summe_tmp = exp_igr%ex(lp,node)*exp_igr%ey(mp,node)*exp_igr%ez(np,node) summe_ef(gpt) = summe_ef(gpt) + atm_factor*summe_tmp ! Precompute pseudo-density for stress tensor calculation IF (do_stress) THEN CALL get_atom_factor_stress(atm_factor_st, pw_grid, gpt, iparticle, task,& - dipoles, quadrupoles, error) + dipoles, quadrupoles) summe_st(1:3,gpt) = summe_st(1:3,gpt) + atm_factor_st(1:3) *summe_tmp END IF END DO @@ -904,7 +895,7 @@ SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & ! Forces IF (do_forces) THEN CALL get_atom_factor(atm_factor, pw_grid, gpt, iparticle, task, charges,& - dipoles, quadrupoles, error) + dipoles, quadrupoles) tmp = gauss * AIMAG(summe_ef(gpt) * (cnjg_fac * CONJG(atm_factor))) forces(1,node) = forces(1,node) + tmp * pw_grid%g(1,gpt) @@ -978,7 +969,7 @@ SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & CALL structure_factor_deallocate (exp_igr) DEALLOCATE (summe_ef, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (do_stress) THEN pv_tmp = pv_tmp * pref ! Symmetrize the tensor @@ -992,7 +983,7 @@ SUBROUTINE ewald_multipole_LR(ewald_env, ewald_pw, cell, particle_set, & pv(3,2) = pv(2,3) pv(3,3) = pv(3,3) + pv_tmp(3,3) DEALLOCATE (summe_st, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (do_forces) THEN forces = 2.0_dp * forces * pref @@ -1020,13 +1011,12 @@ END SUBROUTINE ewald_multipole_LR !> \param charges ... !> \param dipoles ... !> \param quadrupoles ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE get_atom_factor(atm_factor, pw_grid, gpt, iparticle, task, charges,& - dipoles, quadrupoles, error) + dipoles, quadrupoles) COMPLEX(KIND=dp), INTENT(OUT) :: atm_factor TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, INTENT(IN) :: gpt @@ -1038,7 +1028,6 @@ SUBROUTINE get_atom_factor(atm_factor, pw_grid, gpt, iparticle, task, charges,& OPTIONAL, POINTER :: dipoles REAL(KIND=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: quadrupoles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_atom_factor', & routineP = moduleN//':'//routineN @@ -1081,13 +1070,12 @@ END SUBROUTINE get_atom_factor !> \param task ... !> \param dipoles ... !> \param quadrupoles ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE get_atom_factor_stress(atm_factor, pw_grid, gpt, iparticle, task,& - dipoles, quadrupoles, error) + dipoles, quadrupoles) COMPLEX(KIND=dp), INTENT(OUT) :: atm_factor(3) TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, INTENT(IN) :: gpt @@ -1097,7 +1085,6 @@ SUBROUTINE get_atom_factor_stress(atm_factor, pw_grid, gpt, iparticle, task,& OPTIONAL, POINTER :: dipoles REAL(KIND=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: quadrupoles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_atom_factor_stress', & routineP = moduleN//':'//routineN @@ -1143,12 +1130,11 @@ END SUBROUTINE get_atom_factor_stress !> \param efield0 ... !> \param efield1 ... !> \param efield2 ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 12.2007 ! ***************************************************************************** SUBROUTINE ewald_multipole_self (ewald_env, cell, local_particles, e_self, & e_neut, task, do_efield, radii, charges, dipoles, quadrupoles, efield0, & - efield1, efield2, error) + efield1, efield2) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(cell_type), INTENT(IN) :: cell TYPE(distribution_1d_type), POINTER :: local_particles @@ -1163,7 +1149,6 @@ SUBROUTINE ewald_multipole_self (ewald_env, cell, local_particles, e_self, & OPTIONAL, POINTER :: quadrupoles REAL(KIND=dp), DIMENSION(:), POINTER :: efield0 REAL(KIND=dp), DIMENSION(:, :), POINTER :: efield1, efield2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ewald_multipole_self', & routineP = moduleN//':'//routineN @@ -1180,7 +1165,7 @@ SUBROUTINE ewald_multipole_self (ewald_env, cell, local_particles, e_self, & fac2, fac3, fac4, q, q_neutg, q_self, q_sum, qu_qu_self, radius CALL ewald_env_get ( ewald_env, ewald_type=ewald_type, alpha=alpha,& - group=group, error=error) + group=group) do_efield0 = do_efield.AND.ASSOCIATED(efield0) do_efield1 = do_efield.AND.ASSOCIATED(efield1) diff --git a/src/ewalds_multipole_debug.F b/src/ewalds_multipole_debug.F index e0eaf2d515..ee5009b48f 100644 --- a/src/ewalds_multipole_debug.F +++ b/src/ewalds_multipole_debug.F @@ -13,12 +13,11 @@ !> \param local_particles ... !> \param iw ... !> \param debug_r_space ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & - particle_set, local_particles, iw, debug_r_space, error ) + particle_set, local_particles, iw, debug_r_space) USE cell_types, ONLY: cell_type USE distribution_1d_types, ONLY: distribution_1d_type USE ewald_environment_types, ONLY: ewald_environment_type @@ -60,7 +59,6 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & TYPE(distribution_1d_type), POINTER :: local_particles INTEGER, INTENT(IN) :: iw LOGICAL, INTENT(IN) :: debug_r_space - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'debug_ewald_multipoles', & routineP = "ewalds_multipole_debug"//':'//routineN @@ -85,32 +83,32 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & NULLIFY(random_stream, multipoles, charges, dipoles, g_forces, g_pv,& r_forces, r_pv, e_field1, e_field2) CALL create_rng_stream(random_stream,name="DEBUG_EWALD_MULTIPOLE",& - distribution_type=UNIFORM,error=error) + distribution_type=UNIFORM) ! check: charge - charge task = .FALSE. nparticles = SIZE(particle_set) ! Allocate charges, dipoles, quadrupoles ALLOCATE(charges(nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dipoles(3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(quadrupoles(3,3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Allocate arrays for forces ALLOCATE(r_forces(3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(g_forces(3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(e_field1(3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(e_field2(3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(g_pv(3,3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(r_pv(3,3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Debug CHARGES-CHARGES task(1) = .TRUE. @@ -129,20 +127,19 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & e_self = 0.0_dp CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "CHARGE", echarge=-1.0_dp, & - random_stream=random_stream, charges=charges,error=error) + random_stream=random_stream, charges=charges) CALL create_multi_type(multipoles, nparticles, nparticles/2+1, nparticles, "CHARGE", echarge=1.0_dp, & - random_stream=random_stream, charges=charges,error=error) + random_stream=random_stream, charges=charges) CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy,& - debug_r_space, error) + debug_r_space) WRITE(*,*)"DEBUG ENERGY (CHARGE-CHARGE): ", debug_energy CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, g_energy, r_energy, e_neut, e_self,& task, do_correction_bonded=.FALSE., do_forces=.TRUE., do_stress=.TRUE., do_efield=.FALSE.,& charges=charges,dipoles=dipoles,quadrupoles=quadrupoles,forces_local=g_forces,& - forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.,& - error=error) - CALL release_multi_type(multipoles, error=error) + forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.) + CALL release_multi_type(multipoles) ! Debug CHARGES-DIPOLES @@ -163,22 +160,21 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & e_self = 0.0_dp CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "CHARGE", echarge=-1.0_dp, & - random_stream=random_stream, charges=charges,error=error) + random_stream=random_stream, charges=charges) CALL create_multi_type(multipoles, nparticles, nparticles/2+1, nparticles, "DIPOLE", echarge=0.5_dp, & - random_stream=random_stream, dipoles=dipoles,error=error) + random_stream=random_stream, dipoles=dipoles) WRITE(*,'("CHARGES",F15.9)')charges WRITE(*,'("DIPOLES",3F15.9)')dipoles CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, & - debug_r_space, error) + debug_r_space) WRITE(*,*)"DEBUG ENERGY (CHARGE-DIPOLE): ", debug_energy CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, g_energy, r_energy, e_neut, e_self,& task,do_correction_bonded=.FALSE., do_forces=.TRUE., do_stress=.TRUE., do_efield=.FALSE.,& charges=charges,dipoles=dipoles,quadrupoles=quadrupoles,forces_local=g_forces,& - forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.,& - error=error) - CALL release_multi_type(multipoles, error=error) + forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.) + CALL release_multi_type(multipoles) ! Debug DIPOLES-DIPOLES task(2) = .TRUE. @@ -197,21 +193,20 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & e_self = 0.0_dp CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "DIPOLE", echarge=10000.0_dp, & - random_stream=random_stream,dipoles=dipoles,error=error) + random_stream=random_stream,dipoles=dipoles) CALL create_multi_type(multipoles, nparticles, nparticles/2+1, nparticles, "DIPOLE", echarge=20000._dp, & - random_stream=random_stream,dipoles=dipoles,error=error) + random_stream=random_stream,dipoles=dipoles) WRITE(*,'("DIPOLES",3F15.9)')dipoles CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, & - debug_r_space, error) + debug_r_space) WRITE(*,*)"DEBUG ENERGY (DIPOLE-DIPOLE): ", debug_energy CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, g_energy, r_energy, e_neut, e_self,& task,do_correction_bonded=.FALSE., do_forces=.TRUE., do_stress=.TRUE., do_efield=.FALSE.,& charges=charges,dipoles=dipoles,quadrupoles=quadrupoles,forces_local=g_forces,& - forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.,& - error=error) - CALL release_multi_type(multipoles, error=error) + forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.) + CALL release_multi_type(multipoles) ! Debug CHARGES-QUADRUPOLES task(1) = .TRUE. @@ -231,22 +226,21 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & e_self = 0.0_dp CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "CHARGE", echarge=-1.0_dp, & - random_stream=random_stream,charges=charges,error=error) + random_stream=random_stream,charges=charges) CALL create_multi_type(multipoles, nparticles, nparticles/2+1, nparticles, "QUADRUPOLE", echarge=10.0_dp, & - random_stream=random_stream,quadrupoles=quadrupoles,error=error) + random_stream=random_stream,quadrupoles=quadrupoles) WRITE(*,'("CHARGES",F15.9)')charges WRITE(*,'("QUADRUPOLES",9F15.9)')quadrupoles CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, & - debug_r_space, error) + debug_r_space) WRITE(*,*)"DEBUG ENERGY (CHARGE-QUADRUPOLE): ", debug_energy CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, g_energy, r_energy, e_neut, e_self,& task,do_correction_bonded=.FALSE., do_forces=.TRUE., do_stress=.TRUE., do_efield=.FALSE.,& charges=charges,dipoles=dipoles,quadrupoles=quadrupoles,forces_local=g_forces,& - forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.,& - error=error) - CALL release_multi_type(multipoles, error=error) + forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.) + CALL release_multi_type(multipoles) ! Debug DIPOLES-QUADRUPOLES task(2) = .TRUE. @@ -266,22 +260,21 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & e_self = 0.0_dp CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "DIPOLE", echarge=10000.0_dp, & - random_stream=random_stream,dipoles=dipoles,error=error) + random_stream=random_stream,dipoles=dipoles) CALL create_multi_type(multipoles, nparticles, nparticles/2+1, nparticles, "QUADRUPOLE", echarge=10000.0_dp, & - random_stream=random_stream,quadrupoles=quadrupoles,error=error) + random_stream=random_stream,quadrupoles=quadrupoles) WRITE(*,'("DIPOLES",3F15.9)')dipoles WRITE(*,'("QUADRUPOLES",9F15.9)')quadrupoles CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, & - debug_r_space, error) + debug_r_space) WRITE(*,*)"DEBUG ENERGY (DIPOLE-QUADRUPOLE): ", debug_energy CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, g_energy, r_energy, e_neut, e_self,& task,do_correction_bonded=.FALSE., do_forces=.TRUE., do_stress=.TRUE., do_efield=.FALSE.,& charges=charges,dipoles=dipoles,quadrupoles=quadrupoles,forces_local=g_forces,& - forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.,& - error=error) - CALL release_multi_type(multipoles, error=error) + forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.) + CALL release_multi_type(multipoles) ! Debug QUADRUPOLES-QUADRUPOLES task(3) = .TRUE. @@ -300,42 +293,41 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & e_self = 0.0_dp CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "QUADRUPOLE", echarge=-20000.0_dp, & - random_stream=random_stream,quadrupoles=quadrupoles,error=error) + random_stream=random_stream,quadrupoles=quadrupoles) CALL create_multi_type(multipoles, nparticles, nparticles/2+1, nparticles, "QUADRUPOLE", echarge=10000.0_dp, & - random_stream=random_stream,quadrupoles=quadrupoles,error=error) + random_stream=random_stream,quadrupoles=quadrupoles) WRITE(*,'("QUADRUPOLES",9F15.9)')quadrupoles CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, & - debug_r_space, error) + debug_r_space) WRITE(*,*)"DEBUG ENERGY (QUADRUPOLE-QUADRUPOLE): ", debug_energy CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, & particle_set, local_particles, g_energy, r_energy, e_neut, e_self,& task,do_correction_bonded=.FALSE., do_forces=.TRUE., do_stress=.TRUE., do_efield=.FALSE.,& charges=charges,dipoles=dipoles,quadrupoles=quadrupoles,forces_local=g_forces,& - forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.,& - error=error) - CALL release_multi_type(multipoles, error=error) + forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.FALSE.) + CALL release_multi_type(multipoles) DEALLOCATE(charges,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dipoles,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(quadrupoles,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_forces,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(g_forces,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(e_field1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(e_field2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(g_pv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_pv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL delete_rng_stream(random_stream,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL delete_rng_stream(random_stream) CONTAINS ! ***************************************************************************** @@ -346,12 +338,11 @@ SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & !> \param multipoles ... !> \param energy ... !> \param debug_r_space ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** SUBROUTINE debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles,& - energy, debug_r_space, error) + energy, debug_r_space) IMPLICIT NONE TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -361,7 +352,6 @@ SUBROUTINE debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles POINTER :: multipoles REAL(KIND=dp), INTENT(OUT) :: energy LOGICAL, INTENT(IN) :: debug_r_space - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'debug_ewald_multipole_low', & routineP = "ewalds_multipole_debug"//':'//routineN @@ -382,7 +372,7 @@ SUBROUTINE debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles failure = .FALSE. energy = 0.0_dp CALL fist_nonbond_env_get (nonbond_env, nonbonded=nonbonded, natom_types = nkinds,& - r_last_update=r_last_update,r_last_update_pbc=r_last_update_pbc, error=error) + r_last_update=r_last_update,r_last_update_pbc=r_last_update_pbc) rab2_max = HUGE(0.0_dp) IF (debug_r_space) THEN ! This debugs the real space part of the multipole Ewald summation scheme @@ -485,12 +475,11 @@ END SUBROUTINE debug_ewald_multipole_low !> \param charges ... !> \param dipoles ... !> \param quadrupoles ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** SUBROUTINE create_multi_type(multipoles, idim, istart, iend, label, echarge,& - random_stream, charges, dipoles, quadrupoles, error) + random_stream, charges, dipoles, quadrupoles) IMPLICIT NONE TYPE(multi_charge_type), DIMENSION(:),& POINTER :: multipoles @@ -504,7 +493,6 @@ SUBROUTINE create_multi_type(multipoles, idim, istart, iend, label, echarge,& OPTIONAL :: dipoles REAL(KIND=dp), DIMENSION(:,:,:), POINTER,& OPTIONAL :: quadrupoles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_multi_type', & routineP = "ewalds_multipole_debug"//':'//routineN @@ -515,10 +503,10 @@ SUBROUTINE create_multi_type(multipoles, idim, istart, iend, label, echarge,& failure = .FALSE. IF (ASSOCIATED(multipoles)) THEN - CPPostcondition(SIZE(multipoles)==idim,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(multipoles)==idim,cp_failure_level,routineP,failure) ELSE ALLOCATE(multipoles(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, idim NULLIFY(multipoles(i)%charge_typ) END DO @@ -530,28 +518,28 @@ SUBROUTINE create_multi_type(multipoles, idim, istart, iend, label, echarge,& ELSE isize = 1 END IF - CALL reallocate_charge_type(multipoles(i)%charge_typ,1,isize,error) + CALL reallocate_charge_type(multipoles(i)%charge_typ,1,isize) SELECT CASE(label) CASE("CHARGE") - CPPostcondition(PRESENT(charges),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(charges),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(charges),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(charges),cp_failure_level,routineP,failure) ALLOCATE(multipoles(i)%charge_typ(isize)%charge(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(multipoles(i)%charge_typ(isize)%pos(3,1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) multipoles(i)%charge_typ(isize)%charge(1) = echarge multipoles(i)%charge_typ(isize)%pos(1:3,1) = 0.0_dp charges(i) = charges(i) + echarge CASE("DIPOLE") dx = 1.0E-4_dp - CPPostcondition(PRESENT(dipoles),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(dipoles),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(dipoles),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(dipoles),cp_failure_level,routineP,failure) ALLOCATE(multipoles(i)%charge_typ(isize)%charge(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(multipoles(i)%charge_typ(isize)%pos(3,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL random_numbers(rvec, random_stream, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL random_numbers(rvec, random_stream) rvec = rvec/(2.0_dp*SQRT(DOT_PRODUCT(rvec,rvec)))*dx multipoles(i)%charge_typ(isize)%charge(1) = echarge multipoles(i)%charge_typ(isize)%pos(1:3,1) = rvec @@ -561,14 +549,14 @@ SUBROUTINE create_multi_type(multipoles, idim, istart, iend, label, echarge,& dipoles(:,i) = dipoles(:,i) + 2.0_dp*echarge*rvec CASE("QUADRUPOLE") dx = 1.0E-2_dp - CPPostcondition(PRESENT(quadrupoles),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(quadrupoles),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(quadrupoles),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(quadrupoles),cp_failure_level,routineP,failure) ALLOCATE(multipoles(i)%charge_typ(isize)%charge(4),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(multipoles(i)%charge_typ(isize)%pos(3,4),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL random_numbers(rvec1, random_stream, error) - CALL random_numbers(rvec2, random_stream, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL random_numbers(rvec1, random_stream) + CALL random_numbers(rvec2, random_stream) rvec1 = rvec1/SQRT(DOT_PRODUCT(rvec1,rvec1)) rvec2 = rvec2 - DOT_PRODUCT(rvec2,rvec1)*rvec1 rvec2 = rvec2/SQRT(DOT_PRODUCT(rvec2,rvec2)) @@ -610,15 +598,13 @@ END SUBROUTINE create_multi_type ! ***************************************************************************** !> \brief release multi_type for multipoles !> \param multipoles ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** - SUBROUTINE release_multi_type(multipoles, error) + SUBROUTINE release_multi_type(multipoles) IMPLICIT NONE TYPE(multi_charge_type), DIMENSION(:),& POINTER :: multipoles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_multi_type', & routineP = "ewalds_multipole_debug"//':'//routineN @@ -631,12 +617,12 @@ SUBROUTINE release_multi_type(multipoles, error) DO i = 1, SIZE(multipoles) DO j = 1, SIZE(multipoles(i)%charge_typ) DEALLOCATE(multipoles(i)%charge_typ(j)%charge,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(multipoles(i)%charge_typ(j)%pos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(multipoles(i)%charge_typ,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO END IF END SUBROUTINE release_multi_type @@ -646,16 +632,14 @@ END SUBROUTINE release_multi_type !> \param charge_typ ... !> \param istart ... !> \param iend ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** - SUBROUTINE reallocate_charge_type(charge_typ, istart, iend, error) + SUBROUTINE reallocate_charge_type(charge_typ, istart, iend) IMPLICIT NONE TYPE(charge_mono_type), DIMENSION(:),& POINTER :: charge_typ INTEGER, INTENT(IN) :: istart, iend - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reallocate_charge_type', & routineP = "ewalds_multipole_debug"//':'//routineN @@ -669,51 +653,51 @@ SUBROUTINE reallocate_charge_type(charge_typ, istart, iend, error) IF (ASSOCIATED(charge_typ)) THEN isize = SIZE(charge_typ) ALLOCATE(charge_typ_bk(1:isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, isize jsize = SIZE(charge_typ(j)%charge) ALLOCATE(charge_typ_bk(j)%charge(jsize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) jsize1 = SIZE(charge_typ(j)%pos,1) jsize2 = SIZE(charge_typ(j)%pos,2) ALLOCATE(charge_typ_bk(j)%pos(jsize1,jsize2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) charge_typ_bk(j)%pos = charge_typ(j)%pos charge_typ_bk(j)%charge = charge_typ(j)%charge END DO DO j = 1, SIZE(charge_typ) DEALLOCATE(charge_typ(j)%charge,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(charge_typ(j)%pos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(charge_typ,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Reallocate ALLOCATE(charge_typ_bk(istart:iend),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = istart, isize jsize = SIZE(charge_typ_bk(j)%charge) ALLOCATE(charge_typ(j)%charge(jsize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) jsize1 = SIZE(charge_typ_bk(j)%pos,1) jsize2 = SIZE(charge_typ_bk(j)%pos,2) ALLOCATE(charge_typ(j)%pos(jsize1,jsize2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) charge_typ(j)%pos = charge_typ_bk(j)%pos charge_typ(j)%charge = charge_typ_bk(j)%charge END DO DO j = 1, SIZE(charge_typ_bk) DEALLOCATE(charge_typ_bk(j)%charge,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(charge_typ_bk(j)%pos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(charge_typ_bk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(charge_typ(istart:iend), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE reallocate_charge_type @@ -736,13 +720,12 @@ END SUBROUTINE debug_ewald_multipoles !> \param iw ... !> \param atomic_kind_set ... !> \param mm_section ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell,& particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw, & - atomic_kind_set, mm_section, error ) + atomic_kind_set, mm_section) USE atomic_kind_types, ONLY: atomic_kind_type USE cell_types, ONLY: cell_type USE distribution_1d_types, ONLY: distribution_1d_type @@ -776,7 +759,6 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, INTEGER, INTENT(IN) :: iw TYPE(atomic_kind_type), POINTER :: atomic_kind_set(:) TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'debug_ewald_multipoles_fields', & routineP = "ewalds_multipole_debug"//':'//routineN @@ -795,7 +777,7 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, NULLIFY(lcharges, ldipoles, lquadrupoles, shell_particle_set, core_particle_set) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() nparticles = SIZE(particle_set) nparticle_local = 0 @@ -822,7 +804,7 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set,& local_particles, energy_local, energy_glob, e_neut, e_self, task, .FALSE., .TRUE., .TRUE.,& .TRUE., radii, charges, dipoles, quadrupoles, forces_local, forces_glob, pv_local, pv_glob,& - efield0, efield1, efield2, iw, do_debug=.FALSE., error=error ) + efield0, efield1, efield2, iw, do_debug=.FALSE.) o_tot_ene = energy_local + energy_glob + e_neut + e_self WRITE(*,*)"TOTAL ENERGY :: ========>",o_tot_ene ! Debug Potential @@ -842,7 +824,7 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, e_self = 0.0_dp CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set,& local_particles, energy_local, energy_glob, e_neut, e_self, task, .FALSE., .FALSE., .FALSE.,& - .FALSE., radii, lcharges, dipoles, quadrupoles, iw=iw, do_debug=.FALSE., error=error ) + .FALSE., radii, lcharges, dipoles, quadrupoles, iw=iw, do_debug=.FALSE.) ene(k) = energy_local + energy_glob + e_neut + e_self END DO pot = (ene(2)-ene(1))/(2.0_dp*dq) @@ -863,7 +845,7 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, ! Rebuild neighbor lists CALL list_control ( atomic_kind_set, particle_set, local_particles, & cell, nonbond_env, logger%para_env, mm_section, & - shell_particle_set, core_particle_set, error=error) + shell_particle_set, core_particle_set) forces_glob = 0.0_dp forces_local= 0.0_dp @@ -877,7 +859,7 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set,& local_particles, energy_local, energy_glob, e_neut, e_self, task, .FALSE., .TRUE., .TRUE.,& .TRUE., radii, charges, dipoles, quadrupoles, forces_local, forces_glob, pv_local, pv_glob,& - efield0, iw=iw, do_debug=.FALSE., error=error) + efield0, iw=iw, do_debug=.FALSE.) ene(k) = efield0(i) particle_set(i)%r(j) = coord(j) END DO @@ -903,7 +885,7 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, ! Rebuild neighbor lists CALL list_control ( atomic_kind_set, particle_set, local_particles, & cell, nonbond_env, logger%para_env, mm_section, & - shell_particle_set, core_particle_set, error=error) + shell_particle_set, core_particle_set) forces_glob = 0.0_dp forces_local= 0.0_dp @@ -917,7 +899,7 @@ SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set,& local_particles, energy_local, energy_glob, e_neut, e_self, task,.FALSE., .TRUE., .TRUE.,& .TRUE., radii, charges, dipoles, quadrupoles, forces_local, forces_glob, pv_local, pv_glob,& - efield1=efield1, iw=iw, do_debug=.FALSE., error=error) + efield1=efield1, iw=iw, do_debug=.FALSE.) enev(:,k) = efield1(:,i) particle_set(i)%r(j) = coord(j) END DO @@ -944,13 +926,11 @@ END SUBROUTINE debug_ewald_multipoles_fields !> \param quadrupoles ... !> \param task ... !> \param iw ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** SUBROUTINE debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env, cell,& - particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw, & - error ) + particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw) USE cell_types, ONLY: cell_type USE distribution_1d_types, ONLY: distribution_1d_type USE ewald_environment_types, ONLY: ewald_environment_type @@ -980,7 +960,6 @@ SUBROUTINE debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env, cell POINTER, OPTIONAL :: quadrupoles LOGICAL, DIMENSION(3), INTENT(IN) :: task INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'debug_ewald_multipoles_fields', & routineP = "ewalds_multipole_debug"//':'//routineN @@ -998,7 +977,7 @@ SUBROUTINE debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env, cell NULLIFY(ldipoles, lquadrupoles, shell_particle_set, core_particle_set) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() nparticles = SIZE(particle_set) nparticle_local = 0 @@ -1024,7 +1003,7 @@ SUBROUTINE debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env, cell CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set,& local_particles, energy_local, energy_glob, e_neut, e_self, task,.FALSE.,.TRUE., .TRUE.,& .TRUE., radii, charges, dipoles, quadrupoles, forces_local, forces_glob, pv_local, pv_glob,& - efield0, efield1, efield2, iw, do_debug=.FALSE., error=error ) + efield0, efield1, efield2, iw, do_debug=.FALSE.) o_tot_ene = energy_local + energy_glob + e_neut + e_self WRITE(*,*)"TOTAL ENERGY :: ========>",o_tot_ene diff --git a/src/ewalds_multipole_debug.h b/src/ewalds_multipole_debug.h index 37df486dad..960f9a02a7 100644 --- a/src/ewalds_multipole_debug.h +++ b/src/ewalds_multipole_debug.h @@ -10,7 +10,7 @@ ! ***************************************************************************** INTERFACE SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, & - particle_set, local_particles, iw, debug_r_space, error ) + particle_set, local_particles, iw, debug_r_space) USE cell_types, ONLY: cell_type USE distribution_1d_types, ONLY: distribution_1d_type USE ewald_environment_types, ONLY: ewald_environment_type @@ -27,7 +27,6 @@ INTERFACE TYPE(distribution_1d_type), POINTER :: local_particles INTEGER, INTENT(IN) :: iw LOGICAL, INTENT(IN) :: debug_r_space - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE debug_ewald_multipoles END INTERFACE @@ -35,7 +34,7 @@ END INTERFACE INTERFACE SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell,& particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw,& - atomic_kind_set, force_env_section, error) + atomic_kind_set, force_env_section) USE atomic_kind_types, ONLY: atomic_kind_type USE cell_types, ONLY: cell_type USE distribution_1d_types, ONLY: distribution_1d_type @@ -62,15 +61,13 @@ INTERFACE INTEGER, INTENT(IN) :: iw TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE debug_ewald_multipoles_fields END INTERFACE INTERFACE SUBROUTINE debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env, cell,& - particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw,& - error) + particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw) USE cell_types, ONLY: cell_type USE distribution_1d_types, ONLY: distribution_1d_type USE ewald_environment_types, ONLY: ewald_environment_type @@ -93,7 +90,6 @@ INTERFACE POINTER, OPTIONAL :: quadrupoles LOGICAL, DIMENSION(3), INTENT(IN) :: task INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE debug_ewald_multipoles_fields2 END INTERFACE diff --git a/src/exclusion_types.F b/src/exclusion_types.F index 936c74eb5c..e67a3da311 100644 --- a/src/exclusion_types.F +++ b/src/exclusion_types.F @@ -32,15 +32,13 @@ MODULE exclusion_types ! ***************************************************************************** !> \brief Release exclusion type !> \param exclusions ... -!> \param error ... !> \par History !> 12.2010 created [Teodoro Laino] - teodoro.laino@gmail.com !> \author teo ! ***************************************************************************** - SUBROUTINE exclusion_release(exclusions, error) + SUBROUTINE exclusion_release(exclusions) TYPE(exclusion_type), DIMENSION(:), & POINTER :: exclusions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'exclusion_release', & routineP = moduleN//':'//routineN @@ -54,24 +52,24 @@ SUBROUTINE exclusion_release(exclusions, error) IF (ASSOCIATED(exclusions(iatom)%list_exclude_vdw,& exclusions(iatom)%list_exclude_ei)) THEN DEALLOCATE(exclusions(iatom)%list_exclude_vdw,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF (ASSOCIATED(exclusions(iatom)%list_exclude_vdw)) THEN DEALLOCATE(exclusions(iatom)%list_exclude_vdw,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(exclusions(iatom)%list_exclude_ei)) THEN DEALLOCATE(exclusions(iatom)%list_exclude_ei,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ENDIF IF (ASSOCIATED(exclusions(iatom)%list_onfo)) THEN DEALLOCATE(exclusions(iatom)%list_onfo,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDDO DEALLOCATE(exclusions,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF END SUBROUTINE exclusion_release diff --git a/src/extended_system_types.F b/src/extended_system_types.F index d3a56e247b..f9413eab8a 100644 --- a/src/extended_system_types.F +++ b/src/extended_system_types.F @@ -87,13 +87,10 @@ MODULE extended_system_types !> \brief Initialize type for Nose-Hoover thermostat !> \param lnhc ... !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE lnhc_init(lnhc, section, error) + SUBROUTINE lnhc_init(lnhc, section) TYPE(lnhc_parameters_type), POINTER :: lnhc TYPE(section_vals_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lnhc_init', & routineP = moduleN//':'//routineN @@ -106,23 +103,20 @@ SUBROUTINE lnhc_init(lnhc, section, error) lnhc%dt_fact=1.0_dp CALL cite_reference(Nose1984a) CALL cite_reference(Nose1984b) - CALL section_vals_val_get(section,"LENGTH",i_val=lnhc%nhc_len,error=error) - CALL section_vals_val_get(section,"YOSHIDA",i_val=lnhc%nyosh,error=error) - CALL section_vals_val_get(section,"TIMECON",r_val=lnhc%tau_nhc,error=error) - CALL section_vals_val_get(section,"MTS",i_val=lnhc%nc,error=error) - CALL create_map_info_type(lnhc%map_info, error) + CALL section_vals_val_get(section,"LENGTH",i_val=lnhc%nhc_len) + CALL section_vals_val_get(section,"YOSHIDA",i_val=lnhc%nyosh) + CALL section_vals_val_get(section,"TIMECON",r_val=lnhc%tau_nhc) + CALL section_vals_val_get(section,"MTS",i_val=lnhc%nc) + CALL create_map_info_type(lnhc%map_info) END SUBROUTINE lnhc_init ! ***************************************************************************** !> \brief create the map_info type !> \param map_info ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE create_map_info_type(map_info, error) + SUBROUTINE create_map_info_type(map_info) TYPE(map_info_type), POINTER :: map_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_map_info_type', & routineP = moduleN//':'//routineN @@ -132,7 +126,7 @@ SUBROUTINE create_map_info_type(map_info, error) failure = .FALSE. ALLOCATE(map_info, stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) NULLIFY(map_info%index, map_info%map_index) NULLIFY(map_info%v_scale) NULLIFY(map_info%p_scale) @@ -145,12 +139,9 @@ END SUBROUTINE create_map_info_type ! ***************************************************************************** !> \brief release the map_info type !> \param map_info ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE release_map_info_type(map_info, error) + SUBROUTINE release_map_info_type(map_info) TYPE(map_info_type), POINTER :: map_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'release_map_info_type', & routineP = moduleN//':'//routineN @@ -163,31 +154,31 @@ SUBROUTINE release_map_info_type(map_info, error) IF (ASSOCIATED(map_info)) THEN IF (ASSOCIATED (map_info%p_kin)) THEN DEALLOCATE (map_info%p_kin, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF (ASSOCIATED (map_info%p_scale)) THEN DEALLOCATE (map_info%p_scale, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF (ASSOCIATED (map_info%v_scale)) THEN DEALLOCATE (map_info%v_scale, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF (ASSOCIATED (map_info%s_kin)) THEN DEALLOCATE (map_info%s_kin, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF (ASSOCIATED (map_info%index)) THEN DEALLOCATE (map_info%index, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF (ASSOCIATED (map_info%map_index)) THEN DEALLOCATE (map_info%map_index, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF DEALLOCATE (map_info, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF END SUBROUTINE release_map_info_type @@ -195,12 +186,9 @@ END SUBROUTINE release_map_info_type ! ***************************************************************************** !> \brief Deallocate type for Nose-Hoover thermostat !> \param lnhc ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE lnhc_dealloc ( lnhc, error ) + SUBROUTINE lnhc_dealloc ( lnhc) TYPE(lnhc_parameters_type), POINTER :: lnhc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lnhc_dealloc', & routineP = moduleN//':'//routineN @@ -213,15 +201,15 @@ SUBROUTINE lnhc_dealloc ( lnhc, error ) IF (ASSOCIATED(lnhc)) THEN IF ( ASSOCIATED(lnhc%dt_yosh)) THEN DEALLOCATE (lnhc%dt_yosh, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF (ASSOCIATED (lnhc%nvt)) THEN DEALLOCATE (lnhc%nvt, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF - CALL release_map_info_type(lnhc%map_info, error) + CALL release_map_info_type(lnhc%map_info) DEALLOCATE (lnhc, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF END SUBROUTINE lnhc_dealloc diff --git a/src/external_potential_methods.F b/src/external_potential_methods.F index 7bdaf74bf4..0c90c44996 100644 --- a/src/external_potential_methods.F +++ b/src/external_potential_methods.F @@ -45,13 +45,11 @@ MODULE external_potential_methods ! ***************************************************************************** !> \brief ... !> \param force_env ... -!> \param error ... !> \date 03.2008 !> \author Teodoro Laino - University of Zurich [tlaino] ! ***************************************************************************** - SUBROUTINE add_external_potential(force_env, error) + SUBROUTINE add_external_potential(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_external_potential', & routineP = moduleN//':'//routineN @@ -76,27 +74,26 @@ SUBROUTINE add_external_potential(force_env, error) CALL timeset(routineN,handle) NULLIFY(my_par, my_val, logger, subsys, particles, ext_pot_section, nparticle) ext_pot_section => section_vals_get_subs_vals(force_env%force_env_section,& - "EXTERNAL_POTENTIAL",error=error) - CALL section_vals_get(ext_pot_section,n_repetition=n_var,error=error) + "EXTERNAL_POTENTIAL") + CALL section_vals_get(ext_pot_section,n_repetition=n_var) DO rep=1, n_var natom = 0 - logger => cp_error_get_logger(error) - CALL section_vals_val_get(ext_pot_section,"DX",r_val=dx,i_rep_section=rep,error=error) - CALL section_vals_val_get(ext_pot_section,"ERROR_LIMIT",r_val=lerr,i_rep_section=rep,error=error) + logger => cp_get_default_logger() + CALL section_vals_val_get(ext_pot_section,"DX",r_val=dx,i_rep_section=rep) + CALL section_vals_val_get(ext_pot_section,"ERROR_LIMIT",r_val=lerr,i_rep_section=rep) CALL get_generic_info(ext_pot_section, "FUNCTION", coupling_function, my_par, my_val,& - input_variables=(/"X","Y","Z"/), i_rep_sec=rep,error=error) + input_variables=(/"X","Y","Z"/), i_rep_sec=rep) CALL initf(1) CALL parsef(1,TRIM(coupling_function),my_par) ! Apply potential on all atoms, computing energy and forces NULLIFY(particles, subsys) - CALL force_env_get(force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, particles=particles, error=error) - CALL force_env_get(force_env, additional_potential=energy, error=error) - CALL section_vals_val_get(ext_pot_section,"ATOMS_LIST",n_rep_val=a_var,i_rep_section=rep,error=error) + CALL force_env_get(force_env, subsys=subsys) + CALL cp_subsys_get(subsys, particles=particles) + CALL force_env_get(force_env, additional_potential=energy) + CALL section_vals_val_get(ext_pot_section,"ATOMS_LIST",n_rep_val=a_var,i_rep_section=rep) DO k = 1, a_var - CALL section_vals_val_get(ext_pot_section,"ATOMS_LIST",i_rep_val=k,i_vals=iatms,i_rep_section=rep,& - error=error) + CALL section_vals_val_get(ext_pot_section,"ATOMS_LIST",i_rep_val=k,i_vals=iatms,i_rep_section=rep) CALL reallocate(nparticle,1, natom+SIZE(iatms)) nparticle(natom+1:natom+SIZE(iatms)) = iatms natom = natom + SIZE(iatms) @@ -126,19 +123,19 @@ SUBROUTINE add_external_potential(force_env, error) CALL cp_assert(.FALSE.,cp_warning_level,-300,routineP,& 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& ' Error '//TRIM(this_error)//' in computing numerical derivatives larger then'//& - TRIM(def_error)//' .',error=error,only_ionode=.TRUE.) + TRIM(def_error)//' .',only_ionode=.TRUE.) END IF particles%els(iatom)%f(j)=particles%els(iatom)%f(j)-dedf END DO END DO - CALL force_env_set(force_env, additional_potential=energy, error=error) + CALL force_env_set(force_env, additional_potential=energy) DEALLOCATE(my_par,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_val,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (a_var/=0) THEN DEALLOCATE (nparticle,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL finalizef() END DO diff --git a/src/f77_interface.F b/src/f77_interface.F index 89419cb5b4..a324773973 100644 --- a/src/f77_interface.F +++ b/src/f77_interface.F @@ -203,7 +203,6 @@ SUBROUTINE init_cp2k(init_mpi,ierr) INTEGER :: mpi_comm_default, stat, & unit_nr - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger IF (.NOT. module_initialized) THEN @@ -228,7 +227,7 @@ SUBROUTINE init_cp2k(init_mpi,ierr) ! re-create the para_env and log with correct (reordered) ranks NULLIFY(default_para_env) CALL cp_para_env_create(default_para_env, group=mpi_comm_default, & - owns_group=.FALSE.,error=error) + owns_group=.FALSE.) IF (default_para_env%source==default_para_env%mepos) THEN unit_nr=default_output_unit ELSE @@ -260,7 +259,7 @@ SUBROUTINE init_cp2k(init_mpi,ierr) CALL pw_cuda_init() ! Initialize the DBCSR configuration - CALL cp_dbcsr_init_lib (error=error) + CALL cp_dbcsr_init_lib () ELSE ierr=cp_failure_level @@ -285,7 +284,6 @@ SUBROUTINE finalize_cp2k(finalize_mpi,ierr) routineP = moduleN//':'//routineN INTEGER :: ienv, stat - TYPE(cp_error_type) :: error !sample peak memory @@ -295,15 +293,15 @@ SUBROUTINE finalize_cp2k(finalize_mpi,ierr) ierr=cp_failure_level ELSE ! Finalize the DBCSR configuration - CALL cp_dbcsr_finalize_lib (group=default_para_env%group, output_unit=0, error=error) + CALL cp_dbcsr_finalize_lib (group=default_para_env%group, output_unit=0) CALL pw_cuda_finalize() DO ienv=n_f_envs,1,-1 CALL destroy_force_env(f_envs(ienv)%f_env%id_nr,ierr=ierr) - CPAssertNoFail(ierr==0,cp_warning_level,routineP,error) + CPAssertNoFail(ierr==0,cp_warning_level,routineP) END DO DEALLOCATE(f_envs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CALL cp_para_env_release(default_para_env,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CALL cp_para_env_release(default_para_env) ierr=0 CALL cp_rm_default_logger() @@ -321,13 +319,10 @@ END SUBROUTINE finalize_cp2k ! ***************************************************************************** !> \brief deallocates a f_env !> \param f_env the f_env to deallocate -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - RECURSIVE SUBROUTINE f_env_dealloc(f_env,error) + RECURSIVE SUBROUTINE f_env_dealloc(f_env) TYPE(f_env_type), POINTER :: f_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'f_env_dealloc', & routineP = moduleN//':'//routineN @@ -337,14 +332,14 @@ RECURSIVE SUBROUTINE f_env_dealloc(f_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(f_env),cp_failure_level,routineP,error,failure) - CALL force_env_release(f_env%force_env,error=error) + CPPrecondition(ASSOCIATED(f_env),cp_failure_level,routineP,failure) + CALL force_env_release(f_env%force_env) CALL cp_logger_release(f_env%logger) CALL timer_env_release(f_env%timer_env) CALL mp_perf_env_release(f_env%mp_perf_env) IF (f_env%old_path/=f_env%my_path) THEN CALL m_chdir(f_env%old_path,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE f_env_dealloc @@ -357,10 +352,9 @@ END SUBROUTINE f_env_dealloc !> \param id_nr ... !> \param logger ... !> \param old_dir ... -!> \param error ... !> \author fawzi ! ***************************************************************************** - SUBROUTINE f_env_create(f_env,force_env, timer_env,mp_perf_env,id_nr,logger,old_dir,error) + SUBROUTINE f_env_create(f_env,force_env, timer_env,mp_perf_env,id_nr,logger,old_dir) TYPE(f_env_type), POINTER :: f_env TYPE(force_env_type), POINTER :: force_env TYPE(timer_env_type), POINTER :: timer_env @@ -368,7 +362,6 @@ SUBROUTINE f_env_create(f_env,force_env, timer_env,mp_perf_env,id_nr,logger,old_ INTEGER, INTENT(in) :: id_nr TYPE(cp_logger_type), POINTER :: logger CHARACTER(len=*), INTENT(in), OPTIONAL :: old_dir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'f_env_create', & routineP = moduleN//':'//routineN @@ -379,9 +372,9 @@ SUBROUTINE f_env_create(f_env,force_env, timer_env,mp_perf_env,id_nr,logger,old_ failure=.FALSE. ALLOCATE(f_env,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) f_env%force_env => force_env - CALL force_env_retain(f_env%force_env,error=error) + CALL force_env_retain(f_env%force_env) f_env%logger => logger CALL cp_logger_retain(logger) f_env%timer_env => timer_env @@ -398,12 +391,10 @@ END SUBROUTINE f_env_create !> \brief ... !> \param f_env_id ... !> \param f_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE f_env_get_from_id(f_env_id,f_env,error) + SUBROUTINE f_env_get_from_id(f_env_id,f_env) INTEGER, INTENT(in) :: f_env_id TYPE(f_env_type), POINTER :: f_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'f_env_get_from_id', & routineP = moduleN//':'//routineN @@ -416,7 +407,7 @@ SUBROUTINE f_env_get_from_id(f_env_id,f_env,error) f_env_pos = get_pos_of_env(f_env_id) IF (f_env_pos<1) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "invalid env_id "//cp_to_string(f_env_id),error=error,& + "invalid env_id "//cp_to_string(f_env_id),& failure=failure) ELSE f_env => f_envs(f_env_pos)%f_env @@ -430,7 +421,6 @@ END SUBROUTINE f_env_get_from_id !> something went wrong !> \param f_env_id the f_env from where to take the defaults !> \param f_env will contain the f_env corresponding to f_env_id -!> \param new_error an error that can be used for the given f_env !> \param failure will be set to true if something went wrong !> \param handle ... !> \author fawzi @@ -441,10 +431,9 @@ END SUBROUTINE f_env_get_from_id !> f77_interface:f_env_add_defaults, f77_interface:f_env_rm_defaults, !> f77_interface:create_force_env, f77_interface:destroy_force_env ! ***************************************************************************** - SUBROUTINE f_env_add_defaults(f_env_id,f_env,new_error, failure, handle) + SUBROUTINE f_env_add_defaults(f_env_id,f_env,failure, handle) INTEGER, INTENT(in) :: f_env_id TYPE(f_env_type), POINTER :: f_env - TYPE(cp_error_type), INTENT(out) :: new_error LOGICAL :: failure INTEGER, INTENT(out), OPTIONAL :: handle @@ -461,16 +450,16 @@ SUBROUTINE f_env_add_defaults(f_env_id,f_env,new_error, failure, handle) f_env_pos = get_pos_of_env(f_env_id) IF (f_env_pos<1) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "invalid env_id "//cp_to_string(f_env_id),error=new_error,& + "invalid env_id "//cp_to_string(f_env_id),& failure=failure) ELSE f_env => f_envs(f_env_pos)%f_env logger => f_env%logger - CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,new_error,my_failure) + CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,my_failure) CALL m_getcwd(f_env%old_path) IF (f_env%old_path/=f_env%my_path) THEN CALL m_chdir(TRIM(f_env%my_path),ierr) - CPAssert(ierr==0,cp_failure_level,routineP,new_error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END IF CALL add_mp_perf_env(f_env%mp_perf_env) CALL add_timer_env(f_env%timer_env) @@ -484,7 +473,6 @@ END SUBROUTINE f_env_add_defaults !> defaults, and sets ierr accordingly to the failuers stored in error !> It also releases the error !> \param f_env the f_env from where to take the defaults -!> \param error the error to be checked (will be released) !> \param ierr variable that will be set to a number different from 0 if !> error contains an error (otherwise it will be set to 0) !> \param handle ... @@ -496,9 +484,8 @@ END SUBROUTINE f_env_add_defaults !> f77_interface:f_env_add_defaults, f77_interface:f_env_rm_defaults, !> f77_interface:create_force_env, f77_interface:destroy_force_env ! ***************************************************************************** - SUBROUTINE f_env_rm_defaults(f_env,error,ierr,handle) + SUBROUTINE f_env_rm_defaults(f_env,ierr,handle) TYPE(f_env_type), POINTER :: f_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, INTENT(out), OPTIONAL :: ierr INTEGER, INTENT(in), OPTIONAL :: handle @@ -515,23 +502,23 @@ SUBROUTINE f_env_rm_defaults(f_env,error,ierr,handle) IF (ASSOCIATED(f_env)) THEN IF (PRESENT(handle)) THEN - CPAssert(handle==cp_default_logger_stack_size(),cp_failure_level,routineP,error,failure) + CPAssert(handle==cp_default_logger_stack_size(),cp_failure_level,routineP,failure) END IF logger => f_env%logger d_logger => cp_get_default_logger() d_timer_env => get_timer_env() d_mp_perf_env => get_mp_perf_env() - CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(d_logger),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(d_timer_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(d_mp_perf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(logger%id_nr==d_logger%id_nr,cp_failure_level,routineP,error,failure) - ! CPPrecondition(d_timer_env%id_nr==f_env%timer_env%id_nr,cp_failure_level,routineP,error,failure) - CPPrecondition(d_mp_perf_env%id_nr==f_env%mp_perf_env%id_nr,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(d_logger),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(d_timer_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(d_mp_perf_env),cp_failure_level,routineP,failure) + CPPrecondition(logger%id_nr==d_logger%id_nr,cp_failure_level,routineP,failure) + ! CPPrecondition(d_timer_env%id_nr==f_env%timer_env%id_nr,cp_failure_level,routineP,failure) + CPPrecondition(d_mp_perf_env%id_nr==f_env%mp_perf_env%id_nr,cp_failure_level,routineP,failure) IF (f_env%old_path/=f_env%my_path) THEN CALL m_chdir(TRIM(f_env%old_path),ierr2) - CPAssert(ierr2==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr2==0,cp_failure_level,routineP,failure) END IF IF (PRESENT(ierr)) THEN ierr=0 @@ -600,7 +587,6 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& lgroup_distribution LOGICAL :: check, do_qmmm_force_mixing, failure, multiple_subsys, & my_echo, my_owns_out_unit, use_motion_section, use_multiple_para_env - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger, my_logger TYPE(cp_para_env_type), POINTER :: my_para_env, para_env TYPE(eip_environment_type), POINTER :: eip_env @@ -625,15 +611,15 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& failure=.FALSE. - CPPrecondition(ASSOCIATED(input_declaration),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(input_declaration),cp_failure_level,routineP,failure) NULLIFY(para_env, force_env,timer_env,mp_perf_env, globenv,meta_env,& fp_env,eip_env,mixed_env,qs_env,qmmm_env) new_env_id=-1 IF (PRESENT(mpi_comm)) THEN - CALL cp_para_env_create(para_env, group=mpi_comm, owns_group=.FALSE.,error=error) + CALL cp_para_env_create(para_env, group=mpi_comm, owns_group=.FALSE.) ELSE para_env => default_para_env - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) END IF CALL timeset(routineN,handle) @@ -668,7 +654,7 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& END IF my_owns_out_unit=unit_nr/=default_output_unit IF (PRESENT(owns_out_unit)) my_owns_out_unit=owns_out_unit - CALL globenv_create(globenv,error=error) + CALL globenv_create(globenv) CALL cp2k_init(para_env, output_unit=unit_nr, globenv=globenv, input_file_name=input_path,& wdir=wdir) logger => cp_get_default_logger() @@ -679,35 +665,35 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& IF (PRESENT(input)) input_file => input IF (.NOT.ASSOCIATED(input_file)) THEN IF (PRESENT(initial_variables)) THEN - input_file => read_input(input_declaration, input_path,initial_variables,para_env=para_env,error=error) + input_file => read_input(input_declaration, input_path,initial_variables,para_env=para_env) ELSE - input_file => read_input(input_declaration, input_path,empty_initial_variables,para_env=para_env,error=error) + input_file => read_input(input_declaration, input_path,empty_initial_variables,para_env=para_env) ENDIF ELSE - CALL section_vals_retain(input_file,error=error) + CALL section_vals_retain(input_file) END IF CALL section_vals_val_get(input_file,"GLOBAL%ECHO_INPUT",& - l_val=my_echo,error=error) + l_val=my_echo) ! echo after check? IF (para_env%ionode.and.my_echo) THEN CALL section_vals_write(input_file,unit_nr=cp_logger_get_default_unit_nr(logger), & - hide_root=.TRUE., hide_defaults=.FALSE., error=error) + hide_root=.TRUE., hide_defaults=.FALSE.) END IF ! XXXXXXXXXXXXXXXXXXXXXXXXXXX ! root_section => input_file ! XXXXXXXXXXXXXXXXXXXXXXXXXXX - CALL check_cp2k_input(input_declaration,input_file,para_env=para_env,output_unit=unit_nr,error=error) + CALL check_cp2k_input(input_declaration,input_file,para_env=para_env,output_unit=unit_nr) ! XXXXXXXXXXXXXXXXXXXXXXXXXXX ! NULLIFY(input_file) ! XXXXXXXXXXXXXXXXXXXXXXXXXXX root_section => input_file - CALL section_vals_retain(root_section,error) + CALL section_vals_retain(root_section) IF (n_f_envs+1>SIZE(f_envs)) THEN f_envs_old => f_envs ALLOCATE(f_envs(n_f_envs+10), stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,n_f_envs f_envs(i)%f_env => f_envs_old(i)%f_env END DO @@ -715,30 +701,29 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& NULLIFY(f_envs(i)%f_env) END DO DEALLOCATE(f_envs_old,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) END IF - CALL cp2k_read(root_section,para_env,globenv,error=error) + CALL cp2k_read(root_section,para_env,globenv) - CALL cp2k_setup(root_section,para_env,globenv,error) + CALL cp2k_setup(root_section,para_env,globenv) ! Group Distribution ALLOCATE(group_distribution(0:para_env%num_pe-1),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) group_distribution = 0 lgroup_distribution => group_distribution ! Setup all possible force_env - force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL",error=error) + force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL") CALL section_vals_val_get(root_section,"MULTIPLE_FORCE_EVALS%MULTIPLE_SUBSYS",& - l_val=multiple_subsys,error=error) - CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval,& - error) + l_val=multiple_subsys) + CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval) ! Enforce the deletion of the subsys (unless not explicitly required) IF (.NOT.multiple_subsys) THEN DO iforce_eval = 2, nforce_eval wrk_section => section_vals_get_subs_vals(force_env_sections,"SUBSYS",& - i_rep_section=i_force_eval(iforce_eval),error=error) - CALL section_vals_remove_values(wrk_section, error=error) + i_rep_section=i_force_eval(iforce_eval)) + CALL section_vals_remove_values(wrk_section) END DO END IF nsubforce_size = nforce_eval-1 @@ -749,13 +734,13 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& ! Reference subsys from the first ordered force_eval IF (.NOT.multiple_subsys) THEN subsys_section => section_vals_get_subs_vals(force_env_sections,"SUBSYS",& - i_rep_section=i_force_eval(1),error=error) + i_rep_section=i_force_eval(1)) END IF ! Handling para_env in case of multiple force_eval IF (use_multiple_para_env) THEN ! Check that the order of the force_eval is the correct one CALL section_vals_val_get(force_env_sections, "METHOD", i_val=method_name_id, & - i_rep_section=i_force_eval(1), error=error) + i_rep_section=i_force_eval(1)) CALL cp_assert(method_name_id==do_mixed,cp_failure_level,cp_assertion_failed,routineP,& "In case of multiple force_eval the MAIN force_eval (the first in the list of FORCE_EVAL_ORDER or "//& "the one omitted from that order list) must be a MIXED_ENV type calculation. Please check your "//& @@ -763,7 +748,7 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& CPSourceFileRef,& only_ionode=.TRUE.) check = ASSOCIATED(force_env%mixed_env%sub_para_env) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) ngroups = force_env%mixed_env%ngroups my_group= lgroup_distribution(para_env%mepos) isubforce_eval = iforce_eval-1 @@ -782,17 +767,17 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& ! is provided.. this is in order to save memory.. IF (nforce_eval>1) THEN CALL section_vals_duplicate(force_env_sections,force_env_section,& - i_force_eval(iforce_eval),i_force_eval(iforce_eval),error) + i_force_eval(iforce_eval),i_force_eval(iforce_eval)) IF (iforce_eval/=1) use_motion_section = .FALSE. ELSE force_env_section => force_env_sections use_motion_section = .TRUE. END IF - CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id,error=error) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id) IF(method_name_id==do_qmmm) THEN - qmmmx_section => section_vals_get_subs_vals(force_env_section,"QMMM%FORCE_MIXING",error=error) - CALL section_vals_get(qmmmx_section,explicit=do_qmmm_force_mixing,error=error) + qmmmx_section => section_vals_get_subs_vals(force_env_section,"QMMM%FORCE_MIXING") + CALL section_vals_get(qmmmx_section,explicit=do_qmmm_force_mixing) IF(do_qmmm_force_mixing)& method_name_id = do_qmmmx ! QMMM Force-Mixing has its own (hidden) method_id ENDIF @@ -801,83 +786,82 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& CASE (do_fist) CALL fist_create_force_env ( my_force_env, root_section, my_para_env, globenv,& force_env_section=force_env_section, subsys_section=subsys_section,& - use_motion_section=use_motion_section, error=error ) + use_motion_section=use_motion_section) CASE (do_qs) - CALL qs_env_create(qs_env,globenv,error=error) + CALL qs_env_create(qs_env,globenv) CALL qs_init(qs_env, my_para_env, globenv, root_section, force_env_section=force_env_section,& - subsys_section=subsys_section, use_motion_section=use_motion_section, error=error) + subsys_section=subsys_section, use_motion_section=use_motion_section) CALL force_env_create(my_force_env, root_section, qs_env=qs_env, para_env=my_para_env, globenv=globenv,& - force_env_section=force_env_section,error=error) - CALL qs_env_release(qs_env,error=error) + force_env_section=force_env_section) + CALL qs_env_release(qs_env) CASE (do_qmmm) - qmmm_section => section_vals_get_subs_vals(force_env_section,"QMMM",error=error) + qmmm_section => section_vals_get_subs_vals(force_env_section,"QMMM") CALL qmmm_env_create(qmmm_env, root_section, para_env, globenv,& - force_env_section, qmmm_section, subsys_section, use_motion_section, error=error) + force_env_section, qmmm_section, subsys_section, use_motion_section) CALL force_env_create(my_force_env,root_section, qmmm_env=qmmm_env, para_env=para_env,& - globenv=globenv, force_env_section=force_env_section, error=error) - CALL qmmm_env_release(qmmm_env,error=error) + globenv=globenv, force_env_section=force_env_section) + CALL qmmm_env_release(qmmm_env) CASE (do_qmmmx) CALL qmmmx_env_create(qmmmx_env, root_section, para_env, globenv,& - force_env_section, subsys_section, use_motion_section, error=error) + force_env_section, subsys_section, use_motion_section) CALL force_env_create(my_force_env,root_section, qmmmx_env=qmmmx_env, para_env=para_env,& - globenv=globenv, force_env_section=force_env_section, error=error) - CALL qmmmx_env_release(qmmmx_env,error=error) + globenv=globenv, force_env_section=force_env_section) + CALL qmmmx_env_release(qmmmx_env) CASE (do_eip) - CALL eip_env_create(eip_env, error=error) + CALL eip_env_create(eip_env) CALL eip_init(eip_env, root_section, my_para_env, force_env_section=force_env_section,& - subsys_section=subsys_section, error=error) + subsys_section=subsys_section) CALL force_env_create(my_force_env, root_section, eip_env=eip_env, para_env=my_para_env,& - globenv=globenv, force_env_section=force_env_section, error=error) - CALL eip_env_release(eip_env, error=error) + globenv=globenv, force_env_section=force_env_section) + CALL eip_env_release(eip_env) CASE (do_mixed) CALL mixed_create_force_env(mixed_env, root_section, my_para_env,& force_env_section=force_env_section, n_subforce_eval=nsubforce_size,& - use_motion_section=use_motion_section, error=error) + use_motion_section=use_motion_section) CALL force_env_create(my_force_env, root_section, mixed_env=mixed_env, para_env=my_para_env,& - globenv=globenv, force_env_section=force_env_section, error=error) - CALL mixed_env_release(mixed_env, error=error) + globenv=globenv, force_env_section=force_env_section) + CALL mixed_env_release(mixed_env) !TODO: the sub_force_envs should really be created via recursion use_multiple_para_env = .TRUE. CALL cp_add_default_logger(logger) ! just to get the logger swapping started lgroup_distribution => my_force_env%mixed_env%group_distribution CASE default - CALL create_force_eval_section(section,error) - keyword => section_get_keyword(section,"METHOD",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + CALL create_force_eval_section(section) + keyword => section_get_keyword(section,"METHOD") + CALL keyword_get(keyword,enum=enum) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Invalid METHOD <"//TRIM(enum_i2c(enum,method_name_id,error=error))//& + "Invalid METHOD <"//TRIM(enum_i2c(enum,method_name_id))//& "> was specified, "//& CPSourceFileRef,& - error,failure) - CALL section_release(section,error=error) + failure) + CALL section_release(section) END SELECT NULLIFY(meta_env, fp_env) IF (use_motion_section) THEN ! Metadynamics Setup - fe_section => section_vals_get_subs_vals(root_section,"MOTION%FREE_ENERGY",error=error) - CALL metadyn_read(meta_env, my_force_env, root_section, my_para_env, fe_section,& - error=error) - CALL force_env_set(my_force_env,meta_env=meta_env,error=error) - CALL meta_env_release(meta_env,error=error) + fe_section => section_vals_get_subs_vals(root_section,"MOTION%FREE_ENERGY") + CALL metadyn_read(meta_env, my_force_env, root_section, my_para_env, fe_section) + CALL force_env_set(my_force_env,meta_env=meta_env) + CALL meta_env_release(meta_env) ! Flexible Partition Setup - fp_section => section_vals_get_subs_vals(root_section,"MOTION%FLEXIBLE_PARTITIONING",error=error) - CALL fp_env_create(fp_env,error=error) - CALL fp_env_read(fp_env,fp_section,error=error) - CALL fp_env_write(fp_env,fp_section,error=error) - CALL force_env_set(my_force_env,fp_env=fp_env,error=error) - CALL fp_env_release(fp_env,error=error) + fp_section => section_vals_get_subs_vals(root_section,"MOTION%FLEXIBLE_PARTITIONING") + CALL fp_env_create(fp_env) + CALL fp_env_read(fp_env,fp_section) + CALL fp_env_write(fp_env,fp_section) + CALL force_env_set(my_force_env,fp_env=fp_env) + CALL fp_env_release(fp_env) END IF ! Handle multiple force_eval IF (nforce_eval>1.AND.iforce_eval==1) THEN ALLOCATE(my_force_env%sub_force_env(nsubforce_size),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Nullify subforce_env DO k = 1,nsubforce_size NULLIFY(my_force_env%sub_force_env(k)%force_env) @@ -894,14 +878,14 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& lgroup_distribution = iforce_eval END IF ! Release force_env_section - IF (nforce_eval>1) CALL section_vals_release(force_env_section,error) + IF (nforce_eval>1) CALL section_vals_release(force_env_section) END DO IF (use_multiple_para_env)& CALL cp_rm_default_logger() DEALLOCATE(group_distribution,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(i_force_eval,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) timer_env => get_timer_env() mp_perf_env => get_mp_perf_env() CALL mp_max(last_f_env_id,para_env%group) @@ -910,12 +894,12 @@ RECURSIVE SUBROUTINE create_force_env(new_env_id,input_declaration,input_path,& n_f_envs=n_f_envs+1 CALL f_env_create(f_envs(n_f_envs)%f_env,logger=logger,& timer_env=timer_env,mp_perf_env=mp_perf_env,force_env=force_env,& - id_nr=last_f_env_id,old_dir=old_dir,error=error) - CALL force_env_release(force_env,error=error) - CALL globenv_release(globenv,error=error) - CALL section_vals_release(root_section,error) - CALL cp_para_env_release(para_env,error=error) - CALL f_env_rm_defaults(f_envs(n_f_envs)%f_env,error=error,ierr=ierr) + id_nr=last_f_env_id,old_dir=old_dir) + CALL force_env_release(force_env) + CALL globenv_release(globenv) + CALL section_vals_release(root_section) + CALL cp_para_env_release(para_env) + CALL f_env_rm_defaults(f_envs(n_f_envs)%f_env,ierr=ierr) CALL timestop(handle) END SUBROUTINE create_force_env @@ -941,7 +925,6 @@ RECURSIVE SUBROUTINE destroy_force_env(env_id,ierr) INTEGER :: env_pos, i, stat LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(cp_para_env_type), POINTER :: para_env TYPE(f_env_type), POINTER :: f_env TYPE(global_environment_type), POINTER :: globenv @@ -949,7 +932,7 @@ RECURSIVE SUBROUTINE destroy_force_env(env_id,ierr) failure=.FALSE. NULLIFY(f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) + CALL f_env_add_defaults(env_id,f_env,failure) env_pos=get_pos_of_env(env_id) n_f_envs=n_f_envs-1 DO i=env_pos,n_f_envs @@ -958,16 +941,16 @@ RECURSIVE SUBROUTINE destroy_force_env(env_id,ierr) NULLIFY(f_envs(n_f_envs+1)%f_env) CALL force_env_get(f_env%force_env,globenv=globenv,& - root_section=root_section,para_env=para_env,error=error) - - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) - CALL globenv_retain(globenv,error=error) - CALL f_env_dealloc(f_env,error=error) - CALL cp2k_finalize(root_section,para_env,globenv,f_env%old_path,error) - CALL section_vals_release(root_section,error=error) - CALL globenv_release(globenv,error=error) + root_section=root_section,para_env=para_env) + + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) + CALL globenv_retain(globenv) + CALL f_env_dealloc(f_env) + CALL cp2k_finalize(root_section,para_env,globenv,f_env%old_path) + CALL section_vals_release(root_section) + CALL globenv_release(globenv) DEALLOCATE(f_env,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ierr=0 END SUBROUTINE destroy_force_env @@ -988,15 +971,14 @@ SUBROUTINE get_natom(env_id, n_atom, ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure = .FALSE. n_atom = 0 NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) - n_atom = force_env_get_natom(f_env%force_env,error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_add_defaults(env_id,f_env,failure) + n_atom = force_env_get_natom(f_env%force_env) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_natom @@ -1017,15 +999,14 @@ SUBROUTINE get_nparticle(env_id, n_particle, ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure = .FALSE. n_particle = 0 NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) - n_particle = force_env_get_nparticle(f_env%force_env,error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_add_defaults(env_id,f_env,failure) + n_particle = force_env_get_nparticle(f_env%force_env) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_nparticle @@ -1049,18 +1030,17 @@ SUBROUTINE get_cell(env_id, cell, per, ierr) LOGICAL :: failure TYPE(cell_type), POINTER :: cell_full - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) + CALL f_env_add_defaults(env_id,f_env,failure) NULLIFY (cell_full) - CALL force_env_get(f_env%force_env,cell=cell_full,error=error) - CPPrecondition(ASSOCIATED(cell_full),cp_failure_level,routineP,error,failure) + CALL force_env_get(f_env%force_env,cell=cell_full) + CPPrecondition(ASSOCIATED(cell_full),cp_failure_level,routineP,failure) cell = cell_full%hmat IF(PRESENT(per)) per(:) = cell_full%perd(:) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_cell @@ -1085,31 +1065,30 @@ SUBROUTINE get_result_r1(env_id, description, N, RESULT, res_exist, ierr) INTEGER :: nres LOGICAL :: exist_res, failure - TYPE(cp_error_type) :: error TYPE(cp_result_type), POINTER :: results TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env, subsys, results) - CALL f_env_add_defaults(env_id,f_env,error,failure) + CALL f_env_add_defaults(env_id,f_env,failure) - CALL force_env_get(f_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, results=results, error=error) + CALL force_env_get(f_env%force_env, subsys=subsys) + CALL cp_subsys_get(subsys, results=results) ! first test for the result IF(PRESENT(res_exist)) THEN - res_exist = test_for_result(results, description=description, error=error) + res_exist = test_for_result(results, description=description) exist_res = res_exist ELSE exist_res = .TRUE. END IF ! if existing (or assuming the existance) read the results IF(res_exist) THEN - CALL get_results(results, description=description, n_rep=nres,error=error) - CALL get_results(results, description=description, values=RESULT, nval=nres,error=error) + CALL get_results(results, description=description, n_rep=nres) + CALL get_results(results, description=description, values=RESULT, nval=nres) END IF - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_result_r1 @@ -1132,14 +1111,13 @@ SUBROUTINE get_force(env_id, frc, n_el, ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) - CALL force_env_get_frc(f_env%force_env,frc,n_el,error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_add_defaults(env_id,f_env,failure) + CALL force_env_get_frc(f_env%force_env,frc,n_el) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_force @@ -1162,7 +1140,6 @@ SUBROUTINE get_stress_tensor(env_id, stress_tensor, ierr) LOGICAL :: failure TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: error TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env TYPE(virial_type), POINTER :: virial @@ -1171,13 +1148,13 @@ SUBROUTINE get_stress_tensor(env_id, stress_tensor, ierr) NULLIFY (f_env, subsys, virial, cell) stress_tensor(:,:) = 0.0_dp - CALL f_env_add_defaults(env_id,f_env,error,failure) - CALL force_env_get(f_env%force_env, subsys=subsys, cell=cell, error=error) - CALL cp_subsys_get(subsys, virial=virial, error=error) + CALL f_env_add_defaults(env_id,f_env,failure) + CALL force_env_get(f_env%force_env, subsys=subsys, cell=cell) + CALL cp_subsys_get(subsys, virial=virial) IF(virial%pv_availability) THEN stress_tensor(:,:) = virial%pv_virial(:,:)/cell%deth ENDIF - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_stress_tensor @@ -1200,14 +1177,13 @@ SUBROUTINE get_pos(env_id, pos, n_el, ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) - CALL force_env_get_pos(f_env%force_env,pos,n_el,error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_add_defaults(env_id,f_env,failure) + CALL force_env_get_pos(f_env%force_env,pos,n_el) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_pos @@ -1230,14 +1206,13 @@ SUBROUTINE get_vel(env_id, vel, n_el, ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) - CALL force_env_get_vel(f_env%force_env,vel,n_el,error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_add_defaults(env_id,f_env,failure) + CALL force_env_get_vel(f_env%force_env,vel,n_el) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_vel @@ -1259,21 +1234,20 @@ SUBROUTINE set_cell(env_id, new_cell, ierr) LOGICAL :: failure TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: error TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env, cell, subsys) - CALL f_env_add_defaults(env_id,f_env,error,failure) + CALL f_env_add_defaults(env_id,f_env,failure) NULLIFY (cell) - CALL force_env_get(f_env%force_env,cell=cell,error=error) - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CALL force_env_get(f_env%force_env,cell=cell) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) cell%hmat = new_cell CALL init_cell(cell) - CALL force_env_get(f_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_set(subsys, cell=cell, error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL force_env_get(f_env%force_env, subsys=subsys) + CALL cp_subsys_set(subsys, cell=cell) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE set_cell @@ -1296,17 +1270,16 @@ SUBROUTINE set_pos(env_id, new_pos, n_el, ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) + CALL f_env_add_defaults(env_id,f_env,failure) NULLIFY (subsys) - CALL force_env_get(f_env%force_env,subsys=subsys,error=error) - CALL unpack_subsys_particles(subsys=subsys,r=new_pos,error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL force_env_get(f_env%force_env,subsys=subsys) + CALL unpack_subsys_particles(subsys=subsys,r=new_pos) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE set_pos @@ -1329,17 +1302,16 @@ SUBROUTINE set_vel(env_id, new_vel, n_el, ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) + CALL f_env_add_defaults(env_id,f_env,failure) NULLIFY (subsys) - CALL force_env_get(f_env%force_env,subsys=subsys,error=error) - CALL unpack_subsys_particles(subsys=subsys,v=new_vel,error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL force_env_get(f_env%force_env,subsys=subsys) + CALL unpack_subsys_particles(subsys=subsys,v=new_vel) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE set_vel @@ -1361,17 +1333,16 @@ RECURSIVE SUBROUTINE calc_energy_force(env_id,calc_force,ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) - logger => cp_error_get_logger(error) - CALL cp_iterate(logger%iter_info,error=error) ! add one to the iteration count - CALL force_env_calc_energy_force(f_env%force_env,calc_force=calc_force,error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_add_defaults(env_id,f_env,failure) + logger => cp_get_default_logger() + CALL cp_iterate(logger%iter_info) ! add one to the iteration count + CALL force_env_calc_energy_force(f_env%force_env,calc_force=calc_force) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE calc_energy_force @@ -1392,14 +1363,13 @@ SUBROUTINE get_energy(env_id,e_pot,ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(env_id,f_env,error,failure) - CALL force_env_get(f_env%force_env,potential_energy=e_pot,error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_add_defaults(env_id,f_env,failure) + CALL force_env_get(f_env%force_env,potential_energy=e_pot) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE get_energy @@ -1494,7 +1464,6 @@ SUBROUTINE check_input(input_declaration, input_file_path,output_file_path,& INTEGER :: unit_nr LOGICAL :: failure, my_echo_input - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: input_file @@ -1505,10 +1474,10 @@ SUBROUTINE check_input(input_declaration, input_file_path,output_file_path,& IF (PRESENT(mpi_comm)) THEN NULLIFY(para_env) - CALL cp_para_env_create(para_env, group=mpi_comm,error=error) + CALL cp_para_env_create(para_env, group=mpi_comm) ELSE para_env => default_para_env - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) END IF IF (para_env%mepos==para_env%source) THEN IF (output_file_path=="__STD_OUT__") THEN @@ -1530,17 +1499,17 @@ SUBROUTINE check_input(input_declaration, input_file_path,output_file_path,& CALL cp_logger_release(logger) input_file => read_input(input_declaration, input_file_path,initial_variables=empty_initial_variables, & - para_env=para_env,error=error) - CALL check_cp2k_input(input_declaration,input_file,para_env=para_env,output_unit=unit_nr,error=error) + para_env=para_env) + CALL check_cp2k_input(input_declaration,input_file,para_env=para_env,output_unit=unit_nr) IF (my_echo_input.AND.para_env%mepos==para_env%source) THEN CALL section_vals_write(input_file,& unit_nr=cp_logger_get_default_unit_nr(logger,local=.FALSE.),hide_root=.TRUE.,& - hide_defaults=.FALSE.,error=error) + hide_defaults=.FALSE.) END IF - CALL section_vals_release(input_file,error=error) + CALL section_vals_release(input_file) CALL cp_logger_release(logger) - CALL cp_para_env_release(para_env,error=error) + CALL cp_para_env_release(para_env) ierr = 0 CALL cp_rm_default_logger() END SUBROUTINE check_input @@ -1562,16 +1531,15 @@ SUBROUTINE do_shake(f_env_id,dt,shake_tol,ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env failure=.FALSE. NULLIFY(f_env) - CALL f_env_add_defaults(f_env_id,f_env,error,failure) + CALL f_env_add_defaults(f_env_id,f_env,failure) CALL force_env_shake(f_env%force_env,& - dt=dt,shake_tol=shake_tol, error=error) - CALL f_env_rm_defaults(f_env,error,ierr) + dt=dt,shake_tol=shake_tol) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE do_shake END MODULE f77_interface diff --git a/src/farming_methods.F b/src/farming_methods.F index c99f52daa8..6f22e31433 100644 --- a/src/farming_methods.F +++ b/src/farming_methods.F @@ -111,13 +111,11 @@ END SUBROUTINE get_next_job !> \param farming_env ... !> \param root_section ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE farming_parse_input(farming_env,root_section,para_env,error) + SUBROUTINE farming_parse_input(farming_env,root_section,para_env) TYPE(farming_env_type), POINTER :: farming_env TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'farming_parse_input', & routineP = moduleN//':'//routineN @@ -133,15 +131,14 @@ SUBROUTINE farming_parse_input(farming_env,root_section,para_env,error) failure=.FALSE. NULLIFY(farming_section, jobs_section, print_key, logger, dependencies, i_vals) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() farming_env%group_size_wish_set=.FALSE. farming_env%ngroup_wish_set =.FALSE. - farming_section => section_vals_get_subs_vals(root_section,"FARMING",& - error=error) + farming_section => section_vals_get_subs_vals(root_section,"FARMING") IF (ASSOCIATED(farming_env%group_partition)) THEN DEALLOCATE(farming_env%group_partition,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ! The following input order is used @@ -149,86 +146,86 @@ SUBROUTINE farming_parse_input(farming_env,root_section,para_env,error) ! 2) NGROUP ! 3) GROUP_SIZE (default 8) CALL section_vals_val_get(farming_section,"GROUP_PARTITION",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) IF (n_rep_val>0) THEN CALL section_vals_val_get(farming_section,"GROUP_PARTITION",& - i_vals=i_vals,error=error) + i_vals=i_vals) ALLOCATE(farming_env%group_partition(0:SIZE(i_vals)-1)) farming_env%group_partition(:)=i_vals farming_env%ngroup_wish_set=.TRUE. farming_env%ngroup_wish=SIZE(i_vals) ELSE CALL section_vals_val_get(farming_section,"NGROUP",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) IF (n_rep_val>0) THEN CALL section_vals_val_get(farming_section,"NGROUP",& - i_val=farming_env%ngroup_wish,error=error) + i_val=farming_env%ngroup_wish) farming_env%ngroup_wish_set=.TRUE. ELSE CALL section_vals_val_get(farming_section,"GROUP_SIZE",& - i_val=farming_env%group_size_wish,error=error) + i_val=farming_env%group_size_wish) farming_env%group_size_wish_set=.TRUE. END IF END IF CALL section_vals_val_get(farming_section,"RESTART_FILE_NAME",& - explicit=explicit,error=error) + explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(farming_section,"RESTART_FILE_NAME",& - c_val=farming_env%restart_file_name,error=error) + c_val=farming_env%restart_file_name) ELSE - print_key => section_vals_get_subs_vals(farming_section,"RESTART",error=error) + print_key => section_vals_get_subs_vals(farming_section,"RESTART") farming_env%restart_file_name=cp_print_key_generate_filename(logger,print_key,extension=".restart",& - my_local=.FALSE., error=error) + my_local=.FALSE.) END IF CALL section_vals_val_get(farming_section,"DO_RESTART",& - l_val=farming_env%restart,error=error) + l_val=farming_env%restart) CALL section_vals_val_get(farming_section,"MAX_JOBS_PER_GROUP",& - i_val=farming_env%max_steps,error=error) + i_val=farming_env%max_steps) CALL section_vals_val_get(farming_section,"CYCLE",& - l_val=farming_env%cycle,error=error) + l_val=farming_env%cycle) CALL section_vals_val_get(farming_section,"WAIT_TIME",& - r_val=farming_env%wait_time,error=error) + r_val=farming_env%wait_time) CALL section_vals_val_get(farming_section,"MASTER_SLAVE",& - l_val=farming_env%master_slave,error=error) + l_val=farming_env%master_slave) - jobs_section => section_vals_get_subs_vals(farming_section,"JOB",error=error) - CALL section_vals_get(jobs_section,n_repetition=farming_env % njobs,error=error) + jobs_section => section_vals_get_subs_vals(farming_section,"JOB") + CALL section_vals_get(jobs_section,n_repetition=farming_env % njobs) ALLOCATE(farming_env%Job(farming_env % njobs),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL init_job_type(farming_env%job) has_dep=.FALSE. DO i=1,farming_env%njobs CALL section_vals_val_get(jobs_section,i_rep_section=i,& - keyword_name="DIRECTORY",c_val=farming_env%Job(i)%cwd,error=error) + keyword_name="DIRECTORY",c_val=farming_env%Job(i)%cwd) CALL section_vals_val_get(jobs_section,i_rep_section=i,& - keyword_name="INPUT_FILE_NAME",c_val=farming_env%Job(i)%input,error=error) + keyword_name="INPUT_FILE_NAME",c_val=farming_env%Job(i)%input) CALL section_vals_val_get(jobs_section,i_rep_section=i,& - keyword_name="OUTPUT_FILE_NAME",c_val=farming_env%Job(i)%output,error=error) + keyword_name="OUTPUT_FILE_NAME",c_val=farming_env%Job(i)%output) ! if job id is not specified the job id is the index CALL section_vals_val_get(jobs_section,i_rep_section=i,& - keyword_name="JOB_ID",n_rep_val=n_rep_val,error=error) + keyword_name="JOB_ID",n_rep_val=n_rep_val) IF (n_rep_val==0) THEN farming_env%Job(i)%id=i ELSE CALL section_vals_val_get(jobs_section,i_rep_section=i,& - keyword_name="JOB_ID",i_val=farming_env%Job(i)%id,error=error) + keyword_name="JOB_ID",i_val=farming_env%Job(i)%id) ENDIF ! get dependencies CALL section_vals_val_get(jobs_section,i_rep_section=i,& - keyword_name="DEPENDENCIES",n_rep_val=n_rep_val,error=error) + keyword_name="DEPENDENCIES",n_rep_val=n_rep_val) IF (n_rep_val==0) THEN ALLOCATE(farming_env%Job(i)%dependencies(0)) ELSE CALL section_vals_val_get(jobs_section,i_rep_section=i,& - keyword_name="DEPENDENCIES",i_vals=dependencies,error=error) + keyword_name="DEPENDENCIES",i_vals=dependencies) ALLOCATE(farming_env%Job(i)%dependencies(SIZE(dependencies,1))) farming_env%Job(i)%dependencies=dependencies IF (SIZE(dependencies,1).NE.0) has_dep=.TRUE. @@ -236,13 +233,13 @@ SUBROUTINE farming_parse_input(farming_env,root_section,para_env,error) END DO IF (has_dep) THEN - CPPostcondition(farming_env%master_slave,cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.farming_env%cycle,cp_failure_level,routineP,error,failure) + CPPostcondition(farming_env%master_slave,cp_failure_level,routineP,failure) + CPPostcondition(.NOT.farming_env%cycle,cp_failure_level,routineP,failure) ENDIF output_unit=cp_print_key_unit_nr(logger,farming_section,"PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") ! master slave not supported IF (para_env%num_pe==1) THEN @@ -315,7 +312,7 @@ SUBROUTINE farming_parse_input(farming_env,root_section,para_env,error) ENDIF CALL cp_print_key_finished_output(output_unit,logger,farming_section,& - "PROGRAM_RUN_INFO", error=error) + "PROGRAM_RUN_INFO") ENDIF CALL mp_bcast(farming_env%restart_n,para_env%source,para_env%group) diff --git a/src/fist_environment.F b/src/fist_environment.F index 8012085af3..a212b11216 100644 --- a/src/fist_environment.F +++ b/src/fist_environment.F @@ -88,12 +88,11 @@ MODULE fist_environment !> \param subsys_section ... !> \param use_motion_section ... !> \param prev_subsys ... -!> \param error ... !> \par Used By !> fist_main ! ***************************************************************************** SUBROUTINE fist_init ( fist_env, root_section,para_env, force_env_section,& - subsys_section, use_motion_section, prev_subsys, error) + subsys_section, use_motion_section, prev_subsys) TYPE(fist_environment_type), POINTER :: fist_env TYPE(section_vals_type), POINTER :: root_section @@ -102,7 +101,6 @@ SUBROUTINE fist_init ( fist_env, root_section,para_env, force_env_section,& subsys_section LOGICAL, INTENT(IN) :: use_motion_section TYPE(cp_subsys_type), OPTIONAL, POINTER :: prev_subsys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_init', & routineP = moduleN//':'//routineN @@ -129,82 +127,82 @@ SUBROUTINE fist_init ( fist_env, root_section,para_env, force_env_section,& CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY ( subsys, cell,cell_ref) NULLIFY ( ewald_env, fist_nonbond_env, qmmm_env, cell_section, & poisson_section, shell_particle_set, shell_particles, & core_particle_set, core_particles, exclusions) IF (.NOT.ASSOCIATED(subsys_section)) THEN - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") END IF - mm_section => section_vals_get_subs_vals(force_env_section,"MM",error=error) - cell_section => section_vals_get_subs_vals(subsys_section,"CELL",error=error) - poisson_section => section_vals_get_subs_vals(mm_section,"POISSON",error=error) - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD",error=error) + mm_section => section_vals_get_subs_vals(force_env_section,"MM") + cell_section => section_vals_get_subs_vals(subsys_section,"CELL") + poisson_section => section_vals_get_subs_vals(mm_section,"POISSON") + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD") - CALL fist_env_set(fist_env,input=force_env_section,error=error) + CALL fist_env_set(fist_env,input=force_env_section) iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%PROGRAM_BANNER",& - extension=".mmLog",error=error) + extension=".mmLog") CALL fist_header(iw) - CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%PROGRAM_BANNER",error=error) + CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%PROGRAM_BANNER") - CALL read_cell( cell, cell_ref, cell_section=cell_section, para_env=para_env, error=error) + CALL read_cell( cell, cell_ref, cell_section=cell_section, para_env=para_env) CALL get_cell (cell, abc=abc) ! Print the cell parameters - CALL write_cell ( cell, subsys_section, cell_ref, error=error) + CALL write_cell ( cell, subsys_section, cell_ref) ! Create the ewald environment - CALL ewald_env_create ( ewald_env, para_env, error ) + CALL ewald_env_create ( ewald_env, para_env) ! Read the input section and set the ewald_env - CALL read_ewald_section ( ewald_env, ewald_section,error ) - CALL ewald_env_set(ewald_env, poisson_section=poisson_section, error=error) + CALL read_ewald_section ( ewald_env, ewald_section) + CALL ewald_env_set(ewald_env, poisson_section=poisson_section) ! Topology - CALL fist_env_get (fist_env, qmmm=qmmm, qmmm_env=qmmm_env, error=error) + CALL fist_env_get (fist_env, qmmm=qmmm, qmmm_env=qmmm_env) CALL cp_subsys_create(subsys, para_env=para_env, root_section=root_section,& force_env_section=force_env_section, subsys_section=subsys_section,& qmmm=qmmm, qmmm_env=qmmm_env, exclusions=exclusions,& - use_motion_section=use_motion_section, error=error) - CALL fist_env_set(fist_env, subsys=subsys, exclusions=exclusions, error=error) + use_motion_section=use_motion_section) + CALL fist_env_set(fist_env, subsys=subsys, exclusions=exclusions) CALL force_field_control(subsys%atomic_kinds%els, subsys%particles%els, & subsys%molecule_kinds_new%els, subsys%molecules_new%els,& ewald_env, fist_nonbond_env, root_section, para_env, qmmm=qmmm,& qmmm_env=qmmm_env, subsys_section=subsys_section,& mm_section=mm_section, shell_particle_set=shell_particle_set, & - core_particle_set=core_particle_set, cell=cell, error=error ) + core_particle_set=core_particle_set, cell=cell) NULLIFY(shell_particles,core_particles) IF (ASSOCIATED(shell_particle_set)) THEN CALL cite_reference(Devynck2012) CALL cite_reference(Mitchell1993) CALL cite_reference(Dick1958) - CALL particle_list_create ( shell_particles, els_ptr = shell_particle_set, error = error ) + CALL particle_list_create ( shell_particles, els_ptr = shell_particle_set) END IF IF (ASSOCIATED(core_particle_set)) THEN - CALL particle_list_create ( core_particles, els_ptr = core_particle_set, error = error ) + CALL particle_list_create ( core_particles, els_ptr = core_particle_set) END IF CALL get_atomic_kind_set(atomic_kind_set=subsys%atomic_kinds%els,& shell_present=shell_present, shell_adiabatic=shell_adiabatic) CALL fist_env_set(fist_env, shell_model=shell_present, & - shell_model_ad=shell_adiabatic, error=error) + shell_model_ad=shell_adiabatic) CALL cp_subsys_set(subsys, shell_particles=shell_particles, & - core_particles=core_particles, error=error) - CALL particle_list_release ( shell_particles, error = error ) - CALL particle_list_release ( core_particles, error = error ) + core_particles=core_particles) + CALL particle_list_release ( shell_particles) + CALL particle_list_release ( core_particles) CALL fist_init_subsys ( fist_env, subsys, cell, cell_ref, fist_nonbond_env, ewald_env,& - force_env_section, subsys_section, prev_subsys, error) + force_env_section, subsys_section, prev_subsys) - CALL cell_release(cell,error=error) - CALL cell_release(cell_ref,error=error) - CALL ewald_env_release ( ewald_env, error ) - CALL fist_nonbond_env_release ( fist_nonbond_env, error ) - CALL cp_subsys_release(subsys,error=error) + CALL cell_release(cell) + CALL cell_release(cell_ref) + CALL ewald_env_release ( ewald_env) + CALL fist_nonbond_env_release ( fist_nonbond_env) + CALL cp_subsys_release(subsys) CALL timestop(handle) @@ -222,14 +220,13 @@ END SUBROUTINE fist_init !> \param force_env_section ... !> \param subsys_section ... !> \param prev_subsys ... -!> \param error ... !> \date 22.05.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** SUBROUTINE fist_init_subsys ( fist_env, subsys, cell, cell_ref, fist_nonbond_env,& ewald_env, force_env_section, subsys_section, & - prev_subsys, error) + prev_subsys) TYPE(fist_environment_type), POINTER :: fist_env TYPE(cp_subsys_type), POINTER :: subsys @@ -239,7 +236,6 @@ SUBROUTINE fist_init_subsys ( fist_env, subsys, cell, cell_ref, fist_nonbond_env TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section TYPE(cp_subsys_type), OPTIONAL, POINTER :: prev_subsys - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_init_subsys', & routineP = moduleN//':'//routineN @@ -282,16 +278,16 @@ SUBROUTINE fist_init_subsys ( fist_env, subsys, cell, cell_ref, fist_nonbond_env CALL allocate_fist_energy( thermo ) ! Print the molecule kind set - CALL write_molecule_kind_set(molecule_kind_set,subsys_section,error) + CALL write_molecule_kind_set(molecule_kind_set,subsys_section) ! Print the atomic coordinates CALL write_fist_particle_coordinates(particle_set,subsys_section, & - fist_nonbond_env%charges, error) - CALL write_particle_distances(particle_set,cell,subsys_section,error) - CALL write_structure_data(particle_set, cell=cell, input_section=subsys_section, error=error) + fist_nonbond_env%charges) + CALL write_particle_distances(particle_set,cell,subsys_section) + CALL write_structure_data(particle_set, cell=cell, input_section=subsys_section) ! Print symmetry information - CALL write_symmetry(particle_set,cell,subsys_section,error) + CALL write_symmetry(particle_set,cell,subsys_section) ! Distribute molecules and atoms using the new data structures *** CALL distribute_molecules_1d ( atomic_kind_set=atomic_kind_set,& @@ -302,23 +298,22 @@ SUBROUTINE fist_init_subsys ( fist_env, subsys, cell, cell_ref, fist_nonbond_env local_molecules=local_molecules,& prev_molecule_kind_set=prev_molecule_kind_set,& prev_local_molecules=prev_local_molecules,& - force_env_section=force_env_section,& - error=error ) + force_env_section=force_env_section) ! Create ewald grids grid_print_section => section_vals_get_subs_vals(force_env_section,& - "PRINT%GRID_INFORMATION",error=error) - CALL ewald_pw_create ( ewald_pw, ewald_env, cell, cell_ref, grid_print_section, error ) + "PRINT%GRID_INFORMATION") + CALL ewald_pw_create ( ewald_pw, ewald_env, cell, cell_ref, grid_print_section) ! Initialize ewald grids - CALL ewald_pw_grid_update(ewald_pw, ewald_env, cell%hmat, error) + CALL ewald_pw_grid_update(ewald_pw, ewald_env, cell%hmat) ! Possibly Initialize the multipole environment CALL ewald_env_get(ewald_env, do_multipoles=do_multipoles, & - max_multipole=max_multipole, error=error) + max_multipole=max_multipole) IF(do_multipoles) & - CALL create_multipole_type(multipoles, particle_set, subsys_section, max_multipole, error) - CALL cp_subsys_set(subsys, multipoles=multipoles, cell=cell, error=error) + CALL create_multipole_type(multipoles, particle_set, subsys_section, max_multipole) + CALL cp_subsys_set(subsys, multipoles=multipoles, cell=cell) ! Set the fist_env CALL fist_env_set ( fist_env=fist_env,& @@ -327,12 +322,12 @@ SUBROUTINE fist_init_subsys ( fist_env, subsys, cell, cell_ref, fist_nonbond_env local_particles=local_particles,& ewald_env=ewald_env, ewald_pw=ewald_pw, & fist_nonbond_env=fist_nonbond_env,& - thermo=thermo ,error=error) + thermo=thermo) - CALL distribution_1d_release(local_particles, error=error) - CALL distribution_1d_release(local_molecules, error=error) - CALL ewald_pw_release(ewald_pw, error) - CALL release_multipole_type(multipoles, error) + CALL distribution_1d_release(local_particles) + CALL distribution_1d_release(local_molecules) + CALL ewald_pw_release(ewald_pw) + CALL release_multipole_type(multipoles) CALL timestop(handle) END SUBROUTINE fist_init_subsys diff --git a/src/fist_environment_types.F b/src/fist_environment_types.F index d5343cedaf..4b7f9288bc 100644 --- a/src/fist_environment_types.F +++ b/src/fist_environment_types.F @@ -143,7 +143,6 @@ MODULE fist_environment_types !> \param multipoles ... !> \param results ... !> \param exclusions ... -!> \param error ... !> \par History !> 11/03 !> \author CJM @@ -152,7 +151,7 @@ SUBROUTINE fist_env_get( fist_env, atomic_kind_set, particle_set, ewald_pw, & local_particles, local_molecules, molecule_kind_set, molecule_set, cell,& cell_ref, ewald_env, fist_nonbond_env, thermo, para_env, subsys, qmmm,& qmmm_env, input, shell_model, shell_model_ad, shell_particle_set,& - core_particle_set, multipoles, results, exclusions, error ) + core_particle_set, multipoles, results, exclusions) TYPE(fist_environment_type), INTENT(IN) :: fist_env TYPE(atomic_kind_type), OPTIONAL, & @@ -187,7 +186,6 @@ SUBROUTINE fist_env_get( fist_env, atomic_kind_set, particle_set, ewald_pw, & TYPE(cp_result_type), OPTIONAL, POINTER :: results TYPE(exclusion_type), DIMENSION(:), & OPTIONAL, POINTER :: exclusions - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_env_get', & routineP = moduleN//':'//routineN @@ -229,8 +227,7 @@ SUBROUTINE fist_env_get( fist_env, atomic_kind_set, particle_set, ewald_pw, & core_particles=core_particles,& multipoles=fist_multipoles,& results=results,& - cell=cell,& - error=error) + cell=cell) IF (PRESENT(atomic_kind_set)) atomic_kind_set => atomic_kinds%els IF (PRESENT(particle_set)) particle_set => particles%els IF (PRESENT(molecule_kind_set)) molecule_kind_set => molecule_kinds_new%els @@ -244,16 +241,14 @@ END SUBROUTINE fist_env_get !> \brief Initialise the FIST environment. !> \param fist_env the pointer to the fist_env !> \param para_env ... -!> \param error ... !> \par History !> 11/03 !> \author CJM ! ***************************************************************************** - SUBROUTINE init_fist_env ( fist_env, para_env, error ) + SUBROUTINE init_fist_env ( fist_env, para_env) TYPE(fist_environment_type), INTENT(OUT) :: fist_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error NULLIFY (fist_env%input) NULLIFY (fist_env%qmmm_env) @@ -267,9 +262,9 @@ SUBROUTINE init_fist_env ( fist_env, para_env, error ) fist_env % qmmm = .FALSE. fist_env % shell_model = .FALSE. fist_env % shell_model_ad = .FALSE. - CALL qmmm_env_mm_create(fist_env%qmmm_env, error) + CALL qmmm_env_mm_create(fist_env%qmmm_env) NULLIFY (fist_env%subsys) - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) fist_env%para_env => para_env fist_env%ref_count=1 last_fist_env_id_nr=last_fist_env_id_nr+1 @@ -298,7 +293,6 @@ END SUBROUTINE init_fist_env !> \param shell_model ... !> \param shell_model_ad ... !> \param exclusions ... -!> \param error ... !> \par History !> 11/03 !> \author CJM @@ -307,7 +301,7 @@ SUBROUTINE fist_env_set( fist_env, atomic_kind_set, particle_set, ewald_pw, & local_particles, local_molecules, molecule_kind_set, & molecule_set, cell_ref, ewald_env, & fist_nonbond_env, thermo, subsys, qmmm, qmmm_env, & - input, shell_model, shell_model_ad, exclusions, error ) + input, shell_model, shell_model_ad, exclusions) TYPE(fist_environment_type), POINTER :: fist_env TYPE(atomic_kind_type), OPTIONAL, & @@ -336,7 +330,6 @@ SUBROUTINE fist_env_set( fist_env, atomic_kind_set, particle_set, ewald_pw, & LOGICAL, OPTIONAL :: shell_model, shell_model_ad TYPE(exclusion_type), DIMENSION(:), & OPTIONAL, POINTER :: exclusions - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_env_set', & routineP = moduleN//':'//routineN @@ -348,90 +341,80 @@ SUBROUTINE fist_env_set( fist_env, atomic_kind_set, particle_set, ewald_pw, & TYPE(particle_list_type), POINTER :: particles failure=.FALSE. - CPPrecondition(fist_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(fist_env%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(qmmm)) fist_env%qmmm = qmmm IF (PRESENT(qmmm_env)) THEN - CALL qmmm_env_mm_retain(qmmm_env, error) - CALL qmmm_env_mm_release(fist_env%qmmm_env, error=error) + CALL qmmm_env_mm_retain(qmmm_env) + CALL qmmm_env_mm_release(fist_env%qmmm_env) fist_env%qmmm_env => qmmm_env END IF IF ( PRESENT ( ewald_env ) ) THEN - CALL ewald_env_retain ( ewald_env, error = error ) - CALL ewald_env_release ( fist_env % ewald_env, error = error ) + CALL ewald_env_retain ( ewald_env) + CALL ewald_env_release ( fist_env % ewald_env) fist_env % ewald_env => ewald_env ENDIF IF ( PRESENT ( ewald_pw ) ) THEN - CALL ewald_pw_retain ( ewald_pw, error = error ) - CALL ewald_pw_release ( fist_env % ewald_pw, error = error ) + CALL ewald_pw_retain ( ewald_pw) + CALL ewald_pw_release ( fist_env % ewald_pw) fist_env % ewald_pw => ewald_pw ENDIF IF (PRESENT(cell_ref)) THEN - CALL cell_retain(cell_ref, error=error) - CALL cell_release(fist_env%cell_ref,error=error) + CALL cell_retain(cell_ref) + CALL cell_release(fist_env%cell_ref) fist_env%cell_ref => cell_ref END IF IF ( PRESENT ( fist_nonbond_env ) ) THEN - CALL fist_nonbond_env_retain ( fist_nonbond_env, error ) - CALL fist_nonbond_env_release ( fist_env % fist_nonbond_env, error ) + CALL fist_nonbond_env_retain ( fist_nonbond_env) + CALL fist_nonbond_env_release ( fist_env % fist_nonbond_env) fist_env % fist_nonbond_env => fist_nonbond_env ENDIF IF (PRESENT(input)) THEN - CALL section_vals_retain(input,error=error) - CALL section_vals_release(fist_env%input,error=error) + CALL section_vals_retain(input) + CALL section_vals_release(fist_env%input) fist_env%input => input END IF IF ( PRESENT ( thermo ) ) fist_env % thermo => thermo IF (PRESENT(subsys)) THEN - CALL cp_subsys_retain(subsys,error=error) - CALL cp_subsys_release(fist_env%subsys,error=error) + CALL cp_subsys_retain(subsys) + CALL cp_subsys_release(fist_env%subsys) fist_env%subsys => subsys END IF IF (PRESENT(atomic_kind_set)) THEN CALL atomic_kind_list_create(atomic_kinds,& - els_ptr=atomic_kind_set,& - error=error) + els_ptr=atomic_kind_set) CALL cp_subsys_set(fist_env%subsys,& - atomic_kinds=atomic_kinds,& - error=error) - CALL atomic_kind_list_release(atomic_kinds,error=error) + atomic_kinds=atomic_kinds) + CALL atomic_kind_list_release(atomic_kinds) END IF IF (PRESENT(particle_set)) THEN CALL particle_list_create(particles,& - els_ptr=particle_set,& - error=error) + els_ptr=particle_set) CALL cp_subsys_set(fist_env%subsys,& - particles=particles,& - error=error) - CALL particle_list_release(particles,error=error) + particles=particles) + CALL particle_list_release(particles) END IF IF (PRESENT(local_particles)) THEN CALL cp_subsys_set(fist_env%subsys,& - local_particles=local_particles,& - error=error) + local_particles=local_particles) END IF IF (PRESENT(local_molecules)) THEN CALL cp_subsys_set(fist_env%subsys,& - local_molecules_new=local_molecules,& - error=error) + local_molecules_new=local_molecules) END IF IF (PRESENT(molecule_kind_set)) THEN CALL mol_kind_new_list_create(molecule_kinds_new,& - els_ptr=molecule_kind_set,& - error=error) + els_ptr=molecule_kind_set) CALL cp_subsys_set(fist_env%subsys,& - molecule_kinds_new=molecule_kinds_new,& - error=error) - CALL mol_kind_new_list_release(molecule_kinds_new,error=error) + molecule_kinds_new=molecule_kinds_new) + CALL mol_kind_new_list_release(molecule_kinds_new) END IF IF (PRESENT(molecule_set)) THEN CALL mol_new_list_create(molecules_new,& - els_ptr=molecule_set,& - error=error) + els_ptr=molecule_set) CALL cp_subsys_set(fist_env%subsys,& - molecules_new=molecules_new,& - error=error) - CALL mol_new_list_release(molecules_new,error=error) + molecules_new=molecules_new) + CALL mol_new_list_release(molecules_new) END IF IF (PRESENT(exclusions)) fist_env%exclusions=>exclusions IF (PRESENT(shell_model)) THEN @@ -447,16 +430,13 @@ END SUBROUTINE fist_env_set !> \brief allocates and intitializes a fist_env !> \param fist_env the object to create !> \param para_env the parallel environement for the qs_env -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fist_env_create(fist_env,para_env,error) + SUBROUTINE fist_env_create(fist_env,para_env) TYPE(fist_environment_type), POINTER :: fist_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_env_create', & routineP = moduleN//':'//routineN @@ -467,22 +447,19 @@ SUBROUTINE fist_env_create(fist_env,para_env,error) failure=.FALSE. ALLOCATE(fist_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL init_fist_env(fist_env,para_env=para_env, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL init_fist_env(fist_env,para_env=para_env) END SUBROUTINE fist_env_create ! ***************************************************************************** !> \brief retains the given fist_env (see doc/ReferenceCounting.html) !> \param fist_env the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fist_env_retain(fist_env,error) + SUBROUTINE fist_env_retain(fist_env) TYPE(fist_environment_type), POINTER :: fist_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_env_retain', & routineP = moduleN//':'//routineN @@ -490,23 +467,20 @@ SUBROUTINE fist_env_retain(fist_env,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(fist_env),cp_failure_level,routineP,error,failure) - CPPrecondition(fist_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fist_env),cp_failure_level,routineP,failure) + CPPrecondition(fist_env%ref_count>0,cp_failure_level,routineP,failure) fist_env%ref_count=fist_env%ref_count+1 END SUBROUTINE fist_env_retain ! ***************************************************************************** !> \brief releases the given fist_env (see doc/ReferenceCounting.html) !> \param fist_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fist_env_release(fist_env,error) + SUBROUTINE fist_env_release(fist_env) TYPE(fist_environment_type), POINTER :: fist_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_env_release', & routineP = moduleN//':'//routineN @@ -517,23 +491,23 @@ SUBROUTINE fist_env_release(fist_env,error) failure=.FALSE. IF (ASSOCIATED(fist_env)) THEN - CPPrecondition(fist_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(fist_env%ref_count>0,cp_failure_level,routineP,failure) fist_env%ref_count=fist_env%ref_count-1 IF (fist_env%ref_count<1) THEN - CALL qmmm_env_mm_release(fist_env%qmmm_env, error=error) - CALL cell_release(fist_env%cell_ref,error=error) - CALL ewald_pw_release(fist_env%ewald_pw,error=error) - CALL ewald_env_release(fist_env%ewald_env,error=error) - CALL cp_para_env_release(fist_env%para_env,error=error) + CALL qmmm_env_mm_release(fist_env%qmmm_env) + CALL cell_release(fist_env%cell_ref) + CALL ewald_pw_release(fist_env%ewald_pw) + CALL ewald_env_release(fist_env%ewald_env) + CALL cp_para_env_release(fist_env%para_env) CALL deallocate_fist_energy(fist_env%thermo) - CALL fist_nonbond_env_release ( fist_env % fist_nonbond_env, error = error ) - CALL cp_subsys_release(fist_env%subsys,error=error) - CALL section_vals_release(fist_env%input,error=error) - CALL exclusion_release(fist_env%exclusions,error=error) + CALL fist_nonbond_env_release ( fist_env % fist_nonbond_env) + CALL cp_subsys_release(fist_env%subsys) + CALL section_vals_release(fist_env%input) + CALL exclusion_release(fist_env%exclusions) DEALLOCATE(fist_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(fist_env) diff --git a/src/fist_force.F b/src/fist_force.F index fcb3f13aaf..4d60fd8c0b 100644 --- a/src/fist_force.F +++ b/src/fist_force.F @@ -105,7 +105,6 @@ MODULE fist_force !> total pressure tensor from the potentials !> \param fist_env ... !> \param debug ... -!> \param error ... !> \par History !> Harald Forbert(Dec-2000): Changes for multiple linked lists !> cjm, 20-Feb-2001: box_ref used to initialize ewald. Now @@ -116,11 +115,10 @@ MODULE fist_force !> cjm, 28-Feb-2006: box_change is gone !> \author CJM & JGH ! ***************************************************************************** - SUBROUTINE fist_calc_energy_force(fist_env, debug, error) + SUBROUTINE fist_calc_energy_force(fist_env, debug) TYPE(fist_environment_type), POINTER :: fist_env TYPE(debug_variables_type), & INTENT(INOUT), OPTIONAL :: debug - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_calc_energy_force', & routineP = moduleN//':'//routineN @@ -176,18 +174,16 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) failure = .FALSE. NULLIFY(logger) NULLIFY(subsys,virial,atprop_env,para_env,force_env_section) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL fist_env_get(fist_env,& subsys=subsys,& para_env=para_env,& - input=force_env_section,& - error=error) + input=force_env_section) CALL cp_subsys_get(subsys,& virial=virial,& - atprop=atprop_env,& - error=error) + atprop=atprop_env) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) NULLIFY(atomic_kind,atomic_kind_set,cell,ewald_pw,ewald_env,& @@ -196,11 +192,11 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) shell, shell_particle_set, core_particle_set, thermo, multipoles,& e_coulomb, pv_coulomb) - mm_section => section_vals_get_subs_vals(force_env_section,"MM",error=error) + mm_section => section_vals_get_subs_vals(force_env_section,"MM") iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%DERIVATIVES",& - extension=".mmLog",error=error) + extension=".mmLog") iw2= cp_print_key_unit_nr(logger,mm_section,"PRINT%EWALD_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") CALL fist_env_get(fist_env, ewald_pw=ewald_pw, ewald_env=ewald_env, & local_particles=local_particles, particle_set=particle_set, & @@ -208,14 +204,14 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) local_molecules=local_molecules, thermo=thermo, & molecule_kind_set=molecule_kind_set, fist_nonbond_env=fist_nonbond_env,& cell=cell, shell_model=shell_present, shell_model_ad=shell_model_ad, & - multipoles=multipoles, exclusions=exclusions, error=error) + multipoles=multipoles, exclusions=exclusions) CALL ewald_env_get(ewald_env, ewald_type=ewald_type, do_multipoles=do_multipoles,& - do_ipol=do_ipol,error=error) + do_ipol=do_ipol) ! Initialize ewald grids CALL init_cell(cell) - CALL ewald_pw_grid_update(ewald_pw, ewald_env, cell%hmat, error) + CALL ewald_pw_grid_update(ewald_pw, ewald_env, cell%hmat) natoms = SIZE(particle_set) nlocal_particles = 0 @@ -225,19 +221,19 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) ENDDO ALLOCATE(f_nonbond(3,natoms), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nshell = 0 IF(shell_present)THEN CALL fist_env_get(fist_env, shell_particle_set=shell_particle_set, & - core_particle_set=core_particle_set, error=error) - CPPostcondition(ASSOCIATED(shell_particle_set),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(core_particle_set),cp_failure_level,routineP,error,failure) + core_particle_set=core_particle_set) + CPPostcondition(ASSOCIATED(shell_particle_set),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(core_particle_set),cp_failure_level,routineP,failure) nshell = SIZE(shell_particle_set) ALLOCATE(fshell_nonbond(3, nshell), STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fcore_nonbond(3, nshell), STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE NULLIFY(shell_particle_set,core_particle_set) END IF @@ -247,11 +243,11 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF (ASSOCIATED(exclusions)) THEN CALL list_control(atomic_kind_set, particle_set, local_particles, & cell, fist_nonbond_env,para_env, mm_section, shell_particle_set,& - core_particle_set, exclusions=exclusions, error=error) + core_particle_set, exclusions=exclusions) ELSE CALL list_control(atomic_kind_set, particle_set, local_particles, & cell, fist_nonbond_env,para_env, mm_section, shell_particle_set,& - core_particle_set, error=error) + core_particle_set) END IF END IF @@ -306,11 +302,11 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF(fist_nonbond_env%do_nonbonded)THEN ! Compute density for EAM - CALL density_nonbond(fist_nonbond_env, particle_set, cell, para_env ,error=error) + CALL density_nonbond(fist_nonbond_env, particle_set, cell, para_env) ! Compute embedding function and manybody energy CALL energy_manybody(fist_nonbond_env, atomic_kind_set, local_particles, particle_set,& - cell, pot_manybody, para_env , mm_section, error=error) + cell, pot_manybody, para_env , mm_section) ! Nonbond contribution + Manybody Forces IF(shell_present)THEN @@ -318,15 +314,13 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) pot_nonbond, f_nonbond, pv_nonbond, & fshell_nonbond=fshell_nonbond, fcore_nonbond=fcore_nonbond, & atprop_env=atprop_env,& - atomic_kind_set=atomic_kind_set, use_virial=use_virial, & - error=error) + atomic_kind_set=atomic_kind_set, use_virial=use_virial) ELSE CALL force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & pot_nonbond, f_nonbond, pv_nonbond, atprop_env=atprop_env,& - atomic_kind_set=atomic_kind_set, use_virial=use_virial, & - error=error) + atomic_kind_set=atomic_kind_set, use_virial=use_virial) CALL force_nonbond_manybody(fist_nonbond_env, particle_set, cell, f_nonbond, pv_nonbond,& - use_virial=use_virial, error=error) + use_virial=use_virial) END IF ELSE f_nonbond = 0.0_dp @@ -361,29 +355,29 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) END SELECT ! Allocate and zeroing arrays ALLOCATE(fg_coulomb(3, fg_coulomb_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fg_coulomb = 0.0_dp IF(shell_present)THEN ALLOCATE(fgshell_coulomb(3, nshell), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fgcore_coulomb(3, nshell), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fgshell_coulomb = 0.0_dp fgcore_coulomb = 0.0_dp END IF IF(shell_present.AND.do_multipoles)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipoles and Core-Shell model not implemented.",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF ! If not multipole: Compute self-interaction and neutralizing background ! for multipoles is handled separately.. IF(.NOT.do_multipoles)THEN CALL ewald_self(ewald_env, cell, atomic_kind_set, local_particles, & - thermo%e_self, thermo%e_neut, fist_nonbond_env%charges, error=error) + thermo%e_self, thermo%e_neut, fist_nonbond_env%charges) IF(atprop_env%energy) THEN CALL ewald_self_atom(ewald_env, atomic_kind_set, local_particles, & - atprop_env%atener, fist_nonbond_env%charges, error=error) + atprop_env%atener, fist_nonbond_env%charges) atprop_env%atener = atprop_env%atener + thermo%e_neut/SIZE(atprop_env%atener) END IF END IF @@ -394,14 +388,13 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF (ASSOCIATED(fist_nonbond_env%charges)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Polarizable force field and array charges not implemented!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF ! Converge the dipoles self-consistently CALL fist_pol_evaluate(atomic_kind_set, multipoles, ewald_env, & ewald_pw, fist_nonbond_env, cell, particle_set, & local_particles, thermo, vg_coulomb, pot_nonbond, f_nonbond, & - fg_coulomb, use_virial, pv_g, pv_nonbond, mm_section, do_ipol, & - error) + fg_coulomb, use_virial, pv_g, pv_nonbond, mm_section, do_ipol) ELSE ! Non-Polarizable force-field SELECT CASE(ewald_type) @@ -412,16 +405,16 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF (ASSOCIATED(fist_nonbond_env%charges)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Core-Shell and array charges not implemented!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF IF(do_multipoles)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald and CORE-SHELL not yet implemented within Ewald sum!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) ELSE CALL cp_unimplemented_error(fromWhere=routineP, & message="Core-Shell model not yet implemented within Ewald sums.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF ELSE IF(do_multipoles)THEN @@ -429,7 +422,7 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF (ASSOCIATED(fist_nonbond_env%charges)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald and array charges not implemented!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF CALL ewald_multipole_evaluate(ewald_env, ewald_pw, fist_nonbond_env, cell, & particle_set, local_particles, vg_coulomb, pot_nonbond, thermo%e_neut,& @@ -438,21 +431,20 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) charges=multipoles%charges, dipoles=multipoles%dipoles,& quadrupoles=multipoles%quadrupoles, forces_local=fg_coulomb,& forces_glob=f_nonbond, pv_local=pv_g, pv_glob=pv_nonbond,iw=iw2,& - do_debug=.TRUE.,atomic_kind_set=atomic_kind_set, mm_section=mm_section,& - error=error) + do_debug=.TRUE.,atomic_kind_set=atomic_kind_set, mm_section=mm_section) ELSE IF(atprop_env%energy) THEN ALLOCATE(e_coulomb(fg_coulomb_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(atprop_env%stress) THEN ALLOCATE(pv_coulomb(3,3,fg_coulomb_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL ewald_evaluate(ewald_env, ewald_pw, cell, atomic_kind_set, particle_set,& local_particles, fg_coulomb, vg_coulomb, pv_g ,use_virial=use_virial,& charges=fist_nonbond_env%charges, e_coulomb=e_coulomb, & - pv_coulomb=pv_coulomb, error=error) + pv_coulomb=pv_coulomb) END IF END IF CASE(do_ewald_pme) @@ -462,17 +454,17 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF (ASSOCIATED(fist_nonbond_env%charges)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Core-Shell and array charges not implemented!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF IF(do_multipoles)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald and CORE-SHELL not yet implemented within a PME scheme!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) ELSE CALL pme_evaluate(ewald_env, ewald_pw, cell, particle_set, vg_coulomb, fg_coulomb,& pv_g,shell_particle_set=shell_particle_set, core_particle_set=core_particle_set,& fgshell_coulomb=fgshell_coulomb, fgcore_coulomb=fgcore_coulomb, use_virial=use_virial,& - atprop=atprop_env, error=error) + atprop=atprop_env) CALL mp_sum(fgshell_coulomb, para_env%group) CALL mp_sum(fgcore_coulomb, para_env%group) END IF @@ -480,11 +472,11 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF(do_multipoles)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald not yet implemented within a PME scheme!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) ELSE CALL pme_evaluate(ewald_env, ewald_pw, cell, particle_set, vg_coulomb, fg_coulomb,& pv_g, use_virial=use_virial, charges=fist_nonbond_env%charges, & - atprop=atprop_env, error=error) + atprop=atprop_env) END IF END IF CALL mp_sum(fg_coulomb, para_env%group) @@ -495,17 +487,17 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF (ASSOCIATED(fist_nonbond_env%charges)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Core-Shell and array charges not implemented!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF IF(do_multipoles)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald and CORE-SHELL not yet implemented within a SPME scheme!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) ELSE CALL spme_evaluate(ewald_env, ewald_pw, cell, particle_set, fg_coulomb, vg_coulomb,& pv_g,shell_particle_set=shell_particle_set, core_particle_set=core_particle_set,& fgshell_coulomb=fgshell_coulomb, fgcore_coulomb=fgcore_coulomb,use_virial=use_virial,& - atprop=atprop_env, error=error) + atprop=atprop_env) CALL mp_sum(fgshell_coulomb, para_env%group) CALL mp_sum(fgcore_coulomb, para_env%group) END IF @@ -513,11 +505,11 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) IF(do_multipoles)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald not yet implemented within a SPME scheme!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) ELSE CALL spme_evaluate(ewald_env, ewald_pw, cell, particle_set, fg_coulomb, vg_coulomb,& pv_g, use_virial=use_virial, charges=fist_nonbond_env%charges, & - atprop=atprop_env, error=error) + atprop=atprop_env) END IF END IF CALL mp_sum(fg_coulomb, para_env%group) @@ -534,13 +526,13 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) local_particles, particle_set, ewald_env, thermo%e_bonded, & pv_bc, shell_particle_set=shell_particle_set, & core_particle_set=core_particle_set, atprop_env=atprop_env, cell=cell, & - use_virial=use_virial, error=error) + use_virial=use_virial) ELSE IF(.NOT. do_multipoles)THEN CALL bonded_correct_gaussian(fist_nonbond_env, & atomic_kind_set, local_particles, particle_set, & ewald_env, thermo%e_bonded, pv_bc=pv_bc, atprop_env=atprop_env, cell=cell, & - use_virial=use_virial, error=error) + use_virial=use_virial) END IF END IF END IF @@ -579,8 +571,7 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) pot_torsion, pot_imptors, pot_opbend, pot_shell, pv_bond, pv_bend, & pv_urey_bradley, pv_torsion, pv_imptors, pv_opbend, & debug%f_bond, debug%f_bend, debug%f_torsion, debug%f_ub, & - debug%f_imptors, debug%f_opbend, cell, use_virial, atprop_env, & - error) + debug%f_imptors, debug%f_opbend, cell, use_virial, atprop_env) ELSE CALL force_intra_control(molecule_set, molecule_kind_set, & @@ -588,20 +579,20 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) core_particle_set, pot_bond, pot_bend, pot_urey_bradley, & pot_torsion, pot_imptors, pot_opbend, pot_shell, pv_bond, pv_bend, & pv_urey_bradley, pv_torsion, pv_imptors, pv_opbend, & - cell=cell, use_virial=use_virial, atprop_env=atprop_env, error=error) + cell=cell, use_virial=use_virial, atprop_env=atprop_env) ENDIF IF(iw>0)THEN - xdum1 = cp_unit_from_cp2k(pot_bond,"kcalmol",error=error) - xdum2 = cp_unit_from_cp2k(pot_bend,"kcalmol",error=error) - xdum3 = cp_unit_from_cp2k(pot_urey_bradley,"kcalmol",error=error) + xdum1 = cp_unit_from_cp2k(pot_bond,"kcalmol") + xdum2 = cp_unit_from_cp2k(pot_bend,"kcalmol") + xdum3 = cp_unit_from_cp2k(pot_urey_bradley,"kcalmol") WRITE(iw,'(A)')" FIST energy contributions in kcal/mol:" WRITE(iw,'(1x,"BOND = ",f13.4,'//& '2x,"ANGLE = ",f13.4,'//& '2x,"UBRAD = ",f13.4)')xdum1, xdum2, xdum3 - xdum1 = cp_unit_from_cp2k(pot_torsion,"kcalmol",error=error) - xdum2 = cp_unit_from_cp2k(pot_imptors,"kcalmol",error=error) - xdum3 = cp_unit_from_cp2k(pot_opbend,"kcalmol",error=error) + xdum1 = cp_unit_from_cp2k(pot_torsion,"kcalmol") + xdum2 = cp_unit_from_cp2k(pot_imptors,"kcalmol") + xdum3 = cp_unit_from_cp2k(pot_opbend,"kcalmol") WRITE(iw,'(1x,"TORSION = ",f13.4,'//& '2x,"IMPTORS = ",f13.4,'//& '2x,"OPBEND = ",f13.4)')xdum1, xdum2, xdum3 @@ -643,7 +634,7 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) ! We first sum the forces in f_nonbond, this allows for a more efficient ! global sum in the parallel code and in the end copy them back to part ALLOCATE(f_total(3,natoms), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) f_total = 0.0_dp DO i = 1, natoms f_total(1, i)= particle_set(i)%f(1)+ f_nonbond(1, i) @@ -652,9 +643,9 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) END DO IF(shell_present)THEN ALLOCATE(fshell_total(3,nshell), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fcore_total(3,nshell), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nshell fshell_total(1, i)= shell_particle_set(i)%f(1)+ fshell_nonbond(1, i) fshell_total(2, i)= shell_particle_set(i)%f(2)+ fshell_nonbond(2, i) @@ -703,11 +694,11 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) END DO IF(atprop_env%energy) THEN DEALLOCATE(e_coulomb, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(atprop_env%stress) THEN DEALLOCATE(pv_coulomb, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -785,7 +776,7 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) ELSEIF(shell_present .AND. .NOT. shell_model_ad)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Non adiabatic shell-model not implemented.",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ELSE DO i = 1, natoms particle_set(i)%f(1)= f_total(1, i)+ fg_coulomb(1, i) @@ -826,7 +817,7 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) ELSEIF(shell_present .AND. .NOT. shell_model_ad)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Non adiabatic shell-model not implemented.",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ELSE DO i = 1, natoms particle_set(i)%f(1)= f_total(1, i) @@ -899,32 +890,32 @@ SUBROUTINE fist_calc_energy_force(fist_env, debug, error) END IF ! print properties if requested - print_section => section_vals_get_subs_vals(mm_section,"PRINT",error=error) - CALL print_fist(fist_env, print_section, atomic_kind_set, particle_set, cell, error) + print_section => section_vals_get_subs_vals(mm_section,"PRINT") + CALL print_fist(fist_env, print_section, atomic_kind_set, particle_set, cell) ! deallocating all local variables IF(ALLOCATED(fg_coulomb))THEN DEALLOCATE(fg_coulomb, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ALLOCATED(f_total))THEN DEALLOCATE(f_total, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(f_nonbond, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(shell_present)THEN DEALLOCATE(fshell_total, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ewald_type /= do_ewald_none)THEN DEALLOCATE(fgshell_coulomb, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(fshell_nonbond, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%DERIVATIVES",error=error) - CALL cp_print_key_finished_output(iw2,logger,mm_section,"PRINT%EWALD_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%DERIVATIVES") + CALL cp_print_key_finished_output(iw2,logger,mm_section,"PRINT%EWALD_INFO") CALL timestop(handle) END SUBROUTINE fist_calc_energy_force @@ -936,12 +927,11 @@ END SUBROUTINE fist_calc_energy_force !> \param atomic_kind_set ... !> \param particle_set ... !> \param cell ... -!> \param error ... !> \par History !> [01.2006] created !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE print_fist(fist_env, print_section, atomic_kind_set, particle_set, cell, error) + SUBROUTINE print_fist(fist_env, print_section, atomic_kind_set, particle_set, cell) TYPE(fist_environment_type), POINTER :: fist_env TYPE(section_vals_type), POINTER :: print_section TYPE(atomic_kind_type), DIMENSION(:), & @@ -949,7 +939,6 @@ SUBROUTINE print_fist(fist_env, print_section, atomic_kind_set, particle_set, ce TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: unit_nr TYPE(cp_logger_type), POINTER :: logger @@ -957,16 +946,16 @@ SUBROUTINE print_fist(fist_env, print_section, atomic_kind_set, particle_set, ce TYPE(section_vals_type), POINTER :: print_key NULLIFY(logger,print_key,fist_nonbond_env) - logger => cp_error_get_logger(error) - print_key => section_vals_get_subs_vals(print_section,"dipole",error=error) - CALL fist_env_get(fist_env, fist_nonbond_env=fist_nonbond_env, error=error) - IF(BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),& + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(print_section,"dipole") + CALL fist_env_get(fist_env, fist_nonbond_env=fist_nonbond_env) + IF(BTEST(cp_print_key_should_output(logger%iter_info,print_key),& cp_p_file))THEN unit_nr=cp_print_key_unit_nr(logger,print_section,"dipole",& - extension=".data",middle_name="MM_DIPOLE",log_filename=.FALSE.,error=error) + extension=".data",middle_name="MM_DIPOLE",log_filename=.FALSE.) CALL fist_dipole(fist_env, print_section, atomic_kind_set, particle_set,& - cell, unit_nr, fist_nonbond_env%charges, error) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + cell, unit_nr, fist_nonbond_env%charges) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF END SUBROUTINE print_fist @@ -981,14 +970,13 @@ END SUBROUTINE print_fist !> \param cell ... !> \param unit_nr ... !> \param charges ... -!> \param error ... !> \par History !> [01.2006] created !> [12.2007] tlaino - University of Zurich - debug and extended !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE fist_dipole(fist_env, print_section, atomic_kind_set, particle_set,& - cell, unit_nr, charges, error) + cell, unit_nr, charges) TYPE(fist_environment_type), POINTER :: fist_env TYPE(section_vals_type), POINTER :: print_section TYPE(atomic_kind_type), DIMENSION(:), & @@ -999,7 +987,6 @@ SUBROUTINE fist_dipole(fist_env, print_section, atomic_kind_set, particle_set,& INTEGER, INTENT(IN) :: unit_nr REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=default_string_length) :: description, dipole_type COMPLEX(KIND=dp) :: dzeta, dzphase(3), zeta, & @@ -1018,13 +1005,13 @@ SUBROUTINE fist_dipole(fist_env, print_section, atomic_kind_set, particle_set,& NULLIFY(atomic_kind) ! Reference point - reference = section_get_ival(print_section,keyword_name="DIPOLE%REFERENCE",error=error) + reference = section_get_ival(print_section,keyword_name="DIPOLE%REFERENCE") NULLIFY(ref_point) description='[DIPOLE]' - CALL section_vals_val_get(print_section,"DIPOLE%REF_POINT",r_vals=ref_point,error=error) - CALL section_vals_val_get(print_section,"DIPOLE%PERIODIC",l_val=do_berry,error=error) + CALL section_vals_val_get(print_section,"DIPOLE%REF_POINT",r_vals=ref_point) + CALL section_vals_val_get(print_section,"DIPOLE%PERIODIC",l_val=do_berry) - CALL get_reference_point(rcc,drcc,fist_env=fist_env,reference=reference,ref_point=ref_point,error=error) + CALL get_reference_point(rcc,drcc,fist_env=fist_env,reference=reference,ref_point=ref_point) ! Dipole deriv will be the derivative of the Dipole(dM/dt=\sum e_j v_j) dipole_deriv = 0.0_dp @@ -1081,9 +1068,9 @@ SUBROUTINE fist_dipole(fist_env, print_section, atomic_kind_set, particle_set,& dipole = MATMUL(cell%hmat, ci)/twopi dipole_deriv = MATMUL(cell%hmat, dci)/twopi END IF - CALL fist_env_get(fist_env=fist_env,results=results,error=error) - CALL cp_results_erase(results,description,error=error) - CALL put_results(results,description,dipole,error=error) + CALL fist_env_get(fist_env=fist_env,results=results) + CALL cp_results_erase(results,description) + CALL put_results(results,description,dipole) ELSE dipole_type="[Non Periodic]" DO i = 1, SIZE(particle_set) @@ -1094,9 +1081,9 @@ SUBROUTINE fist_dipole(fist_env, print_section, atomic_kind_set, particle_set,& dipole = dipole - q *(ria-rcc) dipole_deriv(:)= dipole_deriv(:)- q *(particle_set(i)%v(:)- drcc) END DO - CALL fist_env_get(fist_env=fist_env,results=results,error=error) - CALL cp_results_erase(results,description,error=error) - CALL put_results(results,description,dipole,error=error) + CALL fist_env_get(fist_env=fist_env,results=results) + CALL cp_results_erase(results,description) + CALL put_results(results,description,dipole) END IF IF(unit_nr>0)THEN WRITE(unit_nr,'(1X,A,T48,3F11.6)')"MM DIPOLE "//TRIM(dipole_type)//"(A.U.)|",dipole diff --git a/src/fist_intra_force.F b/src/fist_intra_force.F index 17dfaeebc3..ad3e64c1fa 100644 --- a/src/fist_intra_force.F +++ b/src/fist_intra_force.F @@ -72,7 +72,6 @@ MODULE fist_intra_force !> \param cell ... !> \param use_virial ... !> \param atprop_env ... -!> \param error ... !> \par History !> none !> \author CJM @@ -82,7 +81,7 @@ SUBROUTINE force_intra_control(molecule_set, molecule_kind_set, & pot_bond, pot_bend, pot_urey_bradley, pot_torsion, pot_imp_torsion, & pot_opbend, pot_shell, pv_bond, pv_bend, pv_urey_bradley, pv_torsion, & pv_imp_torsion, pv_opbend, f_bond, f_bend, f_torsion, f_ub, & - f_imptor, f_opbend, cell, use_virial, atprop_env, error) + f_imptor, f_opbend, cell, use_virial, atprop_env) TYPE(molecule_type), POINTER :: molecule_set( : ) TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) @@ -102,7 +101,6 @@ SUBROUTINE force_intra_control(molecule_set, molecule_kind_set, & TYPE(cell_type), POINTER :: cell LOGICAL, INTENT(IN) :: use_virial TYPE(atprop_type), POINTER :: atprop_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_intra_control', & routineP = moduleN//':'//routineN @@ -133,7 +131,7 @@ SUBROUTINE force_intra_control(molecule_set, molecule_kind_set, & CALL timeset ( routineN, handle ) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF ( PRESENT ( f_bond)) f_bond = 0.0_dp IF ( PRESENT ( f_bend)) f_bend = 0.0_dp diff --git a/src/fist_main.F b/src/fist_main.F index 2358e5af8c..b447590d8f 100644 --- a/src/fist_main.F +++ b/src/fist_main.F @@ -58,13 +58,12 @@ MODULE fist_main !> \param subsys_section ... !> \param use_motion_section ... !> \param prev_subsys ... -!> \param error ... !> \par Used By !> cp2k !> \author CJM ! ***************************************************************************** SUBROUTINE fist_create_force_env ( force_env, root_section, para_env, globenv,& - qmmm, qmmm_env, force_env_section, subsys_section, use_motion_section, prev_subsys, error) + qmmm, qmmm_env, force_env_section, subsys_section, use_motion_section, prev_subsys) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env @@ -76,7 +75,6 @@ SUBROUTINE fist_create_force_env ( force_env, root_section, para_env, globenv,& subsys_section LOGICAL, INTENT(IN) :: use_motion_section TYPE(cp_subsys_type), OPTIONAL, POINTER :: prev_subsys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fist_create_force_env', & routineP = moduleN//':'//routineN @@ -91,22 +89,22 @@ SUBROUTINE fist_create_force_env ( force_env, root_section, para_env, globenv,& myqmmm=qmmm END IF - CALL fist_env_create( fist_env, para_env = para_env ,error=error) + CALL fist_env_create( fist_env, para_env = para_env) IF (PRESENT(qmmm_env)) THEN - CALL fist_env_set (fist_env, qmmm=myqmmm, qmmm_env=qmmm_env, error=error) + CALL fist_env_set (fist_env, qmmm=myqmmm, qmmm_env=qmmm_env) ELSE - CALL fist_env_set (fist_env, qmmm=myqmmm, error=error) + CALL fist_env_set (fist_env, qmmm=myqmmm) END IF ! *** Read the input and the database files and perform further *** ! *** initializations for the setup of the FIST environment *** CALL fist_init ( fist_env, root_section, para_env, force_env_section,& - subsys_section, use_motion_section, prev_subsys=prev_subsys, error=error ) + subsys_section, use_motion_section, prev_subsys=prev_subsys) CALL force_env_create ( force_env, root_section, fist_env = fist_env, & para_env = para_env, globenv = globenv, & - force_env_section=force_env_section, error = error ) + force_env_section=force_env_section) - CALL fist_env_release ( fist_env, error = error ) + CALL fist_env_release ( fist_env) CALL timestop(handle) END SUBROUTINE fist_create_force_env diff --git a/src/fist_neighbor_list_control.F b/src/fist_neighbor_list_control.F index 39d62b0e71..54caff97e2 100644 --- a/src/fist_neighbor_list_control.F +++ b/src/fist_neighbor_list_control.F @@ -71,11 +71,10 @@ MODULE fist_neighbor_list_control !> \param core_particle_set ... !> \param force_update ... !> \param exclusions ... -!> \param error ... ! ***************************************************************************** SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & cell, fist_nonbond_env, para_env, mm_section,shell_particle_set,& - core_particle_set, force_update, exclusions, error) + core_particle_set, force_update, exclusions) TYPE(atomic_kind_type), POINTER :: atomic_kind_set(:) TYPE(particle_type), POINTER :: particle_set(:) @@ -89,7 +88,6 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & LOGICAL, INTENT(IN), OPTIONAL :: force_update TYPE(exclusion_type), DIMENSION(:), & OPTIONAL :: exclusions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'list_control', & routineP = moduleN//':'//routineN @@ -117,7 +115,7 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & failure = .FALSE. CALL timeset(routineN,handle) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! *** Assigning local pointers *** CALL fist_nonbond_env_get(fist_nonbond_env,& @@ -136,7 +134,7 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & cell_last_update=cell_last_update,& num_update=num_update,& potparm=potparm,& - last_update=last_update,error=error) + last_update=last_update) nparticle = SIZE(particle_set) nparticle_kind = SIZE(atomic_kind_set) @@ -150,14 +148,14 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & ! *** Check, if the neighbor lists have to be built or updated *** update_neighbor_lists = .FALSE. CALL section_vals_val_get(mm_section,"NEIGHBOR_LISTS%NEIGHBOR_LISTS_FROM_SCRATCH",& - l_val=build_from_scratch,error=error) + l_val=build_from_scratch) CALL section_vals_val_get(mm_section,"NEIGHBOR_LISTS%GEO_CHECK",& - l_val=geo_check,error=error) + l_val=geo_check) IF (ASSOCIATED(r_last_update)) THEN ! Determine the maximum of the squared displacement, compared to ! r_last_update. CALL section_vals_val_get(mm_section,"NEIGHBOR_LISTS%VERLET_SKIN",& - r_val=verlet_skin,error=error) + r_val=verlet_skin) dr2_max = 0.0_dp DO iparticle_kind=1,nparticle_kind nparticle_local = local_particles%n_el(iparticle_kind) @@ -183,7 +181,7 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & ELSE ! There is no r_last_update to compare with. Neighbor lists from scratch. ALLOCATE (r_last_update(nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iparticle=1,nparticle r_last_update(iparticle )%r=particle_set(iparticle)%r(:) END DO @@ -199,15 +197,15 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & ! Allocate the r_last_update_pbc, rshell_last_update_pbc, rcore_last_update_pbc IF (.NOT.ASSOCIATED(r_last_update_pbc)) THEN ALLOCATE (r_last_update_pbc(nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(shell_present .AND. .NOT.ASSOCIATED(rshell_last_update_pbc)) THEN ALLOCATE (rshell_last_update_pbc(nshell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(shell_present .AND. .NOT.ASSOCIATED(rcore_last_update_pbc)) THEN ALLOCATE (rcore_last_update_pbc(nshell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! update the neighbor lists @@ -215,7 +213,7 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & ! determine which pairs of atom kinds need full neighbor lists. Full ! means that atom a is in the neighbor list of atom b and vice versa. ALLOCATE(full_nl(nparticle_kind,nparticle_kind),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(potparm)) THEN DO ikind = 1, nparticle_kind DO jkind = ikind, nparticle_kind @@ -237,11 +235,11 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & vdw_scale14, nonbonded, para_env, & build_from_scratch=build_from_scratch, geo_check=geo_check, & mm_section=mm_section, full_nl=full_nl,& - exclusions=exclusions, error=error) + exclusions=exclusions) - CALL cell_release(cell_last_update,error=error) - CALL cell_create(cell_last_update,error=error) - CALL cell_clone(cell,cell_last_update,error) + CALL cell_release(cell_last_update) + CALL cell_create(cell_last_update) + CALL cell_clone(cell,cell_last_update) IF ( counter > 0 ) THEN num_update = num_update + 1 @@ -265,10 +263,10 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & nonbonded=nonbonded,& num_update=num_update,& last_update=last_update,& - cell_last_update=cell_last_update,error=error) + cell_last_update=cell_last_update) output_unit = cp_print_key_unit_nr(logger,mm_section,"PRINT%NEIGHBOR_LISTS",& - extension=".mmLog",error=error) + extension=".mmLog") IF (output_unit>0) THEN WRITE (UNIT=output_unit,& FMT="(/,T2,A,/,T52,A,/,A,T31,A,T49,2(1X,F15.2),/,T2,A,/)")& @@ -276,9 +274,9 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & " LIST UPDATES[steps]","= ",lup,aup,REPEAT("*",79) END IF CALL cp_print_key_finished_output(output_unit,logger,mm_section,& - "PRINT%NEIGHBOR_LISTS",error=error) + "PRINT%NEIGHBOR_LISTS") DEALLOCATE(full_nl,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Store particle positions after the last update, translated to the @@ -317,7 +315,7 @@ SUBROUTINE list_control ( atomic_kind_set, particle_set, local_particles, & END DO counter = counter + 1 - CALL fist_nonbond_env_set(fist_nonbond_env,counter=counter,error=error) + CALL fist_nonbond_env_set(fist_nonbond_env,counter=counter) CALL timestop(handle) END SUBROUTINE list_control diff --git a/src/fist_neighbor_list_types.F b/src/fist_neighbor_list_types.F index cc334a700b..77ca09a1dd 100644 --- a/src/fist_neighbor_list_types.F +++ b/src/fist_neighbor_list_types.F @@ -61,15 +61,12 @@ MODULE fist_neighbor_list_types ! ***************************************************************************** !> \brief ... !> \param fist_neighbor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE fist_neighbor_deallocate(fist_neighbor,error) + SUBROUTINE fist_neighbor_deallocate(fist_neighbor) TYPE(fist_neighbor_type), POINTER :: fist_neighbor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fist_neighbor_deallocate', & routineP = moduleN//':'//routineN @@ -84,42 +81,42 @@ SUBROUTINE fist_neighbor_deallocate(fist_neighbor,error) DO i = 1, SIZE(fist_neighbor%neighbor_kind_pairs) IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%list)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%id_kind)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%id_kind, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%ij_kind)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%ij_kind, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_start)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_start, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_end)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_end, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%ei_scale)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%ei_scale, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%vdw_scale)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%vdw_scale, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%is_onfo)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%is_onfo, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(fist_neighbor%neighbor_kind_pairs, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(fist_neighbor, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE fist_neighbor_deallocate @@ -127,16 +124,13 @@ END SUBROUTINE fist_neighbor_deallocate !> \brief ... !> \param fist_neighbor ... !> \param ncell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE fist_neighbor_init(fist_neighbor, ncell, error) + SUBROUTINE fist_neighbor_init(fist_neighbor, ncell) TYPE(fist_neighbor_type), POINTER :: fist_neighbor INTEGER, INTENT(IN) :: ncell(3) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fist_neighbor_init', & routineP = moduleN//':'//routineN @@ -151,7 +145,7 @@ SUBROUTINE fist_neighbor_init(fist_neighbor, ncell, error) CALL timeset ( routineN, handle ) IF (.NOT.ASSOCIATED(fist_neighbor)) THEN ALLOCATE(fist_neighbor,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(fist_neighbor%neighbor_kind_pairs) ENDIF @@ -159,62 +153,62 @@ SUBROUTINE fist_neighbor_init(fist_neighbor, ncell, error) IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs)) THEN IF (SIZE(fist_neighbor%neighbor_kind_pairs)fist_neighbor%neighbor_kind_pairs(i)%list list_size = SIZE(new_pairs(i)%list) ALLOCATE(new_pairs(i)%id_kind(list_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(new_pairs(i)%ei_scale(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(new_pairs(i)%vdw_scale(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(new_pairs(i)%is_onfo(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(new_pairs(i)%ij_kind,& new_pairs(i)%grp_kind_start,& new_pairs(i)%grp_kind_end) IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%ij_kind)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%ij_kind, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%id_kind)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%id_kind, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_start)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_start, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_end)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%grp_kind_end, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%ei_scale)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%ei_scale, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%vdw_scale)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%vdw_scale, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fist_neighbor%neighbor_kind_pairs(i)%is_onfo)) THEN DEALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%is_onfo, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ENDDO DO i=SIZE(fist_neighbor%neighbor_kind_pairs)+1,nlistmin ALLOCATE(new_pairs(i)%list(2,0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(new_pairs(i)%id_kind(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(new_pairs(i)%ij_kind,& new_pairs(i)%grp_kind_start,& new_pairs(i)%grp_kind_end) NULLIFY(new_pairs(i)%ei_scale,new_pairs(i)%vdw_scale,new_pairs(i)%is_onfo) ENDDO DEALLOCATE(fist_neighbor%neighbor_kind_pairs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fist_neighbor%neighbor_kind_pairs=>new_pairs ELSE DO i=1,SIZE(fist_neighbor%neighbor_kind_pairs) @@ -224,18 +218,18 @@ SUBROUTINE fist_neighbor_init(fist_neighbor, ncell, error) ENDIF ELSE ALLOCATE(fist_neighbor%neighbor_kind_pairs(nlistmin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nlistmin ALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%list(2,0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%id_kind(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%ei_scale(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%vdw_scale(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fist_neighbor%neighbor_kind_pairs(i)%is_onfo(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(fist_neighbor%neighbor_kind_pairs(i)%ij_kind,& fist_neighbor%neighbor_kind_pairs(i)%grp_kind_start,& fist_neighbor%neighbor_kind_pairs(i)%grp_kind_end) @@ -266,15 +260,13 @@ END SUBROUTINE fist_neighbor_init !> \param ei_scale14 ... !> \param vdw_scale14 ... !> \param exclusions ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE fist_neighbor_add(neighbor_kind_pair, atom_a, atom_b, & rab, check_spline, id_kind, skip, cell, & - ei_scale14, vdw_scale14, exclusions, error) + ei_scale14, vdw_scale14, exclusions) TYPE(neighbor_kind_pairs_type), POINTER :: neighbor_kind_pair INTEGER, INTENT(IN) :: atom_a, atom_b REAL(KIND=dp), DIMENSION(3) :: rab @@ -285,7 +277,6 @@ SUBROUTINE fist_neighbor_add(neighbor_kind_pair, atom_a, atom_b, & REAL(KIND=dp), INTENT(IN) :: ei_scale14, vdw_scale14 TYPE(exclusion_type), DIMENSION(:), & OPTIONAL :: exclusions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fist_neighbor_add', & routineP = moduleN//':'//routineN @@ -384,17 +375,17 @@ SUBROUTINE fist_neighbor_add(neighbor_kind_pair, atom_a, atom_b, & new_npairs = INT(5+1.2*old_npairs) ! Pair Atoms Info ALLOCATE(new_list(2,new_npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) new_list(1:2,1:old_npairs)=neighbor_kind_pair%list(1:2,1:old_npairs) DEALLOCATE(neighbor_kind_pair%list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) neighbor_kind_pair%list=>new_list ! Kind Info ALLOCATE(new_id_kind(new_npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) new_id_kind(1:old_npairs)=neighbor_kind_pair%id_kind(1:old_npairs) DEALLOCATE(neighbor_kind_pair%id_kind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) neighbor_kind_pair%id_kind=>new_id_kind ENDIF diff --git a/src/fist_neighbor_lists.F b/src/fist_neighbor_lists.F index f4bf454e1a..ac42306501 100644 --- a/src/fist_neighbor_lists.F +++ b/src/fist_neighbor_lists.F @@ -91,8 +91,6 @@ MODULE fist_neighbor_lists !> \param mm_section ... !> \param full_nl ... !> \param exclusions ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino @@ -100,7 +98,7 @@ MODULE fist_neighbor_lists SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & local_particles, cell, r_max, r_minsq, ei_scale14, vdw_scale14, & nonbonded, para_env, build_from_scratch, geo_check, mm_section, & - full_nl, exclusions, error) + full_nl, exclusions) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -119,7 +117,6 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & POINTER :: full_nl TYPE(exclusion_type), DIMENSION(:), & OPTIONAL :: exclusions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_fist_neighbor_lists', & routineP = moduleN//':'//routineN @@ -143,11 +140,11 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & failure = .FALSE. CALL timeset(routineN,handle) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() print_subcell_grid = .FALSE. output_unit = cp_print_key_unit_nr(logger,mm_section,"PRINT%SUBCELL",& - extension=".Log",error=error) + extension=".Log") IF (output_unit > 0) print_subcell_grid = .TRUE. CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& @@ -158,21 +155,21 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & ! if exclusions matters local particles are present. Seems like only the exclusions ! for the local particles are needed, which would imply a huge memory savings for fist IF (PRESENT(exclusions)) THEN - CPPostcondition(present_local_particles,cp_failure_level,routineP,error,failure) + CPPostcondition(present_local_particles,cp_failure_level,routineP,failure) ENDIF ! Allocate work storage nkind = SIZE(atomic_kind_set) ALLOCATE (atom(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (skip_kind(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! full_nl IF (PRESENT(full_nl)) THEN my_full_nl => full_nl ELSE ALLOCATE(my_full_nl(nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_full_nl = .FALSE. END IF ! Initialize the local data structures @@ -191,7 +188,7 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & END IF IF (natom_local_a > 0) THEN ALLOCATE (atom(ikind)%list_local_a_index(natom_local_a),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Build index vector for mapping DO iatom_local=1,natom_local_a IF (present_local_particles) THEN @@ -207,7 +204,7 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & IF (build_from_scratch) THEN IF (ASSOCIATED(nonbonded)) THEN - CALL fist_neighbor_deallocate(nonbonded,error) + CALL fist_neighbor_deallocate(nonbonded) END IF END IF @@ -215,14 +212,14 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & CALL build_neighbor_lists(nonbonded, particle_set, atom, cell, & print_subcell_grid, output_unit, r_max, r_minsq, & ei_scale14, vdw_scale14, geo_check,"NONBONDED", skip_kind, & - my_full_nl, exclusions, error) + my_full_nl, exclusions) ! Sort the list according kinds for each cell - CALL sort_neighbor_lists(nonbonded, nkind, error) + CALL sort_neighbor_lists(nonbonded, nkind) print_key_path = "PRINT%NEIGHBOR_LISTS" - IF (BTEST(cp_print_key_should_output(logger%iter_info,mm_section,print_key_path,error=error),& + IF (BTEST(cp_print_key_should_output(logger%iter_info,mm_section,print_key_path),& cp_p_file)) THEN iw = cp_print_key_unit_nr(logger=logger,& basis_section=mm_section,& @@ -231,17 +228,15 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & middle_name="nonbonded_nl",& local=.TRUE.,& log_filename=.FALSE.,& - file_position="REWIND",& - error=error) - CALL section_vals_val_get(mm_section,TRIM(print_key_path)//"%UNIT",c_val=unit_str,error=error) + file_position="REWIND") + CALL section_vals_val_get(mm_section,TRIM(print_key_path)//"%UNIT",c_val=unit_str) CALL write_neighbor_lists(nonbonded,particle_set,cell,para_env,iw,& - "NONBONDED NEIGHBOR LISTS",unit_str,error) + "NONBONDED NEIGHBOR LISTS",unit_str) CALL cp_print_key_finished_output(unit_nr=iw,& logger=logger,& basis_section=mm_section,& print_key_path=print_key_path,& - local=.TRUE.,& - error=error) + local=.TRUE.) END IF ! Release work storage @@ -249,26 +244,25 @@ SUBROUTINE build_fist_neighbor_lists(atomic_kind_set, particle_set, & NULLIFY (atom(ikind)%list) IF (ASSOCIATED(atom(ikind)%list_local_a_index)) THEN DEALLOCATE (atom(ikind)%list_local_a_index,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO IF (PRESENT(full_nl)) THEN NULLIFY(my_full_nl) ELSE DEALLOCATE(my_full_nl,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (atom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (skip_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL cp_print_key_finished_output(unit_nr=output_unit,& logger=logger,& basis_section=mm_section,& - print_key_path="PRINT%SUBCELL",& - error=error) + print_key_path="PRINT%SUBCELL") CALL timestop(handle) END SUBROUTINE build_fist_neighbor_lists @@ -290,15 +284,13 @@ END SUBROUTINE build_fist_neighbor_lists !> \param skip_kind ... !> \param full_nl ... !> \param exclusions ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & print_subcell_grid, output_unit, r_max, r_minsq, & - ei_scale14, vdw_scale14, geo_check, name, skip_kind, full_nl, exclusions, error) + ei_scale14, vdw_scale14, geo_check, name, skip_kind, full_nl, exclusions) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(particle_type), DIMENSION(:), & @@ -316,7 +308,6 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & LOGICAL, DIMENSION(:, :), POINTER :: full_nl TYPE(exclusion_type), DIMENSION(:), & OPTIONAL :: exclusions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_neighbor_lists', & routineP = moduleN//':'//routineN @@ -381,7 +372,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & isubcell=MAX(isubcell(:),CEILING(sab_max(:)*REAL(nsubcell(:),KIND=dp))) END DO END DO - CALL fist_neighbor_init(nonbonded, ncell, error) + CALL fist_neighbor_init(nonbonded, ncell) ! Print headline IF (print_subcell_grid) THEN WRITE (UNIT=output_unit,FMT="(/,/,T2,A,/)")& @@ -391,12 +382,12 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & WRITE (UNIT=output_unit,FMT="(T4,A,10X,3I10)")" NUMBER OF INTERACTING SUBCELLS ::",isubcell END IF ! Allocate subcells - CALL allocate_subcell(subcell_a,nsubcell,cell=cell,error=error) - CALL allocate_subcell(subcell_b,nsubcell,cell=cell,error=error) + CALL allocate_subcell(subcell_a,nsubcell,cell=cell) + CALL allocate_subcell(subcell_b,nsubcell,cell=cell) ! Let's map the sequence of the periodic images ncellmax = MAXVAL(ncell) ALLOCATE(cellmap(-ncellmax:ncellmax,-ncellmax:ncellmax,-ncellmax:ncellmax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cellmap=-1 imap=0 nkind00 = nkind*(nkind+1)/2 @@ -407,7 +398,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & IF (cellmap(icell,jcell,kcell)==-1) THEN imap=imap+1 cellmap(icell,jcell,kcell)=imap - CPPostcondition(imap<=nonbonded%nlists,cp_failure_level,routineP,error,failure) + CPPostcondition(imap<=nonbonded%nlists,cp_failure_level,routineP,failure) neighbor_kind_pair => nonbonded%neighbor_kind_pairs(imap) neighbor_kind_pair%cell_vector(1) = icell @@ -422,7 +413,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & ALLOCATE(sphcub(-isubcell(1):isubcell(1),& -isubcell(2):isubcell(2),& -isubcell(3):isubcell(3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sphcub = .FALSE. IF (ALL(isubcell/=0)) THEN radius = REAL(isubcell(1),KIND=dp)**2+ REAL(isubcell(2),KIND=dp)**2+& @@ -453,7 +444,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & END IF ! Mapping locally all atoms in the zeroth cell ALLOCATE(coord(3,SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO atom_a = 1, SIZE(particle_set) coord(:,atom_a) = pbc(particle_set(atom_a)%r,cell) END DO @@ -471,7 +462,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & DO j = 1,nsubcell(2) DO i = 1,nsubcell(1) ALLOCATE(subcell_a(i,j,k)%atom_list(subcell_a(i,j,k)%natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) subcell_a(i,j,k)%natom = 0 END DO END DO @@ -495,7 +486,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & DO j = 1,nsubcell(2) DO i = 1,nsubcell(1) ALLOCATE(subcell_b(i,j,k)%atom_list(subcell_b(i,j,k)%natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) subcell_b(i,j,k)%natom = 0 END DO END DO @@ -509,9 +500,9 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & tmpdim = MAXVAL(subcell_a(:,:,:)%natom) tmpdim = MAX(tmpdim,MAXVAL(subcell_b(:,:,:)%natom)) ALLOCATE(work(3*tmpdim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kind_of(SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, SIZE(particle_set) kind_of(i) = particle_set(i)%atomic_kind%kind_number END DO @@ -524,7 +515,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & END DO END DO DEALLOCATE(work,kind_of,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) zdim = nsubcell(3) ydim = nsubcell(2) xdim = nsubcell(1) @@ -626,7 +617,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & check_spline=check_spline, id_kind=id_kind, & skip=(skip_kind(ikind).AND.skip_kind(jkind)), & cell=cell, ei_scale14=ei_scale14, & - vdw_scale14=vdw_scale14, exclusions=exclusions, error=error) + vdw_scale14=vdw_scale14, exclusions=exclusions) ! This is to handle properly when interaction radius is larger than cell size IF ((atom_a==atom_b).AND.(ik_start==0)) THEN invcellmap = cellmap(-b_pi,-b_pj,-b_pk) @@ -637,7 +628,7 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & check_spline=check_spline, id_kind=id_kind, & skip=(skip_kind(ikind).AND.skip_kind(jkind)), & cell=cell, ei_scale14=ei_scale14, & - vdw_scale14=vdw_scale14, exclusions=exclusions, error=error) + vdw_scale14=vdw_scale14, exclusions=exclusions) END IF ! Check for too close hits IF (check_spline) THEN @@ -667,13 +658,13 @@ SUBROUTINE build_neighbor_lists(nonbonded, particle_set, atom,cell, & END DO loop_a_j END DO loop_a_k DEALLOCATE(coord,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cellmap,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(sphcub,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL deallocate_subcell(subcell_a,error=error) - CALL deallocate_subcell(subcell_b,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL deallocate_subcell(subcell_a) + CALL deallocate_subcell(subcell_b) CALL timestop(handle) END SUBROUTINE build_neighbor_lists @@ -687,14 +678,12 @@ END SUBROUTINE build_neighbor_lists !> \param output_unit ... !> \param name ... !> \param unit_str ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE write_neighbor_lists(nonbonded,particle_set,cell,para_env,output_unit,& - name,unit_str,error) + name,unit_str) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(particle_type), DIMENSION(:), & @@ -703,7 +692,6 @@ SUBROUTINE write_neighbor_lists(nonbonded,particle_set,cell,para_env,output_unit TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN) :: output_unit CHARACTER(LEN=*), INTENT(IN) :: name, unit_str - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_string_length) :: string INTEGER :: atom_a, atom_b, iab, ilist, & @@ -723,7 +711,7 @@ SUBROUTINE write_neighbor_lists(nonbonded,particle_set,cell,para_env,output_unit print_headline = .TRUE. nneighbor = 0 - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) DO iab=1,SIZE(nonbonded%neighbor_kind_pairs) neighbor_kind_pair => nonbonded%neighbor_kind_pairs(iab) CALL matvec_3x3(cell_v, cell%hmat,REAL(neighbor_kind_pair%cell_vector,KIND=dp)) @@ -777,18 +765,15 @@ END SUBROUTINE write_neighbor_lists !> \brief Sort the generated neighbor list according the kind !> \param nonbonded ... !> \param nkinds ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] University of Zurich - Reducing memory usage !> for the FIST neighbor lists !> \author Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE sort_neighbor_lists(nonbonded, nkinds, error) + SUBROUTINE sort_neighbor_lists(nonbonded, nkinds) TYPE(fist_neighbor_type), POINTER :: nonbonded INTEGER, INTENT(IN) :: nkinds - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sort_neighbor_lists', & routineP = moduleN//':'//routineN @@ -807,7 +792,7 @@ SUBROUTINE sort_neighbor_lists(nonbonded, nkinds, error) CALL timeset(routineN,handle) ! define a lookup table to get jkind for a given id_kind ALLOCATE(indj(nkinds*(nkinds+1)/2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) id_kind = 0 DO jkind = 1, nkinds DO ikind = jkind, nkinds @@ -827,9 +812,9 @@ SUBROUTINE sort_neighbor_lists(nonbonded, nkinds, error) ! stay packed in the beginning. Sorting is skipped altogether when ! all pairs have scaled interactions. ALLOCATE(work(1:npairs-nscale),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(list_copy(2,1:npairs-nscale),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Copy of the pair list is required to perform the permutation below ! correctly. list_copy = neighbor_kind_pair%list(:,nscale+1:npairs) @@ -842,7 +827,7 @@ SUBROUTINE sort_neighbor_lists(nonbonded, nkinds, error) neighbor_kind_pair%list(2,ipair) = list_copy(2,tmp) END DO DEALLOCATE(work,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(list_copy,stat=stat) END IF ! 2) determine the intervals (groups) in the pair list that correspond @@ -854,25 +839,25 @@ SUBROUTINE sort_neighbor_lists(nonbonded, nkinds, error) ! present, and also provide storage for the pairs with exclusion ! flags, which are unsorted. max_alloc_size = nkinds*(nkinds+1)/2 + nscale - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(neighbor_kind_pair%grp_kind_start)) THEN DEALLOCATE(neighbor_kind_pair%grp_kind_start,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE(neighbor_kind_pair%grp_kind_start(max_alloc_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(neighbor_kind_pair%grp_kind_end)) THEN DEALLOCATE(neighbor_kind_pair%grp_kind_end,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE(neighbor_kind_pair%grp_kind_end(max_alloc_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(neighbor_kind_pair%ij_kind)) THEN DEALLOCATE(neighbor_kind_pair%ij_kind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE(neighbor_kind_pair%ij_kind(2,max_alloc_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Start the first interval. ipair = 1 neighbor_kind_pair%ngrp_kind = 1 @@ -909,10 +894,10 @@ SUBROUTINE sort_neighbor_lists(nonbonded, nkinds, error) END IF ! Clean the memory.. DEALLOCATE(neighbor_kind_pair%id_kind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(indj,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE sort_neighbor_lists diff --git a/src/fist_nonbond_env_types.F b/src/fist_nonbond_env_types.F index 68653e6bb0..761a99a3af 100644 --- a/src/fist_nonbond_env_types.F +++ b/src/fist_nonbond_env_types.F @@ -97,8 +97,6 @@ MODULE fist_nonbond_env_types !> \param eam_data ... !> \param quip_data ... !> \param charges ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed @@ -108,7 +106,7 @@ SUBROUTINE fist_nonbond_env_get(fist_nonbond_env, potparm14, potparm, & shift_cutoff, r_last_update, r_last_update_pbc, rshell_last_update_pbc, & rcore_last_update_pbc, cell_last_update, num_update, last_update, & counter, natom_types, long_range_correction, ij_kind_full_fac, eam_data, & - quip_data, charges, error) + quip_data, charges) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(pair_potential_pp_type), OPTIONAL, & @@ -136,7 +134,6 @@ SUBROUTINE fist_nonbond_env_get(fist_nonbond_env, potparm14, potparm, & TYPE(quip_data_type), OPTIONAL, POINTER :: quip_data REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( charges ) ) charges => fist_nonbond_env%charges IF ( PRESENT ( potparm14 ) ) potparm14 => fist_nonbond_env%potparm14 @@ -197,8 +194,6 @@ END SUBROUTINE fist_nonbond_env_get !> \param eam_data ... !> \param quip_data ... !> \param charges ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed @@ -207,7 +202,7 @@ SUBROUTINE fist_nonbond_env_set(fist_nonbond_env, potparm14, potparm, & rlist_cut, rlist_lowsq, nonbonded, aup, lup, ei_scale14, vdw_scale14, & shift_cutoff, r_last_update, r_last_update_pbc, rshell_last_update_pbc, & rcore_last_update_pbc, cell_last_update, num_update, last_update, & - counter, natom_types, long_range_correction, eam_data, quip_data, charges, error) + counter, natom_types, long_range_correction, eam_data, quip_data, charges) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(pair_potential_pp_type), OPTIONAL, & @@ -233,7 +228,6 @@ SUBROUTINE fist_nonbond_env_set(fist_nonbond_env, potparm14, potparm, & TYPE(quip_data_type), OPTIONAL, POINTER :: quip_data REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( potparm14 ) ) fist_nonbond_env%potparm14 => potparm14 IF ( PRESENT ( eam_data ) ) fist_nonbond_env%eam_data => eam_data @@ -279,15 +273,13 @@ END SUBROUTINE fist_nonbond_env_set !> \param ei_scale14 ... !> \param vdw_scale14 ... !> \param shift_cutoff ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE fist_nonbond_env_create(fist_nonbond_env, atomic_kind_set, & potparm14, potparm, do_nonbonded, verlet_skin, ewald_rcut, ei_scale14, & - vdw_scale14, shift_cutoff, error) + vdw_scale14, shift_cutoff) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -297,7 +289,6 @@ SUBROUTINE fist_nonbond_env_create(fist_nonbond_env, atomic_kind_set, & REAL(KIND=dp), INTENT(IN) :: verlet_skin, ewald_rcut, & ei_scale14, vdw_scale14 LOGICAL, INTENT(IN) :: shift_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_nonbond_env_create', & routineP = moduleN//':'//routineN @@ -307,7 +298,7 @@ SUBROUTINE fist_nonbond_env_create(fist_nonbond_env, atomic_kind_set, & failure=.FALSE. ALLOCATE(fist_nonbond_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(fist_nonbond_env%potparm14) NULLIFY(fist_nonbond_env%potparm) NULLIFY(fist_nonbond_env%rlist_cut) @@ -324,7 +315,7 @@ SUBROUTINE fist_nonbond_env_create(fist_nonbond_env, atomic_kind_set, & NULLIFY(fist_nonbond_env%charges) CALL init_fist_nonbond_env(fist_nonbond_env, atomic_kind_set, potparm14, & potparm, do_nonbonded, verlet_skin, ewald_rcut, ei_scale14, vdw_scale14, & - shift_cutoff, error) + shift_cutoff) END SUBROUTINE fist_nonbond_env_create ! ***************************************************************************** @@ -339,12 +330,10 @@ END SUBROUTINE fist_nonbond_env_create !> \param ei_scale14 ... !> \param vdw_scale14 ... !> \param shift_cutoff ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE init_fist_nonbond_env(fist_nonbond_env, atomic_kind_set, & potparm14, potparm, do_nonbonded, verlet_skin, ewald_rcut, ei_scale14, & - vdw_scale14, shift_cutoff, error) + vdw_scale14, shift_cutoff) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(atomic_kind_type), DIMENSION(:), & @@ -355,7 +344,6 @@ SUBROUTINE init_fist_nonbond_env(fist_nonbond_env, atomic_kind_set, & REAL(KIND=dp), INTENT(IN) :: verlet_skin, ewald_rcut, & ei_scale14, vdw_scale14 LOGICAL, INTENT(IN) :: shift_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_fist_nonbond_env', & routineP = moduleN//':'//routineN @@ -398,18 +386,18 @@ SUBROUTINE init_fist_nonbond_env(fist_nonbond_env, atomic_kind_set, & natom_types = SIZE(atomic_kind_set) IF (use_potparm14) THEN check = (SIZE(potparm14%pot,1)==natom_types) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (use_potparm) THEN check = (SIZE(potparm%pot,1)==natom_types) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF ALLOCATE ( fist_nonbond_env%rlist_cut(natom_types, natom_types), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( fist_nonbond_env%rlist_lowsq(natom_types, natom_types), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( fist_nonbond_env%ij_kind_full_fac(natom_types, natom_types), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fist_nonbond_env%ij_kind_full_fac = 1.0_dp DO idim = 1, natom_types DO jdim = idim, natom_types @@ -472,15 +460,12 @@ END SUBROUTINE init_fist_nonbond_env ! ***************************************************************************** !> \brief retains the given fist_nonbond_env (see doc/ReferenceCounting.html) !> \param fist_nonbond_env the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fist_nonbond_env_retain(fist_nonbond_env,error) + SUBROUTINE fist_nonbond_env_retain(fist_nonbond_env) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_nonbond_env_retain', & routineP = moduleN//':'//routineN @@ -488,23 +473,20 @@ SUBROUTINE fist_nonbond_env_retain(fist_nonbond_env,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(fist_nonbond_env),cp_failure_level,routineP,error,failure) - CPPrecondition(fist_nonbond_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fist_nonbond_env),cp_failure_level,routineP,failure) + CPPrecondition(fist_nonbond_env%ref_count>0,cp_failure_level,routineP,failure) fist_nonbond_env%ref_count=fist_nonbond_env%ref_count+1 END SUBROUTINE fist_nonbond_env_retain ! ***************************************************************************** !> \brief releases the given fist_nonbond_env (see doc/ReferenceCounting.html) !> \param fist_nonbond_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fist_nonbond_env_release(fist_nonbond_env,error) + SUBROUTINE fist_nonbond_env_release(fist_nonbond_env) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_nonbond_env_release', & routineP = moduleN//':'//routineN @@ -514,69 +496,69 @@ SUBROUTINE fist_nonbond_env_release(fist_nonbond_env,error) failure=.FALSE. IF (ASSOCIATED(fist_nonbond_env)) THEN - CPPrecondition(fist_nonbond_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(fist_nonbond_env%ref_count>0,cp_failure_level,routineP,failure) fist_nonbond_env%ref_count=fist_nonbond_env%ref_count-1 IF (fist_nonbond_env%ref_count<1) THEN IF (ASSOCIATED(fist_nonbond_env%nonbonded)) THEN - CALL fist_neighbor_deallocate (fist_nonbond_env%nonbonded, error ) + CALL fist_neighbor_deallocate (fist_nonbond_env%nonbonded) END IF ! Release potparm - CALL pair_potential_pp_release ( fist_nonbond_env%potparm, error ) + CALL pair_potential_pp_release ( fist_nonbond_env%potparm) ! Release potparm14 - CALL pair_potential_pp_release ( fist_nonbond_env%potparm14, error ) + CALL pair_potential_pp_release ( fist_nonbond_env%potparm14) IF (ASSOCIATED(fist_nonbond_env%r_last_update)) THEN DEALLOCATE (fist_nonbond_env%r_last_update,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%r_last_update_pbc)) THEN DEALLOCATE (fist_nonbond_env%r_last_update_pbc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%charges)) THEN DEALLOCATE (fist_nonbond_env%charges,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%eam_data)) THEN DEALLOCATE (fist_nonbond_env%eam_data,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%quip_data)) THEN IF (ASSOCIATED(fist_nonbond_env%quip_data%force)) THEN DEALLOCATE (fist_nonbond_env%quip_data%force,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%quip_data%use_indices)) THEN DEALLOCATE (fist_nonbond_env%quip_data%use_indices,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE (fist_nonbond_env%quip_data,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%rshell_last_update_pbc)) THEN DEALLOCATE (fist_nonbond_env%rshell_last_update_pbc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%rcore_last_update_pbc)) THEN DEALLOCATE (fist_nonbond_env%rcore_last_update_pbc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%cell_last_update)) THEN - CALL cell_release(fist_nonbond_env%cell_last_update,error) + CALL cell_release(fist_nonbond_env%cell_last_update) ENDIF IF (ASSOCIATED(fist_nonbond_env%ij_kind_full_fac)) THEN DEALLOCATE (fist_nonbond_env%ij_kind_full_fac,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%rlist_cut)) THEN DEALLOCATE (fist_nonbond_env%rlist_cut,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(fist_nonbond_env%rlist_lowsq)) THEN DEALLOCATE (fist_nonbond_env%rlist_lowsq,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(fist_nonbond_env, STAT=stat) - CPPrecondition(stat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(stat==0,cp_warning_level,routineP,failure) END IF END IF END SUBROUTINE fist_nonbond_env_release diff --git a/src/fist_nonbond_force.F b/src/fist_nonbond_force.F index 0599389b3e..4c1339514c 100644 --- a/src/fist_nonbond_force.F +++ b/src/fist_nonbond_force.F @@ -81,11 +81,10 @@ MODULE fist_nonbond_force !> \param atprop_env ... !> \param atomic_kind_set ... !> \param use_virial ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & pot_nonbond, f_nonbond, pv_nonbond, fshell_nonbond, fcore_nonbond, & - atprop_env, atomic_kind_set, use_virial, error) + atprop_env, atomic_kind_set, use_virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(ewald_environment_type), POINTER :: ewald_env @@ -100,7 +99,6 @@ SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & TYPE(atprop_type), POINTER :: atprop_env TYPE(atomic_kind_type), POINTER :: atomic_kind_set(:) LOGICAL, INTENT(IN) :: use_virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'force_nonbond', & routineP = moduleN//':'//routineN @@ -144,14 +142,14 @@ SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & CALL timeset(routineN,handle) NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(pot, rshell_last_update_pbc, spl_f, ij_kind_full_fac) CALL fist_nonbond_env_get(fist_nonbond_env, nonbonded=nonbonded, & potparm14=potparm14, potparm=potparm, r_last_update=r_last_update, & r_last_update_pbc=r_last_update_pbc,natom_types=nkind, & rshell_last_update_pbc=rshell_last_update_pbc, & rcore_last_update_pbc=rcore_last_update_pbc, & - ij_kind_full_fac=ij_kind_full_fac, error=error) + ij_kind_full_fac=ij_kind_full_fac) CALL ewald_env_get(ewald_env, alpha=alpha, ewald_type=ewald_type, & do_multipoles=do_multipoles, & interaction_cutoffs=ei_interaction_cutoffs) @@ -165,7 +163,7 @@ SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & END IF shell_present = .FALSE. IF (PRESENT(fshell_nonbond)) THEN - CPPostcondition(PRESENT(fcore_nonbond),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(fcore_nonbond),cp_failure_level,routineP,failure) fshell_nonbond = 0.0_dp fcore_nonbond = 0.0_dp shell_present = .TRUE. @@ -181,7 +179,7 @@ SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"qshell",dp_size*nkind) ALLOCATE (is_shell_kind(nkind),STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"is_shell_kind",int_size*nkind) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind atomic_kind => atomic_kind_set(ikind) CALL get_atomic_kind(atomic_kind,& @@ -192,8 +190,7 @@ SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & IF (ASSOCIATED(shell_kind)) THEN CALL get_shell(shell=shell_kind,& charge_core=qcore(ikind),& - charge_shell=qshell(ikind),& - error=error) + charge_shell=qshell(ikind)) ELSE qcore(ikind) = 0.0_dp qshell(ikind) = 0.0_dp @@ -217,7 +214,7 @@ SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & !$omp private(shell_kind,beta,beta_a,beta_b,spl_f,spline_data) & !$omp private(shell_type,all_terms,rab_cc,rab_cs,rab_sc,rab_ss) & !$omp private(rab_list,rab2_list,rab_com,rab2_com,pv,pv_thread) & - !$omp private(rab,rab2,rab2_max,fscalar,energy,error,failure) & + !$omp private(rab,rab2,rab2_max,fscalar,energy,failure) & !$omp private(shell_a,shell_b,etot,fatom_a,fatom_b) & !$omp private(fcore_a,fcore_b,fshell_a,fshell_b,i,j) & !$omp shared(shell_present) & @@ -318,8 +315,8 @@ SUBROUTINE force_nonbond(fist_nonbond_env, ewald_env, particle_set, cell, & spline_data => pot%pair_spline_data shell_type = pot%shell_type IF (shell_type /= nosh_nosh) THEN - CPPrecondition(.NOT.do_multipoles,cp_failure_level,routineP,error,failure) - CPPostcondition(shell_present,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.do_multipoles,cp_failure_level,routineP,failure) + CPPostcondition(shell_present,cp_failure_level,routineP,failure) END IF rab2_max = pot%rcutsq @@ -664,14 +661,13 @@ SUBROUTINE add_force_nonbond(f_nonbond_a,f_nonbond_b,pv,fscalar,rab,use_virial) !> \param atprop_env ... !> \param cell ... !> \param use_virial ... -!> \param error ... !> \par History !> Splitted routines to clean and to fix a bug with the tensor whose !> original definition was not correct for PBC.. [Teodoro Laino -06/2007] ! ***************************************************************************** SUBROUTINE bonded_correct_gaussian(fist_nonbond_env, atomic_kind_set, & local_particles, particle_set, ewald_env, v_bonded_corr, pv_bc, & - shell_particle_set, core_particle_set, atprop_env, cell, use_virial, error) + shell_particle_set, core_particle_set, atprop_env, cell, use_virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) @@ -686,7 +682,6 @@ SUBROUTINE bonded_correct_gaussian(fist_nonbond_env, atomic_kind_set, & TYPE(atprop_type), POINTER :: atprop_env TYPE(cell_type), POINTER :: cell LOGICAL, INTENT(IN) :: use_virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'bonded_correct_gaussian', & routineP = moduleN//':'//routineN @@ -720,9 +715,9 @@ SUBROUTINE bonded_correct_gaussian(fist_nonbond_env, atomic_kind_set, & CALL fist_nonbond_env_get(fist_nonbond_env, nonbonded=nonbonded, & potparm14=potparm14, potparm=potparm, & - ij_kind_full_fac=ij_kind_full_fac, error=error) + ij_kind_full_fac=ij_kind_full_fac) CALL ewald_env_get(ewald_env, alpha=alpha, do_multipoles=do_multipoles, & - group=group, error=error) + group=group) ! Defining the constants const = 2.0_dp*alpha*oorootpi @@ -779,7 +774,7 @@ SUBROUTINE bonded_correct_gaussian(fist_nonbond_env, atomic_kind_set, & a_is_shell = ASSOCIATED(shell_kind) IF (a_is_shell) THEN CALL get_shell(shell=shell_kind, charge_core=qcore_a, & - charge_shell=qshell_a, error=error) + charge_shell=qshell_a) shell_a = particle_set(atom_a)%shell_index rca = core_particle_set(shell_a)%r rsa = shell_particle_set(shell_a)%r @@ -798,7 +793,7 @@ SUBROUTINE bonded_correct_gaussian(fist_nonbond_env, atomic_kind_set, & b_is_shell = ASSOCIATED(shell_kind) IF (b_is_shell) THEN CALL get_shell(shell=shell_kind, charge_core=qcore_b, & - charge_shell=qshell_b, error=error) + charge_shell=qshell_b) shell_b = particle_set(atom_b)%shell_index rcb = core_particle_set(shell_b)%r rsb = shell_particle_set(shell_b)%r @@ -888,7 +883,7 @@ SUBROUTINE bonded_correct_gaussian(fist_nonbond_env, atomic_kind_set, & CALL get_atomic_kind(atomic_kind, shell=shell_kind) IF (ASSOCIATED(shell_kind)) THEN CALL get_shell(shell=shell_kind, charge_core=qcore_a, & - charge_shell=qshell_a, error=error) + charge_shell=qshell_a) natoms_per_kind = local_particles%n_el(kind_a) DO iatom = 1, natoms_per_kind diff --git a/src/fist_pol_scf.F b/src/fist_pol_scf.F index 5fe07a9050..6648f4c071 100644 --- a/src/fist_pol_scf.F +++ b/src/fist_pol_scf.F @@ -67,13 +67,12 @@ MODULE fist_pol_scf !> \param pv_nonbond ... !> \param mm_section ... !> \param do_ipol ... -!> \param error ... !> \author Toon.Verstraelen@gmail.com (2010-03-01) ! ***************************************************************************** SUBROUTINE fist_pol_evaluate (atomic_kind_set, multipoles, ewald_env, & ewald_pw, fist_nonbond_env, cell, particle_set, local_particles, & thermo, vg_coulomb, pot_nonbond, f_nonbond, fg_coulomb,use_virial, & - pv_g, pv_nonbond, mm_section, do_ipol, error) + pv_g, pv_nonbond, mm_section, do_ipol) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -92,7 +91,6 @@ SUBROUTINE fist_pol_evaluate (atomic_kind_set, multipoles, ewald_env, & REAL(KIND=dp), DIMENSION(3, 3) :: pv_g, pv_nonbond TYPE(section_vals_type), POINTER :: mm_section INTEGER :: do_ipol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_pol_evaluate', & routineP = moduleN//':'//routineN @@ -102,12 +100,12 @@ SUBROUTINE fist_pol_evaluate (atomic_kind_set, multipoles, ewald_env, & CALL fist_pol_evaluate_sc(atomic_kind_set, multipoles, ewald_env, & ewald_pw, fist_nonbond_env, cell, particle_set, local_particles, & thermo, vg_coulomb, pot_nonbond, f_nonbond, fg_coulomb,use_virial, & - pv_g, pv_nonbond, mm_section, error) + pv_g, pv_nonbond, mm_section) CASE (do_fist_pol_cg) CALL fist_pol_evaluate_cg(atomic_kind_set, multipoles, ewald_env, & ewald_pw, fist_nonbond_env, cell, particle_set, local_particles, & thermo, vg_coulomb, pot_nonbond, f_nonbond, fg_coulomb,use_virial, & - pv_g, pv_nonbond, mm_section, error) + pv_g, pv_nonbond, mm_section) END SELECT END SUBROUTINE fist_pol_evaluate @@ -131,7 +129,6 @@ END SUBROUTINE fist_pol_evaluate !> \param pv_g ... !> \param pv_nonbond ... !> \param mm_section ... -!> \param error ... !> \author Toon.Verstraelen@gmail.com (2010-03-01) !> \note !> Method: Given an initial guess of the induced dipoles, the electrostatic @@ -143,8 +140,7 @@ END SUBROUTINE fist_pol_evaluate ! ***************************************************************************** SUBROUTINE fist_pol_evaluate_sc (atomic_kind_set, multipoles, ewald_env, ewald_pw,& fist_nonbond_env, cell, particle_set, local_particles, thermo, vg_coulomb,& - pot_nonbond, f_nonbond, fg_coulomb,use_virial, pv_g, pv_nonbond, mm_section,& - error) + pot_nonbond, f_nonbond, fg_coulomb,use_virial, pv_g, pv_nonbond, mm_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -162,7 +158,6 @@ SUBROUTINE fist_pol_evaluate_sc (atomic_kind_set, multipoles, ewald_env, ewald_p LOGICAL, INTENT(IN) :: use_virial REAL(KIND=dp), DIMENSION(3, 3) :: pv_g, pv_nonbond TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_pol_evaluate_sc', & routineP = moduleN//':'//routineN @@ -182,21 +177,21 @@ SUBROUTINE fist_pol_evaluate_sc (atomic_kind_set, multipoles, ewald_env, ewald_p CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger,atomic_kind) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%ITER_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") iw2= cp_print_key_unit_nr(logger,mm_section,"PRINT%EWALD_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") CALL ewald_env_get (ewald_env, max_ipol_iter=max_ipol_iter, eps_pol=eps_pol,& - ewald_type=ewald_type, error=error) + ewald_type=ewald_type) natoms = SIZE ( particle_set ) ALLOCATE (efield1(3,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (efield2(9,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nkind = SIZE(atomic_kind_set) IF (iw>0) WRITE(iw,FMT='(/,T5,"POL_SCF|","Method: self-consistent")') @@ -208,7 +203,7 @@ SUBROUTINE fist_pol_evaluate_sc (atomic_kind_set, multipoles, ewald_env, ewald_p multipoles, do_correction_bonded=.TRUE., do_forces=.FALSE., & do_stress=.FALSE., do_efield=.TRUE., iw2=iw2, do_debug=.FALSE.,& atomic_kind_set=atomic_kind_set, mm_section=mm_section,& - efield1=efield1, efield2=efield2, error=error) + efield1=efield1, efield2=efield2) CALL mp_sum(pot_nonbond_local,logger%para_env%group) ! compute the new dipoles, qudrupoles, and check for convergence @@ -302,7 +297,7 @@ SUBROUTINE fist_pol_evaluate_sc (atomic_kind_set, multipoles, ewald_env, ewald_p do_stress=use_virial, do_efield=.FALSE., iw2=iw2, do_debug=.FALSE.,& atomic_kind_set=atomic_kind_set, mm_section=mm_section,& forces_local=fg_coulomb, forces_glob=f_nonbond, & - pv_local=pv_g, pv_glob=pv_nonbond, error=error) + pv_local=pv_g, pv_glob=pv_nonbond) pot_nonbond=pot_nonbond+pot_nonbond_local CALL mp_sum(pot_nonbond_local,logger%para_env%group) @@ -314,13 +309,13 @@ SUBROUTINE fist_pol_evaluate_sc (atomic_kind_set, multipoles, ewald_env, ewald_p ! Deallocate working arrays DEALLOCATE(efield1,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(efield2,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL cp_print_key_finished_output(iw2,logger,mm_section,& - "PRINT%EWALD_INFO",error=error) + "PRINT%EWALD_INFO") CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%ITER_INFO",error=error) + "PRINT%ITER_INFO") CALL timestop(handle) END SUBROUTINE fist_pol_evaluate_sc @@ -345,7 +340,6 @@ END SUBROUTINE fist_pol_evaluate_sc !> \param pv_g ... !> \param pv_nonbond ... !> \param mm_section ... -!> \param error ... !> \author Toon.Verstraelen@gmail.com (2010-03-01) !> \note !> Method: The dipoles are found by minimizing the sum of the electrostatic @@ -370,8 +364,7 @@ END SUBROUTINE fist_pol_evaluate_sc ! ***************************************************************************** SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_pw,& fist_nonbond_env, cell, particle_set, local_particles, thermo, vg_coulomb,& - pot_nonbond, f_nonbond, fg_coulomb,use_virial, pv_g, pv_nonbond, mm_section,& - error) + pot_nonbond, f_nonbond, fg_coulomb,use_virial, pv_g, pv_nonbond, mm_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -389,7 +382,6 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p LOGICAL, INTENT(IN) :: use_virial REAL(KIND=dp), DIMENSION(3, 3) :: pv_g, pv_nonbond TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fist_pol_evaluate_cg', & routineP = moduleN//':'//routineN @@ -411,30 +403,30 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger,atomic_kind) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%ITER_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") iw2= cp_print_key_unit_nr(logger,mm_section,"PRINT%EWALD_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") CALL ewald_env_get (ewald_env, max_ipol_iter=max_ipol_iter, eps_pol=eps_pol,& - ewald_type=ewald_type, error=error) + ewald_type=ewald_type) ! allocate work arrays natoms = SIZE ( particle_set ) ALLOCATE (efield1(3,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (tmp_dipoles(3,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (residual(3,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (conjugate(3,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (conjugate_applied(3,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (efield1_ext(3,natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Compute the 'external' electrostatic field (all inducible dipoles ! equal to zero). this is required for the conjugate gradient solver. @@ -446,7 +438,7 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p multipoles, do_correction_bonded=.TRUE., do_forces=.FALSE., & do_stress=.FALSE., do_efield=.TRUE., iw2=iw2, do_debug=.FALSE., & atomic_kind_set=atomic_kind_set, mm_section=mm_section, & - efield1=efield1_ext, error=error) + efield1=efield1_ext) multipoles%dipoles = tmp_dipoles ! restore backup ! Compute the electric field with the initial guess of the dipoles. @@ -455,7 +447,7 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p multipoles, do_correction_bonded=.TRUE., do_forces=.FALSE., & do_stress=.FALSE., do_efield=.TRUE., iw2=iw2, do_debug=.FALSE., & atomic_kind_set=atomic_kind_set, mm_section=mm_section, & - efield1=efield1, error=error) + efield1=efield1) ! Compute the first residual explicitly. nkind = SIZE(atomic_kind_set) @@ -491,7 +483,7 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p multipoles, do_correction_bonded=.TRUE., do_forces=.FALSE., & do_stress=.FALSE., do_efield=.TRUE., iw2=iw2, do_debug=.FALSE., & atomic_kind_set=atomic_kind_set, mm_section=mm_section, & - efield1=efield1, error=error) + efield1=efield1) ! inapropriate use of denom to check the error on the residual denom = 0.0_dp END IF @@ -532,7 +524,7 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p multipoles, do_correction_bonded=.TRUE., do_forces=.FALSE., & do_stress=.FALSE., do_efield=.TRUE., iw2=iw2, do_debug=.FALSE., & atomic_kind_set=atomic_kind_set, mm_section=mm_section, & - efield1=conjugate_applied, error=error) + efield1=conjugate_applied) multipoles%dipoles = tmp_dipoles ! restore backup conjugate_applied(:,:) = efield1_ext - conjugate_applied @@ -614,7 +606,7 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p do_stress=use_virial, do_efield=.TRUE., iw2=iw2, do_debug=.FALSE.,& atomic_kind_set=atomic_kind_set, mm_section=mm_section,& forces_local=fg_coulomb, forces_glob=f_nonbond, & - pv_local=pv_g, pv_glob=pv_nonbond, efield1=efield1, error=error) + pv_local=pv_g, pv_glob=pv_nonbond, efield1=efield1) ! Do a final check on the convergence: compute the residual explicitely rmsd = 0.0_dp @@ -648,7 +640,7 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p do_stress=use_virial, do_efield=.FALSE., iw2=iw2, do_debug=.FALSE.,& atomic_kind_set=atomic_kind_set, mm_section=mm_section,& forces_local=fg_coulomb, forces_glob=f_nonbond, & - pv_local=pv_g, pv_glob=pv_nonbond, error=error) + pv_local=pv_g, pv_glob=pv_nonbond) ENDIF pot_nonbond=pot_nonbond+pot_nonbond_local CALL mp_sum(pot_nonbond_local, logger%para_env%group) @@ -660,21 +652,21 @@ SUBROUTINE fist_pol_evaluate_cg (atomic_kind_set, multipoles, ewald_env, ewald_p ! Deallocate working arrays DEALLOCATE(efield1,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_dipoles,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(residual,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(conjugate,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(conjugate_applied,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(efield1_ext,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL cp_print_key_finished_output(iw2,logger,mm_section,& - "PRINT%EWALD_INFO",error=error) + "PRINT%EWALD_INFO") CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%ITER_INFO",error=error) + "PRINT%ITER_INFO") CALL timestop(handle) END SUBROUTINE fist_pol_evaluate_cg @@ -708,14 +700,13 @@ END SUBROUTINE fist_pol_evaluate_cg !> \param forces_glob ... !> \param pv_local ... !> \param pv_glob ... -!> \param error ... !> \author Teodoro Laino [tlaino] 05.2009 ! ***************************************************************************** SUBROUTINE eval_pol_ewald(ewald_type, ewald_env, ewald_pw, fist_nonbond_env,& cell, particle_set, local_particles, vg_coulomb, pot_nonbond, thermo,& multipoles, do_correction_bonded, do_forces, do_stress, do_efield, iw2,& do_debug, atomic_kind_set, mm_section, efield0, efield1, efield2, forces_local,& - forces_glob, pv_local, pv_glob, error) + forces_glob, pv_local, pv_glob) INTEGER, INTENT(IN) :: ewald_type TYPE(ewald_environment_type), POINTER :: ewald_env @@ -741,7 +732,6 @@ SUBROUTINE eval_pol_ewald(ewald_type, ewald_env, ewald_pw, fist_nonbond_env,& REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL :: forces_local, forces_glob, & pv_local, pv_glob - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eval_pol_ewald', & routineP = moduleN//':'//routineN @@ -764,16 +754,15 @@ SUBROUTINE eval_pol_ewald(ewald_type, ewald_env, ewald_pw, fist_nonbond_env,& dipoles=multipoles%dipoles, quadrupoles=multipoles%quadrupoles,& forces_local=forces_local, forces_glob=forces_glob, pv_local=pv_local,& pv_glob=pv_glob, iw=iw2, do_debug=do_debug, atomic_kind_set=atomic_kind_set,& - mm_section=mm_section, efield0=efield0, efield1=efield1, efield2=efield2, & - error=error) + mm_section=mm_section, efield0=efield0, efield1=efield1, efield2=efield2) CASE(do_ewald_pme) CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald not yet implemented within a PME scheme!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) CASE(do_ewald_spme) CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole Ewald not yet implemented within a SPME scheme!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END SELECT CALL timestop(handle) END SUBROUTINE eval_pol_ewald diff --git a/src/fm/cp_blacs_env.F b/src/fm/cp_blacs_env.F index dbb5f17d7f..fdbdbbdc41 100644 --- a/src/fm/cp_blacs_env.F +++ b/src/fm/cp_blacs_env.F @@ -128,20 +128,17 @@ END SUBROUTINE get_blacs_info !> \param blacs_repeatable ... !> \param row_major ... !> \param grid_2d ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_blacs_env_create(blacs_env,para_env,blacs_grid_layout,blacs_repeatable,row_major,grid_2d,error) +SUBROUTINE cp_blacs_env_create(blacs_env,para_env,blacs_grid_layout,blacs_repeatable,row_major,grid_2d) TYPE(cp_blacs_env_type), POINTER :: blacs_env TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN), OPTIONAL :: blacs_grid_layout LOGICAL, INTENT(IN), OPTIONAL :: blacs_repeatable, row_major INTEGER, DIMENSION(:), INTENT(IN), & OPTIONAL :: grid_2d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_blacs_env_create', & routineP = moduleN//':'//routineN @@ -163,22 +160,21 @@ SUBROUTINE cp_blacs_env_create(blacs_env,para_env,blacs_grid_layout,blacs_repeat CALL cp_assert(.FALSE.,cp_failure_level, cp_assertion_failed,& fromWhere=routineP,message="to USE the blacs environment "//& "you need the blacs/scalapack library : recompile with -D__SCALAPACK (and link scalapack and blacs) "//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) #endif #endif - CPPrecondition(.NOT.ASSOCIATED(blacs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(blacs_env),cp_failure_level,routineP,failure) ALLOCATE(blacs_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blacs_env%group=0 blacs_env%ref_count=1 blacs_env%mepos(:)=0 blacs_env%num_pe(:)=1 blacs_env%my_pid=0 blacs_env%n_pid=1 - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) blacs_env%para_env => para_env #ifdef __SCALAPACK @@ -247,12 +243,12 @@ SUBROUTINE cp_blacs_env_create(blacs_env,para_env,blacs_grid_layout,blacs_repeat ! generate the mappings blacs2mpi and mpi2blacs ALLOCATE(blacs_env%blacs2mpi(0:blacs_env%num_pe(1)-1,0:blacs_env%num_pe(2)-1),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blacs_env%blacs2mpi=0 blacs_env%blacs2mpi(blacs_env%mepos(1),blacs_env%mepos(2))=para_env%mepos CALL mp_sum(blacs_env%blacs2mpi,para_env%group) ALLOCATE(blacs_env%mpi2blacs(2,0:para_env%num_pe-1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blacs_env%mpi2blacs=-1 DO ipcol=0,blacs_env%num_pe(2)-1 DO iprow=0,blacs_env%num_pe(1)-1 @@ -265,15 +261,12 @@ END SUBROUTINE cp_blacs_env_create ! ***************************************************************************** !> \brief retains the given blacs env !> \param blacs_env the blacs env to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_blacs_env_retain(blacs_env,error) +SUBROUTINE cp_blacs_env_retain(blacs_env) TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_blacs_env_retain', & routineP = moduleN//':'//routineN @@ -281,23 +274,20 @@ SUBROUTINE cp_blacs_env_retain(blacs_env,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(blacs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(blacs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(blacs_env),cp_failure_level,routineP,failure) + CPPrecondition(blacs_env%ref_count>0,cp_failure_level,routineP,failure) blacs_env%ref_count=blacs_env%ref_count+1 END SUBROUTINE cp_blacs_env_retain ! ***************************************************************************** !> \brief releases the given blacs_env !> \param blacs_env the blacs env to relase -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_blacs_env_release(blacs_env,error) +SUBROUTINE cp_blacs_env_release(blacs_env) TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_blacs_env_release', & routineP = moduleN//':'//routineN @@ -308,17 +298,17 @@ SUBROUTINE cp_blacs_env_release(blacs_env,error) failure=.FALSE. IF (ASSOCIATED(blacs_env)) THEN - CPPrecondition(blacs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(blacs_env%ref_count>0,cp_failure_level,routineP,failure) blacs_env%ref_count=blacs_env%ref_count-1 IF (blacs_env%ref_count<1) THEN CALL cp_blacs_gridexit(blacs_env%group) - CALL cp_para_env_release(blacs_env%para_env,error=error) + CALL cp_para_env_release(blacs_env%para_env) DEALLOCATE(blacs_env%mpi2blacs, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(blacs_env%blacs2mpi,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(blacs_env,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF NULLIFY(blacs_env) @@ -329,16 +319,13 @@ END SUBROUTINE cp_blacs_env_release !> \param blacs_env the blacs environment to write !> \param unit_nr the unit number where to write the description of the !> blacs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_blacs_env_write(blacs_env, unit_nr, error) +SUBROUTINE cp_blacs_env_write(blacs_env, unit_nr) TYPE(cp_blacs_env_type), POINTER :: blacs_env INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_blacs_env_write', & routineP = moduleN//':'//routineN @@ -351,20 +338,20 @@ SUBROUTINE cp_blacs_env_write(blacs_env, unit_nr, error) IF (ASSOCIATED(blacs_env)) THEN WRITE (unit=unit_nr,fmt="(' group=',i10,', ref_count=',i10,',')",& iostat=iostat) blacs_env%group, blacs_env%ref_count - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' mepos=(',i8,',',i8,'),')",& iostat=iostat) blacs_env%mepos(1), blacs_env%mepos(2) - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' num_pe=(',i8,',',i8,'),')",& iostat=iostat) blacs_env%num_pe(1), blacs_env%num_pe(2) - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(blacs_env%blacs2mpi)) THEN WRITE (unit=unit_nr,fmt="(' blacs2mpi=')",advance="no",iostat=iostat) - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) - CALL cp_2d_i_write(blacs_env%blacs2mpi,unit_nr=unit_nr, error=error) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) + CALL cp_2d_i_write(blacs_env%blacs2mpi,unit_nr=unit_nr) ELSE WRITE (unit=unit_nr,fmt="(' blacs2mpi=*null*')",iostat=iostat) - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(blacs_env%para_env)) THEN WRITE (unit=unit_nr,fmt="(' para_env=,')")& @@ -374,11 +361,11 @@ SUBROUTINE cp_blacs_env_write(blacs_env, unit_nr, error) END IF WRITE (unit=unit_nr,fmt="(' my_pid=',i10,', n_pid=',i10,' }')",& iostat=iostat) blacs_env%my_pid, blacs_env%n_pid - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) ELSE WRITE (unit=unit_nr,& fmt="(a)", iostat=iostat) ' :*null* ' - CPInvariant(iostat==0,cp_failure_level,routineP,error,failure) + CPInvariant(iostat==0,cp_failure_level,routineP,failure) END IF CALL m_flush(unit_nr) END SUBROUTINE cp_blacs_env_write diff --git a/src/fm/cp_cfm_basic_linalg.F b/src/fm/cp_cfm_basic_linalg.F index c469043b7b..90d9620510 100644 --- a/src/fm/cp_cfm_basic_linalg.F +++ b/src/fm/cp_cfm_basic_linalg.F @@ -43,12 +43,10 @@ MODULE cp_cfm_basic_linalg !> \param matrix_a ... !> \param matrix_b ... !> \param matrix_c ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_cfm_schur_product(matrix_a,matrix_b,matrix_c,error) + SUBROUTINE cp_cfm_schur_product(matrix_a,matrix_b,matrix_c) TYPE(cp_cfm_type), POINTER :: matrix_a, matrix_b, matrix_c - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_schur_product', & routineP = moduleN//':'//routineN @@ -86,12 +84,10 @@ END SUBROUTINE cp_cfm_schur_product !> \param matrix_a ... !> \param matrix_b ... !> \param matrix_c ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_cfm_schur_product_cc(matrix_a,matrix_b,matrix_c,error) + SUBROUTINE cp_cfm_schur_product_cc(matrix_a,matrix_b,matrix_c) TYPE(cp_cfm_type), POINTER :: matrix_a, matrix_b, matrix_c - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_schur_product_cc', & routineP = moduleN//':'//routineN @@ -129,17 +125,15 @@ END SUBROUTINE cp_cfm_schur_product_cc !> \param matrix_a ... !> \param beta ... !> \param matrix_b ... -!> \param error ... !> \date 11.06.2001 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - SUBROUTINE cp_cfm_add(alpha,matrix_a,beta,matrix_b,error) + SUBROUTINE cp_cfm_add(alpha,matrix_a,beta,matrix_b) COMPLEX(KIND=dp), INTENT(IN) :: alpha TYPE(cp_cfm_type), POINTER :: matrix_a COMPLEX(KIND=dp), INTENT(in), OPTIONAL :: beta TYPE(cp_cfm_type), OPTIONAL, POINTER :: matrix_b - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_add', & routineP = moduleN//':'//routineN @@ -157,8 +151,8 @@ SUBROUTINE cp_cfm_add(alpha,matrix_a,beta,matrix_b,error) IF(PRESENT(beta)) my_beta=beta NULLIFY(a,b) - CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,error,failure) - CPPrecondition(matrix_a%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,failure) + CPPrecondition(matrix_a%ref_count>0,cp_failure_level,routineP,failure) ! to do: use dscal,dcopy,daxp myprow=matrix_a%matrix_struct%context%mepos(1) mypcol=matrix_a%matrix_struct%context%mepos(2) @@ -176,18 +170,18 @@ SUBROUTINE cp_cfm_add(alpha,matrix_a,beta,matrix_b,error) END IF ELSE - CPPrecondition(PRESENT(matrix_b),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_b),cp_failure_level,routineP,error,failure) - CPPrecondition(matrix_b%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrix_b),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_b),cp_failure_level,routineP,failure) + CPPrecondition(matrix_b%ref_count>0,cp_failure_level,routineP,failure) CALL cp_assert(matrix_a%matrix_struct%context%group==& matrix_b%matrix_struct%context%group,cp_failure_level,& cp_assertion_failed,fromWhere=routineP,& message="matrixes must be in the same blacs context"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) IF (cp_fm_struct_equivalent(matrix_a%matrix_struct,& - matrix_b%matrix_struct,error=error)) THEN + matrix_b%matrix_struct)) THEN b => matrix_b%local_data @@ -209,9 +203,9 @@ SUBROUTINE cp_cfm_add(alpha,matrix_a,beta,matrix_b,error) ELSE #ifdef __SCALAPACK CALL cp_unimplemented_error(fromWhere=routineP, & - message="to do (pdscal,pdcopy,pdaxpy)", error=error) + message="to do (pdscal,pdcopy,pdaxpy)") #else - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) #endif END IF END IF @@ -225,17 +219,15 @@ END SUBROUTINE cp_cfm_add !> \param matrix_a ... !> \param beta ... !> \param matrix_b ... -!> \param error ... !> \date 01.08.2014 !> \author JGH !> \version 1.0 ! ***************************************************************************** - SUBROUTINE cp_cfm_add_fm(alpha,matrix_a,beta,matrix_b,error) + SUBROUTINE cp_cfm_add_fm(alpha,matrix_a,beta,matrix_b) COMPLEX(KIND=dp), INTENT(IN) :: alpha TYPE(cp_cfm_type), POINTER :: matrix_a COMPLEX(KIND=dp), INTENT(IN) :: beta TYPE(cp_fm_type), POINTER :: matrix_b - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_add_fm', & routineP = moduleN//':'//routineN @@ -251,7 +243,7 @@ SUBROUTINE cp_cfm_add_fm(alpha,matrix_a,beta,matrix_b,error) failure=.FALSE. NULLIFY(a,b) - CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,failure) myprow=matrix_a%matrix_struct%context%mepos(1) mypcol=matrix_a%matrix_struct%context%mepos(2) @@ -268,16 +260,16 @@ SUBROUTINE cp_cfm_add_fm(alpha,matrix_a,beta,matrix_b,error) END IF ELSE - CPPrecondition(ASSOCIATED(matrix_b),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_b),cp_failure_level,routineP,failure) CALL cp_assert(matrix_a%matrix_struct%context%group==& matrix_b%matrix_struct%context%group,cp_failure_level,& cp_assertion_failed,fromWhere=routineP,& message="matrices must be in the same blacs context"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) IF (cp_fm_struct_equivalent(matrix_a%matrix_struct,& - matrix_b%matrix_struct,error=error)) THEN + matrix_b%matrix_struct)) THEN b => matrix_b%local_data @@ -299,9 +291,9 @@ SUBROUTINE cp_cfm_add_fm(alpha,matrix_a,beta,matrix_b,error) ELSE #ifdef __SCALAPACK CALL cp_unimplemented_error(fromWhere=routineP, & - message="to do (pdscal,pdcopy,pdaxpy)", error=error) + message="to do (pdscal,pdcopy,pdaxpy)") #else - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) #endif END IF END IF @@ -317,15 +309,13 @@ END SUBROUTINE cp_cfm_add_fm !> one should be able to find out if ipivot is an even or an odd permutation... !> \param matrix_a ... !> \param almost_determinant ... -!> \param error ... !> \date 11.06.2001 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - SUBROUTINE cp_cfm_lu_decompose(matrix_a,almost_determinant,error) + SUBROUTINE cp_cfm_lu_decompose(matrix_a,almost_determinant) TYPE(cp_cfm_type), POINTER :: matrix_a COMPLEX(KIND=dp), INTENT(OUT) :: almost_determinant - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_lu_decompose', & routineP = moduleN//':'//routineN @@ -349,7 +339,7 @@ SUBROUTINE cp_cfm_lu_decompose(matrix_a,almost_determinant,error) a => matrix_a%local_data n = matrix_a%matrix_struct%nrow_global ALLOCATE(ipivot(n)) - CALL cp_cfm_get_info(matrix_a,row_indices=row_indices,nrow_local=nrow_local,error=error) + CALL cp_cfm_get_info(matrix_a,row_indices=row_indices,nrow_local=nrow_local) #if defined(__SCALAPACK) desca(:) = matrix_a%matrix_struct%descriptor(:) CALL pzgetrf(n,n,a(1,1),1,1,desca,ipivot,info) @@ -399,21 +389,19 @@ SUBROUTINE cp_cfm_lu_decompose(matrix_a,almost_determinant,error) !> \param matrix_b ... !> \param beta ... !> \param matrix_c ... -!> \param error ... !> \param b_first_col ... !> \date 07.06.2001 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** SUBROUTINE cp_cfm_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& - matrix_c,error,b_first_col) + matrix_c,b_first_col) CHARACTER(LEN=1), INTENT(IN) :: transa, transb INTEGER, INTENT(IN) :: m, n, k COMPLEX(KIND=dp), INTENT(IN) :: alpha TYPE(cp_cfm_type), POINTER :: matrix_a, matrix_b COMPLEX(KIND=dp), INTENT(IN) :: beta TYPE(cp_cfm_type), POINTER :: matrix_c - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, INTENT(IN), OPTIONAL :: b_first_col CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_gemm', & @@ -514,13 +502,11 @@ END SUBROUTINE cp_cfm_column_scale !> \param matrix_a ... !> \param general_a ... !> \param determinant ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE cp_cfm_solve(matrix_a,general_a,determinant,error) + SUBROUTINE cp_cfm_solve(matrix_a,general_a,determinant) TYPE(cp_cfm_type), POINTER :: matrix_a, general_a COMPLEX(KIND=dp), OPTIONAL :: determinant - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_solve', & routineP = moduleN//':'//routineN @@ -543,7 +529,7 @@ SUBROUTINE cp_cfm_solve(matrix_a,general_a,determinant,error) a => matrix_a%local_data a_general => general_a%local_data n = matrix_a%matrix_struct%nrow_global - CALL cp_cfm_get_info(matrix_a,row_indices=row_indices,nrow_local=nrow_local,error=error) + CALL cp_cfm_get_info(matrix_a,row_indices=row_indices,nrow_local=nrow_local) ALLOCATE(ipivot(n)) #if defined(__SCALAPACK) @@ -598,17 +584,14 @@ END SUBROUTINE cp_cfm_solve !> \param matrix the matrix to replace with its cholesky decomposition !> \param n the number of row (and columns) of the matrix & !> (defaults to the min(size(matrix))) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [JVdV] !> 12.2002 updated, added n optional parm [fawzi] !> \author Joost ! ***************************************************************************** - SUBROUTINE cp_cfm_cholesky_decompose(matrix,n,error) + SUBROUTINE cp_cfm_cholesky_decompose(matrix,n) TYPE(cp_cfm_type), POINTER :: matrix INTEGER, INTENT(in), OPTIONAL :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_cholesky_decompose', & routineP = moduleN//':'//routineN @@ -627,7 +610,7 @@ SUBROUTINE cp_cfm_cholesky_decompose(matrix,n,error) my_n = MIN(matrix%matrix_struct%nrow_global,& matrix%matrix_struct%ncol_global) IF (PRESENT(n)) THEN - CPPrecondition(n<=my_n,cp_failure_level,routineP,error,failure) + CPPrecondition(n<=my_n,cp_failure_level,routineP,failure) my_n=n END IF @@ -643,7 +626,7 @@ SUBROUTINE cp_cfm_cholesky_decompose(matrix,n,error) #endif - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -677,8 +660,6 @@ END SUBROUTINE cp_cfm_cholesky_decompose !> \param n_cols the number of columns of the result (defaults to !> size(matrix_b,2)) !> \param alpha ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -687,7 +668,7 @@ END SUBROUTINE cp_cfm_cholesky_decompose ! ***************************************************************************** SUBROUTINE cp_cfm_triangular_multiply(triangular_matrix,matrix_b,side,& transa_tr, invert_tr, uplo_tr,unit_diag_tr, n_rows, n_cols, & - alpha,error) + alpha) TYPE(cp_cfm_type), POINTER :: triangular_matrix, matrix_b CHARACTER, INTENT(in), OPTIONAL :: side, transa_tr LOGICAL, INTENT(in), OPTIONAL :: invert_tr @@ -695,7 +676,6 @@ SUBROUTINE cp_cfm_triangular_multiply(triangular_matrix,matrix_b,side,& LOGICAL, INTENT(in), OPTIONAL :: unit_diag_tr INTEGER, INTENT(in), OPTIONAL :: n_rows, n_cols COMPLEX(KIND=dp), INTENT(in), OPTIONAL :: alpha - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_triangular_multiply', & routineP = moduleN//':'//routineN @@ -715,7 +695,7 @@ SUBROUTINE cp_cfm_triangular_multiply(triangular_matrix,matrix_b,side,& transa='N' invert=.FALSE. al=CMPLX(1.0_dp,0.0_dp,dp) - CALL cp_cfm_get_info(matrix_b, nrow_global=m, ncol_global=n, error=error) + CALL cp_cfm_get_info(matrix_b, nrow_global=m, ncol_global=n) IF (PRESENT(side)) side_char=side IF (PRESENT(invert_tr)) invert=invert_tr IF (PRESENT(uplo_tr)) uplo=uplo_tr @@ -771,14 +751,12 @@ END SUBROUTINE cp_cfm_triangular_multiply !> \brief inverts a triangular matrix !> \param matrix_a ... !> \param uplo_tr ... -!> \param error ... !> \author MI ! ***************************************************************************** - SUBROUTINE cp_cfm_triangular_invert(matrix_a,uplo_tr,error) + SUBROUTINE cp_cfm_triangular_invert(matrix_a,uplo_tr) TYPE(cp_cfm_type), POINTER :: matrix_a CHARACTER, INTENT(IN), OPTIONAL :: uplo_tr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_cfm_triangular_invert', & routineP = moduleN//':'//routineN diff --git a/src/fm/cp_cfm_diag.F b/src/fm/cp_cfm_diag.F index 5b193bc401..ff909ff8c6 100644 --- a/src/fm/cp_cfm_diag.F +++ b/src/fm/cp_cfm_diag.F @@ -45,16 +45,14 @@ MODULE cp_cfm_diag !> \param matrix ... !> \param eigenvectors ... !> \param eigenvalues ... -!> \param error ... !> \par History !> - (De)Allocation checks updated (15.02.2011,MK) !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_cfm_heevd(matrix,eigenvectors,eigenvalues,error) + SUBROUTINE cp_cfm_heevd(matrix,eigenvectors,eigenvalues) TYPE(cp_cfm_type), POINTER :: matrix, eigenvectors REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: eigenvalues - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_heevd', & routineP = moduleN//':'//routineN @@ -79,8 +77,8 @@ SUBROUTINE cp_cfm_heevd(matrix,eigenvectors,eigenvalues,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(eigenvectors),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(eigenvectors),cp_failure_level,routineP,failure) n = matrix%matrix_struct%nrow_global m => matrix%local_data @@ -170,14 +168,12 @@ END SUBROUTINE cp_cfm_heevd !> \param eigenvectors ... !> \param eigenvalues ... !> \param work ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_cfm_geeig(amatrix,bmatrix,eigenvectors,eigenvalues,work,error) + SUBROUTINE cp_cfm_geeig(amatrix,bmatrix,eigenvectors,eigenvalues,work) TYPE(cp_cfm_type), POINTER :: amatrix, bmatrix, eigenvectors REAL(KIND=dp), DIMENSION(:) :: eigenvalues TYPE(cp_cfm_type), POINTER :: work - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_geeig', & routineP = moduleN//':'//routineN @@ -190,26 +186,26 @@ SUBROUTINE cp_cfm_geeig(amatrix,bmatrix,eigenvectors,eigenvalues,work,error) failure = .FALSE. - CALL cp_cfm_get_info(amatrix,nrow_global=nao,error=error) + CALL cp_cfm_get_info(amatrix,nrow_global=nao) ALLOCATE (evals(nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Cholesky decompose S=U(T)U - CALL cp_cfm_cholesky_decompose(bmatrix,error=error) + CALL cp_cfm_cholesky_decompose(bmatrix) ! Invert to get U^(-1) - CALL cp_cfm_triangular_invert(bmatrix,error=error) + CALL cp_cfm_triangular_invert(bmatrix) ! Reduce to get U^(-T) * H * U^(-1) - CALL cp_cfm_triangular_multiply(bmatrix,amatrix,side="R",error=error) - CALL cp_cfm_triangular_multiply(bmatrix,amatrix,transa_tr="C",error=error) + CALL cp_cfm_triangular_multiply(bmatrix,amatrix,side="R") + CALL cp_cfm_triangular_multiply(bmatrix,amatrix,transa_tr="C") ! Diagonalize - CALL cp_cfm_heevd(matrix=amatrix,eigenvectors=work,eigenvalues=evals,error=error) + CALL cp_cfm_heevd(matrix=amatrix,eigenvectors=work,eigenvalues=evals) ! Restore vectors C = U^(-1) * C* - CALL cp_cfm_triangular_multiply(bmatrix,work,error=error) + CALL cp_cfm_triangular_multiply(bmatrix,work) nmo = SIZE(eigenvalues) CALL cp_cfm_to_cfm(work,eigenvectors,nmo) eigenvalues(1:nmo) = evals(1:nmo) DEALLOCATE (evals,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/fm/cp_cfm_types.F b/src/fm/cp_cfm_types.F index ae26b00981..1e8658d1a6 100644 --- a/src/fm/cp_cfm_types.F +++ b/src/fm/cp_cfm_types.F @@ -77,16 +77,13 @@ MODULE cp_cfm_types !> \param matrix the matrix to be created !> \param matrix_struct the structure of matrix !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \note !> preferred allocation routine ! ***************************************************************************** - SUBROUTINE cp_cfm_create(matrix,matrix_struct,name,error) + SUBROUTINE cp_cfm_create(matrix,matrix_struct,name) TYPE(cp_cfm_type), POINTER :: matrix TYPE(cp_fm_struct_type), POINTER :: matrix_struct CHARACTER(len=*), INTENT(in), OPTIONAL :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_create', & routineP = moduleN//':'//routineN @@ -101,16 +98,15 @@ SUBROUTINE cp_cfm_create(matrix,matrix_struct,name,error) #if defined(__parallel) && ! defined(__SCALAPACK) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"full matrixes need scalapack for parallel runs "//& -CPSourceFileRef,& - error) +CPSourceFileRef) #endif - CPPrecondition(ASSOCIATED(matrix_struct),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_struct),cp_failure_level,routineP,failure) ALLOCATE(matrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) context => matrix_struct%context matrix%matrix_struct => matrix_struct - CALL cp_fm_struct_retain(matrix%matrix_struct,error=error) + CALL cp_fm_struct_retain(matrix%matrix_struct) last_cfm_id_nr=last_cfm_id_nr+1 matrix%id_nr=last_cfm_id_nr matrix%ref_count=1 @@ -123,7 +119,7 @@ SUBROUTINE cp_cfm_create(matrix,matrix_struct,name,error) nrow_local=matrix_struct%local_leading_dimension ncol_local=MAX(1,matrix_struct%ncol_locals(context%mepos(2))) ALLOCATE(matrix%local_data(nrow_local,ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL dcopy(2*nrow_local*ncol_local,0.0_dp,0,matrix%local_data,1) ! matrix%local_data(:,:) = 0.0_dp @@ -138,12 +134,9 @@ END SUBROUTINE cp_cfm_create ! ***************************************************************************** !> \brief retains a full matrix !> \param matrix the matrix to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE cp_cfm_retain(matrix,error) + SUBROUTINE cp_cfm_retain(matrix) TYPE(cp_cfm_type), POINTER :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_retain', & routineP = moduleN//':'//routineN @@ -152,20 +145,17 @@ SUBROUTINE cp_cfm_retain(matrix,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) - CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,failure) + CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,failure) matrix%ref_count=matrix%ref_count+1 END SUBROUTINE cp_cfm_retain ! ***************************************************************************** !> \brief releases a full matrix !> \param matrix the matrix to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE cp_cfm_release(matrix,error) + SUBROUTINE cp_cfm_release(matrix) TYPE(cp_cfm_type), POINTER :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_release', & routineP = moduleN//':'//routineN @@ -176,17 +166,17 @@ SUBROUTINE cp_cfm_release(matrix,error) failure=.FALSE. IF (ASSOCIATED(matrix)) THEN - CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,failure) matrix%ref_count=matrix%ref_count-1 IF (matrix%ref_count<1) THEN IF (ASSOCIATED(matrix%local_data)) THEN DEALLOCATE(matrix%local_data,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF matrix%name="" - CALL cp_fm_struct_release(matrix%matrix_struct,error=error) + CALL cp_fm_struct_release(matrix%matrix_struct) DEALLOCATE(matrix,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF NULLIFY(matrix) @@ -197,23 +187,21 @@ END SUBROUTINE cp_cfm_release !> \param matrix ... !> \param alpha ... !> \param beta ... -!> \param error ... !> \date 12.06.2001 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - SUBROUTINE cp_cfm_set_all(matrix,alpha,beta,error) + SUBROUTINE cp_cfm_set_all(matrix,alpha,beta) TYPE(cp_cfm_type), POINTER :: matrix COMPLEX(KIND=dp), INTENT(IN) :: alpha COMPLEX(KIND=dp), INTENT(IN), OPTIONAL :: beta - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i matrix%local_data(:,:) = alpha IF (PRESENT(beta)) THEN DO i=1,matrix%matrix_struct%nrow_global - CALL cp_cfm_set_element(matrix,i,i,beta,error=error) + CALL cp_cfm_set_element(matrix,i,i,beta) ENDDO ENDIF @@ -276,17 +264,15 @@ END SUBROUTINE cp_cfm_get_element !> \param irow_global ... !> \param icol_global ... !> \param alpha ... -!> \param error ... !> \date 12.06.2001 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - SUBROUTINE cp_cfm_set_element(matrix,irow_global,icol_global,alpha,error) + SUBROUTINE cp_cfm_set_element(matrix,irow_global,icol_global,alpha) TYPE(cp_cfm_type), POINTER :: matrix INTEGER, INTENT(IN) :: irow_global, icol_global COMPLEX(KIND=dp), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: mypcol, myprow, npcol, nprow TYPE(cp_blacs_env_type), POINTER :: context @@ -344,7 +330,6 @@ END SUBROUTINE cp_cfm_set_element !> \param context ... !> \param matrix_struct ... !> \param para_env ... -!> \param error ... !> \date 12.06.2001 !> \author Matthias Krack !> \version 1.0 @@ -352,7 +337,7 @@ END SUBROUTINE cp_cfm_set_element SUBROUTINE cp_cfm_get_info(matrix,name,nrow_global,ncol_global,& nrow_block,ncol_block,nrow_local,ncol_local,& row_indices,col_indices,local_data,context,& - matrix_struct,para_env,error) + matrix_struct,para_env) TYPE(cp_cfm_type), POINTER :: matrix CHARACTER(LEN=*), OPTIONAL, INTENT(OUT) :: name INTEGER, OPTIONAL, INTENT(OUT) :: ncol_block,ncol_global,& @@ -362,7 +347,6 @@ SUBROUTINE cp_cfm_get_info(matrix,name,nrow_global,ncol_global,& TYPE(cp_para_env_type), POINTER, OPTIONAL :: para_env TYPE(cp_blacs_env_type), POINTER, OPTIONAL :: context TYPE(cp_fm_struct_type),POINTER,OPTIONAL :: matrix_struct - TYPE(cp_error_type), INTENT(inout) :: error COMPLEX(KIND = dp), DIMENSION(:,:), POINTER, OPTIONAL :: local_data CHARACTER(len=*), PARAMETER :: routineN='cp_cfm_get_info',& @@ -403,7 +387,7 @@ SUBROUTINE cp_cfm_get_info(matrix,name,nrow_global,ncol_global,& IF (.NOT.ASSOCIATED(row_indices)) THEN ALLOCATE(matrix%matrix_struct%row_indices & (matrix%matrix_struct%nrow_locals(myprow)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices => matrix%matrix_struct%row_indices #ifdef __SCALAPACK DO i=1,SIZE(row_indices) @@ -424,7 +408,7 @@ SUBROUTINE cp_cfm_get_info(matrix,name,nrow_global,ncol_global,& IF (.NOT.ASSOCIATED(col_indices)) THEN ALLOCATE(matrix%matrix_struct%col_indices & (matrix%matrix_struct%ncol_locals(mypcol)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices => matrix%matrix_struct%col_indices #ifdef __SCALAPACK DO i=1,SIZE(col_indices) @@ -448,12 +432,10 @@ END SUBROUTINE cp_cfm_get_info !> \brief copy one identically sized matrix in the other !> \param source ... !> \param destination ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_cfm_to_cfm_matrix(source,destination,error) + SUBROUTINE cp_cfm_to_cfm_matrix(source,destination) TYPE(cp_cfm_type), POINTER :: source, destination - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cfm_to_cfm_matrix', & routineP = moduleN//':'//routineN @@ -467,13 +449,12 @@ SUBROUTINE cp_cfm_to_cfm_matrix(source,destination,error) IF(.NOT. cp2k_is_parallel .OR.& cp_fm_struct_equivalent(source%matrix_struct,& - destination%matrix_struct,error=error)) THEN + destination%matrix_struct)) THEN CALL cp_assert(SIZE(source%local_data,1)==SIZE(destination%local_data,1).AND.& SIZE(source%local_data,2)==SIZE(destination%local_data,2),cp_failure_level,& cp_assertion_failed, routineP, & - "internal error, local_data has different sizes"//& -CPSourceFileRef,& - error=error) + "internal local_data has different sizes"//& +CPSourceFileRef) CALL dcopy(SIZE(source%local_data,1)*SIZE(source%local_data,2)*2,& source%local_data(1,1),1,destination%local_data(1,1),1) ELSE @@ -482,22 +463,20 @@ SUBROUTINE cp_cfm_to_cfm_matrix(source,destination,error) cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy between full matrixes of differen sizes"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) CALL cp_assert(source%matrix_struct%ncol_global==& destination%matrix_struct%ncol_global,& cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy between full matrixes of differen sizes"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) #ifdef __SCALAPACK CALL pzcopy(source%matrix_struct%nrow_global*& source%matrix_struct%ncol_global,& source%local_data(1,1),1,1,source%matrix_struct%descriptor,1,& destination%local_data(1,1),1,1,destination%matrix_struct%descriptor,1) #else - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) #endif END IF END SUBROUTINE cp_cfm_to_cfm_matrix @@ -561,13 +540,11 @@ END SUBROUTINE cp_cfm_to_cfm_columns !> \param msource ... !> \param mtargetr ... !> \param mtargeti ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_cfm_to_fm(msource,mtargetr,mtargeti,error) + SUBROUTINE cp_cfm_to_fm(msource,mtargetr,mtargeti) TYPE(cp_cfm_type), POINTER :: msource TYPE(cp_fm_type), POINTER :: mtargetr, mtargeti - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_cfm_to_fm', & routineP = moduleN//':'//routineN @@ -585,23 +562,20 @@ SUBROUTINE cp_cfm_to_fm(msource,mtargetr,mtargeti,error) ! This routine is only for equivalent structures CALL cp_assert(cp_fm_struct_equivalent(msource%matrix_struct,& - mtargetr%matrix_struct,error=error),cp_failure_level,& + mtargetr%matrix_struct),cp_failure_level,& cp_assertion_failed, routineP, & - "internal error, local_data has different sizes"//& -CPSourceFileRef,& - error=error) + "internal local_data has different sizes"//& +CPSourceFileRef) CALL cp_assert(cp_fm_struct_equivalent(msource%matrix_struct,& - mtargeti%matrix_struct,error=error),cp_failure_level,& + mtargeti%matrix_struct),cp_failure_level,& cp_assertion_failed, routineP, & - "internal error, local_data has different sizes"//& -CPSourceFileRef,& - error=error) + "internal local_data has different sizes"//& +CPSourceFileRef) CALL cp_assert(SIZE(a,1)==SIZE(br,1).AND.SIZE(a,2)==SIZE(br,2)& .AND.SIZE(a,1)==SIZE(bi,1).AND.SIZE(a,2)==SIZE(bi,2),cp_failure_level,& cp_assertion_failed, routineP, & - "internal error, local_data has different sizes"//& -CPSourceFileRef,& - error=error) + "internal local_data has different sizes"//& +CPSourceFileRef) br = REAL(a) bi = AIMAG(a) diff --git a/src/fm/cp_fm_basic_linalg.F b/src/fm/cp_fm_basic_linalg.F index 1270029b40..5b0295169c 100644 --- a/src/fm/cp_fm_basic_linalg.F +++ b/src/fm/cp_fm_basic_linalg.F @@ -61,15 +61,13 @@ MODULE cp_fm_basic_linalg !> \param matrix_a ... !> \param beta ... !> \param matrix_b ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_scale_and_add(alpha,matrix_a,beta,matrix_b,error) + SUBROUTINE cp_fm_scale_and_add(alpha,matrix_a,beta,matrix_b) REAL(KIND=dp), INTENT(IN) :: alpha TYPE(cp_fm_type), POINTER :: matrix_a REAL(KIND=dp), INTENT(in), OPTIONAL :: beta TYPE(cp_fm_type), OPTIONAL, POINTER :: matrix_b - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_scale_and_add', & routineP = moduleN//':'//routineN @@ -91,21 +89,21 @@ SUBROUTINE cp_fm_scale_and_add(alpha,matrix_a,beta,matrix_b,error) IF(PRESENT(beta)) my_beta=beta NULLIFY(a,b) - CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,error,failure) - CPPrecondition(matrix_a%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,failure) + CPPrecondition(matrix_a%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(beta)) THEN - CPPrecondition(PRESENT(matrix_b),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_b),cp_failure_level,routineP,error,failure) - CPPrecondition(matrix_b%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrix_b),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_b),cp_failure_level,routineP,failure) + CPPrecondition(matrix_b%ref_count>0,cp_failure_level,routineP,failure) IF (matrix_a%id_nr==matrix_b%id_nr) THEN CALL cp_assert(matrix_a%id_nr/=matrix_b%id_nr, & cp_warning_level, cp_assertion_failed, & fromWhere=routineP, & message="Bad use of routine. Call cp_fm_scale instead: "// & CPSourceFileRef, & - error=error, failure=failure) - CALL cp_fm_scale(alpha+beta, matrix_a, error=error) + failure=failure) + CALL cp_fm_scale(alpha+beta, matrix_a) CALL timestop(handle) RETURN END IF @@ -133,10 +131,10 @@ SUBROUTINE cp_fm_scale_and_add(alpha,matrix_a,beta,matrix_b,error) cp_assertion_failed,fromWhere=routineP,& message="matrixes must be in the same blacs context"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) IF (cp_fm_struct_equivalent(matrix_a%matrix_struct,& - matrix_b%matrix_struct,error=error)) THEN + matrix_b%matrix_struct)) THEN b => matrix_b%local_data b_sp => matrix_b%local_data_sp @@ -154,9 +152,9 @@ SUBROUTINE cp_fm_scale_and_add(alpha,matrix_a,beta,matrix_b,error) ELSE #ifdef __SCALAPACK CALL cp_unimplemented_error(fromWhere=routineP, & - message="to do (pdscal,pdcopy,pdaxpy)", error=error) + message="to do (pdscal,pdcopy,pdaxpy)") #else - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) #endif END IF @@ -259,7 +257,6 @@ SUBROUTINE cp_fm_lu_decompose(matrix_a,almost_determinant,correct_sign) !> \param matrix_b : k x n matrix ( ! for transb = 'N') !> \param beta ... !> \param matrix_c : m x n matrix -!> \param error ... !> \param b_first_col : the k x n matrix starts at col b_first_col of matrix_b (avoid usage) !> \param a_first_row ... !> \param b_first_row ... @@ -270,7 +267,7 @@ SUBROUTINE cp_fm_lu_decompose(matrix_a,almost_determinant,correct_sign) !> matrix_c should have no overlap with matrix_a, matrix_b ! ***************************************************************************** SUBROUTINE cp_fm_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& - matrix_c,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + matrix_c,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CHARACTER(LEN=1), INTENT(IN) :: transa, transb INTEGER, INTENT(IN) :: m, n, k @@ -278,7 +275,6 @@ SUBROUTINE cp_fm_gemm(transa,transb,m,n,k,alpha,matrix_a,matrix_b,beta,& TYPE(cp_fm_type), POINTER :: matrix_a, matrix_b REAL(KIND=dp), INTENT(IN) :: beta TYPE(cp_fm_type), POINTER :: matrix_c - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, INTENT(IN), OPTIONAL :: b_first_col, a_first_row, & b_first_row, c_first_col, & c_first_row @@ -397,7 +393,6 @@ END SUBROUTINE cp_fm_gemm !> \param matrix_b : m x n matrix !> \param beta ... !> \param matrix_c : m x n matrix -!> \param error ... !> \author Matthias Krack !> \note !> matrix_c should have no overlap with matrix_a, matrix_b @@ -405,8 +400,7 @@ END SUBROUTINE cp_fm_gemm !> matrix_a is always an m x m matrix !> it is typically slower to do cp_fm_symm than cp_fm_gemm (especially in parallel easily 50 percent !) ! ***************************************************************************** - SUBROUTINE cp_fm_symm(side,uplo,m,n,alpha,matrix_a,matrix_b,beta,matrix_c,& - error) + SUBROUTINE cp_fm_symm(side,uplo,m,n,alpha,matrix_a,matrix_b,beta,matrix_c) CHARACTER(LEN=1), INTENT(IN) :: side, uplo INTEGER, INTENT(IN) :: m, n @@ -414,7 +408,6 @@ SUBROUTINE cp_fm_symm(side,uplo,m,n,alpha,matrix_a,matrix_b,beta,matrix_c,& TYPE(cp_fm_type), POINTER :: matrix_a, matrix_b REAL(KIND=dp), INTENT(IN) :: beta TYPE(cp_fm_type), POINTER :: matrix_c - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_symm', & routineP = moduleN//':'//routineN @@ -458,13 +451,11 @@ END SUBROUTINE cp_fm_symm !> \brief computes the Frobenius norm of matrix_a !> \param matrix_a : m x n matrix !> \param norm ... -!> \param error ... !> \author VW ! ***************************************************************************** - SUBROUTINE cp_fm_frobenius_norm(matrix_a,norm,error) + SUBROUTINE cp_fm_frobenius_norm(matrix_a,norm) TYPE(cp_fm_type), POINTER :: matrix_a REAL(KIND=dp), INTENT(inout) :: norm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_frobenius_norm', & routineP = moduleN//':'//routineN @@ -505,12 +496,11 @@ END SUBROUTINE cp_fm_frobenius_norm !> \param ja ... !> \param beta ... !> \param matrix_c ... -!> \param error ... !> \author Matthias Krack !> \note !> In QS uplo should 'U' (upper part updated) ! ***************************************************************************** - SUBROUTINE cp_fm_syrk(uplo,trans,k,alpha,matrix_a,ia,ja,beta,matrix_c,error) + SUBROUTINE cp_fm_syrk(uplo,trans,k,alpha,matrix_a,ia,ja,beta,matrix_c) CHARACTER(LEN=1), INTENT(IN) :: uplo, trans INTEGER, INTENT(IN) :: k REAL(KIND=dp), INTENT(IN) :: alpha @@ -518,7 +508,6 @@ SUBROUTINE cp_fm_syrk(uplo,trans,k,alpha,matrix_a,ia,ja,beta,matrix_c,error) INTEGER, INTENT(IN) :: ia, ja REAL(KIND=dp), INTENT(IN) :: beta TYPE(cp_fm_type), POINTER :: matrix_c - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_syrk', & routineP = moduleN//':'//routineN @@ -563,13 +552,11 @@ END SUBROUTINE cp_fm_syrk !> \param matrix_a ... !> \param matrix_b ... !> \param matrix_c ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_fm_schur_product(matrix_a,matrix_b,matrix_c,error) + SUBROUTINE cp_fm_schur_product(matrix_a,matrix_b,matrix_c) TYPE(cp_fm_type), POINTER :: matrix_a, matrix_b, matrix_c - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_schur_product', & routineP = moduleN//':'//routineN @@ -612,8 +599,6 @@ END SUBROUTINE cp_fm_schur_product !> \param matrix_a a matrix !> \param matrix_b another matrix !> \param trace ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.06.2001 Creation (Matthias Krack) !> 12.2002 added doc [fawzi] @@ -621,11 +606,10 @@ END SUBROUTINE cp_fm_schur_product !> \note !> note the transposition of matrix_a! ! ***************************************************************************** - SUBROUTINE cp_fm_trace(matrix_a,matrix_b,trace,error) + SUBROUTINE cp_fm_trace(matrix_a,matrix_b,trace) TYPE(cp_fm_type), POINTER :: matrix_a, matrix_b REAL(KIND=dp), INTENT(OUT) :: trace - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_trace', & routineP = moduleN//':'//routineN @@ -704,8 +688,6 @@ END SUBROUTINE cp_fm_trace !> \param n_cols the number of columns of the result (defaults to !> size(matrix_b,2)) !> \param alpha ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -714,7 +696,7 @@ END SUBROUTINE cp_fm_trace ! ***************************************************************************** SUBROUTINE cp_fm_triangular_multiply(triangular_matrix,matrix_b,side,& transpose_tr, invert_tr, uplo_tr,unit_diag_tr, n_rows, n_cols, & - alpha,error) + alpha) TYPE(cp_fm_type), POINTER :: triangular_matrix, matrix_b CHARACTER, INTENT(in), OPTIONAL :: side LOGICAL, INTENT(in), OPTIONAL :: transpose_tr, invert_tr @@ -722,7 +704,6 @@ SUBROUTINE cp_fm_triangular_multiply(triangular_matrix,matrix_b,side,& LOGICAL, INTENT(in), OPTIONAL :: unit_diag_tr INTEGER, INTENT(in), OPTIONAL :: n_rows, n_cols REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_triangular_multiply', & routineP = moduleN//':'//routineN @@ -742,7 +723,7 @@ SUBROUTINE cp_fm_triangular_multiply(triangular_matrix,matrix_b,side,& transa='N' invert=.FALSE. al=1.0_dp - CALL cp_fm_get_info(matrix_b, nrow_global=m, ncol_global=n, error=error) + CALL cp_fm_get_info(matrix_b, nrow_global=m, ncol_global=n) IF (PRESENT(side)) side_char=side IF (PRESENT(invert_tr)) invert=invert_tr IF (PRESENT(uplo_tr)) uplo=uplo_tr @@ -804,14 +785,12 @@ END SUBROUTINE cp_fm_triangular_multiply !> matrix_a = alpha * matrix_b !> \param alpha ... !> \param matrix_a ... -!> \param error ... !> \note !> use cp_fm_set_all to zero (avoids problems with nan) ! ***************************************************************************** - SUBROUTINE cp_fm_scale(alpha, matrix_a, error) + SUBROUTINE cp_fm_scale(alpha, matrix_a) REAL(KIND=dp), INTENT(IN) :: alpha TYPE(cp_fm_type), POINTER :: matrix_a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_scale', & routineP = moduleN//':'//routineN @@ -825,8 +804,8 @@ SUBROUTINE cp_fm_scale(alpha, matrix_a, error) failure=.FALSE. NULLIFY(a) - CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,error,failure) - CPPrecondition(matrix_a%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_a),cp_failure_level,routineP,failure) + CPPrecondition(matrix_a%ref_count>0,cp_failure_level,routineP,failure) a => matrix_a%local_data size_a = SIZE(a,1)*SIZE(a,2) @@ -842,14 +821,12 @@ END SUBROUTINE cp_fm_scale !> matrixt = matrix ^ T !> \param matrix ... !> \param matrixt ... -!> \param error ... !> \note !> all matrix elements are transpose (see cp_fm_upper_to_half to symmetrise a matrix) !> all matrix elements are transpose (see cp_fm_upper_to_half to symmetrize a matrix) ! ***************************************************************************** - SUBROUTINE cp_fm_transpose(matrix,matrixt,error) + SUBROUTINE cp_fm_transpose(matrix,matrixt) TYPE(cp_fm_type), POINTER :: matrix, matrixt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_transpose', & routineP = moduleN//':'//routineN @@ -865,12 +842,12 @@ SUBROUTINE cp_fm_transpose(matrix,matrixt,error) #endif failure = .FALSE. - CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrixt),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrixt),cp_failure_level,routineP,failure) IF (failure) RETURN nrow_global = matrix%matrix_struct%nrow_global ncol_global = matrix%matrix_struct%ncol_global - CPPrecondition(nrow_global==ncol_global,cp_failure_level,routineP,error,failure) + CPPrecondition(nrow_global==ncol_global,cp_failure_level,routineP,failure) IF (failure) RETURN CALL timeset(routineN,handle) @@ -897,15 +874,13 @@ END SUBROUTINE cp_fm_transpose !> \brief given an upper triangular matrix computes the corresponding full matrix !> \param matrix the upper triangular matrix as input, the full matrix as output !> \param work a matrix of the same size as matrix -!> \param error ... !> \author Matthias Krack !> \note !> the lower triangular part is irrelevant ! ***************************************************************************** - SUBROUTINE cp_fm_upper_to_full(matrix,work,error) + SUBROUTINE cp_fm_upper_to_full(matrix,work) TYPE(cp_fm_type), POINTER :: matrix,work - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN='cp_fm_upper_to_full',& routineP=moduleN//':'//routineN @@ -929,16 +904,16 @@ SUBROUTINE cp_fm_upper_to_full(matrix,work,error) #endif failure = .FALSE. - CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(work),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(work),cp_failure_level,routineP,failure) IF (failure) RETURN nrow_global = matrix%matrix_struct%nrow_global ncol_global = matrix%matrix_struct%ncol_global - CPPrecondition(nrow_global==ncol_global,cp_failure_level,routineP,error,failure) + CPPrecondition(nrow_global==ncol_global,cp_failure_level,routineP,failure) nrow_global = work%matrix_struct%nrow_global ncol_global = work%matrix_struct%ncol_global - CPPrecondition(nrow_global==ncol_global,cp_failure_level,routineP,error,failure) - CPPrecondition(matrix%use_sp.EQV.work%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(nrow_global==ncol_global,cp_failure_level,routineP,failure) + CPPrecondition(matrix%use_sp.EQV.work%use_sp,cp_failure_level,routineP,failure) IF (failure) RETURN CALL timeset(routineN,handle) @@ -1092,14 +1067,12 @@ END SUBROUTINE cp_fm_column_scale !> \param matrix_a ... !> \param matrix_inverse ... !> \param det_a ... -!> \param error ... !> \author Florian Schiffmann(02.2007) ! ***************************************************************************** - SUBROUTINE cp_fm_invert(matrix_a,matrix_inverse,det_a,error) + SUBROUTINE cp_fm_invert(matrix_a,matrix_inverse,det_a) TYPE(cp_fm_type), POINTER :: matrix_a, matrix_inverse REAL(KIND=dp), INTENT(OUT), OPTIONAL :: det_a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_invert', & routineP = moduleN//':'//routineN @@ -1126,14 +1099,12 @@ SUBROUTINE cp_fm_invert(matrix_a,matrix_inverse,det_a,error) CALL cp_fm_create(matrix=matrix_lu,& matrix_struct=matrix_a%matrix_struct,& - name="A_lu"//TRIM(ADJUSTL(cp_to_string(1)))//"MATRIX",& - error=error) - CALL cp_fm_to_fm(matrix_a,matrix_lu,error=error) + name="A_lu"//TRIM(ADJUSTL(cp_to_string(1)))//"MATRIX") + CALL cp_fm_to_fm(matrix_a,matrix_lu) CALL cp_fm_create(matrix=matrix_B,& matrix_struct=matrix_a%matrix_struct,& - name="B_mat"//TRIM(ADJUSTL(cp_to_string(1)))//"MATRIX",& - error=error) + name="B_mat"//TRIM(ADJUSTL(cp_to_string(1)))//"MATRIX") a => matrix_lu%local_data n = matrix_lu%matrix_struct%nrow_global ALLOCATE(ipivot(n+matrix_a%matrix_struct%nrow_block)) @@ -1163,9 +1134,9 @@ SUBROUTINE cp_fm_invert(matrix_a,matrix_inverse,det_a,error) alpha=0.0_dp beta=1.0_dp - CALL cp_fm_set_all(matrix_inverse,alpha,beta,error) + CALL cp_fm_set_all(matrix_inverse,alpha,beta) CALL pdgetrs('N',n,n,matrix_lu%local_data,1,1,desca,ipivot,matrix_inverse%local_data,1,1,desca,info) -! CALL cp_fm_set_all(matrix_B,alpha,beta,error) +! CALL cp_fm_set_all(matrix_B,alpha,beta) ! DO iter=1,10 ! CALL pdgerfs('N',n,n,matrix_a%local_data,1,1,desca,matrix_lu%local_data,& ! 1,1,desca,ipivot,matrix_B%local_data,& @@ -1185,11 +1156,11 @@ SUBROUTINE cp_fm_invert(matrix_a,matrix_inverse,det_a,error) #else sign=.TRUE. CALL invert_matrix(matrix_a%local_data,matrix_inverse%local_data,& - eval_error=eps1,error=error) + eval_error=eps1) CALL cp_fm_lu_decompose(matrix_lu,determinant,correct_sign=sign) #endif - CALL cp_fm_release(matrix_lu,error=error) - CALL cp_fm_release(matrix_B,error=error) + CALL cp_fm_release(matrix_lu) + CALL cp_fm_release(matrix_B) DEALLOCATE(ipivot) IF(PRESENT(det_a)) det_a = determinant END SUBROUTINE cp_fm_invert @@ -1198,14 +1169,12 @@ END SUBROUTINE cp_fm_invert !> \brief inverts a triangular matrix !> \param matrix_a ... !> \param uplo_tr ... -!> \param error ... !> \author MI ! ***************************************************************************** - SUBROUTINE cp_fm_triangular_invert(matrix_a,uplo_tr,error) + SUBROUTINE cp_fm_triangular_invert(matrix_a,uplo_tr) TYPE(cp_fm_type), POINTER :: matrix_a CHARACTER, INTENT(IN), OPTIONAL :: uplo_tr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_triangular_invert', & routineP = moduleN//':'//routineN @@ -1255,14 +1224,12 @@ END SUBROUTINE cp_fm_triangular_invert !> \param ncol_fact ... !> \param first_row ... !> \param first_col ... -!> \param error ... !> \author MI ! ***************************************************************************** - SUBROUTINE cp_fm_qr_factorization(matrix_a, matrix_r, nrow_fact, ncol_fact, first_row, first_col, error) + SUBROUTINE cp_fm_qr_factorization(matrix_a, matrix_r, nrow_fact, ncol_fact, first_row, first_col) TYPE(cp_fm_type), POINTER :: matrix_a, matrix_r INTEGER, INTENT(IN), OPTIONAL :: nrow_fact, ncol_fact, & first_row, first_col - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_qr_factorization', & routineP = moduleN//':'//routineN @@ -1296,7 +1263,7 @@ SUBROUTINE cp_fm_qr_factorization(matrix_a, matrix_r, nrow_fact, ncol_fact, firs IF(PRESENT(first_col)) icol = first_col - CPPrecondition(nrow>=ncol,cp_failure_level,routineP,error,failure) + CPPrecondition(nrow>=ncol,cp_failure_level,routineP,failure) ndim = SIZE(a,2) ! ALLOCATE(ipiv(ndim),istat=STAT) ALLOCATE(tau(ndim),STAT=istat) @@ -1325,13 +1292,13 @@ SUBROUTINE cp_fm_qr_factorization(matrix_a, matrix_r, nrow_fact, ncol_fact, firs #endif ALLOCATE(r_mat(ncol,ncol),STAT=istat) - CALL cp_fm_get_submatrix(matrix_a,r_mat,1,1,ncol,ncol,error=error) + CALL cp_fm_get_submatrix(matrix_a,r_mat,1,1,ncol,ncol) DO i = 1,ncol DO j = i+1,ncol r_mat(j,i) = 0.0_dp END DO END DO - CALL cp_fm_set_submatrix(matrix_r,r_mat,1,1,ncol,ncol,error=error) + CALL cp_fm_set_submatrix(matrix_r,r_mat,1,1,ncol,ncol) DEALLOCATE(tau, work, r_mat, STAT=istat) @@ -1345,12 +1312,10 @@ END SUBROUTINE cp_fm_qr_factorization !> pay attention, both matrices are overwritten, a_general contais the result !> \param matrix_a ... !> \param general_a ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE cp_fm_solve(matrix_a,general_a,error) + SUBROUTINE cp_fm_solve(matrix_a,general_a) TYPE(cp_fm_type), POINTER :: matrix_a, general_a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_solve', & routineP = moduleN//':'//routineN @@ -1409,7 +1374,6 @@ SUBROUTINE cp_fm_solve(matrix_a,general_a,error) !> \param beta ... !> \param C_re m x n matrix, real part !> \param C_im m x n matrix, imaginary part -!> \param error ... !> \param b_first_col : the k x n matrix starts at col b_first_col of matrix_b (avoid usage) !> \param a_first_row ... !> \param b_first_row ... @@ -1420,14 +1384,13 @@ SUBROUTINE cp_fm_solve(matrix_a,general_a,error) !> C should have no overlap with A, B ! ***************************************************************************** SUBROUTINE cp_complex_fm_gemm(transa,transb,m,n,k,alpha,A_re,A_im,B_re,B_im,beta,& - C_re,C_im,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + C_re,C_im,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CHARACTER(LEN=1), INTENT(IN) :: transa, transb INTEGER, INTENT(IN) :: m, n, k REAL(KIND=dp), INTENT(IN) :: alpha TYPE(cp_fm_type), POINTER :: A_re, A_im, B_re, B_im REAL(KIND=dp), INTENT(IN) :: beta TYPE(cp_fm_type), POINTER :: C_re, C_im - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, INTENT(IN), OPTIONAL :: b_first_col, a_first_row, & b_first_row, c_first_col, & c_first_row @@ -1440,13 +1403,13 @@ SUBROUTINE cp_complex_fm_gemm(transa,transb,m,n,k,alpha,A_re,A_im,B_re,B_im,beta CALL timeset(routineN,handle) CALL cp_fm_gemm(transa,transb,m,n,k,alpha,A_re,B_re,beta,& - C_re,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + C_re,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CALL cp_fm_gemm(transa,transb,m,n,k,-alpha,A_im,B_im,1.0_dp,& - C_re,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + C_re,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CALL cp_fm_gemm(transa,transb,m,n,k,alpha,A_re,B_im,beta,& - C_im,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + C_im,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CALL cp_fm_gemm(transa,transb,m,n,k,alpha,A_im,B_re,1.0_dp,& - C_im,error,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) + C_im,b_first_col,a_first_row,b_first_row,c_first_col,c_first_row) CALL timestop(handle) diff --git a/src/fm/cp_fm_cholesky.F b/src/fm/cp_fm_cholesky.F index e64948c96d..a384ecb7cb 100644 --- a/src/fm/cp_fm_cholesky.F +++ b/src/fm/cp_fm_cholesky.F @@ -37,18 +37,15 @@ MODULE cp_fm_cholesky !> \param n the number of row (and columns) of the matrix & !> (defaults to the min(size(matrix))) !> \param info_out ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [JVdV] !> 12.2002 updated, added n optional parm [fawzi] !> \author Joost ! ***************************************************************************** - SUBROUTINE cp_fm_cholesky_decompose(matrix,n,info_out,error) + SUBROUTINE cp_fm_cholesky_decompose(matrix,n,info_out) TYPE(cp_fm_type), POINTER :: matrix INTEGER, INTENT(in), OPTIONAL :: n INTEGER, INTENT(out), OPTIONAL :: info_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_cholesky_decompose', & routineP = moduleN//':'//routineN @@ -68,7 +65,7 @@ SUBROUTINE cp_fm_cholesky_decompose(matrix,n,info_out,error) my_n = MIN(matrix%matrix_struct%nrow_global,& matrix%matrix_struct%ncol_global) IF (PRESENT(n)) THEN - CPPrecondition(n<=my_n,cp_failure_level,routineP,error,failure) + CPPrecondition(n<=my_n,cp_failure_level,routineP,failure) my_n=n END IF @@ -97,7 +94,7 @@ SUBROUTINE cp_fm_cholesky_decompose(matrix,n,info_out,error) IF (PRESENT(info_out)) THEN info_out = info ELSE - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -108,16 +105,13 @@ END SUBROUTINE cp_fm_cholesky_decompose !> \brief used to replace the cholesky decomposition by the inverse !> \param matrix the matrix to invert (must be an upper triangular matrix) !> \param n size of the matrix to invert (defaults to the min(size(matrix))) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [JVdV] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_fm_cholesky_invert(matrix,n, error) + SUBROUTINE cp_fm_cholesky_invert(matrix,n) TYPE(cp_fm_type), POINTER :: matrix INTEGER, INTENT(in), OPTIONAL :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN='cp_fm_cholesky_invert',& routineP=moduleN//':'//routineN @@ -137,7 +131,7 @@ SUBROUTINE cp_fm_cholesky_invert(matrix,n, error) my_n = MIN(matrix%matrix_struct%nrow_global,& matrix%matrix_struct%ncol_global) IF (PRESENT(n)) THEN - CPPrecondition(n<=my_n,cp_failure_level,routineP,error,failure) + CPPrecondition(n<=my_n,cp_failure_level,routineP,failure) my_n=n END IF @@ -164,7 +158,7 @@ SUBROUTINE cp_fm_cholesky_invert(matrix,n, error) #endif - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -179,16 +173,13 @@ END SUBROUTINE cp_fm_cholesky_invert !> \param matrix the symmetric matrix A !> \param matrixb the cholesky decomposition of matrix B !> \param itype ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [JVdV] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE cp_fm_cholesky_reduce(matrix,matrixb, itype, error) + SUBROUTINE cp_fm_cholesky_reduce(matrix,matrixb, itype) TYPE(cp_fm_type), POINTER :: matrix, matrixb INTEGER, OPTIONAL :: itype - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN='cp_fm_cholesky_reduce',& routineP=moduleN//':'//routineN @@ -225,14 +216,14 @@ SUBROUTINE cp_fm_cholesky_reduce(matrix,matrixb, itype, error) routineP,& "scale not equal 1 (scale="//cp_to_string(scale)//")"//& CPSourceFileRef,& - error,failure) + failure) #else CALL dsygst(my_itype,'U',n,a(1,1),n,b(1,1),n,info) #endif - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -253,16 +244,13 @@ END SUBROUTINE cp_fm_cholesky_reduce !> \param op ... !> \param pos ... !> \param transa ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa,& - error) + SUBROUTINE cp_fm_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa) TYPE(cp_fm_type), POINTER :: matrix,matrixb,matrixout INTEGER, INTENT(IN) :: neig CHARACTER ( LEN = * ), INTENT ( IN ) :: op CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: pos CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: transa - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN='cp_fm_cholesky_restore',& routineP=moduleN//':'//routineN @@ -292,7 +280,7 @@ SUBROUTINE cp_fm_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa,& cp_failure_level,cp_assertion_failed,routineP,& "wrong argument op"//& CPSourceFileRef,& - error,failure) + failure) IF (PRESENT(pos)) THEN SELECT CASE(pos) @@ -305,7 +293,7 @@ SUBROUTINE cp_fm_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa,& cp_failure_level,cp_assertion_failed,routineP,& "wrong argument pos"//& CPSourceFileRef,& - error,failure) + failure) END SELECT ELSE chol_pos='L' @@ -319,7 +307,7 @@ SUBROUTINE cp_fm_cholesky_restore(matrix,neig,matrixb,matrixout,op,pos,transa,& routineP,& "not the same precision"//& CPSourceFileRef,& - error,failure) + failure) ! notice b is the cholesky guy a => matrix%local_data diff --git a/src/fm/cp_fm_diag.F b/src/fm/cp_fm_diag.F index 37801af1a1..bf85736a6a 100644 --- a/src/fm/cp_fm_diag.F +++ b/src/fm/cp_fm_diag.F @@ -90,14 +90,12 @@ MODULE cp_fm_diag !> \param diag_lib diag_library flag from GLOBAL section in input !> \param switched ... !> \param k_elpa ... -!> \param error ... !> \author MI 11.2013 ! ***************************************************************************** - SUBROUTINE diag_init(diag_lib,switched,k_elpa,error) + SUBROUTINE diag_init(diag_lib,switched,k_elpa) CHARACTER(LEN=*), INTENT(IN) :: diag_lib LOGICAL, INTENT(INOUT) :: switched INTEGER, INTENT(IN) :: k_elpa - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'diag_init', & routineP = moduleN//':'//routineN @@ -156,17 +154,15 @@ END SUBROUTINE diag_init !> \param eigenvectors ... !> \param eigenvalues ... !> \param info ... -!> \param error ... !> \par info If present returns error code and prevents program stops. !> Works currently only for cp_fm_syevd with scalapack. !> Other solvers will end the program regardless of PRESENT(info). ! ***************************************************************************** - SUBROUTINE choose_eigv_solver(matrix,eigenvectors,eigenvalues,info,error) + SUBROUTINE choose_eigv_solver(matrix,eigenvectors,eigenvalues,info) TYPE(cp_fm_type), POINTER :: matrix, eigenvectors REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: eigenvalues INTEGER, INTENT(OUT), OPTIONAL :: info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'choose_eigv_solver', & routineP = moduleN//':'//routineN @@ -181,11 +177,11 @@ SUBROUTINE choose_eigv_solver(matrix,eigenvectors,eigenvalues,info,error) CALL m_memory() IF(diag_type==3) THEN - CALL cp_fm_elpa(matrix,eigenvectors,eigenvalues,error=error) + CALL cp_fm_elpa(matrix,eigenvectors,eigenvalues) ELSE IF(diag_type==2) THEN - CALL cp_fm_syevr(matrix,eigenvectors,eigenvalues,1,nmo,error=error) + CALL cp_fm_syevr(matrix,eigenvectors,eigenvalues,1,nmo) ELSE IF(diag_type==1) THEN - CALL cp_fm_syevd(matrix,eigenvectors,eigenvalues,info=myinfo,error=error) + CALL cp_fm_syevd(matrix,eigenvectors,eigenvalues,info=myinfo) END IF IF (PRESENT(info)) info = myinfo @@ -199,18 +195,16 @@ END SUBROUTINE choose_eigv_solver !> \param eigenvectors ... !> \param eigenvalues ... !> \param info ... -!> \param error ... !> \par matrix is supposed to be in upper triangular form, and overwritten by this routine !> \par info If present returns error code and prevents program stops. !> Works currently only for scalapack. !> Other solvers will end the program regardless of PRESENT(info). ! ***************************************************************************** - SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) + SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info) TYPE(cp_fm_type), POINTER :: matrix, eigenvectors REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: eigenvalues INTEGER, INTENT(OUT), OPTIONAL :: info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_syevd', & routineP = moduleN//':'//routineN @@ -243,7 +237,7 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) n = matrix%matrix_struct%nrow_global ALLOCATE(eig(n), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #if defined(__SCALAPACK) @@ -272,22 +266,22 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) IF (group_distribution(mepos_old)==0) THEN - ! create para_env, might need a proper error, bound to this para_env + ! create para_env, might need a proper bound to this para_env NULLIFY(para_env_new) - CALL cp_para_env_create(para_env_new,subgroup,error=error) + CALL cp_para_env_create(para_env_new,subgroup) ! test a sync CALL mp_sync(para_env_new%group) ! create blacs, should inherit the preferences for the layout and so on, from the higher level NULLIFY(blacs_env_new) - CALL cp_blacs_env_create(blacs_env=blacs_env_new, para_env=para_env_new, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env_new, para_env=para_env_new) ! create new matrix NULLIFY(fm_struct_new) CALL cp_fm_struct_create(fmstruct=fm_struct_new, para_env=para_env_new, context=blacs_env_new,& - nrow_global=n, ncol_global=n, error=error) - CALL cp_fm_create(matrix_new, matrix_struct=fm_struct_new, name="yevd_new_mat", error=error) - CALL cp_fm_create(eigenvectors_new, matrix_struct=fm_struct_new, name="yevd_new_vec", error=error) + nrow_global=n, ncol_global=n) + CALL cp_fm_create(matrix_new, matrix_struct=fm_struct_new, name="yevd_new_mat") + CALL cp_fm_create(eigenvectors_new, matrix_struct=fm_struct_new, name="yevd_new_vec") ! redistribute old CALL pdgemr2d(n,n,matrix%local_data(1,1),1,1,matrix%matrix_struct%descriptor, & @@ -295,7 +289,7 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) matrix%matrix_struct%context%group) ! call scalapack - CALL cp_fm_syevd_base(matrix_new,eigenvectors_new,eig,myinfo,error) + CALL cp_fm_syevd_base(matrix_new,eigenvectors_new,eig,myinfo) ! redistribute results CALL pdgemr2d(n,n,eigenvectors_new%local_data(1,1),1,1,eigenvectors_new%matrix_struct%descriptor, & @@ -303,11 +297,11 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) eigenvectors%matrix_struct%context%group) ! free stuff - CALL cp_fm_struct_release(fm_struct_new,error=error) - CALL cp_fm_release(matrix_new,error=error) - CALL cp_fm_release(eigenvectors_new,error=error) - CALL cp_blacs_env_release(blacs_env_new,error=error) - CALL cp_para_env_release(para_env_new,error=error) + CALL cp_fm_struct_release(fm_struct_new) + CALL cp_fm_release(matrix_new) + CALL cp_fm_release(eigenvectors_new) + CALL cp_blacs_env_release(blacs_env_new) + CALL cp_para_env_release(para_env_new) ELSE ! these tasks must help redistribute (they own part of the data), @@ -334,7 +328,7 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) ELSE - CALL cp_fm_syevd_base(matrix,eigenvectors,eig,myinfo,error) + CALL cp_fm_syevd_base(matrix,eigenvectors,eig,myinfo) ENDIF @@ -348,10 +342,10 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) eig(:) = 0.0_dp ALLOCATE (work(1),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) work(:) = 0.0_dp ALLOCATE (iwork(1),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) iwork(:) = 0 CALL dsyevd('V','U',n,m(1,1),n,eig(1),work(1),lwork,iwork(1),liwork,myinfo) @@ -364,15 +358,15 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) ! Reallocate work arrays and perform diagonalisation lwork = INT(work(1)) DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(work(lwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) liwork = iwork(1) DEALLOCATE (iwork,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(liwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) iwork(:) = 0 CALL dsyevd('V','U',n,m(1,1),n,eig(1),work(1),lwork,iwork(1),liwork,myinfo) @@ -382,12 +376,12 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) "Matrix diagonalization failed") END IF - CALL cp_fm_to_fm(matrix,eigenvectors,error=error) + CALL cp_fm_to_fm(matrix,eigenvectors) DEALLOCATE (iwork,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #endif IF(PRESENT(info)) myinfo = 0 @@ -400,7 +394,7 @@ SUBROUTINE cp_fm_syevd(matrix,eigenvectors,eigenvalues,info,error) END IF DEALLOCATE (eig,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE cp_fm_syevd @@ -411,14 +405,12 @@ END SUBROUTINE cp_fm_syevd !> \param eigenvectors ... !> \param eig ... !> \param info ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_syevd_base(matrix,eigenvectors,eig,info,error) + SUBROUTINE cp_fm_syevd_base(matrix,eigenvectors,eig,info) TYPE(cp_fm_type), POINTER :: matrix, eigenvectors REAL(KIND=dp), DIMENSION(:) :: eig INTEGER, INTENT(OUT) :: info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_syevd_base', & routineP = moduleN//':'//routineN @@ -456,12 +448,12 @@ SUBROUTINE cp_fm_syevd_base(matrix,eigenvectors,eig,info,error) liwork = 7*n + 8*context%num_pe(2) + 2 ALLOCATE(iwork(liwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! work space query lwork = -1 ALLOCATE(work(1),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL pdsyevd('V','U',n,m(1,1),1,1,descm,eig(1),v(1,1),1,1,descv, & work(1),lwork,iwork(1),liwork,info) @@ -475,9 +467,9 @@ SUBROUTINE cp_fm_syevd_base(matrix,eigenvectors,eig,info,error) lwork = NINT(work(1)+100000) ! lwork = NINT(work(1)) DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(work(lwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! Scalapack takes advantage of IEEE754 exceptions for speedup. ! Therefore, we disable floating point traps temporarily. @@ -497,10 +489,10 @@ SUBROUTINE cp_fm_syevd_base(matrix,eigenvectors,eig,info,error) (routineN,moduleN,__LINE__, "Matrix diagonalization failed") DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (iwork,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #endif @@ -517,13 +509,12 @@ END SUBROUTINE cp_fm_syevd_base !> \param eigenvalues ... !> \param neig ... !> \param work_syevx ... -!> \param error ... !> \par matrix is supposed to be in upper triangular form, and overwritten by this routine !> neig is the number of vectors needed (default all) !> work_syevx evec calculation only, is the fraction of the working buffer allowed (1.0 use full buffer) !> reducing this saves time, but might cause the routine to fail ! ***************************************************************************** - SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) + SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx) ! Diagonalise the symmetric n by n matrix using the LAPACK library. @@ -532,7 +523,6 @@ SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) REAL(KIND = dp), OPTIONAL, INTENT(IN) :: work_syevx INTEGER, INTENT(IN), OPTIONAL :: neig REAL(KIND = dp), DIMENSION(:), INTENT(OUT) :: eigenvalues - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = "cp_fm_syevx",& routineP = moduleN//":"//routineN @@ -581,7 +571,7 @@ SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) needs_evecs=PRESENT(eigenvectors) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ionode = logger%para_env%mepos==logger%para_env%source n = matrix%matrix_struct%nrow_global @@ -608,7 +598,7 @@ SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) ALLOCATE (w(n),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) eigenvalues(:) = 0.0_dp #if defined(__SCALAPACK) @@ -646,18 +636,18 @@ SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) liwork = 6*MAX(N,npe+1,4) ALLOCATE (gap(npe),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) gap = 0.0_dp ALLOCATE (iclustr(2*npe),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) iclustr = 0 ALLOCATE (ifail(n),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ifail = 0 ALLOCATE (iwork(liwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (work(lwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! Scalapack takes advantage of IEEE754 exceptions for speedup. ! Therefore, we disable floating point traps temporarily. @@ -699,15 +689,15 @@ SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) ! Release work storage DEALLOCATE (gap,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (iclustr,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (ifail,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (iwork,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #else @@ -728,12 +718,12 @@ SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) liwork = 5*n ALLOCATE (ifail(n),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ifail = 0 ALLOCATE (iwork(liwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (work(lwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) info = 0 CALL dsyevx(job_type,"I","U",n,a(1,1),n,vl,vu,1,neig_local,abstol,m,w,z(1,1),n,work(1),lwork,& @@ -756,16 +746,16 @@ SUBROUTINE cp_fm_syevx(matrix,eigenvectors,eigenvalues,neig,work_syevx,error) ! Release work storage DEALLOCATE (ifail,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (iwork,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #endif eigenvalues(1:neig_local) = w(1:neig_local) DEALLOCATE (w,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -781,18 +771,16 @@ END SUBROUTINE cp_fm_syevx !> \param eigenvalues ... !> \param ilow ... !> \param iup ... -!> \param error ... !> \par matrix is supposed to be in upper triangular form, and overwritten by this routine !> subsets of eigenvalues/vectors can be selected by !> specifying a range of values or a range of indices for the desired eigenvalues. ! ***************************************************************************** - SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) + SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup) TYPE(cp_fm_type), POINTER :: matrix TYPE(cp_fm_type), POINTER, OPTIONAL :: eigenvectors REAL(KIND = dp), DIMENSION(:), INTENT(OUT) :: eigenvalues INTEGER, INTENT(IN), OPTIONAL :: ilow,iup - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = "cp_fm_syevr",& routineP = moduleN//":"//routineN @@ -843,7 +831,7 @@ SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) needs_evecs=PRESENT(eigenvectors) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ionode = logger%para_env%mepos==logger%para_env%source n = matrix%matrix_struct%nrow_global @@ -859,14 +847,14 @@ SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) mypcol=context%mepos(2) ALLOCATE(w(n), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) eigenvalues(:) = 0.0_dp #if defined(__SCALAPACK) IF (matrix%matrix_struct%nrow_block /= matrix%matrix_struct%ncol_block) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF a => matrix%local_data @@ -884,9 +872,9 @@ SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) ! First Call: Determine the needed work_space lwork = -1 ALLOCATE(work(5*n), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(6*n), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #if defined (__SCALAPACK2) CALL pdsyevr(job_type,'I','U',n,a,1,1,desca,vl,vu,ilow_local,iup_local,m,nz,w(1),z,1,1,descz,work,lwork,iwork,liwork,info) #endif @@ -896,12 +884,12 @@ SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) IF(lwork>SIZE(work,1)) THEN DEALLOCATE(work,STAT=istat) ALLOCATE(work(lwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF IF(liwork>SIZE(iwork,1)) THEN DEALLOCATE(iwork,STAT=istat) ALLOCATE(iwork(liwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF !Second call: solve the eigenvalue problem @@ -913,13 +901,13 @@ SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) IF(info>0) THEN WRITE(*,*) 'Processor ', myprow, mypcol, ': Error! INFO code = ', INFO END IF - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) ! Release work storage DEALLOCATE (iwork,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #else @@ -940,13 +928,13 @@ SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) liwork = 5*n ALLOCATE (ifail(n),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ifail = 0 ALLOCATE (iwork(liwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (work(lwork),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! target the most accurate calculation of the eigenvalues abstol = 2.0_dp*dlamch("S") @@ -956,19 +944,19 @@ SUBROUTINE cp_fm_syevr(matrix,eigenvectors,eigenvalues,ilow,iup,error) iwork(1),ifail(1),info) ! Error handling - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) ! Release work storage DEALLOCATE (iwork,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) #endif eigenvalues(ilow_local:iup_local) = w(ilow_local:iup_local) DEALLOCATE (w,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -979,13 +967,11 @@ END SUBROUTINE cp_fm_syevr !> \param matrix ... !> \param eigenvectors ... !> \param eigenvalues ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_elpa(matrix,eigenvectors,eigenvalues,error) + SUBROUTINE cp_fm_elpa(matrix,eigenvectors,eigenvalues) TYPE(cp_fm_type), POINTER :: matrix, eigenvectors REAL(KIND=dp), DIMENSION(:) :: eigenvalues - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_elpa', & routineP = moduleN//':'//routineN @@ -1025,14 +1011,14 @@ SUBROUTINE cp_fm_elpa(matrix,eigenvectors,eigenvalues,error) v => eigenvectors%local_data ! elpa needs the full matrix - CALL cp_fm_upper_to_full(matrix,eigenvectors,error=error) + CALL cp_fm_upper_to_full(matrix,eigenvectors) n_rows = matrix%matrix_struct%local_leading_dimension nblk = matrix%matrix_struct%nrow_block neig = SIZE(eigenvalues,1) ! the full eigenvalues vector is needed ALLOCATE(eval(n),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! Calculate eigenvalues/eigenvectors #if defined (__ELPA) || defined (__ELPA2) @@ -1045,17 +1031,16 @@ SUBROUTINE cp_fm_elpa(matrix,eigenvectors,eigenvalues,error) THIS_REAL_ELPA_KERNEL_API=kernel_type,useQR=.FALSE.) CALL cp_assert(success,cp_failure_level,cp_assertion_failed,& routineP,"ELPA failed to diagonalize a matrix at "//& -CPSourceFileRef,& - error) +CPSourceFileRef) #endif #else - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) #endif eigenvalues(1:neig) = eval(1:neig) DEALLOCATE(eval,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! mpi communicators are freed CALL mp_comm_free(comm_row) @@ -1076,9 +1061,8 @@ END SUBROUTINE cp_fm_elpa !> \param threshold ... !> \param n_dependent ... !> \param verbose ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_power(matrix,work,exponent,threshold,n_dependent,verbose,error) + SUBROUTINE cp_fm_power(matrix,work,exponent,threshold,n_dependent,verbose) ! Raise the real symmetric n by n matrix to the power given by ! the exponent. All eigenvectors with a corresponding eigenvalue lower @@ -1091,7 +1075,6 @@ SUBROUTINE cp_fm_power(matrix,work,exponent,threshold,n_dependent,verbose,error) REAL(KIND = dp), INTENT(IN) :: exponent,threshold INTEGER, INTENT(OUT) :: n_dependent LOGICAL, INTENT(IN), OPTIONAL :: verbose - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_power', & routineP = moduleN//':'//routineN @@ -1130,13 +1113,13 @@ SUBROUTINE cp_fm_power(matrix,work,exponent,threshold,n_dependent,verbose,error) ncol_global = matrix%matrix_struct%ncol_global ALLOCATE (eigenvalues(ncol_global),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) eigenvalues(:) = 0.0_dp ! Compute the eigenvectors and eigenvalues - CALL choose_eigv_solver(matrix,work,eigenvalues,error=error) + CALL choose_eigv_solver(matrix,work,eigenvalues) #if defined(__SCALAPACK) nrow_block = work%matrix_struct%nrow_block @@ -1219,8 +1202,8 @@ SUBROUTINE cp_fm_power(matrix,work,exponent,threshold,n_dependent,verbose,error) END DO #endif - CALL cp_fm_syrk("U","N",ncol_global,1.0_dp,work,1,1,0.0_dp,matrix,error=error) - CALL cp_fm_upper_to_full(matrix,work,error=error) + CALL cp_fm_syrk("U","N",ncol_global,1.0_dp,work,1,1,0.0_dp,matrix) + CALL cp_fm_upper_to_full(matrix,work) ! Print some warnings/notes @@ -1241,7 +1224,7 @@ SUBROUTINE cp_fm_power(matrix,work,exponent,threshold,n_dependent,verbose,error) END IF DEALLOCATE (eigenvalues,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1472,14 +1455,12 @@ END SUBROUTINE cp_fm_block_jacobi !> \param eigenvectors ... !> \param eigenvalues ... !> \param work ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_geeig(amatrix,bmatrix,eigenvectors,eigenvalues,work,error) + SUBROUTINE cp_fm_geeig(amatrix,bmatrix,eigenvectors,eigenvalues,work) TYPE(cp_fm_type), POINTER :: amatrix, bmatrix, eigenvectors REAL(KIND=dp), DIMENSION(:) :: eigenvalues TYPE(cp_fm_type), POINTER :: work - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_geeig', & routineP = moduleN//':'//routineN @@ -1491,20 +1472,20 @@ SUBROUTINE cp_fm_geeig(amatrix,bmatrix,eigenvectors,eigenvalues,work,error) failure = .FALSE. - CALL cp_fm_get_info(amatrix,nrow_global=nao,error=error) + CALL cp_fm_get_info(amatrix,nrow_global=nao) nmo = SIZE(eigenvalues) ! Cholesky decompose S=U(T)U - CALL cp_fm_cholesky_decompose(bmatrix,error=error) + CALL cp_fm_cholesky_decompose(bmatrix) ! Invert to get U^(-1) - CALL cp_fm_triangular_invert(bmatrix,error=error) + CALL cp_fm_triangular_invert(bmatrix) ! Reduce to get U^(-T) * H * U^(-1) - CALL cp_fm_triangular_multiply(bmatrix,amatrix,side="R",error=error) - CALL cp_fm_triangular_multiply(bmatrix,amatrix,transpose_tr=.TRUE.,error=error) + CALL cp_fm_triangular_multiply(bmatrix,amatrix,side="R") + CALL cp_fm_triangular_multiply(bmatrix,amatrix,transpose_tr=.TRUE.) ! Diagonalize CALL choose_eigv_solver(matrix=amatrix,eigenvectors=work,& - eigenvalues=eigenvalues,error=error) + eigenvalues=eigenvalues) ! Restore vectors C = U^(-1) * C* - CALL cp_fm_triangular_multiply(bmatrix,work,error=error) + CALL cp_fm_triangular_multiply(bmatrix,work) CALL cp_fm_to_fm(work,eigenvectors,nmo) CALL timestop(handle) diff --git a/src/fm/cp_fm_pool_types.F b/src/fm/cp_fm_pool_types.F index 61c29d264a..7b0e25617d 100644 --- a/src/fm/cp_fm_pool_types.F +++ b/src/fm/cp_fm_pool_types.F @@ -78,17 +78,13 @@ MODULE cp_fm_pool_types !> \param pool the pool to create !> \param el_struct the structure of the elements that are stored in !> this pool -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fm_pool_create(pool, el_struct,& - error) + SUBROUTINE fm_pool_create(pool, el_struct) TYPE(cp_fm_pool_type), POINTER :: pool TYPE(cp_fm_struct_type), POINTER :: el_struct - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pool_create', & routineP = moduleN//':'//routineN @@ -99,9 +95,9 @@ SUBROUTINE fm_pool_create(pool, el_struct,& failure=.FALSE. ALLOCATE(pool, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pool%el_struct=> el_struct - CALL cp_fm_struct_retain(pool%el_struct,error=error) + CALL cp_fm_struct_retain(pool%el_struct) last_fm_pool_id_nr=last_fm_pool_id_nr+1 pool%id_nr=last_fm_pool_id_nr pool%ref_count=1 @@ -112,15 +108,12 @@ END SUBROUTINE fm_pool_create ! ***************************************************************************** !> \brief retains the pool (see cp2k/doc/ReferenceCounting.html) !> \param pool the pool to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fm_pool_retain(pool,error) + SUBROUTINE fm_pool_retain(pool) TYPE(cp_fm_pool_type), POINTER :: pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pool_retain', & routineP = moduleN//':'//routineN @@ -129,8 +122,8 @@ SUBROUTINE fm_pool_retain(pool,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) pool%ref_count=pool%ref_count+1 END SUBROUTINE fm_pool_retain @@ -138,15 +131,12 @@ END SUBROUTINE fm_pool_retain ! ***************************************************************************** !> \brief deallocates all the cached elements !> \param pool the pool to flush -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fm_pool_flush_cache(pool,error) + SUBROUTINE fm_pool_flush_cache(pool) TYPE(cp_fm_pool_type), POINTER :: pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pool_flush_cache', & routineP = moduleN//':'//routineN @@ -157,28 +147,25 @@ SUBROUTINE fm_pool_flush_cache(pool,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) iterator => pool%cache DO - IF (.NOT.cp_sll_fm_next(iterator,el_att=el_att,error=error)) EXIT - CALL cp_fm_release(el_att,error=error) + IF (.NOT.cp_sll_fm_next(iterator,el_att=el_att)) EXIT + CALL cp_fm_release(el_att) END DO - CALL cp_sll_fm_dealloc(pool%cache,error=error) + CALL cp_sll_fm_dealloc(pool%cache) END SUBROUTINE fm_pool_flush_cache ! ***************************************************************************** !> \brief releases the given pool (see cp2k/doc/ReferenceCounting.html) !> \param pool the pool to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE fm_pool_release(pool,error) + SUBROUTINE fm_pool_release(pool) TYPE(cp_fm_pool_type), POINTER :: pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pool_release', & routineP = moduleN//':'//routineN @@ -189,16 +176,16 @@ SUBROUTINE fm_pool_release(pool,error) failure=.FALSE. IF (ASSOCIATED(pool)) THEN - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) pool%ref_count=pool%ref_count-1 IF (pool%ref_count==0) THEN pool%ref_count=1 - CALL fm_pool_flush_cache(pool,error=error) - CALL cp_fm_struct_release(pool%el_struct,error=error) + CALL fm_pool_flush_cache(pool) + CALL cp_fm_struct_release(pool%el_struct) pool%ref_count=0 DEALLOCATE(pool,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF NULLIFY(pool) @@ -210,18 +197,15 @@ END SUBROUTINE fm_pool_release !> \param element will contain the new element !>\param name the name for the new matrix (optional) !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE fm_pool_create_fm(pool, element,& - name, error) + name) TYPE(cp_fm_pool_type), POINTER :: pool TYPE(cp_fm_type), POINTER :: element CHARACTER(len=*), INTENT(in), OPTIONAL :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pool_create_fm', & routineP = moduleN//':'//routineN @@ -230,15 +214,15 @@ SUBROUTINE fm_pool_create_fm(pool, element,& failure=.FALSE. - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) IF (ASSOCIATED(pool%cache)) THEN - element => cp_sll_fm_get_first_el(pool%cache,error=error) - CALL cp_sll_fm_rm_first_el(pool%cache,error=error) + element => cp_sll_fm_get_first_el(pool%cache) + CALL cp_sll_fm_rm_first_el(pool%cache) ELSE NULLIFY(element) - CALL cp_fm_create(element,matrix_struct=pool%el_struct,error=error) + CALL cp_fm_create(element,matrix_struct=pool%el_struct) END IF IF (PRESENT(name)) THEN @@ -250,16 +234,14 @@ SUBROUTINE fm_pool_create_fm(pool, element,& ! guarantee output unicity? END IF - CPPostcondition(ASSOCIATED(element),cp_failure_level,routineP,error,failure) - CPPostcondition(element%ref_count==1,cp_warning_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(element),cp_failure_level,routineP,failure) + CPPostcondition(element%ref_count==1,cp_warning_level,routineP,failure) END SUBROUTINE fm_pool_create_fm ! ***************************************************************************** !> \brief returns the element to the pool !> \param pool the pool where to cache the element !> \param element the element to give back -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -268,10 +250,9 @@ END SUBROUTINE fm_pool_create_fm !> (it is as if you had called cp_fm_release) !> Accept give_backs of non associated elements? ! ***************************************************************************** - SUBROUTINE fm_pool_give_back_fm(pool, element, error) + SUBROUTINE fm_pool_give_back_fm(pool, element) TYPE(cp_fm_pool_type), POINTER :: pool TYPE(cp_fm_type), POINTER :: element - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pool_give_back_fm', & routineP = moduleN//':'//routineN @@ -280,22 +261,22 @@ SUBROUTINE fm_pool_give_back_fm(pool, element, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(element),cp_warning_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(element),cp_warning_level,routineP,failure) CALL cp_assert(pool%el_struct%id_nr==element%matrix_struct%id_nr,& cp_failure_level, cp_assertion_failed, routineP,& "pool cannot reuse matrixes with another structure "//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) - CPPreconditionNoFail(element%ref_count==1,cp_warning_level,routineP,error) + CPPreconditionNoFail(element%ref_count==1,cp_warning_level,routineP) IF (cp_debug) THEN CALL cp_sll_fm_insert_ordered(pool%cache, el=element,& - insert_equals=.FALSE., did_insert=did_insert, error=error) - CPPostcondition(did_insert,cp_failure_level,routineP,error,failure) + insert_equals=.FALSE., did_insert=did_insert) + CPPostcondition(did_insert,cp_failure_level,routineP,failure) ELSE - CALL cp_sll_fm_insert_el(pool%cache, el=element,error=error) + CALL cp_sll_fm_insert_el(pool%cache, el=element) END IF NULLIFY(element) END SUBROUTINE fm_pool_give_back_fm @@ -303,16 +284,13 @@ END SUBROUTINE fm_pool_give_back_fm ! ***************************************************************************** !> \brief returns the structure of the elements in this pool !> \param pool the pool you are interested in -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 05.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION fm_pool_get_el_struct(pool,error) RESULT(res) +FUNCTION fm_pool_get_el_struct(pool) RESULT(res) TYPE(cp_fm_pool_type), POINTER :: pool - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_fm_struct_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'fm_pool_get_el_struct', & @@ -322,8 +300,8 @@ FUNCTION fm_pool_get_el_struct(pool,error) RESULT(res) failure=.FALSE. - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) res => pool%el_struct END FUNCTION fm_pool_get_el_struct @@ -333,16 +311,13 @@ END FUNCTION fm_pool_get_el_struct !> \brief shallow copy of an array of pools (retains each pool) !> \param source_pools the pools to copy !> \param target_pools will contains the new pools -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE fm_pools_copy(source_pools, target_pools, error) +SUBROUTINE fm_pools_copy(source_pools, target_pools) TYPE(cp_fm_pool_p_type), DIMENSION(:), & POINTER :: source_pools, target_pools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pools_copy', & routineP = moduleN//':'//routineN @@ -352,28 +327,25 @@ SUBROUTINE fm_pools_copy(source_pools, target_pools, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(source_pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(source_pools),cp_failure_level,routineP,failure) ALLOCATE(target_pools(SIZE(source_pools)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(source_pools) target_pools(i)%pool => source_pools(i)%pool - CALL fm_pool_retain(source_pools(i)%pool,error=error) + CALL fm_pool_retain(source_pools(i)%pool) END DO END SUBROUTINE fm_pools_copy ! ***************************************************************************** !> \brief deallocate an array of pools (releasing each pool) !> \param pools the pools to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE fm_pools_dealloc(pools, error) +SUBROUTINE fm_pools_dealloc(pools) TYPE(cp_fm_pool_p_type), DIMENSION(:), & POINTER :: pools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pools_dealloc', & routineP = moduleN//':'//routineN @@ -385,10 +357,10 @@ SUBROUTINE fm_pools_dealloc(pools, error) IF (ASSOCIATED(pools)) THEN DO i=1,SIZE(pools) - CALL fm_pool_release(pools(i)%pool,error=error) + CALL fm_pool_release(pools(i)%pool) END DO DEALLOCATE(pools,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE fm_pools_dealloc @@ -397,20 +369,17 @@ END SUBROUTINE fm_pools_dealloc !> \param pools the pools to create the elements from !> \param elements will contain the vector of elements !> \param name the name for the new matrixes (optional) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE fm_pools_create_fm_vect(pools,elements,& - name,error) + name) TYPE(cp_fm_pool_p_type), DIMENSION(:), & POINTER :: pools TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: elements CHARACTER(len=*), INTENT(in), OPTIONAL :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pools_create_fm_vect', & routineP = moduleN//':'//routineN @@ -422,19 +391,17 @@ SUBROUTINE fm_pools_create_fm_vect(pools,elements,& failure=.FALSE. NULLIFY(pool) - CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,failure) ALLOCATE(elements(SIZE(pools)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(pools) NULLIFY(elements(i)%matrix) pool => pools(i)%pool IF (PRESENT(name)) THEN CALL fm_pool_create_fm(pool,elements(i)%matrix,& - name=name//"-"//ADJUSTL(cp_to_string(i)),& - error=error) + name=name//"-"//ADJUSTL(cp_to_string(i))) ELSE - CALL fm_pool_create_fm(pool,elements(i)%matrix,& - error=error) + CALL fm_pool_create_fm(pool,elements(i)%matrix) END IF END DO @@ -446,20 +413,17 @@ END SUBROUTINE fm_pools_create_fm_vect !> (like cp_fm_vect_dealloc) !> \param pools the pool where to give back the vector !> \param elements the vector of elements to give back -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> accept unassociated vect? ! ***************************************************************************** -SUBROUTINE fm_pools_give_back_fm_vect(pools,elements,error) +SUBROUTINE fm_pools_give_back_fm_vect(pools,elements) TYPE(cp_fm_pool_p_type), DIMENSION(:), & POINTER :: pools TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: elements - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fm_pools_give_back_fm_vect', & routineP = moduleN//':'//routineN @@ -469,15 +433,15 @@ SUBROUTINE fm_pools_give_back_fm_vect(pools,elements,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elements),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(pools)==SIZE(elements),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elements),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(pools)==SIZE(elements),cp_failure_level,routineP,failure) DO i=1,SIZE(pools) CALL fm_pool_give_back_fm(pools(i)%pool,& - elements(i)%matrix,error=error) + elements(i)%matrix) END DO DEALLOCATE(elements, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(elements) END SUBROUTINE fm_pools_give_back_fm_vect diff --git a/src/fm/cp_fm_struct.F b/src/fm/cp_fm_struct.F index c0f675db83..58684c596d 100644 --- a/src/fm/cp_fm_struct.F +++ b/src/fm/cp_fm_struct.F @@ -115,15 +115,13 @@ MODULE cp_fm_struct !> \param template_fmstruct a matrix structure where to take the default values !> \param square_blocks ... !> \param force_block ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& ncol_global, nrow_block, ncol_block, descriptor, first_p_pos, & - local_leading_dimension, template_fmstruct, square_blocks, force_block, error) + local_leading_dimension, template_fmstruct, square_blocks, force_block) TYPE(cp_fm_struct_type), POINTER :: fmstruct TYPE(cp_para_env_type), POINTER, OPTIONAL :: para_env @@ -136,7 +134,6 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& TYPE(cp_fm_struct_type), POINTER, OPTIONAL :: template_fmstruct LOGICAL, OPTIONAL, INTENT(in) :: square_blocks LOGICAL, OPTIONAL, INTENT(in) :: force_block - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN='cp_fm_struct_create',& routineP=moduleN//':'//routineN @@ -155,20 +152,19 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& #if defined(__parallel) && ! defined(__SCALAPACK) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"full matrixes need scalapack for parallel runs "//& -CPSourceFileRef,& - error) +CPSourceFileRef) #endif ALLOCATE(fmstruct,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fmstruct%nrow_block=optimal_blacs_row_block_size fmstruct%ncol_block=optimal_blacs_col_block_size IF (.NOT.PRESENT(template_fmstruct)) THEN - CPPrecondition(PRESENT(context),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(nrow_global),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(ncol_global),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(context),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(nrow_global),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(ncol_global),cp_failure_level,routineP,failure) fmstruct %local_leading_dimension = 1 ELSE fmstruct%context => template_fmstruct%context @@ -191,8 +187,8 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& fmstruct%para_env => context%para_env END IF IF (PRESENT(para_env)) fmstruct%para_env => para_env - CALL cp_blacs_env_retain(fmstruct%context,error=error) - CALL cp_para_env_retain(fmstruct%para_env,error=error) + CALL cp_blacs_env_retain(fmstruct%context) + CALL cp_para_env_retain(fmstruct%para_env) IF (PRESENT(nrow_global)) fmstruct%nrow_global=nrow_global IF (PRESENT(ncol_global)) fmstruct%ncol_global=ncol_global @@ -225,7 +221,7 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& ALLOCATE(fmstruct%nrow_locals(0:(fmstruct%context%num_pe(1)-1)),& fmstruct%ncol_locals(0:(fmstruct%context%num_pe(2)-1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (.NOT.PRESENT(template_fmstruct)) & fmstruct%first_p_pos=(/0,0/) IF (PRESENT(first_p_pos)) fmstruct%first_p_pos=first_p_pos @@ -249,7 +245,7 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& IF (SUM(fmstruct%ncol_locals).NE.fmstruct%ncol_global .OR. SUM(fmstruct%nrow_locals).NE.fmstruct%nrow_global) THEN ! try to collect some output if this is going to happen again ! this seems to trigger on blanc, but should really never happen - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iunit=cp_logger_get_default_unit_nr(logger,local=.TRUE.) WRITE(iunit,*) "mepos",fmstruct%context%mepos(1:2),"numpe",fmstruct%context%num_pe(1:2) WRITE(iunit,*) "ncol_global",fmstruct%ncol_global @@ -262,13 +258,11 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& CALL cp_assert(SUM(fmstruct%ncol_locals).EQ.fmstruct%ncol_global,& cp_failure_level,cp_assertion_failed,routineP,& "sum of local cols not equal global cols"//& -CPSourceFileRef,& - error) +CPSourceFileRef) CALL cp_assert(SUM(fmstruct%nrow_locals).EQ.fmstruct%nrow_global,& cp_failure_level,cp_assertion_failed,routineP,& "sum of local row not equal global rows"//& -CPSourceFileRef,& - error) +CPSourceFileRef) #else ! block = full matrix fmstruct%nrow_block=fmstruct%nrow_global @@ -286,7 +280,7 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& cp_to_string(local_leading_dimension)//"<"//& cp_to_string(fmstruct%local_leading_dimension)//")"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) fmstruct%local_leading_dimension=local_leading_dimension END IF @@ -306,7 +300,7 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,& fmstruct%ncol_block,fmstruct%first_p_pos(1),& fmstruct%first_p_pos(2),fmstruct%context%group,& fmstruct%local_leading_dimension,stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) #endif END IF END SUBROUTINE cp_fm_struct_create @@ -314,15 +308,12 @@ END SUBROUTINE cp_fm_struct_create ! ***************************************************************************** !> \brief retains a full matrix structure !> \param fmstruct the structure to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_fm_struct_retain(fmstruct,error) +SUBROUTINE cp_fm_struct_retain(fmstruct) TYPE(cp_fm_struct_type), POINTER :: fmstruct - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_struct_retain', & routineP = moduleN//':'//routineN @@ -331,23 +322,20 @@ SUBROUTINE cp_fm_struct_retain(fmstruct,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(fmstruct),cp_failure_level,routineP,error,failure) - CPPrecondition(fmstruct%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fmstruct),cp_failure_level,routineP,failure) + CPPrecondition(fmstruct%ref_count>0,cp_failure_level,routineP,failure) fmstruct%ref_count=fmstruct%ref_count+1 END SUBROUTINE cp_fm_struct_retain ! ***************************************************************************** !> \brief releases a full matrix structure !> \param fmstruct the structure to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_fm_struct_release(fmstruct,error) +SUBROUTINE cp_fm_struct_release(fmstruct) TYPE(cp_fm_struct_type), POINTER :: fmstruct - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_struct_release', & routineP = moduleN//':'//routineN @@ -358,29 +346,29 @@ SUBROUTINE cp_fm_struct_release(fmstruct,error) failure=.FALSE. IF (ASSOCIATED(fmstruct)) THEN - CPPrecondition(fmstruct%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(fmstruct%ref_count>0,cp_failure_level,routineP,failure) fmstruct%ref_count=fmstruct%ref_count-1 IF (fmstruct%ref_count<1) THEN - CALL cp_blacs_env_release(fmstruct%context,error=error) - CALL cp_para_env_release(fmstruct%para_env,error=error) + CALL cp_blacs_env_release(fmstruct%context) + CALL cp_para_env_release(fmstruct%para_env) IF (ASSOCIATED(fmstruct%row_indices)) THEN DEALLOCATE(fmstruct%row_indices,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ENDIF IF (ASSOCIATED(fmstruct%col_indices)) THEN DEALLOCATE(fmstruct%col_indices,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(fmstruct%nrow_locals)) THEN DEALLOCATE(fmstruct%nrow_locals,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(fmstruct%ncol_locals)) THEN DEALLOCATE(fmstruct%ncol_locals,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF DEALLOCATE(fmstruct, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF NULLIFY(fmstruct) @@ -391,16 +379,13 @@ END SUBROUTINE cp_fm_struct_release !> otherwise. !> \param fmstruct1 one of the full matrix structures to compare !> \param fmstruct2 the second of the full matrix structures to compare -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_fm_struct_equivalent(fmstruct1,fmstruct2,error) RESULT(res) +FUNCTION cp_fm_struct_equivalent(fmstruct1,fmstruct2) RESULT(res) TYPE(cp_fm_struct_type), POINTER :: fmstruct1, fmstruct2 - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_struct_equivalent', & @@ -411,10 +396,10 @@ FUNCTION cp_fm_struct_equivalent(fmstruct1,fmstruct2,error) RESULT(res) failure=.FALSE. - CPPrecondition(ASSOCIATED(fmstruct1),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(fmstruct2),cp_failure_level,routineP,error,failure) - CPPrecondition(fmstruct1%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(fmstruct2%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fmstruct1),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(fmstruct2),cp_failure_level,routineP,failure) + CPPrecondition(fmstruct1%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(fmstruct2%ref_count>0,cp_failure_level,routineP,failure) IF (fmstruct1%id_nr==fmstruct2%id_nr) THEN res=.TRUE. ELSE @@ -434,17 +419,14 @@ END FUNCTION cp_fm_struct_equivalent !> \param fmstruct the structure to print !> \param unit_nr the number of the unit where to write the description !> \param long_description ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_fm_struct_write(fmstruct, unit_nr, long_description,error) +SUBROUTINE cp_fm_struct_write(fmstruct, unit_nr, long_description) TYPE(cp_fm_struct_type), POINTER :: fmstruct INTEGER, INTENT(in) :: unit_nr LOGICAL, INTENT(in), OPTIONAL :: long_description - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_struct_write', & routineP = moduleN//':'//routineN @@ -460,7 +442,7 @@ SUBROUTINE cp_fm_struct_write(fmstruct, unit_nr, long_description,error) WRITE (unit=unit_nr,& fmt="(':{ id_nr=',i10,', ref_count=',i10,',')",& iostat=iostat) fmstruct%id_nr, fmstruct%ref_count - CPPostcondition(iostat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(iostat==0,cp_warning_level,routineP,failure) WRITE (unit=unit_nr,fmt="(' nrow_global=',i8,', ncol_global=',i8,',')",& iostat=iostat) fmstruct%nrow_global, fmstruct%ncol_global WRITE (unit=unit_nr,fmt="(' nrow_block=',i8,', ncol_block=',i8,',')",& @@ -516,7 +498,7 @@ SUBROUTINE cp_fm_struct_write(fmstruct, unit_nr, long_description,error) IF (ASSOCIATED(fmstruct%context)) THEN IF (l_desc) THEN WRITE (unit=unit_nr,fmt="(a)",iostat=iostat) " context=" - CALL cp_blacs_env_write(fmstruct%context,unit_nr,error=error) + CALL cp_blacs_env_write(fmstruct%context,unit_nr) ELSE WRITE (unit=unit_nr,fmt="(a,i10)",iostat=iostat) " context%group=",& fmstruct%context%group @@ -527,7 +509,7 @@ SUBROUTINE cp_fm_struct_write(fmstruct, unit_nr, long_description,error) IF (ASSOCIATED(fmstruct%para_env)) THEN IF (l_desc) THEN WRITE (unit=unit_nr,fmt="(a)",iostat=iostat) " para_env=" - CALL cp_para_env_write(fmstruct%para_env,unit_nr,error=error) + CALL cp_para_env_write(fmstruct%para_env,unit_nr) ELSE WRITE (unit=unit_nr,fmt="(a,i10)",iostat=iostat) & " para_env%group=",fmstruct%para_env%group @@ -562,9 +544,6 @@ END SUBROUTINE cp_fm_struct_write !> \param nrow_locals ... !> \param ncol_locals ... !> \param local_leading_dimension ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> see cp_fm_struct_type attributes for the other arguments !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -573,7 +552,7 @@ SUBROUTINE cp_fm_struct_get(fmstruct, para_env, context,& descriptor, ncol_block, nrow_block, nrow_global,& ncol_global, id_nr, ref_count, first_p_pos, row_indices,& col_indices, nrow_local, ncol_local, nrow_locals, ncol_locals,& - local_leading_dimension, error) + local_leading_dimension) TYPE(cp_fm_struct_type), POINTER :: fmstruct TYPE(cp_para_env_type), POINTER, OPTIONAL :: para_env TYPE(cp_blacs_env_type), POINTER, OPTIONAL :: context @@ -584,7 +563,6 @@ SUBROUTINE cp_fm_struct_get(fmstruct, para_env, context,& INTEGER, DIMENSION(2), INTENT(out), OPTIONAL :: first_p_pos INTEGER, DIMENSION(:), POINTER, OPTIONAL :: row_indices, col_indices,& nrow_locals, ncol_locals - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: failure CHARACTER(len=*), PARAMETER :: routineN='cp_fm_struct_get',& @@ -596,8 +574,8 @@ SUBROUTINE cp_fm_struct_get(fmstruct, para_env, context,& failure=.FALSE. - CPPrecondition(ASSOCIATED(fmstruct),cp_failure_level,routineP,error,failure) - CPPrecondition(fmstruct%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fmstruct),cp_failure_level,routineP,failure) + CPPrecondition(fmstruct%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(para_env)) para_env => fmstruct%para_env IF (PRESENT(context)) context => fmstruct%context IF (PRESENT(descriptor)) descriptor = fmstruct%descriptor @@ -627,7 +605,7 @@ SUBROUTINE cp_fm_struct_get(fmstruct, para_env, context,& ! the max should go away ALLOCATE(fmstruct%row_indices & (MAX(fmstruct%nrow_locals(myprow),1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices => fmstruct%row_indices #ifdef __SCALAPACK DO i=1,SIZE(row_indices) @@ -649,7 +627,7 @@ SUBROUTINE cp_fm_struct_get(fmstruct, para_env, context,& IF (.NOT.ASSOCIATED(col_indices)) THEN ALLOCATE(fmstruct%col_indices & (MAX(fmstruct%ncol_locals(mypcol),1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices => fmstruct%col_indices #ifdef __SCALAPACK DO i=1,SIZE(col_indices) @@ -677,17 +655,14 @@ END SUBROUTINE cp_fm_struct_get !> \param context ... !> \param col in which direction the matrix should be enlarged !> \param row in which direction the matrix should be enlarged -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2009 created [fschiff] !> \author Florian Schiffmann ! ***************************************************************************** -SUBROUTINE cp_fm_struct_double(fmstruct,struct,context,col,row,error) +SUBROUTINE cp_fm_struct_double(fmstruct,struct,context,col,row) TYPE(cp_fm_struct_type), POINTER :: fmstruct, struct TYPE(cp_blacs_env_type), POINTER :: context LOGICAL :: col, row - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_struct_double', & routineP = moduleN//':'//routineN @@ -698,7 +673,7 @@ SUBROUTINE cp_fm_struct_double(fmstruct,struct,context,col,row,error) CALL cp_fm_struct_get(struct, nrow_global=nrow_global,& ncol_global=ncol_global, nrow_block=nrow_block, & - ncol_block=ncol_block, error=error) + ncol_block=ncol_block) newdim_row=nrow_global newdim_col=ncol_global nprocs_row=context%num_pe(1) @@ -735,8 +710,7 @@ SUBROUTINE cp_fm_struct_double(fmstruct,struct,context,col,row,error) nrow_global=newdim_row,& ncol_global=newdim_col,& ncol_block=ncol_block,& - nrow_block=nrow_block,& - error=error) + nrow_block=nrow_block) END SUBROUTINE cp_fm_struct_double ! ***************************************************************************** diff --git a/src/fm/cp_fm_types.F b/src/fm/cp_fm_types.F index 8c69878e35..6e8b1b57c9 100644 --- a/src/fm/cp_fm_types.F +++ b/src/fm/cp_fm_types.F @@ -139,20 +139,17 @@ MODULE cp_fm_types !> \param matrix_struct the structure of matrix !> \param name ... !> \param use_sp ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> preferred allocation routine ! ***************************************************************************** - SUBROUTINE cp_fm_create(matrix,matrix_struct,name,use_sp,error) + SUBROUTINE cp_fm_create(matrix,matrix_struct,name,use_sp) TYPE(cp_fm_type), POINTER :: matrix TYPE(cp_fm_struct_type), POINTER :: matrix_struct CHARACTER(len=*), INTENT(in), OPTIONAL :: name LOGICAL, INTENT(in), OPTIONAL :: use_sp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_create', & routineP = moduleN//':'//routineN @@ -169,16 +166,15 @@ SUBROUTINE cp_fm_create(matrix,matrix_struct,name,use_sp,error) #if defined(__parallel) && ! defined(__SCALAPACK) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"full matrixes need scalapack for parallel runs "//& -CPSourceFileRef,& - error) +CPSourceFileRef) #endif - CPPrecondition(ASSOCIATED(matrix_struct),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_struct),cp_failure_level,routineP,failure) ALLOCATE(matrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) context => matrix_struct%context matrix%matrix_struct => matrix_struct - CALL cp_fm_struct_retain(matrix%matrix_struct,error=error) + CALL cp_fm_struct_retain(matrix%matrix_struct) last_fm_id_nr=last_fm_id_nr+1 matrix%id_nr=last_fm_id_nr matrix%ref_count=1 @@ -199,10 +195,10 @@ SUBROUTINE cp_fm_create(matrix,matrix_struct,name,use_sp,error) ncol_local=MAX(1,matrix_struct%ncol_locals(context%mepos(2))) IF(matrix%use_sp) THEN ALLOCATE(matrix%local_data_sp(nrow_local,ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(matrix%local_data(nrow_local,ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ! JVDV we should remove this, as it is up to the user to zero afterwards @@ -225,15 +221,12 @@ END SUBROUTINE cp_fm_create ! ***************************************************************************** !> \brief retains a full matrix !> \param matrix the matrix to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_fm_retain(matrix,error) + SUBROUTINE cp_fm_retain(matrix) TYPE(cp_fm_type), POINTER :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_retain', & routineP = moduleN//':'//routineN @@ -242,8 +235,8 @@ SUBROUTINE cp_fm_retain(matrix,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) - CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,failure) + CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,failure) matrix%ref_count=matrix%ref_count+1 END SUBROUTINE cp_fm_retain @@ -251,15 +244,12 @@ END SUBROUTINE cp_fm_retain ! ***************************************************************************** !> \brief releases a full matrix !> \param matrix the matrix to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_fm_release(matrix,error) + SUBROUTINE cp_fm_release(matrix) TYPE(cp_fm_type), POINTER :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_release', & routineP = moduleN//':'//routineN @@ -272,21 +262,21 @@ SUBROUTINE cp_fm_release(matrix,error) CALL timeset(routineN,handle) IF (ASSOCIATED(matrix)) THEN - CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,failure) matrix%ref_count=matrix%ref_count-1 IF (matrix%ref_count<1) THEN IF (ASSOCIATED(matrix%local_data)) THEN DEALLOCATE(matrix%local_data,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(matrix%local_data_sp)) THEN DEALLOCATE(matrix%local_data_sp,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF matrix%name="" - CALL cp_fm_struct_release(matrix%matrix_struct,error=error) + CALL cp_fm_struct_release(matrix%matrix_struct) DEALLOCATE(matrix,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF NULLIFY(matrix) @@ -300,15 +290,13 @@ END SUBROUTINE cp_fm_release !> \param matrix : to be initialized !> \param ncol : numbers of cols to fill !> \param start_col : starting at coll number -!> \param error ... !> \author Joost VandeVondele !> \note !> the value of a_ij is independent of the number of cpus ! ***************************************************************************** - SUBROUTINE cp_fm_init_random(matrix,ncol,start_col,error) + SUBROUTINE cp_fm_init_random(matrix,ncol,start_col) TYPE(cp_fm_type), POINTER :: matrix INTEGER, INTENT(IN), OPTIONAL :: ncol, start_col - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_init_random', & routineP = moduleN//':'//routineN @@ -337,14 +325,14 @@ SUBROUTINE cp_fm_init_random(matrix,ncol,start_col,error) NULLIFY(rng) CALL create_rng_stream(rng,"cp_fm_init_random_stream",distribution_type=UNIFORM, & - extended_precision=.TRUE.,seed=seed,error=error) + extended_precision=.TRUE.,seed=seed) - CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,failure) CALL cp_fm_get_info(matrix,nrow_global=nrow_global,ncol_global=ncol_global, & nrow_local=nrow_local,ncol_local=ncol_local,& local_data=local_data,& - row_indices=row_indices, col_indices=col_indices, error=error) + row_indices=row_indices, col_indices=col_indices) my_start_col = 1 IF (PRESENT(start_col)) my_start_col=start_col @@ -354,7 +342,7 @@ SUBROUTINE cp_fm_init_random(matrix,ncol,start_col,error) CALL cp_assert(ncol_global>=(my_start_col+my_ncol-1),& cp_failure_level,cp_assertion_failed,routineP,& "ncol_global>=(my_start_col+my_ncol-1)",& - error,failure) + failure) ALLOCATE(buff(nrow_global)) @@ -363,13 +351,13 @@ SUBROUTINE cp_fm_init_random(matrix,ncol,start_col,error) ! following this, we fill the full buff with random numbers, and pick those we need icol_global=0 DO icol_local=1,ncol_local - CPPrecondition(col_indices(icol_local)>icol_global,cp_failure_level,routineP,error,failure) + CPPrecondition(col_indices(icol_local)>icol_global,cp_failure_level,routineP,failure) DO - CALL reset_to_next_rng_substream(rng,error=error) + CALL reset_to_next_rng_substream(rng) icol_global=icol_global+1 IF (icol_global==col_indices(icol_local)) EXIT ENDDO - CALL random_numbers(buff,rng,error) + CALL random_numbers(buff,rng) DO irow_local=1,nrow_local local_data(irow_local,icol_local)=buff(row_indices(irow_local)) ENDDO @@ -378,8 +366,8 @@ SUBROUTINE cp_fm_init_random(matrix,ncol,start_col,error) DEALLOCATE(buff) ! store seed before deletion (unclear if this is the proper seed) - CALL get_rng_stream(rng,ig=seed,error=error) - CALL delete_rng_stream(rng,error) + CALL get_rng_stream(rng,ig=seed) + CALL delete_rng_stream(rng) CALL timestop(handle) @@ -391,17 +379,15 @@ END SUBROUTINE cp_fm_init_random !> \param matrix input matrix !> \param alpha scalar used to set all elements of the matrix !> \param beta scalar used to set diagonal of the matrix -!> \param error ... !> \note !> can be used to zero a matrix !> can be used to create a unit matrix (I-matrix) alpha=0.0_dp beta=1.0_dp ! ***************************************************************************** - SUBROUTINE cp_fm_set_all(matrix,alpha,beta,error) + SUBROUTINE cp_fm_set_all(matrix,alpha,beta) TYPE(cp_fm_type), POINTER :: matrix REAL(KIND=dp), INTENT(IN) :: alpha REAL(KIND=dp), INTENT(IN), OPTIONAL :: beta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_set_all', & routineP = moduleN//':'//routineN @@ -422,10 +408,10 @@ SUBROUTINE cp_fm_set_all(matrix,alpha,beta,error) ENDIF IF (PRESENT(beta)) THEN - CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,failure) n = MIN(matrix%matrix_struct%nrow_global,matrix%matrix_struct%ncol_global) DO i=1,n - CALL cp_fm_set_element(matrix,i,i,beta,error=error) + CALL cp_fm_set_element(matrix,i,i,beta) END DO END IF @@ -437,16 +423,14 @@ END SUBROUTINE cp_fm_set_all !> \brief returns the diagonal elements of a fm !> \param matrix ... !> \param diag ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_get_diag(matrix,diag,error) + SUBROUTINE cp_fm_get_diag(matrix,diag) IMPLICIT NONE ! arguments TYPE(cp_fm_type), POINTER :: matrix REAL(KIND = dp), DIMENSION(:), INTENT(OUT) :: diag - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_get_diag', & routineP = moduleN//':'//routineN @@ -466,7 +450,7 @@ SUBROUTINE cp_fm_get_diag(matrix,diag,error) failure = .FALSE. - CALL cp_fm_get_info(matrix,nrow_global=nrow_global,error=error) + CALL cp_fm_get_info(matrix,nrow_global=nrow_global) #if defined(__SCALAPACK) diag=0.0_dp @@ -579,16 +563,14 @@ END SUBROUTINE cp_fm_get_element !> \param irow_global ... !> \param icol_global ... !> \param alpha ... -!> \param error ... !> \note !> we expect all cpus to have the same arguments in the call to this function !> (otherwise one should use local_data tricks) ! ***************************************************************************** - SUBROUTINE cp_fm_set_element(matrix,irow_global,icol_global,alpha,error) + SUBROUTINE cp_fm_set_element(matrix,irow_global,icol_global,alpha) TYPE(cp_fm_type), POINTER :: matrix INTEGER, INTENT(IN) :: irow_global, icol_global REAL(KIND=dp), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_set_element', & routineP = moduleN//':'//routineN @@ -611,7 +593,7 @@ SUBROUTINE cp_fm_set_element(matrix,irow_global,icol_global,alpha,error) nprow = context%num_pe(1) npcol = context%num_pe(2) - CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,failure) #if defined(__SCALAPACK) @@ -651,8 +633,6 @@ END SUBROUTINE cp_fm_set_element !> \param transpose if new_values should be transposed: if true !> op(new_values)=new_values^T, else op(new_values)=new_values !> (defaults to false) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created borrowing from Joost's blacs_replicated_copy [fawzi] !> \author Fawzi Mohamed @@ -661,7 +641,7 @@ END SUBROUTINE cp_fm_set_element !> the new_values need to be valid on all cpus ! ***************************************************************************** SUBROUTINE cp_fm_set_submatrix(fm,new_values,start_row,& - start_col, n_rows, n_cols, alpha, beta, transpose, error) + start_col, n_rows, n_cols, alpha, beta, transpose) TYPE(cp_fm_type), POINTER :: fm REAL(KIND=dp), DIMENSION(:, :), & INTENT(in) :: new_values @@ -669,7 +649,6 @@ SUBROUTINE cp_fm_set_submatrix(fm,new_values,start_row,& n_cols REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta LOGICAL, INTENT(in), OPTIONAL :: transpose - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_set_submatrix', & routineP = moduleN//':'//routineN @@ -687,10 +666,10 @@ SUBROUTINE cp_fm_set_submatrix(fm,new_values,start_row,& failure=.FALSE. - CPPrecondition(ASSOCIATED(fm),cp_failure_level,routineP,error,failure) - CPPrecondition(fm%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fm),cp_failure_level,routineP,failure) + CPPrecondition(fm%ref_count>0,cp_failure_level,routineP,failure) - CPPrecondition(.NOT.fm%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.fm%use_sp,cp_failure_level,routineP,failure) IF (PRESENT(alpha)) al=alpha IF (PRESENT(beta)) be=beta @@ -713,7 +692,7 @@ SUBROUTINE cp_fm_set_submatrix(fm,new_values,start_row,& nrow_global=nrow_global,ncol_global=ncol_global,& nrow_block =nrow_block ,ncol_block =ncol_block ,& nrow_local =nrow_local ,ncol_local =ncol_local ,& - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) IF (al==1.0.AND.be==0.0) THEN DO j=1,ncol_local @@ -794,8 +773,6 @@ END SUBROUTINE cp_fm_set_submatrix !> \param transpose if target_m should be transposed: if true !> op(target_m)=target_m^T, else op(target_m)=target_m !> (defaults to false) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created borrowing from Joost's blacs_replicated_copy [fawzi] !> \author Fawzi Mohamed @@ -805,14 +782,13 @@ END SUBROUTINE cp_fm_set_submatrix !> the target_m is replicated and valid on all cpus ! ***************************************************************************** SUBROUTINE cp_fm_get_submatrix(fm,target_m, start_row,& - start_col, n_rows, n_cols, transpose, error) + start_col, n_rows, n_cols, transpose) TYPE(cp_fm_type), POINTER :: fm REAL(KIND=dp), DIMENSION(:, :), & INTENT(out) :: target_m INTEGER, INTENT(in), OPTIONAL :: start_row, start_col, n_rows, & n_cols LOGICAL, INTENT(in), OPTIONAL :: transpose - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_get_submatrix', & routineP = moduleN//':'//routineN @@ -829,10 +805,10 @@ SUBROUTINE cp_fm_get_submatrix(fm,target_m, start_row,& i0=1; j0=1; tr_a=.FALSE. failure=.FALSE. - CPPrecondition(ASSOCIATED(fm),cp_failure_level,routineP,error,failure) - CPPrecondition(fm%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fm),cp_failure_level,routineP,failure) + CPPrecondition(fm%ref_count>0,cp_failure_level,routineP,failure) - CPPrecondition(.NOT.fm%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.fm%use_sp,cp_failure_level,routineP,failure) IF (PRESENT(start_row)) i0=start_row IF (PRESENT(start_col)) j0=start_col @@ -860,7 +836,7 @@ SUBROUTINE cp_fm_get_submatrix(fm,target_m, start_row,& CALL cp_fm_get_info(matrix=fm, & nrow_global=nrow_global,ncol_global=ncol_global, & nrow_local =nrow_local ,ncol_local =ncol_local , & - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) DO j=1,ncol_local this_col=col_indices(j)-j0+1 @@ -919,7 +895,6 @@ END SUBROUTINE cp_fm_get_submatrix !> \param ncol_locals ... !> \param matrix_struct ... !> \param para_env ... -!> \param error ... !> \note !> see also cp_fm_struct for explaination !> - nrow_local, ncol_local, row_indices, col_indices, local_data are hooks for efficient @@ -928,7 +903,7 @@ END SUBROUTINE cp_fm_get_submatrix SUBROUTINE cp_fm_get_info(matrix,name,nrow_global,ncol_global,& nrow_block,ncol_block,nrow_local,ncol_local,& row_indices,col_indices,local_data,context,& - nrow_locals, ncol_locals, matrix_struct,para_env,error) + nrow_locals, ncol_locals, matrix_struct,para_env) TYPE(cp_fm_type), POINTER :: matrix CHARACTER(LEN=*), OPTIONAL, INTENT(OUT) :: name @@ -940,7 +915,6 @@ SUBROUTINE cp_fm_get_info(matrix,name,nrow_global,ncol_global,& TYPE(cp_para_env_type), POINTER, OPTIONAL :: para_env TYPE(cp_blacs_env_type), POINTER, OPTIONAL :: context TYPE(cp_fm_struct_type),POINTER,OPTIONAL :: matrix_struct - TYPE(cp_error_type),INTENT(inout):: error REAL(KIND = dp), DIMENSION(:,:),POINTER, OPTIONAL :: local_data CHARACTER(len=*), PARAMETER :: routineN='cp_fm_get_info',& @@ -954,12 +928,10 @@ SUBROUTINE cp_fm_get_info(matrix,name,nrow_global,ncol_global,& IF (PRESENT(matrix_struct)) matrix_struct => matrix%matrix_struct IF (PRESENT(local_data)) local_data => matrix%local_data ! not hiding things anymore :-( IF (PRESENT(row_indices)) THEN - CALL cp_fm_struct_get(matrix%matrix_struct, row_indices=row_indices,& - error=error) + CALL cp_fm_struct_get(matrix%matrix_struct, row_indices=row_indices) ENDIF IF (PRESENT(col_indices)) THEN - CALL cp_fm_struct_get(matrix%matrix_struct, col_indices=col_indices,& - error=error) + CALL cp_fm_struct_get(matrix%matrix_struct, col_indices=col_indices) ENDIF IF (PRESENT(nrow_locals)) THEN nrow_locals => matrix%matrix_struct%nrow_locals @@ -971,7 +943,7 @@ SUBROUTINE cp_fm_get_info(matrix,name,nrow_global,ncol_global,& CALL cp_fm_struct_get(matrix%matrix_struct, nrow_local=nrow_local,& ncol_local=ncol_local, nrow_global=nrow_global,& ncol_global=ncol_global, nrow_block=nrow_block, & - ncol_block=ncol_block, error=error) + ncol_block=ncol_block) IF (PRESENT(para_env)) para_env => matrix%matrix_struct%para_env @@ -984,13 +956,11 @@ END SUBROUTINE cp_fm_get_info !> \param a_max ... !> \param ir_max ... !> \param ic_max ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_maxabsval(matrix,a_max,ir_max,ic_max,error) + SUBROUTINE cp_fm_maxabsval(matrix,a_max,ir_max,ic_max) TYPE(cp_fm_type), POINTER :: matrix REAL(KIND=dp), INTENT(OUT) :: a_max INTEGER, INTENT(OUT), OPTIONAL :: ir_max, ic_max - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_maxabsval', & routineP = moduleN//':'//routineN @@ -1014,7 +984,7 @@ SUBROUTINE cp_fm_maxabsval(matrix,a_max,ir_max,ic_max,error) my_block_sp => matrix%local_data_sp CALL cp_fm_get_info(matrix, nrow_local=nrow_local, ncol_local=ncol_local,& - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) IF(matrix%use_sp) THEN a_max = REAL(MAXVAL(ABS(my_block_sp(1:nrow_local,1:ncol_local))),dp) @@ -1026,13 +996,13 @@ SUBROUTINE cp_fm_maxabsval(matrix,a_max,ir_max,ic_max,error) num_pe = matrix%matrix_struct%para_env%num_pe mepos = matrix%matrix_struct%para_env%mepos ALLOCATE(ir_max_vec(0:num_pe-1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ir_max_vec(0:num_pe-1) = 0 ALLOCATE(ic_max_vec(0:num_pe-1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ic_max_vec(0:num_pe-1) = 0 ALLOCATE(a_max_vec(0:num_pe-1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) a_max_vec(0:num_pe-1) = 0.0_dp my_max = 0.0_dp @@ -1074,9 +1044,9 @@ SUBROUTINE cp_fm_maxabsval(matrix,a_max,ir_max,ic_max,error) END DO DEALLOCATE(ir_max_vec,ic_max_vec,a_max_vec, STAT = istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CPPostcondition(ic_max>0,cp_failure_level,routineP,error,failure) - CPPostcondition(ir_max>0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CPPostcondition(ic_max>0,cp_failure_level,routineP,failure) + CPPostcondition(ir_max>0,cp_failure_level,routineP,failure) END IF @@ -1091,17 +1061,15 @@ END SUBROUTINE cp_fm_maxabsval !> = || A ||_infinity !> \param matrix ... !> \param a_max ... -!> \param error ... !> \note !> for a real symmetric matrix it holds that || A ||_2 = |lambda_max| < || A ||_infinity !> Hence this can be used to estimate an upper bound for the eigenvalues of a matrix !> http://mathworld.wolfram.com/MatrixNorm.html !> (but the bound is not so tight in the general case) ! ***************************************************************************** - SUBROUTINE cp_fm_maxabsrownorm(matrix, a_max,error) + SUBROUTINE cp_fm_maxabsrownorm(matrix, a_max) TYPE(cp_fm_type), POINTER :: matrix REAL(KIND=dp), INTENT(OUT) :: a_max - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_maxabsrownorm', & routineP = moduleN//':'//routineN @@ -1117,10 +1085,10 @@ SUBROUTINE cp_fm_maxabsrownorm(matrix, a_max,error) my_block => matrix%local_data - CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,failure) CALL cp_fm_get_info(matrix, row_indices=row_indices, nrow_global=nrow_global, & - nrow_local=nrow_local, ncol_local=ncol_local,error=error) + nrow_local=nrow_local, ncol_local=ncol_local) ! the efficiency could be improved by making use of the row-col distribution of scalapack ALLOCATE(values(nrow_global)) @@ -1141,12 +1109,10 @@ SUBROUTINE cp_fm_maxabsrownorm(matrix, a_max,error) !> \brief find the inorm of each column norm_{j}= sqrt( \sum_{i} A_{ij}*A_{ij} ) !> \param matrix ... !> \param norm_array ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_vectorsnorm(matrix, norm_array, error) + SUBROUTINE cp_fm_vectorsnorm(matrix, norm_array) TYPE(cp_fm_type), POINTER :: matrix REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: norm_array - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_vectorsnorm', & routineP = moduleN//':'//routineN @@ -1163,10 +1129,10 @@ SUBROUTINE cp_fm_vectorsnorm(matrix, norm_array, error) my_block => matrix%local_data - CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.matrix%use_sp,cp_failure_level,routineP,failure) CALL cp_fm_get_info(matrix, col_indices=col_indices, ncol_global=ncol_global, & - nrow_local=nrow_local, ncol_local=ncol_local, error=error) + nrow_local=nrow_local, ncol_local=ncol_local) ! the efficiency could be improved by making use of the row-col distribution of scalapack norm_array=0.0_dp @@ -1190,8 +1156,6 @@ SUBROUTINE cp_fm_vectorsnorm(matrix, norm_array, error) !> (defaults to false) !> \param local if the unit is a local unit or a global unit !> (defaults to false, i.e. global) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -1200,11 +1164,10 @@ SUBROUTINE cp_fm_vectorsnorm(matrix, norm_array, error) !> increase nr until no file exists !> routine to help debugging ! ***************************************************************************** - SUBROUTINE cp_fm_write(matrix, unit_nr, long_description, local, error) + SUBROUTINE cp_fm_write(matrix, unit_nr, long_description, local) TYPE(cp_fm_type), POINTER :: matrix INTEGER, INTENT(in) :: unit_nr LOGICAL, INTENT(in), OPTIONAL :: long_description, local - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_write', & routineP = moduleN//':'//routineN @@ -1221,7 +1184,7 @@ SUBROUTINE cp_fm_write(matrix, unit_nr, long_description, local, error) IF (PRESENT(local)) loc=local IF (PRESENT(long_description)) my_long_description=long_description - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() para_env=>logger%para_env IF (ASSOCIATED(matrix)) THEN data_unit=unit_nr @@ -1242,7 +1205,7 @@ SUBROUTINE cp_fm_write(matrix, unit_nr, long_description, local, error) postfix=".desc",local=.TRUE.) INQUIRE (FILE=TRIM(filename),EXIST=exists) CALL cp_assert(.NOT.exists,cp_warning_level,cp_assertion_failed,& - routineP,"file "//TRIM(filename)//" exists, overwriting",error) + routineP,"file "//TRIM(filename)//" exists, overwriting") CALL open_file(TRIM(filename),file_status="unknown",& file_action="WRITE",& unit_number=desc_unit) @@ -1253,7 +1216,7 @@ SUBROUTINE cp_fm_write(matrix, unit_nr, long_description, local, error) postfix=".dat",local=.TRUE.) INQUIRE (FILE=TRIM(filename),EXIST=exists) CALL cp_assert(.NOT.exists,cp_warning_level,cp_assertion_failed,& - routineP,"file "//TRIM(filename)//" exists, overwriting",error) + routineP,"file "//TRIM(filename)//" exists, overwriting") CALL open_file(TRIM(filename),file_status="unknown",& file_action="WRITE",& unit_number=data_unit) @@ -1268,17 +1231,16 @@ SUBROUTINE cp_fm_write(matrix, unit_nr, long_description, local, error) iostat=iostat) matrix%name WRITE(unit=desc_unit,fmt="(a)",iostat=iostat) " matrix_structure=" CALL cp_fm_struct_write(matrix%matrix_struct,unit_nr=desc_unit,& - long_description=my_long_description,error=error) + long_description=my_long_description) WRITE(unit=desc_unit,fmt="(a)",iostat=iostat) " ," IF (my_long_description) THEN WRITE(unit=desc_unit,fmt="(a)",iostat=iostat) " local_data=(" !BEG:ORIG:LT:2015/02/03 - ! CALL cp_2d_r_write(matrix%local_data,unit_nr=data_unit,error=error) + ! CALL cp_2d_r_write(matrix%local_data,unit_nr=data_unit) !END:ORIG:LT:2015/02/03 !BEG:DEBUG:LT:2015/02/03 CALL cp_2d_r_write(matrix%local_data, unit_nr=data_unit, & - el_format="f9.4", & - error=error) + el_format="f9.4") !END:DEBUG:LT:2015/02/03 IF (desc_unit/=data_unit) THEN WRITE(unit=desc_unit,fmt="(a)",iostat=iostat) & @@ -1309,14 +1271,12 @@ END SUBROUTINE cp_fm_write !> \brief copy one identically sized matrix in the other !> \param source ... !> \param destination ... -!> \param error ... !> \note !> see also cp_fm_to_fm_columns ! ***************************************************************************** - SUBROUTINE cp_fm_to_fm_matrix(source,destination,error) + SUBROUTINE cp_fm_to_fm_matrix(source,destination) TYPE(cp_fm_type), POINTER :: source, destination - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_to_fm_matrix', & routineP = moduleN//':'//routineN @@ -1333,7 +1293,7 @@ SUBROUTINE cp_fm_to_fm_matrix(source,destination,error) IF ((.NOT. cp2k_is_parallel).OR.& cp_fm_struct_equivalent(source%matrix_struct,& - destination%matrix_struct,error=error)) THEN + destination%matrix_struct)) THEN IF(source%use_sp.AND.destination%use_sp) THEN CALL cp_assert(SIZE(source%local_data_sp,1)==SIZE(destination%local_data_sp,1).AND.& SIZE(source%local_data_sp,2)==SIZE(destination%local_data_sp,2),cp_failure_level,& @@ -1341,8 +1301,7 @@ SUBROUTINE cp_fm_to_fm_matrix(source,destination,error) "Cannot copy full matrix <"//TRIM(source%name)//& "> to full matrix <"//TRIM(destination%name)//& ">. The local_data blocks have different sizes."//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) CALL scopy(SIZE(source%local_data_sp,1)*SIZE(source%local_data_sp,2),& source%local_data_sp(1,1),1,destination%local_data_sp(1,1),1) ELSEIF(source%use_sp.AND..NOT.destination%use_sp) THEN @@ -1352,8 +1311,7 @@ SUBROUTINE cp_fm_to_fm_matrix(source,destination,error) "Cannot copy full matrix <"//TRIM(source%name)//& "> to full matrix <"//TRIM(destination%name)//& ">. The local_data blocks have different sizes."//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) destination%local_data=REAL(source%local_data_sp,dp) ELSEIF(.NOT.source%use_sp.AND.destination%use_sp) THEN CALL cp_assert(SIZE(source%local_data,1)==SIZE(destination%local_data_sp,1).AND.& @@ -1362,8 +1320,7 @@ SUBROUTINE cp_fm_to_fm_matrix(source,destination,error) "Cannot copy full matrix <"//TRIM(source%name)//& "> to full matrix <"//TRIM(destination%name)//& ">. The local_data blocks have different sizes."//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) destination%local_data_sp=REAL(source%local_data,sp) ELSE CALL cp_assert(SIZE(source%local_data,1)==SIZE(destination%local_data,1).AND.& @@ -1372,13 +1329,12 @@ SUBROUTINE cp_fm_to_fm_matrix(source,destination,error) "Cannot copy full matrix <"//TRIM(source%name)//& "> to full matrix <"//TRIM(destination%name)//& ">. The local_data blocks have different sizes."//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) CALL dcopy(SIZE(source%local_data,1)*SIZE(source%local_data,2),& source%local_data(1,1),1,destination%local_data(1,1),1) ENDIF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -1442,14 +1398,12 @@ END SUBROUTINE cp_fm_to_fm_columns !> \param msource ... !> \param mtarget ... !> \param uplo ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_to_fm_triangular (msource, mtarget, uplo, error) + SUBROUTINE cp_fm_to_fm_triangular (msource, mtarget, uplo) TYPE(cp_fm_type), POINTER :: msource, mtarget CHARACTER(LEN=*), INTENT(IN) :: uplo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_to_fm_triangular', & routineP = moduleN//':'//routineN @@ -1493,16 +1447,14 @@ END SUBROUTINE cp_fm_to_fm_triangular !> \param s_firstcol ... !> \param t_firstrow ... !> \param t_firstcol ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_to_fm_submat(msource, mtarget, nrow, ncol, s_firstrow, s_firstcol, t_firstrow, t_firstcol, error) + SUBROUTINE cp_fm_to_fm_submat(msource, mtarget, nrow, ncol, s_firstrow, s_firstcol, t_firstrow, t_firstcol) TYPE(cp_fm_type), POINTER :: msource, mtarget INTEGER, INTENT(IN) :: nrow, ncol, s_firstrow, & s_firstcol, t_firstrow, & t_firstcol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_to_fm_submat', & routineP = moduleN//':'//routineN @@ -1528,26 +1480,22 @@ SUBROUTINE cp_fm_to_fm_submat(msource, mtarget, nrow, ncol, s_firstrow, s_firstc CALL cp_assert(nrow<=na, cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy because nrow > number of rows of source matrix"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) CALL cp_assert(nrow<=nb, cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy because nrow > number of rows of target matrix"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) na = msource%matrix_struct%ncol_global nb = mtarget%matrix_struct%ncol_global ! ncol must be <= na_col and nb_col CALL cp_assert(ncol<=na, cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy because nrow > number of rows of source matrix"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) CALL cp_assert(ncol<=nb, cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy because nrow > number of rows of target matrix"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) #if defined(__SCALAPACK) desca(:) = msource%matrix_struct%descriptor(:) @@ -1591,13 +1539,11 @@ END SUBROUTINE cp_fm_to_fm_submat !> \param source input fm matrix !> \param destination output fm matrix !> \param global_context process grid that covers all parts of either A or B. -!> \param error CP2K error handling type ! ***************************************************************************** - SUBROUTINE cp_fm_copy_general(source,destination,global_context,error) + SUBROUTINE cp_fm_copy_general(source,destination,global_context) TYPE(cp_fm_type), POINTER :: source, destination INTEGER, INTENT(IN) :: global_context - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_copy_general', & routineP = moduleN//':'//routineN @@ -1617,7 +1563,7 @@ SUBROUTINE cp_fm_copy_general(source,destination,global_context,error) debug = debug_this_module IF (.NOT. cp2k_is_parallel) THEN - CALL cp_fm_to_fm(source,destination,error) + CALL cp_fm_to_fm(source,destination) ELSE #ifdef __SCALAPACK m = 1 @@ -1631,8 +1577,7 @@ SUBROUTINE cp_fm_copy_general(source,destination,global_context,error) CALL cp_assert(.NOT.source%use_sp,& cp_failure_level, cp_assertion_failed, routineP, & "only DP kind implemnted"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) m = source%matrix_struct%nrow_global n = source%matrix_struct%ncol_global smat => source%local_data @@ -1646,8 +1591,7 @@ SUBROUTINE cp_fm_copy_general(source,destination,global_context,error) CALL cp_assert(.NOT.destination%use_sp,& cp_failure_level, cp_assertion_failed, routineP, & "only DP kind implemnted"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) m = destination%matrix_struct%nrow_global n = destination%matrix_struct%ncol_global dmat => destination%local_data @@ -1662,21 +1606,19 @@ SUBROUTINE cp_fm_copy_general(source,destination,global_context,error) cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy between full matrixes of different sizes"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) CALL cp_assert(source%matrix_struct%ncol_global==& destination%matrix_struct%ncol_global,& cp_failure_level,& cp_assertion_failed, routineP, & "cannot copy between full matrixes of differen sizes"//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) END IF CALL pdgemr2d(m,n,smat,1,1,desca,dmat,1,1,descb,global_context) #else - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) #endif END IF @@ -1690,9 +1632,8 @@ END SUBROUTINE cp_fm_copy_general !> \param irow_global ... !> \param icol_global ... !> \param alpha ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_add_to_element(matrix,irow_global,icol_global,alpha,error) + SUBROUTINE cp_fm_add_to_element(matrix,irow_global,icol_global,alpha) ! Add alpha to the matrix element specified by the global indices ! irow_global and icol_global @@ -1702,7 +1643,6 @@ SUBROUTINE cp_fm_add_to_element(matrix,irow_global,icol_global,alpha,error) TYPE(cp_fm_type), POINTER :: matrix INTEGER, INTENT(IN) :: irow_global, icol_global REAL(KIND=dp), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_add_to_element', & routineP = moduleN//':'//routineN @@ -1719,7 +1659,7 @@ SUBROUTINE cp_fm_add_to_element(matrix,irow_global,icol_global,alpha,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,failure) context => matrix%matrix_struct%context @@ -1754,12 +1694,10 @@ END SUBROUTINE cp_fm_add_to_element !> \brief ... !> \param fm ... !> \param unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_write_unformatted(fm,unit,error) + SUBROUTINE cp_fm_write_unformatted(fm,unit) TYPE(cp_fm_type), POINTER :: fm INTEGER :: unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_write_unformatted', & routineP = moduleN//':'//routineN @@ -1783,7 +1721,7 @@ SUBROUTINE cp_fm_write_unformatted(fm,unit,error) failure = .FALSE. CALL timeset(routineN,handle) CALL cp_fm_get_info(fm, nrow_global=nrow_global,ncol_global=ncol_global,ncol_block=max_block,& - para_env=para_env,error=error) + para_env=para_env) #if defined(__SCALAPACK) num_pe=para_env%num_pe @@ -1795,7 +1733,7 @@ SUBROUTINE cp_fm_write_unformatted(fm,unit,error) CALL cp_blacs_gridinit(ictxt_loc,'R',1,num_pe) CALL cp_blacs_gridinfo(ictxt_loc,nprow,npcol,myprow,mypcol) CALL descinit(desc,nrow_global,ncol_global,rb,max_block,0,0,ictxt_loc,nrow_global,info) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) in=numroc(ncol_global,max_block,mypcol,0,npcol) ALLOCATE(newdat(nrow_global,MAX(1,in))) @@ -1806,7 +1744,7 @@ SUBROUTINE cp_fm_write_unformatted(fm,unit,error) newdat(1,1),1,1,desc,ictxt_loc) ALLOCATE(vecbuf(nrow_global*max_block),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vecbuf=HUGE(1.0_dp) ! init for valgrind DO i=1,ncol_global,MAX(max_block,1) @@ -1838,12 +1776,12 @@ SUBROUTINE cp_fm_write_unformatted(fm,unit,error) END DO DEALLOCATE(vecbuf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL cp_blacs_gridexit(ictxt_loc) DEALLOCATE(newdat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) #else @@ -1862,12 +1800,10 @@ END SUBROUTINE cp_fm_write_unformatted !> \brief ... !> \param fm ... !> \param unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_read_unformatted(fm,unit,error) + SUBROUTINE cp_fm_read_unformatted(fm,unit) TYPE(cp_fm_type), POINTER :: fm INTEGER :: unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_read_unformatted', & routineP = moduleN//':'//routineN @@ -1885,14 +1821,14 @@ SUBROUTINE cp_fm_read_unformatted(fm,unit,error) failure=.FALSE. CALL cp_fm_get_info(fm, nrow_global=nrow_global,ncol_global=ncol_global,ncol_block=max_block,& - para_env=para_env,error=error) + para_env=para_env) #if defined(__SCALAPACK) ! the parallel case could be made more efficient (see cp_fm_write_unformatted) ALLOCATE(vecbuf(nrow_global,max_block),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,ncol_global,max_block @@ -1903,12 +1839,12 @@ SUBROUTINE cp_fm_read_unformatted(fm,unit,error) ENDDO ENDIF CALL mp_bcast(vecbuf,0,para_env%group) - CALL cp_fm_set_submatrix(fm,vecbuf,start_row=1,start_col=j,n_cols=n_cols,error=error) + CALL cp_fm_set_submatrix(fm,vecbuf,start_row=1,start_col=j,n_cols=n_cols) ENDDO DEALLOCATE(vecbuf,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) #else diff --git a/src/fm/cp_fm_vect.F b/src/fm/cp_fm_vect.F index 63a9301320..6e4518a99d 100644 --- a/src/fm/cp_fm_vect.F +++ b/src/fm/cp_fm_vect.F @@ -28,16 +28,13 @@ MODULE cp_fm_vect ! ***************************************************************************** !> \brief deallocate an array of pointers to blacs matrixes !> \param matrixes the array of matrixes to deallocate -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_fm_vect_dealloc(matrixes, error) + SUBROUTINE cp_fm_vect_dealloc(matrixes) TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: matrixes - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_vect_dealloc', & routineP = moduleN//':'//routineN @@ -49,10 +46,10 @@ SUBROUTINE cp_fm_vect_dealloc(matrixes, error) IF (ASSOCIATED(matrixes)) THEN DO i=1,SIZE(matrixes) - CALL cp_fm_release(matrixes(i)%matrix,error=error) + CALL cp_fm_release(matrixes(i)%matrix) END DO DEALLOCATE(matrixes,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END SUBROUTINE cp_fm_vect_dealloc @@ -61,18 +58,15 @@ END SUBROUTINE cp_fm_vect_dealloc !> the matrices) !> \param matrixes the matrixes to copy !> \param copy ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_fm_vect_copy(matrixes, copy, error) +SUBROUTINE cp_fm_vect_copy(matrixes, copy) TYPE(cp_fm_p_type), DIMENSION(:), & INTENT(in) :: matrixes TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: copy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_vect_copy', & routineP = moduleN//':'//routineN @@ -83,10 +77,10 @@ SUBROUTINE cp_fm_vect_copy(matrixes, copy, error) failure=.FALSE. ALLOCATE(copy(SIZE(matrixes)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(matrixes) copy(i)%matrix => matrixes(i)%matrix - CALL cp_fm_retain(matrixes(i)%matrix,error=error) + CALL cp_fm_retain(matrixes(i)%matrix) END DO END SUBROUTINE cp_fm_vect_copy diff --git a/src/fm/cp_linked_list_fm.F b/src/fm/cp_linked_list_fm.F index 86e0bc1f19..a30f5aa00f 100644 --- a/src/fm/cp_linked_list_fm.F +++ b/src/fm/cp_linked_list_fm.F @@ -4,8 +4,8 @@ !-----------------------------------------------------------------------------! ! less not much meningful... -#define CP_SLL_FM_LESS_Q(el1,el2,error) ( el1 %id_nr < el2 %id_nr ) -#define CP_SLL_FM_EQUAL_Q(el1,el2,error) ( el1 %id_nr == el2 %id_nr ) +#define CP_SLL_FM_LESS_Q(el1,el2) ( el1 %id_nr < el2 %id_nr ) +#define CP_SLL_FM_EQUAL_Q(el1,el2) ( el1 %id_nr == el2 %id_nr ) ! ***************************************************************************** @@ -209,17 +209,14 @@ MODULE cp_linked_list_fm !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_fm_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_fm_create(sll,first_el,rest) TYPE(cp_sll_fm_type), POINTER :: sll TYPE(cp_fm_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_create', & routineP = moduleN//':'//routineN @@ -234,7 +231,7 @@ SUBROUTINE cp_sll_fm_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el => first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -245,8 +242,6 @@ END SUBROUTINE cp_sll_fm_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -254,14 +249,13 @@ END SUBROUTINE cp_sll_fm_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_fm_dealloc(sll,error) + SUBROUTINE cp_sll_fm_dealloc(sll) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_fm_rm_all_el(sll,error) + CALL cp_sll_fm_rm_all_el(sll) END SUBROUTINE cp_sll_fm_dealloc ! * low-level * @@ -269,15 +263,12 @@ END SUBROUTINE cp_sll_fm_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_fm_dealloc_node(sll,error) + SUBROUTINE cp_sll_fm_dealloc_node(sll) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_dealloc_node', & routineP = moduleN//':'//routineN @@ -288,7 +279,7 @@ SUBROUTINE cp_sll_fm_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_fm_dealloc_node ! ============= get/set ============ @@ -300,17 +291,14 @@ END SUBROUTINE cp_sll_fm_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_fm_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_fm_set(sll,first_el,rest) TYPE(cp_sll_fm_type), POINTER :: sll TYPE(cp_fm_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_set', & routineP = moduleN//':'//routineN @@ -321,9 +309,9 @@ SUBROUTINE cp_sll_fm_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_fm_create(sll,first_el,rest,error) + CALL cp_sll_fm_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el => first_el @@ -338,19 +326,16 @@ END SUBROUTINE cp_sll_fm_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_fm_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_fm_get(sll,first_el,rest,empty,length) TYPE(cp_sll_fm_type), POINTER :: sll TYPE(cp_fm_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get', & routineP = moduleN//':'//routineN @@ -360,7 +345,7 @@ SUBROUTINE cp_sll_fm_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -369,23 +354,20 @@ SUBROUTINE cp_sll_fm_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_fm_get_length(sll,error=error) + length = cp_sll_fm_get_length(sll) END IF END SUBROUTINE cp_sll_fm_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_fm_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_fm_get_first_el(sll) RESULT(res) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_fm_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_first_el', & @@ -396,7 +378,7 @@ FUNCTION cp_sll_fm_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res => sll%first_el @@ -407,8 +389,6 @@ END FUNCTION cp_sll_fm_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -416,10 +396,9 @@ END FUNCTION cp_sll_fm_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_fm_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_fm_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_fm_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_fm_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_rest', & @@ -442,7 +421,7 @@ FUNCTION cp_sll_fm_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -460,16 +439,13 @@ END FUNCTION cp_sll_fm_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_fm_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_fm_get_empty(sll) RESULT(res) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_empty', & @@ -481,8 +457,6 @@ END FUNCTION cp_sll_fm_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -490,9 +464,8 @@ END FUNCTION cp_sll_fm_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_fm_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_fm_get_length(sll) RESULT(res) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_length', & @@ -516,8 +489,6 @@ END FUNCTION cp_sll_fm_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -525,10 +496,9 @@ END FUNCTION cp_sll_fm_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_fm_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_fm_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_fm_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_fm_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_get_el_at', & @@ -540,14 +510,14 @@ FUNCTION cp_sll_fm_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) + pos => cp_sll_fm_get_rest(sll, iter=-1) ELSE - pos => cp_sll_fm_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_fm_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res => pos%first_el END FUNCTION cp_sll_fm_get_el_at @@ -558,19 +528,16 @@ END FUNCTION cp_sll_fm_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_fm_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_fm_set_el_at(sll,index,value) TYPE(cp_sll_fm_type), POINTER :: sll INTEGER, INTENT(in) :: index TYPE(cp_fm_type), POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_set_el_at', & routineP = moduleN//':'//routineN @@ -581,11 +548,11 @@ SUBROUTINE cp_sll_fm_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) + pos => cp_sll_fm_get_rest(sll, iter=-1) ELSE - pos => cp_sll_fm_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_fm_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el => value END SUBROUTINE cp_sll_fm_set_el_at @@ -597,17 +564,14 @@ END SUBROUTINE cp_sll_fm_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_fm_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_fm_next(iterator,el_att) RESULT(res) TYPE(cp_sll_fm_type), POINTER :: iterator TYPE(cp_fm_type), OPTIONAL, POINTER :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_next', & @@ -629,18 +593,15 @@ END FUNCTION cp_sll_fm_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_fm_insert_el(sll,el,error) + SUBROUTINE cp_sll_fm_insert_el(sll,el) TYPE(cp_sll_fm_type), POINTER :: sll TYPE(cp_fm_type), POINTER :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_el', & routineP = moduleN//':'//routineN @@ -650,24 +611,21 @@ SUBROUTINE cp_sll_fm_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_fm_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_fm_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_fm_rm_first_el(sll,error) + SUBROUTINE cp_sll_fm_rm_first_el(sll) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_rm_first_el', & routineP = moduleN//':'//routineN @@ -680,12 +638,12 @@ SUBROUTINE cp_sll_fm_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_fm_dealloc_node(node_to_rm,error=error) + CALL cp_sll_fm_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_fm_rm_first_el @@ -695,19 +653,16 @@ END SUBROUTINE cp_sll_fm_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_fm_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_fm_insert_el_at(sll,el,index) TYPE(cp_sll_fm_type), POINTER :: sll TYPE(cp_fm_type), POINTER :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_el_at', & routineP = moduleN//':'//routineN @@ -718,15 +673,15 @@ SUBROUTINE cp_sll_fm_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_fm_insert_el(sll,el,error=error) + CALL cp_sll_fm_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) + pos => cp_sll_fm_get_rest(sll, iter=-1) ELSE - pos => cp_sll_fm_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_fm_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_fm_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_fm_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_fm_insert_el_at @@ -734,18 +689,15 @@ END SUBROUTINE cp_sll_fm_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_fm_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_fm_rm_el_at(sll,index) TYPE(cp_sll_fm_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_rm_el_at', & routineP = moduleN//':'//routineN @@ -756,35 +708,32 @@ SUBROUTINE cp_sll_fm_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_fm_rm_first_el(sll,error=error) + CALL cp_sll_fm_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_fm_get_rest(sll, iter=-1,error=error) + pos => cp_sll_fm_get_rest(sll, iter=-1) ELSE - pos => cp_sll_fm_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_fm_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_fm_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_fm_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_fm_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_fm_rm_all_el(sll,error) + SUBROUTINE cp_sll_fm_rm_all_el(sll) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_rm_all_el', & routineP = moduleN//':'//routineN @@ -795,7 +744,7 @@ SUBROUTINE cp_sll_fm_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_fm_dealloc_node(actual_node,error=error) + CALL cp_sll_fm_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -805,16 +754,13 @@ END SUBROUTINE cp_sll_fm_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_fm_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_fm_to_array(sll) RESULT(res) TYPE(cp_sll_fm_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: res @@ -827,14 +773,14 @@ FUNCTION cp_sll_fm_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_fm_get_length(sll,error) + len=cp_sll_fm_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i)%matrix => iter%first_el - IF (.NOT.(cp_sll_fm_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_fm_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_fm_to_array @@ -842,17 +788,14 @@ END FUNCTION cp_sll_fm_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_fm_from_array(array,error) RESULT(res) +FUNCTION cp_sll_fm_from_array(array) RESULT(res) TYPE(cp_fm_p_type), DIMENSION(:), & INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_fm_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_from_array', & @@ -864,14 +807,12 @@ FUNCTION cp_sll_fm_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_fm_create(res,& - first_el=array(1)%matrix,& - error=error) + first_el=array(1)%matrix) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_fm_create(last_el%rest,& - first_el=array(i)%matrix,& - error=error) + first_el=array(i)%matrix) last_el => last_el%rest END DO END FUNCTION cp_sll_fm_from_array @@ -885,20 +826,17 @@ END FUNCTION cp_sll_fm_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_fm_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_fm_type), POINTER :: sll TYPE(cp_fm_type), POINTER :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_ordered', & routineP = moduleN//':'//routineN @@ -914,13 +852,13 @@ SUBROUTINE cp_sll_fm_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_fm_create(sll,first_el=el,error=error) + CALL cp_sll_fm_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_FM_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_FM_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_FM_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_fm_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_FM_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_fm_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -928,22 +866,22 @@ SUBROUTINE cp_sll_fm_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_fm_insert_el(iter%rest,el,error=error) + CALL cp_sll_fm_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_FM_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_FM_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_FM_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_fm_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_FM_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_fm_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_fm_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_fm_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_fm_insert_ordered @@ -958,14 +896,12 @@ END SUBROUTINE cp_sll_fm_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_fm_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_fm_type), POINTER :: sll TYPE(cp_fm_type), POINTER :: el INTERFACE @@ -980,7 +916,6 @@ END FUNCTION compare_function LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_fm_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_fm_insert_ordered2', & routineP = moduleN//':'//routineN @@ -997,7 +932,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_fm_create(sll,first_el=el,error=error) + CALL cp_sll_fm_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1005,7 +940,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_fm_insert_el(sll,el,error=error) + CALL cp_sll_fm_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1013,7 +948,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_fm_insert_el(iter%rest,el,error=error) + CALL cp_sll_fm_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1021,15 +956,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_fm_insert_el(iter%rest,el,error=error) + CALL cp_sll_fm_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_fm_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_fm_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_fm_insert_ordered2 @@ -1046,8 +981,8 @@ END SUBROUTINE cp_sll_fm_insert_ordered2 ! common_dir = "../common" ! defines = ! "! less not much meningful... -! #define CP_SLL_FM_LESS_Q(el1,el2,error) ( el1 %id_nr < el2 %id_nr ) -! #define CP_SLL_FM_EQUAL_Q(el1,el2,error) ( el1 %id_nr == el2 %id_nr ) +! #define CP_SLL_FM_LESS_Q(el1,el2) ( el1 %id_nr < el2 %id_nr ) +! #define CP_SLL_FM_EQUAL_Q(el1,el2) ( el1 %id_nr == el2 %id_nr ) ! " ! equalQ = "CP_SLL_FM_EQUAL_Q" ! lessQ = "CP_SLL_FM_LESS_Q" diff --git a/src/force_env_methods.F b/src/force_env_methods.F index 3a2095f8ef..07b77ab47f 100644 --- a/src/force_env_methods.F +++ b/src/force_env_methods.F @@ -147,18 +147,16 @@ MODULE force_env_methods !> \param require_consistent_energy_force ... !> \param linres ... !> \param calc_stress_tensor ... -!> \param error ... !> \author CJM & fawzi ! ***************************************************************************** RECURSIVE SUBROUTINE force_env_calc_energy_force ( force_env, calc_force, & consistent_energies, skip_external_control, eval_energy_forces, & - require_consistent_energy_force, linres, calc_stress_tensor, error) + require_consistent_energy_force, linres, calc_stress_tensor) TYPE(force_env_type), POINTER :: force_env LOGICAL, INTENT(IN), OPTIONAL :: calc_force, consistent_energies, & skip_external_control, eval_energy_forces, & require_consistent_energy_force, linres, calc_stress_tensor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_calc_energy_force', & routineP = moduleN//':'//routineN @@ -183,7 +181,7 @@ RECURSIVE SUBROUTINE force_env_calc_energy_force ( force_env, calc_force, & TYPE(virial_type), POINTER :: virial NULLIFY (logger, virial, subsys, atprop_env, cell) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. eval_ef = .TRUE. my_skip = .FALSE. @@ -201,50 +199,49 @@ RECURSIVE SUBROUTINE force_env_calc_energy_force ( force_env, calc_force, & IF (PRESENT(consistent_energies)) energy_consistency = consistent_energies IF (PRESENT(linres)) linres_run = linres - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL force_env_set(force_env,additional_potential=0.0_dp,error=error) - CALL cp_subsys_get(subsys, virial=virial, atprop=atprop_env, cell=cell, error=error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,failure) + CALL force_env_get(force_env,subsys=subsys) + CALL force_env_set(force_env,additional_potential=0.0_dp) + CALL cp_subsys_get(subsys, virial=virial, atprop=atprop_env, cell=cell) IF (virial%pv_availability) CALL zero_virial(virial,reset=.FALSE.) - nat=force_env_get_natom(force_env,error=error) - CALL atprop_init(atprop_env,nat,error) + nat=force_env_get_natom(force_env) + CALL atprop_init(atprop_env,nat) IF (eval_ef) THEN SELECT CASE ( force_env%in_use ) CASE ( use_fist_force ) - CALL fist_calc_energy_force(force_env%fist_env, error=error) + CALL fist_calc_energy_force(force_env%fist_env) CASE ( use_qs_force ) - CALL qs_calc_energy_force(force_env%qs_env,calculate_forces,energy_consistency,linres_run,error=error) + CALL qs_calc_energy_force(force_env%qs_env,calculate_forces,energy_consistency,linres_run) CASE (use_eip_force) IF (force_env%eip_env%eip_model == use_lenosky_eip) THEN - CALL eip_lenosky(force_env%eip_env, error=error) + CALL eip_lenosky(force_env%eip_env) ELSE IF (force_env%eip_env%eip_model == use_bazant_eip) THEN - CALL eip_bazant(force_env%eip_env, error=error) + CALL eip_bazant(force_env%eip_env) END IF CASE ( use_qmmm ) CALL qmmm_calc_energy_force(force_env%qmmm_env,& - calculate_forces,energy_consistency,linres=linres_run,error=error) + calculate_forces,energy_consistency,linres=linres_run) CASE ( use_qmmmx ) CALL qmmmx_calc_energy_force(force_env%qmmmx_env,& calculate_forces,energy_consistency,linres=linres_run,& - require_consistent_energy_force=require_consistent_energy_force,& - error=error) + require_consistent_energy_force=require_consistent_energy_force) CASE ( use_mixed_force ) - CALL mixed_energy_forces(force_env,calculate_forces,error=error) + CALL mixed_energy_forces(force_env,calculate_forces) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF ! In case it is requested, we evaluate the stress tensor numerically IF (virial%pv_availability) THEN IF (virial%pv_numer.AND.calculate_stress_tensor) THEN ! Compute the numerical stress tensor - CALL force_env_calc_num_pressure(force_env,error=error) + CALL force_env_calc_num_pressure(force_env) ELSE IF (calculate_forces) THEN ! Symmetrize analytical stress tensor - CALL sym_virial(virial,error) + CALL sym_virial(virial) ELSE IF (calculate_stress_tensor) THEN CALL print_warning(routineN,moduleN,__LINE__,& @@ -264,58 +261,56 @@ RECURSIVE SUBROUTINE force_env_calc_energy_force ( force_env, calc_force, & ! Flexible Partitioning IF (ASSOCIATED(force_env%fp_env)) THEN IF (force_env%fp_env%use_fp) THEN - CALL fp_eval(force_env%fp_env,subsys,cell,error=error) + CALL fp_eval(force_env%fp_env,subsys,cell) ENDIF ENDIF ! Constraints ONLY of Fixed Atom type - CALL fix_atom_control(force_env, error=error) + CALL fix_atom_control(force_env) ! All Restraints - CALL restraint_control(force_env, error=error) + CALL restraint_control(force_env) ! Virtual Sites - CALL vsite_force_control(force_env,error) + CALL vsite_force_control(force_env) ! External Potential - CALL add_external_potential(force_env, error=error) + CALL add_external_potential(force_env) ! Rescale forces if requested - CALL rescale_forces(force_env, error=error) + CALL rescale_forces(force_env) END IF ! Print always Energy in the same format for all methods output_unit = cp_print_key_unit_nr(logger,force_env%force_env_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".Log",error=error) + extension=".Log") IF (output_unit > 0) THEN - CALL force_env_get(force_env, potential_energy=e_pot, error=error) + CALL force_env_get(force_env, potential_energy=e_pot) WRITE(output_unit,'(/,T2,"ENERGY| Total FORCE_EVAL ( ",A," ) energy (a.u.): ",T55,F26.15,/)')& ADJUSTR(TRIM(use_prog_name(force_env%in_use))),e_pot END IF CALL cp_print_key_finished_output(output_unit,logger,force_env%force_env_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") ! Print forces, if requested print_forces = cp_print_key_unit_nr(logger,force_env%force_env_section,"PRINT%FORCES",& - extension=".xyz",error=error) + extension=".xyz") IF ((print_forces > 0).AND.calculate_forces) THEN - CALL force_env_get(force_env,subsys=subsys,error=error) + CALL force_env_get(force_env,subsys=subsys) CALL cp_subsys_get(subsys,& core_particles=core_particles,& particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) ! Variable precision output of the forces CALL section_vals_val_get(force_env%force_env_section,"PRINT%FORCES%NDIGITS",& - i_val=ndigits,error=error) - CALL write_forces(particles,print_forces,"ATOMIC",ndigits,total_force,error=error) + i_val=ndigits) + CALL write_forces(particles,print_forces,"ATOMIC",ndigits,total_force) grand_total_force(:) = total_force(:) IF (ASSOCIATED(core_particles)) THEN - CALL write_forces(core_particles,print_forces,"CORE",ndigits,total_force,error=error) + CALL write_forces(core_particles,print_forces,"CORE",ndigits,total_force) grand_total_force(:) = grand_total_force(:) + total_force(:) END IF IF (ASSOCIATED(shell_particles)) THEN CALL write_forces(shell_particles,print_forces,"SHELL",ndigits,total_force,& - grand_total_force,error=error) + grand_total_force) END IF END IF - CALL cp_print_key_finished_output(print_forces,logger,force_env%force_env_section,"PRINT%FORCES",& - error=error) + CALL cp_print_key_finished_output(print_forces,logger,force_env%force_env_section,"PRINT%FORCES") ! Write stress tensor @@ -324,35 +319,34 @@ RECURSIVE SUBROUTINE force_env_calc_energy_force ( force_env, calc_force, & ! virial for consistency IF (calculate_forces.AND.calculate_stress_tensor) THEN output_unit = cp_print_key_unit_nr(logger,force_env%force_env_section,"PRINT%STRESS_TENSOR",& - extension=".stress_tensor",error=error) + extension=".stress_tensor") IF (output_unit > 0) THEN CALL section_vals_val_get(force_env%force_env_section,"PRINT%STRESS_TENSOR%NDIGITS",& - i_val=ndigits,error=error) - CALL write_stress_tensor(virial%pv_virial,output_unit,cell,ndigits,virial%pv_numer,& - error=error) + i_val=ndigits) + CALL write_stress_tensor(virial%pv_virial,output_unit,cell,ndigits,virial%pv_numer) END IF CALL cp_print_key_finished_output(output_unit,logger,force_env%force_env_section,& - "PRINT%STRESS_TENSOR",error=error) + "PRINT%STRESS_TENSOR") ELSE CALL zero_virial(virial,reset=.FALSE.) END IF ELSE output_unit = cp_print_key_unit_nr(logger,force_env%force_env_section,"PRINT%STRESS_TENSOR",& - extension=".stress_tensor",error=error) + extension=".stress_tensor") IF (output_unit > 0) THEN CALL print_warning(routineN,moduleN,__LINE__,"To print the stress tensor switch on the "//& "virial evaluation with the keyword: STRESS_TENSOR",force_env%para_env) END IF CALL cp_print_key_finished_output(output_unit,logger,force_env%force_env_section,& - "PRINT%STRESS_TENSOR",error=error) + "PRINT%STRESS_TENSOR") END IF ! Atomic energy output_unit = cp_print_key_unit_nr(logger,force_env%force_env_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".Log",error=error) + extension=".Log") IF (atprop_env%energy) THEN CALL mp_sum(atprop_env%atener, force_env%para_env%group) - CALL force_env_get(force_env, potential_energy=e_pot, error=error) + CALL force_env_get(force_env, potential_energy=e_pot) IF (output_unit > 0) THEN IF (logger%iter_info%print_level > low_print_level) THEN WRITE (UNIT=output_unit,FMT="(/,T6,A,T15,A)") "Atom","Potential energy" @@ -365,15 +359,15 @@ RECURSIVE SUBROUTINE force_env_calc_energy_force ( force_env, calc_force, & "Potential energy (Atomic):",sum_energy,& "Potential energy (Total) :",e_pot,& "Difference :",checksum - CPPostcondition((checksum < ateps*ABS(e_pot)),cp_fatal_level,routineP,error,failure) + CPPostcondition((checksum < ateps*ABS(e_pot)),cp_fatal_level,routineP,failure) END IF CALL cp_print_key_finished_output(output_unit,logger,force_env%force_env_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END IF ! Atomic stress output_unit = cp_print_key_unit_nr(logger,force_env%force_env_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".Log",error=error) + extension=".Log") IF (atprop_env%stress) THEN CALL mp_sum(atprop_env%atstress,force_env%para_env%group) @@ -428,11 +422,11 @@ RECURSIVE SUBROUTINE force_env_calc_energy_force ( force_env, calc_force, & "Checksum stress (Atomic) :",sum_stress_tensor,& "Checksum stress (Total) :",sum_pv_virial,& "Difference :",checksum - CPPostcondition((checksum < ateps),cp_fatal_level,routineP,error,failure) + CPPostcondition((checksum < ateps),cp_fatal_level,routineP,failure) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,force_env%force_env_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END IF END SUBROUTINE force_env_calc_energy_force @@ -441,18 +435,16 @@ END SUBROUTINE force_env_calc_energy_force !> \brief Evaluates the stress tensor and pressure numerically !> \param force_env ... !> \param dx ... -!> \param error ... !> \par History !> 10.2005 created [JCS] !> 05.2009 Teodoro Laino [tlaino] - rewriting for general force_env !> !> \author JCS ! ***************************************************************************** - SUBROUTINE force_env_calc_num_pressure(force_env,dx,error) + SUBROUTINE force_env_calc_num_pressure(force_env,dx) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), INTENT(IN), OPTIONAL :: dx - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_calc_num_pressure', & routineP = moduleN//':'//routineN @@ -489,20 +481,19 @@ SUBROUTINE force_env_calc_num_pressure(force_env,dx,error) numer_stress = 0.0_dp failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() dx_w = default_dx IF (PRESENT(dx)) dx_w = dx - CALL force_env_get(force_env,subsys=subsys,globenv=globenv,error=error) + CALL force_env_get(force_env,subsys=subsys,globenv=globenv) CALL cp_subsys_get(subsys,& core_particles=core_particles,& particles=particles,& shell_particles=shell_particles,& - virial=virial,& - error=error) + virial=virial) output_unit = cp_print_key_unit_nr(logger,force_env%force_env_section,"PRINT%STRESS_TENSOR",& - extension=".stress_tensor",error=error) + extension=".stress_tensor") IF (output_unit > 0) THEN WRITE (output_unit,'(/A,A/)') ' **************************** ', & 'NUMERICAL STRESS ********************************' @@ -511,14 +502,14 @@ SUBROUTINE force_env_calc_num_pressure(force_env,dx,error) ! Save all original particle positions natom = particles%n_els ALLOCATE (ref_pos_atom(natom,3),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) DO i=1,natom ref_pos_atom(i,:) = particles%els(i)%r END DO IF (ASSOCIATED(core_particles)) THEN ncore = core_particles%n_els ALLOCATE (ref_pos_core(ncore,3),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) DO i=1,ncore ref_pos_core(i,:) = core_particles%els(i)%r END DO @@ -526,14 +517,14 @@ SUBROUTINE force_env_calc_num_pressure(force_env,dx,error) IF (ASSOCIATED(shell_particles)) THEN nshell = shell_particles%n_els ALLOCATE (ref_pos_shell(nshell,3),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) DO i=1,nshell ref_pos_shell(i,:) = shell_particles%els(i)%r END DO END IF - CALL force_env_get(force_env,cell=cell,error=error) - CALL cell_create(cell_local,error=error) - CALL cell_clone(cell,cell_local,error=error) + CALL force_env_get(force_env,cell=cell) + CALL cell_create(cell_local) + CALL cell_clone(cell,cell_local) ! First change box DO ip=1,3 DO iq=1,3 @@ -559,9 +550,8 @@ SUBROUTINE force_env_calc_num_pressure(force_env,dx,error) CALL force_env_calc_energy_force(force_env,& calc_force=.FALSE.,& consistent_energies=.TRUE.,& - calc_stress_tensor=.FALSE.,& - error=error) - CALL force_env_get(force_env,potential_energy=numer_energy(k),error=error) + calc_stress_tensor=.FALSE.) + CALL force_env_get(force_env,potential_energy=numer_energy(k)) ! Reset cell cell%hmat(ip,iq) = cell_local%hmat(ip,iq) END DO @@ -591,8 +581,7 @@ SUBROUTINE force_env_calc_num_pressure(force_env,dx,error) CALL force_env_calc_energy_force(force_env,& calc_force=.FALSE.,& consistent_energies=.TRUE.,& - calc_stress_tensor=.FALSE.,& - error=error) + calc_stress_tensor=.FALSE.) ! Computing pv_test virial%pv_virial = 0.0_dp @@ -609,31 +598,30 @@ SUBROUTINE force_env_calc_num_pressure(force_env,dx,error) IF (output_unit > 0) THEN IF (globenv%run_type_id == debug_run) THEN CALL section_vals_val_get(force_env%force_env_section,"PRINT%STRESS_TENSOR%NDIGITS",& - i_val=ndigits,error=error) - CALL write_stress_tensor(virial%pv_virial,output_unit,cell,ndigits,virial%pv_numer,& - error=error) + i_val=ndigits) + CALL write_stress_tensor(virial%pv_virial,output_unit,cell,ndigits,virial%pv_numer) END IF WRITE (output_unit,'(/,A,/)') ' **************************** '//& 'NUMERICAL STRESS END *****************************' END IF CALL cp_print_key_finished_output(output_unit,logger,force_env%force_env_section,& - "PRINT%STRESS_TENSOR",error=error) + "PRINT%STRESS_TENSOR") ! Release storage IF (ASSOCIATED(ref_pos_atom)) THEN DEALLOCATE (ref_pos_atom,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(ref_pos_core)) THEN DEALLOCATE (ref_pos_core,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(ref_pos_shell)) THEN DEALLOCATE (ref_pos_shell,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) END IF - IF (ASSOCIATED(cell_local)) CALL cell_release(cell_local,error=error) + IF (ASSOCIATED(cell_local)) CALL cell_release(cell_local) END SUBROUTINE force_env_calc_num_pressure @@ -654,15 +642,13 @@ END SUBROUTINE force_env_calc_num_pressure !> \param eip_env ... !> \param force_env_section ... !> \param mixed_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** SUBROUTINE force_env_create(force_env,root_section,para_env,globenv,fist_env,& qs_env,meta_env,sub_force_env,qmmm_env,qmmmx_env,eip_env,force_env_section,& - mixed_env,error) + mixed_env) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section @@ -682,7 +668,6 @@ SUBROUTINE force_env_create(force_env,root_section,para_env,globenv,fist_env,& TYPE(section_vals_type), POINTER :: force_env_section TYPE(mixed_environment_type), OPTIONAL, & POINTER :: mixed_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_create', & routineP = moduleN//':'//routineN @@ -693,7 +678,7 @@ SUBROUTINE force_env_create(force_env,root_section,para_env,globenv,fist_env,& failure=.FALSE. ALLOCATE ( force_env, stat=stat ) - CPPostconditionNoFail(stat==0,cp_fatal_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_fatal_level,routineP) NULLIFY (force_env%fist_env, force_env%qs_env, & force_env%para_env, force_env%globenv, & force_env%meta_env, force_env%sub_force_env, & @@ -707,60 +692,60 @@ SUBROUTINE force_env_create(force_env,root_section,para_env,globenv,fist_env,& force_env%additional_potential=0.0_dp force_env%globenv => globenv - CALL globenv_retain(force_env%globenv,error=error) + CALL globenv_retain(force_env%globenv) force_env%root_section => root_section - CALL section_vals_retain(root_section,error=error) + CALL section_vals_retain(root_section) force_env%para_env=>para_env - CALL cp_para_env_retain(force_env%para_env, error=error) + CALL cp_para_env_retain(force_env%para_env) - CALL section_vals_retain(force_env_section,error=error) + CALL section_vals_retain(force_env_section) force_env%force_env_section => force_env_section IF (PRESENT(fist_env)) THEN - CPPrecondition(ASSOCIATED(fist_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fist_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,failure) force_env%in_use=use_fist_force force_env%fist_env => fist_env - CALL fist_env_retain(fist_env,error=error) + CALL fist_env_retain(fist_env) END IF IF (PRESENT(eip_env)) THEN - CPPrecondition(ASSOCIATED(eip_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%in_use==0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(eip_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%in_use==0, cp_failure_level, routineP,failure) force_env%in_use = use_eip_force force_env%eip_env => eip_env - CALL eip_env_retain(eip_env, error=error) + CALL eip_env_retain(eip_env) END IF IF (PRESENT(qs_env)) THEN - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,failure) force_env%in_use=use_qs_force force_env%qs_env => qs_env - CALL qs_env_retain(qs_env,error=error) + CALL qs_env_retain(qs_env) END IF IF (PRESENT(qmmm_env)) THEN - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,failure) force_env%in_use=use_qmmm force_env%qmmm_env => qmmm_env - CALL qmmm_env_retain(qmmm_env,error=error) + CALL qmmm_env_retain(qmmm_env) END IF IF (PRESENT(qmmmx_env)) THEN - CPPrecondition(ASSOCIATED(qmmmx_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qmmmx_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%in_use==0,cp_failure_level,routineP,failure) force_env%in_use=use_qmmmx force_env%qmmmx_env => qmmmx_env - CALL qmmmx_env_retain(qmmmx_env,error=error) + CALL qmmmx_env_retain(qmmmx_env) END IF IF (PRESENT(mixed_env)) THEN - CPPrecondition(ASSOCIATED(mixed_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%in_use==0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(mixed_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%in_use==0, cp_failure_level, routineP,failure) force_env%in_use=use_mixed_force force_env%mixed_env => mixed_env - CALL mixed_env_retain ( mixed_env, error = error ) + CALL mixed_env_retain ( mixed_env) END IF - CPPostcondition(force_env%in_use/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(force_env%in_use/=0,cp_failure_level,routineP,failure) IF (PRESENT(sub_force_env)) THEN force_env%sub_force_env => sub_force_env @@ -768,7 +753,7 @@ SUBROUTINE force_env_create(force_env,root_section,para_env,globenv,fist_env,& IF (PRESENT(meta_env)) THEN force_env%meta_env => meta_env - CALL meta_env_retain(meta_env,error=error) + CALL meta_env_retain(meta_env) ELSE NULLIFY(force_env%meta_env) END IF @@ -783,7 +768,6 @@ END SUBROUTINE force_env_create !> Computes energy and forces for a mixed force_env type !> \param force_env ... !> \param calculate_forces ... -!> \param error ... !> \par History !> 11.06 created [fschiff] !> 04.07 generalization to an illimited number of force_eval [tlaino] @@ -792,11 +776,10 @@ END SUBROUTINE force_env_create !> 04.08 reorganizing the genmix structure (collecting common code) !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) + SUBROUTINE mixed_energy_forces(force_env, calculate_forces) TYPE(force_env_type), POINTER :: force_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixed_energy_forces', & routineP = moduleN//':'//routineN @@ -834,48 +817,46 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) TYPE(virial_type), POINTER :: loc_virial, virial_mix failure=.FALSE. - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) ! Get infos about the mixed subsys CALL force_env_get(force_env=force_env,& subsys=subsys_mix,& force_env_section=force_env_section,& root_section=root_section,& - cell=cell_mix,& - error=error) + cell=cell_mix) CALL cp_subsys_get(subsys=subsys_mix,& particles=particles_mix,& virial=virial_mix,& - results=results_mix,& - error=error) + results=results_mix) NULLIFY(map_index, glob_natoms, global_forces) nforce_eval = SIZE(force_env%sub_force_env) - mixed_section => section_vals_get_subs_vals(force_env_section,"MIXED",error=error) - mapping_section => section_vals_get_subs_vals(mixed_section,"MAPPING",error=error) + mixed_section => section_vals_get_subs_vals(force_env_section,"MIXED") + mapping_section => section_vals_get_subs_vals(mixed_section,"MAPPING") ! Global Info ALLOCATE(subsystems(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(particles(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Local Info to sync ALLOCATE(global_forces(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(energies(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(glob_natoms(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(virials(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(results(nforce_eval), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) energies = 0.0_dp glob_natoms = 0 DO iforce_eval = 1, nforce_eval NULLIFY(subsystems(iforce_eval)%subsys, particles(iforce_eval)%list) NULLIFY(results(iforce_eval)%results, virials(iforce_eval)%virial) - CALL virial_create (virials(iforce_eval)%virial, error) - CALL cp_result_create (results(iforce_eval)%results, error) + CALL virial_create (virials(iforce_eval)%virial) + CALL cp_result_create (results(iforce_eval)%results) IF (.NOT.ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) CYCLE ! From this point on the error is the sub_error my_group = force_env%mixed_env%group_distribution(force_env%para_env%mepos) @@ -886,19 +867,19 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) ! Get all available subsys CALL force_env_get(force_env=force_env%sub_force_env(iforce_eval)%force_env,& - subsys=subsystems(iforce_eval)%subsys, error=error) + subsys=subsystems(iforce_eval)%subsys) ! all force_env share the same cell - CALL cp_subsys_set(subsystems(iforce_eval)%subsys, cell=cell_mix, error=error) + CALL cp_subsys_set(subsystems(iforce_eval)%subsys, cell=cell_mix) ! Get available particles CALL cp_subsys_get(subsys=subsystems(iforce_eval)%subsys,& - particles=particles(iforce_eval)%list,error=error) + particles=particles(iforce_eval)%list) ! Get Mapping index array natom = SIZE(particles(iforce_eval)%list%els) CALL get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, & - map_index, error) + map_index) ! Mapping particles from iforce_eval environment to the mixed env DO iparticle = 1, natom @@ -909,24 +890,23 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) ! Calculate energy and forces for each sub_force_env CALL force_env_calc_energy_force(force_env%sub_force_env(iforce_eval)%force_env,& calc_force=calculate_forces,& - skip_external_control=.TRUE.,& - error=error) + skip_external_control=.TRUE.) ! Only the rank 0 process collect info for each computation IF ( force_env%sub_force_env(iforce_eval)%force_env%para_env%mepos==& force_env%sub_force_env(iforce_eval)%force_env%para_env%source) THEN CALL force_env_get(force_env%sub_force_env(iforce_eval)%force_env,& - potential_energy=energy,error=error) + potential_energy=energy) CALL cp_subsys_get(subsystems(iforce_eval)%subsys,& - virial=loc_virial, results=loc_results, error=error) + virial=loc_virial, results=loc_results) energies(iforce_eval) = energy glob_natoms(iforce_eval) = natom CALL cp_virial(loc_virial, virials(iforce_eval)%virial) - CALL cp_result_copy(loc_results, results(iforce_eval)%results, error) + CALL cp_result_copy(loc_results, results(iforce_eval)%results) END IF ! Deallocate map_index array IF (ASSOCIATED(map_index)) THEN DEALLOCATE(map_index, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF CALL cp_rm_default_logger() END DO @@ -939,7 +919,7 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) ! Transfer forces DO iforce_eval = 1, nforce_eval ALLOCATE(global_forces(iforce_eval)%forces(3,glob_natoms(iforce_eval)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) global_forces(iforce_eval)%forces = 0.0_dp IF (ASSOCIATED(force_env%sub_force_env(iforce_eval)%force_env)) THEN IF ( force_env%sub_force_env(iforce_eval)%force_env%para_env%mepos==& @@ -967,14 +947,13 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) source=force_env%para_env%mepos ENDIF CALL mp_sum(source, force_env%para_env%group) - CALL cp_results_mp_bcast(results(iforce_eval)%results, source, force_env%para_env, error) + CALL cp_results_mp_bcast(results(iforce_eval)%results, source, force_env%para_env) END DO force_env%mixed_env%energies = energies ! Start combining the different sub_force_env CALL get_mixed_env(mixed_env=force_env%mixed_env,& - mixed_energy=mixed_energy,& - error=error) + mixed_energy=mixed_energy) !NB: do this for all MIXING_TYPE values, since some need it (e.g. linear mixing !NB if the first system has fewer atoms than the second) @@ -982,74 +961,74 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) particles_mix%els(iparticle)%f(:) = 0.0_dp END DO - CALL section_vals_val_get(mixed_section,"MIXING_TYPE",i_val=mixing_type,error=error) + CALL section_vals_val_get(mixed_section,"MIXING_TYPE",i_val=mixing_type) SELECT CASE(mixing_type) CASE(mix_linear_combination) ! Support offered only 2 force_eval - CPPrecondition(nforce_eval==2,cp_failure_level,routineP,error,failure) - CALL section_vals_val_get(mixed_section,"LINEAR%LAMBDA",r_val=lambda,error=error) + CPPrecondition(nforce_eval==2,cp_failure_level,routineP,failure) + CALL section_vals_val_get(mixed_section,"LINEAR%LAMBDA",r_val=lambda) mixed_energy%pot=lambda*energies(1) + (1.0_dp-lambda)*energies(2) ! General Mapping of forces... CALL mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces, virials, results,& - lambda, 1, nforce_eval, map_index, mapping_section, .TRUE., error) + lambda, 1, nforce_eval, map_index, mapping_section, .TRUE.) CALL mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces, virials, results,& - (1.0_dp-lambda), 2, nforce_eval, map_index, mapping_section, .FALSE., error) + (1.0_dp-lambda), 2, nforce_eval, map_index, mapping_section, .FALSE.) CASE(mix_minimum) ! Support offered only 2 force_eval - CPPrecondition(nforce_eval==2,cp_failure_level,routineP,error,failure) + CPPrecondition(nforce_eval==2,cp_failure_level,routineP,failure) IF (energies(1) section_vals_get_subs_vals(mixed_section,"GENERIC",error=error) + gen_section => section_vals_get_subs_vals(mixed_section,"GENERIC") CALL get_generic_info(gen_section, "MIXING_FUNCTION", coupling_function, force_env%mixed_env%par,& - force_env%mixed_env%val, energies, error=error) + force_env%mixed_env%val, energies) CALL initf(1) CALL parsef(1,TRIM(coupling_function),force_env%mixed_env%par) ! Now the hardest part.. map energy with corresponding force_eval mixed_energy%pot= evalf(1,force_env%mixed_env%val) - CPPrecondition(EvalErrType<=0,cp_failure_level,routineP,error,failure) + CPPrecondition(EvalErrType<=0,cp_failure_level,routineP,failure) CALL zero_virial(virial_mix, reset=.FALSE.) - CALL cp_results_erase(results_mix, error=error) + CALL cp_results_erase(results_mix) DO iforce_eval = 1, nforce_eval - CALL section_vals_val_get(gen_section,"DX",r_val=dx,error=error) - CALL section_vals_val_get(gen_section,"ERROR_LIMIT",r_val=lerr,error=error) + CALL section_vals_val_get(gen_section,"DX",r_val=dx) + CALL section_vals_val_get(gen_section,"ERROR_LIMIT",r_val=lerr) dedf = evalfd(1,iforce_eval,force_env%mixed_env%val,dx,err) IF (ABS(err)>lerr) THEN WRITE(this_error,"(A,G12.6,A)")"(",err,")" @@ -1059,11 +1038,11 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) CALL cp_assert(.FALSE.,cp_warning_level,-300,routineP,& 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& ' Error '//TRIM(this_error)//' in computing numerical derivatives larger then'//& - TRIM(def_error)//' .',error=error,only_ionode=.TRUE.) + TRIM(def_error)//' .',only_ionode=.TRUE.) END IF ! General Mapping of forces... CALL mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces, virials, results,& - dedf, iforce_eval, nforce_eval, map_index, mapping_section, .FALSE., error) + dedf, iforce_eval, nforce_eval, map_index, mapping_section, .FALSE.) force_env%mixed_env%val(iforce_eval) = energies(iforce_eval) END DO ! Let's store the needed information.. @@ -1072,44 +1051,44 @@ SUBROUTINE mixed_energy_forces(force_env, calculate_forces, error) force_env%mixed_env%coupling_function = TRIM(coupling_function) CALL finalizef() CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT !Simply deallocate and loose the pointer references.. DO iforce_eval = 1, nforce_eval DEALLOCATE(global_forces(iforce_eval)%forces,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL virial_release(virials(iforce_eval)%virial, error=error) - CALL cp_result_release(results(iforce_eval)%results, error=error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL virial_release(virials(iforce_eval)%virial) + CALL cp_result_release(results(iforce_eval)%results) END DO DEALLOCATE(global_forces, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(subsystems, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(particles, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(energies, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(glob_natoms, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(virials, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(results, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Print Section unit_nr=cp_print_key_unit_nr(logger,mixed_section,"PRINT%DIPOLE",& - extension=".data",middle_name="MIXED_DIPOLE",log_filename=.FALSE.,error=error) + extension=".data",middle_name="MIXED_DIPOLE",log_filename=.FALSE.) IF (unit_nr>0) THEN description ='[DIPOLE]' - dip_exists = test_for_result(results=results_mix,description=description, error=error) + dip_exists = test_for_result(results=results_mix,description=description) IF (dip_exists) THEN - CALL get_results(results=results_mix,description=description,values=dip_mix,error=error) + CALL get_results(results=results_mix,description=description,values=dip_mix) WRITE(unit_nr,'(/,1X,A,T48,3F11.6)')"MIXED ENV| DIPOLE ( A.U.)|",dip_mix WRITE(unit_nr,'( 1X,A,T48,3F11.6)')"MIXED ENV| DIPOLE (Debye)|",dip_mix*debye ELSE WRITE(unit_nr,*) "NO FORCE_EVAL section calculated the dipole" END IF END IF - CALL cp_print_key_finished_output(unit_nr,logger,mixed_section,"PRINT%DIPOLE",error=error) + CALL cp_print_key_finished_output(unit_nr,logger,mixed_section,"PRINT%DIPOLE") END SUBROUTINE mixed_energy_forces END MODULE force_env_methods diff --git a/src/force_env_types.F b/src/force_env_types.F index 7f2c9922e6..3beca1e6b8 100644 --- a/src/force_env_types.F +++ b/src/force_env_types.F @@ -155,17 +155,14 @@ MODULE force_env_types ! ***************************************************************************** !> \brief retains the given force env !> \param force_env the force environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE force_env_retain(force_env, error) + SUBROUTINE force_env_retain(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_retain', & routineP = moduleN//':'//routineN @@ -174,25 +171,22 @@ SUBROUTINE force_env_retain(force_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(force_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(force_env%ref_count>0,cp_failure_level,routineP) force_env%ref_count=force_env%ref_count+1 END SUBROUTINE force_env_retain ! ***************************************************************************** !> \brief releases the given force env !> \param force_env the force environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - RECURSIVE SUBROUTINE force_env_release(force_env, error) + RECURSIVE SUBROUTINE force_env_release(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_release', & routineP = moduleN//':'//routineN @@ -203,7 +197,7 @@ RECURSIVE SUBROUTINE force_env_release(force_env, error) failure=.FALSE. IF (ASSOCIATED(force_env)) THEN - CPPreconditionNoFail(force_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(force_env%ref_count>0,cp_failure_level,routineP) force_env%ref_count=force_env%ref_count-1 IF (force_env%ref_count==0) THEN ! Deallocate SUB_FORCE_ENV @@ -216,39 +210,39 @@ RECURSIVE SUBROUTINE force_env_release(force_env, error) my_logger => force_env%mixed_env%sub_logger(my_group+1)%p CALL cp_add_default_logger(my_logger) END IF - CALL force_env_release(force_env%sub_force_env(i)%force_env,error=error) + CALL force_env_release(force_env%sub_force_env(i)%force_env) IF (force_env%in_use==use_mixed_force) & CALL cp_rm_default_logger() END DO DEALLOCATE(force_env%sub_force_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF SELECT CASE ( force_env%in_use ) CASE ( use_fist_force ) - CALL fist_env_release(force_env%fist_env,error=error) + CALL fist_env_release(force_env%fist_env) CASE ( use_qs_force ) - CALL qs_env_release(force_env%qs_env,error=error) + CALL qs_env_release(force_env%qs_env) CASE ( use_eip_force ) - CALL eip_env_release(force_env%eip_env, error=error) + CALL eip_env_release(force_env%eip_env) CASE (use_mixed_force) - CALL mixed_env_release(force_env%mixed_env,error=error) + CALL mixed_env_release(force_env%mixed_env) END SELECT - CALL globenv_release(force_env%globenv,error=error) - CALL cp_para_env_release(force_env%para_env,error=error) + CALL globenv_release(force_env%globenv) + CALL cp_para_env_release(force_env%para_env) ! Not deallocated - CPAssert(.NOT.ASSOCIATED(force_env%fist_env),cp_warning_level,routineP,error,failure) - CPAssert(.NOT.ASSOCIATED(force_env%qs_env),cp_warning_level,routineP,error,failure) - CPAssert(.NOT.ASSOCIATED(force_env%eip_env),cp_warning_level,routineP,error,failure) - CPAssert(.NOT.ASSOCIATED(force_env%mixed_env),cp_warning_level,routineP,error,failure) - CALL meta_env_release(force_env%meta_env,error=error) - CALL fp_env_release(force_env%fp_env,error=error) - CALL qmmm_env_release(force_env%qmmm_env,error=error) - CALL qmmmx_env_release(force_env%qmmmx_env,error=error) - CALL section_vals_release(force_env%force_env_section,error=error) - CALL section_vals_release(force_env%root_section,error=error) + CPAssert(.NOT.ASSOCIATED(force_env%fist_env),cp_warning_level,routineP,failure) + CPAssert(.NOT.ASSOCIATED(force_env%qs_env),cp_warning_level,routineP,failure) + CPAssert(.NOT.ASSOCIATED(force_env%eip_env),cp_warning_level,routineP,failure) + CPAssert(.NOT.ASSOCIATED(force_env%mixed_env),cp_warning_level,routineP,failure) + CALL meta_env_release(force_env%meta_env) + CALL fp_env_release(force_env%fp_env) + CALL qmmm_env_release(force_env%qmmm_env) + CALL qmmmx_env_release(force_env%qmmmx_env) + CALL section_vals_release(force_env%force_env_section) + CALL section_vals_release(force_env%root_section) DEALLOCATE(force_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(force_env) @@ -280,9 +274,6 @@ END SUBROUTINE force_env_release !> \param method_name_id ... !> \param root_section ... !> \param mixed_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> for the orther arguments see the attributes of force_env_type !> \par History !> 04.2003 created [fawzi] !> \author fawzi @@ -291,7 +282,7 @@ RECURSIVE SUBROUTINE force_env_get(force_env, in_use, fist_env, qs_env, & meta_env, fp_env, subsys, para_env, potential_energy, additional_potential, & kinetic_energy, harmonic_shell, kinetic_shell, cell, sub_force_env,& qmmm_env, qmmmx_env, eip_env, globenv, input, force_env_section, & - method_name_id, root_section, mixed_env, error) + method_name_id, root_section, mixed_env) TYPE(force_env_type), POINTER :: force_env INTEGER, INTENT(out), OPTIONAL :: in_use TYPE(fist_environment_type), OPTIONAL, & @@ -321,7 +312,6 @@ RECURSIVE SUBROUTINE force_env_get(force_env, in_use, fist_env, qs_env, & POINTER :: root_section TYPE(mixed_environment_type), OPTIONAL, & POINTER :: mixed_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_get', & routineP = moduleN//':'//routineN @@ -338,76 +328,70 @@ RECURSIVE SUBROUTINE force_env_get(force_env, in_use, fist_env, qs_env, & failure=.FALSE. - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,failure) SELECT CASE(force_env%in_use) CASE (use_qs_force) - CPPrecondition(ASSOCIATED(force_env%qs_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(.NOT.PRESENT(fist_env),cp_warning_level,routineP,error) - CPPreconditionNoFail(.NOT.PRESENT(eip_env),cp_warning_level,routineP,error) + CPPrecondition(ASSOCIATED(force_env%qs_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(.NOT.PRESENT(fist_env),cp_warning_level,routineP) + CPPreconditionNoFail(.NOT.PRESENT(eip_env),cp_warning_level,routineP) CALL get_qs_env(force_env%qs_env,& energy=qs_energy,& input=input,& - cp_subsys=subsys,& - error=error) + cp_subsys=subsys) IF (PRESENT(potential_energy)) potential_energy = qs_energy%total - CPPrecondition(.NOT.PRESENT(kinetic_energy),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(kinetic_energy),cp_failure_level,routineP,failure) CASE (use_fist_force) - CPPrecondition(ASSOCIATED(force_env%fist_env),cp_failure_level,routineP,error,failure) -! CPPreconditionNoFail(.NOT.PRESENT(qs_env),cp_warning_level,routineP,error) -! CPPreconditionNoFail(.NOT.PRESENT(eip_env),cp_warning_level,routineP,error) - CPPrecondition(.NOT.PRESENT(input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env%fist_env),cp_failure_level,routineP,failure) +! CPPreconditionNoFail(.NOT.PRESENT(qs_env),cp_warning_level,routineP) +! CPPreconditionNoFail(.NOT.PRESENT(eip_env),cp_warning_level,routineP) + CPPrecondition(.NOT.PRESENT(input),cp_failure_level,routineP,failure) CALL fist_env_get(force_env%fist_env,& thermo=thermo,& - subsys=subsys,& - error=error) + subsys=subsys) IF (PRESENT(potential_energy)) potential_energy = thermo%pot IF (PRESENT(kinetic_energy)) kinetic_energy = thermo%kin IF (PRESENT(kinetic_shell)) kinetic_shell = thermo%kin_shell IF (PRESENT(harmonic_shell)) harmonic_shell = thermo%harm_shell CASE (use_eip_force) - CPPrecondition(ASSOCIATED(force_env%eip_env), cp_failure_level, routineP, error, failure) - CPPreconditionNoFail(.NOT. PRESENT(qs_env), cp_warning_level, routineP, error) - CPPreconditionNoFail(.NOT. PRESENT(fist_env), cp_warning_level, routineP, error) + CPPrecondition(ASSOCIATED(force_env%eip_env), cp_failure_level, routineP,failure) + CPPreconditionNoFail(.NOT. PRESENT(qs_env), cp_warning_level, routineP) + CPPreconditionNoFail(.NOT. PRESENT(fist_env), cp_warning_level, routineP) CALL eip_env_get(force_env%eip_env,& eip_potential_energy=eip_potential_energy,& eip_kinetic_energy=eip_kinetic_energy,& - subsys=subsys,& - error=error) + subsys=subsys) IF (PRESENT(potential_energy)) THEN potential_energy = eip_potential_energy END IF IF (PRESENT(kinetic_energy)) kinetic_energy = eip_kinetic_energy - CPPrecondition(.NOT.PRESENT(kinetic_energy),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(kinetic_energy),cp_failure_level,routineP,failure) CASE (use_qmmm) CALL qmmm_env_get(force_env%qmmm_env,& subsys=subsys,& potential_energy=potential_energy,& - kinetic_energy=kinetic_energy,& - error=error) + kinetic_energy=kinetic_energy) CASE (use_qmmmx) CALL qmmmx_env_get(force_env%qmmmx_env,& subsys=subsys,& potential_energy=potential_energy,& - kinetic_energy=kinetic_energy,& - error=error) + kinetic_energy=kinetic_energy) CASE (use_mixed_force) - CPPrecondition(ASSOCIATED(force_env%mixed_env),cp_failure_level,routineP,error,failure) -! CPPreconditionNoFail(.NOT.PRESENT(qs_env),cp_warning_level,routineP,error) -! CPPreconditionNoFail(.NOT.PRESENT(eip_env),cp_warning_level,routineP,error) - CPPrecondition(.NOT.PRESENT(input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env%mixed_env),cp_failure_level,routineP,failure) +! CPPreconditionNoFail(.NOT.PRESENT(qs_env),cp_warning_level,routineP) +! CPPreconditionNoFail(.NOT.PRESENT(eip_env),cp_warning_level,routineP) + CPPrecondition(.NOT.PRESENT(input),cp_failure_level,routineP,failure) CALL get_mixed_env(force_env%mixed_env,& mixed_energy=mixed_energy,& - subsys=subsys,& - error=error) + subsys=subsys) IF (PRESENT(potential_energy)) potential_energy = mixed_energy%pot IF (PRESENT(kinetic_energy)) kinetic_energy = mixed_energy%kin CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown in_use flag value "//& CPSourceFileRef,& - error,failure) + failure) END SELECT IF (PRESENT(force_env_section)) force_env_section => force_env%force_env_section @@ -448,8 +432,8 @@ RECURSIVE SUBROUTINE force_env_get(force_env, in_use, fist_env, qs_env, & additional_potential = force_env%additional_potential END IF IF (PRESENT(cell)) THEN - CALL force_env_get(force_env, subsys=subsys_tmp, error=error) - CALL cp_subsys_get(subsys_tmp, cell=cell, error=error) + CALL force_env_get(force_env, subsys=subsys_tmp) + CALL cp_subsys_get(subsys_tmp, cell=cell) END IF IF (PRESENT(fp_env)) fp_env => force_env%fp_env IF (PRESENT(meta_env)) meta_env => force_env%meta_env @@ -465,16 +449,13 @@ END SUBROUTINE force_env_get ! ***************************************************************************** !> \brief returns the number of atoms !> \param force_env the force_env you what information about -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval n_atom the number of atoms !> \date 22.11.2010 updated (MK) !> \author fawzi ! ***************************************************************************** - FUNCTION force_env_get_natom(force_env,error) RESULT(n_atom) + FUNCTION force_env_get_natom(force_env) RESULT(n_atom) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: n_atom CHARACTER(LEN=*), PARAMETER :: routineN = 'force_env_get_natom', & @@ -486,24 +467,21 @@ FUNCTION force_env_get_natom(force_env,error) RESULT(n_atom) failure = .FALSE. n_atom = 0 NULLIFY (subsys) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,natom=n_atom,error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,natom=n_atom) END FUNCTION force_env_get_natom ! ***************************************************************************** !> \brief returns the number of particles in a force environment !> \param force_env the force_env you what information about -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval n_particle the number of particles !> \date 22.11.2010 (MK) !> \author Matthias Krack ! ***************************************************************************** - FUNCTION force_env_get_nparticle(force_env,error) RESULT(n_particle) + FUNCTION force_env_get_nparticle(force_env) RESULT(n_particle) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: n_particle CHARACTER(LEN=*), PARAMETER :: routineN = 'force_env_get_nparticle', & @@ -515,8 +493,8 @@ FUNCTION force_env_get_nparticle(force_env,error) RESULT(n_particle) failure = .FALSE. n_particle = 0 NULLIFY (subsys) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,nparticle=n_particle,error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,nparticle=n_particle) END FUNCTION force_env_get_nparticle @@ -525,17 +503,14 @@ END FUNCTION force_env_get_nparticle !> \param force_env the force_env you want to get the forces !> \param frc the array of the forces !> \param n ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 22.11.2010 Creation !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE force_env_get_frc(force_env,frc,n,error) + SUBROUTINE force_env_get_frc(force_env,frc,n) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: frc INTEGER, INTENT(IN) :: n - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'force_env_get_frc', & routineP = moduleN//':'//routineN @@ -546,10 +521,10 @@ SUBROUTINE force_env_get_frc(force_env,frc,n,error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition((force_env%ref_count > 0),cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL pack_subsys_particles(subsys=subsys,f=frc(1:n),error=error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition((force_env%ref_count > 0),cp_failure_level,routineP,failure) + CALL force_env_get(force_env,subsys=subsys) + CALL pack_subsys_particles(subsys=subsys,f=frc(1:n)) CALL timestop(handle) END SUBROUTINE force_env_get_frc @@ -559,17 +534,14 @@ END SUBROUTINE force_env_get_frc !> \param force_env the force_env you want to get the positions !> \param pos the array of the positions !> \param n ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 22.11.2010 updated (MK) !> \author fawzi ! ***************************************************************************** - SUBROUTINE force_env_get_pos(force_env,pos,n,error) + SUBROUTINE force_env_get_pos(force_env,pos,n) TYPE(force_env_type), POINTER :: force_env REAL(kind=dp), DIMENSION(*), INTENT(OUT) :: pos INTEGER, INTENT(IN) :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'force_env_get_pos', & routineP = moduleN//':'//routineN @@ -580,10 +552,10 @@ SUBROUTINE force_env_get_pos(force_env,pos,n,error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition((force_env%ref_count > 0),cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL pack_subsys_particles(subsys=subsys,r=pos(1:n),error=error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition((force_env%ref_count > 0),cp_failure_level,routineP,failure) + CALL force_env_get(force_env,subsys=subsys) + CALL pack_subsys_particles(subsys=subsys,r=pos(1:n)) CALL timestop(handle) END SUBROUTINE force_env_get_pos @@ -593,17 +565,14 @@ END SUBROUTINE force_env_get_pos !> \param force_env the force_env you want to get the velocities !> \param vel the array of the velocities !> \param n ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 22.11.2010 Creation (MK) !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE force_env_get_vel(force_env,vel,n,error) + SUBROUTINE force_env_get_vel(force_env,vel,n) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: vel INTEGER, INTENT(IN) :: n - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'force_env_get_vel', & routineP = moduleN//':'//routineN @@ -614,10 +583,10 @@ SUBROUTINE force_env_get_vel(force_env,vel,n,error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition((force_env%ref_count > 0),cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL pack_subsys_particles(subsys=subsys,v=vel(1:n),error=error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition((force_env%ref_count > 0),cp_failure_level,routineP,failure) + CALL force_env_get(force_env,subsys=subsys) + CALL pack_subsys_particles(subsys=subsys,v=vel(1:n)) CALL timestop(handle) END SUBROUTINE force_env_get_vel @@ -630,14 +599,12 @@ END SUBROUTINE force_env_get_vel !> \param force_env_section ... !> \param method_name_id ... !> \param additional_potential ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE force_env_set(force_env, meta_env,fp_env, force_env_section,& - method_name_id, additional_potential, error) + method_name_id, additional_potential) TYPE(force_env_type), POINTER :: force_env TYPE(meta_env_type), OPTIONAL, POINTER :: meta_env @@ -646,7 +613,6 @@ SUBROUTINE force_env_set(force_env, meta_env,fp_env, force_env_section,& POINTER :: force_env_section INTEGER, OPTIONAL :: method_name_id REAL(KIND=dp), INTENT(IN), OPTIONAL :: additional_potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_set', & routineP = moduleN//':'//routineN @@ -654,24 +620,24 @@ SUBROUTINE force_env_set(force_env, meta_env,fp_env, force_env_section,& LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(meta_env)) THEN IF (ASSOCIATED(meta_env)) THEN - CALL meta_env_retain(meta_env,error=error) + CALL meta_env_retain(meta_env) END IF - CALL meta_env_release(force_env%meta_env,error=error) + CALL meta_env_release(force_env%meta_env) force_env%meta_env => meta_env END IF IF (PRESENT(fp_env)) THEN - CALL fp_env_retain(fp_env,error=error) - CALL fp_env_release(force_env%fp_env,error=error) + CALL fp_env_retain(fp_env) + CALL fp_env_release(force_env%fp_env) force_env%fp_env => fp_env END IF IF (PRESENT(force_env_section)) THEN IF (ASSOCIATED(force_env_section)) THEN - CALL section_vals_retain(force_env_section,error=error) - CALL section_vals_release(force_env%force_env_section,error=error) + CALL section_vals_retain(force_env_section) + CALL section_vals_release(force_env%force_env_section) force_env%force_env_section => force_env_section END IF END IF @@ -691,17 +657,14 @@ END SUBROUTINE force_env_set !> \param root_section ... !> \param i_force_eval ... !> \param nforce_eval ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval, error) + SUBROUTINE multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval) TYPE(section_vals_type), POINTER :: force_env_sections, & root_section INTEGER, DIMENSION(:), POINTER :: i_force_eval INTEGER :: nforce_eval - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'multiple_fe_list', & routineP = moduleN//':'//routineN @@ -713,17 +676,17 @@ SUBROUTINE multiple_fe_list(force_env_sections, root_section, i_force_eval, nfor failure = .FALSE. ! Let's treat the case of Multiple force_eval - CALL section_vals_get(force_env_sections, n_repetition=nforce_eval, error=error) + CALL section_vals_get(force_env_sections, n_repetition=nforce_eval) CALL section_vals_val_get(root_section,"MULTIPLE_FORCE_EVALS%FORCE_EVAL_ORDER",& - i_vals=my_i_force_eval,error=error) + i_vals=my_i_force_eval) ALLOCATE(i_force_eval(nforce_eval),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) IF (nforce_eval>0) THEN IF (nforce_eval==SIZE(my_i_force_eval)) THEN i_force_eval = my_i_force_eval ELSE ! The difference in the amount of defined force_env MUST be one.. - CPPostcondition(nforce_eval-SIZE(my_i_force_eval)==1,cp_fatal_level,routineP,error,failure) + CPPostcondition(nforce_eval-SIZE(my_i_force_eval)==1,cp_fatal_level,routineP,failure) DO iforce_eval = 1, nforce_eval IF (ANY(my_i_force_eval==iforce_eval)) CYCLE main_force_eval = iforce_eval diff --git a/src/force_env_utils.F b/src/force_env_utils.F index 833658a116..47a1eebde1 100644 --- a/src/force_env_utils.F +++ b/src/force_env_utils.F @@ -64,12 +64,10 @@ MODULE force_env_utils !> \param vel ... !> \param compold ... !> \param reset ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm,& - pos,vel,compold,reset,error) + pos,vel,compold,reset) TYPE(force_env_type), POINTER :: force_env REAL(kind=dp), INTENT(IN), OPTIONAL :: dt @@ -79,7 +77,6 @@ SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL, TARGET :: pos, vel LOGICAL, INTENT(IN), OPTIONAL :: compold, reset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_shake', & routineP = moduleN//':'//routineN @@ -102,8 +99,8 @@ SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,failure) my_log_unit=-1 IF (PRESENT(log_unit)) my_log_unit=log_unit my_lagrange_mult=-1 @@ -116,7 +113,7 @@ SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm IF (PRESENT(vel)) my_vel => vel mydt = 0.1_dp IF (PRESENT(dt)) mydt = dt - CALL force_env_get(force_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(force_env,subsys=subsys,cell=cell) CALL cp_subsys_get(subsys, & atomic_kinds=atomic_kinds,& local_molecules_new=local_molecules,& @@ -124,20 +121,19 @@ SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm molecules_new=molecules,& molecule_kinds_new=molecule_kinds,& particles=particles,& - gci=gci,& - error=error) + gci=gci) nparticle_kind = atomic_kinds%n_els IF (PRESENT(compold)) THEN IF (compold) THEN CALL getold( gci, local_molecules, molecules%els, molecule_kinds%els,& - particles%els, cell, error) + particles%els, cell) END IF END IF has_pos=.FALSE. IF (.NOT.ASSOCIATED(my_pos)) THEN has_pos=.TRUE. ALLOCATE(my_pos(3,particles%n_els),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) my_pos = 0.0_dp DO iparticle_kind=1,nparticle_kind nparticle_local = local_particles%n_el(iparticle_kind) @@ -151,7 +147,7 @@ SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm IF (.NOT.ASSOCIATED(my_vel)) THEN has_vel=.TRUE. ALLOCATE(my_vel(3,particles%n_els),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) my_vel = 0.0_dp DO iparticle_kind=1,nparticle_kind nparticle_local = local_particles%n_el(iparticle_kind) @@ -167,7 +163,7 @@ SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm particle_set=particles%els, pos=my_pos, vel=my_vel, dt=mydt,& shake_tol=shake_tol, log_unit=my_log_unit, lagrange_mult=my_lagrange_mult,& dump_lm= my_dump_lm, cell=cell,group=force_env%para_env%group,& - local_particles=local_particles, error=error ) + local_particles=local_particles) ! Possibly reset the lagrange multipliers IF (PRESENT(reset)) THEN @@ -218,16 +214,14 @@ SUBROUTINE force_env_shake(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm END IF IF (has_pos) THEN - CALL update_particle_set ( particles%els, force_env%para_env%group, pos=my_pos,& - error=error) + CALL update_particle_set ( particles%els, force_env%para_env%group, pos=my_pos) DEALLOCATE(my_pos,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (has_vel) THEN - CALL update_particle_set ( particles%els, force_env%para_env%group, vel=my_vel,& - error=error) + CALL update_particle_set ( particles%els, force_env%para_env%group, vel=my_vel) DEALLOCATE(my_vel,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE force_env_shake @@ -246,12 +240,10 @@ END SUBROUTINE force_env_shake !> \param dump_lm ... !> \param vel ... !> \param reset ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** SUBROUTINE force_env_rattle(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_lm,& - vel,reset,error) + vel,reset) TYPE(force_env_type), POINTER :: force_env REAL(kind=dp), INTENT(in), OPTIONAL :: dt @@ -261,7 +253,6 @@ SUBROUTINE force_env_rattle(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_l REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL, TARGET :: vel LOGICAL, INTENT(IN), OPTIONAL :: reset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_env_rattle', & routineP = moduleN//':'//routineN @@ -284,8 +275,8 @@ SUBROUTINE force_env_rattle(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_l failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,failure) my_log_unit=-1 IF (PRESENT(log_unit)) my_log_unit=log_unit my_lagrange_mult=-1 @@ -297,7 +288,7 @@ SUBROUTINE force_env_rattle(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_l IF (PRESENT(vel)) my_vel => vel mydt = 0.1_dp IF (PRESENT(dt)) mydt = dt - CALL force_env_get(force_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(force_env,subsys=subsys,cell=cell) CALL cp_subsys_get(subsys, & atomic_kinds=atomic_kinds,& local_molecules_new=local_molecules,& @@ -305,14 +296,13 @@ SUBROUTINE force_env_rattle(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_l molecules_new=molecules,& molecule_kinds_new=molecule_kinds,& particles=particles,& - gci=gci,& - error=error) + gci=gci) nparticle_kind = atomic_kinds%n_els has_vel=.FALSE. IF (.NOT.ASSOCIATED(my_vel)) THEN has_vel=.TRUE. ALLOCATE(my_vel(3,particles%n_els),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) my_vel = 0.0_dp DO iparticle_kind=1,nparticle_kind nparticle_local = local_particles%n_el(iparticle_kind) @@ -328,7 +318,7 @@ SUBROUTINE force_env_rattle(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_l particle_set=particles%els, vel=my_vel, dt=mydt,& rattle_tol=shake_tol, log_unit=my_log_unit, lagrange_mult=my_lagrange_mult,& dump_lm=my_dump_lm, cell=cell, group=force_env%para_env%group,& - local_particles=local_particles, error=error ) + local_particles=local_particles) ! Possibly reset the lagrange multipliers IF (PRESENT(reset)) THEN @@ -379,24 +369,20 @@ SUBROUTINE force_env_rattle(force_env,dt,shake_tol,log_unit,lagrange_mult,dump_l END IF IF (has_vel) THEN - CALL update_particle_set ( particles%els, force_env%para_env%group, vel=my_vel,& - error=error) + CALL update_particle_set ( particles%els, force_env%para_env%group, vel=my_vel) END IF DEALLOCATE(my_vel,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CALL timestop(handle) END SUBROUTINE force_env_rattle ! ***************************************************************************** !> \brief Rescale forces if requested !> \param force_env the force env to shake -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE rescale_forces (force_env, error) + SUBROUTINE rescale_forces (force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rescale_forces', & routineP = moduleN//':'//routineN @@ -410,14 +396,14 @@ SUBROUTINE rescale_forces (force_env, error) failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,error,failure) - rescale_force_section => section_vals_get_subs_vals(force_env%force_env_section,"RESCALE_FORCES",error=error) - CALL section_vals_get(rescale_force_section, explicit=explicit, error=error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,failure) + rescale_force_section => section_vals_get_subs_vals(force_env%force_env_section,"RESCALE_FORCES") + CALL section_vals_get(rescale_force_section, explicit=explicit) IF (.NOT.failure.AND.explicit) THEN - CALL section_vals_val_get(rescale_force_section,"MAX_FORCE",r_val=max_value,error=error) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles,error=error) + CALL section_vals_val_get(rescale_force_section,"MAX_FORCE",r_val=max_value) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO iparticle = 1, SIZE(particles%els) force = particles%els(iparticle)%f(:) mod_force = SQRT(DOT_PRODUCT(force,force)) @@ -438,11 +424,9 @@ END SUBROUTINE rescale_forces !> \param cell ... !> \param ndigits ... !> \param numerical ... -!> \param error ... !> \author MK (26.08.2010) ! ***************************************************************************** - SUBROUTINE write_stress_tensor(pv_virial,output_unit,cell,ndigits,numerical,& - error) + SUBROUTINE write_stress_tensor(pv_virial,output_unit,cell,ndigits,numerical) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: pv_virial @@ -450,7 +434,6 @@ SUBROUTINE write_stress_tensor(pv_virial,output_unit,cell,ndigits,numerical,& TYPE(cell_type), POINTER :: cell INTEGER, INTENT(IN) :: ndigits LOGICAL, INTENT(IN) :: numerical - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_stress_tensor', & routineP = moduleN//':'//routineN @@ -468,7 +451,7 @@ SUBROUTINE write_stress_tensor(pv_virial,output_unit,cell,ndigits,numerical,& failure = .FALSE. IF (output_unit > 0) THEN - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) stress_tensor(:,:) = pv_virial(:,:)/cell%deth*pascal*1.0E-9_dp n = MIN(MAX(1,ndigits),20) fmtstr1 = "(/,T2,A,/,/,T13,A1,2( X,A1))" @@ -524,11 +507,10 @@ END SUBROUTINE write_stress_tensor !> \param ndigits ... !> \param total_force ... !> \param grand_total_force ... -!> \param error ... !> \author MK (06.09.2010) ! ***************************************************************************** SUBROUTINE write_forces(particles,output_unit,label,ndigits,total_force,& - grand_total_force,error) + grand_total_force) TYPE(particle_list_type), POINTER :: particles INTEGER, INTENT(IN) :: output_unit @@ -537,7 +519,6 @@ SUBROUTINE write_forces(particles,output_unit,label,ndigits,total_force,& REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: total_force REAL(KIND=dp), DIMENSION(3), & INTENT(INOUT), OPTIONAL :: grand_total_force - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_forces', & routineP = moduleN//':'//routineN @@ -551,7 +532,7 @@ SUBROUTINE write_forces(particles,output_unit,label,ndigits,total_force,& failure = .FALSE. IF (output_unit > 0) THEN - CPPrecondition(ASSOCIATED(particles),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(particles),cp_failure_level,routineP,failure) n = MIN(MAX(1,ndigits),20) fmtstr1 = "(/,T2,A,/,/,T2,A,T11,A,T18,A,T35,A1,2( X,A1))" WRITE (UNIT=fmtstr1(39:40),FMT="(I2)") n + 6 diff --git a/src/force_field_types.F b/src/force_field_types.F index 4066cd045c..0128b225ec 100644 --- a/src/force_field_types.F +++ b/src/force_field_types.F @@ -216,12 +216,10 @@ MODULE force_field_types ! ***************************************************************************** !> \brief 1. Just NULLIFY and zero all the stuff !> \param ff_type ... -!> \param error ... !> \author ikuo ! ***************************************************************************** - SUBROUTINE init_ff_type (ff_type,error) + SUBROUTINE init_ff_type (ff_type) TYPE(force_field_type), INTENT(INOUT) :: ff_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_ff_type', & routineP = moduleN//':'//routineN @@ -236,13 +234,13 @@ SUBROUTINE init_ff_type (ff_type,error) !----------------------------------------------------------------------------- NULLIFY(ff_type%inp_info,ff_type%chm_info,ff_type%amb_info,ff_type%gro_info) ALLOCATE(ff_type%inp_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ff_type%chm_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ff_type%gro_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ff_type%amb_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !----------------------------------------------------------------------------- ! 2. Initialize and Nullify things in ff_type%inp_info @@ -444,11 +442,9 @@ END SUBROUTINE init_inp_info ! ***************************************************************************** !> \brief 1. Just DEALLOCATE all the stuff !> \param ff_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_ff_type (ff_type,error) + SUBROUTINE deallocate_ff_type (ff_type) TYPE(force_field_type), INTENT(INOUT) :: ff_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_ff_type', & routineP = moduleN//':'//routineN @@ -461,41 +457,41 @@ SUBROUTINE deallocate_ff_type (ff_type,error) !----------------------------------------------------------------------------- ! 1. DEALLOCATE things in ff_type%inp_info !----------------------------------------------------------------------------- - CALL deallocate_inp_info(ff_type%inp_info, error=error) + CALL deallocate_inp_info(ff_type%inp_info) !----------------------------------------------------------------------------- ! 2. DEALLOCATE things in ff_type%chm_info !----------------------------------------------------------------------------- - CALL deallocate_chm_info(ff_type%chm_info,error) + CALL deallocate_chm_info(ff_type%chm_info) !----------------------------------------------------------------------------- ! 3. DEALLOCATE things in ff_type%gro_info !----------------------------------------------------------------------------- - CALL deallocate_gromos_info(ff_type%gro_info,error) + CALL deallocate_gromos_info(ff_type%gro_info) !----------------------------------------------------------------------------- ! 4. DEALLOCATE things in ff_type%amb_info !----------------------------------------------------------------------------- - CALL deallocate_amb_info(ff_type%amb_info,error) + CALL deallocate_amb_info(ff_type%amb_info) !----------------------------------------------------------------------------- ! 5. DEALLOCATE things in ff_type !----------------------------------------------------------------------------- IF(ASSOCIATED(ff_type%inp_info)) THEN DEALLOCATE(ff_type%inp_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(ff_type%chm_info)) THEN DEALLOCATE(ff_type%chm_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(ff_type%gro_info)) THEN DEALLOCATE(ff_type%gro_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(ff_type%amb_info)) THEN DEALLOCATE(ff_type%amb_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_ff_type @@ -503,12 +499,10 @@ END SUBROUTINE deallocate_ff_type ! ***************************************************************************** !> \brief Specific function to deallocate the gro_info !> \param gro_info ... -!> \param error ... !> \author ikuo ! ***************************************************************************** - SUBROUTINE deallocate_gromos_info(gro_info,error) + SUBROUTINE deallocate_gromos_info(gro_info) TYPE(gromos_info_type), POINTER :: gro_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_gromos_info', & routineP = moduleN//':'//routineN @@ -519,71 +513,71 @@ SUBROUTINE deallocate_gromos_info(gro_info,error) failure = .FALSE. IF(ASSOCIATED(gro_info%solvent_k)) THEN DEALLOCATE(gro_info%solvent_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%solvent_r0)) THEN DEALLOCATE(gro_info%solvent_r0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%bond_k)) THEN DEALLOCATE(gro_info%bond_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%bond_r0)) THEN DEALLOCATE(gro_info%bond_r0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%bend_k)) THEN DEALLOCATE(gro_info%bend_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%bend_theta0)) THEN DEALLOCATE(gro_info%bend_theta0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%torsion_k)) THEN DEALLOCATE(gro_info%torsion_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%torsion_m)) THEN DEALLOCATE(gro_info%torsion_m,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%torsion_phi0)) THEN DEALLOCATE(gro_info%torsion_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%impr_k)) THEN DEALLOCATE(gro_info%impr_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%impr_phi0)) THEN DEALLOCATE(gro_info%impr_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%nonbond_a)) THEN DEALLOCATE(gro_info%nonbond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%nonbond_c6)) THEN DEALLOCATE(gro_info%nonbond_c6,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%nonbond_c12)) THEN DEALLOCATE(gro_info%nonbond_c12,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%nonbond_a_14)) THEN DEALLOCATE(gro_info%nonbond_a_14,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%nonbond_c6_14)) THEN DEALLOCATE(gro_info%nonbond_c6_14,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(gro_info%nonbond_c12_14)) THEN DEALLOCATE(gro_info%nonbond_c12_14,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_gromos_info @@ -591,14 +585,12 @@ END SUBROUTINE deallocate_gromos_info ! ***************************************************************************** !> \brief Specific function to deallocate the chm_info !> \param chm_info ... -!> \param error ... !> \par History !> none !> \author teo ! ***************************************************************************** - SUBROUTINE deallocate_chm_info(chm_info,error) + SUBROUTINE deallocate_chm_info(chm_info) TYPE(charmm_info_type), POINTER :: chm_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_chm_info', & routineP = moduleN//':'//routineN @@ -609,135 +601,135 @@ SUBROUTINE deallocate_chm_info(chm_info,error) failure = .FALSE. IF(ASSOCIATED(chm_info%bond_a)) THEN DEALLOCATE(chm_info%bond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bond_b)) THEN DEALLOCATE(chm_info%bond_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bond_k)) THEN DEALLOCATE(chm_info%bond_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bond_r0)) THEN DEALLOCATE(chm_info%bond_r0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bend_a)) THEN DEALLOCATE(chm_info%bend_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bend_b)) THEN DEALLOCATE(chm_info%bend_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bend_c)) THEN DEALLOCATE(chm_info%bend_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bend_k)) THEN DEALLOCATE(chm_info%bend_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%bend_theta0)) THEN DEALLOCATE(chm_info%bend_theta0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%ub_a)) THEN DEALLOCATE(chm_info%ub_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%ub_b)) THEN DEALLOCATE(chm_info%ub_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%ub_c)) THEN DEALLOCATE(chm_info%ub_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%ub_k)) THEN DEALLOCATE(chm_info%ub_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%ub_r0)) THEN DEALLOCATE(chm_info%ub_r0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%torsion_a)) THEN DEALLOCATE(chm_info%torsion_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%torsion_b)) THEN DEALLOCATE(chm_info%torsion_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%torsion_c)) THEN DEALLOCATE(chm_info%torsion_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%torsion_d)) THEN DEALLOCATE(chm_info%torsion_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%torsion_k)) THEN DEALLOCATE(chm_info%torsion_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%torsion_m)) THEN DEALLOCATE(chm_info%torsion_m,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%torsion_phi0)) THEN DEALLOCATE(chm_info%torsion_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%impr_a)) THEN DEALLOCATE(chm_info%impr_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%impr_b)) THEN DEALLOCATE(chm_info%impr_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%impr_c)) THEN DEALLOCATE(chm_info%impr_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%impr_d)) THEN DEALLOCATE(chm_info%impr_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%impr_k)) THEN DEALLOCATE(chm_info%impr_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%impr_phi0)) THEN DEALLOCATE(chm_info%impr_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%nonbond_a)) THEN DEALLOCATE(chm_info%nonbond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%nonbond_eps)) THEN DEALLOCATE(chm_info%nonbond_eps,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%nonbond_rmin2)) THEN DEALLOCATE(chm_info%nonbond_rmin2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%nonbond_a_14)) THEN DEALLOCATE(chm_info%nonbond_a_14,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%nonbond_eps_14)) THEN DEALLOCATE(chm_info%nonbond_eps_14,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(chm_info%nonbond_rmin2_14)) THEN DEALLOCATE(chm_info%nonbond_rmin2_14,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_chm_info @@ -745,14 +737,12 @@ END SUBROUTINE deallocate_chm_info ! ***************************************************************************** !> \brief Specific function to deallocate the chm_info !> \param amb_info ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE deallocate_amb_info(amb_info,error) + SUBROUTINE deallocate_amb_info(amb_info) TYPE(amber_info_type), POINTER :: amb_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_amb_info', & routineP = moduleN//':'//routineN @@ -763,79 +753,79 @@ SUBROUTINE deallocate_amb_info(amb_info,error) failure = .FALSE. IF(ASSOCIATED(amb_info%bond_a)) THEN DEALLOCATE(amb_info%bond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bond_b)) THEN DEALLOCATE(amb_info%bond_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bond_k)) THEN DEALLOCATE(amb_info%bond_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bond_r0)) THEN DEALLOCATE(amb_info%bond_r0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bend_a)) THEN DEALLOCATE(amb_info%bend_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bend_b)) THEN DEALLOCATE(amb_info%bend_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bend_c)) THEN DEALLOCATE(amb_info%bend_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bend_k)) THEN DEALLOCATE(amb_info%bend_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%bend_theta0)) THEN DEALLOCATE(amb_info%bend_theta0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%torsion_a)) THEN DEALLOCATE(amb_info%torsion_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%torsion_b)) THEN DEALLOCATE(amb_info%torsion_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%torsion_c)) THEN DEALLOCATE(amb_info%torsion_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%torsion_d)) THEN DEALLOCATE(amb_info%torsion_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%torsion_k)) THEN DEALLOCATE(amb_info%torsion_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%torsion_m)) THEN DEALLOCATE(amb_info%torsion_m,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%torsion_phi0)) THEN DEALLOCATE(amb_info%torsion_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%nonbond_a)) THEN DEALLOCATE(amb_info%nonbond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%nonbond_eps)) THEN DEALLOCATE(amb_info%nonbond_eps,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(amb_info%nonbond_rmin2)) THEN DEALLOCATE(amb_info%nonbond_rmin2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_amb_info @@ -843,14 +833,12 @@ END SUBROUTINE deallocate_amb_info ! ***************************************************************************** !> \brief Specific function to deallocate the inp_info !> \param inp_info ... -!> \param error ... !> \par History !> none !> \author teo ! ***************************************************************************** - SUBROUTINE deallocate_inp_info(inp_info, error) + SUBROUTINE deallocate_inp_info(inp_info) TYPE(input_info_type), POINTER :: inp_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_inp_info', & routineP = moduleN//':'//routineN @@ -861,224 +849,224 @@ SUBROUTINE deallocate_inp_info(inp_info, error) failure = .FALSE. IF(ASSOCIATED(inp_info%charge_atm)) THEN DEALLOCATE(inp_info%charge_atm,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%charge)) THEN DEALLOCATE(inp_info%charge,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%apol_atm)) THEN DEALLOCATE(inp_info%apol_atm,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%apol)) THEN DEALLOCATE(inp_info%apol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%cpol_atm)) THEN DEALLOCATE(inp_info%cpol_atm,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%cpol)) THEN DEALLOCATE(inp_info%cpol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bond_kind)) THEN DEALLOCATE(inp_info%bond_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bond_a)) THEN DEALLOCATE(inp_info%bond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bond_b)) THEN DEALLOCATE(inp_info%bond_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bond_k)) THEN DEALLOCATE(inp_info%bond_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bond_r0)) THEN DEALLOCATE(inp_info%bond_r0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bond_cs)) THEN DEALLOCATE(inp_info%bond_cs,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_kind)) THEN DEALLOCATE(inp_info%bend_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_a)) THEN DEALLOCATE(inp_info%bend_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_b)) THEN DEALLOCATE(inp_info%bend_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_c)) THEN DEALLOCATE(inp_info%bend_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_k)) THEN DEALLOCATE(inp_info%bend_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_theta0)) THEN DEALLOCATE(inp_info%bend_theta0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_cb)) THEN DEALLOCATE(inp_info%bend_cb,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_r012)) THEN DEALLOCATE(inp_info%bend_r012,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_r032)) THEN DEALLOCATE(inp_info%bend_r032,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_kbs12)) THEN DEALLOCATE(inp_info%bend_kbs12,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_kbs32)) THEN DEALLOCATE(inp_info%bend_kbs32,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%bend_kss)) THEN DEALLOCATE(inp_info%bend_kss,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%ub_kind)) THEN DEALLOCATE(inp_info%ub_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%ub_a)) THEN DEALLOCATE(inp_info%ub_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%ub_b)) THEN DEALLOCATE(inp_info%ub_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%ub_c)) THEN DEALLOCATE(inp_info%ub_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%ub_k)) THEN DEALLOCATE(inp_info%ub_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%ub_r0)) THEN DEALLOCATE(inp_info%ub_r0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_kind)) THEN DEALLOCATE(inp_info%torsion_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_a)) THEN DEALLOCATE(inp_info%torsion_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_b)) THEN DEALLOCATE(inp_info%torsion_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_c)) THEN DEALLOCATE(inp_info%torsion_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_d)) THEN DEALLOCATE(inp_info%torsion_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_k)) THEN DEALLOCATE(inp_info%torsion_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_m)) THEN DEALLOCATE(inp_info%torsion_m,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%torsion_phi0)) THEN DEALLOCATE(inp_info%torsion_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%impr_kind)) THEN DEALLOCATE(inp_info%impr_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%impr_a)) THEN DEALLOCATE(inp_info%impr_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%impr_b)) THEN DEALLOCATE(inp_info%impr_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%impr_c)) THEN DEALLOCATE(inp_info%impr_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%impr_d)) THEN DEALLOCATE(inp_info%impr_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%impr_k)) THEN DEALLOCATE(inp_info%impr_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%impr_phi0)) THEN DEALLOCATE(inp_info%impr_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%opbend_kind)) THEN DEALLOCATE(inp_info%opbend_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%opbend_a)) THEN DEALLOCATE(inp_info%opbend_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%opbend_b)) THEN DEALLOCATE(inp_info%opbend_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%opbend_c)) THEN DEALLOCATE(inp_info%opbend_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%opbend_d)) THEN DEALLOCATE(inp_info%opbend_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%opbend_k)) THEN DEALLOCATE(inp_info%opbend_k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%opbend_phi0)) THEN DEALLOCATE(inp_info%opbend_phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(inp_info%nonbonded)) THEN - CALL pair_potential_p_release(inp_info%nonbonded,error=error) + CALL pair_potential_p_release(inp_info%nonbonded) END IF IF(ASSOCIATED(inp_info%nonbonded14)) THEN - CALL pair_potential_p_release(inp_info%nonbonded14,error=error) + CALL pair_potential_p_release(inp_info%nonbonded14) END IF IF(ASSOCIATED(inp_info%shell_list)) THEN - CALL shell_p_release(inp_info%shell_list,error=error) + CALL shell_p_release(inp_info%shell_list) END IF IF(ASSOCIATED(inp_info%damping_list)) THEN DEALLOCATE(inp_info%damping_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_inp_info diff --git a/src/force_fields.F b/src/force_fields.F index d4c9814ea5..ffb513f0c9 100644 --- a/src/force_fields.F +++ b/src/force_fields.F @@ -81,12 +81,11 @@ MODULE force_fields !> \param shell_particle_set ... !> \param core_particle_set ... !> \param cell ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_control(atomic_kind_set, particle_set, & molecule_kind_set, molecule_set, ewald_env, fist_nonbond_env, & root_section, para_env, qmmm, qmmm_env, subsys_section, mm_section, & - shell_particle_set, core_particle_set, cell, error) + shell_particle_set, core_particle_set, cell) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -108,7 +107,6 @@ SUBROUTINE force_field_control(atomic_kind_set, particle_set, & POINTER :: shell_particle_set, & core_particle_set TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_control', & routineP = moduleN//':'//routineN @@ -122,28 +120,28 @@ SUBROUTINE force_field_control(atomic_kind_set, particle_set, & CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") !----------------------------------------------------------------------------- ! 1. Initialize the ff_type structure type !----------------------------------------------------------------------------- - CALL init_ff_type(ff_type,error) + CALL init_ff_type(ff_type) !----------------------------------------------------------------------------- ! 2. Read in the force field section in the input file if any !----------------------------------------------------------------------------- - CALL read_force_field_section(ff_type,para_env,mm_section,error) + CALL read_force_field_section(ff_type,para_env,mm_section) !----------------------------------------------------------------------------- ! 2.1 In case exclusion 1-4 was requested, we need to modify the values of ! the scale factors setting them to zero.. !----------------------------------------------------------------------------- - topology_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY",error=error) - CALL section_vals_val_get(topology_section,"EXCLUDE_VDW",i_val=exclude_vdw,error=error) - CALL section_vals_val_get(topology_section,"EXCLUDE_EI",i_val=exclude_ei,error=error) + topology_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY") + CALL section_vals_val_get(topology_section,"EXCLUDE_VDW",i_val=exclude_vdw) + CALL section_vals_val_get(topology_section,"EXCLUDE_EI",i_val=exclude_ei) IF (exclude_vdw==do_skip_14) ff_type%vdw_scale14 = 0.0_dp IF (exclude_ei ==do_skip_14) ff_type%ei_scale14 = 0.0_dp @@ -169,11 +167,11 @@ SUBROUTINE force_field_control(atomic_kind_set, particle_set, & !----------------------------------------------------------------------------- SELECT CASE (ff_type%ff_type) CASE (do_ff_charmm) - CALL read_force_field_charmm(ff_type,para_env,mm_section,error) + CALL read_force_field_charmm(ff_type,para_env,mm_section) CASE (do_ff_amber) - CALL read_force_field_amber(ff_type,para_env,mm_section,particle_set,error) + CALL read_force_field_amber(ff_type,para_env,mm_section,particle_set) CASE (do_ff_g87,do_ff_g96) - CALL read_force_field_gromos(ff_type,para_env,mm_section,error) + CALL read_force_field_gromos(ff_type,para_env,mm_section) CASE (do_ff_undef) ! Do Nothing CASE DEFAULT @@ -184,7 +182,7 @@ SUBROUTINE force_field_control(atomic_kind_set, particle_set, & !----------------------------------------------------------------------------- ! 5. Possibly print the top file !----------------------------------------------------------------------------- - CALL print_pot_parameter_file(ff_type, mm_section, error) + CALL print_pot_parameter_file(ff_type, mm_section) !----------------------------------------------------------------------------- ! 6. Pack all force field info into different structures @@ -192,26 +190,26 @@ SUBROUTINE force_field_control(atomic_kind_set, particle_set, & CALL force_field_pack (particle_set,atomic_kind_set, molecule_kind_set,molecule_set,& ewald_env,fist_nonbond_env,ff_type,root_section, qmmm, qmmm_env, mm_section,& subsys_section, shell_particle_set=shell_particle_set, & - core_particle_set=core_particle_set, cell=cell, error=error) + core_particle_set=core_particle_set, cell=cell) !----------------------------------------------------------------------------- ! 7. Output total system charge assigned to qeff !----------------------------------------------------------------------------- CALL force_field_qeff_output (particle_set, molecule_kind_set,& - molecule_set, mm_section, fist_nonbond_env%charges, error) + molecule_set, mm_section, fist_nonbond_env%charges) !----------------------------------------------------------------------------- ! 8. Clean up "UNSET" bond,bend,UB,TORSION,IMPR,ONFO kinds !----------------------------------------------------------------------------- - CALL clean_intra_force_kind (molecule_kind_set,mm_section,error) + CALL clean_intra_force_kind (molecule_kind_set,mm_section) !----------------------------------------------------------------------------- ! 9. Cleanup the ff_type structure type !----------------------------------------------------------------------------- - CALL deallocate_ff_type(ff_type, error=error) + CALL deallocate_ff_type(ff_type) CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%FF_INFO",error=error) + "PRINT%FF_INFO") CALL timestop(handle) END SUBROUTINE force_field_control @@ -220,14 +218,12 @@ END SUBROUTINE force_field_control !> \brief Prints force field information in a pot file !> \param ff_type ... !> \param mm_section ... -!> \param error ... !> \author Teodoro Laino [tlaino, teodoro.laino-AT-gmail.com] - 11.2008 ! ***************************************************************************** - SUBROUTINE print_pot_parameter_file(ff_type, mm_section, error) + SUBROUTINE print_pot_parameter_file(ff_type, mm_section) TYPE(force_field_type) :: ff_type TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_pot_parameter_file', & routineP = moduleN//':'//routineN @@ -240,11 +236,11 @@ SUBROUTINE print_pot_parameter_file(ff_type, mm_section, error) CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,mm_section,"PRINT%FF_PARAMETER_FILE",& - error=error),cp_p_file)) THEN + logger => cp_get_default_logger() + IF (BTEST(cp_print_key_should_output(logger%iter_info,mm_section,"PRINT%FF_PARAMETER_FILE")& + ,cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_PARAMETER_FILE",& - middle_name="force_field",extension=".pot",error=error) + middle_name="force_field",extension=".pot") IF (iw>0) THEN ! Header WRITE(iw,1000)"Force Field Parameter File dumped into CHARMM FF style" @@ -253,14 +249,14 @@ SUBROUTINE print_pot_parameter_file(ff_type, mm_section, error) CASE (do_ff_charmm) CALL cp_unimplemented_error(fromWhere=routineP, & message="Dumping FF parameter file for CHARMM FF not implemented!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) CASE (do_ff_amber) IF (iw>0) THEN ! Bonds WRITE(iw,1001) DO i = 1, SIZE(ff_type%amb_info%bond_a) - k = cp_unit_from_cp2k(ff_type%amb_info%bond_k(i),"kcalmol*angstrom^-2",error=error) - r0= cp_unit_from_cp2k(ff_type%amb_info%bond_r0(i),"angstrom",error=error) + k = cp_unit_from_cp2k(ff_type%amb_info%bond_k(i),"kcalmol*angstrom^-2") + r0= cp_unit_from_cp2k(ff_type%amb_info%bond_r0(i),"angstrom") WRITE(iw, 2001) ff_type%amb_info%bond_a(i),& ff_type%amb_info%bond_b(i),& k, r0 @@ -268,8 +264,8 @@ SUBROUTINE print_pot_parameter_file(ff_type, mm_section, error) ! Angles WRITE(iw,1002) DO i = 1, SIZE(ff_type%amb_info%bend_a) - k = cp_unit_from_cp2k(ff_type%amb_info%bend_k(i),"kcalmol*rad^-2",error=error) - theta0 = cp_unit_from_cp2k(ff_type%amb_info%bend_theta0(i),"deg",error=error) + k = cp_unit_from_cp2k(ff_type%amb_info%bend_k(i),"kcalmol*rad^-2") + theta0 = cp_unit_from_cp2k(ff_type%amb_info%bend_theta0(i),"deg") WRITE(iw, 2002) ff_type%amb_info%bend_a(i),& ff_type%amb_info%bend_b(i),& ff_type%amb_info%bend_c(i),& @@ -278,9 +274,9 @@ SUBROUTINE print_pot_parameter_file(ff_type, mm_section, error) ! Torsions WRITE(iw,1003) DO i = 1, SIZE(ff_type%amb_info%torsion_a) - k = cp_unit_from_cp2k(ff_type%amb_info%torsion_k(i),"kcalmol",error=error) + k = cp_unit_from_cp2k(ff_type%amb_info%torsion_k(i),"kcalmol") m = ff_type%amb_info%torsion_m(i) - phi0 = cp_unit_from_cp2k(ff_type%amb_info%torsion_phi0(i),"deg",error=error) + phi0 = cp_unit_from_cp2k(ff_type%amb_info%torsion_phi0(i),"deg") WRITE(iw, 2003) ff_type%amb_info%torsion_a(i),& ff_type%amb_info%torsion_b(i),& ff_type%amb_info%torsion_c(i),& @@ -290,8 +286,8 @@ SUBROUTINE print_pot_parameter_file(ff_type, mm_section, error) ! Lennard-Jones WRITE(iw,1005) DO i = 1, SIZE(ff_type%amb_info%nonbond_a) - eps = cp_unit_from_cp2k(ff_type%amb_info%nonbond_eps(i),"kcalmol",error=error) - sigma = cp_unit_from_cp2k(ff_type%amb_info%nonbond_rmin2(i),"angstrom", error=error) + eps = cp_unit_from_cp2k(ff_type%amb_info%nonbond_eps(i),"kcalmol") + sigma = cp_unit_from_cp2k(ff_type%amb_info%nonbond_rmin2(i),"angstrom") WRITE(iw, 2005) ff_type%amb_info%nonbond_a(i),& eps, sigma END DO @@ -299,17 +295,17 @@ SUBROUTINE print_pot_parameter_file(ff_type, mm_section, error) CASE (do_ff_g87,do_ff_g96) CALL cp_unimplemented_error(fromWhere=routineP, & message="Dumping FF parameter file for GROMOS FF not implemented!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) CASE (do_ff_undef) CALL cp_unimplemented_error(fromWhere=routineP, & message="Dumping FF parameter file for INPUT FF not implemented!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END SELECT IF (iw>0) THEN WRITE(iw,'(/,A)')"END" END IF CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%FF_PARAMETER_FILE",error=error) + "PRINT%FF_PARAMETER_FILE") END IF CALL timestop(handle) RETURN diff --git a/src/force_fields_all.F b/src/force_fields_all.F index fa23a1ceba..7617e65546 100644 --- a/src/force_fields_all.F +++ b/src/force_fields_all.F @@ -127,10 +127,9 @@ MODULE force_fields_all !> \param molecule_kind_set ... !> \param molecule_set ... !> \param ff_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_unique_bond (particle_set, & - molecule_kind_set, molecule_set, ff_type, error) + molecule_kind_set, molecule_set, ff_type) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -139,7 +138,6 @@ SUBROUTINE force_field_unique_bond (particle_set, & TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set TYPE(force_field_type), INTENT(INOUT) :: ff_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_unique_bond', & routineP = moduleN//':'//routineN @@ -171,7 +169,7 @@ SUBROUTINE force_field_unique_bond (particle_set, & CALL get_molecule(molecule=molecule,first_atom=first,last_atom=last) IF(nbond>0) THEN ALLOCATE(map_bond_kind(nbond),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 IF((ff_type%ff_type==do_ff_g96).OR.(ff_type%ff_type==do_ff_g87)) THEN DO j=1,nbond @@ -214,14 +212,14 @@ SUBROUTINE force_field_unique_bond (particle_set, & END DO END IF NULLIFY(bond_kind_set) - CALL allocate_bond_kind_set(bond_kind_set,counter,error) + CALL allocate_bond_kind_set(bond_kind_set,counter) DO j=1,nbond bond_list(j)%bond_kind => bond_kind_set(map_bond_kind(j)) END DO CALL set_molecule_kind(molecule_kind=molecule_kind,& bond_kind_set=bond_kind_set,bond_list=bond_list) DEALLOCATE(map_bond_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL timestop(handle2) @@ -234,10 +232,9 @@ END SUBROUTINE force_field_unique_bond !> \param molecule_kind_set ... !> \param molecule_set ... !> \param ff_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_unique_bend (particle_set, & - molecule_kind_set, molecule_set, ff_type, error) + molecule_kind_set, molecule_set, ff_type) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -246,7 +243,6 @@ SUBROUTINE force_field_unique_bend (particle_set, & TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set TYPE(force_field_type), INTENT(INOUT) :: ff_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_unique_bend', & routineP = moduleN//':'//routineN @@ -280,7 +276,7 @@ SUBROUTINE force_field_unique_bend (particle_set, & CALL get_molecule(molecule=molecule,first_atom=first,last_atom=last) IF(nbend>0) THEN ALLOCATE(map_bend_kind(nbend),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 IF((ff_type%ff_type==do_ff_g96).OR.(ff_type%ff_type==do_ff_g87)) THEN DO j=1,nbend @@ -333,14 +329,14 @@ SUBROUTINE force_field_unique_bend (particle_set, & END DO END IF NULLIFY(bend_kind_set) - CALL allocate_bend_kind_set(bend_kind_set,counter,error) + CALL allocate_bend_kind_set(bend_kind_set,counter) DO j=1,nbend bend_list(j)%bend_kind => bend_kind_set(map_bend_kind(j)) END DO CALL set_molecule_kind(molecule_kind=molecule_kind,& bend_kind_set=bend_kind_set,bend_list=bend_list) DEALLOCATE(map_bend_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL timestop(handle2) @@ -352,10 +348,9 @@ END SUBROUTINE force_field_unique_bend !> \param particle_set ... !> \param molecule_kind_set ... !> \param molecule_set ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_unique_ub(particle_set, & - molecule_kind_set, molecule_set, error) + molecule_kind_set, molecule_set) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -363,7 +358,6 @@ SUBROUTINE force_field_unique_ub(particle_set, & POINTER :: molecule_kind_set TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_unique_ub', & routineP = moduleN//':'//routineN @@ -397,7 +391,7 @@ SUBROUTINE force_field_unique_ub(particle_set, & CALL get_molecule(molecule=molecule,first_atom=first,last_atom=last) IF(nub>0) THEN ALLOCATE(map_ub_kind(nub),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO j=1,nub atm_a = ub_list(j)%a @@ -442,14 +436,14 @@ SUBROUTINE force_field_unique_ub(particle_set, & map_ub_kind(j) = counter END IF END DO - CALL allocate_ub_kind_set(ub_kind_set,counter,error) + CALL allocate_ub_kind_set(ub_kind_set,counter) DO j=1,nub ub_list(j)%ub_kind => ub_kind_set(map_ub_kind(j)) END DO CALL set_molecule_kind(molecule_kind=molecule_kind,& ub_kind_set=ub_kind_set,ub_list=ub_list) DEALLOCATE(map_ub_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL timestop(handle2) @@ -462,10 +456,9 @@ END SUBROUTINE force_field_unique_ub !> \param molecule_kind_set ... !> \param molecule_set ... !> \param ff_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_unique_tors(particle_set, & - molecule_kind_set, molecule_set, ff_type, error) + molecule_kind_set, molecule_set, ff_type) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -474,7 +467,6 @@ SUBROUTINE force_field_unique_tors(particle_set, & TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set TYPE(force_field_type), INTENT(INOUT) :: ff_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_unique_tors', & routineP = moduleN//':'//routineN @@ -509,7 +501,7 @@ SUBROUTINE force_field_unique_tors(particle_set, & CALL get_molecule(molecule=molecule,first_atom=first,last_atom=last) IF(ntorsion>0) THEN ALLOCATE(map_torsion_kind(ntorsion),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 IF((ff_type%ff_type==do_ff_g96).OR.(ff_type%ff_type==do_ff_g87)) THEN DO j=1,ntorsion @@ -572,14 +564,14 @@ SUBROUTINE force_field_unique_tors(particle_set, & END DO END IF NULLIFY(torsion_kind_set) - CALL allocate_torsion_kind_set(torsion_kind_set,counter,error) + CALL allocate_torsion_kind_set(torsion_kind_set,counter) DO j=1,ntorsion torsion_list(j)%torsion_kind => torsion_kind_set(map_torsion_kind(j)) END DO CALL set_molecule_kind(molecule_kind=molecule_kind,& torsion_kind_set=torsion_kind_set,torsion_list=torsion_list) DEALLOCATE(map_torsion_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL timestop(handle2) @@ -592,10 +584,9 @@ END SUBROUTINE force_field_unique_tors !> \param molecule_kind_set ... !> \param molecule_set ... !> \param ff_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_unique_impr (particle_set, & - molecule_kind_set, molecule_set, ff_type, error) + molecule_kind_set, molecule_set, ff_type) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -604,7 +595,6 @@ SUBROUTINE force_field_unique_impr (particle_set, & TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set TYPE(force_field_type), INTENT(INOUT) :: ff_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_unique_impr', & routineP = moduleN//':'//routineN @@ -638,7 +628,7 @@ SUBROUTINE force_field_unique_impr (particle_set, & CALL get_molecule(molecule=molecule,first_atom=first,last_atom=last) IF(nimpr>0) THEN ALLOCATE(map_impr_kind(nimpr),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 IF((ff_type%ff_type==do_ff_g96).OR.(ff_type%ff_type==do_ff_g87)) THEN DO j=1,nimpr @@ -701,14 +691,14 @@ SUBROUTINE force_field_unique_impr (particle_set, & END DO END IF NULLIFY(impr_kind_set) - CALL allocate_impr_kind_set(impr_kind_set,counter,error) + CALL allocate_impr_kind_set(impr_kind_set,counter) DO j=1,nimpr impr_list(j)%impr_kind => impr_kind_set(map_impr_kind(j)) END DO CALL set_molecule_kind(molecule_kind=molecule_kind,& impr_kind_set=impr_kind_set,impr_list=impr_list) DEALLOCATE(map_impr_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL timestop(handle2) @@ -723,10 +713,9 @@ END SUBROUTINE force_field_unique_impr !> \param molecule_kind_set ... !> \param molecule_set ... !> \param ff_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_unique_opbend (particle_set, & - molecule_kind_set, molecule_set, ff_type, error) + molecule_kind_set, molecule_set, ff_type) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -735,7 +724,6 @@ SUBROUTINE force_field_unique_opbend (particle_set, & TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set TYPE(force_field_type), INTENT(INOUT) :: ff_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_unique_opbend', & routineP = moduleN//':'//routineN @@ -770,7 +758,7 @@ SUBROUTINE force_field_unique_opbend (particle_set, & CALL get_molecule(molecule=molecule,first_atom=first,last_atom=last) IF(nopbend>0) THEN ALLOCATE(map_opbend_kind(nopbend),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 IF((ff_type%ff_type==do_ff_g96).OR.(ff_type%ff_type==do_ff_g87)) THEN DO j=1,nopbend @@ -833,14 +821,14 @@ SUBROUTINE force_field_unique_opbend (particle_set, & END DO END IF NULLIFY(opbend_kind_set) - CALL allocate_opbend_kind_set(opbend_kind_set,counter,error) + CALL allocate_opbend_kind_set(opbend_kind_set,counter) DO j=1,nopbend opbend_list(j)%opbend_kind => opbend_kind_set(map_opbend_kind(j)) END DO CALL set_molecule_kind(molecule_kind=molecule_kind,& opbend_kind_set=opbend_kind_set,opbend_list=opbend_list) DEALLOCATE(map_opbend_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL timestop(handle2) @@ -858,10 +846,9 @@ END SUBROUTINE force_field_unique_opbend !> \param inp_info ... !> \param gro_info ... !> \param amb_info ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_bond (particle_set, molecule_kind_set, molecule_set, & - fatal, Ainfo, chm_info, inp_info, gro_info, amb_info, error) + fatal, Ainfo, chm_info, inp_info, gro_info, amb_info) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -876,7 +863,6 @@ SUBROUTINE force_field_pack_bond (particle_set, molecule_kind_set, molecule_set, TYPE(input_info_type), POINTER :: inp_info TYPE(gromos_info_type), POINTER :: gro_info TYPE(amber_info_type), POINTER :: amb_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_bond', & routineP = moduleN//':'//routineN @@ -944,8 +930,7 @@ SUBROUTINE force_field_pack_bond (particle_set, molecule_kind_set, molecule_set, bond_list(j)%bond_kind%id_type = do_ff_charmm bond_list(j)%bond_kind%k(1) = chm_info%bond_k(k) bond_list(j)%bond_kind%r0 = chm_info%bond_r0(k) - CALL issue_duplications(found,routineP,"Bond", name_atm_a, name_atm_b,& - error=error) + CALL issue_duplications(found,routineP,"Bond", name_atm_a, name_atm_b) found = .TRUE. EXIT END IF @@ -962,8 +947,7 @@ SUBROUTINE force_field_pack_bond (particle_set, molecule_kind_set, molecule_set, bond_list(j)%bond_kind%id_type = do_ff_amber bond_list(j)%bond_kind%k(1) = amb_info%bond_k(k) bond_list(j)%bond_kind%r0 = amb_info%bond_r0(k) - CALL issue_duplications(found,routineP,"Bond", name_atm_a, name_atm_b,& - error=error) + CALL issue_duplications(found,routineP,"Bond", name_atm_a, name_atm_b) found = .TRUE. EXIT END IF @@ -981,8 +965,7 @@ SUBROUTINE force_field_pack_bond (particle_set, molecule_kind_set, molecule_set, bond_list(j)%bond_kind%k(:) = inp_info%bond_k(:,k) bond_list(j)%bond_kind%r0 = inp_info%bond_r0(k) bond_list(j)%bond_kind%cs = inp_info%bond_cs(k) - CALL issue_duplications(found,routineP,"Bond", name_atm_a, name_atm_b,& - error=error) + CALL issue_duplications(found,routineP,"Bond", name_atm_a, name_atm_b) found = .TRUE. EXIT END IF @@ -993,8 +976,7 @@ SUBROUTINE force_field_pack_bond (particle_set, molecule_kind_set, molecule_set, atm2=TRIM(name_atm_b),& fatal=fatal,& type_name="Bond",& - array=Ainfo,& - error=error) + array=Ainfo) ! QM/MM modifications IF (only_qm) THEN bond_list(j)%id_type = do_ff_undef @@ -1019,10 +1001,9 @@ END SUBROUTINE force_field_pack_bond !> \param inp_info ... !> \param gro_info ... !> \param amb_info ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_bend (particle_set, molecule_kind_set, molecule_set, & - fatal, Ainfo, chm_info, inp_info, gro_info, amb_info, error) + fatal, Ainfo, chm_info, inp_info, gro_info, amb_info) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -1037,7 +1018,6 @@ SUBROUTINE force_field_pack_bend (particle_set, molecule_kind_set, molecule_set, TYPE(input_info_type), POINTER :: inp_info TYPE(gromos_info_type), POINTER :: gro_info TYPE(amber_info_type), POINTER :: amb_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_bend', & routineP = moduleN//':'//routineN @@ -1113,7 +1093,7 @@ SUBROUTINE force_field_pack_bend (particle_set, molecule_kind_set, molecule_set, bend_list(j)%bend_kind%k = chm_info%bend_k(k) bend_list(j)%bend_kind%theta0 = chm_info%bend_theta0(k) CALL issue_duplications(found,routineP, "Bend", name_atm_a, name_atm_b,& - name_atm_c, error=error) + name_atm_c) found = .TRUE. EXIT END IF @@ -1133,7 +1113,7 @@ SUBROUTINE force_field_pack_bend (particle_set, molecule_kind_set, molecule_set, bend_list(j)%bend_kind%k = amb_info%bend_k(k) bend_list(j)%bend_kind%theta0 = amb_info%bend_theta0(k) CALL issue_duplications(found,routineP, "Bend", name_atm_a, name_atm_b,& - name_atm_c, error=error) + name_atm_c) found = .TRUE. EXIT END IF @@ -1159,7 +1139,7 @@ SUBROUTINE force_field_pack_bend (particle_set, molecule_kind_set, molecule_set, bend_list(j)%bend_kind%kbs32 = inp_info%bend_kbs32(k) bend_list(j)%bend_kind%kss = inp_info%bend_kss(k) CALL issue_duplications(found,routineP, "Bend", name_atm_a, name_atm_b,& - name_atm_c, error=error) + name_atm_c) found = .TRUE. EXIT END IF @@ -1171,8 +1151,7 @@ SUBROUTINE force_field_pack_bend (particle_set, molecule_kind_set, molecule_set, atm3=TRIM(name_atm_c),& fatal=fatal,& type_name="Angle",& - array=Ainfo,& - error=error) + array=Ainfo) ! QM/MM modifications IF (only_qm) THEN bend_list(j)%id_type = do_ff_undef @@ -1195,10 +1174,9 @@ END SUBROUTINE force_field_pack_bend !> \param chm_info ... !> \param inp_info ... !> \param iw ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_ub (particle_set, molecule_kind_set, molecule_set, & - Ainfo, chm_info, inp_info, iw, error) + Ainfo, chm_info, inp_info, iw) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -1211,7 +1189,6 @@ SUBROUTINE force_field_pack_ub (particle_set, molecule_kind_set, molecule_set, & TYPE(charmm_info_type), POINTER :: chm_info TYPE(input_info_type), POINTER :: inp_info INTEGER :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_ub', & routineP = moduleN//':'//routineN @@ -1276,7 +1253,7 @@ SUBROUTINE force_field_pack_ub (particle_set, molecule_kind_set, molecule_set, & IF(iw>0) WRITE(iw,*) " Found UB ",TRIM(name_atm_a)," ",& TRIM(name_atm_b)," ",TRIM(name_atm_c) CALL issue_duplications(found,routineP, "Urey-Bradley", name_atm_a,& - name_atm_b, name_atm_c, error=error) + name_atm_b, name_atm_c) found = .TRUE. EXIT END IF @@ -1299,7 +1276,7 @@ SUBROUTINE force_field_pack_ub (particle_set, molecule_kind_set, molecule_set, & ub_list(j)%ub_kind%k(:) = inp_info%ub_k(:,k) ub_list(j)%ub_kind%r0 = inp_info%ub_r0(k) CALL issue_duplications(found,routineP, "Urey-Bradley", name_atm_a,& - name_atm_b, name_atm_c, error=error) + name_atm_b, name_atm_c) found = .TRUE. EXIT END IF @@ -1311,8 +1288,7 @@ SUBROUTINE force_field_pack_ub (particle_set, molecule_kind_set, molecule_set, & atm2=TRIM(name_atm_b),& atm3=TRIM(name_atm_c),& type_name="Urey-Bradley",& - array=Ainfo,& - error=error) + array=Ainfo) ub_list(j)%id_type = do_ff_undef ub_list(j)%ub_kind%id_type = do_ff_undef ub_list(j)%ub_kind%k = 0.0_dp @@ -1343,10 +1319,9 @@ END SUBROUTINE force_field_pack_ub !> \param gro_info ... !> \param amb_info ... !> \param iw ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_tors (particle_set, molecule_kind_set, molecule_set, & - Ainfo, chm_info, inp_info, gro_info, amb_info, iw, error) + Ainfo, chm_info, inp_info, gro_info, amb_info, iw) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -1361,7 +1336,6 @@ SUBROUTINE force_field_pack_tors (particle_set, molecule_kind_set, molecule_set, TYPE(gromos_info_type), POINTER :: gro_info TYPE(amber_info_type), POINTER :: amb_info INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_tors', & routineP = moduleN//':'//routineN @@ -1572,8 +1546,7 @@ SUBROUTINE force_field_pack_tors (particle_set, molecule_kind_set, molecule_set, atm3=TRIM(name_atm_c),& atm4=TRIM(name_atm_d),& type_name="Torsion",& - array=Ainfo,& - error=error) + array=Ainfo) torsion_list(j)%torsion_kind%id_type = do_ff_undef torsion_list(j)%id_type = do_ff_undef ELSE @@ -1618,10 +1591,9 @@ END SUBROUTINE force_field_pack_tors !> \param chm_info ... !> \param inp_info ... !> \param gro_info ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_impr (particle_set, molecule_kind_set, molecule_set, & - Ainfo, chm_info, inp_info, gro_info, error) + Ainfo, chm_info, inp_info, gro_info) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -1634,7 +1606,6 @@ SUBROUTINE force_field_pack_impr (particle_set, molecule_kind_set, molecule_set, TYPE(charmm_info_type), POINTER :: chm_info TYPE(input_info_type), POINTER :: inp_info TYPE(gromos_info_type), POINTER :: gro_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_impr', & routineP = moduleN//':'//routineN @@ -1717,7 +1688,7 @@ SUBROUTINE force_field_pack_impr (particle_set, molecule_kind_set, molecule_set, impr_list(j)%impr_kind%k = chm_info%impr_k(k) impr_list(j)%impr_kind%phi0 = chm_info%impr_phi0(k) CALL issue_duplications(found,routineP, "Impropers", name_atm_a, name_atm_b,& - name_atm_c, name_atm_d, error=error) + name_atm_c, name_atm_d) found = .TRUE. EXIT END IF @@ -1736,7 +1707,7 @@ SUBROUTINE force_field_pack_impr (particle_set, molecule_kind_set, molecule_set, impr_list(j)%impr_kind%k = chm_info%impr_k(k) impr_list(j)%impr_kind%phi0 = chm_info%impr_phi0(k) CALL issue_duplications(found,routineP, "Impropers", name_atm_a, name_atm_b,& - name_atm_c,name_atm_d, error=error) + name_atm_c,name_atm_d) found = .TRUE. EXIT END IF @@ -1774,7 +1745,7 @@ SUBROUTINE force_field_pack_impr (particle_set, molecule_kind_set, molecule_set, ! above END IF CALL issue_duplications(found,routineP, "Impropers", name_atm_a, name_atm_b,& - name_atm_c,name_atm_d, error=error) + name_atm_c,name_atm_d) found = .TRUE. EXIT END IF @@ -1787,8 +1758,7 @@ SUBROUTINE force_field_pack_impr (particle_set, molecule_kind_set, molecule_set, atm3=TRIM(name_atm_c),& atm4=TRIM(name_atm_d),& type_name="Improper",& - array=Ainfo,& - error=error) + array=Ainfo) impr_list(j)%impr_kind%k = 0.0_dp impr_list(j)%impr_kind%phi0 = 0.0_dp impr_list(j)%impr_kind%id_type = do_ff_undef @@ -1818,11 +1788,10 @@ END SUBROUTINE force_field_pack_impr !> \param molecule_set ... !> \param Ainfo ... !> \param inp_info ... -!> \param error ... !> \author Louis Vanduyfhuys ! ***************************************************************************** SUBROUTINE force_field_pack_opbend (particle_set, molecule_kind_set, molecule_set, & - Ainfo, inp_info, error) + Ainfo, inp_info) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -1833,7 +1802,6 @@ SUBROUTINE force_field_pack_opbend (particle_set, molecule_kind_set, molecule_se CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: Ainfo TYPE(input_info_type), POINTER :: inp_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_opbend', & routineP = moduleN//':'//routineN @@ -1912,7 +1880,7 @@ SUBROUTINE force_field_pack_opbend (particle_set, molecule_kind_set, molecule_se END IF CALL issue_duplications(found,routineP, "Out of plane bend", name_atm_a, name_atm_b,& - name_atm_c,name_atm_d, error=error) + name_atm_c,name_atm_d) found = .TRUE. EXIT END IF @@ -1925,8 +1893,7 @@ SUBROUTINE force_field_pack_opbend (particle_set, molecule_kind_set, molecule_se atm3=TRIM(name_atm_c),& atm4=TRIM(name_atm_d),& type_name="Out of plane bend",& - array=Ainfo,& - error=error) + array=Ainfo) opbend_list(j)%opbend_kind%k = 0.0_dp opbend_list(j)%opbend_kind%phi0 = 0.0_dp opbend_list(j)%opbend_kind%id_type = do_ff_undef @@ -1956,12 +1923,11 @@ END SUBROUTINE force_field_pack_opbend !> \param qmmm_env ... !> \param inp_info ... !> \param iw4 ... -!> \param error ... !> \date 12.2010 !> \author Teodoro Laino (teodoro.laino@gmail.com) ! ***************************************************************************** SUBROUTINE force_field_pack_charges(charges, charges_section, particle_set, & - my_qmmm, qmmm_env, inp_info, iw4, error) + my_qmmm, qmmm_env, inp_info, iw4) REAL(KIND=dp), DIMENSION(:), POINTER :: charges TYPE(section_vals_type), POINTER :: charges_section @@ -1971,7 +1937,6 @@ SUBROUTINE force_field_pack_charges(charges, charges_section, particle_set, & TYPE(qmmm_env_mm_type), POINTER :: qmmm_env TYPE(input_info_type), POINTER :: inp_info INTEGER :: iw4 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_charges', & routineP = moduleN//':'//routineN @@ -1999,22 +1964,22 @@ SUBROUTINE force_field_pack_charges(charges, charges_section, particle_set, & IF(ASSOCIATED(inp_info%shell_list)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Array of charges not implemented for CORE-SHELL model!!",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF ! Allocate array to particle_set size - CPPostcondition(.NOT.(ASSOCIATED(charges)),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.(ASSOCIATED(charges)),cp_failure_level,routineP,failure) ALLOCATE(charges(SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Fill with input values - CALL section_vals_val_get(charges_section,"_DEFAULT_KEYWORD_",n_rep_val=nval,error=error) - CPPostcondition(nval==SIZE(charges),cp_failure_level,routineP,error,failure) - CALL section_vals_list_get(charges_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_val_get(charges_section,"_DEFAULT_KEYWORD_",n_rep_val=nval) + CPPostcondition(nval==SIZE(charges),cp_failure_level,routineP,failure) + CALL section_vals_list_get(charges_section,"_DEFAULT_KEYWORD_",list=list) DO iatom=1,nval ! we use only the first default_string_length characters of each line - is_ok=cp_sll_val_next(list,val,error=error) - CALL val_get(val,r_val=rval,error=error) + is_ok=cp_sll_val_next(list,val) + CALL val_get(val,r_val=rval) ! assign values charges(iatom)=rval @@ -2073,7 +2038,7 @@ SUBROUTINE force_field_pack_charges(charges, charges_section, particle_set, & DO ilink = 1, SIZE(qmmm_env%mm_link_atoms) IF (iatom == qmmm_env%mm_link_atoms(ilink)) EXIT END DO - CPPostcondition(ilink <= SIZE(qmmm_env%mm_link_atoms),cp_failure_level,routineP,error,failure) + CPPostcondition(ilink <= SIZE(qmmm_env%mm_link_atoms),cp_failure_level,routineP,failure) scale_factor = qmmm_env%fist_scale_charge_link(ilink) END IF charges(iatom) = charges(iatom) * scale_factor @@ -2100,10 +2065,9 @@ END SUBROUTINE force_field_pack_charges !> \param Ainfo ... !> \param my_qmmm ... !> \param inp_info ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_charge(atomic_kind_set, qmmm_env, fatal, iw, iw4,& - Ainfo, my_qmmm, inp_info, error) + Ainfo, my_qmmm, inp_info) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -2114,7 +2078,6 @@ SUBROUTINE force_field_pack_charge(atomic_kind_set, qmmm_env, fatal, iw, iw4,& DIMENSION(:), POINTER :: Ainfo LOGICAL :: my_qmmm TYPE(input_info_type), POINTER :: inp_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_charge', & routineP = moduleN//':'//routineN @@ -2154,7 +2117,7 @@ SUBROUTINE force_field_pack_charge(atomic_kind_set, qmmm_env, fatal, iw, iw4,& IF (iw>0) WRITE(iw,*)"Charge Checking ::",TRIM(inp_info%charge_atm(j)),atmname IF((inp_info%charge_atm(j))==atmname) THEN charge = inp_info%charge(j) - CALL issue_duplications(found,routineP, "Charge", atmname, error=error) + CALL issue_duplications(found,routineP, "Charge", atmname) found = .TRUE. END IF END DO @@ -2214,8 +2177,7 @@ SUBROUTINE force_field_pack_charge(atomic_kind_set, qmmm_env, fatal, iw, iw4,& CALL store_FF_missing_par(atm1=TRIM(atmname),& fatal=fatal,& type_name="Charge",& - array=Ainfo,& - error=error) + array=Ainfo) END IF ! ! QM/MM modifications @@ -2230,7 +2192,7 @@ SUBROUTINE force_field_pack_charge(atomic_kind_set, qmmm_env, fatal, iw, iw4,& DO ilink = 1, SIZE(qmmm_env%mm_link_atoms) IF (ANY(my_atom_list == qmmm_env%mm_link_atoms(ilink))) EXIT END DO - CPPostcondition(ilink <= SIZE(qmmm_env%mm_link_atoms),cp_failure_level,routineP,error,failure) + CPPostcondition(ilink <= SIZE(qmmm_env%mm_link_atoms),cp_failure_level,routineP,failure) scale_factor = qmmm_env%fist_scale_charge_link(ilink) END IF charge = charge * scale_factor @@ -2259,16 +2221,14 @@ END SUBROUTINE force_field_pack_charge !> \param atomic_kind_set ... !> \param iw ... !> \param subsys_section ... -!> \param error ... !> \author Toon.Verstraelen@gmail.com ! ***************************************************************************** - SUBROUTINE force_field_pack_radius(atomic_kind_set, iw, subsys_section, error) + SUBROUTINE force_field_pack_radius(atomic_kind_set, iw, subsys_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set INTEGER, INTENT(IN) :: iw TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_radius', & routineP = moduleN//':'//routineN @@ -2283,8 +2243,8 @@ SUBROUTINE force_field_pack_radius(atomic_kind_set, iw, subsys_section, error) CALL timeset(routineN,handle) - kind_section => section_vals_get_subs_vals(subsys_section,"KIND",error=error) - CALL section_vals_get(kind_section,n_repetition=n_rep,error=error) + kind_section => section_vals_get_subs_vals(subsys_section,"KIND") + CALL section_vals_get(kind_section,n_repetition=n_rep) DO i = 1, SIZE(atomic_kind_set) atomic_kind => atomic_kind_set(i) @@ -2299,14 +2259,14 @@ SUBROUTINE force_field_pack_radius(atomic_kind_set, iw, subsys_section, error) mm_radius = 0.0_dp DO i_rep = 1, n_rep CALL section_vals_val_get(kind_section, "_SECTION_PARAMETERS_",& - c_val=inp_kind_name, i_rep_section=i_rep, error=error) + c_val=inp_kind_name, i_rep_section=i_rep) CALL uppercase(inp_kind_name) IF (iw>0) WRITE(iw,*) "Matching kinds for MM_RADIUS :: '", & TRIM(kind_name), "' with '", TRIM(inp_kind_name), "'" IF (TRIM(kind_name)==TRIM(inp_kind_name)) THEN CALL section_vals_val_get(kind_section, i_rep_section=i_rep,& - keyword_name="MM_RADIUS", r_val=mm_radius, error=error) - CALL issue_duplications(found, routineP, "MM_RADIUS", kind_name, error=error) + keyword_name="MM_RADIUS", r_val=mm_radius) + CALL issue_duplications(found, routineP, "MM_RADIUS", kind_name) found = .TRUE. END IF END DO @@ -2321,16 +2281,14 @@ END SUBROUTINE force_field_pack_radius !> \param atomic_kind_set ... !> \param iw ... !> \param inp_info ... -!> \param error ... !> \author Toon.Verstraelen@gmail.com ! ***************************************************************************** - SUBROUTINE force_field_pack_pol(atomic_kind_set, iw, inp_info, error) + SUBROUTINE force_field_pack_pol(atomic_kind_set, iw, inp_info) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set INTEGER, INTENT(IN) :: iw TYPE(input_info_type), POINTER :: inp_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_pol', & routineP = moduleN//':'//routineN @@ -2360,7 +2318,7 @@ SUBROUTINE force_field_pack_pol(atomic_kind_set, iw, inp_info, error) TRIM(kind_name), "' with '", TRIM(inp_info%apol_atm(j)), "'" IF((inp_info%apol_atm(j))==kind_name) THEN apol = inp_info%apol(j) - CALL issue_duplications(found,routineP, "APOL", kind_name, error=error) + CALL issue_duplications(found,routineP, "APOL", kind_name) found = .TRUE. END IF END DO @@ -2372,7 +2330,7 @@ SUBROUTINE force_field_pack_pol(atomic_kind_set, iw, inp_info, error) TRIM(kind_name), "' with '", TRIM(inp_info%cpol_atm(j)), "'" IF((inp_info%cpol_atm(j))==kind_name) THEN cpol = inp_info%cpol(j) - CALL issue_duplications(found,routineP, "CPOL", kind_name, error=error) + CALL issue_duplications(found,routineP, "CPOL", kind_name) found = .TRUE. END IF END DO @@ -2388,16 +2346,14 @@ END SUBROUTINE force_field_pack_pol !> \param atomic_kind_set ... !> \param iw ... !> \param inp_info ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_damp (atomic_kind_set,& - iw,inp_info,error) + iw,inp_info) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set INTEGER :: iw TYPE(input_info_type), POINTER :: inp_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_damp', & routineP = moduleN//':'//routineN @@ -2427,7 +2383,7 @@ SUBROUTINE force_field_pack_damp (atomic_kind_set,& TRIM(atm_name1) IF (my_atm_name1==atm_name1) THEN IF (.NOT.ASSOCIATED(damping)) THEN - CALL damping_p_create(damping,nkinds,error) + CALL damping_p_create(damping,nkinds) END IF found=.FALSE. @@ -2440,7 +2396,7 @@ SUBROUTINE force_field_pack_damp (atomic_kind_set,& IF (my_atm_name2==atm_name2) THEN IF(damping%damp(k)%bij/=HUGE(0.0_dp)) found=.TRUE. CALL issue_duplications(found,routineP, "Damping",& - atm_name1,error=error) + atm_name1) found=.TRUE. SELECT CASE(TRIM(inp_info%damping_list(i)%dtype)) @@ -2489,11 +2445,10 @@ END SUBROUTINE force_field_pack_damp !> \param cell ... !> \param iw ... !> \param inp_info ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& molecule_kind_set, molecule_set, root_section, subsys_section,& - shell_particle_set, core_particle_set, cell, iw, inp_info, error) + shell_particle_set, core_particle_set, cell, iw, inp_info) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -2510,7 +2465,6 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& TYPE(cell_type), POINTER :: cell INTEGER :: iw TYPE(input_info_type), POINTER :: inp_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_shell', & routineP = moduleN//':'//routineN @@ -2543,8 +2497,8 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& shell_coord_read = .FALSE. NULLIFY(global_section) - global_section => section_vals_get_subs_vals(root_section,"GLOBAL",error=error) - CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem,error=error) + global_section => section_vals_get_subs_vals(root_section,"GLOBAL") + CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem) DO i=1,SIZE(atomic_kind_set) atomic_kind => atomic_kind_set(i) @@ -2563,7 +2517,7 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& CALL get_atomic_kind(atomic_kind=atomic_kind,& shell=shell, mass=atmmass, natom=natom) IF(.NOT. ASSOCIATED(shell)) THEN - CALL shell_create(shell,error) + CALL shell_create(shell) END IF nshell_tot = nshell_tot + natom shell%charge_core=inp_info%shell_list(j)%shell%charge_core @@ -2576,11 +2530,11 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& shell%shell_cutoff=inp_info%shell_list(j)%shell%shell_cutoff shell%mass_shell=shell%massfrac*atmmass shell%mass_core=atmmass-shell%mass_shell - CALL issue_duplications(found_shell,routineP, "Shell", atmname, error=error) + CALL issue_duplications(found_shell,routineP, "Shell", atmname) found_shell = .TRUE. CALL set_atomic_kind(atomic_kind=atomic_kind,& - shell=shell, shell_active=.TRUE.,error=error) - CALL shell_release(shell, error) + shell=shell, shell_active=.TRUE.) + CALL shell_release(shell) END IF END DO ! j shell kind END IF ! associated shell_list @@ -2596,8 +2550,8 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& CALL stop_program(routineN,moduleN,__LINE__,& "Shell-model adiabatic: at least one shell_kind has mass zero") END IF - CALL allocate_particle_set(shell_particle_set,nshell_tot,error) - CALL allocate_particle_set(core_particle_set,nshell_tot,error) + CALL allocate_particle_set(shell_particle_set,nshell_tot) + CALL allocate_particle_set(core_particle_set,nshell_tot) counter = 0 ! Initialise the shell (and core) coordinates with the particle (atomic) coordinates, ! count the shell and set pointers @@ -2621,14 +2575,14 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& particle_set(i)%shell_index = 0 END IF END DO - CPPostcondition(counter==nshell_tot,cp_failure_level,routineP,error,failure) + CPPostcondition(counter==nshell_tot,cp_failure_level,routineP,failure) END IF ! Read the shell (and core) coordinates from the restart file, if available CALL read_binary_cs_coordinates("SHELL",shell_particle_set,root_section,& - subsys_section,shell_coord_read,error) + subsys_section,shell_coord_read) CALL read_binary_cs_coordinates("CORE",core_particle_set,root_section,& - subsys_section,core_coord_read,error) + subsys_section,core_coord_read) IF (nshell_tot > 0) THEN ! Read the shell (and core) coordinates from the input, if no coordinates were found @@ -2637,12 +2591,12 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& IF (.NOT.(core_coord_read.AND.shell_coord_read)) THEN CALL read_shell_coord_input(particle_set,shell_particle_set,cell,& subsys_section,core_particle_set,& - save_mem=save_mem,error=error) + save_mem=save_mem) END IF ELSE IF (.NOT.shell_coord_read) THEN CALL read_shell_coord_input(particle_set,shell_particle_set,cell,& - subsys_section,save_mem=save_mem,error=error) + subsys_section,save_mem=save_mem) END IF END IF ! Determine the number of shells per molecule kind @@ -2654,7 +2608,7 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& molecule=>molecule_set(molecule_list(1)) CALL get_molecule(molecule=molecule,first_atom=first,last_atom=last) ALLOCATE (shell_list_tmp(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter = 0 DO j = first, last atomic_kind => particle_set(j)%atomic_kind @@ -2678,10 +2632,10 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& CALL get_molecule_kind(molecule_kind=molecule_kind,shell_list=shell_list) IF (ASSOCIATED(shell_list)) THEN DEALLOCATE(shell_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE (shell_list(counter), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,counter shell_list(j)%a = shell_list_tmp(j) atomic_kind => particle_set(shell_list_tmp(j)+first-1)%atomic_kind @@ -2693,12 +2647,12 @@ SUBROUTINE force_field_pack_shell(particle_set, atomic_kind_set,& CALL set_molecule_kind(molecule_kind=molecule_kind, nshell=counter,shell_list=shell_list) END IF DEALLOCATE (shell_list_tmp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) n = n + nmol*counter END DO ! i molecule kind END IF - CPPostcondition(first_shell-1==nshell_tot,cp_failure_level,routineP,error,failure) - CPPostcondition(n==nshell_tot,cp_failure_level,routineP,error,failure) + CPPostcondition(first_shell-1==nshell_tot,cp_failure_level,routineP,failure) + CPPostcondition(n==nshell_tot,cp_failure_level,routineP,failure) CALL timestop(handle2) END SUBROUTINE force_field_pack_shell @@ -2716,11 +2670,9 @@ END SUBROUTINE force_field_pack_shell !> \param amb_info ... !> \param potparm_nonbond14 ... !> \param ewald_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & - Ainfo, chm_info, inp_info, gro_info, amb_info, potparm_nonbond14, ewald_env, & - error) + Ainfo, chm_info, inp_info, gro_info, amb_info, potparm_nonbond14, ewald_env) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -2735,7 +2687,6 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & TYPE(amber_info_type), POINTER :: amb_info TYPE(pair_potential_pp_type), POINTER :: potparm_nonbond14 TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_nonbond14', & routineP = moduleN//':'//routineN @@ -2756,9 +2707,9 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & failure = .FALSE. use_qmmm_ff = qmmm_env%use_qmmm_ff NULLIFY(pot) - CALL ewald_env_get(ewald_env, rcut=ewald_rcut, error=error) + CALL ewald_env_get(ewald_env, rcut=ewald_rcut) CALL timeset(routineN,handle2) - CALL pair_potential_pp_create (potparm_nonbond14, SIZE(atomic_kind_set), error) + CALL pair_potential_pp_create (potparm_nonbond14, SIZE(atomic_kind_set)) DO i=1,SIZE(atomic_kind_set) atomic_kind => atomic_kind_set(i) CALL get_atomic_kind(atomic_kind=atomic_kind,name=name_atm_a_local) @@ -2794,7 +2745,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & END IF END DO IF(ii/=0 .AND. jj/=0) THEN - CALL pair_potential_lj_create(pot%set(1)%lj, error) + CALL pair_potential_lj_create(pot%set(1)%lj) pot%type = lj_type pot%at1 = name_atm_a pot%at2 = name_atm_b @@ -2802,7 +2753,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & pot%set(1)%lj%sigma6 = gro_info%nonbond_c6_14(ii,jj) pot%set(1)%lj%sigma12 = gro_info%nonbond_c12_14(ii,jj) pot%rcutsq = (10.0_dp*bohr)**2 - CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b, error=error) + CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b) found = .TRUE. END IF END IF @@ -2852,7 +2803,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & rmin = rmin2_a + rmin2_b ! ABS to allow for mixing the two different sign conventions for epsilon epsilon0 = SQRT(ABS(epsilon_a*epsilon_b)) - CALL pair_potential_lj_create(pot%set(1)%lj, error) + CALL pair_potential_lj_create(pot%set(1)%lj) pot%type = lj_charmm_type pot%at1 = name_atm_a pot%at2 = name_atm_b @@ -2860,8 +2811,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & pot%set(1)%lj%sigma6 = 0.5_dp*rmin**6 pot%set(1)%lj%sigma12 = 0.25_dp*rmin**12 pot%rcutsq = (10.0_dp*bohr)**2 - CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b,& - error=error) + CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b) found = .TRUE. END IF @@ -2891,7 +2841,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & rmin = rmin2_a + rmin2_b ! ABS to allow for mixing the two different sign conventions for epsilon epsilon0 = SQRT(ABS(epsilon_a*epsilon_b)) - CALL pair_potential_lj_create(pot%set(1)%lj, error) + CALL pair_potential_lj_create(pot%set(1)%lj) pot%type = lj_charmm_type pot%at1 = name_atm_a pot%at2 = name_atm_b @@ -2900,7 +2850,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & pot%set(1)%lj%sigma12 = 0.25_dp*rmin**12 pot%rcutsq = (10.0_dp*bohr)**2 CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a,& - name_atm_b, error=error) + name_atm_b) found = .TRUE. END IF END IF @@ -2916,7 +2866,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & (((name_atm_b)==(inp_info%nonbonded14%pot(k)%pot%at1)) .AND. & ((name_atm_a)==(inp_info%nonbonded14%pot(k)%pot%at2))) ) THEN IF (ff_type%multiple_potential) THEN - CALL pair_potential_single_add(inp_info%nonbonded14%pot(k)%pot,pot,error) + CALL pair_potential_single_add(inp_info%nonbonded14%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple ONFO declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" ADDING! "//& @@ -2925,7 +2875,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & potparm_nonbond14%pot(i,j)%pot => pot potparm_nonbond14%pot(j,i)%pot => pot ELSE - CALL pair_potential_single_copy(inp_info%nonbonded14%pot(k)%pot,pot,error) + CALL pair_potential_single_copy(inp_info%nonbonded14%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple ONFO declarations: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" OVERWRITING! "//& @@ -2954,7 +2904,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & (((name_atm_b)==(qmmm_env%inp_info%nonbonded14%pot(k)%pot%at1)) .AND. & ((name_atm_a) ==(qmmm_env%inp_info%nonbonded14%pot(k)%pot%at2))) ) THEN IF (qmmm_env%multiple_potential) THEN - CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded14%pot(k)%pot,pot,error) + CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded14%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple ONFO declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" ADDING QM/MM forcefield specifications! "//& @@ -2963,7 +2913,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & potparm_nonbond14%pot(i,j)%pot => pot potparm_nonbond14%pot(j,i)%pot => pot ELSE - CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded14%pot(k)%pot,pot,error) + CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded14%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple ONFO declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" OVERWRITING QM/MM forcefield specifications! "//& @@ -2983,9 +2933,8 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & CALL store_FF_missing_par(atm1=TRIM(name_atm_a),& atm2=TRIM(name_atm_b),& type_name="Spline_Bond_Env",& - array=Ainfo,& - error=error) - CALL pair_potential_single_clean(pot, error=error) + array=Ainfo) + CALL pair_potential_single_clean(pot) pot%type = nn_type pot%at1 = name_atm_a pot%at2 = name_atm_b @@ -2997,7 +2946,7 @@ SUBROUTINE force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, & ! Cutoff is defined always as the maximum between the FF and Ewald pot%rcutsq = MAX(pot%rcutsq, ewald_rcut*ewald_rcut) IF (only_qm) THEN - CALL pair_potential_single_clean(pot, error=error) + CALL pair_potential_single_clean(pot) END IF END DO ! atom kind j END DO ! atom kind i @@ -3019,11 +2968,10 @@ END SUBROUTINE force_field_pack_nonbond14 !> \param amb_info ... !> \param potparm_nonbond ... !> \param ewald_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & iw, Ainfo, chm_info, inp_info, gro_info, amb_info, potparm_nonbond, & - ewald_env, error) + ewald_env) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -3039,7 +2987,6 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & TYPE(amber_info_type), POINTER :: amb_info TYPE(pair_potential_pp_type), POINTER :: potparm_nonbond TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_nonbond', & routineP = moduleN//':'//routineN @@ -3060,8 +3007,8 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & failure = .FALSE. use_qmmm_ff = qmmm_env%use_qmmm_ff NULLIFY(pot) - CALL ewald_env_get(ewald_env, rcut=ewald_rcut, error=error) - CALL pair_potential_pp_create ( potparm_nonbond, SIZE(atomic_kind_set),error ) + CALL ewald_env_get(ewald_env, rcut=ewald_rcut) + CALL pair_potential_pp_create ( potparm_nonbond, SIZE(atomic_kind_set)) DO i=1,SIZE(atomic_kind_set) atomic_kind => atomic_kind_set(i) CALL get_atomic_kind(atomic_kind=atomic_kind, name=name_atm_a_local, & @@ -3096,7 +3043,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & END DO IF(ii/=0 .AND. jj/=0) THEN - CALL pair_potential_lj_create(pot%set(1)%lj, error) + CALL pair_potential_lj_create(pot%set(1)%lj) pot%type = lj_type pot%at1 = name_atm_a pot%at2 = name_atm_b @@ -3104,7 +3051,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & pot%set(1)%lj%sigma6 = gro_info%nonbond_c6(ii,jj) pot%set(1)%lj%sigma12 = gro_info%nonbond_c12(ii,jj) pot%rcutsq = (10.0_dp*bohr)**2 - CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b, error=error) + CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b) found = .TRUE. END IF END IF @@ -3128,7 +3075,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & rmin = chm_info%nonbond_rmin2(ii)+chm_info%nonbond_rmin2(jj) epsilon0 = SQRT(chm_info%nonbond_eps(ii)*& chm_info%nonbond_eps(jj)) - CALL pair_potential_lj_create(pot%set(1)%lj, error) + CALL pair_potential_lj_create(pot%set(1)%lj) pot%type = lj_charmm_type pot%at1 = name_atm_a pot%at2 = name_atm_b @@ -3136,7 +3083,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & pot%set(1)%lj%sigma6 = 0.5_dp*rmin**6 pot%set(1)%lj%sigma12 = 0.25_dp*rmin**12 pot%rcutsq = (10.0_dp*bohr)**2 - CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b, error=error) + CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b) found = .TRUE. END IF END IF @@ -3159,7 +3106,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & IF(ii/=0 .AND. jj/=0) THEN rmin = amb_info%nonbond_rmin2(ii)+amb_info%nonbond_rmin2(jj) epsilon0 = SQRT(amb_info%nonbond_eps(ii)*amb_info%nonbond_eps(jj)) - CALL pair_potential_lj_create(pot%set(1)%lj, error) + CALL pair_potential_lj_create(pot%set(1)%lj) pot%type = lj_charmm_type pot%at1 = name_atm_a pot%at2 = name_atm_b @@ -3167,7 +3114,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & pot%set(1)%lj%sigma6 = 0.5_dp*rmin**6 pot%set(1)%lj%sigma12 = 0.25_dp*rmin**12 pot%rcutsq = (10.0_dp*bohr)**2 - CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b, error=error) + CALL issue_duplications(found,routineP, "Lennard-Jones", name_atm_a, name_atm_b) found = .TRUE. END IF END IF @@ -3186,7 +3133,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & (((name_atm_b)==(inp_info%nonbonded%pot(k)%pot%at1)) .AND. & ((name_atm_a)==(inp_info%nonbonded%pot(k)%pot%at2))) ) THEN IF (ff_type%multiple_potential) THEN - CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" ADDING! "//& @@ -3195,7 +3142,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & potparm_nonbond%pot(i,j)%pot => pot potparm_nonbond%pot(j,i)%pot => pot ELSE - CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" OVERWRITING! "//& @@ -3221,7 +3168,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & (name_atm_b==inp_info%nonbonded%pot(k)%pot%at1) .OR.& (name_atm_a==inp_info%nonbonded%pot(k)%pot%at2) ) THEN IF (ff_type%multiple_potential) THEN - CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" ADDING! "//& @@ -3230,7 +3177,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & potparm_nonbond%pot(i,j)%pot => pot potparm_nonbond%pot(j,i)%pot => pot ELSE - CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" OVERWRITING! "//& @@ -3253,7 +3200,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & TRIM(inp_info%nonbonded%pot(k)%pot%at2) IF (ff_type%multiple_potential) THEN - CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_add(inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" ADDING! "//& @@ -3262,7 +3209,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & potparm_nonbond%pot(i,j)%pot => pot potparm_nonbond%pot(j,i)%pot => pot ELSE - CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_copy(inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" OVERWRITING! "//& @@ -3292,7 +3239,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & (((name_atm_b)==(qmmm_env%inp_info%nonbonded%pot(k)%pot%at1)) .AND. & ((name_atm_a) ==(qmmm_env%inp_info%nonbonded%pot(k)%pot%at2))) ) THEN IF (qmmm_env%multiple_potential) THEN - CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_add(qmmm_env%inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" ADDING QM/MM forcefield specifications! "//& @@ -3301,7 +3248,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & potparm_nonbond%pot(i,j)%pot => pot potparm_nonbond%pot(j,i)%pot => pot ELSE - CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded%pot(k)%pot,pot,error) + CALL pair_potential_single_copy(qmmm_env%inp_info%nonbonded%pot(k)%pot,pot) CALL cp_assert(.NOT.found,cp_warning_level,cp_assertion_failed,routineP,& "Multiple NONBONDED declaration: "//TRIM(name_atm_a)//& " and "//TRIM(name_atm_b)//" OVERWRITING QM/MM forcefield specifications! "//& @@ -3320,8 +3267,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & atm2=TRIM(name_atm_b),& type_name="Spline_Non_Bond_Env",& fatal=fatal,& - array=Ainfo,& - error=error) + array=Ainfo) END IF ! If defined global RCUT let's use it IF(ff_type%rcut_nb>0.0_dp) THEN @@ -3338,7 +3284,7 @@ SUBROUTINE force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, fatal, & pot%shell_type = nosh_nosh END IF IF (only_qm) THEN - CALL pair_potential_single_clean(pot, error=error) + CALL pair_potential_single_clean(pot) END IF END DO ! jkind END DO ! ikind @@ -3355,10 +3301,9 @@ END SUBROUTINE force_field_pack_nonbond !> \param potparm ... !> \param do_zbl ... !> \param nonbonded_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack_splines(atomic_kind_set, ff_type, iw2, iw3, iw4, & - potparm, do_zbl, nonbonded_type, error) + potparm, do_zbl, nonbonded_type) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -3367,7 +3312,6 @@ SUBROUTINE force_field_pack_splines(atomic_kind_set, ff_type, iw2, iw3, iw4, & TYPE(pair_potential_pp_type), POINTER :: potparm LOGICAL, INTENT(IN) :: do_zbl CHARACTER(LEN=*), INTENT(IN) :: nonbonded_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_splines', & routineP = moduleN//':'//routineN @@ -3384,26 +3328,26 @@ SUBROUTINE force_field_pack_splines(atomic_kind_set, ff_type, iw2, iw3, iw4, & ! prepare storage for these, avoiding duplicates. NULLIFY(spline_env) CALL get_nonbond_storage(spline_env, potparm, atomic_kind_set, & - do_zbl, shift_cutoff=ff_type%shift_cutoff, error=error) + do_zbl, shift_cutoff=ff_type%shift_cutoff) ! Effectively compute the spline data. CALL spline_nonbond_control(spline_env, potparm, & atomic_kind_set, eps_spline=ff_type%eps_spline, & max_energy=ff_type%max_energy, rlow_nb=ff_type%rlow_nb, & emax_spline=ff_type%emax_spline, npoints=ff_type%npoints, iw=iw2, iw2=iw3, iw3=iw4, & do_zbl=do_zbl, shift_cutoff=ff_type%shift_cutoff, & - nonbonded_type=nonbonded_type, error=error) + nonbonded_type=nonbonded_type) ! Let the pointers on potparm point to the splines generated in ! spline_nonbond_control. DO ikind = 1, SIZE ( potparm%pot, 1 ) DO jkind = ikind, SIZE ( potparm%pot, 2) n = spline_env % spltab ( ikind, jkind ) spl_p => spline_env%spl_pp(n)%spl_p - CALL spline_data_p_retain ( spl_p, error ) - CALL spline_data_p_release ( potparm%pot(ikind,jkind)%pot%pair_spline_data, error ) + CALL spline_data_p_retain ( spl_p) + CALL spline_data_p_release ( potparm%pot(ikind,jkind)%pot%pair_spline_data) potparm%pot(ikind,jkind)%pot%pair_spline_data => spl_p END DO END DO - CALL spline_env_release(spline_env,error) + CALL spline_env_release(spline_env) CALL timestop(handle2) END SUBROUTINE force_field_pack_splines @@ -3414,18 +3358,16 @@ END SUBROUTINE force_field_pack_splines !> \param ff_type ... !> \param potparm_nonbond ... !> \param ewald_env ... -!> \param error ... !> \author Toon.Verstraelen@gmail.com ! ***************************************************************************** SUBROUTINE force_field_pack_eicut(atomic_kind_set, ff_type, & - potparm_nonbond, ewald_env, error) + potparm_nonbond, ewald_env) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(force_field_type), INTENT(IN) :: ff_type TYPE(pair_potential_pp_type), POINTER :: potparm_nonbond TYPE(ewald_environment_type), POINTER :: ewald_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack_eicut', & routineP = moduleN//':'//routineN @@ -3448,7 +3390,7 @@ SUBROUTINE force_field_pack_eicut(atomic_kind_set, ff_type, & ! allocate the array with interaction cutoffs for the electrostatics, used ! to make the electrostatic interaction continuous at ewald_env%rcut ALLOCATE(interaction_cutoffs(3,nkinds,nkinds), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) interaction_cutoffs = 0.0_dp ! compute the interaction cutoff if SHIFT_CUTOFF is active @@ -3506,18 +3448,16 @@ END SUBROUTINE force_field_pack_eicut !> \param name_atm_b ... !> \param name_atm_c ... !> \param name_atm_d ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** SUBROUTINE issue_duplications(found, routinePext, tag_label, name_atm_a, name_atm_b,& - name_atm_c, name_atm_d, error) + name_atm_c, name_atm_d) LOGICAL, INTENT(IN) :: found CHARACTER(LEN=*), INTENT(IN) :: routinePext, tag_label, & name_atm_a CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name_atm_b, name_atm_c, & name_atm_d - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'issue_duplications', & routineP = moduleN//':'//routineN @@ -3553,16 +3493,14 @@ END SUBROUTINE issue_duplications !> \param type_name ... !> \param fatal ... !> \param array ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE store_FF_missing_par(atm1,atm2,atm3,atm4,type_name,fatal,array,error) + SUBROUTINE store_FF_missing_par(atm1,atm2,atm3,atm4,type_name,fatal,array) CHARACTER(LEN=*), INTENT(IN) :: atm1 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: atm2, atm3, atm4 CHARACTER(LEN=*), INTENT(IN) :: type_name LOGICAL, INTENT(INOUT), OPTIONAL :: fatal CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: array - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'store_FF_missing_par', & routineP = moduleN//':'//routineN @@ -3684,7 +3622,7 @@ SUBROUTINE store_FF_missing_par(atm1,atm2,atm3,atm4,type_name,fatal,array,error) ((atm1==my_atm2).AND.(atm2==my_atm1))) found = .TRUE. CASE DEFAULT ! Should never reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (found) EXIT END DO diff --git a/src/force_fields_ext.F b/src/force_fields_ext.F index e0c826fc54..f736c6d8c7 100644 --- a/src/force_fields_ext.F +++ b/src/force_fields_ext.F @@ -61,15 +61,13 @@ MODULE force_fields_ext !> \param ff_type ... !> \param para_env ... !> \param mm_section ... -!> \param error ... !> \author ikuo ! ***************************************************************************** - SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) + SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section) TYPE(force_field_type), INTENT(INOUT) :: ff_type TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_force_field_gromos', & routineP = moduleN//':'//routineN @@ -92,9 +90,9 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger,parser) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") avail_section( 1) = "TITLE" avail_section( 2) = "TOPPHYSCON" @@ -123,63 +121,63 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) NULLIFY(namearray) ! ATOMTYPENAME SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the ATOMTYPENAME section' - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(avail_section(4)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) CALL reallocate(namearray,1,ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,namearray(itype),lower_to_upper=.TRUE.,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,namearray(itype),lower_to_upper=.TRUE.) IF(iw>0) WRITE(iw,*) "GTOP_INFO| ",TRIM(namearray(itype)) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! SOLVENTCONSTR SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GROMOS_FF| Parsing the SOLVENTATOM section' - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(avail_section(21)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ncon,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ncon) CALL reallocate(gro_info%solvent_k,1,ncon) CALL reallocate(gro_info%solvent_r0,1,ncon) DO icon=1,ncon - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,itemp,error=error) - CALL parser_get_object(parser,itemp,error=error) - CALL parser_get_object(parser,gro_info%solvent_r0(icon),error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,itemp) + CALL parser_get_object(parser,itemp) + CALL parser_get_object(parser,gro_info%solvent_r0(icon)) gro_info%solvent_k(icon)=0.0_dp END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) ! BONDTYPE SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GROMOS_FF| Parsing the BONDTYPE section' label = TRIM(avail_section(7)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) CALL reallocate(gro_info%bond_k,1,ntype) CALL reallocate(gro_info%bond_r0,1,ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,gro_info%bond_k(itype),error=error) - CALL parser_get_object(parser,gro_info%bond_r0(itype),error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,gro_info%bond_k(itype)) + CALL parser_get_object(parser,gro_info%bond_r0(itype)) IF(ff_type%ff_type==do_ff_g96) THEN - gro_info%bond_k(itype) = cp_unit_to_cp2k(gro_info%bond_k(itype),"kjmol*nm^-4",error=error) + gro_info%bond_k(itype) = cp_unit_to_cp2k(gro_info%bond_k(itype),"kjmol*nm^-4") ELSE ! Assume its G87 gro_info%bond_k(itype) = (2.0_dp) * gro_info%bond_k(itype) * gro_info%bond_r0(itype)**2 - gro_info%bond_k(itype) = cp_unit_to_cp2k(gro_info%bond_k(itype),"kjmol*nm^-2",error=error) + gro_info%bond_k(itype) = cp_unit_to_cp2k(gro_info%bond_k(itype),"kjmol*nm^-2") END IF - gro_info%bond_r0(itype)= cp_unit_to_cp2k(gro_info%bond_r0(itype),"nm",error=error) + gro_info%bond_r0(itype)= cp_unit_to_cp2k(gro_info%bond_r0(itype),"nm") IF(iw>0) WRITE(iw,*) "GROMOS_FF| PUT BONDTYPE INFO HERE!!!!" END DO END IF @@ -187,17 +185,17 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) ! BONDANGLETYPE SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GROMOS_FF| Parsing the BONDANGLETYPE section' label = TRIM(avail_section(10)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) CALL reallocate(gro_info%bend_k,1,ntype) CALL reallocate(gro_info%bend_theta0,1,ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,gro_info%bend_k(itype),error=error) - CALL parser_get_object(parser,gro_info%bend_theta0(itype),error=error) - gro_info%bend_theta0(itype) = cp_unit_to_cp2k(gro_info%bend_theta0(itype),"deg",error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,gro_info%bend_k(itype)) + CALL parser_get_object(parser,gro_info%bend_theta0(itype)) + gro_info%bend_theta0(itype) = cp_unit_to_cp2k(gro_info%bend_theta0(itype),"deg") IF(ff_type%ff_type==do_ff_g96) THEN gro_info%bend_theta0(itype) = COS(gro_info%bend_theta0(itype)) ELSE ! Assume its G87 @@ -206,7 +204,7 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) csq = (cost2-SQRT(sdet))/(2.0_dp*cost2-1.0_dp) gro_info%bend_k(itype) = ekt/ACOS(csq)**2 END IF - gro_info%bend_k(itype) = cp_unit_to_cp2k(gro_info%bend_k(itype),"kjmol",error=error) + gro_info%bend_k(itype) = cp_unit_to_cp2k(gro_info%bend_k(itype),"kjmol") IF(iw>0) WRITE(iw,*) "GROMOS_FF| PUT BONDANGLETYPE INFO HERE!!!!" END DO END IF @@ -214,18 +212,18 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) ! IMPDIHEDRALTYPE SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GROMOS_FF| Parsing the IMPDIHEDRALTYPE section' label = TRIM(avail_section(13)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) CALL reallocate(gro_info%impr_k,1,ntype) CALL reallocate(gro_info%impr_phi0,1,ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,gro_info%impr_k(itype),error=error) - CALL parser_get_object(parser,gro_info%impr_phi0(itype),error=error) - gro_info%impr_phi0(itype) = cp_unit_to_cp2k(gro_info%impr_phi0(itype),"deg",error=error) - gro_info%impr_k(itype) = cp_unit_to_cp2k(gro_info%impr_k(itype),"kjmol*deg^-2",error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,gro_info%impr_k(itype)) + CALL parser_get_object(parser,gro_info%impr_phi0(itype)) + gro_info%impr_phi0(itype) = cp_unit_to_cp2k(gro_info%impr_phi0(itype),"deg") + gro_info%impr_k(itype) = cp_unit_to_cp2k(gro_info%impr_k(itype),"kjmol*deg^-2") IF(iw>0) WRITE(iw,*) "GROMOS_FF| PUT IMPDIHEDRALTYPE INFO HERE!!!!" END DO END IF @@ -233,34 +231,34 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) ! DIHEDRALTYPE SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GROMOS_FF| Parsing the DIHEDRALTYPE section' label = TRIM(avail_section(16)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) CALL reallocate(gro_info%torsion_k,1,ntype) CALL reallocate(gro_info%torsion_m,1,ntype) CALL reallocate(gro_info%torsion_phi0,1,ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,gro_info%torsion_k(itype),error=error) - CALL parser_get_object(parser,cosphi0,error=error) - CALL parser_get_object(parser,gro_info%torsion_m(itype),error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,gro_info%torsion_k(itype)) + CALL parser_get_object(parser,cosphi0) + CALL parser_get_object(parser,gro_info%torsion_m(itype)) gro_info%torsion_phi0(itype) = ACOS(cosphi0) - gro_info%torsion_k(itype) = cp_unit_to_cp2k(gro_info%torsion_k(itype),"kjmol",error=error) + gro_info%torsion_k(itype) = cp_unit_to_cp2k(gro_info%torsion_k(itype),"kjmol") IF(iw>0) WRITE(iw,*) "GROMOS_FF| PUT DIHEDRALTYPE INFO HERE!!!!" END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! LJPARAMETERS SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GROMOS_FF| Parsing the LJPARAMETERS section' - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(avail_section(19)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(gro_info%nonbond_a)) offset = SIZE(gro_info%nonbond_a) ntype=SIZE(namearray) @@ -277,21 +275,21 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) gro_info%nonbond_c6_14 = 0._dp DO itype=1,ntype*(ntype+1)/2 - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,iatom,error=error) - CALL parser_get_object(parser,jatom,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,iatom) + CALL parser_get_object(parser,jatom) IF(iatom==jatom) THEN gro_info%nonbond_a(iatom) = namearray(iatom) gro_info%nonbond_a_14(iatom) = namearray(iatom) END IF - CALL parser_get_object(parser,gro_info%nonbond_c12(iatom,jatom),error=error) - CALL parser_get_object(parser,gro_info%nonbond_c6(iatom,jatom),error=error) - CALL parser_get_object(parser,gro_info%nonbond_c12_14(iatom,jatom),error=error) - CALL parser_get_object(parser,gro_info%nonbond_c6_14(iatom,jatom),error=error) - gro_info%nonbond_c6(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c6(iatom,jatom),"kjmol*nm^6",error=error) - gro_info%nonbond_c12(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c12(iatom,jatom),"kjmol*nm^12",error=error) - gro_info%nonbond_c6_14(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c6_14(iatom,jatom),"kjmol*nm^6",error=error) - gro_info%nonbond_c12_14(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c12_14(iatom,jatom),"kjmol*nm^12",error=error) + CALL parser_get_object(parser,gro_info%nonbond_c12(iatom,jatom)) + CALL parser_get_object(parser,gro_info%nonbond_c6(iatom,jatom)) + CALL parser_get_object(parser,gro_info%nonbond_c12_14(iatom,jatom)) + CALL parser_get_object(parser,gro_info%nonbond_c6_14(iatom,jatom)) + gro_info%nonbond_c6(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c6(iatom,jatom),"kjmol*nm^6") + gro_info%nonbond_c12(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c12(iatom,jatom),"kjmol*nm^12") + gro_info%nonbond_c6_14(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c6_14(iatom,jatom),"kjmol*nm^6") + gro_info%nonbond_c12_14(iatom,jatom) = cp_unit_to_cp2k(gro_info%nonbond_c12_14(iatom,jatom),"kjmol*nm^12") gro_info%nonbond_c6_14(jatom,iatom)= gro_info%nonbond_c6_14(iatom,jatom) gro_info%nonbond_c12_14(jatom,iatom)= gro_info%nonbond_c12_14(iatom,jatom) @@ -300,14 +298,14 @@ SUBROUTINE read_force_field_gromos ( ff_type , para_env, mm_section, error ) IF(iw>0) WRITE(iw,*) "GROMOS_FF| PUT LJPARAMETERS INFO HERE!!!!" END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%FF_INFO",error=error) + "PRINT%FF_INFO") CALL timestop(handle) DEALLOCATE(namearray,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE read_force_field_gromos ! ***************************************************************************** @@ -315,15 +313,13 @@ END SUBROUTINE read_force_field_gromos !> \param ff_type ... !> \param para_env ... !> \param mm_section ... -!> \param error ... !> \author ikuo ! ***************************************************************************** - SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) + SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section) TYPE(force_field_type), INTENT(INOUT) :: ff_type TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_force_field_charmm', & routineP = moduleN//':'//routineN @@ -348,9 +344,9 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger,parser) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") avail_section(1) = "BOND" ; bond_section(1) = avail_section(1) avail_section(11)= "BONDS" @@ -381,19 +377,19 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) !----------------------------------------------------------------------------- nbond = 0 DO ilab = 1, SIZE(bond_section) - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(bond_section(ilab)) DO - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF (found) THEN - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) IF (INDEX(string,TRIM(label)) /= 1) CYCLE - CALL charmm_get_next_line(parser,1,error=error) + CALL charmm_get_next_line(parser,1) DO - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) CALL uppercase ( string ) IF(ANY(string == avail_section)) EXIT - CALL parser_get_object(parser,string2,error=error) + CALL parser_get_object(parser,string2) CALL uppercase ( string2 ) nbond = nbond + 1 CALL reallocate(chm_info%bond_a,1,nbond) @@ -402,23 +398,23 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) CALL reallocate(chm_info%bond_r0,1,nbond) chm_info%bond_a(nbond) = string chm_info%bond_b(nbond) = string2 - CALL parser_get_object(parser,chm_info%bond_k(nbond),error=error) - CALL parser_get_object(parser,chm_info%bond_r0(nbond),error=error) + CALL parser_get_object(parser,chm_info%bond_k(nbond)) + CALL parser_get_object(parser,chm_info%bond_r0(nbond)) IF(iw>0) WRITE(iw,*) " CHM BOND ",nbond,& TRIM(chm_info%bond_a(nbond))," ",& TRIM(chm_info%bond_b(nbond))," ",& chm_info%bond_k(nbond),& chm_info%bond_r0(nbond) ! Do some units conversion into internal atomic units - chm_info%bond_r0(nbond) = cp_unit_to_cp2k(chm_info%bond_r0(nbond),"angstrom",error=error) - chm_info%bond_k(nbond) = cp_unit_to_cp2k(chm_info%bond_k(nbond),"kcalmol*angstrom^-2",error=error) - CALL charmm_get_next_line(parser,1,error=error) + chm_info%bond_r0(nbond) = cp_unit_to_cp2k(chm_info%bond_r0(nbond),"angstrom") + chm_info%bond_k(nbond) = cp_unit_to_cp2k(chm_info%bond_k(nbond),"kcalmol*angstrom^-2") + CALL charmm_get_next_line(parser,1) END DO ELSE EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END DO !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -432,20 +428,20 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) nbend = 0 nub = 0 DO ilab = 1, SIZE(angl_section) - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(angl_section(ilab)) DO - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF (found) THEN - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) IF (INDEX(string,TRIM(label)) /= 1) CYCLE - CALL charmm_get_next_line(parser,1,error=error) + CALL charmm_get_next_line(parser,1) DO - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) CALL uppercase ( string ) IF(ANY(string == avail_section)) EXIT - CALL parser_get_object(parser,string2,error=error) - CALL parser_get_object(parser,string3,error=error) + CALL parser_get_object(parser,string2) + CALL parser_get_object(parser,string3) CALL uppercase ( string2 ) CALL uppercase ( string3 ) nbend = nbend + 1 @@ -457,8 +453,8 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%bend_a(nbend) = string chm_info%bend_b(nbend) = string2 chm_info%bend_c(nbend) = string3 - CALL parser_get_object(parser,chm_info%bend_k(nbend),error=error) - CALL parser_get_object(parser,chm_info%bend_theta0(nbend),error=error) + CALL parser_get_object(parser,chm_info%bend_k(nbend)) + CALL parser_get_object(parser,chm_info%bend_theta0(nbend)) IF(iw>0) WRITE(iw,*) " CHM BEND ",nbend,& TRIM(chm_info%bend_a(nbend))," ",& TRIM(chm_info%bend_b(nbend))," ",& @@ -466,9 +462,9 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%bend_k(nbend),& chm_info%bend_theta0(nbend) ! Do some units conversion into internal atomic units - chm_info%bend_theta0(nbend) = cp_unit_to_cp2k(chm_info%bend_theta0(nbend),"deg",error=error) - chm_info%bend_k(nbend) = cp_unit_to_cp2k(chm_info%bend_k(nbend),"kcalmol*rad^-2",error=error) - IF (parser_test_next_token(parser,error=error) == "FLT") THEN + chm_info%bend_theta0(nbend) = cp_unit_to_cp2k(chm_info%bend_theta0(nbend),"deg") + chm_info%bend_k(nbend) = cp_unit_to_cp2k(chm_info%bend_k(nbend),"kcalmol*rad^-2") + IF (parser_test_next_token(parser) == "FLT") THEN nub = nub + 1 CALL reallocate(chm_info%ub_a,1,nub) CALL reallocate(chm_info%ub_b,1,nub) @@ -478,8 +474,8 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%ub_a(nub) = string chm_info%ub_b(nub) = string2 chm_info%ub_c(nub) = string3 - CALL parser_get_object(parser,chm_info%ub_k(nub),error=error) - CALL parser_get_object(parser,chm_info%ub_r0(nub),error=error) + CALL parser_get_object(parser,chm_info%ub_k(nub)) + CALL parser_get_object(parser,chm_info%ub_r0(nub)) IF(iw>0) WRITE(iw,*) " CHM UB ",nub,& TRIM(chm_info%ub_a(nub))," ",& TRIM(chm_info%ub_b(nub))," ",& @@ -487,16 +483,16 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%ub_k(nub),& chm_info%ub_r0(nub) ! Do some units conversion into internal atomic units - chm_info%ub_r0(nub) = cp_unit_to_cp2k(chm_info%ub_r0(nub),"angstrom",error=error) - chm_info%ub_k(nub) = cp_unit_to_cp2k(chm_info%ub_k(nub),"kcalmol*angstrom^-2",error=error) + chm_info%ub_r0(nub) = cp_unit_to_cp2k(chm_info%ub_r0(nub),"angstrom") + chm_info%ub_k(nub) = cp_unit_to_cp2k(chm_info%ub_k(nub),"kcalmol*angstrom^-2") END IF - CALL charmm_get_next_line(parser,1,error=error) + CALL charmm_get_next_line(parser,1) END DO ELSE EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END DO !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -506,21 +502,21 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) !----------------------------------------------------------------------------- ntorsion = 0 DO ilab = 1, SIZE(thet_section) - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(thet_section(ilab)) DO - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF (found) THEN - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) IF (INDEX(string,TRIM(label)) /= 1) CYCLE - CALL charmm_get_next_line(parser,1,error=error) + CALL charmm_get_next_line(parser,1) DO - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) CALL uppercase ( string ) IF(ANY(string == avail_section)) EXIT - CALL parser_get_object(parser,string2,error=error) - CALL parser_get_object(parser,string3,error=error) - CALL parser_get_object(parser,string4,error=error) + CALL parser_get_object(parser,string2) + CALL parser_get_object(parser,string3) + CALL parser_get_object(parser,string4) CALL uppercase ( string2 ) CALL uppercase ( string3 ) CALL uppercase ( string4 ) @@ -536,9 +532,9 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%torsion_b(ntorsion) = string2 chm_info%torsion_c(ntorsion) = string3 chm_info%torsion_d(ntorsion) = string4 - CALL parser_get_object(parser,chm_info%torsion_k(ntorsion),error=error) - CALL parser_get_object(parser,chm_info%torsion_m(ntorsion),error=error) - CALL parser_get_object(parser,chm_info%torsion_phi0(ntorsion),error=error) + CALL parser_get_object(parser,chm_info%torsion_k(ntorsion)) + CALL parser_get_object(parser,chm_info%torsion_m(ntorsion)) + CALL parser_get_object(parser,chm_info%torsion_phi0(ntorsion)) IF(iw>0) WRITE(iw,*) " CHM TORSION ",ntorsion,& TRIM(chm_info%torsion_a(ntorsion))," ",& TRIM(chm_info%torsion_b(ntorsion))," ",& @@ -549,16 +545,15 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%torsion_phi0(ntorsion) ! Do some units conversion into internal atomic units chm_info%torsion_phi0(ntorsion) = cp_unit_to_cp2k(chm_info%torsion_phi0(ntorsion),& - "deg",error=error) - chm_info%torsion_k(ntorsion) = cp_unit_to_cp2k(chm_info%torsion_k(ntorsion),"kcalmol",& - error=error) - CALL charmm_get_next_line(parser,1,error=error) + "deg") + chm_info%torsion_k(ntorsion) = cp_unit_to_cp2k(chm_info%torsion_k(ntorsion),"kcalmol") + CALL charmm_get_next_line(parser,1) END DO ELSE EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END DO !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -568,21 +563,21 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) !----------------------------------------------------------------------------- nimpr = 0 DO ilab = 1, SIZE(impr_section) - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(impr_section(ilab)) DO - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF (found) THEN - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) IF (INDEX(string,TRIM(label)) /= 1) CYCLE - CALL charmm_get_next_line(parser,1,error=error) + CALL charmm_get_next_line(parser,1) DO - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) CALL uppercase ( string ) IF(ANY(string == avail_section)) EXIT - CALL parser_get_object(parser,string2,error=error) - CALL parser_get_object(parser,string3,error=error) - CALL parser_get_object(parser,string4,error=error) + CALL parser_get_object(parser,string2) + CALL parser_get_object(parser,string3) + CALL parser_get_object(parser,string4) CALL uppercase ( string2 ) CALL uppercase ( string3 ) CALL uppercase ( string4 ) @@ -597,9 +592,9 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%impr_b(nimpr) = string2 chm_info%impr_c(nimpr) = string3 chm_info%impr_d(nimpr) = string4 - CALL parser_get_object(parser,chm_info%impr_k(nimpr),error=error) - CALL parser_get_object(parser,dummy,error=error) - CALL parser_get_object(parser,chm_info%impr_phi0(nimpr),error=error) + CALL parser_get_object(parser,chm_info%impr_k(nimpr)) + CALL parser_get_object(parser,dummy) + CALL parser_get_object(parser,chm_info%impr_phi0(nimpr)) IF(iw>0) WRITE(iw,*) " CHM IMPROPERS ",nimpr,& TRIM(chm_info%impr_a(nimpr))," ",& TRIM(chm_info%impr_b(nimpr))," ",& @@ -608,15 +603,15 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) chm_info%impr_k(nimpr),& chm_info%impr_phi0(nimpr) ! Do some units conversion into internal atomic units - chm_info%impr_phi0(nimpr) = cp_unit_to_cp2k(chm_info%impr_phi0(nimpr),"deg",error=error) - chm_info%impr_k(nimpr) = cp_unit_to_cp2k(chm_info%impr_k(nimpr),"kcalmol",error=error) - CALL charmm_get_next_line(parser,1,error=error) + chm_info%impr_phi0(nimpr) = cp_unit_to_cp2k(chm_info%impr_phi0(nimpr),"deg") + chm_info%impr_k(nimpr) = cp_unit_to_cp2k(chm_info%impr_k(nimpr),"kcalmol") + CALL charmm_get_next_line(parser,1) END DO ELSE EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END DO !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -625,16 +620,16 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) nnonbond = 0 nonfo = 0 DO ilab = 1, SIZE(nbon_section) - CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env,error=error) + CALL parser_create(parser,ff_type%ff_file_name,para_env=para_env) label = TRIM(nbon_section(ilab)) DO - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF (found) THEN - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) IF (INDEX(string,TRIM(label)) /= 1) CYCLE - CALL charmm_get_next_line(parser,1,error=error) + CALL charmm_get_next_line(parser,1) DO - CALL parser_get_object(parser,string,error=error) + CALL parser_get_object(parser,string) CALL uppercase ( string ) IF(ANY(string == avail_section)) EXIT nnonbond = nnonbond + 1 @@ -642,45 +637,45 @@ SUBROUTINE read_force_field_charmm ( ff_type, para_env, mm_section, error ) CALL reallocate(chm_info%nonbond_eps,1,nnonbond) CALL reallocate(chm_info%nonbond_rmin2,1,nnonbond) chm_info%nonbond_a(nnonbond) = string - CALL parser_get_object(parser,chm_info%nonbond_eps(nnonbond),error=error) - CALL parser_get_object(parser,chm_info%nonbond_eps(nnonbond),error=error) - CALL parser_get_object(parser,chm_info%nonbond_rmin2(nnonbond),error=error) + CALL parser_get_object(parser,chm_info%nonbond_eps(nnonbond)) + CALL parser_get_object(parser,chm_info%nonbond_eps(nnonbond)) + CALL parser_get_object(parser,chm_info%nonbond_rmin2(nnonbond)) IF(iw>0) WRITE(iw,*) " CHM NONBOND ",nnonbond,& TRIM(chm_info%nonbond_a(nnonbond))," ",& chm_info%nonbond_eps(nnonbond),& chm_info%nonbond_rmin2(nnonbond) chm_info%nonbond_rmin2(nnonbond) = cp_unit_to_cp2k(chm_info%nonbond_rmin2(nnonbond),& - "angstrom", error=error) + "angstrom") chm_info%nonbond_eps(nnonbond) = cp_unit_to_cp2k(chm_info%nonbond_eps(nnonbond),& - "kcalmol",error=error) - IF (parser_test_next_token(parser,error=error) == "FLT") THEN + "kcalmol") + IF (parser_test_next_token(parser) == "FLT") THEN nonfo = nonfo + 1 CALL reallocate(chm_info%nonbond_a_14,1,nonfo) CALL reallocate(chm_info%nonbond_eps_14,1,nonfo) CALL reallocate(chm_info%nonbond_rmin2_14,1,nonfo) chm_info%nonbond_a_14(nonfo) = chm_info%nonbond_a(nnonbond) - CALL parser_get_object(parser,chm_info%nonbond_eps_14(nonfo),error=error) - CALL parser_get_object(parser,chm_info%nonbond_eps_14(nonfo),error=error) - CALL parser_get_object(parser,chm_info%nonbond_rmin2_14(nonfo),error=error) + CALL parser_get_object(parser,chm_info%nonbond_eps_14(nonfo)) + CALL parser_get_object(parser,chm_info%nonbond_eps_14(nonfo)) + CALL parser_get_object(parser,chm_info%nonbond_rmin2_14(nonfo)) IF(iw>0) WRITE(iw,*) " CHM ONFO ",nonfo,& TRIM(chm_info%nonbond_a_14(nonfo))," ",& chm_info%nonbond_eps_14(nonfo),& chm_info%nonbond_rmin2_14(nonfo) chm_info%nonbond_rmin2_14(nonfo) = cp_unit_to_cp2k(chm_info%nonbond_rmin2_14(nonfo),& - "angstrom",error=error) + "angstrom") chm_info%nonbond_eps_14(nonfo) = cp_unit_to_cp2k(chm_info%nonbond_eps_14(nonfo),& - "kcalmol",error=error) + "kcalmol") END IF - CALL charmm_get_next_line(parser,1,error=error) + CALL charmm_get_next_line(parser,1) END DO ELSE EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END DO CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%FF_INFO",error=error) + "PRINT%FF_INFO") CALL timestop(handle) END SUBROUTINE read_force_field_charmm @@ -691,17 +686,15 @@ END SUBROUTINE read_force_field_charmm !> \param para_env ... !> \param mm_section ... !> \param particle_set ... -!> \param error ... !> \author Teodoro Laino [tlaino, teodoro.laino-AT-gmail.com] - 11.2008 ! ***************************************************************************** - SUBROUTINE read_force_field_amber ( ff_type, para_env, mm_section, particle_set, error ) + SUBROUTINE read_force_field_amber ( ff_type, para_env, mm_section, particle_set) TYPE(force_field_type), INTENT(INOUT) :: ff_type TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: mm_section TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_force_field_amber', & routineP = moduleN//':'//routineN @@ -714,15 +707,15 @@ SUBROUTINE read_force_field_amber ( ff_type, para_env, mm_section, particle_set, CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") amb_info => ff_type%amb_info ! Read the Amber topology file to gather the forcefield information CALL rdparm_amber_8(ff_type%ff_file_name, iw, para_env, do_connectivity=.FALSE.,& - do_forcefield=.TRUE., particle_set=particle_set, amb_info=amb_info, error=error) + do_forcefield=.TRUE., particle_set=particle_set, amb_info=amb_info) !----------------------------------------------------------------------------- ! 1. Converts all the Bonds info from the param file here @@ -737,8 +730,8 @@ SUBROUTINE read_force_field_amber ( ff_type, para_env, mm_section, particle_set, amb_info%bond_r0(i) ! Do some units conversion into internal atomic units - amb_info%bond_r0(i) = cp_unit_to_cp2k(amb_info%bond_r0(i),"angstrom",error=error) - amb_info%bond_k(i) = cp_unit_to_cp2k(amb_info%bond_k(i),"kcalmol*angstrom^-2",error=error) + amb_info%bond_r0(i) = cp_unit_to_cp2k(amb_info%bond_r0(i),"angstrom") + amb_info%bond_k(i) = cp_unit_to_cp2k(amb_info%bond_k(i),"kcalmol*angstrom^-2") END DO !----------------------------------------------------------------------------- @@ -758,8 +751,8 @@ SUBROUTINE read_force_field_amber ( ff_type, para_env, mm_section, particle_set, amb_info%bend_theta0(i) ! Do some units conversion into internal atomic units - amb_info%bend_theta0(i) = cp_unit_to_cp2k(amb_info%bend_theta0(i),"rad",error=error) - amb_info%bend_k(i) = cp_unit_to_cp2k(amb_info%bend_k(i),"kcalmol*rad^-2",error=error) + amb_info%bend_theta0(i) = cp_unit_to_cp2k(amb_info%bend_theta0(i),"rad") + amb_info%bend_k(i) = cp_unit_to_cp2k(amb_info%bend_k(i),"kcalmol*rad^-2") END DO !----------------------------------------------------------------------------- @@ -778,8 +771,8 @@ SUBROUTINE read_force_field_amber ( ff_type, para_env, mm_section, particle_set, amb_info%torsion_phi0(i) ! Do some units conversion into internal atomic units - amb_info%torsion_phi0(i) = cp_unit_to_cp2k(amb_info%torsion_phi0(i),"rad",error=error) - amb_info%torsion_k(i) = cp_unit_to_cp2k(amb_info%torsion_k(i),"kcalmol",error=error) + amb_info%torsion_phi0(i) = cp_unit_to_cp2k(amb_info%torsion_phi0(i),"rad") + amb_info%torsion_k(i) = cp_unit_to_cp2k(amb_info%torsion_k(i),"kcalmol") END DO !----------------------------------------------------------------------------- @@ -792,10 +785,10 @@ SUBROUTINE read_force_field_amber ( ff_type, para_env, mm_section, particle_set, amb_info%nonbond_rmin2(i) ! Do some units conversion into internal atomic units - amb_info%nonbond_rmin2(i) = cp_unit_to_cp2k(amb_info%nonbond_rmin2(i),"angstrom", error=error) - amb_info%nonbond_eps(i) = cp_unit_to_cp2k(amb_info%nonbond_eps(i),"kcalmol",error=error) + amb_info%nonbond_rmin2(i) = cp_unit_to_cp2k(amb_info%nonbond_rmin2(i),"angstrom") + amb_info%nonbond_eps(i) = cp_unit_to_cp2k(amb_info%nonbond_eps(i),"kcalmol") END DO - CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%FF_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%FF_INFO") CALL timestop(handle) END SUBROUTINE read_force_field_amber @@ -807,13 +800,11 @@ END SUBROUTINE read_force_field_amber !> This sounds simply crazy.... !> \param parser ... !> \param nline ... -!> \param error ... !> \author Teodoro Laino - Zurich University - 06.2007 ! ***************************************************************************** - SUBROUTINE charmm_get_next_line(parser, nline, error) + SUBROUTINE charmm_get_next_line(parser, nline) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(IN) :: nline - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'charmm_get_next_line', & routineP = moduleN//':'//routineN @@ -824,10 +815,10 @@ SUBROUTINE charmm_get_next_line(parser, nline, error) DO i = 1, nline len_line = LEN_TRIM(parser%input_line) DO WHILE (parser%input_line(len_line:len_line)==continuation_char) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) len_line = LEN_TRIM(parser%input_line) END DO - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) END DO END SUBROUTINE charmm_get_next_line diff --git a/src/force_fields_input.F b/src/force_fields_input.F index a9647b2ddb..9c7e4192ed 100644 --- a/src/force_fields_input.F +++ b/src/force_fields_input.F @@ -82,14 +82,12 @@ MODULE force_fields_input !> \param mm_section ... !> \param ff_type ... !> \param para_env ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env, error ) + SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env) TYPE(section_vals_type), POINTER :: ff_section, mm_section TYPE(force_field_type), INTENT(INOUT) :: ff_type TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_force_field_section1', & routineP = moduleN//':'//routineN @@ -106,21 +104,21 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env NULLIFY(tmp_section, tmp_section2) inp_info => ff_type%inp_info failure = .FALSE. - CALL section_vals_val_get(ff_section,"PARMTYPE",i_val=ff_type%ff_type,error=error) - CALL section_vals_val_get(ff_section,"EI_SCALE14",r_val=ff_type%ei_scale14,error=error) - CALL section_vals_val_get(ff_section,"VDW_SCALE14",r_val=ff_type%vdw_scale14,error=error) - CALL section_vals_val_get(ff_section,"SPLINE%RCUT_NB",r_val=ff_type%rcut_nb,error=error) - CALL section_vals_val_get(ff_section,"SPLINE%R0_NB",r_val=ff_type%rlow_nb,error=error) - CALL section_vals_val_get(ff_section,"SPLINE%EPS_SPLINE",r_val=ff_type%eps_spline,error=error) - CALL section_vals_val_get(ff_section,"SPLINE%EMAX_SPLINE",r_val=ff_type%emax_spline,error=error) - CALL section_vals_val_get(ff_section,"SPLINE%EMAX_ACCURACY",r_val=ff_type%max_energy,error=error) - CALL section_vals_val_get(ff_section,"SPLINE%NPOINTS",i_val=ff_type%npoints,error=error) - CALL section_vals_val_get(ff_section,"IGNORE_MISSING_CRITICAL_PARAMS",l_val=ff_type%ignore_missing_critical,error=error) - CPPostcondition(ff_type%max_energy<=ff_type%emax_spline,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(ff_section,"PARMTYPE",i_val=ff_type%ff_type) + CALL section_vals_val_get(ff_section,"EI_SCALE14",r_val=ff_type%ei_scale14) + CALL section_vals_val_get(ff_section,"VDW_SCALE14",r_val=ff_type%vdw_scale14) + CALL section_vals_val_get(ff_section,"SPLINE%RCUT_NB",r_val=ff_type%rcut_nb) + CALL section_vals_val_get(ff_section,"SPLINE%R0_NB",r_val=ff_type%rlow_nb) + CALL section_vals_val_get(ff_section,"SPLINE%EPS_SPLINE",r_val=ff_type%eps_spline) + CALL section_vals_val_get(ff_section,"SPLINE%EMAX_SPLINE",r_val=ff_type%emax_spline) + CALL section_vals_val_get(ff_section,"SPLINE%EMAX_ACCURACY",r_val=ff_type%max_energy) + CALL section_vals_val_get(ff_section,"SPLINE%NPOINTS",i_val=ff_type%npoints) + CALL section_vals_val_get(ff_section,"IGNORE_MISSING_CRITICAL_PARAMS",l_val=ff_type%ignore_missing_critical) + CPPostcondition(ff_type%max_energy<=ff_type%emax_spline,cp_failure_level,routineP,failure) ! Read the parameter file name only if the force field type requires it.. SELECT CASE(ff_type%ff_type) CASE(do_ff_charmm,do_ff_amber,do_ff_g96,do_ff_g87) - CALL section_vals_val_get(ff_section,"PARM_FILE_NAME",c_val=ff_type%ff_file_name,error=error) + CALL section_vals_val_get(ff_section,"PARM_FILE_NAME",c_val=ff_type%ff_file_name) CALL cp_assert(TRIM(ff_type%ff_file_name)/="",cp_failure_level,cp_assertion_failed,routineP,& "Force Field Parameter's filename is empty! Please check your input file. "//& CPSourceFileRef,& @@ -148,188 +146,188 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env only_ionode=.TRUE.) ff_type%eps_spline = min_eps_spline_allowed END IF - CALL section_vals_val_get(ff_section,"SHIFT_CUTOFF",l_val=ff_type%shift_cutoff,error=error) - CALL section_vals_val_get(ff_section,"SPLINE%UNIQUE_SPLINE",l_val=unique_spline,error=error) + CALL section_vals_val_get(ff_section,"SHIFT_CUTOFF",l_val=ff_type%shift_cutoff) + CALL section_vals_val_get(ff_section,"SPLINE%UNIQUE_SPLINE",l_val=unique_spline) ! Single spline potential_single_allocation = no_potential_single_allocation IF (unique_spline) potential_single_allocation = do_potential_single_allocation - CALL section_vals_val_get(ff_section,"MULTIPLE_POTENTIAL",l_val=ff_type%multiple_potential,error=error) - CALL section_vals_val_get(ff_section,"DO_NONBONDED",l_val=ff_type%do_nonbonded,error=error) - tmp_section => section_vals_get_subs_vals(ff_section,"NONBONDED",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,error=error) + CALL section_vals_val_get(ff_section,"MULTIPLE_POTENTIAL",l_val=ff_type%multiple_potential) + CALL section_vals_val_get(ff_section,"DO_NONBONDED",l_val=ff_type%do_nonbonded) + tmp_section => section_vals_get_subs_vals(ff_section,"NONBONDED") + CALL section_vals_get(tmp_section,explicit=explicit) IF (explicit.AND.ff_type%do_nonbonded) THEN - tmp_section2 => section_vals_get_subs_vals(tmp_section,"LENNARD-JONES",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nlj,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"LENNARD-JONES") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nlj) ntot = 0 IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nlj,lj_charmm=.TRUE.,error=error) - CALL read_lj_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nlj,lj_charmm=.TRUE.) + CALL read_lj_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"WILLIAMS",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nwl,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"WILLIAMS") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nwl) ntot=nlj IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nwl,williams=.TRUE.,error=error) - CALL read_wl_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nwl,williams=.TRUE.) + CALL read_wl_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"EAM",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=neam,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"EAM") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=neam) ntot=nlj+nwl IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+neam,eam=.TRUE.,error=error) - CALL read_eam_section(inp_info%nonbonded,tmp_section2,ntot,para_env,mm_section,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+neam,eam=.TRUE.) + CALL read_eam_section(inp_info%nonbonded,tmp_section2,ntot,para_env,mm_section) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"GOODWIN",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngd,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"GOODWIN") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngd) ntot=nlj+nwl+neam IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+ngd,goodwin=.TRUE.,error=error) - CALL read_gd_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+ngd,goodwin=.TRUE.) + CALL read_gd_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"IPBV",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nipbv,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"IPBV") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nipbv) ntot=nlj+nwl+neam+ngd IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nipbv,ipbv=.TRUE.,error=error) - CALL read_ipbv_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nipbv,ipbv=.TRUE.) + CALL read_ipbv_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"BMHFT",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nbmhft,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"BMHFT") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nbmhft) ntot=nlj+nwl+neam+ngd+nipbv IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nbmhft,bmhft=.TRUE.,error=error) - CALL read_bmhft_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nbmhft,bmhft=.TRUE.) + CALL read_bmhft_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"BMHFTD",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nbmhftd,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"BMHFTD") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nbmhftd) ntot=nlj+nwl+neam+ngd+nipbv+nbmhft IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nbmhftd,bmhftd=.TRUE.,error=error) - CALL read_bmhftd_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nbmhftd,bmhftd=.TRUE.) + CALL read_bmhftd_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"BUCK4RANGES",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nb4,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"BUCK4RANGES") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nb4) ntot=nlj+nwl+neam+ngd+nipbv+nbmhft+nbmhftd IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nb4,buck4r=.TRUE.,error=error) - CALL read_b4_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nb4,buck4r=.TRUE.) + CALL read_b4_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"BUCKMORSE",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nbm,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"BUCKMORSE") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nbm) ntot=nlj+nwl+neam+ngd+nipbv+nbmhft+nbmhftd+nb4 IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nbm,buckmo=.TRUE.,error=error) - CALL read_bm_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nbm,buckmo=.TRUE.) + CALL read_bm_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"GENPOT",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngp,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"GENPOT") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngp) ntot=nlj+nwl+neam+ngd+nipbv+nbmhft+nbmhftd+nb4+nbm IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+ngp,gp=.TRUE.,error=error) - CALL read_gp_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+ngp,gp=.TRUE.) + CALL read_gp_section(inp_info%nonbonded,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"TERSOFF",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ntersoff,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"TERSOFF") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ntersoff) ntot=nlj+nwl+neam+ngd+nipbv+nbmhft+nbmhftd+nb4+nbm+ngp IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+ntersoff,tersoff=.TRUE.,error=error) - CALL read_tersoff_section(inp_info%nonbonded,tmp_section2,ntot,tmp_section2,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+ntersoff,tersoff=.TRUE.) + CALL read_tersoff_section(inp_info%nonbonded,tmp_section2,ntot,tmp_section2) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"SIEPMANN",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nsiepmann,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"SIEPMANN") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nsiepmann) ntot=nlj+nwl+neam+ngd+nipbv+nbmhft+nbmhftd+nb4+nbm+ngp+ntersoff IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nsiepmann,siepmann=.TRUE.,error=error) - CALL read_siepmann_section(inp_info%nonbonded,tmp_section2,ntot,tmp_section2,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nsiepmann,siepmann=.TRUE.) + CALL read_siepmann_section(inp_info%nonbonded,tmp_section2,ntot,tmp_section2) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"quip",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nquip,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"quip") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nquip) ntot=nlj+nwl+neam+ngd+nipbv+nbmhft+nbmhftd+nb4+nbm+ngp+ntersoff+nsiepmann IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nquip,quip=.TRUE.,error=error) - CALL read_quip_section(inp_info%nonbonded,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,ntot+nquip,quip=.TRUE.) + CALL read_quip_section(inp_info%nonbonded,tmp_section2,ntot) END IF END IF - tmp_section => section_vals_get_subs_vals(ff_section,"NONBONDED14",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"NONBONDED14") + CALL section_vals_get(tmp_section,explicit=explicit) IF (explicit.AND.ff_type%do_nonbonded) THEN - tmp_section2 => section_vals_get_subs_vals(tmp_section,"LENNARD-JONES",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nlj,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"LENNARD-JONES") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nlj) ntot = 0 IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+nlj,lj_charmm=.TRUE.,error=error) - CALL read_lj_section(inp_info%nonbonded14,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+nlj,lj_charmm=.TRUE.) + CALL read_lj_section(inp_info%nonbonded14,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"WILLIAMS",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nwl,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"WILLIAMS") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=nwl) ntot=nlj IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+nwl, williams=.TRUE.,error=error) - CALL read_wl_section(inp_info%nonbonded14,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+nwl, williams=.TRUE.) + CALL read_wl_section(inp_info%nonbonded14,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"GOODWIN",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngd,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"GOODWIN") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngd) ntot=nlj+nwl IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+ngd, goodwin=.TRUE.,error=error) - CALL read_gd_section(inp_info%nonbonded14,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+ngd, goodwin=.TRUE.) + CALL read_gd_section(inp_info%nonbonded14,tmp_section2,ntot) END IF - tmp_section2 => section_vals_get_subs_vals(tmp_section,"GENPOT",error=error) - CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngp,error=error) + tmp_section2 => section_vals_get_subs_vals(tmp_section,"GENPOT") + CALL section_vals_get(tmp_section2,explicit=explicit,n_repetition=ngp) ntot=nlj+nwl+ngd IF (explicit) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+ngp,gp=.TRUE.,error=error) - CALL read_gp_section(inp_info%nonbonded14,tmp_section2,ntot,error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,ntot+ngp,gp=.TRUE.) + CALL read_gp_section(inp_info%nonbonded14,tmp_section2,ntot) END IF END IF - tmp_section => section_vals_get_subs_vals(ff_section,"CHARGE",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"CHARGE") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%charge_atm,1,nchg) CALL reallocate(inp_info%charge,1,nchg) - CALL read_chrg_section(inp_info%charge_atm,inp_info%charge,tmp_section,ntot,error) + CALL read_chrg_section(inp_info%charge_atm,inp_info%charge,tmp_section,ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"DIPOLE",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"DIPOLE") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%apol_atm,1,nchg) CALL reallocate(inp_info%apol,1,nchg) CALL read_apol_section(inp_info%apol_atm,inp_info%apol,inp_info%damping_list,& - tmp_section,ntot,error) + tmp_section,ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"QUADRUPOLE",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"QUADRUPOLE") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%cpol_atm,1,nchg) CALL reallocate(inp_info%cpol,1,nchg) - CALL read_cpol_section(inp_info%cpol_atm,inp_info%cpol,tmp_section,ntot,error) + CALL read_cpol_section(inp_info%cpol_atm,inp_info%cpol,tmp_section,ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"SHELL",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nshell,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"SHELL") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nshell) IF (explicit) THEN ntot=0 - CALL shell_p_create(inp_info%shell_list,nshell,error) - CALL read_shell_section(inp_info%shell_list,tmp_section,ntot,para_env,error) + CALL shell_p_create(inp_info%shell_list,nshell) + CALL read_shell_section(inp_info%shell_list,tmp_section,ntot,para_env) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"BOND",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nbonds,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"BOND") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nbonds) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%bond_kind,1,nbonds) @@ -339,10 +337,10 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env CALL reallocate(inp_info%bond_r0,1,nbonds) CALL reallocate(inp_info%bond_cs,1,nbonds) CALL read_bonds_section(inp_info%bond_kind, inp_info%bond_a, inp_info%bond_b, inp_info%bond_k,& - inp_info%bond_r0, inp_info%bond_cs, tmp_section, ntot, error) + inp_info%bond_r0, inp_info%bond_cs, tmp_section, ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"BEND",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nbends,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"BEND") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nbends) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%bend_kind,1,nbends) @@ -360,10 +358,10 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env CALL read_bends_section(inp_info%bend_kind,inp_info%bend_a, inp_info%bend_b, inp_info%bend_c,& inp_info%bend_k, inp_info%bend_theta0, inp_info%bend_cb,& inp_info%bend_r012,inp_info%bend_r032,inp_info%bend_kbs12,inp_info%bend_kbs32,inp_info%bend_kss,& - tmp_section, ntot, error) + tmp_section, ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"BEND",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nubs,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"BEND") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nubs) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%ub_kind,1,nubs) @@ -373,10 +371,10 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env CALL reallocate(inp_info%ub_k,1,3,1,nubs) CALL reallocate(inp_info%ub_r0,1,nubs) CALL read_ubs_section(inp_info%ub_kind,inp_info%ub_a, inp_info%ub_b, inp_info%ub_c,& - inp_info%ub_k, inp_info%ub_r0, tmp_section, ntot, error) + inp_info%ub_k, inp_info%ub_r0, tmp_section, ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"TORSION",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=ntors,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"TORSION") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=ntors) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%torsion_kind,1,ntors) @@ -389,11 +387,11 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env CALL reallocate(inp_info%torsion_phi0,1,ntors) CALL read_torsions_section(inp_info%torsion_kind,inp_info%torsion_a, inp_info%torsion_b,& inp_info%torsion_c,inp_info%torsion_d,inp_info%torsion_k,inp_info%torsion_phi0,& - inp_info%torsion_m,tmp_section, ntot, error ) + inp_info%torsion_m,tmp_section, ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"IMPROPER",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nimpr,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"IMPROPER") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nimpr) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%impr_kind,1,nimpr) @@ -405,11 +403,11 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env CALL reallocate(inp_info%impr_phi0,1,nimpr) CALL read_improper_section(inp_info%impr_kind,inp_info%impr_a, inp_info%impr_b,& inp_info%impr_c,inp_info%impr_d,inp_info%impr_k,inp_info%impr_phi0,& - tmp_section, ntot, error ) + tmp_section, ntot) END IF - tmp_section => section_vals_get_subs_vals(ff_section,"OPBEND",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nopbend,error=error) + tmp_section => section_vals_get_subs_vals(ff_section,"OPBEND") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nopbend) IF (explicit) THEN ntot=0 CALL reallocate(inp_info%opbend_kind,1,nopbend) @@ -421,7 +419,7 @@ SUBROUTINE read_force_field_section1 ( ff_section, mm_section, ff_type, para_env CALL reallocate(inp_info%opbend_phi0,1,nopbend) CALL read_opbend_section(inp_info%opbend_kind,inp_info%opbend_a, inp_info%opbend_b,& inp_info%opbend_c,inp_info%opbend_d,inp_info%opbend_k,inp_info%opbend_phi0,& - tmp_section, ntot, error ) + tmp_section, ntot) END IF END SUBROUTINE read_force_field_section1 @@ -510,31 +508,29 @@ END SUBROUTINE set_IPBV_ff !> \param at1 ... !> \param at2 ... !> \param ft ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE set_BMHFT_ff(at1, at2, ft, error) + SUBROUTINE set_BMHFT_ff(at1, at2, ft) CHARACTER(LEN=*), INTENT(IN) :: at1, at2 TYPE(ft_pot_type), POINTER :: ft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_BMHFT_ff', & routineP = moduleN//':'//routineN - ft%b = cp_unit_to_cp2k(3.1545_dp,"angstrom^-1",error=error) + ft%b = cp_unit_to_cp2k(3.1545_dp,"angstrom^-1") IF ( ( at1(1:2) == 'NA' ) .AND. ( at2 (1:2) == 'NA' ) ) THEN - ft%a = cp_unit_to_cp2k(424.097_dp,"eV",error=error) - ft%c = cp_unit_to_cp2k(1.05_dp,"eV*angstrom^6",error=error) - ft%d = cp_unit_to_cp2k(0.499_dp,"eV*angstrom^8",error=error) + ft%a = cp_unit_to_cp2k(424.097_dp,"eV") + ft%c = cp_unit_to_cp2k(1.05_dp,"eV*angstrom^6") + ft%d = cp_unit_to_cp2k(0.499_dp,"eV*angstrom^8") ELSEIF(((at1(1:2) == 'NA').AND.(at2(1:2) == 'CL')).OR.& ((at1(1:2) == 'CL').AND.(at2(1:2) == 'NA'))) THEN - ft%a = cp_unit_to_cp2k(1256.31_dp,"eV",error=error) - ft%c = cp_unit_to_cp2k(7.00_dp,"eV*angstrom^6",error=error) - ft%d = cp_unit_to_cp2k(8.676_dp,"eV*angstrom^8",error=error) + ft%a = cp_unit_to_cp2k(1256.31_dp,"eV") + ft%c = cp_unit_to_cp2k(7.00_dp,"eV*angstrom^6") + ft%d = cp_unit_to_cp2k(8.676_dp,"eV*angstrom^8") ELSEIF ( ( at1(1:2) == 'CL' ) .AND. ( at2 (1:2) == 'CL' ) ) THEN - ft%a = cp_unit_to_cp2k(3488.998_dp,"eV",error=error) - ft%c = cp_unit_to_cp2k(72.50_dp,"eV*angstrom^6",error=error) - ft%d = cp_unit_to_cp2k(145.427_dp,"eV*angstrom^8",error=error) + ft%a = cp_unit_to_cp2k(3488.998_dp,"eV") + ft%c = cp_unit_to_cp2k(72.50_dp,"eV*angstrom^6") + ft%d = cp_unit_to_cp2k(145.427_dp,"eV*angstrom^8") ELSE CALL stop_program(routineN,moduleN,__LINE__,& "BMHFT only for NaCl") @@ -544,11 +540,9 @@ END SUBROUTINE set_BMHFT_ff ! ***************************************************************************** !> \brief Set up of the BMHFTD force fields -!> \param error ... !> \author Mathieu Salanne 05.2010 ! ***************************************************************************** - SUBROUTINE set_BMHFTD_ff(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE set_BMHFTD_ff() CHARACTER(len=*), PARAMETER :: routineN = 'set_BMHFTD_ff', & routineP = moduleN//':'//routineN @@ -565,16 +559,14 @@ END SUBROUTINE set_BMHFTD_ff !> \param start ... !> \param para_env ... !> \param mm_section ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_eam_section(nonbonded, section, start, para_env, mm_section, error) + SUBROUTINE read_eam_section(nonbonded, section, start, para_env, mm_section) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_eam_section', & routineP = moduleN//':'//routineN @@ -583,9 +575,9 @@ SUBROUTINE read_eam_section(nonbonded, section, start, para_env, mm_section, err DIMENSION(:), POINTER :: atm_names INTEGER :: isec, n_items - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) nonbonded%pot(start+isec)%pot %type = ea_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -593,8 +585,8 @@ SUBROUTINE read_eam_section(nonbonded, section, start, para_env, mm_section, err CALL uppercase(nonbonded%pot(start+isec)%pot %at1) CALL uppercase(nonbonded%pot(start+isec)%pot %at2) CALL section_vals_val_get(section,"PARM_FILE_NAME",i_rep_section=isec,& - c_val=nonbonded%pot(start+isec)%pot%set(1)%eam%eam_file_name,error=error) - CALL read_eam_data ( nonbonded%pot(start+isec)%pot%set(1)%eam, para_env, mm_section,error) + c_val=nonbonded%pot(start+isec)%pot%set(1)%eam%eam_file_name) + CALL read_eam_data ( nonbonded%pot(start+isec)%pot%set(1)%eam, para_env, mm_section) nonbonded%pot(start+isec)%pot%rcutsq = nonbonded%pot(start+isec)%pot%set(1)%eam%acutal**2 END DO END SUBROUTINE read_eam_section @@ -604,14 +596,12 @@ END SUBROUTINE read_eam_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_quip_section(nonbonded, section, start, error) + SUBROUTINE read_quip_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_quip_section', & routineP = moduleN//':'//routineN @@ -620,9 +610,9 @@ SUBROUTINE read_quip_section(nonbonded, section, start, error) DIMENSION(:), POINTER :: args_str, atm_names INTEGER :: is, isec, n_calc_args, n_items - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) nonbonded%pot(start+isec)%pot %type = quip_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -630,9 +620,9 @@ SUBROUTINE read_quip_section(nonbonded, section, start, error) CALL uppercase(nonbonded%pot(start+isec)%pot %at1) CALL uppercase(nonbonded%pot(start+isec)%pot %at2) CALL section_vals_val_get(section,"PARM_FILE_NAME",i_rep_section=isec,& - c_val=nonbonded%pot(start+isec)%pot%set(1)%quip%quip_file_name,error=error) + c_val=nonbonded%pot(start+isec)%pot%set(1)%quip%quip_file_name) CALL section_vals_val_get(section,"INIT_ARGS",i_rep_section=isec,& - c_vals=args_str, error=error) + c_vals=args_str) nonbonded%pot(start+isec)%pot%set(1)%quip%init_args = "" DO is=1, SIZE(args_str) nonbonded%pot(start+isec)%pot%set(1)%quip%init_args = & @@ -640,10 +630,10 @@ SUBROUTINE read_quip_section(nonbonded, section, start, error) " "//TRIM(args_str(is)) END DO ! is CALL section_vals_val_get(section,"CALC_ARGS",i_rep_section=isec,& - n_rep_val=n_calc_args,error=error) + n_rep_val=n_calc_args) IF (n_calc_args > 0) THEN CALL section_vals_val_get(section,"CALC_ARGS",i_rep_section=isec,& - c_vals=args_str,error=error) + c_vals=args_str) DO is=1, SIZE(args_str) nonbonded%pot(start+isec)%pot%set(1)%quip%calc_args = & TRIM(nonbonded%pot(start+isec)%pot%set(1)%quip%calc_args) // & @@ -659,14 +649,12 @@ END SUBROUTINE read_quip_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_lj_section(nonbonded, section, start, error) + SUBROUTINE read_lj_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_lj_section', & routineP = moduleN//':'//routineN @@ -676,12 +664,12 @@ SUBROUTINE read_lj_section(nonbonded, section, start, error) INTEGER :: isec, n_items, n_rep REAL(KIND=dp) :: epsilon, rcut, sigma - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) - CALL section_vals_val_get(section,"EPSILON",i_rep_section=isec,r_val=epsilon,error=error) - CALL section_vals_val_get(section,"SIGMA",i_rep_section=isec,r_val=sigma,error=error) - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) + CALL section_vals_val_get(section,"EPSILON",i_rep_section=isec,r_val=epsilon) + CALL section_vals_val_get(section,"SIGMA",i_rep_section=isec,r_val=sigma) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot %type = lj_charmm_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -693,12 +681,12 @@ SUBROUTINE read_lj_section(nonbonded, section, start, error) nonbonded%pot(start+isec)%pot %set(1)%lj%sigma12 = sigma**12 nonbonded%pot(start+isec)%pot %rcutsq = rcut*rcut ! - CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_lj_section @@ -707,14 +695,12 @@ END SUBROUTINE read_lj_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_wl_section(nonbonded, section, start, error) + SUBROUTINE read_wl_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_wl_section', & routineP = moduleN//':'//routineN @@ -724,13 +710,13 @@ SUBROUTINE read_wl_section(nonbonded, section, start, error) INTEGER :: isec, n_items, n_rep REAL(KIND=dp) :: a, b, c, rcut - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) - CALL section_vals_val_get(section,"A",i_rep_section=isec,r_val=a,error=error) - CALL section_vals_val_get(section,"B",i_rep_section=isec,r_val=b,error=error) - CALL section_vals_val_get(section,"C",i_rep_section=isec,r_val=c,error=error) - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) + CALL section_vals_val_get(section,"A",i_rep_section=isec,r_val=a) + CALL section_vals_val_get(section,"B",i_rep_section=isec,r_val=b) + CALL section_vals_val_get(section,"C",i_rep_section=isec,r_val=c) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot %type = wl_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -742,12 +728,12 @@ SUBROUTINE read_wl_section(nonbonded, section, start, error) nonbonded%pot(start+isec)%pot %set(1)%willis%c = c nonbonded%pot(start+isec)%pot %rcutsq = rcut*rcut ! - CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_wl_section @@ -756,14 +742,12 @@ END SUBROUTINE read_wl_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_gd_section(nonbonded, section, start, error) + SUBROUTINE read_gd_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_gd_section', & routineP = moduleN//':'//routineN @@ -773,15 +757,15 @@ SUBROUTINE read_gd_section(nonbonded, section, start, error) INTEGER :: isec, m, mc, n_items, n_rep REAL(KIND=dp) :: d, dc, rcut, vr0 - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) - CALL section_vals_val_get(section,"VR0",i_rep_section=isec,r_val=vr0,error=error) - CALL section_vals_val_get(section,"D",i_rep_section=isec,r_val=d,error=error) - CALL section_vals_val_get(section,"DC",i_rep_section=isec,r_val=dc,error=error) - CALL section_vals_val_get(section,"M",i_rep_section=isec,i_val=m,error=error) - CALL section_vals_val_get(section,"MC",i_rep_section=isec,i_val=mc,error=error) - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) + CALL section_vals_val_get(section,"VR0",i_rep_section=isec,r_val=vr0) + CALL section_vals_val_get(section,"D",i_rep_section=isec,r_val=d) + CALL section_vals_val_get(section,"DC",i_rep_section=isec,r_val=dc) + CALL section_vals_val_get(section,"M",i_rep_section=isec,i_val=m) + CALL section_vals_val_get(section,"MC",i_rep_section=isec,i_val=mc) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot %type = gw_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -795,12 +779,12 @@ SUBROUTINE read_gd_section(nonbonded, section, start, error) nonbonded%pot(start+isec)%pot %set(1)%goodwin%mc = mc nonbonded%pot(start+isec)%pot %rcutsq = rcut*rcut ! - CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_gd_section @@ -809,14 +793,12 @@ END SUBROUTINE read_gd_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_ipbv_section(nonbonded, section, start, error) + SUBROUTINE read_ipbv_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_ipbv_section', & routineP = moduleN//':'//routineN @@ -826,9 +808,9 @@ SUBROUTINE read_ipbv_section(nonbonded, section, start, error) INTEGER :: isec, n_items, n_rep REAL(KIND=dp) :: rcut - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) nonbonded%pot(start+isec)%pot %type = ip_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) nonbonded%pot(start+isec)%pot %at2 = atm_names(2) @@ -836,15 +818,15 @@ SUBROUTINE read_ipbv_section(nonbonded, section, start, error) CALL uppercase(nonbonded%pot(start+isec)%pot %at2) CALL set_IPBV_ff(nonbonded%pot(start+isec)%pot %at1, nonbonded%pot(start+isec)%pot %at2,& nonbonded%pot(start+isec)%pot%set(1)%ipbv ) - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot%rcutsq = rcut**2 ! - CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_ipbv_section @@ -853,14 +835,12 @@ END SUBROUTINE read_ipbv_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_bmhft_section(nonbonded, section, start, error) + SUBROUTINE read_bmhft_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_bmhft_section', & routineP = moduleN//':'//routineN @@ -872,44 +852,43 @@ SUBROUTINE read_bmhft_section(nonbonded, section, start, error) INTEGER :: i, isec, n_items, n_rep REAL(KIND=dp) :: rcut - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items CALL cite_reference(Tosi1964a) CALL cite_reference(Tosi1964b) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) nonbonded%pot(start+isec)%pot %type = ft_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) nonbonded%pot(start+isec)%pot %at2 = atm_names(2) CALL uppercase(nonbonded%pot(start+isec)%pot %at1) CALL uppercase(nonbonded%pot(start+isec)%pot %at2) - CALL section_vals_val_get(section,"A",i_rep_section=isec,n_rep_val=i,error=error) + CALL section_vals_val_get(section,"A",i_rep_section=isec,n_rep_val=i) IF (i==1) THEN CALL section_vals_val_get(section,"A",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%a,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%a) CALL section_vals_val_get(section,"B",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%b,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%b) CALL section_vals_val_get(section,"C",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%c,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%c) CALL section_vals_val_get(section,"D",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%d,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ft%d) ELSE - CALL section_vals_val_get(section,"MAP_ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"MAP_ATOMS",i_rep_section=isec,c_vals=atm_names) map_atoms = atm_names CALL uppercase(map_atoms(1)) CALL uppercase(map_atoms(2)) - CALL set_BMHFT_ff(map_atoms(1), map_atoms(2), nonbonded%pot(start+isec)%pot%set(1)%ft,& - error=error) + CALL set_BMHFT_ff(map_atoms(1), map_atoms(2), nonbonded%pot(start+isec)%pot%set(1)%ft) END IF - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot%rcutsq = rcut**2 ! - CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_bmhft_section @@ -918,14 +897,12 @@ END SUBROUTINE read_bmhft_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author Mathieu Salanne 05.2010 ! ***************************************************************************** - SUBROUTINE read_bmhftd_section(nonbonded, section, start, error) + SUBROUTINE read_bmhftd_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_bmhftd_section', & routineP = moduleN//':'//routineN @@ -937,46 +914,46 @@ SUBROUTINE read_bmhftd_section(nonbonded, section, start, error) INTEGER :: i, isec, n_items, n_rep REAL(KIND=dp) :: rcut - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items CALL cite_reference(Tosi1964a) CALL cite_reference(Tosi1964b) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) nonbonded%pot(start+isec)%pot %type = ftd_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) nonbonded%pot(start+isec)%pot %at2 = atm_names(2) CALL uppercase(nonbonded%pot(start+isec)%pot %at1) CALL uppercase(nonbonded%pot(start+isec)%pot %at2) - CALL section_vals_val_get(section,"A",i_rep_section=isec,n_rep_val=i,error=error) + CALL section_vals_val_get(section,"A",i_rep_section=isec,n_rep_val=i) IF (i==1) THEN CALL section_vals_val_get(section,"A",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%a,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%a) CALL section_vals_val_get(section,"B",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%b,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%b) CALL section_vals_val_get(section,"C",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%c,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%c) CALL section_vals_val_get(section,"D",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%d,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%d) CALL section_vals_val_get(section,"BD",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%bd,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%ftd%bd) ELSE - CALL section_vals_val_get(section,"MAP_ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"MAP_ATOMS",i_rep_section=isec,c_vals=atm_names) map_atoms = atm_names CALL uppercase(map_atoms(1)) CALL uppercase(map_atoms(2)) - CALL set_BMHFTD_ff(error=error) + CALL set_BMHFTD_ff() END IF - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot%rcutsq = rcut**2 ! - CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_bmhftd_section @@ -985,17 +962,15 @@ END SUBROUTINE read_bmhftd_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \par History !> MK (11.11.2010): Automatic fit of the (default) polynomial coefficients !> \author MI,MK ! ***************************************************************************** - SUBROUTINE read_b4_section(nonbonded,section,start,error) + SUBROUTINE read_b4_section(nonbonded,section,start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_b4_section', & routineP = moduleN//':'//routineN @@ -1017,23 +992,23 @@ SUBROUTINE read_b4_section(nonbonded,section,start,error) NULLIFY (coeff1) NULLIFY (coeff2) - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec=1,n_items - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) - CALL section_vals_val_get(section,"A",i_rep_section=isec,r_val=a,error=error) - CALL section_vals_val_get(section,"B",i_rep_section=isec,r_val=b,error=error) - CALL section_vals_val_get(section,"C",i_rep_section=isec,r_val=c,error=error) - CALL section_vals_val_get(section,"R1",i_rep_section=isec,r_val=r1,error=error) - CALL section_vals_val_get(section,"R2",i_rep_section=isec,r_val=r2,error=error) - CALL section_vals_val_get(section,"R3",i_rep_section=isec,r_val=r3,error=error) - CALL section_vals_val_get(section,"POLY1",explicit=explicit_poly1,n_rep_val=n_rep,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) + CALL section_vals_val_get(section,"A",i_rep_section=isec,r_val=a) + CALL section_vals_val_get(section,"B",i_rep_section=isec,r_val=b) + CALL section_vals_val_get(section,"C",i_rep_section=isec,r_val=c) + CALL section_vals_val_get(section,"R1",i_rep_section=isec,r_val=r1) + CALL section_vals_val_get(section,"R2",i_rep_section=isec,r_val=r2) + CALL section_vals_val_get(section,"R3",i_rep_section=isec,r_val=r3) + CALL section_vals_val_get(section,"POLY1",explicit=explicit_poly1,n_rep_val=n_rep) ! Check if polynomial coefficients were specified for range 2 and 3 explicitly IF (explicit_poly1) THEN np1 = 0 DO ir=1,n_rep NULLIFY (list) - CALL section_vals_val_get(section,"POLY1",i_rep_val=ir,r_vals=list,error=error) + CALL section_vals_val_get(section,"POLY1",i_rep_val=ir,r_vals=list) IF (ASSOCIATED(list)) THEN CALL reallocate(coeff1,0,np1+SIZE(list)-1) DO i=1,SIZE(list) @@ -1043,12 +1018,12 @@ SUBROUTINE read_b4_section(nonbonded,section,start,error) END IF END DO END IF - CALL section_vals_val_get(section,"POLY2",explicit=explicit_poly2,n_rep_val=n_rep,error=error) + CALL section_vals_val_get(section,"POLY2",explicit=explicit_poly2,n_rep_val=n_rep) IF (explicit_poly2) THEN np2 = 0 DO ir=1,n_rep NULLIFY (list) - CALL section_vals_val_get(section,"POLY2",i_rep_val=ir,r_vals=list,error=error) + CALL section_vals_val_get(section,"POLY2",i_rep_val=ir,r_vals=list) IF (ASSOCIATED(list)) THEN CALL reallocate(coeff2,0,np2+SIZE(list)-1) DO i=1,SIZE(list) @@ -1126,7 +1101,7 @@ SUBROUTINE read_b4_section(nonbonded,section,start,error) v(10) = -7.0_dp*v(9)/r3 ! Calculate p_inv the inverse of the matrix p p_inv(:,:) = 0.0_dp - CALL invert_matrix(p,p_inv,eval_error,error=error) + CALL invert_matrix(p,p_inv,eval_error) CALL cp_assert((eval_error < 1.0E-8_dp),cp_warning_level,cp_assertion_failed,routineP,& "The polynomial fit for the BUCK4RANGES potential is only accurate to "//& TRIM(cp_to_string(eval_error)),only_ionode=.TRUE.) @@ -1135,7 +1110,7 @@ SUBROUTINE read_b4_section(nonbonded,section,start,error) x(:) = MATMUL(p_inv(:,:),v(:)) END IF - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot%type = b4_type nonbonded%pot(start+isec)%pot%at1 = atm_names(1) @@ -1155,30 +1130,28 @@ SUBROUTINE read_b4_section(nonbonded,section,start,error) nonbonded%pot(start+isec)%pot%set(1)%buck4r%poly2(0:3) = x(7:10) ELSE nonbonded%pot(start+isec)%pot%set(1)%buck4r%npoly1 = np1-1 - CPPostcondition((np1 - 1 <= 10),cp_failure_level,routineP,error,failure) + CPPostcondition((np1 - 1 <= 10),cp_failure_level,routineP,failure) nonbonded%pot(start+isec)%pot%set(1)%buck4r%poly1(0:np1-1) = coeff1(0:np1-1) nonbonded%pot(start+isec)%pot%set(1)%buck4r%npoly2 = np2-1 - CPPostcondition((np2 - 1 <= 10),cp_failure_level,routineP,error,failure) + CPPostcondition((np2 - 1 <= 10),cp_failure_level,routineP,failure) nonbonded%pot(start+isec)%pot%set(1)%buck4r%poly2(0:np2-1) = coeff2(0:np2-1) END IF nonbonded%pot(start+isec)%pot%rcutsq = rcut*rcut IF (ASSOCIATED(coeff1)) THEN DEALLOCATE (coeff1,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(coeff2)) THEN DEALLOCATE (coeff2,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF - CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,n_rep_val=n_rep,error=error) + CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,n_rep_val=n_rep) IF (n_rep == 1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,& - error=error) - CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,n_rep_val=n_rep,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,n_rep_val=n_rep) IF (n_rep == 1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,& - error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_b4_section @@ -1188,14 +1161,12 @@ END SUBROUTINE read_b4_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author Teodoro Laino - 10.2006 ! ***************************************************************************** - SUBROUTINE read_gp_section(nonbonded, section, start, error) + SUBROUTINE read_gp_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_gp_section', & routineP = moduleN//':'//routineN @@ -1207,11 +1178,11 @@ SUBROUTINE read_gp_section(nonbonded, section, start, error) REAL(KIND=dp) :: rcut failure = .FALSE. - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items NULLIFY(atm_names) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot%type = gp_type nonbonded%pot(start+isec)%pot%at1 = atm_names(1) nonbonded%pot(start+isec)%pot%at2 = atm_names(2) @@ -1221,15 +1192,15 @@ SUBROUTINE read_gp_section(nonbonded, section, start, error) ! Parse the genpot info CALL get_generic_info(section,"FUNCTION",nonbonded%pot(start+isec)%pot%set(1)%gp%potential,& nonbonded%pot(start+isec)%pot%set(1)%gp%parameters,nonbonded%pot(start+isec)%pot%set(1)%gp%values,& - size_variables=1,i_rep_sec=isec,error=error) + size_variables=1,i_rep_sec=isec) nonbonded%pot(start+isec)%pot%set(1)%gp%variables = nonbonded%pot(start+isec)%pot%set(1)%gp%parameters(1) ! - CALL section_vals_val_get(section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get(section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get(section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get(section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_gp_section @@ -1239,15 +1210,13 @@ END SUBROUTINE read_gp_section !> \param section ... !> \param start ... !> \param tersoff_section ... -!> \param error ... !> \author ikuo ! ***************************************************************************** - SUBROUTINE read_tersoff_section(nonbonded, section, start, tersoff_section,error) + SUBROUTINE read_tersoff_section(nonbonded, section, start, tersoff_section) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start TYPE(section_vals_type), POINTER :: tersoff_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_tersoff_section', & routineP = moduleN//':'//routineN @@ -1257,10 +1226,10 @@ SUBROUTINE read_tersoff_section(nonbonded, section, start, tersoff_section,error INTEGER :: isec, n_items, n_rep REAL(KIND=dp) :: rcut, rcutsq - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items CALL cite_reference(Tersoff1988) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) nonbonded%pot(start+isec)%pot %type = tersoff_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -1268,19 +1237,19 @@ SUBROUTINE read_tersoff_section(nonbonded, section, start, tersoff_section,error CALL uppercase(nonbonded%pot(start+isec)%pot %at1) CALL uppercase(nonbonded%pot(start+isec)%pot %at2) - CALL section_vals_val_get(tersoff_section,"A",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%A,error=error) - CALL section_vals_val_get(tersoff_section,"B",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%B,error=error) - CALL section_vals_val_get(tersoff_section,"lambda1",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%lambda1,error=error) - CALL section_vals_val_get(tersoff_section,"lambda2",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%lambda2,error=error) - CALL section_vals_val_get(tersoff_section,"alpha",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%alpha,error=error) - CALL section_vals_val_get(tersoff_section,"beta",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%beta,error=error) - CALL section_vals_val_get(tersoff_section,"n",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%n,error=error) - CALL section_vals_val_get(tersoff_section,"c",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%c,error=error) - CALL section_vals_val_get(tersoff_section,"d",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%d,error=error) - CALL section_vals_val_get(tersoff_section,"h",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%h,error=error) - CALL section_vals_val_get(tersoff_section,"lambda3",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%lambda3,error=error) - CALL section_vals_val_get(tersoff_section,"bigR",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%bigR,error=error) - CALL section_vals_val_get(tersoff_section,"bigD",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%bigD,error=error) + CALL section_vals_val_get(tersoff_section,"A",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%A) + CALL section_vals_val_get(tersoff_section,"B",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%B) + CALL section_vals_val_get(tersoff_section,"lambda1",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%lambda1) + CALL section_vals_val_get(tersoff_section,"lambda2",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%lambda2) + CALL section_vals_val_get(tersoff_section,"alpha",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%alpha) + CALL section_vals_val_get(tersoff_section,"beta",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%beta) + CALL section_vals_val_get(tersoff_section,"n",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%n) + CALL section_vals_val_get(tersoff_section,"c",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%c) + CALL section_vals_val_get(tersoff_section,"d",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%d) + CALL section_vals_val_get(tersoff_section,"h",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%h) + CALL section_vals_val_get(tersoff_section,"lambda3",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%lambda3) + CALL section_vals_val_get(tersoff_section,"bigR",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%bigR) + CALL section_vals_val_get(tersoff_section,"bigD",r_val=nonbonded%pot(start+isec)%pot%set(1)%tersoff%bigD) rcutsq = (nonbonded%pot(start+isec)%pot%set(1)%tersoff%bigR+& nonbonded%pot(start+isec)%pot%set(1)%tersoff%bigD)**2 @@ -1288,9 +1257,9 @@ SUBROUTINE read_tersoff_section(nonbonded, section, start, tersoff_section,error nonbonded%pot(start+isec)%pot%rcutsq = rcutsq ! In case it is defined override the standard specification of RCUT - CALL section_vals_val_get ( tersoff_section, "RCUT", n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( tersoff_section, "RCUT", n_rep_val=n_rep) IF(n_rep==1) THEN - CALL section_vals_val_get(tersoff_section,"RCUT",r_val=rcut,error=error) + CALL section_vals_val_get(tersoff_section,"RCUT",r_val=rcut) nonbonded%pot(start+isec)%pot %rcutsq = rcut**2 END IF END DO @@ -1302,15 +1271,13 @@ END SUBROUTINE read_tersoff_section !> \param section ... !> \param start ... !> \param siepmann_section ... -!> \param error ... !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE read_siepmann_section(nonbonded, section, start, siepmann_section,error) + SUBROUTINE read_siepmann_section(nonbonded, section, start, siepmann_section) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start TYPE(section_vals_type), POINTER :: siepmann_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_siepmann_section', & routineP = moduleN//':'//routineN @@ -1320,10 +1287,10 @@ SUBROUTINE read_siepmann_section(nonbonded, section, start, siepmann_section,err INTEGER :: isec, n_items, n_rep REAL(KIND=dp) :: rcut - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items CALL cite_reference(Siepmann1995) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) nonbonded%pot(start+isec)%pot %type = siepmann_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -1331,18 +1298,18 @@ SUBROUTINE read_siepmann_section(nonbonded, section, start, siepmann_section,err CALL uppercase(nonbonded%pot(start+isec)%pot %at1) CALL uppercase(nonbonded%pot(start+isec)%pot %at2) - CALL section_vals_val_get(siepmann_section,"B",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%B,error=error) - CALL section_vals_val_get(siepmann_section,"D",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%D,error=error) - CALL section_vals_val_get(siepmann_section,"E",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%E,error=error) - CALL section_vals_val_get(siepmann_section,"F",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%F,error=error) - CALL section_vals_val_get(siepmann_section,"beta",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%beta,error=error) + CALL section_vals_val_get(siepmann_section,"B",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%B) + CALL section_vals_val_get(siepmann_section,"D",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%D) + CALL section_vals_val_get(siepmann_section,"E",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%E) + CALL section_vals_val_get(siepmann_section,"F",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%F) + CALL section_vals_val_get(siepmann_section,"beta",r_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%beta) CALL section_vals_val_get(siepmann_section,"ALLOW_OH_FORMATION",& - l_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%allow_oh_formation,error=error) + l_val=nonbonded%pot(start+isec)%pot%set(1)%siepmann%allow_oh_formation) ! ! In case it is defined override the standard specification of RCUT - CALL section_vals_val_get ( siepmann_section, "RCUT", n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( siepmann_section, "RCUT", n_rep_val=n_rep) IF(n_rep==1) THEN - CALL section_vals_val_get(siepmann_section,"RCUT",r_val=rcut,error=error) + CALL section_vals_val_get(siepmann_section,"RCUT",r_val=rcut) nonbonded%pot(start+isec)%pot %rcutsq = rcut**2 nonbonded%pot(start+isec)%pot%set(1)%siepmann%rcutsq = rcut**2 END IF @@ -1354,14 +1321,12 @@ END SUBROUTINE read_siepmann_section !> \param nonbonded ... !> \param section ... !> \param start ... -!> \param error ... !> \author MI ! ***************************************************************************** - SUBROUTINE read_bm_section(nonbonded, section, start, error) + SUBROUTINE read_bm_section(nonbonded, section, start) TYPE(pair_potential_p_type), POINTER :: nonbonded TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_bm_section', & routineP = moduleN//':'//routineN @@ -1374,20 +1339,20 @@ SUBROUTINE read_bm_section(nonbonded, section, start, error) f0, r0, rcut failure = .FALSE. - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items CALL cite_reference(Yamada2000) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) - CALL section_vals_val_get(section,"F0",i_rep_section=isec,r_val=f0,error=error) - CALL section_vals_val_get(section,"A1",i_rep_section=isec,r_val=a1,error=error) - CALL section_vals_val_get(section,"A2",i_rep_section=isec,r_val=a2,error=error) - CALL section_vals_val_get(section,"B1",i_rep_section=isec,r_val=b1,error=error) - CALL section_vals_val_get(section,"B2",i_rep_section=isec,r_val=b2,error=error) - CALL section_vals_val_get(section,"C",i_rep_section=isec,r_val=c,error=error) - CALL section_vals_val_get(section,"D",i_rep_section=isec,r_val=d,error=error) - CALL section_vals_val_get(section,"R0",i_rep_section=isec,r_val=r0,error=error) - CALL section_vals_val_get(section,"Beta",i_rep_section=isec,r_val=beta,error=error) - CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut,error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) + CALL section_vals_val_get(section,"F0",i_rep_section=isec,r_val=f0) + CALL section_vals_val_get(section,"A1",i_rep_section=isec,r_val=a1) + CALL section_vals_val_get(section,"A2",i_rep_section=isec,r_val=a2) + CALL section_vals_val_get(section,"B1",i_rep_section=isec,r_val=b1) + CALL section_vals_val_get(section,"B2",i_rep_section=isec,r_val=b2) + CALL section_vals_val_get(section,"C",i_rep_section=isec,r_val=c) + CALL section_vals_val_get(section,"D",i_rep_section=isec,r_val=d) + CALL section_vals_val_get(section,"R0",i_rep_section=isec,r_val=r0) + CALL section_vals_val_get(section,"Beta",i_rep_section=isec,r_val=beta) + CALL section_vals_val_get(section,"RCUT",i_rep_section=isec,r_val=rcut) nonbonded%pot(start+isec)%pot %type = bm_type nonbonded%pot(start+isec)%pot %at1 = atm_names(1) @@ -1405,12 +1370,12 @@ SUBROUTINE read_bm_section(nonbonded, section, start, error) nonbonded%pot(start+isec)%pot %set(1)%buckmo%beta = beta nonbonded%pot(start+isec)%pot %rcutsq = rcut*rcut ! - CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep, error=error) + CALL section_vals_val_get ( section, "RMIN", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMIN",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin,error=error) - CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep, error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmin) + CALL section_vals_val_get ( section, "RMAX", i_rep_section=isec, n_rep_val=n_rep) IF(n_rep==1) CALL section_vals_val_get(section,"RMAX",i_rep_section=isec,& - r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax,error=error) + r_val=nonbonded%pot(start+isec)%pot%set(1)%rmax) END DO END SUBROUTINE read_bm_section @@ -1420,16 +1385,14 @@ END SUBROUTINE read_bm_section !> \param charge ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_chrg_section(charge_atm, charge, section, start, error) + SUBROUTINE read_chrg_section(charge_atm, charge, section, start) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: charge_atm REAL(KIND=dp), DIMENSION(:), POINTER :: charge TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_chrg_section', & routineP = moduleN//':'//routineN @@ -1437,14 +1400,12 @@ SUBROUTINE read_chrg_section(charge_atm, charge, section, start, error) CHARACTER(LEN=default_string_length) :: atm_name INTEGER :: isec, n_items - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOM",i_rep_section=isec,c_val=atm_name,& - error=error) + CALL section_vals_val_get(section,"ATOM",i_rep_section=isec,c_val=atm_name) charge_atm(start+isec) = atm_name CALL uppercase(charge_atm(start+isec)) - CALL section_vals_val_get(section,"CHARGE",i_rep_section=isec,r_val=charge(start+isec),& - error=error) + CALL section_vals_val_get(section,"CHARGE",i_rep_section=isec,r_val=charge(start+isec)) END DO END SUBROUTINE read_chrg_section @@ -1455,11 +1416,10 @@ END SUBROUTINE read_chrg_section !> \param damping_list ... !> \param section ... !> \param start ... -!> \param error ... !> \author Marcel Baer ! ***************************************************************************** SUBROUTINE read_apol_section(apol_atm, apol, damping_list, section,& - start, error) + start) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: apol_atm REAL(KIND=dp), DIMENSION(:), POINTER :: apol @@ -1467,7 +1427,6 @@ SUBROUTINE read_apol_section(apol_atm, apol, damping_list, section,& POINTER :: damping_list TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_apol_section', & routineP = moduleN//':'//routineN @@ -1479,14 +1438,14 @@ SUBROUTINE read_apol_section(apol_atm, apol, damping_list, section,& LOGICAL :: failure TYPE(section_vals_type), POINTER :: tmp_section - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) NULLIFY(tmp_section) n_damp=0 ! *** Counts number of DIPOLE%DAMPING sections **** DO isec = 1, n_items tmp_section => section_vals_get_subs_vals(section,"DAMPING",& - i_rep_section=isec,error=error) - CALL section_vals_get(tmp_section,n_repetition=tmp_damp,error=error) + i_rep_section=isec) + CALL section_vals_get(tmp_section,n_repetition=tmp_damp) n_damp=n_damp+tmp_damp END DO @@ -1494,40 +1453,37 @@ SUBROUTINE read_apol_section(apol_atm, apol, damping_list, section,& IF (n_damp > 0) THEN failure=.FALSE. ALLOCATE (damping_list(1:n_damp),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ! *** Reads DIPOLE sections ***** start_damp=0 DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOM",i_rep_section=isec,c_val=atm_name,& - error=error) + CALL section_vals_val_get(section,"ATOM",i_rep_section=isec,c_val=atm_name) apol_atm(start+isec) = atm_name CALL uppercase(apol_atm(start+isec)) - CALL section_vals_val_get(section,"APOL",i_rep_section=isec,r_val=apol(start+isec),& - error=error) + CALL section_vals_val_get(section,"APOL",i_rep_section=isec,r_val=apol(start+isec)) tmp_section => section_vals_get_subs_vals(section,"DAMPING",& - i_rep_section=isec,error=error) - CALL section_vals_get(tmp_section,n_repetition=tmp_damp,error=error) + i_rep_section=isec) + CALL section_vals_get(tmp_section,n_repetition=tmp_damp) DO isec_damp=1,tmp_damp damping_list(start_damp+isec_damp)%atm_name1=apol_atm(start+isec) CALL section_vals_val_get(tmp_section,"ATOM",i_rep_section=isec_damp,& - c_val=atm_name,& - error=error) + c_val=atm_name) damping_list(start_damp+isec_damp)%atm_name2=atm_name CALL uppercase(damping_list(start_damp+isec_damp)%atm_name2) CALL section_vals_val_get(tmp_section,"TYPE",i_rep_section=isec_damp,& - c_val=atm_name,error=error) + c_val=atm_name) damping_list(start_damp+isec_damp)%dtype=atm_name CALL uppercase(damping_list(start_damp+isec_damp)%dtype) CALL section_vals_val_get(tmp_section,"ORDER",i_rep_section=isec_damp,& - i_val=damping_list(start_damp+isec_damp)%order, error=error) + i_val=damping_list(start_damp+isec_damp)%order) CALL section_vals_val_get(tmp_section,"BIJ",i_rep_section=isec_damp,& - r_val=damping_list(start_damp+isec_damp)%bij, error=error) + r_val=damping_list(start_damp+isec_damp)%bij) CALL section_vals_val_get(tmp_section,"CIJ",i_rep_section=isec_damp,& - r_val=damping_list(start_damp+isec_damp)%cij, error=error) + r_val=damping_list(start_damp+isec_damp)%cij) END DO start_damp=start_damp+tmp_damp @@ -1541,16 +1497,14 @@ END SUBROUTINE read_apol_section !> \param cpol ... !> \param section ... !> \param start ... -!> \param error ... !> \author Marcel Baer ! ***************************************************************************** - SUBROUTINE read_cpol_section(cpol_atm, cpol, section, start, error) + SUBROUTINE read_cpol_section(cpol_atm, cpol, section, start) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: cpol_atm REAL(KIND=dp), DIMENSION(:), POINTER :: cpol TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_cpol_section', & routineP = moduleN//':'//routineN @@ -1558,14 +1512,12 @@ SUBROUTINE read_cpol_section(cpol_atm, cpol, section, start, error) CHARACTER(LEN=default_string_length) :: atm_name INTEGER :: isec, n_items - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"ATOM",i_rep_section=isec,c_val=atm_name,& - error=error) + CALL section_vals_val_get(section,"ATOM",i_rep_section=isec,c_val=atm_name) cpol_atm(start+isec) = atm_name CALL uppercase(cpol_atm(start+isec)) - CALL section_vals_val_get(section,"CPOL",i_rep_section=isec,r_val=cpol(start+isec),& - error=error) + CALL section_vals_val_get(section,"CPOL",i_rep_section=isec,r_val=cpol(start+isec)) END DO END SUBROUTINE read_cpol_section @@ -1576,17 +1528,15 @@ END SUBROUTINE read_cpol_section !> \param section ... !> \param start ... !> \param para_env ... -!> \param error ... !> \author Marcella Iannuzzi ! ***************************************************************************** - SUBROUTINE read_shell_section(shell_list,section,start,para_env,error) + SUBROUTINE read_shell_section(shell_list,section,start,para_env) TYPE(shell_p_type), DIMENSION(:), & POINTER :: shell_list TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_shell_section', & routineP = moduleN//':'//routineN @@ -1596,36 +1546,36 @@ SUBROUTINE read_shell_section(shell_list,section,start,para_env,error) REAL(dp) :: ccharge, cutoff, k, maxdist, & mfrac, scharge - CALL section_vals_get(section,n_repetition=n_rep,error=error) + CALL section_vals_get(section,n_repetition=n_rep) DO i_rep = 1, n_rep CALL section_vals_val_get(section,"_SECTION_PARAMETERS_",& - c_val=atm_name,i_rep_section=i_rep,error=error) + c_val=atm_name,i_rep_section=i_rep) CALL uppercase(atm_name) shell_list(start+i_rep)%atm_name = atm_name - CALL section_vals_val_get(section,"CORE_CHARGE",i_rep_section=i_rep,r_val=ccharge,error=error) + CALL section_vals_val_get(section,"CORE_CHARGE",i_rep_section=i_rep,r_val=ccharge) shell_list(start+i_rep)%shell%charge_core = ccharge - CALL section_vals_val_get(section,"SHELL_CHARGE",i_rep_section=i_rep,r_val=scharge,error=error) + CALL section_vals_val_get(section,"SHELL_CHARGE",i_rep_section=i_rep,r_val=scharge) shell_list(start+i_rep)%shell%charge_shell = scharge - CALL section_vals_val_get(section,"MASS_FRACTION",i_rep_section=i_rep,r_val=mfrac,error=error) + CALL section_vals_val_get(section,"MASS_FRACTION",i_rep_section=i_rep,r_val=mfrac) shell_list(start+i_rep)%shell%massfrac = mfrac - CALL section_vals_val_get(section,"K2_SPRING",i_rep_section=i_rep,r_val=k,error=error) + CALL section_vals_val_get(section,"K2_SPRING",i_rep_section=i_rep,r_val=k) IF (k < 0.0_dp) THEN CALL stop_program(routineN,moduleN,__LINE__,& "An invalid value was specified for the force constant k2 of the core-shell "//& "spring potential",para_env) END IF shell_list(start+i_rep)%shell%k2_spring = k - CALL section_vals_val_get(section,"K4_SPRING",i_rep_section=i_rep,r_val=k,error=error) + CALL section_vals_val_get(section,"K4_SPRING",i_rep_section=i_rep,r_val=k) IF (k < 0.0_dp) THEN CALL stop_program(routineN,moduleN,__LINE__,& "An invalid value was specified for the force constant k4 of the core-shell "//& "spring potential",para_env) END IF shell_list(start+i_rep)%shell%k4_spring = k - CALL section_vals_val_get(section,"MAX_DISTANCE",i_rep_section=i_rep,r_val=maxdist,error=error) + CALL section_vals_val_get(section,"MAX_DISTANCE",i_rep_section=i_rep,r_val=maxdist) shell_list(start+i_rep)%shell%max_dist = maxdist - CALL section_vals_val_get(section,"SHELL_CUTOFF",i_rep_section=i_rep,r_val=cutoff,error=error) + CALL section_vals_val_get(section,"SHELL_CUTOFF",i_rep_section=i_rep,r_val=cutoff) shell_list(start+i_rep)%shell%shell_cutoff=cutoff END DO @@ -1641,10 +1591,9 @@ END SUBROUTINE read_shell_section !> \param bond_cs ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_bonds_section(bond_kind,bond_a, bond_b, bond_k, bond_r0, bond_cs, section, start, error) + SUBROUTINE read_bonds_section(bond_kind,bond_a, bond_b, bond_k, bond_r0, bond_cs, section, start) INTEGER, DIMENSION(:), POINTER :: bond_kind CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: bond_a, bond_b @@ -1652,7 +1601,6 @@ SUBROUTINE read_bonds_section(bond_kind,bond_a, bond_b, bond_k, bond_r0, bond_cs REAL(KIND=dp), DIMENSION(:), POINTER :: bond_r0, bond_cs TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_bonds_section', & routineP = moduleN//':'//routineN @@ -1665,22 +1613,22 @@ SUBROUTINE read_bonds_section(bond_kind,bond_a, bond_b, bond_k, bond_r0, bond_cs failure = .FALSE. NULLIFY(Kvals, atm_names) - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=bond_kind(start+isec),error=error) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=bond_kind(start+isec)) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) bond_a(start+isec) = atm_names(1) bond_b(start+isec) = atm_names(2) CALL uppercase(bond_a(start+isec)) CALL uppercase(bond_b(start+isec)) - CALL section_vals_val_get(section,"K",i_rep_section=isec,r_vals=Kvals,error=error) - CPPostcondition(SIZE(Kvals) <= 3, cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(section,"K",i_rep_section=isec,r_vals=Kvals) + CPPostcondition(SIZE(Kvals) <= 3, cp_failure_level, routineP,failure) bond_k(:,start+isec) = 0.0_dp DO k=1,SIZE(Kvals) bond_k(k,start+isec) = Kvals(k) END DO - CALL section_vals_val_get(section,"R0",i_rep_section=isec,r_val=bond_r0(start+isec),error=error) - CALL section_vals_val_get(section,"CS",i_rep_section=isec,r_val=bond_cs(start+isec),error=error) + CALL section_vals_val_get(section,"R0",i_rep_section=isec,r_val=bond_r0(start+isec)) + CALL section_vals_val_get(section,"CS",i_rep_section=isec,r_val=bond_cs(start+isec)) END DO END SUBROUTINE read_bonds_section @@ -1700,11 +1648,10 @@ END SUBROUTINE read_bonds_section !> \param bend_kss ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** SUBROUTINE read_bends_section(bend_kind,bend_a, bend_b, bend_c, bend_k, bend_theta0, bend_cb, & - bend_r012,bend_r032,bend_kbs12,bend_kbs32,bend_kss, section, start, error) + bend_r012,bend_r032,bend_kbs12,bend_kbs32,bend_kss, section, start) INTEGER, DIMENSION(:), POINTER :: bend_kind CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: bend_a, bend_b, bend_c @@ -1714,7 +1661,6 @@ SUBROUTINE read_bends_section(bend_kind,bend_a, bend_b, bend_c, bend_k, bend_the bend_kss TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_bends_section', & routineP = moduleN//':'//routineN @@ -1727,26 +1673,26 @@ SUBROUTINE read_bends_section(bend_kind,bend_a, bend_b, bend_c, bend_k, bend_the failure = .FALSE. NULLIFY(Kvals, atm_names) - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=bend_kind(start+isec),error=error) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=bend_kind(start+isec)) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) bend_a(start+isec) = atm_names(1) bend_b(start+isec) = atm_names(2) bend_c(start+isec) = atm_names(3) CALL uppercase(bend_a(start+isec)) CALL uppercase(bend_b(start+isec)) CALL uppercase(bend_c(start+isec)) - CALL section_vals_val_get(section,"K",i_rep_section=isec,r_vals=Kvals,error=error) - CPPostcondition(SIZE(Kvals) == 1, cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(section,"K",i_rep_section=isec,r_vals=Kvals) + CPPostcondition(SIZE(Kvals) == 1, cp_failure_level, routineP,failure) bend_k(start+isec) = Kvals(1) - CALL section_vals_val_get(section,"THETA0",i_rep_section=isec,r_val=bend_theta0(start+isec),error=error) - CALL section_vals_val_get(section,"CB",i_rep_section=isec,r_val=bend_cb(start+isec),error=error) - CALL section_vals_val_get(section,"R012",i_rep_section=isec,r_val=bend_r012(start+isec),error=error) - CALL section_vals_val_get(section,"R032",i_rep_section=isec,r_val=bend_r032(start+isec),error=error) - CALL section_vals_val_get(section,"KBS12",i_rep_section=isec,r_val=bend_kbs12(start+isec),error=error) - CALL section_vals_val_get(section,"KBS32",i_rep_section=isec,r_val=bend_kbs32(start+isec),error=error) - CALL section_vals_val_get(section,"KSS",i_rep_section=isec,r_val=bend_kss(start+isec),error=error) + CALL section_vals_val_get(section,"THETA0",i_rep_section=isec,r_val=bend_theta0(start+isec)) + CALL section_vals_val_get(section,"CB",i_rep_section=isec,r_val=bend_cb(start+isec)) + CALL section_vals_val_get(section,"R012",i_rep_section=isec,r_val=bend_r012(start+isec)) + CALL section_vals_val_get(section,"R032",i_rep_section=isec,r_val=bend_r032(start+isec)) + CALL section_vals_val_get(section,"KBS12",i_rep_section=isec,r_val=bend_kbs12(start+isec)) + CALL section_vals_val_get(section,"KBS32",i_rep_section=isec,r_val=bend_kbs32(start+isec)) + CALL section_vals_val_get(section,"KSS",i_rep_section=isec,r_val=bend_kss(start+isec)) END DO END SUBROUTINE read_bends_section @@ -1760,9 +1706,8 @@ END SUBROUTINE read_bends_section !> \param ub_r0 ... !> \param section ... !> \param start ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_ubs_section(ub_kind,ub_a, ub_b, ub_c, ub_k, ub_r0, section, start, error) + SUBROUTINE read_ubs_section(ub_kind,ub_a, ub_b, ub_c, ub_k, ub_r0, section, start) INTEGER, DIMENSION(:), POINTER :: ub_kind CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: ub_a, ub_b, ub_c @@ -1770,7 +1715,6 @@ SUBROUTINE read_ubs_section(ub_kind,ub_a, ub_b, ub_c, ub_k, ub_r0, section, star REAL(KIND=dp), DIMENSION(:), POINTER :: ub_r0 TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_ubs_section', & routineP = moduleN//':'//routineN @@ -1784,26 +1728,26 @@ SUBROUTINE read_ubs_section(ub_kind,ub_a, ub_b, ub_c, ub_k, ub_r0, section, star failure = .FALSE. NULLIFY(atm_names) - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - subsection => section_vals_get_subs_vals(section,"UB",i_rep_section=isec,error=error) - CALL section_vals_get(subsection,explicit=explicit,error=error) + subsection => section_vals_get_subs_vals(section,"UB",i_rep_section=isec) + CALL section_vals_get(subsection,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(subsection,"KIND",i_val=ub_kind(start+isec),error=error) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(subsection,"KIND",i_val=ub_kind(start+isec)) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) ub_a(start+isec) = atm_names(1) ub_b(start+isec) = atm_names(2) ub_c(start+isec) = atm_names(3) CALL uppercase(ub_a(start+isec)) CALL uppercase(ub_b(start+isec)) CALL uppercase(ub_c(start+isec)) - CALL section_vals_val_get(subsection,"K",r_vals=Kvals,error=error) - CPPostcondition(SIZE(Kvals) <= 3, cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(subsection,"K",r_vals=Kvals) + CPPostcondition(SIZE(Kvals) <= 3, cp_failure_level, routineP,failure) ub_k(:,start+isec) = 0.0_dp DO k=1,SIZE(Kvals) ub_k(k,start+isec) = Kvals(k) END DO - CALL section_vals_val_get(subsection,"R0",r_val=ub_r0(start+isec),error=error) + CALL section_vals_val_get(subsection,"R0",r_val=ub_r0(start+isec)) END IF END DO END SUBROUTINE read_ubs_section @@ -1820,11 +1764,10 @@ END SUBROUTINE read_ubs_section !> \param torsion_m ... !> \param section ... !> \param start ... -!> \param error ... !> \author teo ! ***************************************************************************** SUBROUTINE read_torsions_section(torsion_kind,torsion_a, torsion_b, torsion_c, torsion_d, torsion_k,& - torsion_phi0, torsion_m, section, start, error ) + torsion_phi0, torsion_m, section, start) INTEGER, DIMENSION(:), POINTER :: torsion_kind CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: torsion_a, torsion_b, & @@ -1833,7 +1776,6 @@ SUBROUTINE read_torsions_section(torsion_kind,torsion_a, torsion_b, torsion_c, t INTEGER, DIMENSION(:), POINTER :: torsion_m TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_torsions_section', & routineP = moduleN//':'//routineN @@ -1845,10 +1787,10 @@ SUBROUTINE read_torsions_section(torsion_kind,torsion_a, torsion_b, torsion_c, t failure = .FALSE. NULLIFY( atm_names) - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=torsion_kind(start+isec),error=error) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=torsion_kind(start+isec)) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) torsion_a(start+isec) = atm_names(1) torsion_b(start+isec) = atm_names(2) torsion_c(start+isec) = atm_names(3) @@ -1857,9 +1799,9 @@ SUBROUTINE read_torsions_section(torsion_kind,torsion_a, torsion_b, torsion_c, t CALL uppercase(torsion_b(start+isec)) CALL uppercase(torsion_c(start+isec)) CALL uppercase(torsion_d(start+isec)) - CALL section_vals_val_get(section,"K",i_rep_section=isec,r_val=torsion_k(start+isec),error=error) - CALL section_vals_val_get(section,"PHI0",i_rep_section=isec,r_val=torsion_phi0(start+isec),error=error) - CALL section_vals_val_get(section,"M",i_rep_section=isec,i_val=torsion_m(start+isec),error=error) + CALL section_vals_val_get(section,"K",i_rep_section=isec,r_val=torsion_k(start+isec)) + CALL section_vals_val_get(section,"PHI0",i_rep_section=isec,r_val=torsion_phi0(start+isec)) + CALL section_vals_val_get(section,"M",i_rep_section=isec,i_val=torsion_m(start+isec)) END DO END SUBROUTINE read_torsions_section @@ -1874,18 +1816,16 @@ END SUBROUTINE read_torsions_section !> \param impr_phi0 ... !> \param section ... !> \param start ... -!> \param error ... !> \author louis vanduyfhuys ! ***************************************************************************** SUBROUTINE read_improper_section(impr_kind,impr_a, impr_b, impr_c, impr_d, impr_k,& - impr_phi0, section, start, error ) + impr_phi0, section, start) INTEGER, DIMENSION(:), POINTER :: impr_kind CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: impr_a, impr_b, impr_c, impr_d REAL(KIND=dp), DIMENSION(:), POINTER :: impr_k, impr_phi0 TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_improper_section', & routineP = moduleN//':'//routineN @@ -1897,10 +1837,10 @@ SUBROUTINE read_improper_section(impr_kind,impr_a, impr_b, impr_c, impr_d, impr_ failure = .FALSE. NULLIFY( atm_names) - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=impr_kind(start+isec),error=error) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=impr_kind(start+isec)) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) impr_a(start+isec) = atm_names(1) impr_b(start+isec) = atm_names(2) impr_c(start+isec) = atm_names(3) @@ -1909,8 +1849,8 @@ SUBROUTINE read_improper_section(impr_kind,impr_a, impr_b, impr_c, impr_d, impr_ CALL uppercase(impr_b(start+isec)) CALL uppercase(impr_c(start+isec)) CALL uppercase(impr_d(start+isec)) - CALL section_vals_val_get(section,"K",i_rep_section=isec,r_val=impr_k(start+isec),error=error) - CALL section_vals_val_get(section,"PHI0",i_rep_section=isec,r_val=impr_phi0(start+isec),error=error) + CALL section_vals_val_get(section,"K",i_rep_section=isec,r_val=impr_k(start+isec)) + CALL section_vals_val_get(section,"PHI0",i_rep_section=isec,r_val=impr_phi0(start+isec)) END DO END SUBROUTINE read_improper_section @@ -1925,11 +1865,10 @@ END SUBROUTINE read_improper_section !> \param opbend_phi0 ... !> \param section ... !> \param start ... -!> \param error ... !> \author louis vanduyfhuys ! ***************************************************************************** SUBROUTINE read_opbend_section(opbend_kind,opbend_a, opbend_b, opbend_c, opbend_d, opbend_k,& - opbend_phi0, section, start, error ) + opbend_phi0, section, start) INTEGER, DIMENSION(:), POINTER :: opbend_kind CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: opbend_a, opbend_b, opbend_c, & @@ -1937,7 +1876,6 @@ SUBROUTINE read_opbend_section(opbend_kind,opbend_a, opbend_b, opbend_c, opbend_ REAL(KIND=dp), DIMENSION(:), POINTER :: opbend_k, opbend_phi0 TYPE(section_vals_type), POINTER :: section INTEGER, INTENT(IN) :: start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_opbend_section', & routineP = moduleN//':'//routineN @@ -1949,10 +1887,10 @@ SUBROUTINE read_opbend_section(opbend_kind,opbend_a, opbend_b, opbend_c, opbend_ failure = .FALSE. NULLIFY( atm_names) - CALL section_vals_get(section,n_repetition=n_items,error=error) + CALL section_vals_get(section,n_repetition=n_items) DO isec = 1, n_items - CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=opbend_kind(start+isec),error=error) - CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names,error=error) + CALL section_vals_val_get(section,"KIND",i_rep_section=isec,i_val=opbend_kind(start+isec)) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=isec,c_vals=atm_names) opbend_a(start+isec) = atm_names(1) opbend_b(start+isec) = atm_names(2) opbend_c(start+isec) = atm_names(3) @@ -1961,8 +1899,8 @@ SUBROUTINE read_opbend_section(opbend_kind,opbend_a, opbend_b, opbend_c, opbend_ CALL uppercase(opbend_b(start+isec)) CALL uppercase(opbend_c(start+isec)) CALL uppercase(opbend_d(start+isec)) - CALL section_vals_val_get(section,"K",i_rep_section=isec,r_val=opbend_k(start+isec),error=error) - CALL section_vals_val_get(section,"PHI0",i_rep_section=isec,r_val=opbend_phi0(start+isec),error=error) + CALL section_vals_val_get(section,"K",i_rep_section=isec,r_val=opbend_k(start+isec)) + CALL section_vals_val_get(section,"PHI0",i_rep_section=isec,r_val=opbend_phi0(start+isec)) END DO END SUBROUTINE read_opbend_section @@ -1971,23 +1909,21 @@ END SUBROUTINE read_opbend_section !> \param ff_type ... !> \param para_env ... !> \param mm_section ... -!> \param error ... !> \par History !> JGH (30.11.2001) : moved determination of setup variables to !> molecule_input !> \author CJM ! ***************************************************************************** - SUBROUTINE read_force_field_section ( ff_type , para_env, mm_section, error ) + SUBROUTINE read_force_field_section ( ff_type , para_env, mm_section) TYPE(force_field_type), INTENT(INOUT) :: ff_type TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(section_vals_type), POINTER :: ff_section NULLIFY(ff_section) - ff_section => section_vals_get_subs_vals(mm_section,"FORCEFIELD",error=error) - CALL read_force_field_section1(ff_section, mm_section, ff_type, para_env, error) + ff_section => section_vals_get_subs_vals(mm_section,"FORCEFIELD") + CALL read_force_field_section1(ff_section, mm_section, ff_type, para_env) END SUBROUTINE read_force_field_section ! ***************************************************************************** @@ -1995,13 +1931,11 @@ END SUBROUTINE read_force_field_section !> \param eam ... !> \param para_env ... !> \param mm_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_eam_data ( eam, para_env, mm_section, error) + SUBROUTINE read_eam_data ( eam, para_env, mm_section) TYPE(eam_pot_type), POINTER :: eam TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_eam_data', & routineP = moduleN//':'//routineN @@ -2014,19 +1948,19 @@ SUBROUTINE read_eam_data ( eam, para_env, mm_section, error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(parser, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") IF (iw>0) WRITE ( iw, * ) "Reading EAM data from: ",TRIM(eam%eam_file_name) - CALL parser_create(parser,TRIM(eam%eam_file_name),para_env=para_env,error=error) + CALL parser_create(parser,TRIM(eam%eam_file_name),para_env=para_env) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) IF (iw>0) WRITE(iw,*) "Title: ",parser%input_line - CALL parser_get_next_line(parser,2,error=error) + CALL parser_get_next_line(parser,2) READ(parser%input_line,*) eam%drar, eam%drhoar, eam%acutal, eam%npoints - eam%drar = cp_unit_to_cp2k(eam%drar,"angstrom",error=error) - eam%acutal = cp_unit_to_cp2k(eam%acutal,"angstrom",error=error) + eam%drar = cp_unit_to_cp2k(eam%drar,"angstrom") + eam%acutal = cp_unit_to_cp2k(eam%acutal,"angstrom") ! Relocating arrays with the right size CALL reallocate(eam%rho, 1, eam%npoints) CALL reallocate(eam%rhop, 1, eam%npoints) @@ -2038,30 +1972,30 @@ SUBROUTINE read_eam_data ( eam, para_env, mm_section, error) CALL reallocate(eam%frhop, 1, eam%npoints) ! Reading density and derivative of density (with respect to r) DO i = 1,eam%npoints - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) READ (parser%input_line,*) eam%rho(i), eam%rhop(i) - eam%rhop(i) = cp_unit_to_cp2k(eam%rhop(i),"angstrom^-1",error=error) + eam%rhop(i) = cp_unit_to_cp2k(eam%rhop(i),"angstrom^-1") eam%rval(i) = REAL(i-1,KIND=dp)*eam%drar eam%rhoval(i) = REAL(i-1,KIND=dp)*eam%drhoar END DO ! Reading pair potential PHI and its derivative (with respect to r) DO i = 1,eam%npoints - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) READ (parser%input_line,*) eam%phi(i), eam%phip(i) - eam%phi(i) = cp_unit_to_cp2k(eam%phi(i),"eV",error=error) - eam%phip(i) = cp_unit_to_cp2k(eam%phip(i),"eV*angstrom^-1",error=error) + eam%phi(i) = cp_unit_to_cp2k(eam%phi(i),"eV") + eam%phip(i) = cp_unit_to_cp2k(eam%phip(i),"eV*angstrom^-1") END DO ! Reading embedded function and its derivative (with respect to density) DO i = 1,eam%npoints - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) READ (parser%input_line,*) eam%frho(i), eam%frhop(i) - eam%frho(i) = cp_unit_to_cp2k(eam%frho(i),"eV",error=error) - eam%frhop(i) = cp_unit_to_cp2k(eam%frhop(i),"eV",error=error) + eam%frho(i) = cp_unit_to_cp2k(eam%frho(i),"eV") + eam%frhop(i) = cp_unit_to_cp2k(eam%frhop(i),"eV") END DO IF (iw>0) WRITE(iw,*)"Finished EAM data" - CALL parser_release(parser,error=error) - CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%FF_INFO",error=error) + CALL parser_release(parser) + CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%FF_INFO") CALL timestop(handle) END SUBROUTINE read_eam_data diff --git a/src/force_fields_util.F b/src/force_fields_util.F index 39ead06e21..fc6f654176 100644 --- a/src/force_fields_util.F +++ b/src/force_fields_util.F @@ -106,12 +106,11 @@ MODULE force_fields_util !> \param shell_particle_set ... !> \param core_particle_set ... !> \param cell ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & molecule_set, ewald_env,fist_nonbond_env,ff_type,root_section, qmmm, & qmmm_env, mm_section, subsys_section, shell_particle_set,core_particle_set,& - cell, error) + cell) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -133,7 +132,6 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & POINTER :: shell_particle_set, & core_particle_set TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_pack', & routineP = moduleN//':'//routineN @@ -160,18 +158,18 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & fatal = .FALSE. ignore_fatal = ff_type%ignore_missing_critical NULLIFY(logger, Ainfo, charges_section, charges) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Error unit output_unit= cp_logger_get_default_io_unit(logger) iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") iw2= cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO/SPLINE_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") iw3= cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO/SPLINE_DATA",& - extension=".mmLog",error=error) + extension=".mmLog") iw4= cp_print_key_unit_nr(logger,mm_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") NULLIFY(potparm_nonbond14, potparm_nonbond) my_qmmm = .FALSE. IF (PRESENT(qmmm).AND.PRESENT(qmmm_env)) my_qmmm = qmmm @@ -184,81 +182,80 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & ! 1. Determine the number of unique bond kind and allocate bond_kind_set !----------------------------------------------------------------------------- CALL force_field_unique_bond (particle_set, molecule_kind_set, molecule_set, & - ff_type, error) + ff_type) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 2. Determine the number of unique bend kind and allocate bend_kind_set !----------------------------------------------------------------------------- CALL force_field_unique_bend (particle_set, molecule_kind_set, molecule_set, & - ff_type, error) + ff_type) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 3. Determine the number of unique Urey-Bradley kind and allocate ub_kind_set !----------------------------------------------------------------------------- - CALL force_field_unique_ub (particle_set, molecule_kind_set, molecule_set, & - error) + CALL force_field_unique_ub (particle_set, molecule_kind_set, molecule_set) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 4. Determine the number of unique torsion kind and allocate torsion_kind_set !----------------------------------------------------------------------------- CALL force_field_unique_tors (particle_set, molecule_kind_set, molecule_set, & - ff_type, error) + ff_type) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 5. Determine the number of unique impr kind and allocate impr_kind_set !----------------------------------------------------------------------------- CALL force_field_unique_impr (particle_set, molecule_kind_set, molecule_set, & - ff_type, error) + ff_type) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 6. Determine the number of unique opbend kind and allocate opbend_kind_set !----------------------------------------------------------------------------- CALL force_field_unique_opbend (particle_set, molecule_kind_set, molecule_set, & - ff_type, error) + ff_type) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 7. Bonds !----------------------------------------------------------------------------- CALL force_field_pack_bond (particle_set, molecule_kind_set, molecule_set, & - fatal, Ainfo, chm_info, inp_info, gro_info, amb_info, error) + fatal, Ainfo, chm_info, inp_info, gro_info, amb_info) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 8. Bends !----------------------------------------------------------------------------- CALL force_field_pack_bend (particle_set, molecule_kind_set, molecule_set, & - fatal, Ainfo, chm_info, inp_info, gro_info, amb_info, error) + fatal, Ainfo, chm_info, inp_info, gro_info, amb_info) ! Give information and abort if any bond or angle parameter is missing.. - CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw,error) + CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 9. Urey-Bradley !----------------------------------------------------------------------------- CALL force_field_pack_ub (particle_set, molecule_kind_set, molecule_set, & - Ainfo, chm_info, inp_info, iw, error) + Ainfo, chm_info, inp_info, iw) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 10. Torsions !----------------------------------------------------------------------------- CALL force_field_pack_tors (particle_set, molecule_kind_set, molecule_set, & - Ainfo, chm_info, inp_info, gro_info, amb_info, iw, error) + Ainfo, chm_info, inp_info, gro_info, amb_info, iw) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 11. Impropers !----------------------------------------------------------------------------- CALL force_field_pack_impr (particle_set, molecule_kind_set, molecule_set, & - Ainfo, chm_info, inp_info, gro_info, error) + Ainfo, chm_info, inp_info, gro_info) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 12. Out of plane bends !----------------------------------------------------------------------------- CALL force_field_pack_opbend (particle_set, molecule_kind_set, molecule_set, & - Ainfo, inp_info, error) + Ainfo, inp_info) ! Give information only if any Urey-Bradley, Torsion, improper or opbend is missing ! continue calculation.. - CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw,error) + CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw) - charges_section => section_vals_get_subs_vals(mm_section,"FORCEFIELD%CHARGES",error=error) - CALL section_vals_get(charges_section, explicit=explicit, error=error) + charges_section => section_vals_get_subs_vals(mm_section,"FORCEFIELD%CHARGES") + CALL section_vals_get(charges_section, explicit=explicit) IF (.NOT.explicit) THEN !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -266,9 +263,9 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & ! potential parameters !----------------------------------------------------------------------------- CALL force_field_pack_charge(atomic_kind_set, qmmm_env, fatal, iw, iw4,& - Ainfo, my_qmmm, inp_info, error) + Ainfo, my_qmmm, inp_info) ! Give information only if charge is missing and abort.. - CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw,error) + CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw) ELSE !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -276,21 +273,21 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & ! allows the usage of different charges for same atomic types !----------------------------------------------------------------------------- CALL force_field_pack_charges(charges, charges_section, particle_set, my_qmmm,& - qmmm_env, inp_info, iw4, error) + qmmm_env, inp_info, iw4) END IF !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 14. Set up the radius of the electrostatic multipole in Fist !----------------------------------------------------------------------------- - CALL force_field_pack_radius(atomic_kind_set, iw, subsys_section, error) + CALL force_field_pack_radius(atomic_kind_set, iw, subsys_section) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 15. Set up the polarizable FF parameters !----------------------------------------------------------------------------- - CALL force_field_pack_pol(atomic_kind_set, iw, inp_info, error) - CALL force_field_pack_damp(atomic_kind_set, iw, inp_info, error) + CALL force_field_pack_pol(atomic_kind_set, iw, inp_info) + CALL force_field_pack_damp(atomic_kind_set, iw, inp_info) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -298,7 +295,7 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & !----------------------------------------------------------------------------- CALL force_field_pack_shell ( particle_set, atomic_kind_set,& molecule_kind_set, molecule_set, root_section, subsys_section,& - shell_particle_set, core_particle_set, cell, iw, inp_info, error) + shell_particle_set, core_particle_set, cell, iw, inp_info) IF (ff_type%do_nonbonded) THEN !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -306,14 +303,13 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & !----------------------------------------------------------------------------- ! Move the data from the info structures to potparm_nonbond CALL force_field_pack_nonbond14(atomic_kind_set, ff_type, qmmm_env, iw, Ainfo,& - chm_info, inp_info, gro_info, amb_info, potparm_nonbond14, ewald_env, & - error) + chm_info, inp_info, gro_info, amb_info, potparm_nonbond14, ewald_env) ! Give information if any 1-4 is missing.. continue calculation.. - CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw,error) + CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw) ! Create the spline data - CALL section_vals_val_get(mm_section,"FORCEFIELD%ZBL_SCATTERING",l_val=do_zbl,error=error) + CALL section_vals_val_get(mm_section,"FORCEFIELD%ZBL_SCATTERING",l_val=do_zbl) CALL force_field_pack_splines(atomic_kind_set, ff_type, iw2, iw3, iw4, & - potparm_nonbond14, do_zbl, nonbonded_type="NONBONDED14", error=error) + potparm_nonbond14, do_zbl, nonbonded_type="NONBONDED14") !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 18. Set up potparm_nonbond @@ -321,34 +317,34 @@ SUBROUTINE force_field_pack (particle_set,atomic_kind_set,molecule_kind_set, & ! Move the data from the info structures to potparm_nonbond CALL force_field_pack_nonbond(atomic_kind_set, ff_type, qmmm_env, & fatal, iw, Ainfo, chm_info, inp_info, gro_info, amb_info, & - potparm_nonbond, ewald_env, error) + potparm_nonbond, ewald_env) ! Give information and abort if any pair potential spline is missing.. - CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw,error) + CALL release_FF_missing_par(fatal,ignore_fatal,AInfo,output_unit,iw) ! Create the spline data - CALL section_vals_val_get(mm_section,"FORCEFIELD%ZBL_SCATTERING",l_val=do_zbl,error=error) + CALL section_vals_val_get(mm_section,"FORCEFIELD%ZBL_SCATTERING",l_val=do_zbl) CALL force_field_pack_splines(atomic_kind_set, ff_type, iw2, iw3, iw4, & - potparm_nonbond, do_zbl, nonbonded_type="NONBONDED", error=error) + potparm_nonbond, do_zbl, nonbonded_type="NONBONDED") END IF !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 19. Create nonbond environment !----------------------------------------------------------------------------- - CALL ewald_env_get(ewald_env, rcut=ewald_rcut, error=error) + CALL ewald_env_get(ewald_env, rcut=ewald_rcut) CALL section_vals_val_get(mm_section,"NEIGHBOR_LISTS%VERLET_SKIN",& - r_val=verlet_skin,error=error) + r_val=verlet_skin) CALL fist_nonbond_env_create (fist_nonbond_env, atomic_kind_set, & potparm_nonbond14, potparm_nonbond, ff_type%do_nonbonded, & verlet_skin, ewald_rcut, ff_type%ei_scale14, & - ff_type%vdw_scale14, ff_type%shift_cutoff, error) - CALL fist_nonbond_env_set(fist_nonbond_env, charges=charges, error=error) + ff_type%vdw_scale14, ff_type%shift_cutoff) + CALL fist_nonbond_env_set(fist_nonbond_env, charges=charges) ! Compute the electrostatic interaction cutoffs. CALL force_field_pack_eicut(atomic_kind_set, ff_type, potparm_nonbond, & - ewald_env, error) + ewald_env) - CALL cp_print_key_finished_output(iw4,logger,mm_section,"PRINT%PROGRAM_RUN_INFO",error=error) - CALL cp_print_key_finished_output(iw3,logger,mm_section,"PRINT%FF_INFO/SPLINE_DATA",error=error) - CALL cp_print_key_finished_output(iw2,logger,mm_section,"PRINT%FF_INFO/SPLINE_INFO",error=error) - CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%FF_INFO",error=error) + CALL cp_print_key_finished_output(iw4,logger,mm_section,"PRINT%PROGRAM_RUN_INFO") + CALL cp_print_key_finished_output(iw3,logger,mm_section,"PRINT%FF_INFO/SPLINE_DATA") + CALL cp_print_key_finished_output(iw2,logger,mm_section,"PRINT%FF_INFO/SPLINE_INFO") + CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%FF_INFO") CALL timestop(handle) END SUBROUTINE force_field_pack @@ -360,14 +356,12 @@ END SUBROUTINE force_field_pack !> \param array ... !> \param output_unit ... !> \param iw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_FF_missing_par(fatal, ignore_fatal, array, output_unit, iw, error) + SUBROUTINE release_FF_missing_par(fatal, ignore_fatal, array, output_unit, iw) LOGICAL, INTENT(INOUT) :: fatal, ignore_fatal CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: array INTEGER, INTENT(IN) :: output_unit, iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_FF_missing_par', & routineP = moduleN//':'//routineN @@ -396,7 +390,7 @@ SUBROUTINE release_FF_missing_par(fatal, ignore_fatal, array, output_unit, iw, e END IF END IF DEALLOCATE(array,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (fatal) THEN IF (ignore_fatal) THEN @@ -421,10 +415,9 @@ END SUBROUTINE release_FF_missing_par !> \param molecule_set ... !> \param mm_section ... !> \param charges ... -!> \param error ... ! ***************************************************************************** SUBROUTINE force_field_qeff_output (particle_set,molecule_kind_set,& - molecule_set,mm_section,charges,error) + molecule_set,mm_section,charges) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -434,7 +427,6 @@ SUBROUTINE force_field_qeff_output (particle_set,molecule_kind_set,& POINTER :: molecule_set TYPE(section_vals_type), POINTER :: mm_section REAL(KIND=dp), DIMENSION(:), POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_field_qeff_output', & routineP = moduleN//':'//routineN @@ -455,9 +447,9 @@ SUBROUTINE force_field_qeff_output (particle_set,molecule_kind_set,& CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") qeff = 0.0_dp qeff_mol = 0.0_dp @@ -517,7 +509,7 @@ SUBROUTINE force_field_qeff_output (particle_set,molecule_kind_set,& IF(iw>0) WRITE(iw,'(A,F20.10)') " Total system mass = ",mass_sum CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%FF_INFO",error=error) + "PRINT%FF_INFO") CALL timestop(handle) END SUBROUTINE force_field_qeff_output @@ -525,14 +517,12 @@ END SUBROUTINE force_field_qeff_output !> \brief Removes UNSET force field types !> \param molecule_kind_set ... !> \param mm_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) + SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section) TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'clean_intra_force_kind', & routineP = moduleN//':'//routineN @@ -579,9 +569,9 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,mm_section,"PRINT%FF_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 1. Lets Tag the unwanted bonds due to the use of distance constraint @@ -769,7 +759,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) IF (iw>0) WRITE(iw,'(2I6)')(bond_list(ibond)%a,bond_list(ibond)%b,ibond=1,SIZE(bond_list)) NULLIFY(bad1,bad2) ALLOCATE(bad1(SIZE(bond_kind_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad1(:)=0 DO ibond=1,SIZE(bond_kind_set) unsetme=.FALSE. @@ -787,7 +777,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO IF(SUM(bad1)/=0) THEN counter = SIZE(bond_kind_set)-SUM(bad1) - CALL allocate_bond_kind_set(new_bond_kind_set,counter,error) + CALL allocate_bond_kind_set(new_bond_kind_set,counter) counter=0 DO ibond=1,SIZE(bond_kind_set) IF(bad1(ibond)==0) THEN @@ -797,7 +787,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO counter=0 ALLOCATE(bad2(SIZE(bond_list)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad2(:)=0 DO ibond=1,SIZE(bond_list) unsetme = .FALSE. @@ -808,7 +798,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) IF(SUM(bad2)/=0) THEN counter = SIZE(bond_list)-SUM(bad2) ALLOCATE(new_bond_list(counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO ibond=1,SIZE(bond_list) IF(bad2(ibond)==0) THEN @@ -828,17 +818,17 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO END IF DEALLOCATE(bad2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL deallocate_bond_kind_set(bond_kind_set,error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL deallocate_bond_kind_set(bond_kind_set) DEALLOCATE(bond_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(iw>0) WRITE(iw,*) " Mol(",ikind,") New BOND Count: ",& SIZE(new_bond_list),SIZE(new_bond_kind_set) IF (iw>0) WRITE(iw,'(2I6)')(new_bond_list(ibond)%a,new_bond_list(ibond)%b,& ibond=1,SIZE(new_bond_list)) END IF DEALLOCATE(bad1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO !----------------------------------------------------------------------------- @@ -858,7 +848,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) bend_list(ibend)%c,ibend=1,SIZE(bend_list)) NULLIFY(bad1,bad2) ALLOCATE(bad1(SIZE(bend_kind_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad1(:)=0 DO ibend=1,SIZE(bend_kind_set) unsetme=.FALSE. @@ -876,7 +866,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO IF(SUM(bad1)/=0) THEN counter = SIZE(bend_kind_set)-SUM(bad1) - CALL allocate_bend_kind_set(new_bend_kind_set,counter,error) + CALL allocate_bend_kind_set(new_bend_kind_set,counter) counter=0 DO ibend=1,SIZE(bend_kind_set) IF(bad1(ibend)==0) THEN @@ -886,7 +876,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO counter=0 ALLOCATE(bad2(SIZE(bend_list)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad2(:)=0 DO ibend=1,SIZE(bend_list) unsetme = .FALSE. @@ -897,7 +887,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) IF(SUM(bad2)/=0) THEN counter = SIZE(bend_list)-SUM(bad2) ALLOCATE(new_bend_list(counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO ibend=1,SIZE(bend_list) IF(bad2(ibend)==0) THEN @@ -917,17 +907,17 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO END IF DEALLOCATE(bad2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL deallocate_bend_kind_set(bend_kind_set,error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL deallocate_bend_kind_set(bend_kind_set) DEALLOCATE(bend_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(iw>0) WRITE(iw,*) " Mol(",ikind,") New BEND Count: ",& SIZE(new_bend_list),SIZE(new_bend_kind_set) IF (iw>0) WRITE(iw,'(3I6)')(new_bend_list(ibend)%a,new_bend_list(ibend)%b,& new_bend_list(ibend)%c,ibend=1,SIZE(new_bend_list)) END IF DEALLOCATE(bad1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO @@ -948,7 +938,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) ub_list(iub)%c,iub=1,SIZE(ub_list)) NULLIFY(bad1,bad2) ALLOCATE(bad1(SIZE(ub_kind_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad1(:)=0 DO iub=1,SIZE(ub_kind_set) unsetme=.FALSE. @@ -966,7 +956,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO IF(SUM(bad1)/=0) THEN counter = SIZE(ub_kind_set)-SUM(bad1) - CALL allocate_ub_kind_set(new_ub_kind_set,counter,error) + CALL allocate_ub_kind_set(new_ub_kind_set,counter) counter=0 DO iub=1,SIZE(ub_kind_set) IF(bad1(iub)==0) THEN @@ -976,7 +966,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO counter=0 ALLOCATE(bad2(SIZE(ub_list)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad2(:)=0 DO iub=1,SIZE(ub_list) unsetme = .FALSE. @@ -987,7 +977,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) IF(SUM(bad2)/=0) THEN counter = SIZE(ub_list)-SUM(bad2) ALLOCATE(new_ub_list(counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO iub=1,SIZE(ub_list) IF(bad2(iub)==0) THEN @@ -1007,17 +997,17 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO END IF DEALLOCATE(bad2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL ub_kind_dealloc_ref(ub_kind_set,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL ub_kind_dealloc_ref(ub_kind_set) DEALLOCATE(ub_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(iw>0) WRITE(iw,*) " Mol(",ikind,") New UB Count: ",& SIZE(new_ub_list),SIZE(new_ub_kind_set) IF (iw>0) WRITE(iw,'(3I6)')(new_ub_list(iub)%a,new_ub_list(iub)%b,& new_ub_list(iub)%c,iub=1,SIZE(new_ub_list)) END IF DEALLOCATE(bad1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO @@ -1038,7 +1028,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) torsion_list(itorsion)%c,torsion_list(itorsion)%d,itorsion=1,SIZE(torsion_list)) NULLIFY(bad1,bad2) ALLOCATE(bad1(SIZE(torsion_kind_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad1(:)=0 DO itorsion=1,SIZE(torsion_kind_set) unsetme=.FALSE. @@ -1056,7 +1046,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO IF(SUM(bad1)/=0) THEN counter = SIZE(torsion_kind_set)-SUM(bad1) - CALL allocate_torsion_kind_set(new_torsion_kind_set,counter,error) + CALL allocate_torsion_kind_set(new_torsion_kind_set,counter) counter=0 DO itorsion=1,SIZE(torsion_kind_set) IF(bad1(itorsion)==0) THEN @@ -1066,11 +1056,11 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) j = SIZE(torsion_kind_set(itorsion)%k) k = SIZE(torsion_kind_set(itorsion)%phi0) ALLOCATE(new_torsion_kind_set(counter)%m(i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(new_torsion_kind_set(counter)%k(i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(new_torsion_kind_set(counter)%phi0(i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) new_torsion_kind_set(counter)%m= torsion_kind_set(itorsion)%m new_torsion_kind_set(counter)%k= torsion_kind_set(itorsion)%k new_torsion_kind_set(counter)%phi0= torsion_kind_set(itorsion)%phi0 @@ -1078,7 +1068,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO counter=0 ALLOCATE(bad2(SIZE(torsion_list)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad2(:)=0 DO itorsion=1,SIZE(torsion_list) unsetme = .FALSE. @@ -1089,7 +1079,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) IF(SUM(bad2)/=0) THEN counter = SIZE(torsion_list)-SUM(bad2) ALLOCATE(new_torsion_list(counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO itorsion=1,SIZE(torsion_list) IF(bad2(itorsion)==0) THEN @@ -1109,14 +1099,14 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO END IF DEALLOCATE(bad2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO itorsion=1,SIZE(torsion_kind_set) - CALL torsion_kind_dealloc_ref(torsion_kind_set(itorsion),error=error) + CALL torsion_kind_dealloc_ref(torsion_kind_set(itorsion)) END DO DEALLOCATE(torsion_kind_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(torsion_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(iw>0) WRITE(iw,*) " Mol(",ikind,") New TORSION Count: ",& SIZE(new_torsion_list),SIZE(new_torsion_kind_set) IF (iw>0) WRITE(iw,'(4I6)')(new_torsion_list(itorsion)%a,new_torsion_list(itorsion)%b,& @@ -1124,7 +1114,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) SIZE(new_torsion_list)) END IF DEALLOCATE(bad1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO @@ -1143,7 +1133,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) SIZE(impr_list),SIZE(impr_kind_set) NULLIFY(bad1,bad2) ALLOCATE(bad1(SIZE(impr_kind_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad1(:)=0 DO iimpr=1,SIZE(impr_kind_set) unsetme=.FALSE. @@ -1161,7 +1151,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO IF(SUM(bad1)/=0) THEN counter = SIZE(impr_kind_set)-SUM(bad1) - CALL allocate_impr_kind_set(new_impr_kind_set,counter,error) + CALL allocate_impr_kind_set(new_impr_kind_set,counter) counter=0 DO iimpr=1,SIZE(impr_kind_set) IF(bad1(iimpr)==0) THEN @@ -1171,7 +1161,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO counter=0 ALLOCATE(bad2(SIZE(impr_list)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad2(:)=0 DO iimpr=1,SIZE(impr_list) unsetme = .FALSE. @@ -1182,7 +1172,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) IF(SUM(bad2)/=0) THEN counter = SIZE(impr_list)-SUM(bad2) ALLOCATE(new_impr_list(counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO iimpr=1,SIZE(impr_list) IF(bad2(iimpr)==0) THEN @@ -1202,19 +1192,19 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO END IF DEALLOCATE(bad2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iimpr=1,SIZE(impr_kind_set) - CALL impr_kind_dealloc_ref(error=error) !This Subroutine doesn't deallocate anything, maybe needs to be implemented + CALL impr_kind_dealloc_ref() !This Subroutine doesn't deallocate anything, maybe needs to be implemented END DO DEALLOCATE(impr_kind_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(impr_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(iw>0) WRITE(iw,*) " Mol(",ikind,") New IMPROPER Count: ",& SIZE(new_impr_list),SIZE(new_impr_kind_set) END IF DEALLOCATE(bad1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO @@ -1233,7 +1223,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) SIZE(opbend_list),SIZE(opbend_kind_set) NULLIFY(bad1,bad2) ALLOCATE(bad1(SIZE(opbend_kind_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad1(:)=0 DO iopbend=1,SIZE(opbend_kind_set) unsetme=.FALSE. @@ -1251,7 +1241,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO IF(SUM(bad1)/=0) THEN counter = SIZE(opbend_kind_set)-SUM(bad1) - CALL allocate_opbend_kind_set(new_opbend_kind_set,counter,error) + CALL allocate_opbend_kind_set(new_opbend_kind_set,counter) counter=0 DO iopbend=1,SIZE(opbend_kind_set) IF(bad1(iopbend)==0) THEN @@ -1261,7 +1251,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO counter=0 ALLOCATE(bad2(SIZE(opbend_list)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bad2(:)=0 DO iopbend=1,SIZE(opbend_list) unsetme = .FALSE. @@ -1272,7 +1262,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) IF(SUM(bad2)/=0) THEN counter = SIZE(opbend_list)-SUM(bad2) ALLOCATE(new_opbend_list(counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO iopbend=1,SIZE(opbend_list) IF(bad2(iopbend)==0) THEN @@ -1292,16 +1282,16 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) END DO END IF DEALLOCATE(bad2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(opbend_kind_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(opbend_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(iw>0) WRITE(iw,*) " Mol(",ikind,") New OPBEND Count: ",& SIZE(new_opbend_list),SIZE(new_opbend_kind_set) END IF DEALLOCATE(bad1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO @@ -1311,7 +1301,7 @@ SUBROUTINE clean_intra_force_kind (molecule_kind_set,mm_section,error) !- NEED TO REMOVE EXTRAS HERE - IKUO !--------------------------------------------------------------------------- CALL cp_print_key_finished_output(iw,logger,mm_section,& - "PRINT%FF_INFO",error=error) + "PRINT%FF_INFO") CALL timestop(handle) END SUBROUTINE clean_intra_force_kind @@ -1326,10 +1316,9 @@ END SUBROUTINE clean_intra_force_kind !> \param size_variables ... !> \param i_rep_sec ... !> \param input_variables ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_generic_info(gen_section, func_name, xfunction, parameters, values,& - var_values, size_variables, i_rep_sec, input_variables, error) + var_values, size_variables, i_rep_sec, input_variables) TYPE(section_vals_type), POINTER :: gen_section CHARACTER(LEN=*), INTENT(IN) :: func_name CHARACTER(LEN=default_path_length), & @@ -1341,7 +1330,6 @@ SUBROUTINE get_generic_info(gen_section, func_name, xfunction, parameters, value POINTER :: var_values INTEGER, INTENT(IN), OPTIONAL :: size_variables, i_rep_sec CHARACTER(LEN=*), DIMENSION(:), OPTIONAL :: input_variables - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_generic_info', & routineP = moduleN//':'//routineN @@ -1361,45 +1349,45 @@ SUBROUTINE get_generic_info(gen_section, func_name, xfunction, parameters, value NULLIFY (my_units_tmp) IF (ASSOCIATED(parameters)) THEN DEALLOCATE(parameters,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(values)) THEN DEALLOCATE(values,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF irep = 1 IF (PRESENT(i_rep_sec)) irep = i_rep_sec mydim = 0 - CALL section_vals_val_get(gen_section,TRIM(func_name),i_rep_section=irep,c_val=xfunction,error=error) + CALL section_vals_val_get(gen_section,TRIM(func_name),i_rep_section=irep,c_val=xfunction) CALL compress(xfunction, full=.TRUE.) IF (PRESENT(input_variables)) THEN ALLOCATE(my_var(SIZE(input_variables)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_var = input_variables ELSE - CALL section_vals_val_get(gen_section,"VARIABLES",i_rep_section=irep,c_vals=my_var,error=error) + CALL section_vals_val_get(gen_section,"VARIABLES",i_rep_section=irep,c_vals=my_var) END IF IF (ASSOCIATED(my_var)) THEN mydim = SIZE(my_var) END IF IF (PRESENT(size_variables)) THEN - CPPrecondition(mydim==size_variables,cp_failure_level,routineP,error,failure) + CPPrecondition(mydim==size_variables,cp_failure_level,routineP,failure) END IF ! Check for presence of Parameters - CALL section_vals_val_get(gen_section,"PARAMETERS",i_rep_section=irep,n_rep_val=n_par,error=error) - CALL section_vals_val_get(gen_section,"VALUES",i_rep_section=irep,n_rep_val=n_val,error=error) + CALL section_vals_val_get(gen_section,"PARAMETERS",i_rep_section=irep,n_rep_val=n_par) + CALL section_vals_val_get(gen_section,"VALUES",i_rep_section=irep,n_rep_val=n_val) check = (n_par>0).EQV.(n_val>0) - CPPrecondition(check,cp_failure_level,routineP,error,failure) - CALL section_vals_val_get(gen_section,"UNITS",i_rep_section=irep,n_rep_val=n_units,error=error) + CPPrecondition(check,cp_failure_level,routineP,failure) + CALL section_vals_val_get(gen_section,"UNITS",i_rep_section=irep,n_rep_val=n_units) IF (n_par>0) THEN ! Parameters ALLOCATE(my_par(0),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(my_val(0),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, n_par isize = SIZE(my_par) - CALL section_vals_val_get(gen_section,"PARAMETERS",i_rep_section=irep,i_rep_val=i,c_vals=my_par_tmp,error=error) + CALL section_vals_val_get(gen_section,"PARAMETERS",i_rep_section=irep,i_rep_val=i,c_vals=my_par_tmp) nblank = COUNT(my_par_tmp=="") CALL reallocate(my_par, 1, isize+SIZE(my_par_tmp)-nblank) ind = 0 @@ -1411,18 +1399,18 @@ SUBROUTINE get_generic_info(gen_section, func_name, xfunction, parameters, value END DO DO i = 1, n_val isize = SIZE(my_val) - CALL section_vals_val_get(gen_section,"VALUES",i_rep_section=irep,i_rep_val=i,r_vals=my_val_tmp,error=error) + CALL section_vals_val_get(gen_section,"VALUES",i_rep_section=irep,i_rep_val=i,r_vals=my_val_tmp) CALL reallocate(my_val,1, isize+SIZE(my_val_tmp)) my_val(isize+1:isize+SIZE(my_val_tmp))=my_val_tmp END DO - CPPrecondition(SIZE(my_par)==SIZE(my_val),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(my_par)==SIZE(my_val),cp_failure_level,routineP,failure) ! Optionally read the units for each parameter value ALLOCATE (my_units(0),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (n_units > 0) THEN DO i=1,n_units isize = SIZE(my_units) - CALL section_vals_val_get(gen_section,"UNITS",i_rep_section=irep,i_rep_val=i,c_vals=my_units_tmp,error=error) + CALL section_vals_val_get(gen_section,"UNITS",i_rep_section=irep,i_rep_val=i,c_vals=my_units_tmp) nblank = COUNT(my_units_tmp == "") CALL reallocate(my_units,1,isize+SIZE(my_units_tmp)-nblank) ind = 0 @@ -1432,35 +1420,35 @@ SUBROUTINE get_generic_info(gen_section, func_name, xfunction, parameters, value my_units(isize+ind) = my_units_tmp(j) END DO END DO - CPPrecondition(SIZE(my_units)==SIZE(my_val),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(my_units)==SIZE(my_val),cp_failure_level,routineP,failure) END IF mydim=mydim+SIZE(my_val) IF (SIZE(my_val)==0) THEN DEALLOCATE(my_par,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_val,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_units,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END IF ! Handle trivial case of a null function defined ALLOCATE(parameters(mydim),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(values(mydim),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (mydim>0) THEN parameters(1:SIZE(my_var)) = my_var values(1:SIZE(my_var)) = 0.0_dp IF (PRESENT(var_values)) THEN - CPPrecondition(SIZE(var_values)==SIZE(my_var),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(var_values)==SIZE(my_var),cp_failure_level,routineP,failure) values(1:SIZE(my_var)) = var_values END IF IF (ASSOCIATED(my_val)) THEN DO i=1,SIZE(my_val) parameters(SIZE(my_var)+i) = my_par(i) IF (n_units > 0) THEN - values(SIZE(my_var)+i) = cp_unit_to_cp2k(my_val(i),TRIM(ADJUSTL(my_units(i))),error=error) + values(SIZE(my_var)+i) = cp_unit_to_cp2k(my_val(i),TRIM(ADJUSTL(my_units(i)))) ELSE values(SIZE(my_var)+i) = my_val(i) END IF @@ -1469,19 +1457,19 @@ SUBROUTINE get_generic_info(gen_section, func_name, xfunction, parameters, value END IF IF (ASSOCIATED(my_par)) THEN DEALLOCATE(my_par,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(my_val)) THEN DEALLOCATE(my_val,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(my_units)) THEN DEALLOCATE(my_units,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (PRESENT(input_variables)) THEN DEALLOCATE(my_var,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE get_generic_info diff --git a/src/fp_methods.F b/src/fp_methods.F index b10b25a365..37c74833ef 100644 --- a/src/fp_methods.F +++ b/src/fp_methods.F @@ -47,15 +47,13 @@ MODULE fp_methods !> \param fp_env ... !> \param subsys ... !> \param cell ... -!> \param error ... !> \par History !> 04.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE fp_eval(fp_env, subsys, cell, error) + SUBROUTINE fp_eval(fp_env, subsys, cell) TYPE(fp_type), POINTER :: fp_env TYPE(cp_subsys_type), POINTER :: subsys TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fp_eval', & routineP = moduleN//':'//routineN @@ -75,10 +73,10 @@ SUBROUTINE fp_eval(fp_env, subsys, cell, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,error,failure) - CPPrecondition(fp_env%use_fp,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) - CALL cp_subsys_get(subsys,particles=particles_list,error=error) + CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,failure) + CPPrecondition(fp_env%use_fp,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,failure) + CALL cp_subsys_get(subsys,particles=particles_list) particles=>particles_list%els ! compute the force due to the reflecting walls @@ -147,7 +145,7 @@ SUBROUTINE fp_eval(fp_env, subsys, cell, error) ! the combinatorial weight i=fp_env%i2+fp_env%o1 - CPPrecondition(i<=maxfac,cp_failure_level,routineP,error,failure) + CPPrecondition(i<=maxfac,cp_failure_level,routineP,failure) fp_env%comb_weight=(fac(fp_env%i2)*fac(fp_env%o1))/fac(i) ! we can add the bias potential now. @@ -195,11 +193,11 @@ SUBROUTINE fp_eval(fp_env, subsys, cell, error) ENDIF ! put weights and other info on file - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,fp_env%print_section,"", & - extension=".weights",error=error) + extension=".weights") IF (output_unit>0) THEN - tmpstr=cp_iter_string(logger%iter_info, fp_env%print_section,error=error) + tmpstr=cp_iter_string(logger%iter_info, fp_env%print_section) WRITE(output_unit,'(T2,A15,6(1X,F16.10),4(1X,I4),4(1X,F16.10))') & tmpstr, & fp_env%weight, fp_env%comb_weight, fp_env%bias_weight, & @@ -209,7 +207,7 @@ SUBROUTINE fp_eval(fp_env, subsys, cell, error) ENDIF CALL cp_print_key_finished_output(output_unit,logger,fp_env%print_section,& - "",error=error) + "") CALL timestop(handle) diff --git a/src/fp_types.F b/src/fp_types.F index ca366f99e0..67ad25d140 100644 --- a/src/fp_types.F +++ b/src/fp_types.F @@ -58,13 +58,11 @@ MODULE fp_types ! ***************************************************************************** !> \brief create retain release the flexible partitioning environment !> \param fp_env ... -!> \param error ... !> \par History !> 04.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE fp_env_create(fp_env,error) + SUBROUTINE fp_env_create(fp_env) TYPE(fp_type), POINTER :: fp_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fp_env_create', & routineP = moduleN//':'//routineN @@ -75,9 +73,9 @@ SUBROUTINE fp_env_create(fp_env,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(fp_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(fp_env),cp_failure_level,routineP,failure) ALLOCATE(fp_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fp_env%ref_count=1 fp_env%use_fp=.FALSE. @@ -91,11 +89,9 @@ END SUBROUTINE fp_env_create ! ***************************************************************************** !> \brief ... !> \param fp_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE fp_env_release(fp_env,error) + SUBROUTINE fp_env_release(fp_env) TYPE(fp_type), POINTER :: fp_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fp_env_release', & routineP = moduleN//':'//routineN @@ -107,12 +103,12 @@ SUBROUTINE fp_env_release(fp_env,error) failure=.FALSE. IF (ASSOCIATED(fp_env)) THEN - CPPrecondition(fp_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(fp_env%ref_count>0,cp_failure_level,routineP,failure) fp_env%ref_count=fp_env%ref_count-1 IF (fp_env%ref_count==0) THEN IF (ASSOCIATED(fp_env%inner_atoms)) DEALLOCATE(fp_env%inner_atoms) IF (ASSOCIATED(fp_env%outer_atoms)) DEALLOCATE(fp_env%outer_atoms) - IF (ASSOCIATED(fp_env%print_section)) CALL section_vals_release(fp_env%print_section,error) + IF (ASSOCIATED(fp_env%print_section)) CALL section_vals_release(fp_env%print_section) fp_env%use_fp=.FALSE. DEALLOCATE(fp_env) ENDIF @@ -124,11 +120,9 @@ END SUBROUTINE fp_env_release ! ***************************************************************************** !> \brief ... !> \param fp_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE fp_env_retain(fp_env,error) + SUBROUTINE fp_env_retain(fp_env) TYPE(fp_type), POINTER :: fp_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fp_env_retain', & routineP = moduleN//':'//routineN @@ -136,7 +130,7 @@ SUBROUTINE fp_env_retain(fp_env,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,failure) fp_env%ref_count=fp_env%ref_count+1 END SUBROUTINE fp_env_retain @@ -145,14 +139,12 @@ END SUBROUTINE fp_env_retain !> \brief reads the corresponding input section and stores it in the fp_env !> \param fp_env ... !> \param fp_section ... -!> \param error ... !> \par History !> 04.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE fp_env_read(fp_env,fp_section,error) + SUBROUTINE fp_env_read(fp_env,fp_section) TYPE(fp_type), POINTER :: fp_env TYPE(section_vals_type), POINTER :: fp_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fp_env_read', & routineP = moduleN//':'//routineN @@ -163,28 +155,28 @@ SUBROUTINE fp_env_read(fp_env,fp_section,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,error,failure) - CALL section_vals_get(fp_section,explicit=fp_env%use_fp,error=error) + CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,failure) + CALL section_vals_get(fp_section,explicit=fp_env%use_fp) IF (fp_env%use_fp) THEN - CALL section_vals_val_get(fp_section,"CENTRAL_ATOM",i_val=fp_env%central_atom,error=error) + CALL section_vals_val_get(fp_section,"CENTRAL_ATOM",i_val=fp_env%central_atom) - CALL section_vals_val_get(fp_section,"INNER_ATOMS",i_vals=tmplist,error=error) + CALL section_vals_val_get(fp_section,"INNER_ATOMS",i_vals=tmplist) ALLOCATE(fp_env%inner_atoms(SIZE(tmplist,1))) fp_env%inner_atoms=tmplist - CALL section_vals_val_get(fp_section,"OUTER_ATOMS",i_vals=tmplist,error=error) + CALL section_vals_val_get(fp_section,"OUTER_ATOMS",i_vals=tmplist) ALLOCATE(fp_env%outer_atoms(SIZE(tmplist,1))) fp_env%outer_atoms=tmplist - CALL section_vals_val_get(fp_section,"INNER_RADIUS",r_val=fp_env%inner_radius,error=error) - CALL section_vals_val_get(fp_section,"OUTER_RADIUS",r_val=fp_env%outer_radius,error=error) - CALL section_vals_val_get(fp_section,"STRENGTH",r_val=fp_env%strength,error=error) - CALL section_vals_val_get(fp_section,"SMOOTH_WIDTH",r_val=fp_env%smooth_width,error=error) - CALL section_vals_val_get(fp_section,"BIAS",l_val=fp_env%bias,error=error) - CALL section_vals_val_get(fp_section,"TEMPERATURE",r_val=fp_env%temperature,error=error) + CALL section_vals_val_get(fp_section,"INNER_RADIUS",r_val=fp_env%inner_radius) + CALL section_vals_val_get(fp_section,"OUTER_RADIUS",r_val=fp_env%outer_radius) + CALL section_vals_val_get(fp_section,"STRENGTH",r_val=fp_env%strength) + CALL section_vals_val_get(fp_section,"SMOOTH_WIDTH",r_val=fp_env%smooth_width) + CALL section_vals_val_get(fp_section,"BIAS",l_val=fp_env%bias) + CALL section_vals_val_get(fp_section,"TEMPERATURE",r_val=fp_env%temperature) - fp_env%print_section=>section_vals_get_subs_vals(fp_section,"WEIGHTS",error=error) - CALL section_vals_retain(fp_env%print_section,error=error) + fp_env%print_section=>section_vals_get_subs_vals(fp_section,"WEIGHTS") + CALL section_vals_retain(fp_env%print_section) ENDIF CALL timestop(handle) @@ -194,14 +186,12 @@ END SUBROUTINE fp_env_read !> \brief writes information concerning the fp_env to the output !> \param fp_env ... !> \param fp_section ... -!> \param error ... !> \par History !> 04.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE fp_env_write(fp_env,fp_section,error) + SUBROUTINE fp_env_write(fp_env,fp_section) TYPE(fp_type), POINTER :: fp_env TYPE(section_vals_type), POINTER :: fp_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fp_env_write', & routineP = moduleN//':'//routineN @@ -213,12 +203,12 @@ SUBROUTINE fp_env_write(fp_env,fp_section,error) CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(fp_env),cp_failure_level,routineP,failure) IF (fp_env%use_fp) THEN - PRINT=>section_vals_get_subs_vals(fp_section,"CONTROL",error=error) - output_unit=cp_print_key_unit_nr(logger,PRINT,"",extension=".Log",error=error) + PRINT=>section_vals_get_subs_vals(fp_section,"CONTROL") + output_unit=cp_print_key_unit_nr(logger,PRINT,"",extension=".Log") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(T2,A,T79,A)")& "FP| Flexible partitioning is ","ON" @@ -248,7 +238,7 @@ SUBROUTINE fp_env_write(fp_env,fp_section,error) "FP| Flexible partitioning bias is" ,"OFF" ENDIF ENDIF - CALL cp_print_key_finished_output(output_unit,logger,PRINT,"",error=error) + CALL cp_print_key_finished_output(output_unit,logger,PRINT,"") ENDIF CALL timestop(handle) diff --git a/src/free_energy_types.F b/src/free_energy_types.F index ac7bfa2a96..a89c771c62 100644 --- a/src/free_energy_types.F +++ b/src/free_energy_types.F @@ -81,14 +81,11 @@ MODULE free_energy_types !> \brief creates the fe_env !> \param fe_env ... !> \param fe_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 01.2007 ! ***************************************************************************** - SUBROUTINE fe_env_create(fe_env,fe_section,error) + SUBROUTINE fe_env_create(fe_env,fe_section) TYPE(free_energy_type), POINTER :: fe_env TYPE(section_vals_type), POINTER :: fe_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fe_env_create', & routineP = moduleN//':'//routineN @@ -98,60 +95,60 @@ SUBROUTINE fe_env_create(fe_env,fe_section,error) TYPE(section_vals_type), POINTER :: ui_section, ui_var_section failure=.FALSE. - CPPreconditionNoFail(.NOT.ASSOCIATED(fe_env),cp_failure_level,routineP,error) + CPPreconditionNoFail(.NOT.ASSOCIATED(fe_env),cp_failure_level,routineP) - CALL section_vals_get(fe_section,explicit=explicit, error=error) + CALL section_vals_get(fe_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(fe_section,"METHOD",i_val=id_method,error=error) + CALL section_vals_val_get(fe_section,"METHOD",i_val=id_method) SELECT CASE(id_method) CASE (do_fe_ui) ALLOCATE(fe_env, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) NULLIFY(fe_env%covmx, fe_env%uivar, fe_env%conv_par, fe_env%cg_data) fe_env%type = id_method fe_env%nr_points = 0 fe_env%nr_rejected = 0 NULLIFY(fe_env%cg_data) - ui_section => section_vals_get_subs_vals(fe_section,"UMBRELLA_INTEGRATION",error=error) - ui_var_section => section_vals_get_subs_vals(ui_section,"UVAR",error=error) - CALL section_vals_get(ui_var_section,n_repetition=fe_env%ncolvar,error=error) + ui_section => section_vals_get_subs_vals(fe_section,"UMBRELLA_INTEGRATION") + ui_var_section => section_vals_get_subs_vals(ui_section,"UVAR") + CALL section_vals_get(ui_var_section,n_repetition=fe_env%ncolvar) ! Convergence controlling parameters ALLOCATE(fe_env%conv_par, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) fe_env%conv_par%test_k = .FALSE. fe_env%conv_par%test_sw = .FALSE. fe_env%conv_par%test_vn = .FALSE. CALL section_vals_val_get(ui_section,"CONVERGENCE_CONTROL%COARSE_GRAINED_WIDTH",& - i_val=fe_env%conv_par%cg_width,error=error) + i_val=fe_env%conv_par%cg_width) CALL section_vals_val_get(ui_section,"CONVERGENCE_CONTROL%MAX_COARSE_GRAINED_WIDTH",& - i_val=fe_env%conv_par%max_cg_width,error=error) + i_val=fe_env%conv_par%max_cg_width) CALL section_vals_val_get(ui_section,"CONVERGENCE_CONTROL%COARSE_GRAINED_POINTS",& - i_val=fe_env%conv_par%cg_points,error=error) + i_val=fe_env%conv_par%cg_points) CALL section_vals_val_get(ui_section,"CONVERGENCE_CONTROL%EPS_CONV",& - r_val=fe_env%conv_par%eps_conv,error=error) + r_val=fe_env%conv_par%eps_conv) CALL section_vals_val_get(ui_section,"CONVERGENCE_CONTROL%K_CONFIDENCE_LIMIT",& - r_val=fe_env%conv_par%k_conf_lm,error=error) + r_val=fe_env%conv_par%k_conf_lm) CALL section_vals_val_get(ui_section,"CONVERGENCE_CONTROL%SW_CONFIDENCE_LIMIT",& - r_val=fe_env%conv_par%sw_conf_lm,error=error) + r_val=fe_env%conv_par%sw_conf_lm) CALL section_vals_val_get(ui_section,"CONVERGENCE_CONTROL%VN_CONFIDENCE_LIMIT",& - r_val=fe_env%conv_par%vn_conf_lm,error=error) + r_val=fe_env%conv_par%vn_conf_lm) ! Umbrella Integration variables ALLOCATE(fe_env%uivar(fe_env%ncolvar), stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DO i = 1, fe_env%ncolvar ! Read Umbrella Integration Variable definition CALL section_vals_val_get(ui_var_section,"COLVAR",& - i_val=fe_env%uivar(i)%icolvar,i_rep_section=i,error=error) + i_val=fe_env%uivar(i)%icolvar,i_rep_section=i) NULLIFY(fe_env%uivar(i)%ss) END DO CASE (do_fe_ac) ALLOCATE(fe_env, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) NULLIFY(fe_env%covmx, fe_env%uivar, fe_env%conv_par, fe_env%cg_data) ALLOCATE(fe_env%covmx(3,0), stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) fe_env%type = id_method - CALL section_vals_val_get(fe_section,"ALCHEMICAL_CHANGE%EPS_CONV",r_val=fe_env%eps_conv,error=error) + CALL section_vals_val_get(fe_section,"ALCHEMICAL_CHANGE%EPS_CONV",r_val=fe_env%eps_conv) CASE DEFAULT ! Do Nothing END SELECT @@ -161,13 +158,10 @@ END SUBROUTINE fe_env_create ! ***************************************************************************** !> \brief releases the fe_env !> \param fe_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Laino Teodoro 01.2007 ! ***************************************************************************** - SUBROUTINE fe_env_release(fe_env,error) + SUBROUTINE fe_env_release(fe_env) TYPE(free_energy_type), POINTER :: fe_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fe_env_release', & routineP = moduleN//':'//routineN @@ -180,38 +174,38 @@ SUBROUTINE fe_env_release(fe_env,error) IF (ASSOCIATED(fe_env)) THEN IF (ASSOCIATED(fe_env%covmx)) THEN DEALLOCATE(fe_env%covmx,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(fe_env%cg_data)) THEN DO i = 1, SIZE(fe_env%cg_data) IF (ASSOCIATED(fe_env%cg_data(i)%avg)) THEN DEALLOCATE(fe_env%cg_data(i)%avg,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fe_env%cg_data(i)%var)) THEN DEALLOCATE(fe_env%cg_data(i)%var,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(fe_env%cg_data,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fe_env%conv_par)) THEN DEALLOCATE(fe_env%conv_par,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fe_env%uivar)) THEN DO i = 1, SIZE(fe_env%uivar) IF (ASSOCIATED(fe_env%uivar(i)%ss)) THEN DEALLOCATE(fe_env%uivar(i)%ss,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(fe_env%uivar,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(fe_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE fe_env_release diff --git a/src/gauss_colloc.F b/src/gauss_colloc.F index 74ccd2627a..1f24b0a124 100644 --- a/src/gauss_colloc.F +++ b/src/gauss_colloc.F @@ -76,10 +76,9 @@ MODULE gauss_colloc !> Set it to posi to use the global reference system. !> \param scale a global scale factor !> \param lgrid ... -!> \param error type to control the error handling ! ***************************************************************************** SUBROUTINE collocGauss(h,h_inv,grid,poly,alphai,posi,max_r2,& - periodic,gdim,local_bounds,local_shift,poly_shift,scale,lgrid,error) + periodic,gdim,local_bounds,local_shift,poly_shift,scale,lgrid) REAL(dp), DIMENSION(0:2, 0:2), & INTENT(in) :: h, h_inv REAL(dp), DIMENSION(0:, 0:, 0:), & @@ -100,14 +99,13 @@ SUBROUTINE collocGauss(h,h_inv,grid,poly,alphai,posi,max_r2,& REAL(dp), INTENT(in), OPTIONAL :: scale TYPE(lgrid_type), INTENT(inout), & OPTIONAL :: lgrid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'collocGauss', & routineP = moduleN//':'//routineN CALL colloc_int_body(h,h_inv,grid,poly,alphai,posi,max_r2,& periodic,gdim,local_bounds,local_shift,& - poly_shift,scale,lgrid,integrate=.FALSE.,error=error) + poly_shift,scale,lgrid,integrate=.FALSE.) END SUBROUTINE @@ -130,10 +128,9 @@ SUBROUTINE collocGauss(h,h_inv,grid,poly,alphai,posi,max_r2,& !> \param local_shift ... !> \param poly_shift ... !> \param scale ... -!> \param error ... ! ***************************************************************************** SUBROUTINE integrateGaussFull(h,h_inv,grid,poly,alphai,posi,max_r2,& - periodic,gdim,local_bounds,local_shift,poly_shift,scale,error) + periodic,gdim,local_bounds,local_shift,poly_shift,scale) REAL(dp), DIMENSION(0:2, 0:2), & INTENT(in) :: h, h_inv REAL(dp), DIMENSION(0:, 0:, 0:), & @@ -152,14 +149,13 @@ SUBROUTINE integrateGaussFull(h,h_inv,grid,poly,alphai,posi,max_r2,& REAL(dp), DIMENSION(0:2), INTENT(in), & OPTIONAL :: poly_shift REAL(dp), INTENT(in), OPTIONAL :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'integrateGaussFull', & routineP = moduleN//':'//routineN CALL colloc_int_body(h,h_inv,grid,poly,alphai,posi,max_r2,& periodic,gdim,local_bounds,local_shift,& - poly_shift,scale,integrate=.TRUE.,error=error) + poly_shift,scale,integrate=.TRUE.) END SUBROUTINE @@ -183,10 +179,9 @@ SUBROUTINE integrateGaussFull(h,h_inv,grid,poly,alphai,posi,max_r2,& !> \param scale ... !> \param lgrid ... !> \param integrate ... -!> \param error ... ! ***************************************************************************** SUBROUTINE colloc_int_body(h,h_inv,grid,poly,alphai,posi,max_r2,& - periodic,gdim,local_bounds,local_shift,poly_shift,scale,lgrid,integrate,error) + periodic,gdim,local_bounds,local_shift,poly_shift,scale,lgrid,integrate) REAL(dp), DIMENSION(0:2, 0:2), & INTENT(in) :: h, h_inv REAL(dp), DIMENSION(0:, 0:, 0:), & @@ -208,7 +203,6 @@ SUBROUTINE colloc_int_body(h,h_inv,grid,poly,alphai,posi,max_r2,& TYPE(lgrid_type), INTENT(inout), & OPTIONAL :: lgrid LOGICAL :: integrate - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colloc_int_body', & routineP=moduleN//':'//routineN @@ -308,16 +302,16 @@ SUBROUTINE colloc_int_body(h,h_inv,grid,poly,alphai,posi,max_r2,& END IF l_ub=l_bounds(2,:)-l_bounds(1,:)+l_shift DO i=0,2 - CPPrecondition(l_ub(i)=0 .or.period(:)==1),cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(l_bounds(2,:)-l_bounds(1,:)=0 .or.period(:)==1),cp_failure_level,routineP,failure) + CPPrecondition(ALL(l_bounds(2,:)-l_bounds(1,:) \param cutoff ... !> \param rel_cutoff ... !> \param print_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_gaussian_gridlevel(gridlevel_info,ngrid_levels,cutoff,rel_cutoff, print_section, error) + SUBROUTINE init_gaussian_gridlevel(gridlevel_info,ngrid_levels,cutoff,rel_cutoff, print_section) TYPE(gridlevel_info_type) :: gridlevel_info INTEGER :: ngrid_levels REAL(KIND=dp), DIMENSION(:), POINTER :: cutoff REAL(KIND=dp) :: rel_cutoff TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i @@ -73,20 +71,18 @@ SUBROUTINE init_gaussian_gridlevel(gridlevel_info,ngrid_levels,cutoff,rel_cutoff gridlevel_info%count(i)=0 ENDDO gridlevel_info%print_section=>print_section - CALL section_vals_retain(print_section,error=error) + CALL section_vals_retain(print_section) END SUBROUTINE init_gaussian_gridlevel ! ***************************************************************************** !> \brief ... !> \param gridlevel_info ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE destroy_gaussian_gridlevel(gridlevel_info,para_env,error) + SUBROUTINE destroy_gaussian_gridlevel(gridlevel_info,para_env) TYPE(gridlevel_info_type) :: gridlevel_info TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'destroy_gaussian_gridlevel', & routineP = moduleN//':'//routineN @@ -95,14 +91,14 @@ SUBROUTINE destroy_gaussian_gridlevel(gridlevel_info,para_env,error) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (PRESENT(para_env)) THEN group=para_env%group ELSE group=logger%para_env%group END IF output_unit = cp_print_key_unit_nr(logger,gridlevel_info%print_section, & - "", extension=".Log",error=error) + "", extension=".Log") CALL mp_sum(gridlevel_info%total_count,group) CALL mp_sum(gridlevel_info%count,group) @@ -130,9 +126,9 @@ SUBROUTINE destroy_gaussian_gridlevel(gridlevel_info,para_env,error) "gridlevel_info%cutoff") CALL cp_print_key_finished_output(output_unit,logger,gridlevel_info%print_section,& - "", error=error) + "") - CALL section_vals_release(gridlevel_info%print_section,error=error) + CALL section_vals_release(gridlevel_info%print_section) DEALLOCATE (gridlevel_info%count,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& diff --git a/src/gle_system_types.F b/src/gle_system_types.F index c22d0a366f..332ca626cc 100644 --- a/src/gle_system_types.F +++ b/src/gle_system_types.F @@ -63,14 +63,12 @@ MODULE gle_system_types !> \param dt ... !> \param temp ... !> \param section ... -!> \param error ... !> \param ! ***************************************************************************** - SUBROUTINE gle_init(gle, dt,temp, section, error) + SUBROUTINE gle_init(gle, dt,temp, section) TYPE(gle_type), POINTER :: gle REAL(dp), INTENT(IN) :: dt, temp TYPE(section_vals_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gle_init', & routineP = moduleN//':'//routineN @@ -92,28 +90,28 @@ SUBROUTINE gle_init(gle, dt,temp, section, error) CALL cite_reference(Ceriotti2009) CALL cite_reference(Ceriotti2009b) - CALL section_vals_val_get(section,"NDIM",i_val=gle%ndim,error=error) - CALL section_vals_val_get(section,"A_SCALE",r_val=a_scale,error=error) + CALL section_vals_val_get(section,"NDIM",i_val=gle%ndim) + CALL section_vals_val_get(section,"A_SCALE",r_val=a_scale) ALLOCATE(gle%a_mat(gle%ndim,gle%ndim), STAT=istat) ALLOCATE(gle%c_mat(gle%ndim,gle%ndim), STAT=istat) ALLOCATE(gle%gle_s(gle%ndim,gle%ndim), STAT=istat) ALLOCATE(gle%gle_t(gle%ndim,gle%ndim), STAT=istat) - CALL section_vals_val_get(section,"A_LIST",n_rep_val=n_rep, error=error) + CALL section_vals_val_get(section,"A_LIST",n_rep_val=n_rep) j = 1 k = 1 DO ir = 1,n_rep NULLIFY(list) CALL section_vals_val_get(section,"A_LIST",& - i_rep_val=ir,r_vals=list,error=error) + i_rep_val=ir,r_vals=list) IF(ASSOCIATED(list)) THEN DO i = 1,SIZE(list) IF(j>gle%ndim) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"GLE: Too many elements in A_LIST",error,failure) + routineP,"GLE: Too many elements in A_LIST",failure) END IF gle%a_mat(j,k) = list(i) k = k + 1 @@ -126,24 +124,24 @@ SUBROUTINE gle_init(gle, dt,temp, section, error) END DO ! ir IF(j0) THEN j = 1 k = 1 DO ir = 1,n_rep NULLIFY(list) CALL section_vals_val_get(section,"C_LIST",& - i_rep_val=ir,r_vals=list,error=error) + i_rep_val=ir,r_vals=list) IF(ASSOCIATED(list)) THEN DO i = 1,SIZE(list) IF(j>gle%ndim) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"GLE: Too many elements in C_LIST",error,failure) + routineP,"GLE: Too many elements in C_LIST",failure) END IF gle%c_mat(j,k) = list(i) k = k + 1 @@ -156,7 +154,7 @@ SUBROUTINE gle_init(gle, dt,temp, section, error) END DO ! ir IF(j \brief ... !> \param gle ... !> \param mal_size ... -!> \param error ... !> \param ! ***************************************************************************** - SUBROUTINE gle_thermo_create(gle, mal_size, error) + SUBROUTINE gle_thermo_create(gle, mal_size) TYPE(gle_type), POINTER :: gle INTEGER, INTENT(IN) :: mal_size - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gle_thermo_create', & routineP = moduleN//':'//routineN @@ -190,35 +186,35 @@ SUBROUTINE gle_thermo_create(gle, mal_size, error) REAL(KIND=dp), DIMENSION(3, 2) :: initial_seed, my_seed failure = .FALSE. - CPPrecondition(ASSOCIATED(gle),cp_fatal_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(gle%nvt),cp_fatal_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gle),cp_fatal_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(gle%nvt),cp_fatal_level,routineP,failure) ALLOCATE ( gle%nvt(gle%loc_num_gle),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, gle%loc_num_gle NULLIFY(gle%nvt(i)%s) ALLOCATE(gle%nvt(i)%s(gle%ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gle%nvt(i)%kin_energy = 0.0_dp gle%nvt(i)%thermostat_energy = 0.0_dp END DO ALLOCATE ( gle%mal(mal_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gle%mal(:) = 0 ! Initialize the gaussian stream random number - initial_seed = next_rng_seed(error=error) + initial_seed = next_rng_seed() ALLOCATE (seed(3,2,gle%glob_num_gle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) seed(:,:,1) = initial_seed DO ithermo=2,gle%glob_num_gle - seed(:,:,ithermo) = next_rng_seed(seed(:,:,ithermo-1),error=error) + seed(:,:,ithermo) = next_rng_seed(seed(:,:,ithermo-1)) END DO ! Update initial seed - initial_seed = next_rng_seed(seed(:,:,gle%glob_num_gle),error=error) + initial_seed = next_rng_seed(seed(:,:,gle%glob_num_gle)) DO ithermo = 1, gle%loc_num_gle NULLIFY(gle%nvt(ithermo)%gaussian_rng_stream) my_index = gle%map_info%index(ithermo) @@ -227,23 +223,20 @@ SUBROUTINE gle_thermo_create(gle, mal_size, error) CALL compress(name) CALL create_rng_stream(rng_stream=gle%nvt(ithermo)%gaussian_rng_stream,& name=name,distribution_type=GAUSSIAN, extended_precision=.TRUE.,& - seed=my_seed,error=error) + seed=my_seed) END DO DEALLOCATE (seed,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE gle_thermo_create ! ***************************************************************************** !> \brief Deallocate type for GLE thermostat !> \param gle ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE gle_dealloc ( gle, error ) + SUBROUTINE gle_dealloc ( gle) TYPE(gle_type), POINTER :: gle - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gle_dealloc', & routineP = moduleN//':'//routineN @@ -256,39 +249,39 @@ SUBROUTINE gle_dealloc ( gle, error ) IF (ASSOCIATED(gle)) THEN IF ( ASSOCIATED(gle%a_mat)) THEN DEALLOCATE (gle%a_mat, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF ( ASSOCIATED(gle%c_mat)) THEN DEALLOCATE (gle%c_mat, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF ( ASSOCIATED(gle%gle_t)) THEN DEALLOCATE (gle%gle_t, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF ( ASSOCIATED(gle%gle_s)) THEN DEALLOCATE (gle%gle_s, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF IF (ASSOCIATED (gle%nvt)) THEN DO i = 1,SIZE(gle%nvt) DEALLOCATE (gle%nvt(i)%s, STAT=stat) IF (ASSOCIATED(gle%nvt(i)%gaussian_rng_stream)) THEN - CALL delete_rng_stream(gle%nvt(i)%gaussian_rng_stream,error=error) + CALL delete_rng_stream(gle%nvt(i)%gaussian_rng_stream) END IF - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END DO DEALLOCATE (gle%nvt, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF IF (ASSOCIATED (gle%mal)) THEN DEALLOCATE (gle%mal, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF - CALL release_map_info_type(gle%map_info, error) + CALL release_map_info_type(gle%map_info) DEALLOCATE (gle, STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF END SUBROUTINE gle_dealloc diff --git a/src/global_types.F b/src/global_types.F index 2be4b9c197..d1507dfc8a 100644 --- a/src/global_types.F +++ b/src/global_types.F @@ -90,13 +90,10 @@ MODULE global_types ! ***************************************************************************** !> \brief creates a globenv !> \param globenv the globenv to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE globenv_create(globenv, error) + SUBROUTINE globenv_create(globenv) TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'globenv_create', & routineP = moduleN//':'//routineN @@ -106,9 +103,9 @@ SUBROUTINE globenv_create(globenv, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(globenv),cp_failure_level,routineP,failure) ALLOCATE(globenv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_globenv_id=last_globenv_id+1 globenv%id_nr=last_globenv_id globenv%ref_count=1 @@ -127,13 +124,10 @@ END SUBROUTINE globenv_create ! ***************************************************************************** !> \brief retains the global environment !> \param globenv the global environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE globenv_retain(globenv, error) +SUBROUTINE globenv_retain(globenv) TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'globenv_retain', & routineP = moduleN//':'//routineN @@ -142,21 +136,18 @@ SUBROUTINE globenv_retain(globenv, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) - CPPrecondition(globenv%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) + CPPrecondition(globenv%ref_count>0,cp_failure_level,routineP,failure) globenv%ref_count=globenv%ref_count+1 END SUBROUTINE globenv_retain ! ***************************************************************************** !> \brief releases the global environment !> \param globenv the global environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE globenv_release(globenv, error) +SUBROUTINE globenv_release(globenv) TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'globenv_release', & routineP = moduleN//':'//routineN @@ -167,14 +158,14 @@ SUBROUTINE globenv_release(globenv, error) failure=.FALSE. IF (ASSOCIATED(globenv)) THEN - CPPrecondition(globenv%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(globenv%ref_count>0,cp_failure_level,routineP,failure) globenv%ref_count=globenv%ref_count-1 IF (globenv%ref_count==0) THEN IF (ASSOCIATED(globenv%gaussian_rng_stream)) THEN - CALL delete_rng_stream(globenv%gaussian_rng_stream,error=error) + CALL delete_rng_stream(globenv%gaussian_rng_stream) END IF DEALLOCATE(globenv,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(globenv) diff --git a/src/hartree_local_methods.F b/src/hartree_local_methods.F index 1acee24aa6..f381e9629a 100644 --- a/src/hartree_local_methods.F +++ b/src/hartree_local_methods.F @@ -67,13 +67,11 @@ MODULE hartree_local_methods !> \brief ... !> \param hartree_local ... !> \param natom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_coulomb_local(hartree_local,natom,error) + SUBROUTINE init_coulomb_local(hartree_local,natom) TYPE(hartree_local_type), POINTER :: hartree_local INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_coulomb_local', & routineP = moduleN//':'//routineN @@ -86,7 +84,7 @@ SUBROUTINE init_coulomb_local(hartree_local,natom,error) NULLIFY(ecoul_1c) ! Allocate and Initialize 1-center Potentials and Integrals - CALL allocate_ecoul_1center(ecoul_1c,natom, error) + CALL allocate_ecoul_1center(ecoul_1c,natom) hartree_local%ecoul_1c => ecoul_1c CALL timestop(handle) @@ -212,18 +210,16 @@ END SUBROUTINE calculate_Vh_1center !> \param tddft ... !> \param do_triplet ... !> \param p_env ... -!> \param error ... !> \par History !> 05.2012 JGH refactoring !> \author ?? ! ***************************************************************************** - SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env,error) + SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env) TYPE(qs_environment_type), POINTER :: qs_env REAL(kind=dp), INTENT(out) :: energy_hartree_1c LOGICAL, INTENT(IN), OPTIONAL :: tddft, do_triplet TYPE(qs_p_env_type), OPTIONAL, POINTER :: p_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'Vh_1c_gg_integrals', & routineP = moduleN//':'//routineN @@ -289,9 +285,9 @@ SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env,er para_env=para_env,& atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,atprop=atprop,& - pw_env=pw_env,qs_charges=qs_charges,error=error) + pw_env=pw_env,qs_charges=qs_charges) - CALL pw_env_get(pw_env,poisson_env=poisson_env,error=error) + CALL pw_env_get(pw_env,poisson_env=poisson_env) my_periodic= (poisson_env%method==pw_poisson_periodic) back_ch = qs_charges%background*cell%deth @@ -307,7 +303,7 @@ SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env,er rho0_atom_set=rho0_atom_set, & rho0_mpole=rho0_mpole,& rhoz_set=rhoz_set,& - ecoul_1c=ecoul_1c,error=error) + ecoul_1c=ecoul_1c) END IF nkind = SIZE(atomic_kind_set,1) @@ -321,15 +317,15 @@ SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env,er ENDIF END IF - CALL get_qs_kind_set(qs_kind_set,maxg_iso_not0=max_iso,error=error) + CALL get_qs_kind_set(qs_kind_set,maxg_iso_not0=max_iso) CALL get_rho0_mpole(rho0_mpole=rho0_mpole,lmax_0=lmax_0) atenergy=.FALSE. IF (ASSOCIATED(atprop)) THEN atenergy = atprop%energy IF (atenergy) THEN - CALL get_qs_env(qs_env=qs_env,natom=natom,error=error) - CALL atprop_array_init(atprop%ate1c,natom,error) + CALL get_qs_env(qs_env=qs_env,natom=natom) + CALL atprop_array_init(atprop%ate1c,natom) END IF END IF @@ -344,7 +340,7 @@ SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env,er basis_set=orb_basis,& grid_atom=grid_atom,& harmonics=harmonics,ngrid_rad=nr,& - max_iso_not0=max_iso_not0,paw_atom=paw_atom,error=error) + max_iso_not0=max_iso_not0,paw_atom=paw_atom) IF(paw_atom) THEN !=========== PAW =============== @@ -357,26 +353,26 @@ SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env,er nsotot = maxso*nset ALLOCATE(gsph(nr,nsotot),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(gexp(nr),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(sqrtwr(nr),g0_h_w(nr,0:lmax_0),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(Vh1_h,Vh1_s) ALLOCATE(Vh1_h(nr,max_iso_not0),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(Vh1_s(nr,max_iso_not0),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(aVh1b_hh(nsotot,nsotot),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(aVh1b_ss(nsotot,nsotot),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(aVh1b_00(nsotot,nsotot),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(Qlm_gg,g0_h) CALL get_rho0_mpole(rho0_mpole=rho0_mpole, ikind=ikind, & @@ -440,35 +436,35 @@ SUBROUTINE Vh_1c_gg_integrals(qs_env,energy_hartree_1c,tddft,do_triplet,p_env,er CALL Vh_1c_atom_potential(rho_atom,vrrad_0,& grid_atom,core_charge,vrrad_z,Vh1_h,Vh1_s,& - nchan_0,nspins,max_iso_not0,factor,error) + nchan_0,nspins,max_iso_not0,factor) CALL Vh_1c_atom_energy(energy_hartree_1c,ecoul_1c,rho_atom,rrad_0,& grid_atom,iatom,core_charge,rrad_z,Vh1_h,Vh1_s,& - nchan_0,nspins,max_iso_not0,atenergy,atprop%ate1c,error) + nchan_0,nspins,max_iso_not0,atenergy,atprop%ate1c) CALL Vh_1c_atom_integrals(rho_atom,& aVh1b_hh,aVh1b_ss,aVh1b_00,Vh1_h,Vh1_s,max_iso_not0,& max_s_harm,llmax,cg_list,cg_n_list,& - nset,npgf,lmin,lmax,nsotot,maxso,nspins,nchan_0,gsph,g0_h_w,my_CG,Qlm_gg,error) + nset,npgf,lmin,lmax,nsotot,maxso,nspins,nchan_0,gsph,g0_h_w,my_CG,Qlm_gg) END DO ! iat DEALLOCATE(aVh1b_hh,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(aVh1b_ss,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(aVh1b_00,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(Vh1_h,Vh1_s, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cg_list,cg_n_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(gsph,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(gexp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(sqrtwr,g0_h_w,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE !=========== NO PAW =============== @@ -498,11 +494,10 @@ END SUBROUTINE Vh_1c_gg_integrals !> \param nspins ... !> \param max_iso_not0 ... !> \param bfactor ... -!> \param error ... ! ***************************************************************************** SUBROUTINE Vh_1c_atom_potential(rho_atom,vrrad_0,& grid_atom,core_charge,vrrad_z,Vh1_h,Vh1_s,& - nchan_0,nspins,max_iso_not0,bfactor,error) + nchan_0,nspins,max_iso_not0,bfactor) TYPE(rho_atom_type), POINTER :: rho_atom REAL(dp), DIMENSION(:, :), POINTER :: vrrad_0 @@ -512,7 +507,6 @@ SUBROUTINE Vh_1c_atom_potential(rho_atom,vrrad_0,& REAL(dp), DIMENSION(:, :), POINTER :: Vh1_h, Vh1_s INTEGER, INTENT(IN) :: nchan_0, nspins, max_iso_not0 REAL(dp), INTENT(IN) :: bfactor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'Vh_1c_atom_potential', & routineP = moduleN//':'//routineN @@ -570,11 +564,10 @@ END SUBROUTINE Vh_1c_atom_potential !> \param max_iso_not0 ... !> \param atenergy ... !> \param ate1c ... -!> \param error ... ! ***************************************************************************** SUBROUTINE Vh_1c_atom_energy(energy_hartree_1c,ecoul_1c,rho_atom,rrad_0,& grid_atom,iatom,core_charge,rrad_z,Vh1_h,Vh1_s,& - nchan_0,nspins,max_iso_not0,atenergy,ate1c,error) + nchan_0,nspins,max_iso_not0,atenergy,ate1c) REAL(dp), INTENT(INOUT) :: energy_hartree_1c TYPE(ecoul_1center_type), DIMENSION(:), & @@ -589,7 +582,6 @@ SUBROUTINE Vh_1c_atom_energy(energy_hartree_1c,ecoul_1c,rho_atom,rrad_0,& INTEGER, INTENT(IN) :: nchan_0, nspins, max_iso_not0 LOGICAL, INTENT(IN) :: atenergy REAL(dp), DIMENSION(:), POINTER :: ate1c - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'Vh_1c_atom_energy', & routineP = moduleN//':'//routineN @@ -667,12 +659,11 @@ END SUBROUTINE Vh_1c_atom_energy !> \param g0_h_w ... !> \param my_CG ... !> \param Qlm_gg ... -!> \param error ... ! ***************************************************************************** SUBROUTINE Vh_1c_atom_integrals(rho_atom,& aVh1b_hh,aVh1b_ss,aVh1b_00,Vh1_h,Vh1_s,max_iso_not0,& max_s_harm,llmax,cg_list,cg_n_list,& - nset,npgf,lmin,lmax,nsotot,maxso,nspins,nchan_0,gsph,g0_h_w,my_CG,Qlm_gg,error) + nset,npgf,lmin,lmax,nsotot,maxso,nspins,nchan_0,gsph,g0_h_w,my_CG,Qlm_gg) TYPE(rho_atom_type), POINTER :: rho_atom REAL(dp), DIMENSION(:, :) :: aVh1b_hh, aVh1b_ss, aVh1b_00 @@ -687,7 +678,6 @@ SUBROUTINE Vh_1c_atom_integrals(rho_atom,& REAL(dp), DIMENSION(:, :), POINTER :: gsph REAL(dp), DIMENSION(:, 0:) :: g0_h_w REAL(dp), DIMENSION(:, :, :), POINTER :: my_CG, Qlm_gg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'Vh_1c_atom_integrals', & routineP = moduleN//':'//routineN @@ -715,7 +705,7 @@ SUBROUTINE Vh_1c_atom_integrals(rho_atom,& m2 = 0 DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local,error) + max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local) n1 = nsoset(lmax(iset1)) DO ipgf1 = 1,npgf(iset1) diff --git a/src/hartree_local_types.F b/src/hartree_local_types.F index 77eaff10f0..f640201bf7 100644 --- a/src/hartree_local_types.F +++ b/src/hartree_local_types.F @@ -49,14 +49,12 @@ MODULE hartree_local_types !> \brief ... !> \param ecoul_1c ... !> \param natom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_ecoul_1center(ecoul_1c,natom,error) + SUBROUTINE allocate_ecoul_1center(ecoul_1c,natom) TYPE(ecoul_1center_type), DIMENSION(:), & POINTER :: ecoul_1c INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_ecoul_1center', & routineP = moduleN//':'//routineN @@ -65,18 +63,18 @@ SUBROUTINE allocate_ecoul_1center(ecoul_1c,natom,error) LOGICAL :: failure IF(ASSOCIATED(ecoul_1c)) THEN - CALL deallocate_ecoul_1center(ecoul_1c,error) + CALL deallocate_ecoul_1center(ecoul_1c) END IF ALLOCATE(ecoul_1c(natom), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO iat = 1,natom ALLOCATE(ecoul_1c(iat)%Vh1_h,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(ecoul_1c(iat)%Vh1_h%r_coef) ALLOCATE(ecoul_1c(iat)%Vh1_s,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(ecoul_1c(iat)%Vh1_s%r_coef) END DO @@ -85,13 +83,11 @@ END SUBROUTINE allocate_ecoul_1center ! ***************************************************************************** !> \brief ... !> \param ecoul_1c ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_ecoul_1center(ecoul_1c,error) + SUBROUTINE deallocate_ecoul_1center(ecoul_1c) TYPE(ecoul_1center_type), DIMENSION(:), & POINTER :: ecoul_1c - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_ecoul_1center', & routineP = moduleN//':'//routineN @@ -104,22 +100,22 @@ SUBROUTINE deallocate_ecoul_1center(ecoul_1c,error) DO iat= 1,natom IF (ASSOCIATED(ecoul_1c(iat)%Vh1_h%r_coef)) THEN DEALLOCATE(ecoul_1c(iat)%Vh1_h%r_coef,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(ecoul_1c(iat)%Vh1_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(ecoul_1c(iat)%Vh1_s%r_coef)) THEN DEALLOCATE(ecoul_1c(iat)%Vh1_s%r_coef,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(ecoul_1c(iat)%Vh1_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(ecoul_1c, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_ecoul_1center @@ -166,12 +162,10 @@ END SUBROUTINE get_hartree_local ! ***************************************************************************** !> \brief ... !> \param hartree_local ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE hartree_local_create(hartree_local, error) + SUBROUTINE hartree_local_create(hartree_local) TYPE(hartree_local_type), POINTER :: hartree_local - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hartree_local_create', & routineP = moduleN//':'//routineN @@ -182,7 +176,7 @@ SUBROUTINE hartree_local_create(hartree_local, error) failure=.FALSE. ALLOCATE(hartree_local, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (hartree_local%ecoul_1c) @@ -191,12 +185,10 @@ END SUBROUTINE hartree_local_create ! ***************************************************************************** !> \brief ... !> \param hartree_local ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE hartree_local_release(hartree_local, error) + SUBROUTINE hartree_local_release(hartree_local) TYPE(hartree_local_type), POINTER :: hartree_local - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hartree_local_release', & routineP = moduleN//':'//routineN @@ -205,11 +197,11 @@ SUBROUTINE hartree_local_release(hartree_local, error) IF (ASSOCIATED(hartree_local)) THEN IF (ASSOCIATED(hartree_local%ecoul_1c)) THEN - CALL deallocate_ecoul_1center(hartree_local%ecoul_1c, error) + CALL deallocate_ecoul_1center(hartree_local%ecoul_1c) END IF DEALLOCATE(hartree_local,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE hartree_local_release diff --git a/src/helium_common.F b/src/helium_common.F index 639144a207..6ce281b360 100644 --- a/src/helium_common.F +++ b/src/helium_common.F @@ -340,16 +340,14 @@ END SUBROUTINE helium_calc_wnumber ! ***************************************************************************** !> \brief Calculate helium radial distribution function wrt . !> \param helium ... -!> \param error ... !> \date 2009-07-22 !> \author Lukasz Walewski !> \note Actually calculate the histogram only, the normalization is !> postponed to the postprocessing stage. ! ***************************************************************************** - SUBROUTINE helium_calc_rdf( helium, error ) + SUBROUTINE helium_calc_rdf( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_rdf', & routineP = moduleN//':'//routineN @@ -362,7 +360,7 @@ SUBROUTINE helium_calc_rdf( helium, error ) ! CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) ! calculate the histogram of distances helium%rdf_inst(:) = 0.0_dp @@ -402,7 +400,6 @@ END SUBROUTINE helium_calc_rdf ! ***************************************************************************** !> \brief Calculate helium density distribution function wrt . !> \param helium ... -!> \param error ... !> \date 2011-06-14 !> \author Lukasz Walewski !> \note The calculated density is stored in the helium%rho_inst array. @@ -411,10 +408,9 @@ END SUBROUTINE helium_calc_rdf !> suitable for the superfluid density estimator calculation !> (full version still in the development branch) [lwalewski] ! ***************************************************************************** - SUBROUTINE helium_calc_rho( helium, error ) + SUBROUTINE helium_calc_rho( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_rho', & routineP = moduleN//':'//routineN @@ -428,7 +424,7 @@ SUBROUTINE helium_calc_rho( helium, error ) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) helium%rho_inst(:,:,:,:) = 0.0_dp r0(:) = helium%origin(:) @@ -448,11 +444,11 @@ SUBROUTINE helium_calc_rho( helium, error ) ! check that bin numbers are within bounds itmp = helium%rho_nbin ltmp = (0 .LT. bx) .AND. ( bx .LE. itmp ) - CPPrecondition(ltmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ltmp,cp_failure_level,routineP,failure) ltmp = (0 .LT. by) .AND. ( by .LE. itmp ) - CPPrecondition(ltmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ltmp,cp_failure_level,routineP,failure) ltmp = (0 .LT. bz) .AND. ( bz .LE. itmp ) - CPPrecondition(ltmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ltmp,cp_failure_level,routineP,failure) helium%rho_inst(1,bx,by,bz) = helium%rho_inst(1,bx,by,bz) + c @@ -468,7 +464,6 @@ END SUBROUTINE helium_calc_rho ! *************************************************************************** !> \brief Calculate probability distribution of the permutation lengths !> \param helium ... -!> \param error ... !> \date 2010-06-07 !> \author Lukasz Walewski !> \note Valid permutation path length is an integer (1, NATOMS), number @@ -476,10 +471,9 @@ END SUBROUTINE helium_calc_rho !> inner loop iterations and helium environments is done in !> helium_sample. ! ***************************************************************************** - SUBROUTINE helium_calc_plength( helium, error ) + SUBROUTINE helium_calc_plength( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_plength', & routineP = moduleN//':'//routineN @@ -506,7 +500,6 @@ END SUBROUTINE helium_calc_plength !> \brief Rotate helium particles in imaginary time by nslices !> \param helium ... !> \param nslices ... -!> \param error ... !> \author hforbert !> \note Positions of helium beads in helium%pos array are reorganized such !> that the indices are cyclically translated in a permutation-aware @@ -515,10 +508,9 @@ END SUBROUTINE helium_calc_plength !> should be always within 0 (no rotation) and helium%beads-1 (almost !> full rotation). [lwalewski] ! ***************************************************************************** - SUBROUTINE helium_rotate(helium, nslices, error) + SUBROUTINE helium_rotate(helium, nslices) TYPE(helium_solvent_type), POINTER :: helium INTEGER, INTENT(IN) :: nslices - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_rotate', & routineP = moduleN//':'//routineN @@ -527,7 +519,7 @@ SUBROUTINE helium_rotate(helium, nslices, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) b = helium%beads n = helium%atoms @@ -628,12 +620,10 @@ END FUNCTION helium_eval_expansion ! ***************************************************************************** !> \brief ... !> \param helium ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE helium_update_transition_matrix(helium,error) + SUBROUTINE helium_update_transition_matrix(helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: b, c, i, j, k, m, n, nb INTEGER, ALLOCATABLE, DIMENSION(:) :: lens, order @@ -895,7 +885,7 @@ SUBROUTINE helium_update_transition_matrix(helium,error) ! number of random numbers to generate: c = 1000000000 DO j=1, c - v = next_random_number(helium%rng_stream_uniform,error=error) + v = next_random_number(helium%rng_stream_uniform) ! walk down the search tree: k = nb-1 DO @@ -974,7 +964,7 @@ SUBROUTINE helium_update_transition_matrix(helium,error) ! (should not be taken, but just in case it does we have something valid) helium%pweight = 0.0_dp - t = next_random_number(helium%rng_stream_uniform,error=error) + t = next_random_number(helium%rng_stream_uniform) helium%ptable(1) = 1+INT(t*nb) helium%ptable(2) = -1 @@ -1515,16 +1505,14 @@ END FUNCTION helium_sdensity_part ! *************************************************************************** !> \brief Given the permutation state assign cycle lengths to all He atoms. !> \param helium ... -!> \param error ... !> \date 2011-07-06 !> \author Lukasz Walewski !> \note The helium%atom_plength array is filled with cycle lengths, !> each atom gets the length of the permutation cycle it belongs to. ! ***************************************************************************** - SUBROUTINE helium_calc_atom_cycle_length( helium, error ) + SUBROUTINE helium_calc_atom_cycle_length( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'helium_calc_atom_cycle_length', & diff --git a/src/helium_io.F b/src/helium_io.F index 496861c451..54378e4d86 100644 --- a/src/helium_io.F +++ b/src/helium_io.F @@ -67,14 +67,12 @@ MODULE helium_io ! *************************************************************************** !> \brief Write helium parameters to the output unit. !> \param helium ... -!> \param error ... !> \date 2009-06-03 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_setup( helium, error ) + SUBROUTINE helium_write_setup( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_setup', & routineP = moduleN//':'//routineN @@ -89,10 +87,10 @@ SUBROUTINE helium_write_setup( helium, error ) TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_label = "HELIUM| " IF (logger%para_env%ionode) THEN @@ -111,26 +109,26 @@ SUBROUTINE helium_write_setup( helium, error ) unit_str = "angstrom^-3" rtmp = cp_unit_from_cp2k(helium%density, & - unit_str, error=error) + unit_str) WRITE(unit_nr,'(T2,A,F12.6)') TRIM(my_label)//" Density ["// & TRIM(unit_str)//"]:", rtmp unit_str = "angstrom" rtmp = cp_unit_from_cp2k(helium%cell_size, & - unit_str, error=error) + unit_str) WRITE(unit_nr,'(T2,A,F12.6)') TRIM(my_label)//" Cell size ["// & TRIM(unit_str)//"]: ", rtmp IF ( helium%periodic ) THEN IF ( helium%cell_shape .EQ. helium_cell_shape_cube ) THEN - CALL helium_write_line("PBC cell shape: CUBE.",error) + CALL helium_write_line("PBC cell shape: CUBE.") ELSE IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) THEN - CALL helium_write_line("PBC cell shape: TRUNCATED OCTAHEDRON.",error) + CALL helium_write_line("PBC cell shape: TRUNCATED OCTAHEDRON.") ELSE - CALL helium_write_line("*** Warning: unknown cell shape.",error) + CALL helium_write_line("*** Warning: unknown cell shape.") END IF ELSE - CALL helium_write_line("PBC turned off.",error) + CALL helium_write_line("PBC turned off.") END IF ! first step gets incremented during first iteration @@ -160,21 +158,21 @@ SUBROUTINE helium_write_setup( helium, error ) ! permutation cycle length sampling stmp = "" - CALL helium_write_line(stmp, error) + CALL helium_write_line(stmp) WRITE(stmp,*) helium%maxcycle stmp2 = "" WRITE(stmp2,*) "Using maximum permutation cycle length: " //& TRIM(ADJUSTL(stmp)) - CALL helium_write_line(stmp2, error) + CALL helium_write_line(stmp2) stmp = "" stmp1 = "" WRITE(stmp1,*) helium%m_ratio stmp2 = "" WRITE(stmp2,*) helium%m_value WRITE(stmp,*) "Using ratio " // TRIM(ADJUSTL(stmp1)) // " for M = " // TRIM(ADJUSTL(stmp2)) - CALL helium_write_line(stmp, error) + CALL helium_write_line(stmp) stmp = "" - CALL helium_write_line(stmp, error) + CALL helium_write_line(stmp) IF (helium%solute_present) THEN WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& @@ -202,9 +200,9 @@ SUBROUTINE helium_write_setup( helium, error ) END DO CALL get_cell(helium%solute_cell, abc=my_abc) unit_str = "angstrom" - v1 = cp_unit_from_cp2k(my_abc(1), unit_str, error=error) - v2 = cp_unit_from_cp2k(my_abc(2), unit_str, error=error) - v3 = cp_unit_from_cp2k(my_abc(3), unit_str, error=error) + v1 = cp_unit_from_cp2k(my_abc(1), unit_str) + v2 = cp_unit_from_cp2k(my_abc(2), unit_str) + v3 = cp_unit_from_cp2k(my_abc(3), unit_str) WRITE(unit_nr,'(T2,A,F12.6,1X,F12.6,1X,F12.6)') & TRIM(my_label)//" Solute cell size ["// & TRIM(unit_str)//"]: ", v1, v2, v3 @@ -214,27 +212,27 @@ SUBROUTINE helium_write_setup( helium, error ) END IF ! radial distribution function related settings - rtmp = cp_unit_from_cp2k(helium%rdf_delr, "angstrom", error=error) + rtmp = cp_unit_from_cp2k(helium%rdf_delr, "angstrom") WRITE(stmp, '(1X,F12.6)') rtmp - CALL helium_write_line("RDF| delr [angstrom]: "//TRIM(stmp),error) - rtmp = cp_unit_from_cp2k(helium%rdf_maxr, "angstrom", error=error) + CALL helium_write_line("RDF| delr [angstrom]: "//TRIM(stmp)) + rtmp = cp_unit_from_cp2k(helium%rdf_maxr, "angstrom") WRITE(stmp, '(1X,F12.6)') rtmp - CALL helium_write_line("RDF| maxr [angstrom]: "//TRIM(stmp),error) + CALL helium_write_line("RDF| maxr [angstrom]: "//TRIM(stmp)) itmp = helium%rdf_nbin WRITE(stmp, '(I6)') itmp - CALL helium_write_line("RDF| nbin : "//TRIM(stmp),error) + CALL helium_write_line("RDF| nbin : "//TRIM(stmp)) - CALL helium_write_line("",error) + CALL helium_write_line("") ! density related IF (helium%rho_present) THEN - CALL helium_write_line("RHO| Calculating densities on the grid", error) + CALL helium_write_line("RHO| Calculating densities on the grid") itmp = helium%rho_nbin stmp = "" WRITE(stmp, '(I6)') itmp CALL helium_write_line("RHO| "//TRIM(ADJUSTL(stmp))//"x"//& - TRIM(ADJUSTL(stmp))//"x"//TRIM(ADJUSTL(stmp)),error) - CALL helium_write_line("",error) + TRIM(ADJUSTL(stmp))//"x"//TRIM(ADJUSTL(stmp))) + CALL helium_write_line("") END IF RETURN @@ -243,14 +241,12 @@ END SUBROUTINE helium_write_setup ! *************************************************************************** !> \brief Writes out a line of text to the default output unit. !> \param line ... -!> \param error ... !> \date 2009-07-10 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_line(line,error) + SUBROUTINE helium_write_line(line) CHARACTER(len=*), INTENT(IN) :: line - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_line', & routineP = moduleN//':'//routineN @@ -260,7 +256,7 @@ SUBROUTINE helium_write_line(line,error) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_label = "HELIUM|" IF (logger%para_env%ionode) THEN @@ -274,14 +270,12 @@ END SUBROUTINE helium_write_line ! *************************************************************************** !> \brief Writes out helium energies according to HELIUM%PRINT%ENERGY !> \param helium ... -!> \param error ... !> \date 2009-06-08 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_energy( helium, error ) + SUBROUTINE helium_write_energy( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_energy', & routineP = moduleN//':'//routineN @@ -296,21 +290,21 @@ SUBROUTINE helium_write_energy( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) my_energy => helium%energy_avrg NULLIFY(print_key,logger) print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%ENERGY", error=error) - logger => cp_error_get_logger(error) + "MOTION%PINT%HELIUM%PRINT%ENERGY") + logger => cp_get_default_logger() iteration = logger%iter_info%iteration(2) IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN unit_nr=cp_print_key_unit_nr(logger,print_key, & middle_name="helium-energy",extension=".dat",& - is_new_file=file_is_new,error=error ) + is_new_file=file_is_new) ! cp_print_key_unit_nr returns -1 on nodes other than logger%para_env%ionode naccptd = 0.0_dp @@ -345,7 +339,7 @@ SUBROUTINE helium_write_energy( helium, error ) my_energy(e_id_total) CALL m_flush(unit_nr) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF CALL timestop(handle) @@ -355,14 +349,12 @@ END SUBROUTINE helium_write_energy ! *************************************************************************** !> \brief Writes out helium energies according to HELIUM%PRINT%SDENSITY !> \param helium ... -!> \param error ... !> \date 2010-06-15 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_sdensity( helium, error ) + SUBROUTINE helium_write_sdensity( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_sdensity', & routineP = moduleN//':'//routineN @@ -375,23 +367,23 @@ SUBROUTINE helium_write_sdensity( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(print_key,logger) print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%SDENSITY", error=error) - logger => cp_error_get_logger(error) + "MOTION%PINT%HELIUM%PRINT%SDENSITY") + logger => cp_get_default_logger() iteration = logger%iter_info%iteration(2) IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-sdensity",extension=".dat",error=error ) + middle_name="helium-sdensity",extension=".dat") IF (unit_nr>0) THEN WRITE (unit_nr,"(F20.9)") helium%sdensity_avrg CALL m_flush(unit_nr) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF CALL timestop(handle) @@ -401,16 +393,14 @@ END SUBROUTINE helium_write_sdensity ! *************************************************************************** !> \brief Writes out helium winding number according to HELIUM%PRINT%WNUMBER !> \param helium ... -!> \param error ... !> \date 2009-10-19 !> \par History !> 2010-06-15 output W for each He environment/processor [lwalewski] !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_wnumber( helium, error ) + SUBROUTINE helium_write_wnumber( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_wnumber', & routineP = moduleN//':'//routineN @@ -423,17 +413,17 @@ SUBROUTINE helium_write_wnumber( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(print_key,logger) print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%WNUMBER", error=error) - logger => cp_error_get_logger(error) + "MOTION%PINT%HELIUM%PRINT%WNUMBER") + logger => cp_get_default_logger() IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-wnumber",extension=".dat",error=error ) + middle_name="helium-wnumber",extension=".dat") ! gather winding number from all processors to logger%para_env%source helium%rtmp_3_np_1d(:) = 0 @@ -453,7 +443,7 @@ SUBROUTINE helium_write_wnumber( helium, error ) CALL m_flush(unit_nr) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF CALL timestop(handle) @@ -463,14 +453,12 @@ END SUBROUTINE helium_write_wnumber ! *************************************************************************** !> \brief Writes out acceptance counts according to HELIUM%PRINT%ACCEPTS !> \param helium ... -!> \param error ... !> \date 2010-05-27 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_accepts( helium, error ) + SUBROUTINE helium_write_accepts( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_accepts', & routineP = moduleN//':'//routineN @@ -484,19 +472,19 @@ SUBROUTINE helium_write_accepts( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(print_key,logger) print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%ACCEPTS", error=error) - logger => cp_error_get_logger(error) + "MOTION%PINT%HELIUM%PRINT%ACCEPTS") + logger => cp_get_default_logger() iteration = logger%iter_info%iteration(2) IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN unit_nr=cp_print_key_unit_nr(logger,print_key, & middle_name="helium-accepts",extension=".dat",& - is_new_file=file_is_new,error=error ) + is_new_file=file_is_new) IF (unit_nr>0) THEN IF ( file_is_new ) THEN @@ -521,7 +509,7 @@ SUBROUTINE helium_write_accepts( helium, error ) CALL m_flush(unit_nr) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF CALL timestop(handle) @@ -531,14 +519,12 @@ END SUBROUTINE helium_write_accepts ! *************************************************************************** !> \brief Writes out permutation state according to HELIUM%PRINT%PERM !> \param helium ... -!> \param error ... !> \date 2010-06-07 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_perm( helium, error ) + SUBROUTINE helium_write_perm( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_perm', & routineP = moduleN//':'//routineN @@ -552,19 +538,19 @@ SUBROUTINE helium_write_perm( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(print_key,logger) print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%PERM", error=error) - logger => cp_error_get_logger(error) + "MOTION%PINT%HELIUM%PRINT%PERM") + logger => cp_get_default_logger() iteration = logger%iter_info%iteration(2) IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN unit_nr=cp_print_key_unit_nr(logger,print_key, & middle_name="helium-perm",extension=".dat",& - is_new_file=file_is_new,error=error ) + is_new_file=file_is_new) ! gather permutation state from all processors to logger%para_env%source helium%itmp_atoms_np_1d(:) = 0 @@ -588,7 +574,7 @@ SUBROUTINE helium_write_perm( helium, error ) CALL m_flush(unit_nr) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF CALL timestop(handle) @@ -598,7 +584,6 @@ END SUBROUTINE helium_write_perm ! *************************************************************************** !> \brief Writes helium configuration according to HELIUM%PRINT%COORDINATES !> \param helium ... -!> \param error ... !> \date 2009-07-16 !> \par History !> 2010-02-15 output from all processors added [lwalewski] @@ -607,10 +592,9 @@ END SUBROUTINE helium_write_perm !> since it does not support atom connectivity information needed !> for helium paths ! ***************************************************************************** - SUBROUTINE helium_write_coordinates( helium, error ) + SUBROUTINE helium_write_coordinates( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_coordinates', & routineP = moduleN//':'//routineN @@ -633,17 +617,17 @@ SUBROUTINE helium_write_coordinates( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger,print_key) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! decide whether to write anything or not print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%COORDINATES", error=error) + "MOTION%PINT%HELIUM%PRINT%COORDINATES") should_output = BTEST(cp_print_key_should_output( & iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) + basis_section=print_key),cp_p_file) IF ( .NOT. should_output ) THEN CALL timestop(handle) RETURN @@ -697,12 +681,12 @@ SUBROUTINE helium_write_coordinates( helium, error ) WRITE(stmp,*) irank my_middle_name = "helium-pos-" // TRIM(ADJUSTL(stmp)) unit_nr=cp_print_key_unit_nr( logger, print_key, & - middle_name=TRIM(my_middle_name), extension=".pdb", error=error ) + middle_name=TRIM(my_middle_name), extension=".pdb") ! write out the unit cell parameters fmt_string = "(A6,3F9.3,3F7.2,1X,A11,1X,I3)" xtmp = helium%cell_size - xtmp = cp_unit_from_cp2k(xtmp, "angstrom", error=error) + xtmp = cp_unit_from_cp2k(xtmp, "angstrom") IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) THEN stmp = "O " ELSE @@ -738,11 +722,11 @@ SUBROUTINE helium_write_coordinates( helium, error ) END IF DO ib = 1, helium%beads xtmp = helium%work(1,ia,ib) - xtmp = cp_unit_from_cp2k(xtmp, "angstrom", error=error) + xtmp = cp_unit_from_cp2k(xtmp, "angstrom") ytmp = helium%work(2,ia,ib) - ytmp = cp_unit_from_cp2k(ytmp, "angstrom", error=error) + ytmp = cp_unit_from_cp2k(ytmp, "angstrom") ztmp = helium%work(3,ia,ib) - ztmp = cp_unit_from_cp2k(ztmp, "angstrom", error=error) + ztmp = cp_unit_from_cp2k(ztmp, "angstrom") WRITE(unit_nr,fmt_string) "ATOM ", & (ia-1)*helium%beads+ib, & " He ", " ", resName, "X", & @@ -821,8 +805,7 @@ SUBROUTINE helium_write_coordinates( helium, error ) WRITE(unit_nr,'(A)') "END" CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,& - error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END DO @@ -835,14 +818,12 @@ END SUBROUTINE helium_write_coordinates ! *************************************************************************** !> \brief Write helium RDF according to HELIUM%PRINT%RDF !> \param helium ... -!> \param error ... !> \date 2009-07-23 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_rdf( helium, error ) + SUBROUTINE helium_write_rdf( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_rdf', & routineP = moduleN//':'//routineN @@ -856,33 +837,32 @@ SUBROUTINE helium_write_rdf( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(logger,print_key) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%RDF", error=error) + "MOTION%PINT%HELIUM%PRINT%RDF") should_output = BTEST(cp_print_key_should_output( & iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) + basis_section=print_key),cp_p_file) IF (should_output) THEN IF (logger%para_env%ionode) THEN unit_nr=cp_print_key_unit_nr(logger,print_key, & middle_name="helium-hst",extension=".dat",& - is_new_file=is_new, error=error) + is_new_file=is_new) IF (.NOT. is_new) THEN WRITE(unit_nr,'(A1)') "&" END IF DO i = 1, helium%rdf_nbin rtmp = ( REAL(i) - 0.5_dp ) * helium%rdf_delr - rtmp = cp_unit_from_cp2k(rtmp, "angstrom", error=error) + rtmp = cp_unit_from_cp2k(rtmp, "angstrom") WRITE(unit_nr,'(2F20.10)') rtmp,& helium%rdf_avrg(i) END DO CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,& - error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF END IF @@ -894,17 +874,15 @@ END SUBROUTINE helium_write_rdf ! *************************************************************************** !> \brief Write helium densities according to HELIUM%PRINT%RHO !> \param helium ... -!> \param error ... !> \date 2011-06-21 !> \par History !> 2011-11-11 output of any number of density estimators to different !> files according to helium%rho_num !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_rho( helium, error ) + SUBROUTINE helium_write_rho( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_rho', & routineP = moduleN//':'//routineN @@ -923,16 +901,16 @@ SUBROUTINE helium_write_rho( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(logger,print_key) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%RHO", error=error) + "MOTION%PINT%HELIUM%PRINT%RHO") should_output = BTEST(cp_print_key_should_output( & iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) + basis_section=print_key),cp_p_file) IF (should_output) THEN ! work on the temporary array so that accumulated data remains intact @@ -945,13 +923,13 @@ SUBROUTINE helium_write_rho( helium, error ) CALL mp_sum(message,logger%para_env%group) END DO itmp = logger%para_env%num_pe - CPPostcondition(itmp>0,cp_failure_level,routineP,error,failure) + CPPostcondition(itmp>0,cp_failure_level,routineP,failure) inv_norm = 1.0_dp / REAL(itmp,dp) helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * inv_norm ! average over steps performed so far in this run nsteps = helium%current_step-helium%first_step - CPPostcondition(nsteps>0,cp_failure_level,routineP,error,failure) + CPPostcondition(nsteps>0,cp_failure_level,routineP,failure) inv_norm = 1.0_dp / REAL(nsteps,dp) helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * inv_norm @@ -966,7 +944,7 @@ SUBROUTINE helium_write_rho( helium, error ) IF (logger%para_env%ionode) THEN N = helium%rho_nbin - rtmp = cp_unit_from_cp2k(helium%rho_delr, "bohr", error=error) + rtmp = cp_unit_from_cp2k(helium%rho_delr, "bohr") r0(:) = helium%origin(:) rx = r0(1) - helium%rho_maxr / 2.0_dp ry = r0(2) - helium%rho_maxr / 2.0_dp @@ -978,7 +956,7 @@ SUBROUTINE helium_write_rho( helium, error ) unit_nr=cp_print_key_unit_nr(logger,print_key, & middle_name="helium-rho-"//TRIM(ADJUSTL(stmp)), & extension=".cube", & - file_position="REWIND", do_backup=.FALSE., error=error) + file_position="REWIND", do_backup=.FALSE.) WRITE(unit_nr,'(A)') "Helium density " // TRIM(ADJUSTL(stmp)) WRITE(unit_nr,'(A)') "CP2K" @@ -1000,8 +978,7 @@ SUBROUTINE helium_write_rho( helium, error ) END DO CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,& - error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END DO @@ -1015,14 +992,12 @@ END SUBROUTINE helium_write_rho ! *************************************************************************** !> \brief Write helium permutation length according to HELIUM%PRINT%PLENGTH !> \param helium ... -!> \param error ... !> \date 2010-06-07 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_plength( helium, error ) + SUBROUTINE helium_write_plength( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_plength', & routineP = moduleN//':'//routineN @@ -1035,21 +1010,21 @@ SUBROUTINE helium_write_plength( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(logger,print_key) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%PLENGTH", error=error) + "MOTION%PINT%HELIUM%PRINT%PLENGTH") should_output = BTEST(cp_print_key_should_output( & iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) + basis_section=print_key),cp_p_file) IF (should_output) THEN IF (logger%para_env%ionode) THEN unit_nr=cp_print_key_unit_nr(logger,print_key, & middle_name="helium-plength",extension=".dat",& - is_new_file=is_new, error=error) + is_new_file=is_new) DO i = 1, helium%atoms WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%plength_avrg(i) @@ -1060,8 +1035,7 @@ SUBROUTINE helium_write_plength( helium, error ) WRITE(unit_nr, '(A)') "" CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,& - error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF END IF @@ -1072,14 +1046,12 @@ END SUBROUTINE helium_write_plength ! *************************************************************************** !> \brief Write helium force according to HELIUM%PRINT%FORCE !> \param helium ... -!> \param error ... !> \date 2010-01-27 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_write_force( helium, error ) + SUBROUTINE helium_write_force( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_force', & routineP = moduleN//':'//routineN @@ -1094,17 +1066,17 @@ SUBROUTINE helium_write_force( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! decide whether to write anything or not NULLIFY(print_key) print_key => section_vals_get_subs_vals( helium%input, & - "MOTION%PINT%HELIUM%PRINT%FORCES", error=error) + "MOTION%PINT%HELIUM%PRINT%FORCES") IF ( .NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN CALL timestop(handle) RETURN END IF @@ -1112,7 +1084,7 @@ SUBROUTINE helium_write_force( helium, error ) ! check if there is anything to be printed out IF ( .NOT. helium%solute_present ) THEN msgstr = "Warning: force printout requested but there is no solute!" - CALL helium_write_line( msgstr, error ) + CALL helium_write_line( msgstr) CALL timestop(handle) RETURN END IF @@ -1121,7 +1093,7 @@ SUBROUTINE helium_write_force( helium, error ) IF (logger%para_env%ionode) THEN unit_nr=cp_print_key_unit_nr(logger, print_key, & - middle_name="helium-force",extension=".dat",error=error) + middle_name="helium-force",extension=".dat") ! print all force components in one line DO ib = 1, helium%solute_beads @@ -1137,7 +1109,7 @@ SUBROUTINE helium_write_force( helium, error ) ! finalize the printout CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF @@ -1148,7 +1120,6 @@ END SUBROUTINE helium_write_force ! *************************************************************************** !> \brief Write instantaneous helium forces !> \param helium ... -!> \param error ... !> \date 2010-01-29 !> \author Lukasz Walewski !> \note Collects instantaneous helium forces from all processors on @@ -1156,10 +1127,9 @@ END SUBROUTINE helium_write_force !> This subroutine does message passing, frequent calls can slow down your !> code significantly. ! ***************************************************************************** - SUBROUTINE helium_write_force_inst( helium, error ) + SUBROUTINE helium_write_force_inst( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_force_inst', & routineP = moduleN//':'//routineN @@ -1174,17 +1144,17 @@ SUBROUTINE helium_write_force_inst( helium, error ) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! decide whether to write anything or not NULLIFY(print_key) print_key => section_vals_get_subs_vals( helium%input, & - "MOTION%PINT%HELIUM%PRINT%FORCES_INST", error=error) + "MOTION%PINT%HELIUM%PRINT%FORCES_INST") IF ( .NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN CALL timestop(handle) RETURN END IF @@ -1192,7 +1162,7 @@ SUBROUTINE helium_write_force_inst( helium, error ) ! check if there is anything to be printed out IF ( .NOT. helium%solute_present ) THEN stmp = "Warning: force printout requested but there is no solute!" - CALL helium_write_line( stmp, error ) + CALL helium_write_line( stmp) CALL timestop(handle) RETURN END IF @@ -1216,7 +1186,7 @@ SUBROUTINE helium_write_force_inst( helium, error ) WRITE(stmp,*) irank my_middle_name = "helium-force-inst-" // TRIM(ADJUSTL(stmp)) unit_nr=cp_print_key_unit_nr( logger, print_key, & - middle_name=TRIM(my_middle_name), extension=".dat", error=error ) + middle_name=TRIM(my_middle_name), extension=".dat") ! unpack and actually print the forces - all components in one line offset = (irank-1) * SIZE(helium%rtmp_p_ndim_1d) @@ -1233,7 +1203,7 @@ SUBROUTINE helium_write_force_inst( helium, error ) ! finalize the printout CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END DO diff --git a/src/hfx_admm_utils.F b/src/hfx_admm_utils.F index 81e35ab094..707b4266fc 100644 --- a/src/hfx_admm_utils.F +++ b/src/hfx_admm_utils.F @@ -97,12 +97,10 @@ MODULE hfx_admm_utils ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE hfx_admm_init(qs_env,error) + SUBROUTINE hfx_admm_init(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_admm_init', & routineP = moduleN//':'//routineN @@ -147,13 +145,12 @@ SUBROUTINE hfx_admm_init(qs_env,error) rho_aux_fit=rho_aux_fit,& ks_env=ks_env,& dft_control=dft_control,& - input=input,& - error=error) + input=input) nspins=dft_control%nspins - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx) !! ** ADMM can only be used with HFX IF ( .NOT. do_hfx ) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& @@ -166,11 +163,11 @@ SUBROUTINE hfx_admm_init(qs_env,error) IF( dft_control%qs_control%gapw ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="ADMM only implemented for GPW", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf,error=error) + CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf) IF ( n_rep_hf > 1 ) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "ADMM can handle only one HF section."//& @@ -180,19 +177,19 @@ SUBROUTINE hfx_admm_init(qs_env,error) IF (.NOT. ASSOCIATED(admm_env)) THEN ! setup admm environment - CALL get_qs_env(qs_env, input=input, particle_set=particle_set, error=error) + CALL get_qs_env(qs_env, input=input, particle_set=particle_set) natoms = SIZE(particle_set,1) CALL admm_env_create(admm_env, dft_control%admm_control, mos, mos_aux_fit, & - para_env, natoms, error) - CALL set_qs_env(qs_env,admm_env=admm_env,error=error) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + para_env, natoms) + CALL set_qs_env(qs_env,admm_env=admm_env) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") CALL create_admm_xc_section(qs_env=qs_env, xc_section=xc_section, & - admm_env=admm_env, error=error) + admm_env=admm_env) ENDIF IF(dft_control%do_admm_dm .AND. .NOT. ASSOCIATED(admm_dm)) THEN CALL admm_dm_create(admm_dm, dft_control%admm_control, nspins=nspins, natoms=natoms) - CALL set_ks_env(ks_env, admm_dm=admm_dm, error=error) + CALL set_ks_env(ks_env, admm_dm=admm_dm) ENDIF CALL timestop(handle) @@ -210,13 +207,12 @@ END SUBROUTINE hfx_admm_init !> \param just_energy ... !> \param v_rspace_new ... !> \param v_tau_rspace ... -!> \param error ... !> \par History !> refactoring 03-2011 [MI] ! ***************************************************************************** SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& - just_energy, v_rspace_new,v_tau_rspace,error) + just_energy, v_rspace_new,v_tau_rspace) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -225,7 +221,6 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces, just_energy TYPE(pw_p_type), DIMENSION(:), POINTER :: v_rspace_new, v_tau_rspace - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_ks_matrix', & routineP = moduleN//':'//routineN @@ -274,55 +269,54 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& matrix_ks_aux_fit=matrix_ks_aux_fit,& matrix_ks_aux_fit_im=matrix_ks_aux_fit_im,& matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx,& - s_mstruct_changed=s_mstruct_changed,& - error=error) + s_mstruct_changed=s_mstruct_changed) nspins=dft_control%nspins nimages=dft_control%nimages use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf,error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF") + CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf) CALL section_vals_val_get(hfx_sections, "TREAT_LSD_IN_CORE", l_val=hfx_treat_lsd_in_core,& - i_rep_section=1,error=error) - adiabatic_rescaling_section => section_vals_get_subs_vals(input,"DFT%XC%ADIABATIC_RESCALING",error=error) - CALL section_vals_get(adiabatic_rescaling_section,explicit=do_adiabatic_rescaling,error=error) + i_rep_section=1) + adiabatic_rescaling_section => section_vals_get_subs_vals(input,"DFT%XC%ADIABATIC_RESCALING") + CALL section_vals_get(adiabatic_rescaling_section,explicit=do_adiabatic_rescaling) ! *** Initialize the auxiliary ks matrix to zero if required IF( dft_control%do_admm ) THEN DO ispin = 1,nspins - CALL cp_dbcsr_set(matrix_ks_aux_fit(ispin)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_ks_aux_fit_hfx(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ks_aux_fit(ispin)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_ks_aux_fit_hfx(ispin)%matrix,0.0_dp) END DO END IF DO ispin = 1,nspins DO img=1,nimages - CALL cp_dbcsr_set(matrix_ks(ispin,img)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ks(ispin,img)%matrix,0.0_dp) END DO END DO - CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf,error=error) + CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf) !! set hf exchange energy to zero energy%ex = 0.0_dp IF( calculate_forces ) THEN !! initalize force array to zero - CALL get_qs_env(qs_env=qs_env, force=force, error=error) + CALL get_qs_env(qs_env=qs_env, force=force) DO ikind = 1,SIZE(force) force(ikind)%fock_4c(:,:) = 0.0_dp END DO END IF ALLOCATE(hf_energy(n_rep_hf), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO irep = 1,n_rep_hf IF( do_adiabatic_rescaling .AND. hfx_treat_lsd_in_core)& CALL cp_unimplemented_error(fromWhere=routineP, & message="HFX_TREAT_LSD_IN_CORE not implemented for adiabatically rescaled hybrids",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ! everything is calulated with adiabatic rescaling but the potential is not added in a first step distribute_fock_matrix=.NOT.do_adiabatic_rescaling @@ -332,30 +326,30 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& ! fetch the correct matrices for normal HFX or ADMM IF( dft_control%do_admm ) THEN CALL get_qs_env(qs_env=qs_env,matrix_ks_aux_fit=matrix_ks_1d,& - rho_aux_fit=rho_orb,error=error) + rho_aux_fit=rho_orb) ns = SIZE(matrix_ks_1d) matrix_ks_orb(1:ns,1:1) => matrix_ks_1d(1:ns) ELSE - CALL get_qs_env(qs_env=qs_env,matrix_ks_kp=matrix_ks_orb,rho=rho_orb,error=error) + CALL get_qs_env(qs_env=qs_env,matrix_ks_kp=matrix_ks_orb,rho=rho_orb) END IF - CALL qs_rho_get(rho_struct=rho_orb,rho_ao_kp=rho_ao_orb,error=error) + CALL qs_rho_get(rho_struct=rho_orb,rho_ao_kp=rho_ao_orb) ! Finally the real hfx calulation DO ispin = 1,mspin CALL integrate_four_center(qs_env,matrix_ks_orb,energy,rho_ao_orb,hfx_sections,& para_env,s_mstruct_changed,irep,distribute_fock_matrix,& - ispin=ispin,error=error) + ispin=ispin) END DO IF( calculate_forces .AND. .NOT. do_adiabatic_rescaling ) THEN !Scale auxiliary density matrix for ADMMP (see Merlot2014) with gsi(ispin) to scale force IF( dft_control%do_admm ) THEN - CALL scale_dm(qs_env, rho_ao_orb,scale_back=.FALSE.,error=error) + CALL scale_dm(qs_env, rho_ao_orb,scale_back=.FALSE.) END IF CALL derivatives_four_center(qs_env,rho_ao_orb,hfx_sections, & - para_env,irep,use_virial,error=error) + para_env,irep,use_virial) !Scale auxiliary density matrix for ADMMP back with 1/gsi(ispin) IF( dft_control%do_admm ) THEN - CALL scale_dm(qs_env, rho_ao_orb, scale_back=.TRUE., error=error) + CALL scale_dm(qs_env, rho_ao_orb, scale_back=.TRUE.) END IF END IF @@ -365,16 +359,16 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& ! special case RTP/EMD we have a full complex density and HFX has a contrinution from the imaginary part IF( qs_env%run_rtp)THEN - CALL get_qs_env(qs_env=qs_env,rtp=rtp,error=error) + CALL get_qs_env(qs_env=qs_env,rtp=rtp) DO ispin = 1,nspins - CALL cp_dbcsr_set(matrix_ks_im(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ks_im(ispin)%matrix,0.0_dp) END DO IF( dft_control%do_admm ) THEN ! matrix_ks_orb => matrix_ks_aux_fit_im ns = SIZE(matrix_ks_aux_fit_im) matrix_ks_orb(1:ns,1:1) => matrix_ks_aux_fit_im(1:ns) DO ispin = 1,nspins - CALL cp_dbcsr_set(matrix_ks_aux_fit_im(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ks_aux_fit_im(ispin)%matrix,0.0_dp) END DO ELSE ! matrix_ks_orb => matrix_ks_im @@ -382,19 +376,19 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& matrix_ks_orb(1:ns,1:1) => matrix_ks_im(1:ns) END IF - CALL qs_rho_get(rho_orb, rho_ao_im=rho_ao_1d, error=error) + CALL qs_rho_get(rho_orb, rho_ao_im=rho_ao_1d) ns = SIZE(rho_ao_1d) rho_ao_orb(1:ns,1:1) => rho_ao_1d(1:ns) DO ispin = 1,mspin CALL integrate_four_center(qs_env, matrix_ks_orb ,energy,rho_ao_orb,hfx_sections,& para_env, .FALSE., irep, distribute_fock_matrix,& - ispin=ispin, error=error) + ispin=ispin) END DO IF( calculate_forces .AND. .NOT. do_adiabatic_rescaling ) THEN CALL derivatives_four_center(qs_env, rho_ao_orb, hfx_sections, & - para_env, irep, use_virial, error=error) + para_env, irep, use_virial) END IF !! If required, the calculation of the forces will be done later with adiabatic rescaling @@ -402,8 +396,8 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& END IF CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env,error=error) - CALL pw_hfx(qs_env,energy,hfx_sections,poisson_env,auxbas_pw_pool,irep,error) + poisson_env=poisson_env) + CALL pw_hfx(qs_env,energy,hfx_sections,poisson_env,auxbas_pw_pool,irep) END DO @@ -411,7 +405,7 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& DO ispin=1,nspins DO img=1,nimages CALL cp_dbcsr_add(matrix_ks(ispin,img)%matrix,matrix_h(1,img)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) END DO END DO IF (use_virial .AND. calculate_forces) THEN @@ -422,7 +416,7 @@ SUBROUTINE hfx_ks_matrix(qs_env,matrix_ks,rho,energy,calculate_forces,& !! If we perform adiabatic rescaling we are now able to rescale the xc-potential IF( do_adiabatic_rescaling ) THEN CALL rescale_xc_potential(qs_env,matrix_ks,rho,energy,v_rspace_new,v_tau_rspace,& - hf_energy, just_energy,calculate_forces,use_virial,error=error) + hf_energy, just_energy,calculate_forces,use_virial) END IF ! do_adiabatic_rescaling CALL timestop(handle) @@ -437,20 +431,18 @@ END SUBROUTINE hfx_ks_matrix !> \param poisson_env ... !> \param auxbas_pw_pool ... !> \param irep ... -!> \param error ... !> \par History !> 12.2007 created [Joost VandeVondele] !> \note !> only computes the HFX energy, no derivatives as yet ! ***************************************************************************** - SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,error) + SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_energy_type), POINTER :: energy TYPE(section_vals_type), POINTER :: hfx_section TYPE(pw_poisson_type), POINTER :: poisson_env TYPE(pw_pool_type), POINTER :: auxbas_pw_pool INTEGER :: irep - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'pw_hfx', & routineP = moduleN//':'//routineN @@ -481,32 +473,32 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL section_vals_val_get(hfx_section, "PW_HFX", l_val=do_pw_hfx, i_rep_section=irep, error=error) + CALL section_vals_val_get(hfx_section, "PW_HFX", l_val=do_pw_hfx, i_rep_section=irep) IF (do_pw_hfx) THEN - CALL section_vals_val_get(hfx_section, "FRACTION", r_val=fraction, error=error) - CALL section_vals_val_get(hfx_section, "PW_HFX_BLOCKSIZE", i_val=blocksize, error=error) + CALL section_vals_val_get(hfx_section, "FRACTION", r_val=fraction) + CALL section_vals_val_get(hfx_section, "PW_HFX_BLOCKSIZE", i_val=blocksize) CALL get_qs_env(qs_env,mos=mo_array,pw_env=pw_env, dft_control=dft_control, & cell=cell, particle_set=particle_set, & - atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set, error=error) + atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set) ! limit the blocksize by the number of orbitals CALL get_mo_set(mo_set=mo_array(1)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=norb,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=norb) blocksize=MAX(1,MIN(blocksize,norb)) CALL pw_pool_create_pw(auxbas_pw_pool,rho_r%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,rho_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,pot_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) ALLOCATE(rho_i(blocksize)) ALLOCATE(rho_j(blocksize)) @@ -515,11 +507,11 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro NULLIFY(rho_i(iorb_block)%pw) CALL pw_create(rho_i(iorb_block)%pw,rho_r%pw%pw_grid,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) NULLIFY(rho_j(iorb_block)%pw) CALL pw_create(rho_j(iorb_block)%pw,rho_r%pw%pw_grid,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) ENDDO exchange_energy = 0.0_dp @@ -528,10 +520,10 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,mo_coeff=mo_coeff,mo_coeff_b=mo_coeff_b) IF(mo_array(ispin)%mo_set%use_mo_coeff_b) THEN!fm->dbcsr - CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff,error=error)!fm->dbcsr + CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff)!fm->dbcsr ENDIF!fm->dbcsr - CALL cp_fm_get_info(mo_coeff,ncol_global=norb,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=norb) DO iorb_block=1,norb,blocksize @@ -540,7 +532,7 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro iloc=iorb-iorb_block+1 CALL calculate_wavefunction(mo_coeff,iorb,rho_i(iloc),rho_g, & atomic_kind_set,qs_kind_set, cell,dft_control,particle_set, & - pw_env,error=error) + pw_env) ENDDO @@ -551,7 +543,7 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro jloc=jorb-jorb_block+1 CALL calculate_wavefunction(mo_coeff,jorb,rho_j(jloc),rho_g, & atomic_kind_set,qs_kind_set, cell,dft_control,particle_set, & - pw_env,error=error) + pw_env) ENDDO @@ -565,8 +557,8 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro rho_r%pw%cr3d = rho_i(iloc)%pw%cr3d * rho_j(jloc)%pw%cr3d ! go the g-space and compute hartree energy - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) ! sum up to the full energy scaling=fraction @@ -583,16 +575,16 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro ENDDO DO iorb_block=1,blocksize - CALL pw_release(rho_i(iorb_block)%pw,error=error) - CALL pw_release(rho_j(iorb_block)%pw,error=error) + CALL pw_release(rho_i(iorb_block)%pw) + CALL pw_release(rho_j(iorb_block)%pw) ENDDO - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw) iw = cp_print_key_unit_nr(logger,hfx_section,"HF_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE (UNIT=iw,FMT="((T3,A,T61,F20.10))")& @@ -602,7 +594,7 @@ SUBROUTINE pw_hfx(qs_env,energy,hfx_section,poisson_env,auxbas_pw_pool,irep,erro ENDIF CALL cp_print_key_finished_output(iw,logger,hfx_section,& - "HF_INFO", error=error) + "HF_INFO") ENDIF @@ -631,17 +623,14 @@ END SUBROUTINE pw_hfx !> \param qs_env the qs environment !> \param xc_section the original xc_section !> \param admm_env the ADMM environment -!> \param error ... -!> !> \par History !> 12.2009 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) + SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: xc_section TYPE(admm_type), POINTER :: admm_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_admm_xc_section', & routineP = moduleN//':'//routineN @@ -658,34 +647,34 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) failure=.FALSE. - CALL get_qs_env(qs_env, error=error) + CALL get_qs_env(qs_env) !! ** Duplicate existing xc-section - CALL section_vals_duplicate(xc_section,admm_env%xc_section_aux,error=error) - CALL section_vals_duplicate(xc_section,admm_env%xc_section_primary,error=error) + CALL section_vals_duplicate(xc_section,admm_env%xc_section_aux) + CALL section_vals_duplicate(xc_section,admm_env%xc_section_primary) !** Now modify the auxiliary basis !** First remove all functionals - xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_aux,"XC_FUNCTIONAL",error=error) + xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_aux,"XC_FUNCTIONAL") !* Overwrite possible shortcut CALL section_vals_val_set(xc_fun_section,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) !** Get number of Functionals in the list ifun = 0 nfun = 0 DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT nfun = nfun + 1 END DO ifun = 0 DO ifun = 1,nfun - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=1,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=1) IF (.NOT.ASSOCIATED(xc_fun)) EXIT - CALL section_vals_remove_values(xc_fun, error=error) + CALL section_vals_remove_values(xc_fun) END DO hfx_potential_type = qs_env%x_data(1,1)%potential_parameter%potential_type @@ -704,44 +693,44 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) SELECT CASE (hfx_potential_type) CASE (do_hfx_potential_coulomb) CALL section_vals_val_set(xc_fun_section,"PBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"PBE%SCALE_X",& - r_val=-hfx_fraction,error=error) + r_val=-hfx_fraction) CALL section_vals_val_set(xc_fun_section,"PBE%SCALE_C",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) CASE (do_hfx_potential_short) omega = qs_env%x_data(1,1)%potential_parameter%omega CALL section_vals_val_set(xc_fun_section,"XWPBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X",& - r_val=-hfx_fraction,error=error) + r_val=-hfx_fraction) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X0",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) CALL section_vals_val_set(xc_fun_section,"XWPBE%OMEGA",& - r_val=omega,error=error) + r_val=omega) CASE (do_hfx_potential_truncated) cutoff_radius = qs_env%x_data(1,1)%potential_parameter%cutoff_radius CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%SCALE_X",& - r_val=hfx_fraction,error=error) + r_val=hfx_fraction) CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%CUTOFF_RADIUS",& - r_val=cutoff_radius,error=error) + r_val=cutoff_radius) CALL section_vals_val_set(xc_fun_section,"XWPBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X0",& - r_val=-hfx_fraction,error=error) + r_val=-hfx_fraction) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT !** Now modify the functionals for the primary basis - xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_primary,"XC_FUNCTIONAL",error=error) + xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_primary,"XC_FUNCTIONAL") !* Overwrite possible shortcut CALL section_vals_val_set(xc_fun_section,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) SELECT CASE (hfx_potential_type) CASE (do_hfx_potential_coulomb) @@ -749,7 +738,7 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) funct_found = .FALSE. DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT IF( xc_fun%section%name == "PBE" ) THEN funct_found = .TRUE. @@ -757,17 +746,17 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) END DO IF( .NOT. funct_found ) THEN CALL section_vals_val_set(xc_fun_section,"PBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"PBE%SCALE_X",& - r_val=hfx_fraction,error=error) + r_val=hfx_fraction) CALL section_vals_val_set(xc_fun_section,"PBE%SCALE_C",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) ELSE CALL section_vals_val_get(xc_fun_section,"PBE%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) scale_x = scale_x + hfx_fraction CALL section_vals_val_set(xc_fun_section,"PBE%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) END IF CASE (do_hfx_potential_short) omega = qs_env%x_data(1,1)%potential_parameter%omega @@ -775,7 +764,7 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) funct_found = .FALSE. DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT IF( xc_fun%section%name == "XWPBE" ) THEN funct_found = .TRUE. @@ -783,19 +772,19 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) END DO IF( .NOT. funct_found ) THEN CALL section_vals_val_set(xc_fun_section,"XWPBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X",& - r_val=hfx_fraction,error=error) + r_val=hfx_fraction) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X0",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) CALL section_vals_val_set(xc_fun_section,"XWPBE%OMEGA",& - r_val=omega,error=error) + r_val=omega) ELSE CALL section_vals_val_get(xc_fun_section,"XWPBE%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) scale_x = scale_x + hfx_fraction CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) END IF CASE (do_hfx_potential_truncated) cutoff_radius = qs_env%x_data(1,1)%potential_parameter%cutoff_radius @@ -803,7 +792,7 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) funct_found = .FALSE. DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT IF( xc_fun%section%name == "PBE_HOLE_T_C_LR" ) THEN funct_found = .TRUE. @@ -811,26 +800,26 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) END DO IF( .NOT. funct_found ) THEN CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%SCALE_X",& - r_val=-hfx_fraction,error=error) + r_val=-hfx_fraction) CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%CUTOFF_RADIUS",& - r_val=cutoff_radius,error=error) + r_val=cutoff_radius) ELSE CALL section_vals_val_get(xc_fun_section,"PBE_HOLE_T_C_LR%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) scale_x = scale_x - hfx_fraction CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) CALL section_vals_val_set(xc_fun_section,"PBE_HOLE_T_C_LR%CUTOFF_RADIUS",& - r_val=cutoff_radius,error=error) + r_val=cutoff_radius) END IF ifun = 0 funct_found = .FALSE. DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT IF( xc_fun%section%name == "XWPBE" ) THEN funct_found = .TRUE. @@ -838,18 +827,18 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) END DO IF( .NOT. funct_found ) THEN CALL section_vals_val_set(xc_fun_section,"XWPBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X0",& - r_val=hfx_fraction,error=error) + r_val=hfx_fraction) CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) ELSE CALL section_vals_val_get(xc_fun_section,"XWPBE%SCALE_X0",& - r_val=scale_x,error=error) + r_val=scale_x) scale_x = scale_x + hfx_fraction CALL section_vals_val_set(xc_fun_section,"XWPBE%SCALE_X0",& - r_val=scale_x,error=error) + r_val=scale_x) END IF END SELECT @@ -867,27 +856,27 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) END IF !primary basis CALL section_vals_val_set(xc_fun_section, TRIM(name_x_func) // "%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,TRIM(name_x_func) //"%SCALE_X",& - r_val=-hfx_fraction,error=error) + r_val=-hfx_fraction) IF(admm_env%aux_exch_func== do_admm_aux_exch_func_pbex) THEN CALL section_vals_val_set(xc_fun_section,TRIM(name_x_func) //"%SCALE_C",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) END IF !** Now modify the functionals for the primary basis - xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_primary,"XC_FUNCTIONAL",error=error) - !* Overwrite possible L",error=error) + xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_primary,"XC_FUNCTIONAL") + !* Overwrite possible L") !* Overwrite possible shortcut CALL section_vals_val_set(xc_fun_section,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) ifun = 0 funct_found = .FALSE. DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT IF( xc_fun%section%name == TRIM(name_x_func) ) THEN funct_found = .TRUE. @@ -895,21 +884,21 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) END DO IF( .NOT. funct_found ) THEN CALL section_vals_val_set(xc_fun_section,TRIM(name_x_func)//"%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(xc_fun_section,TRIM(name_x_func)//"%SCALE_X",& - r_val=hfx_fraction,error=error) + r_val=hfx_fraction) IF(admm_env%aux_exch_func== do_admm_aux_exch_func_pbex) THEN CALL section_vals_val_set(xc_fun_section,TRIM(name_x_func) //"%SCALE_C",& - r_val=0.0_dp,error=error) + r_val=0.0_dp) END IF ELSE CALL section_vals_val_get(xc_fun_section,TRIM(name_x_func)//"%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) scale_x = scale_x + hfx_fraction CALL section_vals_val_set(xc_fun_section,TRIM(name_x_func)//"%SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) END IF @@ -921,22 +910,22 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) IF( 1==0 ) THEN WRITE(*,*) "primary" - xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_primary,"XC_FUNCTIONAL",error=error) + xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_primary,"XC_FUNCTIONAL") ifun = 0 funct_found = .FALSE. DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT scale_x=-1000.0_dp IF(xc_fun%section%name /= "LYP" .AND. xc_fun%section%name /= "VWN") THEN CALL section_vals_val_get(xc_fun,"SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) END IF IF( xc_fun%section%name == "XWPBE" ) THEN CALL section_vals_val_get(xc_fun,"SCALE_X0",& - r_val=hfx_fraction,error=error) + r_val=hfx_fraction) WRITE(*,*) xc_fun%section%name, scale_x, hfx_fraction ELSE @@ -945,21 +934,21 @@ SUBROUTINE create_admm_xc_section(qs_env, xc_section, admm_env, error) END DO WRITE(*,*) "auxiliary" - xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_aux,"XC_FUNCTIONAL",error=error) + xc_fun_section => section_vals_get_subs_vals(admm_env%xc_section_aux,"XC_FUNCTIONAL") ifun = 0 funct_found = .FALSE. DO ifun = ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT scale_x=-1000.0_dp IF(xc_fun%section%name /= "LYP" .AND. xc_fun%section%name /= "VWN") THEN CALL section_vals_val_get(xc_fun,"SCALE_X",& - r_val=scale_x,error=error) + r_val=scale_x) END IF IF( xc_fun%section%name == "XWPBE" ) THEN CALL section_vals_val_get(xc_fun,"SCALE_X0",& - r_val=hfx_fraction,error=error) + r_val=hfx_fraction) WRITE(*,*) xc_fun%section%name, scale_x, hfx_fraction ELSE diff --git a/src/hfx_communication.F b/src/hfx_communication.F index 9bcb18c220..a2e3fc2f1b 100644 --- a/src/hfx_communication.F +++ b/src/hfx_communication.F @@ -64,8 +64,6 @@ MODULE hfx_communication !> \param get_max_vals_spin ... !> \param rho_beta ... !> \param antisymmetric ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -77,7 +75,7 @@ MODULE hfx_communication ! ***************************************************************************** SUBROUTINE get_full_density(para_env, full_density, rho, number_of_p_entries, & block_offset, kind_of, basis_parameter,& - get_max_vals_spin, rho_beta, antisymmetric, error) + get_max_vals_spin, rho_beta, antisymmetric) TYPE(cp_para_env_type), POINTER :: para_env REAL(dp), DIMENSION(:) :: full_density @@ -90,7 +88,6 @@ SUBROUTINE get_full_density(para_env, full_density, rho, number_of_p_entries, & LOGICAL, INTENT(IN) :: get_max_vals_spin TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: rho_beta LOGICAL, INTENT(IN) :: antisymmetric - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_full_density', & routineP = moduleN//':'//routineN @@ -113,9 +110,9 @@ SUBROUTINE get_full_density(para_env, full_density, rho, number_of_p_entries, & full_density = 0.0_dp ALLOCATE(sendbuffer(number_of_p_entries),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(recbuffer(number_of_p_entries),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) i=1 CALL cp_dbcsr_iterator_start(iter, rho, shared=.FALSE.) @@ -191,7 +188,7 @@ SUBROUTINE get_full_density(para_env, full_density, rho, number_of_p_entries, & recbuffer=>swapbuffer ENDDO DEALLOCATE(sendbuffer, recbuffer, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! sync before/after a ring of isendrecv CALL mp_sync(para_env%group) @@ -208,8 +205,6 @@ END SUBROUTINE get_full_density !> \param basis_parameter ... !> \param off_diag_fac ... !> \param diag_fac ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -218,7 +213,7 @@ END SUBROUTINE get_full_density ! ***************************************************************************** SUBROUTINE distribute_ks_matrix(para_env, full_ks, ks_matrix, number_of_p_entries, & block_offset, kind_of, basis_parameter, & - off_diag_fac, diag_fac, error) + off_diag_fac, diag_fac) TYPE(cp_para_env_type), POINTER :: para_env REAL(dp), DIMENSION(:) :: full_ks @@ -229,7 +224,6 @@ SUBROUTINE distribute_ks_matrix(para_env, full_ks, ks_matrix, number_of_p_entrie TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: basis_parameter REAL(dp), INTENT(IN), OPTIONAL :: off_diag_fac, diag_fac - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'distribute_ks_matrix', & routineP = moduleN//':'//routineN @@ -250,10 +244,10 @@ SUBROUTINE distribute_ks_matrix(para_env, full_ks, ks_matrix, number_of_p_entrie IF( PRESENT( diag_fac ) ) myd_fac = diag_fac ALLOCATE(sendbuffer(number_of_p_entries), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) sendbuffer =0.0_dp ALLOCATE(recbuffer(number_of_p_entries), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) recbuffer =0.0_dp ncpu = para_env%num_pe @@ -314,7 +308,7 @@ SUBROUTINE distribute_ks_matrix(para_env, full_ks, ks_matrix, number_of_p_entrie CALL cp_dbcsr_iterator_stop(iter) DEALLOCATE(sendbuffer, recbuffer, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE distribute_ks_matrix @@ -327,8 +321,6 @@ END SUBROUTINE distribute_ks_matrix !> \param ks_matrix Distributed Kohn-Sham matrix !> \param irep ... !> \param scaling_factor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -336,7 +328,7 @@ END SUBROUTINE distribute_ks_matrix !> - Communication with left/right node only ! ***************************************************************************** SUBROUTINE scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, irep ,& - scaling_factor, error) + scaling_factor) TYPE(cp_para_env_type), POINTER :: para_env TYPE(qs_environment_type), POINTER :: qs_env @@ -344,7 +336,6 @@ SUBROUTINE scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, irep ,& POINTER :: ks_matrix INTEGER, INTENT(IN) :: irep REAL(dp), INTENT(IN) :: scaling_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'scale_and_add_fock_to_ks_matrix', & @@ -373,22 +364,21 @@ SUBROUTINE scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, irep ,& CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& particle_set=particle_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) nspins = dft_control%nspins nimages = dft_control%nimages - CPPrecondition(nimages==1,cp_failure_level,routineP,error,failure) + CPPrecondition(nimages==1,cp_failure_level,routineP,failure) natom = SIZE(particle_set,1) ALLOCATE(kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& kind_of=kind_of) ALLOCATE(last_sgf_global(0:natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_sgf_global(0)=0 DO iatom=1,natom ikind = kind_of(iatom) @@ -401,10 +391,10 @@ SUBROUTINE scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, irep ,& DO img=1,nimages CALL distribute_ks_matrix(para_env, full_ks(:,img), ks_matrix(1,img)%matrix, actual_x_data%number_of_p_entries, & actual_x_data%block_offset, kind_of, basis_parameter, & - off_diag_fac=0.5_dp,error=error) + off_diag_fac=0.5_dp) END DO DEALLOCATE(actual_x_data%full_ks_alpha, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(nspins == 2) THEN full_ks => actual_x_data%full_ks_beta @@ -414,14 +404,14 @@ SUBROUTINE scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, irep ,& DO img=1,nimages CALL distribute_ks_matrix(para_env, full_ks(:,img), ks_matrix(2,img)%matrix, actual_x_data%number_of_p_entries, & actual_x_data%block_offset, kind_of, basis_parameter, & - off_diag_fac=0.5_dp,error=error) + off_diag_fac=0.5_dp) END DO DEALLOCATE(actual_x_data%full_ks_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(kind_of, last_sgf_global, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE scale_and_add_fock_to_ks_matrix @@ -463,7 +453,6 @@ END FUNCTION get_1D_idx !> \param block_offset ... !> \param map_atoms_to_cpus ... !> \param nkind ... -!> \param error ... !> \par History !> 11.2007 refactored [Joost VandeVondele] !> 07.2009 add new maps @@ -475,7 +464,7 @@ END FUNCTION get_1D_idx SUBROUTINE get_atomic_block_maps(matrix,basis_parameter,kind_of,& is_assoc_atomic_block,number_of_p_entries,& para_env,atomic_block_offset, set_offset, & - block_offset, map_atoms_to_cpus, nkind, error) + block_offset, map_atoms_to_cpus, nkind) TYPE(cp_dbcsr_type), POINTER :: matrix TYPE(hfx_basis_type), DIMENSION(:) :: basis_parameter @@ -488,7 +477,6 @@ SUBROUTINE get_atomic_block_maps(matrix,basis_parameter,kind_of,& INTEGER, DIMENSION(:), POINTER :: block_offset TYPE(hfx_2D_map), DIMENSION(:), POINTER :: map_atoms_to_cpus INTEGER :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_atomic_block_maps', & routineP = moduleN//':'//routineN @@ -535,11 +523,11 @@ SUBROUTINE get_atomic_block_maps(matrix,basis_parameter,kind_of,& ! pack all data in buffers and use allgatherv ! ALLOCATE(buffer_in(3*number_of_p_blocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(buffer_out(3*number_of_p_blocks*para_env%num_pe),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rcount(para_env%num_pe),rdispl(para_env%num_pe),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_in=0 ibuf=0 @@ -584,9 +572,9 @@ SUBROUTINE get_atomic_block_maps(matrix,basis_parameter,kind_of,& natom = SIZE(is_assoc_atomic_block,1) ALLOCATE(map_atoms_to_cpus(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(counter(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter = 0 DO iatom=1,natom @@ -597,9 +585,9 @@ SUBROUTINE get_atomic_block_maps(matrix,basis_parameter,kind_of,& END DO DO icpu = 1,para_env%num_pe ALLOCATE(map_atoms_to_cpus(icpu)%iatom_list(counter(icpu)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_atoms_to_cpus(icpu)%jatom_list(counter(icpu)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO counter = 0 DO iatom=1,natom @@ -614,7 +602,7 @@ SUBROUTINE get_atomic_block_maps(matrix,basis_parameter,kind_of,& END DO DEALLOCATE(counter, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ncpu = para_env%num_pe offset = 1 diff --git a/src/hfx_compression_methods.F b/src/hfx_compression_methods.F index c7e3b9a737..79dc05756e 100644 --- a/src/hfx_compression_methods.F +++ b/src/hfx_compression_methods.F @@ -65,14 +65,12 @@ MODULE hfx_compression_methods !> \param memory_usage ... !> \param use_disk_storage ... !> \param max_val_memory ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE hfx_add_single_cache_element(value, nbits, cache, container, memory_usage, use_disk_storage, & - max_val_memory, error) + max_val_memory) INTEGER(int_8) :: value INTEGER :: nbits TYPE(hfx_cache_type) :: cache @@ -80,7 +78,6 @@ SUBROUTINE hfx_add_single_cache_element(value, nbits, cache, container, memory_u INTEGER :: memory_usage LOGICAL :: use_disk_storage INTEGER(int_8), OPTIONAL :: max_val_memory - TYPE(cp_error_type), INTENT(inout) :: error INTEGER(int_8) :: int_val @@ -92,7 +89,7 @@ SUBROUTINE hfx_add_single_cache_element(value, nbits, cache, container, memory_u ELSE cache%data(CACHE_SIZE) = int_val CALL hfx_compress_cache(cache%data(1), container, nbits, memory_usage, use_disk_storage, & - max_val_memory, error) + max_val_memory) cache%element_counter = 1 END IF END SUBROUTINE hfx_add_single_cache_element @@ -106,21 +103,18 @@ END SUBROUTINE hfx_add_single_cache_element !> \param memory_usage ... !> \param use_disk_storage ... !> \param max_val_memory ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE hfx_compress_cache(full_array, container, nbits, memory_usage, use_disk_storage, & - max_val_memory, error) + max_val_memory) INTEGER(int_8) :: full_array(*) TYPE(hfx_container_type) :: container INTEGER, INTENT(IN) :: nbits INTEGER :: memory_usage LOGICAL :: use_disk_storage INTEGER(int_8), OPTIONAL :: max_val_memory - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_compress_cache', & routineP = moduleN//':'//routineN @@ -152,7 +146,7 @@ SUBROUTINE hfx_compress_cache(full_array, container, nbits, memory_usage, use_di ELSE !! Allocate new list entry ALLOCATE(container%current%next, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP ATOMIC memory_usage = memory_usage + 1 container%current%next%next => NULL() @@ -315,22 +309,18 @@ END SUBROUTINE hfx_decompress_first_cache !> \param container container that contains the compressed elements !> \param memory_usage ... !> \param use_disk_storage ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE hfx_flush_last_cache(nbits, cache, container, memory_usage, use_disk_storage, error) + SUBROUTINE hfx_flush_last_cache(nbits, cache, container, memory_usage, use_disk_storage) INTEGER :: nbits TYPE(hfx_cache_type) :: cache TYPE(hfx_container_type) :: container INTEGER :: memory_usage LOGICAL :: use_disk_storage - TYPE(cp_error_type), INTENT(inout) :: error - CALL hfx_compress_cache(cache%data(1), container, nbits, memory_usage, use_disk_storage, & - error=error) + CALL hfx_compress_cache(cache%data(1), container, nbits, memory_usage, use_disk_storage) !!If we store to file, we have to make sure, that the last container is also written to disk IF( use_disk_storage ) THEN @@ -354,14 +344,12 @@ END SUBROUTINE hfx_flush_last_cache !> \param pmax_entry ... !> \param memory_usage ... !> \param use_disk_storage ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE hfx_add_mult_cache_elements(values, nints, nbits, cache, container, eps_schwarz, pmax_entry, memory_usage, & - use_disk_storage, error) + use_disk_storage) REAL(dp) :: values(*) INTEGER, INTENT(IN) :: nints, nbits TYPE(hfx_cache_type) :: cache @@ -369,7 +357,6 @@ SUBROUTINE hfx_add_mult_cache_elements(values, nints, nbits, cache, container, e REAL(dp), INTENT(IN) :: eps_schwarz, pmax_entry INTEGER :: memory_usage LOGICAL :: use_disk_storage - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: end_idx, i, start_idx, & tmp_elements @@ -409,8 +396,7 @@ SUBROUTINE hfx_add_mult_cache_elements(values, nints, nbits, cache, container, e cache%data(i+start_idx-1) = shift END IF END DO - CALL hfx_compress_cache(cache%data(1), container, nbits, memory_usage, use_disk_storage, & - error=error) + CALL hfx_compress_cache(cache%data(1), container, nbits, memory_usage, use_disk_storage) DO i=tmp_elements+1, nints values(i) = values(i)*pmax_entry IF(ABS(values(i)) > eps_schwarz) THEN diff --git a/src/hfx_derivatives.F b/src/hfx_derivatives.F index 9bfd6de8a3..705c4ab8ff 100644 --- a/src/hfx_derivatives.F +++ b/src/hfx_derivatives.F @@ -103,8 +103,6 @@ MODULE hfx_derivatives !> \param irep ID of HFX replica !> \param use_virial ... !> \param adiabatic_rescale_factor parameter used for MCY3 hybrid -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2007 created [Manuel Guidon] !> 08.2007 optimized load balance [Manuel Guidon] @@ -112,7 +110,7 @@ MODULE hfx_derivatives !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & - irep, use_virial, adiabatic_rescale_factor, error) + irep, use_virial, adiabatic_rescale_factor) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -122,7 +120,6 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & INTEGER :: irep LOGICAL :: use_virial REAL(dp), INTENT(IN), OPTIONAL :: adiabatic_rescale_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'derivatives_four_center', & routineP = moduleN//':'//routineN @@ -253,7 +250,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & with_mp2_density=.FALSE. IF(ASSOCIATED(qs_env%mp2_env)) with_mp2_density=.TRUE. - IF(with_mp2_density) CALL get_qs_env(qs_env, matrix_p_mp2=rho_ao_mp2, error=error) + IF(with_mp2_density) CALL get_qs_env(qs_env, matrix_p_mp2=rho_ao_mp2) is_anti_symmetric=cp_dbcsr_get_matrix_type(rho_ao(1,1)%matrix).EQ.dbcsr_type_antisymmetric CALL get_qs_env(qs_env,& @@ -261,12 +258,11 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & particle_set=particle_set,& atomic_kind_set=atomic_kind_set,& cell=cell,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) nspins = dft_control%nspins nkimages = dft_control%nimages - CPPostcondition(nkimages==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nkimages==1,cp_failure_level,routineP,failure) cell_loop_info%dokp = .FALSE. !! One atom systems have no contribution to forces @@ -306,7 +302,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & !! get force array - CALL get_qs_env(qs_env=qs_env, force=force, virial=virial, error=error) + CALL get_qs_env(qs_env=qs_env, force=force, virial=virial) my_adiabatic_rescale_factor = 1.0_dp IF(PRESENT(adiabatic_rescale_factor)) THEN @@ -322,7 +318,6 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & !$OMP cell_loop_info,& !$OMP para_env,& !$OMP irep,& -!$OMP error,& !$OMP ncoset,& !$OMP nco,& !$OMP nso,& @@ -430,8 +425,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) max_set = basis_info%max_set max_am = basis_info%max_am @@ -460,16 +454,16 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & !! Get screening parameter ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind,& kind_of=kind_of) !! Create helper arrray for mapping local basis functions to global ones ALLOCATE(last_sgf_global(0:natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_sgf_global(0)=0 DO iatom=1,natom ikind = kind_of(iatom) @@ -477,7 +471,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & END DO ALLOCATE(max_contraction(max_set,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_contraction=0.0_dp max_pgf = 0 @@ -527,7 +521,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & NULLIFY(full_density_alpha) NULLIFY(full_density_beta) ALLOCATE(full_density_alpha(shm_block_offset(ncpu+1),nkimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !! Get the full density from all the processors @@ -535,34 +529,34 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & CALL get_full_density(para_env, full_density_alpha(:,1), rho_ao(1,1)%matrix, shm_number_of_p_entries,& shm_block_offset,& kind_of, basis_parameter, get_max_vals_spin=.FALSE.,& - antisymmetric=is_anti_symmetric,error=error) + antisymmetric=is_anti_symmetric) ! for now only closed shell case IF(with_mp2_density) THEN NULLIFY(full_density_mp2) ALLOCATE(full_density_mp2(shm_block_offset(ncpu+1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_full_density(para_env, full_density_mp2, rho_ao_mp2(1)%matrix, shm_number_of_p_entries,& shm_block_offset,& kind_of, basis_parameter, get_max_vals_spin=.FALSE.,& - antisymmetric=is_anti_symmetric,error=error) + antisymmetric=is_anti_symmetric) END IF IF(nspins == 2) THEN ALLOCATE(full_density_beta(shm_block_offset(ncpu+1),1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_full_density(para_env, full_density_beta(:,1), rho_ao(2,1)%matrix, shm_number_of_p_entries,& shm_block_offset,& kind_of, basis_parameter, get_max_vals_spin=.FALSE.,& - antisymmetric=is_anti_symmetric,error=error) + antisymmetric=is_anti_symmetric) ! With mp2 density IF(with_mp2_density) THEN NULLIFY(full_density_mp2_beta) ALLOCATE(full_density_mp2_beta(shm_block_offset(ncpu+1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_full_density(para_env, full_density_mp2_beta, rho_ao_mp2(2)%matrix, shm_number_of_p_entries,& shm_block_offset,& kind_of, basis_parameter, get_max_vals_spin=.FALSE.,& - antisymmetric=is_anti_symmetric,error=error) + antisymmetric=is_anti_symmetric) END IF END IF @@ -623,13 +617,12 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & load_balance_parameter, kind_of, basis_parameter,shm_initial_p, & shm_pmax_atom, i_thread, n_threads,& cell, screen_pmat_forces, actual_x_data%map_atom_to_kind_atom, & - nkind, hfx_do_eval_forces, shm_pmax_block, use_virial, error) + nkind, hfx_do_eval_forces, shm_pmax_block, use_virial) actual_x_data%b_first_load_balance_forces = .FALSE. ELSE CALL hfx_update_load_balance(actual_x_data, para_env, & load_balance_parameter, & - i_thread, n_threads, hfx_do_eval_forces, & - error) + i_thread, n_threads, hfx_do_eval_forces) END IF END IF !$OMP MASTER @@ -653,103 +646,103 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & !! Allocate work arrays ALLOCATE(primitive_forces(12*nsgf_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) primitive_forces=0.0_dp ! ** Allocate buffers for pgf_lists nneighbors = SIZE(actual_x_data%neighbor_cells) ALLOCATE(pgf_list_ij(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_product_list(nneighbors**3), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nimages(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,max_pgf**2 ALLOCATE(pgf_list_ij(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO ALLOCATE(pbd_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pbc_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pad_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pac_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(with_mp2_density) THEN ALLOCATE(pbd_buf_mp2(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pbc_buf_mp2(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pad_buf_mp2(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pac_buf_mp2(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF( nspins == 2 ) THEN ALLOCATE(pbd_buf_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pbc_buf_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pad_buf_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pac_buf_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(with_mp2_density) THEN ALLOCATE(pbd_buf_mp2_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pbc_buf_mp2_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pad_buf_mp2_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pac_buf_mp2_beta(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF ALLOCATE(ede_work(ncos_max**4*12),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_work2(ncos_max**4*12),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_work_forces(ncos_max**4*12),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_buffer1(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_buffer2(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_primitives_tmp(nsgf_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( use_virial ) THEN ALLOCATE(primitive_forces_virial(12*nsgf_max**4*3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) primitive_forces_virial=0.0_dp ALLOCATE(ede_work_virial(ncos_max**4*12*3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_work2_virial(ncos_max**4*12*3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_primitives_tmp_virial(nsgf_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_virial = 0.0_dp ELSE ! dummy allocation ALLOCATE(primitive_forces_virial(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) primitive_forces_virial=0.0_dp ALLOCATE(ede_work_virial(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_work2_virial(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ede_primitives_tmp_virial(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -802,9 +795,9 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & coeffs_kind_max0=MAXVAL(screen_coeffs_kind(:,:)%x(2)) ALLOCATE(set_list_ij((max_set*load_balance_parameter%block_size)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(set_list_kl((max_set*load_balance_parameter%block_size)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP BARRIER @@ -831,15 +824,15 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & IF( treat_forces_in_core ) THEN !! IF new md step -> reinitialize containers IF(actual_x_data%memory_parameter%recalc_forces) THEN - CALL dealloc_containers(actual_x_data, hfx_do_eval_forces, error) - CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_forces, error) + CALL dealloc_containers(actual_x_data, hfx_do_eval_forces) + CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_forces) DO bin = 1,my_bin_size maxval_container => actual_x_data%maxval_container_forces(bin) integral_containers => actual_x_data%integral_containers_forces(:,bin) - CALL hfx_init_container(maxval_container, memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(maxval_container, memory_parameter%actual_memory_usage, .FALSE.) DO i=1,64 - CALL hfx_init_container(integral_containers(i),memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(integral_containers(i),memory_parameter%actual_memory_usage, .FALSE.) END DO END DO END IF @@ -870,7 +863,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & shm_total_bins = shm_total_bins + SIZE(qs_env%x_data(irep, i)%distribution_forces) END DO ALLOCATE(tmp_task_list(shm_total_bins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) shm_task_counter = 0 DO i = 1,n_threads DO bin = 1,SIZE(qs_env%x_data(irep,i)%distribution_forces) @@ -883,9 +876,9 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & ! ** Now sort the task list ALLOCATE(tmp_task_list_cost(shm_total_bins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_index(shm_total_bins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,shm_total_bins tmp_task_list_cost(i) = tmp_task_list(i)%cost @@ -894,7 +887,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & CALL sort(tmp_task_list_cost,shm_total_bins,tmp_index) ALLOCATE(actual_x_data%task_list(shm_total_bins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,shm_total_bins actual_x_data%task_list(i) = tmp_task_list(tmp_index(shm_total_bins - i +1)) @@ -904,7 +897,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & shm_task_counter = 0 DEALLOCATE(tmp_task_list_cost, tmp_index, tmp_task_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !! precalculate maximum density matrix elements in blocks @@ -1409,7 +1402,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & IF(cartesian_estimate < eps_schwarz ) THEN CALL hfx_add_single_cache_element(estimate_to_store_int, 6,& maxval_cache, maxval_container, memory_parameter%actual_memory_usage, & - use_disk_storage, max_val_memory, error) + use_disk_storage, max_val_memory) END IF END IF @@ -1437,7 +1430,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & CALL hfx_add_single_cache_element(estimate_to_store_int, 6, & maxval_cache, maxval_container, & memory_parameter%actual_memory_usage, & - use_disk_storage, max_val_memory, error) + use_disk_storage, max_val_memory) END IF spherical_estimate = SET_EXPONENT(1.0_dp,estimate_to_store_int+1) IF( .NOT. use_virial ) THEN @@ -1457,7 +1450,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & integral_containers(nbits), & eps_storage, pmax_entry, & memory_parameter%actual_memory_usage, & - use_disk_storage, error) + use_disk_storage) buffer_left = buffer_left - buffer_size buffer_start = buffer_start + buffer_size END DO @@ -1587,25 +1580,25 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & END DO !bin !$OMP MASTER - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() do_print_load_balance_info = .FALSE. do_print_load_balance_info = BTEST(cp_print_key_should_output(logger%iter_info,hfx_section,& - "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO",error=error),cp_p_file) + "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO"),cp_p_file) !$OMP END MASTER !$OMP BARRIER IF(do_print_load_balance_info) THEN iw = -1 !$OMP MASTER iw = cp_print_key_unit_nr(logger,hfx_section,"LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") !$OMP END MASTER CALL collect_load_balance_info(para_env, actual_x_data, iw, n_threads, i_thread, & - hfx_do_eval_forces, error) + hfx_do_eval_forces) !$OMP MASTER CALL cp_print_key_finished_output(iw,logger,hfx_section,& - "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO", error=error) + "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO") !$OMP END MASTER END IF @@ -1668,10 +1661,10 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & compression_factor = 0.0_dp END IF - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,hfx_section,"HF_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE (UNIT=iw,FMT="(/,(T3,A,T65,I16))")& "HFX_MEM_INFO| Number of cart. primitive DERIV's calculated: ",shm_nprim_ints @@ -1696,7 +1689,7 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & END IF CALL cp_print_key_finished_output(iw,logger,hfx_section,& - "HF_INFO", error=error) + "HF_INFO") END IF !$OMP END MASTER @@ -1715,10 +1708,10 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & integral_caches => actual_x_data%integral_caches_forces(:,bin) integral_containers => actual_x_data%integral_containers_forces(:,bin) CALL hfx_flush_last_cache(bits_max_val, maxval_cache, maxval_container, memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) DO i=1,64 CALL hfx_flush_last_cache(i, integral_caches(i), integral_containers(i), & - memory_parameter%actual_memory_usage, .FALSE., error) + memory_parameter%actual_memory_usage, .FALSE.) END DO END DO END IF @@ -1750,94 +1743,94 @@ SUBROUTINE derivatives_four_center(qs_env,rho_ao, hfx_section, para_env, & !$OMP END MASTER !$OMP BARRIER DEALLOCATE(last_sgf_global, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP MASTER DEALLOCATE(full_density_alpha,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(with_mp2_density) THEN DEALLOCATE(full_density_mp2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(nspins==2) THEN DEALLOCATE(full_density_beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(with_mp2_density) THEN DEALLOCATE(full_density_mp2_beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF IF (do_dynamic_load_balancing) THEN DEALLOCATE(actual_x_data%task_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !$OMP END MASTER DEALLOCATE(primitive_forces, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(atom_of_kind,kind_of,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(max_contraction,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pbd_buf, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pbc_buf, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pad_buf, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pac_buf, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(with_mp2_density) THEN DEALLOCATE(pbd_buf_mp2, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pbc_buf_mp2, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pad_buf_mp2, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pac_buf_mp2, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DO i=1,max_pgf**2 DEALLOCATE(pgf_list_ij(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(pgf_list_ij, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_product_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(set_list_ij, set_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(primitive_forces_virial, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ede_work, ede_work2, ede_work_forces, ede_buffer1, ede_buffer2, ede_primitives_tmp, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ede_work_virial, ede_work2_virial, ede_primitives_tmp_virial, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(nimages, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( nspins == 2 ) THEN DEALLOCATE(pbd_buf_beta,pbc_buf_beta,pad_buf_beta,pac_buf_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(with_mp2_density) THEN DEALLOCATE(pbd_buf_mp2_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pbc_buf_mp2_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pad_buf_mp2_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pac_buf_mp2_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF diff --git a/src/hfx_energy_potential.F b/src/hfx_energy_potential.F index 7fdc576697..9110868cbe 100644 --- a/src/hfx_energy_potential.F +++ b/src/hfx_energy_potential.F @@ -123,8 +123,6 @@ MODULE hfx_energy_potential !> new fock matrix or not !> \param ispin ... !> \param do_exx ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2007 created [Manuel Guidon] !> 08.2007 optimized load balance [Manuel Guidon] @@ -134,7 +132,7 @@ MODULE hfx_energy_potential ! ***************************************************************************** SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para_env,& geometry_did_change,irep,distribute_fock_matrix,& - ispin,do_exx,error) + ispin,do_exx) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -149,7 +147,6 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para LOGICAL, INTENT(IN) :: distribute_fock_matrix INTEGER, INTENT(IN) :: ispin LOGICAL, OPTIONAL :: do_exx - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'integrate_four_center', & routineP = moduleN//':'//routineN @@ -289,7 +286,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para ! ** This is not very clean, but effective. ispin can only be 2 if we do the beta spin part in core IF( ispin == 2 ) geometry_did_change = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() is_anti_symmetric=cp_dbcsr_get_matrix_type(rho_ao(1,1)%matrix).EQ.dbcsr_type_antisymmetric @@ -297,25 +294,25 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para CALL m_memory(memsize_before) CALL mp_max(memsize_before, para_env%group) iw = cp_print_key_unit_nr(logger,hfx_section,"HF_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE (UNIT=iw,FMT="(/,(T3,A,T60,I21))")& "HFX_MEM_INFO| Est. max. program size before HFX [MiB]:", memsize_before/(1024*1024) CALL m_flush(iw) END IF CALL cp_print_key_finished_output(iw,logger,hfx_section,& - "HF_INFO", error=error) + "HF_INFO") END IF CALL get_qs_env(qs_env=qs_env, atomic_kind_set=atomic_kind_set, cell=cell, & - matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx, error=error) + matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx) NULLIFY(cell_to_index) - CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints,error=error) + CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints) IF (do_kpoints) THEN - CALL get_qs_env(qs_env=qs_env,ks_env=ks_env,error=error) - CALL get_ks_env(ks_env=ks_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_qs_env(qs_env=qs_env,ks_env=ks_env) + CALL get_ks_env(ks_env=ks_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF my_do_exx=.FALSE. @@ -375,7 +372,6 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para !$OMP irep,& !$OMP distribute_fock_matrix,& !$OMP cell_to_index,& -!$OMP error,& !$OMP ncoset,& !$OMP nso,& !$OMP nco,& @@ -463,8 +459,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para ! ** Rebuild neighbor lists in case the cell has changed (i.e. NPT MD) actual_x_data%periodic_parameter%number_of_shells = actual_x_data%periodic_parameter%mode CALL hfx_create_neighbor_cells(actual_x_data, actual_x_data%periodic_parameter%number_of_shells_from_input,& - cell, i_thread, & - error) + cell, i_thread) END IF screening_parameter = actual_x_data%screening_parameter @@ -507,8 +502,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& particle_set=particle_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) natom = SIZE(particle_set,1) @@ -518,16 +512,16 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para IF(nkimages == 1) THEN cell_loop_info%dokp = .FALSE. ELSE - CALL cp_unimplemented_error(routineP,"HFX with k-points not implemented",error) + CALL cp_unimplemented_error(routineP,"HFX with k-points not implemented") cell_loop_info%dokp = .TRUE. cell_loop_info%cell_to_index => cell_to_index ALLOCATE(cell_loop_info%index_to_cell(3,nkimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL set_cell_info(cell_loop_info) END IF ALLOCATE(kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& kind_of=kind_of) @@ -548,40 +542,40 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para ENDDO !! Allocate the arrays for the integrals. ALLOCATE(primitive_integrals(nsgf_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) primitive_integrals = 0.0_dp ALLOCATE(pbd_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pbc_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pad_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pac_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kbd_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kbc_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kad_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kac_buf(nsgf_max**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_work(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_work2(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_buffer1(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_buffer2(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_primitives_tmp(nsgf_max**4),STAT=stat) ! XXXXX could be wrong - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nspins = dft_control%nspins ALLOCATE(max_contraction(max_set,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_contraction=0.0_dp max_pgf = 0 @@ -607,19 +601,19 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para ! ** Allocate buffers for pgf_lists nneighbors = SIZE(actual_x_data%neighbor_cells) ALLOCATE(pgf_list_ij(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_product_list(nneighbors**3), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nimages(max_pgf**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,max_pgf**2 ALLOCATE(pgf_list_ij(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO !$OMP BARRIER !$OMP MASTER @@ -633,8 +627,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para shm_master_x_data%set_offset,& shm_master_x_data%block_offset,& shm_master_x_data%map_atoms_to_cpus,& - nkind,& - error) + nkind) shm_is_assoc_atomic_block => shm_master_x_data%is_assoc_atomic_block @@ -655,7 +648,6 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para "and EPS_FILTER_MATRIX in the QS section. " CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& error_msg,& - error,& only_ionode=.TRUE.) END IF END IF @@ -769,13 +761,13 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para ELSE buffer_overflow = .TRUE. END IF - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() private_lib = actual_x_data%lib !! Helper array to map local basis function indices to global ones ALLOCATE(last_sgf_global(0:natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_sgf_global(0)=0 DO iatom=1,natom ikind = kind_of(iatom) @@ -787,14 +779,13 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para !! Get the full density from all the processors NULLIFY(full_density_alpha,full_density_beta) ALLOCATE(full_density_alpha(shm_block_offset(ncpu+1),nkimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( .NOT. treat_lsd_in_core .OR. nspins == 1 ) THEN CALL timeset(routineN//"_getP",handle_getP) DO img=1,nkimages CALL get_full_density(para_env, full_density_alpha(:,img), rho_ao(ispin,img)%matrix, shm_number_of_p_entries,& shm_master_x_data%block_offset, & - kind_of, basis_parameter, get_max_vals_spin=.FALSE., antisymmetric=is_anti_symmetric,& - error=error) + kind_of, basis_parameter, get_max_vals_spin=.FALSE., antisymmetric=is_anti_symmetric) END DO IF(nspins == 2) THEN @@ -802,8 +793,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para DO img=1,nkimages CALL get_full_density(para_env, full_density_beta(:,img), rho_ao(2,img)%matrix, shm_number_of_p_entries,& shm_master_x_data%block_offset, & - kind_of, basis_parameter, get_max_vals_spin=.FALSE.,antisymmetric=is_anti_symmetric,& - error=error) + kind_of, basis_parameter, get_max_vals_spin=.FALSE.,antisymmetric=is_anti_symmetric) END DO END IF CALL timestop(handle_getP) @@ -833,7 +823,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para CALL get_full_density(para_env, full_density_alpha(:,img), rho_ao(1,img)%matrix, shm_number_of_p_entries,& shm_master_x_data%block_offset, & kind_of, basis_parameter, get_max_vals_spin=.TRUE., & - rho_beta=rho_ao(2,img)%matrix, antisymmetric=is_anti_symmetric, error=error) + rho_beta=rho_ao(2,img)%matrix, antisymmetric=is_anti_symmetric) END DO CALL timestop(handle_getP) @@ -859,13 +849,13 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para CALL get_full_density(para_env, full_density_alpha(:,img), rho_ao(ispin,img)%matrix, shm_number_of_p_entries,& shm_master_x_data%block_offset, & kind_of, basis_parameter, get_max_vals_spin=.FALSE., & - antisymmetric=is_anti_symmetric, error=error) + antisymmetric=is_anti_symmetric) END DO END IF NULLIFY(full_ks_alpha, full_ks_beta) ALLOCATE(shm_master_x_data%full_ks_alpha(shm_block_offset(ncpu+1),nkimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) full_ks_alpha => shm_master_x_data%full_ks_alpha full_ks_alpha = 0.0_dp @@ -873,7 +863,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para IF (.NOT. treat_lsd_in_core ) THEN IF(nspins==2) THEN ALLOCATE(shm_master_x_data%full_ks_beta(shm_block_offset(ncpu+1),nkimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) full_ks_beta => shm_master_x_data%full_ks_beta full_ks_beta = 0.0_dp END IF @@ -891,14 +881,14 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para IF( .NOT. shm_master_x_data%screen_funct_is_initialized ) THEN CALL calc_pair_dist_radii(qs_env, basis_parameter,& shm_master_x_data%pair_dist_radii_pgf, max_set, max_pgf, eps_schwarz,& - n_threads, i_thread, error) + n_threads, i_thread) !$OMP BARRIER CALL calc_screening_functions(qs_env, basis_parameter, private_lib, shm_master_x_data%potential_parameter,& shm_master_x_data%screen_funct_coeffs_set,& shm_master_x_data%screen_funct_coeffs_kind, & shm_master_x_data%screen_funct_coeffs_pgf, & shm_master_x_data%pair_dist_radii_pgf,& - max_set, max_pgf, n_threads, i_thread, p_work, error) + max_set, max_pgf, n_threads, i_thread, p_work) !$OMP MASTER shm_master_x_data%screen_funct_is_initialized = .TRUE. @@ -935,13 +925,12 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para shm_is_assoc_atomic_block,do_periodic,load_balance_parameter, & kind_of, basis_parameter, shm_initial_p, shm_pmax_atom, i_thread, n_threads, & cell, do_p_screening, actual_x_data%map_atom_to_kind_atom, & - nkind, hfx_do_eval_energy, shm_pmax_block, use_virial=.FALSE., error=error) + nkind, hfx_do_eval_energy, shm_pmax_block, use_virial=.FALSE.) actual_x_data%b_first_load_balance_energy = .FALSE. ELSE CALL hfx_update_load_balance(actual_x_data,para_env, & load_balance_parameter, & - i_thread, n_threads, hfx_do_eval_energy, & - error) + i_thread, n_threads, hfx_do_eval_energy) END IF END IF !$OMP BARRIER @@ -1002,15 +991,15 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para IF(.NOT. memory_parameter%do_all_on_the_fly) THEN !! IF new md step -> reinitialize containers IF(geometry_did_change) THEN - CALL dealloc_containers(actual_x_data, hfx_do_eval_energy, error) - CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy, error) + CALL dealloc_containers(actual_x_data, hfx_do_eval_energy) + CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy) DO bin = 1,my_bin_size maxval_container => actual_x_data%maxval_container(bin) integral_containers => actual_x_data%integral_containers(:,bin) - CALL hfx_init_container(maxval_container, memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(maxval_container, memory_parameter%actual_memory_usage, .FALSE.) DO i=1,64 - CALL hfx_init_container(integral_containers(i),memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(integral_containers(i),memory_parameter%actual_memory_usage, .FALSE.) END DO END DO END IF @@ -1038,9 +1027,9 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para IF(do_disk_storage) THEN !! IF new md step -> reinitialize containers IF(geometry_did_change) THEN - CALL hfx_init_container(maxval_container_disk, memory_parameter%actual_memory_usage_disk, do_disk_storage, error) + CALL hfx_init_container(maxval_container_disk, memory_parameter%actual_memory_usage_disk, do_disk_storage) DO i=1,64 - CALL hfx_init_container(integral_containers_disk(i),memory_parameter%actual_memory_usage_disk, do_disk_storage, error) + CALL hfx_init_container(integral_containers_disk(i),memory_parameter%actual_memory_usage_disk, do_disk_storage) END DO END IF !! Decompress the first cache for maxvals and integrals @@ -1065,7 +1054,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para shm_total_bins = shm_total_bins + SIZE(x_data(irep, i)%distribution_energy) END DO ALLOCATE(tmp_task_list(shm_total_bins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) shm_task_counter = 0 DO i = 1,n_threads DO bin = 1,SIZE(x_data(irep,i)%distribution_energy) @@ -1078,9 +1067,9 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para ! ** Now sort the task list ALLOCATE(tmp_task_list_cost(shm_total_bins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_index(shm_total_bins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,shm_total_bins tmp_task_list_cost(i) = tmp_task_list(i)%cost @@ -1089,7 +1078,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para CALL sort(tmp_task_list_cost,shm_total_bins,tmp_index) ALLOCATE(shm_master_x_data%task_list(shm_total_bins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,shm_total_bins shm_master_x_data%task_list(i) = tmp_task_list(tmp_index(shm_total_bins - i +1)) @@ -1099,7 +1088,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para shm_task_counter = 0 DEALLOCATE(tmp_task_list_cost, tmp_index, tmp_task_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !$OMP END MASTER !$OMP BARRIER @@ -1121,9 +1110,9 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para coeffs_kind_max0=MAXVAL(screen_coeffs_kind(:,:)%x(2)) ALLOCATE(set_list_ij((max_set*load_balance_parameter%block_size)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(set_list_kl((max_set*load_balance_parameter%block_size)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP BARRIER !$OMP MASTER @@ -1646,11 +1635,11 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para IF(.NOT. use_disk_storage) THEN CALL hfx_add_single_cache_element(estimate_to_store_int, 6,& maxval_cache, maxval_container, memory_parameter%actual_memory_usage, & - use_disk_storage, max_val_memory, error) + use_disk_storage, max_val_memory) ELSE CALL hfx_add_single_cache_element(estimate_to_store_int, 6,& maxval_cache_disk, maxval_container_disk, memory_parameter%actual_memory_usage_disk, & - use_disk_storage, error=error) + use_disk_storage) END IF END IF END IF @@ -1671,11 +1660,11 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para IF(.NOT.use_disk_storage) THEN CALL hfx_add_single_cache_element(estimate_to_store_int, 6, & maxval_cache, maxval_container, memory_parameter%actual_memory_usage, & - use_disk_storage, max_val_memory, error) + use_disk_storage, max_val_memory) ELSE CALL hfx_add_single_cache_element(estimate_to_store_int, 6, & maxval_cache_disk, maxval_container_disk, memory_parameter%actual_memory_usage_disk, & - use_disk_storage, error=error) + use_disk_storage) END IF END IF spherical_estimate = SET_EXPONENT(1.0_dp,estimate_to_store_int+1) @@ -1698,7 +1687,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para integral_containers(nbits), & eps_storage, pmax_entry, & memory_parameter%actual_memory_usage, & - use_disk_storage, error) + use_disk_storage) ELSE CALL hfx_add_mult_cache_elements(primitive_integrals(buffer_start),& buffer_size, nbits, & @@ -1706,7 +1695,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para integral_containers_disk(nbits), & eps_storage, pmax_entry, & memory_parameter%actual_memory_usage_disk, & - use_disk_storage, error) + use_disk_storage) END IF buffer_left = buffer_left - buffer_size buffer_start = buffer_start + buffer_size @@ -1788,25 +1777,25 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para !$OMP MASTER - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() do_print_load_balance_info = .FALSE. do_print_load_balance_info = BTEST(cp_print_key_should_output(logger%iter_info,hfx_section,& - "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO",error=error),cp_p_file) + "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO"),cp_p_file) !$OMP END MASTER !$OMP BARRIER IF(do_print_load_balance_info) THEN iw = -1 !$OMP MASTER iw = cp_print_key_unit_nr(logger,hfx_section,"LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") !$OMP END MASTER CALL collect_load_balance_info(para_env, actual_x_data, iw, n_threads, i_thread, & - hfx_do_eval_energy, error) + hfx_do_eval_energy) !$OMP MASTER CALL cp_print_key_finished_output(iw,logger,hfx_section,& - "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO", error=error) + "LOAD_BALANCE%PRINT/LOAD_BALANCE_INFO") !$OMP END MASTER END IF @@ -1817,7 +1806,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para !$OMP BARRIER DEALLOCATE(primitive_integrals,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP BARRIER !! Get some number about ERIS !$OMP ATOMIC @@ -1963,22 +1952,22 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para DO img=1,nkimages CALL distribute_ks_matrix(para_env, full_ks_alpha(:,img), ks_matrix(ispin,img)%matrix, shm_number_of_p_entries, & shm_block_offset, kind_of, basis_parameter, & - off_diag_fac=0.5_dp,diag_fac=afac,error=error) + off_diag_fac=0.5_dp,diag_fac=afac) END DO NULLIFY(full_ks_alpha) DEALLOCATE(shm_master_x_data%full_ks_alpha, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( .NOT. treat_lsd_in_core ) THEN IF(nspins == 2) THEN DO img=1,nkimages CALL distribute_ks_matrix(para_env, full_ks_beta(:,img), ks_matrix(2,img)%matrix, shm_number_of_p_entries, & shm_block_offset, kind_of, basis_parameter, & - off_diag_fac=0.5_dp, diag_fac=afac, error=error) + off_diag_fac=0.5_dp, diag_fac=afac) END DO NULLIFY(full_ks_beta) DEALLOCATE(shm_master_x_data%full_ks_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF CALL timestop(handle_dist_ks) @@ -1990,28 +1979,28 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para ene_x_aa = 0.0_dp DO img=1,nkimages CALL cp_dbcsr_trace(ks_matrix(ispin,img)%matrix, rho_ao(ispin,img)%matrix, & - etmp, error=error) + etmp) ene_x_aa = ene_x_aa + etmp END DO !for ADMMS, we need the exchange matrix k(d) for both spins IF( dft_control%do_admm ) THEN - CPPostcondition(nkimages==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nkimages==1,cp_failure_level,routineP,failure) CALL cp_dbcsr_copy(matrix_ks_aux_fit_hfx(ispin)%matrix, ks_matrix(ispin,1)%matrix, & - name="HF exch. part of matrix_ks_aux_fit for ADMMS", error=error) + name="HF exch. part of matrix_ks_aux_fit for ADMMS") END IF IF( nspins == 2 .AND. .NOT. treat_lsd_in_core ) THEN ene_x_bb = 0.0_dp DO img=1,nkimages CALL cp_dbcsr_trace(ks_matrix(2,img)%matrix, rho_ao(2,img)%matrix, & - etmp, error=error) + etmp) ene_x_bb = ene_x_bb + etmp END DO !for ADMMS, we need the exchange matrix k(d) for both spins IF( dft_control%do_admm ) THEN - CPPostcondition(nkimages==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nkimages==1,cp_failure_level,routineP,failure) CALL cp_dbcsr_copy(matrix_ks_aux_fit_hfx(2)%matrix, ks_matrix(2,1)%matrix, & - name="HF exch. part of matrix_ks_aux_fit for ADMMS", error=error) + name="HF exch. part of matrix_ks_aux_fit for ADMMS") END IF END IF @@ -2071,7 +2060,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para END IF iw = cp_print_key_unit_nr(logger,hfx_section,"HF_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE (UNIT=iw,FMT="((T3,A,T60,I21))")& "HFX_MEM_INFO| Number of cart. primitive ERI's calculated: ",shm_nprim_ints @@ -2121,7 +2110,7 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para END IF CALL cp_print_key_finished_output(iw,logger,hfx_section,& - "HF_INFO", error=error) + "HF_INFO") END IF !$OMP END MASTER @@ -2140,10 +2129,10 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para integral_caches => actual_x_data%integral_caches(:,bin) integral_containers => actual_x_data%integral_containers(:,bin) CALL hfx_flush_last_cache(bits_max_val, maxval_cache, maxval_container, memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) DO i=1,64 CALL hfx_flush_last_cache(i, integral_caches(i), integral_containers(i), & - memory_parameter%actual_memory_usage, .FALSE., error) + memory_parameter%actual_memory_usage, .FALSE.) END DO END DO END IF @@ -2171,10 +2160,10 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para !! flush caches if the geometry changed IF(geometry_did_change ) THEN CALL hfx_flush_last_cache(bits_max_val, maxval_cache_disk, maxval_container_disk, & - memory_parameter%actual_memory_usage_disk, .TRUE., error) + memory_parameter%actual_memory_usage_disk, .TRUE.) DO i=1,64 CALL hfx_flush_last_cache(i, integral_caches_disk(i), integral_containers_disk(i), & - memory_parameter%actual_memory_usage_disk, .TRUE., error) + memory_parameter%actual_memory_usage_disk, .TRUE.) END DO END IF !! reset all caches except we calculate all on the fly @@ -2189,54 +2178,54 @@ SUBROUTINE integrate_four_center(qs_env,ks_matrix,energy,rho_ao,hfx_section,para !$OMP BARRIER !! Clean up DEALLOCATE(last_sgf_global,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP MASTER DEALLOCATE(full_density_alpha,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( .NOT. treat_lsd_in_core ) THEN IF(nspins==2) THEN DEALLOCATE(full_density_beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF IF (do_dynamic_load_balancing) THEN DEALLOCATE(shm_master_x_data%task_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !$OMP END MASTER DEALLOCATE(pbd_buf, pbc_buf, pad_buf, pac_buf, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kbd_buf,kbc_buf,kad_buf,kac_buf, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(set_list_ij, set_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,max_pgf**2 DEALLOCATE(pgf_list_ij(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(pgf_list_ij, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_product_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(max_contraction, kind_of, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ee_work, ee_work2, ee_buffer1, ee_buffer2, ee_primitives_tmp, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(nimages, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ASSOCIATED(cell_loop_info%index_to_cell)) THEN DEALLOCATE(cell_loop_info%index_to_cell, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !$OMP BARRIER diff --git a/src/hfx_helpers.F b/src/hfx_helpers.F index 83c9ccb45a..1e60a2858f 100644 --- a/src/hfx_helpers.F +++ b/src/hfx_helpers.F @@ -96,16 +96,14 @@ END SUBROUTINE next_image_cell_perd !> \brief - Auxiliary function for getting the occupation of a sparse matrix !> \param matrix ... !> \param para_env ... -!> \param error ... !> \retval get_occupation ... !> \par History !> 12.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** -FUNCTION get_occupation(matrix,para_env,error) +FUNCTION get_occupation(matrix,para_env) TYPE(cp_dbcsr_type), POINTER :: matrix TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error REAL(dp) :: get_occupation CHARACTER(LEN=*), PARAMETER :: routineN = 'get_occupation', & @@ -126,11 +124,11 @@ FUNCTION get_occupation(matrix,para_env,error) ! *** Allocate work storage *** ALLOCATE (nblock(npe),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nblock(:) = 0 ALLOCATE (nelement(npe),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nelement(:) = 0 nblock(mype) = cp_dbcsr_get_num_blocks(matrix) diff --git a/src/hfx_libint_wrapper.F b/src/hfx_libint_wrapper.F index fcddd645b3..f64172066d 100644 --- a/src/hfx_libint_wrapper.F +++ b/src/hfx_libint_wrapper.F @@ -112,12 +112,10 @@ END SUBROUTINE free_lib_deriv !> \brief ... !> \param lib ... !> \param max_am ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE initialize_libint(lib,max_am,error) + SUBROUTINE initialize_libint(lib,max_am) TYPE(lib_int) :: lib INTEGER :: max_am - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_libint', & routineP = moduleN//':'//routineN @@ -137,13 +135,13 @@ SUBROUTINE initialize_libint(lib,max_am,error) IF(storage_required(i,0) < 0) EXIT ENDDO CALL cp_assert(libint_max_am==i, cp_failure_level,cp_assertion_failed,routineP,& - "CP2K and libint were compiled with different LIBINT_MAX_AM.", error,failure) + "CP2K and libint were compiled with different LIBINT_MAX_AM.",failure) lib_storage = init_lib(lib, max_am_local, max_prim) IF (lib_storage<0) THEN CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& " the angular momentum needed exceeds the value assumed when configuring libint ", & - error,failure) + failure) ENDIF END SUBROUTINE initialize_libint @@ -151,12 +149,10 @@ END SUBROUTINE initialize_libint !> \brief ... !> \param deriv ... !> \param max_am ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE initialize_libderiv(deriv,max_am,error) + SUBROUTINE initialize_libderiv(deriv,max_am) TYPE(lib_deriv) :: deriv INTEGER :: max_am - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_libderiv', & routineP = moduleN//':'//routineN @@ -178,13 +174,13 @@ SUBROUTINE initialize_libderiv(deriv,max_am,error) IF(storage_required_deriv1(i,0,0) < 0) EXIT ENDDO CALL cp_assert(libderiv_max_am1==i, cp_failure_level,cp_assertion_failed,routineP,& - "CP2K and libderiv were compiled with different LIBDERIV_MAX_AM1.", error,failure) + "CP2K and libderiv were compiled with different LIBDERIV_MAX_AM1.",failure) lib_deriv_storage = init_deriv1(deriv, max_am_local, max_prim, max_classes) IF (lib_deriv_storage<0) THEN CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& " the angular momentum needed exceeds the value assumed when configuring libderiv ", & - error,failure) + failure) ENDIF END SUBROUTINE initialize_libderiv @@ -291,12 +287,10 @@ END SUBROUTINE get_derivs !> \brief ... !> \param lib ... !> \param max_am ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE initialize_libint(lib,max_am,error) + SUBROUTINE initialize_libint(lib,max_am) TYPE(lib_int) :: lib INTEGER :: max_am - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_libint', & routineP = moduleN//':'//routineN @@ -306,7 +300,7 @@ SUBROUTINE initialize_libint(lib,max_am,error) failure = .FALSE. CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& " This CP2K executable has not been linked against the library libint, required for HFX.", & - error,failure) + failure) END SUBROUTINE initialize_libint @@ -314,12 +308,10 @@ END SUBROUTINE initialize_libint !> \brief ... !> \param deriv ... !> \param max_am ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE initialize_libderiv(deriv,max_am,error) + SUBROUTINE initialize_libderiv(deriv,max_am) TYPE(lib_deriv) :: deriv INTEGER :: max_am - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_libderiv', & routineP = moduleN//':'//routineN @@ -329,7 +321,7 @@ SUBROUTINE initialize_libderiv(deriv,max_am,error) failure = .FALSE. CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& " This CP2K executable has not been linked against the library libint, required for HFX.", & - error,failure) + failure) END SUBROUTINE initialize_libderiv diff --git a/src/hfx_load_balance_methods.F b/src/hfx_load_balance_methods.F index b8aa76947c..5430fb9da7 100644 --- a/src/hfx_load_balance_methods.F +++ b/src/hfx_load_balance_methods.F @@ -108,8 +108,6 @@ MODULE hfx_load_balance_methods !> \param eval_type ... !> \param pmax_block ... !> \param use_virial ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2007 created [Manuel Guidon] !> 08.2007 new parallel scheme [Manuel Guidon] @@ -138,7 +136,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& load_balance_parameter, kind_of, basis_parameter, pmax_set, & pmax_atom, i_thread, n_threads, cell, & do_p_screening, map_atom_to_kind_atom, nkind, eval_type, & - pmax_block, use_virial, error) + pmax_block, use_virial) TYPE(hfx_type), POINTER :: x_data REAL(dp), INTENT(IN) :: eps_schwarz TYPE(particle_type), DIMENSION(:), & @@ -164,7 +162,6 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& INTEGER, INTENT(IN) :: nkind, eval_type REAL(dp), DIMENSION(:, :), POINTER :: pmax_block LOGICAL, INTENT(IN) :: use_virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_load_balance', & routineP = moduleN//':'//routineN @@ -232,9 +229,9 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& block_size = load_balance_parameter%block_size ALLOCATE(set_list_ij((max_set*block_size)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(set_list_kl((max_set*block_size)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( .NOT. load_balance_parameter%blocks_initialized ) THEN @@ -244,11 +241,11 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& nblocks = MAX((natom+block_size-1)/block_size,1) ALLOCATE(blocks_guess(nblocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_blocks(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_blocks2(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pmax_blocks = 0.0_dp SELECT CASE(eval_type) @@ -341,7 +338,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& END DO DEALLOCATE(tmp_blocks2, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! ** count number of non empty blocks on each node non_empty_blocks = 0 @@ -351,7 +348,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& END DO ALLOCATE(rcount(ncpu), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rcount = 0 rcount(para_env%mepos+1) = non_empty_blocks CALL mp_sum(rcount, para_env%group) @@ -364,7 +361,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& ! ** calculate offsets ALLOCATE(rdispl(ncpu), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rcount(:) = rcount(:) * 3 rdispl(1) = 0 DO i = 2,ncpu @@ -372,7 +369,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& END DO ALLOCATE(buffer_in(3*non_empty_blocks), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) non_empty_blocks = 0 @@ -387,11 +384,11 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& nblocks = total_blocks ALLOCATE(tmp_blocks2(nblocks), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(buffer_out(3*nblocks), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! ** Gather all three arrays CALL mp_allgather(buffer_in,buffer_out,rcount,rdispl,para_env%group) @@ -404,9 +401,9 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& ! ** Now we sort the blocks ALLOCATE(to_be_sorted(nblocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_index(nblocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO atom_block = 1,nblocks to_be_sorted(atom_block) = tmp_blocks2(atom_block)%istart @@ -415,7 +412,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& CALL sort(to_be_sorted,nblocks,tmp_index) ALLOCATE(x_data%blocks(nblocks), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO atom_block = 1,nblocks x_data%blocks(atom_block) = tmp_blocks2(tmp_index(atom_block)) @@ -428,10 +425,10 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& load_balance_parameter%nblocks = nblocks DEALLOCATE(blocks_guess, tmp_blocks, tmp_blocks2, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rcount, rdispl, buffer_in, buffer_out, to_be_sorted, tmp_index, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) load_balance_parameter%blocks_initialized = .TRUE. @@ -440,7 +437,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& load_balance_parameter%blocks_initialized = .TRUE. ALLOCATE(x_data%pmax_block(shm_nblocks,shm_nblocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%pmax_block = 0.0_dp pmax_block => x_data%pmax_block CALL timestop(handle_range) @@ -449,7 +446,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& IF( .NOT. load_balance_parameter%blocks_initialized ) THEN ALLOCATE(x_data%blocks(shm_nblocks), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%blocks = shm_blocks load_balance_parameter%nblocks = shm_nblocks load_balance_parameter%blocks_initialized = .TRUE. @@ -490,18 +487,18 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& !! If there is only 1 cpu skip the binning IF(n_processes == 1) THEN ALLOCATE(tmp_dist(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_dist(1)%number_of_atom_quartets = HUGE(tmp_dist(1)%number_of_atom_quartets) tmp_dist(1)%istart = 0_int_8 ptr_to_tmp_dist => tmp_dist(:) SELECT CASE( eval_type) CASE (hfx_do_eval_energy) - CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data) CASE (hfx_do_eval_forces) - CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data) END SELECT DEALLOCATE(tmp_dist,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE !! Calculate total numbers of integrals that have to be calculated (wrt screening and symmetry) !$OMP BARRIER @@ -593,7 +590,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& !$OMP BARRIER ALLOCATE(binned_dist(nbins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) binned_dist(:)%istart = -1_int_8 binned_dist(:)%number_of_atom_quartets = 0_int_8 binned_dist(:)%cost = 0_int_8 @@ -724,7 +721,6 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& ") are different. Please send in a bug report." CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& error_msg,& - error,& only_ionode=.TRUE.) END IF END IF @@ -733,7 +729,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& !$OMP BARRIER !$OMP MASTER ALLOCATE(cost_matrix(ncpu*nbins*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cost_matrix = 0 !$OMP END MASTER !$OMP BARRIER @@ -749,9 +745,9 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& CALL mp_sync(para_env%group) ALLOCATE(sendbuffer(nbins*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(recbuffer(nbins*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sendbuffer = cost_matrix(mepos*nbins*n_threads+1:mepos*nbins*n_threads+nbins*n_threads) @@ -772,7 +768,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& recbuffer=>swapbuffer ENDDO DEALLOCATE(recbuffer, sendbuffer, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP END MASTER !$OMP BARRIER @@ -786,21 +782,20 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& !! Find an optimal distribution i.e. assign each element of the cost matrix to a certain process !$OMP BARRIER ALLOCATE(local_cost_matrix(SIZE(cost_matrix,1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_cost_matrix = cost_matrix !$OMP MASTER ALLOCATE(shm_distribution_vector(ncpu*nbins*n_threads), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL optimize_distribution(ncpu*nbins*n_threads, ncpu*n_threads, local_cost_matrix, & - shm_distribution_vector, x_data%load_balance_parameter%do_randomize, & - error) + shm_distribution_vector, x_data%load_balance_parameter%do_randomize) CALL timestop(handle_inner) CALL timeset(routineN//"_redist",handle_inner) !! Collect local data to global array ALLOCATE(full_dist(ncpu*n_threads,nbins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) full_dist(:,:)%istart = 0_int_8 full_dist(:,:)%number_of_atom_quartets = 0_int_8 @@ -816,9 +811,9 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& !$OMP BARRIER !$OMP MASTER ALLOCATE(sendbuffer(3*nbins*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(recbuffer(3*nbins*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos = para_env%mepos DO j=1,n_threads DO i=1,nbins @@ -854,7 +849,7 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& recbuffer=>swapbuffer ENDDO DEALLOCATE(recbuffer, sendbuffer, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! sync before/after ring of isendrecv CALL mp_sync(para_env%group) @@ -862,10 +857,10 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& !$OMP BARRIER !! reorder the distribution according to the distribution vector ALLOCATE(tmp_pos(ncpu*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_pos = 1 ALLOCATE(tmp_dist(nbins*ncpu*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_dist(:)%istart = 0_int_8 tmp_dist(:)%number_of_atom_quartets = 0_int_8 @@ -890,23 +885,23 @@ SUBROUTINE hfx_load_balance(x_data, eps_schwarz, particle_set,max_set,para_env,& ptr_to_tmp_dist => tmp_dist(1:tmp_pos(mepos)-1) SELECT CASE (eval_type) CASE (hfx_do_eval_energy) - CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data) CASE (hfx_do_eval_forces) - CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data) END SELECT !$OMP BARRIER !$OMP MASTER DEALLOCATE(full_dist,cost_matrix,shm_distribution_vector, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP END MASTER !$OMP BARRIER DEALLOCATE(tmp_dist, tmp_pos, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(binned_dist, local_cost_matrix, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(set_list_ij, set_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP BARRIER !$OMP MASTER @@ -1567,8 +1562,6 @@ END SUBROUTINE hfx_permute_binning !> \param i_thread current thread ID !> \param n_threads Total Number of threads !> \param eval_type ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2007 created [Manuel Guidon] !> 02.2009 optimize Memory Usage [Manuel Guidon] @@ -1579,13 +1572,12 @@ END SUBROUTINE hfx_permute_binning ! ***************************************************************************** SUBROUTINE hfx_update_load_balance(x_data, para_env, & load_balance_parameter, & - i_thread, n_threads, eval_type, error) + i_thread, n_threads, eval_type) TYPE(hfx_type), POINTER :: x_data TYPE(cp_para_env_type), POINTER :: para_env TYPE(hfx_load_balance_type) :: load_balance_parameter INTEGER, INTENT(IN) :: i_thread, n_threads, eval_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_update_load_balance', & routineP = moduleN//':'//routineN @@ -1623,25 +1615,25 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & !! If there is only 1 cpu skip the binning IF(n_processes == 1) THEN ALLOCATE(tmp_dist(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_dist(1)%number_of_atom_quartets = HUGE(tmp_dist(1)%number_of_atom_quartets) tmp_dist(1)%istart = 0_int_8 ptr_to_tmp_dist => tmp_dist(:) SELECT CASE (eval_type) CASE (hfx_do_eval_energy) - CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data) CASE (hfx_do_eval_forces) - CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data) END SELECT DEALLOCATE(tmp_dist,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE mepos = para_env%mepos my_process_id = para_env%mepos*n_threads + i_thread nbins = load_balance_parameter%nbins !$OMP MASTER ALLOCATE(bin_histogram(n_processes,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bin_histogram = 0 !$OMP END MASTER !$OMP BARRIER @@ -1665,7 +1657,7 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & !$OMP END MASTER !$OMP BARRIER ALLOCATE(binned_dist(my_bin_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !! Use old binned_dist, but with timings cost SELECT CASE (eval_type) CASE (hfx_do_eval_energy) @@ -1695,12 +1687,12 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & !$OMP MASTER !! store all local results in a big cost matrix ALLOCATE(cost_matrix(ncpu*nbins*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cost_matrix = 0 ALLOCATE(sendbuffer(max_bin_size*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(recbuffer(max_bin_size*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP END MASTER !$OMP BARRIER my_global_start_idx = bin_histogram(my_process_id+1,2)- my_bin_size @@ -1713,7 +1705,7 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & !$OMP BARRIER !$OMP MASTER ALLOCATE(bins_per_rank(ncpu), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bins_per_rank = 0 DO icpu=1,ncpu bins_per_rank(icpu) = SUM(bin_histogram((icpu-1)*n_threads+1:(icpu-1)*n_threads+n_threads,1)) @@ -1743,23 +1735,22 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & recbuffer=>swapbuffer ENDDO DEALLOCATE(recbuffer, sendbuffer, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! sync before/after ring of isendrecv CALL mp_sync(para_env%group) !$OMP END MASTER !$OMP BARRIER ALLOCATE(local_cost_matrix(SIZE(cost_matrix,1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_cost_matrix = cost_matrix !$OMP MASTER ALLOCATE(shm_distribution_vector(ncpu*nbins*n_threads), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL optimize_distribution(ncpu*nbins*n_threads, ncpu*n_threads, local_cost_matrix, & - shm_distribution_vector, x_data%load_balance_parameter%do_randomize, & - error) + shm_distribution_vector, x_data%load_balance_parameter%do_randomize) ALLOCATE(full_dist(ncpu*n_threads,max_bin_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) full_dist(:,:)%istart = 0_int_8 full_dist(:,:)%number_of_atom_quartets = 0_int_8 @@ -1775,9 +1766,9 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & !$OMP BARRIER !$OMP MASTER ALLOCATE(sendbuffer(3*max_bin_size*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(recbuffer(3*max_bin_size*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos = para_env%mepos DO j=1,n_threads DO i=1,max_bin_size @@ -1813,16 +1804,16 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & ENDDO ! sync before/after ring of isendrecv DEALLOCATE(recbuffer, sendbuffer, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_sync(para_env%group) !$OMP END MASTER !$OMP BARRIER !! reorder the distribution according to the distribution vector ALLOCATE(tmp_pos(ncpu*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_pos = 1 ALLOCATE(tmp_dist(nbins*ncpu*n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_dist(:)%istart = 0_int_8 tmp_dist(:)%number_of_atom_quartets = 0_int_8 @@ -1847,23 +1838,23 @@ SUBROUTINE hfx_update_load_balance(x_data, para_env, & ptr_to_tmp_dist => tmp_dist(1:tmp_pos(mepos)-1) SELECT CASE (eval_type) CASE (hfx_do_eval_energy) - CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_energy(ptr_to_tmp_dist,x_data) CASE (hfx_do_eval_forces) - CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data,error=error) + CALL hfx_set_distr_forces(ptr_to_tmp_dist,x_data) END SELECT !$OMP BARRIER !$OMP MASTER DEALLOCATE(full_dist, cost_matrix, shm_distribution_vector, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bins_per_rank,bin_histogram, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP END MASTER !$OMP BARRIER DEALLOCATE(tmp_dist, tmp_pos, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(binned_dist, local_cost_matrix, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !$OMP BARRIER !$OMP MASTER @@ -1950,20 +1941,17 @@ END FUNCTION cost_model !> \param bin_costs costs per bin !> \param distribution_vector will contain the final distribution !> \param do_randomize ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2009 created from a hack by Joost [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE optimize_distribution(total_number_of_bins, number_of_processes, bin_costs, & - distribution_vector, do_randomize, error) + distribution_vector, do_randomize) INTEGER :: total_number_of_bins, & number_of_processes INTEGER(int_8), DIMENSION(:), POINTER :: bin_costs INTEGER, DIMENSION(:), POINTER :: distribution_vector LOGICAL, INTENT(IN) :: do_randomize - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'optimize_distribution', & routineP = moduleN//':'//routineN @@ -1980,15 +1968,15 @@ SUBROUTINE optimize_distribution(total_number_of_bins, number_of_processes, bin_ nstep=MAX(1,INT(number_of_processes)/2) ALLOCATE(tmp_cost(total_number_of_bins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_index(total_number_of_bins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_cpu_cost(number_of_processes),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_cpu_index(number_of_processes),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(my_cost_cpu(number_of_processes),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_cost=bin_costs CALL sort(tmp_cost,total_number_of_bins,tmp_index) @@ -2005,14 +1993,14 @@ SUBROUTINE optimize_distribution(total_number_of_bins, number_of_processes, bin_ NULLIFY(rng_stream) CALL create_rng_stream(rng_stream=rng_stream,& name="uniform_rng",& - distribution_type=UNIFORM,error=error) + distribution_type=UNIFORM) END IF DO i=total_number_of_bins,1,-nstep tmp_cpu_cost=my_cost_cpu CALL sort(tmp_cpu_cost,INT(number_of_processes),tmp_cpu_index) IF( do_randomize ) THEN - CALL reshuffle(MIN(i,nstep), tmp_cpu_index(1:MIN(i,nstep)),rng_stream, error) + CALL reshuffle(MIN(i,nstep), tmp_cpu_index(1:MIN(i,nstep)),rng_stream) END IF DO j=1,MIN(i,nstep) itmp=tmp_cpu_index(j) @@ -2022,13 +2010,13 @@ SUBROUTINE optimize_distribution(total_number_of_bins, number_of_processes, bin_ ENDDO IF( do_randomize ) THEN - CALL delete_rng_stream(rng_stream,error=error) + CALL delete_rng_stream(rng_stream) END IF DEALLOCATE(tmp_cost,tmp_index,tmp_cpu_cost,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_cpu_index,my_cost_cpu,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE optimize_distribution ! ***************************************************************************** @@ -2484,16 +2472,14 @@ END SUBROUTINE init_blocks !> \param n_threads ... !> \param i_thread ... !> \param eval_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, & - eval_type, error) + eval_type) TYPE(cp_para_env_type), POINTER :: para_env TYPE(hfx_type), POINTER :: x_data INTEGER, INTENT(IN) :: iw, n_threads, i_thread, & eval_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'collect_load_balance_info', & routineP = moduleN//':'//routineN @@ -2525,9 +2511,9 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, !$OMP MASTER ALLOCATE(shm_bins_per_rank(n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(shm_displ(n_threads+1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP END MASTER !$OMP BARRIER @@ -2543,7 +2529,7 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, !$OMP BARRIER !$OMP MASTER ALLOCATE(bins_per_rank(nranks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bins_per_rank = 0 bins_per_rank(my_rank+1) = nbins @@ -2556,7 +2542,7 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, END DO ALLOCATE(shm_cost_vector(2*total_bins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) shm_cost_vector = -1_int_8 shm_displ(1) = 1 DO i = 2,n_threads @@ -2584,7 +2570,7 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, !$OMP MASTER ! ** calculate offsets ALLOCATE(rdispl(nranks), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bins_per_rank(:) = bins_per_rank(:) * 2 rdispl(1) = 0 DO i = 2,nranks @@ -2592,9 +2578,9 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, END DO ALLOCATE(buffer_in(2*nbins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(buffer_out(2*total_bins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nbins buffer_in(2*(i-1)+1) = shm_cost_vector(2*(i-1)+1) @@ -2606,7 +2592,7 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, IF( iw>0 ) THEN ALLOCATE(summary(2*nranks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) summary = 0_int_8 WRITE(iw,'( /, 1X, 79("-") )' ) @@ -2665,9 +2651,9 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, ALLOCATE(buffer(nranks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(sort_idx(nranks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nranks buffer(i) = summary(2*i) @@ -2681,17 +2667,17 @@ SUBROUTINE collect_load_balance_info(para_env, x_data, iw, n_threads, i_thread, END DO DEALLOCATE(summary, buffer, sort_idx, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(buffer_in, buffer_out, rdispl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_sync(para_env%group) DEALLOCATE(shm_bins_per_rank, shm_displ, shm_cost_vector, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP END MASTER !$OMP BARRIER @@ -2702,21 +2688,19 @@ END SUBROUTINE collect_load_balance_info !> \param size ... !> \param array ... !> \param rng_stream ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE reshuffle(size, array, rng_stream, error) + SUBROUTINE reshuffle(size, array, rng_stream) INTEGER :: size INTEGER, DIMENSION(size) :: array TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, idx1, idx2, tmp REAL(dp) :: x DO i = 1,size*10 - x = next_random_number(rng_stream,error=error) + x = next_random_number(rng_stream) idx1 = INT(x*(size+1-1))+1 - x = next_random_number(rng_stream,error=error) + x = next_random_number(rng_stream) idx2 = INT(x*(size+1-1))+1 diff --git a/src/hfx_screening_methods.F b/src/hfx_screening_methods.F index 5f9a3a1639..a687f2b0ac 100644 --- a/src/hfx_screening_methods.F +++ b/src/hfx_screening_methods.F @@ -283,7 +283,6 @@ END SUBROUTINE update_pmax_mat !> \param n_threads ... !> \param i_thread Thread ID of current task !> \param p_work ... -!> \param error ... !> \par History !> 02.2009 created [Manuel Guidon] !> \author Manuel Guidon @@ -307,7 +306,7 @@ END SUBROUTINE update_pmax_mat SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_parameter, & coeffs_set, coeffs_kind, coeffs_pgf, radii_pgf,& max_set, max_pgf, n_threads, i_thread,& - p_work, error) + p_work) TYPE(qs_environment_type), POINTER :: qs_env TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: basis_parameter @@ -322,7 +321,6 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para INTEGER, INTENT(IN) :: max_set, max_pgf, n_threads, & i_thread REAL(dp), DIMENSION(:), POINTER :: p_work - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_screening_functions', & routineP = moduleN//':'//routineN @@ -356,14 +354,13 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para !$OMP END MASTER CALL get_qs_env(qs_env=qs_env,& - qs_kind_set=qs_kind_set,& - error=error) + qs_kind_set=qs_kind_set) nkind = SIZE(qs_kind_set,1) !$OMP MASTER ALLOCATE(coeffs_pgf(max_pgf,max_pgf,max_set,max_set,nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind = 1,nkind DO jkind = 1,nkind @@ -386,7 +383,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para DO ikind=1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(la_max,la_min,npgfa,zeta) la_max => basis_parameter(ikind)%lmax @@ -403,7 +400,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para DO jkind = 1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(jkind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(lb_max,lb_min,npgfb,zetb) lb_max => basis_parameter(jkind)%lmax @@ -470,7 +467,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para !$OMP MASTER ALLOCATE(coeffs_set(max_set,max_set,nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind = 1,nkind DO jkind = 1,nkind @@ -488,7 +485,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para DO ikind=1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(la_max,la_min,npgfa,zeta) ! CALL get_gto_basis_set(gto_basis_set=orb_basis,& ! lmax=la_max,& @@ -513,7 +510,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para DO jkind = 1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(jkind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(lb_max,lb_min,npgfb,zetb) lb_max => basis_parameter(jkind)%lmax @@ -568,7 +565,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para ! ** now kinds !$OMP MASTER ALLOCATE(coeffs_kind(nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind = 1,nkind DO jkind = 1,nkind @@ -581,7 +578,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para DO ikind=1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(la_max,la_min,npgfa,zeta) la_max => basis_parameter(ikind)%lmax @@ -597,7 +594,7 @@ SUBROUTINE calc_screening_functions(qs_env, basis_parameter, lib, potential_para DO jkind = 1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(jkind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(lb_max,lb_min,npgfb,zetb) lb_max => basis_parameter(jkind)%lmax @@ -665,7 +662,6 @@ END SUBROUTINE calc_screening_functions !> \param eps_schwarz ... !> \param n_threads ... !> \param i_thread Thread ID of current task -!> \param error ... !> \par History !> 02.2009 created [Manuel Guidon] !> \author Manuel Guidon @@ -680,7 +676,7 @@ END SUBROUTINE calc_screening_functions SUBROUTINE calc_pair_dist_radii(qs_env, basis_parameter, & radii_pgf, max_set, max_pgf, eps_schwarz, & - n_threads, i_thread, error) + n_threads, i_thread) TYPE(qs_environment_type), POINTER :: qs_env TYPE(hfx_basis_type), DIMENSION(:), & @@ -690,7 +686,6 @@ SUBROUTINE calc_pair_dist_radii(qs_env, basis_parameter, & INTEGER, INTENT(IN) :: max_set, max_pgf REAL(dp) :: eps_schwarz INTEGER, INTENT(IN) :: n_threads, i_thread - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_pair_dist_radii', & routineP = moduleN//':'//routineN @@ -721,15 +716,14 @@ SUBROUTINE calc_pair_dist_radii(qs_env, basis_parameter, & CALL timeset(routineN,handle) !$OMP END MASTER CALL get_qs_env(qs_env=qs_env,& - qs_kind_set=qs_kind_set,& - error=error) + qs_kind_set=qs_kind_set) nkind = SIZE(qs_kind_set,1) ra = 0.0_dp rb = 0.0_dp !$OMP MASTER ALLOCATE(radii_pgf(max_pgf,max_pgf,max_set,max_set,nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind = 1,nkind DO jkind = 1,nkind DO iset=1,max_set @@ -751,7 +745,7 @@ SUBROUTINE calc_pair_dist_radii(qs_env, basis_parameter, & DO ikind=1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(la_max,la_min,npgfa,zeta) la_max => basis_parameter(ikind)%lmax @@ -768,7 +762,7 @@ SUBROUTINE calc_pair_dist_radii(qs_env, basis_parameter, & DO jkind = 1,nkind NULLIFY(qs_kind,orb_basis) qs_kind => qs_kind_set(jkind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) NULLIFY(lb_max,lb_min,npgfb,zetb) lb_max => basis_parameter(jkind)%lmax diff --git a/src/hfx_types.F b/src/hfx_types.F index 520915ab91..b3fc67d1ea 100644 --- a/src/hfx_types.F +++ b/src/hfx_types.F @@ -468,8 +468,6 @@ MODULE hfx_types !> \param qs_kind_set ... !> \param dft_control ... !> \param cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param do_exx ... !> \par History !> 09.2007 created [Manuel Guidon] @@ -479,7 +477,7 @@ MODULE hfx_types !> unknown at invocation time ! ***************************************************************************** SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kind_set, & - dft_control, cell, error, do_exx) + dft_control, cell,do_exx) TYPE(hfx_type), DIMENSION(:, :), POINTER :: x_data TYPE(cp_para_env_type) :: para_env TYPE(section_vals_type), POINTER :: hfx_section @@ -490,7 +488,6 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin POINTER :: qs_kind_set TYPE(dft_control_type), POINTER :: dft_control TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, OPTIONAL :: do_exx CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_create', & @@ -513,34 +510,34 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin CALL cite_reference(Guidon2008) CALL cite_reference(Guidon2009) !! There might be 2 hf sections - CALL section_vals_get(hfx_section,n_repetition=n_rep_hf,error=error) + CALL section_vals_get(hfx_section,n_repetition=n_rep_hf) n_threads = 1 !$ n_threads = omp_get_max_threads() ALLOCATE(x_data(n_rep_hf,n_threads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i_thread=1,n_threads DO irep=1,n_rep_hf actual_x_data => x_data(irep,i_thread) !! Get data from input file !! !! GENERAL params - CALL section_vals_val_get(hfx_section, "FRACTION", r_val=real_val, i_rep_section=irep,error=error) + CALL section_vals_val_get(hfx_section, "FRACTION", r_val=real_val, i_rep_section=irep) actual_x_data%general_parameter%fraction = real_val actual_x_data%n_rep_hf = n_rep_hf NULLIFY(actual_x_data%map_atoms_to_cpus) - CALL section_vals_val_get(hfx_section, "TREAT_LSD_IN_CORE", l_val=logic_val, i_rep_section=irep,error=error) + CALL section_vals_val_get(hfx_section, "TREAT_LSD_IN_CORE", l_val=logic_val, i_rep_section=irep) actual_x_data%general_parameter%treat_lsd_in_core = logic_val !! MEMORY section - hf_sub_section => section_vals_get_subs_vals(hfx_section,"MEMORY",i_rep_section=irep, error=error) + hf_sub_section => section_vals_get_subs_vals(hfx_section,"MEMORY",i_rep_section=irep) CALL parse_memory_section(actual_x_data%memory_parameter, hf_sub_section, storage_id, i_thread,& - n_threads, para_env, irep, skip_disk=.FALSE., skip_in_core_forces=.FALSE., error=error) + n_threads, para_env, irep, skip_disk=.FALSE., skip_in_core_forces=.FALSE.) !! PERIODIC section - hf_sub_section => section_vals_get_subs_vals(hfx_section,"PERIODIC", i_rep_section=irep, error=error) - CALL section_vals_val_get(hf_sub_section, "NUMBER_OF_SHELLS", i_val=int_val, error=error) + hf_sub_section => section_vals_get_subs_vals(hfx_section,"PERIODIC", i_rep_section=irep) + CALL section_vals_val_get(hf_sub_section, "NUMBER_OF_SHELLS", i_val=int_val) actual_x_data%periodic_parameter%number_of_shells = int_val actual_x_data%periodic_parameter%mode = int_val CALL get_cell(cell=cell,periodic=actual_x_data%periodic_parameter%perd) @@ -551,34 +548,34 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin END IF !! SCREENING section - hf_sub_section => section_vals_get_subs_vals(hfx_section,"SCREENING",i_rep_section=irep, error=error) - CALL section_vals_val_get(hf_sub_section, "EPS_SCHWARZ", r_val=real_val, error=error) + hf_sub_section => section_vals_get_subs_vals(hfx_section,"SCREENING",i_rep_section=irep) + CALL section_vals_val_get(hf_sub_section, "EPS_SCHWARZ", r_val=real_val) actual_x_data%screening_parameter%eps_schwarz = real_val - CALL section_vals_val_get(hf_sub_section, "EPS_SCHWARZ_FORCES", r_val=real_val, error=error) + CALL section_vals_val_get(hf_sub_section, "EPS_SCHWARZ_FORCES", r_val=real_val) actual_x_data%screening_parameter%eps_schwarz_forces = real_val - CALL section_vals_val_get(hf_sub_section, "SCREEN_P_FORCES", l_val=logic_val, error=error) + CALL section_vals_val_get(hf_sub_section, "SCREEN_P_FORCES", l_val=logic_val) actual_x_data%screening_parameter%do_p_screening_forces = logic_val - CALL section_vals_val_get(hf_sub_section, "SCREEN_ON_INITIAL_P", l_val=logic_val, error=error) + CALL section_vals_val_get(hf_sub_section, "SCREEN_ON_INITIAL_P", l_val=logic_val) actual_x_data%screening_parameter%do_initial_p_screening = logic_val actual_x_data%screen_funct_is_initialized = .FALSE. !! INTERACTION_POTENTIAL section - hf_sub_section => section_vals_get_subs_vals(hfx_section,"INTERACTION_POTENTIAL",i_rep_section=irep,error=error) - CALL section_vals_val_get(hf_sub_section, "POTENTIAL_TYPE", i_val=int_val, error=error) + hf_sub_section => section_vals_get_subs_vals(hfx_section,"INTERACTION_POTENTIAL",i_rep_section=irep) + CALL section_vals_val_get(hf_sub_section, "POTENTIAL_TYPE", i_val=int_val) actual_x_data%potential_parameter%potential_type = int_val - CALL section_vals_val_get(hf_sub_section, "OMEGA", r_val=real_val, error=error) + CALL section_vals_val_get(hf_sub_section, "OMEGA", r_val=real_val) actual_x_data%potential_parameter%omega = real_val - CALL section_vals_val_get(hf_sub_section, "SCALE_COULOMB", r_val=real_val, error=error) + CALL section_vals_val_get(hf_sub_section, "SCALE_COULOMB", r_val=real_val) actual_x_data%potential_parameter%scale_coulomb = real_val - CALL section_vals_val_get(hf_sub_section, "SCALE_LONGRANGE", r_val=real_val, error=error) + CALL section_vals_val_get(hf_sub_section, "SCALE_LONGRANGE", r_val=real_val) actual_x_data%potential_parameter%scale_longrange = real_val - CALL section_vals_val_get(hf_sub_section, "SCALE_GAUSSIAN", r_val=real_val, error=error) + CALL section_vals_val_get(hf_sub_section, "SCALE_GAUSSIAN", r_val=real_val) actual_x_data%potential_parameter%scale_gaussian = real_val IF (actual_x_data%potential_parameter%potential_type == do_hfx_potential_truncated .OR. & actual_x_data%potential_parameter%potential_type == do_hfx_potential_mix_cl_trunc) THEN - CALL section_vals_val_get(hf_sub_section, "CUTOFF_RADIUS", r_val=real_val, error=error) + CALL section_vals_val_get(hf_sub_section, "CUTOFF_RADIUS", r_val=real_val) actual_x_data%potential_parameter%cutoff_radius = real_val - CALL section_vals_val_get(hf_sub_section, "T_C_G_DATA", c_val=char_val, error=error) + CALL section_vals_val_get(hf_sub_section, "T_C_G_DATA", c_val=char_val) CALL compress(char_val,.TRUE.) ! ** Check if file is there IF ( .NOT. file_exists(char_val) ) THEN @@ -587,7 +584,6 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin "in the INTERCATION_POTENTIAL section" CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& error_msg , & - error,& only_ionode=.TRUE.) ELSE actual_x_data%potential_parameter%filename = char_val @@ -596,23 +592,23 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin IF (actual_x_data%potential_parameter%potential_type == do_hfx_potential_short) THEN CALL erfc_cutoff(actual_x_data%screening_parameter%eps_schwarz,& actual_x_data%potential_parameter%omega,& - actual_x_data%potential_parameter%cutoff_radius, error) + actual_x_data%potential_parameter%cutoff_radius) END IF !! LOAD_BALANCE section - hf_sub_section => section_vals_get_subs_vals(hfx_section,"LOAD_BALANCE",i_rep_section=irep, error=error) - CALL section_vals_val_get(hf_sub_section, "NBINS", i_val=int_val, error=error) + hf_sub_section => section_vals_get_subs_vals(hfx_section,"LOAD_BALANCE",i_rep_section=irep) + CALL section_vals_val_get(hf_sub_section, "NBINS", i_val=int_val) actual_x_data%load_balance_parameter%nbins = MAX(1,int_val) actual_x_data%load_balance_parameter%blocks_initialized = .FALSE. - CALL section_vals_val_get(hf_sub_section, "RANDOMIZE", l_val=logic_val, error=error) + CALL section_vals_val_get(hf_sub_section, "RANDOMIZE", l_val=logic_val) actual_x_data%load_balance_parameter%do_randomize = logic_val actual_x_data%load_balance_parameter%rtp_redistribute=.FALSE. IF(ASSOCIATED(dft_control%rtp_control))& actual_x_data%load_balance_parameter%rtp_redistribute=dft_control%rtp_control%hfx_redistribute - CALL section_vals_val_get(hf_sub_section, "BLOCK_SIZE", i_val=int_val, error=error) + CALL section_vals_val_get(hf_sub_section, "BLOCK_SIZE", i_val=int_val) ! negative values ask for a computed default IF (int_val<=0) THEN ! this gives a reasonable number of blocks for binning, yet typically results in blocking. @@ -630,10 +626,10 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin ! in the case of RPA exchange (postprocessing after SCF), we do not use ADMM IF(my_do_exx) THEN CALL hfx_create_basis_types(actual_x_data%basis_parameter,actual_x_data%basis_info, qs_kind_set,& - .FALSE., error) + .FALSE.) ELSE CALL hfx_create_basis_types(actual_x_data%basis_parameter,actual_x_data%basis_info, qs_kind_set,& - dft_control%do_admm, error) + dft_control%do_admm) END IF !!************************************************************************************************** @@ -734,15 +730,15 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin !! **************************************************************************************************** IF(actual_x_data%periodic_parameter%do_periodic) THEN - hf_pbc_section => section_vals_get_subs_vals(hfx_section,"PERIODIC",i_rep_section=irep, error=error) - CALL section_vals_val_get(hf_pbc_section,"NUMBER_OF_SHELLS",i_val=pbc_shells,error=error) + hf_pbc_section => section_vals_get_subs_vals(hfx_section,"PERIODIC",i_rep_section=irep) + CALL section_vals_val_get(hf_pbc_section,"NUMBER_OF_SHELLS",i_val=pbc_shells) actual_x_data%periodic_parameter%number_of_shells_from_input = pbc_shells ALLOCATE(actual_x_data%neighbor_cells(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL hfx_create_neighbor_cells(actual_x_data,pbc_shells, cell, i_thread, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL hfx_create_neighbor_cells(actual_x_data,pbc_shells, cell, i_thread) ELSE ALLOCATE(actual_x_data%neighbor_cells(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! ** Initialize this guy to enable non periodic stress regtests actual_x_data%periodic_parameter%R_max_stress = 1.0_dp END IF @@ -753,26 +749,26 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin !! ** This guy is allocated on the master thread only IF (i_thread == 1 ) THEN ALLOCATE(actual_x_data%is_assoc_atomic_block(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%atomic_block_offset(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%set_offset(max_set, max_set, nkind, nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%block_offset(para_env%num_pe+1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE(actual_x_data%distribution_forces(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%distribution_energy(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) actual_x_data%memory_parameter%size_p_screen = 0_int_8 IF( i_thread == 1 ) THEN ALLOCATE(actual_x_data%atomic_pair_list(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%atomic_pair_list_forces(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(actual_x_data%screening_parameter%do_initial_p_screening .OR. & @@ -780,9 +776,9 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin !! ** This guy is allocated on the master thread only IF (i_thread == 1 ) THEN ALLOCATE(actual_x_data%pmax_atom(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%initial_p(nkind*(nkind+1)/2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) i = 1 DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom_a) @@ -791,7 +787,7 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin CALL get_atomic_kind(atomic_kind_set(jkind), natom=natom_b) nsetb=actual_x_data%basis_parameter(jkind)%nset ALLOCATE(actual_x_data%initial_p(i)%p_kind(nseta, nsetb, natom_a, natom_b),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) actual_x_data%memory_parameter%size_p_screen = & actual_x_data%memory_parameter%size_p_screen + nseta*nsetb*natom_a*natom_b i = i + 1 @@ -799,10 +795,10 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin END DO IF( actual_x_data%memory_parameter%treat_forces_in_core ) THEN ALLOCATE(actual_x_data%pmax_atom_forces(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%initial_p_forces(nkind*(nkind+1)/2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) i = 1 DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom_a) @@ -811,7 +807,7 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin CALL get_atomic_kind(atomic_kind_set(jkind), natom=natom_b) nsetb=actual_x_data%basis_parameter(jkind)%nset ALLOCATE(actual_x_data%initial_p_forces(i)%p_kind(nseta, nsetb, natom_a, natom_b),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) actual_x_data%memory_parameter%size_p_screen = & actual_x_data%memory_parameter%size_p_screen + nseta*nsetb*natom_a*natom_b i = i + 1 @@ -820,11 +816,11 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin END IF END IF ALLOCATE(actual_x_data%map_atom_to_kind_atom(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom2kind(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of) atom2kind = 0 @@ -834,21 +830,21 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin actual_x_data%map_atom_to_kind_atom(iatom) = atom2kind(ikind) END DO DEALLOCATE(kind_of, atom2kind, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! ** Initialize libint type - CALL initialize_libint(actual_x_data%lib, actual_x_data%basis_info%max_am, error) - CALL initialize_libderiv(actual_x_data%lib_deriv, actual_x_data%basis_info%max_am, error) + CALL initialize_libint(actual_x_data%lib, actual_x_data%basis_info%max_am) + CALL initialize_libderiv(actual_x_data%lib_deriv, actual_x_data%basis_info%max_am) - CALL alloc_containers(actual_x_data, 1, hfx_do_eval_energy, error) - CALL alloc_containers(actual_x_data, 1, hfx_do_eval_forces, error) + CALL alloc_containers(actual_x_data, 1, hfx_do_eval_energy) + CALL alloc_containers(actual_x_data, 1, hfx_do_eval_forces) actual_x_data%maxval_cache_disk%element_counter = 1 ALLOCATE(actual_x_data%maxval_container_disk,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%maxval_container_disk%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) actual_x_data%maxval_container_disk%first%prev => NULL() actual_x_data%maxval_container_disk%first%next => NULL() actual_x_data%maxval_container_disk%current => actual_x_data%maxval_container_disk%first @@ -861,13 +857,13 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin storage_id,"_",actual_x_data%maxval_container_disk%desc, "6" CALL compress(actual_x_data%maxval_container_disk%filename, .TRUE.) ALLOCATE(actual_x_data%integral_containers_disk(64), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,64 actual_x_data%integral_caches_disk(i)%element_counter = 1 actual_x_data%integral_caches_disk(i)%data = 0 - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(actual_x_data%integral_containers_disk(i)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) actual_x_data%integral_containers_disk(i)%first%prev => NULL() actual_x_data%integral_containers_disk(i)%first%next => NULL() actual_x_data%integral_containers_disk(i)%current => actual_x_data%integral_containers_disk(i)%first @@ -889,7 +885,7 @@ SUBROUTINE hfx_create(x_data,para_env, hfx_section,natom,atomic_kind_set, qs_kin DO irep=1,n_rep_hf actual_x_data => x_data(irep,1) - CALL hfx_print_info(actual_x_data, hfx_section, irep, error=error) + CALL hfx_print_info(actual_x_data, hfx_section, irep) END DO CALL timestop(handle) END SUBROUTINE hfx_create @@ -899,17 +895,15 @@ END SUBROUTINE hfx_create !> \param eps target accuracy !> \param omg screening parameter !> \param r_cutoff cutoff radius -!> \param error ... !> \par History !> 10.2012 created [Hossein Banihashemian] !> \author Hossein Banihashemian ! ***************************************************************************** - SUBROUTINE erfc_cutoff(eps,omg,r_cutoff,error) + SUBROUTINE erfc_cutoff(eps,omg,r_cutoff) IMPLICIT NONE REAL(dp), INTENT(in) :: eps, omg REAL(dp), INTENT(out) :: r_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'erfc_cutoff', & routineP = moduleN//':'//routineN @@ -932,7 +926,7 @@ SUBROUTINE erfc_cutoff(eps,omg,r_cutoff,error) CALL eval_transc_func(r0,eps,omg,f0,fprime0) IF (ABS(delta_r) .LT. abstol .OR. ABS(f0) .LT. soltol) EXIT END DO - CPPostcondition(iter<=itermax,cp_failure_level,routineP,error,failure) + CPPostcondition(iter<=itermax,cp_failure_level,routineP,failure) r_cutoff = r0 CALL timestop(handle) @@ -959,18 +953,16 @@ END SUBROUTINE erfc_cutoff !> \param basis_info ... !> \param qs_kind_set ... !> \param do_admm ... -!> \param error ... !> \par History !> 07.2011 refactored ! ***************************************************************************** - SUBROUTINE hfx_create_basis_types(basis_parameter,basis_info, qs_kind_set, do_admm, error) + SUBROUTINE hfx_create_basis_types(basis_parameter,basis_info, qs_kind_set, do_admm) TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: basis_parameter TYPE(hfx_basis_info_type) :: basis_info TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set LOGICAL :: do_admm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_create_basis_types', & routineP = moduleN//':'//routineN @@ -992,23 +984,23 @@ SUBROUTINE hfx_create_basis_types(basis_parameter,basis_info, qs_kind_set, do_ad !! BASIS parameter nkind = SIZE(qs_kind_set,1) ALLOCATE(basis_parameter(nkind), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_set = 0 DO ikind = 1,nkind IF( .NOT. do_admm ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_a, basis_type="ORB", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_a, basis_type="ORB") CALL get_qs_kind_set(qs_kind_set,& maxsgf=basis_info%max_sgf,& maxnset=basis_info%max_set,& - maxlgto=basis_info%max_am, error=error) + maxlgto=basis_info%max_am) ELSE - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_a, basis_type="AUX_FIT", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_a, basis_type="AUX_FIT") CALL get_qs_kind_set(qs_kind_set,& maxsgf=basis_info%max_sgf,& maxnset=basis_info%max_set,& maxlgto=basis_info%max_am,& - basis_type="AUX_FIT", error=error) + basis_type="AUX_FIT") END IF IF (basis_info%max_set \brief ... !> \param basis_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE hfx_release_basis_types(basis_parameter,error) + SUBROUTINE hfx_release_basis_types(basis_parameter) TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: basis_parameter - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_release_basis_types', & routineP = moduleN//':'//routineN @@ -1126,12 +1116,12 @@ SUBROUTINE hfx_release_basis_types(basis_parameter,error) !! BASIS parameter DO i=1,SIZE(basis_parameter) DEALLOCATE(basis_parameter(i)%nsgfl,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_parameter(i)%sphi_ext,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(basis_parameter,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE hfx_release_basis_types @@ -1148,10 +1138,9 @@ END SUBROUTINE hfx_release_basis_types !> \param irep ... !> \param skip_disk ... !> \param skip_in_core_forces ... -!> \param error ... ! ***************************************************************************** SUBROUTINE parse_memory_section(memory_parameter, hf_sub_section, storage_id,& - i_thread, n_threads, para_env, irep, skip_disk, skip_in_core_forces, error) + i_thread, n_threads, para_env, irep, skip_disk, skip_in_core_forces) TYPE(hfx_memory_type) :: memory_parameter TYPE(section_vals_type), POINTER :: hf_sub_section INTEGER, INTENT(OUT), OPTIONAL :: storage_id @@ -1159,7 +1148,6 @@ SUBROUTINE parse_memory_section(memory_parameter, hf_sub_section, storage_id,& TYPE(cp_para_env_type), OPTIONAL :: para_env INTEGER, INTENT(IN), OPTIONAL :: irep LOGICAL, INTENT(IN) :: skip_disk, skip_in_core_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parse_memory_section', & routineP = moduleN//':'//routineN @@ -1175,13 +1163,13 @@ SUBROUTINE parse_memory_section(memory_parameter, hf_sub_section, storage_id,& (PRESENT(storage_id).EQV.PRESENT(n_threads)).AND.& (PRESENT(storage_id).EQV.PRESENT(para_env)) .AND.& (PRESENT(storage_id).EQV.PRESENT(irep)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ! Memory Storage - CALL section_vals_val_get(hf_sub_section, "MAX_MEMORY", i_val=int_val, error=error) + CALL section_vals_val_get(hf_sub_section, "MAX_MEMORY", i_val=int_val) memory_parameter%max_memory = int_val memory_parameter%max_compression_counter = int_val*1024_int_8*128_int_8 - CALL section_vals_val_get(hf_sub_section, "EPS_STORAGE", r_val=real_val, error=error) + CALL section_vals_val_get(hf_sub_section, "EPS_STORAGE", r_val=real_val) memory_parameter%eps_storage_scaling = real_val IF(int_val == 0) THEN memory_parameter%do_all_on_the_fly = .TRUE. @@ -1192,7 +1180,7 @@ SUBROUTINE parse_memory_section(memory_parameter, hf_sub_section, storage_id,& memory_parameter%bits_max_val = BITS_MAX_VAL memory_parameter%actual_memory_usage = 1 IF( .NOT. skip_in_core_forces) THEN - CALL section_vals_val_get(hf_sub_section, "TREAT_FORCES_IN_CORE", l_val=logic_val, error=error) + CALL section_vals_val_get(hf_sub_section, "TREAT_FORCES_IN_CORE", l_val=logic_val) memory_parameter%treat_forces_in_core = logic_val END IF @@ -1202,14 +1190,14 @@ SUBROUTINE parse_memory_section(memory_parameter, hf_sub_section, storage_id,& ! Disk Storage IF (.NOT.skip_disk) THEN memory_parameter%actual_memory_usage_disk = 1 - CALL section_vals_val_get(hf_sub_section, "MAX_DISK_SPACE", i_val=int_val, error=error) + CALL section_vals_val_get(hf_sub_section, "MAX_DISK_SPACE", i_val=int_val) memory_parameter%max_compression_counter_disk = int_val*1024_int_8*128_int_8 IF( int_val == 0 ) THEN memory_parameter%do_disk_storage = .FALSE. ELSE memory_parameter%do_disk_storage = .TRUE. END IF - CALL section_vals_val_get(hf_sub_section, "STORAGE_LOCATION", c_val=char_val, error=error) + CALL section_vals_val_get(hf_sub_section, "STORAGE_LOCATION", c_val=char_val) CALL compress(char_val,.TRUE.) !! Add ending / if necessary @@ -1229,7 +1217,7 @@ SUBROUTINE parse_memory_section(memory_parameter, hf_sub_section, storage_id,& TRIM(filename), ". Please check STORAGE_LOCATION" CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& error_msg , & - error,failure) + failure) END IF CALL m_chdir(orig_wd,stat) @@ -1246,15 +1234,12 @@ END SUBROUTINE parse_memory_section ! ***************************************************************************** !> \brief - This routine deallocates all data structures !> \param x_data contains all relevant data structures for hfx runs -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE hfx_release(x_data, error) + SUBROUTINE hfx_release(x_data) TYPE(hfx_type), DIMENSION(:, :), POINTER :: x_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_release', & routineP = moduleN//':'//routineN @@ -1279,111 +1264,111 @@ SUBROUTINE hfx_release(x_data, error) DO irep=1,n_rep_hf actual_x_data => x_data(irep,i_thread) DEALLOCATE(actual_x_data%neighbor_cells,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%distribution_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%distribution_forces,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( actual_x_data%load_balance_parameter%blocks_initialized ) THEN DEALLOCATE(actual_x_data%blocks,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( i_thread == 1 ) THEN DEALLOCATE(actual_x_data%pmax_block,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF IF( i_thread == 1 ) THEN DEALLOCATE(actual_x_data%atomic_pair_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%atomic_pair_list_forces, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(actual_x_data%screening_parameter%do_initial_p_screening .OR. & actual_x_data%screening_parameter%do_p_screening_forces) THEN IF( i_thread == 1 ) THEN DEALLOCATE(actual_x_data%pmax_atom, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(actual_x_data%initial_p) DEALLOCATE(actual_x_data%initial_p(i)%p_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(actual_x_data%initial_p,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF( actual_x_data%memory_parameter%treat_forces_in_core) THEN DEALLOCATE(actual_x_data%pmax_atom_forces, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(actual_x_data%initial_p_forces) DEALLOCATE(actual_x_data%initial_p_forces(i)%p_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(actual_x_data%initial_p_forces,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF DEALLOCATE(actual_x_data%map_atom_to_kind_atom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF( i_thread == 1 ) THEN DEALLOCATE(actual_x_data%is_assoc_atomic_block,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%atomic_block_offset,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%set_offset,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%block_offset,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !! BASIS parameter - CALL hfx_release_basis_types(actual_x_data%basis_parameter,error) + CALL hfx_release_basis_types(actual_x_data%basis_parameter) !MK Release libint and libderiv data structure CALL terminate_libint(actual_x_data%lib) CALL terminate_libderiv(actual_x_data%lib_deriv) !! Deallocate containers - CALL dealloc_containers(actual_x_data, hfx_do_eval_energy, error) - CALL dealloc_containers(actual_x_data, hfx_do_eval_forces, error) + CALL dealloc_containers(actual_x_data, hfx_do_eval_energy) + CALL dealloc_containers(actual_x_data, hfx_do_eval_forces) !! Deallocate containers CALL hfx_init_container(actual_x_data%maxval_container_disk, & actual_x_data%memory_parameter%actual_memory_usage_disk, & - .FALSE., error) + .FALSE.) IF( actual_x_data%memory_parameter%do_disk_storage) THEN CALL close_file(unit_number=actual_x_data%maxval_container_disk%unit,file_status="DELETE") END IF DEALLOCATE(actual_x_data%maxval_container_disk%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%maxval_container_disk,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,64 CALL hfx_init_container(actual_x_data%integral_containers_disk(i), & actual_x_data%memory_parameter%actual_memory_usage_disk, & - .FALSE., error) + .FALSE.) IF( actual_x_data%memory_parameter%do_disk_storage) THEN CALL close_file(unit_number=actual_x_data%integral_containers_disk(i)%unit,file_status="DELETE") END IF DEALLOCATE(actual_x_data%integral_containers_disk(i)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(actual_x_data%integral_containers_disk,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! ** screening functions IF(actual_x_data%screen_funct_is_initialized) THEN DEALLOCATE(actual_x_data%screen_funct_coeffs_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%screen_funct_coeffs_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%pair_dist_radii_pgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%screen_funct_coeffs_pgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) actual_x_data%screen_funct_is_initialized = .FALSE. END IF @@ -1391,18 +1376,18 @@ SUBROUTINE hfx_release(x_data, error) IF( ASSOCIATED(actual_x_data%map_atoms_to_cpus) ) THEN DO i=1,SIZE(actual_x_data%map_atoms_to_cpus) DEALLOCATE(actual_x_data%map_atoms_to_cpus(i)%iatom_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(actual_x_data%map_atoms_to_cpus(i)%jatom_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(actual_x_data%map_atoms_to_cpus,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO END DO DEALLOCATE(x_data,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE hfx_release ! ***************************************************************************** @@ -1412,19 +1397,15 @@ END SUBROUTINE hfx_release !> \param pbc_shells number of shells taken into account !> \param cell cell !> \param i_thread current thread ID -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & - error) + SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread) TYPE(hfx_type), POINTER :: x_data INTEGER, INTENT(INOUT) :: pbc_shells TYPE(cell_type), POINTER :: cell INTEGER, INTENT(IN) :: i_thread - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_create_neighbor_cells', & routineP = moduleN//':'//routineN @@ -1510,9 +1491,9 @@ SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & total_number_of_cells = 0 ub = 1 DEALLOCATE(x_data%neighbor_cells,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%neighbor_cells(1), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%neighbor_cells(1)%cell = 0.0_dp x_data%neighbor_cells(1)%cell_r = 0.0_dp @@ -1555,15 +1536,15 @@ SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & ! Calculate distances to the eight points P1 to P8 image_cell_found = .FALSE. ALLOCATE(tmp_neighbor_cells(1:ub),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,ub-1 tmp_neighbor_cells(i) = x_data%neighbor_cells(i) END DO ub_max = (2*max_shell+1)**3 DEALLOCATE(x_data%neighbor_cells, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%neighbor_cells(1:ub_max), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,ub-1 x_data%neighbor_cells(i) = tmp_neighbor_cells(i) END DO @@ -1573,7 +1554,7 @@ SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & END DO DEALLOCATE(tmp_neighbor_cells, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ishell=-max_shell,max_shell DO jshell=-max_shell,max_shell @@ -1716,30 +1697,30 @@ SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & END DO ! now remove what is not needed ALLOCATE(tmp_neighbor_cells(total_number_of_cells), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,ub-1 tmp_neighbor_cells(i) = x_data%neighbor_cells(i) END DO DEALLOCATE(x_data%neighbor_cells, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! If we only need the supercell, total_number_of_cells is still 0, repair IF( total_number_of_cells == 0 ) THEN total_number_of_cells = 1 ALLOCATE(x_data%neighbor_cells(total_number_of_cells), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,total_number_of_cells x_data%neighbor_cells(i)%cell = 0.0_dp x_data%neighbor_cells(i)%cell_r = 0.0_dp END DO ELSE ALLOCATE(x_data%neighbor_cells(total_number_of_cells), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,total_number_of_cells x_data%neighbor_cells(i) = tmp_neighbor_cells(i) END DO END IF DEALLOCATE(tmp_neighbor_cells, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(x_data%periodic_parameter%number_of_shells == do_hfx_auto_shells ) THEN ! Do nothing @@ -1759,7 +1740,6 @@ SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& error_msg,& - error,& only_ionode=.TRUE.) END IF END IF @@ -1768,10 +1748,10 @@ SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & total_number_of_cells = total_number_of_cells + count_cells_perd(i,x_data%periodic_parameter%perd) END DO DEALLOCATE(x_data%neighbor_cells, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%neighbor_cells(total_number_of_cells), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) m = 0 i = 1 DO WHILE(SUM(m**2)<=x_data%periodic_parameter%number_of_shells) @@ -1787,10 +1767,10 @@ SUBROUTINE hfx_create_neighbor_cells(x_data, pbc_shells, cell, i_thread, & total_number_of_cells = total_number_of_cells + count_cells_perd(i,x_data%periodic_parameter%perd) END DO DEALLOCATE(x_data%neighbor_cells,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%neighbor_cells(total_number_of_cells), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) m = 0 i = 1 @@ -1905,17 +1885,14 @@ END FUNCTION point_is_in_quadrilateral !> \param container container that contains the compressed elements !> \param memory_usage ... !> \param do_disk_storage ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE hfx_init_container(container, memory_usage, do_disk_storage, error) + SUBROUTINE hfx_init_container(container, memory_usage, do_disk_storage) TYPE(hfx_container_type) :: container INTEGER :: memory_usage LOGICAL :: do_disk_storage - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_init_container', & routineP = moduleN//':'//routineN @@ -1937,7 +1914,7 @@ SUBROUTINE hfx_init_container(container, memory_usage, do_disk_storage, error) !! Allocate first list entry, init members ALLOCATE(container%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) container%first%prev => NULL() container%first%next => NULL() container%current => container%first @@ -1962,17 +1939,14 @@ END SUBROUTINE hfx_init_container !> for the energy !> \param ptr_to_distr contains data to store !> \param x_data contains all relevant data structures for hfx runs -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE hfx_set_distr_energy(ptr_to_distr,x_data, error) + SUBROUTINE hfx_set_distr_energy(ptr_to_distr,x_data) TYPE(hfx_distribution), DIMENSION(:), & POINTER :: ptr_to_distr TYPE(hfx_type), POINTER :: x_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_set_distr_energy', & routineP = moduleN//':'//routineN @@ -1981,10 +1955,10 @@ SUBROUTINE hfx_set_distr_energy(ptr_to_distr,x_data, error) LOGICAL :: failure DEALLOCATE(x_data%distribution_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%distribution_energy(SIZE(ptr_to_distr)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%distribution_energy = ptr_to_distr END SUBROUTINE hfx_set_distr_energy @@ -1994,17 +1968,14 @@ END SUBROUTINE hfx_set_distr_energy !> for the forces !> \param ptr_to_distr contains data to store !> \param x_data contains all relevant data structures for hfx runs -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE hfx_set_distr_forces(ptr_to_distr, x_data, error) + SUBROUTINE hfx_set_distr_forces(ptr_to_distr, x_data) TYPE(hfx_distribution), DIMENSION(:), & POINTER :: ptr_to_distr TYPE(hfx_type), POINTER :: x_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_set_distr_forces', & routineP = moduleN//':'//routineN @@ -2013,10 +1984,10 @@ SUBROUTINE hfx_set_distr_forces(ptr_to_distr, x_data, error) LOGICAL :: failure DEALLOCATE(x_data%distribution_forces,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%distribution_forces(SIZE(ptr_to_distr)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%distribution_forces = ptr_to_distr END SUBROUTINE hfx_set_distr_forces @@ -2054,27 +2025,24 @@ END SUBROUTINE hfx_reset_memory_usage_counter !> \param x_data contains all relevant data structures for hfx runs !> \param hfx_section HFX input section !> \param i_rep current replica ID -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE hfx_print_info(x_data, hfx_section, i_rep, error) + SUBROUTINE hfx_print_info(x_data, hfx_section, i_rep) TYPE(hfx_type), POINTER :: x_data TYPE(section_vals_type), POINTER :: hfx_section INTEGER, INTENT(IN) :: i_rep - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iw REAL(dp) :: rc_ang TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,hfx_section,"HF_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE (UNIT=iw,FMT="(/,(T3,A,T61,I20))")& "HFX_INFO| Replica ID: ",i_rep @@ -2099,7 +2067,7 @@ SUBROUTINE hfx_print_info(x_data, hfx_section, i_rep, error) "HFX_INFO| Interaction Potential: ", "SHORTRANGE" WRITE(iw,'(T3,A,T61,F20.10)') & "HFX_INFO| Omega: ", x_data%potential_parameter%omega - rc_ang = cp_unit_from_cp2k(x_data%potential_parameter%cutoff_radius,"angstrom",error=error) + rc_ang = cp_unit_from_cp2k(x_data%potential_parameter%cutoff_radius,"angstrom") WRITE(iw,'(T3,A,T61,F20.10)') & "HFX_INFO| Cutoff Radius [angstrom]: ", rc_ang CASE(do_hfx_potential_long) @@ -2136,13 +2104,13 @@ SUBROUTINE hfx_print_info(x_data, hfx_section, i_rep, error) CASE(do_hfx_potential_truncated) WRITE (UNIT=iw,FMT="((T3,A,T72,A))")& "HFX_INFO| Interaction Potential: ", "TRUNCATED" - rc_ang = cp_unit_from_cp2k(x_data%potential_parameter%cutoff_radius,"angstrom",error=error) + rc_ang = cp_unit_from_cp2k(x_data%potential_parameter%cutoff_radius,"angstrom") WRITE(iw,'(T3,A,T61,F20.10)') & "HFX_INFO| Cutoff Radius [angstrom]: ", rc_ang CASE(do_hfx_potential_mix_cl_trunc) WRITE (UNIT=iw,FMT="((T3,A,T65,A))")& "HFX_INFO| Interaction Potential: ", "TRUNCATED MIX_CL" - rc_ang = cp_unit_from_cp2k(x_data%potential_parameter%cutoff_radius,"angstrom",error=error) + rc_ang = cp_unit_from_cp2k(x_data%potential_parameter%cutoff_radius,"angstrom") WRITE(iw,'(T3,A,T61,F20.10)') & "HFX_INFO| Cutoff Radius [angstrom]: ", rc_ang END SELECT @@ -2166,19 +2134,17 @@ SUBROUTINE hfx_print_info(x_data, hfx_section, i_rep, error) END IF END IF CALL cp_print_key_finished_output(iw,logger,hfx_section,& - "HF_INFO", error=error) + "HF_INFO") END SUBROUTINE hfx_print_info ! ***************************************************************************** !> \brief ... !> \param x_data ... !> \param eval_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dealloc_containers(x_data, eval_type, error) + SUBROUTINE dealloc_containers(x_data, eval_type) TYPE(hfx_type), POINTER :: x_data INTEGER, INTENT(IN) :: eval_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dealloc_containers', & routineP = moduleN//':'//routineN @@ -2193,53 +2159,53 @@ SUBROUTINE dealloc_containers(x_data, eval_type, error) CASE (hfx_do_eval_energy) DO bin=1,SIZE(x_data%maxval_container) CALL hfx_init_container(x_data%maxval_container(bin), x_data%memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) DEALLOCATE(x_data%maxval_container(bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(x_data%maxval_container,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(x_data%maxval_cache,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,SIZE(x_data%integral_containers,2) DO i=1,64 CALL hfx_init_container(x_data%integral_containers(i,bin), x_data%memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) DEALLOCATE(x_data%integral_containers(i,bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO END DO DEALLOCATE(x_data%integral_containers,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(x_data%integral_caches, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE (hfx_do_eval_forces) DO bin=1,SIZE(x_data%maxval_container_forces) CALL hfx_init_container(x_data%maxval_container_forces(bin), x_data%memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) DEALLOCATE(x_data%maxval_container_forces(bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(x_data%maxval_container_forces,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(x_data%maxval_cache_forces,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,SIZE(x_data%integral_containers_forces,2) DO i=1,64 CALL hfx_init_container(x_data%integral_containers_forces(i,bin), x_data%memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) DEALLOCATE(x_data%integral_containers_forces(i,bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO END DO DEALLOCATE(x_data%integral_containers_forces,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(x_data%integral_caches_forces, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT @@ -2250,12 +2216,10 @@ END SUBROUTINE dealloc_containers !> \param x_data ... !> \param bin_size ... !> \param eval_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE alloc_containers(x_data, bin_size, eval_type, error) + SUBROUTINE alloc_containers(x_data, bin_size, eval_type) TYPE(hfx_type), POINTER :: x_data INTEGER, INTENT(IN) :: bin_size, eval_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'alloc_containers', & routineP = moduleN//':'//routineN @@ -2269,15 +2233,15 @@ SUBROUTINE alloc_containers(x_data, bin_size, eval_type, error) SELECT CASE(eval_type) CASE (hfx_do_eval_energy) ALLOCATE(x_data%maxval_cache(bin_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,bin_size x_data%maxval_cache(bin)%element_counter = 1 END DO ALLOCATE(x_data%maxval_container(bin_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,bin_size ALLOCATE(x_data%maxval_container(bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%maxval_container(bin)%first%prev => NULL() x_data%maxval_container(bin)%first%next => NULL() x_data%maxval_container(bin)%current => x_data%maxval_container(bin)%first @@ -2286,16 +2250,16 @@ SUBROUTINE alloc_containers(x_data, bin_size, eval_type, error) END DO ALLOCATE(x_data%integral_containers(64,bin_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%integral_caches(64,bin_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,bin_size DO i=1,64 x_data%integral_caches(i,bin)%element_counter = 1 x_data%integral_caches(i,bin)%data = 0 ALLOCATE(x_data%integral_containers(i,bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%integral_containers(i,bin)%first%prev => NULL() x_data%integral_containers(i,bin)%first%next => NULL() x_data%integral_containers(i,bin)%current => x_data%integral_containers(i,bin)%first @@ -2305,15 +2269,15 @@ SUBROUTINE alloc_containers(x_data, bin_size, eval_type, error) END DO CASE (hfx_do_eval_forces) ALLOCATE(x_data%maxval_cache_forces(bin_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,bin_size x_data%maxval_cache_forces(bin)%element_counter = 1 END DO ALLOCATE(x_data%maxval_container_forces(bin_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,bin_size ALLOCATE(x_data%maxval_container_forces(bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%maxval_container_forces(bin)%first%prev => NULL() x_data%maxval_container_forces(bin)%first%next => NULL() x_data%maxval_container_forces(bin)%current => x_data%maxval_container_forces(bin)%first @@ -2322,16 +2286,16 @@ SUBROUTINE alloc_containers(x_data, bin_size, eval_type, error) END DO ALLOCATE(x_data%integral_containers_forces(64,bin_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(x_data%integral_caches_forces(64,bin_size), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO bin = 1,bin_size DO i=1,64 x_data%integral_caches_forces(i,bin)%element_counter = 1 x_data%integral_caches_forces(i,bin)%data = 0 ALLOCATE(x_data%integral_containers_forces(i,bin)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_data%integral_containers_forces(i,bin)%first%prev => NULL() x_data%integral_containers_forces(i,bin)%first%next => NULL() x_data%integral_containers_forces(i,bin)%current => x_data%integral_containers_forces(i,bin)%first diff --git a/src/hirshfeld_methods.F b/src/hirshfeld_methods.F index 1593e777ab..1fdc9dbabf 100644 --- a/src/hirshfeld_methods.F +++ b/src/hirshfeld_methods.F @@ -79,10 +79,9 @@ MODULE hirshfeld_methods !> \param particle_set ... !> \param qs_kind_set ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** SUBROUTINE write_hirshfeld_charges(charges,hirshfeld_env,particle_set,& - qs_kind_set,unit_nr,error) + qs_kind_set,unit_nr) REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: charges TYPE(hirshfeld_type), POINTER :: hirshfeld_env @@ -91,7 +90,6 @@ SUBROUTINE write_hirshfeld_charges(charges,hirshfeld_env,particle_set,& TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_hirshfeld_charges', & routineP = moduleN//':'//routineN @@ -116,7 +114,7 @@ SUBROUTINE write_hirshfeld_charges(charges,hirshfeld_env,particle_set,& CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind,& element_symbol=element_symbol,kind_number=ikind) refc = hirshfeld_env%charges(iatom) - CALL get_qs_kind(qs_kind_set(ikind),zeff=zeff,error=error) + CALL get_qs_kind(qs_kind_set(ikind),zeff=zeff) IF (nspin == 1) THEN WRITE (UNIT=unit_nr,FMT="(i7,T15,A2,T20,i3,T27,F8.3,T42,F8.3,T72,F8.3)") & iatom,element_symbol,ikind,refc,charges(iatom,1),zeff-charges(iatom,1) @@ -137,15 +135,13 @@ END SUBROUTINE write_hirshfeld_charges !> \param hirshfeld_env ... !> \param qs_kind_set ... !> \param atomic_kind_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_shape_function(hirshfeld_env,qs_kind_set,atomic_kind_set,error) + SUBROUTINE create_shape_function(hirshfeld_env,qs_kind_set,atomic_kind_set) TYPE(hirshfeld_type), POINTER :: hirshfeld_env TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_shape_function', & routineP = moduleN//':'//routineN @@ -160,21 +156,21 @@ SUBROUTINE create_shape_function(hirshfeld_env,qs_kind_set,atomic_kind_set,error TYPE(qs_kind_type), POINTER :: qs_kind failure = .FALSE. - CPPrecondition(ASSOCIATED(hirshfeld_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(hirshfeld_env),cp_failure_level,routineP,failure) nkind = SIZE(qs_kind_set) ALLOCATE(hirshfeld_env%kind_shape_fn(nkind), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE(hirshfeld_env%shape_function_type) CASE (shape_function_gaussian) DO ikind=1,nkind hirshfeld_env%kind_shape_fn(ikind)%numexp = 1 ALLOCATE(hirshfeld_env%kind_shape_fn(ikind)%zet(1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(hirshfeld_env%kind_shape_fn(ikind)%coef(1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL get_qs_kind(qs_kind_set(ikind),element_symbol=esym,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL get_qs_kind(qs_kind_set(ikind),element_symbol=esym) rco = 2.0_dp CALL get_ptable_info(symbol=esym,covalent_radius=rco,found=found) rco = MAX(rco,1.0_dp) @@ -188,21 +184,21 @@ SUBROUTINE create_shape_function(hirshfeld_env,qs_kind_set,atomic_kind_set,error atomic_kind => atomic_kind_set(ikind) qs_kind => qs_kind_set(ikind) CALL calculate_atomic_density(ppdens(:,:),atomic_kind,qs_kind,ngto,& - confine=.FALSE.,error=error) + confine=.FALSE.) hirshfeld_env%kind_shape_fn(ikind)%numexp = ngto ALLOCATE(hirshfeld_env%kind_shape_fn(ikind)%zet(ngto), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(hirshfeld_env%kind_shape_fn(ikind)%coef(ngto), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) hirshfeld_env%kind_shape_fn(ikind)%zet(:) = ppdens(:,1) - CALL get_qs_kind(qs_kind,zeff=zeff,error=error) + CALL get_qs_kind(qs_kind,zeff=zeff) hirshfeld_env%kind_shape_fn(ikind)%coef(:) = ppdens(:,2)/zeff END DO CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Unknown shape function", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END SUBROUTINE create_shape_function @@ -212,14 +208,12 @@ END SUBROUTINE create_shape_function !> \param qs_env ... !> \param hirshfeld_env ... !> \param charges ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE comp_hirshfeld_charges(qs_env,hirshfeld_env,charges,error) + SUBROUTINE comp_hirshfeld_charges(qs_env,hirshfeld_env,charges) TYPE(qs_environment_type), POINTER :: qs_env TYPE(hirshfeld_type), POINTER :: hirshfeld_env REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: charges - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'comp_hirshfeld_charges', & routineP = moduleN//':'//routineN @@ -236,34 +230,34 @@ SUBROUTINE comp_hirshfeld_charges(qs_env,hirshfeld_env,charges,error) NULLIFY(rho_r) failure = .FALSE. ! normalization function on grid - CALL calculate_hirshfeld_normalization(qs_env,hirshfeld_env,error) + CALL calculate_hirshfeld_normalization(qs_env,hirshfeld_env) ! check normalization - tnfun = pw_integrate_function(hirshfeld_env%fnorm%pw,error=error) + tnfun = pw_integrate_function(hirshfeld_env%fnorm%pw) tnfun = ABS(tnfun - SUM(hirshfeld_env%charges)) ! ALLOCATE(rhonorm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,rho=rho,error=error) - CALL qs_rho_get(rho, rho_r=rho_r, rho_r_valid=rho_r_valid, error=error) - CALL pw_env_get(pw_env=pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool,rhonorm%pw,use_data=REALDATA3D,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,rho=rho) + CALL qs_rho_get(rho, rho_r=rho_r, rho_r_valid=rho_r_valid) + CALL pw_env_get(pw_env=pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool,rhonorm%pw,use_data=REALDATA3D) ! loop over spins DO is=1,SIZE(rho_r) IF(rho_r_valid) THEN CALL hfun_scale(rhonorm%pw%cr3d,rho_r(is)%pw%cr3d,& - hirshfeld_env%fnorm%pw%cr3d,error) + hirshfeld_env%fnorm%pw%cr3d) ELSE CALL cp_unimplemented_error(fromWhere=routineP, & - message="We need rho in real space",error=error,error_level=cp_failure_level) + message="We need rho in real space",error_level=cp_failure_level) END IF - CALL hirshfeld_integration(qs_env,hirshfeld_env,rhonorm,charges(:,is),error=error) + CALL hirshfeld_integration(qs_env,hirshfeld_env,rhonorm,charges(:,is)) charges(:,is) = charges(:,is)*hirshfeld_env%charges(:) END DO - CALL pw_pool_give_back_pw(auxbas_pw_pool,rhonorm%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rhonorm%pw) ! DEALLOCATE(rhonorm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE comp_hirshfeld_charges ! ***************************************************************************** @@ -271,14 +265,12 @@ END SUBROUTINE comp_hirshfeld_charges !> \param fout ... !> \param fun1 ... !> \param fun2 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE hfun_scale(fout,fun1,fun2,error) + SUBROUTINE hfun_scale(fout,fun1,fun2) REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(OUT) :: fout REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(IN) :: fun1, fun2 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hfun_scale', & routineP = moduleN//':'//routineN @@ -291,12 +283,12 @@ SUBROUTINE hfun_scale(fout,fun1,fun2,error) n1 = SIZE(fout,1) n2 = SIZE(fout,2) n3 = SIZE(fout,3) - CPPrecondition(n1==SIZE(fun1,1),cp_failure_level,routineP,error,failure) - CPPrecondition(n2==SIZE(fun1,2),cp_failure_level,routineP,error,failure) - CPPrecondition(n3==SIZE(fun1,3),cp_failure_level,routineP,error,failure) - CPPrecondition(n1==SIZE(fun2,1),cp_failure_level,routineP,error,failure) - CPPrecondition(n2==SIZE(fun2,2),cp_failure_level,routineP,error,failure) - CPPrecondition(n3==SIZE(fun2,3),cp_failure_level,routineP,error,failure) + CPPrecondition(n1==SIZE(fun1,1),cp_failure_level,routineP,failure) + CPPrecondition(n2==SIZE(fun1,2),cp_failure_level,routineP,failure) + CPPrecondition(n3==SIZE(fun1,3),cp_failure_level,routineP,failure) + CPPrecondition(n1==SIZE(fun2,1),cp_failure_level,routineP,failure) + CPPrecondition(n2==SIZE(fun2,2),cp_failure_level,routineP,failure) + CPPrecondition(n3==SIZE(fun2,3),cp_failure_level,routineP,failure) DO i3=1,n3 DO i2=1,n2 @@ -318,15 +310,13 @@ END SUBROUTINE hfun_scale !> \param hirshfeld_env ... !> \param charges ... !> \param ounit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE comp_hirshfeld_i_charges(qs_env,hirshfeld_env,charges,ounit,error) + SUBROUTINE comp_hirshfeld_i_charges(qs_env,hirshfeld_env,charges,ounit) TYPE(qs_environment_type), POINTER :: qs_env TYPE(hirshfeld_type), POINTER :: hirshfeld_env REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: charges INTEGER, INTENT(IN) :: ounit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'comp_hirshfeld_i_charges', & routineP = moduleN//':'//routineN @@ -351,30 +341,30 @@ SUBROUTINE comp_hirshfeld_i_charges(qs_env,hirshfeld_env,charges,ounit,error) IF(ounit>0) WRITE(ounit,"(/,T2,A)") "Hirshfeld charge iterations: Residuals ..." ! ALLOCATE(rhonorm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,rho=rho,error=error) - CALL qs_rho_get(rho, rho_r=rho_r, rho_r_valid=rho_r_valid, error=error) - CALL pw_env_get(pw_env=pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool,rhonorm%pw,use_data=REALDATA3D,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,rho=rho) + CALL qs_rho_get(rho, rho_r=rho_r, rho_r_valid=rho_r_valid) + CALL pw_env_get(pw_env=pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool,rhonorm%pw,use_data=REALDATA3D) ! DO iloop=1,maxloop ! normalization function on grid - CALL calculate_hirshfeld_normalization(qs_env,hirshfeld_env,error) + CALL calculate_hirshfeld_normalization(qs_env,hirshfeld_env) ! check normalization - tnfun = pw_integrate_function(hirshfeld_env%fnorm%pw,error=error) + tnfun = pw_integrate_function(hirshfeld_env%fnorm%pw) tnfun = ABS(tnfun - SUM(hirshfeld_env%charges)) ! loop over spins DO is=1,SIZE(rho_r) IF(rho_r_valid) THEN CALL hfun_scale(rhonorm%pw%cr3d,rho_r(is)%pw%cr3d,& - hirshfeld_env%fnorm%pw%cr3d,error) + hirshfeld_env%fnorm%pw%cr3d) ELSE CALL cp_unimplemented_error(fromWhere=routineP, & - message="We need rho in real space",error=error,error_level=cp_failure_level) + message="We need rho in real space",error_level=cp_failure_level) END IF - CALL hirshfeld_integration(qs_env,hirshfeld_env,rhonorm,charges(:,is),error=error) + CALL hirshfeld_integration(qs_env,hirshfeld_env,rhonorm,charges(:,is)) charges(:,is) = charges(:,is)*hirshfeld_env%charges(:) END DO ! residual @@ -396,10 +386,10 @@ SUBROUTINE comp_hirshfeld_i_charges(qs_env,hirshfeld_env,charges,ounit,error) END DO ! - CALL pw_pool_give_back_pw(auxbas_pw_pool,rhonorm%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rhonorm%pw) ! DEALLOCATE(rhonorm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE comp_hirshfeld_i_charges @@ -407,13 +397,11 @@ END SUBROUTINE comp_hirshfeld_i_charges !> \brief !> \param qs_env ... !> \param hirshfeld_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_hirshfeld_normalization(qs_env,hirshfeld_env,error) + SUBROUTINE calculate_hirshfeld_normalization(qs_env,hirshfeld_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(hirshfeld_type), POINTER :: hirshfeld_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'calculate_hirshfeld_normalization', & @@ -445,17 +433,17 @@ SUBROUTINE calculate_hirshfeld_normalization(qs_env,hirshfeld_env,error) failure = .FALSE. CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,cell=cell,& - dft_control=dft_control,particle_set=particle_set,pw_env=pw_env,error=error) + dft_control=dft_control,particle_set=particle_set,pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_desc=auxbas_rs_desc,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) + auxbas_pw_pool=auxbas_pw_pool) cube_info=pw_env%cube_info(1) ! be careful in parallel nsmax is choosen with multigrid in mind! - CALL rs_grid_retain(rs_rho,error=error) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace ALLOCATE(pab(1,1),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) nthread = 1 ithread = 0 @@ -464,7 +452,7 @@ SUBROUTINE calculate_hirshfeld_normalization(qs_env,hirshfeld_env,error) IF ( numexp <= 0 ) CYCLE CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) ALLOCATE(cores(natom),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO iex=1,numexp alpha=hirshfeld_env%kind_shape_fn(ikind)%zet(iex) @@ -494,31 +482,31 @@ SUBROUTINE calculate_hirshfeld_normalization(qs_env,hirshfeld_env,error) CALL collocate_pgf_product_rspace(0,alpha,0,0,0.0_dp,0,ra,& (/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,1.0_dp,pab,0,0,rs_rho,& cell,cube_info,eps_rho_rspace,ga_gb_function=FUNC_AB,& - ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) END DO END DO DEALLOCATE(cores,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END DO DEALLOCATE (pab,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) NULLIFY(fnorm) - CALL get_hirshfeld_info(hirshfeld_env,fnorm=fnorm,error=error) + CALL get_hirshfeld_info(hirshfeld_env,fnorm=fnorm) IF (ASSOCIATED(fnorm)) THEN - CALL pw_release(fnorm%pw,error=error) + CALL pw_release(fnorm%pw) DEALLOCATE(fnorm,stat=ierr) - CPPostconditionNoFail(ierr==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(ierr==0,cp_failure_level,routineP) ENDIF ALLOCATE(fnorm,stat=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) - CALL pw_pool_create_pw(auxbas_pw_pool,fnorm%pw,use_data=REALDATA3D,error=error) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) + CALL pw_pool_create_pw(auxbas_pw_pool,fnorm%pw,use_data=REALDATA3D) fnorm%pw%in_space=REALSPACE - CALL set_hirshfeld_info(hirshfeld_env,fnorm=fnorm,error=error) + CALL set_hirshfeld_info(hirshfeld_env,fnorm=fnorm) - CALL rs_pw_transfer(rs_rho,fnorm%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho,error=error) + CALL rs_pw_transfer(rs_rho,fnorm%pw,rs2pw) + CALL rs_grid_release(rs_rho) CALL timestop(handle) @@ -531,9 +519,8 @@ END SUBROUTINE calculate_hirshfeld_normalization !> \param rfun ... !> \param fval ... !> \param fderiv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE hirshfeld_integration(qs_env,hirshfeld_env,rfun,fval,fderiv,error) + SUBROUTINE hirshfeld_integration(qs_env,hirshfeld_env,rfun,fval,fderiv) TYPE(qs_environment_type), POINTER :: qs_env TYPE(hirshfeld_type), POINTER :: hirshfeld_env @@ -542,7 +529,6 @@ SUBROUTINE hirshfeld_integration(qs_env,hirshfeld_env,rfun,fval,fderiv,error) INTENT(inout) :: fval REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout), OPTIONAL :: fderiv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hirshfeld_integration', & routineP = moduleN//':'//routineN @@ -576,27 +562,27 @@ SUBROUTINE hirshfeld_integration(qs_env,hirshfeld_env,rfun,fval,fderiv,error) dvol = rfun%pw%pw_grid%dvol NULLIFY(pw_env,auxbas_rs_desc) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) CALL pw_env_get(pw_env=pw_env,auxbas_rs_desc=auxbas_rs_desc, & - auxbas_rs_grid=rs_v,error=error) - CALL rs_grid_retain(rs_v,error=error) - CALL rs_pw_transfer(rs_v,rfun%pw,pw2rs,error=error) + auxbas_rs_grid=rs_v) + CALL rs_grid_retain(rs_v) + CALL rs_pw_transfer(rs_v,rfun%pw,pw2rs) CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,cell=cell,& - dft_control=dft_control,particle_set=particle_set,error=error) + dft_control=dft_control,particle_set=particle_set) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace nthread = 1 ithread = 0 ALLOCATE(hab(1,1),pab(1,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,SIZE(atomic_kind_set) numexp = hirshfeld_env%kind_shape_fn(ikind)%numexp IF ( numexp <= 0 ) CYCLE CALL get_atomic_kind(atomic_kind_set(ikind),natom=natom,atom_list=atom_list) ALLOCATE(cores(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iex=1,numexp alpha=hirshfeld_env%kind_shape_fn(ikind)%zet(iex) @@ -632,7 +618,7 @@ SUBROUTINE hirshfeld_integration(qs_env,hirshfeld_env,rfun,fval,fderiv,error) rs_v,cell,pw_env%cube_info(1),hab,pab=pab,o1=0,o2=0,& eps_gvg_rspace=eps_rho_rspace,calculate_forces=do_force,& force_a=force_a,force_b=force_b,use_virial=.FALSE.,& - use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + use_subpatch=.TRUE.,subpatch_pattern=0_int_8) fval(atom_a) = fval(atom_a) + hab(1,1)*dvol*coef IF(do_force) THEN fderiv(:,atom_a) = fderiv(:,atom_a) + force_a(:)*dvol @@ -641,15 +627,15 @@ SUBROUTINE hirshfeld_integration(qs_env,hirshfeld_env,rfun,fval,fderiv,error) END DO DEALLOCATE(cores,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) DEALLOCATE(hab,pab,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env=qs_env,para_env=para_env,error=error) + CALL get_qs_env(qs_env=qs_env,para_env=para_env) CALL mp_sum(fval,para_env%group) CALL timestop(handle) diff --git a/src/hirshfeld_types.F b/src/hirshfeld_types.F index a6ff595c7d..4c2c370fcc 100644 --- a/src/hirshfeld_types.F +++ b/src/hirshfeld_types.F @@ -57,11 +57,9 @@ MODULE hirshfeld_types ! ***************************************************************************** !> \brief ... !> \param hirshfeld_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_hirshfeld_type(hirshfeld_env,error) + SUBROUTINE create_hirshfeld_type(hirshfeld_env) TYPE(hirshfeld_type), POINTER :: hirshfeld_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_hirshfeld_type', & routineP = moduleN//':'//routineN @@ -72,11 +70,11 @@ SUBROUTINE create_hirshfeld_type(hirshfeld_env,error) failure = .FALSE. IF(ASSOCIATED(hirshfeld_env)) THEN - CALL release_hirshfeld_type(hirshfeld_env,error) + CALL release_hirshfeld_type(hirshfeld_env) END IF ALLOCATE(hirshfeld_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) hirshfeld_env%iterative = .FALSE. hirshfeld_env%shape_function_type = shape_function_gaussian @@ -89,11 +87,9 @@ END SUBROUTINE create_hirshfeld_type ! ***************************************************************************** !> \brief ... !> \param hirshfeld_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_hirshfeld_type(hirshfeld_env,error) + SUBROUTINE release_hirshfeld_type(hirshfeld_env) TYPE(hirshfeld_type), POINTER :: hirshfeld_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_hirshfeld_type', & routineP = moduleN//':'//routineN @@ -111,30 +107,30 @@ SUBROUTINE release_hirshfeld_type(hirshfeld_env,error) DO ikind=1,SIZE(kind_shape) IF(ASSOCIATED(hirshfeld_env%kind_shape_fn(ikind)%zet)) THEN DEALLOCATE(kind_shape(ikind)%zet, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(hirshfeld_env%kind_shape_fn(ikind)%coef)) THEN DEALLOCATE(kind_shape(ikind)%coef, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(kind_shape, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(hirshfeld_env%charges)) THEN DEALLOCATE(hirshfeld_env%charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(hirshfeld_env%fnorm)) THEN - CALL pw_release(hirshfeld_env%fnorm%pw,error=error) + CALL pw_release(hirshfeld_env%fnorm%pw) DEALLOCATE(hirshfeld_env%fnorm,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF DEALLOCATE(hirshfeld_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -147,16 +143,14 @@ END SUBROUTINE release_hirshfeld_type !> \param iterative ... !> \param ref_charge ... !> \param fnorm ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_hirshfeld_info(hirshfeld_env,shape_function_type,iterative,& - ref_charge,fnorm,error) + ref_charge,fnorm) TYPE(hirshfeld_type), POINTER :: hirshfeld_env INTEGER, INTENT(OUT), OPTIONAL :: shape_function_type LOGICAL, INTENT(OUT), OPTIONAL :: iterative INTEGER, INTENT(OUT), OPTIONAL :: ref_charge TYPE(pw_p_type), OPTIONAL, POINTER :: fnorm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_hirshfeld_info', & routineP = moduleN//':'//routineN @@ -164,7 +158,7 @@ SUBROUTINE get_hirshfeld_info(hirshfeld_env,shape_function_type,iterative,& LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(hirshfeld_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(hirshfeld_env),cp_failure_level,routineP,failure) IF(PRESENT(shape_function_type)) THEN shape_function_type = hirshfeld_env%shape_function_type @@ -188,16 +182,14 @@ END SUBROUTINE get_hirshfeld_info !> \param iterative ... !> \param ref_charge ... !> \param fnorm ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_hirshfeld_info(hirshfeld_env,shape_function_type,iterative,& - ref_charge,fnorm,error) + ref_charge,fnorm) TYPE(hirshfeld_type), POINTER :: hirshfeld_env INTEGER, INTENT(IN), OPTIONAL :: shape_function_type LOGICAL, INTENT(IN), OPTIONAL :: iterative INTEGER, INTENT(IN), OPTIONAL :: ref_charge TYPE(pw_p_type), OPTIONAL, POINTER :: fnorm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_hirshfeld_info', & routineP = moduleN//':'//routineN @@ -205,7 +197,7 @@ SUBROUTINE set_hirshfeld_info(hirshfeld_env,shape_function_type,iterative,& LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(hirshfeld_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(hirshfeld_env),cp_failure_level,routineP,failure) IF(PRESENT(shape_function_type)) THEN hirshfeld_env%shape_function_type = shape_function_type diff --git a/src/input/cp_linked_list_char.F b/src/input/cp_linked_list_char.F index 7849fb2f24..7f46afd2d6 100644 --- a/src/input/cp_linked_list_char.F +++ b/src/input/cp_linked_list_char.F @@ -3,8 +3,8 @@ ! Copyright (C) 2000 - 2015 CP2K developers group ! !-----------------------------------------------------------------------------! -#define CP_SLL_C_LESS_Q(el1,el2,error) ( el1 < el2 ) -#define CP_SLL_C_EQUAL_Q(el1,el2,error) ( el1 == el2 ) +#define CP_SLL_C_LESS_Q(el1,el2) ( el1 < el2 ) +#define CP_SLL_C_EQUAL_Q(el1,el2) ( el1 == el2 ) ! ***************************************************************************** @@ -203,12 +203,10 @@ MODULE cp_linked_list_char !> \brief ... !> \param str ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE write_string(str,unit_nr,error) +SUBROUTINE write_string(str,unit_nr) CHARACTER(len=*), INTENT(in) :: str INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error WRITE(unit_nr,"(a,a,a)") '"',TRIM(str),'"' END SUBROUTINE write_string @@ -220,19 +218,16 @@ END SUBROUTINE write_string !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_char_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_char_create(sll,first_el,rest) TYPE(cp_sll_char_type), POINTER :: sll CHARACTER(len=default_string_length), & INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_char_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_create', & routineP = moduleN//':'//routineN @@ -247,7 +242,7 @@ SUBROUTINE cp_sll_char_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el = first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -258,8 +253,6 @@ END SUBROUTINE cp_sll_char_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -267,14 +260,13 @@ END SUBROUTINE cp_sll_char_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_char_dealloc(sll,error) + SUBROUTINE cp_sll_char_dealloc(sll) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_char_rm_all_el(sll,error) + CALL cp_sll_char_rm_all_el(sll) END SUBROUTINE cp_sll_char_dealloc ! * low-level * @@ -282,15 +274,12 @@ END SUBROUTINE cp_sll_char_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_char_dealloc_node(sll,error) + SUBROUTINE cp_sll_char_dealloc_node(sll) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_dealloc_node', & routineP = moduleN//':'//routineN @@ -301,7 +290,7 @@ SUBROUTINE cp_sll_char_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_char_dealloc_node ! ============= get/set ============ @@ -313,19 +302,16 @@ END SUBROUTINE cp_sll_char_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_char_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_char_set(sll,first_el,rest) TYPE(cp_sll_char_type), POINTER :: sll CHARACTER(len=default_string_length), & INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_char_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_set', & routineP = moduleN//':'//routineN @@ -336,9 +322,9 @@ SUBROUTINE cp_sll_char_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_char_create(sll,first_el,rest,error) + CALL cp_sll_char_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el = first_el @@ -353,13 +339,11 @@ END SUBROUTINE cp_sll_char_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_char_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_char_get(sll,first_el,rest,empty,length) TYPE(cp_sll_char_type), POINTER :: sll CHARACTER(len=default_string_length), & INTENT(out), OPTIONAL :: first_el @@ -367,7 +351,6 @@ SUBROUTINE cp_sll_char_get(sll,first_el,rest,empty,length,error) POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get', & routineP = moduleN//':'//routineN @@ -377,7 +360,7 @@ SUBROUTINE cp_sll_char_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -386,23 +369,20 @@ SUBROUTINE cp_sll_char_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_char_get_length(sll,error=error) + length = cp_sll_char_get_length(sll) END IF END SUBROUTINE cp_sll_char_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_char_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_char_get_first_el(sll) RESULT(res) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=default_string_length) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_first_el', & @@ -413,7 +393,7 @@ FUNCTION cp_sll_char_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res = sll%first_el @@ -424,8 +404,6 @@ END FUNCTION cp_sll_char_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -433,10 +411,9 @@ END FUNCTION cp_sll_char_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_char_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_char_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_char_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_char_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_rest', & @@ -459,7 +436,7 @@ FUNCTION cp_sll_char_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -477,16 +454,13 @@ END FUNCTION cp_sll_char_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_char_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_char_get_empty(sll) RESULT(res) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_empty', & @@ -498,8 +472,6 @@ END FUNCTION cp_sll_char_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -507,9 +479,8 @@ END FUNCTION cp_sll_char_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_char_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_char_get_length(sll) RESULT(res) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_length', & @@ -533,8 +504,6 @@ END FUNCTION cp_sll_char_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -542,10 +511,9 @@ END FUNCTION cp_sll_char_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_char_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_char_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_char_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=default_string_length) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_get_el_at', & @@ -557,14 +525,14 @@ FUNCTION cp_sll_char_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_char_get_rest(sll, iter=-1,error=error) + pos => cp_sll_char_get_rest(sll, iter=-1) ELSE - pos => cp_sll_char_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_char_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res = pos%first_el END FUNCTION cp_sll_char_get_el_at @@ -575,20 +543,17 @@ END FUNCTION cp_sll_char_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_char_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_char_set_el_at(sll,index,value) TYPE(cp_sll_char_type), POINTER :: sll INTEGER, INTENT(in) :: index CHARACTER(len=default_string_length), & INTENT(in) :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_set_el_at', & routineP = moduleN//':'//routineN @@ -599,11 +564,11 @@ SUBROUTINE cp_sll_char_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_char_get_rest(sll, iter=-1,error=error) + pos => cp_sll_char_get_rest(sll, iter=-1) ELSE - pos => cp_sll_char_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_char_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el = value END SUBROUTINE cp_sll_char_set_el_at @@ -615,18 +580,15 @@ END SUBROUTINE cp_sll_char_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_char_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_char_next(iterator,el_att) RESULT(res) TYPE(cp_sll_char_type), POINTER :: iterator CHARACTER(len=default_string_length), & INTENT(out), OPTIONAL :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_next', & @@ -648,19 +610,16 @@ END FUNCTION cp_sll_char_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_char_insert_el(sll,el,error) + SUBROUTINE cp_sll_char_insert_el(sll,el) TYPE(cp_sll_char_type), POINTER :: sll CHARACTER(len=default_string_length), & INTENT(in) :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_el', & routineP = moduleN//':'//routineN @@ -670,24 +629,21 @@ SUBROUTINE cp_sll_char_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_char_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_char_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_char_rm_first_el(sll,error) + SUBROUTINE cp_sll_char_rm_first_el(sll) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_rm_first_el', & routineP = moduleN//':'//routineN @@ -700,12 +656,12 @@ SUBROUTINE cp_sll_char_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_char_dealloc_node(node_to_rm,error=error) + CALL cp_sll_char_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_char_rm_first_el @@ -715,20 +671,17 @@ END SUBROUTINE cp_sll_char_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_char_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_char_insert_el_at(sll,el,index) TYPE(cp_sll_char_type), POINTER :: sll CHARACTER(len=default_string_length), & INTENT(in) :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_el_at', & routineP = moduleN//':'//routineN @@ -739,15 +692,15 @@ SUBROUTINE cp_sll_char_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_char_insert_el(sll,el,error=error) + CALL cp_sll_char_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_char_get_rest(sll, iter=-1,error=error) + pos => cp_sll_char_get_rest(sll, iter=-1) ELSE - pos => cp_sll_char_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_char_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_char_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_char_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_char_insert_el_at @@ -755,18 +708,15 @@ END SUBROUTINE cp_sll_char_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_char_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_char_rm_el_at(sll,index) TYPE(cp_sll_char_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_rm_el_at', & routineP = moduleN//':'//routineN @@ -777,35 +727,32 @@ SUBROUTINE cp_sll_char_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_char_rm_first_el(sll,error=error) + CALL cp_sll_char_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_char_get_rest(sll, iter=-1,error=error) + pos => cp_sll_char_get_rest(sll, iter=-1) ELSE - pos => cp_sll_char_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_char_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_char_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_char_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_char_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_char_rm_all_el(sll,error) + SUBROUTINE cp_sll_char_rm_all_el(sll) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_rm_all_el', & routineP = moduleN//':'//routineN @@ -816,7 +763,7 @@ SUBROUTINE cp_sll_char_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_char_dealloc_node(actual_node,error=error) + CALL cp_sll_char_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -826,16 +773,13 @@ END SUBROUTINE cp_sll_char_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_char_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_char_to_array(sll) RESULT(res) TYPE(cp_sll_char_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=default_string_length), & DIMENSION(:), POINTER :: res @@ -848,14 +792,14 @@ FUNCTION cp_sll_char_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_char_get_length(sll,error) + len=cp_sll_char_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i) = iter%first_el - IF (.NOT.(cp_sll_char_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_char_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_char_to_array @@ -863,17 +807,14 @@ END FUNCTION cp_sll_char_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_char_from_array(array,error) RESULT(res) +FUNCTION cp_sll_char_from_array(array) RESULT(res) CHARACTER(len=default_string_length), & DIMENSION(:), INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_char_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_from_array', & @@ -885,14 +826,12 @@ FUNCTION cp_sll_char_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_char_create(res,& - first_el=array(1),& - error=error) + first_el=array(1)) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_char_create(last_el%rest,& - first_el=array(i),& - error=error) + first_el=array(i)) last_el => last_el%rest END DO END FUNCTION cp_sll_char_from_array @@ -906,14 +845,12 @@ END FUNCTION cp_sll_char_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_char_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_char_type), POINTER :: sll CHARACTER(len=default_string_length), & INTENT(in) :: el @@ -921,7 +858,6 @@ SUBROUTINE cp_sll_char_insert_ordered(sll,el,insert_equals,& LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_char_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_ordered', & routineP = moduleN//':'//routineN @@ -937,13 +873,13 @@ SUBROUTINE cp_sll_char_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_char_create(sll,first_el=el,error=error) + CALL cp_sll_char_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_C_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_C_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_C_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_char_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_C_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_char_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -951,22 +887,22 @@ SUBROUTINE cp_sll_char_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_char_insert_el(iter%rest,el,error=error) + CALL cp_sll_char_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_C_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_C_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_C_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_char_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_C_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_char_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_char_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_char_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_char_insert_ordered @@ -981,14 +917,12 @@ END SUBROUTINE cp_sll_char_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_char_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_char_type), POINTER :: sll CHARACTER(len=default_string_length), & INTENT(in) :: el @@ -1004,7 +938,6 @@ END FUNCTION compare_function LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_char_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_char_insert_ordered2', & routineP = moduleN//':'//routineN @@ -1021,7 +954,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_char_create(sll,first_el=el,error=error) + CALL cp_sll_char_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1029,7 +962,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_char_insert_el(sll,el,error=error) + CALL cp_sll_char_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1037,7 +970,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_char_insert_el(iter%rest,el,error=error) + CALL cp_sll_char_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1045,15 +978,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_char_insert_el(iter%rest,el,error=error) + CALL cp_sll_char_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_char_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_char_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_char_insert_ordered2 @@ -1067,8 +1000,8 @@ END SUBROUTINE cp_sll_char_insert_ordered2 ! arrayEl = "" ! common_dir = "../common" ! defines = -! "#define CP_SLL_C_LESS_Q(el1,el2,error) ( el1 < el2 ) -! #define CP_SLL_C_EQUAL_Q(el1,el2,error) ( el1 == el2 ) +! "#define CP_SLL_C_LESS_Q(el1,el2) ( el1 < el2 ) +! #define CP_SLL_C_EQUAL_Q(el1,el2) ( el1 == el2 ) ! " ! equalQ = "CP_SLL_C_EQUAL_Q" ! lessQ = "CP_SLL_C_LESS_Q" diff --git a/src/input/cp_linked_list_int.F b/src/input/cp_linked_list_int.F index ae87f74d08..a004106333 100644 --- a/src/input/cp_linked_list_int.F +++ b/src/input/cp_linked_list_int.F @@ -3,8 +3,8 @@ ! Copyright (C) 2000 - 2015 CP2K developers group ! !-----------------------------------------------------------------------------! -#define CP_SLL_I_LESS_Q(el1,el2,error) ( el1 < el2 ) -#define CP_SLL_I_EQUAL_Q(el1,el2,error) ( el1 == el2 ) +#define CP_SLL_I_LESS_Q(el1,el2) ( el1 < el2 ) +#define CP_SLL_I_EQUAL_Q(el1,el2) ( el1 == el2 ) ! ***************************************************************************** @@ -205,17 +205,14 @@ MODULE cp_linked_list_int !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_int_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_int_create(sll,first_el,rest) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_int_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_create', & routineP = moduleN//':'//routineN @@ -230,7 +227,7 @@ SUBROUTINE cp_sll_int_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el = first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -241,8 +238,6 @@ END SUBROUTINE cp_sll_int_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -250,14 +245,13 @@ END SUBROUTINE cp_sll_int_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_int_dealloc(sll,error) + SUBROUTINE cp_sll_int_dealloc(sll) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_int_rm_all_el(sll,error) + CALL cp_sll_int_rm_all_el(sll) END SUBROUTINE cp_sll_int_dealloc ! * low-level * @@ -265,15 +259,12 @@ END SUBROUTINE cp_sll_int_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_int_dealloc_node(sll,error) + SUBROUTINE cp_sll_int_dealloc_node(sll) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_dealloc_node', & routineP = moduleN//':'//routineN @@ -284,7 +275,7 @@ SUBROUTINE cp_sll_int_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_int_dealloc_node ! ============= get/set ============ @@ -296,17 +287,14 @@ END SUBROUTINE cp_sll_int_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_int_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_int_set(sll,first_el,rest) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_int_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_set', & routineP = moduleN//':'//routineN @@ -317,9 +305,9 @@ SUBROUTINE cp_sll_int_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_int_create(sll,first_el,rest,error) + CALL cp_sll_int_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el = first_el @@ -334,19 +322,16 @@ END SUBROUTINE cp_sll_int_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_int_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_int_get(sll,first_el,rest,empty,length) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(out), OPTIONAL :: first_el TYPE(cp_sll_int_type), OPTIONAL, POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_get', & routineP = moduleN//':'//routineN @@ -356,7 +341,7 @@ SUBROUTINE cp_sll_int_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -365,23 +350,20 @@ SUBROUTINE cp_sll_int_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_int_get_length(sll,error=error) + length = cp_sll_int_get_length(sll) END IF END SUBROUTINE cp_sll_int_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_int_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_int_get_first_el(sll) RESULT(res) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_get_first_el', & @@ -392,7 +374,7 @@ FUNCTION cp_sll_int_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res = sll%first_el @@ -403,8 +385,6 @@ END FUNCTION cp_sll_int_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -412,10 +392,9 @@ END FUNCTION cp_sll_int_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_int_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_int_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_int_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_get_rest', & @@ -438,7 +417,7 @@ FUNCTION cp_sll_int_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -456,16 +435,13 @@ END FUNCTION cp_sll_int_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_int_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_int_get_empty(sll) RESULT(res) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_get_empty', & @@ -477,8 +453,6 @@ END FUNCTION cp_sll_int_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -486,9 +460,8 @@ END FUNCTION cp_sll_int_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_int_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_int_get_length(sll) RESULT(res) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_get_length', & @@ -512,8 +485,6 @@ END FUNCTION cp_sll_int_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -521,10 +492,9 @@ END FUNCTION cp_sll_int_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_int_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_int_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_get_el_at', & @@ -536,14 +506,14 @@ FUNCTION cp_sll_int_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_int_get_rest(sll, iter=-1,error=error) + pos => cp_sll_int_get_rest(sll, iter=-1) ELSE - pos => cp_sll_int_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_int_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res = pos%first_el END FUNCTION cp_sll_int_get_el_at @@ -554,18 +524,15 @@ END FUNCTION cp_sll_int_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_int_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_int_set_el_at(sll,index,value) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in) :: index, value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_set_el_at', & routineP = moduleN//':'//routineN @@ -576,11 +543,11 @@ SUBROUTINE cp_sll_int_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_int_get_rest(sll, iter=-1,error=error) + pos => cp_sll_int_get_rest(sll, iter=-1) ELSE - pos => cp_sll_int_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_int_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el = value END SUBROUTINE cp_sll_int_set_el_at @@ -592,17 +559,14 @@ END SUBROUTINE cp_sll_int_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_int_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_int_next(iterator,el_att) RESULT(res) TYPE(cp_sll_int_type), POINTER :: iterator INTEGER, INTENT(out), OPTIONAL :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_next', & @@ -624,18 +588,15 @@ END FUNCTION cp_sll_int_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_int_insert_el(sll,el,error) + SUBROUTINE cp_sll_int_insert_el(sll,el) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in) :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_insert_el', & routineP = moduleN//':'//routineN @@ -645,24 +606,21 @@ SUBROUTINE cp_sll_int_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_int_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_int_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_int_rm_first_el(sll,error) + SUBROUTINE cp_sll_int_rm_first_el(sll) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_rm_first_el', & routineP = moduleN//':'//routineN @@ -675,12 +633,12 @@ SUBROUTINE cp_sll_int_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_int_dealloc_node(node_to_rm,error=error) + CALL cp_sll_int_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_int_rm_first_el @@ -690,18 +648,15 @@ END SUBROUTINE cp_sll_int_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_int_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_int_insert_el_at(sll,el,index) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in) :: el, index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_insert_el_at', & routineP = moduleN//':'//routineN @@ -712,15 +667,15 @@ SUBROUTINE cp_sll_int_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_int_insert_el(sll,el,error=error) + CALL cp_sll_int_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_int_get_rest(sll, iter=-1,error=error) + pos => cp_sll_int_get_rest(sll, iter=-1) ELSE - pos => cp_sll_int_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_int_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_int_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_int_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_int_insert_el_at @@ -728,18 +683,15 @@ END SUBROUTINE cp_sll_int_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_int_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_int_rm_el_at(sll,index) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_rm_el_at', & routineP = moduleN//':'//routineN @@ -750,35 +702,32 @@ SUBROUTINE cp_sll_int_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_int_rm_first_el(sll,error=error) + CALL cp_sll_int_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_int_get_rest(sll, iter=-1,error=error) + pos => cp_sll_int_get_rest(sll, iter=-1) ELSE - pos => cp_sll_int_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_int_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_int_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_int_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_int_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_int_rm_all_el(sll,error) + SUBROUTINE cp_sll_int_rm_all_el(sll) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_rm_all_el', & routineP = moduleN//':'//routineN @@ -789,7 +738,7 @@ SUBROUTINE cp_sll_int_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_int_dealloc_node(actual_node,error=error) + CALL cp_sll_int_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -799,16 +748,13 @@ END SUBROUTINE cp_sll_int_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_int_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_int_to_array(sll) RESULT(res) TYPE(cp_sll_int_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, DIMENSION(:), POINTER :: res INTEGER :: i, len, stat @@ -820,14 +766,14 @@ FUNCTION cp_sll_int_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_int_get_length(sll,error) + len=cp_sll_int_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i) = iter%first_el - IF (.NOT.(cp_sll_int_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_int_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_int_to_array @@ -835,16 +781,13 @@ END FUNCTION cp_sll_int_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_int_from_array(array,error) RESULT(res) +FUNCTION cp_sll_int_from_array(array) RESULT(res) INTEGER, DIMENSION(:), INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_int_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_from_array', & @@ -856,14 +799,12 @@ FUNCTION cp_sll_int_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_int_create(res,& - first_el=array(1),& - error=error) + first_el=array(1)) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_int_create(last_el%rest,& - first_el=array(i),& - error=error) + first_el=array(i)) last_el => last_el%rest END DO END FUNCTION cp_sll_int_from_array @@ -877,20 +818,17 @@ END FUNCTION cp_sll_int_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_int_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in) :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_int_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_insert_ordered', & routineP = moduleN//':'//routineN @@ -906,13 +844,13 @@ SUBROUTINE cp_sll_int_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_int_create(sll,first_el=el,error=error) + CALL cp_sll_int_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_I_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_I_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_I_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_int_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_I_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_int_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -920,22 +858,22 @@ SUBROUTINE cp_sll_int_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_int_insert_el(iter%rest,el,error=error) + CALL cp_sll_int_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_I_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_I_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_I_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_int_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_I_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_int_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_int_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_int_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_int_insert_ordered @@ -950,14 +888,12 @@ END SUBROUTINE cp_sll_int_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_int_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_int_type), POINTER :: sll INTEGER, INTENT(in) :: el INTERFACE @@ -971,7 +907,6 @@ END FUNCTION compare_function LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_int_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_int_insert_ordered2', & routineP = moduleN//':'//routineN @@ -988,7 +923,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_int_create(sll,first_el=el,error=error) + CALL cp_sll_int_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -996,7 +931,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_int_insert_el(sll,el,error=error) + CALL cp_sll_int_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1004,7 +939,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_int_insert_el(iter%rest,el,error=error) + CALL cp_sll_int_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1012,15 +947,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_int_insert_el(iter%rest,el,error=error) + CALL cp_sll_int_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_int_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_int_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_int_insert_ordered2 @@ -1034,8 +969,8 @@ END SUBROUTINE cp_sll_int_insert_ordered2 ! arrayEl = "" ! common_dir = "../common" ! defines = -! "#define CP_SLL_I_LESS_Q(el1,el2,error) ( el1 < el2 ) -! #define CP_SLL_I_EQUAL_Q(el1,el2,error) ( el1 == el2 ) +! "#define CP_SLL_I_LESS_Q(el1,el2) ( el1 < el2 ) +! #define CP_SLL_I_EQUAL_Q(el1,el2) ( el1 == el2 ) ! " ! equalQ = "CP_SLL_I_EQUAL_Q" ! lessQ = "CP_SLL_I_LESS_Q" diff --git a/src/input/cp_linked_list_logical.F b/src/input/cp_linked_list_logical.F index e7c1c61968..7b8c4f08fc 100644 --- a/src/input/cp_linked_list_logical.F +++ b/src/input/cp_linked_list_logical.F @@ -3,8 +3,8 @@ ! Copyright (C) 2000 - 2015 CP2K developers group ! !-----------------------------------------------------------------------------! -#define CP_SLL_L_LESS_Q(el1,el2,error) ( .not.el1.and.el2 ) -#define CP_SLL_L_EQUAL_Q(el1,el2,error) ( el1.EQV.el2 ) +#define CP_SLL_L_LESS_Q(el1,el2) ( .not.el1.and.el2 ) +#define CP_SLL_L_EQUAL_Q(el1,el2) ( el1.EQV.el2 ) ! ***************************************************************************** @@ -205,18 +205,15 @@ MODULE cp_linked_list_logical !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_logical_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_logical_create(sll,first_el,rest) TYPE(cp_sll_logical_type), POINTER :: sll LOGICAL, INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_logical_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_create', & routineP = moduleN//':'//routineN @@ -231,7 +228,7 @@ SUBROUTINE cp_sll_logical_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el = first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -242,8 +239,6 @@ END SUBROUTINE cp_sll_logical_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -251,14 +246,13 @@ END SUBROUTINE cp_sll_logical_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_logical_dealloc(sll,error) + SUBROUTINE cp_sll_logical_dealloc(sll) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_logical_rm_all_el(sll,error) + CALL cp_sll_logical_rm_all_el(sll) END SUBROUTINE cp_sll_logical_dealloc ! * low-level * @@ -266,15 +260,12 @@ END SUBROUTINE cp_sll_logical_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_logical_dealloc_node(sll,error) + SUBROUTINE cp_sll_logical_dealloc_node(sll) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_dealloc_node', & routineP = moduleN//':'//routineN @@ -285,7 +276,7 @@ SUBROUTINE cp_sll_logical_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_logical_dealloc_node ! ============= get/set ============ @@ -297,18 +288,15 @@ END SUBROUTINE cp_sll_logical_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_logical_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_logical_set(sll,first_el,rest) TYPE(cp_sll_logical_type), POINTER :: sll LOGICAL, INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_logical_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_set', & routineP = moduleN//':'//routineN @@ -319,9 +307,9 @@ SUBROUTINE cp_sll_logical_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_logical_create(sll,first_el,rest,error) + CALL cp_sll_logical_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el = first_el @@ -336,20 +324,17 @@ END SUBROUTINE cp_sll_logical_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_logical_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_logical_get(sll,first_el,rest,empty,length) TYPE(cp_sll_logical_type), POINTER :: sll LOGICAL, INTENT(out), OPTIONAL :: first_el TYPE(cp_sll_logical_type), OPTIONAL, & POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_get', & routineP = moduleN//':'//routineN @@ -359,7 +344,7 @@ SUBROUTINE cp_sll_logical_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -368,23 +353,20 @@ SUBROUTINE cp_sll_logical_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_logical_get_length(sll,error=error) + length = cp_sll_logical_get_length(sll) END IF END SUBROUTINE cp_sll_logical_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_logical_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_logical_get_first_el(sll) RESULT(res) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_get_first_el', & @@ -395,7 +377,7 @@ FUNCTION cp_sll_logical_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res = sll%first_el @@ -406,8 +388,6 @@ END FUNCTION cp_sll_logical_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -415,10 +395,9 @@ END FUNCTION cp_sll_logical_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_logical_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_logical_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_logical_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_logical_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_get_rest', & @@ -441,7 +420,7 @@ FUNCTION cp_sll_logical_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -459,16 +438,13 @@ END FUNCTION cp_sll_logical_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_logical_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_logical_get_empty(sll) RESULT(res) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_get_empty', & @@ -480,8 +456,6 @@ END FUNCTION cp_sll_logical_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -489,9 +463,8 @@ END FUNCTION cp_sll_logical_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_logical_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_logical_get_length(sll) RESULT(res) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_get_length', & @@ -515,8 +488,6 @@ END FUNCTION cp_sll_logical_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -524,10 +495,9 @@ END FUNCTION cp_sll_logical_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_logical_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_logical_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_logical_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_get_el_at', & @@ -539,14 +509,14 @@ FUNCTION cp_sll_logical_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_logical_get_rest(sll, iter=-1,error=error) + pos => cp_sll_logical_get_rest(sll, iter=-1) ELSE - pos => cp_sll_logical_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_logical_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res = pos%first_el END FUNCTION cp_sll_logical_get_el_at @@ -557,19 +527,16 @@ END FUNCTION cp_sll_logical_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_logical_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_logical_set_el_at(sll,index,value) TYPE(cp_sll_logical_type), POINTER :: sll INTEGER, INTENT(in) :: index LOGICAL, INTENT(in) :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_set_el_at', & routineP = moduleN//':'//routineN @@ -580,11 +547,11 @@ SUBROUTINE cp_sll_logical_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_logical_get_rest(sll, iter=-1,error=error) + pos => cp_sll_logical_get_rest(sll, iter=-1) ELSE - pos => cp_sll_logical_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_logical_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el = value END SUBROUTINE cp_sll_logical_set_el_at @@ -596,17 +563,14 @@ END SUBROUTINE cp_sll_logical_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_logical_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_logical_next(iterator,el_att) RESULT(res) TYPE(cp_sll_logical_type), POINTER :: iterator LOGICAL, INTENT(out), OPTIONAL :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_next', & @@ -628,18 +592,15 @@ END FUNCTION cp_sll_logical_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_logical_insert_el(sll,el,error) + SUBROUTINE cp_sll_logical_insert_el(sll,el) TYPE(cp_sll_logical_type), POINTER :: sll LOGICAL, INTENT(in) :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_insert_el', & routineP = moduleN//':'//routineN @@ -649,24 +610,21 @@ SUBROUTINE cp_sll_logical_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_logical_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_logical_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_logical_rm_first_el(sll,error) + SUBROUTINE cp_sll_logical_rm_first_el(sll) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_rm_first_el', & routineP = moduleN//':'//routineN @@ -679,12 +637,12 @@ SUBROUTINE cp_sll_logical_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_logical_dealloc_node(node_to_rm,error=error) + CALL cp_sll_logical_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_logical_rm_first_el @@ -694,19 +652,16 @@ END SUBROUTINE cp_sll_logical_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_logical_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_logical_insert_el_at(sll,el,index) TYPE(cp_sll_logical_type), POINTER :: sll LOGICAL, INTENT(in) :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_insert_el_at', & routineP = moduleN//':'//routineN @@ -717,15 +672,15 @@ SUBROUTINE cp_sll_logical_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_logical_insert_el(sll,el,error=error) + CALL cp_sll_logical_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_logical_get_rest(sll, iter=-1,error=error) + pos => cp_sll_logical_get_rest(sll, iter=-1) ELSE - pos => cp_sll_logical_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_logical_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_logical_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_logical_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_logical_insert_el_at @@ -733,18 +688,15 @@ END SUBROUTINE cp_sll_logical_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_logical_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_logical_rm_el_at(sll,index) TYPE(cp_sll_logical_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_rm_el_at', & routineP = moduleN//':'//routineN @@ -755,35 +707,32 @@ SUBROUTINE cp_sll_logical_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_logical_rm_first_el(sll,error=error) + CALL cp_sll_logical_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_logical_get_rest(sll, iter=-1,error=error) + pos => cp_sll_logical_get_rest(sll, iter=-1) ELSE - pos => cp_sll_logical_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_logical_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_logical_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_logical_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_logical_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_logical_rm_all_el(sll,error) + SUBROUTINE cp_sll_logical_rm_all_el(sll) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_rm_all_el', & routineP = moduleN//':'//routineN @@ -794,7 +743,7 @@ SUBROUTINE cp_sll_logical_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_logical_dealloc_node(actual_node,error=error) + CALL cp_sll_logical_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -804,16 +753,13 @@ END SUBROUTINE cp_sll_logical_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_logical_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_logical_to_array(sll) RESULT(res) TYPE(cp_sll_logical_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, DIMENSION(:), POINTER :: res INTEGER :: i, len, stat @@ -825,14 +771,14 @@ FUNCTION cp_sll_logical_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_logical_get_length(sll,error) + len=cp_sll_logical_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i) = iter%first_el - IF (.NOT.(cp_sll_logical_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_logical_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_logical_to_array @@ -840,16 +786,13 @@ END FUNCTION cp_sll_logical_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_logical_from_array(array,error) RESULT(res) +FUNCTION cp_sll_logical_from_array(array) RESULT(res) LOGICAL, DIMENSION(:), INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_logical_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_logical_from_array', & @@ -861,14 +804,12 @@ FUNCTION cp_sll_logical_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_logical_create(res,& - first_el=array(1),& - error=error) + first_el=array(1)) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_logical_create(last_el%rest,& - first_el=array(i),& - error=error) + first_el=array(i)) last_el => last_el%rest END DO END FUNCTION cp_sll_logical_from_array @@ -882,21 +823,18 @@ END FUNCTION cp_sll_logical_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_logical_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_logical_type), POINTER :: sll LOGICAL, INTENT(in) :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_logical_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_sll_logical_insert_ordered', & @@ -913,13 +851,13 @@ SUBROUTINE cp_sll_logical_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_logical_create(sll,first_el=el,error=error) + CALL cp_sll_logical_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_L_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_L_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_L_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_logical_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_L_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_logical_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -927,22 +865,22 @@ SUBROUTINE cp_sll_logical_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_logical_insert_el(iter%rest,el,error=error) + CALL cp_sll_logical_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_L_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_L_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_L_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_logical_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_L_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_logical_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_logical_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_logical_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_logical_insert_ordered @@ -957,14 +895,12 @@ END SUBROUTINE cp_sll_logical_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_logical_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_logical_type), POINTER :: sll LOGICAL, INTENT(in) :: el INTERFACE @@ -979,7 +915,6 @@ END FUNCTION compare_function LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_logical_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_sll_logical_insert_ordered2', & @@ -997,7 +932,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_logical_create(sll,first_el=el,error=error) + CALL cp_sll_logical_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1005,7 +940,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_logical_insert_el(sll,el,error=error) + CALL cp_sll_logical_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1013,7 +948,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_logical_insert_el(iter%rest,el,error=error) + CALL cp_sll_logical_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1021,15 +956,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_logical_insert_el(iter%rest,el,error=error) + CALL cp_sll_logical_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_logical_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_logical_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_logical_insert_ordered2 @@ -1043,8 +978,8 @@ END SUBROUTINE cp_sll_logical_insert_ordered2 ! arrayEl = "" ! common_dir = "../common" ! defines = -! "#define CP_SLL_L_LESS_Q(el1,el2,error) ( .not.el1.and.el2 ) -! #define CP_SLL_L_EQUAL_Q(el1,el2,error) ( el1.EQV.el2 ) +! "#define CP_SLL_L_LESS_Q(el1,el2) ( .not.el1.and.el2 ) +! #define CP_SLL_L_EQUAL_Q(el1,el2) ( el1.EQV.el2 ) ! " ! equalQ = "CP_SLL_L_EQUAL_Q" ! lessQ = "CP_SLL_L_LESS_Q" diff --git a/src/input/cp_linked_list_real.F b/src/input/cp_linked_list_real.F index 5372a2c063..fb2b2a4e18 100644 --- a/src/input/cp_linked_list_real.F +++ b/src/input/cp_linked_list_real.F @@ -3,8 +3,8 @@ ! Copyright (C) 2000 - 2015 CP2K developers group ! !-----------------------------------------------------------------------------! -#define CP_SLL_R_LESS_Q(el1,el2,error) ( el1 < el2 ) -#define CP_SLL_R_EQUAL_Q(el1,el2,error) ( el1 == el2 ) +#define CP_SLL_R_LESS_Q(el1,el2) ( el1 < el2 ) +#define CP_SLL_R_EQUAL_Q(el1,el2) ( el1 == el2 ) ! ***************************************************************************** @@ -206,18 +206,15 @@ MODULE cp_linked_list_real !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_real_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_real_create(sll,first_el,rest) TYPE(cp_sll_real_type), POINTER :: sll REAL(kind=dp), INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_real_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_create', & routineP = moduleN//':'//routineN @@ -232,7 +229,7 @@ SUBROUTINE cp_sll_real_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el = first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -243,8 +240,6 @@ END SUBROUTINE cp_sll_real_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -252,14 +247,13 @@ END SUBROUTINE cp_sll_real_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_real_dealloc(sll,error) + SUBROUTINE cp_sll_real_dealloc(sll) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_real_rm_all_el(sll,error) + CALL cp_sll_real_rm_all_el(sll) END SUBROUTINE cp_sll_real_dealloc ! * low-level * @@ -267,15 +261,12 @@ END SUBROUTINE cp_sll_real_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_real_dealloc_node(sll,error) + SUBROUTINE cp_sll_real_dealloc_node(sll) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_dealloc_node', & routineP = moduleN//':'//routineN @@ -286,7 +277,7 @@ SUBROUTINE cp_sll_real_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_real_dealloc_node ! ============= get/set ============ @@ -298,18 +289,15 @@ END SUBROUTINE cp_sll_real_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_real_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_real_set(sll,first_el,rest) TYPE(cp_sll_real_type), POINTER :: sll REAL(kind=dp), INTENT(in), OPTIONAL :: first_el TYPE(cp_sll_real_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_set', & routineP = moduleN//':'//routineN @@ -320,9 +308,9 @@ SUBROUTINE cp_sll_real_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_real_create(sll,first_el,rest,error) + CALL cp_sll_real_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el = first_el @@ -337,20 +325,17 @@ END SUBROUTINE cp_sll_real_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_real_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_real_get(sll,first_el,rest,empty,length) TYPE(cp_sll_real_type), POINTER :: sll REAL(kind=dp), INTENT(out), OPTIONAL :: first_el TYPE(cp_sll_real_type), OPTIONAL, & POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_get', & routineP = moduleN//':'//routineN @@ -360,7 +345,7 @@ SUBROUTINE cp_sll_real_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -369,23 +354,20 @@ SUBROUTINE cp_sll_real_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_real_get_length(sll,error=error) + length = cp_sll_real_get_length(sll) END IF END SUBROUTINE cp_sll_real_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_real_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_real_get_first_el(sll) RESULT(res) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_get_first_el', & @@ -396,7 +378,7 @@ FUNCTION cp_sll_real_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res = sll%first_el @@ -407,8 +389,6 @@ END FUNCTION cp_sll_real_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -416,10 +396,9 @@ END FUNCTION cp_sll_real_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_real_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_real_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_real_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_real_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_get_rest', & @@ -442,7 +421,7 @@ FUNCTION cp_sll_real_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -460,16 +439,13 @@ END FUNCTION cp_sll_real_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_real_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_real_get_empty(sll) RESULT(res) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_get_empty', & @@ -481,8 +457,6 @@ END FUNCTION cp_sll_real_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -490,9 +464,8 @@ END FUNCTION cp_sll_real_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_real_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_real_get_length(sll) RESULT(res) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_get_length', & @@ -516,8 +489,6 @@ END FUNCTION cp_sll_real_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -525,10 +496,9 @@ END FUNCTION cp_sll_real_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_real_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_real_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_real_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_get_el_at', & @@ -540,14 +510,14 @@ FUNCTION cp_sll_real_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_real_get_rest(sll, iter=-1,error=error) + pos => cp_sll_real_get_rest(sll, iter=-1) ELSE - pos => cp_sll_real_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_real_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res = pos%first_el END FUNCTION cp_sll_real_get_el_at @@ -558,19 +528,16 @@ END FUNCTION cp_sll_real_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_real_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_real_set_el_at(sll,index,value) TYPE(cp_sll_real_type), POINTER :: sll INTEGER, INTENT(in) :: index REAL(kind=dp), INTENT(in) :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_set_el_at', & routineP = moduleN//':'//routineN @@ -581,11 +548,11 @@ SUBROUTINE cp_sll_real_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_real_get_rest(sll, iter=-1,error=error) + pos => cp_sll_real_get_rest(sll, iter=-1) ELSE - pos => cp_sll_real_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_real_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el = value END SUBROUTINE cp_sll_real_set_el_at @@ -597,17 +564,14 @@ END SUBROUTINE cp_sll_real_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_real_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_real_next(iterator,el_att) RESULT(res) TYPE(cp_sll_real_type), POINTER :: iterator REAL(kind=dp), INTENT(out), OPTIONAL :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_next', & @@ -629,18 +593,15 @@ END FUNCTION cp_sll_real_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_real_insert_el(sll,el,error) + SUBROUTINE cp_sll_real_insert_el(sll,el) TYPE(cp_sll_real_type), POINTER :: sll REAL(kind=dp), INTENT(in) :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_insert_el', & routineP = moduleN//':'//routineN @@ -650,24 +611,21 @@ SUBROUTINE cp_sll_real_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_real_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_real_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_real_rm_first_el(sll,error) + SUBROUTINE cp_sll_real_rm_first_el(sll) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_rm_first_el', & routineP = moduleN//':'//routineN @@ -680,12 +638,12 @@ SUBROUTINE cp_sll_real_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_real_dealloc_node(node_to_rm,error=error) + CALL cp_sll_real_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_real_rm_first_el @@ -695,19 +653,16 @@ END SUBROUTINE cp_sll_real_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_real_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_real_insert_el_at(sll,el,index) TYPE(cp_sll_real_type), POINTER :: sll REAL(kind=dp), INTENT(in) :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_insert_el_at', & routineP = moduleN//':'//routineN @@ -718,15 +673,15 @@ SUBROUTINE cp_sll_real_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_real_insert_el(sll,el,error=error) + CALL cp_sll_real_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_real_get_rest(sll, iter=-1,error=error) + pos => cp_sll_real_get_rest(sll, iter=-1) ELSE - pos => cp_sll_real_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_real_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_real_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_real_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_real_insert_el_at @@ -734,18 +689,15 @@ END SUBROUTINE cp_sll_real_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_real_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_real_rm_el_at(sll,index) TYPE(cp_sll_real_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_rm_el_at', & routineP = moduleN//':'//routineN @@ -756,35 +708,32 @@ SUBROUTINE cp_sll_real_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_real_rm_first_el(sll,error=error) + CALL cp_sll_real_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_real_get_rest(sll, iter=-1,error=error) + pos => cp_sll_real_get_rest(sll, iter=-1) ELSE - pos => cp_sll_real_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_real_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_real_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_real_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_real_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_real_rm_all_el(sll,error) + SUBROUTINE cp_sll_real_rm_all_el(sll) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_rm_all_el', & routineP = moduleN//':'//routineN @@ -795,7 +744,7 @@ SUBROUTINE cp_sll_real_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_real_dealloc_node(actual_node,error=error) + CALL cp_sll_real_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -805,16 +754,13 @@ END SUBROUTINE cp_sll_real_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_real_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_real_to_array(sll) RESULT(res) TYPE(cp_sll_real_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp), DIMENSION(:), POINTER :: res INTEGER :: i, len, stat @@ -826,14 +772,14 @@ FUNCTION cp_sll_real_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_real_get_length(sll,error) + len=cp_sll_real_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i) = iter%first_el - IF (.NOT.(cp_sll_real_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_real_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_real_to_array @@ -841,16 +787,13 @@ END FUNCTION cp_sll_real_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_real_from_array(array,error) RESULT(res) +FUNCTION cp_sll_real_from_array(array) RESULT(res) REAL(kind=dp), DIMENSION(:), INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_real_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_from_array', & @@ -862,14 +805,12 @@ FUNCTION cp_sll_real_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_real_create(res,& - first_el=array(1),& - error=error) + first_el=array(1)) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_real_create(last_el%rest,& - first_el=array(i),& - error=error) + first_el=array(i)) last_el => last_el%rest END DO END FUNCTION cp_sll_real_from_array @@ -883,21 +824,18 @@ END FUNCTION cp_sll_real_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_real_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_real_type), POINTER :: sll REAL(kind=dp), INTENT(in) :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_real_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_insert_ordered', & routineP = moduleN//':'//routineN @@ -913,13 +851,13 @@ SUBROUTINE cp_sll_real_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_real_create(sll,first_el=el,error=error) + CALL cp_sll_real_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_R_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_R_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_R_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_real_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_R_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_real_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -927,22 +865,22 @@ SUBROUTINE cp_sll_real_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_real_insert_el(iter%rest,el,error=error) + CALL cp_sll_real_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_R_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_R_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_R_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_real_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_R_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_real_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_real_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_real_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_real_insert_ordered @@ -957,14 +895,12 @@ END SUBROUTINE cp_sll_real_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_real_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_real_type), POINTER :: sll REAL(kind=dp), INTENT(in) :: el INTERFACE @@ -979,7 +915,6 @@ END FUNCTION compare_function LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_real_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_real_insert_ordered2', & routineP = moduleN//':'//routineN @@ -996,7 +931,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_real_create(sll,first_el=el,error=error) + CALL cp_sll_real_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1004,7 +939,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_real_insert_el(sll,el,error=error) + CALL cp_sll_real_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1012,7 +947,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_real_insert_el(iter%rest,el,error=error) + CALL cp_sll_real_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1020,15 +955,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_real_insert_el(iter%rest,el,error=error) + CALL cp_sll_real_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_real_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_real_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_real_insert_ordered2 @@ -1042,8 +977,8 @@ END SUBROUTINE cp_sll_real_insert_ordered2 ! arrayEl = "" ! common_dir = "../common" ! defines = -! "#define CP_SLL_R_LESS_Q(el1,el2,error) ( el1 < el2 ) -! #define CP_SLL_R_EQUAL_Q(el1,el2,error) ( el1 == el2 ) +! "#define CP_SLL_R_LESS_Q(el1,el2) ( el1 < el2 ) +! #define CP_SLL_R_EQUAL_Q(el1,el2) ( el1 == el2 ) ! " ! equalQ = "CP_SLL_R_EQUAL_Q" ! lessQ = "CP_SLL_R_LESS_Q" diff --git a/src/input/cp_linked_list_val.F b/src/input/cp_linked_list_val.F index 9544bcf737..ab1e21a38a 100644 --- a/src/input/cp_linked_list_val.F +++ b/src/input/cp_linked_list_val.F @@ -3,8 +3,8 @@ ! Copyright (C) 2000 - 2015 CP2K developers group ! !-----------------------------------------------------------------------------! -#define CP_SLL_VAL_LESS_Q(el1,el2,error) el1%id_nr \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_val_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_val_create(sll,first_el,rest) TYPE(cp_sll_val_type), POINTER :: sll TYPE(val_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_val_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_create', & routineP = moduleN//':'//routineN @@ -232,7 +229,7 @@ SUBROUTINE cp_sll_val_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el => first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -243,8 +240,6 @@ END SUBROUTINE cp_sll_val_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -252,14 +247,13 @@ END SUBROUTINE cp_sll_val_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_val_dealloc(sll,error) + SUBROUTINE cp_sll_val_dealloc(sll) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_val_rm_all_el(sll,error) + CALL cp_sll_val_rm_all_el(sll) END SUBROUTINE cp_sll_val_dealloc ! * low-level * @@ -267,15 +261,12 @@ END SUBROUTINE cp_sll_val_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_val_dealloc_node(sll,error) + SUBROUTINE cp_sll_val_dealloc_node(sll) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_dealloc_node', & routineP = moduleN//':'//routineN @@ -286,7 +277,7 @@ SUBROUTINE cp_sll_val_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_val_dealloc_node ! ============= get/set ============ @@ -298,17 +289,14 @@ END SUBROUTINE cp_sll_val_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_val_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_val_set(sll,first_el,rest) TYPE(cp_sll_val_type), POINTER :: sll TYPE(val_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_val_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_set', & routineP = moduleN//':'//routineN @@ -319,9 +307,9 @@ SUBROUTINE cp_sll_val_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_val_create(sll,first_el,rest,error) + CALL cp_sll_val_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el => first_el @@ -336,19 +324,16 @@ END SUBROUTINE cp_sll_val_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_val_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_val_get(sll,first_el,rest,empty,length) TYPE(cp_sll_val_type), POINTER :: sll TYPE(val_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_val_type), OPTIONAL, POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_get', & routineP = moduleN//':'//routineN @@ -358,7 +343,7 @@ SUBROUTINE cp_sll_val_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -367,23 +352,20 @@ SUBROUTINE cp_sll_val_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_val_get_length(sll,error=error) + length = cp_sll_val_get_length(sll) END IF END SUBROUTINE cp_sll_val_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_val_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_val_get_first_el(sll) RESULT(res) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(val_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_get_first_el', & @@ -394,7 +376,7 @@ FUNCTION cp_sll_val_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res => sll%first_el @@ -405,8 +387,6 @@ END FUNCTION cp_sll_val_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -414,10 +394,9 @@ END FUNCTION cp_sll_val_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_val_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_val_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_val_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_val_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_get_rest', & @@ -440,7 +419,7 @@ FUNCTION cp_sll_val_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -458,16 +437,13 @@ END FUNCTION cp_sll_val_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_val_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_val_get_empty(sll) RESULT(res) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_get_empty', & @@ -479,8 +455,6 @@ END FUNCTION cp_sll_val_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -488,9 +462,8 @@ END FUNCTION cp_sll_val_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_val_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_val_get_length(sll) RESULT(res) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_get_length', & @@ -514,8 +487,6 @@ END FUNCTION cp_sll_val_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -523,10 +494,9 @@ END FUNCTION cp_sll_val_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_val_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_val_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_val_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error TYPE(val_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_get_el_at', & @@ -538,14 +508,14 @@ FUNCTION cp_sll_val_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_val_get_rest(sll, iter=-1,error=error) + pos => cp_sll_val_get_rest(sll, iter=-1) ELSE - pos => cp_sll_val_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_val_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res => pos%first_el END FUNCTION cp_sll_val_get_el_at @@ -556,19 +526,16 @@ END FUNCTION cp_sll_val_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_val_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_val_set_el_at(sll,index,value) TYPE(cp_sll_val_type), POINTER :: sll INTEGER, INTENT(in) :: index TYPE(val_type), POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_set_el_at', & routineP = moduleN//':'//routineN @@ -579,11 +546,11 @@ SUBROUTINE cp_sll_val_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_val_get_rest(sll, iter=-1,error=error) + pos => cp_sll_val_get_rest(sll, iter=-1) ELSE - pos => cp_sll_val_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_val_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el => value END SUBROUTINE cp_sll_val_set_el_at @@ -595,17 +562,14 @@ END SUBROUTINE cp_sll_val_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_val_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_val_next(iterator,el_att) RESULT(res) TYPE(cp_sll_val_type), POINTER :: iterator TYPE(val_type), OPTIONAL, POINTER :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_next', & @@ -627,18 +591,15 @@ END FUNCTION cp_sll_val_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_val_insert_el(sll,el,error) + SUBROUTINE cp_sll_val_insert_el(sll,el) TYPE(cp_sll_val_type), POINTER :: sll TYPE(val_type), POINTER :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_insert_el', & routineP = moduleN//':'//routineN @@ -648,24 +609,21 @@ SUBROUTINE cp_sll_val_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_val_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_val_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_val_rm_first_el(sll,error) + SUBROUTINE cp_sll_val_rm_first_el(sll) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_rm_first_el', & routineP = moduleN//':'//routineN @@ -678,12 +636,12 @@ SUBROUTINE cp_sll_val_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_val_dealloc_node(node_to_rm,error=error) + CALL cp_sll_val_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_val_rm_first_el @@ -693,19 +651,16 @@ END SUBROUTINE cp_sll_val_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_val_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_val_insert_el_at(sll,el,index) TYPE(cp_sll_val_type), POINTER :: sll TYPE(val_type), POINTER :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_insert_el_at', & routineP = moduleN//':'//routineN @@ -716,15 +671,15 @@ SUBROUTINE cp_sll_val_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_val_insert_el(sll,el,error=error) + CALL cp_sll_val_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_val_get_rest(sll, iter=-1,error=error) + pos => cp_sll_val_get_rest(sll, iter=-1) ELSE - pos => cp_sll_val_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_val_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_val_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_val_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_val_insert_el_at @@ -732,18 +687,15 @@ END SUBROUTINE cp_sll_val_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_val_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_val_rm_el_at(sll,index) TYPE(cp_sll_val_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_rm_el_at', & routineP = moduleN//':'//routineN @@ -754,35 +706,32 @@ SUBROUTINE cp_sll_val_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_val_rm_first_el(sll,error=error) + CALL cp_sll_val_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_val_get_rest(sll, iter=-1,error=error) + pos => cp_sll_val_get_rest(sll, iter=-1) ELSE - pos => cp_sll_val_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_val_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_val_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_val_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_val_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_val_rm_all_el(sll,error) + SUBROUTINE cp_sll_val_rm_all_el(sll) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_rm_all_el', & routineP = moduleN//':'//routineN @@ -793,7 +742,7 @@ SUBROUTINE cp_sll_val_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_val_dealloc_node(actual_node,error=error) + CALL cp_sll_val_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -803,16 +752,13 @@ END SUBROUTINE cp_sll_val_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_val_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_val_to_array(sll) RESULT(res) TYPE(cp_sll_val_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(val_p_type), DIMENSION(:), POINTER :: res INTEGER :: i, len, stat @@ -824,14 +770,14 @@ FUNCTION cp_sll_val_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_val_get_length(sll,error) + len=cp_sll_val_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i)%val => iter%first_el - IF (.NOT.(cp_sll_val_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_val_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_val_to_array @@ -839,17 +785,14 @@ END FUNCTION cp_sll_val_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_val_from_array(array,error) RESULT(res) +FUNCTION cp_sll_val_from_array(array) RESULT(res) TYPE(val_p_type), DIMENSION(:), & INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_val_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_from_array', & @@ -861,14 +804,12 @@ FUNCTION cp_sll_val_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_val_create(res,& - first_el=array(1)%val,& - error=error) + first_el=array(1)%val) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_val_create(last_el%rest,& - first_el=array(i)%val,& - error=error) + first_el=array(i)%val) last_el => last_el%rest END DO END FUNCTION cp_sll_val_from_array @@ -882,20 +823,17 @@ END FUNCTION cp_sll_val_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_val_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_val_type), POINTER :: sll TYPE(val_type), POINTER :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_val_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_insert_ordered', & routineP = moduleN//':'//routineN @@ -911,13 +849,13 @@ SUBROUTINE cp_sll_val_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_val_create(sll,first_el=el,error=error) + CALL cp_sll_val_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_VAL_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_VAL_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_VAL_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_val_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_VAL_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_val_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -925,22 +863,22 @@ SUBROUTINE cp_sll_val_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_val_insert_el(iter%rest,el,error=error) + CALL cp_sll_val_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_VAL_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_VAL_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_VAL_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_val_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_VAL_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_val_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_val_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_val_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_val_insert_ordered @@ -955,14 +893,12 @@ END SUBROUTINE cp_sll_val_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_val_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_val_type), POINTER :: sll TYPE(val_type), POINTER :: el INTERFACE @@ -976,7 +912,6 @@ END FUNCTION compare_function LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_val_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_val_insert_ordered2', & routineP = moduleN//':'//routineN @@ -993,7 +928,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_val_create(sll,first_el=el,error=error) + CALL cp_sll_val_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1001,7 +936,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_val_insert_el(sll,el,error=error) + CALL cp_sll_val_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1009,7 +944,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_val_insert_el(iter%rest,el,error=error) + CALL cp_sll_val_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1017,15 +952,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_val_insert_el(iter%rest,el,error=error) + CALL cp_sll_val_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_val_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_val_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_val_insert_ordered2 @@ -1039,8 +974,8 @@ END SUBROUTINE cp_sll_val_insert_ordered2 ! arrayEl = "%val" ! common_dir = "../common" ! defines = -! "#define CP_SLL_VAL_LESS_Q(el1,el2,error) el1%id_nr \param unit_str specifies an unit of measure for output quantity. If not !> provided the control is totally left to how the output was coded !> (i.e. USERS have no possibility to change it) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & print_level,each_iter_names,each_iter_values,add_last,filename,& - common_iter_levels,citations,unit_str,error) + common_iter_levels,citations,unit_str) TYPE(section_type), POINTER :: print_key_section CHARACTER(len=*), INTENT(IN) :: name, description INTEGER, INTENT(IN), OPTIONAL :: print_level @@ -170,7 +168,6 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & INTEGER, INTENT(IN), OPTIONAL :: common_iter_levels INTEGER, DIMENSION(:), OPTIONAL :: citations CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: unit_str - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_print_key_section_create', & routineP = moduleN//':'//routineN @@ -185,13 +182,13 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(print_key_section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(print_key_section),cp_failure_level,routineP,failure) my_print_level=debug_print_level IF (PRESENT(print_level)) my_print_level=print_level CALL section_create(print_key_section,name=name,description=description,& n_keywords=2, n_subsections=0, repeats=.FALSE.,& - citations=citations, error=error) + citations=citations) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& @@ -201,16 +198,16 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & enum_c_vals=s2a("on","off","silent","low","medium","high","debug"),& enum_i_vals=(/ silent_print_level-1,debug_print_level+1,& silent_print_level, low_print_level,& - medium_print_level,high_print_level,debug_print_level/), error=error) - CALL section_add_keyword(print_key_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + medium_print_level,high_print_level,debug_print_level/)) + CALL section_add_keyword(print_key_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="__CONTROL_VAL",& description=' hidden parameter that controls storage, printing,...'//& ' of the print_key',& - default_i_val=cp_out_default,error=error) - CALL section_add_keyword(print_key_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=cp_out_default) + CALL section_add_keyword(print_key_section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="EACH",& description="This section specifies how often this proprety is printed."//& @@ -221,18 +218,18 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & "though equal to 0, might print the last iteration). If an iteration level is specified "//& "that is not present in the flow of the calculation it is just ignored.",& n_keywords=2, n_subsections=0, repeats=.FALSE.,& - citations=citations, error=error) + citations=citations) ! Enforce the presence or absence of both.. or give an error check = (PRESENT(each_iter_names)).EQV.(PRESENT(each_iter_values)) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) ext_each = (PRESENT(each_iter_names)).AND.(PRESENT(each_iter_values)) DO i_each = 1, SIZE(each_possible_labels) my_value = 1 IF (ext_each) THEN check = SUM(INDEX(each_iter_names,each_possible_labels(i_each)))<=1 - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) DO i_iter = 1, SIZE(each_iter_names) IF (INDEX(TRIM(each_iter_names(i_iter)),TRIM(each_possible_labels(i_each)))/=0) THEN my_value = each_iter_values(i_iter) @@ -242,12 +239,12 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & CALL keyword_create(keyword, name=TRIM(each_possible_labels(i_each)),& description=TRIM(each_desc_labels(i_each)),& usage=TRIM(each_possible_labels(i_each))//" ",& - default_i_val=my_value, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=my_value) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) END DO - CALL section_add_subsection(print_key_section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(print_key_section,subsection) + CALL section_release(subsection) my_add_last = add_last_no IF (PRESENT(add_last)) THEN @@ -266,9 +263,9 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & enum_desc=s2a("Do not mark last iteration specifically",& "Mark last iteration with its iteration number",& "Mark last iteration with lowercase letter l"),& - default_i_val=my_add_last,error=error) - CALL section_add_keyword(print_key_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=my_add_last) + CALL section_add_keyword(print_key_section,keyword) + CALL keyword_release(keyword) my_comm_iter_levels=0 IF (PRESENT(common_iter_levels)) my_comm_iter_levels=common_iter_levels @@ -277,9 +274,9 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & " in the same file (no extra information about the actual"//& " iteration level is written to the file)",& usage="COMMON_ITERATION_LEVELS ",& - default_i_val=my_comm_iter_levels,error=error) - CALL section_add_keyword(print_key_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=my_comm_iter_levels) + CALL section_add_keyword(print_key_section,keyword) + CALL keyword_release(keyword) my_filename="" IF (PRESENT(filename)) my_filename=filename @@ -295,24 +292,24 @@ SUBROUTINE cp_print_key_section_create(print_key_section, name, description, & ' Please note that this can lead to clashes of'//& ' filenames.',& usage="FILENAME ./filename ",& - default_lc_val=my_filename,error=error) - CALL section_add_keyword(print_key_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val=my_filename) + CALL section_add_keyword(print_key_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LOG_PRINT_KEY",& description="This keywords enables the logger for the print_key (a message is printed on "//& "screen everytime data, controlled by this print_key, are written)",& - usage="LOG_PRINT_KEY ", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LOG_PRINT_KEY ", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key_section,keyword) + CALL keyword_release(keyword) IF (PRESENT(unit_str)) THEN CALL keyword_create(keyword, name="UNIT",& description='Specify the unit of measurement for the quantity in output. '//& "All available CP2K units can be used.",& - usage="UNIT angstrom",default_c_val=TRIM(unit_str),error=error) - CALL section_add_keyword(print_key_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="UNIT angstrom",default_c_val=TRIM(unit_str)) + CALL section_add_keyword(print_key_section,keyword) + CALL keyword_release(keyword) END IF END SUBROUTINE cp_print_key_section_create @@ -328,15 +325,13 @@ END SUBROUTINE cp_print_key_section_create !> \param used_print_key here the print_key that was used is returned !> \param first_time if it ist the first time that an output is written !> (not fully correct, but most of the time) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi !> \note !> not all the propreties support can be stored ! ***************************************************************************** FUNCTION cp_print_key_should_output(iteration_info,basis_section,& - print_key_path,used_print_key,first_time,error)& + print_key_path,used_print_key,first_time)& RESULT(res) TYPE(cp_iteration_info_type), POINTER :: iteration_info TYPE(section_vals_type), POINTER :: basis_section @@ -344,7 +339,6 @@ FUNCTION cp_print_key_should_output(iteration_info,basis_section,& TYPE(section_vals_type), OPTIONAL, & POINTER :: used_print_key LOGICAL, INTENT(OUT), OPTIONAL :: first_time - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_print_key_should_output', & @@ -358,8 +352,8 @@ FUNCTION cp_print_key_should_output(iteration_info,basis_section,& failure=.FALSE. res=0 IF (PRESENT(first_time)) first_time=.FALSE. - CPPrecondition(ASSOCIATED(basis_section),cp_failure_level,routineP,error,failure) - CPPrecondition(basis_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(basis_section),cp_failure_level,routineP,failure) + CPPrecondition(basis_section%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(used_print_key)) NULLIFY(used_print_key) IF (failure) THEN IF (iteration_info%print_level>=debug_print_level) res=cp_out_default @@ -375,15 +369,15 @@ FUNCTION cp_print_key_should_output(iteration_info,basis_section,& IF (to_path>1) THEN print_key => section_vals_get_subs_vals(basis_section,& - print_key_path(1:(to_path-1)),error=error) + print_key_path(1:(to_path-1))) ELSE print_key => basis_section END IF - CPPrecondition(ASSOCIATED(print_key),cp_failure_level,routineP,error,failure) - CPPrecondition(print_key%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(print_key),cp_failure_level,routineP,failure) + CPPrecondition(print_key%ref_count>0,cp_failure_level,routineP,failure) IF (to_path+1 does not look if this iteration it should be printed !> \param iteration_info information about the actual iteration level !> \param print_key the section values of the key to be printed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_printkey_is_on(iteration_info,print_key,error) RESULT(res) + FUNCTION cp_printkey_is_on(iteration_info,print_key) RESULT(res) TYPE(cp_iteration_info_type), POINTER :: iteration_info TYPE(section_vals_type), POINTER :: print_key - TYPE(cp_error_type), INTENT(INOUT) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_printkey_is_on', & @@ -448,13 +438,13 @@ FUNCTION cp_printkey_is_on(iteration_info,print_key,error) RESULT(res) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,error,failure) - CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,failure) + CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(print_key)) THEN res=(iteration_info%print_level > debug_print_level) ELSE - CPPrecondition(print_key%ref_count>0,cp_failure_level,routineP,error,failure) - CALL section_vals_val_get(print_key,"_SECTION_PARAMETERS_",i_val=print_level,error=error) + CPPrecondition(print_key%ref_count>0,cp_failure_level,routineP,failure) + CALL section_vals_val_get(print_key,"_SECTION_PARAMETERS_",i_val=print_level) res=iteration_info%print_level>=print_level END IF END FUNCTION cp_printkey_is_on @@ -467,17 +457,14 @@ END FUNCTION cp_printkey_is_on !> \param print_key the section values of the key to be printed !> \param first_time returns if it is the first time that output is written !> (not fully correct, but most of the time) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION cp_printkey_is_iter(iteration_info,print_key,first_time,error)& + FUNCTION cp_printkey_is_iter(iteration_info,print_key,first_time)& RESULT(res) TYPE(cp_iteration_info_type), POINTER :: iteration_info TYPE(section_vals_type), POINTER :: print_key LOGICAL, INTENT(OUT), OPTIONAL :: first_time - TYPE(cp_error_type), INTENT(INOUT) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_printkey_is_iter', & @@ -488,22 +475,22 @@ FUNCTION cp_printkey_is_iter(iteration_info,print_key,first_time,error)& LOGICAL :: failure, first, level_passed failure=.FALSE. - CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,error,failure) - CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,failure) + CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(print_key)) THEN res=(iteration_info%print_level > debug_print_level) first=ALL(iteration_info%iteration(1:iteration_info%n_rlevel)==1) ELSE - CPPrecondition(print_key%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(print_key%ref_count>0,cp_failure_level,routineP,failure) res = .FALSE. first = .FALSE. - CALL section_vals_val_get(print_key,"ADD_LAST",i_val=add_last,error=error) + CALL section_vals_val_get(print_key,"ADD_LAST",i_val=add_last) res =.TRUE. first=.TRUE. DO ilevel=1,iteration_info%n_rlevel level_passed=.FALSE. CALL section_vals_val_get(print_key,"EACH%"//TRIM(iteration_info%level_name(ilevel)),& - i_val=ival,error=error) + i_val=ival) IF (ival>0) THEN iter_nr=iteration_info%iteration(ilevel) IF (iter_nr/ival>1) first=.FALSE. @@ -534,19 +521,16 @@ END FUNCTION cp_printkey_is_iter !> (and should consequently ignore some iteration levels depending !> on COMMON_ITERATION_LEVELS). !> Defaults to false. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi !> \note !> If the root level is 1 removes it ! ***************************************************************************** - FUNCTION cp_iter_string(iter_info,print_key,for_file,error) RESULT(res) + FUNCTION cp_iter_string(iter_info,print_key,for_file) RESULT(res) TYPE(cp_iteration_info_type), POINTER :: iter_info TYPE(section_vals_type), OPTIONAL, & POINTER :: print_key LOGICAL, INTENT(IN), OPTIONAL :: for_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=default_string_length) :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_iter_string', & @@ -562,14 +546,14 @@ FUNCTION cp_iter_string(iter_info,print_key,for_file,error) RESULT(res) res="" my_for_file=.FALSE. IF (PRESENT(for_file)) my_for_file=for_file - CPPrecondition(ASSOCIATED(iter_info),cp_failure_level,routineP,error,failure) - CPPrecondition(iter_info%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(iter_info),cp_failure_level,routineP,failure) + CPPrecondition(iter_info%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(my_print_key) IF (PRESENT(print_key)) my_print_key => print_key s_level=1 IF (ASSOCIATED(my_print_key)) THEN - CALL section_vals_val_get(my_print_key,"ADD_LAST",i_val=add_last,error=error) - CALL section_vals_val_get(my_print_key,"COMMON_ITERATION_LEVELS",i_val=c_i_level, error=error) + CALL section_vals_val_get(my_print_key,"ADD_LAST",i_val=add_last) + CALL section_vals_val_get(my_print_key,"COMMON_ITERATION_LEVELS",i_val=c_i_level) n_rlevel=iter_info%n_rlevel IF (my_for_file) n_rlevel=MIN(n_rlevel,MAX(0,n_rlevel-c_i_level)) DO ilevel=s_level,n_rlevel @@ -601,18 +585,15 @@ END FUNCTION cp_iter_string !> \param iter_nr ... !> \param increment ... !> \param iter_nr_out ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> this is supposed to be called at the beginning of each iteration ! ***************************************************************************** - SUBROUTINE cp_iterate(iteration_info,last,iter_nr,increment,iter_nr_out,error) + SUBROUTINE cp_iterate(iteration_info,last,iter_nr,increment,iter_nr_out) TYPE(cp_iteration_info_type), POINTER :: iteration_info LOGICAL, INTENT(IN), OPTIONAL :: last INTEGER, INTENT(IN), OPTIONAL :: iter_nr, increment INTEGER, INTENT(OUT), OPTIONAL :: iter_nr_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_iterate', & routineP = moduleN//':'//routineN @@ -627,8 +608,8 @@ SUBROUTINE cp_iterate(iteration_info,last,iter_nr,increment,iter_nr_out,error) IF (PRESENT(increment)) my_increment = increment IF (PRESENT(iter_nr_out)) iter_nr_out = -1 - CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,error,failure) - CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,failure) + CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(iter_nr)) THEN iteration_info%iteration(iteration_info%n_rlevel)=iter_nr ELSE @@ -648,15 +629,12 @@ END SUBROUTINE cp_iterate !> to be added !> \param level_name the name of this level, for pretty printing only, right now !> \param n_rlevel_new number of iteration levels after this call -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_add_iter_level(iteration_info,level_name,n_rlevel_new,error) + SUBROUTINE cp_add_iter_level(iteration_info,level_name,n_rlevel_new) TYPE(cp_iteration_info_type), POINTER :: iteration_info CHARACTER(LEN=*), INTENT(IN) :: level_name INTEGER, INTENT(OUT), OPTIONAL :: n_rlevel_new - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_add_iter_level', & routineP = moduleN//':'//routineN @@ -666,8 +644,8 @@ SUBROUTINE cp_add_iter_level(iteration_info,level_name,n_rlevel_new,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,error,failure) - CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,failure) + CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,failure) found = .FALSE. DO i = 1, SIZE(each_possible_labels) IF (TRIM(level_name)==TRIM(each_possible_labels(i))) THEN @@ -700,15 +678,12 @@ END SUBROUTINE cp_add_iter_level !> to be removed !> \param level_name level_name to be destroyed (if does not match gives an error) !> \param n_rlevel_att iteration level before the call (to do some checks) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE cp_rm_iter_level(iteration_info,level_name,n_rlevel_att,error) + SUBROUTINE cp_rm_iter_level(iteration_info,level_name,n_rlevel_att) TYPE(cp_iteration_info_type), POINTER :: iteration_info CHARACTER(LEN=*), INTENT(IN) :: level_name INTEGER, INTENT(IN), OPTIONAL :: n_rlevel_att - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_rm_iter_level', & routineP = moduleN//':'//routineN @@ -717,16 +692,16 @@ SUBROUTINE cp_rm_iter_level(iteration_info,level_name,n_rlevel_att,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,error,failure) - CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(iteration_info),cp_failure_level,routineP,failure) + CPPrecondition(iteration_info%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(n_rlevel_att)) THEN - CPPrecondition(n_rlevel_att==iteration_info%n_rlevel,cp_failure_level,routineP,error,failure) + CPPrecondition(n_rlevel_att==iteration_info%n_rlevel,cp_failure_level,routineP,failure) END IF CALL cp_iteration_info_release(iteration_info) ! This check that the iteration levels are consistently created and destroyed.. ! Never remove this check.. check = iteration_info%level_name(iteration_info%n_rlevel)==level_name - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) iteration_info%n_rlevel=iteration_info%n_rlevel-1 CALL reallocate(iteration_info%iteration, 1, iteration_info%n_rlevel) CALL reallocate(iteration_info%level_name, 1, iteration_info%n_rlevel) @@ -755,19 +730,16 @@ END SUBROUTINE cp_rm_iter_level !> \param extension extension to be applied to the filename (including the ".") !> \param my_local if the unit should be local to this task, or global to the !> program (defaults to false). -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval filename ... !> \author Fawzi Mohamed ! ***************************************************************************** FUNCTION cp_print_key_generate_filename(logger,print_key,middle_name,extension,& - my_local, error) RESULT(filename) + my_local) RESULT(filename) TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: print_key CHARACTER(len=*), INTENT(IN), OPTIONAL :: middle_name CHARACTER(len=*), INTENT(IN) :: extension LOGICAL, INTENT(IN) :: my_local - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=default_path_length) :: filename CHARACTER(len=default_path_length) :: outPath, postfix, root @@ -775,7 +747,7 @@ FUNCTION cp_print_key_generate_filename(logger,print_key,middle_name,extension,& INTEGER :: my_ind1, my_ind2 LOGICAL :: has_root - CALL section_vals_val_get(print_key,"FILENAME",c_val=outPath,error=error) + CALL section_vals_val_get(print_key,"FILENAME",c_val=outPath) IF (outPath(1:1)=='=') THEN filename=outPath(2:LEN_TRIM(outPath)) RETURN @@ -820,7 +792,7 @@ FUNCTION cp_print_key_generate_filename(logger,print_key,middle_name,extension,& END IF ! use the cp_iter_string as a postfix - postfix="-"//TRIM(cp_iter_string(logger%iter_info,print_key=print_key,for_file=.TRUE.,error=error)) + postfix="-"//TRIM(cp_iter_string(logger%iter_info,print_key=print_key,for_file=.TRUE.)) IF (TRIM(postfix)=="-") postfix="" ! and add the extension @@ -848,12 +820,11 @@ END FUNCTION cp_print_key_generate_filename !> \param do_backup ... !> \param on_file ... !> \param is_new_file true if this rank created a new (or rewound) file, false otherwise -!> \param error ... !> \retval res ... ! ***************************************************************************** FUNCTION cp_print_key_unit_nr(logger, basis_section, print_key_path, extension,& middle_name, local, log_filename,ignore_should_output, file_form, file_position,& - file_action, file_status, do_backup, on_file, is_new_file,error) RESULT(res) + file_action, file_status, do_backup, on_file, is_new_file) RESULT(res) TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: basis_section CHARACTER(len=*), INTENT(IN), OPTIONAL :: print_key_path @@ -865,7 +836,6 @@ FUNCTION cp_print_key_unit_nr(logger, basis_section, print_key_path, extension,& file_action, file_status LOGICAL, INTENT(IN), OPTIONAL :: do_backup, on_file LOGICAL, INTENT(OUT), OPTIONAL :: is_new_file - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_print_key_unit_nr', & @@ -904,18 +874,18 @@ FUNCTION cp_print_key_unit_nr(logger, basis_section, print_key_path, extension,& IF (PRESENT(local)) my_local = local IF (PRESENT(is_new_file)) is_new_file = .FALSE. NULLIFY(print_key) - CPPrecondition(ASSOCIATED(basis_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,error,failure) - CPPrecondition(basis_section%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(logger%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(basis_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,failure) + CPPrecondition(basis_section%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(logger%ref_count>0,cp_failure_level,routineP,failure) my_should_output=BTEST(cp_print_key_should_output(logger%iter_info,& - basis_section,print_key_path,used_print_key=print_key,error=error),cp_p_file) + basis_section,print_key_path,used_print_key=print_key),cp_p_file) IF (PRESENT(ignore_should_output)) my_should_output=my_should_output.or.ignore_should_output IF (.NOT.my_should_output) RETURN IF (my_local.OR.& logger%para_env%mepos==logger%para_env%source) THEN - CALL section_vals_val_get(print_key,"FILENAME",c_val=outPath,error=error) + CALL section_vals_val_get(print_key,"FILENAME",c_val=outPath) IF (outPath=='__STD_OUT__'.AND..NOT.my_on_file) THEN res=cp_logger_get_default_unit_nr(logger,local=my_local) ELSE @@ -926,7 +896,7 @@ FUNCTION cp_print_key_unit_nr(logger, basis_section, print_key_path, extension,& ! ! if it is actually a full path, use it as the root filename = cp_print_key_generate_filename(logger,print_key,middle_name,extension,& - my_local,error) + my_local) ! Give back info about a possible existence of the file if required IF (PRESENT(is_new_file)) THEN INQUIRE(FILE=filename,EXIST=found) @@ -938,17 +908,17 @@ FUNCTION cp_print_key_unit_nr(logger, basis_section, print_key_path, extension,& IF (PRESENT(log_filename)) THEN do_log = log_filename ELSE - CALL section_vals_val_get(print_key,"LOG_PRINT_KEY",l_val=do_log,error=error) + CALL section_vals_val_get(print_key,"LOG_PRINT_KEY",l_val=do_log) END IF ! If required do a backup IF (my_do_backup) THEN INQUIRE(FILE=filename,EXIST=found) - CALL section_vals_val_get(print_key,"BACKUP_COPIES",i_val=nbak,error=error) + CALL section_vals_val_get(print_key,"BACKUP_COPIES",i_val=nbak) IF (nbak/=0) THEN iteration_info => logger%iter_info s_backup_level = 0 IF (ASSOCIATED(print_key%ibackup)) s_backup_level = SIZE(print_key%ibackup) - CALL section_vals_val_get(print_key,"COMMON_ITERATION_LEVELS",i_val=c_i_level, error=error) + CALL section_vals_val_get(print_key,"COMMON_ITERATION_LEVELS",i_val=c_i_level) my_backup_level = MAX(1,iteration_info%n_rlevel-c_i_level+1) f_backup_level = MAX(s_backup_level,my_backup_level) IF (f_backup_level>s_backup_level) THEN @@ -999,7 +969,7 @@ FUNCTION cp_print_key_unit_nr(logger, basis_section, print_key_path, extension,& IF (do_log) THEN CALL cp_log(logger=logger, level=cp_note_level, fromWhere=routineP,& message="Writing "//TRIM(print_key%section%name)//" "//& - TRIM(cp_iter_string(logger%iter_info,error=error))//" to "//& + TRIM(cp_iter_string(logger%iter_info))//" to "//& TRIM(filename),local=my_local) END IF END IF @@ -1022,7 +992,6 @@ END FUNCTION cp_print_key_unit_nr !> \param local ... !> \param ignore_should_output ... !> \param on_file ... -!> \param error ... !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -1031,14 +1000,13 @@ END FUNCTION cp_print_key_unit_nr !> not __STD_OUT__ ! ***************************************************************************** SUBROUTINE cp_print_key_finished_output(unit_nr, logger, basis_section,& - print_key_path,local,ignore_should_output,on_file,error) + print_key_path,local,ignore_should_output,on_file) INTEGER, INTENT(INOUT) :: unit_nr TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: basis_section CHARACTER(len=*), INTENT(IN), OPTIONAL :: print_key_path LOGICAL, INTENT(IN), OPTIONAL :: local, ignore_should_output, & on_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_print_key_finished_output', & routineP = moduleN//':'//routineN @@ -1054,25 +1022,25 @@ SUBROUTINE cp_print_key_finished_output(unit_nr, logger, basis_section,& NULLIFY(print_key) IF (PRESENT(local)) my_local=local IF (PRESENT(on_file)) my_on_file=on_file - CPPrecondition(ASSOCIATED(basis_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,error,failure) - CPPrecondition(basis_section%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(logger%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(basis_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(logger),cp_failure_level,routineP,failure) + CPPrecondition(basis_section%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(logger%ref_count>0,cp_failure_level,routineP,failure) my_should_output=BTEST(cp_print_key_should_output(logger%iter_info,basis_section,& - print_key_path,used_print_key=print_key,error=error),cp_p_file) + print_key_path,used_print_key=print_key),cp_p_file) IF (PRESENT(ignore_should_output)) my_should_output=my_should_output.or.ignore_should_output IF (my_should_output.and.(my_local.OR.& logger%para_env%source==logger%para_env%mepos)) THEN - CALL section_vals_val_get(print_key,"FILENAME",c_val=outPath,error=error) + CALL section_vals_val_get(print_key,"FILENAME",c_val=outPath) IF (my_on_file.OR.outPath.NE.'__STD_OUT__') THEN - CPPrecondition(unit_nr>0,cp_failure_level,routineP,error,failure) + CPPrecondition(unit_nr>0,cp_failure_level,routineP,failure) CALL close_file(unit_nr,"KEEP") unit_nr=-1 ELSE unit_nr=-1 ENDIF END IF - CPPostcondition(unit_nr==-1,cp_failure_level,routineP,error,failure) + CPPostcondition(unit_nr==-1,cp_failure_level,routineP,failure) unit_nr=-1 END SUBROUTINE cp_print_key_finished_output @@ -1095,13 +1063,11 @@ END SUBROUTINE cp_print_key_finished_output !> \param ignore_should_output if true always returns a valid unit (ignoring !> cp_print_key_should_output) !> \param on_file ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE cp_print_key_log(logger, basis_section, print_key_path, extension,& message,middle_name, local, log_filename,ignore_should_output, & - on_file, error) + on_file) TYPE(cp_logger_type), POINTER :: logger TYPE(section_vals_type), POINTER :: basis_section CHARACTER(len=*), INTENT(IN), OPTIONAL :: print_key_path @@ -1109,7 +1075,6 @@ SUBROUTINE cp_print_key_log(logger, basis_section, print_key_path, extension,& CHARACTER(len=*), INTENT(IN), OPTIONAL :: middle_name LOGICAL, INTENT(IN), OPTIONAL :: local, log_filename, & ignore_should_output, on_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_print_key_log', & routineP = moduleN//':'//routineN @@ -1126,13 +1091,13 @@ SUBROUTINE cp_print_key_log(logger, basis_section, print_key_path, extension,& print_key_path=print_key_path,extension=extension,& middle_name=middle_name, local=local, log_filename=log_filename,& ignore_should_output=ignore_should_output, & - on_file=on_file, error=error) + on_file=on_file) IF (output_unit>0) THEN WRITE(output_unit,"(a)")message CALL cp_print_key_finished_output(output_unit,logger,& basis_section=basis_section,print_key_path=print_key_path,& local=local,ignore_should_output=ignore_should_output,& - on_file=on_file,error=error) + on_file=on_file) END IF END IF END SUBROUTINE cp_print_key_log diff --git a/src/input/cp_parser_buffer_types.F b/src/input/cp_parser_buffer_types.F index 06b9f5a610..a851dd80b3 100644 --- a/src/input/cp_parser_buffer_types.F +++ b/src/input/cp_parser_buffer_types.F @@ -42,13 +42,11 @@ MODULE cp_parser_buffer_types ! **************************************************************************** !> \brief Creates the parser buffer type !> \param buffer ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE create_buffer_type(buffer, error) + SUBROUTINE create_buffer_type(buffer) TYPE(buffer_type), POINTER :: buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_buffer_type', & routineP = moduleN//':'//routineN @@ -57,14 +55,14 @@ SUBROUTINE create_buffer_type(buffer, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(buffer),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(buffer),cp_failure_level,routineP,failure) ALLOCATE(buffer, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer%size = buffer_size ALLOCATE(buffer%input_lines(buffer%size), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(buffer%input_line_numbers(buffer%size), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer%buffer_id = 0 buffer%input_line_numbers = 0 buffer%istat = 0 @@ -76,13 +74,11 @@ END SUBROUTINE create_buffer_type ! **************************************************************************** !> \brief Releases the parser buffer type !> \param buffer ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - RECURSIVE SUBROUTINE release_buffer_type(buffer, error) + RECURSIVE SUBROUTINE release_buffer_type(buffer) TYPE(buffer_type), POINTER :: buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_buffer_type', & routineP = moduleN//':'//routineN @@ -91,16 +87,16 @@ RECURSIVE SUBROUTINE release_buffer_type(buffer, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(buffer),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(buffer),cp_failure_level,routineP,failure) DEALLOCATE(buffer%input_lines, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(buffer%input_line_numbers, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(buffer%sub_buffer)) THEN - CALL release_buffer_type(buffer%sub_buffer, error) + CALL release_buffer_type(buffer%sub_buffer) END IF DEALLOCATE(buffer, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_buffer_type ! **************************************************************************** @@ -108,14 +104,12 @@ END SUBROUTINE release_buffer_type !> \param buffer_in ... !> \param buffer_out ... !> \param force ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - RECURSIVE SUBROUTINE copy_buffer_type(buffer_in, buffer_out, force, error) + RECURSIVE SUBROUTINE copy_buffer_type(buffer_in, buffer_out, force) TYPE(buffer_type), POINTER :: buffer_in, buffer_out LOGICAL, INTENT(IN), OPTIONAL :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'copy_buffer_type', & routineP = moduleN//':'//routineN @@ -124,9 +118,9 @@ RECURSIVE SUBROUTINE copy_buffer_type(buffer_in, buffer_out, force, error) LOGICAL :: failure, my_force failure = .FALSE. - CPPostcondition(ASSOCIATED(buffer_in),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(buffer_out),cp_failure_level,routineP,error,failure) - CPPostcondition(buffer_in%size==buffer_out%size,cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(buffer_in),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(buffer_out),cp_failure_level,routineP,failure) + CPPostcondition(buffer_in%size==buffer_out%size,cp_failure_level,routineP,failure) my_force = .FALSE. IF (PRESENT(force)) my_force = force ! Copy buffer structure @@ -143,7 +137,7 @@ RECURSIVE SUBROUTINE copy_buffer_type(buffer_in, buffer_out, force, error) END DO END IF IF (ASSOCIATED(buffer_in%sub_buffer).AND.ASSOCIATED(buffer_out%sub_buffer)) THEN - CALL copy_buffer_type(buffer_in%sub_buffer, buffer_out%sub_buffer, force, error) + CALL copy_buffer_type(buffer_in%sub_buffer, buffer_out%sub_buffer, force) END IF END SUBROUTINE copy_buffer_type @@ -151,13 +145,11 @@ END SUBROUTINE copy_buffer_type !> \brief Initializes sub buffer structure !> \param sub_buffer ... !> \param buffer ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE initialize_sub_buffer(sub_buffer, buffer, error) + SUBROUTINE initialize_sub_buffer(sub_buffer, buffer) TYPE(buffer_type), POINTER :: sub_buffer, buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_sub_buffer', & routineP = moduleN//':'//routineN @@ -165,10 +157,10 @@ SUBROUTINE initialize_sub_buffer(sub_buffer, buffer, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(buffer),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(sub_buffer),cp_failure_level,routineP,error,failure) - CALL create_buffer_type(sub_buffer, error) - CALL copy_buffer_type(buffer, sub_buffer,error=error) + CPPostcondition(ASSOCIATED(buffer),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(sub_buffer),cp_failure_level,routineP,failure) + CALL create_buffer_type(sub_buffer) + CALL copy_buffer_type(buffer, sub_buffer) sub_buffer%present_line_number = 0 END SUBROUTINE initialize_sub_buffer @@ -177,13 +169,11 @@ END SUBROUTINE initialize_sub_buffer !> \brief Finalizes sub buffer structure !> \param sub_buffer ... !> \param buffer ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE finalize_sub_buffer(sub_buffer, buffer, error) + SUBROUTINE finalize_sub_buffer(sub_buffer, buffer) TYPE(buffer_type), POINTER :: sub_buffer, buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'finalize_sub_buffer', & routineP = moduleN//':'//routineN @@ -191,10 +181,10 @@ SUBROUTINE finalize_sub_buffer(sub_buffer, buffer, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(buffer),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(sub_buffer),cp_failure_level,routineP,error,failure) - CALL copy_buffer_type(sub_buffer,buffer,error=error) - CALL release_buffer_type(sub_buffer, error=error) + CPPostcondition(ASSOCIATED(buffer),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(sub_buffer),cp_failure_level,routineP,failure) + CALL copy_buffer_type(sub_buffer,buffer) + CALL release_buffer_type(sub_buffer) END SUBROUTINE finalize_sub_buffer END MODULE cp_parser_buffer_types diff --git a/src/input/cp_parser_ilist_methods.F b/src/input/cp_parser_ilist_methods.F index 7cd69c5b88..d8a259e884 100644 --- a/src/input/cp_parser_ilist_methods.F +++ b/src/input/cp_parser_ilist_methods.F @@ -28,14 +28,12 @@ MODULE cp_parser_ilist_methods !> \brief setup the integer listing type !> \param ilist ... !> \param token ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE ilist_setup(ilist, token, error) + SUBROUTINE ilist_setup(ilist, token) TYPE(ilist_type), POINTER :: ilist CHARACTER(LEN=*) :: token - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ilist_setup', & routineP = moduleN//':'//routineN @@ -44,7 +42,7 @@ SUBROUTINE ilist_setup(ilist, token, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,failure) ind = INDEX(token,"..") READ (UNIT=token(:ind-1),FMT=*) ilist%istart READ (UNIT=token(ind+2:),FMT=*) ilist%iend @@ -62,13 +60,11 @@ END SUBROUTINE ilist_setup ! **************************************************************************** !> \brief updates the integer listing type !> \param ilist ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE ilist_update(ilist, error) + SUBROUTINE ilist_update(ilist) TYPE(ilist_type), POINTER :: ilist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ilist_update', & routineP = moduleN//':'//routineN @@ -76,23 +72,21 @@ SUBROUTINE ilist_update(ilist, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,failure) ilist%ipresent = ilist%ipresent + 1 IF (ilist%ipresent>ilist%iend) THEN - CALL ilist_reset(ilist, error) + CALL ilist_reset(ilist) END IF END SUBROUTINE ilist_update ! **************************************************************************** !> \brief updates the integer listing type !> \param ilist ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE ilist_reset(ilist, error) + SUBROUTINE ilist_reset(ilist) TYPE(ilist_type), POINTER :: ilist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ilist_reset', & routineP = moduleN//':'//routineN @@ -100,7 +94,7 @@ SUBROUTINE ilist_reset(ilist, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,failure) IF (ilist%ipresent==ilist%iend) THEN ilist%istart = HUGE(0) ilist%iend = HUGE(0) diff --git a/src/input/cp_parser_ilist_types.F b/src/input/cp_parser_ilist_types.F index 70dcc1499e..b01327bed4 100644 --- a/src/input/cp_parser_ilist_types.F +++ b/src/input/cp_parser_ilist_types.F @@ -34,13 +34,11 @@ MODULE cp_parser_ilist_types ! **************************************************************************** !> \brief creates the integer listing type !> \param ilist ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE create_ilist_type(ilist, error) + SUBROUTINE create_ilist_type(ilist) TYPE(ilist_type), POINTER :: ilist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ilist_type', & routineP = moduleN//':'//routineN @@ -49,9 +47,9 @@ SUBROUTINE create_ilist_type(ilist, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(ilist),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(ilist),cp_failure_level,routineP,failure) ALLOCATE(ilist, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ilist%istart = HUGE(0) ilist%iend = HUGE(0) ilist%nel_list = HUGE(0) @@ -63,13 +61,11 @@ END SUBROUTINE create_ilist_type ! **************************************************************************** !> \brief creates the integer listing type !> \param ilist ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE release_ilist_type(ilist, error) + SUBROUTINE release_ilist_type(ilist) TYPE(ilist_type), POINTER :: ilist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_ilist_type', & routineP = moduleN//':'//routineN @@ -78,9 +74,9 @@ SUBROUTINE release_ilist_type(ilist, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ilist),cp_failure_level,routineP,failure) DEALLOCATE(ilist, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_ilist_type END MODULE cp_parser_ilist_types diff --git a/src/input/cp_parser_inpp_methods.F b/src/input/cp_parser_inpp_methods.F index 8e0be0b12f..78ca315fe3 100644 --- a/src/input/cp_parser_inpp_methods.F +++ b/src/input/cp_parser_inpp_methods.F @@ -45,7 +45,6 @@ MODULE cp_parser_inpp_methods !> \param input_file_name ... !> \param input_line_number ... !> \param input_unit ... -!> \param error ... !> \par History !> - standalone proof-of-concept implementation (20.02.2008,AK) !> - integration into cp2k (22.02.2008,tlaino) @@ -54,11 +53,10 @@ MODULE cp_parser_inpp_methods !> \author AK ! ***************************************************************************** SUBROUTINE inpp_process_directive(inpp, input_line, input_file_name, input_line_number,& - input_unit, error) + input_unit) TYPE(inpp_type), POINTER :: inpp CHARACTER(LEN=*), INTENT(INOUT) :: input_line, input_file_name INTEGER, INTENT(INOUT) :: input_line_number, input_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'inpp_process_directive', & routineP = moduleN//':'//routineN @@ -71,11 +69,11 @@ SUBROUTINE inpp_process_directive(inpp, input_line, input_file_name, input_line_ LOGICAL :: check, failure TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) failure = .TRUE. - CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,failure) ! find location of directive in line and check whether it is commented out indi = INDEX(input_line,"@") @@ -137,10 +135,10 @@ SUBROUTINE inpp_process_directive(inpp, input_line, input_file_name, input_line_ ! Let's check that files already opened won't be again opened DO i = 1, inpp%io_stack_level check = TRIM(filename)/=TRIM(inpp%io_stack_filename(i)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END DO - ! this stops on error, so we can always assume success + ! this stops on so we can always assume success CALL open_file(file_name=TRIM(filename),& file_status="OLD",& file_form="FORMATTED",& @@ -349,7 +347,7 @@ SUBROUTINE inpp_process_directive(inpp, input_line, input_file_name, input_line_ DO WHILE (input_line(indf:indf)/=" ") indf = indf + 1 END DO - CPPostcondition((indf-indi)<=default_string_length,cp_failure_level,routineP,error,failure) + CPPostcondition((indf-indi)<=default_string_length,cp_failure_level,routineP,failure) mytag =input_line(indi:indf-1) CALL uppercase(mytag) IF(INDEX(mytag,"@ENDIF")>0) THEN @@ -396,17 +394,15 @@ END SUBROUTINE inpp_process_directive !> \param input_file_name ... !> \param input_line_number ... !> \param input_unit ... -!> \param error ... !> \par History !> - standalone proof-of-concept implemenation (20.02.2008,AK) !> - integrated into cp2k (21.02.2008) !> \author AK ! ***************************************************************************** - SUBROUTINE inpp_end_include(inpp, input_file_name, input_line_number, input_unit, error) + SUBROUTINE inpp_end_include(inpp, input_file_name, input_line_number, input_unit) TYPE(inpp_type), POINTER :: inpp CHARACTER(LEN=*), INTENT(INOUT) :: input_file_name INTEGER, INTENT(INOUT) :: input_line_number, input_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'inpp_end_include', & routineP = moduleN//':'//routineN @@ -414,7 +410,7 @@ SUBROUTINE inpp_end_include(inpp, input_file_name, input_line_number, input_unit LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,failure) IF(inpp%io_stack_level > 0) THEN CALL close_file(input_unit) input_unit=inpp%io_stack_channel(inpp%io_stack_level) @@ -434,18 +430,15 @@ END SUBROUTINE inpp_end_include !> \param input_line ... !> \param input_file_name ... !> \param input_line_number ... -!> \param error ... !> \par History !> - standalone proof-of-concept implemenation (22.02.2008,AK) !> - integrated into cp2k (23.02.2008) !> \author AK ! ***************************************************************************** - SUBROUTINE inpp_expand_variables(inpp, input_line, input_file_name, input_line_number,& - error) + SUBROUTINE inpp_expand_variables(inpp, input_line, input_file_name, input_line_number) TYPE(inpp_type), POINTER :: inpp CHARACTER(LEN=*), INTENT(INOUT) :: input_line, input_file_name INTEGER, INTENT(IN) :: input_line_number - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'inpp_expand_variables', & routineP = moduleN//':'//routineN @@ -456,14 +449,14 @@ SUBROUTINE inpp_expand_variables(inpp, input_line, input_file_name, input_line_n LOGICAL :: failure failure = .TRUE. - CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,failure) ! process line until all variables named with the convention ${VAR} are expanded DO WHILE (INDEX(input_line,'${') > 0) pos1=INDEX(input_line,'${') pos1=pos1+2 pos2=INDEX(input_line(pos1:),'}') - CPPostcondition(pos2>0,cp_failure_level,routineP,error,failure) + CPPostcondition(pos2>0,cp_failure_level,routineP,failure) IF(pos2==0) THEN WRITE(UNIT=message,FMT="(3A,I6)") & "INPP_@SET: Missing '}' in file: ",& @@ -474,7 +467,7 @@ SUBROUTINE inpp_expand_variables(inpp, input_line, input_file_name, input_line_n pos2=pos1+pos2-2 varname=input_line(pos1:pos2) idx=inpp_find_variable(inpp,varname) - CPPostcondition(idx>0,cp_failure_level,routineP,error,failure) + CPPostcondition(idx>0,cp_failure_level,routineP,failure) IF(idx==0) THEN WRITE(UNIT=message,FMT="(5A,I6)") & "INPP_@SET: Variable ${",TRIM(varname),"} not defined in file: ",& @@ -497,13 +490,13 @@ SUBROUTINE inpp_expand_variables(inpp, input_line, input_file_name, input_line_n pos1=INDEX(input_line,'$') pos1=pos1+1 pos2=INDEX(input_line(pos1:),' ') - CPPostcondition(pos2>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(pos2>=0,cp_failure_level,routineP,failure) IF(pos2==0) pos2 = LEN_TRIM(input_line(pos1:))+1 pos2=pos1+pos2-1 varname=input_line(pos1:pos2) idx=inpp_find_variable(inpp,varname) - CPPostcondition(idx>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(idx>=0,cp_failure_level,routineP,failure) IF(idx==0) THEN WRITE(UNIT=message,FMT="(5A,I6)") & "INPP_@SET: Variable $",TRIM(varname)," not defined in file: ",& diff --git a/src/input/cp_parser_inpp_types.F b/src/input/cp_parser_inpp_types.F index fa6e18ea90..85dd734a87 100644 --- a/src/input/cp_parser_inpp_types.F +++ b/src/input/cp_parser_inpp_types.F @@ -48,15 +48,13 @@ MODULE cp_parser_inpp_types !> \brief creates the internal preprocessing type !> \param inpp ... !> \param initial_variables ... -!> \param error ... !> \date 22.02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE create_inpp_type(inpp, initial_variables, error) + SUBROUTINE create_inpp_type(inpp, initial_variables) TYPE(inpp_type), POINTER :: inpp CHARACTER(len=default_path_length), & DIMENSION(:, :), POINTER :: initial_variables - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_inpp_type', & routineP = moduleN//':'//routineN @@ -65,9 +63,9 @@ SUBROUTINE create_inpp_type(inpp, initial_variables, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(inpp),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(inpp),cp_failure_level,routineP,failure) ALLOCATE(inpp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) inpp%io_stack_level = 0 NULLIFY(inpp%io_stack_channel,& @@ -81,10 +79,10 @@ SUBROUTINE create_inpp_type(inpp, initial_variables, error) IF (ASSOCIATED(initial_variables)) THEN inpp%num_variables =SIZE(initial_variables,2) ALLOCATE(inpp%variable_name(inpp%num_variables),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) inpp%variable_name=initial_variables(1,:) ALLOCATE(inpp%variable_value(inpp%num_variables),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) inpp%variable_value=initial_variables(2,:) ENDIF @@ -93,13 +91,11 @@ END SUBROUTINE create_inpp_type ! **************************************************************************** !> \brief releases the internal preprocessing type !> \param inpp ... -!> \param error ... !> \date 22.02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE release_inpp_type(inpp, error) + SUBROUTINE release_inpp_type(inpp) TYPE(inpp_type), POINTER :: inpp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_inpp_type', & routineP = moduleN//':'//routineN @@ -108,32 +104,32 @@ SUBROUTINE release_inpp_type(inpp, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(inpp),cp_failure_level,routineP,failure) IF (ASSOCIATED(inpp%io_stack_channel)) THEN DEALLOCATE(inpp%io_stack_channel,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(inpp%io_stack_lineno)) THEN DEALLOCATE(inpp%io_stack_lineno,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(inpp%io_stack_filename)) THEN DEALLOCATE(inpp%io_stack_filename,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(inpp%variable_name)) THEN DEALLOCATE(inpp%variable_name,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(inpp%variable_value)) THEN DEALLOCATE(inpp%variable_value,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(inpp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_inpp_type END MODULE cp_parser_inpp_types diff --git a/src/input/cp_parser_methods.F b/src/input/cp_parser_methods.F index 46c86c8d43..5cee10fabd 100644 --- a/src/input/cp_parser_methods.F +++ b/src/input/cp_parser_methods.F @@ -61,15 +61,12 @@ MODULE cp_parser_methods ! ***************************************************************************** !> \brief return a description of the part of the file acually parsed !> \param parser the parser -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION parser_location(parser,error) RESULT(res) + FUNCTION parser_location(parser) RESULT(res) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=& default_path_length+default_string_length& ) :: res @@ -80,8 +77,8 @@ FUNCTION parser_location(parser,error) RESULT(res) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) res = ", File: '"//TRIM(parser%input_file_name)//"', Line: "//& TRIM(ADJUSTL(cp_to_string(parser%input_line_number)))//& ", Column: "//TRIM(ADJUSTL(cp_to_string(parser%icol))) @@ -97,14 +94,12 @@ END FUNCTION parser_location ! ***************************************************************************** !> \brief store the present status of the parser !> \param parser ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE parser_store_status(parser, error) + SUBROUTINE parser_store_status(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_store_status', & routineP = moduleN//':'//routineN @@ -112,9 +107,9 @@ SUBROUTINE parser_store_status(parser, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(parser%status),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(parser%status),cp_failure_level,routineP,failure) parser%status%in_use = .TRUE. parser%status%old_input_line = parser%input_line parser%status%old_input_line_number = parser%input_line_number @@ -122,21 +117,19 @@ SUBROUTINE parser_store_status(parser, error) parser%status%old_icol1 = parser%icol1 parser%status%old_icol2 = parser%icol2 ! Store buffer info - CALL copy_buffer_type(parser%buffer, parser%status%buffer, error=error) + CALL copy_buffer_type(parser%buffer, parser%status%buffer) END SUBROUTINE parser_store_status ! ***************************************************************************** !> \brief retrieve the original status of the parser !> \param parser ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE parser_retrieve_status(parser, error) + SUBROUTINE parser_retrieve_status(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_retrieve_status', & routineP = moduleN//':'//routineN @@ -144,12 +137,12 @@ SUBROUTINE parser_retrieve_status(parser, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) ! Always store the new buffer (if it is really newly read) IF (parser%buffer%buffer_id/=parser%status%buffer%buffer_id) THEN - CALL initialize_sub_buffer(parser%buffer%sub_buffer, parser%buffer, error) + CALL initialize_sub_buffer(parser%buffer%sub_buffer, parser%buffer) END IF parser%status%in_use = .FALSE. parser%input_line = parser%status%old_input_line @@ -159,7 +152,7 @@ SUBROUTINE parser_retrieve_status(parser, error) parser%icol2 = parser%status%old_icol2 ! Retrieve buffer info - CALL copy_buffer_type(parser%status%buffer, parser%buffer, error=error) + CALL copy_buffer_type(parser%status%buffer, parser%buffer) END SUBROUTINE parser_retrieve_status @@ -169,18 +162,16 @@ END SUBROUTINE parser_retrieve_status !> \param parser ... !> \param nline ... !> \param at_end ... -!> \param error ... !> \date 22.11.1999 !> \author Matthias Krack (MK) !> \version 1.0 !> \note 08.2008 [tlaino] - Teodoro Laino UZH : updated for buffer ! ***************************************************************************** - SUBROUTINE parser_read_line(parser,nline,at_end,error) + SUBROUTINE parser_read_line(parser,nline,at_end) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(IN) :: nline LOGICAL, INTENT(out), OPTIONAL :: at_end - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_read_line', & routineP = moduleN//':'//routineN @@ -191,20 +182,20 @@ SUBROUTINE parser_read_line(parser,nline,at_end,error) CALL timeset(routineN, handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(at_end)) at_end = .FALSE. DO iline=1,nline ! Try to read the next line from the buffer - CALL parser_get_line_from_buffer(parser, istat, error) + CALL parser_get_line_from_buffer(parser, istat) ! Handle (persisting) read errors IF (istat /= 0) THEN IF (istat < 0) THEN ! EOF/EOR is negative other errors positive CALL cp_assert(PRESENT(at_end),cp_failure_level,cp_assertion_failed,& - routineP,"Unexpected EOF"//TRIM(parser_location(parser,error=error)),& - error,failure) + routineP,"Unexpected EOF"//TRIM(parser_location(parser)),& + failure) IF (PRESENT(at_end)) at_end = .TRUE. parser%icol = -1 parser%icol1 = 0 @@ -213,7 +204,7 @@ SUBROUTINE parser_read_line(parser,nline,at_end,error) CALL cp_assert(.FALSE.,cp_failure_level,istat,routineP,& "An I/O error occurred (IOSTAT = "//& TRIM(ADJUSTL(cp_to_string(istat)))//")"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF CALL timestop(handle) RETURN @@ -231,15 +222,13 @@ END SUBROUTINE parser_read_line !> \brief Retrieving lines from buffer !> \param parser ... !> \param istat ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE parser_get_line_from_buffer(parser, istat, error) + SUBROUTINE parser_get_line_from_buffer(parser, istat) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(OUT) :: istat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_get_line_from_buffer', & routineP = moduleN//':'//routineN @@ -249,10 +238,10 @@ SUBROUTINE parser_get_line_from_buffer(parser, istat, error) IF (parser%buffer%present_line_number==parser%buffer%size) THEN IF(ASSOCIATED(parser%buffer%sub_buffer)) THEN ! If the sub_buffer is initialized let's restore its buffer - CALL finalize_sub_buffer(parser%buffer%sub_buffer,parser%buffer,error=error) + CALL finalize_sub_buffer(parser%buffer%sub_buffer,parser%buffer) ELSE ! Rebuffer input file if required - CALL parser_read_line_low(parser,error) + CALL parser_read_line_low(parser) END IF END IF parser%buffer%present_line_number = parser%buffer%present_line_number+1 @@ -268,14 +257,12 @@ END SUBROUTINE parser_get_line_from_buffer ! ***************************************************************************** !> \brief Low level reading subroutine with buffering !> \param parser ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE parser_read_line_low(parser,error) + SUBROUTINE parser_read_line_low(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_read_line_low', & routineP = moduleN//':'//routineN @@ -289,8 +276,8 @@ SUBROUTINE parser_read_line_low(parser,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) parser%buffer%input_lines = "" IF (parser%para_env%mepos==parser%para_env%source) THEN iline = 0 @@ -318,14 +305,14 @@ SUBROUTINE parser_read_line_low(parser,error) imark = INDEX(parser%buffer%input_lines(iline)(1:islen),"$") IF (imark/=0) THEN CALL inpp_expand_variables(parser%inpp, parser%buffer%input_lines(iline),& - parser%input_file_name, parser%buffer%input_line_numbers(iline),error) + parser%input_file_name, parser%buffer%input_line_numbers(iline)) islen=LEN_TRIM(parser%buffer%input_lines(iline)) END IF imark = INDEX(parser%buffer%input_lines(iline)(1:islen),"@") IF (imark/=0) THEN CALL inpp_process_directive(parser%inpp, parser%buffer%input_lines(iline),& parser%input_file_name, parser%buffer%input_line_numbers(iline),& - parser%input_unit, error) + parser%input_unit) islen=LEN_TRIM(parser%buffer%input_lines(iline)) ! Handle index and cycle last_buffered_line_number = 0 @@ -337,8 +324,7 @@ SUBROUTINE parser_read_line_low(parser,error) IF (parser%inpp%io_stack_level > 0) THEN ! We were reading from an included file. Go back one level. CALL inpp_end_include ( parser%inpp, parser%input_file_name,& - parser%buffer%input_line_numbers(iline), parser%input_unit,& - error) + parser%buffer%input_line_numbers(iline), parser%input_unit) ! Handle index and cycle last_buffered_line_number = parser%buffer%input_line_numbers(iline) iline = iline - 1 @@ -368,7 +354,7 @@ SUBROUTINE parser_read_line_low(parser,error) END DO END IF ! Broadcast buffer informations - CALL broadcast_input_information(parser,error) + CALL broadcast_input_information(parser) CALL timestop(handle) @@ -377,15 +363,13 @@ END SUBROUTINE parser_read_line_low ! ***************************************************************************** !> \brief Broadcast the input information. !> \param parser ... -!> \param error ... !> \date 02.03.2001 !> \author Matthias Krack (MK) !> \note 08.2008 [tlaino] - Teodoro Laino UZH : updated for buffer ! ***************************************************************************** - SUBROUTINE broadcast_input_information(parser,error) + SUBROUTINE broadcast_input_information(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'broadcast_input_information', & routineP = moduleN//':'//routineN @@ -397,8 +381,8 @@ SUBROUTINE broadcast_input_information(parser,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) para_env => parser%para_env IF (.NOT.failure .AND. para_env%num_pe>1) THEN CALL mp_bcast(parser%buffer%buffer_id,para_env%source,para_env%group) @@ -476,17 +460,15 @@ END FUNCTION is_comment !> \param parser ... !> \param nline ... !> \param at_end ... -!> \param error ... !> \date 22.11.1999 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE parser_get_next_line(parser,nline,at_end,error) + SUBROUTINE parser_get_next_line(parser,nline,at_end) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(IN) :: nline LOGICAL, INTENT(out), OPTIONAL :: at_end - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'parser_get_next_line', & routineP = moduleN//':'//routineN @@ -494,14 +476,13 @@ SUBROUTINE parser_get_next_line(parser,nline,at_end,error) LOGICAL :: my_at_end IF (nline > 0) THEN - CALL parser_read_line(parser,nline,at_end=my_at_end,error=error) + CALL parser_read_line(parser,nline,at_end=my_at_end) IF (PRESENT(at_end)) THEN at_end = my_at_end ELSE IF (my_at_end) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Unexpected EOF"//TRIM(parser_location(parser,error=error)),& - error) + "Unexpected EOF"//TRIM(parser_location(parser))) END IF END IF ELSE IF (PRESENT(at_end)) THEN @@ -513,14 +494,12 @@ END SUBROUTINE parser_get_next_line ! ***************************************************************************** !> \brief Skips the whitespaces !> \param parser ... -!> \param error ... !> \date 02.03.2001 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE parser_skip_space(parser,error) + SUBROUTINE parser_skip_space(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_skip_space', & routineP = moduleN//':'//routineN @@ -529,8 +508,8 @@ SUBROUTINE parser_skip_space(parser,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) ! Variable input string length (automatic search) ! Check for EOF @@ -564,7 +543,7 @@ SUBROUTINE parser_skip_space(parser,error) END DO IF (parser%icol == i.OR. & is_comment(parser,parser%input_line(i:i))) THEN - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) ! does not pass at_end, it is an error to continue to EOF, change this behavoiur? CYCLE ELSE @@ -573,7 +552,7 @@ SUBROUTINE parser_skip_space(parser,error) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Found non-blank tokens after the line continuation character '"//& parser%continuation_character//"' "//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) EXIT END IF ELSE @@ -591,17 +570,15 @@ END SUBROUTINE parser_skip_space !> \brief Get the next input string from the input line. !> \param parser ... !> \param string_length ... -!> \param error ... !> \date 19.02.2001 !> \author Matthias Krack (MK) !> \version 1.0 !> \notes -) this function MUST be private in this module! ! ***************************************************************************** - SUBROUTINE parser_next_token(parser,string_length,error) + SUBROUTINE parser_next_token(parser,string_length) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(IN), OPTIONAL :: string_length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_next_token', & routineP = moduleN//':'//routineN @@ -611,8 +588,8 @@ SUBROUTINE parser_next_token(parser,string_length,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(string_length)) THEN length = MIN(string_length,max_line_length) ELSE @@ -622,8 +599,8 @@ SUBROUTINE parser_next_token(parser,string_length,error) IF (length > 0) THEN ! Fixed input string length CALL cp_assert(parser%icol/=-1,cp_failure_level,cp_assertion_failed,routineP,& - "Unexpectetly reached EOF"//TRIM(parser_location(parser,error=error)),& - error,failure) + "Unexpectetly reached EOF"//TRIM(parser_location(parser)),& + failure) length=MIN(LEN_TRIM(parser%input_line)-parser%icol1+1,length) parser%icol1 = parser%icol + 1 @@ -665,7 +642,7 @@ SUBROUTINE parser_next_token(parser,string_length,error) END DO IF (parser%icol == i.OR. & is_comment(parser,parser%input_line(i:i))) THEN - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) ! does not pass at_end, it is an error to continue to EOF, change this behavoiur? CYCLE ELSE @@ -673,8 +650,8 @@ SUBROUTINE parser_next_token(parser,string_length,error) parser%icol2 = i CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Found non-blank tokens after the line continuation character '"//& - parser%continuation_character//"' "//TRIM(parser_location(parser,error=error)),& - error,failure) + parser%continuation_character//"' "//TRIM(parser_location(parser)),& + failure) EXIT END IF END IF @@ -691,7 +668,7 @@ SUBROUTINE parser_next_token(parser,string_length,error) parser%icol2 = parser%icol CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Unexpected separator token <"//parser%input_line(parser%icol:parser%icol)//& - "> found"//TRIM(parser_location(parser,error=error)),error,failure) + "> found"//TRIM(parser_location(parser)),failure) EXIT END IF ELSE IF (parser%input_line(parser%icol:parser%icol) == '"') THEN @@ -703,8 +680,8 @@ SUBROUTINE parser_next_token(parser,string_length,error) parser%icol1 = parser%icol parser%icol2 = parser%icol CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Unmatched quotation mark found"//TRIM(parser_location(parser,error=error)),& - error,failure) + "Unmatched quotation mark found"//TRIM(parser_location(parser)),& + failure) ELSE parser%icol1 = parser%icol1 - 1 parser%icol = parser%icol2 @@ -751,7 +728,6 @@ END SUBROUTINE parser_next_token !> - test_result : "STR": String !> \param parser ... !> \param string_length ... -!> \param error ... !> \retval test_result ... !> \date 23.11.1999 !> \author Matthias Krack (MK) @@ -759,11 +735,10 @@ END SUBROUTINE parser_next_token !> - Major rewrite to parse also (multiple) products of integer or !> floating point numbers (23.11.2012,MK) ! ***************************************************************************** - FUNCTION parser_test_next_token(parser,string_length,error) RESULT(test_result) + FUNCTION parser_test_next_token(parser,string_length) RESULT(test_result) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(IN), OPTIONAL :: string_length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=3) :: test_result CHARACTER(len=*), PARAMETER :: routineN = 'parser_test_next_token', & @@ -776,28 +751,28 @@ FUNCTION parser_test_next_token(parser,string_length,error) RESULT(test_result) failure = .FALSE. test_result = "" - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) ! Store current status - CALL parser_store_status(parser, error) + CALL parser_store_status(parser) ! Handle possible list of integers ilist_in_use = parser%ilist%in_use.AND.(parser%ilist%ipresent < parser%ilist%iend) IF (ilist_in_use) THEN test_result = "INT" - CALL parser_retrieve_status(parser,error) + CALL parser_retrieve_status(parser) RETURN END IF ! Otherwise continue normally - CALL parser_next_token(parser,string_length=string_length,error=error) + CALL parser_next_token(parser,string_length=string_length) ! End of line IF (parser%icol1 > parser%icol2) THEN test_result = "EOL" - CALL parser_retrieve_status(parser,error) + CALL parser_retrieve_status(parser) RETURN END IF @@ -806,14 +781,14 @@ FUNCTION parser_test_next_token(parser,string_length,error) RESULT(test_result) IF (n == 0) THEN test_result = "STR" - CALL parser_retrieve_status(parser,error) + CALL parser_retrieve_status(parser) RETURN END IF ! Check for end section string IF (string(1:n) == parser%end_section) THEN test_result = "EOS" - CALL parser_retrieve_status(parser,error) + CALL parser_retrieve_status(parser) RETURN END IF @@ -822,7 +797,7 @@ FUNCTION parser_test_next_token(parser,string_length,error) RESULT(test_result) CALL read_integer_object(string(1:n),iz,error_message) IF (LEN_TRIM(error_message) == 0) THEN test_result = "INT" - CALL parser_retrieve_status(parser,error) + CALL parser_retrieve_status(parser) RETURN END IF @@ -831,12 +806,12 @@ FUNCTION parser_test_next_token(parser,string_length,error) RESULT(test_result) CALL read_float_object(string(1:n),fz,error_message) IF (LEN_TRIM(error_message) == 0) THEN test_result = "FLT" - CALL parser_retrieve_status(parser,error) + CALL parser_retrieve_status(parser) RETURN END IF test_result = "STR" - CALL parser_retrieve_status(parser,error) + CALL parser_retrieve_status(parser) END FUNCTION parser_test_next_token @@ -854,13 +829,12 @@ END FUNCTION parser_test_next_token !> \param line ... !> \param begin_line ... !> \param search_from_begin_of_file ... -!> \param error ... !> \date 05.10.1999 !> \author MK !> \note 08.2008 [tlaino] - Teodoro Laino UZH : updated for buffer ! ***************************************************************************** SUBROUTINE parser_search_string(parser,string,ignore_case,found,line,begin_line,& - search_from_begin_of_file,error) + search_from_begin_of_file) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=*), INTENT(IN) :: string @@ -869,7 +843,6 @@ SUBROUTINE parser_search_string(parser,string,ignore_case,found,line,begin_line, CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: line LOGICAL, INTENT(IN), OPTIONAL :: begin_line, & search_from_begin_of_file - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_search_string', & routineP = moduleN//':'//routineN @@ -886,17 +859,17 @@ SUBROUTINE parser_search_string(parser,string,ignore_case,found,line,begin_line, do_reset= .FALSE. IF (PRESENT(begin_line)) begin=begin_line IF (PRESENT(search_from_begin_of_file)) do_reset = search_from_begin_of_file - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(line)) line = "" ! Search for string pattern pattern = string IF (ignore_case) CALL uppercase(pattern) - IF (do_reset) CALL parser_reset(parser,error) + IF (do_reset) CALL parser_reset(parser) DO ! This call is buffered.. so should not represent any bottleneck - CALL parser_get_next_line(parser,1,at_end=at_end,error=error) + CALL parser_get_next_line(parser,1,at_end=at_end) ! Exit loop, if the end of file is reached IF (at_end) EXIT @@ -916,7 +889,7 @@ SUBROUTINE parser_search_string(parser,string,ignore_case,found,line,begin_line, TRIM(ADJUSTL(cp_to_string(LEN(line))))//& " characters and is therefore too long to fit in the "//& "specified variable"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF EXIT END IF @@ -929,7 +902,7 @@ SUBROUTINE parser_search_string(parser,string,ignore_case,found,line,begin_line, IF (found) THEN IF (PRESENT(line)) line = parser%input_line - IF (.NOT.begin) CALL parser_next_token(parser,error=error) + IF (.NOT.begin) CALL parser_next_token(parser) END IF END SUBROUTINE parser_search_string @@ -1030,20 +1003,18 @@ END FUNCTION is_integer !> \param skip_lines ... !> \param string_length ... !> \param at_end ... -!> \param error ... !> \date 22.11.1999 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE parser_get_integer(parser,object,newline,skip_lines,& - string_length, at_end, error) + string_length, at_end) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(OUT) :: object LOGICAL, INTENT(IN), OPTIONAL :: newline INTEGER, INTENT(IN), OPTIONAL :: skip_lines, string_length LOGICAL, INTENT(out), OPTIONAL :: at_end - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_get_integer', & routineP = moduleN//':'//routineN @@ -1053,8 +1024,8 @@ SUBROUTINE parser_get_integer(parser,object,newline,skip_lines,& LOGICAL :: failure, my_at_end failure = .FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(skip_lines)) THEN nline = skip_lines ELSE @@ -1065,50 +1036,50 @@ SUBROUTINE parser_get_integer(parser,object,newline,skip_lines,& IF (newline) nline = nline + 1 END IF - CALL parser_get_next_line(parser,nline,at_end=my_at_end,error=error) + CALL parser_get_next_line(parser,nline,at_end=my_at_end) IF (PRESENT(at_end)) THEN at_end = my_at_end IF (my_at_end) RETURN ELSE IF (my_at_end) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Unexpected EOF"//TRIM(parser_location(parser,error=error)),& - error,failure) + "Unexpected EOF"//TRIM(parser_location(parser)),& + failure) END IF IF (parser%ilist%in_use) THEN - CALL ilist_update(parser%ilist,error) + CALL ilist_update(parser%ilist) ELSE - CALL parser_next_token(parser,string_length=string_length,error=error) + CALL parser_next_token(parser,string_length=string_length) IF (parser%icol1 > parser%icol2) THEN parser%icol1 = parser%icol parser%icol2 = parser%icol CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "An integer type object was expected, found end of line"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF ! Checks for possible lists of integers IF (INDEX(parser%input_line(parser%icol1:parser%icol2),"..") /= 0) THEN - CALL ilist_setup(parser%ilist, parser%input_line(parser%icol1:parser%icol2),error) + CALL ilist_setup(parser%ilist, parser%input_line(parser%icol1:parser%icol2)) END IF END IF IF (integer_object(parser%input_line(parser%icol1:parser%icol2))) THEN IF (parser%ilist%in_use) THEN object = parser%ilist%ipresent - CALL ilist_reset(parser%ilist,error) + CALL ilist_reset(parser%ilist) ELSE CALL read_integer_object(parser%input_line(parser%icol1:parser%icol2),object,error_message) IF (LEN_TRIM(error_message) > 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - TRIM(error_message)//TRIM(parser_location(parser,error=error)),& - error,failure) + TRIM(error_message)//TRIM(parser_location(parser)),& + failure) END IF END IF ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "An integer type object was expected, found <"//& parser%input_line(parser%icol1:parser%icol2)//">"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF @@ -1122,7 +1093,6 @@ END SUBROUTINE parser_get_integer !> \param skip_lines ... !> \param string_length ... !> \param at_end ... -!> \param error ... !> \date 01.04.2003 !> \par History !> - New version (08.07.2003,MK) @@ -1130,14 +1100,13 @@ END SUBROUTINE parser_get_integer !> \version 1.0 ! ***************************************************************************** SUBROUTINE parser_get_logical(parser,object,newline,skip_lines,& - string_length,at_end,error) + string_length,at_end) TYPE(cp_parser_type), POINTER :: parser LOGICAL, INTENT(OUT) :: object LOGICAL, INTENT(IN), OPTIONAL :: newline INTEGER, INTENT(IN), OPTIONAL :: skip_lines, string_length LOGICAL, INTENT(out), OPTIONAL :: at_end - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_get_logical', & routineP = moduleN//':'//routineN @@ -1147,9 +1116,9 @@ SUBROUTINE parser_get_logical(parser,object,newline,skip_lines,& LOGICAL :: failure, my_at_end failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.parser%ilist%in_use,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.parser%ilist%in_use,cp_failure_level,routineP,failure) IF (PRESENT(skip_lines)) THEN nline = skip_lines ELSE @@ -1160,17 +1129,17 @@ SUBROUTINE parser_get_logical(parser,object,newline,skip_lines,& IF (newline) nline = nline + 1 END IF - CALL parser_get_next_line(parser,nline,at_end=my_at_end,error=error) + CALL parser_get_next_line(parser,nline,at_end=my_at_end) IF (PRESENT(at_end)) THEN at_end=my_at_end IF (my_at_end) RETURN ELSE IF (my_at_end) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Unexpected EOF"//TRIM(parser_location(parser,error=error)),& - error,failure) + "Unexpected EOF"//TRIM(parser_location(parser)),& + failure) END IF - CALL parser_next_token(parser,string_length=string_length,error=error) + CALL parser_next_token(parser,string_length=string_length) input_string_length = parser%icol2 - parser%icol1 + 1 @@ -1179,7 +1148,7 @@ SUBROUTINE parser_get_logical(parser,object,newline,skip_lines,& parser%icol2 = parser%icol CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "A string representing a logical object was expected, found end of line"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) ELSE input_string = "" input_string(:input_string_length) = parser%input_line(parser%icol1:parser%icol2) @@ -1194,8 +1163,8 @@ SUBROUTINE parser_get_logical(parser,object,newline,skip_lines,& CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "A string representing a logical object was expected, found <"//& - TRIM(input_string)//">"//TRIM(parser_location(parser,error=error)),& - error,failure) + TRIM(input_string)//">"//TRIM(parser_location(parser)),& + failure) END SELECT END SUBROUTINE parser_get_logical @@ -1208,20 +1177,18 @@ END SUBROUTINE parser_get_logical !> \param skip_lines ... !> \param string_length ... !> \param at_end ... -!> \param error ... !> \date 22.11.1999 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE parser_get_real(parser,object,newline,skip_lines,string_length,& - at_end,error) + at_end) TYPE(cp_parser_type), POINTER :: parser REAL(KIND=dp), INTENT(OUT) :: object LOGICAL, INTENT(IN), OPTIONAL :: newline INTEGER, INTENT(IN), OPTIONAL :: skip_lines, string_length LOGICAL, INTENT(out), OPTIONAL :: at_end - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_get_real', & routineP = moduleN//':'//routineN @@ -1231,9 +1198,9 @@ SUBROUTINE parser_get_real(parser,object,newline,skip_lines,string_length,& LOGICAL :: failure, my_at_end failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.parser%ilist%in_use,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.parser%ilist%in_use,cp_failure_level,routineP,failure) IF (PRESENT(skip_lines)) THEN @@ -1246,32 +1213,32 @@ SUBROUTINE parser_get_real(parser,object,newline,skip_lines,string_length,& IF (newline) nline = nline + 1 END IF - CALL parser_get_next_line(parser,nline,at_end=my_at_end,error=error) + CALL parser_get_next_line(parser,nline,at_end=my_at_end) IF (PRESENT(at_end)) THEN at_end=my_at_end IF (my_at_end) RETURN ELSE IF (my_at_end) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Unexpected EOF"//TRIM(parser_location(parser,error=error)),& - error,failure) + "Unexpected EOF"//TRIM(parser_location(parser)),& + failure) END IF - CALL parser_next_token(parser,string_length=string_length,error=error) + CALL parser_next_token(parser,string_length=string_length) IF (parser%icol1 > parser%icol2) THEN parser%icol1 = parser%icol parser%icol2 = parser%icol CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "A floating point type object was expected, found end of the line"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF ! Possibility to have real numbers described in the input as division between two numbers CALL read_float_object(parser%input_line(parser%icol1:parser%icol2),object,error_message) IF (LEN_TRIM(error_message) > 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - TRIM(error_message)//TRIM(parser_location(parser,error=error)),& - error,failure) + TRIM(error_message)//TRIM(parser_location(parser)),& + failure) END IF @@ -1286,20 +1253,18 @@ END SUBROUTINE parser_get_real !> \param skip_lines ... !> \param string_length ... !> \param at_end ... -!> \param error ... !> \date 22.11.1999 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE parser_get_string(parser,object,lower_to_upper,newline,skip_lines,& - string_length,at_end,error) + string_length,at_end) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=*), INTENT(OUT) :: object LOGICAL, INTENT(IN), OPTIONAL :: lower_to_upper, newline INTEGER, INTENT(IN), OPTIONAL :: skip_lines, string_length LOGICAL, INTENT(out), OPTIONAL :: at_end - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_get_string', & routineP = moduleN//':'//routineN @@ -1309,9 +1274,9 @@ SUBROUTINE parser_get_string(parser,object,lower_to_upper,newline,skip_lines,& object = "" failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.parser%ilist%in_use,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.parser%ilist%in_use,cp_failure_level,routineP,failure) IF (PRESENT(skip_lines)) THEN nline = skip_lines ELSE @@ -1322,31 +1287,31 @@ SUBROUTINE parser_get_string(parser,object,lower_to_upper,newline,skip_lines,& IF (newline) nline = nline + 1 END IF - CALL parser_get_next_line(parser,nline,at_end=my_at_end,error=error) + CALL parser_get_next_line(parser,nline,at_end=my_at_end) IF (PRESENT(at_end)) THEN at_end=my_at_end IF (my_at_end) RETURN ELSE IF (my_at_end) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Unexpected EOF"//TRIM(parser_location(parser,error=error)),& - error,failure) + "Unexpected EOF"//TRIM(parser_location(parser)),& + failure) END IF - CALL parser_next_token(parser,string_length,error=error) + CALL parser_next_token(parser,string_length) input_string_length = parser%icol2 - parser%icol1 + 1 IF (input_string_length <= 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "A string type object was expected, found end of line"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) ELSE IF (input_string_length > LEN(object)) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "The input string <"//parser%input_line(parser%icol1:parser%icol2)//& "> has more than "//cp_to_string(LEN(object))//& " characters and is therefore too long to fit in the "//& - "specified variable"//TRIM(parser_location(parser,error=error)),& - error,failure) + "specified variable"//TRIM(parser_location(parser)),& + failure) object = parser%input_line(parser%icol1:parser%icol1+LEN(object)-1) ELSE object(:input_string_length) = parser%input_line(parser%icol1:parser%icol2) diff --git a/src/input/cp_parser_status_types.F b/src/input/cp_parser_status_types.F index f7a4033226..5589ca5606 100644 --- a/src/input/cp_parser_status_types.F +++ b/src/input/cp_parser_status_types.F @@ -37,13 +37,11 @@ MODULE cp_parser_status_types ! **************************************************************************** !> \brief creates the parser status type !> \param status ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE create_status_type(status, error) + SUBROUTINE create_status_type(status) TYPE(status_type), POINTER :: status - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_status_type', & routineP = moduleN//':'//routineN @@ -52,9 +50,9 @@ SUBROUTINE create_status_type(status, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(status),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(status),cp_failure_level,routineP,failure) ALLOCATE(status, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) status%in_use = .FALSE. status%old_input_line = "" status%old_input_line_number = HUGE(0) @@ -62,19 +60,17 @@ SUBROUTINE create_status_type(status, error) status%old_icol1 = HUGE(0) status%old_icol2 = HUGE(0) NULLIFY(status%buffer) - CALL create_buffer_type(status%buffer, error) + CALL create_buffer_type(status%buffer) END SUBROUTINE create_status_type ! **************************************************************************** !> \brief releases the parser status type !> \param status ... -!> \param error ... !> \date 08.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE release_status_type(status, error) + SUBROUTINE release_status_type(status) TYPE(status_type), POINTER :: status - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_status_type', & routineP = moduleN//':'//routineN @@ -83,10 +79,10 @@ SUBROUTINE release_status_type(status, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(status),cp_failure_level,routineP,error,failure) - CALL release_buffer_type(status%buffer, error) + CPPostcondition(ASSOCIATED(status),cp_failure_level,routineP,failure) + CALL release_buffer_type(status%buffer) DEALLOCATE(status, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_status_type END MODULE cp_parser_status_types diff --git a/src/input/cp_parser_types.F b/src/input/cp_parser_types.F index ed304a3b2d..e01b25c557 100644 --- a/src/input/cp_parser_types.F +++ b/src/input/cp_parser_types.F @@ -101,13 +101,10 @@ MODULE cp_parser_types ! ***************************************************************************** !> \brief retains the given parser !> \param parser the parser to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE parser_retain(parser,error) + SUBROUTINE parser_retain(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'parser_retain', & routineP = moduleN//':'//routineN @@ -115,22 +112,20 @@ SUBROUTINE parser_retain(parser,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(parser%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + CPPreconditionNoFail(parser%ref_count>0,cp_failure_level,routineP) parser%ref_count=parser%ref_count+1 END SUBROUTINE parser_retain ! ***************************************************************************** !> \brief releases the parser !> \param parser ... -!> \param error ... !> \date 14.02.2001 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE parser_release(parser, error) + SUBROUTINE parser_release(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_release', & routineP = moduleN//':'//routineN @@ -138,23 +133,23 @@ SUBROUTINE parser_release(parser, error) INTEGER :: stat IF (ASSOCIATED(parser)) THEN - CPPreconditionNoFail(parser%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(parser%ref_count>0,cp_failure_level,routineP) parser%ref_count=parser%ref_count-1 IF (parser%ref_count==0) THEN IF (parser%input_unit >= 0) THEN CALL close_file(unit_number=parser%input_unit) END IF - CALL cp_para_env_release(parser%para_env,error=error) - CALL release_inpp_type(parser%inpp, error) - CALL release_ilist_type(parser%ilist, error) - CALL release_buffer_type(parser%buffer, error) - CALL release_status_type(parser%status, error) + CALL cp_para_env_release(parser%para_env) + CALL release_inpp_type(parser%inpp) + CALL release_ilist_type(parser%ilist) + CALL release_buffer_type(parser%buffer) + CALL release_status_type(parser%status) IF (ASSOCIATED(parser%initial_variables)) THEN DEALLOCATE(parser%initial_variables,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF DEALLOCATE(parser,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE parser_release @@ -173,14 +168,13 @@ END SUBROUTINE parser_release !> \param parse_white_lines ... !> \param initial_variables ... !> \param apply_preprocessing ... -!> \param error ... !> \date 14.02.2001 !> \author MK !> \version 1.0 ! ***************************************************************************** SUBROUTINE parser_create(parser, file_name, unit_nr, para_env, end_section_label,& separator_chars, comment_char, continuation_char, section_char, parse_white_lines,& - initial_variables, apply_preprocessing, error) + initial_variables, apply_preprocessing) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_name INTEGER, INTENT(in), OPTIONAL :: unit_nr @@ -195,7 +189,6 @@ SUBROUTINE parser_create(parser, file_name, unit_nr, para_env, end_section_label CHARACTER(len=*), DIMENSION(:, :), & OPTIONAL :: initial_variables LOGICAL, INTENT(IN), OPTIONAL :: apply_preprocessing - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_create', & routineP = moduleN//':'//routineN @@ -204,9 +197,9 @@ SUBROUTINE parser_create(parser, file_name, unit_nr, para_env, end_section_label LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(parser),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(parser),cp_failure_level,routineP,failure) ALLOCATE(parser,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) last_parser_id=last_parser_id+1 parser%id_nr=last_parser_id parser%ref_count=1 @@ -242,11 +235,11 @@ SUBROUTINE parser_create(parser, file_name, unit_nr, para_env, end_section_label ! para_env IF (PRESENT(para_env)) THEN parser%para_env => para_env - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) ELSE NULLIFY(parser%para_env) CALL cp_para_env_create(parser%para_env, group=MPI_COMM_SELF, source=0,& - mepos=0, num_pe=1, owns_group=.FALSE.,error=error) + mepos=0, num_pe=1, owns_group=.FALSE.) END IF ! *** Get the logical output unit number for error messages *** @@ -258,7 +251,7 @@ SUBROUTINE parser_create(parser, file_name, unit_nr, para_env, end_section_label CALL cp_assert(PRESENT(file_name),cp_failure_level,cp_assertion_failed,& routineP,"at least one of filename and unit_nr must be present"//& CPSourceFileRef,& - error,failure) + failure) CALL open_file(file_name=TRIM(file_name),& unit_number=parser%input_unit) parser%input_file_name=file_name @@ -268,7 +261,7 @@ SUBROUTINE parser_create(parser, file_name, unit_nr, para_env, end_section_label IF (PRESENT(initial_variables)) THEN IF (SIZE(initial_variables,2)>0) THEN ALLOCATE(parser%initial_variables(2,SIZE(initial_variables,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) parser%initial_variables=initial_variables ENDIF ENDIF @@ -282,23 +275,21 @@ SUBROUTINE parser_create(parser, file_name, unit_nr, para_env, end_section_label NULLIFY(parser%status) NULLIFY(parser%inpp) NULLIFY(parser%ilist) - CALL create_inpp_type(parser%inpp, parser%initial_variables, error) - CALL create_ilist_type(parser%ilist, error) - CALL create_buffer_type(parser%buffer, error) - CALL create_status_type(parser%status, error) + CALL create_inpp_type(parser%inpp, parser%initial_variables) + CALL create_ilist_type(parser%ilist) + CALL create_buffer_type(parser%buffer) + CALL create_status_type(parser%status) END SUBROUTINE parser_create ! ***************************************************************************** !> \brief Resets the parser: rewinding the unit and re-initializing all !> parser structures !> \param parser ... -!> \param error ... !> \date 12.2008 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE parser_reset(parser, error) + SUBROUTINE parser_reset(parser) TYPE(cp_parser_type), POINTER :: parser - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'parser_reset', & routineP = moduleN//':'//routineN @@ -306,7 +297,7 @@ SUBROUTINE parser_reset(parser, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) ! Rewind units IF (parser%input_unit>0) REWIND(parser%input_unit) ! Restore initial settings @@ -316,15 +307,15 @@ SUBROUTINE parser_reset(parser, error) parser%icol2=0 parser%first_separator=.TRUE. ! Release substructures - CALL release_inpp_type(parser%inpp, error) - CALL release_ilist_type(parser%ilist, error) - CALL release_buffer_type(parser%buffer, error) - CALL release_status_type(parser%status, error) + CALL release_inpp_type(parser%inpp) + CALL release_ilist_type(parser%ilist) + CALL release_buffer_type(parser%buffer) + CALL release_status_type(parser%status) ! Reallocate substructures - CALL create_inpp_type(parser%inpp, parser%initial_variables, error) - CALL create_ilist_type(parser%ilist, error) - CALL create_buffer_type(parser%buffer, error) - CALL create_status_type(parser%status, error) + CALL create_inpp_type(parser%inpp, parser%initial_variables) + CALL create_ilist_type(parser%ilist) + CALL create_buffer_type(parser%buffer) + CALL create_status_type(parser%status) END SUBROUTINE parser_reset END MODULE cp_parser_types diff --git a/src/input/input_enumeration_types.F b/src/input/input_enumeration_types.F index 5fc0c08410..d7aa9bc75f 100644 --- a/src/input/input_enumeration_types.F +++ b/src/input/input_enumeration_types.F @@ -57,11 +57,9 @@ MODULE input_enumeration_types !> \param desc ... !> \param strict if integer values not in the list should be accepted, !> defaults defaults to true -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE enum_create(enum,c_vals,i_vals,desc,strict,error) +SUBROUTINE enum_create(enum,c_vals,i_vals,desc,strict) TYPE(enumeration_type), POINTER :: enum CHARACTER(len=*), DIMENSION(:), & INTENT(in) :: c_vals @@ -69,7 +67,6 @@ SUBROUTINE enum_create(enum,c_vals,i_vals,desc,strict,error) CHARACTER(len=*), DIMENSION(:), & INTENT(in), OPTIONAL :: desc LOGICAL, INTENT(in), OPTIONAL :: strict - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'enum_create', & routineP = moduleN//':'//routineN @@ -79,28 +76,28 @@ SUBROUTINE enum_create(enum,c_vals,i_vals,desc,strict,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(enum),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(c_vals)==SIZE(i_vals),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(enum),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(c_vals)==SIZE(i_vals),cp_failure_level,routineP,failure) ALLOCATE(enum,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) last_enumeration_id=last_enumeration_id+1 enum%id_nr=last_enumeration_id enum%ref_count=1 ALLOCATE(enum%c_vals(SIZE(c_vals)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,SIZE(enum%c_vals) enum%c_vals(i)=c_vals(i) CALL uppercase(enum%c_vals(i)) END DO ALLOCATE(enum%i_vals(SIZE(i_vals)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) enum%i_vals=i_vals enum%strict=.TRUE. IF (PRESENT(strict)) enum%strict=strict ALLOCATE(enum%desc(SIZE(c_vals)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) IF (PRESENT(desc)) THEN - CPPrecondition(SIZE(enum%desc)==SIZE(desc),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(enum%desc)==SIZE(desc),cp_failure_level,routineP,failure) DO i=1,SIZE(enum%desc) n = LEN_TRIM(desc(i)) ALLOCATE(enum%desc(i)%chars(n)) @@ -119,13 +116,10 @@ END SUBROUTINE enum_create ! ***************************************************************************** !> \brief retains the given enumeration !> \param enum the obect to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE enum_retain(enum,error) +SUBROUTINE enum_retain(enum) TYPE(enumeration_type), POINTER :: enum - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'enum_retain', & routineP = moduleN//':'//routineN @@ -133,21 +127,18 @@ SUBROUTINE enum_retain(enum,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(enum%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,failure) + CPPreconditionNoFail(enum%ref_count>0,cp_failure_level,routineP) enum%ref_count=enum%ref_count+1 END SUBROUTINE enum_retain ! ***************************************************************************** !> \brief releases the given enumeration !> \param enum the obect to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE enum_release(enum,error) +SUBROUTINE enum_release(enum) TYPE(enumeration_type), POINTER :: enum - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'enum_release', & routineP = moduleN//':'//routineN @@ -157,20 +148,20 @@ SUBROUTINE enum_release(enum,error) failure=.FALSE. IF (ASSOCIATED(enum)) THEN - CPPreconditionNoFail(enum%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(enum%ref_count>0,cp_failure_level,routineP) enum%ref_count=enum%ref_count-1 IF (enum%ref_count==0) THEN DEALLOCATE(enum%c_vals,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DEALLOCATE(enum%i_vals,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1, SIZE(enum%desc) DEALLOCATE(enum%desc(i)%chars) END DO DEALLOCATE(enum%desc,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DEALLOCATE(enum,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) END IF END IF NULLIFY(enum) @@ -180,15 +171,12 @@ END SUBROUTINE enum_release !> \brief maps an integer to a string !> \param enum the enumeration to use for the mapping !> \param i the value to map -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** -FUNCTION enum_i2c(enum,i,error) RESULT(res) +FUNCTION enum_i2c(enum,i) RESULT(res) TYPE(enumeration_type), POINTER :: enum INTEGER, INTENT(in) :: i - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=default_string_length) :: res CHARACTER(len=*), PARAMETER :: routineN = 'enum_i2c', & @@ -199,8 +187,8 @@ FUNCTION enum_i2c(enum,i,error) RESULT(res) failure=.FALSE. - CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,error,failure) - CPPrecondition(enum%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,failure) + CPPrecondition(enum%ref_count>0,cp_failure_level,routineP,failure) res=" " found=.FALSE. DO j=1,SIZE(enum%i_vals) @@ -220,7 +208,7 @@ FUNCTION enum_i2c(enum,i,error) RESULT(res) END IF CALL cp_assert(.NOT.enum%strict,cp_failure_level,cp_assertion_failed,& routineP,"invalid value for enumeration:"//cp_to_string(i),& - error,failure) + failure) res=ADJUSTL(cp_to_string(i)) END IF END FUNCTION enum_i2c @@ -229,15 +217,12 @@ END FUNCTION enum_i2c !> \brief maps a string to an integer !> \param enum the enumeration to use for the mapping !> \param c the value to map -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** -FUNCTION enum_c2i(enum,c,error) RESULT(res) +FUNCTION enum_c2i(enum,c) RESULT(res) TYPE(enumeration_type), POINTER :: enum CHARACTER(len=*), INTENT(in) :: c - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'enum_c2i', & @@ -249,8 +234,8 @@ FUNCTION enum_c2i(enum,c,error) RESULT(res) failure=.FALSE. - CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,error,failure) - CPPrecondition(enum%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,failure) + CPPrecondition(enum%ref_count>0,cp_failure_level,routineP,failure) upc=c CALL uppercase(upc) found=.FALSE. @@ -265,11 +250,11 @@ FUNCTION enum_c2i(enum,c,error) RESULT(res) IF (.NOT.found) THEN CALL cp_assert(.NOT.enum%strict,cp_failure_level,cp_assertion_failed,& routineP,"invalid value for enumeration:"//TRIM(c),& - error=error,failure=failure) + failure=failure) READ(c,"(i10)",iostat=iostat) res CALL cp_assert(iostat==0,cp_failure_level,cp_assertion_failed,& routineP,"invalid value for enumeration2:"//TRIM(c),& - error=error,failure=failure) + failure=failure) END IF END FUNCTION enum_c2i diff --git a/src/input/input_keyword_types.F b/src/input/input_keyword_types.F index 7eb85c9b1f..bc4b3ac9b3 100644 --- a/src/input/input_keyword_types.F +++ b/src/input/input_keyword_types.F @@ -136,8 +136,6 @@ MODULE input_keyword_types !> \param enum_desc ... !> \param unit_str ... !> \param citations ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& @@ -147,7 +145,7 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& lone_keyword_val, lone_keyword_l_val, lone_keyword_r_val, lone_keyword_c_val,& lone_keyword_i_val, lone_keyword_l_vals, lone_keyword_r_vals, & lone_keyword_c_vals, lone_keyword_i_vals, enum_c_vals, enum_i_vals, & - enum,enum_strict,enum_desc,unit_str,citations,error) + enum,enum_strict,enum_desc,unit_str,citations) TYPE(keyword_type), POINTER :: keyword CHARACTER(len=*), INTENT(in) :: name, description CHARACTER(len=*), INTENT(in), OPTIONAL :: usage @@ -193,7 +191,6 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& CHARACTER(len=*), INTENT(in), OPTIONAL :: unit_str INTEGER, DIMENSION(:), INTENT(in), & OPTIONAL :: citations - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'keyword_create', & routineP = moduleN//':'//routineN @@ -203,9 +200,9 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(keyword),cp_failure_level,routineP,failure) ALLOCATE(keyword,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) keyword%ref_count=1 last_keyword_id=last_keyword_id+1 keyword%id_nr=last_keyword_id @@ -213,14 +210,14 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& IF (PRESENT(variants)) THEN ALLOCATE(keyword%names(SIZE(variants)+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) keyword%names(1)=name DO i=1,SIZE(variants) keyword%names(i+1)=variants(i) END DO ELSE ALLOCATE(keyword%names(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (.not.failure) keyword%names(1)=name END IF DO i=1,SIZE(keyword%names) @@ -228,7 +225,7 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& END DO IF (PRESENT(usage)) THEN - CPPrecondition(LEN_TRIM(usage)<=LEN(keyword%usage),cp_failure_level,routineP,error,failure) + CPPrecondition(LEN_TRIM(usage)<=LEN(keyword%usage),cp_failure_level,routineP,failure) keyword%usage=usage ELSE keyword%usage="" @@ -242,7 +239,7 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& IF (PRESENT(citations)) THEN ALLOCATE(keyword%citations(SIZE(citations,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) keyword%citations=citations ELSE NULLIFY(keyword%citations) @@ -254,15 +251,15 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& NULLIFY(keyword%enum) IF (PRESENT(enum)) THEN keyword%enum => enum - IF (ASSOCIATED(enum)) CALL enum_retain(enum,error=error) + IF (ASSOCIATED(enum)) CALL enum_retain(enum) END IF IF (PRESENT(enum_i_vals)) THEN - CPPrecondition(PRESENT(enum_c_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(keyword%enum),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(enum_c_vals),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(keyword%enum),cp_failure_level,routineP,failure) CALL enum_create(keyword%enum,c_vals=enum_c_vals,i_vals=enum_i_vals,& - desc=enum_desc,strict=enum_strict,error=error) + desc=enum_desc,strict=enum_strict) ELSE - CPPrecondition(.NOT.PRESENT(enum_c_vals),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(enum_c_vals),cp_failure_level,routineP,failure) END IF NULLIFY(keyword%default_value, keyword%lone_keyword_value) @@ -273,30 +270,30 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& PRESENT(default_c_val).OR.PRESENT(default_c_vals)),cp_failure_level,& cp_assertion_failed,routineP,& "you should pass either default_val or a default value, not both",& - error,failure) + failure) keyword%default_value => default_val IF (ASSOCIATED(default_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN - CPAssert(keyword%enum%id_nr==default_val%enum%id_nr,cp_failure_level,routineP,error,failure) + CPAssert(keyword%enum%id_nr==default_val%enum%id_nr,cp_failure_level,routineP,failure) ELSE keyword%enum => default_val%enum - CALL enum_retain(keyword%enum,error=error) + CALL enum_retain(keyword%enum) END IF ELSE - CPAssert(.NOT.ASSOCIATED(keyword%enum),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.ASSOCIATED(keyword%enum),cp_failure_level,routineP,failure) END IF - CALL val_retain(default_val,error=error) + CALL val_retain(default_val) END IF IF (.not.ASSOCIATED(keyword%default_value)) THEN CALL val_create(keyword%default_value,l_val=default_l_val,& l_vals=default_l_vals,i_val=default_i_val,i_vals=default_i_vals,& r_val=default_r_val,r_vals=default_r_vals,c_val=default_c_val,& - c_vals=default_c_vals,lc_val=default_lc_val,enum=keyword%enum,error=error) + c_vals=default_c_vals,lc_val=default_lc_val,enum=keyword%enum) END IF keyword%type_of_var=keyword%default_value%type_of_var IF (keyword%default_value%type_of_var==no_t) THEN - CALL val_release(keyword%default_value,error=error) + CALL val_release(keyword%default_value) END IF IF (keyword%type_of_var==no_t) THEN @@ -305,19 +302,19 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "keyword "//TRIM(keyword%names(1))//& - " assumed undefined type by default",error,failure) + " assumed undefined type by default",failure) END IF ELSE IF (PRESENT(type_of_var)) THEN CALL cp_assert(keyword%type_of_var==type_of_var,cp_failure_level,& cp_assertion_failed,routineP, & "keyword "//TRIM(keyword%names(1))//& " has a type different from the type of the default_value",& - error,failure) + failure) keyword%type_of_var=type_of_var END IF IF (keyword%type_of_var==no_t) THEN - CALL val_create(keyword%default_value,error=error) + CALL val_create(keyword%default_value) END IF IF (PRESENT(lone_keyword_val)) THEN @@ -327,42 +324,42 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& PRESENT(lone_keyword_c_val).OR.PRESENT(lone_keyword_c_vals)),& cp_failure_level, cp_assertion_failed,routineP,& "you should pass either lone_keyword_val or a lone_keyword value, not both",& - error,failure) + failure) keyword%lone_keyword_value => lone_keyword_val - CALL val_retain(lone_keyword_val,error=error) + CALL val_retain(lone_keyword_val) IF (ASSOCIATED(lone_keyword_val%enum)) THEN IF (ASSOCIATED(keyword%enum)) THEN CALL cp_assert(keyword%enum%id_nr==lone_keyword_val%enum%id_nr, & cp_failure_level,cp_assertion_failed,routineP, & "keyword%enum%id_nr==lone_keyword_val%enum%id_nr", & - error,failure) + failure) ELSE IF (ASSOCIATED(keyword%lone_keyword_value)) THEN CALL cp_assert(.FALSE., cp_failure_level, cp_precondition_failed, & routineP, ".NOT. ASSOCIATED(keyword%lone_keyword_value)", & - error, failure) + failure) END IF keyword%enum => lone_keyword_val%enum - CALL enum_retain(keyword%enum,error=error) + CALL enum_retain(keyword%enum) END IF ELSE - CPAssert(.NOT.ASSOCIATED(keyword%enum),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.ASSOCIATED(keyword%enum),cp_failure_level,routineP,failure) END IF END IF IF (.NOT.ASSOCIATED(keyword%lone_keyword_value)) THEN CALL val_create(keyword%lone_keyword_value,l_val=lone_keyword_l_val,& l_vals=lone_keyword_l_vals,i_val=lone_keyword_i_val,i_vals=lone_keyword_i_vals,& r_val=lone_keyword_r_val,r_vals=lone_keyword_r_vals,c_val=lone_keyword_c_val,& - c_vals=lone_keyword_c_vals,enum=keyword%enum,error=error) + c_vals=lone_keyword_c_vals,enum=keyword%enum) END IF IF (ASSOCIATED(keyword%lone_keyword_value)) THEN IF (keyword%lone_keyword_value%type_of_var==no_t) THEN - CALL val_release(keyword%lone_keyword_value,error=error) + CALL val_release(keyword%lone_keyword_value) ELSE CALL cp_assert(keyword%lone_keyword_value%type_of_var==keyword%type_of_var,& cp_failure_level,cp_assertion_failed,routineP,& "lone_keyword_value type incompatible with "//& - "keyword type",error,failure) + "keyword type",failure) ! lc_val cannot have lone_keyword_value! IF (keyword%type_of_var==enum_t) THEN IF (keyword%enum%strict) THEN @@ -372,7 +369,7 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& END DO CALL cp_assert(check,cp_failure_level,& cp_assertion_failed,routineP,"default value not in enumeration : "//keyword%names(1), & - error,failure) + failure) ENDIF ENDIF END IF @@ -393,7 +390,7 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& END DO CALL cp_assert(check,cp_failure_level,& cp_assertion_failed,routineP,"default value not in enumeration : "//& - keyword%names(1), error,failure) + keyword%names(1),failure) ENDIF keyword%n_var=SIZE(keyword%default_value%i_val) CASE(real_t) @@ -405,29 +402,26 @@ SUBROUTINE keyword_create(keyword, name, description, usage, type_of_var,& CASE(no_t) keyword%n_var=0 CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF IF (PRESENT(n_var)) keyword%n_var=n_var CALL cp_assert(keyword%type_of_var/=lchar_t.or.keyword%n_var==1,cp_failure_level,& cp_assertion_failed,routineP,"arrays of lchar_t not supported : "& - //keyword%names(1), error,failure) + //keyword%names(1),failure) IF (PRESENT(unit_str)) THEN - CALL cp_unit_create(keyword%unit,unit_str,error=error) + CALL cp_unit_create(keyword%unit,unit_str) END IF END SUBROUTINE keyword_create ! ***************************************************************************** !> \brief retains the given keyword (see doc/ReferenceCounting.html) !> \param keyword the keyword to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE keyword_retain(keyword, error) + SUBROUTINE keyword_retain(keyword) TYPE(keyword_type), POINTER :: keyword - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'keyword_retain', & routineP = moduleN//':'//routineN @@ -435,21 +429,18 @@ SUBROUTINE keyword_retain(keyword, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(keyword%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,failure) + CPPreconditionNoFail(keyword%ref_count>0,cp_failure_level,routineP) keyword%ref_count=keyword%ref_count+1 END SUBROUTINE keyword_retain ! ***************************************************************************** !> \brief releases the given keyword (see doc/ReferenceCounting.html) !> \param keyword the keyword to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE keyword_release(keyword, error) + SUBROUTINE keyword_release(keyword) TYPE(keyword_type), POINTER :: keyword - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'keyword_release', & routineP = moduleN//':'//routineN @@ -459,22 +450,22 @@ SUBROUTINE keyword_release(keyword, error) failure=.FALSE. IF (ASSOCIATED(keyword)) THEN - CPPreconditionNoFail(keyword%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(keyword%ref_count>0,cp_failure_level,routineP) keyword%ref_count=keyword%ref_count-1 IF (keyword%ref_count==0) THEN DEALLOCATE(keyword%names,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(keyword%description) - CALL val_release(keyword%default_value,error=error) - CALL val_release(keyword%lone_keyword_value,error=error) - CALL enum_release(keyword%enum,error=error) - CALL cp_unit_release(keyword%unit,error=error) + CALL val_release(keyword%default_value) + CALL val_release(keyword%lone_keyword_value) + CALL enum_release(keyword%enum) + CALL cp_unit_release(keyword%unit) IF (ASSOCIATED(keyword%citations)) THEN DEALLOCATE(keyword%citations,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF DEALLOCATE(keyword,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(keyword) @@ -493,12 +484,10 @@ END SUBROUTINE keyword_release !> \param repeats ... !> \param enum ... !> \param citations ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE keyword_get(keyword,names,usage,description,type_of_var,n_var,& - default_value, lone_keyword_value,repeats,enum,citations,error) + default_value, lone_keyword_value,repeats,enum,citations) TYPE(keyword_type), POINTER :: keyword CHARACTER(len=default_string_length), & DIMENSION(:), OPTIONAL, POINTER :: names @@ -510,7 +499,6 @@ SUBROUTINE keyword_get(keyword,names,usage,description,type_of_var,n_var,& TYPE(enumeration_type), OPTIONAL, & POINTER :: enum INTEGER, DIMENSION(:), OPTIONAL, POINTER :: citations - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'keyword_get', & routineP = moduleN//':'//routineN @@ -519,8 +507,8 @@ SUBROUTINE keyword_get(keyword,names,usage,description,type_of_var,n_var,& failure=.FALSE. - CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) - CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,failure) + CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(names)) names => keyword%names IF (PRESENT(usage)) usage=keyword%usage IF (PRESENT(description)) description=a2s(keyword%description) @@ -540,14 +528,11 @@ END SUBROUTINE keyword_get !> \param level the description level (0 no description, 1 name !> 2: +usage, 3: +variants+description+default_value+repeats !> 4: +type_of_var) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE keyword_describe(keyword, unit_nr, level,error) + SUBROUTINE keyword_describe(keyword, unit_nr, level) TYPE(keyword_type), POINTER :: keyword INTEGER, INTENT(in) :: unit_nr, level - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'keyword_describe', & routineP = moduleN//':'//routineN @@ -558,8 +543,8 @@ SUBROUTINE keyword_describe(keyword, unit_nr, level,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) - CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,failure) + CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT. failure.AND.level>0.AND.(unit_nr>0)) THEN WRITE(unit_nr,"(a,a,a)") " ---",& TRIM(keyword%names(1)),"---" @@ -597,8 +582,7 @@ SUBROUTINE keyword_describe(keyword, unit_nr, level,error) WRITE(unit_nr,"(i6,' reals are expected')") keyword%n_var END IF IF (ASSOCIATED(keyword%unit)) THEN - c_string=cp_unit_desc(keyword%unit,accept_undefined=.TRUE.,& - error=error) + c_string=cp_unit_desc(keyword%unit,accept_undefined=.TRUE.) WRITE(unit_nr,"('the default unit of measure is ',a)")& TRIM(c_string) END IF @@ -623,7 +607,7 @@ SUBROUTINE keyword_describe(keyword, unit_nr, level,error) CASE (no_t) WRITE(unit_nr,"(' Non-standard type.')") CASE default - CPAssert(.FALSE.,cp_warning_level,routineP,error,failure) + CPAssert(.FALSE.,cp_warning_level,routineP,failure) END SELECT END IF IF (keyword%type_of_var==enum_t) THEN @@ -658,11 +642,11 @@ SUBROUTINE keyword_describe(keyword, unit_nr, level,error) END IF IF (ASSOCIATED(keyword%default_value).AND.keyword%type_of_var/=no_t) THEN WRITE(unit_nr,"('default_value : ')",advance="NO") - CALL val_write(keyword%default_value,unit_nr=unit_nr,error=error) + CALL val_write(keyword%default_value,unit_nr=unit_nr) END IF IF (ASSOCIATED(keyword%lone_keyword_value).AND.keyword%type_of_var/=no_t) THEN WRITE(unit_nr,"('lone_keyword : ')",advance="NO") - CALL val_write(keyword%lone_keyword_value,unit_nr=unit_nr,error=error) + CALL val_write(keyword%lone_keyword_value,unit_nr=unit_nr) END IF IF (keyword%repeats) THEN WRITE(unit_nr,"(' and it can be repeated more than once')",advance="NO") @@ -683,14 +667,11 @@ END SUBROUTINE keyword_describe !> \brief writes out a description of the keyword !> \param keyword the keyword to describe !> \param unit_nr the unit to write to -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele [10.2004], based on keyword_describe ! ***************************************************************************** - SUBROUTINE keyword_describe_html(keyword, unit_nr, error) + SUBROUTINE keyword_describe_html(keyword, unit_nr) TYPE(keyword_type), POINTER :: keyword INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'keyword_describe_html', & routineP = moduleN//':'//routineN @@ -701,8 +682,8 @@ SUBROUTINE keyword_describe_html(keyword, unit_nr, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) - CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,failure) + CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,failure) WRITE(unit_nr,'(a)') ''// & ''//TRIM(keyword%names(1))//''// & '' @@ -756,29 +737,29 @@ SUBROUTINE keyword_describe_html(keyword, unit_nr, error) CASE (no_t) WRITE(unit_nr,'(a)',ADVANCE="NO") 'expects a non-standard input type' CASE DEFAULT - CPAssert(.FALSE.,cp_warning_level,routineP,error,failure) + CPAssert(.FALSE.,cp_warning_level,routineP,failure) END SELECT IF (keyword%repeats) THEN WRITE(unit_nr,"(', and may repeat')",ADVANCE="NO") END IF IF (ASSOCIATED(keyword%lone_keyword_value).AND.keyword%type_of_var/=no_t) THEN WRITE(unit_nr,'(a)',advance="NO") 'This keyword behaves as a switch' - CALL val_write(keyword%lone_keyword_value,unit_nr=unit_nr,error=error) + CALL val_write(keyword%lone_keyword_value,unit_nr=unit_nr) END IF IF (ASSOCIATED(keyword%default_value).AND.keyword%type_of_var/=no_t) THEN IF (ASSOCIATED(keyword%unit)) THEN - my_unit=cp_unit_desc(keyword%unit,accept_undefined=.TRUE.,error=error) + my_unit=cp_unit_desc(keyword%unit,accept_undefined=.TRUE.) WRITE(unit_nr,'(a)',advance="NO") '. Default unit: ' // '[' // TRIM(my_unit)// '], default value: ' ELSE WRITE(unit_nr,'(a)',advance="NO") '. Default value: ' ENDIF - CALL val_write(keyword%default_value,unit=keyword%unit,unit_nr=unit_nr,error=error) + CALL val_write(keyword%default_value,unit=keyword%unit,unit_nr=unit_nr) IF (ASSOCIATED(keyword%unit)) THEN WRITE(unit_nr,'(a)',advance="NO") TRIM(my_unit) END IF ELSE IF (ASSOCIATED(keyword%unit)) THEN - my_unit=cp_unit_desc(keyword%unit,accept_undefined=.TRUE.,error=error) + my_unit=cp_unit_desc(keyword%unit,accept_undefined=.TRUE.) WRITE(unit_nr,'(a)',advance="NO") '. Default unit: ' // '[' // TRIM(my_unit)// '].' END IF ENDIF @@ -840,15 +821,12 @@ END SUBROUTINE keyword_describe_html !> \param keyword The keyword to describe !> \param level ... !> \param unit_number Number of the output unit -!> \param error Variable to control error logging, stopping ... -!> see module cp_error_handling !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE write_keyword_xml(keyword,level,unit_number,error) + SUBROUTINE write_keyword_xml(keyword,level,unit_number) TYPE(keyword_type), POINTER :: keyword INTEGER, INTENT(IN) :: level, unit_number - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_keyword_xml', & routineP = moduleN//':'//routineN @@ -860,8 +838,8 @@ SUBROUTINE write_keyword_xml(keyword,level,unit_number,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) - CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,failure) + CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,failure) ! Indentation for current level, next level, etc. @@ -941,7 +919,7 @@ SUBROUTINE write_keyword_xml(keyword,level,unit_number,error) WRITE (UNIT=unit_number,FMT="(A)")& REPEAT(" ",l1)//"" CASE DEFAULT - CPAssert(.FALSE.,cp_warning_level,routineP,error,failure) + CPAssert(.FALSE.,cp_warning_level,routineP,failure) END SELECT short_string = "" @@ -963,12 +941,10 @@ SUBROUTINE write_keyword_xml(keyword,level,unit_number,error) IF (ASSOCIATED(keyword%unit)) THEN CALL val_write_internal(val=keyword%default_value,& string=string,& - unit=keyword%unit,& - error=error) + unit=keyword%unit) ELSE CALL val_write_internal(val=keyword%default_value,& - string=string,& - error=error) + string=string) END IF CALL compress(string) WRITE (UNIT=unit_number,FMT="(A)")& @@ -977,7 +953,7 @@ SUBROUTINE write_keyword_xml(keyword,level,unit_number,error) END IF IF (ASSOCIATED(keyword%unit)) THEN - string = cp_unit_desc(keyword%unit,accept_undefined=.TRUE.,error=error) + string = cp_unit_desc(keyword%unit,accept_undefined=.TRUE.) WRITE (UNIT=unit_number,FMT="(A)")& REPEAT(" ",l1)//""//& TRIM(ADJUSTL(string))//"" @@ -986,8 +962,7 @@ SUBROUTINE write_keyword_xml(keyword,level,unit_number,error) IF (ASSOCIATED(keyword%lone_keyword_value).AND.& (keyword%type_of_var /= no_t)) THEN CALL val_write_internal(val=keyword%lone_keyword_value,& - string=string,& - error=error) + string=string) WRITE (UNIT=unit_number,FMT="(A)")& REPEAT(" ",l1)//""//& TRIM(ADJUSTL(string))//"" @@ -1028,9 +1003,8 @@ END SUBROUTINE write_keyword_xml !> \param location_string ... !> \param matching_rank ... !> \param matching_string ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE keyword_typo_match(keyword,unknown_string,location_string,matching_rank,matching_string,error) + SUBROUTINE keyword_typo_match(keyword,unknown_string,location_string,matching_rank,matching_string) TYPE(keyword_type), POINTER :: keyword CHARACTER(LEN=*) :: unknown_string, & @@ -1038,7 +1012,6 @@ SUBROUTINE keyword_typo_match(keyword,unknown_string,location_string,matching_ra INTEGER, DIMENSION(:), INTENT(INOUT) :: matching_rank CHARACTER(LEN=*), DIMENSION(:), & INTENT(INOUT) :: matching_string - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'keyword_typo_match', & routineP = moduleN//':'//routineN @@ -1048,8 +1021,8 @@ SUBROUTINE keyword_typo_match(keyword,unknown_string,location_string,matching_ra LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) - CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,failure) + CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,failure) DO i=1,SIZE(keyword%names) diff --git a/src/input/input_parsing.F b/src/input/input_parsing.F index 3e799ed714..36a6adeba3 100644 --- a/src/input/input_parsing.F +++ b/src/input/input_parsing.F @@ -79,16 +79,13 @@ MODULE input_parsing !> \param parser ... !> \param default_units ... !> \param root_section if the root section should be parsed (defaults to true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_section,error) + RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_section) TYPE(section_vals_type), POINTER :: section_vals TYPE(cp_parser_type), POINTER :: parser TYPE(cp_unit_set_type), POINTER :: default_units LOGICAL, INTENT(in), OPTIONAL :: root_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_parse', & routineP = moduleN//':'//routineN @@ -115,18 +112,18 @@ RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_s root_sect=.TRUE. IF (PRESENT(root_section)) root_sect=root_section - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,error,failure) - logger => cp_error_get_logger(error) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(parser),cp_failure_level,routineP,failure) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(parser%ref_count>0,cp_failure_level,routineP,failure) IF (root_sect.and.parser%icol1>parser%icol2) & CALL cp_assert(.FALSE.,cp_failure_level,& cp_assertion_failed,routineP,& "Error 1: this routine must be called just after having parsed the start of the section "& - //TRIM(parser_location(parser,error=error)),error,failure) + //TRIM(parser_location(parser)),failure) section => section_vals%section IF (root_sect) THEN token=parser%input_line(parser%icol1:parser%icol2) @@ -134,41 +131,41 @@ RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_s IF (token/=parser%section_character//section%name)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Error 2: this routine must be called just after having parsed the start of the section "& - //TRIM(parser_location(parser,error=error)), error,failure) + //TRIM(parser_location(parser)),failure) END IF CALL cp_assert(section%repeats.OR.SIZE(section_vals%values,2)==0,& cp_failure_level,cp_assertion_failed,routineP,& "Section "//TRIM(section%name)//& - " should not repeat "//TRIM(parser_location(parser,error=error)),& - error,failure) + " should not repeat "//TRIM(parser_location(parser)),& + failure) skip_description=.TRUE. skip_help=.TRUE. - CALL section_vals_add_values(section_vals,error=error) + CALL section_vals_add_values(section_vals) irs=SIZE(section_vals%values,2) IF (ASSOCIATED(section%keywords(-1)%keyword)) THEN ! reads section params keyword => section%keywords(-1)%keyword NULLIFY(el) - IF (keyword%type_of_var==lchar_t) CALL parser_skip_space(parser,error=error) + IF (keyword%type_of_var==lchar_t) CALL parser_skip_space(parser) CALL val_create_parsing(el,type_of_var=keyword%type_of_var,& n_var=keyword%n_var,default_value=keyword%lone_keyword_value,& enum=keyword%enum,unit=keyword%unit,& default_units=default_units,& - parser=parser,error=error) + parser=parser) NULLIFY(new_val) - CALL cp_sll_val_create(new_val,el,error=error) + CALL cp_sll_val_create(new_val,el) section_vals%values(-1,irs)%list => new_val NULLIFY(el) END IF DO WHILE (.NOT.failure) CALL parser_get_object(parser,token,newline=.TRUE.,& - lower_to_upper=.TRUE.,at_end=at_end,error=error) + lower_to_upper=.TRUE.,at_end=at_end) IF (at_end) THEN CALL cp_assert(.not.root_sect,cp_failure_level,& cp_assertion_failed,routineP,& "unexpected end of file while parsing section "//& - TRIM(section%name)//" "//TRIM(parser_location(parser,error=error)),& - error,failure) + TRIM(section%name)//" "//TRIM(parser_location(parser)),& + failure) EXIT END IF IF (failure) EXIT @@ -176,16 +173,16 @@ RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_s IF (token=="&END") THEN ! end of section compatible_end=.TRUE. - IF (parser_test_next_token(parser,error=error)/="EOL") THEN + IF (parser_test_next_token(parser)/="EOL") THEN CALL parser_get_object(parser,token,newline=.FALSE.,& - lower_to_upper=.TRUE.,error=error) + lower_to_upper=.TRUE.) IF (token/="SECTION".and.token/=section%name) THEN compatible_end=.FALSE. END IF END IF - IF (parser_test_next_token(parser,error=error)/="EOL") THEN + IF (parser_test_next_token(parser)/="EOL") THEN CALL parser_get_object(parser,token,newline=.FALSE.,& - lower_to_upper=.TRUE.,error=error) + lower_to_upper=.TRUE.) IF (token/=section%name) THEN PRINT *,TRIM(token),"/=",TRIM(section%name) compatible_end=.FALSE. @@ -194,27 +191,27 @@ RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_s IF (.NOT.compatible_end) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"non-compatible end of section "//TRIM(section%name)//" "//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) skip_description=.TRUE. END IF ! RETURN EXIT END IF - is=section_get_subsection_index(section,token(2:),error=error) + is=section_get_subsection_index(section,token(2:)) IF (is>0) THEN ! PRINT *,"parsing subsection "//TRIM(section%subsections(is)%section%name)& ! //" of section "// TRIM(section%name) CALL section_vals_parse(section_vals%subs_vals(is,irs)%section_vals,& - default_units=default_units,parser=parser,error=error) + default_units=default_units,parser=parser) ELSE ! this should be an error (failure) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown subsection "//TRIM(token(2:))//" of section "& - //TRIM(section%name),error=error) + //TRIM(section%name)) nSub=1 DO WHILE (nSub>0) CALL parser_get_object(parser,token,newline=.TRUE.,& - lower_to_upper=.TRUE.,error=error) + lower_to_upper=.TRUE.) IF (failure) EXIT IF (token(1:1)==parser%section_character) THEN IF (token=="&END") THEN @@ -230,52 +227,51 @@ RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_s IF (output_unit>0) WRITE(output_unit,"(/,' ****** DESCRIPTION ******',/)") skip_description=.TRUE. desc_level=3 - IF (parser_test_next_token(parser,error=error)=="INT") THEN - CALL parser_get_object(parser,desc_level,error=error) + IF (parser_test_next_token(parser)=="INT") THEN + CALL parser_get_object(parser,desc_level) END IF whole_section=.TRUE. - DO WHILE (parser_test_next_token(parser,error=error)=="STR") + DO WHILE (parser_test_next_token(parser)=="STR") whole_section=.FALSE. CALL parser_get_object(parser,token,newline=.FALSE.,& - lower_to_upper=.TRUE.,error=error) - keyword => section_get_keyword(section,token,error=error) + lower_to_upper=.TRUE.) + keyword => section_get_keyword(section,token) IF (.NOT.ASSOCIATED(keyword)) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"unknown keyword to describe "//TRIM(token)//& - " in section "//TRIM(section%name),error,failure) + " in section "//TRIM(section%name),failure) ELSE - CALL keyword_describe(keyword,output_unit,desc_level,error=error) + CALL keyword_describe(keyword,output_unit,desc_level) END IF END DO IF (whole_section) THEN - CALL section_describe(section, output_unit, desc_level,hide_root=.NOT.root_sect,& - error=error) + CALL section_describe(section, output_unit, desc_level,hide_root=.NOT.root_sect) END IF IF (output_unit>0) WRITE(output_unit,"(/,' ****** =========== ******',/)") ELSE ! token is a "normal" keyword - ik=section_get_keyword_index(section,token,error=error) + ik=section_get_keyword_index(section,token) IF (ik<1) THEN ! don't accept pseudo keyword names parser%icol=parser%icol1-1 ! re-read also the actual token ik=0 IF (.NOT.ASSOCIATED(section%keywords(0)%keyword)) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"found an unknown keyword "//TRIM(token)//& - " in section "//TRIM(section%name),error=error) + " in section "//TRIM(section%name)) END IF END IF keyword => section%keywords(ik)%keyword IF (ASSOCIATED(keyword)) THEN NULLIFY(el) IF (ik/=0.and.keyword%type_of_var==lchar_t) & - CALL parser_skip_space(parser,error=error) + CALL parser_skip_space(parser) CALL val_create_parsing(el,type_of_var=keyword%type_of_var,& n_var=keyword%n_var,default_value=keyword%lone_keyword_value,& enum=keyword%enum,unit=keyword%unit,& - default_units=default_units,parser=parser,error=error) + default_units=default_units,parser=parser) IF (.NOT.failure.AND.ASSOCIATED(el)) THEN NULLIFY(new_val) - CALL cp_sll_val_create(new_val,el,error=error) + CALL cp_sll_val_create(new_val,el) last_val => section_vals%values(ik,irs)%list IF (.NOT.ASSOCIATED(last_val)) THEN section_vals%values(ik,irs)%list => new_val @@ -284,18 +280,17 @@ RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_s PRINT *, "Keyword "//TRIM(token)//& " in section "//TRIM(section%name)//" should not repeat." PRINT *, "new_val=" - CALL val_write(el,6,keyword%unit,error=error) + CALL val_write(el,6,keyword%unit) PRINT *,"old_val=" DO - CALL val_write(last_val%first_el,6,keyword%unit,& - error=error) + CALL val_write(last_val%first_el,6,keyword%unit) IF (.not.ASSOCIATED(last_val%rest)) EXIT last_val => last_val%rest END DO END IF CALL cp_assert(keyword%repeats,cp_failure_level,cp_assertion_failed,& routineP,"Keyword "//TRIM(token)//& - " in section "//TRIM(section%name)//" should not repeat.",error,failure) + " in section "//TRIM(section%name)//" should not repeat.",failure) IF (ASSOCIATED(last_val,previous_list)) THEN last_val=>previous_last ELSE @@ -326,7 +321,7 @@ RECURSIVE SUBROUTINE section_vals_parse(section_vals,parser,default_units,root_s output_unit,0,0,0) END IF IF (.NOT.skip_description) THEN - CALL section_describe(section,output_unit,3,error=error) + CALL section_describe(section,output_unit,3) END IF END IF CALL timestop(handle) @@ -342,14 +337,12 @@ END SUBROUTINE section_vals_parse !> \param unit ... !> \param default_units ... !> \param default_value a default value if nothing is found (can be null) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> - no_t does not create a value ! ***************************************************************************** SUBROUTINE val_create_parsing(val,type_of_var, n_var,enum,& - parser,unit,default_units,default_value,error) + parser,unit,default_units,default_value) TYPE(val_type), POINTER :: val INTEGER, INTENT(in) :: type_of_var, n_var TYPE(enumeration_type), POINTER :: enum @@ -357,7 +350,6 @@ SUBROUTINE val_create_parsing(val,type_of_var, n_var,enum,& TYPE(cp_unit_type), POINTER :: unit TYPE(cp_unit_set_type), POINTER :: default_units TYPE(val_type), OPTIONAL, POINTER :: default_value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_create_parsing', & routineP = moduleN//':'//routineN @@ -379,274 +371,273 @@ SUBROUTINE val_create_parsing(val,type_of_var, n_var,enum,& CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(val),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(val),cp_failure_level,routineP,failure) SELECT CASE(type_of_var) CASE(no_t) CASE (logical_t) NULLIFY(l_val_p) - IF (parser_test_next_token(parser,error=error)=="EOL") THEN + IF (parser_test_next_token(parser)=="EOL") THEN IF (.NOT.ASSOCIATED(default_value)) THEN IF (n_var<1) THEN ALLOCATE(l_val_p(0),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) - CALL val_create(val,l_vals_ptr=l_val_p,error=error) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) + CALL val_create(val,l_vals_ptr=l_val_p) ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"no value was given and there is no default value"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF ELSE - CPPrecondition(ASSOCIATED(default_value%l_val),cp_failure_level,routineP,error,failure) - CALL val_create(val,l_vals=default_value%l_val,error=error) + CPPrecondition(ASSOCIATED(default_value%l_val),cp_failure_level,routineP,failure) + CALL val_create(val,l_vals=default_value%l_val) END IF ELSE IF (n_var<1) THEN NULLIFY(l_last,l_first) - CALL parser_get_object(parser,l_val,error=error) - CALL cp_create(l_first,l_val,error=error) + CALL parser_get_object(parser,l_val) + CALL cp_create(l_first,l_val) l_last => l_first - DO WHILE(parser_test_next_token(parser,error=error)/="EOL"& + DO WHILE(parser_test_next_token(parser)/="EOL"& .AND..NOT.failure) - CALL parser_get_object(parser,l_val,error=error) - CALL cp_create(l_new,l_val,error=error) + CALL parser_get_object(parser,l_val) + CALL cp_create(l_new,l_val) l_last%rest => l_new l_last => l_new END DO - l_val_p => cp_to_array(l_first,error=error) - CALL cp_dealloc(l_first,error=error) + l_val_p => cp_to_array(l_first) + CALL cp_dealloc(l_first) ELSE ALLOCATE(l_val_p(n_var),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,n_var - CALL parser_get_object(parser,l_val_p(i),error=error) + CALL parser_get_object(parser,l_val_p(i)) END DO END IF IF (ASSOCIATED(l_val_p)) THEN - CALL val_create(val,l_vals_ptr=l_val_p,error=error) + CALL val_create(val,l_vals_ptr=l_val_p) END IF END IF CASE (integer_t) NULLIFY(i_val_p) - IF (parser_test_next_token(parser,error=error)=="EOL") THEN + IF (parser_test_next_token(parser)=="EOL") THEN IF (.NOT.ASSOCIATED(default_value)) THEN IF (n_var<1) THEN ALLOCATE(i_val_p(0),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) - CALL val_create(val,i_vals_ptr=i_val_p,error=error) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) + CALL val_create(val,i_vals_ptr=i_val_p) ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"no value was given and there is no default value"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF ELSE check = ASSOCIATED(default_value%i_val) - CPPrecondition(check,cp_failure_level,routineP,error,failure) - CALL val_create(val,i_vals=default_value%i_val,error=error) + CPPrecondition(check,cp_failure_level,routineP,failure) + CALL val_create(val,i_vals=default_value%i_val) END IF ELSE IF (n_var<1) THEN NULLIFY(i_last,i_first) - CALL parser_get_object(parser,i_val,error=error) - CALL cp_create(i_first,i_val,error=error) + CALL parser_get_object(parser,i_val) + CALL cp_create(i_first,i_val) i_last => i_first - DO WHILE(parser_test_next_token(parser,error=error)/="EOL".AND..NOT.failure) - CALL parser_get_object(parser,i_val,error=error) - CALL cp_create(i_new,i_val,error=error) + DO WHILE(parser_test_next_token(parser)/="EOL".AND..NOT.failure) + CALL parser_get_object(parser,i_val) + CALL cp_create(i_new,i_val) i_last%rest => i_new i_last => i_new END DO - i_val_p => cp_to_array(i_first,error=error) - CALL cp_dealloc(i_first,error=error) + i_val_p => cp_to_array(i_first) + CALL cp_dealloc(i_first) ELSE ALLOCATE(i_val_p(n_var),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,n_var - CALL parser_get_object(parser,i_val_p(i),error=error) + CALL parser_get_object(parser,i_val_p(i)) END DO END IF IF (ASSOCIATED(i_val_p)) THEN - CALL val_create(val,i_vals_ptr=i_val_p,error=error) + CALL val_create(val,i_vals_ptr=i_val_p) END IF END IF CASE (real_t) NULLIFY(r_val_p) - IF (parser_test_next_token(parser,error=error)=="EOL") THEN + IF (parser_test_next_token(parser)=="EOL") THEN IF (.NOT.ASSOCIATED(default_value)) THEN IF (n_var<1) THEN ALLOCATE(r_val_p(0),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) - CALL val_create(val,r_vals_ptr=r_val_p,error=error) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) + CALL val_create(val,r_vals_ptr=r_val_p) ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"no value was given and there is no default value"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF ELSE - CPPrecondition(ASSOCIATED(default_value%r_val),cp_failure_level,routineP,error,failure) - CALL val_create(val,r_vals=default_value%r_val,error=error) + CPPrecondition(ASSOCIATED(default_value%r_val),cp_failure_level,routineP,failure) + CALL val_create(val,r_vals=default_value%r_val) END IF ELSE IF (n_var<1) THEN NULLIFY(r_last,r_first) c_val = "" - CALL get_r_val(r_val, parser, unit, default_units, c_val, error) - CALL cp_create(r_first,r_val,error=error) + CALL get_r_val(r_val, parser, unit, default_units, c_val) + CALL cp_create(r_first,r_val) r_last => r_first - DO WHILE(parser_test_next_token(parser,error=error)/="EOL".AND..NOT.failure) - CALL get_r_val(r_val, parser, unit, default_units, c_val, error) - CALL cp_create(r_new,r_val,error=error) + DO WHILE(parser_test_next_token(parser)/="EOL".AND..NOT.failure) + CALL get_r_val(r_val, parser, unit, default_units, c_val) + CALL cp_create(r_new,r_val) r_last%rest => r_new r_last => r_new END DO NULLIFY(r_last) - r_val_p => cp_to_array(r_first,error=error) - CALL cp_dealloc(r_first,error=error) + r_val_p => cp_to_array(r_first) + CALL cp_dealloc(r_first) ELSE ALLOCATE(r_val_p(n_var),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) c_val = "" DO i=1,n_var - CALL get_r_val(r_val_p(i), parser, unit, default_units, c_val, error) + CALL get_r_val(r_val_p(i), parser, unit, default_units, c_val) END DO END IF IF (ASSOCIATED(r_val_p)) THEN - CALL val_create(val,r_vals_ptr=r_val_p,error=error) + CALL val_create(val,r_vals_ptr=r_val_p) END IF END IF CASE (char_t) NULLIFY(c_val_p) - IF (parser_test_next_token(parser,error=error)=="EOL") THEN + IF (parser_test_next_token(parser)=="EOL") THEN IF (n_var<1) THEN ALLOCATE(c_val_p(1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) c_val_p(1)=' ' - CALL val_create(val,c_vals_ptr=c_val_p,error=error) + CALL val_create(val,c_vals_ptr=c_val_p) ELSE IF (.NOT.ASSOCIATED(default_value)) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"no value was given and there is no default value"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) ELSE - CPPrecondition(ASSOCIATED(default_value%c_val),cp_failure_level,routineP,error,failure) - CALL val_create(val,c_vals=default_value%c_val,error=error) + CPPrecondition(ASSOCIATED(default_value%c_val),cp_failure_level,routineP,failure) + CALL val_create(val,c_vals=default_value%c_val) END IF END IF ELSE IF (n_var<1) THEN - CPAssert(n_var==-1,cp_failure_level,routineP,error,failure) + CPAssert(n_var==-1,cp_failure_level,routineP,failure) NULLIFY(c_last,c_first) - CALL parser_get_object(parser,c_val,error=error) - CALL cp_create(c_first,c_val,error=error) + CALL parser_get_object(parser,c_val) + CALL cp_create(c_first,c_val) c_last => c_first - DO WHILE(parser_test_next_token(parser,error=error)/="EOL"& + DO WHILE(parser_test_next_token(parser)/="EOL"& .AND..NOT.failure) - CALL parser_get_object(parser,c_val,error=error) - CALL cp_create(c_new,c_val,error=error) + CALL parser_get_object(parser,c_val) + CALL cp_create(c_new,c_val) c_last%rest => c_new c_last => c_new END DO - c_val_p => cp_to_array(c_first,error=error) - CALL cp_dealloc(c_first,error=error) + c_val_p => cp_to_array(c_first) + CALL cp_dealloc(c_first) ELSE ALLOCATE(c_val_p(n_var),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,n_var - CALL parser_get_object(parser,c_val_p(i),error=error) + CALL parser_get_object(parser,c_val_p(i)) END DO END IF IF (ASSOCIATED(c_val_p)) THEN - CALL val_create(val,c_vals_ptr=c_val_p,error=error) + CALL val_create(val,c_vals_ptr=c_val_p) END IF END IF CASE (lchar_t) CALL cp_assert(.NOT.ASSOCIATED(default_value),cp_failure_level,cp_assertion_failed,& routineP,"input variables of type lchar_t cannot have a lone keyword attribute,"//& " no value is interpreted as empty string"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) CALL cp_assert(n_var==1,cp_failure_level,cp_assertion_failed,& routineP,"input variables of type lchar_t cannot be repeated,"//& " one always represent a whole line, till the end"//& - TRIM(parser_location(parser,error=error)),error,failure) - IF (parser_test_next_token(parser,error=error)=="EOL") THEN + TRIM(parser_location(parser)),failure) + IF (parser_test_next_token(parser)=="EOL") THEN ALLOCATE(c_val_p(1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) c_val_p(1)=' ' ELSE NULLIFY(c_last,c_first) - CALL parser_get_object(parser,c_val,string_length=LEN(c_val),& - error=error) - CALL cp_create(c_first,c_val,error=error) + CALL parser_get_object(parser,c_val,string_length=LEN(c_val)) + CALL cp_create(c_first,c_val) c_last => c_first - DO WHILE(parser_test_next_token(parser,error=error)/="EOL"& + DO WHILE(parser_test_next_token(parser)/="EOL"& .AND..NOT.failure) - CALL parser_get_object(parser,c_val,string_length=LEN(c_val),error=error) - CALL cp_create(c_new,c_val,error=error) + CALL parser_get_object(parser,c_val,string_length=LEN(c_val)) + CALL cp_create(c_new,c_val) c_last%rest => c_new c_last => c_new END DO - c_val_p => cp_to_array(c_first,error=error) - CALL cp_dealloc(c_first,error=error) + c_val_p => cp_to_array(c_first) + CALL cp_dealloc(c_first) END IF - CPPostcondition(ASSOCIATED(c_val_p),cp_failure_level,routineP,error,failure) - CALL val_create(val,lc_vals_ptr=c_val_p,error=error) + CPPostcondition(ASSOCIATED(c_val_p),cp_failure_level,routineP,failure) + CALL val_create(val,lc_vals_ptr=c_val_p) CASE (enum_t) - CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(enum),cp_failure_level,routineP,failure) NULLIFY(i_val_p) - IF (parser_test_next_token(parser,error=error)=="EOL") THEN + IF (parser_test_next_token(parser)=="EOL") THEN IF (.NOT.ASSOCIATED(default_value)) THEN IF (n_var<1) THEN ALLOCATE(i_val_p(0),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) - CALL val_create(val,i_vals_ptr=i_val_p,error=error) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) + CALL val_create(val,i_vals_ptr=i_val_p) ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"no value was given and there is no default value"//& - TRIM(parser_location(parser,error=error)),error,failure) + TRIM(parser_location(parser)),failure) END IF ELSE - CPPrecondition(ASSOCIATED(default_value%i_val),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(default_value%i_val),cp_failure_level,routineP,failure) CALL val_create(val,i_vals=default_value%i_val,& - enum=default_value%enum,error=error) + enum=default_value%enum) END IF ELSE IF (n_var<1) THEN NULLIFY(i_last,i_first) - CALL parser_get_object(parser,c_val,error=error) - CALL cp_create(i_first,enum_c2i(enum,c_val,error=error),error=error) + CALL parser_get_object(parser,c_val) + CALL cp_create(i_first,enum_c2i(enum,c_val)) i_last => i_first - DO WHILE(parser_test_next_token(parser,error=error)/="EOL".AND..NOT.failure) - CALL parser_get_object(parser,c_val,error=error) - CALL cp_create(i_new,enum_c2i(enum,c_val,error=error),error=error) + DO WHILE(parser_test_next_token(parser)/="EOL".AND..NOT.failure) + CALL parser_get_object(parser,c_val) + CALL cp_create(i_new,enum_c2i(enum,c_val)) i_last%rest => i_new i_last => i_new END DO - i_val_p => cp_to_array(i_first,error=error) - CALL cp_dealloc(i_first,error=error) + i_val_p => cp_to_array(i_first) + CALL cp_dealloc(i_first) ELSE ALLOCATE(i_val_p(n_var),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,n_var - CALL parser_get_object(parser,c_val,error=error) - i_val_p(i)=enum_c2i(enum,c_val,error=error) + CALL parser_get_object(parser,c_val) + i_val_p(i)=enum_c2i(enum,c_val) END DO END IF IF (ASSOCIATED(i_val_p)) THEN - CALL val_create(val,i_vals_ptr=i_val_p,enum=enum,error=error) + CALL val_create(val,i_vals_ptr=i_val_p,enum=enum) END IF END IF CASE default CALL cp_unimplemented_error(routineP, "type "//cp_to_string(type_of_var)//& "unknown to the parser"//& CPSourceFileRef,& - error,cp_failure_level) + cp_failure_level) END SELECT - IF (parser_test_next_token(parser,error=error).NE."EOL") THEN - location=TRIM(parser_location(parser,error=error)) - CALL parser_get_object(parser,info,error=error) + IF (parser_test_next_token(parser).NE."EOL") THEN + location=TRIM(parser_location(parser)) + CALL parser_get_object(parser,info) CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "found unexpected extra argument "//TRIM(info)//" at "//& - location,error,failure) + location,failure) ENDIF CALL timestop(handle) @@ -660,18 +651,15 @@ END SUBROUTINE val_create_parsing !> \param unit ... !> \param default_units ... !> \param c_val ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino - 11.2007 [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE get_r_val(r_val, parser, unit, default_units, c_val, error) + SUBROUTINE get_r_val(r_val, parser, unit, default_units, c_val) REAL(kind=dp), INTENT(OUT) :: r_val TYPE(cp_parser_type), POINTER :: parser TYPE(cp_unit_type), POINTER :: unit TYPE(cp_unit_set_type), POINTER :: default_units CHARACTER(len=default_string_length), & INTENT(INOUT) :: c_val - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_r_val', & routineP = moduleN//':'//routineN @@ -682,29 +670,29 @@ SUBROUTINE get_r_val(r_val, parser, unit, default_units, c_val, error) failure = .FALSE. NULLIFY(my_unit) IF (ASSOCIATED(unit)) THEN - IF ('STR'==parser_test_next_token(parser,error=error)) THEN - CALL parser_get_object(parser,c_val,error=error) + IF ('STR'==parser_test_next_token(parser)) THEN + CALL parser_get_object(parser,c_val) check = c_val(1:1)=="[" - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) check = c_val(LEN_TRIM(c_val):LEN_TRIM(c_val))=="]" - CPPrecondition(check,cp_failure_level,routineP,error,failure) - CALL cp_unit_create(my_unit,c_val(2:LEN_TRIM(c_val)-1),error=error) + CPPrecondition(check,cp_failure_level,routineP,failure) + CALL cp_unit_create(my_unit,c_val(2:LEN_TRIM(c_val)-1)) ELSE IF (c_val /= "") THEN - CALL cp_unit_create(my_unit,c_val(2:LEN_TRIM(c_val)-1),error=error) + CALL cp_unit_create(my_unit,c_val(2:LEN_TRIM(c_val)-1)) ELSE my_unit => unit END IF END IF - CALL cp_assert(cp_unit_compatible(unit,my_unit,error=error),& + CALL cp_assert(cp_unit_compatible(unit,my_unit),& cp_failure_level,cp_assertion_failed,routineP,"Incompatible units. Defined as ("//& - TRIM(cp_unit_desc(unit,error=error))//") specified in input as ("//& - TRIM(cp_unit_desc(my_unit,error=error))//"). These units are incompatible!",error,failure) + TRIM(cp_unit_desc(unit))//") specified in input as ("//& + TRIM(cp_unit_desc(my_unit))//"). These units are incompatible!",failure) END IF - CALL parser_get_object(parser,r_val,error=error) + CALL parser_get_object(parser,r_val) IF (ASSOCIATED(unit)) THEN - r_val=cp_unit_to_cp2k1(r_val,my_unit,default_units,error=error) - IF (.NOT.(ASSOCIATED(my_unit,unit))) CALL cp_unit_release(my_unit,error=error) + r_val=cp_unit_to_cp2k1(r_val,my_unit,default_units) + IF (.NOT.(ASSOCIATED(my_unit,unit))) CALL cp_unit_release(my_unit) END IF END SUBROUTINE get_r_val diff --git a/src/input/input_section_types.F b/src/input/input_section_types.F index 0786fd6322..82e75aca0d 100644 --- a/src/input/input_section_types.F +++ b/src/input/input_section_types.F @@ -145,19 +145,16 @@ MODULE input_section_types !> structure, defaults to 0 !> \param repeats if this section can repeat (defaults to false) !> \param citations ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE section_create(section,name,description,n_keywords,& - n_subsections, repeats, citations, error) + n_subsections, repeats, citations) TYPE(section_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: name, description INTEGER, INTENT(in), OPTIONAL :: n_keywords, n_subsections LOGICAL, INTENT(in), OPTIONAL :: repeats INTEGER, DIMENSION(:), INTENT(IN), & OPTIONAL :: citations - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_create', & routineP = moduleN//':'//routineN @@ -168,14 +165,14 @@ SUBROUTINE section_create(section,name,description,n_keywords,& failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) my_n_keywords=10 IF (PRESENT(n_keywords)) my_n_keywords=n_keywords my_n_subsections=0 IF (PRESENT(n_subsections)) my_n_subsections=n_subsections ALLOCATE(section,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_section_id=last_section_id+1 section%id_nr=last_section_id section%ref_count=1 @@ -198,18 +195,18 @@ SUBROUTINE section_create(section,name,description,n_keywords,& NULLIFY(section%citations) IF (PRESENT(citations)) THEN ALLOCATE(section%citations(SIZE(citations)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) section%citations=citations ENDIF ALLOCATE(section%keywords(-1:my_n_keywords),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=-1,my_n_keywords NULLIFY(section%keywords(i)%keyword) END DO ALLOCATE(section%subsections(my_n_subsections),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,my_n_subsections NULLIFY(section%subsections(i)%section) END DO @@ -218,13 +215,10 @@ END SUBROUTINE section_create ! ***************************************************************************** !> \brief retains the given keyword list (see doc/ReferenceCounting.html) !> \param section the list to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE section_retain(section,error) + SUBROUTINE section_retain(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_retain', & routineP = moduleN//':'//routineN @@ -233,21 +227,18 @@ SUBROUTINE section_retain(section,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(section%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPreconditionNoFail(section%ref_count>0,cp_failure_level,routineP) section%ref_count=section%ref_count+1 END SUBROUTINE section_retain ! ***************************************************************************** !> \brief releases the given keyword list (see doc/ReferenceCounting.html) !> \param section the list to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - RECURSIVE SUBROUTINE section_release(section,error) + RECURSIVE SUBROUTINE section_release(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_release', & routineP = moduleN//':'//routineN @@ -258,31 +249,31 @@ RECURSIVE SUBROUTINE section_release(section,error) failure=.FALSE. IF (ASSOCIATED(section)) THEN - CPPreconditionNoFail(section%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(section%ref_count>0,cp_failure_level,routineP) section%ref_count=section%ref_count-1 IF (section%ref_count==0) THEN IF (ASSOCIATED(section%citations)) THEN DEALLOCATE(section%citations,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(section%keywords)) THEN DO i=-1,UBOUND(section%keywords,1) - CALL keyword_release(section%keywords(i)%keyword,error=error) + CALL keyword_release(section%keywords(i)%keyword) END DO DEALLOCATE(section%keywords,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF section%n_keywords=0 IF (ASSOCIATED(section%subsections)) THEN DO i=1,SIZE(section%subsections) - CALL section_release(section%subsections(i)%section,error=error) + CALL section_release(section%subsections(i)%section) END DO DEALLOCATE(section%subsections,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(section%description) DEALLOCATE(section,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF NULLIFY(section) END IF @@ -291,13 +282,11 @@ END SUBROUTINE section_release ! ***************************************************************************** !> \brief collects additional information on the section for IO + documentation !> \param section ... -!> \param error ... !> \retval message ... !> \author fawzi ! ***************************************************************************** - FUNCTION get_section_info(section, error) RESULT(message) + FUNCTION get_section_info(section) RESULT(message) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_path_length) :: message CHARACTER(len=*), PARAMETER :: routineN = 'get_section_info', & @@ -329,16 +318,13 @@ END FUNCTION get_section_info !> \param hide_root if the name of the first section should be hidden !> (defaults to false). !> \param recurse ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - RECURSIVE SUBROUTINE section_describe(section, unit_nr, level, hide_root, recurse,error) + RECURSIVE SUBROUTINE section_describe(section, unit_nr, level, hide_root, recurse) TYPE(section_type), POINTER :: section INTEGER, INTENT(in) :: unit_nr, level LOGICAL, INTENT(in), OPTIONAL :: hide_root INTEGER, INTENT(in), OPTIONAL :: recurse - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_describe', & routineP = moduleN//':'//routineN @@ -354,26 +340,26 @@ RECURSIVE SUBROUTINE section_describe(section, unit_nr, level, hide_root, recurs my_recurse=0 IF (PRESENT(recurse)) my_recurse=recurse IF (ASSOCIATED(section)) THEN - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) IF (.not.my_hide_root)& WRITE(unit_nr,"('*** section &',a,' ***')")TRIM(section%name) IF (level>1) THEN - message = get_section_info(section, error) + message = get_section_info(section) CALL print_message(TRIM(a2s(section%description))//TRIM(message),unit_nr,0,0,0) END IF IF (level>0) THEN IF (ASSOCIATED(section%keywords(-1)%keyword)) THEN CALL keyword_describe(section%keywords(-1)%keyword,unit_nr,& - level,error=error) + level) END IF IF (ASSOCIATED(section%keywords(0)%keyword)) THEN CALL keyword_describe(section%keywords(0)%keyword,unit_nr,& - level,error=error) + level) END IF DO ikeyword=1,section%n_keywords CALL keyword_describe(section%keywords(ikeyword)%keyword,unit_nr,& - level,error=error) + level) END DO END IF IF (section%n_subsections>0 .and.my_recurse>=0) THEN @@ -382,7 +368,7 @@ RECURSIVE SUBROUTINE section_describe(section, unit_nr, level, hide_root, recurs DO isub=1,section%n_subsections IF (my_recurse>0) THEN CALL section_describe(section%subsections(isub)%section,unit_nr,& - level,recurse=my_recurse-1,error=error) + level,recurse=my_recurse-1) ELSE WRITE(unit_nr,"(' ',a)") section%subsections(isub)%section%name END IF @@ -402,13 +388,11 @@ END SUBROUTINE section_describe !> \param prefix ... !> \param depth ... !> \param unit_number ... -!> \param error ... ! ***************************************************************************** - RECURSIVE SUBROUTINE section_describe_html(section, prefix, depth, unit_number, error) + RECURSIVE SUBROUTINE section_describe_html(section, prefix, depth, unit_number) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: prefix INTEGER, INTENT(in) :: depth, unit_number - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_describe_html', & routineP = moduleN//':'//routineN @@ -423,7 +407,7 @@ RECURSIVE SUBROUTINE section_describe_html(section, prefix, depth, unit_number, failure=.FALSE. IF (ASSOCIATED(section)) THEN local_prefix=TRIM(prefix//"~"//TRIM(section%name)) - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) CALL open_file(unit_number=unit_nr,file_name=TRIM(local_prefix)//".html",& file_status="UNKNOWN",file_action="WRITE") WRITE(unit_nr,FMT='(A)') "" @@ -441,7 +425,7 @@ RECURSIVE SUBROUTINE section_describe_html(section, prefix, depth, unit_number, name(depth+1)=TRIM(section%name) WRITE(unit_nr,FMT='(A)') ''//TRIM(name(depth+1))//'.' - message = get_section_info(section, error) + message = get_section_info(section) WRITE(unit_nr,FMT='(A)') '

'//TRIM(a2s(section%description))//TRIM(message) IF (ASSOCIATED(section%citations)) THEN @@ -487,7 +471,7 @@ RECURSIVE SUBROUTINE section_describe_html(section, prefix, depth, unit_number, WRITE(unit_nr,FMT='(A)') "" DO ikeyword=-1,section%n_keywords IF (ASSOCIATED(section%keywords(ikeyword)%keyword)) THEN - CALL keyword_describe_html(section%keywords(ikeyword)%keyword,unit_nr,error=error) + CALL keyword_describe_html(section%keywords(ikeyword)%keyword,unit_nr) END IF END DO WRITE(unit_nr,FMT='(A)') "
" @@ -500,8 +484,7 @@ RECURSIVE SUBROUTINE section_describe_html(section, prefix, depth, unit_number, WRITE(unit_nr,FMT='(A)') "" CALL close_file(unit_nr) DO isub=1,section%n_subsections - CALL section_describe_html(section%subsections(isub)%section,TRIM(local_prefix),depth+1,unit_number,& - error=error) + CALL section_describe_html(section%subsections(isub)%section,TRIM(local_prefix),depth+1,unit_number) END DO END IF END SUBROUTINE section_describe_html @@ -511,13 +494,11 @@ END SUBROUTINE section_describe_html !> \param section ... !> \param prefix ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** - RECURSIVE SUBROUTINE section_describe_index_html(section,prefix, unit_nr, error) + RECURSIVE SUBROUTINE section_describe_index_html(section,prefix, unit_nr) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: prefix INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_describe_index_html', & routineP = moduleN//':'//routineN @@ -528,15 +509,14 @@ RECURSIVE SUBROUTINE section_describe_index_html(section,prefix, unit_nr, error) failure=.FALSE. IF (ASSOCIATED(section)) THEN - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) local_prefix=TRIM(prefix//"~"//TRIM(section%name)) WRITE(unit_nr,FMT='(A)') & '
  • '//TRIM(section%name)//"" IF (section%n_subsections>0) THEN WRITE(unit_nr,FMT='(A)') "
      " DO isub=1,section%n_subsections - CALL section_describe_index_html(section%subsections(isub)%section,TRIM(local_prefix),unit_nr,& - error=error) + CALL section_describe_index_html(section%subsections(isub)%section,TRIM(local_prefix),unit_nr) END DO WRITE(unit_nr,FMT='(A)') "
    " ENDIF @@ -547,17 +527,14 @@ END SUBROUTINE section_describe_index_html !> \brief returns the index of requested subsection (-1 if not found) !> \param section the root section !> \param subsection_name the name of the subsection you want to get -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi !> \note !> private utility function ! ***************************************************************************** - FUNCTION section_get_subsection_index(section,subsection_name,error) RESULT(res) + FUNCTION section_get_subsection_index(section,subsection_name) RESULT(res) TYPE(section_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: subsection_name - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'section_get_subsection_index', & @@ -569,13 +546,13 @@ FUNCTION section_get_subsection_index(section,subsection_name,error) RESULT(res) failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) res=-1 upc_name=subsection_name CALL uppercase(upc_name) DO isub=1,section%n_subsections - CPInvariant(ASSOCIATED(section%subsections(isub)%section),cp_failure_level,routineP,error,failure) + CPInvariant(ASSOCIATED(section%subsections(isub)%section),cp_failure_level,routineP,failure) IF (section%subsections(isub)%section%name==upc_name) THEN res=isub EXIT @@ -587,15 +564,12 @@ END FUNCTION section_get_subsection_index !> \brief returns the requested subsection !> \param section the root section !> \param subsection_name the name of the subsection you want to get -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION section_get_subsection(section,subsection_name,error) RESULT(res) + FUNCTION section_get_subsection(section,subsection_name) RESULT(res) TYPE(section_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: subsection_name - TYPE(cp_error_type), INTENT(inout) :: error TYPE(section_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'section_get_subsection', & @@ -603,7 +577,7 @@ FUNCTION section_get_subsection(section,subsection_name,error) RESULT(res) INTEGER :: isub - isub=section_get_subsection_index(section,subsection_name,error=error) + isub=section_get_subsection_index(section,subsection_name) IF (isub>0) THEN res => section%subsections(isub)%section ELSE @@ -615,17 +589,14 @@ END FUNCTION section_get_subsection !> \brief returns the index of the requested keyword (or -2 if not found) !> \param section the section the keyword is in !> \param keyword_name the keyword you are interested in -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi !> \note !> private utility function ! ***************************************************************************** - FUNCTION section_get_keyword_index(section,keyword_name,error) RESULT(res) + FUNCTION section_get_keyword_index(section,keyword_name) RESULT(res) TYPE(section_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'section_get_keyword_index', & @@ -637,9 +608,9 @@ FUNCTION section_get_keyword_index(section,keyword_name,error) RESULT(res) failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(section%keywords),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(section%keywords),cp_failure_level,routineP,failure) res=-2 upc_name=keyword_name CALL uppercase(upc_name) @@ -652,7 +623,7 @@ FUNCTION section_get_keyword_index(section,keyword_name,error) RESULT(res) END DO IF (res==-2) THEN k_search_loop: DO ik=1,section%n_keywords - CPInvariant(ASSOCIATED(section%keywords(ik)%keyword),cp_failure_level,routineP,error,failure) + CPInvariant(ASSOCIATED(section%keywords(ik)%keyword),cp_failure_level,routineP,failure) DO in=1,SIZE(section%keywords(ik)%keyword%names) IF (section%keywords(ik)%keyword%names(in)==upc_name) THEN res = ik @@ -667,15 +638,12 @@ END FUNCTION section_get_keyword_index !> \brief returns the requested keyword !> \param section the section the keyword is in !> \param keyword_name the keyword you are interested in -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - RECURSIVE FUNCTION section_get_keyword(section,keyword_name,error) RESULT(res) + RECURSIVE FUNCTION section_get_keyword(section,keyword_name) RESULT(res) TYPE(section_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error TYPE(keyword_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'section_get_keyword', & @@ -687,14 +655,14 @@ RECURSIVE FUNCTION section_get_keyword(section,keyword_name,error) RESULT(res) failure = .FALSE. IF (INDEX(keyword_name,"%")/=0) THEN my_index = INDEX(keyword_name,"%") + 1 - CPPrecondition(ASSOCIATED(section%subsections),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section%subsections),cp_failure_level,routineP,failure) DO ik = LBOUND(section%subsections,1), UBOUND(section%subsections,1) IF (section%subsections(ik)%section%name==keyword_name(1:my_index-2)) EXIT END DO - CPPrecondition(ik<=UBOUND(section%subsections,1),cp_failure_level,routineP,error,failure) - res => section_get_keyword(section%subsections(ik)%section,keyword_name(my_index:),error) + CPPrecondition(ik<=UBOUND(section%subsections,1),cp_failure_level,routineP,failure) + res => section_get_keyword(section%subsections(ik)%section,keyword_name(my_index:)) ELSE - ik=section_get_keyword_index(section,keyword_name,error) + ik=section_get_keyword_index(section,keyword_name) IF (ik==-2) THEN NULLIFY(res) ELSE @@ -713,22 +681,17 @@ END FUNCTION section_get_keyword !> \param name ... !> \param description ... !> \param citations ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> -!> For the other attributes see the section type !> \author fawzi !> \note !> give direct access to keywords and subsections? ! ***************************************************************************** SUBROUTINE section_get(section,frozen, repeats,id_nr,ref_count, & - name,description,citations,error) + name,description,citations) TYPE(section_type), POINTER :: section LOGICAL, INTENT(out), OPTIONAL :: frozen, repeats INTEGER, INTENT(out), OPTIONAL :: id_nr, ref_count CHARACTER(len=*), INTENT(out), OPTIONAL :: name, description INTEGER, DIMENSION(:), OPTIONAL, POINTER :: citations - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_get', & routineP = moduleN//':'//routineN @@ -737,8 +700,8 @@ SUBROUTINE section_get(section,frozen, repeats,id_nr,ref_count, & failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(frozen)) frozen=section%frozen IF (PRESENT(repeats)) repeats=section%repeats IF (PRESENT(id_nr)) id_nr=section%id_nr @@ -752,14 +715,11 @@ END SUBROUTINE section_get !> \brief adds a keyword to the given section !> \param section the section to which the keyword should be added !> \param keyword the keyword to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE section_add_keyword(section,keyword,error) + SUBROUTINE section_add_keyword(section,keyword) TYPE(section_type), POINTER :: section TYPE(keyword_type), POINTER :: keyword - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_add_keyword', & routineP = moduleN//':'//routineN @@ -771,17 +731,17 @@ SUBROUTINE section_add_keyword(section,keyword,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.section%frozen,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) - CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,error,failure) - CALL keyword_retain(keyword,error=error) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.section%frozen,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(keyword),cp_failure_level,routineP,failure) + CPPrecondition(keyword%ref_count>0,cp_failure_level,routineP,failure) + CALL keyword_retain(keyword) IF (keyword%names(1)=="_SECTION_PARAMETERS_") THEN - CALL keyword_release(section%keywords(-1)%keyword,error=error) + CALL keyword_release(section%keywords(-1)%keyword) section%keywords(-1)%keyword => keyword ELSE IF (keyword%names(1)=="_DEFAULT_KEYWORD_") THEN - CALL keyword_release(section%keywords(0)%keyword,error=error) + CALL keyword_release(section%keywords(0)%keyword) section%keywords(0)%keyword => keyword ELSE DO k=1,SIZE(keyword%names) @@ -791,7 +751,7 @@ SUBROUTINE section_add_keyword(section,keyword,error) CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "trying to add a keyword with a name ("//& TRIM(keyword%names(k))//") that was already used in section "& - //TRIM(section%name),error,failure) + //TRIM(section%name),failure) ENDIF END DO END DO @@ -799,7 +759,7 @@ SUBROUTINE section_add_keyword(section,keyword,error) IF (UBOUND(section%keywords,1)==section%n_keywords) THEN ALLOCATE(new_keywords(-1:section%n_keywords+10),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=-1,section%n_keywords new_keywords(i)%keyword => section%keywords(i)%keyword END DO @@ -807,7 +767,7 @@ SUBROUTINE section_add_keyword(section,keyword,error) NULLIFY(new_keywords(i)%keyword) END DO DEALLOCATE(section%keywords,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) section%keywords => new_keywords END IF section%n_keywords=section%n_keywords+1 @@ -819,13 +779,10 @@ END SUBROUTINE section_add_keyword !> \brief adds a subsection to the given section !> \param section to section to which you want to add a subsection !> \param subsection the subsection to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE section_add_subsection(section,subsection,error) + SUBROUTINE section_add_subsection(section,subsection) TYPE(section_type), POINTER :: section, subsection - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_add_subsection', & routineP = moduleN//':'//routineN @@ -837,13 +794,13 @@ SUBROUTINE section_add_subsection(section,subsection,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(subsection),cp_failure_level,routineP,error,failure) - CPPrecondition(subsection%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(subsection),cp_failure_level,routineP,failure) + CPPrecondition(subsection%ref_count>0,cp_failure_level,routineP,failure) IF (SIZE(section%subsections) section%subsections(i)%section END DO @@ -851,7 +808,7 @@ SUBROUTINE section_add_subsection(section,subsection,error) NULLIFY(new_subsections(i)%section) END DO DEALLOCATE(section%subsections,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) section%subsections => new_subsections END IF DO i=1,section%n_subsections @@ -859,9 +816,9 @@ SUBROUTINE section_add_subsection(section,subsection,error) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "trying to add a subsection with a name ("//& TRIM(subsection%name)//") that was already used in section "& - //TRIM(section%name),error,failure) + //TRIM(section%name),failure) END DO - CALL section_retain(subsection,error=error) + CALL section_retain(subsection) section%n_subsections=section%n_subsections+1 section%subsections(section%n_subsections)%section => subsection END SUBROUTINE section_add_subsection @@ -870,14 +827,11 @@ END SUBROUTINE section_add_subsection !> \brief creates a object where to store the values of a section !> \param section_vals the parsed section that will be created !> \param section the structure of the section that you want to parse -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - RECURSIVE SUBROUTINE section_vals_create(section_vals,section,error) + RECURSIVE SUBROUTINE section_vals_create(section_vals,section) TYPE(section_vals_type), POINTER :: section_vals TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_create', & routineP = moduleN//':'//routineN @@ -887,23 +841,23 @@ RECURSIVE SUBROUTINE section_vals_create(section_vals,section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section_vals),cp_failure_level,routineP,failure) ALLOCATE(section_vals,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_section_vals_id=last_section_vals_id+1 section_vals%id_nr=last_section_vals_id section_vals%ref_count=1 - CALL section_retain(section,error=error) + CALL section_retain(section) section_vals%section => section section%frozen=.TRUE. ALLOCATE(section_vals%values(-1:section%n_keywords,0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(section_vals%subs_vals(section%n_subsections,1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,section%n_subsections NULLIFY(section_vals%subs_vals(i,1)%section_vals) CALL section_vals_create(section_vals%subs_vals(i,1)%section_vals,& - section=section%subsections(i)%section,error=error) + section=section%subsections(i)%section) END DO NULLIFY(section_vals%ibackup) END SUBROUTINE section_vals_create @@ -911,13 +865,10 @@ END SUBROUTINE section_vals_create ! ***************************************************************************** !> \brief retains the given section values (see doc/ReferenceCounting.html) !> \param section_vals the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE section_vals_retain(section_vals,error) + SUBROUTINE section_vals_retain(section_vals) TYPE(section_vals_type), POINTER :: section_vals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_retain', & routineP = moduleN//':'//routineN @@ -925,21 +876,18 @@ SUBROUTINE section_vals_retain(section_vals,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(section_vals%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPreconditionNoFail(section_vals%ref_count>0,cp_failure_level,routineP) section_vals%ref_count=section_vals%ref_count+1 END SUBROUTINE section_vals_retain ! ***************************************************************************** !> \brief releases the given object !> \param section_vals the section_vals to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - RECURSIVE SUBROUTINE section_vals_release(section_vals, error) + RECURSIVE SUBROUTINE section_vals_release(section_vals) TYPE(section_vals_type), POINTER :: section_vals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_release', & routineP = moduleN//':'//routineN @@ -952,35 +900,34 @@ RECURSIVE SUBROUTINE section_vals_release(section_vals, error) failure=.FALSE. IF (ASSOCIATED(section_vals)) THEN - CPPreconditionNoFail(section_vals%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(section_vals%ref_count>0,cp_failure_level,routineP) section_vals%ref_count=section_vals%ref_count-1 IF (section_vals%ref_count==0) THEN - CALL section_release(section_vals%section,error=error) + CALL section_release(section_vals%section) DO j=1,SIZE(section_vals%values,2) DO i=-1,UBOUND(section_vals%values,1) vals => section_vals%values(i,j)%list - DO WHILE (cp_sll_val_next(vals,el_att=el,error=error)) - CALL val_release(el,error=error) + DO WHILE (cp_sll_val_next(vals,el_att=el)) + CALL val_release(el) END DO - CALL cp_sll_val_dealloc(section_vals%values(i,j)%list,error=error) + CALL cp_sll_val_dealloc(section_vals%values(i,j)%list) END DO END DO DEALLOCATE(section_vals%values,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO j=1,SIZE(section_vals%subs_vals,2) DO i=1,SIZE(section_vals%subs_vals,1) - CALL section_vals_release(section_vals%subs_vals(i,j)%section_vals,& - error=error) + CALL section_vals_release(section_vals%subs_vals(i,j)%section_vals) END DO END DO DEALLOCATE(section_vals%subs_vals,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) IF (ASSOCIATED(section_vals%ibackup)) THEN DEALLOCATE(section_vals%ibackup,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(section_vals,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE section_vals_release @@ -995,20 +942,16 @@ END SUBROUTINE section_vals_release !> (max(1,n_repetition)) !> \param section ... !> \param explicit if the section was explicitly present in -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> !> \author fawzi !> \note For the other arguments see the attributes of section_vals_type ! ***************************************************************************** SUBROUTINE section_vals_get(section_vals, ref_count, id_nr, n_repetition,& - n_subs_vals_rep,section,explicit, error) + n_subs_vals_rep,section,explicit) TYPE(section_vals_type), POINTER :: section_vals INTEGER, INTENT(out), OPTIONAL :: ref_count, id_nr, & n_repetition, n_subs_vals_rep TYPE(section_type), OPTIONAL, POINTER :: section LOGICAL, INTENT(out), OPTIONAL :: explicit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_get', & routineP = moduleN//':'//routineN @@ -1017,8 +960,8 @@ SUBROUTINE section_vals_get(section_vals, ref_count, id_nr, n_repetition,& failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(ref_count)) ref_count=section_vals%ref_count IF (PRESENT(id_nr)) id_nr=section_vals%id_nr IF (PRESENT(section)) section => section_vals%section @@ -1034,18 +977,15 @@ END SUBROUTINE section_vals_get !> \param i_rep_section index of the repetition of section_vals from which !> you want to extract the subsection (defaults to 1) !> \param can_return_null if the results can be null (defaults to false) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** RECURSIVE FUNCTION section_vals_get_subs_vals(section_vals,subsection_name,& - i_rep_section,can_return_null,error) RESULT(res) + i_rep_section,can_return_null) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: subsection_name INTEGER, INTENT(in), OPTIONAL :: i_rep_section LOGICAL, INTENT(in), OPTIONAL :: can_return_null - TYPE(cp_error_type), INTENT(inout) :: error TYPE(section_vals_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_get_subs_vals', & @@ -1056,8 +996,8 @@ RECURSIVE FUNCTION section_vals_get_subs_vals(section_vals,subsection_name,& my_can_return_null failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) my_can_return_null=.FALSE. IF (PRESENT(can_return_null)) my_can_return_null=can_return_null @@ -1076,20 +1016,19 @@ RECURSIVE FUNCTION section_vals_get_subs_vals(section_vals,subsection_name,& my_index=my_index-1 ENDIF - CPPrecondition(irep<=SIZE(section_vals%subs_vals,2),cp_failure_level,routineP,error,failure) + CPPrecondition(irep<=SIZE(section_vals%subs_vals,2),cp_failure_level,routineP,failure) - isection=section_get_subsection_index(section_vals%section,subsection_name(1:my_index),& - error=error) + isection=section_get_subsection_index(section_vals%section,subsection_name(1:my_index)) IF (isection>0) res => section_vals%subs_vals(isection,irep)%section_vals IF(.NOT.(ASSOCIATED(res).OR.my_can_return_null))& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "could not find subsection "//TRIM(subsection_name(1:my_index))//" in section "//& TRIM(section_vals%section%name)//" at "//& CPSourceFileRef,& - error,failure) + failure) IF (is_path .AND. ASSOCIATED(res) ) THEN res=>section_vals_get_subs_vals(res,subsection_name(my_index+2:LEN_TRIM(subsection_name)),& - i_rep_section,can_return_null,error) + i_rep_section,can_return_null) ENDIF END FUNCTION section_vals_get_subs_vals @@ -1101,16 +1040,13 @@ END FUNCTION section_vals_get_subs_vals !> \param i_section index of the section !> \param i_rep_section index of the repetition of section_vals from which !> you want to extract the subsection (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION section_vals_get_subs_vals2(section_vals,i_section,i_rep_section,error) RESULT(res) + FUNCTION section_vals_get_subs_vals2(section_vals,i_section,i_rep_section) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals INTEGER, INTENT(in) :: i_section INTEGER, INTENT(in), OPTIONAL :: i_rep_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(section_vals_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_get_subs_vals2', & @@ -1120,12 +1056,12 @@ FUNCTION section_vals_get_subs_vals2(section_vals,i_section,i_rep_section,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(res) irep=1 IF (PRESENT(i_rep_section)) irep=i_rep_section - CPPrecondition(irep<=SIZE(section_vals%subs_vals,2),cp_failure_level,routineP,error,failure) + CPPrecondition(irep<=SIZE(section_vals%subs_vals,2),cp_failure_level,routineP,failure) isect_att=0 DO i=1,section_vals%section%n_subsections IF (SIZE(section_vals%subs_vals(i,irep)%section_vals%values,2)>0) THEN @@ -1145,17 +1081,14 @@ END FUNCTION section_vals_get_subs_vals2 !> \param subsection_name ... !> \param i_rep_section index of the repetition of section_vals from which !> you want to extract the subsection (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** FUNCTION section_vals_get_subs_vals3(section_vals,subsection_name,& - i_rep_section,error) RESULT(res) + i_rep_section) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(LEN=*), INTENT(IN) :: subsection_name INTEGER, INTENT(in), OPTIONAL :: i_rep_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(section_vals_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_get_subs_vals3', & @@ -1165,26 +1098,23 @@ FUNCTION section_vals_get_subs_vals3(section_vals,subsection_name,& LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(res) irep=1 IF (PRESENT(i_rep_section)) irep=i_rep_section - CPPrecondition(irep<=SIZE(section_vals%subs_vals,2),cp_failure_level,routineP,error,failure) - i_section = section_get_subsection_index(section_vals%section,subsection_name,error) + CPPrecondition(irep<=SIZE(section_vals%subs_vals,2),cp_failure_level,routineP,failure) + i_section = section_get_subsection_index(section_vals%section,subsection_name) res => section_vals%subs_vals(i_section,irep)%section_vals END FUNCTION section_vals_get_subs_vals3 ! ***************************************************************************** !> \brief adds the place to store the values of a repetition of the section !> \param section_vals the section you want to extend -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE section_vals_add_values(section_vals,error) + SUBROUTINE section_vals_add_values(section_vals) TYPE(section_vals_type), POINTER :: section_vals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_add_values', & routineP = moduleN//':'//routineN @@ -1198,17 +1128,17 @@ SUBROUTINE section_vals_add_values(section_vals,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) ALLOCATE(new_values(-1:UBOUND(section_vals%values,1),SIZE(section_vals%values,2)+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,SIZE(section_vals%values,2) DO i=-1,UBOUND(section_vals%values,1) new_values(i,j)%list => section_vals%values(i,j)%list END DO END DO DEALLOCATE(section_vals%values,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) section_vals%values => new_values j=SIZE ( new_values, 2 ) DO i=-1,UBOUND(new_values,1) @@ -1218,20 +1148,20 @@ SUBROUTINE section_vals_add_values(section_vals,error) IF (SIZE(new_values,2)>1) THEN ALLOCATE(new_sps(SIZE(section_vals%subs_vals,1),& SIZE(section_vals%subs_vals,2)+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,SIZE(section_vals%subs_vals,2) DO i=1,SIZE(section_vals%subs_vals,1) new_sps(i,j)%section_vals => section_vals%subs_vals(i,j)%section_vals END DO END DO DEALLOCATE(section_vals%subs_vals,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) section_vals%subs_vals => new_sps j = SIZE ( new_sps, 2 ) DO i=1,SIZE(new_sps,1) NULLIFY(new_sps(i,j)%section_vals) CALL section_vals_create(new_sps(i,SIZE(new_sps,2))%section_vals,& - section=section_vals%section%subsections(i)%section,error=error) + section=section_vals%section%subsections(i)%section) END DO END IF END SUBROUTINE section_vals_add_values @@ -1239,13 +1169,10 @@ END SUBROUTINE section_vals_add_values ! ***************************************************************************** !> \brief removes the values of a repetition of the section !> \param section_vals the section you want to extend -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE section_vals_remove_values(section_vals,error) + SUBROUTINE section_vals_remove_values(section_vals) TYPE(section_vals_type), POINTER :: section_vals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_remove_values', & routineP = moduleN//':'//routineN @@ -1260,23 +1187,23 @@ SUBROUTINE section_vals_remove_values(section_vals,error) failure=.FALSE. IF (ASSOCIATED(section_vals)) THEN - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(el, vals) ! Allocate a null 0 dimension array of values ALLOCATE(new_values(-1:section_vals%section%n_keywords,0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Release old values DO j=1,SIZE(section_vals%values,2) DO i=-1,UBOUND(section_vals%values,1) vals => section_vals%values(i,j)%list - DO WHILE (cp_sll_val_next(vals,el_att=el,error=error)) - CALL val_release(el,error=error) + DO WHILE (cp_sll_val_next(vals,el_att=el)) + CALL val_release(el) END DO - CALL cp_sll_val_dealloc(section_vals%values(i,j)%list,error=error) + CALL cp_sll_val_dealloc(section_vals%values(i,j)%list) END DO END DO DEALLOCATE(section_vals%values,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) section_vals%values => new_values END IF END SUBROUTINE section_vals_remove_values @@ -1290,17 +1217,15 @@ END SUBROUTINE section_vals_remove_values !> \brief ... !> \param section_vals ... !> \param keyword_name ... -!> \param error ... !> \retval res ... ! ***************************************************************************** - FUNCTION section_get_cval(section_vals,keyword_name,error) RESULT(res) + FUNCTION section_get_cval(section_vals,keyword_name) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_string_length) :: res - CALL section_vals_val_get(section_vals, keyword_name, c_val=res, error=error) + CALL section_vals_val_get(section_vals, keyword_name, c_val=res) END FUNCTION section_get_cval @@ -1308,17 +1233,15 @@ END FUNCTION section_get_cval !> \brief ... !> \param section_vals ... !> \param keyword_name ... -!> \param error ... !> \retval res ... ! ***************************************************************************** - FUNCTION section_get_rval(section_vals,keyword_name,error) RESULT(res) + FUNCTION section_get_rval(section_vals,keyword_name) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res - CALL section_vals_val_get(section_vals, keyword_name, r_val=res, error=error) + CALL section_vals_val_get(section_vals, keyword_name, r_val=res) END FUNCTION section_get_rval @@ -1326,17 +1249,15 @@ END FUNCTION section_get_rval !> \brief ... !> \param section_vals ... !> \param keyword_name ... -!> \param error ... !> \retval res ... ! ***************************************************************************** - FUNCTION section_get_rvals(section_vals,keyword_name,error) RESULT(res) + FUNCTION section_get_rvals(section_vals,keyword_name) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp), DIMENSION(:), POINTER :: res - CALL section_vals_val_get(section_vals, keyword_name, r_vals=res, error=error) + CALL section_vals_val_get(section_vals, keyword_name, r_vals=res) END FUNCTION section_get_rvals @@ -1344,17 +1265,15 @@ END FUNCTION section_get_rvals !> \brief ... !> \param section_vals ... !> \param keyword_name ... -!> \param error ... !> \retval res ... ! ***************************************************************************** - FUNCTION section_get_ival(section_vals,keyword_name,error) RESULT(res) + FUNCTION section_get_ival(section_vals,keyword_name) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res - CALL section_vals_val_get(section_vals, keyword_name, i_val=res, error=error) + CALL section_vals_val_get(section_vals, keyword_name, i_val=res) END FUNCTION section_get_ival @@ -1362,17 +1281,15 @@ END FUNCTION section_get_ival !> \brief ... !> \param section_vals ... !> \param keyword_name ... -!> \param error ... !> \retval res ... ! ***************************************************************************** - FUNCTION section_get_ivals(section_vals,keyword_name,error) RESULT(res) + FUNCTION section_get_ivals(section_vals,keyword_name) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, DIMENSION(:), POINTER :: res - CALL section_vals_val_get(section_vals, keyword_name, i_vals=res, error=error) + CALL section_vals_val_get(section_vals, keyword_name, i_vals=res) END FUNCTION section_get_ivals @@ -1380,17 +1297,15 @@ END FUNCTION section_get_ivals !> \brief ... !> \param section_vals ... !> \param keyword_name ... -!> \param error ... !> \retval res ... ! ***************************************************************************** - FUNCTION section_get_lval(section_vals,keyword_name,error) RESULT(res) + FUNCTION section_get_lval(section_vals,keyword_name) RESULT(res) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res - CALL section_vals_val_get(section_vals, keyword_name, l_val=res, error=error) + CALL section_vals_val_get(section_vals, keyword_name, l_val=res) END FUNCTION section_get_lval @@ -1415,13 +1330,11 @@ END FUNCTION section_get_lval !> \param r_vals ... !> \param c_vals ... !> \param explicit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE section_vals_val_get(section_vals,keyword_name,i_rep_section,& i_rep_val,n_rep_val,val,l_val,i_val,r_val,c_val,l_vals,i_vals,r_vals,& - c_vals,explicit,error) + c_vals,explicit) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name INTEGER, INTENT(in), OPTIONAL :: i_rep_section, i_rep_val @@ -1438,7 +1351,6 @@ SUBROUTINE section_vals_val_get(section_vals,keyword_name,i_rep_section,& CHARACTER(LEN=default_string_length), & DIMENSION(:), OPTIONAL, POINTER :: c_vals LOGICAL, INTENT(out), OPTIONAL :: explicit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_val_get', & routineP = moduleN//':'//routineN @@ -1454,8 +1366,8 @@ SUBROUTINE section_vals_val_get(section_vals,keyword_name,i_rep_section,& failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) my_index=INDEX(keyword_name,'%')+1 len_key=LEN_TRIM(keyword_name) @@ -1465,8 +1377,7 @@ SUBROUTINE section_vals_val_get(section_vals,keyword_name,i_rep_section,& IF (tmp_index<=0) EXIT my_index=my_index+tmp_index END DO - s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2),& - error=error) + s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2)) ELSE s_vals=> section_vals END IF @@ -1481,22 +1392,22 @@ SUBROUTINE section_vals_val_get(section_vals,keyword_name,i_rep_section,& valRequested=PRESENT(l_val).or.PRESENT(i_val).or.PRESENT(r_val).OR.& PRESENT(c_val).OR.PRESENT(l_vals).or.PRESENT(i_vals).OR.& PRESENT(r_vals).OR.PRESENT(c_vals) - ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key),error=error) + ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key)) IF(ik==-2) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - TRIM(keyword_name(my_index:len_key)),error,failure) + TRIM(keyword_name(my_index:len_key)),failure) keyword => section%keywords(ik)%keyword IF(.NOT.(irs>0.AND.irs<=SIZE(s_vals%subs_vals,2)))& CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,"section repetition requested ("//cp_to_string(irs)//& ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals,2))& - //")",error,failure) + //")",failure) NULLIFY(my_val) IF (PRESENT(n_rep_val)) n_rep_val=0 IF (irs<=SIZE(s_vals%values,2)) THEN ! the section was parsed vals => s_vals%values(ik,irs)%list - IF (PRESENT(n_rep_val)) n_rep_val=cp_sll_val_get_length(vals,error=error) + IF (PRESENT(n_rep_val)) n_rep_val=cp_sll_val_get_length(vals) IF (.NOT.ASSOCIATED(vals)) THEN ! this keyword was not parsed IF (ASSOCIATED(keyword%default_value)) THEN @@ -1505,7 +1416,7 @@ SUBROUTINE section_vals_val_get(section_vals,keyword_name,i_rep_section,& END IF ELSE my_val => cp_sll_val_get_el_at(s_vals%values(ik,irs)%list,& - irk,error=error) + irk) IF (PRESENT(explicit)) explicit = .TRUE. END IF ELSE IF (ASSOCIATED(keyword%default_value)) THEN @@ -1518,10 +1429,10 @@ SUBROUTINE section_vals_val_get(section_vals,keyword_name,i_rep_section,& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Value requested, but no value set getting value from "//& "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "//& - TRIM(section%name),error,failure) + TRIM(section%name),failure) CALL val_get(my_val,l_val=l_val,i_val=i_val,r_val=r_val,& c_val=c_val,l_vals=l_vals,i_vals=i_vals,r_vals=r_vals,& - c_vals=c_vals,error=error) + c_vals=c_vals) END IF END SUBROUTINE section_vals_val_get @@ -1533,18 +1444,16 @@ END SUBROUTINE section_vals_val_get !> \param i_rep_section which repetition of the section you are interested in !> (defaults to 1) !> \param list ... -!> \param error ... !> \author Joost VandeVondele !> \note !> - most useful if the full list is needed anyway, so that faster iteration can be used ! ***************************************************************************** SUBROUTINE section_vals_list_get(section_vals,keyword_name,i_rep_section,& - list,error) + list) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name INTEGER, OPTIONAL :: i_rep_section TYPE(cp_sll_val_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_list_get', & routineP = moduleN//':'//routineN @@ -1557,8 +1466,8 @@ SUBROUTINE section_vals_list_get(section_vals,keyword_name,i_rep_section,& failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(list) my_index=INDEX(keyword_name,'%')+1 len_key=LEN_TRIM(keyword_name) @@ -1568,8 +1477,7 @@ SUBROUTINE section_vals_list_get(section_vals,keyword_name,i_rep_section,& IF (tmp_index<=0) EXIT my_index=my_index+tmp_index END DO - s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2),& - error=error) + s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2)) ELSE s_vals=> section_vals END IF @@ -1577,16 +1485,16 @@ SUBROUTINE section_vals_list_get(section_vals,keyword_name,i_rep_section,& irs=1 IF (PRESENT(i_rep_section)) irs=i_rep_section section => s_vals%section - ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key),error=error) + ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key)) IF(ik==-2)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - TRIM(keyword_name(my_index:len_key)),error,failure) + TRIM(keyword_name(my_index:len_key)),failure) IF(.NOT.(irs>0.AND.irs<=SIZE(s_vals%subs_vals,2)))& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "section repetition requested ("//cp_to_string(irs)//& ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals,2))& - //")",error,failure) + //")",failure) list => s_vals%values(ik,irs)%list END SUBROUTINE section_vals_list_get @@ -1611,12 +1519,10 @@ END SUBROUTINE section_vals_list_get !> \param i_vals_ptr ... !> \param r_vals_ptr ... !> \param c_vals_ptr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE section_vals_val_set(section_vals,keyword_name,i_rep_section,i_rep_val,& - val,l_val,i_val,r_val,c_val,l_vals_ptr,i_vals_ptr,r_vals_ptr,c_vals_ptr,error) + val,l_val,i_val,r_val,c_val,l_vals_ptr,i_vals_ptr,r_vals_ptr,c_vals_ptr) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name INTEGER, INTENT(in), OPTIONAL :: i_rep_section, i_rep_val @@ -1631,7 +1537,6 @@ SUBROUTINE section_vals_val_set(section_vals,keyword_name,i_rep_section,i_rep_va POINTER :: r_vals_ptr CHARACTER(LEN=default_string_length), & DIMENSION(:), OPTIONAL, POINTER :: c_vals_ptr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_val_set', & routineP = moduleN//':'//routineN @@ -1647,8 +1552,8 @@ SUBROUTINE section_vals_val_set(section_vals,keyword_name,i_rep_section,i_rep_va failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) my_index=INDEX(keyword_name,'%')+1 len_key=LEN_TRIM(keyword_name) @@ -1658,8 +1563,7 @@ SUBROUTINE section_vals_val_set(section_vals,keyword_name,i_rep_section,i_rep_va IF (tmp_index<=0) EXIT my_index=my_index+tmp_index END DO - s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2),& - error=error) + s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2)) ELSE s_vals=> section_vals END IF @@ -1669,21 +1573,21 @@ SUBROUTINE section_vals_val_set(section_vals,keyword_name,i_rep_section,i_rep_va IF (PRESENT(i_rep_section)) irs=i_rep_section IF (PRESENT(i_rep_val)) irk=i_rep_val section => s_vals%section - ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key),error=error) + ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key)) IF(ik==-2)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - TRIM(keyword_name(my_index:len_key)),error,failure) + TRIM(keyword_name(my_index:len_key)),failure) ! Add values.. DO IF (irs<=SIZE(s_vals%values,2)) EXIT - CALL section_vals_add_values(s_vals,error=error) + CALL section_vals_add_values(s_vals) END DO IF(.NOT.(irs>0.AND.irs<=SIZE(s_vals%subs_vals,2)))& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "section repetition requested ("//cp_to_string(irs)//& ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals,2))& - //")",error,failure) + //")",failure) keyword => s_vals%section%keywords(ik)%keyword NULLIFY(my_val) IF (PRESENT(val)) my_val => val @@ -1697,47 +1601,46 @@ SUBROUTINE section_vals_val_set(section_vals,keyword_name,i_rep_section,i_rep_va cp_failure_level,cp_assertion_failed,routineP,& " both val and values present, in setting "//& "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "//& - TRIM(section%name),error,failure) + TRIM(section%name),failure) ELSE ! ignore ? IF(.NOT.valSet)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& " empty value in setting "//& "keyword "//TRIM(keyword_name(my_index:len_key))//" of section "//& - TRIM(section%name),error,failure) - CPPrecondition(valSet,cp_failure_level,routineP,error,failure) + TRIM(section%name),failure) + CPPrecondition(valSet,cp_failure_level,routineP,failure) IF (keyword%type_of_var==lchar_t) THEN - CALL val_create(my_val, lc_val=c_val, lc_vals_ptr=c_vals_ptr,& - error=error) + CALL val_create(my_val, lc_val=c_val, lc_vals_ptr=c_vals_ptr) ELSE CALL val_create(my_val,l_val=l_val,i_val=i_val,r_val=r_val,& c_val=c_val,l_vals_ptr=l_vals_ptr,i_vals_ptr=i_vals_ptr,& r_vals_ptr=r_vals_ptr,& - c_vals_ptr=c_vals_ptr,enum=keyword%enum,error=error) + c_vals_ptr=c_vals_ptr,enum=keyword%enum) END IF - CPPostcondition(ASSOCIATED(my_val),cp_failure_level,routineP,error,failure) - CPPostcondition(my_val%type_of_var==keyword%type_of_var,cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(my_val),cp_failure_level,routineP,failure) + CPPostcondition(my_val%type_of_var==keyword%type_of_var,cp_failure_level,routineP,failure) END IF vals => s_vals%values(ik,irs)%list IF (irk==-1) THEN - CALL cp_sll_val_insert_el_at(vals,my_val,index=-1,error=error) - ELSE IF (irk <= cp_sll_val_get_length(vals,error)) THEN + CALL cp_sll_val_insert_el_at(vals,my_val,index=-1) + ELSE IF (irk <= cp_sll_val_get_length(vals)) THEN IF(irk<=0)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"invalid irk "//TRIM(ADJUSTL(cp_to_string(irk)))//& " in keyword "//TRIM(keyword_name(my_index:len_key))//" of section "//& - TRIM(section%name),error,failure) - old_val => cp_sll_val_get_el_at(vals,index=irk,error=error) - CALL val_release(old_val,error=error) - CALL cp_sll_val_set_el_at(vals,value=my_val,index=irk,error=error) - ELSE IF (irk>cp_sll_val_get_length(vals,error)+1) THEN + TRIM(section%name),failure) + old_val => cp_sll_val_get_el_at(vals,index=irk) + CALL val_release(old_val) + CALL cp_sll_val_set_el_at(vals,value=my_val,index=irk) + ELSE IF (irk>cp_sll_val_get_length(vals)+1) THEN ! change? CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"cannot add extra keyword repetitions to keyword"& //TRIM(keyword_name(my_index:len_key))//" of section "//& - TRIM(section%name),error,failure) + TRIM(section%name),failure) ELSE - CALL cp_sll_val_insert_el_at(vals,my_val,index=irk,error=error) + CALL cp_sll_val_insert_el_at(vals,my_val,index=irk) END IF s_vals%values(ik,irs)%list => vals NULLIFY(my_val) @@ -1754,16 +1657,13 @@ END SUBROUTINE section_vals_val_set !> (defaults to 1) !> \param i_rep_val which repetition of the keyword/val you are interested in !> (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE section_vals_val_unset(section_vals,keyword_name,i_rep_section,& - i_rep_val,error) + i_rep_val) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: keyword_name INTEGER, INTENT(in), OPTIONAL :: i_rep_section, i_rep_val - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_val_unset', & routineP = moduleN//':'//routineN @@ -1778,8 +1678,8 @@ SUBROUTINE section_vals_val_unset(section_vals,keyword_name,i_rep_section,& failure=.FALSE. NULLIFY(pos) - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) my_index=INDEX(keyword_name,'%')+1 len_key=LEN_TRIM(keyword_name) @@ -1789,8 +1689,7 @@ SUBROUTINE section_vals_val_unset(section_vals,keyword_name,i_rep_section,& IF (tmp_index<=0) EXIT my_index=my_index+tmp_index END DO - s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2),& - error=error) + s_vals => section_vals_get_subs_vals(section_vals,keyword_name(1:my_index-2)) ELSE s_vals=> section_vals END IF @@ -1800,29 +1699,27 @@ SUBROUTINE section_vals_val_unset(section_vals,keyword_name,i_rep_section,& IF (PRESENT(i_rep_section)) irs=i_rep_section IF (PRESENT(i_rep_val)) irk=i_rep_val section => s_vals%section - ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key),error=error) + ik=section_get_keyword_index(s_vals%section,keyword_name(my_index:len_key)) IF(ik==-2)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - TRIM(keyword_name(my_index:len_key)),error,failure) + TRIM(keyword_name(my_index:len_key)),failure) ! ignore unset of non set values IF (irs<=SIZE(s_vals%values,2)) THEN IF(.NOT.(irs>0.AND.irs<=SIZE(s_vals%subs_vals,2)))& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "section repetition requested ("//cp_to_string(irs)//& ") out of bounds (1:"//cp_to_string(SIZE(s_vals%subs_vals,2))& - //")",error,failure) + //")",failure) IF (irk==-1) THEN - pos => cp_sll_val_get_rest(s_vals%values(ik,irs)%list, iter=-1,error=error) + pos => cp_sll_val_get_rest(s_vals%values(ik,irs)%list, iter=-1) ELSE - pos => cp_sll_val_get_rest(s_vals%values(ik,irs)%list, iter=irk-1,error=error) + pos => cp_sll_val_get_rest(s_vals%values(ik,irs)%list, iter=irk-1) END IF IF (ASSOCIATED(pos)) THEN - old_val => cp_sll_val_get_el_at(s_vals%values(ik,irs)%list,index=irk,& - error=error) - CALL val_release(old_val,error=error) - CALL cp_sll_val_rm_el_at(s_vals%values(ik,irs)%list,index=irk,& - error=error) + old_val => cp_sll_val_get_el_at(s_vals%values(ik,irs)%list,index=irk) + CALL val_release(old_val) + CALL cp_sll_val_rm_el_at(s_vals%values(ik,irs)%list,index=irk) END IF END IF @@ -1835,17 +1732,14 @@ END SUBROUTINE section_vals_val_unset !> \param unit_nr the unit where to write to !> \param hide_root ... !> \param hide_defaults ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> skips required sections which weren't read ! ***************************************************************************** - RECURSIVE SUBROUTINE section_vals_write(section_vals,unit_nr,hide_root,hide_defaults,error) + RECURSIVE SUBROUTINE section_vals_write(section_vals,unit_nr,hide_root,hide_defaults) TYPE(section_vals_type), POINTER :: section_vals INTEGER, INTENT(in) :: unit_nr LOGICAL, INTENT(in), OPTIONAL :: hide_root, hide_defaults - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_write', & routineP = moduleN//':'//routineN @@ -1869,11 +1763,10 @@ RECURSIVE SUBROUTINE section_vals_write(section_vals,unit_nr,hide_root,hide_defa IF (PRESENT(hide_root)) my_hide_root=hide_root IF (PRESENT(hide_defaults)) my_hide_defaults=hide_defaults - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) IF ((.NOT.failure).AND.(unit_nr>0)) THEN - CALL section_vals_get(section_vals, explicit=explicit, n_repetition=nr, section=section,& - error=error) + CALL section_vals_get(section_vals, explicit=explicit, n_repetition=nr, section=section) IF (explicit.OR.(.NOT.my_hide_defaults)) THEN DO i_rep_s=1,nr IF (.NOT.my_hide_root) THEN @@ -1895,7 +1788,7 @@ RECURSIVE SUBROUTINE section_vals_write(section_vals,unit_nr,hide_root,hide_defa IF (ASSOCIATED(keyword)) THEN IF (keyword%type_of_var/=no_t.AND.keyword%names(1)(1:2)/="__") THEN CALL section_vals_val_get(section_vals,keyword%names(1),& - i_rep_s,n_rep_val=nval,error=error) + i_rep_s,n_rep_val=nval) IF (i_rep_s<=SIZE(section_vals%values,2)) THEN ! Section was parsed vals => section_vals%values(ik,i_rep_s)%list @@ -1923,7 +1816,7 @@ RECURSIVE SUBROUTINE section_vals_write(section_vals,unit_nr,hide_root,hide_defa WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") END IF CALL val_write(val,unit_nr=unit_nr,unit=keyword%unit,& - fmt=myfmt,error=error) + fmt=myfmt) END DO ELSEIF (ASSOCIATED(keyword%default_value)) THEN ! Section was not parsed but default for the keywords may exist @@ -1938,7 +1831,7 @@ RECURSIVE SUBROUTINE section_vals_write(section_vals,unit_nr,hide_root,hide_defa WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") END IF CALL val_write(val,unit_nr=unit_nr,unit=keyword%unit,& - fmt=myfmt,error=error) + fmt=myfmt) END IF END IF END IF @@ -1948,7 +1841,7 @@ RECURSIVE SUBROUTINE section_vals_write(section_vals,unit_nr,hide_root,hide_defa DO isec=1,SIZE(section_vals%subs_vals,1) sval => section_vals%subs_vals(isec,i_rep_s)%section_vals IF (ASSOCIATED(sval)) THEN - CALL section_vals_write(sval,unit_nr=unit_nr,hide_defaults=hide_defaults,error=error) + CALL section_vals_write(sval,unit_nr=unit_nr,hide_defaults=hide_defaults) END IF END DO END IF @@ -1969,13 +1862,11 @@ END SUBROUTINE section_vals_write !> \param section ... !> \param level ... !> \param unit_number ... -!> \param error ... ! ***************************************************************************** - RECURSIVE SUBROUTINE write_section_xml(section,level,unit_number,error) + RECURSIVE SUBROUTINE write_section_xml(section,level,unit_number) TYPE(section_type), POINTER :: section INTEGER, INTENT(IN) :: level, unit_number - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_section_xml', & routineP = moduleN//':'//routineN @@ -1989,7 +1880,7 @@ RECURSIVE SUBROUTINE write_section_xml(section,level,unit_number,error) IF (ASSOCIATED(section)) THEN - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) ! Indentation for current level, next level, etc. @@ -2024,14 +1915,12 @@ RECURSIVE SUBROUTINE write_section_xml(section,level,unit_number,error) DO i=-1,section%n_keywords IF (ASSOCIATED(section%keywords(i)%keyword)) THEN - CALL write_keyword_xml(section%keywords(i)%keyword,l1,unit_number,& - error) + CALL write_keyword_xml(section%keywords(i)%keyword,l1,unit_number) END IF END DO DO i=1,section%n_subsections - CALL write_section_xml(section%subsections(i)%section,l1,unit_number,& - error) + CALL write_section_xml(section%subsections(i)%section,l1,unit_number) END DO WRITE (UNIT=unit_number,FMT="(A)") REPEAT(" ",l0)//"" @@ -2047,10 +1936,9 @@ END SUBROUTINE write_section_xml !> \param location_string ... !> \param matching_rank ... !> \param matching_string ... -!> \param error ... ! ***************************************************************************** RECURSIVE SUBROUTINE section_typo_match(section,unknown_string,location_string,& - matching_rank,matching_string,error) + matching_rank,matching_string) TYPE(section_type), POINTER :: section CHARACTER(LEN=*) :: unknown_string, & @@ -2058,7 +1946,6 @@ RECURSIVE SUBROUTINE section_typo_match(section,unknown_string,location_string,& INTEGER, DIMENSION(:), INTENT(INOUT) :: matching_rank CHARACTER(LEN=*), DIMENSION(:), & INTENT(INOUT) :: matching_string - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'section_typo_match', & routineP = moduleN//':'//routineN @@ -2069,7 +1956,7 @@ RECURSIVE SUBROUTINE section_typo_match(section,unknown_string,location_string,& failure = .FALSE. IF (ASSOCIATED(section)) THEN - CPPrecondition(section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(section%ref_count>0,cp_failure_level,routineP,failure) imatch=typo_match(TRIM(section%name),TRIM(unknown_string)) IF (imatch>0) THEN WRITE(line,'(T2,A)') " subsection "//TRIM(section%name)//" in section "//TRIM(location_string) @@ -2089,13 +1976,13 @@ RECURSIVE SUBROUTINE section_typo_match(section,unknown_string,location_string,& DO i=-1,section%n_keywords IF (ASSOCIATED(section%keywords(i)%keyword)) THEN CALL keyword_typo_match(section%keywords(i)%keyword,unknown_string,location_string// & - "%"//TRIM(section%name),matching_rank,matching_string,error) + "%"//TRIM(section%name),matching_rank,matching_string) END IF END DO DO i=1,section%n_subsections CALL section_typo_match(section%subsections(i)%section,unknown_string,& - location_string//"%"//TRIM(section%name),matching_rank,matching_string,error) + location_string//"%"//TRIM(section%name),matching_rank,matching_string) END DO END IF @@ -2109,17 +1996,14 @@ END SUBROUTINE section_typo_match !> \param new_section_vals the new section_vals to use !> \param i_rep_section index of the repetition of section_vals of which !> you want to replace the subsection (defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE section_vals_set_subs_vals(section_vals,subsection_name,& - new_section_vals,i_rep_section,error) + new_section_vals,i_rep_section) TYPE(section_vals_type), POINTER :: section_vals CHARACTER(len=*), INTENT(in) :: subsection_name TYPE(section_vals_type), POINTER :: new_section_vals INTEGER, INTENT(in), OPTIONAL :: i_rep_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_set_subs_vals', & routineP = moduleN//':'//routineN @@ -2130,10 +2014,10 @@ SUBROUTINE section_vals_set_subs_vals(section_vals,subsection_name,& TYPE(section_vals_type), POINTER :: s_vals failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(new_section_vals),cp_failure_level,routineP,error,failure) - CPPrecondition(new_section_vals%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals),cp_failure_level,routineP,failure) + CPPrecondition(section_vals%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(new_section_vals),cp_failure_level,routineP,failure) + CPPrecondition(new_section_vals%ref_count>0,cp_failure_level,routineP,failure) irep=1 IF (PRESENT(i_rep_section)) irep=i_rep_section @@ -2146,25 +2030,23 @@ SUBROUTINE section_vals_set_subs_vals(section_vals,subsection_name,& IF (tmp_index<=0) EXIT my_index=my_index+tmp_index END DO - s_vals => section_vals_get_subs_vals(section_vals,subsection_name(1:my_index-2),& - error=error) + s_vals => section_vals_get_subs_vals(section_vals,subsection_name(1:my_index-2)) ELSE s_vals=> section_vals END IF - CPPrecondition(irep<=SIZE(s_vals%subs_vals,2),cp_failure_level,routineP,error,failure) + CPPrecondition(irep<=SIZE(s_vals%subs_vals,2),cp_failure_level,routineP,failure) - isection=section_get_subsection_index(s_vals%section,subsection_name(my_index:LEN_TRIM(subsection_name)),& - error=error) + isection=section_get_subsection_index(s_vals%section,subsection_name(my_index:LEN_TRIM(subsection_name))) IF(isection<=0)& CALL cp_assert(.FALSE.,cp_failure_level,& cp_assertion_failed,routineP,& "could not find subsection "//subsection_name(my_index:LEN_TRIM(subsection_name))//" in section "//& TRIM(section_vals%section%name)//" at "//& CPSourceFileRef,& - error,failure) - CALL section_vals_retain(new_section_vals,error=error) - CALL section_vals_release(s_vals%subs_vals(isection,irep)%section_vals,error=error) + failure) + CALL section_vals_retain(new_section_vals) + CALL section_vals_release(s_vals%subs_vals(isection,irep)%section_vals) s_vals%subs_vals(isection,irep)%section_vals => new_section_vals END SUBROUTINE section_vals_set_subs_vals @@ -2175,16 +2057,13 @@ END SUBROUTINE section_vals_set_subs_vals !> \param section_vals_out the section_vals to create !> \param i_rep_start ... !> \param i_rep_end ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE section_vals_duplicate(section_vals_in,section_vals_out,& - i_rep_start, i_rep_end, error) + i_rep_start, i_rep_end) TYPE(section_vals_type), POINTER :: section_vals_in, & section_vals_out INTEGER, INTENT(IN), OPTIONAL :: i_rep_start, i_rep_end - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_duplicate', & routineP = moduleN//':'//routineN @@ -2193,11 +2072,10 @@ SUBROUTINE section_vals_duplicate(section_vals_in,section_vals_out,& failure=.FALSE. - CPPrecondition(ASSOCIATED(section_vals_in),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(section_vals_out),cp_failure_level,routineP,error,failure) - CALL section_vals_create(section_vals_out,section_vals_in%section,& - error=error) - CALL section_vals_copy(section_vals_in,section_vals_out,i_rep_start,i_rep_end,error=error) + CPPrecondition(ASSOCIATED(section_vals_in),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(section_vals_out),cp_failure_level,routineP,failure) + CALL section_vals_create(section_vals_out,section_vals_in%section) + CALL section_vals_copy(section_vals_in,section_vals_out,i_rep_start,i_rep_end) END SUBROUTINE section_vals_duplicate ! ***************************************************************************** @@ -2206,18 +2084,15 @@ END SUBROUTINE section_vals_duplicate !> \param section_vals_out the section_vals where to copy !> \param i_rep_low ... !> \param i_rep_high ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> private, only works with a newly initialized section_vals_out ! ***************************************************************************** RECURSIVE SUBROUTINE section_vals_copy(section_vals_in,section_vals_out,& - i_rep_low,i_rep_high,error) + i_rep_low,i_rep_high) TYPE(section_vals_type), POINTER :: section_vals_in, & section_vals_out INTEGER, INTENT(IN), OPTIONAL :: i_rep_low, i_rep_high - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'section_vals_copy', & routineP = moduleN//':'//routineN @@ -2230,30 +2105,30 @@ RECURSIVE SUBROUTINE section_vals_copy(section_vals_in,section_vals_out,& failure=.FALSE. NULLIFY(v2,el) - CPPrecondition(ASSOCIATED(section_vals_in),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(section_vals_out),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section_vals_in),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(section_vals_out),cp_failure_level,routineP,failure) ! IF(section_vals_in%section%id_nr/=section_vals_out%section%id_nr)& ! CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& ! CPSourceFileRef,& - ! error,failure) + ! failure) istart = 1 iend = SIZE(section_vals_in%values,2) IF (PRESENT(i_rep_low)) istart=i_rep_low IF (PRESENT(i_rep_high)) iend=i_rep_high DO irep=istart,iend - CALL section_vals_add_values(section_vals_out,error=error) + CALL section_vals_add_values(section_vals_out) DO ival=LBOUND(section_vals_in%values,1),UBOUND(section_vals_in%values,1) v1=>section_vals_in%values(ival,irep)%list IF (ASSOCIATED(v1)) THEN - CALL val_duplicate(v1%first_el,el,error=error) - CALL cp_sll_val_create(v2,el,error=error) + CALL val_duplicate(v1%first_el,el) + CALL cp_sll_val_create(v2,el) NULLIFY(el) section_vals_out%values(ival,irep-istart+1)%list => v2 DO IF (.not.ASSOCIATED(v1%rest)) EXIT v1 => v1%rest - CALL val_duplicate(v1%first_el,el,error=error) - CALL cp_sll_val_create(v2%rest,first_el=el,error=error) + CALL val_duplicate(v1%first_el,el) + CALL cp_sll_val_create(v2%rest,first_el=el) NULLIFY(el) v2 => v2%rest END DO @@ -2264,18 +2139,18 @@ RECURSIVE SUBROUTINE section_vals_copy(section_vals_in,section_vals_out,& CALL cp_assert(SIZE(section_vals_in%values,2)==SIZE(section_vals_out%values,2),& cp_failure_level,cp_assertion_failed,routineP,& CPSourceFileRef,& - error,failure) + failure) CALL cp_assert(SIZE(section_vals_in%subs_vals,2)==SIZE(section_vals_out%subs_vals,2),& cp_failure_level,cp_assertion_failed,routineP,& CPSourceFileRef,& - error,failure) + failure) END IF iend = SIZE(section_vals_in%subs_vals,2) IF (PRESENT(i_rep_high)) iend=i_rep_high DO irep=istart,iend DO isec=1,SIZE(section_vals_in%subs_vals,1) CALL section_vals_copy(section_vals_in%subs_vals(isec,irep)%section_vals,& - section_vals_out%subs_vals(isec,irep-istart+1)%section_vals,error=error) + section_vals_out%subs_vals(isec,irep-istart+1)%section_vals) END DO END DO END SUBROUTINE section_vals_copy diff --git a/src/input/input_val_types.F b/src/input/input_val_types.F index c72f04fe22..01594bfeac 100644 --- a/src/input/input_val_types.F +++ b/src/input/input_val_types.F @@ -94,15 +94,13 @@ MODULE input_val_types !> \param lc_vals ... !> \param lc_vals_ptr ... !> \param enum the enumaration type this value is using -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> using an enumeration only i_val/i_vals/i_vals_ptr are accepted ! ***************************************************************************** SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& r_val,r_vals,r_vals_ptr,c_val,c_vals,c_vals_ptr,lc_val,lc_vals,& - lc_vals_ptr,enum,error) + lc_vals_ptr,enum) TYPE(val_type), POINTER :: val LOGICAL, INTENT(in), OPTIONAL :: l_val LOGICAL, DIMENSION(:), INTENT(in), & @@ -129,7 +127,6 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& DIMENSION(:), OPTIONAL, POINTER :: lc_vals_ptr TYPE(enumeration_type), OPTIONAL, & POINTER :: enum - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_create', & routineP = moduleN//':'//routineN @@ -139,9 +136,9 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(val),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(val),cp_failure_level,routineP,failure) ALLOCATE(val,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(val%l_val,val%i_val,val%r_val,val%c_val,val%enum) val%type_of_var=no_t last_val_id=last_val_id+1 @@ -151,19 +148,19 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& narg=0 val%type_of_var=no_t IF (PRESENT(l_val)) THEN -!FM CPPrecondition(.NOT.PRESENT(l_vals),cp_failure_level,routineP,error,failure) -!FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(l_vals),cp_failure_level,routineP,failure) +!FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%l_val(1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) val%l_val(1)=l_val val%type_of_var=logical_t END IF IF (PRESENT(l_vals)) THEN -!FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(l_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%l_val(SIZE(l_vals)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%l_val=l_vals val%type_of_var=logical_t END IF @@ -174,19 +171,19 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& END IF IF (PRESENT(r_val)) THEN -!FM CPPrecondition(.NOT.PRESENT(r_vals),cp_failure_level,routineP,error,failure) -!FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(r_vals),cp_failure_level,routineP,failure) +!FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%r_val(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%r_val(1)=r_val val%type_of_var=real_t END IF IF (PRESENT(r_vals)) THEN -!FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(r_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%r_val(SIZE(r_vals)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%r_val=r_vals val%type_of_var=real_t END IF @@ -197,19 +194,19 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& END IF IF (PRESENT(i_val)) THEN -!FM CPPrecondition(.NOT.PRESENT(i_vals),cp_failure_level,routineP,error,failure) -!FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(i_vals),cp_failure_level,routineP,failure) +!FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%i_val(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%i_val(1)=i_val val%type_of_var=integer_t END IF IF (PRESENT(i_vals)) THEN -!FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(i_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%i_val(SIZE(i_vals)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%i_val=i_vals val%type_of_var=integer_t END IF @@ -220,21 +217,21 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& END IF IF (PRESENT(c_val)) THEN - CPPrecondition(LEN_TRIM(c_val)<=default_string_length,cp_failure_level,routineP,error,failure) -!FM CPPrecondition(.NOT.PRESENT(c_vals),cp_failure_level,routineP,error,failure) -!FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(LEN_TRIM(c_val)<=default_string_length,cp_failure_level,routineP,failure) +!FM CPPrecondition(.NOT.PRESENT(c_vals),cp_failure_level,routineP,failure) +!FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%c_val(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%c_val(1)=c_val val%type_of_var=char_t END IF IF (PRESENT(c_vals)) THEN -!FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(LEN_TRIM(c_vals)<=default_string_length),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(c_vals_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ALL(LEN_TRIM(c_vals)<=default_string_length),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%c_val(SIZE(c_vals)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%c_val=c_vals val%type_of_var=char_t END IF @@ -244,13 +241,13 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& val%type_of_var=char_t END IF IF (PRESENT(lc_val)) THEN -!FM CPPrecondition(.NOT.PRESENT(lc_vals),cp_failure_level,routineP,error,failure) -!FM CPPrecondition(.NOT.PRESENT(lc_vals_ptr),cp_failure_level,routineP,error,failure) +!FM CPPrecondition(.NOT.PRESENT(lc_vals),cp_failure_level,routineP,failure) +!FM CPPrecondition(.NOT.PRESENT(lc_vals_ptr),cp_failure_level,routineP,failure) narg=narg+1 len_c=LEN_TRIM(lc_val) nVal=MAX(1,CEILING(REAL(len_c,dp)/80._dp)) ALLOCATE(val%c_val(nVal),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (len_c == 0) THEN val%c_val(1) = "" @@ -263,10 +260,10 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& val%type_of_var=lchar_t END IF IF (PRESENT(lc_vals)) THEN - CPPrecondition(ALL(LEN_TRIM(lc_vals)<=default_string_length),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(LEN_TRIM(lc_vals)<=default_string_length),cp_failure_level,routineP,failure) narg=narg+1 ALLOCATE(val%c_val(SIZE(lc_vals)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) val%c_val=lc_vals val%type_of_var=lchar_t END IF @@ -275,33 +272,30 @@ SUBROUTINE val_create(val,l_val,l_vals,l_vals_ptr,i_val,i_vals,i_vals_ptr,& val%c_val => lc_vals_ptr val%type_of_var=lchar_t END IF - CPPostcondition(narg<=1,cp_failure_level,routineP,error,failure) + CPPostcondition(narg<=1,cp_failure_level,routineP,failure) IF (PRESENT(enum)) THEN IF (ASSOCIATED(enum)) THEN IF (val%type_of_var/=no_t.AND.val%type_of_var/=integer_t.AND.& val%type_of_var/=enum_t) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(val%i_val)) THEN val%type_of_var=enum_t val%enum=>enum - CALL enum_retain(enum,error=error) + CALL enum_retain(enum) END IF END IF END IF - CPPostcondition(ASSOCIATED(val%enum).eqv.val%type_of_var==enum_t,cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(val%enum).eqv.val%type_of_var==enum_t,cp_failure_level,routineP,failure) END SUBROUTINE val_create ! ***************************************************************************** !> \brief releases the given val !> \param val the val to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE val_release(val,error) +SUBROUTINE val_release(val) TYPE(val_type), POINTER :: val - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_release', & routineP = moduleN//':'//routineN @@ -312,29 +306,29 @@ SUBROUTINE val_release(val,error) failure=.FALSE. IF (ASSOCIATED(val)) THEN - CPPreconditionNoFail(val%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(val%ref_count>0,cp_failure_level,routineP) val%ref_count=val%ref_count-1 IF (val%ref_count==0) THEN IF (ASSOCIATED(val%l_val)) THEN DEALLOCATE(val%l_val,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(val%i_val)) THEN DEALLOCATE(val%i_val,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(val%r_val)) THEN DEALLOCATE(val%r_val,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(val%c_val)) THEN DEALLOCATE(val%c_val,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF - CALL enum_release(val%enum,error=error) + CALL enum_release(val%enum) val%type_of_var=no_t DEALLOCATE(val,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(val) @@ -343,13 +337,10 @@ END SUBROUTINE val_release ! ***************************************************************************** !> \brief retains the given val !> \param val the val to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE val_retain(val,error) +SUBROUTINE val_retain(val) TYPE(val_type), POINTER :: val - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_retain', & routineP = moduleN//':'//routineN @@ -358,8 +349,8 @@ SUBROUTINE val_retain(val,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(val),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(val%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(val),cp_failure_level,routineP,failure) + CPPreconditionNoFail(val%ref_count>0,cp_failure_level,routineP) val%ref_count=val%ref_count+1 END SUBROUTINE val_retain @@ -383,8 +374,6 @@ END SUBROUTINE val_retain !> it might be longet than default_string_length) !> \param type_of_var ... !> \param enum ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> using an enumeration only i_val/i_vals/i_vals_ptr are accepted @@ -392,7 +381,7 @@ END SUBROUTINE val_retain !> the c_val is too short to contain the string ! ***************************************************************************** SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& - i_vals,r_val,r_vals,c_val,c_vals,len_c,type_of_var,enum,error) + i_vals,r_val,r_vals,c_val,c_vals,len_c,type_of_var,enum) TYPE(val_type), POINTER :: val LOGICAL, INTENT(out), OPTIONAL :: has_l, has_i, has_r, has_lc, & has_c, l_val @@ -408,7 +397,6 @@ SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& INTEGER, INTENT(out), OPTIONAL :: len_c, type_of_var TYPE(enumeration_type), OPTIONAL, & POINTER :: enum - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_get', & routineP = moduleN//':'//routineN @@ -429,10 +417,10 @@ SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& IF (SIZE(val%l_val)>0) THEN l_val=val%l_val(1) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END IF @@ -442,10 +430,10 @@ SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& IF (SIZE(val%i_val)>0) THEN i_val=val%i_val(1) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END IF @@ -455,10 +443,10 @@ SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& IF (SIZE(val%r_val)>0) THEN r_val=val%r_val(1) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END IF @@ -472,7 +460,7 @@ SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& LEN_TRIM(val%c_val(SIZE(val%c_val))) CALL cp_assert(l_out>=l_in,cp_warning_level,cp_assertion_failed,& routineP,"val_get will truncate value, value beginning with '"//& - TRIM(val%c_val(1))//"' is too long for variable",error,failure) + TRIM(val%c_val(1))//"' is too long for variable",failure) DO i=1,SIZE(val%c_val) c_val((i-1)*default_string_length+1:MIN(l_out,i*default_string_length))=& val%c_val(i)(1:MIN(80,l_out-(i-1)*default_string_length)) @@ -484,20 +472,20 @@ SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& l_in=LEN_TRIM(val%c_val(1)) CALL cp_assert(l_out>=l_in,cp_warning_level,cp_assertion_failed,& routineP,"val_get will truncate value, value '"//& - TRIM(val%c_val(1))//"' is too long for variable",error,failure) + TRIM(val%c_val(1))//"' is too long for variable",failure) c_val=val%c_val(1) END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF ELSE IF (ASSOCIATED(val%i_val).AND.ASSOCIATED(val%enum)) THEN IF (SIZE(val%i_val)>0) THEN - c_val=enum_i2c(val%enum,val%i_val(1),error=error) + c_val=enum_i2c(val%enum,val%i_val(1)) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END IF @@ -515,7 +503,7 @@ SUBROUTINE val_get(val,has_l,has_i,has_r,has_lc,has_c,l_val,l_vals,i_val,& END IF ELSE IF (ASSOCIATED(val%i_val).AND.ASSOCIATED(val%enum)) THEN IF (SIZE(val%i_val)>0) THEN - len_c=LEN_TRIM(enum_i2c(val%enum,val%i_val(1),error=error)) + len_c=LEN_TRIM(enum_i2c(val%enum,val%i_val(1))) ELSE len_c=-HUGE(0) END IF @@ -538,18 +526,15 @@ END SUBROUTINE val_get !> (overrides unit_str) !> \param unit_str the unit of mesure in wich the output should be written !> \param fmt ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> unit of mesure used only for reals ! ***************************************************************************** -SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) +SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt) TYPE(val_type), POINTER :: val INTEGER, INTENT(in) :: unit_nr TYPE(cp_unit_type), OPTIONAL, POINTER :: unit CHARACTER(len=*), INTENT(in), OPTIONAL :: unit_str, fmt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_write', & routineP = moduleN//':'//routineN @@ -566,9 +551,9 @@ SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) IF (PRESENT(fmt)) myfmt = fmt IF (PRESENT(unit)) my_unit => unit IF (ASSOCIATED(my_unit)) THEN - CALL cp_unit_retain(my_unit,error=error) + CALL cp_unit_retain(my_unit) ELSE IF (PRESENT(unit_str)) THEN - CALL cp_unit_create(my_unit,unit_str,error=error) + CALL cp_unit_create(my_unit,unit_str) END IF IF (ASSOCIATED(val)) THEN SELECT CASE(val%type_of_var) @@ -583,7 +568,7 @@ SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) val%l_val(i) END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (integer_t) IF (ASSOCIATED(val%i_val)) THEN @@ -614,7 +599,7 @@ SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) i = i + 1 END DO loop_i ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (real_t) IF (ASSOCIATED(val%r_val)) THEN @@ -624,14 +609,14 @@ SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") END IF IF (ASSOCIATED(my_unit)) THEN - WRITE(rcval,"(ES25.16)")cp_unit_from_cp2k1(val%r_val(i),my_unit,error=error) + WRITE(rcval,"(ES25.16)")cp_unit_from_cp2k1(val%r_val(i),my_unit) ELSE WRITE(rcval,"(ES25.16)")val%r_val(i) END IF WRITE(unit=unit_nr,fmt="(' ',A)",advance="NO")TRIM(rcval) END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (char_t) IF (ASSOCIATED(val%c_val)) THEN @@ -654,7 +639,7 @@ SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) END IF END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (lchar_t) IF (ASSOCIATED(val%c_val)) THEN @@ -666,13 +651,13 @@ SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) WRITE(unit=unit_nr,fmt='(a)',advance="NO") TRIM(val%c_val(SIZE(val%c_val))) END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (enum_t) IF (ASSOCIATED(val%i_val)) THEN l=0 DO i=1,SIZE(val%i_val) - c_string=enum_i2c(val%enum,val%i_val(i),error=error) + c_string=enum_i2c(val%enum,val%i_val(i)) IF (l>10.AND.l+LEN_TRIM(c_string)>76)THEN WRITE(unit=unit_nr,fmt="(' ',A)")default_continuation_character WRITE(unit=unit_nr,fmt="("//TRIM(myfmt)//")",advance="NO") @@ -683,19 +668,19 @@ SUBROUTINE val_write(val,unit_nr,unit,unit_str,fmt,error) WRITE(unit=unit_nr,fmt="(' ',a)",advance="NO") TRIM(c_string) END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE(no_t) WRITE(unit=unit_nr,fmt="(' *empty*')",advance="NO") CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"unexpected type_of_var for val ",error,failure) + routineP,"unexpected type_of_var for val ",failure) END SELECT ELSE WRITE(unit=unit_nr,fmt="(' *null*')",advance="NO") END IF - IF (ASSOCIATED(my_unit)) CALL cp_unit_release(my_unit,error=error) + IF (ASSOCIATED(my_unit)) CALL cp_unit_release(my_unit) WRITE(unit=unit_nr,fmt="()") END SUBROUTINE val_write @@ -704,19 +689,17 @@ END SUBROUTINE val_write !> \param val ... !> \param string ... !> \param unit ... -!> \param error ... !> \date 10.03.2005 !> \par History !> 17.01.2006, MK, Optional argument unit for the conversion to the external unit added !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE val_write_internal(val,string,unit,error) + SUBROUTINE val_write_internal(val,string,unit) TYPE(val_type), POINTER :: val CHARACTER(LEN=*), INTENT(OUT) :: string TYPE(cp_unit_type), OPTIONAL, POINTER :: unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_write_internal', & routineP = moduleN//':'//routineN @@ -741,7 +724,7 @@ SUBROUTINE val_write_internal(val,string,unit,error) WRITE (UNIT=string(2*i-1:),FMT="(L2)") val%l_val(i) END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (integer_t) IF (ASSOCIATED(val%i_val)) THEN @@ -749,16 +732,14 @@ SUBROUTINE val_write_internal(val,string,unit,error) WRITE (UNIT=string(12*i-11:),FMT="(I12)") val%i_val(i) END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (real_t) IF (ASSOCIATED(val%r_val)) THEN IF (PRESENT(unit)) THEN DO i=1,SIZE(val%r_val) value = cp_unit_from_cp2k(value=val%r_val(i),& - unit_str=cp_unit_desc(unit=unit,& - error=error),& - error=error) + unit_str=cp_unit_desc(unit=unit)) WRITE (UNIT=string(16*i-15:),FMT="(ES16.8E3)") value END DO ELSE @@ -767,7 +748,7 @@ SUBROUTINE val_write_internal(val,string,unit,error) END DO END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (char_t) IF (ASSOCIATED(val%c_val)) THEN @@ -777,26 +758,26 @@ SUBROUTINE val_write_internal(val,string,unit,error) ipos = ipos + LEN_TRIM(ADJUSTL(val%c_val(i))) + 1 END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (lchar_t) IF (ASSOCIATED(val%c_val)) THEN - CALL val_get(val,c_val=string,error=error) + CALL val_get(val,c_val=string) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE (enum_t) IF (ASSOCIATED(val%i_val)) THEN DO i=1,SIZE(val%i_val) - enum_string = enum_i2c(val%enum,val%i_val(i),error) + enum_string = enum_i2c(val%enum,val%i_val(i)) WRITE (UNIT=string,FMT="(A)") TRIM(ADJUSTL(enum_string)) END DO ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"unexpected type_of_var for val ",error,& + routineP,"unexpected type_of_var for val ",& failure) END SELECT @@ -808,13 +789,10 @@ END SUBROUTINE val_write_internal !> \brief creates a copy of the given value !> \param val_in the value to copy !> \param val_out the value tha will be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE val_duplicate(val_in,val_out,error) +SUBROUTINE val_duplicate(val_in,val_out) TYPE(val_type), POINTER :: val_in, val_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'val_duplicate', & routineP = moduleN//':'//routineN @@ -823,36 +801,36 @@ SUBROUTINE val_duplicate(val_in,val_out,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(val_in),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(val_out),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(val_in),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(val_out),cp_failure_level,routineP,failure) ALLOCATE(val_out,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_val_id=last_val_id+1 val_out%id_nr=last_val_id val_out%type_of_var=val_in%type_of_var val_out%ref_count=1 val_out%enum => val_in%enum - IF (ASSOCIATED(val_out%enum)) CALL enum_retain(val_out%enum,error=error) + IF (ASSOCIATED(val_out%enum)) CALL enum_retain(val_out%enum) NULLIFY(val_out%l_val,val_out%i_val,val_out%c_val,val_out%r_val) IF (ASSOCIATED(val_in%l_val)) THEN ALLOCATE(val_out%l_val(SIZE(val_in%l_val)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) val_out%l_val=val_in%l_val END IF IF (ASSOCIATED(val_in%i_val)) THEN ALLOCATE(val_out%i_val(SIZE(val_in%i_val)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) val_out%i_val=val_in%i_val END IF IF (ASSOCIATED(val_in%r_val)) THEN ALLOCATE(val_out%r_val(SIZE(val_in%r_val)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) val_out%r_val=val_in%r_val END IF IF (ASSOCIATED(val_in%c_val)) THEN ALLOCATE(val_out%c_val(SIZE(val_in%c_val)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) val_out%c_val=val_in%c_val END IF END SUBROUTINE val_duplicate diff --git a/src/input_cp2k_almo.F b/src/input_cp2k_almo.F index 5038478007..f6e3f54944 100644 --- a/src/input_cp2k_almo.F +++ b/src/input_cp2k_almo.F @@ -47,14 +47,12 @@ MODULE input_cp2k_almo ! ***************************************************************************** !> \brief create the almo scf section !> \param section ... -!> \param error ... !> \par History !> 2011.05 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** -SUBROUTINE create_almo_scf_section(section,error) +SUBROUTINE create_almo_scf_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_almo_scf_section', & routineP = moduleN//':'//routineN @@ -65,22 +63,21 @@ SUBROUTINE create_almo_scf_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"ALMO_SCF",& description="Settings for a class of efficient linear scaling methods based "//& "on absolutely localized orbitals"//& " (ALMOs). ALMO methods are currently restricted to closed-shell molecular systems.",& n_keywords=4, n_subsections=3, repeats=.FALSE.,& - citations=(/Khaliullin2013/),& - error=error) + citations=(/Khaliullin2013/)) NULLIFY (keyword) CALL keyword_create(keyword, name="EPS_FILTER",& description="Threshold for the matrix sparsity filter",& - usage="EPS_FILTER 1.e-6", default_r_val=1.e-7_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_FILTER 1.e-6", default_r_val=1.e-7_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALMO_SCF_GUESS",& description="The method to generate initial ALMOs.",& @@ -91,10 +88,9 @@ SUBROUTINE create_almo_scf_section(section,error) "keywords outside ALMO options. This kind of calculation is expensive "//& "and only recommended if ALMO SCF does not converge from the ATOMIC guess.",& "Superpoisiton of atomic densities."),& - enum_i_vals=(/molecular_guess,atomic_guess/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/molecular_guess,atomic_guess/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALMO_ALGORITHM",& description="Specifies the algorithm to update block-diagonal ALMOs during the SCF procedure.",& @@ -108,10 +104,9 @@ SUBROUTINE create_almo_scf_section(section,error) !"Recommended if large fragments are present.",& "Energy minimization with a PCG algorithm controlled by ALMO_OPTIMIZER_PCG."),& !enum_i_vals=(/almo_scf_diag,almo_scf_dm_sign,almo_scf_pcg/),& - enum_i_vals=(/almo_scf_diag,almo_scf_pcg/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/almo_scf_diag,almo_scf_pcg/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DELOCALIZE_METHOD",& description="Methods to reintroduce electron delocalization, which is excluded "//& @@ -131,49 +126,47 @@ SUBROUTINE create_almo_scf_section(section,error) "Self-consistent treatment of delocalization without spatial restrictions",& "Single excitation correction followed by full SCF procedure, both without spatial restrictions"),& enum_i_vals=(/almo_deloc_none,almo_deloc_xalmo_1diag,almo_deloc_xalmo_x,almo_deloc_xalmo_scf,& - almo_deloc_x,almo_deloc_scf,almo_deloc_x_then_scf/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + almo_deloc_x,almo_deloc_scf,almo_deloc_x_then_scf/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="XALMO_R_CUTOFF_FACTOR",& description="Controls the localization radius of XALMOs: "//& !"r0 = r0_factor*(radius(at1)+radius(at2)) + r0_shift",& "R_cutoff = XALMO_R_CUTOFF_FACTOR*(radius(at1)+radius(at2))",& - usage="XALMO_R_CUTOFF_FACTOR 1.6", default_r_val=1.50_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="XALMO_R_CUTOFF_FACTOR 1.6", default_r_val=1.50_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOCALIZE_EPS_ITER",& ! description="Obsolete and to be deleted: use EPS_ERROR in XALMO_OPTIMIZER_PCG",& - ! usage="DELOCALIZE_EPS_ITER 1.e-5", default_r_val=1.e-5_dp,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="DELOCALIZE_EPS_ITER 1.e-5", default_r_val=1.e-5_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOCALIZE_EPS_LIN_SEARCH",& ! description="Obsolete and to be deleted: use EPS_ERROR_LIN_SEARCH in XALMO_OPTIMIZER_PCG",& - ! usage="DELOCALIZE_EPS_LIN_SEARCH 1.e-6", default_r_val=1.e-7_dp,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="DELOCALIZE_EPS_LIN_SEARCH 1.e-6", default_r_val=1.e-7_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="BLOCKED_MAX_ITER",& ! description="Obsolete and to be deleted: use MAX_ITER in ALMO_OPTIMIZER_DIIS or ALMO_OPTIMIZER_PCG",& - ! usage="BLOCKED_MAX_ITER 200", default_i_val=100,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="BLOCKED_MAX_ITER 200", default_i_val=100) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="BLOCKED_EPS_ITER",& ! description="Obsolete and to be deleted: use EPS_ERROR in ALMO_OPTIMIZER_DIIS or ALMO_OPTIMIZER_PCG",& - ! usage="BLOCKED_EPS_ITER 1.e-5", default_r_val=1.e-5_dp,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="BLOCKED_EPS_ITER 1.e-5", default_r_val=1.e-5_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOCALIZE_MAX_ITER",& ! description="Obsolete and to be deleted: use MAX_ITER in XALMO_OPTIMIZER_PCG",& - ! usage="DELOCALIZE_MAX_ITER 200", default_i_val=100,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="DELOCALIZE_MAX_ITER 200", default_i_val=100) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DOMAIN_LAYOUT_MOS",& ! description="Each electron in the system is constrained to its own delocalization domain."//& @@ -185,10 +178,9 @@ SUBROUTINE create_almo_scf_section(section,error) ! "All electrons of an atom are delocalized over the same domain",& ! "All electrons of a molecule are delocalized over the same domain."//& ! " This is the only implemented option"),& - ! enum_i_vals=(/almo_domain_layout_orbital,almo_domain_layout_atomic,almo_domain_layout_molecular/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! enum_i_vals=(/almo_domain_layout_orbital,almo_domain_layout_atomic,almo_domain_layout_molecular/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DOMAIN_LAYOUT_AOS",& ! description="Atomic orbitals or groups of atomic orbitals represent domains over which electrons "//& @@ -201,10 +193,9 @@ SUBROUTINE create_almo_scf_section(section,error) ! "Molecular subsets represent domains. That is, if a basis function on a molecule is"//& ! " in domain A then all basis functions on this molecule are in domain A. "//& ! "This is the only implemented option"),& - ! enum_i_vals=(/almo_domain_layout_atomic,almo_domain_layout_molecular/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! enum_i_vals=(/almo_domain_layout_atomic,almo_domain_layout_molecular/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="MATRIX_CLUSTERING_MOS",& ! description="Blocks of matrices in the MO basis set are distributed for parallel computations. "//& @@ -214,10 +205,9 @@ SUBROUTINE create_almo_scf_section(section,error) ! enum_c_vals=s2a("ATOMIC", "MOLECULAR"),& ! enum_desc=s2a("Not recommended. ZZZ Maybe used for the PAO-based methods in the future",& ! "All molecular orbitals of a molecule belong to the same block."),& - ! enum_i_vals=(/almo_mat_distr_atomic,almo_mat_distr_molecular/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! enum_i_vals=(/almo_mat_distr_atomic,almo_mat_distr_molecular/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="MATRIX_CLUSTERING_AOS",& ! description="Blocks of matrices in the AO basis set are distributed for parallel computations."//& @@ -229,10 +219,9 @@ SUBROUTINE create_almo_scf_section(section,error) ! "same block. Use only if there are very large molecules in the system. "//& ! "ZZZ Maybe used for the PAO-based methods in the future",& ! "All atomic orbitals of a molecule belong to the same block."),& - ! enum_i_vals=(/almo_mat_distr_atomic,almo_mat_distr_molecular/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! enum_i_vals=(/almo_mat_distr_atomic,almo_mat_distr_molecular/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="CONSTRAINT_TYPE",& ! description="Determines the type of ALMO constraints",& @@ -243,44 +232,43 @@ SUBROUTINE create_almo_scf_section(section,error) ! "MO coefficients are quenched according to the distance criterion",& ! "MO coefficients are quenched according to the AO overlap criterion"),& ! enum_i_vals=(/almo_constraint_block_diagonal,almo_constraint_distance,& - ! almo_constraint_ao_overlap/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! almo_constraint_ao_overlap/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !!CALL keyword_create(keyword, name="OUTER_MAX_SCF_Q",& !! description="Maximum number of the outer loop SCF iterations for optimization of quenched ALMOs",& - !! usage="OUTER_MAX_SCF_Q 10", default_i_val=0,error=error) - !!CALL section_add_keyword(section,keyword,error=error) - !!CALL keyword_release(keyword,error=error) + !! usage="OUTER_MAX_SCF_Q 10", default_i_val=0) + !!CALL section_add_keyword(section,keyword) + !!CALL keyword_release(keyword) !!CALL keyword_create(keyword, name="EPS_USE_PREV_AS_GUESS",& !! description="SCF convergence below which quantities from previous iterations"//& !! " can be used as initial guess for the current iteration.",& - !! usage="EPS_USE_PREV_AS_GUESS 0.01", default_r_val=0.001_dp,error=error) - !!CALL section_add_keyword(section,keyword,error=error) - !!CALL keyword_release(keyword,error=error) + !! usage="EPS_USE_PREV_AS_GUESS 0.01", default_r_val=0.001_dp) + !!CALL section_add_keyword(section,keyword) + !!CALL keyword_release(keyword) !!CALL keyword_create(keyword, name="MIXING_FRACTION",& !! description="Weight of the new KS matrix in the mixing during the SCF procedure.",& - !! usage="MIXING_FRACTION 0.45", default_r_val=0.45_dp,error=error) - !!CALL section_add_keyword(section,keyword,error=error) - !!CALL keyword_release(keyword,error=error) + !! usage="MIXING_FRACTION 0.45", default_r_val=0.45_dp) + !!CALL section_add_keyword(section,keyword) + !!CALL keyword_release(keyword) !!CALL keyword_create(keyword, name="FIXED_MU",& !! description="Fix chemical potential or optimize it to get "//& !! "the correct number of electrons",& !! usage="FIXED_MU .TRUE.", default_l_val=.FALSE.,& - !! lone_keyword_l_val=.TRUE., error=error) - !!CALL section_add_keyword(section,keyword,error=error) - !!CALL keyword_release(keyword,error=error) + !! lone_keyword_l_val=.TRUE.) + !!CALL section_add_keyword(section,keyword) + !!CALL keyword_release(keyword) !!CALL keyword_create(keyword, name="MU",& !! description="Value (or initial guess) for the chemical potential."//& !! " Provide energy between HOMO and LUMO energy.",& - !! usage="MU 0.0", default_r_val=-0.1_dp,error=error) - !!CALL section_add_keyword(section,keyword,error=error) - !!CALL keyword_release(keyword,error=error) + !! usage="MU 0.0", default_r_val=-0.1_dp) + !!CALL section_add_keyword(section,keyword) + !!CALL keyword_release(keyword) !CALL keyword_create(keyword, name="XALMO_ALGORITHM",& ! description="Specifies the algorithm to update ALMOs on eXtended domains (XALMOs).",& @@ -289,10 +277,9 @@ SUBROUTINE create_almo_scf_section(section,error) ! enum_c_vals=s2a("DDIAG", "PCG"),& ! enum_desc=s2a("Domain diagonalization",& ! "Preconditioned conjugate gradient"),& - ! enum_i_vals=(/almo_scf_diag,almo_scf_pcg/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! enum_i_vals=(/almo_scf_diag,almo_scf_pcg/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="QUENCHER_RADIUS_TYPE",& ! description="Determines the type of atomic radii used for imposing the ALMO constraints",& @@ -301,65 +288,59 @@ SUBROUTINE create_almo_scf_section(section,error) ! enum_c_vals=s2a("COVALENT", "VDW"),& ! enum_desc=s2a("Covalent atomic radii",& ! "Van der Waals atomic radii"),& - ! enum_i_vals=(/do_bondparm_covalent,do_bondparm_vdw/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! enum_i_vals=(/do_bondparm_covalent,do_bondparm_vdw/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="QUENCHER_R0_FACTOR",& ! description="Parameter to calculate the inner soft cutoff radius: "//& ! !"r0 = r0_factor*(radius(at1)+radius(at2)) + r0_shift",& ! "r0 = r0_factor*(radius(at1)+radius(at2))",& - ! usage="QUENCHER_R0_FACTOR 1.05", default_r_val=1.05_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="QUENCHER_R0_FACTOR 1.05", default_r_val=1.05_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !!CALL keyword_create(keyword, name="QUENCHER_R0_SHIFT",& !! description="Parameter to calculate the inner soft cutoff radius (in Angstrom): "//& !! "r0 = r0_factor*(radius(at1)+radius(at2)) + r0_shift",& - !! usage="QUENCHER_R0_SHIFT 0.0", default_r_val=0.0_dp,& - !! error=error) - !!CALL section_add_keyword(section,keyword,error=error) - !!CALL keyword_release(keyword,error=error) + !! usage="QUENCHER_R0_SHIFT 0.0", default_r_val=0.0_dp) + !! + !!CALL section_add_keyword(section,keyword) + !!CALL keyword_release(keyword) !CALL keyword_create(keyword, name="QUENCHER_R1_FACTOR",& ! description="Parameter to calculate the outer soft cutoff radius: "//& ! !"r1 = r1_factor*(radius(at1)+radius(at2)) + r1_shift",& ! "r1 = r1_factor*(radius(at1)+radius(at2))",& - ! usage="QUENCHER_R1_FACTOR 1.55", default_r_val=1.55_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="QUENCHER_R1_FACTOR 1.55", default_r_val=1.55_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !!CALL keyword_create(keyword, name="QUENCHER_R1_SHIFT",& !! description="Parameter to calculate the outer soft cutoff radius (in Angstrom): "//& !! "r1 = r1_factor*(radius(at1)+radius(at2)) + r1_shift",& - !! usage="QUENCHER_R1_SHIFT 0.0", default_r_val=0.0_dp,& - !! error=error) - !!CALL section_add_keyword(section,keyword,error=error) - !!CALL keyword_release(keyword,error=error) + !! usage="QUENCHER_R1_SHIFT 0.0", default_r_val=0.0_dp) + !! + !!CALL section_add_keyword(section,keyword) + !!CALL keyword_release(keyword) !CALL keyword_create(keyword, name="QUENCHER_AO_OVERLAP_0",& ! description="Overlap value of the inner soft cutoff",& - ! usage="QUENCHER_AO_OVERLAP_0 1.0E-4", default_r_val=1.0E-4_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="QUENCHER_AO_OVERLAP_0 1.0E-4", default_r_val=1.0E-4_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="QUENCHER_AO_OVERLAP_1",& ! description="Overlap value of the outer soft cutoff",& - ! usage="QUENCHER_AO_OVERLAP_1 1.0E-6", default_r_val=1.0E-6_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="QUENCHER_AO_OVERLAP_1 1.0E-6", default_r_val=1.0E-6_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="ENVELOPE_AMPLITUDE",& ! description="Defines an upper bound on the maximum norm of the MO coefficients",& - ! usage="ENVELOPE_AMPLITUDE 1.0", default_r_val=1.0_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="ENVELOPE_AMPLITUDE 1.0", default_r_val=1.0_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_TENSOR_TYPE",& ! description="Tensor properties of occupied and virtual indices",& @@ -368,10 +349,9 @@ SUBROUTINE create_almo_scf_section(section,error) ! enum_c_vals=s2a("ORTHOGONAL", "BIORTHOGONAL"),& ! enum_desc=s2a("Orthogonalize both occupied and virtual orbitals",& ! "Contravariant virtual (MOs or AOs) and covariant occupied orbitals"),& - ! enum_i_vals=(/tensor_orthogonal,tensor_up_down/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! enum_i_vals=(/tensor_orthogonal,tensor_up_down/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_CONJUGATOR",& ! description="Various methods to compute step directions in the CG algorithm",& @@ -385,37 +365,35 @@ SUBROUTINE create_almo_scf_section(section,error) ! "Dai and Yuan","Hager and Zhang"),& ! enum_i_vals=(/cg_zero,cg_polak_ribiere,cg_fletcher_reeves,& ! cg_hestenes_stiefel,cg_fletcher,cg_liu_storey,& - ! cg_dai_yuan,cg_hager_zhang/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! cg_dai_yuan,cg_hager_zhang/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_MAX_ITER",& ! description="Maximum number of CG iterations to solve Ricatti equations",& - ! usage="DELOC_CAYLEY_MAX_ITER 100",default_i_val=50,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="DELOC_CAYLEY_MAX_ITER 100",default_i_val=50) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_EPS_CONVERGENCE",& ! description="Convergence criterion of the CG algorithm",& - ! usage="DELOC_CAYLEY_EPS_CONVERGENCE 1.e-6", default_r_val=1.e-7_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="DELOC_CAYLEY_EPS_CONVERGENCE 1.e-6", default_r_val=1.e-7_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_VIR_PRECOND",& ! description="Use preconditioner for the virtual subspace",& ! usage="DELOC_CAYLEY_VIR_PRECOND .TRUE.", default_l_val=.TRUE.,& - ! lone_keyword_l_val=.TRUE., error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! lone_keyword_l_val=.TRUE.) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_OCC_PRECOND",& ! description="Use preconditioner for the occupied subspace",& ! usage="DELOC_CAYLEY_OCC_PRECOND .TRUE.", default_l_val=.TRUE.,& - ! lone_keyword_l_val=.TRUE., error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! lone_keyword_l_val=.TRUE.) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_TRUNCATE_VIRTUALS",& ! description="Truncation of the virtual subspace",& @@ -427,90 +405,86 @@ SUBROUTINE create_almo_scf_section(section,error) ! "Number of virtuals is equal to the number of occupied orbitals",& ! "Specify exact number of virtuals per domain with DELOC_VIRT_PER_DOMAIN"),& ! enum_i_vals=(/virt_full,virt_minimal,virt_occ_size,& - ! virt_number/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! virt_number/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_VIRT_PER_DOMAIN",& ! description="Number of virtual orbitals (per domain, atom or molecule) "//& ! "retained to obtain the delocalization correction",& - ! usage="DELOC_VIRT_PER_DOMAIN",default_i_val=-1,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="DELOC_VIRT_PER_DOMAIN",default_i_val=-1) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_USE_OCC_ORBS",& ! description="Use occupied orbitals (as opposed to density matrix) "//& ! "to calculate correction for electron delocalization",& ! usage="DELOC_USE_OCC_ORBS .TRUE.", default_l_val=.TRUE.,& - ! lone_keyword_l_val=.TRUE., error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! lone_keyword_l_val=.TRUE.) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_USE_VIRT_ORBS",& ! description="Use virtual orbitals (as opposed to the 1-P projector) "//& ! "to calculate correction for electron delocalization. Works only if "//& ! "DELOC_USE_OCC_ORBS is set to TRUE",& ! usage="DELOC_CAYLEY_USE_VIRT_ORBS .TRUE.", default_l_val=.FALSE.,& - ! lone_keyword_l_val=.TRUE., error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! lone_keyword_l_val=.TRUE.) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="DELOC_CAYLEY_LINEAR",& ! description="Neglect the quadratic term in the Riccati equations. "//& ! "Equivalent to the first order correction to the occupied orbitals "//& ! "(second order correction to the energy)",& ! usage="DELOC_CAYLEY_LINEAR .FALSE.", default_l_val=.FALSE.,& - ! lone_keyword_l_val=.TRUE., error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! lone_keyword_l_val=.TRUE.) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_OUTER_MAX_ITER",& ! description="Maximum number of outer loop iterations to optimize retained virtual orbitals",& - ! usage="OPT_K_OUTER_MAX_ITER 10",default_i_val=1,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_OUTER_MAX_ITER 10",default_i_val=1) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_MAX_ITER",& ! description="Maximum number of iterations to optimize retained virtual orbitals",& - ! usage="OPT_K_MAX_ITER 100",default_i_val=100,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_MAX_ITER 100",default_i_val=100) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_EPS_CONVERGENCE",& ! description="Convergence criterion of the optimization algorithm",& - ! usage="OPT_K_EPS_CONVERGENCE 1.e-5", default_r_val=1.e-5_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_EPS_CONVERGENCE 1.e-5", default_r_val=1.e-5_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_TRIAL_STEP_SIZE",& ! description="Size of the trial step along the gradient",& - ! usage="OPT_K_TRIAL_STEP_SIZE 0.05", default_r_val=0.05_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_TRIAL_STEP_SIZE 0.05", default_r_val=0.05_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_TRIAL_STEP_SIZE_MULTIPLIER",& ! description="The trial step size is obtained by multiplying the optimal step size "//& ! "from the previous iteration",& - ! usage="OPT_K_TRIAL_STEP_SIZE_multiplier 1.0", default_r_val=1.4_dp,& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_TRIAL_STEP_SIZE_multiplier 1.0", default_r_val=1.4_dp) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_CONJ_ITER_START",& ! description="Iteration for switching from the steepest descent algorithm "//& ! "to conjugate gradient",& - ! usage="OPT_K_CONJ_ITER_START 5",default_i_val=0,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_CONJ_ITER_START 5",default_i_val=0) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_CONJ_ITER_FREQ_RESET",& ! description="Reset frequency of the conjugate gradient direction",& - ! usage="OPT_K_CONJ_ITER_FREQ_RESET 20",default_i_val=1000000,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_CONJ_ITER_FREQ_RESET 20",default_i_val=1000000) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_CONJUGATOR",& ! description="Various methods to compute step directions in the CG algorithm",& @@ -524,43 +498,42 @@ SUBROUTINE create_almo_scf_section(section,error) ! "Dai and Yuan","Hager and Zhang"),& ! enum_i_vals=(/cg_zero,cg_polak_ribiere,cg_fletcher_reeves,& ! cg_hestenes_stiefel,cg_fletcher,cg_liu_storey,& - ! cg_dai_yuan,cg_hager_zhang/),& - ! error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! cg_dai_yuan,cg_hager_zhang/)) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_PREC_ITER_START",& ! description="Start using the preconditioner (approximate preconditioners "//& ! "might not be valid on early iterations)",& - ! usage="OPT_K_PREC_ITER_START 2",default_i_val=0,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_PREC_ITER_START 2",default_i_val=0) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) !CALL keyword_create(keyword, name="OPT_K_PREC_ITER_FREQ_UPDATE",& ! description="Frequency for updating the preconditioner",& - ! usage="OPT_K_PREC_ITER_FREQ_UPDATE 10",default_i_val=1,error=error) - !CALL section_add_keyword(section,keyword,error=error) - !CALL keyword_release(keyword,error=error) + ! usage="OPT_K_PREC_ITER_FREQ_UPDATE 10",default_i_val=1) + !CALL section_add_keyword(section,keyword) + !CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_optimizer_section(subsection,optimizer_block_diagonal_diis,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_optimizer_section(subsection,optimizer_block_diagonal_diis) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_optimizer_section(subsection,optimizer_block_diagonal_pcg,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_optimizer_section(subsection,optimizer_block_diagonal_pcg) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_optimizer_section(subsection,optimizer_xalmo_pcg,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_optimizer_section(subsection,optimizer_xalmo_pcg) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) !NULLIFY(subsection) - !CALL create_almo_eda_section(subsection,error) - !CALL section_add_subsection(section, subsection, error=error) - !CALL section_release(subsection,error=error) + !CALL create_almo_eda_section(subsection) + !CALL section_add_subsection(section, subsection) + !CALL section_release(subsection) END SUBROUTINE create_almo_scf_section @@ -568,15 +541,13 @@ END SUBROUTINE create_almo_scf_section ! ***************************************************************************** !> \brief The ALMO EDA section controls decomposition analysis based on ALMOs !> \param section ... -!> \param error ... !> \par History !> 2014.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** -SUBROUTINE create_almo_eda_section(section,error) +SUBROUTINE create_almo_eda_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_almo_eda_section', & routineP = moduleN//':'//routineN @@ -586,14 +557,13 @@ SUBROUTINE create_almo_eda_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"ALMO_DA",& description="Controls decomposition analysis based on ALMOs and XALMOs. "//& "Not yet fully implemented.",& n_keywords=1, n_subsections=0, repeats=.FALSE.,& - citations=(/Khaliullin2007,Khaliullin2008/),& - error=error) + citations=(/Khaliullin2007,Khaliullin2008/)) NULLIFY (keyword) @@ -609,10 +579,9 @@ SUBROUTINE create_almo_eda_section(section,error) "Be careful interpreting this term for systems with charged fragmetns."),& enum_i_vals=(/almo_frz_none,& ! almo_frz_isolated,& - almo_frz_crystal/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + almo_frz_crystal/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_almo_eda_section @@ -622,17 +591,15 @@ END SUBROUTINE create_almo_eda_section !> to all optimization methods (e.g. target error, number of iterations) !> \param section ... !> \param optimizer_id - allows to adapt the standard section for specific needs -!> \param error ... !> \par History !> 2012.03 created [Rustam Z Khaliullin] !> 2014.10 fully integrated [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** -SUBROUTINE create_optimizer_section(section,optimizer_id,error) +SUBROUTINE create_optimizer_section(section,optimizer_id) TYPE(section_type), POINTER :: section INTEGER, INTENT(IN) :: optimizer_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_optimizer_section', & routineP = moduleN//':'//routineN @@ -643,31 +610,28 @@ SUBROUTINE create_optimizer_section(section,optimizer_id,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) ! choose the name of the section SELECT CASE(optimizer_id) CASE(optimizer_block_diagonal_diis) CALL section_create(section,"ALMO_OPTIMIZER_DIIS",& description="Controls the iterative DIIS-accelerated optimization of block-diagonal ALMOs.",& - n_keywords=3, n_subsections=0, repeats=.FALSE.,& - error=error) + n_keywords=3, n_subsections=0, repeats=.FALSE.) optimizer_type=optimizer_diis CASE(optimizer_block_diagonal_pcg) CALL section_create(section,"ALMO_OPTIMIZER_PCG",& description="Controls the PCG optimization of block-diagonal ALMOs.",& - n_keywords=6, n_subsections=0, repeats=.FALSE.,& - error=error) + n_keywords=6, n_subsections=0, repeats=.FALSE.) optimizer_type=optimizer_pcg CASE(optimizer_xalmo_pcg) CALL section_create(section,"XALMO_OPTIMIZER_PCG",& description="Controls the PCG optimization of extended ALMOs.",& - n_keywords=6, n_subsections=0, repeats=.FALSE.,& - error=error) + n_keywords=6, n_subsections=0, repeats=.FALSE.) optimizer_type=optimizer_pcg CASE DEFAULT - CPErrorMessage(cp_failure_level,routineP,"No default values allowed",error) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"No default values allowed") + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT NULLIFY (keyword) @@ -675,15 +639,15 @@ SUBROUTINE create_optimizer_section(section,optimizer_id,error) ! add common keywords CALL keyword_create(keyword, name="MAX_ITER",& description="Maximum number of iterations",& - usage="MAX_ITER 100", default_i_val=20,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER 100", default_i_val=20) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_ERROR",& description="Target value of the MAX norm of the error",& - usage="EPS_ERROR 1.E-6", default_r_val=1.0E-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_ERROR 1.E-6", default_r_val=1.0E-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! add keywords specific to each type SELECT CASE(optimizer_type) @@ -692,31 +656,31 @@ SUBROUTINE create_optimizer_section(section,optimizer_id,error) CALL keyword_create(keyword, name="N_DIIS",& description="Number of error vectors to be used in the DIIS "//& "optimization procedure",& - usage="N_DIIS 5", default_i_val=6,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_DIIS 5", default_i_val=6) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CASE(optimizer_pcg) CALL keyword_create(keyword, name="LIN_SEARCH_EPS_ERROR",& description="Target value of the gradient norm during the linear search",& - usage="LIN_SEARCH_EPS_ERROR 1.E-2", default_r_val=1.0E-3_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LIN_SEARCH_EPS_ERROR 1.E-2", default_r_val=1.0E-3_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LIN_SEARCH_STEP_SIZE_GUESS",& description="The size of the first step in the linear search",& - usage="LIN_SEARCH_STEP_SIZE_GUESS 0.1", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LIN_SEARCH_STEP_SIZE_GUESS 0.1", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER_OUTER_LOOP",& description="Maximum number of iterations in the outer loop. "//& "Use the outer loop to update the preconditioner and reset the conjugator. "//& "This can speed up convergence significantly.",& - usage="MAX_ITER 10", default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER 10", default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRECONDITIONER",& description="Select a preconditioner for the conjugate gradient optimization",& @@ -724,10 +688,9 @@ SUBROUTINE create_optimizer_section(section,optimizer_id,error) default_i_val=-1,& enum_c_vals=s2a("DEFAULT", "NONE"),& enum_desc=s2a("Default preconditioner","Do not use preconditioner"),& - enum_i_vals=(/prec_default,prec_zero/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/prec_default,prec_zero/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CONJUGATOR",& description="Various methods to compute step directions in the PCG optimization",& @@ -741,10 +704,9 @@ SUBROUTINE create_optimizer_section(section,optimizer_id,error) "Dai and Yuan","Hager and Zhang"),& enum_i_vals=(/cg_zero,cg_polak_ribiere,cg_fletcher_reeves,& cg_hestenes_stiefel,cg_fletcher,cg_liu_storey,& - cg_dai_yuan,cg_hager_zhang/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + cg_dai_yuan,cg_hager_zhang/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SELECT @@ -761,10 +723,9 @@ END SUBROUTINE create_optimizer_section !!!> 2014.10 created [Rustam Z Khaliullin] !!!> \author Rustam Z Khaliullin !!! ***************************************************************************** -!! SUBROUTINE create_developer_section(section,error) +!! SUBROUTINE create_developer_section(section) !! !! TYPE(section_type), POINTER :: section -!! TYPE(cp_error_type), INTENT(inout) :: error !! !! CHARACTER(len=*), PARAMETER :: routineN = 'create_developer_section', & !! routineP = moduleN//':'//routineN @@ -774,15 +735,15 @@ END SUBROUTINE create_optimizer_section !! !! failure=.FALSE. !! -!! CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) +!! CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) !! IF (.NOT. failure) THEN !! !! CALL section_create(section,"DEVELOPER",& !! description="Developer section for all ALMO-based methods. "//& !! "Allows uninterrupted development of the code "//& !! "by keeping untested keywords neatly separated from those publicly available",& -!! n_keywords=3, n_subsections=0, repeats=.FALSE.,& -!! error=error) +!! n_keywords=3, n_subsections=0, repeats=.FALSE.) +!! !! !! NULLIFY (keyword) !! diff --git a/src/input_cp2k_atom.F b/src/input_cp2k_atom.F index 1475dd3929..b4d1ba117a 100644 --- a/src/input_cp2k_atom.F +++ b/src/input_cp2k_atom.F @@ -54,13 +54,10 @@ MODULE input_cp2k_atom ! ***************************************************************************** !> \brief Creates the input section for the atom code !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_atom_section(section,error) + SUBROUTINE create_atom_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atom_section', & routineP = moduleN//':'//routineN @@ -71,25 +68,24 @@ SUBROUTINE create_atom_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ATOM",& description="Section handling input for atomic calculations.",& - n_keywords=1, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="ATOMIC_NUMBER",& description="Specify the atomic number",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ELEMENT",& description="Specify the element to be calculated",& usage="ELEMENT char",n_var=1,type_of_var=char_t,& - default_c_val="H", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="H") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RUN_TYPE",& description="Type of run that you want to perform "//& @@ -101,10 +97,9 @@ SUBROUTINE create_atom_section(section,error) enum_desc=s2a("Perform no run",& "Perform energy optimization",& "Perform basis optimization",& - "Perform pseudopotential optimization"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Perform pseudopotential optimization")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COULOMB_INTEGRALS",& description="Method to calculate Coulomb integrals",& @@ -116,10 +111,9 @@ SUBROUTINE create_atom_section(section,error) enum_i_vals= (/ do_analytic, do_semi_analytic, do_numeric /),& enum_desc=s2a("Use analytical method",& "Use semi-analytical method",& - "Use numerical method"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use numerical method")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCHANGE_INTEGRALS",& description="Method to calculate Exchange integrals",& @@ -131,67 +125,66 @@ SUBROUTINE create_atom_section(section,error) enum_i_vals= (/ do_analytic, do_semi_analytic, do_numeric /),& enum_desc=s2a("Use analytical method",& "Use semi-analytical method",& - "Use numerical method"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use numerical method")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORE",& description="Specifies the core electrons for a pseudopotential",& usage="CORE 1s2 ... or CORE [Ne] or CORE none for 0 electron cores", repeats=.FALSE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ELECTRON_CONFIGURATION",& description="Specifies the electron configuration. "//& "Optional the multiplicity (m) and a core state [XX] can be declared",& usage="ELECTRON_CONFIGURATION (1) [Ne] 3s2 ... ", repeats=.TRUE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ANGULAR_MOMENTUM",& description="Specifies the largest angular momentum calculated [0-3]",& usage="MAX_ANGULAR_MOMENTUM 3", repeats=.FALSE.,& - default_i_val=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CALCULATE_STATES",& description="Specifies the number of states calculated per l value",& usage="CALCULATE_STATES 5 5 5 3 ", repeats=.FALSE.,& - default_i_val=0, n_var=-1,type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0, n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_atom_print_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_atom_print_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_atom_aebasis_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_atom_aebasis_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_atom_ppbasis_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_atom_ppbasis_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_atom_method_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_atom_method_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_optimization_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_optimization_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_potential_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_potential_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_powell_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_powell_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_atom_section @@ -199,13 +192,10 @@ END SUBROUTINE create_atom_section ! ***************************************************************************** !> \brief Create the print atom section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_atom_print_section(section,error) + SUBROUTINE create_atom_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atom_print_section', & routineP = moduleN//':'//routineN @@ -216,149 +206,132 @@ SUBROUTINE create_atom_print_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Section of possible print options specific of the ATOM code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key, keyword) CALL cp_print_key_section_create(print_key,"PROGRAM_BANNER",& description="Controls the printing of the banner of the ATOM program",& - print_level=silent_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=silent_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"METHOD_INFO",& description="Controls the printing of method information",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"BASIS_SET",& description="Controls the printing of the basis sets",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"POTENTIAL",& description="Controls the printing of the potentials",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FIT_DENSITY",& description="Fit the total electronic density to a linear combination of Gaussian functions",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword, name="NUM_GTO",& description="Number of Gaussian type functions for density fit",& usage="NUM_GTO integer ",type_of_var=integer_t,& - default_i_val=40,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_i_val=40) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FIT_KGPOT",& description="Fit an approximation to the non-additive kinetic energy potential used in KG",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword, name="NUM_GAUSSIAN",& description="Number of Gaussian terms for the fit",& usage="NUM_GAUSSIAN integer ",type_of_var=integer_t,& - default_i_val=1,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_POLYNOM",& description="Number of terms in the polynomial expansion",& usage="NUM_POLYNOM integer ",type_of_var=integer_t,& - default_i_val=4,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=4) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESPONSE_BASIS",& description="Calculate a response basis set contraction scheme",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword, name="DELTA_CHARGE",& description="Variation of charge used in finite difference calculation",& usage="DELTA_CHARGE real ",type_of_var=real_t,& - default_r_val=0.05_dp,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.05_dp) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DERIVATIVES",& description="Number of wavefunction derivatives to calculate",& usage="DERIVATIVES integer ",type_of_var=integer_t,& - default_i_val=2,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_i_val=2) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SCF_INFO",& description="Controls the printing of SCF information",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ORBITALS",& description="Controls the printing of the optimized orbitals information",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FIT_PSEUDO",& description="Controls the printing of FIT PSEUDO task",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FIT_BASIS",& description="Controls the printing of FIT BASIS task",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"UPF_FILE",& description="Write GTH pseudopotential in UPF format",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ENERGIES_MINUS_KINETIC",& description="Print out the total energy and orbital energies without " //& "the kinetic energy component. Useful for atomic calculations used" //& "during SCPTB parametrization",& - print_level=debug_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_atom_print_section ! ***************************************************************************** !> \brief Create the all-electron basis section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_atom_aebasis_section(section,error) + SUBROUTINE create_atom_aebasis_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atom_aebasis_section', & routineP = moduleN//':'//routineN @@ -367,26 +340,22 @@ SUBROUTINE create_atom_aebasis_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="AE_BASIS",& description="Section of basis set information for all-electron calculations.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) - CALL atom_basis_section(section,error) + CALL atom_basis_section(section) END SUBROUTINE create_atom_aebasis_section ! ***************************************************************************** !> \brief Create the pseudopotential basis section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_atom_ppbasis_section(section,error) + SUBROUTINE create_atom_ppbasis_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atom_ppbasis_section', & routineP = moduleN//':'//routineN @@ -395,26 +364,22 @@ SUBROUTINE create_atom_ppbasis_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PP_BASIS",& description="Section of basis set information for pseudopotential calculations.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) - CALL atom_basis_section(section,error) + CALL atom_basis_section(section) END SUBROUTINE create_atom_ppbasis_section ! ***************************************************************************** !> \brief Keywords in the atom basis section !> \param section the section to fill -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE atom_basis_section(section,error) + SUBROUTINE atom_basis_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_basis_section', & routineP = moduleN//':'//routineN @@ -425,7 +390,7 @@ SUBROUTINE atom_basis_section(section,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword) CALL keyword_create(keyword, name="BASIS_TYPE",& @@ -442,102 +407,101 @@ SUBROUTINE atom_basis_section(section,error) "Geometrical Gaussian type orbitals",& "Contracted Gaussian type orbitals",& "Slater-type orbitals",& - "Numerical basis type"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Numerical basis type")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_GTO",& description="Number of Gaussian type functions for s, p, d, ...",& usage="NUM_GTO 5 5 5 ",n_var=-1,type_of_var=integer_t,& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_SLATER",& description="Number of Slater type functions for s, p, d, ...",& usage="NUM_SLATER 5 5 5 ",n_var=-1,type_of_var=integer_t,& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="START_INDEX",& description="Starting index for Geometrical Basis sets",& usage="START_INDEX 0 2 5 4 ",n_var=-1,type_of_var=integer_t,& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="S_EXPONENTS",& description="Exponents for s functions",& - usage="S_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="S_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="P_EXPONENTS",& description="Exponents for p functions",& - usage="P_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="P_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D_EXPONENTS",& description="Exponents for d functions",& - usage="D_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="D_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="F_EXPONENTS",& description="Exponents for f functions",& - usage="F_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="F_EXPONENTS 1.0 2.0 ... ",n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="S_QUANTUM_NUMBERS",& description="Main quantum numbers for s functions",& - usage="S_QUANTUM_NUMBERS 1 2 ... ",n_var=-1,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="S_QUANTUM_NUMBERS 1 2 ... ",n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="P_QUANTUM_NUMBERS",& description="Main quantum numbers for p functions",& - usage="P_QUANTUM_NUMBERS 2 3 ... ",n_var=-1,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="P_QUANTUM_NUMBERS 2 3 ... ",n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D_QUANTUM_NUMBERS",& description="Main quantum numbers for d functions",& - usage="D_QUANTUM_NUMBERS 3 4 ... ",n_var=-1,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="D_QUANTUM_NUMBERS 3 4 ... ",n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="F_QUANTUM_NUMBERS",& description="Main quantum numbers for f functions",& - usage="F_QUANTUM_NUMBERS 4 5 ... ",n_var=-1,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="F_QUANTUM_NUMBERS 4 5 ... ",n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GEOMETRICAL_FACTOR",& description="Geometrical basis: factor C in a*C^k",& usage="GEOMETRICAL_FACTOR real",& - default_r_val=2.6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=2.6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GEO_START_VALUE",& description="Geometrical basis: starting value a in a*C^k",& usage="GEO_START_VALUE real",& - default_r_val=0.016_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.016_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIS_SET_FILE_NAME",& description="Name of the basis set file, may include a path",& usage="BASIS_SET_FILE_NAME ",& - default_lc_val="BASIS_SET",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="BASIS_SET") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIS_SET",& variants=s2a("ORBITAL_BASIS_SET","ORB_BASIS"),& description="The contracted Gaussian basis set",& usage="BASIS_SET DZVP", default_c_val=" ", & - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="QUADRATURE",& description="Algorithm to construct the atomic radial grids",& @@ -547,41 +511,38 @@ SUBROUTINE atom_basis_section(section,error) enum_desc=s2a("Gauss-Chebyshev quadrature",& "Transformed Gauss-Chebyshev quadrature",& "Logarithmic transformed Gauss-Chebyshev quadrature"),& - default_i_val=do_gapw_log, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_gapw_log) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GRID_POINTS",& description="Number of radial grid points",& usage="GRID_POINTS integer",& - default_i_val=400,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=400) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_EIGENVALUE",& description="Cutoff of overlap matrix eigenvalues included into basis",& usage="EPS_EIGENVALUE real",& - default_r_val=1.e-12_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.e-12_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_basis_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_basis_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE atom_basis_section ! ***************************************************************************** !> \brief Create the method section for Atom calculations !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_atom_method_section(section,error) + SUBROUTINE create_atom_method_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atom_method_section', & routineP = moduleN//':'//routineN @@ -593,11 +554,10 @@ SUBROUTINE create_atom_method_section(section,error) failure=.FALSE. NULLIFY(subsection,keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="METHOD",& description="Section of information on method to use.",& - n_keywords=0, n_subsections=2, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=2, repeats=.TRUE.) CALL keyword_create(keyword, name="METHOD_TYPE",& description="Type of electronic structure method to be used",& @@ -618,10 +578,9 @@ SUBROUTINE create_atom_method_section(section,error) "Hartree-Fock electronic structure method",& "Restricted Hartree-Fock electronic structure method",& "Unrestricted Hartree-Fock electronic structure method",& - "Restricted open-shell Hartree-Fock electronic structure method"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Restricted open-shell Hartree-Fock electronic structure method")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RELATIVISTIC",& description="Type of scalar relativistic method to be used",& @@ -646,23 +605,22 @@ SUBROUTINE create_atom_method_section(section,error) "Use Douglas-Kroll-Hess Hamiltonian of order 2",& "Use Douglas-Kroll-Hess Hamiltonian of order 3",& "Use Douglas-Kroll-Hess Hamiltonian of order 4",& - "Use Douglas-Kroll-Hess Hamiltonian of order 5"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use Douglas-Kroll-Hess Hamiltonian of order 5")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_xc_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_xc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! ZMP creating zubsection for the zmp calculations - CALL create_zmp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_zmp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_external_vxc(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_external_vxc(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_atom_method_section @@ -670,12 +628,10 @@ END SUBROUTINE create_atom_method_section !> \brief Create the ZMP subsection for Atom calculations !> !> \param section ... -!> \param error ... !> \author D. Varsano [daniele.varsano@nano.cnr.it] ! ***************************************************************************** - SUBROUTINE create_zmp_section(section,error) + SUBROUTINE create_zmp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_zmp_section', & routineP = moduleN//':'//routineN @@ -687,42 +643,39 @@ SUBROUTINE create_zmp_section(section,error) failure=.FALSE. NULLIFY(subsection,keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ZMP",& description="Section used to specify ZMP Potentials.",& - n_keywords=3, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="FILE_DENSITY",& description="Specifies the filename containing the target density ",& usage="FILE_DENSITY ",& - type_of_var=char_t,default_c_val="RHO_O.dat", n_var=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t,default_c_val="RHO_O.dat", n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GRID_TOL",& description="Tolerance in the equivalence of read-grid in ZMP method",& - usage="GRID_TOL ", default_r_val=1.E-12_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GRID_TOL ", default_r_val=1.E-12_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LAMBDA",& description="Parameter used for the constraint in ZMP method",& - usage="LAMBDA ", default_r_val=10.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LAMBDA ", default_r_val=10.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DM",& description="read external density from density matrix",& - usage="DM ", type_of_var=logical_t,default_l_val=.FALSE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DM ", type_of_var=logical_t,default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_zmp_restart_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_zmp_restart_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_zmp_section @@ -730,12 +683,10 @@ END SUBROUTINE create_zmp_section !> \brief Create the ZMP restart subsection for Atom calculations !> !> \param section ... -!> \param error ... !> \author D. Varsano [daniele.varsano@nano.cnr.it] ! ***************************************************************************** - SUBROUTINE create_zmp_restart_section(section,error) + SUBROUTINE create_zmp_restart_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_zmp_restart_section', & routineP = moduleN//':'//routineN @@ -746,20 +697,18 @@ SUBROUTINE create_zmp_restart_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RESTART",& description="Section used to specify the restart option in the ZMP"//& "procedure, and the file that must be read.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="FILE_RESTART",& description="Specifies the filename containing the restart file density ",& usage="FILE_RESTART ",& - type_of_var=char_t,default_c_val="RESTART.wfn", n_var=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t,default_c_val="RESTART.wfn", n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_zmp_restart_section @@ -767,12 +716,10 @@ END SUBROUTINE create_zmp_restart_section !> \brief Subroutine to create the external v_xc potential !> !> \param section ... -!> \param error ... !> \author D. Varsano [daniele.varsano@nano.cnr.it] ! ***************************************************************************** - SUBROUTINE create_external_vxc(section,error) + SUBROUTINE create_external_vxc(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_external_vxc', & routineP = moduleN//':'//routineN @@ -783,38 +730,34 @@ SUBROUTINE create_external_vxc(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EXTERNAL_VXC",& description="Section used to specify exernal VXC Potentials.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="FILE_VXC",& description="Specifies the filename containing the external vxc ",& usage="FILE_VXC ",& - type_of_var=char_t,default_c_val="VXC.dat", n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t,default_c_val="VXC.dat", n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GRID_TOL",& description="Tolerance in the equivalence of read-grid in ZMP method",& - usage="GRID_TOL ", default_r_val=1.E-12_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GRID_TOL ", default_r_val=1.E-12_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_external_vxc ! ***************************************************************************** !> \brief Create the optimization section for Atom calculations !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_optimization_section(section,error) + SUBROUTINE create_optimization_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_optimization_section', & routineP = moduleN//':'//routineN @@ -825,59 +768,50 @@ SUBROUTINE create_optimization_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="OPTIMIZATION",& description="Section of information on optimization thresholds and algorithms.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="MAX_ITER",& description="Maximum number of iterations for optimization",& - usage="MAX_ITER 50", default_i_val=200,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER 50", default_i_val=200) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SCF",& description="Convergence criterion for SCF",& - usage="EPS_SCF 1.e-10", default_r_val=1.e-6_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SCF 1.e-10", default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DAMPING",& description="Damping parameter for extrapolation method",& - usage="DAMPING 0.4", default_r_val=0.4_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DAMPING 0.4", default_r_val=0.4_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_DIIS",& description="Starting DIIS method at convergence to EPS_DIIS",& - usage="EPS_DIIS 0.01", default_r_val=10000._dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_DIIS 0.01", default_r_val=10000._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_DIIS",& description="Maximum number of DIIS vectors",& - usage="N_DIIS 6", default_i_val=5,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_DIIS 6", default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_optimization_section ! ***************************************************************************** !> \brief Create the potential section for Atom calculations !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_potential_section(section,error) + SUBROUTINE create_potential_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_potential_section', & routineP = moduleN//':'//routineN @@ -889,20 +823,18 @@ SUBROUTINE create_potential_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="POTENTIAL",& description="Section of information on potential.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="CONFINEMENT",& description="Definition of confinement potential",& usage="CONFINEMENT prefactor range exponent", & default_r_vals=(/ 0._dp, 4._dp, 2._dp /),& - repeats=.FALSE., n_var=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PSEUDO_TYPE",& description="Pseudopotential type",& @@ -912,43 +844,38 @@ SUBROUTINE create_potential_section(section,error) "GTH "/),& enum_i_vals= (/ no_pseudo, gth_pseudo /),& enum_desc=s2a("Do not use pseudopotentials",& - "Use Goedecker-Teter-Hutter pseudopotentials"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use Goedecker-Teter-Hutter pseudopotentials")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POTENTIAL_FILE_NAME",& description="Name of the pseudo potential file, may include a path",& usage="POTENTIAL_FILE_NAME ",& - default_lc_val="POTENTIAL",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="POTENTIAL") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POTENTIAL_NAME",& variants=(/ "POT_NAME" /),& description="The name of the pseudopotential for the defined kind.",& - usage="POTENTIAL_NAME ", default_c_val=" ", n_var=1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="POTENTIAL_NAME ", default_c_val=" ", n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_gthpotential_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_gthpotential_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_potential_section ! ***************************************************************************** !> \brief Creates the >H_POTENTIAL section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_gthpotential_section(section,error) + SUBROUTINE create_gthpotential_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gthpotential_section', & routineP = moduleN//':'//routineN @@ -960,26 +887,22 @@ SUBROUTINE create_gthpotential_section(section,error) CALL section_create(section,name="GTH_POTENTIAL",& description="Section used to specify Potentials.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="CP2K Pseudo Potential Standard Format (GTH, ALL or KG)",& - repeats=.TRUE.,type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.,type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_gthpotential_section ! ***************************************************************************** !> \brief Creates the &BASIS section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_basis_section(section,error) + SUBROUTINE create_basis_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_basis_section', & routineP = moduleN//':'//routineN @@ -991,26 +914,22 @@ SUBROUTINE create_basis_section(section,error) CALL section_create(section,name="basis",& description="Section used to specify a general basis set for QM calculations.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="CP2K Basis Set Standard Format",repeats=.TRUE.,& - type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_basis_section ! ***************************************************************************** !> \brief Creates the &POWELL section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_powell_section(section,error) + SUBROUTINE create_powell_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_powell_section', & routineP = moduleN//':'//routineN @@ -1022,107 +941,106 @@ SUBROUTINE create_powell_section(section,error) CALL section_create(section,name="powell",& description="Section defines basic parameters for Powell optimization",& - n_keywords=4, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=4, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ACCURACY",& description="Final accuracy requested in optimization (RHOEND)",& usage="ACCURACY 0.00001",& - default_r_val=1.e-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEP_SIZE",& description="Initial step size for search algorithm (RHOBEG)",& usage="STEP_SIZE 0.005",& - default_r_val=0.005_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.005_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_FUN",& description="Maximum number of function evaluations",& usage="MAX_FUN 1000",& - default_i_val=5000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHT_POT_VIRTUAL",& description="Weight for virtual states in pseudopotential optimization",& usage="WEIGHT_POT_VIRTUAL 1.0",& - default_r_val=0.01_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.01_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHT_POT_SEMICORE",& description="Weight for semi core states in pseudopotential optimization",& usage="WEIGHT_POT_SEMICORE 1.0",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHT_POT_VALENCE",& description="Weight for valence states in pseudopotential optimization",& usage="WEIGHT_POT_VALENCE 1.0",& - default_r_val=100.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=100.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHT_POT_NODE",& description="Weight for node mismatch in pseudopotential optimization",& usage="WEIGHT_POT_NODE 1.0",& - default_r_val=1000.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1000.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHT_ELECTRON_CONFIGURATION",& description="Weight for different electronic states in optimization",& usage="WEIGHT_ELECTRON_CONFIGURATION 1.0 0.1 ...",& - n_var=-1,type_of_var=real_t, default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t, default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHT_METHOD",& description="Weight for different methods in optimization",& usage="WEIGHT_METHOD 1.0 0.1 ...",& - n_var=-1,type_of_var=real_t, default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t, default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET_POT_VIRTUAL",& description="Target accuracy for virtual state eigenvalues in pseudopotential optimization",& usage="TARGET_POT_VIRTUAL 0.0001",& - default_r_val=0.001_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET_POT_VALENCE",& description="Target accuracy for valence state eigenvalues in pseudopotential optimization",& usage="TARGET_POT_VALENCE 0.0001",& - default_r_val=0.00001_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.00001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET_POT_SEMICORE",& description="Target accuracy for semicore state eigenvalues in pseudopotential optimization",& usage="TARGET_POT_SEMICORE 0.01",& - default_r_val=0.001_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHT_PSIR0",& description="Weight for the wavefunctions at r=0 (only occupied states)",& usage="WEIGHT_PSIR0 0.01",& - default_r_val=0._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCOV_MULTIPLICATION",& description="Multiply Rcov integration limit for charge conservation",& usage="RCOV_MULTIPLICATION 1.10",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_powell_section diff --git a/src/input_cp2k_atprop.F b/src/input_cp2k_atprop.F index fdd362d878..37877bae63 100644 --- a/src/input_cp2k_atprop.F +++ b/src/input_cp2k_atprop.F @@ -32,13 +32,10 @@ MODULE input_cp2k_atprop ! ***************************************************************************** !> \brief Creates the ATOMIC section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author JHU ! ***************************************************************************** - SUBROUTINE create_atprop_section(section,error) + SUBROUTINE create_atprop_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_atprop_section', & routineP = moduleN//':'//routineN @@ -48,13 +45,12 @@ SUBROUTINE create_atprop_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ATOMIC",& description="Controls the calculation of atomic properties. "//& "Printing is controled by FORCE_EVAL / PRINT / PROGRAM_RUN_INFO",& repeats=.FALSE., & - citations=(/Kikuchi2009/),& - error=error) + citations=(/Kikuchi2009/)) NULLIFY(keyword) @@ -64,10 +60,9 @@ SUBROUTINE create_atprop_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRESSURE",& description="Calculate atomic pressure tensors ",& @@ -75,10 +70,9 @@ SUBROUTINE create_atprop_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_atprop_section diff --git a/src/input_cp2k_binary_restarts.F b/src/input_cp2k_binary_restarts.F index 27ac571cb4..49c3470be9 100644 --- a/src/input_cp2k_binary_restarts.F +++ b/src/input_cp2k_binary_restarts.F @@ -62,21 +62,19 @@ MODULE input_cp2k_binary_restarts !> \param para_env ... !> \param subsys_section ... !> \param binary_file_read ... -!> \param error ... !> \par History !> - Creation (10.02.2011,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE read_binary_coordinates(topology,root_section,para_env,& - subsys_section,binary_file_read,error) + subsys_section,binary_file_read) TYPE(topology_parameters_type) :: topology TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section LOGICAL, INTENT(OUT) :: binary_file_read - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_binary_coordinates', & routineP = moduleN//':'//routineN @@ -94,15 +92,15 @@ SUBROUTINE read_binary_coordinates(topology,root_section,para_env,& NULLIFY (logger) failure = .FALSE. - CPPrecondition(ASSOCIATED(root_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(subsys_section),cp_failure_level,routineP,error,failure) - logger => cp_error_get_logger(error) + CPPrecondition(ASSOCIATED(root_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(subsys_section),cp_failure_level,routineP,failure) + logger => cp_get_default_logger() binary_file_read = .FALSE. CALL section_vals_val_get(root_section,"EXT_RESTART%BINARY_RESTART_FILE_NAME",& - c_val=binary_restart_file_name,error=error) + c_val=binary_restart_file_name) IF (TRIM(ADJUSTL(binary_restart_file_name)) == "") THEN CALL timestop(handle) @@ -110,7 +108,7 @@ SUBROUTINE read_binary_coordinates(topology,root_section,para_env,& END IF iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/XYZ_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") natomkind = 0 natom = 0 @@ -342,21 +340,19 @@ END SUBROUTINE read_binary_coordinates !> \param root_section ... !> \param subsys_section ... !> \param binary_file_read ... -!> \param error ... !> \par History !> - Creation (17.02.2011,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE read_binary_cs_coordinates(prefix,particle_set,root_section,& - subsys_section,binary_file_read,error) + subsys_section,binary_file_read) CHARACTER(LEN=*), INTENT(IN) :: prefix TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(section_vals_type), POINTER :: root_section, subsys_section LOGICAL, INTENT(OUT) :: binary_file_read - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_binary_cs_coordinates', & routineP = moduleN//':'//routineN @@ -378,9 +374,9 @@ SUBROUTINE read_binary_cs_coordinates(prefix,particle_set,root_section,& NULLIFY (logger) failure = .FALSE. - CPPrecondition(ASSOCIATED(root_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(subsys_section),cp_failure_level,routineP,error,failure) - logger => cp_error_get_logger(error) + CPPrecondition(ASSOCIATED(root_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(subsys_section),cp_failure_level,routineP,failure) + logger => cp_get_default_logger() para_env => logger%para_env binary_file_read = .FALSE. @@ -394,7 +390,7 @@ SUBROUTINE read_binary_cs_coordinates(prefix,particle_set,root_section,& END IF CALL section_vals_val_get(root_section,"EXT_RESTART%BINARY_RESTART_FILE_NAME",& - c_val=binary_restart_file_name,error=error) + c_val=binary_restart_file_name) IF (TRIM(ADJUSTL(binary_restart_file_name)) == "") THEN CALL timestop(handle) @@ -402,7 +398,7 @@ SUBROUTINE read_binary_cs_coordinates(prefix,particle_set,root_section,& END IF iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/XYZ_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") section_name = prefix//" COORDINATES" @@ -485,7 +481,7 @@ SUBROUTINE read_binary_cs_coordinates(prefix,particle_set,root_section,& RETURN END IF - CPPrecondition((nparticle > 0),cp_failure_level,routineP,error,failure) + CPPrecondition((nparticle > 0),cp_failure_level,routineP,failure) ALLOCATE (rbuf(3,nparticle),STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -567,14 +563,13 @@ END SUBROUTINE read_binary_cs_coordinates !> \param para_env ... !> \param subsys_section ... !> \param binary_file_read ... -!> \param error ... !> \par History !> - Creation (17.02.2011,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE read_binary_velocities(prefix,particle_set,root_section,para_env,& - subsys_section,binary_file_read,error) + subsys_section,binary_file_read) CHARACTER(LEN=*), INTENT(IN) :: prefix TYPE(particle_type), DIMENSION(:), & @@ -583,7 +578,6 @@ SUBROUTINE read_binary_velocities(prefix,particle_set,root_section,para_env,& TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section LOGICAL, INTENT(OUT) :: binary_file_read - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_binary_velocities', & routineP = moduleN//':'//routineN @@ -603,15 +597,15 @@ SUBROUTINE read_binary_velocities(prefix,particle_set,root_section,para_env,& NULLIFY (logger) failure = .FALSE. - CPPrecondition(ASSOCIATED(root_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(subsys_section),cp_failure_level,routineP,error,failure) - logger => cp_error_get_logger(error) + CPPrecondition(ASSOCIATED(root_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(subsys_section),cp_failure_level,routineP,failure) + logger => cp_get_default_logger() binary_file_read = .FALSE. CALL section_vals_val_get(root_section,"EXT_RESTART%BINARY_RESTART_FILE_NAME",& - c_val=binary_restart_file_name,error=error) + c_val=binary_restart_file_name) IF (TRIM(ADJUSTL(binary_restart_file_name)) == "") THEN CALL timestop(handle) @@ -619,7 +613,7 @@ SUBROUTINE read_binary_velocities(prefix,particle_set,root_section,para_env,& END IF iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/XYZ_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") IF (LEN_TRIM(prefix) == 0) THEN section_name = "VELOCITIES" @@ -769,21 +763,19 @@ END SUBROUTINE read_binary_velocities !> \param binary_restart_file_name ... !> \param restart ... !> \param para_env ... -!> \param error ... !> \par History !> - Creation (28.02.2011,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE read_binary_thermostats_nose(prefix,nhc,binary_restart_file_name,& - restart,para_env,error) + restart,para_env) CHARACTER(LEN=*), INTENT(IN) :: prefix TYPE(lnhc_parameters_type), POINTER :: nhc CHARACTER(LEN=*), INTENT(IN) :: binary_restart_file_name LOGICAL, INTENT(OUT) :: restart TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_binary_thermostats_nose', & routineP = moduleN//':'//routineN @@ -799,12 +791,12 @@ SUBROUTINE read_binary_thermostats_nose(prefix,nhc,binary_restart_file_name,& CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(nhc),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(nhc),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) ! Set to .TRUE. for debug mode, i.e. all data read are written to stdout NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) IF (logger%iter_info%print_level >= debug_print_level) THEN diff --git a/src/input_cp2k_check.F b/src/input_cp2k_check.F index 50e8e1fe3f..ab39385c27 100644 --- a/src/input_cp2k_check.F +++ b/src/input_cp2k_check.F @@ -58,18 +58,15 @@ MODULE input_cp2k_check !> \param input_file the parsed input !> \param para_env ... !> \param output_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> at the moment does nothing ! ***************************************************************************** - SUBROUTINE check_cp2k_input(input_declaration,input_file,para_env,output_unit,error) + SUBROUTINE check_cp2k_input(input_declaration,input_file,para_env,output_unit) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: input_file TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN), OPTIONAL :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'check_cp2k_input', & routineP = moduleN//':'//routineN @@ -83,23 +80,23 @@ SUBROUTINE check_cp2k_input(input_declaration,input_file,para_env,output_unit,er CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(input_file),cp_failure_level,routineP,error,failure) - CPPrecondition(input_file%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(input_file),cp_failure_level,routineP,failure) + CPPrecondition(input_file%ref_count>0,cp_failure_level,routineP,failure) ! ext_restart IF(PRESENT(output_unit)) & - CALL handle_ext_restart(input_declaration, input_file,para_env,output_unit,error) + CALL handle_ext_restart(input_declaration, input_file,para_env,output_unit) ! checks on force_eval section - sections => section_vals_get_subs_vals(input_file,"FORCE_EVAL",error=error) - CALL section_vals_get(sections, n_repetition=nforce_eval, error=error) + sections => section_vals_get_subs_vals(input_file,"FORCE_EVAL") + CALL section_vals_get(sections, n_repetition=nforce_eval) ! multiple force_eval only if present RESPA or MIXED calculation is performed - section2 => section_vals_get_subs_vals(input_file,"MOTION%MD%RESPA",error=error) - CALL section_vals_get(section2,explicit=explicit,error=error) + section2 => section_vals_get_subs_vals(input_file,"MOTION%MD%RESPA") + CALL section_vals_get(section2,explicit=explicit) DO iforce_eval=1,nforce_eval section3 =>section_vals_get_subs_vals(sections,"MIXED",& - i_rep_section=iforce_eval,error=error) - CALL section_vals_get(section3,explicit=explicit_mix,error=error) + i_rep_section=iforce_eval) + CALL section_vals_get(section3,explicit=explicit_mix) IF(explicit_mix)EXIT END DO @@ -107,23 +104,23 @@ SUBROUTINE check_cp2k_input(input_declaration,input_file,para_env,output_unit,er IF((explicit_mix.AND.(nforce_eval==1)).OR.(.NOT.explicit_mix.AND.(nforce_eval>1)))THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Error multiple force_env without RESPA or MIXED, or RESPA with one single "//& - " or MIXED with only two force_env section.",error,failure) + " or MIXED with only two force_env section.",failure) END IF END IF DO iforce_eval = 1,nforce_eval - section => section_vals_get_subs_vals3(sections,"DFT",i_rep_section=iforce_eval,error=error) + section => section_vals_get_subs_vals3(sections,"DFT",i_rep_section=iforce_eval) ! xc: expand and fix default for tddfpt - section1 => section_vals_get_subs_vals(section,"XC",error=error) - section2 => section_vals_get_subs_vals(section,"XC%XC_FUNCTIONAL",error=error) - CALL xc_functionals_expand(section2,section1,error=error) - section1 => section_vals_get_subs_vals(section,"TDDFPT%XC",error=error) - section2 => section_vals_get_subs_vals(section,"TDDFPT%XC%XC_FUNCTIONAL",error=error) - CALL section_vals_get(section2,explicit=explicit,error=error) + section1 => section_vals_get_subs_vals(section,"XC") + section2 => section_vals_get_subs_vals(section,"XC%XC_FUNCTIONAL") + CALL xc_functionals_expand(section2,section1) + section1 => section_vals_get_subs_vals(section,"TDDFPT%XC") + section2 => section_vals_get_subs_vals(section,"TDDFPT%XC%XC_FUNCTIONAL") + CALL section_vals_get(section2,explicit=explicit) IF (explicit) THEN - CALL xc_functionals_expand(section2,section1,error=error) + CALL xc_functionals_expand(section2,section1) ELSE - section2 => section_vals_get_subs_vals(section,"XC%XC_FUNCTIONAL",error=error) - CALL section_vals_set_subs_vals(section,"TDDFPT%XC%XC_FUNCTIONAL",section2,error=error) + section2 => section_vals_get_subs_vals(section,"XC%XC_FUNCTIONAL") + CALL section_vals_set_subs_vals(section,"TDDFPT%XC%XC_FUNCTIONAL",section2) END IF END DO @@ -134,13 +131,10 @@ END SUBROUTINE check_cp2k_input !> \brief expand a shortcutted functional section !> \param functionals the functional section to expand !> \param xc_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE xc_functionals_expand(functionals,xc_section,error) + SUBROUTINE xc_functionals_expand(functionals,xc_section) TYPE(section_vals_type), POINTER :: functionals, xc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_functionals_expand', & routineP = moduleN//':'//routineN @@ -151,127 +145,127 @@ SUBROUTINE xc_functionals_expand(functionals,xc_section,error) failure=.FALSE. CALL section_vals_val_get(functionals,"_SECTION_PARAMETERS_",& - i_val=shortcut,error=error) + i_val=shortcut) SELECT CASE(shortcut) CASE(xc_funct_no_shortcut, xc_none) ! nothing to expand CASE(xc_funct_pbe0) CALL section_vals_val_set(functionals,"PBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"PBE%SCALE_X",& - r_val=0.75_dp,error=error) + r_val=0.75_dp) CALL section_vals_val_set(functionals,"PBE%SCALE_C",& - r_val=1.0_dp,error=error) + r_val=1.0_dp) ! Hartree Fock Exact Exchange CALL section_vals_val_set(xc_section,"HF%FRACTION",& - r_val=0.25_dp,error=error) + r_val=0.25_dp) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_beefvdw) CALL section_vals_val_set(functionals,"PBE%_SECTION_PARAMETERS_",& !40% PBEc - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"PBE%SCALE_C",& - r_val=0.3998335231_dp,error=error) + r_val=0.3998335231_dp) CALL section_vals_val_set(functionals,"PBE%SCALE_X",& !no PBEx - r_val=0.0000000000_dp,error=error) + r_val=0.0000000000_dp) !PW92 correlation functional from libxc is required. !The cp2k-native PW92 gives disagreeing results (in the 0.01E_H !decimal) and yields inconsistent forces in a DEBUG run. !(rk, 6.3.2014) CALL section_vals_val_set(functionals,"LIBXC%_SECTION_PARAMETERS_",& !60%LDA - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"LIBXC%FUNCTIONAL",& - c_val="LDA_C_PW",error=error) + c_val="LDA_C_PW") CALL section_vals_val_set(functionals,"LIBXC%SCALE",& - r_val=0.6001664769_dp,error=error) + r_val=0.6001664769_dp) CALL section_vals_val_set(functionals,"BEEF%_SECTION_PARAMETERS_",& !BEEF exchange - l_val=.TRUE.,error=error) + l_val=.TRUE.) !NONLOCAL, LMKLL. CALL section_vals_val_set(xc_section,"VDW_POTENTIAL%DISPERSION_FUNCTIONAL",& - i_val=xc_vdw_fun_nonloc,error=error) + i_val=xc_vdw_fun_nonloc) CALL section_vals_val_set(xc_section,"VDW_POTENTIAL%NON_LOCAL%TYPE",& - i_val=vdw_nl_LMKLL,error=error) + i_val=vdw_nl_LMKLL) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_b3lyp) CALL section_vals_val_set(functionals,"BECKE88%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"BECKE88%SCALE_X",& - r_val=0.72_dp,error=error) + r_val=0.72_dp) CALL section_vals_val_set(functionals,"LYP%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"LYP%SCALE_C",& - r_val=0.81_dp,error=error) + r_val=0.81_dp) CALL section_vals_val_set(functionals,"VWN%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"VWN%FUNCTIONAL_TYPE",& - i_val=do_vwn5,error=error) + i_val=do_vwn5) CALL section_vals_val_set(functionals,"VWN%SCALE_C",& - r_val=0.19_dp,error=error) + r_val=0.19_dp) CALL section_vals_val_set(functionals,"XALPHA%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"XALPHA%SCALE_X",& - r_val=0.08_dp,error=error) + r_val=0.08_dp) ! Hartree Fock Exact Exchange CALL section_vals_val_set(xc_section,"HF%FRACTION",& - r_val=0.20_dp,error=error) + r_val=0.20_dp) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_blyp) CALL section_vals_val_set(functionals,"BECKE88%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"LYP%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_bp) CALL section_vals_val_set(functionals,"BECKE88%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"P86C%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_pade) CALL section_vals_val_set(functionals,"PADE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_pbe) CALL section_vals_val_set(functionals,"PBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_xwpbe) CALL section_vals_val_set(functionals,"XWPBE%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_tpss) CALL section_vals_val_set(functionals,"TPSS%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_olyp) CALL section_vals_val_set(functionals,"OPTX%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"LYP%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE(xc_funct_hcth120) CALL section_vals_val_set(functionals,"HCTH%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_val_set(functionals,"HCTH%PARAMETER_SET",& - i_val=120,error=error) + i_val=120) CALL section_vals_val_set(functionals,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown shortcut "//TRIM(ADJUSTL(cp_to_string(shortcut))),& - error,failure) + failure) END SELECT END SUBROUTINE xc_functionals_expand @@ -282,16 +276,13 @@ END SUBROUTINE xc_functionals_expand !> \param input_file the input file to initialize !> \param para_env ... !> \param output_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE handle_ext_restart(input_declaration, input_file,para_env,output_unit,error) + SUBROUTINE handle_ext_restart(input_declaration, input_file,para_env,output_unit) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: input_file TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'handle_ext_restart', & routineP = moduleN//':'//routineN @@ -325,112 +316,109 @@ SUBROUTINE handle_ext_restart(input_declaration, input_file,para_env,output_unit failure=.FALSE. IF (.NOT. failure) THEN ! Handle restart file - r_section => section_vals_get_subs_vals(input_file, "EXT_RESTART",error=error) - CALL section_vals_val_get(r_section,"RESTART_FILE_NAME", c_val=r_file_path, error=error) - CALL section_vals_val_get(r_section,"BINARY_RESTART_FILE_NAME",c_val=binary_restart_file,& - error=error) + r_section => section_vals_get_subs_vals(input_file, "EXT_RESTART") + CALL section_vals_val_get(r_section,"RESTART_FILE_NAME", c_val=r_file_path) + CALL section_vals_val_get(r_section,"BINARY_RESTART_FILE_NAME",c_val=binary_restart_file) IF (r_file_path/=" ") THEN ! parse the input NULLIFY(default_units,restart_file) - CALL section_vals_create(restart_file,input_declaration, error=error) + CALL section_vals_create(restart_file,input_declaration) NULLIFY(cpparser) - CALL parser_create(cpparser,file_name=r_file_path,para_env=para_env,error=error) - CALL cp_unit_set_create(default_units, "OUTPUT",error=error) + CALL parser_create(cpparser,file_name=r_file_path,para_env=para_env) + CALL cp_unit_set_create(default_units, "OUTPUT") CALL section_vals_parse(restart_file,cpparser,root_section=.FALSE.,& - default_units=default_units,error=error) - CALL cp_unit_set_release(default_units,error=error) - CALL parser_release(cpparser,error=error) + default_units=default_units) + CALL cp_unit_set_release(default_units) + CALL parser_release(cpparser) ! Restart and input files same number of force_env sections - sections1 => section_vals_get_subs_vals(restart_file,"FORCE_EVAL",error=error) - CALL section_vals_get(sections1, n_repetition=nforce_eval1, error=error) - sections2 => section_vals_get_subs_vals(input_file,"FORCE_EVAL",error=error) - CALL section_vals_get(sections2, n_repetition=nforce_eval2, error=error) + sections1 => section_vals_get_subs_vals(restart_file,"FORCE_EVAL") + CALL section_vals_get(sections1, n_repetition=nforce_eval1) + sections2 => section_vals_get_subs_vals(input_file,"FORCE_EVAL") + CALL section_vals_get(sections2, n_repetition=nforce_eval2) IF (nforce_eval1/=nforce_eval2) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Restart and input file MUST have the number of force_env sections",& - error,failure) + failure) END IF ! Handle default restarts - CALL handle_defaults_restart(r_section, error=error) + CALL handle_defaults_restart(r_section) ! Real restart of force_evals DO iforce_eval = 1, nforce_eval1 section1 => section_vals_get_subs_vals3(sections1,"SUBSYS",& - i_rep_section=iforce_eval,error=error) + i_rep_section=iforce_eval) section2 => section_vals_get_subs_vals3(sections2,"SUBSYS",& - i_rep_section=iforce_eval,error=error) + i_rep_section=iforce_eval) ! Some care needs to be handled when treating multiple force_eval ! Both subsys need to be consistently associated or not ! Mixed stuff will be rejected for safety reason.. subsys_check = (ASSOCIATED(section1).EQV.ASSOCIATED(section2)) IF (subsys_check) THEN IF (ASSOCIATED(section1)) THEN - CALL section_vals_val_get(r_section,"RESTART_CELL",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_CELL",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"CELL",error=error) - CALL section_vals_set_subs_vals(section2,"CELL",section,error=error) - CALL set_restart_info("CELL",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"CELL") + CALL section_vals_set_subs_vals(section2,"CELL",section) + CALL set_restart_info("CELL",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_POS",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_POS",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"COORD",error=error) - CALL section_vals_set_subs_vals(section2,"COORD",section,error=error) - CALL set_restart_info("COORDINATES",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"COORD") + CALL section_vals_set_subs_vals(section2,"COORD",section) + CALL set_restart_info("COORDINATES",restarted_infos) ! Copy over also the information on the multiple_unit_cell - CALL section_vals_val_get(section1,"TOPOLOGY%MULTIPLE_UNIT_CELL",i_vals=ivec,& - error=error) + CALL section_vals_val_get(section1,"TOPOLOGY%MULTIPLE_UNIT_CELL",i_vals=ivec) ALLOCATE(iwork(3),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) iwork=ivec - CALL section_vals_val_set(section2,"TOPOLOGY%MULTIPLE_UNIT_CELL",i_vals_ptr=iwork,& - error=error) + CALL section_vals_val_set(section2,"TOPOLOGY%MULTIPLE_UNIT_CELL",i_vals_ptr=iwork) END IF - CALL section_vals_val_get(r_section,"RESTART_RANDOMG",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_RANDOMG",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"RNG_INIT",error=error) - CALL section_vals_set_subs_vals(section2,"RNG_INIT",section,error=error) - CALL set_restart_info("RANDOM NUMBER GENERATOR",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"RNG_INIT") + CALL section_vals_set_subs_vals(section2,"RNG_INIT",section) + CALL set_restart_info("RANDOM NUMBER GENERATOR",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_VEL",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_VEL",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"VELOCITY",error=error) - CALL section_vals_set_subs_vals(section2,"VELOCITY",section,error=error) - CALL set_restart_info("VELOCITIES",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"VELOCITY") + CALL section_vals_set_subs_vals(section2,"VELOCITY",section) + CALL set_restart_info("VELOCITIES",restarted_infos) END IF ! Core-Shell information "restarted" only when strictly necessary - CALL section_vals_val_get(r_section,"RESTART_SHELL_POS",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_SHELL_POS",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"SHELL_COORD",error=error) - CALL section_vals_set_subs_vals(section2,"SHELL_COORD",section,error=error) - IF (check_restart(section1, section2, "SHELL_COORD",error)) & - CALL set_restart_info("SHELL COORDINATES",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"SHELL_COORD") + CALL section_vals_set_subs_vals(section2,"SHELL_COORD",section) + IF (check_restart(section1, section2, "SHELL_COORD")) & + CALL set_restart_info("SHELL COORDINATES",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_CORE_POS",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_CORE_POS",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"CORE_COORD",error=error) - CALL section_vals_set_subs_vals(section2,"CORE_COORD",section,error=error) - IF (check_restart(section1, section2, "CORE_COORD",error)) & - CALL set_restart_info("CORE COORDINATES",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"CORE_COORD") + CALL section_vals_set_subs_vals(section2,"CORE_COORD",section) + IF (check_restart(section1, section2, "CORE_COORD")) & + CALL set_restart_info("CORE COORDINATES",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_SHELL_VELOCITY",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_SHELL_VELOCITY",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"SHELL_VELOCITY",error=error) - CALL section_vals_set_subs_vals(section2,"SHELL_VELOCITY",section,error=error) - IF (check_restart(section1, section2, "SHELL_VELOCITY",error)) & - CALL set_restart_info("SHELL VELOCITIES",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"SHELL_VELOCITY") + CALL section_vals_set_subs_vals(section2,"SHELL_VELOCITY",section) + IF (check_restart(section1, section2, "SHELL_VELOCITY")) & + CALL set_restart_info("SHELL VELOCITIES",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_CORE_VELOCITY",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_CORE_VELOCITY",l_val=flag) IF (flag) THEN - section => section_vals_get_subs_vals(section1,"CORE_VELOCITY",error=error) - CALL section_vals_set_subs_vals(section2,"CORE_VELOCITY",section,error=error) - IF (check_restart(section1, section2, "CORE_VELOCITY",error)) & - CALL set_restart_info("CORE VELOCITIES",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"CORE_VELOCITY") + CALL section_vals_set_subs_vals(section2,"CORE_VELOCITY",section) + IF (check_restart(section1, section2, "CORE_VELOCITY")) & + CALL set_restart_info("CORE VELOCITIES",restarted_infos) END IF END IF ELSE @@ -438,355 +426,355 @@ SUBROUTINE handle_ext_restart(input_declaration, input_file,para_env,output_unit routineP,"Error while reading the restart file. Two force_eval have incompatible"//& " subsys.One of them has an allocated subsys while the other has not! Check your"//& " input file or whether the restart file is compatible with the input!",& - error,failure) + failure) END IF ! QMMM restarts - CALL section_vals_val_get(r_section,"RESTART_QMMM",l_val=flag,error=error) - section1 => section_vals_get_subs_vals3(sections1,"QMMM",i_rep_section=iforce_eval,error=error) - section2 => section_vals_get_subs_vals3(sections2,"QMMM",i_rep_section=iforce_eval,error=error) - CALL section_vals_get(section1,explicit=explicit1,error=error) - CALL section_vals_get(section2,explicit=explicit2,error=error) + CALL section_vals_val_get(r_section,"RESTART_QMMM",l_val=flag) + section1 => section_vals_get_subs_vals3(sections1,"QMMM",i_rep_section=iforce_eval) + section2 => section_vals_get_subs_vals3(sections2,"QMMM",i_rep_section=iforce_eval) + CALL section_vals_get(section1,explicit=explicit1) + CALL section_vals_get(section2,explicit=explicit2) qmmm_check = (explicit1.AND.explicit2) IF (flag.AND.qmmm_check) THEN - CALL set_restart_info("QMMM TRANSLATION VECTOR",restarted_infos,error) - CALL section_vals_val_get(section1,"INITIAL_TRANSLATION_VECTOR",r_vals=vec,error=error) + CALL set_restart_info("QMMM TRANSLATION VECTOR",restarted_infos) + CALL section_vals_val_get(section1,"INITIAL_TRANSLATION_VECTOR",r_vals=vec) ALLOCATE(work(3),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) work = vec - CALL section_vals_val_set(section2,"INITIAL_TRANSLATION_VECTOR",r_vals_ptr=work,error=error) + CALL section_vals_val_set(section2,"INITIAL_TRANSLATION_VECTOR",r_vals_ptr=work) END IF ! BSSE restarts - CALL section_vals_val_get(r_section,"RESTART_BSSE",l_val=flag,error=error) - section1 => section_vals_get_subs_vals3(sections1,"BSSE",i_rep_section=iforce_eval,error=error) - section2 => section_vals_get_subs_vals3(sections2,"BSSE",i_rep_section=iforce_eval,error=error) - CALL section_vals_get(section1,explicit=explicit1,error=error) - CALL section_vals_get(section2,explicit=explicit2,error=error) + CALL section_vals_val_get(r_section,"RESTART_BSSE",l_val=flag) + section1 => section_vals_get_subs_vals3(sections1,"BSSE",i_rep_section=iforce_eval) + section2 => section_vals_get_subs_vals3(sections2,"BSSE",i_rep_section=iforce_eval) + CALL section_vals_get(section1,explicit=explicit1) + CALL section_vals_get(section2,explicit=explicit2) bsse_check = (explicit1.AND.explicit2) IF (flag.AND.bsse_check) THEN - section => section_vals_get_subs_vals(section1,"FRAGMENT_ENERGIES",error=error) - CALL section_vals_set_subs_vals(section2,"FRAGMENT_ENERGIES",section,error=error) - CALL set_restart_info("BSSE FRAGMENT ENERGIES",restarted_infos,error) + section => section_vals_get_subs_vals(section1,"FRAGMENT_ENERGIES") + CALL section_vals_set_subs_vals(section2,"FRAGMENT_ENERGIES",section) + CALL set_restart_info("BSSE FRAGMENT ENERGIES",restarted_infos) END IF END DO - CALL section_vals_val_get(r_section,"RESTART_COUNTERS",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_COUNTERS",l_val=flag) IF (flag) THEN - IF (check_restart(input_file, restart_file, "MOTION%MD",error)) THEN - CALL section_vals_val_get(restart_file,"MOTION%MD%STEP_START_VAL",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%MD%STEP_START_VAL",i_val=myi,error=error) - CALL section_vals_val_get(restart_file,"MOTION%MD%TIME_START_VAL",r_val=myt,error=error) - CALL section_vals_val_set(input_file,"MOTION%MD%TIME_START_VAL",r_val=myt,error=error) - CALL section_vals_val_get(restart_file,"MOTION%MD%ECONS_START_VAL",r_val=myt,error=error) - CALL section_vals_val_set(input_file,"MOTION%MD%ECONS_START_VAL",r_val=myt,error=error) - CALL set_restart_info("MD COUNTERS",restarted_infos,error) + IF (check_restart(input_file, restart_file, "MOTION%MD")) THEN + CALL section_vals_val_get(restart_file,"MOTION%MD%STEP_START_VAL",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%MD%STEP_START_VAL",i_val=myi) + CALL section_vals_val_get(restart_file,"MOTION%MD%TIME_START_VAL",r_val=myt) + CALL section_vals_val_set(input_file,"MOTION%MD%TIME_START_VAL",r_val=myt) + CALL section_vals_val_get(restart_file,"MOTION%MD%ECONS_START_VAL",r_val=myt) + CALL section_vals_val_set(input_file,"MOTION%MD%ECONS_START_VAL",r_val=myt) + CALL set_restart_info("MD COUNTERS",restarted_infos) END IF ! - IF (check_restart(input_file, restart_file, "MOTION%GEO_OPT",error)) THEN + IF (check_restart(input_file, restart_file, "MOTION%GEO_OPT")) THEN ! GEO_OPT - CALL section_vals_val_get(restart_file,"MOTION%GEO_OPT%STEP_START_VAL",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%GEO_OPT%STEP_START_VAL",i_val=myi,error=error) - CALL set_restart_info("GEO_OPT COUNTERS",restarted_infos,error) + CALL section_vals_val_get(restart_file,"MOTION%GEO_OPT%STEP_START_VAL",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%GEO_OPT%STEP_START_VAL",i_val=myi) + CALL set_restart_info("GEO_OPT COUNTERS",restarted_infos) ! ROT_OPT - IF (check_restart(input_file, restart_file, "MOTION%GEO_OPT%TRANSITION_STATE%DIMER%ROT_OPT",error)) THEN + IF (check_restart(input_file, restart_file, "MOTION%GEO_OPT%TRANSITION_STATE%DIMER%ROT_OPT")) THEN CALL section_vals_val_get(restart_file,"MOTION%GEO_OPT%TRANSITION_STATE%DIMER%ROT_OPT%STEP_START_VAL",& - i_val=myi,error=error) + i_val=myi) CALL section_vals_val_set(input_file,"MOTION%GEO_OPT%TRANSITION_STATE%DIMER%ROT_OPT%STEP_START_VAL",& - i_val=myi,error=error) - CALL set_restart_info("ROT_OPT COUNTERS",restarted_infos,error) + i_val=myi) + CALL set_restart_info("ROT_OPT COUNTERS",restarted_infos) END IF END IF ! - IF (check_restart(input_file, restart_file, "MOTION%GEO_OPT",error)) THEN + IF (check_restart(input_file, restart_file, "MOTION%GEO_OPT")) THEN ! CELL_OPT - CALL section_vals_val_get(restart_file,"MOTION%CELL_OPT%STEP_START_VAL",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%CELL_OPT%STEP_START_VAL",i_val=myi,error=error) - CALL set_restart_info("CELL_OPT COUNTERS",restarted_infos,error) + CALL section_vals_val_get(restart_file,"MOTION%CELL_OPT%STEP_START_VAL",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%CELL_OPT%STEP_START_VAL",i_val=myi) + CALL set_restart_info("CELL_OPT COUNTERS",restarted_infos) END IF ! - IF (check_restart(input_file, restart_file, "OPTIMIZE_INPUT",error)) THEN - CALL section_vals_val_get(restart_file,"OPTIMIZE_INPUT%ITER_START_VAL",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"OPTIMIZE_INPUT%ITER_START_VAL",i_val=myi,error=error) - CALL set_restart_info("OPTIMIZE_INPUT ITERATION NUMBER",restarted_infos,error) + IF (check_restart(input_file, restart_file, "OPTIMIZE_INPUT")) THEN + CALL section_vals_val_get(restart_file,"OPTIMIZE_INPUT%ITER_START_VAL",i_val=myi) + CALL section_vals_val_set(input_file,"OPTIMIZE_INPUT%ITER_START_VAL",i_val=myi) + CALL set_restart_info("OPTIMIZE_INPUT ITERATION NUMBER",restarted_infos) END IF ! - IF (check_restart(input_file, restart_file, "MOTION%PINT",error)) THEN + IF (check_restart(input_file, restart_file, "MOTION%PINT")) THEN ! PINT - CALL section_vals_val_get(restart_file,"MOTION%PINT%ITERATION",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%PINT%ITERATION",i_val=myi,error=error) - CALL set_restart_info("PINT ITERATION NUMBER",restarted_infos,error) + CALL section_vals_val_get(restart_file,"MOTION%PINT%ITERATION",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%PINT%ITERATION",i_val=myi) + CALL set_restart_info("PINT ITERATION NUMBER",restarted_infos) END IF ! - CALL section_vals_val_get(r_section,"RESTART_METADYNAMICS",l_val=flag2,error=error) - IF (flag2.AND.check_restart(input_file, restart_file, "MOTION%FREE_ENERGY%METADYN",error)) THEN + CALL section_vals_val_get(r_section,"RESTART_METADYNAMICS",l_val=flag2) + IF (flag2.AND.check_restart(input_file, restart_file, "MOTION%FREE_ENERGY%METADYN")) THEN CALL section_vals_val_get(restart_file,& - "MOTION%FREE_ENERGY%METADYN%STEP_START_VAL",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%STEP_START_VAL",i_val=myi) CALL section_vals_val_set(input_file,& - "MOTION%FREE_ENERGY%METADYN%STEP_START_VAL",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%STEP_START_VAL",i_val=myi) CALL section_vals_val_get(restart_file,& - "MOTION%FREE_ENERGY%METADYN%NHILLS_START_VAL",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%NHILLS_START_VAL",i_val=myi) CALL section_vals_val_set(input_file,& - "MOTION%FREE_ENERGY%METADYN%NHILLS_START_VAL",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%NHILLS_START_VAL",i_val=myi) !RG Adaptive hills CALL section_vals_val_get(restart_file,& - "MOTION%FREE_ENERGY%METADYN%OLD_HILL_NUMBER",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%OLD_HILL_NUMBER",i_val=myi) CALL section_vals_val_set(input_file,& - "MOTION%FREE_ENERGY%METADYN%OLD_HILL_NUMBER",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%OLD_HILL_NUMBER",i_val=myi) CALL section_vals_val_get(restart_file,& - "MOTION%FREE_ENERGY%METADYN%OLD_HILL_STEP",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%OLD_HILL_STEP",i_val=myi) CALL section_vals_val_set(input_file,& - "MOTION%FREE_ENERGY%METADYN%OLD_HILL_STEP",i_val=myi,error=error) + "MOTION%FREE_ENERGY%METADYN%OLD_HILL_STEP",i_val=myi) !RG Adaptive hills - CALL set_restart_info("METADYNAMIC COUNTERS",restarted_infos,error) + CALL set_restart_info("METADYNAMIC COUNTERS",restarted_infos) END IF END IF - CALL section_vals_val_get(r_section,"RESTART_AVERAGES",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_AVERAGES",l_val=flag) IF (flag) THEN - IF (check_restart(input_file, restart_file, "MOTION%MD",error)) THEN - rep_sections => section_vals_get_subs_vals(restart_file,"MOTION%MD%AVERAGES%RESTART_AVERAGES",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%MD%AVERAGES%RESTART_AVERAGES",rep_sections,error=error) - CALL set_restart_info("MD AVERAGES",restarted_infos,error) + IF (check_restart(input_file, restart_file, "MOTION%MD")) THEN + rep_sections => section_vals_get_subs_vals(restart_file,"MOTION%MD%AVERAGES%RESTART_AVERAGES") + CALL section_vals_set_subs_vals(input_file,"MOTION%MD%AVERAGES%RESTART_AVERAGES",rep_sections) + CALL set_restart_info("MD AVERAGES",restarted_infos) END IF END IF - CALL section_vals_val_get(r_section,"RESTART_BAND",l_val=flag,error=error) - IF (flag.AND.check_restart(input_file, restart_file, "MOTION%BAND",error)) THEN - rep_sections => section_vals_get_subs_vals(restart_file,"MOTION%BAND%REPLICA",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%BAND%REPLICA",rep_sections,error=error) - CALL set_restart_info("BAND CALCULATION",restarted_infos,error) + CALL section_vals_val_get(r_section,"RESTART_BAND",l_val=flag) + IF (flag.AND.check_restart(input_file, restart_file, "MOTION%BAND")) THEN + rep_sections => section_vals_get_subs_vals(restart_file,"MOTION%BAND%REPLICA") + CALL section_vals_set_subs_vals(input_file,"MOTION%BAND%REPLICA",rep_sections) + CALL set_restart_info("BAND CALCULATION",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_OPTIMIZE_INPUT_VARIABLES",l_val=flag,error=error) - IF (flag.AND.check_restart(input_file, restart_file, "OPTIMIZE_INPUT%VARIABLE",error)) THEN - rep_sections => section_vals_get_subs_vals(restart_file,"OPTIMIZE_INPUT%VARIABLE",error=error) - CALL section_vals_set_subs_vals(input_file,"OPTIMIZE_INPUT%VARIABLE",rep_sections,error=error) - CALL set_restart_info("OPTIMIZE_INPUT: VARIABLES",restarted_infos,error) + CALL section_vals_val_get(r_section,"RESTART_OPTIMIZE_INPUT_VARIABLES",l_val=flag) + IF (flag.AND.check_restart(input_file, restart_file, "OPTIMIZE_INPUT%VARIABLE")) THEN + rep_sections => section_vals_get_subs_vals(restart_file,"OPTIMIZE_INPUT%VARIABLE") + CALL section_vals_set_subs_vals(input_file,"OPTIMIZE_INPUT%VARIABLE",rep_sections) + CALL set_restart_info("OPTIMIZE_INPUT: VARIABLES",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_BAROSTAT",l_val=flag,error=error) - IF (flag.AND.check_restart(input_file, restart_file, "MOTION%MD%BAROSTAT",error)) THEN + CALL section_vals_val_get(r_section,"RESTART_BAROSTAT",l_val=flag) + IF (flag.AND.check_restart(input_file, restart_file, "MOTION%MD%BAROSTAT")) THEN section => section_vals_get_subs_vals(restart_file,& - "MOTION%MD%BAROSTAT%MASS",error=error) + "MOTION%MD%BAROSTAT%MASS") CALL section_vals_set_subs_vals(input_file,"MOTION%MD%BAROSTAT%MASS",& - section,error=error) + section) section => section_vals_get_subs_vals(restart_file,& - "MOTION%MD%BAROSTAT%VELOCITY",error=error) + "MOTION%MD%BAROSTAT%VELOCITY") CALL section_vals_set_subs_vals(input_file,"MOTION%MD%BAROSTAT%VELOCITY",& - section,error=error) - CALL set_restart_info("BAROSTAT",restarted_infos,error) + section) + CALL set_restart_info("BAROSTAT",restarted_infos) END IF - flag = check_restart(input_file, restart_file, "MOTION%MD", error) + flag = check_restart(input_file, restart_file, "MOTION%MD") IF(flag) THEN - CALL section_vals_val_get(input_file,"MOTION%MD%ENSEMBLE",i_val=ensemble,error=error) + CALL section_vals_val_get(input_file,"MOTION%MD%ENSEMBLE",i_val=ensemble) IF(ensemble == npt_i_ensemble .OR. ensemble==npt_f_ensemble) THEN - CALL section_vals_val_get(r_section,"RESTART_BAROSTAT_THERMOSTAT",l_val=flag,error=error) - check = check_restart(input_file, restart_file, "MOTION%MD%BAROSTAT", error) + CALL section_vals_val_get(r_section,"RESTART_BAROSTAT_THERMOSTAT",l_val=flag) + check = check_restart(input_file, restart_file, "MOTION%MD%BAROSTAT") CALL restart_thermostat(flag, input_file, restart_file, "MOTION%MD%BAROSTAT%THERMOSTAT", & - check=check, error=error) - IF (flag.AND.check) CALL set_restart_info("THERMOSTAT OF BAROSTAT",restarted_infos,error) + check=check) + IF (flag.AND.check) CALL set_restart_info("THERMOSTAT OF BAROSTAT",restarted_infos) END IF END IF - check = check_restart(input_file, restart_file, "MOTION%MD%SHELL", error) + check = check_restart(input_file, restart_file, "MOTION%MD%SHELL") IF(check) THEN - CALL section_vals_val_get(r_section,"RESTART_SHELL_THERMOSTAT",l_val=flag,error=error) - CALL restart_thermostat(flag, input_file, restart_file, "MOTION%MD%SHELL%THERMOSTAT", error=error) - CALL set_restart_info("SHELL THERMOSTAT",restarted_infos,error) + CALL section_vals_val_get(r_section,"RESTART_SHELL_THERMOSTAT",l_val=flag) + CALL restart_thermostat(flag, input_file, restart_file, "MOTION%MD%SHELL%THERMOSTAT") + CALL set_restart_info("SHELL THERMOSTAT",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_THERMOSTAT",l_val=flag,error=error) - CALL restart_thermostat(flag,input_file, restart_file, "MOTION%MD%THERMOSTAT", error=error) - IF (flag) CALL set_restart_info("PARTICLE THERMOSTAT",restarted_infos,error) + CALL section_vals_val_get(r_section,"RESTART_THERMOSTAT",l_val=flag) + CALL restart_thermostat(flag,input_file, restart_file, "MOTION%MD%THERMOSTAT") + IF (flag) CALL set_restart_info("PARTICLE THERMOSTAT",restarted_infos) - CALL section_vals_val_get(r_section,"RESTART_CONSTRAINT",l_val=flag,error=error) - IF (flag.AND.check_restart(input_file, restart_file, "MOTION%CONSTRAINT",error)) THEN - section => section_vals_get_subs_vals(restart_file,"MOTION%CONSTRAINT",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%CONSTRAINT",section,error=error) - CALL set_restart_info("CONSTRAINTS/RESTRAINTS",restarted_infos,error) + CALL section_vals_val_get(r_section,"RESTART_CONSTRAINT",l_val=flag) + IF (flag.AND.check_restart(input_file, restart_file, "MOTION%CONSTRAINT")) THEN + section => section_vals_get_subs_vals(restart_file,"MOTION%CONSTRAINT") + CALL section_vals_set_subs_vals(input_file,"MOTION%CONSTRAINT",section) + CALL set_restart_info("CONSTRAINTS/RESTRAINTS",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_METADYNAMICS",l_val=flag,error=error) - IF (flag.AND.check_restart(input_file, restart_file, "MOTION%FREE_ENERGY%METADYN",error)) THEN + CALL section_vals_val_get(r_section,"RESTART_METADYNAMICS",l_val=flag) + IF (flag.AND.check_restart(input_file, restart_file, "MOTION%FREE_ENERGY%METADYN")) THEN section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_POS",error=error) + "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_POS") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_POS",& - section,error=error) + section) section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_SCALE",error=error) + "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_SCALE") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_SCALE",& - section,error=error) + section) section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_HEIGHT",error=error) + "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_HEIGHT") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_HEIGHT",& - section,error=error) + section) section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_INVDT",error=error) + "MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_INVDT") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%SPAWNED_HILLS_INVDT",& - section,error=error) + section) ! Extended Lagrangian section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_SS0",error=error) + "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_SS0") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_SS0",& - section,error=error) + section) section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_VVP",error=error) + "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_VVP") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_VVP",& - section,error=error) + section) section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_SS",error=error) + "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_SS") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_SS",& - section,error=error) + section) section => section_vals_get_subs_vals(restart_file,& - "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_FS",error=error) + "MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_FS") CALL section_vals_set_subs_vals(input_file,"MOTION%FREE_ENERGY%METADYN%EXT_LAGRANGE_FS",& - section,error=error) - CALL set_restart_info("METADYNAMICS",restarted_infos,error) + section) + CALL set_restart_info("METADYNAMICS",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_WALKERS",l_val=flag,error=error) - IF (flag.AND.check_restart(input_file, restart_file, "MOTION%FREE_ENERGY%METADYN%MULTIPLE_WALKERS",error)) THEN + CALL section_vals_val_get(r_section,"RESTART_WALKERS",l_val=flag) + IF (flag.AND.check_restart(input_file, restart_file, "MOTION%FREE_ENERGY%METADYN%MULTIPLE_WALKERS")) THEN CALL section_vals_val_get(restart_file,"MOTION%FREE_ENERGY%METADYN%MULTIPLE_WALKERS%WALKERS_STATUS",& - i_vals=rwalkers_status, error=error) + i_vals=rwalkers_status) ALLOCATE(iwalkers_status(SIZE(rwalkers_status)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) iwalkers_status = rwalkers_status CALL section_vals_val_set(input_file,"MOTION%FREE_ENERGY%METADYN%MULTIPLE_WALKERS%WALKERS_STATUS",& - i_vals_ptr=iwalkers_status, error=error) - CALL set_restart_info("WALKERS INFO",restarted_infos,error) + i_vals_ptr=iwalkers_status) + CALL set_restart_info("WALKERS INFO",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_DIMER",l_val=flag,error=error) - IF (flag.AND.check_restart(input_file, restart_file, "MOTION%GEO_OPT%TRANSITION_STATE%DIMER",error)) THEN + CALL section_vals_val_get(r_section,"RESTART_DIMER",l_val=flag) + IF (flag.AND.check_restart(input_file, restart_file, "MOTION%GEO_OPT%TRANSITION_STATE%DIMER")) THEN section => section_vals_get_subs_vals(restart_file,& - "MOTION%GEO_OPT%TRANSITION_STATE%DIMER%DIMER_VECTOR",error=error) + "MOTION%GEO_OPT%TRANSITION_STATE%DIMER%DIMER_VECTOR") CALL section_vals_set_subs_vals(input_file,"MOTION%GEO_OPT%TRANSITION_STATE%DIMER%DIMER_VECTOR",& - section,error=error) - CALL set_restart_info("DIMER TRANSITION STATE SEARCH",restarted_infos,error) + section) + CALL set_restart_info("DIMER TRANSITION STATE SEARCH",restarted_infos) END IF - CALL section_vals_val_get(r_section,"CUSTOM_PATH",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(r_section,"CUSTOM_PATH",n_rep_val=n_rep_val) DO i_rep_val=1,n_rep_val - CALL section_vals_val_get(r_section,"CUSTOM_PATH",i_rep_val=i_rep_val,c_val=path,error=error) + CALL section_vals_val_get(r_section,"CUSTOM_PATH",i_rep_val=i_rep_val,c_val=path) IF (path/=" ") THEN - section => section_vals_get_subs_vals(restart_file,path,error=error) - CALL section_vals_set_subs_vals(input_file,path,section,error=error) - CALL set_restart_info("USER RESTART: "//TRIM(path),restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,path) + CALL section_vals_set_subs_vals(input_file,path,section) + CALL set_restart_info("USER RESTART: "//TRIM(path),restarted_infos) END IF END DO - CALL section_vals_val_get(r_section,"RESTART_RTP",l_val=flag,error=error) -! IF(flag.AND.check_restart(input_file, restart_file, "FORCE_EVAL%DFT%REAL_TIME_PROPAGATION",error)) THEN + CALL section_vals_val_get(r_section,"RESTART_RTP",l_val=flag) +! IF(flag.AND.check_restart(input_file, restart_file, "FORCE_EVAL%DFT%REAL_TIME_PROPAGATION")) THEN IF(flag)THEN section => section_vals_get_subs_vals(restart_file,& - "FORCE_EVAL%DFT%REAL_TIME_PROPAGATION",error=error) - CALL section_vals_val_get(section,"INITIAL_WFN",i_val=myi,error=error) + "FORCE_EVAL%DFT%REAL_TIME_PROPAGATION") + CALL section_vals_val_get(section,"INITIAL_WFN",i_val=myi) CALL section_vals_val_set(input_file,"FORCE_EVAL%DFT%REAL_TIME_PROPAGATION%INITIAL_WFN",& - i_val=myi,error=error) - CALL set_restart_info("REAL TIME PROPAGATION",restarted_infos,error) + i_val=myi) + CALL set_restart_info("REAL TIME PROPAGATION",restarted_infos) END IF ! PIMD - CALL section_vals_val_get(r_section,"RESTART_PINT_POS",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_PINT_POS",l_val=flag) IF(flag) THEN - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%BEADS%COORD",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%BEADS%COORD",section,error=error) - CALL set_restart_info("PINT BEAD POSITIONS",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%BEADS%COORD") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%BEADS%COORD",section) + CALL set_restart_info("PINT BEAD POSITIONS",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_PINT_VEL",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_PINT_VEL",l_val=flag) IF(flag) THEN - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%BEADS%VELOCITY",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%BEADS%VELOCITY",section,error=error) - CALL set_restart_info("PINT BEAD VELOCITIES",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%BEADS%VELOCITY") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%BEADS%VELOCITY",section) + CALL set_restart_info("PINT BEAD VELOCITIES",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_PINT_NOSE",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_PINT_NOSE",l_val=flag) IF(flag) THEN - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%NOSE%COORD",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%NOSE%COORD",section,error=error) - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%NOSE%VELOCITY",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%NOSE%VELOCITY",section,error=error) - CALL set_restart_info("PINT NOSE THERMOSTAT",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%NOSE%COORD") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%NOSE%COORD",section) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%NOSE%VELOCITY") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%NOSE%VELOCITY",section) + CALL set_restart_info("PINT NOSE THERMOSTAT",restarted_infos) END IF - CALL section_vals_val_get(r_section,"RESTART_PINT_GLE",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_PINT_GLE",l_val=flag) IF(flag) THEN - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%GLE",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%GLE",section,error=error) - CALL set_restart_info("PINT GLE THERMOSTAT",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%GLE") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%GLE",section) + CALL set_restart_info("PINT GLE THERMOSTAT",restarted_infos) END IF ! PIMC ! - CALL section_vals_val_get(r_section,"RESTART_HELIUM_POS",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_HELIUM_POS",l_val=flag) IF(flag) THEN CALL section_vals_val_get(input_file,"MOTION%PINT%HELIUM%NUM_ENV",& - explicit=explicit1, error=error) + explicit=explicit1) IF ( .NOT. explicit1 ) THEN - CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) + CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) END IF - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%COORD",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%COORD",section,error=error) - CALL set_restart_info("HELIUM BEAD POSITIONS",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%COORD") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%COORD",section) + CALL set_restart_info("HELIUM BEAD POSITIONS",restarted_infos) END IF ! - CALL section_vals_val_get(r_section,"RESTART_HELIUM_PERMUTATION",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_HELIUM_PERMUTATION",l_val=flag) IF(flag) THEN CALL section_vals_val_get(input_file,"MOTION%PINT%HELIUM%NUM_ENV",& - explicit=explicit1, error=error) + explicit=explicit1) IF ( .NOT. explicit1 ) THEN - CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) + CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) END IF - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%PERM",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%PERM",section,error=error) - CALL set_restart_info("HELIUM PERMUTATION STATE",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%PERM") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%PERM",section) + CALL set_restart_info("HELIUM PERMUTATION STATE",restarted_infos) END IF ! - CALL section_vals_val_get(r_section,"RESTART_HELIUM_FORCE",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_HELIUM_FORCE",l_val=flag) IF(flag) THEN CALL section_vals_val_get(input_file,"MOTION%PINT%HELIUM%NUM_ENV",& - explicit=explicit1, error=error) + explicit=explicit1) IF ( .NOT. explicit1 ) THEN - CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) + CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) END IF - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%FORCE",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%FORCE",section,error=error) - CALL set_restart_info("HELIUM FORCES ON SOLUTE",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%FORCE") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%FORCE",section) + CALL set_restart_info("HELIUM FORCES ON SOLUTE",restarted_infos) END IF ! - CALL section_vals_val_get(r_section,"RESTART_HELIUM_RNG",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_HELIUM_RNG",l_val=flag) IF(flag) THEN CALL section_vals_val_get(input_file,"MOTION%PINT%HELIUM%NUM_ENV",& - explicit=explicit1, error=error) + explicit=explicit1) IF ( .NOT. explicit1 ) THEN - CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) + CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) END IF - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%RNG_STATE",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%RNG_STATE",section,error=error) - CALL set_restart_info("HELIUM RNG STATE",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%RNG_STATE") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%RNG_STATE",section) + CALL set_restart_info("HELIUM RNG STATE",restarted_infos) END IF ! ! - CALL section_vals_val_get(r_section,"RESTART_HELIUM_DENSITIES",l_val=flag,error=error) + CALL section_vals_val_get(r_section,"RESTART_HELIUM_DENSITIES",l_val=flag) IF(flag) THEN CALL section_vals_val_get(input_file,"MOTION%PINT%HELIUM%NUM_ENV",& - explicit=explicit1, error=error) + explicit=explicit1) IF ( .NOT. explicit1 ) THEN - CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) - CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi,error=error) + CALL section_vals_val_get(restart_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) + CALL section_vals_val_set(input_file,"MOTION%PINT%HELIUM%NUM_ENV",i_val=myi) END IF - section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%RHO",error=error) - CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%RHO",section,error=error) - CALL set_restart_info("HELIUM DENSITIES",restarted_infos,error) + section => section_vals_get_subs_vals(restart_file,"MOTION%PINT%HELIUM%RHO") + CALL section_vals_set_subs_vals(input_file,"MOTION%PINT%HELIUM%RHO",section) + CALL set_restart_info("HELIUM DENSITIES",restarted_infos) END IF ! - CALL section_vals_val_set(r_section,"RESTART_FILE_NAME", c_val=" ",error=error) - CALL section_vals_release(restart_file,error=error) + CALL section_vals_val_set(r_section,"RESTART_FILE_NAME", c_val=" ") + CALL section_vals_release(restart_file) CALL release_restart_info(restarted_infos, r_file_path, binary_restart_file,& - output_unit, error) + output_unit) END IF END IF CALL timestop(handle) @@ -796,15 +784,13 @@ END SUBROUTINE handle_ext_restart !> \brief store information on the restarted quantities !> \param label ... !> \param restarted_infos ... -!> \param error ... !> \author Teodoro Laino [tlaino] 09.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE set_restart_info(label, restarted_infos, error) + SUBROUTINE set_restart_info(label, restarted_infos) CHARACTER(LEN=*), INTENT(IN) :: label CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: restarted_infos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_restart_info', & routineP = moduleN//':'//routineN @@ -827,17 +813,15 @@ END SUBROUTINE set_restart_info !> \param r_file_path ... !> \param binary_restart_file ... !> \param output_unit ... -!> \param error ... !> \author Teodoro Laino [tlaino] 09.2008 - University of Zurich ! ***************************************************************************** SUBROUTINE release_restart_info(restarted_infos, r_file_path,& - binary_restart_file, output_unit, error) + binary_restart_file, output_unit) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: restarted_infos CHARACTER(LEN=*), INTENT(IN) :: r_file_path, & binary_restart_file INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_restart_info', & routineP = moduleN//':'//routineN @@ -876,7 +860,7 @@ SUBROUTINE release_restart_info(restarted_infos, r_file_path,& END IF IF (ASSOCIATED(restarted_infos)) THEN DEALLOCATE(restarted_infos,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE release_restart_info @@ -888,16 +872,13 @@ END SUBROUTINE release_restart_info !> \param restart_file ... !> \param path ... !> \param check ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE restart_thermostat(flag, input_file, restart_file, path, check, error) + SUBROUTINE restart_thermostat(flag, input_file, restart_file, path, check) LOGICAL, INTENT(IN) :: flag TYPE(section_vals_type), POINTER :: input_file, restart_file CHARACTER(LEN=*), INTENT(IN) :: path LOGICAL, INTENT(IN), OPTIONAL :: check - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'restart_thermostat', & routineP = moduleN//':'//routineN @@ -909,17 +890,17 @@ SUBROUTINE restart_thermostat(flag, input_file, restart_file, path, check, error TYPE(section_vals_type), POINTER :: section failure = .FALSE. - check_loc = check_restart(input_file, restart_file, TRIM(path), error) + check_loc = check_restart(input_file, restart_file, TRIM(path)) skip_other_checks = PRESENT(check) IF (skip_other_checks) check_loc = check IF (flag.AND.check_loc) THEN ! Let's check if the thermostat type is different otherwise it does not make any ! sense to do any kind of restart - CALL section_vals_val_get(input_file,TRIM(path)//"%TYPE",i_val=input_type,error=error) - CALL section_vals_val_get(restart_file,TRIM(path)//"%TYPE",i_val=restart_type,error=error) + CALL section_vals_val_get(input_file,TRIM(path)//"%TYPE",i_val=input_type) + CALL section_vals_val_get(restart_file,TRIM(path)//"%TYPE",i_val=restart_type) IF (input_type==do_thermo_same_as_part) THEN - CALL section_vals_val_get(input_file,"MOTION%MD%THERMOSTAT%TYPE",i_val=input_type,error=error) + CALL section_vals_val_get(input_file,"MOTION%MD%THERMOSTAT%TYPE",i_val=input_type) END IF IF (skip_other_checks) THEN @@ -927,41 +908,41 @@ SUBROUTINE restart_thermostat(flag, input_file, restart_file, path, check, error restart_region = do_region_global ELSE ! Also the regions must be the same.. - CALL section_vals_val_get(input_file,TRIM(path)//"%REGION",i_val=input_region,error=error) - CALL section_vals_val_get(restart_file,TRIM(path)//"%REGION",i_val=restart_region,error=error) + CALL section_vals_val_get(input_file,TRIM(path)//"%REGION",i_val=input_region) + CALL section_vals_val_get(restart_file,TRIM(path)//"%REGION",i_val=restart_region) END IF IF ((input_type==restart_type).AND.(input_region==restart_region)) THEN SELECT CASE(input_type) CASE(do_thermo_nose) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%COORD",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%COORD",section,error=error) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%COORD") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%COORD",section) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%VELOCITY",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%VELOCITY",section,error=error) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%VELOCITY") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%VELOCITY",section) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%MASS",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%MASS",section,error=error) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%MASS") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%MASS",section) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%FORCE",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%FORCE",section,error=error) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%NOSE%FORCE") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%NOSE%FORCE",section) CASE(do_thermo_csvr) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%CSVR%THERMOSTAT_ENERGY",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%CSVR%THERMOSTAT_ENERGY",section,error=error) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%CSVR%RNG_INIT",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%CSVR%RNG_INIT",section,error=error) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%CSVR%THERMOSTAT_ENERGY") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%CSVR%THERMOSTAT_ENERGY",section) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%CSVR%RNG_INIT") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%CSVR%RNG_INIT",section) CASE(do_thermo_gle) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%GLE%THERMOSTAT_ENERGY",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%GLE%THERMOSTAT_ENERGY",section,error=error) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%GLE%RNG_INIT",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%GLE%RNG_INIT",section,error=error) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%GLE%S",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%GLE%S",section,error=error) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%GLE%THERMOSTAT_ENERGY") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%GLE%THERMOSTAT_ENERGY",section) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%GLE%RNG_INIT") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%GLE%RNG_INIT",section) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%GLE%S") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%GLE%S",section) CASE(do_thermo_al) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%AD_LANGEVIN%CHI",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%AD_LANGEVIN%CHI",section,error=error) - section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%AD_LANGEVIN%MASS",error=error) - CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%AD_LANGEVIN%MASS",section,error=error) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%AD_LANGEVIN%CHI") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%AD_LANGEVIN%CHI",section) + section => section_vals_get_subs_vals(restart_file,TRIM(path)//"%AD_LANGEVIN%MASS") + CALL section_vals_set_subs_vals(input_file,TRIM(path)//"%AD_LANGEVIN%MASS",section) END SELECT ELSE CALL cp_assert((input_type==restart_type),cp_warning_level,cp_assertion_failed,routineP,& @@ -987,15 +968,12 @@ END SUBROUTINE restart_thermostat !> \param input_file the input file to initialize !> \param restart_file ... !> \param tag_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval do_restart ... !> \author teo ! ***************************************************************************** - FUNCTION check_restart(input_file, restart_file, tag_section, error) RESULT(do_restart) + FUNCTION check_restart(input_file, restart_file, tag_section) RESULT(do_restart) TYPE(section_vals_type), POINTER :: input_file, restart_file CHARACTER(LEN=*), INTENT(IN) :: tag_section - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: do_restart CHARACTER(len=*), PARAMETER :: routineN = 'check_restart', & @@ -1008,10 +986,10 @@ FUNCTION check_restart(input_file, restart_file, tag_section, error) RESULT(do_r CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(work_section) - work_section => section_vals_get_subs_vals(input_file,TRIM(tag_section),error=error) - CALL section_vals_get(work_section,explicit=explicit1,error=error) - work_section => section_vals_get_subs_vals(restart_file,TRIM(tag_section),error=error) - CALL section_vals_get(work_section,explicit=explicit2,error=error) + work_section => section_vals_get_subs_vals(input_file,TRIM(tag_section)) + CALL section_vals_get(work_section,explicit=explicit1) + work_section => section_vals_get_subs_vals(restart_file,TRIM(tag_section)) + CALL section_vals_get(work_section,explicit=explicit2) do_restart = explicit1.AND.explicit2 CALL timestop(handle) @@ -1021,13 +999,10 @@ END FUNCTION check_restart !> \brief Removes section used to restart a calculation from an !> input file in memory !> \param input_file the input file to initialize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE remove_restart_info(input_file,error) + SUBROUTINE remove_restart_info(input_file) TYPE(section_vals_type), POINTER :: input_file - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'remove_restart_info', & routineP = moduleN//':'//routineN @@ -1043,100 +1018,97 @@ SUBROUTINE remove_restart_info(input_file,error) failure=.FALSE. NULLIFY(work_section) - section_to_delete => section_vals_get_subs_vals(input_file,"EXT_RESTART",error=error) - CALL section_vals_remove_values(section_to_delete,error) - sections1 => section_vals_get_subs_vals(input_file,"FORCE_EVAL",error=error) - CALL section_vals_get(sections1, n_repetition=nforce_eval1, error=error) + section_to_delete => section_vals_get_subs_vals(input_file,"EXT_RESTART") + CALL section_vals_remove_values(section_to_delete) + sections1 => section_vals_get_subs_vals(input_file,"FORCE_EVAL") + CALL section_vals_get(sections1, n_repetition=nforce_eval1) DO iforce_eval = 1, nforce_eval1 - section1 => section_vals_get_subs_vals3(sections1,"SUBSYS",i_rep_section=iforce_eval,error=error) - section_to_delete => section_vals_get_subs_vals(section1,"COORD",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(section1,"VELOCITY",error=error) - CALL section_vals_remove_values(section_to_delete,error) + section1 => section_vals_get_subs_vals3(sections1,"SUBSYS",i_rep_section=iforce_eval) + section_to_delete => section_vals_get_subs_vals(section1,"COORD") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(section1,"VELOCITY") + CALL section_vals_remove_values(section_to_delete) END DO - motion_section => section_vals_get_subs_vals(input_file,"MOTION",error=error) - md_section => section_vals_get_subs_vals(motion_section,"MD",error=error) - CALL section_vals_get(md_section,explicit=explicit1,error=error) + motion_section => section_vals_get_subs_vals(input_file,"MOTION") + md_section => section_vals_get_subs_vals(motion_section,"MD") + CALL section_vals_get(md_section,explicit=explicit1) IF (explicit1) THEN - CALL section_vals_val_unset(md_section,"STEP_START_VAL",error=error) - CALL section_vals_val_unset(md_section,"TIME_START_VAL",error=error) - CALL section_vals_val_unset(md_section,"ECONS_START_VAL",error=error) + CALL section_vals_val_unset(md_section,"STEP_START_VAL") + CALL section_vals_val_unset(md_section,"TIME_START_VAL") + CALL section_vals_val_unset(md_section,"ECONS_START_VAL") END IF - work_section => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN",error=error) - CALL section_vals_get(work_section,explicit=explicit1,error=error) + work_section => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN") + CALL section_vals_get(work_section,explicit=explicit1) IF (explicit1) THEN - CALL section_vals_val_unset(motion_section,"FREE_ENERGY%METADYN%STEP_START_VAL",error=error) - CALL section_vals_val_unset(motion_section,"FREE_ENERGY%METADYN%NHILLS_START_VAL",error=error) + CALL section_vals_val_unset(motion_section,"FREE_ENERGY%METADYN%STEP_START_VAL") + CALL section_vals_val_unset(motion_section,"FREE_ENERGY%METADYN%NHILLS_START_VAL") END IF - section_to_delete => section_vals_get_subs_vals(motion_section,"BAND%REPLICA",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"AVERAGES%RESTART_AVERAGES",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%COORD",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%VELOCITY",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%MASS",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%FORCE",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%MASS",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%VELOCITY",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%COORD",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%VELOCITY",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%MASS",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%FORCE",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%COORD",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%VELOCITY",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%MASS",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%FORCE",error=error) - CALL section_vals_remove_values(section_to_delete,error) + section_to_delete => section_vals_get_subs_vals(motion_section,"BAND%REPLICA") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"AVERAGES%RESTART_AVERAGES") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%COORD") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%VELOCITY") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%MASS") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"THERMOSTAT%NOSE%FORCE") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%MASS") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%VELOCITY") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%COORD") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%VELOCITY") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%MASS") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT%NOSE%FORCE") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%COORD") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%VELOCITY") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%MASS") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT%NOSE%FORCE") + CALL section_vals_remove_values(section_to_delete) ! Constrained/Restrained section - section_to_delete => section_vals_get_subs_vals(motion_section,"CONSTRAINT%FIX_ATOM_RESTART",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"CONSTRAINT%COLVAR_RESTART",error=error) - CALL section_vals_remove_values(section_to_delete,error) + section_to_delete => section_vals_get_subs_vals(motion_section,"CONSTRAINT%FIX_ATOM_RESTART") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"CONSTRAINT%COLVAR_RESTART") + CALL section_vals_remove_values(section_to_delete) ! Free energies restarts - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_POS",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_SCALE",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_HEIGHT",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_INVDT",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_SS0",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_VVP",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_SS",error=error) - CALL section_vals_remove_values(section_to_delete,error) - section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_FS",error=error) - CALL section_vals_remove_values(section_to_delete,error) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_POS") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_SCALE") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_HEIGHT") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%SPAWNED_HILLS_INVDT") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_SS0") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_VVP") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_SS") + CALL section_vals_remove_values(section_to_delete) + section_to_delete => section_vals_get_subs_vals(motion_section,"FREE_ENERGY%METADYN%EXT_LAGRANGE_FS") + CALL section_vals_remove_values(section_to_delete) CALL timestop(handle) END SUBROUTINE remove_restart_info ! ***************************************************************************** !> \brief This subroutine controls the defaults for the restartable quantities.. !> \param r_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo - University of Zurich - 09.2007 [tlaino] ! ***************************************************************************** - SUBROUTINE handle_defaults_restart(r_section,error) + SUBROUTINE handle_defaults_restart(r_section) TYPE(section_vals_type), POINTER :: r_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'handle_defaults_restart', & routineP = moduleN//':'//routineN @@ -1149,17 +1121,17 @@ SUBROUTINE handle_defaults_restart(r_section,error) CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(keyword, section) - CALL section_vals_get(r_section, section=section, error=error) - CALL section_vals_val_get(r_section,"RESTART_DEFAULT",l_val=restart_default,error=error) + CALL section_vals_get(r_section, section=section) + CALL section_vals_val_get(r_section,"RESTART_DEFAULT",l_val=restart_default) DO ik=-1,section%n_keywords keyword => section%keywords(ik)%keyword IF (ASSOCIATED(keyword)) THEN IF (keyword%type_of_var==logical_t.AND.keyword%names(1)(1:8)=="RESTART_") THEN IF (TRIM(keyword%names(1))=="RESTART_DEFAULT") CYCLE - CALL section_vals_val_get(r_section,keyword%names(1),n_rep_val=nval,error=error) + CALL section_vals_val_get(r_section,keyword%names(1),n_rep_val=nval) IF (nval==0) THEN ! User didn't specify any value, use the value of the RESTART_DEFAULT keyword.. - CALL section_vals_val_set(r_section,keyword%names(1),l_val=restart_default,error=error) + CALL section_vals_val_set(r_section,keyword%names(1),l_val=restart_default) END IF END IF END IF diff --git a/src/input_cp2k_colvar.F b/src/input_cp2k_colvar.F index d417cb8cea..8dca7b2da4 100644 --- a/src/input_cp2k_colvar.F +++ b/src/input_cp2k_colvar.F @@ -55,14 +55,11 @@ MODULE input_cp2k_colvar !> \brief creates the colvar section !> \param section the section to be created !> \param skip_recursive_colvar ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - RECURSIVE SUBROUTINE create_colvar_section(section,skip_recursive_colvar,error) + RECURSIVE SUBROUTINE create_colvar_section(section,skip_recursive_colvar) TYPE(section_type), POINTER :: section LOGICAL, OPTIONAL :: skip_recursive_colvar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_section', & routineP = moduleN//':'//routineN @@ -73,33 +70,30 @@ RECURSIVE SUBROUTINE create_colvar_section(section,skip_recursive_colvar,error) failure=.FALSE. skip=.FALSE. IF(PRESENT(skip_recursive_colvar))skip=skip_recursive_colvar - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="COLVAR",& description="This section specifies the nature of the collective variables.",& - n_keywords=1, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.TRUE.) NULLIFY(subsection, print_key) CALL create_colvar_var_section(subsection=subsection,& - section=section,skip_recursive_colvar=skip,error=error) + section=section,skip_recursive_colvar=skip) CALL section_create(subsection,name="PRINT",& description="Controls the printing of the colvar specifications",& - n_keywords=0, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of basic information during colvar setup.", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_clv_info_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_clv_info_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_section @@ -108,13 +102,10 @@ END SUBROUTINE create_colvar_section !> This section will be only used for restraint restarts. !> Constraints are handled automatically !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE create_clv_info_section(section, error) + SUBROUTINE create_clv_info_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_clv_info_section', & routineP = moduleN//':'//routineN @@ -123,21 +114,20 @@ SUBROUTINE create_clv_info_section(section, error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY( keyword) CALL section_create(section,name="COLVAR_FUNC_INFO",& description="Specify further data possibly used by colvars, depending "//& "on the starting geometry, for computing the functions value.",& - n_subsections=0, repeats=.FALSE., & - error=error) + n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Colvar function data."//& " The order is an internal order. So if you decide to edit/modify/add these values by hand"//& " you should know very well what you are doing.!",repeats=.TRUE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_clv_info_section @@ -147,14 +137,11 @@ END SUBROUTINE create_clv_info_section !> \param subsection ... !> \param section the section to be created !> \param skip_recursive_colvar ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - RECURSIVE SUBROUTINE create_colvar_var_section(subsection, section, skip_recursive_colvar, error) + RECURSIVE SUBROUTINE create_colvar_var_section(subsection, section, skip_recursive_colvar) TYPE(section_type), POINTER :: subsection, section LOGICAL, INTENT(IN) :: skip_recursive_colvar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_var_section', & routineP = moduleN//':'//routineN @@ -162,101 +149,101 @@ RECURSIVE SUBROUTINE create_colvar_var_section(subsection, section, skip_recursi LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(subsection),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(subsection),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) - CALL create_colvar_dist_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_dist_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_angle_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_angle_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_torsion_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_torsion_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_coord_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_coord_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_pop_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_pop_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_gyr_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_gyr_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_d_pl_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_d_pl_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_a_pl_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_a_pl_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_rot_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_rot_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_dfunct_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_dfunct_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_qparm_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_qparm_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_hydronium_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_hydronium_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_rmsd_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_rmsd_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_xyz_d_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_xyz_d_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_xyz_od_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_xyz_od_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_u_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_u_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_wc_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_wc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_hbp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_hbp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_ring_puckering_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_ring_puckering_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_cond_dist_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_cond_dist_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) IF(.NOT. skip_recursive_colvar)THEN - CALL create_colvar_rpath_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_rpath_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_dpath_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_dpath_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_colvar_comb_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_comb_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ENDIF END SUBROUTINE create_colvar_var_section @@ -264,13 +251,10 @@ END SUBROUTINE create_colvar_var_section ! ***************************************************************************** !> \brief collective variables specifying coordination !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_coord_section(section,error) + SUBROUTINE create_colvar_coord_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_coord_section', & routineP = moduleN//':'//routineN @@ -281,11 +265,10 @@ SUBROUTINE create_colvar_coord_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="coordination",& description="Section to define the coordination number as a collective variable.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection, keyword) @@ -293,88 +276,88 @@ SUBROUTINE create_colvar_coord_section(section,error) variants=(/"POINTS_FROM"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_FROM {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_TO",& variants=(/"POINTS_TO"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_TO {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_TO_B",& variants=(/"POINTS_TO_B"/),& description="For the CV given by the multiplication of two coorination numbers,"//& " here specify indexes of the third set of atoms/points. ",& usage="ATOMS_TO_B {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS_FROM",& description="Specify alternatively kinds of atoms building the coordination variable.",& usage="KINDS_FROM {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS_TO",& description="Specify alternatively kinds of atoms building the coordination variable.",& usage="KINDS_TO {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS_TO_B",& description="For the CV given by the multiplication of two coorination numbers,"//& " here specify alternatively kinds of atoms building the coordination variable.",& usage="KINDS_TO_B {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="R0",& variants=(/"R_0"/),& description="Specify the R0 parameter in the coordination function.",& usage="R0 {real}",default_r_val=3.0_dp,& - unit_str="bohr",n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="bohr",n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NN",& variants=(/"EXPON_NUMERATOR"/),& description="Sets the value of the numerator of the exponential factor"//& "in the coordination FUNCTION.",& usage="NN {integer}",default_i_val=6,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ND",& variants=(/"EXPON_DENOMINATOR"/),& description="Sets the value of the denominator of the exponential factor"//& "in the coordination FUNCTION.",& usage="ND {integer}",default_i_val=12,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R0_B",& variants=(/"R_0_B"/),& description="For the CV given by the multiplication of two coorination numbers,"//& " specify the R0 parameter in the second coordination function.",& usage="R0_B {real}",default_r_val=3.0_dp,& - unit_str="bohr",n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="bohr",n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NN_B",& variants=(/"EXPON_NUMERATOR_B"/),& @@ -382,9 +365,9 @@ SUBROUTINE create_colvar_coord_section(section,error) "Sets the value of the numerator of the exponential factor"//& "in the coordination FUNCTION.",& usage="NN_B {integer}",default_i_val=6,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ND_B",& variants=(/"EXPON_DENOMINATOR_B"/),& @@ -392,9 +375,9 @@ SUBROUTINE create_colvar_coord_section(section,error) "Sets the value of the denominator of the exponential factor"//& "in the coordination FUNCTION.",& usage="ND_B {integer}",default_i_val=12,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_colvar_coord_section @@ -404,11 +387,9 @@ END SUBROUTINE create_colvar_coord_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_colvar_cond_dist_section(section,error) + SUBROUTINE create_colvar_cond_dist_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_colvar_cond_dist_section', & @@ -420,90 +401,89 @@ SUBROUTINE create_colvar_cond_dist_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CONDITIONED_DISTANCE",& description="Section to define the conditioned distance as a collective variable.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection, keyword) CALL keyword_create(keyword, name="ATOMS_DISTANCE",& description="Specify indexes of atoms/points from which the distance is computed. ",& usage="ATOMS_DISTANCE {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_FROM",& variants=(/"POINTS_FROM"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_FROM {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_TO",& variants=(/"POINTS_TO"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_TO {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS_FROM",& description="Specify alternatively kinds of atoms building the coordination variable.",& usage="KINDS_FROM {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS_TO",& description="Specify alternatively kinds of atoms building the coordination variable.",& usage="KINDS_TO {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="R0",& variants=(/"R_0"/),& description="Specify the R0 parameter in the coordination function.",& usage="R0 {real}",default_r_val=3.0_dp,& - unit_str="bohr",n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="bohr",n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NN",& variants=(/"EXPON_NUMERATOR"/),& description="Sets the value of the numerator of the exponential factor"//& "in the coordination FUNCTION.",& usage="NN {integer}",default_i_val=6,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ND",& variants=(/"EXPON_DENOMINATOR"/),& description="Sets the value of the denominator of the exponential factor"//& "in the coordination FUNCTION.",& usage="ND {integer}",default_i_val=12,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LAMBDA",& description="Specify the lambda parameter at the exponent of the conditioned distance function.",& usage="R0 {real}",default_r_val=3.0_dp,& - unit_str="bohr",n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="bohr",n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) @@ -515,14 +495,11 @@ END SUBROUTINE create_colvar_cond_dist_section ! ***************************************************************************** !> \brief collective variables specifying population of a specie based on coordination !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 01.2009 !> \author Fabio Sterpone ! ***************************************************************************** - SUBROUTINE create_colvar_pop_section(section,error) + SUBROUTINE create_colvar_pop_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_pop_section', & routineP = moduleN//':'//routineN @@ -533,11 +510,10 @@ SUBROUTINE create_colvar_pop_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="population",& description="Section to define the population of specie as a collective variable.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection, keyword) @@ -545,78 +521,78 @@ SUBROUTINE create_colvar_pop_section(section,error) variants=(/"POINTS_FROM"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_FROM {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_TO",& variants=(/"POINTS_TO"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_TO {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS_FROM",& description="Specify alternatively kinds of atoms building the coordination variable.",& usage="KINDS_FROM {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS_TO",& description="Specify alternatively kinds of atoms building the coordination variable.",& usage="KINDS_TO {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="R0",& variants=(/"R_0"/),& description="Specify the R0 parameter in the coordination function.",& usage="R0 {real}",default_r_val=3.0_dp,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NN",& variants=(/"EXPON_NUMERATOR"/),& description="Sets the value of the numerator of the exponential factor"//& "in the coordination FUNCTION.",& usage="NN {integer}",default_i_val=6,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ND",& variants=(/"EXPON_DENOMINATOR"/),& description="Sets the value of the denominator of the exponential factor"//& "in the coordination FUNCTION.",& usage="ND {integer}",default_i_val=12,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="n0",& variants=(/"n_0"/),& description="Specify the n0 parameter that sets the coordination of the species.",& usage="n0 {integer}",default_i_val=4,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIGMA",& description="Specify the gaussian width of used to build the population istogram.",& usage="SIGMA {real}",default_r_val=0.5_dp,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_colvar_pop_section @@ -624,11 +600,9 @@ END SUBROUTINE create_colvar_pop_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_colvar_gyr_section(section,error) + SUBROUTINE create_colvar_gyr_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_gyr_section', & routineP = moduleN//':'//routineN @@ -639,11 +613,10 @@ SUBROUTINE create_colvar_gyr_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="GYRATION_RADIUS",& description="Section to define the gyration radius as a collective variable.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection, keyword) @@ -651,21 +624,21 @@ SUBROUTINE create_colvar_gyr_section(section,error) variants=(/"POINTS"/),& description="Specify indexes of atoms/points defyining the gyration radius variable. ",& usage="ATOMS {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINDS",& description="Specify alternatively kinds of atoms defining the gyration radius.",& usage="KINDS {CHAR} {CHAR} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_gyr_section @@ -673,13 +646,10 @@ END SUBROUTINE create_colvar_gyr_section ! ***************************************************************************** !> \brief collective variables specifying torsion !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_dfunct_section(section,error) + SUBROUTINE create_colvar_dfunct_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_dfunct_section', & routineP = moduleN//':'//routineN @@ -690,12 +660,11 @@ SUBROUTINE create_colvar_dfunct_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DISTANCE_FUNCTION",& description="Section to define functions between two distances as collective variables."//& " The function is defined as d1+coeff*d2",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -703,30 +672,30 @@ SUBROUTINE create_colvar_dfunct_section(section,error) variants=(/"POINTS"/),& description="Specifies the indexes of atoms/points for the two bonds d1=(1-2) d2=(3-4).",& usage="ATOMS {integer} {integer} {integer} {integer}",& - n_var=4, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COEFFICIENT",& description="Specifies the coefficient in the function for the constraint."//& " -1.0 has to be used for distance difference, 1.0 for distance addition",& usage="COEFFICIENT {real}",& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PBC",& description="Whether periodic boundary conditions should be applied on the "//& "atomic position before computing the colvar or not.",& usage="PBC",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_dfunct_section @@ -734,13 +703,10 @@ END SUBROUTINE create_colvar_dfunct_section ! ***************************************************************************** !> \brief collective variables specifying torsion !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_torsion_section(section,error) + SUBROUTINE create_colvar_torsion_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_colvar_torsion_section', & @@ -752,11 +718,10 @@ SUBROUTINE create_colvar_torsion_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="torsion",& description="Section to define the torsion as a collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -764,14 +729,14 @@ SUBROUTINE create_colvar_torsion_section(section,error) variants=(/"POINTS"/),& description="Specifies the indexes of atoms/points defining the torsion.",& usage="ATOMS {integer} {integer} {integer} {integer}",& - n_var=4, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_torsion_section @@ -779,13 +744,10 @@ END SUBROUTINE create_colvar_torsion_section ! ***************************************************************************** !> \brief collective variables specifying torsion !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_rot_section(section,error) + SUBROUTINE create_colvar_rot_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_rot_section', & routineP = moduleN//':'//routineN @@ -796,12 +758,11 @@ SUBROUTINE create_colvar_rot_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="bond_rotation",& description="Section to define the rotation of a bond/line with respect to"//& "another bond/line",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -809,38 +770,38 @@ SUBROUTINE create_colvar_rot_section(section,error) description="Specifies the index of atom/point defining the first point"//& "of the first bond/line.",& usage="P1_BOND1 {integer}",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="P2_BOND1",& description="Specifies the index of atom/point defining the second point"//& "of the first bond/line.",& usage="P2_BOND1 {integer}",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="P1_BOND2",& description="Specifies the index of atom/point defining the first point"//& "of the second bond/line.",& usage="P1_BOND2 {integer}",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="P2_BOND2",& description="Specifies the index of atom/point defining the second point"//& "of the second bond/line.",& usage="P2_BOND2 {integer}",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_rot_section @@ -848,13 +809,10 @@ END SUBROUTINE create_colvar_rot_section ! ***************************************************************************** !> \brief collective variables specifying angles !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_angle_section(section,error) + SUBROUTINE create_colvar_angle_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_angle_section', & routineP = moduleN//':'//routineN @@ -865,25 +823,24 @@ SUBROUTINE create_colvar_angle_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="angle",& description="Section to define the angle as a collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="ATOMS",& variants=(/"POINTS"/),& description="Specifies the indexes of atoms/points defining the angle.",& usage="ATOMS {integer} {integer} {integer}",& - n_var=3, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_angle_section @@ -891,13 +848,10 @@ END SUBROUTINE create_colvar_angle_section ! ***************************************************************************** !> \brief creates the colvar section regarded to the collective variables dist !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_dist_section(section,error) + SUBROUTINE create_colvar_dist_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_dist_section', & routineP = moduleN//':'//routineN @@ -908,33 +862,32 @@ SUBROUTINE create_colvar_dist_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="distance",& description="Section to define the distance as a collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="ATOMS",& variants=(/"POINTS"/),& description="Specifies the indexes of atoms/points defining the distance.",& usage="ATOMS {integer} {integer}",& - n_var=2, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AXIS",& description="Define the axes along which the colvar should be evaluated",& usage="AXIS (XYZ | X | Y | Z | XY| XZ | YZ)",& enum_c_vals=s2a( "XYZ","X", "Y", "Z", "XY", "XZ", "YZ"),& enum_i_vals=(/ do_clv_xyz, do_clv_x, do_clv_y,do_clv_z, do_clv_xy, do_clv_xz, do_clv_yz/),& - default_i_val=do_clv_xyz, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_clv_xyz) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_dist_section @@ -942,13 +895,10 @@ END SUBROUTINE create_colvar_dist_section ! ***************************************************************************** !> \brief creates the colvar section regarded to the collective variables dist !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_xyz_d_section(section,error) + SUBROUTINE create_colvar_xyz_d_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_xyz_d_section', & routineP = moduleN//':'//routineN @@ -959,23 +909,22 @@ SUBROUTINE create_colvar_xyz_d_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="XYZ_DIAG",& description="Section to define the distance of an atom from its starting "//& "position ((X-X(0))^2+(Y-Y(0))^2+(Z-Z(0))^2) or part of its components as a collective variable."//& "If absolute_position is specified, instead the CV is represented by the "//& "instantaneous position of the atom (only available for X, Y or Z components).",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="ATOM",& variants=(/"POINT"/),& description="Specifies the index of the atom/point.",& usage="ATOM {integer}",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COMPONENT",& description="Define the component of the position vector which will be used "//& @@ -983,29 +932,29 @@ SUBROUTINE create_colvar_xyz_d_section(section,error) usage="AXIS (XYZ | X | Y | Z | XY| XZ | YZ)",& enum_c_vals=s2a( "XYZ","X", "Y", "Z", "XY", "XZ", "YZ"),& enum_i_vals=(/ do_clv_xyz, do_clv_x, do_clv_y,do_clv_z, do_clv_xy, do_clv_xz, do_clv_yz/),& - default_i_val=do_clv_xyz, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_clv_xyz) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PBC",& description="Whether periodic boundary conditions should be applied on the "//& "atomic position before computing the colvar or not.",& usage="PBC",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ABSOLUTE_POSITION",& description="If enabled, the absolute position of the atoms will be used. ",& usage="ABSOLUTE_POSITION",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_xyz_d_section @@ -1013,13 +962,10 @@ END SUBROUTINE create_colvar_xyz_d_section ! ***************************************************************************** !> \brief creates the colvar section regarded to the collective variables dist !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_xyz_od_section(section,error) + SUBROUTINE create_colvar_xyz_od_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_xyz_od_section', & routineP = moduleN//':'//routineN @@ -1030,22 +976,21 @@ SUBROUTINE create_colvar_xyz_od_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="XYZ_OUTERDIAG",& description="Section to define the cross term (XA-XA(0))*(XB-XB(0))+(XA-XA(0))*(YB-YB(0))"//& " or part of its components as a collective variable. The final term is given by the product "//& " of the components of A with the components of B.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="ATOMS",& variants=(/"POINTS"/),& description="Specifies the index of the atoms/points A and B.",& usage="ATOMS {integer} {integer}",& - n_var=2, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COMPONENT_A",& description="Define the component of the position vector which will be used "//& @@ -1053,9 +998,9 @@ SUBROUTINE create_colvar_xyz_od_section(section,error) usage="AXIS (XYZ | X | Y | Z | XY| XZ | YZ)",& enum_c_vals=s2a( "XYZ","X", "Y", "Z", "XY", "XZ", "YZ"),& enum_i_vals=(/ do_clv_xyz, do_clv_x, do_clv_y,do_clv_z, do_clv_xy, do_clv_xz, do_clv_yz/),& - default_i_val=do_clv_xyz, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_clv_xyz) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COMPONENT_B",& description="Define the component of the position vector which will be used "//& @@ -1063,22 +1008,22 @@ SUBROUTINE create_colvar_xyz_od_section(section,error) usage="AXIS (XYZ | X | Y | Z | XY| XZ | YZ)",& enum_c_vals=s2a( "XYZ","X", "Y", "Z", "XY", "XZ", "YZ"),& enum_i_vals=(/ do_clv_xyz, do_clv_x, do_clv_y,do_clv_z, do_clv_xy, do_clv_xz, do_clv_yz/),& - default_i_val=do_clv_xyz, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_clv_xyz) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PBC",& description="Whether periodic boundary conditions should be applied on the "//& "atomic position before computing the colvar or not.",& usage="PBC",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_xyz_od_section @@ -1086,13 +1031,10 @@ END SUBROUTINE create_colvar_xyz_od_section ! ***************************************************************************** !> \brief energy as collective variable !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Sebastiano Caravati ! ***************************************************************************** - SUBROUTINE create_colvar_u_section(section,error) + SUBROUTINE create_colvar_u_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_u_section', & routineP = moduleN//':'//routineN @@ -1103,72 +1045,70 @@ SUBROUTINE create_colvar_u_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="u",& description="Section to define the energy as a generalized collective variable.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection, keyword) CALL section_create(subsection,name="MIXED",& description="This section allows to use any function of the energy subsystems "//& " in a mixed_env calculation as a collective variable.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="ENERGY_FUNCTION",& description="Specifies the functional form of the collective variable in mathematical notation.",& usage="ENERGY_FUNCTION (E1+E2-LOG(E1/E2))", type_of_var=lchar_t,& - n_var=1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VARIABLES",& description="Defines the variables of the functional form. To allow an efficient"//& " mapping the order of the energy variables will be considered identical to the"//& " order of the force_eval in the force_eval_order list.",& usage="VARIABLES x", type_of_var=char_t,& - n_var=-1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARAMETERS",& description="Defines the parameters of the functional form",& usage="PARAMETERS a b D", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VALUES",& description="Defines the values of parameter of the functional form",& usage="VALUES ", type_of_var=real_t,& - n_var=-1, repeats=.TRUE., unit_str="internal_cp2k", error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE., unit_str="internal_cp2k") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="UNITS",& description="Optionally, allows to define valid CP2K unit strings for each parameter value. "//& "It is assumed that the corresponding parameter value is specified in this unit.",& usage="UNITS angstrom eV*angstrom^-1 angstrom^1 K", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DX",& description="Parameter used for computing the derivative with the Ridders' method.",& - usage="DX ", default_r_val=0.1_dp, unit_str="bohr", error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DX ", default_r_val=0.1_dp, unit_str="bohr") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ERROR_LIMIT",& description="Checks that the error in computing the derivative is not larger than "//& "the value set; in case error is larger a warning message is printed.",& - usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_u_section @@ -1176,13 +1116,10 @@ END SUBROUTINE create_colvar_u_section !> \brief creates the colvar section regarded to the collective variables distance !> of a point from a plane !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_d_pl_section(section,error) + SUBROUTINE create_colvar_d_pl_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_d_pl_section', & routineP = moduleN//':'//routineN @@ -1193,42 +1130,41 @@ SUBROUTINE create_colvar_d_pl_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="distance_point_plane",& description="Section to define the distance of a point from a plane "//& "as a collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="PBC",& description="Whether periodic boundary conditions should be applied on the "//& "atomic position before computing the colvar or not.",& usage="PBC",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_PLANE",& variants=(/"POINTS_PLANE"/),& description="Specifies the indexes of atoms/points defining the plane.",& usage="ATOMS_PLANE ",& - n_var=3, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOM_POINT",& variants=(/"POINT_POINT"/),& description="Specifies the atom/point index defining the point.",& usage="ATOM_POINT ",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_d_pl_section @@ -1237,13 +1173,10 @@ END SUBROUTINE create_colvar_d_pl_section !> \brief creates the colvar section regarded to the collective variables !> angles betweem two planes !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_a_pl_section(section,error) + SUBROUTINE create_colvar_a_pl_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_a_pl_section', & routineP = moduleN//':'//routineN @@ -1254,19 +1187,17 @@ SUBROUTINE create_colvar_a_pl_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="angle_plane_plane",& description="This section defines the angle between two planes "//& "as a collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL section_create(subsection,name="PLANE",& description="This section defines the plane. When using this colvar, "//& "two plane section must be defined!",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="DEF_TYPE",& description="Specify how the plane is defined: either by 3 atoms or by a fixed normal "//& @@ -1276,44 +1207,41 @@ SUBROUTINE create_colvar_a_pl_section(section,error) enum_c_vals=s2a("ATOMS", "VECTOR"),& enum_desc=s2a("Plane defined by the position of 3 atoms",& "Plane defined by a fixed normal vector"),& - enum_i_vals=(/plane_def_atoms,plane_def_vec/),error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/plane_def_atoms,plane_def_vec/)) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies the indexes of 3 atoms/points defining the plane.",& usage="ATOMS ",& - n_var=3, type_of_var=integer_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3, type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NORMAL_VECTOR",& description="Alternatively to 3 atoms/points one can define one of the two, "//& "planes by defining its NORMAL vector.",& usage="NORMAL_VECTOR 0.0 1.0 0.0",& - n_var=3, type_of_var=real_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + n_var=3, type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_a_pl_section ! ***************************************************************************** !> \brief create a geometrical point as a function of several atom coordinates !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_point_section(section,error) + SUBROUTINE create_point_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_point_section', & routineP = moduleN//':'//routineN @@ -1323,12 +1251,11 @@ SUBROUTINE create_point_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="POINT",& description="Enables the possibility to use geometrical centers instead of single atoms"//& " to define colvars",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -1339,31 +1266,31 @@ SUBROUTINE create_point_section(section,error) enum_desc=s2a("Conmputes the geometrical center of the listed atoms",& "Defines a fixed point in space"),& enum_i_vals=(/ do_clv_geo_center, do_clv_fix_point /),& - default_i_val=do_clv_geo_center, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_clv_geo_center) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies the indexes of atoms defining the geometrical center",& usage="ATOMS {integer} {integer} {integer} {integer}",& - n_var=-1, type_of_var=integer_t, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHTS",& description="Specifies the weights for a weighted geometrical center. Default is 1/natoms for every atom",& usage="WEIGHTS {real} {real} {real} {real}",& - n_var=-1, type_of_var=real_t, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=real_t, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="XYZ",& description="Specifies the xyz of the fixed point (if the case)",& usage="XYZ {real} {real} {real}",& n_var=3, type_of_var=real_t, unit_str="bohr",& - repeats=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_point_section @@ -1371,13 +1298,10 @@ END SUBROUTINE create_point_section ! ***************************************************************************** !> \brief collective variables specifying torsion !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_colvar_qparm_section(section,error) + SUBROUTINE create_colvar_qparm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_qparm_section', & routineP = moduleN//':'//routineN @@ -1388,11 +1312,10 @@ SUBROUTINE create_colvar_qparm_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="qparm",& description="Section to define the Q parameter (crystalline order parameter) as a collective variable.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -1400,42 +1323,42 @@ SUBROUTINE create_colvar_qparm_section(section,error) variants=(/"POINTS_FROM"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_FROM {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_TO",& variants=(/"POINTS_TO"/),& description="Specify indexes of atoms/points building the coordination variable. ",& usage="ATOMS_TO {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Specifies the distance cutoff for neighbors.",& usage="RCUT {real}",& - n_var=1, unit_str="angstrom",type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="L",& description="Specifies the L spherical harmonics from Ylm.",& usage="L {integer}",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA",& description="Specifies the width of the Fermi-Dirac style smearing around RCUT.",& - usage="ALPHA {real}",unit_str="angstrom^-1",default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALPHA {real}",unit_str="angstrom^-1",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_qparm_section @@ -1443,14 +1366,10 @@ END SUBROUTINE create_colvar_qparm_section ! ***************************************************************************** !> \brief collective variables specifying hydronium solvation !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Marcel Baer ! ***************************************************************************** - SUBROUTINE create_colvar_hydronium_section(section,error) + SUBROUTINE create_colvar_hydronium_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_colvar_hydronium_section', & @@ -1462,130 +1381,126 @@ SUBROUTINE create_colvar_hydronium_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="hydronium",& description="Section to define the formation of a hydronium as a collective variable.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="OXYGENS",& description="Specify indexes of atoms building the coordination variable. ",& usage="OXYGENS {integer} {integer} ..", repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HYDROGENS",& description="Specify indexes of atoms building the coordination variable. ",& usage="HYDROGENS {integer} {integer} ..", repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROO",& variants=(/"R_OO"/),& description="Specify the ROO parameter in the coordination function.",& usage="ROO {real}",default_r_val=3.0_dp,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="pNO",& variants=(/"EXPON_NUMERATORA"/),& description="Sets the value of the numerator of the exponential factor"//& "in the coordination FUNCTION.",& usage="pNO {integer}",default_i_val=6,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="qNO",& variants=(/"EXPON_DENOMINATORA"/),& description="Sets the value of the denominator of the exponential factor"//& "in the coordination FUNCTION.",& usage="qNO {integer}",default_i_val=12,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROH",& variants=(/"R_OH"/),& description="Specify the ROH parameter in the coordination function.",& usage="ROH {real}",default_r_val=3.0_dp,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="pNH",& variants=(/"EXPON_NUMERATORB"/),& description="Sets the value of the numerator of the exponential factor"//& "in the coordination FUNCTION.",& usage="pNH {integer}",default_i_val=6,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="qNH",& variants=(/"EXPON_DENOMINATORB"/),& description="Sets the value of the denominator of the exponential factor"//& "in the coordination FUNCTION.",& usage="qNH {integer}",default_i_val=12,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NH",& variants=(/"NHtest"/),& description="Specify the NH parameter in the hydronium function.",& usage="NH {real}",default_r_val=3.0_dp,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="p",& variants=(/"EXPON_NUMERATOR"/),& description="Sets the value of the numerator of the exponential factor"//& "in the coordination FUNCTION.",& usage="p {integer}",default_i_val=8,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="q",& variants=(/"EXPON_DENOMINATOR"/),& description="Sets the value of the denominator of the exponential factor"//& "in the coordination FUNCTION.",& usage="q {integer}",default_i_val=16,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LAMBDA",& variants=(/"LAMBDA"/),& description="Specify the LAMBDA parameter in the hydronium function.",& usage="LAMBDA {real}",default_r_val=10.0_dp,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_hydronium_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_colvar_rmsd_section(section,error) + SUBROUTINE create_colvar_rmsd_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_rmsd_section', & routineP = moduleN//':'//routineN @@ -1596,14 +1511,13 @@ SUBROUTINE create_colvar_rmsd_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="rmsd",& description="Section to define a CV as function of RMSD computed with respect to"//& " given reference configurations. For 2 configurations the colvar is equal to:"//& " ss = (RMSDA-RMSDB)/(RMSDA+RMSDB), while if only 1 configuration is given, then the"//& " colvar is just the RMSD from that frame.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection, subsubsection) CALL keyword_create(keyword, name="SUBSET_TYPE",& @@ -1611,48 +1525,48 @@ SUBROUTINE create_colvar_rmsd_section(section,error) usage="SUBSET_TYPE ALL",& enum_c_vals=s2a( "ALL","LIST", "WEIGHT_LIST"),& enum_i_vals=(/ rmsd_all, rmsd_list, rmsd_weightlist/),& - default_i_val=rmsd_all, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=rmsd_all) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALIGN_FRAMES",& description="Whether the reference frames should be aligned to minimize the RMSD",& usage="ALIGN_FRAME",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specify indexes of atoms building the subset. ",& usage="ATOMS {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHTS",& description="Specify weights of atoms building the subset. ",& usage="weightS {real} {real} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="FRAME",& description="Specify coordinates of the frame (number of frames can be either 1 or 2)",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword, name="COORD_FILE_NAME",& description="Name of the xyz file with coordinates (alternative to &COORD section)",& usage="COORD_FILE_NAME ",& - default_lc_val="",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL create_coord_section_cv(subsubsection,"RMSD",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + CALL create_coord_section_cv(subsubsection,"RMSD") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_rmsd_section @@ -1661,13 +1575,10 @@ END SUBROUTINE create_colvar_rmsd_section !> \brief collective variables specifying the space orthogonal to the reaction path !> in the space spanned by the involved collective coordinates !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff ! ***************************************************************************** - SUBROUTINE create_colvar_rpath_section(section,error) + SUBROUTINE create_colvar_rpath_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_rpath_section', & routineP = moduleN//':'//routineN @@ -1676,29 +1587,25 @@ SUBROUTINE create_colvar_rpath_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="REACTION_PATH",& description="Section defining a one dimensional reaction path in an Q-dimensional space of colvars. "//& "Constraining this colvar, allows to sample the space orthogonal to the reaction path, "//& "both in the Q-dimensional colvar and 3N-Q remaining coordinates. "//& "For the details of the function see cited literature.",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/Branduardi2007/), & - error=error) + citations=(/Branduardi2007/)) - CALL keywords_colvar_path(section,error) + CALL keywords_colvar_path(section) END SUBROUTINE create_colvar_rpath_section ! ***************************************************************************** !> \brief Distance from reaction path !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author 01.2010 ! ***************************************************************************** - SUBROUTINE create_colvar_dpath_section(section,error) + SUBROUTINE create_colvar_dpath_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_dpath_section', & routineP = moduleN//':'//routineN @@ -1706,7 +1613,7 @@ SUBROUTINE create_colvar_dpath_section(section,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DISTANCE_FROM_PATH",& description="Section defining the distance from a one dimensional reaction "//& "path in an Q-dimensional space of colvars. "//& @@ -1714,23 +1621,19 @@ SUBROUTINE create_colvar_dpath_section(section,error) "both in the Q-dimensional colvar and 3N-Q remaining coordinates. "//& "For the details of the function see cited literature.",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/Branduardi2007/), & - error=error) + citations=(/Branduardi2007/)) - CALL keywords_colvar_path(section,error) + CALL keywords_colvar_path(section) END SUBROUTINE create_colvar_dpath_section ! ***************************************************************************** !> \brief Section describinf keywords for both reaction path and distance from reaction path !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author 01.2010 ! ***************************************************************************** - SUBROUTINE keywords_colvar_path(section,error) + SUBROUTINE keywords_colvar_path(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'keywords_colvar_path', & routineP = moduleN//':'//routineN @@ -1740,23 +1643,23 @@ SUBROUTINE keywords_colvar_path(section,error) subsubsection NULLIFY(keyword, subsection, subsubsection, print_key) - CALL create_colvar_section(subsection,skip_recursive_colvar=.TRUE.,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_section(subsection,skip_recursive_colvar=.TRUE.) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="DISTANCES_RMSD",& description=" ",& usage="DISTANCES_RMSD T", & - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMSD",& description=" ",& usage="RMSD T", & - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SUBSET_TYPE",& @@ -1764,58 +1667,58 @@ SUBROUTINE keywords_colvar_path(section,error) usage="SUBSET_TYPE ALL",& enum_c_vals=s2a( "ALL","LIST"),& enum_i_vals=(/ rmsd_all, rmsd_list/),& - default_i_val=rmsd_all, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=rmsd_all) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALIGN_FRAMES",& description="Whether the reference frames should be aligned to minimize the RMSD",& usage="ALIGN_FRAME",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specify indexes of atoms building the subset. ",& usage="ATOMS {integer} {integer} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="FRAME",& description="Specify coordinates of the frame",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword, name="COORD_FILE_NAME",& description="Name of the xyz file with coordinates (alternative to &COORD section)",& usage="COORD_FILE_NAME ",& - default_lc_val="",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL create_coord_section_cv(subsubsection,"RMSD",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + CALL create_coord_section_cv(subsubsection,"RMSD") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="FUNCTION",& description="Specifies the ith element of the vector valued function that defines the reaction path. "//& "This keyword needs to repeat exactly Q times, and the order must match the order of the colvars. "//& "The VARIABLE (e.g. T) which parametrises the curve can be used as the target of a constraint.",& usage="FUNCTION (sin(T+2)+2*T)", type_of_var=lchar_t,& - n_var=1, default_lc_val="0",repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, default_lc_val="0",repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VARIABLE",& description="Specifies the name of the variable that parametrises the FUNCTION "//& "defining the reaction path.",& usage="VARIABLE T", type_of_var=char_t,& - n_var=1, repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LAMBDA",& description="Specifies the exponent of the Gaussian used in the integral representation of the colvar."//& @@ -1823,63 +1726,57 @@ SUBROUTINE keywords_colvar_path(section,error) "In the limit of large values, it is given by the plane orthogonal to the path."//& "In practice, modest values are required for stable numerical integration.",& usage="LAMBDA {real}",& - type_of_var=real_t,default_r_val=5.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_val=5.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEP_SIZE",& description="Step size in the numerical integration, "//& "a few thousand points are common, and the proper number also depends on LAMBDA.",& usage="STEP_SIZE {real}",& - type_of_var=real_t,default_r_val=0.01_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_val=0.01_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="RANGE",& description="The range of VARIABLE used for the parametrisation.",& usage="RANGE ",& - n_var=2,type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,name="MAP",& description="Activating this print key will print once a file with the values of the FUNCTION on a grid "//& "of COLVAR values in a specified range. "//& "GRID_SPACING and RANGE for every COLVAR has to be specified again in the same order as they are in the input.", & - print_level=high_print_level,filename="PATH",& - error=error) + print_level=high_print_level,filename="PATH") CALL keyword_create(keyword,name="RANGE",& description="The range of of the grid of the COLVAR.",& usage="RANGE ",& - n_var=2,type_of_var=real_t,repeats=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,type_of_var=real_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GRID_SPACING",& description="Distance between two gridpoints for the grid on the COLVAR",& usage="STEP_SIZE {real}",repeats=.TRUE.,& - type_of_var=real_t,default_r_val=0.01_dp, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_val=0.01_dp) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE keywords_colvar_path ! ***************************************************************************** !> \brief Colvar allowing a combination of COLVARS !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - 12.2008 ! ***************************************************************************** - SUBROUTINE create_colvar_comb_section(section,error) + SUBROUTINE create_colvar_comb_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_comb_section', & routineP = moduleN//':'//routineN @@ -1890,17 +1787,16 @@ SUBROUTINE create_colvar_comb_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="COMBINE_COLVAR",& description="Allows the possibility to combine several COLVARs into one COLVAR "//& "with a generic function.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) - CALL create_colvar_section(subsection,skip_recursive_colvar=.TRUE.,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_section(subsection,skip_recursive_colvar=.TRUE.) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="FUNCTION",& description="Specifies the function used to combine different COLVARs into one.",& @@ -1914,45 +1810,45 @@ SUBROUTINE create_colvar_comb_section(section,error) !> \param error=error ... ! ***************************************************************************** usage="FUNCTION SQRT(CV1^2+CV2^2)", type_of_var=lchar_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VARIABLES",& description="Specifies the name of the variable that parametrises the FUNCTION "//& "defining how COLVARS should be combined. The matching follows the same order of the "//& "COLVARS definition in the input file.",& - usage="VARIABLE CV1 CV2 CV3", type_of_var=char_t,n_var=-1, repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="VARIABLE CV1 CV2 CV3", type_of_var=char_t,n_var=-1, repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARAMETERS",& description="Defines the parameters of the functional form",& usage="PARAMETERS a b D", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VALUES",& description="Defines the values of parameter of the functional form",& usage="VALUES ", type_of_var=real_t,& - n_var=-1, repeats=.TRUE., unit_str="internal_cp2k", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE., unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DX",& description="Parameter used for computing the derivative of the combination "//& "of COLVARs with the Ridders' method.",& - usage="DX ", default_r_val=0.1_dp, unit_str="bohr", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DX ", default_r_val=0.1_dp, unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ERROR_LIMIT",& description="Checks that the error in computing the derivative is not larger than "//& "the value set; in case error is larger a warning message is printed.",& - usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_colvar_comb_section @@ -1960,14 +1856,11 @@ END SUBROUTINE create_colvar_comb_section !> \brief Creates the coord section !> \param section the section to create !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_coord_section_cv(section,name,error) + SUBROUTINE create_coord_section_cv(section,name) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_coord_section_cv', & routineP = moduleN//':'//routineN @@ -1977,31 +1870,27 @@ SUBROUTINE create_coord_section_cv(section,name,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="coord",& description="The positions for "//TRIM(name)//" used for restart",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify positions of the system",repeats=.TRUE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_coord_section_cv ! ***************************************************************************** !> \brief collective variables specifying h bonds !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author alin m elena ! ***************************************************************************** - SUBROUTINE create_colvar_wc_section(section,error) + SUBROUTINE create_colvar_wc_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_wc_section', & routineP = moduleN//':'//routineN @@ -2012,33 +1901,32 @@ SUBROUTINE create_colvar_wc_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="wc",& description="Section to define the hbond wannier centre as a collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="RCUT",& description="Parameter used for computing the cutoff radius for searching "//& "the wannier centres around an atom",& usage="RCUT ", default_r_val=0.529177208590000_dp, unit_str="angstrom",& - type_of_var=real_t,repeats=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& variants=(/"POINTS"/),& description="Specifies the indexes of atoms/points defining the bond (Od, H, Oa).",& usage="ATOMS {integer} {integer} {integer}",& - n_var=3, type_of_var=integer_t,repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3, type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_wc_section @@ -2047,13 +1935,10 @@ END SUBROUTINE create_colvar_wc_section ! ***************************************************************************** !> \brief collective variables specifying h bonds= wire !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author alin m elena ! ***************************************************************************** - SUBROUTINE create_colvar_hbp_section(section,error) + SUBROUTINE create_colvar_hbp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_colvar_hbp_section', & routineP = moduleN//':'//routineN @@ -2064,47 +1949,46 @@ SUBROUTINE create_colvar_hbp_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="hbp",& description="Section to define the hbond wannier centre as a collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="RCUT",& description="Parameter used for computing the cutoff radius for searching "//& "the wannier centres around an atom",& usage="RCUT ", default_r_val=0.529177208590000_dp, unit_str="angstrom",& - type_of_var=real_t,repeats=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHIFT",& description="Parameter used for shifting each term in the sum ", & usage="SHIFT ", default_r_val=0.5_dp,& - type_of_var=real_t,repeats=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NPOINTS",& description="The number of points in the path",& usage="NPOINTS {integer}",default_i_val=-1,& - n_var=1,type_of_var=integer_t,repeats=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=integer_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& variants=(/"POINTS"/),& description="Specifies the indexes of atoms/points defining the bond (Od, H, Oa).",& usage="ATOMS {integer} {integer} {integer}",& - n_var=3, type_of_var=integer_t,repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3, type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_hbp_section @@ -2113,14 +1997,10 @@ END SUBROUTINE create_colvar_hbp_section !> \brief collective variables specifying ring puckering !> \brief D. Cremer and J.A. Pople, JACS 97 1354 (1975) !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Marcel Baer ! ***************************************************************************** - SUBROUTINE create_colvar_ring_puckering_section(section,error) + SUBROUTINE create_colvar_ring_puckering_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_colvar_ring_puckering_section', & @@ -2132,11 +2012,10 @@ SUBROUTINE create_colvar_ring_puckering_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RING_PUCKERING",& description="Section to define general ring puckering collective variables.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -2145,9 +2024,9 @@ SUBROUTINE create_colvar_ring_puckering_section(section,error) description="Specifies the indexes of atoms/points defining the ring."//& "At least 4 Atoms are needed.",& usage="ATOMS {integer} {integer} {integer} ..",& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COORDINATE",& description="Indicate the coordinate to be used. Follow the Cremer-Pople definition for a N ring."//& @@ -2155,14 +2034,14 @@ SUBROUTINE create_colvar_ring_puckering_section(section,error) "2..[N/2] are puckering coordinates."//& "-2..-[N/2-1] are puckering angles.",& usage="COORDINATE {integer}",default_i_val=0,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Must be present in each colvar and handled properly - CALL create_point_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_point_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_colvar_ring_puckering_section diff --git a/src/input_cp2k_constraints.F b/src/input_cp2k_constraints.F index 7ec1d150a1..622c0f5e46 100644 --- a/src/input_cp2k_constraints.F +++ b/src/input_cp2k_constraints.F @@ -53,13 +53,10 @@ MODULE input_cp2k_constraints !> \brief Create the constraint section. This section is useful to impose !> constraints !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_constraint_section(section,error) + SUBROUTINE create_constraint_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_constraint_section', & routineP = moduleN//':'//routineN @@ -70,87 +67,86 @@ SUBROUTINE create_constraint_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="constraint",& description="Section specifying information regarding how to impose constraints"// & " on the system.",& - n_keywords=0, n_subsections=2, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=2, repeats=.FALSE.) NULLIFY(subsection, keyword, print_key) CALL keyword_create(keyword, name="SHAKE_TOLERANCE",& variants=s2a("SHAKE_TOL","SHAKE"),& description="Set the tolerance for the shake/rattle constraint algorithm.",& usage="SHAKE_TOLERANCE ",& - default_r_val=1.0E-6_dp, unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-6_dp, unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROLL_TOLERANCE",& variants=s2a("ROLL_TOL","ROLL"),& description="Set the tolerance for the roll constraint algorithm.",& usage="ROLL_TOLERANCE ",& - default_r_val=1.0E-10_dp,unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-10_dp,unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CONSTRAINT_INIT",& description="Apply constraints to the initial position and velocities."//& " Default is to apply constraints only after the first MD step.",& usage="CONSTRAINT_INIT ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - - CALL create_hbonds_section(subsection, error=error) - CALL restraint_info_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) - - CALL create_g3x3_section(subsection, error=error) - CALL restraint_info_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) - - CALL create_g4x6_section(subsection, error=error) - CALL restraint_info_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) - - CALL create_vsite_section(subsection, error=error) - CALL restraint_info_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) - - CALL create_collective_section(subsection, error=error) - CALL restraint_info_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) - - CALL create_fixed_atom_section(subsection, error=error) - CALL restraint_info_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) - - CALL create_f_a_rest_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) - - CALL create_clv_rest_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + + CALL create_hbonds_section(subsection) + CALL restraint_info_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL create_g3x3_section(subsection) + CALL restraint_info_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL create_g4x6_section(subsection) + CALL restraint_info_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL create_vsite_section(subsection) + CALL restraint_info_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL create_collective_section(subsection) + CALL restraint_info_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL create_fixed_atom_section(subsection) + CALL restraint_info_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL create_f_a_rest_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) + + CALL create_clv_rest_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(print_key,"constraint_info",& description="Prints information about iterative constraints solutions",& - print_level=high_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"lagrange_multipliers",& description="Prints out the lagrange multipliers of the specified constraints during an MD.",& - print_level=high_print_level, filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level, filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_constraint_section @@ -160,13 +156,10 @@ END SUBROUTINE create_constraint_section !> This section will be only used for restraint restarts. !> Constraints are handled automatically !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE create_clv_rest_section(section, error) + SUBROUTINE create_clv_rest_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_clv_rest_section', & routineP = moduleN//':'//routineN @@ -175,20 +168,19 @@ SUBROUTINE create_clv_rest_section(section, error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY( keyword) CALL section_create(section,name="COLVAR_RESTART",& description="Specify restart position only for COLVAR restraints.",& - n_subsections=0, repeats=.FALSE., & - error=error) + n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The restarting values for COLVAR restraints."//& " The order is an internal order. So if you decide to modify these values by hand"//& " first think what you're doing!",repeats=.TRUE.,& - usage="{Real}", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real}", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_clv_rest_section @@ -198,13 +190,10 @@ END SUBROUTINE create_clv_rest_section !> This section will be only used for restraint restarts. !> Constraints are handled automatically !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE create_f_a_rest_section(section, error) + SUBROUTINE create_f_a_rest_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_f_a_rest_section', & routineP = moduleN//':'//routineN @@ -213,20 +202,19 @@ SUBROUTINE create_f_a_rest_section(section, error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY( keyword) CALL section_create(section,name="FIX_ATOM_RESTART",& description="Specify restart position only for FIXED_ATOMS restraints.",& - n_subsections=0, repeats=.FALSE., & - error=error) + n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The restarting position of fixed atoms for restraints."//& " The order is an internal order. So if you decide to modify these values by hand"//& " first think what you're doing!",repeats=.TRUE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_f_a_rest_section @@ -234,13 +222,10 @@ END SUBROUTINE create_f_a_rest_section ! ***************************************************************************** !> \brief Create the restraint info section in the constraint section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE restraint_info_section(section, error) + SUBROUTINE restraint_info_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'restraint_info_section', & routineP = moduleN//':'//routineN @@ -251,36 +236,32 @@ SUBROUTINE restraint_info_section(section, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(subsection, keyword) CALL section_create(subsection,name="RESTRAINT",& description="Activate and specify information on restraint instead of constraint",& - n_subsections=0, repeats=.FALSE., & - error=error) + n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="K",& description="Specifies the force constant for the harmonic restraint. The functional "//& "form for the restraint is: K*(X-TARGET)^2.",& usage="K {real}",& - type_of_var=real_t, default_r_val=0.0_dp, unit_str="internal_cp2k",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, default_r_val=0.0_dp, unit_str="internal_cp2k") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE restraint_info_section ! ***************************************************************************** !> \brief Create the constraint section for collective constraints !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele [01.2006] ! ***************************************************************************** - SUBROUTINE create_collective_section(section,error) + SUBROUTINE create_collective_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_collective_section', & routineP = moduleN//':'//routineN @@ -290,80 +271,79 @@ SUBROUTINE create_collective_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="COLLECTIVE",& description="Used to constraint collective (general) degrees of freedom, "//& "writing langrangian multipliers to file.",& - n_subsections=0, repeats=.TRUE., & - error=error) + n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="COLVAR",& description="Specifies the index (in input file order) of the type of colvar to constrain.",& usage="COLVAR {int}",& - type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLECULE",& description="Specifies the index of the molecule kind (in input file order)"//& "on which the constraint will be applied."//& " MOLECULE and MOLNAME keyword exclude themself mutually.",& - usage="MOLECULE {integer}", n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOLECULE {integer}", n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLNAME",& variants=(/"SEGNAME"/),& description="Specifies the name of the molecule on which the constraint will be applied.",& - usage="MOLNAME {character}", n_var=1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOLNAME {character}", n_var=1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTERMOLECULAR",& description="Specify if the constraint/restraint is intermolecular.",& usage="INTERMOLECULAR ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET",& description="Specifies the target value of the constrained collective"//& " variable (units depend on the colvar).",& usage="TARGET {real}",& - type_of_var=real_t, unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET_GROWTH",& description="Specifies the growth speed of the target value of the constrained collective"//& " variable.",& usage="TARGET_GROWTH {real}",& - default_r_val=0.0_dp, unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp, unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET_LIMIT",& description="Specifies the limit of the growth of the target value of the constrained collective"//& " variable. By default no limit at the colvar growth is set.",& usage="TARGET_LIMIT {real}",type_of_var=real_t,& - unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_QM",& description="Does not apply the constraint to the QM region within a QM/MM calculation",& usage="EXCLUDE_QM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_MM",& description="Does not apply the constraint to the MM region within a QM/MM calculation",& usage="EXCLUDE_MM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_collective_section @@ -371,13 +351,10 @@ END SUBROUTINE create_collective_section ! ***************************************************************************** !> \brief Create the constraint section that fixes atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_fixed_atom_section(section,error) + SUBROUTINE create_fixed_atom_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_fixed_atom_section', & routineP = moduleN//':'//routineN @@ -386,12 +363,12 @@ SUBROUTINE create_fixed_atom_section(section,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="fixed_atoms",& description="This section is used to constraint the overall atomic position (X,Y,Z). In case "//& "a restraint is specified the value of the TARGET is considered to be the value of the "//& "coordinates at the beginning of the run or alternatively the corresponding value in the section: "//& - "FIX_ATOM_RESTART.",n_keywords=3, n_subsections=0, repeats=.TRUE., error=error) + "FIX_ATOM_RESTART.",n_keywords=3, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) ! Section Parameter @@ -411,25 +388,25 @@ SUBROUTINE create_fixed_atom_section(section,error) "Fix X-Z components",& "Fix Y-Z components",& "Fix the full components of the atomic position."),& - repeats=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Integer CALL keyword_create(keyword, name="LIST",& description="Specifies a list of atoms to freeze.",& usage="LIST {integer} {integer} .. {integer}", repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLNAME",& variants=(/"SEGNAME"/),& description="Specifies the name of the molecule to fix",& usage="MOLNAME WAT MEOH", repeats=.TRUE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MM_SUBSYS",& variants=(/"PROTEIN"/),& @@ -440,9 +417,9 @@ SUBROUTINE create_fixed_atom_section(section,error) enum_desc=s2a("fix nothing",& "only the MM atoms itself",& "the full molecule/residue that contains a MM atom (i.e. some QM atoms might be fixed as well)"),& - default_i_val=do_constr_none,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_constr_none,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="QM_SUBSYS",& description="In a QM/MM run all QM atoms are fixed according to the argument.",& @@ -452,25 +429,25 @@ SUBROUTINE create_fixed_atom_section(section,error) "only the QM atoms itself",& "the full molecule/residue that contains a QM atom (i.e. some MM atoms might be fixed as well)"),& enum_i_vals=(/do_constr_none,do_constr_atomic,do_constr_molec/),& - default_i_val=do_constr_none,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_constr_none,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_QM",& description="Does not apply the constraint to the QM region within a QM/MM calculation."//& " This keyword is active only together with MOLNAME",& usage="EXCLUDE_QM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_MM",& description="Does not apply the constraint to the MM region within a QM/MM calculation."//& " This keyword is active only together with MOLNAME",& usage="EXCLUDE_MM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_fixed_atom_section @@ -478,13 +455,10 @@ END SUBROUTINE create_fixed_atom_section ! ***************************************************************************** !> \brief Create the constraint section specialized on g3x3 constraints !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_g3x3_section(section,error) + SUBROUTINE create_g3x3_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_g3x3_section', & routineP = moduleN//':'//routineN @@ -494,11 +468,10 @@ SUBROUTINE create_g3x3_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="g3x3",& description="This section is used to set 3x3 (3 atoms and 3 distances) constraints.",& - n_keywords=3, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -507,65 +480,62 @@ SUBROUTINE create_g3x3_section(section,error) variants=(/"MOL"/),& description="Specifies the molecule kind number on which constraint will be applied."//& " MOLECULE and MOLNAME keyword exclude themself mutually.",& - usage="MOL {integer}", n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOL {integer}", n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLNAME",& variants=(/"SEGNAME"/),& description="Specifies the name of the molecule on which the constraint will be applied.",& - usage="MOLNAME {character}", n_var=1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOLNAME {character}", n_var=1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTERMOLECULAR",& description="Specify if the constraint/restraint is intermolecular.",& usage="INTERMOLECULAR ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Atoms' index on which apply the constraint", usage="ATOMS 1 3 6",& - n_var=-1,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Real CALL keyword_create(keyword, name="DISTANCES",& description="The constrained distances' values.",& usage="DISTANCES {real} {real} {real}", type_of_var=real_t,& - unit_str="internal_cp2k",n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="internal_cp2k",n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Logical CALL keyword_create(keyword, name="EXCLUDE_QM",& description="Does not apply the constraint to the QM region within a QM/MM calculation",& usage="EXCLUDE_QM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_MM",& description="Does not apply the constraint to the MM region within a QM/MM calculation",& usage="EXCLUDE_MM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_g3x3_section ! ***************************************************************************** !> \brief Create the constraint section specialized on H BONDS constraints !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_hbonds_section(section,error) + SUBROUTINE create_hbonds_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_hbonds_section', & routineP = moduleN//':'//routineN @@ -575,11 +545,10 @@ SUBROUTINE create_hbonds_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="HBONDS",& description="This section is used to set bonds constraints involving Hydrogen atoms",& - n_keywords=3, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) ! Character @@ -587,48 +556,48 @@ SUBROUTINE create_hbonds_section(section,error) description="Defines the atoms' type forming a bond with an hydrogen. If not specified "//& " the default bond value of the first molecule is used as constraint target",& usage="ATOMS ",& - n_var=-1,type_of_var=char_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLECULE",& description="Specifies the indexes of the molecule kind (in input file order)"//& "on which the constraint will be applied."//& " MOLECULE and MOLNAME keyword exclude themself mutually.",& usage="MOLECULE {integer} .. {integer} ", n_var=-1,& - type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLNAME",& variants=(/"SEGNAME"/),& description="Specifies the names of the molecule on which the constraint will be applied.",& usage="MOLNAME {character} .. {character} ", n_var=-1,& - type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_QM",& description="Does not shake HBONDS in the QM region within a QM/MM calculation",& usage="EXCLUDE_QM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_MM",& description="Does not shake HBONDS in the MM region within a QM/MM calculation",& usage="EXCLUDE_MM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Real CALL keyword_create(keyword, name="TARGETS",& description="The constrained distances' values for the types defines in ATOM_TYPE.",& usage="TARGETS {real} {real} {real}", type_of_var=real_t, n_var=-1,& - unit_str="internal_cp2k", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_hbonds_section @@ -636,13 +605,10 @@ END SUBROUTINE create_hbonds_section ! ***************************************************************************** !> \brief Create the constraint section specialized on g4x6 constraints !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_g4x6_section(section,error) + SUBROUTINE create_g4x6_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_g4x6_section', & routineP = moduleN//':'//routineN @@ -652,11 +618,10 @@ SUBROUTINE create_g4x6_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="g4x6",& description="This section is used to set 4x6 (4 atoms and 6 distances) constraints.",& - n_keywords=3, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -665,65 +630,62 @@ SUBROUTINE create_g4x6_section(section,error) variants=(/"MOL"/),& description="Specifies the molecule number on which constraint will be applied."//& " MOLECULE and MOLNAME keyword exclude themself mutually.",& - usage="MOL {integer}", n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOL {integer}", n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLNAME",& variants=(/"SEGNAME"/),& description="Specifies the name of the molecule on which the constraint will be applied.",& - usage="MOLNAME {character}", n_var=1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOLNAME {character}", n_var=1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTERMOLECULAR",& description="Specify if the constraint/restraint is intermolecular.",& usage="INTERMOLECULAR ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Atoms' index on which apply the constraint", usage="ATOMS 1 3 6 4",& - n_var=4,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Real CALL keyword_create(keyword, name="DISTANCES",& description="The constrained distances' values.",& usage="DISTANCES {real} {real} {real} {real} {real} {real}",& - type_of_var=real_t, n_var=6,unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=6,unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Logical CALL keyword_create(keyword, name="EXCLUDE_QM",& description="Does not apply the constraint to the QM region within a QM/MM calculation",& usage="EXCLUDE_QM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_MM",& description="Does not apply the constraint to the MM region within a QM/MM calculation",& usage="EXCLUDE_MM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_g4x6_section ! ***************************************************************************** !> \brief Create the constraint section specialized on vsite constraints !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author marcel baer ! ***************************************************************************** - SUBROUTINE create_vsite_section(section,error) + SUBROUTINE create_vsite_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_vsite_section', & routineP = moduleN//':'//routineN @@ -733,11 +695,10 @@ SUBROUTINE create_vsite_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="virtual_site",& description="This section is used to set a virtual interaction-site constraint.",& - n_keywords=3, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -746,54 +707,54 @@ SUBROUTINE create_vsite_section(section,error) variants=(/"MOL"/),& description="Specifies the molecule number on which constraint will be applied."//& " MOLECULE and MOLNAME keyword exclude themself mutually.",& - usage="MOL {integer}", n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOL {integer}", n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLNAME",& variants=(/"SEGNAME"/),& description="Specifies the name of the molecule on which the constraint will be applied.",& - usage="MOLNAME {character}", n_var=1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MOLNAME {character}", n_var=1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTERMOLECULAR",& description="Specify if the constraint/restraint is intermolecular.",& usage="INTERMOLECULAR ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Atoms' index on which apply the constraint (v i j k), first is virtual site",& usage="ATOMS 1 2 3 4",& - n_var=4,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Real CALL keyword_create(keyword, name="PARAMETERS",& description="The constrained paramters' values to construct virtual site."//& "r_v=a*r_ij+b*r_kj",& usage="PARAMETERS {real} {real}",& - type_of_var=real_t, n_var=2,unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=2,unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Logical CALL keyword_create(keyword, name="EXCLUDE_QM",& description="Does not apply the constraint to the QM region within a QM/MM calculation",& usage="EXCLUDE_QM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_MM",& description="Does not apply the constraint to the MM region within a QM/MM calculation",& usage="EXCLUDE_MM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_vsite_section END MODULE input_cp2k_constraints diff --git a/src/input_cp2k_dft.F b/src/input_cp2k_dft.F index cb2c054261..25d2355782 100644 --- a/src/input_cp2k_dft.F +++ b/src/input_cp2k_dft.F @@ -148,13 +148,10 @@ MODULE input_cp2k_dft ! ***************************************************************************** !> \brief creates the dft section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_dft_section(section,error) + SUBROUTINE create_dft_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_dft_section', & routineP = moduleN//':'//routineN @@ -165,37 +162,35 @@ SUBROUTINE create_dft_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="dft",& description="parameter needed by dft programs",& - n_keywords=3, n_subsections=4, repeats=.FALSE., & - error=error) + n_keywords=3, n_subsections=4, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="BASIS_SET_FILE_NAME",& description="Name of the basis set file, may include a path",& usage="BASIS_SET_FILE_NAME ",& type_of_var=lchar_t,repeats=.TRUE.,& - default_lc_val="BASIS_SET",n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="BASIS_SET",n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POTENTIAL_FILE_NAME",& description="Name of the pseudo potential file, may include a path",& usage="POTENTIAL_FILE_NAME ",& - default_lc_val="POTENTIAL",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="POTENTIAL") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WFN_RESTART_FILE_NAME",& variants=(/"RESTART_FILE_NAME"/),& description="Name of the wavefunction restart file, may include a path."//& " If no file is specified, the default is to open the file as generated by the wfn restart print key.",& usage="WFN_RESTART_FILE_NAME ",& - type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="UKS",& @@ -206,20 +201,18 @@ SUBROUTINE create_dft_section(section,error) "and beta orbitals, i.e. no spin restriction is applied",& usage="LSD",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="ROKS",& variants=(/"RESTRICTED_OPEN_KOHN_SHAM"/),& description="Requests a restricted open Kohn-Sham calculation",& usage="ROKS",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="MULTIPLICITY",& variants=(/"MULTIP"/),& @@ -229,25 +222,24 @@ SUBROUTINE create_dft_section(section,error) "even number and 2 (doublet) for an odd number "//& "of electrons.",& usage="MULTIPLICITY 3",& - default_i_val=0,& ! this default value is just a flag to get the above - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) ! this default value is just a flag to get the above + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE",& description="The total charge of the system",& usage="CHARGE -1",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCITATIONS",& description="If excitations should be calculated",& usage="EXCITATIONS",& enum_c_vals=s2a("NONE","TDLR","TDDFPT"),& enum_i_vals=(/ no_excitations, tddfpt_excitations, & tddfpt_excitations/),& - default_i_val=no_excitations, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=no_excitations) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="PLUS_U_METHOD",& @@ -263,10 +255,9 @@ SUBROUTINE create_dft_section(section,error) "Method based on Mulliken gross orbital populations (GOP)"),& n_var=1,& default_i_val=plus_u_mulliken,& - usage="METHOD Lowdin",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="METHOD Lowdin") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="RELAX_MULTIPLICITY",& @@ -279,17 +270,16 @@ SUBROUTINE create_dft_section(section,error) "Kohn-Sham (UKS) calculations.",& usage="RELAX_MULTIPLICITY 0.00001",& repeats=.FALSE.,& - default_r_val=0.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SUBCELLS",& description="Read the grid size for subcell generation in the construction of "//& "neighbor lists.", usage="SUBCELLS 1.5",& - n_var=1,default_r_val=2.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_r_val=2.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="SURFACE_DIPOLE_CORRECTION",& @@ -302,10 +292,9 @@ SUBROUTINE create_dft_section(section,error) usage="SURF_DIP",& default_l_val=.FALSE.,& lone_keyword_l_val=.TRUE.,& - citations=(/Bengtsson1999/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/Bengtsson1999/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="SURF_DIP_DIR",& @@ -315,132 +304,128 @@ SUBROUTINE create_dft_section(section,error) enum_desc=s2a("Along x", "Along y", "Along z"),& n_var=1,& default_i_val=3,& - usage="SURF_DIP_DIR Z",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SURF_DIP_DIR Z") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_scf_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_scf_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_ls_scf_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ls_scf_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_almo_scf_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_almo_scf_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_kg_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_kg_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_admm_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_admm_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_qs_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_qs_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_tddfpt_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_tddfpt_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_mgrid_section(subsection,error=error) - CALL section_add_subsection(section, subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mgrid_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_xc_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_xc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_relativistic_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_relativistic_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_sic_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_sic_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_low_spin_roks_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_low_spin_roks_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_efield_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_efield_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_per_efield_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_per_efield_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_ext_pot_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ext_pot_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_transport_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_transport_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! ZMP sections to include the external density or v_xc potential - CALL create_ext_den_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ext_den_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_ext_vxc_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ext_vxc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_poisson_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_poisson_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_kpoints_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_kpoints_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_implicit_solv_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_implicit_solv_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_density_fitting_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_density_fitting_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_xas_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_xas_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_localize_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_localize_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_rtp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_rtp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_print_dft_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_print_dft_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_sccs_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_sccs_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_dft_section ! ***************************************************************************** !> \brief Implicit Solvation Model !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_implicit_solv_section(section,error) + SUBROUTINE create_implicit_solv_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_implicit_solv_section', & routineP = moduleN//':'//routineN @@ -452,50 +437,45 @@ SUBROUTINE create_implicit_solv_section(section,error) failure=.FALSE. NULLIFY(keyword, subsection, print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SCRF",& description="Adds an implicit solvation model to the DFT calculation."//& " Know also as Self Consistent Reaction Field.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,name="EPS_OUT",& description="Value of the dielectric constant outside the sphere",& usage="EPS_OUT ",& - default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="LMAX",& description="Maximum value of L used in the multipole expansion",& usage="LMAX ",& - default_i_val=3,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_sphere_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_sphere_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing basic info about the method", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_implicit_solv_section ! ***************************************************************************** !> \brief Create Sphere cavity !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_sphere_section(section,error) + SUBROUTINE create_sphere_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_sphere_section', & routineP = moduleN//':'//routineN @@ -507,36 +487,32 @@ SUBROUTINE create_sphere_section(section,error) failure=.FALSE. NULLIFY(keyword, subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SPHERE",& description="Treats the implicit solvent environment like a sphere",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,name="RADIUS",& description="Value of the spherical cavity in the dielectric medium",& usage="RADIUS ",& unit_str="angstrom",& - type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_center_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_center_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_sphere_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_center_section(section,error) + SUBROUTINE create_center_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_center_section', & routineP = moduleN//':'//routineN @@ -547,26 +523,25 @@ SUBROUTINE create_center_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CENTER",& description="Defines the center of the sphere.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,name="XYZ",& description="Coordinates of the center of the sphere",& usage="XYZ ",& unit_str="angstrom",& - type_of_var=real_t, n_var=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ATOM_LIST",& description="Defines a list of atoms to define the center of the sphere",& usage="ATOM_LIST .. ",& - type_of_var=integer_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="WEIGHT_TYPE",& description="Defines the weight used to define the center of the sphere"//& @@ -574,30 +549,28 @@ SUBROUTINE create_center_section(section,error) usage="WEIGHT (UNIT|MASS)",& enum_c_vals=(/"UNIT","MASS"/),& enum_i_vals=(/weight_type_unit,weight_type_mass/),& - default_i_val=weight_type_unit,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=weight_type_unit) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="FIXED",& description="Specify if the center of the sphere should be fixed or"//& " allowed to move",& usage="FIXED ",& - default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_center_section ! ***************************************************************************** !> \brief parameters fo the localization of wavefunctions !> \param section ... -!> \param error ... !> \par History !> 03.2005 created [MI] ! ***************************************************************************** - SUBROUTINE create_localize_section(section, error) + SUBROUTINE create_localize_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_localize_section', & routineP = moduleN//':'//routineN @@ -609,80 +582,78 @@ SUBROUTINE create_localize_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword, print_key) CALL section_create(section,name="LOCALIZE",& description="Use one of the available methods to define the localization "//& " and possibly to optimize it to a minimum or a maximum.",& - n_keywords=8, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=8, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the MOS localization procedure",& - usage="&LOCALIZE T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="&LOCALIZE T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER",& description="Maximum number of iterations used for localization methods",& - usage="MAX_ITER 2000", default_i_val=10000, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER 2000", default_i_val=10000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_CRAZY_ANGLE",& description="Largest allowed angle for the crazy rotations algorithm (smaller is slower but more stable).",& - usage="MAX_CRAZY_ANGLE 0.1", unit_str="rad", default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_CRAZY_ANGLE 0.1", unit_str="rad", default_r_val=0.2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CRAZY_SCALE",& description="scale angles",& - usage="CRAZY_SCALE 0.9", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CRAZY_SCALE 0.9", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CRAZY_USE_DIAG",& description="Use diagonalization (slow) or pade based calculation of matrix exponentials.",& - usage="CRAZY_USE_DIAG ", default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CRAZY_USE_DIAG ", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_HISTORY",& description="Generate an improved initial guess based on a history of results, which is useful during MD."//& "Will only work if the number of states to be localized remains constant.",& - usage="USE_HISTORY ", default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="USE_HISTORY ", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_OCCUPATION",& description="Tolerance in the occupation number to select only fully occupied orbitals for the rotation",& - usage="EPS_OCCUPATION 1.E-5", default_r_val=1.0E-8_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_OCCUPATION 1.E-5", default_r_val=1.0E-8_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OUT_ITER_EACH",& description="Every how many iterations of the localization algorithm"//& "(Jacobi) the tolerance value is printed out",& - usage="OUT_ITER_EACH 100", default_i_val=100, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="OUT_ITER_EACH 100", default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_LOCALIZATION",& description="Tolerance used in the convergence criterium of the localization methods.",& - usage="EPS_LOCALIZATION 1.0E-2", default_r_val=1.0E-4_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_LOCALIZATION 1.0E-2", default_r_val=1.0E-4_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="MIN_OR_MAX",& description="Requires the maximization of the spread of the wfn",& usage="MIN_OR_MAX (SPREADMIN|SPREADMAX)",& enum_c_vals=(/"SPREADMIN","SPREADMAX"/),& enum_i_vals=(/do_loc_min, do_loc_max/),& - default_i_val=do_loc_min,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_loc_min) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="METHOD",& description="Method of optimization if any",& @@ -698,61 +669,59 @@ SUBROUTINE create_localize_section(section, error) "A new fast method is applied, might be slightly less robust than jacobi, but usually much faster",& "Steepest descent minimization of an approximate l1 norm",& "Using a direct minimisation approach"),& - default_i_val=do_loc_jacobi,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_loc_jacobi) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="JACOBI_FALLBACK",& description="Use Jacobi method in case no convergence was achieved"//& " by using the crazy rotations method.",& usage="JACOBI_FALLBACK", default_l_val=.TRUE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART",& description="Restart the localization from a set of orbitals"//& " read from a localization restart file.",& usage="RESTART", default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LOCHOMO_RESTART_FILE_NAME",& description="File name where to read the MOS from"//& "which to restart the localization procedure for occupied states",& usage="LOCHOMO_RESTART_FILE_NAME ",& - type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LOCLUMO_RESTART_FILE_NAME",& description="File name where to read the MOS from"//& "which to restart the localization procedure for unoccupied states",& usage="LOCLUMO_RESTART_FILE_NAME ",& - type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="OPERATOR",& description="Type of opertator which defines the spread functional",& usage="OPERATOR (BERRY|BOYS|PIPEK)",& enum_c_vals=s2a("BERRY","BOYS","PIPEK"),& enum_i_vals=(/op_loc_berry, op_loc_boys, op_loc_pipek/),& - default_i_val=op_loc_berry,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=op_loc_berry) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="LIST",& description="Indexes of the occupied wfn to be localized"//& "This keyword can be repeated several times"//& "(useful if you have to specify many indexes).",& usage="LIST 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="LIST_UNOCCUPIED",& description="Indexes of the unoccupied states to be localized, "//& @@ -761,18 +730,18 @@ SUBROUTINE create_localize_section(section, error) "This keyword can be repeated several times"//& "(useful if you have to specify many indexes).",& usage="LIST 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="STATES",& description="Which states to localize, LUMO up to now only available in GPW",& usage="STATES (HOMO|LUMO|ALL)",& enum_c_vals=s2a("OCCUPIED","UNOCCUPIED","ALL"),& enum_i_vals=(/do_loc_homo, do_loc_lumo,do_loc_both/),& - default_i_val=do_loc_homo,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_loc_homo) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="ENERGY_RANGE",& @@ -782,44 +751,42 @@ SUBROUTINE create_localize_section(section, error) usage=" ENERGY_RANGE lower_bound {real}, higher_bound {real}", & repeats=.FALSE.,& n_var=2,default_r_vals=(/0._dp,0._dp/),unit_str='eV',& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_section) CALL section_create(print_section,name="PRINT",& description="Collects all printing options related to the Wannier centers and "//& "properties computed with Wannier centers.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing basic info about the method", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(print_section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(print_section,print_key) + CALL section_release(print_key) ! Add printing of wannier infos - CALL print_wanniers(print_section, error) + CALL print_wanniers(print_section) NULLIFY(subsection) ! Total Dipoles with wannier - CALL create_dipoles_section(subsection,"TOTAL_DIPOLE",debug_print_level+1,error) - CALL section_add_subsection(print_section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_dipoles_section(subsection,"TOTAL_DIPOLE",debug_print_level+1) + CALL section_add_subsection(print_section, subsection) + CALL section_release(subsection) ! Molecular Dipoles with wannier - CALL create_dipoles_section(subsection,"MOLECULAR_DIPOLES",debug_print_level+1,error) - CALL section_add_subsection(print_section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_dipoles_section(subsection,"MOLECULAR_DIPOLES",debug_print_level+1) + CALL section_add_subsection(print_section, subsection) + CALL section_release(subsection) ! Molecular States with wannier - CALL create_molecular_states_section(subsection,error) - CALL section_add_subsection(print_section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_molecular_states_section(subsection) + CALL section_add_subsection(print_section, subsection) + CALL section_release(subsection) ! Wannier States with wannier - CALL create_wannier_states_section(subsection,error) - CALL section_add_subsection(print_section, subsection, error=error) - CALL section_release(subsection,error=error) - CALL section_add_subsection(section,print_section,error=error) - CALL section_release(print_section,error=error) + CALL create_wannier_states_section(subsection) + CALL section_add_subsection(print_section, subsection) + CALL section_release(subsection) + CALL section_add_subsection(section,print_section) + CALL section_release(print_section) END SUBROUTINE create_localize_section @@ -828,13 +795,10 @@ END SUBROUTINE create_localize_section !> \brief Controls the printing of the basic info coming from the LOCALIZE !> section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE print_wanniers(section, error) + SUBROUTINE print_wanniers(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_wanniers', & routineP = moduleN//':'//routineN @@ -844,92 +808,85 @@ SUBROUTINE print_wanniers(section, error) TYPE(section_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(print_key, keyword) CALL cp_print_key_section_create(print_key,"WANNIER_CUBES",& description="Controls the printing of the wannier functions ", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LU_BOUNDS",& variants=(/"CUBES_LU"/),& description="The lower and upper index of the states to be printed as cube",& usage="CUBES_LU_BOUNDS integer integer",& - n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LIST",& description="Indexes of the states to be printed as cube files"//& "This keyword can be repeated several times"//& "(useful if you have to specify many indexes).",& usage="CUBES_LIST 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"WANNIER_CENTERS",& description="Controls the printing of the wannier functions", & print_level=high_print_level,add_last=add_last_numeric,filename="",& - unit_str="angstrom",error=error) + unit_str="angstrom") CALL keyword_create(keyword, name="IONS+CENTERS",& description="prints out the wannier centers together with the particles",& usage="IONS+CENTERS", default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL add_format_keyword(keyword, print_key, pos=.TRUE.,& - description="Specifies the format of the output file when IONS+CENTERS is enabled.",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file when IONS+CENTERS is enabled.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"WANNIER_SPREADS",& description="Controls the printing of the wannier functions", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"LOC_RESTART",& description="Controls the printing of restart file for localized MOS", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE print_wanniers ! ***************************************************************************** !> \brief Create the print dft section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_print_dft_section(section,error) + SUBROUTINE create_print_dft_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_dft_section', & routineP = moduleN//':'//routineN @@ -941,58 +898,51 @@ SUBROUTINE create_print_dft_section(section,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PRINT",& description="Section of possible print options in DFT code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key, keyword, subsection) CALL cp_print_key_section_create(print_key,"PROGRAM_BANNER",& description="Controls the printing of the banner of the MM program",& - print_level=silent_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=silent_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"KINETIC_ENERGY",& description="Controls the printing of the kinetic energy",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"DERIVATIVES",& description="Print all derivatives after the DFT calculation", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword=keyword,& name="ndigits",& description="Specify the number of digits used to print derivatives",& - default_i_val=6,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=6) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key_section=print_key,& name="neighbor_lists",& description="Controls the printing of the neighbor lists",& - print_level=debug_print_level, filename="", unit_str="angstrom",& - error=error) + print_level=debug_print_level, filename="", unit_str="angstrom") CALL keyword_create(keyword=keyword,& name="sab_orb",& description="Activates the printing of the orbital "//& "orbital neighbor lists, "//& "i.e. the overlap neighbor lists",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_aux_fit",& @@ -1000,10 +950,9 @@ SUBROUTINE create_print_dft_section(section,error) "orbital neighbor lists wavefunction fitting basis, "//& "i.e. the overlap neighbor lists",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_aux_fit_vs_orb",& @@ -1011,20 +960,18 @@ SUBROUTINE create_print_dft_section(section,error) "orbital mixed neighbor lists of wavefunction fitting basis, "//& "and the orbital basis, i.e. the overlap neighbor lists",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_scp",& description="Activates the printing of the vdW SCP "//& "neighbor lists ",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_vdw",& @@ -1032,30 +979,27 @@ SUBROUTINE create_print_dft_section(section,error) "neighbor lists (from DFT, DFTB, SE), "//& "i.e. the dispersion neighbor lists",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_cn",& description="Activates the printing of the "//& "neighbor lists used for coordination numbers in vdW DFT-D3",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sac_ae",& description="Activates the printing of the orbital "//& "nuclear attraction neighbor lists (erfc potential)",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sac_ppl",& @@ -1063,10 +1007,9 @@ SUBROUTINE create_print_dft_section(section,error) "GTH-PPL neighbor lists (local part of the "//& "Goedecker-Teter-Hutter pseudo potentials)",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sap_ppnl",& @@ -1074,216 +1017,206 @@ SUBROUTINE create_print_dft_section(section,error) "GTH-PPNL neighbor lists (non-local part of the"//& "Goedecker-Teter-Hutter pseudo potentials)",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sap_oce",& description="Activates the printing of the orbital "//& "PAW-projector neighbor lists (only GAPW)",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_se",& description="Activates the printing of the two-center "//& "neighbor lists for Coulomb type interactions in NDDO ",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_lrc",& description="Activates the printing of the long-range SE correction "//& "neighbor lists (only when doing long-range SE with integral scheme KDSO and KDSO-d)",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_tbe",& description="Activates the printing of the DFTB Ewald "//& "neighbor lists ",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sab_core",& description="Activates the printing of core interaction "//& "neighbor lists ",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="soo_list",& description="Activates the printing of RI orbital-orbital "//& "neighbor lists ",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="sip_list",& description="Activates the printing of RI basis-projector interaction "//& "neighbor lists ",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SUBCELL",& description="Activates the printing of the subcells used for the"//& "generation of neighbor lists.", unit_str="angstrom",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"AO_MATRICES",& description="Controls the printing of the ao (i.e. contracted gaussian) matrices (debug).", & - print_level=debug_print_level,filename="__STD_OUT__",& - error=error) + print_level=debug_print_level,filename="__STD_OUT__") CALL keyword_create(keyword=keyword, name="NDIGITS",& description="Specify the number of digits used to print the AO matrices",& - default_i_val=6, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=6) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORE_HAMILTONIAN",& description="If the printkey is activated controls the printing of the hamiltonian matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DENSITY",& description="If the printkey is activated controls the printing of the density (P) matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KINETIC_ENERGY",& description="If the printkey is activated controls the printing of the kinetic energy matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KOHN_SHAM_MATRIX",& description="If the printkey is activated controls the printing of the kohn-sham matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MATRIX_VXC",& description="If the printkey is activated compute and print the matrix of the exchange and correlation potential."//& "Only the GGA part for GPW is printed",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORTHO",& description="If the printkey is activated controls the printing of the orthogonalization matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OVERLAP",& description="If the printkey is activated controls the printing of the overlap matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FERMI_CONTACT",& description="If the printkey is activated controls the printing of the Fermi contact matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PSO",& description="If the printkey is activated controls the printing of the paramagnetic spin-orbit matrices",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EFG",& description="If the printkey is activated controls the printing of the electric field gradient matrices",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POTENTIAL_ENERGY",& description="If the printkey is activated controls the printing of the potential energy matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OCE_HARD",& description="If the printkey is activated controls the printing of the OCE HARD matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OCE_SOFT",& description="If the printkey is activated controls the printing of the OCE SOFT matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="W_MATRIX",& description="If the printkey is activated controls the printing of the w matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="W_MATRIX_AUX_FIT",& description="If the printkey is activated controls the printing of the w matrix",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DERIVATIVES",& description="If the printkey is activated controls the printing "//& "of derivatives (for the matrixes that support this)",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"MO",& description="Controls the printing of the molecular orbitals."//& "Note that this is only functional with diagonalization based methods, in particular not with OT (see MO_CUBES)", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword, name="Cartesian",& description="If the printkey is activated controls the printing of the mo in the cartesian basis",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EIGENVALUES",variants=s2a("EIGVALS"),& description="If the printkey is activated controls the printing of the eigenvalues of the mos",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EIGENVECTORS",variants=s2a("EIGVECS"),& description="If the printkey is activated controls the printing of the eigenvectors of the mos",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OCCUPATION_NUMBERS",variants=s2a("OCCNUMS"),& description="If the printkey is activated controls the printing of the occupation numbers of the mos",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="NDIGITS",& description="Specify the number of digits used to print the MO eigenvalues and occupation numbers",& - default_i_val=6, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=6) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="MO_INDEX_RANGE",& variants=s2a("MO_RANGE","RANGE"),& @@ -1293,73 +1226,67 @@ SUBROUTINE create_print_dft_section(section,error) n_var=2,& type_of_var=integer_t,& default_i_vals=(/0,0/),& - usage="MO_INDEX_RANGE 10 15",& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + usage="MO_INDEX_RANGE 10 15") + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_mo_cubes_section(print_key,error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL create_mo_cubes_section(print_key) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_stm_section(print_key,error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL create_stm_section(print_key) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_wfn_mix_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_wfn_mix_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="GAPW",& description="Controls the printing of some gapw related information (debug).",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"projectors",& description="If the printkey is activated controls if information on"//& " the projectors is printed.",& - print_level=debug_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"rho0_information",& description="If the printkey is activated controls if information on rho0 is printed.",& - print_level=debug_print_level,filename="__STD_OUT__",unit_str="angstrom",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=debug_print_level,filename="__STD_OUT__",unit_str="angstrom") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(print_key,"dft_control_parameters",& description="Controls the printing of dft control parameters.", & - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"KPOINTS",& description="Controls the printing of kpoint information.", & - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,& name="E_DENSITY_CUBE",& description="Controls the printing of cube files with "//& "the electronic density and, for LSD "//& "calculations, the spin density",& - print_level=high_print_level,filename="",error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="TOTAL_DENSITY",& description="Print the total electronic density in the case "//& @@ -1374,16 +1301,15 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="XRD_INTERFACE",& description="It activates the print out of exponents and coefficients for the "//& @@ -1392,227 +1318,218 @@ SUBROUTINE create_print_dft_section(section,error) " If GAPW the local densities are also given in terms of a Gaussian expansion,"//& " by fitting the difference between local-fhard and local-soft density for each atom."//& " In this case the keyword TOTAL_DENSITY is set to FALSE",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NGAUSS",& description="Number of Gaussian functions used in the expansion of atomic (core) density",& - usage="NGAUSS 10",n_var=1,default_i_val=12, type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NGAUSS 10",n_var=1,default_i_val=12, type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"tot_density_cube",& description="Controls printing of cube files with "//& "the total density (electrons+atomic core). Note that "//& "the value of the total density is positive where the "//& "electron density dominates and negative where the core is.",& - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"v_hartree_cube",& description="Controls the printing of a cube file with eletrostatic "//& " potential generated by the total density (electrons+ions). It is "//& " valid only for QS with GPW formalism."//& " Note that by convention the potential has opposite sign than the expected physical one.", & - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"external_potential_cube",& description="Controls the printing of a cube file with external "//& " potential from the DFT%EXTERNAL_POTENTIAL section only.",& - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! dielectric constant function CALL cp_print_key_section_create(print_key,"dielectric_cube",& description="Controls the printing of a cube file with dielectric constant from "//& "the implicit Poisson solver.", & - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! dirichlet type constraints CALL cp_print_key_section_create(print_key,"dirichlet_bc_cube",& description="Controls the printing of cube files with Dirichlet type (boundary) regions "//& "defined in the implicit Poisson solver section. Note that the generated cube files are "//& "meant to be used only for visualization purposes and the values have no physical meaning.", & - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="TILE_CUBES",& description="Print tiles that tessellate the Dirichlet regions into cube files. If TRUE, "//& "generates cube files as many as the total number of tiles.",& usage="TILE_CUBES ",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! charge introduced by Lagrange multipliers CALL cp_print_key_section_create(print_key,"dirichlet_cstr_charge_cube",& description="Controls the printing of cube files with penalty charges induced to "//& "Dirichlet regions by Lagrange multipliers (implicit Poisson solver).", & - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! ZMP adding the print section for the v_xc cube CALL cp_print_key_section_create(print_key,"v_xc_cube",& description="Controls the printing of a cube file with xc "//& " potential generated by the ZMP method (for the moment). It is "//& " valid only for QS with GPW formalism .", & - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"efield_cube",& description="Controls the printing of cube files with electric "//& " field generated by the total density (electrons+ions). It is "//& " valid only for QS with GPW formalism .", & - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ELF_CUBE",& description="Controls printing of cube files with "//& "the electron localization function (ELF). Note that "//& "the value of ELF is defined between 0 and 1: Pauli kinetic energy density normalized "//& " by the kinetic energy density of a uniform el. gas of same density.",& - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="density_cutoff",& description=" ",& @@ -1620,114 +1537,111 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& type_of_var=real_t,& - default_r_val=1.0e-10_dp, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0e-10_dp) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PDOS",& description="Print out the DOS projected per kind and per angular momentum ",& - print_level=debug_print_level,common_iter_levels=1,filename="",& - error=error) + print_level=debug_print_level,common_iter_levels=1,filename="") CALL keyword_create(keyword, name="COMPONENTS",& description="Print out pdos distinguishing all angular momentum components.",& usage="COMPONENTS", default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="Append the pdos obtained at different iterations to the pdos output file."//& "By defaut the file is overwritten",& usage="APPEND", default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NLUMO",& description="Number of virtual orbitals to be added to the MO set (-1=all)."//newline//& "CAUTION: Setting this value to be higher than the number of states present may cause a Cholesky error.",& - usage="NLUMO integer",default_i_val=0, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NLUMO integer",default_i_val=0) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OUT_EACH_MO",& description="Output on the status of the calculation every OUT_EACH_MO states. If -1 no output",& - usage="OUT_EACH_MO integer",default_i_val=-1, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="OUT_EACH_MO integer",default_i_val=-1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) ! CALL section_create(subsection,name="LDOS",& description="Controls the printing of local PDOS, projected on subsets"//& " of atoms given through lists",& - n_keywords=4, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=4, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="COMPONENTS",& description="Print out pdos distinguishing all angular momentum components.",& usage="COMPONENTS", default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LIST",& description="Specifies a list of indexes of atoms where to project the DOS ",& usage="LIST {integer} {integer} .. {integer} ",type_of_var=integer_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(print_key,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(print_key,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="R_LDOS",& description="Controls the printing of local PDOS, projected on 3D volume in real space,"//& " the volume is defined in terms of position with respect to atoms in the lists",& - n_keywords=4, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=4, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="LIST",& description="Specifies a list of indexes of atoms used to define the real space volume ",& usage="LIST {integer} {integer} .. {integer} ",type_of_var=integer_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="XRANGE",& description="range of positions in Cartesian direction x: all grid points within "//& " this range from at least one atom of the list are considered",& - usage="XRANGE -10.0 10.0",unit_str="angstrom",n_var=2,type_of_var=real_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="XRANGE -10.0 10.0",unit_str="angstrom",n_var=2,type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="YRANGE",& description="range of positions in Cartesian direction y: all grid points within "//& " this range from at least one atom of the list are considered",& - usage="YRANGE -10.0 10.0",unit_str="angstrom",n_var=2,type_of_var=real_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="YRANGE -10.0 10.0",unit_str="angstrom",n_var=2,type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ZRANGE",& description="range of positions in Cartesian direction z: all grid points within "//& " this range from at least one atom of the list are considered",& - usage="ZRANGE -10.0 10.0",unit_str="angstrom",n_var=2,type_of_var=real_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ZRANGE -10.0 10.0",unit_str="angstrom",n_var=2,type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ERANGE",& description="only project states with the eigenvalues in the given interval. "//& "Default is all states.",& - usage="ERANGE -1.0 1.0",unit_str="hartree",n_var=2,type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ERANGE -1.0 1.0",unit_str="hartree",n_var=2,type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(print_key,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(print_key,subsection) + CALL section_release(subsection) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! !Printing of Moments - CALL create_dipoles_section(print_key,"MOMENTS",high_print_level,error) + CALL create_dipoles_section(print_key,"MOMENTS",high_print_level) CALL keyword_create(keyword=keyword,& name="MAX_MOMENT",& description="Maximum moment to be calculated. Values higher than 1 not implemented under periodic boundaries.",& @@ -1735,10 +1649,9 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& type_of_var=integer_t,& - default_i_val=1,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="MAGNETIC",& description="Calculate also magnetic moments, only implemented without periodic boundaries",& @@ -1746,18 +1659,17 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) ! Mulliken population analysis CALL cp_print_key_section_create(print_key,"MULLIKEN",& description="Controls the printing of the Mulliken (spin) population analysis", & print_level=medium_print_level,filename="__STD_OUT__",& - common_iter_levels=1, error=error) + common_iter_levels=1) CALL keyword_create(& keyword=keyword,& name="PRINT_GOP",& @@ -1767,10 +1679,9 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& name="PRINT_ALL",& @@ -1779,18 +1690,17 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! Lowdin population analysis (fairly expensive to compute, so only at high) CALL cp_print_key_section_create(print_key,"LOWDIN",& description="Controls the printing of the Lowdin (spin) population analysis", & print_level=high_print_level,filename="__STD_OUT__",& - common_iter_levels=1, error=error) + common_iter_levels=1) CALL keyword_create(& keyword=keyword,& name="PRINT_GOP",& @@ -1799,10 +1709,9 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& name="PRINT_ALL",& @@ -1811,26 +1720,24 @@ SUBROUTINE create_print_dft_section(section,error) repeats=.FALSE.,& n_var=1,& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! Hirshfeld population analysis CALL cp_print_key_section_create(print_key,"HIRSHFELD",& description="Controls the printing of the Hirshfeld (spin) population analysis", & print_level=medium_print_level,filename="__STD_OUT__",& - common_iter_levels=1, error=error) + common_iter_levels=1) CALL keyword_create(keyword=keyword,name="SELF_CONSISTENT",& description="Calculate charges from the Hirscheld-I (self_consistent) method."//& " This scales only the full shape function, not the added charge as in the original scheme.",& usage="SELF_CONSISTENT yes",repeats=.FALSE.,n_var=1,& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="SHAPE_FUNCTION",& description="Type of shape function used for Hirshfeld partitioning.",& usage="SHAPE_FUNCTION {Gaussian,Density}",repeats=.FALSE.,n_var=1,& @@ -1838,22 +1745,20 @@ SUBROUTINE create_print_dft_section(section,error) enum_c_vals=s2a("GAUSSIAN","DENSITY"),& enum_desc=s2a("Single Gaussian with Colvalent radius", & "Atomic density expanded in multiple Gaussians"), & - enum_i_vals=(/shape_function_gaussian,shape_function_density/),& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/shape_function_gaussian,shape_function_density/)) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="REFERENCE_CHARGE",& description="Charge of atomic partitioning function for Hirshfeld method.",& usage="REFERENCE_CHARGE {Atomic,Mulliken}",repeats=.FALSE.,n_var=1,& default_i_val=ref_charge_atomic,& enum_c_vals=s2a("ATOMIC","MULLIKEN"),& enum_desc=s2a("Use atomic core charges","Calculate Mulliken charges"), & - enum_i_vals=(/ref_charge_atomic,ref_charge_mulliken/),& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + enum_i_vals=(/ref_charge_atomic,ref_charge_mulliken/)) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) ! Xray diffraction CALL cp_print_key_section_create(& @@ -1863,8 +1768,7 @@ SUBROUTINE create_print_dft_section(section,error) "diffraction spectrum",& print_level=debug_print_level,& filename="",& - citations=(/Krack2000,Krack2002/),& - error=error) + citations=(/Krack2000,Krack2002/)) CALL keyword_create(& keyword=keyword,& name="Q_MAX",& @@ -1875,21 +1779,19 @@ SUBROUTINE create_print_dft_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=20.0_dp,& - unit_str="angstrom^-1",& - error=error),& - unit_str="angstrom^-1",& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + unit_str="angstrom^-1"),& + unit_str="angstrom^-1") + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key_section=print_key,& name="ELECTRIC_FIELD_GRADIENT",& description="Calculate and print the electric field gradients"//& "at atomic positions",& print_level=debug_print_level,& - filename="__STD_OUT__",error=error) + filename="__STD_OUT__") CALL keyword_create(keyword=keyword,& name="INTERPOLATION",& @@ -1897,9 +1799,9 @@ SUBROUTINE create_print_dft_section(section,error) usage="INTERPOLATION {logical}",& repeats=.FALSE.,& n_var=1,& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="GSPACE_SMOOTHING",& @@ -1907,9 +1809,9 @@ SUBROUTINE create_print_dft_section(section,error) usage="GSPACE_SMOOTHING cutoff {real}, width {real}", & repeats=.FALSE.,& n_var=2,default_r_vals=(/-1._dp,-1._dp/),& - type_of_var=real_t, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="DEBUG",& @@ -1917,32 +1819,32 @@ SUBROUTINE create_print_dft_section(section,error) usage="DEBUG {logical}",& repeats=.FALSE.,& n_var=1,& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL create_gspace_interp_section(subsection,error=error) - CALL section_add_subsection(print_key, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_gspace_interp_section(subsection) + CALL section_add_subsection(print_key, subsection) + CALL section_release(subsection) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key_section=print_key,& name="BASIS_MOLOPT_QUANTITIES",& description="Print the two quantities needed in the basis molopt generation:"//& " total energy and condition number of the overlap matrix (S matrix)",& print_level=debug_print_level,& - filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key_section=print_key,& name="HYPERFINE_COUPLING_TENSOR",& description="Calculate and print the EPR hyperfine coupling tensor"//& " at atomic positions",& print_level=debug_print_level,& - filename="__STD_OUT__",error=error) + filename="__STD_OUT__") CALL keyword_create(keyword=keyword,& name="INTERACTION_RADIUS",& @@ -1950,20 +1852,20 @@ SUBROUTINE create_print_dft_section(section,error) usage="INTERACTION_RADIUS radius {real}",& repeats=.FALSE.,& n_var=1,default_r_val=10._dp,& - type_of_var=real_t, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key_section=print_key,& name="OPTIMIZE_LRI_BASIS",& description="Optimize the exponents of the LRI basis set",& print_level=low_print_level,& - filename="OPTIMIZED_LRI_BASIS",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="OPTIMIZED_LRI_BASIS") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(& print_key_section=print_key,& @@ -1973,10 +1875,9 @@ SUBROUTINE create_print_dft_section(section,error) filename="__STD_OUT__",& each_iter_names=s2a("QS_SCF"),& each_iter_values=(/0/),& - citations=(/Dudarev1997,Dudarev1998/),& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + citations=(/Dudarev1997,Dudarev1998/)) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(& print_key_section=print_key,& @@ -1986,8 +1887,7 @@ SUBROUTINE create_print_dft_section(section,error) filename="__STD_OUT__",& each_iter_names=s2a("QS_SCF"),& each_iter_values=(/0/),& - citations=(/Fattebert2002,Andreussi2012/),& - error=error) + citations=(/Fattebert2002,Andreussi2012/)) NULLIFY (sub_print_key) @@ -2000,8 +1900,7 @@ SUBROUTINE create_print_dft_section(section,error) print_level=debug_print_level,& filename="",& each_iter_names=s2a("QS_SCF"),& - each_iter_values=(/0/),& - error=error) + each_iter_values=(/0/)) CALL keyword_create(keyword,name="STRIDE",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 "//& @@ -2009,20 +1908,18 @@ SUBROUTINE create_print_dft_section(section,error) n_var=-1,& default_i_vals=(/2,2,2/),& type_of_var=integer_t,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub_print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.) + CALL section_add_keyword(sub_print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="APPEND",& description="Append the cube files when they already exist",& default_l_val=.FALSE.,& lone_keyword_l_val=.TRUE.,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub_print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(print_key,sub_print_key,error=error) - CALL section_release(sub_print_key,error=error) + repeats=.FALSE.) + CALL section_add_keyword(sub_print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(print_key,sub_print_key) + CALL section_release(sub_print_key) CALL cp_print_key_section_create(& print_key_section=sub_print_key,& @@ -2035,8 +1932,7 @@ SUBROUTINE create_print_dft_section(section,error) filename="",& each_iter_names=s2a("QS_SCF"),& each_iter_values=(/0/),& - citations=(/Fattebert2002,Andreussi2012/),& - error=error) + citations=(/Fattebert2002,Andreussi2012/)) CALL keyword_create(keyword,name="STRIDE",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 "//& @@ -2044,20 +1940,18 @@ SUBROUTINE create_print_dft_section(section,error) n_var=-1,& default_i_vals=(/2,2,2/),& type_of_var=integer_t,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub_print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.) + CALL section_add_keyword(sub_print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="APPEND",& description="Append the cube files when they already exist",& default_l_val=.FALSE.,& lone_keyword_l_val=.TRUE.,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub_print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(print_key,sub_print_key,error=error) - CALL section_release(sub_print_key,error=error) + repeats=.FALSE.) + CALL section_add_keyword(sub_print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(print_key,sub_print_key) + CALL section_release(sub_print_key) CALL cp_print_key_section_create(& print_key_section=sub_print_key,& @@ -2069,8 +1963,7 @@ SUBROUTINE create_print_dft_section(section,error) filename="",& each_iter_names=s2a("QS_SCF"),& each_iter_values=(/0/),& - citations=(/Fattebert2002,Andreussi2012/),& - error=error) + citations=(/Fattebert2002,Andreussi2012/)) CALL keyword_create(keyword,name="STRIDE",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 "//& @@ -2078,23 +1971,21 @@ SUBROUTINE create_print_dft_section(section,error) n_var=-1,& default_i_vals=(/2,2,2/),& type_of_var=integer_t,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub_print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.) + CALL section_add_keyword(sub_print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="APPEND",& description="Append the cube files when they already exist",& default_l_val=.FALSE.,& lone_keyword_l_val=.TRUE.,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub_print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(print_key,sub_print_key,error=error) - CALL section_release(sub_print_key,error=error) + repeats=.FALSE.) + CALL section_add_keyword(sub_print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(print_key,sub_print_key) + CALL section_release(sub_print_key) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_dft_section @@ -2102,11 +1993,9 @@ END SUBROUTINE create_print_dft_section ! ***************************************************************************** !> \brief creates the input section for dealing with homo lumos, including dumping cubes !> \param print_key ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_mo_cubes_section(print_key,error) + SUBROUTINE create_mo_cubes_section(print_key) TYPE(section_type), POINTER :: print_key - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mo_cubes_section', & routineP = moduleN//':'//routineN @@ -2117,52 +2006,49 @@ SUBROUTINE create_mo_cubes_section(print_key,error) CALL cp_print_key_section_create(print_key,"MO_CUBES",& description="Controls the printing of cubes of the molecular orbitals.", & - print_level=high_print_level,filename="",& - error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="write_cube",& description="If the MO cube file should be written. If false, the eigenvalues are still computed."//& " Can also be useful in combination with STM calculations",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="nlumo",& description="If the printkey is activated controls the number of lumos"//& " that are printed and dumped as a cube (-1=all)",& - default_i_val=0, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="nhomo",& description="If the printkey is activated controls the number of homos that dumped as a cube (-1=all),"//& " eigenvalues are always all dumped",& - default_i_val=1, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mo_cubes_section ! ***************************************************************************** !> \brief ... !> \param print_key ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_stm_section(print_key,error) + SUBROUTINE create_stm_section(print_key) TYPE(section_type), POINTER :: print_key - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_stm_section', & routineP = moduleN//':'//routineN @@ -2173,23 +2059,22 @@ SUBROUTINE create_stm_section(print_key,error) CALL cp_print_key_section_create(print_key,"STM",& description="Controls the printing of cubes for the generation of STM images.", & - print_level=debug_print_level,filename="",& - error=error) + print_level=debug_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="nlumo",& description="If the printkey is activated controls the number of additional lumos"//& " that are computed to be able to reproduce STM images obtained"//& " from positive bias (imaging unoccupied states)",& - default_i_val=0, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BIAS",& @@ -2199,9 +2084,9 @@ SUBROUTINE create_stm_section(print_key,error) "While positive values sum states in the range [EF,EF+bias[."//& "If postive biases are used, sufficiently many unoccupied stated"//& " (see ADDED_MOS and NLUMO ) should be computed.",& - n_var=-1,type_of_var=real_t, default_r_vals=(/0.0_dp/), unit_str='eV', error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t, default_r_vals=(/0.0_dp/), unit_str='eV') + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TH_TORB",& description="Tip orbital symmetry in Tersoff-Hamann approximation to compute STM images",& @@ -2211,25 +2096,24 @@ SUBROUTINE create_stm_section(print_key,error) enum_c_vals=s2a("S","PX","PY","PZ","DXY","DYZ","DZX","DX2","DY2","DZ2"),& enum_i_vals=(/orb_s,orb_px,orb_py,orb_pz,orb_dxy,orb_dyz,orb_dzx,orb_dx2,orb_dy2,orb_dz2/),& enum_desc=s2a("s orbital","px orbital","py orbital","pz orbital",& - "dxy orbital","dyz orbital","dzx orbital","x^2 orbital","y^2 orbital","z^2 orbital"),& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + "dxy orbital","dyz orbital","dzx orbital","x^2 orbital","y^2 orbital","z^2 orbital")) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REF_ENERGY",& description="By default the reference energy is the Fermi energy. In order to compare"//& " with STS experiments, where specific energy ranges are addressed, here"//& " one can set a different reference energy."//& " The energy range is anyway controlled by the BIAS",& - type_of_var=real_t,default_r_val=0.0_dp, unit_str='eV',error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_val=0.0_dp, unit_str='eV') + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) @@ -2238,12 +2122,10 @@ END SUBROUTINE create_stm_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_wfn_mix_section(section, error) + SUBROUTINE create_wfn_mix_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_wfn_mix_section', & routineP = moduleN//':'//routineN @@ -2256,107 +2138,104 @@ SUBROUTINE create_wfn_mix_section(section, error) NULLIFY(subsection) NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="WFN_MIX",& description="A section that allows manipulation of the MO coeffs,"//& " e.g. for changing a ground state into an excited state."//& "Starting from a copy of the original MOs, changes can be made"//& "by adding linear combinations of HOMO/LUMO of the original MOs to the result MOs",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="OVERWRITE_MOS",& description="If the keyword is active molecular orbitals in memory will be replaced by the mixed wfn."//& " In combination with RTP or EMD no restart will be required to use the mixed wfn.",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="UPDATE",& description="update a result MO with with a linear combination of of original MOs."//& " This section can be repeated to build arbitrary linear combinations using repeatedly y=a*y+b*x.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="RESULT_MO_INDEX",& description="Index of the MO (y) to be modified. Counting down in energy with HOMO=1",& - usage="RESULT_MO_INDEX 1", type_of_var=integer_t,default_i_val=0, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESULT_MO_INDEX 1", type_of_var=integer_t,default_i_val=0) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESULT_MARKED_STATE",& description="Specifies the MO according to "//& "the marks set in MOLECULAR_STATES. The value corresponds to the repetition "//& " of MARK_STATES in MOLECULAR_STATES",& - usage="ORIG_MARKED_STATE 1", type_of_var=integer_t,default_i_val=0, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORIG_MARKED_STATE 1", type_of_var=integer_t,default_i_val=0) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESULT_SPIN_INDEX",& description="Spin of the MO (y) to be modified.",& enum_c_vals=s2a("Alpha","Beta"),& enum_i_vals=(/ 1, 2/),& ! direct index in array default_i_val=1,& - enum_desc=s2a("Majority spin","Minority spin"), error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_desc=s2a("Majority spin","Minority spin")) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESULT_SCALE",& description="Scaling factor of the result variable (a).",& - usage="RESULT_SCALE 0.0", type_of_var=real_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESULT_SCALE 0.0", type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORIG_MO_INDEX",& description="Index of the original MO (x). "//& "Counting down in energy with HOMO=1 or up from LUMO=1, depending on ORIG_IS_VIRTUAL.",& - usage="ORIG_MO_INDEX 1", type_of_var=integer_t,default_i_val=0, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORIG_MO_INDEX 1", type_of_var=integer_t,default_i_val=0) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORIG_MARKED_STATE",& description="Specifies the MO according to "//& "the marks set in MOLECULAR_STATES. The value corresponds to the repetition "//& " of MARK_STATES in MOLECULAR_STATES",& - usage="ORIG_MARKED_STATE 1", type_of_var=integer_t,default_i_val=0, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORIG_MARKED_STATE 1", type_of_var=integer_t,default_i_val=0) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORIG_SPIN_INDEX",& description="Spin of the MO (x) to be modified.",& enum_c_vals=s2a("Alpha","Beta"),& enum_i_vals=(/ 1, 2/),& ! direct index in array default_i_val=1,& - enum_desc=s2a("Majority spin","Minority spin"), error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_desc=s2a("Majority spin","Minority spin")) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORIG_SCALE",& description="Scaling factor of the result variable (b).",& - usage="ORIG_SCALE 0.0", type_of_var=real_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORIG_SCALE 0.0", type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORIG_IS_VIRTUAL",& description="The original MO (x) is a LUMO.",& - usage="ORIG_IS_VIRTUAL", type_of_var=logical_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORIG_IS_VIRTUAL", type_of_var=logical_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_wfn_mix_section ! ***************************************************************************** !> \brief creates the input section for the molecular states !> \param print_key ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_molecular_states_section(print_key,error) + SUBROUTINE create_molecular_states_section(print_key) TYPE(section_type), POINTER :: print_key - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_molecular_states_section', & @@ -2367,18 +2246,18 @@ SUBROUTINE create_molecular_states_section(print_key,error) TYPE(section_type), POINTER :: print_key2 failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,failure) NULLIFY(print_key2, keyword) CALL cp_print_key_section_create(print_key,"MOLECULAR_STATES",& description="Controls printing of molecular states ",& - print_level=high_print_level,filename=" ",citations=(/Hunt2003/), error=error) + print_level=high_print_level,filename=" ",citations=(/Hunt2003/)) CALL keyword_create(keyword, name="CUBE_EVAL_RANGE",& description="only write cubes if the eigenvalues of the corresponding molecular states lie in the given interval. "//& "Default is all states.",& - usage="CUBE_EVAL_RANGE -1.0 1.0",unit_str="hartree",n_var=2,type_of_var=real_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CUBE_EVAL_RANGE -1.0 1.0",unit_str="hartree",n_var=2,type_of_var=real_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="MARK_STATES",& description="Can be used to mark given molecular states."//& @@ -2388,33 +2267,31 @@ SUBROUTINE create_molecular_states_section(print_key,error) "This is only meaningful in combination with WFN_MIX. "//& "First integer specifies the molecule, second integer specifies the state.",& usage="MARK_STATES integer integer",& - n_var=2,default_i_vals=(/-1,-1/), type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/-1,-1/), type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key2,"cubes",& description="Controls the printing of cube files", & - print_level=high_print_level,filename="",error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key2,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(print_key,print_key2,error=error) - CALL section_release(print_key2,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key2,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(print_key,print_key2) + CALL section_release(print_key2) END SUBROUTINE create_molecular_states_section ! ***************************************************************************** !> \brief ... !> \param print_key ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_wannier_states_section(print_key,error) + SUBROUTINE create_wannier_states_section(print_key) TYPE(section_type), POINTER :: print_key - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_wannier_states_section', & @@ -2425,18 +2302,18 @@ SUBROUTINE create_wannier_states_section(print_key,error) TYPE(section_type), POINTER :: print_key2 failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,failure) NULLIFY(print_key2, keyword) CALL cp_print_key_section_create(print_key,"WANNIER_STATES",& description="Controls printing of molecular states ",& - print_level=high_print_level,filename=" ", error=error) + print_level=high_print_level,filename=" ") CALL keyword_create(keyword, name="CUBE_EVAL_RANGE",& description="only write cubes if the eigenvalues of the corresponding molecular states lie in the given interval. "//& "Default is all states.",& - usage="CUBE_EVAL_RANGE -1.0 1.0",unit_str="hartree",n_var=2,type_of_var=real_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CUBE_EVAL_RANGE -1.0 1.0",unit_str="hartree",n_var=2,type_of_var=real_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="MARK_STATES",& description="Can be used to mark given molecular states."//& @@ -2446,34 +2323,31 @@ SUBROUTINE create_wannier_states_section(print_key,error) "This is only meaningful in combination with WFN_MIX. "//& "First integer specifies the molecule, second integer specifies the state.",& usage="MARK_STATES integer integer",& - n_var=2,default_i_vals=(/-1,-1/), type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/-1,-1/), type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key2,"cubes",& description="Controls the printing of cube files", & - print_level=high_print_level,filename="",error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key2,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(print_key,print_key2,error=error) - CALL section_release(print_key2,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key2,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(print_key,print_key2) + CALL section_release(print_key2) END SUBROUTINE create_wannier_states_section ! ***************************************************************************** !> \brief creates the input section for the qs part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_qs_section(section,error) + SUBROUTINE create_qs_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qs_section', & routineP = moduleN//':'//routineN @@ -2483,141 +2357,124 @@ SUBROUTINE create_qs_section(section,error) TYPE(section_type), POINTER :: subsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"qs",& description="parameters needed to set up the Quickstep framework",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) ! Reals CALL keyword_create(keyword, name="EPS_DEFAULT",& description="Try setting all EPS_xxx to values leading to an energy correct up to EPS_DEFAULT",& - usage="EPS_DEFAULT real", default_r_val=1.0E-10_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_DEFAULT real", default_r_val=1.0E-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_CORE_CHARGE",& description="Precision for mapping the core charges.Overrides EPS_DEFAULT/100.0 value",& - usage="EPS_CORE_CHARGE real", type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_CORE_CHARGE real", type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_GVG_RSPACE",& variants=(/"EPS_GVG"/),& description="Sets precision of the realspace KS matrix element integration. Overrides SQRT(EPS_DEFAULT) value",& - usage="EPS_GVG_RSPACE real",type_of_var=real_t ,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_GVG_RSPACE real",type_of_var=real_t ) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_PGF_ORB",& description="Sets precision of the overlap matrix elements. Overrides SQRT(EPS_DEFAULT) value",& - usage="EPS_PGF_ORB real",type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_PGF_ORB real",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_KG_ORB",& description="Sets precision used in coloring the subsets for the Kim-Gordon method. Overrides SQRT(EPS_DEFAULT) value",& usage="EPS_KG_ORB 1.0E-8",& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_PPL",& description="Adjusts the precision for the local part of the pseudo potential. ",& - usage="EPS_PPL real", type_of_var=real_t, default_r_val=1.0E-2_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_PPL real", type_of_var=real_t, default_r_val=1.0E-2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_PPNL",& description="Sets precision of the non-local part of the pseudo potential. Overrides sqrt(EPS_DEFAULT) value",& - usage="EPS_PPNL real", type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_PPNL real", type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_CPC",& description="Sets precision of the GAPW projection. Overrides EPS_DEFAULT value",& - usage="EPS_CPC real", type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_CPC real", type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_RHO",& description="Sets precision of the density mapping on the grids.Overrides EPS_DEFAULT value",& - usage="EPS_RHO real",type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_RHO real",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_RHO_RSPACE",& description="Sets precision of the density mapping in rspace.Overrides EPS_DEFAULT value."//& ".Overrides EPS_RHO value",& - usage="EPS_RHO_RSPACE real",type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_RHO_RSPACE real",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_RHO_GSPACE",& description="Sets precision of the density mapping in gspace.Overrides EPS_DEFAULT value."//& ".Overrides EPS_RHO value",& - usage="EPS_RHO_GSPACE real",type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_RHO_GSPACE real",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_FILTER_MATRIX",& description="Sets the threshold for filtering matrix elements.",& - usage="EPS_FILTER_MATRIX 1.0E-6", type_of_var=real_t,default_r_val=0.0E0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_FILTER_MATRIX 1.0E-6", type_of_var=real_t,default_r_val=0.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPSFIT",& variants=(/"EPS_FIT"/),& description="GAPW: precision to give the extention of a hard gaussian ",& - usage="EPSFIT real", default_r_val=1.0E-4_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPSFIT real", default_r_val=1.0E-4_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPSISO",& variants=(/"EPS_ISO"/),& description="GAPW: precision to determine an isolated projector",& - usage="EPSISO real", default_r_val=1.0E-12_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPSISO real", default_r_val=1.0E-12_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPSSVD",& variants=(/"EPS_SVD"/),& description="GAPW: tolerance used in the singular value decomposition of the projector matrix",& - usage="EPS_SVD real", default_r_val=1.0E-8_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SVD real", default_r_val=1.0E-8_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPSRHO0",& variants=s2a("EPSVRHO0","EPS_VRHO0"),& description="GAPW : precision to determine the range of V(rho0-rho0soft)",& - usage="EPSRHO0 real", default_r_val=1.0E-6_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPSRHO0 real", default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA0_HARD",& variants=s2a("ALPHA0_H","ALPHA0"),& description="GAPW: Exponent for hard compensation charge",& - usage="ALPHA0_HARD real", default_r_val=0.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALPHA0_HARD real", default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FORCE_PAW",& description="Use the GAPW scheme also for atoms with soft basis sets, i.e. "//& @@ -2626,46 +2483,45 @@ SUBROUTINE create_qs_section(section,error) "the corresponding density contribution goes on the global grid and is expanded in PW. "//& " This option nullifies the effect of the GPW_TYPE in the atomic KIND",& usage="FORCE_PAW",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_RAD_LOCAL",& description="GAPW : maximum radius of gaussian functions"//& " included in the generation of projectors",& - usage="MAX_RAD_LOCAL real", default_r_val=25.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_RAD_LOCAL real", default_r_val=25.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Logicals CALL keyword_create(keyword, name="LS_SCF",& description="Perform a linear scaling SCF",& usage="LS_SCF",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALMO_SCF",& description="Perform ALMO SCF",& usage="ALMO_SCF",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRANSPORT",& description="Perform transport calculations (coupling CP2K and OMEN)",& usage="TRANSPORT",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KG_METHOD",& description="Use a Kim-Gordon-like scheme.",& usage="KG_METHOD",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,citations=(/Iannuzzi2006, Brelaz1979/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,citations=(/Iannuzzi2006, Brelaz1979/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAP_CONSISTENT",& description="Compute the exact derivative (Hks) of the energy with respect to the density matrix. "//& @@ -2673,34 +2529,34 @@ SUBROUTINE create_qs_section(section,error) "but consistent mapping can improve the stability of the SCF procedure, "//& "especially for a tight EPS_SCF and a less tight EPS_DEFAULT.",& usage="MAP_CONSISTENT FALSE",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Integers CALL keyword_create(keyword, name="LMAXN1",& variants=(/"LMAXRHO1"/),& description="GAPW : max L number for expansion of the atomic densities in spherical gaussians",& usage="LMAXN1 integer",& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LMAXN0",& variants=(/"LMAXRHO0"/),& description="GAPW : max L number for the expansion compensation densities in spherical gaussians",& usage="LMAXN0 integer",& - default_i_val=2,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LADDN0",& description="GAPW : integer added to the max L of the basis set, used to determine the "//& "maximum value of L for the compensation charge density.",& usage="LADDN0 integer",& - default_i_val=99,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=99) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Characters CALL keyword_create(keyword, name="QUADRATURE",& @@ -2711,9 +2567,9 @@ SUBROUTINE create_qs_section(section,error) enum_desc=s2a("Gauss-Chebyshev quadrature",& "Transformed Gauss-Chebyshev quadrature",& "Logarithmic transformed Gauss-Chebyshev quadrature"),& - default_i_val=do_gapw_log, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_gapw_log) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_GRID",& description="What kind of PW_GRID should be employed",& @@ -2721,9 +2577,9 @@ SUBROUTINE create_qs_section(section,error) enum_c_vals=s2a("SPHERICAL","NS-FULLSPACE","NS-HALFSPACE"),& enum_desc=s2a("- not tested"," tested"," - not tested"),& enum_i_vals=(/ do_pwgrid_spherical, do_pwgrid_ns_fullspace,do_pwgrid_ns_halfspace/),& - default_i_val=do_pwgrid_ns_fullspace, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_pwgrid_ns_fullspace) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_GRID_LAYOUT",& description="Force a particular real-space layout for the plane waves grids. "//& @@ -2732,10 +2588,9 @@ SUBROUTINE create_qs_section(section,error) "i.e. plane distributed for large grids, more general distribution for small grids.",& usage="PW_GRID_LAYOUT 4 16",& repeats=.FALSE.,n_var=2,& - default_i_vals=(/-1,-1/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_vals=(/-1,-1/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_GRID_BLOCKED",& description="Can be used to set the distribution in g-space for the pw grids and their FFT.",& @@ -2743,9 +2598,9 @@ SUBROUTINE create_qs_section(section,error) enum_c_vals=s2a("FREE","TRUE","FALSE"),& enum_desc=s2a("CP2K will select an appropriate value","blocked","not blocked"),& enum_i_vals=(/do_pw_grid_blocked_free,do_pw_grid_blocked_true,do_pw_grid_blocked_false/),& - default_i_val=do_pw_grid_blocked_free, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_pw_grid_blocked_free) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXTRAPOLATION",& variants=s2a("INTERPOLATION","WF_INTERPOLATION"),& @@ -2776,9 +2631,9 @@ SUBROUTINE create_qs_section(section,error) wfi_ps_method_nr,& wfi_frozen_method_nr,& wfi_aspc_nr/),& - default_i_val=wfi_aspc_nr, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=wfi_aspc_nr) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXTRAPOLATION_ORDER",& description="Order for the PS or ASPC extrapolation (typically 2-4). "//& @@ -2786,9 +2641,9 @@ SUBROUTINE create_qs_section(section,error) "for large systems, also at some cost. "//& "In some cases, a high order extrapolation is not stable,"//& " and the order needs to be reduced.",& - usage="EXTRAPOLATION_ORDER {integer}",default_i_val=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EXTRAPOLATION_ORDER {integer}",default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="METHOD",& description="Specifies the electronic structure method that should be employed",& @@ -2813,9 +2668,9 @@ SUBROUTINE create_qs_section(section,error) citations=(/Lippert1997,Lippert1999,Krack2000,VandeVondele2005a,& VandeVondele2006,Dewar1977,Dewar1985,Rocha2006,Stewart1989,Thiel1992,& Repasky2002,Stewart2007,Schenter2008/),& - default_i_val=do_method_gpw, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_method_gpw) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORE_PPL",& description="Specifies the method used to calculate the local pseudopotential contribution.",& @@ -2824,60 +2679,58 @@ SUBROUTINE create_qs_section(section,error) enum_desc=s2a("Analytic integration of integrals",& "Numerical integration on real space grid. Lumped together with core charge"),& enum_i_vals=(/ do_ppl_analytic, do_ppl_grid/), & - default_i_val=do_ppl_analytic, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ppl_analytic) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_distribution_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_distribution_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_dftb_control_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_dftb_control_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_scptb_control_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_scptb_control_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_se_control_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_se_control_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_mulliken_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mulliken_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_ddapc_restraint_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ddapc_restraint_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_becke_restraint_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_becke_restraint_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_s2_restraint_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_s2_restraint_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_lrigpw_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_lrigpw_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_optimize_lri_basis_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_optimize_lri_basis_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_qs_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_dftb_control_section(section,error) + SUBROUTINE create_dftb_control_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_dftb_control_section', & routineP = moduleN//':'//routineN @@ -2888,65 +2741,64 @@ SUBROUTINE create_dftb_control_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"DFTB",& description="Parameters needed to set up the DFTB methods",& n_keywords=1, n_subsections=1, repeats=.FALSE., & - citations=(/Porezag1995, Seifert1996, Elstner1998, Zhechkov2005/),& - error=error) + citations=(/Porezag1995, Seifert1996, Elstner1998, Zhechkov2005/)) NULLIFY(subsection) - CALL create_dftb_parameter_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_dftb_parameter_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) NULLIFY(keyword) CALL keyword_create(keyword, name="self_consistent",& description="Use self-consistent method",& citations=(/Elstner1998/),& - usage="SELF_CONSISTENT",default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SELF_CONSISTENT",default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="orthogonal_basis",& description="Assume orthogonal basis set",& - usage="ORTHOGONAL_BASIS",default_l_val=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORTHOGONAL_BASIS",default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="do_ewald",& description="Use Ewald type method instead of direct sum for Coulomb interaction",& - usage="DO_EWALD",default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DO_EWALD",default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="dispersion",& description="Use dispersion correction",& citations=(/Zhechkov2005/),lone_keyword_l_val=.TRUE.,& - usage="DISPERSION",default_l_val=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DISPERSION",default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIAGONAL_DFTB3",& description="Use a diagonal version of the 3rd order energy correction (DFTB3) ",& lone_keyword_l_val=.TRUE.,& - usage="DIAGONAL_DFTB3",default_l_val=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DIAGONAL_DFTB3",default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HB_SR_GAMMA",& description="Uses a modified version for the GAMMA within the SCC-DFTB scheme, "//& "specifically tuned for hydrogen bonds.",& citations=(/Hu2007/),lone_keyword_l_val=.TRUE.,& - usage="HB_SR_GAMMA",default_l_val=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="HB_SR_GAMMA",default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_disp",& description="Define accuracy of dispersion interaction",& - usage="EPS_DISP",default_r_val=0.0001_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_DISP",default_r_val=0.0001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_dftb_control_section @@ -2954,11 +2806,9 @@ END SUBROUTINE create_dftb_control_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_scptb_control_section(section,error) + SUBROUTINE create_scptb_control_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_scptb_control_section', & routineP = moduleN//':'//routineN @@ -2968,82 +2818,80 @@ SUBROUTINE create_scptb_control_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"SCPTB",& description="Parameters needed to set up the SCPTB methods",& - n_keywords=1, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword,name="PARAMETER_FILE_NAME",& description="Specify file that contains the atomic parameters",& usage="PARAMETER_FILE_NAME filename",& - n_var=1,type_of_var=char_t,default_c_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=char_t,default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="DISPERSION_PARAMETER_FILE",& description="Specify file that contains the atomic dispersion parameters",& usage="DISPERSION_PARAMETER_FILE filename",& - n_var=1,type_of_var=char_t,default_c_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=char_t,default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPERSION",& description="Use dispersion correction",& lone_keyword_l_val=.TRUE.,& - usage="DISPERSION",default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DISPERSION",default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPERSION_RADIUS",& description="Define radius of dispersion interaction",& - usage="DISPERSION_RADIUS",default_r_val=15._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DISPERSION_RADIUS",default_r_val=15._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COORDINATION_CUTOFF",& description="Define cutoff for coordination number calculation",& - usage="COORDINATION_CUTOFF",default_r_val=1.e-6_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COORDINATION_CUTOFF",default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="D3_SCALING",& description="Scaling parameters (s6,sr6,s8) for the D3 dispersion method,",& - usage="D3_SCALING 1.0 1.0 1.0", n_var=3, default_r_vals=(/1.0_dp,1.0_dp,1.0_dp/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="D3_SCALING 1.0 1.0 1.0", n_var=3, default_r_vals=(/1.0_dp,1.0_dp,1.0_dp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STO_NG",& description="Provides the order of the Slater orbital expansion of Gaussian-Type Orbitals.",& - usage="STO_NG",default_i_val=6, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STO_NG",default_i_val=6) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PAIR_CUTOFF",& description="Define cutoff for pair potential calculation",& - usage="PAIR_CUTOFF",default_r_val=1.e-8_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PAIR_CUTOFF",default_r_val=1.e-8_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="do_ewald",& description="Use Ewald type method instead of direct sum for Coulomb interaction",& - usage="DO_EWALD",default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DO_EWALD",default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="do_scc",& description="Use self consistent charge method. Can be used together with DO_SCP to get TB method",& - usage="DO_SCC",default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DO_SCC",default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="do_scp",& description="Use SCP method. Can be used to switch off SCP to get a SCC-DFTB method",& - usage="DO_SCP",default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DO_SCP",default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_scptb_control_section @@ -3051,11 +2899,9 @@ END SUBROUTINE create_scptb_control_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_admm_section(section,error) + SUBROUTINE create_admm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_admm_section', & routineP = moduleN//':'//routineN @@ -3065,12 +2911,11 @@ SUBROUTINE create_admm_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"AUXILIARY_DENSITY_MATRIX_METHOD",& description="Parameters needed for the ADMM method.",& n_keywords=1, n_subsections=1, repeats=.FALSE., & - citations=(/Guidon2010/),& - error=error) + citations=(/Guidon2010/)) CALL keyword_create(& keyword=keyword,& @@ -3087,9 +2932,9 @@ SUBROUTINE create_admm_section(section,error) "Calculate MO derivatives via Cauchy representation by inversion",& "Perform original McWeeny purification via matrix multiplications",& "Do not apply any purification, works directly with density matrix"), & - default_i_val=do_admm_purify_mo_diag, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_admm_purify_mo_diag) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -3104,9 +2949,9 @@ SUBROUTINE create_admm_section(section,error) " but use the original matrix for purification.",& "Construct auxiliary density from a blocked Fock matrix.",& "Construct auxiliary density from auxiliary basis enforcing charge constrain."),& - default_i_val=do_admm_basis_projection, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_admm_basis_projection) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& @@ -3117,9 +2962,9 @@ SUBROUTINE create_admm_section(section,error) enum_i_vals=(/do_admm_exch_scaling_none, do_admm_exch_scaling_merlot/),& enum_desc=s2a("No scaling is enabled, refers to methods ADMM1, ADMM2 or ADMMQ.",& "Exchange scaling according to Merlot (2014)"),& - default_i_val=do_admm_exch_scaling_none, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_admm_exch_scaling_none) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -3134,35 +2979,33 @@ SUBROUTINE create_admm_section(section,error) "No correction: X(D)-x(d)-> 0.",& "Use OPTX functional for exchange correction.",& "Use Becke88X functional for exchange correction."),& - default_i_val=do_admm_aux_exch_func_default, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_admm_aux_exch_func_default) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BLOCK_LIST",& description="Specifies a list of atoms.",& usage="LIST {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_FILTER",& description="Define accuracy of DBCSR operations",& - usage="EPS_FILTER",default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_FILTER",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_admm_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_dftb_parameter_section(section, error) + SUBROUTINE create_dftb_parameter_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_dftb_parameter_section', & @@ -3173,37 +3016,36 @@ SUBROUTINE create_dftb_parameter_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PARAMETER",& description="Information on where to find DFTB parameters",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword,name="SK_FILE",& description="Define parameter file for atom pair",& usage="SK_FILE a1 a2 filename",& - n_var=3,type_of_var=char_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,type_of_var=char_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="PARAM_FILE_PATH",& description="Specify the directory with the DFTB parameter files. "//& "Used in combination with the filenames specified in the file "//& "given in PARAM_FILE_NAME.", usage="PARAM_FILE_PATH pathname",& - n_var=1,type_of_var=char_t,default_c_val="./",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=char_t,default_c_val="./") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="PARAM_FILE_NAME",& description="Specify file that contains the names of "//& "Slater-Koster tables: A plain text file, each line has the "//& 'format "ATOM1 ATOM2 filename.spl".',& usage="PARAM_FILE_NAME filename",& - n_var=1,type_of_var=char_t,default_c_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=char_t,default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPERSION_TYPE",& description="Use dispersion correction of the specified type."//& @@ -3213,63 +3055,60 @@ SUBROUTINE create_dftb_parameter_section(section, error) enum_i_vals=(/dispersion_uff, dispersion_d3/),& enum_desc=s2a("Uses the UFF force field for a pair potential dispersion correction.",& "Uses the Grimme D3 method (simplified) for a pair potential dispersion correction."),& - default_i_val=dispersion_uff, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=dispersion_uff) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="UFF_FORCE_FIELD",& description="Name of file with UFF parameters that will be used "//& "for the dispersion correction. Needs to be specified when "//& "DISPERSION==.TRUE., otherwise cp2k crashes with a Segmentation "//& "Fault.", usage="UFF_FORCE_FIELD filename",& - n_var=1,type_of_var=char_t,default_c_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=char_t,default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="DISPERSION_PARAMETER_FILE",& description="Specify file that contains the atomic dispersion "//& "parameters for the D3 method",& usage="DISPERSION_PARAMETER_FILE filename",& - n_var=1,type_of_var=char_t,default_c_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=char_t,default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPERSION_RADIUS",& description="Define radius of dispersion interaction",& - usage="DISPERSION_RADIUS",default_r_val=15._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DISPERSION_RADIUS",default_r_val=15._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COORDINATION_CUTOFF",& description="Define cutoff for coordination number calculation",& - usage="COORDINATION_CUTOFF",default_r_val=1.e-6_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COORDINATION_CUTOFF",default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="D3_SCALING",& description="Scaling parameters (s6,sr6,s8) for the D3 dispersion method,",& - usage="D3_SCALING 1.0 1.0 1.0", n_var=3, default_r_vals=(/0.0_dp,0.0_dp,0.0_dp/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="D3_SCALING 1.0 1.0 1.0", n_var=3, default_r_vals=(/0.0_dp,0.0_dp,0.0_dp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HB_SR_PARAM",& description="Uses a modified version for the GAMMA within the SCC-DFTB scheme, "//& "specifically tuned for hydrogen bonds. Specify the exponent used in the exponential.",& - usage="HB_SR_PARAM {real}",default_r_val=4.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="HB_SR_PARAM {real}",default_r_val=4.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_dftb_parameter_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_se_control_section(section,error) + SUBROUTINE create_se_control_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_se_control_section', & routineP = moduleN//':'//routineN @@ -3281,38 +3120,35 @@ SUBROUTINE create_se_control_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"SE",& description="Parameters needed to set up the Semi-empirical methods",& - n_keywords=8, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=8, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="ORTHOGONAL_BASIS",& description="Assume orthogonal basis set. This flag is overwritten by "//& "methods with fixed orthogonal/non-orthogonal basis set.",& - usage="ORTHOGONAL_BASIS",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORTHOGONAL_BASIS",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STO_NG",& description="Provides the order of the Slater orbital expansion of Gaussian-Type Orbitals.",& - usage="STO_NG",default_i_val=6, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STO_NG",default_i_val=6) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ANALYTICAL_GRADIENTS",& description="Nuclear Gradients are computed analytically or numerically",& - usage="ANALYTICAL_GRADIENTS",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ANALYTICAL_GRADIENTS",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DELTA",& description="Step size in finite difference force calculation",& - usage="DELTA {real} ",default_r_val=1.e-6_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DELTA {real} ",default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTEGRAL_SCREENING",& description="Specifies the functional form for the ",& @@ -3324,9 +3160,9 @@ SUBROUTINE create_se_control_section(section,error) "Uses a modified Klopman-Dewar-Sabelli-Ohno equation, dumping the screening "//& "parameter for the Coulomb interactions.",& "Uses an exponential Slater-type function for modelling the Coulomb interactions."),& - default_i_val=do_se_IS_kdso, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_se_IS_kdso) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PERIODIC",& description="Specifies the type of treatment for the electrostatic long-range part "//& @@ -3342,97 +3178,92 @@ SUBROUTINE create_se_control_section(section,error) "treatment for the 1/R^3 term, deriving from the short-range component. This option "//& "is active only for K-DSO integral screening type.",& "Use Ewald directly in Coulomb integral evaluation, works only with Slater screening"),& - default_i_val=do_se_lr_none, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_se_lr_none) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FORCE_KDSO-D_EXCHANGE",& description="This keywords forces the usage of the KDSO-D integral screening "//& "for the Exchange integrals (default is to apply the screening only to the "//& - "Coulomb integrals.",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Coulomb integrals.",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPERSION",& description="Use dispersion correction",& lone_keyword_l_val=.TRUE.,& - usage="DISPERSION",default_l_val=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DISPERSION",default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPERSION_PARAMETER_FILE",& description="Specify file that contains the atomic dispersion parameters",& usage="DISPERSION_PARAMETER_FILE filename",& - n_var=1,type_of_var=char_t,default_c_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=char_t,default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPERSION_RADIUS",& description="Define radius of dispersion interaction",& - usage="DISPERSION_RADIUS",default_r_val=15._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DISPERSION_RADIUS",default_r_val=15._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COORDINATION_CUTOFF",& description="Define cutoff for coordination number calculation",& - usage="COORDINATION_CUTOFF",default_r_val=1.e-6_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COORDINATION_CUTOFF",default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D3_SCALING",& description="Scaling parameters (s6,sr6,s8) for the D3 dispersion method,",& - usage="D3_SCALING 1.0 1.0 1.0", n_var=3, default_r_vals=(/0.0_dp,0.0_dp,0.0_dp/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="D3_SCALING 1.0 1.0 1.0", n_var=3, default_r_vals=(/0.0_dp,0.0_dp,0.0_dp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_coulomb_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_coulomb_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_exchange_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_exchange_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_screening_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_screening_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_lr_corr_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_lr_corr_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_neighbor_lists_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_neighbor_lists_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_se_memory_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_se_memory_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_se_print_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_se_print_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_se_ga_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_se_ga_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_se_control_section ! ***************************************************************************** !> \brief Create the COULOMB se section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 03.2009 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE create_lr_corr_section(section,error) + SUBROUTINE create_lr_corr_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_lr_corr_section', & routineP = moduleN//':'//routineN @@ -3441,48 +3272,43 @@ SUBROUTINE create_lr_corr_section(section,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="LR_CORRECTION",& description="Setup parameters for the evaluation of the long-range correction term in SE "//& - "calculations.", n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + "calculations.", n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="CUTOFF",& description="Atomic Cutoff Radius Cutoff for the evaluation of the long-ranbe correction integrals. ",& usage="CUTOFF {real} ",unit_str="angstrom",& - default_r_val=cp_unit_to_cp2k(value=6.0_dp,unit_str="angstrom",error=error),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=6.0_dp,unit_str="angstrom")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RC_TAPER",& description="Atomic Cutoff Radius Cutoff for Tapering the long-range correction integrals. "//& "If not specified it assumes the same value specified for the CUTOFF.",& - usage="RC_TAPER {real} ",unit_str="angstrom",type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RC_TAPER {real} ",unit_str="angstrom",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RC_RANGE",& description="Range of cutoff switch function (tapering): 0.5*(1-TANH((r-r0)/RC_RANGE)), "//& "where r0=2.0*RC_TAPER-20.0*RC_RANGE.",& - usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_lr_corr_section ! ***************************************************************************** !> \brief Create the COULOMB se section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 03.2009 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE create_coulomb_section(section,error) + SUBROUTINE create_coulomb_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_coulomb_section', & routineP = moduleN//':'//routineN @@ -3491,11 +3317,10 @@ SUBROUTINE create_coulomb_section(section,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="COULOMB",& description="Setup parameters for the evaluation of the COULOMB term in SE "//& - "calculations.", n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + "calculations.", n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="CUTOFF",& @@ -3503,38 +3328,34 @@ SUBROUTINE create_coulomb_section(section,error) "For non-periodic calculation the default value is exactly the full cell dimension, in order "//& "to evaluate all pair interactions. Instead, for periodic calculations the default numerical value is used." ,& usage="CUTOFF {real} ",unit_str="angstrom",& - default_r_val=cp_unit_to_cp2k(value=12.0_dp,unit_str="angstrom",error=error),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=12.0_dp,unit_str="angstrom")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RC_TAPER",& description="Atomic Cutoff Radius Cutoff for Tapering Coulomb integrals. "//& "If not specified it assumes the same value specified for the CUTOFF.",& - usage="RC_TAPER {real} ",unit_str="angstrom",type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RC_TAPER {real} ",unit_str="angstrom",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RC_RANGE",& description="Range of cutoff switch function (tapering): 0.5*(1-TANH((r-r0)/RC_RANGE)), "//& "where r0=2.0*RC_TAPER-20.0*RC_RANGE.",& - usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_coulomb_section ! ***************************************************************************** !> \brief Create the EXCHANGE se section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 03.2009 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE create_exchange_section(section,error) + SUBROUTINE create_exchange_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_exchange_section', & routineP = moduleN//':'//routineN @@ -3543,11 +3364,11 @@ SUBROUTINE create_exchange_section(section,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EXCHANGE",& description="Setup parameters for the evaluation of the EXCHANGE and "//& " core Hamiltonian terms in SE calculations.", n_keywords=0, n_subsections=1,& - repeats=.FALSE., error=error) + repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="CUTOFF",& @@ -3557,38 +3378,34 @@ SUBROUTINE create_exchange_section(section,error) "minimum value between 1/4 of the cell dimension and the value specified in input (either"//& " explicitly defined or the default numerical value).",& usage="CUTOFF {real} ",unit_str="angstrom",& - default_r_val=cp_unit_to_cp2k(value=12.0_dp,unit_str="angstrom",error=error),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=12.0_dp,unit_str="angstrom")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RC_TAPER",& description="Atomic Cutoff Radius Cutoff for Tapering Exchange integrals. "//& "If not specified it assumes the same value specified for the CUTOFF.",& - usage="RC_TAPER {real} ",unit_str="angstrom",type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RC_TAPER {real} ",unit_str="angstrom",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RC_RANGE",& description="Range of cutoff switch function (tapering): 0.5*(1-TANH((r-r0)/RC_RANGE)), "//& "where r0=2.0*RC_TAPER-20.0*RC_RANGE.",& - usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_exchange_section ! ***************************************************************************** !> \brief Create the SCREENING se section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 03.2009 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE create_screening_section(section,error) + SUBROUTINE create_screening_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_screening_section', & routineP = moduleN//':'//routineN @@ -3597,40 +3414,35 @@ SUBROUTINE create_screening_section(section,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SCREENING",& description="Setup parameters for the tapering of the Coulomb/Exchange Screening in "//& - "KDSO-D integral scheme,", n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + "KDSO-D integral scheme,", n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="RC_TAPER",& description="Atomic Cutoff Radius Cutoff for Tapering the screening term. ",& usage="RC_TAPER {real} ",unit_str="angstrom",& - default_r_val=cp_unit_to_cp2k(value=12.0_dp,unit_str="angstrom",error=error),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=12.0_dp,unit_str="angstrom")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RC_RANGE",& description="Range of cutoff switch function (tapering): 0.5*(1-TANH((r-r0)/RC_RANGE)), "//& "where r0=2*RC_TAPER-20*RC_RANGE.",& - usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RC_RANGE {real} ",unit_str="angstrom",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_screening_section ! ***************************************************************************** !> \brief Create the print se section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_se_print_section(section,error) + SUBROUTINE create_se_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_se_print_section', & routineP = moduleN//':'//routineN @@ -3639,48 +3451,42 @@ SUBROUTINE create_se_print_section(section,error) TYPE(section_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Section of possible print options in SE code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"NEIGHBOR_LISTS",& description="Activates the printing of the neighbor lists used"//& " for the periodic SE calculations.", & - print_level=high_print_level,filename="",unit_str="angstrom",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="",unit_str="angstrom") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SUBCELL",& description="Activates the printing of the subcells used for the"//& "generation of neighbor lists for periodic SE.", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"EWALD_INFO",& description="Activates the printing of the information for "//& "Ewald multipole summation in periodic SE.", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_se_print_section ! ***************************************************************************** !> \brief creates the input section for use with the GA part of the code !> \param section the section to create -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** - SUBROUTINE create_se_ga_section(section,error) + SUBROUTINE create_se_ga_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_se_ga_section', & routineP = moduleN//':'//routineN @@ -3690,11 +3496,10 @@ SUBROUTINE create_se_ga_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"GA",& description="Sets up memory parameters for the storage of the integrals",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(& @@ -3703,22 +3508,18 @@ SUBROUTINE create_se_ga_section(section,error) description="Defines the number of linked cells for the neighbor list. "//& "Default value is number of processors",& usage="NCELLS 10",& - default_i_val=0,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_se_ga_section ! ***************************************************************************** !> \brief creates the input section for the se-memory part integral storage !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008 ! ***************************************************************************** - SUBROUTINE create_se_memory_section(section,error) + SUBROUTINE create_se_memory_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_se_memory_section', & routineP = moduleN//':'//routineN @@ -3728,21 +3529,19 @@ SUBROUTINE create_se_memory_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"MEMORY",& description="Sets up memory parameters for the storage of the integrals",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(& keyword=keyword,& name="EPS_STORAGE",& description="Storage threshold for compression is EPS_STORAGE",& usage="EPS_STORAGE 1.0E-10",& - default_r_val=1.0E-10_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -3750,17 +3549,16 @@ SUBROUTINE create_se_memory_section(section,error) description="Defines the maximum amount of memory [MB] used to store precomputed "//& "(possibly compressed) two-electron two-center integrals",& usage="MAX_MEMORY 256",& - default_i_val=50,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COMPRESS",& description="Enables the compression of the integrals in memory.",& usage="COMPRESS ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_se_memory_section @@ -3768,11 +3566,9 @@ END SUBROUTINE create_se_memory_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_mulliken_section(section,error) + SUBROUTINE create_mulliken_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mulliken_section', & routineP = moduleN//':'//routineN @@ -3782,41 +3578,38 @@ SUBROUTINE create_mulliken_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"MULLIKEN_RESTRAINT",& description="Use mulliken charges in a restraint (check code for details)",& - n_keywords=7, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="STRENGTH",& description="force constant of the restraint",& - usage="STRENGTH {real} ",default_r_val=0.1_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRENGTH {real} ",default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET",& description="target value of the restraint",& - usage="TARGET {real} ",default_r_val=1._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TARGET {real} ",default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies the list of atoms that is summed in the restraint",& usage="ATOMS {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mulliken_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_density_fitting_section(section,error) + SUBROUTINE create_density_fitting_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_density_fitting_section', & @@ -3828,65 +3621,63 @@ SUBROUTINE create_density_fitting_section(section,error) failure=.FALSE. NULLIFY(keyword, print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"DENSITY_FITTING",& description="Setup parameters for density fitting (Bloechl charges or density derived "//& " atomic point charges (DDAPC) charges)",& n_keywords=7, n_subsections=0, repeats=.FALSE., & - citations=(/Blochl1995/),& - error=error) + citations=(/Blochl1995/)) CALL keyword_create(keyword, name="NUM_GAUSS",& description="Specifies the numbers of gaussian used to fit the QM density for each atomic site.",& usage="NUM_GAUSS {integer}", & - n_var=1, type_of_var=integer_t, default_i_val=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t, default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PFACTOR",& description="Specifies the progression factor for the gaussian exponent for each atomic site.",& usage="PFACTOR {real}", & - n_var=1, type_of_var=real_t, default_r_val=1.5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=real_t, default_r_val=1.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIN_RADIUS",& description="Specifies the smallest radius of the gaussian used in the fit. All other radius are"//& " obtained with the progression factor.",& usage="MIN_RADIUS {real}", & - unit_str="angstrom",n_var=1, type_of_var=real_t, default_r_val=0.5_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom",n_var=1, type_of_var=real_t, default_r_val=0.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RADII",& description="Specifies all the radius of the gaussian used in the fit for each atomic site. The use"//& " of this keyword disables all other keywords of this section.",& usage="RADII {real} {real} .. {real}", & - unit_str="angstrom",n_var=-1, type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom",n_var=-1, type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GCUT",& description="Cutoff for charge fit in G-space.",& usage="GCUT {real}", & - n_var=1, type_of_var=real_t, default_r_val=SQRT(6.0_dp),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=real_t, default_r_val=SQRT(6.0_dp)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic information during the run", & - print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__") CALL keyword_create(keyword, name="CONDITION_NUMBER",& description="Prints information regarding the condition numbers of the A matrix (to be inverted)",& usage="ANALYTICAL_GTERM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_density_fitting_section @@ -3894,11 +3685,9 @@ END SUBROUTINE create_density_fitting_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_ddapc_restraint_section(section,error) + SUBROUTINE create_ddapc_restraint_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_ddapc_restraint_section', & @@ -3910,11 +3699,10 @@ SUBROUTINE create_ddapc_restraint_section(section,error) failure=.FALSE. NULLIFY(keyword, print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"DDAPC_RESTRAINT",& description="Use DDAPC charges in a restraint (check code for details)",& - n_keywords=7, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="TYPE_OF_DENSITY",& description="Specifies the type of density used for the fitting",& @@ -3922,35 +3710,35 @@ SUBROUTINE create_ddapc_restraint_section(section,error) enum_c_vals=s2a("FULL","SPIN"),& enum_i_vals=(/ do_full_density, do_spin_density/),& enum_desc=s2a("Full density","Spin density"),& - default_i_val=do_full_density, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_full_density) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STRENGTH",& description="force constant of the restraint",& - usage="STRENGTH {real} ",default_r_val=0.1_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRENGTH {real} ",default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET",& description="target value of the restraint",& - usage="TARGET {real} ",default_r_val=1._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TARGET {real} ",default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies the list of atoms that is summed in the restraint",& usage="ATOMS {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="COEFF",& description="Defines the the coefficient of the atom in the atom list (default is one) ",& usage="COEFF 1.0 -1.0",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTIONAL_FORM",& description="Specifies the functional form of the term added",& @@ -3958,16 +3746,15 @@ SUBROUTINE create_ddapc_restraint_section(section,error) enum_c_vals=s2a("RESTRAINT","CONSTRAINT"),& enum_i_vals=(/ do_ddapc_restraint, do_ddapc_constraint/),& enum_desc=s2a("Harmonic potential: s*(q-t)**2","Constraint form: s*(q-t)"),& - default_i_val=do_ddapc_restraint, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ddapc_restraint) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing basic info about the method", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_ddapc_restraint_section @@ -3975,11 +3762,9 @@ END SUBROUTINE create_ddapc_restraint_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_becke_restraint_section(section,error) + SUBROUTINE create_becke_restraint_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_becke_restraint_section', & @@ -3991,37 +3776,36 @@ SUBROUTINE create_becke_restraint_section(section,error) failure=.FALSE. NULLIFY(keyword, print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"BECKE_RESTRAINT",& description="Use Becke weight population in a restraint/constraint ",& - n_keywords=7, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="STRENGTH",& description="force constant of the restraint",& - usage="STRENGTH {real} ",default_r_val=0.1_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRENGTH {real} ",default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET",& description="target value of the restraint",& - usage="TARGET {real} ",default_r_val=1._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TARGET {real} ",default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies the list of atoms that is summed in the restraint",& usage="ATOMS {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="COEFF",& description="Defines the the coefficient of the atom in the atom list (default is one)",& usage="COEFF 1.0 -1.0",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTIONAL_FORM",& description="Specifies the functional form of the term added",& @@ -4029,9 +3813,9 @@ SUBROUTINE create_becke_restraint_section(section,error) enum_c_vals=s2a("RESTRAINT","CONSTRAINT"),& enum_i_vals=(/ do_ddapc_restraint, do_ddapc_constraint/),& enum_desc=s2a("Harmonic potential: s*(q-t)**2","Constraint form: s*(q-t)"),& - default_i_val=do_ddapc_restraint, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ddapc_restraint) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TYPE_OF_DENSITY",& description="Specifies the type of density used for the fitting",& @@ -4039,16 +3823,15 @@ SUBROUTINE create_becke_restraint_section(section,error) enum_c_vals=s2a("FULL","SPIN"),& enum_i_vals=(/ do_full_density, do_spin_density/),& enum_desc=s2a("Full density","Spin density"),& - default_i_val=do_full_density, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_full_density) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing basic info about the method", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_becke_restraint_section @@ -4056,11 +3839,9 @@ END SUBROUTINE create_becke_restraint_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_s2_restraint_section(section,error) + SUBROUTINE create_s2_restraint_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_s2_restraint_section', & routineP = moduleN//':'//routineN @@ -4070,24 +3851,23 @@ SUBROUTINE create_s2_restraint_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"S2_RESTRAINT",& description="Use S2 in a re/constraint (OT only)",& - n_keywords=7, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="STRENGTH",& description="force constant of the restraint",& - usage="STRENGTH {real} ",default_r_val=0.1_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRENGTH {real} ",default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET",& description="target value of the restraint",& - usage="TARGET {real} ",default_r_val=1._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TARGET {real} ",default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTIONAL_FORM",& description="Specifies the functional form of the term added",& @@ -4095,9 +3875,9 @@ SUBROUTINE create_s2_restraint_section(section,error) enum_c_vals=s2a("RESTRAINT","CONSTRAINT"),& enum_i_vals=(/ do_s2_restraint, do_s2_constraint/),& enum_desc=s2a("Harmonic potential: s*(q-t)**2","Constraint form: s*(q-t)"),& - default_i_val=do_s2_restraint, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_s2_restraint) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_s2_restraint_section @@ -4105,13 +3885,10 @@ END SUBROUTINE create_s2_restraint_section ! ***************************************************************************** !> \brief creates the input section for the tddfpt part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_tddfpt_section(section,error) + SUBROUTINE create_tddfpt_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_tddfpt_section', & routineP = moduleN//':'//routineN @@ -4122,11 +3899,11 @@ SUBROUTINE create_tddfpt_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"tddfpt",& description="parameters needed to set up the Time Dependent Density Functional PT",& n_keywords=5, n_subsections=1, repeats=.FALSE., & - citations=(/Iannuzzi2005/),error=error) + citations=(/Iannuzzi2005/)) NULLIFY(subsection,keyword) @@ -4136,76 +3913,76 @@ SUBROUTINE create_tddfpt_section(section,error) description=" maximal number of Krylov space vectors",& usage="MAX_KV someInteger>0",& n_var=1,type_of_var=integer_t,& - default_i_val=60, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=60) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTARTS",& variants=s2a("N_RESTARTS"),& description=" maximal number subspace search restarts",& usage="RESTARTS someInteger>0",& n_var=1,type_of_var=integer_t,& - default_i_val=5, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NEV",& variants=s2a("N_EV", "EV"),& description=" number of excitations to calculate",& usage="NEV someInteger>0",& n_var=1,type_of_var=integer_t,& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NLUMO",& description=" number of additional unoccupied orbitals ",& usage="NLUMO 10",& n_var=1,type_of_var=integer_t,& - default_i_val=5, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NREORTHO",& variants=s2a("N_REORTHO","REORTHO","REORTHOGONALITAZIONS"),& description=" number of reorthogonalization steps",& usage="NREORTHO someInteger>0",& n_var=1,type_of_var=integer_t,& - default_i_val=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Logical CALL keyword_create(keyword, name="KERNEL",& variants=s2a("DO_KERNEL"),& description="compute the kernel (debug purpose only)",& usage="KERNEL logical_value",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LSD_SINGLETS",& description="compute singlets using lsd vxc kernel",& usage="LSD_SINGLETS logical_value",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INVERT_S",& variants=s2a("INVERT_OVERLAP"),& description="use the inverse of the overlap matrix",& usage="INVERT_S logical_value",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRECONDITIONER",& variants=s2a("PRECOND"),& description="use the preconditioner (only for Davidson)",& usage="PRECONDITIONER logical_value",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Character CALL keyword_create(keyword, name="RES_ETYPE",& @@ -4215,9 +3992,9 @@ SUBROUTINE create_tddfpt_section(section,error) enum_c_vals=s2a("S","SINGLET","SINGLETS","T","TRIPLET","TRIPLETS"),& enum_i_vals=(/ tddfpt_singlet, tddfpt_singlet, tddfpt_singlet,& tddfpt_triplet, tddfpt_triplet, tddfpt_triplet/),& - default_i_val=tddfpt_singlet, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=tddfpt_singlet) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIAG_METHOD",& variants=s2a("DIAGONALIZATION_METHOD", "METHOD"),& @@ -4225,9 +4002,9 @@ SUBROUTINE create_tddfpt_section(section,error) usage="DIAG_METHOD DAVIDSON",& enum_c_vals=s2a("DAVIDSON","LANCZOS"),& enum_i_vals=(/ tddfpt_davidson, tddfpt_lanczos/),& - default_i_val=tddfpt_davidson, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=tddfpt_davidson) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OE_CORR",& variants=s2a("ORBITAL_EIGENVALUES_CORRECTION"),& @@ -4236,9 +4013,9 @@ SUBROUTINE create_tddfpt_section(section,error) usage="OE_CORR SAOP",& enum_c_vals=s2a("NONE", "LB", "LB_ALPHA", "LB94", "GLLB", "GLB", "SAOP","SIC"),& enum_i_vals=(/ oe_none, oe_lb, oe_lb, oe_lb, oe_gllb, oe_gllb, oe_saop, oe_sic /),& - default_i_val=oe_none, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=oe_none) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Real CALL keyword_create(keyword, name="CONVERGENCE",& @@ -4246,30 +4023,27 @@ SUBROUTINE create_tddfpt_section(section,error) description="The convergence of the eigenvalues",& usage="CONVERGENCE 1.0E-6 ",& n_var=1,type_of_var=real_t,& - default_r_val=1.0e-5_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_xc_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_xc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_sic_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_sic_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_tddfpt_section ! ***************************************************************************** !> \brief creates the input section for the relativistic part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jens ! ***************************************************************************** - SUBROUTINE create_relativistic_section(section,error) + SUBROUTINE create_relativistic_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_relativistic_section', & routineP = moduleN//':'//routineN @@ -4279,11 +4053,10 @@ SUBROUTINE create_relativistic_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"relativistic",& description="parameters needed and setup for relativistic calculations",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) @@ -4294,15 +4067,15 @@ SUBROUTINE create_relativistic_section(section,error) enum_i_vals=(/ rel_none, rel_dkh, rel_zora /),& enum_desc=s2a("Use no relativistic correction",& "Use Douglas-Kroll-Hess method",& - "Use ZORA method"), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use ZORA method")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DKH_order",& description="The order of the DKH transformation ",& - usage="DKH_order 2", default_i_val=2,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DKH_order 2", default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ZORA_type",& description="Type of ZORA method to be used",& @@ -4311,9 +4084,9 @@ SUBROUTINE create_relativistic_section(section,error) enum_desc=s2a("Full ZORA method (not implemented)",& "ZORA with atomic model potential",& "Scaled ZORA with atomic model potential"),& - enum_i_vals=(/ rel_zora_full, rel_zora_mp, rel_sczora_mp/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ rel_zora_full, rel_zora_mp, rel_sczora_mp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="transformation",& description="Type of DKH transformation",& @@ -4322,36 +4095,33 @@ SUBROUTINE create_relativistic_section(section,error) enum_i_vals=(/ rel_trans_full, rel_trans_molecule, rel_trans_atom/),& enum_desc=s2a("Use full matrix transformation",& "Use transformation blocked by molecule",& - "Use atomic blocks"),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use atomic blocks")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="z_cutoff",& description="The minimal atomic number considered for atom transformation",& - usage="z_cutoff 50", default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="z_cutoff 50", default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="potential",& description="External potential used in DKH transformation, full 1/r or erfc(r)/r",& usage="POTENTIAL {FULL,ERFC}", default_i_val=rel_pot_erfc,& enum_c_vals=s2a("FULL","ERFC"),& - enum_i_vals=(/ rel_pot_full, rel_pot_erfc /),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ rel_pot_full, rel_pot_erfc /)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_relativistic_section ! ***************************************************************************** !> \brief creates the structure of the section with the DFT SCF parameters !> \param section will contain the SCF section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_scf_section(section,error) + SUBROUTINE create_scf_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_scf_section', & routineP = moduleN//':'//routineN @@ -4363,89 +4133,86 @@ SUBROUTINE create_scf_section(section,error) failure=.FALSE. NULLIFY(print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"scf",& description="Parameters needed perform an SCF run.",& - n_keywords=24, n_subsections=3, repeats=.FALSE., & - error=error) + n_keywords=24, n_subsections=3, repeats=.FALSE.) NULLIFY (subsection) - CALL create_ot_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ot_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_diagonalization_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_diagonalization_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_outer_scf_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_outer_scf_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_smear_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_smear_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_mixing_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mixing_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY (keyword) CALL keyword_create(keyword, name="MAX_ITER_LUMO",& variants=(/"MAX_ITER_LUMOS"/),& description="The maximum number of iteration for the lumo computation",& - usage="MAX_ITER_LUMO 100", default_i_val=299,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER_LUMO 100", default_i_val=299) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_LUMO",& variants=(/"EPS_LUMOS"/),& description="target accuracy of the computation of the lumo energy",& - usage="EPS_LUMO 1.e-6", default_r_val=1.0e-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_LUMO 1.e-6", default_r_val=1.0e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_SCF",& description="Maximum number of SCF iteration to be performed for one optimization",& - usage="MAX_SCF 200", default_i_val=50,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_SCF 200", default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_SCF_HISTORY", variants=(/"MAX_SCF_HIST"/), & description="Maximum number of SCF iterations after the history pipeline is filled", & - usage="MAX_SCF_HISTORY 1", default_i_val=0,lone_keyword_i_val=1, & - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="MAX_SCF_HISTORY 1", default_i_val=0,lone_keyword_i_val=1) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_DIIS",& variants=(/"MAX_DIIS_BUFFER_SIZE"/),& description="Maximum number of DIIS vectors to be used",& - usage="MAX_DIIS 3", default_i_val=4,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_DIIS 3", default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LEVEL_SHIFT",& variants=(/"LSHIFT"/),& description="Use level shifting to improve convergence",& - usage="LEVEL_SHIFT 0.1", default_r_val=0._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LEVEL_SHIFT 0.1", default_r_val=0._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SCF",& description="Target accuracy for the SCF convergence.",& - usage="EPS_SCF 1.e-6", default_r_val=1.e-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SCF 1.e-6", default_r_val=1.e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SCF_HISTORY", variants=(/"EPS_SCF_HIST"/), & description="Target accuracy for the SCF convergence after the history pipeline is filled.",& - usage="EPS_SCF_HISTORY 1.e-5", default_r_val=0.0_dp,lone_keyword_r_val=1.0e-5_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SCF_HISTORY 1.e-5", default_r_val=0.0_dp,lone_keyword_r_val=1.0e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHOLESKY",& description="If the cholesky method should be used for computing "//& @@ -4456,22 +4223,21 @@ SUBROUTINE create_scf_section(section,error) "Reduce is replaced by two restore",& "Restore uses operator multiply by inverse of the triangular matrix",& "Like inverse, but matrix stored as dbcsr, sparce matrix algebra used when possible"),& - enum_i_vals=(/cholesky_off,cholesky_reduce,cholesky_restore,cholesky_inverse,cholesky_dbcsr/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/cholesky_off,cholesky_reduce,cholesky_restore,cholesky_inverse,cholesky_dbcsr/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_EIGVAL",& description="Throw away linear combinations of basis functions with a small eigenvalue in S",& - usage="EPS_EIGVAL 1.0", default_r_val=1.0e-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_EIGVAL 1.0", default_r_val=1.0e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_DIIS",& description="Threshold on the convergence to start using DIAG/DIIS",& - usage="EPS_DIIS 5.0e-2", default_r_val=0.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_DIIS 5.0e-2", default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCF_GUESS",& description="Change the initial guess for the wavefunction.",& @@ -4488,28 +4254,27 @@ SUBROUTINE create_scf_section(section,error) "Generate a sparse wavefunction using the atomic code (for OT based methods)", & "Skip initial guess (only for NON-SCC DFTB)."), & enum_i_vals=(/atomic_guess,restart_guess,random_guess,core_guess,& - densities_guess,history_guess,mopac_guess,sparse_guess,no_guess/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + densities_guess,history_guess,mopac_guess,sparse_guess,no_guess/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NROW_BLOCK",& description="sets the number of rows in a scalapack block",& - usage="NROW_BLOCK 31", default_i_val=32,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NROW_BLOCK 31", default_i_val=32) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NCOL_BLOCK",& description="Sets the number of columns in a scalapack block",& - usage="NCOL_BLOCK 31", default_i_val=32,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NCOL_BLOCK 31", default_i_val=32) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ADDED_MOS",& description="Number of additional MOS added for each spin",& - usage="ADDED_MOS", default_i_val=0,n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ADDED_MOS", default_i_val=0,n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="ROKS_SCHEME",& @@ -4519,10 +4284,9 @@ SUBROUTINE create_scf_section(section,error) n_var=1,& enum_c_vals=s2a("GENERAL","HIGH-SPIN"),& enum_i_vals=(/general_roks,high_spin_roks/),& - default_i_val=high_spin_roks,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=high_spin_roks) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="ROKS_F",& @@ -4533,10 +4297,9 @@ SUBROUTINE create_scf_section(section,error) repeats=.FALSE.,& n_var=1,& type_of_var=real_t,& - default_r_val=0.5_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="ROKS_PARAMETERS",& @@ -4549,13 +4312,12 @@ SUBROUTINE create_scf_section(section,error) repeats=.FALSE.,& n_var=6,& type_of_var=real_t,& - default_r_vals=(/-0.5_dp,1.5_dp,0.5_dp,0.5_dp,1.5_dp,-0.5_dp/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/-0.5_dp,1.5_dp,0.5_dp,0.5_dp,1.5_dp,-0.5_dp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,"PRINT", "Printing of information during the SCF.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"RESTART",& description="Controls the dumping of the MO restart file during SCF."//& @@ -4563,128 +4325,115 @@ SUBROUTINE create_scf_section(section,error) "See also RESTART_HISTORY", & print_level=low_print_level, common_iter_levels=3,& each_iter_names=s2a("QS_SCF"),each_iter_values=(/20/), & - add_last=add_last_numeric,filename="RESTART",error=error) + add_last=add_last_numeric,filename="RESTART") CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum index of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=3, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + default_i_val=3) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART_HISTORY",& description="Dumps unique MO restart files during the run keeping all of them.",& print_level=low_print_level, common_iter_levels=0,& each_iter_names=s2a("__ROOT__","MD","GEO_OPT","ROT_OPT","NEB","METADYNAMICS","QS_SCF"),& each_iter_values=(/500,500,500,500,500,500,500/), & - filename="RESTART",error=error) + filename="RESTART") CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum index of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=3, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + default_i_val=3) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"iteration_info",& description="Controls the printing of basic iteration information during the SCF.", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") CALL keyword_create(keyword, name="time_cumul",& description="If the printkey is activated switches the printing of timings"//& " to cumulative (over the SCF).",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic information during the SCF.", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"MO_ORTHONORMALITY",& description="Controls the printing relative to the orthonormality of MOs (CT S C).", & - print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"MO_MAGNITUDE",& description="Prints the min/max eigenvalues of the overlap of the MOs without S (CT C).", & - print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"detailed_energy",& description="Controls the printing of detailed energy information.", & - print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"diis_info",& description="Controls the printing of DIIS information.", & - print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"total_densities",& description="Controls the printing of total densities.", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"Lanczos",& description="Controls the printing of information on Lanczos refinement iterations.", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"DIAG_SUB_SCF",& description="Controls the printing of information on subspace diagonalization internal loop. ", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"Davidson",& description="Controls the printing of information on Davidson iterations.", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FILTER_MATRIX",& description="Controls the printing of information on Filter Matrix method.", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_scf_section ! ***************************************************************************** !> \brief creates the KG section !> \param section ... -!> \param error ... !> \author Martin Haeufel [2012.07] ! ***************************************************************************** - SUBROUTINE create_kg_section(section,error) + SUBROUTINE create_kg_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_kg_section', & routineP = moduleN//':'//routineN @@ -4695,12 +4444,12 @@ SUBROUTINE create_kg_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"KG_METHOD",& description="Specifies the parameters for a Kim-Gordon-like partitioning"//& " into molecular subunits",& n_keywords=0, n_subsections=1, repeats=.FALSE., & - citations=(/Iannuzzi2006, Brelaz1979/),error=error) + citations=(/Iannuzzi2006, Brelaz1979/)) NULLIFY (keyword, subsection, print_key) @@ -4711,10 +4460,9 @@ SUBROUTINE create_kg_section(section,error) enum_c_vals=s2a( "DSATUR", "GREEDY"),& enum_desc=s2a("Maximum degree of saturation, relatively accurate",& "Greedy, fast coloring, less accurate"),& - enum_i_vals=(/kg_color_dsatur, kg_color_greedy /),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/kg_color_dsatur, kg_color_greedy /)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TNADD_METHOD",& description="Algorithm to use for the calculation of the nonadditive kinetic energy.",& @@ -4723,56 +4471,50 @@ SUBROUTINE create_kg_section(section,error) enum_c_vals=s2a( "EMBEDDING", "ATOMIC"),& enum_desc=s2a("Use full embedding potential (see Iannuzzi et al)",& "Use sum of atomic model potentials"),& - enum_i_vals=(/kg_tnadd_embed, kg_tnadd_atomic /),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/kg_tnadd_embed, kg_tnadd_atomic /)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection, name="PRINT",& description="Print section",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"NEIGHBOR_LISTS",& description="Controls the printing of the neighbor lists.", & - print_level=low_print_level, filename="__STD_OUT__", unit_str="angstrom",& - error=error) + print_level=low_print_level, filename="__STD_OUT__", unit_str="angstrom") CALL keyword_create(keyword=keyword,& name="SAB_ORB_FULL",& description="Activates the printing of the full orbital "//& "orbital neighbor lists.", & default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="SAB_ORB_MOLECULAR",& description="Activates the printing of the orbital "//& "orbital neighbor lists for molecular subsets.",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="SAC_KIN",& description="Activates the printing of the orbital "//& "atomic potential neighbor list.",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection, print_key, error=error) - CALL section_release(print_key, error=error) + CALL section_add_subsection(subsection, print_key) + CALL section_release(print_key) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_kg_section @@ -4781,13 +4523,10 @@ END SUBROUTINE create_kg_section !> \brief creates the structure of the section with SCF parameters !> controlling an other loop !> \param section will contain the SCF section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele [2006.03] ! ***************************************************************************** - SUBROUTINE create_outer_scf_section(section,error) + SUBROUTINE create_outer_scf_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_outer_scf_section', & routineP = moduleN//':'//routineN @@ -4796,20 +4535,18 @@ SUBROUTINE create_outer_scf_section(section,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"OUTER_SCF",& description="parameters controlling the outer SCF loop",& - n_keywords=9, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=9, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the outer SCF loop",& - usage="&OUTER_SCF ON",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="&OUTER_SCF ON",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TYPE",& description="Specifies which kind of outer SCF should be employed",& @@ -4821,10 +4558,9 @@ SUBROUTINE create_outer_scf_section(section,error) "Enforce a constraint on the Becke weight population,requires the corresponding section", & "Do nothing in the outer loop, useful for resetting the inner loop,"),& enum_i_vals=(/outer_scf_ddapc_constraint,outer_scf_s2_constraint,& - outer_scf_becke_constraint,outer_scf_none/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + outer_scf_becke_constraint,outer_scf_none/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OPTIMIZER",& description="Method used to bring the outer loop to a stationary point",& @@ -4835,17 +4571,16 @@ SUBROUTINE create_outer_scf_section(section,error) "Uses a Direct Inversion in the Iterative Subspace method", & "Do nothing, useful only with the none type",& "Bisection on the gradient, useful for difficult one dimensional cases"),& - enum_i_vals=(/outer_scf_optimizer_sd,outer_scf_optimizer_diis,outer_scf_optimizer_none,outer_scf_optimizer_bisect/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/outer_scf_optimizer_sd,outer_scf_optimizer_diis,outer_scf_optimizer_none,outer_scf_optimizer_bisect/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BISECT_TRUST_COUNT",& description="Maximum number of times the same point will be used in bisection,"//& " a small number guards against the effect of wrongly converged states.", & - usage="BISECT_TRUST_COUNT 5", default_i_val=10,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BISECT_TRUST_COUNT 5", default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SCF",& description="The target gradient of the outer SCF variables. "//& @@ -4853,35 +4588,35 @@ SUBROUTINE create_outer_scf_section(section,error) "the value that can be reached in the outer loop, "//& "typically EPS_SCF of the outer loop must be smaller "//& "than EPS_SCF of the inner loop.", & - usage="EPS_SCF 1.0E-6 ", default_r_val=1.0E-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SCF 1.0E-6 ", default_r_val=1.0E-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIIS_BUFFER_LENGTH",& description="Maximum number of DIIS vectors used ", & - usage="DIIS_BUFFER_LENGTH 5", default_i_val=3,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DIIS_BUFFER_LENGTH 5", default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXTRAPOLATION_ORDER",& description="Number of past states used in the extrapolation of the variables during e.g. MD", & - usage="EXTRAPOLATION_ORDER 5", default_i_val=3,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EXTRAPOLATION_ORDER 5", default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_SCF",& description="The maximum number of outer loops ", & - usage="MAX_SCF 20", default_i_val=50,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_SCF 20", default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEP_SIZE",& description="The initial step_size used in the optimizer (currently steepest descent)."//& "Note that in cases where a sadle point is sought for (DDAPC_CONSTRAINT),"//& " this can be negative", & - usage="STEP_SIZE -1.0", default_r_val=0.5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STEP_SIZE -1.0", default_r_val=0.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_outer_scf_section @@ -4890,13 +4625,10 @@ END SUBROUTINE create_outer_scf_section ! ***************************************************************************** !> \brief Create the BSSE section for counterpoise correction !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_bsse_section(section,error) + SUBROUTINE create_bsse_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_bsse_section', & routineP = moduleN//':'//routineN @@ -4907,50 +4639,47 @@ SUBROUTINE create_bsse_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BSSE",& description="This section is used to set up the BSSE calculation. "//& "It also requires that for each atomic kind X a kind X_ghost is present, "//& "with the GHOST keyword specified, in addition to the other required fields.",& - n_keywords=3, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=3, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword, subsection) ! FRAGMENT SECTION CALL section_create(subsection,name="FRAGMENT",& description="Specify the atom number belonging to this fragment.",& - n_keywords=2, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="LIST",& description="Specifies a list of atoms.",& usage="LIST {integer} {integer} .. {integer}", & - repeats=.TRUE., n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE., n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! CONFIGURATION SECTION CALL section_create(subsection,name="CONFIGURATION",& description="Specify additional parameters for the combinatorial configurations.",& - n_keywords=2, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="GLB_CONF",& description="Specifies the global configuration using 1 or 0.",& usage="GLB_CONF {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SUB_CONF",& description="Specifies the subconfiguration using 1 or 0 belonging to the global configuration.",& usage="SUB_CONF {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="MULTIPLICITY",& @@ -4959,36 +4688,34 @@ SUBROUTINE create_bsse_section(section,error) "Specify 3 for a triplet, 4 for a quartet,and so on. Default is 1 (singlet) for an "//& "even number and 2 (doublet) for an odd number of electrons.",& usage="MULTIPLICITY 3",& - default_i_val=0,& ! this default value is just a flag to get the above - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) ! this default value is just a flag to get the above + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE",& description="The total charge for each fragment.",& usage="CHARGE -1",& - default_i_val=0,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + default_i_val=0) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL section_create(subsection,name="FRAGMENT_ENERGIES",& description="This section contains the energies of the fragments already"//& " computed. It is useful as a summary and specifically for restarting BSSE runs.",& - n_keywords=2, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The energy computed for each fragment",repeats=.TRUE.,& - usage="{REAL}", type_of_var=real_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + usage="{REAL}", type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_print_bsse_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_print_bsse_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_bsse_section @@ -4996,13 +4723,10 @@ END SUBROUTINE create_bsse_section ! ***************************************************************************** !> \brief Create the print bsse section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_print_bsse_section(section,error) + SUBROUTINE create_print_bsse_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_bsse_section', & routineP = moduleN//':'//routineN @@ -5012,41 +4736,36 @@ SUBROUTINE create_print_bsse_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Section of possible print options in BSSE code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of information regarding the run.",& - print_level=low_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART",& description="Controls the dumping of the restart file during BSSE runs."//& "By default the restart is updated after each configuration calculation is "//& " completed.", & print_level=silent_print_level, common_iter_levels=0, & - add_last=add_last_numeric,filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric,filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_bsse_section ! ***************************************************************************** !> \brief creates the interpolation section for the periodic QM/MM !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_gspace_interp_section(section,error) + SUBROUTINE create_gspace_interp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gspace_interp_section', & routineP = moduleN//':'//routineN @@ -5057,11 +4776,10 @@ SUBROUTINE create_gspace_interp_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="interpolator",& description="controls the interpolation for the G-space term",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, print_key) @@ -5073,10 +4791,9 @@ SUBROUTINE create_gspace_interp_section(section,error) enum_c_vals=s2a( "copy","spl3_nopbc_aint1","spl3_nopbc_precond1",& "spl3_nopbc_aint2","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_1,& - precond_spl3_aint2, precond_spl3_2, precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_aint2, precond_spl3_2, precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="precond",& description="The preconditioner used"//& @@ -5086,29 +4803,28 @@ SUBROUTINE create_gspace_interp_section(section,error) enum_c_vals=s2a("copy","spl3_nopbc_aint1","spl3_nopbc_precond1",& "spl3_nopbc_aint2","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_1,& - precond_spl3_aint2, precond_spl3_2, precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_aint2, precond_spl3_2, precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_x",& description="accuracy on the solution for spline3 the interpolators",& - usage="eps_x 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_x 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_r",& description="accuracy on the residual for spline3 the interpolators",& - usage="eps_r 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_r 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="max_iter",& variants=(/'maxiter'/),& description="the maximum number of iterations",& - usage="max_iter 200", default_i_val=100, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="max_iter 200", default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"conv_info",& @@ -5116,9 +4832,9 @@ SUBROUTINE create_gspace_interp_section(section,error) " of the spline methods should be printed", & print_level=medium_print_level,each_iter_names=s2a("SPLINE_FIND_COEFFS"),& each_iter_values=(/10/),filename="__STD_OUT__",& - add_last=add_last_numeric,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_gspace_interp_section @@ -5126,13 +4842,10 @@ END SUBROUTINE create_gspace_interp_section !> \brief input section for optional parameters for LRIGPW !> LRI: local resolution of identity !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze [02.2015] ! ***************************************************************************** - SUBROUTINE create_lrigpw_section(section,error) + SUBROUTINE create_lrigpw_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_lrigpw_section', & routineP = moduleN//':'//routineN @@ -5142,11 +4855,10 @@ SUBROUTINE create_lrigpw_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="LRIGPW",& description="This section specifies optional parameters for LRIGPW.",& - n_keywords=3, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) @@ -5171,47 +4883,43 @@ SUBROUTINE create_lrigpw_section(section,error) "Calculating the pseudoinverse is much more expensive."),& enum_i_vals=(/do_lri_inv, do_lri_pseudoinv_svd,& do_lri_pseudoinv_diag, do_lri_inv_auto/),& - default_i_val=do_lri_inv,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_lri_inv) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_CONDITION_NUM", & description="If AUTOSELECT is chosen for LRI_OVERLAP_MATRIX, this "//& "keyword specifies that the pseudoinverse is calculated "//& "only if the LOG of the condition number of the lri "//& "overlap matrix is larger than the given value.",& - usage="MAX_CONDITION_NUM 20.0", default_r_val=20.0_dp,& - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="MAX_CONDITION_NUM 20.0", default_r_val=20.0_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DEBUG_LRI_INTEGRALS",& description="Debug the integrals needed for LRIGPW.",& usage="DEBUG_LRI_INTEGRALS TRUE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHG_LRI_INTEGRALS",& description="Uses the SHG (solid harmonic Gaussian) integral "//& "scheme instead of Obara-Saika",& usage="SHG_LRI_INTEGRALS TRUE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_lrigpw_section ! ***************************************************************************** !> \brief input section for optimization of the auxililary basis for LRIGPW !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze [05.2014] ! ***************************************************************************** - SUBROUTINE create_optimize_lri_basis_section(section,error) + SUBROUTINE create_optimize_lri_basis_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_optimize_lri_basis_section', & @@ -5223,60 +4931,55 @@ SUBROUTINE create_optimize_lri_basis_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="OPTIMIZE_LRI_BASIS",& description="This section specifies the parameters for optimizing "//& "the lri auxiliary basis sets for LRIGPW. The Powell optimizer is used.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword,subsection) CALL keyword_create(keyword, name="ACCURACY", & description="Target accuracy for the objective function (RHOEND)",& - usage="ACCURACY 5.0E-4", default_r_val=1.0E-5_dp,& - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="ACCURACY 5.0E-4", default_r_val=1.0E-5_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_FUN", & description="Maximum number of function evaluations",& - usage="MAX_FUN 200", default_i_val=4000,& - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="MAX_FUN 200", default_i_val=4000) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEP_SIZE", & description="Initial step size for search algorithm (RHOBEG)",& - usage="STEP_SIZE 1.0E-1", default_r_val=5.0E-2_dp,& - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="STEP_SIZE 1.0E-1", default_r_val=5.0E-2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CONDITION_WEIGHT", & description="This keyword allows to give different weight "//& "factors to the condition number (LOG(cond) is used).",& - usage="CONDITION_WEIGHT 1.0E-4", default_r_val=1.0E-6_dp,& - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="CONDITION_WEIGHT 1.0E-4", default_r_val=1.0E-6_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_CONDITION_NUMBER",& description="Determines whether condition number should be part "//& "of optimization or not",& usage="USE_CONDITION_NUMBER",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GEOMETRIC_SEQUENCE",& description="Exponents are assumed to be a geometric squence. "//& "Only the minimal and maximal exponents of one set are optimized and "//& "the other exponents are obtained by geometric progression.",& usage="GEOMETRIC_SEQUENCE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DEGREES_OF_FREEDOM",& description="Specifies the degrees of freedom in the basis "//& @@ -5287,26 +4990,23 @@ SUBROUTINE create_optimize_lri_basis_section(section,error) "Set all coefficients in the basis set to be variable.",& "Set all exponents in the basis to be variable."),& enum_i_vals=(/do_lri_opt_all, do_lri_opt_coeff, do_lri_opt_exps/),& - default_i_val=do_lri_opt_exps,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_lri_opt_exps) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_constrain_exponents_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_constrain_exponents_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_optimize_lri_basis_section ! ***************************************************************************** !> \brief input section for constraints for auxiliary basis set optimization !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze [11.2014] ! ***************************************************************************** - SUBROUTINE create_constrain_exponents_section(section,error) + SUBROUTINE create_constrain_exponents_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_constrain_exponents_section', & @@ -5320,8 +5020,7 @@ SUBROUTINE create_constrain_exponents_section(section,error) CALL section_create(section,name="CONSTRAIN_EXPONENTS",& description="specifies constraints for the exponents of the "//& "lri auxiliary basis sets in the optimization.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) @@ -5329,15 +5028,15 @@ SUBROUTINE create_constrain_exponents_section(section,error) description="Defines the upper and lower boundaries as "//& "(1+scale)*exp and (1-scale)*exp. Fermi-like constraint "//& "function",& - usage="SCALE 0.3", default_r_val=0.3_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCALE 0.3", default_r_val=0.3_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FERMI_EXP",& description="Exponent in the fermi-like constraint function. ",& - usage="FERMI_EXP 2.63", default_r_val=2.63391_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FERMI_EXP 2.63", default_r_val=2.63391_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_constrain_exponents_section @@ -5345,13 +5044,10 @@ END SUBROUTINE create_constrain_exponents_section ! ***************************************************************************** !> \brief creates the multigrid !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_mgrid_section(section,error) + SUBROUTINE create_mgrid_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mgrid_section', & routineP = moduleN//':'//routineN @@ -5362,47 +5058,46 @@ SUBROUTINE create_mgrid_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="mgrid",& description="multigrid information",& - n_keywords=5, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="NGRIDS",& description="The number of multigrids to use",& - usage="ngrids 1", default_i_val=4, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ngrids 1", default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="cutoff",& description="The cutoff of the finest grid level. Default value for "//& "SE or DFTB calculation is 1.0 [Ry].",& usage="cutoff 300",default_r_val=cp_unit_to_cp2k(value=280.0_dp,& - unit_str="Ry",error=error), n_var=1, unit_str="Ry", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="Ry"), n_var=1, unit_str="Ry") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="progression_factor",& description="Factor used to find the cutoff of the multigrids that"//& " where not given explicitly",& - usage="progression_factor ", default_r_val=3._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="progression_factor ", default_r_val=3._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="commensurate",& description="If the grids should be commensurate. If true overrides "//& "the progression factor and the cutoffs of the sub grids",& usage="commensurate", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="realspace",& description="If both rho and rho_gspace are needed ",& usage="realspace", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REL_CUTOFF",& variants=(/"RELATIVE_CUTOFF"/),& @@ -5412,54 +5107,48 @@ SUBROUTINE create_mgrid_section(section,error) " Or for simulations with a variable cell."//& " Versions prior to 2.3 used a default of 30Ry.",& usage="RELATIVE_CUTOFF real", default_r_val=20.0_dp,& - unit_str="Ry",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="Ry") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MULTIGRID_SET",& description="Activate a manual setting of the multigrids",& - usage="MULTIGRID_SET", default_l_val=.FALSE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MULTIGRID_SET", default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SKIP_LOAD_BALANCE_DISTRIBUTED",& description="Skip load balancing on distributed multigrids, which might be memory intensive."//& "If not explicitly specified, runs using more than 1024 MPI tasks will default to .TRUE.",& - usage="SKIP_LOAD_BALANCE_DISTRIBUTED", default_l_val=.FALSE., lone_keyword_l_val=.TRUE., & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SKIP_LOAD_BALANCE_DISTRIBUTED", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="MULTIGRID_CUTOFF",& variants=(/"CUTOFF_LIST"/),& description="List of cutoff values to set up multigrids manually",& - usage="MULTIGRID_CUTOFF 200.0 100.0 ", n_var=-1, type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MULTIGRID_CUTOFF 200.0 100.0 ", n_var=-1, type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_rsgrid_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_rsgrid_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_interp_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_interp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_mgrid_section ! ***************************************************************************** !> \brief creates the interpolation section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_interp_section(section,error) + SUBROUTINE create_interp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_interp_section', & routineP = moduleN//':'//routineN @@ -5470,11 +5159,10 @@ SUBROUTINE create_interp_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="interpolator",& description="kind of interpolation used between the multigrids",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, print_key) @@ -5484,18 +5172,17 @@ SUBROUTINE create_interp_section(section,error) default_i_val=pw_interp,& enum_c_vals=s2a("pw","spline3_nopbc","spline3"),& enum_i_vals=(/pw_interp,& - spline3_nopbc_interp,spline3_pbc_interp/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + spline3_nopbc_interp,spline3_pbc_interp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="safe_computation",& description="if a non unrolled calculation is to be performed in parallel",& usage="safe_computation OFF",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="aint_precond",& description="the approximate inverse to use to get the starting point"//& @@ -5505,10 +5192,9 @@ SUBROUTINE create_interp_section(section,error) enum_c_vals=s2a( "copy","spl3_nopbc_aint1","spl3_nopbc_aint2",& "spl3_nopbc_precond1","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_aint2,& - precond_spl3_1,precond_spl3_2,precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_1,precond_spl3_2,precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="precond",& description="The preconditioner used"//& @@ -5518,29 +5204,28 @@ SUBROUTINE create_interp_section(section,error) enum_c_vals=s2a( "copy","spl3_nopbc_aint1","spl3_nopbc_aint2",& "spl3_nopbc_precond1","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_aint2,& - precond_spl3_1,precond_spl3_2,precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_1,precond_spl3_2,precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_x",& description="accuracy on the solution for spline3 the interpolators",& - usage="eps_x 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_x 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_r",& description="accuracy on the residual for spline3 the interpolators",& - usage="eps_r 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_r 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="max_iter",& variants=(/'maxiter'/),& description="the maximum number of iterations",& - usage="max_iter 200", default_i_val=100, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="max_iter 200", default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"conv_info",& @@ -5548,22 +5233,19 @@ SUBROUTINE create_interp_section(section,error) " of the spline methods should be printed", & print_level=medium_print_level,each_iter_names=s2a("SPLINE_FIND_COEFFS"),& each_iter_values=(/10/),filename="__STD_OUT__",& - add_last=add_last_numeric,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_interp_section ! ***************************************************************************** !> \brief creates the sic (self interaction correction) section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_sic_section(section,error) + SUBROUTINE create_sic_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_sic_section', & routineP = moduleN//':'//routineN @@ -5573,12 +5255,11 @@ SUBROUTINE create_sic_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"sic",& description="parameters for the self interaction correction",& n_keywords=6, n_subsections=0, repeats=.FALSE., & - citations=(/VandeVondele2005b,Perdew1981,Avezac2005/),& - error=error) + citations=(/VandeVondele2005b,Perdew1981,Avezac2005/)) NULLIFY(keyword) @@ -5586,17 +5267,17 @@ SUBROUTINE create_sic_section(section,error) description="Scaling of the coulomb term in sic [experimental]",& usage="SIC_SCALING_A 0.5",& citations=(/VandeVondele2005b/),& - default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIC_SCALING_B",& description="Scaling of the xc term in sic [experimental]",& usage="SIC_SCALING_B 0.5",& citations=(/VandeVondele2005b/),& - default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIC_METHOD",& description="Method used to remove the self interaction",& @@ -5611,10 +5292,9 @@ SUBROUTINE create_sic_section(section,error) " on the spin density / doublet unpaired orbital",& "The average density correction",& "(scaled) Perdew-Zunger correction explicitly on a set of orbitals."),& - citations=(/VandeVondele2005b,Perdew1981,Avezac2005/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/VandeVondele2005b,Perdew1981,Avezac2005/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORBITAL_SET",& description="Type of orbitals treated with the SIC",& @@ -5623,22 +5303,19 @@ SUBROUTINE create_sic_section(section,error) enum_c_vals=s2a("UNPAIRED","ALL"),& enum_desc=s2a("correction for the unpaired orbitals only, requires a restricted open shell calculation",& "correction for all orbitals, requires a LSD or ROKS calculation"),& - enum_i_vals=(/sic_list_unpaired,sic_list_all/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/sic_list_unpaired,sic_list_all/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_sic_section ! ***************************************************************************** !> \brief creates the low spin roks section !> \param section ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_low_spin_roks_section(section,error) + SUBROUTINE create_low_spin_roks_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_low_spin_roks_section', & routineP = moduleN//':'//routineN @@ -5648,42 +5325,39 @@ SUBROUTINE create_low_spin_roks_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"LOW_SPIN_ROKS",& description="Specify the details of the low spin ROKS method."//& "In particular, one can specify various terms added to the energy of the high spin roks configuration"//& " with a energy scaling factor, and a prescription of the spin state.",& - n_keywords=6, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=6, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword,name="ENERGY_SCALING",& description="The scaling factors for each term added to the total energy."//& "This list should contain one number for each term added to the total energy.",& usage="ENERGY_SCALING 1.0 -1.0 ",& - n_var=-1,type_of_var=real_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="SPIN_CONFIGURATION",& description="for each singly occupied orbital, specify if this should be an alpha (=1) or a beta (=2) orbital"//& "This keyword should be repeated, each repetition corresponding to an additional term." ,& usage="SPIN_CONFIGURATION 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_low_spin_roks_section ! ***************************************************************************** !> \brief Creates the section for applying an electrostatic external potential !> \param section ... -!> \param error ... !> \date 12.2009 !> \author teo ! ***************************************************************************** - SUBROUTINE create_ext_pot_section(section,error) + SUBROUTINE create_ext_pot_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ext_pot_section', & routineP = moduleN//':'//routineN @@ -5693,93 +5367,90 @@ SUBROUTINE create_ext_pot_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EXTERNAL_POTENTIAL",& description="Section controlling the presence of an electrostatic "//& "external potential dependent on the atomic positions (X,Y,Z). "//& "As the external potential is currently applied via a grid, "//& "it only works with DFT based methods (GPW/GAPW) that already use "//& "a grid based approach to solve the Poisson equation.",& - n_keywords=7, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="FUNCTION",& description="Specifies the functional form in mathematical notation. Variables must be the atomic "//& "coordinates (X,Y,Z) of the grid.",usage="FUNCTION X^2+Y^2+Z^2+LOG(ABS(X+Y))", & - type_of_var=lchar_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARAMETERS",& description="Defines the parameters of the functional form",& usage="PARAMETERS a b D", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VALUES",& description="Defines the values of parameter of the functional form",& usage="VALUES ", type_of_var=real_t,& - n_var=-1, repeats=.TRUE., unit_str="internal_cp2k", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE., unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="UNITS",& description="Optionally, allows to define valid CP2K unit strings for each parameter value. "//& "It is assumed that the corresponding parameter value is specified in this unit.",& usage="UNITS angstrom eV*angstrom^-1 angstrom^1 K", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STATIC",& description="Specifies the external potential as STATIC or time dependent. At the moment "//& "only static potentials are implemented.",& - usage="STATIC T", default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STATIC T", default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DX",& description="Parameter used for computing the derivative with the Ridders' method.",& - usage="DX ", default_r_val=0.1_dp, unit_str="bohr", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DX ", default_r_val=0.1_dp, unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ERROR_LIMIT",& description="Checks that the error in computing the derivative is not larger than "//& "the value set; in case error is larger a warning message is printed.",& - usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) !keyword for reading the external potential from cube file CALL keyword_create(keyword, name="READ_FROM_CUBE",& description="Switch for reading the external potential from file pot.cube. The values "//& "of the potential must be on the grid points of the realspace grid.",& - usage="READ_FROM_CUBE T", default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="READ_FROM_CUBE T", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) !keyword for scaling the external potential that is read from file by a constant factor CALL keyword_create(keyword, name="SCALING_FACTOR",& description="A factor for scaling the the external potential that is read from file."//& "The value of the potential at each grid point is multiplied by this factor.",& - usage="SCALING_FACTOR ", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCALING_FACTOR ", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ext_pot_section ! ***************************************************************************** !> \brief ZMP Creates the section for reading user supplied external density !> \param section ... -!> \param error ... !> \date 03.2011 !> \author D. Varsano [daniele.varsano@nano.cnr.it] ! ***************************************************************************** - SUBROUTINE create_ext_den_section(section,error) + SUBROUTINE create_ext_den_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ext_den_section', & routineP = moduleN//':'//routineN @@ -5789,12 +5460,11 @@ SUBROUTINE create_ext_den_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EXTERNAL_DENSITY",& description="Section for the use of the ZMP technique on external densities.",& n_keywords=4, n_subsections=0, repeats=.FALSE., & - citations=(/Zhao1994, Tozer1996/),& - error=error) + citations=(/Zhao1994, Tozer1996/)) NULLIFY(keyword) CALL keyword_create(keyword, name="FILE_DENSITY",& @@ -5804,9 +5474,9 @@ SUBROUTINE create_ext_den_section(section,error) "be previously defined choosing the plane waves cut-off in section MGRID"//& "keyword CUTOFF, and the cube dimention in section SUBSYS / CELL / keyword ABC",& usage="DENSITY_FILE_NAME ",& - type_of_var=char_t,default_c_val="RHO_O.dat", n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t,default_c_val="RHO_O.dat", n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LAMBDA",& description="Lagrange multiplier defined in the constraint ZMP method. When starting, use"//& @@ -5814,9 +5484,9 @@ SUBROUTINE create_ext_den_section(section,error) "the values depending, restarting from the previous calculation with the smaller"//& "value. To choose the progressive values of LAMBDA look at the convergence of the"//& " eigenvalues.",& - usage="DX ", default_r_val=10.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DX ", default_r_val=10.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ZMP_CONSTRAINT",& description="Specify which kind of constraint to solve the ZMP equation. The COULOMB default"//& @@ -5827,9 +5497,9 @@ SUBROUTINE create_ext_den_section(section,error) enum_desc=s2a("Coulomb constraint, integral of [rho_0(r)-rho(r)]/|r-r'|",& "Simple constraint, [rho_0(r)-rho(r)]",& "No constrain imposed"),& - default_i_val=use_coulomb, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=use_coulomb) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FERMI_AMALDI",& description="Add the Fermi-Amaldi contribution to the Hartree potential."//& @@ -5837,22 +5507,20 @@ SUBROUTINE create_ext_den_section(section,error) usage="FERMI_AMALDI ",& repeats=.FALSE.,& n_var=1,& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ext_den_section ! ***************************************************************************** !> \brief ZMP Creates the section for creating the external v_xc !> \param section ... -!> \param error ... !> \date 03.2011 !> \author D. Varsano [daniele.varsano@nano.cnr.it] ! ***************************************************************************** - SUBROUTINE create_ext_vxc_section(section,error) + SUBROUTINE create_ext_vxc_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ext_vxc_section', & routineP = moduleN//':'//routineN @@ -5862,12 +5530,11 @@ SUBROUTINE create_ext_vxc_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EXTERNAL_VXC",& description="SCF convergence with external v_xc calculated through previous ZMP"//& "calculation",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="FILE_VXC",& @@ -5878,22 +5545,19 @@ SUBROUTINE create_ext_vxc_section(section,error) "respectively set in section MGRID / keyword CUTOFF, and in section SUBSYS /"//& "CELL / keyword ABC",& usage="FILE_VXC ",& - type_of_var=char_t,default_c_val="VXC_O.dat", n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t,default_c_val="VXC_O.dat", n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ext_vxc_section ! ***************************************************************************** !> \brief creates the section for static periodic fields !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE create_per_efield_section(section,error) + SUBROUTINE create_per_efield_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_per_efield_section', & routineP = moduleN//':'//routineN @@ -5903,54 +5567,49 @@ SUBROUTINE create_per_efield_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"PERIODIC_EFIELD",& description="parameters for finite periodic electric field computed using "//& "the Berry phase approach. IMPORTANT: Can only be used in combination "//& " with OT. Can not be used in combination with RTP or EMD.",& citations=(/Souza2002, Umari2002/),& - n_keywords=6, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=6, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="INTENSITY",& description="Intensity of the electric field in a.u",& usage="INTENSITY 0.001",& - default_r_val=0._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POLARISATION",& description="Polarisation vector of electric field",& usage="POLARISIATION 0.0 0.0 1.0",& repeats=.FALSE.,n_var=3,& - type_of_var=real_t,default_r_vals=(/0.0_dp,0.0_dp,1.0_dp/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_vals=(/0.0_dp,0.0_dp,1.0_dp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPLACEMENT_FIELD",& description="Use the displacement field formulation.",& usage="DISPLACEMENT_FIELD T",& citations=(/Stengel2009/),& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_per_efield_section ! ***************************************************************************** !> \brief creates the section for time dependent nonperiodic fields !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE create_efield_section(section,error) + SUBROUTINE create_efield_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_efield_section', & routineP = moduleN//':'//routineN @@ -5961,11 +5620,10 @@ SUBROUTINE create_efield_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"EFIELD",& description="parameters for finite, time dependent, nonperiodic electric fields",& - n_keywords=6, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=6, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword,subsection) @@ -5975,33 +5633,32 @@ SUBROUTINE create_efield_section(section,error) "to a maximal amplitude in a.u. of sqrt(I/(3.50944*10^16)). "//& "For a constant local field in isolated system calclulations, units are in a.u..",& usage="INTENSITY 0.001",& - default_r_val=0._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POLARISATION",& description="Polarisation vector of electric field",& usage="POLARISATION 0.0 0.0 1.0",& repeats=.FALSE.,n_var=3,& - type_of_var=real_t,default_r_vals=(/0.0_dp,0.0_dp,1.0_dp/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_vals=(/0.0_dp,0.0_dp,1.0_dp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WAVELENGTH",& description="Wavelength of efield field for real-time propagation (RTP) calculations.",& usage="Wavelength 1.E0",& - default_r_val=0._dp,unit_str="nm",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp,unit_str="nm") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PHASE",& description="Phase offset of the cosine given in multiples of pi. "//& "Used in real-time propagation (RTP) calculations.",& usage="Phase 1.E0",& - default_r_val=0._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENVELOP",& description="Shape of the efield pulse used in real-time propagation (RTP) calculations.",& @@ -6011,35 +5668,32 @@ SUBROUTINE create_efield_section(section,error) enum_desc=s2a("No envelop function is applied to the strength",& "A Gaussian function is used as envelop ",& "Linear tune in/out of the field"),& - enum_i_vals=(/constant_env,gaussian_env,ramp_env/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/constant_env,gaussian_env,ramp_env/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_constant_env_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_constant_env_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_ramp_env_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ramp_env_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_gaussian_env_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_gaussian_env_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_efield_section ! ***************************************************************************** !> \brief makes the orbital transformation section !> \param section ... -!> \param error ... !> \par History !> 11.2004 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE create_ot_section(section,error) + SUBROUTINE create_ot_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ot_section', & routineP = moduleN//':'//routineN @@ -6049,7 +5703,7 @@ SUBROUTINE create_ot_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"OT",& description="Sets the various options for the orbital transformation (OT) method. "//& "Default settings already provide an efficient, yet robust method. "//& @@ -6057,7 +5711,7 @@ SUBROUTINE create_ot_section(section,error) "combined with a small value (0.001) of ENERGY_GAP."//& "Well-behaved systems might benefit from using a DIIS minimizer.",& n_keywords=27, n_subsections=0, repeats=.FALSE., & - citations=(/VandeVondele2003,Weber2008/), error=error) + citations=(/VandeVondele2003,Weber2008/)) NULLIFY(keyword) @@ -6065,10 +5719,9 @@ SUBROUTINE create_ot_section(section,error) description="controls the activation of the ot method",& usage="&OT T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALGORITHM",& description="Algorithm to be used for OT",& @@ -6079,24 +5732,23 @@ SUBROUTINE create_ot_section(section,error) "Orbital Transformation based Iterative Refinement "//& "of the Approximative Congruence transformation (OT/IR)."),& enum_i_vals=(/ot_algo_taylor_or_diag,ot_algo_irac/),& - citations=(/VandeVondele2003,VandeVondele2005a,Weber2008/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/VandeVondele2003,VandeVondele2005a,Weber2008/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IRAC_DEGREE",& description="The refinement polynomial degree (2, 3 or 4).",& usage="IRAC_DEGREE 4",& - default_i_val=4,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_IRAC",& description="Maximum allowed refinement iteration.",& usage="MAX_IRAC 5",& - default_i_val=50,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIXED_PRECISION",& description="Uses a mixed precision algorithm." //& @@ -6104,9 +5756,9 @@ SUBROUTINE create_ot_section(section,error) "it provides double precision accuracy results and up to a 2 fold speedup for building and "//& "applying the preconditioner.",& usage="MIXED_PRECISION T",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORTHO_IRAC",& description="The orthogonality method.",& @@ -6114,48 +5766,47 @@ SUBROUTINE create_ot_section(section,error) default_i_val=ot_chol_irac,& enum_c_vals=s2a( "CHOL", "POLY", "LWDN"),& enum_desc=s2a("Cholesky.","Polynomial.","Loewdin."),& - enum_i_vals=(/ot_chol_irac,ot_poly_irac,ot_lwdn_irac/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ot_chol_irac,ot_poly_irac,ot_lwdn_irac/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_IRAC_FILTER_MATRIX",& description="Sets the threshold for filtering the matrices.",& usage="EPS_IRAC_FILTER_MATRIX 1.0E-5",& - default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_IRAC",& description="Targeted accuracy during the refinement iteration.",& usage="EPS_IRAC 1.0E-5",& - default_r_val=1.0E-10_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_IRAC_QUICK_EXIT",& description="Only one extra refinement iteration is "//& "done when the norm is below this value.",& usage="EPS_IRAC_QUICK_EXIT 1.0E-2",& - default_r_val=1.0E-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_IRAC_SWITCH",& description="The algorithm switches to the polynomial "//& "refinement when the norm is below this value.",& usage="EPS_IRAC_SWITCH 1.0E-3",& - default_r_val=1.0E-2_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ON_THE_FLY_LOC",& description="On the fly localization of the molecular orbitals. "//& "Can only be used with OT/IRAC.",& usage="ON_THE_FLY_LOC T",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MINIMIZER",& description="Minimizer to be used with the OT method",& @@ -6166,96 +5817,95 @@ SUBROUTINE create_ot_section(section,error) " The total energy should decrease at every OT CG step if the line search is appropriate.", & "Direct inversion in the iterative subspace: less reliable than CG, but sometimes about 50% faster",& "Broyden mixing approximating the inverse Hessian"),& - enum_i_vals=(/ot_mini_sd,ot_mini_cg,ot_mini_diis,ot_mini_broyden/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ot_mini_sd,ot_mini_cg,ot_mini_diis,ot_mini_broyden/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SAFE_DIIS",& variants=(/"SAFER_DIIS"/),& description="Reject DIIS steps if they point away from the"//& " minimum, do SD in that case.",& - usage="SAFE_DIIS ON", default_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SAFE_DIIS ON", default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_HISTORY_VEC",& variants=s2a("NDIIS","N_DIIS","N_BROYDEN"),& description="Number of history vectors to be used with DIIS or BROYDEN",& usage="N_DIIS 4",& - default_i_val=7,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=7) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_BETA",& description="Underrelaxation for the broyden mixer",& usage="BROYDEN_BETA 0.9",& - default_r_val=0.9_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.9_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_GAMMA",& description="Backtracking parameter",& usage="BROYDEN_GAMMA 0.5",& - default_r_val=0.5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_SIGMA",& description="Curvature of energy functional.",& usage="BROYDEN_SIGMA 0.25",& - default_r_val=0.25_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.25_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_ETA",& description="Dampening of estimated energy curvature.",& usage="BROYDEN_ETA 0.7",& - default_r_val=0.7_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.7_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_OMEGA",& description="Growth limit of curvature.",& usage="BROYDEN_OMEGA 1.1",& - default_r_val=1.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_SIGMA_DECREASE",& description="Reduction of curvature on bad approximation.",& usage="BROYDEN_SIGMA_DECREASE 0.7",& - default_r_val=0.7_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.7_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_SIGMA_MIN",& description="Minimum adaptive curvature.",& usage="BROYDEN_SIGMA_MIN 0.05",& - default_r_val=0.05_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.05_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_FORGET_HISTORY",& description="Forget history on bad approximation", & usage="BROYDEN_FORGET_HISTORY OFF", default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_ADAPTIVE_SIGMA",& description="Enable adaptive curvature estimation", & usage="BROYDEN_ADAPTIVE_SIGMA ON", default_l_val=.TRUE., & - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BROYDEN_ENABLE_FLIP",& description="Ensure positive definite update", & usage="BROYDEN_ENABLE_FLIP ON", default_l_val=.TRUE., & - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LINESEARCH",& variants=(/"LINE_SEARCH"/),& @@ -6269,10 +5919,9 @@ SUBROUTINE create_ot_section(section,error) enum_c_vals=s2a( "NONE", "2PNT", "3PNT","GOLD"),& enum_desc=s2a("take fixed lenght steps","extrapolate based on 2 points", & "... or on 3 points","perform 1D golden section search of the minimum (very expensive)"),& - enum_i_vals=(/ls_none,ls_2pnt,ls_3pnt,ls_gold/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ls_none,ls_2pnt,ls_3pnt,ls_gold/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEPSIZE",& description="Initial stepsize used for the line search, sometimes this parameter can be reduced to stablize DIIS"//& @@ -6280,16 +5929,16 @@ SUBROUTINE create_ot_section(section,error) " The optimal value depends on the quality of the preconditioner."//& " A negative values leaves the choice to CP2K depending on the preconditioner.",& usage="STEPSIZE 0.4",& - default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GOLD_TARGET",& description="Target relative uncertainty in the location of the minimum for LINESEARCH GOLD",& usage="GOLD_TARGET 0.1",& - default_r_val=0.01_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.01_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRECONDITIONER",& description="Type of preconditioner to be used with all minimization schemes. "//& @@ -6313,10 +5962,9 @@ SUBROUTINE create_ot_section(section,error) "skip preconditioning"),& enum_i_vals=(/ot_precond_full_all,ot_precond_full_single_inverse,ot_precond_full_single, & ot_precond_full_kinetic,ot_precond_s_inverse,ot_precond_none/),& - citations=(/VandeVondele2003/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/VandeVondele2003/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRECOND_SOLVER",& description="How the preconditioner is applied to the residual.",& @@ -6332,10 +5980,9 @@ SUBROUTINE create_ot_section(section,error) enum_i_vals=(/ot_precond_solver_default,& ot_precond_solver_direct,& ot_precond_solver_inv_chol,& - ot_precond_solver_update/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + ot_precond_solver_update/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY_GAP",& description="Should be an estimate for the energy gap [a.u.] (HOMO-LUMO) and is used in preconditioning, "//& @@ -6345,25 +5992,25 @@ SUBROUTINE create_ot_section(section,error) " In general, heigher values will tame the preconditioner in case of poor initial guesses."//& " A negative value will leave the choice to CP2K depending on type of preconditioner.",& usage="ENERGY_GAP 0.001",& - default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_TAYLOR",& variants=(/"EPSTAYLOR"/),& description="Target accuracy of the taylor expansion for the matrix functions, should normally be kept as is.",& usage="EPS_TAYLOR 1.0E-15",& - default_r_val=1.0E-16_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-16_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_TAYLOR",& description="Maximum order of the Taylor expansion before diagonalisation is prefered, for large parallel runs"//& " a slightly higher order could sometimes result in a small speedup.",& usage="MAX_TAYLOR 5",& - default_i_val=4,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROTATION",& description="Introduce additional variables so that rotations of the occupied"//& @@ -6371,37 +6018,37 @@ SUBROUTINE create_ot_section(section,error) " a rotation of the occupied subspace such as non-singlet restricted calculations "//& " or fractional occupations.",& usage="ROTATION",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGIES",& description="Optimize orbital energies for use in Fermi-Dirac smearing "//& "(requires ROTATION and FD smearing to be active).",& usage="ENERGIES",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OCCUPATION_PRECONDITIONER",& description="Preconditioner with the occupation numbers (FD smearing)",& usage="OCCUPATION_PRECONDITIONER",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NONDIAG_ENERGY",& description="Add a non-diagonal energy penalty (FD smearing)",& usage="NONDIAG_ENERGY",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NONDIAG_ENERGY_STRENGTH",& description="The prefactor for the non-diagonal energy penalty (FD smearing)",& - usage="NONDIAG_ENERGY_STRENGTH", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NONDIAG_ENERGY_STRENGTH", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ot_section @@ -6409,13 +6056,11 @@ END SUBROUTINE create_ot_section ! ***************************************************************************** !> \brief creates the diagonalization section !> \param section ... -!> \param error ... !> \par History !> 10.2008 created [JGH] ! ***************************************************************************** - SUBROUTINE create_diagonalization_section(section,error) + SUBROUTINE create_diagonalization_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_diagonalization_section', & @@ -6427,11 +6072,10 @@ SUBROUTINE create_diagonalization_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"DIAGONALIZATION",& description="Set up type and parameters for Kohn-Sham matrix diagonalization.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) @@ -6439,10 +6083,9 @@ SUBROUTINE create_diagonalization_section(section,error) description="controls the activation of the diagonalization method",& usage="&DIAGONALIZATION T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALGORITHM",& description="Algorithm to be used for diagonalization",& @@ -6455,19 +6098,17 @@ SUBROUTINE create_diagonalization_section(section,error) "Preconditioned blocked Davidson",& "Filter matrix diagonalization"),& enum_i_vals=(/diag_standard, diag_ot, diag_block_krylov, diag_block_davidson,& - diag_filter_matrix/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + diag_filter_matrix/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="JACOBI_THRESHOLD",& description="Controls the accuracy of the pseudo-diagonalization method using Jacobi rotations",& usage="JACOBI_THRESHOLD 1.0E-6",& default_r_val=1.0E-7_dp,& - citations=(/Stewart1982/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/Stewart1982/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_JACOBI",& description="Below this threshold value for the SCF convergence the pseudo-diagonalization "//& @@ -6479,61 +6120,57 @@ SUBROUTINE create_diagonalization_section(section,error) "up calculations for large systems e.g. using a semi-empirical method.",& usage="EPS_JACOBI 1.0E-5",& default_r_val=0.0_dp,& - citations=(/Stewart1982/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/Stewart1982/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_ADAPT",& description="Required accuracy in iterative diagonalization as compared to current SCF convergence",& usage="EPS_ADAPT 0.01",& - default_r_val=0._dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER",& description="Maximum number of iterations in iterative diagonalization",& usage="MAX_ITER 20",& - default_i_val=2,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_ITER",& description="Required accuracy in iterative diagonalization",& usage="EPS_ITER 1.e-8",& - default_r_val=1.e-8_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.e-8_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_ot_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ot_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_krylov_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_krylov_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_diag_subspace_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_diag_subspace_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_davidson_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_davidson_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_filtermatrix_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_filtermatrix_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_diagonalization_section @@ -6542,12 +6179,10 @@ END SUBROUTINE create_diagonalization_section ! ***************************************************************************** !> \brief Input section for filter matrix diagonalisation method !> \param section : section to be created -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE create_filtermatrix_section(section, error) + SUBROUTINE create_filtermatrix_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_filtermatrix_section', & routineP = moduleN//':'//routineN @@ -6556,12 +6191,11 @@ SUBROUTINE create_filtermatrix_section(section, error) TYPE(keyword_type), POINTER :: keyword failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"FILTER_MATRIX",& description=" ",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) @@ -6573,14 +6207,12 @@ SUBROUTINE create_filtermatrix_section(section, error) n_var=1, & type_of_var=real_t, & default_r_val=cp_unit_to_cp2k(value=30000.0_dp, & - unit_str="K", & - error=error), & + unit_str="K"),& unit_str="K", & usage="FILTER_TEMPERATURE [K] 30000", & - citations=(/Rayson2009/), & - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + citations=(/Rayson2009/)) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, & name="AUTO_CUTOFF_SCALE", & @@ -6592,10 +6224,9 @@ SUBROUTINE create_filtermatrix_section(section, error) type_of_var=real_t, & default_r_val=1.0_dp, & usage="AUTO_CUTOFF_SCALE 0.5_dp", & - citations=(/Rayson2009/), & - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + citations=(/Rayson2009/)) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, & name="COLLECTIVE_COMMUNICATION", & @@ -6612,10 +6243,9 @@ SUBROUTINE create_filtermatrix_section(section, error) n_var=1, & type_of_var=logical_t, & default_l_val=.FALSE., & - usage="COLLECTIVE_COMMUNICATION T", & - error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="COLLECTIVE_COMMUNICATION T") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_filtermatrix_section @@ -6623,11 +6253,9 @@ END SUBROUTINE create_filtermatrix_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_davidson_section(section,error) + SUBROUTINE create_davidson_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_davidson_section', & routineP = moduleN//':'//routineN @@ -6636,11 +6264,10 @@ SUBROUTINE create_davidson_section(section,error) TYPE(keyword_type), POINTER :: keyword failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"DAVIDSON",& description=" ",& - n_keywords=2, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) @@ -6654,10 +6281,9 @@ SUBROUTINE create_davidson_section(section,error) "but cheaper to construct, might be somewhat less robust. Recommended for large systems.",& "skip preconditioning"),& enum_i_vals=(/ot_precond_full_all,ot_precond_full_single_inverse,ot_precond_none/),& - citations=(/VandeVondele2003/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/VandeVondele2003/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRECOND_SOLVER",& description="How the preconditioner is applied to the residual.",& @@ -6670,10 +6296,9 @@ SUBROUTINE create_davidson_section(section,error) "(works for FULL_KINETIC/SINGLE_INVERSE/S_INVERSE)"),& enum_i_vals=(/ot_precond_solver_default,& ot_precond_solver_direct,& - ot_precond_solver_inv_chol/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + ot_precond_solver_inv_chol/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY_GAP",& description="Should be an estimate for the energy gap [a.u.] (HOMO-LUMO) and is used in preconditioning, "//& @@ -6681,35 +6306,35 @@ SUBROUTINE create_davidson_section(section,error) "of the gap (0.001 doing normally fine). For the other preconditioners, making this value larger (0.2)"//& " will tame the preconditioner in case of poor initial guesses.",& usage="ENERGY_GAP 0.001",& - default_r_val=0.2_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NEW_PREC_EACH",& description="Number of SCF iterations after which a new Preconditioner is computed",& - usage="NEW_PREC_EACH 10", default_i_val=20,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NEW_PREC_EACH 10", default_i_val=20) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FIRST_PREC",& description="First SCF iteration at which a Preconditioner is employed",& - usage="FIRST_PREC 1", default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FIRST_PREC 1", default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CONV_MOS_PERCENT",& description="Minimal percent of MOS that have to converge within the Davidson loop"//& " before the SCF iteration is completed and a new Hamiltonian is computed",& - usage="CONV_MOS_PERCENT 0.8", default_r_val=0.5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CONV_MOS_PERCENT 0.8", default_r_val=0.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SPARSE_MOS",& description="Use MOS as sparse matrix and avoid as much as possible multiplications with full matrices",& usage="SPARSE_MOS",default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_davidson_section @@ -6717,11 +6342,9 @@ END SUBROUTINE create_davidson_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_krylov_section(section,error) + SUBROUTINE create_krylov_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_krylov_section', & routineP = moduleN//':'//routineN @@ -6730,57 +6353,51 @@ SUBROUTINE create_krylov_section(section,error) TYPE(keyword_type), POINTER :: keyword failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"KRYLOV",& description=" ",& - n_keywords=2, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="NKRYLOV",& description="Dimension of the Krylov space used for the Lanczos refinement",& usage="NKRYLOV 20",& - default_i_val=4,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NBLOCK",& description="Size of the block of vectors refined simultaneously by the Lanczos procedure",& usage="NBLOCK 1",& - default_i_val=32,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=32) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_KRYLOV",& description="Convergence criterion for the MOs",& usage="EPS_KRYLOV 0.00001",& - default_r_val=0.0000001_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0000001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_STD_DIAG",& description="Level of convergence to be reached before starting the Lanczos procedure."//& " Above this threshold a standard diagonalization method is used. "//& " If negative Lanczos is started at the first iteration",& usage="EPS_STD_DIAG 0.001",& - default_r_val=-1.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHECK_MOS_CONV",& description="This requires to check the convergence of MOS also when standard "//& "diagonalization steps are performed, if the block krylov approach is active.",& usage="CHECK_MOS_CONV T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_krylov_section @@ -6789,11 +6406,9 @@ END SUBROUTINE create_krylov_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_diag_subspace_section(section,error) + SUBROUTINE create_diag_subspace_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_diag_subspace_section', & routineP = moduleN//':'//routineN @@ -6803,12 +6418,11 @@ SUBROUTINE create_diag_subspace_section(section,error) TYPE(section_type), POINTER :: subsection failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"DIAG_SUB_SCF",& description="Activation of self-consistenf subspace refinement by diagonalization "//& "of H by adjusting the occupation but keeping the MOS unchanged.",& - n_keywords=2, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -6816,60 +6430,53 @@ SUBROUTINE create_diag_subspace_section(section,error) description="controls the activation of inner SCF loop to refine occupations in MOS subspace",& usage="&DIAG_SUB_SCF T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER",& description="Maximum number of iterations for the SCF inner loop",& usage="MAX_ITER 20",& - default_i_val=2,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_ENE",& description="Required energy accuracy for convergence of subspace diagonalization",& usage="EPS_ENE 1.e-8",& - default_r_val=1.e-4_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.e-4_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_ADAPT_SCF",& description="Required density matrix accuracy as compared to current SCF convergence",& usage="EPS_ADAPT_SCF 1.e-1",& - default_r_val=1._dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SKIP_SUB_DIAG",& description="Level of convergence to be reached before starting the internal loop of subspace rotations."//& " Above this threshold only the outer diagonalization method is used. "//& " If negative the subspace rotation is started at the first iteration",& usage="EPS_SKIP_SUB_DIAG 0.001",& - default_r_val=-1.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - - CALL create_mixing_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + + CALL create_mixing_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_diag_subspace_section ! ***************************************************************************** !> \brief makes the input section for core-level spectroscopy simulations !> \param section ... -!> \param error ... !> \par History !> 03.2005 created [MI] ! ***************************************************************************** - SUBROUTINE create_xas_section(section,error) + SUBROUTINE create_xas_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_xas_section', & routineP = moduleN//':'//routineN @@ -6880,15 +6487,14 @@ SUBROUTINE create_xas_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"xas",& description="Sets the method of choice to calculate core-level excitation spectra. "//& "The occupied states from which we calculate the "//& "excitation should be specified. "//& "Localization of the orbitals may be useful.",& n_keywords=10, n_subsections=1, repeats=.FALSE., & - citations=(/Iannuzzi2007/),& - error=error) + citations=(/Iannuzzi2007/)) NULLIFY(keyword,subsection,print_key) @@ -6896,10 +6502,9 @@ SUBROUTINE create_xas_section(section,error) description="controls the activation of core-level spectroscopy simulations",& usage="&XAS T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="METHOD",& variants=(/"XAS_METHOD"/),& @@ -6915,16 +6520,16 @@ SUBROUTINE create_xas_section(section,error) "DSCF calculations to compute the first (core)excited state", & "Transition potential with generalized core occupation and total number of electrons"),& enum_i_vals=(/xas_none,xas_tp_hh,xas_tp_fh,xes_tp_val,xas_tp_xhh,& - xas_tp_xfh,xas_dscf,xas_tp_flex/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + xas_tp_xfh,xas_dscf,xas_tp_flex/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="XAS_CORE",& description="Occupation of the core state in XAS calculation by TP_FLEX.",& usage="XAS_CORE 0.5",& - default_r_val=0.5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) @@ -6933,27 +6538,27 @@ SUBROUTINE create_xas_section(section,error) "If it is a negative value, the number of electrons is set to GS number of electrons "//& "minus the amount subtracted from the core state",& usage="XAS_TOT_EL 10",& - default_r_val=-1._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="XES_CORE",& description="Occupation of the core state in XES calculation by TP_VAL. "//& "The HOMO is emptied by the same amount.",& usage="XES_CORE 0.5",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="XES_EMPTY_HOMO",& description="Set the occupation of the HOMO in XES calculation by TP_VAL. "//& "The HOMO can be emptied or not, if the core is still full.",& usage="XES_EMPTY_HOMO",& default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIPOLE_FORM",& variants=(/"DIP_FORM"/),& @@ -6964,18 +6569,18 @@ SUBROUTINE create_xas_section(section,error) enum_c_vals=s2a( "LENGTH","VELOCITY" ),& enum_desc=s2a("Length form ⟨ i | e r | j ⟩",& "Velocity form ⟨ i | d/dr | j ⟩"),& - enum_i_vals=(/xas_dip_len2,xas_dip_vel/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/xas_dip_len2,xas_dip_vel/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! replace the specialized keyword with standard scf section ! scf_env is added to xas_env NULLIFY(subsection) - CALL create_scf_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_scf_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="STATE_TYPE",& @@ -6985,17 +6590,16 @@ SUBROUTINE create_xas_section(section,error) default_i_val=xas_1s_type,& enum_c_vals=s2a("1S","2S","2P"),& enum_desc=s2a("1s orbitals","2s orbitals","2p orbitals"),& - enum_i_vals=(/xas_1s_type,xas_2s_type,xas_2p_type/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/xas_1s_type,xas_2s_type,xas_2p_type/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STATE_SEARCH",& description="# of states where to look for the one to be excited",& usage="STATE_SEARCH 1",& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ATOMS_LIST",& variants=(/"AT_LIST"/),& @@ -7003,96 +6607,91 @@ SUBROUTINE create_xas_section(section,error) "This keyword can be repeated several times"//& "(useful if you have to specify many indexes).",& usage="ATOMS_LIST {integer} {integer} .. {integer} ",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ADDED_MOS",& description="Number of additional MOS added spin up only",& - usage="ADDED_MOS {integer}", default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ADDED_MOS {integer}", default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER_ADDED",& description="maximum number of iteration in calculation of added orbitals",& - usage="MAX_ITER_ADDED 100", default_i_val=2999,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER_ADDED 100", default_i_val=2999) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_ADDED",& description="target accuracy incalculation of the added orbitals",& - usage="EPS_ADDED 1.e-6", default_r_val=1.0e-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_ADDED 1.e-6", default_r_val=1.0e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NGAUSS",& description="Number of gto's for the expansion of the STO "//& "of the type given by STATE_TYPE",& - usage="NGAUSS {integer}", default_i_val=3,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NGAUSS {integer}", default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART",& description="Restart the excited state if the restart file exists",& usage="RESTART",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WFN_RESTART_FILE_NAME",& variants=(/"RESTART_FILE_NAME"/),& description="Root of the file names where to read the MOS from "//& "which to restart the calculation of the core level excited states",& usage="WFN_RESTART_FILE_NAME ",& - type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_localize_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_localize_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL section_create(subsection,"PRINT",& "printing of information during the core-level spectroscopy simulation",& - repeats=.FALSE.,error=error) + repeats=.FALSE.) ! Add printing of wannier infos - CALL print_wanniers(subsection, error) + CALL print_wanniers(subsection) CALL cp_print_key_section_create(print_key,"iteration_info",& description="Controls the printing of basic iteration information during the XAS SCF.", & - print_level=low_print_level,filename="__STD_OUT__",& - error=error) + print_level=low_print_level,filename="__STD_OUT__") CALL keyword_create(keyword, name="time_cumul",& description="If the printkey is activated switches the printing of timings"//& " to cumulative (over the SCF).",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic iteration information in CLS", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"XES_SPECTRUM",& description="Controls the dumping of the CLS output files containing the emission spectra",& - print_level=low_print_level,common_iter_levels=3,filename="",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,common_iter_levels=3,filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"XAS_SPECTRUM",& description="Controls the dumping of the CLS output files containing the absorption spectra",& - print_level=low_print_level,common_iter_levels=3,filename="",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,common_iter_levels=3,filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART",& description="Controls the dumping of MO restart file during the SCF."//& @@ -7101,64 +6700,61 @@ SUBROUTINE create_xas_section(section,error) "employed only to restart the same type of CLS calculation, "//& "i.e. with the same core potential.", & print_level=low_print_level,common_iter_levels=3,each_iter_names=s2a("XAS_SCF"),& - add_last=add_last_numeric,each_iter_values=(/3/),filename="",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric,each_iter_values=(/3/),filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CLS_FUNCTION_CUBES",& description="Controls the printing of the relaxed orbitals ", & - print_level=high_print_level,common_iter_levels=3,add_last=add_last_numeric,filename="",& - error=error) + print_level=high_print_level,common_iter_levels=3,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LU_BOUNDS",& variants=(/"CUBES_LU"/),& description="The lower and upper index of the states to be printed as cube",& usage="CUBES_LU_BOUNDS integer integer",& - n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LIST",& description="Indexes of the states to be printed as cube files"//& "This keyword can be repeated several times"//& "(useful if you have to specify many indexes).",& usage="CUBES_LIST 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_xas_section ! ***************************************************************************** !> \brief Create CP2K input section for the smearing of occupation numbers !> \param section ... -!> \param error ... !> \date 27.08.2008 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE create_smear_section(section,error) + SUBROUTINE create_smear_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_smear_section', & routineP = moduleN//':'//routineN @@ -7168,7 +6764,7 @@ SUBROUTINE create_smear_section(section,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,& @@ -7176,8 +6772,7 @@ SUBROUTINE create_smear_section(section,error) description="Define the smearing of the MO occupation numbers",& n_keywords=6,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) NULLIFY (keyword) @@ -7186,10 +6781,9 @@ SUBROUTINE create_smear_section(section,error) description="Controls the activation of smearing",& usage="&SMEAR ON",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="METHOD",& @@ -7200,10 +6794,9 @@ SUBROUTINE create_smear_section(section,error) enum_i_vals=(/smear_fermi_dirac,smear_energy_window,smear_list/),& enum_desc=s2a("Fermi-Dirac distribution defined by the keyword ELECTRONIC_TEMPERATURE",& "Energy window defined by the keyword WINDOW_SIZE",& - "Use a fixed list of occupations"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use a fixed list of occupations")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="LIST",& @@ -7212,10 +6805,9 @@ SUBROUTINE create_smear_section(section,error) repeats=.FALSE.,& n_var=-1,& type_of_var=real_t,& - usage="LIST 2.0 0.6666 0.6666 0.66666 0.0 0.0",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LIST 2.0 0.6666 0.6666 0.66666 0.0 0.0") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="ELECTRONIC_TEMPERATURE",& @@ -7224,12 +6816,11 @@ SUBROUTINE create_smear_section(section,error) repeats=.FALSE.,& n_var=1,& type_of_var=real_t,& - default_r_val=cp_unit_to_cp2k(value=300.0_dp, unit_str="K", error=error),& + default_r_val=cp_unit_to_cp2k(value=300.0_dp, unit_str="K"),& unit_str="K",& - usage="ELECTRONIC_TEMPERATURE [K] 300",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ELECTRONIC_TEMPERATURE [K] 300") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="EPS_FERMI_DIRAC",& @@ -7238,10 +6829,9 @@ SUBROUTINE create_smear_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=1.0E-10_dp,& - usage="EPS_FERMI_DIRAC 1.0E-6",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_FERMI_DIRAC 1.0E-6") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="WINDOW_SIZE",& @@ -7251,10 +6841,9 @@ SUBROUTINE create_smear_section(section,error) type_of_var=real_t,& default_r_val=0.0_dp,& unit_str="au_e",& - usage="WINDOW_SIZE [eV] 0.3",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="WINDOW_SIZE [eV] 0.3") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FIXED_MAGNETIC_MOMENT",& description="Imposed difference between the numbers of electrons of spin up "//& @@ -7265,10 +6854,9 @@ SUBROUTINE create_smear_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=-100.0_dp,& - usage="FIXED_MAGNETIC_MOMENT 1.5",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FIXED_MAGNETIC_MOMENT 1.5") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_smear_section @@ -7277,11 +6865,9 @@ END SUBROUTINE create_smear_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_rtp_section(section,error) + SUBROUTINE create_rtp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_rtp_section', & routineP = moduleN//':'//routineN @@ -7292,38 +6878,34 @@ SUBROUTINE create_rtp_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"REAL_TIME_PROPAGATION",& description="Parameters needed to set up the real time propagation"//& " for the electron dynamics",& n_keywords=4, n_subsections=4, repeats=.FALSE., & - citations=(/Kunert2003/),& - error=error) + citations=(/Kunert2003/)) CALL keyword_create(keyword, name="MAX_ITER",& description="Maximal number of iterations for the self consistent propagator loop.",& usage="MAX_ITER 10",& - default_i_val=10,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_ITER",& description="Convergence criterium for the self consistent propagator loop.",& usage="EPS_ITER 1.0E-5",& - default_r_val=1.0E-7_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-7_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ASPC_ORDER",& description="Speciefies how many steps will be used for extrapolation. "//& "One will be always used which is means X(t+dt)=X(t)",& usage="ASPC_ORDER 3",& - default_i_val=3,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAT_EXP",& description="Which method should be used to calculate the exponential"//& @@ -7338,37 +6920,34 @@ SUBROUTINE create_rtp_section(section,error) "uses arnoldi subspace algorithm to compute exp(H)*MO directly, can't be used in "//& "combination with Crank Nicholson or density propagation",& "Uses a Baker-Campbell-Hausdorff expansion to propagate the density matrix,"//& - " only works for density propagation"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + " only works for density propagation")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DENSITY_PROPAGATION",& description="The density matrix is propagated instead of the molecular orbitals. "//& "This allows for a linear scaling simulation",& usage="DENSITY_PROPAGATION .TRUE.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SC_CHECK_START",& description="Speciefies how many iteration steps will be done without "//& "a check for self consistency. Can save some time in big calculations.",& usage="SC_CHECK_START 3",& - default_i_val=0,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXP_ACCURACY",& description="Accuracy for the taylor and pade approximation. "//& "This is only an upper bound bound since the norm used for the guess "//& "is an upper bound for the needed one.",& usage="EXP_ACCURACY 1.0E-6",& - default_r_val=1.0E-9_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-9_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROPAGATOR",& description="Which propagator should be used for the orbitals",& @@ -7377,10 +6956,9 @@ SUBROUTINE create_rtp_section(section,error) enum_i_vals=(/do_etrs,do_cn,do_em/),& enum_desc=s2a("enforced time reversible symmetry",& "Crank Nicholson propagator",& - "Exponential midpoint propagator"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Exponential midpoint propagator")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INITIAL_WFN",& description="Controls the initial WFN used for propagation.",& @@ -7391,18 +6969,17 @@ SUBROUTINE create_rtp_section(section,error) "A wavefunction from a previous SCF is propagated. Especially useful,"//& " if electronic constraints or restraints are used in the previous calculation, "//& "since these do not work in the rtp scheme.",& - "use the wavefunction of a real time propagation/ehrenfest run"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "use the wavefunction of a real time propagation/ehrenfest run")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPLY_DELTA_PULSE",& description="Applies a delta kick to the initial wfn (only RTP for now - the EMD "//& " case is not yet implemented).",& usage="APPLY_DELTA_PULSE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PERIODIC",& description="Apply a delta-kick that is compatible with periodic boundary conditions"//& @@ -7410,9 +6987,9 @@ SUBROUTINE create_rtp_section(section,error) " the initial wfn. Note that the pulse is only applied when INITIAL_WFN is set to SCF_WFN,"//& " and not for restarts (RT_RESTART).",& usage="PERIODIC",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DELTA_PULSE_DIRECTION",& description="Direction of the applied electric field. The k vector is given as"//& @@ -7420,69 +6997,67 @@ SUBROUTINE create_rtp_section(section,error) " the unit cell, only if DELTA_PULSE_SCALE is set to unity. For an orthorhombic cell"//& " [1,0,0] yields [2*Pi/L_x,0,0]. For small cells, this results in a very large kick.",& usage="DELTA_PULSE_DIRECTION 1 1 1",n_var=3,default_i_vals=(/1,0,0/),& - type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DELTA_PULSE_SCALE",& description="Scale the k vector, which for PERIODIC .FALSE. results in exp(ikr) no"//& " longer being periodic with the unit cell. The norm of k is the strength of the"//& " applied electric field in atomic units.",& - usage="DELTA_PULSE_SCALE 0.01 ",n_var=1,default_r_val=0.001_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DELTA_PULSE_SCALE 0.01 ",n_var=1,default_r_val=0.001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HFX_BALANCE_IN_CORE",& description="If HFX is used, this keyword forces a redistribution/recalculation"//& " of the integrals, balanced with respect to the in core steps.",& usage="HFX_BALANCE_IN_CORE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORTHONORMAL",& description="Performs rtp in the orthonormal basis. This keyword is only intended for development purposes."//& "It should not be used outside code development",& usage="ORTHONORMAL",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MCWEENY_MAX_ITER",& description="Determines the maximum amount of McWeeny steps used after each converged"//& " step in density propagation",& - usage="MCWEENY_MAX_ITER 2",default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MCWEENY_MAX_ITER 2",default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ACCURACY_REFINEMENT",& description="If using density propagation some parts should be calculated with a higher accuracy than the rest"//& " to reduce numerical noise. This factor determines by how much the filtering threshold is"//& " reduced for these calculations.",& - usage="ACCURACY_REFINEMENT",default_i_val=100,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ACCURACY_REFINEMENT",default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MCWEENY_EPS",& description="Threshold after which McWeeny is terminated",& usage="MCWEENY_EPS 0.00001",& - default_r_val=0.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_section) CALL section_create(print_section,name="PRINT",& description="Section of possible print options for an RTP runs",& - repeats=.FALSE., error=error) + repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing within real time propagation and Eherenfest dynamics",& - print_level=low_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(print_section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,filename="__STD_OUT__") + CALL section_add_subsection(print_section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART",& @@ -7491,30 +7066,30 @@ SUBROUTINE create_rtp_section(section,error) "See also RESTART_HISTORY. In density propagation this controls the printing of P", & print_level=low_print_level, common_iter_levels=3,& each_iter_names=s2a("MD"),each_iter_values=(/20/), & - add_last=add_last_numeric,filename="RESTART",error=error) + add_last=add_last_numeric,filename="RESTART") CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum index of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=3, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(print_section,print_key,error=error) - CALL section_release(print_key,error=error) + default_i_val=3) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(print_section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART_HISTORY",& description="Dumps unique MO restart files during the run keeping all of them.",& print_level=low_print_level, common_iter_levels=0,& each_iter_names=s2a("MD"),& each_iter_values=(/500/), & - filename="RESTART",error=error) + filename="RESTART") CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum index of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=3, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(print_section,print_key,error=error) - CALL section_release(print_key,error=error) + default_i_val=3) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(print_section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CURRENT",& description="Print the current during an EMD simulation to cube files."//& @@ -7522,26 +7097,26 @@ SUBROUTINE create_rtp_section(section,error) print_level=high_print_level, common_iter_levels=0,& each_iter_names=s2a("MD"),& each_iter_values=(/20/), & - filename="current",error=error) + filename="current") CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum index of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=1, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STRIDE",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(print_section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(print_section,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,print_section,error=error) - CALL section_release(print_section,error=error) + CALL section_add_subsection(section,print_section) + CALL section_release(print_section) END SUBROUTINE create_rtp_section @@ -7549,11 +7124,9 @@ END SUBROUTINE create_rtp_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_constant_env_section(section,error) + SUBROUTINE create_constant_env_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_constant_env_section', & routineP = moduleN//':'//routineN @@ -7563,40 +7136,35 @@ SUBROUTINE create_constant_env_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"CONSTANT_ENV",& description="parameters for a constant envelop",& - n_keywords=6, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=6, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="START_STEP",& description="First step the field is applied ",& usage="START_STEP 0",& - default_i_val=0,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="END_STEP",& description="Last step the field is applied",& usage="END_STEP 2",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_constant_env_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_gaussian_env_section(section,error) + SUBROUTINE create_gaussian_env_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gaussian_env_section', & routineP = moduleN//':'//routineN @@ -7606,11 +7174,10 @@ SUBROUTINE create_gaussian_env_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"GAUSSIAN_ENV",& description="parameters for a gaussian envelop",& - n_keywords=6, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=6, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) @@ -7618,27 +7185,25 @@ SUBROUTINE create_gaussian_env_section(section,error) description="Center of the gaussian envelop (maximum of the gaussian)",& usage="T0 2.0E0",& default_r_val=0.0E0_dp,& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIGMA",& description="Width of the gaussian ",& usage="SIGMA 2.0E0",& default_r_val=-1.0E0_dp,& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_gaussian_env_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_ramp_env_section(section,error) + SUBROUTINE create_ramp_env_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ramp_env_section', & routineP = moduleN//':'//routineN @@ -7648,61 +7213,54 @@ SUBROUTINE create_ramp_env_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"RAMP_ENV",& description="Parameters for an trapeziodal envelop ",& - n_keywords=6, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=6, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="START_STEP_IN",& description="Step when the electric field starts to be applied ",& usage="START_STEP_IN 0",& - default_i_val=0,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="END_STEP_IN",& description="Step when the field reaches the full strength",& usage="END_STEP_IN 2",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="START_STEP_OUT",& description="Step when the field starts to vanish ",& usage="START_STEP 0",& - default_i_val=0,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="END_STEP_OUT",& description="Step when the field disappears",& usage="END_TIME 2",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ramp_env_section ! ***************************************************************************** !> \brief Create CP2K input section for the SCCS model !> \param section ... -!> \param error ... !> \par History: !> - Creation (10.10.2013,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE create_sccs_section(section,error) + SUBROUTINE create_sccs_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_sccs_section', & routineP = moduleN//':'//routineN @@ -7713,7 +7271,7 @@ SUBROUTINE create_sccs_section(section,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,& @@ -7722,8 +7280,7 @@ SUBROUTINE create_sccs_section(section,error) citations=(/Fattebert2002,Andreussi2012/),& n_keywords=8,& n_subsections=2,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) NULLIFY (keyword) @@ -7732,10 +7289,9 @@ SUBROUTINE create_sccs_section(section,error) description="Controls the activation of the SCCS section",& usage="&SCCS ON",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="ALPHA",& @@ -7746,10 +7302,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.0_dp,& - unit_str="mN/m",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="mN/m") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="BETA",& @@ -7760,10 +7315,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.0_dp,& - unit_str="GPa",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="GPa") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="DELTA_RHO",& @@ -7772,10 +7326,9 @@ SUBROUTINE create_sccs_section(section,error) repeats=.FALSE.,& n_var=1,& type_of_var=real_t,& - default_r_val=2.0E-5_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=2.0E-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="DERIVATIVE_METHOD",& @@ -7792,10 +7345,9 @@ SUBROUTINE create_sccs_section(section,error) enum_desc=s2a("Fast Fourier transformation",& "3-point stencil central differences",& "5-point stencil central differences",& - "7-point stencil central differences"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "7-point stencil central differences")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="DIELECTRIC_CONSTANT",& @@ -7805,10 +7357,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=80.0_dp,& - usage="DIELECTRIC_CONSTANT 78.36",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DIELECTRIC_CONSTANT 78.36") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="EPS_SCCS",& @@ -7819,10 +7370,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=1.0E-6_dp,& - usage="EPS_ITER 1.0E-7",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_ITER 1.0E-7") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="EPS_SCF",& @@ -7832,10 +7382,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.5_dp,& - usage="EPS_SCF 1.0E-2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SCF 1.0E-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="GAMMA",& @@ -7847,10 +7396,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.0_dp,& - unit_str="mN/m",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="mN/m") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="MAX_ITER",& @@ -7860,10 +7408,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=integer_t,& default_i_val=100,& - usage="MAX_ITER 50",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER 50") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="METHOD",& @@ -7873,10 +7420,9 @@ SUBROUTINE create_sccs_section(section,error) enum_c_vals=s2a("ANDREUSSI","FATTEBERT-GYGI"),& enum_i_vals=(/sccs_andreussi,sccs_fattebert_gygi/),& enum_desc=s2a("Smoothing function proposed by Andreussi et al.",& - "Smoothing function proposed by Fattebert and Gygi"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Smoothing function proposed by Fattebert and Gygi")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="MIXING",& @@ -7886,10 +7432,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.6_dp,& - usage="MIXING 0.2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MIXING 0.2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY (subsection) @@ -7900,8 +7445,7 @@ SUBROUTINE create_sccs_section(section,error) citations=(/Andreussi2012/),& n_keywords=2,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) CALL keyword_create(keyword,& name="RHO_MAX",& @@ -7910,10 +7454,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.0035_dp,& - usage="RHO_MAX 0.01",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RHO_MAX 0.01") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="RHO_MIN",& @@ -7922,13 +7465,12 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.0001_dp,& - usage="RHO_MIN 0.0003",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RHO_MIN 0.0003") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,& name="FATTEBERT-GYGI",& @@ -7937,8 +7479,7 @@ SUBROUTINE create_sccs_section(section,error) citations=(/Fattebert2002/),& n_keywords=2,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) CALL keyword_create(keyword,& name="BETA",& @@ -7947,10 +7488,9 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=1.7_dp,& - usage="BETA 1.3",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BETA 1.3") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="RHO_ZERO",& @@ -7961,13 +7501,12 @@ SUBROUTINE create_sccs_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=0.0006_dp,& - usage="RHO_ZERO 0.0004",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RHO_ZERO 0.0004") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_sccs_section diff --git a/src/input_cp2k_distribution.F b/src/input_cp2k_distribution.F index 2d5410d45c..ee06ce45d1 100644 --- a/src/input_cp2k_distribution.F +++ b/src/input_cp2k_distribution.F @@ -36,13 +36,10 @@ MODULE input_cp2k_distribution ! ***************************************************************************** !> \brief Creates the distribution section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_distribution_section(section,error) + SUBROUTINE create_distribution_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_distribution_section', & routineP = moduleN//':'//routineN @@ -52,11 +49,10 @@ SUBROUTINE create_distribution_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DISTRIBUTION",& description="can be used used to tune the parallel distribution of the data",& - n_keywords=2, n_subsections=2, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=2, repeats=.FALSE.) NULLIFY(keyword) @@ -68,56 +64,56 @@ SUBROUTINE create_distribution_section(section,error) enum_desc=s2a("the number of blocks",& "the number of blocks weighted by the number elements per block",& "the number of blocks weighted by the sum of the lmax"), & - default_i_val=model_block_count,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=model_block_count) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="2D_MOLECULAR_DISTRIBUTION",& description="Distribute the atoms so that atoms belonging to a given molecule"//& " are on the same CPU for the 2D distribution. This might give rise to a"//& " worse distribution but reduces memory needs of finding the optimal distribution.",& usage="2D_MOLECULAR_DISTRIBUTION TRUE",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SKIP_OPTIMIZATION",& description="Do not optimize the distribution, go for something very simple."//& " Might be useful if the optimization, which scales quadratically in system size, is too expensive.",& usage="SKIP_OPTIMIZATION TRUE",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIC_OPTIMIZATION",& description="Creates a distribution based on a few heuristics using only minimal memory "//& "and CPU time.",& usage="BASIC_OPTIMIZATION TRUE",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIC_SPATIAL_OPTIMIZATION",& description="Creates a distribution with spatial info, using only minimal memory "//& "and CPU time.",& usage="BASIC_SPATIAL_OPTIMIZATION TRUE",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIC_CLUSTER_OPTIMIZATION",& description="Creates a distribution with spatial info, using recursively KMEANS clustering. ",& usage="BASIC_CLUSTER_OPTIMIZATION TRUE",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SYMMETRIC",& description="Take the symmetry of the distribution_2d into account.",& usage="SYMMETRIC TRUE",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_distribution_section diff --git a/src/input_cp2k_eip.F b/src/input_cp2k_eip.F index fecac9a41c..e718e5cb2f 100644 --- a/src/input_cp2k_eip.F +++ b/src/input_cp2k_eip.F @@ -40,15 +40,12 @@ MODULE input_cp2k_eip ! ***************************************************************************** !> \brief Create the input section for EIP !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 created !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE create_eip_section(section, error) + SUBROUTINE create_eip_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_eip_section', & routineP = moduleN//':'//routineN @@ -61,12 +58,11 @@ SUBROUTINE create_eip_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EIP", & description="This section contains all information to run an "//& "Empirical Interatomic Potential (EIP) calculation.", & - n_keywords=1, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(subsection, keyword) @@ -79,13 +75,13 @@ SUBROUTINE create_eip_section(section, error) enum_desc=s2a("Bazant potentials",& "Environment-Dependent Interatomic Potential",& "Lenosky potentials"),& - default_i_val=use_lenosky_eip, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_i_val=use_lenosky_eip) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) - CALL create_eip_print_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error) - CALL section_release(subsection, error=error) + CALL create_eip_print_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_eip_section @@ -93,15 +89,12 @@ END SUBROUTINE create_eip_section ! ***************************************************************************** !> \brief Creates the print section for the eip subsection !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 created !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE create_eip_print_section(section, error) + SUBROUTINE create_eip_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_eip_print_section', & routineP = moduleN//':'//routineN @@ -113,55 +106,48 @@ SUBROUTINE create_eip_print_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section, name="PRINT", & description="Section of possible print options in EIP code.", & - n_keywords=0, n_subsections=6, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=6, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key, "ENERGIES", & description="Controls the printing of the EIP energies.", & - print_level=medium_print_level, filename="__STD_OUT__", & - error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + print_level=medium_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "ENERGIES_VAR", & description="Controls the printing of the variance of the EIP energies.", & - print_level=high_print_level, filename="__STD_OUT__", & - error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + print_level=high_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "FORCES", & description="Controls the printing of the EIP forces.", & - print_level=medium_print_level, filename="__STD_OUT__", & - error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + print_level=medium_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "COORD_AVG", & description="Controls the printing of the average coordination number.", & - print_level=high_print_level, filename="__STD_OUT__", & - error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + print_level=high_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "COORD_VAR", & description="Controls the printing of the variance of the coordination number.", & - print_level=high_print_level, filename="__STD_OUT__", & - error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + print_level=high_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "COUNT", & description="Controls the printing of the number of function calls.", & - print_level=high_print_level, filename="__STD_OUT__", & - error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + print_level=high_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) END SUBROUTINE create_eip_print_section diff --git a/src/input_cp2k_force_eval.F b/src/input_cp2k_force_eval.F index 8d57e7f2d9..5a16bab4ab 100644 --- a/src/input_cp2k_force_eval.F +++ b/src/input_cp2k_force_eval.F @@ -57,13 +57,10 @@ MODULE input_cp2k_force_eval ! ***************************************************************************** !> \brief creates the force_eval section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_force_eval_section(section,error) + SUBROUTINE create_force_eval_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_force_eval_section', & routineP = moduleN//':'//routineN @@ -74,12 +71,11 @@ SUBROUTINE create_force_eval_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="force_eval",& description="parameters needed to calculate energy and forces and"//& " describe the system you want to analyze.",& - n_keywords=1, n_subsections=9, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=9, repeats=.TRUE.) NULLIFY(subsection) NULLIFY(keyword) @@ -99,9 +95,9 @@ SUBROUTINE create_force_eval_section(section,error) "Electronic structure methods (DFT, ...)",& "Use a combination of two of the above"),& enum_i_vals=(/do_qs, do_fist, do_qmmm, do_eip, do_qs, do_mixed/),& - default_i_val=do_qs, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_qs) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STRESS_TENSOR",& description="Controls the calculation of the stress tensor. The combinations defined below"//& @@ -115,67 +111,64 @@ SUBROUTINE create_force_eval_section(section,error) "Compute the stress tensor analytically (if available).",& "Compute the stress tensor numerically.",& "Compute the diagonal part only of the stress tensor analytically (if available).",& - "Compute the diagonal part only of the stress tensor numerically"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Compute the diagonal part only of the stress tensor numerically")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_ext_pot_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ext_pot_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_rescale_force_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_rescale_force_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_mix_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mix_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_dft_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_dft_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_mm_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mm_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_qmmm_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_eip_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_eip_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_bsse_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_bsse_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_subsys_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_subsys_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_properties_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_properties_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_f_env_print_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_f_env_print_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_force_eval_section ! ***************************************************************************** !> \brief Creates the section for applying an external potential !> \param section ... -!> \param error ... !> \date 03.2008 !> \author teo ! ***************************************************************************** - SUBROUTINE create_ext_pot_section(section,error) + SUBROUTINE create_ext_pot_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ext_pot_section', & routineP = moduleN//':'//routineN @@ -185,62 +178,61 @@ SUBROUTINE create_ext_pot_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EXTERNAL_POTENTIAL",& description="Section controlling the presence of an external potential dependent "//& " on the atomic positions (X,Y,Z)",& - n_keywords=7, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS_LIST",& description="Specifies the atoms on which the external potential will act",& usage="ATOMS_LIST {INT} {INT} ..",repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTION",& description="Specifies the functional form in mathematical notation. Variables must be the atomic "//& "coordinates (X,Y,Z).",usage="FUNCTION X^2+Y^2+Z^2+LOG(ABS(X+Y))", & - type_of_var=lchar_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARAMETERS",& description="Defines the parameters of the functional form",& usage="PARAMETERS a b D", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VALUES",& description="Defines the values of parameter of the functional form",& usage="VALUES ", type_of_var=real_t,& - n_var=-1, repeats=.TRUE., unit_str="internal_cp2k", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE., unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="UNITS",& description="Optionally, allows to define valid CP2K unit strings for each parameter value. "//& "It is assumed that the corresponding parameter value is specified in this unit.",& usage="UNITS angstrom eV*angstrom^-1 angstrom^1 K", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DX",& description="Parameter used for computing the derivative with the Ridders' method.",& - usage="DX ", default_r_val=0.1_dp, unit_str="bohr", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DX ", default_r_val=0.1_dp, unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ERROR_LIMIT",& description="Checks that the error in computing the derivative is not larger than "//& "the value set; in case error is larger a warning message is printed.",& - usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ext_pot_section @@ -248,13 +240,10 @@ END SUBROUTINE create_ext_pot_section ! ***************************************************************************** !> \brief Creates the section controlling the rescaling of forces !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_rescale_force_section(section,error) + SUBROUTINE create_rescale_force_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_rescale_force_section', & routineP = moduleN//':'//routineN @@ -264,12 +253,11 @@ SUBROUTINE create_rescale_force_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RESCALE_FORCES",& description="Section controlling the rescaling of forces. Useful when"//& " starting from quite bad geometries with unphysically large forces.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="MAX_FORCE",& @@ -277,25 +265,20 @@ SUBROUTINE create_rescale_force_section(section,error) " of one atom exceed this value it's rescaled to the MAX_FORCE"//& " value.",& default_r_val=cp_unit_to_cp2k(value=50.0_dp,& - unit_str="kcalmol*angstrom^-1",& - error=error),& - unit_str="hartree*bohr^-1",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="kcalmol*angstrom^-1"),& + unit_str="hartree*bohr^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_rescale_force_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_f_env_print_section(section,error) + SUBROUTINE create_f_env_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_f_env_print_section', & routineP = moduleN//':'//routineN @@ -309,82 +292,77 @@ SUBROUTINE create_f_env_print_section(section,error) NULLIFY (keyword) NULLIFY (print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PRINT",& description="Properties that you want to output and that are common to all methods",& - n_keywords=0, n_subsections=5, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=5, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of basic information generated by force_eval", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FORCES",& description="Controls the printing of the forces after each force evaluation",& - print_level=high_print_level, filename="__STD_OUT__",error=error) + print_level=high_print_level, filename="__STD_OUT__") CALL keyword_create(keyword=keyword,& name="NDIGITS",& description="Specifies the number of digits used "//& "for the printing of the forces",& usage="NDIGITS 6",& default_i_val=8,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + repeats=.FALSE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"GRID_INFORMATION",& description="Controls the printing of information regarding the PW and RS grid structures.",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"TOTAL_NUMBERS",& description="Controls the printing of the total number of atoms, kinds,...",& - print_level=medium_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"DISTRIBUTION",& description="Controls the printing of the distribution of molecules, atoms, ...",& - print_level=medium_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"DISTRIBUTION2D",& description="Controls the printing of the distribution of matrix blocks,...",& - print_level=high_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"DISTRIBUTION1D",& description="Each node prints out its distribution info ...",& - print_level=high_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"STRESS_TENSOR",& description="Controls the printing of the stress tensor",& - print_level=high_print_level, filename="__STD_OUT__",error=error) + print_level=high_print_level, filename="__STD_OUT__") CALL keyword_create(keyword=keyword,& name="NDIGITS",& description="Specifies the number of digits used "//& "for the printing of the stress tensor",& usage="NDIGITS 6",& default_i_val=8,& - repeats=.FALSE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + repeats=.FALSE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_f_env_print_section diff --git a/src/input_cp2k_free_energy.F b/src/input_cp2k_free_energy.F index bdec334eec..ffa15536b3 100644 --- a/src/input_cp2k_free_energy.F +++ b/src/input_cp2k_free_energy.F @@ -51,13 +51,10 @@ MODULE input_cp2k_free_energy ! ***************************************************************************** !> \brief creates the free energy section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_fe_section(section,error) + SUBROUTINE create_fe_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_fe_section', & routineP = moduleN//':'//routineN @@ -68,12 +65,11 @@ SUBROUTINE create_fe_section(section,error) failure=.FALSE. NULLIFY (subsection,keyword,print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="free_energy",& description="Controls the calculation of free energy and free energy derivatives"//& " with different possible methods",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="METHOD",& description="Defines the method to use to compute free energy.",& @@ -83,43 +79,39 @@ SUBROUTINE create_fe_section(section,error) enum_desc=s2a("Metadynamics",& "Umbrella Integration",& "Alchemical Change"),& - default_i_val=do_fe_meta,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_fe_meta,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_metadyn_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_metadyn_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_ui_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ui_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_ac_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ac_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(print_key,"free_energy_info",& description="Controls the printing of basic and summary information during the"//& " Free Energy calculation", & print_level=low_print_level,each_iter_names=s2a("MD"),& - each_iter_values=(/1/),add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + each_iter_values=(/1/),add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_fe_section ! ***************************************************************************** !> \brief creates the metadynamics section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_metadyn_section(section,error) + SUBROUTINE create_metadyn_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_metadyn_section', & routineP = moduleN//':'//routineN @@ -130,27 +122,27 @@ SUBROUTINE create_metadyn_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="metadyn",& description="This section sets parameters to set up a calculation of metadynamics.",& n_keywords=1, n_subsections=1, repeats=.FALSE., & - citations=(/VandenCic2006/),error=error) + citations=(/VandenCic2006/)) NULLIFY(subsection,keyword,print_key) CALL keyword_create(keyword, name="USE_PLUMED",& description="Specify whether to use plumed as an external metadynamics driver.",& usage="USE_PLUMED .FALSE./.TRUE.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PLUMED_INPUT_FILE",& description="Specify the file name of the external plumed input file",& usage="PLUMED_INPUT_FILE ./FILENAME",& - default_c_val="./plumed.dat",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="./plumed.dat") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIN_NT_HILLS",& description="Specify the minimum MD step interval between spawning "//& @@ -158,47 +150,47 @@ SUBROUTINE create_metadyn_section(section,error) "is used, if MIN_DISP is satisfied before MIN_NT_HILLS MD steps have been "//& "performed, the MD will continue without any spawning until MIN_NT_HILLS is "//& "reached. The default value has the net effect of skipping this check.",& - usage="MIN_NT_HILLS {integer}",default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MIN_NT_HILLS {integer}",default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NT_HILLS",& description="Specify the maximum MD step interval between spawning "//& "two hills. When negative, no new hills are spawned and only "//& "the hills read from SPAWNED_HILLS_* are in effect. The latter"//& "is useful when one wants to add a custom constant bias potential.",& - usage="NT_HILLS {integer}",default_i_val=30,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NT_HILLS {integer}",default_i_val=30) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE",& description="If a Lagrangian scheme is used the temperature for the collective "//& "variables is specified. ",usage="TEMPERATURE ",& - default_r_val=0.0_dp,unit_str='K',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp,unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) !RG Adaptive hills CALL keyword_create(keyword, name="MIN_DISP",& description="Minimum displacement between hills before placing a new hill.",& usage="MIN_DISP ",& - default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OLD_HILL_NUMBER",& description="Index of the last hill spawned for this walker.Needed to calculate MIN_DISP",& usage="OLD_HILL_NUMBER ",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OLD_HILL_STEP",& description="Timestep of the last hill spawned for this walker.Needed to calculate MIN_DISP",& usage="OLD_HILL_STEP ",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) !RG Adaptive hills !Hills tail damping @@ -210,149 +202,146 @@ SUBROUTINE create_metadyn_section(section,error) " X0 and SCALE are METAVAR-dependent. "//& " (1-(|x-X0|/HILL_TAIL_CUTOFF*SCALE)^P_EXP)/(1-(|x-X0|/HILL_TAIL_CUTOFF*SCALE)^Q_EXP)",& usage="HILL_TAIL_CUTOFF ",& - default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="P_EXPONENT",& description="Exponent at the numerator of the cutoff function to damp the tail of the Gaussian.",& usage="P_EXPONENT ",& - default_i_val=8,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=8) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Q_EXPONENT",& description="Exponent at the denominator of the cutoff function to damp the tail of the Gaussian.",& usage="Q_EXPONENT ",& - default_i_val=20,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=20) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SLOW_GROWTH",& description="Let the last hill grow slowly over NT_HILLS. ",& usage="SLOW_GROWTH {logical}",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMP_TOL",& description="If a Lagrangian scheme is used the temperature tolerance for the collective "//& "variables is specified.",usage="TEMP_TOL ",& - unit_str='K',default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str='K',default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LANGEVIN",& description="If a Lagrangian scheme is used the eq. motion of the COLVARS are integrated "//& "with a LANGEVIN scheme.",& usage="LANGEVIN {logical}",& citations=(/VandenCic2006/),& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WW",& description="Specifies the height of the gaussian to spawn. Default 0.1 .",& - usage="WW ",unit_str='hartree',default_r_val=0.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="WW ",unit_str='hartree',default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DO_HILLS",& description="This keyword enables the spawning of the hills. Default .FALSE.",& - usage="DO_HILLS",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DO_HILLS",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WELL_TEMPERED",& description="This keyword enables Well-tempered metadynamics. Default .FALSE.",& usage="WELL_TEMPERED",citations=(/BarducBus2008/),& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DELTA_T",& description="If Well-tempered metaD is used, the temperature parameter "//& "must be specified.",usage="DELTA_T ",& - unit_str='K',default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str='K',default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WTGAMMA",& description="If Well-tempered metaD is used, the gamma parameter "//& "must be specified if not DELTA_T.",usage="WTGAMMA ",& - default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LAGRANGE",& description="Specifies whether an extended-lagrangian should be used. Default .FALSE.",& - usage="LAGRANGE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LAGRANGE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="step_start_val",& description="The starting step value for metadynamics",& - usage="step_start_val ",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="step_start_val ",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="nhills_start_val",& description="The starting value of previously spawned hills",& - usage="nhills_start_val ",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="nhills_start_val ",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="COLVAR_AVG_TEMPERATURE_RESTART",& description="COLVAR average temperature. Only for restarting purposes.",& - usage="COLVAR_AVG_TEMPERATURE_RESTART 0.0",default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COLVAR_AVG_TEMPERATURE_RESTART 0.0",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="TAMCSteps",& description="Number of sampling points for z",& - usage="TAMCSteps ",default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TAMCSteps ",default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="timestep",& description="The length of an integration step for colvars (TAMC only)",& - usage="timestep ",default_r_val=cp_unit_to_cp2k(value=0.5_dp,unit_str="fs",error=error),& - unit_str="fs",error=error) + usage="timestep ",default_r_val=cp_unit_to_cp2k(value=0.5_dp,unit_str="fs"),& + unit_str="fs") - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_metavar_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_metavar_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_multiple_walkers_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_multiple_walkers_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL section_create(subsection,name="print",& description="Controls the printing properties during an metadynamics run",& - n_keywords=0, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic and summary information during"//& " metadynamics.", & print_level=low_print_level,each_iter_names=s2a("MD","METADYNAMICS"),& - each_iter_values=(/1,1/),add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + each_iter_values=(/1,1/),add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"temperature_colvar",& description="Controls the printing of the temperature of COLVARS in an "//& "extended lagrangian scheme.", & print_level=low_print_level,each_iter_names=s2a("MD","METADYNAMICS"),& - each_iter_values=(/1,1/),add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + each_iter_values=(/1,1/),add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"COLVAR",& description="Controls the printing of COLVAR summary information during"//& @@ -367,10 +356,9 @@ SUBROUTINE create_metadyn_section(section,error) " Lagrangian. When the extended Lagrangian is not used, all"//& " related fields are omitted.",& print_level=low_print_level,each_iter_names=s2a("MD","METADYNAMICS"),& - each_iter_values=(/1,1/),add_last=add_last_numeric,filename="COLVAR",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + each_iter_values=(/1,1/),add_last=add_last_numeric,filename="COLVAR") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"HILLS",& description="Controls the printing of HILLS summary information during"//& @@ -378,27 +366,23 @@ SUBROUTINE create_metadyn_section(section,error) " the spawned gaussian and height of the gaussian. According the value of "//& " the EACH keyword this file may not be synchronized with the COLVAR file.", & print_level=high_print_level,each_iter_names=s2a("MD","METADYNAMICS"),& - each_iter_values=(/1,1/),add_last=add_last_numeric,filename="HILLS",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + each_iter_values=(/1,1/),add_last=add_last_numeric,filename="HILLS") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_metadyn_history(subsection, section, error) + CALL create_metadyn_history(subsection, section) END SUBROUTINE create_metadyn_section ! ***************************************************************************** !> \brief creates the multiple walker section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teodoro laino [tlaino] 10.2008 ! ***************************************************************************** - SUBROUTINE create_multiple_walkers_section(section,error) + SUBROUTINE create_multiple_walkers_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_multiple_walkers_section', & @@ -409,74 +393,65 @@ SUBROUTINE create_multiple_walkers_section(section,error) TYPE(section_type), POINTER :: subsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MULTIPLE_WALKERS",& description="Enables and configures the metadynamics using multiple walkers.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection,keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Controls the usage of the multiple walkers in a metadynamics run.",& - usage="&MULTIPLE_WALKERS T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="&MULTIPLE_WALKERS T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WALKER_ID",& description="Sets the walker ID for the local metadynamics run.",& - usage="WALKER_ID ",type_of_var=integer_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="WALKER_ID ",type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUMBER_OF_WALKERS",& description="Sets the total number of walkers in the metadynamic run.",& - usage="NUMBER_OF_WALKERS ",type_of_var=integer_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NUMBER_OF_WALKERS ",type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WALKER_COMM_FREQUENCY",& description="Sets the frequency (in unit of spawned hills) for the "//& "communication between the several walkers, in order to update the "//& "local list of hills with the ones coming from the other walkers",& - usage="WALKER_COMM_FREQUENCY ",default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="WALKER_COMM_FREQUENCY ",default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WALKERS_STATUS",& description="Stores the status of the several walkers in the local run.",& - usage="WALKERS_STATUS .. ",type_of_var=integer_t,n_var=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="WALKERS_STATUS .. ",type_of_var=integer_t,n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="WALKERS_FILE_NAME",& description="Specify the basename for the NUMBER_OF_WALKERS files used to "//& "communicate between the walkers. Absolute path can be input as well "//& "together with the filename. One file will be created for each spawned hill.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specified the communication filename for each walker.",repeats=.TRUE.,& - usage="{String}", type_of_var=lchar_t, n_var=1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + usage="{String}", type_of_var=lchar_t, n_var=1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_multiple_walkers_section ! ***************************************************************************** !> \brief creates the alchemical section for free energy evaluation !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teodoro laino [tlaino] 04.2007 ! ***************************************************************************** - SUBROUTINE create_ac_section(section,error) + SUBROUTINE create_ac_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ac_section', & routineP = moduleN//':'//routineN @@ -486,53 +461,49 @@ SUBROUTINE create_ac_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ALCHEMICAL_CHANGE",& description="Controls the calculation of delta free energies"//& " with the alchemical change method.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="PARAMETER",& description="Defines the perturbing parameter of the alchemical change tranformation",& usage="PARAMETERS k", type_of_var=char_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WEIGHTING_FUNCTION",& description="Specifies the weighting function (umbrella potential, part of the mixing function)",& usage="WEIGHTING_FUNCTION (E1+E2-LOG(E1/E2))", type_of_var=lchar_t,& - n_var=1, default_lc_val="0",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, default_lc_val="0") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_CONV",& description="Set the relative tolerance for the convergence of the free energy derivative",& usage="EPS_CONV ",& - default_r_val=1.0E-2_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NEQUIL_STEPS",& description="Set the number of equilibration steps, skipped to compute averages",& usage="NEQUIL_STEPS ",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ac_section ! ***************************************************************************** !> \brief creates the umbrella integration section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teodoro laino [tlaino] 01.2007 ! ***************************************************************************** - SUBROUTINE create_ui_section(section,error) + SUBROUTINE create_ui_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ui_section', & routineP = moduleN//':'//routineN @@ -541,21 +512,20 @@ SUBROUTINE create_ui_section(section,error) TYPE(section_type), POINTER :: subsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="umbrella_integration",& description="Controls the calculation of free energy derivatives"//& " with the umbrella integration method.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection) - CALL create_uvar_conv_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_uvar_conv_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_uvar_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_uvar_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_ui_section @@ -564,13 +534,10 @@ END SUBROUTINE create_ui_section !> \brief Creates the velocity section !> \param section the section to create !> \param metadyn_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_metadyn_history(section, metadyn_section, error) + SUBROUTINE create_metadyn_history(section, metadyn_section) TYPE(section_type), POINTER :: section, metadyn_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_metadyn_history', & routineP = moduleN//':'//routineN @@ -580,20 +547,19 @@ SUBROUTINE create_metadyn_history(section, metadyn_section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SPAWNED_HILLS_POS",& description="The position of the spawned hills during metadynamics."//& "Used for RESTART.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify the spawned hills",repeats=.TRUE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) CALL section_create(section,name="SPAWNED_HILLS_SCALE",& description="The scales of the spawned hills during metadynamics."//& @@ -602,115 +568,105 @@ SUBROUTINE create_metadyn_history(section, metadyn_section, error) "in those directions. The latter can be used to combine spawned "//& "hills from multiple 1D metadynamics runs in one multidimensional "//& "metadynamics run.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify the spawned hills",repeats=.TRUE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) CALL section_create(section,name="SPAWNED_HILLS_HEIGHT",& description="The height of the spawned hills during metadynamics."//& "Used for RESTART.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify the spawned hills",repeats=.TRUE.,& - usage="{Real}", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real}", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) CALL section_create(section,name="SPAWNED_HILLS_INVDT",& description="The inverse of the DELTA_T parameter used for Well-Tempered metadynamics."//& "Used for RESTART.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify the spawned hills",repeats=.TRUE.,& - usage="{Real}", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real}", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) ! ! Extended Lagrangian ! CALL section_create(section,name="EXT_LAGRANGE_SS0",& description="Colvar position within an extended Lagrangian formalism."//& "Used for RESTART.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specified the positions",repeats=.TRUE.,& - usage="{Real}", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real}", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) CALL section_create(section,name="EXT_LAGRANGE_VVP",& description="Colvar velocities within an extended Lagrangian formalism."//& "Used for RESTART.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specified the velocities",repeats=.TRUE.,& - usage="{Real}", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real}", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) CALL section_create(section,name="EXT_LAGRANGE_SS",& description="Colvar Theta within an extended Lagrangian formalism."//& "Used for RESTART.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specified the theta",repeats=.TRUE.,& - usage="{Real}", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real}", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) CALL section_create(section,name="EXT_LAGRANGE_FS",& description="Colvar force within an extended Lagrangian formalism."//& "Used for RESTART.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specified the theta",repeats=.TRUE.,& - usage="{Real}", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(metadyn_section, section, error=error) - CALL section_release(section,error=error) + usage="{Real}", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(metadyn_section, section) + CALL section_release(section) END SUBROUTINE create_metadyn_history ! ***************************************************************************** !> \brief creates the metavar section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_metavar_section(section,error) + SUBROUTINE create_metavar_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_metavar_section', & routineP = moduleN//':'//routineN @@ -721,33 +677,32 @@ SUBROUTINE create_metavar_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="METAVAR",& description="This section specify the nature of the collective variables.",& - n_keywords=1, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="LAMBDA",& description="Specifies the lambda parameter of the collective variable in the"//& " extended lagrangian scheme.",& - usage="LAMBDA ",unit_str='internal_cp2k',type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LAMBDA ",unit_str='internal_cp2k',type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MASS",& description="Specifies the mass parameter of the collective variable in the"//& - " extended lagrangian scheme.",usage="MASS ",unit_str='amu',type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + " extended lagrangian scheme.",usage="MASS ",unit_str='amu',type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GAMMA",& description="Specifies the friction term in Langevin integration of the collective variable in the"//& " extended lagrangian scheme.",& citations=(/VandenCic2006/),& - usage="GAMMA {real}",type_of_var=real_t,unit_str="fs^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GAMMA {real}",type_of_var=real_t,unit_str="fs^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALE",& variants=(/"WIDTH"/),& @@ -755,22 +710,21 @@ SUBROUTINE create_metavar_section(section,error) "dependent term has the expression: WW * Sum_{j=1}^{nhills} Prod_{k=1}^{ncolvar} "//& "[EXP[-0.5*((ss-ss0(k,j))/SCALE(k))^2]], "//& "where ncolvar is the number of defined METAVAR and nhills is the number of spawned hills. ",& - usage="SCALE ",type_of_var=real_t,unit_str='internal_cp2k',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCALE ",type_of_var=real_t,unit_str='internal_cp2k') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COLVAR",& description="Specifies the colvar on which to apply metadynamics.",& - usage="COLVAR {integer}", type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COLVAR {integer}", type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Wall section NULLIFY(wall_section, subsection) CALL section_create(wall_section,name="WALL",& description="Controls the activation of walls on COLVAR during a metadynamic run.",& - n_keywords=0, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) CALL keyword_create(keyword, name="TYPE",& description="Specify the type of wall",& @@ -782,22 +736,21 @@ SUBROUTINE create_metavar_section(section,error) "Applies a gaussian potential at the wall position.",& "No walls are applied."),& enum_i_vals=(/do_wall_reflective,do_wall_quadratic,do_wall_quartic,do_wall_gaussian,do_wall_none/),& - default_i_val=do_wall_none,error=error) - CALL section_add_keyword(wall_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_wall_none) + CALL section_add_keyword(wall_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POSITION",& description="Specify the value of the colvar for the wall position",& usage="POSITION ",unit_str='internal_cp2k',& - type_of_var=real_t,error=error) - CALL section_add_keyword(wall_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(wall_section,keyword) + CALL keyword_release(keyword) ! Reflective wall CALL section_create(subsection,name="REFLECTIVE",& description="Parameters controlling the reflective wall",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="DIRECTION",& description="Specify the direction of the wall.",& @@ -805,17 +758,16 @@ SUBROUTINE create_metavar_section(section,error) enum_c_vals=s2a( "WALL_PLUS","WALL_MINUS"),& enum_desc=s2a("Wall extends from the position towards larger values of COLVAR",& "Wall extends from the position towards smaller values of COLVAR"),& - enum_i_vals=(/do_wall_p,do_wall_m/),default_i_val=do_wall_p,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(wall_section, subsection, error=error) - CALL section_release(subsection,error=error) + enum_i_vals=(/do_wall_p,do_wall_m/),default_i_val=do_wall_p) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(wall_section, subsection) + CALL section_release(subsection) ! Quadratic wall CALL section_create(subsection,name="QUADRATIC",& description="Parameters controlling the quadratic wall",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="DIRECTION",& description="Specify the direction of the wall.",& @@ -823,25 +775,24 @@ SUBROUTINE create_metavar_section(section,error) enum_c_vals=s2a( "WALL_PLUS","WALL_MINUS"),& enum_desc=s2a("Wall extends from the position towards larger values of COLVAR",& "Wall extends from the position towards smaller values of COLVAR"),& - enum_i_vals=(/do_wall_p,do_wall_m/),default_i_val=do_wall_p,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/do_wall_p,do_wall_m/),default_i_val=do_wall_p) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Specify the value of the quadratic potential constant: K*(CV-POS)^2",& usage="K ",unit_str='hartree',& - type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(wall_section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(wall_section, subsection) + CALL section_release(subsection) ! Quartic wall CALL section_create(subsection,name="QUARTIC",& description="Parameters controlling the quartic wall",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="DIRECTION",& description="Specify the direction of the wall.",& @@ -849,45 +800,44 @@ SUBROUTINE create_metavar_section(section,error) enum_c_vals=s2a( "WALL_PLUS","WALL_MINUS"),& enum_desc=s2a("Wall extends from the position towards larger values of COLVAR",& "Wall extends from the position towards smaller values of COLVAR"),& - enum_i_vals=(/do_wall_p,do_wall_m/),default_i_val=do_wall_p,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/do_wall_p,do_wall_m/),default_i_val=do_wall_p) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Specify the value of the quartic potential constant: K*(CV-(POS+/-(1/K^(1/4))))^4",& usage="K ",unit_str='hartree',& - type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(wall_section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(wall_section, subsection) + CALL section_release(subsection) ! Gaussian wall CALL section_create(subsection,name="GAUSSIAN",& description="Parameters controlling the gaussian wall.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="WW",& description="Specify the height of the gaussian: WW*e^(-((CV-POS)/sigma)^2)",& usage="K ",unit_str='hartree',& - type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIGMA",& description="Specify the width of the gaussian: WW*e^(-((CV-POS)/sigma)^2)",& usage="SIGMA ",unit_str='internal_cp2k',& - type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(wall_section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(wall_section, subsection) + CALL section_release(subsection) - CALL section_add_subsection(section, wall_section, error=error) - CALL section_release(wall_section,error=error) + CALL section_add_subsection(section, wall_section) + CALL section_release(wall_section) END SUBROUTINE create_metavar_section @@ -895,13 +845,10 @@ END SUBROUTINE create_metavar_section ! ***************************************************************************** !> \brief creates the uvar section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_uvar_section(section,error) + SUBROUTINE create_uvar_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_uvar_section', & routineP = moduleN//':'//routineN @@ -911,33 +858,29 @@ SUBROUTINE create_uvar_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="UVAR",& description="This section specify the nature of the collective variables"//& " used in computing the free energy.",& - n_keywords=1, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="COLVAR",& description="Specifies the colvar used to compute free energy",& - usage="COLVAR {integer}", type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COLVAR {integer}", type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_uvar_section ! ***************************************************************************** !> \brief creates the section specifying parameters to control the convergence !> of the free energy !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teodoro laino [tlaino] 01.2007 ! ***************************************************************************** - SUBROUTINE create_uvar_conv_section(section,error) + SUBROUTINE create_uvar_conv_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_uvar_conv_section', & routineP = moduleN//':'//routineN @@ -947,66 +890,65 @@ SUBROUTINE create_uvar_conv_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CONVERGENCE_CONTROL",& description="This section specify parameters controlling the convergence"//& " of the free energy.",& - n_keywords=1, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="COARSE_GRAINED_WIDTH",& variants=(/"CG_WIDTH"/),& description="Width of segments in MD steps to generate the set of"//& " coarse grained data, providing a correlation independent data set.",& - usage="COARSE_GRAINED_WIDTH ", default_i_val=50,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COARSE_GRAINED_WIDTH ", default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_COARSE_GRAINED_WIDTH",& variants=(/"MAX_CG_WIDTH"/),& description="Max Width of segments in MD steps to generate the set of"//& " coarse grained data.",& - usage="MAX_COARSE_GRAINED_WIDTH ", default_i_val=200,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_COARSE_GRAINED_WIDTH ", default_i_val=200) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COARSE_GRAINED_POINTS",& variants=(/"CG_POINTS"/),& description="Set the minimum amount of coarse grained points to collect"//& " before starting the statistical analysis",& - usage="COARSE_GRAINED_POINTS ", default_i_val=30,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COARSE_GRAINED_POINTS ", default_i_val=30) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_CONV",& description="Set the relative tolerance for the convergence of the collective"//& " variable averages used to compute the free energy.",& usage="EPS_CONV ",& - default_r_val=1.0E-2_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K_CONFIDENCE_LIMIT",& description="Set the confidence limit for the Mann-Kendall trend test.",& usage="K_CONFIDENCE_LIMIT ",& - default_r_val=0.90_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.90_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SW_CONFIDENCE_LIMIT",& description="Set the confidence limit for the Shapiro-Wilks normality test.",& usage="SW_CONFIDENCE_LIMIT ",& - default_r_val=0.90_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.90_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VN_CONFIDENCE_LIMIT",& description="Set the confidence limit for the Von Neumann serial correlation test.",& usage="VN_CONFIDENCE_LIMIT ",& - default_r_val=0.90_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.90_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_uvar_conv_section END MODULE input_cp2k_free_energy diff --git a/src/input_cp2k_global.F b/src/input_cp2k_global.F index 74b37e4315..87e0d6b06b 100644 --- a/src/input_cp2k_global.F +++ b/src/input_cp2k_global.F @@ -72,13 +72,10 @@ MODULE input_cp2k_global ! ***************************************************************************** !> \brief section to hold global settings for the whole program !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_global_section(section,error) + SUBROUTINE create_global_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_global_section', & routineP = moduleN//':'//routineN @@ -89,12 +86,11 @@ SUBROUTINE create_global_section(section,error) failure=.FALSE. NULLIFY(print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="GLOBAL",& description="Section with general information regarding which kind "//& "of simulation to perform an parameters for the whole PROGRAM",& - n_keywords=7, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="BLACS_GRID",& @@ -103,17 +99,17 @@ SUBROUTINE create_global_section(section,error) default_i_val=BLACS_GRID_SQUARE,enum_c_vals=s2a("SQUARE","ROW","COLUMN"),& enum_desc=s2a("Distribution by matrix blocks", "Distribution by matrix rows",& "Distribution by matrix columns"), & - enum_i_vals=(/BLACS_GRID_SQUARE,BLACS_GRID_ROW,BLACS_GRID_COL/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/BLACS_GRID_SQUARE,BLACS_GRID_ROW,BLACS_GRID_COL/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BLACS_REPEATABLE",& description="Use a topology for BLACS collectives that is guaranteed to be repeatable "//& "on homegeneous architectures",& usage="BLACS_REPEATABLE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PREFERRED_DIAG_LIBRARY",& description="Specifies the DIAGONALIZATION library to be used. If not availabe, the standard scalapack is used",& @@ -121,10 +117,9 @@ SUBROUTINE create_global_section(section,error) default_i_val=do_diag_sl, & enum_i_vals=(/do_diag_sl,do_diag_sl2,do_diag_elpa/),& enum_c_vals=s2a("SL","SL2","ELPA"),& - enum_desc=s2a("Standard scalapack: syevd","Scalapack 2.0: syevr","ELPA"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_desc=s2a("Standard scalapack: syevd","Scalapack 2.0: syevr","ELPA")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ELPA_KERNEL",& description="Specifies the kernel to be used when ELPA is in use",& @@ -135,10 +130,9 @@ SUBROUTINE create_global_section(section,error) enum_desc=s2a("Generic kernel","Simplified generic kernel","Kernel optimized for IBM BGP","Kernel optimized for IBM BGQ",& "Kernel wiwth assembler for SSE vectorization","Kernel optimized for x86_64 using SSE2/SSE3 (Intel)",& "Kernel optimized for x86_64 using SSE2/SSE4 (AMD Bulldozer) ",& - "Kernel optimized for x86_64 using SSE2/SSE4 (block6)"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Kernel optimized for x86_64 using SSE2/SSE4 (block6)")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PREFERRED_FFT_LIBRARY",& @@ -159,10 +153,9 @@ SUBROUTINE create_global_section(section,error) "will be used in case a FFT lib is specified and not available",& "a fast portable FFT library. Recommended."//& "See also the FFTW_PLAN_TYPE, and FFTW_WISDOM_FILE_NAME keywords.",& - "Same as FFTW3 (for compatability with CP2K 2.3)"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Same as FFTW3 (for compatability with CP2K 2.3)")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FFTW_WISDOM_FILE_NAME",& description="The name of the file that contains wisdom (pre-planned FFTs) for use with FFTW3. "//& @@ -171,10 +164,9 @@ SUBROUTINE create_global_section(section,error) "Wisdom can be generated using the fftw-wisdom tool that is part of the fftw installation. "//& "cp2k/tools/cp2k-wisdom is a script that contains some additional info, and can help "//& "to generate a useful default for /etc/fftw/wisdom or particular values for a given simulation.",& - usage="FFTW_WISDOM_FILE_NAME wisdom.dat", default_lc_val="/etc/fftw/wisdom", & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FFTW_WISDOM_FILE_NAME wisdom.dat", default_lc_val="/etc/fftw/wisdom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FFTW_PLAN_TYPE",& description="FFTW can have improved performance if it is allowed to plan with "//& @@ -194,10 +186,9 @@ SUBROUTINE create_global_section(section,error) enum_desc=s2a("Quick estimate, no runtime measurements.",& "Quick measurement, somewhat faster FFTs.",& "Measurements trying a wider range of possibilities.",& - "Measurements trying all possibilities - use with caution."),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Measurements trying all possibilities - use with caution.")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXTENDED_FFT_LENGTHS",& description="Use fft library specific values for the allows number of points in FFTs. "//& @@ -210,22 +201,22 @@ SUBROUTINE create_global_section(section,error) "A change of FFT library must therefore be considered equivalent to a change of basis, "//& "which implies a change of total energy. ",& usage="EXTENDED_FFT_LENGTHS",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="FFT_POOL_SCRATCH_LIMIT",& description="Limits the memory usage of the FFT scratch pool, potentially reducing efficiency a bit",& - usage="FFT_POOL_SCRATCH_LIMIT ",default_i_val=15,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FFT_POOL_SCRATCH_LIMIT ",default_i_val=15) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALLTOALL_SGL",& description="All-to-all communication (FFT) should use single precision",& usage="ALLTOALL_SGL YES",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRINT_LEVEL",& variants=(/"IOLEVEL"/),& @@ -237,9 +228,9 @@ SUBROUTINE create_global_section(section,error) "Little output", "Quite some output", "Lots of output",& "Everything is written out, useful for debugging purposes only"),& enum_i_vals=(/silent_print_level,low_print_level,medium_print_level,& - high_print_level,debug_print_level/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + high_print_level,debug_print_level/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROGRAM_NAME",& variants=(/"PROGRAM"/),& @@ -258,26 +249,26 @@ SUBROUTINE create_global_section(section,error) "Runs swarm based calculation"),& enum_i_vals=(/do_atom, do_farming, do_test, do_cp2k, do_optimize_input,& do_opt_basis, do_tree_mc, do_tree_mc_ana, do_swarm/),& - default_i_val=do_cp2k, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_cp2k) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROJECT_NAME",& variants=(/"PROJECT"/),& description="Name of the project (used to build the name of the "//& "trajectory, and other files generated by the program)",& usage="PROJECT_NAME ",& - default_c_val="PROJECT",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="PROJECT") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OUTPUT_FILE_NAME",& description="Name of the output file. "//& "Relevant only if automatically started (through farming for example). "//& "If empty uses the project name as basis for it.",& - usage="OUTPUT_FILE_NAME {filename}",default_lc_val="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="OUTPUT_FILE_NAME {filename}",default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RUN_TYPE",& description="Type of run that you want to perform Geometry "//& @@ -306,67 +297,63 @@ SUBROUTINE create_global_section(section,error) "Ehrenfest dynamics (using real time propagation of the wavefunction)",& "Temperature Accelerated Monte Carlo (TAMC)",& "Tree Monte Carlo (TMC), a pre-sampling MC algorithm",& - "i-PI driver mode"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "i-PI driver mode")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WALLTIME",& variants=(/"WALLTI"/),& description="Maximum execution time for this run. Time in seconds or in HH:MM:SS.",& - usage="WALLTIME {real} or {HH:MM:SS}", default_lc_val="", & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="WALLTIME {real} or {HH:MM:SS}", default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ECHO_INPUT",& description="If the input should be echoed to the output with all the "//& "defaults made explicit",& - usage="ECHO_INPUT NO",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ECHO_INPUT NO",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ECHO_ALL_HOSTS",& description="Echo a list of hostname and pid for all MPI processes.",& - usage="ECHO_ALL_HOSTS NO",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ECHO_ALL_HOSTS NO",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRACE",& description="If a debug trace of the execution of the program should be written ",& usage="TRACE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRACE_MASTER",& description="For parallel TRACEd runs: only the master node writes output.",& usage="TRACE_MASTER",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRACE_MAX",& description="Limit the total number a given subroutine is printed in the trace. Accounting is not influenced.",& - usage="TRACE_MAX 100",default_i_val=HUGE(0),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TRACE_MAX 100",default_i_val=HUGE(0)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRACE_ROUTINES",& description="A list of routines to trace. If left empty all routines are traced. Accounting is not influenced.",& usage="TRACE_ROUTINES {routine_name1} {routine_name2} ...", type_of_var=char_t,& - n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FLUSH_SHOULD_FLUSH",& description="Flush output regularly, enabling this option might degrade performance significantly on certain machines.",& usage="FLUSH_SHOULD_FLUSH",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CALLGRAPH",& @@ -379,147 +366,138 @@ SUBROUTINE create_global_section(section,error) enum_desc=s2a("No callgraph gets written",& "Only the master process writes his callgraph",& "All processes write their callgraph (into a separate files)."), & - enum_i_vals=(/CALLGRAPH_NONE, CALLGRAPH_MASTER, CALLGRAPH_ALL/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/CALLGRAPH_NONE, CALLGRAPH_MASTER, CALLGRAPH_ALL/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CALLGRAPH_FILE_NAME",& description="Name of the callgraph file, which is writte a the end of the run. "//& "If not specified the project name will be used as filename.",& - usage="CALLGRAPH_FILE_NAME {filename}",default_lc_val="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CALLGRAPH_FILE_NAME {filename}",default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="SEED",& description="Initial seed for the global (pseudo)random number "//& "generator to create a stream of normally Gaussian "//& "distributed random numbers.",& - usage="SEED ",default_i_val=2000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SEED ",default_i_val=2000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SAVE_MEM",& description="Some sections of the input structure are deallocated when not needed,"//& " and reallocated only when used. This reduces the required maximum memory ",& usage="SAVE_MEM",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key, "TIMINGS", description=& "Controls the printing of the timing report at the end of CP2K execution", & - print_level=silent_print_level,filename="__STD_OUT__",& - error=error) + print_level=silent_print_level,filename="__STD_OUT__") CALL keyword_create(keyword,name="THRESHOLD",& description="Specify % of CPUTIME above which the contribution will be inserted in the"//& " final timing report (e.g. 0.02 = 2%)",& usage="THRESHOLD ",& - default_r_val=0.02_dp, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.02_dp) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="SORT_BY_SELF_TIME",& description="Sort the final timing report by the average self (exclusive) time instead of the "//& "total (inclusive) time of a routine",& usage="SORT_BY_SELF_TIME on",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="TIME_MPI",& description="Include message_passing calls in the timing report (useful with CALLGRAPH).",& usage="TIME_MPI .TRUE.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "REFERENCES", description=& "Controls the printing of the references relevant to the calculations performed", & - print_level=silent_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=silent_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="controls the printing of initialization controlled by the global section",& - print_level=silent_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=silent_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "PRINT", description=& "controls the printing of physical and mathematical constants", & - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) + print_level=medium_print_level,filename="__STD_OUT__") CALL keyword_create(keyword,"BASIC_DATA_TYPES",& description="Controls the printing of the basic data types.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"physcon",& description="if the printkey is active prints the physical constants",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"spherical_harmonics",& description="if the printkey is active prints the spherical harmonics",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"RNG_MATRICES",& description="Prints the transformation matrices used by the "//& " random number generator",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"RNG_CHECK",& description="Performs a check of the global (pseudo)random "//& "number generator (RNG) and prints the result",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"GLOBAL_GAUSSIAN_RNG",& description="Prints the initial status of the global Gaussian "//& "(pseudo)random number stream which is mostly used for "//& "the velocity initialization",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) NULLIFY(sub_section) ! FM section - CALL create_fm_section(sub_section,error) - CALL section_add_subsection(section,sub_section,error=error) - CALL section_release(sub_section,error=error) + CALL create_fm_section(sub_section) + CALL section_add_subsection(section,sub_section) + CALL section_release(sub_section) ! DBCSR options - CALL create_dbcsr_section(sub_section,error) - CALL section_add_subsection(section,sub_section,error=error) - CALL section_release(sub_section,error=error) + CALL create_dbcsr_section(sub_section) + CALL section_add_subsection(section,sub_section) + CALL section_release(sub_section) END SUBROUTINE create_global_section ! ***************************************************************************** !> \brief Creates the dbcsr section for configuring DBCSR !> \param section ... -!> \param error ... !> \date 2011-04-05 !> \author Urban Borstnik ! ***************************************************************************** - SUBROUTINE create_dbcsr_section(section,error) + SUBROUTINE create_dbcsr_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_dbcsr_section', & routineP = moduleN//':'//routineN @@ -530,11 +508,11 @@ SUBROUTINE create_dbcsr_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DBCSR",& description="Configuration options for the DBCSR library.",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/Borstnik2014/), error=error) + citations=(/Borstnik2014/)) NULLIFY (keyword) ! @@ -542,9 +520,9 @@ SUBROUTINE create_dbcsr_section(section,error) description="Size of multiplication parameter stack."& //" A negative value leaves the decision up to DBCSR.",& usage="mm_stack_size 1000",& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="mm_driver",& description="Select which routines to use "//& @@ -559,10 +537,9 @@ SUBROUTINE create_dbcsr_section(section,error) "Fortran MATMUL",& "Library optimised for Small Matrix Multiplies "//& "(requires the SMM library at link time)",& - "ACC (requires an accelerator backend)"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "ACC (requires an accelerator backend)")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="avg_elements_images",& description="Average number of elements (dense limit)" & @@ -571,16 +548,16 @@ SUBROUTINE create_dbcsr_section(section,error) // " during the operations." & // " A negative or zero value means unlimited.",& usage="avg_elements_images 10000",& - default_i_val=dbcsr_get_conf_avg_elements_images(),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=dbcsr_get_conf_avg_elements_images()) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="randmat_seed",& description="Seed value used to create random matrices in testing",& usage="randmat_seed 3141592",& - default_i_val=dbcsr_get_conf_randmat_seed(),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=dbcsr_get_conf_randmat_seed()) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="use_mpi_filtering",& description="Use filtering for MPI communications" & @@ -588,9 +565,9 @@ SUBROUTINE create_dbcsr_section(section,error) // " the number of elements exchanged between MPI processes" & // " during the operations.",& usage="use_mpi_filtering F",& - default_l_val=dbcsr_get_conf_use_mpi_filtering(),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=dbcsr_get_conf_use_mpi_filtering()) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="use_mpi_rma",& description="Use RMA for MPI communications" & @@ -598,18 +575,18 @@ SUBROUTINE create_dbcsr_section(section,error) // " the number of elements exchanged between MPI processes" & // " during the operations.",& usage="use_mpi_rma F",& - default_l_val=dbcsr_get_conf_use_mpi_rma(),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=dbcsr_get_conf_use_mpi_rma()) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="n_size_mnk_stacks",& description="Number of stacks to use for distinct atomic sizes" & // " (e.g., 2 for a system of mostly waters). "& //"A negative value leaves the decision up to DBCSR.",& usage="n_size_mnk_stacks 2",& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="use_comm_thread",& description="During multiplication, use a thread to periodically poll" & @@ -617,16 +594,16 @@ SUBROUTINE create_dbcsr_section(section,error) // " beneficial on systems without a DMA-capable network adapter" & // " e.g. Cray XE6.",& usage="use_comm_thread T",& - default_l_val=dbcsr_get_conf_use_comm_thread(),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=dbcsr_get_conf_use_comm_thread()) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="MAX_ELEMENTS_PER_BLOCK",& description="Default block size for turning dense matrices in blocked ones",& usage="MAX_ELEMENTS_PER_BLOCK 32",& - default_i_val=dbcsr_get_conf_max_ele_block(),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=dbcsr_get_conf_max_ele_block()) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="comm_thread_load",& description="If a communications thread is used, specify how much " & @@ -634,106 +611,103 @@ SUBROUTINE create_dbcsr_section(section,error) // "addition to communication tasks. "& // "A negative value leaves the decision up to DBCSR.",& usage="comm_thread_load 50",& - default_i_val=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="multrec_limit",& description="Recursion limit of cache oblivious multrec algorithm.",& - default_i_val=multrec_limit,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=multrec_limit) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) !--------------------------------------------------------------------------- NULLIFY(subsection) CALL section_create(subsection,name="ACC",& description="Configuration options for the ACC-Driver.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="priority_buffers",& description="Number of transfer-buffers associated with high priority streams.",& - default_i_val=accdrv_priority_buffers,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_priority_buffers) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="posterior_buffers",& description="Number of transfer-buffers associated with low priority streams.",& - default_i_val=accdrv_posterior_buffers,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_posterior_buffers) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="priority_streams",& description="Number of acc streams created with high priority.",& - default_i_val=accdrv_priority_streams,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_priority_streams) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="posterior_streams",& description="Number of acc streams created with low priority.",& - default_i_val=accdrv_posterior_streams,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_posterior_streams) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="avoid_after_busy",& description="If enabled, stacks are not processed by the acc-driver "& //"after it has signaled congestion during a round of flushing. "& //"For the next round of flusing the driver is used again.",& - default_l_val=accdrv_avoid_after_busy,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=accdrv_avoid_after_busy) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="min_flop_process",& description="Only process stacks with more than the given number of "& //"floating-point operations per stack-entry (2*m*n*k).",& - default_i_val=accdrv_min_flop_process,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_min_flop_process) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="min_flop_sort",& description="Only sort stacks with more than the given number of "& //"floating-point operations per stack-entry (2*m*n*k). "& //"Alternatively, the stacks are roughly ordered through a "& //"binning-scheme by Peter Messmer.",& - default_i_val=accdrv_min_flop_sort,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_min_flop_sort) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="process_inhomogenous",& description="If enabled, inhomogenous stacks are also processed by the acc driver.",& - default_l_val=accdrv_do_inhomogenous,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=accdrv_do_inhomogenous) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="binning_nbins",& description="Number of bins used when ordering "& //"the stacks with the binning-scheme.",& - default_i_val=accdrv_binning_nbins,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_binning_nbins) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="binning_binsize",& description="Size of bins used when ordering "& //"the stacks with the binning-scheme.",& - default_i_val=accdrv_binning_binsize,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=accdrv_binning_binsize) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection,error=error) - CALL section_release(subsection, error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! END SUBROUTINE create_dbcsr_section ! ***************************************************************************** !> \brief Creates the dbcsr section for configuring FM !> \param section ... -!> \param error ... !> \date 2011-04-05 !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE create_fm_section(section,error) + SUBROUTINE create_fm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_fm_section', & routineP = moduleN//':'//routineN @@ -741,35 +715,34 @@ SUBROUTINE create_fm_section(section,error) LOGICAL :: failure TYPE(keyword_type), POINTER :: keyword - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="FM",& description="Configuration options for the full matrices.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY (keyword) CALL keyword_create(keyword, name="NROW_BLOCKS",& description="Defines the number of rows per scalapack block in "//& "the creation of block cyclic dense matrices ",& - default_i_val=32,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=32) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NCOL_BLOCKS",& description="Defines the number of columns per scalapack block in "//& "the creation of vlock cyclic dense matrices ",& - default_i_val=32,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=32) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FORCE_BLOCK_SIZE",& description="Ensure for small matrices that the layout is compatible "//& "with bigger ones, i.e. no subdivision is performed (can break LAPACK!!!).",& usage="FORCE_BLOCK_SIZE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TYPE_OF_MATRIX_MULTIPLICATION",& description="Allows to switch between scalapack pdgemm and dbcsr_multiply. "//& @@ -782,10 +755,9 @@ SUBROUTINE create_fm_section(section,error) enum_i_vals=(/do_pdgemm,do_dbcsr/),& enum_c_vals=s2a("PDGEMM","DBCSR_MM"),& enum_desc=s2a("Standard scalapack: pdgemm",& - "DBCSR_MM is employed. This needs local transformation of the matrices"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "DBCSR_MM is employed. This needs local transformation of the matrices")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! END SUBROUTINE create_fm_section diff --git a/src/input_cp2k_hfx.F b/src/input_cp2k_hfx.F index ace74d7b29..4b31cb1a42 100644 --- a/src/input_cp2k_hfx.F +++ b/src/input_cp2k_hfx.F @@ -46,13 +46,10 @@ MODULE input_cp2k_hfx ! ***************************************************************************** !> \brief creates the input section for the hf part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_hfx_section(section,error) + SUBROUTINE create_hfx_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_hfx_section', & routineP = moduleN//':'//routineN @@ -63,12 +60,11 @@ SUBROUTINE create_hfx_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"HF",& description="Sets up the Hartree-Fock parameters if requested ",& n_keywords=5, n_subsections=2, repeats=.TRUE., & - citations=(/Guidon2008,Guidon2009/),& - error=error) + citations=(/Guidon2008,Guidon2009/)) NULLIFY(keyword, print_key, subsection) @@ -77,59 +73,58 @@ SUBROUTINE create_hfx_section(section,error) "1.0 implies standard Hartree-Fock if used with XC_FUNCTIONAL NONE. "//& "NOTE: In a mixed potential calculation this should be set to 1.0, otherwise "//& "all parts are multiplied with this factor. ",& - usage="FRACTION 1.0", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FRACTION 1.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TREAT_LSD_IN_CORE",& description="Determines how spin denisities are taken into account. "//& "If true, the beta spin density is included via a second in core call. "//& "If false, alpha and beta spins are done in one shot ",& - usage="TREAT_LSD_IN_CORE TRUE", default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TREAT_LSD_IN_CORE TRUE", default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_HFX",& description="Compute the Hartree-Fock energy also in the plane wave basis."//& "The value is ignored, and intended for debugging only.",& - usage="PW_HFX FALSE", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PW_HFX FALSE", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_HFX_BLOCKSIZE",& description="Improve the performance of pw_hfx at the cost of some additional memory "//& "by storing the realspace representation of PW_HFX_BLOCKSIZE states.",& - usage="PW_HFX_BLOCKSIZE 20", default_i_val=20,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PW_HFX_BLOCKSIZE 20", default_i_val=20) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"HF_INFO",& description="Controls the printing basic info about hf method", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_hf_pbc_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_hf_pbc_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_hf_screening_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_hf_screening_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_hf_potential_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_hf_potential_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_hf_load_balance_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_hf_load_balance_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_hf_memory_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_hf_memory_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_hfx_section @@ -139,13 +134,10 @@ END SUBROUTINE create_hfx_section !> !> creates the input section for the hf potential part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_hf_load_balance_section(section,error) + SUBROUTINE create_hf_load_balance_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_hf_load_balance_section', & @@ -157,12 +149,11 @@ SUBROUTINE create_hf_load_balance_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"LOAD_BALANCE",& description="Parameters influencing the load balancing of the HF",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/guidon2008/),& - error=error) + citations=(/guidon2008/)) NULLIFY(keyword) CALL keyword_create(& @@ -170,10 +161,9 @@ SUBROUTINE create_hf_load_balance_section(section,error) name="NBINS",& description="Number of bins per process used to group atom quartets.",& usage="NBINS 32",& - default_i_val=64,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=64) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -181,10 +171,9 @@ SUBROUTINE create_hf_load_balance_section(section,error) description="Determines the blocking used for the atomic quartet loops. "//& "A proper choice can speedup the calculation. The default (-1) is automatic.",& usage="BLOCK_SIZE 4",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(& @@ -194,29 +183,26 @@ SUBROUTINE create_hf_load_balance_section(section,error) "For highly ordered input structures with a bad load balance, setting "//& "this flag to TRUE might improve.", & usage="RANDOMIZE TRUE",& - default_l_val=.FALSE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PRINT",& description="Controls the printing of info about load balance", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) - CALL keyword_release(keyword,error=error) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="LOAD_BALANCE_INFO",& description="Activates the printing of load balance information ",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_release(print_key,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_release(print_key) END SUBROUTINE create_hf_load_balance_section @@ -226,13 +212,10 @@ END SUBROUTINE create_hf_load_balance_section !> !> creates the input section for the hf potential part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_hf_potential_section(section,error) + SUBROUTINE create_hf_potential_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_hf_potential_section', & routineP = moduleN//':'//routineN @@ -242,12 +225,11 @@ SUBROUTINE create_hf_potential_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"INTERACTION_POTENTIAL",& description="Sets up interaction potential if requested ",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/guidon2008,guidon2009/),& - error=error) + citations=(/guidon2008,guidon2009/)) NULLIFY(keyword) CALL keyword_create(& @@ -270,9 +252,9 @@ SUBROUTINE create_hf_potential_section(section,error) "Overlap",& "Truncated coulomb potential: if (r < R_c) 1/r else 0",& "Truncated Mix coulomb and longrange potential, assumes/requires that the erf has fully decayed at R_c"),& - default_i_val=do_hfx_potential_coulomb, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_hfx_potential_coulomb) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(& @@ -280,39 +262,38 @@ SUBROUTINE create_hf_potential_section(section,error) name="OMEGA",& description="Parameter for short/longrange interaction",& usage="OMEGA 0.5",& - default_r_val=0.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALE_COULOMB",& description="Scales Hartree-Fock contribution arising from a coulomb potential. "//& "Only valid when doing a mixed potential calculation",& - usage="SCALE_COULOMB 1.0", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCALE_COULOMB 1.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALE_LONGRANGE",& description="Scales Hartree-Fock contribution arising from a longrange potential. "//& "Only valid when doing a mixed potential calculation",& - usage="SCALE_LONGRANGE 1.0", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCALE_LONGRANGE 1.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALE_GAUSSIAN",& description="Scales Hartree-Fock contribution arising from a gaussian potential. "//& "Only valid when doing a mixed potential calculation",& - usage="SCALE_GAUSSIAN 1.0", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCALE_GAUSSIAN 1.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CUTOFF_RADIUS",& description="Determines cutoff radius for the truncated 1/r potential. "//& "Only valid when doing truncated calculation",& usage="CUTOFF_RADIUS 10.0",type_of_var=real_t,&! default_r_val=10.0_dp,& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -320,10 +301,9 @@ SUBROUTINE create_hf_potential_section(section,error) description="Location of the file t_c_g.dat that contains the data for the "//& "evaluation of the truncated gamma function ",& usage="T_C_G_DATA /data/t_c_g.dat",& - default_c_val="t_c_g.dat",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="t_c_g.dat") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_hf_potential_section @@ -333,13 +313,10 @@ END SUBROUTINE create_hf_potential_section ! ***************************************************************************** !> \brief creates the input section for the hf screening part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_hf_screening_section(section,error) + SUBROUTINE create_hf_screening_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_hf_screening_section', & routineP = moduleN//':'//routineN @@ -349,12 +326,11 @@ SUBROUTINE create_hf_screening_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"SCREENING",& description="Sets up screening parameters if requested ",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/guidon2008,guidon2009/),& - error=error) + citations=(/guidon2008,guidon2009/)) NULLIFY(keyword) CALL keyword_create(& @@ -364,10 +340,9 @@ SUBROUTINE create_hf_screening_section(section,error) "integrals using the Schwarz inequality for the given "//& "threshold.",& usage="EPS_SCHWARZ 1.0E-6",& - default_r_val=1.0E-10_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(& @@ -378,10 +353,9 @@ SUBROUTINE create_hf_screening_section(section,error) "threshold. This will be approximately the accuracy of the forces, "//& " and should normally be similar to EPS_SCF",& usage="EPS_SCHWARZ_FORCES 1.0E-5",& - default_r_val=1.0E-6_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(& @@ -392,40 +366,36 @@ SUBROUTINE create_hf_screening_section(section,error) "This results in a significant speedup for large systems, "//& "but might require a somewhat tigher EPS_SCHWARZ_FORCES.", & usage="SCREEN_P_FORCES TRUE",& - default_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(keyword, name="SCREEN_ON_INITIAL_P",& description="Screen on an initial density matrix. For the first MD step"//& " this matrix must be provided by a Restart File.",& - usage="SCREEN_ON_INITIAL_P TRUE", default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCREEN_ON_INITIAL_P TRUE", default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(keyword, name="P_SCREEN_CORRECTION_FACTOR",& description="Recalculates integrals on the fly if the actual density matrix is"//& " larger by a given factor than the initial one. If the factor is set"//& " to 0.0_dp, this feature is disabled.",& - usage="P_SCREEN_CORRECTION_FACTOR 0.0_dp", default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="P_SCREEN_CORRECTION_FACTOR 0.0_dp", default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_hf_screening_section ! ***************************************************************************** !> \brief creates the input section for the hf-pbc part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_hf_pbc_section(section,error) + SUBROUTINE create_hf_pbc_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_hf_pbc_section', & routineP = moduleN//':'//routineN @@ -435,12 +405,11 @@ SUBROUTINE create_hf_pbc_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"PERIODIC",& description="Sets up periodic boundary condition parameters if requested ",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/guidon2008,guidon2009/),& - error=error) + citations=(/guidon2008,guidon2009/)) NULLIFY(keyword) CALL keyword_create(& keyword=keyword,& @@ -450,10 +419,9 @@ SUBROUTINE create_hf_pbc_section(section,error) "This algorithm might be to conservative, resulting in some overhead. "//& "You can try to adjust this number in order to make a calculation cheaper. ", & usage="NUMBER_OF_SHELLS 2",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_hf_pbc_section @@ -461,13 +429,10 @@ END SUBROUTINE create_hf_pbc_section ! ***************************************************************************** !> \brief creates the input section for the hf-memory part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_hf_memory_section(section,error) + SUBROUTINE create_hf_memory_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_hf_memory_section', & routineP = moduleN//':'//routineN @@ -477,12 +442,11 @@ SUBROUTINE create_hf_memory_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"MEMORY",& description="Sets up memory parameters for the storage of the ERI's if requested ",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/guidon2008/),& - error=error) + citations=(/guidon2008/)) NULLIFY(keyword) CALL keyword_create(& keyword=keyword,& @@ -491,10 +455,9 @@ SUBROUTINE create_hf_memory_section(section,error) description="Scaling factor to scale eps_schwarz. Storage threshold for compression "//& "will be EPS_SCHWARZ*EPS_STORAGE_SCALING.",& usage="EPS_STORAGE 1.0E-2",& - default_r_val=1.0E0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -506,10 +469,9 @@ SUBROUTINE create_hf_memory_section(section,error) "When running a threaded version, cp2k automatically takes care of "//& "distributing the memory among all the threads within a process.",& usage="MAX_MEMORY 256",& - default_i_val=512,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=512) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -517,10 +479,9 @@ SUBROUTINE create_hf_memory_section(section,error) description="Loaction where ERI's are stored if MAX_DISK_SPACE /=0 "//& "Expects a path to a directory. ",& usage="STORAGE_LOCATION /data/scratch",& - default_c_val=".",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val=".") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -528,18 +489,17 @@ SUBROUTINE create_hf_memory_section(section,error) description="Defines the maximum amount of disk space [MiB] used to store precomputed "//& "compressed four-center integrals. If 0, nothing is stored to disk",& usage="MAX_DISK_SPACE 256",& - default_i_val=0,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TREAT_FORCES_IN_CORE",& description="Determines whether the derivative ERI's should be stored to RAM or not. "//& "Only meaningful when performing Ehrenfest MD. "//& "Memory usage is defined via MAX_MEMORY, i.e. the memory is shared wit the energy ERI's.",& - usage="TREAT_FORCES_IN_CORE TRUE", default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TREAT_FORCES_IN_CORE TRUE", default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_hf_memory_section diff --git a/src/input_cp2k_kpoints.F b/src/input_cp2k_kpoints.F index 3b85e6aeb2..a47fc08d93 100644 --- a/src/input_cp2k_kpoints.F +++ b/src/input_cp2k_kpoints.F @@ -51,13 +51,10 @@ MODULE input_cp2k_kpoints !> PARALLEL_GROUP_SIZE [-1,0,n] !> !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author JGH ! ***************************************************************************** - SUBROUTINE create_kpoints_section(section,error) + SUBROUTINE create_kpoints_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_kpoints_section', & routineP = moduleN//':'//routineN @@ -67,54 +64,53 @@ SUBROUTINE create_kpoints_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="KPOINTS",& description="Sets up the kpoints.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY (keyword) CALL keyword_create(keyword, name="SCHEME",& description="Kpoint scheme to be used. ",& usage="SCHEME {KPMETHOD}{integer} {integer} ..",& - n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KPOINT",& description="Specify kpoint coordinates and weight. ",& usage="KPOINT x y z w",repeats=.TRUE.,& - n_var=4, type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4, type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SYMMETRY",& description="Use symmetry to reduce the number of kpoints.",& usage="SYMMETRY ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FULL_GRID",& description="Use full non-reduced kpoint grid.",& usage="FULL_GRID ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VERBOSE",& description="Verbose output information.",& usage="VERBOSE ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_GEO",& description="Accuracy in symmetry determination.",& usage="EPS_GEO ",& - default_r_val=1.0e-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARALLEL_GROUP_SIZE",& description="Number of processors to be used for a single kpoint. "//& @@ -124,9 +120,9 @@ SUBROUTINE create_kpoints_section(section,error) " Value=0 (all processes)."//& " Value=n (exactly n processes).",& usage="PARALLEL_GROUP_SIZE ",& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WAVEFUNCTIONS",& description="Use real/complex wavefunctions if possible.",& @@ -135,9 +131,9 @@ SUBROUTINE create_kpoints_section(section,error) enum_c_vals=s2a("REAL","COMPLEX"),& enum_desc=s2a("Use real wavefunctions (if possible by kpoints specified).",& "Use complex wavefunctions (default)."),& - enum_i_vals=(/ use_real_wfn, use_complex_wfn/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ use_real_wfn, use_complex_wfn/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_kpoints_section diff --git a/src/input_cp2k_ls.F b/src/input_cp2k_ls.F index 360bcc5061..4cfd0de813 100644 --- a/src/input_cp2k_ls.F +++ b/src/input_cp2k_ls.F @@ -48,12 +48,10 @@ MODULE input_cp2k_ls ! ***************************************************************************** !> \brief creates the linear scaling scf section !> \param section ... -!> \param error ... !> \author Joost VandeVondele [2010-10] ! ***************************************************************************** - SUBROUTINE create_ls_scf_section(section,error) + SUBROUTINE create_ls_scf_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ls_scf_section', & routineP = moduleN//':'//routineN @@ -64,103 +62,103 @@ SUBROUTINE create_ls_scf_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"LS_SCF",& description="Specifies the parameters of the linear scaling SCF routines",& n_keywords=24, n_subsections=3, repeats=.FALSE., & - citations=(/VandeVondele2012/),error=error) + citations=(/VandeVondele2012/)) NULLIFY (keyword,subsection) CALL keyword_create(keyword, name="LS_DIIS",& description="Perform DIIS within linear scaling SCF",& usage="LS_DIIS",lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INI_DIIS",& description="Iteration cycle to start DIIS Kohn-Sham matrix update",& - usage="INI_DIIS 2", default_i_val=2,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="INI_DIIS 2", default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_DIIS",& description="Size of LS_DIIS buffer",& - usage="MAX_DIIS 4", default_i_val=4,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_DIIS 4", default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NMIXING",& description="Minimal number of density mixing before start DIIS",& - usage="NMIXING 2", default_i_val=2,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NMIXING 2", default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_DIIS",& description="Threshold on the convergence to start using DIIS",& - usage="EPS_DIIS 1.e-1", default_r_val=1.e-1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_DIIS 1.e-1", default_r_val=1.e-1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_SCF",& description="Maximum number of SCF iteration to be performed for one optimization",& - usage="MAX_SCF 200", default_i_val=20,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_SCF 200", default_i_val=20) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SCF",& description="Target accuracy for the SCF convergence in terms of change of the total energy per electron.",& - usage="EPS_SCF 1.e-6", default_r_val=1.e-7_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SCF 1.e-6", default_r_val=1.e-7_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIXING_FRACTION",& description="Mixing density matrices uses the specified fraction in the SCF procedure.",& - usage="MIXING_FRACTION 0.4", default_r_val=0.45_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MIXING_FRACTION 0.4", default_r_val=0.45_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_FILTER",& description="Threshold used for filtering matrix operations.",& - usage="EPS_FILTER 1.0E-7", default_r_val=1.0E-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_FILTER 1.0E-7", default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_LANCZOS",& description="Threshold used for lanczos estimates.",& - usage="EPS_LANCZOS 1.0E-4", default_r_val=1.0E-3_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_LANCZOS 1.0E-4", default_r_val=1.0E-3_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER_LANCZOS",& description="Maximum number of lanczos iterations.",& - usage="MAX_ITER_LANCZOS ", default_i_val=128,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER_LANCZOS ", default_i_val=128) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MU",& description="Value (or initial guess) for the chemical potential,"//& " i.e. some suitable energy between HOMO and LUMO energy.",& - usage="MU 0.0", default_r_val=-0.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MU 0.0", default_r_val=-0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FIXED_MU",& description="Should the calculation be performed at fixed chemical potential,"//& " or should it be found fixing the number of electrons",& - usage="FIXED_MU .TRUE.", default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FIXED_MU .TRUE.", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXTRAPOLATION_ORDER",& description="Number of previous matrices used for the ASPC extrapolation of the initial guess. "//& "0 implies that an atomic guess is used at each step. "//& "low (1-2) will result in a drift of the constant of motion during MD. "//& "high (>5) might be somewhat unstable, leading to more SCF iterations.",& - usage="EXTRAPOLATION_ORDER 3",default_i_val=4, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EXTRAPOLATION_ORDER 3",default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="S_PRECONDITIONER",& description="Preconditions S with some appropriate form.",& @@ -170,10 +168,9 @@ SUBROUTINE create_ls_scf_section(section,error) enum_desc=s2a("No preconditioner",& "Using atomic blocks",& "Using molecular sub-blocks. Recommended if molecules are defined and not too large."),& - enum_i_vals=(/ls_s_preconditioner_none, ls_s_preconditioner_atomic, ls_s_preconditioner_molecular/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ls_s_preconditioner_none, ls_s_preconditioner_atomic, ls_s_preconditioner_molecular/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PURIFICATION_METHOD",& description="Scheme used to purify the Kohn-Sham matrix into the density matrix.",& @@ -185,22 +182,21 @@ SUBROUTINE create_ls_scf_section(section,error) "Trace resetting 4th order scheme",& "Trace conserving 2nd order scheme",& "PEXSI method"),& - enum_i_vals=(/ls_scf_ns, ls_scf_trs4, ls_scf_tc2, ls_scf_pexsi/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ls_scf_ns, ls_scf_trs4, ls_scf_tc2, ls_scf_pexsi/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DYNAMIC_THRESHOLD",& description="Should the threshold for the purification be chosen dynamically",& - usage="DYNAMIC_THRESHOLD .TRUE.", default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DYNAMIC_THRESHOLD .TRUE.", default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NON_MONOTONIC",& description="Should the purification be performed non-monotonically. Relevant for TC2 only.",& - usage="NON_MONOTONIC .TRUE.", default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NON_MONOTONIC .TRUE.", default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MATRIX_CLUSTER_TYPE",& description="Specify how atomic blocks should be clustered in the used matrices, in order to improve flop rate, "//& @@ -212,29 +208,28 @@ SUBROUTINE create_ls_scf_section(section,error) enum_c_vals=s2a("ATOMIC", "MOLECULAR"),& enum_desc=s2a("Using atomic blocks",& "Using molecular blocks."),& - enum_i_vals=(/ls_cluster_atomic, ls_cluster_molecular /),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ls_cluster_atomic, ls_cluster_molecular /)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SINGLE_PRECISION_MATRICES",& description="Matrices used within the LS code can be either double or single precision.",& - usage="SINGLE_PRECISION_MATRICES", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SINGLE_PRECISION_MATRICES", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_WRITE",& description="Write the density matrix at the end of the SCF (currently requires EXTRAPOLATION_ORDER>0). "//& "Files might be rather large.",& - usage="RESTART_READ", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESTART_READ", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_READ",& description="Read the density matrix before the (first) SCF.",& - usage="RESTART_READ", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESTART_READ", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="S_INVERSION",& description="Method used to compute the inverse of S.",& @@ -243,46 +238,44 @@ SUBROUTINE create_ls_scf_section(section,error) enum_c_vals=s2a("SIGN_SQRT","HOTELLING"),& enum_desc=s2a("Using the inverse sqrt as obtained from sign function iterations.",& "Using the Hotellign iteration."),& - enum_i_vals=(/ls_s_inversion_sign_sqrt,ls_s_inversion_hotelling/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ls_s_inversion_sign_sqrt,ls_s_inversion_hotelling/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIGN_SQRT_ORDER",& description="Order of the sqrt iteration, should be 2..5, 3 or 5 recommended",& usage="SIGN_SQRT_ORDER 5",& - default_i_val=3,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REPORT_ALL_SPARSITIES",& description="Run the sparsity report at the end of the SCF",& - usage="REPORT_ALL_SPARSITIES", default_l_val=.TRUE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="REPORT_ALL_SPARSITIES", default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PERFORM_MU_SCAN",& description="Do a scan of the chemical potential after the SCF",& - usage="PERFORM_MU_SCAN", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PERFORM_MU_SCAN", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_ls_curvy_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ls_curvy_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_chebyshev_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_chebyshev_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_mixing_section(subsection,ls_scf=.TRUE.,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mixing_section(subsection,ls_scf=.TRUE.) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_pexsi_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_pexsi_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_ls_scf_section @@ -290,12 +283,10 @@ END SUBROUTINE create_ls_scf_section ! ***************************************************************************** !> \brief creates the DOS section !> \param section ... -!> \param error ... !> \author Joost VandeVondele, Jinwoong Cha [2012-10] ! ***************************************************************************** - SUBROUTINE create_chebyshev_section(section,error) + SUBROUTINE create_chebyshev_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_chebyshev_section', & routineP = moduleN//':'//routineN @@ -306,33 +297,32 @@ SUBROUTINE create_chebyshev_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"CHEBYSHEV",& description="Specifies the parameters needed for the chebyshev expansion based properties.",& - n_keywords=24, n_subsections=3, repeats=.FALSE., & - error=error) + n_keywords=24, n_subsections=3, repeats=.FALSE.) NULLIFY (keyword) NULLIFY(print_key) CALL keyword_create(keyword, name="N_CHEBYSHEV",& description="Order of the polynomial expansion.",& - usage="N_CHEBYSHEV 2000", default_i_val=500,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_CHEBYSHEV 2000", default_i_val=500) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! A DOS print key CALL cp_print_key_section_create(print_key,"DOS",& description="Controls the printing of the Density of States (DOS).", & - print_level=high_print_level,filename="",error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="N_GRIDPOINTS",& description="Number of points in the computed DOS",& - usage="N_GRIDPOINTS 10000", default_i_val=2000,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + usage="N_GRIDPOINTS 10000", default_i_val=2000) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) ! Energy specific electron density cubes CALL cp_print_key_section_create(print_key,& @@ -342,32 +332,32 @@ SUBROUTINE create_chebyshev_section(section,error) "contributing to the density of states within "//& "the specific energy range "//& "(MIN_ENERGY ≤ E ≤ MAX_ENERGY). MIN_ENERGY and MAX_ENERGY need to be specified explicitly.",& - print_level=high_print_level,filename="",error=error) + print_level=high_print_level,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIN_ENERGY",& description="Lower bounds of the energy ranges of interest.",& usage="MIN_ENERGY -1.01 -0.62 0.10 .. ", & - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ENERGY",& description="Upper bounds of the energy ranges of interest.",& usage="MAX_ENERGY -0.81 -0.43 0.22 .. ", & - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, print_key, error=error) - CALL section_release(print_key, error=error) + CALL section_add_subsection(section, print_key) + CALL section_release(print_key) END SUBROUTINE create_chebyshev_section @@ -375,12 +365,10 @@ END SUBROUTINE create_chebyshev_section ! ***************************************************************************** !> \brief creates the curvy_steps section in linear scaling scf !> \param section ... -!> \param error ... !> \author Florian Schiffmann [2012-10] ! ***************************************************************************** - SUBROUTINE create_ls_curvy_section(section,error) + SUBROUTINE create_ls_curvy_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ls_curvy_section', & routineP = moduleN//':'//routineN @@ -390,12 +378,11 @@ SUBROUTINE create_ls_curvy_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"CURVY_STEPS",& description="Specifies the parameters of the linear scaling SCF routines",& n_keywords=24, n_subsections=3, repeats=.FALSE., & - citations=(/Shao2003/),& - error=error) + citations=(/Shao2003/)) NULLIFY (keyword) @@ -406,46 +393,45 @@ SUBROUTINE create_ls_curvy_section(section,error) enum_desc=s2a("Performs a three point line search",& "Only for spin unrestricted calcualtions. Separate step sizes for alpha and beta spin"//& " using a fit to a 2D parabolic function"),& - enum_i_vals=(/ls_scf_line_search_3point,ls_scf_line_search_3point_2d/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ls_scf_line_search_3point,ls_scf_line_search_3point_2d/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_BCH_HISTORY",& description="Number of stored matrices in the Baker-Campbell-Hausdorff series. "//& "Reduces the BCH evaluation during line search but can be memory intense. ",& usage="N_BCH_HISTORY 5",& - default_i_val=7,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=7) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIN_HESSIAN_SHIFT",& description="Minimal eigenvalue shift for the Hessian in the Newton iteration."//& " Useful for small band gap systems (0.5-1.0 recommended). ",& - usage="MIN_HESSIAN_SHIFT 0.0", default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MIN_HESSIAN_SHIFT 0.0", default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FILTER_FACTOR",& description="Allows to set a seperate EPS_FILTER in the newton iterations."//& " The new EPS is EPS_FILTER*FILTER_FACTOR.",& - usage="FILTER_FACTOR 10.0", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FILTER_FACTOR 10.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FILTER_FACTOR_SCALE",& description="Allows for dynamic EPS_FILTER. Updates the filter factor every SCF-Newton "//& "step by FILTER_FACTOR=FILTER_FACTOR*FILTER_FACTOR_SCALE",& - usage="FILTER_FACTOR_SCALE 0.5", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FILTER_FACTOR_SCALE 0.5", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIN_FILTER",& description="Lowest EPS_FILTER in dynamic filtering. Given as multiple of EPS_FILTER:"//& " EPS_FILTER_MIN=EPS_FILTER*MIN_FILTER",& - usage="FILTER_FACTOR 1.0", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FILTER_FACTOR 1.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ls_curvy_section @@ -453,14 +439,12 @@ END SUBROUTINE create_ls_curvy_section ! ***************************************************************************** !> \brief creates the PEXSI library subsection of the linear scaling section. !> \param section ... -!> \param error ... !> \par History !> 11.2014 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** - SUBROUTINE create_pexsi_section(section, error) + SUBROUTINE create_pexsi_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_pexsi_section', & routineP = moduleN//':'//routineN @@ -470,7 +454,7 @@ SUBROUTINE create_pexsi_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"PEXSI",& description="Specifies the parameters of the PEXSI library. The density matrix is calculated "//& @@ -479,82 +463,82 @@ SUBROUTINE create_pexsi_section(section, error) "and PEXSI is applicable to insulating and metallic systems. The value of EPS_PGF_ORB "//& "(in QS input section) defines the sparsity of the matrices sent to PEXSI and EPS_FILTER "//& "is overwritten with 0.",& - n_keywords=17, repeats=.FALSE.,citations=(/Lin2009,Lin2013/),error=error) + n_keywords=17, repeats=.FALSE.,citations=(/Lin2009,Lin2013/)) NULLIFY (keyword) CALL keyword_create(keyword, name="TEMPERATURE",& description="Electronic temperature",& - default_r_val=cp_unit_to_cp2k(value=300.0_dp, unit_str="K", error=error),& - unit_str="K", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=300.0_dp, unit_str="K"),& + unit_str="K") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GAP",& description="Spectral gap. Note: This can be set to be 0 in most cases.",& - default_r_val=0.0_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_POLE",& description="Number of terms in the pole expansion (should be even).",& - default_i_val=64,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=64) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IS_INERTIA_COUNT",& description="Whether inertia counting is used each time the DFT driver "//& "of PEXSI is invoked. If FALSE, inertia counting is still used in the "//& "first SCF iteration.",& - default_l_val=.FALSE., lone_keyword_l_val = .TRUE. ,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val = .TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_PEXSI_ITER",& description="Maximum number of PEXSI iterations after each inertia counting procedure.",& - default_i_val=5,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MU_MIN_0",& description="Initial guess of lower bound for mu.",& - default_r_val=-5.0_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-5.0_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MU_MAX_0",& description="Initial guess of upper bound for mu.",& - default_r_val=5.0_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=5.0_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MU_INERTIA_TOLERANCE",& description="Stopping criterion in terms of the chemical potential for the "//& "inertia counting procedure.",& - default_r_val=0.01_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.01_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MU_INERTIA_EXPANSION",& description="If the chemical potential is not in the initial interval, "//& "the interval is expanded by MU_INERTIA_EXPANSION.",& - default_r_val=0.15_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.15_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MU_PEXSI_SAFE_GUARD",& description="Safe guard criterion in terms of the chemical potential to "//& "reinvoke the inertia counting procedure.",& - default_r_val=0.01_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.01_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_ELECTRON_PEXSI_TOLERANCE",& description="Stopping criterion of the PEXSI iteration in terms of "//& "The number of electrons compared to the exact number of electrons. "//& "This threshold is the target tolerance applied at convergence of SCF.",& - default_r_val=0.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_ELECTRON_INITIAL_TOLERANCE",& description="The same as NUM_ELECTRON_PEXSI_TOLERANCE but applied in the first SCF steps. "//& @@ -563,9 +547,9 @@ SUBROUTINE create_pexsi_section(section, error) "NUM_ELECTRON_PEXSI_TOLERANCE, the PEXSI tolerance in number of electrons is set adaptively "//& "according to the SCF convergence error of the previous SCF step. This reduces the number "//& "of PEXSI iterations in the first SCF steps but leads to at least one more SCF step.",& - default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORDERING",& description="Ordering strategy for factorization and selected inversion.",& @@ -573,40 +557,40 @@ SUBROUTINE create_pexsi_section(section, error) enum_desc=s2a("Parallel ordering using ParMETIS/PT-SCOTCH (PARMETIS option in SuperLU_DIST)",& "Sequential ordering using METIS (METIS_AT_PLUS_A option in SuperLU_DIST)",& "Multiple minimum degree ordering (MMD_AT_PLUS_A option in SuperLU_DIST)"),& - enum_i_vals=(/0,1,2/), default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/0,1,2/), default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NP_SYMB_FACT",& description="Number of processors for PARMETIS/PT-SCOTCH. Only used if the ordering == 0. "//& "If 0, the number of processors for PARMETIS/PT-SCOTCH will be set equal to the number of "//& "MPI ranks per pole. Note: if more than one processor is used, a segmentation fault may occur in the "//& "symbolic factorization phase.",& - default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VERBOSITY",& description="The level of output information.",& enum_c_vals=s2a("SILENT","BASIC","DETAILED"),& - enum_i_vals=(/0,1,2/), default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/0,1,2/), default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIN_RANKS_PER_POLE",& description="The minimum number of processors used for each pole. The real "//& "number of processors per pole is the smallest number greater or equal to "//& "MIN_RANKS_PER_POLE that divides MPI size without remainder. For efficiency, MIN_RANKS_PER_POLE "//& "should be a small numbers (limited by the available memory).", & - default_i_val=64,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=64) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CSR_SCREENING",& description="Whether distance screening should be applied to improve sparsity of CSR matrices.",& - default_l_val=.TRUE., lone_keyword_l_val = .TRUE. ,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val = .TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_pexsi_section diff --git a/src/input_cp2k_mixed.F b/src/input_cp2k_mixed.F index 9e0e3ec694..537e823ac4 100644 --- a/src/input_cp2k_mixed.F +++ b/src/input_cp2k_mixed.F @@ -48,13 +48,10 @@ MODULE input_cp2k_mixed ! ***************************************************************************** !> \brief Create the input section for MIXED. !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff ! ***************************************************************************** - SUBROUTINE create_mix_section(section,error) + SUBROUTINE create_mix_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mix_section', & routineP = moduleN//':'//routineN @@ -66,12 +63,11 @@ SUBROUTINE create_mix_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MIXED",& description="This section contains all information to run with a hamiltonian "//& "defined by a mixing of force_evals",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="MIXING_TYPE",& @@ -90,132 +86,123 @@ SUBROUTINE create_mix_section(section,error) "Use the difference between the energy of the force envs as a"//& " restraint on the first (support only 2 force_evals)",& "Defines a user-driven generica coupling (support for an unlimited number of force_eval)"),& - enum_i_vals=(/mix_linear_combination,mix_minimum,mix_coupled,mix_restrained,mix_generic/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/mix_linear_combination,mix_minimum,mix_coupled,mix_restrained,mix_generic/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GROUP_PARTITION",& description="gives the exact number of processors for each group."//& " If not specified processors allocated will be equally distributed for"//& " the specified subforce_eval, trying to build a number of groups equal to the"//& " number of subforce_eval specified.",& - usage="group_partition 2 2 4 2 4 ", type_of_var=integer_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="group_partition 2 2 4 2 4 ", type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NGROUPS",variants=(/"NGROUP"/),& description="Gives the wanted number of groups. If not specified the number"//& " of groups is set to the number of subforce_eval defined.",& - usage="ngroups 4", type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ngroups 4", type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Double force_eval CALL section_create(subsection,name="LINEAR",& description="Linear combination between two force_eval: F= lambda F1 + (1-lambda) F2",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="LAMBDA",& description="Specify the mixing parameter lambda in the formula.",& - usage="lambda ", type_of_var=real_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="lambda ", type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="COUPLING",& description="Coupling between two force_eval: E=(E1+E2 - sqrt((E1-E2)**2+4*H12**2))/2",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="COUPLING_PARAMETER",& description="Coupling parameter H12 used in the coupling",& - usage="COUPLING_PARAMETER ", type_of_var=real_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="COUPLING_PARAMETER ", type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="RESTRAINT",& description="Restraint between two force_eval: E = E1 + k*(E1-E2-t)**2",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="RESTRAINT_TARGET",& description="Target value of the restraint (t) ",& - usage="RESTRAINT_TARGET ", type_of_var=real_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESTRAINT_TARGET ", type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTRAINT_STRENGTH",& description="Strength of the restraint (k) in "//& "k*(E1-E2-t)**2" ,& - usage="RESTRAINT_STRENGTH ", type_of_var=real_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="RESTRAINT_STRENGTH ", type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! Multiple force_eval CALL section_create(subsection,name="GENERIC",& description="User driven coupling between two or more force_eval.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="MIXING_FUNCTION",& description="Specifies the mixing functional form in mathematical notation.",& usage="MIXING_FUNCTION (E1+E2-LOG(E1/E2))", type_of_var=lchar_t,& - n_var=1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VARIABLES",& description="Defines the variables of the functional form. To allow an efficient"//& " mapping the order of the energy variables will be considered identical to the"//& " order of the force_eval in the force_eval_order list.",& usage="VARIABLES x", type_of_var=char_t,& - n_var=-1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARAMETERS",& description="Defines the parameters of the functional form",& usage="PARAMETERS a b D", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VALUES",& description="Defines the values of parameter of the functional form",& usage="VALUES ", type_of_var=real_t,& - n_var=-1, repeats=.TRUE., unit_str="internal_cp2k", error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE., unit_str="internal_cp2k") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="UNITS",& description="Optionally, allows to define valid CP2K unit strings for each parameter value. "//& "It is assumed that the corresponding parameter value is specified in this unit.",& usage="UNITS angstrom eV*angstrom^-1 angstrom^1 K", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DX",& description="Parameter used for computing the derivative with the Ridders' method.",& - usage="DX ", default_r_val=0.1_dp, unit_str="bohr", error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DX ", default_r_val=0.1_dp, unit_str="bohr") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ERROR_LIMIT",& description="Checks that the error in computing the derivative is not larger than "//& "the value set; in case error is larger a warning message is printed.",& - usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="ERROR_LIMIT ", default_r_val=1.0E-12_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! Mapping of atoms NULLIFY(sub2section, sub3section) @@ -224,110 +211,98 @@ SUBROUTINE create_mix_section(section,error) " The default is to have a mapping 1-1 between atom index (i.e. all force_eval share the same"//& " geometrical structure). The mapping is based on defining fragments and the mapping the "//& " fragments between the several force_eval and the mixed force_eval",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) ! Mixed force_eval CALL section_create(sub2section,name="FORCE_EVAL_MIXED",& description="Defines the fragments for the mixed force_eval (reference)",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL section_create(sub3section,name="FRAGMENT",& description="Fragment definition",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Defines the index of the fragment defined",& - usage="", type_of_var=integer_t, n_var=1, error=error) - CALL section_add_keyword(sub3section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="", type_of_var=integer_t, n_var=1) + CALL section_add_keyword(sub3section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Starting and ending atomic index defining one fragment must be provided",& - usage="{Integer} {Integer}", type_of_var=integer_t, n_var=2, repeats=.TRUE.,& - error=error) - CALL section_add_keyword(sub3section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Integer} {Integer}", type_of_var=integer_t, n_var=2, repeats=.TRUE.) + CALL section_add_keyword(sub3section,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(sub2section,sub3section,error=error) - CALL section_release(sub3section,error=error) - CALL section_add_subsection(subsection,sub2section,error=error) - CALL section_release(sub2section,error=error) + CALL section_add_subsection(sub2section,sub3section) + CALL section_release(sub3section) + CALL section_add_subsection(subsection,sub2section) + CALL section_release(sub2section) ! All other force_eval CALL section_create(sub2section,name="FORCE_EVAL",& description="Defines the fragments and the mapping for each force_eval (an integer index (ID) "//& "needs to be provided as parameter)",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="DEFINE_FRAGMENTS",& description="Specify the fragments definition of the force_eval through the fragments of the"//& " force_eval_mixed. This avoids the pedantic definition of the fragments for the force_eval,"//& " assuming the order of the fragments for the specified force_eval is the same as the sequence "//& " of integers provided. Easier to USE should be preferred to the specification of the single fragments.",& - usage="DEFINE_FRAGMENTS .. ", type_of_var=integer_t, n_var=-1,& - error=error) - CALL section_add_keyword(sub2section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DEFINE_FRAGMENTS .. ", type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(sub2section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Defines the index of the force_eval for which fragments and mappings are provided",& - usage="", type_of_var=integer_t, n_var=1, error=error) - CALL section_add_keyword(sub2section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="", type_of_var=integer_t, n_var=1) + CALL section_add_keyword(sub2section,keyword) + CALL keyword_release(keyword) CALL section_create(sub3section,name="FRAGMENT",& description="Fragment definition",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Defines the index of the fragment defined",& - usage="", type_of_var=integer_t, n_var=1, error=error) - CALL section_add_keyword(sub3section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="", type_of_var=integer_t, n_var=1) + CALL section_add_keyword(sub3section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Starting and ending atomic index defining one fragment must be provided",& - usage="{Integer} {Integer}", type_of_var=integer_t, n_var=2, repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub3section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Integer} {Integer}", type_of_var=integer_t, n_var=2, repeats=.FALSE.) + CALL section_add_keyword(sub3section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAP",& description="Provides the index of the fragment of the MIXED force_eval mapped on the"//& " locally defined fragment.",& - usage="MAP ", type_of_var=integer_t, n_var=1, repeats=.FALSE.,& - error=error) - CALL section_add_keyword(sub3section,keyword,error=error) - CALL keyword_release(keyword,error=error) - - CALL section_add_subsection(sub2section,sub3section,error=error) - CALL section_release(sub3section,error=error) - CALL section_add_subsection(subsection,sub2section,error=error) - CALL section_release(sub2section,error=error) - - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) - - CALL create_print_mix_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="MAP ", type_of_var=integer_t, n_var=1, repeats=.FALSE.) + CALL section_add_keyword(sub3section,keyword) + CALL keyword_release(keyword) + + CALL section_add_subsection(sub2section,sub3section) + CALL section_release(sub3section) + CALL section_add_subsection(subsection,sub2section) + CALL section_release(sub2section) + + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) + + CALL create_print_mix_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_mix_section ! ***************************************************************************** !> \brief Create the print section for mixed !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_print_mix_section(section,error) + SUBROUTINE create_print_mix_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_mix_section', & routineP = moduleN//':'//routineN @@ -336,29 +311,26 @@ SUBROUTINE create_print_mix_section(section,error) TYPE(section_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Section of possible print options in MIXED env.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of information during the evaluation of "//& "the mixed environment. ",& - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"DIPOLE",& description="Controls the printing of dipole information. "//& "Requires the DIPOLE calculation be active for all subforce_eval.", & - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_mix_section END MODULE input_cp2k_mixed diff --git a/src/input_cp2k_mm.F b/src/input_cp2k_mm.F index 481978c29e..d340c5adb0 100644 --- a/src/input_cp2k_mm.F +++ b/src/input_cp2k_mm.F @@ -65,13 +65,10 @@ MODULE input_cp2k_mm ! ***************************************************************************** !> \brief Create the input section for FIST.. Come on.. Let's get woohooo !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_mm_section(section,error) + SUBROUTINE create_mm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mm_section', & routineP = moduleN//':'//routineN @@ -81,29 +78,28 @@ SUBROUTINE create_mm_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="mm",& description="This section contains all information to run a MM calculation.",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection) - CALL create_forcefield_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_forcefield_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_neighbor_lists_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_neighbor_lists_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_poisson_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_poisson_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_print_mm_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_print_mm_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_mm_section @@ -111,13 +107,10 @@ END SUBROUTINE create_mm_section ! ***************************************************************************** !> \brief Create the print mm section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_print_mm_section(section,error) + SUBROUTINE create_print_mm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_mm_section', & routineP = moduleN//':'//routineN @@ -127,96 +120,88 @@ SUBROUTINE create_print_mm_section(section,error) TYPE(section_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Section of possible print options in MM code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key, keyword) CALL cp_print_key_section_create(print_key,"DERIVATIVES",& description="Controls the printing of derivatives.", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"EWALD_INFO",& description="Controls the printing of Ewald energy components during the "//& "evaluation of the electrostatics.", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_dipoles_section(print_key,"DIPOLE",medium_print_level,error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL create_dipoles_section(print_key,"DIPOLE",medium_print_level) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"NEIGHBOR_LISTS",& description="Activates the printing of the neighbor lists.", & - print_level=high_print_level,filename="",unit_str="angstrom",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="",unit_str="angstrom") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ITER_INFO",& description="Activates the printing of iteration info during the self-consistent "//& "calculation of a polarizable forcefield.", & - print_level=medium_print_level,filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SUBCELL",& description="Activates the printing of the subcells used for the"//& "generation of neighbor lists.", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_BANNER",& description="Controls the printing of the banner of the MM program",& - print_level=silent_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=silent_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of information regarding the run.",& - print_level=low_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "FF_PARAMETER_FILE", description=& "Controls the printing of Force Field parameter file", & - print_level=debug_print_level+1,filename="",common_iter_levels=2,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level+1,filename="",common_iter_levels=2) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "FF_INFO", description=& "Controls the printing of information in the forcefield settings", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword,"spline_info",& description="if the printkey is active prints information regarding the splines"//& " used in the nonbonded interactions",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"spline_data",& description="if the printkey is active prints on separated files the splined function"//& " together with the reference one. Useful to check the spline behavior.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_mm_section @@ -224,13 +209,10 @@ END SUBROUTINE create_print_mm_section !> \brief Create the forcefield section. This section is useful to set up the !> proper force_field for FIST calculations !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_forcefield_section(section,error) + SUBROUTINE create_forcefield_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_forcefield_section', & routineP = moduleN//':'//routineN @@ -241,12 +223,11 @@ SUBROUTINE create_forcefield_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="FORCEFIELD",& description="Section specifying information regarding how to set up properly"// & " a force_field for the classical calculations.",& - n_keywords=2, n_subsections=2, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=2, repeats=.FALSE.) NULLIFY(subsection,keyword) @@ -264,27 +245,27 @@ SUBROUTINE create_forcefield_section(section,error) do_ff_g87,& do_ff_g96,& do_ff_amber/),& - default_i_val=do_ff_undef, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ff_undef) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARM_FILE_NAME",& description="Specifies the filename that contains the parameters of the FF.",& - usage="PARM_FILE_NAME {FILENAME}",type_of_var=lchar_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PARM_FILE_NAME {FILENAME}",type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VDW_SCALE14",& description="Scaling factor for the VDW 1-4 ",& - usage="VDW_SCALE14 1.0", default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="VDW_SCALE14 1.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EI_SCALE14",& description="Scaling factor for the electrostatics 1-4 ",& - usage="EI_SCALE14 1.0", default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EI_SCALE14 1.0", default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHIFT_CUTOFF",& description="Add a constant energy shift to the real-space "//& @@ -292,9 +273,9 @@ SUBROUTINE create_forcefield_section(section,error) "electrostatic) such that the energy at the cutoff radius is "//& "zero. This makes the non-bonding interactions continuous at "//& "the cutoff.",& - usage="SHIFT_CUTOFF ", default_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SHIFT_CUTOFF ", default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DO_NONBONDED",& description="Controls the computation of all the real-space "//& @@ -303,90 +284,87 @@ SUBROUTINE create_forcefield_section(section,error) "or scaled 1-2, 1-3 and 1-4 interactions. When set "//& "to F, the neighborlists are not created and all "//& "interactions that depend on them are not computed.",& - usage="DO_NONBONDED T",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DO_NONBONDED T",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IGNORE_MISSING_CRITICAL_PARAMS",& description="Do not abort when critical force-field parameters "//& "are missing. CP2K will run as if the terms containing the "//& "missing parameters are zero.",& usage="IGNORE_MISSING_BOND_PARAMS T",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MULTIPLE_POTENTIAL",& description="Enables the possibility to define NONBONDED and NONBONDED14 as a"//& " sum of different kinds of potential. Useful for piecewise defined potentials.",& - usage="MULTIPLE_POTENTIAL T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MULTIPLE_POTENTIAL T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) !Universal scattering potential at very short distances CALL keyword_create(keyword, name="ZBL_SCATTERING",& description="A short range repulsive potential is added, to simulate "//& "collisions and scattering.",& - usage="ZBL_SCATTERING T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ZBL_SCATTERING T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! ! subsections ! - CALL create_SPLINE_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_SPLINE_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_NONBONDED_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_NONBONDED_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_NONBONDED14_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_NONBONDED14_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_CHARGE_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_CHARGE_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_CHARGES_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_CHARGES_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_SHELL_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_SHELL_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_BOND_section(subsection, "BOND", error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_BOND_section(subsection, "BOND") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_BEND_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_BEND_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_TORSION_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_TORSION_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_IMPROPER_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_IMPROPER_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_OPBEND_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_OPBEND_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_DIPOLE_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_DIPOLE_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_QUADRUPOLE_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_QUADRUPOLE_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_forcefield_section @@ -394,13 +372,10 @@ END SUBROUTINE create_forcefield_section ! ***************************************************************************** !> \brief This section specifies the parameters for the splines !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_SPLINE_section(section,error) + SUBROUTINE create_SPLINE_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_SPLINE_section', & routineP = moduleN//':'//routineN @@ -410,12 +385,11 @@ SUBROUTINE create_SPLINE_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SPLINE",& description="specifies parameters to set up the splines used in the"//& " nonboned interactions (both pair body potential and many body potential)",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -423,71 +397,66 @@ SUBROUTINE create_SPLINE_section(section,error) description="Specify the minimum value of the distance interval "//& " that brackets the value of emax_spline.",& usage="R0_NB ",default_r_val=cp_unit_to_cp2k(value=0.9_dp,& - unit_str="bohr",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="bohr"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT_NB",& description="Cutoff radius for nonbonded interactions. This value overrides "//& " the value specified in the potential definition and is global for all potentials.",& usage="RCUT_NB {real}", default_r_val=cp_unit_to_cp2k(value=-1.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EMAX_SPLINE",& description="Specify the maximum value of the potential up to which"//& " splines will be constructed",& usage="EMAX_SPLINE ",& - default_r_val=0.5_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.5_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EMAX_ACCURACY",& description="Specify the maximum value of energy used to check the accuracy"//& " requested through EPS_SPLINE. Energy values larger than EMAX_ACCURACY"//& " generally do not satisfy the requested accuracy",& - usage="EMAX_ACCURACY ", default_r_val=0.02_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EMAX_ACCURACY ", default_r_val=0.02_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SPLINE",& description="Specify the threshold for the choice of the number of"//& " points used in the splines (comparing the splined value with the "//& " analytically evaluated one)",& - usage="EPS_SPLINE ", default_r_val=1.0E-7_dp,unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SPLINE ", default_r_val=1.0E-7_dp,unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NPOINTS",& description="Override the default search for an accurate spline by specifying a fixed number of spline points.",& - usage="NPOINTS 1024", default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NPOINTS 1024", default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="UNIQUE_SPLINE",& description="For few potentials (Lennard-Jones) one global optimal spline is generated instead"//& " of different optimal splines for each kind of potential",& - usage="UNIQUE_SPLINE ",lone_keyword_l_val=.TRUE., default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="UNIQUE_SPLINE ",lone_keyword_l_val=.TRUE., default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_SPLINE_section ! ***************************************************************************** !> \brief This section specifies the torsion of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_TORSION_section(section,error) + SUBROUTINE create_TORSION_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_TORSION_section', & routineP = moduleN//':'//routineN @@ -497,19 +466,18 @@ SUBROUTINE create_TORSION_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="TORSION",& description="Specifies the torsion potential of the MM system.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kinds involved in the tors.",& usage="ATOMS {KIND1} {KIND2} {KIND3} {KIND4}", type_of_var=char_t,& - n_var=4, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="KIND",& description="Define the kind of torsion potential",& @@ -523,43 +491,40 @@ SUBROUTINE create_TORSION_section(section,error) do_ff_g87,& do_ff_g96,& do_ff_amber/),& - default_i_val=do_ff_charmm, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ff_charmm) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Defines the force constant of the potential",& usage="K {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PHI0",& description="Defines the phase of the potential.",& usage="PHI0 {real}", type_of_var=real_t,& - n_var=1, unit_str="rad", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="rad") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="M",& description="Defines the multiplicity of the potential.",& usage="M {integer}", type_of_var=integer_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_TORSION_section ! ***************************************************************************** !> \brief This section specifies the improper torsion of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author louis vanduyfhuys ! ***************************************************************************** - SUBROUTINE create_IMPROPER_section(section,error) + SUBROUTINE create_IMPROPER_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_IMPROPER_section', & routineP = moduleN//':'//routineN @@ -569,19 +534,18 @@ SUBROUTINE create_IMPROPER_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="IMPROPER",& description="Specifies the improper torsion potential of the MM system.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kinds involved in the improper tors.",& usage="ATOMS {KIND1} {KIND2} {KIND3} {KIND4}", type_of_var=char_t,& - n_var=4, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="KIND",& description="Define the kind of improper torsion potential",& @@ -595,36 +559,33 @@ SUBROUTINE create_IMPROPER_section(section,error) do_ff_g87,& do_ff_g96,& do_ff_harmonic/),& - default_i_val=do_ff_charmm, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ff_charmm) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Defines the force constant of the potential",& usage="K {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree*rad^-2",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*rad^-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PHI0",& description="Defines the phase of the potential.",& usage="PHI0 {real}", type_of_var=real_t,& - n_var=1, unit_str="rad", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="rad") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_IMPROPER_section ! ***************************************************************************** !> \brief This section specifies the out of plane bend of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author louis vanduyfhuys ! ***************************************************************************** - SUBROUTINE create_OPBEND_section(section,error) + SUBROUTINE create_OPBEND_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_OPBEND_section', & routineP = moduleN//':'//routineN @@ -634,21 +595,20 @@ SUBROUTINE create_OPBEND_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="OPBEND",& description="Specifies the out of plane bend potential of the MM system."//& "(Only defined for atom quadruples which are also defined as an improper"//& " pattern in the topology.)",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kinds involved in the opbend.",& usage="ATOMS {KIND1} {KIND2} {KIND3} {KIND4}", type_of_var=char_t,& - n_var=4, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="KIND",& description="Define the kind of out of plane bend potential",& @@ -662,36 +622,33 @@ SUBROUTINE create_OPBEND_section(section,error) do_ff_mm2,& do_ff_mm3,& do_ff_mm4/),& - default_i_val=do_ff_harmonic, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ff_harmonic) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Defines the force constant of the potential",& usage="K {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree*rad^-2",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*rad^-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PHI0",& description="Defines the phase of the potential.",& usage="PHI0 {real}", type_of_var=real_t,& - n_var=1, unit_str="rad", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="rad") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_OPBEND_section ! ***************************************************************************** !> \brief This section specifies the bend of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_BEND_section(section,error) + SUBROUTINE create_BEND_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_BEND_section', & routineP = moduleN//':'//routineN @@ -702,20 +659,19 @@ SUBROUTINE create_BEND_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BEND",& description="Specifies the bend potential of the MM system.",& - n_keywords=1, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword,subsection) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kinds involved in the bend.",& usage="ATOMS {KIND1} {KIND2} {KIND3}", type_of_var=char_t,& - n_var=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="KIND",& description="Define the kind of bend potential",& @@ -740,66 +696,66 @@ SUBROUTINE create_BEND_section(section,error) do_ff_cubic,& do_ff_mixed_bend_stretch,& do_ff_mm3/),& - default_i_val=do_ff_charmm, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ff_charmm) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Defines the force constant of the potential",& usage="K {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree*rad^-2",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*rad^-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CB",& description="Defines the the cubic force constant of the bend",& usage="CB {real}", default_r_val=0.0_dp , type_of_var=real_t,& - n_var=1, unit_str="rad^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="rad^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R012",& description="Mixed bend stretch parameter",& usage="R012 {real}", default_r_val=0.0_dp , type_of_var=real_t,& - n_var=1, unit_str="bohr",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R032",& description="Mixed bend stretch parameter",& usage="R032 {real}", default_r_val=0.0_dp , type_of_var=real_t,& - n_var=1, unit_str="bohr",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KBS12",& description="Mixed bend stretch parameter",& usage="KBS12 {real}", default_r_val=0.0_dp , type_of_var=real_t,& - n_var=1, unit_str="hartree*bohr^-1*rad^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*bohr^-1*rad^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KBS32",& description="Mixed bend stretch parameter",& usage="KBS32 {real}", default_r_val=0.0_dp , type_of_var=real_t,& - n_var=1, unit_str="hartree*bohr^-1*rad^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*bohr^-1*rad^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KSS",& description="Mixed bend stretch parameter",& usage="KSS {real}", default_r_val=0.0_dp , type_of_var=real_t,& - n_var=1, unit_str="hartree*bohr^-2",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*bohr^-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="THETA0",& description="Defines the equilibrium angle.",& usage="THETA0 {real}", type_of_var=real_t,& - n_var=1, unit_str='rad',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str='rad') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Create the Urey-Bradley section - CALL create_BOND_section(subsection,"UB",error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_BOND_section(subsection,"UB") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_BEND_section @@ -808,14 +764,11 @@ END SUBROUTINE create_BEND_section !> \brief This section specifies the bond of the MM atoms !> \param section the section to create !> \param label ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_BOND_section(section,label,error) + SUBROUTINE create_BOND_section(section,label) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: label - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_BOND_section', & routineP = moduleN//':'//routineN @@ -826,7 +779,7 @@ SUBROUTINE create_BOND_section(section,label,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword) IF (TRIM(label)=="UB") THEN @@ -834,22 +787,20 @@ SUBROUTINE create_BOND_section(section,label,error) CALL section_create(section,name=TRIM(label),& description="Specifies the Urey-Bradley potential between the external atoms"//& " defining the angle",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) ELSE tag = " Bond " CALL section_create(section,name=TRIM(label),& description="Specifies the bond potential",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kinds involved in the bond.",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END IF CALL keyword_create(keyword=keyword, name="KIND",& @@ -875,45 +826,42 @@ SUBROUTINE create_BOND_section(section,label,error) do_ff_morse, & do_ff_cubic, & do_ff_fues/),& - default_i_val=do_ff_charmm, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ff_charmm) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Defines the force constant of the potential. "//& "For MORSE potentials 2 numbers are expected. "//& "For QUARTIC potentials 3 numbers are expected.",& usage="K {real}", type_of_var=real_t,& - n_var=-1, unit_str="internal_cp2k",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CS",& description="Defines the cubic stretch term.",& usage="CS {real}", default_r_val=0.0_dp , type_of_var=real_t,& - n_var=1, unit_str="bohr^-1", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="bohr^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R0",& description="Defines the equilibrium distance.",& usage="R0 {real}", type_of_var=real_t,& - n_var=1, unit_str="bohr", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_BOND_section ! ***************************************************************************** !> \brief This section specifies the charge of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_charges_section(section,error) + SUBROUTINE create_charges_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_charges_section', & routineP = moduleN//':'//routineN @@ -923,33 +871,29 @@ SUBROUTINE create_charges_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="charges",& description="Allow to specify an array of classical charges, thus avoiding the"//& " packing and permitting the usage of different charges for same atomic types.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Value of the charge for the individual atom. Order MUST reflect"//& " the one specified for the geometry.", repeats=.TRUE., usage="{Real}", & - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_charges_section ! ***************************************************************************** !> \brief This section specifies the charge of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_charge_section(section,error) + SUBROUTINE create_charge_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_charge_section', & routineP = moduleN//':'//routineN @@ -959,40 +903,36 @@ SUBROUTINE create_charge_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="charge",& description="This section specifies the charge of the MM atoms",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOM",& description="Defines the atomic kind of the charge.",& usage="ATOM {KIND1}", type_of_var=char_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE",& description="Defines the charge of the MM atom in electron charge unit.",& usage="CHARGE {real}", type_of_var=real_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_charge_section ! ***************************************************************************** !> \brief This section specifies the isotropic polarizability of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Marcel Baer ! ***************************************************************************** - SUBROUTINE create_quadrupole_section(section,error) + SUBROUTINE create_quadrupole_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_quadrupole_section', & routineP = moduleN//':'//routineN @@ -1002,41 +942,37 @@ SUBROUTINE create_quadrupole_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="QUADRUPOLE",& description="This section specifies that we will perform an SCF quadrupole calculation of the MM atoms. "//& "Needs KEYWORD POL_SCF in POISSON secton",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOM",& description="Defines the atomic kind of the SCF quadrupole.",& usage="ATOM {KIND1}", type_of_var=char_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CPOL",& description="Defines the isotropic polarizability of the MM atom.",& usage="CPOL {real}", type_of_var=real_t,& - n_var=1, unit_str='internal_cp2k', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str='internal_cp2k') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_quadrupole_section ! ***************************************************************************** !> \brief This section specifies the isotropic polarizability of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Marcel Baer ! ***************************************************************************** - SUBROUTINE create_dipole_section(section,error) + SUBROUTINE create_dipole_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_dipole_section', & routineP = moduleN//':'//routineN @@ -1047,44 +983,40 @@ SUBROUTINE create_dipole_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DIPOLE",& description="This section specifies that we will perform an SCF dipole calculation of the MM atoms. "//& "Needs KEYWORD POL_SCF in POISSON secton",& - n_keywords=1, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.TRUE.) NULLIFY(subsection,keyword) CALL keyword_create(keyword, name="ATOM",& description="Defines the atomic kind of the SCF dipole.",& usage="ATOM {KIND1}", type_of_var=char_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APOL",& description="Defines the isotropic polarizability of the MM atom.",& usage="APOL {real}", type_of_var=real_t,& - n_var=1, unit_str='angstrom^3', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str='angstrom^3') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_DAMPING_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_DAMPING_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_dipole_section ! ***************************************************************************** !> \brief This section specifies the idamping parameters for polarizable atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Rodolphe Vuilleumier ! ***************************************************************************** - SUBROUTINE create_damping_section(section,error) + SUBROUTINE create_damping_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_damping_section', & routineP = moduleN//':'//routineN @@ -1094,62 +1026,58 @@ SUBROUTINE create_damping_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DAMPING",& description="This section specifies optional electric field damping for the polarizable atoms. ",& - n_keywords=4, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=4, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOM",& description="Defines the atomic kind for this damping function.",& usage="ATOM {KIND1}", type_of_var=char_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TYPE",& description="Defines the damping type.",& usage="TYPE {string}", type_of_var=char_t,& - n_var=1, default_c_val="TANG-TOENNIES", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, default_c_val="TANG-TOENNIES") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORDER",& description="Defines the order for this damping.",& usage="ORDER {integer}", type_of_var=integer_t,& - n_var=1, default_i_val=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BIJ",& description="Defines the BIJ parameter for this damping.",& usage="BIJ {real}", type_of_var=real_t,& - n_var=1, unit_str='angstrom^-1', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str='angstrom^-1') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CIJ",& description="Defines the CIJ parameter for this damping.",& usage="CIJ {real}", type_of_var=real_t,& - n_var=1, unit_str='', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str='') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_damping_section ! ***************************************************************************** !> \brief This section specifies the charge of the MM atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_shell_section(section,error) + SUBROUTINE create_shell_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_shell_section', & routineP = moduleN//':'//routineN @@ -1159,44 +1087,43 @@ SUBROUTINE create_shell_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section, name="SHELL",& description="This section specifies the parameters for shell-model potentials",& n_keywords=6, n_subsections=0, repeats=.TRUE., & - citations=(/Dick1958,Mitchell1993,Devynck2012/),& - error=error) + citations=(/Dick1958,Mitchell1993,Devynck2012/)) NULLIFY(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="The kind for which the shell potential parameters are given ",& - usage="H", default_c_val="DEFAULT", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="H", default_c_val="DEFAULT") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORE_CHARGE",& variants=(/"CORE"/),& description="Partial charge assigned to the core (electron charge units)",& usage="CORE_CHARGE {real}",& - default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHELL_CHARGE",& variants=(/"SHELL"/),& description="Partial charge assigned to the shell (electron charge units)",& usage="SHELL_CHARGE {real}",& - default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MASS_FRACTION",& variants=(/"MASS"/),& description="Fraction of the mass of the atom to be assigned to the shell",& usage="MASS_FRACTION {real}",& - default_r_val=0.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K2_SPRING",& variants=s2a("K2","SPRING"),& @@ -1205,10 +1132,9 @@ SUBROUTINE create_shell_section(section,error) repeats=.FALSE.,& usage="K2_SPRING {real}",& default_r_val=-1.0_dp,& - unit_str="hartree*bohr^-2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="hartree*bohr^-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K4_SPRING",& variants=s2a("K4"),& @@ -1218,19 +1144,18 @@ SUBROUTINE create_shell_section(section,error) repeats=.FALSE.,& usage="K4_SPRING {real}",& default_r_val=0.0_dp,& - unit_str="hartree*bohr^-4",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="hartree*bohr^-4") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_DISTANCE",& description="Assign a maximum elongation of the spring, "//& "if negative no limit is imposed",& usage="MAX_DISTANCE 0.0",& default_r_val=-1.0_dp,& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHELL_CUTOFF",& description="Define a screening function to exclude some neighbors "//& @@ -1238,9 +1163,9 @@ SUBROUTINE create_shell_section(section,error) "if negative no screening is operated",& usage="SHELL_CUTOFF -1.0",& default_r_val=-1.0_dp,& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_shell_section @@ -1249,13 +1174,10 @@ END SUBROUTINE create_shell_section !> \brief This section specifies the input parameters for 1-4 NON-BONDED !> Interactions !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_NONBONDED14_section(section,error) + SUBROUTINE create_NONBONDED14_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_NONBONDED14_section', & routineP = moduleN//':'//routineN @@ -1265,28 +1187,27 @@ SUBROUTINE create_NONBONDED14_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="nonbonded14",& description="This section specifies the input parameters for 1-4 NON-BONDED interactions.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection) - CALL create_LJ_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_LJ_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Williams_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Williams_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Goodwin_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Goodwin_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_GENPOT_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_GENPOT_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_NONBONDED14_section @@ -1295,13 +1216,10 @@ END SUBROUTINE create_NONBONDED14_section !> \brief This section specifies the input parameters for 1-4 NON-BONDED !> Interactions !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_NONBONDED_section(section,error) + SUBROUTINE create_NONBONDED_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_NONBONDED_section', & routineP = moduleN//':'//routineN @@ -1311,64 +1229,63 @@ SUBROUTINE create_NONBONDED_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="nonbonded",& description="This section specifies the input parameters for NON-BONDED interactions.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(subsection) - CALL create_LJ_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_LJ_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Williams_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Williams_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_EAM_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_EAM_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_QUIP_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_QUIP_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Goodwin_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Goodwin_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_IPBV_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_IPBV_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_BMHFT_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_BMHFT_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_BMHFTD_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_BMHFTD_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Buck4r_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Buck4r_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Buckmorse_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Buckmorse_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_GENPOT_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_GENPOT_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Tersoff_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Tersoff_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Siepmann_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Siepmann_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_NONBONDED_section @@ -1377,13 +1294,10 @@ END SUBROUTINE create_NONBONDED_section !> \brief This section specifies the input parameters for generation of !> neighbor lists !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo [07.2007] - Zurich University ! ***************************************************************************** - SUBROUTINE create_neighbor_lists_section(section,error) + SUBROUTINE create_neighbor_lists_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_neighbor_lists_section', & @@ -1395,28 +1309,26 @@ SUBROUTINE create_neighbor_lists_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="neighbor_lists",& description="This section specifies the input parameters for the construction of"//& " neighbor lists.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="VERLET_SKIN",& description="Defines the Verlet Skin for the generation of the neighbor lists",& usage="VERLET_SKIN {real}", default_r_val=cp_unit_to_cp2k(value=1.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="neighbor_lists_from_scratch",& description="This keyword enables the building of the neighbouring list from scratch.",& usage="neighbor_lists_from_scratch logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GEO_CHECK",& description="This keyword enables the check that two atoms are never below the minimum"//& @@ -1424,9 +1336,9 @@ SUBROUTINE create_neighbor_lists_section(section,error) " Disabling this keyword avoids CP2K to abort in case two atoms are below the minimum "//& " value of the radius used to generate the splines.",& usage="GEO_CHECK",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_neighbor_lists_section @@ -1434,13 +1346,10 @@ END SUBROUTINE create_neighbor_lists_section ! ***************************************************************************** !> \brief This section specifies the input parameters for a generic potential form !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_GENPOT_section(section,error) + SUBROUTINE create_GENPOT_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_GENPOT_section', & routineP = moduleN//':'//routineN @@ -1450,7 +1359,7 @@ SUBROUTINE create_GENPOT_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="GENPOT",& description="This section specifies the input parameters for a generic potential type."//& "A functional form is specified. Mathematical Operators recognized are +, -, *, /, ** "//& @@ -1458,89 +1367,84 @@ SUBROUTINE create_GENPOT_section(section,error) "The function parser recognizes the (single argument) Fortran 90 intrinsic functions "//& "abs, exp, log10, log, sqrt, sinh, cosh, tanh, sin, cos, tan, asin, acos, atan. "//& "Parsing for INTRINSIC functions is CASE INsensitive.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the generic potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTION",& description="Specifies the functional form in mathematical notation.",& usage="FUNCTION a*EXP(-b*x^2)/x+D*log10(x)", type_of_var=lchar_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VARIABLES",& description="Defines the variable of the functional form.",& usage="VARIABLES x", type_of_var=char_t,& - n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARAMETERS",& description="Defines the parameters of the functional form",& usage="PARAMETERS a b D", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VALUES",& description="Defines the values of parameter of the functional form",& usage="VALUES ", type_of_var=real_t,& - n_var=-1, repeats=.TRUE., unit_str="internal_cp2k", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE., unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="UNITS",& description="Optionally, allows to define valid CP2K unit strings for each parameter value. "//& "It is assumed that the corresponding parameter value is specified in this unit.",& usage="UNITS angstrom eV*angstrom^-1 angstrom^1 K", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the generic potential",& usage="RCUT {real}", default_r_val=cp_unit_to_cp2k(value=10.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_GENPOT_section ! ***************************************************************************** !> \brief This section specifies the input parameters for EAM potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_EAM_section(section,error) + SUBROUTINE create_EAM_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_EAM_section', & routineP = moduleN//':'//routineN @@ -1550,20 +1454,19 @@ SUBROUTINE create_EAM_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EAM",& description="This section specifies the input parameters for EAM potential type.",& - citations=(/Foiles1986/),n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + citations=(/Foiles1986/),n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARM_FILE_NAME",& variants=(/"PARMFILE"/),& @@ -1577,22 +1480,19 @@ SUBROUTINE create_EAM_section(section,error) "in order npoints lines for rho [au_c] and its derivative [au_c*angstrom^-1]; npoints lines for "//& "PHI [ev] and its derivative [ev*angstrom^-1] and npoint lines for the embedded function [ev] "//& "and its derivative [ev*au_c^-1].",& - usage="PARM_FILE_NAME {FILENAME}",default_lc_val=" ",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PARM_FILE_NAME {FILENAME}",default_lc_val=" ") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_EAM_section ! ***************************************************************************** !> \brief This section specifies the input parameters for QUIP potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_QUIP_section(section,error) + SUBROUTINE create_QUIP_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_QUIP_section', & routineP = moduleN//':'//routineN @@ -1602,15 +1502,14 @@ SUBROUTINE create_QUIP_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="QUIP",& description="This section specifies the input parameters for QUIP potential type. " //& "Mainly intended for things like GAP corrections to DFT "//& "to achieve correlated-wavefunction-like accuracy. " //& "Requires linking with quip library from http://www.libatoms.org .",& - citations=(/QUIP_ref/),n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + citations=(/QUIP_ref/),n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -1620,31 +1519,31 @@ SUBROUTINE create_QUIP_section(section,error) "has been mentioned at least once. Set IGNORE_MISSING_CRITICAL_PARAMS to T "//& "in enclosing &FORCEFIELD section to avoid having to list every pair of elements separately.",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARM_FILE_NAME",& variants=(/"PARMFILE"/),& description="Specifies the filename that contains the QUIP potential.",& - usage="PARM_FILE_NAME {FILENAME}",default_lc_val="quip_params.xml",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PARM_FILE_NAME {FILENAME}",default_lc_val="quip_params.xml") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INIT_ARGS",& description="Specifies the potential initialization arguments for the QUIP potential. "//& "If blank (default) first potential defined in QUIP parameter file will be used.",& usage="INIT_ARGS",default_c_vals=(/""/),& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CALC_ARGS",& description="Specifies the potential calculation arguments for the QUIP potential.",& usage="CALC_ARGS",default_c_vals=(/""/), & - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_QUIP_section @@ -1652,13 +1551,10 @@ END SUBROUTINE create_QUIP_section ! ***************************************************************************** !> \brief This section specifies the input parameters for Lennard-Jones potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_LJ_section(section,error) + SUBROUTINE create_LJ_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_LJ_section', & routineP = moduleN//':'//routineN @@ -1668,71 +1564,66 @@ SUBROUTINE create_LJ_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="lennard-jones",& description="This section specifies the input parameters for LENNARD-JONES potential type."//& "Functional form: V(r) = 4.0 * EPSILON * [(SIGMA/r)^12-(SIGMA/r)^6].",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPSILON",& description="Defines the EPSILON parameter of the LJ potential",& usage="EPSILON {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIGMA",& description="Defines the SIGMA parameter of the LJ potential",& usage="SIGMA {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the LJ potential",& usage="RCUT {real}", default_r_val=cp_unit_to_cp2k(value=10.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_LJ_section ! ***************************************************************************** !> \brief This section specifies the input parameters for Williams potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_Williams_section(section,error) + SUBROUTINE create_Williams_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_Williams_section', & routineP = moduleN//':'//routineN @@ -1742,78 +1633,73 @@ SUBROUTINE create_Williams_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="williams",& description="This section specifies the input parameters for WILLIAMS potential type."//& "Functional form: V(r) = A*EXP(-B*r) - C / r^6 .",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A",& description="Defines the A parameter of the Williams potential",& usage="A {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B",& description="Defines the B parameter of the Williams potential",& usage="B {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="C",& description="Defines the C parameter of the Williams potential",& usage="C {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e*angstrom^6",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e*angstrom^6") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the Williams potential",& usage="RCUT {real}",default_r_val=cp_unit_to_cp2k(value=10.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_Williams_section ! ***************************************************************************** !> \brief This section specifies the input parameters for Goodwin potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_Goodwin_section(section,error) + SUBROUTINE create_Goodwin_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_Goodwin_section', & routineP = moduleN//':'//routineN @@ -1823,91 +1709,86 @@ SUBROUTINE create_Goodwin_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="goodwin",& description="This section specifies the input parameters for GOODWIN potential type."//& "Functional form: V(r) = EXP(M*(-(r/DC)**MC+(D/DC)**MC))*VR0*(D/r)**M.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VR0",& description="Defines the VR0 parameter of the Goodwin potential",& usage="VR0 {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D",& description="Defines the D parameter of the Goodwin potential",& usage="D {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DC",& description="Defines the DC parameter of the Goodwin potential",& usage="DC {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="M",& description="Defines the M parameter of the Goodwin potential",& usage="M {real}", type_of_var=integer_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MC",& description="Defines the MC parameter of the Goodwin potential",& usage="MC {real}", type_of_var=integer_t,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the Goodwin potential",& usage="RCUT {real}",default_r_val=cp_unit_to_cp2k(value=10.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_Goodwin_section ! ***************************************************************************** !> \brief This section specifies the input parameters for IPBV potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_ipbv_section(section,error) + SUBROUTINE create_ipbv_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ipbv_section', & routineP = moduleN//':'//routineN @@ -1917,57 +1798,52 @@ SUBROUTINE create_ipbv_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ipbv",& description="This section specifies the input parameters for IPBV potential type."//& "Functional form: Implicit table function.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the IPBV nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the IPBV potential",& usage="RCUT {real}",default_r_val=cp_unit_to_cp2k(value=10.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ipbv_section ! ***************************************************************************** !> \brief This section specifies the input parameters for BMHFT potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_BMHFT_section(section,error) + SUBROUTINE create_BMHFT_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_BMHFT_section', & routineP = moduleN//':'//routineN @@ -1977,92 +1853,88 @@ SUBROUTINE create_BMHFT_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BMHFT",& description="This section specifies the input parameters for BMHFT potential type."//& "Functional form: V(r) = A * EXP(-B*r) - C/r^6 - D/r^8."//& "Values available inside cp2k only for the Na/Cl pair.",& - citations=(/Tosi1964a,Tosi1964b/),n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + citations=(/Tosi1964a,Tosi1964b/),n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the BMHFT nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAP_ATOMS",& description="Defines the kinds for which internally is defined the BMHFT nonbond potential"//& " at the moment only Na and Cl.",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the BMHFT potential",& usage="RCUT {real}", default_r_val=7.8_dp,& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A",& description="Defines the A parameter of the Fumi-Tosi Potential",& usage="A {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B",& description="Defines the B parameter of the Fumi-Tosi Potential",& usage="B {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="C",& description="Defines the C parameter of the Fumi-Tosi Potential",& usage="C {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree*angstrom^6",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*angstrom^6") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D",& description="Defines the D parameter of the Fumi-Tosi Potential",& usage="D {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree*angstrom^8",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*angstrom^8") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_BMHFT_section ! ***************************************************************************** !> \brief This section specifies the input parameters for BMHFTD potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mathieu Salanne 05.2010 ! ***************************************************************************** - SUBROUTINE create_BMHFTD_section(section,error) + SUBROUTINE create_BMHFTD_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_BMHFTD_section', & routineP = moduleN//':'//routineN @@ -2072,108 +1944,104 @@ SUBROUTINE create_BMHFTD_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BMHFTD",& description="This section specifies the input parameters for BMHFTD potential type."//& "Functional form: V(r) = A*exp(-B*r) - f_6*(r)C/r^6 - f_8(r)*D/r^8."//& "where f_order(r)=1-exp(-BD * r) * \sum_{k=0}^order (BD * r)^k / k! ."//& "(Tang-Toennies damping function)"//& "No values available inside cp2k.",& - citations=(/Tosi1964a,Tosi1964b/),n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + citations=(/Tosi1964a,Tosi1964b/),n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the BMHFTD nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAP_ATOMS",& description="Defines the kinds for which internally is defined the BMHFTD nonbond potential"//& " at the moment no species included.",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the BMHFTD potential",& usage="RCUT {real}", default_r_val=7.8_dp,& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A",& description="Defines the A parameter of the dispersion-damped Fumi-Tosi Potential",& usage="A {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B",& description="Defines the B parameter of the dispersion-damped Fumi-Tosi Potential",& usage="B {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="C",& description="Defines the C parameter of the dispersion-damped Fumi-Tosi Potential",& usage="C {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree*angstrom^6",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*angstrom^6") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D",& description="Defines the D parameter of the dispersion-damped Fumi-Tosi Potential",& usage="D {real}", type_of_var=real_t,& - n_var=1, unit_str="hartree*angstrom^8",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="hartree*angstrom^8") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BD",& description="Defines the BD parameter of the dispersion-damped Fumi-Tosi Potential",& usage="D {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ORDER",& description="Defines the order for this damping.",& usage="ORDER {integer}", type_of_var=integer_t,& - n_var=1, default_i_val=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_BMHFTD_section ! ***************************************************************************** !> \brief This section specifies the input parameters for Buckingham 4 ranges potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MI ! ***************************************************************************** - SUBROUTINE create_Buck4r_section(section,error) + SUBROUTINE create_Buck4r_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_Buck4r_section', & routineP = moduleN//':'//routineN @@ -2183,7 +2051,7 @@ SUBROUTINE create_Buck4r_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BUCK4RANGES",& description="This section specifies the input parameters for the Buckingham 4-ranges"//& " potential type."//& @@ -2192,111 +2060,106 @@ SUBROUTINE create_Buck4r_section(section,error) "
  • V(r) = Sum_n POLY1(n)*rn for r1 ≤ r < r2
    • "//& "
  • V(r) = Sum_n POLY2(n)*rn for r2 ≤ r < r3
    • "//& "
  • V(r) = -C/r6 for r ≥ r3
    • ",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A",& description="Defines the A parameter of the Buckingham potential",& usage="A {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B",& description="Defines the B parameter of the Buckingham potential",& usage="B {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="C",& description="Defines the C parameter of the Buckingham potential",& usage="C {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e*angstrom^6",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e*angstrom^6") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R1",& description="Defines the upper bound of the first range ",& usage="R1 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R2",& description="Defines the upper bound of the second range ",& usage="R2 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R3",& description="Defines the upper bound of the third range ",& usage="R3 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="POLY1",& description="Coefficients of the polynomial used in the second range"//& "This keyword can be repeated several times.",& usage="POLY1 C1 C2 C3 ..",& - n_var=-1,unit_str="K_e",type_of_var=real_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,unit_str="K_e",type_of_var=real_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="POLY2",& description="Coefficients of the polynomial used in the third range"//& "This keyword can be repeated several times.",& usage="POLY1 C1 C2 C3 ..",& - n_var=-1,unit_str="K_e",type_of_var=real_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,unit_str="K_e",type_of_var=real_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the Buckingham potential",& usage="RCUT {real}",default_r_val=cp_unit_to_cp2k(value=10.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_Buck4r_section ! ***************************************************************************** !> \brief This section specifies the input parameters for Buckingham + Morse potential type !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MI ! ***************************************************************************** - SUBROUTINE create_Buckmorse_section(section,error) + SUBROUTINE create_Buckmorse_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_Buckmorse_section', & routineP = moduleN//':'//routineN @@ -2306,108 +2169,106 @@ SUBROUTINE create_Buckmorse_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BUCKMORSE",& description="This section specifies the input parameters for"//& " Buckingham plus Morse potential type "//& " Functional Form: V(r) = F0*(B1+B2)*EXP([A1+A2-r]/[B1+B2])-C/r^6+D*{EXP[-2*beta*(r-R0)]-2*EXP[-beta*(r-R0)]}.",& - citations=(/Yamada2000/),n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + citations=(/Yamada2000/),n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="F0",& description="Defines the f0 parameter of Buckingham+Morse potential",& usage="F0 {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e*angstrom^-1", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e*angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A1",& description="Defines the A1 parameter of Buckingham+Morse potential",& usage="A1 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A2",& description="Defines the A2 parameter of Buckingham+Morse potential",& usage="A2 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B1",& description="Defines the B1 parameter of Buckingham+Morse potential",& usage="B1 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B2",& description="Defines the B2 parameter of Buckingham+Morse potential",& usage="B2 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="C",& description="Defines the C parameter of Buckingham+Morse potential",& usage="C {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e*angstrom^6",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e*angstrom^6") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D",& description="Defines the amplitude for the Morse part ",& usage="D {real}", type_of_var=real_t,& - n_var=1, unit_str="K_e",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="K_e") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R0",& description="Defines the equilibrium distance for the Morse part ",& usage="R0 {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Beta",& description="Defines the width for the Morse part ",& usage="Beta {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom^-1",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the Buckingham potential",& usage="RCUT {real}",default_r_val=cp_unit_to_cp2k(value=10.0_dp,& - unit_str="angstrom",& - error=error),& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Defines the lower bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMIN {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Defines the upper bound of the potential. If not set the range is the"//& " full range generate by the spline", usage="RMAX {real}", & - type_of_var=real_t, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_Buckmorse_section @@ -2415,11 +2276,9 @@ END SUBROUTINE create_Buckmorse_section !> \brief This section specifies the input parameters for Tersoff potential type !> (Tersoff, J. PRB 39(8), 5566, 1989) !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_Tersoff_section(section,error) + SUBROUTINE create_Tersoff_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_Tersoff_section', & routineP = moduleN//':'//routineN @@ -2429,138 +2288,130 @@ SUBROUTINE create_Tersoff_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="TERSOFF",& description="This section specifies the input parameters for Tersoff potential type.",& - citations=(/Tersoff1988/),n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + citations=(/Tersoff1988/),n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A",& description="Defines the A parameter of Tersoff potential",& usage="A {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=1.8308E3_dp,& - unit_str="eV",& - error=error),& - n_var=1, unit_str="eV", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="eV"),& + n_var=1, unit_str="eV") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B",& description="Defines the B parameter of Tersoff potential",& usage="B {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=4.7118E2_dp,& - unit_str="eV",& - error=error),& - n_var=1, unit_str="eV", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="eV"),& + n_var=1, unit_str="eV") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="lambda1",& description="Defines the lambda1 parameter of Tersoff potential",& usage="lambda1 {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=2.4799_dp,& - unit_str="angstrom^-1",& - error=error),& - n_var=1, unit_str="angstrom^-1", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom^-1"),& + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="lambda2",& description="Defines the lambda2 parameter of Tersoff potential",& usage="lambda2 {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=1.7322_dp,& - unit_str="angstrom^-1",& - error=error),& - n_var=1, unit_str="angstrom^-1", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom^-1"),& + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="alpha",& description="Defines the alpha parameter of Tersoff potential",& usage="alpha {real}", type_of_var=real_t,& default_r_val=0.0_dp,& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="beta",& description="Defines the beta parameter of Tersoff potential",& usage="beta {real}", type_of_var=real_t,& default_r_val=1.0999E-6_dp,& - n_var=1, unit_str="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="n",& description="Defines the n parameter of Tersoff potential",& usage="n {real}", type_of_var=real_t,& default_r_val=7.8734E-1_dp,& - n_var=1, unit_str="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="c",& description="Defines the c parameter of Tersoff potential",& usage="c {real}", type_of_var=real_t,& default_r_val=1.0039E5_dp,& - n_var=1, unit_str="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="d",& description="Defines the d parameter of Tersoff potential",& usage="d {real}", type_of_var=real_t,& default_r_val=1.6218E1_dp,& - n_var=1, unit_str="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="h",& description="Defines the h parameter of Tersoff potential",& usage="h {real}", type_of_var=real_t,& default_r_val=-5.9826E-1_dp,& - n_var=1, unit_str="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="lambda3",& description="Defines the lambda3 parameter of Tersoff potential",& usage="lambda3 {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=1.7322_dp,& - unit_str="angstrom^-1",& - error=error),& - n_var=1, unit_str="angstrom^-1", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom^-1"),& + n_var=1, unit_str="angstrom^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="bigR",& description="Defines the bigR parameter of Tersoff potential",& usage="bigR {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=2.85_dp,& - unit_str="angstrom",& - error=error),& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="bigD",& description="Defines the D parameter of Tersoff potential",& usage="bigD {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=0.15_dp,& - unit_str="angstrom",& - error=error),& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of the tersoff potential. "//& @@ -2569,9 +2420,9 @@ SUBROUTINE create_Tersoff_section(section,error) " in conjuction with other potentials (for the same atomic pair) in order to have"//& " the same consistent definition of RCUT for all potentials.",& usage="RCUT {real}", type_of_var=real_t,& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_Tersoff_section @@ -2580,11 +2431,9 @@ END SUBROUTINE create_Tersoff_section !> potential type !> (Siepmann and Sprik, J. Chem. Phys. 102(1) 511, 1995) !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_Siepmann_section(section,error) + SUBROUTINE create_Siepmann_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_Siepmann_section', & routineP = moduleN//':'//routineN @@ -2594,7 +2443,7 @@ SUBROUTINE create_Siepmann_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SIEPMANN",& description="This section specifies the input parameters for the"//& " Siepmann-Sprik potential type. Consists of 4 terms:"//& @@ -2602,80 +2451,75 @@ SUBROUTINE create_Siepmann_section(section,error) " have to be given via the GENPOT section. The terms T3+T4"//& " are obtained from the SIEPMANN section. The Siepmann-Sprik"//& " potential is designed for water-metal chemisorption.",& - citations=(/Siepmann1995/),n_keywords=1, n_subsections=0, repeats=.TRUE.,& - error=error) + citations=(/Siepmann1995/),n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kind involved in the nonbond potential",& usage="ATOMS {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B",& description="Defines the B parameter of Siepmann potential",& usage="B {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=0.6_dp,& - unit_str="angstrom",& - error=error),& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="D",& description="Defines the D parameter of Siepmann potential",& usage="D {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=3.688388_dp,& - unit_str="internal_cp2k",& - error=error),& - n_var=1, unit_str="internal_cp2k", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="internal_cp2k"),& + n_var=1, unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="E",& description="Defines the E parameter of Siepmann potential",& usage="E {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=9.069025_dp,& - unit_str="internal_cp2k",& - error=error),& - n_var=1, unit_str="internal_cp2k", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="internal_cp2k"),& + n_var=1, unit_str="internal_cp2k") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="F",& description="Defines the F parameter of Siepmann potential",& usage="B {real}", type_of_var=real_t,& - default_r_val=13.3_dp,n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=13.3_dp,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="beta",& description="Defines the beta parameter of Siepmann potential",& usage="beta {real}", type_of_var=real_t,& - default_r_val=10.0_dp, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=10.0_dp, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="RCUT",& description="Defines the cutoff parameter of Siepmann potential",& usage="RCUT {real}", type_of_var=real_t,& default_r_val=cp_unit_to_cp2k(value=3.2_dp,& - unit_str="angstrom",& - error=error),& - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),& + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="ALLOW_OH_FORMATION",& description="If water is treated at the QM level, water molecules"//& " can potentially dissociate. In that case, the T3"//& " term (dipole term) is switched off.",& usage="ALLOW_OH_FORMATION TRUE",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_Siepmann_section @@ -2684,15 +2528,12 @@ END SUBROUTINE create_Siepmann_section !> \param print_key ... !> \param label ... !> \param print_level ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_dipoles_section(print_key,label,print_level,error) + SUBROUTINE create_dipoles_section(print_key,label,print_level) TYPE(section_type), POINTER :: print_key CHARACTER(LEN=*), INTENT(IN) :: label INTEGER, INTENT(IN) :: print_level - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_dipoles_section', & routineP = moduleN//':'//routineN @@ -2701,12 +2542,12 @@ SUBROUTINE create_dipoles_section(print_key,label,print_level,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,failure) CALL cp_print_key_section_create(print_key_section=print_key,name=TRIM(label),& description="Section controlling the calculation of "//TRIM(label)//"."//& " Note that the result in the periodic case might be defined modulo a certain period,"//& " determined by the lattice vectors. During MD, this can lead to jumps.",& - print_level=print_level,filename="__STD_OUT__",error=error) + print_level=print_level,filename="__STD_OUT__") NULLIFY(keyword) CALL keyword_create(keyword=keyword,& @@ -2716,10 +2557,9 @@ SUBROUTINE create_dipoles_section(print_key,label,print_level,error) usage="PERIODIC {logical}",& repeats=.FALSE.,& n_var=1,& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="REFERENCE",& variants=s2a("REF"),& @@ -2734,9 +2574,9 @@ SUBROUTINE create_dipoles_section(print_key,label,print_level,error) use_mom_ref_coac,& use_mom_ref_user,& use_mom_ref_zero /),& - default_i_val=use_mom_ref_zero, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=use_mom_ref_zero) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="REFERENCE_POINT",& variants=s2a("REF_POINT"),& @@ -2745,10 +2585,9 @@ SUBROUTINE create_dipoles_section(print_key,label,print_level,error) repeats=.FALSE.,& n_var=3,default_r_vals=(/0._dp,0._dp,0._dp/),& type_of_var=real_t, & - unit_str='bohr',& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str='bohr') + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_dipoles_section END MODULE input_cp2k_mm diff --git a/src/input_cp2k_motion_print.F b/src/input_cp2k_motion_print.F index c6ea9db084..8437f5da3e 100644 --- a/src/input_cp2k_motion_print.F +++ b/src/input_cp2k_motion_print.F @@ -45,13 +45,10 @@ MODULE input_cp2k_motion_print ! ***************************************************************************** !> \brief creates the motion%print section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_motion_print_section(section,error) + SUBROUTINE create_motion_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_motion_print_section', & routineP = moduleN//':'//routineN @@ -63,44 +60,43 @@ SUBROUTINE create_motion_print_section(section,error) CALL section_create(section,name="print",& description="Controls the printing properties during an MD run",& - n_keywords=0, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) CALL cp_print_key_section_create(print_key,"TRAJECTORY",& description="Controls the output of the trajectory",& print_level=low_print_level, common_iter_levels=1,& - filename="",unit_str="angstrom",error=error) + filename="",unit_str="angstrom") CALL add_format_keyword(keyword, print_key, pos=.TRUE.,& - description="Specifies the format of the output file for the trajectory.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the trajectory.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SHELL_TRAJECTORY",& description="Controls the output of the trajectory of shells when the shell-model is used ",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="angstrom",error=error) + filename="",unit_str="angstrom") CALL add_format_keyword(keyword, print_key, pos=.TRUE.,& - description="Specifies the format of the output file for the trajectory of shells.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the trajectory of shells.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CORE_TRAJECTORY",& description="Controls the output of the trajectory of cores when the shell-model is used ",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="angstrom",error=error) + filename="",unit_str="angstrom") CALL add_format_keyword(keyword, print_key, pos=.TRUE.,& - description="Specifies the format of the output file for the trajectory of cores.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the trajectory of cores.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CELL",& description="Controls the output of the simulation cell. "//& "For later analysis of the trajectory it is recommendable that the "//& "frequency of printing is the same as the one used for the trajectory file.",& print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"VELOCITIES",& description="Controls the output of the velocities."//newline//& @@ -110,99 +106,99 @@ SUBROUTINE create_motion_print_section(section,error) "Having an atom with a mass m in AMU the kinetic energy 1/2mv^2 will be obtained "//& "in Hartree (i.e. au) multiplying by 911.447 .",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="bohr*au_t^-1",error=error) + filename="",unit_str="bohr*au_t^-1") CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Specifies the format of the output file for the velocities.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the velocities.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SHELL_VELOCITIES",& description="Controls the output of the velocities of shells when the shell model is used",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="bohr*au_t^-1",error=error) + filename="",unit_str="bohr*au_t^-1") CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Specifies the format of the output file for the velocities of shells.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the velocities of shells.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CORE_VELOCITIES",& description="controls the output of the velocities of cores when the shell model is used",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="bohr*au_t^-1",error=error) + filename="",unit_str="bohr*au_t^-1") CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Specifies the format of the output file for the velocities of cores.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the velocities of cores.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_structure_data_section(print_key, error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL create_structure_data_section(print_key) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FORCE_MIXING_LABELS",& description="Controls the output of the force mixing (FORCE_EVAL&QMMM&FORCE_MIXING) labels",& print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) + filename="") CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Specifies the format of the output file for the force mixing labels.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the force mixing labels.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FORCES",& description="Controls the output of the forces",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="hartree*bohr^-1",error=error) + filename="",unit_str="hartree*bohr^-1") CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Specifies the format of the output file for the forces.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the forces.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SHELL_FORCES",& description="controls the output of the forces on shells when shell-model is used",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="hartree*bohr^-1",error=error) + filename="",unit_str="hartree*bohr^-1") CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Specifies the format of the output file for the forces on shells.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the forces on shells.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CORE_FORCES",& description="controls the output of the forces on cores when shell-model is used",& print_level=high_print_level, common_iter_levels=1,& - filename="",unit_str="hartree*bohr^-1",error=error) + filename="",unit_str="hartree*bohr^-1") CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Specifies the format of the output file for the forces on cores.", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + description="Specifies the format of the output file for the forces on cores.") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"MIXED_ENERGIES",& description="Controls the output of the energies of the two"//& "regular FORCE_EVALS in the MIXED method"//& "printed is step,time,Etot,E_F1,E_F2,CONS_QNT",& print_level=low_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"STRESS",& description="Controls the output of the stress tensor",& print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART",& description="Controls the dumping of the restart file during runs. "//& "By default keeps a short history of three restarts. See also RESTART_HISTORY", & each_iter_names=s2a("MD"),each_iter_values=(/20/), & print_level=silent_print_level, common_iter_levels=1, & - add_last=add_last_numeric, filename="",error=error) + add_last=add_last_numeric, filename="") CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum number of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=3, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SPLIT_RESTART_FILE",& description="If specified selected input sections, which are growing with the "//& @@ -213,22 +209,21 @@ SUBROUTINE create_motion_print_section(section,error) "systems with a very large number of atoms",& usage="SPLIT_RESTART_FILE yes",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART_HISTORY",& description="Dumps unique restart files during the run keeping all of them."//& "Most useful if recovery is needed at a later point.",& print_level=low_print_level, common_iter_levels=0, & each_iter_names=s2a("MD","GEO_OPT","ROT_OPT"),each_iter_values=(/500,500,500/), & - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"TRANSLATION_VECTOR",& @@ -236,9 +231,9 @@ SUBROUTINE create_motion_print_section(section,error) " for postprocessing of QMMM trajectories in which the QM fragment is continuously"//& " centered in the QM box",& print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_motion_print_section @@ -249,16 +244,13 @@ END SUBROUTINE create_motion_print_section !> \param section will contain the pint section !> \param pos ... !> \param description ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 10.2008 [tlaino] ! ***************************************************************************** - SUBROUTINE add_format_keyword(keyword, section, pos, description, error) + SUBROUTINE add_format_keyword(keyword, section, pos, description) TYPE(keyword_type), POINTER :: keyword TYPE(section_type), POINTER :: section LOGICAL, INTENT(IN) :: pos CHARACTER(LEN=*), INTENT(IN) :: description - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_format_keyword', & routineP = moduleN//':'//routineN @@ -266,8 +258,8 @@ SUBROUTINE add_format_keyword(keyword, section, pos, description, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(keyword),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(keyword),cp_failure_level,routineP,failure) IF (pos) THEN @@ -283,33 +275,32 @@ SUBROUTINE add_format_keyword(keyword, section, pos, description, error) "the xy plane. This allows the reconstruction of scaled coordinates from the DCD data only.",& "Write the atomic information in PDB format to a formatted file",& "Mostly known as XYZ format, provides in a formatted file: element_symbol X Y Z",& - "Alias name for XMOL"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Alias name for XMOL")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE_OCCUP",& variants=(/"CHARGE_O"/),& description="Write the MM charges to the OCCUP field of the PDB file",& usage="CHARGE_OCCUP logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE_BETA",& variants=(/"CHARGE_B"/),& description="Write the MM charges to the BETA field of the PDB file",& usage="CHARGE_BETA logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE_EXTENDED",& description="Write the MM charges to the very last field of the PDB file (starting from column 81)",& usage="CHARGE_EXTENDED logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ELSE @@ -321,10 +312,9 @@ SUBROUTINE add_format_keyword(keyword, section, pos, description, error) enum_desc=s2a("Write only the coordinates X,Y,Z without element symbols to a formatted file",& "Write the coordinates (no element labels) and the cell information to a binary file",& "Mostly known as XYZ format, provides in a formatted file: element_symbol X Y Z",& - "Alias name for XMOL"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Alias name for XMOL")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END IF diff --git a/src/input_cp2k_mp2.F b/src/input_cp2k_mp2.F index da8b41dff9..b21d1d4ad7 100644 --- a/src/input_cp2k_mp2.F +++ b/src/input_cp2k_mp2.F @@ -53,13 +53,10 @@ MODULE input_cp2k_mp2 ! ***************************************************************************** !> \brief creates the input section for the mp2 part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MDB ! ***************************************************************************** - SUBROUTINE create_mp2_section(section,error) + SUBROUTINE create_mp2_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mp2_section', & routineP = moduleN//':'//routineN @@ -70,12 +67,11 @@ SUBROUTINE create_mp2_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"WF_CORRELATION",& description="Sets up the Wavefunction-based Correlation parameters if requested ",& n_keywords=8, n_subsections=6, repeats=.TRUE., & - citations=(/DelBen2012,DelBen2013,DelBen2015/),& - error=error) + citations=(/DelBen2012,DelBen2013,DelBen2015/)) NULLIFY(keyword, print_key, subsection) @@ -96,39 +92,36 @@ SUBROUTINE create_mp2_section(section,error) "Use the GPW approach to RI-RPA",& "Use the GPW approach to RI-SOS-Laplace-MP2",& "Optimize RIMP2 basis set"),& - default_i_val=mp2_method_direct, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=mp2_method_direct) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& name="MEMORY",& description="Maximum allowed total memory usage during MP2 methods [MiB].",& usage="MEMORY 1500 ",& - default_r_val=1.024E+3_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.024E+3_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& name="SCALE_S",& description="Scaling factor of the singlet energy component (opposite spin, OS). ",& usage="SCALE_S 1.0",& - default_r_val=1.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& name="SCALE_T",& description="Scaling factor of the triplet energy component (same spin, SS).",& usage="SCALE_T 1.0",& - default_r_val=1.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -138,10 +131,9 @@ SUBROUTINE create_mp2_section(section,error) "A smaller group size (for example the node size), might a better choice if the actual MP2 time is large "//& "compared to integral computation time. This is usually the case if the total number of processors is not too large.",& usage="GROUP_SIZE 32",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -151,10 +143,9 @@ SUBROUTINE create_mp2_section(section,error) "Default is (ROW_BLOCK=-1) is automatic. "//& "A proper choice can speedup the parallel matrix multiplication in the case of RI-RPA and RI-SOS-MP2-Laplace.",& usage="ROW_BLOCK 512",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -164,10 +155,9 @@ SUBROUTINE create_mp2_section(section,error) "Default is (COL_BLOCK=-1) is automatic. "//& "A proper choice can speedup the parallel matrix multiplication in the case of RI-RPA and RI-SOS-MP2-Laplace.",& usage="COL_BLOCK 512",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -176,49 +166,47 @@ SUBROUTINE create_mp2_section(section,error) description="Calculate the condition number of the (P|Q) matrix for the RI methods.",& usage="CALC_COND_NUM",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"MP2_INFO",& description="Controls the printing basic info about MP2 method", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_mp2_direct(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mp2_direct(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_wfc_gpw(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_wfc_gpw(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_ri_mp2(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ri_mp2(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_opt_ri_basis(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_opt_ri_basis(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_ri_rpa(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ri_rpa(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_ri_laplace(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ri_laplace(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_cphf(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cphf(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_mp2_potential(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mp2_potential(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_mp2_section @@ -226,11 +214,9 @@ END SUBROUTINE create_mp2_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_mp2_direct(section,error) + SUBROUTINE create_mp2_direct(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mp2_direct', & routineP = moduleN//':'//routineN @@ -240,11 +226,10 @@ SUBROUTINE create_mp2_direct(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"DIRECT_CANONICAL",& description="Parameters influencing the direct canonical method",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) @@ -254,10 +239,9 @@ SUBROUTINE create_mp2_direct(section,error) description="Send big messages between processes (useful for >48 processors).",& usage="BIG_SEND",& default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mp2_direct @@ -265,11 +249,9 @@ END SUBROUTINE create_mp2_direct ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_ri_mp2(section,error) + SUBROUTINE create_ri_mp2(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ri_mp2', & routineP = moduleN//':'//routineN @@ -279,12 +261,11 @@ SUBROUTINE create_ri_mp2(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"RI_MP2",& description="Parameters influencing the RI MP2 method",& n_keywords=3, n_subsections=0, repeats=.FALSE., & - citations=(/DelBen2013/),& - error=error) + citations=(/DelBen2013/)) NULLIFY(keyword) @@ -293,10 +274,9 @@ SUBROUTINE create_ri_mp2(section,error) description="Determines the blocking used for communication in RI-MP2. Larger BLOCK_SIZE "//& "reduces communication but requires more memory. The default (-1) is automatic.",& usage="BLOCK_SIZE 2",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_CANONICAL",& description="Threshold for discriminate if a given ij pairs "//& @@ -304,9 +284,9 @@ SUBROUTINE create_ri_mp2(section,error) "calculated with a canonical reformulation based "//& "on the occupied eigenvalues differences.",& usage="EPS_CANONICAL 1.0E-8",type_of_var=real_t,& - default_r_val=1.0E-7_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-7_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -316,10 +296,9 @@ SUBROUTINE create_ri_mp2(section,error) "case, the buffers are released by default. (Right now debugging only).",& usage="FREE_HFX_BUFFER",& default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ri_mp2 @@ -327,11 +306,9 @@ END SUBROUTINE create_ri_mp2 ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_opt_ri_basis(section,error) + SUBROUTINE create_opt_ri_basis(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_opt_ri_basis', & routineP = moduleN//':'//routineN @@ -341,14 +318,13 @@ SUBROUTINE create_opt_ri_basis(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"OPT_RI_BASIS",& description="Parameters influencing the optimization of the RI MP2 basis. "//& "Only exponents of non-contracted auxiliary basis can be optimized. "//& "An initial RI auxiliary basis has to be specified.",& n_keywords=6, n_subsections=0, repeats=.FALSE., & - citations=(/DelBen2013/),& - error=error) + citations=(/DelBen2013/)) NULLIFY(keyword) @@ -357,20 +333,18 @@ SUBROUTINE create_opt_ri_basis(section,error) description="Target accuracy in the relative deviation of the amplitudes calculated with "//& "and without RI approximation, (more details in Chem.Phys.Lett.294(1998)143).",& usage="DELTA_I_REL 1.0E-6_dp",& - default_r_val=1.0E-6_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DELTA_RI",& variants=(/"DRI"/),& description="Target accuracy in the absolute difference between the RI-MP2 "//& "and the exact MP2 energy, DRI=ABS(E_MP2-E_RI-MP2).",& usage="DELTA_RI 1.0E-6_dp",& - default_r_val=5.0E-6_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=5.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_DERIV",& variants=(/"EPS_NUM_DERIV"/),& @@ -379,28 +353,26 @@ SUBROUTINE create_opt_ri_basis(section,error) "The change in the exponent a_i employed for the numerical evaluation "//& "is defined as h_i=EPS_DERIV*a_i.",& usage="EPS_DERIV 1.0E-3_dp",& - default_r_val=1.0E-3_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-3_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER",& variants=(/"MAX_NUM_ITER"/),& description="Specifies the maximum number of steps in the RI basis optimization.",& usage="MAX_ITER 100",& - default_i_val=50,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_FUNC",& description="Specifies the number of function, for each angular momentum (s, p, d ...), "//& "employed in the automatically generated initial guess. "//& "This will be effective only if RI_AUX_BASIS_SET in the KIND section is not specified.",& usage="NUM_FUNC {number of s func.} {number of p func.} ...", & - n_var=-1, default_i_vals=(/-1/), type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, default_i_vals=(/-1/), type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="BASIS_SIZE",& description="Specifies the size of the auxiliary basis set automatically "//& @@ -409,9 +381,9 @@ SUBROUTINE create_opt_ri_basis(section,error) usage="BASIS_SIZE (MEDIUM|LARGE|VERY_LARGE)",& enum_c_vals=s2a("MEDIUM","LARGE","VERY_LARGE"),& enum_i_vals=(/0,1,2/),& - default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_opt_ri_basis @@ -419,11 +391,9 @@ END SUBROUTINE create_opt_ri_basis ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_ri_laplace(section,error) + SUBROUTINE create_ri_laplace(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ri_laplace', & routineP = moduleN//':'//routineN @@ -433,12 +403,11 @@ SUBROUTINE create_ri_laplace(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"RI_LAPLACE",& description="Parameters influencing the RI-SOS-MP2-Laplace method",& n_keywords=2, n_subsections=0, repeats=.FALSE., & - citations=(/DelBen2013/),& - error=error) + citations=(/DelBen2013/)) NULLIFY(keyword) @@ -446,10 +415,9 @@ SUBROUTINE create_ri_laplace(section,error) variants=(/"LAPLACE_NUM_QUAD_POINTS"/),& description="Number of quadrature points for the numerical integration in the RI-SOS-MP2-Laplace method.",& usage="QUADRATURE_POINTS 6",& - default_i_val=5,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIZE_INTEG_GROUP",& variants=(/"LAPLACE_GROUP_SIZE"/),& @@ -458,10 +426,9 @@ SUBROUTINE create_ri_laplace(section,error) "of GROUP_SIZE in the WF_CORRELATION section. The default (-1) "//& "is automatic.",& usage="SIZE_INTEG_GROUP 16",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ri_laplace @@ -469,11 +436,9 @@ END SUBROUTINE create_ri_laplace ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_ri_rpa(section,error) + SUBROUTINE create_ri_rpa(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ri_rpa', & routineP = moduleN//':'//routineN @@ -484,12 +449,11 @@ SUBROUTINE create_ri_rpa(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"RI_RPA",& description="Parameters influencing the RI RPA method",& n_keywords=2, n_subsections=1, repeats=.FALSE., & - citations=(/DelBen2013,DelBen2015/),& - error=error) + citations=(/DelBen2013,DelBen2015/)) NULLIFY(keyword,subsection) @@ -497,10 +461,9 @@ SUBROUTINE create_ri_rpa(section,error) variants=(/"RPA_NUM_QUAD_POINTS"/),& description="Number of quadrature points for the numerical integration in the RI-RPA method.",& usage="QUADRATURE_POINTS 60",& - default_i_val=40,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=40) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIZE_FREQ_INTEG_GROUP",& variants=(/"RPA_GROUP_SIZE"/),& @@ -509,10 +472,9 @@ SUBROUTINE create_ri_rpa(section,error) "of GROUP_SIZE in the WF_CORRELATION section. The default (-1) "//& "is automatic.",& usage="SIZE_FREQ_INTEG_GROUP 16",& - default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="MM_STYLE",& @@ -522,9 +484,9 @@ SUBROUTINE create_ri_rpa(section,error) enum_i_vals=(/wfc_mm_style_gemm,wfc_mm_style_syrk/),& enum_desc=s2a("Use pdgemm: more flops, maybe faster.",& "Use pdysrk: fewer flops, maybe slower."),& - default_i_val=wfc_mm_style_gemm, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=wfc_mm_style_gemm) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -534,10 +496,9 @@ SUBROUTINE create_ri_rpa(section,error) "Maximum number of quadrature point limited to 20.",& usage="MINIMAX_QUADRATURE",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -546,21 +507,20 @@ SUBROUTINE create_ri_rpa(section,error) description="Decide whether to perform an RI_G0W0 calculation on top of RI_ RPA.",& usage="RI_G0W0",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! here we generate a hfx subsection to use in the case EXX has to be computed after RPA - CALL create_hfx_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_hfx_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! here we generate a G0W0 subsection to use if G0W0 is desired - CALL create_ri_g0w0(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ri_g0w0(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_ri_rpa @@ -568,11 +528,9 @@ END SUBROUTINE create_ri_rpa ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_ri_g0w0(section,error) + SUBROUTINE create_ri_g0w0(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ri_g0w0', & routineP = moduleN//':'//routineN @@ -582,12 +540,11 @@ SUBROUTINE create_ri_g0w0(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"RI_G0W0",& description="Parameters influencing the RI-G0W0 method",& n_keywords=12, n_subsections=0, repeats=.FALSE., & - citations=(/DelBen2013/),& - error=error) + citations=(/DelBen2013/)) NULLIFY(keyword) @@ -600,10 +557,9 @@ SUBROUTINE create_ri_g0w0(section,error) "want to correct all occ. MOs, insert a number larger than the number "//& "of occ. MOs.",& usage="CORR_OCC 3",& - default_i_val=10,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORR_MOS_VIRT",& variants=(/"CORR_VIRT"/),& @@ -614,10 +570,9 @@ SUBROUTINE create_ri_g0w0(section,error) "want to correct all virt. MOs, insert a number larger than the number "//& "of virt. MOs.",& usage="CORR_VIRT 3",& - default_i_val=10,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALING",& variants=(/"A_SCALING"/),& @@ -626,38 +581,34 @@ SUBROUTINE create_ri_g0w0(section,error) "choice seems to be 0.2. The grid points of the frequency grid are "//& "just multiplied by SCALING: omega_j = omega_j*Scaling.",& usage="SCALING 0.2",& - default_r_val=0.2_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUMB_POLES",& description="Number of poles for the fitting. Usually, two poles are sufficient. ",& usage="NUMB_POLES 2",& - default_i_val=2,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OMEGA_MAX_FIT",& description="Determines fitting range for the self-energy on the imaginary axis: "//& "[0, OMEGA_MAX_FIT] for virt orbitals, [-OMEGA_MAX_FIT,0] for occ orbitals. "//& "Unit: Hartree. Default: 0.734996 H = 20 eV. ",& usage="OMEGA_MAX_FIT 0.5",& - default_r_val=0.734996_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.734996_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STOP_CRIT",& variants=(/"STOP_CRIT_1"/),& description="Convergence criterion for the fit. The fitting iteration terminates, if "//& "chi^2(n+1)/chi^2(n)-1 < STOP_CRIT.",& usage="STOP_CRIT 1.0E-7",& - default_r_val=1E-5_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1E-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRINT_FIT_ERROR",& variants=(/"FIT_ERROR"/),& @@ -665,28 +616,25 @@ SUBROUTINE create_ri_g0w0(section,error) "is very pessimistic (e.g. can be a factor of 10 too large).",& usage="FIT_ERROR",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER_FIT",& description="Maximum number of iterations for the Levenberg-Marquard fit.",& usage="MAX_ITER_FIT 10000",& - default_i_val=10000,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=10000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHECK_FIT",& description="If true, the self-energy on the imaginary axis and the fit are printed"//& "the file self_energy_of_MO__for_imaginary_frequency.",& usage="CHECK_FIT",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CROSSING_SEARCH",& description="Determines, how the self_energy is evaluated on the real axis.",& @@ -695,9 +643,9 @@ SUBROUTINE create_ri_g0w0(section,error) enum_i_vals=(/ri_rpa_g0w0_crossing_none,ri_rpa_g0w0_crossing_z_shot/),& enum_desc=s2a("Evaluate the correlation self-energy at the energy eigenvalue of SCF.",& "Calculate the derivative of Sigma and out of it Z. Then extrapolate using Z"),& - default_i_val=ri_rpa_g0w0_crossing_z_shot, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=ri_rpa_g0w0_crossing_z_shot) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FERMI_LEVEL_OFFSET",& description="Fermi level for occ. orbitals: e_HOMO + FERMI_LEVEL_OFFSET; "//& @@ -705,59 +653,54 @@ SUBROUTINE create_ri_g0w0(section,error) "In case e_homo + FERMI_LEVEL_OFFSET < e_lumo - FERMI_LEVEL_OFFSET,"//& "we set Fermi level = (e_HOMO+e_LUMO)/2",& usage="FERMI_LEVEL_OFFSET 1.0E-2",& - default_r_val=2.0E-2_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=2.0E-2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CUTOFF_RADIUS",& description="Cutoff radius for the truncated Coulomb potential in GW in Angstrom. "//& "The cell length seems to be a good choice for the truncation.",& usage="CUTOFF_RADIUS 6.0",& default_r_val=10.0_dp,& - unit_str="angstrom",error=error) + unit_str="angstrom") - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRUNCATION",& description="If true, the Coulomb potential is truncated. Recommended for periodic"//& "systems.",& usage="TRUNCATION",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EV_SC_ITER",& description="Number of iterations for eigenvalue self-consistency cycle. The "//& "computational effort of RPA and GW scales linearly with this number.",& usage="EV_SC_ITER 3",& - default_i_val=1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HF_LIKE_EV_START",& description="If true, take as input for GW/RPA corrected HF-like eigenvalues according "//& "to PRB 83, 115103 (2011), Sec. IV.",& usage="HF_LIKE_EV_START",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRINT_GW_DETAILS",& description="If true, prints additional information on the quasiparticle energies.",& usage="PRINT_GW_DETAILS",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ri_g0w0 @@ -765,11 +708,9 @@ END SUBROUTINE create_ri_g0w0 ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_wfc_gpw(section,error) + SUBROUTINE create_wfc_gpw(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_wfc_gpw', & routineP = moduleN//':'//routineN @@ -779,50 +720,48 @@ SUBROUTINE create_wfc_gpw(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"WFC_GPW",& description="Parameters for the GPW approach in Wavefunction-based Correlation methods",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="EPS_GRID",& description="Determines a threshold for the GPW based integration",& usage="EPS_GRID 1.0E-9 ",type_of_var=real_t,& - default_r_val=1.0E-8_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-8_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_FILTER",& description="Determines a threshold for the DBCSR based multiply (usually 10 times smaller than EPS_GRID).",& usage="EPS_FILTER 1.0E-10 ",type_of_var=real_t,& - default_r_val=1.0E-9_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-9_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CUTOFF",& description="The cutoff of the finest grid level in the MP2 gpw integration.",& usage="CUTOFF 300",type_of_var=real_t,& - default_r_val=300.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=300.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REL_CUTOFF",& variants=(/"RELATIVE_CUTOFF"/),& description="Determines the grid at which a Gaussian is mapped.",& usage="REL_CUTOFF 50",type_of_var=real_t,& - default_r_val=50.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=50.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MULTIPOLE_TWO_CENT_INT",& description="Use fast algorithm to calculate two-center RI integrals based on multipole expansion",& usage="MULTIPOLE_TWO_CENT_INT",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRINT_LEVEL",& variants=(/"IOLEVEL"/),& @@ -834,9 +773,9 @@ SUBROUTINE create_wfc_gpw(section,error) "Little output", "Quite some output", "Lots of output",& "Everything is written out, useful for debugging purposes only"),& enum_i_vals=(/silent_print_level,low_print_level,medium_print_level,& - high_print_level,debug_print_level/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + high_print_level,debug_print_level/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_wfc_gpw @@ -844,11 +783,9 @@ END SUBROUTINE create_wfc_gpw ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_cphf(section,error) + SUBROUTINE create_cphf(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_cphf', & routineP = moduleN//':'//routineN @@ -858,12 +795,11 @@ SUBROUTINE create_cphf(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"CPHF",& description="Parameters influencing the solution of the Z-vector equations in MP2 gradients calculations.",& n_keywords=2, n_subsections=0, repeats=.FALSE., & - citations=(/DelBen2013/),& - error=error) + citations=(/DelBen2013/)) NULLIFY(keyword) @@ -871,19 +807,18 @@ SUBROUTINE create_cphf(section,error) variants=(/"MAX_NUM_ITER"/),& description="Maximum number of iterations allowed for the solution of the Z-vector equations.",& usage="MAX_ITER 50",& - default_i_val=30,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=30) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_CONV",& description="Convergence threshold for the solution of the Z-vector equations. "//& "The Z-vector equations have the form of a linear system of equations Ax=b, "//& "convergence is achieved when |Ax-b|<=EPS_CONV.",& usage="EPS_CONV 1.0E-6",type_of_var=real_t,& - default_r_val=1.0E-4_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-4_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_cphf @@ -891,11 +826,9 @@ END SUBROUTINE create_cphf ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_mp2_potential(section,error) + SUBROUTINE create_mp2_potential(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mp2_potential', & routineP = moduleN//':'//routineN @@ -905,11 +838,10 @@ SUBROUTINE create_mp2_potential(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"INTERACTION_POTENTIAL",& description="Parameters the interaction potential in computing the biel integrals",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(& @@ -928,18 +860,18 @@ SUBROUTINE create_mp2_potential(section,error) "(6-3*s - 4*n + n^2)*(x - Rc)^4/(Rc^5*(n^4 - 4*n^3 + 6*n^2 - 4*n + 1)) "//& "for Rc < x ≤ n*Rc (4th order polynomial)"//& "
  • 0 for x > n*Rc
    • "),& - default_i_val=do_hfx_potential_coulomb, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_hfx_potential_coulomb) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRUNCATION_RADIUS",& description="Determines truncation radius for the truncated TShPSC potential. "//& "Only valid when doing truncated calculation",& usage="TRUNCATION_RADIUS 10.0",type_of_var=real_t,& default_r_val=10.0_dp,& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -947,10 +879,9 @@ SUBROUTINE create_mp2_potential(section,error) description="Location of the file TShPSC.dat that contains the data for the "//& "evaluation of the TShPSC G0 ",& usage="TShPSC_DATA t_sh_p_s_c.dat",& - default_c_val="t_sh_p_s_c.dat",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="t_sh_p_s_c.dat") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mp2_potential diff --git a/src/input_cp2k_neb.F b/src/input_cp2k_neb.F index 27f02df79d..182235b5b5 100644 --- a/src/input_cp2k_neb.F +++ b/src/input_cp2k_neb.F @@ -55,13 +55,10 @@ MODULE input_cp2k_neb ! ***************************************************************************** !> \brief creates the section for a BAND run !> \param section will contain the pint section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 09.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE create_band_section(section,error) + SUBROUTINE create_band_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_band_section', & routineP = moduleN//':'//routineN @@ -72,20 +69,19 @@ SUBROUTINE create_band_section(section,error) subsubsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="band",& description="The section that controls a BAND run",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/Elber1987,Jonsson1998,Jonsson2000_1,Jonsson2000_2,Wales2004/),& - error=error) + citations=(/Elber1987,Jonsson1998,Jonsson2000_1,Jonsson2000_2,Wales2004/)) NULLIFY(keyword, print_key, subsection, subsubsection) CALL keyword_create(keyword, name="NPROC_REP",& description="Specify the number of processors to be used per replica "//& "environment (for parallel runs)",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROC_DIST_TYPE",& description="Specify the topology of the mapping of processors into replicas.",& @@ -95,9 +91,9 @@ SUBROUTINE create_band_section(section,error) enum_desc=s2a( "Interleaved distribution",& "Blocked distribution"),& enum_i_vals=(/do_rep_interleaved,do_rep_blocked/),& - default_i_val=do_rep_blocked, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_rep_blocked) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BAND_TYPE",& description="Specifies the type of BAND calculation",& @@ -115,22 +111,21 @@ SUBROUTINE create_band_section(section,error) "Doubly nudged elastic band",& "String Method",& "Elastic band (Hamiltonian formulation)"),& - enum_i_vals=(/do_b_neb,do_it_neb,do_ci_neb,do_d_neb,do_sm,do_eb/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/do_b_neb,do_it_neb,do_ci_neb,do_d_neb,do_sm,do_eb/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUMBER_OF_REPLICA",& description="Specify the number of Replica to use in the BAND",& - default_i_val=10, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_COLVARS",& description="Uses a version of the band scheme projected in a subspace of colvars.",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POT_TYPE",& description="Specifies the type of potential used in the BAND calculation",& @@ -142,193 +137,187 @@ SUBROUTINE create_band_section(section,error) enum_desc=s2a( "Full potential (no projections in a subspace of colvars)",& "Free energy (requires a projections in a subspace of colvars)",& "Minimum energy (requires a projections in a subspace of colvars)"),& - enum_i_vals=(/pot_neb_full,pot_neb_fe,pot_neb_me/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/pot_neb_full,pot_neb_fe,pot_neb_me/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROTATE_FRAMES",& description="Compute at each BAND step the RMSD and rotate the frames in order"//& " to minimize it.",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALIGN_FRAMES",& description="Enables the alignment of the frames at the beginning of a BAND calculation. "//& "This keyword does not affect the rotation of the replicas during a BAND calculation.",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K_SPRING",& variants=(/"K"/),& description="Specify the value of the spring constant",& - default_r_val=0.02_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.02_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Convergence_control CALL section_create(subsection,name="CONVERGENCE_CONTROL",& description="Setup parameters to control the convergence criteria for BAND",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="MAX_DR",& description="Tolerance on the maximum value of the displacement on the BAND.",& usage="MAX_DR {real}",& - default_r_val=0.0002_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0002_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_FORCE",& description="Tolerance on the maximum value of Forces on the BAND.",& usage="MAX_FORCE {real}",& - default_r_val=0.00045_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.00045_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMS_DR",& description="Tolerance on RMS displacements on the BAND.",& usage="RMS_DR {real}",& - default_r_val=0.0001_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0001_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMS_FORCE",& description="Tolerance on RMS Forces on the BAND.",& usage="RMS_FORCE {real}",& - default_r_val=0.00030_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + default_r_val=0.00030_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) NULLIFY(subsection, subsubsection) ! CI-NEB section CALL section_create(subsection,name="CI_NEB",& description="Controls parameters for CI-NEB type calculation only.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="NSTEPS_IT",& description="Specify the number of steps of IT-NEB to perform before "//& "switching on the CI algorithm",& - default_i_val=5, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + default_i_val=5) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! String Method section CALL section_create(subsection,name="STRING_METHOD",& description="Controls parameters for String Method type calculation only.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="SPLINE_ORDER",& description="Specify the oder of the spline used in the String Method.",& - default_i_val=1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SMOOTHING",& description="Smoothing parameter for the reparametrization of the frames.",& - default_r_val=0.2_dp, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.2_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! Optimization section CALL section_create(subsection,name="optimize_band",& description="Specify the optimization method for the band",& - repeats=.TRUE., error=error) - CALL create_opt_band_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + repeats=.TRUE.) + CALL create_opt_band_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! replica section: to specify coordinates and velocities (possibly) of the ! different replica used in the BAND CALL section_create(subsection,name="replica",& description="Specify coordinates and velocities (possibly) of the replica",& - repeats=.TRUE., error=error) + repeats=.TRUE.) ! Colvar CALL keyword_create(keyword, name="COLLECTIVE",& description="Specifies the value of the collective variables used in the projected"//& " BAND method. The order of the values is the order of the COLLECTIVE section in the"//& " constraints/restraints section",& usage="COLLECTIVE {real} .. {real}",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) ! Coordinates read through an external file CALL keyword_create(keyword, name="COORD_FILE_NAME",& description="Name of the xyz file with coordinates (alternative to &COORD section)",& usage="COORD_FILE_NAME ",& - default_lc_val="",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) ! Coordinates and velocities - CALL create_coord_section(subsubsection,"BAND",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) - CALL create_velocity_section(subsubsection,"BAND",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + CALL create_coord_section(subsubsection,"BAND") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) + CALL create_velocity_section(subsubsection,"BAND") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! Print key section CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing basic info about the BAND run", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") CALL keyword_create(keyword, name="INITIAL_CONFIGURATION_INFO",& description="Print information for the setup of the initial configuration.",& usage="INITIAL_CONFIGURATION_INFO ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"convergence_info",& description="Controls the printing of the convergence criteria during a BAND run", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"replica_info",& description="Controls the printing of each replica info during a BAND run", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ENERGY",& description="Controls the printing of the ENER file in a BAND run", & print_level=low_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"BANNER",& description="Controls the printing of the BAND banner", & print_level=low_print_level, common_iter_levels=1,& - filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_band_section ! ***************************************************************************** !> \brief creates the optimization section for a BAND run !> \param section will contain the pint section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino 02.2007 [tlaino] ! ***************************************************************************** - SUBROUTINE create_opt_band_section(section,error) + SUBROUTINE create_opt_band_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_opt_band_section', & routineP = moduleN//':'//routineN @@ -339,7 +328,7 @@ SUBROUTINE create_opt_band_section(section,error) subsubsection failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword, print_key, subsection, subsubsection) CALL keyword_create(keyword, name="OPT_TYPE",& @@ -350,27 +339,26 @@ SUBROUTINE create_opt_band_section(section,error) "DIIS"),& enum_desc=s2a( "Molecular dynamics-based optimizer",& "Coupled steepest descent / direct inversion in the iterative subspace"),& - enum_i_vals=(/band_md_opt,band_diis_opt/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/band_md_opt,band_diis_opt/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OPTIMIZE_END_POINTS",& description="Performs also an optimization of the end points of the band.",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! MD optimization section CALL section_create(subsection,name="MD",& description="Activate the MD based optimization procedure for BAND",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="MAX_STEPS",& description="Specify the maximum number of MD steps",& - default_i_val=100, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=100) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(& keyword=keyword,& @@ -378,154 +366,147 @@ SUBROUTINE create_opt_band_section(section,error) description="The length of an integration step",& usage="timestep 1.0",& default_r_val=cp_unit_to_cp2k(value=0.5_dp,& - unit_str="fs",& - error=error),& - unit_str="fs",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="fs"),& + unit_str="fs") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE",& description="Specify the initial temperature",& default_r_val=cp_unit_to_cp2k(value=0.0_dp,& - unit_str="K",& - error=error),& - unit_str="K",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="K"),& + unit_str="K") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) ! Temp_control CALL section_create(subsubsection,name="TEMP_CONTROL",& description="Setup parameters to control the temperature during a BAND MD run.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="TEMPERATURE",& description="Specify the target temperature",& - type_of_var=real_t,unit_str="K",error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,unit_str="K") + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMP_TOL",& description="Specify the tolerance on the temperature for rescaling",& default_r_val=cp_unit_to_cp2k(value=0.0_dp,& - unit_str="K",& - error=error),& - unit_str="K",& - error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="K"),& + unit_str="K") + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMP_TOL_STEPS",& description="Specify the number of steps to apply a temperature control",& - default_i_val=0, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection, subsubsection, error=error) - CALL section_release(subsubsection,error=error) + default_i_val=0) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection, subsubsection) + CALL section_release(subsubsection) ! Vel_control CALL section_create(subsubsection,name="VEL_CONTROL",& description="Setup parameters to control the velocity during a BAND MD run.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="ANNEALING",& description="Specify the annealing coefficient",& - default_r_val=1.0_dp, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROJ_VELOCITY_VERLET",& description="Uses a Projected Velocity Verlet instead of a normal Velocity Verlet."//& " Every time the cosine between velocities and forces is < 0 velocities are"//& " zeroed.",& usage="PROJ_VELOCITY_VERLET ",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SD_LIKE",& description="Zeros velocity at each MD step emulating a steepest descent like"//& "(SD_LIKE) approach",& usage="SD_LIKE ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection, subsubsection, error=error) - CALL section_release(subsubsection,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection, subsubsection) + CALL section_release(subsubsection) ! End of MD - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! DIIS optimization section CALL section_create(subsection,name="DIIS",& description="Activate the DIIS based optimization procedure for BAND",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="MAX_SD_STEPS",& description="Specify the maximum number of SD steps to perform"//& " before switching on DIIS (the minimum number will always be equal to N_DIIS).",& - default_i_val=1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_STEPS",& description="Specify the maximum number of optimization steps",& - default_i_val=100, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=100) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_DIIS",& variants=(/"NDIIS"/),& description="Number of history vectors to be used with DIIS",& usage="N_DIIS 4",& - default_i_val=7,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=7) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEPSIZE",& description="Initial stepsize used for the line search, sometimes this parameter"//& "can be reduced to stablize DIIS",& usage="STEPSIZE ",& - default_r_val=1.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_STEPSIZE",& description="Maximum stepsize used for the line search, sometimes this parameter"//& "can be reduced to stablize the LS for particularly difficult initial geometries",& usage="MAX_STEPSIZE ",& - default_r_val=2.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=2.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NP_LS",& description="Number of points used in the line search SD.",& usage="NP_LS ",& - default_i_val=2,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NO_LS",& description="Does not perform LS during SD. Useful in combination with a proper STEPSIZE"//& " for particularly out of equilibrium starting geometries.",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHECK_DIIS",& description="Performes a series of checks on the DIIS solution in order to accept the DIIS step."//& " If set to .FALSE. the only check performed is that the angle between the DIIS solution and the"//& " reference vector is less than Pi/2. Can be useful if many DIIS steps are rejected.",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"diis_info",& description="Controls the printing of DIIS info during a BAND run", & - print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_opt_band_section diff --git a/src/input_cp2k_poisson.F b/src/input_cp2k_poisson.F index 495c8f6e6e..e3df9a28e7 100644 --- a/src/input_cp2k_poisson.F +++ b/src/input_cp2k_poisson.F @@ -87,13 +87,10 @@ MODULE input_cp2k_poisson ! ***************************************************************************** !> \brief Creates the Poisson section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_poisson_section(section,error) + SUBROUTINE create_poisson_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_poisson_section', & routineP = moduleN//':'//routineN @@ -104,11 +101,10 @@ SUBROUTINE create_poisson_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="poisson",& description="Sets up the poisson resolutor.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="POISSON_SOLVER",& @@ -119,9 +115,9 @@ SUBROUTINE create_poisson_section(section,error) enum_i_vals=(/ pw_poisson_periodic, pw_poisson_analytic, pw_poisson_mt, pw_poisson_multipole, & pw_poisson_wavelet, pw_poisson_implicit/),& citations=(/Blochl1995,Martyna1999,Genovese2006,Genovese2007/),& - default_i_val=pw_poisson_periodic, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=pw_poisson_periodic) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PERIODIC",& description="Specify the directions on wich apply PBC. Important notice, "//& @@ -133,41 +129,38 @@ SUBROUTINE create_poisson_section(section,error) enum_i_vals=(/ use_perd_x, use_perd_y, use_perd_z,& use_perd_xy, use_perd_xz, use_perd_yz,& use_perd_xyz, use_perd_none /),& - default_i_val=use_perd_xyz, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=use_perd_xyz) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_mt_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mt_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_wavelet_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_wavelet_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_multipole_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_multipole_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_ewald_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_ewald_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_implicit_ps_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_implicit_ps_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_poisson_section ! ***************************************************************************** !> \brief Section to set-up parameters for decoupling using the Bloechl scheme !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_multipole_section(section,error) + SUBROUTINE create_multipole_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_multipole_section', & routineP = moduleN//':'//routineN @@ -178,60 +171,56 @@ SUBROUTINE create_multipole_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MULTIPOLE",& description="This section is used to set up the decoupling of QM periodic images with "//& "the use of density derived atomic point charges.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="RCUT",& description="Real space cutoff for the Ewald sum.",& usage="RCUT {real}", n_var=1, type_of_var=real_t,& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EWALD_PRECISION",& description="Precision achieved in the Ewald sum.",& usage="EWALD_PRECISION {real}", n_var=1, type_of_var=real_t,& - unit_str="hartree",default_r_val=1.0E-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="hartree",default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ANALYTICAL_GTERM",& description="Evaluates the Gterm in the Ewald Scheme analytically instead of using Splines.",& usage="ANALYTICAL_GTERM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NGRIDS",& description="Specifies the number of grid points used for the Interpolation of the G-space term",& - usage="NGRIDS ",n_var=3,default_i_vals=(/50,50,50/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NGRIDS ",n_var=3,default_i_vals=(/50,50,50/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_gspace_interp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_gspace_interp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(subsection,"check_spline",& description="Controls the checking of the G-space term Spline Interpolation.",& - print_level=medium_print_level,filename="GSpace-SplInterp",& - error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=medium_print_level,filename="GSpace-SplInterp") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(subsection,"program_run_info",& description="Controls the printing of basic information during the run", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_multipole_section @@ -239,13 +228,10 @@ END SUBROUTINE create_multipole_section ! ***************************************************************************** !> \brief Creates the Martyna-Tuckerman section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_mt_section(section,error) + SUBROUTINE create_mt_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mt_section', & routineP = moduleN//':'//routineN @@ -255,46 +241,42 @@ SUBROUTINE create_mt_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="mt",& description="Sets up parameters of Martyna-Tuckerman poisson solver. "//& "Note that exact results are only guaranteed if the unit cell is "//& "twice as large as charge density (and serious artefacts can result "//& "if the cell is much smaller).",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/Martyna1999/),& - error=error) + citations=(/Martyna1999/)) NULLIFY(keyword) CALL keyword_create(keyword, name="ALPHA",& description="Convergence parameter ALPHA*RMIN. Default value 7.0",& usage="ALPHA real",& - n_var=1,default_r_val=7.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_r_val=7.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REL_CUTOFF",& description="Specify the multiplicative factor for the CUTOFF keyword in MULTI_GRID "//& " section. The result gives the cutoff at which the 1/r non-periodic FFT3D is evaluated."//& "Default is 2.0",& usage="REL_CUTOFF real",& - n_var=1,default_r_val=2.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_r_val=2.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mt_section ! ***************************************************************************** !> \brief ... !> \param section will contain the ewald section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE create_ewald_section(section,error) +SUBROUTINE create_ewald_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ewald_section', & routineP = moduleN//':'//routineN @@ -305,12 +287,11 @@ SUBROUTINE create_ewald_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ewald",& description="Ewald parameters controlling electrostatic only for CLASSICAL MM.",& n_keywords=7, n_subsections=0, repeats=.FALSE., & - citations=(/Ewald1921,Darden1993,Essmann1995,Toukmaji1996,Laino2008/),& - error=error) + citations=(/Ewald1921,Darden1993,Essmann1995,Toukmaji1996,Laino2008/)) NULLIFY(keyword,print_key,subsection) CALL keyword_create(keyword, name="EWALD_TYPE",& @@ -329,10 +310,9 @@ SUBROUTINE create_ewald_section(section,error) enum_desc=s2a("NONE standard real-space coulomb potential is computed together with the non-bonded contributions",& "EWALD is the standard non-fft based ewald",& "PME is the particle mesh using fft interpolation",& - "SPME is the smooth particle mesh using beta-Euler splines (recommended)"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "SPME is the smooth particle mesh using beta-Euler splines (recommended)")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EWALD_ACCURACY",& description="Expected accuracy in the Ewald sum. This number affects only the calculation of "//& @@ -341,28 +321,28 @@ SUBROUTINE create_ewald_section(section,error) "value employed to compute the EWALD real-space term). This keyword has no "//& "effect on the reciprocal space term (which can be tuned independently).",& usage="EWALD_ACCURACY {real}", n_var=1, type_of_var=real_t,& - unit_str="hartree",default_r_val=1.0E-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="hartree",default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Explicitly provide the real-space cutoff of the ewald summation (EWALD|PME|SPME). "//& "If present, overwrites the estimate of EWALD_ACCURACY and may affect the "//& "construction of the neighbor lists for non-bonded terms (in FIST), if the value "//& "specified is larger than the cutoff for non-bonded interactions.",& - usage="RCUT 5.0", n_var=1, type_of_var=real_t, unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RCUT 5.0", n_var=1, type_of_var=real_t, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="alpha",& description="alpha parameter associated with Ewald (EWALD|PME|SPME). "//& "Recommended for small systems is is alpha = 3.5 / r_cut. "//& "Tuning alpha, r_cut and gmax is needed to obtain O(N**1.5) scaling for ewald.",& usage="alpha .30",& - default_r_val=cp_unit_to_cp2k(value=0.35_dp,unit_str="angstrom^-1", error=error), & - unit_str='angstrom^-1',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=0.35_dp,unit_str="angstrom^-1"), & + unit_str='angstrom^-1') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="gmax",& description="number of grid points (SPME and EWALD). If a single number is specified,"// & @@ -370,45 +350,44 @@ SUBROUTINE create_ewald_section(section,error) "If three numbers are given, each direction can have a different number of points."// & "The number of points needs to be FFTable (which depends on the library used) and odd for EWALD."// & "The optimal number depends e.g. on alpha and the size of the cell. 1 point per Angstrom is common.",& - usage="gmax 25 25 25", n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="gmax 25 25 25", n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ns_max",& description="number of grid points on small mesh (PME only), should be odd.",& - usage="ns_max 11", default_i_val=11,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ns_max 11", default_i_val=11) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="o_spline",& description="order of the beta-Euler spline (SPME only)",& - usage="o_spline 6", default_i_val=6,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="o_spline 6", default_i_val=6) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="epsilon",& description="tolerance of gaussians for fft interpolation (PME only)",& - usage="epsilon 1e-6", default_r_val=1.e-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="epsilon 1e-6", default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_rsgrid_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_rsgrid_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) CALL section_create(subsection,name="MULTIPOLES",& description="Enables the use of multipoles in the treatment of the electrostatics.",& n_keywords=0, n_subsections=1, repeats=.FALSE., & - citations=(/Aguado2003,Laino2008/), error=error) + citations=(/Aguado2003,Laino2008/)) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Controls the activation of the Multipoles",& - usage="&MULTIPOLES T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="&MULTIPOLES T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_MULTIPOLE_EXPANSION",& description="Specify the maximum level of multipoles expansion used "//& @@ -420,9 +399,9 @@ SUBROUTINE create_ewald_section(section,error) "Use up to the Dipole term",& "Use up to the Quadrupole term"),& enum_i_vals=(/ do_multipole_none, do_multipole_charge, do_multipole_dipole,& - do_multipole_quadrupole/), type_of_var=enum_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + do_multipole_quadrupole/), type_of_var=enum_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POL_SCF", & description="Specify the method to obtain self consistent induced "// & @@ -436,56 +415,51 @@ SUBROUTINE create_ewald_section(section,error) "method does not support non-linear polarization "//& "but is sometimes faster."), & enum_i_vals=(/ do_fist_pol_none, do_fist_pol_sc, do_fist_pol_cg/), & - type_of_var=enum_t, default_i_val=do_fist_pol_none, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=enum_t, default_i_val=do_fist_pol_none) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_IPOL_ITER",& description="Specify the maximum number of iterations for induced "//& "dipoles",& usage="MAX_IPOL_ITER {int}", type_of_var=integer_t,& - n_var=1, default_i_val=0,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, default_i_val=0) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_POL",& description="Specify the rmsd threshold for the derivatives "//& "of the energy towards the Cartesian dipoles components",& usage="EPS_POL {real}", type_of_var=real_t,& - n_var=1, default_r_val=0.5e-07_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, default_r_val=0.5e-07_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="Controls printing of Ewald properties",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="controls the printing of ewald setup",& - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_ewald_section ! ***************************************************************************** !> \brief creates the interpolation section for the periodic QM/MM !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_gspace_interp_section(section,error) + SUBROUTINE create_gspace_interp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gspace_interp_section', & routineP = moduleN//':'//routineN @@ -496,11 +470,10 @@ SUBROUTINE create_gspace_interp_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="interpolator",& description="controls the interpolation for the G-space term",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, print_key) @@ -512,10 +485,9 @@ SUBROUTINE create_gspace_interp_section(section,error) enum_c_vals=s2a( "copy","spl3_nopbc_aint1","spl3_nopbc_precond1",& "spl3_nopbc_aint2","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_1,& - precond_spl3_aint2, precond_spl3_2, precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_aint2, precond_spl3_2, precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="precond",& description="The preconditioner used"//& @@ -525,29 +497,28 @@ SUBROUTINE create_gspace_interp_section(section,error) enum_c_vals=s2a("copy","spl3_nopbc_aint1","spl3_nopbc_precond1",& "spl3_nopbc_aint2","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_1,& - precond_spl3_aint2, precond_spl3_2, precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_aint2, precond_spl3_2, precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_x",& description="accuracy on the solution for spline3 the interpolators",& - usage="eps_x 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_x 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_r",& description="accuracy on the residual for spline3 the interpolators",& - usage="eps_r 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_r 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="max_iter",& variants=(/'maxiter'/),& description="the maximum number of iterations",& - usage="max_iter 200", default_i_val=100, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="max_iter 200", default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"conv_info",& @@ -555,24 +526,21 @@ SUBROUTINE create_gspace_interp_section(section,error) " of the spline methods should be printed", & print_level=medium_print_level,each_iter_names=s2a("SPLINE_FIND_COEFFS"),& each_iter_values=(/10/),filename="__STD_OUT__",& - add_last=add_last_numeric,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_gspace_interp_section ! ***************************************************************************** !> \brief Creates the wavelet section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff !> \note !> this approach is based on the development of T. Deutsch and S. Goedecker ! ***************************************************************************** - SUBROUTINE create_wavelet_section(section,error) + SUBROUTINE create_wavelet_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_wavelet_section', & routineP = moduleN//':'//routineN @@ -582,7 +550,7 @@ SUBROUTINE create_wavelet_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="wavelet",& description="Sets up parameters of wavelet based poisson solver."//& "This solver allows for non-periodic (PERIODIC NONE) boundary conditions and slab-boundary conditions "//& @@ -590,8 +558,7 @@ SUBROUTINE create_wavelet_section(section,error) "It does not require very large unit cells, only that the density goes to zero on the faces of the cell."//& "The use of PREFERRED_FFT_LIBRARY FFTSG is required",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/Genovese2006,Genovese2007/),& - error=error) + citations=(/Genovese2006,Genovese2007/)) NULLIFY(keyword) @@ -600,22 +567,19 @@ SUBROUTINE create_wavelet_section(section,error) "and the convergence with respect to cutoff depends on the selected scaling functions."//& "Possible values are 8,14,16,20,24,30,40,50,60,100 ",& usage="SCF_TYPE integer",& - n_var=1,default_i_val=40,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_i_val=40) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_wavelet_section ! ***************************************************************************** !> \brief Creates the section for the implicit (generalized) poisson solver !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_implicit_ps_section(section,error) + SUBROUTINE create_implicit_ps_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_implicit_ps_section', & routineP = moduleN//':'//routineN @@ -626,21 +590,20 @@ SUBROUTINE create_implicit_ps_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="IMPLICIT",& description="Parameters for the implicit (generalized) Poisson solver.",& - n_keywords=4, n_subsections=2, repeats=.FALSE., & - error=error) + n_keywords=4, n_subsections=2, repeats=.FALSE.) NULLIFY(subsection, keyword) - CALL create_dielectric_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_dielectric_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_dbc_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_dbc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="BOUNDARY_CONDITIONS", & enum_c_vals=s2a( 'PERIODIC', 'MIXED', 'MIXED_PERIODIC', 'NEUMANN' ), & @@ -649,33 +612,33 @@ SUBROUTINE create_implicit_ps_section(section,error) enum_i_vals=(/ PERIODIC_BC, MIXED_BC, MIXED_PERIODIC_BC, NEUMANN_BC /), & description="Specifies the type of boundary conditions. Dirichlet=fixed value, Neumann=zero normal deriv. "//& "Mixed boundaries essentially requires FFTW3 so that all grid sizes are FFT-able.", & - usage="BOUNDARY_CONDITIONS ", default_i_val=PERIODIC_BC, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="BOUNDARY_CONDITIONS ", default_i_val=PERIODIC_BC) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ZERO_INITIAL_GUESS", & description="Whether or not to use zero potential as initial guess.", & - usage="ZERO_INITIAL_GUESS ", default_l_val=.FALSE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="ZERO_INITIAL_GUESS ", default_l_val=.FALSE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="max_iter", & description="Maximum number of iterations.", & - usage="max_iter ", default_i_val=30, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="max_iter ", default_i_val=30) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="tol", & description="Stopping tolerance.", & - usage="tol ", default_r_val=1.0E-8_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="tol ", default_r_val=1.0E-8_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OR_PARAMETER", variants=s2a('omega'), & description="Over-relaxation parameter (large epsilon requires smaller omega ~0.1).", & - usage="OR_PARAMETER ", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="OR_PARAMETER ", default_r_val=1.0_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_implicit_ps_section @@ -684,13 +647,10 @@ END SUBROUTINE create_implicit_ps_section !> The dielectric constant is defined as a function of electronic density. !> [see O. Andreussi, I. Dabo, and N. Marzari, J. Chem. Phys., 136, 064102(2012)] !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_dielectric_section(section,error) + SUBROUTINE create_dielectric_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_dielectric_section', & routineP = moduleN//':'//routineN @@ -701,11 +661,10 @@ SUBROUTINE create_dielectric_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="DIELECTRIC", & description="Parameters for the dielectric constant function.", & - n_keywords=6, n_subsections=2, repeats=.FALSE., & - error=error) + n_keywords=6, n_subsections=2, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -713,9 +672,9 @@ SUBROUTINE create_dielectric_section(section,error) description="Avoid spurious values of the dielectric constant at the ionic core for pseudopotentials "// & "where the electron density goes to zero at the core (e.g. GTH). "// & "The correction is based on rho_core.", & - usage="DIELECTRIC_CORE_CORRECTION ", default_l_val=.TRUE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="DIELECTRIC_CORE_CORRECTION ", default_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIELECTRIC_FUNCTION_TYPE", & enum_c_vals=s2a('density_dependent', 'spatially_dependent', 'spatially_rho_dependent'), & @@ -726,27 +685,27 @@ SUBROUTINE create_dielectric_section(section,error) "Various regions with different dielectric constants. The dielectric constant decays to 1.0, "//& "wherever the electron density is present."),& description="Preferred type for the dielectric constant function.", & - usage="DIELECTRIC_FUNCTION_TYPE ", default_i_val=rho_dependent, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="DIELECTRIC_FUNCTION_TYPE ", default_i_val=rho_dependent) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="dielectric_constant", variants=s2a('epsilon'), & description="Dielectric constant in the bulk of the solvent.", & - usage="dielectric_constant ", default_r_val=80.0_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="dielectric_constant ", default_r_val=80.0_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="rho_min", & description="Lower density threshold.", & - usage="rho_min ", default_r_val=1.0E-4_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="rho_min ", default_r_val=1.0E-4_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="rho_max", & description="Upper density threshold.", & - usage="rho_max ", default_r_val=1.0E-3_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="rho_max ", default_r_val=1.0E-3_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DERIVATIVE_METHOD", & enum_c_vals=s2a('fft', 'fft_use_deps', 'fft_use_drho', 'cd3', 'cd5', 'cd7'), & @@ -759,17 +718,17 @@ SUBROUTINE create_dielectric_section(section,error) "5-point central difference derivative.",& "7-point central difference derivative (recommended)."),& description="Preferred method for evaluating the gradient of ln(eps).", & - usage="DERIVATIVE_METHOD ", default_i_val=derivative_cd7, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="DERIVATIVE_METHOD ", default_i_val=derivative_cd7) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) - CALL create_dielec_aa_cuboidal_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_dielec_aa_cuboidal_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_dielec_xaa_annular_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_dielec_xaa_annular_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_dielectric_section @@ -777,13 +736,10 @@ END SUBROUTINE create_dielectric_section ! ***************************************************************************** !> \brief Creates the section for creating axis-aligned cuboidal dielectric region. !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_dielec_aa_cuboidal_section(section,error) + SUBROUTINE create_dielec_aa_cuboidal_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_dielec_aa_cuboidal_section', & @@ -794,59 +750,55 @@ SUBROUTINE create_dielec_aa_cuboidal_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="DIELEC_AA_CUBOIDAL", & description="Parameters for creating axis-aligned cuboidal dielectric region.",& - n_keywords=5, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="dielectric_constant", variants=s2a('epsilon'), & description="value of the dielectric constant inside the region.", & - usage="dielectric_constant ", default_r_val=80.0_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="dielectric_constant ", default_r_val=80.0_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="X_xtnt", & description="The X extents of the cuboid.", & usage="X_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Y_xtnt", & description="The Y extents of the cuboid.", & usage="Y_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Z_xtnt", & description="The Z extents of the cuboid.", & usage="Z_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="smoothing_width", variants = s2a('zeta'), & description="The width of the standard mollifier.", & - usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_dielec_aa_cuboidal_section ! ***************************************************************************** !> \brief Creates the section for creating x-axis-aligned annular dielectric region. !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_dielec_xaa_annular_section(section,error) + SUBROUTINE create_dielec_xaa_annular_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_dielec_xaa_annular_section', & @@ -857,59 +809,55 @@ SUBROUTINE create_dielec_xaa_annular_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="DIELEC_XAA_ANNULAR", & description="Parameters for creating x-axis-aligned annular dielectric region.",& - n_keywords=5, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="dielectric_constant", variants=s2a('epsilon'), & description="value of the dielectric constant inside the region.", & - usage="dielectric_constant ", default_r_val=80.0_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="dielectric_constant ", default_r_val=80.0_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="X_xtnt", & description="The X extents of the annulus.", & usage="X_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="base_center", & description="The y and z coordinates of the annulus' base center.", & usage="base_center ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="base_radii", & description="The base radius of the annulus.", & usage="base_radius ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="smoothing_width", variants = s2a('zeta'), & description="The width of the standard mollifier.", & - usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_dielec_xaa_annular_section ! ***************************************************************************** !> \brief Creates the section for Dirichlet boundary conditions !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_dbc_section(section,error) + SUBROUTINE create_dbc_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_dbc_section', & routineP = moduleN//':'//routineN @@ -920,11 +868,10 @@ SUBROUTINE create_dbc_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="DIRICHLET_BC", & description="Parameters for creating Dirichlet type boundary conditions.",& - n_keywords=1, n_subsections=4, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=4, repeats=.FALSE.) NULLIFY(keyword) @@ -932,40 +879,37 @@ SUBROUTINE create_dbc_section(section,error) description="Print out the coordinates of the vertices defining Dirichlet regions and their "// & "tessellations (in Angstrom), the values of the electrostatic potential at the regions (in a.u.), "// & "and their corresponding evaluated Lagrange multipliers.", & - usage="VERBOSE_OUTPUT ", default_l_val=.FALSE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="VERBOSE_OUTPUT ", default_l_val=.FALSE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_aa_planar_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_aa_planar_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_planar_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_planar_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_xaa_cylindrical_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_xaa_cylindrical_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_aa_cuboidal_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_aa_cuboidal_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_dbc_section ! ***************************************************************************** !> \brief Creates the section for creating axis-aligned planar Dirichlet BC. !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_aa_planar_section(section,error) + SUBROUTINE create_aa_planar_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_aa_planar_section', & routineP = moduleN//':'//routineN @@ -975,89 +919,85 @@ SUBROUTINE create_aa_planar_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="AA_PLANAR", & description="Parameters for creating axis-aligned planar (rectangular) Dirichlet boundary region.",& - n_keywords=9, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=9, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="v_D", & description="value of the potential at the Dirichlet boundary (e.g. gate voltage).", & - usage="v_D ", unit_str="volt", type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="v_D ", unit_str="volt", type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARALLEL_PLANE", & enum_c_vals=s2a( 'XY', 'YZ' , 'XZ'), & enum_i_vals=(/ xy_aligned_rectangle, yz_aligned_rectangle, xz_aligned_rectangle /), & description="The coordinate plane that the region is parallel to.", & usage="PARALLEL_PLANE ", & - type_of_var=enum_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + type_of_var=enum_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTERCEPT", & description="The intercept of the rectangle's plane.", & usage="INTERCEPT ", unit_str="angstrom", & - type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="X_xtnt", & description="The X extents of the plane.", & usage="X_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Y_xtnt", & description="The Y extents of the plane.", & usage="Y_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Z_xtnt", & description="The Z extents of the plane.", & usage="Z_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_PRTN", & description="The number of partitions in xy, yz or xz directions for tiling the plane.", & usage="N_PRTN ", & - n_var=2, default_i_vals=(/1, 1/), error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, default_i_vals=(/1, 1/)) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SMOOTH", & description="Whether or not to smoothen (mollify) the dirichlet boundary region to avoid "//& "possible Gibbs phenomenon.", & - usage="SMOOTH ", default_l_val=.FALSE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="SMOOTH ", default_l_val=.FALSE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="smoothing_width", variants = s2a('zeta'), & description="The width of the standard mollifier.", & - usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_aa_planar_section ! ***************************************************************************** !> \brief Creates the section for creating axis-aligned planar Dirichlet BC. !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_planar_section(section,error) + SUBROUTINE create_planar_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_planar_section', & routineP = moduleN//':'//routineN @@ -1067,73 +1007,69 @@ SUBROUTINE create_planar_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="PLANAR", & description="Parameters for creating an arbitrary planar Dirichlet boundary region.",& - n_keywords=7, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="v_D", & description="value of the potential at the Dirichlet boundary (e.g. gate voltage).", & - usage="v_D ", unit_str="volt", type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="v_D ", unit_str="volt", type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="A", & description="Coordinates of the vertex A.", & usage="A ", unit_str="angstrom", & - n_var=3, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=3, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B", & description="Coordinates of the vertex B.", & usage="B ", unit_str="angstrom", & - n_var=3, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=3, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="C", & description="Coordinates of the vertex C.", & usage="C ", unit_str="angstrom", & - n_var=3, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=3, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_PRTN", & description="The number of partitions in the x, y and z directions for tiling the plane.", & usage="N_PRTN ", & - n_var=3, default_i_vals=(/1, 1, 1/), error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=3, default_i_vals=(/1, 1, 1/)) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SMOOTH", & description="Whether or not to smoothen (mollify) the dirichlet boundary region to avoid "//& "possible Gibbs phenomenon.", & - usage="SMOOTH ", default_l_val=.FALSE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="SMOOTH ", default_l_val=.FALSE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="smoothing_width", variants = s2a('zeta'), & description="The width of the standard mollifier.", & - usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_planar_section ! ***************************************************************************** !> \brief Creates the section for creating x-axis-aligned cylindrical Dirichlet BC. !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_xaa_cylindrical_section(section,error) + SUBROUTINE create_xaa_cylindrical_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_xaa_cylindrical_section', & @@ -1144,86 +1080,82 @@ SUBROUTINE create_xaa_cylindrical_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="XAA_CYLINDRICAL", & description="Parameters for creating x-axis-aligned cylindrical Dirichlet boundary region.",& - n_keywords=9, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=9, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="v_D", & description="value of the potential at the Dirichlet boundary (e.g. gate voltage).", & - usage="v_D ", unit_str="volt", type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="v_D ", unit_str="volt", type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="X_xtnt", & description="The X extents of the cylinder.", & usage="X_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="base_center", & description="The y and z coordinates of the cylinder's base center.", & usage="base_center ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="base_radius", & description="The base radius of the cylinder.", & - usage="base_radius ", default_r_val=1.0_dp, unit_str="angstrom", error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="base_radius ", default_r_val=1.0_dp, unit_str="angstrom") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="n_sides", & description="The number of sides os the n-gonal prism approximating the cylinder.", & - usage="n_sides ", default_i_val=5, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="n_sides ", default_i_val=5) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="apx_type", & enum_c_vals=s2a( 'CIRCUMSCRIBED', 'INSCRIBED' ), & enum_i_vals=(/ CIRCUMSCRIBED, INSCRIBED /), & description="Specifies the type of the n-gonal prism approximating the cylinder.", & - usage="apx_type ", default_i_val=CIRCUMSCRIBED, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="apx_type ", default_i_val=CIRCUMSCRIBED) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_PRTN", & description="The number of partitions in the x, y and z directions for tiling the plane.", & usage="N_PRTN ", & - n_var=3, default_i_vals=(/1, 1, 1/), error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=3, default_i_vals=(/1, 1, 1/)) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SMOOTH", & description="Whether or not to smoothen (mollify) the dirichlet boundary region to avoid "//& "possible Gibbs phenomenon.", & - usage="SMOOTH ", default_l_val=.FALSE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="SMOOTH ", default_l_val=.FALSE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="smoothing_width", variants = s2a('zeta'), & description="The width of the standard mollifier.", & - usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_xaa_cylindrical_section ! ***************************************************************************** !> \brief Creates the section for creating axis-aligned cuboidal Dirichlet region. !> \param section the section to be created -!> \param error cp2k error -!> !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE create_aa_cuboidal_section(section,error) + SUBROUTINE create_aa_cuboidal_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_aa_cuboidal_section', & routineP = moduleN//':'//routineN @@ -1233,60 +1165,59 @@ SUBROUTINE create_aa_cuboidal_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(section), cp_failure_level, routineP,failure) CALL section_create(section,name="AA_CUBOIDAL", & description="Parameters for creating axis-aligned cuboidal region where a fixed voltage is applied.",& - n_keywords=7, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="v_D", & description="value of the potential at the Dirichlet boundary (e.g. gate voltage).", & - usage="v_D ", unit_str="volt", type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="v_D ", unit_str="volt", type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="X_xtnt", & description="The X extents of the cuboid.", & usage="X_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Y_xtnt", & description="The Y extents of the cuboid.", & usage="Y_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Z_xtnt", & description="The Z extents of the cuboid.", & usage="Z_xtnt ", unit_str="angstrom", & - n_var=2, type_of_var=real_t, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=2, type_of_var=real_t) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_PRTN", & description="The number of partitions in the x, y and z directions for partitioning the cuboid.", & usage="N_PRTN ", & - n_var=3, default_i_vals=(/1, 1, 1/), error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + n_var=3, default_i_vals=(/1, 1, 1/)) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SMOOTH", & description="Whether or not to smoothen (mollify) the dirichlet region to avoid "//& "possible Gibbs phenomenon.", & - usage="SMOOTH ", default_l_val=.FALSE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="SMOOTH ", default_l_val=.FALSE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="smoothing_width", variants = s2a('zeta'), & description="The width of the standard mollifier.", & - usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="smoothing_width ", unit_str="angstrom", default_r_val=0.2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_aa_cuboidal_section diff --git a/src/input_cp2k_properties_dft.F b/src/input_cp2k_properties_dft.F index ba9f7c5c27..3d8d489f50 100644 --- a/src/input_cp2k_properties_dft.F +++ b/src/input_cp2k_properties_dft.F @@ -62,13 +62,10 @@ MODULE input_cp2k_properties_dft ! ***************************************************************************** !> \brief Create the PROPERTIES section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_properties_section(section,error) + SUBROUTINE create_properties_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_properties_section', & routineP = moduleN//':'//routineN @@ -79,45 +76,44 @@ SUBROUTINE create_properties_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PROPERTIES",& description="This section is used to set up the PROPERTIES calculation.",& - n_keywords=4, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=4, n_subsections=1, repeats=.FALSE.) NULLIFY (subsection,keyword) - CALL create_linres_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_linres_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_et_coupling_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_et_coupling_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_resp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_resp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_atprop_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_atprop_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(subsection,name="FIT_CHARGE",& description="This section is used to print the density derived atomic point charges."//& "The fit of the charges is controlled through the DENSITY_FITTING section",& - print_level=high_print_level,filename="__STD_OUT__",error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword, name="TYPE_OF_DENSITY",& description="Specifies the type of density used for the fitting",& usage="TYPE_OF_DENSITY (FULL|SPIN)",& enum_c_vals=s2a("FULL","SPIN"),& enum_i_vals=(/ do_full_density, do_spin_density/),& enum_desc=s2a("Full density","Spin density"),& - default_i_val=do_full_density, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + default_i_val=do_full_density) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_properties_section @@ -127,13 +123,10 @@ END SUBROUTINE create_properties_section !> a linear response calculation !> Available properties : none !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MI ! ***************************************************************************** - SUBROUTINE create_linres_section(section,error) + SUBROUTINE create_linres_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_linres_section', & routineP = moduleN//':'//routineN @@ -145,31 +138,30 @@ SUBROUTINE create_linres_section(section,error) failure=.FALSE. NULLIFY(keyword,subsection,print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="linres",& description="The linear response is used to calculate one of the "//& " following properties: nmr, epr, raman, ... ",& n_keywords=5, n_subsections=2, repeats=.FALSE., & - citations=(/Putrino2000/),& - error=error) + citations=(/Putrino2000/)) CALL keyword_create(keyword, name="EPS",& description="target accuracy for the convergence of the conjugate gradient.",& - usage="EPS 1.e-6", default_r_val=1.e-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS 1.e-6", default_r_val=1.e-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER",& description="Maximum number of conjugate gradient iteration to be performed for one optimization.",& - usage="MAX_ITER 200", default_i_val=50,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_ITER 200", default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_EVERY",& description="Restart the conjugate gradient after the specified number of iterations.",& - usage="RESTART_EVERY 200", default_i_val=50,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESTART_EVERY 200", default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRECONDITIONER",& description="Type of preconditioner to be used with all minimization schemes. "//& @@ -192,68 +184,65 @@ SUBROUTINE create_linres_section(section,error) "Cholesky inversion of S, not as good as FULL_KINETIC, yet equally expensive.",& "skip preconditioning"),& enum_i_vals=(/ot_precond_full_all,ot_precond_full_single_inverse,ot_precond_full_single, & - ot_precond_full_kinetic,ot_precond_s_inverse,ot_precond_none/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + ot_precond_full_kinetic,ot_precond_s_inverse,ot_precond_none/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY_GAP",& description="Energy gap estimate [a.u.] for preconditioning",& usage="ENERGY_GAP 0.1",& - default_r_val=0.2_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART",& description="Restart the response calculation if the restart file exists",& usage="RESTART",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WFN_RESTART_FILE_NAME",& variants=(/"RESTART_FILE_NAME"/),& description="Root of the file names where to read the response functions from"//& "which to restart the calculation of the linear response",& usage="WFN_RESTART_FILE_NAME ",& - type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_localize_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_localize_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_current_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_current_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_nmr_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_nmr_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_spin_spin_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_spin_spin_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_epr_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_epr_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_polarizability_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_polarizability_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,"PRINT","printing of information during the linear response calculation",& - repeats=.FALSE.,error=error) + repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic iteration information during the LINRES calculation", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESTART",& description="Controls the dumping of restart file of the response wavefunction."//& @@ -262,12 +251,12 @@ SUBROUTINE create_linres_section(section,error) "employed only to restart the same type of LINRES calculation, "//& "i.e. with the same perturbation.", & print_level=low_print_level,common_iter_levels=3,each_iter_names=s2a("ITER"),& - add_last=add_last_numeric,each_iter_values=(/3/),filename="",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric,each_iter_values=(/3/),filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_linres_section @@ -276,13 +265,10 @@ END SUBROUTINE create_linres_section !> calculation of induced current DFPT !> Available properties : none !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MI/VW ! ***************************************************************************** - SUBROUTINE create_current_section(section,error) + SUBROUTINE create_current_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_current_section', & routineP = moduleN//':'//routineN @@ -294,21 +280,19 @@ SUBROUTINE create_current_section(section,error) failure=.FALSE. NULLIFY(keyword,print_key, subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="current",& description="The induced current density is calculated by DFPT.",& n_keywords=4, n_subsections=1, repeats=.FALSE., & - citations=(/Sebastiani2001,Weber2009/),& - error=error) + citations=(/Sebastiani2001,Weber2009/)) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the induced current calculation",& usage="&CURRENT T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="GAUGE",& description="The gauge used to compute the induced current within GAPW.",& @@ -318,26 +302,25 @@ SUBROUTINE create_current_section(section,error) enum_desc=s2a("Position gauge (doesnt work well).",& "Position and step function for the soft and the local parts, respectively.",& "Atoms."),& - enum_i_vals=(/current_gauge_r,current_gauge_r_and_step_func,current_gauge_atom/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/current_gauge_r,current_gauge_r_and_step_func,current_gauge_atom/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GAUGE_ATOM_RADIUS",& description="Build the gauge=atom using only the atoms within this radius.", & usage="GAUGE_ATOM_RADIUS 10.0",& type_of_var=real_t,& - default_r_val=cp_unit_to_cp2k(value=4.0_dp,unit_str="angstrom",error=error),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=4.0_dp,unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_OLD_GAUGE_ATOM",& description="Use the old way to compute the gauge.", & usage="USE_OLD_GAUGE_ATOM T",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ORBITAL_CENTER",& description="The orbital center.",& @@ -349,127 +332,123 @@ SUBROUTINE create_current_section(section,error) "Use the atoms as center.",& "Boxing."),& enum_i_vals=(/current_orb_center_wannier,current_orb_center_common,& - current_orb_center_atom,current_orb_center_box/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + current_orb_center_atom,current_orb_center_box/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COMMON_CENTER",& description="The common center ", usage="COMMON_CENTER 0.0 1.0 0.0",& n_var=3,default_r_vals=(/0.0_dp,0.0_dp,0.0_dp/),type_of_var=real_t,& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NBOX",& description="How many boxes along each directions ", usage="NBOX 6 6 5",& - n_var=3,default_i_vals=(/4,4,4/),type_of_var=integer_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,default_i_vals=(/4,4,4/),type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHI_PBC",& description="Calculate the succeptibility correction to the shift with PBC",& usage="CHI_PBC T",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="SELECTED_STATES_ON_ATOM_LIST",& description="Indexes of the atoms for selecting"//& " the states to be used for the response calculations.",& usage="SELECTED_STATES_ON_ATOM_LIST 1 2 10",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="SELECTED_STATES_ATOM_RADIUS",& description="Select all the states included in the given radius arround each atoms "//& "in SELECTED_STATES_ON_ATOM_LIST.",& usage="SELECTED_STATES_ATOM_RADIUS 2.0",& type_of_var=real_t,& - default_r_val=cp_unit_to_cp2k(value=4.0_dp,unit_str="angstrom",error=error),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=4.0_dp,unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_CURRENT",& description="Restart the induced current density calculation"//& " from a previous run (not working yet).",& usage="RESTART_CURRENT",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="print results of induced current density calculation",& - repeats=.FALSE.,error=error) + repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"CURRENT_CUBES",& description="Controls the printing of the induced current density (not working yet).", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components (not working yet).",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESPONSE_FUNCTION_CUBES",& description="Controls the printing of the response functions (not working yet).", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components (not working yet).",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LU_BOUNDS",& variants=(/"CUBES_LU"/),& description="The lower and upper index of the states to be printed as cube (not working yet).",& usage="CUBES_LU_BOUNDS integer integer",& - n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LIST",& description="Indexes of the states to be printed as cube files"//& "This keyword can be repeated several times"//& "(useful if you have to specify many indexes) (not working yet).",& usage="CUBES_LIST 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_interp_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_interp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_current_section @@ -480,13 +459,10 @@ END SUBROUTINE create_current_section !> the induced current obtained from DFPT !> Available properties : none !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MI/VW ! ***************************************************************************** - SUBROUTINE create_nmr_section(section,error) + SUBROUTINE create_nmr_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_nmr_section', & routineP = moduleN//':'//routineN @@ -498,139 +474,134 @@ SUBROUTINE create_nmr_section(section,error) failure=.FALSE. NULLIFY(keyword,print_key, subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="nmr",& description="The chemical shift is calculated by DFPT.",& n_keywords=5, n_subsections=1, repeats=.FALSE., & - citations=(/Weber2009/),& - error=error) + citations=(/Weber2009/)) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the nmr calculation",& usage="&NMR T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTERPOLATE_SHIFT",& description="Calculate the soft part of the chemical shift by interpolation ",& usage="INTERPOLATE_SHIFT T",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NICS",& description="Calculate the chemical shift in a set of points "//& " given from an external file", usage="NICS",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NICS_FILE_NAME",& description="Name of the file with the NICS points coordinates",& usage="NICS_FILE_NAME nics_file",& - default_lc_val="nics_file",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="nics_file") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_NMR",& description="Restart the NMR calculation from a previous run (NOT WORKING YET)",& usage="RESTART_NMR",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHIFT_GAPW_RADIUS",& description="While computing the local part of the shift (GAPW), "//& "the integration is restricted to nuclei that are within this radius.", & usage="SHIFT_GAPW_RADIUS 20.0",& type_of_var=real_t,& - default_r_val=cp_unit_to_cp2k(value=60.0_dp,unit_str="angstrom",error=error),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=60.0_dp,unit_str="angstrom"),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="print results of nmr calculation",& - repeats=.FALSE.,error=error) + repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"RESPONSE_FUNCTION_CUBES",& description="Controls the printing of the response functions ", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LU_BOUNDS",& variants=(/"CUBES_LU"/),& description="The lower and upper index of the states to be printed as cube",& usage="CUBES_LU_BOUNDS integer integer",& - n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LIST",& description="Indexes of the states to be printed as cube files"//& "This keyword can be repeated several times"//& "(useful if you have to specify many indexes).",& usage="CUBES_LIST 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CHI_TENSOR",& description="Controls the printing of susceptibility",& - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SHIELDING_TENSOR",& description="Controls the printing of the chemical shift",& - print_level=low_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword,name="ATOMS_LU_BOUNDS",& variants=(/"ATOMS_LU"/),& description="The lower and upper atomic index for which the tensor is printed",& usage="ATOMS_LU_BOUNDS integer integer",& - n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS_LIST",& description="list of atoms for which the shift is printed into a file ",& usage="LIST_ATOMS 1 2",n_var=-1,& - type_of_var=integer_t,repeats=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_interp_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_interp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_nmr_section @@ -640,13 +611,10 @@ END SUBROUTINE create_nmr_section !> calculation of NMR spin-spin coupling (implementation not operating) !> Available properties : none !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author VW ! ***************************************************************************** - SUBROUTINE create_spin_spin_section(section,error) + SUBROUTINE create_spin_spin_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_spin_spin_section', & routineP = moduleN//':'//routineN @@ -658,90 +626,87 @@ SUBROUTINE create_spin_spin_section(section,error) failure=.FALSE. NULLIFY(keyword,print_key,subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="spinspin",& description="Compute indirect spin-spin coupling constants.",& - n_keywords=5, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the nmr calculation",& usage="&SPINSPIN T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_SPINSPIN",& description="Restart the spin-spin calculation from a previous run (NOT WORKING YET)",& usage="RESTART_SPINSPIN",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ISSC_ON_ATOM_LIST",& description="Atoms for which the issc is computed.",& usage="ISSC_ON_ATOM_LIST 1 2 10",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DO_FC",& description="Compute the Fermi contact contribution",& usage="DO_FC F",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DO_SD",& description="Compute the spin-dipolar contribution",& usage="DO_SD F",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DO_PSO",& description="Compute the paramagnetic spin-orbit contribution",& usage="DO_PSO F",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DO_DSO",& description="Compute the diamagnetic spin-orbit contribution (NOT YET IMPLEMENTED)",& usage="DO_DSO F",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="print results of the indirect spin-spin calculation",& - repeats=.FALSE.,error=error) + repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"K_MATRIX",& description="Controls the printing of the indirect spin-spin matrix",& - print_level=low_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="ATOMS_LIST",& description="list of atoms for which the indirect spin-spin is printed into a file ",& usage="LIST_ATOMS 1 2",n_var=-1,& - type_of_var=integer_t,repeats=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_interp_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_interp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_spin_spin_section @@ -752,14 +717,10 @@ END SUBROUTINE create_spin_spin_section !> the induced current obtained from DFPT !> Available properties : none !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author VW ! ***************************************************************************** - SUBROUTINE create_epr_section(section,error) + SUBROUTINE create_epr_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_epr_section', & routineP = moduleN//':'//routineN @@ -772,124 +733,118 @@ SUBROUTINE create_epr_section(section,error) failure=.FALSE. NULLIFY(keyword,print_key, subsection, subsubsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EPR",& description="The g tensor is calculated by DFPT ",& n_keywords=5, n_subsections=1, repeats=.FALSE., & - citations=(/Weber2009/),& - error=error) + citations=(/Weber2009/)) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the epr calculation",& usage="&EPR T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_EPR",& description="Restart the EPR calculation from a previous run (NOT WORKING)",& usage="RESTART_EPR",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="print results of epr calculation",& - repeats=.FALSE.,error=error) + repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"NABLAVKS_CUBES",& description="Controls the printing of the components of nabla v_ks ", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"G_TENSOR",& description="Controls the printing of the g tensor",& - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) - CALL create_xc_section(subsubsection,error) - CALL section_add_subsection(print_key, subsubsection, error=error) - CALL section_release(subsubsection,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") + CALL create_xc_section(subsubsection) + CALL section_add_subsection(print_key, subsubsection) + CALL section_release(subsubsection) CALL keyword_create(keyword, name="GAPW_MAX_ALPHA",& description="Maximum alpha of GTH potentials allowed on the soft grids ",& - usage="GAPW_MAX_ALPHA real", default_r_val=5.0_dp,& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GAPW_MAX_ALPHA real", default_r_val=5.0_dp) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SOO_RHO_HARD",& description="Whether or not to include the atomic parts of the density "//& "in the SOO part of the g tensor", usage="SOO_RHO_HARD", & - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESPONSE_FUNCTION_CUBES",& description="Controls the printing of the response functions ", & - print_level=high_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LU_BOUNDS",& variants=(/"CUBES_LU"/),& description="The lower and upper index of the states to be printed as cube",& usage="CUBES_LU_BOUNDS integer integer",& - n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,default_i_vals=(/0,-2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="CUBES_LIST",& description="Indexes of the states to be printed as cube files"//& "This keyword can be repeated several times"//& "(useful if you have to specify many indexes).",& usage="CUBES_LIST 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_interp_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_interp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_epr_section @@ -899,14 +854,11 @@ END SUBROUTINE create_epr_section !> calculation of polarizability tensor DFPT !> Available properties : none !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author SL ! ***************************************************************************** - SUBROUTINE create_polarizability_section(section,error) + SUBROUTINE create_polarizability_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_polarizability_section', & @@ -919,51 +871,48 @@ SUBROUTINE create_polarizability_section(section,error) failure=.FALSE. NULLIFY(keyword,print_key,subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="POLAR",& description="Compute polarizabilities.",& n_keywords=5, n_subsections=1, repeats=.FALSE., & - citations=(/Putrino2002/),& - error=error) + citations=(/Putrino2002/)) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the polarizability calculation",& usage="&POLAR T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DO_RAMAN",& description="Compute the electric-dipole--electric-dipole polarizability",& usage="DO_RAMAN F",& citations=(/Luber2014/),& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="print results of the polarizability calculation",& - repeats=.FALSE.,error=error) + repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"POLAR_MATRIX",& description="Controls the printing of the polarizabilities",& - print_level=low_print_level,add_last=add_last_numeric,filename="",& - error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="") - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_interp_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_interp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_polarizability_section @@ -971,13 +920,10 @@ END SUBROUTINE create_polarizability_section ! ***************************************************************************** !> \brief creates the section for electron transfer coupling !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff ! ***************************************************************************** - SUBROUTINE create_et_coupling_section(section,error) + SUBROUTINE create_et_coupling_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_et_coupling_section', & routineP = moduleN//':'//routineN @@ -988,31 +934,30 @@ SUBROUTINE create_et_coupling_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"ET_COUPLING",& description="specifies the two constraints/restraints for extracting ET coupling elements",& - n_keywords=1, n_subsections=4, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=4, repeats=.FALSE.) NULLIFY(subsection) - CALL create_restraint_A(subsection,"DDAPC_RESTRAINT_A",error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_restraint_A(subsection,"DDAPC_RESTRAINT_A") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_restraint_A(subsection,"DDAPC_RESTRAINT_B",error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_restraint_A(subsection,"DDAPC_RESTRAINT_B") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_restraint_A(subsection,"BECKE_RESTRAINT_A",error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_restraint_A(subsection,"BECKE_RESTRAINT_A") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) NULLIFY(subsection) - CALL create_restraint_A(subsection,"BECKE_RESTRAINT_B",error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_restraint_A(subsection,"BECKE_RESTRAINT_B") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="TYPE_OF_CONSTRAINT",& description="Specifies the type of constraint",& @@ -1020,17 +965,16 @@ SUBROUTINE create_et_coupling_section(section,error) enum_c_vals=s2a("NONE","DDAPC","BECKE"),& enum_i_vals=(/ do_no_et, do_et_ddapc, do_et_becke/),& enum_desc=s2a("NONE","ddapc_restraint","Sperical potential"),& - default_i_val=do_no_et,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_no_et) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing basic info about the method", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_et_coupling_section @@ -1038,12 +982,10 @@ END SUBROUTINE create_et_coupling_section !> \brief ... !> \param section ... !> \param section_name ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_restraint_A(section,section_name,error) + SUBROUTINE create_restraint_A(section,section_name) TYPE(section_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: section_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_restraint_A', & routineP = moduleN//':'//routineN @@ -1054,18 +996,17 @@ SUBROUTINE create_restraint_A(section,section_name,error) failure=.FALSE. NULLIFY(keyword, print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,TRIM(ADJUSTL(section_name)),& description="Use DDAPC charges in a restraint (check code for details),"//& " section can be repeated, but only one constraint is possible at the moment.",& - n_keywords=7, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="STRENGTH",& description="force constant of the restraint",& - usage="STRENGTH {real} ",default_r_val=0.1_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRENGTH {real} ",default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TYPE_OF_DENSITY",& description="Specifies the type of density used for the fitting",& @@ -1073,30 +1014,30 @@ SUBROUTINE create_restraint_A(section,section_name,error) enum_c_vals=s2a("FULL","SPIN"),& enum_i_vals=(/ do_full_density, do_spin_density/),& enum_desc=s2a("Full density","Spin density"),& - default_i_val=do_full_density, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_full_density) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TARGET",& description="target value of the restraint",& - usage="TARGET {real} ",default_r_val=1._dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TARGET {real} ",default_r_val=1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies the list of atoms that is summed in the restraint",& usage="ATOMS {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="COEFF",& description="Defines the the coefficient of the atom in the atom list (default is one), currently DDAPC only ",& usage="COEFF 1.0 -1.0",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTIONAL_FORM",& description="Specifies the functional form of the term added",& @@ -1104,16 +1045,15 @@ SUBROUTINE create_restraint_A(section,section_name,error) enum_c_vals=s2a("RESTRAINT","CONSTRAINT"),& enum_i_vals=(/ do_ddapc_restraint, do_ddapc_constraint/),& enum_desc=s2a("Harmonic potential: s*(q-t)**2","Constraint form: s*(q-t)"),& - default_i_val=do_ddapc_restraint, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_ddapc_restraint) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing basic info about the method", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_restraint_A diff --git a/src/input_cp2k_qmmm.F b/src/input_cp2k_qmmm.F index b2659187b0..1bee867623 100644 --- a/src/input_cp2k_qmmm.F +++ b/src/input_cp2k_qmmm.F @@ -85,13 +85,10 @@ MODULE input_cp2k_qmmm ! ***************************************************************************** !> \brief Creates the QM/MM section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_qmmm_section(section,error) + SUBROUTINE create_qmmm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_section', & routineP = moduleN//':'//routineN @@ -102,12 +99,11 @@ SUBROUTINE create_qmmm_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="qmmm",& description="Input for QM/MM calculations.",& n_keywords=6, n_subsections=3, repeats=.FALSE., & - citations=(/Laino2005,Laino2006/),& - error=error) + citations=(/Laino2005,Laino2006/)) NULLIFY(keyword, subsection ) CALL keyword_create(keyword, name="E_COUPL",& @@ -121,17 +117,17 @@ SUBROUTINE create_qmmm_section(section,error) "Using fast gaussian expansion of the electrostatic potential (Erf(r/rc)/r)",& "Using fast gaussian expansion of the s-wave electrostatic potential",& "Using quantum mechanics derived point charges interacting with MM charges"),& - default_i_val=do_qmmm_none, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_qmmm_none) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MM_POTENTIAL_FILE_NAME",& description="Name of the file containing the potential expansion in gaussians. See the "//& "USE_GEEP_LIB keyword.",& usage="MM_POTENTIAL_FILE_NAME {filename}",& - default_lc_val="MM_POTENTIAL",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="MM_POTENTIAL") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="use_geep_lib",& description=" This keyword enables the use of the internal GEEP library to generate the "//& @@ -139,9 +135,9 @@ SUBROUTINE create_qmmm_section(section,error) "the MM_POTENTIAL_FILENAME. It expects a number from 2 to 15 (the number of gaussian funtions"//& " to be used in the expansion.",& usage="use_geep_lib INTEGER",& - default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="nocompatibility",& description="This keyword disables the compatibility of QM/MM "//& @@ -149,17 +145,17 @@ SUBROUTINE create_qmmm_section(section,error) " is achieved using an MM potential of the form: Erf[x/rc]/x + (1/rc -2/(pi^1/2*rc))*Exp[-(x/rc)^2] ."//& "This keyword has effect only selecting GAUSS E_COUPLING type.",& usage="nocompatibility LOGICAL",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_mm_rspace",& description="Set the threshold for the collocation of the GEEP gaussian functions."//& "this keyword affects only the GAUSS E_COUPLING.",& usage="eps_mm_rspace real",& - default_r_val=1.0E-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SPHERICAL_CUTOFF",& description="Set the spherical cutoff for the QMMM electrostatic interaction. "//& @@ -169,9 +165,9 @@ SUBROUTINE create_qmmm_section(section,error) "Two values are required: the first one is the distance cutoff. The second one controls "//& "the stiffness of the smoothing.",& usage="SPHERICAL_CUTOFF ", default_r_vals=(/-1.0_dp,0.0_dp/), n_var=2,& - unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="parallel_scheme",& description="Chooses the parallel_scheme for the long range Potential ",& @@ -182,9 +178,9 @@ SUBROUTINE create_qmmm_section(section,error) "with limited memory per core. The grid option may be preferred in this case.",& "parallelizes on grid slices. atoms replicated."),& enum_i_vals=(/ do_par_atom, do_par_grid /),& - default_i_val=do_par_atom, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_par_atom) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Centering keywords CALL keyword_create(keyword, name="CENTER",& @@ -196,9 +192,9 @@ SUBROUTINE create_qmmm_section(section,error) "Center at first step only", & "Never center"),& enum_i_vals=(/ do_qmmm_center_every_step, do_qmmm_center_setup_only, do_qmmm_center_never /),& - default_i_val=do_qmmm_center_every_step, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_qmmm_center_every_step) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CENTER_TYPE",& description="This keyword specifies how to do the QM system centering.",& @@ -207,88 +203,85 @@ SUBROUTINE create_qmmm_section(section,error) enum_desc=s2a("Center of box defined by maximum coordinate minus minimum coordinate",& "PBC-aware centering (useful for &QMMM&FORCE_MIXING)"),& enum_i_vals=(/ do_qmmm_center_max_minus_min, do_qmmm_center_pbc_aware /),& - default_i_val=do_qmmm_center_max_minus_min, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_qmmm_center_max_minus_min) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CENTER_GRID",& description="This keyword specifies whether the QM system is centered in units of the grid spacing.",& usage="grid_center LOGICAL",& - default_l_val=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="initial_translation_vector",& description="This keyword specify the initial translation vector to be applied to the system.",& usage="initial_translation_vector ",& - n_var=3, default_r_vals=(/0.0_dp, 0.0_dp, 0.0_dp/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3, default_r_vals=(/0.0_dp, 0.0_dp, 0.0_dp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DELTA_CHARGE",& description="Additional net charge relative to that specified in DFT section. Used automatically by force mixing",& usage="DELTA_CHARGE q",default_i_val=0,& - n_var=1,type_of_var=integer_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=integer_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! NB: remember to create these - CALL create_qmmm_force_mixing_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_force_mixing_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_qm_kinds(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_qm_kinds(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_mm_kinds(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_mm_kinds(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_cell_section(subsection,periodic=use_perd_none,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cell_section(subsection,periodic=use_perd_none) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_periodic_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_periodic_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_link_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_link_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_interp_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_interp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_forcefield_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_forcefield_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_walls_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_walls_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_qmmm_image_charge_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_image_charge_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_print_qmmm_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_print_qmmm_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_qmmm_section ! ***************************************************************************** !> \brief Input section to create MM kinds sections !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_mm_kinds(section,error) + SUBROUTINE create_qmmm_mm_kinds(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_mm_kinds', & routineP = moduleN//':'//routineN @@ -298,44 +291,39 @@ SUBROUTINE create_qmmm_mm_kinds(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MM_KIND",& description="Information about the MM kind in the QM/MM scheme",& - n_keywords=2, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& - description="The MM kind",usage="O",n_var=1,type_of_var=char_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + description="The MM kind",usage="O",n_var=1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RADIUS",& description="Specifies the radius of the atomic kinds",& usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom",& - default_r_val=cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom",error=error),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORR_RADIUS",& description="Specifies the correction radius of the atomic kinds"//& " The correction radius is connected to the use of the compatibility keyword.",& - usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_qmmm_mm_kinds ! ***************************************************************************** !> \brief Input section to create FORCE_MIXING sections !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author noam ! ***************************************************************************** - SUBROUTINE create_qmmm_force_mixing_section(section, error) + SUBROUTINE create_qmmm_force_mixing_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_qmmm_force_mixing_section', & @@ -349,7 +337,7 @@ SUBROUTINE create_qmmm_force_mixing_section(section, error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="FORCE_MIXING",& description="This section enables and defines parameters for force-mixing based QM/MM,"//& " which actually does two conventional QM/MM calculations, on a small "//& @@ -367,14 +355,13 @@ SUBROUTINE create_qmmm_force_mixing_section(section, error) " only MOTION&GEO_OPT&TYPE CG, MOTION&GEO_OPT&CG&LINE_SEARCH&TYPE 2PNT, and "//& " MOTION&GEO_OPT&CG&LINE_SEARCH&2PNT&LINMIN_GRAD_ONLY T",& n_keywords=5, n_subsections=3, repeats=.FALSE., & - citations=(/Bernstein2009,Bernstein2012/),& - error=error) + citations=(/Bernstein2009,Bernstein2012/)) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_", & description="Enables force-mixing", & - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOMENTUM_CONSERVATION_TYPE",& description="How to apply force to get momentum conservation", & @@ -384,9 +371,9 @@ SUBROUTINE create_qmmm_force_mixing_section(section, error) enum_desc=s2a("No momentum conservation", & "Equal force on each atom",& "Equal acceleration on each atom"),& - default_i_val=do_fm_mom_conserv_equal_a, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_fm_mom_conserv_equal_a) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOMENTUM_CONSERVATION_REGION",& description="Region to apply correction force to for momentum conservation", & @@ -396,31 +383,31 @@ SUBROUTINE create_qmmm_force_mixing_section(section, error) enum_desc=s2a("Apply to QM core region", & "Apply to full QM (dynamics) region",& "Apply to QM+buffer regions"),& - default_i_val=do_fm_mom_conserv_QM, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_fm_mom_conserv_QM) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R_CORE",& description="Specify the inner and outer radii of core QM region. "//& " All molecules with any atoms within this distance (hysteretically) of any atoms "//& " specified as QM in enclosing QM/MM section will be core QM atoms in the force-mixing calculation.", & usage="R_CORE ",n_var=2,type_of_var=real_t,& - default_r_vals=(/ cp_unit_to_cp2k(0.0_dp,"angstrom",error=error),& - cp_unit_to_cp2k(0.0_dp,"angstrom",error=error) /),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/ cp_unit_to_cp2k(0.0_dp,"angstrom"),& + cp_unit_to_cp2k(0.0_dp,"angstrom") /),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R_QM",& description="Specify the inner and outer radii of QM dynamics region. "//& " All molecules with atoms within this distance (hysteretically) of any atoms in "//& " core will follow QM dynamics in the force-mixing calculation.", & usage="R_QM ",n_var=2,type_of_var=real_t,& - default_r_vals=(/ cp_unit_to_cp2k(0.5_dp,"angstrom",error=error),& - cp_unit_to_cp2k(1.0_dp,"angstrom",error=error) /),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/ cp_unit_to_cp2k(0.5_dp,"angstrom"),& + cp_unit_to_cp2k(1.0_dp,"angstrom") /),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="QM_EXTENDED_SEED_IS_ONLY_CORE_LIST",& description="Makes the extended QM zone be defined hysterestically "//& @@ -428,83 +415,81 @@ SUBROUTINE create_qmmm_force_mixing_section(section, error) " user) instead of from full QM core region (specified by user + hysteretic "//& " selection + unbreakable bonds)",& usage="QM_EXTENDED_SEED_IS_ONLY_CORE_LIST ",n_var=1,type_of_var=logical_t,& - default_l_val=.FALSE., repeats = .FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., repeats = .FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="R_BUF",& description="Specify the inner and outer radii of buffer region. "//& " All atoms within this distance (hysteretically) of any QM atoms "//& " will be buffer atoms in the force-mixing calculation.", & usage="R_BUF ",n_var=2,type_of_var=real_t,& - default_r_vals=(/ cp_unit_to_cp2k(0.5_dp,"angstrom",error=error),& - cp_unit_to_cp2k(1.0_dp,"angstrom",error=error) /),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/ cp_unit_to_cp2k(0.5_dp,"angstrom"),& + cp_unit_to_cp2k(1.0_dp,"angstrom") /),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="QM_KIND_ELEMENT_MAPPING",& description="Mapping from elements to QM_KINDs for adaptively included atoms.",& usage="QM_KIND_ELEMENT_MAPPING {El} {QM_KIND}",& - n_var=2,type_of_var=char_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2,type_of_var=char_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_N_QM",& description="Maximum number of QM atoms, for detection of runaway adaptive selection.",& usage="MAX_N_QM int",default_i_val=300,& - n_var=1,type_of_var=integer_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=integer_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ADAPTIVE_EXCLUDE_MOLECULES",& description="List of molecule names to exclude from adaptive regions (e.g. big things like proteins)",& usage="ADAPTIVE_EXCLUDE_MOLECULES molec1 molec2 ...",& - n_var=-1,type_of_var=char_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXTENDED_DELTA_CHARGE",& description="Additional net charge in extended region relative to core (core charge is "//& " specified in DFT section, as usual for a convetional QM/MM calculation)",& usage="EXTENDED_DELTA_CHARGE q",default_i_val=0,& - n_var=1,type_of_var=integer_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,type_of_var=integer_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! QM_NON_ADAPTIVE subsection NULLIFY(subsection) CALL section_create(subsection,name="QM_NON_ADAPTIVE",& description="List of atoms always in QM region, non-adaptively",& - n_keywords=0, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(qm_kinds_subsection) - CALL create_qmmm_qm_kinds(qm_kinds_subsection,error) - CALL section_add_subsection(subsection,qm_kinds_subsection,error=error) - CALL section_release(qm_kinds_subsection,error=error) + CALL create_qmmm_qm_kinds(qm_kinds_subsection) + CALL section_add_subsection(subsection,qm_kinds_subsection) + CALL section_release(qm_kinds_subsection) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! BUFFER_NON_ADAPTIVE subsection NULLIFY(subsection) CALL section_create(subsection,name="BUFFER_NON_ADAPTIVE",& description="List of atoms always in buffer region, non-adaptively, and any needed LINK sections",& - n_keywords=0, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(qm_kinds_subsection) - CALL create_qmmm_qm_kinds(qm_kinds_subsection,error) - CALL section_add_subsection(subsection,qm_kinds_subsection,error=error) - CALL section_release(qm_kinds_subsection,error=error) + CALL create_qmmm_qm_kinds(qm_kinds_subsection) + CALL section_add_subsection(subsection,qm_kinds_subsection) + CALL section_release(qm_kinds_subsection) NULLIFY(link_subsection) - CALL create_qmmm_link_section(link_subsection,error) - CALL section_add_subsection(subsection,link_subsection,error=error) - CALL section_release(link_subsection,error=error) + CALL create_qmmm_link_section(link_subsection) + CALL section_add_subsection(subsection,link_subsection) + CALL section_release(link_subsection) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ![NB] also need a list? @@ -515,66 +500,61 @@ SUBROUTINE create_qmmm_force_mixing_section(section, error) CALL section_create(subsection,name="BUFFER_LINKS",& description="Information about possible links for automatic covalent bond breaking for the buffer QM/MM calculation."//& "Ignored - need to implement buffer selection by atom and walking of connectivity data.",& - n_keywords=0, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(link_subsection) - CALL create_qmmm_link_section(link_subsection,error) - CALL section_add_subsection(subsection,link_subsection,error=error) - CALL section_release(link_subsection,error=error) + CALL create_qmmm_link_section(link_subsection) + CALL section_add_subsection(subsection,link_subsection) + CALL section_release(link_subsection) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! RESTART_INFO subsection NULLIFY(subsection) CALL section_create(subsection,name="RESTART_INFO",& description="This section provides information about old force-mixing indices and labels, "//& "for restarts.", & - n_keywords=2, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="INDICES",& description="Indices of atoms in previous step QM regions.", & usage="INDICES 1 2 ...", & - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LABELS",& description="Labels of atoms in previous step QM regions.", & usage="LABELS 1 1 ...", & - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! PRINT subsection, with keys for neighbor list CALL section_create(subsection,name="print",& description="Section of possible print options in FORCE_MIXING.",& - n_keywords=0, n_subsections=2, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=2, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"SUBCELL",& description="Activates the printing of the subcells used for the"//& "generation of neighbor lists.", unit_str="angstrom",& - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"NEIGHBOR_LISTS",& description="Activates the printing of the neighbor lists used"//& " for the hysteretic region calculations.", & - print_level=high_print_level,filename="",unit_str="angstrom",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="",unit_str="angstrom") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_qmmm_force_mixing_section @@ -582,13 +562,10 @@ END SUBROUTINE create_qmmm_force_mixing_section ! ***************************************************************************** !> \brief Input section to create QM kinds sections !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_qm_kinds(section,error) + SUBROUTINE create_qmmm_qm_kinds(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_qm_kinds', & routineP = moduleN//':'//routineN @@ -598,37 +575,33 @@ SUBROUTINE create_qmmm_qm_kinds(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="QM_KIND",& description="Information about the QM kind in the QM/MM scheme",& - n_keywords=3, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& - description="The QM kind",usage="O",n_var=1,type_of_var=char_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + description="The QM kind",usage="O",n_var=1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MM_INDEX",& description="The indexes of the MM atoms that have this kind. This keyword can be"//& " repeated several times (useful if you have to specify many indexes).",& usage="MM_INDEX 1 2",& - n_var=-1,type_of_var=integer_t,repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_qmmm_qm_kinds ! ***************************************************************************** !> \brief Input section to set QM/MM periodic boundary conditions !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_walls_section(section,error) + SUBROUTINE create_qmmm_walls_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_walls_section', & routineP = moduleN//':'//routineN @@ -639,23 +612,22 @@ SUBROUTINE create_qmmm_walls_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="WALLS",& description="Enables Walls for the QM box. This can be used to avoid that QM "//& " atoms move out of the QM box.",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="WALL_SKIN",& description="Specify the value of the skin of the Wall in each dimension. "//& "The wall's effect is felt when atoms fall within the skin of the Wall.",& usage="WALL_SKIN ",n_var=3,type_of_var=real_t,& - default_r_vals=(/ cp_unit_to_cp2k(0.5_dp,"angstrom",error=error),& - cp_unit_to_cp2k(0.5_dp,"angstrom",error=error),& - cp_unit_to_cp2k(0.5_dp,"angstrom",error=error) /),& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/ cp_unit_to_cp2k(0.5_dp,"angstrom"),& + cp_unit_to_cp2k(0.5_dp,"angstrom"),& + cp_unit_to_cp2k(0.5_dp,"angstrom") /),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TYPE",& description="Specifies the type of wall",& @@ -665,29 +637,26 @@ SUBROUTINE create_qmmm_walls_section(section,error) enum_desc=s2a("No Wall around QM box", & "Reflective Wall around QM box",& "Quadratic Wall around QM box"),& - default_i_val=do_qmmm_wall_reflective, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_qmmm_wall_reflective) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Specify the value of the the force constant for the quadratic wall",& usage="K ",unit_str='internal_cp2k',& - type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_qmmm_walls_section ! **************************************************************************** !> \brief Input section for QM/MM image charge calculations !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE create_qmmm_image_charge_section (section,error) + SUBROUTINE create_qmmm_image_charge_section (section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_qmmm_image_charge_section', & @@ -699,39 +668,38 @@ SUBROUTINE create_qmmm_image_charge_section (section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="IMAGE_CHARGE",& description="Inclusion of polarization effects within the image charge "//& "approach for systems where QM molecules are physisorbed on e.g. metal "//& "surfaces described by MM. QM box size has to be equal to MM box size.",& n_keywords=3, n_subsections=0, repeats=.FALSE., & - citations=(/Golze2013/),& - error=error) + citations=(/Golze2013/)) CALL keyword_create(keyword, name="MM_ATOM_LIST",& description="List of MM atoms carrying an induced Gaussian charge. "//& "If this keyword is not given, all MM atoms will carry an image charge.",& usage="MM_ATOM_LIST 1 2 3 or 1..3 ",n_var=-1,type_of_var=integer_t,& - repeats=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WIDTH",& description="Specifies the value of the width of the (induced) Gaussian "//& "charge distribution carried by each MM atom.",& usage="WIDTH ",n_var=1,type_of_var=real_t,& - default_r_val=cp_unit_to_cp2k(value=3.0_dp,unit_str="angstrom^-2", error=error), & - unit_str="angstrom^-2",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=3.0_dp,unit_str="angstrom^-2"), & + unit_str="angstrom^-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXT_POTENTIAL",& description="External potential applied to the metal electrode ",& usage="EXT_POTENTIAL ",n_var=1,type_of_var=real_t,& default_r_val= 0.0_dp,& - unit_str="volt",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="volt") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DETERM_COEFF",& description="Specifies how the coefficients are determined.",& @@ -740,40 +708,36 @@ SUBROUTINE create_qmmm_image_charge_section (section,error) enum_i_vals=(/ do_qmmm_image_calcmatrix, do_qmmm_image_iter/),& enum_desc=s2a("Calculates image matrix and solves linear set of equations", & "Uses an iterative scheme to calculate the coefficients"),& - default_i_val=do_qmmm_image_calcmatrix, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_qmmm_image_calcmatrix) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_IMAGE_MATRIX",& description="Restart the image matrix. Useful when "//& "calculating coefficients iteratively (the image matrix "//& "is used as preconditioner in that case)",& usage="RESTART_IMAGE_MATRIX", default_l_val=.FALSE., & - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IMAGE_RESTART_FILE_NAME",& description="File name where to read the image matrix used "//& "as preconditioner in the iterative scheme",& usage="IMAGE_RESTART_FILE_NAME ",& - type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_qmmm_image_charge_section ! ***************************************************************************** !> \brief Input section to set QM/MM periodic boundary conditions !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_periodic_section(section,error) + SUBROUTINE create_qmmm_periodic_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_periodic_section', & routineP = moduleN//':'//routineN @@ -785,69 +749,61 @@ SUBROUTINE create_qmmm_periodic_section(section,error) failure=.FALSE. NULLIFY(keyword, subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PERIODIC",& description="Specify parameters for QM/MM periodic boundary conditions calculations",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Laino2006/),& - error=error) + citations=(/Laino2006/)) CALL keyword_create(keyword, name="GMAX",& description="Specifies the maximum value of G in the reciprocal space over which perform the Ewald sum.",& - usage="GMAX ",n_var=1,default_r_val=1.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GMAX ",n_var=1,default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REPLICA",& description="Specifies the number of replica to take into consideration for the real part of the "//& "calculation. Default is letting the qmmm module decide how many replica you really need.",& - usage="REPLICA ",n_var=1,default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="REPLICA ",n_var=1,default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NGRIDS",& description="Specifies the number of grid points used for the Interpolation of the G-space term",& - usage="NGRIDS ",n_var=3,default_i_vals=(/50,50,50/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NGRIDS ",n_var=3,default_i_vals=(/50,50,50/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_multipole_qmmm_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_multipole_qmmm_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_gspace_interp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_gspace_interp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_poisson_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_poisson_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(subsection,"check_spline",& description="Controls the checking of the G-space term Spline Interpolation.",& - print_level=medium_print_level,filename="GSpace-SplInterp",& - error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=medium_print_level,filename="GSpace-SplInterp") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_qmmm_periodic_section ! ***************************************************************************** !> \brief Section to set-up parameters for decoupling using the Bloechl scheme !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Dorothea Golze [04.2014] copied from input_cp2k_poisson.F and !> enabled switch-on/off !> \author teo ! ***************************************************************************** - SUBROUTINE create_multipole_qmmm_section(section,error) + SUBROUTINE create_multipole_qmmm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_multipole_qmmm_section', & @@ -859,14 +815,13 @@ SUBROUTINE create_multipole_qmmm_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MULTIPOLE",& description="This section is used to set up the decoupling of QM periodic images with "//& "the use of density derived atomic point charges. Switched on by default even if not "//& "explicitly given. Can be switched off if e.g. QM and MM box are of the same size.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& @@ -876,56 +831,52 @@ SUBROUTINE create_multipole_qmmm_section(section,error) enum_i_vals=(/do_multipole_section_on, do_multipole_section_off/),& enum_desc=s2a("switch on MULTIPOLE section", & "switch off MULTIPOLE section"), & - default_i_val=do_multipole_section_on,lone_keyword_i_val=do_multipole_section_on,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_multipole_section_on,lone_keyword_i_val=do_multipole_section_on) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RCUT",& description="Real space cutoff for the Ewald sum.",& usage="RCUT {real}", n_var=1, type_of_var=real_t,& - unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EWALD_PRECISION",& description="Precision achieved in the Ewald sum.",& usage="EWALD_PRECISION {real}", n_var=1, type_of_var=real_t,& - unit_str="hartree",default_r_val=1.0E-6_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="hartree",default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ANALYTICAL_GTERM",& description="Evaluates the Gterm in the Ewald Scheme analytically instead of using Splines.",& usage="ANALYTICAL_GTERM ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NGRIDS",& description="Specifies the number of grid points used for the Interpolation of the G-space term",& - usage="NGRIDS ",n_var=3,default_i_vals=(/50,50,50/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NGRIDS ",n_var=3,default_i_vals=(/50,50,50/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_gspace_interp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_gspace_interp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(subsection,"check_spline",& description="Controls the checking of the G-space term Spline Interpolation.",& - print_level=medium_print_level,filename="GSpace-SplInterp",& - error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=medium_print_level,filename="GSpace-SplInterp") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL cp_print_key_section_create(subsection,"program_run_info",& description="Controls the printing of basic information during the run", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_multipole_qmmm_section @@ -934,13 +885,10 @@ END SUBROUTINE create_multipole_qmmm_section !> \brief creates the qm/mm forcefield section to override to the FF specification !> given in the FIST input !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_forcefield_section(section,error) + SUBROUTINE create_qmmm_forcefield_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_qmmm_forcefield_section', & @@ -953,27 +901,25 @@ SUBROUTINE create_qmmm_forcefield_section(section,error) failure=.FALSE. NULLIFY(subsection,keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="FORCEFIELD",& description="Specify information on the QM/MM forcefield",& - n_keywords=0, n_subsections=2, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=2, repeats=.TRUE.) CALL keyword_create(keyword, name="MULTIPLE_POTENTIAL",& description="Enables the possibility to define NONBONDED and NONBONDED14 as a"//& " sum of different kinds of potential. Useful for piecewise defined potentials.",& - usage="MULTIPLE_POTENTIAL T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MULTIPLE_POTENTIAL T",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_qmmm_ff_nb_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_qmmm_ff_nb_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_NONBONDED14_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_NONBONDED14_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_qmmm_forcefield_section @@ -981,13 +927,10 @@ END SUBROUTINE create_qmmm_forcefield_section !> \brief creates the qm/mm forcefield section to override to the FF specification !> given in the FIST input - NONBONDED PART !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_ff_nb_section(section,error) + SUBROUTINE create_qmmm_ff_nb_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_ff_nb_section', & routineP = moduleN//':'//routineN @@ -998,40 +941,36 @@ SUBROUTINE create_qmmm_ff_nb_section(section,error) failure=.FALSE. NULLIFY(subsection ) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="NONBONDED",& description="Specify information on the QM/MM non-bonded forcefield",& - n_keywords=0, n_subsections=2, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=2, repeats=.TRUE.) - CALL create_LJ_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_LJ_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Williams_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Williams_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_Goodwin_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_Goodwin_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_GENPOT_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_GENPOT_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_qmmm_ff_nb_section ! ***************************************************************************** !> \brief creates the qm/mm link section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_link_section(section,error) + SUBROUTINE create_qmmm_link_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_link_section', & routineP = moduleN//':'//routineN @@ -1043,48 +982,45 @@ SUBROUTINE create_qmmm_link_section(section,error) failure=.FALSE. NULLIFY(keyword, subsection ) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="LINK",& description="Specify information on the QM/MM link treatment",& - n_keywords=7, n_subsections=2, repeats=.TRUE., & - error=error) + n_keywords=7, n_subsections=2, repeats=.TRUE.) CALL keyword_create(keyword, name="QM_INDEX",& variants=(/ "QM" /),& description="Specifies the index of the QM atom involved in the QM/MM link",& - usage="QM_INDEX integer",n_var=1,type_of_var=integer_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="QM_INDEX integer",n_var=1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="QM_KIND",& description="Specifies the element of the QM capping atom involved in the QM/MM link",& usage="QM_KIND char",n_var=1,type_of_var=char_t,& - default_c_val="H",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="H") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MM_INDEX",& variants=(/ "MM" /),& description="Specifies the index of the MM atom involved in the QM/MM link, Default hydrogen.",& - usage="MM_INDEX integer",n_var=1,type_of_var=integer_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MM_INDEX integer",n_var=1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RADIUS",& description="Overwrite the specification of the radius only for the MM atom involved in the link."//& "Default is to use the same radius as for the specified type.",& - usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORR_RADIUS",& description="Overwrite the specification of the correction radius only for the MM atom involved in the link."//& "Default is to use the same correction radius as for the specified type.",& - usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LINK_TYPE",& variants=(/ "LINK ","TYPE ","LTYPE"/),& @@ -1095,9 +1031,9 @@ SUBROUTINE create_qmmm_link_section(section,error) enum_desc=s2a("Use Generalized Hybrid Orbital method",& "Use Integrated Molecular Orbital Molecular Mechanics method",& "Use a monovalent pseudo-potential"),& - default_i_val=do_qmmm_link_imomm, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_qmmm_link_imomm) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA_IMOMM",& variants=s2a("ALPHA"),& @@ -1106,9 +1042,9 @@ SUBROUTINE create_qmmm_link_section(section,error) "A good guess can be derived from the bond distances of the forcefield: "//& "alpha = r_eq(QM-MM) / r_eq(QM-H).",& usage="ALPHA_IMOMM real",n_var=1,type_of_var=real_t,& - default_r_val=ALPHA_IMOMM_DEFAULT,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=ALPHA_IMOMM_DEFAULT) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="QMMM_SCALE_FACTOR",& variants=(/ "QMMM_CHARGE_SCALE ",& @@ -1119,9 +1055,9 @@ SUBROUTINE create_qmmm_link_section(section,error) " the classical part of the code. "//& "Default 1.0 i.e. no charge rescaling of the MM atom of the QM/MM link bond.",& usage="SCALE_FACTOR real",n_var=1,type_of_var=real_t,& - default_r_val=CHARGE_SCALE_FACTOR,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=CHARGE_SCALE_FACTOR) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FIST_SCALE_FACTOR",& variants=(/ "FIST_CHARGE_SCALE ",& @@ -1132,119 +1068,109 @@ SUBROUTINE create_qmmm_link_section(section,error) " for the generation of the QM/MM potential. "//& "Default 1.0 i.e. no charge rescaling of the MM atom of the QM/MM link bond.",& usage="SCALE_FACTOR real",n_var=1,type_of_var=real_t,& - default_r_val=CHARGE_SCALE_FACTOR,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=CHARGE_SCALE_FACTOR) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="MOVE_MM_CHARGE",& description="Specify information to move a classical charge before the"//& " QM/MM energies and forces evaluation",& - n_keywords=4, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=4, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="ATOM_INDEX_1",& variants=(/ "MM1" /),& description="Specifies the index of the MM atom involved in the QM/MM link to be moved",& - usage="ATOM_INDEX_1 integer",n_var=1,type_of_var=integer_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ATOM_INDEX_1 integer",n_var=1,type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOM_INDEX_2",& variants=(/ "MM2" /),& description="Specifies the index of the second atom defining the direction along which "//& " the atom will be moved",& - usage="ATOM_INDEX_2 integer",n_var=1,type_of_var=integer_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ATOM_INDEX_2 integer",n_var=1,type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA",& description="Specifies the scaling factor that defines the movement along the defined direction",& - usage="ALPHA real",n_var=1,type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALPHA real",n_var=1,type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RADIUS",& description="Specifies the radius used for the QM/MM electrostatic coupling after movement",& - usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom", default_r_val=0.0_dp, & - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom", default_r_val=0.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORR_RADIUS",& description="Specifies the correction radius used for the QM/MM electrostatic coupling after movement",& - usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom", default_r_val=0.0_dp, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RADIUS real",n_var=1,type_of_var=real_t,unit_str="angstrom", default_r_val=0.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="ADD_MM_CHARGE",& description="Specify information to add a classical charge before the"//& " QM/MM energies and forces evaluation",& - n_keywords=5, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="ATOM_INDEX_1",& variants=(/ "MM1" /),& description="Specifies the index of the first atom defining the direction along which"//& " the atom will be added",& - usage="ATOM_INDEX_1 integer",n_var=1,type_of_var=integer_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ATOM_INDEX_1 integer",n_var=1,type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOM_INDEX_2",& variants=(/ "MM2" /),& description="Specifies the index of the second atom defining the direction along which "//& " the atom will be added",& - usage="ATOM_INDEX_2 integer",n_var=1,type_of_var=integer_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ATOM_INDEX_2 integer",n_var=1,type_of_var=integer_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA",& description="Specifies the scaling factor that defines the movement along the defined direction",& - usage="ALPHA real",n_var=1,type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALPHA real",n_var=1,type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RADIUS",& description="Specifies the radius used for the QM/MM electrostatic coupling for the added source",& usage="RADIUS real",n_var=1,unit_str="angstrom",& - default_r_val=cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom",error=error),error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom")) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORR_RADIUS",& description="Specifies the correction radius used for the QM/MM electrostatic coupling for the added source",& usage="RADIUS real",n_var=1,unit_str="angstrom",& - default_r_val=cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom",error=error),error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom")) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE",& description="Specifies the charge for the added source of QM/MM potential",& - usage="CHARGE real",default_r_val=0.0_dp,n_var=1,type_of_var=real_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CHARGE real",default_r_val=0.0_dp,n_var=1,type_of_var=real_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_qmmm_link_section ! ***************************************************************************** !> \brief creates the interpolation section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_qmmm_interp_section(section,error) + SUBROUTINE create_qmmm_interp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qmmm_interp_section', & routineP = moduleN//':'//routineN @@ -1255,11 +1181,10 @@ SUBROUTINE create_qmmm_interp_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="interpolator",& description="kind of interpolation used between the multigrids",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, print_key) @@ -1268,18 +1193,17 @@ SUBROUTINE create_qmmm_interp_section(section,error) usage="kind spline3",& default_i_val=spline3_nopbc_interp,& enum_c_vals=s2a("spline3_nopbc"),& - enum_i_vals=(/spline3_nopbc_interp/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/spline3_nopbc_interp/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="safe_computation",& description="if a non unrolled calculation is to be performed in parallel",& usage="safe_computation OFF",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="aint_precond",& description="the approximate inverse to use to get the starting point"//& @@ -1289,10 +1213,9 @@ SUBROUTINE create_qmmm_interp_section(section,error) enum_c_vals=s2a( "copy","spl3_nopbc_aint1","spl3_nopbc_precond1",& "spl3_nopbc_aint2","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_1,& - precond_spl3_aint2, precond_spl3_2, precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_aint2, precond_spl3_2, precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="precond",& description="The preconditioner used"//& @@ -1302,29 +1225,28 @@ SUBROUTINE create_qmmm_interp_section(section,error) enum_c_vals=s2a("copy","spl3_nopbc_aint1","spl3_nopbc_precond1",& "spl3_nopbc_aint2","spl3_nopbc_precond2","spl3_nopbc_precond3"),& enum_i_vals=(/no_precond,precond_spl3_aint, precond_spl3_1,& - precond_spl3_aint2, precond_spl3_2, precond_spl3_3/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + precond_spl3_aint2, precond_spl3_2, precond_spl3_3/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_x",& description="accuracy on the solution for spline3 the interpolators",& - usage="eps_x 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_x 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eps_r",& description="accuracy on the residual for spline3 the interpolators",& - usage="eps_r 1.e-15", default_r_val=1.e-10_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eps_r 1.e-15", default_r_val=1.e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="max_iter",& variants=(/'maxiter'/),& description="the maximum number of iterations",& - usage="max_iter 200", default_i_val=100, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="max_iter 200", default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"conv_info",& @@ -1332,29 +1254,25 @@ SUBROUTINE create_qmmm_interp_section(section,error) " of the spline methods should be printed", & print_level=medium_print_level,each_iter_names=s2a("SPLINE_FIND_COEFFS"),& each_iter_values=(/10/),filename="__STD_OUT__",& - add_last=add_last_numeric,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"spl_coeffs",& description="outputs a cube with the coefficents calculated for "//& "the spline interpolation", & - print_level=debug_print_level,& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_qmmm_interp_section ! ***************************************************************************** !> \brief Create the print qmmm section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_print_qmmm_section(section,error) + SUBROUTINE create_print_qmmm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_qmmm_section', & routineP = moduleN//':'//routineN @@ -1365,12 +1283,11 @@ SUBROUTINE create_print_qmmm_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword, print_key) CALL section_create(section,name="print",& description="Section of possible print options specific of the QMMM code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key) @@ -1378,121 +1295,110 @@ SUBROUTINE create_print_qmmm_section(section,error) description="Controls the printing of the DIPOLE in a QM/MM calculations."//& " It requires that the DIPOLE calculations is "//& " requested both for the QS and for the MM part.", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PGF",& description="Controls the printing of the gaussian expansion basis set of the"//& " electrostatic potential", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"POTENTIAL",& description="Controls the printing of the QMMM potential",& print_level=high_print_level,filename="MM_ELPOT_QMMM",& - common_iter_levels=1,error=error) + common_iter_levels=1) CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"MM_POTENTIAL",& description="Controls the printing of the MM unidimensional potential on file",& print_level=high_print_level,filename="MM_ELPOT",& - common_iter_levels=1,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + common_iter_levels=1) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"QMMM_MATRIX",& description="Controls the printing of the QMMM 1 electron Hamiltonian Matrix"//& " for methods like semiempirical and DFTB",& print_level=high_print_level,filename="__STD_OUT__",& - common_iter_levels=1,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + common_iter_levels=1) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_BANNER",& description="Controls the printing of the banner of the MM program",& - print_level=silent_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=silent_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of information regarding the run.",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PERIODIC_INFO",& description="Controls the printing of information regarding the periodic boundary condition.",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"GRID_INFORMATION",& description="Controls the printing of information regarding the PW grid structures"//& " for PERIODIC QM/MM calculations.",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"derivatives",& description="Print all derivatives after QM/MM calculation", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"qmmm_charges",& description="Print all charges generating the QM/MM potential", & - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"qmmm_link_info",& description="Print all information on QM/MM links", & - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"qs_derivatives",& description="Print QM derivatives after QS calculation", & - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"image_charge_info",& description="Prints image charge coefficients and detailed energy info", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"image_charge_restart",& description="Controls the printing of the restart file for "// & "the image matrix when using the iterative scheme",& print_level=low_print_level,add_last=add_last_numeric,filename="RESTART",& - common_iter_levels=3, error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + common_iter_levels=3) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_qmmm_section diff --git a/src/input_cp2k_read.F b/src/input_cp2k_read.F index 5b5183765e..81c1fb407d 100644 --- a/src/input_cp2k_read.F +++ b/src/input_cp2k_read.F @@ -44,17 +44,14 @@ MODULE input_cp2k_read !> \param file_path path where the input should be read !> \param initial_variables ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION read_input(input_declaration, file_path,initial_variables, para_env,error) RESULT(res) + FUNCTION read_input(input_declaration, file_path,initial_variables, para_env) RESULT(res) TYPE(section_type), POINTER :: input_declaration CHARACTER(len=*), INTENT(in) :: file_path CHARACTER(len=*), DIMENSION(:, :) :: initial_variables TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error TYPE(section_vals_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'read_input', & @@ -69,14 +66,14 @@ FUNCTION read_input(input_declaration, file_path,initial_variables, para_env,err failure=.FALSE. NULLIFY(res) NULLIFY(cpparser, default_units) - CALL section_vals_create(res,input_declaration, error=error) + CALL section_vals_create(res,input_declaration) CALL parser_create(cpparser,initial_variables=initial_variables,file_name=file_path, & - para_env=para_env, error=error) - CALL cp_unit_set_create(default_units, "OUTPUT",error=error) + para_env=para_env) + CALL cp_unit_set_create(default_units, "OUTPUT") CALL section_vals_parse(res,cpparser,root_section=.FALSE.,& - default_units=default_units,error=error) - CALL cp_unit_set_release(default_units,error=error) - CALL parser_release(cpparser,error=error) + default_units=default_units) + CALL cp_unit_set_release(default_units) + CALL parser_release(cpparser) CALL timestop(handle) END FUNCTION read_input diff --git a/src/input_cp2k_resp.F b/src/input_cp2k_resp.F index 60094b5216..76c815f19d 100644 --- a/src/input_cp2k_resp.F +++ b/src/input_cp2k_resp.F @@ -51,13 +51,10 @@ MODULE input_cp2k_resp ! ***************************************************************************** !> \brief Creates the RESP section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_resp_section(section,error) + SUBROUTINE create_resp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_resp_section', & routineP = moduleN//':'//routineN @@ -68,7 +65,7 @@ SUBROUTINE create_resp_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RESP",& description="Requests a RESP fit of charges. When using a periodic "//& "Poisson solver and a periodic cell, the periodic RESP routines are "//& @@ -76,8 +73,7 @@ SUBROUTINE create_resp_section(section,error) "system (i.e. isolated Poisson solver and big, nonperiodic cells), "//& "the nonperiodic RESP routines are automatically used. All restraints "//& "are harmonic!",& - n_keywords=2, n_subsections=2, repeats=.FALSE., citations=(/Golze2015/),& - error=error) + n_keywords=2, n_subsections=2, repeats=.FALSE., citations=(/Golze2015/)) NULLIFY(keyword, subsection) @@ -85,75 +81,72 @@ SUBROUTINE create_resp_section(section,error) description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide "//& "3 numbers (for X,Y,Z) or 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTEGER_TOTAL_CHARGE",& description="Forces the total charge to be integer",& usage="INTEGER_TOTAL_CHARGE TRUE",& - default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTRAIN_HEAVIES_TO_ZERO",& description="Restrain non-hydrogen atoms to zero.",& usage="RESTRAIN_HEAVIES_TO_ZERO FALSE",& - default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTRAIN_HEAVIES_STRENGTH",& description="If defined, enforce the restraint of non-hydrogen "//& "atoms to zero. Its value is the strength of the restraint on "//& "the heavy atoms.",& usage="RESTRAIN_HEAVIES_STRENGTH 0.0001 ",& - default_r_val=1.0E-6_dp ,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WIDTH",& description="Specifies the value of the width of the Gaussian "//& "charge distribution carried by each atom. Needs only "//& "to be specified when using a periodic Poisson solver.",& usage="WIDTH ",n_var=1,type_of_var=real_t,& - default_r_val=cp_unit_to_cp2k(value=11.249_dp,unit_str="angstrom^-2",error=error), & - unit_str="angstrom^-2",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=11.249_dp,unit_str="angstrom^-2"), & + unit_str="angstrom^-2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_constraint_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_constraint_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_restraint_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_restraint_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_sphere_sampling_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_sphere_sampling_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_slab_sampling_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_slab_sampling_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_print_resp_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_print_resp_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_resp_section ! ***************************************************************************** !> \brief specifies constraints to be satisfied in a resp fit !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_constraint_section(section,error) + SUBROUTINE create_constraint_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_constraint_section', & routineP = moduleN//':'//routineN @@ -163,22 +156,21 @@ SUBROUTINE create_constraint_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CONSTRAINT",& description="specifies a linear constraint on the fitted charges."//& "This can be used to give equal values to equivalent atoms." //& "sum over atom_list c_i * q_i = t",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="TARGET",& description="the target value for the constraint",& usage="TARGET 0.0",& - n_var=1,default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EQUAL_CHARGES",& description="All atoms in ATOM_LIST are constrained to have the "//& @@ -186,25 +178,24 @@ SUBROUTINE create_constraint_section(section,error) "not need to be set and will be ignored. Instead of using this "//& "keyword, the constraint section could be repeated.",& usage="EQUAL_CHARGES",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ATOM_LIST",& description="Defines the list of atoms involved in this constraint",& usage="ATOM_LIST 3 4",& - type_of_var=integer_t, n_var=-1,repeats=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t, n_var=-1,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ATOM_COEF",& description="Defines the coefficient of the atom in this "//& "linear constraint",& usage="ATOM_COEF 1.0 -1.0",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_constraint_section @@ -212,13 +203,10 @@ END SUBROUTINE create_constraint_section ! ***************************************************************************** !> \brief specifies restraints to be added to a resp fit !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_restraint_section(section,error) + SUBROUTINE create_restraint_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_restraint_section', & routineP = moduleN//':'//routineN @@ -228,46 +216,44 @@ SUBROUTINE create_restraint_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RESTRAINT",& description="specifies a restraint on the fitted charges."//& "This can be used to restrain values to zero." //& "s*(sum over atom_list q_i - t)**2",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="TARGET",& description="the target value for the restraint",& usage="TARGET 0.0",& - n_var=1,default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STRENGTH",& description="the target value for the constraint",& usage="STRENGTH 0.001",& - n_var=1,default_r_val=0.001_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_r_val=0.001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ATOM_LIST",& description="Defines the list of atoms involved in this restraint",& usage="ATOM_LIST 3 4",& - type_of_var=integer_t, n_var=-1, repeats=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t, n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ATOM_COEF",& description="Defines the coefficient of the atom in this "//& "linear restraint. If given, the restraint will be: "//& "s*(sum over atom_list c_i * q_i - t)**2 ",& usage="ATOM_COEF 1.0 -1.0",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_restraint_section @@ -276,13 +262,10 @@ END SUBROUTINE create_restraint_section !> \brief specifies the parameter for sampling the resp fitting points for !> molecular structures; sampling in spheres around the atoms !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE create_sphere_sampling_section(section,error) + SUBROUTINE create_sphere_sampling_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_sphere_sampling_section', & @@ -293,86 +276,86 @@ SUBROUTINE create_sphere_sampling_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SPHERE_SAMPLING",& description="Specifies the parameter for sampling the RESP fitting points "//& "for molecular structures, i.e. systems that do not involve " //& "surfaces. Fitting points are sampled in spheres around the "//& "atom. All grid points in the shell defined by rmin and rmax "//& "are accepted for fitting.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="X_LOW",& description="Specifies the lower boundary of the box along X used to sample the potential.",& - usage="X_LOW -15.", type_of_var=real_t, n_var=1, unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="X_LOW -15.", type_of_var=real_t, n_var=1, unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="X_HI",& description="Specifies the upper boundary of the box along X used to sample the potential.",& - usage="X_HI 5.", type_of_var=real_t, n_var=1, unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="X_HI 5.", type_of_var=real_t, n_var=1, unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Y_LOW",& description="Specifies the lower boundary of the box along Y used to sample the potential.",& - usage="Y_LOW -15.", type_of_var=real_t, n_var=1, unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="Y_LOW -15.", type_of_var=real_t, n_var=1, unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Y_HI",& description="Specifies the upper boundary of the box along Y used to sample the potential.",& - usage="Y_HI 5.", type_of_var=real_t, n_var=1, unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="Y_HI 5.", type_of_var=real_t, n_var=1, unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Z_LOW",& description="Specifies the lower boundary of the box along Z used to sample the potential.",& - usage="Z_LOW -15.", type_of_var=real_t, n_var=1, unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="Z_LOW -15.", type_of_var=real_t, n_var=1, unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Z_HI",& description="Specifies the upper boundary of the box along Z used to sample the potential.",& - usage="Z_HI 5.", type_of_var=real_t, n_var=1, unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="Z_HI 5.", type_of_var=real_t, n_var=1, unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX",& description="Specifies the maximum distance a fit point is away from an atom. "//& "Valid for all atomic kinds for which no RMAX_KIND are specified.",& usage="RMAX 2.5",& - default_r_val=cp_unit_to_cp2k(value=2.5_dp, unit_str="angstrom", error=error),& - unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=2.5_dp, unit_str="angstrom"),& + unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN",& description="Specifies the minimum distance a fit point is away from an atom. "//& "Valid for all atomic kinds for which no RMIN_KIND are specified.",& usage="RMIN 2.1",& - default_r_val=cp_unit_to_cp2k(value=2.1_dp, unit_str="angstrom", error=error),& - unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=2.1_dp, unit_str="angstrom"),& + unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMAX_KIND",& description="Specifies the maximum distance a fit point is away from an atom "//& "of a given kind",& usage="RMAX 2.5 Br", repeats=.TRUE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMIN_KIND",& description="Specifies the minimum distance a fit point is away from an atom "//& "of a given kind",& usage="RMIN 2.1 Br", repeats=.TRUE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_sphere_sampling_section @@ -381,13 +364,10 @@ END SUBROUTINE create_sphere_sampling_section !> \brief specifies the parameter for sampling the resp fitting points for !> slab-like periodic systems, i.e. systems that involve surfaces !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE create_slab_sampling_section(section,error) + SUBROUTINE create_slab_sampling_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_slab_sampling_section', & routineP = moduleN//':'//routineN @@ -397,15 +377,14 @@ SUBROUTINE create_slab_sampling_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="SLAB_SAMPLING",& description="Specifies the parameter for sampling the RESP fitting "//& "points for slab-like periodic systems, i.e. systems that "//& "involve surfaces. This section can only be used with periodic "//& "Poisson solver and cell. To see, which grid points were "//& "used, switch on COORD_FIT_POINTS in the PRINT section.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -414,20 +393,18 @@ SUBROUTINE create_slab_sampling_section(section,error) "the region for the RESP fitting. The list should "//& "contain indexes of atoms of the first surface layer." ,& usage="ATOM_LIST 1 2 3 or 1..3",& - type_of_var=integer_t, n_var=-1,repeats=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t, n_var=-1,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RANGE",& description="Range where the fitting points are sampled. A range of "//& "3 to 5 Angstroms means that the fitting points are sampled in the region "//& "of 3 to 5 Angstroms above the surface which is defined by atom indexes given "//& "in ATOM_LIST.",& - usage="RANGE ",unit_str="angstrom",n_var=2,type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RANGE ",unit_str="angstrom",n_var=2,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LENGTH",& description="Length of the sampling box, i.e. a box of this length and "//& @@ -437,9 +414,9 @@ SUBROUTINE create_slab_sampling_section(section,error) "on the safe side). Allows for a refined sampling of grid points in case of "//& "corrugated surfaces.",& usage="LENGTH ",unit_str="angstrom",n_var=1,type_of_var=real_t,& - default_r_val=cp_unit_to_cp2k(value=3.0_dp,unit_str="angstrom", error=error),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=3.0_dp,unit_str="angstrom")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SURF_DIRECTION",& description="Specifies what above the surface means. Defines the direction.",& @@ -453,9 +430,9 @@ SUBROUTINE create_slab_sampling_section(section,error) "surface layers are piled up in -x-direction",& "surface layers are piled up in -y-direction",& "surface layers are piled up in -z-direction"),& - default_i_val=do_resp_z_dir, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_resp_z_dir) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_slab_sampling_section @@ -463,13 +440,10 @@ END SUBROUTINE create_slab_sampling_section ! ***************************************************************************** !> \brief create the resp print section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE create_print_resp_section(section,error) + SUBROUTINE create_print_resp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_resp_section', & routineP = moduleN//':'//routineN @@ -479,19 +453,17 @@ SUBROUTINE create_print_resp_section(section,error) TYPE(section_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(print_key, keyword) CALL section_create(section,name="print",& description="Section of possible print options specific for the RESP code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of information regarding the run.",& - print_level=low_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"COORD_FIT_POINTS",& description="Controls the printing of the coordinates of the "// & @@ -499,18 +471,18 @@ SUBROUTINE create_print_resp_section(section,error) "is intended to be only used for testing (you can get large files).",& print_level=high_print_level,add_last=add_last_numeric,& filename="RESP_FIT_POINTS",& - common_iter_levels=3, error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + common_iter_levels=3) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RESP_CHARGES_TO_FILE",& description="Controls the printing of the RESP charges "// & "to a file.",& print_level=high_print_level,add_last=add_last_numeric,& filename="RESP_CHARGES",& - common_iter_levels=3, error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + common_iter_levels=3) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"V_RESP_CUBE",& description="Controls the printing of the potential generated "//& @@ -518,21 +490,21 @@ SUBROUTINE create_print_resp_section(section,error) "root-mean-square (RRMS) and root-mean-square (RMS) errors.",& print_level=high_print_level,add_last=add_last_numeric,& filename="RESP_POTENTIAL",& - common_iter_levels=3, error=error) + common_iter_levels=3) CALL keyword_create(keyword, name="stride",& description="The stride (X,Y,Z) used to write the cube file "//& "(larger values result in smaller cube files). You can provide 3 numbers (for X,Y,Z) or"//& " 1 number valid for all components.",& - usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRIDE 2 2 2",n_var=-1,default_i_vals=(/2,2,2/), type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="APPEND",& description="append the cube files when they already exist",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_resp_section END MODULE input_cp2k_resp diff --git a/src/input_cp2k_restarts_util.F b/src/input_cp2k_restarts_util.F index 07bda2d824..24959e24a5 100644 --- a/src/input_cp2k_restarts_util.F +++ b/src/input_cp2k_restarts_util.F @@ -36,13 +36,11 @@ MODULE input_cp2k_restarts_util !> \param particles ... !> \param velocity ... !> \param conv_factor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE section_velocity_val_set(velocity_section, particles, velocity, conv_factor, error) + SUBROUTINE section_velocity_val_set(velocity_section, particles, velocity, conv_factor) TYPE(section_vals_type), POINTER :: velocity_section TYPE(particle_list_type), OPTIONAL, & @@ -50,8 +48,6 @@ SUBROUTINE section_velocity_val_set(velocity_section, particles, velocity, conv_ REAL(KIND=dp), DIMENSION(:, :), & OPTIONAL, POINTER :: velocity REAL(KIND=dp) :: conv_factor - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'section_velocity_val_set', & routineP = moduleN//':'//routineN @@ -67,37 +63,37 @@ SUBROUTINE section_velocity_val_set(velocity_section, particles, velocity, conv_ CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(velocity_section),cp_failure_level,routineP,error,failure) - CPPrecondition(velocity_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(velocity_section),cp_failure_level,routineP,failure) + CPPrecondition(velocity_section%ref_count>0,cp_failure_level,routineP,failure) section => velocity_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) ! At least one of the two arguments must be present.. check = PRESENT(particles).NEQV.PRESENT(velocity) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) IF(PRESENT(particles)) nloop = particles%n_els IF(PRESENT(velocity)) nloop = SIZE(velocity,2) DO IF (SIZE(velocity_section%values,2)==1) EXIT - CALL section_vals_add_values(velocity_section,error=error) + CALL section_vals_add_values(velocity_section) END DO vals => velocity_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF DO irk=1,nloop ALLOCATE(vel(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Always stored in A.U. IF(PRESENT(particles)) vel = particles%els(irk)%v(1:3)*conv_factor IF(PRESENT(velocity)) vel = velocity(1:3,irk)*conv_factor - CALL val_create(my_val,r_vals_ptr=vel,error=error) + CALL val_create(my_val,r_vals_ptr=vel) IF (Nlist /= 0) THEN IF (irk==1) THEN @@ -106,16 +102,16 @@ SUBROUTINE section_velocity_val_set(velocity_section, particles, velocity, conv_ new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF diff --git a/src/input_cp2k_rsgrid.F b/src/input_cp2k_rsgrid.F index 4685f9f5be..c0f4205dcb 100644 --- a/src/input_cp2k_rsgrid.F +++ b/src/input_cp2k_rsgrid.F @@ -36,12 +36,10 @@ MODULE input_cp2k_rsgrid ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... !> \author Joost ! ***************************************************************************** - SUBROUTINE create_rsgrid_section(section, error) + SUBROUTINE create_rsgrid_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_rsgrid_section', & routineP = moduleN//':'//routineN @@ -51,10 +49,10 @@ SUBROUTINE create_rsgrid_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RS_GRID",& description="Set options that influence how the realspace grids are being distributed in parallel runs.",& - n_keywords=5, n_subsections=0, repeats=.TRUE., error=error) + n_keywords=5, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="DISTRIBUTION_TYPE",& @@ -65,9 +63,9 @@ SUBROUTINE create_rsgrid_section(section, error) enum_desc=s2a("Use heuristic rules to decide between distributed and replicated", & "Force a distributed setup if possible",& "Force a replicated setup"),& - default_i_val=rsgrid_automatic, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=rsgrid_automatic) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISTRIBUTION_LAYOUT",& description="Specifies the number of slices in the x, y and z directions."//& @@ -76,18 +74,17 @@ SUBROUTINE create_rsgrid_section(section, error) "Also see LOCK_DISTRIBUTION.",& usage="DISTRIBUTION_LAYOUT",& repeats=.FALSE.,n_var=3,& - default_i_vals=(/-1,-1,-1/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_vals=(/-1,-1,-1/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_DISTRIBUTED_LEVEL",& description="If the multigrid-level of a grid is larger than the parameter,"//& " it will not be distributed in the automatic scheme.",& usage="MAX_DISTRIBUTED_LEVEL 1",& - default_i_val=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LOCK_DISTRIBUTION",& description="Expert use only, only basic QS deals correctly with a non-default value."//& @@ -95,24 +92,24 @@ SUBROUTINE create_rsgrid_section(section, error) "the next finer multigrid (provided it is distributed)."//& "If unlocked, all grids can be distributed freely.",& usage="LOCK_DISTRIBUTION TRUE",& - default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MEMORY_FACTOR",& description="A grid will only be distributed if the memory usage for that grid (including halo) "//& "is smaller than a replicated grid by this parameter.",& usage="MEMORY_FACTOR 4.0",& - default_r_val=2.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=2.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HALO_REDUCTION_FACTOR",& description="Can be used to reduce the halo of the distributed grid (experimental features).",& usage="HALO_REDUCTION_FACTOR 0.5",& - default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_rsgrid_section END MODULE input_cp2k_rsgrid diff --git a/src/input_cp2k_subsys.F b/src/input_cp2k_subsys.F index 36bfb448bc..17e77c748e 100644 --- a/src/input_cp2k_subsys.F +++ b/src/input_cp2k_subsys.F @@ -74,15 +74,12 @@ MODULE input_cp2k_subsys !> \param section ... !> \param periodic ... !> \param label ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - RECURSIVE SUBROUTINE create_cell_section(section,periodic,label,error) + RECURSIVE SUBROUTINE create_cell_section(section,periodic,label) TYPE(section_type), POINTER :: section INTEGER, INTENT(IN), OPTIONAL :: periodic CHARACTER(LEN=*), OPTIONAL :: label - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_cell_section', & routineP = moduleN//':'//routineN @@ -99,36 +96,35 @@ RECURSIVE SUBROUTINE create_cell_section(section,periodic,label,error) my_label = "CELL" IF (PRESENT(periodic)) my_periodic = periodic IF (PRESENT(label)) my_label = label - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,TRIM(my_label),& description="Input parameters needed to set up the "//TRIM(my_label)//".",& - n_keywords=6, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=6, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="A",& description="Specify the Cartesian components for the cell vector A. "//& "This defines the first column of the h matrix.",& usage="A 10.000 0.000 0.000",unit_str="angstrom",& - n_var=3,type_of_var=real_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="B",& description="Specify the Cartesian components for the cell vector B. "//& "This defines the second column of the h matrix.",& usage="B 0.000 10.000 0.000", unit_str="angstrom",& - n_var=3,type_of_var=real_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="C",& description="Specify the Cartesian components for the cell vector C. "//& "This defines the third column of the h matrix.",& usage="C 0.000 0.000 10.000", unit_str="angstrom",& - n_var=3,type_of_var=real_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ABC",& description="Specify the lengths of the cell vectors A, B, and C, which"//& @@ -137,9 +133,9 @@ RECURSIVE SUBROUTINE create_cell_section(section,periodic,label,error) "ALPHA, BETA, GAMMA via ALPHA_BETA_GAMMA keyword or alternatively use the keywords "//& "A, B, and C. The convention is that A lies along the X-axis, B is in the XY plane.",& usage="ABC 10.000 10.000 10.000", unit_str="angstrom",& - n_var=3,type_of_var=real_t,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,type_of_var=real_t,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA_BETA_GAMMA",& variants=(/"ANGLES"/),& @@ -148,19 +144,19 @@ RECURSIVE SUBROUTINE create_cell_section(section,periodic,label,error) "ALPHA is the angle between B and C, BETA is the angle between A and C and "//& "GAMMA the angle between A and B.",& usage="ALPHA_BETA_GAMMA [deg] 90.0 90.0 120.0", unit_str="deg",& - n_var=3,default_r_vals=(/cp_unit_to_cp2k(value=90.0_dp,unit_str="deg",error=error),& - cp_unit_to_cp2k(value=90.0_dp,unit_str="deg",error=error),& - cp_unit_to_cp2k(value=90.0_dp,unit_str="deg",error=error)/),& - repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,default_r_vals=(/cp_unit_to_cp2k(value=90.0_dp,unit_str="deg"),& + cp_unit_to_cp2k(value=90.0_dp,unit_str="deg"),& + cp_unit_to_cp2k(value=90.0_dp,unit_str="deg")/),& + repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CELL_FILE_NAME",& description="Possibility to read the cell from an external file ",& repeats=.FALSE., usage="CELL_FILE_NAME ",& - type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CELL_FILE_FORMAT",& description="Specify the format of the cell file (if used)",& @@ -169,9 +165,9 @@ RECURSIVE SUBROUTINE create_cell_section(section,periodic,label,error) enum_i_vals=(/do_cell_cp2k,do_cell_xsc/),& enum_desc=s2a("Cell info in the CP2K native format.",& "Cell info in the XSC format (NAMD)" ),& - default_i_val=do_cell_cp2k,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_cell_cp2k) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PERIODIC",& description="Specify the directions for which periodic boundary conditions (PBC) will be applied. "//& @@ -184,18 +180,18 @@ RECURSIVE SUBROUTINE create_cell_section(section,periodic,label,error) enum_i_vals=(/ use_perd_x, use_perd_y, use_perd_z,& use_perd_xy, use_perd_xz, use_perd_yz,& use_perd_xyz, use_perd_none /),& - default_i_val=my_periodic, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=my_periodic) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MULTIPLE_UNIT_CELL",& description="Specifies the numbers of repetition in space (X, Y, Z) of the defined cell, "//& "assuming it as a unit cell. This keyword affects only the CELL specification. The same keyword "//& "in SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL should be modified in order to affect the coordinates "//& "specification.", usage="MULTIPLE_UNIT_CELL 1 1 1", & - n_var=3,default_i_vals=(/1,1,1/),repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,default_i_vals=(/1,1,1/),repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SYMMETRY",& description="Imposes an initial cell symmetry.",& @@ -216,28 +212,24 @@ RECURSIVE SUBROUTINE create_cell_section(section,periodic,label,error) enum_i_vals=(/cell_sym_none,cell_sym_triclinic,cell_sym_monoclinic,cell_sym_orthorhombic,& cell_sym_tetragonal_ab,cell_sym_tetragonal_ac,cell_sym_tetragonal_bc,& cell_sym_tetragonal_ab,cell_sym_rhombohedral,cell_sym_hexagonal,cell_sym_cubic/),& - default_i_val=cell_sym_none,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=cell_sym_none) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) IF (TRIM(my_label)=="CELL") THEN - CALL create_cell_section(subsection,periodic,"CELL_REF",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cell_section(subsection,periodic,"CELL_REF") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END IF END SUBROUTINE create_cell_section ! ***************************************************************************** !> \brief Creates the random number restart section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_rng_section(section,error) + SUBROUTINE create_rng_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_rng_section', & routineP = moduleN//':'//routineN @@ -247,18 +239,17 @@ SUBROUTINE create_rng_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RNG_INIT",& description="Information to initialize the parallel random number generator streams",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify an initial RNG stream record",repeats=.TRUE.,& - usage="{RNG record string}",type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{RNG record string}",type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_rng_section @@ -266,13 +257,10 @@ END SUBROUTINE create_rng_section !> \brief creates the structure of a subsys, i.e. a full set of !> atoms+mol+bounds+cell !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_subsys_section(section,error) + SUBROUTINE create_subsys_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_subsys_section', & routineP = moduleN//':'//routineN @@ -282,78 +270,74 @@ SUBROUTINE create_subsys_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="subsys",& description="a subsystem: coordinates, topology, molecules and cell",& - n_keywords=0, n_subsections=9, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=9, repeats=.FALSE.) NULLIFY(subsection) - CALL create_rng_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_rng_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_cell_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cell_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_coord_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_coord_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_velocity_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_velocity_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_kind_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_kind_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_topology_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_topology_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_colvar_section(section=subsection,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_colvar_section(section=subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_multipole_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_multipole_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_shell_coord_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_shell_coord_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_shell_vel_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_shell_vel_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_core_coord_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_core_coord_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_core_vel_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_core_vel_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_subsys_print_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_subsys_print_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_subsys_section ! ***************************************************************************** !> \brief Creates the subsys print section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_subsys_print_section(section,error) + SUBROUTINE create_subsys_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_subsys_print_section', & routineP = moduleN//':'//routineN @@ -365,245 +349,240 @@ SUBROUTINE create_subsys_print_section(section,error) failure=.FALSE. NULLIFY(print_key, keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Controls printings related to the subsys",& - n_keywords=0, n_subsections=9, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=9, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"atomic_coordinates",& description="controls the output of the atomic coordinates when setting up the"//& "force environment. For printing coordinates during MD or GEO refer to the keyword"//& " trajectory.",unit_str="angstrom",& - print_level=medium_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_structure_data_section(print_key, error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL create_structure_data_section(print_key) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"interatomic_distances",& description="controls the output of the interatomic distances when setting up the"//& "force environment",unit_str="angstrom",& - print_level=debug_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key, "topology_info", description=& "controls the printing of information in the topology settings", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) + print_level=high_print_level,filename="__STD_OUT__") CALL keyword_create(keyword,"xtl_info",& description="Prints information when parsing XTL files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"cif_info",& description="Prints information when parsing CIF files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"pdb_info",& description="Prints information when parsing PDB files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"xyz_info",& description="Prints information when parsing XYZ files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"psf_info",& description="Prints information when parsing PSF files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"amber_info",& description="Prints information when parsing ABER topology files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"g96_info",& description="Prints information when parsing G96 files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"crd_info",& description="Prints information when parsing CRD files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"gtop_info",& description="Prints information when parsing GROMOS topology files.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"util_info",& description="Prints information regarding topology utilities",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"generate_info",& description="Prints information regarding topology generation",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"cell",& description="controls the output of the cell parameters",& print_level=medium_print_level, filename="__STD_OUT__",& - unit_str="angstrom",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + unit_str="angstrom") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"kinds",& description="controls the output of information on the kinds",& - print_level=medium_print_level, filename="__STD_OUT__",error=error) + print_level=medium_print_level, filename="__STD_OUT__") CALL keyword_create(keyword, name="potential",& description="If the printkey is activated controls the printing of the"//& " fist_potential, gth_potential or all electron"//& " potential information",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="basis_set",& description="If the printkey is activated controls the printing of basis set information",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="se_parameters",& description="If the printkey is activated controls the printing of the semi-empirical parameters.",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SYMMETRY",& description="controls the output of symmetry information",& - print_level=debug_print_level+1, filename="__STD_OUT__",error=error) + print_level=debug_print_level+1, filename="__STD_OUT__") CALL keyword_create(keyword, name="MOLECULE",& description="Assume the system is an isolated molecule",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_GEO",& description="Accuracy required for symmetry detection",& - default_r_val=1.e-4_dp, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.e-4_dp) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STANDARD_ORIENTATION",& description="Print molecular coordinates in standard orientation",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INERTIA",& description="Print molecular inertia tensor",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SYMMETRY_ELEMENTS",& description="Print symmetry elements",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALL",& description="Print all symmetry information",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROTATION_MATRICES",& description="All the rotation matrices of the point group",& - default_l_val=.FALSE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHECK_SYMMETRY",& description="Check if calculated symmetry has expected value."//& " Use either Schoenfliess or Hermann-Maugin symbols",& - default_c_val="NONE", error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_c_val="NONE") + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"molecules",& description="controls the output of information on the molecules",& - print_level=medium_print_level, filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level, filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"radii",& description="controls the output of radii information",unit_str="angstrom",& - print_level=high_print_level, filename="__STD_OUT__",error=error) + print_level=high_print_level, filename="__STD_OUT__") CALL keyword_create(keyword, name="core_charges_radii",& description="If the printkey is activated controls the printing of the radii of the core charges",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="pgf_radii",& description="If the printkey is activated controls the printing of the core gaussian radii",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="set_radii",& description="If the printkey is activated controls the printing of the set_radii",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="kind_radii",& description="If the printkey is activated controls the printing of the kind_radii",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="core_charge_radii",& description="If the printkey is activated controls the printing of the core_charge_radii",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="gth_ppl_radii",& description="If the printkey is activated controls the printing of the "//& "gth pseudo potential local radii",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="gth_ppnl_radii",& description="If the printkey is activated controls the printing of the "//& "gth pseudo potential non local radii",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="gapw_prj_radii",& description="If the printkey is activated controls the printing of the gapw projector radii",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_subsys_print_section ! ***************************************************************************** !> \brief Creates the multipole section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_multipole_section(section,error) + SUBROUTINE create_multipole_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_multipole_section', & routineP = moduleN//':'//routineN @@ -614,41 +593,38 @@ SUBROUTINE create_multipole_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="multipoles",& description="Specifies the dipoles and quadrupoles for particles.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL section_create(subsection,name="dipoles",& description="Specifies the dipoles of the particles.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The dipole components for each atom in the format:"//& "

    Dx Dy Dz

    ",& repeats=.TRUE., usage="{Real} {Real} {Real}",& - type_of_var=real_t, n_var=3, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + type_of_var=real_t, n_var=3) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="quadrupoles",& description="Specifies the quadrupoles of the particles.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The quadrupole components for each atom in the format:"//& "

    Qxx Qxy Qxz Qyy "//& "Qyz Qzz

    ",& repeats=.TRUE., usage="{Real} {Real} {Real} {Real} {Real} {Real}",& - type_of_var=real_t, n_var=6, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + type_of_var=real_t, n_var=6) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_multipole_section @@ -656,12 +632,9 @@ END SUBROUTINE create_multipole_section !> \brief creates structure data section for output.. both subsys (for initialization) !> and motion section.. !> \param print_key ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE create_structure_data_section(print_key,error) + SUBROUTINE create_structure_data_section(print_key) TYPE(section_type), POINTER :: print_key - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_structure_data_section', & @@ -671,7 +644,7 @@ SUBROUTINE create_structure_data_section(print_key,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(print_key),cp_failure_level,routineP,failure) NULLIFY(keyword) @@ -679,58 +652,55 @@ SUBROUTINE create_structure_data_section(print_key,error) CALL cp_print_key_section_create(print_key,name="STRUCTURE_DATA",& description="Request the printing of special structure data during a structure "//& "optimization (in MOTION%PRINT) or when setting up a subsys (in SUBSYS%PRINT).",& - print_level=high_print_level,filename="__STD_OUT__",unit_str="angstrom",error=error) + print_level=high_print_level,filename="__STD_OUT__",unit_str="angstrom") CALL keyword_create(keyword, name="POSITION", variants=(/"POS"/),& description="Print the position vectors in Cartesian coordinates of the atoms specified "//& "by a list of their indices",& usage="POSITION {integer} {integer} {integer}..{integer}",n_var=-1,repeats=.TRUE.,& - type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POSITION_SCALED",variants=(/"POS_SCALED"/),& description="Print the position vectors in scaled coordinates of the atoms specified "//& "by a list of their indices",& usage="POSITION_SCALED {integer} {integer} {integer}..{integer}",n_var=-1,repeats=.TRUE.,& - type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="DISTANCE",variants=(/"DIS"/),& description="Print the distance between the atoms a and b specified by their indices",& usage="DISTANCE {integer} {integer}",n_var=2,repeats=.TRUE.,& - type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="ANGLE",variants=(/"ANG"/),& description="Print the angle formed by the atoms specified by their indices",& usage="ANGLE {integer} {integer} {integer}",n_var=3, repeats=.TRUE.,& - type_of_var=integer_t, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIHEDRAL_ANGLE",variants=s2a("DIHEDRAL","DIH"),& description="Print the dihedral angle between the planes defined by the atoms (a,b,c) and "//& "the atoms (b,c,d) specified by their indices",& usage="DIHEDRAL_ANGLE {integer} {integer} {integer} {integer}",n_var=4,& - repeats=.TRUE.,type_of_var=integer_t,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.,type_of_var=integer_t) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_structure_data_section ! ***************************************************************************** !> \brief Creates the velocity section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_velocity_section(section,error) + SUBROUTINE create_velocity_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_velocity_section', & routineP = moduleN//':'//routineN @@ -740,31 +710,29 @@ SUBROUTINE create_velocity_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="velocity",& description="The velocities for simple systems or "//& "the centroid mode in PI runs, xyz format by default",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="PINT_UNIT",& description="Specify the units of measurement for the velocities "//& "(currently works only for the path integral code). "//& "All available CP2K units can be used.",& usage="UNIT angstrom*au_t^-1",& - default_c_val="bohr*au_t^-1",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="bohr*au_t^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The atomic velocities in the format:"//& "

    vx vy vz

    "//& "The same order as for the atomic coordinates is assumed.",& repeats=.TRUE., usage="{Real} {Real} {Real}",& - type_of_var=real_t, n_var=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_velocity_section @@ -772,13 +740,10 @@ END SUBROUTINE create_velocity_section ! ***************************************************************************** !> \brief Creates the shell velocity section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_shell_vel_section(section,error) + SUBROUTINE create_shell_vel_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_shell_vel_section', & routineP = moduleN//':'//routineN @@ -788,12 +753,11 @@ SUBROUTINE create_shell_vel_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="shell_velocity",& description="The velocities of shells for shell-model potentials, "//& "in xyz format ",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& @@ -801,9 +765,9 @@ SUBROUTINE create_shell_vel_section(section,error) "

    vx vy vz

    "//& "The same order as for the shell particle coordinates is assumed.",& repeats=.TRUE., usage="{Real} {Real} {Real}",& - type_of_var=real_t, n_var=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_shell_vel_section @@ -811,13 +775,10 @@ END SUBROUTINE create_shell_vel_section ! ***************************************************************************** !> \brief Creates the shell velocity section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_core_vel_section(section,error) + SUBROUTINE create_core_vel_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_core_vel_section', & routineP = moduleN//':'//routineN @@ -827,12 +788,11 @@ SUBROUTINE create_core_vel_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="core_velocity",& description="The velocities of cores for shell-model potentials, "//& "in xyz format ",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& @@ -840,9 +800,9 @@ SUBROUTINE create_core_vel_section(section,error) "

    vx vy vz

    "//& "The same order as for the core particle coordinates is assumed.",& repeats=.TRUE., usage="{Real} {Real} {Real}",& - type_of_var=real_t, n_var=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_core_vel_section @@ -850,13 +810,10 @@ END SUBROUTINE create_core_vel_section ! ***************************************************************************** !> \brief Creates the &POTENTIAL section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_potential_section(section,error) + SUBROUTINE create_potential_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_potential_section', & routineP = moduleN//':'//routineN @@ -868,27 +825,23 @@ SUBROUTINE create_potential_section(section,error) CALL section_create(section,name="potential",& description="Section used to specify Potentials.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="CP2K Pseudo Potential Standard Format (GTH, ALL)",& - repeats=.TRUE.,type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.,type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_potential_section ! ***************************************************************************** !> \brief Creates the &KG_POTENTIAL section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author JGH ! ***************************************************************************** - SUBROUTINE create_kgpot_section(section,error) + SUBROUTINE create_kgpot_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_kgpot_section', & routineP = moduleN//':'//routineN @@ -900,27 +853,23 @@ SUBROUTINE create_kgpot_section(section,error) CALL section_create(section,name="kg_potential",& description="Section used to specify KG Potentials.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="CP2K KG TNADD Potential Standard Format (TNADD)",& - repeats=.TRUE.,type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.,type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_kgpot_section ! ***************************************************************************** !> \brief Creates the &BASIS section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_basis_section(section,error) + SUBROUTINE create_basis_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_basis_section', & routineP = moduleN//':'//routineN @@ -932,20 +881,19 @@ SUBROUTINE create_basis_section(section,error) CALL section_create(section,name="BASIS",& description="Section used to specify a general basis set for QM calculations.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="The type of basis set defined in this section.",& lone_keyword_c_val="Orbital",& - usage="Orbital",default_c_val="Orbital", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="Orbital",default_c_val="Orbital") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& - repeats=.TRUE., type_of_var=lchar_t, error=error,& + repeats=.TRUE., type_of_var=lchar_t,& description="CP2K Basis Set Standard Format"//newline//& "
    "//newline//&
      "Element symbol  Name of the basis set  Alias names"//newline//&
@@ -969,21 +917,18 @@ SUBROUTINE create_basis_section(section,error)
      "c        : Contraction coefficient"//newline//&
      "
    "//newline//& "Source: ftp://ftp.aip.org/epaps/journ_chem_phys/E-JCPSA6-127-308733/BASIS_MOLOPT_JCP.txt") - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_basis_section ! ***************************************************************************** !> \brief Creates the &COORD section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_coord_section(section,error) + SUBROUTINE create_coord_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_coord_section', & routineP = moduleN//':'//routineN @@ -993,28 +938,26 @@ SUBROUTINE create_coord_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="coord",& description="The coordinates for simple systems (like the QM ones)"//& " xyz format by default. More complex systems should be given with"//& " an external pdb file.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="UNIT",& description='Specify the unit of measurement for the coordinates in input'//& "All available CP2K units can be used.",& - usage="UNIT angstrom",default_c_val="angstrom",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="UNIT angstrom",default_c_val="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALED",& description='Specify if the coordinateds in input are scaled.',& usage="SCALED F",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The atomic coordinates in the format:"//& @@ -1022,21 +965,18 @@ SUBROUTINE create_coord_section(section,error) "The MOLNAME is optional. If not provided the molecule name "//& "is internally created. All other fields after MOLNAME are simply ignored.",& repeats=.TRUE., usage="{{String} {Real} {Real} {Real} {String}}",& - type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_coord_section ! ***************************************************************************** !> \brief Creates the &SHELL_COORD section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_shell_coord_section(section,error) + SUBROUTINE create_shell_coord_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_shell_coord_section', & routineP = moduleN//':'//routineN @@ -1046,36 +986,34 @@ SUBROUTINE create_shell_coord_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="shell_coord",& description="The shell coordinates for the shell-model potentials"//& " xyz format with an additional column for the index of the corresponding particle",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="UNIT",& description='Specify the unit of measurement for the coordinates in input'//& "All available CP2K units can be used.",& - usage="UNIT angstrom",default_c_val="angstrom",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="UNIT angstrom",default_c_val="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALED",& description='Specify if the coordinateds in input are scaled.',& usage="SCALED F",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The shell particle coordinates in the format:"//& "

    ATOMIC_KIND X Y Z ATOMIC_INDEX

    "//& "The ATOMIC_INDEX refers to the atom the shell particle belongs to.",& repeats=.TRUE., usage="{{String} {Real} {Real} {Real} {Integer}}",& - type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_shell_coord_section @@ -1083,13 +1021,10 @@ END SUBROUTINE create_shell_coord_section ! ***************************************************************************** !> \brief Creates the &core_COORD section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_core_coord_section(section,error) + SUBROUTINE create_core_coord_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_core_coord_section', & routineP = moduleN//':'//routineN @@ -1099,36 +1034,34 @@ SUBROUTINE create_core_coord_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="core_coord",& description="The core coordinates for the shell-model potentials"//& " xyz format with an additional column for the index of the corresponding particle",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="UNIT",& description='Specify the unit of measurement for the coordinates in input'//& "All available CP2K units can be used.",& - usage="UNIT angstrom",default_c_val="angstrom",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="UNIT angstrom",default_c_val="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SCALED",& description='Specify if the coordinateds in input are scaled.',& usage="SCALED F",default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="The core particle coordinates in the format:"//& "

    ATOMIC_KIND X Y Z ATOMIC_INDEX

    "//& "The ATOMIC_INDEX refers to the atom the core particle belongs to.",& repeats=.TRUE., usage="{{String} {Real} {Real} {Real} {Integer}}",& - type_of_var=lchar_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_core_coord_section @@ -1136,13 +1069,10 @@ END SUBROUTINE create_core_coord_section ! ***************************************************************************** !> \brief Creates the QM/MM section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_kind_section(section,error) + SUBROUTINE create_kind_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_kind_section', & routineP = moduleN//':'//routineN @@ -1153,28 +1083,27 @@ SUBROUTINE create_kind_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="KIND",& description="The description of the kind of the atoms (mostly for QM)",& - n_keywords=19, n_subsections=1, repeats=.TRUE., & - error=error) + n_keywords=19, n_subsections=1, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="The name of the kind described in this section.",& - usage="H", default_c_val="DEFAULT", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="H", default_c_val="DEFAULT") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIS_SET",& description="The primary Gaussian basis set (NONE implies no basis used, meaningful with GHOST)",& usage="BASIS_SET [type] DZVP", type_of_var=char_t, default_c_vals=(/" "," "/), & citations=(/VandeVondele2005a,VandeVondele2007/),& - repeats=.TRUE., n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE., n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! old type basis set input keywords ! kept for back compatability @@ -1182,126 +1111,117 @@ SUBROUTINE create_kind_section(section,error) variants=s2a("AUXILIARY_BASIS_SET", "AUX_BASIS"),& description="DEPRECATED (use BASIS_SET): The auxliliary basis set (GTO type)",& usage="AUX_BASIS_SET DZVP", default_c_val=" ", & - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RI_AUX_BASIS_SET",& variants=s2a("RI_MP2_BASIS_SET","RI_RPA_BASIS_SET", "RI_AUX_BASIS"),& description="DEPRECATED (use BASIS_SET): The RI auxliliary basis set used in WF_CORRELATION (GTO type)",& usage="RI_AUX_BASIS_SET DZVP", default_c_val=" ", & - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LRI_BASIS_SET",& variants=s2a("LRI_BASIS"),& description="DEPRECATED (use BASIS_SET): The local resolution of identity basis set (GTO type)",& usage="LRI_BASIS_SET DZVP", default_c_val=" ", & - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AUX_FIT_BASIS_SET",& variants=s2a("AUXILIARY_FIT_BASIS_SET", "AUX_FIT_BASIS"),& description="DEPRECATED (use BASIS_SET): The auxliliary basis set (GTO type) for auxiliary density matrix method",& usage="AUX_FIT_BASIS_SET DZVP", default_c_val=" ", & citations=(/Guidon2010/),& - n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! end of old basis set keywords CALL keyword_create(keyword, name="ELEC_CONF",& description="Specifies the electronic configration used in construction the "// & "atomic initial guess (see the pseudo potential file for the default values.",& usage="ELEC_COND n_elec(s) n_elec(p) n_elec(d) ... ", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORE_CORRECTION",& description="Corrects the effective nuclear charge",& usage="CORE_CORRECTION 1.0", n_var=1, & - default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ELEMENT",& variants=(/ "ELEMENT_SYMBOL" /),& description="The element of the actual kind "//& "(if not given it is inferred from the kind name)",& - usage="ELEMENT O", type_of_var=char_t,n_var=1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ELEMENT O", type_of_var=char_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MASS",& variants=s2a("ATOMIC_MASS", "ATOMIC_WEIGHT", "WEIGHT"),& description="The mass of the atom "//& "(if negative or non present it is inferred from the element symbol)",& - usage="MASS 2.0", type_of_var=real_t,n_var=1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MASS 2.0", type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POTENTIAL",& variants=(/ "POT" /),& description="The name of the pseudopotential for the defined kind.",& usage="POTENTIAL ", default_c_val="GTH", n_var=1,& - citations=(/Goedecker1996, Hartwigsen1998, Krack2005/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + citations=(/Goedecker1996, Hartwigsen1998, Krack2005/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KG_POTENTIAL",& variants=(/ "KG_POT" /),& description="The name of the non-additive atomic kinetic energy potential.",& - usage="KG_POTENTIAL ", default_c_val="NONE", n_var=1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="KG_POTENTIAL ", default_c_val="NONE", n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HARD_EXP_RADIUS",& description="The region where the hard density is supposed to be confined"//& "(GAPW)(in Bohr, default is 1.2 for H and 1.512 otherwise)",& - usage="HARD_EXP_RADIUS 0.9", type_of_var=real_t,n_var=1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="HARD_EXP_RADIUS 0.9", type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_RAD_LOCAL",& description="Max radius for the basis functions used to"//& " generate the local projectors in GAPW [Bohr]",& - usage="MAX_RAD_LOCAL 15.0", default_r_val=13.0_dp*bohr,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_RAD_LOCAL 15.0", default_r_val=13.0_dp*bohr) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RHO0_EXP_RADIUS",& description="the radius which defines the atomic region where "//& "the hard compensation density is confined."//& "should be less than HARD_EXP_RADIUS (GAPW)(Bohr, default equals HARD_EXP_RADIUS)",& - usage="RHO_EXP_RADIUS 0.9", type_of_var=real_t,n_var=1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RHO_EXP_RADIUS 0.9", type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LEBEDEV_GRID",& description="The number of points for the angular part of "//& "the local grid (GAPW)",& - usage="LEBEDEV_GRID 40", default_i_val=50,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="LEBEDEV_GRID 40", default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RADIAL_GRID",& description="The number of points for the radial part of "//& "the local grid (GAPW)",& - usage="RADIAL_GRID 70", default_i_val=50,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RADIAL_GRID 70", default_i_val=50) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MM_RADIUS",& description="Defines the radius of the electrostatic multipole "//& @@ -1314,40 +1234,38 @@ SUBROUTINE create_kind_section(section,error) "shell is treated as a Gaussian and the core is always a point "//& "charge.",& usage="MM_RADIUS {real}", default_r_val=0.0_dp, type_of_var=real_t,& - unit_str="angstrom", n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom", n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DFTB3_PARAM",& description="The third order parameter (derivative of hardness) used in "//& "diagonal DFTB3 correction.",& - usage="DFTB3_PARAM 0.2", default_r_val=0.0_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DFTB3_PARAM 0.2", default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAO",& description="The number of MAOs (Modified Atomic Orbitals) for this kind.",& - usage="MAO 4", default_i_val=-1,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAO 4", default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Logicals CALL keyword_create(keyword, name="SE_P_ORBITALS_ON_H",& description="Forces the usage of p-orbitals on H for SEMI-EMPIRICAL calculations. "//& " This keyword applies only when the KIND is specifying an Hydrogen element. In all "//& " other cases is simply ignored. ",& - usage="SE_P_ORBITALS_ON_H",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SE_P_ORBITALS_ON_H",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GPW_TYPE",& description="Force one type to be treated by the GPW scheme,"//& " whatever are its primitives, even if the GAPW method is used",& - usage="GPW_TYPE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GPW_TYPE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="GHOST",& @@ -1357,10 +1275,9 @@ SUBROUTINE create_kind_section(section,error) "or to have a non-interacting particle with BASIS_SET NONE",& usage="GHOST",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="NO_OPTIMIZE",& @@ -1368,31 +1285,30 @@ SUBROUTINE create_kind_section(section,error) " potential optimization schemes",& usage="NO_OPTIMIZE",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_basis_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_basis_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_potential_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_potential_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_kgpot_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_kgpot_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_dft_plus_u_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_dft_plus_u_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_bs_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_bs_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_kind_section @@ -1402,15 +1318,13 @@ END SUBROUTINE create_kind_section !> different from default in initialization of the density matrix !> it works only with GUESS ATOMIC !> \param section ... -!> \param error ... !> \date 05.08.2009 !> \author MI !> \version 1.0 ! ***************************************************************************** - SUBROUTINE create_bs_section(section,error) + SUBROUTINE create_bs_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_bs_section', & routineP = moduleN//':'//routineN @@ -1421,7 +1335,7 @@ SUBROUTINE create_bs_section(section,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,& @@ -1432,8 +1346,7 @@ SUBROUTINE create_bs_section(section,error) "It works only with GUESS ATOMIC.",& n_keywords=0,& n_subsections=2,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) NULLIFY (keyword,subsection) @@ -1442,16 +1355,14 @@ SUBROUTINE create_bs_section(section,error) description="controls the activation of the BS section",& usage="&BS ON",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="ALPHA",description="alpha spin",& n_keywords=3,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) CALL keyword_create(keyword,& name="NEL",& @@ -1460,10 +1371,9 @@ SUBROUTINE create_bs_section(section,error) repeats=.FALSE.,& n_var=-1,& default_i_val=-1,& - usage="NEL 2",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NEL 2") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="L",& @@ -1473,10 +1383,9 @@ SUBROUTINE create_bs_section(section,error) repeats=.FALSE.,& n_var=-1,& default_i_val=-1,& - usage="L 2",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="L 2") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="N",& @@ -1487,18 +1396,16 @@ SUBROUTINE create_bs_section(section,error) repeats=.FALSE.,& n_var=-1,& default_i_val=0,& - usage="N 2",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="N 2") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="BETA",description="beta spin",& n_keywords=3,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) CALL keyword_create(keyword,& name="NEL",& @@ -1507,10 +1414,9 @@ SUBROUTINE create_bs_section(section,error) repeats=.FALSE.,& n_var=-1,& default_i_val=-1,& - usage="NEL 2",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NEL 2") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="L",& @@ -1520,10 +1426,9 @@ SUBROUTINE create_bs_section(section,error) repeats=.FALSE.,& n_var=-1,& default_i_val=-1,& - usage="L 2",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="L 2") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="N",& @@ -1534,13 +1439,12 @@ SUBROUTINE create_bs_section(section,error) repeats=.FALSE.,& n_var=-1,& default_i_val=0,& - usage="N 2",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N 2") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_bs_section @@ -1549,13 +1453,10 @@ END SUBROUTINE create_bs_section !> \brief Create the topology section for FIST.. and the base is running running... !> Contains all information regarding topology to be read in input file.. !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_topology_section(section,error) + SUBROUTINE create_topology_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_topology_section', & routineP = moduleN//':'//routineN @@ -1566,12 +1467,11 @@ SUBROUTINE create_topology_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="TOPOLOGY",& description="Section specifying information regarding how to handle the topology"// & " for classical runs.",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, print_key) ! Logical @@ -1579,55 +1479,54 @@ SUBROUTINE create_topology_section(section,error) variants=(/ "CHARGE_O" /),& description="Read MM charges from the OCCUP field of PDB file.",& usage="CHARGE_OCCUP logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE_BETA",& variants=(/ "CHARGE_B" /),& description="Read MM charges from the BETA field of PDB file.",& usage="CHARGE_BETA logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE_EXTENDED",& description="Read MM charges from the very last field of PDB file (starting from column 81)."//& " No limitations of number of digits.",& usage="CHARGE_EXTENDED logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARA_RES",& description="For a protein, each residue is now considered a molecule",& usage="PARA_RES logical",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOL_CHECK",& description="Check molecules have the same number of atom and names.",& usage="MOL_CHECK logical",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_G96_VELOCITY",& description="Use the velocities in the G96 coordinate files as the starting velocity",& usage="USE_G96_VELOCITY logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Character CALL keyword_create(keyword, name="COORD_FILE_NAME",& variants=s2a("COORD_FILE"),& description="Specifies the filename that contains coordinates.",& - usage="COORD_FILE_NAME ",type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="COORD_FILE_NAME ",type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COORD_FILE_FORMAT",& variants=s2a("COORDINATE"),& @@ -1646,9 +1545,9 @@ SUBROUTINE create_topology_section(section,error) "Coordinates provided through a XTL (MSI native) file format",& "Read the coordinates in CP2K &COORD section format from an external file. "//& "NOTE: This file will be overwritten with the latest coordinates."),& - default_i_val=do_coord_off,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_coord_off) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUMBER_OF_ATOMS",& variants=s2a("NATOMS","NATOM"),& @@ -1658,37 +1557,36 @@ SUBROUTINE create_topology_section(section,error) n_var=1,& type_of_var=integer_t,& default_i_val=-1,& - usage="NATOMS 768000",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NATOMS 768000") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL connectivity_framework(section, do_conn_generate, error) + CALL connectivity_framework(section, do_conn_generate) CALL keyword_create(keyword, name="DISABLE_EXCLUSION_LISTS",& description="Do not build any exclusion lists.",& usage="DISABLE_EXCLUSION_LISTS",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_VDW",& description="Specifies which kind of Van der Waals interaction to skip.",& usage="EXCLUDE_VDW (1-1||1-2||1-3||1-4)", & enum_c_vals=s2a("1-1","1-2","1-3","1-4"),& enum_i_vals=(/do_skip_11,do_skip_12,do_skip_13, do_skip_14/),& - default_i_val=do_skip_13,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_skip_13) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXCLUDE_EI",& description="Specifies which kind of Electrostatic interaction to skip.",& usage="EXCLUDE_EI (1-1||1-2||1-3||1-4)", & enum_c_vals=s2a("1-1","1-2","1-3","1-4"),& enum_i_vals=(/do_skip_11,do_skip_12,do_skip_13, do_skip_14/),& - default_i_val=do_skip_13,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_skip_13) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AUTOGEN_EXCLUDE_LISTS",& description="When True, the exclude lists are solely based on"//& @@ -1704,83 +1602,83 @@ SUBROUTINE create_topology_section(section,error) " not to be in the exclusion list, in case 1-4"//& " exclusion is requested for VDW or EI interactions.",& usage="AUTOGEN_EXCLUDE_LISTS logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MULTIPLE_UNIT_CELL",& description="Specifies the numbers of repetition in space (X, Y, Z) of the defined cell, "//& "assuming it as a unit cell. This keyword affects only the coordinates specification. The same keyword "//& "in SUBSYS%CELL%MULTIPLE_UNIT_CELL should be modified in order to affect the cell "//& "specification.", usage="MULTIPLE_UNIT_CELL 1 1 1", & - n_var=3,default_i_vals=(/1,1,1/),repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=3,default_i_vals=(/1,1,1/),repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MEMORY_PROGRESSION_FACTOR",& description="This keyword is quite technical and should normally not be changed by the user. It "//& "affects the memory allocation during the construction of the topology. It does NOT affect the "//& "memory used once the topology is built.",& - n_var=1,default_r_val=1.2_dp,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1,default_r_val=1.2_dp,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"DUMP_PDB",& description="controls the dumping of the PDB at the starting geometry",& - print_level=debug_print_level, filename="dump",error=error) - CALL section_add_subsection(section,print_key,error=error) + print_level=debug_print_level, filename="dump") + CALL section_add_subsection(section,print_key) CALL keyword_create(keyword, name="CHARGE_OCCUP",& variants=(/"CHARGE_O"/),& description="Write the MM charges to the OCCUP field of the PDB file",& usage="CHARGE_OCCUP logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE_BETA",& variants=(/"CHARGE_B"/),& description="Write the MM charges to the BETA field of the PDB file",& usage="CHARGE_BETA logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CHARGE_EXTENDED",& description="Write the MM charges to the very last field of the PDB file (starting from column 81)",& usage="CHARGE_EXTENDED logical",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) - CALL section_release(print_key,error=error) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"DUMP_PSF",& description="controls the dumping of the PSF connectivity",& - print_level=debug_print_level, filename="dump",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level, filename="dump") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) NULLIFY(subsection) - CALL create_exclude_list_section(subsection, "EXCLUDE_VDW_LIST", error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_exclude_list_section(subsection, "EXCLUDE_VDW_LIST") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_exclude_list_section(subsection, "EXCLUDE_EI_LIST", error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_exclude_list_section(subsection, "EXCLUDE_EI_LIST") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_center_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection, error=error) + CALL create_center_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_generate_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_generate_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_molset_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_molset_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_topology_section @@ -1788,14 +1686,11 @@ END SUBROUTINE create_topology_section !> \brief Setup a list of fine exclusion elements !> \param section the section to create !> \param header ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - 12.2009 ! ***************************************************************************** - SUBROUTINE create_exclude_list_section(section, header, error) + SUBROUTINE create_exclude_list_section(section, header) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: header - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_exclude_list_section', & routineP = moduleN//':'//routineN @@ -1804,7 +1699,7 @@ SUBROUTINE create_exclude_list_section(section, header, error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword) CALL section_create(section,TRIM(header),& description="Speficy bonds (via atom kinds) for fine tuning of 1-2 "//& @@ -1812,27 +1707,23 @@ SUBROUTINE create_exclude_list_section(section, header, error) "applied to all bond kinds. When this section is present the 1-2 exclusion "//& "is applied ONLY to the bonds defined herein. This section allows ONLY fine tuning of 1-2 "//& "interactions. ",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="BOND",& description="Specify the atom kinds involved in the bond for which 1-2 exclusion holds.",& usage="BOND {KIND1} {KIND2}", type_of_var=char_t,& - n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_exclude_list_section ! ***************************************************************************** !> \brief Specify keywords used to center molecule in the box !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 06.2009 ! ***************************************************************************** - SUBROUTINE create_center_section(section,error) + SUBROUTINE create_center_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_center_section', & routineP = moduleN//':'//routineN @@ -1841,41 +1732,36 @@ SUBROUTINE create_center_section(section,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword) CALL section_create(section,"CENTER_COORDINATES",& description="Allows centering the coordinates of the system in the box. "//& "The centering point can be defined by the user.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Controls the activation of the centering method",& usage="&CENTER_COORDINATES T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CENTER_POINT",& description="Specify the point used for centering the coordinates. Default is to "//& "center the system in cell/2. ", type_of_var=real_t, n_var=3,& - repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_center_section ! ***************************************************************************** !> \brief Specify keywords used to setup several molecules with few connectivity files !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 08.2008 ! ***************************************************************************** - SUBROUTINE create_molset_section(section,error) + SUBROUTINE create_molset_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_molset_section', & routineP = moduleN//':'//routineN @@ -1885,88 +1771,84 @@ SUBROUTINE create_molset_section(section,error) TYPE(section_type), POINTER :: subsection, subsubsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword, subsection, subsubsection) CALL section_create(section,name="MOL_SET",& description="Specify the connectivity of a full system specifying the connectivity"//& " of the fragments of the system.",& - n_keywords=2, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) ! MOLECULES CALL section_create(subsection,name="MOLECULE",& description="Specify information about the connectivity of single molecules",& - n_keywords=2, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="NMOL",& description="number of molecules ",& - usage="NMOL {integer}", default_i_val=1,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NMOL {integer}", default_i_val=1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL connectivity_framework(subsection, do_conn_psf, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL connectivity_framework(subsection, do_conn_psf) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! MERGE MOLECULES CALL section_create(subsection,name="MERGE_MOLECULES",& description="Enables the creation of connecting bridges (bonds, angles, torsions, impropers)"//& " between the two or more molecules defined with independent connectivity.",& - n_keywords=2, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL section_create(subsubsection,name="bonds",& - description="Defines new bonds",n_keywords=2, n_subsections=0, repeats=.FALSE.,& - error=error) + description="Defines new bonds",n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Two integer indexes per line defining the new bond."//& " Indexes must be relative to the full system and not to the single molecules",& repeats=.TRUE.,& - usage="{Integer} {Integer}", type_of_var=integer_t, n_var=2, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection, subsubsection, error=error) - CALL section_release(subsubsection,error=error) + usage="{Integer} {Integer}", type_of_var=integer_t, n_var=2) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection, subsubsection) + CALL section_release(subsubsection) CALL section_create(subsubsection,name="angles",& description="Defines new angles",n_keywords=2, n_subsections=0,& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Three integer indexes per line defining the new angle"//& " Indexes must be relative to the full system and not to the single molecules",repeats=.TRUE.,& - usage="{Integer} {Integer} {Integer}", type_of_var=integer_t, n_var=3, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection, subsubsection, error=error) - CALL section_release(subsubsection,error=error) + usage="{Integer} {Integer} {Integer}", type_of_var=integer_t, n_var=3) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection, subsubsection) + CALL section_release(subsubsection) CALL section_create(subsubsection,name="torsions",& description="Defines new torsions",n_keywords=2, n_subsections=0,& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Four integer indexes per line defining the new torsion"//& " Indexes must be relative to the full system and not to the single molecules",repeats=.TRUE.,& - usage="{Integer} {Integer} {Integer} {Integer}", type_of_var=integer_t, n_var=4, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection, subsubsection, error=error) - CALL section_release(subsubsection,error=error) + usage="{Integer} {Integer} {Integer} {Integer}", type_of_var=integer_t, n_var=4) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection, subsubsection) + CALL section_release(subsubsection) CALL section_create(subsubsection,name="impropers",& description="Defines new impropers",n_keywords=2, n_subsections=0,& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Four integer indexes per line defining the new improper"//& " Indexes must be relative to the full system and not to the single molecules",repeats=.TRUE.,& - usage="{Integer} {Integer} {Integer} {Integer}", type_of_var=integer_t, n_var=4, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection, subsubsection, error=error) - CALL section_release(subsubsection,error=error) + usage="{Integer} {Integer} {Integer} {Integer}", type_of_var=integer_t, n_var=4) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection, subsubsection) + CALL section_release(subsubsection) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_molset_section @@ -1974,13 +1856,10 @@ END SUBROUTINE create_molset_section ! ***************************************************************************** !> \brief Specify keywords used to generate connectivity !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 08.2008 ! ***************************************************************************** - SUBROUTINE create_generate_section(section,error) + SUBROUTINE create_generate_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_generate_section', & routineP = moduleN//':'//routineN @@ -1990,28 +1869,27 @@ SUBROUTINE create_generate_section(section,error) TYPE(section_type), POINTER :: subsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword,subsection) CALL section_create(section,name="GENERATE",& description="Setup of keywords controlling the generation of the connectivity",& - n_keywords=2, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="REORDER",& description="Reorder a list of atomic coordinates into order so it can be packed correctly.",& usage="REORDER ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CREATE_MOLECULES",& description="Create molecules names and definition. Can be used to override the "//& " molecules specifications of a possible input connectivity or to create molecules"//& " specifications for file types as XYZ, missing of molecules definitions.",& usage="CREATE_MOLECULES ",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BONDPARM",& description="Used in conjunction with BONDPARM_FACTOR to "//& @@ -2021,176 +1899,164 @@ SUBROUTINE create_generate_section(section,error) usage="BONDPARM (COVALENT||VDW)", & enum_c_vals=s2a( "COVALENT", "VDW"),& enum_i_vals=(/do_bondparm_covalent, do_bondparm_vdw/),& - default_i_val=do_bondparm_covalent,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_bondparm_covalent) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BONDPARM_FACTOR",& description="Used in conjunction with BONDPARM to help "//& "determine wheather there is bonding between "//& "two atoms based on a distance criteria.",& - usage="bondparm_factor {real}", default_r_val=1.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="bondparm_factor {real}", default_r_val=1.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="BONDLENGTH_MAX",& description="Maximum distance to generate neighbor lists to build connectivity",& usage="BONDLENGTH_MAX ",default_r_val=cp_unit_to_cp2k(value=3.0_dp,& - unit_str="angstrom",error=error),unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="BONDLENGTH_MIN",& description="Minimum distance to generate neighbor lists to build connectivity",& usage="BONDLENGTH_MIN ",default_r_val=cp_unit_to_cp2k(value=0.01_dp,& - unit_str="angstrom",error=error),unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom"),unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! BONDS CALL section_create(subsection,name="BOND",& description="Section used to add/remove bonds in the connectivity."//& " Useful for systems with a complex connectivity, difficult to find out automatically.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the bond",& usage="&BOND (ADD|REMOVE)",& enum_c_vals=s2a("ADD","REMOVE"),& enum_i_vals=(/do_add,do_remove/),& - default_i_val=do_add,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_add) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies two atomic index united by a covalent bond",& usage="ATOMS {integer} {integer}", type_of_var=integer_t, n_var=2,& - repeats=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! ANGLES CALL section_create(subsection,name="ANGLE",& description="Section used to add/remove angles in the connectivity."//& " Useful for systems with a complex connectivity, difficult to find out automatically.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the bond",& usage="&ANGLE (ADD|REMOVE)",& enum_c_vals=s2a("ADD","REMOVE"),& enum_i_vals=(/do_add,do_remove/),& - default_i_val=do_add,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_add) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies two atomic index united by a covalent bond",& usage="ATOMS {integer} {integer} {integer} ", type_of_var=integer_t, n_var=3,& - repeats=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! TORSIONS CALL section_create(subsection,name="TORSION",& description="Section used to add/remove torsion in the connectivity."//& " Useful for systems with a complex connectivity, difficult to find out automatically.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the bond",& usage="&TORSION (ADD|REMOVE)",& enum_c_vals=s2a("ADD","REMOVE"),& enum_i_vals=(/do_add,do_remove/),& - default_i_val=do_add,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_add) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies two atomic index united by a covalent bond",& usage="ATOMS {integer} {integer} {integer} {integer} ", type_of_var=integer_t, n_var=4,& - repeats=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! IMPROPERS CALL section_create(subsection,name="IMPROPER",& description="Section used to add/remove improper in the connectivity."//& " Useful for systems with a complex connectivity, difficult to find out automatically.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="controls the activation of the bond",& usage="&IMPROPER (ADD|REMOVE)",& enum_c_vals=s2a("ADD","REMOVE"),& enum_i_vals=(/do_add,do_remove/),& - default_i_val=do_add,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_add) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies two atomic index united by a covalent bond",& usage="ATOMS {integer} {integer} {integer} {integer} ", type_of_var=integer_t, n_var=4,& - repeats=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! ISOLATED ATOMS CALL section_create(subsection,name="ISOLATED_ATOMS",& description=" This section specifies the atoms that one considers isolated. Useful when present "//& - " ions in solution.",n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + " ions in solution.",n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="LIST",& description="Specifies a list of atomic indexes of the isolated ion",& usage="LIST {integer}", type_of_var=integer_t, n_var=-1,& - repeats=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! Neighbor lists keys and printing handling the construction of NL for the connectivity - CALL create_neighbor_lists_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_neighbor_lists_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_gen_print_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_gen_print_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_generate_section ! ***************************************************************************** !> \brief Create the print gen section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_gen_print_section(section,error) + SUBROUTINE create_gen_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gen_print_section', & routineP = moduleN//':'//routineN @@ -2199,27 +2065,25 @@ SUBROUTINE create_gen_print_section(section,error) TYPE(section_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Section of possible print options in GENERATE code.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"NEIGHBOR_LISTS",& description="Activates the printing of the neighbor lists used"//& " for generating the connectivity.", print_level=high_print_level,& - filename="", unit_str="angstrom", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="", unit_str="angstrom") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SUBCELL",& description="Activates the printing of the subcells used for the"//& "generation of neighbor lists for connectivity.", & - print_level=high_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_gen_print_section @@ -2227,14 +2091,11 @@ END SUBROUTINE create_gen_print_section !> \brief Specify keywords used to define connectivity !> \param section the section to create !> \param default ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE connectivity_framework(section,default,error) + SUBROUTINE connectivity_framework(section,default) TYPE(section_type), POINTER :: section INTEGER, INTENT(IN) :: default - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'connectivity_framework', & routineP = moduleN//':'//routineN @@ -2243,14 +2104,14 @@ SUBROUTINE connectivity_framework(section,default,error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(keyword) CALL keyword_create(keyword, name="CONN_FILE_NAME",& variants=(/"CONN_FILE"/),& description="Specifies the filename that contains the molecular connectivity.",& - usage="CONN_FILE_NAME ",type_of_var=lchar_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CONN_FILE_NAME ",type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CONN_FILE_FORMAT",& variants=(/"CONNECTIVITY"/),& @@ -2279,23 +2140,21 @@ SUBROUTINE connectivity_framework(section,default,error) "Allows the definition of molecules and residues based on the 5th and 6th column of "//& "the COORD section. This option can be handy for the definition of molecules with QS "//& "or to save memory in the case of very large systems (use PARA_RES off)."),& - default_i_val=default,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=default) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE connectivity_framework ! ***************************************************************************** !> \brief Create CP2K input section for the DFT+U method parameters !> \param section ... -!> \param error ... !> \date 01.11.2007 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE create_dft_plus_u_section(section,error) + SUBROUTINE create_dft_plus_u_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_dft_plus_u_section', & routineP = moduleN//':'//routineN @@ -2306,7 +2165,7 @@ SUBROUTINE create_dft_plus_u_section(section,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,& @@ -2314,8 +2173,7 @@ SUBROUTINE create_dft_plus_u_section(section,error) description="Define the parameters for a DFT+U run",& n_keywords=3,& n_subsections=1,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) NULLIFY (keyword) @@ -2324,10 +2182,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) description="Controls the activation of the DFT+U section",& usage="&DFT_PLUS_U ON",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="L",& @@ -2337,10 +2194,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) n_var=1,& type_of_var=integer_t,& default_i_val=-1,& - usage="L 2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="L 2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="U_MINUS_J",& @@ -2350,10 +2206,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) type_of_var=real_t,& default_r_val=0.0_dp,& unit_str="au_e",& - usage="U_MINUS_J [eV] 1.4",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="U_MINUS_J [eV] 1.4") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="U_RAMPING",& @@ -2364,10 +2219,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) type_of_var=real_t,& default_r_val=0.0_dp,& unit_str="au_e",& - usage="U_RAMPING [eV] 0.1",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="U_RAMPING [eV] 0.1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="EPS_U_RAMPING",& @@ -2377,10 +2231,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=1.0E-5_dp,& - usage="EPS_U_RAMPING 1.0E-6",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_U_RAMPING 1.0E-6") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="INIT_U_RAMPING_EACH_SCF",& @@ -2389,10 +2242,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) repeats=.FALSE.,& default_l_val=.FALSE.,& lone_keyword_l_val=.TRUE.,& - usage="INIT_U_RAMPING_EACH_SCF on",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="INIT_U_RAMPING_EACH_SCF on") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY (subsection) @@ -2404,18 +2256,16 @@ SUBROUTINE create_dft_plus_u_section(section,error) "inadequate parameter choice can easily inhibit SCF convergence.",& n_keywords=5,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) CALL keyword_create(keyword,& name="_SECTION_PARAMETERS_",& description="Controls the activation of the ENFORCE_OCCUPATION section",& usage="&ENFORCE_OCCUPATION ON",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="ORBITALS",& @@ -2426,10 +2276,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) n_var=-1,& type_of_var=integer_t,& default_i_val=0,& - usage="ORBITALS 0 +1 -1",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ORBITALS 0 +1 -1") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="EPS_SCF",& @@ -2439,10 +2288,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) n_var=1,& type_of_var=real_t,& default_r_val=1.0E30_dp,& - usage="EPS_SCF 0.001",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_SCF 0.001") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="MAX_SCF",& @@ -2451,10 +2299,9 @@ SUBROUTINE create_dft_plus_u_section(section,error) n_var=1,& type_of_var=integer_t,& default_i_val=-1,& - usage="MAX_SCF 5",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_SCF 5") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="SMEAR",& @@ -2462,13 +2309,12 @@ SUBROUTINE create_dft_plus_u_section(section,error) repeats=.FALSE.,& default_l_val=.FALSE.,& lone_keyword_l_val=.TRUE.,& - usage="SMEAR ON",& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SMEAR ON") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_dft_plus_u_section diff --git a/src/input_cp2k_thermostats.F b/src/input_cp2k_thermostats.F index 0a7f872b51..242f457fe7 100644 --- a/src/input_cp2k_thermostats.F +++ b/src/input_cp2k_thermostats.F @@ -61,14 +61,11 @@ MODULE input_cp2k_thermostats !> \brief Specifies parameter for thermostat for constant temperature ensembles !> \param section will contain the coeff section !> \param coupled_thermostat ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo [tlaino] - University of Zurich - 09.2007 ! ***************************************************************************** - SUBROUTINE create_thermo_slow_section(section, coupled_thermostat, error) + SUBROUTINE create_thermo_slow_section(section, coupled_thermostat) TYPE(section_type), POINTER :: section LOGICAL, INTENT(IN), OPTIONAL :: coupled_thermostat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_thermo_slow_section', & routineP = moduleN//':'//routineN @@ -79,14 +76,14 @@ SUBROUTINE create_thermo_slow_section(section, coupled_thermostat, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) my_coupled_thermostat = .FALSE. IF (PRESENT(coupled_thermostat)) my_coupled_thermostat = coupled_thermostat NULLIFY(nose_section, region_section) CALL section_create(section,name="THERMOSTAT_SLOW",& description="Specify thermostat type and parameters controlling the thermostat.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) IF (.NOT.my_coupled_thermostat) THEN @@ -96,10 +93,9 @@ SUBROUTINE create_thermo_slow_section(section, coupled_thermostat, error) default_i_val=do_thermo_nose,& enum_c_vals=s2a("NOSE"),& enum_i_vals=(/do_thermo_nose/),& - enum_desc=s2a("Uses only the Nose-Hoover thermostat."),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_desc=s2a("Uses only the Nose-Hoover thermostat.")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REGION",& description="Determines the defined region for slow thermostat",& @@ -107,13 +103,13 @@ SUBROUTINE create_thermo_slow_section(section, coupled_thermostat, error) enum_c_vals=s2a( "GLOBAL", "MOLECULE", "MASSIVE", "DEFINED", "NONE"),& enum_i_vals=(/do_region_global, do_region_molecule,& do_region_massive, do_region_defined, do_region_none/),& - default_i_val=do_region_global,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_region_global) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_region_section(region_section,"slow thermostat",error=error) - CALL section_add_subsection(section, region_section, error=error) - CALL section_release(region_section,error=error) + CALL create_region_section(region_section,"slow thermostat") + CALL section_add_subsection(section, region_section) + CALL section_release(region_section) ELSE CALL keyword_create(keyword, name="TYPE",& description="Specify the thermostat used for the constant temperature ensembles.",& @@ -123,20 +119,19 @@ SUBROUTINE create_thermo_slow_section(section, coupled_thermostat, error) enum_i_vals=(/do_thermo_same_as_part,do_thermo_nose,do_thermo_csvr/),& enum_desc=s2a("Use the same kind of thermostat used for particles.",& "Uses the Nose-Hoover thermostat.",& - "Uses the canonical sampling through velocity rescaling."),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Uses the canonical sampling through velocity rescaling.")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END IF - CALL create_nose_section(nose_section, error=error) - CALL section_add_subsection(section, nose_section, error=error) - CALL section_release(nose_section,error=error) + CALL create_nose_section(nose_section) + CALL section_add_subsection(section, nose_section) + CALL section_release(nose_section) ! Print Section -! CALL create_print_section(subsection, error=error) -! CALL section_add_subsection(section, subsection, error=error) -! CALL section_release(subsection,error=error) +! CALL create_print_section(subsection) +! CALL section_add_subsection(section, subsection) +! CALL section_release(subsection) END SUBROUTINE create_thermo_slow_section @@ -144,14 +139,11 @@ END SUBROUTINE create_thermo_slow_section !> \brief Specifies parameter for thermostat for constant temperature ensembles !> \param section will contain the coeff section !> \param coupled_thermostat ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo [tlaino] - University of Zurich - 09.2007 ! ***************************************************************************** - SUBROUTINE create_thermo_fast_section(section, coupled_thermostat, error) + SUBROUTINE create_thermo_fast_section(section, coupled_thermostat) TYPE(section_type), POINTER :: section LOGICAL, INTENT(IN), OPTIONAL :: coupled_thermostat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_thermo_fast_section', & routineP = moduleN//':'//routineN @@ -162,14 +154,14 @@ SUBROUTINE create_thermo_fast_section(section, coupled_thermostat, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) my_coupled_thermostat = .FALSE. IF (PRESENT(coupled_thermostat)) my_coupled_thermostat = coupled_thermostat NULLIFY(nose_section, region_section) CALL section_create(section,name="THERMOSTAT_FAST",& description="Specify thermostat type and parameters controlling the thermostat.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) IF (.NOT.my_coupled_thermostat) THEN @@ -179,10 +171,9 @@ SUBROUTINE create_thermo_fast_section(section, coupled_thermostat, error) default_i_val=do_thermo_nose,& enum_c_vals=s2a("NOSE"),& enum_i_vals=(/do_thermo_nose/),& - enum_desc=s2a("Uses only the Nose-Hoover thermostat."),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_desc=s2a("Uses only the Nose-Hoover thermostat.")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REGION",& description="Determines the defined region for fast thermostat",& @@ -190,13 +181,13 @@ SUBROUTINE create_thermo_fast_section(section, coupled_thermostat, error) enum_c_vals=s2a( "GLOBAL", "MOLECULE", "MASSIVE", "DEFINED", "NONE"),& enum_i_vals=(/do_region_global, do_region_molecule,& do_region_massive, do_region_defined, do_region_none/),& - default_i_val=do_region_global,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_region_global) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_region_section(region_section,"fast thermostat",error=error) - CALL section_add_subsection(section, region_section, error=error) - CALL section_release(region_section,error=error) + CALL create_region_section(region_section,"fast thermostat") + CALL section_add_subsection(section, region_section) + CALL section_release(region_section) ELSE CALL keyword_create(keyword, name="TYPE",& description="Specify the thermostat used for the constant temperature ensembles.",& @@ -206,20 +197,19 @@ SUBROUTINE create_thermo_fast_section(section, coupled_thermostat, error) enum_i_vals=(/do_thermo_same_as_part,do_thermo_nose,do_thermo_csvr/),& enum_desc=s2a("Use the same kind of thermostat used for particles.",& "Uses the Nose-Hoover thermostat.",& - "Uses the canonical sampling through velocity rescaling."),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Uses the canonical sampling through velocity rescaling.")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END IF - CALL create_nose_section(nose_section, error=error) - CALL section_add_subsection(section, nose_section, error=error) - CALL section_release(nose_section,error=error) + CALL create_nose_section(nose_section) + CALL section_add_subsection(section, nose_section) + CALL section_release(nose_section) ! Print Section -! CALL create_print_section(subsection, error=error) -! CALL section_add_subsection(section, subsection, error=error) -! CALL section_release(subsection,error=error) +! CALL create_print_section(subsection) +! CALL section_add_subsection(section, subsection) +! CALL section_release(subsection) END SUBROUTINE create_thermo_fast_section @@ -228,14 +218,11 @@ END SUBROUTINE create_thermo_fast_section !> \brief Specifies parameter for thermostat for constant temperature ensembles !> \param section will contain the coeff section !> \param coupled_thermostat ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo [tlaino] - University of Zurich - 09.2007 ! ***************************************************************************** - SUBROUTINE create_thermostat_section(section, coupled_thermostat, error) + SUBROUTINE create_thermostat_section(section, coupled_thermostat) TYPE(section_type), POINTER :: section LOGICAL, INTENT(IN), OPTIONAL :: coupled_thermostat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_thermostat_section', & routineP = moduleN//':'//routineN @@ -248,14 +235,14 @@ SUBROUTINE create_thermostat_section(section, coupled_thermostat, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) my_coupled_thermostat = .FALSE. IF (PRESENT(coupled_thermostat)) my_coupled_thermostat = coupled_thermostat NULLIFY(csvr_section, gle_section, al_section, nose_section, subsection, region_section) CALL section_create(section,name="THERMOSTAT",& description="Specify thermostat type and parameters controlling the thermostat.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) IF (.NOT.my_coupled_thermostat) THEN @@ -269,10 +256,9 @@ SUBROUTINE create_thermostat_section(section, coupled_thermostat, error) enum_desc=s2a("Uses the Nose-Hoover thermostat.",& "Uses the canonical sampling through velocity rescaling.",& "Uses GLE thermostat",& - "Uses adaptive-Langevin thermostat"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Uses adaptive-Langevin thermostat")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REGION",& description="Determines the region each thermostat is attached to.",& @@ -280,13 +266,13 @@ SUBROUTINE create_thermostat_section(section, coupled_thermostat, error) enum_c_vals=s2a( "GLOBAL", "MOLECULE", "MASSIVE", "DEFINED", "NONE"),& enum_i_vals=(/do_region_global, do_region_molecule,& do_region_massive, do_region_defined, do_region_none/),& - default_i_val=do_region_global,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_region_global) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_region_section(region_section,"thermostat",error=error) - CALL section_add_subsection(section, region_section, error=error) - CALL section_release(region_section,error=error) + CALL create_region_section(region_section,"thermostat") + CALL section_add_subsection(section, region_section) + CALL section_release(region_section) ELSE CALL keyword_create(keyword, name="TYPE",& description="Specify the thermostat used for the constant temperature ensembles.",& @@ -296,44 +282,41 @@ SUBROUTINE create_thermostat_section(section, coupled_thermostat, error) enum_i_vals=(/do_thermo_same_as_part,do_thermo_nose,do_thermo_csvr/),& enum_desc=s2a("Use the same kind of thermostat used for particles.",& "Uses the Nose-Hoover thermostat.",& - "Uses the canonical sampling through velocity rescaling."),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Uses the canonical sampling through velocity rescaling.")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END IF - CALL create_nose_section(nose_section, error=error) - CALL section_add_subsection(section, nose_section, error=error) - CALL section_release(nose_section,error=error) + CALL create_nose_section(nose_section) + CALL section_add_subsection(section, nose_section) + CALL section_release(nose_section) - CALL create_csvr_section(csvr_section, error=error) - CALL section_add_subsection(section, csvr_section, error=error) - CALL section_release(csvr_section,error=error) + CALL create_csvr_section(csvr_section) + CALL section_add_subsection(section, csvr_section) + CALL section_release(csvr_section) - CALL create_gle_section(gle_section, error=error) - CALL section_add_subsection(section, gle_section, error=error) - CALL section_release(gle_section,error=error) + CALL create_gle_section(gle_section) + CALL section_add_subsection(section, gle_section) + CALL section_release(gle_section) - CALL create_al_section(al_section, error=error) - CALL section_add_subsection(section, al_section, error=error) - CALL section_release(al_section,error=error) + CALL create_al_section(al_section) + CALL section_add_subsection(section, al_section) + CALL section_release(al_section) ! Print Section - CALL create_print_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_print_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_thermostat_section ! ***************************************************************************** !> \brief Creates print section for thermostat section !> \param section ... -!> \param error ... !> \author teo [tlaino] - University of Zurich - 02.2008 ! ***************************************************************************** - SUBROUTINE create_print_section(section, error) + SUBROUTINE create_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_section', & routineP = moduleN//':'//routineN @@ -343,48 +326,44 @@ SUBROUTINE create_print_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(print_key) CALL section_create(section,name="PRINT",& description="Collects all print_keys for thermostat",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"THERMOSTAT_INFO",& description="Controls output information of the corresponding thermostat.", & print_level=low_print_level, common_iter_levels=1,& - filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"TEMPERATURE",& description="Controls the output of the temperatures of the regions corresponding to "//& "the present thermostat", & print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ENERGY",& description="Controls the output of kinetic energy, and potential energy "//& " of the defined thermostat.", print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_section ! ***************************************************************************** !> \brief Creates a section to arbitrary define a region to thermostat !> \param section will contain the coeff section !> \param label ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_region_section(section, label, error) + SUBROUTINE create_region_section(section, label) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: label - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_region_section', & routineP = moduleN//':'//routineN @@ -394,29 +373,28 @@ SUBROUTINE create_region_section(section, label, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DEFINE_REGION",& description="This section provides the possibility to define arbitrary region "//& " for the "//TRIM(label)//".",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="LIST",& description="Specifies a list of atoms to thermostat.",& usage="LIST {integer} {integer} .. {integer}", repeats=.TRUE.,& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLNAME",& variants=(/"SEGNAME"/),& description="Specifies the name of the molecules to thermostat",& usage="MOLNAME WAT MEOH", repeats=.TRUE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MM_SUBSYS",& variants=(/"PROTEIN"/),& @@ -427,9 +405,9 @@ SUBROUTINE create_region_section(section, label, error) enum_desc=s2a("Thermostat nothing",& "Only the MM atoms itself",& "The full molecule/residue that contains a MM atom"),& - default_i_val=do_constr_none,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_constr_none,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="QM_SUBSYS",& description="In a QM/MM run all QM atoms are specified as a whole ensemble to be thermostated",& @@ -439,22 +417,19 @@ SUBROUTINE create_region_section(section, label, error) "Only the QM atoms itself",& "The full molecule/residue that contains a QM atom"),& enum_i_vals=(/do_constr_none,do_constr_atomic,do_constr_molec/),& - default_i_val=do_constr_none,repeats=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_constr_none,repeats=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_region_section ! ***************************************************************************** !> \brief ... !> \param section will contain the ewald section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author gloria ! ***************************************************************************** - SUBROUTINE create_nose_section(section, error) + SUBROUTINE create_nose_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_nose_section', & routineP = moduleN//':'//routineN @@ -465,59 +440,56 @@ SUBROUTINE create_nose_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="nose",& description="paramameters of the Nose Hoover thermostat chain",& - citations=(/Nose1984a,Nose1984b/),error=error) + citations=(/Nose1984a,Nose1984b/)) NULLIFY(keyword,subsection) CALL keyword_create(keyword, name="length",& description="length of the Nose-Hoover chain", usage="length integer", & - default_i_val=3,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Yoshida",& description="order of the yoshida integretor used for the thermostat",& usage="Yoshida integer", & - default_i_val=3,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="timecon",& description="timeconstant of the thermostat chain",& usage="timecon ", & - default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs",error=error),& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs"),& + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="mts", & variants=s2a("multiple_time_steps","mult_t_steps"),& description="number of multiple timesteps to be used for the NoseHoover chain",& usage="mts integer", & - default_i_val=2,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_coord_section(subsection,"NOSE HOOVER",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_coord_section(subsection,"NOSE HOOVER") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_velocity_section(subsection,"NOSE HOOVER",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_velocity_section(subsection,"NOSE HOOVER") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_mass_section(subsection,"NOSE HOOVER",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mass_section(subsection,"NOSE HOOVER") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_force_section(subsection,"NOSE HOOVER",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_force_section(subsection,"NOSE HOOVER") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_nose_section @@ -526,13 +498,11 @@ END SUBROUTINE create_nose_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... !> \param !> \author ! ***************************************************************************** - SUBROUTINE create_gle_section(section, error) + SUBROUTINE create_gle_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gle_section', & routineP = moduleN//':'//routineN @@ -543,62 +513,60 @@ SUBROUTINE create_gle_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="GLE",& description="paramameters of the gle thermostat. This section can be generated "//& " from https://epfl-cosmo.github.io/gle4md/index.html?page=matrix ",& - citations=(/Ceriotti2009,Ceriotti2009b/),error=error) + citations=(/Ceriotti2009,Ceriotti2009b/)) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="NDIM",& description="Size of the gle matrix", usage="NDIM 6", & - default_i_val=5, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="A_SCALE",& description="scaling factor for matrix A (for generic matrix A, depends "//& "on the characteristic frequency of the system).", usage="A_SCALE 0.5", & - default_r_val=cp_unit_to_cp2k(1.0_dp,"ps^-1",error=error), unit_str="ps^-1", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(1.0_dp,"ps^-1"), unit_str="ps^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="A_LIST",& description="A matrix The defaults give optimal sampling for most "//& "cristalline and liquid compounds. Generated with the parameters set kv_4-4.a"//& "centered on w_0=40 cm^-1.", usage="A_LIST real real real", & type_of_var=real_t, unit_str="internal_cp2k",& - n_var=-1, repeats=.TRUE., & + n_var=-1, repeats=.TRUE.) ! default_r_vals=(/ & ! 1.859575861256e+2_dp, 2.726385349840e-1_dp, 1.152610045461e+1_dp, -3.641457826260e+1_dp, 2.317337581602e+2_dp, & ! -2.780952471206e-1_dp, 8.595159180871e-5_dp, 7.218904801765e-1_dp, -1.984453934386e-1_dp, 4.240925758342e-1_dp, & ! -1.482580813121e+1_dp, -7.218904801765e-1_dp, 1.359090212128e+0_dp, 5.149889628035e+0_dp, -9.994926845099e+0_dp, & ! -1.037218912688e+1_dp, 1.984453934386e-1_dp, -5.149889628035e+0_dp, 2.666191089117e+1_dp, 1.150771549531e+1_dp, & ! 2.180134636042e+2_dp, -4.240925758342e-1_dp, 9.994926845099e+0_dp, -1.150771549531e+1_dp, 3.095839456559e+2_dp /), & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="C_LIST",& description="C matrix", usage="C_LIST real real real", & unit_str="K_e",& - type_of_var=real_t, n_var=-1, repeats=.TRUE., & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_thermo_energy_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_thermo_energy_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_rng_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_rng_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_gles_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_gles_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_gle_section @@ -606,13 +574,10 @@ END SUBROUTINE create_gle_section ! ***************************************************************************** !> \brief Creates the gles section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_gles_section(section,error) + SUBROUTINE create_gles_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_gles_section', & routineP = moduleN//':'//routineN @@ -622,31 +587,27 @@ SUBROUTINE create_gles_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="s",& description="The s variable for GLE used for restart",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify s variable for GLE thermostat ",repeats=.FALSE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_gles_section ! ***************************************************************************** !> \brief ... !> \param section will contain the ewald section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo [tlaino] - University of Zurich - 09.2007 ! ***************************************************************************** - SUBROUTINE create_csvr_section(section, error) + SUBROUTINE create_csvr_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_csvr_section', & routineP = moduleN//':'//routineN @@ -657,10 +618,10 @@ SUBROUTINE create_csvr_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="csvr",& description="Parameters of the canonical sampling through velocity rescaling thermostat.",& - citations=(/Bussi2007/),error=error) + citations=(/Bussi2007/)) NULLIFY(keyword, subsection) @@ -670,31 +631,28 @@ SUBROUTINE create_csvr_section(section, error) "initial equilibrations) and a large time constant would be adequate "//& "to get weak thermostatting in production runs.",& usage="timecon ", & - default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs",error=error),& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs"),& + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_thermo_energy_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_thermo_energy_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_rng_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_rng_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_csvr_section ! ***************************************************************************** !> \brief ... !> \param section will contain the adaptive langevin section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Noam [bernstei] ! ***************************************************************************** - SUBROUTINE create_al_section(section, error) + SUBROUTINE create_al_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_al_section', & routineP = moduleN//':'//routineN @@ -705,14 +663,14 @@ SUBROUTINE create_al_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ad_langevin",& description="Parameters of the adaptive-Langevin thermostat."//& " Known to work with NVT ensemble, but not tested with"//& " other ensembles. Also tested with FIXED_ATOMS constraints, but"//& " may not work with other constraints (restraints should be OK, but"//& " haven't been well tested)",& - citations=(/Jones2011/),error=error) + citations=(/Jones2011/)) NULLIFY(keyword, subsection) @@ -722,10 +680,10 @@ SUBROUTINE create_al_section(section, error) "initial equilibrations) and a large time constant would be adequate "//& "to get weak thermostatting in production runs.",& usage="timecon_nh ", & - default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs",error=error),& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs"),& + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="timecon_langevin",& description="Time constant of the Langevin part of the AD_LANGEVIN thermostat. A small time "//& @@ -733,18 +691,18 @@ SUBROUTINE create_al_section(section, error) "initial equilibrations) and a large time constant would be adequate "//& "to get weak thermostatting in production runs.",& usage="timecon_langevin ", & - default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs",error=error),& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs"),& + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_thermo_chi_mass_section(subsection,"CHI",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_thermo_chi_mass_section(subsection,"CHI") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_thermo_chi_mass_section(subsection,"MASS",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_thermo_chi_mass_section(subsection,"MASS") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_al_section @@ -753,14 +711,11 @@ END SUBROUTINE create_al_section !> \brief Creates the thermostat chi restarting section !> \param section the section to create !> \param sec_name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_thermo_chi_mass_section(section,sec_name,error) + SUBROUTINE create_thermo_chi_mass_section(section,sec_name) TYPE(section_type), POINTER :: section CHARACTER(len=*) :: sec_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_thermo_chi_mass_section', & @@ -771,32 +726,28 @@ SUBROUTINE create_thermo_chi_mass_section(section,sec_name,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name=TRIM(sec_name),& description="Information to initialize the Ad-Langevin thermostat DOF "//TRIM(sec_name),& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify an initial thermostat DOF "//TRIM(sec_name)//& " for Ad-Langevin thermostat.",repeats=.TRUE.,& - unit_str="fs^-1",type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="fs^-1",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_thermo_chi_mass_section ! ***************************************************************************** !> \brief Creates the thermostat energy restarting section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_thermo_energy_section(section,error) + SUBROUTINE create_thermo_energy_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_thermo_energy_section', & routineP = moduleN//':'//routineN @@ -806,18 +757,17 @@ SUBROUTINE create_thermo_energy_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="THERMOSTAT_ENERGY",& description="Information to initialize the CSVR thermostat energy.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify an initial thermostat energy for CSVR thermostat.",& - repeats=.TRUE., unit_str="internal_cp2k",type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE., unit_str="internal_cp2k",type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_thermo_energy_section @@ -825,14 +775,11 @@ END SUBROUTINE create_thermo_energy_section !> \brief Creates the mass section !> \param section the section to create !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_force_section(section,name,error) + SUBROUTINE create_force_section(section,name) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_force_section', & routineP = moduleN//':'//routineN @@ -842,18 +789,17 @@ SUBROUTINE create_force_section(section,name,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="force",& description="The forces for "//TRIM(name)//" used for restart",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify masses of the system",repeats=.FALSE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_force_section @@ -861,14 +807,11 @@ END SUBROUTINE create_force_section !> \brief Creates the mass section !> \param section the section to create !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_mass_section(section,name,error) + SUBROUTINE create_mass_section(section,name) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mass_section', & routineP = moduleN//':'//routineN @@ -878,18 +821,17 @@ SUBROUTINE create_mass_section(section,name,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="mass",& description="The masses for "//TRIM(name)//" used for restart",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify masses of the system",repeats=.FALSE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mass_section @@ -897,14 +839,11 @@ END SUBROUTINE create_mass_section !> \brief Creates the velocity section !> \param section the section to create !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_velocity_section(section,name,error) + SUBROUTINE create_velocity_section(section,name) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_velocity_section', & routineP = moduleN//':'//routineN @@ -914,18 +853,17 @@ SUBROUTINE create_velocity_section(section,name,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="velocity",& description="The velocities for "//TRIM(name)//" used for restart",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify velocities of the system",repeats=.TRUE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_velocity_section @@ -933,14 +871,11 @@ END SUBROUTINE create_velocity_section !> \brief Creates the coord section !> \param section the section to create !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_coord_section(section,name,error) + SUBROUTINE create_coord_section(section,name) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_coord_section', & routineP = moduleN//':'//routineN @@ -950,18 +885,17 @@ SUBROUTINE create_coord_section(section,name,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="coord",& description="The positions for "//TRIM(name)//" used for restart",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify positions of the system",repeats=.TRUE.,& - usage="{Real} ...", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="{Real} ...", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_coord_section diff --git a/src/input_cp2k_transport.F b/src/input_cp2k_transport.F index 77dbb0c4e5..74a3459cb5 100644 --- a/src/input_cp2k_transport.F +++ b/src/input_cp2k_transport.F @@ -42,11 +42,9 @@ MODULE input_cp2k_transport ! ***************************************************************************** !> \brief creates the TRABSPORT section !> \param[inout] section the section to be created -!> \param[inout] error CP2K error ! ***************************************************************************** - SUBROUTINE create_transport_section(section,error) + SUBROUTINE create_transport_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_transport_section', & routineP = moduleN//':'//routineN @@ -56,12 +54,11 @@ SUBROUTINE create_transport_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"TRANSPORT",& description="Specifies the parameters for transport, sets parameters for the OMEN code, "//& "see also http://www.nano-tcad.ethz.ch/ ",& - n_keywords=19, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=19, n_subsections=0, repeats=.FALSE.) NULLIFY (keyword) @@ -74,118 +71,117 @@ SUBROUTINE create_transport_section(section,error) "transport code",& "experimental code",& "miscellaneous method"),& - enum_i_vals=(/scalapack_diagonalization, do_transport, exper_code, misc_method/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/scalapack_diagonalization, do_transport, exper_code, misc_method/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BANDWIDTH",& description="The number of neighboring unit cells that one unit cell interacts with.",& - usage="BANDWIDTH ", default_i_val=2, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="BANDWIDTH ", default_i_val=2) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_CELLS",& description="The number of unit cells.",& - usage="N_CELLS ", default_i_val=5, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="N_CELLS ", default_i_val=5) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_ABSCISSAE",& description="The number of abscissae per integration interval on the real axis.",& - usage="N_ABSCISSAE ", default_i_val=0, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="N_ABSCISSAE ", default_i_val=0) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_KPOINTS",& description="The number of k points for determination of the singularities.",& - usage="N_KPOINTS ", default_i_val=64, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="N_KPOINTS ", default_i_val=64) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_INTERVAL",& description="Max number of energy points per small interval.",& - usage="NUM_INTERVAL ", default_i_val=10, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="NUM_INTERVAL ", default_i_val=10) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_CONTACTS",& description="The number of contacts.",& - usage="NUM_CONTACTS ", default_i_val=2, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="NUM_CONTACTS ", default_i_val=2) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_DOF",& description="Number of degrees of freedom for the contact unit cell.",& - usage="N_DOF ", default_i_val=0, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="N_DOF ", default_i_val=0) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TASKS_PER_POINT",& description="Minimum number of tasks per energy point.",& - usage="TASKS_PER_POINT ", default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TASKS_PER_POINT ", default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CORES_PER_NODE",& description="Number of cores per node.",& - usage="CORES_PER_NODE ", default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CORES_PER_NODE ", default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COLZERO_THRESHOLD",& description="The smallest number that is not zero in the full diagonalization part.",& - usage="COLZERO_THRESHOLD ", default_r_val=1.0E-12_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="COLZERO_THRESHOLD ", default_r_val=1.0E-12_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_LIMIT",& description="The smallest eigenvalue that is kept.",& - usage="EPS_LIMIT ", default_r_val=1.0E-6_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="EPS_LIMIT ", default_r_val=1.0E-6_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_DECAY",& description="The smallest imaginary part that a decaying eigenvalue may have not to be considered as propagating.",& - usage="EPS_DECAY ", default_r_val=1.0E-6_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_DECAY ", default_r_val=1.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_SINGULARITY_CURVATURES",& description="Filter for degenerate bands in the bandstructure.",& - usage="EPS_SINGULARITY_CURVATURES ", default_r_val=1.0E-12_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="EPS_SINGULARITY_CURVATURES ", default_r_val=1.0E-12_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_MU",& description="Accuracy to which the Fermi level should be determined.",& - usage="EPS_MU ", default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="EPS_MU ", default_r_val=0.0_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_EIGVAL_DEGEN",& description="Filter for degenerate bands in the injection vector.",& - usage="EPS_EIGVAL_DEGEN ", default_r_val=1.0E-4_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="EPS_EIGVAL_DEGEN ", default_r_val=1.0E-4_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY_INTERVAL",& description="Average distance for big intervals in energy vector.",& - usage="ENERGY_INTERVAL ", default_r_val=1.0E-2_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="ENERGY_INTERVAL ", default_r_val=1.0E-2_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MIN_INTERVAL",& description="Smallest enery distance in energy vector.",& - usage="MIN_INTERVAL ", default_r_val=1.0E-4_dp, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="MIN_INTERVAL ", default_r_val=1.0E-4_dp) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE",& description="Temperature.",& - usage="TEMPERATURE [K] 300.0", default_r_val=300.0_dp, unit_str="K", error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="TEMPERATURE [K] 300.0", default_r_val=300.0_dp, unit_str="K") + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROW_DISTRIBUTION",& description="How to distribute matrix rows over tasks.",& @@ -194,15 +190,15 @@ SUBROUTINE create_transport_section(section,error) "Each task holds ceiling(N/TASKS_PER_POINT) rows for a total of N matrix rows",& "Each task holds floor(N/TASKS_PER_POINT) rows for a total of N matrix rows"),& enum_i_vals=(/csr_dbcsr_blkrow_dist,csr_eqrow_ceil_dist,csr_eqrow_floor_dist/),& - default_i_val=csr_dbcsr_blkrow_dist, error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_i_val=csr_dbcsr_blkrow_dist) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CSR_SCREENING",& description="Whether distance screening should be applied to improve sparsity of CSR matrices.",& - default_l_val=.FALSE., lone_keyword_l_val = .TRUE. ,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val = .TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_transport_section diff --git a/src/input_cp2k_xc.F b/src/input_cp2k_xc.F index 7cbcba4f55..4ca503aed3 100644 --- a/src/input_cp2k_xc.F +++ b/src/input_cp2k_xc.F @@ -68,13 +68,10 @@ MODULE input_cp2k_xc ! ***************************************************************************** !> \brief creates the structure of the section needed to select the xc functional !> \param section the section that will be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_xc_fun_section(section,error) + SUBROUTINE create_xc_fun_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_xc_fun_section', & routineP = moduleN//':'//routineN @@ -85,14 +82,13 @@ SUBROUTINE create_xc_fun_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="xc_functional",& description="The xc functional to use",& n_keywords=0, n_subsections=4, repeats=.FALSE., & citations=(/Ortiz1994,Becke1988,Perdew1996,Zhang1998,Lee1988, & Heyd2004,Vosko1980, Goedecker1996,Perdew1981,& - Tao2003,Wellendorff2012/),& - error=error) + Tao2003,Wellendorff2012/)) NULLIFY(subsection,keyword) CALL keyword_create(keyword,name="_SECTION_PARAMETERS_",& @@ -104,206 +100,195 @@ SUBROUTINE create_xc_fun_section(section,error) enum_desc=s2a("B3LYP","PBE0","BLYP","BP","PADE","Alias for PADE","PBE","TPSS","HCTH120","OLYP",& "BEEFVDW","NO_SHORTCUT","NONE"),& default_i_val=xc_funct_no_shortcut,& - lone_keyword_i_val=xc_funct_no_shortcut,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_i_val=xc_funct_no_shortcut) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="BECKE88",& description="Uses the Becke 88 exchange functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Becke1988/),& - error=error) + citations=(/Becke1988/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="LYP_ADIABATIC",& description="Uses the LYP correlation functional in an adiabatic fashion",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Lee1988/),& - error=error) + citations=(/Lee1988/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"LAMBDA",& description="Defines the parameter of the adiabatic curve.",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="BECKE88_LR_ADIABATIC",& description="Uses the Becke 88 longrange exchange functional in an adiabatic fashion",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Becke1988/),& - error=error) + citations=(/Becke1988/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"OMEGA",& description="Potential parameter in erf(omega*r)/r",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"LAMBDA",& description="Defines the parameter of the adiabatic curve",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="BECKE88_LR",& description="Uses the Becke 88 longrange exchange functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Becke1988/),& - error=error) + citations=(/Becke1988/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"OMEGA",& description="Potential parameter in erf(omega*r)/r",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="LYP",& description="Uses the LYP functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Lee1988/),& - error=error) + citations=(/Lee1988/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_c",& description="scales the correlation part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PADE",& description="Uses the PADE functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Goedecker1996/),& - error=error) + citations=(/Goedecker1996/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="HCTH",& description="Uses the HCTH class of functionals",& - n_keywords=0, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,name="PARAMETER_SET",& description="Which version of the parameters should be used",& usage="PARAMETER_SET 407",& enum_c_vals=(/"93 ","120","147","407"/),& enum_i_vals=(/93,120,147,407/),& - default_i_val=120,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=120) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="OPTX",& description="Uses the OPTX functional",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL create_libxc_section(subsection, "LIBXC",& "Uses functionals from LIBXC, see also "//& "http://www.tddft.org/programs/octopus/wiki/index.php/Libxc_functionals ",& - "FUNCTIONAL GGA_X_PBE GGA_C_PBE", error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + "FUNCTIONAL GGA_X_PBE GGA_C_PBE") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL create_libxc_section(subsection, "KE_LIBXC",& "To be used for KG runs. Uses kinetic energy functionals from LIBXC, "//& "see also http://www.tddft.org/programs/octopus/wiki/index.php/Libxc_functionals ",& - "FUNCTIONAL GGA_K_LLP", error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + "FUNCTIONAL GGA_K_LLP") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="CS1",& description="Uses the CS1 functional",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="XGGA",& description="Uses one of the XGGA functionals (optimized versions of "//& "some of these functionals might be available outside this section).",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="FUNCTIONAL",& description="Which one of the XGGA functionals should be used",& usage="FUNCTIONAL PW86X",& @@ -316,24 +301,23 @@ SUBROUTINE create_xc_fun_section(section,error) "OPTX ",& "EV93 "/),& enum_i_vals=(/xgga_b88x,xgga_pw86,xgga_pw91,xgga_pbex,xgga_revpbe,xgga_opt,xgga_ev93/),& - default_i_val=xgga_b88x,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_i_val=xgga_b88x) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="KE_GGA",& description="Uses one of the KE_GGA functionals (optimized versions of "//& "some of these functionals might be available outside this section). "//& "These functionals are needed for the computation of the kinetic "//& "energy in the Kim-Gordon method.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="FUNCTIONAL",& description="Which one of the KE_GGA functionals should be used",& usage="FUNCTIONAL (OL1|OL2|LLP|PW86|PW91|LC|T92|PBE)",& @@ -347,43 +331,41 @@ SUBROUTINE create_xc_fun_section(section,error) "Uses Lembarki and Chermette functional",& "Uses Thakkar functional",& "Uses the 1996 functional of Perdew, Burke and Ernzerhof"),& - default_i_val=ke_llp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_i_val=ke_llp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="P86C",& description="Uses the P86C functional",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_c",& description="scales the correlation part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PW92",& description="Uses the PerdewWang correlation functional.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"SCALE",& description="Scaling of the energy functional",& - default_r_val=1.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="PARAMETRIZATION",& description="Which one of parametrizations should be used",& usage="PARAMETRIZATION DMC",& @@ -392,21 +374,21 @@ SUBROUTINE create_xc_fun_section(section,error) "DMC ",& "VMC "/),& enum_i_vals=(/c_pw92,c_pw92dmc,c_pw92vmc/),& - default_i_val=c_pw92,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_i_val=c_pw92) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PZ81",& description="Uses the PZ functional.",& n_keywords=1, n_subsections=0, repeats=.TRUE., & - citations=(/Perdew1981,Ortiz1994/), error=error) + citations=(/Perdew1981,Ortiz1994/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="PARAMETRIZATION",& description="Which one of parametrizations should be used",& usage="PARAMETRIZATION DMC",& @@ -415,56 +397,53 @@ SUBROUTINE create_xc_fun_section(section,error) "DMC ",& "VMC "/),& enum_i_vals=(/c_pz,c_pzdmc,c_pzvmc/),& - default_i_val=pz_orig,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=pz_orig) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_c",& description="scales the correlation part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="TFW",& description="Uses the TFW functional",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="TF",& description="Uses the TF functional",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="VWN",& description="Uses the VWN functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Vosko1980/),& - error=error) + citations=(/Vosko1980/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_c",& description="scales the correlation part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTIONAL_TYPE",& description="Which version of the VWN functional should be used",& @@ -474,68 +453,66 @@ SUBROUTINE create_xc_fun_section(section,error) enum_desc=s2a("This is the recommended (correct) version of the VWN functional", & "This version is the default in Gaussian, but not recommended."//& "Notice that it is also employed in Gaussian's default version of B3LYP"),& - default_i_val=do_vwn5, error=error) + default_i_val=do_vwn5) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="XALPHA",& description="Uses the XALPHA (SLATER) functional.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="XA",& description="Value of the xa parameter (this does not change the exponent, "//& "just the mixing)",& - usage="XA 0.7", default_r_val=2._dp/3._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="XA 0.7", default_r_val=2._dp/3._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="TPSS",& description="Uses the TPSS functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Tao2003/), error=error) + citations=(/Tao2003/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_c",& description="scales the correlation part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PBE",& description="Uses the PBE functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Perdew1996,Zhang1998,Perdew2008/),& - error=error) + citations=(/Perdew1996,Zhang1998,Perdew2008/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"parametrization",& description="switches between the different "//& "parametrizations of the functional",& @@ -544,200 +521,193 @@ SUBROUTINE create_xc_fun_section(section,error) enum_desc=(/"original PBE ",& "revised PBE (revPBE) ",& "PBE for solids and surfaces (PBEsol)"/),& - default_i_val=xc_pbe_orig,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=xc_pbe_orig) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_c",& description="scales the correlation part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="XWPBE",& description="Uses the short range PBE functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Heyd2004/),& - error=error) + citations=(/Heyd2004/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x0",& description="scales the exchange part of the original hole PBE-functional",& - default_r_val=0.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"omega",& description="screening parameter",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="BECKE97",& description="Uses the Becke 97 exchange correlation functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Becke1997,Grimme2006/),& - error=error) + citations=(/Becke1997,Grimme2006/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional, if -1 the default for the given parametrization is used",& - default_r_val=-1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_c",& description="scales the correlation part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"parametrization",& description="switches between the B97 and Grimme parametrization ",& enum_i_vals=(/xc_b97_orig,xc_b97_grimme,xc_b97_grimme,xc_b97_mardirossian/),& enum_c_vals=(/"ORIG ","B97GRIMME ","B97_GRIMME","wB97X-V "/),& - default_i_val=xc_b97_orig,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=xc_b97_orig) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="BECKE_ROUSSEL",& description="Becke Roussel exchange hole model. Can be used"//& "as long range correction with a truncated coulomb potential",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/BeckeRoussel1989,Proynov2007/),& - error=error) + citations=(/BeckeRoussel1989,Proynov2007/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"CUTOFF_RADIUS",& description="Defines the cutoff radius for the truncation. "//& "If put to zero, the standard full range potential will be used",& - usage="CUTOFF_RADIUS 2.0",default_r_val=0.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CUTOFF_RADIUS 2.0",default_r_val=0.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"GAMMA",& description="Parameter in the exchange hole. "//& "Usually this is put to 1.0 or 0.8",& - usage="GAMMA 0.8",default_r_val=1.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="GAMMA 0.8",default_r_val=1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="LDA_HOLE_T_C_LR",& description="LDA exchange hole model in truncated coulomb potential",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"SCALE_X",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"CUTOFF_RADIUS",& description="Defines cutoff for lower integration boundary",& - default_r_val=0.0_dp,unit_str="angstrom", error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=0.0_dp,unit_str="angstrom") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PBE_HOLE_T_C_LR",& description="PBE exchange hole model in trucanted coulomb potential",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"SCALE_X",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"CUTOFF_RADIUS",& description="Defines cutoff for lower integration boundary",& - default_r_val=1.0_dp,unit_str="angstrom", error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1.0_dp,unit_str="angstrom") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="GV09",& description="Combination of three different exchange hole models",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"SCALE_X",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"CUTOFF_RADIUS",& description="Defines cutoff for lower integration boundary",& - default_r_val=0.0_dp,unit_str="angstrom", error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp,unit_str="angstrom") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"GAMMA",& description="Parameter for Becke Roussel hole",& - default_r_val=1.0_dp, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="BEEF",& !rk: BEEF Exchange description="Uses the BEEFvdW exchange functional",& n_keywords=0, n_subsections=0, repeats=.FALSE., & - citations=(/Wellendorff2012/),& - error=error) + citations=(/Wellendorff2012/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,"scale_x",& description="scales the exchange part of the functional",& - default_r_val=1._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_xc_fun_section ! ***************************************************************************** @@ -746,12 +716,10 @@ END SUBROUTINE create_xc_fun_section !> \param name ... !> \param description ... !> \param usage ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_libxc_section(section,name,description,usage,error) + SUBROUTINE create_libxc_section(section,name,description,usage) TYPE(section_type), POINTER :: section CHARACTER(len=*), INTENT(in) :: name, description, usage - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_libxc_section', & routineP = moduleN//':'//routineN @@ -761,48 +729,45 @@ SUBROUTINE create_libxc_section(section,name,description,usage,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) - CPPrecondition(name == "LIBXC" .OR. name == "KE_LIBXC",cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) + CPPrecondition(name == "LIBXC" .OR. name == "KE_LIBXC",cp_failure_level,routineP,failure) NULLIFY(keyword) CALL section_create(section, name, description,& n_keywords=3, n_subsections=0, repeats=.FALSE., & - citations=(/Marques2012/), error=error) + citations=(/Marques2012/)) CALL keyword_create(keyword,"_SECTION_PARAMETERS_",& description="activates the functional",& - lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="FUNCTIONAL",& description="names of the functionals, see also "//& "http://www.tddft.org/programs/octopus/wiki/index.php/Libxc_functionals ."//& "The precise list of available functionals depends on "//& "the version of libxc interfaced (currently 2.2.2).",& - usage=usage,type_of_var=char_t,n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage=usage,type_of_var=char_t,n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="SCALE",& description="scaling factors of the functionals",& usage="SCALE 1.0 1.0",type_of_var=real_t,& - default_r_vals=(/1.0_dp/),n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/1.0_dp/),n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="PARAMETERS",& description="parameters of the functionals",& - type_of_var=real_t,default_r_vals=(/1e20_dp/),n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_vals=(/1e20_dp/),n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE ! ***************************************************************************** !> \brief creates the structure of the section needed to select an xc potential !> \param section the section that will be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author thomas chassaing ! ***************************************************************************** - SUBROUTINE create_xc_potential_section(section,error) + SUBROUTINE create_xc_potential_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_xc_potential_section', & routineP = moduleN//':'//routineN @@ -813,37 +778,35 @@ SUBROUTINE create_xc_potential_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="xc_potential",& description="The xc potential to use (CAREFUL: xc potential here refers "//& "to potentials that are not derived from an xc functional, but rather are "//& "modelled directly. Therefore there is no consistent xc energy available. "//& "To still get an energy expression, see ENERGY below",& - n_keywords=1, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(subsection,keyword) CALL section_create(subsection,name="SAOP",& description="Uses the SAOP potential",& - n_keywords=3, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=3, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,name="ALPHA",& description="Value of the alpha parameter (default = 1.19).",& - usage="ALPHA 1.19", default_r_val=1.19_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALPHA 1.19", default_r_val=1.19_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="BETA",& description="Value of the beta parameter (default = 0.01).",& - usage="BETA 0.01", default_r_val=0.01_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BETA 0.01", default_r_val=0.01_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="K_RHO",& description="Value of the K_rho parameter (default = 0.42).",& - usage="ALPHA 0.42", default_r_val=0.42_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + usage="ALPHA 0.42", default_r_val=0.42_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="ENERGY",& description="How to determine the total energy.",& @@ -854,22 +817,19 @@ SUBROUTINE create_xc_potential_section(section,error) xc_pot_energy_xc_functional,& xc_pot_energy_sum_eigenvalues,& xc_pot_energy_sum_eigenvalues /),& - default_i_val=xc_pot_energy_none, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=xc_pot_energy_none) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_xc_potential_section ! ***************************************************************************** !> \brief creates the structure of the section needed for vdW potentials !> \param section the section that will be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author jgh ! ***************************************************************************** - SUBROUTINE create_vdw_potential_section(section,error) + SUBROUTINE create_vdw_potential_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_vdw_potential_section', & routineP = moduleN//':'//routineN @@ -880,14 +840,13 @@ SUBROUTINE create_vdw_potential_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="vdw_potential",& description="This section combines all possible additional dispersion "//& "corrections to the normal XC functionals. This can be more functionals "//& "or simple empirical pair potentials. ",& citations=(/grimme2006,Tran2013/),& - n_keywords=1, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(subsection,keyword) CALL keyword_create(keyword, name="POTENTIAL_TYPE",& @@ -899,20 +858,19 @@ SUBROUTINE create_vdw_potential_section(section,error) enum_desc=s2a("No dispersion/van der Waals functional",& "Pair potential van der Waals density functional",& "Nonlocal van der Waals density functional"),& - default_i_val=xc_vdw_fun_none, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=xc_vdw_fun_none) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="PAIR_POTENTIAL",& description="Information on the pair potential to calculate dispersion",& - n_keywords=5, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,name="R_CUTOFF",& description="Range of potential. The cutoff will be 2 times this value",& usage="R_CUTOFF 24.0", default_r_val=20.0_dp,& - unit_str="angstrom",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="TYPE",& description="Type of potential",& citations=(/grimme2006,grimme2010,grimme2011/),& @@ -922,121 +880,120 @@ SUBROUTINE create_vdw_potential_section(section,error) enum_desc=s2a("Grimme D2 method",& "Grimme D3 method (zero damping)",& "Grimme D3 method (Becke-Johnson damping)"),& - default_i_val=vdw_pairpot_dftd3, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=vdw_pairpot_dftd3) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PARAMETER_FILE_NAME",& description="Name of the parameter file, may include a path",& usage="PARAMETER_FILE_NAME ",& - default_lc_val="DISPERSION_PARAMETERS",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="DISPERSION_PARAMETERS") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REFERENCE_FUNCTIONAL",& description="Use parameters for this specific density functional. "& //"For available D3 and D3(BJ) parameters see: "& //"http://www.thch.uni-bonn.de/tc/downloads/DFT-D3/functionals.html, "& //"http://www.thch.uni-bonn.de/tc/downloads/DFT-D3/functionalsbj.html",& usage="REFERENCE_FUNCTIONAL ",& - type_of_var=char_t,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="SCALING",& description="XC Functional dependent scaling parameter, if set to zero CP2K attempts"//& " to guess the xc functional that is in use and sets the associated scaling parameter.",& - usage="SCALING 0.2", default_r_val=0._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SCALING 0.2", default_r_val=0._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="EXP_PRE",& description="Prefactor in exponential damping factor (DFT-D2 potential)",& - usage="EXP_PRE 20.", default_r_val=20._dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EXP_PRE 20.", default_r_val=20._dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="EPS_CN",& description="Cutoff value for coordination number function (DFT-D3 method)",& - usage="EPS_CN 1.e-6_dp", default_r_val=1.e-6_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_CN 1.e-6_dp", default_r_val=1.e-6_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="D3_SCALING",& description="XC Functional dependent scaling parameters (s6,sr6,s8) for the DFT-D3 method,"//& " if set to zero CP2K attempts"//& " to guess the xc functional from REFERENCE_FUNCTIONAL and sets the associated scaling parameter.",& usage="D3_SCALING 1.0 1.0 1.0", n_var=3, & - default_r_vals=(/0.0_dp,0.0_dp,0.0_dp/),error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/0.0_dp,0.0_dp,0.0_dp/)) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="D3BJ_SCALING",& description="XC Functional dependent scaling parameters (s6,a1,s8,a2) for the DFT-D3(BJ) method,"//& " if set to zero CP2K attempts"//& " to guess the xc functional from REFERENCE_FUNCTIONAL and sets the associated scaling parameter.",& usage="D3BJ_SCALING 1.0 1.0 1.0 1.0", n_var=4, & - default_r_vals=(/0.0_dp,0.0_dp,0.0_dp,0.0_dp/),error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/0.0_dp,0.0_dp,0.0_dp,0.0_dp/)) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CALCULATE_C9_TERM",& description="Calculate C9 terms in DFT-D3 model",& usage="CALCULATE_C9_TERM", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REFERENCE_C9_TERM",& description="Calculate C9 terms in DFT-D3 model using reference coordination numbers",& usage="REFERENCE_C9_TERM", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LONG_RANGE_CORRECTION",& description="Calculate a long range correction to the DFT-D3 model",& usage="LONG_RANGE_CORRECTION", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VERBOSE_OUTPUT",& description="Extensive output for the DFT-D2 and DFT-D3 models",& usage="VERBOSE_OUTPUT", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) ! Set coordination numbers by atom kinds CALL keyword_create(keyword, name="KIND_COORDINATION_NUMBERS",& description="Specifies the coordination number for a kind for the C9 term in DFT-D3.",& usage="KIND_COORDINATION_NUMBERS CN kind ", repeats=.TRUE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) ! Set coordination numbers by atom numbers CALL keyword_create(keyword, name="ATOM_COORDINATION_NUMBERS",& description="Specifies the coordination number of a set of atoms for the C9 term in DFT-D3.",& usage="ATOM_COORDINATION_NUMBERS CN atom1 atom2 ... ", repeats=.TRUE.,& - n_var=-1,type_of_var=char_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) ! parameter specification atom by atom CALL keyword_create(keyword, name="ATOMPARM",& description="Specifies parameters for atom types (in atomic units). If "//& "not provided default parameters are used (DFT-D2).",& usage="ATOMPARM ", & - repeats=.TRUE., n_var=-1, type_of_var=char_t, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE., n_var=-1, type_of_var=char_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PRINT_DFTD",& description="Controls the printing of some info about DFTD contributions",& - print_level=high_print_level,add_last=add_last_numeric,filename="",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,add_last=add_last_numeric,filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! nonlocal section NULLIFY(subsection,keyword) CALL section_create(subsection,name="NON_LOCAL",& description="Information on the non local dispersion functional",& - n_keywords=0, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword,name="TYPE",& description="Type of functional (the corresponding kernel data file should be selected)."//& @@ -1048,52 +1005,49 @@ SUBROUTINE create_vdw_potential_section(section,error) "Lee-Murray-Kong-Lundqvist-Langreth nonlocal van der Waals density functional",& "Revised Vydrov-van Voorhis nonlocal van der Waals density functional"),& citations=(/Tran2013/),& - default_i_val=vdw_nl_DRSLL, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=vdw_nl_DRSLL) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VERBOSE_OUTPUT",& description="Extensive output for non local functionals",& usage="VERBOSE_OUTPUT", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KERNEL_FILE_NAME",& description="Name of the kernel data file, may include a path."//& "vdW_kernel_table.dat is for DRSLL and LMKLL and"//& "rVV10_kernel_table.dat is for rVV10.",& usage="KERNEL_FILE_NAME ",& - default_lc_val="vdW_kernel_table.dat",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="vdW_kernel_table.dat") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CUTOFF",& description="The cutoff of the FFT grid used in the calculation "//& "of the nonlocal vdW functional [Ry].",& usage="CUTOFF 300",& - default_r_val=-1._dp,unit_str="Ry",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1._dp,unit_str="Ry") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="PARAMETERS",& description="Parameters b and C of the rVV10 functional",& usage="PARAMETERS 6.3 0.0093",& - type_of_var=real_t,default_r_vals=(/6.3_dp,0.0093_dp/),n_var=2,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,default_r_vals=(/6.3_dp,0.0093_dp/),n_var=2) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_vdw_potential_section ! ***************************************************************************** !> \brief creates the input section for the xc part !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_xc_section(section,error) + SUBROUTINE create_xc_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_xc_section', & routineP = moduleN//':'//routineN @@ -1104,39 +1058,38 @@ SUBROUTINE create_xc_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"xc",& description="Parameters needed for the calculation of the eXchange and Correlation potential",& - n_keywords=5, n_subsections=2, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=2, repeats=.FALSE.) NULLIFY(subsection,keyword) CALL keyword_create(keyword, name="density_cutoff",& description="The cutoff on the density used by the xc calculation",& - usage="density_cutoff 1.e-11", default_r_val=1.0e-10_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="density_cutoff 1.e-11", default_r_val=1.0e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="gradient_cutoff",& description="The cutoff on the gradient of the density used by the "//& "xc calculation",& - usage="gradient_cutoff 1.e-11", default_r_val=1.0e-10_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="gradient_cutoff 1.e-11", default_r_val=1.0e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DENSITY_SMOOTH_CUTOFF_RANGE",& description="Parameter for the smoothing procedure in"//& "xc calculation",& - usage="gradient_cutoff {real}", default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="gradient_cutoff {real}", default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="tau_cutoff",& description="The cutoff on tau used by the xc calculation",& - usage="tau_cutoff 1.e-11", default_r_val=1.0e-10_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="tau_cutoff 1.e-11", default_r_val=1.0e-10_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FUNCTIONAL_ROUTINE",& description="Select the code for xc calculation",& @@ -1148,25 +1101,22 @@ SUBROUTINE create_xc_section(section,error) enum_desc=s2a("Use new code for exchange-correlation functional calculation",& "Use old code for exchange-correlation functional calculation",& "Use test local-spin-density approximation code for exchange-correlation functional calculation",& - "Use debug new code for exchange-correlation functional calculation"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Use debug new code for exchange-correlation functional calculation")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection, name="xc_grid",&!FM to do description="The xc parameters used when calculating the xc on the grid",& - n_keywords=5, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="xc_smooth_rho",& description="The density smoothing used for the xc calculation",& usage="xc_smooth_rho nn10", default_i_val=xc_rho_no_smooth,& enum_c_vals=s2a("NONE","NN50","NN10","SPLINE2","NN6","SPLINE3","NN4"),& enum_i_vals=(/ xc_rho_no_smooth, xc_rho_nn50, xc_rho_nn10, & xc_rho_spline2_smooth,xc_rho_spline2_smooth,xc_rho_spline3_smooth,& - xc_rho_spline3_smooth/),& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + xc_rho_spline3_smooth/)) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="xc_deriv",& description="The method used to compute the derivatives",& @@ -1176,57 +1126,53 @@ SUBROUTINE create_xc_section(section,error) enum_i_vals=(/xc_deriv_pw, xc_deriv_spline3, xc_deriv_spline2,& xc_deriv_nn50_smooth, xc_deriv_nn10_smooth, xc_deriv_spline2_smooth,& xc_deriv_spline2_smooth, xc_deriv_spline3_smooth, xc_deriv_spline3_smooth,& - xc_deriv_collocate/),& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + xc_deriv_collocate/)) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="use_finer_grid",& description="Uses a finer grid only to calculate the xc",& usage="use_finer_grid", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_xc_fun_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_xc_fun_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_hfx_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_hfx_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_mp2_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mp2_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_adiabatic_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_adiabatic_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_xc_potential_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_xc_potential_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_vdw_potential_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_vdw_potential_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_xc_section ! ***************************************************************************** !> \brief creates the section for adiabatic hybrid functionals !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE create_adiabatic_section(section,error) + SUBROUTINE create_adiabatic_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_adiabatic_section', & routineP = moduleN//':'//routineN @@ -1236,11 +1182,10 @@ SUBROUTINE create_adiabatic_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,"ADIABATIC_RESCALING",& description="Parameters for self interation corrected hybrid functionals",& - n_keywords=0, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(& keyword=keyword,& @@ -1251,9 +1196,9 @@ SUBROUTINE create_adiabatic_section(section,error) enum_c_vals=s2a("MCY3"),& enum_i_vals=(/do_adiabatic_hybrid_mcy3/), & enum_desc=s2a("Use MCY3 hybrid functional"), & - default_i_val=do_adiabatic_hybrid_mcy3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_adiabatic_hybrid_mcy3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(& @@ -1261,9 +1206,9 @@ SUBROUTINE create_adiabatic_section(section,error) name="LAMBDA",& description="The point to be used along the adiabatic curve (0 < λ < 1)",& usage="LAMBDA 0.71",& - default_r_val=0.71_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.71_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(& @@ -1271,9 +1216,9 @@ SUBROUTINE create_adiabatic_section(section,error) name="OMEGA",& description="Long-range parameter",& usage="OMEGA 0.2",& - default_r_val=0.2_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.2_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(keyword) CALL keyword_create(& @@ -1284,9 +1229,9 @@ SUBROUTINE create_adiabatic_section(section,error) enum_c_vals=s2a("PADE"),& enum_i_vals=(/do_adiabatic_model_pade/), & enum_desc=s2a("Use pade model: W(lambda)=a+(b*lambda)/(1+c*lambda)"), & - default_i_val=do_adiabatic_model_pade, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_adiabatic_model_pade) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_adiabatic_section END MODULE input_cp2k_xc diff --git a/src/input_optimize_basis.F b/src/input_optimize_basis.F index 44dcdbaf18..fa7a7431a3 100644 --- a/src/input_optimize_basis.F +++ b/src/input_optimize_basis.F @@ -41,12 +41,10 @@ MODULE input_optimize_basis ! ***************************************************************************** !> \brief creates the optimize_basis section !> \param section ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE create_optimize_basis_section(section,error) + SUBROUTINE create_optimize_basis_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_optimize_basis_section', & @@ -58,59 +56,59 @@ SUBROUTINE create_optimize_basis_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="OPTIMIZE_BASIS",& description="describes a basis optimization job, in which an ADMM like approach is used to"//& " find the best exponents and/or coefficients to match a given training set.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="BASIS_TEMPLATE_FILE",& description="Name of the basis set file, containing the structure of the new basis set",& usage="BASIS_TEMPLATE_FILE ",& type_of_var=char_t,repeats=.FALSE.,& - default_c_val="BASIS_SET",n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="BASIS_SET",n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIS_WORK_FILE",& description="Name of the basis set file which is created to be read as initial guess",& usage="BASIS_WORK_FILE ",& type_of_var=char_t,repeats=.FALSE.,& - default_c_val="BASIS_WORK_FILE",n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="BASIS_WORK_FILE",n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIS_OUTPUT_FILE",& description="Name of the basis set file containing the optimized basis",& usage="BASIS_OUTPUT_FILE ",& type_of_var=char_t,repeats=.FALSE.,& - default_c_val="BASIS_OUTPUT_FILE",n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="BASIS_OUTPUT_FILE",n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WRITE_FREQUENCY",& description="Frequency at which the intermediate results should be written",& usage="WRITE_FREQUENCY 1000",& - default_i_val=5000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_CONDITION_NUMBER",& description="Determines whether condition number should be part of optimization or not",& usage="USE_CONDITION_NUMBER",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIS_COMBINATIONS",& description="If multiple atomic kinds are fitted at the same time, this keyword "//& "allows to specify which basis sets should be used together in optimization (underived set ID=0). "//& "If skipped all combinations are used. The order is taken as the kinds and sets are specified in the input",& repeats=.TRUE.,& - usage="BASIS_COMBINATIONS SET_ID(KIND1) SET_ID(KIND2) ... ", type_of_var=integer_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BASIS_COMBINATIONS SET_ID(KIND1) SET_ID(KIND2) ... ", type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESIDUUM_WEIGHT",& description="This keyword allows to give different weight factors to the "//& @@ -118,9 +116,9 @@ SUBROUTINE create_optimize_basis_section(section,error) "The first entry corresponds to the original basis sets. Every further value is assigned to the combinations "//& "in the order given for BASIS_COMBINATIONS.",& repeats=.TRUE.,& - usage="RESIDUUM_WEIGHT REAL ", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESIDUUM_WEIGHT REAL ", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CONDITION_WEIGHT",& description="This keyword allows to give different weight factors to the "//& @@ -128,9 +126,9 @@ SUBROUTINE create_optimize_basis_section(section,error) "The first entry corresponds to the original basis sets. Every further value is assigned to the combinations "//& "in the order given for BASIS_COMBINATIONS.",& repeats=.TRUE.,& - usage="CONTITION_WEIGHT REAL ", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CONTITION_WEIGHT REAL ", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GROUP_PARTITION",& description="Allows the specification of the group mpi group sizes in parallel "//& @@ -138,21 +136,21 @@ SUBROUTINE create_optimize_basis_section(section,error) " Will be assigned to one group (derived basis sets and then training sets)"//& " If keyword is skipped, equal group sizes will be generated trying to fit all calculations.",& repeats=.TRUE.,& - usage="GROUP_PARTITION INT INT ... ", type_of_var=integer_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GROUP_PARTITION INT INT ... ", type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_fit_kinds_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_fit_kinds_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_training_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_training_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_powell_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_powell_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) @@ -161,11 +159,9 @@ END SUBROUTINE create_optimize_basis_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_fit_kinds_section(section,error) + SUBROUTINE create_fit_kinds_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_fit_kinds_section', & routineP = moduleN//':'//routineN @@ -175,23 +171,23 @@ SUBROUTINE create_fit_kinds_section(section,error) TYPE(section_type), POINTER :: subsection NULLIFY(keyword, subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="FIT_KIND",& description="specicifies the atomic kinds to be fitted and the basis"//& " sets associated with the kind.",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="The name of the kind described in this section.",& - usage="H", default_c_val="DEFAULT", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="H", default_c_val="DEFAULT") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BASIS_SET",& description="The name of the basis set for the kind. Has to be specified in BASIS_TEMPLATE_FILE.",& - usage="H", default_c_val="DEFAULT", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="H", default_c_val="DEFAULT") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INITIAL_DEGREES_OF_FREEDOM",& description="Specifies the initial degrees of freedom in the basis optimization."//& @@ -203,60 +199,58 @@ SUBROUTINE create_fit_kinds_section(section,error) "Set all coefficients in the basis set to be variable.",& "Set all exponents in the basis to be variable."),& enum_i_vals=(/do_opt_all, do_opt_none, do_opt_coeff, do_opt_exps/),& - default_i_val=do_opt_coeff,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_opt_coeff) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SWITCH_COEFF_STATE",& description="Allows to switch the state of a given coefficient from current state "//& "(varibale/fixed)) to the opposite state. The three integers indicate "//& "the set number, the angular momentum i'th contraction and i'th coefficient",repeats=.TRUE.,& - usage="SWITCH_COEFF_STATE SET L CONTRACTION IPGF", type_of_var=integer_t, n_var=4, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SWITCH_COEFF_STATE SET L CONTRACTION IPGF", type_of_var=integer_t, n_var=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SWITCH_CONTRACTION_STATE",& description="Allows to switch the state of a given contraction from current state "//& "(varibale/fixed)) to the opposite state. The three integers indicate "//& "the set number, the angular momentum and i'th contraction ",repeats=.TRUE.,& - usage="SWITCH_CONTRACTION_STATE SET L CONTRACTION ", type_of_var=integer_t, n_var=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SWITCH_CONTRACTION_STATE SET L CONTRACTION ", type_of_var=integer_t, n_var=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SWITCH_EXP_STATE",& description="Allows to switch the state of a given exponent from current state "//& "(varibale/fixed)) to the opposite state. The two integers indicate "//& "the set number and i'th exponent",repeats=.TRUE.,& - usage="SWITCH_EXP_STATE SET IEXP", type_of_var=integer_t, n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SWITCH_EXP_STATE SET IEXP", type_of_var=integer_t, n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SWITCH_SET_STATE",& description="Allows to switch the states of in a set from current state "//& "(varibale/fixed)) to the opposite state. The two integers indicate "//& "the affected part (0=ALL,1=EXPS,2=COEFF) and i'th set",repeats=.TRUE.,& - usage="SWITCH_SET_STATE SET IEXP", type_of_var=integer_t, n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SWITCH_SET_STATE SET IEXP", type_of_var=integer_t, n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_constrain_exp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_constrain_exp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_derived_sets_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_derived_sets_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_fit_kinds_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_derived_sets_section(section,error) + SUBROUTINE create_derived_sets_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_derived_sets_section', & routineP = moduleN//':'//routineN @@ -265,45 +259,43 @@ SUBROUTINE create_derived_sets_section(section,error) TYPE(keyword_type), POINTER :: keyword NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DERIVED_BASIS_SETS",& description="This section can be used to create subsets of a basis "//& " which will be fitted at the same time. This is especially useful if connected"//& " bsis sets e.g. TZVP, DZVP, SZV should be fitted. ",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword, name="REFERENCE_SET",& description="Specifies the reference basis ID which is used as template to create the new set. "//& "The original basis has ID 0. All follwing sets are counted in order as specified in the Input."//& " The decriptors always assume the structure of the input basis set.",& - repeats=.FALSE., usage="REFERNCE_SET INTEGER", default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="REFERNCE_SET INTEGER", default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REMOVE_CONTRACTION",& description="Can be used to remove a contraction from the reference basis set. "//& "The contraction is speciefied by set number, angular momentum and number of contraction."//& " The decriptors always assume the structure of the input basis set.",& - repeats=.TRUE., usage="REMOVE_CONTRACTION SET L ICONTRACTION", type_of_var=integer_t, n_var=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE., usage="REMOVE_CONTRACTION SET L ICONTRACTION", type_of_var=integer_t, n_var=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REMOVE_SET",& description="Can be used to remove a set from the reference basis set. ",& - repeats=.TRUE., usage="REMOVE_SET SET", type_of_var=integer_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE., usage="REMOVE_SET SET", type_of_var=integer_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_derived_sets_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_constrain_exp_section(section,error) + SUBROUTINE create_constrain_exp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_constrain_exp_section', & routineP = moduleN//':'//routineN @@ -312,32 +304,32 @@ SUBROUTINE create_constrain_exp_section(section,error) TYPE(keyword_type), POINTER :: keyword NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CONSTRAIN_EXPONENTS",& description="specicifies contraints for the exponents to be fitted."//& " Only a single constraint can be applied to an exponent",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword, name="USE_EXP",& description="Defines the exponent to be constraint. The two integers indicate "//& "the set number and i'th exponent. The value -1 can be used to mark all sets/expoenents in a set.",& - repeats=.FALSE., usage="USE_EXP SET IEXP", type_of_var=integer_t, n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="USE_EXP SET IEXP", type_of_var=integer_t, n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BOUNDARIES",& description="Defines the boundaries to which the optimization is restricted."//& " First value is the lower bound, second value is the upper bound.",& - repeats=.FALSE., usage="BOUNDARIES LOWER UPPER", type_of_var=real_t, n_var=2, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="BOUNDARIES LOWER UPPER", type_of_var=real_t, n_var=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_VAR_FRACTION",& description="Defines the maximum fractionr by which the exponent is allowed to vary."//& " e.g. 0.5 allows the exp to vary by 0.5*exp in both directions.",& - repeats=.FALSE., usage="MAX_VAR_FRACTION REAL", type_of_var=real_t, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="MAX_VAR_FRACTION REAL", type_of_var=real_t, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_constrain_exp_section @@ -345,11 +337,9 @@ END SUBROUTINE create_constrain_exp_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_training_section(section,error) + SUBROUTINE create_training_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_training_section', & routineP = moduleN//':'//routineN @@ -360,36 +350,34 @@ SUBROUTINE create_training_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="TRAINING_FILES",& description="specicifies the location in which the files necessary for"//& " fitting procedure are located. Each Training set needs a reptition of this section.",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword,name="DIRECTORY",& description="the directory in which the files are placed",& usage="DIRECTORY /my/path",& - default_lc_val=".",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val=".") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="INPUT_FILE_NAME",& description="the filename of the input file used to run the original calcuation",& usage="INPUT_FILE_NAME my_input.inp",& - default_lc_val="input.inp",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="input.inp") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_training_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_powell_section(section,error) + SUBROUTINE create_powell_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_powell_section', & routineP = moduleN//':'//routineN @@ -400,31 +388,31 @@ SUBROUTINE create_powell_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="OPTIMIZATION",& description="sets the parameters for optimizition, output frequency and restarts",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="ACCURACY",& description="Final accuracy requested in optimization (RHOEND)",& usage="ACCURACY 0.00001",& - default_r_val=1.e-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEP_SIZE",& description="Initial step size for search algorithm (RHOBEG)",& usage="STEP_SIZE 0.005",& - default_r_val=0.1_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_FUN",& description="Maximum number of function evaluations",& usage="MAX_FUN 1000",& - default_i_val=5000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_powell_section diff --git a/src/input_optimize_input.F b/src/input_optimize_input.F index e4fd33c47b..3df845be8c 100644 --- a/src/input_optimize_input.F +++ b/src/input_optimize_input.F @@ -38,12 +38,10 @@ MODULE input_optimize_input ! ***************************************************************************** !> \brief creates the optimize_input section !> \param section ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_optimize_input_section(section,error) + SUBROUTINE create_optimize_input_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_optimize_input_section', & @@ -55,10 +53,10 @@ SUBROUTINE create_optimize_input_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="OPTIMIZE_INPUT",& description="describes an input optimization job, in which parameters in input files get optimized.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="METHOD",& @@ -67,45 +65,44 @@ SUBROUTINE create_optimize_input_section(section,error) enum_c_vals=s2a("FORCE_MATCHING"),& enum_desc=s2a("Perform a force matching minimization."),& enum_i_vals=(/opt_force_matching/), & - default_i_val=opt_force_matching,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=opt_force_matching) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ACCURACY",& description="Final accuracy requested in optimization (RHOEND)",& usage="ACCURACY 0.00001",& - default_r_val=1.e-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.e-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STEP_SIZE",& description="Initial step size for search algorithm (RHOBEG)",& usage="STEP_SIZE 0.005",& - default_r_val=0.05_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.05_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_FUN",& description="Maximum number of function evaluations",& usage="MAX_FUN 1000",& - default_i_val=5000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ITER_START_VAL",& description="Used for restarting, starting value of the iteration",& usage="ITER_START_VAL 0",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RANDOMIZE_VARIABLES",& description="Percentage randomization of the free variables applied initially",& usage="RANDOMIZE_VARIABLES 20",& - default_r_val=0.00_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.00_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! ! variables section @@ -114,33 +111,31 @@ SUBROUTINE create_optimize_input_section(section,error) NULLIFY(sub_section) CALL section_create(sub_section,name="VARIABLE",& description="Defines initial values for variables and their labels",& - n_subsections=0, repeats=.TRUE., & - error=error) + n_subsections=0, repeats=.TRUE.) CALL keyword_create(keyword, name="VALUE",& description="Initial value of the variable",& usage="VALUE 0.0",& - type_of_var=real_t, unit_str="internal_cp2k",error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, unit_str="internal_cp2k") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FIXED",& description="Is this variable fixed or should it be optimized.",& usage="FIXED",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LABEL",& description="The label used in the input file, i.e. ${LABEL} will be replaced by the VALUE specified.",& usage="LABEL PRM01",& - type_of_var=char_t,& - error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, sub_section, error=error) - CALL section_release(sub_section,error=error) + CALL section_add_subsection(section, sub_section) + CALL section_release(sub_section) ! @@ -150,136 +145,128 @@ SUBROUTINE create_optimize_input_section(section,error) NULLIFY(sub_section) CALL section_create(sub_section,name="FORCE_MATCHING",& description="Specify the force matching input.",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword,name="OPTIMIZE_FILE_NAME",& description="the filename of the input file which contains the parameters to be optimized",& usage="OPTIMIZE_FILE_NAME my_input.inp",& - default_lc_val="",& - error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="REF_TRAJ_FILE_NAME",& description="the filename of the reference coordinates.",& usage="REF_TRAJ_FILE_NAME pos.xyz",& - default_lc_val="",& - error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="REF_FORCE_FILE_NAME",& description="the filename of the reference forces, should also contain the energy",& usage="REF_FORCE_FILE_NAME frc.xyz",& - default_lc_val="",& - error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="REF_CELL_FILE_NAME",& description="the filename of the reference cell",& usage="REF_CELL_FILE_NAME project.cell",& - default_lc_val="",& - error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GROUP_SIZE",& description="Gives the preferred size of a working group, "//& "groups will always be equal or larger than this size."//& "Usually this should take the number of cores per socket into account for good performance.",& - usage="group_size 2", default_i_val=6, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="group_size 2", default_i_val=6) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FRAME_START",& description="starting frame to be used from the reference trajectory",& - usage="FRAME_START 1", default_i_val=1, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FRAME_START 1", default_i_val=1) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FRAME_STOP",& description="final frame to be used from the reference trajectory (all=-1)",& - usage="FRAME_STOP -1", default_i_val=-1, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FRAME_STOP -1", default_i_val=-1) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FRAME_STRIDE",& description="stride when using the reference trajectory",& - usage="FRAME_STRIDE 1", default_i_val=1, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FRAME_STRIDE 1", default_i_val=1) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FRAME_COUNT",& description="Use at most FRAME_COUNT frames from the reference trajectory, "//& "adjusting the stride to have them as fas apart as possible (all=-1).",& - usage="FRAME_COUNT 100", default_i_val=-1, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FRAME_COUNT 100", default_i_val=-1) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY_WEIGHT",& description="Relative weight of the energy RMSD vs the force RMSD",& - usage="ENERGY_WEIGHT 0.1", default_r_val=0.1_dp, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ENERGY_WEIGHT 0.1", default_r_val=0.1_dp) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHIFT_AVERAGE",& description="Shift averages of the energies before computing energy RMSD.",& - usage="SHIFT_AVERAGE", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SHIFT_AVERAGE", default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHIFT_QM",& description="Shift of the reference energies applied before computing energy RMSD.",& - usage="SHIFT_QM -17.0", default_r_val=0.0_dp, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SHIFT_QM -17.0", default_r_val=0.0_dp) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHIFT_MM",& description="Shift of the fit energies applied before computing energy RMSD.",& - usage="SHIFT_MM 0.0", default_r_val=0.0_dp, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SHIFT_MM 0.0", default_r_val=0.0_dp) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) NULLIFY(subsubsection) CALL cp_print_key_section_create(subsubsection,"COMPARE_ENERGIES",& description="A comparison of energies between fit and reference",& - print_level=low_print_level,filename="compare_energies",common_iter_levels=1,& - error=error) - CALL section_add_subsection(sub_section,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + print_level=low_print_level,filename="compare_energies",common_iter_levels=1) + CALL section_add_subsection(sub_section,subsubsection) + CALL section_release(subsubsection) NULLIFY(subsubsection) CALL cp_print_key_section_create(subsubsection,"COMPARE_FORCES",& description="A comparison of forces between fit and reference",& - print_level=low_print_level,filename="compare_forces",common_iter_levels=1,& - error=error) - CALL section_add_subsection(sub_section,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + print_level=low_print_level,filename="compare_forces",common_iter_levels=1) + CALL section_add_subsection(sub_section,subsubsection) + CALL section_release(subsubsection) - CALL section_add_subsection(section, sub_section, error=error) - CALL section_release(sub_section,error=error) + CALL section_add_subsection(section, sub_section) + CALL section_release(sub_section) NULLIFY(subsubsection) CALL cp_print_key_section_create(subsubsection,"HISTORY",& description="writes a history of the function value and parameters",& - print_level=low_print_level,filename="history",common_iter_levels=1,& - error=error) - CALL section_add_subsection(section,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + print_level=low_print_level,filename="history",common_iter_levels=1) + CALL section_add_subsection(section,subsubsection) + CALL section_release(subsubsection) CALL cp_print_key_section_create(subsubsection,"RESTART",& description="writes an input file that can be used to restart ",& - print_level=low_print_level,filename="optimize",common_iter_levels=1,& - error=error) + print_level=low_print_level,filename="optimize",common_iter_levels=1) CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum index of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=3, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + default_i_val=3) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsubsection) + CALL section_release(subsubsection) END SUBROUTINE create_optimize_input_section diff --git a/src/input_restart_force_eval.F b/src/input_restart_force_eval.F index cc5db55d90..7ff7e09726 100644 --- a/src/input_restart_force_eval.F +++ b/src/input_restart_force_eval.F @@ -76,18 +76,15 @@ MODULE input_restart_force_eval !> \param force_env ... !> \param root_section ... !> \param write_binary_restart_file ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE update_force_eval(force_env,root_section,& - write_binary_restart_file,error) + write_binary_restart_file) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section LOGICAL, INTENT(IN) :: write_binary_restart_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_force_eval', & routineP = moduleN//':'//routineN @@ -107,48 +104,48 @@ SUBROUTINE update_force_eval(force_env,root_section,& failure = .FALSE. NULLIFY(rng_section, subsys_section, cell_section, virial, subsys, cell) ! If it's not a dynamical run don't update the velocity section - CALL section_vals_val_get(root_section,"GLOBAL%RUN_TYPE",i_val=myid,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%RUN_TYPE",i_val=myid) skip_vel_section =((myid /= mol_dyn_run).AND.& (myid /= mon_car_run).AND.& (myid /= pint_run).AND.& (myid /= ehrenfest)) ! Go on updatig the force_env_section - force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL",error=error) - CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval, error) + force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL") + CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval) ! The update of the input MUST be realized only on the main force_eval ! All the others will be left not updated because there is no real need to update them... iforce_eval=1 subsys_section => section_vals_get_subs_vals3(force_env_sections,"SUBSYS",& - i_rep_section=i_force_eval(iforce_eval),error=error) + i_rep_section=i_force_eval(iforce_eval)) CALL update_subsys(subsys_section,force_env,skip_vel_section,& - write_binary_restart_file,error) + write_binary_restart_file) - rng_section => section_vals_get_subs_vals(subsys_section,"RNG_INIT",error=error) - CALL update_rng_particle(rng_section,force_env,error) + rng_section => section_vals_get_subs_vals(subsys_section,"RNG_INIT") + CALL update_rng_particle(rng_section,force_env) qmmm_section => section_vals_get_subs_vals3(force_env_sections,"QMMM",& - i_rep_section=i_force_eval(iforce_eval),error=error) - CALL update_qmmm(qmmm_section,force_env,error) + i_rep_section=i_force_eval(iforce_eval)) + CALL update_qmmm(qmmm_section,force_env) ! And now update only the cells of all other force_eval ! This is to make consistent for cell variable runs.. IF (nforce_eval>1) THEN - CALL force_env_get(force_env, subsys=subsys, cell=cell, error=error) - CALL cp_subsys_get(subsys, virial=virial, error=error) - CALL section_vals_val_get(root_section,"MULTIPLE_FORCE_EVALS%MULTIPLE_SUBSYS",l_val=multiple_subsys,error=error) + CALL force_env_get(force_env, subsys=subsys, cell=cell) + CALL cp_subsys_get(subsys, virial=virial) + CALL section_vals_val_get(root_section,"MULTIPLE_FORCE_EVALS%MULTIPLE_SUBSYS",l_val=multiple_subsys) IF (virial%pv_availability.AND.multiple_subsys) THEN DO iforce_eval = 2, nforce_eval subsys_section => section_vals_get_subs_vals3(force_env_sections,"SUBSYS",& - i_rep_section=i_force_eval(iforce_eval),error=error) - cell_section => section_vals_get_subs_vals(subsys_section,"CELL",error=error) - CALL update_cell_section(cell, cell_section, error) + i_rep_section=i_force_eval(iforce_eval)) + cell_section => section_vals_get_subs_vals(subsys_section,"CELL") + CALL update_cell_section(cell, cell_section) END DO END IF END IF IF(myid == ehrenfest)CALL section_vals_val_set(root_section,"FORCE_EVAL%DFT%REAL_TIME_PROPAGATION%INITIAL_WFN",& - i_val=use_rt_restart,error=error) + i_val=use_rt_restart) DEALLOCATE(i_force_eval) END SUBROUTINE update_force_eval @@ -157,16 +154,13 @@ END SUBROUTINE update_force_eval !> \brief Updates the qmmm section if needed !> \param qmmm_section ... !> \param force_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2007 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE update_qmmm(qmmm_section,force_env,error) + SUBROUTINE update_qmmm(qmmm_section,force_env) TYPE(section_vals_type), POINTER :: qmmm_section TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_qmmm', & routineP = moduleN//':'//routineN @@ -178,13 +172,13 @@ SUBROUTINE update_qmmm(qmmm_section,force_env,error) failure = .FALSE. SELECT CASE(force_env%in_use) CASE(use_qmmm) - CALL section_vals_get(qmmm_section, explicit=explicit, error=error) - CPPostcondition(explicit,cp_failure_level,routineP,error,failure) + CALL section_vals_get(qmmm_section, explicit=explicit) + CPPostcondition(explicit,cp_failure_level,routineP,failure) ALLOCATE(work(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work = force_env%qmmm_env%qm%transl_v - CALL section_vals_val_set(qmmm_section,"INITIAL_TRANSLATION_VECTOR",r_vals_ptr=work,error=error) + CALL section_vals_val_set(qmmm_section,"INITIAL_TRANSLATION_VECTOR",r_vals_ptr=work) END SELECT END SUBROUTINE update_qmmm @@ -194,17 +188,14 @@ END SUBROUTINE update_qmmm !> Write current status of the parallel random number generator (RNG) !> \param rng_section ... !> \param force_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE update_rng_particle(rng_section,force_env,error) + SUBROUTINE update_rng_particle(rng_section,force_env) TYPE(section_vals_type), POINTER :: rng_section TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_rng_particle', & routineP = moduleN//':'//routineN @@ -220,16 +211,16 @@ SUBROUTINE update_rng_particle(rng_section,force_env,error) TYPE(distribution_1d_type), POINTER :: local_particles TYPE(particle_list_type), POINTER :: particles - CALL force_env_get(force_env, subsys=subsys, para_env=para_env, error=error) + CALL force_env_get(force_env, subsys=subsys, para_env=para_env) CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, local_particles=local_particles,& - particles=particles, error=error) + particles=particles) IF (ASSOCIATED(local_particles%local_particle_set)) THEN nparticle_kind = atomic_kinds%n_els nparticle = particles%n_els ALLOCATE (ascii(rng_record_length,nparticle),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ascii = 0 DO iparticle=1,nparticle @@ -239,7 +230,7 @@ SUBROUTINE update_rng_particle(rng_section,force_env,error) IF (iparticle == local_particles%list(iparticle_kind)%array(iparticle_local)) THEN CALL dump_rng_stream(rng_stream=local_particles%local_particle_set(iparticle_kind)%& rng(iparticle_local)%stream,& - rng_record=rng_record, error=error) + rng_record=rng_record) CALL string_to_ascii(rng_record,ascii(:,iparticle)) END IF END DO @@ -248,11 +239,10 @@ SUBROUTINE update_rng_particle(rng_section,force_env,error) CALL mp_sum(ascii,para_env%group) - CALL section_rng_val_set(rng_section=rng_section,nsize=nparticle,ascii=ascii,& - error=error) + CALL section_rng_val_set(rng_section=rng_section,nsize=nparticle,ascii=ascii) DEALLOCATE (ascii,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE update_rng_particle @@ -263,19 +253,16 @@ END SUBROUTINE update_rng_particle !> \param force_env ... !> \param skip_vel_section ... !> \param write_binary_restart_file ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE update_subsys(subsys_section,force_env,skip_vel_section,& - write_binary_restart_file,error) + write_binary_restart_file) TYPE(section_vals_type), POINTER :: subsys_section TYPE(force_env_type), POINTER :: force_env LOGICAL, INTENT(IN) :: skip_vel_section, & write_binary_restart_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_subsys', & routineP = moduleN//':'//routineN @@ -299,34 +286,31 @@ SUBROUTINE update_subsys(subsys_section,force_env,skip_vel_section,& NULLIFY (work_section, core_particles, particles, shell_particles, & subsys, cell, para_env, multipoles) CALL timeset(routineN,handle) - CALL force_env_get(force_env, subsys=subsys, cell=cell, para_env=para_env, & - error=error) + CALL force_env_get(force_env, subsys=subsys, cell=cell, para_env=para_env) CALL cp_subsys_get(subsys, particles=particles, molecules_new=molecules,& shell_particles=shell_particles, core_particles=core_particles,& - multipoles=multipoles, error=error) + multipoles=multipoles) ! Remove the multiple_unit_cell from the input structure.. at this point we have ! already all the information we need.. ALLOCATE(multiple_unit_cell(3),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) multiple_unit_cell = 1 CALL section_vals_val_set(subsys_section, "TOPOLOGY%MULTIPLE_UNIT_CELL",& - i_vals_ptr=multiple_unit_cell, error=error) + i_vals_ptr=multiple_unit_cell) ! Coordinates and Velocities - work_section => section_vals_get_subs_vals(subsys_section,"COORD",error=error) - CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(work_section,"SCALED",l_val=scale,error=error) - conv_factor = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + work_section => section_vals_get_subs_vals(subsys_section,"COORD") + CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(work_section,"SCALED",l_val=scale) + conv_factor = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (.NOT.write_binary_restart_file) THEN CALL section_vals_val_get(subsys_section,"TOPOLOGY%COORD_FILE_FORMAT",& - i_val=coord_file_format,& - error=error) + i_val=coord_file_format) IF (coord_file_format == do_coord_cp2k) THEN CALL section_vals_val_get(subsys_section,"TOPOLOGY%COORD_FILE_NAME",& - c_val=coord_file_name,& - error=error) + c_val=coord_file_name) output_unit = 0 IF (para_env%ionode) THEN CALL open_file(file_name=TRIM(ADJUSTL(coord_file_name)),& @@ -338,85 +322,84 @@ SUBROUTINE update_subsys(subsys_section,force_env,skip_vel_section,& CALL dump_coordinates_cp2k(particles,molecules,cell,conv_factor,& output_unit=output_unit,& core_or_shell=.FALSE.,& - scaled_coordinates=scale,& - error=error) + scaled_coordinates=scale) CALL close_file(unit_number=output_unit) END IF ELSE CALL section_coord_val_set(work_section, particles, molecules, conv_factor, scale,& - cell, error=error) + cell) END IF END IF - CALL section_vals_val_set(subsys_section,"TOPOLOGY%NUMBER_OF_ATOMS",i_val=particles%n_els,error=error) - work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) + CALL section_vals_val_set(subsys_section,"TOPOLOGY%NUMBER_OF_ATOMS",i_val=particles%n_els) + work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") IF (.NOT.skip_vel_section) THEN IF (.NOT.write_binary_restart_file) THEN - CALL section_velocity_val_set(work_section, particles, conv_factor=1.0_dp, error=error) + CALL section_velocity_val_set(work_section, particles, conv_factor=1.0_dp) END IF ELSE - CALL section_vals_remove_values(work_section, error) + CALL section_vals_remove_values(work_section) END IF ! Write restart input for core-shell model IF (.NOT.write_binary_restart_file) THEN IF (ASSOCIATED(shell_particles)) THEN - work_section => section_vals_get_subs_vals(subsys_section,"SHELL_COORD",error=error) - CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(work_section,"SCALED",l_val=scale,error=error) - conv_factor = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + work_section => section_vals_get_subs_vals(subsys_section,"SHELL_COORD") + CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(work_section,"SCALED",l_val=scale) + conv_factor = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) CALL section_coord_val_set(work_section, shell_particles, molecules, & - conv_factor, scale, cell, shell=.TRUE., error=error) + conv_factor, scale, cell, shell=.TRUE.) IF (.NOT.skip_vel_section) THEN - work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY",error=error) - CALL section_velocity_val_set(work_section, shell_particles, conv_factor=1.0_dp, error=error) + work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY") + CALL section_velocity_val_set(work_section, shell_particles, conv_factor=1.0_dp) END IF END IF IF (ASSOCIATED(core_particles)) THEN - work_section => section_vals_get_subs_vals(subsys_section,"CORE_COORD",error=error) - CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(work_section,"SCALED",l_val=scale,error=error) - conv_factor = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + work_section => section_vals_get_subs_vals(subsys_section,"CORE_COORD") + CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(work_section,"SCALED",l_val=scale) + conv_factor = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) CALL section_coord_val_set(work_section, core_particles, molecules, & - conv_factor, scale, cell, shell=.TRUE., error=error) + conv_factor, scale, cell, shell=.TRUE.) IF (.NOT.skip_vel_section) THEN - work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY",error=error) - CALL section_velocity_val_set(work_section, core_particles, conv_factor=1.0_dp, error=error) + work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY") + CALL section_velocity_val_set(work_section, core_particles, conv_factor=1.0_dp) END IF END IF END IF ! Updating cell info - CALL force_env_get(force_env, cell=cell, error=error) - work_section => section_vals_get_subs_vals(subsys_section,"CELL",error=error) - CALL update_cell_section(cell, cell_section=work_section, error=error) + CALL force_env_get(force_env, cell=cell) + work_section => section_vals_get_subs_vals(subsys_section,"CELL") + CALL update_cell_section(cell, cell_section=work_section) ! Updating cell_ref info use_ref_cell=.FALSE. SELECT CASE(force_env%in_use) CASE(use_qs_force) - CALL get_qs_env(force_env%qs_env,cell_ref=cell,use_ref_cell=use_ref_cell,error=error) + CALL get_qs_env(force_env%qs_env,cell_ref=cell,use_ref_cell=use_ref_cell) CASE(use_eip_force) - CALL eip_env_get(force_env%eip_env,cell_ref=cell,use_ref_cell=use_ref_cell,error=error) + CALL eip_env_get(force_env%eip_env,cell_ref=cell,use_ref_cell=use_ref_cell) END SELECT IF(use_ref_cell) THEN - work_section => section_vals_get_subs_vals(subsys_section,"CELL%CELL_REF",error=error) - CALL update_cell_section(cell, cell_section=work_section, error=error) + work_section => section_vals_get_subs_vals(subsys_section,"CELL%CELL_REF") + CALL update_cell_section(cell, cell_section=work_section) ENDIF ! Updating multipoles IF (ASSOCIATED(multipoles)) THEN - work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES",error=error) + work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES") DO IF (SIZE(work_section%values,2)==1) EXIT - CALL section_vals_add_values(work_section,error=error) + CALL section_vals_add_values(work_section) END DO IF (ASSOCIATED(multipoles%dipoles)) THEN - work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%DIPOLES",error=error) - CALL update_dipoles_section(multipoles%dipoles, work_section, error) + work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%DIPOLES") + CALL update_dipoles_section(multipoles%dipoles, work_section) END IF IF (ASSOCIATED(multipoles%quadrupoles)) THEN - work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%QUADRUPOLES",error=error) - CALL update_quadrupoles_section(multipoles%quadrupoles, work_section, error) + work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%QUADRUPOLES") + CALL update_quadrupoles_section(multipoles%quadrupoles, work_section) END IF END IF CALL timestop(handle) @@ -427,13 +410,11 @@ END SUBROUTINE update_subsys !> \brief Routine to update a cell section !> \param cell ... !> \param cell_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE update_cell_section(cell, cell_section, error) + SUBROUTINE update_cell_section(cell, cell_section) TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: cell_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_cell_section', & routineP = moduleN//':'//routineN @@ -448,26 +429,26 @@ SUBROUTINE update_cell_section(cell, cell_section, error) ! CELL VECTORS - A ALLOCATE(work(3)) work(1:3) = cell%hmat(1:3,1) - CALL section_vals_val_set(cell_section,"A",r_vals_ptr=work,error=error) + CALL section_vals_val_set(cell_section,"A",r_vals_ptr=work) ! CELL VECTORS - B ALLOCATE(work(3)) work(1:3) = cell%hmat(1:3,2) - CALL section_vals_val_set(cell_section,"B",r_vals_ptr=work,error=error) + CALL section_vals_val_set(cell_section,"B",r_vals_ptr=work) ! CELL VECTORS - C ALLOCATE(work(3)) work(1:3) = cell%hmat(1:3,3) - CALL section_vals_val_set(cell_section,"C",r_vals_ptr=work,error=error) + CALL section_vals_val_set(cell_section,"C",r_vals_ptr=work) ! MULTIPLE_UNIT_CELL ALLOCATE(iwork(3)) iwork = 1 - CALL section_vals_val_set(cell_section,"MULTIPLE_UNIT_CELL",i_vals_ptr=iwork,error=error) + CALL section_vals_val_set(cell_section,"MULTIPLE_UNIT_CELL",i_vals_ptr=iwork) ! Unset unused or misleading information - CALL section_vals_val_unset(cell_section,"ABC",error=error) - CALL section_vals_val_unset(cell_section,"ALPHA_BETA_GAMMA",error=error) + CALL section_vals_val_unset(cell_section,"ABC") + CALL section_vals_val_unset(cell_section,"ALPHA_BETA_GAMMA") CALL timestop(handle) END SUBROUTINE update_cell_section @@ -482,14 +463,12 @@ END SUBROUTINE update_cell_section !> \param scale ... !> \param cell ... !> \param shell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_factor,& - scale, cell, shell, error) + scale, cell, shell) TYPE(section_vals_type), POINTER :: coord_section TYPE(particle_list_type), POINTER :: particles TYPE(mol_new_list_type), POINTER :: molecules @@ -497,7 +476,6 @@ SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_facto LOGICAL, INTENT(IN) :: scale TYPE(cell_type), POINTER :: cell LOGICAL, INTENT(IN), OPTIONAL :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'section_coord_val_set', & routineP = moduleN//':'//routineN @@ -520,22 +498,22 @@ SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_facto NULLIFY(my_val, old_val, section, vals) my_shell = .FALSE. IF(PRESENT(shell)) my_shell = shell - CPPrecondition(ASSOCIATED(coord_section),cp_failure_level,routineP,error,failure) - CPPrecondition(coord_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(coord_section),cp_failure_level,routineP,failure) + CPPrecondition(coord_section%ref_count>0,cp_failure_level,routineP,failure) section => coord_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(coord_section%values,2)==1) EXIT - CALL section_vals_add_values(coord_section,error=error) + CALL section_vals_add_values(coord_section) END DO vals => coord_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF imol=0 last_atom=0 @@ -551,7 +529,7 @@ SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_facto END IF WRITE (UNIT=line,FMT="(A,3(1X,ES25.16),1X,I0)")& TRIM(name),s(1:3),particles%els(irk)%atom_index - CALL val_create(my_val,lc_val=line,error=error) + CALL val_create(my_val,lc_val=line) IF (Nlist /= 0) THEN IF (irk==1) THEN new_pos => vals @@ -559,16 +537,16 @@ SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_facto new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -598,7 +576,7 @@ SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_facto WRITE (UNIT=line,FMT="(A,3(1X,ES25.16))")& TRIM(name),s(1:3) END IF - CALL val_create(my_val,lc_val=line,error=error) + CALL val_create(my_val,lc_val=line) IF (Nlist /= 0) THEN IF (irk==1) THEN @@ -607,16 +585,16 @@ SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_facto new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -632,18 +610,14 @@ END SUBROUTINE section_coord_val_set !> \brief routine to dump dipoles.. fast implementation !> \param dipoles ... !> \param dipoles_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2007 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE update_dipoles_section(dipoles, dipoles_section, error) + SUBROUTINE update_dipoles_section(dipoles, dipoles_section) REAL(KIND=dp), DIMENSION(:, :), POINTER :: dipoles TYPE(section_vals_type), POINTER :: dipoles_section - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_dipoles_section', & routineP = moduleN//':'//routineN @@ -659,31 +633,31 @@ SUBROUTINE update_dipoles_section(dipoles, dipoles_section, error) CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(dipoles_section),cp_failure_level,routineP,error,failure) - CPPrecondition(dipoles_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dipoles_section),cp_failure_level,routineP,failure) + CPPrecondition(dipoles_section%ref_count>0,cp_failure_level,routineP,failure) section => dipoles_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) ! At least one of the two arguments must be present.. nloop = SIZE(dipoles,2) DO IF (SIZE(dipoles_section%values,2)==1) EXIT - CALL section_vals_add_values(dipoles_section,error=error) + CALL section_vals_add_values(dipoles_section) END DO vals => dipoles_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF DO irk=1,nloop ALLOCATE(work(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Always stored in A.U. work = dipoles(1:3,irk) - CALL val_create(my_val,r_vals_ptr=work,error=error) + CALL val_create(my_val,r_vals_ptr=work) IF (Nlist /= 0) THEN IF (irk==1) THEN @@ -692,16 +666,16 @@ SUBROUTINE update_dipoles_section(dipoles, dipoles_section, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -716,19 +690,15 @@ END SUBROUTINE update_dipoles_section !> \brief routine to dump quadrupoles.. fast implementation !> \param quadrupoles ... !> \param quadrupoles_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2007 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE update_quadrupoles_section(quadrupoles, quadrupoles_section, error) + SUBROUTINE update_quadrupoles_section(quadrupoles, quadrupoles_section) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: quadrupoles TYPE(section_vals_type), POINTER :: quadrupoles_section - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_quadrupoles_section', & routineP = moduleN//':'//routineN @@ -744,28 +714,28 @@ SUBROUTINE update_quadrupoles_section(quadrupoles, quadrupoles_section, error) CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(quadrupoles_section),cp_failure_level,routineP,error,failure) - CPPrecondition(quadrupoles_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(quadrupoles_section),cp_failure_level,routineP,failure) + CPPrecondition(quadrupoles_section%ref_count>0,cp_failure_level,routineP,failure) section => quadrupoles_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) ! At least one of the two arguments must be present.. nloop = SIZE(quadrupoles,2) DO IF (SIZE(quadrupoles_section%values,2)==1) EXIT - CALL section_vals_add_values(quadrupoles_section,error=error) + CALL section_vals_add_values(quadrupoles_section) END DO vals => quadrupoles_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF DO irk=1,nloop ALLOCATE(work(6),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Always stored in A.U. ind = 0 DO i = 1, 3 @@ -774,7 +744,7 @@ SUBROUTINE update_quadrupoles_section(quadrupoles, quadrupoles_section, error) work(ind) = quadrupoles(j,i,irk) END DO END DO - CALL val_create(my_val,r_vals_ptr=work,error=error) + CALL val_create(my_val,r_vals_ptr=work) IF (Nlist /= 0) THEN IF (irk==1) THEN @@ -783,16 +753,16 @@ SUBROUTINE update_quadrupoles_section(quadrupoles, quadrupoles_section, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -813,7 +783,6 @@ END SUBROUTINE update_quadrupoles_section !> \param output_unit ... !> \param core_or_shell ... !> \param scaled_coordinates ... -!> \param error ... !> \par History !> 07.02.2011 (Creation, MK) !> \author Matthias Krack (MK) @@ -821,7 +790,7 @@ END SUBROUTINE update_quadrupoles_section ! ***************************************************************************** SUBROUTINE dump_coordinates_cp2k(particles,molecules,cell,conv_factor,& output_unit,core_or_shell,& - scaled_coordinates,error) + scaled_coordinates) TYPE(particle_list_type), POINTER :: particles TYPE(mol_new_list_type), POINTER :: molecules @@ -830,7 +799,6 @@ SUBROUTINE dump_coordinates_cp2k(particles,molecules,cell,conv_factor,& INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN) :: core_or_shell, & scaled_coordinates - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_coordinates_cp2k', & routineP = moduleN//':'//routineN @@ -846,12 +814,12 @@ SUBROUTINE dump_coordinates_cp2k(particles,molecules,cell,conv_factor,& CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(particles),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(particles),cp_failure_level,routineP,failure) IF (.NOT.core_or_shell) THEN - CPPrecondition(ASSOCIATED(molecules),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(molecules),cp_failure_level,routineP,failure) END IF IF (scaled_coordinates) THEN - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) END IF kind_name = "" diff --git a/src/input_restart_rng.F b/src/input_restart_rng.F index 95d22a8176..252f95f109 100644 --- a/src/input_restart_rng.F +++ b/src/input_restart_rng.F @@ -33,19 +33,16 @@ MODULE input_restart_rng !> \param rng_section ... !> \param nsize ... !> \param ascii ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2006 created [teo] !> - string dump (again) instead of integer ASCII code (07.03.06,MK) !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE section_rng_val_set(rng_section, nsize, ascii, error) + SUBROUTINE section_rng_val_set(rng_section, nsize, ascii) TYPE(section_vals_type), POINTER :: rng_section INTEGER, INTENT(IN) :: nsize INTEGER, DIMENSION(:, :) :: ascii - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'section_rng_val_set', & routineP = moduleN//':'//routineN @@ -59,35 +56,35 @@ SUBROUTINE section_rng_val_set(rng_section, nsize, ascii, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rng_section),cp_failure_level,routineP,error,failure) - CPPrecondition((rng_section%ref_count > 0),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_section),cp_failure_level,routineP,failure) + CPPrecondition((rng_section%ref_count > 0),cp_failure_level,routineP,failure) NULLIFY (my_val,old_val,section,vals) section => rng_section%section - ik = section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik = section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(rng_section%values,2)==1) EXIT - CALL section_vals_add_values(rng_section,error=error) + CALL section_vals_add_values(rng_section) END DO vals => rng_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF DO irk=1,nsize CALL ascii_to_string(ascii(:,irk),rng_record) - CALL val_create(val=my_val,lc_val=rng_record,error=error) + CALL val_create(val=my_val,lc_val=rng_record) IF (Nlist /= 0) THEN IF (irk == 1) THEN @@ -96,16 +93,16 @@ SUBROUTINE section_rng_val_set(rng_section, nsize, ascii, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk == 1) THEN NULLIFY (new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY (new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF diff --git a/src/ipi_driver.F b/src/ipi_driver.F index 115022596d..3e2406572e 100644 --- a/src/ipi_driver.F +++ b/src/ipi_driver.F @@ -289,16 +289,14 @@ SUBROUTINE readbuffer_dv(psockfd, fdata, plen) !> \brief ... !> \param force_env ... !> \param globenv ... -!> \param error ... !> \par History !> 12.2013 included in repository !> \author Ceriotti ! ***************************************************************************** - SUBROUTINE run_driver ( force_env, globenv, error ) + SUBROUTINE run_driver ( force_env, globenv) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'run_driver', & routineP = moduleN//':'//routineN @@ -331,12 +329,12 @@ SUBROUTINE run_driver ( force_env, globenv, error ) ionode=(default_para_env%source==default_para_env%mepos) ! reads driver parameters from input - motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION",error=error) - drv_section => section_vals_get_subs_vals(motion_section,"DRIVER",error=error) + motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION") + drv_section => section_vals_get_subs_vals(motion_section,"DRIVER") - CALL section_vals_val_get(drv_section,"HOST",c_val=drv_hostname,error=error) - CALL section_vals_val_get(drv_section,"PORT",i_val=drv_port,error=error) - CALL section_vals_val_get(drv_section,"UNIX",l_val=drv_unix,error=error) + CALL section_vals_val_get(drv_section,"HOST",c_val=drv_hostname) + CALL section_vals_val_get(drv_section,"PORT",i_val=drv_port) + CALL section_vals_val_get(drv_section,"UNIX",l_val=drv_unix) #ifdef __NO_IPI_DRIVER CALL stop_program(routineN,moduleN,__LINE__,"CP2K was compiled with the __NO_IPI_DRIVER option!") @@ -356,7 +354,7 @@ SUBROUTINE run_driver ( force_env, globenv, error ) !now we have a socket, so we can initialize the CP2K environments. NULLIFY(cpcell) - CALL cell_create(cpcell,error=error) + CALL cell_create(cpcell) driver_loop: DO ! do communication on master node only... header = "" @@ -398,7 +396,7 @@ SUBROUTINE run_driver ( force_env, globenv, error ) IF (ionode) CALL readbuffer(socket, combuf, nat*3) CALL mp_bcast(combuf,default_para_env%source, default_para_env%group) - CALL force_env_get(force_env,subsys=subsys,error=error) + CALL force_env_get(force_env,subsys=subsys) IF (nat/=subsys%particles%n_els) WRITE(*,*) & " @DRIVER MODE: Uh-oh! Particle number mismatch between i-PI and cp2k input!" ii=0 @@ -409,9 +407,9 @@ SUBROUTINE run_driver ( force_env, globenv, error ) END DO END DO CALL init_cell(cpcell, hmat=cellh) - CALL cp_subsys_set(subsys, cell=cpcell, error=error) + CALL cp_subsys_set(subsys, cell=cpcell) - CALL force_env_calc_energy_force(force_env,calc_force=.TRUE. ,error=error) + CALL force_env_calc_energy_force(force_env,calc_force=.TRUE.) IF (ionode) WRITE(*,*) " @ DRIVER MODE: Received positions " @@ -423,12 +421,12 @@ SUBROUTINE run_driver ( force_env, globenv, error ) combuf(ii)=subsys%particles%els(ip)%f(idir) END DO END DO - CALL force_env_get(force_env, potential_energy=pot, error=error) - CALL force_env_get(force_env,cell=cpcell, error=error) - CALL cp_subsys_get(subsys, virial=virial, error=error) + CALL force_env_get(force_env, potential_energy=pot) + CALL force_env_get(force_env,cell=cpcell) + CALL cp_subsys_get(subsys, virial=virial) vir = TRANSPOSE(virial%pv_virial) - CALL external_control(should_stop,"IPI",globenv=globenv,error=error) + CALL external_control(should_stop,"IPI",globenv=globenv) IF (should_stop) EXIT hasdata=.TRUE. diff --git a/src/iterate_matrix.F b/src/iterate_matrix.F index 054d177379..e9fd9470bc 100644 --- a/src/iterate_matrix.F +++ b/src/iterate_matrix.F @@ -53,21 +53,19 @@ MODULE iterate_matrix !> \param use_inv_as_guess logical whether input can be used as guess for inverse !> \param norm_convergence convergence threshold for the 2-norm, useful for approximate solutions !> \param filter_eps filter_eps for matrix multiplications, if not passed nothing is filteres -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> 2011.10 guess option added [Rustam Z Khaliullin] !> \author Joost VandeVondele ! ***************************************************************************** SUBROUTINE invert_Hotelling(matrix_inverse,matrix,threshold,use_inv_as_guess,& - norm_convergence,filter_eps,error) + norm_convergence,filter_eps) TYPE(cp_dbcsr_type), INTENT(INOUT), & TARGET :: matrix_inverse, matrix REAL(KIND=dp), INTENT(IN) :: threshold LOGICAL, INTENT(IN), OPTIONAL :: use_inv_as_guess REAL(KIND=dp), INTENT(IN), OPTIONAL :: norm_convergence, filter_eps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'invert_Hotelling', & routineP = moduleN//':'//routineN @@ -86,7 +84,7 @@ SUBROUTINE invert_Hotelling(matrix_inverse,matrix,threshold,use_inv_as_guess,& CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -102,21 +100,21 @@ SUBROUTINE invert_Hotelling(matrix_inverse,matrix,threshold,use_inv_as_guess,& ! initialize matrix to unity and use arnoldi to scale it into the convergence range gershgorin_norm=cp_dbcsr_gershgorin_norm(matrix) frob_matrix=cp_dbcsr_frobenius_norm(matrix) - CALL cp_dbcsr_set(matrix_inverse,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_inverse,1.0_dp,error=error) + CALL cp_dbcsr_set(matrix_inverse,0.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_inverse,1.0_dp) ! everything commutes, therefor our all products will be symmetric - CALL cp_dbcsr_init(tmp1,error=error) - CALL cp_dbcsr_create(tmp1,template=matrix_inverse,error=error) + CALL cp_dbcsr_init(tmp1) + CALL cp_dbcsr_create(tmp1,template=matrix_inverse) ELSE ! It is unlikely that our guess will commute with the matrix, therefore the first product will ! be non symmetric - CALL cp_dbcsr_init(tmp1,error=error) - CALL cp_dbcsr_create(tmp1,template=matrix_inverse,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(tmp1) + CALL cp_dbcsr_create(tmp1,template=matrix_inverse,matrix_type=dbcsr_type_no_symmetry) ENDIF CALL cp_dbcsr_get_info(matrix, nfullrows_total=nrow ) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=matrix_inverse,error=error) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=matrix_inverse) IF (unit_nr>0) WRITE(unit_nr,*) @@ -124,20 +122,20 @@ SUBROUTINE invert_Hotelling(matrix_inverse,matrix,threshold,use_inv_as_guess,& ! scale the approximate inverse to be within the convergence radius t1 = m_walltime() CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_inverse, matrix,& - 0.0_dp, tmp1,flop=flop1, filter_eps=filter_eps, error=error) + 0.0_dp, tmp1,flop=flop1, filter_eps=filter_eps) mymat(1)%matrix=>tmp1 CALL cp_dbcsr_setup_arnoldi_data(my_arnoldi,mymat,max_iter=30,threshold=1.0E-3_dp,selection_crit=1, & nval_request=2, nrestarts=2, generalized_ev=.FALSE.,iram=.TRUE.) - CALL cp_dbcsr_arnoldi_ev(mymat,my_arnoldi,error) + CALL cp_dbcsr_arnoldi_ev(mymat,my_arnoldi) max_eV=REAL(get_selected_ritz_val(my_arnoldi,2),dp) min_eV=REAL(get_selected_ritz_val(my_arnoldi,1),dp) CALL deallocate_arnoldi_data(my_arnoldi) occ_matrix=cp_dbcsr_get_occupation(matrix_inverse) ! 2.0 would be the correct scaling howver, we should make sure here, that we are in the convergence radius - CALL cp_dbcsr_scale(tmp1,1.9_dp/(min_ev+max_ev),error=error) - CALL cp_dbcsr_scale(matrix_inverse,1.9_dp/(min_ev+max_ev),error=error) + CALL cp_dbcsr_scale(tmp1,1.9_dp/(min_ev+max_ev)) + CALL cp_dbcsr_scale(matrix_inverse,1.9_dp/(min_ev+max_ev)) min_ev=min_ev*1.9_dp/(min_ev+max_ev) DO i=1,100 @@ -146,21 +144,21 @@ SUBROUTINE invert_Hotelling(matrix_inverse,matrix,threshold,use_inv_as_guess,& ! for the convergence check !frob_matrix_base=cp_dbcsr_frobenius_norm(tmp1) - CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(tmp1) CALL cp_dbcsr_norm(tmp1,& - dbcsr_norm_maxabsnorm, norm_scalar=maxnorm_matrix, error=error) + dbcsr_norm_maxabsnorm, norm_scalar=maxnorm_matrix) - CALL cp_dbcsr_add_on_diag(tmp1,+1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,+1.0_dp) ! tmp2 = S^-1 S S^-1 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, tmp1, matrix_inverse, 0.0_dp, tmp2,& - flop=flop2, filter_eps=filter_eps, error=error) + flop=flop2, filter_eps=filter_eps) ! S^-1_{n+1} = 2 S^-1 - S^-1 S S^-1 - CALL cp_dbcsr_add(matrix_inverse, tmp2, 2.0_dp, -1.0_dp, error=error) + CALL cp_dbcsr_add(matrix_inverse, tmp2, 2.0_dp, -1.0_dp) - CALL cp_dbcsr_filter(matrix_inverse, threshold, error=error) + CALL cp_dbcsr_filter(matrix_inverse, threshold) t2 = m_walltime() occ_matrix=cp_dbcsr_get_occupation(matrix_inverse) @@ -179,18 +177,18 @@ SUBROUTINE invert_Hotelling(matrix_inverse,matrix,threshold,use_inv_as_guess,& ! scale the matrix for improved convergence min_ev=min_ev*2.0_dp/(min_ev+1.0_dp) - CALL cp_dbcsr_scale(matrix_inverse,2.0_dp/(min_ev+1.0_dp),error=error) + CALL cp_dbcsr_scale(matrix_inverse,2.0_dp/(min_ev+1.0_dp)) t1 = m_walltime() CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_inverse, matrix,& - 0.0_dp, tmp1,flop=flop1, filter_eps=filter_eps, error=error) + 0.0_dp, tmp1,flop=flop1, filter_eps=filter_eps) ENDDO ! try to symmetrize the output matrix IF(cp_dbcsr_get_matrix_type(matrix_inverse)==dbcsr_type_no_symmetry)THEN - CALL cp_dbcsr_transposed(tmp2,matrix_inverse,error=error) - CALL cp_dbcsr_add(matrix_inverse,tmp2,0.5_dp,0.5_dp,error=error) + CALL cp_dbcsr_transposed(tmp2,matrix_inverse) + CALL cp_dbcsr_add(matrix_inverse,tmp2,0.5_dp,0.5_dp) END IF IF (unit_nr>0) THEN @@ -201,8 +199,8 @@ SUBROUTINE invert_Hotelling(matrix_inverse,matrix,threshold,use_inv_as_guess,& CALL m_flush(unit_nr) ENDIF - CALL cp_dbcsr_release(tmp1,error=error) - CALL cp_dbcsr_release(tmp2,error=error) + CALL cp_dbcsr_release(tmp1) + CALL cp_dbcsr_release(tmp2) CALL timestop(handle) @@ -213,16 +211,14 @@ END SUBROUTINE invert_Hotelling !> \param matrix_sign ... !> \param matrix ... !> \param threshold ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE matrix_sign_Newton_Schulz(matrix_sign,matrix,threshold,error) + SUBROUTINE matrix_sign_Newton_Schulz(matrix_sign,matrix,threshold) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_sign, matrix REAL(KIND=dp), INTENT(IN) :: threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'matrix_sign_Newton_Schulz', & routineP = moduleN//':'//routineN @@ -238,26 +234,26 @@ SUBROUTINE matrix_sign_Newton_Schulz(matrix_sign,matrix,threshold,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE unit_nr=-1 ENDIF - CALL cp_dbcsr_init(tmp1,error=error) - CALL cp_dbcsr_create(tmp1,template=matrix_sign,error=error) + CALL cp_dbcsr_init(tmp1) + CALL cp_dbcsr_create(tmp1,template=matrix_sign) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=matrix_sign,error=error) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=matrix_sign) - CALL cp_dbcsr_copy(matrix_sign,matrix,error=error) - CALL cp_dbcsr_filter(matrix_sign,threshold,error=error) + CALL cp_dbcsr_copy(matrix_sign,matrix) + CALL cp_dbcsr_filter(matrix_sign,threshold) ! scale the matrix to get into the convergence range frob_matrix=cp_dbcsr_frobenius_norm(matrix_sign) gersh_matrix=cp_dbcsr_gershgorin_norm(matrix_sign) - CALL cp_dbcsr_scale(matrix_sign,1/MIN(frob_matrix,gersh_matrix),error=error) + CALL cp_dbcsr_scale(matrix_sign,1/MIN(frob_matrix,gersh_matrix)) IF (unit_nr>0) WRITE(unit_nr,*) @@ -267,24 +263,24 @@ SUBROUTINE matrix_sign_Newton_Schulz(matrix_sign,matrix,threshold,error) t1 = m_walltime() ! tmp1 = X * X CALL cp_dbcsr_multiply("N", "N", -1.0_dp, matrix_sign, matrix_sign, 0.0_dp, tmp1,& - filter_eps=threshold, flop=flop1, error=error) + filter_eps=threshold, flop=flop1) ! check convergence (frob norm of what should be the identity matrix minus identity matrix) frob_matrix_base=cp_dbcsr_frobenius_norm(tmp1) - CALL cp_dbcsr_add_on_diag(tmp1,+1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,+1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(tmp1) ! update the above to 3*I-X*X - CALL cp_dbcsr_add_on_diag(tmp1,+2.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,+2.0_dp) occ_matrix=cp_dbcsr_get_occupation(matrix_sign) ! tmp2 = 0.5 * X * (3*I-X*X) CALL cp_dbcsr_multiply("N", "N", 0.5_dp, matrix_sign, tmp1, 0.0_dp, tmp2, & - filter_eps=threshold, flop=flop2, error=error) + filter_eps=threshold, flop=flop2) ! done iterating - ! CALL cp_dbcsr_filter(tmp2,threshold,error=error) - CALL cp_dbcsr_copy(matrix_sign,tmp2,error=error) + ! CALL cp_dbcsr_filter(tmp2,threshold) + CALL cp_dbcsr_copy(matrix_sign,tmp2) t2 = m_walltime() IF (unit_nr>0) THEN @@ -300,9 +296,9 @@ SUBROUTINE matrix_sign_Newton_Schulz(matrix_sign,matrix,threshold,error) ! this check is not really needed CALL cp_dbcsr_multiply("N", "N", +1.0_dp, matrix_sign, matrix_sign, 0.0_dp, tmp1,& - filter_eps=threshold, error=error) + filter_eps=threshold) frob_matrix_base=cp_dbcsr_frobenius_norm(tmp1) - CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(tmp1) occ_matrix=cp_dbcsr_get_occupation(matrix_sign) IF (unit_nr>0) THEN @@ -312,8 +308,8 @@ SUBROUTINE matrix_sign_Newton_Schulz(matrix_sign,matrix,threshold,error) CALL m_flush(unit_nr) ENDIF - CALL cp_dbcsr_release(tmp1,error=error) - CALL cp_dbcsr_release(tmp2,error=error) + CALL cp_dbcsr_release(tmp1) + CALL cp_dbcsr_release(tmp2) CALL timestop(handle) @@ -329,12 +325,11 @@ END SUBROUTINE matrix_sign_Newton_Schulz !> \param order ... !> \param eps_lanczos ... !> \param max_iter_lanczos ... -!> \param error ... !> \par History !> 2010.10 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshold, order, eps_lanczos, max_iter_lanczos, error) + SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshold, order, eps_lanczos, max_iter_lanczos) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_sqrt, matrix_sqrt_inv, & matrix @@ -342,7 +337,6 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol INTEGER, INTENT(IN) :: order REAL(KIND=dp), INTENT(IN) :: eps_lanczos INTEGER, INTENT(IN) :: max_iter_lanczos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'matrix_sqrt_Newton_Schulz', & routineP = moduleN//':'//routineN @@ -362,7 +356,7 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -370,23 +364,23 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol ENDIF ! for stability symmetry can not be assumed - CALL cp_dbcsr_init(tmp1,error=error) - CALL cp_dbcsr_create(tmp1,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(tmp1) + CALL cp_dbcsr_create(tmp1,template=matrix,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=matrix,matrix_type=dbcsr_type_no_symmetry) IF (order.GE.4) THEN - CALL cp_dbcsr_init(tmp3,error=error) - CALL cp_dbcsr_create(tmp3,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(tmp3) + CALL cp_dbcsr_create(tmp3,template=matrix,matrix_type=dbcsr_type_no_symmetry) ENDIF - CALL cp_dbcsr_set(matrix_sqrt_inv,0.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(matrix_sqrt_inv,1.0_dp,error=error) - CALL cp_dbcsr_filter(matrix_sqrt_inv,threshold,error=error) - CALL cp_dbcsr_copy(matrix_sqrt,matrix,error=error) + CALL cp_dbcsr_set(matrix_sqrt_inv,0.0_dp) + CALL cp_dbcsr_add_on_diag(matrix_sqrt_inv,1.0_dp) + CALL cp_dbcsr_filter(matrix_sqrt_inv,threshold) + CALL cp_dbcsr_copy(matrix_sqrt,matrix) ! scale the matrix to get into the convergence range CALL cp_dbcsr_arnoldi_extremal(matrix_sqrt, max_ev, min_ev, threshold=eps_lanczos, & - max_iter=max_iter_lanczos, converged=converged, error=error) + max_iter=max_iter_lanczos, converged=converged) IF (unit_nr>0) THEN WRITE(unit_nr,*) WRITE(unit_nr,'(T6,A,1X,L1,A,E12.3)') "Lanczos converged: ",converged," threshold:",eps_lanczos @@ -397,8 +391,8 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol ! and adjust the scaling to be on the safe side scaling=2/(max_ev+min_ev+100*eps_lanczos) - CALL cp_dbcsr_scale(matrix_sqrt,scaling,error=error) - CALL cp_dbcsr_filter(matrix_sqrt,threshold,error=error) + CALL cp_dbcsr_scale(matrix_sqrt,scaling) + CALL cp_dbcsr_filter(matrix_sqrt,threshold) DO i=1,100 @@ -406,9 +400,9 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol ! tmp1 = Zk * Yk - I CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_sqrt_inv, matrix_sqrt, 0.0_dp, tmp1,& - filter_eps=threshold, flop=flop1, error=error) + filter_eps=threshold, flop=flop1) frob_matrix_base=cp_dbcsr_frobenius_norm(tmp1) - CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp) ! check convergence (frob norm of what should be the identity matrix minus identity matrix) frob_matrix=cp_dbcsr_frobenius_norm(tmp1) @@ -417,28 +411,28 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol SELECT CASE(order) CASE(2) ! update the above to 0.5*(3*I-Zk*Yk) - CALL cp_dbcsr_add_on_diag(tmp1,-2.0_dp,error=error) - CALL cp_dbcsr_scale(tmp1,-0.5_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,-2.0_dp) + CALL cp_dbcsr_scale(tmp1,-0.5_dp) CASE(3) ! tmp2 = tmp1 ** 2 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, tmp1, tmp1, 0.0_dp, tmp2,& - filter_eps=threshold, flop=flop4, error=error) + filter_eps=threshold, flop=flop4) ! tmp1 = 1/16 * (16*I-8*tmp1+6*tmp1**2-5*tmp1**3) - CALL cp_dbcsr_add(tmp1, tmp2, -4.0_dp, 3.0_dp, error=error) - CALL cp_dbcsr_add_on_diag(tmp1,8.0_dp,error=error) - CALL cp_dbcsr_scale(tmp1,0.125_dp,error=error) + CALL cp_dbcsr_add(tmp1, tmp2, -4.0_dp, 3.0_dp) + CALL cp_dbcsr_add_on_diag(tmp1,8.0_dp) + CALL cp_dbcsr_scale(tmp1,0.125_dp) CASE(4) ! as expensive as case(5), so little need to use it ! tmp2 = tmp1 ** 2 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, tmp1, tmp1, 0.0_dp, tmp2,& - filter_eps=threshold, flop=flop4, error=error) + filter_eps=threshold, flop=flop4) ! tmp3 = tmp2 * tmp1 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, tmp2, tmp1, 0.0_dp, tmp3,& - filter_eps=threshold, flop=flop5, error=error) - CALL cp_dbcsr_scale(tmp1,-8.0_dp,error=error) - CALL cp_dbcsr_add_on_diag(tmp1,16.0_dp,error=error) - CALL cp_dbcsr_add(tmp1, tmp2, 1.0_dp, 6.0_dp, error=error) - CALL cp_dbcsr_add(tmp1, tmp3, 1.0_dp,-5.0_dp, error=error) - CALL cp_dbcsr_scale(tmp1,1/16.0_dp,error=error) + filter_eps=threshold, flop=flop5) + CALL cp_dbcsr_scale(tmp1,-8.0_dp) + CALL cp_dbcsr_add_on_diag(tmp1,16.0_dp) + CALL cp_dbcsr_add(tmp1, tmp2, 1.0_dp, 6.0_dp) + CALL cp_dbcsr_add(tmp1, tmp3, 1.0_dp,-5.0_dp) + CALL cp_dbcsr_scale(tmp1,1/16.0_dp) CASE(5) ! Knuth's reformulation to evaluate the polynomial of 4th degree in 2 multiplications ! p = y4+A*y3+B*y2+C*y+D @@ -456,36 +450,36 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol d=od-b*c ! tmp2 = tmp1 ** 2 + a * tmp1 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, tmp1, tmp1, 0.0_dp, tmp2,& - filter_eps=threshold, flop=flop4, error=error) - CALL cp_dbcsr_add(tmp2, tmp1, 1.0_dp, a , error=error) + filter_eps=threshold, flop=flop4) + CALL cp_dbcsr_add(tmp2, tmp1, 1.0_dp, a) ! tmp3 = tmp2 + tmp1 + b - CALL cp_dbcsr_copy(tmp3,tmp2,error=error) - CALL cp_dbcsr_add(tmp3, tmp1, 1.0_dp, 1.0_dp , error=error) - CALL cp_dbcsr_add_on_diag(tmp3,b,error=error) + CALL cp_dbcsr_copy(tmp3,tmp2) + CALL cp_dbcsr_add(tmp3, tmp1, 1.0_dp, 1.0_dp) + CALL cp_dbcsr_add_on_diag(tmp3,b) ! tmp2 = tmp2 + c - CALL cp_dbcsr_add_on_diag(tmp2,c,error=error) + CALL cp_dbcsr_add_on_diag(tmp2,c) ! tmp1 = tmp2 * tmp3 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, tmp2, tmp3, 0.0_dp, tmp1,& - filter_eps=threshold, flop=flop5, error=error) + filter_eps=threshold, flop=flop5) ! tmp1 = tmp1 + d - CALL cp_dbcsr_add_on_diag(tmp1,d,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,d) ! final scale - CALL cp_dbcsr_scale(tmp1,35.0_dp/128.0_dp,error=error) + CALL cp_dbcsr_scale(tmp1,35.0_dp/128.0_dp) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! tmp2 = Yk * tmp1 = Y(k+1) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_sqrt, tmp1, 0.0_dp, tmp2,& - filter_eps=threshold, flop=flop2, error=error) - ! CALL cp_dbcsr_filter(tmp2,threshold,error=error) - CALL cp_dbcsr_copy(matrix_sqrt, tmp2, error=error) + filter_eps=threshold, flop=flop2) + ! CALL cp_dbcsr_filter(tmp2,threshold) + CALL cp_dbcsr_copy(matrix_sqrt, tmp2) ! tmp2 = tmp1 * Zk = Z(k+1) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, tmp1, matrix_sqrt_inv, 0.0_dp, tmp2,& - filter_eps=threshold,flop=flop3, error=error) - ! CALL cp_dbcsr_filter(tmp2,threshold,error=error) - CALL cp_dbcsr_copy(matrix_sqrt_inv, tmp2, error=error) + filter_eps=threshold,flop=flop3) + ! CALL cp_dbcsr_filter(tmp2,threshold) + CALL cp_dbcsr_copy(matrix_sqrt_inv, tmp2) occ_matrix=cp_dbcsr_get_occupation(matrix_sqrt_inv) @@ -504,16 +498,16 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol ENDDO ! symmetrize the matrices as this is not guaranteed by the algorithm - CALL cp_dbcsr_transposed(tmp1,matrix_sqrt_inv,error=error) - CALL cp_dbcsr_add(matrix_sqrt_inv,tmp1,0.5_dp,0.5_dp,error=error) - CALL cp_dbcsr_transposed(tmp1,matrix_sqrt,error=error) - CALL cp_dbcsr_add(matrix_sqrt,tmp1,0.5_dp,0.5_dp,error=error) + CALL cp_dbcsr_transposed(tmp1,matrix_sqrt_inv) + CALL cp_dbcsr_add(matrix_sqrt_inv,tmp1,0.5_dp,0.5_dp) + CALL cp_dbcsr_transposed(tmp1,matrix_sqrt) + CALL cp_dbcsr_add(matrix_sqrt,tmp1,0.5_dp,0.5_dp) ! this check is not really needed CALL cp_dbcsr_multiply("N", "N", +1.0_dp, matrix_sqrt_inv, matrix_sqrt, 0.0_dp, tmp1,& - filter_eps=threshold,error=error) + filter_eps=threshold) frob_matrix_base=cp_dbcsr_frobenius_norm(tmp1) - CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp,error=error) + CALL cp_dbcsr_add_on_diag(tmp1,-1.0_dp) frob_matrix=cp_dbcsr_frobenius_norm(tmp1) occ_matrix=cp_dbcsr_get_occupation(matrix_sqrt_inv) IF (unit_nr>0) THEN @@ -524,13 +518,13 @@ SUBROUTINE matrix_sqrt_Newton_Schulz(matrix_sqrt,matrix_sqrt_inv,matrix,threshol ENDIF ! scale to proper end results - CALL cp_dbcsr_scale(matrix_sqrt,1/SQRT(scaling),error=error) - CALL cp_dbcsr_scale(matrix_sqrt_inv,SQRT(scaling),error=error) + CALL cp_dbcsr_scale(matrix_sqrt,1/SQRT(scaling)) + CALL cp_dbcsr_scale(matrix_sqrt_inv,SQRT(scaling)) - CALL cp_dbcsr_release(tmp1,error=error) - CALL cp_dbcsr_release(tmp2,error=error) + CALL cp_dbcsr_release(tmp1) + CALL cp_dbcsr_release(tmp2) IF (order.GE.4) THEN - CALL cp_dbcsr_release(tmp3,error=error) + CALL cp_dbcsr_release(tmp3) ENDIF CALL timestop(handle) @@ -544,13 +538,11 @@ END SUBROUTINE matrix_sqrt_Newton_Schulz !> \param omega ... !> \param alpha ... !> \param threshold ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE matrix_exponential(matrix_exp,matrix,omega,alpha,threshold,error) + SUBROUTINE matrix_exponential(matrix_exp,matrix,omega,alpha,threshold) ! compute matrix_exp=omega*exp(alpha*matrix) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_exp, matrix REAL(KIND=dp), INTENT(IN) :: omega, alpha, threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'matrix_exponential', & routineP = moduleN//':'//routineN @@ -566,7 +558,7 @@ SUBROUTINE matrix_exponential(matrix_exp,matrix,omega,alpha,threshold,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -584,46 +576,46 @@ SUBROUTINE matrix_exponential(matrix_exp,matrix,omega,alpha,threshold,error) END DO ! copy and scale the input matrix in matrix C and in matrix D - CALL cp_dbcsr_init(C,error=error) - CALL cp_dbcsr_create(C,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(C,matrix,error=error) - CALL cp_dbcsr_scale(C, alpha_scalar=alpha/2.0_dp**k, error=error) + CALL cp_dbcsr_init(C) + CALL cp_dbcsr_create(C,template=matrix,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(C,matrix) + CALL cp_dbcsr_scale(C, alpha_scalar=alpha/2.0_dp**k) - CALL cp_dbcsr_init(D,error=error) - CALL cp_dbcsr_create(D,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(D,C,error=error) + CALL cp_dbcsr_init(D) + CALL cp_dbcsr_create(D,template=matrix,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(D,C) ! write(*,*) ! write(*,*) - ! CALL cp_dbcsr_print(D, nodata=.FALSE., matlab_format=.TRUE., variable_name="D", unit_nr=6, error=error) + ! CALL cp_dbcsr_print(D, nodata=.FALSE., matlab_format=.TRUE., variable_name="D", unit_nr=6) ! set the B matrix as B=Identity+D - CALL cp_dbcsr_init(B,error=error) - CALL cp_dbcsr_create(B,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_copy(B,D,error=error) - CALL cp_dbcsr_add_on_diag(B, alpha_scalar=one, error=error) + CALL cp_dbcsr_init(B) + CALL cp_dbcsr_create(B,template=matrix,matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_copy(B,D) + CALL cp_dbcsr_add_on_diag(B, alpha_scalar=one) - ! CALL cp_dbcsr_print(B, nodata=.FALSE., matlab_format=.TRUE., variable_name="B", unit_nr=6, error=error) + ! CALL cp_dbcsr_print(B, nodata=.FALSE., matlab_format=.TRUE., variable_name="B", unit_nr=6) ! Calculate the norm of C and moltiply by toll to be used as a threshold norm_C=toll*cp_dbcsr_frobenius_norm(matrix) ! iteration for the trucated taylor series expansion - CALL cp_dbcsr_init(D_product,error=error) - CALL cp_dbcsr_create(D_product,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(D_product) + CALL cp_dbcsr_create(D_product,template=matrix,matrix_type=dbcsr_type_no_symmetry) i=1 DO i=i+1 ! compute D_product=D*C CALL cp_dbcsr_multiply("N", "N", one, D, C, & - zero, D_product, filter_eps=threshold,error=error) + zero, D_product, filter_eps=threshold) ! copy D_product in D - CALL cp_dbcsr_copy(D,D_product,error=error) + CALL cp_dbcsr_copy(D,D_product) ! calculate B=B+D_product/fat(i) factorial=ifac(i) - CALL cp_dbcsr_add(B, D_product, one, factorial, error=error) + CALL cp_dbcsr_add(B, D_product, one, factorial) ! check for convergence using the norm of D (copy of the matrix D_product) and C norm_D=factorial*cp_dbcsr_frobenius_norm(D) @@ -631,21 +623,21 @@ SUBROUTINE matrix_exponential(matrix_exp,matrix,omega,alpha,threshold,error) END DO ! start the k iteration for the squaring of the matrix - CALL cp_dbcsr_init(B_square,error=error) - CALL cp_dbcsr_create(B_square,template=matrix,matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(B_square) + CALL cp_dbcsr_create(B_square,template=matrix,matrix_type=dbcsr_type_no_symmetry) DO i=1, k !compute B_square=B*B CALL cp_dbcsr_multiply("N", "N", one, B, B, & - zero, B_square, filter_eps=threshold,error=error) + zero, B_square, filter_eps=threshold) ! copy Bsquare in B to iterate - CALL cp_dbcsr_copy(B,B_square,error=error) + CALL cp_dbcsr_copy(B,B_square) END DO ! copy B_square in matrix_exp and - CALL cp_dbcsr_copy(matrix_exp,B_square,error=error) + CALL cp_dbcsr_copy(matrix_exp,B_square) ! scale matrix_exp by omega, matrix_exp=omega*B_square - CALL cp_dbcsr_scale(matrix_exp, alpha_scalar=omega, error=error) + CALL cp_dbcsr_scale(matrix_exp, alpha_scalar=omega) ! write(*,*) alpha,omega CALL timestop(handle) @@ -657,17 +649,15 @@ END SUBROUTINE matrix_exponential !> \param matrix_p Matrix to purify (needs to be almost idempotent already) !> \param threshold Threshold used as filter_eps and convergence criteria !> \param max_steps Max number of iterations -!> \param error The error-handler !> \par History !> 2013.01 created [Florian Schiffmann] !> 2014.07 slightly refactored [Ole Schuett] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE purify_mcweeny_orth(matrix_p,threshold,max_steps,error) + SUBROUTINE purify_mcweeny_orth(matrix_p,threshold,max_steps) TYPE(cp_dbcsr_type), DIMENSION(:) :: matrix_p REAL(KIND=dp) :: threshold INTEGER :: max_steps - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'purify_mcweeny_orth', & routineP = moduleN//':'//routineN @@ -678,40 +668,40 @@ SUBROUTINE purify_mcweeny_orth(matrix_p,threshold,max_steps,error) TYPE(cp_logger_type), POINTER :: logger CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE unit_nr=-1 ENDIF - CALL cp_dbcsr_init(matrix_pp,error=error) - CALL cp_dbcsr_create(matrix_pp,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_create(matrix_tmp,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_pp) + CALL cp_dbcsr_create(matrix_pp,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry) DO ispin=1,SIZE(matrix_p) DO i=1,max_steps CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p(ispin), matrix_p(ispin),& - 0.0_dp, matrix_pp, filter_eps=threshold, error=error) + 0.0_dp, matrix_pp, filter_eps=threshold) ! test convergence - CALL cp_dbcsr_copy(matrix_tmp, matrix_pp, error=error) - CALL cp_dbcsr_add(matrix_tmp, matrix_p(ispin), 1.0_dp, -1.0_dp, error=error) + CALL cp_dbcsr_copy(matrix_tmp, matrix_pp) + CALL cp_dbcsr_add(matrix_tmp, matrix_p(ispin), 1.0_dp, -1.0_dp) frob_norm = cp_dbcsr_frobenius_norm(matrix_tmp) ! tmp = PP - P IF(unit_nr > 0) WRITE(unit_nr,'(t3,a,f16.8)')"McWeeny: Deviation of idempotency",frob_norm IF(frob_norm<1000_dp*threshold .AND. i>1) EXIT ! construct new P - CALL cp_dbcsr_copy(matrix_tmp, matrix_pp, error=error) + CALL cp_dbcsr_copy(matrix_tmp, matrix_pp) CALL cp_dbcsr_multiply("N", "N", -2.0_dp, matrix_pp, matrix_p(ispin),& - 3.0_dp, matrix_tmp, filter_eps=threshold, error=error) - CALL cp_dbcsr_copy(matrix_p(ispin), matrix_tmp, error=error) ! tmp = 3PP - 2PPP + 3.0_dp, matrix_tmp, filter_eps=threshold) + CALL cp_dbcsr_copy(matrix_p(ispin), matrix_tmp) ! tmp = 3PP - 2PPP END DO END DO - CALL cp_dbcsr_release(matrix_pp,error) - CALL cp_dbcsr_release(matrix_tmp,error) + CALL cp_dbcsr_release(matrix_pp) + CALL cp_dbcsr_release(matrix_tmp) CALL timestop(handle) END SUBROUTINE purify_mcweeny_orth @@ -721,18 +711,16 @@ END SUBROUTINE purify_mcweeny_orth !> \param matrix_s Overlap-Matrix !> \param threshold Threshold used as filter_eps and convergence criteria !> \param max_steps Max number of iterations -!> \param error The error-handler !> \par History !> 2013.01 created [Florian Schiffmann] !> 2014.07 slightly refactored [Ole Schuett] !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE purify_mcweeny_nonorth(matrix_p,matrix_s,threshold,max_steps,error) + SUBROUTINE purify_mcweeny_nonorth(matrix_p,matrix_s,threshold,max_steps) TYPE(cp_dbcsr_type), DIMENSION(:) :: matrix_p TYPE(cp_dbcsr_type) :: matrix_s REAL(KIND=dp) :: threshold INTEGER :: max_steps - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'purify_mcweeny_nonorth', & routineP = moduleN//':'//routineN @@ -745,44 +733,44 @@ SUBROUTINE purify_mcweeny_nonorth(matrix_p,matrix_s,threshold,max_steps,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE unit_nr=-1 ENDIF - CALL cp_dbcsr_init(matrix_ps,error=error) - CALL cp_dbcsr_create(matrix_ps,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_psp,error=error) - CALL cp_dbcsr_create(matrix_psp,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init(matrix_test,error=error) - CALL cp_dbcsr_create(matrix_test,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry,error=error) + CALL cp_dbcsr_init(matrix_ps) + CALL cp_dbcsr_create(matrix_ps,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_psp) + CALL cp_dbcsr_create(matrix_psp,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init(matrix_test) + CALL cp_dbcsr_create(matrix_test,template=matrix_p(1),matrix_type=dbcsr_type_no_symmetry) DO ispin=1,SIZE(matrix_p) DO i=1,max_steps CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_p(ispin), matrix_s,& - 0.0_dp, matrix_ps, filter_eps=threshold,error=error) + 0.0_dp, matrix_ps, filter_eps=threshold) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, matrix_ps, matrix_p(ispin),& - 0.0_dp, matrix_psp, filter_eps=threshold,error=error) + 0.0_dp, matrix_psp, filter_eps=threshold) ! test convergence - CALL cp_dbcsr_copy(matrix_test, matrix_psp, error=error) - CALL cp_dbcsr_add(matrix_test, matrix_p(ispin), 1.0_dp,-1.0_dp, error=error) + CALL cp_dbcsr_copy(matrix_test, matrix_psp) + CALL cp_dbcsr_add(matrix_test, matrix_p(ispin), 1.0_dp,-1.0_dp) frob_norm = cp_dbcsr_frobenius_norm(matrix_test) ! test = PSP - P IF(unit_nr>0) WRITE(unit_nr,'(t3,a,2f16.8)')"McWeeny: Deviation of idempotency",frob_norm IF(frob_norm<1000_dp*threshold .AND. i>1) EXIT ! construct new P - CALL cp_dbcsr_copy(matrix_p(ispin), matrix_psp, error=error) + CALL cp_dbcsr_copy(matrix_p(ispin), matrix_psp) CALL cp_dbcsr_multiply("N", "N", -2.0_dp, matrix_ps, matrix_psp,& - 3.0_dp, matrix_p(ispin), filter_eps=threshold, error=error) + 3.0_dp, matrix_p(ispin), filter_eps=threshold) END DO END DO - CALL cp_dbcsr_release(matrix_ps,error) - CALL cp_dbcsr_release(matrix_psp,error) - CALL cp_dbcsr_release(matrix_test,error) + CALL cp_dbcsr_release(matrix_ps) + CALL cp_dbcsr_release(matrix_psp) + CALL cp_dbcsr_release(matrix_test) CALL timestop(handle) END SUBROUTINE purify_mcweeny_nonorth diff --git a/src/k290.F b/src/k290.F index 27bbb78a2a..e2c21e2e4f 100644 --- a/src/k290.F +++ b/src/k290.F @@ -115,11 +115,9 @@ MODULE k290 ! ***************************************************************************** !> \brief Release the CSYM type !> \param csym The CSYM type -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE release_csym_type(csym,error) + SUBROUTINE release_csym_type(csym) TYPE(csym_type), POINTER :: csym - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'release_csym_type', & routineP = moduleN//':'//routineN @@ -128,19 +126,19 @@ SUBROUTINE release_csym_type(csym,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(csym),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(csym),cp_failure_level,routineP,failure) IF ( ASSOCIATED(csym%xkappa) ) THEN DEALLOCATE(csym%xkappa,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(csym%ty) ) THEN DEALLOCATE(csym%ty,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(csym,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE release_csym_type @@ -158,10 +156,9 @@ END SUBROUTINE release_csym_type !> \param wkpoint ... !> \param xkpoint ... !> \param iounit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE kp_sym_gen(csym,coor,types,hmat,nk,shift,stress,symm,delta,& - wkpoint,xkpoint,iounit,error) + wkpoint,xkpoint,iounit) TYPE(csym_type), POINTER :: csym REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: coor @@ -176,7 +173,6 @@ SUBROUTINE kp_sym_gen(csym,coor,types,hmat,nk,shift,stress,symm,delta,& REAL(KIND=dp), DIMENSION(:, :), & OPTIONAL, POINTER :: xkpoint INTEGER, INTENT(IN), OPTIONAL :: iounit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kp_sym_gen', & routineP = moduleN//':'//routineN @@ -193,17 +189,17 @@ SUBROUTINE kp_sym_gen(csym,coor,types,hmat,nk,shift,stress,symm,delta,& failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(.NOT.ASSOCIATED(csym),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(csym),cp_failure_level,routineP,failure) ALLOCATE(csym,stat=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) !..total number of atoms nat = SIZE(coor,2) !..allocate arrays for coordinates and atom types ALLOCATE (csym%xkappa(3,nat),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (csym%ty(nat),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) !..count number of atom types csym%ty = types nsp = 0 @@ -251,26 +247,26 @@ SUBROUTINE kp_sym_gen(csym,coor,types,hmat,nk,shift,stress,symm,delta,& nkk = csym%nkpoint !..allocate intermediate arrays ALLOCATE (rx(3,nat),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (tvec(3,nat),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (isc(nat),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (f0(49,nat),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (wvkl(3,nkk),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (lwght(nkk),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (lrot(48,nkk),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (includ(nkk),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) nhash = MAX(2000,nkk/10) ALLOCATE (list(nkk+nhash),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ALLOCATE (rlist(3,nkk),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) IF ( PRESENT(iounit) ) THEN csym%punit = iounit @@ -287,10 +283,10 @@ SUBROUTINE kp_sym_gen(csym,coor,types,hmat,nk,shift,stress,symm,delta,& csym%istriz,csym%a1,csym%a2,csym%a3,csym%alat,csym%strain,csym%xkappa,& rx,tvec,csym%ty,isc,f0,csym%ntvec,csym%wvk0,csym%ihg,csym%ihc,csym%isy,& csym%li,csym%nc,csym%indpg,csym%ib,csym%v,csym%r,csym%origin,csym%xb,& - wvkl,lwght,lrot,nhash,includ,list,rlist,csym%delta,error) + wvkl,lwght,lrot,nhash,includ,list,rlist,csym%delta) IF ( PRESENT(xkpoint) ) THEN !..return kpoints and weights - CPPrecondition(PRESENT(wkpoint),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(wkpoint),cp_failure_level,routineP,failure) isum=0 nkpts=0 DO ik=1,nkk @@ -300,7 +296,7 @@ SUBROUTINE kp_sym_gen(csym,coor,types,hmat,nk,shift,stress,symm,delta,& END DO wsum=REAL(isum,KIND=dp) ALLOCATE (xkpoint(3,nkpts),wkpoint(nkpts),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) DO ik=1,nkpts wkpoint(ik) = REAL(lwght(ik),KIND=dp)/wsum xkpoint(1:3,ik) = wvkl(1:3,ik) @@ -308,7 +304,7 @@ SUBROUTINE kp_sym_gen(csym,coor,types,hmat,nk,shift,stress,symm,delta,& END IF !..deallocate intermediate arrays DEALLOCATE (rx,tvec,isc,f0,wvkl,lwght,lrot,includ,list,rlist,STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -317,11 +313,9 @@ END SUBROUTINE kp_sym_gen ! ***************************************************************************** !> \brief ... !> \param csym ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE print_crys_symmetry(csym,error) + SUBROUTINE print_crys_symmetry(csym) TYPE(csym_type), POINTER :: csym - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_crys_symmetry', & routineP = moduleN//':'//routineN @@ -463,7 +457,6 @@ END SUBROUTINE print_crys_symmetry !> \param list ... !> \param rlist ... !> \param delta ... -!> \param error ... !> \par Original Header: !> ---------------------------------------------------------------------------! !> WRITTEN ON SEPTEMBER 12TH, 1979. @@ -526,7 +519,7 @@ END SUBROUTINE print_crys_symmetry ! ***************************************************************************** SUBROUTINE k290prg(iout,nat,nkpoint,iq1,iq2,iq3,istriz,a1,a2,a3, & alat,strain,xkapa,rx,tvec,ty,isc,f0,ntvec,wvk0,ihg,ihc,isy,li,nc,indpg,ib,v,r,& - xb,origin,wvkl,lwght,lrot,nhash,includ,list,rlist,delta,error) + xb,origin,wvkl,lwght,lrot,nhash,includ,list,rlist,delta) INTEGER :: iout, nat, nkpoint, iq1, iq2, & iq3, istriz REAL(KIND=dp) :: a1(3), a2(3), a3(3), alat, & @@ -544,7 +537,6 @@ SUBROUTINE k290prg(iout,nat,nkpoint,iq1,iq2,iq3,istriz,a1,a2,a3, & includ(nkpoint), & list(nkpoint+nhash) REAL(KIND=dp) :: rlist(3,nkpoint), delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'k290prg', & routineP = moduleN//':'//routineN @@ -597,7 +589,7 @@ SUBROUTINE k290prg(iout,nat,nkpoint,iq1,iq2,iq3,istriz,a1,a2,a3, & ! GROUP-THEORY ANALYSIS OF LATTICE !----------------------------------------------------------------------------! CALL group1(a1,a2,a3,nat,ty,xkapa,b1,b2,b3,ihg,ihc,isy,li,nc, & - indpg,ib,ntvec,v,f0,xb,r,tvec,origin,rx,isc,delta,error) + indpg,ib,ntvec,v,f0,xb,r,tvec,origin,rx,isc,delta) !----------------------------------------------------------------------------! DO n = nc + 1, 48 ib(n) = 0 @@ -623,7 +615,7 @@ SUBROUTINE k290prg(iout,nat,nkpoint,iq1,iq2,iq3,istriz,a1,a2,a3, & ' (used for generating the largest possible mesh in the B.Z.)' !----------------------------------------------------------------------------! CALL group1(a01,a02,a03,1,ty,x0,b01,b02,b03,ihg0,ihc0,isy0,li0, & - nc0,indpg0,ib0,ntvec0,v0,f00,xb0,r0,tvec0,origin0,rx,isc,delta,error) + nc0,indpg0,ib0,ntvec0,v0,f00,xb0,r0,tvec0,origin0,rx,isc,delta) !----------------------------------------------------------------------------! ! It is assumed that the same 'type' of symmetry operations ! (cubic/hexagonal) will apply to the crystal as well as the Bravais @@ -641,7 +633,7 @@ SUBROUTINE k290prg(iout,nat,nkpoint,iq1,iq2,iq3,istriz,a1,a2,a3, & ' constant vector shift (MacDonald) of this mesh:', wvk0 IF (ABS(istriz)/=1) THEN WRITE (iout,'(" invalid switch for symmetrization",I10)') istriz - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF WRITE (iout,'(" symmetrization switch: ",I3)',ADVANCE="NO") istriz IF (istriz==1) THEN @@ -668,7 +660,7 @@ SUBROUTINE k290prg(iout,nat,nkpoint,iq1,iq2,iq3,istriz,a1,a2,a3, & WRITE (iout,*) ' K290| Number of rotations for crystal lattice', & nc WRITE (iout,*) ' K290| No duplication found' - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF nc = nc0 DO i = 1, nc0 @@ -685,7 +677,7 @@ SUBROUTINE k290prg(iout,nat,nkpoint,iq1,iq2,iq3,istriz,a1,a2,a3, & END IF CALL sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a01,a02,a03,b01,b02,b03, & invadd,nc,ib,r,ntot,wvkl,lwght,lrot,nc0,ib0,istriz,nhash,includ, & - list,rlist,delta,error) + list,rlist,delta) !----------------------------------------------------------------------------! ! Check on error signals !----------------------------------------------------------------------------! @@ -767,7 +759,6 @@ END SUBROUTINE k290prg !> \param rx ... !> \param isc ... !> \param delta ... -!> \param error ... !> \par Original Header: !> ---------------------------------------------------------------------------! !> WRITTEN ON SEPTEMBER 10TH - FROM THE ACMI COMPLEX @@ -872,7 +863,7 @@ END SUBROUTINE k290prg !> CONTAINS INVERSION. ! ***************************************************************************** SUBROUTINE group1(a1,a2,a3,nat,ty,x,b1,b2,b3,ihg,ihc,isy,li,nc, & - indpg,ib,ntvec,v,f0,xb,r,tvec,origin,rx,isc,delta,error) + indpg,ib,ntvec,v,f0,xb,r,tvec,origin,rx,isc,delta) REAL(KIND=dp) :: a1(3), a2(3), a3(3) INTEGER :: nat, ty(nat) REAL(KIND=dp) :: x(3,nat), b1(3), b2(3), b3(3) @@ -885,7 +876,6 @@ SUBROUTINE group1(a1,a2,a3,nat,ty,x,b1,b2,b3,ihg,ihc,isy,li,nc, & rx(3,nat) INTEGER :: isc(nat) REAL(KIND=dp) :: delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'group1', & routineP = moduleN//':'//routineN @@ -910,7 +900,7 @@ SUBROUTINE group1(a1,a2,a3,nat,ty,x,b1,b2,b3,ihg,ihc,isy,li,nc, & ! DETERMINE PRIMITIVE LATTICE VECTORS FOR THE RECIPROCAL LATTICE !------------------------------------------------------------------------------! - CALL calbrec(a,ai,error) + CALL calbrec(a,ai) DO i = 1, 3 b1(i) = ai(1,i) b2(i) = ai(2,i) @@ -920,25 +910,25 @@ SUBROUTINE group1(a1,a2,a3,nat,ty,x,b1,b2,b3,ihg,ihc,isy,li,nc, & ! Determination of the translation vectors associated with ! the Identity matrix i.e. if the cell is duplicated ! Give also the ``primitive lattice'' - CALL primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta,error) + CALL primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta) !------------------------------------------------------------------------------! ! Determination of the holohedral group (and crystal system) - CALL pgl1(ap,api,ihc,nc,ib,ihg,r,delta,error) + CALL pgl1(ap,api,ihc,nc,ib,ihg,r,delta) IF (ntvec>1) THEN ! All rotations found by PGL1 have axes in x, y or z cart. axis ! So we have too check if we do not loose symmetry ncprim = nc ! The hexagonal system is found if the z axis is the sixfold axis - CALL pgl1(a,ai,ihc,nc,ib,ihg,r,delta,error) + CALL pgl1(a,ai,ihc,nc,ib,ihg,r,delta) IF (ncprim>nc) THEN ! More symmetry with - CALL pgl1(ap,api,ihc,nc,ib,ihg,r,delta,error) + CALL pgl1(ap,api,ihc,nc,ib,ihg,r,delta) END IF END IF !------------------------------------------------------------------------------! ! Determination of the space group CALL atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec,a,ai, & - li,isy,isc,delta,error) + li,isy,isc,delta) !------------------------------------------------------------------------------! END SUBROUTINE group1 @@ -946,7 +936,6 @@ END SUBROUTINE group1 !> \brief CALCULATE RECIPROCAL VECTOR BASIS (AI(1:3,1:3)) !> \param a ... !> \param ai ... -!> \param error ... !> \par Note !> INPUT: !> A(3,3) A(I,J) IS THE I-TH CARTESIAN COMPONENT @@ -955,9 +944,8 @@ END SUBROUTINE group1 !> OUTPUT: !> AI(3,3) RECIPROCAL VECTOR BASIS ! ***************************************************************************** - SUBROUTINE calbrec(a,ai,error) + SUBROUTINE calbrec(a,ai) REAL(KIND=dp) :: a(3,3), ai(3,3) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calbrec', & routineP = moduleN//':'//routineN @@ -1001,7 +989,6 @@ END SUBROUTINE calbrec !> \param f0 ... !> \param isc ... !> \param delta ... -!> \param error ... !> \par Note !> INPUT: !> A(3,3) A(I,J) IS THE I-TH CARTESIAN COMPONENT @@ -1023,7 +1010,7 @@ END SUBROUTINE calbrec !> THE 49-TH LINE !> ISC(NAT) SCRATCH ARRAY ! ***************************************************************************** - SUBROUTINE primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta,error) + SUBROUTINE primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta) REAL(KIND=dp) :: a(3,3), ai(3,3), ap(3,3), & api(3,3) INTEGER :: nat, ty(nat) @@ -1032,7 +1019,6 @@ SUBROUTINE primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta,error) REAL(KIND=dp) :: tvec(3,nat) INTEGER :: f0(49,nat), isc(nat) REAL(KIND=dp) :: delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'primlatt', & routineP = moduleN//':'//routineN @@ -1057,8 +1043,8 @@ SUBROUTINE primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta,error) xb(i) = x(i,k2) - x(i,1) END DO ! A fractional translation vector VR is defined. - CALL rlv3(ai,xb,vr,il,delta,error) - CALL checkrlv3(1,nat,ty,x,x,vr,f0,ai,isc,.TRUE.,oksym,delta,error) + CALL rlv3(ai,xb,vr,il,delta) + CALL checkrlv3(1,nat,ty,x,x,vr,f0,ai,isc,.TRUE.,oksym,delta) IF (oksym) THEN ! A fractional translational vector is found ntvec = ntvec + 1 @@ -1096,7 +1082,7 @@ SUBROUTINE primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta,error) tvec(3,iv)*a(i,3) END DO ! We calculare TVEC in AP basis - CALL rlv3(api,xb,vr,il,delta,error) + CALL rlv3(api,xb,vr,il,delta) DO i = 1, 3 IF (ABS(vr(i))>delta) THEN il = NINT(1.0_dp/ABS(vr(i))) @@ -1106,7 +1092,7 @@ SUBROUTINE primlatt(a,ai,ap,api,nat,ty,x,ntvec,tvec,f0,isc,delta,error) ap(j,i) = xb(j) END DO ! Calculate new API - CALL calbrec(ap,api,error) + CALL calbrec(ap,api) EXIT END IF END IF @@ -1125,7 +1111,6 @@ END SUBROUTINE primlatt !> \param ihg ... !> \param r ... !> \param delta ... -!> \param error ... !> \par Original Header !> ---------------------------------------------------------------------------! !> WRITTEN ON SEPTEMBER 11TH, 1979 - FROM ACMI COMPLEX @@ -1163,11 +1148,10 @@ END SUBROUTINE primlatt !> ALL 48 OR 24 MATRICES ARE LISTED. !> FOLLOW NOTATION OF WORLTON-WARREN(1972) ! ***************************************************************************** - SUBROUTINE pgl1(a,ai,ihc,nc,ib,ihg,r,delta,error) + SUBROUTINE pgl1(a,ai,ihc,nc,ib,ihg,r,delta) REAL(KIND=dp) :: a(3,3), ai(3,3) INTEGER :: ihc, nc, ib(48), ihg REAL(KIND=dp) :: r(3,3,48), delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pgl1', & routineP = moduleN//':'//routineN @@ -1184,7 +1168,7 @@ SUBROUTINE pgl1(a,ai,ihc,nc,ib,ihg,r,delta,error) END IF nc = 0 ! Constructs rotation operations. - CALL rot1(ihc,r,error) + CALL rot1(ihc,r) DO n = 1, nr ib(n) = 0 ! Rotate the A1,2,3 vectors by rotation No. N @@ -1195,7 +1179,7 @@ SUBROUTINE pgl1(a,ai,ihc,nc,ib,ihg,r,delta,error) xa(i) = xa(i) + r(i,j,n)*a(j,k) END DO END DO - CALL rlv3(ai,xa,vr,lx,delta,error) + CALL rlv3(ai,xa,vr,lx,delta) tr = 0.0_dp DO i = 1, 3 tr = tr + ABS(vr(i)) @@ -1234,7 +1218,6 @@ END SUBROUTINE pgl1 !> \param vr ... !> \param il ... !> \param delta ... -!> \param error ... !> \par Original Header !> ---------------------------------------------------------------------------! !> WRITTEN ON SEPTEMBER 11TH, 1979 - FROM ACMI COMPLEX @@ -1256,12 +1239,11 @@ END SUBROUTINE pgl1 !> IL ABS OF VR !> K.K., 23.10.1979 ! ***************************************************************************** - SUBROUTINE rlv3(ai,xb,vr,il,delta,error) + SUBROUTINE rlv3(ai,xb,vr,il,delta) REAL(KIND=dp) :: ai(3,3), xb(3), vr(3) INTEGER :: il REAL(KIND=dp) :: delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rlv3', & routineP = moduleN//':'//routineN @@ -1309,7 +1291,6 @@ END SUBROUTINE rlv3 !> \param isy ... !> \param isc ... !> \param delta ... -!> \param error ... !> \par Original Header !> ---------------------------------------------------------------------------! !> WRITTEN ON SEPTEMBER 11TH, 1979 - FROM ACMI COMPLEX @@ -1362,7 +1343,7 @@ END SUBROUTINE rlv3 !> group of the crystal ! ***************************************************************************** SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & - a,ai,li,isy,isc,delta,error) + a,ai,li,isy,isc,delta) REAL(KIND=dp) :: r(3,3,48), v(3,48), xb(3), & origin(3) INTEGER :: ib(48), nat, ty(nat), & @@ -1374,7 +1355,6 @@ SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & REAL(KIND=dp) :: a(3,3), ai(3,3) INTEGER :: li, isy, isc(nat) REAL(KIND=dp) :: delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'atftm1', & routineP = moduleN//':'//routineN @@ -1408,7 +1388,7 @@ SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & END DO ! First we determine for VR=(/0,0,0/) ! IMPORTANT IF NOT UNIQUE ATOMS FOR DETERMINATION OF SYMMORPHIC - CALL checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta,error) + CALL checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta) IF (oksym) THEN nca = nca + 1 DO i = 1, 3 @@ -1424,7 +1404,7 @@ SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & xb(i) = rx(i,1) - x(i,k2) END DO ! A translation vector VR is defined. - CALL rlv3(ai,xb,vr,il,delta,error) + CALL rlv3(ai,xb,vr,il,delta) !------------------------------------------------------------------------------! ! SUBROUTINE RLV3 REMOVES A DIRECT LATTICE VECTOR FROM XB ! LEAVING THE REMAINDER IN VR. IF A NONZERO LATTICE @@ -1433,7 +1413,7 @@ SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & ! VR IS NOT GIVEN IN CARTESIAN COORDINATES BUT ! IN THE SYSTEM A1,A2,A3. K.K., 23.10.1979 !------------------------------------------------------------------------------! - CALL checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta,error) + CALL checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta) IF (oksym) THEN nca = nca + 1 DO i = 1, 3 @@ -1489,7 +1469,7 @@ SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & IF (ihg<6) THEN IF (nc==0) THEN WRITE (*,'(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nc - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ! Triclinic system ELSE IF (nc==1) THEN ! IB=1 @@ -1627,7 +1607,7 @@ SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & ELSE IF (ihg>=6) THEN IF (nc==0) THEN WRITE (*,'(" ATFTM1! IHG=",A," NC=",I2)') icst(ihg), nc - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ! Triclinic system ELSE IF (nc==1) THEN ! IB=1 @@ -1720,9 +1700,9 @@ SUBROUTINE atftm1(r,v,x,f0,xb,origin,ib,ty,nat,ihg,rx,nc,indpg,ntvec, & vc(i,n) = a(i,1)*v(1,n) + a(i,2)*v(2,n) + a(i,3)*v(3,n) END DO END DO - CALL symmorphic(nc,ib,r,vc,ai,info,origin,delta,error) + CALL symmorphic(nc,ib,r,vc,ai,info,origin,delta) IF (info==1) THEN - CALL rlv3(ai,origin,xb,il,delta,error) + CALL rlv3(ai,origin,xb,il,delta) ! !!!RLV3 determines -XB in crystal coordinates ! !!We want between 0.0 and 1.0 DO i = 1, 3 @@ -1761,7 +1741,6 @@ END SUBROUTINE atftm1 !> \param nodupli ... !> \param oksym ... !> \param delta ... -!> \param error ... !> \par Original Header !> ------------------------------------------------------------------------------! !> WRITTEN IN MAY 14TH, 1998 (T.D.) @@ -1790,7 +1769,7 @@ END SUBROUTINE atftm1 !> EACH ATOM IS ONLY ONCE AN IMAGE !> IF NO DUPLICATION OF THE CELL ! ***************************************************************************** - SUBROUTINE checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta,error) + SUBROUTINE checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta) INTEGER :: n, nat, ty(nat) REAL(KIND=dp) :: rx(3,nat), x(3,nat), vr(3) @@ -1799,7 +1778,6 @@ SUBROUTINE checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta,error) INTEGER :: isc(nat) LOGICAL :: nodupli, oksym REAL(KIND=dp) :: delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'checkrlv3', & routineP = moduleN//':'//routineN @@ -1817,7 +1795,7 @@ SUBROUTINE checkrlv3(n,nat,ty,rx,x,vr,f0,ai,isc,nodupli,oksym,delta,error) xb(1) = rx(1,ia) - x(1,ib) xb(2) = rx(2,ia) - x(2,ib) xb(3) = rx(3,ia) - x(3,ib) - CALL rlv3(ai,xb,vt,il,delta,error) + CALL rlv3(ai,xb,vt,il,delta) ! VT STANDS FOR V-TEST oksym = (ABS((vr(1)-vt(1))-NINT(vr(1)-vt(1))) \param info ... !> \param origin ... !> \param delta ... -!> \param error ... !> \par Original Header !> ------------------------------------------------------------------------------! !> Check if the group is symmorphic with a non-standard origin @@ -1872,12 +1849,11 @@ END SUBROUTINE checkrlv3 !> INFO = 0 The group is not symmorphic !> INFO =-1 The routine cannot determine ! ***************************************************************************** - SUBROUTINE symmorphic(nc,ib,r,v,ai,info,origin,delta,error) + SUBROUTINE symmorphic(nc,ib,r,v,ai,info,origin,delta) INTEGER :: nc, ib(nc) REAL(KIND=dp) :: r(3,3,48), v(3,nc), ai(3,3) INTEGER :: info REAL(KIND=dp) :: origin(3), delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'symmorphic', & routineP = moduleN//':'//routineN @@ -1908,7 +1884,7 @@ SUBROUTINE symmorphic(nc,ib,r,v,ai,info,origin,delta,error) END DO r3(i,i) = 1 + r3(i,i) END DO - CALL invmat(r3(1:3,1:3),ierror,error) + CALL invmat(r3(1:3,1:3),ierror) IF (ierror==0) THEN ! The matrix 3x3 has an inverse. DO i = 1, 3 @@ -1933,7 +1909,7 @@ SUBROUTINE symmorphic(nc,ib,r,v,ai,info,origin,delta,error) r2(i1,i1) = 1 + r2(i1,i1) END IF END DO - CALL invmat(r2(1:2,1:2),ierror,error) + CALL invmat(r2(1:2,1:2),ierror) IF (ierror==0) THEN ! The matrix 2X2 has an inverse. ! Solve Vxy = (1-R).OAxy + OAz R3z (z is IMISSING3) @@ -2019,7 +1995,7 @@ SUBROUTINE symmorphic(nc,ib,r,v,ai,info,origin,delta,error) r(i,3,ib(ir))*origin(3) vr(i) = (origin(i)-vr(i)) - v(i,ir) END DO - CALL rlv3(ai,vr,xb,il,delta,error) + CALL rlv3(ai,vr,xb,il,delta) dif = ABS(xb(1)) + ABS(xb(2)) + ABS(xb(3)) IF (dif>delta) THEN ! Non-symmorphic @@ -2033,7 +2009,6 @@ END SUBROUTINE symmorphic !> \brief ... !> \param ihc ... !> \param r ... -!> \param error ... !> \par Original Header !> ------------------------------------------------------------------------------! !> WRITTEN ON FEBRUARY 17TH, 1976 @@ -2058,10 +2033,9 @@ END SUBROUTINE symmorphic !> FOR IHC=1 THE FIRST 48 MATRICES OF THE ARRAY R REPRESENT !> THE FULL CUBIC GROUP O(H) ! ***************************************************************************** - SUBROUTINE rot1(ihc,r,error) + SUBROUTINE rot1(ihc,r) INTEGER :: ihc REAL(KIND=dp) :: r(3,3,48) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rot1', & routineP = moduleN//':'//routineN @@ -2222,7 +2196,6 @@ END SUBROUTINE rot1 !> \param list ... !> \param rlist ... !> \param delta ... -!> \param error ... !> \par Original Header !> ------------------------------------------------------------------------------! !> WRITTEN ON SEPTEMBER 12-20TH, 1979 BY K.K. @@ -2354,7 +2327,7 @@ END SUBROUTINE rot1 ! ***************************************************************************** SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & ib,r,ntot,wvkl,lwght,lrot,ncbrav,ibrav,istriz,nhash,includ,list, & - rlist,delta,error) + rlist,delta) INTEGER :: iout, iq1, iq2, iq3 REAL(KIND=dp) :: wvk0(3) INTEGER :: nkpoint @@ -2367,7 +2340,6 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & INTEGER :: lwght(nkpoint), lrot(48,nkpoint), ncbrav, ibrav(48), istriz, & nhash, includ(nkpoint), list(nkpoint+nhash) REAL(KIND=dp) :: rlist(3,nkpoint), delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sppt2', & routineP = moduleN//':'//routineN @@ -2403,7 +2375,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & !------------------------------------------------------------------------------! ! DEFINE THE 1ST BRILLOUIN ZONE !------------------------------------------------------------------------------! - CALL bzdefi(iout,b1,b2,b3,rsdir,nrsdir,nplane,delta,error) + CALL bzdefi(iout,b1,b2,b3,rsdir,nrsdir,nplane,delta) !------------------------------------------------------------------------------! ! Generation of the mesh (they are not multiplied by 2*pi) by ! the Monkhorst/Pack algorithm, supplemented by all rotations @@ -2411,7 +2383,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & ! Initialize the list of vectors iplace = -2 CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & - delta,error) + delta) imesh = 0 DO i1 = 1, iq1 DO i2 = 1, iq2 @@ -2423,7 +2395,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & wvk(i) = ur1*b1(i) + ur2*b2(i) + ur3*b3(i) + wvk0(i) END DO ! Reduce WVK to the 1st Brillouin zone - CALL bzrduc(wvk,a1,a2,a3,b1,b2,b3,rsdir,nrsdir,nplane,delta,error) + CALL bzrduc(wvk,a1,a2,a3,b1,b2,b3,rsdir,nrsdir,nplane,delta) IF (istriz==1) THEN ! Symmetrization of the k-points mesh. ! Apply all the Bravais lattice operations to WVK @@ -2439,7 +2411,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & ! Place WVA in list iplace = 0 CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list, & - rlist,delta,error) + rlist,delta) ! If WVA was new (and therefore inserted), ! IPLACE is the number. IF (iplace>0) imesh = iplace @@ -2449,7 +2421,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & ! Place WVK in list iplace = 0 CALL mesh(iout,wvk,iplace,igarb0,igarbg,nkpoint,nhash,list, & - rlist,delta,error) + rlist,delta) imesh = iplace IF (iplace>nkpoint) GO TO 470 END IF @@ -2462,7 +2434,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & imesh WRITE (iout,'(" K290| The points are:")') DO i = 1, imesh - CALL mesh(iout,wva,i,igarb0,igarbg,nkpoint,nhash,list,rlist,delta,error) + CALL mesh(iout,wva,i,igarb0,igarbg,nkpoint,nhash,list,rlist,delta) IF (MOD(i,2)==1) THEN WRITE (iout,'(1X,I5,3F10.4)',ADVANCE="NO") i, wva ELSE @@ -2479,7 +2451,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & DO i = 1, (imesh-1) iplace = i CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & - delta,error) + delta) ! Project WVA onto B1,2,3: proja(1) = 0.0_dp proja(2) = 0.0_dp @@ -2493,7 +2465,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & DO j = (i+1), imesh jplace = j CALL mesh(iout,wvk,jplace,igarb0,igarbg,nkpoint,nhash,list, & - rlist,delta,error) + rlist,delta) ! Project WVK onto B1,2,3: projb(1) = 0.0_dp projb(2) = 0.0_dp @@ -2511,7 +2483,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & IF (ABS(REAL(NINT(diff),KIND=dp)-diff)>delta) CYCLE ! DIFF is integral: remove WVK from mesh: CALL remove(wvk,jplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & - delta,error) + delta) ! If WVK actually removed, increment IREMOV IF (jplace>0) iremov = iremov + 1 END DO @@ -2534,9 +2506,9 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & includ(iwvk) = IBSET(includ(iwvk),0) iplace = iwvk CALL mesh(iout,wvk,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & - delta,error) + delta) ! Find out whether Wvk is in the garbage list - CALL garbag(wvk,igarbage,igarb0,nkpoint,nhash,list,rlist,delta,error) + CALL garbag(wvk,igarbage,igarb0,nkpoint,nhash,list,rlist,delta) IF (igarbage>0) CYCLE ntot = ntot + 1 ! Give the index in the special k points table. @@ -2560,7 +2532,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & ! Find WVA in the list iplace = -1 CALL mesh(iout,wva,iplace,igarb0,igarbg,nkpoint,nhash,list,rlist, & - delta,error) + delta) IF (iplace==0) THEN IF (istriz==-1) THEN ! No symmetrisation -> WVA not in the list @@ -2572,7 +2544,7 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & END IF END IF ! Find out whether WVA is in the garbage list - CALL garbag(wva,igarbage,igarb0,nkpoint,nhash,list,rlist,delta,error) + CALL garbag(wva,igarbage,igarb0,nkpoint,nhash,list,rlist,delta) IF (igarbage>0) CYCLE ! Was WVA encountered before ? ! IF(INCLUD(IPLACE) .EQ. YES) GOTO 364 @@ -2629,19 +2601,19 @@ SUBROUTINE sppt2(iout,iq1,iq2,iq3,wvk0,nkpoint,a1,a2,a3,b1,b2,b3,inv,nc, & WRITE (*,'(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') ' THE VECTOR ', & wva, ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & ' BY ROTATION NO. ', ibrav(iop), ' IS OUTSIDE THE 1BZ' - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) !------------------------------------------------------------------------------! 470 CONTINUE WRITE (*,'(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' WRITE (*,*) 'MESH SIZE EXCEEDS NKPOINT=', nkpoint - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) !------------------------------------------------------------------------------! 490 CONTINUE WRITE (*,'(A,/)') ' SUBROUTINE SPPT2 *** FATAL ERROR ***' WRITE (*,'(A,3F10.4,/,A,3F10.4,A,/,A,I3,A)') ' THE VECTOR ', & wva, ' GENERATED FROM ', wvk, ' IN THE BASIC MESH', & ' BY ROTATION NO. ', ib(n), ' IS NOT IN THE LIST' - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SUBROUTINE sppt2 ! ***************************************************************************** !> \brief ... @@ -2655,7 +2627,6 @@ END SUBROUTINE sppt2 !> \param list ... !> \param rlist ... !> \param delta ... -!> \param error ... !> \par Original Header !> MESH MAINTAINS A LIST OF VECTORS FOR PLACEMENT AND/OR LOOKUP !> @@ -2673,7 +2644,7 @@ END SUBROUTINE sppt2 !> DELTA REQUIRED ACCURACY (1.0E-6_dp IS A GOOD VALUE) ! ***************************************************************************** SUBROUTINE mesh(iout,wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist, & - delta,error) + delta) INTEGER :: iout REAL(KIND=dp) :: wvk(3) @@ -2681,7 +2652,6 @@ SUBROUTINE mesh(iout,wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist, & nmesh, nhash, & list(nhash+nmesh) REAL(KIND=dp) :: rlist(3,nmesh), delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mesh', & routineP = moduleN//':'//routineN @@ -2729,7 +2699,7 @@ SUBROUTINE mesh(iout,wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist, & WRITE (*,'(2A,/,A)') & ' SUBROUTINE MESH *** FATAL ERROR *** LINKED LIST', & ' TOO LONG ***', ' CHOOSE A BETTER HASH-FUNCTION' - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ! WVK was not found 130 CONTINUE IF (iplace==-1) THEN @@ -2743,7 +2713,7 @@ SUBROUTINE mesh(iout,wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist, & WRITE (*,'(A)') 'SUBROUTINE MESH *** FATAL ERROR ***' WRITE (*,'(A,I10,A,/,A,3F10.5)') ' ISTORE=', istore, & ' EXCEEDS DIMENSIONS', ' WVK = ', wvk - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF list(istore) = nil DO i = 1, 3 @@ -2793,7 +2763,6 @@ END SUBROUTINE mesh !> \param list ... !> \param rlist ... !> \param delta ... -!> \param error ... !> \par Original Header !> ENTRY POINT FOR REMOVING A WAVEVECTOR !> @@ -2805,14 +2774,13 @@ END SUBROUTINE mesh !> 0 IF WVK WAS NOT REMOVED !> (WVK NOT IN THE LINKED LISTS) ! ***************************************************************************** - SUBROUTINE remove(wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist,delta,error) + SUBROUTINE remove(wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist,delta) REAL(KIND=dp) :: wvk(3) INTEGER :: iplace, igarb0, igarbg, & nmesh, nhash, & list(nhash+nmesh) REAL(KIND=dp) :: rlist(3,nmesh), delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove', & routineP = moduleN//':'//routineN @@ -2864,7 +2832,7 @@ SUBROUTINE remove(wvk,iplace,igarb0,igarbg,nmesh,nhash,list,rlist,delta,error) RETURN END DO ! List too long - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SUBROUTINE remove ! ***************************************************************************** @@ -2877,7 +2845,6 @@ END SUBROUTINE remove !> \param list ... !> \param rlist ... !> \param delta ... -!> \param error ... !> \par Original Header !> ENTRY POINT FOR CHECKING IF A WAVEVECTOR !> IS IN THE GARBAGE LIST @@ -2889,12 +2856,11 @@ END SUBROUTINE remove !> IPLACE ..... I > 0 IS THE PLACE IN THE GARBAGE LIST !> 0 IF WVK NOT AMONG THE GARBAGE ! ***************************************************************************** - SUBROUTINE garbag(wvk,iplace,igarb0,nmesh,nhash,list,rlist,delta,error) + SUBROUTINE garbag(wvk,iplace,igarb0,nmesh,nhash,list,rlist,delta) REAL(KIND=dp) :: wvk(3) INTEGER :: iplace, igarb0, nmesh, nhash, & list(nhash+nmesh) REAL(KIND=dp) :: rlist(3,nmesh), delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'garbag', & routineP = moduleN//':'//routineN @@ -2931,7 +2897,7 @@ SUBROUTINE garbag(wvk,iplace,igarb0,nmesh,nhash,list,rlist,delta,error) END DO ! List too long - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SUBROUTINE garbag ! ***************************************************************************** @@ -2947,20 +2913,18 @@ END SUBROUTINE garbag !> \param nrsdir ... !> \param nplane ... !> \param delta ... -!> \param error ... !> \par Original Header !> REDUCE WVK TO LIE ENTIRELY WITHIN THE 1ST BRILLOUIN ZONE !> BY ADDING B-VECTORS !> DELTA REQUIRED ACCURACY (1.0E-6_dp IS A GOOD VALUE) ! ***************************************************************************** - SUBROUTINE bzrduc(wvk,a1,a2,a3,b1,b2,b3,rsdir,nrsdir,nplane,delta,error) + SUBROUTINE bzrduc(wvk,a1,a2,a3,b1,b2,b3,rsdir,nrsdir,nplane,delta) REAL(KIND=dp) :: wvk(3), a1(3), a2(3), a3(3), & b1(3), b2(3), b3(3) INTEGER :: nrsdir REAL(KIND=dp) :: rsdir(4,nrsdir) INTEGER :: nplane REAL(KIND=dp) :: delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'bzrduc', & routineP = moduleN//':'//routineN @@ -3015,7 +2979,7 @@ SUBROUTINE bzrduc(wvk,a1,a2,a3,b1,b2,b3,rsdir,nrsdir,nplane,delta,error) ! Fatal error WRITE (*,'(A,/,A,3F10.4,A)') ' SUBROUTINE BZRDUC *** FATAL ERROR ***', & ' WAVEVECTOR ', wvk, ' COULD NOT BE REDUCED TO THE 1BZ' - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SUBROUTINE bzrduc ! ***************************************************************************** @@ -3067,7 +3031,6 @@ END FUNCTION inbz !> \param nrsdir ... !> \param nplane ... !> \param delta ... -!> \param error ... !> \par Original Header !> FIND THE VECTORS WHOSE HALVES DEFINE THE 1ST BRILLOUIN ZONE !> OUTPUT: @@ -3081,14 +3044,13 @@ END FUNCTION inbz !> PLANES. !> DELTA REQUIRED ACCURACY (1.0E-6_dp IS A GOOD VALUE) ! ***************************************************************************** - SUBROUTINE bzdefi(iout,b1,b2,b3,rsdir,nrsdir,nplane,delta,error) + SUBROUTINE bzdefi(iout,b1,b2,b3,rsdir,nrsdir,nplane,delta) INTEGER :: iout REAL(KIND=dp) :: b1(3), b2(3), b3(3) INTEGER :: nrsdir REAL(KIND=dp) :: rsdir(4,nrsdir) INTEGER :: nplane REAL(KIND=dp) :: delta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'bzdefi', & routineP = moduleN//':'//routineN @@ -3161,7 +3123,7 @@ SUBROUTINE bzdefi(iout,b1,b2,b3,rsdir,nrsdir,nplane,delta,error) WRITE (iout,'(A)') ' SUBROUTINE BZDEFI *** FATAL ERROR ***' WRITE (iout,'(" TOO MANY PLANES, NRSDIR = ",I5)') nrsdir END IF - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) RETURN ENDIF DO i = 1, 3 diff --git a/src/kg_correction.F b/src/kg_correction.F index 3bcc638fb2..1b70128578 100644 --- a/src/kg_correction.F +++ b/src/kg_correction.F @@ -57,20 +57,18 @@ MODULE kg_correction !> \param gapw_xc ... !> \param ekin_mol ... !> \param calc_force ... -!> \param error ... !> \par History !> 2012.06 created [Martin Haeufel] !> 2014.01 added atomic potential option [JGH] !> \author Martin Haeufel and Florian Schiffmann ! ***************************************************************************** - SUBROUTINE kg_ekin_subset(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force, error) + SUBROUTINE kg_ekin_subset(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix LOGICAL, INTENT(in), OPTIONAL :: gapw, gapw_xc REAL(KIND=dp), INTENT(out) :: ekin_mol LOGICAL :: calc_force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_ekin_subset', & routineP = moduleN//':'//routineN @@ -83,14 +81,14 @@ SUBROUTINE kg_ekin_subset(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force IF (kg_env%tnadd_method == kg_tnadd_embed) THEN CALL kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, & - ekin_mol, calc_force, error) + ekin_mol, calc_force) ELSE IF (kg_env%tnadd_method == kg_tnadd_atomic) THEN - CALL kg_ekin_atomic(qs_env, ks_matrix, ekin_mol, error) + CALL kg_ekin_atomic(qs_env, ks_matrix, ekin_mol) ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE kg_ekin_subset @@ -103,16 +101,14 @@ END SUBROUTINE kg_ekin_subset !> \param gapw_xc ... !> \param ekin_mol ... !> \param calc_force ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force, error) + SUBROUTINE kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix LOGICAL, INTENT(in), OPTIONAL :: gapw, gapw_xc REAL(KIND=dp), INTENT(out) :: ekin_mol LOGICAL :: calc_force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_ekin_embed', & routineP = moduleN//':'//routineN @@ -152,23 +148,22 @@ SUBROUTINE kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force, matrix_h=matrix_h,& natom=natom,& dft_control=dft_control,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) nspins = dft_control%nspins - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) ! get the density matrix - CALL qs_rho_get(old_rho, rho_ao=density_matrix, error=error) + CALL qs_rho_get(old_rho, rho_ao=density_matrix) ! allocate and initialize the density - CALL qs_rho_create(rho_struct, error) + CALL qs_rho_create(rho_struct) ! set the density matrix to the blocked matrix - CALL qs_rho_set(rho_struct, rho_ao=density_matrix, error=error) ! blocked_matrix + CALL qs_rho_set(rho_struct, rho_ao=density_matrix) ! blocked_matrix - CALL qs_rho_rebuild(rho_struct, qs_env, rebuild_ao=.FALSE., rebuild_grids=.TRUE., error=error) + CALL qs_rho_rebuild(rho_struct, qs_env, rebuild_ao=.FALSE., rebuild_grids=.TRUE.) ! loop over all subsets DO isub=1,kg_env%nsubsets @@ -179,14 +174,13 @@ SUBROUTINE kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force, ! calculate the densities for the given blocked density matrix - pass the subset task_list CALL qs_rho_update_rho(rho_struct, qs_env, & !task_list_external=qs_env%task_list, & - task_list_external=kg_env%subset(isub)%task_list, & - error=error) + task_list_external=kg_env%subset(isub)%task_list) ekin_imol=0.0_dp ! calc Hohenberg-Kohn kin. energy of the density corresp. to the remaining molecular block(s) CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_struct, xc_section=kg_env%xc_section_kg, & - vxc_rho=vxc_rho, vxc_tau=vxc_tau, exc=ekin_imol, error=error) + vxc_rho=vxc_rho, vxc_tau=vxc_tau, exc=ekin_imol) ekin_mol = ekin_mol + ekin_imol @@ -200,11 +194,10 @@ SUBROUTINE kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force, qs_env=qs_env, & calculate_forces=calc_force, & gapw=gapw, & - task_list_external=kg_env%subset(isub)%task_list, & - error=error) + task_list_external=kg_env%subset(isub)%task_list) ! clean up vxc_rho - CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_rho(ispin)%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_rho(ispin)%pw) END DO DEALLOCATE(vxc_rho) @@ -219,7 +212,7 @@ SUBROUTINE kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force, DO ispin=1,nspins ! clean up vxc_tau - CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_tau(ispin)%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_tau(ispin)%pw) END DO @@ -230,8 +223,8 @@ SUBROUTINE kg_ekin_embed(qs_env, ks_matrix, gapw, gapw_xc, ekin_mol, calc_force, END DO ! clean up rho_struct - CALL qs_rho_set(rho_struct, rho_ao=Null(), error=error) - CALL qs_rho_release(rho_struct, error) + CALL qs_rho_set(rho_struct, rho_ao=Null()) + CALL qs_rho_release(rho_struct) CALL timestop(handle) @@ -242,14 +235,12 @@ END SUBROUTINE kg_ekin_embed !> \param qs_env ... !> \param ks_matrix ... !> \param ekin_mol ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_ekin_atomic(qs_env, ks_matrix, ekin_mol, error) + SUBROUTINE kg_ekin_atomic(qs_env, ks_matrix, ekin_mol) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix REAL(KIND=dp), INTENT(out) :: ekin_mol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_ekin_atomic', & routineP = moduleN//':'//routineN @@ -263,19 +254,19 @@ SUBROUTINE kg_ekin_atomic(qs_env, ks_matrix, ekin_mol, error) NULLIFY(rho, kg_env, density_matrix, tnadd_matrix) CALL timeset(routineN, handle) - CALL get_qs_env(qs_env, kg_env=kg_env, rho=rho, error=error) + CALL get_qs_env(qs_env, kg_env=kg_env, rho=rho) nspins = SIZE(ks_matrix) ! get the density matrix - CALL qs_rho_get(rho, rho_ao=density_matrix, error=error) + CALL qs_rho_get(rho, rho_ao=density_matrix) ! get the tnadd matrix tnadd_matrix => kg_env%tnadd_mat ekin_mol = 0.0_dp DO ispin=1,nspins - CALL cp_dbcsr_trace(tnadd_matrix(1)%matrix,density_matrix(ispin)%matrix,ekin_mol,error=error) + CALL cp_dbcsr_trace(tnadd_matrix(1)%matrix,density_matrix(ispin)%matrix,ekin_mol) CALL cp_dbcsr_add(ks_matrix(ispin)%matrix, tnadd_matrix(1)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) END DO ! definition is inverted (see qs_ks_methods) ekin_mol = -ekin_mol diff --git a/src/kg_environment.F b/src/kg_environment.F index 3ae2d24b95..d74422a3dc 100644 --- a/src/kg_environment.F +++ b/src/kg_environment.F @@ -76,17 +76,14 @@ MODULE kg_environment !> \brief Allocates and intitializes kg_env !> \param kg_env the object to create !> \param input ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 2012.07 created [Martin Haeufel] !> \author Martin Haeufel ! ***************************************************************************** - SUBROUTINE kg_env_create(kg_env, input, error) + SUBROUTINE kg_env_create(kg_env, input) TYPE(kg_environment_type), POINTER :: kg_env TYPE(section_vals_type), OPTIONAL, & POINTER :: input - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kg_env_create', & routineP = moduleN//':'//routineN @@ -97,24 +94,22 @@ SUBROUTINE kg_env_create(kg_env, input, error) failure=.FALSE. ALLOCATE(kg_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL init_kg_env(kg_env, input, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL init_kg_env(kg_env, input) END SUBROUTINE kg_env_create ! ***************************************************************************** !> \brief Initializes kg_env !> \param kg_env ... !> \param input ... -!> \param error ... !> \par History !> 2012.07 created [Martin Haeufel] !> \author Martin Haeufel ! ***************************************************************************** - SUBROUTINE init_kg_env(kg_env, input, error) + SUBROUTINE init_kg_env(kg_env, input) TYPE(kg_environment_type), POINTER :: kg_env TYPE(section_vals_type), OPTIONAL, & POINTER :: input - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_kg_env', & routineP = moduleN//':'//routineN @@ -138,87 +133,83 @@ SUBROUTINE init_kg_env(kg_env, input, error) kg_env%nsubsets=0 ! get coloring method settings - CALL section_vals_val_get(input,"DFT%KG_METHOD%COLORING_METHOD",i_val=kg_env%coloring_method,error=error) + CALL section_vals_val_get(input,"DFT%KG_METHOD%COLORING_METHOD",i_val=kg_env%coloring_method) ! get method for nonadditive kinetic energy embedding potential - CALL section_vals_val_get(input,"DFT%KG_METHOD%TNADD_METHOD",i_val=kg_env%tnadd_method,error=error) + CALL section_vals_val_get(input,"DFT%KG_METHOD%TNADD_METHOD",i_val=kg_env%tnadd_method) IF (kg_env%tnadd_method == kg_tnadd_embed) THEN ! generate a new XC section with only the KE functional NULLIFY(xc_fun_section_kg, xc_section_kg) - xc_section => section_vals_get_subs_vals(input, "DFT%XC", error=error) - xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL",error=error) + xc_section => section_vals_get_subs_vals(input, "DFT%XC") + xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL") - CALL section_vals_duplicate(xc_section, xc_section_kg, error=error) + CALL section_vals_duplicate(xc_section, xc_section_kg) ! test for TF, TFW, KE_GGA, and KE_LIBXC sections in turn ke_sections = 0 NULLIFY(kef_section) - kef_section => section_vals_get_subs_vals(xc_fun_section,"TF",error=error) - CALL section_vals_get(kef_section, explicit=is_set, error=error) + kef_section => section_vals_get_subs_vals(xc_fun_section,"TF") + CALL section_vals_get(kef_section, explicit=is_set) IF(is_set) THEN NULLIFY(xc_fun_section_kg) - CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section,& - error=error) + CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section) CALL section_vals_val_set(xc_fun_section_kg,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CALL section_vals_set_subs_vals(xc_fun_section_kg,"TF",& - kef_section,error=error) + kef_section) CALL section_vals_set_subs_vals(xc_section_kg,"XC_FUNCTIONAL",& - xc_fun_section_kg,error=error) + xc_fun_section_kg) ke_sections = ke_sections + 1 END IF NULLIFY(kef_section) - kef_section => section_vals_get_subs_vals(xc_fun_section,"TFW",error=error) - CALL section_vals_get(kef_section, explicit=is_set, error=error) + kef_section => section_vals_get_subs_vals(xc_fun_section,"TFW") + CALL section_vals_get(kef_section, explicit=is_set) IF(is_set) THEN NULLIFY(xc_fun_section_kg) - CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section,& - error=error) + CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section) CALL section_vals_val_set(xc_fun_section_kg,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CALL section_vals_set_subs_vals(xc_fun_section_kg,"TFW",& - kef_section,error=error) + kef_section) CALL section_vals_set_subs_vals(xc_section_kg,"XC_FUNCTIONAL",& - xc_fun_section_kg,error=error) + xc_fun_section_kg) ke_sections = ke_sections + 1 END IF NULLIFY(kef_section) - kef_section => section_vals_get_subs_vals(xc_fun_section,"KE_GGA",error=error) - CALL section_vals_get(kef_section, explicit=is_set, error=error) + kef_section => section_vals_get_subs_vals(xc_fun_section,"KE_GGA") + CALL section_vals_get(kef_section, explicit=is_set) IF(is_set) THEN NULLIFY(xc_fun_section_kg) - CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section,& - error=error) + CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section) CALL section_vals_val_set(xc_fun_section_kg,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CALL section_vals_set_subs_vals(xc_fun_section_kg,"KE_GGA",& - kef_section,error=error) + kef_section) CALL section_vals_set_subs_vals(xc_section_kg,"XC_FUNCTIONAL",& - xc_fun_section_kg,error=error) + xc_fun_section_kg) ke_sections = ke_sections + 1 END IF NULLIFY(kef_section) - kef_section => section_vals_get_subs_vals(xc_fun_section,"KE_LIBXC",error=error) - CALL section_vals_get(kef_section, explicit=is_set, error=error) + kef_section => section_vals_get_subs_vals(xc_fun_section,"KE_LIBXC") + CALL section_vals_get(kef_section, explicit=is_set) IF(is_set) THEN NULLIFY(xc_fun_section_kg) - CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section,& - error=error) + CALL section_vals_create(xc_fun_section_kg,xc_fun_section%section) CALL section_vals_val_set(xc_fun_section_kg,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CALL section_vals_set_subs_vals(xc_fun_section_kg,"KE_LIBXC",& - kef_section,error=error) + kef_section) CALL section_vals_set_subs_vals(xc_section_kg,"XC_FUNCTIONAL",& - xc_fun_section_kg,error=error) + xc_fun_section_kg) ke_sections = ke_sections + 1 END IF ! stop if there is more than one kinetic energy functional section present - !CPPostcondition(ke_sections==1,cp_failure_level,routineP,error,failure) + !CPPostcondition(ke_sections==1,cp_failure_level,routineP,failure) CALL cp_assert(ke_sections==1, cp_fatal_level, cp_assertion_failed, routineP, & "KG runs require a kinetic energy functional. Exactly one of the following "// & "subsections of XC_FUNCTIONAL needs to be present: KE_GGA, TF, TFW, or KE_LIBXC.") @@ -227,12 +218,12 @@ SUBROUTINE init_kg_env(kg_env, input, error) NULLIFY(kef_section, xc_fun_section) - CALL section_vals_release(xc_fun_section_kg, error=error) + CALL section_vals_release(xc_fun_section_kg) ELSEIF(kg_env%tnadd_method == kg_tnadd_atomic) THEN NULLIFY(kg_env%xc_section_kg) ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -248,20 +239,18 @@ END SUBROUTINE init_kg_env !> \param molecular if false, the full neighborlist is build !> \param subset_of_mol the molecular subsets !> \param current_subset the subset of which the neighborlist is to be build -!> \param error ... !> \par History !> 2012.07 created [Martin Haeufel] !> \author Martin Haeufel ! ***************************************************************************** SUBROUTINE kg_build_neighborlist(qs_env, sab_orb, sac_kin,& - molecular, subset_of_mol, current_subset, error) + molecular, subset_of_mol, current_subset) TYPE(qs_environment_type), POINTER :: qs_env TYPE(neighbor_list_set_p_type), & DIMENSION(:), OPTIONAL, POINTER :: sab_orb, sac_kin LOGICAL, OPTIONAL :: molecular INTEGER, DIMENSION(:), OPTIONAL, POINTER :: subset_of_mol INTEGER, OPTIONAL :: current_subset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_build_neighborlist', & routineP = moduleN//':'//routineN @@ -304,32 +293,31 @@ SUBROUTINE kg_build_neighborlist(qs_env, sab_orb, sac_kin,& molecule_set=molecule_set,& local_particles=distribution_1d,& particle_set=particle_set,& - para_env=para_env,& - error=error) + para_env=para_env) ! Allocate work storage nkind = SIZE(atomic_kind_set) ALLOCATE (orb_radius(nkind),tpot_radius(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) orb_radius(:) = 0.0_dp tpot_radius(:) = 0.0_dp ALLOCATE (orb_present(nkind),tpot_present(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (pair_radius(nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom2d(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL section_vals_val_get(qs_env%input,"DFT%SUBCELLS",r_val=subcells,error=error) + CALL section_vals_val_get(qs_env%input,"DFT%SUBCELLS",r_val=subcells) IF (PRESENT(subset_of_mol)) THEN CALL atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distribution_2d,& atomic_kind_set,qs_kind_set,molecule_set,molecule_only,kg=.FALSE.,& - dftb=.FALSE.,particle_set=particle_set,error=error) + dftb=.FALSE.,particle_set=particle_set) ELSE CALL atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distribution_2d,& atomic_kind_set,qs_kind_set,molecule_set,molecule_only,kg=.TRUE.,& - dftb=.FALSE.,particle_set=particle_set,error=error) + dftb=.FALSE.,particle_set=particle_set) END IF DO ikind=1,nkind @@ -339,26 +327,26 @@ SUBROUTINE kg_build_neighborlist(qs_env, sab_orb, sac_kin,& IF (PRESENT(sab_orb)) THEN ! Build the orbital-orbital overlap neighbor list - CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius) IF (PRESENT(subset_of_mol)) THEN CALL build_neighbor_lists(sab_orb,particle_set,atom2d,cell,pair_radius,& mic=.FALSE.,subcells=subcells,molecular=molecule_only,subset_of_mol=subset_of_mol,& - current_subset=current_subset,name="sab_orb",error=error) + current_subset=current_subset,name="sab_orb") ELSE CALL build_neighbor_lists(sab_orb,particle_set,atom2d,cell,pair_radius,& - mic=.FALSE.,subcells=subcells,molecular=molecule_only,name="sab_orb",error=error) + mic=.FALSE.,subcells=subcells,molecular=molecule_only,name="sab_orb") END IF ! Print out the neighborlist - neighbor_list_section => section_vals_get_subs_vals(qs_env%input,"DFT%KG_METHOD%PRINT%NEIGHBOR_LISTS",error=error) + neighbor_list_section => section_vals_get_subs_vals(qs_env%input,"DFT%KG_METHOD%PRINT%NEIGHBOR_LISTS") IF (molecule_only) THEN CALL write_neighbor_lists(sab_orb,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_ORB_MOLECULAR","sab_orb","MOLECULAR SUBSET NEIGHBORLIST",error) + "/SAB_ORB_MOLECULAR","sab_orb","MOLECULAR SUBSET NEIGHBORLIST") ELSE CALL write_neighbor_lists(sab_orb,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_ORB_FULL","sab_orb","FULL NEIGHBORLIST",error) + "/SAB_ORB_FULL","sab_orb","FULL NEIGHBORLIST") END IF END IF @@ -366,31 +354,31 @@ SUBROUTINE kg_build_neighborlist(qs_env, sab_orb, sac_kin,& IF (PRESENT(sac_kin)) THEN DO ikind=1,nkind tpot_present(ikind) = .FALSE. - CALL get_qs_kind(qs_kind_set(ikind),tnadd_potential=tnadd_potential, error=error) + CALL get_qs_kind(qs_kind_set(ikind),tnadd_potential=tnadd_potential) IF (ASSOCIATED(tnadd_potential)) THEN CALL get_potential(potential=tnadd_potential,radius=tpot_radius(ikind)) tpot_present(ikind) = .TRUE. END IF END DO - CALL pair_radius_setup(orb_present,tpot_present,orb_radius,tpot_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,tpot_present,orb_radius,tpot_radius,pair_radius) CALL build_neighbor_lists(sac_kin,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="ABC",name="sac_kin",error=error) + subcells=subcells,operator_type="ABC",name="sac_kin") neighbor_list_section => section_vals_get_subs_vals(qs_env%input,& - "DFT%KG_METHOD%PRINT%NEIGHBOR_LISTS",error=error) + "DFT%KG_METHOD%PRINT%NEIGHBOR_LISTS") CALL write_neighbor_lists(sac_kin,particle_set,cell,para_env,neighbor_list_section,& - "/SAC_KIN","sac_kin","ORBITAL kin energy potential",error) + "/SAC_KIN","sac_kin","ORBITAL kin energy potential") END IF ! Release work storage - CALL atom2d_cleanup(atom2d,error) + CALL atom2d_cleanup(atom2d) DEALLOCATE (atom2d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (orb_present,tpot_present,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (orb_radius,tpot_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (pair_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -460,13 +448,11 @@ SUBROUTINE kg_remove_duplicates(pairs_buffer, n) !> for an edge (w,v) the fields W and V specify its endpoints !> \param pairs ... !> \param nnodes the total number of nodes -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_to_file(pairs, nnodes, error) + SUBROUTINE write_to_file(pairs, nnodes) INTEGER(KIND=int_4), ALLOCATABLE, & DIMENSION(:, :), INTENT(IN) :: pairs INTEGER, INTENT(IN) :: nnodes - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_to_file', & routineP = moduleN//':'//routineN @@ -506,7 +492,7 @@ SUBROUTINE write_to_file(pairs, nnodes, error) CALL kg_remove_duplicates(sorted_pairs, npairs) ! should now be half as much pairs as before - CPPostcondition(npairs==SIZE(pairs,2)/2,cp_failure_level,routineP,error,failure) + CPPostcondition(npairs==SIZE(pairs,2)/2,cp_failure_level,routineP,failure) CALL open_file(unit_number=unit_nr, file_name="graph.col") @@ -529,12 +515,10 @@ SUBROUTINE write_to_file(pairs, nnodes, error) !> \brief ... !> \param kg_env ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_build_subsets(kg_env, para_env, error) + SUBROUTINE kg_build_subsets(kg_env, para_env) TYPE(kg_environment_type), POINTER :: kg_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_build_subsets', & routineP = moduleN//':'//routineN @@ -665,11 +649,11 @@ SUBROUTINE kg_build_subsets(kg_env, para_env, error) ! write to file, nnodes = number of molecules IF (.FALSE.) THEN - CALL write_to_file(pairs, SIZE(kg_env%molecule_set), error) + CALL write_to_file(pairs, SIZE(kg_env%molecule_set)) ENDIF ! vertex coloring algorithm - CALL kg_vertex_coloring(kg_env, pairs, ncolors, color_of_node, error) + CALL kg_vertex_coloring(kg_env, pairs, ncolors, color_of_node) DEALLOCATE(pairs) @@ -706,7 +690,7 @@ SUBROUTINE kg_build_subsets(kg_env, para_env, error) DEALLOCATE(kg_env%subset(isub)%sab_orb) - CALL deallocate_task_list(kg_env%subset(isub)%task_list, error) + CALL deallocate_task_list(kg_env%subset(isub)%task_list) END DO diff --git a/src/kg_environment_types.F b/src/kg_environment_types.F index b6acbadac5..9d8fb5437c 100644 --- a/src/kg_environment_types.F +++ b/src/kg_environment_types.F @@ -74,11 +74,9 @@ MODULE kg_environment_types ! ***************************************************************************** !> \brief ... !> \param kg_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_env_release(kg_env, error) + SUBROUTINE kg_env_release(kg_env) TYPE(kg_environment_type), POINTER :: kg_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_env_release', & routineP = moduleN//':'//routineN @@ -90,27 +88,27 @@ SUBROUTINE kg_env_release(kg_env, error) CALL timeset(routineN, handle) - CPPostcondition(ASSOCIATED(kg_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(kg_env),cp_failure_level,routineP,failure) - CALL section_vals_release(kg_env%xc_section_kg, error=error) + CALL section_vals_release(kg_env%xc_section_kg) IF (ASSOCIATED(kg_env%sab_orb_full)) THEN DO iab=1,SIZE(kg_env%sab_orb_full) CALL deallocate_neighbor_list_set(kg_env%sab_orb_full(iab)%neighbor_list_set) END DO DEALLOCATE(kg_env%sab_orb_full,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(kg_env%sac_kin)) THEN DO iab=1,SIZE(kg_env%sac_kin) CALL deallocate_neighbor_list_set(kg_env%sac_kin(iab)%neighbor_list_set) END DO DEALLOCATE(kg_env%sac_kin,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kg_env%tnadd_mat)) THEN - CALL cp_dbcsr_deallocate_matrix_set(kg_env%tnadd_mat,error) + CALL cp_dbcsr_deallocate_matrix_set(kg_env%tnadd_mat) ENDIF DO isub=1,kg_env%nsubsets @@ -118,8 +116,8 @@ SUBROUTINE kg_env_release(kg_env, error) CALL deallocate_neighbor_list_set(kg_env%subset(isub)%sab_orb(iab)%neighbor_list_set) END DO DEALLOCATE(kg_env%subset(isub)%sab_orb,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CALL deallocate_task_list(kg_env%subset(isub)%task_list, error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CALL deallocate_task_list(kg_env%subset(isub)%task_list) END DO IF (ASSOCIATED(kg_env%subset_of_mol)) DEALLOCATE(kg_env%subset_of_mol) @@ -127,10 +125,10 @@ SUBROUTINE kg_env_release(kg_env, error) IF (ALLOCATED(kg_env%atom_to_molecule)) DEALLOCATE(kg_env%atom_to_molecule) - IF (ASSOCIATED(kg_env%tnadd_mat)) CALL cp_dbcsr_deallocate_matrix_set(kg_env%tnadd_mat,error) + IF (ASSOCIATED(kg_env%tnadd_mat)) CALL cp_dbcsr_deallocate_matrix_set(kg_env%tnadd_mat) DEALLOCATE(kg_env,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/kg_tnadd_mat.F b/src/kg_tnadd_mat.F index 92dcb62758..e1e216d885 100644 --- a/src/kg_tnadd_mat.F +++ b/src/kg_tnadd_mat.F @@ -74,10 +74,9 @@ MODULE kg_tnadd_mat !> \param particle_set ... !> \param sab_orb ... !> \param dbcsr_dist ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, use_virial, & - qs_kind_set, atomic_kind_set, particle_set, sab_orb, dbcsr_dist, error) + qs_kind_set, atomic_kind_set, particle_set, sab_orb, dbcsr_dist) TYPE(kg_environment_type), POINTER :: kg_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -96,7 +95,6 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_orb TYPE(dbcsr_distribution_obj), POINTER :: dbcsr_dist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_tnadd_mat', & routineP = moduleN//':'//routineN @@ -149,7 +147,7 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us NULLIFY(matrix_kg) IF (ASSOCIATED(kg_env%tnadd_mat)) THEN - CALL cp_dbcsr_deallocate_matrix_set(kg_env%tnadd_mat,error) + CALL cp_dbcsr_deallocate_matrix_set(kg_env%tnadd_mat) ENDIF sac_kin => kg_env%sac_kin atom_to_molecule => kg_env%atom_to_molecule @@ -158,7 +156,7 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us natom = SIZE(particle_set) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) IF (calculate_forces) THEN @@ -166,9 +164,9 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us IF (SIZE(matrix_p,1) == 2) THEN DO img=1,SIZE(matrix_p,2) CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-2.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-2.0_dp, beta_scalar=1.0_dp) END DO END IF ELSE @@ -178,7 +176,7 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us maxder = ncoset(nder) CALL get_qs_kind_set(qs_kind_set,maxpol=maxpol,maxco=maxco,maxlgto=maxlgto,& - maxsgf=maxsgf,maxnset=maxnset,error=error) + maxsgf=maxsgf,maxnset=maxnset) maxl = MAX(maxlgto,maxpol) CALL init_orbital_pointers(maxl+nder+1) @@ -187,9 +185,9 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us ldai = ncoset(maxl+nder+1) ALLOCATE (basis_set_list(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -199,23 +197,23 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us ! build the matrix ALLOCATE (row_blk_sizes(natom),col_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes, error=error) - CALL get_particle_set(particle_set, qs_kind_set, nsgf=col_blk_sizes, error=error) + CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes) + CALL get_particle_set(particle_set, qs_kind_set, nsgf=col_blk_sizes) - CALL cp_dbcsr_allocate_matrix_set(matrix_kg,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_kg,1) ALLOCATE(matrix_kg(1)%matrix, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_kg(1)%matrix,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_kg(1)%matrix) CALL cp_dbcsr_create(matrix=matrix_kg(1)%matrix, & name="Nonadditive kinetic energy potential", & dist=dbcsr_dist, matrix_type=dbcsr_type_symmetric,& row_blk_size=row_blk_sizes, col_blk_size=col_blk_sizes, & - nze=0, reuse_arrays=.TRUE., error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_kg(1)%matrix,sab_orb,error) - CALL cp_dbcsr_set(matrix_kg(1)%matrix,0.0_dp,error=error) + nze=0, reuse_arrays=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_kg(1)%matrix,sab_orb) + CALL cp_dbcsr_set(matrix_kg(1)%matrix,0.0_dp) nthread=1 !$ nthread=omp_get_max_threads() @@ -238,7 +236,7 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us !$OMP npol, ngau, cval, ccval, ap_iterator, rac, dac, rbc, dbc, & !$OMP set_radius_a, rpgfa, force_a, force_b, ppl_fwork, mepos, & !$OMP f0, failure, katom, ppl_work, atom_c,& -!$OMP error, stat, ldai,tnadd_potential) +!$OMP stat, ldai,tnadd_potential) mepos=0 !$ mepos=omp_get_thread_num() @@ -247,16 +245,16 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us CALL neighbor_list_iterator_create(ap_iterator,sac_kin,search=.TRUE.) ALLOCATE(hab(ldsab,ldsab,maxnset,maxnset),work(ldsab,ldsab*maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ldai = ncoset(2*maxlgto+2*nder) ALLOCATE (ppl_work(ldai,ldai,MAX(maxder,2*maxlgto+2*nder+1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN ALLOCATE(pab(maxco,maxco,maxnset,maxnset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ldai = ncoset(maxlgto) ALLOCATE (ppl_fwork(ldai,ldai,maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF last_iatom = 0 @@ -275,7 +273,7 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us atom_b = atom_of_kind(jatom) imol = atom_to_molecule(iatom) jmol = atom_to_molecule(jatom) - CPPostcondition(imol==jmol,cp_failure_level,routineP,error,failure) + CPPostcondition(imol==jmol,cp_failure_level,routineP,failure) ! basis ikind first_sgfa => basis_set_a%first_sgf @@ -330,7 +328,7 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us CALL cp_dbcsr_get_block_p(matrix_kg(1)%matrix,irow,icol,h_block,found) IF(ASSOCIATED(h_block)) THEN IF (calculate_forces) THEN - CPPrecondition(SIZE(matrix_p,2)==1,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(matrix_p,2)==1,cp_failure_level,routineP,failure) NULLIFY(p_block) CALL cp_dbcsr_get_block_p(matrix_p(1,1)%matrix,irow,icol,p_block,found) IF(ASSOCIATED(p_block)) THEN @@ -370,13 +368,13 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us ! loop over all kinds for nonadditive kinetic energy potential atoms DO kkind=1,nkind - CALL get_qs_kind(qs_kind_set(kkind),tnadd_potential=tnadd_potential,error=error) + CALL get_qs_kind(qs_kind_set(kkind),tnadd_potential=tnadd_potential) IF (.NOT.ASSOCIATED(tnadd_potential)) CYCLE CALL get_potential(potential=tnadd_potential,& alpha=alpha,cval=cval,ngau=ngau,npol=npol,radius=radius) nct = npol ALLOCATE(ccval(npol,ngau),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ccval(1:npol,1:ngau) = TRANSPOSE(cval(1:ngau,1:npol)) CALL nl_set_sub_iterator(ap_iterator,ikind,kkind,iatom) @@ -417,7 +415,7 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us ngau,alpha,nct,ccval,radius,& rab,dab,rac,dac,rbc,dbc,& hab(:,:,iset,jset),ppl_work,pab(:,:,iset,jset),& - force_a,force_b,ppl_fwork,error=error) + force_a,force_b,ppl_fwork) ! *** The derivatives w.r.t. atomic center c are *** ! *** calculated using the translational invariance *** ! *** of the first derivatives *** @@ -439,8 +437,8 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us force(kkind)%kinetic(3,atom_c) =force(kkind)%kinetic(3,atom_c) - f0*force_b(3) IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, f0, force_a, rac, error) - CALL virial_pair_force ( virial%pv_virial, f0, force_b, rbc, error) + CALL virial_pair_force ( virial%pv_virial, f0, force_a, rac) + CALL virial_pair_force ( virial%pv_virial, f0, force_b, rbc) END IF !$OMP END CRITICAL(force_critical) @@ -451,14 +449,13 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us lb_max(jset),lb_min(jset),npgfb(jset),& rpgfb(:,jset),zetb(:,jset),& ngau,alpha,nct,ccval,radius,& - rab,dab,rac,dac,rbc,dbc,hab(:,:,iset,jset),ppl_work,& - error=error) + rab,dab,rac,dac,rbc,dbc,hab(:,:,iset,jset),ppl_work) END IF END DO END DO END DO DEALLOCATE(ccval,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO ! *** Contract integrals @@ -495,11 +492,11 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us CALL neighbor_list_iterator_release(ap_iterator) DEALLOCATE(hab,work,ppl_work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE(pab,ppl_fwork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !$OMP END PARALLEL @@ -507,12 +504,12 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us CALL neighbor_list_iterator_release(nl_iterator) DO i = 1,SIZE(matrix_kg) - CALL cp_dbcsr_finalize(matrix_kg(i)%matrix, error=error) + CALL cp_dbcsr_finalize(matrix_kg(i)%matrix) ENDDO kg_env%tnadd_mat => matrix_kg DEALLOCATE (atom_of_kind,basis_set_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN ! *** If LSD, then recover alpha density and beta density *** @@ -520,9 +517,9 @@ SUBROUTINE build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, us IF (SIZE(matrix_p,1) == 2) THEN DO img=1,SIZE(matrix_p,2) CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 0.5_dp, beta_scalar=0.5_dp,error=error) + alpha_scalar= 0.5_dp, beta_scalar=0.5_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-1.0_dp, beta_scalar=1.0_dp) END DO END IF END IF diff --git a/src/kg_vertex_coloring_methods.F b/src/kg_vertex_coloring_methods.F index 24287faac9..3f99760b06 100644 --- a/src/kg_vertex_coloring_methods.F +++ b/src/kg_vertex_coloring_methods.F @@ -261,12 +261,10 @@ SUBROUTINE print_subsets(graph, ncolors, unit_nr) !> \brief ... !> \param heap ... !> \param nnodes ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_heap_new(heap, nnodes, error) + SUBROUTINE kg_heap_new(heap, nnodes) TYPE(heap_t), INTENT(OUT) :: heap INTEGER :: nnodes - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_heap_new', & routineP = moduleN//':'//routineN @@ -277,7 +275,7 @@ SUBROUTINE kg_heap_new(heap, nnodes, error) CALL heap_new(heap, nnodes, heap_error) CALL cp_assert (.NOT. heap_error, cp_fatal_level, cp_internal_error,& - routineP, "Error creating heap.", error=error) + routineP, "Error creating heap.") END SUBROUTINE @@ -304,13 +302,11 @@ ELEMENTAL FUNCTION kg_get_value(dsat, degree) RESULT(value) !> \brief ... !> \param heap ... !> \param graph ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_heap_fill(heap, graph, error) + SUBROUTINE kg_heap_fill(heap, graph) TYPE(heap_t), INTENT(INOUT) :: heap TYPE(vertex_p_type), DIMENSION(:), & INTENT(IN), POINTER :: graph - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_heap_fill', & routineP = moduleN//':'//routineN @@ -333,7 +329,7 @@ SUBROUTINE kg_heap_fill(heap, graph, error) ! fill the heap CALL heap_fill (heap, values, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error,& - routineP, "Error initially filling heap.", error=error) + routineP, "Error initially filling heap.") DEALLOCATE (values) @@ -342,11 +338,9 @@ SUBROUTINE kg_heap_fill(heap, graph, error) ! ***************************************************************************** !> \brief ... !> \param heap ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_heap_release(heap, error) + SUBROUTINE kg_heap_release(heap) TYPE(heap_t) :: heap - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_heap_release', & routineP = moduleN//':'//routineN @@ -357,7 +351,7 @@ SUBROUTINE kg_heap_release(heap, error) CALL heap_release(heap, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error,& - routineP, "Error releasing heap.", error=error) + routineP, "Error releasing heap.") END SUBROUTINE @@ -365,12 +359,10 @@ SUBROUTINE kg_heap_release(heap, error) !> \brief ... !> \param heap ... !> \param key ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_heap_pop(heap, key, error) + SUBROUTINE kg_heap_pop(heap, key) TYPE(heap_t) :: heap INTEGER, INTENT(OUT) :: key - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_heap_pop', & routineP = moduleN//':'//routineN @@ -382,7 +374,7 @@ SUBROUTINE kg_heap_pop(heap, key, error) CALL heap_pop (heap, key, value, found, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error,& - routineP, "Error getting topmost heap element.", error=error) + routineP, "Error getting topmost heap element.") END SUBROUTINE @@ -391,13 +383,11 @@ SUBROUTINE kg_heap_pop(heap, key, error) !> \param heap ... !> \param key ... !> \param value ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_heap_reset_node(heap, key, value, error) + SUBROUTINE kg_heap_reset_node(heap, key, value) TYPE(heap_t) :: heap INTEGER(KIND=keyt), INTENT(IN) :: key INTEGER(KIND=valt), INTENT(IN) :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_heap_reset_node', & routineP = moduleN//':'//routineN @@ -406,7 +396,7 @@ SUBROUTINE kg_heap_reset_node(heap, key, value, error) CALL heap_reset_node (heap, key, value, heap_error) CALL cp_assert (.NOT. heap_error, cp_warning_level, cp_internal_error,& - routineP, "Error changing value of heap element.", error=error) + routineP, "Error changing value of heap element.") END SUBROUTINE @@ -414,12 +404,10 @@ SUBROUTINE kg_heap_reset_node(heap, key, value, error) !> \brief ... !> \param heap ... !> \param node ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_update_node(heap, node, error) + SUBROUTINE kg_update_node(heap, node) TYPE(heap_t) :: heap TYPE(vertex), INTENT(IN), POINTER :: node - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_update_node', & routineP = moduleN//':'//routineN @@ -437,7 +425,7 @@ SUBROUTINE kg_update_node(heap, node, error) value = kg_get_value(dsat, degree) - CALL kg_heap_reset_node(heap, id, value, error) + CALL kg_heap_reset_node(heap, id, value) END IF @@ -449,14 +437,12 @@ SUBROUTINE kg_update_node(heap, node, error) !> \param kg_env ... !> \param graph ... !> \param ncolors ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_dsatur(kg_env, graph, ncolors, error) + SUBROUTINE kg_dsatur(kg_env, graph, ncolors) TYPE(kg_environment_type), POINTER :: kg_env TYPE(vertex_p_type), DIMENSION(:), & POINTER :: graph INTEGER(KIND=int_4), INTENT(OUT) :: ncolors - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kg_dsatur', & routineP = moduleN//':'//routineN @@ -493,13 +479,13 @@ SUBROUTINE kg_dsatur(kg_env, graph, ncolors, error) ELSE ! allocate and fill the heap - CALL kg_heap_new(heap, nnodes, error) + CALL kg_heap_new(heap, nnodes) - CALL kg_heap_fill(heap, graph, error) + CALL kg_heap_fill(heap, graph) DO WHILE (heap%n>0) - CALL kg_heap_pop(heap, key, error) + CALL kg_heap_pop(heap, key) this => graph(key)%vertex @@ -526,7 +512,7 @@ SUBROUTINE kg_dsatur(kg_env, graph, ncolors, error) neighbor%color_present(this%color)=.TRUE. neighbor%dsat = neighbor%dsat + 1 IF(neighbor%color/=0) CYCLE - CALL kg_update_node(heap, neighbor, error) + CALL kg_update_node(heap, neighbor) END DO @@ -551,7 +537,7 @@ SUBROUTINE kg_dsatur(kg_env, graph, ncolors, error) END DO ! release the heap - CALL kg_heap_release(heap, error) + CALL kg_heap_release(heap) END IF @@ -750,16 +736,14 @@ SUBROUTINE deallocate_graph(graph) !> \param pairs ... !> \param ncolors ... !> \param color_of_node ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kg_vertex_coloring(kg_env, pairs, ncolors, color_of_node, error) + SUBROUTINE kg_vertex_coloring(kg_env, pairs, ncolors, color_of_node) TYPE(kg_environment_type), POINTER :: kg_env INTEGER(KIND=int_4), ALLOCATABLE, & DIMENSION(:, :), INTENT(IN) :: pairs INTEGER(KIND=int_4), INTENT(OUT) :: ncolors INTEGER(KIND=int_4), ALLOCATABLE, & DIMENSION(:), INTENT(out) :: color_of_node - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kg_vertex_coloring', & routineP = moduleN//':'//routineN @@ -774,7 +758,7 @@ SUBROUTINE kg_vertex_coloring(kg_env, pairs, ncolors, color_of_node, error) failure = .FALSE. ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -791,10 +775,10 @@ SUBROUTINE kg_vertex_coloring(kg_env, pairs, ncolors, color_of_node, error) CALL color_graph_greedy(graph, kg_env%maxdegree, ncolors) CASE(kg_color_dsatur) ! color with max degree of saturation - CALL kg_dsatur(kg_env, graph, ncolors, error) + CALL kg_dsatur(kg_env, graph, ncolors) CASE DEFAULT CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error,& - routineP, "Coloring method not known.", error=error) + routineP, "Coloring method not known.") END SELECT CALL kg_pair_switching(graph,ncolors) @@ -802,7 +786,7 @@ SUBROUTINE kg_vertex_coloring(kg_env, pairs, ncolors, color_of_node, error) valid=.FALSE. CALL check_coloring(graph, valid) CALL cp_assert (valid, cp_fatal_level, cp_internal_error,& - routineP, "Coloring not valid.", error=error) + routineP, "Coloring not valid.") nnodes = SIZE(kg_env%molecule_set) diff --git a/src/kpoint_methods.F b/src/kpoint_methods.F index 656cff1a78..78bd649ec1 100644 --- a/src/kpoint_methods.F +++ b/src/kpoint_methods.F @@ -98,15 +98,13 @@ MODULE kpoint_methods !> \param kpoint The kpoint environment !> \param particle_set Particle types and coordinates !> \param cell Computational cell information -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) + SUBROUTINE kpoint_initialize(kpoint, particle_set, cell) TYPE(kpoint_type), POINTER :: kpoint TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_initialize', & routineP = moduleN//':'//routineN @@ -124,7 +122,7 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) failure=.FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) SELECT CASE (kpoint%kp_scheme) CASE ("NONE") @@ -132,7 +130,7 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) CASE ("GAMMA") kpoint%nkp = 1 ALLOCATE(kpoint%xkp(3,1),kpoint%wkp(1),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) kpoint%xkp(1:3,1) = 0.0_dp kpoint%wkp(1) = 1.0_dp CASE ("MONKHORST-PACK","MACDONALD") @@ -142,7 +140,7 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) ! we set up a random molecule to avoid any possible symmetry natom = 10 ALLOCATE(coord(3,natom),zeff(natom),weight(natom),atype(natom),element(natom),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO i=1,natom atype(i) = i coord(1,i) = SIN(i*0.12345_dp) @@ -152,7 +150,7 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) ELSE natom = SIZE(particle_set) ALLOCATE(coord(3,natom),zeff(natom),weight(natom),atype(natom),element(natom),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO i=1,natom CALL get_atomic_kind(atomic_kind=particle_set(i)%atomic_kind,kind_number=atype(i)) coord(1:3,i) = particle_set(i)%r(1:3) @@ -160,7 +158,7 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) END IF IF(kpoint%verbose) THEN NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iounit = cp_logger_get_default_io_unit(logger) ELSE iounit = -1 @@ -173,7 +171,7 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) delta=kpoint%eps_geo,& iounit=iounit,& xkpoint=kpoint%xkp,& - wkpoint=kpoint%wkp, error=error) + wkpoint=kpoint%wkp) kpoint%nkp = SIZE(kpoint%wkp) ! inversion symmetry @@ -181,14 +179,14 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) ! symmorphic group without special translation symmo = (crys_sym%isy ==1) - CALL release_csym_type(crys_sym,error) + CALL release_csym_type(crys_sym) DEALLOCATE(coord,zeff,weight,atype,element,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) CASE ("GENERAL") ! do nothing CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT ! check for consistency of options @@ -196,15 +194,15 @@ SUBROUTINE kpoint_initialize(kpoint, particle_set, cell, error) CASE ("NONE") ! don't use k-point code CASE ("GAMMA") - CPPostcondition(kpoint%nkp==1, cp_failure_level, routineP, error, failure) - CPPostcondition(SUM(ABS(kpoint%xkp))<=1.e-12_dp, cp_failure_level, routineP, error, failure) - CPPostcondition(kpoint%wkp(1)==1.0_dp, cp_failure_level, routineP, error, failure) - CPPostcondition(.NOT.kpoint%symmetry, cp_failure_level, routineP, error, failure) + CPPostcondition(kpoint%nkp==1, cp_failure_level, routineP,failure) + CPPostcondition(SUM(ABS(kpoint%xkp))<=1.e-12_dp, cp_failure_level, routineP,failure) + CPPostcondition(kpoint%wkp(1)==1.0_dp, cp_failure_level, routineP,failure) + CPPostcondition(.NOT.kpoint%symmetry, cp_failure_level, routineP,failure) CASE ("GENERAL") - CPPostcondition(.NOT.kpoint%symmetry, cp_failure_level, routineP, error, failure) - CPPostcondition(kpoint%nkp>=1, cp_failure_level, routineP, error, failure) + CPPostcondition(.NOT.kpoint%symmetry, cp_failure_level, routineP,failure) + CPPostcondition(kpoint%nkp>=1, cp_failure_level, routineP,failure) CASE ("MONKHORST-PACK","MACDONALD") - CPPostcondition(kpoint%nkp>=1, cp_failure_level, routineP, error, failure) + CPPostcondition(kpoint%nkp>=1, cp_failure_level, routineP,failure) END SELECT IF(kpoint%use_real_wfn) THEN ! what about inversion symmetry? @@ -230,12 +228,10 @@ END SUBROUTINE kpoint_initialize ! ***************************************************************************** !> \brief Initialize the kpoint environment !> \param kpoint Kpoint environment -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE kpoint_env_initialize(kpoint, error) + SUBROUTINE kpoint_env_initialize(kpoint) TYPE(kpoint_type), POINTER :: kpoint - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_env_initialize', & routineP = moduleN//':'//routineN @@ -255,10 +251,10 @@ SUBROUTINE kpoint_env_initialize(kpoint, error) TYPE(kpoint_env_type), POINTER :: kp failure = .FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) para_env => kpoint%para_env - CPAssert(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPAssert(.NOT.ASSOCIATED(kpoint%kp_env),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPAssert(.NOT.ASSOCIATED(kpoint%kp_env),cp_failure_level,routineP,failure) NULLIFY(kp_env) nkp = kpoint%nkp @@ -266,10 +262,10 @@ SUBROUTINE kpoint_env_initialize(kpoint, error) IF(npe == 1) THEN ! only one process availabe -> owns all kpoints ALLOCATE(kp_env(nkp),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO ik=1,nkp NULLIFY(kp_env(ik)%kpoint_env) - CALL kpoint_env_create(kp_env(ik)%kpoint_env, error) + CALL kpoint_env_create(kp_env(ik)%kpoint_env) kp => kp_env(ik)%kpoint_env kp%nkpoint = ik kp%wkp = kpoint%wkp(ik) @@ -277,7 +273,7 @@ SUBROUTINE kpoint_env_initialize(kpoint, error) kp%is_local = .TRUE. END DO ALLOCATE(kpoint%kp_dist(2,1),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) kpoint%kp_dist(1,1) = 1 kpoint%kp_dist(2,1) = nkp kpoint%kp_range(1) = 1 @@ -285,11 +281,11 @@ SUBROUTINE kpoint_env_initialize(kpoint, error) kpoint%kp_env => kp_env ! parallel environments kpoint%para_env_full => para_env - CALL cp_para_env_retain(para_env, error) + CALL cp_para_env_retain(para_env) kpoint%para_env_kp => para_env - CALL cp_para_env_retain(para_env, error) + CALL cp_para_env_retain(para_env) kpoint%para_env_inter_kp => para_env - CALL cp_para_env_retain(para_env, error) + CALL cp_para_env_retain(para_env) kpoint%iogrp = .TRUE. kpoint%nkp_groups = 1 ELSE @@ -309,36 +305,36 @@ SUBROUTINE kpoint_env_initialize(kpoint, error) ELSE IF(kpoint%parallel_group_size > 0) THEN ngr = MIN(kpoint%parallel_group_size,npe) ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF nkp_grp = npe/ngr ! processor dimensions dims(1)=ngr dims(2)=nkp_grp - CPPostcondition(MOD(nkp,nkp_grp)==0,cp_failure_level,routineP,error,failure) + CPPostcondition(MOD(nkp,nkp_grp)==0,cp_failure_level,routineP,failure) nkp_loc=nkp/nkp_grp IF ((dims(1)*dims(2)/=npe)) THEN message = "Number of processors is not divisible by the kpoint group size." CALL print_warning(routineN,moduleN,__LINE__,TRIM(message),para_env) - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF NULLIFY(cart,para_env_full,para_env_kp,para_env_inter_kp) CALL mp_cart_create(comm_old=para_env%group, ndims=2, dims=dims, pos=pos, & comm_cart=comm_cart) - CALL cp_cart_create(cart,comm_cart,ndims=2,owns_group=.TRUE.,error=error) - CALL cp_para_env_create(para_env_full,comm_cart,owns_group=.FALSE.,error=error) + CALL cp_cart_create(cart,comm_cart,ndims=2,owns_group=.TRUE.) + CALL cp_para_env_create(para_env_full,comm_cart,owns_group=.FALSE.) rdim(2)=.FALSE. rdim(1)=.TRUE. CALL mp_cart_sub(comm=comm_cart,rdim=rdim,sub_comm=comm_kp) - CALL cp_para_env_create(para_env_kp,comm_kp,owns_group=.TRUE.,error=error) + CALL cp_para_env_create(para_env_kp,comm_kp,owns_group=.TRUE.) rdim(2)=.TRUE. rdim(1)=.FALSE. CALL mp_cart_sub(comm=comm_cart,rdim=rdim,sub_comm=comm_inter_kp) CALL cp_para_env_create(para_env_inter_kp,comm_inter_kp,& - owns_group=.TRUE.,error=error) + owns_group=.TRUE.) niogrp = 0 IF(para_env%ionode) niogrp=1 @@ -353,18 +349,18 @@ SUBROUTINE kpoint_env_initialize(kpoint, error) ! distribution of kpoints ALLOCATE(kpoint%kp_dist(2,nkp_grp),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO igr = 1,nkp_grp kpoint%kp_dist(1:2,igr) = get_limit(nkp,nkp_grp,igr-1) END DO ! local kpoints kpoint%kp_range(1:2) = kpoint%kp_dist(1:2,para_env_inter_kp%mepos+1) ALLOCATE(kp_env(nkp_loc),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO ik=1,nkp_loc NULLIFY(kp_env(ik)%kpoint_env) ikk = kpoint%kp_range(1) + ik -1 - CALL kpoint_env_create(kp_env(ik)%kpoint_env, error) + CALL kpoint_env_create(kp_env(ik)%kpoint_env) kp => kp_env(ik)%kpoint_env kp%nkpoint = ikk kp%wkp = kpoint%wkp(ikk) @@ -374,7 +370,7 @@ SUBROUTINE kpoint_env_initialize(kpoint, error) kpoint%kp_env => kp_env - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_nr=cp_logger_get_default_io_unit(logger) IF (unit_nr>0) THEN WRITE(unit_nr,*) @@ -392,14 +388,12 @@ END SUBROUTINE kpoint_env_initialize !> \brief Initialize a set of MOs and density matrix for each kpoint (kpoint group) !> \param kpoint Kpoint environment !> \param mos Reference MOs (global) -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE kpoint_initialize_mos(kpoint, mos, error) + SUBROUTINE kpoint_initialize_mos(kpoint, mos) TYPE(kpoint_type), POINTER :: kpoint TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_initialize_mos', & routineP = moduleN//':'//routineN @@ -418,7 +412,7 @@ SUBROUTINE kpoint_initialize_mos(kpoint, mos, error) TYPE(qs_matrix_pools_type), POINTER :: mpools failure = .FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) IF (ASSOCIATED(mos)) THEN @@ -430,19 +424,19 @@ SUBROUTINE kpoint_initialize_mos(kpoint, mos, error) nspin = SIZE(mos,1) nkp_loc = kpoint%kp_range(2) - kpoint%kp_range(1) + 1 IF (nkp_loc > 0) THEN - CPAssert(SIZE(kpoint%kp_env)==nkp_loc,cp_failure_level,routineP,error,failure) + CPAssert(SIZE(kpoint%kp_env)==nkp_loc,cp_failure_level,routineP,failure) ! allocate the mo sets, correct number of kpoints (local), real/complex, spin DO ik=1,nkp_loc kp => kpoint%kp_env(ik)%kpoint_env ALLOCATE(kp%mos(nc,nspin),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO is=1,nspin CALL get_mo_set(mos(is)%mo_set,nao=nao,nmo=nmo,nelectron=nelectron,& n_el_f=n_el_f,maxocc=maxocc,flexible_electron_count=flexible_electron_count) DO ic=1,nc NULLIFY(kp%mos(ic,is)%mo_set) CALL allocate_mo_set(kp%mos(ic,is)%mo_set,nao,nmo,nelectron,n_el_f,maxocc,& - flexible_electron_count,error) + flexible_electron_count) END DO END DO END DO @@ -452,59 +446,59 @@ SUBROUTINE kpoint_initialize_mos(kpoint, mos, error) ! we assume here that the group para_env_inter_kp will connect ! equivalent parts of fm matrices, i.e. no reshuffeling of processors NULLIFY(blacs_env) - CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=kpoint%para_env_kp, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=kpoint%para_env_kp) kpoint%blacs_env => blacs_env ! matrix pools for the kpoint group, information on MOs is transfered using ! generic mos structure NULLIFY(mpools) - CALL mpools_create(mpools=mpools,error=error) + CALL mpools_create(mpools=mpools) CALL mpools_rebuild_fm_pools(mpools=mpools,mos=mos,& - blacs_env=blacs_env,para_env=kpoint%para_env_kp,error=error) + blacs_env=blacs_env,para_env=kpoint%para_env_kp) kpoint%mpools => mpools ! allocate density matrices - CALL mpools_get(mpools,ao_ao_fm_pools=ao_ao_fm_pools,error=error) - CALL fm_pool_create_fm(ao_ao_fm_pools(1)%pool,fmlocal,error=error) - CALL cp_fm_get_info(fmlocal,matrix_struct=matrix_struct,error=error) + CALL mpools_get(mpools,ao_ao_fm_pools=ao_ao_fm_pools) + CALL fm_pool_create_fm(ao_ao_fm_pools(1)%pool,fmlocal) + CALL cp_fm_get_info(fmlocal,matrix_struct=matrix_struct) DO ik=1,nkp_loc kp => kpoint%kp_env(ik)%kpoint_env ! density matrix IF(ASSOCIATED(kp%pmat)) THEN DO is=1,SIZE(kp%pmat,2) DO ic=1,SIZE(kp%pmat,1) - CALL cp_fm_release(kp%pmat(ic,is)%matrix,error) + CALL cp_fm_release(kp%pmat(ic,is)%matrix) END DO END DO DEALLOCATE(kp%pmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF ALLOCATE(kp%pmat(nc,nspin),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO is=1,nspin DO ic=1,nc - CALL cp_fm_create(kp%pmat(ic,is)%matrix,matrix_struct,error=error) + CALL cp_fm_create(kp%pmat(ic,is)%matrix,matrix_struct) END DO END DO ! energy weighted density matrix IF(ASSOCIATED(kp%wmat)) THEN DO is=1,SIZE(kp%wmat,2) DO ic=1,SIZE(kp%wmat,1) - CALL cp_fm_release(kp%wmat(ic,is)%matrix,error) + CALL cp_fm_release(kp%wmat(ic,is)%matrix) END DO END DO DEALLOCATE(kp%wmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF ALLOCATE(kp%wmat(nc,nspin),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO is=1,nspin DO ic=1,nc - CALL cp_fm_create(kp%wmat(ic,is)%matrix,matrix_struct,error=error) + CALL cp_fm_create(kp%wmat(ic,is)%matrix,matrix_struct) END DO END DO END DO - CALL fm_pool_give_back_fm(ao_ao_fm_pools(1)%pool, fmlocal, error=error) + CALL fm_pool_give_back_fm(ao_ao_fm_pools(1)%pool, fmlocal) END IF @@ -519,16 +513,14 @@ END SUBROUTINE kpoint_initialize_mos !> \param sab_nl Defining neighbour list !> \param para_env Parallel environment !> \param dft_control ... -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE kpoint_init_cell_index(kpoint, sab_nl, para_env, dft_control, error) + SUBROUTINE kpoint_init_cell_index(kpoint, sab_nl, para_env, dft_control) TYPE(kpoint_type), POINTER :: kpoint TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl TYPE(cp_para_env_type), POINTER :: para_env TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_init_cell_index', & routineP = moduleN//':'//routineN @@ -544,7 +536,7 @@ SUBROUTINE kpoint_init_cell_index(kpoint, sab_nl, para_env, dft_control, error) DIMENSION(:), POINTER :: nl_iterator failure = .FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) ALLOCATE(list(3,125)) list = 0 @@ -643,10 +635,9 @@ END SUBROUTINE kpoint_init_cell_index !> \param xkp Kpoint coordinates !> \param cell_to_index mapping of cell indices to RS index !> \param sab_nl Defining neighbor list -!> \param error CP2K error handling ! ***************************************************************************** SUBROUTINE rskp_transform(rmatrix,cmatrix,rsmat,ispin,& - xkp,cell_to_index,sab_nl,error) + xkp,cell_to_index,sab_nl) TYPE(cp_dbcsr_type), POINTER :: rmatrix TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: cmatrix @@ -657,7 +648,6 @@ SUBROUTINE rskp_transform(rmatrix,cmatrix,rsmat,ispin,& INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rskp_transform', & routineP = moduleN//':'//routineN @@ -676,10 +666,10 @@ SUBROUTINE rskp_transform(rmatrix,cmatrix,rsmat,ispin,& CALL get_neighbor_list_set_p(neighbor_list_sets=sab_nl,symmetric=do_symmetric) IF(wfn_real_only) THEN - CALL cp_dbcsr_set(rmatrix,0.0_dp,error=error) + CALL cp_dbcsr_set(rmatrix,0.0_dp) ELSE - CALL cp_dbcsr_set(rmatrix,0.0_dp,error=error) - CALL cp_dbcsr_set(cmatrix,0.0_dp,error=error) + CALL cp_dbcsr_set(rmatrix,0.0_dp) + CALL cp_dbcsr_set(cmatrix,0.0_dp) END IF CALL neighbor_list_iterator_create(nl_iterator,sab_nl) @@ -702,20 +692,20 @@ SUBROUTINE rskp_transform(rmatrix,cmatrix,rsmat,ispin,& ic = cell_to_index(cell(1),cell(2),cell(3)) CALL cp_dbcsr_get_block_p(matrix=rsmat(ispin,ic)%matrix,row=irow,col=icol,& block=rsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) IF(wfn_real_only) THEN CALL cp_dbcsr_get_block_p(matrix=rmatrix,row=irow,col=icol,& block=rblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) rblock = rblock + coskl*rsblock ELSE CALL cp_dbcsr_get_block_p(matrix=rmatrix,row=irow,col=icol,& block=rblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=cmatrix,row=irow,col=icol,& block=cblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) rblock = rblock + coskl*rsblock cblock = cblock + sinkl*rsblock END IF @@ -729,13 +719,11 @@ END SUBROUTINE rskp_transform !> \brief Given the eigenvalues of all kpoints, calculates the occupation numbers !> \param kpoint Kpoint environment !> \param smear Smearing information -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE kpoint_set_mo_occupation(kpoint,smear,error) + SUBROUTINE kpoint_set_mo_occupation(kpoint,smear) TYPE(kpoint_type), POINTER :: kpoint TYPE(smear_type), POINTER :: smear - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_set_mo_occupation', & routineP = moduleN//':'//routineN @@ -755,20 +743,20 @@ SUBROUTINE kpoint_set_mo_occupation(kpoint,smear,error) failure = .FALSE. ! first collect all the eigenvalues - CALL get_kpoint_info(kpoint,nkp=nkp,error=error) + CALL get_kpoint_info(kpoint,nkp=nkp) kp => kpoint%kp_env(1)%kpoint_env nspin = SIZE(kp%mos,2) mo_set => kp%mos(1,1)%mo_set CALL get_mo_set(mo_set,nmo=nmo,nelectron=nelectron) IF(nspin==2) THEN CALL get_mo_set(kp%mos(1,2)%mo_set,nmo=nb) - CPAssert(nmo==nb,cp_failure_level,routineP,error,failure) + CPAssert(nmo==nb,cp_failure_level,routineP,failure) END IF ALLOCATE(weig(nmo,nkp,nspin),wocc(nmo,nkp,nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) weig = 0.0_dp wocc = 0.0_dp - CALL get_kpoint_info(kpoint,kp_range=kp_range,error=error) + CALL get_kpoint_info(kpoint,kp_range=kp_range) kplocal = kp_range(2) - kp_range(1) + 1 DO ikpgr = 1,kplocal ik = kp_range(1)+ikpgr-1 @@ -779,20 +767,20 @@ SUBROUTINE kpoint_set_mo_occupation(kpoint,smear,error) weig(1:nmo,ik,ispin) = eigenvalues(1:nmo) END DO END DO - CALL get_kpoint_info(kpoint,para_env_inter_kp=para_env_inter_kp,error=error) + CALL get_kpoint_info(kpoint,para_env_inter_kp=para_env_inter_kp) CALL mp_sum(weig,para_env_inter_kp%group) nel = REAL(nelectron,KIND=dp) - CALL get_kpoint_info(kpoint,wkp=wkp,error=error) + CALL get_kpoint_info(kpoint,wkp=wkp) IF(smear%do_smear) THEN ! finite electronic temperature - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) ELSE ! fixed occupations (2/1) IF(nspin==1) THEN CALL Fermikp(wocc(:,:,1),mu,kTS,weig(:,:,1),nel,wkp,0.0_dp,2.0_dp) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END IF DO ikpgr = 1,kplocal @@ -807,7 +795,7 @@ SUBROUTINE kpoint_set_mo_occupation(kpoint,smear,error) END DO DEALLOCATE(weig,wocc,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE kpoint_set_mo_occupation @@ -815,13 +803,11 @@ END SUBROUTINE kpoint_set_mo_occupation !> \brief Calculate kpoint density matrices (rho(k), owned by kpoint groups) !> \param kpoint kpoint environment !> \param energy_weighted calculate energy weighted density matrix -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE kpoint_density_matrices(kpoint,energy_weighted,error) + SUBROUTINE kpoint_density_matrices(kpoint,energy_weighted) TYPE(kpoint_type), POINTER :: kpoint LOGICAL, OPTIONAL :: energy_weighted - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_density_matrices', & routineP = moduleN//':'//routineN @@ -849,10 +835,10 @@ SUBROUTINE kpoint_density_matrices(kpoint,energy_weighted,error) ! work matrix mo_set => kpoint%kp_env(1)%kpoint_env%mos(1,1)%mo_set CALL get_mo_set(mo_set,nao=nao,nmo=nmo) - CALL cp_fm_get_info(mo_set%mo_coeff,matrix_struct=matrix_struct,error=error) - CALL cp_fm_create(fwork,matrix_struct,error=error) + CALL cp_fm_get_info(mo_set%mo_coeff,matrix_struct=matrix_struct) + CALL cp_fm_create(fwork,matrix_struct) - CALL get_kpoint_info(kpoint,kp_range=kp_range,error=error) + CALL get_kpoint_info(kpoint,kp_range=kp_range) kplocal = kp_range(2) - kp_range(1) + 1 DO ikpgr = 1,kplocal kp => kpoint%kp_env(ikpgr)%kpoint_env @@ -869,12 +855,12 @@ SUBROUTINE kpoint_density_matrices(kpoint,energy_weighted,error) pmat => kp%pmat(1,ispin)%matrix END IF CALL get_mo_set(mo_set,occupation_numbers=occupation) - CALL cp_fm_to_fm(mo_set%mo_coeff,fwork,error) + CALL cp_fm_to_fm(mo_set%mo_coeff,fwork) CALL cp_fm_column_scale(fwork,occupation) IF(wtype) THEN CALL cp_fm_column_scale(fwork,eigenvalues) END IF - CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,mo_set%mo_coeff,fwork,0.0_dp,pmat,error) + CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,mo_set%mo_coeff,fwork,0.0_dp,pmat) ELSE IF(wtype) THEN rpmat => kp%wmat(1,ispin)%matrix @@ -884,30 +870,30 @@ SUBROUTINE kpoint_density_matrices(kpoint,energy_weighted,error) cpmat => kp%pmat(2,ispin)%matrix END IF CALL get_mo_set(mo_set,occupation_numbers=occupation) - CALL cp_fm_to_fm(mo_set%mo_coeff,fwork,error) + CALL cp_fm_to_fm(mo_set%mo_coeff,fwork) CALL cp_fm_column_scale(fwork,occupation) IF(wtype) THEN CALL cp_fm_column_scale(fwork,eigenvalues) END IF ! Re(c)*Re(c) - CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,mo_set%mo_coeff,fwork,0.0_dp,rpmat,error) + CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,mo_set%mo_coeff,fwork,0.0_dp,rpmat) mo_set => kp%mos(2,ispin)%mo_set ! Im(c)*Re(c) - CALL cp_gemm("N","T",nao,nao,nmo,-1.0_dp,mo_set%mo_coeff,fwork,0.0_dp,cpmat,error) + CALL cp_gemm("N","T",nao,nao,nmo,-1.0_dp,mo_set%mo_coeff,fwork,0.0_dp,cpmat) ! Re(c)*Im(c) - CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,fwork,mo_set%mo_coeff,1.0_dp,cpmat,error) - CALL cp_fm_to_fm(mo_set%mo_coeff,fwork,error) + CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,fwork,mo_set%mo_coeff,1.0_dp,cpmat) + CALL cp_fm_to_fm(mo_set%mo_coeff,fwork) CALL cp_fm_column_scale(fwork,occupation) IF(wtype) THEN CALL cp_fm_column_scale(fwork,eigenvalues) END IF ! Im(c)*Im(c) - CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,mo_set%mo_coeff,fwork,1.0_dp,rpmat,error) + CALL cp_gemm("N","T",nao,nao,nmo,1.0_dp,mo_set%mo_coeff,fwork,1.0_dp,rpmat) END IF END DO END DO - CALL cp_fm_release(fwork,error=error) + CALL cp_fm_release(fwork) END SUBROUTINE kpoint_density_matrices @@ -920,9 +906,8 @@ END SUBROUTINE kpoint_density_matrices !> \param tempmat DBCSR matrix to be used as template !> \param sab_nl ... !> \param fmwork FM work matrices (kpoint group) -!> \param error CP2K error handling ! ***************************************************************************** - SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork,error) + SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork) TYPE(kpoint_type), POINTER :: kpoint TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -933,7 +918,6 @@ SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork,er DIMENSION(:), POINTER :: sab_nl TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: fmwork - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_density_transform', & routineP = moduleN//':'//routineN @@ -960,18 +944,17 @@ SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork,er ! work storage ALLOCATE(rpmat,cpmat,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(rpmat,error=error) - CALL cp_dbcsr_init(cpmat,error=error) - CALL cp_dbcsr_create(rpmat,template=tempmat,matrix_type=dbcsr_type_symmetric,error=error) - CALL cp_dbcsr_create(cpmat,template=tempmat,matrix_type=dbcsr_type_antisymmetric,error=error) - CALL cp_dbcsr_alloc_block_from_nbl(rpmat,sab_nl,error) - CALL cp_dbcsr_alloc_block_from_nbl(cpmat,sab_nl,error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(rpmat) + CALL cp_dbcsr_init(cpmat) + CALL cp_dbcsr_create(rpmat,template=tempmat,matrix_type=dbcsr_type_symmetric) + CALL cp_dbcsr_create(cpmat,template=tempmat,matrix_type=dbcsr_type_antisymmetric) + CALL cp_dbcsr_alloc_block_from_nbl(rpmat,sab_nl) + CALL cp_dbcsr_alloc_block_from_nbl(cpmat,sab_nl) CALL get_kpoint_info(kpoint,nkp=nkp,xkp=xkp,wkp=wkp,& para_env_inter_kp=para_env_inter_kp,& - sab_nl=sab_nl,cell_to_index=cell_to_index,& - error=error) + sab_nl=sab_nl,cell_to_index=cell_to_index) ! initialize real space density matrices kp => kpoint%kp_env(1)%kpoint_env nspin = SIZE(kp%mos,2) @@ -982,7 +965,7 @@ SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork,er NULLIFY(fmdummy) DO ispin=1,nspin DO ic=1,nimg - CALL cp_dbcsr_set(denmat(ispin,ic)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(denmat(ispin,ic)%matrix,0.0_dp) END DO ! DO ik=1,nkp @@ -994,26 +977,26 @@ SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork,er NULLIFY(kp) END IF ! collect this density matrix on all processors - CPPrecondition(SIZE(fmwork)>=nc,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(fmwork)>=nc,cp_failure_level,routineP,failure) DO ic=1,nc IF(my_kpgrp) THEN ! choose density matrix IF(wtype) THEN - CALL cp_fm_copy_general(kp%wmat(ic,ispin)%matrix,fmwork(ic)%matrix,bcntxt,error) + CALL cp_fm_copy_general(kp%wmat(ic,ispin)%matrix,fmwork(ic)%matrix,bcntxt) ELSE - CALL cp_fm_copy_general(kp%pmat(ic,ispin)%matrix,fmwork(ic)%matrix,bcntxt,error) + CALL cp_fm_copy_general(kp%pmat(ic,ispin)%matrix,fmwork(ic)%matrix,bcntxt) END IF ELSE - CALL cp_fm_copy_general(fmdummy,fmwork(ic)%matrix,bcntxt,error) + CALL cp_fm_copy_general(fmdummy,fmwork(ic)%matrix,bcntxt) END IF END DO ! reduce to dbcsr storage IF(real_only) THEN - CALL copy_fm_to_dbcsr(fmwork(1)%matrix,rpmat,keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(fmwork(1)%matrix,rpmat,keep_sparsity=.TRUE.) ELSE - CALL copy_fm_to_dbcsr(fmwork(1)%matrix,rpmat,keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(fmwork(1)%matrix,rpmat,keep_sparsity=.TRUE.) ! it seems this copy to a antisymmetric dbcsr matrix changes sign! - CALL copy_fm_to_dbcsr(fmwork(2)%matrix,cpmat,keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(fmwork(2)%matrix,cpmat,keep_sparsity=.TRUE.) END IF ! transformation @@ -1039,20 +1022,20 @@ SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork,er CALL cp_dbcsr_get_block_p(matrix=denmat(ispin,icell)%matrix,row=irow,col=icol,& block=dblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) IF(real_only) THEN CALL cp_dbcsr_get_block_p(matrix=rpmat,row=irow,col=icol,& block=rblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) dblock = dblock + coskl*rblock ELSE CALL cp_dbcsr_get_block_p(matrix=rpmat,row=irow,col=icol,& block=rblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=cpmat,row=irow,col=icol,& block=cblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) dblock = dblock + coskl*rblock dblock = dblock + sinkl*cblock END IF @@ -1062,8 +1045,8 @@ SUBROUTINE kpoint_density_transform(kpoint,denmat,wtype,tempmat,sab_nl,fmwork,er END DO END DO - CALL cp_dbcsr_deallocate_matrix(rpmat,error) - CALL cp_dbcsr_deallocate_matrix(cpmat,error) + CALL cp_dbcsr_deallocate_matrix(rpmat) + CALL cp_dbcsr_deallocate_matrix(cpmat) END SUBROUTINE kpoint_density_transform diff --git a/src/kpoint_transitional.F b/src/kpoint_transitional.F index df50686ea5..ec71a8070b 100644 --- a/src/kpoint_transitional.F +++ b/src/kpoint_transitional.F @@ -115,18 +115,16 @@ END SUBROUTINE set_2d_pointer ! ***************************************************************************** !> \brief Release the matrix set, using the right pointer !> \param this ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE kpoint_transitional_release(this, error) + SUBROUTINE kpoint_transitional_release(this) TYPE(kpoint_transitional_type) :: this - TYPE(cp_error_type), INTENT(inout) :: error IF (ASSOCIATED(this%ptr_1d)) THEN IF (this%set_as_1d) THEN - CALL cp_dbcsr_deallocate_matrix_set(this%ptr_1d, error) + CALL cp_dbcsr_deallocate_matrix_set(this%ptr_1d) ELSE - CALL cp_dbcsr_deallocate_matrix_set(this%ptr_2d, error) + CALL cp_dbcsr_deallocate_matrix_set(this%ptr_2d) ENDIF ENDIF NULLIFY(this%ptr_1d, this%ptr_2d) diff --git a/src/kpoint_types.F b/src/kpoint_types.F index 35ab6452a1..5f46e23086 100644 --- a/src/kpoint_types.F +++ b/src/kpoint_types.F @@ -148,12 +148,10 @@ MODULE kpoint_types ! ***************************************************************************** !> \brief Create a kpoint environment !> \param kpoint All the kpoint information -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** - SUBROUTINE kpoint_create(kpoint, error) + SUBROUTINE kpoint_create(kpoint) TYPE(kpoint_type), POINTER :: kpoint - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_create', & routineP = moduleN//':'//routineN @@ -163,10 +161,10 @@ SUBROUTINE kpoint_create(kpoint, error) failure=.FALSE. - CPAssert(.NOT.ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.ASSOCIATED(kpoint),cp_failure_level,routineP,failure) ALLOCATE(kpoint,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) kpoint%kp_scheme = "" kpoint%nkp_grid = 0 @@ -203,12 +201,10 @@ END SUBROUTINE kpoint_create ! ***************************************************************************** !> \brief Release a kpoint environment, deallocate all data !> \param kpoint The kpoint environment -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** - SUBROUTINE kpoint_release(kpoint, error) + SUBROUTINE kpoint_release(kpoint) TYPE(kpoint_type), POINTER :: kpoint - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_release', & routineP = moduleN//':'//routineN @@ -222,41 +218,41 @@ SUBROUTINE kpoint_release(kpoint, error) IF(ASSOCIATED(kpoint%xkp)) THEN DEALLOCATE(kpoint%xkp,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(kpoint%xkp) END IF IF(ASSOCIATED(kpoint%wkp)) THEN DEALLOCATE(kpoint%wkp,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(kpoint%wkp) END IF IF(ASSOCIATED(kpoint%kp_dist)) THEN DEALLOCATE(kpoint%kp_dist,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) ENDIF - CALL mpools_release(kpoint%mpools, error=error) - CALL cp_blacs_env_release(kpoint%blacs_env,error=error) - CALL cp_blacs_env_release(kpoint%blacs_env_all,error=error) + CALL mpools_release(kpoint%mpools) + CALL cp_blacs_env_release(kpoint%blacs_env) + CALL cp_blacs_env_release(kpoint%blacs_env_all) - CALL cp_cart_release(kpoint%cart,error=error) - CALL cp_para_env_release(kpoint%para_env,error=error) - CALL cp_para_env_release(kpoint%para_env_full,error=error) - CALL cp_para_env_release(kpoint%para_env_kp,error=error) - CALL cp_para_env_release(kpoint%para_env_inter_kp,error=error) + CALL cp_cart_release(kpoint%cart) + CALL cp_para_env_release(kpoint%para_env) + CALL cp_para_env_release(kpoint%para_env_full) + CALL cp_para_env_release(kpoint%para_env_kp) + CALL cp_para_env_release(kpoint%para_env_inter_kp) IF(ASSOCIATED(kpoint%cell_to_index)) DEALLOCATE(kpoint%cell_to_index) IF(ASSOCIATED(kpoint%kp_env)) THEN DO ik=1,SIZE(kpoint%kp_env) - CALL kpoint_env_release(kpoint%kp_env(ik)%kpoint_env,error) + CALL kpoint_env_release(kpoint%kp_env(ik)%kpoint_env) END DO DEALLOCATE(kpoint%kp_env,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF DEALLOCATE(kpoint,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(kpoint) END IF @@ -295,14 +291,12 @@ END SUBROUTINE kpoint_release !> \param kp_dist kpoints distribution on groups !> \param cell_to_index given a cell triple, returns the real space index !> \param sab_nl neighbourlist that defines real space matrices -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** SUBROUTINE get_kpoint_info(kpoint, kp_scheme, nkp_grid, kp_shift, symmetry, verbose,& full_grid, use_real_wfn, eps_geo, parallel_group_size, kp_range, nkp, xkp, wkp,& para_env, blacs_env_all, cart, para_env_full, para_env_kp, para_env_inter_kp, blacs_env,& - kp_env, mpools, iogrp, nkp_groups, kp_dist, cell_to_index, sab_nl,& - error) + kp_env, mpools, iogrp, nkp_groups, kp_dist, cell_to_index, sab_nl) TYPE(kpoint_type), POINTER :: kpoint CHARACTER(LEN=*), OPTIONAL :: kp_scheme INTEGER, DIMENSION(3), OPTIONAL :: nkp_grid @@ -340,7 +334,6 @@ SUBROUTINE get_kpoint_info(kpoint, kp_scheme, nkp_grid, kp_shift, symmetry, verb POINTER :: cell_to_index TYPE(neighbor_list_set_p_type), & DIMENSION(:), OPTIONAL, POINTER :: sab_nl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_kpoint_info', & routineP = moduleN//':'//routineN @@ -349,7 +342,7 @@ SUBROUTINE get_kpoint_info(kpoint, kp_scheme, nkp_grid, kp_shift, symmetry, verb failure=.FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) IF(PRESENT(kp_scheme)) kp_scheme = kpoint%kp_scheme IF(PRESENT(nkp_grid)) nkp_grid = kpoint%nkp_grid @@ -419,14 +412,12 @@ END SUBROUTINE get_kpoint_info !> \param kp_dist kpoints distribution on groups !> \param cell_to_index given a cell triple, returns the real space index !> \param sab_nl neighbourlist that defines real space matrices -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** SUBROUTINE set_kpoint_info(kpoint, kp_scheme, nkp_grid, kp_shift, symmetry, verbose,& full_grid, use_real_wfn, eps_geo, parallel_group_size, kp_range, nkp, xkp, wkp,& para_env, blacs_env_all, cart, para_env_full, para_env_kp, para_env_inter_kp, blacs_env,& - kp_env, mpools, iogrp, nkp_groups, kp_dist, cell_to_index, sab_nl,& - error) + kp_env, mpools, iogrp, nkp_groups, kp_dist, cell_to_index, sab_nl) TYPE(kpoint_type), POINTER :: kpoint CHARACTER(LEN=*), OPTIONAL :: kp_scheme INTEGER, DIMENSION(3), OPTIONAL :: nkp_grid @@ -464,7 +455,6 @@ SUBROUTINE set_kpoint_info(kpoint, kp_scheme, nkp_grid, kp_shift, symmetry, verb POINTER :: cell_to_index TYPE(neighbor_list_set_p_type), & DIMENSION(:), OPTIONAL, POINTER :: sab_nl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_kpoint_info', & routineP = moduleN//':'//routineN @@ -473,7 +463,7 @@ SUBROUTINE set_kpoint_info(kpoint, kp_scheme, nkp_grid, kp_shift, symmetry, verb failure=.FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) IF(PRESENT(kp_scheme)) kpoint%kp_scheme = kp_scheme IF(PRESENT(nkp_grid)) kpoint%nkp_grid = nkp_grid @@ -517,13 +507,11 @@ END SUBROUTINE set_kpoint_info !> \brief Read the kpoint input section !> \param kpoint The kpoint environment !> \param kpoint_section The input section -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** - SUBROUTINE read_kpoint_section(kpoint,kpoint_section,error) + SUBROUTINE read_kpoint_section(kpoint,kpoint_section) TYPE(kpoint_type), POINTER :: kpoint TYPE(section_vals_type), POINTER :: kpoint_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_kpoint_section', & routineP = moduleN//':'//routineN @@ -535,14 +523,14 @@ SUBROUTINE read_kpoint_section(kpoint,kpoint_section,error) REAL(KIND=dp), DIMENSION(:), POINTER :: reallist failure = .FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) - CALL section_vals_get(kpoint_section,explicit=available, error=error) + CALL section_vals_get(kpoint_section,explicit=available) IF (available) THEN - CALL section_vals_val_get(kpoint_section,"SCHEME",c_vals=tmpstringlist,error=error) + CALL section_vals_val_get(kpoint_section,"SCHEME",c_vals=tmpstringlist) nval = SIZE(tmpstringlist) - CPPrecondition(nval >= 1, cp_failure_level, routineP, error, failure) + CPPrecondition(nval >= 1, cp_failure_level, routineP,failure) kpoint%kp_scheme = tmpstringlist(1) CALL uppercase(kpoint%kp_scheme) @@ -553,12 +541,12 @@ SUBROUTINE read_kpoint_section(kpoint,kpoint_section,error) CASE ("GAMMA") ! do nothing CASE ("MONKHORST-PACK") - CPPrecondition(nval >= 4, cp_failure_level, routineP, error, failure) + CPPrecondition(nval >= 4, cp_failure_level, routineP,failure) DO i=2,4 READ(tmpstringlist(i),*) kpoint%nkp_grid(i-1) END DO CASE ("MACDONALD") - CPPrecondition(nval >= 7, cp_failure_level, routineP, error, failure) + CPPrecondition(nval >= 7, cp_failure_level, routineP,failure) DO i=2,4 READ(tmpstringlist(i),*) kpoint%nkp_grid(i-1) END DO @@ -566,36 +554,36 @@ SUBROUTINE read_kpoint_section(kpoint,kpoint_section,error) READ(tmpstringlist(i),*) kpoint%kp_shift(i-4) END DO CASE ("GENERAL") - CALL section_vals_val_get(kpoint_section,"KPOINT", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(kpoint_section,"KPOINT", n_rep_val=n_rep) kpoint%nkp = n_rep ALLOCATE(kpoint%xkp(3,n_rep),kpoint%wkp(n_rep),STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) DO i=1,n_rep CALL section_vals_val_get(kpoint_section,"KPOINT", i_rep_val=i,& - r_vals=reallist, error=error) + r_vals=reallist) nval = SIZE(reallist) - CPPostcondition(nval>=4, cp_failure_level, routineP, error, failure) + CPPostcondition(nval>=4, cp_failure_level, routineP,failure) kpoint%xkp(1:3,i) = reallist(1:3) kpoint%wkp(i) = reallist(4) END DO CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT - CALL section_vals_val_get(kpoint_section,"SYMMETRY",l_val=kpoint%symmetry,error=error) - CALL section_vals_val_get(kpoint_section,"WAVEFUNCTIONS",i_val=wfntype,error=error) - CALL section_vals_val_get(kpoint_section,"VERBOSE",l_val=kpoint%verbose,error=error) - CALL section_vals_val_get(kpoint_section,"FULL_GRID",l_val=kpoint%full_grid,error=error) - CALL section_vals_val_get(kpoint_section,"EPS_GEO",r_val=kpoint%eps_geo,error=error) + CALL section_vals_val_get(kpoint_section,"SYMMETRY",l_val=kpoint%symmetry) + CALL section_vals_val_get(kpoint_section,"WAVEFUNCTIONS",i_val=wfntype) + CALL section_vals_val_get(kpoint_section,"VERBOSE",l_val=kpoint%verbose) + CALL section_vals_val_get(kpoint_section,"FULL_GRID",l_val=kpoint%full_grid) + CALL section_vals_val_get(kpoint_section,"EPS_GEO",r_val=kpoint%eps_geo) CALL section_vals_val_get(kpoint_section,"PARALLEL_GROUP_SIZE",& - i_val=kpoint%parallel_group_size,error=error) + i_val=kpoint%parallel_group_size) SELECT CASE (wfntype) CASE (use_real_wfn) kpoint%use_real_wfn = .TRUE. CASE (use_complex_wfn) kpoint%use_real_wfn = .FALSE. CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT ELSE @@ -608,13 +596,11 @@ END SUBROUTINE read_kpoint_section !> \brief Write information on the kpoints to output !> \param kpoint The kpoint environment !> \param dft_section DFT section information -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** - SUBROUTINE write_kpoint_info(kpoint,dft_section,error) + SUBROUTINE write_kpoint_info(kpoint,dft_section) TYPE(kpoint_type), POINTER :: kpoint TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_kpoint_info', & routineP = moduleN//':'//routineN @@ -624,13 +610,13 @@ SUBROUTINE write_kpoint_info(kpoint,dft_section,error) TYPE(cp_logger_type), POINTER :: logger failure = .FALSE. - CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint),cp_failure_level,routineP,failure) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - punit = cp_print_key_unit_nr(logger,dft_section,"PRINT%KPOINTS",extension=".Log",error=error) + punit = cp_print_key_unit_nr(logger,dft_section,"PRINT%KPOINTS",extension=".Log") IF (punit>0) THEN IF(kpoint%kp_scheme /= "NONE") THEN @@ -653,7 +639,7 @@ SUBROUTINE write_kpoint_info(kpoint,dft_section,error) CASE ("GENERAL") WRITE (punit,'(A,T71,A10)') ' BRILLOUIN| K-point scheme ',' General' CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT IF(kpoint%kp_scheme /= "NONE") THEN IF (kpoint%symmetry) THEN @@ -682,19 +668,17 @@ SUBROUTINE write_kpoint_info(kpoint,dft_section,error) END IF END IF - CALL cp_print_key_finished_output(punit,logger,dft_section,"PRINT%KPOINTS",error=error) + CALL cp_print_key_finished_output(punit,logger,dft_section,"PRINT%KPOINTS") END SUBROUTINE write_kpoint_info ! ***************************************************************************** !> \brief Create a single kpoint environment !> \param kp_env Single kpoint environment -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** - SUBROUTINE kpoint_env_create(kp_env, error) + SUBROUTINE kpoint_env_create(kp_env) TYPE(kpoint_env_type), POINTER :: kp_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_env_create', & routineP = moduleN//':'//routineN @@ -704,10 +688,10 @@ SUBROUTINE kpoint_env_create(kp_env, error) failure=.FALSE. - CPAssert(.NOT.ASSOCIATED(kp_env),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.ASSOCIATED(kp_env),cp_failure_level,routineP,failure) ALLOCATE(kp_env,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) kp_env%nkpoint = 0 kp_env%wkp = 0.0_dp @@ -723,12 +707,10 @@ END SUBROUTINE kpoint_env_create ! ***************************************************************************** !> \brief Release a single kpoint environment !> \param kp_env Single kpoint environment -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** - SUBROUTINE kpoint_env_release(kp_env, error) + SUBROUTINE kpoint_env_release(kp_env) TYPE(kpoint_env_type), POINTER :: kp_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_env_release', & routineP = moduleN//':'//routineN @@ -743,35 +725,35 @@ SUBROUTINE kpoint_env_release(kp_env, error) IF(ASSOCIATED(kp_env%mos)) THEN DO is=1,SIZE(kp_env%mos,2) DO ic=1,SIZE(kp_env%mos,1) - CALL deallocate_mo_set(kp_env%mos(ic,is)%mo_set,error) + CALL deallocate_mo_set(kp_env%mos(ic,is)%mo_set) END DO END DO DEALLOCATE(kp_env%mos,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF(ASSOCIATED(kp_env%pmat)) THEN DO is=1,SIZE(kp_env%pmat,2) DO ic=1,SIZE(kp_env%pmat,1) - CALL cp_fm_release(kp_env%pmat(ic,is)%matrix,error) + CALL cp_fm_release(kp_env%pmat(ic,is)%matrix) END DO END DO DEALLOCATE(kp_env%pmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF IF(ASSOCIATED(kp_env%wmat)) THEN DO is=1,SIZE(kp_env%wmat,2) DO ic=1,SIZE(kp_env%wmat,1) - CALL cp_fm_release(kp_env%wmat(ic,is)%matrix,error) + CALL cp_fm_release(kp_env%wmat(ic,is)%matrix) END DO END DO DEALLOCATE(kp_env%wmat,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) END IF DEALLOCATE(kp_env,STAT=ierr) - CPPostcondition(ierr==0, cp_failure_level, routineP, error, failure) + CPPostcondition(ierr==0, cp_failure_level, routineP,failure) NULLIFY(kp_env) END IF @@ -786,10 +768,9 @@ END SUBROUTINE kpoint_env_release !> \param xkp Coordinates of kpoint !> \param is_local Is this kpoint local (single cpu group) !> \param mos MOs of this kpoint -!> \param error CP2K error handling !> \author JGH ! ***************************************************************************** - SUBROUTINE get_kpoint_env(kpoint_env, nkpoint, wkp, xkp, is_local, mos, error) + SUBROUTINE get_kpoint_env(kpoint_env, nkpoint, wkp, xkp, is_local, mos) TYPE(kpoint_env_type), POINTER :: kpoint_env INTEGER, OPTIONAL :: nkpoint REAL(KIND=dp), OPTIONAL :: wkp @@ -797,7 +778,6 @@ SUBROUTINE get_kpoint_env(kpoint_env, nkpoint, wkp, xkp, is_local, mos, error) LOGICAL, OPTIONAL :: is_local TYPE(mo_set_p_type), DIMENSION(:, :), & OPTIONAL, POINTER :: mos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_kpoint_env', & routineP = moduleN//':'//routineN @@ -806,7 +786,7 @@ SUBROUTINE get_kpoint_env(kpoint_env, nkpoint, wkp, xkp, is_local, mos, error) failure=.FALSE. - CPAssert(ASSOCIATED(kpoint_env),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(kpoint_env),cp_failure_level,routineP,failure) IF(PRESENT(nkpoint)) nkpoint = kpoint_env%nkpoint IF(PRESENT(wkp)) wkp = kpoint_env%wkp diff --git a/src/library_tests.F b/src/library_tests.F index a00f428f16..b8ff2d4fda 100644 --- a/src/library_tests.F +++ b/src/library_tests.F @@ -124,17 +124,15 @@ MODULE library_tests !> \param root_section ... !> \param para_env ... !> \param globenv ... -!> \param error ... !> \par History !> none !> \author JGH 6-NOV-2000 ! ***************************************************************************** - SUBROUTINE lib_test ( root_section, para_env, globenv, error ) + SUBROUTINE lib_test ( root_section, para_env, globenv) TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lib_test', & routineP = moduleN//':'//routineN @@ -148,8 +146,8 @@ SUBROUTINE lib_test ( root_section, para_env, globenv, error ) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) - iw=cp_print_key_unit_nr(logger,root_section,"TEST%PROGRAM_RUN_INFO",extension=".log",error=error) + logger => cp_get_default_logger() + iw=cp_print_key_unit_nr(logger,root_section,"TEST%PROGRAM_RUN_INFO",extension=".log") IF ( iw > 0 ) THEN WRITE ( iw, '(T2,79("*"))' ) @@ -157,7 +155,7 @@ SUBROUTINE lib_test ( root_section, para_env, globenv, error ) WRITE ( iw, '(T2,79("*"))' ) END IF ! - CALL test_input ( root_section, para_env, error=error) + CALL test_input ( root_section, para_env) ! IF ( runtest ( 1 ) /= 0 ) CALL copy_test ( para_env, iw) ! @@ -165,54 +163,53 @@ SUBROUTINE lib_test ( root_section, para_env, globenv, error ) IF ( runtest ( 5 ) /= 0 ) CALL matmul_test ( para_env,test_matmul=.FALSE.,test_dgemm=.TRUE.,iw=iw) ! IF ( runtest ( 3 ) /= 0 ) CALL fft_test ( para_env, iw, globenv%fftw_plan_type, & - globenv%fftw_wisdom_file_name, & - error=error ) + globenv%fftw_wisdom_file_name) ! - IF ( runtest ( 4 ) /= 0 ) CALL eri_test ( iw, error ) + IF ( runtest ( 4 ) /= 0 ) CALL eri_test ( iw) ! - IF ( runtest ( 6 ) /= 0 ) CALL clebsch_gordon_test ( error ) + IF ( runtest ( 6 ) /= 0 ) CALL clebsch_gordon_test () ! ! runtest 7 has been deleted and can be recycled ! IF ( runtest ( 8 ) /= 0 ) CALL mpi_perf_test ( para_env%group, runtest ( 8 ), iw ) ! - IF ( runtest ( 9 ) /= 0 ) CALL rng_test( para_env, iw, error) + IF ( runtest ( 9 ) /= 0 ) CALL rng_test( para_env, iw) ! - rs_pw_transfer_section => section_vals_get_subs_vals(root_section,"TEST%RS_PW_TRANSFER",error=error) - CALL section_vals_get(rs_pw_transfer_section,explicit=explicit, error=error) + rs_pw_transfer_section => section_vals_get_subs_vals(root_section,"TEST%RS_PW_TRANSFER") + CALL section_vals_get(rs_pw_transfer_section,explicit=explicit) IF (explicit) THEN - CALL rs_pw_transfer_test ( para_env, iw, globenv, rs_pw_transfer_section, error ) + CALL rs_pw_transfer_test ( para_env, iw, globenv, rs_pw_transfer_section) ENDIF - pw_transfer_section => section_vals_get_subs_vals(root_section,"TEST%PW_TRANSFER",error=error) - CALL section_vals_get(pw_transfer_section,explicit=explicit, error=error) + pw_transfer_section => section_vals_get_subs_vals(root_section,"TEST%PW_TRANSFER") + CALL section_vals_get(pw_transfer_section,explicit=explicit) IF (explicit) THEN - CALL pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) + CALL pw_fft_test ( para_env, iw, globenv, pw_transfer_section) ENDIF - cp_fm_gemm_test_section => section_vals_get_subs_vals(root_section,"TEST%CP_FM_GEMM",error=error) - CALL section_vals_get(cp_fm_gemm_test_section,explicit=explicit, error=error) + cp_fm_gemm_test_section => section_vals_get_subs_vals(root_section,"TEST%CP_FM_GEMM") + CALL section_vals_get(cp_fm_gemm_test_section,explicit=explicit) IF (explicit) THEN - CALL cp_fm_gemm_test ( para_env, iw, cp_fm_gemm_test_section, error ) + CALL cp_fm_gemm_test ( para_env, iw, cp_fm_gemm_test_section) ENDIF - eigensolver_section => section_vals_get_subs_vals(root_section,"TEST%EIGENSOLVER",error=error) - CALL section_vals_get(eigensolver_section,explicit=explicit, error=error) + eigensolver_section => section_vals_get_subs_vals(root_section,"TEST%EIGENSOLVER") + CALL section_vals_get(eigensolver_section,explicit=explicit) IF (explicit) THEN - CALL eigensolver_test( para_env, iw,eigensolver_section,error=error ) + CALL eigensolver_test( para_env, iw,eigensolver_section) ENDIF ! DBCSR tests ! matrix_multiplication cp_dbcsr_test_section => section_vals_get_subs_vals(root_section,& - "TEST%CP_DBCSR", error=error) - CALL section_vals_get(cp_dbcsr_test_section, explicit=explicit, error=error) + "TEST%CP_DBCSR") + CALL section_vals_get(cp_dbcsr_test_section, explicit=explicit) IF (explicit) THEN - CALL cp_dbcsr_tests (para_env, iw, cp_dbcsr_test_section, error) + CALL cp_dbcsr_tests (para_env, iw, cp_dbcsr_test_section) ENDIF - CALL cp_print_key_finished_output(iw,logger,root_section,"TEST%PROGRAM_RUN_INFO", error=error) + CALL cp_print_key_finished_output(iw,logger,root_section,"TEST%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -222,7 +219,6 @@ END SUBROUTINE lib_test !> \brief Reads input section &TEST ... &END !> \param root_section ... !> \param para_env ... -!> \param error ... !> \author JGH 30-NOV-2000 !> \note !> I---------------------------------------------------------------------------I @@ -240,10 +236,9 @@ END SUBROUTINE lib_test !> I RNG n -> Parallel random number generator I !> I---------------------------------------------------------------------------I ! ***************************************************************************** - SUBROUTINE test_input ( root_section, para_env, error) + SUBROUTINE test_input ( root_section, para_env) TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'test_input', & routineP = moduleN//':'//routineN @@ -255,16 +250,16 @@ SUBROUTINE test_input ( root_section, para_env, error) ! using this style is not recommended, introduce sections instead (see e.g. cp_fm_gemm) runtest = 0 - test_section => section_vals_get_subs_vals(root_section,"TEST",error=error) - CALL section_vals_val_get(test_section,"MEMORY",r_val=max_memory,error=error) - CALL section_vals_val_get(test_section,'COPY',i_val=runtest(1),error=error ) - CALL section_vals_val_get(test_section,'MATMUL',i_val=runtest(2),error=error ) - CALL section_vals_val_get(test_section,'DGEMM',i_val=runtest(5),error=error ) - CALL section_vals_val_get(test_section,'FFT',i_val=runtest(3),error=error ) - CALL section_vals_val_get(test_section,'ERI',i_val=runtest(4),error=error ) - CALL section_vals_val_get(test_section,'CLEBSCH_GORDON',i_val=runtest(6),error=error ) - CALL section_vals_val_get(test_section,'MPI',i_val=runtest (8),error=error ) - CALL section_vals_val_get(test_section,'RNG',i_val=runtest(9),error=error ) + test_section => section_vals_get_subs_vals(root_section,"TEST") + CALL section_vals_val_get(test_section,"MEMORY",r_val=max_memory) + CALL section_vals_val_get(test_section,'COPY',i_val=runtest(1)) + CALL section_vals_val_get(test_section,'MATMUL',i_val=runtest(2)) + CALL section_vals_val_get(test_section,'DGEMM',i_val=runtest(5)) + CALL section_vals_val_get(test_section,'FFT',i_val=runtest(3)) + CALL section_vals_val_get(test_section,'ERI',i_val=runtest(4)) + CALL section_vals_val_get(test_section,'CLEBSCH_GORDON',i_val=runtest(6)) + CALL section_vals_val_get(test_section,'MPI',i_val=runtest (8)) + CALL section_vals_val_get(test_section,'RNG',i_val=runtest(9)) CALL mp_sync(para_env%group) END SUBROUTINE test_input @@ -567,17 +562,15 @@ END SUBROUTINE matmul_test !> \param iw ... !> \param fftw_plan_type ... !> \param wisdom_file where FFTW3 should look to save/load wisdom -!> \param error ... !> \par History !> none !> \author JGH 6-NOV-2000 ! ***************************************************************************** - SUBROUTINE fft_test ( para_env, iw, fftw_plan_type, wisdom_file, error ) + SUBROUTINE fft_test ( para_env, iw, fftw_plan_type, wisdom_file) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: iw, fftw_plan_type CHARACTER(LEN=*), INTENT(IN) :: wisdom_file - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: iall, ierr, it, j, len, n(3), & ntim, radix_in, radix_out, & @@ -606,15 +599,13 @@ SUBROUTINE fft_test ( para_env, iw, fftw_plan_type, wisdom_file, error ) EXIT CASE ( 1 ) CALL init_fft ( "FFTSG", alltoall=.FALSE., fftsg_sizes=.TRUE., wisdom_file=wisdom_file, & - pool_limit=10, plan_style=fftw_plan_type, & - error=error ) + pool_limit=10, plan_style=fftw_plan_type) method = "FFTSG " CASE ( 2 ) CYCLE CASE ( 3 ) CALL init_fft ( "FFTW3", alltoall=.FALSE., fftsg_sizes=.TRUE., wisdom_file=wisdom_file, & - pool_limit=10, plan_style=fftw_plan_type, & - error=error ) + pool_limit=10, plan_style=fftw_plan_type) method = "FFTW3 " END SELECT n = 4 @@ -722,7 +713,7 @@ SUBROUTINE fft_test ( para_env, iw, fftw_plan_type, wisdom_file, error ) DEALLOCATE ( cc , STAT = ierr ) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"cc") END IF - CALL finalize_fft(para_env, wisdom_file=wisdom_file,error=error) + CALL finalize_fft(para_env, wisdom_file=wisdom_file) END DO END SUBROUTINE fft_test @@ -733,18 +724,16 @@ END SUBROUTINE fft_test !> \param iw ... !> \param globenv ... !> \param rs_pw_transfer_section ... -!> \param error ... !> \author Joost VandeVondele !> 9.2008 Randomise rs grid [Iain Bethune] !> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project ! ***************************************************************************** - SUBROUTINE rs_pw_transfer_test ( para_env, iw, globenv, rs_pw_transfer_section, error ) + SUBROUTINE rs_pw_transfer_test ( para_env, iw, globenv, rs_pw_transfer_section) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: iw TYPE(global_environment_type), POINTER :: globenv TYPE(section_vals_type), POINTER :: rs_pw_transfer_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rs_pw_transfer_test', & routineP = moduleN//':'//routineN @@ -769,48 +758,47 @@ SUBROUTINE rs_pw_transfer_test ( para_env, iw, globenv, rs_pw_transfer_section, CALL init_fft ( globenv%default_fft_library, alltoall=.FALSE., fftsg_sizes=.TRUE., & pool_limit=globenv%fft_pool_scratch_limit,& wisdom_file=globenv%fftw_wisdom_file_name, & - plan_style=globenv%fftw_plan_type,& - error=error ) + plan_style=globenv%fftw_plan_type) ! .. set cell (should otherwise be irrelevant) NULLIFY(box) - CALL cell_create(box,error=error) + CALL cell_create(box) box % hmat = RESHAPE ( (/20.0_dp,0.0_dp,0.0_dp,0.0_dp,20.0_dp,0.0_dp,& 0.0_dp,0.0_dp,20.0_dp/), (/3,3/) ) CALL init_cell ( box ) ! .. grid type and pw_grid NULLIFY(grid) - CALL section_vals_val_get(rs_pw_transfer_section,"GRID",i_vals=i_vals,error=error ) + CALL section_vals_val_get(rs_pw_transfer_section,"GRID",i_vals=i_vals) np = i_vals - CALL pw_grid_create ( grid, para_env%group ,error=error) - CALL pw_grid_setup ( box%hmat, grid, grid_span=FULLSPACE, npts=np, fft_usage=.TRUE., iounit=iw, error=error) + CALL pw_grid_create ( grid, para_env%group) + CALL pw_grid_setup ( box%hmat, grid, grid_span=FULLSPACE, npts=np, fft_usage=.TRUE., iounit=iw) no = grid % npts NULLIFY(ca%pw) - CALL pw_create ( ca%pw, grid, REALDATA3D ,error=error) + CALL pw_create ( ca%pw, grid, REALDATA3D) ca % pw % in_space = REALSPACE - CALL pw_zero(ca%pw,error=error) + CALL pw_zero(ca%pw) ! .. rs input setting type - CALL section_vals_val_get(rs_pw_transfer_section,"HALO_SIZE",i_val=halo_size,error=error ) - rs_grid_section => section_vals_get_subs_vals(rs_pw_transfer_section,"RS_GRID",error=error) + CALL section_vals_val_get(rs_pw_transfer_section,"HALO_SIZE",i_val=halo_size) + rs_grid_section => section_vals_get_subs_vals(rs_pw_transfer_section,"RS_GRID") ns_max=2*halo_size+1 - CALL init_input_type(input_settings,ns_max,rs_grid_section,1,(/-1,-1,-1/),error) + CALL init_input_type(input_settings,ns_max,rs_grid_section,1,(/-1,-1,-1/)) ! .. rs type NULLIFY(rs_grid) NULLIFY(rs_desc) - CALL rs_grid_create_descriptor(rs_desc,pw_grid=grid, input_settings=input_settings,error=error) - CALL rs_grid_create(rs_grid,rs_desc,error=error) - CALL rs_grid_print(rs_grid,iw,error=error) + CALL rs_grid_create_descriptor(rs_desc,pw_grid=grid, input_settings=input_settings) + CALL rs_grid_create(rs_grid,rs_desc) + CALL rs_grid_print(rs_grid,iw) CALL rs_grid_zero(rs_grid) ! Put random values on the grid, so summation check will pick up errors CALL RANDOM_NUMBER(rs_grid % r) - CALL section_vals_val_get(rs_pw_transfer_section,"N_loop",i_val=N_loop,error=error ) - CALL section_vals_val_get(rs_pw_transfer_section,"RS2PW",l_val=do_rs2pw,error=error ) + CALL section_vals_val_get(rs_pw_transfer_section,"N_loop",i_val=N_loop) + CALL section_vals_val_get(rs_pw_transfer_section,"RS2PW",l_val=do_rs2pw) IF (do_rs2pw) THEN dir=rs2pw ELSE @@ -827,7 +815,7 @@ SUBROUTINE rs_pw_transfer_test ( para_env, iw, globenv, rs_pw_transfer_section, DO i_loop=1,N_loop CALL mp_sync(para_env%group) tstart=m_walltime() - CALL rs_pw_transfer ( rs_grid, ca%pw, dir,error=error) + CALL rs_pw_transfer ( rs_grid, ca%pw, dir) CALL mp_sync(para_env%group) tend=m_walltime() IF (para_env%ionode) THEN @@ -836,13 +824,12 @@ SUBROUTINE rs_pw_transfer_test ( para_env, iw, globenv, rs_pw_transfer_section, ENDDO !cleanup - CALL rs_grid_release(rs_grid,error=error) - CALL rs_grid_release_descriptor(rs_desc, error=error) - CALL pw_release ( ca%pw ,error=error) - CALL pw_grid_release ( grid ,error=error) - CALL cell_release(box,error=error) - CALL finalize_fft(para_env,wisdom_file=globenv%fftw_wisdom_file_name,& - error=error) + CALL rs_grid_release(rs_grid) + CALL rs_grid_release_descriptor(rs_desc) + CALL pw_release ( ca%pw) + CALL pw_grid_release ( grid) + CALL cell_release(box) + CALL finalize_fft(para_env,wisdom_file=globenv%fftw_wisdom_file_name) CALL timestop(handle) @@ -854,19 +841,17 @@ END SUBROUTINE rs_pw_transfer_test !> \param iw ... !> \param globenv ... !> \param pw_transfer_section ... -!> \param error ... !> \par History !> JGH 6-Feb-2001 : Test and performance code !> Made input sensitive [Joost VandeVondele] !> \author JGH 1-JAN-2001 ! ***************************************************************************** - SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) + SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: iw TYPE(global_environment_type), POINTER :: globenv TYPE(section_vals_type), POINTER :: pw_transfer_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_fft_test', & routineP = moduleN//':'//routineN @@ -893,33 +878,32 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) CALL init_fft ( globenv%default_fft_library, alltoall=.FALSE., fftsg_sizes=.TRUE., & pool_limit=globenv%fft_pool_scratch_limit,& wisdom_file=globenv%fftw_wisdom_file_name,& - plan_style=globenv%fftw_plan_type,& - error=error ) + plan_style=globenv%fftw_plan_type) !..the unit cell (should not really matter, the number of grid points do) NULLIFY(box,grid) - CALL cell_create(box,error=error) + CALL cell_create(box) box % hmat = RESHAPE ( (/10.0_dp,0.0_dp,0.0_dp,0.0_dp,8.0_dp,0.0_dp,& 0.0_dp,0.0_dp,7.0_dp/), (/3,3/) ) CALL init_cell ( box ) - CALL section_vals_get(pw_transfer_section,n_repetition=n_rep,error=error) + CALL section_vals_get(pw_transfer_section,n_repetition=n_rep) DO i_rep=1,n_rep ! how often should we do the transfer - CALL section_vals_val_get(pw_transfer_section,"N_loop",i_rep_section=i_rep,i_val=N_loop,error=error ) + CALL section_vals_val_get(pw_transfer_section,"N_loop",i_rep_section=i_rep,i_val=N_loop) ALLOCATE(t_start(N_loop)) ALLOCATE(t_end(N_loop)) ! setup of the grids - CALL section_vals_val_get(pw_transfer_section,"GRID",i_rep_section=i_rep,i_vals=i_vals,error=error ) + CALL section_vals_val_get(pw_transfer_section,"GRID",i_rep_section=i_rep,i_vals=i_vals) np = i_vals - CALL section_vals_val_get(pw_transfer_section,"PW_GRID_BLOCKED",i_rep_section=i_rep,i_val=blocked_id,error=error ) - CALL section_vals_val_get(pw_transfer_section,"DEBUG",i_rep_section=i_rep,l_val=debug,error=error ) + CALL section_vals_val_get(pw_transfer_section,"PW_GRID_BLOCKED",i_rep_section=i_rep,i_val=blocked_id) + CALL section_vals_val_get(pw_transfer_section,"DEBUG",i_rep_section=i_rep,l_val=debug) CALL section_vals_val_get(pw_transfer_section,"PW_GRID_LAYOUT_ALL",i_rep_section=i_rep,& - l_val=pw_grid_layout_all,error=error ) + l_val=pw_grid_layout_all) ! prepare to loop over all or a specific layout IF (pw_grid_layout_all) THEN @@ -943,7 +927,7 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) ENDIF ENDDO ELSE - CALL section_vals_val_get(pw_transfer_section,"PW_GRID_LAYOUT",i_rep_section=i_rep,i_vals=i_vals,error=error) + CALL section_vals_val_get(pw_transfer_section,"PW_GRID_LAYOUT",i_rep_section=i_rep,i_vals=i_vals) ALLOCATE(layouts(2,1)) layouts(:,1)=i_vals ENDIF @@ -952,9 +936,9 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) distribution_layout=layouts(:,i_layout) - CALL pw_grid_create ( grid, para_env%group ,error=error) + CALL pw_grid_create ( grid, para_env%group) - CALL section_vals_val_get(pw_transfer_section,"PW_GRID",i_rep_section=i_rep,i_val=itmp,error=error) + CALL section_vals_val_get(pw_transfer_section,"PW_GRID",i_rep_section=i_rep,i_val=itmp) ! from cp_control_utils SELECT CASE (itmp) @@ -987,7 +971,7 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) ! actual setup CALL pw_grid_setup ( box%hmat, grid, grid_span=grid_span, odd=odd, spherical=spherical, & blocked=blocked_id, npts=np, fft_usage=.TRUE.,& - rs_dims=distribution_layout, iounit=iw, error=error) + rs_dims=distribution_layout, iounit=iw) IF (iw>0) CALL m_flush(iw) @@ -998,14 +982,14 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) NULLIFY(cb%pw) NULLIFY(cc%pw) - CALL pw_create ( ca%pw, grid, COMPLEXDATA1D ,error=error) - CALL pw_create ( cb%pw, grid, COMPLEXDATA3D ,error=error) - CALL pw_create ( cc%pw, grid, COMPLEXDATA1D ,error=error) + CALL pw_create ( ca%pw, grid, COMPLEXDATA1D) + CALL pw_create ( cb%pw, grid, COMPLEXDATA3D) + CALL pw_create ( cc%pw, grid, COMPLEXDATA1D) ! initialize data - CALL pw_zero ( ca%pw , error=error) - CALL pw_zero ( cb%pw , error=error) - CALL pw_zero ( cc%pw , error=error) + CALL pw_zero ( ca%pw) + CALL pw_zero ( cb%pw) + CALL pw_zero ( cc%pw) ca % pw % in_space = RECIPROCALSPACE nn = SIZE ( ca % pw % cc ) DO ig = 1, nn @@ -1018,8 +1002,8 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) DO ip = 1, n_loop CALL mp_sync(para_env%group) t_start(ip) = m_walltime() - CALL pw_transfer ( ca%pw, cb%pw, debug, error=error) - CALL pw_transfer ( cb%pw, cc%pw, debug, error=error) + CALL pw_transfer ( ca%pw, cb%pw, debug) + CALL pw_transfer ( cb%pw, cc%pw, debug) CALL mp_sync(para_env%group) t_end(ip) = m_walltime() END DO @@ -1053,15 +1037,15 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) IF ( em > toler .OR. et > toler ) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "The FFT results are not accurate ... starting debug pw_transfer") - CALL pw_transfer ( ca%pw, cb%pw, .TRUE., error=error) - CALL pw_transfer ( cb%pw, cc%pw, .TRUE., error=error) + CALL pw_transfer ( ca%pw, cb%pw, .TRUE.) + CALL pw_transfer ( cb%pw, cc%pw, .TRUE.) ENDIF ! done with these grids - CALL pw_release ( ca%pw ,error=error) - CALL pw_release ( cb%pw ,error=error) - CALL pw_release ( cc%pw ,error=error) - CALL pw_grid_release ( grid ,error=error) + CALL pw_release ( ca%pw) + CALL pw_release ( cb%pw) + CALL pw_release ( cc%pw) + CALL pw_grid_release ( grid) END DO @@ -1073,9 +1057,8 @@ SUBROUTINE pw_fft_test ( para_env, iw, globenv, pw_transfer_section, error ) ENDDO ! cleanup - CALL cell_release(box,error=error) - CALL finalize_fft(para_env, wisdom_file=globenv%fftw_wisdom_file_name,& - error=error) + CALL cell_release(box) + CALL finalize_fft(para_env, wisdom_file=globenv%fftw_wisdom_file_name) END SUBROUTINE pw_fft_test @@ -1083,15 +1066,13 @@ END SUBROUTINE pw_fft_test !> \brief Test the parallel (pseudo)random number generator (RNG). !> \param para_env ... !> \param output_unit ... -!> \param error ... !> \par History !> JGH 6-Feb-2001 : Test and performance code !> \author JGH 1-JAN-2001 ! ***************************************************************************** - SUBROUTINE rng_test(para_env,output_unit, error) + SUBROUTINE rng_test(para_env,output_unit) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rng_test', & routineP = moduleN//':'//routineN @@ -1108,7 +1089,7 @@ SUBROUTINE rng_test(para_env,output_unit, error) ! Check correctness - CALL check_rng(output_unit,ionode,error=error) + CALL check_rng(output_unit,ionode) ! Check performance @@ -1122,10 +1103,10 @@ SUBROUTINE rng_test(para_env,output_unit, error) CALL create_rng_stream(rng_stream=rng_stream,& name="Test uniform distribution [0,1]",& distribution_type=UNIFORM,& - extended_precision=.TRUE.,error=error) + extended_precision=.TRUE.) IF (ionode) THEN - CALL write_rng_stream(rng_stream,output_unit,write_all=.TRUE.,error=error) + CALL write_rng_stream(rng_stream,output_unit,write_all=.TRUE.) END IF tmax = -HUGE(0.0_dp) @@ -1135,7 +1116,7 @@ SUBROUTINE rng_test(para_env,output_unit, error) tstart = m_walltime() DO i=1,n - t = next_random_number(rng_stream,error=error) + t = next_random_number(rng_stream) tsum = tsum + t tsum2 = tsum2 + t*t IF (t > tmax) tmax = t @@ -1152,14 +1133,14 @@ SUBROUTINE rng_test(para_env,output_unit, error) "Time [s]:",tend - tstart END IF - CALL delete_rng_stream(rng_stream,error=error) + CALL delete_rng_stream(rng_stream) ! Test normal Gaussian distribution CALL create_rng_stream(rng_stream=rng_stream,& name="Test normal Gaussian distribution",& distribution_type=GAUSSIAN,& - extended_precision=.TRUE.,error=error) + extended_precision=.TRUE.) tmax = -HUGE(0.0_dp) tmin = +HUGE(0.0_dp) @@ -1168,7 +1149,7 @@ SUBROUTINE rng_test(para_env,output_unit, error) tstart = m_walltime() DO i=1,n - t = next_random_number(rng_stream,error=error) + t = next_random_number(rng_stream) tsum = tsum + t tsum2 = tsum2 + t*t IF (t > tmax) tmax = t @@ -1177,7 +1158,7 @@ SUBROUTINE rng_test(para_env,output_unit, error) tend = m_walltime() IF (ionode) THEN - CALL write_rng_stream(rng_stream,output_unit,error=error) + CALL write_rng_stream(rng_stream,output_unit) WRITE (UNIT=output_unit,FMT="(/,(T4,A,F12.6))")& "Minimum: ",tmin,& "Maximum: ",tmax,& @@ -1186,7 +1167,7 @@ SUBROUTINE rng_test(para_env,output_unit, error) "Time [s]:",tend - tstart END IF - CALL delete_rng_stream(rng_stream,error=error) + CALL delete_rng_stream(rng_stream) END SUBROUTINE rng_test @@ -1195,17 +1176,15 @@ END SUBROUTINE rng_test !> \param para_env ... !> \param iw ... !> \param eigensolver_section ... -!> \param error ... !> \par History !> JGH 6-Feb-2001 : Test and performance code !> \author JGH 1-JAN-2001 ! ***************************************************************************** - SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) + SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: iw TYPE(section_vals_type), POINTER :: eigensolver_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eigensolver_test', & routineP = moduleN//':'//routineN @@ -1233,19 +1212,18 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) ! create blacs env corresponding to para_env NULLIFY (blacs_env) CALL cp_blacs_env_create(blacs_env=blacs_env,& - para_env=para_env,& - error=error) + para_env=para_env) ! loop over all tests - CALL section_vals_get(eigensolver_section,n_repetition=n_rep,error=error) + CALL section_vals_get(eigensolver_section,n_repetition=n_rep) DO i_rep=1,n_rep ! parse section - CALL section_vals_val_get(eigensolver_section,"N",i_rep_section=i_rep,i_val=n,error=error) - CALL section_vals_val_get(eigensolver_section,"EIGENVALUES",i_rep_section=i_rep,i_val=neig,error=error) - CALL section_vals_val_get(eigensolver_section,"DIAG_METHOD",i_rep_section=i_rep,i_val=diag_method,error=error) - CALL section_vals_val_get(eigensolver_section,"INIT_METHOD",i_rep_section=i_rep,i_val=init_method,error=error) - CALL section_vals_val_get(eigensolver_section,"N_loop",i_rep_section=i_rep,i_val=n_loop,error=error) + CALL section_vals_val_get(eigensolver_section,"N",i_rep_section=i_rep,i_val=n) + CALL section_vals_val_get(eigensolver_section,"EIGENVALUES",i_rep_section=i_rep,i_val=neig) + CALL section_vals_val_get(eigensolver_section,"DIAG_METHOD",i_rep_section=i_rep,i_val=diag_method) + CALL section_vals_val_get(eigensolver_section,"INIT_METHOD",i_rep_section=i_rep,i_val=init_method) + CALL section_vals_val_get(eigensolver_section,"N_loop",i_rep_section=i_rep,i_val=n_loop) ! proper number of eigs IF (neig<0) neig=n @@ -1282,30 +1260,26 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) para_env=para_env,& context=blacs_env,& nrow_global=n,& - ncol_global=n,& - error=error) + ncol_global=n) ! create all needed matrices, and buffers for the eigenvalues NULLIFY (matrix) CALL cp_fm_create(matrix=matrix,& matrix_struct=fmstruct,& - name="MATRIX",& - error=error) - CALL cp_fm_set_all(matrix,0.0_dp,error=error) + name="MATRIX") + CALL cp_fm_set_all(matrix,0.0_dp) NULLIFY (eigenvectors) CALL cp_fm_create(matrix=eigenvectors,& matrix_struct=fmstruct,& - name="EIGENVECTORS",& - error=error) - CALL cp_fm_set_all(eigenvectors,0.0_dp,error=error) + name="EIGENVECTORS") + CALL cp_fm_set_all(eigenvectors,0.0_dp) NULLIFY (work) CALL cp_fm_create(matrix=work,& matrix_struct=fmstruct,& - name="WORK",& - error=error) - CALL cp_fm_set_all(matrix,0.0_dp,error=error) + name="WORK") + CALL cp_fm_set_all(matrix,0.0_dp) ALLOCATE (eigenvalues(n)) eigenvalues = 0.0_dp @@ -1319,7 +1293,7 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) CALL create_rng_stream(rng_stream=rng_stream,& name="rng_stream",& distribution_type=UNIFORM,& - extended_precision=.TRUE.,error=error) + extended_precision=.TRUE.) CASE(do_mat_read) CALL open_file(file_name="MATRIX",& file_action="READ",& @@ -1334,7 +1308,7 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) SELECT CASE(init_method) CASE(do_mat_random) DO j=i,n - buffer(1,j) = next_random_number(rng_stream,error=error) - 0.5_dp + buffer(1,j) = next_random_number(rng_stream) - 0.5_dp END DO !MK activate/modify for a diagonal dominant symmetric matrix: !MK buffer(1,i) = 10.0_dp*buffer(1,i) @@ -1353,8 +1327,7 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) n_cols=n-i+1,& alpha=1.0_dp,& beta=0.0_dp,& - transpose=.FALSE.,& - error=error) + transpose=.FALSE.) CALL cp_fm_set_submatrix(fm=matrix,& new_values=buffer,& start_row=i,& @@ -1363,8 +1336,7 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) n_cols=1,& alpha=1.0_dp,& beta=0.0_dp,& - transpose=.TRUE.,& - error=error) + transpose=.TRUE.) CASE(do_mat_read) CALL cp_fm_set_submatrix(fm=matrix,& new_values=buffer,& @@ -1374,8 +1346,7 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) n_cols=n,& alpha=1.0_dp,& beta=0.0_dp,& - transpose=.FALSE.,& - error=error) + transpose=.FALSE.) END SELECT END DO @@ -1384,7 +1355,7 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) IF (para_env%mepos==para_env%source) THEN SELECT CASE(init_method) CASE(do_mat_random) - CALL delete_rng_stream(rng_stream=rng_stream,error=error) + CALL delete_rng_stream(rng_stream=rng_stream) CASE(do_mat_read) CALL close_file(unit_number=unit_number) END SELECT @@ -1392,10 +1363,9 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) DO i_loop=1,n_loop eigenvalues = 0.0_dp - CALL cp_fm_set_all(eigenvectors,0.0_dp,error=error) + CALL cp_fm_set_all(eigenvectors,0.0_dp) CALL cp_fm_to_fm(source=matrix,& - destination=work,& - error=error) + destination=work) ! DONE, now testing t1=m_walltime() @@ -1403,15 +1373,13 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) CASE(do_diag_syevd) CALL cp_fm_syevd(matrix=work,& eigenvectors=eigenvectors,& - eigenvalues=eigenvalues,& - error=error) + eigenvalues=eigenvalues) CASE(do_diag_syevx) CALL cp_fm_syevx(matrix=work,& eigenvectors=eigenvectors,& eigenvalues=eigenvalues,& neig=neig,& - work_syevx=1.0_dp,& - error=error) + work_syevx=1.0_dp) END SELECT t2=m_walltime() IF (iw>0) WRITE(iw,*) "Timing for loop ",i_loop," : ",t2-t1 @@ -1426,14 +1394,14 @@ SUBROUTINE eigensolver_test(para_env, iw, eigensolver_section,error ) ! Clean up DEALLOCATE (eigenvalues) - CALL cp_fm_release(matrix=work,error=error) - CALL cp_fm_release(matrix=eigenvectors,error=error) - CALL cp_fm_release(matrix=matrix,error=error) - CALL cp_fm_struct_release(fmstruct=fmstruct,error=error) + CALL cp_fm_release(matrix=work) + CALL cp_fm_release(matrix=eigenvectors) + CALL cp_fm_release(matrix=matrix) + CALL cp_fm_struct_release(fmstruct=fmstruct) ENDDO - CALL cp_blacs_env_release(blacs_env=blacs_env,error=error) + CALL cp_blacs_env_release(blacs_env=blacs_env) END SUBROUTINE eigensolver_test @@ -1442,14 +1410,12 @@ END SUBROUTINE eigensolver_test !> \param para_env ... !> \param iw ... !> \param cp_fm_gemm_test_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) + SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: iw TYPE(section_vals_type), POINTER :: cp_fm_gemm_test_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_gemm_test', & routineP = moduleN//':'//routineN @@ -1470,23 +1436,23 @@ SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) INTEGER :: pilaenv #endif - CALL section_vals_get(cp_fm_gemm_test_section,n_repetition=n_rep,error=error) + CALL section_vals_get(cp_fm_gemm_test_section,n_repetition=n_rep) DO i_rep=1,n_rep ! how often should we do the multiply - CALL section_vals_val_get(cp_fm_gemm_test_section,"N_loop",i_rep_section=i_rep,i_val=N_loop,error=error ) + CALL section_vals_val_get(cp_fm_gemm_test_section,"N_loop",i_rep_section=i_rep,i_val=N_loop) ! matrices def. - CALL section_vals_val_get(cp_fm_gemm_test_section,"K",i_rep_section=i_rep,i_val=k,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"N",i_rep_section=i_rep,i_val=n,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"M",i_rep_section=i_rep,i_val=m,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"transa",i_rep_section=i_rep,l_val=transa_p,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"transb",i_rep_section=i_rep,l_val=transb_p,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"nrow_block",i_rep_section=i_rep,i_val=nrow_block,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"ncol_block",i_rep_section=i_rep,i_val=ncol_block,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"ROW_MAJOR",i_rep_section=i_rep,l_val=row_major,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"GRID_2D",i_rep_section=i_rep,i_vals=grid_2d,error=error ) - CALL section_vals_val_get(cp_fm_gemm_test_section,"FORCE_BLOCKSIZE",i_rep_section=i_rep,l_val=force_blocksize,error=error ) + CALL section_vals_val_get(cp_fm_gemm_test_section,"K",i_rep_section=i_rep,i_val=k) + CALL section_vals_val_get(cp_fm_gemm_test_section,"N",i_rep_section=i_rep,i_val=n) + CALL section_vals_val_get(cp_fm_gemm_test_section,"M",i_rep_section=i_rep,i_val=m) + CALL section_vals_val_get(cp_fm_gemm_test_section,"transa",i_rep_section=i_rep,l_val=transa_p) + CALL section_vals_val_get(cp_fm_gemm_test_section,"transb",i_rep_section=i_rep,l_val=transb_p) + CALL section_vals_val_get(cp_fm_gemm_test_section,"nrow_block",i_rep_section=i_rep,i_val=nrow_block) + CALL section_vals_val_get(cp_fm_gemm_test_section,"ncol_block",i_rep_section=i_rep,i_val=ncol_block) + CALL section_vals_val_get(cp_fm_gemm_test_section,"ROW_MAJOR",i_rep_section=i_rep,l_val=row_major) + CALL section_vals_val_get(cp_fm_gemm_test_section,"GRID_2D",i_rep_section=i_rep,i_vals=grid_2d) + CALL section_vals_val_get(cp_fm_gemm_test_section,"FORCE_BLOCKSIZE",i_rep_section=i_rep,l_val=force_blocksize) transa="N" transb="N" IF (transa_p) transa="T" @@ -1520,8 +1486,7 @@ SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) CALL cp_blacs_env_create(blacs_env=blacs_env,& para_env=para_env,& row_major=row_major,& - grid_2d=grid_2d,& - error=error) + grid_2d=grid_2d) NULLIFY (fmstruct_a) IF (transa_p) THEN @@ -1531,8 +1496,8 @@ SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) ENDIF CALL cp_fm_struct_create(fmstruct=fmstruct_a, para_env=para_env, context=blacs_env,& nrow_global=nrow_global, ncol_global=ncol_global, & - nrow_block=nrow_block, ncol_block=ncol_block, force_block=force_blocksize, error=error) - CALL cp_fm_struct_get(fmstruct_a,nrow_block=nrow_block_actual,ncol_block=ncol_block_actual, error=error) + nrow_block=nrow_block, ncol_block=ncol_block, force_block=force_blocksize) + CALL cp_fm_struct_get(fmstruct_a,nrow_block=nrow_block_actual,ncol_block=ncol_block_actual) IF (iw>0) WRITE(iw,'(T2,A,I9,A,I9,A,I5,A,I5)') 'matrix A ',nrow_global," by ",ncol_global, & ' using blocks of ',nrow_block_actual, ' by ',ncol_block_actual @@ -1544,8 +1509,8 @@ SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) NULLIFY (fmstruct_b) CALL cp_fm_struct_create(fmstruct=fmstruct_b, para_env=para_env, context=blacs_env,& nrow_global=nrow_global, ncol_global=ncol_global, & - nrow_block=nrow_block, ncol_block=ncol_block, force_block=force_blocksize, error=error) - CALL cp_fm_struct_get(fmstruct_b,nrow_block=nrow_block_actual,ncol_block=ncol_block_actual, error=error) + nrow_block=nrow_block, ncol_block=ncol_block, force_block=force_blocksize) + CALL cp_fm_struct_get(fmstruct_b,nrow_block=nrow_block_actual,ncol_block=ncol_block_actual) IF (iw>0) WRITE(iw,'(T2,A,I9,A,I9,A,I5,A,I5)') 'matrix B ',nrow_global," by ",ncol_global, & ' using blocks of ',nrow_block_actual, ' by ',ncol_block_actual @@ -1554,17 +1519,17 @@ SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) ncol_global=n CALL cp_fm_struct_create(fmstruct=fmstruct_c, para_env=para_env, context=blacs_env,& nrow_global=nrow_global, ncol_global=ncol_global, & - nrow_block=nrow_block, ncol_block=ncol_block, force_block=force_blocksize, error=error) - CALL cp_fm_struct_get(fmstruct_c,nrow_block=nrow_block_actual,ncol_block=ncol_block_actual, error=error) + nrow_block=nrow_block, ncol_block=ncol_block, force_block=force_blocksize) + CALL cp_fm_struct_get(fmstruct_c,nrow_block=nrow_block_actual,ncol_block=ncol_block_actual) IF (iw>0) WRITE(iw,'(T2,A,I9,A,I9,A,I5,A,I5)') 'matrix C ',nrow_global," by ",ncol_global, & ' using blocks of ',nrow_block_actual, ' by ',ncol_block_actual NULLIFY (matrix_a) - CALL cp_fm_create(matrix=matrix_a, matrix_struct=fmstruct_a, name="MATRIX A", error=error) + CALL cp_fm_create(matrix=matrix_a, matrix_struct=fmstruct_a, name="MATRIX A") NULLIFY (matrix_b) - CALL cp_fm_create(matrix=matrix_b, matrix_struct=fmstruct_b, name="MATRIX B", error=error) + CALL cp_fm_create(matrix=matrix_b, matrix_struct=fmstruct_b, name="MATRIX B") NULLIFY (matrix_c) - CALL cp_fm_create(matrix=matrix_c, matrix_struct=fmstruct_c, name="MATRIX C", error=error) + CALL cp_fm_create(matrix=matrix_c, matrix_struct=fmstruct_c, name="MATRIX C") CALL RANDOM_NUMBER(matrix_a%local_data) CALL RANDOM_NUMBER(matrix_b%local_data) @@ -1575,7 +1540,7 @@ SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) t1=m_walltime() DO i_loop=1,N_loop t3=m_walltime() - CALL cp_gemm(transa,transb,k,n,m,1.0_dp,matrix_a,matrix_b,0.0_dp,matrix_c,error=error) + CALL cp_gemm(transa,transb,k,n,m,1.0_dp,matrix_a,matrix_b,0.0_dp,matrix_c) t4=m_walltime() IF (iw>0) THEN WRITE(iw,'(T2,A,T50,F12.6)') "cp_fm_gemm timing: ",(t4-t3) @@ -1592,13 +1557,13 @@ SUBROUTINE cp_fm_gemm_test(para_env, iw, cp_fm_gemm_test_section, error ) ENDIF ENDIF - CALL cp_fm_release(matrix=matrix_a,error=error) - CALL cp_fm_release(matrix=matrix_b,error=error) - CALL cp_fm_release(matrix=matrix_c,error=error) - CALL cp_fm_struct_release(fmstruct=fmstruct_a,error=error) - CALL cp_fm_struct_release(fmstruct=fmstruct_b,error=error) - CALL cp_fm_struct_release(fmstruct=fmstruct_c,error=error) - CALL cp_blacs_env_release(blacs_env=blacs_env,error=error) + CALL cp_fm_release(matrix=matrix_a) + CALL cp_fm_release(matrix=matrix_b) + CALL cp_fm_release(matrix=matrix_c) + CALL cp_fm_struct_release(fmstruct=fmstruct_a) + CALL cp_fm_struct_release(fmstruct=fmstruct_b) + CALL cp_fm_struct_release(fmstruct=fmstruct_c) + CALL cp_blacs_env_release(blacs_env=blacs_env) ENDDO @@ -1610,14 +1575,12 @@ END SUBROUTINE cp_fm_gemm_test !> \param para_env ... !> \param iw ... !> \param input_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_dbcsr_tests (para_env, iw, input_section, error ) + SUBROUTINE cp_dbcsr_tests (para_env, iw, input_section) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: iw TYPE(section_vals_type), POINTER :: input_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_tests', & routineP = moduleN//':'//routineN @@ -1635,42 +1598,42 @@ SUBROUTINE cp_dbcsr_tests (para_env, iw, input_section, error ) ! --------------------------------------------------------------------------- NULLIFY (bs_m, bs_n, bs_k) - CALL section_vals_get(input_section,n_repetition=n_rep,error=error) + CALL section_vals_get(input_section,n_repetition=n_rep) DO i_rep = 1, n_rep ! how often should we do the multiply - CALL section_vals_val_get(input_section,"N_loop",i_rep_section=i_rep,i_val=N_loop,error=error ) + CALL section_vals_val_get(input_section,"N_loop",i_rep_section=i_rep,i_val=N_loop) ! matrices def. - CALL section_vals_val_get(input_section,"TEST_TYPE",i_rep_section=i_rep,i_val=test_type,error=error ) - CALL section_vals_val_get(input_section,"DATA_TYPE",i_rep_section=i_rep,i_val=data_type,error=error ) - CALL section_vals_val_get(input_section,"K",i_rep_section=i_rep,i_val=k,error=error ) - CALL section_vals_val_get(input_section,"N",i_rep_section=i_rep,i_val=n,error=error ) - CALL section_vals_val_get(input_section,"M",i_rep_section=i_rep,i_val=m,error=error ) - CALL section_vals_val_get(input_section,"transa",i_rep_section=i_rep,l_val=transa_p,error=error ) - CALL section_vals_val_get(input_section,"transb",i_rep_section=i_rep,l_val=transb_p,error=error ) + CALL section_vals_val_get(input_section,"TEST_TYPE",i_rep_section=i_rep,i_val=test_type) + CALL section_vals_val_get(input_section,"DATA_TYPE",i_rep_section=i_rep,i_val=data_type) + CALL section_vals_val_get(input_section,"K",i_rep_section=i_rep,i_val=k) + CALL section_vals_val_get(input_section,"N",i_rep_section=i_rep,i_val=n) + CALL section_vals_val_get(input_section,"M",i_rep_section=i_rep,i_val=m) + CALL section_vals_val_get(input_section,"transa",i_rep_section=i_rep,l_val=transa_p) + CALL section_vals_val_get(input_section,"transb",i_rep_section=i_rep,l_val=transb_p) CALL section_vals_val_get(input_section,"bs_m",i_rep_section=i_rep,& - i_vals=bs_m, error=error) + i_vals=bs_m) CALL section_vals_val_get(input_section,"bs_n",i_rep_section=i_rep,& - i_vals=bs_n, error=error) + i_vals=bs_n) CALL section_vals_val_get(input_section,"bs_k",i_rep_section=i_rep,& - i_vals=bs_k, error=error) - CALL section_vals_val_get(input_section,"keepsparse",i_rep_section=i_rep,l_val=retain_sparsity,error=error ) - CALL section_vals_val_get(input_section,"asparsity",i_rep_section=i_rep,r_val=s_a,error=error ) - CALL section_vals_val_get(input_section,"bsparsity",i_rep_section=i_rep,r_val=s_b,error=error ) - CALL section_vals_val_get(input_section,"csparsity",i_rep_section=i_rep,r_val=s_c,error=error ) - CALL section_vals_val_get(input_section,"alpha",i_rep_section=i_rep,r_val=alpha,error=error ) - CALL section_vals_val_get(input_section,"beta",i_rep_section=i_rep,r_val=beta,error=error ) + i_vals=bs_k) + CALL section_vals_val_get(input_section,"keepsparse",i_rep_section=i_rep,l_val=retain_sparsity) + CALL section_vals_val_get(input_section,"asparsity",i_rep_section=i_rep,r_val=s_a) + CALL section_vals_val_get(input_section,"bsparsity",i_rep_section=i_rep,r_val=s_b) + CALL section_vals_val_get(input_section,"csparsity",i_rep_section=i_rep,r_val=s_c) + CALL section_vals_val_get(input_section,"alpha",i_rep_section=i_rep,r_val=alpha) + CALL section_vals_val_get(input_section,"beta",i_rep_section=i_rep,r_val=beta) CALL section_vals_val_get(input_section,"nproc",i_rep_section=i_rep,& - i_vals=nproc, error=error) + i_vals=nproc) CALL section_vals_val_get(input_section,"atype",i_rep_section=i_rep,& - c_val=types(1), error=error) + c_val=types(1)) CALL section_vals_val_get(input_section,"btype",i_rep_section=i_rep,& - c_val=types(2), error=error) + c_val=types(2)) CALL section_vals_val_get(input_section,"ctype",i_rep_section=i_rep,& - c_val=types(3), error=error) + c_val=types(3)) CALL section_vals_val_get(input_section,"filter_eps",& - i_rep_section=i_rep,r_val=filter_eps,error=error ) - CALL section_vals_val_get(input_section,"ALWAYS_CHECKSUM",i_rep_section=i_rep,l_val=always_checksum,error=error ) + i_rep_section=i_rep,r_val=filter_eps) + CALL section_vals_val_get(input_section,"ALWAYS_CHECKSUM",i_rep_section=i_rep,l_val=always_checksum) CALL dbcsr_run_tests (para_env%group, iw, nproc,& (/ m, n, k /),& diff --git a/src/lri_debug_integrals.F b/src/lri_debug_integrals.F index ee08ccfc5f..8a7b2d6cd9 100644 --- a/src/lri_debug_integrals.F +++ b/src/lri_debug_integrals.F @@ -41,11 +41,9 @@ MODULE lri_debug_integrals ! ****************************************************************************** !> \brief recursive test routines for integral (a,b) for only two exponents -!> \param error ... ! ***************************************************************************** - SUBROUTINE overlap_ab_test_simple(error) + SUBROUTINE overlap_ab_test_simple() - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'overlap_ab_test_simple', & routineP = moduleN//':'//routineN @@ -79,12 +77,12 @@ SUBROUTINE overlap_ab_test_simple(error) !--------------------------------------- ALLOCATE(sab(ncoset(la_max),ncoset(lb_max)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) maxl=MAX(la_max, lb_max) lds = ncoset(maxl) ALLOCATE(swork(lds,lds,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sab=0._dp rab(:)= B(:) - A(:) dab = SQRT(DOT_PRODUCT(rab,rab)) @@ -126,7 +124,7 @@ SUBROUTINE overlap_ab_test_simple(error) WRITE(*,*) "dmax", dmax DEALLOCATE(sab,swork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_ab_test_simple @@ -144,10 +142,9 @@ END SUBROUTINE overlap_ab_test_simple !> \param rb ... !> \param sab ... !> \param dmax ... -!> \param error ... ! ***************************************************************************** SUBROUTINE overlap_ab_test(la_max,la_min,npgfa,zeta,lb_max,lb_min,npgfb,zetb,& - ra,rb,sab,dmax,error) + ra,rb,sab,dmax) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta @@ -157,7 +154,6 @@ SUBROUTINE overlap_ab_test(la_max,la_min,npgfa,zeta,lb_max,lb_min,npgfb,zetb,& REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: sab REAL(KIND=dp), INTENT(INOUT) :: dmax - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'overlap_ab_test', & routineP = moduleN//':'//routineN @@ -209,11 +205,9 @@ END SUBROUTINE overlap_ab_test ! ****************************************************************************** !> \brief recursive test routines for integral (a,b,c) for only three exponents -!> \param error ... ! ***************************************************************************** - SUBROUTINE overlap_abc_test_simple(error) + SUBROUTINE overlap_abc_test_simple() - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'overlap_abc_test_simple', & routineP = moduleN//':'//routineN @@ -254,7 +248,7 @@ SUBROUTINE overlap_abc_test_simple(error) rbc(:)= C(:) - B(:) dbc = SQRT(DOT_PRODUCT(rbc,rbc)) ALLOCATE(sabc(ncoset(la_max),ncoset(lb_max),ncoset(lc_max)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) xa_work(1)=xa xb_work(1)=xb xc_work(1)=xc @@ -266,7 +260,7 @@ SUBROUTINE overlap_abc_test_simple(error) CALL overlap3(la_max_set=la_max,npgfa=1,zeta=xa_work,rpgfa=rpgfa,la_min_set=la_min,& lb_max_set=lb_max,npgfb=1,zetb=xb_work,rpgfb=rpgfb,lb_min_set=lb_min,& lc_max_set=lc_max,npgfc=1,zetc=xc_work,rpgfc=rpgfc,lc_min_set=lc_min,& - rab=rab,dab=dab,rac=rac,dac=dac,rbc=rbc,dbc=dbc,sabc=sabc,error=error) + rab=rab,dab=dab,rac=rac,dac=dac,rbc=rbc,dbc=dbc,sabc=sabc) !sabc(:,:,:)=0._dp !CALL overlap3_old(la_max=la_max,npgfa=1,zeta=xa_work,rpgfa=rpgfa,la_min=la_min,& ! lb_max=lb_max,npgfb=1,zetb=xb_work,rpgfb=rpgfb,lb_min=lb_min,& @@ -313,7 +307,7 @@ SUBROUTINE overlap_abc_test_simple(error) WRITE(*,*) "dmax", dmax DEALLOCATE(sabc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_abc_test_simple @@ -336,12 +330,11 @@ END SUBROUTINE overlap_abc_test_simple !> \param rc ... !> \param sabc ... !> \param dmax ... -!> \param error ... ! ***************************************************************************** SUBROUTINE overlap_abc_test(la_max,npgfa,zeta,la_min,& lb_max,npgfb,zetb,lb_min,& lc_max,npgfc,zetc,lc_min,& - ra,rb,rc,sabc,dmax,error) + ra,rb,rc,sabc,dmax) INTEGER, INTENT(IN) :: la_max, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta @@ -354,7 +347,6 @@ SUBROUTINE overlap_abc_test(la_max,npgfa,zeta,la_min,& REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(IN) :: sabc REAL(KIND=dp), INTENT(INOUT) :: dmax - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'overlap_abc_test', & routineP = moduleN//':'//routineN @@ -427,11 +419,9 @@ END SUBROUTINE overlap_abc_test ! ****************************************************************************** !> \brief recursive test routines for integral (aa,bb) for only four exponents -!> \param error ... ! ***************************************************************************** - SUBROUTINE overlap_aabb_test_simple(error) + SUBROUTINE overlap_aabb_test_simple() - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'overlap_aabb_test_simple', & routineP = moduleN//':'//routineN @@ -473,12 +463,12 @@ SUBROUTINE overlap_aabb_test_simple(error) !--------------------------------------- ALLOCATE(saabb(ncoset(la_max1),ncoset(la_max2),ncoset(lb_max1),ncoset(lb_max2)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) maxl=MAX(la_max1+la_max2, lb_max1+lb_max2) lds = ncoset(maxl) ALLOCATE(swork(lds,lds),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) saabb=0._dp rab(:)= B(:) - A(:) dab = SQRT(DOT_PRODUCT(rab,rab)) @@ -541,7 +531,7 @@ SUBROUTINE overlap_aabb_test_simple(error) WRITE(*,*) "dmax", dmax DEALLOCATE(saabb,swork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE overlap_aabb_test_simple @@ -567,13 +557,12 @@ END SUBROUTINE overlap_aabb_test_simple !> \param rb ... !> \param saabb ... !> \param dmax ... -!> \param error ... ! ***************************************************************************** SUBROUTINE overlap_aabb_test(la_max1,la_min1,npgfa1,zeta1,& la_max2,la_min2,npgfa2,zeta2,& lb_max1,lb_min1,npgfb1,zetb1,& lb_max2,lb_min2,npgfb2,zetb2,& - ra,rb,saabb,dmax,error) + ra,rb,saabb,dmax) INTEGER, INTENT(IN) :: la_max1, la_min1, npgfa1 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta1 @@ -587,7 +576,6 @@ SUBROUTINE overlap_aabb_test(la_max1,la_min1,npgfa1,zeta1,& REAL(KIND=dp), DIMENSION(:, :, :, :), & INTENT(IN) :: saabb REAL(KIND=dp), INTENT(INOUT) :: dmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'overlap_aabb_test', & routineP = moduleN//':'//routineN diff --git a/src/lri_environment_init.F b/src/lri_environment_init.F index b43be9a789..6070dc4bb1 100644 --- a/src/lri_environment_init.F +++ b/src/lri_environment_init.F @@ -55,16 +55,13 @@ MODULE lri_environment_init !> \param qs_env ... !> \param force_env_section ... !> \param qs_kind_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE lri_env_init(qs_env,force_env_section,qs_kind_set,error) + SUBROUTINE lri_env_init(qs_env,force_env_section,qs_kind_set) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: force_env_section TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lri_env_init', & routineP = moduleN//':'//routineN @@ -79,54 +76,54 @@ SUBROUTINE lri_env_init(qs_env,force_env_section,qs_kind_set,error) TYPE(lri_environment_type), POINTER :: lri_env NULLIFY(atomic_kind_set,lri_basis_set,lri_env,orb_basis_set) - CALL lri_env_create(lri_env,error) + CALL lri_env_create(lri_env) ! initialize the basic basis sets (orb and ri) - CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,error=error) + CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set) nkind = SIZE(atomic_kind_set) ALLOCATE(lri_env%orb_basis(nkind),lri_env%ri_basis(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) maxl_orb = 0 maxl_ri = 0 DO ikind=1,nkind NULLIFY(orb_basis_set,lri_basis_set) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,basis_type="ORB",error=error) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=lri_basis_set,basis_type="LRI",error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,basis_type="ORB") + CALL get_qs_kind(qs_kind_set(ikind),basis_set=lri_basis_set,basis_type="LRI") NULLIFY(lri_env%orb_basis(ikind)%gto_basis_set) NULLIFY(lri_env%ri_basis(ikind)%gto_basis_set) IF (ASSOCIATED(orb_basis_set)) THEN - CALL copy_gto_basis_set(orb_basis_set,lri_env%orb_basis(ikind)%gto_basis_set,error) - CALL copy_gto_basis_set(lri_basis_set,lri_env%ri_basis(ikind)%gto_basis_set,error) + CALL copy_gto_basis_set(orb_basis_set,lri_env%orb_basis(ikind)%gto_basis_set) + CALL copy_gto_basis_set(lri_basis_set,lri_env%ri_basis(ikind)%gto_basis_set) END IF lmax_ikind_orb = MAXVAL(lri_env%orb_basis(ikind)%gto_basis_set%lmax) lmax_ikind_ri = MAXVAL(lri_env%ri_basis(ikind)%gto_basis_set%lmax) maxl_orb = MAX(maxl_orb,lmax_ikind_orb) maxl_ri = MAX(maxl_ri,lmax_ikind_ri) END DO - CALL lri_basis_init(lri_env,error) + CALL lri_basis_init(lri_env) ! CG coefficients needed for lri integrals IF(ASSOCIATED(lri_env%cg_shg)) THEN CALL get_clebsch_gordon_coefficients(lri_env%cg_shg%cg_coeff,& lri_env%cg_shg%cg_none0_list,& lri_env%cg_shg%ncg_none0,& - maxl_orb,maxl_ri,error) + maxl_orb,maxl_ri) ENDIF ! init keywords ! check for debug (OS scheme) CALL section_vals_val_get(force_env_section,"DFT%QS%LRIGPW%DEBUG_LRI_INTEGRALS",& - l_val=lri_env%debug,error=error) + l_val=lri_env%debug) ! integrals based on solid harmonic Gaussians CALL section_vals_val_get(force_env_section,"DFT%QS%LRIGPW%SHG_LRI_INTEGRALS",& - l_val=lri_env%use_shg_integrals,error=error) + l_val=lri_env%use_shg_integrals) ! how to calculate inverse/pseuodinverse of overlap CALL section_vals_val_get(force_env_section,"DFT%QS%LRIGPW%LRI_OVERLAP_MATRIX",& - i_val=lri_env%lri_overlap_inv,error=error) + i_val=lri_env%lri_overlap_inv) CALL section_vals_val_get(force_env_section,"DFT%QS%LRIGPW%MAX_CONDITION_NUM",& - r_val=lri_env%cond_max,error=error) + r_val=lri_env%cond_max) ! - CALL set_qs_env (qs_env,lri_env=lri_env,error=error) + CALL set_qs_env (qs_env,lri_env=lri_env) END SUBROUTINE lri_env_init @@ -134,11 +131,9 @@ END SUBROUTINE lri_env_init !> \brief initializes the lri basis: calculates the norm, self-overlap !> and integral of the ri basis !> \param lri_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE lri_basis_init(lri_env,error) + SUBROUTINE lri_basis_init(lri_env) TYPE(lri_environment_type), POINTER :: lri_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lri_basis_init', & routineP = moduleN//':'//routineN @@ -156,40 +151,40 @@ SUBROUTINE lri_basis_init(lri_env,error) IF (ASSOCIATED(lri_env)) THEN IF (ASSOCIATED(lri_env%orb_basis)) THEN - CPPreconditionNoFail(ASSOCIATED(lri_env%ri_basis),cp_warning_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(lri_env%ri_basis),cp_warning_level,routineP) nkind = SIZE(lri_env%orb_basis) - CALL deallocate_bas_properties(lri_env,error) + CALL deallocate_bas_properties(lri_env) ALLOCATE (lri_env%bas_prop(nkind),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO ikind = 1, nkind NULLIFY(orb_basis, ri_basis) orb_basis => lri_env%orb_basis(ikind)%gto_basis_set IF (ASSOCIATED(orb_basis)) THEN ri_basis => lri_env%ri_basis(ikind)%gto_basis_set - CPPreconditionNoFail(ASSOCIATED(ri_basis),cp_warning_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(ri_basis),cp_warning_level,routineP) NULLIFY(ri_norm_r) - CALL basis_norm_radial(ri_basis,ri_norm_r,error) + CALL basis_norm_radial(ri_basis,ri_norm_r) NULLIFY(orb_norm_r) - CALL basis_norm_radial(orb_basis,orb_norm_r,error) + CALL basis_norm_radial(orb_basis,orb_norm_r) NULLIFY(ri_norm_s) - CALL basis_norm_s_func(ri_basis,ri_norm_s,error) + CALL basis_norm_s_func(ri_basis,ri_norm_s) NULLIFY(ri_int_fbas) - CALL basis_int(ri_basis,ri_int_fbas,ri_norm_s,error) + CALL basis_int(ri_basis,ri_int_fbas,ri_norm_s) lri_env%bas_prop(ikind)%int_fbas => ri_int_fbas NULLIFY(ri_ovlp) - CALL basis_ovlp(ri_basis,ri_ovlp,ri_norm_r,error) + CALL basis_ovlp(ri_basis,ri_ovlp,ri_norm_r) lri_env%bas_prop(ikind)%ri_ovlp => ri_ovlp NULLIFY(orb_ovlp) - CALL basis_ovlp(orb_basis,orb_ovlp,orb_norm_r,error) + CALL basis_ovlp(orb_basis,orb_ovlp,orb_norm_r) lri_env%bas_prop(ikind)%orb_ovlp => orb_ovlp NULLIFY(scon_ri) - CALL contraction_matrix_shg(ri_basis,scon_ri,error) + CALL contraction_matrix_shg(ri_basis,scon_ri) lri_env%bas_prop(ikind)%scon_ri => scon_ri NULLIFY(scon_orb) - CALL contraction_matrix_shg(orb_basis,scon_orb,error) + CALL contraction_matrix_shg(orb_basis,scon_orb) lri_env%bas_prop(ikind)%scon_orb => scon_orb DEALLOCATE (orb_norm_r,ri_norm_r,ri_norm_s,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END IF @@ -202,13 +197,11 @@ END SUBROUTINE lri_basis_init !> spherical = cartesian Gaussian for s-functions !> \param basis ... !> \param norm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE basis_norm_s_func(basis,norm,error) + SUBROUTINE basis_norm_s_func(basis,norm) TYPE(gto_basis_set_type), POINTER :: basis REAL(dp), DIMENSION(:), POINTER :: norm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'basis_norm_s_func', & routineP = moduleN//':'//routineN @@ -222,7 +215,7 @@ SUBROUTINE basis_norm_s_func(basis,norm,error) nbas = basis%nsgf ALLOCATE (norm(nbas),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) norm = 0._dp DO iset=1,basis%nset @@ -253,13 +246,11 @@ END SUBROUTINE basis_norm_s_func !> functions !> \param basis ... !> \param norm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE basis_norm_radial(basis,norm,error) + SUBROUTINE basis_norm_radial(basis,norm) TYPE(gto_basis_set_type), POINTER :: basis REAL(dp), DIMENSION(:), POINTER :: norm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'basis_norm_radial', & routineP = moduleN//':'//routineN @@ -273,7 +264,7 @@ SUBROUTINE basis_norm_radial(basis,norm,error) nbas = basis%nsgf ALLOCATE (norm(nbas),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) norm = 0._dp DO iset=1,basis%nset @@ -302,13 +293,11 @@ END SUBROUTINE basis_norm_radial !> \brief normalization solid harmonic Gaussians (SHG) !> \param basis ... !> \param norm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE basis_norm_shg(basis,norm,error) + SUBROUTINE basis_norm_shg(basis,norm) TYPE(gto_basis_set_type), POINTER :: basis REAL(dp), DIMENSION(:, :), POINTER :: norm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'basis_norm_shg', & routineP = moduleN//':'//routineN @@ -346,13 +335,11 @@ END SUBROUTINE basis_norm_shg !> \param basis ... !> \param int_aux ... !> \param norm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE basis_int(basis,int_aux,norm,error) + SUBROUTINE basis_int(basis,int_aux,norm) TYPE(gto_basis_set_type), POINTER :: basis REAL(dp), DIMENSION(:), POINTER :: int_aux, norm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'basis_int', & routineP = moduleN//':'//routineN @@ -364,7 +351,7 @@ SUBROUTINE basis_int(basis,int_aux,norm,error) nbas = basis%nsgf ALLOCATE (int_aux(nbas),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) int_aux = 0._dp DO iset=1,basis%nset @@ -392,14 +379,12 @@ END SUBROUTINE basis_int !> \param basis ... !> \param ovlp ... !> \param norm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE basis_ovlp(basis,ovlp,norm,error) + SUBROUTINE basis_ovlp(basis,ovlp,norm) TYPE(gto_basis_set_type), POINTER :: basis REAL(dp), DIMENSION(:, :), POINTER :: ovlp REAL(dp), DIMENSION(:), POINTER :: norm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'basis_ovlp', & routineP = moduleN//':'//routineN @@ -414,7 +399,7 @@ SUBROUTINE basis_ovlp(basis,ovlp,norm,error) nbas = basis%nsgf ALLOCATE (ovlp(nbas,nbas),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ovlp = 0._dp DO iset=1,basis%nset @@ -459,14 +444,12 @@ END SUBROUTINE basis_ovlp !> \brief contraction matrix for SHG integrals !> \param basis ... !> \param scon_shg contraction matrix -!> \param error ... ! ***************************************************************************** - SUBROUTINE contraction_matrix_shg(basis,scon_shg,error) + SUBROUTINE contraction_matrix_shg(basis,scon_shg) TYPE(gto_basis_set_type), POINTER :: basis REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: scon_shg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'contraction_matrix_shg', & routineP = moduleN//':'//routineN @@ -486,11 +469,11 @@ SUBROUTINE contraction_matrix_shg(basis,scon_shg,error) maxpgf = SIZE(basis%gcc,1) maxshell = SIZE(basis%gcc,2) ALLOCATE(norm(basis%nset,maxshell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(scon_shg(maxpgf,maxshell,nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL basis_norm_shg(basis,norm,error) + CALL basis_norm_shg(basis,norm) DO iset=1,nset DO ishell=1,nshell(iset) @@ -504,7 +487,7 @@ SUBROUTINE contraction_matrix_shg(basis,scon_shg,error) END DO DEALLOCATE(norm,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE contraction_matrix_shg @@ -516,17 +499,15 @@ END SUBROUTINE contraction_matrix_shg !> \param ncg_none0 number of none-zero CG coefficients !> \param maxl1 maximal l quantum number of 1st spherical function !> \param maxl2 maximal l quantum number of 2nd spherical function -!> \param error ... ! ***************************************************************************** SUBROUTINE get_clebsch_gordon_coefficients(my_cg,cg_none0_list,ncg_none0,& - maxl1,maxl2,error) + maxl1,maxl2) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: my_cg INTEGER, DIMENSION(:, :, :), POINTER :: cg_none0_list INTEGER, DIMENSION(:, :), POINTER :: ncg_none0 INTEGER, INTENT(IN) :: maxl1, maxl2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'get_clebsch_gordon_coefficients', & @@ -548,17 +529,17 @@ SUBROUTINE get_clebsch_gordon_coefficients(my_cg,cg_none0_list,ncg_none0,& CALL clebsch_gordon_init(maxl) ALLOCATE(my_cg(nsfunc1,nsfunc2,nsfunc),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) my_cg =0.0_dp ALLOCATE(ncg_none0(nsfunc1,nsfunc2),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ncg_none0 = 0 ALLOCATE(cg_none0_list(nsfunc1,nsfunc2,nlist_max),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) cg_none0_list = 0 ALLOCATE(rga(maxl,2),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) rga = 0.0_dp DO lc1 = 0,maxl1 DO iso1=nsoset(lc1-1)+1,nsoset(lc1) @@ -616,7 +597,7 @@ SUBROUTINE get_clebsch_gordon_coefficients(my_cg,cg_none0_list,ncg_none0,& ENDDO ! lc1 DEALLOCATE(rga,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL clebsch_gordon_deallocate() END SUBROUTINE get_clebsch_gordon_coefficients diff --git a/src/lri_environment_methods.F b/src/lri_environment_methods.F index 4efa9389b2..9747b6cdf6 100644 --- a/src/lri_environment_methods.F +++ b/src/lri_environment_methods.F @@ -92,14 +92,12 @@ MODULE lri_environment_methods !> \param lri_env the lri_environment you want to create !> \param qs_env ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_lri_matrices(lri_env,qs_env,calculate_forces,error) + SUBROUTINE build_lri_matrices(lri_env,qs_env,calculate_forces) TYPE(lri_environment_type), POINTER :: lri_env TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_lri_matrices', & routineP = moduleN//':'//routineN @@ -107,7 +105,7 @@ SUBROUTINE build_lri_matrices(lri_env,qs_env,calculate_forces,error) ! calculate the integrals needed to do the local (2-center) expansion ! of the (pair) densities - CALL calculate_lri_integrals(lri_env,qs_env,calculate_forces,error) + CALL calculate_lri_integrals(lri_env,qs_env,calculate_forces) END SUBROUTINE build_lri_matrices @@ -117,14 +115,12 @@ END SUBROUTINE build_lri_matrices !> \param lri_env ... !> \param qs_env ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_lri_integrals(lri_env,qs_env,calculate_forces,error) + SUBROUTINE calculate_lri_integrals(lri_env,qs_env,calculate_forces) TYPE(lri_environment_type), POINTER :: lri_env TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_lri_integrals', & routineP = moduleN//':'//routineN @@ -156,16 +152,15 @@ SUBROUTINE calculate_lri_integrals(lri_env,qs_env,calculate_forces,error) soo_list => lri_env%soo_list CALL get_qs_env(qs_env=qs_env,cell=cell,dft_control=dft_control,& - nkind=nkind,particle_set=particle_set,virial=virial,& - error=error) + nkind=nkind,particle_set=particle_set,virial=virial) IF ( ASSOCIATED(lri_env%lri_ints) ) THEN - CALL deallocate_lri_ints (lri_env%lri_ints,error) + CALL deallocate_lri_ints (lri_env%lri_ints) END IF ! allocate matrices storing the LRI integrals CALL allocate_lri_ints(lri_env,lri_env%lri_ints,nkind,& - calculate_forces,virial,error) + calculate_forces,virial) lri_ints => lri_env%lri_ints CALL neighbor_list_iterator_create(nl_iterator,soo_list) @@ -204,10 +199,10 @@ SUBROUTINE calculate_lri_integrals(lri_env,qs_env,calculate_forces,error) ! calculate integrals (fa,fb), (a,b), (a,b,fa) and (a,b,fb) IF(lri_env%use_shg_integrals) THEN CALL lri_int_shg(lri_env,lrii,ra,rb,rab,obasa,obasb,fbasa,fbasb,& - iatom,jatom,ikind,jkind,error) + iatom,jatom,ikind,jkind) ELSE CALL lri_int_os(lri_env,lrii,ra,rb,rab,obasa,obasb,fbasa,fbasb,& - iatom,jatom,ikind,error) + iatom,jatom,ikind) ENDIF ! construct and invert S matrix @@ -218,7 +213,7 @@ SUBROUTINE calculate_lri_integrals(lri_env,qs_env,calculate_forces,error) lrii%sinv(nfa+1:nn,1:nfa) = TRANSPOSE(lrii%sab(1:nfa,1:nfb)) lrii%sinv(nfa+1:nn,nfa+1:nn) = lri_env%bas_prop(jkind)%ri_ovlp(1:nfb,1:nfb) ENDIF - CALL inverse_lri_overlap(lri_env,lrii%sinv,error) + CALL inverse_lri_overlap(lri_env,lrii%sinv) ! calculate Sinv*n and n*Sinv*n lrii%n(1:nfa) = lri_env%bas_prop(ikind)%int_fbas(1:nfa) @@ -234,7 +229,7 @@ SUBROUTINE calculate_lri_integrals(lri_env,qs_env,calculate_forces,error) ! calculate derivative of fit coefficients, needed for update of KS matrix IF(.NOT.dft_control%qs_control%lri_optbas) THEN CALL lri_calculate_derivative_acoef(lri_env,lrii,iatom,jatom,nba,nbb,& - nfa,nfb,dab,error) + nfa,nfb,dab) ENDIF END DO @@ -242,7 +237,7 @@ SUBROUTINE calculate_lri_integrals(lri_env,qs_env,calculate_forces,error) CALL neighbor_list_iterator_release(nl_iterator) IF(lri_env%debug) THEN - CALL output_debug_info(lri_env,qs_env,lri_ints,soo_list,error) + CALL output_debug_info(lri_env,qs_env,lri_ints,soo_list) ENDIF END IF @@ -256,13 +251,11 @@ END SUBROUTINE calculate_lri_integrals !> reguired for LRI basis set optimization !> \param lri_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_lri_overlap_aabb(lri_env,qs_env,error) + SUBROUTINE calculate_lri_overlap_aabb(lri_env,qs_env) TYPE(lri_environment_type), POINTER :: lri_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_lri_overlap_aabb', & routineP = moduleN//':'//routineN @@ -294,13 +287,13 @@ SUBROUTINE calculate_lri_overlap_aabb(lri_env,qs_env,error) soo_list => lri_env%soo_list CALL get_qs_env(qs_env=qs_env,nkind=nkind,particle_set=particle_set,& - cell=cell,error=error) + cell=cell) IF ( ASSOCIATED(lri_env%lri_ints_rho) ) THEN - CALL deallocate_lri_ints_rho (lri_env%lri_ints_rho,error) + CALL deallocate_lri_ints_rho (lri_env%lri_ints_rho) END IF - CALL allocate_lri_ints_rho(lri_env,lri_env%lri_ints_rho,nkind,error) + CALL allocate_lri_ints_rho(lri_env,lri_env%lri_ints_rho,nkind) lri_ints_rho => lri_env%lri_ints_rho CALL neighbor_list_iterator_create(nl_iterator,soo_list) @@ -327,7 +320,7 @@ SUBROUTINE calculate_lri_overlap_aabb(lri_env,qs_env,error) ! calculate integrals (aa,bb) CALL lri_int_aabb(lriir%soaabb,obasa,obasb,rab,ra,rb,lri_env%debug,& - lriir%dmax_aabb,error) + lriir%dmax_aabb) END DO @@ -352,10 +345,9 @@ END SUBROUTINE calculate_lri_overlap_aabb !> \param lri_rho_struct ... !> \param atomic_kind_set ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_lri_densities(lri_env,lri_density,qs_env,pmatrix,& - lri_rho_struct,atomic_kind_set,para_env,error) + lri_rho_struct,atomic_kind_set,para_env) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density @@ -366,15 +358,14 @@ SUBROUTINE calculate_lri_densities(lri_env,lri_density,qs_env,pmatrix,& TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_lri_densities', & routineP = moduleN//':'//routineN - CALL calculate_avec(lri_env,lri_density,qs_env,pmatrix,error) + CALL calculate_avec(lri_env,lri_density,qs_env,pmatrix) CALL distribute_lri_density_on_the_grid(lri_env,lri_density,qs_env,& - lri_rho_struct,atomic_kind_set,para_env,error) + lri_rho_struct,atomic_kind_set,para_env) END SUBROUTINE calculate_lri_densities @@ -387,16 +378,14 @@ END SUBROUTINE calculate_lri_densities !> \param lri_density ... !> \param qs_env ... !> \param pmatrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_avec(lri_env,lri_density,qs_env,pmatrix,error) + SUBROUTINE calculate_avec(lri_env,lri_density,qs_env,pmatrix) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: pmatrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_avec', & routineP = moduleN//':'//routineN @@ -426,12 +415,12 @@ SUBROUTINE calculate_avec(lri_env,lri_density,qs_env,pmatrix,error) nspin = SIZE(pmatrix) nkind = lri_env%lri_ints%nkind - CALL lri_density_release(lri_density,error) - CALL lri_density_create(lri_density,error) + CALL lri_density_release(lri_density) + CALL lri_density_create(lri_density) lri_density%nspin = nspin ! allocate structure lri_rhos and vectors tvec and avec - CALL allocate_lri_rhos(lri_env,lri_density%lri_rhos,nspin,nkind,error) + CALL allocate_lri_rhos(lri_env,lri_density%lri_rhos,nspin,nkind) DO ispin = 1, nspin pmat => pmatrix(ispin)%matrix @@ -457,7 +446,7 @@ SUBROUTINE calculate_avec(lri_env,lri_density,qs_env,pmatrix,error) CALL cp_dbcsr_get_block_p(matrix=pmat,row=jatom,col=iatom,block=pbij,found=found) trans = .TRUE. END IF - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) lrho => lri_rho%lri_atom(iac)%lri_node(ilist)%lri_rhoab(jneighbor) lrii => lri_env%lri_ints%lri_atom(iac)%lri_node(ilist)%lri_int(jneighbor) @@ -501,7 +490,7 @@ SUBROUTINE calculate_avec(lri_env,lri_density,qs_env,pmatrix,error) ! solve the linear system of equations ALLOCATE(m(nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) m = 0._dp IF(iatom == jatom.AND.dab < lri_env%delta) THEN m(1:nfa) = lrho%tvec(1:nfa) + lrho%lambda * lrii%n(1:nfa) @@ -513,14 +502,14 @@ SUBROUTINE calculate_avec(lri_env,lri_density,qs_env,pmatrix,error) m(1),1,0.0_dp,lrho%avec,1) ENDIF DEALLOCATE(m,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO CALL neighbor_list_iterator_release(nl_iterator) END DO - CALL set_qs_env(qs_env, lri_density=lri_density, error=error) + CALL set_qs_env(qs_env, lri_density=lri_density) END IF @@ -539,10 +528,9 @@ END SUBROUTINE calculate_avec !> \param lri_rho_struct ... !> \param atomic_kind_set ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE distribute_lri_density_on_the_grid(lri_env,lri_density,qs_env,& - lri_rho_struct,atomic_kind_set,para_env,error) + lri_rho_struct,atomic_kind_set,para_env) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density @@ -551,7 +539,6 @@ SUBROUTINE distribute_lri_density_on_the_grid(lri_env,lri_density,qs_env,& TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'distribute_lri_density_on_the_grid', & @@ -587,12 +574,12 @@ SUBROUTINE distribute_lri_density_on_the_grid(lri_env,lri_density,qs_env,& CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,natom=nat) ALLOCATE(atom_of_kind(nat),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind) ! allocate the arrays to hold RI expansion coefficients lri_coefs - CALL allocate_lri_coefs(lri_env,lri_density,atomic_kind_set,error) + CALL allocate_lri_coefs(lri_env,lri_density,atomic_kind_set) DO ispin = 1, nspin lri_coef => lri_density%lri_coefs(ispin)%lri_kinds @@ -643,18 +630,18 @@ SUBROUTINE distribute_lri_density_on_the_grid(lri_env,lri_density,qs_env,& !distribute fitted density on the grid CALL qs_rho_get(lri_rho_struct, rho_r=rho_r, rho_g=rho_g,& - tot_rho_r=tot_rho_r, error=error) + tot_rho_r=tot_rho_r) DO ispin=1,nspin CALL calculate_lri_rho_elec(rho_g(ispin),& rho_r(ispin), qs_env, & lri_density%lri_coefs(ispin)%lri_kinds,& - tot_rho_r(ispin), error) + tot_rho_r(ispin)) ENDDO - CALL set_qs_env(qs_env, lri_density=lri_density, error=error) + CALL set_qs_env(qs_env, lri_density=lri_density) DEALLOCATE(atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -677,17 +664,15 @@ END SUBROUTINE distribute_lri_density_on_the_grid !> \param iatom index atom A !> \param jatom index atom B !> \param ikind kind atom A -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_os(lri_env,lrii,ra,rb,rab,obasa,obasb,fbasa,fbasb,& - iatom,jatom,ikind,error) + iatom,jatom,ikind) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_int_type), POINTER :: lrii REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: ra, rb, rab TYPE(gto_basis_set_type), POINTER :: obasa, obasb, fbasa, fbasb INTEGER, INTENT(IN) :: iatom, jatom, ikind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_os', & routineP = moduleN//':'//routineN @@ -714,26 +699,24 @@ SUBROUTINE lri_int_os(lri_env,lrii,ra,rb,rab,obasa,obasb,fbasa,fbasb,& !*** (a,a,fa) CALL lri_int_aba(lrii%abaint,ra=ra,rb=rb,rab=rab,oba=obasa,obb=obasb,& fba=fbasa, calculate_forces=.FALSE.,debug=lri_env%debug,& - dmax=lrii%dmax_aba,error=error) + dmax=lrii%dmax_aba) lrii%dabdaint = 0.0_dp lrii%dabbint = 0.0_dp ELSE !*** (fa,fb) CALL lri_int_ab(lrii%sab,lrii%dsab,ra,rb,rab,fbasa,fbasb,& lrii%calc_force_pair,lri_env%debug,& - lrii%dmax_ab,error) + lrii%dmax_ab) !*** (a,b) CALL lri_int_ab(lrii%soo,lrii%dsoo,ra,rb,rab,obasa,obasb,& lrii%calc_force_pair,lri_env%debug,& - lrii%dmax_oo,error=error) + lrii%dmax_oo) !*** (a,b,fa) CALL lri_int_aba(lrii%abaint,lrii%dabdaint,ra,rb,rab,obasa,obasb,fbasa,& - lrii%calc_force_pair,lri_env%debug,lrii%dmax_aba,& - error=error) + lrii%calc_force_pair,lri_env%debug,lrii%dmax_aba) !*** (a,b,fb) CALL lri_int_abb(lrii%abbint,lrii%dabbint,ra,rb,rab,obasa,obasb,fbasb,& - lrii%calc_force_pair,lri_env%debug,lrii%dmax_abb,& - error=error) + lrii%calc_force_pair,lri_env%debug,lrii%dmax_abb) ENDIF CALL timestop(handle) @@ -755,17 +738,15 @@ END SUBROUTINE lri_int_os !> \param jatom index atom B !> \param ikind kind atom A !> \param jkind kind atom B -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_shg(lri_env,lrii,ra,rb,rab,obasa,obasb,fbasa,fbasb,& - iatom,jatom,ikind,jkind,error) + iatom,jatom,ikind,jkind) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_int_type), POINTER :: lrii REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: ra, rb, rab TYPE(gto_basis_set_type), POINTER :: obasa, obasb, fbasa, fbasb INTEGER, INTENT(IN) :: iatom, jatom, ikind, jkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_shg', & routineP = moduleN//':'//routineN @@ -803,7 +784,7 @@ SUBROUTINE lri_int_shg(lri_env,lrii,ra,rb,rab,obasa,obasb,fbasa,fbasb,& !*** (a,a,fa) CALL lri_int_aba(lrii%abaint,ra=ra,rb=rb,rab=rab,oba=obasa,obb=obasb,& fba=fbasa, calculate_forces=.FALSE.,debug=lri_env%debug,& - dmax=lrii%dmax_aba,error=error) + dmax=lrii%dmax_aba) lrii%dabdaint = 0.0_dp lrii%dabbint = 0.0_dp ELSE @@ -812,23 +793,23 @@ SUBROUTINE lri_int_shg(lri_env,lrii,ra,rb,rab,obasa,obasb,fbasa,fbasb,& scon_ria => lri_env%bas_prop(ikind)%scon_ri scon_rib => lri_env%bas_prop(jkind)%scon_ri CALL precalc_angular_shg_part(obasa,obasb,fbasa,fbasb,rab,Waux_mat,dWaux_mat,& - lrii%calc_force_pair,error) + lrii%calc_force_pair) !*** (fa,fb) CALL lri_int_ab_shg(lrii%sab,lrii%dsab,rab,fbasa,fbasb,scon_ria,scon_rib,& - Waux_mat,dWaux_mat,lrii%calc_force_pair,error) + Waux_mat,dWaux_mat,lrii%calc_force_pair) !*** (a,b) CALL lri_int_ab_shg(lrii%soo,lrii%dsoo,rab,obasa,obasb,scon_orba,scon_orbb,& - Waux_mat,dWaux_mat,lrii%calc_force_pair,error) + Waux_mat,dWaux_mat,lrii%calc_force_pair) !*** (a,b,fa) CALL lri_int_aba_shg(lri_env,lrii%abaint,lrii%dabdaint,rab,obasa,obasb,fbasa,& scon_orba,scon_orbb,scon_ria,Waux_mat,dWaux_mat,& - lrii%calc_force_pair,error=error) + lrii%calc_force_pair) !*** (a,b,fb) CALL lri_int_abb_shg(lri_env,lrii%abbint,lrii%dabbint,rab,obasa,obasb,fbasb,& scon_orba,scon_orbb,scon_rib,Waux_mat,dWaux_mat,& - lrii%calc_force_pair,error=error) + lrii%calc_force_pair) DEALLOCATE(Waux_mat,dWaux_mat,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle) @@ -850,17 +831,15 @@ END SUBROUTINE lri_int_shg !> \param nfa number of ri basis functions on a !> \param nfb number of ri basis functions on b !> \param dab distance between center a and b -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_calculate_derivative_acoef(lri_env,lrii,iatom,jatom,nba,nbb,& - nfa,nfb,dab,error) + nfa,nfb,dab) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_int_type), POINTER :: lrii INTEGER, INTENT(IN) :: iatom, jatom, nba, nbb, nfa, & nfb REAL(KIND=dp), INTENT(IN) :: dab - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'lri_calculate_derivative_acoef', & @@ -879,13 +858,13 @@ SUBROUTINE lri_calculate_derivative_acoef(lri_env,lrii,iatom,jatom,nba,nbb,& nn = nfa + nfb ALLOCATE(R(nba,nbb,nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dlambdadp(nba,nbb),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Q(nba,nbb,nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(abxint_work(nba,nbb,nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) R(:,:,:) = 0._dp dlambdadp = 0._dp @@ -921,13 +900,13 @@ SUBROUTINE lri_calculate_derivative_acoef(lri_env,lrii,iatom,jatom,nba,nbb,& ENDIF DEALLOCATE(abxint_work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(R,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dlambdadp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Q,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -937,13 +916,11 @@ END SUBROUTINE lri_calculate_derivative_acoef !> \brief get inverse or pseudoinverse of lri overlap matrix for aux basis set !> \param lri_env lri environment !> \param sinv on entry overlap matrix, on exit its inverse -!> \param error ... ! ***************************************************************************** - SUBROUTINE inverse_lri_overlap(lri_env,sinv,error) + SUBROUTINE inverse_lri_overlap(lri_env,sinv) TYPE(lri_environment_type) :: lri_env REAL(KIND=dp), DIMENSION(:, :), POINTER :: sinv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'inverse_lri_overlap', & routineP = moduleN//':'//routineN @@ -966,28 +943,28 @@ SUBROUTINE inverse_lri_overlap(lri_env,sinv,error) SELECT CASE(lri_env%lri_overlap_inv) CASE(do_lri_inv) - CALL invmat_symm(sinv,error=error) + CALL invmat_symm(sinv) CASE(do_lri_pseudoinv_svd) ALLOCATE(s(n,n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) s(:,:) = sinv - CALL get_pseudo_inverse_svd(s,sinv,rskip,error) + CALL get_pseudo_inverse_svd(s,sinv,rskip) DEALLOCATE(s,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(do_lri_pseudoinv_diag) ALLOCATE(s(n,n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) s(:,:) = sinv - CALL get_pseudo_inverse_diag(s,sinv,rskip,error) + CALL get_pseudo_inverse_diag(s,sinv,rskip) DEALLOCATE(s,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(do_lri_inv_auto) ! decide whether to calculate inverse or pseudoinverse ALLOCATE(s(n,n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) s(:,:) = sinv ALLOCATE(work(3*n),iwork(n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! norm of matrix anorm = dlange('1',n,n,sinv,n,work) ! Cholesky factorization (fails if matrix not positive definite) @@ -999,15 +976,15 @@ SUBROUTINE inverse_lri_overlap(lri_env,sinv,error) CALL stop_program(routineN,moduleN,__LINE__,"DPOCON failed") ENDIF IF(LOG(1._dp/rcond) > lri_env%cond_max) THEN - CALL get_pseudo_inverse_svd(s,sinv,rskip,error) + CALL get_pseudo_inverse_svd(s,sinv,rskip) ELSE - CALL invmat_symm(sinv,"U",error) + CALL invmat_symm(sinv,"U") ENDIF ELSE - CALL get_pseudo_inverse_svd(s,sinv,rskip,error) + CALL get_pseudo_inverse_svd(s,sinv,rskip) END IF DEALLOCATE(s,work,iwork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE DEFAULT CALL cp_assert(.FALSE.,cp_fatal_level,cp_assertion_failed,& routineP,"No initialization for LRI overlap available?",& @@ -1024,16 +1001,14 @@ END SUBROUTINE inverse_lri_overlap !> \param qs_env ... !> \param lri_ints ... !> \param soo_list ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE output_debug_info(lri_env,qs_env,lri_ints,soo_list,error) + SUBROUTINE output_debug_info(lri_env,qs_env,lri_ints,soo_list) TYPE(lri_environment_type), POINTER :: lri_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(lri_list_type), POINTER :: lri_ints TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: soo_list - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'output_debug_info', & routineP = moduleN//':'//routineN @@ -1054,7 +1029,7 @@ SUBROUTINE output_debug_info(lri_env,qs_env,lri_ints,soo_list,error) CALL timeset(routineN,handle) NULLIFY(input, logger, lrii, lriir, nl_iterator, para_env) CALL get_qs_env(qs_env,dft_control=dft_control,input=input,nkind=nkind,& - para_env=para_env,error=error) + para_env=para_env) dmax_ab = 0._dp dmax_oo = 0._dp dmax_aba = 0._dp @@ -1089,9 +1064,9 @@ SUBROUTINE output_debug_info(lri_env,qs_env,lri_ints,soo_list,error) CALL mp_max(dmax_abb,para_env%group) CALL mp_max(dmax_aabb,para_env%group) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iunit=cp_print_key_unit_nr(logger,input,"PRINT%PROGRAM_RUN_INFO",& - extension=".lridebug",error=error) + extension=".lridebug") IF (iunit > 0) THEN WRITE(iunit,FMT="(/,T2,A)") "DEBUG INFO FOR LRI INTEGRALS" @@ -1111,7 +1086,7 @@ SUBROUTINE output_debug_info(lri_env,qs_env,lri_ints,soo_list,error) ENDIF CALL cp_print_key_finished_output(iunit,logger,input,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE output_debug_info diff --git a/src/lri_environment_types.F b/src/lri_environment_types.F index 87c2d9ee20..7bb84cab5a 100644 --- a/src/lri_environment_types.F +++ b/src/lri_environment_types.F @@ -262,13 +262,10 @@ MODULE lri_environment_types ! ***************************************************************************** !> \brief creates and initializes an lri_env !> \param lri_env the lri_environment you want to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE lri_env_create (lri_env, error) + SUBROUTINE lri_env_create (lri_env) TYPE(lri_environment_type), POINTER :: lri_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_env_create', & routineP = moduleN//':'//routineN @@ -276,7 +273,7 @@ SUBROUTINE lri_env_create (lri_env, error) INTEGER :: stat ALLOCATE ( lri_env, stat=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) last_lri_env_id=last_lri_env_id+1 lri_env%id_nr=last_lri_env_id @@ -296,20 +293,17 @@ SUBROUTINE lri_env_create (lri_env, error) NULLIFY(lri_env%cg_shg) ALLOCATE ( lri_env%cg_shg, stat=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END SUBROUTINE lri_env_create ! ***************************************************************************** !> \brief releases the given lri_env !> \param lri_env the lri environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE lri_env_release(lri_env, error) + SUBROUTINE lri_env_release(lri_env) TYPE(lri_environment_type), POINTER :: lri_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lri_env_release', & routineP = moduleN//':'//routineN @@ -326,45 +320,45 @@ SUBROUTINE lri_env_release(lri_env, error) IF(ASSOCIATED(lri_env%orb_basis)) THEN nkind = SIZE(lri_env%orb_basis) DO ikind=1,nkind - CALL deallocate_gto_basis_set(lri_env%orb_basis(ikind)%gto_basis_set,error) + CALL deallocate_gto_basis_set(lri_env%orb_basis(ikind)%gto_basis_set) END DO DEALLOCATE(lri_env%orb_basis,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF(ASSOCIATED(lri_env%ri_basis)) THEN nkind = SIZE(lri_env%ri_basis) DO ikind=1,nkind - CALL deallocate_gto_basis_set(lri_env%ri_basis(ikind)%gto_basis_set,error) + CALL deallocate_gto_basis_set(lri_env%ri_basis(ikind)%gto_basis_set) END DO DEALLOCATE(lri_env%ri_basis,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(lri_env%soo_list)) THEN DO i=1,SIZE(lri_env%soo_list) CALL deallocate_neighbor_list_set(lri_env%soo_list(i)%neighbor_list_set) END DO DEALLOCATE(lri_env%soo_list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(lri_env%lri_ints)) THEN - CALL deallocate_lri_ints(lri_env%lri_ints,error) + CALL deallocate_lri_ints(lri_env%lri_ints) END IF IF (ASSOCIATED(lri_env%lri_ints_rho)) THEN - CALL deallocate_lri_ints_rho(lri_env%lri_ints_rho,error) + CALL deallocate_lri_ints_rho(lri_env%lri_ints_rho) END IF - CALL deallocate_bas_properties(lri_env,error) + CALL deallocate_bas_properties(lri_env) IF (ASSOCIATED(lri_env%cg_shg)) THEN DEALLOCATE(lri_env%cg_shg%cg_coeff,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(lri_env%cg_shg%cg_none0_list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(lri_env%cg_shg%ncg_none0,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(lri_env%cg_shg,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF DEALLOCATE(lri_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF NULLIFY(lri_env) @@ -373,13 +367,10 @@ END SUBROUTINE lri_env_release ! ***************************************************************************** !> \brief creates and initializes an lri_density environment !> \param lri_density the lri_density environment you want to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE lri_density_create(lri_density, error) + SUBROUTINE lri_density_create(lri_density) TYPE(lri_density_type), POINTER :: lri_density - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_density_create', & routineP = moduleN//':'//routineN @@ -387,7 +378,7 @@ SUBROUTINE lri_density_create(lri_density, error) INTEGER :: stat ALLOCATE ( lri_density, stat=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) last_lri_density_id=last_lri_density_id+1 lri_density%id_nr=last_lri_density_id @@ -405,12 +396,9 @@ END SUBROUTINE lri_density_create ! ***************************************************************************** !> \brief releases the given lri_density !> \param lri_density the lri_density to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE lri_density_release(lri_density, error) + SUBROUTINE lri_density_release(lri_density) TYPE(lri_density_type), POINTER :: lri_density - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lri_density_release', & routineP = moduleN//':'//routineN @@ -423,12 +411,12 @@ SUBROUTINE lri_density_release(lri_density, error) IF (ASSOCIATED(lri_density)) THEN lri_density%ref_count=0 - CALL deallocate_lri_rhos(lri_density%lri_rhos,error) - CALL deallocate_lri_coefs(lri_density%lri_coefs, error) - CALL deallocate_lri_force_components(lri_density%lri_force, error) + CALL deallocate_lri_rhos(lri_density%lri_rhos) + CALL deallocate_lri_coefs(lri_density%lri_coefs) + CALL deallocate_lri_force_components(lri_density%lri_force) DEALLOCATE(lri_density,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF NULLIFY(lri_density) @@ -441,17 +429,15 @@ END SUBROUTINE lri_density_release !> \param nkind number of atom kinds !> \param calculate_forces ... !> \param virial ... -!> \param error variable to control error logging, stopping,... ! ***************************************************************************** SUBROUTINE allocate_lri_ints(lri_env,lri_ints,nkind,calculate_forces,& - virial,error) + virial) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_list_type), POINTER :: lri_ints INTEGER, INTENT(IN) :: nkind LOGICAL, INTENT(IN) :: calculate_forces TYPE(virial_type), POINTER :: virial - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_lri_ints', & routineP = moduleN//':'//routineN @@ -473,11 +459,11 @@ SUBROUTINE allocate_lri_ints(lri_env,lri_ints,nkind,calculate_forces,& use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ALLOCATE(lri_ints,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_ints%nkind = nkind ALLOCATE(lri_ints%lri_atom(nkind*nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nkind*nkind NULLIFY(lri_ints%lri_atom(i)%lri_node) @@ -505,7 +491,7 @@ SUBROUTINE allocate_lri_ints(lri_env,lri_ints,nkind,calculate_forces,& IF(.NOT.ASSOCIATED(lri_ints%lri_atom(iac)%lri_node)) THEN lri_ints%lri_atom(iac)%natom = nlist ALLOCATE(lri_ints%lri_atom(iac)%lri_node(nlist),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nlist NULLIFY(lri_ints%lri_atom(iac)%lri_node(i)%lri_int) lri_ints%lri_atom(iac)%lri_node(i)%nnode = 0 @@ -514,7 +500,7 @@ SUBROUTINE allocate_lri_ints(lri_env,lri_ints,nkind,calculate_forces,& IF(.NOT.ASSOCIATED(lri_ints%lri_atom(iac)%lri_node(ilist)%lri_int)) THEN lri_ints%lri_atom(iac)%lri_node(ilist)%nnode = nneighbor ALLOCATE(lri_ints%lri_atom(iac)%lri_node(ilist)%lri_int(nneighbor),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF lrii => lri_ints%lri_atom(iac)%lri_node(ilist)%lri_int(jneighbor) @@ -527,51 +513,51 @@ SUBROUTINE allocate_lri_ints(lri_env,lri_ints,nkind,calculate_forces,& ALLOCATE(lrii%abaint(nba,nbb,nfa),& lrii%abbint(nba,nbb,nfb),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lrii%abaint = 0._dp lrii%abbint = 0._dp ALLOCATE(lrii%dabdaint(nba,nbb,nfa,3),& lrii%dabbint(nba,nbb,nfb,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lrii%dabdaint = 0._dp lrii%dabbint = 0._dp ALLOCATE(lrii%sab(nfa,nfb),lrii%dsab(nfa,nfb,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lrii%sab = 0._dp lrii%dsab = 0._dp IF(iatom == jatom.AND.dab < lri_env%delta) THEN ALLOCATE(lrii%sinv(nfa,nfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(lrii%sinv(nn,nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF lrii%sinv = 0._dp IF(iatom == jatom.AND.dab < lri_env%delta) THEN ALLOCATE(lrii%n(nfa),lrii%sn(nfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(lrii%n(nn),lrii%sn(nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF lrii%n = 0._dp lrii%sn = 0._dp ALLOCATE(lrii%soo(nba,nbb),lrii%dsoo(nba,nbb,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lrii%soo = 0._dp lrii%dsoo = 0._dp IF(iatom == jatom.AND.dab < lri_env%delta) THEN ALLOCATE(lrii%dacoef(nba,nbb,nfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(lrii%dacoef(nba,nbb,nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF lrii%dacoef = 0._dp @@ -608,14 +594,12 @@ END SUBROUTINE allocate_lri_ints !> \param lri_env ... !> \param lri_ints_rho structure storing the integrals (aa,bb) !> \param nkind number of atom kinds -!> \param error variable to control error logging, stopping,... ! ***************************************************************************** - SUBROUTINE allocate_lri_ints_rho(lri_env,lri_ints_rho,nkind,error) + SUBROUTINE allocate_lri_ints_rho(lri_env,lri_ints_rho,nkind) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_list_type), POINTER :: lri_ints_rho INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_lri_ints_rho', & routineP = moduleN//':'//routineN @@ -630,11 +614,11 @@ SUBROUTINE allocate_lri_ints_rho(lri_env,lri_ints_rho,nkind,error) DIMENSION(:), POINTER :: nl_iterator ALLOCATE(lri_ints_rho,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_ints_rho%nkind = nkind ALLOCATE(lri_ints_rho%lri_atom(nkind*nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nkind*nkind NULLIFY(lri_ints_rho%lri_atom(i)%lri_node) @@ -659,7 +643,7 @@ SUBROUTINE allocate_lri_ints_rho(lri_env,lri_ints_rho,nkind,error) IF(.NOT.ASSOCIATED(lri_ints_rho%lri_atom(iac)%lri_node)) THEN lri_ints_rho%lri_atom(iac)%natom = nlist ALLOCATE(lri_ints_rho%lri_atom(iac)%lri_node(nlist),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nlist NULLIFY(lri_ints_rho%lri_atom(iac)%lri_node(i)%lri_int_rho) lri_ints_rho%lri_atom(iac)%lri_node(i)%nnode = 0 @@ -668,7 +652,7 @@ SUBROUTINE allocate_lri_ints_rho(lri_env,lri_ints_rho,nkind,error) IF(.NOT.ASSOCIATED(lri_ints_rho%lri_atom(iac)%lri_node(ilist)%lri_int_rho)) THEN lri_ints_rho%lri_atom(iac)%lri_node(ilist)%nnode = nneighbor ALLOCATE(lri_ints_rho%lri_atom(iac)%lri_node(ilist)%lri_int_rho(nneighbor),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF lriir => lri_ints_rho%lri_atom(iac)%lri_node(ilist)%lri_int_rho(jneighbor) @@ -677,7 +661,7 @@ SUBROUTINE allocate_lri_ints_rho(lri_env,lri_ints_rho,nkind,error) nbb = obasb%nsgf ALLOCATE(lriir%soaabb(nba,nba,nbb,nbb),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lriir%soaabb = 0._dp lriir%dmax_aabb = 0._dp @@ -693,15 +677,13 @@ END SUBROUTINE allocate_lri_ints_rho !> \param lri_rhos structure storing tvec and avec !> \param nspin ... !> \param nkind number of atom kinds -!> \param error variable to control error logging, stopping,... ! ***************************************************************************** - SUBROUTINE allocate_lri_rhos(lri_env,lri_rhos,nspin,nkind,error) + SUBROUTINE allocate_lri_rhos(lri_env,lri_rhos,nspin,nkind) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_list_p_type), DIMENSION(:), & POINTER :: lri_rhos INTEGER, INTENT(IN) :: nspin, nkind - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_lri_rhos', & routineP = moduleN//':'//routineN @@ -722,16 +704,16 @@ SUBROUTINE allocate_lri_rhos(lri_env,lri_rhos,nspin,nkind,error) NULLIFY(lri_rho, lrho, lrii, nl_iterator) ALLOCATE(lri_rhos(nspin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1, nspin ALLOCATE(lri_rhos(ispin)%lri_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_rhos(ispin)%lri_list%nkind = nkind ALLOCATE(lri_rhos(ispin)%lri_list%lri_atom(nkind*nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nkind*nkind NULLIFY(lri_rhos(ispin)%lri_list%lri_atom(i)%lri_node) @@ -754,7 +736,7 @@ SUBROUTINE allocate_lri_rhos(lri_env,lri_rhos,nspin,nkind,error) IF(.NOT.ASSOCIATED(lri_rho%lri_atom(iac)%lri_node)) THEN lri_rho%lri_atom(iac)%natom = nlist ALLOCATE(lri_rho%lri_atom(iac)%lri_node(nlist),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nlist NULLIFY(lri_rho%lri_atom(iac)%lri_node(i)%lri_rhoab) lri_rho%lri_atom(iac)%lri_node(i)%nnode = 0 @@ -763,7 +745,7 @@ SUBROUTINE allocate_lri_rhos(lri_env,lri_rhos,nspin,nkind,error) IF(.NOT.ASSOCIATED(lri_rho%lri_atom(iac)%lri_node(ilist)%lri_rhoab)) THEN lri_rho%lri_atom(iac)%lri_node(ilist)%nnode = nneighbor ALLOCATE(lri_rho%lri_atom(iac)%lri_node(ilist)%lri_rhoab(nneighbor),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF lrho => lri_rho%lri_atom(iac)%lri_node(ilist)%lri_rhoab(jneighbor) @@ -780,14 +762,14 @@ SUBROUTINE allocate_lri_rhos(lri_env,lri_rhos,nspin,nkind,error) IF(iatom == jatom.AND.dab < lri_env%delta) THEN ALLOCATE(lrho%avec(nfa), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(lrho%tvec(nfa), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(lrho%avec(nn), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(lrho%tvec(nn), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF lrho%avec = 0._dp lrho%tvec = 0._dp @@ -805,15 +787,13 @@ END SUBROUTINE allocate_lri_rhos !> \param lri_env ... !> \param lri_density ... !> \param atomic_kind_set ... -!> \param error variable to control error logging, stopping,... ! ***************************************************************************** - SUBROUTINE allocate_lri_coefs(lri_env, lri_density, atomic_kind_set, error) + SUBROUTINE allocate_lri_coefs(lri_env, lri_density, atomic_kind_set) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_lri_coefs', & routineP = moduleN//':'//routineN @@ -832,12 +812,12 @@ SUBROUTINE allocate_lri_coefs(lri_env, lri_density, atomic_kind_set, error) nspin = lri_density%nspin ALLOCATE(lri_density%lri_coefs(nspin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_coefs => lri_density%lri_coefs DO ispin =1, nspin ALLOCATE(lri_density%lri_coefs(ispin)%lri_kinds(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind NULLIFY(lri_coefs(ispin)%lri_kinds(ikind)%acoef) NULLIFY(lri_coefs(ispin)%lri_kinds(ikind)%v_int) @@ -848,16 +828,16 @@ SUBROUTINE allocate_lri_coefs(lri_env, lri_density, atomic_kind_set, error) fbas => lri_env%ri_basis(ikind)%gto_basis_set nsgf = fbas%nsgf ALLOCATE(lri_coefs(ispin)%lri_kinds(ikind)%acoef(natom,nsgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_coefs(ispin)%lri_kinds(ikind)%acoef = 0._dp ALLOCATE(lri_coefs(ispin)%lri_kinds(ikind)%v_int(natom,nsgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_coefs(ispin)%lri_kinds(ikind)%v_int = 0._dp ALLOCATE(lri_coefs(ispin)%lri_kinds(ikind)%v_dadr(natom,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_coefs(ispin)%lri_kinds(ikind)%v_dadr = 0._dp ALLOCATE(lri_coefs(ispin)%lri_kinds(ikind)%v_dfdr(natom,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_coefs(ispin)%lri_kinds(ikind)%v_dfdr = 0._dp END DO ENDDO @@ -869,13 +849,11 @@ END SUBROUTINE allocate_lri_coefs !> \param lri_force ... !> \param nfa and nfb number of fit functions on a/b !> \param nfb ... -!> \param error variable to control error logging, stopping,... ! ***************************************************************************** - SUBROUTINE allocate_lri_force_components(lri_force,nfa,nfb,error) + SUBROUTINE allocate_lri_force_components(lri_force,nfa,nfb) TYPE(lri_force_type), POINTER :: lri_force INTEGER, INTENT(IN) :: nfa, nfb - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'allocate_lri_force_components', & @@ -890,34 +868,34 @@ SUBROUTINE allocate_lri_force_components(lri_force,nfa,nfb,error) IF(.NOT.ASSOCIATED(lri_force)) THEN ALLOCATE(lri_force,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(lri_force%ds(nn,nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%ds = 0._dp ALLOCATE(lri_force%st(nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%st = 0._dp ALLOCATE(lri_force%dsst(nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%dsst = 0._dp ALLOCATE(lri_force%sdsst(nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%sdsst = 0._dp ALLOCATE(lri_force%dssn(nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%dssn = 0._dp ALLOCATE(lri_force%sdssn(nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%sdssn = 0._dp ALLOCATE(lri_force%sdt(nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%sdt = 0._dp ALLOCATE(lri_force%davec(nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%davec = 0._dp ALLOCATE(lri_force%dtvec(nn,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lri_force%dtvec = 0._dp ENDIF @@ -927,13 +905,10 @@ END SUBROUTINE allocate_lri_force_components !> \brief deallocates one-center overlap integrals, integral of ri basis !> and scon matrices !> \param lri_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE deallocate_bas_properties (lri_env,error) + SUBROUTINE deallocate_bas_properties (lri_env) TYPE(lri_environment_type), POINTER :: lri_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_bas_properties', & routineP = moduleN//':'//routineN @@ -943,18 +918,18 @@ SUBROUTINE deallocate_bas_properties (lri_env,error) IF (ASSOCIATED(lri_env%bas_prop)) THEN DO i=1,SIZE(lri_env%bas_prop) DEALLOCATE(lri_env%bas_prop(i)%int_fbas,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(lri_env%bas_prop(i)%ri_ovlp,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(lri_env%bas_prop(i)%orb_ovlp,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(lri_env%bas_prop(i)%scon_ri,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(lri_env%bas_prop(i)%scon_orb,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO DEALLOCATE(lri_env%bas_prop,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE deallocate_bas_properties @@ -962,13 +937,10 @@ END SUBROUTINE deallocate_bas_properties ! ***************************************************************************** !> \brief deallocates the given lri_ints !> \param lri_ints ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE deallocate_lri_ints (lri_ints,error) + SUBROUTINE deallocate_lri_ints (lri_ints) TYPE(lri_list_type), POINTER :: lri_ints - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_lri_ints', & routineP = moduleN//':'//routineN @@ -977,7 +949,7 @@ SUBROUTINE deallocate_lri_ints (lri_ints,error) nkind, nnode, stat LOGICAL :: failure - CPPrecondition(ASSOCIATED(lri_ints),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(lri_ints),cp_failure_level,routineP,failure) nkind = lri_ints%nkind IF(nkind > 0) THEN @@ -1002,35 +974,32 @@ SUBROUTINE deallocate_lri_ints (lri_ints,error) lri_ints%lri_atom(ijkind)%lri_node(iatom)%lri_int(inode)%n,& lri_ints%lri_atom(ijkind)%lri_node(iatom)%lri_int(inode)%sn,& STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE (lri_ints%lri_atom(ijkind)%lri_node(iatom)%lri_int,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END DO DEALLOCATE (lri_ints%lri_atom(ijkind)%lri_node,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (lri_ints%lri_atom,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (lri_ints,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_lri_ints ! ***************************************************************************** !> \brief deallocates the given lri_ints_rho !> \param lri_ints_rho ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE deallocate_lri_ints_rho (lri_ints_rho,error) + SUBROUTINE deallocate_lri_ints_rho (lri_ints_rho) TYPE(lri_list_type), POINTER :: lri_ints_rho - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_lri_ints_rho', & routineP = moduleN//':'//routineN @@ -1039,7 +1008,7 @@ SUBROUTINE deallocate_lri_ints_rho (lri_ints_rho,error) nkind, nnode, stat LOGICAL :: failure - CPPrecondition(ASSOCIATED(lri_ints_rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(lri_ints_rho),cp_failure_level,routineP,failure) nkind = lri_ints_rho%nkind IF(nkind > 0) THEN @@ -1053,36 +1022,33 @@ SUBROUTINE deallocate_lri_ints_rho (lri_ints_rho,error) DO inode = 1,nnode DEALLOCATE (lri_ints_rho%lri_atom(ijkind)%lri_node(iatom)%lri_int_rho(inode)%soaabb,& STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE (lri_ints_rho%lri_atom(ijkind)%lri_node(iatom)%lri_int_rho,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END DO DEALLOCATE (lri_ints_rho%lri_atom(ijkind)%lri_node,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (lri_ints_rho%lri_atom,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (lri_ints_rho,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_lri_ints_rho ! ***************************************************************************** !> \brief deallocates the given lri_rhos !> \param lri_rhos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE deallocate_lri_rhos(lri_rhos,error) + SUBROUTINE deallocate_lri_rhos(lri_rhos) TYPE(lri_list_p_type), DIMENSION(:), & POINTER :: lri_rhos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_lri_rhos', & routineP = moduleN//':'//routineN @@ -1100,7 +1066,7 @@ SUBROUTINE deallocate_lri_rhos(lri_rhos,error) DO i=1,SIZE(lri_rhos) lri_rho => lri_rhos(i)%lri_list - CPPrecondition(ASSOCIATED(lri_rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(lri_rho),cp_failure_level,routineP,failure) nkind = lri_rho%nkind IF(nkind > 0) THEN @@ -1115,26 +1081,26 @@ SUBROUTINE deallocate_lri_rhos(lri_rhos,error) DEALLOCATE (lri_rho%lri_atom(ijkind)%lri_node(iatom)%lri_rhoab(inode)%avec,& lri_rho%lri_atom(ijkind)%lri_node(iatom)%lri_rhoab(inode)%tvec,& STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE (lri_rho%lri_atom(ijkind)%lri_node(iatom)%lri_rhoab,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END DO DEALLOCATE (lri_rho%lri_atom(ijkind)%lri_node,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (lri_rho%lri_atom,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (lri_rho,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(lri_rhos,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF @@ -1143,13 +1109,10 @@ END SUBROUTINE deallocate_lri_rhos ! ***************************************************************************** !> \brief releases the given lri_coefs !> \param lri_coefs the integral storage environment that is released -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE deallocate_lri_coefs(lri_coefs,error) + SUBROUTINE deallocate_lri_coefs(lri_coefs) TYPE(lri_spin_type), DIMENSION(:), & POINTER :: lri_coefs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_lri_coefs', & routineP = moduleN//':'//routineN @@ -1164,26 +1127,26 @@ SUBROUTINE deallocate_lri_coefs(lri_coefs,error) DO j=1,SIZE(lri_coefs(i)%lri_kinds) IF(ASSOCIATED(lri_coefs(i)%lri_kinds(j)%acoef)) THEN DEALLOCATE(lri_coefs(i)%lri_kinds(j)%acoef,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_coefs(i)%lri_kinds(j)%v_int)) THEN DEALLOCATE(lri_coefs(i)%lri_kinds(j)%v_int,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_coefs(i)%lri_kinds(j)%v_dadr)) THEN DEALLOCATE(lri_coefs(i)%lri_kinds(j)%v_dadr,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_coefs(i)%lri_kinds(j)%v_dfdr)) THEN DEALLOCATE(lri_coefs(i)%lri_kinds(j)%v_dfdr,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ENDDO DEALLOCATE(lri_coefs(i)%lri_kinds,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO DEALLOCATE(lri_coefs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF NULLIFY(lri_coefs) @@ -1192,13 +1155,10 @@ END SUBROUTINE deallocate_lri_coefs ! ***************************************************************************** !> \brief releases the given lri_force_type !> \param lri_force the integral storage environment that is released -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE deallocate_lri_force_components(lri_force,error) + SUBROUTINE deallocate_lri_force_components(lri_force) TYPE(lri_force_type), POINTER :: lri_force - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'deallocate_lri_force_components', & @@ -1213,43 +1173,43 @@ SUBROUTINE deallocate_lri_force_components(lri_force,error) IF(ASSOCIATED(lri_force%st)) THEN DEALLOCATE(lri_force%st,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%dssn)) THEN DEALLOCATE(lri_force%dssn,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%sdssn)) THEN DEALLOCATE(lri_force%sdssn,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%dsst)) THEN DEALLOCATE(lri_force%dsst,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%sdsst)) THEN DEALLOCATE(lri_force%sdsst,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%sdt)) THEN DEALLOCATE(lri_force%sdt,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%dtvec)) THEN DEALLOCATE(lri_force%dtvec,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%davec)) THEN DEALLOCATE(lri_force%davec,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF(ASSOCIATED(lri_force%ds)) THEN DEALLOCATE(lri_force%ds,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF DEALLOCATE(lri_force, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(lri_force) ENDIF diff --git a/src/lri_forces.F b/src/lri_forces.F index b710564035..7789e3d423 100644 --- a/src/lri_forces.F +++ b/src/lri_forces.F @@ -60,11 +60,9 @@ MODULE lri_forces !> \param pmatrix density matrix !> \param atomic_kind_set ... !> \param use_virial ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calculate_lri_forces(lri_env,lri_density,qs_env,pmatrix,& - atomic_kind_set,use_virial,error) + atomic_kind_set,use_virial) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density @@ -74,7 +72,6 @@ SUBROUTINE calculate_lri_forces(lri_env,lri_density,qs_env,pmatrix,& TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set LOGICAL :: use_virial - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_lri_forces', & routineP = moduleN//':'//routineN @@ -99,11 +96,11 @@ SUBROUTINE calculate_lri_forces(lri_env,lri_density,qs_env,pmatrix,& nkind = lri_env%lri_ints%nkind nspin = SIZE(pmatrix) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,natom=natom) - CALL get_qs_env(qs_env=qs_env,force=force,virial=virial,error=error) + CALL get_qs_env(qs_env=qs_env,force=force,virial=virial) !calculate SUM_i integral(V*fbas_i)*davec/dR CALL calculate_v_dadr(lri_env,lri_density,pmatrix,atomic_kind_set,& - use_virial,virial,error) + use_virial,virial) DO ispin = 1, nspin @@ -138,10 +135,9 @@ END SUBROUTINE calculate_lri_forces !> \param atomic_kind_set ... !> \param use_virial ... !> \param virial ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_v_dadr(lri_env,lri_density,pmatrix,atomic_kind_set,& - use_virial,virial,error) + use_virial,virial) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density @@ -151,7 +147,6 @@ SUBROUTINE calculate_v_dadr(lri_env,lri_density,pmatrix,atomic_kind_set,& POINTER :: atomic_kind_set LOGICAL, INTENT(IN) :: use_virial TYPE(virial_type), POINTER :: virial - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_v_dadr', & routineP = moduleN//':'//routineN @@ -197,7 +192,7 @@ SUBROUTINE calculate_v_dadr(lri_env,lri_density,pmatrix,atomic_kind_set,& CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,natom=natom) ALLOCATE(atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind) @@ -230,7 +225,7 @@ SUBROUTINE calculate_v_dadr(lri_env,lri_density,pmatrix,atomic_kind_set,& nbb = lrii%nbb nn = nfa + nfb - CALL allocate_lri_force_components(lri_density%lri_force,nfa,nfb,error) + CALL allocate_lri_force_components(lri_density%lri_force,nfa,nfb) lri_force => lri_density%lri_force ds => lri_force%ds st => lri_force%st @@ -337,13 +332,13 @@ SUBROUTINE calculate_v_dadr(lri_env,lri_density,pmatrix,atomic_kind_set,& IF(use_virial) THEN !periodic self-pairs aa' contribute only with factor 0.5 IF(iatom == jatom) THEN - CALL virial_pair_force (virial%pv_virial,0.5_dp,force_a,rab,error) + CALL virial_pair_force (virial%pv_virial,0.5_dp,force_a,rab) ELSE - CALL virial_pair_force (virial%pv_virial,1.0_dp,force_a,rab,error) + CALL virial_pair_force (virial%pv_virial,1.0_dp,force_a,rab) ENDIF ENDIF - CALL deallocate_lri_force_components(lri_density%lri_force,error) + CALL deallocate_lri_force_components(lri_density%lri_force) END DO @@ -352,7 +347,7 @@ SUBROUTINE calculate_v_dadr(lri_env,lri_density,pmatrix,atomic_kind_set,& ENDDO DEALLOCATE(atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF diff --git a/src/lri_ks_methods.F b/src/lri_ks_methods.F index 0707098ad1..71999a0b88 100644 --- a/src/lri_ks_methods.F +++ b/src/lri_ks_methods.F @@ -74,11 +74,10 @@ MODULE lri_ks_methods !> \param lri_v_int integrals of potential * ri basis set !> \param h_matrix KS matrix, on entry containing the core hamiltonian !> \param atomic_kind_set ... -!> \param error ... !> \note including this in lri_environment_methods? ! ***************************************************************************** SUBROUTINE calculate_lri_ks_matrix(lri_env, lri_v_int, h_matrix, & - atomic_kind_set, error) + atomic_kind_set) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_kind_type), DIMENSION(:), & @@ -86,7 +85,6 @@ SUBROUTINE calculate_lri_ks_matrix(lri_env, lri_v_int, h_matrix, & TYPE(cp_dbcsr_type), POINTER :: h_matrix TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'calculate_lri_ks_matrix', & routineP = moduleN//':'//routineN @@ -117,7 +115,7 @@ SUBROUTINE calculate_lri_ks_matrix(lri_env, lri_v_int, h_matrix, & CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,natom=natom) ALLOCATE(atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind) CALL neighbor_list_iterator_create(nl_iterator,soo_list) @@ -141,7 +139,7 @@ SUBROUTINE calculate_lri_ks_matrix(lri_env, lri_v_int, h_matrix, & nn=nfa+nfb ALLOCATE(h_work(nba,nbb),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) h_work(:,:)=0.0_dp IF (iatom <= jatom) THEN @@ -157,7 +155,7 @@ SUBROUTINE calculate_lri_ks_matrix(lri_env, lri_v_int, h_matrix, & NULLIFY(h_block) CALL cp_dbcsr_get_block_p(h_matrix,row,col,h_block,found) IF (.NOT.ASSOCIATED(h_block)) THEN - CALL cp_dbcsr_add_block_node (h_matrix, row, col, h_block ,error=error) + CALL cp_dbcsr_add_block_node (h_matrix, row, col, h_block) END IF atom_a = atom_of_kind(iatom) @@ -186,14 +184,14 @@ SUBROUTINE calculate_lri_ks_matrix(lri_env, lri_v_int, h_matrix, & ENDIF DEALLOCATE(h_work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO - CALL cp_dbcsr_finalize(h_matrix, error=error) + CALL cp_dbcsr_finalize(h_matrix) CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -207,16 +205,14 @@ END SUBROUTINE calculate_lri_ks_matrix !> \param qs_env ... !> \param lri_rho_g ... !> \param skip_nuclear_density ... -!> \param error ... !> \note routine for testing, to be deleted later ! ***************************************************************************** SUBROUTINE calc_lri_rho_tot_gspace(rho_tot_gspace, qs_env, lri_rho_g,& - skip_nuclear_density, error) + skip_nuclear_density) TYPE(pw_p_type), INTENT(INOUT) :: rho_tot_gspace TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type), DIMENSION(:), POINTER :: lri_rho_g LOGICAL, INTENT(IN), OPTIONAL :: skip_nuclear_density - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'calc_lri_rho_tot_gspace', & routineP = moduleN//':'//routineN @@ -231,17 +227,16 @@ SUBROUTINE calc_lri_rho_tot_gspace(rho_tot_gspace, qs_env, lri_rho_g,& IF (PRESENT(skip_nuclear_density)) my_skip=skip_nuclear_density CALL get_qs_env(qs_env=qs_env,& rho_core=rho_core,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF (.NOT.my_skip) THEN - CALL pw_copy(rho_core%pw,rho_tot_gspace%pw, error=error) - CALL pw_axpy(lri_rho_g(1)%pw,rho_tot_gspace%pw, error=error) + CALL pw_copy(rho_core%pw,rho_tot_gspace%pw) + CALL pw_axpy(lri_rho_g(1)%pw,rho_tot_gspace%pw) ELSE - CALL pw_axpy(lri_rho_g(1)%pw, rho_tot_gspace%pw, error=error) + CALL pw_axpy(lri_rho_g(1)%pw, rho_tot_gspace%pw) END IF DO ispin=2, dft_control%nspins - CALL pw_axpy(lri_rho_g(ispin)%pw, rho_tot_gspace%pw, error=error) + CALL pw_axpy(lri_rho_g(ispin)%pw, rho_tot_gspace%pw) END DO END SUBROUTINE calc_lri_rho_tot_gspace @@ -250,16 +245,14 @@ END SUBROUTINE calc_lri_rho_tot_gspace !> \param qs_env ... !> \param rho_r ... !> \param lri ... -!> \param error ... !> \note only NSPIN=1!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \note routine for testing, to be deleted later ! ***************************************************************************** - SUBROUTINE print_lri_density_cube(qs_env, rho_r, lri, error) + SUBROUTINE print_lri_density_cube(qs_env, rho_r, lri) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_r LOGICAL, INTENT(IN) :: lri - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'print_lri_density_cube', & routineP = moduleN//':'//routineN @@ -274,16 +267,16 @@ SUBROUTINE print_lri_density_cube(qs_env, rho_r, lri, error) NULLIFY(dft_section, logger, particles, subsys) - CALL get_qs_env(qs_env=qs_env, input=input, subsys=subsys, error=error) - logger => cp_error_get_logger(error) + CALL get_qs_env(qs_env=qs_env, input=input, subsys=subsys) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") + CALL qs_subsys_get(subsys,particles=particles) IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%E_DENSITY_CUBE", error=error),cp_p_file)) THEN + "DFT%PRINT%E_DENSITY_CUBE"),cp_p_file)) THEN - append_cube = section_get_lval(input,"DFT%PRINT%E_DENSITY_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%E_DENSITY_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" @@ -296,13 +289,12 @@ SUBROUTINE print_lri_density_cube(qs_env, rho_r, lri, error) ENDIF unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%E_DENSITY_CUBE",& extension=".cube",middle_name=TRIM(filename),file_position=my_pos_cube,& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) CALL cp_pw_to_cube(rho_r(1)%pw,unit_nr,"ELECTRONIC DENSITY",& particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE",error=error),& - error=error) + stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%E_DENSITY_CUBE",error=error) + "DFT%PRINT%E_DENSITY_CUBE") END IF END SUBROUTINE print_lri_density_cube @@ -310,15 +302,13 @@ END SUBROUTINE print_lri_density_cube !> \brief ... !> \param qs_env ... !> \param v_rspace_new ... -!> \param error ... !> \note only NSPIN=1!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \note routine for testing, to be deleted later ! ***************************************************************************** - SUBROUTINE print_v_xc_cube(qs_env, v_rspace_new, error) + SUBROUTINE print_v_xc_cube(qs_env, v_rspace_new) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type) :: v_rspace_new - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'print_v_xc_cube', & routineP = moduleN//':'//routineN @@ -338,43 +328,42 @@ SUBROUTINE print_v_xc_cube(qs_env, v_rspace_new, error) NULLIFY(dft_section, logger, particles, subsys) NULLIFY(auxbas_pw_pool, pw_env) - CALL get_qs_env(qs_env=qs_env, input=input, subsys=subsys, error=error) - logger => cp_error_get_logger(error) + CALL get_qs_env(qs_env=qs_env, input=input, subsys=subsys) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") + CALL qs_subsys_get(subsys,particles=particles) IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%V_HARTREE_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%V_HARTREE_CUBE"),cp_p_file)) THEN - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,aux_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) - append_cube = section_get_lval(input,"DFT%PRINT%V_HARTREE_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%V_HARTREE_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env, error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env) unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%V_HARTREE_CUBE",& - extension=".cube",middle_name="v_xc",file_position=my_pos_cube,error=error) + extension=".cube",middle_name="v_xc",file_position=my_pos_cube) udvol = 1.0_dp/v_rspace_new%pw%pw_grid%dvol - CALL pw_copy(v_rspace_new%pw,aux_r%pw, error=error) - CALL pw_scale(aux_r%pw,udvol,error=error) + CALL pw_copy(v_rspace_new%pw,aux_r%pw) + CALL pw_scale(aux_r%pw,udvol) CALL cp_pw_to_cube(aux_r%pw,unit_nr,"Exchange POTENTIAL",particles=particles,& stride=section_get_ivals(dft_section,& - "PRINT%V_HARTREE_CUBE%STRIDE",error=error),& - error=error) + "PRINT%V_HARTREE_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%V_HARTREE_CUBE",error=error) + "DFT%PRINT%V_HARTREE_CUBE") - CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw) ENDIF END SUBROUTINE print_v_xc_cube ! diff --git a/src/lri_optimize_ri_basis.F b/src/lri_optimize_ri_basis.F index edc54df3c7..de715f5aa7 100644 --- a/src/lri_optimize_ri_basis.F +++ b/src/lri_optimize_ri_basis.F @@ -85,13 +85,10 @@ MODULE lri_optimize_ri_basis ! ***************************************************************************** !> \brief optimizes the lri basis set !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE optimize_lri_basis(qs_env,error) + SUBROUTINE optimize_lri_basis(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'optimize_lri_basis', & routineP = moduleN//':'//routineN @@ -117,28 +114,28 @@ SUBROUTINE optimize_lri_basis(qs_env,error) CALL get_qs_env(qs_env,atomic_kind_set=atomic_kind_set,input=input,& lri_env=lri_env,lri_density=lri_density,nkind=nkind,& - para_env=para_env,rho=rho_struct,error=error) + para_env=para_env,rho=rho_struct) ! density matrix - CALL qs_rho_get(rho_struct, rho_ao=pmatrix, error=error) + CALL qs_rho_get(rho_struct, rho_ao=pmatrix) - logger => cp_error_get_logger(error) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + logger => cp_get_default_logger() + dft_section => section_vals_get_subs_vals(input,"DFT") lri_optbas_section => section_vals_get_subs_vals(input,& - "DFT%QS%OPTIMIZE_LRI_BASIS",error=error) + "DFT%QS%OPTIMIZE_LRI_BASIS") iunit=cp_print_key_unit_nr(logger,input,"PRINT%PROGRAM_RUN_INFO",& - extension=".opt",error=error) + extension=".opt") IF ( iunit > 0 ) THEN WRITE(iunit,'(/," POWELL| Start optimization procedure")') ENDIF ! *** initialization - CALL create_lri_opt(lri_opt,error) + CALL create_lri_opt(lri_opt) CALL init_optimization(lri_env,lri_opt,lri_optbas_section,& - opt_state,lri_opt%x,lri_opt%zet_init,nkind,iunit,error) + opt_state,lri_opt%x,lri_opt%zet_init,nkind,iunit) - CALL calculate_lri_overlap_aabb(lri_env,qs_env,error) + CALL calculate_lri_overlap_aabb(lri_env,qs_env) ! *** ======================= START optimization ===================== opt_state%state = 0 @@ -146,13 +143,13 @@ SUBROUTINE optimize_lri_basis(qs_env,error) IF ( opt_state%state == 2 ) THEN CALL calc_lri_integrals_get_objective(lri_env,lri_density,qs_env,& lri_opt,opt_state,pmatrix,para_env,& - nkind,error) + nkind) ENDIF IF ( opt_state%state == -1 ) EXIT CALL powell_optimize (opt_state%nvar, lri_opt%x, opt_state) - CALL update_exponents(lri_env,lri_opt,lri_opt%x,lri_opt%zet_init,nkind,error) + CALL update_exponents(lri_env,lri_opt,lri_opt%x,lri_opt%zet_init,nkind) CALL print_optimization_update(opt_state,lri_opt,iunit) ENDDO ! *** ======================= END optimization ======================= @@ -160,10 +157,10 @@ SUBROUTINE optimize_lri_basis(qs_env,error) ! *** get final optimized parameters opt_state%state = 8 CALL powell_optimize (opt_state%nvar, lri_opt%x, opt_state) - CALL update_exponents(lri_env,lri_opt,lri_opt%x,lri_opt%zet_init,nkind,error) + CALL update_exponents(lri_env,lri_opt,lri_opt%x,lri_opt%zet_init,nkind) CALL write_optimized_lri_basis(lri_env,dft_section,nkind,lri_opt,& - atomic_kind_set,error) + atomic_kind_set) IF ( iunit > 0 ) THEN WRITE(iunit,'(" POWELL| Number of function evaluations",T71,I10)') opt_state%nf @@ -172,9 +169,9 @@ SUBROUTINE optimize_lri_basis(qs_env,error) ENDIF CALL cp_print_key_finished_output(iunit,logger,input,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") - CALL deallocate_lri_opt(lri_opt,error) + CALL deallocate_lri_opt(lri_opt) END SUBROUTINE optimize_lri_basis @@ -189,11 +186,9 @@ END SUBROUTINE optimize_lri_basis !> \param zet_init initial values of the exponents !> \param nkind number of atom kinds !> \param iunit output unit -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE init_optimization(lri_env,lri_opt,lri_optbas_section,opt_state,& - x,zet_init,nkind,iunit,error) + x,zet_init,nkind,iunit) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_opt_type), POINTER :: lri_opt @@ -201,7 +196,6 @@ SUBROUTINE init_optimization(lri_env,lri_opt,lri_optbas_section,opt_state,& TYPE(opt_state_type) :: opt_state REAL(KIND=dp), DIMENSION(:), POINTER :: x, zet_init INTEGER, INTENT(IN) :: nkind, iunit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_optimization', & routineP = moduleN//':'//routineN @@ -219,11 +213,11 @@ SUBROUTINE init_optimization(lri_env,lri_opt,lri_optbas_section,opt_state,& failure = .FALSE. ALLOCATE(lri_opt%ri_gcc_orig(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! *** get parameters CALL get_optimization_parameter(lri_opt,lri_optbas_section,& - opt_state,error) + opt_state) opt_state%nvar =0 opt_state%nf = 0 @@ -257,7 +251,7 @@ SUBROUTINE init_optimization(lri_env,lri_opt,lri_optbas_section,opt_state,& ! *** constraints on exponents IF(lri_opt%use_constraints) THEN ALLOCATE(zet_init(SIZE(x)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) zet_init(:)=x ELSE x(:)=SQRT(x) @@ -268,7 +262,7 @@ SUBROUTINE init_optimization(lri_env,lri_opt,lri_optbas_section,opt_state,& DO ikind=1,nkind fbas => lri_env%ri_basis(ikind)%gto_basis_set CALL get_original_gcc(lri_opt%ri_gcc_orig(ikind)%gcc_orig,fbas,& - lri_opt,error) + lri_opt) ENDDO ! *** init coefficients @@ -279,7 +273,7 @@ SUBROUTINE init_optimization(lri_env,lri_opt,lri_optbas_section,opt_state,& CALL get_gto_basis_set(gto_basis_set=fbas,& npgf=npgf,nset=nset,nshell=nshell,zet=zet) ! *** Gram Schmidt orthonormalization - CALL orthonormalize_gcc(gcc_orig,fbas,lri_opt,error) + CALL orthonormalize_gcc(gcc_orig,fbas,lri_opt) n=opt_state%nvar DO iset=1,nset DO ishell=1,nshell(iset) @@ -309,16 +303,13 @@ END SUBROUTINE init_optimization !> \param lri_opt optimization environmnet !> \param lri_optbas_section ... !> \param opt_state state of the optimizer -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE get_optimization_parameter(lri_opt,lri_optbas_section,& - opt_state,error) + opt_state) TYPE(lri_opt_type), POINTER :: lri_opt TYPE(section_vals_type), POINTER :: lri_optbas_section TYPE(opt_state_type) :: opt_state - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_optimization_parameter', & routineP = moduleN//':'//routineN @@ -330,15 +321,15 @@ SUBROUTINE get_optimization_parameter(lri_opt,lri_optbas_section,& ! *** parameter for POWELL optimizer CALL section_vals_val_get(lri_optbas_section,"ACCURACY",& - r_val=opt_state%rhoend, error=error) + r_val=opt_state%rhoend) CALL section_vals_val_get(lri_optbas_section,"STEP_SIZE",& - r_val=opt_state%rhobeg, error=error) + r_val=opt_state%rhobeg) CALL section_vals_val_get(lri_optbas_section,"MAX_FUN",& - i_val=opt_state%maxfun, error=error) + i_val=opt_state%maxfun) ! *** parameters which are optimized, i.e. exps or coeff or both CALL section_vals_val_get(lri_optbas_section,"DEGREES_OF_FREEDOM",& - i_val=degree_freedom, error=error) + i_val=degree_freedom) SELECT CASE(degree_freedom) CASE(do_lri_opt_all) @@ -356,23 +347,22 @@ SUBROUTINE get_optimization_parameter(lri_opt,lri_optbas_section,& ! *** restraint CALL section_vals_val_get(lri_optbas_section,"USE_CONDITION_NUMBER",& - l_val=lri_opt%use_condition_number,error=error) + l_val=lri_opt%use_condition_number) CALL section_vals_val_get(lri_optbas_section,"CONDITION_WEIGHT",& - r_val=lri_opt%cond_weight,error=error) + r_val=lri_opt%cond_weight) CALL section_vals_val_get(lri_optbas_section,"GEOMETRIC_SEQUENCE",& - l_val=lri_opt%use_geometric_seq,error=error) + l_val=lri_opt%use_geometric_seq) ! *** get constraint info constrain_exp_section => section_vals_get_subs_vals(lri_optbas_section,& - "CONSTRAIN_EXPONENTS",error=error) - CALL section_vals_get(constrain_exp_section,explicit=lri_opt%use_constraints,& - error=error) + "CONSTRAIN_EXPONENTS") + CALL section_vals_get(constrain_exp_section,explicit=lri_opt%use_constraints) IF(lri_opt%use_constraints) THEN CALL section_vals_val_get(constrain_exp_section,"SCALE",& - r_val=lri_opt%scale_exp, error=error) + r_val=lri_opt%scale_exp) CALL section_vals_val_get(constrain_exp_section,"FERMI_EXP",& - r_val=lri_opt%fermi_exp, error=error) + r_val=lri_opt%fermi_exp) ENDIF END SUBROUTINE get_optimization_parameter @@ -384,16 +374,13 @@ END SUBROUTINE get_optimization_parameter !> \param x optimization parameters !> \param zet_init initial values of the exponents !> \param nkind number of atomic kinds -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE update_exponents(lri_env,lri_opt,x,zet_init,nkind,error) + SUBROUTINE update_exponents(lri_env,lri_opt,x,zet_init,nkind) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_opt_type), POINTER :: lri_opt REAL(KIND=dp), DIMENSION(:), POINTER :: x, zet_init INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_exponents', & routineP = moduleN//':'//routineN @@ -414,13 +401,13 @@ SUBROUTINE update_exponents(lri_env,lri_opt,x,zet_init,nkind,error) ! nvar_exp: number of exponents that are variables nvar_exp= SIZE(x) - lri_opt%ncoeff ALLOCATE(zet_trans(nvar_exp),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! *** update exponents IF(lri_opt%opt_exps) THEN IF (lri_opt%use_constraints) THEN zet => x(1:nvar_exp) - CALL transfer_exp(lri_opt,zet,zet_init,zet_trans,nvar_exp,error) + CALL transfer_exp(lri_opt,zet,zet_init,zet_trans,nvar_exp) ELSE zet_trans(:) = x(1:nvar_exp)**2.0_dp ENDIF @@ -458,12 +445,12 @@ SUBROUTINE update_exponents(lri_env,lri_opt,x,zet_init,nkind,error) ENDDO ENDDO ! *** Gram Schmidt orthonormalization - CALL orthonormalize_gcc(gcc_orig,fbas,lri_opt,error) + CALL orthonormalize_gcc(gcc_orig,fbas,lri_opt) ENDDO ENDIF DEALLOCATE(zet_trans,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE update_exponents ! ***************************************************************************** @@ -473,15 +460,12 @@ END SUBROUTINE update_exponents !> \param zet_init intial value of the eponents !> \param zet_trans transferred exponents !> \param nvar number of optimized exponents -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE transfer_exp(lri_opt,zet,zet_init,zet_trans,nvar,error) + SUBROUTINE transfer_exp(lri_opt,zet,zet_init,zet_trans,nvar) TYPE(lri_opt_type), POINTER :: lri_opt REAL(KIND=dp), DIMENSION(:), POINTER :: zet, zet_init, zet_trans INTEGER, INTENT(IN) :: nvar - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'transfer_exp', & routineP = moduleN//':'//routineN @@ -493,7 +477,7 @@ SUBROUTINE transfer_exp(lri_opt,zet,zet_init,zet_trans,nvar,error) failure = .FALSE. ALLOCATE(zet_max(nvar),zet_min(nvar),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) zet_min(:) = zet_init(:)*(1.0_dp-lri_opt%scale_exp) zet_max(:) = zet_init(:)*(1.0_dp+lri_opt%scale_exp) @@ -503,7 +487,7 @@ SUBROUTINE transfer_exp(lri_opt,zet,zet_init,zet_trans,nvar,error) zet_trans= zet_min + (zet_max-zet_min)/(1+EXP(-a*(zet-zet_init))) DEALLOCATE(zet_max,zet_min,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE transfer_exp @@ -548,12 +532,10 @@ END SUBROUTINE geometric_progression !> \param pmatrix density matrix !> \param para_env ... !> \param nkind number of atomic kinds -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calc_lri_integrals_get_objective(lri_env,lri_density,qs_env,& lri_opt,opt_state,pmatrix,para_env,& - nkind,error) + nkind) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density @@ -564,7 +546,6 @@ SUBROUTINE calc_lri_integrals_get_objective(lri_env,lri_density,qs_env,& POINTER :: pmatrix TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'calc_lri_integrals_get_objective', & @@ -582,16 +563,16 @@ SUBROUTINE calc_lri_integrals_get_objective(lri_env,lri_density,qs_env,& CALL get_gto_basis_set(gto_basis_set=fbas,npgf=npgf,nset=nset) !build new sphi fbas%gcc = lri_opt%ri_gcc_orig(ikind)%gcc_orig - CALL init_orb_basis_set(fbas,error) + CALL init_orb_basis_set(fbas) ENDDO - CALL lri_basis_init(lri_env,error) - CALL calculate_lri_integrals(lri_env,qs_env,calculate_forces=.FALSE.,error=error) - CALL calculate_avec(lri_env,lri_density,qs_env,pmatrix,error=error) + CALL lri_basis_init(lri_env) + CALL calculate_lri_integrals(lri_env,qs_env,calculate_forces=.FALSE.) + CALL calculate_avec(lri_env,lri_density,qs_env,pmatrix) IF(lri_opt%use_condition_number) THEN - CALL get_condition_number_of_overlap(lri_env,error) + CALL get_condition_number_of_overlap(lri_env) ENDIF CALL calculate_objective(lri_env,lri_density,lri_opt,pmatrix,para_env,& - opt_state%f,error) + opt_state%f) END SUBROUTINE calc_lri_integrals_get_objective @@ -606,11 +587,9 @@ END SUBROUTINE calc_lri_integrals_get_objective !> \param pmatrix density matrix !> \param para_env ... !> \param fobj objective function -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calculate_objective(lri_env,lri_density,lri_opt,pmatrix,para_env,& - fobj,error) + fobj) TYPE(lri_environment_type), POINTER :: lri_env TYPE(lri_density_type), POINTER :: lri_density @@ -619,7 +598,6 @@ SUBROUTINE calculate_objective(lri_env,lri_density,lri_opt,pmatrix,para_env,& POINTER :: pmatrix TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), INTENT(OUT) :: fobj - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_objective', & routineP = moduleN//':'//routineN @@ -690,7 +668,7 @@ SUBROUTINE calculate_objective(lri_env,lri_density,lri_opt,pmatrix,para_env,& CALL cp_dbcsr_get_block_p(matrix=pmat,row=jatom,col=iatom,block=pbij,found=found) trans = .TRUE. END IF - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ! *** calculate integral of the square of exact density rhoexact_sq IF (trans) THEN @@ -778,13 +756,10 @@ END SUBROUTINE calculate_objective ! ***************************************************************************** !> \brief get condition number of overlap matrix !> \param lri_env lri environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE get_condition_number_of_overlap(lri_env,error) + SUBROUTINE get_condition_number_of_overlap(lri_env) TYPE(lri_environment_type), POINTER :: lri_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'get_condition_number_of_overlap', & @@ -825,10 +800,10 @@ SUBROUTINE get_condition_number_of_overlap(lri_env,error) ! build the overlap matrix IF(iatom == jatom) THEN ALLOCATE(smat(nfa,nfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(smat(nn,nn),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF smat(1:nfa,1:nfa) = lri_env%bas_prop(ikind)%ri_ovlp(1:nfa,1:nfa) IF(iatom /= jatom) THEN @@ -840,7 +815,7 @@ SUBROUTINE get_condition_number_of_overlap(lri_env,error) IF(iatom==jatom) nn=nfa ALLOCATE(diag(nn),off_diag(nn-1),tau(nn-1),work(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) diag=0.0_dp off_diag=0.0_dp tau=0.0_dp @@ -857,7 +832,7 @@ SUBROUTINE get_condition_number_of_overlap(lri_env,error) lrii%cond_num=MAXVAL(ABS(diag))/MINVAL(ABS(diag)) DEALLOCATE(diag,off_diag,smat,tau,work) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO CALL neighbor_list_iterator_release(nl_iterator) @@ -909,11 +884,9 @@ END SUBROUTINE print_optimization_update !> \param nkind ... !> \param lri_opt ... !> \param atomic_kind_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE write_optimized_lri_basis(lri_env,dft_section,nkind,lri_opt,& - atomic_kind_set,error) + atomic_kind_set) TYPE(lri_environment_type), POINTER :: lri_env TYPE(section_vals_type), POINTER :: dft_section @@ -921,7 +894,6 @@ SUBROUTINE write_optimized_lri_basis(lri_env,dft_section,nkind,lri_opt,& TYPE(lri_opt_type), POINTER :: lri_opt TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_optimized_lri_basis', & routineP = moduleN//':'//routineN @@ -942,25 +914,23 @@ SUBROUTINE write_optimized_lri_basis(lri_env,dft_section,nkind,lri_opt,& !*** do the printing print_key => section_vals_get_subs_vals(dft_section,& - "PRINT%OPTIMIZE_LRI_BASIS",& - error=error) - logger => cp_error_get_logger(error) + "PRINT%OPTIMIZE_LRI_BASIS") + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,"PRINT%OPTIMIZE_LRI_BASIS",error=error),& + dft_section,"PRINT%OPTIMIZE_LRI_BASIS"),& cp_p_file)) THEN output_file=cp_print_key_unit_nr(logger,dft_section,& "PRINT%OPTIMIZE_LRI_BASIS",& extension=".opt",& file_status="REPLACE",& file_action="WRITE",& - file_form="FORMATTED",& - error=error) + file_form="FORMATTED") IF(output_file>0) THEN filename = cp_print_key_generate_filename(logger,& print_key,extension=".opt", & - my_local=.TRUE.,error=error) + my_local=.TRUE.) DO ikind =1, nkind fbas => lri_env%ri_basis(ikind)%gto_basis_set @@ -1004,7 +974,7 @@ SUBROUTINE write_optimized_lri_basis(lri_env,dft_section,nkind,lri_opt,& ENDIF CALL cp_print_key_finished_output(output_file,logger,dft_section,& - "PRINT%OPTIMIZE_LRI_BASIS", error=error) + "PRINT%OPTIMIZE_LRI_BASIS") ENDIF END SUBROUTINE write_optimized_lri_basis diff --git a/src/lri_optimize_ri_basis_types.F b/src/lri_optimize_ri_basis_types.F index 8ab3db901e..6acbac9163 100644 --- a/src/lri_optimize_ri_basis_types.F +++ b/src/lri_optimize_ri_basis_types.F @@ -71,13 +71,10 @@ MODULE lri_optimize_ri_basis_types ! ***************************************************************************** !> \brief creates lri_opt !> \param lri_opt optimization environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE create_lri_opt(lri_opt,error) + SUBROUTINE create_lri_opt(lri_opt) TYPE(lri_opt_type), POINTER :: lri_opt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_lri_opt', & routineP = moduleN//':'//routineN @@ -86,7 +83,7 @@ SUBROUTINE create_lri_opt(lri_opt,error) LOGICAL :: failure ALLOCATE(lri_opt,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(lri_opt%ri_gcc_orig) NULLIFY(lri_opt%subset) @@ -107,13 +104,10 @@ END SUBROUTINE create_lri_opt ! ***************************************************************************** !> \brief deallocates lri_opt !> \param lri_opt optimization environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE deallocate_lri_opt(lri_opt,error) + SUBROUTINE deallocate_lri_opt(lri_opt) TYPE(lri_opt_type), POINTER :: lri_opt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_lri_opt', & routineP = moduleN//':'//routineN @@ -127,29 +121,29 @@ SUBROUTINE deallocate_lri_opt(lri_opt,error) IF(ASSOCIATED(lri_opt%subset)) THEN DO i=1,SIZE(lri_opt%subset) DEALLOCATE(lri_opt%subset(i)%ncont_l,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(lri_opt%subset,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(lri_opt%x)) THEN DEALLOCATE(lri_opt%x,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(lri_opt%zet_init)) THEN DEALLOCATE(lri_opt%zet_init,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(lri_opt%ri_gcc_orig)) THEN DO i=1,SIZE(lri_opt%ri_gcc_orig) DEALLOCATE(lri_opt%ri_gcc_orig(i)%gcc_orig,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(lri_opt%ri_gcc_orig,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(lri_opt,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF END SUBROUTINE deallocate_lri_opt @@ -160,16 +154,13 @@ END SUBROUTINE deallocate_lri_opt !> \param gcc_orig original contraction coefficient !> \param gto_basis_set gaussian type basis set !> \param lri_opt optimization environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE get_original_gcc(gcc_orig,gto_basis_set,lri_opt,error) + SUBROUTINE get_original_gcc(gcc_orig,gto_basis_set,lri_opt) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: gcc_orig TYPE(gto_basis_set_type), POINTER :: gto_basis_set TYPE(lri_opt_type), POINTER :: lri_opt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_original_gcc', & routineP = moduleN//':'//routineN @@ -187,7 +178,7 @@ SUBROUTINE get_original_gcc(gcc_orig,gto_basis_set,lri_opt,error) nset = SIZE(gto_basis_set%gcc,3) ALLOCATE(gcc_orig(maxpgf,maxshell,nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gcc_orig = 0.0_dp DO iset=1,gto_basis_set%nset @@ -208,13 +199,13 @@ SUBROUTINE get_original_gcc(gcc_orig,gto_basis_set,lri_opt,error) CALL get_gto_basis_set(gto_basis_set=gto_basis_set,& lmax=lmax,lmin=lmin) ALLOCATE(lri_opt%subset(nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iset=1,gto_basis_set%nset nl=lmax(iset)-lmin(iset)+1 lri_opt%subset(iset)%nl=nl il=1 ALLOCATE(lri_opt%subset(iset)%ncont_l(nl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ncont_l => lri_opt%subset(iset)%ncont_l ncont_l=1 DO ishell=2,gto_basis_set%nshell(iset) @@ -236,16 +227,13 @@ END SUBROUTINE get_original_gcc !> \param gcc contraction coefficient !> \param gto_basis_set gaussian type basis set !> \param lri_opt optimization environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE orthonormalize_gcc(gcc,gto_basis_set,lri_opt,error) + SUBROUTINE orthonormalize_gcc(gcc,gto_basis_set,lri_opt) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: gcc TYPE(gto_basis_set_type), POINTER :: gto_basis_set TYPE(lri_opt_type), POINTER :: lri_opt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'orthonormalize_gcc', & routineP = moduleN//':'//routineN diff --git a/src/lri_os_integrals.F b/src/lri_os_integrals.F index c6213c38e7..0dd73998e0 100644 --- a/src/lri_os_integrals.F +++ b/src/lri_os_integrals.F @@ -52,10 +52,9 @@ MODULE lri_os_integrals !> \param calculate_forces ... !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_ab(sab,dsab,ra,rb,rab,fba,fbb,calculate_forces,debug,& - dmax,error) + dmax) REAL(KIND=dp), DIMENSION(:, :), POINTER :: sab REAL(KIND=dp), DIMENSION(:, :, :), & @@ -64,7 +63,6 @@ SUBROUTINE lri_int_ab(sab,dsab,ra,rb,rab,fba,fbb,calculate_forces,debug,& TYPE(gto_basis_set_type), POINTER :: fba, fbb LOGICAL, INTENT(IN) :: calculate_forces, debug REAL(KIND=dp), INTENT(INOUT) :: dmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_ab', & routineP = moduleN//':'//routineN @@ -124,15 +122,15 @@ SUBROUTINE lri_int_ab(sab,dsab,ra,rb,rab,fba,fbb,calculate_forces,debug,& ENDIF lds = ncoset(maxl) ALLOCATE(sint(maxco,maxco),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calculate_forces) THEN !derivatives will be stored in devab(:,:,2:4) ALLOCATE(swork(lds,lds,4),devab(maxco,maxco,4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) devab = 0._dp ELSE ALLOCATE(swork(lds,lds,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF sint = 0._dp swork = 0._dp @@ -165,7 +163,7 @@ SUBROUTINE lri_int_ab(sab,dsab,ra,rb,rab,fba,fbb,calculate_forces,debug,& !NOTE: devab(:,:,2:4) contains all derivatives for lmin=0 to lmax=lmax ! correct after contraction (multiply with zero for elements l < lmin) CALL ab_contract(dsab(sgfa:m1,sgfb:m2,i),devab(:,:,i+1),sphi_a(:,sgfa:),& - sphi_b(:,sgfb:),ncoa,ncob,nsgfa(iset),nsgfb(jset),error) + sphi_b(:,sgfb:),ncoa,ncob,nsgfa(iset),nsgfb(jset)) ENDDO ELSE @@ -177,21 +175,21 @@ SUBROUTINE lri_int_ab(sab,dsab,ra,rb,rab,fba,fbb,calculate_forces,debug,& IF(debug) THEN CALL overlap_ab_test(la_max(iset),la_min(iset),npgfa(iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),zetb(:,jset),& - ra,rb,sint,dmax,error) + ra,rb,sint,dmax) ENDIF CALL ab_contract(sab(sgfa:m1,sgfb:m2),sint,sphi_a(:,sgfa:),sphi_b(:,sgfb:),& - ncoa,ncob,nsgfa(iset),nsgfb(jset),error) + ncoa,ncob,nsgfa(iset),nsgfb(jset)) END DO END DO IF(calculate_forces) THEN DEALLOCATE(devab,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(sint,swork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -210,10 +208,9 @@ END SUBROUTINE lri_int_ab !> \param calculate_forces ... !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_aba(abaint,dabdaint,ra,rb,rab,oba,obb,fba,& - calculate_forces,debug,dmax,error) + calculate_forces,debug,dmax) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: abaint @@ -223,7 +220,6 @@ SUBROUTINE lri_int_aba(abaint,dabdaint,ra,rb,rab,oba,obb,fba,& TYPE(gto_basis_set_type), POINTER :: oba, obb, fba LOGICAL, INTENT(IN) :: calculate_forces, debug REAL(KIND=dp), INTENT(INOUT) :: dmax - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_aba', & routineP = moduleN//':'//routineN @@ -325,52 +321,52 @@ SUBROUTINE lri_int_aba(abaint,dabdaint,ra,rb,rab,oba,obb,fba,& m3=sgfc+nsgfca(kaset)-1 IF(ncoa*ncob*ncoc > 0) THEN ALLOCATE(saba(ncoa,ncob,ncoc),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) saba(:,:,:) = 0._dp ! integrals IF(calculate_forces) THEN ALLOCATE(sdaba(ncoa,ncob,ncoc,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(sabda(ncoa,ncob,ncoc,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(sdabda(ncoa,ncob,ncoc,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sdaba(:,:,:,:) = 0._dp sabda(:,:,:,:) = 0._dp sdabda(:,:,:,:) = 0._dp CALL overlap3(la_max(iset),npgfa(iset),zeta(:,iset),rpgfa(:,iset),la_min(iset),& lb_max(jset),npgfb(jset),zetb(:,jset),rpgfb(:,jset),lb_min(jset),& lca_max(kaset),npgfca(kaset),zetca(:,kaset),rpgfca(:,kaset),lca_min(kaset),& - rab,dab,rac,dac,rbc,dbc,saba,sdaba,sabda,error=error) + rab,dab,rac,dac,rbc,dbc,saba,sdaba,sabda) !d(a,b,a)/dA = (da/dA,b,a) + (a,b,da/dA) sdabda(:,:,:,:) = sdaba + sabda DO i=1,3 CALL abc_contract(dabdaint(sgfa:m1,sgfb:m2,sgfc:m3,i),sdabda(:,:,:,i),& sphi_a(:,sgfa:),sphi_b(:,sgfb:),sphi_ca(:,sgfc:),& - ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfca(kaset),error) + ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfca(kaset)) ENDDO DEALLOCATE(sdaba,sabda,sdabda,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL overlap3(la_max(iset),npgfa(iset),zeta(:,iset),rpgfa(:,iset),la_min(iset),& lb_max(jset),npgfb(jset),zetb(:,jset),rpgfb(:,jset),lb_min(jset),& lca_max(kaset),npgfca(kaset),zetca(:,kaset),rpgfca(:,kaset),lca_min(kaset),& - rab,dab,rac,dac,rbc,dbc,saba,error=error) + rab,dab,rac,dac,rbc,dbc,saba) ENDIF ! debug if requested IF(debug) THEN CALL overlap_abc_test(la_max(iset),npgfa(iset),zeta(:,iset),la_min(iset),& lb_max(jset),npgfb(jset),zetb(:,jset),lb_min(jset),& lca_max(kaset),npgfca(kaset),zetca(:,kaset),lca_min(kaset),& - ra,rb,ra,saba,dmax,error) + ra,rb,ra,saba,dmax) ENDIF CALL abc_contract(abaint(sgfa:m1,sgfb:m2,sgfc:m3),saba,& sphi_a(:,sgfa:),sphi_b(:,sgfb:),sphi_ca(:,sgfc:),& - ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfca(kaset),error) + ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfca(kaset)) DEALLOCATE(saba,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO END DO @@ -393,10 +389,9 @@ END SUBROUTINE lri_int_aba !> \param calculate_forces ... !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_abb(abbint,dabbint,ra,rb,rab,oba,obb,fbb,calculate_forces,& - debug,dmax,error) + debug,dmax) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: abbint @@ -406,7 +401,6 @@ SUBROUTINE lri_int_abb(abbint,dabbint,ra,rb,rab,oba,obb,fbb,calculate_forces,& TYPE(gto_basis_set_type), POINTER :: oba, obb, fbb LOGICAL, INTENT(IN) :: calculate_forces, debug REAL(KIND=dp), INTENT(INOUT) :: dmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_abb', & routineP = moduleN//':'//routineN @@ -508,41 +502,41 @@ SUBROUTINE lri_int_abb(abbint,dabbint,ra,rb,rab,oba,obb,fbb,calculate_forces,& m3=sgfc+nsgfcb(kbset)-1 IF(ncoa*ncob*ncoc > 0) THEN ALLOCATE(sabb(ncoa,ncob,ncoc),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sabb(:,:,:) = 0._dp IF(calculate_forces) THEN ALLOCATE(sdabb(ncoa,ncob,ncoc,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sdabb(:,:,:,:) = 0._dp CALL overlap3(la_max(iset),npgfa(iset),zeta(:,iset),rpgfa(:,iset),la_min(iset),& lb_max(jset),npgfb(jset),zetb(:,jset),rpgfb(:,jset),lb_min(jset),& lcb_max(kbset),npgfcb(kbset),zetcb(:,kbset),rpgfcb(:,kbset),lcb_min(kbset),& - rab,dab,rac,dac,rbc,dbc,sabb,sdabc=sdabb,error=error) + rab,dab,rac,dac,rbc,dbc,sabb,sdabc=sdabb) DO i=1,3 CALL abc_contract(dabbint(sgfa:m1,sgfb:m2,sgfc:m3,i),sdabb(:,:,:,i),& sphi_a(:,sgfa:),sphi_b(:,sgfb:),sphi_cb(:,sgfc:),& - ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfcb(kbset),error) + ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfcb(kbset)) ENDDO DEALLOCATE(sdabb,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL overlap3(la_max(iset),npgfa(iset),zeta(:,iset),rpgfa(:,iset),la_min(iset),& lb_max(jset),npgfb(jset),zetb(:,jset),rpgfb(:,jset),lb_min(jset),& lcb_max(kbset),npgfcb(kbset),zetcb(:,kbset),rpgfcb(:,kbset),lcb_min(kbset),& - rab,dab,rac,dac,rbc,dbc,sabb,error=error) + rab,dab,rac,dac,rbc,dbc,sabb) ENDIF ! debug if requested IF(debug) THEN CALL overlap_abc_test(la_max(iset),npgfa(iset),zeta(:,iset),la_min(iset),& lb_max(jset),npgfb(jset),zetb(:,jset),lb_min(jset),& lcb_max(kbset),npgfcb(kbset),zetcb(:,kbset),lcb_min(kbset),& - ra,rb,rb,sabb,dmax,error) + ra,rb,rb,sabb,dmax) ENDIF CALL abc_contract(abbint(sgfa:m1,sgfb:m2,sgfc:m3),sabb,& sphi_a(:,sgfa:),sphi_b(:,sgfb:),sphi_cb(:,sgfc:),& - ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfcb(kbset),error) + ncoa,ncob,ncoc,nsgfa(iset),nsgfb(jset),nsgfcb(kbset)) DEALLOCATE(sabb,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF END DO @@ -563,9 +557,8 @@ END SUBROUTINE lri_int_abb !> \param rb ... !> \param debug integrals are debugged by recursive routines if requested !> \param dmax maximal deviation between integrals when debugging -!> \param error ... ! ***************************************************************************** - SUBROUTINE lri_int_aabb(saabb,oba,obb,rab,ra,rb,debug,dmax,error) + SUBROUTINE lri_int_aabb(saabb,oba,obb,rab,ra,rb,debug,dmax) REAL(KIND=dp), DIMENSION(:, :, :, :), & POINTER :: saabb @@ -573,7 +566,6 @@ SUBROUTINE lri_int_aabb(saabb,oba,obb,rab,ra,rb,debug,dmax,error) REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab, ra, rb LOGICAL, INTENT(IN) :: debug REAL(KIND=dp), INTENT(INOUT) :: dmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_aabb', & routineP = moduleN//':'//routineN @@ -634,9 +626,9 @@ SUBROUTINE lri_int_aabb(saabb,oba,obb,rab,ra,rb,debug,dmax,error) maxl = MAX(maxla,maxlb) lds = ncoset(maxl) ALLOCATE(sint(maxco,maxco,maxco,maxco),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(swork(lds,lds),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sint = 0._dp swork = 0._dp @@ -683,12 +675,12 @@ SUBROUTINE lri_int_aabb(saabb,oba,obb,rab,ra,rb,debug,dmax,error) la_max(jset),la_min(jset),npgfa(jset),zeta(:,jset),& lb_max(kset),lb_min(kset),npgfb(kset),zetb(:,kset),& lb_max(lset),lb_min(lset),npgfb(lset),zetb(:,lset),& - ra,rb,sint,dmax,error) + ra,rb,sint,dmax) ENDIF CALL abcd_contract(saabb(sgfa1:m1,sgfa2:m2,sgfb1:m3,sgfb2:m4),sint,sphi_a(:,sgfa1:),& sphi_a(:,sgfa2:),sphi_b(:,sgfb1:),sphi_b(:,sgfb2:),ncoa1,ncoa2,& - ncob1,ncob2,nsgfa(iset),nsgfa(jset),nsgfb(kset),nsgfb(lset),error) + ncob1,ncob2,nsgfa(iset),nsgfa(jset),nsgfb(kset),nsgfb(lset)) ! account for the fact that some integrals are alike DO isgfa1 = sgfa1,m1 @@ -709,7 +701,7 @@ SUBROUTINE lri_int_aabb(saabb,oba,obb,rab,ra,rb,debug,dmax,error) END DO DEALLOCATE(sint,swork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -725,16 +717,14 @@ END SUBROUTINE lri_int_aabb !> \param ncob ... !> \param nsgfa ... !> \param nsgfb ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ab_contract(abint,sab,sphi_a,sphi_b,ncoa,ncob,nsgfa,nsgfb,error) + SUBROUTINE ab_contract(abint,sab,sphi_a,sphi_b,ncoa,ncob,nsgfa,nsgfb) REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: abint REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: sab, sphi_a, sphi_b INTEGER, INTENT(IN) :: ncoa, ncob, nsgfa, nsgfb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ab_contract', & routineP = moduleN//':'//routineN @@ -754,14 +744,14 @@ SUBROUTINE ab_contract(abint,sab,sphi_a,sphi_b,ncoa,ncob,nsgfa,nsgfb,error) nn = SIZE(abint,1) ALLOCATE(cpp(nsgfa,m2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL dgemm("T","N",nsgfa,m2,ncoa,1._dp,sphi_a,msphia,sab,m1,0.0_dp,cpp,nsgfa) CALL dgemm("N","N",nsgfa,nsgfb,ncob,1._dp,cpp,nsgfa,sphi_b,msphib,0.0_dp,& abint,nn) DEALLOCATE(cpp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE ab_contract @@ -779,16 +769,14 @@ END SUBROUTINE ab_contract !> \param nsgfa ... !> \param nsgfb ... !> \param nsgfc ... -!> \param error ... ! ***************************************************************************** SUBROUTINE abc_contract(abcint,sabc,sphi_a,sphi_b,sphi_c,ncoa,ncob,ncoc,& - nsgfa,nsgfb,nsgfc,error) + nsgfa,nsgfb,nsgfc) REAL(KIND=dp), DIMENSION(:, :, :) :: abcint, sabc REAL(KIND=dp), DIMENSION(:, :) :: sphi_a, sphi_b, sphi_c INTEGER, INTENT(IN) :: ncoa, ncob, ncoc, nsgfa, & nsgfb, nsgfc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'abc_contract', & routineP = moduleN//':'//routineN @@ -812,11 +800,11 @@ SUBROUTINE abc_contract(abcint,sabc,sphi_a,sphi_b,sphi_c,ncoa,ncob,ncoc,& m3 = SIZE(sabc,3) ALLOCATE(cpp(nsgfa,m2,m3),cpc(nsgfa,m2,nsgfc),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cpp = 0._dp cpc = 0._dp ALLOCATE(work_cpc(nsgfa,m2),temp_ccc(nsgfa,nsgfb),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work_cpc(:,:) = 0._dp temp_ccc(:,:) = 0._dp @@ -832,7 +820,7 @@ SUBROUTINE abc_contract(abcint,sabc,sphi_a,sphi_b,sphi_c,ncoa,ncob,ncoc,& END DO DEALLOCATE(cpp,cpc,work_cpc,temp_ccc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -855,10 +843,9 @@ END SUBROUTINE abc_contract !> \param nsgfb ... !> \param nsgfc ... !> \param nsgfd ... -!> \param error ... ! ***************************************************************************** SUBROUTINE abcd_contract(abcdint,sabcd,sphi_a,sphi_b,sphi_c,sphi_d,ncoa,ncob,& - ncoc,ncod,nsgfa,nsgfb,nsgfc,nsgfd,error) + ncoc,ncod,nsgfa,nsgfb,nsgfc,nsgfd) REAL(KIND=dp), DIMENSION(:, :, :, :), & INTENT(INOUT) :: abcdint @@ -868,7 +855,6 @@ SUBROUTINE abcd_contract(abcdint,sabcd,sphi_a,sphi_b,sphi_c,sphi_d,ncoa,ncob,& INTENT(IN) :: sphi_a, sphi_b, sphi_c, sphi_d INTEGER, INTENT(IN) :: ncoa, ncob, ncoc, ncod, & nsgfa, nsgfb, nsgfc, nsgfd - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'abcd_contract', & routineP = moduleN//':'//routineN @@ -898,15 +884,15 @@ SUBROUTINE abcd_contract(abcdint,sabcd,sphi_a,sphi_b,sphi_c,sphi_d,ncoa,ncob,& ALLOCATE(cppp(nsgfa,m2,m3,m4),cppc(nsgfa,m2,m3,nsgfd),& cpcc(nsgfa,m2,nsgfc,nsgfd),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work_cppc(nsgfa,m2,m3),temp_cpcc(nsgfa,m2,nsgfc),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work_cppc = 0._dp temp_cpcc = 0._dp ALLOCATE(work_cpcc(nsgfa,m2),temp_cccc(nsgfa,nsgfb),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work_cpcc = 0._dp temp_cccc = 0._dp @@ -929,9 +915,9 @@ SUBROUTINE abcd_contract(abcdint,sabcd,sphi_a,sphi_b,sphi_c,sphi_d,ncoa,ncob,& END DO DEALLOCATE(cpcc,cppc,cppp,stat=STAT) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work_cpcc,work_cppc,temp_cpcc,temp_cccc,stat=STAT) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/lri_shg_integrals.F b/src/lri_shg_integrals.F index 9fd6823e2c..7882dc21c7 100644 --- a/src/lri_shg_integrals.F +++ b/src/lri_shg_integrals.F @@ -54,10 +54,9 @@ MODULE lri_shg_integrals !> \param Waux_mat matrix storing angular-dependent part !> \param dWaux_mat ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** SUBROUTINE precalc_angular_shg_part(oba,obb,fba,fbb,rab,Waux_mat,dWaux_mat,& - calculate_forces,error) + calculate_forces) TYPE(gto_basis_set_type), POINTER :: oba, obb, fba, fbb REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rab @@ -66,7 +65,6 @@ SUBROUTINE precalc_angular_shg_part(oba,obb,fba,fbb,rab,Waux_mat,dWaux_mat,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'precalc_angular_shg_part', & routineP = moduleN//':'//routineN @@ -104,9 +102,9 @@ SUBROUTINE precalc_angular_shg_part(oba,obb,fba,fbb,rab,Waux_mat,dWaux_mat,& lmax = li_max ALLOCATE(li_max_all(0:lj_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Rc(0:lmax,-2*lmax:2*lmax),Rs(0:lmax,-2*lmax:2*lmax),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Rc=0._dp Rs=0._dp mdim(1) = nsoset(li_max) + 1 @@ -114,9 +112,9 @@ SUBROUTINE precalc_angular_shg_part(oba,obb,fba,fbb,rab,Waux_mat,dWaux_mat,& mdim(3) = li_max+lj_max + 1 mdim(4) = 4 ALLOCATE(Waux_mat(mdim(1),mdim(2),mdim(3),mdim(4)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dWaux_mat(3,mdim(1),mdim(2),mdim(3),mdim(4)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !Waux_mat = 0._dp !.. takes time !*** Waux_mat (li_max,lj_max) contains elements not needed, @@ -147,11 +145,11 @@ SUBROUTINE precalc_angular_shg_part(oba,obb,fba,fbb,rab,Waux_mat,dWaux_mat,& CALL get_real_scaled_solid_harmonic(Rc,Rs,lmax,-rab,rab2) CALL get_W_matrix(li_max_all,lj_max,lmax,Rc,Rs,Waux_mat) IF(calculate_forces) THEN - CALL get_dW_matrix(li_max_all,lj_max,Waux_mat,dWaux_mat,error) + CALL get_dW_matrix(li_max_all,lj_max,Waux_mat,dWaux_mat) ENDIF DEALLOCATE(Rc,Rs,li_max_all,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -172,11 +170,10 @@ END SUBROUTINE precalc_angular_shg_part !> \param Waux_mat angular-depedent part !> \param dWaux_mat derivative of Waux_mat !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_aba_shg(lri_env,abaint,dabdaint,rab,oba,obb,fba,scona_shg,& sconb_shg,sconca_shg,Waux_mat,dWaux_mat,& - calculate_forces,error) + calculate_forces) TYPE(lri_environment_type), POINTER :: lri_env REAL(KIND=dp), DIMENSION(:, :, :), & @@ -193,7 +190,6 @@ SUBROUTINE lri_int_aba_shg(lri_env,abaint,dabdaint,rab,oba,obb,fba,scona_shg,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_aba_shg', & routineP = moduleN//':'//routineN @@ -275,9 +271,9 @@ SUBROUTINE lri_int_aba_shg(lri_env,abaint,dabdaint,rab,oba,obb,fba,scona_shg,& nds_max = laa_max_set + lb_max_set + ndev + 1 nl_set = INT((laa_max_set)/2) ALLOCATE(swork(npgfa_set,npgfb_set,npgfca_set,0:nl_set,nds_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(swork_cont(nshella_set,nshellb_set,nshellca_set,0:nl_set,nds_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iset=1,nseta @@ -292,8 +288,7 @@ SUBROUTINE lri_int_aba_shg(lri_env,abaint,dabdaint,rab,oba,obb,fba,scona_shg,& CALL s_overlap_abx(la_max(iset),npgfa(iset),zeta(:,iset),& lb_max(jset),npgfb(jset),zetb(:,jset),& lca_max(kset),npgfca(kset),zetca(:,kset),& - rab,swork,calculate_forces,calc_aba=.TRUE.,& - error=error) + rab,swork,calculate_forces,calc_aba=.TRUE.) swork_cont = 0.0_dp DO ishella = 1, nshella(iset) @@ -369,7 +364,7 @@ SUBROUTINE lri_int_aba_shg(lri_env,abaint,dabdaint,rab,oba,obb,fba,scona_shg,& CALL cp_unimplemented_error(fromWhere=routineP, & message="SHG integrals not implemented when l quantum number"//& " of orbital and ri basis larger than 11", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ENDIF ENDDO ENDDO @@ -400,9 +395,9 @@ SUBROUTINE lri_int_aba_shg(lri_env,abaint,dabdaint,rab,oba,obb,fba,scona_shg,& END DO DEALLOCATE(swork_cont,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(swork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -423,11 +418,10 @@ END SUBROUTINE lri_int_aba_shg !> \param Waux_mat angular-dependent part !> \param dWaux_mat derivative of Waux_mat !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_abb_shg(lri_env,abbint,dabbint,rab,oba,obb,fbb,scona_shg,& sconb_shg,sconcb_shg,Waux_mat,dWaux_mat,& - calculate_forces,error) + calculate_forces) TYPE(lri_environment_type), POINTER :: lri_env REAL(KIND=dp), DIMENSION(:, :, :), & @@ -444,7 +438,6 @@ SUBROUTINE lri_int_abb_shg(lri_env,abbint,dabbint,rab,oba,obb,fbb,scona_shg,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_abb_shg', & routineP = moduleN//':'//routineN @@ -526,9 +519,9 @@ SUBROUTINE lri_int_abb_shg(lri_env,abbint,dabbint,rab,oba,obb,fbb,scona_shg,& nds_max = la_max_set + lbb_max_set + ndev + 1 nl_set = INT((lbb_max_set)/2) ALLOCATE(swork(1:npgfa_set,1:npgfb_set,1:npgfcb_set,0:nl_set,1:nds_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(swork_cont(nshella_set,nshellb_set,nshellcb_set,0:nl_set,nds_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iset=1,nseta @@ -543,8 +536,7 @@ SUBROUTINE lri_int_abb_shg(lri_env,abbint,dabbint,rab,oba,obb,fbb,scona_shg,& CALL s_overlap_abx(la_max(iset),npgfa(iset),zeta(:,iset),& lb_max(jset),npgfb(jset),zetb(:,jset),& lcb_max(kset),npgfcb(kset),zetcb(:,kset),& - rab,swork,calculate_forces,calc_aba=.FALSE.,& - error=error) + rab,swork,calculate_forces,calc_aba=.FALSE.) swork_cont = 0.0_dp DO ishella = 1, nshella(iset) @@ -620,7 +612,7 @@ SUBROUTINE lri_int_abb_shg(lri_env,abbint,dabbint,rab,oba,obb,fbb,scona_shg,& CALL cp_unimplemented_error(fromWhere=routineP, & message="SHG integrals not implemented when l quantum number"//& " of orbital and ri basis larger than 11", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ENDIF ENDDO ENDDO @@ -650,9 +642,9 @@ SUBROUTINE lri_int_abb_shg(lri_env,abbint,dabbint,rab,oba,obb,fbb,scona_shg,& END DO DEALLOCATE(swork_cont,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(swork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -670,10 +662,9 @@ END SUBROUTINE lri_int_abb_shg !> \param Waux_mat angular-dependent part !> \param dWaux_mat derivative of Waux_mat !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** SUBROUTINE lri_int_ab_shg(sab,dsab,rab,fba,fbb,scona_shg,sconb_shg,Waux_mat,& - dWaux_mat,calculate_forces,error) + dWaux_mat,calculate_forces) REAL(KIND=dp), DIMENSION(:, :), POINTER :: sab REAL(KIND=dp), DIMENSION(:, :, :), & @@ -687,7 +678,6 @@ SUBROUTINE lri_int_ab_shg(sab,dsab,rab,fba,fbb,scona_shg,sconb_shg,Waux_mat,& REAL(KIND=dp), & DIMENSION(:, :, :, :, :), POINTER :: dWaux_mat LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_int_ab_shg', & routineP = moduleN//':'//routineN @@ -743,9 +733,9 @@ SUBROUTINE lri_int_ab_shg(sab,dsab,rab,fba,fbb,scona_shg,sconb_shg,Waux_mat,& IF(calculate_forces) ndev = 1 nds_max = la_max_set + lb_max_set + ndev + 1 ALLOCATE(swork(npgfa_set,npgfb_set,nds_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(swork_cont(nshella_set,nshellb_set,nds_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iset=1,nseta @@ -792,7 +782,7 @@ SUBROUTINE lri_int_ab_shg(sab,dsab,rab,fba,fbb,scona_shg,sconb_shg,Waux_mat,& END DO DEALLOCATE(swork,swork_cont,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/ls_matrix_exp.F b/src/ls_matrix_exp.F index 8ce6419997..34faf9d587 100644 --- a/src/ls_matrix_exp.F +++ b/src/ls_matrix_exp.F @@ -52,7 +52,6 @@ MODULE ls_matrix_exp !> \param C_re m x n matrix, real part !> \param C_im m x n matrix, imaginary part !> \param filter_eps ... -!> \param error ... !> \author Samuel Andermatt !> \note !> C should have no overlap with A, B @@ -63,14 +62,13 @@ MODULE ls_matrix_exp ! ***************************************************************************** SUBROUTINE cp_complex_dbcsr_gemm_3(transa, transb, alpha, A_re, A_im,& - B_re, B_im, beta, C_re, C_im, filter_eps, error) + B_re, B_im, beta, C_re, C_im, filter_eps) CHARACTER(LEN=1), INTENT(IN) :: transa, transb REAL(KIND=dp), INTENT(IN) :: alpha TYPE(cp_dbcsr_type), INTENT(IN) :: A_re, A_im, B_re, B_im REAL(KIND=dp), INTENT(IN) :: beta TYPE(cp_dbcsr_type), INTENT(INOUT) :: C_re, C_im REAL(KIND=dp), INTENT(IN), OPTIONAL :: filter_eps - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_complex_dbcsr_gemm_3', & routineP = moduleN//':'//routineN @@ -111,54 +109,54 @@ SUBROUTINE cp_complex_dbcsr_gemm_3(transa, transb, alpha, A_re, A_im,& !create the work matrices NULLIFY(ac) ALLOCATE(ac,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(ac,error=error) - CALL cp_dbcsr_create(ac,template=A_re,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(ac) + CALL cp_dbcsr_create(ac,template=A_re,matrix_type="N") NULLIFY(bd) ALLOCATE(bd,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(bd,error=error) - CALL cp_dbcsr_create(bd,template=A_re,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(bd) + CALL cp_dbcsr_create(bd,template=A_re,matrix_type="N") NULLIFY(a_plus_b) ALLOCATE(a_plus_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(a_plus_b,error=error) - CALL cp_dbcsr_create(a_plus_b,template=A_re,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(a_plus_b) + CALL cp_dbcsr_create(a_plus_b,template=A_re,matrix_type="N") NULLIFY(c_plus_d) ALLOCATE(c_plus_d,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(c_plus_d,error=error) - CALL cp_dbcsr_create(c_plus_d,template=A_re,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(c_plus_d) + CALL cp_dbcsr_create(c_plus_d,template=A_re,matrix_type="N") !Do the neccesarry multiplications - CALL cp_dbcsr_multiply(transa2,transb2,alpha,A_re,B_re,zero,ac,filter_eps=filter_eps,error=error) - CALL cp_dbcsr_multiply(transa2,transb2,alpha2,A_im,B_im,zero,bd,filter_eps=filter_eps,error=error) + CALL cp_dbcsr_multiply(transa2,transb2,alpha,A_re,B_re,zero,ac,filter_eps=filter_eps) + CALL cp_dbcsr_multiply(transa2,transb2,alpha2,A_im,B_im,zero,bd,filter_eps=filter_eps) - CALL cp_dbcsr_add(a_plus_b,A_re,zero,alpha,error=error) - CALL cp_dbcsr_add(a_plus_b,A_im,one,alpha3,error=error) - CALL cp_dbcsr_add(c_plus_d,B_re,zero,alpha,error=error) - CALL cp_dbcsr_add(c_plus_d,B_im,one,alpha4,error=error) + CALL cp_dbcsr_add(a_plus_b,A_re,zero,alpha) + CALL cp_dbcsr_add(a_plus_b,A_im,one,alpha3) + CALL cp_dbcsr_add(c_plus_d,B_re,zero,alpha) + CALL cp_dbcsr_add(c_plus_d,B_im,one,alpha4) !this can already be written into C_im !now both matrixes have been scaled which means we currently multiplied by alpha squared - CALL cp_dbcsr_multiply(transa2,transb2,one/alpha,a_plus_b,c_plus_d,beta,C_im,filter_eps=filter_eps,error=error) + CALL cp_dbcsr_multiply(transa2,transb2,one/alpha,a_plus_b,c_plus_d,beta,C_im,filter_eps=filter_eps) !now add up all the terms into the result - CALL cp_dbcsr_add(C_re,ac,beta,one,error=error) + CALL cp_dbcsr_add(C_re,ac,beta,one) !the minus sign was already taken care of at the definition of alpha2 - CALL cp_dbcsr_add(C_re,bd,one,one,error=error) - CALL cp_dbcsr_filter(C_re,filter_eps,error=error) + CALL cp_dbcsr_add(C_re,bd,one,one) + CALL cp_dbcsr_filter(C_re,filter_eps) - CALL cp_dbcsr_add(C_im,ac,one,-one,error=error) + CALL cp_dbcsr_add(C_im,ac,one,-one) !the minus sign was already taken care of at the definition of alpha2 - CALL cp_dbcsr_add(C_im,bd,one,one,error=error) - CALL cp_dbcsr_filter(C_im,filter_eps,error=error) + CALL cp_dbcsr_add(C_im,bd,one,one) + CALL cp_dbcsr_filter(C_im,filter_eps) !Deallocate the work matrices - CALL cp_dbcsr_deallocate_matrix(ac,error=error) - CALL cp_dbcsr_deallocate_matrix(bd,error=error) - CALL cp_dbcsr_deallocate_matrix(a_plus_b,error=error) - CALL cp_dbcsr_deallocate_matrix(c_plus_d,error=error) + CALL cp_dbcsr_deallocate_matrix(ac) + CALL cp_dbcsr_deallocate_matrix(bd) + CALL cp_dbcsr_deallocate_matrix(a_plus_b) + CALL cp_dbcsr_deallocate_matrix(c_plus_d) CALL timestop(handle) @@ -171,17 +169,15 @@ SUBROUTINE cp_complex_dbcsr_gemm_3(transa, transb, alpha, A_re, A_im,& !> \param nsquare ... !> \param ntaylor ... !> \param filter_eps ... -!> \param error ... !> \author Samuel Andermatt (02.2014) ! ***************************************************************************** - SUBROUTINE taylor_only_imaginary_dbcsr(exp_H,im_matrix,nsquare,ntaylor,filter_eps,error) + SUBROUTINE taylor_only_imaginary_dbcsr(exp_H,im_matrix,nsquare,ntaylor,filter_eps) TYPE(cp_dbcsr_p_type), DIMENSION(2) :: exp_H TYPE(cp_dbcsr_type), POINTER :: im_matrix INTEGER, INTENT(in) :: nsquare, ntaylor REAL(KIND=dp), INTENT(in) :: filter_eps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'taylor_only_imaginary_dbcsr', & routineP = moduleN//':'//routineN @@ -202,50 +198,50 @@ SUBROUTINE taylor_only_imaginary_dbcsr(exp_H,im_matrix,nsquare,ntaylor,filter_ep !Allocate work matrices NULLIFY(T1) ALLOCATE(T1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(T1,error=error) - CALL cp_dbcsr_create(T1,template=im_matrix,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(T1) + CALL cp_dbcsr_create(T1,template=im_matrix,matrix_type="N") NULLIFY(T2) ALLOCATE(T2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(T2,error=error) - CALL cp_dbcsr_create(T2,template=im_matrix,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(T2) + CALL cp_dbcsr_create(T2,template=im_matrix,matrix_type="N") NULLIFY(Tres_re) ALLOCATE(Tres_re,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(Tres_re,error=error) - CALL cp_dbcsr_create(Tres_re,template=im_matrix,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(Tres_re) + CALL cp_dbcsr_create(Tres_re,template=im_matrix,matrix_type="N") NULLIFY(Tres_im) ALLOCATE(Tres_im,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(Tres_im,error=error) - CALL cp_dbcsr_create(Tres_im,template=im_matrix,matrix_type="N",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(Tres_im) + CALL cp_dbcsr_create(Tres_im,template=im_matrix,matrix_type="N") !Create the unit matrices - CALL cp_dbcsr_set(T1,zero,error=error) - CALL cp_dbcsr_add_on_diag(T1,one,error=error) - CALL cp_dbcsr_set(Tres_re,zero,error=error) - CALL cp_dbcsr_add_on_diag(Tres_re,one,error=error) - CALL cp_dbcsr_set(Tres_im,zero,error=error) + CALL cp_dbcsr_set(T1,zero) + CALL cp_dbcsr_add_on_diag(T1,one) + CALL cp_dbcsr_set(Tres_re,zero) + CALL cp_dbcsr_add_on_diag(Tres_re,one) + CALL cp_dbcsr_set(Tres_im,zero) nloop=CEILING(REAL(ntaylor,dp)/2.0_dp) !the inverse of the prefactor in the taylor series tmp=1.0_dp DO i=1,nloop - CALL cp_dbcsr_scale(T1,1.0_dp/(REAL(i,dp)*2.0_dp-1.0_dp),error=error) - CALL cp_dbcsr_filter(T1,filter_eps,error=error) + CALL cp_dbcsr_scale(T1,1.0_dp/(REAL(i,dp)*2.0_dp-1.0_dp)) + CALL cp_dbcsr_filter(T1,filter_eps) CALL cp_dbcsr_multiply("N","N",square_fac,im_matrix,T1,zero,& - T2,filter_eps=filter_eps,error=error) + T2,filter_eps=filter_eps) Tfac=one IF(MOD(i,2)==0) Tfac=-Tfac - CALL cp_dbcsr_add(Tres_im,T2,one,Tfac,error=error) - CALL cp_dbcsr_scale(T2,1.0_dp/(REAL(i,dp)*2.0_dp),error=error) - CALL cp_dbcsr_filter(T2,filter_eps,error=error) + CALL cp_dbcsr_add(Tres_im,T2,one,Tfac) + CALL cp_dbcsr_scale(T2,1.0_dp/(REAL(i,dp)*2.0_dp)) + CALL cp_dbcsr_filter(T2,filter_eps) CALL cp_dbcsr_multiply("N","N",square_fac,im_matrix,T2,zero,& - T1,filter_eps=filter_eps,error=error) + T1,filter_eps=filter_eps) Tfac=one IF(MOD(i,2)==1) Tfac=-Tfac - CALL cp_dbcsr_add(Tres_re,T1,one,Tfac,error=error) + CALL cp_dbcsr_add(Tres_re,T1,one,Tfac) END DO !Square the matrices, due to the scaling and squaring procedure @@ -253,18 +249,18 @@ SUBROUTINE taylor_only_imaginary_dbcsr(exp_H,im_matrix,nsquare,ntaylor,filter_ep DO i=1,nsquare CALL cp_complex_dbcsr_gemm_3("N","N",one,Tres_re,Tres_im,& Tres_re,Tres_im,zero,exp_H(1)%matrix,exp_H(2)%matrix,& - filter_eps=filter_eps,error=error) - CALL cp_dbcsr_copy(Tres_re,exp_H(1)%matrix,error=error) - CALL cp_dbcsr_copy(Tres_im,exp_H(2)%matrix,error=error) + filter_eps=filter_eps) + CALL cp_dbcsr_copy(Tres_re,exp_H(1)%matrix) + CALL cp_dbcsr_copy(Tres_im,exp_H(2)%matrix) END DO ELSE - CALL cp_dbcsr_copy(exp_H(1)%matrix,Tres_re,error=error) - CALL cp_dbcsr_copy(exp_H(2)%matrix,Tres_im,error=error) + CALL cp_dbcsr_copy(exp_H(1)%matrix,Tres_re) + CALL cp_dbcsr_copy(exp_H(2)%matrix,Tres_im) END IF - CALL cp_dbcsr_deallocate_matrix(T1,error=error) - CALL cp_dbcsr_deallocate_matrix(T2,error=error) - CALL cp_dbcsr_deallocate_matrix(Tres_re,error=error) - CALL cp_dbcsr_deallocate_matrix(Tres_im,error=error) + CALL cp_dbcsr_deallocate_matrix(T1) + CALL cp_dbcsr_deallocate_matrix(T2) + CALL cp_dbcsr_deallocate_matrix(Tres_re) + CALL cp_dbcsr_deallocate_matrix(Tres_im) CALL timestop(handle) @@ -283,15 +279,13 @@ END SUBROUTINE taylor_only_imaginary_dbcsr !> \param nsquare ... !> \param ntaylor ... !> \param filter_eps ... -!> \param error ... !> \author Samuel Andermatt (02.2014) ! ***************************************************************************** - SUBROUTINE taylor_full_complex_dbcsr(exp_H,re_part,im_part,nsquare,ntaylor,filter_eps,error) + SUBROUTINE taylor_full_complex_dbcsr(exp_H,re_part,im_part,nsquare,ntaylor,filter_eps) TYPE(cp_dbcsr_p_type), DIMENSION(2) :: exp_H TYPE(cp_dbcsr_type), POINTER :: re_part, im_part INTEGER, INTENT(in) :: nsquare, ntaylor REAL(KIND=dp), INTENT(in) :: filter_eps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'taylor_full_complex_dbcsr', & routineP = moduleN//':'//routineN @@ -313,67 +307,67 @@ SUBROUTINE taylor_full_complex_dbcsr(exp_H,re_part,im_part,nsquare,ntaylor,filte !Allocate work matrices NULLIFY(T1) ALLOCATE(T1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(T1,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(T1) CALL cp_dbcsr_create(T1,template=re_part,matrix_type="N",& - data_type=dbcsr_type_complex_8,error=error) + data_type=dbcsr_type_complex_8) NULLIFY(T2) ALLOCATE(T2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(T2,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(T2) CALL cp_dbcsr_create(T2,template=re_part,matrix_type="N",& - data_type=dbcsr_type_complex_8,error=error) + data_type=dbcsr_type_complex_8) NULLIFY(T3) ALLOCATE(T3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(T3,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(T3) CALL cp_dbcsr_create(T3,template=re_part,matrix_type="N",& - data_type=dbcsr_type_complex_8,error=error) + data_type=dbcsr_type_complex_8) NULLIFY(Tres) ALLOCATE(Tres,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(Tres,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(Tres) CALL cp_dbcsr_create(Tres,template=re_part,matrix_type="N",& - data_type=dbcsr_type_complex_8,error=error) + data_type=dbcsr_type_complex_8) !Fuse the input matrices to a single complex matrix - CALL cp_dbcsr_copy(T3,re_part,error=error) - CALL cp_dbcsr_copy(Tres,im_part,error=error) !will later on be set back to zero - CALL cp_dbcsr_scale(Tres,CMPLX(0.0_dp,1.0_dp,KIND=dp),error=error) - CALL cp_dbcsr_add(T3,Tres,one,one,error=error) + CALL cp_dbcsr_copy(T3,re_part) + CALL cp_dbcsr_copy(Tres,im_part) !will later on be set back to zero + CALL cp_dbcsr_scale(Tres,CMPLX(0.0_dp,1.0_dp,KIND=dp)) + CALL cp_dbcsr_add(T3,Tres,one,one) !Create the unit matrices - CALL cp_dbcsr_set(T1,zero,error=error) - CALL cp_dbcsr_add_on_diag(T1,1.0_dp,error=error) - CALL cp_dbcsr_set(Tres,zero,error=error) - CALL cp_dbcsr_add_on_diag(Tres,1.0_dp,error=error) + CALL cp_dbcsr_set(T1,zero) + CALL cp_dbcsr_add_on_diag(T1,1.0_dp) + CALL cp_dbcsr_set(Tres,zero) + CALL cp_dbcsr_add_on_diag(Tres,1.0_dp) DO i=1,ntaylor - CALL cp_dbcsr_scale(T1,one/CMPLX(i*1.0_dp,0.0_dp,KIND=dp),error=error) - CALL cp_dbcsr_filter(T1,filter_eps,error=error) + CALL cp_dbcsr_scale(T1,one/CMPLX(i*1.0_dp,0.0_dp,KIND=dp)) + CALL cp_dbcsr_filter(T1,filter_eps) CALL cp_dbcsr_multiply("N","N",square_fac,T1,T3,& - zero,T2,filter_eps=filter_eps,error=error) - CALL cp_dbcsr_add(Tres,T2,one,one,error=error) - CALL cp_dbcsr_copy(T1,T2,error=error) + zero,T2,filter_eps=filter_eps) + CALL cp_dbcsr_add(Tres,T2,one,one) + CALL cp_dbcsr_copy(T1,T2) END DO IF(nsquare.GT.0)THEN DO i=1,nsquare CALL cp_dbcsr_multiply("N","N",one,Tres,Tres,zero,& - T2,filter_eps=filter_eps,error=error) - CALL cp_dbcsr_copy(Tres,T2,error=error) + T2,filter_eps=filter_eps) + CALL cp_dbcsr_copy(Tres,T2) END DO END IF - CALL cp_dbcsr_copy(exp_H(1)%matrix,Tres,keep_imaginary=.FALSE.,error=error) - CALL cp_dbcsr_scale(Tres,CMPLX(0.0_dp,-1.0_dp,KIND=dp),error=error) - CALL cp_dbcsr_copy(exp_H(2)%matrix,Tres,keep_imaginary=.FALSE.,error=error) + CALL cp_dbcsr_copy(exp_H(1)%matrix,Tres,keep_imaginary=.FALSE.) + CALL cp_dbcsr_scale(Tres,CMPLX(0.0_dp,-1.0_dp,KIND=dp)) + CALL cp_dbcsr_copy(exp_H(2)%matrix,Tres,keep_imaginary=.FALSE.) - CALL cp_dbcsr_deallocate_matrix(T1,error=error) - CALL cp_dbcsr_deallocate_matrix(T2,error=error) - CALL cp_dbcsr_deallocate_matrix(T3,error=error) - CALL cp_dbcsr_deallocate_matrix(Tres,error=error) + CALL cp_dbcsr_deallocate_matrix(T1) + CALL cp_dbcsr_deallocate_matrix(T2) + CALL cp_dbcsr_deallocate_matrix(T3) + CALL cp_dbcsr_deallocate_matrix(Tres) CALL timestop(handle) @@ -388,16 +382,14 @@ END SUBROUTINE taylor_full_complex_dbcsr !> \param filter_eps The filtering threshold for all matrices !> \param filter_eps_small ... !> \param eps_exp The accuracy of the exponential -!> \param error The cp2k error type !> \author Samuel Andermatt (02.2014) ! ***************************************************************************** - SUBROUTINE bch_expansion_imaginary_propagator(propagator,density_re,density_im,filter_eps,filter_eps_small,eps_exp,error) + SUBROUTINE bch_expansion_imaginary_propagator(propagator,density_re,density_im,filter_eps,filter_eps_small,eps_exp) TYPE(cp_dbcsr_type), POINTER :: propagator, density_re, & density_im REAL(KIND=dp), INTENT(in) :: filter_eps, filter_eps_small, & eps_exp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'bch_expansion_imaginary_propagator', & @@ -412,49 +404,49 @@ SUBROUTINE bch_expansion_imaginary_propagator(propagator,density_re,density_im,f CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_nr = cp_logger_get_default_io_unit(logger) failure=.FALSE. NULLIFY(tmp) ALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=propagator,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=propagator) NULLIFY(tmp2) ALLOCATE(tmp2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=propagator,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=propagator) NULLIFY(comm) ALLOCATE(comm,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(comm,error=error) - CALL cp_dbcsr_create(comm,template=propagator,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(comm) + CALL cp_dbcsr_create(comm,template=propagator) NULLIFY(comm2) ALLOCATE(comm2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(comm2,error=error) - CALL cp_dbcsr_create(comm2,template=propagator,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(comm2) + CALL cp_dbcsr_create(comm2,template=propagator) - CALL cp_dbcsr_copy(tmp,density_re,error=error) - CALL cp_dbcsr_copy(tmp2,density_im,error=error) + CALL cp_dbcsr_copy(tmp,density_re) + CALL cp_dbcsr_copy(tmp2,density_im) convergence=.FALSE. DO i=1,20 prefac=one/i CALL cp_dbcsr_multiply("N","N",-prefac,propagator,tmp2,zero,comm,& - filter_eps=filter_eps_small,error=error) + filter_eps=filter_eps_small) CALL cp_dbcsr_multiply("N","N",prefac,propagator,tmp,zero,comm2,& - filter_eps=filter_eps_small,error=error) - CALL cp_dbcsr_transposed(tmp,comm,error=error) - CALL cp_dbcsr_transposed(tmp2,comm2,error=error) - CALL cp_dbcsr_add(comm,tmp,one,one,error=error) - CALL cp_dbcsr_add(comm2,tmp2,one,-one,error=error) - CALL cp_dbcsr_add(density_re,comm,one,one,error=error) - CALL cp_dbcsr_add(density_im,comm2,one,one,error=error) - CALL cp_dbcsr_copy(tmp,comm,error=error) - CALL cp_dbcsr_copy(tmp2,comm2,error=error) + filter_eps=filter_eps_small) + CALL cp_dbcsr_transposed(tmp,comm) + CALL cp_dbcsr_transposed(tmp2,comm2) + CALL cp_dbcsr_add(comm,tmp,one,one) + CALL cp_dbcsr_add(comm2,tmp2,one,-one) + CALL cp_dbcsr_add(density_re,comm,one,one) + CALL cp_dbcsr_add(density_im,comm2,one,one) + CALL cp_dbcsr_copy(tmp,comm) + CALL cp_dbcsr_copy(tmp2,comm2) !check for convergence max_alpha=zero alpha = cp_dbcsr_frobenius_norm(comm) @@ -469,18 +461,18 @@ SUBROUTINE bch_expansion_imaginary_propagator(propagator,density_re,density_im,f ENDIF ENDDO - CALL cp_dbcsr_filter(density_re,filter_eps,error=error) - CALL cp_dbcsr_filter(density_im,filter_eps,error=error) + CALL cp_dbcsr_filter(density_re,filter_eps) + CALL cp_dbcsr_filter(density_im,filter_eps) CALL cp_assert(convergence,cp_warning_level,cp_assertion_failed,routineP,& "BCH method did not converge"//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp2,error=error) - CALL cp_dbcsr_deallocate_matrix(comm,error=error) - CALL cp_dbcsr_deallocate_matrix(comm2,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp) + CALL cp_dbcsr_deallocate_matrix(tmp2) + CALL cp_dbcsr_deallocate_matrix(comm) + CALL cp_dbcsr_deallocate_matrix(comm2) CALL timestop(handle) @@ -496,17 +488,15 @@ SUBROUTINE bch_expansion_imaginary_propagator(propagator,density_re,density_im,f !> \param filter_eps The filtering threshold for all matrices !> \param filter_eps_small ... !> \param eps_exp The accuracy of the exponential -!> \param error The cp2k error type !> \author Samuel Andermatt (02.2014) ! ***************************************************************************** SUBROUTINE bch_expansion_complex_propagator(propagator_re,propagator_im,density_re,density_im,filter_eps,& - filter_eps_small,eps_exp,error) + filter_eps_small,eps_exp) TYPE(cp_dbcsr_type), POINTER :: propagator_re, propagator_im, & density_re, density_im REAL(KIND=dp), INTENT(in) :: filter_eps, filter_eps_small, & eps_exp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'bch_expansion_complex_propagator', & @@ -521,48 +511,48 @@ SUBROUTINE bch_expansion_complex_propagator(propagator_re,propagator_im,density_ CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_nr = cp_logger_get_default_io_unit(logger) failure=.FALSE. NULLIFY(tmp) ALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=propagator_re,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=propagator_re) NULLIFY(tmp2) ALLOCATE(tmp2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=propagator_re,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=propagator_re) NULLIFY(comm) ALLOCATE(comm,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(comm,error=error) - CALL cp_dbcsr_create(comm,template=propagator_re,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(comm) + CALL cp_dbcsr_create(comm,template=propagator_re) NULLIFY(comm2) ALLOCATE(comm2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(comm2,error=error) - CALL cp_dbcsr_create(comm2,template=propagator_re,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(comm2) + CALL cp_dbcsr_create(comm2,template=propagator_re) - CALL cp_dbcsr_copy(tmp,density_re,error=error) - CALL cp_dbcsr_copy(tmp2,density_im,error=error) + CALL cp_dbcsr_copy(tmp,density_re) + CALL cp_dbcsr_copy(tmp2,density_im) convergence=.FALSE. DO i=1,20 prefac=one/i CALL cp_complex_dbcsr_gemm_3("N", "N", prefac, propagator_re, propagator_im,& - tmp, tmp2, zero, comm, comm2, filter_eps=filter_eps_small, error=error) - CALL cp_dbcsr_transposed(tmp,comm,error=error) - CALL cp_dbcsr_transposed(tmp2,comm2,error=error) - CALL cp_dbcsr_add(comm,tmp,one,one,error=error) - CALL cp_dbcsr_add(comm2,tmp2,one,-one,error=error) - CALL cp_dbcsr_add(density_re,comm,one,one,error=error) - CALL cp_dbcsr_add(density_im,comm2,one,one,error=error) - CALL cp_dbcsr_copy(tmp,comm,error=error) - CALL cp_dbcsr_copy(tmp2,comm2,error=error) + tmp, tmp2, zero, comm, comm2, filter_eps=filter_eps_small) + CALL cp_dbcsr_transposed(tmp,comm) + CALL cp_dbcsr_transposed(tmp2,comm2) + CALL cp_dbcsr_add(comm,tmp,one,one) + CALL cp_dbcsr_add(comm2,tmp2,one,-one) + CALL cp_dbcsr_add(density_re,comm,one,one) + CALL cp_dbcsr_add(density_im,comm2,one,one) + CALL cp_dbcsr_copy(tmp,comm) + CALL cp_dbcsr_copy(tmp2,comm2) !check for convergence max_alpha=zero alpha = cp_dbcsr_frobenius_norm(comm) @@ -577,18 +567,18 @@ SUBROUTINE bch_expansion_complex_propagator(propagator_re,propagator_im,density_ ENDIF ENDDO - CALL cp_dbcsr_filter(density_re,filter_eps,error=error) - CALL cp_dbcsr_filter(density_im,filter_eps,error=error) + CALL cp_dbcsr_filter(density_re,filter_eps) + CALL cp_dbcsr_filter(density_im,filter_eps) CALL cp_assert(convergence,cp_warning_level,cp_assertion_failed,routineP,& "BCH method did not converge "//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp2,error=error) - CALL cp_dbcsr_deallocate_matrix(comm,error=error) - CALL cp_dbcsr_deallocate_matrix(comm2,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp) + CALL cp_dbcsr_deallocate_matrix(tmp2) + CALL cp_dbcsr_deallocate_matrix(comm) + CALL cp_dbcsr_deallocate_matrix(comm2) CALL timestop(handle) diff --git a/src/manybody_eam.F b/src/manybody_eam.F index d1f8c7be97..b1ce24e4aa 100644 --- a/src/manybody_eam.F +++ b/src/manybody_eam.F @@ -46,17 +46,14 @@ MODULE manybody_eam !> \param particle_set ... !> \param cell ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author CJM ! ***************************************************************************** - SUBROUTINE density_nonbond (fist_nonbond_env, particle_set, cell, para_env, error) + SUBROUTINE density_nonbond (fist_nonbond_env, particle_set, cell, para_env) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(particle_type), DIMENSION(:), & INTENT(INOUT) :: particle_set TYPE(cell_type), POINTER :: cell TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_nonbond', & routineP = moduleN//':'//routineN @@ -81,18 +78,18 @@ SUBROUTINE density_nonbond (fist_nonbond_env, particle_set, cell, para_env, erro do_eam = .FALSE. CALL fist_nonbond_env_get ( fist_nonbond_env, nonbonded = nonbonded, & potparm = potparm, r_last_update=r_last_update,& - r_last_update_pbc=r_last_update_pbc, eam_data=eam_data,error=error) + r_last_update_pbc=r_last_update_pbc, eam_data=eam_data) nkinds = SIZE(potparm%pot, 1) ALLOCATE(eam_kinds_index(nkinds,nkinds),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) eam_kinds_index = -1 DO ikind = 1, nkinds DO jkind = ikind, nkinds DO i = 1, SIZE(potparm%pot(ikind,jkind)%pot%type) IF (potparm%pot(ikind,jkind)%pot%type(i)==ea_type) THEN ! At the moment we allow only 1 EAM per each kinds pair.. - CPPostcondition(eam_kinds_index(ikind,jkind)==-1,cp_failure_level,routineP,error,failure) - CPPostcondition(eam_kinds_index(jkind,ikind)==-1,cp_failure_level,routineP,error,failure) + CPPostcondition(eam_kinds_index(ikind,jkind)==-1,cp_failure_level,routineP,failure) + CPPostcondition(eam_kinds_index(jkind,ikind)==-1,cp_failure_level,routineP,failure) eam_kinds_index(ikind,jkind) = i eam_kinds_index(jkind,ikind) = i do_eam = .TRUE. @@ -106,8 +103,8 @@ SUBROUTINE density_nonbond (fist_nonbond_env, particle_set, cell, para_env, erro IF (do_eam) THEN IF (.NOT. ASSOCIATED(eam_data)) THEN ALLOCATE(eam_data(nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL fist_nonbond_env_set (fist_nonbond_env, eam_data=eam_data, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL fist_nonbond_env_set (fist_nonbond_env, eam_data=eam_data) ENDIF DO i=1,nparticle eam_data(i)%rho=0.0_dp @@ -121,7 +118,7 @@ SUBROUTINE density_nonbond (fist_nonbond_env, particle_set, cell, para_env, erro CALL cite_reference(Foiles1986) NULLIFY(eam_a, eam_b) ALLOCATE ( rho(nparticle), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rho = 0._dp ! Starting the force loop DO ilist=1,nonbonded%nlists @@ -163,10 +160,10 @@ SUBROUTINE density_nonbond (fist_nonbond_env, particle_set, cell, para_env, erro END DO DEALLOCATE (rho,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (eam_kinds_index, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE density_nonbond diff --git a/src/manybody_potential.F b/src/manybody_potential.F index 9852f4b1aa..b74e9fe992 100644 --- a/src/manybody_potential.F +++ b/src/manybody_potential.F @@ -69,14 +69,12 @@ MODULE manybody_potential !> \param pot_manybody ... !> \param para_env ... !> \param mm_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> tlaino [2007] - New algorithm for tersoff potential !> \author CJM, I-Feng W. Kuo, Teodoro Laino ! ***************************************************************************** SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles,& - particle_set, cell, pot_manybody, para_env, mm_section, error ) + particle_set, cell, pot_manybody, para_env, mm_section) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) @@ -87,7 +85,6 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env TYPE(section_vals_type), POINTER :: mm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'energy_manybody', & routineP = moduleN//':'//routineN @@ -123,7 +120,7 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, failure = .FALSE. CALL timeset ( routineN, handle ) CALL fist_nonbond_env_get ( fist_nonbond_env, r_last_update_pbc=r_last_update_pbc,& - potparm = potparm , eam_data=eam_data, error=error) + potparm = potparm , eam_data=eam_data) ! EAM requires a single loop DO ikind = 1, SIZE ( atomic_kind_set ) pot => potparm %pot ( ikind, ikind ) % pot @@ -132,9 +129,9 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, eam => pot%set(i)%eam nparticle = SIZE ( particle_set ) ALLOCATE(fembed(nparticle), stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fembed(:) = 0._dp - CPPostcondition(ASSOCIATED(eam_data),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(eam_data),cp_failure_level,routineP,failure) ! computation of embedding function and energy nparticle_local = local_particles%n_el(ikind) DO iparticle_local=1,nparticle_local @@ -157,7 +154,7 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, END DO DEALLOCATE ( fembed, stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO END DO ! Other manybody potential @@ -169,17 +166,17 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, any_siepmann = any_siepmann .OR. ANY(pot%type==siepmann_type) END DO END DO - CALL fist_nonbond_env_get(fist_nonbond_env,nonbonded=nonbonded,natom_types=nkinds,error=error) + CALL fist_nonbond_env_get(fist_nonbond_env,nonbonded=nonbonded,natom_types=nkinds) ! QUIP IF (any_quip) THEN CALL quip_energy_store_force_virial(particle_set, cell, atomic_kind_set, potparm, & - fist_nonbond_env, pot_quip, para_env, error=error) + fist_nonbond_env, pot_quip, para_env) pot_manybody = pot_manybody + pot_quip ENDIF ! TERSOFF IF (any_tersoff) THEN NULLIFY(glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell, error) + CALL setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell) DO ilist=1,nonbonded%nlists neighbor_kind_pair => nonbonded%neighbor_kind_pairs(ilist) npairs=neighbor_kind_pair%npairs @@ -201,7 +198,7 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, npairs = iend-istart+1 IF (npairs /=0) THEN ALLOCATE(sort_list(2,npairs),work_list (npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sort_list = list(:,istart:iend) ! Sort the list of neighbors, this increases the efficiency for single ! potential contributions @@ -249,18 +246,18 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, IF (ipair<=npairs) junique = sort_list(1,ipair) END DO DEALLOCATE(sort_list,work_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO END DO Kind_Group_Loop END DO - CALL destroy_tersoff_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, error) + CALL destroy_tersoff_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a) END IF !SIEPMANN POTENTIAL IF (any_siepmann) THEN NULLIFY(glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell, error) + CALL setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell) nr_oh = 0 DO ilist=1,nonbonded%nlists neighbor_kind_pair => nonbonded%neighbor_kind_pairs(ilist) @@ -283,7 +280,7 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, npairs = iend-istart+1 IF (npairs /=0) THEN ALLOCATE(sort_list(2,npairs),work_list (npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sort_list = list(:,istart:iend) ! Sort the list of neighbors, this increases the efficiency for single ! potential contributions @@ -332,14 +329,14 @@ SUBROUTINE energy_manybody ( fist_nonbond_env, atomic_kind_set, local_particles, IF (ipair<=npairs) junique = sort_list(1,ipair) END DO DEALLOCATE(sort_list,work_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO END DO Kind_Group_Loop_2 END DO - CALL destroy_siepmann_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, error) + CALL destroy_siepmann_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a) IF(siepmann%allow_oh_formation) THEN - CALL print_nr_oh_siepmann(nr_oh,mm_section,para_env,error) + CALL print_nr_oh_siepmann(nr_oh,mm_section,para_env) ENDIF END IF @@ -354,14 +351,12 @@ END SUBROUTINE energy_manybody !> \param f_nonbond ... !> \param pv_nonbond ... !> \param use_virial ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Fast implementation of the tersoff potential - [tlaino] 2007 !> \author I-Feng W. Kuo, Teodoro Laino ! ***************************************************************************** SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & - f_nonbond, pv_nonbond, use_virial, error ) + f_nonbond, pv_nonbond, use_virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(particle_type), DIMENSION(:), & @@ -370,7 +365,6 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: f_nonbond, pv_nonbond LOGICAL, INTENT(IN) :: use_virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'force_nonbond_manybody', & routineP = moduleN//':'//routineN @@ -407,7 +401,7 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & NULLIFY(eam_a, eam_b, tersoff, siepmann) CALL fist_nonbond_env_get(fist_nonbond_env,nonbonded=nonbonded,potparm=potparm,& - natom_types=nkinds, eam_data=eam_data, r_last_update_pbc=r_last_update_pbc,error=error) + natom_types=nkinds, eam_data=eam_data, r_last_update_pbc=r_last_update_pbc) ! Initializing the potential energy, pressure tensor and force IF (use_virial) THEN @@ -418,15 +412,15 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & nkinds = SIZE(potparm%pot,1) ALLOCATE(eam_kinds_index(nkinds,nkinds),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) eam_kinds_index = -1 DO ikind = 1, nkinds DO jkind = ikind, nkinds DO i = 1, SIZE(potparm%pot(ikind,jkind)%pot%type) IF (potparm%pot(ikind,jkind)%pot%type(i)==ea_type) THEN ! At the moment we allow only 1 EAM per each kinds pair.. - CPPostcondition(eam_kinds_index(ikind,jkind)==-1,cp_failure_level,routineP,error,failure) - CPPostcondition(eam_kinds_index(jkind,ikind)==-1,cp_failure_level,routineP,error,failure) + CPPostcondition(eam_kinds_index(ikind,jkind)==-1,cp_failure_level,routineP,failure) + CPPostcondition(eam_kinds_index(jkind,ikind)==-1,cp_failure_level,routineP,failure) eam_kinds_index(ikind,jkind) = i eam_kinds_index(jkind,ikind) = i END IF @@ -436,7 +430,7 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & ! QUIP IF (use_virial) & - CALL quip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond, error=error) + CALL quip_add_force_virial(fist_nonbond_env, f_nonbond, pv_nonbond) ! starting the force loop DO ilist=1,nonbonded%nlists @@ -459,7 +453,7 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & i = eam_kinds_index(ikind,jkind) IF (i==-1) CYCLE ! EAM - CPPostcondition(ASSOCIATED(eam_data),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(eam_data),cp_failure_level,routineP,failure) DO ipair = istart, iend atom_a = list(1,ipair) atom_b = list(2,ipair) @@ -507,12 +501,12 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & END DO Kind_Group_Loop1 END DO DEALLOCATE (eam_kinds_index, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Special way of handling the tersoff potential.. IF (any_tersoff) THEN NULLIFY(glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell, error) + CALL setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell) DO ilist=1,nonbonded%nlists neighbor_kind_pair => nonbonded%neighbor_kind_pairs(ilist) npairs=neighbor_kind_pair%npairs @@ -535,7 +529,7 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & npairs = iend-istart+1 tersoff => pot%set(i)%tersoff ALLOCATE(sort_list(2,npairs),work_list (npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sort_list = list(:,istart:iend) ! Sort the list of neighbors, this increases the efficiency for single ! potential contributions @@ -581,17 +575,17 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & IF (ipair<=npairs) junique = sort_list(1,ipair) END DO DEALLOCATE(sort_list,work_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO END DO Kind_Group_Loop2 END DO - CALL destroy_tersoff_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, error) + CALL destroy_tersoff_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a) END IF ! Special way of handling the siepmann potential.. IF (any_siepmann) THEN NULLIFY(glob_loc_list, glob_cell_v, glob_loc_list_a) - CALL setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell, error) + CALL setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell) DO ilist=1,nonbonded%nlists neighbor_kind_pair => nonbonded%neighbor_kind_pairs(ilist) npairs=neighbor_kind_pair%npairs @@ -614,7 +608,7 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & npairs = iend-istart+1 siepmann => pot%set(i)%siepmann ALLOCATE(sort_list(2,npairs),work_list (npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sort_list = list(:,istart:iend) ! Sort the list of neighbors, this increases the efficiency for single ! potential contributions @@ -654,23 +648,23 @@ SUBROUTINE force_nonbond_manybody ( fist_nonbond_env, particle_set, cell, & CALL siepmann_forces_v2 ( siepmann, r_last_update_pbc, cell_v, cell,& nloc_size, glob_loc_list(:,ifirst:ilast), glob_cell_v(:,ifirst:ilast),& atom_a, atom_b, f_nonbond, pv_nonbond, use_virial, siepmann%rcutsq,& - particle_set, error) + particle_set) CALL siepmann_forces_v3( siepmann, r_last_update_pbc, cell_v,& nloc_size, glob_loc_list(:,ifirst:ilast), glob_cell_v(:,ifirst:ilast),& atom_a, atom_b, f_nonbond, pv_nonbond, use_virial, siepmann%rcutsq, & - cell, particle_set, error) + cell, particle_set) END IF END DO ifirst = ilast + 1 IF (ipair<=npairs) junique = sort_list(1,ipair) END DO DEALLOCATE(sort_list,work_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO END DO Kind_Group_Loop3 END DO - CALL destroy_siepmann_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, error) + CALL destroy_siepmann_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a) END IF IF (use_virial) THEN pv_nonbond(1,1) = pv_nonbond(1,1) + ptens11 diff --git a/src/manybody_quip.F b/src/manybody_quip.F index f225ed1957..5f3ed8af37 100644 --- a/src/manybody_quip.F +++ b/src/manybody_quip.F @@ -48,10 +48,9 @@ MODULE manybody_quip !> \param fist_nonbond_env ... !> \param pot_quip ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE quip_energy_store_force_virial(particle_set, cell, atomic_kind_set, potparm, fist_nonbond_env, & - pot_quip, para_env, error) + pot_quip, para_env) TYPE(particle_type), POINTER :: particle_set( : ) TYPE(cell_type), POINTER :: cell TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) @@ -60,7 +59,6 @@ SUBROUTINE quip_energy_store_force_virial(particle_set, cell, atomic_kind_set, p REAL(kind=dp) :: pot_quip TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'quip_energy_store_force_virial', & @@ -155,11 +153,11 @@ SUBROUTINE quip_energy_store_force_virial(particle_set, cell, atomic_kind_set, p IF (PRESENT(para_env)) force = force / REAL(para_env%num_pe, dp) IF (PRESENT(para_env)) virial = virial / REAL(para_env%num_pe, dp) ! get quip_data to save force, virial info - CALL fist_nonbond_env_get ( fist_nonbond_env, quip_data=quip_data, error=error) + CALL fist_nonbond_env_get ( fist_nonbond_env, quip_data=quip_data) IF (.NOT. ASSOCIATED(quip_data)) THEN ALLOCATE(quip_data,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL fist_nonbond_env_set (fist_nonbond_env, quip_data=quip_data, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL fist_nonbond_env_set (fist_nonbond_env, quip_data=quip_data) NULLIFY(quip_data%use_indices, quip_data%force) ENDIF IF (ASSOCIATED(quip_data%force)) THEN @@ -192,12 +190,10 @@ END SUBROUTINE quip_energy_store_force_virial !> \param fist_nonbond_env ... !> \param force ... !> \param virial ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE quip_add_force_virial(fist_nonbond_env, force, virial, error) +SUBROUTINE quip_add_force_virial(fist_nonbond_env, force, virial) TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env REAL(KIND=dp) :: force(:,:), virial(3,3) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'quip_add_force_virial', & routineP = moduleN//':'//routineN @@ -212,12 +208,12 @@ SUBROUTINE quip_add_force_virial(fist_nonbond_env, force, virial, error) RETURN #else failure = .FALSE. - CALL fist_nonbond_env_get ( fist_nonbond_env, quip_data=quip_data, error=error) + CALL fist_nonbond_env_get ( fist_nonbond_env, quip_data=quip_data) IF (.NOT. ASSOCIATED(quip_data)) RETURN DO iat_use=1, SIZE(quip_data%use_indices) iat = quip_data%use_indices(iat_use) - CPPostcondition(iat >= 1 .AND. iat <= SIZE(force,2),cp_failure_level,routineP,error,failure) + CPPostcondition(iat >= 1 .AND. iat <= SIZE(force,2),cp_failure_level,routineP,failure) force(1:3,iat) = force(1:3,iat) + quip_data%force(1:3,iat_use) END DO virial = virial + quip_data%virial diff --git a/src/manybody_siepmann.F b/src/manybody_siepmann.F index 8f9618d464..2d404e6fe5 100644 --- a/src/manybody_siepmann.F +++ b/src/manybody_siepmann.F @@ -237,14 +237,12 @@ END FUNCTION siep_a_ij !> \param cell ... !> \param rcutsq ... !> \param use_virial ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Using a local list of neighbors ! ***************************************************************************** SUBROUTINE siep_a_ij_d(siepmann,r_last_update_pbc,iparticle,jparticle,f_nonbond,& pv_nonbond,prefactor,n_loc_size,full_loc_list,loc_cell_v,& - cell_v,cell,rcutsq,use_virial, error) + cell_v,cell,rcutsq,use_virial) TYPE(siepmann_pot_type), POINTER :: siepmann TYPE(pos_type), DIMENSION(:), POINTER :: r_last_update_pbc INTEGER, INTENT(IN) :: iparticle, jparticle @@ -259,7 +257,6 @@ SUBROUTINE siep_a_ij_d(siepmann,r_last_update_pbc,iparticle,jparticle,f_nonbond, TYPE(cell_type), POINTER :: cell REAL(KIND=dp), INTENT(IN) :: rcutsq LOGICAL, INTENT(IN) :: use_virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'siep_a_ij_d', & routineP = moduleN//':'//routineN @@ -324,7 +321,7 @@ SUBROUTINE siep_a_ij_d(siepmann,r_last_update_pbc,iparticle,jparticle,f_nonbond, CALL cp_unimplemented_error(fromWhere=routineP, & message="using virial with Siepmann-Sprik"//& " not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO END SUBROUTINE siep_a_ij_d @@ -447,14 +444,12 @@ END FUNCTION siep_Phi_ij !> \param rcutsq ... !> \param use_virial ... !> \param particle_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Using a local list of neighbors ! ***************************************************************************** SUBROUTINE siep_Phi_ij_d(siepmann,r_last_update_pbc,iparticle,jparticle,f_nonbond,& prefactor,n_loc_size,full_loc_list, loc_cell_v,& - cell_v, cell, rcutsq,use_virial, particle_set, error) + cell_v, cell, rcutsq,use_virial, particle_set) TYPE(siepmann_pot_type), POINTER :: siepmann TYPE(pos_type), DIMENSION(:), POINTER :: r_last_update_pbc INTEGER, INTENT(IN) :: iparticle, jparticle @@ -471,7 +466,6 @@ SUBROUTINE siep_Phi_ij_d(siepmann,r_last_update_pbc,iparticle,jparticle,f_nonbon LOGICAL, INTENT(IN) :: use_virial TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'siep_Phi_ij_d', & routineP = moduleN//':'//routineN @@ -568,7 +562,7 @@ SUBROUTINE siep_Phi_ij_d(siepmann,r_last_update_pbc,iparticle,jparticle,f_nonbon CALL cp_unimplemented_error(fromWhere=routineP, & message="using virial with Siepmann-Sprik"//& " not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF ENDIF @@ -590,14 +584,12 @@ END SUBROUTINE siep_Phi_ij_d !> \param rcutsq ... !> \param cell ... !> \param particle_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Using a local list of neighbors ! ***************************************************************************** SUBROUTINE siepmann_forces_v3(siepmann,r_last_update_pbc, cell_v, n_loc_size,& full_loc_list, loc_cell_v, iparticle,jparticle,f_nonbond,pv_nonbond,& - use_virial, rcutsq, cell, particle_set, error) + use_virial, rcutsq, cell, particle_set) TYPE(siepmann_pot_type), POINTER :: siepmann TYPE(pos_type), DIMENSION(:), POINTER :: r_last_update_pbc REAL(KIND=dp), DIMENSION(3) :: cell_v @@ -613,7 +605,6 @@ SUBROUTINE siepmann_forces_v3(siepmann,r_last_update_pbc, cell_v, n_loc_size,& TYPE(cell_type), POINTER :: cell TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'siepmann_forces_v3', & routineP = moduleN//':'//routineN @@ -652,7 +643,7 @@ SUBROUTINE siepmann_forces_v3(siepmann,r_last_update_pbc, cell_v, n_loc_size,& IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="using virial with Siepmann-Sprik"//& - " not implemented", error=error, error_level=cp_failure_level) + " not implemented",error_level=cp_failure_level) END IF ! Lets do the f_A2 piece derivative of rji**(-beta) @@ -667,14 +658,14 @@ SUBROUTINE siepmann_forces_v3(siepmann,r_last_update_pbc, cell_v, n_loc_size,& IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="using virial with Siepmann-Sprik"//& - " not implemented", error=error, error_level=cp_failure_level) + " not implemented",error_level=cp_failure_level) END IF ! Lets do the f_A3 piece derivative: of a_ij prefactor = E * f2 * drji**(-beta) * fac CALL siep_a_ij_d(siepmann, r_last_update_pbc, iparticle, jparticle, f_nonbond,& pv_nonbond, prefactor, n_loc_size, full_loc_list,loc_cell_v, cell_v,& - cell, rcutsq, use_virial, error) + cell, rcutsq, use_virial) END SUBROUTINE siepmann_forces_v3 @@ -694,14 +685,12 @@ END SUBROUTINE siepmann_forces_v3 !> \param use_virial ... !> \param rcutsq ... !> \param particle_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Using a local list of neighbors ! ***************************************************************************** SUBROUTINE siepmann_forces_v2(siepmann,r_last_update_pbc, cell_v, cell, n_loc_size,& full_loc_list, loc_cell_v, iparticle,jparticle,f_nonbond,pv_nonbond,& - use_virial, rcutsq, particle_set, error) + use_virial, rcutsq, particle_set) TYPE(siepmann_pot_type), POINTER :: siepmann TYPE(pos_type), DIMENSION(:), POINTER :: r_last_update_pbc REAL(KIND=dp), DIMENSION(3) :: cell_v @@ -717,7 +706,6 @@ SUBROUTINE siepmann_forces_v2(siepmann,r_last_update_pbc, cell_v, cell, n_loc_si REAL(KIND=dp), INTENT(IN) :: rcutsq TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'siepmann_forces_v2', & routineP = moduleN//':'//routineN @@ -754,7 +742,7 @@ SUBROUTINE siepmann_forces_v2(siepmann,r_last_update_pbc, cell_v, cell, n_loc_si IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="using virial with Siepmann-Sprik"//& - " not implemented", error=error, error_level=cp_failure_level) + " not implemented",error_level=cp_failure_level) END IF ! ! Lets do the f_A2 piece derivative of rji**(-3) @@ -769,14 +757,14 @@ SUBROUTINE siepmann_forces_v2(siepmann,r_last_update_pbc, cell_v, cell, n_loc_si IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="using virial with Siepmann-Sprik"//& - " not implemented", error=error, error_level=cp_failure_level) + " not implemented",error_level=cp_failure_level) END IF ! Lets do the f_A3 piece derivative: of Phi_ij prefactor = -D * f2 * drji**(-3) * fac CALL siep_Phi_ij_d(siepmann, r_last_update_pbc, iparticle, jparticle, f_nonbond,& prefactor, n_loc_size, full_loc_list, loc_cell_v,cell_v, cell,& - rcutsq, use_virial, particle_set, error) + rcutsq, use_virial, particle_set) END SUBROUTINE siepmann_forces_v2 @@ -788,19 +776,16 @@ END SUBROUTINE siepmann_forces_v2 !> \param glob_cell_v ... !> \param glob_loc_list_a ... !> \param cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History ! ***************************************************************************** SUBROUTINE setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v,& - glob_loc_list_a, cell, error) + glob_loc_list_a, cell) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(pair_potential_pp_type), POINTER :: potparm INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_siepmann_arrays', & routineP = moduleN//':'//routineN @@ -818,9 +803,9 @@ SUBROUTINE setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, TYPE(pair_potential_single_type), & POINTER :: pot - CPPostcondition(.NOT.ASSOCIATED(glob_loc_list),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(glob_loc_list_a),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(glob_cell_v),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(glob_loc_list),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(glob_loc_list_a),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(glob_cell_v),cp_failure_level,routineP,failure) failure = .FALSE. CALL timeset ( routineN, handle ) npairs_tot = 0 @@ -843,13 +828,13 @@ SUBROUTINE setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, END DO Kind_Group_Loop1 END DO ALLOCATE(work_list(npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work_list2(npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(glob_loc_list(2,npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(glob_cell_v(3,npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Fill arrays with data npairs_tot = 0 DO ilist=1,nonbonded%nlists @@ -886,19 +871,19 @@ SUBROUTINE setup_siepmann_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, END DO glob_loc_list(2,:) = work_list2 DEALLOCATE(work_list2, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rwork_list(3,npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ipair = 1, npairs_tot rwork_list(:,ipair)=glob_cell_v(:,work_list(ipair)) END DO glob_cell_v = rwork_list DEALLOCATE(rwork_list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work_list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(glob_loc_list_a(npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) glob_loc_list_a = glob_loc_list(1,:) CALL timestop ( handle ) END SUBROUTINE setup_siepmann_arrays @@ -908,14 +893,11 @@ END SUBROUTINE setup_siepmann_arrays !> \param glob_loc_list ... !> \param glob_cell_v ... !> \param glob_loc_list_a ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE destroy_siepmann_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, error) + SUBROUTINE destroy_siepmann_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a) INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'destroy_siepmann_arrays', & routineP = moduleN//':'//routineN @@ -926,15 +908,15 @@ SUBROUTINE destroy_siepmann_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, failure = .FALSE. IF (ASSOCIATED(glob_loc_list)) THEN DEALLOCATE(glob_loc_list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(glob_loc_list_a)) THEN DEALLOCATE(glob_loc_list_a, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(glob_cell_v)) THEN DEALLOCATE(glob_cell_v, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE destroy_siepmann_arrays @@ -944,15 +926,12 @@ END SUBROUTINE destroy_siepmann_arrays !> \param nr_oh ... !> \param mm_section ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_nr_oh_siepmann(nr_oh,mm_section,para_env,error) + SUBROUTINE print_nr_oh_siepmann(nr_oh,mm_section,para_env) INTEGER, INTENT(INOUT) :: nr_oh TYPE(section_vals_type), POINTER :: mm_section TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_nr_oh_siepmann', & routineP = moduleN//':'//routineN @@ -965,17 +944,16 @@ SUBROUTINE print_nr_oh_siepmann(nr_oh,mm_section,para_env,error) NULLIFY(logger) CALL mp_sum(nr_oh,para_env%group) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw= cp_print_key_unit_nr(logger,mm_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") IF(iw > 0 .AND. nr_oh > 0) THEN WRITE(iw,'(/,A,T71,I10,/)') " SIEPMANN: number of OH ions at surface", nr_oh ENDIF - CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%PROGRAM_RUN_INFO",& - error=error) + CALL cp_print_key_finished_output(iw,logger,mm_section,"PRINT%PROGRAM_RUN_INFO") END SUBROUTINE print_nr_oh_siepmann diff --git a/src/manybody_tersoff.F b/src/manybody_tersoff.F index 1df0a49ea4..8689a0996c 100644 --- a/src/manybody_tersoff.F +++ b/src/manybody_tersoff.F @@ -742,20 +742,17 @@ END SUBROUTINE tersoff_forces !> \param glob_cell_v ... !> \param glob_loc_list_a ... !> \param cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Fast implementation of the tersoff potential - [tlaino] 2007 !> \author Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell, error) + SUBROUTINE setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, glob_loc_list_a, cell) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(pair_potential_pp_type), POINTER :: potparm INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_tersoff_arrays', & routineP = moduleN//':'//routineN @@ -773,9 +770,9 @@ SUBROUTINE setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, TYPE(pair_potential_single_type), & POINTER :: pot - CPPostcondition(.NOT.ASSOCIATED(glob_loc_list),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(glob_loc_list_a),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(glob_cell_v),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(glob_loc_list),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(glob_loc_list_a),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(glob_cell_v),cp_failure_level,routineP,failure) failure = .FALSE. CALL timeset ( routineN, handle ) npairs_tot = 0 @@ -798,13 +795,13 @@ SUBROUTINE setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, END DO Kind_Group_Loop1 END DO ALLOCATE(work_list(npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work_list2(npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(glob_loc_list(2,npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(glob_cell_v(3,npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Fill arrays with data npairs_tot = 0 DO ilist=1,nonbonded%nlists @@ -841,19 +838,19 @@ SUBROUTINE setup_tersoff_arrays(nonbonded, potparm, glob_loc_list, glob_cell_v, END DO glob_loc_list(2,:) = work_list2 DEALLOCATE(work_list2, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rwork_list(3,npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ipair = 1, npairs_tot rwork_list(:,ipair)=glob_cell_v(:,work_list(ipair)) END DO glob_cell_v = rwork_list DEALLOCATE(rwork_list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work_list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(glob_loc_list_a(npairs_tot), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) glob_loc_list_a = glob_loc_list(1,:) CALL timestop ( handle ) END SUBROUTINE setup_tersoff_arrays @@ -863,17 +860,14 @@ END SUBROUTINE setup_tersoff_arrays !> \param glob_loc_list ... !> \param glob_cell_v ... !> \param glob_loc_list_a ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Fast implementation of the tersoff potential - [tlaino] 2007 !> \author Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE destroy_tersoff_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, error) + SUBROUTINE destroy_tersoff_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a) INTEGER, DIMENSION(:, :), POINTER :: glob_loc_list REAL(KIND=dp), DIMENSION(:, :), POINTER :: glob_cell_v INTEGER, DIMENSION(:), POINTER :: glob_loc_list_a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'destroy_tersoff_arrays', & routineP = moduleN//':'//routineN @@ -884,15 +878,15 @@ SUBROUTINE destroy_tersoff_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, e failure = .FALSE. IF (ASSOCIATED(glob_loc_list)) THEN DEALLOCATE(glob_loc_list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(glob_loc_list_a)) THEN DEALLOCATE(glob_loc_list_a, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(glob_cell_v)) THEN DEALLOCATE(glob_cell_v, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE destroy_tersoff_arrays diff --git a/src/matrix_exp.F b/src/matrix_exp.F index fcb889cbd1..52ee814241 100644 --- a/src/matrix_exp.F +++ b/src/matrix_exp.F @@ -67,15 +67,13 @@ MODULE matrix_exp !> \param im_matrix ... !> \param nsquare ... !> \param ntaylor ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE taylor_only_imaginary(exp_H,im_matrix,nsquare,ntaylor,error) + SUBROUTINE taylor_only_imaginary(exp_H,im_matrix,nsquare,ntaylor) TYPE(cp_fm_p_type), DIMENSION(2) :: exp_H TYPE(cp_fm_type), POINTER :: im_matrix INTEGER, INTENT(in) :: nsquare, ntaylor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'taylor_only_imaginary', & routineP = moduleN//':'//routineN @@ -88,33 +86,29 @@ SUBROUTINE taylor_only_imaginary(exp_H,im_matrix,nsquare,ntaylor,error) CALL timeset(routineN,handle) - CALL cp_fm_get_info(im_matrix,local_data=local_data_im,error=error) + CALL cp_fm_get_info(im_matrix,local_data=local_data_im) ndim=im_matrix%matrix_struct%nrow_global square_fac=1.0_dp/(2.0_dp**REAL(nsquare,dp)) -! CALL cp_fm_scale(square_fac,im_matrix,error) +! CALL cp_fm_scale(square_fac,im_matrix) CALL cp_fm_create(T1,& matrix_struct=im_matrix%matrix_struct,& - name="T1",& - error=error) + name="T1") CALL cp_fm_create(T2,& matrix_struct=T1%matrix_struct,& - name="T2",& - error=error) + name="T2") CALL cp_fm_create(Tres_im,& matrix_struct=T1%matrix_struct,& - name="T3",& - error=error) + name="T3") CALL cp_fm_create(Tres_re,& matrix_struct=T1%matrix_struct,& - name="Tres",& - error=error) + name="Tres") tmp=1.0_dp - CALL cp_fm_set_all(Tres_re,zero,one,error) - CALL cp_fm_set_all(Tres_im,zero,zero,error) - CALL cp_fm_set_all(T1,zero,one,error) + CALL cp_fm_set_all(Tres_re,zero,one) + CALL cp_fm_set_all(Tres_im,zero,zero) + CALL cp_fm_set_all(T1,zero,one) Tfac=one nloop=CEILING(REAL(ntaylor,dp)/2.0_dp) @@ -123,37 +117,37 @@ SUBROUTINE taylor_only_imaginary(exp_H,im_matrix,nsquare,ntaylor,error) tmp=tmp*(REAL(i,dp)*2.0_dp-1.0_dp) CALL cp_gemm("N","N",ndim,ndim,ndim,square_fac,im_matrix,T1,zero,& ! CALL cp_gemm("N","N",ndim,ndim,ndim,one,im_matrix,T1,zero,& - T2,error) + T2) Tfac=1._dp/tmp IF(MOD(i,2)==0) Tfac=-Tfac - CALL cp_fm_scale_and_add(one,Tres_im,Tfac,T2,error) + CALL cp_fm_scale_and_add(one,Tres_im,Tfac,T2) tmp=tmp*REAL(i,dp)*2.0_dp CALL cp_gemm("N","N",ndim,ndim,ndim,square_fac,im_matrix,T2,zero,& ! CALL cp_gemm("N","N",ndim,ndim,ndim,one,im_matrix,T2,zero,& - T1,error) + T1) Tfac=1._dp/tmp IF(MOD(i,2)==1) Tfac=-Tfac - CALL cp_fm_scale_and_add(one,Tres_re,Tfac,T1,error) + CALL cp_fm_scale_and_add(one,Tres_re,Tfac,T1) END DO IF(nsquare.GT.0)THEN DO i=1,nsquare CALL cp_complex_fm_gemm("N","N",ndim,ndim,ndim,one,Tres_re,Tres_im,& - Tres_re,Tres_im,zero,exp_H(1)%matrix,exp_H(2)%matrix,error) + Tres_re,Tres_im,zero,exp_H(1)%matrix,exp_H(2)%matrix) - CALL cp_fm_to_fm(exp_H(1)%matrix,Tres_re,error) - CALL cp_fm_to_fm(exp_H(2)%matrix,Tres_im,error) + CALL cp_fm_to_fm(exp_H(1)%matrix,Tres_re) + CALL cp_fm_to_fm(exp_H(2)%matrix,Tres_im) END DO ELSE - CALL cp_fm_to_fm(Tres_re,exp_H(1)%matrix,error) - CALL cp_fm_to_fm(Tres_im,exp_H(2)%matrix,error) + CALL cp_fm_to_fm(Tres_re,exp_H(1)%matrix) + CALL cp_fm_to_fm(Tres_im,exp_H(2)%matrix) END IF - CALL cp_fm_release(T1,error) - CALL cp_fm_release(T2,error) - CALL cp_fm_release(Tres_re,error) - CALL cp_fm_release(Tres_im,error) + CALL cp_fm_release(T1) + CALL cp_fm_release(T2) + CALL cp_fm_release(Tres_re) + CALL cp_fm_release(Tres_im) CALL timestop(handle) @@ -171,15 +165,13 @@ END SUBROUTINE taylor_only_imaginary !> \param im_part ... !> \param nsquare ... !> \param ntaylor ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE taylor_full_complex(exp_H,re_part,im_part,nsquare,ntaylor,error) + SUBROUTINE taylor_full_complex(exp_H,re_part,im_part,nsquare,ntaylor) TYPE(cp_fm_p_type), DIMENSION(2) :: exp_H TYPE(cp_fm_type), POINTER :: re_part, im_part INTEGER, INTENT(in) :: nsquare, ntaylor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'taylor_full_complex', & routineP = moduleN//':'//routineN @@ -193,14 +185,13 @@ SUBROUTINE taylor_full_complex(exp_H,re_part,im_part,nsquare,ntaylor,error) TYPE(cp_cfm_type), POINTER :: T1, T2, T3, Tres CALL timeset(routineN,handle) - CALL cp_fm_get_info(re_part,local_data=local_data_re,error=error) - CALL cp_fm_get_info(im_part,local_data=local_data_im,error=error) + CALL cp_fm_get_info(re_part,local_data=local_data_re) + CALL cp_fm_get_info(im_part,local_data=local_data_im) ndim=re_part%matrix_struct%nrow_global CALL cp_cfm_create(T1,& matrix_struct=re_part%matrix_struct,& - name="T1",& - error=error) + name="T1") square_fac=2.0_dp**REAL(nsquare,dp) @@ -208,35 +199,32 @@ SUBROUTINE taylor_full_complex(exp_H,re_part,im_part,nsquare,ntaylor,error) CALL cp_cfm_create(T2,& matrix_struct=T1%matrix_struct,& - name="T2",& - error=error) + name="T2") CALL cp_cfm_create(T3,& matrix_struct=T1%matrix_struct,& - name="T3",& - error=error) + name="T3") CALL cp_cfm_create(Tres,& matrix_struct=T1%matrix_struct,& - name="Tres",& - error=error) + name="Tres") tmp=1.0_dp - CALL cp_cfm_set_all(Tres,zero,one,error) - CALL cp_cfm_set_all(T2,zero,one,error) + CALL cp_cfm_set_all(Tres,zero,one) + CALL cp_cfm_set_all(T2,zero,one) Tfac=one DO i=1,ntaylor tmp=tmp*REAL(i,dp) CALL cp_cfm_gemm("N","N",ndim,ndim,ndim,one,T1,T2,zero,& - T3,error) + T3) Tfac=CMPLX(1._dp/tmp,0.0_dp,kind=dp) - CALL cp_cfm_add(one,Tres,Tfac,T3,error) - CALL cp_cfm_to_cfm(T3,T2,error) + CALL cp_cfm_add(one,Tres,Tfac,T3) + CALL cp_cfm_to_cfm(T3,T2) END DO IF(nsquare.GT.0)THEN DO i=1,nsquare CALL cp_cfm_gemm("N","N",ndim,ndim,ndim,one,Tres,Tres,zero,& - T2,error) - CALL cp_cfm_to_cfm(T2,Tres,error) + T2) + CALL cp_cfm_to_cfm(T2,Tres) END DO END IF @@ -244,10 +232,10 @@ SUBROUTINE taylor_full_complex(exp_H,re_part,im_part,nsquare,ntaylor,error) exp_H(1)%matrix%local_data=REAL(Tres%local_data,KIND=dp) exp_H(2)%matrix%local_data=AIMAG(Tres%local_data) - CALL cp_cfm_release(T1,error) - CALL cp_cfm_release(T2,error) - CALL cp_cfm_release(T3,error) - CALL cp_cfm_release(Tres,error) + CALL cp_cfm_release(T1) + CALL cp_cfm_release(T2) + CALL cp_cfm_release(T3) + CALL cp_cfm_release(Tres) CALL timestop(handle) END SUBROUTINE taylor_full_complex @@ -261,17 +249,15 @@ END SUBROUTINE taylor_full_complex !> \param eps_exp ... !> \param method ... !> \param do_emd ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE get_nsquare_norder(norm,nsquare,norder,eps_exp,method,do_emd,error) + SUBROUTINE get_nsquare_norder(norm,nsquare,norder,eps_exp,method,do_emd) REAL(dp), INTENT(in) :: norm INTEGER, INTENT(out) :: nsquare, norder REAL(dp), INTENT(in) :: eps_exp INTEGER, INTENT(in) :: method LOGICAL, INTENT(in) :: do_emd - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_nsquare_norder', & routineP = moduleN//':'//routineN @@ -364,15 +350,13 @@ END SUBROUTINE get_nsquare_norder !> \param im_part ... !> \param nsquare ... !> \param npade ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE exp_pade_full_complex(exp_H,re_part,im_part,nsquare,npade,error) + SUBROUTINE exp_pade_full_complex(exp_H,re_part,im_part,nsquare,npade) TYPE(cp_fm_p_type), DIMENSION(2) :: exp_H TYPE(cp_fm_type), POINTER :: re_part, im_part INTEGER, INTENT(in) :: nsquare, npade - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'exp_pade_full_complex', & routineP = moduleN//':'//routineN @@ -392,68 +376,63 @@ SUBROUTINE exp_pade_full_complex(exp_H,re_part,im_part,nsquare,npade,error) CALL timeset(routineN,handle) CALL cp_fm_get_info(re_part,local_data=local_data_re,ncol_local=ldim,& - nrow_global=ndim,error=error) - CALL cp_fm_get_info(im_part,local_data=local_data_im,error=error) + nrow_global=ndim) + CALL cp_fm_get_info(im_part,local_data=local_data_im) ALLOCATE(mult_p(2)) CALL cp_cfm_create(Dpq,& matrix_struct=re_part%matrix_struct,& - name="Dpq",& - error=error) + name="Dpq") square_fac=2.0_dp**REAL(nsquare,dp) CALL cp_cfm_create(T1,& matrix_struct=Dpq%matrix_struct,& - name="T1",& - error=error) + name="T1") CALL cp_cfm_create(T2,& matrix_struct=T1%matrix_struct,& - name="T2",& - error=error) + name="T2") CALL cp_cfm_create(Npq,& matrix_struct=T1%matrix_struct,& - name="Npq",& - error=error) + name="Npq") CALL cp_cfm_create(Tres,& matrix_struct=T1%matrix_struct,& - name="Tres",& - error=error) + name="Tres") DO i=1,ldim T2%local_data(:,i)=CMPLX(local_data_re(:,i)/square_fac,local_data_im(:,i)/square_fac,KIND=dp) END DO - CALL cp_cfm_to_cfm(T2,T1,error) + CALL cp_cfm_to_cfm(T2,T1) mult_p(1)%matrix=>T2 mult_p(2)%matrix=>Tres tmp=1.0_dp - CALL cp_cfm_set_all(Npq,zero,one,error) - CALL cp_cfm_set_all(Dpq,zero,one,error) + CALL cp_cfm_set_all(Npq,zero,one) + CALL cp_cfm_set_all(Dpq,zero,one) - CALL cp_cfm_add(one,Npq,one*0.5_dp,T2,error) - CALL cp_cfm_add(one,Dpq,-one*0.5_dp,T2,error) + CALL cp_cfm_add(one,Npq,one*0.5_dp,T2) + CALL cp_cfm_add(one,Dpq,-one*0.5_dp,T2) IF(npade.GT.2)THEN DO i=2,npade IF(i.LE.p)scaleN=CMPLX(fac(p +q -i )*fac(p )/(fac(p +q )*fac(i )*fac(p -i )),0.0_dp,kind=dp) scaleD=CMPLX((-1.0_dp)**i * fac(p +q -i )*fac(q)/(fac(p +q )*fac(i )*fac(q -i)),0.0_dp,kind=dp) CALL cp_cfm_gemm("N","N",ndim,ndim,ndim,one,T1,mult_p(MOD(i,2)+1)%matrix,zero,& - mult_p(MOD(i+1,2)+1)%matrix,error) - IF(i.LE.p)CALL cp_cfm_add(one,Npq,scaleN, mult_p(MOD(i+1,2)+1)%matrix,error) - IF(i.LE.q)CALL cp_cfm_add(one,Dpq,scaleD, mult_p(MOD(i+1,2)+1)%matrix,error) + mult_p(MOD(i+1,2)+1)%matrix) + IF(i.LE.p)CALL cp_cfm_add(one,Npq,scaleN, mult_p(MOD(i+1,2)+1)%matrix) + IF(i.LE.q)CALL cp_cfm_add(one,Dpq,scaleD, mult_p(MOD(i+1,2)+1)%matrix) END DO END IF - CALL cp_cfm_solve(Dpq,Npq,error=error) + CALL cp_cfm_solve(Dpq,Npq) mult_p(2)%matrix=>Npq mult_p(1)%matrix=>Tres IF(nsquare.GT.0)THEN DO i=1,nsquare CALL cp_cfm_gemm("N","N",ndim,ndim,ndim,one,mult_p(MOD(i,2)+1)%matrix,mult_p(MOD(i,2)+1)%matrix,zero,& - mult_p(MOD(i+1,2)+1)%matrix,error) + mult_p(MOD(i+1,2)+1)%matrix) fin_p=> mult_p(MOD(i+1,2)+1)%matrix END DO ELSE @@ -464,11 +443,11 @@ SUBROUTINE exp_pade_full_complex(exp_H,re_part,im_part,nsquare,npade,error) exp_H(2)%matrix%local_data(:,i)=AIMAG(fin_p%local_data(:,i)) END DO - CALL cp_cfm_release(Npq,error) - CALL cp_cfm_release(Dpq,error) - CALL cp_cfm_release(T1,error) - CALL cp_cfm_release(T2,error) - CALL cp_cfm_release(Tres,error) + CALL cp_cfm_release(Npq) + CALL cp_cfm_release(Dpq) + CALL cp_cfm_release(T1) + CALL cp_cfm_release(T2) + CALL cp_cfm_release(Tres) DEALLOCATE(mult_p) CALL timestop(handle) @@ -481,15 +460,13 @@ END SUBROUTINE exp_pade_full_complex !> \param im_part ... !> \param nsquare ... !> \param npade ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE exp_pade_only_imaginary(exp_H,im_part,nsquare,npade,error) + SUBROUTINE exp_pade_only_imaginary(exp_H,im_part,nsquare,npade) TYPE(cp_fm_p_type), DIMENSION(2) :: exp_H TYPE(cp_fm_type), POINTER :: im_part INTEGER, INTENT(in) :: nsquare, npade - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'exp_pade_only_imaginary', & routineP = moduleN//':'//routineN @@ -511,43 +488,38 @@ SUBROUTINE exp_pade_only_imaginary(exp_H,im_part,nsquare,npade,error) p=npade q=npade !p==q seems to be neccesary for the rest of the code - CALL cp_fm_get_info(im_part,local_data=local_data_im,ncol_local=ldim,nrow_global=ndim,error=error) + CALL cp_fm_get_info(im_part,local_data=local_data_im,ncol_local=ldim,nrow_global=ndim) square_fac=1.0_dp/(2.0_dp**REAL(nsquare,dp)) ALLOCATE(cmult_p(2)) CALL cp_cfm_create(Dpq,& matrix_struct=im_part%matrix_struct,& - name="Dpq",& - error=error) + name="Dpq") CALL cp_cfm_create(Npq,& matrix_struct=Dpq%matrix_struct,& - name="Npq",& - error=error) + name="Npq") CALL cp_cfm_create(T1,& matrix_struct=Dpq%matrix_struct,& - name="T1",& - error=error) + name="T1") CALL cp_fm_create(T2,& matrix_struct=T1%matrix_struct,& - name="T2",& - error=error) + name="T2") CALL cp_fm_create(Tres,& matrix_struct=T1%matrix_struct,& - name="Tres",& - error=error) + name="Tres") ! DO i=1,ldim ! local_data_im(:,i)=local_data_im(:,i)/square_fac ! END DO - CALL cp_fm_to_fm(im_part,T2,error) + CALL cp_fm_to_fm(im_part,T2) - CALL cp_cfm_set_all(Npq,zero,one,error) - CALL cp_cfm_set_all(Dpq,zero,one,error) + CALL cp_cfm_set_all(Npq,zero,one) + CALL cp_cfm_set_all(Dpq,zero,one) DO i=1,ldim Npq%local_data(:,i)= Npq%local_data(:,i)+CMPLX(rzero,0.5_dp*square_fac*local_data_im(:,i),dp) @@ -563,7 +535,7 @@ SUBROUTINE exp_pade_only_imaginary(exp_H,im_part,nsquare,npade,error) my_fac=(-rone)**j IF(i.LE.p)scaleN=CMPLX(my_fac*fac(p +q -i )*fac(p )/(fac(p +q )*fac(i )*fac(p -i )),0.0_dp,dp) scaleD=CMPLX(my_fac* fac(p +q -i )*fac(q)/(fac(p +q )*fac(i )*fac(q -i)),0.0_dp,dp) - CALL cp_gemm("N","N",ndim,ndim,ndim,square_fac,im_part,T2,rzero,Tres,error) + CALL cp_gemm("N","N",ndim,ndim,ndim,square_fac,im_part,T2,rzero,Tres) DO k=1,ldim Npq%local_data(:,k)= Npq%local_data(:,k)+scaleN * Tres%local_data(:,k) @@ -574,7 +546,7 @@ SUBROUTINE exp_pade_only_imaginary(exp_H,im_part,nsquare,npade,error) i=2*j+1 IF(i.LE.p)scaleN=CMPLX(my_fac*fac(p +q -i )*fac(p )/(fac(p +q )*fac(i )*fac(p -i )),rzero,dp) scaleD=CMPLX(-my_fac*fac(p +q -i )*fac(q)/(fac(p +q )*fac(i )*fac(q -i)),rzero,dp) - CALL cp_gemm("N","N",ndim,ndim,ndim,square_fac,im_part,Tres,rzero,T2,error) + CALL cp_gemm("N","N",ndim,ndim,ndim,square_fac,im_part,Tres,rzero,T2) DO k=1,ldim Npq%local_data(:,k)= Npq%local_data(:,k)+scaleN*CMPLX(rzero, T2%local_data(:,k),dp) @@ -584,14 +556,14 @@ SUBROUTINE exp_pade_only_imaginary(exp_H,im_part,nsquare,npade,error) END DO END IF - CALL cp_cfm_solve(Dpq,Npq,error=error) + CALL cp_cfm_solve(Dpq,Npq) cmult_p(2)%matrix=>Npq cmult_p(1)%matrix=>T1 IF(nsquare.GT.0)THEN DO i=1,nsquare CALL cp_cfm_gemm("N","N",ndim,ndim,ndim,one,cmult_p(MOD(i,2)+1)%matrix,cmult_p(MOD(i,2)+1)%matrix,zero,& - cmult_p(MOD(i+1,2)+1)%matrix,error) + cmult_p(MOD(i+1,2)+1)%matrix) fin_p=> cmult_p(MOD(i+1,2)+1)%matrix END DO ELSE @@ -603,11 +575,11 @@ SUBROUTINE exp_pade_only_imaginary(exp_H,im_part,nsquare,npade,error) exp_H(2)%matrix%local_data(:,k)=AIMAG(fin_p%local_data(:,k)) END DO - CALL cp_cfm_release(Npq,error) - CALL cp_cfm_release(Dpq,error) - CALL cp_cfm_release(T1,error) - CALL cp_fm_release(T2,error) - CALL cp_fm_release(Tres,error) + CALL cp_cfm_release(Npq) + CALL cp_cfm_release(Dpq) + CALL cp_cfm_release(T1) + CALL cp_fm_release(T2) + CALL cp_fm_release(Tres) DEALLOCATE(cmult_p) CALL timestop(handle) END SUBROUTINE exp_pade_only_imaginary @@ -619,15 +591,13 @@ END SUBROUTINE exp_pade_only_imaginary !> \param matrix ... !> \param nsquare ... !> \param npade ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE exp_pade_real(exp_H,matrix,nsquare,npade,error) + SUBROUTINE exp_pade_real(exp_H,matrix,nsquare,npade) TYPE(cp_fm_type) :: exp_H TYPE(cp_fm_type), POINTER :: matrix INTEGER, INTENT(in) :: nsquare, npade - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'exp_pade_real', & routineP = moduleN//':'//routineN @@ -646,42 +616,37 @@ SUBROUTINE exp_pade_real(exp_H,matrix,nsquare,npade,error) p=npade q=npade !p==q seems to be neccesary for the rest of the code - CALL cp_fm_get_info(matrix,local_data=local_data,ncol_local=ldim,nrow_global=ndim,error=error) + CALL cp_fm_get_info(matrix,local_data=local_data,ncol_local=ldim,nrow_global=ndim) square_fac=2.0_dp**REAL(nsquare,dp) ALLOCATE(mult_p(2)) CALL cp_fm_create(Dpq,& matrix_struct=matrix%matrix_struct,& - name="Dpq",& - error=error) + name="Dpq") CALL cp_fm_create(Npq,& matrix_struct=Dpq%matrix_struct,& - name="Npq",& - error=error) + name="Npq") CALL cp_fm_create(T1,& matrix_struct=Dpq%matrix_struct,& - name="T1",& - error=error) + name="T1") CALL cp_fm_create(T2,& matrix_struct=T1%matrix_struct,& - name="T2",& - error=error) + name="T2") CALL cp_fm_create(Tres,& matrix_struct=T1%matrix_struct,& - name="Tres",& - error=error) + name="Tres") DO i=1,ldim T2%local_data(:,i)=local_data(:,i)/square_fac END DO - CALL cp_fm_to_fm(T2,T1,error) - CALL cp_fm_set_all(Npq,zero,one,error) - CALL cp_fm_set_all(Dpq,zero,one,error) + CALL cp_fm_to_fm(T2,T1) + CALL cp_fm_set_all(Npq,zero,one) + CALL cp_fm_set_all(Dpq,zero,one) DO i=1,ldim Npq%local_data(:,i)= Npq%local_data(:,i)+0.5_dp*local_data(:,i) @@ -697,7 +662,7 @@ SUBROUTINE exp_pade_real(exp_H,matrix,nsquare,npade,error) scaleN=fac(p +q -j )*fac(p )/(fac(p +q )*fac(j )*fac(p -j )) scaleD=my_fac* fac(p +q -j )*fac(q)/(fac(p +q )*fac(j )*fac(q -j)) CALL cp_gemm("N","N",ndim,ndim,ndim,one,mult_p(MOD(j,2)+1)%matrix,T1,& - zero,mult_p(MOD(j+1,2)+1)%matrix,error) + zero,mult_p(MOD(j+1,2)+1)%matrix) DO k=1,ldim Npq%local_data(:,k)= Npq%local_data(:,k)+scaleN* mult_p(MOD(j+1,2)+1)%matrix%local_data(:,k) @@ -706,14 +671,14 @@ SUBROUTINE exp_pade_real(exp_H,matrix,nsquare,npade,error) END DO END IF - CALL cp_fm_solve(Dpq,Npq,error) + CALL cp_fm_solve(Dpq,Npq) mult_p(2)%matrix=>Npq mult_p(1)%matrix=>T1 IF(nsquare.GT.0)THEN DO i=1,nsquare CALL cp_gemm("N","N",ndim,ndim,ndim,one,mult_p(MOD(i,2)+1)%matrix,mult_p(MOD(i,2)+1)%matrix,zero,& - mult_p(MOD(i+1,2)+1)%matrix,error) + mult_p(MOD(i+1,2)+1)%matrix) fin_p=> mult_p(MOD(i+1,2)+1)%matrix END DO ELSE @@ -724,11 +689,11 @@ SUBROUTINE exp_pade_real(exp_H,matrix,nsquare,npade,error) exp_H%local_data(:,k)=fin_p%local_data(:,k) END DO - CALL cp_fm_release(Npq,error) - CALL cp_fm_release(Dpq,error) - CALL cp_fm_release(T1,error) - CALL cp_fm_release(T2,error) - CALL cp_fm_release(Tres,error) + CALL cp_fm_release(Npq) + CALL cp_fm_release(Dpq) + CALL cp_fm_release(T1) + CALL cp_fm_release(T2) + CALL cp_fm_release(Tres) DEALLOCATE(mult_p) CALL timestop(handle) @@ -744,11 +709,10 @@ END SUBROUTINE exp_pade_real !> \param Him ... !> \param mos_next ... !> \param narn_old ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) + SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old) TYPE(cp_fm_p_type), DIMENSION(2) :: mos_old, mos_new REAL(KIND=dp), INTENT(in) :: eps_exp @@ -757,7 +721,6 @@ SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) TYPE(cp_fm_p_type), DIMENSION(2), & OPTIONAL :: mos_next INTEGER, INTENT(inout) :: narn_old - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'arnoldi', & routineP = moduleN//':'//routineN @@ -787,35 +750,35 @@ SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) para_env=>mos_new(1)%matrix%matrix_struct%para_env CALL cp_fm_get_info(mos_old(1)%matrix,ncol_local=ncol_local,col_indices=col_indices,& - nrow_global=nao,ncol_global=nmo,matrix_struct=mo_struct,error=error) + nrow_global=nao,ncol_global=nmo,matrix_struct=mo_struct) narnoldi=MIN(18,nao) ALLOCATE(results(ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(norm1(ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(V_mats(narnoldi+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(last_norm(ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(H_approx(narnoldi,narnoldi,ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(H_approx_save(narnoldi,narnoldi,ncol_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_procs=>mo_struct%context%blacs2mpi(:,mo_struct%context%mepos(2)) CALL mp_reordering(para_env%group,col_group,col_procs) double_col=.TRUE. double_row=.FALSE. - CALL cp_fm_struct_double(newstruct,mo_struct,mo_struct%context,double_col,double_row,error) + CALL cp_fm_struct_double(newstruct,mo_struct,mo_struct%context,double_col,double_row) H_approx_save=rzero DO i=1,narnoldi+1 CALL cp_fm_create(V_mats(i)%matrix, matrix_struct=newstruct,& - name="V_mat"//cp_to_string(i),error=error) + name="V_mat"//cp_to_string(i)) END DO - CALL cp_fm_get_info(V_mats(1)%matrix,ncol_global=newdim,error=error) + CALL cp_fm_get_info(V_mats(1)%matrix,ncol_global=newdim) norm1=0.0_dp !$OMP PARALLEL DO PRIVATE(icol_local) DEFAULT(NONE) SHARED(V_mats,norm1,mos_old,ncol_local) @@ -839,7 +802,7 @@ SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) ! arnoldi subspace procedure to get H_approx DO i=2,narnoldi+1 !Be careful, imaginary matrix multiplied with complex. Unfortunately requires a swap of arrays afterwards - CALL cp_gemm("N","N",nao,newdim,nao,1.0_dp,Him,V_mats(i-1)%matrix,0.0_dp,V_mats(i)%matrix,error) + CALL cp_gemm("N","N",nao,newdim,nao,1.0_dp,Him,V_mats(i-1)%matrix,0.0_dp,V_mats(i)%matrix) !$OMP PARALLEL DO PRIVATE(icol_local) DEFAULT(NONE) SHARED(mos_new,V_mats,ncol_local,i) DO icol_local=1,ncol_local @@ -849,7 +812,7 @@ SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) END DO IF(PRESENT(Hre))THEN - CALL cp_gemm("N","N",nao,newdim,nao,1.0_dp,Hre,V_mats(i-1)%matrix,1.0_dp,V_mats(i)%matrix,error) + CALL cp_gemm("N","N",nao,newdim,nao,1.0_dp,Hre,V_mats(i-1)%matrix,1.0_dp,V_mats(i)%matrix) END IF DO l=1,i-1 @@ -906,17 +869,17 @@ SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) npade=9 mydim=MIN(i,narnoldi) ALLOCATE(ipivot(mydim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mat1(mydim,mydim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mat2(mydim,mydim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mat3(mydim,mydim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(N(mydim,mydim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(D(mydim,mydim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO icol_local=1,ncol_local DO idim=1,mydim DO j=1,mydim @@ -1023,17 +986,17 @@ SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) END IF DEALLOCATE(ipivot,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mat1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mat2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mat3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(N,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(D,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(convergence)EXIT @@ -1045,23 +1008,23 @@ SUBROUTINE arnoldi(mos_old,mos_new,eps_exp,Hre,Him,mos_next,narn_old,error) !deallocate all work matrices DO i=1,SIZE(V_mats) - CALL cp_fm_release(V_mats(i)%matrix,error) + CALL cp_fm_release(V_mats(i)%matrix) END DO - CALL cp_fm_struct_release(newstruct,error) + CALL cp_fm_struct_release(newstruct) CALL mp_comm_free(col_group) DEALLOCATE(V_mats,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(H_approx,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(H_approx_save,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(results,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(norm1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(last_norm,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE arnoldi diff --git a/src/metadynamics.F b/src/metadynamics.F index 7363debd48..3409cfd2f6 100644 --- a/src/metadynamics.F +++ b/src/metadynamics.F @@ -85,14 +85,12 @@ MODULE metadynamics !> \param force_env ... !> \param simpar ... !> \param itimes ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE metadyn_initialise_plumed(force_env, simpar, itimes, error) + SUBROUTINE metadyn_initialise_plumed(force_env, simpar, itimes) TYPE(force_env_type), POINTER :: force_env TYPE(simpar_type), POINTER :: simpar INTEGER, INTENT(IN) :: itimes - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'metadyn_initialise_plumed', & routineP = moduleN//':'//routineN @@ -118,13 +116,12 @@ SUBROUTINE metadyn_initialise_plumed(force_env, simpar, itimes, error) #endif CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(simpar),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(simpar),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) #if defined (__PLUMED_CP2K) || defined (__PLUMED2) NULLIFY(cell,subsys) - CALL force_env_get(force_env, subsys=subsys, cell=cell, & - error=error) + CALL force_env_get(force_env, subsys=subsys, cell=cell) CALL pbc_cp2k_plumed_getset_cell (cell, set=.TRUE.) !Store the cell pointer for later use. timestep_plumed=simpar%dt natom_plumed=subsys%particles%n_els @@ -170,7 +167,7 @@ SUBROUTINE metadyn_initialise_plumed(force_env, simpar, itimes, error) routineP,"Requested to use plumed for metadynamics, but cp2k was"//& " not compiled with plumed support."//& CPSourceFileRef,& - error,failure) + failure) #endif CALL timestop(handle) @@ -203,20 +200,18 @@ SUBROUTINE metadyn_finalise_plumed() !> \param itimes ... !> \param vel ... !> \param rand ... -!> \param error ... !> \date 01.2009 !> \par History !> 01.2009 created !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand, error) + SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand) TYPE(force_env_type), POINTER :: force_env INTEGER, INTENT(IN) :: itimes REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL :: vel REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: rand - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_integrator', & routineP = moduleN//':'//routineN @@ -251,7 +246,7 @@ SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand, error) IF (force_env%meta_env%use_plumed .EQV. .TRUE.) THEN plumed_itimes = itimes #if defined (__PLUMED_CP2K) - CALL force_env_get(force_env, subsys=subsys,cell=cell, error=error) + CALL force_env_get(force_env, subsys=subsys,cell=cell) natom_plumed=subsys%particles%n_els ALLOCATE (pos_plumed(1:3,natom_plumed)) ALLOCATE (force_plumed(1:3,natom_plumed)) @@ -277,7 +272,7 @@ SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand, error) DEALLOCATE (force_plumed, pos_plumed) #endif #if defined (__PLUMED2) - CALL force_env_get(force_env, meta_env=meta_env, subsys=subsys,cell=cell, error=error) + CALL force_env_get(force_env, meta_env=meta_env, subsys=subsys,cell=cell) natom_plumed=subsys%particles%n_els ALLOCATE (pos_plumed_x(natom_plumed)) ALLOCATE (pos_plumed_y(natom_plumed)) @@ -314,7 +309,7 @@ SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand, error) ! virial plu_vir(:,:)=0.0d0 - CALL force_env_get(force_env, potential_energy=stpcfg, error=error) + CALL force_env_get(force_env, potential_energy=stpcfg) CALL plumed_f_gcmd("setStep"//CHAR(0),plumed_itimes) CALL plumed_f_gcmd("setPositionsX"//CHAR(0),pos_plumed_x(:)) @@ -345,7 +340,7 @@ SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand, error) DEALLOCATE (mass_plumed) ! Constraints ONLY of Fixed Atom type - CALL fix_atom_control(force_env, error=error) + CALL fix_atom_control(force_env) #endif #if !defined (__PLUMED_CP2K) && !defined (__PLUMED2) @@ -353,7 +348,7 @@ SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand, error) routineP,"Requested to use plumed for metadynamics, but cp2k was"//& " not compiled with plumed support."//& CPSourceFileRef,& - error,failure) + failure) #endif @@ -362,19 +357,19 @@ SUBROUTINE metadyn_integrator(force_env, itimes, vel, rand, error) IF (.NOT.PRESENT(rand)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Langevin on COLVAR not implemented for this MD ensemble!", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF ! *** Velocity Verlet for Langevin S(t)->S(t+1) - CALL metadyn_position_colvar(force_env, error=error) + CALL metadyn_position_colvar(force_env) ! *** Forces from Vs and S(X(t+1)) - CALL metadyn_forces(force_env, error=error) + CALL metadyn_forces(force_env) ! *** Velocity Verlet for Langeving *** v(t+1/2)--> v(t) - CALL metadyn_velocities_colvar(force_env, rand,error=error) + CALL metadyn_velocities_colvar(force_env, rand) ELSE - CALL metadyn_forces(force_env, vel,error=error) + CALL metadyn_forces(force_env, vel) ENDIF ! *** Write down COVAR informations - CALL metadyn_write_colvar(force_env, error=error) + CALL metadyn_write_colvar(force_env) END IF ENDIF @@ -387,15 +382,13 @@ END SUBROUTINE metadyn_integrator !> possibly modifies the velocites (if reflective walls are applied) !> \param force_env ... !> \param vel ... -!> \param error ... !> \par History !> 04.2004 created ! ***************************************************************************** - SUBROUTINE metadyn_forces(force_env,vel,error) + SUBROUTINE metadyn_forces(force_env,vel) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL :: vel - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_forces', & routineP = moduleN//':'//routineN @@ -422,9 +415,9 @@ SUBROUTINE metadyn_forces(force_env,vel,error) IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(colvar_p,subsys,cv,ss0_section, vvp_section) - CALL force_env_get(force_env, subsys=subsys, error=error) + CALL force_env_get(force_env, subsys=subsys) dt = meta_env%dt IF (.NOT.meta_env%restart) meta_env%n_steps=meta_env%n_steps+1 @@ -434,7 +427,7 @@ SUBROUTINE metadyn_forces(force_env,vel,error) meta_env%ekin_s = 0.0_dp DO i_c=1,meta_env%n_colvar cv => meta_env%metavar(i_c) - cv%vvp = next_random_number(force_env%globenv%gaussian_rng_stream,error=error) + cv%vvp = next_random_number(force_env%globenv%gaussian_rng_stream) meta_env%ekin_s = meta_env%ekin_s + 0.5_dp*cv%mass*cv%vvp**2 END DO ekin_w = 0.5_dp*meta_env%temp_wanted*REAL(meta_env%n_colvar,KIND=dp) @@ -451,7 +444,7 @@ SUBROUTINE metadyn_forces(force_env,vel,error) DO i_c=1,meta_env%n_colvar cv => meta_env%metavar(i_c) icolvar = cv%icolvar - CALL colvar_eval_glob_f(icolvar,force_env,error=error) + CALL colvar_eval_glob_f(icolvar,force_env) cv%ss = subsys%colvar_p(icolvar)%colvar%ss ! Setup the periodic flag if the COLVAR is (-pi,pi] periodic @@ -460,20 +453,20 @@ SUBROUTINE metadyn_forces(force_env,vel,error) ! Restart for Extended Lagrangian Metadynamics IF (meta_env%restart) THEN ! Initialize the position of the collective variable in the extended lagrange - ss0_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS0",error=error) - CALL section_vals_get(ss0_section, explicit=explicit, error=error) + ss0_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS0") + CALL section_vals_get(ss0_section, explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(ss0_section,"_DEFAULT_KEYWORD_",& - i_rep_val=i_c, r_val=rval, error=error) + i_rep_val=i_c, r_val=rval) cv%ss0 = rval ELSE cv%ss0 = cv%ss END IF - vvp_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_VVP",error=error) - CALL section_vals_get(vvp_section, explicit=explicit, error=error) + vvp_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_VVP") + CALL section_vals_get(vvp_section, explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(vvp_section,"_DEFAULT_KEYWORD_",& - i_rep_val=i_c, r_val=rval, error=error) + i_rep_val=i_c, r_val=rval) cv%vvp = rval END IF END IF @@ -484,10 +477,10 @@ SUBROUTINE metadyn_forces(force_env,vel,error) END IF ENDDO ! History dependent forces (evaluated at s0) - IF(meta_env%do_hills) CALL hills(meta_env,error) + IF(meta_env%do_hills) CALL hills(meta_env) ! Apply walls to the colvars - CALL meta_walls(meta_env, error) + CALL meta_walls(meta_env) meta_env%restart = .FALSE. IF(.NOT.meta_env%extended_lagrange)THEN @@ -502,7 +495,7 @@ SUBROUTINE metadyn_forces(force_env,vel,error) icolvar=cv%icolvar NULLIFY(particles) CALL cp_subsys_get(subsys, colvar_p=colvar_p, & - particles=particles,error=error) + particles=particles) DO ii=1,colvar_p(icolvar)%colvar%n_atom_s i=colvar_p(icolvar)%colvar%i_atom(ii) fft = cv%ff_hills + cv%ff_walls @@ -526,7 +519,7 @@ SUBROUTINE metadyn_forces(force_env,vel,error) ! forces on the atoms NULLIFY(particles) CALL cp_subsys_get(subsys, colvar_p=colvar_p, & - particles=particles,error=error) + particles=particles) DO ii=1,colvar_p(icolvar)%colvar%n_atom_s i=colvar_p(icolvar)%colvar%i_atom(ii) particles%els(i)%f=particles%els(i)%f- cv%ff_s*colvar_p(icolvar)%colvar%dsdr(:,ii) @@ -588,7 +581,7 @@ SUBROUTINE metadyn_forces(force_env,vel,error) END IF ENDIF ! Constraints ONLY of Fixed Atom type - CALL fix_atom_control(force_env, error=error) + CALL fix_atom_control(force_env) ! Reflective Wall only for ss DO i_c = 1, meta_env%n_colvar @@ -607,7 +600,7 @@ SUBROUTINE metadyn_forces(force_env,vel,error) END SELECT NULLIFY(particles) icolvar=cv%icolvar - CALL cp_subsys_get(subsys, colvar_p=colvar_p, particles=particles,error=error) + CALL cp_subsys_get(subsys, colvar_p=colvar_p, particles=particles) scal=0.0_dp scalf=0.0_dp norm=0.0_dp @@ -656,15 +649,13 @@ END SUBROUTINE metadyn_forces !> Vanden-Eijnden Ciccotti C.Phys.Letter 429 (2006) 310-316 !> \param force_env ... !> \param rand ... -!> \param error ... !> \date 01.2009 !> \author Fabio Sterpone and Teodoro Laino ! ***************************************************************************** - SUBROUTINE metadyn_velocities_colvar(force_env,rand,error) + SUBROUTINE metadyn_velocities_colvar(force_env,rand) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT), OPTIONAL :: rand - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_velocities_colvar', & routineP = moduleN//':'//routineN @@ -682,13 +673,13 @@ SUBROUTINE metadyn_velocities_colvar(force_env,rand,error) IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Add citation IF (meta_env%langevin) CALL cite_reference(VandenCic2006) dt = meta_env%dt ! History dependent forces (evaluated at s0) - IF(meta_env%do_hills) CALL hills(meta_env,error) + IF(meta_env%do_hills) CALL hills(meta_env) ! Evolve Velocities meta_env%ekin_s = 0.0_dp @@ -718,13 +709,11 @@ END SUBROUTINE metadyn_velocities_colvar !> \brief Evolves COLVAR position !> Vanden-Eijnden Ciccotti C.Phys.Letter 429 (2006) 310-316 !> \param force_env ... -!> \param error ... !> \date 01.2009 !> \author Fabio Sterpone and Teodoro Laino ! ***************************************************************************** - SUBROUTINE metadyn_position_colvar(force_env,error) + SUBROUTINE metadyn_position_colvar(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_position_colvar', & routineP = moduleN//':'//routineN @@ -742,7 +731,7 @@ SUBROUTINE metadyn_position_colvar(force_env,error) IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Add citation IF (meta_env%langevin) CALL cite_reference(VandenCic2006) @@ -765,13 +754,11 @@ END SUBROUTINE metadyn_position_colvar !> \brief Write down COLVAR information evolved according to !> Vanden-Eijnden Ciccotti C.Phys.Letter 429 (2006) 310-316 !> \param force_env ... -!> \param error ... !> \date 01.2009 !> \author Fabio Sterpone and Teodoro Laino ! ***************************************************************************** - SUBROUTINE metadyn_write_colvar(force_env,error) + SUBROUTINE metadyn_write_colvar(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_write_colvar', & routineP = moduleN//':'//routineN @@ -789,7 +776,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! If Langevin we need to recompute few quantities ! This does not apply to the standard lagrangian scheme since it is @@ -816,7 +803,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) ! write COLVAR file iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%COLVAR",extension=".metadynLog",error=error) + "PRINT%COLVAR",extension=".metadynLog") IF (iw>0) THEN IF (meta_env%extended_lagrange) THEN WRITE(iw,'(f16.8,70f15.8)')meta_env%time*femtoseconds, & @@ -840,7 +827,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) END IF END IF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%COLVAR", error=error) + "PRINT%COLVAR") ! Temperature for COLVAR IF (meta_env%extended_lagrange) THEN @@ -848,7 +835,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) meta_env%avg_temp = (meta_env%avg_temp*REAL(meta_env%n_steps,KIND=dp)+& temp)/REAL(meta_env%n_steps+1,KIND=dp) iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%TEMPERATURE_COLVAR",extension=".metadynLog",error=error) + "PRINT%TEMPERATURE_COLVAR",extension=".metadynLog") IF (iw > 0) THEN WRITE (iw, '(T2,79("-"))') WRITE (iw,'( A,T51,f10.2,T71,f10.2)' )' COLVARS INSTANTANEOUS/AVERAGE TEMPERATURE ',& @@ -856,7 +843,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) WRITE (iw, '(T2,79("-"))') ENDIF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%TEMPERATURE_COLVAR", error=error) + "PRINT%TEMPERATURE_COLVAR") END IF CALL timestop(handle) @@ -866,15 +853,13 @@ END SUBROUTINE metadyn_write_colvar !> \brief Major driver for adding hills and computing forces due to the history !> dependent term !> \param meta_env ... -!> \param error ... !> \par History !> 04.2004 created !> 10.2008 Teodoro Laino [tlaino] - University of Zurich !> Major rewriting and addition of multiple walkers ! ***************************************************************************** - SUBROUTINE hills(meta_env,error) + SUBROUTINE hills(meta_env) TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hills', & routineP = moduleN//':'//routineN @@ -900,26 +885,26 @@ SUBROUTINE hills(meta_env,error) failure = .FALSE. NULLIFY(hills_env, multiple_walkers, logger, colvars, ddp, local_last_hills) hills_env => meta_env%hills_env - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() colvars => meta_env%metavar n_colvar = meta_env%n_colvar n_step = meta_env%n_steps ! Create a temporary logger level specific for metadynamics - CALL cp_add_iter_level(logger%iter_info,"METADYNAMICS",error=error) - CALL get_meta_iter_level(meta_env, iter_nr, error) - CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_nr,error=error) + CALL cp_add_iter_level(logger%iter_info,"METADYNAMICS") + CALL get_meta_iter_level(meta_env, iter_nr) + CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_nr) ! Set-up restart if any IF (meta_env%hills_env%restart) THEN meta_env%hills_env%restart = .FALSE. IF (meta_env%well_tempered) THEN CALL restart_hills(hills_env%ss_history, hills_env%delta_s_history, hills_env%ww_history,& - hills_env%ww, hills_env%n_hills, n_colvar, colvars, meta_env%metadyn_section, error,& + hills_env%ww, hills_env%n_hills, n_colvar, colvars, meta_env%metadyn_section,& invdt_history=hills_env%invdt_history) ELSE CALL restart_hills(hills_env%ss_history, hills_env%delta_s_history, hills_env%ww_history,& - hills_env%ww, hills_env%n_hills, n_colvar, colvars, meta_env%metadyn_section, error) + hills_env%ww, hills_env%n_hills, n_colvar, colvars, meta_env%metadyn_section) END IF END IF @@ -930,9 +915,9 @@ SUBROUTINE hills(meta_env,error) IF ((hills_env%min_disp > 0.0_dp).AND.(hills_env%old_hill_number > 0).AND.& (intermeta_steps >= hills_env%min_nt_hills)) THEN ALLOCATE (ddp(meta_env%n_colvar), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE (local_last_hills(meta_env%n_colvar), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) local_last_hills(1:n_colvar) = hills_env%ss_history(1:n_colvar,hills_env%old_hill_number) @@ -950,21 +935,19 @@ SUBROUTINE hills(meta_env,error) IF (dp2 > hills_env%min_disp) THEN force_gauss = .TRUE. iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".metadynLog",& - error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".metadynLog") IF (iw > 0) THEN WRITE (UNIT=iw,FMT="(A,F0.6,A,F0.6)")& " METADYN| Threshold value for COLVAR displacement exceeded: ",& dp2," > ",hills_env%min_disp END IF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%PROGRAM_RUN_INFO",& - error=error) + "PRINT%PROGRAM_RUN_INFO") END IF DEALLOCATE (ddp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE (local_last_hills, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF !RG keep into account adaptive hills @@ -993,9 +976,9 @@ SUBROUTINE hills(meta_env,error) ENDDO wtww=hills_env%ww*EXP(-V_now_here*meta_env%invdt) ww=wtww*(1.0_dp + meta_env%wttemperature*meta_env%invdt) - CALL add_hill_single(hills_env, colvars, ww, hills_env%n_hills, n_colvar, error, meta_env%invdt) + CALL add_hill_single(hills_env, colvars, ww, hills_env%n_hills, n_colvar,meta_env%invdt) ELSE - CALL add_hill_single(hills_env, colvars, hills_env%ww, hills_env%n_hills, n_colvar, error) + CALL add_hill_single(hills_env, colvars, hills_env%ww, hills_env%n_hills, n_colvar) END IF ! Update local n_hills counter IF (meta_env%do_multiple_walkers) multiple_walkers%n_hills_local = multiple_walkers%n_hills_local+1 @@ -1004,12 +987,12 @@ SUBROUTINE hills(meta_env,error) hills_env%old_hill_step=n_step ! Update iteration level for printing - CALL get_meta_iter_level(meta_env, iter_nr, error) - CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_nr,error=error) + CALL get_meta_iter_level(meta_env, iter_nr) + CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_nr) ! Print just program_run_info iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".metadynLog",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".metadynLog") IF (iw>0) THEN IF (meta_env%do_multiple_walkers) THEN WRITE(iw,'(/,1X,"METADYN|",A,I0,A,I0,A,/)')& @@ -1020,13 +1003,13 @@ SUBROUTINE hills(meta_env,error) END IF END IF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") ! Handle Multiple Walkers IF (meta_env%do_multiple_walkers) THEN ! Print Local Hills file if requested iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%HILLS",middle_name="LOCAL",extension=".metadynLog",error=error) + "PRINT%HILLS",middle_name="LOCAL",extension=".metadynLog") IF (iw>0) THEN WRITE(iw,'(f12.1,30f13.5)')meta_env%time*femtoseconds,& (hills_env%ss_history(ih,hills_env%n_hills),ih=1,n_colvar),& @@ -1034,17 +1017,17 @@ SUBROUTINE hills(meta_env,error) hills_env%ww_history(hills_env%n_hills) END IF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%HILLS", error=error) + "PRINT%HILLS") ! Check the communication buffer of the other walkers CALL synchronize_multiple_walkers(multiple_walkers, hills_env, colvars,& - n_colvar, meta_env%metadyn_section, error) + n_colvar, meta_env%metadyn_section) END IF ! Print Hills file if requested (for multiple walkers this file includes ! the Hills coming from all the walkers). iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%HILLS",extension=".metadynLog",error=error) + "PRINT%HILLS",extension=".metadynLog") IF (iw>0) THEN DO i_hills = n_hills_start+1, hills_env%n_hills WRITE(iw,'(f12.1,30f13.5)')meta_env%time*femtoseconds,& @@ -1054,18 +1037,18 @@ SUBROUTINE hills(meta_env,error) END DO END IF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%HILLS", error=error) + "PRINT%HILLS") END IF ! Computes forces due to the hills: history dependent term ALLOCATE(ddp(meta_env%n_colvar), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(diff_ss(meta_env%n_colvar), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(numf(meta_env%n_colvar), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(denf(meta_env%n_colvar), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) hills_env%energy = 0.0_dp DO ih=1,n_colvar @@ -1120,15 +1103,15 @@ SUBROUTINE hills(meta_env,error) ENDDO ENDDO DEALLOCATE(ddp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(diff_ss, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(numf, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(denf, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) - CALL cp_rm_iter_level(logger%iter_info,"METADYNAMICS",error=error) + CALL cp_rm_iter_level(logger%iter_info,"METADYNAMICS") CALL timestop(handle) diff --git a/src/metadynamics_types.F b/src/metadynamics_types.F index b8d38ba84f..a21858d510 100644 --- a/src/metadynamics_types.F +++ b/src/metadynamics_types.F @@ -134,8 +134,6 @@ MODULE metadynamics_types !> \param dt ... !> \param para_env ... !> \param metadyn_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2004 created !> 02.2006 Reorganized the structure of the restart for Metadynamics (teo) @@ -145,13 +143,12 @@ MODULE metadynamics_types !> - Teodoro Laino [tlaino] - University of Zurich. 10.2008 !> Major rewriting and addition of multiple walkers ! ***************************************************************************** - SUBROUTINE metadyn_create(meta_env, n_colvar, dt, para_env, metadyn_section, error) + SUBROUTINE metadyn_create(meta_env, n_colvar, dt, para_env, metadyn_section) TYPE(meta_env_type), POINTER :: meta_env INTEGER, INTENT(in) :: n_colvar REAL(dp), INTENT(in) :: dt TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: metadyn_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_create', & routineP = moduleN//':'//routineN @@ -161,9 +158,9 @@ SUBROUTINE metadyn_create(meta_env, n_colvar, dt, para_env, metadyn_section, err failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(meta_env),cp_failure_level,routinep,error,failure) + CPPrecondition(.NOT.ASSOCIATED(meta_env),cp_failure_level,routinep,failure) ALLOCATE(meta_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) NULLIFY(meta_env%multiple_walkers,& meta_env%metadyn_section,& meta_env%time,& @@ -179,7 +176,7 @@ SUBROUTINE metadyn_create(meta_env, n_colvar, dt, para_env, metadyn_section, err meta_env%id_nr = last_meta_env_id meta_env%n_colvar = n_colvar meta_env%para_env => para_env - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) meta_env%ekin_s = 0.0_dp meta_env%epot_s = 0.0_dp @@ -190,22 +187,22 @@ SUBROUTINE metadyn_create(meta_env, n_colvar, dt, para_env, metadyn_section, err ! Hills_env ALLOCATE(meta_env%hills_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(meta_env%hills_env%ss_history(n_colvar,0), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(meta_env%hills_env%delta_s_history(n_colvar,0), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(meta_env%hills_env%ww_history(0), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(meta_env%hills_env%invdt_history(0), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) meta_env%hills_env%n_hills = 0 meta_env%hills_env%energy = 0.0_dp meta_env%hills_env%restart = .TRUE. ! Colvar ALLOCATE(meta_env%metavar(n_colvar), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DO i = 1, n_colvar NULLIFY(meta_env%metavar(i)%walls) meta_env%metavar(i)%mass = -HUGE(0.0_dp) @@ -227,10 +224,10 @@ SUBROUTINE metadyn_create(meta_env, n_colvar, dt, para_env, metadyn_section, err ! Multiple Walkers CALL section_vals_val_get(metadyn_section,"MULTIPLE_WALKERS%_SECTION_PARAMETERS_",& - l_val=meta_env%do_multiple_walkers,error=error) + l_val=meta_env%do_multiple_walkers) IF (meta_env%do_multiple_walkers) THEN ALLOCATE(meta_env%multiple_walkers,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ! Walkers status and Walkers file name NULLIFY(meta_env%multiple_walkers%walkers_status,& @@ -238,10 +235,10 @@ SUBROUTINE metadyn_create(meta_env, n_colvar, dt, para_env, metadyn_section, err meta_env%multiple_walkers%n_hills_local = 0 END IF - CALL section_vals_val_get(metadyn_section,"LANGEVIN",l_val=do_langevin,error=error) + CALL section_vals_val_get(metadyn_section,"LANGEVIN",l_val=do_langevin) IF (do_langevin) THEN ALLOCATE (meta_env%rng(meta_env%n_colvar),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,meta_env%n_colvar NULLIFY(meta_env%rng(meta_env%n_colvar)%stream) END DO @@ -252,14 +249,11 @@ END SUBROUTINE metadyn_create !> \brief sets the meta_env !> \param meta_env ... !> \param time ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author alessandro laio and fawzi mohamed ! ***************************************************************************** - SUBROUTINE set_meta_env(meta_env, time, error) + SUBROUTINE set_meta_env(meta_env, time) TYPE(meta_env_type), POINTER :: meta_env REAL(KIND=dp), OPTIONAL, POINTER :: time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_meta_env', & routineP = moduleN//':'//routineN @@ -278,13 +272,10 @@ END SUBROUTINE set_meta_env ! ***************************************************************************** !> \brief retains the meta_env !> \param meta_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author alessandro laio and fawzi mohamed ! ***************************************************************************** - SUBROUTINE meta_env_retain(meta_env,error) + SUBROUTINE meta_env_retain(meta_env) TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'meta_env_retain', & routineP = moduleN//':'//routineN @@ -293,21 +284,18 @@ SUBROUTINE meta_env_retain(meta_env,error) failure=.FALSE. - CPPreconditionNoFail(ASSOCIATED(meta_env),cp_failure_level,routineP,error) - CPPreconditionNoFail(meta_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(meta_env),cp_failure_level,routineP) + CPPreconditionNoFail(meta_env%ref_count>0,cp_failure_level,routineP) meta_env%ref_count=meta_env%ref_count+1 END SUBROUTINE meta_env_retain ! ***************************************************************************** !> \brief releases the meta_env !> \param meta_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author alessandro laio and fawzi mohamed ! ***************************************************************************** - SUBROUTINE meta_env_release(meta_env,error) + SUBROUTINE meta_env_release(meta_env) TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'meta_env_release', & routineP = moduleN//':'//routineN @@ -317,51 +305,51 @@ SUBROUTINE meta_env_release(meta_env,error) failure=.FALSE. IF (ASSOCIATED(meta_env)) THEN - CPPreconditionNoFail(meta_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(meta_env%ref_count>0,cp_failure_level,routineP) meta_env%ref_count=meta_env%ref_count-1 IF (meta_env%ref_count==0) THEN - CALL cp_para_env_release(meta_env%para_env,error=error) + CALL cp_para_env_release(meta_env%para_env) IF (ASSOCIATED(meta_env%metavar)) THEN DO i = 1, SIZE(meta_env%metavar) IF (ASSOCIATED(meta_env%metavar(i)%walls)) THEN DEALLOCATE(meta_env%metavar(i)%walls,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END DO DEALLOCATE(meta_env%metavar,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF ! Hills env - CALL hills_env_release(meta_env%hills_env,error) + CALL hills_env_release(meta_env%hills_env) ! Walkers type IF (ASSOCIATED(meta_env%multiple_walkers)) THEN IF (ASSOCIATED(meta_env%multiple_walkers%walkers_status)) THEN DEALLOCATE(meta_env%multiple_walkers%walkers_status,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(meta_env%multiple_walkers%walkers_file_name)) THEN DEALLOCATE(meta_env%multiple_walkers%walkers_file_name,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF DEALLOCATE(meta_env%multiple_walkers,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF ! Langevin on COLVARS IF (meta_env%langevin) THEN DO i = 1, SIZE(meta_env%rng) IF (ASSOCIATED(meta_env%rng(i)%stream)) THEN - CALL delete_rng_stream(meta_env%rng(i)%stream,error=error) + CALL delete_rng_stream(meta_env%rng(i)%stream) END IF END DO DEALLOCATE (meta_env%rng,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF NULLIFY(meta_env%time) NULLIFY(meta_env%metadyn_section) DEALLOCATE(meta_env, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF END SUBROUTINE meta_env_release @@ -369,13 +357,10 @@ END SUBROUTINE meta_env_release ! ***************************************************************************** !> \brief releases the hills_env !> \param hills_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE hills_env_release(hills_env, error) + SUBROUTINE hills_env_release(hills_env) TYPE(hills_env_type), POINTER :: hills_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hills_env_release', & routineP = moduleN//':'//routineN @@ -387,22 +372,22 @@ SUBROUTINE hills_env_release(hills_env, error) IF (ASSOCIATED(hills_env)) THEN IF (ASSOCIATED(hills_env%ss_history)) THEN DEALLOCATE(hills_env%ss_history,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(hills_env%delta_s_history)) THEN DEALLOCATE(hills_env%delta_s_history,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(hills_env%ww_history)) THEN DEALLOCATE(hills_env%ww_history,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(hills_env%invdt_history)) THEN DEALLOCATE(hills_env%invdt_history,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF DEALLOCATE(hills_env,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END SUBROUTINE hills_env_release diff --git a/src/metadynamics_utils.F b/src/metadynamics_utils.F index c936558130..710280169a 100644 --- a/src/metadynamics_utils.F +++ b/src/metadynamics_utils.F @@ -74,19 +74,17 @@ MODULE metadynamics_utils !> \param root_section ... !> \param para_env ... !> \param fe_section ... -!> \param error ... !> \par History !> 04.2004 created !> \author Teodoro Laino [tlaino] - University of Zurich. 11.2007 ! ***************************************************************************** - SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section,error) + SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section) TYPE(meta_env_type), POINTER :: meta_env TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), OPTIONAL, & POINTER :: fe_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_read', & routineP = moduleN//':'//routineN @@ -107,54 +105,54 @@ SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section,erro CALL timeset(routineN,handle) failure = .FALSE. - CALL section_vals_get(fe_section,explicit=explicit,error=error) + CALL section_vals_get(fe_section,explicit=explicit) IF (explicit) THEN number_allocated_colvars = 0 - CALL force_env_get(force_env, subsys=subsys, error=error) + CALL force_env_get(force_env, subsys=subsys) IF (ASSOCIATED(subsys%colvar_p)) THEN number_allocated_colvars = SIZE(subsys%colvar_p) END IF - CALL section_vals_val_get(fe_section,"METHOD",i_val=id_method,error=error) + CALL section_vals_val_get(fe_section,"METHOD",i_val=id_method) IF (id_method/=do_fe_meta) THEN CALL timestop(handle) RETURN ENDIF - metadyn_section => section_vals_get_subs_vals(fe_section,"METADYN",error=error) - CPPreconditionNoFail(.NOT.ASSOCIATED(meta_env),cp_failure_level,routineP,error) + metadyn_section => section_vals_get_subs_vals(fe_section,"METADYN") + CPPreconditionNoFail(.NOT.ASSOCIATED(meta_env),cp_failure_level,routineP) - md_section => section_vals_get_subs_vals(root_section,"MOTION%MD",error=error) - CALL section_vals_val_get(md_section,"TIMESTEP",r_val=dt,error=error) + md_section => section_vals_get_subs_vals(root_section,"MOTION%MD") + CALL section_vals_val_get(md_section,"TIMESTEP",r_val=dt) - metavar_section => section_vals_get_subs_vals(metadyn_section,"METAVAR",error=error) - CALL section_vals_get(metavar_section,n_repetition=n_colvar,error=error) + metavar_section => section_vals_get_subs_vals(metadyn_section,"METAVAR") + CALL section_vals_get(metavar_section,n_repetition=n_colvar) CALL metadyn_create(meta_env,n_colvar=n_colvar,& - dt=dt,para_env=para_env,metadyn_section=metadyn_section,error=error) + dt=dt,para_env=para_env,metadyn_section=metadyn_section) !Check if using plumed. If so, only get the file name and read nothing else - CALL section_vals_val_get(metadyn_section,"USE_PLUMED",l_val=meta_env%use_plumed,error=error) + CALL section_vals_val_get(metadyn_section,"USE_PLUMED",l_val=meta_env%use_plumed) IF (meta_env%use_plumed .EQV. .TRUE.) THEN - CALL section_vals_val_get(metadyn_section,"PLUMED_INPUT_FILE",c_val=meta_env%plumed_input_file,error=error) + CALL section_vals_val_get(metadyn_section,"PLUMED_INPUT_FILE",c_val=meta_env%plumed_input_file) meta_env%plumed_input_file=TRIM(meta_env%plumed_input_file)//CHAR(0) meta_env%langevin=.FALSE. CALL timestop(handle) RETURN END IF - CALL section_vals_val_get(metadyn_section,"DO_HILLS",l_val=meta_env%do_hills,error=error) - CALL section_vals_val_get(metadyn_section,"LAGRANGE",l_val=meta_env%extended_lagrange,error=error) - CALL section_vals_val_get(metadyn_section,"TAMCSteps",i_val=meta_env%TAMCSteps,error=error) + CALL section_vals_val_get(metadyn_section,"DO_HILLS",l_val=meta_env%do_hills) + CALL section_vals_val_get(metadyn_section,"LAGRANGE",l_val=meta_env%extended_lagrange) + CALL section_vals_val_get(metadyn_section,"TAMCSteps",i_val=meta_env%TAMCSteps) IF (meta_env%TAMCSteps<0) THEN CALL cp_assert(.FALSE.,cp_fatal_level,cp_assertion_failed,routineP,& "TAMCSteps must be positive!",only_ionode=.TRUE.) ENDIF - CALL section_vals_val_get(metadyn_section,"Timestep",r_val=meta_env%zdt,error=error) + CALL section_vals_val_get(metadyn_section,"Timestep",r_val=meta_env%zdt) IF (meta_env%zdt<=0.0_dp) THEN CALL cp_assert(.FALSE.,cp_fatal_level,cp_assertion_failed,routineP,& "Timestep must be positive!",only_ionode=.TRUE.) ENDIF - CALL section_vals_val_get(metadyn_section,"WW",r_val=meta_env%hills_env%ww,error=error) - CALL section_vals_val_get(metadyn_section,"NT_HILLS",i_val=meta_env%hills_env%nt_hills,error=error) - CALL section_vals_val_get(metadyn_section,"MIN_NT_HILLS",i_val=meta_env%hills_env%min_nt_hills,error=error) + CALL section_vals_val_get(metadyn_section,"WW",r_val=meta_env%hills_env%ww) + CALL section_vals_val_get(metadyn_section,"NT_HILLS",i_val=meta_env%hills_env%nt_hills) + CALL section_vals_val_get(metadyn_section,"MIN_NT_HILLS",i_val=meta_env%hills_env%min_nt_hills) IF (meta_env%hills_env%nt_hills<=0) THEN meta_env%hills_env%min_nt_hills=meta_env%hills_env%nt_hills CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& @@ -166,33 +164,31 @@ SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section,erro "MIN_NT_HILLS must have a value smaller or equal to NT_HILLS! Cross check with the input reference!",& only_ionode=.TRUE.) !RG Adaptive hills - CALL section_vals_val_get(metadyn_section,"MIN_DISP",r_val=meta_env%hills_env%min_disp,error=error) - CALL section_vals_val_get(metadyn_section,"OLD_HILL_NUMBER",i_val=meta_env%hills_env%old_hill_number,& - error=error) - CALL section_vals_val_get(metadyn_section,"OLD_HILL_STEP",i_val=meta_env%hills_env%old_hill_step,& - error=error) + CALL section_vals_val_get(metadyn_section,"MIN_DISP",r_val=meta_env%hills_env%min_disp) + CALL section_vals_val_get(metadyn_section,"OLD_HILL_NUMBER",i_val=meta_env%hills_env%old_hill_number) + CALL section_vals_val_get(metadyn_section,"OLD_HILL_STEP",i_val=meta_env%hills_env%old_hill_step) !Hills tail damping - CALL section_vals_val_get(metadyn_section,"HILL_TAIL_CUTOFF",r_val=meta_env%hills_env%tail_cutoff,error=error) - CALL section_vals_val_get(metadyn_section,"P_EXPONENT",i_val=meta_env%hills_env%p_exp, error=error) - CALL section_vals_val_get(metadyn_section,"Q_EXPONENT",i_val=meta_env%hills_env%q_exp, error=error) + CALL section_vals_val_get(metadyn_section,"HILL_TAIL_CUTOFF",r_val=meta_env%hills_env%tail_cutoff) + CALL section_vals_val_get(metadyn_section,"P_EXPONENT",i_val=meta_env%hills_env%p_exp) + CALL section_vals_val_get(metadyn_section,"Q_EXPONENT",i_val=meta_env%hills_env%q_exp) - CALL section_vals_val_get(metadyn_section,"SLOW_GROWTH",l_val=meta_env%hills_env%slow_growth,error=error) + CALL section_vals_val_get(metadyn_section,"SLOW_GROWTH",l_val=meta_env%hills_env%slow_growth) !RG Adaptive hills - CALL section_vals_val_get(metadyn_section,"STEP_START_VAL",i_val=meta_env%n_steps,error=error) - CPPreconditionNoFail(meta_env%n_steps>=0,cp_failure_level,routineP,error) + CALL section_vals_val_get(metadyn_section,"STEP_START_VAL",i_val=meta_env%n_steps) + CPPreconditionNoFail(meta_env%n_steps>=0,cp_failure_level,routineP) CALL section_vals_val_get(metadyn_section,"NHILLS_START_VAL",& - i_val=meta_env%hills_env%n_hills,error=error) - CALL section_vals_val_get(metadyn_section,"TEMPERATURE",r_val=meta_env%temp_wanted,error=error) - CALL section_vals_val_get(metadyn_section,"LANGEVIN",l_val=meta_env%langevin,error=error) + i_val=meta_env%hills_env%n_hills) + CALL section_vals_val_get(metadyn_section,"TEMPERATURE",r_val=meta_env%temp_wanted) + CALL section_vals_val_get(metadyn_section,"LANGEVIN",l_val=meta_env%langevin) CALL section_vals_val_get(metadyn_section,"TEMP_TOL",explicit=meta_env%tempcontrol,& - r_val=meta_env%toll_temp,error=error) - CALL section_vals_val_get(metadyn_section,"WELL_TEMPERED",l_val=meta_env%well_tempered,error=error) + r_val=meta_env%toll_temp) + CALL section_vals_val_get(metadyn_section,"WELL_TEMPERED",l_val=meta_env%well_tempered) CALL section_vals_val_get(metadyn_section,"DELTA_T",explicit=meta_env%hills_env%wtcontrol,& - r_val=meta_env%delta_t,error=error) + r_val=meta_env%delta_t) CALL section_vals_val_get(metadyn_section,"WTGAMMA",explicit=check,& - r_val=meta_env%wtgamma,error=error) + r_val=meta_env%wtgamma) IF (meta_env%well_tempered) THEN meta_env%hills_env%wtcontrol=meta_env%hills_env%wtcontrol.OR.check check=meta_env%hills_env%wtcontrol @@ -208,11 +204,11 @@ SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section,erro ENDIF CALL section_vals_val_get(metadyn_section,"COLVAR_AVG_TEMPERATURE_RESTART",& - r_val=meta_env%avg_temp,error=error) + r_val=meta_env%avg_temp) ! Parsing Metavar Section DO i= 1, n_colvar CALL metavar_read(meta_env%metavar(i), meta_env%extended_lagrange, & - meta_env%langevin, i, metavar_section,error=error) + meta_env%langevin, i, metavar_section) check=(meta_env%metavar(i)%icolvar<=number_allocated_colvars) CALL cp_assert(check,cp_fatal_level,cp_assertion_failed,routineP,& "An error occured in the specification of COLVAR for METAVAR. "//& @@ -226,25 +222,24 @@ SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section,erro ! Parsing the Multiple Walkers Info IF (meta_env%do_multiple_walkers) THEN NULLIFY(walkers_status) - walkers_section => section_vals_get_subs_vals(metadyn_section,"MULTIPLE_WALKERS",error=error) + walkers_section => section_vals_get_subs_vals(metadyn_section,"MULTIPLE_WALKERS") ! General setup for walkers CALL section_vals_val_get(walkers_section,"WALKER_ID",& - i_val=meta_env%multiple_walkers%walker_id,error=error) + i_val=meta_env%multiple_walkers%walker_id) CALL section_vals_val_get(walkers_section,"NUMBER_OF_WALKERS",& - i_val=meta_env%multiple_walkers%walkers_tot_nr,error=error) + i_val=meta_env%multiple_walkers%walkers_tot_nr) CALL section_vals_val_get(walkers_section,"WALKER_COMM_FREQUENCY",& - i_val=meta_env%multiple_walkers%walkers_freq_comm,error=error) + i_val=meta_env%multiple_walkers%walkers_freq_comm) ! Handle status and file names ALLOCATE(meta_env%multiple_walkers%walkers_status(meta_env%multiple_walkers%walkers_tot_nr),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(meta_env%multiple_walkers%walkers_file_name(meta_env%multiple_walkers%walkers_tot_nr),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) - CALL section_vals_val_get(walkers_section,"WALKERS_STATUS",explicit=explicit,error=error) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) + CALL section_vals_val_get(walkers_section,"WALKERS_STATUS",explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(walkers_section,"WALKERS_STATUS",i_vals=walkers_status,& - error=error) + CALL section_vals_val_get(walkers_section,"WALKERS_STATUS",i_vals=walkers_status) check = (SIZE(walkers_status)==meta_env%multiple_walkers%walkers_tot_nr) CALL cp_assert(check,cp_failure_level,cp_assertion_failed,routineP,& "Number of Walkers specified in the input does not match with the "//& @@ -261,7 +256,7 @@ SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section,erro meta_env%multiple_walkers%walkers_status(meta_env%multiple_walkers%walker_id) CALL section_vals_val_get(walkers_section,"WALKERS_FILE_NAME%_DEFAULT_KEYWORD_",& - n_rep_val=n_rep, error=error) + n_rep_val=n_rep) check = (n_rep==meta_env%multiple_walkers%walkers_tot_nr) CALL cp_assert(check,cp_failure_level,cp_assertion_failed,routineP,& "Number of Walkers specified in the input does not match with the "//& @@ -272,13 +267,13 @@ SUBROUTINE metadyn_read(meta_env,force_env,root_section,para_env,fe_section,erro only_ionode=.TRUE.) DO i = 1, n_rep CALL section_vals_val_get(walkers_section,"WALKERS_FILE_NAME%_DEFAULT_KEYWORD_",& - i_rep_val=i, c_val=walkers_file_name, error=error) + i_rep_val=i, c_val=walkers_file_name) meta_env%multiple_walkers%walkers_file_name(i) = walkers_file_name END DO END IF ! Print Metadynamics Info - CALL print_metadyn_info(meta_env, n_colvar, metadyn_section, error) + CALL print_metadyn_info(meta_env, n_colvar, metadyn_section) END IF CALL timestop(handle) @@ -290,14 +285,12 @@ END SUBROUTINE metadyn_read !> \param meta_env ... !> \param n_colvar ... !> \param metadyn_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich. 10.2008 ! ***************************************************************************** - SUBROUTINE print_metadyn_info(meta_env, n_colvar, metadyn_section, error) + SUBROUTINE print_metadyn_info(meta_env, n_colvar, metadyn_section) TYPE(meta_env_type), POINTER :: meta_env INTEGER, INTENT(IN) :: n_colvar TYPE(section_vals_type), POINTER :: metadyn_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_metadyn_info', & routineP = moduleN//':'//routineN @@ -312,12 +305,12 @@ SUBROUTINE print_metadyn_info(meta_env, n_colvar, metadyn_section, error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,metadyn_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".metadynLog",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".metadynLog") NULLIFY(section,enum,keyword) - CALL create_metavar_section(section,error=error) - wall_section => section_get_subsection(section,"WALL",error) + CALL create_metavar_section(section) + wall_section => section_get_subsection(section,"WALL") IF (iw>0) THEN WRITE (iw,'( /A )') ' METADYN| Meta Dynamics Protocol ' WRITE (iw,'( A,T71,I10)') ' METADYN| Number of interval time steps to spawn hills',& @@ -392,27 +385,27 @@ SUBROUTINE print_metadyn_info(meta_env, n_colvar, metadyn_section, error) IF (meta_env%metavar(i)%do_wall) THEN WRITE (iw,'( A,T71,I10)') ' METAVARS| Number of Walls present',SIZE(meta_env%metavar(i)%walls) DO j = 1, SIZE(meta_env%metavar(i)%walls) - keyword => section_get_keyword(wall_section,"TYPE",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + keyword => section_get_keyword(wall_section,"TYPE") + CALL keyword_get(keyword,enum=enum) WRITE (iw,'(/,A,5X,I10,T50,A,T70,A11)') ' METAVARS| Wall Number:',j,'Type of Wall:',& - ADJUSTR(TRIM(enum_i2c(enum,meta_env%metavar(i)%walls(j)%id_type,error=error))) + ADJUSTR(TRIM(enum_i2c(enum,meta_env%metavar(i)%walls(j)%id_type))) ! Type of wall IO SELECT CASE(meta_env%metavar(i)%walls(j)%id_type) CASE(do_wall_none) ! Do Nothing CYCLE CASE(do_wall_reflective) - work_section => section_get_subsection(wall_section,"REFLECTIVE",error) - keyword => section_get_keyword(work_section,"DIRECTION",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + work_section => section_get_subsection(wall_section,"REFLECTIVE") + keyword => section_get_keyword(work_section,"DIRECTION") + CALL keyword_get(keyword,enum=enum) WRITE (iw,'(A,T70,A11)') ' METAVARS| Wall direction',& - ADJUSTR(TRIM(enum_i2c(enum,meta_env%metavar(i)%walls(j)%id_direction,error=error))) + ADJUSTR(TRIM(enum_i2c(enum,meta_env%metavar(i)%walls(j)%id_direction))) CASE(do_wall_quadratic) - work_section => section_get_subsection(wall_section,"QUADRATIC",error) - keyword => section_get_keyword(work_section,"DIRECTION",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + work_section => section_get_subsection(wall_section,"QUADRATIC") + keyword => section_get_keyword(work_section,"DIRECTION") + CALL keyword_get(keyword,enum=enum) WRITE (iw,'(A,T70,A11)') ' METAVARS| Wall direction',& - ADJUSTR(TRIM(enum_i2c(enum,meta_env%metavar(i)%walls(j)%id_direction,error=error))) + ADJUSTR(TRIM(enum_i2c(enum,meta_env%metavar(i)%walls(j)%id_direction))) WRITE (iw,'(A,T70,F11.6)') ' METAVARS| Constant K of the quadratic potential',& meta_env%metavar(i)%walls(j)%k_quadratic CASE(do_wall_gaussian) @@ -428,8 +421,8 @@ SUBROUTINE print_metadyn_info(meta_env, n_colvar, metadyn_section, error) WRITE (iw,'( A )')' '//'----------------------------------------------------------------------' ENDDO END IF - CALL section_release(section,error=error) - CALL cp_print_key_finished_output(iw,logger,metadyn_section,"PRINT%PROGRAM_RUN_INFO", error=error) + CALL section_release(section) + CALL cp_print_key_finished_output(iw,logger,metadyn_section,"PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -442,19 +435,17 @@ END SUBROUTINE print_metadyn_info !> \param langevin ... !> \param icol ... !> \param metavar_section ... -!> \param error ... !> \par History !> 04.2004 created !> \author alessandro laio and fawzi mohamed !> Teodoro Laino [tlaino] - University of Zurich. 11.2007 ! ***************************************************************************** - SUBROUTINE metavar_read(metavar,extended_lagrange,langevin,icol,metavar_section,error) + SUBROUTINE metavar_read(metavar,extended_lagrange,langevin,icol,metavar_section) TYPE(metavar_type), INTENT(INOUT) :: metavar LOGICAL, INTENT(IN) :: extended_lagrange, langevin INTEGER, INTENT(IN) :: icol TYPE(section_vals_type), OPTIONAL, & POINTER :: metavar_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metavar_read', & routineP = moduleN//':'//routineN @@ -466,33 +457,33 @@ SUBROUTINE metavar_read(metavar,extended_lagrange,langevin,icol,metavar_section, CALL timeset(routineN,handle) failure=.FALSE. - CALL section_vals_val_get(metavar_section,"COLVAR",i_rep_section=icol,i_val=metavar%icolvar,error=error) - CALL section_vals_val_get(metavar_section,"SCALE",i_rep_section=icol,r_val=metavar%delta_s,error=error) + CALL section_vals_val_get(metavar_section,"COLVAR",i_rep_section=icol,i_val=metavar%icolvar) + CALL section_vals_val_get(metavar_section,"SCALE",i_rep_section=icol,r_val=metavar%delta_s) ! Walls - wall_section => section_vals_get_subs_vals(metavar_section,"WALL",i_rep_section=icol,error=error) - CALL section_vals_get(wall_section,n_repetition=n_walls,error=error) + wall_section => section_vals_get_subs_vals(metavar_section,"WALL",i_rep_section=icol) + CALL section_vals_get(wall_section,n_repetition=n_walls) IF (n_walls/=0) THEN metavar%do_wall = .TRUE. ALLOCATE(metavar%walls(n_walls),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DO i = 1, n_walls - CALL section_vals_val_get(wall_section,"TYPE",i_rep_section=i,i_val=metavar%walls(i)%id_type,error=error) - CALL section_vals_val_get(wall_section,"POSITION",i_rep_section=i,r_val=metavar%walls(i)%pos,error=error) + CALL section_vals_val_get(wall_section,"TYPE",i_rep_section=i,i_val=metavar%walls(i)%id_type) + CALL section_vals_val_get(wall_section,"POSITION",i_rep_section=i,r_val=metavar%walls(i)%pos) SELECT CASE(metavar%walls(i)%id_type) CASE(do_wall_none) ! Just cycle.. CYCLE CASE(do_wall_reflective) - work_section => section_vals_get_subs_vals(wall_section,"REFLECTIVE",i_rep_section=i,error=error) - CALL section_vals_val_get(work_section,"DIRECTION",i_val=metavar%walls(i)%id_direction,error=error) + work_section => section_vals_get_subs_vals(wall_section,"REFLECTIVE",i_rep_section=i) + CALL section_vals_val_get(work_section,"DIRECTION",i_val=metavar%walls(i)%id_direction) CASE(do_wall_quadratic) - work_section => section_vals_get_subs_vals(wall_section,"QUADRATIC",i_rep_section=i,error=error) - CALL section_vals_val_get(work_section,"DIRECTION",i_val=metavar%walls(i)%id_direction,error=error) - CALL section_vals_val_get(work_section,"K",r_val=metavar%walls(i)%k_quadratic,error=error) + work_section => section_vals_get_subs_vals(wall_section,"QUADRATIC",i_rep_section=i) + CALL section_vals_val_get(work_section,"DIRECTION",i_val=metavar%walls(i)%id_direction) + CALL section_vals_val_get(work_section,"K",r_val=metavar%walls(i)%k_quadratic) CASE(do_wall_quartic) - work_section => section_vals_get_subs_vals(wall_section,"QUARTIC",i_rep_section=i,error=error) - CALL section_vals_val_get(work_section,"DIRECTION",i_val=metavar%walls(i)%id_direction,error=error) - CALL section_vals_val_get(work_section,"K",r_val=metavar%walls(i)%k_quartic,error=error) + work_section => section_vals_get_subs_vals(wall_section,"QUARTIC",i_rep_section=i) + CALL section_vals_val_get(work_section,"DIRECTION",i_val=metavar%walls(i)%id_direction) + CALL section_vals_val_get(work_section,"K",r_val=metavar%walls(i)%k_quartic) SELECT CASE(metavar%walls(i)%id_direction) CASE(do_wall_m) metavar%walls(i)%pos0= metavar%walls(i)%pos+(0.05_dp/metavar%walls(i)%k_quartic**(1/4)) @@ -500,18 +491,18 @@ SUBROUTINE metavar_read(metavar,extended_lagrange,langevin,icol,metavar_section, metavar%walls(i)%pos0= metavar%walls(i)%pos-(0.05_dp/metavar%walls(i)%k_quartic**(1/4)) END SELECT CASE(do_wall_gaussian) - work_section => section_vals_get_subs_vals(wall_section,"GAUSSIAN",i_rep_section=i,error=error) - CALL section_vals_val_get(work_section,"WW",r_val=metavar%walls(i)%ww_gauss,error=error) - CALL section_vals_val_get(work_section,"SIGMA",r_val=metavar%walls(i)%sigma_gauss,error=error) + work_section => section_vals_get_subs_vals(wall_section,"GAUSSIAN",i_rep_section=i) + CALL section_vals_val_get(work_section,"WW",r_val=metavar%walls(i)%ww_gauss) + CALL section_vals_val_get(work_section,"SIGMA",r_val=metavar%walls(i)%sigma_gauss) END SELECT END DO END IF ! Setup few more parameters for extended lagrangian IF(extended_lagrange)THEN - CALL section_vals_val_get(metavar_section,"MASS",i_rep_section=icol,r_val=metavar%mass,error=error) - CALL section_vals_val_get(metavar_section,"LAMBDA",i_rep_section=icol,r_val=metavar%lambda,error=error) + CALL section_vals_val_get(metavar_section,"MASS",i_rep_section=icol,r_val=metavar%mass) + CALL section_vals_val_get(metavar_section,"LAMBDA",i_rep_section=icol,r_val=metavar%lambda) IF (langevin) THEN - CALL section_vals_val_get(metavar_section,"GAMMA",i_rep_section=icol,r_val=metavar%gamma,error=error) + CALL section_vals_val_get(metavar_section,"GAMMA",i_rep_section=icol,r_val=metavar%gamma) END IF ENDIF @@ -526,18 +517,16 @@ END SUBROUTINE metavar_read !> \param colvars ... !> \param n_colvar ... !> \param metadyn_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2008 ! ***************************************************************************** SUBROUTINE synchronize_multiple_walkers(multiple_walkers, hills_env, colvars,& - n_colvar, metadyn_section, error) + n_colvar, metadyn_section) TYPE(multiple_walkers_type), POINTER :: multiple_walkers TYPE(hills_env_type), POINTER :: hills_env TYPE(metavar_type), DIMENSION(:), & POINTER :: colvars INTEGER, INTENT(IN) :: n_colvar TYPE(section_vals_type), POINTER :: metadyn_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'synchronize_multiple_walkers', & routineP = moduleN//':'//routineN @@ -556,7 +545,7 @@ SUBROUTINE synchronize_multiple_walkers(multiple_walkers, hills_env, colvars,& CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() para_env => logger%para_env ! Locally dump information on file.. @@ -582,11 +571,11 @@ SUBROUTINE synchronize_multiple_walkers(multiple_walkers, hills_env, colvars,& IF (MODULO(multiple_walkers%n_hills_local,multiple_walkers%walkers_freq_comm)==0) THEN ! Store colvars information ALLOCATE(ss0_save(n_colvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(delta_s_save(n_colvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(delta_s_ss0_buf(2,0:n_colvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) delta_s_ss0_buf=0 DO i = 1, n_colvar ss0_save(i) = colvars(i)%ss0 @@ -635,9 +624,9 @@ SUBROUTINE synchronize_multiple_walkers(multiple_walkers, hills_env, colvars,& ! Add this hill to the history dependent terms IF (hills_env%wtcontrol) THEN - CALL add_hill_single(hills_env, colvars, ww, hills_env%n_hills, n_colvar, error, invdt=invdt) + CALL add_hill_single(hills_env, colvars, ww, hills_env%n_hills, n_colvar,invdt=invdt) ELSE - CALL add_hill_single(hills_env, colvars, ww, hills_env%n_hills, n_colvar, error) + CALL add_hill_single(hills_env, colvars, ww, hills_env%n_hills, n_colvar) END IF i_hills = i_hills + 1 @@ -652,13 +641,13 @@ SUBROUTINE synchronize_multiple_walkers(multiple_walkers, hills_env, colvars,& delta_hills = i_hills - 1 - multiple_walkers%walkers_status(i) multiple_walkers%walkers_status(i) = i_hills - 1 iw = cp_print_key_unit_nr(logger,metadyn_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".metadynLog",error=error) + extension=".metadynLog") IF (iw>0) THEN WRITE(iw,'(T2,A,I0,A,I0,A,I0,A)')'WALKERS| Walker #',i,'. Reading [',delta_hills,& '] Hills. Total number of Hills acquired [',multiple_walkers%walkers_status(i),']' END IF CALL cp_print_key_finished_output(iw,logger,metadyn_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END DO ! Restore colvars information @@ -667,9 +656,9 @@ SUBROUTINE synchronize_multiple_walkers(multiple_walkers, hills_env, colvars,& colvars(i)%delta_s = delta_s_save(i) END DO DEALLOCATE(ss0_save,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(delta_s_save,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF CALL timestop(handle) @@ -683,18 +672,16 @@ END SUBROUTINE synchronize_multiple_walkers !> \param ww ... !> \param n_hills ... !> \param n_colvar ... -!> \param error ... !> \param invdt ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2008 ! ***************************************************************************** - SUBROUTINE add_hill_single(hills_env, colvars, ww, n_hills, n_colvar, error, invdt) + SUBROUTINE add_hill_single(hills_env, colvars, ww, n_hills, n_colvar,invdt) TYPE(hills_env_type), POINTER :: hills_env TYPE(metavar_type), DIMENSION(:), & POINTER :: colvars REAL(KIND=dp), INTENT(IN) :: ww INTEGER, INTENT(INOUT) :: n_hills INTEGER, INTENT(IN) :: n_colvar - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), INTENT(IN), OPTIONAL :: invdt CHARACTER(len=*), PARAMETER :: routineN = 'add_hill_single', & @@ -711,42 +698,42 @@ SUBROUTINE add_hill_single(hills_env, colvars, ww, n_hills, n_colvar, error, inv NULLIFY(tmp, tnp) IF(SIZE(hills_env%ss_history,2)< n_hills+1)THEN ALLOCATE(tmp(n_colvar,n_hills+100), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) tmp(:,:n_hills)=hills_env%ss_history tmp(:,n_hills+1:)=0.0_dp DEALLOCATE(hills_env%ss_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) hills_env%ss_history => tmp NULLIFY(tmp) ENDIF IF(SIZE(hills_env%delta_s_history,2)< n_hills+1)THEN ALLOCATE(tmp(n_colvar,n_hills+100), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) tmp(:,:n_hills)=hills_env%delta_s_history tmp(:,n_hills+1:)=0.0_dp DEALLOCATE(hills_env%delta_s_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) hills_env%delta_s_history => tmp NULLIFY(tmp) ENDIF IF(SIZE(hills_env%ww_history)< n_hills+1)THEN ALLOCATE(tnp(n_hills+100), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) tnp(1:n_hills) = hills_env%ww_history tnp(n_hills+1:)= 0.0_dp DEALLOCATE(hills_env%ww_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) hills_env%ww_history => tnp NULLIFY(tnp) ENDIF IF(wtcontrol)THEN IF(SIZE(hills_env%invdt_history)< n_hills+1)THEN ALLOCATE(tnp(n_hills+100), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) tnp(1:n_hills) = hills_env%invdt_history tnp(n_hills+1:)= 0.0_dp DEALLOCATE(hills_env%invdt_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) hills_env%invdt_history => tnp NULLIFY(tnp) ENDIF @@ -774,12 +761,11 @@ END SUBROUTINE add_hill_single !> \param n_colvar ... !> \param colvars ... !> \param metadyn_section ... -!> \param error ... !> \param invdt_history ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2008 ! ***************************************************************************** SUBROUTINE restart_hills(ss_history, delta_s_history, ww_history, ww,& - n_hills, n_colvar, colvars, metadyn_section, error, invdt_history) + n_hills, n_colvar, colvars, metadyn_section,invdt_history) REAL(KIND=dp), DIMENSION(:, :), POINTER :: ss_history, delta_s_history REAL(KIND=dp), DIMENSION(:), POINTER :: ww_history REAL(KIND=dp) :: ww @@ -787,7 +773,6 @@ SUBROUTINE restart_hills(ss_history, delta_s_history, ww_history, ww,& TYPE(metavar_type), DIMENSION(:), & POINTER :: colvars TYPE(section_vals_type), POINTER :: metadyn_section - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: invdt_history @@ -804,51 +789,51 @@ SUBROUTINE restart_hills(ss_history, delta_s_history, ww_history, ww,& failure = .FALSE.; wtcontrol=PRESENT(invdt_history) NULLIFY(rvals) - hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_POS",error=error) - CALL section_vals_get(hills_history, explicit=explicit, error=error) + hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_POS") + CALL section_vals_get(hills_history, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get( hills_history,"_DEFAULT_KEYWORD_",n_rep_val=ndum, error=error) + CALL section_vals_val_get( hills_history,"_DEFAULT_KEYWORD_",n_rep_val=ndum) ! ss_history, delta_s_history, ww_history, invdt_history : deallocate and reallocate with the proper size DEALLOCATE(ss_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(delta_s_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(ww_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) IF (wtcontrol) THEN DEALLOCATE(invdt_history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ENDIF ! - CPPostcondition(n_hills==ndum,cp_failure_level,routinep,error,failure) + CPPostcondition(n_hills==ndum,cp_failure_level,routinep,failure) ALLOCATE(ss_history(n_colvar,n_hills), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(delta_s_history(n_colvar,n_hills), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(ww_history(n_hills), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) IF (wtcontrol) THEN ALLOCATE(invdt_history(n_hills), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ENDIF ! DO i = 1, n_hills CALL section_vals_val_get(hills_history,"_DEFAULT_KEYWORD_",& - i_rep_val=i, r_vals=rvals, error=error) - CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,error,failure) + i_rep_val=i, r_vals=rvals) + CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,failure) ss_history(1:n_colvar,i)=rvals END DO ! - hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_SCALE",error=error) - CALL section_vals_get(hills_history, explicit=explicit, error=error) + hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_SCALE") + CALL section_vals_get(hills_history, explicit=explicit) IF (explicit) THEN ! delta_s_history - CALL section_vals_val_get( hills_history,"_DEFAULT_KEYWORD_",n_rep_val=ndum, error=error) - CPPostcondition(n_hills==ndum,cp_failure_level,routinep,error,failure) + CALL section_vals_val_get( hills_history,"_DEFAULT_KEYWORD_",n_rep_val=ndum) + CPPostcondition(n_hills==ndum,cp_failure_level,routinep,failure) DO i = 1, n_hills CALL section_vals_val_get(hills_history,"_DEFAULT_KEYWORD_",& - i_rep_val=i, r_vals=rvals, error=error) - CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,error,failure) + i_rep_val=i, r_vals=rvals) + CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,failure) delta_s_history(1:n_colvar,i)=rvals END DO ELSE @@ -864,17 +849,17 @@ SUBROUTINE restart_hills(ss_history, delta_s_history, ww_history, ww,& END DO END IF ! - hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_HEIGHT",error=error) - CALL section_vals_get(hills_history, explicit=explicit, error=error) + hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_HEIGHT") + CALL section_vals_get(hills_history, explicit=explicit) IF (explicit) THEN ! ww_history CALL section_vals_val_get( hills_history,"_DEFAULT_KEYWORD_",& - n_rep_val=ndum, error=error) - CPPostcondition(n_hills==ndum,cp_failure_level,routinep,error,failure) + n_rep_val=ndum) + CPPostcondition(n_hills==ndum,cp_failure_level,routinep,failure) DO i = 1, n_hills CALL section_vals_val_get(hills_history,"_DEFAULT_KEYWORD_",& - i_rep_val=i, r_val=rval, error=error) - CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,error,failure) + i_rep_val=i, r_val=rval) + CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,failure) ww_history(i)=rval END DO ELSE @@ -886,18 +871,18 @@ SUBROUTINE restart_hills(ss_history, delta_s_history, ww_history, ww,& ww_history = ww END IF ! - hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_INVDT",error=error) - CALL section_vals_get(hills_history, explicit=explicit, error=error) + hills_history => section_vals_get_subs_vals(metadyn_section,"SPAWNED_HILLS_INVDT") + CALL section_vals_get(hills_history, explicit=explicit) IF (wtcontrol) THEN IF (explicit) THEN ! invdt_history CALL section_vals_val_get( hills_history,"_DEFAULT_KEYWORD_",& - n_rep_val=ndum, error=error) - CPPostcondition(n_hills==ndum,cp_failure_level,routinep,error,failure) + n_rep_val=ndum) + CPPostcondition(n_hills==ndum,cp_failure_level,routinep,failure) DO i = 1, n_hills CALL section_vals_val_get(hills_history,"_DEFAULT_KEYWORD_",& - i_rep_val=i, r_val=rval, error=error) - CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,error,failure) + i_rep_val=i, r_val=rval) + CPPostcondition(SIZE(rvals)==n_colvar,cp_failure_level,routinep,failure) invdt_history(i)=rval END DO ELSE @@ -927,13 +912,11 @@ END SUBROUTINE restart_hills !> \brief Retrieves the iteration level for the metadynamics loop !> \param meta_env ... !> \param iter_nr ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2008 ! ***************************************************************************** - SUBROUTINE get_meta_iter_level(meta_env, iter_nr, error) + SUBROUTINE get_meta_iter_level(meta_env, iter_nr) TYPE(meta_env_type), POINTER :: meta_env INTEGER, INTENT(OUT) :: iter_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_meta_iter_level', & routineP = moduleN//':'//routineN @@ -949,14 +932,12 @@ END SUBROUTINE get_meta_iter_level ! ***************************************************************************** !> \brief ... !> \param meta_env ... -!> \param error ... !> \par History !> 11.2007 [created] [tlaino] !> \author Teodoro Laino - University of Zurich - 11.2007 ! ***************************************************************************** - SUBROUTINE meta_walls(meta_env,error) + SUBROUTINE meta_walls(meta_env) TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'meta_walls', & routineP = moduleN//':'//routineN diff --git a/src/minimax.F b/src/minimax.F index 9dbdc6d138..c4f5a2d7cc 100644 --- a/src/minimax.F +++ b/src/minimax.F @@ -94,15 +94,13 @@ END SUBROUTINE check_range !> \param Rc ... !> \param aw ... !> \param ierr ... -!> \param error ... !> \author Mauro Del Ben ! ***************************************************************************** - SUBROUTINE get_minimax_coeff(k,Rc,aw,ierr,error) + SUBROUTINE get_minimax_coeff(k,Rc,aw,ierr) INTEGER :: k REAL(KIND=dp) :: Rc REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: aw INTEGER :: ierr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_minimax_coeff', & routineP = moduleN//':'//routineN diff --git a/src/minimax_rpa.F b/src/minimax_rpa.F index d3528f0503..425b87688a 100644 --- a/src/minimax_rpa.F +++ b/src/minimax_rpa.F @@ -34,15 +34,13 @@ MODULE minimax_rpa !> \param E_range ... !> \param aw ... !> \param ierr ... -!> \param error ... !> \author Mauro Del Ben ! ***************************************************************************** - SUBROUTINE get_rpa_minimax_coeff(k,E_range,aw,ierr,error) + SUBROUTINE get_rpa_minimax_coeff(k,E_range,aw,ierr) INTEGER :: k REAL(KIND=dp) :: E_range REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: aw INTEGER :: ierr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_rpa_minimax_coeff', & routineP = moduleN//':'//routineN @@ -114,20 +112,20 @@ SUBROUTINE get_rpa_minimax_coeff(k,E_range,aw,ierr,error) "for the required number of quadrature points. The Minimax parameters "//& "have been optimized for the lower bound of: ",TRIM(Rc_cha) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& - error_msg,error,only_ionode=.TRUE.) + error_msg,only_ionode=.TRUE.) END IF IF( E_range > Rc ) THEN WRITE(error_msg,'(A,A)') " The range for the Minimax approximation exceeds the upper bound "//& "for the required number of quadrature points. The Minimax parameters "//& "have been optimized for the upper bound of: ",TRIM(Rc_cha) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& - error_msg,error,only_ionode=.TRUE.) + error_msg,only_ionode=.TRUE.) END IF IF( ierr < 0 ) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "The required number of quadrature point exceeds the maximum available. "//& "The number of quadrature point has been reset to 20.", & - error,only_ionode=.TRUE.) + only_ionode=.TRUE.) END IF R_transf=SQRT(L_b/Rc) diff --git a/src/mixed_energy_types.F b/src/mixed_energy_types.F index adcfcba506..87b18f0217 100644 --- a/src/mixed_energy_types.F +++ b/src/mixed_energy_types.F @@ -42,14 +42,12 @@ MODULE mixed_energy_types ! ***************************************************************************** !> \brief Allocate and/or initialise a mixed energy data structure. !> \param mixed_energy ... -!> \param error ... !> \date 11.06 !> \author fschiff !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_mixed_energy(mixed_energy, error) + SUBROUTINE allocate_mixed_energy(mixed_energy) TYPE(mixed_energy_type), POINTER :: mixed_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_mixed_energy', & routineP = moduleN//':'//routineN @@ -60,7 +58,7 @@ SUBROUTINE allocate_mixed_energy(mixed_energy, error) failure = .FALSE. IF (.NOT.ASSOCIATED(mixed_energy)) THEN ALLOCATE (mixed_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL init_mixed_energy(mixed_energy) END SUBROUTINE allocate_mixed_energy @@ -68,14 +66,12 @@ END SUBROUTINE allocate_mixed_energy ! ***************************************************************************** !> \brief Deallocate a mixed energy data structure. !> \param mixed_energy ... -!> \param error ... !> \date 11.06 !> \author fschiff !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_mixed_energy(mixed_energy, error) + SUBROUTINE deallocate_mixed_energy(mixed_energy) TYPE(mixed_energy_type), POINTER :: mixed_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_mixed_energy', & routineP = moduleN//':'//routineN @@ -86,7 +82,7 @@ SUBROUTINE deallocate_mixed_energy(mixed_energy, error) failure = .FALSE. IF (ASSOCIATED(mixed_energy)) THEN DEALLOCATE (mixed_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_mixed_energy diff --git a/src/mixed_environment.F b/src/mixed_environment.F index 6d10dcf542..3a283d59ac 100644 --- a/src/mixed_environment.F +++ b/src/mixed_environment.F @@ -53,20 +53,18 @@ MODULE mixed_environment !> \param para_env ... !> \param force_env_section ... !> \param use_motion_section ... -!> \param error ... !> \par Used By !> mixed_main !> \author fschiff ! ***************************************************************************** SUBROUTINE mixed_init ( mixed_env, root_section,para_env, force_env_section,& - use_motion_section, error ) + use_motion_section) TYPE(mixed_environment_type), POINTER :: mixed_env TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: force_env_section LOGICAL, INTENT(IN) :: use_motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixed_init', & routineP = moduleN//':'//routineN @@ -84,27 +82,27 @@ SUBROUTINE mixed_init ( mixed_env, root_section,para_env, force_env_section,& NULLIFY (subsys, cell, cell_ref) NULLIFY ( cell_section) - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) - cell_section => section_vals_get_subs_vals(subsys_section,"CELL",error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") + cell_section => section_vals_get_subs_vals(subsys_section,"CELL") - CALL set_mixed_env(mixed_env,input=force_env_section,error=error) + CALL set_mixed_env(mixed_env,input=force_env_section) CALL cp_subsys_create(subsys, para_env, root_section,& force_env_section=force_env_section,& - use_motion_section=use_motion_section, error=error) + use_motion_section=use_motion_section) CALL read_cell( cell, cell_ref, use_ref_cell = use_ref_cell, & - cell_section=cell_section, para_env=para_env, error=error) + cell_section=cell_section, para_env=para_env) CALL get_cell (cell, abc=abc) ! Print the cell parameters *** - CALL write_cell ( cell, subsys_section, cell_ref, error=error) + CALL write_cell ( cell, subsys_section, cell_ref) CALL mixed_init_subsys ( mixed_env, subsys, cell, cell_ref, & - force_env_section, subsys_section, error ) + force_env_section, subsys_section) - CALL cell_release(cell,error=error) - CALL cell_release(cell_ref,error=error) - CALL cp_subsys_release(subsys,error=error) + CALL cell_release(cell) + CALL cell_release(cell_ref) + CALL cp_subsys_release(subsys) CALL timestop(handle) @@ -119,20 +117,18 @@ END SUBROUTINE mixed_init !> \param cell_ref ... !> \param force_env_section ... !> \param subsys_section ... -!> \param error ... !> \date 11.06 !> \author fschiff !> \version 1.0 ! ***************************************************************************** SUBROUTINE mixed_init_subsys ( mixed_env, subsys, cell, cell_ref, & - force_env_section, subsys_section, error ) + force_env_section, subsys_section) TYPE(mixed_environment_type), POINTER :: mixed_env TYPE(cp_subsys_type), POINTER :: subsys TYPE(cell_type), POINTER :: cell, cell_ref TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixed_init_subsys', & routineP = moduleN//':'//routineN @@ -158,10 +154,10 @@ SUBROUTINE mixed_init_subsys ( mixed_env, subsys, cell, cell_ref, & molecule_kind_set => subsys % molecule_kinds_new % els ! Create the mixed_energy_type - CALL allocate_mixed_energy( mixed_energy, error=error) + CALL allocate_mixed_energy( mixed_energy) ! Print the molecule kind set - CALL write_molecule_kind_set(molecule_kind_set,subsys_section,error) + CALL write_molecule_kind_set(molecule_kind_set,subsys_section) ! Distribute molecules and atoms using the new data structures *** CALL distribute_molecules_1d (atomic_kind_set=atomic_kind_set,& @@ -170,21 +166,20 @@ SUBROUTINE mixed_init_subsys ( mixed_env, subsys, cell, cell_ref, & molecule_kind_set=molecule_kind_set,& molecule_set=molecule_set,& local_molecules=local_molecules,& - force_env_section=force_env_section,& - error=error ) + force_env_section=force_env_section) - CALL cp_subsys_set(subsys, cell=cell, error=error) + CALL cp_subsys_set(subsys, cell=cell) ! set the mixed_env - CALL set_mixed_env ( mixed_env = mixed_env, subsys = subsys, error = error ) + CALL set_mixed_env ( mixed_env = mixed_env, subsys = subsys) CALL set_mixed_env ( mixed_env=mixed_env,& cell_ref=cell_ref, & local_molecules=local_molecules,& local_particles=local_particles,& - mixed_energy=mixed_energy ,error=error) + mixed_energy=mixed_energy) - CALL distribution_1d_release ( local_particles, error = error ) - CALL distribution_1d_release ( local_molecules, error = error ) + CALL distribution_1d_release ( local_particles) + CALL distribution_1d_release ( local_molecules) CALL timestop(handle) diff --git a/src/mixed_environment_types.F b/src/mixed_environment_types.F index 38ec448ab8..66f09b7810 100644 --- a/src/mixed_environment_types.F +++ b/src/mixed_environment_types.F @@ -121,13 +121,12 @@ MODULE mixed_environment_types !> \param subsys ... !> \param input ... !> \param results ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_mixed_env( mixed_env, atomic_kind_set, particle_set, & local_particles, local_molecules, molecule_kind_set, & molecule_set, cell, cell_ref, & mixed_energy, para_env, sub_para_env, subsys, & - input, results, error ) + input, results) TYPE(mixed_environment_type), INTENT(IN) :: mixed_env TYPE(atomic_kind_type), OPTIONAL, & @@ -150,7 +149,6 @@ SUBROUTINE get_mixed_env( mixed_env, atomic_kind_set, particle_set, & TYPE(section_vals_type), OPTIONAL, & POINTER :: input TYPE(cp_result_type), OPTIONAL, POINTER :: results - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_mixed_env', & routineP = moduleN//':'//routineN @@ -163,7 +161,7 @@ SUBROUTINE get_mixed_env( mixed_env, atomic_kind_set, particle_set, & failure=.FALSE. NULLIFY( atomic_kinds, particles, molecules_new, molecule_kinds_new ) - CPPrecondition(ASSOCIATED(mixed_env%subsys),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixed_env%subsys),cp_failure_level,routineP,failure) IF ( PRESENT ( input ) ) input => mixed_env%input IF ( PRESENT ( cell_ref ) ) cell_ref => mixed_env % cell_ref @@ -179,8 +177,7 @@ SUBROUTINE get_mixed_env( mixed_env, atomic_kind_set, particle_set, & molecule_kinds_new=molecule_kinds_new,& molecules_new=molecules_new,& results=results,& - cell=cell,& - error=error) + cell=cell) IF (PRESENT(atomic_kind_set)) atomic_kind_set => atomic_kinds%els IF (PRESENT(particle_set)) particle_set => particles%els IF (PRESENT(molecule_kind_set)) molecule_kind_set => molecule_kinds_new%els @@ -192,14 +189,12 @@ END SUBROUTINE get_mixed_env !> \brief Initialise the MIXED environment. !> \param mixed_env the pointer to the mixed_env !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_mixed_env ( mixed_env, para_env, error ) + SUBROUTINE init_mixed_env ( mixed_env, para_env) TYPE(mixed_environment_type), & INTENT(OUT) :: mixed_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error NULLIFY (mixed_env%input) NULLIFY (mixed_env%cell_ref) @@ -211,7 +206,7 @@ SUBROUTINE init_mixed_env ( mixed_env, para_env, error ) NULLIFY (mixed_env%par) NULLIFY (mixed_env%val) NULLIFY (mixed_env%subsys) - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) mixed_env%para_env => para_env mixed_env%ref_count=1 last_mixed_env_id_nr=last_mixed_env_id_nr+1 @@ -233,12 +228,11 @@ END SUBROUTINE init_mixed_env !> \param subsys ... !> \param input ... !> \param sub_para_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_mixed_env( mixed_env, atomic_kind_set, particle_set, & local_particles, local_molecules, molecule_kind_set, & molecule_set, cell_ref, mixed_energy, subsys, & - input, sub_para_env, error ) + input, sub_para_env) TYPE(mixed_environment_type), POINTER :: mixed_env TYPE(atomic_kind_type), OPTIONAL, & @@ -258,7 +252,6 @@ SUBROUTINE set_mixed_env( mixed_env, atomic_kind_set, particle_set, & POINTER :: input TYPE(cp_para_env_p_type), DIMENSION(:), & OPTIONAL, POINTER :: sub_para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_mixed_env', & routineP = moduleN//':'//routineN @@ -270,22 +263,22 @@ SUBROUTINE set_mixed_env( mixed_env, atomic_kind_set, particle_set, & TYPE(particle_list_type), POINTER :: particles failure=.FALSE. - CPPrecondition(mixed_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(mixed_env%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(cell_ref)) THEN - CALL cell_retain(cell_ref, error=error) - CALL cell_release(mixed_env%cell_ref,error=error) + CALL cell_retain(cell_ref) + CALL cell_release(mixed_env%cell_ref) mixed_env%cell_ref => cell_ref END IF IF (PRESENT(input)) THEN - CALL section_vals_retain(input,error=error) - CALL section_vals_release(mixed_env%input,error=error) + CALL section_vals_retain(input) + CALL section_vals_release(mixed_env%input) mixed_env%input => input END IF IF ( PRESENT ( mixed_energy ) ) mixed_env % mixed_energy => mixed_energy IF (PRESENT(subsys)) THEN - CALL cp_subsys_retain(subsys,error=error) - CALL cp_subsys_release(mixed_env%subsys,error=error) + CALL cp_subsys_retain(subsys) + CALL cp_subsys_release(mixed_env%subsys) mixed_env%subsys => subsys END IF IF (PRESENT(sub_para_env)) THEN @@ -293,49 +286,39 @@ SUBROUTINE set_mixed_env( mixed_env, atomic_kind_set, particle_set, & END IF IF (PRESENT(atomic_kind_set)) THEN CALL atomic_kind_list_create(atomic_kinds,& - els_ptr=atomic_kind_set,& - error=error) + els_ptr=atomic_kind_set) CALL cp_subsys_set(mixed_env%subsys,& - atomic_kinds=atomic_kinds,& - error=error) - CALL atomic_kind_list_release(atomic_kinds,error=error) + atomic_kinds=atomic_kinds) + CALL atomic_kind_list_release(atomic_kinds) END IF IF (PRESENT(particle_set)) THEN CALL particle_list_create(particles,& - els_ptr=particle_set,& - error=error) + els_ptr=particle_set) CALL cp_subsys_set(mixed_env%subsys,& - particles=particles,& - error=error) - CALL particle_list_release(particles,error=error) + particles=particles) + CALL particle_list_release(particles) END IF IF (PRESENT(local_particles)) THEN CALL cp_subsys_set(mixed_env%subsys,& - local_particles=local_particles,& - error=error) + local_particles=local_particles) END IF IF (PRESENT(local_molecules)) THEN CALL cp_subsys_set(mixed_env%subsys,& - local_molecules_new=local_molecules,& - error=error) + local_molecules_new=local_molecules) END IF IF (PRESENT(molecule_kind_set)) THEN CALL mol_kind_new_list_create(molecule_kinds_new,& - els_ptr=molecule_kind_set,& - error=error) + els_ptr=molecule_kind_set) CALL cp_subsys_set(mixed_env%subsys,& - molecule_kinds_new=molecule_kinds_new,& - error=error) - CALL mol_kind_new_list_release(molecule_kinds_new,error=error) + molecule_kinds_new=molecule_kinds_new) + CALL mol_kind_new_list_release(molecule_kinds_new) END IF IF (PRESENT(molecule_set)) THEN CALL mol_new_list_create(molecules_new,& - els_ptr=molecule_set,& - error=error) + els_ptr=molecule_set) CALL cp_subsys_set(mixed_env%subsys,& - molecules_new=molecules_new,& - error=error) - CALL mol_new_list_release(molecules_new,error=error) + molecules_new=molecules_new) + CALL mol_new_list_release(molecules_new) END IF END SUBROUTINE set_mixed_env @@ -344,14 +327,11 @@ END SUBROUTINE set_mixed_env !> \brief allocates and intitializes a mixed_env !> \param mixed_env the object to create !> \param para_env the parallel environement for the qs_env -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff 11.06 ! ***************************************************************************** - SUBROUTINE mixed_env_create(mixed_env,para_env,error) + SUBROUTINE mixed_env_create(mixed_env,para_env) TYPE(mixed_environment_type), POINTER :: mixed_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixed_env_create', & routineP = moduleN//':'//routineN @@ -362,20 +342,17 @@ SUBROUTINE mixed_env_create(mixed_env,para_env,error) failure=.FALSE. ALLOCATE(mixed_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL init_mixed_env(mixed_env,para_env=para_env, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL init_mixed_env(mixed_env,para_env=para_env) END SUBROUTINE mixed_env_create ! ***************************************************************************** !> \brief retains the given mixed_env (see doc/ReferenceCounting.html) !> \param mixed_env the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff 11.06 ! ***************************************************************************** - SUBROUTINE mixed_env_retain(mixed_env,error) + SUBROUTINE mixed_env_retain(mixed_env) TYPE(mixed_environment_type), POINTER :: mixed_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixed_env_retain', & routineP = moduleN//':'//routineN @@ -384,21 +361,18 @@ SUBROUTINE mixed_env_retain(mixed_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(mixed_env),cp_failure_level,routineP,error,failure) - CPPrecondition(mixed_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixed_env),cp_failure_level,routineP,failure) + CPPrecondition(mixed_env%ref_count>0,cp_failure_level,routineP,failure) mixed_env%ref_count=mixed_env%ref_count+1 END SUBROUTINE mixed_env_retain ! ***************************************************************************** !> \brief releases the given mixed_env (see doc/ReferenceCounting.html) !> \param mixed_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff 11.06 ! ***************************************************************************** - SUBROUTINE mixed_env_release(mixed_env,error) + SUBROUTINE mixed_env_release(mixed_env) TYPE(mixed_environment_type), POINTER :: mixed_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixed_env_release', & routineP = moduleN//':'//routineN @@ -409,41 +383,41 @@ SUBROUTINE mixed_env_release(mixed_env,error) failure=.FALSE. IF (ASSOCIATED(mixed_env)) THEN - CPPrecondition(mixed_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(mixed_env%ref_count>0,cp_failure_level,routineP,failure) mixed_env%ref_count=mixed_env%ref_count-1 IF (mixed_env%ref_count<1) THEN ngroups = SIZE(mixed_env%sub_para_env) DO i = 1, ngroups IF (ASSOCIATED(mixed_env%sub_para_env(i)%para_env)) THEN CALL cp_logger_release(mixed_env%sub_logger(i)%p) - CALL cp_para_env_release(mixed_env%sub_para_env(i)%para_env,error=error) + CALL cp_para_env_release(mixed_env%sub_para_env(i)%para_env) END IF END DO DEALLOCATE(mixed_env%sub_para_env, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mixed_env%sub_logger, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mixed_env%energies, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(mixed_env%par)) THEN DEALLOCATE(mixed_env%par, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(mixed_env%val)) THEN DEALLOCATE(mixed_env%val, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL cell_release(mixed_env%cell_ref,error=error) - CALL cp_para_env_release(mixed_env%para_env,error=error) - CALL deallocate_mixed_energy(mixed_env%mixed_energy,error=error) - CALL cp_subsys_release(mixed_env%subsys,error=error) - CALL section_vals_release(mixed_env%input,error=error) + CALL cell_release(mixed_env%cell_ref) + CALL cp_para_env_release(mixed_env%para_env) + CALL deallocate_mixed_energy(mixed_env%mixed_energy) + CALL cp_subsys_release(mixed_env%subsys) + CALL section_vals_release(mixed_env%input) IF (ASSOCIATED(mixed_env%group_distribution)) THEN DEALLOCATE(mixed_env%group_distribution, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(mixed_env, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END IF NULLIFY(mixed_env) diff --git a/src/mixed_environment_utils.F b/src/mixed_environment_utils.F index fb91d26239..7fcbd8ea1c 100644 --- a/src/mixed_environment_utils.F +++ b/src/mixed_environment_utils.F @@ -53,13 +53,11 @@ MODULE mixed_environment_utils !> \param map_index ... !> \param mapping_section ... !> \param overwrite ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino - University of Zurich [tlaino] - 05.2007 ! ***************************************************************************** SUBROUTINE mixed_map_forces(particles_mix, virial_mix, results_mix, global_forces,& virials, results, factor, iforce_eval, nforce_eval, map_index,& - mapping_section, overwrite, error) + mapping_section, overwrite) TYPE(particle_list_type), POINTER :: particles_mix TYPE(virial_type), POINTER :: virial_mix @@ -75,7 +73,6 @@ SUBROUTINE mixed_map_forces(particles_mix, virial_mix, results_mix, global_force INTEGER, DIMENSION(:), POINTER :: map_index TYPE(section_vals_type), POINTER :: mapping_section LOGICAL, INTENT(IN) :: overwrite - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixed_map_forces', & routineP = moduleN//':'//routineN @@ -89,7 +86,7 @@ SUBROUTINE mixed_map_forces(particles_mix, virial_mix, results_mix, global_force failure = .FALSE. ! Get Mapping index array natom = SIZE(global_forces(iforce_eval)%forces,2) - CALL get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, map_index, error) + CALL get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, map_index) DO iparticle = 1, natom jparticle = map_index(iparticle) IF (overwrite) THEN @@ -112,25 +109,25 @@ SUBROUTINE mixed_map_forces(particles_mix, virial_mix, results_mix, global_force ! Deallocate map_index array IF (ASSOCIATED(map_index)) THEN DEALLOCATE(map_index, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ! Collect Requested Results info description = '[DIPOLE]' - IF (overwrite) CALL cp_results_erase(results_mix, error=error) + IF (overwrite) CALL cp_results_erase(results_mix) - dip_exists = test_for_result(results=results(iforce_eval)%results,description=description, error=error) + dip_exists = test_for_result(results=results(iforce_eval)%results,description=description) IF (dip_exists) THEN - CALL get_results(results=results_mix,description=description,n_rep=nres,error=error) - CPPrecondition(nres<=1,cp_failure_level,routineP,error,failure) + CALL get_results(results=results_mix,description=description,n_rep=nres) + CPPrecondition(nres<=1,cp_failure_level,routineP,failure) dip_mix = 0.0_dp - IF (nres==1) CALL get_results(results=results_mix,description=description,values=dip_mix,error=error) - CALL get_results(results=results(iforce_eval)%results,description=description,n_rep=nres,error=error) + IF (nres==1) CALL get_results(results=results_mix,description=description,values=dip_mix) + CALL get_results(results=results(iforce_eval)%results,description=description,n_rep=nres) CALL get_results(results=results(iforce_eval)%results,description=description,& - values=dip_tmp,nval=nres,error=error) + values=dip_tmp,nval=nres) dip_mix = dip_mix + factor*dip_tmp - CALL cp_results_erase(results=results_mix,description=description,error=error) - CALL put_results(results=results_mix,description=description,values=dip_mix,error=error) + CALL cp_results_erase(results=results_mix,description=description) + CALL put_results(results=results_mix,description=description,values=dip_mix) END IF END SUBROUTINE mixed_map_forces @@ -142,17 +139,14 @@ END SUBROUTINE mixed_map_forces !> \param iforce_eval ... !> \param nforce_eval ... !> \param map_index ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino - University of Zurich [tlaino] - 05.2007 ! ***************************************************************************** - SUBROUTINE get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, map_index, error) + SUBROUTINE get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval, map_index) TYPE(section_vals_type), POINTER :: mapping_section INTEGER, INTENT(IN) :: natom, iforce_eval, & nforce_eval INTEGER, DIMENSION(:), POINTER :: map_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_subsys_map_index', & routineP = moduleN//':'//routineN @@ -166,10 +160,10 @@ SUBROUTINE get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval map_force_ev, map_full_sys failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(map_index),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(map_index),cp_failure_level,routineP,failure) ALLOCATE(map_index(natom),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL section_vals_get(mapping_section, explicit=explicit, error=error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL section_vals_get(mapping_section, explicit=explicit) IF (.NOT.explicit) THEN ! Standard Mapping.. subsys are assumed to have the same structure DO i = 1, natom @@ -177,67 +171,65 @@ SUBROUTINE get_subsys_map_index(mapping_section, natom, iforce_eval, nforce_eval END DO ELSE ! Mapping systems with different structures - map_full_sys => section_vals_get_subs_vals(mapping_section,"FORCE_EVAL_MIXED",error=error) - map_force_ev => section_vals_get_subs_vals(mapping_section,"FORCE_EVAL",error=error) - CALL section_vals_get(map_full_sys, explicit=explicit, error=error) - CPPrecondition(explicit,cp_failure_level,routineP,error,failure) - CALL section_vals_get(map_force_ev, explicit=explicit, n_repetition=n_rep, error=error) - CPPrecondition(explicit,cp_failure_level,routineP,error,failure) - CPPrecondition(n_rep==nforce_eval,cp_failure_level,routineP,error,failure) + map_full_sys => section_vals_get_subs_vals(mapping_section,"FORCE_EVAL_MIXED") + map_force_ev => section_vals_get_subs_vals(mapping_section,"FORCE_EVAL") + CALL section_vals_get(map_full_sys, explicit=explicit) + CPPrecondition(explicit,cp_failure_level,routineP,failure) + CALL section_vals_get(map_force_ev, explicit=explicit, n_repetition=n_rep) + CPPrecondition(explicit,cp_failure_level,routineP,failure) + CPPrecondition(n_rep==nforce_eval,cp_failure_level,routineP,failure) DO i = 1, n_rep - CALL section_vals_val_get(map_force_ev,"_SECTION_PARAMETERS_",i_rep_section=i,i_val=ival,error=error) + CALL section_vals_val_get(map_force_ev,"_SECTION_PARAMETERS_",i_rep_section=i,i_val=ival) IF (ival==iforce_eval) EXIT END DO - CPPrecondition(i<=nforce_eval,cp_failure_level,routineP,error,failure) - fragments_sys => section_vals_get_subs_vals(map_full_sys,"FRAGMENT",error=error) - fragments_loc => section_vals_get_subs_vals(map_force_ev,"FRAGMENT",i_rep_section=i,error=error) + CPPrecondition(i<=nforce_eval,cp_failure_level,routineP,failure) + fragments_sys => section_vals_get_subs_vals(map_full_sys,"FRAGMENT") + fragments_loc => section_vals_get_subs_vals(map_force_ev,"FRAGMENT",i_rep_section=i) !Perform few check on the structure of the input mapping section. as provided by the user - CALL section_vals_get(fragments_loc, n_repetition=n_rep_loc, error=error) - CALL section_vals_get(fragments_sys, explicit=explicit, n_repetition=n_rep_sys, error=error) - CPPrecondition(explicit,cp_failure_level,routineP,error,failure) - CPPrecondition(n_rep_sys>=n_rep_loc,cp_failure_level,routineP,error,failure) + CALL section_vals_get(fragments_loc, n_repetition=n_rep_loc) + CALL section_vals_get(fragments_sys, explicit=explicit, n_repetition=n_rep_sys) + CPPrecondition(explicit,cp_failure_level,routineP,failure) + CPPrecondition(n_rep_sys>=n_rep_loc,cp_failure_level,routineP,failure) IF (n_rep_loc==0) THEN NULLIFY(list) ! We expect an easier syntax in this case.. - CALL section_vals_val_get(map_force_ev,"DEFINE_FRAGMENTS",i_rep_section=i,n_rep_val=n_rep_map,& - error=error) + CALL section_vals_val_get(map_force_ev,"DEFINE_FRAGMENTS",i_rep_section=i,n_rep_val=n_rep_map) check = (n_rep_map/=0) - CPPrecondition(check,cp_failure_level,routineP,error,failure) - CALL section_vals_val_get(map_force_ev,"DEFINE_FRAGMENTS",i_rep_section=i,i_vals=list,& - error=error) - CPPrecondition(SIZE(list)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) + CALL section_vals_val_get(map_force_ev,"DEFINE_FRAGMENTS",i_rep_section=i,i_vals=list) + CPPrecondition(SIZE(list)>0,cp_failure_level,routineP,failure) iatom = 0 DO i = 1, SIZE(list) jval = list(i) DO j = 1, n_rep_sys - CALL section_vals_val_get(fragments_sys,"_SECTION_PARAMETERS_",i_rep_section=j,i_val=tmp,error=error) + CALL section_vals_val_get(fragments_sys,"_SECTION_PARAMETERS_",i_rep_section=j,i_val=tmp) IF (tmp==jval) EXIT END DO - CALL section_vals_val_get(fragments_sys,"_DEFAULT_KEYWORD_",i_rep_section=j,i_vals=index_glo,error=error) + CALL section_vals_val_get(fragments_sys,"_DEFAULT_KEYWORD_",i_rep_section=j,i_vals=index_glo) DO k = 0, index_glo(2)-index_glo(1) iatom = iatom + 1 - CPPrecondition(iatom<=natom,cp_failure_level,routineP,error,failure) + CPPrecondition(iatom<=natom,cp_failure_level,routineP,failure) map_index(iatom) = index_glo(1)+k END DO END DO check = (iatom==natom) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) ELSE ! General syntax.. !Loop over the fragment of the force_eval DO i = 1, n_rep_loc - CALL section_vals_val_get(fragments_loc,"_SECTION_PARAMETERS_",i_rep_section=i,i_val=ival,error=error) - CALL section_vals_val_get(fragments_loc,"MAP",i_rep_section=i,i_val=jval,error=error) + CALL section_vals_val_get(fragments_loc,"_SECTION_PARAMETERS_",i_rep_section=i,i_val=ival) + CALL section_vals_val_get(fragments_loc,"MAP",i_rep_section=i,i_val=jval) ! Index corresponding to the mixed_force_eval fragment DO j = 1, n_rep_sys - CALL section_vals_val_get(fragments_sys,"_SECTION_PARAMETERS_",i_rep_section=j,i_val=tmp,error=error) + CALL section_vals_val_get(fragments_sys,"_SECTION_PARAMETERS_",i_rep_section=j,i_val=tmp) IF (tmp==jval) EXIT END DO - CPPrecondition(j<=n_rep_sys,cp_failure_level,routineP,error,failure) - CALL section_vals_val_get(fragments_loc,"_DEFAULT_KEYWORD_",i_rep_section=i,i_vals=index_loc,error=error) - CALL section_vals_val_get(fragments_sys,"_DEFAULT_KEYWORD_",i_rep_section=j,i_vals=index_glo,error=error) + CPPrecondition(j<=n_rep_sys,cp_failure_level,routineP,failure) + CALL section_vals_val_get(fragments_loc,"_DEFAULT_KEYWORD_",i_rep_section=i,i_vals=index_loc) + CALL section_vals_val_get(fragments_sys,"_DEFAULT_KEYWORD_",i_rep_section=j,i_vals=index_glo) check = ((index_loc(2)-index_loc(1))==(index_glo(2)-index_glo(1))) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) ! Now let's build the real mapping DO k = 0, index_loc(2)-index_loc(1) map_index(index_loc(1)+k) = index_glo(1)+k diff --git a/src/mixed_main.F b/src/mixed_main.F index 3d79c336c4..858dc4ab99 100644 --- a/src/mixed_main.F +++ b/src/mixed_main.F @@ -42,11 +42,10 @@ MODULE mixed_main !> \param force_env_section ... !> \param n_subforce_eval ... !> \param use_motion_section ... -!> \param error ... !> \author fschiff ! ***************************************************************************** SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& - force_env_section, n_subforce_eval, use_motion_section, error ) + force_env_section, n_subforce_eval, use_motion_section) TYPE(mixed_environment_type), POINTER :: mixed_env TYPE(section_vals_type), POINTER :: root_section @@ -54,7 +53,6 @@ SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& TYPE(section_vals_type), POINTER :: force_env_section INTEGER, INTENT(IN) :: n_subforce_eval LOGICAL, INTENT(IN) :: use_motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mixed_create_force_env', & routineP = moduleN//':'//routineN @@ -71,31 +69,27 @@ SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& failure = .FALSE. CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,force_env_section,"MIXED%PRINT%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") - CALL mixed_env_create( mixed_env, para_env = para_env, error=error) + CALL mixed_env_create( mixed_env, para_env = para_env) ! Setup the new parallel env NULLIFY(group_partition) group_size_wish_set=.FALSE. ngroup_wish_set =.FALSE. - CALL section_vals_val_get(force_env_section,"MIXED%GROUP_PARTITION",n_rep_val=n_rep_val,& - error=error) + CALL section_vals_val_get(force_env_section,"MIXED%GROUP_PARTITION",n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CALL section_vals_val_get(force_env_section,"MIXED%GROUP_PARTITION",i_vals=i_vals,& - error=error) + CALL section_vals_val_get(force_env_section,"MIXED%GROUP_PARTITION",i_vals=i_vals) ALLOCATE(group_partition(0:SIZE(i_vals)-1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) group_partition(:)=i_vals ngroup_wish_set=.TRUE. ngroup_wish=SIZE(i_vals) ELSE - CALL section_vals_val_get(force_env_section,"MIXED%NGROUPS",n_rep_val=n_rep_val,& - error=error) + CALL section_vals_val_get(force_env_section,"MIXED%NGROUPS",n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CALL section_vals_val_get(force_env_section,"MIXED%NGROUPS",i_val=ngroup_wish,& - error=error) + CALL section_vals_val_get(force_env_section,"MIXED%NGROUPS",i_val=ngroup_wish) ELSE ngroup_wish = n_subforce_eval END IF @@ -105,7 +99,7 @@ SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& ! Split the current communicator ALLOCATE(mixed_env%group_distribution(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (group_size_wish_set) THEN CALL mp_comm_split(para_env%group,mixed_env%new_group,mixed_env%ngroups,mixed_env%group_distribution,& subgroup_min_size=group_size_wish) @@ -114,7 +108,7 @@ SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& n_subgroups=ngroup_wish,& group_partition=group_partition) ENDIF - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (output_unit>0) THEN WRITE(output_unit,FMT="(T2,A,T71,I10)") "MIXED_ENV| Number of created MPI groups:",mixed_env%ngroups WRITE(output_unit,FMT="(T2,A)",ADVANCE="NO") "MIXED_ENV| Task to group correspondence:" @@ -127,15 +121,15 @@ SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& ENDIF IF (ASSOCIATED(group_partition)) THEN DEALLOCATE(group_partition,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Allocate para_env and handle the several loggers ALLOCATE(mixed_env%sub_para_env(mixed_env%ngroups),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixed_env%sub_logger(mixed_env%ngroups),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixed_env%energies(n_subforce_eval),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! DO i = 1, mixed_env%ngroups NULLIFY(mixed_env%sub_para_env(i)%para_env,logger) @@ -143,12 +137,12 @@ SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& ! Create sub_para_env CALL cp_para_env_create(mixed_env%sub_para_env(i)%para_env,& group=mixed_env%new_group,& - owns_group=.TRUE.,error=error) + owns_group=.TRUE.) ! Create sub_logger IF (mixed_env%sub_para_env(i)%para_env%mepos==mixed_env%sub_para_env(i)%para_env%source) THEN ! Redirecting output of subforce_eval to file.. CALL section_vals_val_get(root_section,"GLOBAL%PROJECT_NAME",& - c_val=input_file_path,error=error) + c_val=input_file_path) lp=LEN_TRIM(input_file_path) input_file_path(lp+1:LEN(input_file_path))="-r-"//& ADJUSTL(cp_to_string(i)) @@ -166,27 +160,27 @@ SUBROUTINE mixed_create_force_env ( mixed_env, root_section, para_env,& close_global_unit_on_dealloc=.FALSE.) ! Try to use better names for the local log if it is not too late CALL section_vals_val_get(root_section,"GLOBAL%OUTPUT_FILE_NAME",& - c_val=c_val,error=error) + c_val=c_val) IF (c_val/="") THEN CALL cp_logger_set(mixed_env%sub_logger(i)%p,& local_filename=TRIM(c_val)//"_localLog") END IF - CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=c_val,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=c_val) IF (c_val/="") THEN CALL cp_logger_set(mixed_env%sub_logger(i)%p,& local_filename=TRIM(c_val)//"_localLog") END IF mixed_env%sub_logger(i)%p%iter_info%project_name=c_val CALL section_vals_val_get(root_section,"GLOBAL%PRINT_LEVEL",& - i_val=mixed_env%sub_logger(i)%p%iter_info%print_level,error=error) + i_val=mixed_env%sub_logger(i)%p%iter_info%print_level) END IF END DO ! *** initializations for the setup of the MIXED environment *** - CALL set_mixed_env (mixed_env, error=error) + CALL set_mixed_env (mixed_env) CALL mixed_init ( mixed_env, root_section, para_env, force_env_section, & - use_motion_section, error ) + use_motion_section) CALL timestop(handle) END SUBROUTINE mixed_create_force_env diff --git a/src/mm_mapping_library.F b/src/mm_mapping_library.F index 79f21c3b81..72335fc794 100644 --- a/src/mm_mapping_library.F +++ b/src/mm_mapping_library.F @@ -40,15 +40,12 @@ MODULE mm_mapping_library !> \brief Initialize arrays for mapping KINDS <-> ELEMENTS !> for major elements in AMBER and CHARMM !> \param ff_type ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE create_ff_map(ff_type, error) + SUBROUTINE create_ff_map(ff_type) CHARACTER(LEN=*), INTENT(IN) :: ff_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ff_map', & routineP = moduleN//':'//routineN @@ -62,12 +59,12 @@ SUBROUTINE create_ff_map(ff_type, error) SELECT CASE(ff_type) CASE("AMBER") ALLOCATE(amber_map,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! allocate substructures ALLOCATE(amber_map%kind(amb_imax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(amber_map%element(amb_imax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) amber_map%kind=(/& "BR","C ","CA","CB","CC","CK","CM","CN","CQ","CR",& @@ -84,12 +81,12 @@ SUBROUTINE create_ff_map(ff_type, error) CASE("CHARMM") ALLOCATE(charmm_map,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! allocate substructures ALLOCATE(charmm_map%kind(chm_imax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(charmm_map%element(chm_imax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) charmm_map%kind=(/& "CA ","CAL ","C ","CC ","CD ","CE ","CEL ","CES ","CLA ","CL ",& @@ -119,12 +116,12 @@ SUBROUTINE create_ff_map(ff_type, error) CASE("GROMOS") ALLOCATE(gromos_map,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! allocate substructures ALLOCATE(gromos_map%kind(grm_imax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gromos_map%element(grm_imax),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gromos_map%kind=(/& "H1 ","CA ","HA ","SD ","OG ","CG ","HD ","SG ",& @@ -143,15 +140,12 @@ END SUBROUTINE create_ff_map ! ***************************************************************************** !> \brief Deallocates the arrays used for mapping !> \param ff_type ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2006 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE destroy_ff_map(ff_type, error) + SUBROUTINE destroy_ff_map(ff_type) CHARACTER(LEN=*), INTENT(IN) :: ff_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'destroy_ff_map', & routineP = moduleN//':'//routineN @@ -164,30 +158,30 @@ SUBROUTINE destroy_ff_map(ff_type, error) CASE("AMBER") ! deallocate substructures DEALLOCATE(amber_map%kind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(amber_map%element,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! deallocate main DEALLOCATE(amber_map,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE("CHARMM") ! deallocate substructures DEALLOCATE(charmm_map%kind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(charmm_map%element,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! deallocate main DEALLOCATE(charmm_map,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE("GROMOS") ! deallocate substructures DEALLOCATE(gromos_map%kind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gromos_map%element,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! deallocate main DEALLOCATE(gromos_map,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE destroy_ff_map diff --git a/src/mode_selective.F b/src/mode_selective.F index 4da585f671..caa93a7561 100644 --- a/src/mode_selective.F +++ b/src/mode_selective.F @@ -92,11 +92,10 @@ MODULE mode_selective !> \param dx ... !> \param output_unit ... !> \param logger ... -!> \param error ... !> \author Teodoro Laino 08.2006 ! ***************************************************************************** SUBROUTINE ms_vb_anal(input,rep_env, para_env, globenv, particles,& - nrep,calc_intens,dx,output_unit,logger,error) + nrep,calc_intens,dx,output_unit,logger) TYPE(section_vals_type), POINTER :: input TYPE(replica_env_type), POINTER :: rep_env TYPE(cp_para_env_type), POINTER :: para_env @@ -108,7 +107,6 @@ SUBROUTINE ms_vb_anal(input,rep_env, para_env, globenv, particles,& REAL(KIND=dp) :: dx INTEGER :: output_unit TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ms_vb_anal', & routineP = moduleN//':'//routineN @@ -129,7 +127,7 @@ SUBROUTINE ms_vb_anal(input,rep_env, para_env, globenv, particles,& natoms=SIZE(particles) ncoord=3*natoms ALLOCATE(mass(3*natoms), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natoms DO j=1,3 mass((i-1)*3+j) = particles(i)%atomic_kind%mass @@ -138,30 +136,30 @@ SUBROUTINE ms_vb_anal(input,rep_env, para_env, globenv, particles,& END DO ! Allocate working arrays ALLOCATE(ms_vib%delta_vec(ncoord,nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%b_vec(ncoord,nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%step_r(nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%step_b(nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calc_intens)THEN description='[DIPOLE]' ALLOCATE(tmp_dip(nrep,3,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%dip_deriv(3,nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL MS_initial_moves( para_env, nrep , input, globenv,ms_vib,& particles,& mass,& dx,& - calc_intens,logger,error) + calc_intens,logger) ncoord=3*natoms ALLOCATE(pos0(ncoord), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%ms_force(ncoord,nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natoms DO j=1,3 pos0((i-1)*3+j) = particles((i))%r(j) @@ -175,17 +173,17 @@ SUBROUTINE ms_vb_anal(input,rep_env, para_env, globenv, particles,& rep_env%r(j,i)=pos0(j)+ms_vib%step_r(i)*ms_vib%delta_vec(j,i) END DO END DO - CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.,error=error) + CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.) DO i = 1, nrep IF(calc_intens)THEN CALL get_results(results=rep_env%results(i)%results,& description=description,& - n_rep=ip1,error=error) + n_rep=ip1) CALL get_results(results=rep_env%results(i)%results,& description=description,& values=tmp_dip(i,:,1),& - nval=ip1,error=error) + nval=ip1) END IF DO j = 1, ncoord ms_vib%ms_force(j,i) = rep_env%f(j,i) @@ -196,16 +194,16 @@ SUBROUTINE ms_vb_anal(input,rep_env, para_env, globenv, particles,& rep_env%r(j,i)=pos0(j)-ms_vib%step_r(i)*ms_vib%delta_vec(j,i) END DO END DO - CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.,error=error) + CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.) IF(calc_intens)THEN DO i = 1, nrep CALL get_results(results=rep_env%results(i)%results,& description=description,& - n_rep=ip1,error=error) + n_rep=ip1) CALL get_results(results=rep_env%results(i)%results,& description=description,& values=tmp_dip(i,:,2),& - nval=ip1,error=error) + nval=ip1) ms_vib%dip_deriv(:,ms_vib%mat_size+i)=(tmp_dip(i,:,1)-tmp_dip(i,:,2))/(2*ms_vib%step_b(i)) END DO END IF @@ -215,56 +213,56 @@ SUBROUTINE ms_vb_anal(input,rep_env, para_env, globenv, particles,& mass,& converged,& dx,calc_intens,& - output_unit,logger,error) + output_unit,logger) IF(converged)EXIT IF(calc_intens)THEN ALLOCATE(tmp_deriv(3,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_deriv=ms_vib%dip_deriv DEALLOCATE(ms_vib%dip_deriv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%dip_deriv(3,ms_vib%mat_size+nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ms_vib%dip_deriv(:,1:ms_vib%mat_size)=tmp_deriv(:,1:ms_vib%mat_size) DEALLOCATE(tmp_deriv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(ms_vib%ms_force, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pos0, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%step_r, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%step_b, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%b_vec, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%delta_vec, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mass, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%b_mat, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%s_mat, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ms_vib%select_id==3)THEN DEALLOCATE(ms_vib%inv_atoms, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(ms_vib%eig_bfgs)) THEN DEALLOCATE(ms_vib%eig_bfgs, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(ms_vib%hes_bfgs)) THEN DEALLOCATE(ms_vib%hes_bfgs, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(calc_intens)THEN DEALLOCATE(ms_vib%dip_deriv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_dip,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE ms_vb_anal @@ -281,12 +279,11 @@ END SUBROUTINE ms_vb_anal !> \param dx ... !> \param calc_intens ... !> \param logger ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& mass, dx,& - calc_intens, logger, error) + calc_intens, logger) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: nrep TYPE(section_vals_type), POINTER :: input @@ -298,7 +295,6 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& REAL(KIND=dp) :: dx LOGICAL :: calc_intens TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'MS_initial_moves', & routineP = moduleN//':'//routineN @@ -317,14 +313,14 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& failure = .FALSE. CALL timeset(routineN,handle) NULLIFY(ms_vib%eig_bfgs,ms_vib%f_range,ms_vib%hes_bfgs,ms_vib%inv_range) - ms_vib_section => section_vals_get_subs_vals(input,"VIBRATIONAL_ANALYSIS%MODE_SELECTIVE", error=error) - CALL section_vals_val_get(ms_vib_section,"INITIAL_GUESS",i_val=guess,error=error) - CALL section_vals_val_get(ms_vib_section,"EPS_MAX_VAL",r_val=ms_vib%eps(1), error=error) - CALL section_vals_val_get(ms_vib_section,"EPS_NORM",r_val=ms_vib%eps(2), error=error) - CALL section_vals_val_get(ms_vib_section,"RANGE",n_rep_val=n_rep_val,error=error) + ms_vib_section => section_vals_get_subs_vals(input,"VIBRATIONAL_ANALYSIS%MODE_SELECTIVE") + CALL section_vals_val_get(ms_vib_section,"INITIAL_GUESS",i_val=guess) + CALL section_vals_val_get(ms_vib_section,"EPS_MAX_VAL",r_val=ms_vib%eps(1)) + CALL section_vals_val_get(ms_vib_section,"EPS_NORM",r_val=ms_vib%eps(2)) + CALL section_vals_val_get(ms_vib_section,"RANGE",n_rep_val=n_rep_val) ms_vib%select_id=0 IF(n_rep_val.NE.0)THEN - CALL section_vals_val_get(ms_vib_section,"RANGE",r_vals=ms_vib%f_range,error=error) + CALL section_vals_val_get(ms_vib_section,"RANGE",r_vals=ms_vib%f_range) IF(ms_vib%f_range(1).GT.ms_vib%f_range(2))THEN my_val=ms_vib%f_range(2) ms_vib%f_range(2)=ms_vib%f_range(1) @@ -332,16 +328,15 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& END IF ms_vib%select_id=2 END IF - CALL section_vals_val_get(ms_vib_section,"FREQUENCY",r_val=ms_vib%sel_freq, error=error) + CALL section_vals_val_get(ms_vib_section,"FREQUENCY",r_val=ms_vib%sel_freq) IF(ms_vib%sel_freq.gt.0._dp)ms_vib%select_id=1 - involved_at_section=>section_vals_get_subs_vals(ms_vib_section,"INVOLVED_ATOMS",& - error=error) - CALL section_vals_get(involved_at_section,explicit=do_involved_atoms, error=error) + involved_at_section=>section_vals_get_subs_vals(ms_vib_section,"INVOLVED_ATOMS") + CALL section_vals_get(involved_at_section,explicit=do_involved_atoms) IF(do_involved_atoms)THEN - CALL section_vals_val_get(involved_at_section,"INVOLVED_ATOMS",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(involved_at_section,"INVOLVED_ATOMS",n_rep_val=n_rep_val) jj = 0 DO k = 1,n_rep_val - CALL section_vals_val_get(involved_at_section,"INVOLVED_ATOMS",i_rep_val=k,i_vals=tmplist, error=error) + CALL section_vals_val_get(involved_at_section,"INVOLVED_ATOMS",i_rep_val=k,i_vals=tmplist) DO j = 1,SIZE(tmplist) jj = jj+1 END DO @@ -349,19 +344,19 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& IF (jj.GE.1)THEN natoms=jj ALLOCATE(ms_vib%inv_atoms(natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) jj = 0 DO m=1,n_rep_val - CALL section_vals_val_get(involved_at_section,"INVOLVED_ATOMS",i_rep_val=m,i_vals=tmplist, error=error) + CALL section_vals_val_get(involved_at_section,"INVOLVED_ATOMS",i_rep_val=m,i_vals=tmplist) DO j = 1,SIZE(tmplist) ms_vib%inv_atoms (j) = tmplist(j) END DO END DO ms_vib%select_id=3 END IF - CALL section_vals_val_get(involved_at_section,"RANGE",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(involved_at_section,"RANGE",n_rep_val=n_rep_val) IF(n_rep_val.NE.0)THEN - CALL section_vals_val_get(involved_at_section,"RANGE",r_vals=ms_vib%inv_range,error=error) + CALL section_vals_val_get(involved_at_section,"RANGE",r_vals=ms_vib%inv_range) IF(ms_vib%inv_range(1).GT.ms_vib%inv_range(2))THEN ms_vib%inv_range(2)=my_val ms_vib%inv_range(2)=ms_vib%inv_range(1) @@ -372,15 +367,15 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& IF(ms_vib%select_id==0)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"no frequency, range or involved atoms specified ",& - error=error,failure=failure) + failure=failure) ionode=para_env%mepos==para_env%source SELECT CASE(guess) CASE(ms_guess_atomic) ms_vib%initial_guess=1 - CALL section_vals_val_get(ms_vib_section,"ATOMS",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(ms_vib_section,"ATOMS",n_rep_val=n_rep_val) jj = 0 DO k = 1,n_rep_val - CALL section_vals_val_get(ms_vib_section,"ATOMS",i_rep_val=k,i_vals=tmplist, error=error) + CALL section_vals_val_get(ms_vib_section,"ATOMS",i_rep_val=k,i_vals=tmplist) DO j = 1,SIZE(tmplist) jj = jj+1 END DO @@ -388,17 +383,17 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& IF (jj<1)THEN natoms=SIZE(particles) ALLOCATE(map_atoms(natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,natoms map_atoms(j)=j END DO ELSE natoms=jj ALLOCATE(map_atoms(natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) jj = 0 DO m=1,n_rep_val - CALL section_vals_val_get(ms_vib_section,"ATOMS",i_rep_val=m,i_vals=tmplist, error=error) + CALL section_vals_val_get(ms_vib_section,"ATOMS",i_rep_val=m,i_vals=tmplist) DO j = 1,SIZE(tmplist) map_atoms (j) = tmplist(j) END DO @@ -414,7 +409,7 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& DO j=1,natoms DO k=1,3 jj=(map_atoms(j)-1)*3+k - ms_vib%b_vec(jj,i)=ABS(next_random_number(globenv%gaussian_rng_stream,error=error)) + ms_vib%b_vec(jj,i)=ABS(next_random_number(globenv%gaussian_rng_stream)) END DO END DO norm=SQRT(DOT_PRODUCT(ms_vib%b_vec(:,i),ms_vib%b_vec(:,i))) @@ -441,26 +436,26 @@ SUBROUTINE MS_initial_moves(para_env, nrep , input, globenv ,ms_vib,particles ,& CASE(ms_guess_bfgs) ms_vib%initial_guess=2 - CALL bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep,error) + CALL bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep) ms_vib%mat_size=0 CASE(ms_guess_restart_vec) ms_vib%initial_guess=3 ncoord=3*SIZE(particles) - CALL rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep,calc_intens,error) + CALL rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep,calc_intens) ms_vib%mat_size=0 CASE(ms_guess_restart) ms_vib%initial_guess=4 ncoord=3*SIZE(particles) - CALL rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep,calc_intens,error) + CALL rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep,calc_intens) CASE(ms_guess_molden) ms_vib%initial_guess=5 ncoord=3*SIZE(particles) - CALL molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,logger,error) + CALL molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,logger) ms_vib%mat_size=0 END SELECT CALL mp_bcast(ms_vib%b_vec,para_env%source,para_env%group) @@ -482,10 +477,9 @@ END SUBROUTINE MS_initial_moves !> \param mass ... !> \param para_env ... !> \param nrep ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** - SUBROUTINE bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep,error) + SUBROUTINE bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep) TYPE(section_vals_type), POINTER :: ms_vib_section TYPE(ms_vib_type) :: ms_vib @@ -494,7 +488,6 @@ SUBROUTINE bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep,error) REAL(Kind=dp), DIMENSION(:) :: mass TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: nrep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'bfgs_guess', & routineP = moduleN//':'//routineN @@ -508,27 +501,26 @@ SUBROUTINE bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep,error) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tmp TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) natoms=SIZE(particles) ncoord=3*natoms ALLOCATE(ms_vib%hes_bfgs(ncoord,ncoord),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%eig_bfgs(ncoord),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(para_env%mepos==para_env%source)THEN - CALL section_vals_val_get(ms_vib_section,"RESTART_FILE_NAME",c_val=hes_filename,& - error=error) + CALL section_vals_val_get(ms_vib_section,"RESTART_FILE_NAME",c_val=hes_filename) IF(hes_filename=="") hes_filename="HESSIAN" CALL open_file(file_name=hes_filename,file_status="OLD",& file_form="UNFORMATTED", file_action="READ", unit_number=hesunit) ALLOCATE(tmp(ncoord),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmplist(ncoord),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! should use the cp_fm_read_unformatted... DO i=1,ncoord @@ -550,7 +542,7 @@ SUBROUTINE bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep,error) END DO - CALL diamat_all(ms_vib%hes_bfgs,ms_vib%eig_bfgs,error=error) + CALL diamat_all(ms_vib%hes_bfgs,ms_vib%eig_bfgs) tmp(:) = 0._dp IF(ms_vib%select_id==1) my_val=(ms_vib%sel_freq/vibfac)**2/massunit IF(ms_vib%select_id==2) my_val=(((ms_vib%f_range(2)+ms_vib%f_range(1))*0.5_dp)/vibfac)**2/massunit @@ -580,18 +572,18 @@ SUBROUTINE bfgs_guess(ms_vib_section,ms_vib,particles,mass,para_env,nrep,error) ms_vib%delta_vec(i,:)=ms_vib%b_vec(i,:)/mass(i) END DO DEALLOCATE(tmp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmplist,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL mp_bcast(ms_vib%b_vec,para_env%source,para_env%group) CALL mp_bcast(ms_vib%delta_vec,para_env%source,para_env%group) DEALLOCATE(ms_vib%hes_bfgs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%eig_bfgs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ms_vib%mat_size=0 END SUBROUTINE bfgs_guess @@ -607,10 +599,9 @@ END SUBROUTINE bfgs_guess !> \param particles ... !> \param nrep ... !> \param calc_intens ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** - SUBROUTINE rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep,calc_intens,error) + SUBROUTINE rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep,calc_intens) TYPE(section_vals_type), POINTER :: ms_vib_section TYPE(cp_para_env_type), POINTER :: para_env @@ -621,7 +612,6 @@ SUBROUTINE rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep, POINTER :: particles INTEGER :: nrep LOGICAL :: calc_intens - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rest_guess', & routineP = moduleN//':'//routineN @@ -637,20 +627,19 @@ SUBROUTINE rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep, DIMENSION(:, :) :: approx_H TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) natoms=SIZE(particles) ncoord=3*natoms IF(calc_intens)THEN DEALLOCATE(ms_vib%dip_deriv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ionode)THEN - CALL section_vals_val_get(ms_vib_section,"RESTART_FILE_NAME",c_val=ms_filename,& - error=error) + CALL section_vals_val_get(ms_vib_section,"RESTART_FILE_NAME",c_val=ms_filename) IF(ms_filename=="") ms_filename="MS_RESTART" CALL open_file(file_name=ms_filename,& file_status="UNKNOWN",& @@ -658,17 +647,17 @@ SUBROUTINE rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep, file_action="READ",& unit_number=hesunit) READ(UNIT=hesunit,IOSTAT=stat)mat - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ms_vib%mat_size=mat END IF CALL mp_bcast(ms_vib%mat_size,para_env%source,para_env%group) ALLOCATE(ms_vib%b_mat(ncoord,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%s_mat(ncoord,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calc_intens)THEN ALLOCATE(ms_vib%dip_deriv(3,ms_vib%mat_size+nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ionode)THEN statint=0 @@ -690,18 +679,18 @@ SUBROUTINE rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep, CALL mp_bcast(ms_vib%s_mat,para_env%source,para_env%group) IF(calc_intens)CALL mp_bcast( ms_vib%dip_deriv ,para_env%source,para_env%group) ALLOCATE(approx_H(ms_vib%mat_size,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(eigenval(ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ind(ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL dgemm('T','N',ms_vib%mat_size,ms_vib%mat_size,SIZE(ms_vib%s_mat,1),1._dp,ms_vib%b_mat,SIZE(ms_vib%b_mat,1),& ms_vib%s_mat,SIZE(ms_vib%s_mat,1),0._dp,approx_H,ms_vib%mat_size) - CALL diamat_all(approx_H,eigenval,error=error) + CALL diamat_all(approx_H,eigenval) - CALL select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,ms_vib%b_vec,error=error) + CALL select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,ms_vib%b_vec) IF(ms_vib%initial_guess.NE.4)THEN ms_vib%b_vec=0._dp @@ -713,22 +702,22 @@ SUBROUTINE rest_guess(ms_vib_section,para_env,ms_vib,mass,ionode,particles,nrep, END DO DEALLOCATE(ms_vib%s_mat,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%b_mat,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calc_intens)THEN DEALLOCATE(ms_vib%dip_deriv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%dip_deriv(3,nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF DEALLOCATE(approx_H,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(eigenval,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nrep ms_vib%delta_vec(:,i)= ms_vib%b_vec(:,i)/mass(:) END DO @@ -745,17 +734,15 @@ END SUBROUTINE rest_guess !> \param ncoord ... !> \param nrep ... !> \param logger ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** - SUBROUTINE molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,logger,error) + SUBROUTINE molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,logger) TYPE(section_vals_type), POINTER :: ms_vib_section, input TYPE(cp_para_env_type), POINTER :: para_env TYPE(ms_vib_type) :: ms_vib REAL(Kind=dp), DIMENSION(:) :: mass INTEGER :: ncoord, nrep TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'molden_guess', & routineP = moduleN//':'//routineN @@ -776,11 +763,10 @@ SUBROUTINE molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,lo output_unit = cp_logger_get_default_io_unit(logger) - CALL section_vals_val_get(ms_vib_section,"RESTART_FILE_NAME",c_val=ms_filename,& - error=error) + CALL section_vals_val_get(ms_vib_section,"RESTART_FILE_NAME",c_val=ms_filename) IF(ms_filename=="") output_molden=cp_print_key_unit_nr(logger,input,& "VIBRATIONAL_ANALYSIS%PRINT%MOLDEN_VIB",extension=".mol",file_status='UNKNOWN',& - file_action="READ",error=error) + file_action="READ") IF(para_env%mepos==para_env%source)THEN IF(ms_filename=="") THEN @@ -802,7 +788,7 @@ SUBROUTINE molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,lo istat=istat+stat IF(TRIM(ADJUSTL(info))=="[FR-COORD]")EXIT - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nvibs=nvibs+1 END DO @@ -814,9 +800,9 @@ SUBROUTINE molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,lo istat=istat+stat ALLOCATE(freq(nvibs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(modes(ncoord,nvibs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nvibs READ(iw,*,IOSTAT=stat)freq(i) @@ -847,10 +833,10 @@ SUBROUTINE molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,lo END IF !!!!!!! select modes !!!!!! ALLOCATE(tmp(nvibs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp(:) = 0.0_dp ALLOCATE(tmplist(nvibs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ms_vib%select_id==1) my_val=ms_vib%sel_freq IF(ms_vib%select_id==2) my_val=(ms_vib%f_range(2)+ms_vib%f_range(1))*0.5_dp IF(ms_vib%select_id==1.OR.ms_vib%select_id==2)THEN @@ -880,20 +866,20 @@ SUBROUTINE molden_guess(ms_vib_section,input,para_env,ms_vib,mass,ncoord,nrep,lo END DO DEALLOCATE(freq,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(modes,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmplist,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL mp_bcast(ms_vib%b_vec,para_env%source,para_env%group) CALL mp_bcast(ms_vib%delta_vec,para_env%source,para_env%group) IF(ms_filename=="")CALL cp_print_key_finished_output(output_molden,logger,input,& - "VIBRATIONAL_ANALYSIS%PRINT%MOLDEN_VIB",error=error) + "VIBRATIONAL_ANALYSIS%PRINT%MOLDEN_VIB") END SUBROUTINE molden_guess ! ***************************************************************************** @@ -910,14 +896,13 @@ END SUBROUTINE molden_guess !> \param calc_intens ... !> \param output_unit_ms ... !> \param logger ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& particles,& mass, & converged,dx,& - calc_intens,output_unit_ms,logger,error) + calc_intens,output_unit_ms,logger) TYPE(replica_env_type), POINTER :: rep_env TYPE(ms_vib_type) :: ms_vib TYPE(section_vals_type), POINTER :: input @@ -930,7 +915,6 @@ SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& LOGICAL :: calc_intens INTEGER :: output_unit_ms TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'evaluate_H_update_b', & routineP = moduleN//':'//routineN @@ -955,23 +939,23 @@ SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& IF(ms_vib%mat_size.NE.0)THEN ALLOCATE(tmp_b(3*natoms,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_s(3*natoms,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_b(:,:)=ms_vib%b_mat tmp_s(:,:)=ms_vib%s_mat DEALLOCATE(ms_vib%b_mat,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ms_vib%s_mat,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ALLOCATE(ms_vib%b_mat(3*natoms,ms_vib%mat_size+nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ms_vib%s_mat(3*natoms,ms_vib%mat_size+nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ms_vib%s_mat=0.0_dp @@ -989,19 +973,19 @@ SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& IF(ms_vib%mat_size.NE.0)THEN DEALLOCATE(tmp_s,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ms_vib%mat_size=ms_vib%mat_size+nrep ALLOCATE(approx_H(ms_vib%mat_size,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(H_save(ms_vib%mat_size,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(eigenval(ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !!!!!!!!!!!! calculate the new derivativ and the approximate hessian @@ -1015,15 +999,15 @@ SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& ms_vib%s_mat,SIZE(ms_vib%s_mat,1),0._dp,approx_H,ms_vib%mat_size) H_save(:,:)=approx_H - CALL diamat_all(approx_H,eigenval,error=error) + CALL diamat_all(approx_H,eigenval) !!!!!!!!!!!! select eigenvalue(s) and vector(s) and calculate the new displacement vector ALLOCATE(ind(ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(residuum(SIZE(ms_vib%s_mat,1),nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum,criteria,error) + CALL select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum,criteria) DO i=1,nrep DO j=1,natoms @@ -1042,7 +1026,7 @@ SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& IF(MAXVAL(criteria(1,:)).LE.ms_vib%eps(1).AND.MAXVAL(criteria(2,:))& .LE.ms_vib%eps(2).OR.ms_vib%mat_size.GE.ncoord)converged=.TRUE. ALLOCATE(freq(nrep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nrep freq(i)=SQRT(ABS(eigenval(ind(i)))*massunit)*vibfac END DO @@ -1051,14 +1035,14 @@ SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& IF(converged)THEN eigenval(:)=SIGN(1._dp,eigenval(:))*SQRT(ABS(eigenval(:))*massunit)*vibfac ALLOCATE(tmp_b(ncoord,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_b=0._dp ALLOCATE(tmp_s(3,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_s=0._dp IF(calc_intens)THEN ALLOCATE(intensities(ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) intensities=0._dp END IF DO i=1,ms_vib%mat_size @@ -1078,36 +1062,36 @@ SUBROUTINE evaluate_H_update_b(rep_env,ms_vib,input,nrep,& IF(calc_intens)THEN CALL ms_out(output_unit_ms, converged, freq, criteria, ms_vib, & input, nrep,approx_H, eigenval, calc_intens, & - intensities=intensities, logger=logger, error=error) + intensities=intensities, logger=logger) ELSE CALL ms_out(output_unit_ms, converged, freq, criteria, ms_vib, & - input, nrep, approx_H, eigenval, calc_intens, logger=logger, error=error) + input, nrep, approx_H, eigenval, calc_intens, logger=logger) ENDIF CALL molden_out(input,particles,eigenval,tmp_b,intensities,calc_intens,& - dump_only_positive=.TRUE., logger=logger, error=error) + dump_only_positive=.TRUE., logger=logger) IF (calc_intens) THEN DEALLOCATE(intensities,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(tmp_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_s,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(.NOT.converged) CALL ms_out(output_unit_ms, converged, freq, criteria, & - ms_vib, input, nrep,approx_H, eigenval, calc_intens, logger=logger, error=error) + ms_vib, input, nrep,approx_H, eigenval, calc_intens, logger=logger) DEALLOCATE(freq,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(approx_H,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(eigenval,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(residuum,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ind,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE evaluate_H_update_b @@ -1123,10 +1107,9 @@ END SUBROUTINE evaluate_H_update_b !> \param ind ... !> \param residuum ... !> \param criteria ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** - SUBROUTINE select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum,criteria,error) + SUBROUTINE select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum,criteria) TYPE(ms_vib_type) :: ms_vib INTEGER :: nrep @@ -1138,7 +1121,6 @@ SUBROUTINE select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum, REAL(KIND=dp), DIMENSION(:, :) :: residuum REAL(KIND=dp), DIMENSION(2, nrep), & OPTIONAL :: criteria - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'select_vector', & routineP = moduleN//':'//routineN @@ -1151,7 +1133,7 @@ SUBROUTINE select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum, DIMENSION(:, :) :: tmp_b ALLOCATE(tmp(ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE(ms_vib%select_id) CASE(1) @@ -1171,7 +1153,7 @@ SUBROUTINE select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum, CASE(3) ALLOCATE(tmp_b(ncoord,ms_vib%mat_size),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_b=0._dp @@ -1206,7 +1188,7 @@ SUBROUTINE select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum, END DO END DO DEALLOCATE(tmp_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT DO j=1,nrep @@ -1246,7 +1228,7 @@ SUBROUTINE select_vector(ms_vib,nrep,mass,ncoord,approx_H,eigenval,ind,residuum, END DO ms_vib%b_vec=residuum DEALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE select_vector ! ***************************************************************************** @@ -1263,11 +1245,10 @@ END SUBROUTINE select_vector !> \param calc_intens ... !> \param intensities ... !> \param logger ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** SUBROUTINE ms_out(iw, converged, freq, criter, ms_vib, input, nrep, & - approx_H, eigenval, calc_intens, intensities, logger, error) + approx_H, eigenval, calc_intens, intensities, logger) INTEGER :: iw LOGICAL :: converged @@ -1281,7 +1262,6 @@ SUBROUTINE ms_out(iw, converged, freq, criter, ms_vib, input, nrep, & LOGICAL :: calc_intens REAL(KIND=dp), DIMENSION(:), OPTIONAL :: intensities TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ms_out', & routineP = moduleN//':'//routineN @@ -1293,7 +1273,7 @@ SUBROUTINE ms_out(iw, converged, freq, criter, ms_vib, input, nrep, & TYPE(section_vals_type), POINTER :: ms_vib_section ms_vib_section => section_vals_get_subs_vals(input, & - "VIBRATIONAL_ANALYSIS%MODE_SELECTIVE", error=error) + "VIBRATIONAL_ANALYSIS%MODE_SELECTIVE") IF(converged)THEN IF(iw.GT.0)THEN @@ -1302,7 +1282,7 @@ SUBROUTINE ms_out(iw, converged, freq, criter, ms_vib, input, nrep, & WRITE(iw,'(T2,"MS| TRACKED FREQUENCY (",I0,") IS:",F12.6,3X,A)') i,freq(i),'cm-1' END DO ALLOCATE(residuum(SIZE(ms_vib%b_mat,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) WRITE ( iw, '( /, 1X, 79("-") )' ) WRITE ( iw, '( 25X, A)' ) 'FREQUENCY AND CONVERGENCE LIST' IF(PRESENT(intensities))THEN @@ -1339,12 +1319,12 @@ SUBROUTINE ms_out(iw, converged, freq, criter, ms_vib, input, nrep, & END IF END DO DEALLOCATE(residuum,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) msunit = cp_print_key_unit_nr(logger, ms_vib_section, & "PRINT%MS_RESTART", extension=".bin", middle_name="MS_RESTART", & file_status="REPLACE", file_form="UNFORMATTED", & - file_action="WRITE", error=error) + file_action="WRITE") IF (msunit>0) THEN WRITE(UNIT=msunit,IOSTAT=stat)ms_vib%mat_size @@ -1354,14 +1334,14 @@ SUBROUTINE ms_out(iw, converged, freq, criter, ms_vib, input, nrep, & END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & - "PRINT%MS_RESTART", error=error) + "PRINT%MS_RESTART") END IF ELSE IF(iw.GT.0)THEN msunit = cp_print_key_unit_nr(logger, ms_vib_section, & "PRINT%MS_RESTART", extension=".bin", middle_name="MS_RESTART", & file_status="REPLACE", file_form="UNFORMATTED", & - file_action="WRITE", error=error) + file_action="WRITE") IF (msunit>0) THEN WRITE(UNIT=msunit,IOSTAT=stat)ms_vib%mat_size @@ -1371,7 +1351,7 @@ SUBROUTINE ms_out(iw, converged, freq, criter, ms_vib, input, nrep, & END IF CALL cp_print_key_finished_output(msunit, logger, ms_vib_section, & - "PRINT%MS_RESTART", error=error) + "PRINT%MS_RESTART") WRITE(iw,'(T2,A,3X,I6)')"MS| ITERATION STEP", ms_vib%mat_size/nrep DO i=1,nrep diff --git a/src/molden_utils.F b/src/molden_utils.F index 904ea9c9b8..79c9bae319 100644 --- a/src/molden_utils.F +++ b/src/molden_utils.F @@ -35,11 +35,10 @@ MODULE molden_utils !> \param calc_intens ... !> \param dump_only_positive ... !> \param logger ... -!> \param error ... !> \author Florian Schiffmann 11.2007 ! ***************************************************************************** SUBROUTINE molden_out(input,particles,freq,eigen_vec,intensities,calc_intens,& - dump_only_positive,logger,error) + dump_only_positive,logger) TYPE(section_vals_type), POINTER :: input TYPE(particle_type), DIMENSION(:), & @@ -50,7 +49,6 @@ SUBROUTINE molden_out(input,particles,freq,eigen_vec,intensities,calc_intens,& LOGICAL :: calc_intens, & dump_only_positive TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'molden_out', & routineP = moduleN//':'//routineN @@ -60,12 +58,12 @@ SUBROUTINE molden_out(input,particles,freq,eigen_vec,intensities,calc_intens,& LOGICAL :: failure iw=cp_print_key_unit_nr(logger,input,"VIBRATIONAL_ANALYSIS%PRINT%MOLDEN_VIB",& - extension=".mol",file_status='REPLACE',error=error) + extension=".mol",file_status='REPLACE') IF(iw.GT.0)THEN - CPPostcondition(MOD(SIZE(eigen_vec,1),3)==0,cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(particles)==SIZE(eigen_vec,1)/3,cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(freq,1)==SIZE(eigen_vec,2),cp_failure_level,routineP,error,failure) + CPPostcondition(MOD(SIZE(eigen_vec,1),3)==0,cp_failure_level,routineP,failure) + CPPostcondition(SIZE(particles)==SIZE(eigen_vec,1)/3,cp_failure_level,routineP,failure) + CPPostcondition(SIZE(freq,1)==SIZE(eigen_vec,2),cp_failure_level,routineP,failure) WRITE(iw,'(T2,A)')"[Molden Format]" WRITE(iw,'(T2,A)')"[FREQ]" DO i=1,SIZE(freq,1) @@ -97,7 +95,7 @@ SUBROUTINE molden_out(input,particles,freq,eigen_vec,intensities,calc_intens,& END DO END IF END IF - CALL cp_print_key_finished_output(iw,logger,input,"VIBRATIONAL_ANALYSIS%PRINT%MOLDEN_VIB",error=error) + CALL cp_print_key_finished_output(iw,logger,input,"VIBRATIONAL_ANALYSIS%PRINT%MOLDEN_VIB") END SUBROUTINE molden_out END MODULE molden_utils diff --git a/src/molecular_states.F b/src/molecular_states.F index 8189a8ebb4..5da9582ea3 100644 --- a/src/molecular_states.F +++ b/src/molecular_states.F @@ -87,11 +87,10 @@ MODULE molecular_states !> \param particles ... !> \param tag ... !> \param marked_states ... -!> \param error ... ! ***************************************************************************** SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & mo_coeff, mo_eigenvalues, Hks, matrix_S, qs_env, wf_r, wf_g,& - loc_print_section, particles, tag, marked_states,error) + loc_print_section, particles, tag, marked_states) TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set @@ -104,7 +103,6 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & TYPE(particle_list_type), POINTER :: particles CHARACTER(LEN=*), INTENT(IN) :: tag INTEGER, DIMENSION(:), POINTER :: marked_states - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'construct_molecular_states', & routineP = moduleN//':'//routineN @@ -141,25 +139,25 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & failure = .FALSE. NULLIFY(logger,mark_states,mark_list,para_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() !----------------------------------------------------------------------------- ! 1. !----------------------------------------------------------------------------- - CALL get_qs_env(qs_env, para_env=para_env, error=error) + CALL get_qs_env(qs_env, para_env=para_env) nproc = para_env%num_pe output_unit = cp_logger_get_default_io_unit(logger) CALL section_vals_val_get(loc_print_section,"MOLECULAR_STATES%CUBE_EVAL_RANGE",& - explicit=explicit,error=error) + explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(loc_print_section,"MOLECULAR_STATES%CUBE_EVAL_RANGE",& - r_vals=eval_range,error=error) + r_vals=eval_range) ELSE ALLOCATE(eval_range(2)) eval_range(1)=-HUGE(0.0_dp) eval_range(2)=+HUGE(0.0_dp) ENDIF CALL section_vals_val_get(loc_print_section,"MOLECULAR_STATES%MARK_STATES", & - n_rep_val=n_rep, error=error) + n_rep_val=n_rep) IF(n_rep.GT.0)THEN ALLOCATE (mark_states(2,n_rep),STAT=isos) IF (isos /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -171,7 +169,7 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & END IF DO i=1,n_rep CALL section_vals_val_get(loc_print_section,"MOLECULAR_STATES%MARK_STATES",& - i_rep_val=i,i_vals=mark_list, error=error) + i_rep_val=i,i_vals=mark_list) mark_states(:,i)=mark_list(:) END DO ELSE @@ -183,7 +181,7 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & ! 2. !----------------------------------------------------------------------------- unit_report=cp_print_key_unit_nr(logger,loc_print_section,"MOLECULAR_STATES",& - extension=".data",middle_name="Molecular_DOS",log_filename=.FALSE.,error=error) + extension=".data",middle_name="Molecular_DOS",log_filename=.FALSE.) IF (unit_report>0) THEN WRITE(unit_report,*) SIZE(mo_eigenvalues)," number of states " DO i=1,SIZE(mo_eigenvalues) @@ -197,10 +195,10 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & !----------------------------------------------------------------------------- CALL cp_fm_get_info(mo_localized, & ncol_global=ncol_global, & - nrow_global=nrow_global ,error=error) + nrow_global=nrow_global) NULLIFY(smo) - CALL cp_fm_create(smo,mo_coeff%matrix_struct,error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_S,mo_coeff,smo,ncol_global,error=error) + CALL cp_fm_create(smo,mo_coeff%matrix_struct) + CALL cp_dbcsr_sm_fm_multiply(matrix_S,mo_coeff,smo,ncol_global) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -210,7 +208,7 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & IF (isos /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "nstates",int_size*2) - CALL cp_fm_create(storage,mo_localized%matrix_struct,name='storage',error=error) + CALL cp_fm_create(storage,mo_localized%matrix_struct,name='storage') DO imol = 1, SIZE(molecule_set) IF (ASSOCIATED(molecule_set(imol)%lmi)) THEN @@ -247,32 +245,32 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nrow_global, & ncol_global=ns, & para_env=mo_localized%matrix_struct%para_env, & - context=mo_localized%matrix_struct%context,error=error) + context=mo_localized%matrix_struct%context) - CALL cp_fm_create(b,fm_struct_tmp, name="b",error=error) - CALL cp_fm_create(c,fm_struct_tmp, name="c",error=error) - CALL cp_fm_create(rot_e_vectors,fm_struct_tmp, name="rot_e_vectors",error=error) + CALL cp_fm_create(b,fm_struct_tmp, name="b") + CALL cp_fm_create(c,fm_struct_tmp, name="c") + CALL cp_fm_create(rot_e_vectors,fm_struct_tmp, name="rot_e_vectors") - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ns, ncol_global=ns, & para_env=mo_localized%matrix_struct%para_env, & - context=mo_localized%matrix_struct%context,error=error) + context=mo_localized%matrix_struct%context) - CALL cp_fm_create(d,fm_struct_tmp, name="d",error=error) - CALL cp_fm_create(e_vectors,fm_struct_tmp, name="e_vectors",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(d,fm_struct_tmp, name="d") + CALL cp_fm_create(e_vectors,fm_struct_tmp, name="e_vectors") + CALL cp_fm_struct_release(fm_struct_tmp) DO i=1,ns CALL cp_fm_to_fm ( mo_localized, b, 1, ind ( i ), i) END DO - CALL cp_dbcsr_sm_fm_multiply(Hks,b,c,ns,error=error) + CALL cp_dbcsr_sm_fm_multiply(Hks,b,c,ns) CALL cp_gemm('T','N',ns,ns,nrow_global,1.0_dp, & - b,c,0.0_dp,d,error=error) + b,c,0.0_dp,d) - CALL choose_eigv_solver( d, e_vectors, evals , error=error) + CALL choose_eigv_solver( d, e_vectors, evals) IF (output_unit>0) WRITE(output_unit,*)"" IF (output_unit>0) WRITE(output_unit,*)"MOLECULE ",imol @@ -297,7 +295,7 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & ENDIF CALL cp_gemm('N','N',nrow_global,ns,ns,1.0_dp, & - b,e_vectors,0.0_dp,rot_e_vectors,error=error) + b,e_vectors,0.0_dp,rot_e_vectors) DO i=1,ns CALL cp_fm_to_fm ( rot_e_vectors, storage, 1, i, ind ( i )) @@ -308,11 +306,11 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ns, & ncol_global=ncol_global, & para_env=mo_localized%matrix_struct%para_env, & - context=mo_localized%matrix_struct%context,error=error) - CALL cp_fm_create(D_igk,fm_struct_tmp,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=mo_localized%matrix_struct%context) + CALL cp_fm_create(D_igk,fm_struct_tmp) + CALL cp_fm_struct_release(fm_struct_tmp) CALL cp_gemm('T','N',ns,ncol_global,nrow_global,1.0_dp, & - rot_e_vectors,smo,0.0_dp,D_igk,error=error) + rot_e_vectors,smo,0.0_dp,D_igk) DO i=1,ns DO k=1,ncol_global CALL cp_fm_get_element(D_igk,i,k,tmp) @@ -321,11 +319,11 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & ENDIF ENDDO ENDDO - CALL cp_fm_release(D_igk,error=error) + CALL cp_fm_release(D_igk) ENDIF IF ( BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "MOLECULAR_STATES%CUBES",error=error),cp_p_file) ) THEN + "MOLECULAR_STATES%CUBES"),cp_p_file) ) THEN CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& @@ -333,43 +331,43 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - pw_env=pw_env,error=error) + pw_env=pw_env) DO i=1,ns IF (evals(i)eval_range(2)) CYCLE CALL calculate_wavefunction(rot_e_vectors,i,wf_r, & wf_g, atomic_kind_set, qs_kind_set, cell,dft_control,particle_set, & - pw_env, error = error ) + pw_env) WRITE(filename,'(a9,I4.4,a1,I5.5,a4)')"MOLECULE_",imol,"_",i,tag WRITE(title,'(A,I0,A,I0,A,F14.6,A,I0)') "Mol. Eigenstate ",i," of ",ns," E [a.u.] = ",& evals(i)," Orig. index ",ind(i) unit_nr=cp_print_key_unit_nr(logger,loc_print_section,"MOLECULAR_STATES%CUBES",& - extension=".cube",middle_name=TRIM(filename),log_filename=.FALSE.,error=error) + extension=".cube",middle_name=TRIM(filename),log_filename=.FALSE.) CALL cp_pw_to_cube(wf_r%pw,unit_nr,particles=particles,title=title,& stride=section_get_ivals(loc_print_section,& - "MOLECULAR_STATES%CUBES%STRIDE",error=error), error=error) + "MOLECULAR_STATES%CUBES%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,loc_print_section,& - "MOLECULAR_STATES%CUBES",error=error) + "MOLECULAR_STATES%CUBES") END DO ENDIF DEALLOCATE (evals,STAT=isos) IF (isos /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"eval") - CALL cp_fm_release ( b ,error=error) - CALL cp_fm_release ( c ,error=error) - CALL cp_fm_release ( d ,error=error) - CALL cp_fm_release ( e_vectors ,error=error) - CALL cp_fm_release ( rot_e_vectors ,error=error) + CALL cp_fm_release ( b) + CALL cp_fm_release ( c) + CALL cp_fm_release ( d) + CALL cp_fm_release ( e_vectors) + CALL cp_fm_release ( rot_e_vectors) DEALLOCATE (states,STAT=isos) IF (isos /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"states") END DO - CALL cp_fm_release(smo,error=error) - CALL cp_fm_to_fm(storage,mo_localized,error) - CALL cp_fm_release(storage,error) + CALL cp_fm_release(smo) + CALL cp_fm_to_fm(storage,mo_localized) + CALL cp_fm_release(storage) IF (ASSOCIATED(mark_states))THEN DEALLOCATE (mark_states,stat=isos) IF (isos /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"mark_states") @@ -377,7 +375,7 @@ SUBROUTINE construct_molecular_states(molecule_set, mo_localized, & DEALLOCATE (nstates,STAT=isos) IF (isos /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"nstates") CALL cp_print_key_finished_output(unit_report,logger,loc_print_section,& - "MOLECULAR_STATES",error=error) + "MOLECULAR_STATES") !------------------------------------------------------------------------------ IF (.NOT.explicit) THEN diff --git a/src/molsym.F b/src/molsym.F index 479dd792e1..5f9aded491 100644 --- a/src/molsym.F +++ b/src/molsym.F @@ -119,13 +119,11 @@ MODULE molsym !> \brief Create an object of molsym type !> \param sym ... !> \param natoms ... -!> \param error ... !> \author jgh ! ***************************************************************************** - SUBROUTINE create_molsym(sym,natoms,error) + SUBROUTINE create_molsym(sym,natoms) TYPE(molsym_type), POINTER :: sym INTEGER, INTENT(IN) :: natoms - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_molsym', & routineP = moduleN//':'//routineN @@ -134,26 +132,24 @@ SUBROUTINE create_molsym(sym,natoms,error) LOGICAL :: failure failure = .FALSE. - IF ( ASSOCIATED(sym) ) CALL release_molsym(sym,error) + IF ( ASSOCIATED(sym) ) CALL release_molsym(sym) ALLOCATE(sym,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE (sym%ain(natoms),sym%aw(natoms),sym%group_of(natoms),sym%llequatom(natoms),& sym%nequatom(natoms),sym%symequ_list(natoms),sym%ulequatom(natoms),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE create_molsym ! ***************************************************************************** !> \brief release an object of molsym type !> \param sym ... -!> \param error ... !> \author jgh ! ***************************************************************************** - SUBROUTINE release_molsym(sym,error) + SUBROUTINE release_molsym(sym) TYPE(molsym_type), POINTER :: sym - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_molsym', & routineP = moduleN//':'//routineN @@ -162,39 +158,39 @@ SUBROUTINE release_molsym(sym,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(sym),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sym),cp_failure_level,routineP,failure) IF ( ASSOCIATED(sym%aw) ) THEN DEALLOCATE(sym%aw,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sym%ain) ) THEN DEALLOCATE(sym%ain,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sym%group_of) ) THEN DEALLOCATE(sym%group_of,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sym%llequatom) ) THEN DEALLOCATE(sym%llequatom,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sym%nequatom) ) THEN DEALLOCATE(sym%nequatom,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sym%symequ_list) ) THEN DEALLOCATE(sym%symequ_list,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sym%ulequatom) ) THEN DEALLOCATE(sym%ulequatom,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(sym,STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE release_molsym @@ -206,16 +202,14 @@ END SUBROUTINE release_molsym !> \param n ... !> \param a ... !> \param sym ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE addsec(n,a,sym,error) + SUBROUTINE addsec(n,a,sym) INTEGER, INTENT(IN) :: n REAL(dp), DIMENSION(3), INTENT(IN) :: a TYPE(molsym_type), INTENT(inout) :: sym - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'addsec', & routineP = moduleN//':'//routineN @@ -237,7 +231,7 @@ SUBROUTINE addsec(n,a,sym,error) sym%ncn = MAX(sym%ncn,n) ! Add the new Cn axis to the list sec - CPPrecondition(sym%nsec(n) < maxsec,cp_failure_level,routineP,error,failure) + CPPrecondition(sym%nsec(n) < maxsec,cp_failure_level,routineP,failure) sym%nsec(1) = sym%nsec(1) + 1 sym%nsec(n) = sym%nsec(n) + 1 sym%sec(:,sym%nsec(n),n) = d(:) @@ -250,16 +244,14 @@ END SUBROUTINE addsec !> \param n ... !> \param a ... !> \param sym ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE addses(n,a,sym,error) + SUBROUTINE addses(n,a,sym) INTEGER, INTENT(IN) :: n REAL(dp), DIMENSION(3), INTENT(IN) :: a TYPE(molsym_type), INTENT(inout) :: sym - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'addses', & routineP = moduleN//':'//routineN @@ -281,7 +273,7 @@ SUBROUTINE addses(n,a,sym,error) sym%nsn = MAX(sym%nsn,n) ! Add the new Sn axis to the list ses - CPPrecondition(sym%nses(n) < maxses,cp_failure_level,routineP,error,failure) + CPPrecondition(sym%nses(n) < maxses,cp_failure_level,routineP,failure) sym%nses(1) = sym%nses(1) + 1 sym%nses(n) = sym%nses(n) + 1 sym%ses(:,sym%nses(n),n) = d(:) @@ -293,15 +285,13 @@ END SUBROUTINE addses !> normal vector of the mirror plane is already in the list. !> \param a ... !> \param sym ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE addsig(a,sym,error) + SUBROUTINE addsig(a,sym) REAL(dp), DIMENSION(3), INTENT(IN) :: a TYPE(molsym_type), INTENT(inout) :: sym - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'addsig', & routineP = moduleN//':'//routineN @@ -322,7 +312,7 @@ SUBROUTINE addsig(a,sym,error) END DO ! Add the normal vector of the new mirror plane to the list sig - CPPrecondition(sym%nsig < maxsig,cp_failure_level,routineP,error,failure) + CPPrecondition(sym%nsig < maxsig,cp_failure_level,routineP,failure) sym%nsig = sym%nsig + 1 sym%sig(:,sym%nsig) = d(:) @@ -331,14 +321,12 @@ END SUBROUTINE addsig ! ***************************************************************************** !> \brief Symmetry handling for only one atom. !> \param sym ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE atomsym(sym,error) + SUBROUTINE atomsym(sym) TYPE(molsym_type), INTENT(inout) :: sym - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atomsym', & routineP = moduleN//':'//routineN @@ -359,16 +347,14 @@ END SUBROUTINE atomsym !> \brief Search for point groups with AXial SYMmetry (Cn,Cnh,Cnv,Dn,Dnh,Dnd,S2n). !> \param coord ... !> \param sym ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE axsym(coord,sym,error) + SUBROUTINE axsym(coord,sym) REAL(Kind=dp), DIMENSION(:, :), & INTENT(inout) :: coord TYPE(molsym_type), INTENT(inout) :: sym - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'axsym', & routineP = moduleN//':'//routineN @@ -385,7 +371,7 @@ SUBROUTINE axsym(coord,sym,error) ! Special case: D2d phi = angle(sym%ses(:,1,sym%nsn),sym%z_axis(:)) d(:) = vector_product(sym%ses(:,1,sym%nsn),sym%z_axis(:)) - CALL rotate_molecule(phi,d(:),sym,coord,error) + CALL rotate_molecule(phi,d(:),sym,coord) ELSE ! Special cases: D2 and D2h phi = 0.5_dp*pi @@ -393,15 +379,15 @@ SUBROUTINE axsym(coord,sym,error) ny = naxis(sym%y_axis(:),coord,sym) nz = naxis(sym%z_axis(:),coord,sym) IF ((nx > ny).AND.(nx > nz)) THEN - CALL rotate_molecule(-phi,sym%y_axis(:),sym,coord,error) + CALL rotate_molecule(-phi,sym%y_axis(:),sym,coord) ELSE IF ((ny > nz).AND.(ny > nx)) THEN - CALL rotate_molecule(phi,sym%x_axis(:),sym,coord,error) + CALL rotate_molecule(phi,sym%x_axis(:),sym,coord) END IF END IF ELSE phi = angle(sym%sec(:,1,sym%ncn),sym%z_axis(:)) d(:) = vector_product(sym%sec(:,1,sym%ncn),sym%z_axis(:)) - CALL rotate_molecule(phi,d(:),sym,coord,error) + CALL rotate_molecule(phi,d(:),sym,coord) END IF ! Search for C2 axes perpendicular to the main axis @@ -411,9 +397,9 @@ SUBROUTINE axsym(coord,sym,error) a(:) = coord(:,iatom) IF ((ABS(a(1)) > sym%eps_geo).OR.(ABS(a(2)) > sym%eps_geo)) THEN a(3) = 0.0_dp - IF (caxis(2,a(:),sym,coord)) CALL addsec(2,a(:),sym,error) + IF (caxis(2,a(:),sym,coord)) CALL addsec(2,a(:),sym) d(:) = vector_product(a(:),sym%z_axis(:)) - IF (sigma(d(:),sym,coord)) CALL addsig(d(:),sym,error) + IF (sigma(d(:),sym,coord)) CALL addsig(d(:),sym) DO jatom=iatom+1,natoms b(:) = coord(:,jatom) IF ((ABS(b(1)) > sym%eps_geo).OR.(ABS(b(2)) > sym%eps_geo)) THEN @@ -421,9 +407,9 @@ SUBROUTINE axsym(coord,sym,error) phi = 0.5_dp*angle(a(:),b(:)) d(:) = vector_product(a(:),b(:)) b(:) = rotate_vector(a(:),phi,d(:)) - IF (caxis(2,b(:),sym,coord)) CALL addsec(2,b(:),sym,error) + IF (caxis(2,b(:),sym,coord)) CALL addsec(2,b(:),sym) d(:) = vector_product(b(:),sym%z_axis) - IF (sigma(d(:),sym,coord)) CALL addsig(d(:),sym,error) + IF (sigma(d(:),sym,coord)) CALL addsig(d(:),sym) END IF END DO END IF @@ -431,7 +417,7 @@ SUBROUTINE axsym(coord,sym,error) ! Check the xy plane for mirror plane IF (sigma(sym%z_axis(:),sym,coord)) THEN - CALL addsig(sym%z_axis(:),sym,error) + CALL addsig(sym%z_axis(:),sym) sym%sigmah = .TRUE. END IF @@ -469,7 +455,7 @@ SUBROUTINE axsym(coord,sym,error) phi = angle(a(:),sym%y_axis(:)) d(:) = vector_product(a(:),sym%y_axis(:)) END IF - CALL rotate_molecule(phi,d(:),sym,coord,error) + CALL rotate_molecule(phi,d(:),sym,coord) END IF ELSE IF (sym%sigmah) THEN ! Cnh @@ -485,7 +471,7 @@ SUBROUTINE axsym(coord,sym,error) IF (m > 0) THEN phi = angle(a(:),sym%x_axis(:)) d(:) = vector_product(a(:),sym%x_axis(:)) - CALL rotate_molecule(phi,d(:),sym,coord,error) + CALL rotate_molecule(phi,d(:),sym,coord) END IF ! No action for Dn, Cn or S2n *** END IF @@ -496,16 +482,14 @@ END SUBROUTINE axsym !> \brief Generate a symmetry list to identify equivalent atoms. !> \param sym ... !> \param coord ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE build_symequ_list(sym,coord,error) + SUBROUTINE build_symequ_list(sym,coord) TYPE(molsym_type), INTENT(inout) :: sym REAL(Kind=dp), DIMENSION(:, :), & INTENT(inout) :: coord - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_symequ_list', & routineP = moduleN//':'//routineN @@ -656,17 +640,15 @@ END FUNCTION caxis !> \param sym ... !> \param coord ... !> \param failed ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE cubsym(sym,coord,failed,error) + SUBROUTINE cubsym(sym,coord,failed) TYPE(molsym_type), INTENT(inout) :: sym REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: coord LOGICAL, INTENT(INOUT) :: failed - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, iatom, iax, ic3, isec, & jatom, jc3, jsec, katom, & @@ -688,7 +670,7 @@ SUBROUTINE cubsym(sym,coord,failed,error) DO iatom=1,natoms ! Check all atomic vectors for C3 axis IF (caxis(3,coord(:,iatom),sym,coord)) THEN - CALL addsec(3,coord(:,iatom),sym,error) + CALL addsec(3,coord(:,iatom),sym) IF (sym%nsec(3) > 1) EXIT END IF END DO @@ -707,7 +689,7 @@ SUBROUTINE cubsym(sym,coord,failed,error) - dist(coord(:,jatom),coord(:,katom))) < sym%eps_geo)) THEN b(:) = a(:) + coord(:,jatom) + coord(:,katom) IF (caxis(3,b(:),sym,coord)) THEN - CALL addsec(3,b(:),sym,error) + CALL addsec(3,b(:),sym) IF (sym%nsec(3) > 1) EXIT loop END IF END IF @@ -735,7 +717,7 @@ SUBROUTINE cubsym(sym,coord,failed,error) DO i=1,2 phi1 = 2.0_dp*REAL(i,KIND=dp)*pi/3.0_dp b(:) = rotate_vector(a(:),phi1,d(:)) - CALL addsec(3,b(:),sym,error) + CALL addsec(3,b(:),sym) END DO END IF END DO @@ -762,11 +744,11 @@ SUBROUTINE cubsym(sym,coord,failed,error) phi1 = 0.5_dp*phidd a(:) = rotate_vector(b(:),phi1,d(:)) IF (caxis(3,a(:),sym,coord)) THEN - CALL addsec(3,a(:),sym,error) + CALL addsec(3,a(:),sym) ELSE phi2 = 0.5_dp*pi - phi1 a(:) = rotate_vector(b(:),phi2,d(:)) - IF (caxis(3,a(:),sym,coord)) CALL addsec(3,a(:),sym,error) + IF (caxis(3,a(:),sym,coord)) CALL addsec(3,a(:),sym) END IF IF (sym%nsec(3) > 4) CYCLE @@ -798,10 +780,10 @@ SUBROUTINE cubsym(sym,coord,failed,error) IF (sym%nsec(3) == 10) THEN b(:) = rotate_vector(a(:),phidi,d(:)) IF (caxis(5,b(:),sym,coord)) THEN - CALL addsec(5,b(:),sym,error) + CALL addsec(5,b(:),sym) phi1 = phidi + phiii b(:) = rotate_vector(a(:),phi1,d(:)) - IF (caxis(5,b(:),sym,coord)) CALL addsec(5,b(:),sym,error) + IF (caxis(5,b(:),sym,coord)) CALL addsec(5,b(:),sym) END IF END IF @@ -810,20 +792,20 @@ SUBROUTINE cubsym(sym,coord,failed,error) phi2 = phi1 - 0.5_dp*REAL(i,KIND=dp)*pi b(:) = rotate_vector(a(:),phi2,d(:)) IF (caxis(2,b(:),sym,coord)) THEN - CALL addsec(2,b(:),sym,error) + CALL addsec(2,b(:),sym) IF (sym%nsec(3) == 4) THEN - IF (caxis(4,b(:),sym,coord)) CALL addsec(4,b(:),sym,error) + IF (caxis(4,b(:),sym,coord)) CALL addsec(4,b(:),sym) END IF IF (saxis(2,b(:),sym,coord)) THEN - CALL addses(2,b(:),sym,error) + CALL addses(2,b(:),sym) sym%invers = .TRUE. END IF END IF - IF (sigma(b(:),sym,coord)) CALL addsig(b(:),sym,error) + IF (sigma(b(:),sym,coord)) CALL addsig(b(:),sym) END DO ! Check for mirror plane - IF (sigma(d(:),sym,coord)) CALL addsig(d(:),sym,error) + IF (sigma(d(:),sym,coord)) CALL addsig(d(:),sym) END DO @@ -849,13 +831,13 @@ SUBROUTINE cubsym(sym,coord,failed,error) ! Rotate molecule to standard orientation phi1 = angle(sym%sec(:,1,iax),sym%z_axis(:)) d(:) = vector_product(sym%sec(:,1,iax),sym%z_axis(:)) - CALL rotate_molecule(phi1,d(:),sym,coord,error) + CALL rotate_molecule(phi1,d(:),sym,coord) a(:) = sym%sec(:,2,iax) a(3) = 0.0_dp phi2 = angle(a(:),sym%x_axis(:)) d(:) = vector_product(a(:),sym%x_axis(:)) - CALL rotate_molecule(phi2,d(:),sym,coord,error) + CALL rotate_molecule(phi2,d(:),sym,coord) END SUBROUTINE cubsym @@ -1009,16 +991,14 @@ END SUBROUTINE get_point_group_symbol !> \param sym ... !> \param atype ... !> \param weight ... -!> \param error ... !> \par History !> Creation (19.10.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE init_symmetry(sym,atype,weight,error) + SUBROUTINE init_symmetry(sym,atype,weight) TYPE(molsym_type), INTENT(inout) :: sym INTEGER, DIMENSION(:), INTENT(IN) :: atype REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: weight - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_symmetry', & routineP = moduleN//':'//routineN @@ -1115,16 +1095,14 @@ END FUNCTION in_symequ_list !> \brief Search for point groups of LOW SYMmetry (Ci,Cs). !> \param sym ... !> \param coord ... -!> \param error ... !> \par History !> Creation (21.04.95, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE lowsym(sym,coord,error) + SUBROUTINE lowsym(sym,coord) TYPE(molsym_type), INTENT(inout) :: sym REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: coord - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lowsym', & routineP = moduleN//':'//routineN @@ -1138,7 +1116,7 @@ SUBROUTINE lowsym(sym,coord,error) sym%invers = .TRUE. phi = angle(sym%ses(:,1,2),sym%z_axis(:)) d(:) = vector_product(sym%ses(:,1,2),sym%z_axis(:)) - CALL rotate_molecule(phi,d(:),sym,coord,error) + CALL rotate_molecule(phi,d(:),sym,coord) ELSE IF (sym%nsig == 1) THEN @@ -1146,7 +1124,7 @@ SUBROUTINE lowsym(sym,coord,error) sym%sigmah = .TRUE. phi = angle(sym%sig(:,1),sym%z_axis(:)) d(:) = vector_product(sym%sig(:,1),sym%z_axis(:)) - CALL rotate_molecule(phi,d(:),sym,coord,error) + CALL rotate_molecule(phi,d(:),sym,coord) END IF @@ -1159,19 +1137,17 @@ END SUBROUTINE lowsym !> \param coord ... !> \param atype ... !> \param weight ... -!> \param error ... !> \par History !> Creation (14.11.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE molecular_symmetry(sym,eps_geo,coord,atype,weight,error) + SUBROUTINE molecular_symmetry(sym,eps_geo,coord,atype,weight) TYPE(molsym_type), POINTER :: sym REAL(KIND=dp), INTENT(IN) :: eps_geo REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: coord INTEGER, DIMENSION(:), INTENT(IN) :: atype REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: weight - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'molecular_symmetry', & routineP = moduleN//':'//routineN @@ -1182,18 +1158,18 @@ SUBROUTINE molecular_symmetry(sym,eps_geo,coord,atype,weight,error) ! Perform memory allocation for the symmetry analysis natoms = SIZE(coord,2) - CALL create_molsym(sym,natoms,error) + CALL create_molsym(sym,natoms) sym%eps_geo=eps_geo ! Initialization of symmetry analysis - CALL init_symmetry(sym,atype,weight,error) + CALL init_symmetry(sym,atype,weight) IF (natoms == 1) THEN ! Special case: only one atom - CALL atomsym(sym,error) + CALL atomsym(sym) ELSE ! Find molecular symmetry - CALL moleculesym(sym,coord,error) + CALL moleculesym(sym,coord) ! Get point group and load point group table CALL get_point_group_symbol(sym) END IF @@ -1202,7 +1178,7 @@ SUBROUTINE molecular_symmetry(sym,eps_geo,coord,atype,weight,error) IF (.NOT.sym%linear) CALL get_point_group_order(sym) ! Generate a list of equivalent atoms - CALL build_symequ_list(sym,coord,error) + CALL build_symequ_list(sym,coord) CALL timestop(handle) @@ -1212,16 +1188,14 @@ END SUBROUTINE molecular_symmetry !> \brief Find the molecular symmetry. !> \param sym ... !> \param coord ... -!> \param error ... !> \par History !> Creation (14.11.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE moleculesym(sym,coord,error) + SUBROUTINE moleculesym(sym,coord) TYPE(molsym_type), INTENT(inout) :: sym REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: coord - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'moleculesym', & routineP = moduleN//':'//routineN @@ -1235,7 +1209,7 @@ SUBROUTINE moleculesym(sym,coord,error) eps_tenval = 0.01_dp*sym%eps_geo ! Calculate the molecular tensor of inertia - CALL tensor(sym,coord,error) + CALL tensor(sym,coord) ! Use symmetry information from the eigenvalues of the molecular tensor of inertia IF ((sym%tenval(3) - sym%tenval(1)) < eps_tenval) THEN ! 0 < tenval(1) = tenval(2) = tenval(3) @@ -1254,7 +1228,7 @@ SUBROUTINE moleculesym(sym,coord,error) DO failed = .FALSE. IF (sym%cubic) THEN - CALL cubsym(sym,coord,failed,error) + CALL cubsym(sym,coord,failed) IF (failed) THEN sym%cubic = .FALSE. CYCLE @@ -1273,30 +1247,30 @@ SUBROUTINE moleculesym(sym,coord,error) ! Check the new coordinate axes for Cn axes DO icn=2,maxcn - IF (caxis(icn,sym%z_axis(:),sym,coord)) CALL addsec(icn,sym%z_axis(:),sym,error) - IF (caxis(icn,sym%x_axis(:),sym,coord)) CALL addsec(icn,sym%x_axis(:),sym,error) - IF (caxis(icn,sym%y_axis(:),sym,coord)) CALL addsec(icn,sym%y_axis(:),sym,error) + IF (caxis(icn,sym%z_axis(:),sym,coord)) CALL addsec(icn,sym%z_axis(:),sym) + IF (caxis(icn,sym%x_axis(:),sym,coord)) CALL addsec(icn,sym%x_axis(:),sym) + IF (caxis(icn,sym%y_axis(:),sym,coord)) CALL addsec(icn,sym%y_axis(:),sym) END DO ! Check the new coordinate axes for Sn axes DO isn=2,maxsn - IF (saxis(isn,sym%z_axis(:),sym,coord)) CALL addses(isn,sym%z_axis(:),sym,error) - IF (saxis(isn,sym%x_axis(:),sym,coord)) CALL addses(isn,sym%x_axis(:),sym,error) - IF (saxis(isn,sym%y_axis(:),sym,coord)) CALL addses(isn,sym%y_axis(:),sym,error) + IF (saxis(isn,sym%z_axis(:),sym,coord)) CALL addses(isn,sym%z_axis(:),sym) + IF (saxis(isn,sym%x_axis(:),sym,coord)) CALL addses(isn,sym%x_axis(:),sym) + IF (saxis(isn,sym%y_axis(:),sym,coord)) CALL addses(isn,sym%y_axis(:),sym) END DO ! Check the new coordinate planes for mirror planes - IF (sigma(sym%z_axis(:),sym,coord)) CALL addsig(sym%z_axis(:),sym,error) - IF (sigma(sym%x_axis(:),sym,coord)) CALL addsig(sym%x_axis(:),sym,error) - IF (sigma(sym%y_axis(:),sym,coord)) CALL addsig(sym%y_axis(:),sym,error) + IF (sigma(sym%z_axis(:),sym,coord)) CALL addsig(sym%z_axis(:),sym) + IF (sigma(sym%x_axis(:),sym,coord)) CALL addsig(sym%x_axis(:),sym) + IF (sigma(sym%y_axis(:),sym,coord)) CALL addsig(sym%y_axis(:),sym) ! There is a main axis (MAXIS = .TRUE.) IF ((sym%ncn > 1).OR.(sym%nsn > 3)) THEN sym%maxis = .TRUE. - CALL axsym(coord,sym,error) + CALL axsym(coord,sym) ELSE ! Only low or no symmetry (Ci, Cs or C1) - CALL lowsym(sym,coord,error) + CALL lowsym(sym,coord) END IF END IF @@ -1310,9 +1284,9 @@ SUBROUTINE moleculesym(sym,coord,error) DO icn=2,sym%ncn DO isec=1,sym%nsec(icn) IF (saxis(icn,sym%sec(:,isec,icn),sym,coord)) & - CALL addses(icn,sym%sec(:,isec,icn),sym,error) + CALL addses(icn,sym%sec(:,isec,icn),sym) IF (saxis(2*icn,sym%sec(:,isec,icn),sym,coord)) & - CALL addses(2*icn,sym%sec(:,isec,icn),sym,error) + CALL addses(2*icn,sym%sec(:,isec,icn),sym) END DO END DO END IF @@ -1321,7 +1295,7 @@ SUBROUTINE moleculesym(sym,coord,error) IF (sym%nses(2) > 0) THEN sym%nses(1) = sym%nses(1) - sym%nses(2) sym%nses(2) = 0 - CALL addses(2,sym%z_axis(:),sym,error) + CALL addses(2,sym%z_axis(:),sym) END IF END SUBROUTINE moleculesym @@ -1485,12 +1459,11 @@ END SUBROUTINE outse !> \param weight ... !> \param iw ... !> \param plevel ... -!> \param error ... !> \par History !> Creation (16.11.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE print_symmetry(sym,coord,atype,element,z,weight,iw,plevel,error) + SUBROUTINE print_symmetry(sym,coord,atype,element,z,weight,iw,plevel) TYPE(molsym_type), INTENT(inout) :: sym REAL(KIND=dp), DIMENSION(:, :), & INTENT(in) :: coord @@ -1500,7 +1473,6 @@ SUBROUTINE print_symmetry(sym,coord,atype,element,z,weight,iw,plevel,error) INTEGER, DIMENSION(:), INTENT(in) :: z REAL(KIND=dp), DIMENSION(:), INTENT(in) :: weight INTEGER, INTENT(IN) :: iw, plevel - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_symmetry', & routineP = moduleN//':'//routineN @@ -1524,7 +1496,7 @@ SUBROUTINE print_symmetry(sym,coord,atype,element,z,weight,iw,plevel,error) IF ( MOD(plevel,10) == 1 ) THEN ! Print the Cartesian coordinates of the standard orientation - CALL write_coordinates(coord,atype,element,z,weight,iw,error) + CALL write_coordinates(coord,atype,element,z,weight,iw) WRITE (iw,"(/,T3,A,(T41,10I4))") "Group Number: 1 Group Members:",& (sym%symequ_list(iequatom),iequatom=sym%llequatom(1),sym%ulequatom(1)) @@ -1602,18 +1574,16 @@ END SUBROUTINE print_symmetry !> \param a ... !> \param sym ... !> \param coord ... -!> \param error ... !> \par History !> Creation (16.11.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE rotate_molecule(phi,a,sym,coord,error) + SUBROUTINE rotate_molecule(phi,a,sym,coord) REAL(KIND=dp), INTENT(IN) :: phi REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: a TYPE(molsym_type), INTENT(inout) :: sym REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: coord - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotate_molecule', & routineP = moduleN//':'//routineN @@ -1748,16 +1718,14 @@ END FUNCTION sigma !> center of mass of the molecule. !> \param sym ... !> \param coord ... -!> \param error ... !> \par History !> Creation (16.11.98, Matthias Krack) !> \author jgh ! ***************************************************************************** - SUBROUTINE tensor(sym,coord,error) + SUBROUTINE tensor(sym,coord) TYPE(molsym_type), INTENT(inout) :: sym REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: coord - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tensor', & routineP = moduleN//':'//routineN @@ -1797,7 +1765,7 @@ SUBROUTINE tensor(sym,coord,error) sym%tenvec(:,3) = vector_product(sym%tenvec(:,1),sym%tenvec(:,2)) tt = SQRT(sym%tenval(1)**2 + sym%tenval(2)**2 + sym%tenval(3)**2) - CPPostcondition(tt /= 0,cp_failure_level,routineP,error,failure) + CPPostcondition(tt /= 0,cp_failure_level,routineP,failure) END SUBROUTINE tensor @@ -1853,11 +1821,10 @@ FUNCTION dist(a,b) RESULT(d) !> \param z ... !> \param weight ... !> \param iw ... -!> \param error ... !> \date 08.05.2008 !> \author JGH ! ***************************************************************************** - SUBROUTINE write_coordinates(coord,atype,element,z,weight,iw,error) + SUBROUTINE write_coordinates(coord,atype,element,z,weight,iw) REAL(KIND=dp), DIMENSION(:, :), & INTENT(in) :: coord INTEGER, DIMENSION(:), INTENT(in) :: atype @@ -1866,7 +1833,6 @@ SUBROUTINE write_coordinates(coord,atype,element,z,weight,iw,error) INTEGER, DIMENSION(:), INTENT(in) :: z REAL(KIND=dp), DIMENSION(:), INTENT(in) :: weight INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iatom, natom diff --git a/src/moments_utils.F b/src/moments_utils.F index 10a3e36dad..a6a896145c 100644 --- a/src/moments_utils.F +++ b/src/moments_utils.F @@ -54,10 +54,9 @@ MODULE moments_utils !> \param ref_point ... !> \param ifirst ... !> \param ilast ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_reference_point(rpoint,drpoint,qs_env,fist_env,reference,ref_point,& - ifirst, ilast, error) + ifirst, ilast) REAL(dp), DIMENSION(3), INTENT(OUT) :: rpoint REAL(dp), DIMENSION(3), INTENT(OUT), & OPTIONAL :: drpoint @@ -68,7 +67,6 @@ SUBROUTINE get_reference_point(rpoint,drpoint,qs_env,fist_env,reference,ref_poin INTEGER, INTENT(IN) :: reference REAL(KIND=dp), DIMENSION(:), POINTER :: ref_point INTEGER, INTENT(IN), OPTIONAL :: ifirst, ilast - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_reference_point', & routineP = moduleN//':'//routineN @@ -88,16 +86,16 @@ SUBROUTINE get_reference_point(rpoint,drpoint,qs_env,fist_env,reference,ref_poin POINTER :: qs_kind_set failure = .FALSE. - CPPostcondition(PRESENT(ifirst).EQV.PRESENT(ilast),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(ifirst).EQV.PRESENT(ilast),cp_failure_level,routineP,failure) NULLIFY ( cell, particle_set, qs_kind_set, local_particles, para_env ) IF (PRESENT(qs_env)) THEN CALL get_qs_env ( qs_env, cell=cell, particle_set=particle_set, & qs_kind_set=qs_kind_set,& - local_particles=local_particles, para_env=para_env, error=error) + local_particles=local_particles, para_env=para_env) END IF IF (PRESENT(fist_env)) THEN CALL fist_env_get( fist_env, cell=cell, particle_set=particle_set, & - local_particles=local_particles, para_env=para_env, error=error) + local_particles=local_particles, para_env=para_env) END IF do_molecule = .FALSE. IF (PRESENT(ifirst).AND.PRESENT(ilast)) do_molecule = .TRUE. @@ -106,7 +104,7 @@ SUBROUTINE get_reference_point(rpoint,drpoint,qs_env,fist_env,reference,ref_poin CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Type of reference point not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE (use_mom_ref_com) rpoint = 0._dp mtot = 0._dp @@ -169,7 +167,7 @@ SUBROUTINE get_reference_point(rpoint,drpoint,qs_env,fist_env,reference,ref_poin ria = pbc(ria-center,cell)+center atomic_kind => particle_set(iatom)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=akind ) - CALL get_qs_kind(qs_kind_set(akind), core_charge=charge,error=error) + CALL get_qs_kind(qs_kind_set(akind), core_charge=charge) rpoint(:) = rpoint(:) + charge*ria(:) IF (PRESENT(drpoint)) drpoint = drpoint + charge*particle_set(iatom)%v ztot = ztot + charge @@ -182,7 +180,7 @@ SUBROUTINE get_reference_point(rpoint,drpoint,qs_env,fist_env,reference,ref_poin ria = pbc(ria,cell) atomic_kind => particle_set(iatom)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=akind ) - CALL get_qs_kind(qs_kind_set(akind), core_charge=charge,error=error) + CALL get_qs_kind(qs_kind_set(akind), core_charge=charge) rpoint(:) = rpoint(:) + charge*ria(:) IF (PRESENT(drpoint)) drpoint = drpoint + charge*particle_set(iatom)%v ztot = ztot + charge diff --git a/src/motion/averages_types.F b/src/motion/averages_types.F index e36a7190b9..443a81192f 100644 --- a/src/motion/averages_types.F +++ b/src/motion/averages_types.F @@ -73,15 +73,13 @@ MODULE averages_types !> \param averages_section ... !> \param virial_avg ... !> \param force_env ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE create_averages(averages, averages_section, virial_avg, force_env, error) + SUBROUTINE create_averages(averages, averages_section, virial_avg, force_env) TYPE(average_quantities_type), POINTER :: averages TYPE(section_vals_type), POINTER :: averages_section LOGICAL, INTENT(IN), OPTIONAL :: virial_avg TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_averages', & routineP = moduleN//':'//routineN @@ -91,7 +89,7 @@ SUBROUTINE create_averages(averages, averages_section, virial_avg, force_env, er failure = .FALSE. ALLOCATE (averages, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(averages%virial) NULLIFY(averages%avecolvar) NULLIFY(averages%aveMmatrix) @@ -122,21 +120,20 @@ SUBROUTINE create_averages(averages, averages_section, virial_avg, force_env, er averages%avetemp_qm = 0.0_dp averages%avekin_qm = 0.0_dp averages%econs = 0.0_dp - CALL section_vals_val_get(averages_section,"_SECTION_PARAMETERS_",l_val=averages%do_averages,& - error=error) + CALL section_vals_val_get(averages_section,"_SECTION_PARAMETERS_",l_val=averages%do_averages) IF (averages%do_averages) THEN ! Setup Virial if requested IF (PRESENT(virial_avg)) THEN - IF (virial_avg) CALL virial_create(averages%virial, error) + IF (virial_avg) CALL virial_create(averages%virial) END IF - CALL section_vals_val_get(averages_section,"AVERAGE_COLVAR",l_val=do_colvars,error=error) + CALL section_vals_val_get(averages_section,"AVERAGE_COLVAR",l_val=do_colvars) ! Total number of COLVARs nint = 0 - IF (do_colvars) nint = number_of_colvar(force_env, error=error) + IF (do_colvars) nint = number_of_colvar(force_env) ALLOCATE(averages%avecolvar(nint), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(averages%aveMmatrix(nint*nint), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nint averages%avecolvar(i) = 0.0_dp END DO @@ -149,12 +146,10 @@ END SUBROUTINE create_averages ! ***************************************************************************** !> \brief retains the given averages env !> \param averages ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE retain_averages(averages, error) + SUBROUTINE retain_averages(averages) TYPE(average_quantities_type), POINTER :: averages - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_averages', & routineP = moduleN//':'//routineN @@ -163,20 +158,18 @@ SUBROUTINE retain_averages(averages, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(averages),cp_failure_level,routineP,error,failure) - CPPrecondition(averages%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(averages),cp_failure_level,routineP,failure) + CPPrecondition(averages%ref_count>0,cp_failure_level,routineP,failure) averages%ref_count=averages%ref_count+1 END SUBROUTINE retain_averages ! ***************************************************************************** !> \brief releases the given averages env !> \param averages ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE release_averages(averages, error) + SUBROUTINE release_averages(averages) TYPE(average_quantities_type), POINTER :: averages - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_averages', & routineP = moduleN//':'//routineN @@ -187,25 +180,25 @@ SUBROUTINE release_averages(averages, error) failure=.FALSE. IF (ASSOCIATED(averages)) THEN - CPPrecondition(averages%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(averages%ref_count>0,cp_failure_level,routineP,failure) averages%ref_count=averages%ref_count-1 IF (averages%ref_count==0) THEN - CALL virial_release(averages%virial, error) + CALL virial_release(averages%virial) IF (ASSOCIATED(averages%avecolvar)) THEN DEALLOCATE(averages%avecolvar, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(averages%aveMmatrix)) THEN DEALLOCATE(averages%aveMmatrix, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Removes restart values from the corresponding restart section.. - work_section => section_vals_get_subs_vals(averages%averages_section,"RESTART_AVERAGES",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(averages%averages_section,"RESTART_AVERAGES") + CALL section_vals_remove_values(work_section) NULLIFY(averages%averages_section) ! DEALLOCATE(averages,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -229,12 +222,11 @@ END SUBROUTINE release_averages !> \param time ... !> \param my_pos ... !> \param my_act ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2008 - University of Zurich ! ***************************************************************************** SUBROUTINE compute_averages (averages, force_env, md_ener, cell, virial, & pv_scalar, pv_xx, used_time, hugoniot, abc, cell_angle, nat, itimes, & - time, my_pos, my_act, error) + time, my_pos, my_act) TYPE(average_quantities_type), POINTER :: averages TYPE(force_env_type), POINTER :: force_env TYPE(md_ener_type), POINTER :: md_ener @@ -248,7 +240,6 @@ SUBROUTINE compute_averages (averages, force_env, md_ener, cell, virial, & REAL(KIND=dp), INTENT(IN) :: time CHARACTER(LEN=default_string_length), & INTENT(IN) :: my_pos, my_act - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_averages', & routineP = moduleN//':'//routineN @@ -265,10 +256,10 @@ SUBROUTINE compute_averages (averages, force_env, md_ener, cell, virial, & failure = .FALSE. CALL timeset(routineN,handle) CALL section_vals_val_get(averages%averages_section,"ACQUISITION_START_TIME",& - r_val=start_time, error=error) + r_val=start_time) IF (averages%do_averages) THEN NULLIFY(cvalues, Mmatrix, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Determine the nr. of internal colvar (if any/requested) nint = 0 IF (ASSOCIATED(averages%avecolvar)) nint = SIZE(averages%avecolvar) @@ -278,51 +269,51 @@ SUBROUTINE compute_averages (averages, force_env, md_ener, cell, virial, & ! Handling properly the restart IF (averages%itimes_start==-1) THEN - restart_section => section_vals_get_subs_vals(averages%averages_section,"RESTART_AVERAGES",error=error) - CALL section_vals_get(restart_section, explicit=restart_averages, error=error) + restart_section => section_vals_get_subs_vals(averages%averages_section,"RESTART_AVERAGES") + CALL section_vals_get(restart_section, explicit=restart_averages) IF (restart_averages) THEN - CALL section_vals_val_get(restart_section,"ITIMES_START",i_val=averages%itimes_start,error=error) - CALL section_vals_val_get(restart_section,"AVECPU",r_val=averages%avecpu,error=error) - CALL section_vals_val_get(restart_section,"AVEHUGONIOT",r_val=averages%avehugoniot,error=error) - CALL section_vals_val_get(restart_section,"AVETEMP_BARO",r_val=averages%avetemp_baro,error=error) - CALL section_vals_val_get(restart_section,"AVEPOT",r_val=averages%avepot,error=error) - CALL section_vals_val_get(restart_section,"AVEKIN",r_val=averages%avekin,error=error) - CALL section_vals_val_get(restart_section,"AVETEMP",r_val=averages%avetemp,error=error) - CALL section_vals_val_get(restart_section,"AVEKIN_QM",r_val=averages%avekin_qm,error=error) - CALL section_vals_val_get(restart_section,"AVETEMP_QM",r_val=averages%avetemp_qm,error=error) - CALL section_vals_val_get(restart_section,"AVEVOL",r_val=averages%avevol,error=error) - CALL section_vals_val_get(restart_section,"AVECELL_A",r_val=averages%aveca,error=error) - CALL section_vals_val_get(restart_section,"AVECELL_B",r_val=averages%avecb,error=error) - CALL section_vals_val_get(restart_section,"AVECELL_C",r_val=averages%avecc,error=error) - CALL section_vals_val_get(restart_section,"AVEALPHA",r_val=averages%aveal,error=error) - CALL section_vals_val_get(restart_section,"AVEBETA",r_val=averages%avebe,error=error) - CALL section_vals_val_get(restart_section,"AVEGAMMA",r_val=averages%avega,error=error) - CALL section_vals_val_get(restart_section,"AVE_ECONS",r_val=averages%econs,error=error) + CALL section_vals_val_get(restart_section,"ITIMES_START",i_val=averages%itimes_start) + CALL section_vals_val_get(restart_section,"AVECPU",r_val=averages%avecpu) + CALL section_vals_val_get(restart_section,"AVEHUGONIOT",r_val=averages%avehugoniot) + CALL section_vals_val_get(restart_section,"AVETEMP_BARO",r_val=averages%avetemp_baro) + CALL section_vals_val_get(restart_section,"AVEPOT",r_val=averages%avepot) + CALL section_vals_val_get(restart_section,"AVEKIN",r_val=averages%avekin) + CALL section_vals_val_get(restart_section,"AVETEMP",r_val=averages%avetemp) + CALL section_vals_val_get(restart_section,"AVEKIN_QM",r_val=averages%avekin_qm) + CALL section_vals_val_get(restart_section,"AVETEMP_QM",r_val=averages%avetemp_qm) + CALL section_vals_val_get(restart_section,"AVEVOL",r_val=averages%avevol) + CALL section_vals_val_get(restart_section,"AVECELL_A",r_val=averages%aveca) + CALL section_vals_val_get(restart_section,"AVECELL_B",r_val=averages%avecb) + CALL section_vals_val_get(restart_section,"AVECELL_C",r_val=averages%avecc) + CALL section_vals_val_get(restart_section,"AVEALPHA",r_val=averages%aveal) + CALL section_vals_val_get(restart_section,"AVEBETA",r_val=averages%avebe) + CALL section_vals_val_get(restart_section,"AVEGAMMA",r_val=averages%avega) + CALL section_vals_val_get(restart_section,"AVE_ECONS",r_val=averages%econs) ! Virial IF (virial%pv_availability) THEN - CALL section_vals_val_get(restart_section,"AVE_PRESS",r_val=averages%avepress,error=error) - CALL section_vals_val_get(restart_section,"AVE_PXX",r_val=averages%avepxx,error=error) + CALL section_vals_val_get(restart_section,"AVE_PRESS",r_val=averages%avepress) + CALL section_vals_val_get(restart_section,"AVE_PXX",r_val=averages%avepxx) IF (ASSOCIATED(averages%virial)) THEN - CALL section_vals_val_get(restart_section,"AVE_PV_TOT",r_vals=tmp,error=error) + CALL section_vals_val_get(restart_section,"AVE_PV_TOT",r_vals=tmp) averages%virial%pv_total = RESHAPE(tmp,(/3,3/)) - CALL section_vals_val_get(restart_section,"AVE_PV_VIR",r_vals=tmp,error=error) + CALL section_vals_val_get(restart_section,"AVE_PV_VIR",r_vals=tmp) averages%virial%pv_virial = RESHAPE(tmp,(/3,3/)) - CALL section_vals_val_get(restart_section,"AVE_PV_KIN",r_vals=tmp,error=error) + CALL section_vals_val_get(restart_section,"AVE_PV_KIN",r_vals=tmp) averages%virial%pv_kinetic = RESHAPE(tmp,(/3,3/)) - CALL section_vals_val_get(restart_section,"AVE_PV_CNSTR",r_vals=tmp,error=error) + CALL section_vals_val_get(restart_section,"AVE_PV_CNSTR",r_vals=tmp) averages%virial%pv_constraint = RESHAPE(tmp,(/3,3/)) - CALL section_vals_val_get(restart_section,"AVE_PV_XC",r_vals=tmp,error=error) + CALL section_vals_val_get(restart_section,"AVE_PV_XC",r_vals=tmp) averages%virial%pv_xc = RESHAPE(tmp,(/3,3/)) - CALL section_vals_val_get(restart_section,"AVE_PV_FOCK_4C",r_vals=tmp,error=error) + CALL section_vals_val_get(restart_section,"AVE_PV_FOCK_4C",r_vals=tmp) averages%virial%pv_fock_4c = RESHAPE(tmp,(/3,3/)) END IF END IF ! Colvars IF (nint>0) THEN - CALL section_vals_val_get(restart_section,"AVE_COLVARS",r_vals=cvalues,error=error) - CALL section_vals_val_get(restart_section,"AVE_MMATRIX",r_vals=Mmatrix,error=error) - CPPostcondition(nint==SIZE(cvalues),cp_failure_level,routineP,error,failure) - CPPostcondition(nint*nint==SIZE(Mmatrix),cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(restart_section,"AVE_COLVARS",r_vals=cvalues) + CALL section_vals_val_get(restart_section,"AVE_MMATRIX",r_vals=Mmatrix) + CPPostcondition(nint==SIZE(cvalues),cp_failure_level,routineP,failure) + CPPostcondition(nint*nint==SIZE(Mmatrix),cp_failure_level,routineP,failure) averages%avecolvar = cvalues averages%aveMmatrix = Mmatrix END IF @@ -367,59 +358,59 @@ SUBROUTINE compute_averages (averages, force_env, md_ener, cell, virial, & ! Colvars IF (nint>0) THEN CALL get_clv_force(force_env, nsize_xyz=nat*3, nsize_int=nint, & - cvalues=averages%avecolvar,Mmatrix=averages%aveMmatrix, error=error) + cvalues=averages%avecolvar,Mmatrix=averages%aveMmatrix) END IF CASE DEFAULT - CALL get_averages(averages%avecpu,used_time,delta_t,error) - CALL get_averages(averages%avehugoniot,hugoniot,delta_t,error) - CALL get_averages(averages%avetemp_baro,md_ener%temp_baro,delta_t,error) - CALL get_averages(averages%avepot,md_ener%epot,delta_t,error) - CALL get_averages(averages%avekin,md_ener%ekin,delta_t,error) - CALL get_averages(averages%avetemp,md_ener%temp_part,delta_t,error) - CALL get_averages(averages%avekin_qm,md_ener%ekin_qm,delta_t,error) - CALL get_averages(averages%avetemp_qm,md_ener%temp_qm,delta_t,error) - CALL get_averages(averages%avevol,cell%deth,delta_t,error) - CALL get_averages(averages%aveca,abc(1),delta_t,error) - CALL get_averages(averages%avecb,abc(2),delta_t,error) - CALL get_averages(averages%avecc,abc(3),delta_t,error) - CALL get_averages(averages%aveal,cell_angle(3),delta_t,error) - CALL get_averages(averages%avebe,cell_angle(2),delta_t,error) - CALL get_averages(averages%avega,cell_angle(1),delta_t,error) - CALL get_averages(averages%econs,md_ener%delta_cons,delta_t,error) + CALL get_averages(averages%avecpu,used_time,delta_t) + CALL get_averages(averages%avehugoniot,hugoniot,delta_t) + CALL get_averages(averages%avetemp_baro,md_ener%temp_baro,delta_t) + CALL get_averages(averages%avepot,md_ener%epot,delta_t) + CALL get_averages(averages%avekin,md_ener%ekin,delta_t) + CALL get_averages(averages%avetemp,md_ener%temp_part,delta_t) + CALL get_averages(averages%avekin_qm,md_ener%ekin_qm,delta_t) + CALL get_averages(averages%avetemp_qm,md_ener%temp_qm,delta_t) + CALL get_averages(averages%avevol,cell%deth,delta_t) + CALL get_averages(averages%aveca,abc(1),delta_t) + CALL get_averages(averages%avecb,abc(2),delta_t) + CALL get_averages(averages%avecc,abc(3),delta_t) + CALL get_averages(averages%aveal,cell_angle(3),delta_t) + CALL get_averages(averages%avebe,cell_angle(2),delta_t) + CALL get_averages(averages%avega,cell_angle(1),delta_t) + CALL get_averages(averages%econs,md_ener%delta_cons,delta_t) ! Virial IF (virial%pv_availability) THEN - CALL get_averages(averages%avepress,pv_scalar,delta_t,error) - CALL get_averages(averages%avepxx,pv_xx,delta_t,error) + CALL get_averages(averages%avepress,pv_scalar,delta_t) + CALL get_averages(averages%avepxx,pv_xx,delta_t) IF (ASSOCIATED(averages%virial)) THEN - CALL get_averages(averages%virial%pv_total,virial%pv_total,delta_t,error) - CALL get_averages(averages%virial%pv_virial,virial%pv_virial,delta_t,error) - CALL get_averages(averages%virial%pv_kinetic,virial%pv_kinetic,delta_t,error) - CALL get_averages(averages%virial%pv_constraint,virial%pv_constraint,delta_t,error) - CALL get_averages(averages%virial%pv_xc,virial%pv_xc,delta_t,error) - CALL get_averages(averages%virial%pv_fock_4c,virial%pv_fock_4c,delta_t,error) + CALL get_averages(averages%virial%pv_total,virial%pv_total,delta_t) + CALL get_averages(averages%virial%pv_virial,virial%pv_virial,delta_t) + CALL get_averages(averages%virial%pv_kinetic,virial%pv_kinetic,delta_t) + CALL get_averages(averages%virial%pv_constraint,virial%pv_constraint,delta_t) + CALL get_averages(averages%virial%pv_xc,virial%pv_xc,delta_t) + CALL get_averages(averages%virial%pv_fock_4c,virial%pv_fock_4c,delta_t) END IF END IF ! Colvars IF (nint>0) THEN ALLOCATE(cvalues(nint),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Mmatrix(nint*nint),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_clv_force(force_env, nsize_xyz=nat*3, nsize_int=nint, cvalues=cvalues,& - Mmatrix=Mmatrix, error=error) - CALL get_averages(averages%avecolvar, cvalues, delta_t,error) - CALL get_averages(averages%aveMmatrix, Mmatrix, delta_t,error) + Mmatrix=Mmatrix) + CALL get_averages(averages%avecolvar, cvalues, delta_t) + CALL get_averages(averages%aveMmatrix, Mmatrix, delta_t) DEALLOCATE(cvalues,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Mmatrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SELECT END IF ! Possibly print averages output_unit = cp_print_key_unit_nr(logger,averages%averages_section,"PRINT_AVERAGES",& - extension=".avg", file_position=my_pos, file_action=my_act, error=error) + extension=".avg", file_position=my_pos, file_action=my_act) IF (output_unit>0) THEN WRITE(output_unit,FMT='(A15,1X,"=",1X,G15.9," NSTEP #",I15)')& "AVECPU",averages%avecpu,itimes,& @@ -461,7 +452,7 @@ SUBROUTINE compute_averages (averages, force_env, md_ener, cell, virial, & WRITE(output_unit,FMT='(/)') END IF CALL cp_print_key_finished_output(output_unit,logger,averages%averages_section,& - "PRINT_AVERAGES", error=error) + "PRINT_AVERAGES") END IF CALL timestop(handle) END SUBROUTINE compute_averages @@ -471,14 +462,12 @@ END SUBROUTINE compute_averages !> \param avg ... !> \param add ... !> \param delta_t ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE get_averages_rs(avg, add, delta_t, error) + SUBROUTINE get_averages_rs(avg, add, delta_t) REAL(KIND=dp), INTENT(INOUT) :: avg REAL(KIND=dp), INTENT(IN) :: add INTEGER, INTENT(IN) :: delta_t - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_averages_rs', & routineP = moduleN//':'//routineN @@ -494,15 +483,13 @@ END SUBROUTINE get_averages_rs !> \param avg ... !> \param add ... !> \param delta_t ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE get_averages_rv(avg, add, delta_t, error) + SUBROUTINE get_averages_rv(avg, add, delta_t) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: avg REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: add INTEGER, INTENT(IN) :: delta_t - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_averages_rv', & routineP = moduleN//':'//routineN @@ -512,7 +499,7 @@ SUBROUTINE get_averages_rv(avg, add, delta_t, error) failure = .FALSE. check = SIZE(avg)==SIZE(add) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) DO i = 1, SIZE(avg) avg(i) = (avg(i)*REAL(delta_t-1,dp) + add(i))/REAL(delta_t,dp) END DO @@ -523,16 +510,14 @@ END SUBROUTINE get_averages_rv !> \param avg ... !> \param add ... !> \param delta_t ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE get_averages_rm(avg, add, delta_t, error) + SUBROUTINE get_averages_rm(avg, add, delta_t) REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: avg REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: add INTEGER, INTENT(IN) :: delta_t - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_averages_rm', & routineP = moduleN//':'//routineN @@ -542,9 +527,9 @@ SUBROUTINE get_averages_rm(avg, add, delta_t, error) failure = .FALSE. check = SIZE(avg,1)==SIZE(add,1) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) check = SIZE(avg,2)==SIZE(add,2) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) DO i = 1, SIZE(avg,2) DO j = 1, SIZE(avg,1) avg(j,i) = (avg(j,i)*REAL(delta_t-1,dp) + add(j,i))/REAL(delta_t,dp) diff --git a/src/motion/bfgs_optimizer.F b/src/motion/bfgs_optimizer.F index b24f1e3850..5d91118023 100644 --- a/src/motion/bfgs_optimizer.F +++ b/src/motion/bfgs_optimizer.F @@ -89,10 +89,8 @@ MODULE bfgs_optimizer !> \param geo_section ... !> \param gopt_env ... !> \param x0 ... -!> \param error ... ! ***************************************************************************** - RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_env,x0,& - error) + RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_env,x0) TYPE(force_env_type), POINTER :: force_env TYPE(gopt_param_type), POINTER :: gopt_param @@ -100,7 +98,6 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e TYPE(section_vals_type), POINTER :: geo_section TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'geoopt_bfgs', & routineP = moduleN//':'//routineN @@ -133,14 +130,14 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e failure = .FALSE. NULLIFY(logger, g,blacs_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() para_env => force_env%para_env root_section => force_env%root_section t_old=m_walltime() CALL timeset(routineN,handle) - CALL section_vals_val_get(geo_section,"BFGS%TRUST_RADIUS",r_val=rad,error=error) - print_key => section_vals_get_subs_vals(geo_section,"BFGS%RESTART", error=error) + CALL section_vals_val_get(geo_section,"BFGS%TRUST_RADIUS",r_val=rad) + print_key => section_vals_get_subs_vals(geo_section,"BFGS%RESTART") ionode = para_env%mepos==para_env%source maxiter = gopt_param%max_iter cell_opt = .FALSE. @@ -153,14 +150,14 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e CASE (default_ts_method_id) CALL cp_unimplemented_error(fromWhere=routineP, & message="BFGS method not yet working with DIMER", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT - CALL section_vals_val_get(geo_section,"BFGS%USE_RAT_FUN_OPT",l_val=use_rfo,error=error) - CALL section_vals_val_get(geo_section,"BFGS%USE_MODEL_HESSIAN",l_val=use_mod_hes,error=error) - CALL section_vals_val_get(geo_section,"BFGS%RESTART_HESSIAN",l_val=hesrest,error=error) + CALL section_vals_val_get(geo_section,"BFGS%USE_RAT_FUN_OPT",l_val=use_rfo) + CALL section_vals_val_get(geo_section,"BFGS%USE_MODEL_HESSIAN",l_val=use_mod_hes) + CALL section_vals_val_get(geo_section,"BFGS%RESTART_HESSIAN",l_val=hesrest) output_unit = cp_print_key_unit_nr(logger,geo_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".geoLog",error=error) + extension=".geoLog") ndf = SIZE(x0) nfree = gopt_env%nfree @@ -174,18 +171,18 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e ! Initialize hessian (hes = unitary matrix or model hessian ) CALL cp_blacs_env_create(blacs_env,para_env,globenv%blacs_grid_layout,& - globenv%blacs_repeatable,error=error) + globenv%blacs_repeatable) CALL cp_fm_struct_create(fm_struct_hes,para_env=para_env,context=blacs_env, & - nrow_global=ndf,ncol_global=ndf,error=error) - CALL cp_fm_create(hess_mat, fm_struct_hes,name="hess_mat",error=error) - CALL cp_fm_create(hess_tmp, fm_struct_hes,name="hess_tmp",error=error) - CALL cp_fm_create(eigvec_mat, fm_struct_hes,name="eigvec_mat",error=error) + nrow_global=ndf,ncol_global=ndf) + CALL cp_fm_create(hess_mat, fm_struct_hes,name="hess_mat") + CALL cp_fm_create(hess_tmp, fm_struct_hes,name="hess_tmp") + CALL cp_fm_create(eigvec_mat, fm_struct_hes,name="eigvec_mat") ALLOCATE (eigval(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) eigval(:) = 0.0_dp - CALL force_env_get(force_env=force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,error=error) + CALL force_env_get(force_env=force_env,subsys=subsys) + CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds) CALL get_atomic_kind_set(atomic_kind_set=atomic_kinds%els,shell_present=shell_present) IF (shell_present) THEN CALL cp_assert((.NOT.use_mod_hes),cp_warning_level,cp_assertion_failed,routineP,& @@ -196,86 +193,85 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e END IF IF (use_mod_hes) THEN - CALL cp_fm_set_all(hess_mat,alpha=zero,beta=0.00_dp,error=error) - CALL construct_initial_hess(gopt_env%force_env,hess_mat,error) - CALL cp_fm_to_fm(hess_mat,hess_tmp,error) - CALL choose_eigv_solver(hess_tmp,eigvec_mat,eigval,info=info, error=error) + CALL cp_fm_set_all(hess_mat,alpha=zero,beta=0.00_dp) + CALL construct_initial_hess(gopt_env%force_env,hess_mat) + CALL cp_fm_to_fm(hess_mat,hess_tmp) + CALL choose_eigv_solver(hess_tmp,eigvec_mat,eigval,info=info) ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF(info/=0) THEN - CALL cp_fm_set_all(hess_mat,alpha=zero,beta=one,error=error) + CALL cp_fm_set_all(hess_mat,alpha=zero,beta=one) IF(output_unit>0) WRITE(output_unit,*) & "BFGS: Matrix diagonalization failed, using unity as model Hessian." ELSE DO its=1,SIZE(eigval) IF(eigval(its).lt.0.1_dp)eigval(its)=0.1_dp END DO - CALL cp_fm_to_fm(eigvec_mat,hess_tmp,error) + CALL cp_fm_to_fm(eigvec_mat,hess_tmp) CALL cp_fm_column_scale(eigvec_mat,eigval) - CALL cp_gemm("N","T",ndf,ndf,ndf,one,hess_tmp,eigvec_mat,zero,hess_mat,error=error) + CALL cp_gemm("N","T",ndf,ndf,ndf,one,hess_tmp,eigvec_mat,zero,hess_mat) ENDIF ELSE - CALL cp_fm_set_all(hess_mat,alpha=zero,beta=one,error=error) + CALL cp_fm_set_all(hess_mat,alpha=zero,beta=one) END IF ALLOCATE (xold(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) xold(:) = x0(:) ALLOCATE (g(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) g(:) = 0.0_dp ALLOCATE (gold(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gold(:) = 0.0_dp ALLOCATE (dx(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dx(:) = 0.0_dp ALLOCATE (dg(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dg(:) = 0.0_dp ALLOCATE (work(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work(:) = 0.0_dp ALLOCATE (dr(ndf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dr(:) = 0.0_dp ! refernce cell needed for smooth cell optimizations - CALL force_env_get(gopt_env%force_env,cell=cell,error=error) + CALL force_env_get(gopt_env%force_env,cell=cell) ! Geometry optimization starts now - CALL cp_iterate(logger%iter_info,increment=0,iter_nr_out=iter_nr,error=error) + CALL cp_iterate(logger%iter_info,increment=0,iter_nr_out=iter_nr) CALL print_geo_opt_header(gopt_env, output_unit, wildcard) ! Calculate Energy & Gradients CALL cp_eval_at(gopt_env, x0, etot, g, gopt_env%force_env%para_env%mepos,& - .FALSE., gopt_env%force_env%para_env, error) + .FALSE., gopt_env%force_env%para_env) ! Print info at time 0 emin = etot t_now=m_walltime() t_diff=t_now-t_old t_old=t_now - CALL gopt_f_io_init(gopt_env, output_unit, etot, wildcard=wildcard, its=iter_nr, used_time=t_diff, error=error) + CALL gopt_f_io_init(gopt_env, output_unit, etot, wildcard=wildcard, its=iter_nr, used_time=t_diff) DO its = iter_nr+1, maxiter - CALL cp_iterate(logger%iter_info,last=(its==maxiter),error=error) - CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=its,error=error) + CALL cp_iterate(logger%iter_info,last=(its==maxiter)) + CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=its) CALL gopt_f_ii(its, output_unit) ! Hessian update/restarting IF (((its-iter_nr) == 1).AND.hesrest) THEN IF(ionode)THEN - CALL section_vals_val_get(geo_section,"BFGS%RESTART_FILE_NAME",c_val=hes_filename,& - error=error) + CALL section_vals_val_get(geo_section,"BFGS%RESTART_FILE_NAME",c_val=hes_filename) CALL open_file(file_name=hes_filename,file_status="OLD",& file_form="UNFORMATTED", file_action="READ", unit_number=hesunit_read) END IF - CALL cp_fm_read_unformatted(hess_mat,hesunit_read,error) + CALL cp_fm_read_unformatted(hess_mat,hesunit_read) IF (ionode) CALL close_file(unit_number=hesunit_read) ELSE IF( (its-iter_nr) > 1 ) THEN @@ -284,11 +280,11 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e dg(indf) = g(indf) - gold(indf) END DO - CALL bfgs(ndf,dx,dg,hess_mat,work,para_env,error) + CALL bfgs(ndf,dx,dg,hess_mat,work,para_env) !Possibly dump the Hessian file - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file))THEN - CALL write_bfgs_hessian(geo_section,hess_mat,logger,error) + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file))THEN + CALL write_bfgs_hessian(geo_section,hess_mat,logger) ENDIF ENDIF END IF @@ -298,40 +294,40 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e gold(:) = g ! Copying hessian hes to (ndf x ndf) matrix hes_mat for diagonalization - CALL cp_fm_to_fm(hess_mat,hess_tmp,error) + CALL cp_fm_to_fm(hess_mat,hess_tmp) - CALL choose_eigv_solver(hess_tmp,eigvec_mat,eigval,info=info,error=error) + CALL choose_eigv_solver(hess_tmp,eigvec_mat,eigval,info=info) ! In rare cases the diagonalization of hess_mat fails (bug in scalapack?) IF(info/=0) THEN IF(output_unit>0) WRITE(output_unit,*) & "BFGS: Matrix diagonalization failed, resetting Hessian to unity." - CALL cp_fm_set_all(hess_mat,alpha=zero,beta=one,error=error) - CALL cp_fm_to_fm(hess_mat,hess_tmp,error) - CALL choose_eigv_solver(hess_tmp,eigvec_mat,eigval,error=error) + CALL cp_fm_set_all(hess_mat,alpha=zero,beta=one) + CALL cp_fm_to_fm(hess_mat,hess_tmp) + CALL choose_eigv_solver(hess_tmp,eigvec_mat,eigval) END IF IF(use_rfo)THEN CALL set_hes_eig(ndf,eigval,work) dx(:) = eigval - CALL rat_fun_opt(ndf,dg,eigval,work,eigvec_mat,g,para_env,error) + CALL rat_fun_opt(ndf,dg,eigval,work,eigvec_mat,g,para_env) END IF - CALL geoopt_get_step(ndf,eigval,eigvec_mat,hess_tmp,dr,g,para_env,use_rfo,error) + CALL geoopt_get_step(ndf,eigval,eigvec_mat,hess_tmp,dr,g,para_env,use_rfo) CALL trust_radius(ndf,step,rad,rat,dr,output_unit) ! Update the atomic positions x0 = x0 + dr - CALL energy_predict(ndf,work,hess_mat,dr,g,conv,pred,para_env,error) + CALL energy_predict(ndf,work,hess_mat,dr,g,conv,pred,para_env) eold = etot ! Energy & Gradients at new step CALL cp_eval_at(gopt_env, x0, etot, g, gopt_env%force_env%para_env%mepos,& - .FALSE., gopt_env%force_env%para_env, error) + .FALSE., gopt_env%force_env%para_env) ediff = etot - eold ! check for an external exit command - CALL external_control(should_stop,"GEO",globenv=globenv,error=error) + CALL external_control(should_stop,"GEO",globenv=globenv) IF(should_stop) EXIT ! Some IO and Convergence check @@ -340,7 +336,7 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e t_old=t_now CALL gopt_f_io(gopt_env, force_env, root_section, its, etot, output_unit,& eold, emin, wildcard, gopt_param, ndf, dr, g, conv, pred, rat,& - step, rad, used_time=t_diff, error=error) + step, rad, used_time=t_diff) IF (conv.OR.(its==maxiter)) EXIT IF (etot < emin) emin = etot @@ -352,36 +348,36 @@ RECURSIVE SUBROUTINE geoopt_bfgs(force_env,gopt_param,globenv,geo_section,gopt_e END IF ! Write final information, if converged - CALL cp_iterate(logger%iter_info,last=.TRUE.,increment=0,error=error) - CALL write_bfgs_hessian(geo_section,hess_mat,logger,error) + CALL cp_iterate(logger%iter_info,last=.TRUE.,increment=0) + CALL write_bfgs_hessian(geo_section,hess_mat,logger) CALL gopt_f_io_finalize(gopt_env, force_env, x0, conv, its, root_section,& - gopt_env%force_env%para_env, gopt_env%force_env%para_env%mepos, output_unit, error) + gopt_env%force_env%para_env, gopt_env%force_env%para_env%mepos, output_unit) - CALL cp_fm_struct_release(fm_struct_hes,error=error) - CALL cp_fm_release(hess_mat,error=error) - CALL cp_fm_release(eigvec_mat,error=error) - CALL cp_fm_release(hess_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_hes) + CALL cp_fm_release(hess_mat) + CALL cp_fm_release(eigvec_mat) + CALL cp_fm_release(hess_tmp) - CALL cp_blacs_env_release(blacs_env,error=error) + CALL cp_blacs_env_release(blacs_env) DEALLOCATE (xold,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (g,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (gold,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (dx,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (dg,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (eigval,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (dr,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL cp_print_key_finished_output(output_unit,logger,geo_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE geoopt_bfgs @@ -395,9 +391,8 @@ END SUBROUTINE geoopt_bfgs !> \param eigvec_mat ... !> \param g ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rat_fun_opt(ndf,dg,eigval,work,eigvec_mat,g,para_env,error) + SUBROUTINE rat_fun_opt(ndf,dg,eigval,work,eigvec_mat,g,para_env) INTEGER, INTENT(IN) :: ndf REAL(KIND=dp), INTENT(INOUT) :: dg(ndf), eigval(ndf), & @@ -406,7 +401,6 @@ SUBROUTINE rat_fun_opt(ndf,dg,eigval,work,eigvec_mat,g,para_env,error) REAL(KIND=dp), INTENT(INOUT) :: g(ndf) TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rat_fun_opt', & routineP = moduleN//':'//routineN @@ -433,7 +427,7 @@ SUBROUTINE rat_fun_opt(ndf,dg,eigval,work,eigvec_mat,g,para_env,error) dg=0._dp CALL cp_fm_get_info(eigvec_mat,row_indices=row_indices,col_indices=col_indices, & - local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local,error=error) + local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local) DO i=1,nrow_local j=row_indices(i) @@ -571,16 +565,14 @@ END SUBROUTINE rat_fun_opt !> \param hess_mat ... !> \param work ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE bfgs(ndf,dx,dg,hess_mat,work,para_env,error) + SUBROUTINE bfgs(ndf,dx,dg,hess_mat,work,para_env) INTEGER, INTENT(IN) :: ndf REAL(KIND=dp), INTENT(INOUT) :: dx(ndf), dg(ndf) TYPE(cp_fm_type), POINTER :: hess_mat REAL(KIND=dp), INTENT(INOUT) :: work(ndf) TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'bfgs', & routineP = moduleN//':'//routineN @@ -595,7 +587,7 @@ SUBROUTINE bfgs(ndf,dx,dg,hess_mat,work,para_env,error) CALL timeset(routineN,handle) CALL cp_fm_get_info(hess_mat,row_indices=row_indices,col_indices=col_indices, & - local_data=local_hes,nrow_local=nrow_local,ncol_local=ncol_local,error=error) + local_data=local_hes,nrow_local=nrow_local,ncol_local=ncol_local) work=zero DO i=1,nrow_local @@ -690,9 +682,8 @@ END SUBROUTINE set_hes_eig !> \param g ... !> \param para_env ... !> \param use_rfo ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE geoopt_get_step(ndf,eigval,eigvec_mat,hess_tmp,dr,g,para_env,use_rfo,error) + SUBROUTINE geoopt_get_step(ndf,eigval,eigvec_mat,hess_tmp,dr,g,para_env,use_rfo) INTEGER, INTENT(IN) :: ndf REAL(KIND=dp), INTENT(INOUT) :: eigval(ndf) @@ -701,7 +692,6 @@ SUBROUTINE geoopt_get_step(ndf,eigval,eigvec_mat,hess_tmp,dr,g,para_env,use_rfo, TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env LOGICAL :: use_rfo - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), PARAMETER :: one = 1.0_dp, zero = 0.0_dp @@ -712,7 +702,7 @@ SUBROUTINE geoopt_get_step(ndf,eigval,eigvec_mat,hess_tmp,dr,g,para_env,use_rfo, TYPE(cp_fm_struct_type), POINTER :: matrix_struct TYPE(cp_fm_type), POINTER :: tmp - CALL cp_fm_to_fm(eigvec_mat,hess_tmp,error) + CALL cp_fm_to_fm(eigvec_mat,hess_tmp) IF(use_rfo)THEN DO indf=1,ndf eigval(indf) = one/eigval(indf) @@ -724,18 +714,18 @@ SUBROUTINE geoopt_get_step(ndf,eigval,eigvec_mat,hess_tmp,dr,g,para_env,use_rfo, END IF CALL cp_fm_column_scale(hess_tmp,eigval) - CALL cp_fm_get_info(eigvec_mat,matrix_struct=matrix_struct,error=error) - CALL cp_fm_create(tmp, matrix_struct ,name="tmp",error=error) + CALL cp_fm_get_info(eigvec_mat,matrix_struct=matrix_struct) + CALL cp_fm_create(tmp, matrix_struct ,name="tmp") - CALL cp_gemm("N","T",ndf,ndf,ndf,one,hess_tmp,eigvec_mat,zero,tmp,error=error) + CALL cp_gemm("N","T",ndf,ndf,ndf,one,hess_tmp,eigvec_mat,zero,tmp) - CALL cp_fm_transpose(tmp,hess_tmp,error) - CALL cp_fm_release(tmp,error) + CALL cp_fm_transpose(tmp,hess_tmp) + CALL cp_fm_release(tmp) ! ** New step ** CALL cp_fm_get_info(hess_tmp,row_indices=row_indices,col_indices=col_indices, & - local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local,error=error) + local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local) dr=0.0_dp DO i=1,nrow_local @@ -800,9 +790,8 @@ END SUBROUTINE trust_radius !> \param conv ... !> \param pred ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE energy_predict(ndf,work,hess_mat,dr,g,conv,pred,para_env,error) + SUBROUTINE energy_predict(ndf,work,hess_mat,dr,g,conv,pred,para_env) INTEGER, INTENT(IN) :: ndf REAL(KIND=dp), INTENT(INOUT) :: work(ndf) @@ -811,7 +800,6 @@ SUBROUTINE energy_predict(ndf,work,hess_mat,dr,g,conv,pred,para_env,error) LOGICAL, INTENT(INOUT) :: conv REAL(KIND=dp), INTENT(INOUT) :: pred TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'energy_predict', & routineP = moduleN//':'//routineN @@ -828,7 +816,7 @@ SUBROUTINE energy_predict(ndf,work,hess_mat,dr,g,conv,pred,para_env,error) ener1 = DDOT(ndf,g,1,dr,1) CALL cp_fm_get_info(hess_mat,row_indices=row_indices,col_indices=col_indices, & - local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local,error=error) + local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local) work=zero DO i=1,nrow_local @@ -934,14 +922,12 @@ END SUBROUTINE update_trust_rad !> \param geo_section ... !> \param hess_mat ... !> \param logger ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_bfgs_hessian(geo_section,hess_mat,logger,error) + SUBROUTINE write_bfgs_hessian(geo_section,hess_mat,logger) TYPE(section_vals_type), POINTER :: geo_section TYPE(cp_fm_type), POINTER :: hess_mat TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_bfgs_hessian', & routineP = moduleN//':'//routineN @@ -952,11 +938,11 @@ SUBROUTINE write_bfgs_hessian(geo_section,hess_mat,logger,error) hesunit = cp_print_key_unit_nr(logger,geo_section,"BFGS%RESTART",& extension=".Hessian",file_form="UNFORMATTED",file_action="WRITE",& - file_position="REWIND",error=error) + file_position="REWIND") - CALL cp_fm_write_unformatted(hess_mat,hesunit,error) + CALL cp_fm_write_unformatted(hess_mat,hesunit) - CALL cp_print_key_finished_output(hesunit,logger,geo_section,"BFGS%RESTART", error=error) + CALL cp_print_key_finished_output(hesunit,logger,geo_section,"BFGS%RESTART") CALL timestop(handle) @@ -967,13 +953,11 @@ END SUBROUTINE write_bfgs_hessian !> \brief ... !> \param force_env ... !> \param hess_mat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE construct_initial_hess(force_env,hess_mat,error) + SUBROUTINE construct_initial_hess(force_env,hess_mat) TYPE(force_env_type), POINTER :: force_env TYPE(cp_fm_type), POINTER :: hess_mat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'construct_initial_hess', & routineP = moduleN//':'//routineN @@ -994,10 +978,9 @@ SUBROUTINE construct_initial_hess(force_env,hess_mat,error) TYPE(particle_list_type), POINTER :: particles failure=.FALSE. - CALL force_env_get(force_env=force_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(force_env=force_env,subsys=subsys,cell=cell) CALL cp_subsys_get(subsys,& - particles=particles,& - error=error) + particles=particles) alpha(1,:)=(/1._dp,0.3949_dp,0.3949_dp/) alpha(2,:)=(/0.3494_dp,0.2800_dp,0.2800_dp/) @@ -1008,20 +991,20 @@ SUBROUTINE construct_initial_hess(force_env,hess_mat,error) r0(3,:)=(/2.53_dp,3.40_dp,3.40_dp/) CALL cp_fm_get_info(hess_mat,row_indices=row_indices,col_indices=col_indices, & - local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local,error=error) + local_data=local_data,nrow_local=nrow_local,ncol_local=ncol_local) natom=particles%n_els ALLOCATE(at_row(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rho_ij(natom,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(d_ij(natom,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(r_ij(natom,natom,3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fixed(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fixed=1.0_dp - CALL fix_atom_control( force_env, error, fixed) + CALL fix_atom_control( force_env,fixed) DO i=1,3 CALL mp_min(fixed(i,:),hess_mat%matrix_struct%para_env%group) END DO @@ -1085,15 +1068,15 @@ SUBROUTINE construct_initial_hess(force_env,hess_mat,error) END DO END DO DEALLOCATE(fixed,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rho_ij,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(d_ij,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_ij,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(at_row,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE construct_initial_hess diff --git a/src/motion/cell_opt.F b/src/motion/cell_opt.F index 2af0b64e01..43350b1995 100644 --- a/src/motion/cell_opt.F +++ b/src/motion/cell_opt.F @@ -49,14 +49,11 @@ MODULE cell_opt !> \brief Main driver to perform geometry optimization !> \param force_env ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** - SUBROUTINE cp_cell_opt(force_env, globenv, error) + SUBROUTINE cp_cell_opt(force_env, globenv) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cell_opt', & routineP = moduleN//':'//routineN @@ -72,32 +69,32 @@ SUBROUTINE cp_cell_opt(force_env, globenv, error) failure = .FALSE. CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) NULLIFY (gopt_param,force_env_section,gopt_env,x0) root_section => force_env%root_section force_env_section => force_env%force_env_section - geo_section => section_vals_get_subs_vals(root_section,"MOTION%CELL_OPT",error=error) + geo_section => section_vals_get_subs_vals(root_section,"MOTION%CELL_OPT") - CALL gopt_param_read(gopt_param, geo_section, type_id=default_cell_method_id, error=error) + CALL gopt_param_read(gopt_param, geo_section, type_id=default_cell_method_id) CALL gopt_f_create(gopt_env, gopt_param, force_env=force_env, globenv=globenv,& - geo_opt_section=geo_section, error=error) - CALL gopt_f_create_x0(gopt_env, x0, error=error) + geo_opt_section=geo_section) + CALL gopt_f_create_x0(gopt_env, x0) - CALL section_vals_val_get(geo_section,"STEP_START_VAL",i_val=step_start_val,error=error) - CALL cp_add_iter_level(logger%iter_info,"CELL_OPT",error=error) - CALL cp_iterate(logger%iter_info,iter_nr=step_start_val,error=error) + CALL section_vals_val_get(geo_section,"STEP_START_VAL",i_val=step_start_val) + CALL cp_add_iter_level(logger%iter_info,"CELL_OPT") + CALL cp_iterate(logger%iter_info,iter_nr=step_start_val) CALL cp_cell_opt_low(force_env, globenv, gopt_param, gopt_env,& - force_env_section, geo_section, x0, error) - CALL cp_rm_iter_level(logger%iter_info,"CELL_OPT",error=error) + force_env_section, geo_section, x0) + CALL cp_rm_iter_level(logger%iter_info,"CELL_OPT") ! Reset counter for next iteration - CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=0,error=error) + CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=0) DEALLOCATE(x0, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL gopt_f_release(gopt_env, error=error) - CALL gopt_param_release(gopt_param, error=error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL gopt_f_release(gopt_env) + CALL gopt_param_release(gopt_param) CALL timestop(handle) END SUBROUTINE cp_cell_opt @@ -111,19 +108,16 @@ END SUBROUTINE cp_cell_opt !> \param force_env_section ... !> \param geo_section ... !> \param x0 ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** SUBROUTINE cp_cell_opt_low(force_env, globenv, gopt_param, gopt_env, force_env_section,& - geo_section, x0, error) + geo_section, x0) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv TYPE(gopt_param_type), POINTER :: gopt_param TYPE(gopt_f_type), POINTER :: gopt_env TYPE(section_vals_type), POINTER :: force_env_section, geo_section REAL(KIND=dp), DIMENSION(:), POINTER :: x0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cell_opt_low', & routineP = moduleN//':'//routineN @@ -131,26 +125,26 @@ SUBROUTINE cp_cell_opt_low(force_env, globenv, gopt_param, gopt_env, force_env_s LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(x0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(force_env_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(geo_section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(x0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(force_env_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(geo_section),cp_failure_level,routineP,failure) SELECT CASE (gopt_param%method_id) CASE (default_bfgs_method_id) CALL geoopt_bfgs(force_env,gopt_param,globenv,& - geo_section, gopt_env, x0, error=error) + geo_section, gopt_env, x0) CASE (default_lbfgs_method_id) CALL geoopt_lbfgs(force_env,gopt_param,globenv,& - geo_section, gopt_env, x0, error=error) + geo_section, gopt_env, x0) CASE (default_cg_method_id) CALL geoopt_cg(force_env,gopt_param,globenv,& - geo_section, gopt_env, x0, error=error) + geo_section, gopt_env, x0) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE cp_cell_opt_low diff --git a/src/motion/cell_opt_types.F b/src/motion/cell_opt_types.F index f97e848650..f36530fe8d 100644 --- a/src/motion/cell_opt_types.F +++ b/src/motion/cell_opt_types.F @@ -62,16 +62,14 @@ MODULE cell_opt_types !> \param cell_env ... !> \param force_env ... !> \param geo_section ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - created [tlaino] - 03.2008 - Zurich University ! ***************************************************************************** - SUBROUTINE cell_opt_env_create(cell_env, force_env, geo_section, error) + SUBROUTINE cell_opt_env_create(cell_env, force_env, geo_section) TYPE(cell_opt_env_type), POINTER :: cell_env TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: geo_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_opt_env_create', & routineP = moduleN//':'//routineN @@ -84,32 +82,32 @@ SUBROUTINE cell_opt_env_create(cell_env, force_env, geo_section, error) TYPE(particle_list_type), POINTER :: particles failure=.FALSE. - CPPostcondition(.NOT.ASSOCIATED(cell_env),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(cell_env),cp_failure_level,routineP,failure) ALLOCATE(cell_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(cell_env%ref_cell,cell,subsys,particles) cell_env%ref_count=1 last_cell_opt_env_id=last_cell_opt_env_id+1 cell_env%id_nr=last_cell_opt_env_id - CALL force_env_get(force_env, cell=cell, subsys=subsys, error=error) - CALL cell_create(cell_env%ref_cell,error=error) - CALL cell_clone(cell, cell_env%ref_cell, error) - CALL section_vals_val_get(geo_section,"KEEP_ANGLES",l_val=cell_env%keep_angles,error=error) - CALL section_vals_val_get(geo_section,"KEEP_SYMMETRY",l_val=cell_env%keep_symmetry,error=error) - CALL section_vals_val_get(geo_section,"PRESSURE_TOLERANCE",r_val=cell_env%pres_tol,error=error) + CALL force_env_get(force_env, cell=cell, subsys=subsys) + CALL cell_create(cell_env%ref_cell) + CALL cell_clone(cell, cell_env%ref_cell) + CALL section_vals_val_get(geo_section,"KEEP_ANGLES",l_val=cell_env%keep_angles) + CALL section_vals_val_get(geo_section,"KEEP_SYMMETRY",l_val=cell_env%keep_symmetry) + CALL section_vals_val_get(geo_section,"PRESSURE_TOLERANCE",r_val=cell_env%pres_tol) ! First let's rotate the cell vectors in order to have an upper triangular matrix. - CALL get_ut_cell_matrix(cell, error) + CALL get_ut_cell_matrix(cell) ! Compute the rotation matrix that give the cell vectors in the "canonical" orientation cell_env%rot_matrix = MATMUL(cell_env%ref_cell%hmat,cell%h_inv) ! Get the external pressure CALL read_external_press_tensor(geo_section,cell,cell_env%pres_ext,cell_env%mtrx,& - cell_env%rot_matrix, error) + cell_env%rot_matrix) ! Rotate particles accordingly - CALL cp_subsys_get(subsys, particles=particles, error=error) + CALL cp_subsys_get(subsys, particles=particles) DO ip=1,particles%n_els r = MATMUL(TRANSPOSE(cell_env%rot_matrix),particles%els(ip)%r) particles%els(ip)%r = r @@ -119,14 +117,12 @@ END SUBROUTINE cell_opt_env_create ! ***************************************************************************** !> \brief ... !> \param cell_env ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - created [tlaino] - 03.2008 - Zurich University ! ***************************************************************************** - SUBROUTINE cell_opt_env_retain(cell_env, error) + SUBROUTINE cell_opt_env_retain(cell_env) TYPE(cell_opt_env_type), POINTER :: cell_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_opt_env_retain', & routineP = moduleN//':'//routineN @@ -134,22 +130,20 @@ SUBROUTINE cell_opt_env_retain(cell_env, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(cell_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(cell_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(cell_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(cell_env%ref_count>0,cp_failure_level,routineP) cell_env%ref_count=cell_env%ref_count+1 END SUBROUTINE cell_opt_env_retain ! ***************************************************************************** !> \brief ... !> \param cell_env ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino - created [tlaino] - 03.2008 - Zurich University ! ***************************************************************************** - SUBROUTINE cell_opt_env_release(cell_env, error) + SUBROUTINE cell_opt_env_release(cell_env) TYPE(cell_opt_env_type), POINTER :: cell_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_opt_env_release', & routineP = moduleN//':'//routineN @@ -159,12 +153,12 @@ SUBROUTINE cell_opt_env_release(cell_env, error) failure=.FALSE. IF (ASSOCIATED(cell_env)) THEN - CPPreconditionNoFail(cell_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(cell_env%ref_count>0,cp_failure_level,routineP) cell_env%ref_count=cell_env%ref_count-1 IF (cell_env%ref_count==0) THEN - CALL cell_release(cell_env%ref_cell,error) + CALL cell_release(cell_env%ref_cell) DEALLOCATE(cell_env, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF END SUBROUTINE cell_opt_env_release diff --git a/src/motion/cell_opt_utils.F b/src/motion/cell_opt_utils.F index d332362019..253bbd09aa 100644 --- a/src/motion/cell_opt_utils.F +++ b/src/motion/cell_opt_utils.F @@ -50,12 +50,10 @@ MODULE cell_opt_utils ! ***************************************************************************** !> \brief Transform a general cell matrix into an upper triangular one !> \param cell ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** - SUBROUTINE get_ut_cell_matrix(cell, error) + SUBROUTINE get_ut_cell_matrix(cell) TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_ut_cell_matrix', & routineP = moduleN//':'//routineN @@ -67,10 +65,9 @@ SUBROUTINE get_ut_cell_matrix(cell, error) failure = .FALSE. ! orthorhombic cells are diagonal, and should stay exactly like this IF (.NOT. cell%orthorhombic) THEN - CALL get_cell_param(cell,cell_length,cell_angle,cp_units_rad,periodic=periodic,& - error=error) + CALL get_cell_param(cell,cell_length,cell_angle,cp_units_rad,periodic=periodic) CALL set_cell_param(cell,cell_length,cell_angle,periodic=periodic,& - do_init_cell=.TRUE.,error=error) + do_init_cell=.TRUE.) END IF END SUBROUTINE get_ut_cell_matrix @@ -82,18 +79,16 @@ END SUBROUTINE get_ut_cell_matrix !> \param para_env ... !> \param project_name ... !> \param id_run ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** SUBROUTINE gopt_new_logger_create(new_logger, root_section, para_env, project_name,& - id_run, error) + id_run) TYPE(cp_logger_type), POINTER :: new_logger TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env CHARACTER(len=default_string_length), & INTENT(OUT) :: project_name INTEGER, INTENT(IN) :: id_run - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gopt_new_logger_create', & routineP = moduleN//':'//routineN @@ -110,23 +105,23 @@ SUBROUTINE gopt_new_logger_create(new_logger, root_section, para_env, project_na failure = .FALSE. NULLIFY(new_logger, logger, enum, keyword, section) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL create_global_section(section,error=error) - keyword => section_get_keyword(section,"RUN_TYPE",error=error) - CALL keyword_get(keyword,enum=enum,error=error) - label = TRIM(enum_i2c(enum,id_run,error=error)) - CALL section_release(section, error) + CALL create_global_section(section) + keyword => section_get_keyword(section,"RUN_TYPE") + CALL keyword_get(keyword,enum=enum) + label = TRIM(enum_i2c(enum,id_run)) + CALL section_release(section) ! Redirecting output of the sub_calculation to a different file - CALL section_vals_val_get(root_section,"GLOBAL%PROJECT_NAME",c_val=project_name,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%PROJECT_NAME",c_val=project_name) input_file_path = TRIM(project_name) lp=LEN_TRIM(input_file_path) i = logger%iter_info%iteration(logger%iter_info%n_rlevel) input_file_path(lp+1:LEN(input_file_path))="-"//TRIM(label)//"-"//ADJUSTL(cp_to_string(i)) lp=LEN_TRIM(input_file_path) - CALL section_vals_val_set(root_section,"GLOBAL%PROJECT_NAME",c_val=input_file_path(1:lp),error=error) - CALL section_vals_val_set(root_section,"GLOBAL%RUN_TYPE",i_val=id_run,error=error) + CALL section_vals_val_set(root_section,"GLOBAL%PROJECT_NAME",c_val=input_file_path(1:lp)) + CALL section_vals_val_set(root_section,"GLOBAL%RUN_TYPE",i_val=id_run) ! Redirecting output into a new file output_file_path=input_file_path(1:lp)//".out" @@ -138,13 +133,13 @@ SUBROUTINE gopt_new_logger_create(new_logger, root_section, para_env, project_na END IF CALL cp_logger_create(new_logger, para_env=para_env, default_global_unit_nr=unit_nr, & close_global_unit_on_dealloc=.FALSE.) - CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=c_val,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=c_val) IF (c_val/="") THEN CALL cp_logger_set(new_logger,local_filename=TRIM(c_val)//"_localLog") END IF new_logger%iter_info%project_name=c_val CALL section_vals_val_get(root_section,"GLOBAL%PRINT_LEVEL",& - i_val=new_logger%iter_info%print_level,error=error) + i_val=new_logger%iter_info%print_level) END SUBROUTINE gopt_new_logger_create @@ -155,17 +150,15 @@ END SUBROUTINE gopt_new_logger_create !> \param para_env ... !> \param project_name ... !> \param id_run ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** - SUBROUTINE gopt_new_logger_release(new_logger, root_section, para_env, project_name, id_run, error) + SUBROUTINE gopt_new_logger_release(new_logger, root_section, para_env, project_name, id_run) TYPE(cp_logger_type), POINTER :: new_logger TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env CHARACTER(len=default_string_length), & INTENT(IN) :: project_name INTEGER, INTENT(IN) :: id_run - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gopt_new_logger_release', & routineP = moduleN//':'//routineN @@ -177,8 +170,8 @@ SUBROUTINE gopt_new_logger_release(new_logger, root_section, para_env, project_n CALL close_file(unit_number=unit_nr) END IF CALL cp_logger_release(new_logger) - CALL section_vals_val_set(root_section,"GLOBAL%RUN_TYPE",i_val=id_run,error=error) - CALL section_vals_val_set(root_section,"GLOBAL%PROJECT_NAME",c_val=project_name,error=error) + CALL section_vals_val_set(root_section,"GLOBAL%RUN_TYPE",i_val=id_run) + CALL section_vals_val_set(root_section,"GLOBAL%PROJECT_NAME",c_val=project_name) END SUBROUTINE gopt_new_logger_release @@ -189,10 +182,9 @@ END SUBROUTINE gopt_new_logger_release !> \param pres_ext ... !> \param mtrx ... !> \param rot ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** - SUBROUTINE read_external_press_tensor(geo_section, cell, pres_ext, mtrx, rot, error) + SUBROUTINE read_external_press_tensor(geo_section, cell, pres_ext, mtrx, rot) TYPE(section_vals_type), POINTER :: geo_section TYPE(cell_type), POINTER :: cell REAL(KIND=dp), INTENT(OUT) :: pres_ext @@ -200,7 +192,6 @@ SUBROUTINE read_external_press_tensor(geo_section, cell, pres_ext, mtrx, rot, er INTENT(OUT) :: mtrx REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: rot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_external_press_tensor', & routineP = moduleN//':'//routineN @@ -215,7 +206,7 @@ SUBROUTINE read_external_press_tensor(geo_section, cell, pres_ext, mtrx, rot, er mtrx = 0.0_dp pres_ext_tens = 0.0_dp pres_ext = 0.0_dp - CALL section_vals_val_get(geo_section,"EXTERNAL_PRESSURE", r_vals=pvals, error=error) + CALL section_vals_val_get(geo_section,"EXTERNAL_PRESSURE", r_vals=pvals) check = (SIZE(pvals)==1).OR.(SIZE(pvals)==9) CALL cp_assert(check,cp_failure_level,cp_assertion_failed,routineP,& "EXTERNAL_PRESSURE can have 1 or 9 components only! "//& @@ -260,11 +251,10 @@ END SUBROUTINE read_external_press_tensor !> \param keep_angles ... !> \param keep_symmetry ... !> \param pres_int ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** SUBROUTINE get_dg_dh(gradient,av_ptens,pres_ext,cell,mtrx,keep_angles,& - keep_symmetry,pres_int,error) + keep_symmetry,pres_int) REAL(KIND=dp), DIMENSION(:), POINTER :: gradient REAL(KIND=dp), DIMENSION(3, 3), & @@ -275,7 +265,6 @@ SUBROUTINE get_dg_dh(gradient,av_ptens,pres_ext,cell,mtrx,keep_angles,& INTENT(IN) :: mtrx LOGICAL, INTENT(IN), OPTIONAL :: keep_angles, keep_symmetry REAL(KIND=dp), INTENT(OUT) :: pres_int - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_dg_dh', & routineP = moduleN//':'//routineN diff --git a/src/motion/cg_optimizer.F b/src/motion/cg_optimizer.F index a58caf7d3a..cccde76d8b 100644 --- a/src/motion/cg_optimizer.F +++ b/src/motion/cg_optimizer.F @@ -55,14 +55,12 @@ MODULE cg_optimizer !> \param gopt_env ... !> \param x0 ... !> \param do_update ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** RECURSIVE SUBROUTINE geoopt_cg(force_env,gopt_param,globenv,geo_section,& - gopt_env,x0,do_update,error) + gopt_env,x0,do_update) TYPE(force_env_type), POINTER :: force_env TYPE(gopt_param_type), POINTER :: gopt_param @@ -71,7 +69,6 @@ RECURSIVE SUBROUTINE geoopt_cg(force_env,gopt_param,globenv,geo_section,& TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0 LOGICAL, INTENT(OUT), OPTIONAL :: do_update - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'geoopt_cg', & routineP = moduleN//':'//routineN @@ -82,17 +79,17 @@ RECURSIVE SUBROUTINE geoopt_cg(force_env,gopt_param,globenv,geo_section,& CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. output_unit = cp_print_key_unit_nr(logger,geo_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".geoLog",error=error) + extension=".geoLog") CALL print_geo_opt_header(gopt_env, output_unit, "CONJUGATE GRADIENTS") CALL cp_cg_main(force_env, x0, gopt_param, output_unit, globenv,& - gopt_env, do_update=my_do_update, error=error) + gopt_env, do_update=my_do_update) CALL cp_print_key_finished_output(output_unit,logger,geo_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") IF(PRESENT(do_update)) do_update=my_do_update CALL timestop(handle) @@ -108,14 +105,12 @@ END SUBROUTINE geoopt_cg !> \param globenv ... !> \param gopt_env ... !> \param do_update ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** RECURSIVE SUBROUTINE cp_cg_main(force_env, x0, gopt_param, output_unit, globenv,& - gopt_env, do_update, error) + gopt_env, do_update) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0 TYPE(gopt_param_type), POINTER :: gopt_param @@ -123,7 +118,6 @@ RECURSIVE SUBROUTINE cp_cg_main(force_env, x0, gopt_param, output_unit, globenv, TYPE(global_environment_type), POINTER :: globenv TYPE(gopt_f_type), POINTER :: gopt_env LOGICAL, INTENT(OUT), OPTIONAL :: do_update - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_cg_main', & routineP = moduleN//':'//routineN @@ -147,7 +141,7 @@ RECURSIVE SUBROUTINE cp_cg_main(force_env, x0, gopt_param, output_unit, globenv, t_old=m_walltime() NULLIFY(logger,g, h, xi) root_section => force_env%root_section - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() conv = .FALSE. failure = .FALSE. maxiter = gopt_param%max_iter @@ -155,47 +149,47 @@ RECURSIVE SUBROUTINE cp_cg_main(force_env, x0, gopt_param, output_unit, globenv, Fletcher_Reeves = gopt_param%Fletcher_Reeves res_lim = gopt_param%restart_limit ALLOCATE(g (SIZE(x0)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(h (SIZE(x0)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(xi(SIZE(x0)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(xold(SIZE(x0)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,cell=cell,error=error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL force_env_get(force_env,cell=cell) ! Evaluate energy and forces at the first step ![NB] consistent energies and forces not required for CG, but some line minimizers might set it save_consistent_energy_force = gopt_env%require_consistent_energy_force gopt_env%require_consistent_energy_force = .FALSE. CALL cp_eval_at(gopt_env, x0, opt_energy, xi, gopt_env%force_env%para_env%mepos,& - .FALSE., gopt_env%force_env%para_env, error) + .FALSE., gopt_env%force_env%para_env) gopt_env%require_consistent_energy_force = save_consistent_energy_force g = -xi h = g xi = h emin = HUGE(0.0_dp) - CALL cp_iterate(logger%iter_info,increment=0,iter_nr_out=iter_nr,error=error) + CALL cp_iterate(logger%iter_info,increment=0,iter_nr_out=iter_nr) ! Main Loop wildcard = " SD" t_now=m_walltime() t_diff=t_now-t_old t_old=t_now - CALL gopt_f_io_init(gopt_env, output_unit, opt_energy, wildcard, used_time=t_diff, its=iter_nr, error=error) + CALL gopt_f_io_init(gopt_env, output_unit, opt_energy, wildcard, used_time=t_diff, its=iter_nr) eold = opt_energy DO its = iter_nr+1, maxiter - CALL cp_iterate(logger%iter_info,last=(its==maxiter),error=error) - CALL section_vals_val_set(gopt_env%geo_section,"STEP_START_VAL",i_val=its,error=error) + CALL cp_iterate(logger%iter_info,last=(its==maxiter)) + CALL section_vals_val_set(gopt_env%geo_section,"STEP_START_VAL",i_val=its) CALL gopt_f_ii(its, output_unit) xold(:) = x0 ! Line minimization - CALL cg_linmin(gopt_env, x0, xi, g, opt_energy, output_unit, gopt_param, globenv, error) + CALL cg_linmin(gopt_env, x0, xi, g, opt_energy, output_unit, gopt_param, globenv) ! Check for an external exit command - CALL external_control(should_stop,"GEO",globenv=globenv,error=error) + CALL external_control(should_stop,"GEO",globenv=globenv) IF(should_stop) EXIT ! Some IO and Convergence check @@ -204,7 +198,7 @@ RECURSIVE SUBROUTINE cp_cg_main(force_env, x0, gopt_param, output_unit, globenv, t_old=t_now CALL gopt_f_io(gopt_env, force_env, root_section, its, opt_energy,& output_unit, eold, emin, wildcard, gopt_param, SIZE(x0), x0-xold, xi, conv, & - used_time=t_diff,error=error) + used_time=t_diff) eold = opt_energy emin = MIN(emin, opt_energy) @@ -213,12 +207,12 @@ RECURSIVE SUBROUTINE cp_cg_main(force_env, x0, gopt_param, output_unit, globenv, save_consistent_energy_force = gopt_env%require_consistent_energy_force gopt_env%require_consistent_energy_force = .FALSE. CALL cp_eval_at(gopt_env, x0, opt_energy, xi, gopt_env%force_env%para_env%mepos,& - .FALSE., gopt_env%force_env%para_env, error) + .FALSE., gopt_env%force_env%para_env) gopt_env%require_consistent_energy_force = save_consistent_energy_force ! Get Conjugate Directions: updates the searching direction (h) wildcard = " CG" - CALL get_conjugate_direction(gopt_env, Fletcher_Reeves, g, xi, h, error) + CALL get_conjugate_direction(gopt_env, Fletcher_Reeves, g, xi, h) ! Reset Condition or Steepest Descent Requested IF ( ABS(DOT_PRODUCT(g,h))/SQRT((DOT_PRODUCT(g,g)*DOT_PRODUCT(h,h))) > res_lim & @@ -236,18 +230,18 @@ RECURSIVE SUBROUTINE cp_cg_main(force_env, x0, gopt_param, output_unit, globenv, ! Write final particle information and restart, if converged IF (PRESENT(do_update)) do_update = conv - CALL cp_iterate(logger%iter_info,last=.TRUE.,increment=0,error=error) + CALL cp_iterate(logger%iter_info,last=.TRUE.,increment=0) CALL gopt_f_io_finalize(gopt_env, force_env, x0, conv, its, root_section, & - gopt_env%force_env%para_env, gopt_env%force_env%para_env%mepos, output_unit, error) + gopt_env%force_env%para_env, gopt_env%force_env%para_env%mepos, output_unit) DEALLOCATE(xold, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(g, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(h, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(xi,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/motion/cg_utils.F b/src/motion/cg_utils.F index 4e7a115014..fa8cddc4e1 100644 --- a/src/motion/cg_utils.F +++ b/src/motion/cg_utils.F @@ -50,14 +50,12 @@ MODULE cg_utils !> \param output_unit ... !> \param gopt_param ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** RECURSIVE SUBROUTINE cg_linmin(gopt_env, xvec, xi, g, opt_energy, output_unit, gopt_param,& - globenv, error) + globenv) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: xvec, xi, g @@ -65,7 +63,6 @@ RECURSIVE SUBROUTINE cg_linmin(gopt_env, xvec, xi, g, opt_energy, output_unit, g INTEGER :: output_unit TYPE(gopt_param_type), POINTER :: gopt_param TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cg_linmin', & routineP = moduleN//':'//routineN @@ -81,56 +78,56 @@ RECURSIVE SUBROUTINE cg_linmin(gopt_env, xvec, xi, g, opt_energy, output_unit, g SELECT CASE(gopt_param%cg_ls%type_id) CASE(ls_2pnt) CALL linmin_2pnt(gopt_env, xvec, xi, g, opt_energy, gopt_param, use_only_grad=gopt_param%cg_ls%grad_only, & - output_unit=output_unit, error=error) + output_unit=output_unit) CASE(ls_fit) CALL linmin_fit(gopt_env, xvec, xi, opt_energy, gopt_param%cg_ls%brack_limit, & - gopt_param%cg_ls%initial_step, output_unit, gopt_param, globenv, error) + gopt_param%cg_ls%initial_step, output_unit, gopt_param, globenv) CASE(ls_gold) CALL linmin_gold(gopt_env, xvec, xi, opt_energy, gopt_param%cg_ls%brent_tol,& gopt_param%cg_ls%brent_max_iter, gopt_param%cg_ls%brack_limit, & - gopt_param%cg_ls%initial_step, output_unit, globenv, error) + gopt_param%cg_ls%initial_step, output_unit, globenv) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Line Search type not yet implemented in CG.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT CASE(default_ts_method_id) SELECT CASE(gopt_param%cg_ls%type_id) CASE(ls_2pnt) IF (gopt_env%dimer_rotation) THEN - CALL rotmin_2pnt(gopt_env, gopt_env%dimer_env, xvec, xi, opt_energy,error) + CALL rotmin_2pnt(gopt_env, gopt_env%dimer_env, xvec, xi, opt_energy) ELSE CALL tslmin_2pnt(gopt_env, gopt_env%dimer_env, xvec, xi, opt_energy, gopt_param,& - output_unit, error) + output_unit) END IF CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Line Search type not yet implemented in CG for TS search.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT CASE(default_cell_method_id) SELECT CASE(gopt_param%cg_ls%type_id) CASE(ls_2pnt) CALL linmin_2pnt(gopt_env, xvec, xi, g, opt_energy, gopt_param, use_only_grad=.TRUE.,& - output_unit=output_unit, error=error) + output_unit=output_unit) CASE(ls_gold) CALL linmin_gold(gopt_env, xvec, xi, opt_energy, gopt_param%cg_ls%brent_tol,& gopt_param%cg_ls%brent_max_iter, gopt_param%cg_ls%brack_limit, & - gopt_param%cg_ls%initial_step, output_unit, globenv, error) + gopt_param%cg_ls%initial_step, output_unit, globenv) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Line Search type not yet implemented in CG for cell optimization.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT CASE(default_shellcore_method_id) SELECT CASE(gopt_param%cg_ls%type_id) CASE(ls_2pnt) CALL linmin_2pnt(gopt_env, xvec, xi, g, opt_energy, gopt_param, use_only_grad=.TRUE.,& - output_unit=output_unit, error=error) + output_unit=output_unit) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Line Search type not yet implemented in CG for shellcore optimization.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END SELECT @@ -150,19 +147,16 @@ END SUBROUTINE cg_linmin !> \param gopt_param ... !> \param use_only_grad ... !> \param output_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino - created [tlaino] - 03.2008 ! ***************************************************************************** RECURSIVE SUBROUTINE linmin_2pnt(gopt_env, x0, ls_vec, g, opt_energy, gopt_param, use_only_grad,& - output_unit, error) + output_unit) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0, ls_vec, g REAL(KIND=dp), INTENT(INOUT) :: opt_energy TYPE(gopt_param_type), POINTER :: gopt_param LOGICAL, INTENT(IN), OPTIONAL :: use_only_grad INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'linmin_2pnt', & routineP = moduleN//':'//routineN @@ -181,9 +175,9 @@ RECURSIVE SUBROUTINE linmin_2pnt(gopt_env, x0, ls_vec, g, opt_energy, gopt_param IF (PRESENT(use_only_grad)) my_use_only_grad = use_only_grad IF (norm_ls_vec/=0.0_dp) THEN ALLOCATE(ls_norm(SIZE(ls_vec)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gradient2(SIZE(ls_vec)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ls_norm = ls_vec / norm_ls_vec dx = norm_ls_vec dx_thrs = gopt_param%cg_ls%max_step @@ -193,7 +187,7 @@ RECURSIVE SUBROUTINE linmin_2pnt(gopt_env, x0, ls_vec, g, opt_energy, gopt_param save_consistent_energy_force = gopt_env%require_consistent_energy_force gopt_env%require_consistent_energy_force = .NOT. my_use_only_grad CALL cp_eval_at(gopt_env, x0, opt_energy2, gradient2, master=gopt_env%force_env%para_env%mepos,& - final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env, error=error) + final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env) gopt_env%require_consistent_energy_force = save_consistent_energy_force norm_grad1 = -DOT_PRODUCT( g,ls_norm) @@ -240,9 +234,9 @@ RECURSIVE SUBROUTINE linmin_2pnt(gopt_env, x0, ls_vec, g, opt_energy, gopt_param WRITE(UNIT=output_unit,FMT="(T2,A)") REPEAT("*",79) END IF DEALLOCATE(ls_norm,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gradient2,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE ! Do Nothing, since.. if the effective force is 0 means that we are already ! in the saddle point.. @@ -259,18 +253,15 @@ END SUBROUTINE linmin_2pnt !> \param opt_energy ... !> \param gopt_param ... !> \param output_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE tslmin_2pnt(gopt_env, dimer_env, x0, tls_vec, opt_energy, gopt_param, output_unit, error) + SUBROUTINE tslmin_2pnt(gopt_env, dimer_env, x0, tls_vec, opt_energy, gopt_param, output_unit) TYPE(gopt_f_type), POINTER :: gopt_env TYPE(dimer_env_type), POINTER :: dimer_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0, tls_vec REAL(KIND=dp), INTENT(INOUT) :: opt_energy TYPE(gopt_param_type), POINTER :: gopt_param INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tslmin_2pnt', & routineP = moduleN//':'//routineN @@ -287,7 +278,7 @@ SUBROUTINE tslmin_2pnt(gopt_env, dimer_env, x0, tls_vec, opt_energy, gopt_param, norm_tls_vec = SQRT(DOT_PRODUCT(tls_vec,tls_vec)) IF (norm_tls_vec/=0.0_dp) THEN ALLOCATE(tls_norm(SIZE(tls_vec)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) tls_norm = tls_vec / norm_tls_vec dimer_env%tsl%tls_vec => tls_norm @@ -298,8 +289,7 @@ SUBROUTINE tslmin_2pnt(gopt_env, dimer_env, x0, tls_vec, opt_energy, gopt_param, IF (dimer_env%rot%curvature>0) dx = dx_thrs x0 = x0 + dx * tls_norm CALL cp_eval_at(gopt_env, x0, opt_energy2, master=gopt_env%force_env%para_env%mepos,& - final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env,& - error=error) + final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env) IF (dimer_env%rot%curvature>0) THEN dx_min = 0.0_dp dx_min_save = dx @@ -333,11 +323,10 @@ SUBROUTINE tslmin_2pnt(gopt_env, dimer_env, x0, tls_vec, opt_energy, gopt_param, ! Here we compute the value of the energy in point zero.. CALL cp_eval_at(gopt_env, x0, opt_energy, master=gopt_env%force_env%para_env%mepos,& - final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env,& - error=error) + final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env) DEALLOCATE(tls_norm,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE ! Do Nothing, since.. if the effective force is 0 means that we are already ! in the saddle point.. @@ -353,16 +342,13 @@ END SUBROUTINE tslmin_2pnt !> \param x0 ... !> \param theta ... !> \param opt_energy ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE rotmin_2pnt(gopt_env, dimer_env, x0, theta, opt_energy, error) + SUBROUTINE rotmin_2pnt(gopt_env, dimer_env, x0, theta, opt_energy) TYPE(gopt_f_type), POINTER :: gopt_env TYPE(dimer_env_type), POINTER :: dimer_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0, theta REAL(KIND=dp), INTENT(INOUT) :: opt_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotmin_2pnt', & routineP = moduleN//':'//routineN @@ -384,11 +370,10 @@ SUBROUTINE rotmin_2pnt(gopt_env, dimer_env, x0, theta, opt_energy, error) dimer_env%cg_rot%nvec_old = dimer_env%nvec IF (angle>dimer_env%rot%angle_tol) THEN ! Rotating the dimer of dtheta degrees - CALL rotate_dimer(dimer_env%nvec,theta,angle,error=error) + CALL rotate_dimer(dimer_env%nvec,theta,angle) ! Re-compute energy, gradients and rotation vector for new R1 CALL cp_eval_at(gopt_env, x0, f, master=gopt_env%force_env%para_env%mepos,& - final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env,& - error=error) + final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env) curvature1 = dimer_env%rot%curvature a1 = (curvature0 - curvature1 + b1 * SIN(2.0_dp*angle))/(1.0_dp - COS(2.0_dp*angle)) @@ -403,12 +388,12 @@ SUBROUTINE rotmin_2pnt(gopt_env, dimer_env, x0, theta, opt_energy, error) dimer_env%rot%curvature = curvature2 ! Rotating the dimer the optimized (in plane) vector position dimer_env%nvec = dimer_env%cg_rot%nvec_old - CALL rotate_dimer(dimer_env%nvec,theta,angle,error=error) + CALL rotate_dimer(dimer_env%nvec,theta,angle) ! Evaluate (by interpolation) the norm of the rotational force in the ! minimum of the rotational search (this is for print-out only) ALLOCATE(work(SIZE(dimer_env%nvec)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) work = dimer_env%rot%g1 work = SIN(dimer_env%rot%angle1-dimer_env%rot%angle2)/SIN(dimer_env%rot%angle1)*dimer_env%rot%g1+& SIN(dimer_env%rot%angle2)/SIN(dimer_env%rot%angle1)*dimer_env%rot%g1p+& @@ -418,7 +403,7 @@ SUBROUTINE rotmin_2pnt(gopt_env, dimer_env, x0, theta, opt_energy, error) work = work - DOT_PRODUCT(work, dimer_env%nvec) * dimer_env%nvec opt_energy = SQRT(DOT_PRODUCT(work, work)) DEALLOCATE(work,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF dimer_env%rot%angle2 = angle CALL timestop(handle) @@ -436,8 +421,6 @@ END SUBROUTINE rotmin_2pnt !> \param output_unit ... !> \param gopt_param ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino @@ -447,14 +430,13 @@ END SUBROUTINE rotmin_2pnt !> with the optimal value. Enhanced Version ! ***************************************************************************** SUBROUTINE linmin_fit(gopt_env, xvec, xi, opt_energy, & - brack_limit, step, output_unit, gopt_param, globenv, error) + brack_limit, step, output_unit, gopt_param, globenv) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: xvec, xi REAL(KIND=dp) :: opt_energy, brack_limit, step INTEGER :: output_unit TYPE(gopt_param_type), POINTER :: gopt_param TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'linmin_fit', & routineP = moduleN//':'//routineN @@ -473,9 +455,9 @@ SUBROUTINE linmin_fit(gopt_env, xvec, xi, opt_energy, & rms_dr = gopt_param%rms_dr rms_force = gopt_param%rms_force ALLOCATE(pcom(SIZE(xvec)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(xicom(SIZE(xvec)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) pcom = xvec xicom = xi @@ -484,7 +466,7 @@ SUBROUTINE linmin_fit(gopt_env, xvec, xi, opt_energy, & ax = 0.0_dp xx = step CALL cg_mnbrak(gopt_env, ax, xx, bx, pcom, xicom, brack_limit, output_unit, & - histpoint=hist,globenv=globenv, error=error) + histpoint=hist,globenv=globenv) ! fprev = 0.0_dp opt_energy = MINVAL(hist(:,2)) @@ -492,15 +474,15 @@ SUBROUTINE linmin_fit(gopt_env, xvec, xi, opt_energy, & scale = 0.25_dp loc_iter = 0 DO WHILE ( ABS(hist(odim,3)) > rms_force*scale .OR. ABS(hist(odim,1)-hist(odim-1,1)) > scale*rms_dr) - CALL external_control(should_stop,"LINFIT",globenv=globenv,error=error) + CALL external_control(should_stop,"LINFIT",globenv=globenv) IF(should_stop) EXIT ! loc_iter = loc_iter + 1 fprev = opt_energy - xmin = FindMin(hist(:,1),hist(:,2),hist(:,3),error) + xmin = FindMin(hist(:,1),hist(:,2),hist(:,3)) CALL reallocate(hist,1,odim+1,1,3) hist(odim+1,1) = xmin - hist(odim+1,3) = cg_deval1d(gopt_env,xmin,pcom,xicom,opt_energy,error) + hist(odim+1,3) = cg_deval1d(gopt_env,xmin,pcom,xicom,opt_energy) hist(odim+1,2) = opt_energy odim = SIZE(hist,1) END DO @@ -509,11 +491,11 @@ SUBROUTINE linmin_fit(gopt_env, xvec, xi, opt_energy, & step = xmin xvec = xvec + xicom DEALLOCATE(pcom, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(xicom, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(hist, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (output_unit>0) THEN WRITE(UNIT=output_unit,FMT="(/,T2,A)") REPEAT("*",79) WRITE(UNIT=output_unit,FMT="(T2,A,T22,A,I7,T78,A)")& @@ -536,8 +518,6 @@ END SUBROUTINE linmin_fit !> \param step ... !> \param output_unit ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino @@ -547,7 +527,7 @@ END SUBROUTINE linmin_fit !> with the optimal value ! ***************************************************************************** SUBROUTINE linmin_gold(gopt_env, xvec, xi, opt_energy, brent_tol, brent_max_iter, & - brack_limit, step, output_unit, globenv, error) + brack_limit, step, output_unit, globenv) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: xvec, xi REAL(KIND=dp) :: opt_energy, brent_tol @@ -555,7 +535,6 @@ SUBROUTINE linmin_gold(gopt_env, xvec, xi, opt_energy, brent_tol, brent_max_iter REAL(KIND=dp) :: brack_limit, step INTEGER :: output_unit TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'linmin_gold', & routineP = moduleN//':'//routineN @@ -570,9 +549,9 @@ SUBROUTINE linmin_gold(gopt_env, xvec, xi, opt_energy, brent_tol, brent_max_iter failure = .FALSE. NULLIFY(pcom,xicom) ALLOCATE(pcom(SIZE(xvec)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(xicom(SIZE(xvec)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) pcom = xvec xicom = xi @@ -581,17 +560,17 @@ SUBROUTINE linmin_gold(gopt_env, xvec, xi, opt_energy, brent_tol, brent_max_iter ax = 0.0_dp xx = step CALL cg_mnbrak(gopt_env, ax, xx, bx, pcom, xicom, brack_limit, output_unit,& - globenv=globenv, error=error) + globenv=globenv) opt_energy = cg_dbrent(gopt_env, ax, xx, bx, brent_tol, brent_max_iter, & - xmin, pcom, xicom, output_unit, globenv, error) + xmin, pcom, xicom, output_unit, globenv) xicom = xmin*xicom step = xmin xvec = xvec + xicom DEALLOCATE(pcom, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(xicom, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE linmin_gold @@ -608,8 +587,6 @@ END SUBROUTINE linmin_gold !> \param output_unit ... !> \param histpoint ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino @@ -619,7 +596,7 @@ END SUBROUTINE linmin_gold !> bracket the minimum of the function ! ***************************************************************************** SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit,& - histpoint, globenv, error) + histpoint, globenv) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp) :: ax, bx, cx REAL(KIND=dp), DIMENSION(:), POINTER :: pcom, xicom @@ -628,7 +605,6 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit REAL(KIND=dp), DIMENSION(:, :), & OPTIONAL, POINTER :: histpoint TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cg_mnbrak', & routineP = moduleN//':'//routineN @@ -642,21 +618,21 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit failure = .FALSE. hist = PRESENT(histpoint) IF (hist) THEN - CPPrecondition(.NOT.ASSOCIATED(histpoint),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(histpoint),cp_failure_level,routineP,failure) ALLOCATE(histpoint(3,3), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF gold = (1.0_dp+SQRT(5.0_dp))/2.0_dp IF (hist) THEN histpoint(1,1) = ax - histpoint(1,3) = cg_deval1d(gopt_env,ax,pcom,xicom,fa,error) + histpoint(1,3) = cg_deval1d(gopt_env,ax,pcom,xicom,fa) histpoint(1,2) = fa histpoint(2,1) = bx - histpoint(2,3) = cg_deval1d(gopt_env,bx,pcom,xicom,fb,error) + histpoint(2,3) = cg_deval1d(gopt_env,bx,pcom,xicom,fb) histpoint(2,2) = fb ELSE - fa=cg_eval1d(gopt_env,ax,pcom,xicom,error=error) - fb=cg_eval1d(gopt_env,bx,pcom,xicom,error=error) + fa=cg_eval1d(gopt_env,ax,pcom,xicom) + fb=cg_eval1d(gopt_env,bx,pcom,xicom) END IF IF(fb.GT.fa)THEN dum=ax @@ -669,14 +645,14 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit cx=bx+gold*(bx-ax) IF (hist) THEN histpoint(3,1) = cx - histpoint(3,3) = cg_deval1d(gopt_env,cx,pcom,xicom,fc,error) + histpoint(3,3) = cg_deval1d(gopt_env,cx,pcom,xicom,fc) histpoint(3,2) = fc ELSE - fc=cg_eval1d(gopt_env,cx,pcom,xicom,error=error) + fc=cg_eval1d(gopt_env,cx,pcom,xicom) END IF loc_iter = 3 DO WHILE (fb.GE.fc) - CALL external_control(should_stop,"MNBRACK",globenv=globenv,error=error) + CALL external_control(should_stop,"MNBRACK",globenv=globenv) IF(should_stop) EXIT ! r=(bx-ax)*(fb-fc) @@ -688,10 +664,10 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit odim = SIZE(histpoint,1) CALL reallocate(histpoint,1,odim+1,1,3) histpoint(odim+1,1) = u - histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu) histpoint(odim+1,2) = fu ELSE - fu=cg_eval1d(gopt_env,u,pcom,xicom,error=error) + fu=cg_eval1d(gopt_env,u,pcom,xicom) END IF loc_iter = loc_iter + 1 IF(fu.LT.fc)THEN @@ -710,10 +686,10 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit odim = SIZE(histpoint,1) CALL reallocate(histpoint,1,odim+1,1,3) histpoint(odim+1,1) = u - histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu) histpoint(odim+1,2) = fu ELSE - fu=cg_eval1d(gopt_env,u,pcom,xicom,error=error) + fu=cg_eval1d(gopt_env,u,pcom,xicom) END IF loc_iter = loc_iter + 1 ELSE IF((cx-u)*(u-ulim).GT.0.)THEN @@ -721,10 +697,10 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit odim = SIZE(histpoint,1) CALL reallocate(histpoint,1,odim+1,1,3) histpoint(odim+1,1) = u - histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu) histpoint(odim+1,2) = fu ELSE - fu=cg_eval1d(gopt_env,u,pcom,xicom,error=error) + fu=cg_eval1d(gopt_env,u,pcom,xicom) END IF loc_iter = loc_iter + 1 IF(fu.LT.fc)THEN @@ -737,10 +713,10 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit odim = SIZE(histpoint,1) CALL reallocate(histpoint,1,odim+1,1,3) histpoint(odim+1,1) = u - histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu) histpoint(odim+1,2) = fu ELSE - fu=cg_eval1d(gopt_env,u,pcom,xicom,error=error) + fu=cg_eval1d(gopt_env,u,pcom,xicom) END IF loc_iter = loc_iter + 1 ENDIF @@ -750,10 +726,10 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit odim = SIZE(histpoint,1) CALL reallocate(histpoint,1,odim+1,1,3) histpoint(odim+1,1) = u - histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu) histpoint(odim+1,2) = fu ELSE - fu=cg_eval1d(gopt_env,u,pcom,xicom,error=error) + fu=cg_eval1d(gopt_env,u,pcom,xicom) END IF loc_iter = loc_iter + 1 ELSE @@ -762,10 +738,10 @@ SUBROUTINE cg_mnbrak(gopt_env, ax, bx, cx, pcom, xicom, brack_limit, output_unit odim = SIZE(histpoint,1) CALL reallocate(histpoint,1,odim+1,1,3) histpoint(odim+1,1) = u - histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + histpoint(odim+1,3) = cg_deval1d(gopt_env,u,pcom,xicom,fu) histpoint(odim+1,2) = fu ELSE - fu=cg_eval1d(gopt_env,u,pcom,xicom,error=error) + fu=cg_eval1d(gopt_env,u,pcom,xicom) END IF loc_iter = loc_iter + 1 ENDIF @@ -801,8 +777,6 @@ END SUBROUTINE cg_mnbrak !> \param xicom ... !> \param output_unit ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval dbrent ... !> \par History !> 10.2005 created [tlaino] @@ -815,7 +789,7 @@ END SUBROUTINE cg_mnbrak !> using derivatives ! ***************************************************************************** FUNCTION cg_dbrent(gopt_env,ax,bx,cx,tol,itmax,xmin,pcom,xicom,output_unit,& - globenv, error) RESULT(dbrent) + globenv) RESULT(dbrent) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp) :: ax, bx, cx, tol INTEGER :: itmax @@ -823,7 +797,6 @@ FUNCTION cg_dbrent(gopt_env,ax,bx,cx,tol,itmax,xmin,pcom,xicom,output_unit,& REAL(KIND=dp), DIMENSION(:), POINTER :: pcom, xicom INTEGER :: output_unit TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: dbrent CHARACTER(len=*), PARAMETER :: routineN = 'cg_dbrent', & @@ -844,14 +817,14 @@ FUNCTION cg_dbrent(gopt_env,ax,bx,cx,tol,itmax,xmin,pcom,xicom,output_unit,& b = MAX(ax,cx) v = bx ; w = v; x = v e = 0.0_dp - dx = cg_deval1d(gopt_env,x,pcom,xicom,fx,error) + dx = cg_deval1d(gopt_env,x,pcom,xicom,fx) fv = fx fw = fx dv = dx dw = dx loc_iter = 1 DO iter = 1, itmax - CALL external_control(should_stop,"BRENT",globenv=globenv,error=error) + CALL external_control(should_stop,"BRENT",globenv=globenv) IF(should_stop) EXIT ! xm = 0.5_dp * (a+b) @@ -903,11 +876,11 @@ FUNCTION cg_dbrent(gopt_env,ax,bx,cx,tol,itmax,xmin,pcom,xicom,output_unit,& END IF IF(ABS(d).GE.tol1) THEN u=x+d - du=cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + du=cg_deval1d(gopt_env,u,pcom,xicom,fu) loc_iter = loc_iter + 1 ELSE u=x+SIGN(tol1,d) - du=cg_deval1d(gopt_env,u,pcom,xicom,fu,error) + du=cg_deval1d(gopt_env,u,pcom,xicom,fu) loc_iter = loc_iter + 1 IF(fu.GT.fx) EXIT ENDIF @@ -944,7 +917,7 @@ FUNCTION cg_dbrent(gopt_env,ax,bx,cx,tol,itmax,xmin,pcom,xicom,output_unit,& "***","BRENT - NUMBER OF ITERATIONS EXCEEDED ","***" WRITE(UNIT=output_unit,FMT="(T2,A)") REPEAT("*",79) END IF - CPPrecondition((iter/=itmax+1),cp_failure_level,routineP,error,failure) + CPPrecondition((iter/=itmax+1),cp_failure_level,routineP,failure) xmin=x dbrent=fx CALL timestop(handle) @@ -958,18 +931,15 @@ END FUNCTION cg_dbrent !> \param x ... !> \param pcom ... !> \param xicom ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval my_val ... !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - FUNCTION cg_eval1d(gopt_env,x,pcom,xicom,error) RESULT(my_val) + FUNCTION cg_eval1d(gopt_env,x,pcom,xicom) RESULT(my_val) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp) :: x REAL(KIND=dp), DIMENSION(:), POINTER :: pcom, xicom - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: my_val CHARACTER(len=*), PARAMETER :: routineN = 'cg_eval1d', & @@ -983,13 +953,12 @@ FUNCTION cg_eval1d(gopt_env,x,pcom,xicom,error) RESULT(my_val) failure = .FALSE. ALLOCATE(xvec(SIZE(pcom)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) xvec = pcom + x*xicom CALL cp_eval_at(gopt_env, xvec, my_val, master=gopt_env%force_env%para_env%mepos,& - final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env,& - error=error) + final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env) DEALLOCATE(xvec, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1003,20 +972,16 @@ END FUNCTION cg_eval1d !> \param pcom ... !> \param xicom ... !> \param fval ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval my_val ... !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - FUNCTION cg_deval1d(gopt_env,x,pcom,xicom,fval,error) RESULT(my_val) + FUNCTION cg_deval1d(gopt_env,x,pcom,xicom,fval) RESULT(my_val) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp) :: x REAL(KIND=dp), DIMENSION(:), POINTER :: pcom, xicom - REAL(KIND=dp) :: fval - TYPE(cp_error_type), INTENT(inout) :: error - REAL(KIND=dp) :: my_val + REAL(KIND=dp) :: fval, my_val CHARACTER(len=*), PARAMETER :: routineN = 'cg_deval1d', & routineP = moduleN//':'//routineN @@ -1030,18 +995,18 @@ FUNCTION cg_deval1d(gopt_env,x,pcom,xicom,fval,error) RESULT(my_val) failure = .FALSE. ALLOCATE(xvec(SIZE(pcom)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(grad(SIZE(pcom)), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) xvec = pcom + x * xicom CALL cp_eval_at(gopt_env, xvec, energy, grad, master=gopt_env%force_env%para_env%mepos,& - final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env, error=error) + final_evaluation=.FALSE., para_env=gopt_env%force_env%para_env) my_val = DOT_PRODUCT(grad,xicom) fval = energy DEALLOCATE(xvec, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(grad, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END FUNCTION cg_deval1d @@ -1051,16 +1016,13 @@ END FUNCTION cg_deval1d !> \param x ... !> \param y ... !> \param dy ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 10.2005 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION FindMin(x,y,dy,error) RESULT(res) + FUNCTION FindMin(x,y,dy) RESULT(res) REAL(kind=dp), DIMENSION(:) :: x, y, dy - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'FindMin', & @@ -1079,7 +1041,7 @@ FUNCTION FindMin(x,y,dy,error) RESULT(res) failure=.FALSE. np=SIZE(x) - CPPrecondition(np>1,cp_failure_level,routineP,error,failure) + CPPrecondition(np>1,cp_failure_level,routineP,failure) sum_x=0._dp sum_xx=0._dp min_pos=1 @@ -1110,11 +1072,11 @@ FUNCTION FindMin(x,y,dy,error) RESULT(res) iwork,info) lwork=CEILING(tmpw(1)) ALLOCATE(work(lwork),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL dgesdd('S',SIZE(f,1),SIZE(f,2),f,SIZE(f,1),diag,u,SIZE(u,1),vt,SIZE(vt,1),work,lwork,& iwork,info) DEALLOCATE(work, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL dgemv('T',SIZE(u,1),SIZE(u,2),1._dp,u,SIZE(u,1),b,1,0._dp,res1,1) DO i=1,3 res2(i)=res1(i)/diag(i) @@ -1131,18 +1093,15 @@ END FUNCTION FindMin !> \param xi contains the -theta of the present step.. (norm 1.0 vector) !> \param h contains the search direction of the previous step (must be orthogonal !> to nvec of the previous step (nvec_old)) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par Info for DIMER method !> \par History !> 10.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE get_conjugate_direction(gopt_env, Fletcher_Reeves, g, xi, h, error) + SUBROUTINE get_conjugate_direction(gopt_env, Fletcher_Reeves, g, xi, h) TYPE(gopt_f_type), POINTER :: gopt_env LOGICAL, INTENT(IN) :: Fletcher_Reeves REAL(KIND=dp), DIMENSION(:), POINTER :: g, xi, h - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_conjugate_direction', & routineP = moduleN//':'//routineN @@ -1168,13 +1127,13 @@ SUBROUTINE get_conjugate_direction(gopt_env, Fletcher_Reeves, g, xi, h, error) ELSE dimer_env => gopt_env%dimer_env check = ABS(DOT_PRODUCT(g,g)-1.0_dp) \param geo_section ... !> \param gopt_env ... !> \param x0 ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** RECURSIVE SUBROUTINE geoopt_lbfgs(force_env, gopt_param, globenv, geo_section, gopt_env,& - x0, error) + x0) TYPE(force_env_type), POINTER :: force_env TYPE(gopt_param_type), POINTER :: gopt_param TYPE(global_environment_type), POINTER :: globenv TYPE(section_vals_type), POINTER :: geo_section TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'geoopt_lbfgs', & routineP = moduleN//':'//routineN @@ -89,46 +86,46 @@ RECURSIVE SUBROUTINE geoopt_lbfgs(force_env, gopt_param, globenv, geo_section, g failure = .FALSE. NULLIFY (optimizer, para_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() root_section => force_env%root_section - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,error,failure) - CPPrecondition(gopt_param%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,failure) + CPPrecondition(gopt_param%ref_count>0,cp_failure_level,routineP,failure) - CALL force_env_get(force_env, para_env=para_env, cell=cell, error=error) + CALL force_env_get(force_env, para_env=para_env, cell=cell) ! Geometry optimization starts now output_unit = cp_print_key_unit_nr(logger,geo_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".geoLog",error=error) + extension=".geoLog") CALL print_geo_opt_header(gopt_env, output_unit, "L-BFGS") ! Stop if not implemented IF(gopt_env%type_id == default_ts_method_id) & CALL cp_unimplemented_error(fromWhere=routineP, & message="BFGS method not yet working with DIMER", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) - CALL section_vals_val_get(geo_section,"LBFGS%TRUST_RADIUS",r_val=trust_radius,error=error) + CALL section_vals_val_get(geo_section,"LBFGS%TRUST_RADIUS",r_val=trust_radius) CALL cp_opt_gopt_create(optimizer, para_env=para_env, obj_funct=gopt_env,& x0=x0, wanted_relative_f_delta=gopt_param%wanted_rel_f_error,& wanted_projected_gradient=gopt_param%wanted_proj_gradient, m=gopt_param%max_h_rank,& - max_f_per_iter=gopt_param%max_f_per_iter,trust_radius=trust_radius, error=error) - CALL cp_iterate(logger%iter_info,increment=0,iter_nr_out=iter_nr,error=error) + max_f_per_iter=gopt_param%max_f_per_iter,trust_radius=trust_radius) + CALL cp_iterate(logger%iter_info,increment=0,iter_nr_out=iter_nr) converged=.FALSE. DO its=iter_nr+1,gopt_param%max_iter - CALL cp_iterate(logger%iter_info,last=(its==gopt_param%max_iter),error=error) - CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=its,error=error) + CALL cp_iterate(logger%iter_info,last=(its==gopt_param%max_iter)) + CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=its) CALL gopt_f_ii(its, output_unit) ! Real optimization step.. IF (.NOT.cp_opt_gopt_next(optimizer,geo_section=geo_section,& - force_env=force_env,gopt_param=gopt_param, converged=converged,error=error)) EXIT + force_env=force_env,gopt_param=gopt_param, converged=converged)) EXIT ! Check for an external exit command - CALL external_control(should_stop,"GEO",globenv=globenv,error=error) + CALL external_control(should_stop,"GEO",globenv=globenv) IF (should_stop) THEN - CALL cp_opt_gopt_stop(optimizer, error=error) + CALL cp_opt_gopt_stop(optimizer) EXIT END IF IF (its == gopt_param%max_iter) EXIT @@ -139,13 +136,13 @@ RECURSIVE SUBROUTINE geoopt_lbfgs(force_env, gopt_param, globenv, geo_section, g END IF ! Write final output information, if converged - CALL cp_iterate(logger%iter_info,last=.TRUE.,increment=0,error=error) + CALL cp_iterate(logger%iter_info,last=.TRUE.,increment=0) CALL gopt_f_io_finalize(gopt_env, force_env, optimizer%x, converged, its, root_section,& - optimizer%para_env, optimizer%master, output_unit, error) + optimizer%para_env, optimizer%master, output_unit) - CALL cp_opt_gopt_release(optimizer, error=error) + CALL cp_opt_gopt_release(optimizer) CALL cp_print_key_finished_output(output_unit,logger,geo_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) diff --git a/src/motion/cp_lbfgs_optimizer_gopt.F b/src/motion/cp_lbfgs_optimizer_gopt.F index 7294c1ff12..c3a8bd0a5c 100644 --- a/src/motion/cp_lbfgs_optimizer_gopt.F +++ b/src/motion/cp_lbfgs_optimizer_gopt.F @@ -184,8 +184,6 @@ MODULE cp_lbfgs_optimizer_gopt !> \param master ... !> \param max_f_per_iter ... !> \param trust_radius ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2002 created [fawzi] !> 09.2003 refactored (retain/release,para_env) [fawzi] @@ -195,7 +193,7 @@ MODULE cp_lbfgs_optimizer_gopt ! ***************************************************************************** SUBROUTINE cp_opt_gopt_create(optimizer, para_env, obj_funct, x0, m, print_every, & wanted_relative_f_delta, wanted_projected_gradient, lower_bound,upper_bound,& - kind_of_bound, master, max_f_per_iter, trust_radius, error) + kind_of_bound, master, max_f_per_iter, trust_radius) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer TYPE(cp_para_env_type), POINTER :: para_env TYPE(gopt_f_type), POINTER :: obj_funct @@ -209,7 +207,6 @@ SUBROUTINE cp_opt_gopt_create(optimizer, para_env, obj_funct, x0, m, print_every INTENT(in), OPTIONAL :: kind_of_bound INTEGER, INTENT(in), OPTIONAL :: master, max_f_per_iter REAL(kind=dp), INTENT(in), OPTIONAL :: trust_radius - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_create', & routineP = moduleN//':'//routineN @@ -222,7 +219,7 @@ SUBROUTINE cp_opt_gopt_create(optimizer, para_env, obj_funct, x0, m, print_every failure=.FALSE. ALLOCATE(optimizer,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(optimizer%kind_of_bound,& optimizer%i_work_array,& optimizer%isave,& @@ -242,9 +239,9 @@ SUBROUTINE cp_opt_gopt_create(optimizer, para_env, obj_funct, x0, m, print_every IF (PRESENT(m)) optimizer%m=m optimizer%master= para_env%source optimizer%para_env => para_env - CALL cp_para_env_retain(para_env,error=error) + CALL cp_para_env_retain(para_env) optimizer%obj_funct => obj_funct - CALL gopt_f_retain(obj_funct, error=error) + CALL gopt_f_retain(obj_funct) optimizer%max_f_per_iter=20 IF(PRESENT(max_f_per_iter)) optimizer%max_f_per_iter=max_f_per_iter optimizer%print_every=-1 @@ -259,11 +256,11 @@ SUBROUTINE cp_opt_gopt_create(optimizer, para_env, obj_funct, x0, m, print_every lenwa = 2*optimizer%m*n + 5*n + 11*optimizer%m*optimizer%m + 8*optimizer%m ALLOCATE (optimizer%kind_of_bound(n), optimizer%i_work_array(3*n),& optimizer%isave(44), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (optimizer%x(n), optimizer%lower_bound(n), & optimizer%upper_bound(n), optimizer%gradient(n), & optimizer%dsave(29), optimizer%work_array(lenwa), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) optimizer%x=x0 optimizer%task='START' optimizer%wanted_relative_f_delta=wanted_relative_f_delta @@ -288,10 +285,10 @@ SUBROUTINE cp_opt_gopt_create(optimizer, para_env, obj_funct, x0, m, print_every optimizer%lower_bound, optimizer%upper_bound, optimizer%gradient,& optimizer%dsave, optimizer%work_array) ALLOCATE (optimizer%x(n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) optimizer%x(:) = 0.0_dp ALLOCATE (optimizer%gradient(n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) optimizer%gradient(:) = 0.0_dp END IF CALL mp_bcast(optimizer%x,optimizer%master,optimizer%para_env%group) @@ -305,15 +302,12 @@ END SUBROUTINE cp_opt_gopt_create ! ***************************************************************************** !> \brief retains the given optimizer (see doc/ReferenceCounting.html) !> \param optimizer the optimizer to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_opt_gopt_retain(optimizer,error) +SUBROUTINE cp_opt_gopt_retain(optimizer) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_retain', & routineP = moduleN//':'//routineN @@ -322,24 +316,21 @@ SUBROUTINE cp_opt_gopt_retain(optimizer,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(optimizer%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,failure) + CPPreconditionNoFail(optimizer%ref_count>0,cp_failure_level,routineP) optimizer%ref_count=optimizer%ref_count+1 END SUBROUTINE cp_opt_gopt_retain ! ***************************************************************************** !> \brief releases the optimizer (see doc/ReferenceCounting.html) !> \param optimizer the object that should be released -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2002 created [fawzi] !> 09.2003 dealloc_ref->release [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE cp_opt_gopt_release(optimizer,error) +SUBROUTINE cp_opt_gopt_release(optimizer) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_release', & routineP = moduleN//':'//routineN @@ -351,51 +342,51 @@ SUBROUTINE cp_opt_gopt_release(optimizer,error) failure=.FALSE. IF (ASSOCIATED(optimizer)) THEN - CPPreconditionNoFail(optimizer%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(optimizer%ref_count>0,cp_failure_level,routineP) optimizer%ref_count=optimizer%ref_count-1 IF (optimizer%ref_count==0) THEN optimizer%status=6 IF (ASSOCIATED(optimizer%kind_of_bound)) THEN DEALLOCATE(optimizer%kind_of_bound, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%i_work_array)) THEN DEALLOCATE(optimizer%i_work_array, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%isave)) THEN DEALLOCATE(optimizer%isave, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%x)) THEN DEALLOCATE(optimizer%x, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%lower_bound)) THEN DEALLOCATE(optimizer%lower_bound, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%upper_bound)) THEN DEALLOCATE(optimizer%upper_bound, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%gradient)) THEN DEALLOCATE(optimizer%gradient, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%dsave)) THEN DEALLOCATE(optimizer%dsave, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(optimizer%work_array)) THEN DEALLOCATE(optimizer%work_array, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF - CALL cp_para_env_release(optimizer%para_env,error=error) - CALL gopt_f_release(optimizer%obj_funct,error=error) + CALL cp_para_env_release(optimizer%para_env) + CALL gopt_f_release(optimizer%obj_funct) NULLIFY(optimizer%obj_funct) DEALLOCATE(optimizer, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(optimizer) @@ -426,8 +417,6 @@ END SUBROUTINE cp_opt_gopt_release !> \param is_master ... !> \param last_f ... !> \param f ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -439,7 +428,7 @@ SUBROUTINE cp_opt_gopt_get(optimizer, para_env, & x, lower_bound, upper_bound, kind_of_bound, master,& actual_projected_gradient, & n_var, n_iter, status, max_f_per_iter,at_end,& - is_master, last_f, f, error) + is_master, last_f, f) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer TYPE(cp_para_env_type), OPTIONAL, & POINTER :: para_env @@ -456,7 +445,6 @@ SUBROUTINE cp_opt_gopt_get(optimizer, para_env, & max_f_per_iter LOGICAL, INTENT(out), OPTIONAL :: at_end, is_master REAL(kind=dp), INTENT(out), OPTIONAL :: last_f, f - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_get', & routineP = moduleN//':'//routineN @@ -465,8 +453,8 @@ SUBROUTINE cp_opt_gopt_get(optimizer, para_env, & ! call timeset(routineN,handle) - CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,error,failure) - CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,failure) + CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(is_master)) is_master=optimizer%master==optimizer%para_env%mepos IF (PRESENT(master)) master=optimizer%master @@ -500,8 +488,8 @@ SUBROUTINE cp_opt_gopt_get(optimizer, para_env, & IF (PRESENT(actual_projected_gradient))& actual_projected_gradient=optimizer%dsave(13) ELSE - CPPrecondition(.NOT.PRESENT(last_f),cp_warning_level,routineP,error,failure) - CPPrecondition(.NOT.PRESENT(actual_projected_gradient),cp_warning_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(last_f),cp_warning_level,routineP,failure) + CPPrecondition(.NOT.PRESENT(actual_projected_gradient),cp_warning_level,routineP,failure) END IF ELSE CALL cp_assert(.NOT.(PRESENT(lower_bound).OR.& @@ -509,7 +497,7 @@ SUBROUTINE cp_opt_gopt_get(optimizer, para_env, & cp_warning_level,cp_assertion_failed,& routineP, "asked undefined types in "//& CPSourceFileRef,& - error,failure) + failure) END IF ! call timestop(handle) @@ -526,8 +514,6 @@ END SUBROUTINE cp_opt_gopt_get !> \param geo_section ... !> \param force_env ... !> \param gopt_param ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -537,7 +523,7 @@ END SUBROUTINE cp_opt_gopt_get ! ***************************************************************************** RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& projected_gradient, converged, geo_section, force_env,& - gopt_param, error) + gopt_param) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer INTEGER, INTENT(out), OPTIONAL :: n_iter REAL(kind=dp), INTENT(out), OPTIONAL :: f, last_f, projected_gradient @@ -545,7 +531,6 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& TYPE(section_vals_type), POINTER :: geo_section TYPE(force_env_type), POINTER :: force_env TYPE(gopt_param_type), POINTER :: gopt_param - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_step', & routineP = moduleN//':'//routineN @@ -559,26 +544,25 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger,xold) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) failure=.FALSE. justEntred=.TRUE. is_master=optimizer%master==optimizer%para_env%mepos IF (PRESENT(converged)) converged = optimizer%status==4 ALLOCATE(xold(SIZE(optimizer%x)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) xold = optimizer%x t_old = m_walltime() - CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,error,failure) - CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,failure) + CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,failure) IF (optimizer%status>=4) THEN CALL cp_assert(.FALSE.,level=cp_warning_level,& error_nr=cp_assertion_failed,fromWhere=routineP,& message="status>=4, trying to restart in "//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) optimizer%status=0 IF (is_master) THEN optimizer%task='START' @@ -643,15 +627,13 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& optimizer%status=5 CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"task became stop in an unknown way in "//& -CPSourceFileRef,& - error) +CPSourceFileRef) ELSE IF (optimizer%task(1:5)=='ERROR') THEN optimizer%status=5 ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"unknown task '"//optimizer%task//"' in "//& -CPSourceFileRef,& - error) +CPSourceFileRef) END IF END IF ifMaster CALL mp_bcast(optimizer%status,optimizer%master, optimizer%para_env%group) @@ -671,8 +653,8 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& f=optimizer%f,& gradient=optimizer%gradient,& final_evaluation=.FALSE.,& - master=optimizer%master,para_env=optimizer%para_env,& - error=error) ! do not use keywords? + master=optimizer%master,para_env=optimizer%para_env) + ! do not use keywords? IF (is_master) THEN CALL setulb (SIZE(optimizer%x), optimizer%m, optimizer%x, & optimizer%lower_bound, optimizer%upper_bound, & @@ -692,7 +674,7 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& !op=3 ended iter wildcard = "LBFGS" dataunit = cp_print_key_unit_nr(logger,geo_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".geoLog",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".geoLog") IF (is_master) its = optimizer%isave(30) CALL mp_bcast(its,optimizer%master,optimizer%para_env%group) @@ -702,11 +684,10 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& t_old = t_now CALL gopt_f_io(optimizer%obj_funct, force_env, force_env%root_section, & its, optimizer%f, dataunit, optimizer%eold, optimizer%emin, wildcard, gopt_param,& - SIZE(optimizer%x), optimizer%x-xold, optimizer%gradient, conv, used_time=t_diff,& - error=error) + SIZE(optimizer%x), optimizer%x-xold, optimizer%gradient, conv, used_time=t_diff) CALL mp_bcast(conv,optimizer%master,optimizer%para_env%group) CALL cp_print_key_finished_output(dataunit,logger,geo_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") optimizer%eold = optimizer%f optimizer%emin = MIN(optimizer%emin,optimizer%eold) xold = optimizer%x @@ -717,7 +698,7 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& ! Specific L-BFGS convergence criteria.. overrides the convergence criteria on ! stepsize and gradients dataunit = cp_print_key_unit_nr(logger,geo_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".geoLog",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".geoLog") IF (dataunit>0) THEN WRITE(dataunit,'(T2,A)')"" WRITE(dataunit,'(T2,A)')"***********************************************" @@ -728,11 +709,11 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& WRITE(dataunit,'(T2,A)')"" END IF CALL cp_print_key_finished_output(dataunit,logger,geo_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") IF (PRESENT(converged)) converged=.TRUE. EXIT CASE (5) - ! op=5 abnormal exit (error) + ! op=5 abnormal exit () CALL mp_bcast(optimizer%task,optimizer%master,& optimizer%para_env%group) CASE (6) @@ -740,13 +721,13 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"step on a deallocated opt structure "//& CPSourceFileRef,& - error,failure) + failure) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown status "//cp_to_string(optimizer%status)//& " in "//& CPSourceFileRef,& - error,failure) + failure) optimizer%status=5 EXIT END SELECT @@ -761,10 +742,10 @@ RECURSIVE SUBROUTINE cp_opt_gopt_step(optimizer,n_iter,f,last_f,& CALL cp_opt_gopt_bcast_res(optimizer,& n_iter=optimizer%n_iter,& f=optimizer%f, last_f=optimizer%last_f,& - projected_gradient=optimizer%projected_gradient,error=error) + projected_gradient=optimizer%projected_gradient) DEALLOCATE(xold,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(f)) f=optimizer%f IF (PRESENT(last_f)) last_f=optimizer%last_f IF (PRESENT(projected_gradient)) & @@ -781,8 +762,6 @@ END SUBROUTINE cp_opt_gopt_step !> \param f the actual value of the objective function (f) !> \param last_f the last value of f !> \param projected_gradient the infinity norm of the projected gradient -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -791,11 +770,10 @@ END SUBROUTINE cp_opt_gopt_step !> private routine ! ***************************************************************************** SUBROUTINE cp_opt_gopt_bcast_res(optimizer, n_iter,f,last_f,& - projected_gradient,error) + projected_gradient) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer INTEGER, INTENT(out), OPTIONAL :: n_iter REAL(kind=dp), INTENT(inout), OPTIONAL :: f, last_f, projected_gradient - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_bcast_res', & routineP = moduleN//':'//routineN @@ -805,8 +783,8 @@ SUBROUTINE cp_opt_gopt_bcast_res(optimizer, n_iter,f,last_f,& ! call timeset(routineN,handle) - CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,error,failure) - CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,failure) + CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,failure) IF (optimizer%master==optimizer%para_env%mepos) THEN results=(/ REAL(optimizer%isave(30), kind=dp), & @@ -835,8 +813,6 @@ END SUBROUTINE cp_opt_gopt_bcast_res !> \param geo_section ... !> \param force_env ... !> \param gopt_param ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -847,7 +823,7 @@ END SUBROUTINE cp_opt_gopt_bcast_res ! ***************************************************************************** RECURSIVE FUNCTION cp_opt_gopt_next(optimizer,n_iter,f,last_f,& projected_gradient, converged, geo_section,force_env,& - gopt_param, error) RESULT(res) + gopt_param) RESULT(res) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer INTEGER, INTENT(out), OPTIONAL :: n_iter REAL(kind=dp), INTENT(out), OPTIONAL :: f, last_f, projected_gradient @@ -855,7 +831,6 @@ RECURSIVE FUNCTION cp_opt_gopt_next(optimizer,n_iter,f,last_f,& TYPE(section_vals_type), POINTER :: geo_section TYPE(force_env_type), POINTER :: force_env TYPE(gopt_param_type), POINTER :: gopt_param - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_next', & @@ -866,13 +841,12 @@ RECURSIVE FUNCTION cp_opt_gopt_next(optimizer,n_iter,f,last_f,& failure=.FALSE. !call timeset(routineN,handle) - CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,error,failure) - CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,failure) + CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,failure) CALL cp_opt_gopt_step(optimizer,n_iter=n_iter,f=f,& last_f=last_f, projected_gradient=projected_gradient,& converged=converged,geo_section=geo_section,& - force_env=force_env,gopt_param=gopt_param,& - error=error) + force_env=force_env,gopt_param=gopt_param) res= (optimizer%status<40) .AND. .NOT. converged !call timestop(handle) END FUNCTION cp_opt_gopt_next @@ -880,8 +854,6 @@ END FUNCTION cp_opt_gopt_next ! ***************************************************************************** !> \brief stops the optimization !> \param optimizer ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -889,9 +861,8 @@ END FUNCTION cp_opt_gopt_next !> \note !> necessary??? ! ***************************************************************************** - SUBROUTINE cp_opt_gopt_stop(optimizer, error) + SUBROUTINE cp_opt_gopt_stop(optimizer) TYPE(cp_lbfgs_opt_gopt_type), POINTER :: optimizer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_opt_gopt_stop', & routineP = moduleN//':'//routineN @@ -901,8 +872,8 @@ SUBROUTINE cp_opt_gopt_stop(optimizer, error) failure=.FALSE. ! call timeset(routineN,handle) - CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,error,failure) - CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(optimizer),cp_failure_level,routineP,failure) + CPPrecondition(optimizer%ref_count>0,cp_failure_level,routineP,failure) optimizer%task='STOPPED on user request' optimizer%status=4 ! normal exit diff --git a/src/motion/dimer_methods.F b/src/motion/dimer_methods.F index 3ab306a1a5..b89d13752d 100644 --- a/src/motion/dimer_methods.F +++ b/src/motion/dimer_methods.F @@ -50,19 +50,17 @@ MODULE dimer_methods !> \param f ... !> \param gradient ... !> \param calc_force ... -!> \param error ... !> \date 01.2008 !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] ! ***************************************************************************** - RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error) + RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x REAL(KIND=dp), INTENT(OUT) :: f REAL(KIND=dp), DIMENSION(:), POINTER :: gradient LOGICAL, INTENT(IN) :: calc_force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_eval_at_ts', & routineP = moduleN//':'//routineN @@ -77,12 +75,12 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error failure=.FALSE. NULLIFY(dimer_env,logger, print_section) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPostcondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,failure) dimer_env => gopt_env%dimer_env - CPPostcondition(ASSOCIATED(dimer_env),cp_failure_level,routineP,error,failure) - iw = cp_print_key_unit_nr(logger,gopt_env%geo_section,"PRINT%PROGRAM_RUN_INFO",extension=".log",error=error) + CPPostcondition(ASSOCIATED(dimer_env),cp_failure_level,routineP,failure) + iw = cp_print_key_unit_nr(logger,gopt_env%geo_section,"PRINT%PROGRAM_RUN_INFO",extension=".log") ! Possibly rotate Dimer or just compute Gradients of point 0 for Translation IF (gopt_env%dimer_rotation) THEN IF (debug_this_module.AND.(iw>0)) THEN @@ -97,7 +95,7 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error END IF IF (eval_analytical) THEN ! Compute energy, gradients and rotation vector for R1 - CALL cp_eval_at_ts_low(gopt_env, x, 1, dimer_env, calc_force, f1, dimer_env%rot%g1, error) + CALL cp_eval_at_ts_low(gopt_env, x, 1, dimer_env, calc_force, f1, dimer_env%rot%g1) ELSE angle1 = dimer_env%rot%angle1 angle2 = dimer_env%rot%angle2 @@ -114,7 +112,7 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error WRITE(iw,'(A)')"-2*(G1-G0) vector:" WRITE(iw,'(3F15.9)')gradient END IF - CALL get_theta(gradient, dimer_env, norm, error) + CALL get_theta(gradient, dimer_env, norm) f = norm dimer_env%cg_rot%norm_theta_old = dimer_env%cg_rot%norm_theta dimer_env%cg_rot%norm_theta = norm @@ -132,7 +130,7 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error gradient = -gradient CASE(do_second_rotation_step) ! Compute energy, gradients and rotation vector for R1 - CALL cp_eval_at_ts_low(gopt_env, x, 1, dimer_env, calc_force, f1, dimer_env%rot%g1p, error) + CALL cp_eval_at_ts_low(gopt_env, x, 1, dimer_env, calc_force, f1, dimer_env%rot%g1p) dimer_env%rot%curvature = DOT_PRODUCT(dimer_env%rot%g1p-dimer_env%rot%g0,dimer_env%nvec)/dimer_env%dr dimer_env%rot%rotation_step = do_third_rotation_step @@ -140,7 +138,7 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error ! This is never used for getting a new theta but is consistent in order to ! give back the right value of f gradient = -2.0_dp*(dimer_env%rot%g1p-dimer_env%rot%g0) - CALL get_theta(gradient, dimer_env, norm, error) + CALL get_theta(gradient, dimer_env, norm) f = norm IF (debug_this_module.AND.(iw>0)) THEN @@ -150,7 +148,7 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error END SELECT ELSE ! Compute energy, gradients and rotation vector for R0 - CALL cp_eval_at_ts_low(gopt_env, x, 0, dimer_env, calc_force, f, dimer_env%rot%g0, error) + CALL cp_eval_at_ts_low(gopt_env, x, 0, dimer_env, calc_force, f, dimer_env%rot%g0) ! The dimer is rotated only when we are out of the translation line search IF (.NOT.gopt_env%do_line_search) THEN @@ -160,18 +158,18 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error WRITE(iw,'(3F15.9)')dimer_env%rot%g0 END IF CALL cp_rot_opt(gopt_env%gopt_dimer_env, x, gopt_env%gopt_dimer_param ,& - gopt_env%gopt_dimer_env%geo_section, error) + gopt_env%gopt_dimer_env%geo_section) dimer_env%rot%rotation_step = do_first_rotation_step END IF - print_section => section_vals_get_subs_vals(gopt_env%gopt_dimer_env%geo_section,"PRINT",error=error) + print_section => section_vals_get_subs_vals(gopt_env%gopt_dimer_env%geo_section,"PRINT") ! Correcting gradients for Translation IF (dimer_env%rot%curvature>0) THEN gradient = - DOT_PRODUCT(dimer_env%rot%g0,dimer_env%nvec)*dimer_env%nvec - CALL remove_rot_transl_component(gopt_env, gradient, print_section, error) + CALL remove_rot_transl_component(gopt_env, gradient, print_section) ELSE gradient = dimer_env%rot%g0 - 2.0_dp*DOT_PRODUCT(dimer_env%rot%g0,dimer_env%nvec)*dimer_env%nvec - CALL remove_rot_transl_component(gopt_env, gradient, print_section, error) + CALL remove_rot_transl_component(gopt_env, gradient, print_section) END IF IF (debug_this_module.AND.(iw>0)) THEN WRITE(iw,*)"final gradient:",gradient @@ -183,7 +181,7 @@ RECURSIVE SUBROUTINE cp_eval_at_ts (gopt_env, x, f, gradient, calc_force, error f = -DOT_PRODUCT(gradient,dimer_env%tsl%tls_vec) END IF END IF - CALL cp_print_key_finished_output(iw,logger,gopt_env%geo_section,"PRINT%PROGRAM_RUN_INFO", error=error) + CALL cp_print_key_finished_output(iw,logger,gopt_env%geo_section,"PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE cp_eval_at_ts @@ -192,16 +190,14 @@ END SUBROUTINE cp_eval_at_ts !> \param gopt_env ... !> \param gradient ... !> \param print_section ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE remove_rot_transl_component (gopt_env,gradient,print_section,error) + SUBROUTINE remove_rot_transl_component (gopt_env,gradient,print_section) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:) :: gradient TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'remove_rot_transl_component', & routineP = moduleN//':'//routineN @@ -217,25 +213,25 @@ SUBROUTINE remove_rot_transl_component (gopt_env,gradient,print_section,error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(mat) - CALL force_env_get(gopt_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, particles=particles, error=error) + CALL force_env_get(gopt_env%force_env, subsys=subsys) + CALL cp_subsys_get(subsys, particles=particles) natoms = particles%n_els norm_gradient_old = SQRT(DOT_PRODUCT(gradient,gradient)) IF (norm_gradient_old>0.0_dp) THEN IF (natoms>1) THEN CALL rot_ana(particles%els, mat, dof, print_section, keep_rotations=.FALSE.,& - mass_weighted=.FALSE., natoms=natoms, error=error) + mass_weighted=.FALSE., natoms=natoms) ! Orthogonalize gradient with respect to the full set of Roto-Trasl vectors ALLOCATE(D(3*natoms,dof),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Check First orthogonality in the first element of the basis set DO i = 1, dof D(:,i) = mat(:,i) DO j = i+1, dof norm = DOT_PRODUCT(mat(:,i),mat(:,j)) - CPPostcondition(ABS(norm) \param calc_force ... !> \param f ... !> \param gradient ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** SUBROUTINE cp_eval_at_ts_low (gopt_env, x, dimer_index, dimer_env, calc_force,& - f, gradient, error) + f, gradient) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x INTEGER, INTENT(IN) :: dimer_index @@ -274,7 +269,6 @@ SUBROUTINE cp_eval_at_ts_low (gopt_env, x, dimer_index, dimer_env, calc_force, LOGICAL, INTENT(IN) :: calc_force REAL(KIND=dp), INTENT(OUT), OPTIONAL :: f REAL(KIND=dp), DIMENSION(:), OPTIONAL :: gradient - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_eval_at_ts_low', & routineP = moduleN//':'//routineN @@ -286,8 +280,8 @@ SUBROUTINE cp_eval_at_ts_low (gopt_env, x, dimer_index, dimer_env, calc_force, CALL timeset(routineN,handle) idg=0 - CALL force_env_get(gopt_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, particles=particles, error=error) + CALL force_env_get(gopt_env%force_env, subsys=subsys) + CALL cp_subsys_get(subsys, particles=particles) DO ip=1,particles%n_els DO idir=1,3 idg=idg+1 @@ -296,21 +290,21 @@ SUBROUTINE cp_eval_at_ts_low (gopt_env, x, dimer_index, dimer_env, calc_force, END DO ! Compute energy and forces - CALL force_env_calc_energy_force(gopt_env%force_env,calc_force=calc_force,error=error) + CALL force_env_calc_energy_force(gopt_env%force_env,calc_force=calc_force) ! Possibly take the potential energy IF (PRESENT(f)) THEN - CALL force_env_get(gopt_env%force_env,potential_energy=f,error=error) + CALL force_env_get(gopt_env%force_env,potential_energy=f) END IF ! Possibly take the gradients IF (PRESENT(gradient)) THEN idg=0 - CALL cp_subsys_get(subsys, particles=particles, error=error) + CALL cp_subsys_get(subsys, particles=particles) DO ip=1,particles%n_els DO idir=1,3 idg=idg+1 - CPInvariant(SIZE(gradient)>=idg,cp_failure_level,routineP,error,failure) + CPInvariant(SIZE(gradient)>=idg,cp_failure_level,routineP,failure) gradient(idg)=-particles%els(ip)%f(idir) END DO END DO diff --git a/src/motion/dimer_types.F b/src/motion/dimer_types.F index 9a7a2f1f5a..3a47388806 100644 --- a/src/motion/dimer_types.F +++ b/src/motion/dimer_types.F @@ -92,17 +92,15 @@ MODULE dimer_types !> \param natom ... !> \param globenv ... !> \param dimer_section ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE dimer_env_create(dimer_env, natom, globenv, dimer_section, error) + SUBROUTINE dimer_env_create(dimer_env, natom, globenv, dimer_section) TYPE(dimer_env_type), POINTER :: dimer_env INTEGER, INTENT(IN) :: natom TYPE(global_environment_type), POINTER :: globenv TYPE(section_vals_type), POINTER :: dimer_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dimer_env_create', & routineP = moduleN//':'//routineN @@ -116,10 +114,10 @@ SUBROUTINE dimer_env_create(dimer_env, natom, globenv, dimer_section, error) TYPE(section_vals_type), POINTER :: nvec_section failure=.FALSE. - CPPostcondition(.NOT.ASSOCIATED(dimer_env),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(dimer_env),cp_failure_level,routineP,failure) ALLOCATE(dimer_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - logger => cp_error_get_logger(error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + logger => cp_get_default_logger() dimer_env%ref_count=1 last_dimer_id=last_dimer_id+1 dimer_env%id_nr=last_dimer_id @@ -128,32 +126,32 @@ SUBROUTINE dimer_env_create(dimer_env, natom, globenv, dimer_section, error) dimer_env%tsl%tls_vec) ! Allocate the working arrays ALLOCATE(dimer_env%nvec(natom*3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dimer_env%rot%g0(natom*3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dimer_env%rot%g1(natom*3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dimer_env%rot%g1p(natom*3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Check if the dimer vector is available in the input or not.. - nvec_section => section_vals_get_subs_vals(dimer_section,"DIMER_VECTOR",error=error) - CALL section_vals_get(nvec_section, explicit=explicit, error=error) + nvec_section => section_vals_get_subs_vals(dimer_section,"DIMER_VECTOR") + CALL section_vals_get(nvec_section, explicit=explicit) IF (explicit) THEN CALL cp_log(logger=logger, level=cp_note_level, fromWhere=routineP,& message="Reading Dimer Vector from file!",local=.FALSE.) NULLIFY(array) - CALL section_vals_val_get(nvec_section,"_DEFAULT_KEYWORD_",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(nvec_section,"_DEFAULT_KEYWORD_",n_rep_val=n_rep_val) isize = 0 DO i = 1, n_rep_val - CALL section_vals_val_get(nvec_section,"_DEFAULT_KEYWORD_",r_vals=array,i_rep_val=i,error=error) + CALL section_vals_val_get(nvec_section,"_DEFAULT_KEYWORD_",r_vals=array,i_rep_val=i) DO j = 1, SIZE(array) isize = isize + 1 dimer_env%nvec(isize) = array(j) END DO END DO - CPPostcondition(isize==SIZE(dimer_env%nvec),cp_failure_level,routineP,error,failure) + CPPostcondition(isize==SIZE(dimer_env%nvec),cp_failure_level,routineP,failure) ELSE - CALL random_numbers(dimer_env%nvec, globenv%gaussian_rng_stream, error) + CALL random_numbers(dimer_env%nvec, globenv%gaussian_rng_stream) END IF ! Check for translation in the dimer vector and remove them IF (natom>1) THEN @@ -180,29 +178,27 @@ SUBROUTINE dimer_env_create(dimer_env, natom, globenv, dimer_section, error) only_ionode=.TRUE.) dimer_env%nvec = dimer_env%nvec / norm dimer_env%rot%rotation_step= do_first_rotation_step - CALL section_vals_val_get(dimer_section,"DR",r_val=dimer_env%dr,error=error) + CALL section_vals_val_get(dimer_section,"DR",r_val=dimer_env%dr) CALL section_vals_val_get(dimer_section,"INTERPOLATE_GRADIENT",& - l_val=dimer_env%rot%interpolate_gradient,error=error) + l_val=dimer_env%rot%interpolate_gradient) CALL section_vals_val_get(dimer_section,"ANGLE_TOLERANCE",& - r_val=dimer_env%rot%angle_tol,error=error) + r_val=dimer_env%rot%angle_tol) dimer_env%cg_rot%norm_h = 1.0_dp dimer_env%cg_rot%norm_theta = 0.0_dp dimer_env%cg_rot%norm_theta_old = 0.0_dp ALLOCATE(dimer_env%cg_rot%nvec_old(natom*3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE dimer_env_create ! ***************************************************************************** !> \brief ... !> \param dimer_env ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE dimer_env_retain(dimer_env, error) + SUBROUTINE dimer_env_retain(dimer_env) TYPE(dimer_env_type), POINTER :: dimer_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dimer_env_retain', & routineP = moduleN//':'//routineN @@ -211,22 +207,20 @@ SUBROUTINE dimer_env_retain(dimer_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(dimer_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(dimer_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(dimer_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(dimer_env%ref_count>0,cp_failure_level,routineP) dimer_env%ref_count=dimer_env%ref_count+1 END SUBROUTINE dimer_env_retain ! ***************************************************************************** !> \brief ... !> \param dimer_env ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE dimer_env_release(dimer_env, error) + SUBROUTINE dimer_env_release(dimer_env) TYPE(dimer_env_type), POINTER :: dimer_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dimer_env_release', & routineP = moduleN//':'//routineN @@ -237,33 +231,33 @@ SUBROUTINE dimer_env_release(dimer_env, error) failure=.FALSE. IF (ASSOCIATED(dimer_env)) THEN - CPPreconditionNoFail(dimer_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(dimer_env%ref_count>0,cp_failure_level,routineP) dimer_env%ref_count=dimer_env%ref_count-1 IF (dimer_env%ref_count==0) THEN IF (ASSOCIATED(dimer_env%nvec)) THEN DEALLOCATE(dimer_env%nvec, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(dimer_env%rot%g0)) THEN DEALLOCATE(dimer_env%rot%g0, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(dimer_env%rot%g1)) THEN DEALLOCATE(dimer_env%rot%g1, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(dimer_env%rot%g1p)) THEN DEALLOCATE(dimer_env%rot%g1p, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(dimer_env%cg_rot%nvec_old)) THEN DEALLOCATE(dimer_env%cg_rot%nvec_old, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF ! No need to deallocate tls_vec (just a pointer to aother local array) NULLIFY(dimer_env%tsl%tls_vec) DEALLOCATE(dimer_env, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF END SUBROUTINE dimer_env_release diff --git a/src/motion/dimer_utils.F b/src/motion/dimer_utils.F index f09feb59f0..7cb7ce7b2b 100644 --- a/src/motion/dimer_utils.F +++ b/src/motion/dimer_utils.F @@ -35,15 +35,13 @@ MODULE dimer_utils !> \param nvec ... !> \param theta ... !> \param dt ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE rotate_dimer(nvec,theta,dt,error) + SUBROUTINE rotate_dimer(nvec,theta,dt) REAL(KIND=dp), DIMENSION(:), POINTER :: nvec, theta REAL(KIND=dp) :: dt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotate_dimer', & routineP = moduleN//':'//routineN @@ -53,7 +51,7 @@ SUBROUTINE rotate_dimer(nvec,theta,dt,error) TYPE(cp_logger_type), POINTER :: logger failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) ! Orthogonality check for the rotation.. @@ -62,7 +60,7 @@ SUBROUTINE rotate_dimer(nvec,theta,dt,error) WRITE(output_unit,*)"NVEC and THETA should be orthogonal! Residue: ",& ABS(DOT_PRODUCT(nvec,theta)) END IF - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) nvec = nvec * COS(dt) + theta * SIN(dt) END SUBROUTINE rotate_dimer @@ -71,15 +69,13 @@ END SUBROUTINE rotate_dimer !> \brief Updates the orientation of the dimer vector in the input file !> \param dimer_env ... !> \param motion_section ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE update_dimer_vec(dimer_env, motion_section, error) + SUBROUTINE update_dimer_vec(dimer_env, motion_section) TYPE(dimer_env_type), POINTER :: dimer_env TYPE(section_vals_type), POINTER :: motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_dimer_vec', & routineP = moduleN//':'//routineN @@ -92,16 +88,16 @@ SUBROUTINE update_dimer_vec(dimer_env, motion_section, error) failure = .FALSE. nvec_section => section_vals_get_subs_vals(motion_section,& - "GEO_OPT%TRANSITION_STATE%DIMER%DIMER_VECTOR", error=error) + "GEO_OPT%TRANSITION_STATE%DIMER%DIMER_VECTOR") ! Clean the content of the section first.. - CALL section_vals_remove_values(nvec_section,error) + CALL section_vals_remove_values(nvec_section) ! Fill in the section with the present values.. size_array = 6 isize = 0 i_rep_val = 0 Main_Loop: DO i = 1, SIZE(dimer_env%nvec), size_array ALLOCATE(array(size_array), stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) i_rep_val = i_rep_val + 1 DO j = 1, size_array isize = isize + 1 @@ -109,14 +105,14 @@ SUBROUTINE update_dimer_vec(dimer_env, motion_section, error) IF (isize == SIZE(dimer_env%nvec))THEN CALL reallocate(array,1,j) CALL section_vals_val_set(nvec_section,"_DEFAULT_KEYWORD_",r_vals_ptr=array,& - i_rep_val=i_rep_val,error=error) + i_rep_val=i_rep_val) EXIT Main_Loop END IF END DO CALL section_vals_val_set(nvec_section,"_DEFAULT_KEYWORD_",r_vals_ptr=array,& - i_rep_val=i_rep_val,error=error) + i_rep_val=i_rep_val) END DO Main_Loop - CPPostcondition(isize==SIZE(dimer_env%nvec),cp_failure_level,routineP,error,failure) + CPPostcondition(isize==SIZE(dimer_env%nvec),cp_failure_level,routineP,failure) END SUBROUTINE update_dimer_vec ! ***************************************************************************** @@ -124,16 +120,14 @@ END SUBROUTINE update_dimer_vec !> \param gradient ... !> \param dimer_env ... !> \param norm ... -!> \param error ... !> \par History !> none !> \author Luca Bellucci and Teodoro Laino - created [tlaino] - 01.2008 ! ***************************************************************************** - SUBROUTINE get_theta(gradient, dimer_env, norm, error) + SUBROUTINE get_theta(gradient, dimer_env, norm) REAL(KIND=dp), DIMENSION(:) :: gradient TYPE(dimer_env_type), POINTER :: dimer_env REAL(KIND=dp), INTENT(OUT) :: norm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_theta', & routineP = moduleN//':'//routineN diff --git a/src/motion/free_energy_methods.F b/src/motion/free_energy_methods.F index df94fa93b7..ff4fa2c5ef 100644 --- a/src/motion/free_energy_methods.F +++ b/src/motion/free_energy_methods.F @@ -57,15 +57,13 @@ MODULE free_energy_methods !> \param md_env ... !> \param converged ... !> \param fe_section ... -!> \param error ... !> \par History !> Teodoro Laino (01.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE free_energy_evaluate(md_env,converged,fe_section,error) + SUBROUTINE free_energy_evaluate(md_env,converged,fe_section) TYPE(md_environment_type), POINTER :: md_env LOGICAL, INTENT(OUT) :: converged TYPE(section_vals_type), POINTER :: fe_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'free_energy_evaluate', & routineP = moduleN//':'//routineN @@ -88,25 +86,25 @@ SUBROUTINE free_energy_evaluate(md_env,converged,fe_section,error) TYPE(ui_var_type), POINTER :: cv NULLIFY(force_env, istep, subsys, cv, simpar) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) failure = .FALSE. converged = .FALSE. CALL get_md_env(md_env, force_env=force_env, fe_env=fe_env, simpar=simpar,& - itimes=istep, error=error) + itimes=istep) ! Metadynamics is also a free energy calculation but is handled in a different ! module. IF (.NOT.ASSOCIATED(force_env%meta_env).AND.ASSOCIATED(fe_env)) THEN SELECT CASE(fe_env%type) CASE(do_fe_ui) ! Umbrella Integration.. - CALL force_env_get(force_env, subsys=subsys, error=error) + CALL force_env_get(force_env, subsys=subsys) fe_env%nr_points = fe_env%nr_points + 1 output_unit = cp_logger_get_default_io_unit(logger) DO ic=1,fe_env%ncolvar cv => fe_env%uivar(ic) icolvar = cv%icolvar - CALL colvar_eval_glob_f(icolvar,force_env,error=error) + CALL colvar_eval_glob_f(icolvar,force_env) CALL reallocate(cv%ss,1,fe_env%nr_points) cv%ss(fe_env%nr_points) = subsys%colvar_p(icolvar)%colvar%ss IF (output_unit > 0) THEN @@ -121,26 +119,26 @@ SUBROUTINE free_energy_evaluate(md_env,converged,fe_section,error) IF ( (fe_env%conv_par%cg_width*fe_env%conv_par%cg_points <= stat_sign_points).AND.& (MOD(stat_sign_points,fe_env%conv_par%cg_width)==0) ) THEN output_unit = cp_print_key_unit_nr(logger,fe_section,"FREE_ENERGY_INFO",& - extension=".FreeEnergyLog",log_filename=.FALSE.,error=error) - CALL print_fe_prolog(output_unit,error) + extension=".FreeEnergyLog",log_filename=.FALSE.) + CALL print_fe_prolog(output_unit) ! Trend test.. recomputes the number of statistically significant points.. - CALL ui_check_trend(fe_env, fe_env%conv_par%test_k, stat_sign_points, output_unit, error) + CALL ui_check_trend(fe_env, fe_env%conv_par%test_k, stat_sign_points, output_unit) stat_sign_points = fe_env%nr_points - fe_env%nr_rejected ! Normality and serial correlation tests.. IF (fe_env%conv_par%cg_width*fe_env%conv_par%cg_points <= stat_sign_points.AND.& fe_env%conv_par%test_k) THEN ! Statistical tests - CALL ui_check_convergence(fe_env,converged,stat_sign_points,output_unit,error) + CALL ui_check_convergence(fe_env,converged,stat_sign_points,output_unit) END IF - CALL print_fe_epilog(output_unit,error) - CALL cp_print_key_finished_output(output_unit, logger,fe_section,"FREE_ENERGY_INFO",error=error) + CALL print_fe_epilog(output_unit) + CALL cp_print_key_finished_output(output_unit, logger,fe_section,"FREE_ENERGY_INFO") END IF CASE(do_fe_ac) CALL initf(2) ! Alchemical Changes CALL cp_assert(ASSOCIATED(force_env%mixed_env),cp_fatal_level,-300,routineP,& 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& - ' Free Energy calculations require the definition of a mixed env!',error) + ' Free Energy calculations require the definition of a mixed env!') my_par => force_env%mixed_env%par my_val => force_env%mixed_env%val dx = force_env%mixed_env%dx @@ -150,7 +148,7 @@ SUBROUTINE free_energy_evaluate(md_env,converged,fe_section,error) CALL parsef(1,TRIM(coupling_function),my_par) nforce_eval = SIZE(force_env%sub_force_env) CALL dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval,& - fe_env%covmx, istep, beta, error) + fe_env%covmx, istep, beta) CALL finalizef() CASE DEFAULT ! Do Nothing @@ -163,13 +161,11 @@ END SUBROUTINE free_energy_evaluate ! ***************************************************************************** !> \brief Print prolog of free energy output section !> \param output_unit which unit to print to -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE print_fe_prolog(output_unit,error) + SUBROUTINE print_fe_prolog(output_unit) INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_fe_prolog', & routineP = moduleN//':'//routineN @@ -183,13 +179,11 @@ END SUBROUTINE print_fe_prolog ! ***************************************************************************** !> \brief Print epilog of free energy output section !> \param output_unit which unit to print to -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE print_fe_epilog(output_unit,error) + SUBROUTINE print_fe_epilog(output_unit) INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_fe_epilog', & routineP = moduleN//':'//routineN @@ -205,15 +199,13 @@ END SUBROUTINE print_fe_epilog !> \param trend_free ... !> \param nr_points ... !> \param output_unit which unit to print to -!> \param error ... !> \par History !> Teodoro Laino (01.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE ui_check_trend(fe_env, trend_free, nr_points, output_unit, error) + SUBROUTINE ui_check_trend(fe_env, trend_free, nr_points, output_unit) TYPE(free_energy_type), POINTER :: fe_env LOGICAL, INTENT(OUT) :: trend_free INTEGER, INTENT(IN) :: nr_points, output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ui_check_trend', & routineP = moduleN//':'//routineN @@ -238,9 +230,9 @@ SUBROUTINE ui_check_trend(fe_env, trend_free, nr_points, output_unit, error) ng_points = nr_points/fe_env%conv_par%cg_width my_reject = 0 ! Allocate storage - CALL create_tmp_data(fe_env,wrk,ng_points,ncolvar,error) + CALL create_tmp_data(fe_env,wrk,ng_points,ncolvar) ! Compute the Coarse Grained data set using a reverse cumulative strategy - CALL create_csg_data(fe_env,ng_points,output_unit,error) + CALL create_csg_data(fe_env,ng_points,output_unit) ! Test on coarse grained average DO j = 1, ncolvar ii = 1 @@ -254,7 +246,7 @@ SUBROUTINE ui_check_trend(fe_env, trend_free, nr_points, output_unit, error) test_avg = .FALSE. EXIT END IF - CALL k_test(wrk,my_reject+1,ng_points,tau,z,prob,error) + CALL k_test(wrk,my_reject+1,ng_points,tau,z,prob) PRINT *,prob,fe_env%conv_par%k_conf_lm IF (prob \param wrk ... !> \param ng_points ... !> \param ncolvar ... -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE create_tmp_data(fe_env,wrk,ng_points,ncolvar,error) + SUBROUTINE create_tmp_data(fe_env,wrk,ng_points,ncolvar) TYPE(free_energy_type), POINTER :: fe_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: wrk INTEGER, INTENT(IN) :: ng_points, ncolvar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_tmp_data', & routineP = moduleN//':'//routineN @@ -330,16 +320,16 @@ SUBROUTINE create_tmp_data(fe_env,wrk,ng_points,ncolvar,error) failure = .FALSE. ALLOCATE(fe_env%cg_data(ng_points),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, ng_points ALLOCATE(fe_env%cg_data(i)%avg(ncolvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fe_env%cg_data(i)%var(ncolvar,ncolvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO IF (PRESENT(wrk)) THEN ALLOCATE(wrk(ng_points),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE create_tmp_data @@ -348,16 +338,14 @@ END SUBROUTINE create_tmp_data !> \param fe_env ... !> \param wrk ... !> \param ng_points ... -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE destroy_tmp_data(fe_env,wrk,ng_points,error) + SUBROUTINE destroy_tmp_data(fe_env,wrk,ng_points) TYPE(free_energy_type), POINTER :: fe_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: wrk INTEGER, INTENT(IN) :: ng_points - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'destroy_tmp_data', & routineP = moduleN//':'//routineN @@ -368,15 +356,15 @@ SUBROUTINE destroy_tmp_data(fe_env,wrk,ng_points,error) failure = .FALSE. DO i = 1, ng_points DEALLOCATE(fe_env%cg_data(i)%avg,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(fe_env%cg_data(i)%var,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(fe_env%cg_data,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(wrk)) THEN DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE destroy_tmp_data @@ -385,14 +373,12 @@ END SUBROUTINE destroy_tmp_data !> \param fe_env ... !> \param ng_points ... !> \param output_unit which unit to print to -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE create_csg_data(fe_env,ng_points,output_unit,error) + SUBROUTINE create_csg_data(fe_env,ng_points,output_unit) TYPE(free_energy_type), POINTER :: fe_env INTEGER, INTENT(IN) :: ng_points, output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_csg_data', & routineP = moduleN//':'//routineN @@ -405,7 +391,7 @@ SUBROUTINE create_csg_data(fe_env,ng_points,output_unit,error) IF (output_unit > 0) THEN WRITE(output_unit,*)istart, iend END IF - CALL eval_cov_matrix(fe_env,cg_index=i,istart=istart,iend=iend,output_unit=output_unit,error=error) + CALL eval_cov_matrix(fe_env,cg_index=i,istart=istart,iend=iend,output_unit=output_unit) END DO END SUBROUTINE create_csg_data @@ -417,15 +403,13 @@ END SUBROUTINE create_csg_data !> \param test_passed ... !> \param nr_points ... !> \param output_unit which unit to print to -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE ui_check_norm_sc(fe_env,test_passed,nr_points,output_unit,error) + SUBROUTINE ui_check_norm_sc(fe_env,test_passed,nr_points,output_unit) TYPE(free_energy_type), POINTER :: fe_env LOGICAL, INTENT(OUT) :: test_passed INTEGER, INTENT(IN) :: nr_points, output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ui_check_norm_sc', & routineP = moduleN//':'//routineN @@ -440,7 +424,7 @@ SUBROUTINE ui_check_norm_sc(fe_env,test_passed,nr_points,output_unit,error) ng_points = nr_points/fe_env%conv_par%cg_width PRINT *, ng_points IF (ng_points \param fe_env ... !> \param nr_points ... !> \param output_unit which unit to print to -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit,error) + SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit) TYPE(free_energy_type), POINTER :: fe_env INTEGER, INTENT(IN) :: nr_points, output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ui_check_norm_sc_low', & routineP = moduleN//':'//routineN @@ -490,8 +472,8 @@ SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit,error) avg_test_passed = .TRUE. sdv_test_passed = .TRUE. ng_points = nr_points/fe_env%conv_par%cg_width - CALL create_tmp_data(fe_env,wrk,ng_points,ncolvar,error) - CALL create_csg_data(fe_env,ng_points,output_unit,error) + CALL create_tmp_data(fe_env,wrk,ng_points,ncolvar) + CALL create_csg_data(fe_env,ng_points,output_unit) ! Testing Averages DO j = 1, ncolvar DO i = 1, ng_points @@ -499,7 +481,7 @@ SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit,error) END DO ! Test of Shapiro - Wilks for normality ! - Average - CALL sw_test(wrk, ng_points, w, pw, error) + CALL sw_test(wrk, ng_points, w, pw) PRINT *, 1.0_dp-pw,fe_env%conv_par%sw_conf_lm avg_test_passed = (1.0_dp-pw)<=fe_env%conv_par%sw_conf_lm fe_env%conv_par%test_sw = avg_test_passed @@ -508,7 +490,7 @@ SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit,error) END IF ! Test of von Neumann for serial correlation ! - Average - CALL vn_test(wrk,ng_points,r,u,prob,error) + CALL vn_test(wrk,ng_points,r,u,prob) PRINT *, prob, fe_env%conv_par%vn_conf_lm avg_test_passed = prob<=fe_env%conv_par%vn_conf_lm fe_env%conv_par%test_vn = avg_test_passed @@ -526,7 +508,7 @@ SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit,error) END DO ! Test of Shapiro - Wilks for normality ! - Standard Deviation - CALL sw_test(wrk, ng_points, w, pw, error) + CALL sw_test(wrk, ng_points, w, pw) PRINT *, 1.0_dp-pw,fe_env%conv_par%sw_conf_lm sdv_test_passed = (1.0_dp-pw)<=fe_env%conv_par%sw_conf_lm fe_env%conv_par%test_sw = fe_env%conv_par%test_sw .AND. sdv_test_passed @@ -535,7 +517,7 @@ SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit,error) END IF ! Test of von Neumann for serial correlation ! - Standard Deviation - CALL vn_test(wrk,ng_points,r,u,prob,error) + CALL vn_test(wrk,ng_points,r,u,prob) PRINT *, prob, fe_env%conv_par%vn_conf_lm sdv_test_passed = prob<=fe_env%conv_par%vn_conf_lm fe_env%conv_par%test_vn = fe_env%conv_par%test_vn .AND. sdv_test_passed @@ -544,9 +526,9 @@ SUBROUTINE ui_check_norm_sc_low(fe_env,nr_points,output_unit,error) END IF END DO END DO - CALL destroy_tmp_data(fe_env,wrk,ng_points,error) + CALL destroy_tmp_data(fe_env,wrk,ng_points) ELSE - CALL destroy_tmp_data(fe_env,wrk,ng_points,error) + CALL destroy_tmp_data(fe_env,wrk,ng_points) END IF CALL timestop(handle) END SUBROUTINE ui_check_norm_sc_low @@ -558,15 +540,13 @@ END SUBROUTINE ui_check_norm_sc_low !> \param converged ... !> \param nr_points ... !> \param output_unit which unit to print to -!> \param error ... !> \par History !> Teodoro Laino (01.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE ui_check_convergence(fe_env,converged,nr_points,output_unit,error) + SUBROUTINE ui_check_convergence(fe_env,converged,nr_points,output_unit) TYPE(free_energy_type), POINTER :: fe_env LOGICAL, INTENT(OUT) :: converged INTEGER, INTENT(IN) :: nr_points, output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ui_check_convergence', & routineP = moduleN//':'//routineN @@ -583,21 +563,21 @@ SUBROUTINE ui_check_convergence(fe_env,converged,nr_points,output_unit,error) converged = .FALSE. ncolvar = fe_env%ncolvar NULLIFY(avgmx, avg_std, covmx, cov_std) - CALL ui_check_norm_sc(fe_env,test_passed,nr_points,output_unit,error) + CALL ui_check_norm_sc(fe_env,test_passed,nr_points,output_unit) IF (test_passed) THEN ng_points = nr_points/fe_env%conv_par%cg_width ! We can finally compute the error on average and covariance matrix ! and check if we converged.. - CALL create_tmp_data(fe_env,ng_points=ng_points,ncolvar=ncolvar,error=error) - CALL create_csg_data(fe_env,ng_points,output_unit,error) + CALL create_tmp_data(fe_env,ng_points=ng_points,ncolvar=ncolvar) + CALL create_csg_data(fe_env,ng_points,output_unit) ALLOCATE(covmx(ncolvar,ncolvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(avgmx(ncolvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cov_std(ncolvar*(ncolvar+1)/2,ncolvar*(ncolvar+1)/2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(avg_std(ncolvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) covmx = 0.0_dp avgmx = 0.0_dp DO i = 1, ng_points @@ -608,7 +588,7 @@ SUBROUTINE ui_check_convergence(fe_env,converged,nr_points,output_unit,error) avgmx = avgmx / REAL(ng_points, KIND=dp) ! Compute errors on average and standard deviation - CALL compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_std, error) + CALL compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_std) IF (output_unit>0) THEN WRITE(output_unit,*)"pippo",avgmx, covmx WRITE(output_unit,*)"pippo",avg_std, cov_std @@ -641,15 +621,15 @@ SUBROUTINE ui_check_convergence(fe_env,converged,nr_points,output_unit,error) WRITE(output_unit,'(T2,"CV",I8,21X,7X,E12.6,14X,E12.6)')& (ic,avgmx(ic),SQRT(ABS(avg_std(ic))),ic=1,ncolvar) END IF - CALL destroy_tmp_data(fe_env,ng_points=ng_points,error=error) + CALL destroy_tmp_data(fe_env,ng_points=ng_points) DEALLOCATE(covmx,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(avgmx,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cov_std,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(avg_std,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE ui_check_convergence @@ -663,18 +643,16 @@ END SUBROUTINE ui_check_convergence !> \param covmx ... !> \param avg_std ... !> \param cov_std ... -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_std, error) + SUBROUTINE compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_std) TYPE(free_energy_type), POINTER :: fe_env INTEGER, INTENT(IN) :: ncolvar REAL(KIND=dp), DIMENSION(:), POINTER :: avgmx REAL(KIND=dp), DIMENSION(:, :), POINTER :: covmx REAL(KIND=dp), DIMENSION(:), POINTER :: avg_std REAL(KIND=dp), DIMENSION(:, :), POINTER :: cov_std - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_avg_std_errors', & routineP = moduleN//':'//routineN @@ -689,9 +667,9 @@ SUBROUTINE compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_st ! Averages nvar = ncolvar ALLOCATE(wrk(nvar,nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(eig(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fac = REAL(SIZE(fe_env%cg_data),KIND=dp) wrk = 0.0_dp eig = 0.0_dp @@ -710,24 +688,24 @@ SUBROUTINE compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_st END DO wrk = wrk / (fac-1.0_dp) ! Diagonalize the covariance matrix and check for the maximum error - CALL diamat_all(wrk,eig,error=error) + CALL diamat_all(wrk,eig) DO i = 1, nvar avg_std(i) = eig(i) END DO DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(eig,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Standard Deviations nvar = ncolvar*(ncolvar+1)/2 ALLOCATE(wrk(nvar,nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(eig(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(awrk(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wrk = 0.0_dp eig = 0.0_dp ind = 0 @@ -759,7 +737,7 @@ SUBROUTINE compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_st END DO wrk = wrk / (fac-1.0_dp) ! Diagonalize the covariance matrix and check for the maximum error - CALL diamat_all(wrk,eig,error=error) + CALL diamat_all(wrk,eig) ind = 0 DO i = 1, ncolvar DO j = i, ncolvar @@ -769,13 +747,13 @@ SUBROUTINE compute_avg_std_errors(fe_env, ncolvar, avgmx, covmx, avg_std, cov_st END DO END DO DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(eig,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(awrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE compute_avg_std_errors @@ -788,11 +766,10 @@ END SUBROUTINE compute_avg_std_errors !> \param output_unit which unit to print to !> \param covmx ... !> \param avgs ... -!> \param error ... !> \par History !> Teodoro Laino (01.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE eval_cov_matrix(fe_env,cg_index,istart,iend,output_unit,covmx,avgs,error) + SUBROUTINE eval_cov_matrix(fe_env,cg_index,istart,iend,output_unit,covmx,avgs) TYPE(free_energy_type), POINTER :: fe_env INTEGER, INTENT(IN) :: cg_index, istart, iend, & output_unit @@ -800,7 +777,6 @@ SUBROUTINE eval_cov_matrix(fe_env,cg_index,istart,iend,output_unit,covmx,avgs,er OPTIONAL, POINTER :: covmx REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: avgs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'eval_cov_matrix', & routineP = moduleN//':'//routineN @@ -866,12 +842,10 @@ END SUBROUTINE eval_cov_matrix !> \param cum_res ... !> \param istep ... !> \param beta ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino - University of Zurich [tlaino] - 05.2007 ! ***************************************************************************** SUBROUTINE dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval, cum_res,& - istep, beta, error) + istep, beta) REAL(KIND=dp), DIMENSION(:), POINTER :: my_val CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: my_par @@ -881,7 +855,6 @@ SUBROUTINE dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval, cum_r REAL(KIND=dp), DIMENSION(:, :), POINTER :: cum_res INTEGER, POINTER :: istep REAL(KIND=dp), INTENT(IN) :: beta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dump_ac_info', & routineP = moduleN//':'//routineN @@ -897,13 +870,13 @@ SUBROUTINE dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval, cum_r TYPE(section_vals_type), POINTER :: alch_section failure = .FALSE. - logger => cp_error_get_logger(error) - alch_section => section_vals_get_subs_vals(fe_section,"ALCHEMICAL_CHANGE",error=error) - CALL section_vals_val_get(alch_section,"PARAMETER",c_val=par,error=error) + logger => cp_get_default_logger() + alch_section => section_vals_get_subs_vals(fe_section,"ALCHEMICAL_CHANGE") + CALL section_vals_val_get(alch_section,"PARAMETER",c_val=par) DO i = 1, SIZE(my_par) IF (my_par(i)==par) EXIT END DO - CPPrecondition(i<=SIZE(my_par),cp_failure_level,routineP,error,failure) + CPPrecondition(i<=SIZE(my_par),cp_failure_level,routineP,failure) ipar = i dedf = evalfd(1,ipar,my_val,dx,err) IF (ABS(err)>lerr) THEN @@ -914,13 +887,13 @@ SUBROUTINE dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval, cum_r CALL cp_assert(.FALSE.,cp_warning_level,-300,routineP,& 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& ' Error '//TRIM(this_error)//' in computing numerical derivatives larger then'//& - TRIM(def_error)//' .',error=error,only_ionode=.TRUE.) + TRIM(def_error)//' .',only_ionode=.TRUE.) END IF ! We must print now the energy of the biased system, the weigthing energy ! and the derivative w.r.t.the coupling parameter of the biased energy ! Retrieve the expression of the weighting function: - CALL section_vals_val_get(alch_section,"WEIGHTING_FUNCTION",c_val=coupling_function,error=error) + CALL section_vals_val_get(alch_section,"WEIGHTING_FUNCTION",c_val=coupling_function) CALL compress(coupling_function, full=.TRUE.) CALL parsef(2,TRIM(coupling_function),my_par) ene_w = evalf(2,my_val) @@ -933,9 +906,9 @@ SUBROUTINE dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval, cum_r CALL cp_assert(.FALSE.,cp_warning_level,-300,routineP,& 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& ' Error '//TRIM(this_error)//' in computing numerical derivatives larger then'//& - TRIM(def_error)//' .',error=error,only_ionode=.TRUE.) + TRIM(def_error)//' .',only_ionode=.TRUE.) END IF - CALL section_vals_val_get(alch_section,"NEQUIL_STEPS",i_val=NEquilStep,error=error) + CALL section_vals_val_get(alch_section,"NEQUIL_STEPS",i_val=NEquilStep) ! Store results IF (istep>NEquilStep) THEN isize = SIZE(cum_res,2)+1 @@ -967,7 +940,7 @@ SUBROUTINE dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval, cum_r END IF ! Print info iw = cp_print_key_unit_nr(logger,fe_section,"FREE_ENERGY_INFO",& - extension=".free_energy",error=error) + extension=".free_energy") IF (iw>0) THEN WRITE(iw,'(T2,79("-"),T37," oOo ")') DO iforce_eval = 1, nforce_eval @@ -995,7 +968,7 @@ SUBROUTINE dump_ac_info(my_val, my_par, dx, lerr, fe_section, nforce_eval, cum_r WRITE(iw,'(T2,79("-"))') END IF END IF - CALL cp_print_key_finished_output(iw,logger,fe_section,"FREE_ENERGY_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,fe_section,"FREE_ENERGY_INFO") END SUBROUTINE dump_ac_info diff --git a/src/motion/geo_opt.F b/src/motion/geo_opt.F index 343a5d7cc0..dc15631d2e 100644 --- a/src/motion/geo_opt.F +++ b/src/motion/geo_opt.F @@ -52,15 +52,12 @@ MODULE geo_opt !> \param globenv ... !> \param eval_opt_geo ... !> \param rm_restart_info ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - RECURSIVE SUBROUTINE cp_geo_opt(force_env, globenv, eval_opt_geo, rm_restart_info, error) + RECURSIVE SUBROUTINE cp_geo_opt(force_env, globenv, eval_opt_geo, rm_restart_info) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv LOGICAL, INTENT(IN), OPTIONAL :: eval_opt_geo, rm_restart_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_geo_opt', & routineP = moduleN//':'//routineN @@ -76,36 +73,36 @@ RECURSIVE SUBROUTINE cp_geo_opt(force_env, globenv, eval_opt_geo, rm_restart_inf failure = .FALSE. CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) NULLIFY (gopt_param,force_env_section,gopt_env,x0) root_section => force_env%root_section force_env_section => force_env%force_env_section - geo_section => section_vals_get_subs_vals(root_section,"MOTION%GEO_OPT",error=error) + geo_section => section_vals_get_subs_vals(root_section,"MOTION%GEO_OPT") - CALL gopt_param_read(gopt_param, geo_section, error=error) + CALL gopt_param_read(gopt_param, geo_section) CALL gopt_f_create(gopt_env, gopt_param, force_env=force_env, globenv=globenv,& - geo_opt_section=geo_section, eval_opt_geo=eval_opt_geo, error=error) - CALL gopt_f_create_x0(gopt_env, x0, error=error) + geo_opt_section=geo_section, eval_opt_geo=eval_opt_geo) + CALL gopt_f_create_x0(gopt_env, x0) - CALL section_vals_val_get(geo_section,"STEP_START_VAL",i_val=step_start_val,error=error) - CALL cp_add_iter_level(logger%iter_info,"GEO_OPT",error=error) - CALL cp_iterate(logger%iter_info,iter_nr=step_start_val,error=error) + CALL section_vals_val_get(geo_section,"STEP_START_VAL",i_val=step_start_val) + CALL cp_add_iter_level(logger%iter_info,"GEO_OPT") + CALL cp_iterate(logger%iter_info,iter_nr=step_start_val) CALL cp_geo_opt_low(force_env, globenv, gopt_param, gopt_env,& - force_env_section, geo_section, x0, error) - CALL cp_rm_iter_level(logger%iter_info,"GEO_OPT",error=error) + force_env_section, geo_section, x0) + CALL cp_rm_iter_level(logger%iter_info,"GEO_OPT") ! Reset counter for next iteration, unless rm_restart_info==.FALSE. my_rm_restart_info = .TRUE. IF(PRESENT(rm_restart_info)) my_rm_restart_info = rm_restart_info IF(my_rm_restart_info) & - CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=0,error=error) + CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=0) DEALLOCATE (x0,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL gopt_f_release(gopt_env, error=error) - CALL gopt_param_release(gopt_param, error=error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL gopt_f_release(gopt_env) + CALL gopt_param_release(gopt_param) CALL timestop(handle) END SUBROUTINE cp_geo_opt @@ -116,15 +113,12 @@ END SUBROUTINE cp_geo_opt !> \param x0 ... !> \param gopt_param ... !> \param geo_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE cp_rot_opt(gopt_env, x0, gopt_param, geo_section, error) + SUBROUTINE cp_rot_opt(gopt_env, x0, gopt_param, geo_section) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0 TYPE(gopt_param_type), POINTER :: gopt_param TYPE(section_vals_type), POINTER :: geo_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_rot_opt', & routineP = moduleN//':'//routineN @@ -137,21 +131,21 @@ SUBROUTINE cp_rot_opt(gopt_env, x0, gopt_param, geo_section, error) failure = .FALSE. CALL timeset(routineN,handle) NULLIFY (force_env_section) - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_env%force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_env%globenv),cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_env%force_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_env%globenv),cp_failure_level,routineP,failure) force_env_section => gopt_env%force_env%force_env_section - CALL section_vals_val_get(geo_section,"STEP_START_VAL",i_val=step_start_val,error=error) - CALL cp_add_iter_level(logger%iter_info,"ROT_OPT",error=error) - CALL cp_iterate(logger%iter_info,iter_nr=step_start_val,error=error) + CALL section_vals_val_get(geo_section,"STEP_START_VAL",i_val=step_start_val) + CALL cp_add_iter_level(logger%iter_info,"ROT_OPT") + CALL cp_iterate(logger%iter_info,iter_nr=step_start_val) CALL cp_geo_opt_low(gopt_env%force_env, gopt_env%globenv, gopt_param, gopt_env,& - force_env_section, geo_section, x0, error) - CALL cp_rm_iter_level(logger%iter_info,"ROT_OPT",error=error) + force_env_section, geo_section, x0) + CALL cp_rm_iter_level(logger%iter_info,"ROT_OPT") ! Reset counter for next iteration - CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=0,error=error) + CALL section_vals_val_set(geo_section,"STEP_START_VAL",i_val=0) CALL timestop(handle) END SUBROUTINE cp_rot_opt @@ -165,18 +159,15 @@ END SUBROUTINE cp_rot_opt !> \param force_env_section ... !> \param geo_section ... !> \param x0 ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** RECURSIVE SUBROUTINE cp_geo_opt_low(force_env, globenv, gopt_param, gopt_env, force_env_section,& - geo_section, x0, error) + geo_section, x0) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv TYPE(gopt_param_type), POINTER :: gopt_param TYPE(gopt_f_type), POINTER :: gopt_env TYPE(section_vals_type), POINTER :: force_env_section, geo_section REAL(KIND=dp), DIMENSION(:), POINTER :: x0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_geo_opt_low', & routineP = moduleN//':'//routineN @@ -184,26 +175,26 @@ RECURSIVE SUBROUTINE cp_geo_opt_low(force_env, globenv, gopt_param, gopt_env, fo LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(x0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(force_env_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(geo_section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(x0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(force_env_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(geo_section),cp_failure_level,routineP,failure) SELECT CASE (gopt_param%method_id) CASE (default_bfgs_method_id) CALL geoopt_bfgs(force_env,gopt_param,globenv,& - geo_section, gopt_env, x0, error=error) + geo_section, gopt_env, x0) CASE (default_lbfgs_method_id) CALL geoopt_lbfgs(force_env,gopt_param,globenv,& - geo_section, gopt_env, x0, error=error) + geo_section, gopt_env, x0) CASE (default_cg_method_id) CALL geoopt_cg(force_env,gopt_param,globenv,& - geo_section, gopt_env, x0, error=error) + geo_section, gopt_env, x0) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE cp_geo_opt_low diff --git a/src/motion/glbopt_callback.F b/src/motion/glbopt_callback.F index aa44a85a41..92a8f518f4 100644 --- a/src/motion/glbopt_callback.F +++ b/src/motion/glbopt_callback.F @@ -38,14 +38,12 @@ MODULE glbopt_callback !> \param mdctrl_data ... !> \param md_env ... !> \param should_stop ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE glbopt_md_callback(mdctrl_data, md_env, should_stop, error) + SUBROUTINE glbopt_md_callback(mdctrl_data, md_env, should_stop) TYPE(glbopt_mdctrl_data_type), POINTER :: mdctrl_data TYPE(md_environment_type), POINTER :: md_env LOGICAL, INTENT(inout) :: should_stop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'glbopt_md_callback', & routineP = moduleN//':'//routineN @@ -59,14 +57,14 @@ SUBROUTINE glbopt_md_callback(mdctrl_data, md_env, should_stop, error) TYPE(md_ener_type), POINTER :: md_ener failure = .FALSE. - CPPrecondition(ASSOCIATED(mdctrl_data), cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(md_env), cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mdctrl_data), cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(md_env), cp_failure_level,routineP,failure) iw = mdctrl_data%output_unit ! add new potential energy value to history NULLIFY(md_ener, itimes) - CALL get_md_env(md_env=md_env, md_ener=md_ener, itimes=itimes, force_env=force_env, error=error) + CALL get_md_env(md_env=md_env, md_ener=md_ener, itimes=itimes, force_env=force_env) mdctrl_data%itimes = itimes mdctrl_data%epot_history(:) = EOSHIFT(mdctrl_data%epot_history, shift=-1) @@ -94,10 +92,10 @@ SUBROUTINE glbopt_md_callback(mdctrl_data, md_env, should_stop, error) IF(iw>0) WRITE (iw,"(A)") " GLBOPT| Stopping MD because of MD_BUMPS_MAX." END IF - CALL force_env_get(force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, natom=n_atoms, error=error) + CALL force_env_get(force_env, subsys=subsys) + CALL cp_subsys_get(subsys, natom=n_atoms) ALLOCATE(positions(3*n_atoms)) - CALL pack_subsys_particles(subsys, r=positions, error=error) + CALL pack_subsys_particles(subsys, r=positions) END SUBROUTINE glbopt_md_callback diff --git a/src/motion/gopt_f77_methods.F b/src/motion/gopt_f77_methods.F index a6ac97eb4f..5053eb8575 100644 --- a/src/motion/gopt_f77_methods.F +++ b/src/motion/gopt_f77_methods.F @@ -13,15 +13,13 @@ !> \param master ... !> \param final_evaluation ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> CELL OPTIMIZATION: Teodoro Laino [tlaino] - University of Zurich - 03.2008 !> !> \author Teodoro Laino [tlaino] - University of Zurich - 01.2008 ! ***************************************************************************** RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& - final_evaluation,para_env,error) + final_evaluation,para_env) USE averages_types, ONLY: average_quantities_type,& create_averages,& @@ -88,7 +86,6 @@ RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& INTEGER, INTENT(IN) :: master LOGICAL, INTENT(IN), OPTIONAL :: final_evaluation TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_eval_at', moduleN='gopt_f77_methods',& routineP = moduleN//':'//routineN @@ -123,61 +120,59 @@ RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& CALL timeset(routineN,handle) - CALL force_env_get(gopt_env%force_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(gopt_env%force_env,subsys=subsys,cell=cell) CALL cp_subsys_get(subsys,& core_particles=core_particles,& particles=particles,& shell_particles=shell_particles,& - virial=virial,& - error=error) + virial=virial) my_final_evaluation = .FALSE. IF (PRESENT(final_evaluation)) my_final_evaluation = final_evaluation SELECT CASE (gopt_env%type_id) CASE (default_minimization_method_id,default_ts_method_id) - CALL unpack_subsys_particles(subsys=subsys,r=x,error=error) - CALL write_structure_data(particles%els,cell,gopt_env%motion_section,error) + CALL unpack_subsys_particles(subsys=subsys,r=x) + CALL write_structure_data(particles%els,cell,gopt_env%motion_section) SELECT CASE (gopt_env%type_id) CASE (default_minimization_method_id) ! Geometry Minimization CALL force_env_calc_energy_force(gopt_env%force_env,& calc_force=PRESENT(gradient),& - require_consistent_energy_force=gopt_env%require_consistent_energy_force,& - error=error) + require_consistent_energy_force=gopt_env%require_consistent_energy_force) ! Possibly take the potential energy IF (PRESENT(f)) THEN - CALL force_env_get(gopt_env%force_env,potential_energy=f,error=error) + CALL force_env_get(gopt_env%force_env,potential_energy=f) END IF ! Possibly take the gradients IF (PRESENT(gradient)) THEN IF (master == para_env%mepos) THEN ! we are on the master - CALL pack_subsys_particles(subsys=subsys,f=gradient,fscale=-1.0_dp,error=error) + CALL pack_subsys_particles(subsys=subsys,f=gradient,fscale=-1.0_dp) END IF END IF CASE (default_ts_method_id) ! Transition State Optimization ALLOCATE (gradient_ts(particles%n_els*3),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Real calculation of energy and forces for transition state optimization: ! When doing dimer methods forces have to be always computed since the function ! to minimize is not the energy but the effective force - CALL cp_eval_at_ts (gopt_env, x, f_ts, gradient_ts, calc_force=.TRUE., error=error) + CALL cp_eval_at_ts (gopt_env, x, f_ts, gradient_ts, calc_force=.TRUE.) ! Possibly take the potential energy IF (PRESENT(f)) f = f_ts ! Possibly take the gradients IF (PRESENT(gradient)) THEN IF (master == para_env%mepos) THEN ! we are on the master - CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,failure) gradient = gradient_ts END IF END IF DEALLOCATE (gradient_ts,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SELECT ! This call is necessary for QM/MM if a Translation is applied ! this makes the geometry optimizer consistent - CALL unpack_subsys_particles(subsys=subsys,r=x,error=error) + CALL unpack_subsys_particles(subsys=subsys,r=x) CASE (default_cell_method_id) ! Check for VIRIAL CALL cp_assert(virial%pv_availability,cp_failure_level,cp_assertion_failed,routineP,& @@ -187,66 +182,63 @@ RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& only_ionode=.TRUE.) SELECT CASE (gopt_env%cell_method_id) CASE (default_cell_direct_id) - CALL apply_cell_change(gopt_env,cell,x,update_forces=.FALSE.,error=error) + CALL apply_cell_change(gopt_env,cell,x,update_forces=.FALSE.) ! Possibly output the new cell used for the next calculation - CALL write_cell(cell,gopt_env%geo_section,error=error) + CALL write_cell(cell,gopt_env%geo_section) ! Compute the pressure tensor - CALL virial_create(virial_avg,error=error) + CALL virial_create(virial_avg) CALL force_env_calc_energy_force(gopt_env%force_env,& calc_force=PRESENT(gradient),& - require_consistent_energy_force=gopt_env%require_consistent_energy_force,& - error=error) + require_consistent_energy_force=gopt_env%require_consistent_energy_force) ! Possibly take the potential energy - CALL force_env_get(gopt_env%force_env,potential_energy=potential_energy,error=error) + CALL force_env_get(gopt_env%force_env,potential_energy=potential_energy) CALL cp_virial(virial,virial_avg) - CALL virial_update(virial_avg,subsys,para_env,error=error) + CALL virial_update(virial_avg,subsys,para_env) IF (PRESENT(f)) THEN - CALL force_env_get(gopt_env%force_env,potential_energy=f,error=error) + CALL force_env_get(gopt_env%force_env,potential_energy=f) END IF ! Possibly take the gradients IF (PRESENT(gradient)) THEN - CPPrecondition(ANY(virial_avg%pv_total /= 0),cp_failure_level,routineP,error,failure) + CPPrecondition(ANY(virial_avg%pv_total /= 0),cp_failure_level,routineP,failure) ! Convert the average ptens av_ptens(:,:) = virial_avg%pv_total(:,:)/cell%deth IF (master == para_env%mepos) THEN ! we are on the master - CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,error,failure) - nparticle = force_env_get_nparticle(gopt_env%force_env,error) + CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,failure) + nparticle = force_env_get_nparticle(gopt_env%force_env) nsize = 3*nparticle - CPPrecondition((SIZE(gradient) == nsize + 6),cp_failure_level,routineP,error,failure) - CALL pack_subsys_particles(subsys=subsys,f=gradient(1:nsize),fscale=-1.0_dp,error=error) - CALL apply_cell_change(gopt_env,cell,gradient,update_forces=.TRUE.,error=error) + CPPrecondition((SIZE(gradient) == nsize + 6),cp_failure_level,routineP,failure) + CALL pack_subsys_particles(subsys=subsys,f=gradient(1:nsize),fscale=-1.0_dp) + CALL apply_cell_change(gopt_env,cell,gradient,update_forces=.TRUE.) cell_gradient => gradient(nsize+1:nsize+6) cell_gradient = 0.0_dp CALL get_dg_dh(cell_gradient,av_ptens,gopt_env%cell_env%pres_ext,cell,gopt_env%cell_env%mtrx,& keep_angles=gopt_env%cell_env%keep_angles,& keep_symmetry=gopt_env%cell_env%keep_symmetry,& - pres_int=gopt_env%cell_env%pres_int,& - error=error) + pres_int=gopt_env%cell_env%pres_int) END IF ! some callers expect pres_int to be available on all ranks. Also, here master is not necessarily a single rank. ! Assume at least master==0 CALL mp_bcast(gopt_env%cell_env%pres_int,0,para_env%group) END IF - CALL virial_release(virial_avg,error=error) + CALL virial_release(virial_avg) CASE (default_cell_geo_opt_id,default_cell_md_id) - CALL apply_cell_change(gopt_env,cell,x,update_forces=.FALSE.,error=error) + CALL apply_cell_change(gopt_env,cell,x,update_forces=.FALSE.) ! Possibly output the new cell used for the next calculation - CALL write_cell(cell,gopt_env%geo_section,error=error) + CALL write_cell(cell,gopt_env%geo_section) ! Compute the pressure tensor - CALL virial_create(virial_avg,error=error) + CALL virial_create(virial_avg) IF (my_final_evaluation) THEN CALL force_env_calc_energy_force(gopt_env%force_env,& calc_force=PRESENT(gradient),& - require_consistent_energy_force=gopt_env%require_consistent_energy_force,& - error=error) + require_consistent_energy_force=gopt_env%require_consistent_energy_force) IF (PRESENT(f)) THEN - CALL force_env_get(gopt_env%force_env,potential_energy=f,error=error) + CALL force_env_get(gopt_env%force_env,potential_energy=f) END IF ELSE SELECT CASE (gopt_env%cell_method_id) CASE (default_cell_geo_opt_id) - work => section_vals_get_subs_vals(gopt_env%motion_section,"GEO_OPT",error=error) - CALL section_vals_get(work,explicit=explicit,error=error) + work => section_vals_get_subs_vals(gopt_env%motion_section,"GEO_OPT") + CALL section_vals_get(work,explicit=explicit) CALL cp_assert(explicit,cp_failure_level,cp_assertion_failed,routineP,& "Cell optimization at 0K was requested. GEO_OPT section MUST be provided in the "//& "input file! "//& @@ -254,46 +246,44 @@ RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& only_ionode=.TRUE.) ! Perform a geometry optimization CALL gopt_new_logger_create(new_logger, gopt_env%force_env%root_section, para_env,& - project_name, id_run=geo_opt_run, error=error) + project_name, id_run=geo_opt_run) CALL cp_add_default_logger(new_logger) - CALL cp_geo_opt(gopt_env%force_env, gopt_env%globenv,eval_opt_geo=.FALSE.,error=error) - CALL force_env_get(gopt_env%force_env,potential_energy=potential_energy,error=error) + CALL cp_geo_opt(gopt_env%force_env, gopt_env%globenv,eval_opt_geo=.FALSE.) + CALL force_env_get(gopt_env%force_env,potential_energy=potential_energy) CALL cp_virial(virial, virial_avg) CASE(default_cell_md_id) - work => section_vals_get_subs_vals(gopt_env%motion_section,"MD",error=error) - avgs_section => section_vals_get_subs_vals(work,"AVERAGES",error=error) - CALL section_vals_get(work,explicit=explicit,error=error) + work => section_vals_get_subs_vals(gopt_env%motion_section,"MD") + avgs_section => section_vals_get_subs_vals(work,"AVERAGES") + CALL section_vals_get(work,explicit=explicit) CALL cp_assert(explicit,cp_failure_level,cp_assertion_failed,routineP,& "Cell optimization at finite temperature was requested. MD section MUST be provided in the "//& "input file! "//& CPSourceFileRef,& only_ionode=.TRUE.) ! Only NVT ensemble is allowed.. - CALL section_vals_val_get(gopt_env%motion_section,"MD%ENSEMBLE",i_val=ensemble,error=error) + CALL section_vals_val_get(gopt_env%motion_section,"MD%ENSEMBLE",i_val=ensemble) CALL cp_assert(ensemble==nvt_ensemble,cp_failure_level,cp_assertion_failed,routineP,& "Cell optimization at finite temperature requires the NVT MD ensemble! "//& CPSourceFileRef,& only_ionode=.TRUE.) ! Perform a molecular dynamics CALL gopt_new_logger_create(new_logger, gopt_env%force_env%root_section, para_env,& - project_name, id_run=mol_dyn_run, error=error) + project_name, id_run=mol_dyn_run) CALL cp_add_default_logger(new_logger) - CALL create_averages(averages, avgs_section, virial_avg=.TRUE., force_env=gopt_env%force_env,& - error=error) - CALL qs_mol_dyn(gopt_env%force_env, gopt_env%globenv, averages, rm_restart_info=.FALSE.,& - error=error) + CALL create_averages(averages, avgs_section, virial_avg=.TRUE., force_env=gopt_env%force_env) + CALL qs_mol_dyn(gopt_env%force_env, gopt_env%globenv, averages, rm_restart_info=.FALSE.) ! Retrieve the average of the stress tensor and the average of the potential energy potential_energy = averages%avepot CALL cp_virial(averages%virial, virial_avg) - CALL release_averages(averages, error) + CALL release_averages(averages) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL cp_rm_default_logger() CALL gopt_new_logger_release(new_logger, gopt_env%force_env%root_section, para_env, project_name,& - cell_opt_run, error) + cell_opt_run) ! Update the virial - CALL virial_update(virial_avg, subsys, para_env, error) + CALL virial_update(virial_avg, subsys, para_env) ! Possibly take give back the potential energy IF (PRESENT(f)) THEN f = potential_energy @@ -301,25 +291,24 @@ RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& END IF ! Possibly give back the gradients IF (PRESENT(gradient)) THEN - CPPrecondition(ANY(virial_avg%pv_total/=0),cp_failure_level,routineP,error,failure) + CPPrecondition(ANY(virial_avg%pv_total/=0),cp_failure_level,routineP,failure) ! Convert the average ptens av_ptens(:,:) = virial_avg%pv_total(:,:)/cell%deth IF (master == para_env%mepos) THEN ! we are on the master - CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,failure) ! Compute the gradients on the cell CALL get_dg_dh(gradient,av_ptens,gopt_env%cell_env%pres_ext,cell,gopt_env%cell_env%mtrx,& keep_angles=gopt_env%cell_env%keep_angles,& keep_symmetry=gopt_env%cell_env%keep_symmetry,& - pres_int=gopt_env%cell_env%pres_int,& - error=error) + pres_int=gopt_env%cell_env%pres_int) END IF ! some callers expect pres_int to be available on all ranks. Also, here master is not necessarily a single rank. ! Assume at least master==0 CALL mp_bcast(gopt_env%cell_env%pres_int,0,para_env%group) END IF - CALL virial_release(virial_avg,error=error) + CALL virial_release(virial_avg) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CASE (default_shellcore_method_id) idg = 0 @@ -332,23 +321,22 @@ RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& END DO END IF END DO - CALL write_structure_data(particles%els,cell,gopt_env%motion_section,error) + CALL write_structure_data(particles%els,cell,gopt_env%motion_section) ! Shell-core optimization CALL force_env_calc_energy_force(gopt_env%force_env,& calc_force=PRESENT(gradient),& - require_consistent_energy_force=gopt_env%require_consistent_energy_force,& - error=error) + require_consistent_energy_force=gopt_env%require_consistent_energy_force) ! Possibly take the potential energy IF (PRESENT(f)) THEN - CALL force_env_get(gopt_env%force_env,potential_energy=f,error=error) + CALL force_env_get(gopt_env%force_env,potential_energy=f) END IF ! Possibly take the gradients IF (PRESENT(gradient)) THEN IF (master == para_env%mepos) THEN ! we are on the master - CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gradient),cp_failure_level,routineP,failure) idg = 0 DO ip=1,shell_particles%n_els DO idir=1,3 @@ -359,7 +347,7 @@ RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& END IF END IF CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) diff --git a/src/motion/gopt_f77_methods.h b/src/motion/gopt_f77_methods.h index 286931326e..b57ee550a2 100644 --- a/src/motion/gopt_f77_methods.h +++ b/src/motion/gopt_f77_methods.h @@ -19,7 +19,7 @@ INTERFACE RECURSIVE SUBROUTINE cp_eval_at(gopt_env,x,f,gradient,master,& - final_evaluation,para_env,error) + final_evaluation,para_env) USE cp_para_types, ONLY: cp_para_env_type USE gopt_f_types, ONLY: gopt_f_type @@ -35,7 +35,6 @@ INTERFACE INTEGER, INTENT(IN) :: master LOGICAL, INTENT(IN), OPTIONAL :: final_evaluation TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error END SUBROUTINE cp_eval_at diff --git a/src/motion/gopt_f_methods.F b/src/motion/gopt_f_methods.F index 975c7c394d..41db401266 100644 --- a/src/motion/gopt_f_methods.F +++ b/src/motion/gopt_f_methods.F @@ -80,16 +80,13 @@ MODULE gopt_f_methods !> \param gopt_env the geometry optimization environment you want the info about !> x0: the parameter vector (is allocated by this routine) !> \param x0 ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - Cell optimization revised (06.11.2012,MK) ! ***************************************************************************** - SUBROUTINE gopt_f_create_x0(gopt_env,x0,error) + SUBROUTINE gopt_f_create_x0(gopt_env,x0) TYPE(gopt_f_type), POINTER :: gopt_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gopt_f_create_x0', & routineP = moduleN//':'//routineN @@ -106,31 +103,31 @@ SUBROUTINE gopt_f_create_x0(gopt_env,x0,error) SELECT CASE (gopt_env%type_id) CASE (default_minimization_method_id,default_ts_method_id) - CALL force_env_get(gopt_env%force_env,subsys=subsys,error=error) + CALL force_env_get(gopt_env%force_env,subsys=subsys) ! before starting we handle the case of translating coordinates (QM/MM) IF(gopt_env%force_env%in_use == use_qmmm)& - CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env,error=error) + CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) IF(gopt_env%force_env%in_use == use_qmmmx)& - CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env,error=error) - nparticle = force_env_get_nparticle(gopt_env%force_env,error) + CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) + nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pack_subsys_particles(subsys=subsys,r=x0,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pack_subsys_particles(subsys=subsys,r=x0) CASE (default_cell_method_id) SELECT CASE (gopt_env%cell_method_id) CASE (default_cell_direct_id) - CALL force_env_get(gopt_env%force_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(gopt_env%force_env,subsys=subsys,cell=cell) ! Store reference cell gopt_env%h_ref = cell%hmat ! before starting we handle the case of translating coordinates (QM/MM) IF(gopt_env%force_env%in_use == use_qmmm)& - CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env,error=error) + CALL apply_qmmm_translate(gopt_env%force_env%qmmm_env) IF(gopt_env%force_env%in_use == use_qmmmx)& - CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env,error=error) - nparticle = force_env_get_nparticle(gopt_env%force_env,error) + CALL apply_qmmmx_translate(gopt_env%force_env%qmmmx_env) + nparticle = force_env_get_nparticle(gopt_env%force_env) ALLOCATE (x0(3*nparticle+6),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pack_subsys_particles(subsys=subsys,r=x0,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pack_subsys_particles(subsys=subsys,r=x0) idg = 3*nparticle DO i=1,3 DO j=1,i @@ -139,9 +136,9 @@ SUBROUTINE gopt_f_create_x0(gopt_env,x0,error) END DO END DO CASE (default_cell_geo_opt_id,default_cell_md_id) - CALL force_env_get(gopt_env%force_env,cell=cell,error=error) + CALL force_env_get(gopt_env%force_env,cell=cell) ALLOCATE (x0(6),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) idg = 0 DO i=1,3 DO j=1,i @@ -150,10 +147,10 @@ SUBROUTINE gopt_f_create_x0(gopt_env,x0,error) END DO END DO CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE gopt_f_create_x0 @@ -185,17 +182,15 @@ END SUBROUTINE gopt_f_ii !> \param wildcard ... !> \param its ... !> \param used_time ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** - SUBROUTINE gopt_f_io_init(gopt_env, output_unit, opt_energy, wildcard, its, used_time, error) + SUBROUTINE gopt_f_io_init(gopt_env, output_unit, opt_energy, wildcard, its, used_time) TYPE(gopt_f_type), POINTER :: gopt_env INTEGER, INTENT(IN) :: output_unit REAL(KIND=dp) :: opt_energy CHARACTER(LEN=5) :: wildcard INTEGER, INTENT(IN) :: its REAL(KIND=dp) :: used_time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_f_io_init', & routineP = moduleN//':'//routineN @@ -207,7 +202,7 @@ SUBROUTINE gopt_f_io_init(gopt_env, output_unit, opt_energy, wildcard, its, used ! Geometry Optimization (Minimization and Transition State Search) IF (.NOT.gopt_env%dimer_rotation) THEN CALL write_cycle_infos(output_unit,it=its,etot=opt_energy,wildcard=wildcard, & - used_time=used_time, error=error) + used_time=used_time) ELSE CALL write_rot_cycle_infos(output_unit,it=its,etot=opt_energy,dimer_env=gopt_env%dimer_env,& wildcard=wildcard, used_time=used_time) @@ -216,10 +211,10 @@ SUBROUTINE gopt_f_io_init(gopt_env, output_unit, opt_energy, wildcard, its, used ! Cell Optimization pres_int = gopt_env%cell_env%pres_int CALL write_cycle_infos(output_unit,it=its,etot=opt_energy,pres_int=pres_int,wildcard=wildcard,& - used_time=used_time, error=error) + used_time=used_time) CASE(default_shellcore_method_id) CALL write_cycle_infos(output_unit,it=its,etot=opt_energy,wildcard=wildcard, & - used_time=used_time, error=error) + used_time=used_time) END SELECT END SUBROUTINE gopt_f_io_init @@ -245,12 +240,11 @@ END SUBROUTINE gopt_f_io_init !> \param step ... !> \param rad ... !> \param used_time ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** SUBROUTINE gopt_f_io(gopt_env, force_env, root_section, its, opt_energy,& output_unit, eold, emin, wildcard, gopt_param, ndf, dx, xi, conv, pred, rat,& - step, rad, used_time, error) + step, rad, used_time) TYPE(gopt_f_type), POINTER :: gopt_env TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section @@ -268,7 +262,6 @@ SUBROUTINE gopt_f_io(gopt_env, force_env, root_section, its, opt_energy,& LOGICAL, OPTIONAL :: conv REAL(KIND=dp), INTENT(IN), OPTIONAL :: pred, rat, step, rad REAL(KIND=dp) :: used_time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_f_io', & routineP = moduleN//':'//routineN @@ -282,26 +275,25 @@ SUBROUTINE gopt_f_io(gopt_env, force_env, root_section, its, opt_energy,& ! Geometry Optimization (Minimization and Transition State Search) IF (.NOT.gopt_env%dimer_rotation) THEN CALL geo_opt_io(force_env=force_env, root_section=root_section, & - motion_section=gopt_env%motion_section, its=its, opt_energy=opt_energy, error=error) + motion_section=gopt_env%motion_section, its=its, opt_energy=opt_energy) CALL write_cycle_infos(output_unit,its,etot=opt_energy,ediff=opt_energy-eold,& - pred=pred,rat=rat,step=step,rad=rad,emin=emin,wildcard=wildcard,used_time=used_time,error=error) + pred=pred,rat=rat,step=step,rad=rad,emin=emin,wildcard=wildcard,used_time=used_time) ! Possibly check convergence IF (PRESENT(conv)) THEN - CPPostcondition(PRESENT(ndf),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(dx),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(xi),cp_failure_level,routineP,error,failure) - CALL check_converg(ndf,dx,xi,output_unit,conv,gopt_param,error=error) + CPPostcondition(PRESENT(ndf),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(dx),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(xi),cp_failure_level,routineP,failure) + CALL check_converg(ndf,dx,xi,output_unit,conv,gopt_param) END IF ELSE - CALL update_dimer_vec(gopt_env%dimer_env, gopt_env%motion_section, error) - CALL write_restart(force_env=force_env,root_section=root_section,& - error=error) + CALL update_dimer_vec(gopt_env%dimer_env, gopt_env%motion_section) + CALL write_restart(force_env=force_env,root_section=root_section) CALL write_rot_cycle_infos(output_unit,its,opt_energy,opt_energy-eold,emin,gopt_env%dimer_env,& used_time=used_time, wildcard=wildcard) ! Possibly check convergence IF (PRESENT(conv)) THEN - CPPostcondition(ASSOCIATED(gopt_env%dimer_env),cp_failure_level,routineP,error,failure) - CALL check_rot_conv(gopt_env%dimer_env, output_unit, conv, error) + CPPostcondition(ASSOCIATED(gopt_env%dimer_env),cp_failure_level,routineP,failure) + CALL check_rot_conv(gopt_env%dimer_env, output_unit, conv) END IF END IF CASE (default_cell_method_id) @@ -310,26 +302,26 @@ SUBROUTINE gopt_f_io(gopt_env, force_env, root_section, its, opt_energy,& pres_int = gopt_env%cell_env%pres_int pres_tol = gopt_env%cell_env%pres_tol CALL geo_opt_io(force_env=force_env, root_section=root_section, & - motion_section=gopt_env%motion_section, its=its, opt_energy=opt_energy, error=error) + motion_section=gopt_env%motion_section, its=its, opt_energy=opt_energy) CALL write_cycle_infos(output_unit,its,etot=opt_energy,ediff=opt_energy-eold,& pred=pred,rat=rat,step=step,rad=rad,emin=emin,pres_int=pres_int,wildcard=wildcard,& - used_time=used_time, error=error) + used_time=used_time) ! Possibly check convergence IF (PRESENT(conv)) THEN - CPPostcondition(PRESENT(ndf),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(dx),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(xi),cp_failure_level,routineP,error,failure) - CALL check_converg(ndf,dx,xi,output_unit,conv,gopt_param,pres_diff,pres_tol,error=error) + CPPostcondition(PRESENT(ndf),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(dx),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(xi),cp_failure_level,routineP,failure) + CALL check_converg(ndf,dx,xi,output_unit,conv,gopt_param,pres_diff,pres_tol) END IF CASE (default_shellcore_method_id) CALL write_cycle_infos(output_unit,its,etot=opt_energy,ediff=opt_energy-eold,& - pred=pred,rat=rat,step=step,rad=rad,emin=emin,wildcard=wildcard, used_time=used_time, error=error) + pred=pred,rat=rat,step=step,rad=rad,emin=emin,wildcard=wildcard, used_time=used_time) ! Possibly check convergence IF (PRESENT(conv)) THEN - CPPostcondition(PRESENT(ndf),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(dx),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(xi),cp_failure_level,routineP,error,failure) - CALL check_converg(ndf,dx,xi,output_unit,conv,gopt_param,error=error) + CPPostcondition(PRESENT(ndf),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(dx),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(xi),cp_failure_level,routineP,failure) + CALL check_converg(ndf,dx,xi,output_unit,conv,gopt_param) END IF END SELECT END SUBROUTINE gopt_f_io @@ -345,11 +337,10 @@ END SUBROUTINE gopt_f_io !> \param para_env ... !> \param master ... !> \param output_unit ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** RECURSIVE SUBROUTINE gopt_f_io_finalize(gopt_env, force_env, x0, conv, its, root_section,& - para_env, master, output_unit, error) + para_env, master, output_unit) TYPE(gopt_f_type), POINTER :: gopt_env TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:), POINTER :: x0 @@ -358,7 +349,6 @@ RECURSIVE SUBROUTINE gopt_f_io_finalize(gopt_env, force_env, x0, conv, its, root TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN) :: master, output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_f_io_finalize', & routineP = moduleN//':'//routineN @@ -366,11 +356,10 @@ RECURSIVE SUBROUTINE gopt_f_io_finalize(gopt_env, force_env, x0, conv, its, root IF (gopt_env%eval_opt_geo) THEN IF (.NOT.gopt_env%dimer_rotation) THEN CALL write_final_info(output_unit, conv, its, gopt_env, x0, master, & - para_env, force_env, gopt_env%motion_section, root_section, error) + para_env, force_env, gopt_env%motion_section, root_section) ELSE - CALL update_dimer_vec(gopt_env%dimer_env, gopt_env%motion_section, error) - CALL write_restart(force_env=force_env,root_section=root_section,& - error=error) + CALL update_dimer_vec(gopt_env%dimer_env, gopt_env%motion_section) + CALL write_restart(force_env=force_env,root_section=root_section) END IF END IF @@ -390,10 +379,9 @@ END SUBROUTINE gopt_f_io_finalize !> \param pres_int ... !> \param wildcard ... !> \param used_time ... -!> \param error ... ! ***************************************************************************** SUBROUTINE write_cycle_infos(output_unit,it,etot,ediff,pred,rat,step,rad,emin,& - pres_int,wildcard,used_time, error) + pres_int,wildcard,used_time) INTEGER, INTENT(IN) :: output_unit, it REAL(KIND=dp), INTENT(IN) :: etot @@ -401,7 +389,6 @@ SUBROUTINE write_cycle_infos(output_unit,it,etot,ediff,pred,rat,step,rad,emin,& emin, pres_int CHARACTER(LEN=5), OPTIONAL :: wildcard REAL(KIND=dp), INTENT(IN) :: used_time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_cycle_infos', & routineP = moduleN//':'//routineN @@ -416,7 +403,7 @@ SUBROUTINE write_cycle_infos(output_unit,it,etot,ediff,pred,rat,step,rad,emin,& WRITE(UNIT=output_unit,FMT="(T2,A,F20.10)")& " Total Energy = ",etot IF (PRESENT(pres_int)) THEN - tmp_r1 = cp_unit_from_cp2k(pres_int,"bar",error=error) + tmp_r1 = cp_unit_from_cp2k(pres_int,"bar") WRITE(UNIT=output_unit,FMT="(T2,A,F20.10)")& " Internal Pressure [bar] = ",tmp_r1 END IF @@ -522,9 +509,8 @@ END SUBROUTINE write_rot_cycle_infos !> \param gopt_param ... !> \param pres_diff ... !> \param pres_tol ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE check_converg(ndf,dr,g,output_unit,conv,gopt_param,pres_diff,pres_tol,error) + SUBROUTINE check_converg(ndf,dr,g,output_unit,conv,gopt_param,pres_diff,pres_tol) INTEGER, INTENT(IN) :: ndf REAL(KIND=dp), INTENT(IN) :: dr(ndf), g(ndf) @@ -532,7 +518,6 @@ SUBROUTINE check_converg(ndf,dr,g,output_unit,conv,gopt_param,pres_diff,pres_tol LOGICAL, INTENT(OUT) :: conv TYPE(gopt_param_type), POINTER :: gopt_param REAL(KIND=dp), INTENT(IN), OPTIONAL :: pres_diff, pres_tol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_converg', & routineP = moduleN//':'//routineN @@ -634,10 +619,10 @@ SUBROUTINE check_converg(ndf,dr,g,output_unit,conv,gopt_param,pres_diff,pres_tol " NO" END IF IF (PRESENT(pres_diff).AND.PRESENT(pres_tol)) THEN - tmp_r1 = cp_unit_from_cp2k(pres_diff,"bar",error=error) + tmp_r1 = cp_unit_from_cp2k(pres_diff,"bar") WRITE(UNIT=output_unit,FMT="(T2,A,F20.10)")& " Pressure Deviation [bar] = ",tmp_r1 - tmp_r1 = cp_unit_from_cp2k(pres_tol,"bar",error=error) + tmp_r1 = cp_unit_from_cp2k(pres_tol,"bar") WRITE(UNIT=output_unit,FMT="(T2,A,F20.10)")& " Pressure Tolerance [bar] = ",tmp_r1 IF(conv_p)THEN @@ -669,16 +654,14 @@ END SUBROUTINE check_converg !> \param dimer_env ... !> \param output_unit ... !> \param conv ... -!> \param error ... !> \date 01.2008 !> \author Luca Bellucci and Teodoro Laino - created [tlaino] ! ***************************************************************************** - SUBROUTINE check_rot_conv(dimer_env, output_unit, conv, error) + SUBROUTINE check_rot_conv(dimer_env, output_unit, conv) TYPE(dimer_env_type), POINTER :: dimer_env INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(OUT) :: conv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_rot_conv', & routineP = moduleN//':'//routineN @@ -725,12 +708,11 @@ END SUBROUTINE check_rot_conv !> \param force_env ... !> \param motion_section ... !> \param root_section ... -!> \param error ... !> \date 11.2007 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** RECURSIVE SUBROUTINE write_final_info(output_unit, conv, it, gopt_env, x0, master, para_env, force_env,& - motion_section, root_section, error) + motion_section, root_section) INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN) :: conv INTEGER, INTENT(INOUT) :: it @@ -740,7 +722,6 @@ RECURSIVE SUBROUTINE write_final_info(output_unit, conv, it, gopt_env, x0, maste TYPE(cp_para_env_type), POINTER :: para_env TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: motion_section, root_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_final_info', & routineP = moduleN//':'//routineN @@ -755,21 +736,20 @@ RECURSIVE SUBROUTINE write_final_info(output_unit, conv, it, gopt_env, x0, maste failure = .FALSE. - CALL force_env_get(force_env, cell=cell, subsys=subsys, error=error) - CALL cp_subsys_get(subsys=subsys, particles=particles,error=error) + CALL force_env_get(force_env, cell=cell, subsys=subsys) + CALL cp_subsys_get(subsys=subsys, particles=particles) particle_set => particles%els IF (conv) THEN it = it + 1 - CALL write_structure_data(particle_set,cell,motion_section,error) - CALL write_restart(force_env=force_env,root_section=root_section,& - error=error) + CALL write_structure_data(particle_set,cell,motion_section) + CALL write_restart(force_env=force_env,root_section=root_section) IF (output_unit > 0) & WRITE (UNIT=output_unit,FMT="(/,T20,' Reevaluating energy at the minimum')") CALL cp_eval_at(gopt_env,x0,f=etot,master=master,final_evaluation=.TRUE.,& - para_env=para_env,error=error) - CALL write_geo_traj(force_env,root_section,it,etot,error) + para_env=para_env) + CALL write_geo_traj(force_env,root_section,it,etot) END IF END SUBROUTINE write_final_info @@ -780,19 +760,17 @@ END SUBROUTINE write_final_info !> \param root_section ... !> \param it ... !> \param etot ... -!> \param error ... !> \date 11.2007 !> \par History !> 09.2010: Output of core and shell positions and forces (MK) !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE write_geo_traj(force_env, root_section, it, etot, error) + SUBROUTINE write_geo_traj(force_env, root_section, it, etot) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section INTEGER, INTENT(IN) :: it REAL(KIND=dp), INTENT(IN) :: etot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_geo_traj', & routineP = moduleN//':'//routineN @@ -814,9 +792,9 @@ SUBROUTINE write_geo_traj(force_env, root_section, it, etot, error) NULLIFY (shell_particles) NULLIFY (subsys) - CALL write_trajectory(force_env,root_section,it,0.0_dp,0.0_dp,etot,error=error) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,error=error) + CALL write_trajectory(force_env,root_section,it,0.0_dp,0.0_dp,etot) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds) atomic_kind_set => atomic_kinds%els CALL get_atomic_kind_set(atomic_kind_set,& shell_present=shell_present,& @@ -824,21 +802,20 @@ SUBROUTINE write_geo_traj(force_env, root_section, it, etot, error) IF (shell_present) THEN CALL cp_subsys_get(subsys,& core_particles=core_particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) CALL write_trajectory(force_env,root_section,it=it,time=0.0_dp,dtime=0.0_dp,& etot=etot,pk_name="SHELL_TRAJECTORY",middle_name="shpos",& - particles=shell_particles,error=error) + particles=shell_particles) IF (shell_adiabatic) THEN CALL write_trajectory(force_env,root_section,it=it,time=0.0_dp,dtime=0.0_dp,& etot=etot,pk_name="SHELL_FORCES",middle_name="shfrc",& - particles=shell_particles,error=error) + particles=shell_particles) CALL write_trajectory(force_env,root_section,it=it,time=0.0_dp,dtime=0.0_dp,& etot=etot,pk_name="CORE_TRAJECTORY",middle_name="copos",& - particles=core_particles,error=error) + particles=core_particles) CALL write_trajectory(force_env,root_section,it=it,time=0.0_dp,dtime=0.0_dp,& etot=etot,pk_name="CORE_FORCES",middle_name="cofrc",& - particles=core_particles,error=error) + particles=core_particles) END IF END IF @@ -921,18 +898,16 @@ END SUBROUTINE print_geo_opt_nc !> \param motion_section ... !> \param its ... !> \param opt_energy ... -!> \param error ... !> \date 02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich !> \version 1.0 ! ***************************************************************************** - SUBROUTINE geo_opt_io(force_env, root_section, motion_section, its, opt_energy, error) + SUBROUTINE geo_opt_io(force_env, root_section, motion_section, its, opt_energy) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section, motion_section INTEGER, INTENT(IN) :: its REAL(KIND=dp), INTENT(IN) :: opt_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'geo_opt_io', & routineP = moduleN//':'//routineN @@ -955,25 +930,24 @@ SUBROUTINE geo_opt_io(force_env, root_section, motion_section, its, opt_energy, local_particles, atomic_kinds, particles) ! Write Restart File - CALL write_restart(force_env=force_env,root_section=root_section,& - error=error) + CALL write_restart(force_env=force_env,root_section=root_section) ! Write Trajectory - CALL write_geo_traj(force_env, root_section, its, opt_energy, error) + CALL write_geo_traj(force_env, root_section, its, opt_energy) ! Write the stress Tensor CALL force_env_get(force_env, cell=cell, para_env=para_env, & - subsys=subsys, error=error) + subsys=subsys) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& - particles=particles, virial=virial, error=error) + particles=particles, virial=virial) atomic_kind_set => atomic_kinds%els particle_set => particles%els CALL virial_evaluate(atomic_kind_set, particle_set, local_particles, & - virial, para_env%group, error=error) - CALL write_stress_tensor(virial, cell, motion_section, its, 0.0_dp, error=error) + virial, para_env%group) + CALL write_stress_tensor(virial, cell, motion_section, its, 0.0_dp) ! Write the cell - CALL write_simulation_cell(cell, motion_section, its, 0.0_dp, error=error) + CALL write_simulation_cell(cell, motion_section, its, 0.0_dp) END SUBROUTINE geo_opt_io @@ -983,18 +957,16 @@ END SUBROUTINE geo_opt_io !> \param cell ... !> \param x ... !> \param update_forces ... -!> \param error ... !> \date 05.11.2012 (revised version of unbiase_coordinates moved here, MK) !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - SUBROUTINE apply_cell_change(gopt_env,cell,x,update_forces,error) + SUBROUTINE apply_cell_change(gopt_env,cell,x,update_forces) TYPE(gopt_f_type), POINTER :: gopt_env TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:), POINTER :: x LOGICAL, INTENT(IN) :: update_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_cell_change', & routineP = moduleN//':'//routineN @@ -1017,20 +989,18 @@ SUBROUTINE apply_cell_change(gopt_env,cell,x,update_forces,error) NULLIFY (shell_particles) NULLIFY (subsys) - natom = force_env_get_natom(gopt_env%force_env,error) - nparticle = force_env_get_nparticle(gopt_env%force_env,error) + natom = force_env_get_natom(gopt_env%force_env) + nparticle = force_env_get_nparticle(gopt_env%force_env) CALL force_env_get(gopt_env%force_env,& - subsys=subsys,& - error=error) + subsys=subsys) CALL cp_subsys_get(subsys=subsys,& core_particles=core_particles,& particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) ! Retrieve the reference cell - CALL cell_create(cell_ref,error=error) - CALL cell_copy(cell,cell_ref,error=error) + CALL cell_create(cell_ref) + CALL cell_copy(cell,cell_ref) ! Load the updated cell information SELECT CASE (gopt_env%cell_method_id) @@ -1040,7 +1010,7 @@ SUBROUTINE apply_cell_change(gopt_env,cell,x,update_forces,error) CASE (default_cell_geo_opt_id,default_cell_md_id) idg = 0 END SELECT - CPPrecondition((SIZE(x) == idg + 6),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(x) == idg + 6),cp_failure_level,routineP,failure) IF (update_forces) THEN @@ -1062,7 +1032,7 @@ SUBROUTINE apply_cell_change(gopt_env,cell,x,update_forces,error) END DO END DO CALL init_cell(cell) - CALL cp_subsys_set(subsys,cell=cell,error=error) + CALL cp_subsys_set(subsys,cell=cell) ! Retrieve particle coordinates for the current cell SELECT CASE (gopt_env%cell_method_id) @@ -1111,7 +1081,7 @@ SUBROUTINE apply_cell_change(gopt_env,cell,x,update_forces,error) END IF - CALL cell_release(cell_ref,error) + CALL cell_release(cell_ref) END SUBROUTINE apply_cell_change diff --git a/src/motion/gopt_f_types.F b/src/motion/gopt_f_types.F index ea11f4c08d..9de4f089a6 100644 --- a/src/motion/gopt_f_types.F +++ b/src/motion/gopt_f_types.F @@ -84,13 +84,11 @@ MODULE gopt_f_types !> \param globenv ... !> \param geo_opt_section ... !> \param eval_opt_geo ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none ! ***************************************************************************** RECURSIVE SUBROUTINE gopt_f_create(gopt_env, gopt_param, force_env, globenv, geo_opt_section,& - eval_opt_geo, error) + eval_opt_geo) TYPE(gopt_f_type), POINTER :: gopt_env TYPE(gopt_param_type), POINTER :: gopt_param @@ -98,7 +96,6 @@ RECURSIVE SUBROUTINE gopt_f_create(gopt_env, gopt_param, force_env, globenv, geo TYPE(global_environment_type), POINTER :: globenv TYPE(section_vals_type), POINTER :: geo_opt_section LOGICAL, INTENT(IN), OPTIONAL :: eval_opt_geo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_f_create', & routineP = moduleN//':'//routineN @@ -110,9 +107,9 @@ RECURSIVE SUBROUTINE gopt_f_create(gopt_env, gopt_param, force_env, globenv, geo TYPE(section_vals_type), POINTER :: dimer_section, rot_opt_section failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(gopt_env),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(gopt_env),cp_failure_level,routineP,failure) ALLOCATE (gopt_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nshell = 0 NULLIFY (gopt_env%dimer_env, gopt_env%gopt_dimer_env, gopt_env%gopt_dimer_param, gopt_env%cell_env) @@ -121,23 +118,22 @@ RECURSIVE SUBROUTINE gopt_f_create(gopt_env, gopt_param, force_env, globenv, geo gopt_env%id_nr=last_gopt_f_id gopt_env%dimer_rotation=.FALSE. gopt_env%do_line_search=.FALSE. - CALL force_env_retain(force_env, error=error) + CALL force_env_retain(force_env) gopt_env%force_env => force_env - gopt_env%motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION",error=error) + gopt_env%motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION") gopt_env%geo_section => geo_opt_section gopt_env%globenv => globenv gopt_env%eval_opt_geo=.TRUE. IF (PRESENT(eval_opt_geo)) gopt_env%eval_opt_geo = eval_opt_geo gopt_env%require_consistent_energy_force=.TRUE. - CALL force_env_get(force_env,subsys=subsys,error=error) + CALL force_env_get(force_env,subsys=subsys) gopt_env%type_id = gopt_param%type_id SELECT CASE(gopt_env%type_id) CASE (default_ts_method_id,default_minimization_method_id) CALL cp_subsys_get(subsys,& particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) IF (ASSOCIATED(shell_particles)) nshell = shell_particles%n_els ! The same number of shell and core particles is assumed gopt_env%nfree = particles%n_els + nshell @@ -150,19 +146,19 @@ RECURSIVE SUBROUTINE gopt_f_create(gopt_env, gopt_param, force_env, globenv, geo CASE(default_dimer_method_id) ! For the Dimer method we use the same framework of geometry optimizers ! already defined for cp2k.. - natom = force_env_get_natom(force_env,error) - dimer_section => section_vals_get_subs_vals(geo_opt_section,"TRANSITION_STATE%DIMER",error=error) - CALL dimer_env_create(gopt_env%dimer_env, natom, globenv, dimer_section, error) + natom = force_env_get_natom(force_env) + dimer_section => section_vals_get_subs_vals(geo_opt_section,"TRANSITION_STATE%DIMER") + CALL dimer_env_create(gopt_env%dimer_env, natom, globenv, dimer_section) ! Setup the GEO_OPT environment for the rotation of the Dimer - rot_opt_section => section_vals_get_subs_vals(dimer_section,"ROT_OPT",error=error) + rot_opt_section => section_vals_get_subs_vals(dimer_section,"ROT_OPT") CALL gopt_param_read(gopt_env%gopt_dimer_param, rot_opt_section,& - type_id=default_minimization_method_id,error=error) + type_id=default_minimization_method_id) gopt_env%gopt_dimer_param%type_id = default_ts_method_id CALL gopt_f_create(gopt_env%gopt_dimer_env, gopt_env%gopt_dimer_param, force_env=force_env,& - globenv=globenv, geo_opt_section=rot_opt_section, eval_opt_geo=eval_opt_geo, error=error) - CALL dimer_env_retain(gopt_env%dimer_env, error) + globenv=globenv, geo_opt_section=rot_opt_section, eval_opt_geo=eval_opt_geo) + CALL dimer_env_retain(gopt_env%dimer_env) gopt_env%gopt_dimer_env%dimer_env => gopt_env%dimer_env gopt_env%gopt_dimer_env%label = "ROT_OPT" gopt_env%gopt_dimer_env%dimer_rotation = .TRUE. @@ -173,7 +169,7 @@ RECURSIVE SUBROUTINE gopt_f_create(gopt_env, gopt_param, force_env, globenv, geo gopt_env%label = "CELL_OPT" gopt_env%tag = " CELL " gopt_env%cell_method_id = gopt_param%cell_method_id - CALL cell_opt_env_create(gopt_env%cell_env, force_env, gopt_env%geo_section, error) + CALL cell_opt_env_create(gopt_env%cell_env, force_env, gopt_env%geo_section) CASE(default_shellcore_method_id) gopt_env%nfree = subsys%shell_particles%n_els gopt_env%label = "SHELL_OPT" @@ -185,14 +181,11 @@ END SUBROUTINE gopt_f_create ! ***************************************************************************** !> \brief ... !> \param gopt_env the geometry optimization environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none ! ***************************************************************************** - SUBROUTINE gopt_f_retain(gopt_env, error) + SUBROUTINE gopt_f_retain(gopt_env) TYPE(gopt_f_type), POINTER :: gopt_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_f_retain', & routineP = moduleN//':'//routineN @@ -201,22 +194,19 @@ SUBROUTINE gopt_f_retain(gopt_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(gopt_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(gopt_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(gopt_env%ref_count>0,cp_failure_level,routineP) gopt_env%ref_count=gopt_env%ref_count+1 END SUBROUTINE gopt_f_retain ! ***************************************************************************** !> \brief ... !> \param gopt_env the geometry optimization environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none ! ***************************************************************************** - RECURSIVE SUBROUTINE gopt_f_release(gopt_env, error) + RECURSIVE SUBROUTINE gopt_f_release(gopt_env) TYPE(gopt_f_type), POINTER :: gopt_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_f_release', & routineP = moduleN//':'//routineN @@ -227,20 +217,20 @@ RECURSIVE SUBROUTINE gopt_f_release(gopt_env, error) failure=.FALSE. IF (ASSOCIATED(gopt_env)) THEN - CPPreconditionNoFail(gopt_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(gopt_env%ref_count>0,cp_failure_level,routineP) gopt_env%ref_count=gopt_env%ref_count-1 IF (gopt_env%ref_count==0) THEN - CALL force_env_release(gopt_env%force_env,error=error) + CALL force_env_release(gopt_env%force_env) NULLIFY(gopt_env%force_env,& gopt_env%globenv,& gopt_env%motion_section,& gopt_env%geo_section) - CALL cell_opt_env_release(gopt_env%cell_env,error) - CALL dimer_env_release(gopt_env%dimer_env, error) - CALL gopt_f_release(gopt_env%gopt_dimer_env, error=error) - CALL gopt_param_release(gopt_env%gopt_dimer_param, error=error) + CALL cell_opt_env_release(gopt_env%cell_env) + CALL dimer_env_release(gopt_env%dimer_env) + CALL gopt_f_release(gopt_env%gopt_dimer_env) + CALL gopt_param_release(gopt_env%gopt_dimer_param) DEALLOCATE(gopt_env, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF END SUBROUTINE gopt_f_release diff --git a/src/motion/gopt_param_types.F b/src/motion/gopt_param_types.F index 9c05d3f54b..10830b7fdb 100644 --- a/src/motion/gopt_param_types.F +++ b/src/motion/gopt_param_types.F @@ -72,15 +72,12 @@ MODULE gopt_param_types ! ***************************************************************************** !> \brief creates a new gopt_param object !> \param gopt_param the object to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE gopt_param_create(gopt_param,error) + SUBROUTINE gopt_param_create(gopt_param) TYPE(gopt_param_type), POINTER :: gopt_param - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_param_create', & routineP = moduleN//':'//routineN @@ -91,7 +88,7 @@ SUBROUTINE gopt_param_create(gopt_param,error) failure=.FALSE. ALLOCATE(gopt_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_gopt_param_id=last_gopt_param_id+1 gopt_param%id_nr=last_gopt_param_id @@ -103,17 +100,14 @@ END SUBROUTINE gopt_param_create !> \param gopt_param ... !> \param gopt_section ... !> \param type_id ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE gopt_param_read(gopt_param, gopt_section, type_id, error) + SUBROUTINE gopt_param_read(gopt_param, gopt_section, type_id) TYPE(gopt_param_type), POINTER :: gopt_param TYPE(section_vals_type), POINTER :: gopt_section INTEGER, INTENT(IN), OPTIONAL :: type_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_param_read', & routineP = moduleN//':'//routineN @@ -122,49 +116,49 @@ SUBROUTINE gopt_param_read(gopt_param, gopt_section, type_id, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(gopt_param),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(gopt_section),cp_failure_level,routineP,error,failure) - CALL gopt_param_create(gopt_param, error=error) + CPPrecondition(.NOT.ASSOCIATED(gopt_param),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(gopt_section),cp_failure_level,routineP,failure) + CALL gopt_param_create(gopt_param) failure=.FALSE. IF (PRESENT(type_id)) THEN gopt_param%type_id = type_id ELSE - CALL section_vals_val_get(gopt_section,"TYPE",i_val=gopt_param%type_id,error=error) + CALL section_vals_val_get(gopt_section,"TYPE",i_val=gopt_param%type_id) END IF - CALL section_vals_val_get(gopt_section,"OPTIMIZER",i_val=gopt_param%method_id,error=error) + CALL section_vals_val_get(gopt_section,"OPTIMIZER",i_val=gopt_param%method_id) - CALL section_vals_val_get(gopt_section,"MAX_ITER",i_val=gopt_param%max_iter,error=error) - CALL section_vals_val_get(gopt_section,"MAX_DR",r_val=gopt_param%max_dr,error=error) - CALL section_vals_val_get(gopt_section,"MAX_FORCE",r_val=gopt_param%max_force,error=error) - CALL section_vals_val_get(gopt_section,"RMS_DR",r_val=gopt_param%rms_dr,error=error) - CALL section_vals_val_get(gopt_section,"RMS_FORCE",r_val=gopt_param%rms_force,error=error) + CALL section_vals_val_get(gopt_section,"MAX_ITER",i_val=gopt_param%max_iter) + CALL section_vals_val_get(gopt_section,"MAX_DR",r_val=gopt_param%max_dr) + CALL section_vals_val_get(gopt_section,"MAX_FORCE",r_val=gopt_param%max_force) + CALL section_vals_val_get(gopt_section,"RMS_DR",r_val=gopt_param%rms_dr) + CALL section_vals_val_get(gopt_section,"RMS_FORCE",r_val=gopt_param%rms_force) SELECT CASE(gopt_param%method_id) CASE(default_lbfgs_method_id) - CALL section_vals_val_get(gopt_section,"LBFGS%MAX_H_RANK",i_val=gopt_param%max_h_rank,error=error) - CALL section_vals_val_get(gopt_section,"LBFGS%MAX_F_PER_ITER",i_val=gopt_param%max_f_per_iter,error=error) - CALL section_vals_val_get(gopt_section,"LBFGS%WANTED_PROJ_GRADIENT",r_val=gopt_param%wanted_proj_gradient,error=error) - CALL section_vals_val_get(gopt_section,"LBFGS%WANTED_REL_F_ERROR",r_val=gopt_param%wanted_rel_f_error,error=error) + CALL section_vals_val_get(gopt_section,"LBFGS%MAX_H_RANK",i_val=gopt_param%max_h_rank) + CALL section_vals_val_get(gopt_section,"LBFGS%MAX_F_PER_ITER",i_val=gopt_param%max_f_per_iter) + CALL section_vals_val_get(gopt_section,"LBFGS%WANTED_PROJ_GRADIENT",r_val=gopt_param%wanted_proj_gradient) + CALL section_vals_val_get(gopt_section,"LBFGS%WANTED_REL_F_ERROR",r_val=gopt_param%wanted_rel_f_error) CASE(default_bfgs_method_id) ! Do nothing CASE(default_cg_method_id) - CALL section_vals_val_get(gopt_section,"CG%FLETCHER_REEVES",l_val=gopt_param%Fletcher_Reeves,error=error) - CALL section_vals_val_get(gopt_section,"CG%MAX_STEEP_STEPS",i_val=gopt_param%max_steep_steps,error=error) - CALL section_vals_val_get(gopt_section,"CG%RESTART_LIMIT",r_val=gopt_param%restart_limit,error=error) - CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%TYPE",i_val=gopt_param%cg_ls%type_id,error=error) + CALL section_vals_val_get(gopt_section,"CG%FLETCHER_REEVES",l_val=gopt_param%Fletcher_Reeves) + CALL section_vals_val_get(gopt_section,"CG%MAX_STEEP_STEPS",i_val=gopt_param%max_steep_steps) + CALL section_vals_val_get(gopt_section,"CG%RESTART_LIMIT",r_val=gopt_param%restart_limit) + CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%TYPE",i_val=gopt_param%cg_ls%type_id) CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%GOLD%INITIAL_STEP",& - r_val=gopt_param%cg_ls%initial_step,error=error) + r_val=gopt_param%cg_ls%initial_step) CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%GOLD%BRENT_TOL",& - r_val=gopt_param%cg_ls%brent_tol,error=error) + r_val=gopt_param%cg_ls%brent_tol) CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%GOLD%BRENT_MAX_ITER",& - i_val=gopt_param%cg_ls%brent_max_iter,error=error) + i_val=gopt_param%cg_ls%brent_max_iter) CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%GOLD%BRACK_LIMIT",& - r_val=gopt_param%cg_ls%brack_limit,error=error) + r_val=gopt_param%cg_ls%brack_limit) CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%2PNT%MAX_ALLOWED_STEP",& - r_val=gopt_param%cg_ls%max_step,error=error) + r_val=gopt_param%cg_ls%max_step) CALL section_vals_val_get(gopt_section,"CG%LINE_SEARCH%2PNT%LINMIN_GRAD_ONLY",& - l_val=gopt_param%cg_ls%grad_only,error=error) + l_val=gopt_param%cg_ls%grad_only) END SELECT SELECT CASE(gopt_param%type_id) @@ -172,9 +166,9 @@ SUBROUTINE gopt_param_read(gopt_param, gopt_section, type_id, error) ! Do Nothing gopt_param%ts_method_id=none_ts_method_id CASE(default_ts_method_id) - CALL section_vals_val_get(gopt_section,"TRANSITION_STATE%METHOD",i_val=gopt_param%ts_method_id,error=error) + CALL section_vals_val_get(gopt_section,"TRANSITION_STATE%METHOD",i_val=gopt_param%ts_method_id) CASE(default_cell_method_id) - CALL section_vals_val_get(gopt_section,"TYPE",i_val=gopt_param%cell_method_id,error=error) + CALL section_vals_val_get(gopt_section,"TYPE",i_val=gopt_param%cell_method_id) END SELECT END SUBROUTINE gopt_param_read @@ -182,14 +176,11 @@ END SUBROUTINE gopt_param_read ! ***************************************************************************** !> \brief ... !> \param gopt_param the geometry optimization environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none ! ***************************************************************************** - SUBROUTINE gopt_param_retain(gopt_param, error) + SUBROUTINE gopt_param_retain(gopt_param) TYPE(gopt_param_type), POINTER :: gopt_param - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_param_retain', & routineP = moduleN//':'//routineN @@ -198,22 +189,19 @@ SUBROUTINE gopt_param_retain(gopt_param, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(gopt_param%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(gopt_param),cp_failure_level,routineP,failure) + CPPreconditionNoFail(gopt_param%ref_count>0,cp_failure_level,routineP) gopt_param%ref_count=gopt_param%ref_count+1 END SUBROUTINE gopt_param_retain ! ***************************************************************************** !> \brief ... !> \param gopt_param the geometry optimization environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none ! ***************************************************************************** - SUBROUTINE gopt_param_release(gopt_param, error) + SUBROUTINE gopt_param_release(gopt_param) TYPE(gopt_param_type), POINTER :: gopt_param - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gopt_param_release', & routineP = moduleN//':'//routineN @@ -224,11 +212,11 @@ SUBROUTINE gopt_param_release(gopt_param, error) failure=.FALSE. IF (ASSOCIATED(gopt_param)) THEN - CPPreconditionNoFail(gopt_param%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(gopt_param%ref_count>0,cp_failure_level,routineP) gopt_param%ref_count=gopt_param%ref_count-1 IF (gopt_param%ref_count==0) THEN DEALLOCATE(gopt_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF END SUBROUTINE gopt_param_release diff --git a/src/motion/helium_interactions.F b/src/motion/helium_interactions.F index b970681523..0d238ec667 100644 --- a/src/motion/helium_interactions.F +++ b/src/motion/helium_interactions.F @@ -200,11 +200,10 @@ SUBROUTINE helium_bead_solute_e_f(pint_env, helium, helium_part_index, & REAL(KIND=dp) :: d, d2, dd, ep, eps, s1, s2, & sig REAL(KIND=dp), DIMENSION(3) :: dr, helium_r, solute_r - TYPE(cp_error_type) :: error failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) num_chlorine = helium%solute_number(1) num_oxygen = helium%solute_number(2) diff --git a/src/motion/helium_methods.F b/src/motion/helium_methods.F index 8915640b31..389faa60c5 100644 --- a/src/motion/helium_methods.F +++ b/src/motion/helium_methods.F @@ -85,14 +85,12 @@ MODULE helium_methods !> \param helium ... !> \param input ... !> \param solute ... -!> \param error ... !> \author hforbert ! ***************************************************************************** - SUBROUTINE helium_create( helium, input, solute, error ) + SUBROUTINE helium_create( helium, input, solute) TYPE(helium_solvent_type), POINTER :: helium TYPE(section_vals_type), POINTER :: input TYPE(pint_env_type), OPTIONAL, POINTER :: solute - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_create', & routineP = moduleN//':'//routineN @@ -116,16 +114,16 @@ SUBROUTINE helium_create( helium, input, solute, error ) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,error,failure) - CPPrecondition(input%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,failure) + CPPrecondition(input%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(helium_section) helium_section => section_vals_get_subs_vals(input, & - "MOTION%PINT%HELIUM",error=error) - CALL section_vals_get(helium_section,explicit=explicit,error=error) - CPPostcondition(explicit,cp_failure_level,routineP,error,failure) + "MOTION%PINT%HELIUM") + CALL section_vals_get(helium_section,explicit=explicit) + CPPostcondition(explicit,cp_failure_level,routineP,failure) ALLOCATE(helium, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY ( helium%input, & helium%ptable, helium%permutation, & helium%iperm, & @@ -160,15 +158,15 @@ SUBROUTINE helium_create( helium, input, solute, error ) helium%relrot = 0 NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! get number of environments in the restart file (if present) CALL section_vals_val_get(helium_section,"NUM_ENV",& - explicit=explicit, error=error) + explicit=explicit) IF ( explicit ) THEN CALL section_vals_val_get(helium_section,"NUM_ENV",& - i_val=itmp, error=error) - CPPostcondition(itmp>=0,cp_failure_level,routineP,error,failure) + i_val=itmp) + CPPostcondition(itmp>=0,cp_failure_level,routineP,failure) helium%num_env_restart = itmp ELSE helium%num_env_restart = -1 @@ -178,7 +176,7 @@ SUBROUTINE helium_create( helium, input, solute, error ) helium%num_env = logger%para_env%num_pe CALL section_vals_val_set(helium%input,& "MOTION%PINT%HELIUM%NUM_ENV",& - i_val=helium%num_env, error=error) + i_val=helium%num_env) ! if the restart file contains more environments than the runtime ! the additional environments (possibly with valuable permutation state) @@ -192,12 +190,12 @@ SUBROUTINE helium_create( helium, input, solute, error ) stmp = "" WRITE(stmp,*) helium%num_env_restart msg_str = TRIM(ADJUSTL(msg_str)) // TRIM(ADJUSTL(stmp)) // ")!" - CALL helium_write_line(msg_str,error) + CALL helium_write_line(msg_str) CALL section_vals_val_get(helium_section,"DROP_UNUSED_ENVS",& - l_val=ltmp, error=error) + l_val=ltmp) IF (ltmp) THEN msg_str = "DROP_UNUSED_ENVS set - proceeding anyways." - CALL helium_write_line(msg_str,error) + CALL helium_write_line(msg_str) ELSE CALL cp_assert( .FALSE., cp_failure_level, & cp_assertion_failed, routineP, msg_str ) @@ -205,26 +203,26 @@ SUBROUTINE helium_create( helium, input, solute, error ) END IF CALL section_vals_val_get(helium_section,"NBEADS",& - i_val=helium%beads, error=error) + i_val=helium%beads) CALL section_vals_val_get(helium_section,"INOROT",& - i_val=helium%iter_norot, error=error) + i_val=helium%iter_norot) CALL section_vals_val_get(helium_section,"IROT",& - i_val=helium%iter_rot, error=error) + i_val=helium%iter_rot) ! get number of steps and current step number from PINT CALL section_vals_val_get(input,"MOTION%PINT%ITERATION",& - i_val=itmp, error=error) + i_val=itmp) helium%first_step = itmp CALL section_vals_val_get(input,"MOTION%PINT%MAX_STEP",& - explicit=explicit, error=error) + explicit=explicit) IF ( explicit ) THEN CALL section_vals_val_get(input,"MOTION%PINT%MAX_STEP",& - i_val=itmp, error=error) + i_val=itmp) helium%last_step = itmp helium%num_steps = helium%last_step - helium%first_step ELSE CALL section_vals_val_get(input,"MOTION%PINT%NUM_STEPS",& - i_val=itmp, error=error) + i_val=itmp) helium%num_steps = itmp helium%last_step = helium%first_step + helium%num_steps END IF @@ -232,10 +230,10 @@ SUBROUTINE helium_create( helium, input, solute, error ) ! If we should apply periodicity, check wheather we support the cell ! shape or not, and refuse to proceed if not. Otherwise just go on. CALL section_vals_val_get(helium_section,"PERIODIC",& - l_val=helium%periodic, error=error) + l_val=helium%periodic) IF ( helium%periodic ) THEN CALL section_vals_val_get(helium_section,"CELL_SHAPE",& - i_val=helium%cell_shape, error=error) + i_val=helium%cell_shape) cell_shape_supported = .FALSE. IF ( helium%cell_shape .EQ. helium_cell_shape_cube ) THEN cell_shape_supported = .TRUE. @@ -266,11 +264,11 @@ SUBROUTINE helium_create( helium, input, solute, error ) ! If CELL_SIZE is not given explicitly then all four combinations of the ! two other options are valid. CALL section_vals_val_get(helium_section,"DENSITY",& - explicit=expl_dens, r_val=helium%density, error=error) + explicit=expl_dens, r_val=helium%density) CALL section_vals_val_get(helium_section,"NATOMS",& - explicit=expl_nats, i_val=helium%atoms, error=error) + explicit=expl_nats, i_val=helium%atoms) CALL section_vals_val_get(helium_section,"CELL_SIZE",& - explicit=expl_cell, error=error) + explicit=expl_cell) cgeof = 1.0_dp IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) cgeof = 2.0_dp rtmp = ( cgeof * helium%atoms / helium%density )**(1.0_dp/3.0_dp) @@ -278,7 +276,7 @@ SUBROUTINE helium_create( helium, input, solute, error ) helium%cell_size = rtmp ELSE CALL section_vals_val_get(helium_section,"CELL_SIZE",& - r_val=helium%cell_size, error=error) + r_val=helium%cell_size) ! only more work if not all three values are consistent: IF ( ABS(helium%cell_size-rtmp) .GT. 100.0_dp*EPSILON(0.0_dp)* & (ABS(helium%cell_size)+rtmp) ) THEN @@ -294,7 +292,7 @@ SUBROUTINE helium_create( helium, input, solute, error ) IF ( .NOT. expl_nats ) THEN msg_str = "Warning: CELL_SIZE defined but neither "//& "NATOMS nor DENSITY given, using default NATOMS." - CALL helium_write_line(msg_str, error) + CALL helium_write_line(msg_str) END IF ELSE ! ( expl_dens .AND. .NOT. expl_nats ) ! calculate the nearest number of atoms for given conditions @@ -308,7 +306,7 @@ SUBROUTINE helium_create( helium, input, solute, error ) * ( ABS(helium%cell_size)+rtmp ) ) THEN msg_str = "Warning: Adjusting actual cell size "//& "to maintain correct density." - CALL helium_write_line(msg_str, error) + CALL helium_write_line(msg_str) helium%cell_size = rtmp END IF END IF @@ -343,31 +341,31 @@ SUBROUTINE helium_create( helium, input, solute, error ) ! check value of maxcycle CALL section_vals_val_get(helium_section,"MAX_PERM_CYCLE",& - i_val=helium%maxcycle, error=error) + i_val=helium%maxcycle) i = helium%maxcycle - CPPostcondition(i>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(i>=0,cp_failure_level,routineP,failure) i = helium%atoms - helium%maxcycle - CPPostcondition(i>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(i>=0,cp_failure_level,routineP,failure) ! set m-distribution parameters CALL section_vals_val_get(helium_section,"M-SAMPLING%M-VALUE",& - i_val=i, error=error) - CPPostcondition(i>=1,cp_failure_level,routineP,error,failure) - CPPostcondition(i<=helium%maxcycle,cp_failure_level,routineP,error,failure) + i_val=i) + CPPostcondition(i>=1,cp_failure_level,routineP,failure) + CPPostcondition(i<=helium%maxcycle,cp_failure_level,routineP,failure) helium%m_value = i CALL section_vals_val_get(helium_section,"M-SAMPLING%M-RATIO",& - r_val=rtmp, error=error) - CPPostcondition(rtmp>0.0_dp,cp_failure_level,routineP,error,failure) - CPPostcondition(rtmp<=1.0_dp,cp_failure_level,routineP,error,failure) + r_val=rtmp) + CPPostcondition(rtmp>0.0_dp,cp_failure_level,routineP,failure) + CPPostcondition(rtmp<=1.0_dp,cp_failure_level,routineP,failure) helium%m_ratio = rtmp CALL section_vals_val_get(helium_section,"BISECTION",& - i_val=helium%bisection, error=error) + i_val=helium%bisection) ! precheck bisection value (not all invalids are filtered out here yet) i = helium%bisection - CPPostcondition(i>1,cp_failure_level,routineP,error,failure) + CPPostcondition(i>1,cp_failure_level,routineP,failure) i = helium%beads - helium%bisection - CPPostcondition(i>0,cp_failure_level,routineP,error,failure) + CPPostcondition(i>0,cp_failure_level,routineP,failure) ! itmp = helium%bisection rtmp = 2**(ANINT(LOG(REAL(itmp))/LOG(2.0_dp))) @@ -384,20 +382,20 @@ SUBROUTINE helium_create( helium, input, solute, error ) ! get the RDF parameters CALL section_vals_val_get(helium_section,"RDF%MAXR",& - explicit=explicit, error=error) + explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(helium_section,"RDF%MAXR",& - r_val=helium%rdf_maxr, error=error) + r_val=helium%rdf_maxr) ELSE helium%rdf_maxr = helium%cell_size END IF CALL section_vals_val_get(helium_section,"RDF%NBIN",& - i_val=helium%rdf_nbin, error=error) + i_val=helium%rdf_nbin) helium%rdf_delr = helium%rdf_maxr / REAL(helium%rdf_nbin,KIND=dp) IF (logger%para_env%ionode) THEN CALL section_vals_val_get(helium_section,"POTENTIAL_FILE_NAME",& - c_val=potential_file_name, error=error) + c_val=potential_file_name) CALL open_file(file_name=TRIM(potential_file_name), & file_action="READ", file_status="OLD",unit_number=input_unit) READ (input_unit,*) nlines, helium%pdx, helium%tau,& @@ -419,17 +417,15 @@ SUBROUTINE helium_create( helium, input, solute, error ) isize = helium%pdx+1 ALLOCATE(helium%uij(isize,isize),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%eij(isize,isize),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, isize DO j = 1, i - CALL spline_data_create(helium%uij(i,j)%spline_data, & - error=error) + CALL spline_data_create(helium%uij(i,j)%spline_data) CALL init_splinexy(helium%uij(i,j)%spline_data,nlines) helium%uij(i,j)%spline_data%x1 = x1 - CALL spline_data_create(helium%eij(i,j)%spline_data, & - error=error) + CALL spline_data_create(helium%eij(i,j)%spline_data) CALL init_splinexy(helium%eij(i,j)%spline_data,nlines) helium%eij(i,j)%spline_data%x1 = x1 END DO @@ -437,17 +433,15 @@ SUBROUTINE helium_create( helium, input, solute, error ) DO i = 1, isize-1 DO j = i+1, isize helium%uij(i,j) = helium%uij(j,i) - CALL spline_data_retain(helium%uij(i,j)%spline_data, & - error=error) + CALL spline_data_retain(helium%uij(i,j)%spline_data) helium%eij(i,j) = helium%eij(j,i) - CALL spline_data_retain(helium%eij(i,j)%spline_data, & - error=error) + CALL spline_data_retain(helium%eij(i,j)%spline_data) END DO END DO isize = (helium%pdx+1)*(helium%pdx+2) ALLOCATE(pot_transfer(nlines,isize), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (logger%para_env%ionode) THEN DO i = 1, nlines READ (input_unit,*) pot_transfer(i,:) @@ -475,63 +469,63 @@ SUBROUTINE helium_create( helium, input, solute, error ) END DO END DO DEALLOCATE(pot_transfer, STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ! ALLOCATE helium-related arrays i = helium%atoms j = helium%beads ALLOCATE(helium%pos(3,i,j),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%work(3,i,j),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%ptable(helium%maxcycle+1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%permutation(i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%iperm(i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%tmatrix(i,i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%nmatrix(i,2*i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%pmatrix(i,i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%ipmatrix(i,i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) itmp = helium%bisctlog2 + 2 ALLOCATE(helium%num_accepted(itmp,helium%maxcycle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rdf_avrg(helium%rdf_nbin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rdf_inst(helium%rdf_nbin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%plength_avrg(helium%atoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%plength_inst(helium%atoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%atom_plength(helium%atoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! density related data helium%rho_num = 1 CALL section_vals_val_get(helium_section, & "RHO%_SECTION_PARAMETERS_", & - l_val=helium%rho_present, error=error) + l_val=helium%rho_present) IF ( helium%rho_present ) THEN helium%rho_maxr = helium%cell_size CALL section_vals_val_get(helium%input, & "MOTION%PINT%HELIUM%RHO%IWEIGHT",& - i_val=helium%rho_iweight, error=error) + i_val=helium%rho_iweight) CALL section_vals_val_get(helium_section,"RHO%NBIN",& - i_val=helium%rho_nbin, error=error) + i_val=helium%rho_nbin) helium%rho_delr = helium%rho_maxr / REAL(helium%rho_nbin,KIND=dp) helium%rho_minb = INT(-helium%cell_size / 2.0_dp / helium%rho_delr ) itmp = helium%rho_nbin jtmp = helium%rho_num ALLOCATE(helium%rho_avrg(jtmp,itmp,itmp,itmp),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rho_inst(jtmp,itmp,itmp,itmp),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) helium%rho_avrg(:,:,:,:) = 0.0_dp helium%rho_inst(:,:,:,:) = 0.0_dp @@ -539,15 +533,15 @@ SUBROUTINE helium_create( helium, input, solute, error ) ! as we will make so much effort to calculated it CALL section_vals_val_set(helium%input, & "MOTION%PINT%HELIUM%PRINT%RHO%_SECTION_PARAMETERS_",& - i_val=silent_print_level-1, error=error) + i_val=silent_print_level-1) END IF CALL section_vals_val_get(helium%input, & "EXT_RESTART%RESTART_HELIUM_DENSITIES", & - l_val=helium%rho_restart,error=error) + l_val=helium%rho_restart) IF ( helium%rho_restart ) THEN IF ( helium%rho_present) THEN - CALL helium_densities_restore( helium, error ) + CALL helium_densities_restore( helium) ELSE msg_str = "Inconsistent input: densities not calculated but restarted!" CALL cp_assert(.FALSE.,cp_failure_level,& @@ -556,7 +550,7 @@ SUBROUTINE helium_create( helium, input, solute, error ) END IF ! RNG state create & init - CALL helium_rng_state_init( helium, error ) + CALL helium_rng_state_init( helium) ! check if solute is present in our simulation helium%solute_present = .FALSE. @@ -576,7 +570,7 @@ SUBROUTINE helium_create( helium, input, solute, error ) ! check if bead numbers are commensurate: i = helium%bead_ratio*helium%solute_beads - helium%beads !TODO Adjust helium bead number if not comm. and if coords not given expl. - CPPostcondition(i==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i==0,cp_failure_level,routineP,failure) ! check if tau, temperature and bead number are consistent: tcheck=ABS( (helium%tau*helium%beads-solute%beta) / solute%beta ) @@ -608,40 +602,40 @@ SUBROUTINE helium_create( helium, input, solute, error ) ! ALLOCATE solute-related arrays ALLOCATE(helium%force_avrg(helium%solute_beads,& helium%solute_atoms*3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%force_inst(helium%solute_beads,& helium%solute_atoms*3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! ALLOCATE temporary arrays ALLOCATE(helium%itmp_atoms_1d(helium%atoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%ltmp_atoms_1d(helium%atoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%itmp_atoms_np_1d(helium%atoms*helium%num_env),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rtmp_3_np_1d(3*helium%num_env),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rtmp_p_ndim_1d(helium%solute_beads*& helium%solute_atoms*3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rtmp_p_ndim_np_1d(helium%solute_beads*& helium%solute_atoms*3*helium%num_env),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rtmp_3_atoms_beads_1d(3*helium%atoms*& helium%beads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rtmp_3_atoms_beads_np_1d(3*helium%atoms*& helium%beads*helium%num_env),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%rtmp_p_ndim_2d(helium%solute_beads,& helium%solute_atoms*3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(helium%ltmp_3_atoms_beads_3d(3,helium%atoms,& helium%beads),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL helium_write_setup(helium,error) + CALL helium_write_setup(helium) CALL timestop(handle) @@ -652,12 +646,10 @@ END SUBROUTINE helium_create ! *************************************************************************** !> \brief Releases helium_solvent_type !> \param helium ... -!> \param error ... !> \author hforbert ! ***************************************************************************** - SUBROUTINE helium_release(helium,error) + SUBROUTINE helium_release(helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_release', & routineP = moduleN//':'//routineN @@ -668,7 +660,7 @@ SUBROUTINE helium_release(helium,error) failure=.FALSE. IF (ASSOCIATED(helium)) THEN - CPPrecondition(helium%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(helium%ref_count>0,cp_failure_level,routineP,failure) helium%ref_count=helium%ref_count-1 IF (helium%ref_count<1) THEN @@ -685,7 +677,7 @@ SUBROUTINE helium_release(helium,error) helium%ltmp_atoms_1d, & helium%itmp_atoms_1d, & STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY ( & helium%ltmp_3_atoms_beads_3d, & helium%rtmp_p_ndim_2d, & @@ -704,7 +696,7 @@ SUBROUTINE helium_release(helium,error) helium%force_inst, & helium%force_avrg, & STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY( & helium%force_inst, & helium%force_avrg & @@ -713,7 +705,7 @@ SUBROUTINE helium_release(helium,error) IF ( helium%rho_present ) THEN IF ( helium%rho_restart ) THEN DEALLOCATE( helium%rho_rstr, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY( helium%rho_rstr ) END IF DEALLOCATE( & @@ -745,7 +737,7 @@ SUBROUTINE helium_release(helium,error) helium%work, & helium%pos, & STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY( & helium%atom_plength, & helium%plength_inst, & @@ -766,10 +758,8 @@ SUBROUTINE helium_release(helium,error) DO i = 1, SIZE ( helium%eij , 1 ) DO j = 1, SIZE ( helium%eij , 1 ) - CALL spline_data_release(helium%eij(i,j)%spline_data,& - error=error) - CALL spline_data_release(helium%uij(i,j)%spline_data,& - error=error) + CALL spline_data_release(helium%eij(i,j)%spline_data) + CALL spline_data_release(helium%uij(i,j)%spline_data) !TODO: shouldn't that be done in spline_data_release?? NULLIFY(helium%eij(i,j)%spline_data, & helium%uij(i,j)%spline_data) @@ -777,15 +767,15 @@ SUBROUTINE helium_release(helium,error) END DO DEALLOCATE( helium%eij, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(helium%eij) DEALLOCATE( helium%uij, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(helium%uij) - CALL delete_rng_stream(helium%rng_stream_uniform,error=error) - CALL delete_rng_stream(helium%rng_stream_gaussian,error=error) + CALL delete_rng_stream(helium%rng_stream_uniform) + CALL delete_rng_stream(helium%rng_stream_gaussian) ! deallocate solute-related arrays IF (helium%solute_present) THEN @@ -793,14 +783,14 @@ SUBROUTINE helium_release(helium,error) helium%solute_number, & helium%solute_index, & STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(helium%solute_element, & helium%solute_number, & helium%solute_index) END IF DEALLOCATE( helium, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF @@ -810,12 +800,10 @@ END SUBROUTINE helium_release ! *************************************************************************** !> \brief Retains helium_solvent_type !> \param helium ... -!> \param error ... !> \author hforbert ! ***************************************************************************** - SUBROUTINE helium_retain(helium,error) + SUBROUTINE helium_retain(helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_retain', & routineP = moduleN//':'//routineN @@ -823,8 +811,8 @@ SUBROUTINE helium_retain(helium,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(helium%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(helium%ref_count>0,cp_failure_level,routineP,failure) helium%ref_count=helium%ref_count+1 RETURN END SUBROUTINE helium_retain @@ -833,7 +821,6 @@ END SUBROUTINE helium_retain !> \brief Initialize helium data structures. !> \param helium ... !> \param pint_env ... -!> \param error ... !> \par History !> removed refereces to pint_env_type data structure [lwalewski] !> 2009-11-10 init/restore coords, perm, RNG and forces [lwalewski] @@ -843,11 +830,10 @@ END SUBROUTINE helium_retain !> Initializes helium permutation state as identity permutation or !> from HELIUM%PERM section if it's present in the input file. ! ***************************************************************************** - SUBROUTINE helium_init( helium, pint_env, error ) + SUBROUTINE helium_init( helium, pint_env) TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_init', & routineP = moduleN//':'//routineN @@ -861,60 +847,60 @@ SUBROUTINE helium_init( helium, pint_env, error ) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(helium%input),cp_failure_level,routineP,failure) NULLIFY(helium_section) helium_section => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM", error=error) + "MOTION%PINT%HELIUM") ! set the origin for rdf and density calculations IF (helium%solute_present) THEN - helium%origin = pint_com_pos(pint_env,error) + helium%origin = pint_com_pos(pint_env) ELSE helium%origin = (/0.0_dp, 0.0_dp, 0.0_dp/) END IF ! restore RNG state NULLIFY(sec) - sec => section_vals_get_subs_vals(helium_section,"RNG_STATE",error=error) - CALL section_vals_get(sec,explicit=explicit,error=error) + sec => section_vals_get_subs_vals(helium_section,"RNG_STATE") + CALL section_vals_get(sec,explicit=explicit) IF ( explicit ) THEN - CALL helium_rng_state_restore( helium, error ) + CALL helium_rng_state_restore( helium) ELSE - CALL helium_write_line("RNG state initialized as new.",error) + CALL helium_write_line("RNG state initialized as new.") END IF ! init/restore permutation state NULLIFY(sec) - sec => section_vals_get_subs_vals(helium_section,"PERM",error=error) - CALL section_vals_get(sec,explicit=explicit,error=error) + sec => section_vals_get_subs_vals(helium_section,"PERM") + CALL section_vals_get(sec,explicit=explicit) IF ( explicit ) THEN - CALL helium_perm_restore( helium, error ) + CALL helium_perm_restore( helium) ELSE - CALL helium_perm_init( helium, error ) - CALL helium_write_line("Permutation state initialized as identity.",error) + CALL helium_perm_init( helium) + CALL helium_write_line("Permutation state initialized as identity.") END IF ! init/restore coordinates NULLIFY(sec) - sec => section_vals_get_subs_vals(helium_section,"COORD",error=error) - CALL section_vals_get(sec,explicit=explicit,error=error) + sec => section_vals_get_subs_vals(helium_section,"COORD") + CALL section_vals_get(sec,explicit=explicit) CALL section_vals_val_get(helium_section,"PRESAMPLE",& - l_val=presample, error=error) + l_val=presample) CALL section_vals_val_get(helium_section,"PRESAMPLE",& - explicit=explicit_presample, error=error) + explicit=explicit_presample) coords_presampled = .FALSE. IF ( explicit ) THEN - CALL helium_coord_restore( helium, error ) + CALL helium_coord_restore( helium) IF ( presample ) THEN ! Default value of PINT%HELIUM%PRESAMPLE is .FALSE. so if the actual ! value is .TRUE. it must have been supplied explicitly. ! This might be used to force presampling even though the cooridnates ! are given in the restart file. - CALL helium_sample( helium, pint_env, error ) + CALL helium_sample( helium, pint_env) helium%force_avrg(:,:) = 0.0_dp helium%energy_avrg(:) = 0.0_dp helium%wnumber_avrg(:) = 0.0_dp @@ -923,11 +909,11 @@ SUBROUTINE helium_init( helium, pint_env, error ) helium%rdf_avrg(:) = 0.0_dp helium%num_accepted(:,:) = 0.0_dp coords_presampled = .TRUE. - CALL helium_write_line("Bead coordinates pre-sampled.",error) + CALL helium_write_line("Bead coordinates pre-sampled.") END IF ELSE - CALL helium_coord_init( helium, error ) - CALL helium_write_line("Bead coordinates initialized as random.",error) + CALL helium_coord_init( helium) + CALL helium_write_line("Bead coordinates initialized as random.") IF ( (explicit_presample .AND. presample) .OR. & (.NOT. explicit_presample) ) THEN ! Perform initial MC sampling to get rid of the overlaps. @@ -937,7 +923,7 @@ SUBROUTINE helium_init( helium, pint_env, error ) ! case when PRESAMPLE is given explicitly and it's value is set to ! .FALSE. - this might be used to skip presampling even though the ! coordinates are not given in the restart file. - CALL helium_sample( helium, pint_env, error ) + CALL helium_sample( helium, pint_env) helium%force_avrg(:,:) = 0.0_dp helium%energy_avrg(:) = 0.0_dp helium%wnumber_avrg(:) = 0.0_dp @@ -946,23 +932,23 @@ SUBROUTINE helium_init( helium, pint_env, error ) helium%rdf_avrg(:) = 0.0_dp helium%num_accepted(:,:) = 0.0_dp coords_presampled = .TRUE. - CALL helium_write_line("Bead coordinates pre-sampled.",error) + CALL helium_write_line("Bead coordinates pre-sampled.") END IF END IF IF ( helium%solute_present ) THEN ! restore helium forces NULLIFY(sec) - sec => section_vals_get_subs_vals(helium_section,"FORCE",error=error) - CALL section_vals_get(sec,explicit=explicit,error=error) + sec => section_vals_get_subs_vals(helium_section,"FORCE") + CALL section_vals_get(sec,explicit=explicit) IF ( explicit ) THEN IF ( .NOT. coords_presampled ) THEN - CALL helium_force_restore( helium, error ) + CALL helium_force_restore( helium) END IF ELSE IF ( .NOT. coords_presampled ) THEN - CALL helium_force_init( helium, error ) - CALL helium_write_line("Forces on the solute initialized as zero.",error) + CALL helium_force_init( helium) + CALL helium_write_line("Forces on the solute initialized as zero.") END IF END IF END IF @@ -982,13 +968,11 @@ END SUBROUTINE helium_init ! *************************************************************************** !> \brief Initialize helium coordinates with random positions. !> \param helium ... -!> \param error ... !> \date 2009-11-09 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_coord_init( helium, error ) + SUBROUTINE helium_coord_init( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_coord_init', & routineP = moduleN//':'//routineN @@ -998,15 +982,15 @@ SUBROUTINE helium_coord_init( helium, error ) REAL(kind=dp) :: r1, r2 failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) DO ia = 1, helium%atoms DO ic = 1, 3 - r1 = next_random_number(helium%rng_stream_uniform,error=error) + r1 = next_random_number(helium%rng_stream_uniform) r1 = r1 * helium%cell_size DO ib = 1, helium%beads !TODO use thermal gaussian instead - r2 = next_random_number(helium%rng_stream_uniform,error=error) + r2 = next_random_number(helium%rng_stream_uniform) helium%pos(ic,ia,ib) = r1+0.1_dp*r2 END DO END DO @@ -1021,16 +1005,14 @@ END SUBROUTINE helium_coord_init ! *************************************************************************** !> \brief Restore coordinates from the input structure. !> \param helium ... -!> \param error ... !> \date 2009-11-09 !> \par History !> 2010-07-22 accomodate additional cpus in the runtime wrt the !> restart [lwalewski] !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_coord_restore( helium, error ) + SUBROUTINE helium_coord_restore( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_coord_restore', & routineP = moduleN//':'//routineN @@ -1047,17 +1029,17 @@ SUBROUTINE helium_coord_restore( helium, error ) TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! assign the pointer to the memory location of the input structure, where ! the coordinates are stored NULLIFY(message) CALL section_vals_val_get( helium%input, & "MOTION%PINT%HELIUM%COORD%_DEFAULT_KEYWORD_", & - r_vals=message, error=error) + r_vals=message) ! check that the number of values in the input match the current runtime actlen = SIZE(message) @@ -1068,40 +1050,40 @@ SUBROUTINE helium_coord_restore( helium, error ) offset = msglen * MOD( logger%para_env%mepos, num_env_restart ) NULLIFY(m,f) ALLOCATE(m(3,helium%atoms,helium%beads),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) ALLOCATE(f(3,helium%atoms,helium%beads),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) m(:,:,:) = .TRUE. f(:,:,:) = 0.0_dp helium%pos(:,:,:) = UNPACK(message(offset+1:offset+msglen), MASK=m, FIELD=f ) DEALLOCATE(f,m,STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) IF ( num_env_restart .NE. logger%para_env%num_pe ) THEN err_str = "Reading bead coordinates from the input file." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) err_str = "Number of environments in the restart...: '" stmp = "" WRITE(stmp,*) num_env_restart err_str = TRIM(ADJUSTL(err_str)) // TRIM(ADJUSTL(stmp)) // "'." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) err_str = "Number of current run time environments.: '" stmp = "" WRITE(stmp,*) logger%para_env%num_pe err_str = TRIM(ADJUSTL(err_str)) // TRIM(ADJUSTL(stmp)) // "'." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) IF ( num_env_restart .LT. logger%para_env%num_pe ) THEN err_str = "Replicated bead coordinates from the restarted environments." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) END IF IF ( num_env_restart .GT. logger%para_env%num_pe ) THEN err_str = "Dropped bead coordinates from some restarted environments." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) END IF err_str = "Done." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) ELSE - CALL helium_write_line("Bead coordinates read from the input file.",error) + CALL helium_write_line("Bead coordinates read from the input file.") END IF NULLIFY(message) @@ -1112,16 +1094,14 @@ END SUBROUTINE helium_coord_restore ! *************************************************************************** !> \brief Initialize forces exerted on the solute. !> \param helium ... -!> \param error ... !> \date 2009-11-10 !> \author Lukasz Walewski !> \note The forces are calculated based on both the helium and the solute !> positions, hence this function should be called AFTER !> helium_coord_init/restore. ! ***************************************************************************** - SUBROUTINE helium_force_init( helium,error ) + SUBROUTINE helium_force_init( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_force_init', & routineP = moduleN//':'//routineN @@ -1129,7 +1109,7 @@ SUBROUTINE helium_force_init( helium,error ) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) IF ( helium%solute_present ) THEN !TODO initial forces are set to 0 due to possible overlapping atoms @@ -1145,13 +1125,11 @@ END SUBROUTINE helium_force_init ! *************************************************************************** !> \brief Restore forces from the input structure to the runtime environment. !> \param helium ... -!> \param error ... !> \date 2009-11-10 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_force_restore( helium, error ) + SUBROUTINE helium_force_restore( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_force_restore', & routineP = moduleN//':'//routineN @@ -1165,14 +1143,14 @@ SUBROUTINE helium_force_restore( helium, error ) REAL(kind=dp), DIMENSION(:, :), POINTER :: f failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) ! assign the pointer to the memory location of the input structure, where ! the forces are stored NULLIFY(message) CALL section_vals_val_get( helium%input, & "MOTION%PINT%HELIUM%FORCE%_DEFAULT_KEYWORD_", & - r_vals=message, error=error) + r_vals=message) ! check the number of environments presumably stored in the restart actlen = SIZE(message) @@ -1196,17 +1174,17 @@ SUBROUTINE helium_force_restore( helium, error ) ! restore forces on all processors (no message passing) NULLIFY(m,f) ALLOCATE(m(helium%solute_beads,helium%solute_atoms*3),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) ALLOCATE(f(helium%solute_beads,helium%solute_atoms*3),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) m(:,:) = .TRUE. f(:,:) = 0.0_dp helium%force_avrg(:,:) = UNPACK(message(1:msglen), MASK=m, FIELD=f ) helium%force_inst(:,:) = 0.0_dp DEALLOCATE(f,m,STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) - CALL helium_write_line("Forces on the solute read from the input file.",error) + CALL helium_write_line("Forces on the solute read from the input file.") NULLIFY(message) @@ -1216,15 +1194,13 @@ END SUBROUTINE helium_force_restore ! *************************************************************************** !> \brief Initialize the permutation state. !> \param helium ... -!> \param error ... !> \date 2009-11-05 !> \author Lukasz Walewski !> \note Assign the identity permutation at each processor. Inverse !> permutation array gets assigned as well. ! ***************************************************************************** - SUBROUTINE helium_perm_init( helium, error ) + SUBROUTINE helium_perm_init( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_perm_init', & routineP = moduleN//':'//routineN @@ -1233,7 +1209,7 @@ SUBROUTINE helium_perm_init( helium, error ) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) DO ia = 1, helium%atoms helium%permutation(ia) = ia @@ -1246,7 +1222,6 @@ END SUBROUTINE helium_perm_init ! *************************************************************************** !> \brief Restore permutation state from the input structre. !> \param helium ... -!> \param error ... !> \date 2009-11-05 !> \par History !> 2010-07-22 accomodate additional cpus in the runtime wrt the @@ -1256,9 +1231,8 @@ END SUBROUTINE helium_perm_init !> data structures on each processor. Inverse permutation array is !> recalculated according to the restored permutation state. ! ***************************************************************************** - SUBROUTINE helium_perm_restore( helium, error ) + SUBROUTINE helium_perm_restore( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_perm_restore', & routineP = moduleN//':'//routineN @@ -1271,17 +1245,17 @@ SUBROUTINE helium_perm_restore( helium, error ) TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! assign the pointer to the memory location of the input structure, where ! the permutation state is stored NULLIFY(message) CALL section_vals_val_get( helium%input, & "MOTION%PINT%HELIUM%PERM%_DEFAULT_KEYWORD_", & - i_vals=message, error=error) + i_vals=message) ! check the number of environments presumably stored in the restart actlen = SIZE(message) @@ -1297,29 +1271,29 @@ SUBROUTINE helium_perm_restore( helium, error ) IF ( num_env_restart .NE. logger%para_env%num_pe ) THEN err_str = "Reading permutation state from the input file." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) err_str = "Number of environments in the restart...: '" stmp = "" WRITE(stmp,*) num_env_restart err_str = TRIM(ADJUSTL(err_str)) // TRIM(ADJUSTL(stmp)) // "'." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) err_str = "Number of current run time environments.: '" stmp = "" WRITE(stmp,*) logger%para_env%num_pe err_str = TRIM(ADJUSTL(err_str)) // TRIM(ADJUSTL(stmp)) // "'." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) IF ( num_env_restart .LT. logger%para_env%num_pe ) THEN err_str = "Replicated permutation state from the restarted environments." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) END IF IF ( num_env_restart .GT. logger%para_env%num_pe ) THEN err_str = "Dropped permutation state from some restarted environments." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) END IF err_str = "Done." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) ELSE - CALL helium_write_line("Permutation state read from the input file.",error) + CALL helium_write_line("Permutation state read from the input file.") END IF ! recalculate the inverse permutation array @@ -1347,16 +1321,14 @@ END SUBROUTINE helium_perm_restore ! *************************************************************************** !> \brief Create RNG streams and initialize their state. !> \param helium ... -!> \param error ... !> \date 2009-11-04 !> \author Lukasz Walewski !> \note This function shouldn't create (allocate) objects! Only !> initialization, i.e. setting the seed values etc, should be done !> here, allocation should be moved to helium_create ! ***************************************************************************** - SUBROUTINE helium_rng_state_init( helium, error ) + SUBROUTINE helium_rng_state_init( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_rng_state_init', & routineP = moduleN//':'//routineN @@ -1367,10 +1339,10 @@ SUBROUTINE helium_rng_state_init( helium, error ) TYPE(rng_stream_type), POINTER :: next_rngs, prev_rngs failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Create two RNG streams on each processor and initialize them so, that ! each processor gets unique RN sequences. @@ -1384,8 +1356,7 @@ SUBROUTINE helium_rng_state_init( helium, error ) CALL create_rng_stream(prev_rngs,& name="helium_rns_uniform",& distribution_type=UNIFORM,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) IF (logger%para_env%mepos .EQ. 0) THEN helium%rng_stream_uniform => prev_rngs END IF @@ -1393,13 +1364,12 @@ SUBROUTINE helium_rng_state_init( helium, error ) name="helium_rns_gaussian",& last_rng_stream=prev_rngs,& distribution_type=GAUSSIAN,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) IF (logger%para_env%mepos .EQ. 0) THEN helium%rng_stream_gaussian => next_rngs NULLIFY(prev_rngs) ELSE - CALL delete_rng_stream(prev_rngs,error=error) + CALL delete_rng_stream(prev_rngs) prev_rngs => next_rngs END IF NULLIFY(next_rngs) @@ -1412,25 +1382,23 @@ SUBROUTINE helium_rng_state_init( helium, error ) name="helium_rns_uniform",& last_rng_stream=prev_rngs,& distribution_type=UNIFORM,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) IF ( logger%para_env%mepos .EQ. rank ) THEN helium%rng_stream_uniform => next_rngs END IF - CALL delete_rng_stream(prev_rngs,error=error) + CALL delete_rng_stream(prev_rngs) prev_rngs => next_rngs NULLIFY(next_rngs) CALL create_rng_stream(next_rngs,& name="helium_rns_gaussian",& last_rng_stream=prev_rngs,& distribution_type=GAUSSIAN,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) IF ( logger%para_env%mepos .EQ. rank ) THEN helium%rng_stream_gaussian => next_rngs NULLIFY(prev_rngs) ELSE - CALL delete_rng_stream(prev_rngs,error=error) + CALL delete_rng_stream(prev_rngs) prev_rngs => next_rngs END IF NULLIFY(next_rngs) @@ -1442,16 +1410,14 @@ END SUBROUTINE helium_rng_state_init ! *************************************************************************** !> \brief Restore RNG state from the input structure. !> \param helium ... -!> \param error ... !> \date 2009-11-04 !> \par History !> 2010-07-22 Create new rng streams if more cpus available in the !> runtime than in the restart [lwalewski] !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_rng_state_restore( helium, error ) + SUBROUTINE helium_rng_state_restore( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_rng_state_restore', & routineP = moduleN//':'//routineN @@ -1468,17 +1434,17 @@ SUBROUTINE helium_rng_state_restore( helium, error ) TYPE(rng_stream_type), POINTER :: next_rngs, prev_rngs failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! assign the pointer to the memory location of the input structure ! where the RNG state is stored NULLIFY(message) CALL section_vals_val_get( helium%input, & "MOTION%PINT%HELIUM%RNG_STATE%_DEFAULT_KEYWORD_", & - r_vals=message, error=error) + r_vals=message) ! check the number of environments presumably stored in the restart actlen = SIZE(message) @@ -1502,7 +1468,7 @@ SUBROUTINE helium_rng_state_restore( helium, error ) lbf = .FALSE. END IF CALL set_rng_stream(helium%rng_stream_uniform,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf,error=error) + buffer=bu,buffer_filled=lbf) bg(:,:) = UNPACK(message(offset+21:offset+26), MASK=m, FIELD=f ) cg(:,:) = UNPACK(message(offset+27:offset+32), MASK=m, FIELD=f ) ig(:,:) = UNPACK(message(offset+33:offset+38), MASK=m, FIELD=f ) @@ -1514,7 +1480,7 @@ SUBROUTINE helium_rng_state_restore( helium, error ) lbf = .FALSE. END IF CALL set_rng_stream(helium%rng_stream_gaussian,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf,error=error) + buffer=bu,buffer_filled=lbf) ELSE ! On processors that did not receive rng state from the restart file @@ -1524,8 +1490,8 @@ SUBROUTINE helium_rng_state_restore( helium, error ) ! restart file, each stream is initialized from the previously created ! one. - CALL delete_rng_stream(helium%rng_stream_uniform,error) - CALL delete_rng_stream(helium%rng_stream_gaussian,error) + CALL delete_rng_stream(helium%rng_stream_uniform) + CALL delete_rng_stream(helium%rng_stream_gaussian) NULLIFY(prev_rngs, next_rngs) NULLIFY(helium%rng_stream_uniform,helium%rng_stream_gaussian) @@ -1548,11 +1514,10 @@ SUBROUTINE helium_rng_state_restore( helium, error ) CALL create_rng_stream(prev_rngs,& name="helium_rns_uniform",& distribution_type=UNIFORM,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) ! set it to the last uniform rng stream from the restart CALL set_rng_stream(prev_rngs,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf,error=error) + buffer=bu,buffer_filled=lbf) ! use this on the first non-restarted environment as the new rng IF ( logger%para_env%mepos .EQ. num_env_restart ) THEN helium%rng_stream_uniform => prev_rngs @@ -1573,17 +1538,16 @@ SUBROUTINE helium_rng_state_restore( helium, error ) name="helium_rns_gaussian",& last_rng_stream=prev_rngs,& distribution_type=GAUSSIAN,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) ! set it to the last gaussian rng stream from the restart CALL set_rng_stream(next_rngs,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf,error=error) + buffer=bu,buffer_filled=lbf) ! use this on the first non-restarted environment as the new gaussian rng IF ( logger%para_env%mepos .EQ. num_env_restart ) THEN helium%rng_stream_gaussian => next_rngs NULLIFY(prev_rngs) ELSE - CALL delete_rng_stream(prev_rngs,error=error) + CALL delete_rng_stream(prev_rngs) prev_rngs => next_rngs END IF NULLIFY(next_rngs) @@ -1596,25 +1560,23 @@ SUBROUTINE helium_rng_state_restore( helium, error ) name="helium_rns_uniform",& last_rng_stream=prev_rngs,& distribution_type=UNIFORM,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) IF ( logger%para_env%mepos .EQ. rank ) THEN helium%rng_stream_uniform => next_rngs END IF - CALL delete_rng_stream(prev_rngs,error=error) + CALL delete_rng_stream(prev_rngs) prev_rngs => next_rngs NULLIFY(next_rngs) CALL create_rng_stream(next_rngs,& name="helium_rns_gaussian",& last_rng_stream=prev_rngs,& distribution_type=GAUSSIAN,& - extended_precision=.TRUE.,& - error=error) + extended_precision=.TRUE.) IF ( logger%para_env%mepos .EQ. rank ) THEN helium%rng_stream_gaussian => next_rngs NULLIFY(prev_rngs) ELSE - CALL delete_rng_stream(prev_rngs,error=error) + CALL delete_rng_stream(prev_rngs) prev_rngs => next_rngs END IF NULLIFY(next_rngs) @@ -1625,29 +1587,29 @@ SUBROUTINE helium_rng_state_restore( helium, error ) ! say what has been done IF ( num_env_restart .NE. logger%para_env%num_pe ) THEN err_str = "Reading RNG state from the input file." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) err_str = "Number of environments in the restart...: '" stmp = "" WRITE(stmp,*) num_env_restart err_str = TRIM(ADJUSTL(err_str)) // TRIM(ADJUSTL(stmp)) // "'." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) err_str = "Number of current run time environments.: '" stmp = "" WRITE(stmp,*) logger%para_env%num_pe err_str = TRIM(ADJUSTL(err_str)) // TRIM(ADJUSTL(stmp)) // "'." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) IF ( num_env_restart .LT. logger%para_env%num_pe ) THEN err_str = "Created some new RNGs from the restarted environments." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) END IF IF ( num_env_restart .GT. logger%para_env%num_pe ) THEN err_str = "Dropped RNG state from some restarted environments." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) END IF err_str = "Done." - CALL helium_write_line(err_str,error) + CALL helium_write_line(err_str) ELSE - CALL helium_write_line("RNG state read from the input file.",error) + CALL helium_write_line("RNG state read from the input file.") END IF NULLIFY(message) @@ -1659,14 +1621,12 @@ END SUBROUTINE helium_rng_state_restore ! *************************************************************************** !> \brief Restore the densities from the input structure. !> \param helium ... -!> \param error ... !> \date 2011-06-22 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_densities_restore( helium, error ) + SUBROUTINE helium_densities_restore( helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_densities_restore', & routineP = moduleN//':'//routineN @@ -1681,14 +1641,14 @@ SUBROUTINE helium_densities_restore( helium, error ) itmp = helium%rho_nbin ALLOCATE(helium%rho_rstr(helium%rho_num,itmp,itmp,itmp),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! assign pointers to the memory locations in the input structure, where ! the old densities are stored and check if the sizes match NULLIFY(message) CALL section_vals_val_get( helium%input, & "MOTION%PINT%HELIUM%RHO%CUBE_DATA%_DEFAULT_KEYWORD_", & - r_vals=message, error=error) + r_vals=message) msglen = SIZE(message) itmp = SIZE(helium%rho_rstr) ltmp = ( msglen .EQ. itmp ) @@ -1708,16 +1668,16 @@ SUBROUTINE helium_densities_restore( helium, error ) itmp = helium%rho_nbin NULLIFY(m,f) ALLOCATE(m(helium%rho_num,itmp,itmp,itmp),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(f(helium%rho_num,itmp,itmp,itmp),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) m(:,:,:,:) = .TRUE. f(:,:,:,:) = 0.0_dp helium%rho_rstr(:,:,:,:) = UNPACK(message(1:msglen), MASK=m, FIELD=f) DEALLOCATE(f,m,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(message) RETURN @@ -1745,39 +1705,37 @@ SUBROUTINE helium_set_solute_indices(helium, pint_env) nelements LOGICAL :: found, my_failure REAL(KIND=dp) :: mass - TYPE(cp_error_type) :: my_error TYPE(cp_subsys_type), POINTER :: my_subsys TYPE(f_env_type), POINTER :: my_f_env TYPE(particle_list_type), POINTER :: my_particles my_failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,my_error,my_failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,my_failure) ! set up my_particles structure NULLIFY(my_f_env, my_subsys, my_particles) CALL f_env_add_defaults(f_env_id=pint_env%replicas%f_env_id, & - f_env=my_f_env, new_error=my_error, failure=my_failure) - CALL force_env_get(force_env=my_f_env%force_env, subsys=my_subsys, & - error=my_error) - CALL cp_subsys_get(my_subsys, particles=my_particles, error=my_error) - CALL f_env_rm_defaults(my_f_env, my_error, istat) - CPPostcondition(istat==0,cp_failure_level,routineP,my_error,my_failure) + f_env=my_f_env,failure=my_failure) + CALL force_env_get(force_env=my_f_env%force_env, subsys=my_subsys) + CALL cp_subsys_get(my_subsys, particles=my_particles) + CALL f_env_rm_defaults(my_f_env,istat) + CPPostcondition(istat==0,cp_failure_level,routineP,my_failure) natoms = helium%solute_atoms NULLIFY(helium%solute_element) ALLOCATE(helium%solute_element(natoms), STAT=istat) - CPPostcondition(istat==0, cp_fatal_level, routineP, my_error, my_failure) + CPPostcondition(istat==0, cp_fatal_level, routineP,my_failure) ! in the worst case there will be as many atomic types as atoms NULLIFY(element) ALLOCATE(element(natoms), STAT=istat) - CPPostcondition(istat==0, cp_fatal_level, routineP, my_error, my_failure) + CPPostcondition(istat==0, cp_fatal_level, routineP,my_failure) ! find out how many different atomic types are there nelements = 0 DO i=1, natoms CALL get_atomic_kind( my_particles%els(i)%atomic_kind, mass=mass) - mnum = NINT(cp_unit_from_cp2k(mass, "amu", error=my_error)) + mnum = NINT(cp_unit_from_cp2k(mass, "amu")) SELECT CASE (mnum) CASE (1) my_element_symbol = "H " @@ -1788,7 +1746,7 @@ SUBROUTINE helium_set_solute_indices(helium, pint_env) CASE DEFAULT WRITE(*,*) "Atomic mass number'", mnum, & "' not supported by the HELIUM code." - CPAssert(.FALSE., cp_failure_level, routineP, my_error, my_failure) + CPAssert(.FALSE., cp_failure_level, routineP,my_failure) END SELECT helium%solute_element(i) = my_element_symbol ! check if this element symbol is already present in element @@ -1805,14 +1763,14 @@ SUBROUTINE helium_set_solute_indices(helium, pint_env) element(nelements) = my_element_symbol END IF END DO - CPPostcondition(nelements.LE.3,cp_fatal_level,routineP,my_error,my_failure) + CPPostcondition(nelements.LE.3,cp_fatal_level,routineP,my_failure) ! allocate the arrays, DEALLOCATE them in helium_release ! (solute_index a bit superfluous at the moment) NULLIFY(helium%solute_number,helium%solute_index) ALLOCATE(helium%solute_number(3), STAT=istat) ALLOCATE(helium%solute_index(3,natoms), STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,my_error,my_failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,my_failure) ! collect atomic indices helium%solute_number(:) = 0 @@ -1830,12 +1788,12 @@ SUBROUTINE helium_set_solute_indices(helium, pint_env) CASE DEFAULT WRITE(*,*) "Atom type '", helium%solute_element(i), & "' not supported by the HELIUM code." - CPAssert(.FALSE., cp_failure_level, routineP, my_error, my_failure) + CPAssert(.FALSE., cp_failure_level, routineP,my_failure) END SELECT END DO DEALLOCATE(element, STAT=istat) - CPPostconditionNoFail(istat==0, cp_warning_level, routineP, my_error) + CPPostconditionNoFail(istat==0, cp_warning_level, routineP) RETURN END SUBROUTINE helium_set_solute_indices @@ -1862,25 +1820,23 @@ SUBROUTINE helium_set_solute_cell(helium, pint_env) INTEGER :: status LOGICAL :: my_failure, my_orthorhombic TYPE(cell_type), POINTER :: my_cell - TYPE(cp_error_type) :: my_error TYPE(f_env_type), POINTER :: my_f_env my_failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,my_error,my_failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,my_failure) ! get the cell structure from pint_env NULLIFY(my_f_env, my_cell) CALL f_env_add_defaults(f_env_id=pint_env%replicas%f_env_id, & - f_env=my_f_env, new_error=my_error, failure=my_failure) - CALL force_env_get(force_env=my_f_env%force_env, cell=my_cell, & - error=my_error) - CALL f_env_rm_defaults(my_f_env, my_error, status) - CPPostcondition(status==0,cp_failure_level,routineP,my_error,my_failure) + f_env=my_f_env,failure=my_failure) + CALL force_env_get(force_env=my_f_env%force_env, cell=my_cell) + CALL f_env_rm_defaults(my_f_env,status) + CPPostcondition(status==0,cp_failure_level,routineP,my_failure) CALL get_cell(my_cell, orthorhombic=my_orthorhombic) IF (.NOT. my_orthorhombic) THEN PRINT *, "Helium solvent not implemented for non-orthorhombic cells." - CPAssert(.FALSE., cp_failure_level, routineP, my_error, my_failure) + CPAssert(.FALSE., cp_failure_level, routineP,my_failure) ELSE helium%solute_cell => my_cell END IF diff --git a/src/motion/helium_sampling.F b/src/motion/helium_sampling.F index a40f86bf72..e5b1ff6f42 100644 --- a/src/motion/helium_sampling.F +++ b/src/motion/helium_sampling.F @@ -59,16 +59,14 @@ MODULE helium_sampling !> \brief Performs MC simulation for helium (only) !> \param helium ... !> \param globenv ... -!> \param error ... !> \date 2009-07-14 !> \author Lukasz Walewski !> \note This routine gets called only when HELIUM_ONLY is set to .TRUE., !> so do not put any property calculations here! ! ***************************************************************************** - SUBROUTINE helium_do_run(helium, globenv, error) + SUBROUTINE helium_do_run(helium, globenv) TYPE(helium_solvent_type), POINTER :: helium TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_do_run', & routineP = moduleN//':'//routineN @@ -78,42 +76,42 @@ SUBROUTINE helium_do_run(helium, globenv, error) TYPE(pint_env_type), POINTER :: pint_env failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) IF (failure) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF NULLIFY(pint_env) NULLIFY(helium%logger) - helium%logger => cp_error_get_logger(error) + helium%logger => cp_get_default_logger() ! create iteration level ! The iteration level 'MD' can be misleading since this is a pure MC ! simulation, however the helium code is meant to be run mainly from PINT. ! We keep it like that for compatibility with PINT+HELIUM simulations. - CALL cp_add_iter_level(helium%logger%iter_info,"MD",error=error) - CALL cp_iterate(helium%logger%iter_info,iter_nr=helium%first_step,error=error) + CALL cp_add_iter_level(helium%logger%iter_info,"MD") + CALL cp_iterate(helium%logger%iter_info,iter_nr=helium%first_step) tot_steps = helium%first_step DO step = 1, helium%num_steps tot_steps = tot_steps + 1 - CALL cp_iterate(helium%logger%iter_info,last=(step==helium%num_steps),iter_nr=tot_steps,error=error) + CALL cp_iterate(helium%logger%iter_info,last=(step==helium%num_steps),iter_nr=tot_steps) helium%current_step = tot_steps - CALL helium_step(helium,pint_env,error) + CALL helium_step(helium,pint_env) ! call write_restart here to avoid interference with PINT write_restart - CALL write_restart(root_section=helium%input,helium_env=helium,error=error) + CALL write_restart(root_section=helium%input,helium_env=helium) ! exit from the main loop if soft exit has been requested - CALL external_control(should_stop,"MD",globenv=globenv,error=error) + CALL external_control(should_stop,"MD",globenv=globenv) IF (should_stop) EXIT END DO ! remove iteration level - CALL cp_rm_iter_level(helium%logger%iter_info,"MD",error=error) + CALL cp_rm_iter_level(helium%logger%iter_info,"MD") RETURN END SUBROUTINE helium_do_run @@ -122,7 +120,6 @@ END SUBROUTINE helium_do_run !> \brief Sample the helium phase space !> \param helium ... !> \param pint_env ... -!> \param error ... !> \date 2009-10-27 !> \author Lukasz Walewski !> \note Samples helium variable space according to multilevel Metropolis @@ -134,11 +131,10 @@ END SUBROUTINE helium_do_run !> everywhere I should. This leads to some redundancy in the case of !> helium-only calculations. ! ***************************************************************************** - SUBROUTINE helium_sample( helium, pint_env, error ) + SUBROUTINE helium_sample( helium, pint_env) TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_sample', & routineP = moduleN//':'//routineN @@ -150,10 +146,10 @@ SUBROUTINE helium_sample( helium, pint_env, error ) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) solute_present = helium%solute_present helium%force_avrg(:,:) = 0.0_dp @@ -177,24 +173,24 @@ SUBROUTINE helium_sample( helium, pint_env, error ) ! 'rotation state' in helium%relrot wich is within (0, helium%beads-1) ! (this is needed to sample different fragments of the permutation ! paths in try_permutations) - rnd = next_random_number(helium%rng_stream_uniform,error=error) + rnd = next_random_number(helium%rng_stream_uniform) nslices = INT(rnd * helium%beads) - CALL helium_rotate(helium,nslices,error) + CALL helium_rotate(helium,nslices) - CALL helium_try_permutations(helium,pint_env,error) + CALL helium_try_permutations(helium,pint_env) ! calculate instantaneous forces on the solute and He properties IF (solute_present) CALL helium_solute_e_f(pint_env, helium, rtmp) CALL helium_calc_energy(helium,pint_env) CALL helium_calc_wnumber( helium ) - CALL helium_calc_plength( helium, error ) - CALL helium_calc_rdf( helium, error ) - IF (helium%rho_present) CALL helium_calc_rho( helium, error ) + CALL helium_calc_plength( helium) + CALL helium_calc_rdf( helium) + IF (helium%rho_present) CALL helium_calc_rho( helium) ! instantaneous force output according to HELIUM%PRINT%FORCES_INST ! Warning: file I/O here may cost A LOT of cpu time! ! switched off here to save cpu - !CALL helium_write_force_inst( helium, error ) + !CALL helium_write_force_inst( helium) ! collect instantaneous values for averaging helium%force_avrg(:,:) = & @@ -214,7 +210,7 @@ SUBROUTINE helium_sample( helium, pint_env, error ) ! restore the original alignment of beads in imaginary time ! (this is useful to make a single bead's position easy to follow ! in the trajectory, otherwise it's index would change every step) - CALL helium_rotate(helium,-helium%relrot, error) + CALL helium_rotate(helium,-helium%relrot) ! actually average the forces and properties over the outer MC loop helium%force_avrg(:,:) = helium%force_avrg(:,:) * inv_iter_rot @@ -247,15 +243,13 @@ END SUBROUTINE helium_sample !> \brief Perform MC step for helium !> \param helium ... !> \param pint_env ... -!> \param error ... !> \date 2009-06-12 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_step( helium, pint_env, error ) + SUBROUTINE helium_step( helium, pint_env) TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_step', & routineP = moduleN//':'//routineN @@ -270,22 +264,22 @@ SUBROUTINE helium_step( helium, pint_env, error ) time_start = m_walltime() failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) ! perform the actual phase space sampling - CALL helium_sample( helium, pint_env, error ) + CALL helium_sample( helium, pint_env) ! write out the averaged properties - CALL helium_write_energy( helium, error ) - CALL helium_write_sdensity( helium, error ) - CALL helium_write_wnumber( helium, error ) - CALL helium_write_plength( helium, error ) - CALL helium_write_rdf( helium, error ) - IF (helium%rho_present) CALL helium_write_rho( helium, error ) - CALL helium_write_perm( helium, error ) - CALL helium_write_accepts( helium, error ) - CALL helium_write_coordinates( helium, error=error ) - CALL helium_write_force( helium, error ) + CALL helium_write_energy( helium) + CALL helium_write_sdensity( helium) + CALL helium_write_wnumber( helium) + CALL helium_write_plength( helium) + CALL helium_write_rdf( helium) + IF (helium%rho_present) CALL helium_write_rho( helium) + CALL helium_write_perm( helium) + CALL helium_write_accepts( helium) + CALL helium_write_coordinates( helium) + CALL helium_write_force( helium) time_stop = m_walltime() time_used = time_stop - time_start @@ -309,13 +303,13 @@ SUBROUTINE helium_step( helium, pint_env, error ) WRITE(stmp, '(F20.1)') time_used msgstr = TRIM(ADJUSTL(msgstr)) // " " // TRIM(ADJUSTL(stmp)) msgstr = TRIM(ADJUSTL(msgstr)) // " " // TRIM(ADJUSTL(time_unit)) // "." - CALL helium_write_line(TRIM(msgstr), error) + CALL helium_write_line(TRIM(msgstr)) ! print out the total energy - for regtest evaluation stmp = "" WRITE(stmp, *) helium%energy_avrg(e_id_total) msgstr = "Total energy = " // TRIM(ADJUSTL(stmp)) - CALL helium_write_line(TRIM(msgstr), error) + CALL helium_write_line(TRIM(msgstr)) CALL timestop(handle) @@ -326,15 +320,13 @@ END SUBROUTINE helium_step !> \brief ... !> \param helium ... !> \param pint_env - path integral environment -!> \param error - error handling (see module cp_error_handling) !> \par History !> 2010-06-17 ratio for m-value added (m-sampling related) [lwalewski] !> \author hforbert ! ***************************************************************************** - SUBROUTINE helium_try_permutations(helium, pint_env, error) + SUBROUTINE helium_try_permutations(helium, pint_env) TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'helium_try_permutations', & routineP = moduleN//':'//routineN @@ -342,7 +334,7 @@ SUBROUTINE helium_try_permutations(helium, pint_env, error) INTEGER :: ncycles, ni, nselected, res REAL(KIND=dp) :: r, rnd, x - IF (helium%maxcycle>1) CALL helium_update_transition_matrix(helium,error) + IF (helium%maxcycle>1) CALL helium_update_transition_matrix(helium) helium%work(:,:,:)=helium%pos(:,:,:) ! the inner MC loop (without rotation in imaginary time) @@ -352,12 +344,12 @@ SUBROUTINE helium_try_permutations(helium, pint_env, error) r = 1.0_dp / ( 1.0_dp + (helium%maxcycle-1)/helium%m_ratio ) ! draw permutation length for this trial from the distribution of choice - x = next_random_number(helium%rng_stream_uniform,error=error) + x = next_random_number(helium%rng_stream_uniform) IF ( x .LT. r ) THEN ncycles = helium%m_value ELSE DO - x = next_random_number(helium%rng_stream_uniform,error=error) + x = next_random_number(helium%rng_stream_uniform) ncycles = INT(helium%maxcycle*x)+1 IF ( ncycles .NE. helium%m_value ) EXIT END DO @@ -369,18 +361,18 @@ SUBROUTINE helium_try_permutations(helium, pint_env, error) ! check, if permutation of this length can be constructed IF (ncycles == 1) THEN - rnd = next_random_number(helium%rng_stream_uniform,error=error) + rnd = next_random_number(helium%rng_stream_uniform) helium%ptable(1)=1+INT(rnd*helium%atoms) helium%ptable(2)=-1 helium%pweight=0.0_dp nselected = 1 ELSE - nselected = helium_select_permutation(helium,ncycles,error) + nselected = helium_select_permutation(helium,ncycles) END IF IF (nselected /= 0) THEN ! the permutation was successfully selected - actually sample this permutation - res = helium_slice_metro_cyclic(helium, pint_env, ncycles, error) + res = helium_slice_metro_cyclic(helium, pint_env, ncycles) END IF END DO @@ -393,15 +385,13 @@ END SUBROUTINE helium_try_permutations !> \param helium ... !> \param pint_env ... !> \param n ... -!> \param error ... !> \retval res 1 - if the MC move was accepted, 0 - otherwise !> \author hforbert ! ***************************************************************************** - FUNCTION helium_slice_metro_cyclic(helium,pint_env,n,error) RESULT(res) + FUNCTION helium_slice_metro_cyclic(helium,pint_env,n) RESULT(res) TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env INTEGER, INTENT(IN) :: n - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: res INTEGER :: c, hbeads, i, j, k, l, level, & @@ -496,7 +486,7 @@ FUNCTION helium_slice_metro_cyclic(helium,pint_env,n,error) RESULT(res) CALL helium_boxmean_3d( helium, work(:,p(k),pk1), work(:,p(k),pk2), tmp1 ) DO c = 1, 3 x = next_random_number(rng_stream=helium%rng_stream_gaussian,& - variance=1.0_dp,error=error) + variance=1.0_dp) x = sigma * x tmp1(c) = tmp1(c) + x tmp2(c) = x @@ -523,7 +513,7 @@ FUNCTION helium_slice_metro_cyclic(helium,pint_env,n,error) RESULT(res) CALL helium_boxmean_3d( helium, work(:,p(k),pk1), work(:,perm(p(1+MOD(k,n))),1), tmp1 ) DO c = 1, 3 x = next_random_number(rng_stream=helium%rng_stream_gaussian,& - variance=1.0_dp,error=error) + variance=1.0_dp) x = sigma * x tmp1(c) = tmp1(c) + x tmp2(c) = x @@ -605,7 +595,7 @@ FUNCTION helium_slice_metro_cyclic(helium,pint_env,n,error) RESULT(res) ds = ds - x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) END DO ! ok now accept or reject: - tmp = next_random_number(helium%rng_stream_uniform,error=error) + tmp = next_random_number(helium%rng_stream_uniform) ! IF ((dtk+ds-pds < 0.0_dp).AND.(EXP(dtk+ds-pds) \brief ... !> \param helium ... !> \param len ... -!> \param error ... !> \retval res 1 - if the permutation was successfully selected, 0 - otherwise !> \author hforbert ! ***************************************************************************** - FUNCTION helium_select_permutation(helium,len,error) RESULT(res) + FUNCTION helium_select_permutation(helium,len) RESULT(res) TYPE(helium_solvent_type), POINTER :: helium INTEGER, INTENT(IN) :: len - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: res INTEGER :: i, j, k, n @@ -850,10 +838,10 @@ FUNCTION helium_select_permutation(helium,len,error) RESULT(res) nmatrix => helium%nmatrix p(len+1)=-1 - rnd = next_random_number(helium%rng_stream_uniform,error=error) + rnd = next_random_number(helium%rng_stream_uniform) p(1) = INT(n*rnd)+1 DO k = 1, len - 1 - t = next_random_number(helium%rng_stream_uniform,error=error) + t = next_random_number(helium%rng_stream_uniform) ! find the corresponding path to connect to ! using the precalculated optimal decision tree: i = n-1 @@ -881,7 +869,7 @@ FUNCTION helium_select_permutation(helium,len,error) RESULT(res) s1 = s1 + ipmatrix(p(len),perm(p(1))) s2 = s2 + ipmatrix(p(len),perm(p(len))) ! final accept/reject: - rnd = next_random_number(helium%rng_stream_uniform,error=error) + rnd = next_random_number(helium%rng_stream_uniform) t = s1*rnd IF (t > s2) RETURN ! ok, we have accepted the permutation diff --git a/src/motion/input_cp2k_md.F b/src/motion/input_cp2k_md.F index 1be04ac4d7..d750ad5a4f 100644 --- a/src/motion/input_cp2k_md.F +++ b/src/motion/input_cp2k_md.F @@ -58,13 +58,10 @@ MODULE input_cp2k_md ! ***************************************************************************** !> \brief ... !> \param section will contain the md section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_md_section(section,error) + SUBROUTINE create_md_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_md_section', & routineP = moduleN//':'//routineN @@ -75,11 +72,10 @@ SUBROUTINE create_md_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MD",& description="This section defines the whole set of parameters needed perform an MD run.",& - n_keywords=13, n_subsections=6, repeats=.FALSE., & - error=error) + n_keywords=13, n_subsections=6, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="ensemble",& @@ -106,50 +102,50 @@ SUBROUTINE create_md_section(section,error) enum_i_vals=(/nve_ensemble,nvt_ensemble,npt_i_ensemble,npt_f_ensemble,& nph_uniaxial_ensemble,nph_uniaxial_damped_ensemble,nph_ensemble,isokin_ensemble,& reftraj_ensemble,langevin_ensemble, npe_f_ensemble, npe_i_ensemble, & - nvt_adiabatic_ensemble/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + nvt_adiabatic_ensemble/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="steps",& description="The number of MD steps to perform",& - usage="steps 100", default_i_val=3,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="steps 100", default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="timestep",& description="The length of an integration step (in case RESPA the large TIMESTEP)",& - usage="timestep 1.0",default_r_val=cp_unit_to_cp2k(value=0.5_dp,unit_str="fs",error=error),& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="timestep 1.0",default_r_val=cp_unit_to_cp2k(value=0.5_dp,unit_str="fs"),& + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="step_start_val",& description="The starting step value for the MD",usage="step_start_val ",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="time_start_val",& description="The starting timer value for the MD",& - usage="time_start_val ",default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="fs",error=error),& - unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="time_start_val ",default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="fs"),& + unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="econs_start_val",& description="The starting value of the conserved quantity",& usage="econs_start_val ",default_r_val=0.0_dp,& - unit_str="hartree",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="hartree") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="temperature",& description="The temperature in K used to initialize "//& "the velocities with init and pos restart, and in the NPT/NVT simulations",& - usage="temperature 325.0",default_r_val=cp_unit_to_cp2k(value=300.0_dp,unit_str="K",error=error),& - unit_str="K",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="temperature 325.0",default_r_val=cp_unit_to_cp2k(value=300.0_dp,unit_str="K"),& + unit_str="K") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="temp_tol",& variants=s2a("temp_to","temperature_tolerance"),& @@ -158,40 +154,38 @@ SUBROUTINE create_md_section(section,error) "is performed. If it is 0 no rescaling is performed. NOTE: This keyword is "//& "obsolescent; Using a CSVR thermostat with a short timeconstant is "//& "recommended as a better alternative.", & - usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="temp_kind",& description="Compute the temperature per each kind separately",& usage="temp_kind LOGICAL",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="scale_temp_kind",& description="When necessary rescale the temperature per each kind separately",& usage="scale_temp_kind LOGICAL",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="comvel_tol",& description="The maximum accepted velocity of the center of mass. "//& "With Shell-Model, comvel may drift if MD%THERMOSTAT%REGION /= GLOBAL ", & - usage="comvel_tol 0.1", type_of_var=real_t, n_var=1, unit_str="bohr*au_t^-1",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="comvel_tol 0.1", type_of_var=real_t, n_var=1, unit_str="bohr*au_t^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="angvel_tol",& description="The maximum accepted angular velocity. This option is ignored "//& "when the system is periodic. Removes the components of the velocities that"//& "project on the external rotational degrees of freedom.",& - usage="angvel_tol 0.1", type_of_var=real_t, n_var=1, unit_str="bohr*au_t^-1",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="angvel_tol 0.1", type_of_var=real_t, n_var=1, unit_str="bohr*au_t^-1") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="angvel_zero",& description="Set the initial angular velocity to zero. This option is ignored "//& @@ -199,25 +193,25 @@ SUBROUTINE create_md_section(section,error) "the part of the random initial velocities that projects on the external "//& "rotational degrees of freedom is subtracted.",& usage="angvel_zero LOGICAL",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ANNEALING",& description="Specifies the rescaling factor for annealing velocities. "//& "Automatically enables the annealing procedure. This scheme works only for ensembles "//& "that do not have thermostats on particles.", & - usage="annealing ", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="annealing ", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ANNEALING_CELL",& description="Specifies the rescaling factor for annealing velocities of the CELL "//& "Automatically enables the annealing procedure for the CELL. This scheme works only "//& "for ensambles that do not have thermostat on CELLS velocities.", & - usage="ANNEALING_CELL ", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ANNEALING_CELL ", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPLACEMENT_TOL",& description="This keyword sets a maximum atomic displacement "//& @@ -226,61 +220,61 @@ SUBROUTINE create_md_section(section,error) "within the assigned limit, the time step is rescaled accordingly,"//& "and the first half step of the velocity verlet is repeated.",& usage="DISPLACEMENT_TOL ", default_r_val=100.0_dp,& - unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_langevin_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_langevin_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_msst_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_msst_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_barostat_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_barostat_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_thermostat_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_thermostat_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_respa_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_respa_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_shell_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_shell_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_adiabatic_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_adiabatic_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_softening_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_softening_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_reftraj_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_reftraj_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_avgs_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection, error=error) + CALL create_avgs_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_thermal_region_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection, error=error) + CALL create_thermal_region_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_md_print_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection, error=error) + CALL create_md_print_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_cascade_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection, error=error) + CALL create_cascade_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_md_section @@ -288,13 +282,10 @@ END SUBROUTINE create_md_section ! ***************************************************************************** !> \brief Defines LANGEVIN section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_langevin_section(section, error) + SUBROUTINE create_langevin_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_langevin_section', & routineP = moduleN//':'//routineN @@ -304,7 +295,7 @@ SUBROUTINE create_langevin_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="Langevin",& description="Controls the set of parameters to run a Langevin MD. "//& "The integrator used follows that given in the article by Ricci et al. "//& @@ -315,44 +306,41 @@ SUBROUTINE create_langevin_section(section, error) "Langevin MD involving sub-regions can be found in articles by "//& "Kantorovitch et al. All the references can be found in the links below.",& citations=(/Ricci2003, Kantorovich2008, Kantorovich2008a/),& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="gamma",& description="Gamma parameter for the Langevin dynamics (LD)",& usage="gamma 0.001",& - default_r_val=0.0_dp, unit_str='fs^-1',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp, unit_str='fs^-1') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Noisy_Gamma",& variants=(/"NoisyGamma"/), & description="Imaginary Langevin Friction term for LD with noisy forces.",& citations=(/Kuhne2007/),& - usage="Noisy_Gamma 4.0E-5", default_r_val=0.0_dp, unit_str='fs^-1', error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="Noisy_Gamma 4.0E-5", default_r_val=0.0_dp, unit_str='fs^-1') + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Shadow_Gamma",& variants=(/"ShadowGamma"/), & description="Shadow Langevin Friction term for LD with noisy forces in order to adjust Noisy_Gamma.", & citations=(/Kuhne2007/),& - usage="Shadow_Gamma 0.001", default_r_val=0.0_dp, unit_str='fs^-1', error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + usage="Shadow_Gamma 0.001", default_r_val=0.0_dp, unit_str='fs^-1') + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) END SUBROUTINE create_langevin_section ! ***************************************************************************** !> \brief Defines print section for MD !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_md_print_section(section, error) + SUBROUTINE create_md_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_md_print_section', & routineP = moduleN//':'//routineN @@ -363,10 +351,10 @@ SUBROUTINE create_md_print_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="print",& description="Controls the printing properties during an MD run",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(print_key, keyword) CALL keyword_create(keyword, name="FORCE_LAST",& @@ -375,87 +363,83 @@ SUBROUTINE create_md_print_section(section, error) "to be present for the specific print key (in case the last step should not "//& "match with the print_key iteration number).",& usage="FORCE_LAST LOGICAL",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"ENERGY",& description="Controls the output the ener file",& print_level=low_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SHELL_ENERGY",& description="Controls the output of the shell-energy file (only if shell-model)",& print_level=medium_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"TEMP_KIND",& description="Controls the output of the temperature"//& " computed separately for each kind",& print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"TEMP_SHELL_KIND",& description="Controls the output of the temperature of the"//& " shell-core motion computed separately for each kind",& print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CENTER_OF_MASS",& description="Controls the printing of COM velocity during an MD", & print_level=medium_print_level,common_iter_levels=1,& - filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"COEFFICIENTS",& description="Controls the printing of coefficients during an MD run.", & print_level=medium_print_level,common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ROTATIONAL_INFO",& description="Controls the printing basic info during the calculation of the "//& "translational/rotational degrees of freedom.", print_level=low_print_level,& - add_last=add_last_numeric,filename="__STD_OUT__",error=error) + add_last=add_last_numeric,filename="__STD_OUT__") CALL keyword_create(keyword, name="COORDINATES",& description="Prints atomic coordinates in the standard orientation. "//& "Coordinates are not affected during the calculation.",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of basic and summary information during the"//& " Molecular Dynamics", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_md_print_section ! ***************************************************************************** !> \brief Defines parameters for RESPA integration scheme !> \param section will contain the coeff section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_respa_section(section, error) + SUBROUTINE create_respa_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_respa_section', & routineP = moduleN//':'//routineN @@ -465,7 +449,7 @@ SUBROUTINE create_respa_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RESPA",& description="Multiple timestep integration based on RESPA (implemented for NVE only)."//& @@ -476,15 +460,14 @@ SUBROUTINE create_respa_section(section, error) " subsys in the force_eval corresponding at the first index in the multiple_force_eval list."//& " Can be used to speedup classical and ab initio MD simulations.",& n_keywords=1, n_subsections=0, repeats=.FALSE., & - citations=(/Tuckerman1992,Guidon2008/),& - error=error) + citations=(/Tuckerman1992,Guidon2008/)) NULLIFY(keyword) CALL keyword_create(keyword, name="FREQUENCY",& description="The number of reference MD steps between two RESPA corrections.",& - usage="FREQUENCY ", default_i_val=5,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FREQUENCY ", default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_respa_section @@ -492,13 +475,10 @@ END SUBROUTINE create_respa_section ! ***************************************************************************** !> \brief Defines parameters for REFTRAJ analysis !> \param section will contain the coeff section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_reftraj_section(section, error) + SUBROUTINE create_reftraj_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_reftraj_section', & routineP = moduleN//':'//routineN @@ -509,97 +489,93 @@ SUBROUTINE create_reftraj_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="REFTRAJ",& description="Loads an external trajectory file and performs analysis on the"//& " loaded snapshots.",& - n_keywords=1, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword, print_key, subsection) CALL keyword_create(keyword, name="TRAJ_FILE_NAME",& description="Specify the filename where the trajectory is stored.",repeats=.FALSE.,& - usage="TRAJ_FILE_NAME ", default_lc_val="reftraj.xyz", & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TRAJ_FILE_NAME ", default_lc_val="reftraj.xyz") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CELL_FILE_NAME",& description="Specify the filename where the cell is stored "//& "(for trajectories generated within variable cell ensembles).",repeats=.FALSE.,& - usage="CELL_FILE_NAME ", default_lc_val="reftraj.cell", & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CELL_FILE_NAME ", default_lc_val="reftraj.cell") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VARIABLE_VOLUME",& description="Enables the possibility to read a CELL file with information on the CELL size during the MD.",& - repeats=.FALSE., default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FIRST_SNAPSHOT",& description="Index of the snapshot stored in the trajectory file "//& "from which to start a REFTRAJ run",& - repeats=.FALSE., usage="FIRST_SNAPSHOT ", default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="FIRST_SNAPSHOT ", default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LAST_SNAPSHOT",& description="Index of the last snapshot stored in the trajectory file that is read along a REFTRAJ run",& - repeats=.FALSE., usage="LAST_SNAPSHOT", default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="LAST_SNAPSHOT", default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STRIDE",& description=" Stride in number of snapshot for the reftraj analysis",& - repeats=.FALSE., usage="STRIDE", default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="STRIDE", default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="eval_energy_forces",& description="Evaluate energy and forces for each retrieved snapshot during a REFTRAJ run",& - repeats=.FALSE., default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_msd_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_msd_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL section_create(subsection,name="print",& description="The section that controls the output of a reftraj run",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"msd_kind",& description="Controls the output of msd per kind", & print_level=low_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"msd_molecule",& description="Controls the output of msd per molecule kind", & print_level=low_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"displaced_atom",& description="Controls the output of index and dislacement of "//& "atoms that moved away from the initial position of more than a"//& "given distance (see msd%disp_tol)", & print_level=low_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection, error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_reftraj_section @@ -607,13 +583,10 @@ END SUBROUTINE create_reftraj_section ! ***************************************************************************** !> \brief Defines parameters for MSD calculation along a REFTRAJ analysis !> \param section will contain the coeff section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MI ! ***************************************************************************** - SUBROUTINE create_msd_section(section, error) + SUBROUTINE create_msd_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_msd_section', & routineP = moduleN//':'//routineN @@ -624,12 +597,12 @@ SUBROUTINE create_msd_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MSD",& description="Loads an external trajectory file and performs analysis on the"//& " loaded snapshots.",& - n_keywords=3, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=3, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -637,58 +610,56 @@ SUBROUTINE create_msd_section(section, error) description="controls the activation of core-level spectroscopy simulations",& usage="&MSD T",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REF0_FILENAME",& description="Specify the filename where the initial reference configuration is stored.",& - repeats=.FALSE., usage="REF0_FILENAME ", default_lc_val="", & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., usage="REF0_FILENAME ", default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="MSD_PER_KIND",& description="Set up the calculation of the MSD for each atomic kind",& usage="MSD_PER_KIND ",repeats=.FALSE.,& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="MSD_PER_MOLKIND",& description="Set up the calculation of the MSD for each molecule kind."//& "The position of the center of mass of the molecule is considered.",& usage="MSD_PER_MOLKIND ",repeats=.FALSE.,& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="MSD_PER_REGION",& description="Set up the calculation of the MSD for each defined region.",& usage="MSD_PER_REGION ",repeats=.FALSE.,& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_region_section(subsection,"MSD calculation",error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_region_section(subsection,"MSD calculation") + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword,name="DISPLACED_ATOM",& description="Identify the atoms that moved from their initial"//& "position of a distance larger than a given tolerance (see msd%displacement_tol).",& usage="DISPLACED_ATOM ",repeats=.FALSE.,& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="displacement_tol",& description="Lower limit to define displaced atoms",& usage="DISPLACEMENT_TOL real",& - default_r_val=0._dp, n_var=1, unit_str='bohr', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp, n_var=1, unit_str='bohr') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_msd_section @@ -697,13 +668,10 @@ END SUBROUTINE create_msd_section ! ***************************************************************************** !> \brief ... !> \param section will contain the coeff section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_msst_section(section, error) + SUBROUTINE create_msst_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_msst_section', & routineP = moduleN//':'//routineN @@ -713,58 +681,57 @@ SUBROUTINE create_msst_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="msst",& description="Parameters for Multi-Scale Shock Technique (MSST) "//& "which simulate the effect of a steady planar shock on a unit cell. "//& "Reed et. al. Physical Review Letters 90, 235503 (2003).",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword ) CALL keyword_create(keyword, name="PRESSURE",& description="Initial pressure",& usage="PRESSURE real",& - default_r_val=0._dp, n_var=1, unit_str='bar', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp, n_var=1, unit_str='bar') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY",& description="Initial energy",& usage="ENERGY real",& - default_r_val=0._dp, n_var=1, unit_str='hartree',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp, n_var=1, unit_str='hartree') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VOLUME",& description="Initial volume",& usage="VOLUME real",& - default_r_val=0._dp, n_var=1, unit_str='angstrom^3',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp, n_var=1, unit_str='angstrom^3') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CMASS",& description="Effective cell mass",& usage="CMASS real",& - default_r_val=0._dp, n_var=1,unit_str='au_m',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp, n_var=1,unit_str='au_m') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VSHOCK",variants=(/"V_SHOCK"/),& description="Velocity shock",& usage="VSHOCK real",& - default_r_val=0._dp, n_var=1,unit_str='m/s',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp, n_var=1,unit_str='m/s') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GAMMA",& description="Damping coefficient for cell volume",& usage="GAMMA real",& unit_str='fs^-1', & - default_r_val=0.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_msst_section @@ -772,12 +739,9 @@ END SUBROUTINE create_msst_section ! ***************************************************************************** !> \brief section will contain some parameters for the shells dynamics !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE create_shell_section(section, error) + SUBROUTINE create_shell_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_shell_section', & routineP = moduleN//':'//routineN @@ -788,11 +752,11 @@ SUBROUTINE create_shell_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="shell",& description="Parameters of shell model in adiabatic dynamics.",& - n_keywords=4, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=4, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword,thermo_section) @@ -800,26 +764,26 @@ SUBROUTINE create_shell_section(section, error) description="Temperature in K used to control "//& "the internal velocities of the core-shell motion ",& usage="temperature 5.0",& - default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K",error=error),& - unit_str="K", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K"),& + unit_str="K") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="temp_tol",& description="Maximum accepted temperature deviation"//& " from the expected value, for the internal core-shell motion."//& "If 0, no rescaling is performed", & - usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="nose_particle",& description="If nvt or npt, the core and shell velocities are controlled "//& "by the same thermostat used for the particle. This might favour heat exchange "//& "and additional rescaling of the internal core-shell velocity is needed (TEMP_TOL)",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISPLACEMENT_SHELL_TOL",& description="This keyword sets a maximum variation of the shell "//& @@ -829,13 +793,13 @@ SUBROUTINE create_shell_section(section, error) "within the assigned limit, the time step is rescaled accordingly,"//& "and the first half step of the velocity verlet is repeated.",& usage="DISPLACEMENT_SHELL_TOL ", default_r_val=100.0_dp,& - unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_thermostat_section(thermo_section, error=error) - CALL section_add_subsection(section, thermo_section, error=error) - CALL section_release(thermo_section,error=error) + CALL create_thermostat_section(thermo_section) + CALL section_add_subsection(section, thermo_section) + CALL section_release(thermo_section) END SUBROUTINE create_shell_section @@ -843,12 +807,9 @@ END SUBROUTINE create_shell_section ! ***************************************************************************** !> \brief section will contain some parameters for the adiabatic dynamics !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE create_adiabatic_section(section, error) + SUBROUTINE create_adiabatic_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_adiabatic_section', & routineP = moduleN//':'//routineN @@ -860,13 +821,12 @@ SUBROUTINE create_adiabatic_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="ADIABATIC_DYNAMICS",& description="Parameters used in canonical adiabatic free energy sampling (CAFES).",& n_keywords=5, n_subsections=2, repeats=.FALSE.,& - citations=(/VandeVondele2002/),& - error=error) + citations=(/VandeVondele2002/)) NULLIFY(keyword,thermo_fast_section,thermo_slow_section) @@ -874,50 +834,50 @@ SUBROUTINE create_adiabatic_section(section, error) description="Temperature in K used to control "//& "the fast degrees of freedom ",& usage="temp_fast 5.0",& - default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K",error=error),& - unit_str="K", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K"),& + unit_str="K") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="temp_slow",& description="Temperature in K used to control "//& "the slow degrees of freedom ",& usage="temp_slow 5.0",& - default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K",error=error),& - unit_str="K", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K"),& + unit_str="K") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="temp_tol_fast",& description="Maximum accepted temperature deviation"//& " from the expected value, for the fast motion."//& "If 0, no rescaling is performed", & - usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="temp_tol_slow",& description="Maximum accepted temperature deviation"//& " from the expected value, for the slow motion."//& "If 0, no rescaling is performed", & - usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="temp_tol 0.0", default_r_val=0.0_dp, unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="n_resp_fast",& description="number of respa steps for fast degrees of freedom",& - repeats=.FALSE., default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_thermo_fast_section(thermo_fast_section, error=error) - CALL section_add_subsection(section, thermo_fast_section, error=error) - CALL section_release(thermo_fast_section,error=error) + CALL create_thermo_fast_section(thermo_fast_section) + CALL section_add_subsection(section, thermo_fast_section) + CALL section_release(thermo_fast_section) - CALL create_thermo_slow_section(thermo_slow_section, error=error) - CALL section_add_subsection(section, thermo_slow_section, error=error) - CALL section_release(thermo_slow_section,error=error) + CALL create_thermo_slow_section(thermo_slow_section) + CALL section_add_subsection(section, thermo_slow_section) + CALL section_release(thermo_slow_section) END SUBROUTINE create_adiabatic_section @@ -925,12 +885,10 @@ END SUBROUTINE create_adiabatic_section ! ***************************************************************************** !> \brief section will contain parameters for the velocity softening !> \param section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE create_softening_section(section, error) + SUBROUTINE create_softening_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_softening_section', & routineP = moduleN//':'//routineN @@ -946,27 +904,27 @@ SUBROUTINE create_softening_section(section, error) //"of the original velocities v. The velocities are then updated with "& //"the force component F_t, which is perpendicular to N. "& //"N = v / |v|; y = x + delta * N; F_t = F(y) - ⟨ F(y) | N ⟩ * N; "& - //"v' = v + alpha * F_t", error=error) + //"v' = v + alpha * F_t") NULLIFY(keyword) CALL keyword_create(keyword=keyword, name="STEPS",& description="Number of softening iterations performed. "& //"Typical values are around 40 steps.",& - default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="DELTA",& description="Displacement used to obtain y.",& - default_r_val=0.1_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.1_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="ALPHA",& description="Mixing factor used for updating velocities.",& - default_r_val=0.15_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.15_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_softening_section @@ -975,14 +933,12 @@ END SUBROUTINE create_softening_section !> \brief input section used to define regions with different temperature !> initialization and control !> \param section ... -!> \param error ... !> \par History !> - Added input for langevin regions in thermal regions section !> (2014/02/04, LT) ! ***************************************************************************** - SUBROUTINE create_thermal_region_section(section,error) + SUBROUTINE create_thermal_region_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_thermal_region_section', & @@ -995,7 +951,7 @@ SUBROUTINE create_thermal_region_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="thermal_region", & description="Define regions where different initialization and control "//& @@ -1005,7 +961,7 @@ SUBROUTINE create_thermal_region_section(section,error) "The theory behind Langevin MD using different regions can be found in "//& "articles by Kantorovitch et al. listed below.", & citations=(/Kantorovich2008, Kantorovich2008a/), & - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) NULLIFY(region_section) NULLIFY(keyword,subsection) @@ -1014,83 +970,82 @@ SUBROUTINE create_thermal_region_section(section,error) description="Control the rescaling ot the velocities in all the regions, "//& "according to the temperature assigned to each reagion, when "//& "RESTART_VELOCITY in EXT_RESTART is active.", & - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword, name="do_langevin_default", & description="If ENSEMBLE is set to LANGEVIN, controls whether the "//& "atoms NOT defined in the thermal regions to undergo langevin MD "//& "or not. If not, then the atoms will undergo NVE Born-Oppenheimer MD.", & usage="do_langevin_default .FALSE.", & - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL section_create(region_section,name="DEFINE_REGION",& description="This section provides the possibility to define arbitrary region ", & - n_keywords=3, n_subsections=0, repeats=.TRUE., error=error) + n_keywords=3, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="LIST",& description="Specifies a list of atoms belonging to the region.",& usage="LIST {integer} {integer} .. {integer}", & - repeats=.TRUE., n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(region_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.TRUE., n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(region_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="temperature",& description="The temperature in K used to initialize the velocities "//& "of the atoms in this region ", & usage="temperature 5.0", & - default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K",error=error), & - unit_str="K", error=error) - CALL section_add_keyword(region_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(value=0.0_dp,unit_str="K"), & + unit_str="K") + CALL section_add_keyword(region_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="temp_tol",& description="Maximum accepted temperature deviation from the expected "//& "value for this region. If temp_tol=0 no rescaling is performed", & usage="temp_tol 0.0", & - default_r_val=0.0_dp, unit_str='K', error=error) - CALL section_add_keyword(region_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp, unit_str='K') + CALL section_add_keyword(region_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="do_langevin", & description="When ENSEMBLE is set to LANGEVIN, Controls whether "//& "the atoms in the thermal region should undergo Langevin MD. If "//& "not, then they will undergo NVE Born-Oppenheimer MD.", & usage="do_langevin .TRUE.",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(region_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(region_section, keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section, region_section, error=error) - CALL section_release(region_section,error=error) + CALL section_add_subsection(section, region_section) + CALL section_release(region_section) NULLIFY(print_key) CALL section_create(subsection,name="PRINT",& description="Collects all print_keys for thermal_regions",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"TEMPERATURE",& description="Controls output of temperature per region.", & print_level=high_print_level, common_iter_levels=1, & - filename="", error=error) - CALL section_add_subsection(subsection,print_key, error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"LANGEVIN_REGIONS",& description="Controls output of information on which atoms "//& "underwent Langevin MD and which atoms did not.", & print_level=high_print_level, & - filename="", error=error) - CALL section_add_subsection(subsection, print_key, error=error) - CALL section_release(print_key, error=error) + filename="") + CALL section_add_subsection(subsection, print_key) + CALL section_release(print_key) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_thermal_region_section @@ -1099,16 +1054,13 @@ END SUBROUTINE create_thermal_region_section ! ***************************************************************************** !> \brief Defines the parameters for the setup of a cascade simulation !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 03.02.2012 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE create_cascade_section(section,error) + SUBROUTINE create_cascade_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_cascade_section', & routineP = moduleN//':'//routineN @@ -1120,41 +1072,37 @@ SUBROUTINE create_cascade_section(section,error) failure = .FALSE. NULLIFY (keyword) NULLIFY (subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CASCADE",& description="Defines the parameters for the setup of a cascade simulation.",& n_keywords=1,& n_subsections=1,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) CALL keyword_create(keyword,& name="_SECTION_PARAMETERS_",& description="Controls the activation of the CASCADE section.",& usage="&CASCADE on",& default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY",& description="Total energy transferred to the system during the cascade event.",& usage="ENERGY 20.0",& default_r_val=0.0_dp,& - unit_str="keV",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="keV") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="ATOM_LIST",& description="Defines a list of atoms for which the initial velocities are modified",& n_keywords=1,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Defines the list of atoms for which the velocities are modified. "//& @@ -1165,13 +1113,12 @@ SUBROUTINE create_cascade_section(section,error) "Weight

    ",& usage="{{Integer} {Real} {Real} {Real} {Real}}",& repeats=.TRUE.,& - type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=lchar_t) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_cascade_section @@ -1180,13 +1127,10 @@ END SUBROUTINE create_cascade_section ! ***************************************************************************** !> \brief Defines AVERAGES section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_avgs_section(section, error) + SUBROUTINE create_avgs_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_avgs_section', & routineP = moduleN//':'//routineN @@ -1196,57 +1140,53 @@ SUBROUTINE create_avgs_section(section, error) TYPE(section_type), POINTER :: print_key, subsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="Averages",& description="Controls the calculation of the averages during an MD run.",& - n_keywords=1, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword, print_key, subsection) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Controls the calculations of the averages.",& - usage="&AVERAGES T",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="&AVERAGES T",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ACQUISITION_START_TIME",& description="Setup up the simulation time when the acquisition process to compute "//& " averages is started.",& usage="ACQUISITION_START_TIME ",& - default_r_val=0.0_dp, unit_str='fs',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0_dp, unit_str='fs') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVERAGE_COLVAR",& description="Switch for computing the averages of COLVARs.", & usage="AVERAGE_COLVAR ", default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section, keyword, error=error) - CALL keyword_release(keyword, error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section, keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"PRINT_AVERAGES",& description="Controls the output the averaged quantities",& print_level=debug_print_level+1, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) - CALL create_avgs_restart_section(subsection, error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection, error=error) + CALL create_avgs_restart_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_avgs_section ! ***************************************************************************** !> \brief Defines the AVERAGES RESTART section !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_avgs_restart_section(section, error) + SUBROUTINE create_avgs_restart_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_avgs_restart_section', & routineP = moduleN//':'//routineN @@ -1255,174 +1195,173 @@ SUBROUTINE create_avgs_restart_section(section, error) TYPE(keyword_type), POINTER :: keyword failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RESTART_AVERAGES",& description="Stores information for restarting averages.",& - n_keywords=1, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="ITIMES_START",& description="TIME STEP starting the evaluation of averages",& - usage="ITIMES_START ",type_of_var=integer_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ITIMES_START ",type_of_var=integer_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVECPU",& description="CPU average",usage="AVECPU ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEHUGONIOT",& description="HUGONIOT average",usage="AVEHUGONIOT ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVETEMP_BARO",& description="BAROSTAT TEMPERATURE average",usage="AVETEMP_BARO ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEPOT",& description="POTENTIAL ENERGY average",usage="AVEPOT ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEKIN",& description="KINETIC ENERGY average",usage="AVEKIN ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVETEMP",& description="TEMPERATURE average",usage="AVETEMP ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEKIN_QM",& description="QM KINETIC ENERGY average in QMMM runs",usage="AVEKIN_QM ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVETEMP_QM",& description="QM TEMPERATURE average in QMMM runs",usage="AVETEMP_QM ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEVOL",& description="VOLUME average",usage="AVEVOL ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVECELL_A",& description="CELL VECTOR A average",usage="AVECELL_A ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVECELL_B",& description="CELL VECTOR B average",usage="AVECELL_B ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVECELL_C",& description="CELL VECTOR C average",usage="AVECELL_C ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEALPHA",& description="ALPHA cell angle average",usage="AVEALPHA ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEBETA",& description="BETA cell angle average",usage="AVEBETA ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVEGAMMA",& description="GAMMA cell angle average",usage="AVEGAMMA ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_ECONS",& description="CONSTANT ENERGY average",usage="AVE_ECONS ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PRESS",& description="PRESSURE average",usage="AVE_PRESS ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PXX",& description="P_{XX} average",usage="AVE_PXX ",& - type_of_var=real_t,n_var=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t,n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PV_VIR",& description="PV VIRIAL average",usage="AVE_PV_VIR .. ",& - type_of_var=real_t, n_var=9, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=9) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PV_TOT",& description="PV TOTAL average",usage="AVE_PV_TOT .. ",& - type_of_var=real_t, n_var=9, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=9) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PV_KIN",& description="PV KINETIC average",usage="AVE_PV_KIN .. ",& - type_of_var=real_t, n_var=9, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=9) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PV_CNSTR",& description="PV CONSTRAINTS average",usage="AVE_PV_CNSTR .. ",& - type_of_var=real_t, n_var=9, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=9) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PV_XC",& description="PV XC average",usage="AVE_PV_XC .. ",& - type_of_var=real_t, n_var=9, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=9) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_PV_FOCK_4C",& description="PV XC average",usage="AVE_PV_FOCK_4C .. ",& - type_of_var=real_t, n_var=9, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=9) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_COLVARS",& description="COLVARS averages",usage="AVE_COLVARS .. ",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVE_MMATRIX",& description="METRIC TENSOR averages",usage="AVE_MMATRIX .. ",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_avgs_restart_section END MODULE input_cp2k_md diff --git a/src/motion/input_cp2k_restarts.F b/src/motion/input_cp2k_restarts.F index a245a7abcc..dae65ecedc 100644 --- a/src/motion/input_cp2k_restarts.F +++ b/src/motion/input_cp2k_restarts.F @@ -105,14 +105,12 @@ MODULE input_cp2k_restarts !> \param vels ... !> \param pint_env ... !> \param helium_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 created [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** SUBROUTINE write_restart(md_env,force_env,root_section,& - coords, vels, pint_env, helium_env, error) + coords, vels, pint_env, helium_env) TYPE(md_environment_type), OPTIONAL, & POINTER :: md_env TYPE(force_env_type), OPTIONAL, POINTER :: force_env @@ -121,7 +119,6 @@ SUBROUTINE write_restart(md_env,force_env,root_section,& TYPE(pint_env_type), OPTIONAL, POINTER :: pint_env TYPE(helium_solvent_type), OPTIONAL, & POINTER :: helium_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_restart', & routineP = moduleN//':'//routineN @@ -139,69 +136,66 @@ SUBROUTINE write_restart(md_env,force_env,root_section,& CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) - motion_section => section_vals_get_subs_vals(root_section,"MOTION",error=error) + logger => cp_get_default_logger() + motion_section => section_vals_get_subs_vals(root_section,"MOTION") NULLIFY(global_section) - global_section => section_vals_get_subs_vals(root_section,"GLOBAL",error=error) - CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem,error=error) + global_section => section_vals_get_subs_vals(root_section,"GLOBAL") + CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - motion_section,keys(1),error=error),cp_p_file).OR. & + motion_section,keys(1)),cp_p_file).OR. & BTEST(cp_print_key_should_output(logger%iter_info,& - motion_section,keys(2),error=error),cp_p_file)) THEN + motion_section,keys(2)),cp_p_file)) THEN - sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL",error=error) - CALL section_vals_get(sections, n_repetition=nforce_eval, error=error) + sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL") + CALL section_vals_get(sections, n_repetition=nforce_eval) CALL section_vals_val_get(motion_section,"PRINT%RESTART%SPLIT_RESTART_FILE",& - l_val=write_binary_restart_file,error=error) + l_val=write_binary_restart_file) IF (write_binary_restart_file) THEN - CALL update_subsys_release(md_env,force_env,root_section,error) - CALL update_motion_release(motion_section,error) + CALL update_subsys_release(md_env,force_env,root_section) + CALL update_motion_release(motion_section) DO ikey=1,SIZE(keys) log_unit = cp_logger_get_default_io_unit(logger) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - motion_section,keys(ikey),error=error),cp_p_file)) THEN + motion_section,keys(ikey)),cp_p_file)) THEN ires = cp_print_key_unit_nr(logger,motion_section,TRIM(keys(ikey)),& extension=".restart.bin",& file_action="READWRITE",& file_form="UNFORMATTED",& file_position="REWIND",& file_status="UNKNOWN",& - do_backup=(ikey==2),& - error=error) - CALL write_binary_restart(ires,log_unit,root_section,md_env,force_env,error=error) + do_backup=(ikey==2)) + CALL write_binary_restart(ires,log_unit,root_section,md_env,force_env) CALL cp_print_key_finished_output(ires,logger,motion_section,& - TRIM(keys(ikey)),error=error) + TRIM(keys(ikey))) END IF END DO END IF CALL update_input(md_env,force_env,root_section,coords,vels,pint_env,helium_env,& save_mem=save_mem,& - write_binary_restart_file=write_binary_restart_file,& - error=error) + write_binary_restart_file=write_binary_restart_file) DO ikey=1,SIZE(keys) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - motion_section,keys(ikey),error=error),cp_p_file)) THEN + motion_section,keys(ikey)),cp_p_file)) THEN ires = cp_print_key_unit_nr(logger,motion_section,TRIM(keys(ikey)),& extension=".restart",& file_position="REWIND",& - do_backup=(ikey==2),& - error=error) + do_backup=(ikey==2)) IF (ires > 0) THEN CALL write_restart_header(ires) - CALL section_vals_write(root_section,unit_nr=ires,hide_root=.TRUE.,error=error) + CALL section_vals_write(root_section,unit_nr=ires,hide_root=.TRUE.) END IF - CALL cp_print_key_finished_output(ires,logger,motion_section,TRIM(keys(ikey)),error=error) + CALL cp_print_key_finished_output(ires,logger,motion_section,TRIM(keys(ikey))) END IF END DO IF (save_mem) THEN - CALL update_subsys_release(md_env,force_env,root_section,error) - CALL update_motion_release(motion_section,error) + CALL update_subsys_release(md_env,force_env,root_section) + CALL update_motion_release(motion_section) END IF END IF @@ -215,19 +209,16 @@ END SUBROUTINE write_restart !> \param md_env ... !> \param force_env ... !> \param root_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2007 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE update_subsys_release(md_env,force_env,root_section,error) + SUBROUTINE update_subsys_release(md_env,force_env,root_section) TYPE(md_environment_type), OPTIONAL, & POINTER :: md_env TYPE(force_env_type), OPTIONAL, POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_subsys_release', & routineP = moduleN//':'//routineN @@ -252,88 +243,88 @@ SUBROUTINE update_subsys_release(md_env,force_env,root_section,error) shell_particles,subsys,work_section) IF (PRESENT(md_env)) THEN - CALL get_md_env ( md_env=md_env,force_env=my_force_env,error=error) + CALL get_md_env ( md_env=md_env,force_env=my_force_env) ELSEIF (PRESENT(force_env)) THEN my_force_env => force_env END IF IF (ASSOCIATED(my_force_env)) THEN NULLIFY(subsys_section) - CALL section_vals_val_get(root_section,"GLOBAL%RUN_TYPE",i_val=myid,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%RUN_TYPE",i_val=myid) skip_vel_section =(& (myid /= mol_dyn_run).AND.& (myid /= mon_car_run).AND.& (myid /= pint_run)) - force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL",error=error) - CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval, error) + force_env_sections => section_vals_get_subs_vals(root_section,"FORCE_EVAL") + CALL multiple_fe_list(force_env_sections, root_section, i_force_eval, nforce_eval) DO iforce_eval=1,nforce_eval subsys_section => section_vals_get_subs_vals3(force_env_sections,"SUBSYS",& - i_rep_section=i_force_eval(iforce_eval),error=error) - CALL section_vals_get(subsys_section, explicit=explicit, error=error) + i_rep_section=i_force_eval(iforce_eval)) + CALL section_vals_get(subsys_section, explicit=explicit) IF (.NOT.explicit) CYCLE ! Nothing to update... my_force_b => my_force_env IF (iforce_eval>1) my_force_b => my_force_env%sub_force_env(iforce_eval-1)%force_env - CALL force_env_get(my_force_b, subsys=subsys, error=error) + CALL force_env_get(my_force_b, subsys=subsys) CALL cp_subsys_get(subsys, particles=particles, shell_particles=shell_particles,& - core_particles=core_particles, error=error) + core_particles=core_particles) - work_section => section_vals_get_subs_vals(subsys_section,"COORD",error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + work_section => section_vals_get_subs_vals(subsys_section,"COORD") + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(work_section,"SCALED",l_val=scale) END IF - CALL section_vals_remove_values(work_section, error) + CALL section_vals_remove_values(work_section) IF (explicit) THEN - CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_set(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_set(work_section,"SCALED",l_val=scale) END IF - work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) + work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") IF (.NOT.skip_vel_section) THEN - CALL section_vals_remove_values(work_section, error) + CALL section_vals_remove_values(work_section) END IF IF (ASSOCIATED(shell_particles)) THEN - work_section => section_vals_get_subs_vals(subsys_section,"SHELL_COORD",error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + work_section => section_vals_get_subs_vals(subsys_section,"SHELL_COORD") + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(work_section,"SCALED",l_val=scale) END IF - CALL section_vals_remove_values(work_section, error=error) + CALL section_vals_remove_values(work_section) IF (explicit) THEN - CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_set(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_set(work_section,"SCALED",l_val=scale) END IF - work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY",error=error) + work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY") IF (.NOT.skip_vel_section) THEN - CALL section_vals_remove_values(work_section, error=error) + CALL section_vals_remove_values(work_section) END IF END IF IF (ASSOCIATED(core_particles)) THEN - work_section => section_vals_get_subs_vals(subsys_section,"CORE_COORD",error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + work_section => section_vals_get_subs_vals(subsys_section,"CORE_COORD") + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(work_section,"SCALED",l_val=scale) END IF - CALL section_vals_remove_values(work_section, error=error) + CALL section_vals_remove_values(work_section) IF (explicit) THEN - CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_set(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_set(work_section,"SCALED",l_val=scale) END IF - work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY",error=error) + work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY") IF (.NOT.skip_vel_section) THEN - CALL section_vals_remove_values(work_section, error=error) + CALL section_vals_remove_values(work_section) END IF END IF @@ -350,16 +341,13 @@ END SUBROUTINE update_subsys_release ! ***************************************************************************** !> \brief deallocate the nose subsections (coord, vel, force, mass) in the md section !> \param motion_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2007 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE update_motion_release(motion_section,error) + SUBROUTINE update_motion_release(motion_section) TYPE(section_vals_type), POINTER :: motion_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_motion_release', & routineP = moduleN//':'//routineN @@ -371,35 +359,35 @@ SUBROUTINE update_motion_release(motion_section,error) NULLIFY (work_section) - work_section => section_vals_get_subs_vals(motion_section,"MD%AVERAGES%RESTART_AVERAGES",error=error) - CALL section_vals_remove_values(work_section,error) - - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%COORD",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%VELOCITY",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%MASS",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%FORCE",error=error) - CALL section_vals_remove_values(work_section,error) - - work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%COORD",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%VELOCITY",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%MASS",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%FORCE",error=error) - CALL section_vals_remove_values(work_section,error) - - work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%COORD",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%VELOCITY",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%MASS",error=error) - CALL section_vals_remove_values(work_section,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%FORCE",error=error) - CALL section_vals_remove_values(work_section,error) + work_section => section_vals_get_subs_vals(motion_section,"MD%AVERAGES%RESTART_AVERAGES") + CALL section_vals_remove_values(work_section) + + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%COORD") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%VELOCITY") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%MASS") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE%FORCE") + CALL section_vals_remove_values(work_section) + + work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%COORD") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%VELOCITY") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%MASS") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE%FORCE") + CALL section_vals_remove_values(work_section) + + work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%COORD") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%VELOCITY") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%MASS") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE%FORCE") + CALL section_vals_remove_values(work_section) CALL timestop(handle) @@ -416,14 +404,12 @@ END SUBROUTINE update_motion_release !> \param helium_env ... !> \param save_mem ... !> \param write_binary_restart_file ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE update_input(md_env,force_env,root_section,coords,vels,pint_env, & - helium_env,save_mem,write_binary_restart_file,error) + helium_env,save_mem,write_binary_restart_file) TYPE(md_environment_type), OPTIONAL, & POINTER :: md_env @@ -435,7 +421,6 @@ SUBROUTINE update_input(md_env,force_env,root_section,coords,vels,pint_env, & POINTER :: helium_env LOGICAL, INTENT(IN), OPTIONAL :: save_mem, & write_binary_restart_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_input', & routineP = moduleN//':'//routineN @@ -465,18 +450,18 @@ SUBROUTINE update_input(md_env,force_env,root_section,coords,vels,pint_env, & my_write_binary_restart_file = .FALSE. END IF - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Can handle md_env or force_env lcond = PRESENT(md_env).OR.PRESENT(force_env).OR.PRESENT(pint_env).OR.PRESENT(helium_env) IF (lcond) THEN IF (PRESENT(md_env)) THEN - CALL get_md_env ( md_env=md_env, force_env=my_force_env, error=error) + CALL get_md_env ( md_env=md_env, force_env=my_force_env) ELSE IF (PRESENT(force_env)) THEN my_force_env => force_env END IF ! The real restart setting... - motion_section => section_vals_get_subs_vals(root_section,"MOTION",error=error) + motion_section => section_vals_get_subs_vals(root_section,"MOTION") CALL update_motion(motion_section,& md_env=md_env,& force_env=my_force_env,& @@ -486,14 +471,12 @@ SUBROUTINE update_input(md_env,force_env,root_section,coords,vels,pint_env, & pint_env=pint_env,& helium_env=helium_env,& save_mem=my_save_mem,& - write_binary_restart_file=my_write_binary_restart_file,& - error=error) + write_binary_restart_file=my_write_binary_restart_file) ! Update one force_env_section per time.. IF (ASSOCIATED(my_force_env)) THEN CALL update_force_eval(force_env=my_force_env,& root_section=root_section,& - write_binary_restart_file=my_write_binary_restart_file,& - error=error) + write_binary_restart_file=my_write_binary_restart_file) END IF END IF @@ -513,15 +496,13 @@ END SUBROUTINE update_input !> \param helium_env ... !> \param save_mem ... !> \param write_binary_restart_file ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& coords,vels,pint_env,helium_env,save_mem,& - write_binary_restart_file,error) + write_binary_restart_file) TYPE(section_vals_type), POINTER :: motion_section TYPE(md_environment_type), OPTIONAL, & POINTER :: md_env @@ -533,7 +514,6 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& POINTER :: helium_env LOGICAL, INTENT(IN), OPTIONAL :: save_mem, & write_binary_restart_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_motion', & routineP = moduleN//':'//routineN @@ -577,8 +557,7 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& constant=constant,& itimes=itimes,& averages=averages,& - para_env=para_env,& - error=error) + para_env=para_env) ELSE IF (ASSOCIATED(force_env)) THEN para_env => force_env%para_env @@ -587,7 +566,7 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& ELSEIF (PRESENT(helium_env)) THEN para_env => helium_env%logger%para_env ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF @@ -610,85 +589,85 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& CALL timeset(routineN//"_COUNTERS",handle2) IF (ASSOCIATED(itimes)) THEN IF (itimes>=0) THEN - CALL section_vals_val_set(motion_section,"MD%STEP_START_VAL",i_val=itimes,error=error) - CPAssert(ASSOCIATED(t),cp_failure_level,routineP,error,failure) - CALL section_vals_val_set(motion_section,"MD%TIME_START_VAL",r_val=t,error=error) + CALL section_vals_val_set(motion_section,"MD%STEP_START_VAL",i_val=itimes) + CPAssert(ASSOCIATED(t),cp_failure_level,routineP,failure) + CALL section_vals_val_set(motion_section,"MD%TIME_START_VAL",r_val=t) END IF END IF IF (ASSOCIATED(constant)) THEN - CALL section_vals_val_set(motion_section,"MD%ECONS_START_VAL",r_val=constant,error=error) + CALL section_vals_val_set(motion_section,"MD%ECONS_START_VAL",r_val=constant) END IF CALL timestop(handle2) ! AVERAGES CALL timeset(routineN//"_AVERAGES",handle2) IF (ASSOCIATED(averages)) THEN IF ((averages%do_averages).AND.(averages%itimes_start/=-1)) THEN - work_section => section_vals_get_subs_vals(motion_section,"MD%AVERAGES",error=error) - CALL section_vals_val_set(work_section,"_SECTION_PARAMETERS_",l_val=averages%do_averages,error=error) - work_section => section_vals_get_subs_vals(motion_section,"MD%AVERAGES%RESTART_AVERAGES",error=error) - CALL section_vals_val_set(work_section,"ITIMES_START",i_val=averages%itimes_start,error=error) - CALL section_vals_val_set(work_section,"AVECPU",r_val=averages%avecpu,error=error) - CALL section_vals_val_set(work_section,"AVEHUGONIOT",r_val=averages%avehugoniot,error=error) - CALL section_vals_val_set(work_section,"AVETEMP_BARO",r_val=averages%avetemp_baro,error=error) - CALL section_vals_val_set(work_section,"AVEPOT",r_val=averages%avepot,error=error) - CALL section_vals_val_set(work_section,"AVEKIN",r_val=averages%avekin,error=error) - CALL section_vals_val_set(work_section,"AVETEMP",r_val=averages%avetemp,error=error) - CALL section_vals_val_set(work_section,"AVEKIN_QM",r_val=averages%avekin_qm,error=error) - CALL section_vals_val_set(work_section,"AVETEMP_QM",r_val=averages%avetemp_qm,error=error) - CALL section_vals_val_set(work_section,"AVEVOL",r_val=averages%avevol,error=error) - CALL section_vals_val_set(work_section,"AVECELL_A",r_val=averages%aveca,error=error) - CALL section_vals_val_set(work_section,"AVECELL_B",r_val=averages%avecb,error=error) - CALL section_vals_val_set(work_section,"AVECELL_C",r_val=averages%avecc,error=error) - CALL section_vals_val_set(work_section,"AVEALPHA",r_val=averages%aveal,error=error) - CALL section_vals_val_set(work_section,"AVEBETA",r_val=averages%avebe,error=error) - CALL section_vals_val_set(work_section,"AVEGAMMA",r_val=averages%avega,error=error) - CALL section_vals_val_set(work_section,"AVE_ECONS",r_val=averages%econs,error=error) - CALL section_vals_val_set(work_section,"AVE_PRESS",r_val=averages%avepress,error=error) - CALL section_vals_val_set(work_section,"AVE_PXX",r_val=averages%avepxx,error=error) + work_section => section_vals_get_subs_vals(motion_section,"MD%AVERAGES") + CALL section_vals_val_set(work_section,"_SECTION_PARAMETERS_",l_val=averages%do_averages) + work_section => section_vals_get_subs_vals(motion_section,"MD%AVERAGES%RESTART_AVERAGES") + CALL section_vals_val_set(work_section,"ITIMES_START",i_val=averages%itimes_start) + CALL section_vals_val_set(work_section,"AVECPU",r_val=averages%avecpu) + CALL section_vals_val_set(work_section,"AVEHUGONIOT",r_val=averages%avehugoniot) + CALL section_vals_val_set(work_section,"AVETEMP_BARO",r_val=averages%avetemp_baro) + CALL section_vals_val_set(work_section,"AVEPOT",r_val=averages%avepot) + CALL section_vals_val_set(work_section,"AVEKIN",r_val=averages%avekin) + CALL section_vals_val_set(work_section,"AVETEMP",r_val=averages%avetemp) + CALL section_vals_val_set(work_section,"AVEKIN_QM",r_val=averages%avekin_qm) + CALL section_vals_val_set(work_section,"AVETEMP_QM",r_val=averages%avetemp_qm) + CALL section_vals_val_set(work_section,"AVEVOL",r_val=averages%avevol) + CALL section_vals_val_set(work_section,"AVECELL_A",r_val=averages%aveca) + CALL section_vals_val_set(work_section,"AVECELL_B",r_val=averages%avecb) + CALL section_vals_val_set(work_section,"AVECELL_C",r_val=averages%avecc) + CALL section_vals_val_set(work_section,"AVEALPHA",r_val=averages%aveal) + CALL section_vals_val_set(work_section,"AVEBETA",r_val=averages%avebe) + CALL section_vals_val_set(work_section,"AVEGAMMA",r_val=averages%avega) + CALL section_vals_val_set(work_section,"AVE_ECONS",r_val=averages%econs) + CALL section_vals_val_set(work_section,"AVE_PRESS",r_val=averages%avepress) + CALL section_vals_val_set(work_section,"AVE_PXX",r_val=averages%avepxx) ! Virial averages IF (ASSOCIATED(averages%virial)) THEN ALLOCATE(buffer(9),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = RESHAPE(averages%virial%pv_total,(/9/)) - CALL section_vals_val_set(work_section,"AVE_PV_TOT",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_PV_TOT",r_vals_ptr=buffer) ALLOCATE(buffer(9),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = RESHAPE(averages%virial%pv_virial,(/9/)) - CALL section_vals_val_set(work_section,"AVE_PV_VIR",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_PV_VIR",r_vals_ptr=buffer) ALLOCATE(buffer(9),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = RESHAPE(averages%virial%pv_kinetic,(/9/)) - CALL section_vals_val_set(work_section,"AVE_PV_KIN",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_PV_KIN",r_vals_ptr=buffer) ALLOCATE(buffer(9),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = RESHAPE(averages%virial%pv_constraint,(/9/)) - CALL section_vals_val_set(work_section,"AVE_PV_CNSTR",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_PV_CNSTR",r_vals_ptr=buffer) ALLOCATE(buffer(9),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = RESHAPE(averages%virial%pv_xc,(/9/)) - CALL section_vals_val_set(work_section,"AVE_PV_XC",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_PV_XC",r_vals_ptr=buffer) ALLOCATE(buffer(9),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = RESHAPE(averages%virial%pv_fock_4c,(/9/)) - CALL section_vals_val_set(work_section,"AVE_PV_FOCK_4C",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_PV_FOCK_4C",r_vals_ptr=buffer) END IF ! Colvars averages IF (SIZE(averages%avecolvar)>0) THEN ALLOCATE(buffer(SIZE(averages%avecolvar)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = averages%avecolvar - CALL section_vals_val_set(work_section,"AVE_COLVARS",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_COLVARS",r_vals_ptr=buffer) END IF IF (SIZE(averages%aveMmatrix)>0) THEN ALLOCATE(buffer(SIZE(averages%aveMmatrix)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) buffer = averages%aveMmatrix - CALL section_vals_val_set(work_section,"AVE_MMATRIX",r_vals_ptr=buffer,error=error) + CALL section_vals_val_set(work_section,"AVE_MMATRIX",r_vals_ptr=buffer) END IF END IF END IF @@ -701,22 +680,22 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& ! Restart of Nose-Hoover Thermostat for Particles IF (.NOT.my_write_binary_restart_file) THEN nhc => thermostat_part%nhc - CALL collect_nose_restart_info(nhc,para_env,eta,veta,fnhc,mnhc,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE",error=error) - CALL set_template_restart(work_section,eta,veta,fnhc,mnhc,error) + CALL collect_nose_restart_info(nhc,para_env,eta,veta,fnhc,mnhc) + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%NOSE") + CALL set_template_restart(work_section,eta,veta,fnhc,mnhc) END IF ELSE IF (thermostat_part%type_of_thermostat == do_thermo_csvr) THEN ! Restart of CSVR Thermostat for Particles - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%CSVR",error=error) - CALL dump_csvr_restart_info(thermostat_part%csvr, para_env, work_section, error) + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%CSVR") + CALL dump_csvr_restart_info(thermostat_part%csvr, para_env, work_section) ELSE IF (thermostat_part%type_of_thermostat == do_thermo_al) THEN ! Restart of AD_LANGEVIN Thermostat for Particles - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%AD_LANGEVIN",error=error) - CALL dump_al_restart_info(thermostat_part%al, para_env, work_section, error) + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%AD_LANGEVIN") + CALL dump_al_restart_info(thermostat_part%al, para_env, work_section) ELSE IF (thermostat_part%type_of_thermostat == do_thermo_gle) THEN ! Restart of GLE Thermostat for Particles - work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%GLE",error=error) - CALL dump_gle_restart_info(thermostat_part%gle, para_env, work_section, error) + work_section => section_vals_get_subs_vals(motion_section,"MD%THERMOSTAT%GLE") + CALL dump_gle_restart_info(thermostat_part%gle, para_env, work_section) END IF END IF CALL timestop(handle2) @@ -730,13 +709,13 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& nhc_len = SIZE(nhc%nvt,1) tot_nhcneed = nhc%glob_num_nhc ALLOCATE(eta(tot_nhcneed*nhc_len), STAT = stat ) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(veta(tot_nhcneed*nhc_len), STAT = stat ) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(fnhc(tot_nhcneed*nhc_len), STAT = stat ) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mnhc(tot_nhcneed*nhc_len), STAT = stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) counter = 0 DO i=1,SIZE(nhc%nvt,1) DO j=1,SIZE(nhc%nvt,2) @@ -747,12 +726,12 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& mnhc(counter)= nhc%nvt(i,j)%mass END DO END DO - work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE",error=error) - CALL set_template_restart(work_section, eta, veta, fnhc, mnhc, error) + work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%NOSE") + CALL set_template_restart(work_section, eta, veta, fnhc, mnhc) ELSE IF (thermostat_baro%type_of_thermostat==do_thermo_csvr) THEN ! Restart of CSVR Thermostat for Barostat - work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%CSVR",error=error) - CALL dump_csvr_restart_info(thermostat_baro%csvr, para_env, work_section, error) + work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT%THERMOSTAT%CSVR") + CALL dump_csvr_restart_info(thermostat_baro%csvr, para_env, work_section) END IF END IF CALL timestop(handle2) @@ -761,9 +740,9 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& CALL timeset(routineN//"_NPT",handle2) IF (ASSOCIATED(npt)) THEN ALLOCATE(veta(SIZE(npt,1)*SIZE(npt,2)), STAT = stat ) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mnhc(SIZE(npt,1)*SIZE(npt,2)), STAT = stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) counter = 0 DO i=1,SIZE(npt,1) DO j=1,SIZE(npt,2) @@ -772,8 +751,8 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& mnhc(counter) = npt(i,j)%mass END DO END DO - work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT",error=error) - CALL set_template_restart(work_section, veta=veta, mnhc=mnhc, error=error) + work_section => section_vals_get_subs_vals(motion_section,"MD%BAROSTAT") + CALL set_template_restart(work_section, veta=veta, mnhc=mnhc) END IF CALL timestop(handle2) @@ -784,14 +763,14 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& ! Restart of Nose-Hoover Thermostat for Shell Particles IF (.NOT.my_write_binary_restart_file) THEN nhc => thermostat_shell%nhc - CALL collect_nose_restart_info(nhc,para_env,eta,veta,fnhc,mnhc,error) - work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE",error=error) - CALL set_template_restart(work_section,eta,veta,fnhc,mnhc,error) + CALL collect_nose_restart_info(nhc,para_env,eta,veta,fnhc,mnhc) + work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%NOSE") + CALL set_template_restart(work_section,eta,veta,fnhc,mnhc) END IF ELSE IF (thermostat_shell%type_of_thermostat == do_thermo_csvr) THEN - work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%CSVR",error=error) + work_section => section_vals_get_subs_vals(motion_section,"MD%SHELL%THERMOSTAT%CSVR") ! Restart of CSVR Thermostat for Shell Particles - CALL dump_csvr_restart_info(thermostat_shell%csvr, para_env, work_section, error) + CALL dump_csvr_restart_info(thermostat_shell%csvr, para_env, work_section) END IF END IF CALL timestop(handle2) @@ -799,110 +778,110 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& CALL timeset(routineN//"_META",handle2) IF (ASSOCIATED(meta_env)) THEN CALL section_vals_val_set(meta_env%metadyn_section,"STEP_START_VAL",& - i_val=meta_env%n_steps,error=error) + i_val=meta_env%n_steps) CALL section_vals_val_set(meta_env%metadyn_section,"NHILLS_START_VAL",& - i_val=meta_env%hills_env%n_hills,error=error) + i_val=meta_env%hills_env%n_hills) !RG Adaptive hills CALL section_vals_val_set(meta_env%metadyn_section,"MIN_DISP",& - r_val=meta_env%hills_env%min_disp,error=error) + r_val=meta_env%hills_env%min_disp) CALL section_vals_val_set(meta_env%metadyn_section,"OLD_HILL_NUMBER",& - i_val=meta_env%hills_env%old_hill_number,error=error) + i_val=meta_env%hills_env%old_hill_number) CALL section_vals_val_set(meta_env%metadyn_section,"OLD_HILL_STEP",& - i_val=meta_env%hills_env%old_hill_step,error=error) + i_val=meta_env%hills_env%old_hill_step) !RG Adaptive hills IF (meta_env%do_hills.AND.meta_env%hills_env%n_hills/=0) THEN - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_POS",error=error) - CALL meta_hills_val_set_ss(work_section, meta_env, error=error) - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_SCALE",error=error) - CALL meta_hills_val_set_ds(work_section, meta_env, error=error) - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_HEIGHT",error=error) - CALL meta_hills_val_set_ww(work_section, meta_env, error=error) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_POS") + CALL meta_hills_val_set_ss(work_section, meta_env) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_SCALE") + CALL meta_hills_val_set_ds(work_section, meta_env) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_HEIGHT") + CALL meta_hills_val_set_ww(work_section, meta_env) IF (meta_env%well_tempered) THEN - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_INVDT",error=error) - CALL meta_hills_val_set_dt(work_section, meta_env, error=error) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"SPAWNED_HILLS_INVDT") + CALL meta_hills_val_set_dt(work_section, meta_env) END IF END IF IF (meta_env%extended_lagrange) THEN CALL section_vals_val_set(meta_env%metadyn_section,"COLVAR_AVG_TEMPERATURE_RESTART",& - r_val=meta_env%avg_temp,error=error) - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS0",error=error) + r_val=meta_env%avg_temp) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS0") DO irep = 1, meta_env%n_colvar CALL section_vals_val_set(work_section,"_DEFAULT_KEYWORD_",r_val=meta_env%metavar(irep)%ss0,& - i_rep_val=irep,error=error) + i_rep_val=irep) END DO - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_VVP",error=error) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_VVP") DO irep = 1, meta_env%n_colvar CALL section_vals_val_set(work_section,"_DEFAULT_KEYWORD_",r_val=meta_env%metavar(irep)%vvp,& - i_rep_val=irep,error=error) + i_rep_val=irep) END DO - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS",error=error) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS") DO irep = 1, meta_env%n_colvar CALL section_vals_val_set(work_section,"_DEFAULT_KEYWORD_",r_val=meta_env%metavar(irep)%ss,& - i_rep_val=irep,error=error) + i_rep_val=irep) END DO - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_FS",error=error) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_FS") DO irep = 1, meta_env%n_colvar CALL section_vals_val_set(work_section,"_DEFAULT_KEYWORD_",r_val=meta_env%metavar(irep)%ff_s,& - i_rep_val=irep,error=error) + i_rep_val=irep) END DO END IF ! Multiple Walkers IF (meta_env%do_multiple_walkers) THEN ALLOCATE(walkers_status(meta_env%multiple_walkers%walkers_tot_nr),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) walkers_status = meta_env%multiple_walkers%walkers_status - work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"MULTIPLE_WALKERS",error=error) - CALL section_vals_val_set(work_section,"WALKERS_STATUS",i_vals_ptr=walkers_status,error=error) + work_section => section_vals_get_subs_vals(meta_env%metadyn_section,"MULTIPLE_WALKERS") + CALL section_vals_val_set(work_section,"WALKERS_STATUS",i_vals_ptr=walkers_status) END IF END IF CALL timestop(handle2) CALL timeset(routineN//"_NEB",handle2) IF (PRESENT(coords).OR.(PRESENT(vels))) THEN ! Update NEB section - replica_section => section_vals_get_subs_vals(motion_section,"BAND%REPLICA",error=error) - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles,error=error) + replica_section => section_vals_get_subs_vals(motion_section,"BAND%REPLICA") + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) IF (PRESENT(coords)) THEN ! Allocate possible missing sections DO IF (coords%size_wrk(2)<=SIZE(replica_section%values,2)) EXIT - CALL section_vals_add_values(replica_section,error=error) + CALL section_vals_add_values(replica_section) END DO ! Write Values DO isec = 1, coords%size_wrk(2) - CALL section_vals_val_unset(replica_section,"COORD_FILE_NAME",i_rep_section=isec,error=error) - work_section => section_vals_get_subs_vals3(replica_section,"COORD",i_rep_section=isec,error=error) + CALL section_vals_val_unset(replica_section,"COORD_FILE_NAME",i_rep_section=isec) + work_section => section_vals_get_subs_vals3(replica_section,"COORD",i_rep_section=isec) CALL section_neb_coord_val_set(work_section,coords%xyz(:,isec),SIZE(coords%xyz,1),3*SIZE(particles%els),& - 3,particles%els,angstrom,error) + 3,particles%els,angstrom) ! Update Collective Variables IF (coords%in_use == do_band_collective) THEN ALLOCATE (wrk(coords%size_wrk(1)),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) wrk = coords%wrk(:,isec) CALL section_vals_val_set(replica_section,"COLLECTIVE",r_vals_ptr=wrk,& - i_rep_section=isec,error=error) + i_rep_section=isec) END IF END DO END IF IF (PRESENT(vels)) THEN - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles,error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ! Allocate possible missing sections DO IF (vels%size_wrk(2)<=SIZE(replica_section%values,2)) EXIT - CALL section_vals_add_values(replica_section,error=error) + CALL section_vals_add_values(replica_section) END DO ! Write Values DO isec = 1, vels%size_wrk(2) - work_section => section_vals_get_subs_vals3(replica_section,"VELOCITY",i_rep_section=isec,error=error) + work_section => section_vals_get_subs_vals3(replica_section,"VELOCITY",i_rep_section=isec) IF (vels%in_use == do_band_collective) THEN CALL section_neb_coord_val_set(work_section,vels%wrk(:,isec),SIZE(vels%wrk,1),SIZE(vels%wrk,1),& - 1,particles%els,1.0_dp,error) + 1,particles%els,1.0_dp) ELSE CALL section_neb_coord_val_set(work_section,vels%wrk(:,isec),SIZE(vels%wrk,1),3*SIZE(particles%els),& - 3,particles%els,1.0_dp,error) + 3,particles%els,1.0_dp) END IF END DO END IF @@ -911,12 +890,12 @@ SUBROUTINE update_motion(motion_section,md_env,force_env,logger,& IF (PRESENT(pint_env)) THEN ! Update PINT section - CALL update_motion_pint(motion_section, pint_env, error) + CALL update_motion_pint(motion_section, pint_env) END IF IF (PRESENT(helium_env)) THEN ! Update HELIUM section - CALL update_motion_helium(helium_env, error) + CALL update_motion_helium(helium_env) END IF CALL timestop(handle) @@ -928,15 +907,13 @@ END SUBROUTINE update_motion !> \brief Update PINT section in the input structure !> \param motion_section ... !> \param pint_env ... -!> \param error ... !> \date 2010-10-13 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE update_motion_pint(motion_section, pint_env, error) + SUBROUTINE update_motion_pint(motion_section, pint_env) TYPE(section_vals_type), POINTER :: motion_section TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_motion_pint', & routineP = moduleN//':'//routineN @@ -949,26 +926,26 @@ SUBROUTINE update_motion_pint(motion_section, pint_env, error) CALL timeset(routineN,handle) - pint_section => section_vals_get_subs_vals(motion_section,"PINT",error=error) - CALL section_vals_val_set(pint_section,"ITERATION",i_val=pint_env%iter,error=error) + pint_section => section_vals_get_subs_vals(motion_section,"PINT") + CALL section_vals_val_set(pint_section,"ITERATION",i_val=pint_env%iter) ! allocate memory for COORDs and VELOCITYs if the BEADS section was not ! explicitly given in the input (this is actually done only once since ! after section_vals_add_values section becomes explict) NULLIFY(tmpsec) - tmpsec => section_vals_get_subs_vals(pint_section,"BEADS", error=error) - CALL section_vals_get(tmpsec,explicit=explicit,error=error) + tmpsec => section_vals_get_subs_vals(pint_section,"BEADS") + CALL section_vals_get(tmpsec,explicit=explicit) IF ( .NOT. explicit ) THEN - CALL section_vals_add_values(tmpsec,error) + CALL section_vals_add_values(tmpsec) END IF ! update bead coordinates in the global input structure NULLIFY(r_vals) ALLOCATE(r_vals(pint_env%p*pint_env%ndim),STAT=istat) - CPAssert(istat==0, cp_failure_level, routineP, error, failure) + CPAssert(istat==0, cp_failure_level, routineP,failure) i=1 - CALL pint_u2x(pint_env,error=error) + CALL pint_u2x(pint_env) DO iatom=1, pint_env%ndim DO ibead=1, pint_env%p r_vals(i)=pint_env%x(ibead,iatom) @@ -976,14 +953,14 @@ SUBROUTINE update_motion_pint(motion_section, pint_env, error) END DO END DO CALL section_vals_val_set(pint_section,"BEADS%COORD%_DEFAULT_KEYWORD_", & - r_vals_ptr=r_vals,error=error) + r_vals_ptr=r_vals) ! update bead velocities in the global input structure NULLIFY(r_vals) ALLOCATE(r_vals(pint_env%p*pint_env%ndim),STAT=istat) - CPAssert(istat==0, cp_failure_level, routineP, error, failure) + CPAssert(istat==0, cp_failure_level, routineP,failure) i=1 - CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v) DO iatom=1, pint_env%ndim DO ibead=1, pint_env%p r_vals(i)=pint_env%v(ibead,iatom) @@ -991,7 +968,7 @@ SUBROUTINE update_motion_pint(motion_section, pint_env, error) END DO END DO CALL section_vals_val_set(pint_section,"BEADS%VELOCITY%_DEFAULT_KEYWORD_",& - r_vals_ptr=r_vals,error=error) + r_vals_ptr=r_vals) IF(pint_env%pimd_thermostat==thermostat_nose) THEN @@ -999,16 +976,16 @@ SUBROUTINE update_motion_pint(motion_section, pint_env, error) ! explicitly given in the input (this is actually done only once since ! after section_vals_add_values section becomes explict) NULLIFY(tmpsec) - tmpsec => section_vals_get_subs_vals(pint_section,"NOSE", error=error) - CALL section_vals_get(tmpsec,explicit=explicit,error=error) + tmpsec => section_vals_get_subs_vals(pint_section,"NOSE") + CALL section_vals_get(tmpsec,explicit=explicit) IF ( .NOT. explicit ) THEN - CALL section_vals_add_values(tmpsec,error) + CALL section_vals_add_values(tmpsec) END IF ! update thermostat coordinates in the global input structure NULLIFY(r_vals) ALLOCATE(r_vals(pint_env%p*pint_env%ndim*pint_env%nnos),STAT=istat) - CPAssert(istat==0, cp_failure_level, routineP, error, failure) + CPAssert(istat==0, cp_failure_level, routineP,failure) i=1 DO iatom=1, pint_env%ndim DO ibead=1, pint_env%p @@ -1019,12 +996,12 @@ SUBROUTINE update_motion_pint(motion_section, pint_env, error) END DO END DO CALL section_vals_val_set(pint_section,"NOSE%COORD%_DEFAULT_KEYWORD_", & - r_vals_ptr=r_vals,error=error) + r_vals_ptr=r_vals) ! update thermostat velocities in the global input structure NULLIFY(r_vals) ALLOCATE(r_vals(pint_env%p*pint_env%ndim*pint_env%nnos),STAT=istat) - CPAssert(istat==0, cp_failure_level, routineP, error, failure) + CPAssert(istat==0, cp_failure_level, routineP,failure) i=1 DO iatom=1, pint_env%ndim DO ibead=1, pint_env%p @@ -1035,13 +1012,13 @@ SUBROUTINE update_motion_pint(motion_section, pint_env, error) END DO END DO CALL section_vals_val_set(pint_section,"NOSE%VELOCITY%_DEFAULT_KEYWORD_", & - r_vals_ptr=r_vals,error=error) + r_vals_ptr=r_vals) ELSEIF(pint_env%pimd_thermostat==thermostat_gle) THEN NULLIFY(tmpsec) - tmpsec => section_vals_get_subs_vals(pint_section,"GLE",error=error) - CALL dump_gle_restart_info(pint_env%gle, pint_env%replicas%para_env, tmpsec, error) + tmpsec => section_vals_get_subs_vals(pint_section,"GLE") + CALL dump_gle_restart_info(pint_env%gle, pint_env%replicas%para_env, tmpsec) END IF @@ -1052,17 +1029,15 @@ END SUBROUTINE update_motion_pint ! *************************************************************************** !> \brief Update HELIUM section in the input structure. !> \param helium ... -!> \param error ... !> \date 2009-11-12 !> \author Lukasz Walewski !> \note Transfer the current helium state from the runtime environment !> to the input structure, so that it can be used for I/O, etc. !> \note Moved from the helium_io module directly, might be done better way ! ***************************************************************************** - SUBROUTINE update_motion_helium(helium, error) + SUBROUTINE update_motion_helium(helium) TYPE(helium_solvent_type), POINTER :: helium - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_motion_helium', & routineP = moduleN//':'//routineN @@ -1084,10 +1059,10 @@ SUBROUTINE update_motion_helium(helium, error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(helium),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF ( .NOT. helium%solute_present ) THEN ! update iteration number @@ -1095,8 +1070,7 @@ SUBROUTINE update_motion_helium(helium, error) CALL section_vals_val_set( & helium%input, & "MOTION%PINT%ITERATION", & - i_val=itmp, & - error=error ) + i_val=itmp) ! else - PINT will do that END IF @@ -1107,14 +1081,14 @@ SUBROUTINE update_motion_helium(helium, error) NULLIFY(real_msg) msglen = SIZE(helium%pos) ALLOCATE(real_msg(msglen),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) real_msg(:) = PACK( helium%pos, .TRUE. ) ! allocate the buffer for message passing NULLIFY(real_msg_gather) msglen = SIZE(helium%pos) * logger%para_env%num_pe ALLOCATE(real_msg_gather(msglen),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) ! pass the message from all processors to logger%para_env%source real_msg_gather(:) = 0.0_dp @@ -1124,7 +1098,7 @@ SUBROUTINE update_motion_helium(helium, error) ! update coordinates in the global input structure CALL section_vals_val_set(helium%input, & "MOTION%PINT%HELIUM%COORD%_DEFAULT_KEYWORD_", & - r_vals_ptr=real_msg_gather,error=error) + r_vals_ptr=real_msg_gather) ! NULLIFY, but do not DEALLOCATE! - a new pointer to this array is silently ! assigned in section_vals_val_set - this memory will be used later on! @@ -1133,7 +1107,7 @@ SUBROUTINE update_motion_helium(helium, error) ! DEALLOCATE since this array is only used locally DEALLOCATE(real_msg,STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) ! ! save permutation state @@ -1142,7 +1116,7 @@ SUBROUTINE update_motion_helium(helium, error) NULLIFY(int_msg_gather) msglen = SIZE(helium%permutation) * logger%para_env%num_pe ALLOCATE(int_msg_gather(msglen),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) ! pass the message from all processors to logger%para_env%source int_msg_gather(:) = 0 @@ -1152,7 +1126,7 @@ SUBROUTINE update_motion_helium(helium, error) ! update permutation state in the global input structure CALL section_vals_val_set(helium%input, & "MOTION%PINT%HELIUM%PERM%_DEFAULT_KEYWORD_", & - i_vals_ptr=int_msg_gather,error=error) + i_vals_ptr=int_msg_gather) ! NULLIFY, but do not DEALLOCATE! - a new pointer to this array is silently ! assigned in section_vals_val_set - this memory will be used later on! @@ -1166,9 +1140,9 @@ SUBROUTINE update_motion_helium(helium, error) NULLIFY(real_msg) msglen = 40 ALLOCATE(real_msg(msglen),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) CALL get_rng_stream(helium%rng_stream_uniform,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf,error=error) + buffer=bu,buffer_filled=lbf) offset = 0 real_msg(offset+1:offset+6) = PACK( bg, .TRUE. ) real_msg(offset+7:offset+12) = PACK( cg, .TRUE. ) @@ -1181,7 +1155,7 @@ SUBROUTINE update_motion_helium(helium, error) real_msg(offset+19) = bf real_msg(offset+20) = bu CALL get_rng_stream(helium%rng_stream_gaussian,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf,error=error) + buffer=bu,buffer_filled=lbf) offset = 20 real_msg(offset+1:offset+6) = PACK( bg, .TRUE. ) real_msg(offset+7:offset+12) = PACK( cg, .TRUE. ) @@ -1199,14 +1173,14 @@ SUBROUTINE update_motion_helium(helium, error) NULLIFY(real_msg_gather) msglen = SIZE(real_msg)*logger%para_env%num_pe ALLOCATE(real_msg_gather(msglen),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) real_msg_gather(:) = 0.0_dp CALL mp_gather(real_msg,real_msg_gather,logger%para_env%source,logger%para_env%group) ! update the RNG state in the global input structure CALL section_vals_val_set(helium%input, & "MOTION%PINT%HELIUM%RNG_STATE%_DEFAULT_KEYWORD_", & - r_vals_ptr=real_msg_gather,error=error) + r_vals_ptr=real_msg_gather) ! NULLIFY, but do not DEALLOCATE! - a new pointer to this array is silently ! assigned in section_vals_val_set - this memeory will be used later on! @@ -1215,7 +1189,7 @@ SUBROUTINE update_motion_helium(helium, error) ! DEALLOCATE since this array is only used locally DEALLOCATE(real_msg,STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) IF (helium%solute_present) THEN ! @@ -1240,13 +1214,13 @@ SUBROUTINE update_motion_helium(helium, error) ! forces should be the same on all processors, but we don't check that here NULLIFY(real_msg_gather) ALLOCATE(real_msg_gather(msglen),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) real_msg_gather(:) = PACK( helium%force_avrg, .TRUE. ) ! update forces in the global input structure CALL section_vals_val_set(helium%input, & "MOTION%PINT%HELIUM%FORCE%_DEFAULT_KEYWORD_", & - r_vals_ptr=real_msg_gather,error=error) + r_vals_ptr=real_msg_gather) ! NULLIFY, but do not DEALLOCATE! - a new pointer to this array is silently ! assigned in section_vals_val_set - this memeory will be used later on! @@ -1262,11 +1236,10 @@ SUBROUTINE update_motion_helium(helium, error) ! make sure that the section is explicitly present in the input structure NULLIFY(tmpsec) tmpsec => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%RHO", & - error=error) - CALL section_vals_get(tmpsec,explicit=explicit,error=error) + "MOTION%PINT%HELIUM%RHO") + CALL section_vals_get(tmpsec,explicit=explicit) IF ( .NOT. explicit ) THEN - CALL section_vals_add_values(tmpsec,error) + CALL section_vals_add_values(tmpsec) END IF ! work on the temporary array so that accumulated data remains intact @@ -1279,13 +1252,13 @@ SUBROUTINE update_motion_helium(helium, error) CALL mp_sum(message,logger%para_env%group) END DO itmp = logger%para_env%num_pe - CPPostcondition(itmp>0,cp_failure_level,routineP,error,failure) + CPPostcondition(itmp>0,cp_failure_level,routineP,failure) rtmp = 1.0_dp / REAL(itmp,dp) helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * rtmp ! average over steps performed so far in this run nsteps = helium%current_step-helium%first_step - CPPostcondition(nsteps>0,cp_failure_level,routineP,error,failure) + CPPostcondition(nsteps>0,cp_failure_level,routineP,failure) rtmp = 1.0_dp / REAL(nsteps,dp) helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * rtmp @@ -1302,11 +1275,11 @@ SUBROUTINE update_motion_helium(helium, error) NULLIFY(real_msg) msglen = SIZE(helium%rho_inst) ALLOCATE(real_msg(msglen),STAT=status) - CPPostcondition(status==0,cp_failure_level,routineP,error,failure) + CPPostcondition(status==0,cp_failure_level,routineP,failure) real_msg(:) = PACK( helium%rho_inst, .TRUE. ) CALL section_vals_val_set(helium%input, & "MOTION%PINT%HELIUM%RHO%CUBE_DATA%_DEFAULT_KEYWORD_", & - r_vals_ptr=real_msg,error=error) + r_vals_ptr=real_msg) NULLIFY(real_msg) ! update the weighting factor @@ -1318,7 +1291,7 @@ SUBROUTINE update_motion_helium(helium, error) END IF CALL section_vals_val_set(helium%input, & "MOTION%PINT%HELIUM%RHO%IWEIGHT", & - i_val=itmp,error=error) + i_val=itmp) END IF @@ -1331,18 +1304,15 @@ END SUBROUTINE update_motion_helium !> \param thermostat_energy ... !> \param nsize ... !> \param work_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [teo] !> \author Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE dump_csvr_energy_info(thermostat_energy, nsize, work_section, error) + SUBROUTINE dump_csvr_energy_info(thermostat_energy, nsize, work_section) REAL(KIND=dp), DIMENSION(:), POINTER :: thermostat_energy INTEGER, INTENT(IN) :: nsize TYPE(section_vals_type), POINTER :: work_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_csvr_energy_info', & routineP = moduleN//':'//routineN @@ -1355,33 +1325,33 @@ SUBROUTINE dump_csvr_energy_info(thermostat_energy, nsize, work_section, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(work_section),cp_failure_level,routineP,error,failure) - CPPrecondition((work_section%ref_count>0),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(work_section),cp_failure_level,routineP,failure) + CPPrecondition((work_section%ref_count>0),cp_failure_level,routineP,failure) NULLIFY (my_val,old_val,section,vals) section => work_section%section - ik = section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik = section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(work_section%values,2)==1) EXIT - CALL section_vals_add_values(work_section,error=error) + CALL section_vals_add_values(work_section) END DO vals => work_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF DO irk=1,nsize - CALL val_create(val=my_val,r_val=thermostat_energy(irk),error=error) + CALL val_create(val=my_val,r_val=thermostat_energy(irk)) IF (Nlist /= 0) THEN IF (irk == 1) THEN new_pos => vals @@ -1389,16 +1359,16 @@ SUBROUTINE dump_csvr_energy_info(thermostat_energy, nsize, work_section, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk == 1) THEN NULLIFY (new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY (new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -1414,17 +1384,14 @@ END SUBROUTINE dump_csvr_energy_info !> \param csvr ... !> \param para_env ... !> \param csvr_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] - University of Zurich !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE dump_csvr_restart_info(csvr, para_env, csvr_section, error) + SUBROUTINE dump_csvr_restart_info(csvr, para_env, csvr_section) TYPE(csvr_system_type), POINTER :: csvr TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: csvr_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_csvr_restart_info', & routineP = moduleN//':'//routineN @@ -1441,34 +1408,34 @@ SUBROUTINE dump_csvr_restart_info(csvr, para_env, csvr_section, error) failure = .FALSE. ! Thermostat Energies ALLOCATE(work(csvr%glob_num_csvr),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(thermo_energy(csvr%loc_num_csvr),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,csvr%loc_num_csvr thermo_energy(i) = csvr%nvt(i)%thermostat_energy END DO CALL get_kin_energies (csvr%map_info,csvr%loc_num_csvr,& csvr%glob_num_csvr,thermo_energy,& - dum, para_env, array_kin=work, error=error) + dum, para_env, array_kin=work) DEALLOCATE(thermo_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! If check passes then let's dump the info on the restart file - work_section => section_vals_get_subs_vals(csvr_section,"THERMOSTAT_ENERGY",error=error) - CALL dump_csvr_energy_info(work, csvr%glob_num_csvr, work_section, error) + work_section => section_vals_get_subs_vals(csvr_section,"THERMOSTAT_ENERGY") + CALL dump_csvr_energy_info(work, csvr%glob_num_csvr, work_section) DEALLOCATE (work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Thermostat Random Number info for restart - work_section => section_vals_get_subs_vals(csvr_section,"RNG_INIT",error=error) + work_section => section_vals_get_subs_vals(csvr_section,"RNG_INIT") ALLOCATE (dwork(rng_record_length,csvr%glob_num_csvr),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dwork = 0 DO i=1,csvr%loc_num_csvr my_index = csvr%map_info%index(i) CALL dump_rng_stream(rng_stream=csvr%nvt(i)%gaussian_rng_stream,& - rng_record=rng_record, error=error) + rng_record=rng_record) CALL string_to_ascii(rng_record,dwork(:,my_index)) END DO @@ -1478,12 +1445,11 @@ SUBROUTINE dump_csvr_restart_info(csvr, para_env, csvr_section, error) CALL mp_sum(dwork,para_env%group) ELSE ! Perform some check and collect data in case of communicating thermostats - CALL communication_thermo_low2(dwork, rng_record_length, csvr%glob_num_csvr, para_env, error) + CALL communication_thermo_low2(dwork, rng_record_length, csvr%glob_num_csvr, para_env) END IF - CALL section_rng_val_set(rng_section=work_section,nsize=csvr%glob_num_csvr,ascii=dwork,& - error=error) + CALL section_rng_val_set(rng_section=work_section,nsize=csvr%glob_num_csvr,ascii=dwork) DEALLOCATE (dwork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE dump_csvr_restart_info @@ -1493,17 +1459,14 @@ END SUBROUTINE dump_csvr_restart_info !> \param al ... !> \param para_env ... !> \param al_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] - University of Zurich !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE dump_al_restart_info(al, para_env, al_section, error) + SUBROUTINE dump_al_restart_info(al, para_env, al_section) TYPE(al_system_type), POINTER :: al TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: al_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_al_restart_info', & routineP = moduleN//':'//routineN @@ -1518,9 +1481,9 @@ SUBROUTINE dump_al_restart_info(al, para_env, al_section, error) ! chi and mass ALLOCATE(work(al%glob_num_al),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(t_array(al%loc_num_al),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! copy chi into temporary DO i = 1,al%loc_num_al @@ -1529,11 +1492,11 @@ SUBROUTINE dump_al_restart_info(al, para_env, al_section, error) ! consolidate into work CALL get_kin_energies (al%map_info,al%loc_num_al,& al%glob_num_al,t_array,& - dum, para_env, array_kin=work, error=error) + dum, para_env, array_kin=work) ! If check passes then let's dump the info on the restart file - work_section => section_vals_get_subs_vals(al_section,"CHI",error=error) - CALL dump_csvr_energy_info(work, al%glob_num_al, work_section, error) + work_section => section_vals_get_subs_vals(al_section,"CHI") + CALL dump_csvr_energy_info(work, al%glob_num_al, work_section) ! copy mass into temporary DO i = 1,al%loc_num_al @@ -1542,16 +1505,16 @@ SUBROUTINE dump_al_restart_info(al, para_env, al_section, error) ! consolidate into work CALL get_kin_energies (al%map_info,al%loc_num_al,& al%glob_num_al,t_array,& - dum, para_env, array_kin=work, error=error) + dum, para_env, array_kin=work) ! If check passes then let's dump the info on the restart file - work_section => section_vals_get_subs_vals(al_section,"MASS",error=error) - CALL dump_csvr_energy_info(work, al%glob_num_al, work_section, error) + work_section => section_vals_get_subs_vals(al_section,"MASS") + CALL dump_csvr_energy_info(work, al%glob_num_al, work_section) DEALLOCATE (t_array,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE dump_al_restart_info @@ -1561,15 +1524,12 @@ END SUBROUTINE dump_al_restart_info !> \param gle ... !> \param para_env ... !> \param gle_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author MI ! ***************************************************************************** - SUBROUTINE dump_gle_restart_info(gle, para_env, gle_section, error) + SUBROUTINE dump_gle_restart_info(gle, para_env, gle_section) TYPE(gle_type), POINTER :: gle TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: gle_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_gle_restart_info', & routineP = moduleN//':'//routineN @@ -1590,35 +1550,35 @@ SUBROUTINE dump_gle_restart_info(gle, para_env, gle_section, error) ! Thermostat Energies ALLOCATE(work(gle%glob_num_gle),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(thermo_energy(gle%loc_num_gle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,gle%loc_num_gle thermo_energy(i) = gle%nvt(i)%thermostat_energy END DO CALL get_kin_energies (gle%map_info,gle%loc_num_gle,& gle%glob_num_gle,thermo_energy,& - dum, para_env, array_kin=work, error=error) + dum, para_env, array_kin=work) DEALLOCATE(thermo_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! If check passes then let's dump the info on the restart file - work_section => section_vals_get_subs_vals(gle_section,"THERMOSTAT_ENERGY",error=error) - CALL dump_csvr_energy_info(work, gle%glob_num_gle, work_section, error) + work_section => section_vals_get_subs_vals(gle_section,"THERMOSTAT_ENERGY") + CALL dump_csvr_energy_info(work, gle%glob_num_gle, work_section) DEALLOCATE (work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Thermostat Random Number info for restart - work_section => section_vals_get_subs_vals(gle_section,"RNG_INIT",error=error) + work_section => section_vals_get_subs_vals(gle_section,"RNG_INIT") glob_num = gle%glob_num_gle loc_num = gle%loc_num_gle ALLOCATE (dwork(rng_record_length,glob_num),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dwork = 0 DO i=1,loc_num j = gle%map_info%index(i) CALL dump_rng_stream(rng_stream= gle%nvt(i)%gaussian_rng_stream,& - rng_record=rng_record, error=error) + rng_record=rng_record) CALL string_to_ascii(rng_record,dwork(:,j)) END DO @@ -1628,22 +1588,21 @@ SUBROUTINE dump_gle_restart_info(gle, para_env, gle_section, error) CALL mp_sum(dwork,para_env%group) ELSE ! Perform some check and collect data in case of communicating thermostats - CALL communication_thermo_low2(dwork, rng_record_length, glob_num, para_env, error) + CALL communication_thermo_low2(dwork, rng_record_length, glob_num, para_env) END IF - CALL section_rng_val_set(rng_section=work_section,nsize=glob_num,ascii=dwork,& - error=error) + CALL section_rng_val_set(rng_section=work_section,nsize=glob_num,ascii=dwork) DEALLOCATE (dwork,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( gle_per_proc(para_env%num_pe),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) gle_per_proc(:) = 0 CALL mp_allgather(gle%loc_num_gle,gle_per_proc,para_env%group) ! Thermostat S variable info for restart NULLIFY(s_tmp) ALLOCATE (s_tmp((gle%ndim)*gle%glob_num_gle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) s_tmp=0.0_dp NULLIFY(work,index) @@ -1675,19 +1634,19 @@ SUBROUTINE dump_gle_restart_info(gle, para_env, gle_section, error) END DO IF(SIZE(s_tmp)>0) THEN - work_section => section_vals_get_subs_vals(gle_section,"S",error=error) - CALL section_vals_val_set(work_section,"_DEFAULT_KEYWORD_",r_vals_ptr=s_tmp,error=error) + work_section => section_vals_get_subs_vals(gle_section,"S") + CALL section_vals_val_set(work_section,"_DEFAULT_KEYWORD_",r_vals_ptr=s_tmp) ELSE DEALLOCATE(s_tmp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(gle_per_proc, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( work, STAT = stat ) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( index, STAT = stat ) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE dump_gle_restart_info @@ -1700,17 +1659,14 @@ END SUBROUTINE dump_gle_restart_info !> \param veta ... !> \param fnhc ... !> \param mnhc ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] - University of Zurich !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE collect_nose_restart_info(nhc, para_env, eta, veta, fnhc, mnhc, error) + SUBROUTINE collect_nose_restart_info(nhc, para_env, eta, veta, fnhc, mnhc) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:), POINTER :: eta, veta, fnhc, mnhc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'collect_nose_restart_info', & routineP = moduleN//':'//routineN @@ -1886,14 +1842,12 @@ END SUBROUTINE collect_nose_restart_info !> \param nfield ... !> \param particle_set ... !> \param conv_factor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE section_neb_coord_val_set(coord_section,array,narray,nsize,nfield,& - particle_set,conv_factor,error) + particle_set,conv_factor) TYPE(section_vals_type), POINTER :: coord_section REAL(KIND=dp), DIMENSION(*) :: array @@ -1901,7 +1855,6 @@ SUBROUTINE section_neb_coord_val_set(coord_section,array,narray,nsize,nfield,& TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set REAL(KIND=dp) :: conv_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'section_neb_coord_val_set', & routineP = moduleN//':'//routineN @@ -1915,32 +1868,32 @@ SUBROUTINE section_neb_coord_val_set(coord_section,array,narray,nsize,nfield,& failure = .FALSE. NULLIFY (my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(coord_section),cp_failure_level,routineP,error,failure) - CPPrecondition(coord_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(coord_section),cp_failure_level,routineP,failure) + CPPrecondition(coord_section%ref_count>0,cp_failure_level,routineP,failure) section => coord_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(coord_section%values,2)==1) EXIT - CALL section_vals_add_values(coord_section,error=error) + CALL section_vals_add_values(coord_section) END DO vals => coord_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF DO irk=1,nsize/nfield ALLOCATE (my_c(nfield),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (nfield == 3) THEN my_c(1:3) = get_particle_pos_or_vel(irk,particle_set,array(1:narray)) my_c(1:3) = my_c(1:3)*conv_factor ELSE my_c(1) = array(irk) END IF - CALL val_create(my_val,r_vals_ptr=my_c,error=error) + CALL val_create(my_val,r_vals_ptr=my_c) IF (Nlist /= 0) THEN IF (irk==1) THEN @@ -1949,16 +1902,16 @@ SUBROUTINE section_neb_coord_val_set(coord_section,array,narray,nsize,nfield,& new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -1974,17 +1927,14 @@ END SUBROUTINE section_neb_coord_val_set !> \param veta ... !> \param fnhc ... !> \param mnhc ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE set_template_restart(work_section, eta, veta, fnhc, mnhc, error) + SUBROUTINE set_template_restart(work_section, eta, veta, fnhc, mnhc) TYPE(section_vals_type), POINTER :: work_section REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: eta, veta, fnhc, mnhc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_template_restart', & routineP = moduleN//':'//routineN @@ -1997,8 +1947,8 @@ SUBROUTINE set_template_restart(work_section, eta, veta, fnhc, mnhc, error) NULLIFY (coord, force, velocity, mass) IF (PRESENT(eta)) THEN IF (SIZE(eta) > 0) THEN - coord => section_vals_get_subs_vals(work_section,"COORD",error=error) - CALL section_vals_val_set(coord,"_DEFAULT_KEYWORD_",r_vals_ptr=eta,error=error) + coord => section_vals_get_subs_vals(work_section,"COORD") + CALL section_vals_val_set(coord,"_DEFAULT_KEYWORD_",r_vals_ptr=eta) ELSE DEALLOCATE (eta,STAT=stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"eta") @@ -2006,8 +1956,8 @@ SUBROUTINE set_template_restart(work_section, eta, veta, fnhc, mnhc, error) END IF IF (PRESENT(veta)) THEN IF (SIZE(veta) > 0) THEN - velocity => section_vals_get_subs_vals(work_section,"VELOCITY",error=error) - CALL section_vals_val_set(velocity,"_DEFAULT_KEYWORD_",r_vals_ptr=veta,error=error) + velocity => section_vals_get_subs_vals(work_section,"VELOCITY") + CALL section_vals_val_set(velocity,"_DEFAULT_KEYWORD_",r_vals_ptr=veta) ELSE DEALLOCATE (veta,STAT=stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"veta") @@ -2015,8 +1965,8 @@ SUBROUTINE set_template_restart(work_section, eta, veta, fnhc, mnhc, error) END IF IF (PRESENT(fnhc)) THEN IF (SIZE(fnhc) > 0) THEN - force => section_vals_get_subs_vals(work_section,"FORCE",error=error) - CALL section_vals_val_set(force,"_DEFAULT_KEYWORD_",r_vals_ptr=fnhc,error=error) + force => section_vals_get_subs_vals(work_section,"FORCE") + CALL section_vals_val_set(force,"_DEFAULT_KEYWORD_",r_vals_ptr=fnhc) ELSE DEALLOCATE (fnhc,STAT=stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"fnhc") @@ -2024,8 +1974,8 @@ SUBROUTINE set_template_restart(work_section, eta, veta, fnhc, mnhc, error) END IF IF (PRESENT(mnhc)) THEN IF (SIZE(mnhc) > 0) THEN - mass => section_vals_get_subs_vals(work_section,"MASS",error=error) - CALL section_vals_val_set(mass,"_DEFAULT_KEYWORD_",r_vals_ptr=mnhc,error=error) + mass => section_vals_get_subs_vals(work_section,"MASS") + CALL section_vals_val_set(mass,"_DEFAULT_KEYWORD_",r_vals_ptr=mnhc) ELSE DEALLOCATE (mnhc,STAT=stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"mnhc") @@ -2038,17 +1988,14 @@ END SUBROUTINE set_template_restart !> \brief routine to dump hills information during metadynamics run !> \param ss_section ... !> \param meta_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE meta_hills_val_set_ss(ss_section, meta_env, error) + SUBROUTINE meta_hills_val_set_ss(ss_section, meta_env) TYPE(section_vals_type), POINTER :: ss_section TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'meta_hills_val_set_ss', & routineP = moduleN//':'//routineN @@ -2062,29 +2009,29 @@ SUBROUTINE meta_hills_val_set_ss(ss_section, meta_env, error) failure=.FALSE. NULLIFY(my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(ss_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ss_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ss_section),cp_failure_level,routineP,failure) + CPPrecondition(ss_section%ref_count>0,cp_failure_level,routineP,failure) section => ss_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(ss_section%values,2)==1) EXIT - CALL section_vals_add_values(ss_section,error=error) + CALL section_vals_add_values(ss_section) END DO vals => ss_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF lsize = SIZE(meta_env%hills_env%ss_history,1) DO irk=1,meta_env%hills_env%n_hills ALLOCATE(ss_val(lsize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Always stored in A.U. ss_val = meta_env%hills_env%ss_history(:,irk) - CALL val_create(my_val,r_vals_ptr=ss_val,error=error) + CALL val_create(my_val,r_vals_ptr=ss_val) IF (irk <= Nlist) THEN IF (irk==1) THEN @@ -2093,16 +2040,16 @@ SUBROUTINE meta_hills_val_set_ss(ss_section, meta_env, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -2115,17 +2062,14 @@ END SUBROUTINE meta_hills_val_set_ss !> \brief routine to dump hills information during metadynamics run !> \param ds_section ... !> \param meta_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE meta_hills_val_set_ds(ds_section, meta_env, error) + SUBROUTINE meta_hills_val_set_ds(ds_section, meta_env) TYPE(section_vals_type), POINTER :: ds_section TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'meta_hills_val_set_ds', & routineP = moduleN//':'//routineN @@ -2139,29 +2083,29 @@ SUBROUTINE meta_hills_val_set_ds(ds_section, meta_env, error) failure=.FALSE. NULLIFY(my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(ds_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ds_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ds_section),cp_failure_level,routineP,failure) + CPPrecondition(ds_section%ref_count>0,cp_failure_level,routineP,failure) section => ds_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(ds_section%values,2)==1) EXIT - CALL section_vals_add_values(ds_section,error=error) + CALL section_vals_add_values(ds_section) END DO vals => ds_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF lsize = SIZE(meta_env%hills_env%delta_s_history,1) DO irk=1,meta_env%hills_env%n_hills ALLOCATE(ds_val(lsize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Always stored in A.U. ds_val = meta_env%hills_env%delta_s_history(:,irk) - CALL val_create(my_val,r_vals_ptr=ds_val,error=error) + CALL val_create(my_val,r_vals_ptr=ds_val) IF (irk<=Nlist) THEN IF (irk==1) THEN @@ -2170,16 +2114,16 @@ SUBROUTINE meta_hills_val_set_ds(ds_section, meta_env, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -2192,17 +2136,14 @@ END SUBROUTINE meta_hills_val_set_ds !> \brief routine to dump hills information during metadynamics run !> \param ww_section ... !> \param meta_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2006 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE meta_hills_val_set_ww(ww_section, meta_env, error) + SUBROUTINE meta_hills_val_set_ww(ww_section, meta_env) TYPE(section_vals_type), POINTER :: ww_section TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'meta_hills_val_set_ww', & routineP = moduleN//':'//routineN @@ -2215,25 +2156,25 @@ SUBROUTINE meta_hills_val_set_ww(ww_section, meta_env, error) failure=.FALSE. NULLIFY(my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(ww_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ww_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ww_section),cp_failure_level,routineP,failure) + CPPrecondition(ww_section%ref_count>0,cp_failure_level,routineP,failure) section => ww_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(ww_section%values,2)==1) EXIT - CALL section_vals_add_values(ww_section,error=error) + CALL section_vals_add_values(ww_section) END DO vals => ww_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF lsize = meta_env%hills_env%n_hills DO irk=1,lsize - CALL val_create(my_val,r_val=meta_env%hills_env%ww_history(irk),error=error) + CALL val_create(my_val,r_val=meta_env%hills_env%ww_history(irk)) IF (irk<=Nlist) THEN IF (irk==1) THEN @@ -2242,16 +2183,16 @@ SUBROUTINE meta_hills_val_set_ww(ww_section, meta_env, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -2264,17 +2205,14 @@ END SUBROUTINE meta_hills_val_set_ww !> \brief routine to dump hills information during metadynamics run !> \param invdt_section ... !> \param meta_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2009 created [seb] !> \author SC ! ***************************************************************************** - SUBROUTINE meta_hills_val_set_dt(invdt_section, meta_env, error) + SUBROUTINE meta_hills_val_set_dt(invdt_section, meta_env) TYPE(section_vals_type), POINTER :: invdt_section TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'meta_hills_val_set_dt', & routineP = moduleN//':'//routineN @@ -2287,25 +2225,25 @@ SUBROUTINE meta_hills_val_set_dt(invdt_section, meta_env, error) failure=.FALSE. NULLIFY(my_val, old_val, section, vals) - CPPrecondition(ASSOCIATED(invdt_section),cp_failure_level,routineP,error,failure) - CPPrecondition(invdt_section%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(invdt_section),cp_failure_level,routineP,failure) + CPPrecondition(invdt_section%ref_count>0,cp_failure_level,routineP,failure) section => invdt_section%section - ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_",error=error) + ik=section_get_keyword_index(section,"_DEFAULT_KEYWORD_") CALL cp_assert(ik/=-2,cp_failure_level,cp_assertion_failed,routineP,& "section "//TRIM(section%name)//" does not contain keyword "//& - "_DEFAULT_KEYWORD_",error,failure) + "_DEFAULT_KEYWORD_",failure) DO IF (SIZE(invdt_section%values,2)==1) EXIT - CALL section_vals_add_values(invdt_section,error=error) + CALL section_vals_add_values(invdt_section) END DO vals => invdt_section%values(ik,1)%list Nlist = 0 IF (ASSOCIATED(vals)) THEN - Nlist = cp_sll_val_get_length(vals,error) + Nlist = cp_sll_val_get_length(vals) END IF lsize = meta_env%hills_env%n_hills DO irk=1,lsize - CALL val_create(my_val,r_val=meta_env%hills_env%invdt_history(irk),error=error) + CALL val_create(my_val,r_val=meta_env%hills_env%invdt_history(irk)) IF (irk<=Nlist) THEN IF (irk==1) THEN @@ -2314,16 +2252,16 @@ SUBROUTINE meta_hills_val_set_dt(invdt_section, meta_env, error) new_pos => new_pos%rest END IF old_val => new_pos%first_el - CALL val_release(old_val,error=error) + CALL val_release(old_val) new_pos%first_el => my_val ELSE IF (irk==1) THEN NULLIFY(new_pos) - CALL cp_sll_val_create(new_pos,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos,first_el=my_val) vals => new_pos ELSE NULLIFY(new_pos%rest) - CALL cp_sll_val_create(new_pos%rest,first_el=my_val,error=error) + CALL cp_sll_val_create(new_pos%rest,first_el=my_val) new_pos => new_pos%rest END IF END IF @@ -2340,21 +2278,18 @@ END SUBROUTINE meta_hills_val_set_dt !> \param root_section ... !> \param md_env ... !> \param force_env ... -!> \param error ... !> \par History !> - Creation (10.02.2011,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_env,& - error) + SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_env) INTEGER, INTENT(IN) :: output_unit, log_unit TYPE(section_vals_type), POINTER :: root_section TYPE(md_environment_type), OPTIONAL, & POINTER :: md_env TYPE(force_env_type), OPTIONAL, POINTER :: force_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_binary_restart', & routineP = moduleN//':'//routineN @@ -2398,8 +2333,7 @@ SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_e CALL get_md_env(md_env=md_env,& force_env=my_force_env,& thermostat_part=thermostat_part,& - thermostat_shell=thermostat_shell,& - error=error) + thermostat_shell=thermostat_shell) ELSE IF (PRESENT(force_env)) THEN my_force_env => force_env END IF @@ -2409,7 +2343,7 @@ SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_e RETURN END IF - CALL section_vals_val_get(root_section,"GLOBAL%PRINT_LEVEL",i_val=print_level,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%PRINT_LEVEL",i_val=print_level) IF (print_level > 1) THEN print_info = .TRUE. @@ -2419,15 +2353,14 @@ SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_e - CALL section_vals_val_get(root_section,"GLOBAL%RUN_TYPE",i_val=run_type,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%RUN_TYPE",i_val=run_type) write_velocities = ((run_type == mol_dyn_run).OR.& (run_type == mon_car_run).OR.& (run_type == pint_run)) CALL force_env_get(force_env=my_force_env,& para_env=para_env,& - subsys=subsys,& - error=error) + subsys=subsys) CALL cp_subsys_get(subsys,& atomic_kinds=atomic_kinds,& particles=particles,& @@ -2437,8 +2370,7 @@ SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_e shell_particles=shell_particles,& nshell=nshell,& molecule_kinds_new=molecule_kinds,& - molecules_new=molecules,& - error=error) + molecules_new=molecules) natomkind = atomic_kinds%n_els IF (ASSOCIATED(molecule_kinds)) THEN @@ -2671,7 +2603,7 @@ SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_e nhc => thermostat_part%nhc CALL write_binary_thermostats_nose(nhc,output_unit,log_unit,section_label,& n_char_size,n_dp_size,n_int_size,& - print_info,para_env,error) + print_info,para_env) END IF ELSE nhc_size = 0 @@ -2700,7 +2632,7 @@ SUBROUTINE write_binary_restart(output_unit,log_unit,root_section,md_env,force_e nhc => thermostat_shell%nhc CALL write_binary_thermostats_nose(nhc,output_unit,log_unit,section_label,& n_char_size,n_dp_size,n_int_size,& - print_info,para_env,error) + print_info,para_env) END IF ELSE nhc_size = 0 @@ -2848,7 +2780,6 @@ END SUBROUTINE write_binary_restart !> \param n_int_size ... !> \param print_info ... !> \param para_env ... -!> \param error ... !> \par History !> - Creation (23.03.2011,MK) !> \author Matthias Krack (MK) @@ -2856,7 +2787,7 @@ END SUBROUTINE write_binary_restart ! ***************************************************************************** SUBROUTINE write_binary_thermostats_nose(nhc,output_unit,log_unit,section_label,& n_char_size,n_dp_size,n_int_size,& - print_info,para_env,error) + print_info,para_env) TYPE(lnhc_parameters_type), POINTER :: nhc INTEGER, INTENT(IN) :: output_unit, log_unit @@ -2866,7 +2797,6 @@ SUBROUTINE write_binary_thermostats_nose(nhc,output_unit,log_unit,section_label, n_int_size LOGICAL, INTENT(IN) :: print_info TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'write_binary_thermostats_nose', & @@ -2882,7 +2812,7 @@ SUBROUTINE write_binary_thermostats_nose(nhc,output_unit,log_unit,section_label, NULLIFY (mnhc) NULLIFY (veta) - CALL collect_nose_restart_info(nhc,para_env,eta,veta,fnhc,mnhc,error) + CALL collect_nose_restart_info(nhc,para_env,eta,veta,fnhc,mnhc) nhc_size = SIZE(eta) diff --git a/src/motion/input_cp2k_vib.F b/src/motion/input_cp2k_vib.F index e8d1c0bd8e..8b4415f036 100644 --- a/src/motion/input_cp2k_vib.F +++ b/src/motion/input_cp2k_vib.F @@ -50,13 +50,10 @@ MODULE input_cp2k_vib ! ***************************************************************************** !> \brief Creates the exteranal restart section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author tlaino ! ***************************************************************************** - SUBROUTINE create_vib_section(section,error) + SUBROUTINE create_vib_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_vib_section', & routineP = moduleN//':'//routineN @@ -67,28 +64,27 @@ SUBROUTINE create_vib_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="VIBRATIONAL_ANALYSIS",& description="Section to setup parameters to perform a Normal Modes analysis.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, subsection) CALL keyword_create(keyword, name="DX",& description="Specify the increment to be used to construct the HESSIAN with "//& "finite difference method",& - default_r_val=1.0E-2_dp, unit_str="bohr", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-2_dp, unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NPROC_REP",& description="Specify the number of processors to be used per replica "//& "environment (for parallel runs). "//& "In case of mode selective calculations more than one replica will start"//& " a block Davidson algorithm to track more than only one frequency",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROC_DIST_TYPE",& description="Specify the topology of the mapping of processors into replicas.",& @@ -98,41 +94,38 @@ SUBROUTINE create_vib_section(section,error) enum_desc=s2a( "Interleaved distribution",& "Blocked distribution"),& enum_i_vals=(/do_rep_interleaved,do_rep_blocked/),& - default_i_val=do_rep_blocked, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_rep_blocked) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FULLY_PERIODIC",& description="Avoids to clean rotations from the Hessian matrix.",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTENSITIES",& description="Calculation of the IR-Intensities. Calculation of dipols has to be specified explicitly ",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_mode_selective_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mode_selective_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_print_vib_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_print_vib_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_vib_section ! ***************************************************************************** !> \brief Create the print section for VIB !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - 10.2008 ! ***************************************************************************** - SUBROUTINE create_print_vib_section(section,error) + SUBROUTINE create_print_vib_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_vib_section', & routineP = moduleN//':'//routineN @@ -143,59 +136,53 @@ SUBROUTINE create_print_vib_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PRINT",& description="Section controlling the print information during a vibrational "//& - "analysis.",n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + "analysis.",n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, print_key) CALL cp_print_key_section_create(print_key,"BANNER",& description="Controls the printing of the vibrational analysis banner", & print_level=low_print_level, common_iter_levels=1,& - filename="__STD_OUT__",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing basic info about the vibrational method", & - print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"MOLDEN_VIB",& description="Controls the printing for visualization in molden format", & - print_level=low_print_level,add_last=add_last_numeric,filename="VIBRATIONS",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="VIBRATIONS") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ROTATIONAL_INFO",& description="Controls the printing basic info during the cleaning of the "//& "rotational degrees of freedom.", & - print_level=debug_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) + print_level=debug_print_level,add_last=add_last_numeric,filename="__STD_OUT__") ! Print_key keywords CALL keyword_create(keyword, name="COORDINATES",& description="Prints atomic coordinates after rotation",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_vib_section ! ***************************************************************************** !> \brief Create the input section for MODE selective !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff ! ***************************************************************************** - SUBROUTINE create_mode_selective_section(section,error) + SUBROUTINE create_mode_selective_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_mode_selective_section', & @@ -208,51 +195,46 @@ SUBROUTINE create_mode_selective_section(section,error) failure=.FALSE. NULLIFY(keyword, subsection, print_key) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MODE_SELECTIVE",& description="All parameters needed for to run a mode selective vibrational analysis",& - n_keywords=5, n_subsections=1, repeats=.FALSE., & - error=error) + n_keywords=5, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword,name="FREQUENCY",& description="value close to the expected value of the frequency for to look for. "//& "If the block Davidson algorithm is applied, the nrep closest frequencies are tracked. ",& - usage="FREQUENCY {REAL}", default_r_val=-1._dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FREQUENCY {REAL}", default_r_val=-1._dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="RANGE",& description="Track modes in a given range of frequencies. "//& "No warranty that the set of frequencies is complete.",& usage="RANGE {REAL} {REAL}",& - n_var=-1,type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Specifies the list of atoms which should be displaced for the Initial guess",& usage="ATOMS {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="EPS_MAX_VAL",& description="Convergence criterium for the davidson algorithm. Specifies the maximal value in the "//& "residuum vectors ",& - usage="EPS_MAX_VAL {REAL}", default_r_val=5.0E-7_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_MAX_VAL {REAL}", default_r_val=5.0E-7_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="EPS_NORM",& description="Convergence criterium for the davidson algorithm. Specifies the maximal value of the norm "//& "of the residuum vectors ",& - usage="EPS_NORM {REAL}", default_r_val=2.0E-6_dp,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_NORM {REAL}", default_r_val=2.0E-6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INITIAL_GUESS",& description="The type of initial guess for the normal modes",& @@ -265,48 +247,44 @@ SUBROUTINE create_mode_selective_section(section,error) "use a vector from MS_RESTART, useful if you want to increase accurcy by changing functionals or basis",& "use the .mol file of a former run, to restart a vector"//& "(similar to Restart_vec, but a different file FORMAT is used)"),& - enum_i_vals=(/ms_guess_bfgs,ms_guess_atomic,ms_guess_restart,ms_guess_restart_vec,ms_guess_molden/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ms_guess_bfgs,ms_guess_atomic,ms_guess_restart,ms_guess_restart_vec,ms_guess_molden/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_FILE_NAME",& description="Specifies the name of the file used to create the restarted vectors",& usage="RESTART_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_involved_atoms_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_involved_atoms_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL section_create(subsection, name="PRINT",& description="Controls the printing mode selective vibrational analysis",& - n_keywords=0, n_subsections=1, repeats=.TRUE., error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) CALL cp_print_key_section_create(print_key,"MS_RESTART",& description="Controls the printing of the Mode Selective Restart file.", & print_level=silent_print_level, common_iter_levels=1, & - add_last=add_last_numeric, filename="",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + add_last=add_last_numeric, filename="") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_mode_selective_section ! ***************************************************************************** !> \brief Create the input section for Ivolved_atoms keyword in mode selective !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff ! ***************************************************************************** - SUBROUTINE create_involved_atoms_section(section,error) + SUBROUTINE create_involved_atoms_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_involved_atoms_section', & @@ -318,28 +296,26 @@ SUBROUTINE create_involved_atoms_section(section,error) failure=.FALSE. NULLIFY(keyword) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="INVOLVED_ATOMS",& description="All parameters needed for the tracking of modes dominated by the motion of selected atoms ",& - n_keywords=2, n_subsections=0, repeats=.FALSE., & - error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword,name="RANGE",& description=" Specifies the range of wavenumbers in which the modes related to the ATOMS have to be tracked. "//& " If not specified frequencies >400cm-1 will be used to avoid tracking of translational or rotational modes",& usage="RANGE {REAL} {REAL}",& - n_var=-1,type_of_var=real_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INVOLVED_ATOMS",& description="Specifies the list of atoms on which the tracked eigenvector should have the highest value "//& "similar to looking for the vibration of a set of atoms",& usage="INVOLVED_ATOMS {integer} {integer} .. {integer}", & - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) diff --git a/src/motion/integrator.F b/src/motion/integrator.F index 272bed838f..7e78379681 100644 --- a/src/motion/integrator.F +++ b/src/motion/integrator.F @@ -116,7 +116,6 @@ MODULE integrator ! ***************************************************************************** !> \brief Langevin integrator for particle positions & momenta (Brownian dynamics) !> \param md_env ... -!> \param error ... !> \par Literature !> - A. Ricci and G. Ciccotti, Mol. Phys. 101, 1927-1931 (2003) !> - For langevin regions: @@ -128,10 +127,9 @@ MODULE integrator !> (01.12.2013, LT) !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE langevin(md_env,error) + SUBROUTINE langevin(md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'langevin', & routineP = moduleN//':'//routineN @@ -181,16 +179,16 @@ SUBROUTINE langevin(md_env,error) CALL get_md_env(md_env=md_env, simpar=simpar, force_env=force_env,& para_env=para_env, thermal_regions=thermal_regions, & - itimes=itimes, error=error) + itimes=itimes) dt = simpar%dt gam = simpar%gamma+simpar%shadow_gamma nshell = 0 - CALL force_env_get(force_env=force_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(force_env=force_env,subsys=subsys,cell=cell) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,& atomic_kinds=atomic_kinds,& @@ -201,11 +199,10 @@ SUBROUTINE langevin(md_env,error) molecule_kinds_new=molecule_kinds,& nshell=nshell,& particles=particles,& - virial=virial,& - error=error) + virial=virial) CALL cp_assert((nshell == 0),cp_failure_level,cp_assertion_failed,routineP,& "Langevin dynamics is not yet implemented for core-shell models",& - error,failure) + failure) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -217,7 +214,7 @@ SUBROUTINE langevin(md_env,error) ! Setup the langevin regions information ALLOCATE(do_langevin(nparticle), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (simpar%do_thermal_region) THEN DO iparticle = 1, nparticle do_langevin(iparticle) = thermal_regions%do_langevin(iparticle) @@ -232,7 +229,7 @@ SUBROUTINE langevin(md_env,error) ! for each region should depend on the temperature defined in the ! region ALLOCATE(var_w(nparticle), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) var_w(1:nparticle) = simpar%var_w IF (simpar%do_thermal_region) THEN DO ireg = 1, thermal_regions%nregions @@ -247,19 +244,19 @@ SUBROUTINE langevin(md_env,error) ! Allocate work storage ALLOCATE (pos(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pos(:,:) = 0.0_dp ALLOCATE (vel(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vel(:,:) = 0.0_dp ALLOCATE (w(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) w(:,:) = 0.0_dp IF (simpar%constraint) CALL getold(gci,local_molecules,molecule_set,& - molecule_kind_set, particle_set,cell,error) + molecule_kind_set, particle_set,cell) ! Generate random variables DO iparticle_kind=1,nparticle_kind @@ -272,18 +269,18 @@ SUBROUTINE langevin(md_env,error) sigma = var_w(iparticle)*mass rng_stream => local_particles%local_particle_set(iparticle_kind)%& rng(iparticle_local)%stream - w(1,iparticle) = next_random_number(rng_stream,variance=sigma,error=error) - w(2,iparticle) = next_random_number(rng_stream,variance=sigma,error=error) - w(3,iparticle) = next_random_number(rng_stream,variance=sigma,error=error) + w(1,iparticle) = next_random_number(rng_stream,variance=sigma) + w(2,iparticle) = next_random_number(rng_stream,variance=sigma) + w(3,iparticle) = next_random_number(rng_stream,variance=sigma) END IF END DO END DO DEALLOCATE(var_w,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Apply fix atom constraint - CALL fix_atom_control(force_env,error,w) + CALL fix_atom_control(force_env,w) ! Velocity Verlet (first part) c = EXP(-0.25_dp*dt*gam) @@ -319,25 +316,25 @@ SUBROUTINE langevin(md_env,error) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) CALL shake_control(gci,local_molecules,molecule_set,molecule_kind_set,& particle_set,pos,vel,dt,simpar%shake_tol,& simpar%info_constraint,simpar%lagrange_multipliers,& - simpar%dump_lm,cell,para_env%group,local_particles, error) + simpar%dump_lm,cell,para_env%group,local_particles) END IF ! Broadcast the new particle positions - CALL update_particle_set(particle_set,para_env%group,pos=pos,error=error) + CALL update_particle_set(particle_set,para_env%group,pos=pos) DEALLOCATE(pos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Update forces - CALL force_env_calc_energy_force(force_env,error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, vel, error=error) + CALL metadyn_integrator(force_env, itimes, vel) ! Update Verlet (second part) DO iparticle_kind=1,nparticle_kind @@ -367,27 +364,27 @@ SUBROUTINE langevin(md_env,error) CALL rattle_control(gci,local_molecules,molecule_set,molecule_kind_set,& particle_set,vel,dt,simpar%shake_tol,& simpar%info_constraint,simpar%lagrange_multipliers,& - simpar%dump_lm,cell,para_env%group,local_particles, error) + simpar%dump_lm,cell,para_env%group,local_particles) END IF ! Broadcast the new particle velocities - CALL update_particle_set(particle_set,para_env%group,vel=vel,error=error) + CALL update_particle_set(particle_set,para_env%group,vel=vel) DEALLOCATE(vel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(w,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(do_langevin,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Update virial IF (simpar%constraint) CALL pv_constraint(gci,local_molecules,molecule_set,& molecule_kind_set, particle_set,virial,para_env%group) CALL virial_evaluate(atomic_kind_set,particle_set,local_particles,& - virial,para_env%group, error=error) + virial,para_env%group) END SUBROUTINE langevin @@ -395,17 +392,15 @@ END SUBROUTINE langevin !> \brief nve integrator for particle positions & momenta !> \param md_env ... !> \param globenv ... -!> \param error ... !> \par History !> - the local particle lists are used instead of pnode (Sep. 2003,MK) !> - usage of fragments retrieved from the force environment (Oct. 2003,MK) !> \author CJM ! ***************************************************************************** - SUBROUTINE nve ( md_env, globenv, error) + SUBROUTINE nve ( md_env, globenv) TYPE(md_environment_type), POINTER :: md_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nve', & routineP = moduleN//':'//routineN @@ -457,16 +452,16 @@ SUBROUTINE nve ( md_env, globenv, error) core_particle_set, thermostat_shell, dft_control, itimes) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,& thermostat_coeff=thermostat_coeff,thermostat_shell=thermostat_shell,& - para_env=para_env, ehrenfest_md=ehrenfest_md, itimes=itimes, error=error) + para_env=para_env, ehrenfest_md=ehrenfest_md, itimes=itimes) dt = simpar%dt - CALL force_env_get(force_env=force_env, subsys=subsys,cell=cell, error=error) + CALL force_env_get(force_env=force_env, subsys=subsys,cell=cell) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules, & - molecule_kinds_new=molecule_kinds,gci=gci,virial=virial,error=error) + molecule_kinds_new=molecule_kinds,gci=gci,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -482,7 +477,7 @@ SUBROUTINE nve ( md_env, globenv, error) IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,shell_particles=shell_particles,& - core_particles=core_particles, error=error) + core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) @@ -491,44 +486,44 @@ SUBROUTINE nve ( md_env, globenv, error) END IF END IF - CALL allocate_tmp(md_env, tmp, nparticle,nshell,shell_adiabatic,error=error) + CALL allocate_tmp(md_env, tmp, nparticle,nshell,shell_adiabatic) ! Apply thermostat over the full set of shells if required IF(shell_adiabatic) THEN CALL apply_thermostat_shells(thermostat_shell, atomic_kind_set, particle_set,& local_particles, para_env%group, shell_particle_set=shell_particle_set,& - core_particle_set=core_particle_set, error=error) + core_particle_set=core_particle_set) END IF IF (simpar%constraint) CALL getold(gci,local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ! Velocity Verlet (first part) CALL vv_first(tmp,atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar, para_env, atomic_kind_set,& local_particles, particle_set, core_particle_set, shell_particle_set,& - nparticle_kind, shell_adiabatic, error=error) + nparticle_kind, shell_adiabatic) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) CALL shake_control(gci,local_molecules, molecule_set,& molecule_kind_set, particle_set, tmp%pos, tmp%vel, dt,simpar%shake_tol, & simpar%info_constraint,simpar%lagrange_multipliers,simpar%dump_lm,& - cell,para_env%group,local_particles, error ) + cell,para_env%group,local_particles) END IF ! Broadcast the new particle positions and deallocate pos part of temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) IF(shell_adiabatic .AND. shell_check_distance) THEN CALL optimize_shell_core(force_env, particle_set,& - shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE., error=error) + shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE.) END IF ! Update forces @@ -537,12 +532,12 @@ SUBROUTINE nve ( md_env, globenv, error) ALLOCATE(v_old(3,SIZE(tmp%vel,2))) v_old(:,:)=tmp%vel CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error ) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & core_particle_set, para_env, shell_adiabatic, vel=.TRUE.,& - should_deall_vel=.FALSE.,error=error ) + should_deall_vel=.FALSE.) tmp%vel=v_old - CALL get_qs_env(force_env%qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(force_env%qs_env, dft_control=dft_control) n_iter=dft_control%rtp_control%max_iter ELSE n_iter=1 @@ -551,37 +546,36 @@ SUBROUTINE nve ( md_env, globenv, error) DO i_iter=1,n_iter IF(ehrenfest_md)THEN - CALL get_qs_env(qs_env=force_env%qs_env,rtp=rtp,error=error) + CALL get_qs_env(qs_env=force_env%qs_env,rtp=rtp) rtp%iter=i_iter tmp%vel=v_old - CALL propagation_step(force_env%qs_env, rtp, dft_control%rtp_control, error=error) + CALL propagation_step(force_env%qs_env, rtp, dft_control%rtp_control) END IF ![NB] let nve work with force mixing which does not have consistent energies and forces - CALL force_env_calc_energy_force(force_env,require_consistent_energy_force=.FALSE.,error=error) + CALL force_env_calc_energy_force(force_env,require_consistent_energy_force=.FALSE.) IF(ehrenfest_md)THEN - CALL rt_prop_output(force_env%qs_env,ehrenfest,delta_iter=force_env%qs_env%rtp%delta_iter,error=error) + CALL rt_prop_output(force_env%qs_env,ehrenfest,delta_iter=force_env%qs_env%rtp%delta_iter) ENDIF ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel) ! Velocity Verlet (second part) CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error ) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) IF (simpar%constraint) CALL rattle_control(gci,local_molecules, molecule_set, & molecule_kind_set, particle_set, tmp%vel, dt,simpar%shake_tol,& simpar%info_constraint,simpar%lagrange_multipliers,simpar%dump_lm,& - cell,para_env%group,local_particles, error ) + cell,para_env%group,local_particles) ! Apply thermostat over the full set of shell if required IF (shell_adiabatic) THEN CALL apply_thermostat_shells(thermostat_shell,atomic_kind_set, particle_set,& local_particles, para_env%group, vel=tmp%vel, & - shell_vel=tmp%shell_vel, core_vel=tmp%core_vel,& - error=error) + shell_vel=tmp%shell_vel, core_vel=tmp%core_vel) END IF IF (simpar%annealing) THEN @@ -597,7 +591,7 @@ SUBROUTINE nve ( md_env, globenv, error) ! Broadcast the new particle velocities and deallocate the full temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & core_particle_set, para_env, shell_adiabatic, vel=.TRUE.,& - should_deall_vel=deallocate_vel,error=error ) + should_deall_vel=deallocate_vel) IF(ehrenfest_md)THEN IF(force_env%qs_env%rtp%converged)EXIT END IF @@ -609,14 +603,13 @@ SUBROUTINE nve ( md_env, globenv, error) molecule_set,molecule_kind_set,particle_set, virial,para_env%group ) CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group ,error=error) + local_particles, virial, para_env%group) END SUBROUTINE nve ! ***************************************************************************** !> \brief simplest version of the isokinetic gaussian thermostat !> \param md_env ... -!> \param error ... !> \par History !> - Created [2004-07] !> \author Joost VandeVondele @@ -628,10 +621,9 @@ END SUBROUTINE nve !> - Zhang F. , JCP 106, 6102 (1997) !> - Minary P. et al, JCP 118, 2510 (2003) ! ***************************************************************************** - SUBROUTINE isokin ( md_env, error ) + SUBROUTINE isokin ( md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'isokin', & routineP = moduleN//':'//routineN @@ -666,14 +658,14 @@ SUBROUTINE isokin ( md_env, error ) NULLIFY(core_particle_set,particle_set,shell_particle_set) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,& - para_env=para_env, itimes=itimes, error=error) + para_env=para_env, itimes=itimes) dt = simpar%dt - CALL force_env_get(force_env=force_env,subsys=subsys,error=error) + CALL force_env_get(force_env=force_env,subsys=subsys) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) IF (simpar%constraint) THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -682,7 +674,7 @@ SUBROUTINE isokin ( md_env, error ) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,& local_particles=local_particles,& - particles=particles ,error=error) + particles=particles) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -694,7 +686,7 @@ SUBROUTINE isokin ( md_env, error ) IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,shell_particles=shell_particles,& - core_particles=core_particles, error=error) + core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) @@ -703,7 +695,7 @@ SUBROUTINE isokin ( md_env, error ) END IF END IF - CALL allocate_tmp (md_env,tmp, nparticle, nshell, shell_adiabatic, error=error) + CALL allocate_tmp (md_env,tmp, nparticle, nshell, shell_adiabatic) ! compute s,ds CALL get_s_ds(tmp, nparticle_kind, atomic_kind_set, local_particles, particle_set,& @@ -714,21 +706,21 @@ SUBROUTINE isokin ( md_env, error ) tmp%poly_v(1:3) = 2.0_dp*tmp%s/SQRT(tmp%ds)/dt CALL vv_first(tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error) + shell_adiabatic, dt) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar,para_env,atomic_kind_set, & local_particles, particle_set, core_particle_set, shell_particle_set,& - nparticle_kind, shell_adiabatic,error=error) + nparticle_kind, shell_adiabatic) ! Broadcast the new particle positions and deallocate the pos components of temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) - CALL force_env_calc_energy_force(force_env,error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel) ! compute s,ds CALL get_s_ds(tmp, nparticle_kind, atomic_kind_set, local_particles, particle_set,& @@ -739,30 +731,28 @@ SUBROUTINE isokin ( md_env, error ) tmp%poly_v(1:3) = 2.0_dp*tmp%s/SQRT(tmp%ds)/dt CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error) + shell_adiabatic, dt) IF (simpar%annealing) tmp%vel(:,:)=tmp%vel(:,:)*simpar%f_annealing ! Broadcast the new particle velocities and deallocate the temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, vel=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) END SUBROUTINE isokin ! ***************************************************************************** !> \brief nvt adiabatic integrator for particle positions & momenta !> \param md_env ... !> \param globenv ... -!> \param error ... !> \par History !> - the local particle lists are used instead of pnode (Sep. 2003,MK) !> - usage of fragments retrieved from the force environment (Oct. 2003,MK) !> \author CJM ! ***************************************************************************** - SUBROUTINE nvt_adiabatic ( md_env, globenv, error) + SUBROUTINE nvt_adiabatic ( md_env, globenv) TYPE(md_environment_type), POINTER :: md_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nvt_adiabatic', & routineP = moduleN//':'//routineN @@ -819,17 +809,17 @@ SUBROUTINE nvt_adiabatic ( md_env, globenv, error) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,& thermostat_fast=thermostat_fast, thermostat_slow=thermostat_slow,& thermostat_coeff=thermostat_coeff, thermostat_shell=thermostat_shell, & - para_env=para_env, itimes=itimes, error=error) + para_env=para_env, itimes=itimes) dt = simpar%dt - CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell,error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules,& - molecule_kinds_new=molecule_kinds,gci=gci,virial=virial,error=error) + molecule_kinds_new=molecule_kinds,gci=gci,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -847,7 +837,7 @@ SUBROUTINE nvt_adiabatic ( md_env, globenv, error) ! Allocate random number for Langevin Thermostat acting on COLVARS IF(force_env%meta_env%langevin) THEN ALLOCATE (rand(force_env%meta_env%n_colvar),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rand(:) = 0.0_dp ENDIF ENDIF @@ -855,7 +845,7 @@ SUBROUTINE nvt_adiabatic ( md_env, globenv, error) ! Allocate work storage for positions and velocities IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,shell_particles=shell_particles,& - core_particles=core_particles, error=error) + core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) @@ -864,108 +854,107 @@ SUBROUTINE nvt_adiabatic ( md_env, globenv, error) END IF END IF - CALL allocate_tmp(md_env, tmp, nparticle,nshell,shell_adiabatic,error=error) + CALL allocate_tmp(md_env, tmp, nparticle,nshell,shell_adiabatic) ! Apply Thermostat over the full set of particles IF(shell_adiabatic) THEN ! CALL apply_thermostat_particles(thermostat_part, molecule_kind_set, molecule_set,& ! particle_set, local_molecules, para_env%group, shell_adiabatic=shell_adiabatic,& -! shell_particle_set=shell_particle_set, core_particle_set=core_particle_set,& -! error=error) +! shell_particle_set=shell_particle_set, core_particle_set=core_particle_set) CALL apply_thermostat_shells(thermostat_shell, atomic_kind_set, particle_set,& local_particles, para_env%group, shell_particle_set=shell_particle_set,& - core_particle_set=core_particle_set, error=error) + core_particle_set=core_particle_set) ELSE CALL apply_thermostat_particles(thermostat_fast, force_env, molecule_kind_set, molecule_set,& - particle_set, local_molecules, local_particles, para_env%group ,error=error) + particle_set, local_molecules, local_particles, para_env%group) CALL apply_thermostat_particles(thermostat_slow, force_env, molecule_kind_set, molecule_set,& - particle_set, local_molecules, local_particles, para_env%group ,error=error) + particle_set, local_molecules, local_particles, para_env%group) END IF IF (simpar%constraint) CALL getold( gci, local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ! *** Velocity Verlet for Langeving *** v(t)--> v(t+1/2) IF (ASSOCIATED(force_env%meta_env)) THEN IF(force_env%meta_env%langevin) THEN DO ivar = 1 , force_env%meta_env%n_colvar rng_stream => force_env%meta_env%rng(ivar)%stream - rand(ivar)=next_random_number(rng_stream,error=error) + rand(ivar)=next_random_number(rng_stream) ENDDO - CALL metadyn_velocities_colvar(force_env,rand,error=error) + CALL metadyn_velocities_colvar(force_env,rand) ENDIF ENDIF ! Velocity Verlet (first part) CALL vv_first(tmp, atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar,para_env,atomic_kind_set,& local_particles, particle_set, core_particle_set, shell_particle_set,& - nparticle_kind, shell_adiabatic,error=error) + nparticle_kind, shell_adiabatic) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) CALL shake_control( gci, local_molecules, molecule_set, & molecule_kind_set, particle_set,tmp%pos, tmp%vel, dt,simpar%shake_tol,& simpar%info_constraint,simpar%lagrange_multipliers,simpar%dump_lm,& - cell, para_env%group,local_particles,error ) + cell, para_env%group,local_particles) END IF ! Broadcast the new particle positions and deallocate pos components of temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) IF(shell_adiabatic .AND. shell_check_distance) THEN CALL optimize_shell_core(force_env, particle_set,& - shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE., error=error) + shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE.) END IF ! Update forces - CALL force_env_calc_energy_force(force_env,error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, rand=rand, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel, rand=rand) ! Velocity Verlet (second part) CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) IF (simpar%constraint) CALL rattle_control( gci, local_molecules, molecule_set, & molecule_kind_set, particle_set, tmp%vel, dt,simpar%shake_tol,& simpar%info_constraint,simpar%lagrange_multipliers,simpar%dump_lm,& - cell,para_env%group,local_particles, error ) + cell,para_env%group,local_particles) ! Apply Thermostat over the full set of particles IF (shell_adiabatic) THEN ! CALL apply_thermostat_particles(thermostat_part,molecule_kind_set, molecule_set, & ! particle_set, local_molecules, para_env%group, shell_adiabatic=shell_adiabatic,& - ! vel= tmp%vel, shell_vel= tmp%shell_vel, core_vel= tmp%core_vel, error=error) + ! vel= tmp%vel, shell_vel= tmp%shell_vel, core_vel= tmp%core_vel) CALL apply_thermostat_shells(thermostat_shell,atomic_kind_set, particle_set,& local_particles, para_env%group, vel= tmp%vel, shell_vel= tmp%shell_vel, & - core_vel= tmp%core_vel, error=error) + core_vel= tmp%core_vel) ELSE CALL apply_thermostat_particles(thermostat_slow, force_env,molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, para_env%group, vel= tmp%vel, error=error) + particle_set, local_molecules, local_particles, para_env%group, vel= tmp%vel) CALL apply_thermostat_particles(thermostat_fast, force_env,molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, para_env%group, vel= tmp%vel, error=error) + particle_set, local_molecules, local_particles, para_env%group, vel= tmp%vel) END IF ! Broadcast the new particle velocities and deallocate temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, vel=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) IF (ASSOCIATED(force_env%meta_env)) THEN IF(force_env%meta_env%langevin) THEN DEALLOCATE(rand,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ENDIF @@ -975,7 +964,7 @@ SUBROUTINE nvt_adiabatic ( md_env, globenv, error) ! ** Evaluate Virial CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group, error=error) + local_particles, virial, para_env%group) END SUBROUTINE nvt_adiabatic @@ -984,17 +973,15 @@ END SUBROUTINE nvt_adiabatic !> \brief nvt integrator for particle positions & momenta !> \param md_env ... !> \param globenv ... -!> \param error ... !> \par History !> - the local particle lists are used instead of pnode (Sep. 2003,MK) !> - usage of fragments retrieved from the force environment (Oct. 2003,MK) !> \author CJM ! ***************************************************************************** - SUBROUTINE nvt ( md_env, globenv, error) + SUBROUTINE nvt ( md_env, globenv) TYPE(md_environment_type), POINTER :: md_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nvt', & routineP = moduleN//':'//routineN @@ -1049,17 +1036,17 @@ SUBROUTINE nvt ( md_env, globenv, error) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,& thermostat_part=thermostat_part, thermostat_coeff=thermostat_coeff,& thermostat_shell=thermostat_shell,para_env=para_env,& - itimes=itimes, error=error) + itimes=itimes) dt = simpar%dt - CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell,error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules,& - molecule_kinds_new=molecule_kinds,gci=gci,virial=virial,error=error) + molecule_kinds_new=molecule_kinds,gci=gci,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1077,7 +1064,7 @@ SUBROUTINE nvt ( md_env, globenv, error) ! Allocate random number for Langevin Thermostat acting on COLVARS IF(force_env%meta_env%langevin) THEN ALLOCATE (rand(force_env%meta_env%n_colvar),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rand(:) = 0.0_dp ENDIF ENDIF @@ -1085,7 +1072,7 @@ SUBROUTINE nvt ( md_env, globenv, error) ! Allocate work storage for positions and velocities IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,shell_particles=shell_particles,& - core_particles=core_particles, error=error) + core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) @@ -1094,76 +1081,75 @@ SUBROUTINE nvt ( md_env, globenv, error) END IF END IF - CALL allocate_tmp(md_env, tmp, nparticle,nshell,shell_adiabatic,error=error) + CALL allocate_tmp(md_env, tmp, nparticle,nshell,shell_adiabatic) ! Apply Thermostat over the full set of particles IF(shell_adiabatic) THEN CALL apply_thermostat_particles(thermostat_part, force_env, molecule_kind_set, molecule_set,& particle_set, local_molecules, local_particles, para_env%group, shell_adiabatic=shell_adiabatic,& - shell_particle_set=shell_particle_set, core_particle_set=core_particle_set,& - error=error) + shell_particle_set=shell_particle_set, core_particle_set=core_particle_set) CALL apply_thermostat_shells(thermostat_shell, atomic_kind_set, particle_set,& local_particles, para_env%group, shell_particle_set=shell_particle_set,& - core_particle_set=core_particle_set, error=error) + core_particle_set=core_particle_set) ELSE CALL apply_thermostat_particles(thermostat_part, force_env, molecule_kind_set, molecule_set,& - particle_set, local_molecules, local_particles, para_env%group ,error=error) + particle_set, local_molecules, local_particles, para_env%group) END IF IF (simpar%constraint) CALL getold( gci, local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ! *** Velocity Verlet for Langeving *** v(t)--> v(t+1/2) IF (ASSOCIATED(force_env%meta_env)) THEN IF(force_env%meta_env%langevin) THEN DO ivar = 1 , force_env%meta_env%n_colvar rng_stream => force_env%meta_env%rng(ivar)%stream - rand(ivar)=next_random_number(rng_stream,error=error) + rand(ivar)=next_random_number(rng_stream) ENDDO - CALL metadyn_velocities_colvar(force_env,rand,error=error) + CALL metadyn_velocities_colvar(force_env,rand) ENDIF ENDIF ! Velocity Verlet (first part) CALL vv_first(tmp, atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar,para_env,atomic_kind_set,& local_particles, particle_set, core_particle_set, shell_particle_set,& - nparticle_kind, shell_adiabatic,error=error) + nparticle_kind, shell_adiabatic) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) CALL shake_control( gci, local_molecules, molecule_set, & molecule_kind_set, particle_set,tmp%pos, tmp%vel, dt,simpar%shake_tol,& simpar%info_constraint,simpar%lagrange_multipliers,simpar%dump_lm,& - cell, para_env%group,local_particles,error ) + cell, para_env%group,local_particles) END IF ! Broadcast the new particle positions and deallocate pos components of temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) IF(shell_adiabatic .AND. shell_check_distance) THEN CALL optimize_shell_core(force_env, particle_set,& - shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE., error=error) + shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE.) END IF ![ADAPT] update input structure with new coordinates, make new labels - CALL qmmmx_update_force_env(force_env, force_env%root_section, error=error) + CALL qmmmx_update_force_env(force_env, force_env%root_section) ![NB] recreate pointers changed by creation of new subsys in qmmm_update_force_mixing_env ![NB] ugly hack, which is why adaptivity isn't implemented in most other ensembles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell,error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules,& - molecule_kinds_new=molecule_kinds,gci=gci,virial=virial,error=error) + molecule_kinds_new=molecule_kinds,gci=gci,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1180,7 +1166,7 @@ SUBROUTINE nvt ( md_env, globenv, error) ! Allocate work storage for positions and velocities IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,shell_particles=shell_particles,& - core_particles=core_particles, error=error) + core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) @@ -1192,42 +1178,42 @@ SUBROUTINE nvt ( md_env, globenv, error) ! Update forces ![NB] let nvt work with force mixing which does not have consistent energies and forces - CALL force_env_calc_energy_force(force_env,require_consistent_energy_force=.FALSE.,error=error) + CALL force_env_calc_energy_force(force_env,require_consistent_energy_force=.FALSE.) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, rand=rand, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel, rand=rand) ! Velocity Verlet (second part) CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) IF (simpar%constraint) CALL rattle_control( gci, local_molecules, molecule_set, & molecule_kind_set, particle_set, tmp%vel, dt,simpar%shake_tol,& simpar%info_constraint,simpar%lagrange_multipliers,simpar%dump_lm,& - cell,para_env%group,local_particles, error ) + cell,para_env%group,local_particles) ! Apply Thermostat over the full set of particles IF (shell_adiabatic) THEN CALL apply_thermostat_particles(thermostat_part, force_env,molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, para_env%group, shell_adiabatic=shell_adiabatic,& - vel= tmp%vel, shell_vel= tmp%shell_vel, core_vel= tmp%core_vel, error=error) + vel= tmp%vel, shell_vel= tmp%shell_vel, core_vel= tmp%core_vel) CALL apply_thermostat_shells(thermostat_shell,atomic_kind_set, particle_set,& local_particles, para_env%group, vel= tmp%vel, shell_vel= tmp%shell_vel, & - core_vel= tmp%core_vel, error=error) + core_vel= tmp%core_vel) ELSE CALL apply_thermostat_particles(thermostat_part, force_env,molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, para_env%group, vel= tmp%vel, error=error) + particle_set, local_molecules, local_particles, para_env%group, vel= tmp%vel) END IF ! Broadcast the new particle velocities and deallocate temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, vel=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) IF (ASSOCIATED(force_env%meta_env)) THEN IF(force_env%meta_env%langevin) THEN DEALLOCATE(rand,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ENDIF @@ -1237,7 +1223,7 @@ SUBROUTINE nvt ( md_env, globenv, error) ! ** Evaluate Virial CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group, error=error) + local_particles, virial, para_env%group) END SUBROUTINE nvt @@ -1246,16 +1232,14 @@ END SUBROUTINE nvt !> isotropic box changes !> \param md_env ... !> \param globenv ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE npt_i ( md_env, globenv, error ) + SUBROUTINE npt_i ( md_env, globenv) TYPE(md_environment_type), POINTER :: md_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'npt_i', & routineP = moduleN//':'//routineN @@ -1322,18 +1306,18 @@ SUBROUTINE npt_i ( md_env, globenv, error ) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,& thermostat_part=thermostat_part, thermostat_baro=thermostat_baro,& thermostat_shell=thermostat_shell, npt=npt, first_time=first_time,& - para_env=para_env, itimes=itimes, error=error) + para_env=para_env, itimes=itimes) dt = simpar%dt infree = 1.0_dp / REAL ( simpar%nfree,KIND=dp) - CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell, error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules, & - gci=gci,molecule_kinds_new=molecule_kinds,virial=virial,error=error) + gci=gci,molecule_kinds_new=molecule_kinds,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1349,25 +1333,24 @@ SUBROUTINE npt_i ( md_env, globenv, error ) IF ( first_time ) THEN CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group, error=error) + local_particles, virial, para_env%group) END IF ! Allocate work storage for positions and velocities - CALL allocate_old ( old, particle_set, npt, error=error ) + CALL allocate_old ( old, particle_set, npt) IF (ASSOCIATED(force_env%meta_env)) THEN ! Allocate random number for Langevin Thermostat acting on COLVARS IF(force_env%meta_env%langevin) THEN ALLOCATE (rand(force_env%meta_env%n_colvar),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rand(:) = 0.0_dp ENDIF ENDIF IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,& - shell_particles=shell_particles, core_particles=core_particles,& - error=error) + shell_particles=shell_particles, core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) IF(shell_adiabatic) THEN @@ -1375,37 +1358,36 @@ SUBROUTINE npt_i ( md_env, globenv, error ) END IF END IF - CALL allocate_tmp(md_env, tmp, nparticle, nshell, shell_adiabatic, error=error) + CALL allocate_tmp(md_env, tmp, nparticle, nshell, shell_adiabatic) ! Initialize eps_0 the first time through IF ( first_time ) eps_0 = npt (1,1)%eps ! Apply thermostat to barostat - CALL apply_thermostat_baro( thermostat_baro, npt, para_env%group, error) + CALL apply_thermostat_baro( thermostat_baro, npt, para_env%group) ! Apply Thermostat over the full set of particles IF(simpar% ensemble /= npe_i_ensemble) THEN IF(shell_adiabatic) THEN CALL apply_thermostat_particles(thermostat_part, force_env, molecule_kind_set, molecule_set,& particle_set, local_molecules, local_particles, para_env%group,shell_adiabatic=shell_adiabatic,& - shell_particle_set=shell_particle_set, core_particle_set=core_particle_set,& - error=error) + shell_particle_set=shell_particle_set, core_particle_set=core_particle_set) ELSE CALL apply_thermostat_particles(thermostat_part, force_env, molecule_kind_set, molecule_set,& - particle_set, local_molecules, local_particles, para_env%group ,error=error) + particle_set, local_molecules, local_particles, para_env%group) END IF END IF ! Apply Thermostat over the core-shell motion CALL apply_thermostat_shells(thermostat_shell, atomic_kind_set, particle_set,& local_particles, para_env%group, shell_particle_set=shell_particle_set,& - core_particle_set=core_particle_set, error=error) + core_particle_set=core_particle_set) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) END IF ! setting up for ROLL: saving old variables @@ -1414,7 +1396,7 @@ SUBROUTINE npt_i ( md_env, globenv, error ) iroll = 1 CALL set ( old, atomic_kind_set, particle_set, local_particles, cell, npt, 'F' ) CALL getold ( gci, local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ELSE roll_tol_thrs = EPSILON(0.0_dp) ENDIF @@ -1425,9 +1407,9 @@ SUBROUTINE npt_i ( md_env, globenv, error ) IF(force_env%meta_env%langevin) THEN DO ivar = 1 , force_env%meta_env%n_colvar rng_stream => force_env%meta_env%rng(ivar)%stream - rand(ivar)=next_random_number(rng_stream,error=error) + rand(ivar)=next_random_number(rng_stream) ENDDO - CALL metadyn_velocities_colvar(force_env,rand,error=error) + CALL metadyn_velocities_colvar(force_env,rand) ENDIF ENDIF @@ -1460,11 +1442,11 @@ SUBROUTINE npt_i ( md_env, globenv, error ) ! first half of velocity verlet CALL vv_first( tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error ) + shell_adiabatic, dt) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar,para_env,& atomic_kind_set, local_particles, particle_set, core_particle_set,& - shell_particle_set, nparticle_kind, shell_adiabatic, npt=npt,error=error) + shell_particle_set, nparticle_kind, shell_adiabatic, npt=npt) roll_tol = 0.0_dp @@ -1474,7 +1456,7 @@ SUBROUTINE npt_i ( md_env, globenv, error ) IF ( simpar%constraint ) CALL shake_roll_control( gci, local_molecules, & molecule_set, molecule_kind_set, particle_set, tmp%pos, tmp%vel, dt, simpar, & roll_tol, iroll, vector_r, vector_v, para_env%group, cell=cell, & - local_particles=local_particles, error=error ) + local_particles=local_particles) END DO SR ! Update eps: @@ -1490,23 +1472,23 @@ SUBROUTINE npt_i ( md_env, globenv, error ) ! Broadcast the new particle positions and deallocate the pos components of temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) IF(shell_adiabatic .AND. shell_check_distance) THEN CALL optimize_shell_core(force_env, particle_set,& - shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE., error=error) + shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE.) END IF ! Update forces - CALL force_env_calc_energy_force(force_env,error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, rand=rand, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel, rand=rand) ! Velocity Verlet (second part) CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error ) + shell_adiabatic, dt) IF (simpar%constraint) THEN roll_tol_thrs = simpar%roll_tol @@ -1523,7 +1505,7 @@ SUBROUTINE npt_i ( md_env, globenv, error ) IF ( simpar%constraint ) CALL rattle_roll_setup ( old, gci, atomic_kind_set, & particle_set, local_particles, molecule_kind_set, molecule_set, & local_molecules, tmp%vel, dt, cell, npt, simpar, virial, vector_v, & - roll_tol, iroll, infree, first, para_env,error=error) + roll_tol, iroll, infree, first, para_env) CALL update_pv ( gci, simpar, atomic_kind_set, tmp%vel, particle_set, & local_molecules, molecule_set, molecule_kind_set, & @@ -1536,10 +1518,10 @@ SUBROUTINE npt_i ( md_env, globenv, error ) IF (shell_adiabatic) THEN CALL apply_thermostat_particles(thermostat_part, force_env,molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, para_env%group, shell_adiabatic=shell_adiabatic,& - vel=tmp%vel, shell_vel=tmp%shell_vel, core_vel=tmp%core_vel, error=error) + vel=tmp%vel, shell_vel=tmp%shell_vel, core_vel=tmp%core_vel) ELSE CALL apply_thermostat_particles(thermostat_part, force_env,molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, para_env%group, vel=tmp%vel, error=error) + particle_set, local_molecules, local_particles, para_env%group, vel=tmp%vel) END IF END IF @@ -1548,11 +1530,11 @@ SUBROUTINE npt_i ( md_env, globenv, error ) IF(ASSOCIATED(thermostat_shell)) THEN CALL apply_thermostat_shells(thermostat_shell,atomic_kind_set, particle_set,& local_particles, para_env%group, vel=tmp%vel, shell_vel=tmp%shell_vel, & - core_vel=tmp%core_vel, error=error) + core_vel=tmp%core_vel) END IF ! Apply Thermostat to Barostat - CALL apply_thermostat_baro( thermostat_baro, npt, para_env%group, error) + CALL apply_thermostat_baro( thermostat_baro, npt, para_env%group) ! Annealing of particle velocities is only possible when no thermostat is active IF (simpar% ensemble == npe_i_ensemble .AND. simpar%annealing) THEN @@ -1570,28 +1552,28 @@ SUBROUTINE npt_i ( md_env, globenv, error ) ! Broadcast the new particle velocities and deallocate temporary CALL update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, vel=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial IF ( simpar%constraint ) CALL pv_constraint ( gci, local_molecules, & molecule_set, molecule_kind_set, particle_set, virial, para_env%group ) CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group , error=error) + local_particles, virial, para_env%group) ! Deallocate old variables - CALL deallocate_old (old, error=error ) + CALL deallocate_old (old) IF (ASSOCIATED(force_env%meta_env)) THEN IF(force_env%meta_env%langevin) THEN DEALLOCATE(rand,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ENDIF IF (first_time) THEN first_time = .FALSE. - CALL set_md_env(md_env, first_time=first_time,error=error) + CALL set_md_env(md_env, first_time=first_time) END IF END SUBROUTINE npt_i @@ -1599,16 +1581,14 @@ END SUBROUTINE npt_i ! ***************************************************************************** !> \brief uses coordinates in a file and generates frame after frame of these !> \param md_env ... -!> \param error ... !> \par History !> - 04.2005 created [Joost VandeVondele] !> - modified to make it more general [MI] !> \note !> it can be used to compute some properties on already available trajectories ! ***************************************************************************** - SUBROUTINE reftraj ( md_env, error ) + SUBROUTINE reftraj ( md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reftraj', & routineP = moduleN//':'//routineN @@ -1634,48 +1614,47 @@ SUBROUTINE reftraj ( md_env, error ) failure = .FALSE. NULLIFY(reftraj_env, particle_set, particles, force_env, subsys, simpar, para_env, cell, itimes, time) CALL get_md_env(md_env=md_env, init=init, reftraj=reftraj_env, force_env=force_env,& - para_env=para_env, simpar=simpar, error=error) + para_env=para_env, simpar=simpar) - CALL force_env_get(force_env=force_env, cell=cell, subsys=subsys, & - error=error) + CALL force_env_get(force_env=force_env, cell=cell, subsys=subsys) reftraj_env%isnap = reftraj_env%isnap + reftraj_env%info%stride ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) - CALL cp_subsys_get(subsys=subsys, particles=particles, error=error) + CALL apply_qmmm_walls_reflective(force_env) + CALL cp_subsys_get(subsys=subsys, particles=particles) nparticle = particles%n_els particle_set => particles%els ! SnapShots read from an external file (parsers calls are buffered! please ! don't put any additional MPI call!) [tlaino] - CALL parser_read_line(reftraj_env%info%traj_parser,1,error=error) + CALL parser_read_line(reftraj_env%info%traj_parser,1) READ(reftraj_env%info%traj_parser%input_line,FMT="(I8)") nread - CPPostcondition(nread==nparticle,cp_failure_level,routineP,error,failure) - CALL parser_read_line(reftraj_env%info%traj_parser,1,error=error) + CPPostcondition(nread==nparticle,cp_failure_level,routineP,failure) + CALL parser_read_line(reftraj_env%info%traj_parser,1) test_ok = .FALSE. READ(reftraj_env%info%traj_parser%input_line,FMT="(T6,I8,T23,F12.3,T41,F20.10)",ERR=999)& trj_itimes, trj_time, trj_epot test_ok = .TRUE. 999 IF (.NOT.test_ok) THEN ! Handling properly the error when reading the title of an XYZ - CALL get_md_env(md_env, itimes=itimes, error=error) + CALL get_md_env(md_env, itimes=itimes) trj_itimes = itimes trj_time = 0.0_dp trj_epot = 0.0_dp END IF DO i = 1,nread-1 - CALL parser_read_line(reftraj_env%info%traj_parser,1,error=error) + CALL parser_read_line(reftraj_env%info%traj_parser,1) READ(reftraj_env%info%traj_parser%input_line(1:LEN_TRIM(reftraj_env%info%traj_parser%input_line)),*) AA,particle_set(i)%r particle_set(i)%r = particle_set(i)%r*bohr END DO ! End of file is properly addressed in the previous call.. ! Let's check directly (providing some info) also for the last ! line of this frame.. - CALL parser_read_line(reftraj_env%info%traj_parser,1,at_end=my_end,error=error) + CALL parser_read_line(reftraj_env%info%traj_parser,1,at_end=my_end) READ(unit=reftraj_env%info%traj_parser%input_line,fmt=*) AA,particle_set(i)%r - particle_set(i)%r(1) = cp_unit_to_cp2k(particle_set(i)%r(1),"angstrom",error=error) - particle_set(i)%r(2) = cp_unit_to_cp2k(particle_set(i)%r(2),"angstrom",error=error) - particle_set(i)%r(3) = cp_unit_to_cp2k(particle_set(i)%r(3),"angstrom",error=error) + particle_set(i)%r(1) = cp_unit_to_cp2k(particle_set(i)%r(1),"angstrom") + particle_set(i)%r(2) = cp_unit_to_cp2k(particle_set(i)%r(2),"angstrom") + particle_set(i)%r(3) = cp_unit_to_cp2k(particle_set(i)%r(3),"angstrom") ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN @@ -1687,9 +1666,9 @@ SUBROUTINE reftraj ( md_env, error ) END IF IF(reftraj_env%info%variable_volume)THEN - CALL parser_get_next_line(reftraj_env%info%cell_parser,1,at_end=my_end,error=error) - CALL parse_cell_line(reftraj_env%info%cell_parser%input_line, cell_itimes, cell_time, h, vol, error) - CPPostcondition(trj_itimes==cell_itimes,cp_failure_level,routineP,error,failure) + CALL parser_get_next_line(reftraj_env%info%cell_parser,1,at_end=my_end) + CALL parse_cell_line(reftraj_env%info%cell_parser%input_line, cell_itimes, cell_time, h, vol) + CPPostcondition(trj_itimes==cell_itimes,cp_failure_level,routineP,failure) ! Check if we reached the end of the file and provide some info.. IF (my_end) THEN CALL cp_assert(reftraj_env%isnap==(simpar%nsteps-1),cp_fatal_level,cp_assertion_failed,routineP,& @@ -1711,7 +1690,7 @@ SUBROUTINE reftraj ( md_env, error ) reftraj_env%epot = trj_epot reftraj_env%itimes = trj_itimes reftraj_env%time = trj_time/femtoseconds - CALL get_md_env(md_env, t=time, error=error) + CALL get_md_env(md_env, t=time) time = reftraj_env%time @@ -1721,27 +1700,27 @@ SUBROUTINE reftraj ( md_env, error ) END IF ![ADAPT] update input structure with new coordinates, make new labels - CALL qmmmx_update_force_env(force_env, force_env%root_section, error=error) + CALL qmmmx_update_force_env(force_env, force_env%root_section) ! no pointers into force_env%subsys to update ! Task to perform on the reference trajectory ! Compute energy and forces ![NB] let reftraj work with force mixing which does not have consistent energies and forces CALL force_env_calc_energy_force(force_env,eval_energy_forces=reftraj_env%info%eval_EF,& - require_consistent_energy_force=.FALSE., error=error) + require_consistent_energy_force=.FALSE.) ! Metadynamics - CALL metadyn_integrator(force_env, trj_itimes, error=error) + CALL metadyn_integrator(force_env, trj_itimes) ! Compute MSD with respect to a reference configuration IF(reftraj_env%info%msd) THEN - CALL compute_msd_reftraj(reftraj_env,md_env, particle_set,error=error) + CALL compute_msd_reftraj(reftraj_env,md_env, particle_set) END IF ! Skip according the stride both Trajectory and Cell (if possible) - CALL parser_get_next_line(reftraj_env%info%traj_parser,(reftraj_env%info%stride-1)*(nparticle+2),error=error) + CALL parser_get_next_line(reftraj_env%info%traj_parser,(reftraj_env%info%stride-1)*(nparticle+2)) IF(reftraj_env%info%variable_volume)THEN - CALL parser_get_next_line(reftraj_env%info%cell_parser,(reftraj_env%info%stride-1),error=error) + CALL parser_get_next_line(reftraj_env%info%cell_parser,(reftraj_env%info%stride-1)) END IF END SUBROUTINE reftraj @@ -1752,15 +1731,13 @@ END SUBROUTINE reftraj !> due to a shock compression: !> Reed et. al. Physical Review Letters 90, 235503 (2003). !> \param md_env ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE nph_uniaxial ( md_env, error ) + SUBROUTINE nph_uniaxial ( md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nph_uniaxial', & routineP = moduleN//':'//routineN @@ -1815,18 +1792,18 @@ SUBROUTINE nph_uniaxial ( md_env, error ) NULLIFY(simpar,virial,itimes) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,npt = npt,& - first_time=first_time, para_env=para_env, itimes=itimes, error=error) + first_time=first_time, para_env=para_env, itimes=itimes) dt = simpar%dt infree = 1.0_dp / REAL ( simpar%nfree, dp ) - CALL force_env_get(force_env, subsys=subsys, cell=cell ,error=error) + CALL force_env_get(force_env, subsys=subsys, cell=cell) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules, molecules_new=molecules, gci=gci,& - molecule_kinds_new=molecule_kinds,virial=virial,error=error) + molecule_kinds_new=molecule_kinds,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1838,19 +1815,18 @@ SUBROUTINE nph_uniaxial ( md_env, error ) IF ( first_time ) THEN CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group ,error=error) + local_particles, virial, para_env%group) END IF CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& shell_present=shell_present,shell_adiabatic=shell_adiabatic) ! Allocate work storage for positions and velocities - CALL allocate_old ( old, particle_set, npt, error=error ) + CALL allocate_old ( old, particle_set, npt) IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,& - shell_particles=shell_particles, core_particles=core_particles,& - error=error) + shell_particles=shell_particles, core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) IF(shell_adiabatic) THEN @@ -1858,12 +1834,12 @@ SUBROUTINE nph_uniaxial ( md_env, error ) END IF END IF - CALL allocate_tmp(md_env, tmp,nparticle, nshell, shell_adiabatic, error=error) + CALL allocate_tmp(md_env, tmp,nparticle, nshell, shell_adiabatic) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) END IF ! setting up for ROLL: saving old variables @@ -1872,7 +1848,7 @@ SUBROUTINE nph_uniaxial ( md_env, error ) iroll = 1 CALL set ( old, atomic_kind_set, particle_set, local_particles, cell, npt, 'F' ) CALL getold ( gci, local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ELSE roll_tol_thrs = EPSILON(0.0_dp) ENDIF @@ -1919,11 +1895,11 @@ SUBROUTINE nph_uniaxial ( md_env, error ) ! first half of velocity verlet CALL vv_first( tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error ) + shell_adiabatic, dt) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar,para_env,& atomic_kind_set, local_particles, particle_set, core_particle_set,& - shell_particle_set, nparticle_kind, shell_adiabatic, npt=npt, error=error) + shell_particle_set, nparticle_kind, shell_adiabatic, npt=npt) roll_tol = 0._dp @@ -1934,7 +1910,7 @@ SUBROUTINE nph_uniaxial ( md_env, error ) IF ( simpar%constraint ) CALL shake_roll_control( gci, local_molecules, & molecule_set, molecule_kind_set, particle_set, tmp%pos, tmp%vel, dt, simpar,& roll_tol, iroll, vector_r, vector_v, para_env%group, cell=cell, & - local_particles=local_particles, error=error ) + local_particles=local_particles) END DO SR ! Update h_mat @@ -1945,18 +1921,18 @@ SUBROUTINE nph_uniaxial ( md_env, error ) ! Broadcast the new particle positions and deallocate the pos component of temporary CALL update_dealloc_tmp (tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) ! Update forces (and stress) - CALL force_env_calc_energy_force(force_env, error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel) ! Velocity Verlet (second part) CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error ) + shell_adiabatic, dt) IF (simpar%constraint) THEN roll_tol_thrs = simpar%roll_tol @@ -1973,7 +1949,7 @@ SUBROUTINE nph_uniaxial ( md_env, error ) IF ( simpar%constraint ) CALL rattle_roll_setup ( old, gci, atomic_kind_set, & particle_set, local_particles, molecule_kind_set, molecule_set, & local_molecules, tmp%vel, dt, cell, npt, simpar, virial, vector_v, & - roll_tol, iroll, infree, first, para_env, error=error ) + roll_tol, iroll, infree, first, para_env) CALL update_pv ( gci, simpar, atomic_kind_set, tmp%vel, particle_set, & local_molecules, molecule_set, molecule_kind_set, & @@ -1985,21 +1961,21 @@ SUBROUTINE nph_uniaxial ( md_env, error ) ! Broadcast the new particle velocities and deallocate the temporary CALL update_dealloc_tmp (tmp, particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, vel=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial IF ( simpar%constraint ) CALL pv_constraint ( gci, local_molecules, & molecule_set,molecule_kind_set,particle_set, virial, para_env%group ) CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group, error=error) + local_particles, virial, para_env%group) ! Deallocate old variables - CALL deallocate_old ( old, error=error ) + CALL deallocate_old ( old) IF (first_time) THEN first_time = .FALSE. - CALL set_md_env(md_env, first_time=first_time,error=error) + CALL set_md_env(md_env, first_time=first_time) END IF END SUBROUTINE nph_uniaxial @@ -2012,15 +1988,13 @@ END SUBROUTINE nph_uniaxial !> Reed et. al. Physical Review Letters 90, 235503 (2003). !> Added damping (e.g. thermostat to barostat) !> \param md_env ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE nph_uniaxial_damped ( md_env, error ) + SUBROUTINE nph_uniaxial_damped ( md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nph_uniaxial_damped', & routineP = moduleN//':'//routineN @@ -2075,16 +2049,16 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) NULLIFY(simpar,virial,itimes) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,npt = npt,& - first_time=first_time, para_env=para_env, itimes=itimes, error=error) + first_time=first_time, para_env=para_env, itimes=itimes) dt = simpar%dt infree = 1.0_dp / REAL ( simpar%nfree, dp ) gamma1 = simpar%gamma_nph - CALL force_env_get(force_env, subsys=subsys, cell = cell ,error=error) + CALL force_env_get(force_env, subsys=subsys, cell = cell) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules,gci=gci,& - molecule_kinds_new=molecule_kinds,virial=virial,error=error) + molecule_kinds_new=molecule_kinds,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -2096,19 +2070,18 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) IF ( first_time ) THEN CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group , error=error) + local_particles, virial, para_env%group) END IF CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& shell_present=shell_present,shell_adiabatic=shell_adiabatic) ! Allocate work storage for positions and velocities - CALL allocate_old ( old, particle_set, npt, error=error ) + CALL allocate_old ( old, particle_set, npt) IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,& - shell_particles=shell_particles, core_particles=core_particles,& - error=error) + shell_particles=shell_particles, core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) IF(shell_adiabatic) THEN @@ -2116,7 +2089,7 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) END IF END IF - CALL allocate_tmp(md_env, tmp,nparticle, nshell, shell_adiabatic, error=error) + CALL allocate_tmp(md_env, tmp,nparticle, nshell, shell_adiabatic) ! perform damping on velocities CALL damp_v ( molecule_kind_set, molecule_set, particle_set, local_molecules,& @@ -2125,7 +2098,7 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) END IF ! setting up for ROLL: saving old variables @@ -2134,7 +2107,7 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) iroll = 1 CALL set ( old, atomic_kind_set, particle_set, local_particles, cell, npt, 'F' ) CALL getold ( gci, local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ELSE roll_tol_thrs = EPSILON(0.0_dp) ENDIF @@ -2181,12 +2154,12 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) ! first half of velocity verlet CALL vv_first( tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error ) + shell_adiabatic, dt) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar,para_env,& atomic_kind_set, local_particles, particle_set, core_particle_set,& - shell_particle_set, nparticle_kind, shell_adiabatic, npt=npt, error=error) + shell_particle_set, nparticle_kind, shell_adiabatic, npt=npt) roll_tol = 0._dp @@ -2197,7 +2170,7 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) IF ( simpar%constraint ) CALL shake_roll_control( gci, local_molecules, & molecule_set, molecule_kind_set, particle_set, tmp%pos,tmp%vel, dt, simpar,& roll_tol, iroll, vector_r, vector_v, para_env%group, cell=cell,& - local_particles=local_particles, error=error ) + local_particles=local_particles) END DO SR ! Update h_mat @@ -2208,18 +2181,18 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) ! Broadcast the new particle positions and deallocate the pos components of temporary CALL update_dealloc_tmp (tmp,particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) ! Update forces - CALL force_env_calc_energy_force(force_env, error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel) ! Velocity Verlet (second part) CALL vv_second(tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error ) + shell_adiabatic, dt) IF (simpar%constraint) THEN roll_tol_thrs = simpar%roll_tol @@ -2236,7 +2209,7 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) IF ( simpar%constraint ) CALL rattle_roll_setup ( old, gci, atomic_kind_set, & particle_set, local_particles, molecule_kind_set, molecule_set, local_molecules,& tmp%vel, dt, cell, npt, simpar, virial, vector_v, roll_tol, iroll, infree, first,& - para_env, error=error) + para_env) ! perform damping on the barostat momentum CALL damp_veps ( npt ( 1, 1 ), gamma1, dt ) @@ -2258,21 +2231,21 @@ SUBROUTINE nph_uniaxial_damped ( md_env, error ) ! Broadcast the new particle velocities and deallocate temporary CALL update_dealloc_tmp (tmp,particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, vel=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial IF ( simpar%constraint ) CALL pv_constraint ( gci, local_molecules, & molecule_set, molecule_kind_set, particle_set, virial, para_env%group ) CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group, error=error) + local_particles, virial, para_env%group) ! Deallocate old variables - CALL deallocate_old ( old, error=error) + CALL deallocate_old ( old) IF (first_time) THEN first_time = .FALSE. - CALL set_md_env(md_env, first_time=first_time,error=error) + CALL set_md_env(md_env, first_time=first_time) END IF END SUBROUTINE nph_uniaxial_damped @@ -2281,16 +2254,14 @@ END SUBROUTINE nph_uniaxial_damped !> \brief Velocity Verlet integrator for the NPT ensemble with fully flexible cell !> \param md_env ... !> \param globenv ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE npt_f ( md_env, globenv, error ) + SUBROUTINE npt_f ( md_env, globenv) TYPE(md_environment_type), POINTER :: md_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'npt_f', & routineP = moduleN//':'//routineN @@ -2353,18 +2324,18 @@ SUBROUTINE npt_f ( md_env, globenv, error ) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env,& thermostat_part=thermostat_part, thermostat_baro=thermostat_baro,& thermostat_shell=thermostat_shell, npt=npt, first_time=first_time,& - para_env=para_env, barostat=barostat, itimes=itimes, error=error) + para_env=para_env, barostat=barostat, itimes=itimes) dt = simpar%dt infree = 1.0_dp / REAL ( simpar%nfree,KIND=dp) - CALL force_env_get(force_env, subsys=subsys, cell=cell ,error=error) + CALL force_env_get(force_env, subsys=subsys, cell=cell) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds, local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules, & - gci=gci,molecule_kinds_new=molecule_kinds,virial=virial,error=error) + gci=gci,molecule_kinds_new=molecule_kinds,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -2380,16 +2351,15 @@ SUBROUTINE npt_f ( md_env, globenv, error ) IF ( first_time ) THEN CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group ,error=error) + local_particles, virial, para_env%group) END IF ! Allocate work storage for positions and velocities - CALL allocate_old ( old, particle_set, npt, error=error ) + CALL allocate_old ( old, particle_set, npt) IF(shell_present) THEN CALL cp_subsys_get(subsys=subsys,& - shell_particles=shell_particles, core_particles=core_particles,& - error=error) + shell_particles=shell_particles, core_particles=core_particles) shell_particle_set => shell_particles%els nshell = SIZE(shell_particles%els) IF(shell_adiabatic) THEN @@ -2397,33 +2367,32 @@ SUBROUTINE npt_f ( md_env, globenv, error ) END IF END IF - CALL allocate_tmp(md_env, tmp,nparticle, nshell, shell_adiabatic, error=error) + CALL allocate_tmp(md_env, tmp,nparticle, nshell, shell_adiabatic) ! Apply Thermostat to Barostat - CALL apply_thermostat_baro(thermostat_baro, npt, para_env%group, error) + CALL apply_thermostat_baro(thermostat_baro, npt, para_env%group) ! Apply Thermostat over the full set of particles IF(simpar% ensemble /= npe_f_ensemble) THEN IF(shell_adiabatic) THEN CALL apply_thermostat_particles(thermostat_part, force_env, molecule_kind_set, molecule_set,& particle_set, local_molecules, local_particles, para_env%group,shell_adiabatic=shell_adiabatic,& - shell_particle_set=shell_particle_set,core_particle_set=core_particle_set,& - error=error) + shell_particle_set=shell_particle_set,core_particle_set=core_particle_set) ELSE CALL apply_thermostat_particles(thermostat_part, force_env, molecule_kind_set, molecule_set,& - particle_set, local_molecules, local_particles, para_env%group ,error=error) + particle_set, local_molecules, local_particles, para_env%group) END IF END IF ! Apply Thermostat over the core-shell motion CALL apply_thermostat_shells(thermostat_shell, atomic_kind_set, particle_set,& local_particles, para_env%group, shell_particle_set=shell_particle_set,& - core_particle_set=core_particle_set, error=error) + core_particle_set=core_particle_set) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) END IF ! setting up for ROLL: saving old variables @@ -2432,7 +2401,7 @@ SUBROUTINE npt_f ( md_env, globenv, error ) iroll = 1 CALL set ( old, atomic_kind_set, particle_set, local_particles, cell, npt, 'F' ) CALL getold ( gci, local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ELSE roll_tol_thrs = EPSILON(0.0_dp) ENDIF @@ -2471,11 +2440,11 @@ SUBROUTINE npt_f ( md_env, globenv, error ) CALL vv_first(tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, u=tmp%u, error=error) + shell_adiabatic, dt, u=tmp%u) IF(simpar%variable_dt) CALL variable_timestep(md_env,tmp, dt, simpar,para_env,& atomic_kind_set, local_particles, particle_set, core_particle_set,& - shell_particle_set, nparticle_kind, shell_adiabatic,npt=npt,error=error) + shell_particle_set, nparticle_kind, shell_adiabatic,npt=npt) roll_tol = 0.0_dp vector_r = tmp%scale_r*tmp%poly_r @@ -2485,7 +2454,7 @@ SUBROUTINE npt_f ( md_env, globenv, error ) molecule_set, molecule_kind_set, particle_set, tmp%pos, tmp%vel, dt,& simpar, roll_tol, iroll, vector_r, vector_v, & para_env%group, u=tmp%u, cell=cell,& - local_particles=local_particles, error=error ) + local_particles=local_particles) END DO SR ! Update h_mat @@ -2503,23 +2472,23 @@ SUBROUTINE npt_f ( md_env, globenv, error ) ! Broadcast the new particle positions and deallocate the pos components of temporary CALL update_dealloc_tmp (tmp,particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, pos=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, pos=.TRUE.) IF(shell_adiabatic .AND. shell_check_distance) THEN CALL optimize_shell_core(force_env, particle_set,& - shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE., error=error) + shell_particle_set, core_particle_set, globenv, tmp=tmp, check=.TRUE.) END IF ! Update forces - CALL force_env_calc_energy_force(force_env,error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, tmp%vel, error=error) + CALL metadyn_integrator(force_env, itimes, tmp%vel) ! Velocity Verlet (second part) CALL vv_second (tmp, atomic_kind_set, local_particles, particle_set,& core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, tmp%u, error=error ) + shell_adiabatic, dt, tmp%u) IF (simpar%constraint) THEN roll_tol_thrs = simpar%roll_tol @@ -2536,7 +2505,7 @@ SUBROUTINE npt_f ( md_env, globenv, error ) IF ( simpar%constraint ) CALL rattle_roll_setup ( old, gci, atomic_kind_set, & particle_set, local_particles, molecule_kind_set, molecule_set, & local_molecules, tmp%vel, dt, cell, npt, simpar, virial, vector_v, & - roll_tol, iroll, infree, first, para_env, u=tmp%u, error=error) + roll_tol, iroll, infree, first, para_env, u=tmp%u) CALL update_pv ( gci, simpar, atomic_kind_set, tmp%vel, particle_set, & local_molecules, molecule_set, molecule_kind_set, & @@ -2550,11 +2519,11 @@ SUBROUTINE npt_f ( md_env, globenv, error ) IF (shell_adiabatic) THEN CALL apply_thermostat_particles(thermostat_part, force_env,molecule_kind_set, molecule_set, & particle_set, local_molecules, local_particles, para_env%group,shell_adiabatic=shell_adiabatic,& - vel=tmp%vel, shell_vel=tmp%shell_vel, core_vel=tmp%core_vel, error=error) + vel=tmp%vel, shell_vel=tmp%shell_vel, core_vel=tmp%core_vel) ELSE CALL apply_thermostat_particles(thermostat_part, force_env,molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, para_env%group, vel=tmp%vel, error=error) + particle_set, local_molecules, local_particles, para_env%group, vel=tmp%vel) END IF END IF @@ -2562,11 +2531,11 @@ SUBROUTINE npt_f ( md_env, globenv, error ) IF(ASSOCIATED(thermostat_shell)) THEN CALL apply_thermostat_shells(thermostat_shell,atomic_kind_set, particle_set,& local_particles, para_env%group, vel=tmp%vel, shell_vel=tmp%shell_vel, & - core_vel=tmp%core_vel, error=error) + core_vel=tmp%core_vel) END IF ! Apply Thermostat to Barostat - CALL apply_thermostat_baro( thermostat_baro, npt, para_env%group, error) + CALL apply_thermostat_baro( thermostat_baro, npt, para_env%group) ! Annealing of particle velocities is only possible when no thermostat is active IF (simpar% ensemble == npe_f_ensemble .AND. simpar%annealing) THEN @@ -2583,7 +2552,7 @@ SUBROUTINE npt_f ( md_env, globenv, error ) ! Broadcast the new particle velocities and deallocate temporary CALL update_dealloc_tmp (tmp,particle_set, shell_particle_set, & - core_particle_set, para_env, shell_adiabatic, vel=.TRUE., error=error ) + core_particle_set, para_env, shell_adiabatic, vel=.TRUE.) ! Update constraint virial IF ( simpar%constraint ) & @@ -2591,14 +2560,14 @@ SUBROUTINE npt_f ( md_env, globenv, error ) molecule_kind_set, particle_set, virial, para_env%group ) CALL virial_evaluate ( atomic_kind_set, particle_set, & - local_particles, virial, para_env%group, error=error ) + local_particles, virial, para_env%group) ! Deallocate old variables - CALL deallocate_old ( old, error=error ) + CALL deallocate_old ( old) IF (first_time) THEN first_time = .FALSE. - CALL set_md_env(md_env, first_time=first_time,error=error) + CALL set_md_env(md_env, first_time=first_time) END IF END SUBROUTINE npt_f @@ -2606,13 +2575,11 @@ END SUBROUTINE npt_f ! ***************************************************************************** !> \brief RESPA integrator for nve ensemble for particle positions & momenta !> \param md_env ... -!> \param error ... !> \author FS ! ***************************************************************************** - SUBROUTINE nve_respa ( md_env, error) + SUBROUTINE nve_respa ( md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nve_respa', & routineP = moduleN//':'//routineN @@ -2653,22 +2620,22 @@ SUBROUTINE nve_respa ( md_env, error) NULLIFY (atomic_kind_set,simpar,subsys,particles,particle_set) NULLIFY (local_molecules,molecule_kinds, molecules,molecule_kind_set, local_particles,itimes) CALL get_md_env(md_env=md_env,simpar=simpar,force_env=force_env, & - para_env=para_env, itimes=itimes, error=error) + para_env=para_env, itimes=itimes) dt = simpar%dt n_time_steps=simpar%n_time_steps - CALL force_env_get(force_env,subsys=subsys,cell=cell,error=error) - CALL force_env_get(force_env%sub_force_env(1)%force_env,subsys=subsys_respa,error=error) + CALL force_env_get(force_env,subsys=subsys,cell=cell) + CALL force_env_get(force_env%sub_force_env(1)%force_env,subsys=subsys_respa) ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles, local_molecules_new=local_molecules, molecules_new=molecules,& - gci=gci, molecule_kinds_new=molecule_kinds ,error=error) + gci=gci, molecule_kinds_new=molecule_kinds) - CALL cp_subsys_get (subsys=subsys_respa, particles=particles_respa,error=error) + CALL cp_subsys_get (subsys=subsys_respa, particles=particles_respa) particle_set_respa => particles_respa%els nparticle_kind = atomic_kinds%n_els @@ -2681,13 +2648,13 @@ SUBROUTINE nve_respa ( md_env, error) ! Allocate work storage for positions and velocities ALLOCATE (pos(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (vel(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vel(:,:) = 0.0_dp IF (simpar%constraint) CALL getold(gci, local_molecules, molecule_set, & - molecule_kind_set, particle_set, cell, error) + molecule_kind_set, particle_set, cell) ! Multiple time step (first part) DO iparticle_kind=1,nparticle_kind @@ -2723,25 +2690,25 @@ SUBROUTINE nve_respa ( md_env, error) IF (simpar%constraint) THEN ! Possibly update the target values CALL shake_update_targets(gci, local_molecules, molecule_set, & - molecule_kind_set, dt, force_env%root_section, error) + molecule_kind_set, dt, force_env%root_section) CALL shake_control( gci, local_molecules, molecule_set,& molecule_kind_set, particle_set,pos, vel, dt, simpar%shake_tol,& simpar%info_constraint, simpar%lagrange_multipliers,simpar%dump_lm, cell,& - para_env%group, local_particles, error ) + para_env%group, local_particles) END IF ! Broadcast the new particle positions - CALL update_particle_set ( particle_set, para_env%group, pos = pos, error=error) + CALL update_particle_set ( particle_set, para_env%group, pos = pos) DO iparticle = 1, SIZE(particle_set) particle_set_respa(iparticle)%r = particle_set(iparticle)%r END DO ! Update forces - CALL force_env_calc_energy_force(force_env%sub_force_env(1)%force_env,error=error) + CALL force_env_calc_energy_force(force_env%sub_force_env(1)%force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, vel, error=error) + CALL metadyn_integrator(force_env, itimes, vel) ! Velocity Verlet (second part) DO iparticle_kind=1,nparticle_kind @@ -2760,19 +2727,19 @@ SUBROUTINE nve_respa ( md_env, error) IF (simpar%constraint) CALL rattle_control( gci,local_molecules, molecule_set, & molecule_kind_set, particle_set, vel, dt,simpar%shake_tol,& simpar%info_constraint, simpar%lagrange_multipliers,& - simpar%dump_lm, cell, para_env%group,local_particles, error ) + simpar%dump_lm, cell, para_env%group,local_particles) IF (simpar%annealing) vel(:,:)=vel(:,:)*simpar%f_annealing END DO DEALLOCATE (pos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Multiple time step (second part) ! Compute forces for respa force_env - CALL force_env_calc_energy_force(force_env,error=error) + CALL force_env_calc_energy_force(force_env) ! Metadynamics - CALL metadyn_integrator(force_env, itimes, vel, error=error) + CALL metadyn_integrator(force_env, itimes, vel) DO iparticle_kind=1,nparticle_kind atomic_kind => atomic_kind_set(iparticle_kind) @@ -2788,10 +2755,10 @@ SUBROUTINE nve_respa ( md_env, error) END DO ! Broadcast the new particle velocities - CALL update_particle_set ( particle_set, para_env%group, vel = vel, error=error) + CALL update_particle_set ( particle_set, para_env%group, vel = vel) DEALLOCATE (vel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE nve_respa diff --git a/src/motion/integrator_utils.F b/src/motion/integrator_utils.F index 24124fb01b..c2e649a016 100644 --- a/src/motion/integrator_utils.F +++ b/src/motion/integrator_utils.F @@ -109,16 +109,14 @@ MODULE integrator_utils !> \param old ... !> \param particle_set ... !> \param npt ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE allocate_old ( old, particle_set, npt, error ) + SUBROUTINE allocate_old ( old, particle_set, npt) TYPE(old_variables_type), POINTER :: old TYPE(particle_type), POINTER :: particle_set(:) TYPE(npt_info_type), POINTER :: npt(:,:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_old', & routineP = moduleN//':'//routineN @@ -130,24 +128,24 @@ SUBROUTINE allocate_old ( old, particle_set, npt, error ) natoms = SIZE ( particle_set) idim = SIZE ( npt, 1) jdim = SIZE ( npt, 2) - CPPostcondition(.NOT.ASSOCIATED(old),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(old),cp_failure_level,routineP,failure) ALLOCATE ( old, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( old%v ( natoms, 3 ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) old%v = 0.0_dp ALLOCATE ( old%r ( natoms, 3 ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) old%r = 0.0_dp ALLOCATE ( old%eps ( idim, jdim ),STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) old%eps = 0.0_dp ALLOCATE ( old%veps ( idim, jdim ),STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) old%veps = 0.0_dp ALLOCATE ( old%h(3, 3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) old%h = 0.0_dp END SUBROUTINE allocate_old @@ -155,14 +153,12 @@ END SUBROUTINE allocate_old ! ***************************************************************************** !> \brief ... !> \param old ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE deallocate_old (old, error) + SUBROUTINE deallocate_old (old) TYPE(old_variables_type), POINTER :: old - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_old', & routineP = moduleN//':'//routineN @@ -174,26 +170,26 @@ SUBROUTINE deallocate_old (old, error) IF (ASSOCIATED(old)) THEN IF (ASSOCIATED(old%v)) THEN DEALLOCATE ( old%v, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(old%r)) THEN DEALLOCATE ( old%r, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(old%eps)) THEN DEALLOCATE ( old%eps, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(old%veps)) THEN DEALLOCATE ( old%veps, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(old%h)) THEN DEALLOCATE ( old%h, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE ( old, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_old @@ -206,17 +202,15 @@ END SUBROUTINE deallocate_old !> \param nparticle ... !> \param nshell ... !> \param shell_adiabatic ... -!> \param error ... !> \par History !> none !> \author MI (February 2008) ! ***************************************************************************** - SUBROUTINE allocate_tmp ( md_env, tmp, nparticle, nshell, shell_adiabatic, error ) + SUBROUTINE allocate_tmp ( md_env, tmp, nparticle, nshell, shell_adiabatic) TYPE(md_environment_type), POINTER :: md_env TYPE(tmp_variables_type), POINTER :: tmp INTEGER, INTENT(IN) :: nparticle, nshell LOGICAL, INTENT(IN) :: shell_adiabatic - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_tmp', & routineP = moduleN//':'//routineN @@ -225,9 +219,9 @@ SUBROUTINE allocate_tmp ( md_env, tmp, nparticle, nshell, shell_adiabatic, error LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(tmp),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(tmp),cp_failure_level,routineP,failure) ALLOCATE (tmp, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Nullify Components NULLIFY(tmp%pos) @@ -240,10 +234,10 @@ SUBROUTINE allocate_tmp ( md_env, tmp, nparticle, nshell, shell_adiabatic, error ! *** Allocate work storage for positions and velocities *** ALLOCATE (tmp%pos(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (tmp%vel(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp%pos(:,:) = 0.0_dp tmp%vel(:,:) = 0.0_dp @@ -251,16 +245,16 @@ SUBROUTINE allocate_tmp ( md_env, tmp, nparticle, nshell, shell_adiabatic, error IF(shell_adiabatic) THEN ! *** Allocate work storage for positions and velocities *** ALLOCATE (tmp%shell_pos(3,nshell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (tmp%core_pos(3,nshell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (tmp%shell_vel(3,nshell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (tmp%core_vel(3,nshell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp%shell_pos(:,:) = 0.0_dp tmp%shell_vel(:,:) = 0.0_dp @@ -281,7 +275,7 @@ SUBROUTINE allocate_tmp ( md_env, tmp, nparticle, nshell, shell_adiabatic, error tmp%poly_r = 1.0_dp tmp%poly_v = 1.0_dp - CALL get_md_env(md_env=md_env, itimes=tmp%itimes, error=error) + CALL get_md_env(md_env=md_env, itimes=tmp%itimes) END SUBROUTINE allocate_tmp @@ -296,14 +290,13 @@ END SUBROUTINE allocate_tmp !> \param pos ... !> \param vel ... !> \param should_deall_vel ... -!> \param error ... !> \par History !> none !> \author MI (February 2008) ! ***************************************************************************** SUBROUTINE update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & core_particle_set, para_env, shell_adiabatic, pos, vel,& - should_deall_vel,error ) + should_deall_vel) TYPE(tmp_variables_type), POINTER :: tmp TYPE(particle_type), DIMENSION(:), & @@ -313,7 +306,6 @@ SUBROUTINE update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(IN) :: shell_adiabatic LOGICAL, INTENT(IN), OPTIONAL :: pos, vel, should_deall_vel - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_dealloc_tmp', & routineP = moduleN//':'//routineN @@ -324,7 +316,7 @@ SUBROUTINE update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & failure = .FALSE. - CPPostcondition(ASSOCIATED(tmp),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tmp),cp_failure_level,routineP,failure) my_pos =.FALSE. my_vel =.FALSE. my_deall=.TRUE. @@ -334,41 +326,41 @@ SUBROUTINE update_dealloc_tmp ( tmp, particle_set, shell_particle_set, & ! *** Broadcast the new particle positions *** IF(my_pos) THEN - CALL update_particle_set ( particle_set, para_env % group, pos = tmp%pos, error=error) + CALL update_particle_set ( particle_set, para_env % group, pos = tmp%pos) DEALLOCATE (tmp%pos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(shell_adiabatic)THEN - CALL update_particle_set ( shell_particle_set, para_env%group, pos=tmp%shell_pos, error=error ) - CALL update_particle_set ( core_particle_set, para_env%group, pos=tmp%core_pos, error=error ) + CALL update_particle_set ( shell_particle_set, para_env%group, pos=tmp%shell_pos) + CALL update_particle_set ( core_particle_set, para_env%group, pos=tmp%core_pos) DEALLOCATE (tmp%shell_pos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (tmp%core_pos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF ! *** Broadcast the new particle velocities *** IF(my_vel) THEN - CALL update_particle_set ( particle_set, para_env % group, vel = tmp%vel, error=error ) + CALL update_particle_set ( particle_set, para_env % group, vel = tmp%vel) IF (shell_adiabatic) THEN - CALL update_particle_set ( shell_particle_set, para_env%group, vel=tmp%shell_vel, error=error ) - CALL update_particle_set ( core_particle_set, para_env%group, vel=tmp%core_vel, error=error ) + CALL update_particle_set ( shell_particle_set, para_env%group, vel=tmp%shell_vel) + CALL update_particle_set ( core_particle_set, para_env%group, vel=tmp%core_vel) END IF IF(my_deall)THEN DEALLOCATE (tmp%vel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (shell_adiabatic) THEN DEALLOCATE (tmp%shell_vel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (tmp%core_vel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CPPostcondition(.NOT.ASSOCIATED(tmp%pos),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(tmp%shell_pos),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(tmp%core_pos),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(tmp%pos),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(tmp%shell_pos),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(tmp%core_pos),cp_failure_level,routineP,failure) DEALLOCATE (tmp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -788,14 +780,13 @@ END SUBROUTINE damp_veps !> \param first ... !> \param para_env ... !> \param u ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** SUBROUTINE rattle_roll_setup ( old, gci, atomic_kind_set, particle_set, local_particles, & molecule_kind_set, molecule_set, local_molecules, vel, dt, cell, npt, simpar, virial,& - vector_v, roll_tol, iroll, infree, first, para_env, u, error ) + vector_v, roll_tol, iroll, infree, first, para_env, u) TYPE(old_variables_type), POINTER :: old TYPE(global_constraint_type), POINTER :: gci @@ -819,7 +810,6 @@ SUBROUTINE rattle_roll_setup ( old, gci, atomic_kind_set, particle_set, local_pa LOGICAL, INTENT(INOUT) :: first TYPE(cp_para_env_type), INTENT(IN) :: para_env REAL(KIND=dp), INTENT(IN), OPTIONAL :: u( : , : ) - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: kin REAL(KIND=dp), DIMENSION(3, 3) :: pv_kin @@ -853,7 +843,7 @@ SUBROUTINE rattle_roll_setup ( old, gci, atomic_kind_set, particle_set, local_pa CALL set ( old, atomic_kind_set, particle_set, vel, local_particles, cell , npt, 'B' ) CALL rattle_roll_control( gci, local_molecules, molecule_set, molecule_kind_set, & particle_set, vel, dt, simpar, vector_v, npt_loc%v, roll_tol, iroll,& - para_env, u, cell, local_particles, error=error ) + para_env, u, cell, local_particles) END SUBROUTINE rattle_roll_setup @@ -1203,14 +1193,13 @@ END SUBROUTINE update_veps !> \param shell_adiabatic ... !> \param dt ... !> \param u ... -!> \param error ... !> \par History !> none !> \author MI (February 2008) ! ***************************************************************************** SUBROUTINE vv_first ( tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, u, error ) + shell_adiabatic, dt, u) TYPE(tmp_variables_type), POINTER :: tmp TYPE(atomic_kind_type), DIMENSION(:), & @@ -1224,7 +1213,6 @@ SUBROUTINE vv_first ( tmp, atomic_kind_set, local_particles, particle_set, & LOGICAL, INTENT(IN) :: shell_adiabatic REAL(KIND=dp) :: dt REAL(KIND=dp), DIMENSION(3, 3), OPTIONAL :: u - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vv_first', & routineP = moduleN//':'//routineN @@ -1416,14 +1404,13 @@ END SUBROUTINE vv_first !> \param shell_adiabatic ... !> \param dt ... !> \param u ... -!> \param error ... !> \par History !> none !> \author MI (February 2008) ! ***************************************************************************** SUBROUTINE vv_second ( tmp, atomic_kind_set, local_particles, particle_set,& core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, u, error ) + shell_adiabatic, dt, u) TYPE(tmp_variables_type), POINTER :: tmp TYPE(atomic_kind_type), DIMENSION(:), & @@ -1437,7 +1424,6 @@ SUBROUTINE vv_second ( tmp, atomic_kind_set, local_particles, particle_set,& LOGICAL, INTENT(IN) :: shell_adiabatic REAL(KIND=dp) :: dt REAL(KIND=dp), DIMENSION(3, 3), OPTIONAL :: u - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vv_second', & routineP = moduleN//':'//routineN @@ -1651,13 +1637,12 @@ END SUBROUTINE transform_second !> \param nparticle_kind ... !> \param shell_adiabatic ... !> \param npt ... -!> \param error ... !> \par History !> none !> \author MI (October 2008) ! ***************************************************************************** SUBROUTINE variable_timestep(md_env,tmp,dt,simpar,para_env,atomic_kind_set, local_particles,& - particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt,error) + particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt) TYPE(md_environment_type), POINTER :: md_env TYPE(tmp_variables_type), POINTER :: tmp @@ -1674,7 +1659,6 @@ SUBROUTINE variable_timestep(md_env,tmp,dt,simpar,para_env,atomic_kind_set, loc INTEGER, INTENT(IN) :: nparticle_kind LOGICAL, INTENT(IN) :: shell_adiabatic TYPE(npt_info_type), OPTIONAL, POINTER :: npt(:,:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'variable_timestep', & routineP = moduleN//':'//routineN @@ -1717,7 +1701,7 @@ SUBROUTINE variable_timestep(md_env,tmp,dt,simpar,para_env,atomic_kind_set, loc dt = dt*dt_fact_f simpar%dt_fact = dt_fact_f CALL rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& - particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt,error) + particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt) END IF dt_fact = 1.0_dp @@ -1743,15 +1727,15 @@ SUBROUTINE variable_timestep(md_env,tmp,dt,simpar,para_env,atomic_kind_set, loc dt = dt*dt_fact_v simpar%dt_fact = dt_fact_f*dt_fact_v CALL rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& - particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt,error) + particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt) END IF simpar%dt_fact = dt_fact_f*dt_fact_v IF(simpar%dt_fact < 1.0_dp) THEN - CALL get_md_env(md_env, t=time, thermostats=thermostats, error=error) + CALL get_md_env(md_env, t=time, thermostats=thermostats) time = time - dt_old + dt_old*simpar%dt_fact IF(ASSOCIATED(thermostats)) THEN - CALL set_thermostats(thermostats, dt_fact=simpar%dt_fact, error=error) + CALL set_thermostats(thermostats, dt_fact=simpar%dt_fact) END IF END IF @@ -1770,14 +1754,13 @@ END SUBROUTINE variable_timestep !> \param nparticle_kind ... !> \param shell_adiabatic ... !> \param npt ... -!> \param error ... !> \par History !> none !> \author MI (October 2008) !> I soliti ignoti ! ***************************************************************************** SUBROUTINE rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& - particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt,error) + particle_set, core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic,npt) TYPE(tmp_variables_type), POINTER :: tmp REAL(KIND=dp), INTENT(IN) :: dt @@ -1792,7 +1775,6 @@ SUBROUTINE rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& INTEGER, INTENT(IN) :: nparticle_kind LOGICAL, INTENT(IN) :: shell_adiabatic TYPE(npt_info_type), OPTIONAL, POINTER :: npt(:,:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rescaled_vv_first', & routineP = moduleN//':'//routineN @@ -1813,13 +1795,13 @@ SUBROUTINE rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& SELECT CASE(simpar%ensemble) CASE (nve_ensemble, nvt_ensemble) CALL vv_first(tmp,atomic_kind_set, local_particles, particle_set, & - core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt, error=error) + core_particle_set, shell_particle_set, nparticle_kind, shell_adiabatic, dt) CASE (isokin_ensemble) tmp%scale_v(1:3) = SQRT(1.0_dp/tmp%ds) tmp%poly_v(1:3) = 2.0_dp*tmp%s/SQRT(tmp%ds)/dt CALL vv_first(tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error) + shell_adiabatic, dt) CASE (npt_i_ensemble, npe_i_ensemble) arg_r = arg_r * simpar%dt_fact*simpar%dt_fact @@ -1831,7 +1813,7 @@ SUBROUTINE rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& (1.0_dp + 3.0_dp * infree ) ) CALL vv_first( tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error ) + shell_adiabatic, dt) CASE (npt_f_ensemble,npe_f_ensemble) trvg = npt ( 1, 1 ) % v + npt ( 2, 2 ) % v + npt ( 3, 3 ) % v @@ -1845,7 +1827,7 @@ SUBROUTINE rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& CALL vv_first( tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, u, error=error) + shell_adiabatic, dt, u) CASE (nph_uniaxial_ensemble,nph_uniaxial_damped_ensemble) arg_r = arg_r * simpar%dt_fact*simpar%dt_fact @@ -1862,7 +1844,7 @@ SUBROUTINE rescaled_vv_first(tmp,dt,simpar,atomic_kind_set, local_particles,& tmp%scale_v(3) = EXP( -0.25_dp * dt * npt ( 1, 1 ) % v * infree ) CALL vv_first( tmp, atomic_kind_set, local_particles, particle_set, & core_particle_set, shell_particle_set, nparticle_kind,& - shell_adiabatic, dt, error=error) + shell_adiabatic, dt) END SELECT diff --git a/src/motion/mc/mc_control.F b/src/motion/mc/mc_control.F index d1745ef921..5db6bc812a 100644 --- a/src/motion/mc/mc_control.F +++ b/src/motion/mc/mc_control.F @@ -100,7 +100,6 @@ SUBROUTINE write_mc_restart ( nnstep, mc_par, nchains,force_env ) REAL(KIND=dp), DIMENSION(1:3) :: abc TYPE(atom_type), DIMENSION(:), POINTER :: atom_list TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: error TYPE(cp_subsys_type), POINTER :: subsys TYPE(mol_kind_new_list_type), POINTER :: molecule_kinds_new TYPE(molecule_kind_type), POINTER :: molecule_kind @@ -117,12 +116,11 @@ SUBROUTINE write_mc_restart ( nnstep, mc_par, nchains,force_env ) file_action='WRITE',file_status='REPLACE') ! get the cell length and coordinates - CALL force_env_get(force_env,cell=cell,subsys=subsys,& - error=error) + CALL force_env_get(force_env,cell=cell,subsys=subsys) CALL get_cell(cell,abc=abc) CALL cp_subsys_get(subsys, & molecule_kinds_new=molecule_kinds_new,& - particles=particles, error=error) + particles=particles) nunits_tot=SIZE(particles%els(:)) IF(SUM(nchains(:)) == 0) nunits_tot=0 @@ -201,7 +199,6 @@ SUBROUTINE read_mc_restart ( mc_par, force_env, iw, mc_nunits_tot,rng_stream) DIMENSION(:, :) :: r REAL(KIND=dp), DIMENSION(1:3) :: abc, box_length TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: error TYPE(cp_subsys_type), POINTER :: subsys TYPE(mc_input_file_type), POINTER :: mc_input_file TYPE(mc_molecule_info_type), POINTER :: mc_molecule_info @@ -271,11 +268,10 @@ SUBROUTINE read_mc_restart ( mc_par, force_env, iw, mc_nunits_tot,rng_stream) ENDIF ! get the cell length and coordinates - CALL force_env_get(force_env,cell=cell,subsys=subsys,& - error=error) + CALL force_env_get(force_env,cell=cell,subsys=subsys) CALL get_cell(cell,abc=abc) CALL cp_subsys_get(subsys, & - particles=particles, error=error) + particles=particles) IF(ionode) THEN READ(unit,*) box_length(1:3) ! in angstroms @@ -341,7 +337,7 @@ SUBROUTINE read_mc_restart ( mc_par, force_env, iw, mc_nunits_tot,rng_stream) ! advance the random number sequence based on the restart step IF(ionode) THEN DO i=1,nstart+1 - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ENDDO ENDIF @@ -363,13 +359,11 @@ END SUBROUTINE read_mc_restart !> \param para_env ... !> \param input_file_name ... !> \param globenv_new the global environment parameters -!> \param error the CP error structure -!> !> \author MJM !> \note Suitable for parallel. ! ***************************************************************************** SUBROUTINE mc_create_force_env ( force_env, input_declaration, para_env, input_file_name,& - globenv_new, error ) + globenv_new) TYPE(force_env_type), POINTER :: force_env TYPE(section_type), POINTER :: input_declaration @@ -377,14 +371,12 @@ SUBROUTINE mc_create_force_env ( force_env, input_declaration, para_env, input_f CHARACTER(LEN=*), INTENT(IN) :: input_file_name TYPE(global_environment_type), & OPTIONAL, POINTER :: globenv_new - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mc_create_force_env', & routineP = moduleN//':'//routineN INTEGER :: f_env_id, ierr, output_unit LOGICAL :: failure - TYPE(cp_error_type) :: new_error TYPE(f_env_type), POINTER :: f_env failure= .FALSE. @@ -396,16 +388,16 @@ SUBROUTINE mc_create_force_env ( force_env, input_declaration, para_env, input_f output_unit=output_unit,& mpi_comm=para_env%group) - CALL f_env_add_defaults(f_env_id, f_env, new_error, failure) + CALL f_env_add_defaults(f_env_id, f_env,failure) IF(failure) STOP "mc_create_force_env: f_env_add_defaults failed" force_env => f_env%force_env - CALL force_env_retain(force_env, error) - CALL f_env_rm_defaults(f_env, new_error) + CALL force_env_retain(force_env) + CALL f_env_rm_defaults(f_env) CALL destroy_force_env(f_env_id, ierr) IF(ierr/=0) STOP "mc_create_force_env: destroy_force_env failed" IF(PRESENT(globenv_new)) & - CALL force_env_get(force_env, globenv=globenv_new, error=error) + CALL force_env_get(force_env, globenv=globenv_new) END SUBROUTINE mc_create_force_env @@ -422,13 +414,11 @@ END SUBROUTINE mc_create_force_env !> \param input_declaration ... !> \param mc_input_file ... !> \param ionode ... -!> \param error the CP error structure -!> !> \author MJM !> \note Suitable for parallel. ! ***************************************************************************** SUBROUTINE mc_create_bias_force_env (bias_env,r,atom_symbols,nunits_tot,& - para_env, box_length,nchains,input_declaration,mc_input_file,ionode,error) + para_env, box_length,nchains,input_declaration,mc_input_file,ionode) TYPE(force_env_type), POINTER :: bias_env REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: r @@ -442,7 +432,6 @@ SUBROUTINE mc_create_bias_force_env (bias_env,r,atom_symbols,nunits_tot,& TYPE(section_type), POINTER :: input_declaration TYPE(mc_input_file_type), POINTER :: mc_input_file LOGICAL, INTENT(IN) :: ionode - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mc_create_bias_force_env', & routineP = moduleN//':'//routineN @@ -451,7 +440,7 @@ SUBROUTINE mc_create_bias_force_env (bias_env,r,atom_symbols,nunits_tot,& CALL mc_make_dat_file_new(r(:,:),atom_symbols,nunits_tot,& box_length(:),'bias_temp.dat',nchains(:),mc_input_file) - CALL mc_create_force_env(bias_env,input_declaration, para_env, 'bias_temp.dat',error=error) + CALL mc_create_force_env(bias_env,input_declaration, para_env, 'bias_temp.dat') END SUBROUTINE mc_create_bias_force_env diff --git a/src/motion/mc/mc_coordinates.F b/src/motion/mc/mc_coordinates.F index ff9d70e5f3..4d3e7bc438 100644 --- a/src/motion/mc/mc_coordinates.F +++ b/src/motion/mc/mc_coordinates.F @@ -89,7 +89,6 @@ SUBROUTINE check_for_overlap ( force_env, nchains, nunits,loverlap,mol_type,& DIMENSION(:, :, :) :: r REAL(KIND=dp), DIMENSION(1:3) :: abc, box_length, RIJ TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: error TYPE(cp_subsys_type), POINTER :: oldsys TYPE(particle_list_type), POINTER :: particles @@ -104,9 +103,9 @@ SUBROUTINE check_for_overlap ( force_env, nchains, nunits,loverlap,mol_type,& rmin=3.57106767_dp ! 1 angstrom squared ! get the particle coordinates and the cell length - CALL force_env_get(force_env,cell=cell,subsys=oldsys,error=error) + CALL force_env_get(force_env,cell=cell,subsys=oldsys) CALL get_cell(cell,abc=abc) - CALL cp_subsys_get(oldsys,particles=particles, error=error) + CALL cp_subsys_get(oldsys,particles=particles) ALLOCATE(r(1:3,1:MAXVAL(nunits),1:SUM(nchains)),STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -326,7 +325,6 @@ END SUBROUTINE mc_coordinate_fold !> \param source the MPI source value, for broadcasts !> \param group the MPI group value, for broadcasts !> \param rng_stream the random number stream that we draw from -!> \param error the the cp_error type !> \param avbmc_atom ... !> \param rmin ... !> \param rmax ... @@ -346,7 +344,7 @@ END SUBROUTINE mc_coordinate_fold SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max_val,& exp_min_val, nswapmoves, rosenbluth_weight, start_atom,natoms_tot,nunits,nunits_mol,& mass,loverlap, choosen_energy,old_energy,ionode,lremove,mol_type,nchains,source,& - group,rng_stream,error,avbmc_atom,rmin,rmax,move_type,target_atom) + group,rng_stream,avbmc_atom,rmin,rmax,move_type,target_atom) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), INTENT(IN) :: BETA, max_val, min_val, & @@ -365,7 +363,6 @@ SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max INTEGER, DIMENSION(:), INTENT(IN) :: mol_type, nchains INTEGER, INTENT(IN) :: source, group TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type) :: error INTEGER, INTENT(IN), OPTIONAL :: avbmc_atom REAL(KIND=dp), INTENT(IN), OPTIONAL :: rmin, rmax CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: move_type @@ -399,9 +396,9 @@ SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max NULLIFY(oldsys) ! get the particle coordinates and the cell length - CALL force_env_get(force_env,cell=cell,subsys=oldsys,error=error) + CALL force_env_get(force_env,cell=cell,subsys=oldsys) CALL get_cell(cell,abc=abc) - CALL cp_subsys_get(oldsys,particles=particles, error=error) + CALL cp_subsys_get(oldsys,particles=particles) ! do some checking to make sure we have all the data we need IF(PRESENT(avbmc_atom)) THEN @@ -490,7 +487,7 @@ SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max ! find an AVBMC insertion point CALL generate_avbmc_insertion(rmin,rmax,& r_old(1:3,target_atom),& - move_type,r_insert(:),abc(:),rng_stream,error=error) + move_type,r_insert(:),abc(:),rng_stream) DO i=1,3 diff(i)=r_insert(i)-r_old(i,start_atom+avbmc_atom-1) @@ -499,7 +496,7 @@ SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max ELSE ! find a new insertion point somewhere in the box DO i=1,3 - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) r_insert(i)=rand*abc(i) ENDDO @@ -521,7 +518,7 @@ SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max ! rotate the molecule...this routine is only made for serial use CALL rotate_molecule(r(:,start_atom:end_atom,imove),mass(:),& - nunits_mol,rng_stream,error=error) + nunits_mol,rng_stream) IF(imove == 1 .AND. lremove) THEN DO iatom=1,natoms_tot @@ -545,9 +542,9 @@ SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max CYCLE ENDIF - CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.,error=error) + CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.) CALL force_env_get(force_env,& - potential_energy=bias_energy,error=error) + potential_energy=bias_energy) trial_energy(imove)=(bias_energy-old_energy) exponent=-BETA*trial_energy(imove) @@ -585,7 +582,7 @@ SUBROUTINE generate_cbmc_swap_config( force_env, BETA, max_val, min_val, exp_max total_running_weight=0.0E0_dp choosen=0 IF(ionode)THEN - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ! CALL random_number(rand) ENDIF CALL mp_bcast(rand,source,group) @@ -681,10 +678,9 @@ END SUBROUTINE generate_cbmc_swap_config !> \param rng_stream the stream we pull random numbers from !> !> Use only in serial. -!> \param error ... !> \author MJM ! ***************************************************************************** -SUBROUTINE rotate_molecule(r,mass,natoms,rng_stream,error) +SUBROUTINE rotate_molecule(r,mass,natoms,rng_stream) INTEGER, INTENT(IN) :: natoms REAL(KIND=dp), DIMENSION(1:natoms), & @@ -693,7 +689,6 @@ SUBROUTINE rotate_molecule(r,mass,natoms,rng_stream,error) DIMENSION(1:3, 1:natoms), & INTENT(INOUT) :: r TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotate_molecule', & routineP = moduleN//':'//routineN @@ -712,7 +707,7 @@ SUBROUTINE rotate_molecule(r,mass,natoms,rng_stream,error) CALL get_center_of_mass(r(:,:),natoms,center_of_mass(:),mass(:)) ! call a random number to figure out how far we're moving - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) dgamma=pi*(rand-0.5E0_dp)*2.0E0_dp ! *** set up the rotation matrix *** @@ -775,20 +770,16 @@ END SUBROUTINE rotate_molecule !> \param rng_stream the stream we pull random numbers from !> \param box if present, tells the routine which box to grab a molecule from !> \param molecule_type_old if present, tells the routine which molecule type to select from -!> \param error the optional cp_error_type -!> -!> Designed only for serial use. !> \author MJM ! ***************************************************************************** SUBROUTINE find_mc_test_molecule(mc_molecule_info,start_atom,& - box_number,molecule_type,rng_stream,box,molecule_type_old,error) + box_number,molecule_type,rng_stream,box,molecule_type_old) TYPE(mc_molecule_info_type), POINTER :: mc_molecule_info INTEGER, INTENT(OUT) :: start_atom, box_number, & molecule_type TYPE(rng_stream_type), POINTER :: rng_stream INTEGER, INTENT(IN), OPTIONAL :: box, molecule_type_old - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'find_mc_test_molecule', & routineP = moduleN//':'//routineN @@ -817,7 +808,7 @@ SUBROUTINE find_mc_test_molecule(mc_molecule_info,start_atom,& IF(PRESENT(box) .AND. PRESENT(molecule_type_old))THEN ! only need to find the atom number the molecule starts on - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) molecule_number=CEILING(rand*REAL(nchains(molecule_type_old,box))) start_mol=1 @@ -837,7 +828,7 @@ SUBROUTINE find_mc_test_molecule(mc_molecule_info,start_atom,& ELSEIF(PRESENT(box))THEN ! any molecule in box...need to find molecule type and start atom - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) molecule_number=CEILING(rand*REAL(SUM(nchains(:,box)))) start_mol=1 @@ -855,7 +846,7 @@ SUBROUTINE find_mc_test_molecule(mc_molecule_info,start_atom,& ELSEIF(PRESENT(molecule_type_old))THEN ! any molecule of type molecule_type_old...need to find box number and start atom - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) molecule_number=CEILING(rand*REAL(SUM(nchains(molecule_type_old,:)))) ! find which box it's in @@ -888,7 +879,7 @@ SUBROUTINE find_mc_test_molecule(mc_molecule_info,start_atom,& DO ibox=1,SIZE(nchains(1,:)) nchains_tot=nchains_tot+SUM(nchains(:,ibox)) ENDDO - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) molecule_number=CEILING(rand*REAL(nchains_tot)) molecule_type=mol_type(molecule_number) @@ -918,9 +909,9 @@ SUBROUTINE find_mc_test_molecule(mc_molecule_info,start_atom,& IF(PRESENT(box)) box_number=box IF(PRESENT(molecule_type_old)) molecule_type=molecule_type_old - CPPostcondition(start_atom/=0,cp_failure_level,routineP,error,failure) - CPPostcondition(box_number/=0,cp_failure_level,routineP,error,failure) - CPPostcondition(molecule_type/=0,cp_failure_level,routineP,error,failure) + CPPostcondition(start_atom/=0,cp_failure_level,routineP,failure) + CPPostcondition(box_number/=0,cp_failure_level,routineP,failure) + CPPostcondition(molecule_type/=0,cp_failure_level,routineP,failure) ! end the timing CALL timestop(handle) @@ -1001,11 +992,10 @@ END SUBROUTINE create_discrete_array !> \param rng_stream the random number stream that we draw from !> !> Use only in serial. -!> \param error ... !> \author MJM ! ***************************************************************************** SUBROUTINE generate_avbmc_insertion( rmin,rmax,r_target,& - move_type,r_insert,abc,rng_stream,error) + move_type,r_insert,abc,rng_stream) REAL(KIND=dp), INTENT(IN) :: rmin, rmax REAL(KIND=dp), DIMENSION(1:3), & @@ -1016,7 +1006,6 @@ SUBROUTINE generate_avbmc_insertion( rmin,rmax,r_target,& REAL(KIND=dp), DIMENSION(1:3), & INTENT(IN) :: abc TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i REAL(dp) :: dist, eta_1, eta_2, eta_sq, & @@ -1028,8 +1017,8 @@ SUBROUTINE generate_avbmc_insertion( rmin,rmax,r_target,& IF(move_type == 'in') THEN ! generate a random unit vector, from Allen and Tildesley DO - eta_1=next_random_number(rng_stream,error=error) - eta_2=next_random_number(rng_stream,error=error) + eta_1=next_random_number(rng_stream) + eta_2=next_random_number(rng_stream) eta_sq=eta_1**2+eta_2**2 IF(eta_sq .LT. 1.0_dp) THEN r_insert(1)=2.0_dp*eta_1*SQRT(1.0_dp-eta_sq) @@ -1040,7 +1029,7 @@ SUBROUTINE generate_avbmc_insertion( rmin,rmax,r_target,& ENDDO ! now scale that vector to be within the "in" region - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) r_insert(1:3)=r_insert(1:3)*(rand*(rmax**3-rmin**3)+rmin**3)**& (1.0_dp/3.0_dp) @@ -1050,7 +1039,7 @@ SUBROUTINE generate_avbmc_insertion( rmin,rmax,r_target,& ! find a new insertion point somewhere in the box DO DO i=1,3 - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) r_insert(i)=rand*abc(i) ENDDO diff --git a/src/motion/mc/mc_ensembles.F b/src/motion/mc/mc_ensembles.F index cf0c8ae36e..b71c9c9844 100644 --- a/src/motion/mc/mc_ensembles.F +++ b/src/motion/mc/mc_ensembles.F @@ -110,10 +110,9 @@ MODULE mc_ensembles !> \param rng_stream the stream we pull random numbers from !> !> Suitable for parallel. -!> \param error the error type !> \author MJM ! ***************************************************************************** - SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxes, rng_stream, error) + SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxes, rng_stream) TYPE(mc_environment_p_type), & DIMENSION(:), POINTER :: mc_env @@ -122,7 +121,6 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe TYPE(section_type), POINTER :: input_declaration INTEGER, INTENT(IN) :: nboxes TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_run_ensemble', & routineP = moduleN//':'//routineN @@ -192,7 +190,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe TYPE(section_vals_type), POINTER :: root_section failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) ! nullify some pointers @@ -200,23 +198,23 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! allocate a whole bunch of stuff based on how many boxes we have ALLOCATE (force_env(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (bias_env(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (cell(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (particles_old(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (oldsys(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (averages(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (mc_par(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (pmvol_box(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (pmhmc_box(1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO ibox=1,nboxes CALL get_mc_env ( mc_env(ibox)%mc_env, & @@ -227,8 +225,8 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! Gather units of measure for output (if available) root_section => force_env(1)%force_env%root_section CALL section_vals_val_get(root_section,"MOTION%PRINT%TRAJECTORY%UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) ! get some data out of mc_par CALL get_mc_par(mc_par(1)%mc_par,& @@ -254,9 +252,9 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! allocate some stuff based on the number of molecule types we have ALLOCATE (moves(1:nmol_types,1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (move_updates(1:nmol_types,1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF(nboxes .GT. 1) THEN DO ibox=2,nboxes @@ -283,7 +281,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! allocate the particle positions array for broadcasting ALLOCATE (r_old(3,SUM(nunits_tot),1:nboxes),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! figure out what the default write unit is iw = cp_logger_get_default_io_unit(logger) @@ -313,10 +311,9 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! find the energy of the initial configuration IF(SUM(nchains(:,ibox)) .NE. 0) THEN CALL force_env_calc_energy_force(force_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env,& - potential_energy=old_energy(ibox),& - error=error) + potential_energy=old_energy(ibox)) ELSE old_energy(ibox)=0.0E0_dp ENDIF @@ -339,11 +336,10 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! get the subsystems and the cell information CALL force_env_get(force_env(ibox)%force_env,& - subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell,& - error=error) + subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell) CALL get_cell(cell(ibox)%cell,abc=abc(:,ibox)) CALL cp_subsys_get(oldsys(ibox)%subsys, & - particles=particles_old(ibox)%list, error=error) + particles=particles_old(ibox)%list) ! record the old coordinates, in case a move is rejected DO iparticle=1,nunits_tot(ibox) r_old(1:3,iparticle,ibox)=& @@ -354,7 +350,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe IF(lbias) THEN ! determine the atom names of every particle ALLOCATE (atom_names_box(1:nunits_tot(ibox)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) atom_number=1 DO imolecule=1,SUM(nchains(:,ibox)) @@ -370,19 +366,19 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe CALL mc_create_bias_force_env(bias_env(ibox)%force_env,& r_old(:,:,ibox),atom_names_box(:),nunits_tot(ibox),& para_env,abc(:,ibox),nchains_box,input_declaration,mc_bias_file,& - ionode,error) + ionode) IF(SUM(nchains(:,ibox)) .NE. 0) THEN CALL force_env_calc_energy_force(bias_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(bias_env(ibox)%force_env,& - potential_energy=last_bias_energy(ibox),error=error) + potential_energy=last_bias_energy(ibox)) ELSE last_bias_energy(ibox)=0.0E0_dp ENDIF bias_energy(ibox)=last_bias_energy(ibox) DEALLOCATE(atom_names_box,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF lnew_bias_env=.FALSE. @@ -424,7 +420,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ELSE CALL write_particle_coordinates(particles_old(ibox)%list%els,& com_crd,dump_xmol,'POS','INITIAL BOX ' // TRIM(ADJUSTL(cbox)),& - unit_conv=unit_conv,error=error) + unit_conv=unit_conv) ENDIF CALL open_file(file_name=data_file(ibox),& unit_number=data_unit(ibox),file_position='APPEND',& @@ -478,7 +474,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe WRITE(iw,*) "------- On Monte Carlo Step ",nnstep ENDIF - IF (ionode) rand=next_random_number(rng_stream,error=error) + IF (ionode) rand=next_random_number(rng_stream) ! broadcast the random number, to make sure we're on the same move CALL mp_bcast(rand,source,group) @@ -496,14 +492,14 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe moves(1,1)%moves,move_updates(1,1)%moves,& old_energy(1),1,& energy_check(1),r_old(:,:,1),iw,discrete_array(:,:),& - rng_stream,error=error) + rng_stream) CASE("GEMC_NVT") CALL mc_ge_volume_move ( mc_par,force_env, moves,& move_updates,nnstep,old_energy,energy_check,& - r_old,rng_stream,error) + r_old,rng_stream) CASE("GEMC_NPT") ! we need to select a box based on the probability given in the input file - IF (ionode) rand=next_random_number(rng_stream,error=error) + IF (ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) DO ibox=1,nboxes @@ -520,26 +516,25 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe old_energy(box_number),box_number,& energy_check(box_number),r_old(:,:,box_number),iw,& discrete_array(:,:),& - rng_stream,error=error) + rng_stream) END SELECT ! update all the pointers here, because otherwise we may pass wrong information when we're making a bias environment DO ibox=1,nboxes CALL force_env_get(force_env(ibox)%force_env,& - subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell,& - error=error) + subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell) CALL get_cell(cell(ibox)%cell,abc=abc(:,ibox)) CALL cp_subsys_get(oldsys(ibox)%subsys,& - particles=particles_old(ibox)%list, error=error) + particles=particles_old(ibox)%list) ENDDO ! we need a new biasing environment now, if we're into that sort of thing IF(lbias) THEN DO ibox=1,nboxes - CALL force_env_release(bias_env(ibox)%force_env,error=error) + CALL force_env_release(bias_env(ibox)%force_env) ! determine the atom names of every particle ALLOCATE (atom_names_box(1:nunits_tot(ibox)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) start_mol=1 DO jbox=1,ibox-1 start_mol=start_mol+SUM(nchains(:,jbox)) @@ -556,8 +551,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! need to find out what the cell lengths are CALL force_env_get(force_env(ibox)%force_env,& - subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell,& - error=error) + subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell) CALL get_cell(cell(ibox)%cell,abc=abc(:,ibox)) CALL get_mc_par(mc_par(ibox)%mc_par,& @@ -567,21 +561,20 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe CALL mc_create_bias_force_env(bias_env(ibox)%force_env,& r_old(:,:,ibox),atom_names_box(:),nunits_tot(ibox),& para_env,abc(:,ibox),nchains_box,input_declaration,& - mc_bias_file,ionode,error) + mc_bias_file,ionode) IF(SUM(nchains(:,ibox)) .NE. 0) THEN CALL force_env_calc_energy_force(& bias_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(bias_env(ibox)%force_env,& - potential_energy=last_bias_energy(ibox),& - error=error) + potential_energy=last_bias_energy(ibox)) ELSE last_bias_energy(ibox)=0.0E0_dp ENDIF bias_energy(ibox)=last_bias_energy(ibox) DEALLOCATE(atom_names_box,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDDO ENDIF @@ -595,7 +588,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe CALL mc_ge_swap_move(mc_par,force_env,bias_env,moves,& energy_check(:),r_old(:,:,:),old_energy(:),input_declaration,& - para_env,bias_energy(:),last_bias_energy(:),rng_stream,error) + para_env,bias_energy(:),last_bias_energy(:),rng_stream) ! the number of molecules may have changed, which deallocated the whole ! mc_molecule_info structure @@ -613,7 +606,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ENDIF ! pick a box at random - IF (ionode) rand=next_random_number(rng_stream,error=error) + IF (ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) DO ibox=1,nboxes @@ -629,7 +622,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe move_updates(1,box_number)%moves,& old_energy(box_number),box_number,& energy_check(box_number),r_old(:,:,box_number),& - rng_stream,error=error) + rng_stream) ELSEIF ( rand .LT. pmavbmc) THEN ! try an AVBMC move @@ -639,7 +632,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ENDIF ! first, pick a box to do it for - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) IF(nboxes .EQ. 2) THEN @@ -653,7 +646,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ENDIF ! now pick a molecule type to do it for - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) molecule_type_swap=0 DO imol_type=1,nmol_types @@ -678,14 +671,13 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe IF (ionode) THEN CALL find_mc_test_molecule(mc_molecule_info,& start_atom_swap,idum,jdum,rng_stream,& - box=box_number,molecule_type_old=molecule_type_swap,& - error=error) + box=box_number,molecule_type_old=molecule_type_swap) ! pick a molecule to act as the target in the box...we don't care what type DO CALL find_mc_test_molecule(mc_molecule_info,& start_atom_target,idum,molecule_type_target,& - rng_stream,box=box_number,error=error) + rng_stream,box=box_number) IF(start_atom_swap .NE. start_atom_target) THEN start_atom_target=start_atom_target+& avbmc_atom(molecule_type_target)-1 @@ -695,7 +687,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! choose if we're swapping into the bonded region of mol_target, or ! into the nonbonded region - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ENDIF CALL mp_bcast(start_atom_swap,source,group) @@ -718,7 +710,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe start_atom_swap,start_atom_target,molecule_type_swap,& box_number,bias_energy(box_number),& last_bias_energy(box_number),& - move_type_avbmc,rng_stream,error=error) + move_type_avbmc,rng_stream) ENDIF @@ -731,12 +723,12 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe DO imove=1,nmoves - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) IF(rand .LT. pmtraion) THEN ! change molecular conformation ! first, pick a box to do it for - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) IF(nboxes .EQ. 2) THEN IF(rand .LT. 0.75E0_dp) THEN @@ -749,7 +741,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ENDIF ! figure out which molecule type we're looking for - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) molecule_type=0 DO imol_type=1,nmol_types @@ -774,11 +766,10 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe CALL find_mc_test_molecule(mc_molecule_info,& start_atom,idum,& jdum,rng_stream,& - box=box_number,molecule_type_old=molecule_type,& - error=error) + box=box_number,molecule_type_old=molecule_type) ! choose if we're changing a bond length or an angle - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ENDIF CALL mp_bcast(rand,source,group) CALL mp_bcast(start_atom,source,group) @@ -802,13 +793,13 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe move_updates(molecule_type,box_number)%moves,& start_atom,molecule_type,box_number,& bias_energy(box_number),& - move_type,lreject,rng_stream,error=error) + move_type,lreject,rng_stream) IF(lreject) EXIT ENDIF ELSEIF(rand .LT. pmtrans) THEN ! translate a whole molecule in the system ! pick a molecule type - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) molecule_type=0 DO imol_type=1,nmol_types @@ -825,7 +816,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe IF(ionode) & CALL find_mc_test_molecule(mc_molecule_info,& start_atom,box_number,idum,rng_stream,& - molecule_type_old=molecule_type,error=error) + molecule_type_old=molecule_type) CALL mp_bcast(start_atom,source,group) CALL mp_bcast(box_number,source,group) box_flag(box_number)=1 @@ -835,12 +826,12 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe moves(molecule_type,box_number)%moves,& move_updates(molecule_type,box_number)%moves,& start_atom,box_number,bias_energy(box_number),& - molecule_type,lreject,rng_stream,error=error) + molecule_type,lreject,rng_stream) IF(lreject) EXIT ELSE ! rotate a whole molecule in the system ! pick a molecule type - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) molecule_type=0 DO imol_type=1,nmol_types @@ -856,7 +847,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe IF(ionode) & CALL find_mc_test_molecule(mc_molecule_info,& start_atom,box_number,idum,rng_stream,& - molecule_type_old=molecule_type,error=error) + molecule_type_old=molecule_type) CALL mp_bcast(start_atom,source,group) CALL mp_bcast(box_number,source,group) box_flag(box_number)=1 @@ -867,7 +858,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe move_updates(molecule_type,box_number)%moves,& box_number,start_atom,& molecule_type,bias_energy(box_number),& - lreject,rng_stream,error=error) + lreject,rng_stream) IF(lreject) EXIT ENDIF @@ -878,7 +869,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe moves,lreject,move_updates,energy_check(:),r_old(:,:,:),& nnstep,old_energy(:),bias_energy(:),last_bias_energy(:),& nboxes,box_flag(:),oldsys,particles_old,& - rng_stream,unit_conv,error=error) + rng_stream,unit_conv) ENDIF @@ -886,11 +877,10 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! have changed DO ibox=1,nboxes CALL force_env_get(force_env(ibox)%force_env,& - subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell,& - error=error) + subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell) CALL get_cell(cell(ibox)%cell,abc=abc(:,ibox)) CALL cp_subsys_get(oldsys(ibox)%subsys,& - particles=particles_old(ibox)%list, error=error) + particles=particles_old(ibox)%list) ENDDO IF(ionode) THEN @@ -929,7 +919,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe com_crd,dump_xmol,'POS',& 'BOX ' // TRIM(ADJUSTL(cbox))// & ', STEP ' // TRIM(ADJUSTL(cstep)),& - unit_conv=unit_conv,error=error) + unit_conv=unit_conv) ENDIF ENDDO ENDIF ! end the things we only do every iprint moves @@ -971,7 +961,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe box_flag(:)=0 ! check to see if EXIT file exists...if so, end the calculation - CALL external_control(should_stop,"MC",globenv=globenv,error=error) + CALL external_control(should_stop,"MC",globenv=globenv) IF (should_stop) EXIT ! update the move displacements, if necessary @@ -1012,7 +1002,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! we can get screwed up with the mc_molecule_info stuff (like in swap move)... ! this is kind of ugly, with allocated and deallocating every time ALLOCATE (r_temp(1:3,1:nunits_tot(ibox)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO iunit=1,nunits_tot(ibox) r_temp(1:3,iunit)=& @@ -1033,9 +1023,9 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ! if we're biasing, we need to do the same IF(lbias) THEN CALL force_env_get(bias_env(ibox)%force_env,& - subsys=biassys,error=error) + subsys=biassys) CALL cp_subsys_get(biassys,& - particles=particles_bias, error=error) + particles=particles_bias) DO iunit=1,nunits_tot(ibox) particles_bias%els(iunit)%r(1:3)=& @@ -1044,7 +1034,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ENDIF DEALLOCATE (r_temp,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDIF ENDDO @@ -1055,10 +1045,9 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe DO ibox=1,nboxes IF(SUM(nchains(:,ibox)) .NE. 0) THEN CALL force_env_calc_energy_force(force_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env,& - potential_energy=test_energy,& - error=error) + potential_energy=test_energy) ELSE test_energy=0.0E0_dp ENDIF @@ -1091,15 +1080,14 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe DO ibox=1,nboxes IF(SUM(nchains(:,ibox)) .NE. 0) THEN CALL force_env_calc_energy_force(force_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env,& - potential_energy=final_energy(ibox),& - error=error) + potential_energy=final_energy(ibox)) ELSE final_energy(ibox)=0.0E0_dp ENDIF IF (lbias) THEN - CALL force_env_release(bias_env(ibox)%force_env,error=error) + CALL force_env_release(bias_env(ibox)%force_env) ENDIF ENDDO @@ -1118,8 +1106,7 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe CALL write_particle_coordinates(& particles_old(ibox)%list%els,& com_crd,dump_xmol,'POS',& - 'FINAL BOX ' // TRIM(ADJUSTL(cbox)),unit_conv=unit_conv,& - error=error) + 'FINAL BOX ' // TRIM(ADJUSTL(cbox)),unit_conv=unit_conv) ENDIF ! write a bunch of data to the screen @@ -1165,29 +1152,29 @@ SUBROUTINE mc_run_ensemble ( mc_env, para_env, globenv, input_declaration, nboxe ENDDO DEALLOCATE(pmhmc_box,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pmvol_box,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_old,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(force_env,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bias_env,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (cell,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (particles_old,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (oldsys,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (averages,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (moves,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (move_updates,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (mc_par,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! end the timing CALL timestop(handle) @@ -1208,15 +1195,13 @@ END SUBROUTINE mc_run_ensemble !> \param rng_stream the stream we pull random numbers from !> !> Suitable for parallel. -!> \param error the error type !> \author MJM ! ***************************************************************************** - SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) + SUBROUTINE mc_compute_virial ( mc_env, rng_stream) TYPE(mc_environment_p_type), & DIMENSION(:), POINTER :: mc_env TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_compute_virial', & routineP = moduleN//':'//routineN @@ -1248,16 +1233,16 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) DIMENSION(:), POINTER :: particles failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! these are current magic numbers for how we compute the virial... ! we break it up into three parts to integrate the function so provide ! better statistics nintegral_divisions=3 ALLOCATE (virial_cutoffs(1:nintegral_divisions),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (virial_stepsize(1:nintegral_divisions),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) virial_cutoffs(1)=8.0 ! first distance, in bohr virial_cutoffs(2)=13.0 ! second distance, in bohr virial_cutoffs(3)=22.0 ! maximum distance, in bohr @@ -1274,15 +1259,15 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) ! allocate a whole bunch of stuff based on how many boxes we have ALLOCATE (force_env(1:1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (cell(1:1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (particles(1:1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (subsys(1:1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (mc_par(1:1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL get_mc_env ( mc_env(1)%mc_env, & mc_par = mc_par(1)%mc_par,& @@ -1311,7 +1296,7 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) nvirial_temps=SIZE(virial_temps) ALLOCATE (BETA(1:nvirial_temps),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO itemp=1,nvirial_temps BETA(itemp) = 1 / virial_temps(itemp) / boltzmann * joule @@ -1319,11 +1304,10 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) ! get the subsystems and the cell information CALL force_env_get(force_env(1)%force_env,& - subsys=subsys(1)%subsys,cell=cell(1)%cell,& - error=error) + subsys=subsys(1)%subsys,cell=cell(1)%cell) CALL get_cell(cell(1)%cell,abc=abc(:)) CALL cp_subsys_get(subsys(1)%subsys, & - particles=particles(1)%list, error=error) + particles=particles(1)%list) ! check and make sure the box is big enough IF(abc(1) .NE. abc(2) .OR. abc(2) .NE. abc(3)) THEN @@ -1340,7 +1324,7 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) ! store the coordinates of the molecules in an array so we can work with it ALLOCATE (r_old(1:3,1:nunits_tot(1)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO iparticle=1,nunits_tot(1) r_old(1:3,iparticle)=& @@ -1367,7 +1351,7 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) ! we'll compute the average potential, and then integrate that, as opposed to ! integrating every orientation and then averaging ALLOCATE (mayer(1:nvirial_temps,1:nbins),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) mayer(:,:)=0.0_dp @@ -1388,7 +1372,7 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) IF(ionode) THEN CALL rotate_molecule(r_old(:,start_atom:end_atom),& mass(1:nunits(mol_type(2)),mol_type(2)),& - nunits(mol_type(2)),rng_stream,error=error) + nunits(mol_type(2)),rng_stream) ENDIF CALL mp_bcast(r_old(:,:),source,group) @@ -1424,9 +1408,9 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) ENDDO ELSE CALL force_env_calc_energy_force(force_env(1)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env(1)%force_env,& - potential_energy=trial_energy,error=error) + potential_energy=trial_energy) DO itemp=1,nvirial_temps @@ -1503,25 +1487,25 @@ SUBROUTINE mc_compute_virial ( mc_env, rng_stream, error) ! deallocate some stuff DEALLOCATE(mc_par,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(subsys,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(force_env,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(particles,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cell,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(virial_cutoffs,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(virial_stepsize,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_old,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mayer,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(BETA,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE mc_compute_virial diff --git a/src/motion/mc/mc_environment_types.F b/src/motion/mc/mc_environment_types.F index f82b7f9871..2ed6a962d1 100644 --- a/src/motion/mc/mc_environment_types.F +++ b/src/motion/mc/mc_environment_types.F @@ -46,13 +46,11 @@ MODULE mc_environment_types !> \param mc_env the mc_environment you want to create !> !> Suitable for parallel use. -!> \param error ... !> \author MJM ! ***************************************************************************** - SUBROUTINE mc_env_create ( mc_env, error ) + SUBROUTINE mc_env_create ( mc_env) TYPE(mc_environment_type), POINTER :: mc_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mc_env_create', & routineP = moduleN//':'//routineN @@ -60,7 +58,7 @@ SUBROUTINE mc_env_create ( mc_env, error ) INTEGER :: istat ALLOCATE ( mc_env, stat=istat ) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) last_mc_env_id=last_mc_env_id+1 mc_env%id_nr=last_mc_env_id @@ -122,17 +120,12 @@ END SUBROUTINE get_mc_env ! ***************************************************************************** !> \brief retains the given mc env !> \param mc_env the force environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> -!> Suitable for parallel. !> \author MJM !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** -SUBROUTINE mc_env_retain(mc_env, error) +SUBROUTINE mc_env_retain(mc_env) TYPE(mc_environment_type), POINTER :: mc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_env_retain', & routineP = moduleN//':'//routineN @@ -141,25 +134,20 @@ SUBROUTINE mc_env_retain(mc_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(mc_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(mc_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(mc_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(mc_env%ref_count>0,cp_failure_level,routineP) mc_env%ref_count=mc_env%ref_count+1 END SUBROUTINE mc_env_retain ! ***************************************************************************** !> \brief releases the given mc env !> \param mc_env the mc environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> -!> Suitable for parallel. !> \author MJM !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** -SUBROUTINE mc_env_release(mc_env, error) +SUBROUTINE mc_env_release(mc_env) TYPE(mc_environment_type), POINTER :: mc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_env_release', & routineP = moduleN//':'//routineN @@ -170,7 +158,7 @@ SUBROUTINE mc_env_release(mc_env, error) failure=.FALSE. IF (ASSOCIATED(mc_env)) THEN - CPPreconditionNoFail(mc_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(mc_env%ref_count>0,cp_failure_level,routineP) mc_env%ref_count=mc_env%ref_count-1 IF (mc_env%ref_count==0) THEN mc_env%ref_count=1 @@ -178,7 +166,7 @@ SUBROUTINE mc_env_release(mc_env, error) NULLIFY ( mc_env % force_env) mc_env%ref_count=0 DEALLOCATE(mc_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(mc_env) diff --git a/src/motion/mc/mc_ge_moves.F b/src/motion/mc/mc_ge_moves.F index 35955c4573..533a0baad4 100644 --- a/src/motion/mc/mc_ge_moves.F +++ b/src/motion/mc/mc_ge_moves.F @@ -99,16 +99,13 @@ MODULE mc_ge_moves !> \param particles the pointers for the particle sets !> \param rng_stream the stream we pull random numbers from !> \param unit_conv ... -!> \param error the cp_error_type in case something goes wrong -!> -!> Designed for parallel use. !> \author MJM ! ***************************************************************************** SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& lreject,move_updates,energy_check,r_old,& nnstep,old_energy,bias_energy_new,last_bias_energy,& nboxes,box_flag,subsys,particles,rng_stream,& - unit_conv,error) + unit_conv) TYPE(mc_simulation_parameters_p_type), & DIMENSION(:), POINTER :: mc_par @@ -135,7 +132,6 @@ SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& DIMENSION(:), POINTER :: particles TYPE(rng_stream_type), POINTER :: rng_stream REAL(KIND=dp), INTENT(IN) :: unit_conv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_Quickstep_move', & routineP = moduleN//':'//routineN @@ -190,9 +186,9 @@ SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& ! grab the coordinates for the force_env DO ibox=1,nboxes CALL force_env_get(force_env(ibox)%force_env,& - subsys=subsys(ibox)%subsys,error=error) + subsys=subsys(ibox)%subsys) CALL cp_subsys_get(subsys(ibox)%subsys, & - particles=particles(ibox)%list, error=error) + particles=particles(ibox)%list) ENDDO ! calculate the new energy of the system...if we're biasing, @@ -202,9 +198,9 @@ SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& IF(lbias) THEN ! grab the coords from bias_env and put them into force_env CALL force_env_get(bias_env(ibox)%force_env,& - subsys=subsys_bias(ibox)%subsys,error=error) + subsys=subsys_bias(ibox)%subsys) CALL cp_subsys_get(subsys_bias(ibox)%subsys, & - particles=particles_bias(ibox)%list, error=error) + particles=particles_bias(ibox)%list) DO iparticle=1,nunits_tot(ibox) particles(ibox)%list%els(iparticle)%r(1:3)=& @@ -212,15 +208,15 @@ SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& ENDDO CALL force_env_calc_energy_force(force_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env,& - potential_energy=new_energy(ibox),error=error) + potential_energy=new_energy(ibox)) ELSE IF( .NOT. lreject) THEN CALL force_env_calc_energy_force(force_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env,& - potential_energy=new_energy(ibox),error=error) + potential_energy=new_energy(ibox)) ENDIF ENDIF ELSE @@ -243,7 +239,7 @@ SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& CALL write_particle_coordinates(& particles(ibox)%list%els,& diff(ibox),dump_xmol,'POS','TRIAL',& - unit_conv=unit_conv,error=error) + unit_conv=unit_conv) ENDIF ENDDO ENDIF @@ -307,7 +303,7 @@ SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& w=1.0E0_dp rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF @@ -407,10 +403,10 @@ SUBROUTINE mc_Quickstep_move(mc_par,force_env,bias_env,moves,& ! make sure the coordinates are transferred DO ibox=1,nboxes CALL cp_subsys_set(subsys(ibox)%subsys,& - particles=particles(ibox)%list,error=error) + particles=particles(ibox)%list) IF(lbias .AND. box_flag(ibox) == 1) & CALL cp_subsys_set(subsys_bias(ibox)%subsys,& - particles=particles_bias(ibox)%list,error=error) + particles=particles_bias(ibox)%list) ENDDO ! deallocate some stuff @@ -445,15 +441,12 @@ END SUBROUTINE mc_Quickstep_move !> potential !> \param last_bias_energy the energy for the biased simulations !> \param rng_stream the stream we pull random numbers from -!> \param error the cp_error_type in case something goes wrong -!> -!> Suitable for parallel. !> \author MJM ! ***************************************************************************** SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& energy_check,r_old,old_energy,input_declaration,& para_env,bias_energy_old,last_bias_energy,& - rng_stream,error) + rng_stream) TYPE(mc_simulation_parameters_p_type), & DIMENSION(:), POINTER :: mc_par @@ -473,7 +466,6 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& INTENT(INOUT) :: bias_energy_old, & last_bias_energy TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_ge_swap_move', & routineP = moduleN//':'//routineN @@ -558,14 +550,13 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& ! get the old coordinates DO ibox=1,2 CALL force_env_get(force_env(ibox)%force_env,& - subsys=oldsys(ibox)%subsys,error=error) + subsys=oldsys(ibox)%subsys) CALL cp_subsys_get(oldsys(ibox)%subsys, & - particles=particles_old(ibox)%list, & - error=error) + particles=particles_old(ibox)%list) ENDDO ! choose a direction to swap - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) IF ( rand .LE. 0.50E0_dp ) THEN @@ -585,7 +576,7 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& ! insert_box=1 ! now choose a molecule type at random - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) DO itype=1,nmol_types IF(rand .LT. pmswap_mol(itype)) THEN @@ -606,7 +597,7 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& moves(molecule_type,insert_box)%moves%empty+1 ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) imolecule=CEILING(rand*nchains(molecule_type,remove_box)) ! figure out the atom number this molecule starts on @@ -682,14 +673,14 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& ! grab the cells for later...acceptance and insertion IF(lbias) THEN CALL force_env_get(bias_env(insert_box)%force_env,& - cell=cell_insert,error=error) + cell=cell_insert) CALL force_env_get(bias_env(remove_box)%force_env,& - cell=cell_remove,error=error) + cell=cell_remove) ELSE CALL force_env_get(force_env(insert_box)%force_env,& - cell=cell_insert,error=error) + cell=cell_insert) CALL force_env_get(force_env(remove_box)%force_env,& - cell=cell_remove,error=error) + cell=cell_remove) ENDIF CALL get_cell(cell_remove,abc=abc_remove) CALL get_cell(cell_insert,abc=abc_insert) @@ -697,7 +688,7 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& IF(ionode) THEN ! choose an insertion point DO idim=1,3 - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) pos_insert(idim)=rand*abc_insert(1) ENDDO ENDIF @@ -866,9 +857,9 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "test_env",3*ins_atoms*dp_size) CALL mc_create_force_env(test_env(insert_box)%force_env,input_declaration,& - para_env, dat_file(insert_box),error=error) + para_env, dat_file(insert_box)) CALL mc_create_force_env(test_env(remove_box)%force_env,input_declaration,& - para_env, dat_file(remove_box),error=error) + para_env, dat_file(remove_box)) ! allocate an array we'll need ALLOCATE(r_cbmc(1:3,1:ins_atoms),STAT=istat) @@ -883,10 +874,10 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& ! compute the new molecule information...we need this for the CBMC part IF(rem_atoms == 0) THEN - CALL mc_determine_molecule_info(test_env,mc_molecule_info_test,error,& + CALL mc_determine_molecule_info(test_env,mc_molecule_info_test,& box_number=remove_box) ELSE - CALL mc_determine_molecule_info(test_env,mc_molecule_info_test,error) + CALL mc_determine_molecule_info(test_env,mc_molecule_info_test) ENDIF CALL get_mc_molecule_info(mc_molecule_info_test,nchains=nchains_test,& mol_type=mol_type_test) @@ -905,7 +896,7 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& exp_min_val,nswapmoves,weight_new,start_atom_ins,ins_atoms,nunits(:),& nunits(molecule_type),mass(:,molecule_type),loverlap_ins,bias_energy_new(insert_box),& bias_energy_old(insert_box),ionode,.FALSE.,mol_type_test(start_mol:end_mol),& - nchains_test(:,insert_box),source,group,rng_stream,error) + nchains_test(:,insert_box),source,group,rng_stream) ! the energy that comes out of the above routine is the difference...we want ! the real energy for the acceptance rule...we don't do this for the @@ -919,13 +910,13 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& exp_min_val,nswapmoves,weight_new,start_atom_ins,ins_atoms,nunits(:),& nunits(molecule_type),mass(:,molecule_type),loverlap_ins,new_energy(insert_box),& old_energy(insert_box),ionode,.FALSE.,mol_type_test(start_mol:end_mol),& - nchains_test(:,insert_box),source,group,rng_stream,error) + nchains_test(:,insert_box),source,group,rng_stream) ENDIF CALL force_env_get(test_env(insert_box)%force_env,& - subsys=insert_sys,error=error) + subsys=insert_sys) CALL cp_subsys_get(insert_sys, & - particles=particles_insert,error=error) + particles=particles_insert) DO iatom=1,ins_atoms r_cbmc(1:3,iatom)=particles_insert%els(iatom)%r(1:3) @@ -936,8 +927,8 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& IF(loverlap_ins .OR. loverlap_rem) THEN ! deallocate some stuff CALL mc_molecule_info_destroy(mc_molecule_info_test) - CALL force_env_release(test_env(insert_box)%force_env,error=error) - CALL force_env_release(test_env(remove_box)%force_env,error=error) + CALL force_env_release(test_env(insert_box)%force_env) + CALL force_env_release(test_env(remove_box)%force_env) DEALLOCATE(insert_coords,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,& __LINE__,"insert_coords") @@ -966,9 +957,9 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& ! broadcast the choosen coordiantes to all processors CALL force_env_get(test_env(insert_box)%force_env,& - subsys=insert_sys,error=error) + subsys=insert_sys) CALL cp_subsys_get(insert_sys, & - particles=particles_insert,error=error) + particles=particles_insert) DO iatom=1,ins_atoms particles_insert%els(iatom)%r(1:3)= & @@ -995,12 +986,12 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& test_env_bias(insert_box)%force_env => test_env(insert_box)%force_env NULLIFY(test_env(insert_box)%force_env) CALL mc_create_force_env(test_env(insert_box)%force_env, input_declaration, & - para_env, dat_file(insert_box),error=error) + para_env, dat_file(insert_box)) CALL force_env_calc_energy_force(test_env(insert_box)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(test_env(insert_box)%force_env,& - potential_energy=new_energy(insert_box),error=error) + potential_energy=new_energy(insert_box)) ! now the environment that has one less molecule IF (SUM(nchains_test(:,remove_box)) == 0) THEN @@ -1011,7 +1002,7 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& test_env_bias(remove_box)%force_env => test_env(remove_box)%force_env NULLIFY(test_env(remove_box)%force_env) CALL mc_create_force_env(test_env(remove_box)%force_env,input_declaration,& - para_env,dat_file(remove_box),error=error) + para_env,dat_file(remove_box)) new_energy(remove_box)=0.0E0_dp bias_energy_new(remove_box)=0.0E0_dp ELSE @@ -1022,24 +1013,24 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& test_env_bias(remove_box)%force_env => test_env(remove_box)%force_env NULLIFY(test_env(remove_box)%force_env) CALL mc_create_force_env(test_env(remove_box)%force_env,input_declaration,& - para_env,dat_file(remove_box),error=error) + para_env,dat_file(remove_box)) CALL force_env_calc_energy_force(test_env(remove_box)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(test_env(remove_box)%force_env,& - potential_energy=new_energy(remove_box),error=error) + potential_energy=new_energy(remove_box)) CALL force_env_calc_energy_force(test_env_bias(remove_box)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(test_env_bias(remove_box)%force_env,& - potential_energy=bias_energy_new(remove_box),error=error) + potential_energy=bias_energy_new(remove_box)) ENDIF ELSE IF (SUM(nchains_test(:,remove_box)) == 0) THEN new_energy(remove_box)=0.0E0_dp ELSE CALL force_env_calc_energy_force(test_env(remove_box)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(test_env(remove_box)%force_env,& - potential_energy=new_energy(remove_box),error=error) + potential_energy=new_energy(remove_box)) ENDIF ENDIF @@ -1059,14 +1050,14 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& exp_min_val,nswapmoves,weight_old,start_atom_rem,nunits_tot(remove_box),& nunits(:),nunits(molecule_type),mass(:,molecule_type),loverlap_rem,rdum,& bias_energy_new(remove_box),ionode,.TRUE.,mol_type(start_mol:end_mol),& - nchains(:,remove_box),source,group,rng_stream,error) + nchains(:,remove_box),source,group,rng_stream) ELSE CALL generate_cbmc_swap_config(force_env(remove_box)%force_env,& BETA,max_val, min_val, exp_max_val,& exp_min_val,nswapmoves,weight_old,start_atom_rem,nunits_tot(remove_box),& nunits(:),nunits(molecule_type),mass(:,molecule_type),loverlap_rem,rdum,& new_energy(remove_box),ionode,.TRUE.,mol_type(start_mol:end_mol),& - nchains(:,remove_box),source,group,rng_stream,error) + nchains(:,remove_box),source,group,rng_stream) ENDIF ! figure out the prefactor to the boltzmann weight in the acceptance @@ -1104,7 +1095,7 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& IF(w .GE. 1.0E0_dp) THEN rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF @@ -1146,33 +1137,33 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& ! update coordinates CALL force_env_get(test_env(insert_box)%force_env,& - subsys=insert_sys,error=error) + subsys=insert_sys) CALL cp_subsys_get(insert_sys, & - particles=particles_insert,error=error) + particles=particles_insert) DO ipart=1,ins_atoms r_old(1:3,ipart,insert_box)=particles_insert%els(ipart)%r(1:3) ENDDO CALL force_env_get(test_env(remove_box)%force_env,& - subsys=remove_sys,error=error) + subsys=remove_sys) CALL cp_subsys_get(remove_sys, & - particles=particles_remove,error=error) + particles=particles_remove) DO ipart=1,rem_atoms r_old(1:3,ipart,remove_box)=particles_remove%els(ipart)%r(1:3) ENDDO ! insertion box - CALL force_env_release(force_env(insert_box)%force_env,error=error) + CALL force_env_release(force_env(insert_box)%force_env) force_env(insert_box)%force_env => test_env(insert_box)%force_env ! removal box - CALL force_env_release(force_env(remove_box)%force_env,error=error) + CALL force_env_release(force_env(remove_box)%force_env) force_env(remove_box)%force_env => test_env(remove_box)%force_env ! if we're biasing, update the bias_env IF(lbias) THEN - CALL force_env_release(bias_env(insert_box)%force_env,error=error) + CALL force_env_release(bias_env(insert_box)%force_env) bias_env(insert_box)%force_env => test_env_bias(insert_box)%force_env - CALL force_env_release(bias_env(remove_box)%force_env,error=error) + CALL force_env_release(bias_env(remove_box)%force_env) bias_env(remove_box)%force_env => test_env_bias(remove_box)%force_env DEALLOCATE(test_env_bias,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,& @@ -1183,11 +1174,11 @@ SUBROUTINE mc_ge_swap_move(mc_par,force_env,bias_env,moves,& ! reject the move CALL mc_molecule_info_destroy(mc_molecule_info_test) - CALL force_env_release(test_env(insert_box)%force_env,error=error) - CALL force_env_release(test_env(remove_box)%force_env,error=error) + CALL force_env_release(test_env(insert_box)%force_env) + CALL force_env_release(test_env(remove_box)%force_env) IF(lbias) THEN - CALL force_env_release( test_env_bias(insert_box)%force_env,error=error) - CALL force_env_release( test_env_bias(remove_box)%force_env,error=error) + CALL force_env_release( test_env_bias(insert_box)%force_env) + CALL force_env_release( test_env_bias(remove_box)%force_env) DEALLOCATE(test_env_bias,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,& __LINE__,"test_env_bias") @@ -1240,13 +1231,10 @@ END SUBROUTINE mc_ge_swap_move !> \param r_old the coordinates of the last accepted move involving a !> Quickstep calculation !> \param rng_stream the stream we pull random numbers from -!> \param error the cp_error_type in case of problems -!> -!> Designed for parallel. !> \author MJM ! ***************************************************************************** SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& - nnstep,old_energy,energy_check,r_old,rng_stream,error) + nnstep,old_energy,energy_check,r_old,rng_stream) TYPE(mc_simulation_parameters_p_type), & DIMENSION(:), POINTER :: mc_par @@ -1260,7 +1248,6 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& REAL(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT) :: r_old TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_ge_volume_move', & routineP = moduleN//':'//routineN @@ -1357,13 +1344,13 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& ! now let's grab the cell length and particle positions DO ibox=1,2 CALL force_env_get(force_env(ibox)%force_env,& - subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell,error=error) + subsys=oldsys(ibox)%subsys,cell=cell(ibox)%cell) CALL get_cell(cell(ibox)%cell,abc=abc(:,ibox)) NULLIFY(cell_old(ibox)%cell) - CALL cell_create(cell_old(ibox)%cell,error=error) - CALL cell_clone(cell(ibox)%cell,cell_old(ibox)%cell,error=error) + CALL cell_create(cell_old(ibox)%cell) + CALL cell_clone(cell(ibox)%cell,cell_old(ibox)%cell) CALL cp_subsys_get(oldsys(ibox)%subsys, & - particles=particles_old(ibox)%list, error=error) + particles=particles_old(ibox)%list) ! find the old cell length old_cell_length(1:3,ibox)=abc(1:3,ibox) @@ -1380,7 +1367,7 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& ENDDO ! call a random number to figure out how far we're moving - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) vol_dis=rmvolume*(rand-0.5E0_dp)*2.0E0_dp @@ -1410,9 +1397,9 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& hmat_test(3,3,ibox)=new_cell_length(3,ibox) NULLIFY (cell_test(ibox)%cell) CALL cell_create(cell_test(ibox)%cell,hmat=hmat_test(:,:,ibox),& - periodic=cell(ibox)%cell%perd,error=error) - CALL force_env_get(force_env(ibox)%force_env, subsys=subsys, error=error) - CALL cp_subsys_set(subsys, cell=cell_test(ibox)%cell, error=error) + periodic=cell(ibox)%cell%perd) + CALL force_env_get(force_env(ibox)%force_env, subsys=subsys) + CALL cp_subsys_set(subsys, cell=cell_test(ibox)%cell) ENDDO DO ibox=1,2 @@ -1478,9 +1465,9 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& ELSE CALL force_env_calc_energy_force(force_env(ibox)%force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env(ibox)%force_env,& - potential_energy=new_energy(ibox),error=error) + potential_energy=new_energy(ibox)) ENDIF ENDDO @@ -1508,7 +1495,7 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& w=1.0E0_dp rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF @@ -1561,8 +1548,8 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& ! reset the cell and particle positions DO ibox=1,2 - CALL force_env_get(force_env(ibox)%force_env, subsys=subsys, error=error) - CALL cp_subsys_set(subsys, cell=cell_old(ibox)%cell, error=error) + CALL force_env_get(force_env(ibox)%force_env, subsys=subsys) + CALL cp_subsys_set(subsys, cell=cell_old(ibox)%cell) DO iatom=1,nunits_tot(ibox) particles_old(ibox)%list%els(iatom)%r(1:3)=r_old(1:3,iatom,ibox) ENDDO @@ -1572,8 +1559,8 @@ SUBROUTINE mc_ge_volume_move ( mc_par,force_env, moves,move_updates,& ! free up some memory DO ibox=1,2 - CALL cell_release(cell_test(ibox)%cell,error=error) - CALL cell_release(cell_old(ibox)%cell,error=error) + CALL cell_release(cell_test(ibox)%cell) + CALL cell_release(cell_old(ibox)%cell) ENDDO DEALLOCATE(r,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& diff --git a/src/motion/mc/mc_moves.F b/src/motion/mc/mc_moves.F index 341886ad90..a88433ac5e 100644 --- a/src/motion/mc/mc_moves.F +++ b/src/motion/mc/mc_moves.F @@ -131,15 +131,12 @@ END SUBROUTINE depth_first_search !> \param move_type dictates what kind of conformational change we do !> \param lreject set to .true. if there is an overlap !> \param rng_stream the random number stream that we draw from -!> \param error the cp_error type -!> -!> This subroutine is designed to run in parallel. !> \author MJM ! ***************************************************************************** SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& move_updates,start_atom,molecule_type,box_number,& bias_energy,move_type,lreject,& - rng_stream,error) + rng_stream) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(force_env_type), POINTER :: force_env, bias_env @@ -150,7 +147,6 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& CHARACTER(LEN=*), INTENT(IN) :: move_type LOGICAL, INTENT(OUT) :: lreject TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_conformation_change', & routineP = moduleN//':'//routineN @@ -224,20 +220,19 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& IF(lbias) THEN ! grab the coordinates - CALL force_env_get(bias_env,subsys=subsys,error=error) + CALL force_env_get(bias_env,subsys=subsys) ! save the energy bias_energy_old=bias_energy ELSE ! grab the coordinates - CALL force_env_get(force_env,subsys=subsys,error=error) + CALL force_env_get(force_env,subsys=subsys) ENDIF ! now find the molecule type associated with this guy CALL cp_subsys_get(subsys, & - particles=particles, molecule_kinds_new=molecule_kinds_new,& - error=error) + particles=particles, molecule_kinds_new=molecule_kinds_new) DO imol_type=1,SIZE(molecule_kinds_new%els(:)) molecule_kind_test => molecule_kinds_new%els(imol_type) CALL get_molecule_kind(molecule_kind_test,name=name) @@ -274,7 +269,7 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& ! do the move CALL change_bond_length(r_old,r_new,mc_par,molecule_type,& - molecule_kind,dis_length,particles,rng_stream,error=error) + molecule_kind,dis_length,particles,rng_stream) ELSEIF( move_type == 'angle') THEN @@ -294,7 +289,7 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& ! do the move CALL change_bond_angle(r_old,r_new,mc_par,molecule_type,& - molecule_kind,particles,rng_stream,error=error) + molecule_kind,particles,rng_stream) dis_length=1.0E0_dp ELSE ! record the attempt @@ -313,7 +308,7 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& ! do the move CALL change_dihedral(r_old,r_new,mc_par,molecule_type,& - molecule_kind,particles,rng_stream,error=error) + molecule_kind,particles,rng_stream) dis_length=1.0E0_dp ENDIF @@ -344,9 +339,9 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& IF(loverlap) THEN w=0.0E0_dp ELSE - CALL force_env_calc_energy_force(bias_env,calc_force=.FALSE.,error=error) + CALL force_env_calc_energy_force(bias_env,calc_force=.FALSE.) CALL force_env_get(bias_env,& - potential_energy=bias_energy_new,error=error) + potential_energy=bias_energy_new) ! accept or reject the move based on the Metropolis rule with a ! correction factor for the change in phase space...dis_length is ! made unitless in change_bond_length @@ -366,7 +361,7 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& rand=0.0E0_dp ELSE IF(ionode) THEN - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ENDIF CALL mp_bcast(rand,source,group) ENDIF @@ -404,12 +399,12 @@ SUBROUTINE mc_conformation_change ( mc_par,force_env,bias_env, moves,& ! reject the move ! restore the coordinates - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO ipart=start_atom,end_atom particles%els(ipart)%r(1:3)=r_old(1:3,ipart-start_atom+1) ENDDO - CALL cp_subsys_set(subsys,particles=particles,error=error) + CALL cp_subsys_set(subsys,particles=particles) ENDIF @@ -446,15 +441,12 @@ END SUBROUTINE mc_conformation_change !> \param molecule_type the type of molecule we're moving !> \param lreject set to .true. if there is an overlap !> \param rng_stream the random number stream that we draw from -!> \param error the cp_error type -!> -!> This subroutine designed to be parallel. !> \author MJM ! ***************************************************************************** SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& move_updates,start_atom,box_number,& bias_energy,molecule_type,& - lreject,rng_stream,error) + lreject,rng_stream) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(force_env_type), POINTER :: force_env, bias_env @@ -464,7 +456,6 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& INTEGER, INTENT(IN) :: molecule_type LOGICAL, INTENT(OUT) :: lreject TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_molecule_translation', & routineP = moduleN//':'//routineN @@ -533,8 +524,8 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& IF(lbias) THEN ! grab the coordinates - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ! save the coordinates DO ipart=1,nunits_tot(box_number) @@ -547,8 +538,8 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& ELSE ! grab the coordinates - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ENDIF ! record the attempt @@ -566,13 +557,13 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& ! move one molecule in the system ! call a random number to figure out which direction we're moving - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ! 1,2,3 with equal prob move_direction=INT(3*rand)+1 ! call a random number to figure out how far we're moving - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) dis_mol=rmtrans(molecule_type)*(rand-0.5E0_dp)*2.0E0_dp @@ -581,7 +572,7 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& particles%els(iparticle)%r(move_direction)=& particles%els(iparticle)%r(move_direction)+dis_mol ENDDO - CALL cp_subsys_set(subsys,particles=particles,error=error) + CALL cp_subsys_set(subsys,particles=particles) ! figure out if there is any overlap...need the number of the molecule lreject=.FALSE. @@ -603,9 +594,9 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& IF(loverlap) THEN w=0.0E0_dp ELSE - CALL force_env_calc_energy_force(bias_env,calc_force=.FALSE.,error=error) + CALL force_env_calc_energy_force(bias_env,calc_force=.FALSE.) CALL force_env_get(bias_env,& - potential_energy=bias_energy_new,error=error) + potential_energy=bias_energy_new) ! accept or reject the move based on the Metropolis rule value=-BETA*(bias_energy_new-bias_energy_old) IF (value .GT. exp_max_val) THEN @@ -622,7 +613,7 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& w=1.0E0_dp rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF @@ -642,12 +633,12 @@ SUBROUTINE mc_molecule_translation( mc_par,force_env, bias_env,moves,& ! reject the move ! restore the coordinates - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO ipart=1,nunits_tot(box_number) particles%els(ipart)%r(1:3)=r_old(1:3,ipart) ENDDO - CALL cp_subsys_set(subsys,particles=particles,error=error) + CALL cp_subsys_set(subsys,particles=particles) ENDIF @@ -682,15 +673,12 @@ END SUBROUTINE mc_molecule_translation !> \param bias_energy the biased energy of the system before the move !> \param lreject set to .true. if there is an overlap !> \param rng_stream the random number stream that we draw from -!> \param error the cp_error type -!> -!> This subroutine has been designed for parallel use. !> \author MJM ! ***************************************************************************** SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& move_updates,box_number,& start_atom,molecule_type,bias_energy,lreject,& - rng_stream,error) + rng_stream) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(force_env_type), POINTER :: force_env, bias_env @@ -700,7 +688,6 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& REAL(KIND=dp), INTENT(INOUT) :: bias_energy LOGICAL, INTENT(OUT) :: lreject TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_molecule_rotation', & routineP = moduleN//':'//routineN @@ -778,8 +765,8 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& IF(lbias) THEN ! grab the coordinates - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ! save the coordinates DO ipart=1,nunits_tot(box_number) @@ -792,8 +779,8 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& ELSE ! grab the coordinates - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ENDIF ! grab the masses @@ -814,7 +801,7 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& ! rotate one molecule in the system ! call a random number to figure out which direction we're moving - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) ! CALL RANDOM_NUMBER(rand) CALL mp_bcast(rand,source,group) ! 1,2,3 with equal prob @@ -841,7 +828,7 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& nzcm = nzcm / masstot ! call a random number to figure out how far we're moving - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) dgamma=rmrot(molecule_type)*(rand-0.5E0_dp)*2.0E0_dp @@ -896,7 +883,7 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& ENDDO ENDIF - CALL cp_subsys_set(subsys,particles=particles,error=error) + CALL cp_subsys_set(subsys,particles=particles) ! check for overlap lreject=.FALSE. @@ -919,9 +906,9 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& IF(loverlap) THEN w=0.0E0_dp ELSE - CALL force_env_calc_energy_force(bias_env,calc_force=.FALSE.,error=error) + CALL force_env_calc_energy_force(bias_env,calc_force=.FALSE.) CALL force_env_get(bias_env,& - potential_energy=bias_energy_new,error=error) + potential_energy=bias_energy_new) ! accept or reject the move based on the Metropolis rule value=-BETA*(bias_energy_new-bias_energy_old) IF (value .GT. exp_max_val) THEN @@ -938,7 +925,7 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& w=1.0E0_dp rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF @@ -956,12 +943,12 @@ SUBROUTINE mc_molecule_rotation ( mc_par,force_env, bias_env,moves,& ! reject the move ! restore the coordinates - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO ipart=1,nunits_tot(box_number) particles%els(ipart)%r(1:3)=r_old(1:3,ipart) ENDDO - CALL cp_subsys_set(subsys,particles=particles,error=error) + CALL cp_subsys_set(subsys,particles=particles) ENDIF @@ -997,14 +984,12 @@ END SUBROUTINE mc_molecule_rotation !> \param discrete_array tells use which volumes we can do for the discrete !> case !> \param rng_stream the random number stream that we draw from -!> \param error the cp error type -!> !> \author MJM !> \note Designed for parallel use. ! ***************************************************************************** SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& old_energy,box_number,& - energy_check,r_old,iw,discrete_array,rng_stream,error) + energy_check,r_old,iw,discrete_array,rng_stream) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(force_env_type), POINTER :: force_env @@ -1018,7 +1003,6 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& INTEGER, DIMENSION(1:3, 1:2), & INTENT(INOUT) :: discrete_array TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mc_volume_move', & routineP = moduleN//':'//routineN @@ -1085,13 +1069,11 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& move_updates%volume%attempts=move_updates%volume%attempts+1 ! now let's grab the cell length and particle positions - CALL force_env_get(force_env,subsys=oldsys,cell=cell,& - error=error) + CALL force_env_get(force_env,subsys=oldsys,cell=cell) CALL get_cell(cell,abc=abc) - CALL cell_create(cell_old,error=error) - CALL cell_clone(cell,cell_old,error=error) - CALL cp_subsys_get(oldsys,particles=particles_old, & - error=error) + CALL cell_create(cell_old) + CALL cell_clone(cell,cell_old) + CALL cp_subsys_get(oldsys,particles=particles_old) ! find the old cell length old_cell_length(1)=abc(1) @@ -1106,7 +1088,7 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& ! now do the move ! call a random number to figure out how far we're moving - IF (ionode) rand=next_random_number(rng_stream,error=error) + IF (ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ! find the test cell lenghts for the discrete volume move @@ -1122,7 +1104,7 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& ! if we're increasing the volume, we need to find a side we can increase IF(lincrease) THEN DO - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) iside_change=CEILING(3.0_dp*rand) IF(discrete_array(iside_change,1) .EQ. 1) THEN @@ -1133,7 +1115,7 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& ENDDO ELSE DO - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) iside_change=CEILING(3.0_dp*rand) IF(discrete_array(iside_change,2) .EQ. 1) THEN @@ -1177,7 +1159,7 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& DEALLOCATE(r,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "r") - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() output_unit=cp_logger_get_default_io_unit(logger) IF(output_unit>0) WRITE(output_unit,*) & "Volume move rejected because we tried to make too small of box.",vol_dis @@ -1191,8 +1173,8 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& hmat_test(1,1)=new_cell_length(1) hmat_test(2,2)=new_cell_length(2) hmat_test(3,3)=new_cell_length(3) - CALL cell_create(cell_test,hmat=hmat_test(:,:),periodic=cell%perd,error=error) - CALL cp_subsys_set(oldsys, cell=cell_test, error=error) + CALL cell_create(cell_test,hmat=hmat_test(:,:),periodic=cell%perd) + CALL cp_subsys_set(oldsys, cell=cell_test) ! now we need to scale the coordinates of all the molecules by the ! center of mass, using the minimum image (not all molecules are in @@ -1239,14 +1221,14 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "r") - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() output_unit=cp_logger_get_default_io_unit(logger) IF(output_unit>0) WRITE(output_unit,*) & "Volume move rejected due to overlap.",vol_dis ! end the timing CALL timestop(handle) ! reset the cell and particle positions - CALL cp_subsys_set(oldsys, cell=cell_old, error=error) + CALL cp_subsys_set(oldsys, cell=cell_old) DO iatom=1,nunits_tot(box_number) particles_old%els(iatom)%r(1:3)=r_old(1:3,iatom) ENDDO @@ -1275,9 +1257,9 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& "Attempted a volume move where box size got too small.") ! now compute the energy - CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.,error=error) + CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.) CALL force_env_get(force_env,& - potential_energy=new_energy,error=error) + potential_energy=new_energy) ! accept or reject the move ! to prevent overflows @@ -1304,7 +1286,7 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& w=1.0E0_dp rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF @@ -1331,7 +1313,7 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& ELSE ! reset the cell and particle positions - CALL cp_subsys_set(oldsys, cell=cell_old, error=error) + CALL cp_subsys_set(oldsys, cell=cell_old) DO iatom=1,nunits_tot(box_number) particles_old%els(iatom)%r(1:3)=r_old(1:3,iatom) ENDDO @@ -1342,8 +1324,8 @@ SUBROUTINE mc_volume_move ( mc_par,force_env, moves,move_updates,& DEALLOCATE(r,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "r") - CALL cell_release(cell_test,error=error) - CALL cell_release(cell_old,error=error) + CALL cell_release(cell_test) + CALL cell_release(cell_old) ! end the timing CALL timestop(handle) @@ -1365,11 +1347,10 @@ END SUBROUTINE mc_volume_move !> \param rng_stream the random number stream that we draw from !> !> This subroutine is written to be parallel. -!> \param error ... !> \author MJM ! ***************************************************************************** SUBROUTINE change_bond_length ( r_old,r_new,mc_par,molecule_type,molecule_kind,& - dis_length,particles,rng_stream,error) + dis_length,particles,rng_stream) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: r_old @@ -1381,7 +1362,6 @@ SUBROUTINE change_bond_length ( r_old,r_new,mc_par,molecule_type,molecule_kind,& REAL(KIND=dp), INTENT(OUT) :: dis_length TYPE(particle_list_type), POINTER :: particles TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'change_bond_length', & routineP = moduleN//':'//routineN @@ -1419,7 +1399,7 @@ SUBROUTINE change_bond_length ( r_old,r_new,mc_par,molecule_type,molecule_kind,& ! pick which bond in the molecule at random IF(ionode) THEN - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ENDIF CALL mp_bcast(rand,source,group) CALL get_molecule_kind(molecule_kind,natom=natom,nbond=nbond,& @@ -1488,7 +1468,7 @@ SUBROUTINE change_bond_length ( r_old,r_new,mc_par,molecule_type,molecule_kind,& ENDDO ! choose a displacement - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) dis_length=rmbond(molecule_type)*2.0E0_dp*(rand-0.5E0_dp) @@ -1559,11 +1539,10 @@ END SUBROUTINE change_bond_length !> \param particles the particle_list_type for all particles in the force_env... !> used to grab the mass of each atom !> \param rng_stream the random number stream that we draw from -!> \param error ... !> \author MJM ! ***************************************************************************** SUBROUTINE change_bond_angle ( r_old,r_new,mc_par,molecule_type,molecule_kind,& - particles,rng_stream,error) + particles,rng_stream) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: r_old @@ -1574,7 +1553,6 @@ SUBROUTINE change_bond_angle ( r_old,r_new,mc_par,molecule_type,molecule_kind,& TYPE(molecule_kind_type), POINTER :: molecule_kind TYPE(particle_list_type), POINTER :: particles TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'change_bond_angle', & routineP = moduleN//':'//routineN @@ -1616,7 +1594,7 @@ SUBROUTINE change_bond_angle ( r_old,r_new,mc_par,molecule_type,molecule_kind,& ! pick which bond in the molecule at random IF(ionode) THEN - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ENDIF CALL mp_bcast(rand,source,group) CALL get_molecule_kind(molecule_kind,natom=natom,nbend=nbend,& @@ -1682,7 +1660,7 @@ SUBROUTINE change_bond_angle ( r_old,r_new,mc_par,molecule_type,molecule_kind,& ENDDO ! choose a displacement - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) dis_angle=rmangle(molecule_type)*2.0E0_dp*(rand-0.5E0_dp) @@ -1846,11 +1824,10 @@ END SUBROUTINE change_bond_angle !> \param particles the particle_list_type for all particles in the force_env.. !> used to grab the mass of each atom !> \param rng_stream the random number stream that we draw from -!> \param error ... !> \author MJM ! ***************************************************************************** SUBROUTINE change_dihedral ( r_old,r_new,mc_par,molecule_type,molecule_kind,& - particles,rng_stream,error) + particles,rng_stream) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: r_old @@ -1861,7 +1838,6 @@ SUBROUTINE change_dihedral ( r_old,r_new,mc_par,molecule_type,molecule_kind,& TYPE(molecule_kind_type), POINTER :: molecule_kind TYPE(particle_list_type), POINTER :: particles TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'change_dihedral', & routineP = moduleN//':'//routineN @@ -1904,7 +1880,7 @@ SUBROUTINE change_dihedral ( r_old,r_new,mc_par,molecule_type,molecule_kind,& ! pick which bond in the molecule at random IF(ionode) THEN - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) ! CALL RANDOM_NUMBER(rand) ENDIF CALL mp_bcast(rand,source,group) @@ -1973,7 +1949,7 @@ SUBROUTINE change_dihedral ( r_old,r_new,mc_par,molecule_type,molecule_kind,& ENDDO ! choose a displacement - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) dis_angle=rmdihedral(molecule_type)*2.0E0_dp*(rand-0.5E0_dp) @@ -2086,8 +2062,6 @@ END SUBROUTINE change_dihedral !> \param last_bias_energy the last biased energy of the system !> \param move_type dictates if we're moving to an "in" or "out" region !> \param rng_stream the random number stream that we draw from -!> \param error the cp_error type -!> !> \author MJM !> \note Designed for parallel. ! ***************************************************************************** @@ -2095,7 +2069,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& energy_check,r_old,old_energy,start_atom_swap,& target_atom,& molecule_type,box_number,bias_energy_old,last_bias_energy,& - move_type,rng_stream,error) + move_type,rng_stream) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(force_env_type), POINTER :: force_env, bias_env @@ -2110,7 +2084,6 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& last_bias_energy CHARACTER(LEN=*), INTENT(IN) :: move_type TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_avbmc_move', & routineP = moduleN//':'//routineN @@ -2173,10 +2146,9 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& IF(lbias) THEN ! grab the coordinates - CALL force_env_get(bias_env,cell=cell,subsys=subsys,error=error) + CALL force_env_get(bias_env,cell=cell,subsys=subsys) CALL cp_subsys_get(subsys, & - particles=particles, molecule_kinds_new=molecule_kinds_new,& - error=error) + particles=particles, molecule_kinds_new=molecule_kinds_new) molecule_kind => molecule_kinds_new%els(1) CALL get_molecule_kind(molecule_kind,natom=natom) CALL get_cell(cell,abc=abc) @@ -2187,10 +2159,9 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& ELSE ! grab the coordinates - CALL force_env_get(force_env,cell=cell,subsys=subsys,error=error) + CALL force_env_get(force_env,cell=cell,subsys=subsys) CALL cp_subsys_get(subsys, & - particles=particles, molecule_kinds_new=molecule_kinds_new,& - error=error) + particles=particles, molecule_kinds_new=molecule_kinds_new) molecule_kind => molecule_kinds_new%els(1) CALL get_molecule_kind(molecule_kind,natom=natom) CALL get_cell(cell,abc=abc) @@ -2248,7 +2219,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& weight_old,start_atom_swap,nunits_tot(box_number),nunits,nunits(molecule_type),& mass(:,molecule_type),ldum, rdum,& bias_energy_old,ionode,.TRUE.,mol_type(start_mol:end_mol),nchains(:,box_number),& - source,group,rng_stream,error,& + source,group,rng_stream,& avbmc_atom=avbmc_atom(molecule_type),& rmin=avbmc_rmin(molecule_type),rmax=avbmc_rmax(molecule_type),move_type='out',& target_atom=target_atom) @@ -2261,7 +2232,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& weight_old,start_atom_swap,nunits_tot(box_number),nunits,nunits(molecule_type),& mass(:,molecule_type),ldum, rdum,& bias_energy_old,ionode,.TRUE.,mol_type(start_mol:end_mol),nchains(:,box_number),& - source,group,rng_stream,error,& + source,group,rng_stream,& avbmc_atom=avbmc_atom(molecule_type),& rmin=avbmc_rmin(molecule_type),rmax=avbmc_rmax(molecule_type),move_type='in',& target_atom=target_atom) @@ -2274,7 +2245,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& weight_new,start_atom_swap,nunits_tot(box_number),nunits,nunits(molecule_type),& mass(:,molecule_type),loverlap, bias_energy_new,& bias_energy_old,ionode,.FALSE.,mol_type(start_mol:end_mol),nchains(:,box_number),& - source,group,rng_stream,error,& + source,group,rng_stream,& avbmc_atom=avbmc_atom(molecule_type),& rmin=avbmc_rmin(molecule_type),rmax=avbmc_rmax(molecule_type),move_type=move_type,& target_atom=target_atom) @@ -2294,7 +2265,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& exp_min_val,nswapmoves,& weight_old,start_atom_swap,nunits_tot(box_number),nunits,nunits(molecule_type),& mass(:,molecule_type),ldum,rdum,old_energy,& - ionode,.TRUE.,mol_type(start_mol:end_mol),nchains(:,box_number),source,group,rng_stream,error,& + ionode,.TRUE.,mol_type(start_mol:end_mol),nchains(:,box_number),source,group,rng_stream,& avbmc_atom=avbmc_atom(molecule_type),& rmin=avbmc_rmin(molecule_type),rmax=avbmc_rmax(molecule_type),move_type='out',& target_atom=target_atom) @@ -2306,7 +2277,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& exp_min_val,nswapmoves,& weight_old,start_atom_swap,nunits_tot(box_number),nunits,nunits(molecule_type),& mass(:,molecule_type),ldum,rdum,old_energy,& - ionode,.TRUE.,mol_type(start_mol:end_mol),nchains(:,box_number),source,group,rng_stream,error,& + ionode,.TRUE.,mol_type(start_mol:end_mol),nchains(:,box_number),source,group,rng_stream,& avbmc_atom=avbmc_atom(molecule_type),& rmin=avbmc_rmin(molecule_type),rmax=avbmc_rmax(molecule_type),move_type='in',& target_atom=target_atom) @@ -2318,7 +2289,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& exp_min_val,nswapmoves,& weight_new,start_atom_swap,nunits_tot(box_number),nunits,nunits(molecule_type),& mass(:,molecule_type),loverlap,new_energy,old_energy,& - ionode,.FALSE.,mol_type(start_mol:end_mol),nchains(:,box_number),source,group,rng_stream,error,& + ionode,.FALSE.,mol_type(start_mol:end_mol),nchains(:,box_number),source,group,rng_stream,& avbmc_atom=avbmc_atom(molecule_type),& rmin=avbmc_rmin(molecule_type),rmax=avbmc_rmax(molecule_type),move_type=move_type,& target_atom=target_atom) @@ -2332,11 +2303,11 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& ! need to reset the old coordinates IF(lbias) THEN - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles,error=error) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ELSE - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles,error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ENDIF DO ipart=1,nunits_tot(box_number) particles%els(ipart)%r(1:3)=r_old(1:3,ipart) @@ -2351,18 +2322,18 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& ! potential IF(lbias) THEN ! need to give the force_env the coords from the bias_env - CALL force_env_get(force_env,subsys=subsys_force,error=error) - CALL cp_subsys_get(subsys_force,particles=particles_force,error=error) - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles,error=error) + CALL force_env_get(force_env,subsys=subsys_force) + CALL cp_subsys_get(subsys_force,particles=particles_force) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO ipart=1,nunits_tot(box_number) particles_force%els(ipart)%r(1:3)=particles%els(ipart)%r(1:3) ENDDO CALL force_env_calc_energy_force(force_env,& - calc_force=.FALSE.,error=error) + calc_force=.FALSE.) CALL force_env_get(force_env,& - potential_energy=new_energy,error=error) + potential_energy=new_energy) ENDIF @@ -2406,7 +2377,7 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& IF(w .GE. 1.0E0_dp) THEN rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF @@ -2450,27 +2421,27 @@ SUBROUTINE mc_avbmc_move ( mc_par,force_env,bias_env, moves,& ENDIF ! update coordinates - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles,error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO ipart=1,nunits_tot(box_number) r_old(1:3,ipart)=particles%els(ipart)%r(1:3) ENDDO ELSE ! reject the move...need to restore the old coordinates IF(lbias) THEN - CALL force_env_get(bias_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(bias_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO ipart=1,nunits_tot(box_number) particles%els(ipart)%r(1:3)=r_old(1:3,ipart) ENDDO - CALL cp_subsys_set(subsys,particles=particles,error=error) + CALL cp_subsys_set(subsys,particles=particles) ENDIF - CALL force_env_get(force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys,particles=particles, error=error) + CALL force_env_get(force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) DO ipart=1,nunits_tot(box_number) particles%els(ipart)%r(1:3)=r_old(1:3,ipart) ENDDO - CALL cp_subsys_set(subsys,particles=particles,error=error) + CALL cp_subsys_set(subsys,particles=particles) ENDIF @@ -2501,14 +2472,12 @@ END SUBROUTINE mc_avbmc_move !> \param r_old the coordinates of the last accepted move involving an !> unbiased calculation !> \param rng_stream the random number stream that we draw from -!> \param error the cp error type -!> !> \author MJM !> \note Designed for parallel use. ! ***************************************************************************** SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,move_updates,& old_energy,box_number,& - energy_check,r_old,rng_stream,error) + energy_check,r_old,rng_stream) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(force_env_type), POINTER :: force_env @@ -2520,7 +2489,6 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,move_updates,& REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: r_old TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mc_hmc_move', & routineP = moduleN//':'//routineN @@ -2566,10 +2534,8 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,move_updates,& move_updates%hmc%attempts=move_updates%hmc%attempts+1 ! now let's grab the particle positions - CALL force_env_get(force_env,subsys=oldsys,& - error=error) - CALL cp_subsys_get(oldsys,particles=particles_old, & - error=error) + CALL force_env_get(force_env,subsys=oldsys) + CALL cp_subsys_get(oldsys,particles=particles_old) ! save the old coordinates DO iatom=1,nunits_tot(box_number) @@ -2577,12 +2543,12 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,move_updates,& ENDDO ! now run the MD simulation - CALL qs_mol_dyn(force_env,globenv,error=error,hmc_e_initial=hmc_ekin%initial_ekin,hmc_e_final=hmc_ekin%final_ekin) + CALL qs_mol_dyn(force_env,globenv,hmc_e_initial=hmc_ekin%initial_ekin,hmc_e_final=hmc_ekin%final_ekin) ! get the energy CALL force_env_get(force_env,& - potential_energy=new_energy,error=error) + potential_energy=new_energy) ! accept or reject the move ! to prevent overflows @@ -2601,7 +2567,7 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,move_updates,& w=1.0E0_dp rand=0.0E0_dp ELSE - IF(ionode) rand=next_random_number(rng_stream,error=error) + IF(ionode) rand=next_random_number(rng_stream) CALL mp_bcast(rand,source,group) ENDIF diff --git a/src/motion/mc/mc_run.F b/src/motion/mc/mc_run.F index 845ca61b67..a6ec902cf6 100644 --- a/src/motion/mc/mc_run.F +++ b/src/motion/mc/mc_run.F @@ -98,18 +98,16 @@ MODULE mc_run !> \param input_declaration ... !> \param input_file_name the name of the input file that force_env_1 was !> created from -!> \param error the error type !> \author MJM !> \note !> Designed for parallel. ! ***************************************************************************** - SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name, error ) + SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name) TYPE(force_env_type), POINTER :: force_env_1 TYPE(global_environment_type), POINTER :: globenv TYPE(section_type), POINTER :: input_declaration CHARACTER(LEN=*) :: input_file_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_mon_car', & routineP = moduleN//':'//routineN @@ -142,29 +140,29 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name NULLIFY(mc_env,mc_par,force_env_2,rng_stream,force_env_section,& root_section,mc_molecule_info) - CALL force_env_retain(force_env_1, error) + CALL force_env_retain(force_env_1) para_env=>force_env_1%para_env - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() iw = cp_logger_get_default_io_unit(logger) force_env_section => force_env_1%force_env_section root_section => force_env_1%root_section - CALL section_vals_get(force_env_section,n_repetition=isos,error=error) - CPPostconditionNoFail(isos==1,cp_warning_level,routineP,error) + CALL section_vals_get(force_env_section,n_repetition=isos) + CPPostconditionNoFail(isos==1,cp_warning_level,routineP) ! set some values...will use get_globenv if that ever comes around ! initialize the random numbers CALL create_rng_stream(rng_stream=rng_stream,& name="first",& - distribution_type=UNIFORM,error=error) + distribution_type=UNIFORM) ! need to figure out how many boxes we have, based on the value ! of mc_par % ensemble NULLIFY(mc_section) mc_section => section_vals_get_subs_vals(root_section,& - "MOTION%MC",error=error) + "MOTION%MC") CALL section_vals_val_get(mc_section,"ENSEMBLE",& - c_val=ensemble,error=error) + c_val=ensemble) ! now we read in the second force_env, if we have another box SELECT CASE(ensemble) @@ -173,9 +171,9 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name CASE("GEMC_NVT","GEMC_NPT") nboxes=2 CALL section_vals_val_get(mc_section,"BOX2_FILE_NAME",& - c_val=box2_file,error=error) + c_val=box2_file) CALL mc_create_force_env(force_env_2,input_declaration,para_env,& - box2_file,globenv_new=globenv_2,error=error) + box2_file,globenv_new=globenv_2) END SELECT ! now we create the various pointers that contain information for all boxes @@ -198,7 +196,7 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name ! now we need the molecule information ! determine the total number of molecules and atoms - CALL mc_determine_molecule_info(force_env,mc_molecule_info,error,& + CALL mc_determine_molecule_info(force_env,mc_molecule_info,& coordinates_empty=empty_coordinates) CALL get_mc_molecule_info(mc_molecule_info,nmol_types=nmol_types,& nunits_tot=nunits_tot) @@ -213,8 +211,7 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name ENDIF ! allocates an mc_env and sets the variables to zero - CALL mc_env_create ( mc_env(ibox)%mc_env, & - error = error ) + CALL mc_env_create ( mc_env(ibox)%mc_env) ! now read in the values of the mc_pars ! creating the mc_par @@ -228,10 +225,10 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name root_section => force_env(ibox)%force_env%root_section IF(ibox == 1) THEN CALL read_mc_section ( mc_par(ibox)%mc_par, para_env, globenv ,input_file_name,& - root_section,force_env_section,error) + root_section,force_env_section) ELSE CALL read_mc_section ( mc_par(ibox)%mc_par, para_env, globenv ,box2_file,& - root_section,force_env_section,error) + root_section,force_env_section) ENDIF ! get the input file data, in case we need to make a restart... @@ -242,17 +239,17 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name CALL get_mc_par(mc_par(1)%mc_par,lbias=lbias) IF(ibox == 1) THEN CALL mc_input_file_create ( mc_input_file,& - input_file_name,mc_molecule_info,empty_coordinates,lhmc,error) + input_file_name,mc_molecule_info,empty_coordinates,lhmc) ELSE CALL mc_input_file_create ( mc_input_file,& - box2_file,mc_molecule_info,empty_coordinates,lhmc,error) + box2_file,mc_molecule_info,empty_coordinates,lhmc) ENDIF CALL set_mc_par(mc_par(ibox)%mc_par,mc_input_file=mc_input_file) IF(lbias) THEN CALL get_mc_par(mc_par(ibox)%mc_par,mc_bias_file=mc_bias_file) CALL mc_input_file_create ( mc_bias_file,& - "bias_template.inp",mc_molecule_info,empty_coordinates,lhmc,error) + "bias_template.inp",mc_molecule_info,empty_coordinates,lhmc) CALL set_mc_par(mc_par(ibox)%mc_par,mc_bias_file=mc_bias_file) ENDIF @@ -263,9 +260,9 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name CALL read_mc_restart(mc_par(ibox)%mc_par,force_env(ibox)%force_env,& iw,nunits_tot(ibox),rng_stream) ! release the old force env and make the new one - CALL force_env_release(force_env(ibox)%force_env,error=error) + CALL force_env_release(force_env(ibox)%force_env) CALL mc_create_force_env(force_env(ibox)%force_env, & - input_declaration,para_env, dat_file,error=error) + input_declaration,para_env, dat_file) ENDIF ENDDO @@ -286,7 +283,7 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name ! in case there was a restart, we need to do this again CALL mc_molecule_info_destroy(mc_molecule_info) - CALL mc_determine_molecule_info(force_env,mc_molecule_info,error,box_number=box_number) + CALL mc_determine_molecule_info(force_env,mc_molecule_info,box_number=box_number) CALL get_mc_molecule_info(mc_molecule_info,nmol_types=nmol_types,& nunits_tot=nunits_tot) DO ibox=1,nboxes @@ -325,9 +322,9 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name ! of running a simulation SELECT CASE(ensemble) CASE("VIRIAL") - CALL mc_compute_virial(mc_env,rng_stream,error) + CALL mc_compute_virial(mc_env,rng_stream) CASE DEFAULT - CALL mc_run_ensemble(mc_env,para_env,globenv,input_declaration,nboxes,rng_stream,error) + CALL mc_run_ensemble(mc_env,para_env,globenv,input_declaration,nboxes,rng_stream) END SELECT ! get rid of all the MC molecule information @@ -347,22 +344,22 @@ SUBROUTINE do_mon_car ( force_env_1, globenv, input_declaration, input_file_name ENDIF CALL mc_sim_par_destroy(mc_par(ibox)%mc_par) - CALL mc_env_release ( mc_env(ibox)%mc_env, error ) - CALL force_env_release(force_env(ibox)%force_env,error=error) + CALL mc_env_release ( mc_env(ibox)%mc_env) + CALL force_env_release(force_env(ibox)%force_env) ENDDO DEALLOCATE ( empty_coordinates, STAT = isos ) - CPPostconditionNoFail(isos==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(isos==0,cp_warning_level,routineP) DEALLOCATE ( mc_par, STAT = isos ) - CPPostconditionNoFail(isos==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(isos==0,cp_warning_level,routineP) DEALLOCATE ( mc_env, STAT = isos ) - CPPostconditionNoFail(isos==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(isos==0,cp_warning_level,routineP) DEALLOCATE ( force_env, STAT = isos ) - CPPostconditionNoFail(isos==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(isos==0,cp_warning_level,routineP) ! delete the random numbers - CALL delete_rng_stream(rng_stream,error=error) + CALL delete_rng_stream(rng_stream) END SUBROUTINE do_mon_car diff --git a/src/motion/mc/mc_types.F b/src/motion/mc/mc_types.F index fb8ad8cfaf..72f7c48c11 100644 --- a/src/motion/mc/mc_types.F +++ b/src/motion/mc/mc_types.F @@ -1013,18 +1013,16 @@ END SUBROUTINE mc_sim_par_destroy !> \param mc_molecule_info ... !> \param empty_coords ... !> \param lhmc ... -!> \param error ... !> \author MJM ! ***************************************************************************** SUBROUTINE mc_input_file_create (mc_input_file,input_file_name,& - mc_molecule_info,empty_coords,lhmc,error) + mc_molecule_info,empty_coords,lhmc) TYPE(mc_input_file_type), POINTER :: mc_input_file CHARACTER(LEN=*), INTENT(IN) :: input_file_name TYPE(mc_molecule_info_type), POINTER :: mc_molecule_info REAL(dp), DIMENSION(:, :) :: empty_coords LOGICAL, INTENT(IN) :: lhmc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mc_input_file_create', & routineP = moduleN//':'//routineN @@ -1040,7 +1038,7 @@ SUBROUTINE mc_input_file_create (mc_input_file,input_file_name,& ! some stuff in case we need to write error messages to the screen - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() iw = cp_logger_get_default_io_unit(logger) ! allocate the array we'll need in case we have an empty box @@ -1322,18 +1320,15 @@ END SUBROUTINE mc_parse_text !> \param input_file_name the name of the input_file !> \param input_file the structure that contains all the keywords in the input file !> \param force_env_section used to grab the type of force_env -!> \param error the cp_error_type !> \author MJM ! ***************************************************************************** -SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_file, force_env_section,& - error ) +SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_file, force_env_section) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv CHARACTER(LEN=*), INTENT(IN) :: input_file_name TYPE(section_vals_type), POINTER :: input_file, force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_mc_section', & routineP = moduleN//':'//routineN @@ -1355,13 +1350,13 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ! begin the timing of the subroutine - CPPrecondition(ASSOCIATED(input_file),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(input_file),cp_failure_level,routineP,failure) CALL timeset(routineN,handle) NULLIFY(mc_section) mc_section => section_vals_get_subs_vals(input_file,& - "MOTION%MC",error=error) + "MOTION%MC") ! need the input file sturcutre that we're reading from for when we make ! dat files @@ -1377,7 +1372,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f !..defaults...most are set in input_cp2k_motion mc_par % nstart = 0 - CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id,error=error) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id) SELECT CASE (method_name_id) CASE (do_fist) mc_par % iprint = 100 @@ -1385,7 +1380,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par % iprint = 1 END SELECT - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() iw = cp_logger_get_default_io_unit(logger) IF(iw>0) WRITE ( iw, * ) @@ -1405,19 +1400,19 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ! set them into the input parameter structure as the new defaults CALL section_vals_val_set(mc_section,"COORDINATE_FILE_NAME",& - c_val=mc_par%coords_file,error=error) + c_val=mc_par%coords_file) CALL section_vals_val_set(mc_section,"DATA_FILE_NAME",& - c_val=mc_par%data_file,error=error) + c_val=mc_par%data_file) CALL section_vals_val_set(mc_section,"CELL_FILE_NAME",& - c_val=mc_par%cell_file,error=error) + c_val=mc_par%cell_file) CALL section_vals_val_set(mc_section,"MAX_DISP_FILE_NAME",& - c_val=mc_par%displacement_file,error=error) + c_val=mc_par%displacement_file) CALL section_vals_val_set(mc_section,"MOVES_FILE_NAME",& - c_val=mc_par%moves_file,error=error) + c_val=mc_par%moves_file) CALL section_vals_val_set(mc_section,"MOLECULES_FILE_NAME",& - c_val=mc_par%molecules_file,error=error) + c_val=mc_par%molecules_file) CALL section_vals_val_set(mc_section,"ENERGY_FILE_NAME",& - c_val=mc_par%energy_file,error=error) + c_val=mc_par%energy_file) ! grab the FFT library name and print level...this is used for writing the dat file ! and hopefully will be changed @@ -1428,26 +1423,26 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ! find out if we're only doing HMC moves...we can ignore a lot of extra information ! then, which would ordinarily be cause for concern - CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMHMC",r_val=mc_par%pmhmc,error=error) - CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMSWAP",r_val=mc_par%pmswap,error=error) - CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMVOLUME",r_val=mc_par%pmvolume,error=error) - CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMAVBMC",r_val=mc_par%pmavbmc,error=error) - CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMTRANS",r_val=mc_par%pmtrans,error=error) - CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMTRAION",r_val=mc_par%pmtraion,error=error) + CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMHMC",r_val=mc_par%pmhmc) + CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMSWAP",r_val=mc_par%pmswap) + CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMVOLUME",r_val=mc_par%pmvolume) + CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMAVBMC",r_val=mc_par%pmavbmc) + CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMTRANS",r_val=mc_par%pmtrans) + CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%PMTRAION",r_val=mc_par%pmtraion) ! first, grab all the integer values - CALL section_vals_val_get(mc_section,"NSTEP",i_val=mc_par%nstep,error=error) - CALL section_vals_val_get(mc_section,"NMOVES",i_val=mc_par%nmoves,error=error) - CALL section_vals_val_get(mc_section,"NSWAPMOVES",i_val=mc_par%nswapmoves,error=error) + CALL section_vals_val_get(mc_section,"NSTEP",i_val=mc_par%nstep) + CALL section_vals_val_get(mc_section,"NMOVES",i_val=mc_par%nmoves) + CALL section_vals_val_get(mc_section,"NSWAPMOVES",i_val=mc_par%nswapmoves) CALL section_vals_val_get(mc_section,"MOVE_UPDATES%IUPVOLUME",& - i_val=mc_par%iupvolume,error=error) - CALL section_vals_val_get(mc_section,"NVIRIAL",i_val=mc_par%nvirial,error=error) + i_val=mc_par%iupvolume) + CALL section_vals_val_get(mc_section,"NVIRIAL",i_val=mc_par%nvirial) CALL section_vals_val_get(mc_section,"MOVE_UPDATES%IUPTRANS",& - i_val=mc_par%iuptrans,error=error) - CALL section_vals_val_get(mc_section,"IPRINT",i_val=mc_par%iprint,error=error) + i_val=mc_par%iuptrans) + CALL section_vals_val_get(mc_section,"IPRINT",i_val=mc_par%iprint) ! now an integer array - CALL section_vals_val_get(mc_section,"AVBMC%AVBMC_ATOM",i_vals=temp_i_array,error=error) + CALL section_vals_val_get(mc_section,"AVBMC%AVBMC_ATOM",i_vals=temp_i_array) IF(mc_par%pmhmc - mc_par%pmswap >= 1.0_dp .AND. mc_par%pmhmc == 1.0_dp)THEN @@ -1467,32 +1462,32 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ENDDO ! now the real values - CALL section_vals_val_get(mc_section,"PRESSURE",r_val=mc_par%pressure,error=error) - CALL section_vals_val_get(mc_section,"TEMPERATURE",r_val=mc_par%temperature,error=error) + CALL section_vals_val_get(mc_section,"PRESSURE",r_val=mc_par%pressure) + CALL section_vals_val_get(mc_section,"TEMPERATURE",r_val=mc_par%temperature) CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%BOX_PROBABILITIES%PMHMC_BOX",& - r_val=mc_par%pmhmc_box,error=error) + r_val=mc_par%pmhmc_box) CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%BOX_PROBABILITIES%PMVOL_BOX",& - r_val=mc_par%pmvol_box,error=error) - CALL section_vals_val_get(mc_section,"DISCRETE_STEP",r_val=mc_par%discrete_step,error=error) + r_val=mc_par%pmvol_box) + CALL section_vals_val_get(mc_section,"DISCRETE_STEP",r_val=mc_par%discrete_step) CALL section_vals_val_get(mc_section,"MAX_DISPLACEMENTS%BOX_DISPLACEMENTS%RMVOLUME",& - r_val=mc_par%rmvolume,error=error) + r_val=mc_par%rmvolume) ! finally the character values - CALL section_vals_val_get(mc_section,"ENSEMBLE",c_val=mc_par%ensemble,error=error) - CALL section_vals_val_get(mc_section,"RESTART_FILE_NAME",c_val=mc_par%restart_file_name,error=error) - CALL section_vals_val_get(mc_section,"COORDINATE_FILE_NAME",c_val=mc_par%coords_file,error=error) - CALL section_vals_val_get(mc_section,"ENERGY_FILE_NAME",c_val=mc_par%energy_file,error=error) - CALL section_vals_val_get(mc_section,"MOVES_FILE_NAME",c_val=mc_par%moves_file,error=error) - CALL section_vals_val_get(mc_section,"MOLECULES_FILE_NAME",c_val=mc_par%molecules_file,error=error) - CALL section_vals_val_get(mc_section,"CELL_FILE_NAME",c_val=mc_par%cell_file,error=error) - CALL section_vals_val_get(mc_section,"DATA_FILE_NAME",c_val=mc_par%data_file,error=error) - CALL section_vals_val_get(mc_section,"MAX_DISP_FILE_NAME",c_val=mc_par%displacement_file,error=error) - CALL section_vals_val_get(mc_section,"BOX2_FILE_NAME",c_val=mc_par%box2_file,error=error) + CALL section_vals_val_get(mc_section,"ENSEMBLE",c_val=mc_par%ensemble) + CALL section_vals_val_get(mc_section,"RESTART_FILE_NAME",c_val=mc_par%restart_file_name) + CALL section_vals_val_get(mc_section,"COORDINATE_FILE_NAME",c_val=mc_par%coords_file) + CALL section_vals_val_get(mc_section,"ENERGY_FILE_NAME",c_val=mc_par%energy_file) + CALL section_vals_val_get(mc_section,"MOVES_FILE_NAME",c_val=mc_par%moves_file) + CALL section_vals_val_get(mc_section,"MOLECULES_FILE_NAME",c_val=mc_par%molecules_file) + CALL section_vals_val_get(mc_section,"CELL_FILE_NAME",c_val=mc_par%cell_file) + CALL section_vals_val_get(mc_section,"DATA_FILE_NAME",c_val=mc_par%data_file) + CALL section_vals_val_get(mc_section,"MAX_DISP_FILE_NAME",c_val=mc_par%displacement_file) + CALL section_vals_val_get(mc_section,"BOX2_FILE_NAME",c_val=mc_par%box2_file) ! set the values of the arrays...if we just point, we have problems when we start fooling around ! with releasing force_envs and wonky values get set (despite that these are private) IF(mc_par%ensemble == "VIRIAL") THEN - CALL section_vals_val_get(mc_section,"VIRIAL_TEMPS",r_vals=temp_r_array,error=error) + CALL section_vals_val_get(mc_section,"VIRIAL_TEMPS",r_vals=temp_r_array) ! yes, I'm allocating here...I cannot find a better place to do it, though ALLOCATE (mc_par%virial_temps(1:SIZE(temp_r_array)),STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -1502,7 +1497,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ENDDO END IF ! all of these arrays should have one value for each type of molecule...so check that - CALL section_vals_val_get(mc_section,"AVBMC%AVBMC_RMIN",r_vals=temp_r_array,error=error) + CALL section_vals_val_get(mc_section,"AVBMC%AVBMC_RMIN",r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1512,7 +1507,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f DO imol=1,SIZE(temp_r_array) mc_par%avbmc_rmin(imol)=temp_r_array(imol) ENDDO - CALL section_vals_val_get(mc_section,"AVBMC%AVBMC_RMAX",r_vals=temp_r_array,error=error) + CALL section_vals_val_get(mc_section,"AVBMC%AVBMC_RMAX",r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1522,7 +1517,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f DO imol=1,SIZE(temp_r_array) mc_par%avbmc_rmax(imol)=temp_r_array(imol) ENDDO - CALL section_vals_val_get(mc_section,"AVBMC%PBIAS",r_vals=temp_r_array,error=error) + CALL section_vals_val_get(mc_section,"AVBMC%PBIAS",r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1533,7 +1528,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par%pbias(imol)=temp_r_array(imol) ENDDO CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%MOL_PROBABILITIES%PMAVBMC_MOL",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1543,7 +1538,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f DO imol=1,SIZE(temp_r_array) mc_par%pmavbmc_mol(imol)=temp_r_array(imol) ENDDO - CALL section_vals_val_get(mc_section,"ETA",r_vals=temp_r_array,error=error) + CALL section_vals_val_get(mc_section,"ETA",r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1554,7 +1549,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par%eta(imol)=temp_r_array(imol) ENDDO CALL section_vals_val_get(mc_section,"MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMBOND",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1565,7 +1560,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par%rmbond(imol)=temp_r_array(imol) ENDDO CALL section_vals_val_get(mc_section,"MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMANGLE",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1576,7 +1571,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par%rmangle(imol)=temp_r_array(imol) ENDDO CALL section_vals_val_get(mc_section,"MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMDIHEDRAL",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1587,7 +1582,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par%rmdihedral(imol)=temp_r_array(imol) ENDDO CALL section_vals_val_get(mc_section,"MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMROT",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1598,7 +1593,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par%rmrot(imol)=temp_r_array(imol) ENDDO CALL section_vals_val_get(mc_section,"MAX_DISPLACEMENTS%MOL_DISPLACEMENTS%RMTRANS",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1610,7 +1605,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ENDDO CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%MOL_PROBABILITIES%PMTRAION_MOL",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1622,7 +1617,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ENDDO CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%MOL_PROBABILITIES%PMTRANS_MOL",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1634,7 +1629,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ENDDO CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%MOL_PROBABILITIES%PMROT_MOL",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1646,7 +1641,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ENDDO CALL section_vals_val_get(mc_section,"MOVE_PROBABILITIES%MOL_PROBABILITIES%PMSWAP_MOL",& - r_vals=temp_r_array,error=error) + r_vals=temp_r_array) IF( .NOT. mc_par%lhmc)THEN IF(SIZE(temp_r_array) .NE. nmol_types)THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -1658,11 +1653,11 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f ENDDO ! now some logical values - CALL section_vals_val_get(mc_section,"LBIAS",l_val=mc_par%lbias,error=error) - CALL section_vals_val_get(mc_section,"LDISCRETE",l_val=mc_par%ldiscrete,error=error) - CALL section_vals_val_get(mc_section,"LSTOP",l_val=mc_par%lstop,error=error) - CALL section_vals_val_get(mc_section,"RESTART",l_val=mc_par%lrestart,error=error) - CALL section_vals_val_get(mc_section,"LBIAS",l_val=mc_par%lbias,error=error) + CALL section_vals_val_get(mc_section,"LBIAS",l_val=mc_par%lbias) + CALL section_vals_val_get(mc_section,"LDISCRETE",l_val=mc_par%ldiscrete) + CALL section_vals_val_get(mc_section,"LSTOP",l_val=mc_par%lstop) + CALL section_vals_val_get(mc_section,"RESTART",l_val=mc_par%lrestart) + CALL section_vals_val_get(mc_section,"LBIAS",l_val=mc_par%lbias) !..end of parsing the input section @@ -1816,7 +1811,7 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par % min_val = 0.0_dp ! convert from bar to a.u. - mc_par%pressure = cp_unit_to_cp2k(mc_par%pressure,"bar",error=error) + mc_par%pressure = cp_unit_to_cp2k(mc_par%pressure,"bar") ! convert from angstrom to a.u. DO itype=1,mc_par%mc_molecule_info%nmol_types ! convert from Kelvin to a.u. @@ -1825,14 +1820,14 @@ SUBROUTINE read_mc_section ( mc_par, para_env, globenv, input_file_name, input_f mc_par%rmrot(itype) = mc_par%rmrot(itype)/180.0e0_dp*pi mc_par%rmangle(itype) = mc_par%rmangle(itype)/180.0e0_dp*pi mc_par%rmdihedral(itype) = mc_par%rmdihedral(itype)/180.0e0_dp*pi - mc_par%rmtrans(itype) = cp_unit_to_cp2k(mc_par%rmtrans(itype),"angstrom",error=error) - mc_par%rmbond(itype) = cp_unit_to_cp2k(mc_par%rmbond(itype),"angstrom",error=error) - mc_par%eta(itype) = cp_unit_to_cp2k(mc_par%eta(itype),"K_e",error=error) - mc_par%avbmc_rmin(itype) = cp_unit_to_cp2k(mc_par%avbmc_rmin(itype),"angstrom",error=error) - mc_par%avbmc_rmax(itype) = cp_unit_to_cp2k(mc_par%avbmc_rmax(itype),"angstrom",error=error) + mc_par%rmtrans(itype) = cp_unit_to_cp2k(mc_par%rmtrans(itype),"angstrom") + mc_par%rmbond(itype) = cp_unit_to_cp2k(mc_par%rmbond(itype),"angstrom") + mc_par%eta(itype) = cp_unit_to_cp2k(mc_par%eta(itype),"K_e") + mc_par%avbmc_rmin(itype) = cp_unit_to_cp2k(mc_par%avbmc_rmin(itype),"angstrom") + mc_par%avbmc_rmax(itype) = cp_unit_to_cp2k(mc_par%avbmc_rmax(itype),"angstrom") ENDDO - mc_par%rmvolume = cp_unit_to_cp2k(mc_par%rmvolume,"angstrom^3",error=error) - mc_par%discrete_step = cp_unit_to_cp2k(mc_par%discrete_step,"angstrom",error=error) + mc_par%rmvolume = cp_unit_to_cp2k(mc_par%rmvolume,"angstrom^3") + mc_par%discrete_step = cp_unit_to_cp2k(mc_par%discrete_step,"angstrom") ! end the timing CALL timestop(handle) @@ -1864,7 +1859,6 @@ SUBROUTINE find_mc_rcut ( mc_par, force_env, lterminate ) REAL(KIND=dp) :: rcutsq_max REAL(KIND=dp), DIMENSION(1:3) :: abc TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: error TYPE(fist_environment_type), POINTER :: fist_env TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env TYPE(pair_potential_pp_type), POINTER :: potparm @@ -1872,10 +1866,10 @@ SUBROUTINE find_mc_rcut ( mc_par, force_env, lterminate ) NULLIFY(cell,potparm,fist_nonbond_env,fist_env) lterminate=.FALSE. - CALL force_env_get(force_env,fist_env=fist_env,error=error) + CALL force_env_get(force_env,fist_env=fist_env) CALL fist_env_get(fist_env,cell=cell,& - fist_nonbond_env=fist_nonbond_env,error=error) - CALL fist_nonbond_env_get (fist_nonbond_env, potparm=potparm,error=error) + fist_nonbond_env=fist_nonbond_env) + CALL fist_nonbond_env_get (fist_nonbond_env, potparm=potparm) CALL get_cell(cell,abc=abc) ! find the largest value of rcutsq @@ -1909,18 +1903,16 @@ END SUBROUTINE find_mc_rcut !> for the molecule types !> !> Suitable for parallel. -!> \param error ... !> \param box_number ... !> \param coordinates_empty ... !> \author MJM ! ***************************************************************************** -SUBROUTINE mc_determine_molecule_info(force_env,mc_molecule_info,error,box_number,& +SUBROUTINE mc_determine_molecule_info(force_env,mc_molecule_info,box_number,& coordinates_empty) TYPE(force_env_p_type), DIMENSION(:), & POINTER :: force_env TYPE(mc_molecule_info_type), POINTER :: mc_molecule_info - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, INTENT(IN), OPTIONAL :: box_number REAL(dp), DIMENSION(:, :), OPTIONAL, & POINTER :: coordinates_empty @@ -1981,10 +1973,10 @@ SUBROUTINE mc_determine_molecule_info(force_env,mc_molecule_info,error,box_numbe DO ibox=1,nboxes IF(ibox == skip_box) CYCLE CALL force_env_get(force_env(ibox)%force_env,& - subsys=subsys,error=error) + subsys=subsys) CALL cp_subsys_get(subsys, & molecule_kinds_new=molecule_kinds_new(ibox)%list,& - particles=particles(ibox)%list,error=error) + particles=particles(ibox)%list) ntypes=ntypes+SIZE(molecule_kinds_new(ibox)%list%els(:)) ENDDO diff --git a/src/motion/mc/tamc_run.F b/src/motion/mc/tamc_run.F index 09ea82a25e..21e0f8552c 100644 --- a/src/motion/mc/tamc_run.F +++ b/src/motion/mc/tamc_run.F @@ -151,17 +151,15 @@ MODULE tamc_run !> \param force_env ... !> \param globenv ... !> \param averages ... -!> \param error ... !> \author Alin M Elena !> \note it computes the forces using QuickStep. ! ***************************************************************************** -SUBROUTINE qs_tamc(force_env, globenv,averages,error) +SUBROUTINE qs_tamc(force_env, globenv,averages) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv TYPE(average_quantities_type), & OPTIONAL, POINTER :: averages - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_tamc', & routineP = moduleN//':'//routineN @@ -215,17 +213,17 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) my_rm_restart_info = .TRUE. NULLIFY(md_env, para_env,fs_section, virial) para_env => force_env%para_env - motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION",error=error) - md_section => section_vals_get_subs_vals(motion_section,"MD",error=error) + motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION") + md_section => section_vals_get_subs_vals(motion_section,"MD") ! Real call to MD driver - Low Level - CALL md_env_create(md_env, md_section, para_env, force_env=force_env, error=error) - IF (PRESENT(averages)) CALL set_md_env(md_env, averages=averages, error=error) + CALL md_env_create(md_env, md_section, para_env, force_env=force_env) + IF (PRESENT(averages)) CALL set_md_env(md_env, averages=averages) - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) failure=.FALSE. NULLIFY (particles, cell, simpar, itimes, used_time, subsys, & @@ -233,57 +231,57 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) reftraj_section, work_section, atomic_kinds, & local_particles, time, fe_env, free_energy_section, & constraint_section, thermal_regions, subsys_i) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() para_env => force_env%para_env - global_section => section_vals_get_subs_vals(force_env%root_section,"GLOBAL",error=error) - free_energy_section =>section_vals_get_subs_vals(motion_section,"FREE_ENERGY",error=error) - constraint_section =>section_vals_get_subs_vals(motion_section,"CONSTRAINT",error=error) - CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem,error=error) + global_section => section_vals_get_subs_vals(force_env%root_section,"GLOBAL") + free_energy_section =>section_vals_get_subs_vals(motion_section,"FREE_ENERGY") + constraint_section =>section_vals_get_subs_vals(motion_section,"CONSTRAINT") + CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem) - CALL section_vals_val_get(global_section,"RUN_TYPE", i_val=run_type_id,error=error) + CALL section_vals_val_get(global_section,"RUN_TYPE", i_val=run_type_id) - CALL create_simpar_type(simpar, error) + CALL create_simpar_type(simpar) force_env_section => force_env%force_env_section - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) - CALL cp_add_iter_level(logger%iter_info,"MD",error=error) - CALL cp_iterate(logger%iter_info,iter_nr=initialStep,error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") + CALL cp_add_iter_level(logger%iter_info,"MD") + CALL cp_iterate(logger%iter_info,iter_nr=initialStep) ! Read MD section - CALL read_md_section(simpar, motion_section, md_section, error) + CALL read_md_section(simpar, motion_section, md_section) ! Setup print_keys simpar%info_constraint = cp_print_key_unit_nr(logger,constraint_section,& - "CONSTRAINT_INFO",extension=".shakeLog",log_filename=.FALSE.,error=error) + "CONSTRAINT_INFO",extension=".shakeLog",log_filename=.FALSE.) simpar%lagrange_multipliers = cp_print_key_unit_nr(logger,constraint_section,& - "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.,error=error) + "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.) simpar%dump_lm = BTEST(cp_print_key_should_output(logger%iter_info,constraint_section,& - "LAGRANGE_MULTIPLIERS",error=error),cp_p_file) + "LAGRANGE_MULTIPLIERS"),cp_p_file) ! Create the structure for the md energies - CALL create_md_ener(md_ener, error=error) - CALL set_md_env(md_env, md_ener=md_ener, error=error) - CALL release_md_ener(md_ener, error=error) + CALL create_md_ener(md_ener) + CALL set_md_env(md_env, md_ener=md_ener) + CALL release_md_ener(md_ener) ! If requested setup Thermostats CALL create_thermostats(thermostats, md_section, force_env, simpar, para_env,& - globenv, global_section, error ) + globenv, global_section) ! If requested setup Barostat - CALL create_barostat_type(barostat, md_section, force_env, simpar, globenv, error ) + CALL create_barostat_type(barostat, md_section, force_env, simpar, globenv) ! If requested setup different thermal regions - CALL create_thermal_regions(thermal_regions, md_section, simpar, force_env, error ) + CALL create_thermal_regions(thermal_regions, md_section, simpar, force_env) - CALL set_md_env(md_env, thermostats=thermostats, barostat=barostat, thermal_regions=thermal_regions,error=error) + CALL set_md_env(md_env, thermostats=thermostats, barostat=barostat, thermal_regions=thermal_regions) IF(simpar%ensemble == reftraj_ensemble) THEN - reftraj_section => section_vals_get_subs_vals(md_section,"REFTRAJ",error=error) - CALL create_reftraj(reftraj, reftraj_section, para_env, error=error) - CALL set_md_env(md_env, reftraj=reftraj, error=error) - CALL release_reftraj(reftraj,error=error) + reftraj_section => section_vals_get_subs_vals(md_section,"REFTRAJ") + CALL create_reftraj(reftraj, reftraj_section, para_env) + CALL set_md_env(md_env, reftraj=reftraj) + CALL release_reftraj(reftraj) END IF CALL force_env_get(force_env, subsys=subsys, cell=cell, & - force_env_section=force_env_section, error=error ) + force_env_section=force_env_section) @@ -296,29 +294,29 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) ! Initialize velocities possibly applying constraints at the zeroth MD step ! ! ! CALL section_vals_val_get(motion_section,"PRINT%RESTART%SPLIT_RESTART_FILE",& -! ! ! l_val=write_binary_restart_file,error=error) +! ! ! l_val=write_binary_restart_file) !! let us see if this created all the trouble ! CALL setup_velocities(force_env,simpar,globenv,md_env,md_section,constraint_section, & -! write_binary_restart_file,error) +! write_binary_restart_file) ! Setup Free Energy Calculation (if required) - CALL fe_env_create (fe_env, free_energy_section, error) + CALL fe_env_create (fe_env, free_energy_section) CALL set_md_env(md_env=md_env, simpar=simpar, fe_env=fe_env, cell=cell,& - force_env=force_env, error=error) + force_env=force_env) ! Possibly initialize Wiener processes - IF (simpar%ensemble == langevin_ensemble) CALL create_wiener_process(md_env,error) + IF (simpar%ensemble == langevin_ensemble) CALL create_wiener_process(md_env) time_iter_start=m_walltime() CALL get_md_env(md_env, force_env=force_env, itimes=itimes, constant=constant,& - md_ener=md_ener, t=time, used_time=used_time, error=error) + md_ener=md_ener, t=time, used_time=used_time) ! Attach the time counter of the meta_env to the one of the MD - CALL set_meta_env(force_env%meta_env, time=time, error=error) + CALL set_meta_env(force_env%meta_env, time=time) ! Initialize the md_ener structure force_env%meta_env%dt=force_env%meta_env%zdt - CALL initialize_md_ener(md_ener, force_env, simpar, error=error) + CALL initialize_md_ener(md_ener, force_env, simpar) ! force_env%meta_env%dt=force_env%meta_env%zdt @@ -327,35 +325,35 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) NULLIFY(mc_env,mc_par,rng_stream_mc,MCaverages) - CALL section_vals_get(force_env_section,n_repetition=isos,error=error) - CPPostconditionNoFail(isos==1,cp_warning_level,routineP,error) + CALL section_vals_get(force_env_section,n_repetition=isos) + CPPostconditionNoFail(isos==1,cp_warning_level,routineP) ! set some values...will use get_globenv if that ever comes around ! initialize the random numbers ! IF (para_env%ionode) THEN CALL create_rng_stream(rng_stream=rng_stream_mc,& name="Random numbers for monte carlo acc/rej",& - distribution_type=UNIFORM,error=error) + distribution_type=UNIFORM) ! ENDIF !!!!! this shoudl go in a routine hmc_read NULLIFY(mc_section) ALLOCATE(mc_par, stat=isos) ! do not forget to clean this mess - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) mc_section => section_vals_get_subs_vals(force_env%root_section,& - "MOTION%MC",error=error) + "MOTION%MC") CALL section_vals_val_get(mc_section,"ENSEMBLE",& - c_val=ensemble,error=error) - CPPostcondition(str_comp(ensemble,"TRADITIONAL"),cp_failure_level,routineP,error,failure) + c_val=ensemble) + CPPostcondition(str_comp(ensemble,"TRADITIONAL"),cp_failure_level,routineP,failure) CALL section_vals_val_get(mc_section,"NSTEP",& - i_val=nmccycles,error=error) - CPPostcondition(nmccycles>0,cp_failure_level,routineP,error,failure) + i_val=nmccycles) + CPPostcondition(nmccycles>0,cp_failure_level,routineP,failure) CALL section_vals_val_get(mc_section,"IPRINT",& - i_val=iprint,error=error) - CALL section_vals_val_get(mc_section,"RANDOMTOSKIP",i_val=rand2skip,error=error) - CPPostcondition(rand2skip>=0,cp_failure_level,routineP,error,failure) - temp=cp_unit_from_cp2k(simpar%temp_ext,"K",error=error) + i_val=iprint) + CALL section_vals_val_get(mc_section,"RANDOMTOSKIP",i_val=rand2skip) + CPPostcondition(rand2skip>=0,cp_failure_level,routineP,failure) + temp=cp_unit_from_cp2k(simpar%temp_ext,"K") ! CALL set_mc_par(mc_par, ensemble=ensemble, nstep=nmccycles, iprint=iprint, temperature=temp, & @@ -373,21 +371,21 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) WRITE(output_unit,'(a,f16.8,a)')"HMC| Temperature ",temp, "K" ENDIF - CALL force_env_get( force_env, subsys=subsys, error=error ) + CALL force_env_get( force_env, subsys=subsys) CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& - particles=particles,virial=virial,error=error) + particles=particles,virial=virial) DO i=1,rand2skip - auxRandom=next_random_number(rng_stream_mc,error=error) + auxRandom=next_random_number(rng_stream_mc) DO j=1,3*SIZE(particles%els) - auxRandom=next_random_number(globenv%gaussian_rng_stream,error=error) + auxRandom=next_random_number(globenv%gaussian_rng_stream) ENDDO ENDDO - CALL mc_env_create ( mc_env, error = error ) + CALL mc_env_create ( mc_env) CALL set_mc_env( mc_env,mc_par=mc_par,force_env=force_env) !!!!!!!end mc setup @@ -405,12 +403,12 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) "You may consider to switch on the virial evaluation with the keyword: STRESS_TENSOR."//& "Be sure the method you are using can compute the virial! "//& CPSourceFileRef,& - error,failure) + failure) IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN - CALL force_env_get(force_env%sub_force_env(i)%force_env, subsys=subsys_i, error=error ) - CALL cp_subsys_get(subsys_i, virial=virial, error=error) + CALL force_env_get(force_env%sub_force_env(i)%force_env, subsys=subsys_i) + CALL cp_subsys_get(subsys_i, virial=virial) check = check .AND. virial%pv_availability END IF END DO @@ -420,32 +418,32 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR "//& " in each force_eval section. Be sure the method you are using can compute the virial!"//& CPSourceFileRef,& - error,failure) + failure) END IF ! Computing Forces at zero MD step IF (simpar%ensemble /= reftraj_ensemble) THEN - CALL section_vals_val_get(md_section,"STEP_START_VAL",i_val=itimes,error=error) - CALL section_vals_val_get(md_section,"TIME_START_VAL",r_val=time,error=error) - CALL section_vals_val_get(md_section,"ECONS_START_VAL",r_val=constant,error=error) - CALL section_vals_val_set(md_section,"STEP_START_VAL",i_val=initialStep,error=error) - CALL section_vals_val_set(md_section,"TIME_START_VAL",r_val=inittime,error=error) + CALL section_vals_val_get(md_section,"STEP_START_VAL",i_val=itimes) + CALL section_vals_val_get(md_section,"TIME_START_VAL",r_val=time) + CALL section_vals_val_get(md_section,"ECONS_START_VAL",r_val=constant) + CALL section_vals_val_set(md_section,"STEP_START_VAL",i_val=initialStep) + CALL section_vals_val_set(md_section,"TIME_START_VAL",r_val=inittime) initialStep=itimes - CALL cp_iterate(logger%iter_info,iter_nr=itimes,error=error) + CALL cp_iterate(logger%iter_info,iter_nr=itimes) IF(save_mem) THEN - work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) - CALL section_vals_remove_values(work_section, error) - work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY",error=error) - CALL section_vals_remove_values(work_section, error) - work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY") + CALL section_vals_remove_values(work_section) END IF -! CALL force_env_calc_energy_force (force_env, calc_force=.TRUE., error=error) +! CALL force_env_calc_energy_force (force_env, calc_force=.TRUE.) meta_env_saved=> force_env%meta_env NULLIFY(force_env%meta_env) - CALL force_env_calc_energy_force (force_env, calc_force=.FALSE., error=error) + CALL force_env_calc_energy_force (force_env, calc_force=.FALSE.) force_env%meta_env=>meta_env_saved IF(ASSOCIATED(force_env%qs_env))THEN @@ -457,13 +455,13 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) ! Warm-up engines for metadynamics IF (ASSOCIATED(force_env%meta_env)) THEN IF(force_env%meta_env%langevin) THEN - CALL create_wiener_process_cv(force_env%meta_env, error=error) + CALL create_wiener_process_cv(force_env%meta_env) NULLIFY(rng_stream) DO j=1, (rand2skip-1)/nmccycles DO i = 1 , force_env%meta_env%n_colvar rng_stream => force_env%meta_env%rng(i)%stream - auxRandom=next_random_number(rng_stream,error=error) - auxRandom=next_random_number(rng_stream,error=error) + auxRandom=next_random_number(rng_stream) + auxRandom=next_random_number(rng_stream) ENDDO ENDDO ENDIF @@ -476,7 +474,7 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) ! CALL cp_assert(check,cp_failure_level,cp_assertion_failed,routineP,& ! "Inconsistency between DELTA_T and WTGAMMA (both specified):"//& ! " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE",& -! error,failure) +! failure) ! ELSE ! force_env%meta_env%delta_t = dummy ! ENDIF @@ -486,64 +484,64 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) ! ENDIF ! force_env%meta_env%invdt = 1._dp/force_env%meta_env%delta_t ! ENDIF - CALL tamc_force(force_env,error=error) -! CALL metadyn_write_colvar(force_env,error=error) + CALL tamc_force(force_env) +! CALL metadyn_write_colvar(force_env) ENDIF IF (simpar%do_respa)THEN CALL force_env_calc_energy_force (force_env%sub_force_env(1)%force_env,& - calc_force=.TRUE.,error=error) + calc_force=.TRUE.) END IF -! CALL force_env_get( force_env, subsys=subsys, error=error ) +! CALL force_env_get( force_env, subsys=subsys) ! ! CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& -! particles=particles,error=error) +! particles=particles) CALL virial_evaluate(atomic_kinds%els, particles%els, local_particles,& - virial, force_env%para_env%group, error=error) + virial, force_env%para_env%group) - CALL md_energy(md_env,md_ener,error) -! CALL md_write_output(md_env, error) !inits the print env at itimes == 0 also writes trajectories + CALL md_energy(md_env,md_ener) +! CALL md_write_output(md_env) !inits the print env at itimes == 0 also writes trajectories md_stride = 1 ELSE - CALL get_md_env(md_env, reftraj=reftraj, error=error) - CALL initialize_reftraj(reftraj, reftraj_section, md_env, error=error) + CALL get_md_env(md_env, reftraj=reftraj) + CALL initialize_reftraj(reftraj, reftraj_section, md_env) itimes = reftraj%info%first_snapshot -1 md_stride = reftraj%info%stride END IF CALL cp_print_key_finished_output(simpar%info_constraint, logger,& - constraint_section,"CONSTRAINT_INFO",error=error) + constraint_section,"CONSTRAINT_INFO") CALL cp_print_key_finished_output(simpar%lagrange_multipliers, logger,& - constraint_section,"LAGRANGE_MULTIPLIERS",error=error) + constraint_section,"LAGRANGE_MULTIPLIERS") CALL init_mc_moves(moves) CALL init_mc_moves(gmoves) ALLOCATE (r(1:3,SIZE(particles%els)),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ! ALLOCATE (r_old(1:3,size(particles%els)),STAT=isos) -! CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) +! CPPostcondition(isos==0,cp_failure_level,routineP,failure) CALL mc_averages_create(MCaverages) !!!!! some more buffers ! Allocate random number for Langevin Thermostat acting on COLVARS ALLOCATE (xieta(2*force_env%meta_env%n_colvar),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) xieta(:) = 0.0_dp ALLOCATE (An(force_env%meta_env%n_colvar),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) An(:) = 0.0_dp ALLOCATE (fz(force_env%meta_env%n_colvar),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) fz(:) = 0.0_dp ALLOCATE (zbuff(2*force_env%meta_env%n_colvar),STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) zbuff(:) = 0.0_dp IF (output_unit>0)THEN WRITE(output_unit,'(a)')"HMC|==== Initial average forces" ENDIF - CALL metadyn_write_colvar_header(force_env,error=error) + CALL metadyn_write_colvar_header(force_env) moves%hmc%attempts=0 moves%hmc%successes=0 gmoves%hmc%attempts=0 @@ -552,27 +550,27 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) !!! if we come from a restart we shall properly compute the average force !!! read the average force up to now DO i=1,force_env%meta_env%n_colvar - fs_section => section_vals_get_subs_vals(force_env%meta_env%metadyn_section,"EXT_LAGRANGE_FS",error=error) - CALL section_vals_get(fs_section, explicit=explicit, error=error) + fs_section => section_vals_get_subs_vals(force_env%meta_env%metadyn_section,"EXT_LAGRANGE_FS") + CALL section_vals_get(fs_section, explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(fs_section,"_DEFAULT_KEYWORD_",& - i_rep_val=i, r_val=rval, error=error) + i_rep_val=i, r_val=rval) fz(i) = rval*rand2skip END IF ENDDO CALL HMCsampler(globenv,force_env,MCaverages,r,mc_par,moves,gmoves,rng_stream_mc,output_unit,& - fz,zbuff,nskip=rand2skip,error=error) - CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=0,error=error) - CALL section_vals_val_set(mc_section,"RANDOMTOSKIP",i_val=rand2skip+nmccycles,error=error) - CALL write_restart(md_env=md_env,root_section=force_env%root_section, error=error) + fz,zbuff,nskip=rand2skip) + CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=0) + CALL section_vals_val_set(mc_section,"RANDOMTOSKIP",i_val=rand2skip+nmccycles) + CALL write_restart(md_env=md_env,root_section=force_env%root_section) ENDIF IF (output_unit>0)THEN WRITE(output_unit,'(a)')"HMC|==== end initial average forces" ENDIF -! call set_md_env(md_env, init=.FALSE., error=error) +! call set_md_env(md_env, init=.FALSE.) - CALL metadyn_write_colvar(force_env,error=error) + CALL metadyn_write_colvar(force_env) DO istep=1, force_env%meta_env%TAMCSteps ! Increase counters @@ -589,31 +587,31 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) force_env%meta_env%time=force_env%qs_env%sim_time END IF - CALL cp_iterate(logger%iter_info,last=(istep==force_env%meta_env%TAMCSteps),iter_nr=itimes,error=error) + CALL cp_iterate(logger%iter_info,last=(istep==force_env%meta_env%TAMCSteps),iter_nr=itimes) ! Open possible Shake output units simpar%info_constraint = cp_print_key_unit_nr(logger,constraint_section,"CONSTRAINT_INFO",& - extension=".shakeLog",log_filename=.FALSE.,error=error) + extension=".shakeLog",log_filename=.FALSE.) simpar%lagrange_multipliers = cp_print_key_unit_nr(logger,constraint_section,& - "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.,error=error) + "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.) simpar%dump_lm = BTEST(cp_print_key_should_output(logger%iter_info,constraint_section,& - "LAGRANGE_MULTIPLIERS",error=error),cp_p_file) + "LAGRANGE_MULTIPLIERS"),cp_p_file) ! Velocity Verlet Integrator moves%hmc%attempts=0 moves%hmc%successes=0 CALL langevinVEC(md_env,globenv,mc_env,moves,gmoves,r,& - rng_stream_mc,xieta,An,fz,MCaverages,zbuff,error) + rng_stream_mc,xieta,An,fz,MCaverages,zbuff) ! Close Shake output if requested... CALL cp_print_key_finished_output(simpar%info_constraint, logger,& - constraint_section,"CONSTRAINT_INFO",error=error) + constraint_section,"CONSTRAINT_INFO") CALL cp_print_key_finished_output(simpar%lagrange_multipliers, logger,& - constraint_section,"LAGRANGE_MULTIPLIERS",error=error) - CALL cp_iterate(logger%iter_info,iter_nr=initialStep,error=error) - CALL metadyn_write_colvar(force_env,error=error) + constraint_section,"LAGRANGE_MULTIPLIERS") + CALL cp_iterate(logger%iter_info,iter_nr=initialStep) + CALL metadyn_write_colvar(force_env) ! Free Energy calculation -! CALL free_energy_evaluate(md_env,should_stop,free_energy_section,error) +! CALL free_energy_evaluate(md_env,should_stop,free_energy_section) ![AME:UB] IF (should_stop) EXIT @@ -626,20 +624,20 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) ! You can force to print the last step (for example if the method used ! to compute energy and forces is not SCF based) activating the print_key ! MOTION%MD%PRINT%FORCE_LAST. - CALL external_control(should_stop,"MD",globenv=globenv,error=error) + CALL external_control(should_stop,"MD",globenv=globenv) IF (should_stop) THEN - CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=itimes,error=error) -! CALL md_output(md_env,md_section,force_env%root_section,should_stop,error=error) + CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=itimes) +! CALL md_output(md_env,md_section,force_env%root_section,should_stop) EXIT END IF ! IF(simpar%ensemble /= reftraj_ensemble) THEN -! CALL md_energy(md_env, md_ener, error) -! CALL temperature_control(simpar, md_env, md_ener, force_env, logger, error) -! CALL comvel_control(md_ener, force_env, md_section, logger, error) -! CALL angvel_control(md_ener, force_env, md_section, logger, error) +! CALL md_energy(md_env, md_ener) +! CALL temperature_control(simpar, md_env, md_ener, force_env, logger) +! CALL comvel_control(md_ener, force_env, md_section, logger) +! CALL angvel_control(md_ener, force_env, md_section, logger) ! ELSE -! CALL md_ener_reftraj(md_env, md_ener, error) +! CALL md_ener_reftraj(md_env, md_ener) ! END IF time_iter_stop=m_walltime() @@ -647,10 +645,10 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) time_iter_start=time_iter_stop !!!!! this writes the restart... -! CALL md_output(md_env,md_section,force_env%root_section,should_stop,error=error) +! CALL md_output(md_env,md_section,force_env%root_section,should_stop) ! IF(simpar%ensemble == reftraj_ensemble ) THEN -! CALL write_output_reftraj(md_env,error=error) +! CALL write_output_reftraj(md_env) ! END IF IF (output_unit>0)THEN @@ -658,49 +656,49 @@ SUBROUTINE qs_tamc(force_env, globenv,averages,error) WRITE(output_unit,'(a)')"HMC|===================================" ENDIF END DO - CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=itimes,error=error) + CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=itimes) force_env%qs_env%sim_time=0.0_dp force_env%qs_env%sim_step=0 rand2skip=rand2skip+nmccycles*force_env%meta_env%TAMCSteps IF (initialStep == 0) rand2skip=rand2skip+nmccycles - CALL section_vals_val_set(mc_section,"RANDOMTOSKIP",i_val=rand2skip,error=error) + CALL section_vals_val_set(mc_section,"RANDOMTOSKIP",i_val=rand2skip) - CALL write_restart(md_env=md_env,root_section=force_env%root_section, error=error) + CALL write_restart(md_env=md_env,root_section=force_env%root_section) ! if we need the final kinetic energy for Hybrid Monte Carlo ! hmc_ekin%final_ekin=md_ener%ekin ! Remove the iteration level - CALL cp_rm_iter_level(logger%iter_info,"MD",error=error) + CALL cp_rm_iter_level(logger%iter_info,"MD") ! Deallocate Thermostats and Barostats - CALL release_thermostats(thermostats, error=error) - CALL release_barostat_type(barostat, error=error) - CALL release_simpar_type(simpar, error) - CALL release_thermal_regions(thermal_regions, error) + CALL release_thermostats(thermostats) + CALL release_barostat_type(barostat) + CALL release_simpar_type(simpar) + CALL release_thermal_regions(thermal_regions) - CALL md_env_release(md_env, error=error) + CALL md_env_release(md_env) ! Clean restartable sections.. - IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section,error=error) + IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section) ! IF (para_env%ionode) THEN - CALL delete_rng_stream(rng_stream_mc,error=error) + CALL delete_rng_stream(rng_stream_mc) ! ENDIF - CALL MC_ENV_RELEASE(mc_env,error) + CALL MC_ENV_RELEASE(mc_env) DEALLOCATE(mc_par, stat=isos) ! do not forget to clean this mess - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) CALL MC_MOVES_RELEASE(moves) CALL MC_MOVES_RELEASE(gmoves) DEALLOCATE(r,STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) ! DEALLOCATE(r_old,STAT=isos) -! CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) +! CPPostcondition(isos==0,cp_failure_level,routineP,failure) DEALLOCATE(xieta,STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) DEALLOCATE(An,STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) DEALLOCATE(fz,STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) DEALLOCATE(zbuff,STAT=isos) - CPPostcondition(isos==0,cp_failure_level,routineP,error,failure) + CPPostcondition(isos==0,cp_failure_level,routineP,failure) CALL mc_averages_release(MCaverages) CALL timestop(handle) @@ -712,15 +710,13 @@ END SUBROUTINE qs_tamc !> \brief Propagates velocities for z half a step !> \param force_env ... !> \param An ... -!> \param error ... !> \author Alin M Elena !> \note Vanden-Eijnden Ciccotti C.Phys.Letter 429 (2006) 310-316 ! ***************************************************************************** - SUBROUTINE tamc_velocities_colvar(force_env,An,error) + SUBROUTINE tamc_velocities_colvar(force_env,An) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: An - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tamc_velocities_colvar', & routineP = moduleN//':'//routineN @@ -736,7 +732,7 @@ SUBROUTINE tamc_velocities_colvar(force_env,An,error) NULLIFY(logger,meta_env,cv) meta_env => force_env%meta_env CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Add citation IF (meta_env%langevin) CALL cite_reference(VandenCic2006) dt = meta_env%dt @@ -757,15 +753,13 @@ END SUBROUTINE tamc_velocities_colvar !> \brief propagates z one step !> \param force_env ... !> \param xieta ... -!> \param error ... !> \author Alin M Elena !> \note Vanden-Eijnden Ciccotti C.Phys.Letter 429 (2006) 310-316 ! ***************************************************************************** - SUBROUTINE tamc_position_colvar(force_env,xieta,error) + SUBROUTINE tamc_position_colvar(force_env,xieta) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: xieta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tamc_position_colvar', & routineP = moduleN//':'//routineN @@ -783,7 +777,7 @@ SUBROUTINE tamc_position_colvar(force_env,xieta,error) ! IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Add citation IF (meta_env%langevin) CALL cite_reference(VandenCic2006) @@ -809,13 +803,11 @@ END SUBROUTINE tamc_position_colvar !> #details also can be used to get the potenzial evergy of z !> \param force_env ... !> \param zpot ... -!> \param error ... !> \author Alin M Elena ! ***************************************************************************** - SUBROUTINE tamc_force(force_env,zpot,error) + SUBROUTINE tamc_force(force_env,zpot) TYPE(force_env_type), POINTER :: force_env REAL(KIND=dp), INTENT(inout), OPTIONAL :: zpot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tamc_force', & routineP = moduleN//':'//routineN @@ -839,9 +831,9 @@ SUBROUTINE tamc_force(force_env,zpot,error) ! IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(colvar_p,subsys,cv,ss0_section, vvp_section,ss_section) - CALL force_env_get(force_env, subsys=subsys, error=error) + CALL force_env_get(force_env, subsys=subsys) dt = meta_env%dt IF (.NOT.meta_env%restart) meta_env%n_steps=meta_env%n_steps+1 @@ -849,35 +841,35 @@ SUBROUTINE tamc_force(force_env,zpot,error) DO i_c=1,meta_env%n_colvar cv => meta_env%metavar(i_c) icolvar = cv%icolvar - CALL colvar_eval_glob_f(icolvar,force_env,error=error) + CALL colvar_eval_glob_f(icolvar,force_env) cv%ss = subsys%colvar_p(icolvar)%colvar%ss ! Restart for Extended Lagrangian Metadynamics IF (meta_env%restart) THEN ! Initialize the position of the collective variable in the extended lagrange - ss0_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS0",error=error) - CALL section_vals_get(ss0_section, explicit=explicit, error=error) + ss0_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS0") + CALL section_vals_get(ss0_section, explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(ss0_section,"_DEFAULT_KEYWORD_",& - i_rep_val=i_c, r_val=rval, error=error) + i_rep_val=i_c, r_val=rval) cv%ss0 = rval ELSE cv%ss0 = cv%ss END IF - vvp_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_VVP",error=error) - CALL section_vals_get(vvp_section, explicit=explicit, error=error) + vvp_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_VVP") + CALL section_vals_get(vvp_section, explicit=explicit) IF (explicit) THEN - CALL setup_velocities_z(force_env,error) + CALL setup_velocities_z(force_env) CALL section_vals_val_get(vvp_section,"_DEFAULT_KEYWORD_",& - i_rep_val=i_c, r_val=rval, error=error) + i_rep_val=i_c, r_val=rval) cv%vvp = rval ELSE - CALL setup_velocities_z(force_env,error) + CALL setup_velocities_z(force_env) ENDIF - ss_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS",error=error) - CALL section_vals_get(ss_section, explicit=explicit, error=error) + ss_section => section_vals_get_subs_vals(meta_env%metadyn_section,"EXT_LAGRANGE_SS") + CALL section_vals_get(ss_section, explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(ss_section,"_DEFAULT_KEYWORD_",& - i_rep_val=i_c, r_val=rval, error=error) + i_rep_val=i_c, r_val=rval) cv%ss = rval END IF END IF @@ -886,7 +878,7 @@ SUBROUTINE tamc_force(force_env,zpot,error) ! forces on the atoms NULLIFY(particles) CALL cp_subsys_get(subsys, colvar_p=colvar_p, & - particles=particles,error=error) + particles=particles) meta_env%restart = .FALSE. meta_env%epot_s = 0.0_dp @@ -910,7 +902,7 @@ SUBROUTINE tamc_force(force_env,zpot,error) ENDDO IF(PRESENT(zpot))zpot=meta_env%epot_s - CALL fix_atom_control(force_env, error=error) + CALL fix_atom_control(force_env) CALL timestop(handle) END SUBROUTINE tamc_force @@ -931,11 +923,10 @@ END SUBROUTINE tamc_force !> \param fz ... !> \param averages ... !> \param zbuff ... -!> \param error ... !> \author Alin M Elena ! ***************************************************************************** SUBROUTINE langevinVEC ( md_env, globenv,mc_env,moves,gmoves,r,& - rng_stream_mc,xieta,An,fz,averages,zbuff,error) + rng_stream_mc,xieta,An,fz,averages,zbuff) TYPE(md_environment_type), POINTER :: md_env TYPE(global_environment_type), POINTER :: globenv @@ -950,7 +941,6 @@ SUBROUTINE langevinVEC ( md_env, globenv,mc_env,moves,gmoves,r,& POINTER :: averages REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: zbuff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'langevinVEC', & routineP = moduleN//':'//routineN @@ -986,7 +976,7 @@ SUBROUTINE langevinVEC ( md_env, globenv,mc_env,moves,gmoves,r,& TYPE(virial_type), POINTER :: virial NULLIFY(logger, mc_par) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) NULLIFY(rng_stream) @@ -999,21 +989,21 @@ SUBROUTINE langevinVEC ( md_env, globenv,mc_env,moves,gmoves,r,& NULLIFY(atomic_kinds,local_particles,particles,local_molecules,molecules,molecule_kinds,gci) CALL get_md_env(md_env=md_env, simpar=simpar, force_env=force_env,& - para_env=para_env, error=error) + para_env=para_env) CALL get_mc_env(mc_env, mc_par=mc_par) CALL get_mc_par(mc_par,nstep=nstep,iprint=iprint) dt = simpar%dt - CALL force_env_get(force_env=force_env,subsys=subsys,cell=cell,error=error) + CALL force_env_get(force_env=force_env,subsys=subsys,cell=cell) !!!! this bit should vanish once I understand what the hell is with it ! ! Do some checks on coordinates and box - CALL apply_qmmm_walls_reflective(force_env, error=error) + CALL apply_qmmm_walls_reflective(force_env) CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& particles=particles,local_molecules_new=local_molecules,molecules_new=molecules,& - molecule_kinds_new=molecule_kinds,gci=gci,virial=virial,error=error) + molecule_kinds_new=molecule_kinds,gci=gci,virial=virial) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -1022,14 +1012,14 @@ SUBROUTINE langevinVEC ( md_env, globenv,mc_env,moves,gmoves,r,& nparticle = particles%n_els particle_set => particles%els molecule_set => molecules%els - CPPrecondition(ASSOCIATED(force_env%meta_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%meta_env%langevin,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env%meta_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%meta_env%langevin,cp_failure_level,routineP,failure) ! *** Velocity Verlet for Langevin *** v(t)--> v(t+1/2) !!!!!! noise xi is in the first half, eta in the second half DO ivar = 1 , force_env%meta_env%n_colvar rng_stream => force_env%meta_env%rng(ivar)%stream - xieta(ivar)=next_random_number(rng_stream,error=error) - xieta(ivar+force_env%meta_env%n_colvar)=next_random_number(rng_stream,error=error) + xieta(ivar)=next_random_number(rng_stream) + xieta(ivar+force_env%meta_env%n_colvar)=next_random_number(rng_stream) gamma=force_env%meta_env%metavar(ivar)%gamma mass=force_env%meta_env%metavar(ivar)%mass sigma = SQRT((force_env%meta_env%temp_wanted*kelvin)*2.0_dp*(boltzmann/joule)*gamma/mass) @@ -1037,11 +1027,11 @@ SUBROUTINE langevinVEC ( md_env, globenv,mc_env,moves,gmoves,r,& dt*gamma*xieta(ivar+force_env%meta_env%n_colvar)/SQRT(12.0_dp)) ENDDO ! *** Velocity Verlet for Langeving *** v(t)--> v(t+1/2) - CALL tamc_velocities_colvar(force_env,An,error=error) + CALL tamc_velocities_colvar(force_env,An) ! *** Velocity Verlet for Langevin S(t)->S(t+1) - CALL tamc_position_colvar(force_env,xieta,error) + CALL tamc_position_colvar(force_env,xieta) !!!!! start zHMC sampler - CALL HMCsampler(globenv,force_env,averages,r,mc_par,moves,gmoves,rng_stream_mc,output_unit,fz,zbuff,error=error) + CALL HMCsampler(globenv,force_env,averages,r,mc_par,moves,gmoves,rng_stream_mc,output_unit,fz,zbuff) ! CALL final_mc_write(mc_par,tmp_moves,& ! output_unit,energy_check,& @@ -1050,9 +1040,9 @@ SUBROUTINE langevinVEC ( md_env, globenv,mc_env,moves,gmoves,r,& !!!!!!!!!!!!!!!!!!!! end zHMC sampler ! *** Velocity Verlet for Langeving *** v(t+1/2)--> v(t+1) - CALL tamc_velocities_colvar(force_env,An,error) + CALL tamc_velocities_colvar(force_env,An) ! CALL virial_evaluate ( atomic_kind_set, particle_set, & -! local_particles, virial, para_env%group, error=error) +! local_particles, virial, para_env%group) END SUBROUTINE langevinVEC @@ -1071,13 +1061,12 @@ END SUBROUTINE langevinVEC !> \param fz ... !> \param zbuff ... !> \param nskip ... -!> \param error ... !> \author Alin M Elena !> \note at the end of this routine %ff_s will contain mean force ! ***************************************************************************** SUBROUTINE HMCsampler(globenv,force_env,averages,r,mc_par,moves,gmoves,rng_stream_mc,output_unit,& - fz,zbuff,nskip,error) + fz,zbuff,nskip) TYPE(global_environment_type), POINTER :: globenv TYPE(force_env_type), POINTER :: force_env TYPE(mc_averages_type), POINTER :: averages @@ -1090,7 +1079,6 @@ SUBROUTINE HMCsampler(globenv,force_env,averages,r,mc_par,moves,gmoves,rng_strea REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: fz, zbuff INTEGER, INTENT(IN), OPTIONAL :: nskip - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, iprint, ishift, it1, j, & nsamples, nstep @@ -1113,7 +1101,7 @@ SUBROUTINE HMCsampler(globenv,force_env,averages,r,mc_par,moves,gmoves,rng_strea CALL get_mc_par(mc_par,nstep=nstep,iprint=iprint) meta_env_saved=> force_env%meta_env NULLIFY(force_env%meta_env) - CALL force_env_get(force_env,potential_energy=old_epx,error=error) + CALL force_env_get(force_env,potential_energy=old_epx) force_env%meta_env=> meta_env_saved old_epz=force_env%meta_env%epot_s @@ -1141,7 +1129,7 @@ SUBROUTINE HMCsampler(globenv,force_env,averages,r,mc_par,moves,gmoves,rng_strea ENDIF CALL mc_hmc_move(mc_par, force_env,globenv, moves,gmoves,old_epx,old_epz,energy_check,& - r, output_unit, rng_stream_mc,zbuff,error) + r, output_unit, rng_stream_mc,zbuff) ! check averages... ! force average for z needed too... averages%ave_energy=averages%ave_energy*REAL(i-1,dp)/REAL(i,dp)+& @@ -1174,10 +1162,10 @@ SUBROUTINE HMCsampler(globenv,force_env,averages,r,mc_par,moves,gmoves,rng_strea ! DO j=1,force_env%meta_env%n_colvar ! force_env%meta_env%metavar(j)%ff_s=fz(j)/real(i+ishift,dp) ! ENDDO -! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=-1,error=error) -! CALL section_vals_val_set(mcsec,"RANDOMTOSKIP",i_val=i+ishift,error=error) -! CALL write_restart(md_env=mdenv,root_section=force_env%root_section, error=error) -! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter,error=error) +! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=-1) +! CALL section_vals_val_set(mcsec,"RANDOMTOSKIP",i_val=i+ishift) +! CALL write_restart(md_env=mdenv,root_section=force_env%root_section) +! ! CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter) ! ENDIF ! ENDIF ENDDO @@ -1209,13 +1197,12 @@ END SUBROUTINE HMCsampler !> \param output_unit ... !> \param rng_stream ... !> \param zbuff ... -!> \param error ... !> \author Alin M Elena !> \note It runs a NVE trajectory, followed by localisation and accepts rejects !> using the biased Hamiltonian, rather than the traditional guiding Hamiltonian ! ***************************************************************************** SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,gmoves,old_epx,old_epz,& - energy_check,r,output_unit,rng_stream,zbuff,error) + energy_check,r,output_unit,rng_stream,zbuff) TYPE(mc_simpar_type), POINTER :: mc_par TYPE(force_env_type), POINTER :: force_env @@ -1228,7 +1215,6 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,gmoves,old_epx,old_epz TYPE(rng_stream_type), POINTER :: rng_stream REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: zbuff - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mc_hmc_move', & routineP = moduleN//':'//routineN @@ -1253,8 +1239,8 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,gmoves,old_epx,old_epz failure=.TRUE. NULLIFY(scf_env) - CALL get_qs_env(force_env%qs_env,scf_env=scf_env,error=error,input=input) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + CALL get_qs_env(force_env%qs_env,scf_env=scf_env,input=input) + dft_section => section_vals_get_subs_vals(input,"DFT") ! get a bunch of stuff from mc_par CALL get_mc_par(mc_par,ionode=ionode,& @@ -1265,16 +1251,14 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,gmoves,old_epx,old_epz ! NULLIFY(particles_set,oldsys,hmc_ekin) NULLIFY(particles_set,oldsys,meta_env_saved,hmc_ekin) ! now let's grab the particle positions - CALL force_env_get(force_env,subsys=oldsys,& - error=error) - CALL cp_subsys_get(oldsys,particles=particles_set, & - error=error) + CALL force_env_get(force_env,subsys=oldsys) + CALL cp_subsys_get(oldsys,particles=particles_set) nAtoms=SIZE(particles_set%els) ! do some allocation ALLOCATE (hmc_ekin,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! record the attempt moves%hmc%attempts=moves%hmc%attempts+1 @@ -1301,18 +1285,18 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,gmoves,old_epx,old_epz force_env%qs_env%sim_time=0.0_dp force_env%qs_env%sim_step=0 IF (.NOT. localise) THEN - CALL section_vals_val_set(dft_section,"LOCALIZE%_SECTION_PARAMETERS_",l_val=.FALSE.,error=error) + CALL section_vals_val_set(dft_section,"LOCALIZE%_SECTION_PARAMETERS_",l_val=.FALSE.) ENDIF - CALL qs_mol_dyn(force_env,globenv,error=error,hmc_e_initial=hmc_ekin%initial_ekin,hmc_e_final=hmc_ekin%final_ekin) + CALL qs_mol_dyn(force_env,globenv,hmc_e_initial=hmc_ekin%initial_ekin,hmc_e_final=hmc_ekin%final_ekin) IF (.NOT. localise) THEN - CALL section_vals_val_set(dft_section,"LOCALIZE%_SECTION_PARAMETERS_",l_val=.TRUE.,error=error) - CALL scf_post_calculation_gpw(dft_section, scf_env, force_env%qs_env, error) + CALL section_vals_val_set(dft_section,"LOCALIZE%_SECTION_PARAMETERS_",l_val=.TRUE.) + CALL scf_post_calculation_gpw(dft_section, scf_env, force_env%qs_env) ENDIF - CALL force_env_get(force_env, potential_energy=new_epx,error=error) + CALL force_env_get(force_env, potential_energy=new_epx) force_env%meta_env=>meta_env_saved - CALL tamc_force(force_env, zpot=new_epz,error=error) + CALL tamc_force(force_env, zpot=new_epz) new_energy=new_epx+new_epz IF (output_unit>0) THEN WRITE(output_unit,'(a,4(f16.8,1x))')"HMC|old Ep, Ekx, Epz, Epx ",old_epx+old_epz,hmc_ekin%initial_ekin, old_epz,old_epx @@ -1330,7 +1314,7 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,gmoves,old_epx,old_epz w=EXP(value) ENDIF - rand=next_random_number(rng_stream,error=error) + rand=next_random_number(rng_stream) IF (rand < w) THEN ! accept the move moves%hmc%successes=moves%hmc%successes+1 @@ -1352,7 +1336,7 @@ SUBROUTINE mc_hmc_move ( mc_par,force_env, globenv, moves,gmoves,old_epx,old_epz ENDIF DEALLOCATE(hmc_ekin,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! end the timing CALL timestop(handle) @@ -1364,11 +1348,9 @@ END SUBROUTINE mc_hmc_move ! ***************************************************************************** !> \brief ... !> \param force_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE metadyn_write_colvar_header(force_env,error) +SUBROUTINE metadyn_write_colvar_header(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_write_colvar_header', & routineP = moduleN//':'//routineN @@ -1387,10 +1369,10 @@ SUBROUTINE metadyn_write_colvar_header(force_env,error) IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%COLVAR",extension=".metadynLog",error=error) + "PRINT%COLVAR",extension=".metadynLog") IF (iw>0) THEN label1="" label2="" @@ -1439,7 +1421,7 @@ SUBROUTINE metadyn_write_colvar_header(force_env,error) END IF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%COLVAR", error=error) + "PRINT%COLVAR") CALL timestop(handle) @@ -1448,11 +1430,9 @@ END SUBROUTINE metadyn_write_colvar_header ! ***************************************************************************** !> \brief ... !> \param force_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE metadyn_write_colvar(force_env,error) + SUBROUTINE metadyn_write_colvar(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'metadyn_write_colvar', & routineP = moduleN//':'//routineN @@ -1470,7 +1450,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) IF (.NOT.ASSOCIATED(meta_env)) RETURN CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (meta_env%langevin) THEN meta_env%ekin_s = 0.0_dp @@ -1483,7 +1463,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) ! write COLVAR file iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%COLVAR",extension=".metadynLog",error=error) + "PRINT%COLVAR",extension=".metadynLog") IF (iw>0) THEN IF (meta_env%extended_lagrange) THEN WRITE(iw,'(f16.8,70f15.8)')meta_env%time*femtoseconds, & @@ -1507,14 +1487,14 @@ SUBROUTINE metadyn_write_colvar(force_env,error) END IF END IF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%COLVAR", error=error) + "PRINT%COLVAR") ! Temperature for COLVAR IF (meta_env%extended_lagrange) THEN temp = meta_env%ekin_s*2.0_dp/(REAL(meta_env%n_colvar,KIND=dp))*kelvin meta_env%avg_temp = (meta_env%avg_temp*REAL(meta_env%n_steps,KIND=dp)+& temp)/REAL(meta_env%n_steps+1,KIND=dp) iw = cp_print_key_unit_nr(logger,meta_env%metadyn_section,& - "PRINT%TEMPERATURE_COLVAR",extension=".metadynLog",error=error) + "PRINT%TEMPERATURE_COLVAR",extension=".metadynLog") IF (iw > 0) THEN WRITE (iw, '(T2,79("-"))') WRITE (iw,'( A,T51,f10.2,T71,f10.2)' )' COLVARS INSTANTANEOUS/AVERAGE TEMPERATURE ',& @@ -1522,7 +1502,7 @@ SUBROUTINE metadyn_write_colvar(force_env,error) WRITE (iw, '(T2,79("-"))') ENDIF CALL cp_print_key_finished_output(iw,logger,meta_env%metadyn_section,& - "PRINT%TEMPERATURE_COLVAR", error=error) + "PRINT%TEMPERATURE_COLVAR") END IF CALL timestop(handle) @@ -1532,11 +1512,9 @@ END SUBROUTINE metadyn_write_colvar ! ***************************************************************************** !> \brief ... !> \param force_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE setup_velocities_z(force_env,error) + SUBROUTINE setup_velocities_z(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i_c REAL(kind=dp) :: ekin_w, fac_t @@ -1548,7 +1526,7 @@ SUBROUTINE setup_velocities_z(force_env,error) meta_env%ekin_s = 0.0_dp DO i_c=1,meta_env%n_colvar cv => meta_env%metavar(i_c) - cv%vvp = next_random_number(force_env%globenv%gaussian_rng_stream,error=error) + cv%vvp = next_random_number(force_env%globenv%gaussian_rng_stream) meta_env%ekin_s = meta_env%ekin_s + 0.5_dp*cv%mass*cv%vvp**2 END DO ekin_w = 0.5_dp*meta_env%temp_wanted*REAL(meta_env%n_colvar,KIND=dp) diff --git a/src/motion/md_conserved_quantities.F b/src/motion/md_conserved_quantities.F index 5292d95624..ae19cd1b3e 100644 --- a/src/motion/md_conserved_quantities.F +++ b/src/motion/md_conserved_quantities.F @@ -65,7 +65,6 @@ MODULE md_conserved_quantities !> \param tkind ... !> \param tshell ... !> \param natom ... -!> \param error ... !> \par Input Arguments !> md_env is the md_environment !> epot is the total potential energy @@ -81,12 +80,11 @@ MODULE md_conserved_quantities !> \author gloria ! ***************************************************************************** SUBROUTINE compute_conserved_quantity (md_env, md_ener, tkind, tshell,& - natom, error) + natom) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), POINTER :: md_ener LOGICAL, INTENT(IN) :: tkind, tshell INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_conserved_quantity', & routineP = moduleN//':'//routineN @@ -102,24 +100,23 @@ SUBROUTINE compute_conserved_quantity (md_env, md_ener, tkind, tshell,& NULLIFY(itimes, para_env, simpar) - CALL zero_md_ener(md_ener, tkind, tshell, error=error) + CALL zero_md_ener(md_ener, tkind, tshell) CALL get_md_env (md_env=md_env,& constant=constant,& itimes=itimes,& init=init,& simpar=simpar,& - para_env = para_env, & - error=error) + para_env = para_env) - CALL get_part_ke ( md_env, md_ener, tkind, tshell, para_env%group, error=error) + CALL get_part_ke ( md_env, md_ener, tkind, tshell, para_env%group) IF (md_ener%nfree /= 0) THEN md_ener%temp_part = 2.0_dp * md_ener%ekin / REAL ( simpar%nfree,KIND=dp) md_ener%temp_part = md_ener%temp_part*kelvin END IF - nfree_qm = calc_nfree_qm(md_env, md_ener, error) + nfree_qm = calc_nfree_qm(md_env, md_ener) IF (nfree_qm > 0) THEN md_ener%temp_qm = 2.0_dp * md_ener%ekin_qm / REAL (nfree_qm,KIND=dp) md_ener%temp_qm = md_ener%temp_qm*kelvin @@ -154,35 +151,35 @@ SUBROUTINE compute_conserved_quantity (md_env, md_ener, tkind, tshell,& CASE ( reftraj_ensemble ) ! no constant of motion available md_ener%constant = md_ener%epot CASE ( nve_ensemble) - CALL get_econs_nve (md_env, md_ener, para_env,error=error) + CALL get_econs_nve (md_env, md_ener, para_env) CASE ( nvt_ensemble) - CALL get_econs_nvt (md_env, md_ener, para_env,error=error) + CALL get_econs_nvt (md_env, md_ener, para_env) CASE ( npt_i_ensemble, npt_f_ensemble ) - CALL get_econs_npt (md_env, md_ener, para_env, error=error) + CALL get_econs_npt (md_env, md_ener, para_env) md_ener%temp_baro = md_ener%temp_baro*kelvin CASE ( nph_uniaxial_ensemble ) - CALL get_econs_nph_uniaxial (md_env, md_ener, error=error) + CALL get_econs_nph_uniaxial (md_env, md_ener) md_ener%temp_baro = md_ener%temp_baro*kelvin CASE ( nph_uniaxial_damped_ensemble ) - CALL get_econs_nph_uniaxial (md_env, md_ener, error=error) + CALL get_econs_nph_uniaxial (md_env, md_ener) md_ener%temp_baro = md_ener%temp_baro*kelvin CASE ( langevin_ensemble ) md_ener%constant = md_ener%ekin + md_ener%epot CASE ( npe_f_ensemble, npe_i_ensemble ) - CALL get_econs_npe (md_env, md_ener, para_env, error=error) + CALL get_econs_npe (md_env, md_ener, para_env) md_ener%temp_baro = md_ener%temp_baro*kelvin CASE ( nvt_adiabatic_ensemble ) - CALL get_econs_nvt_adiabatic (md_env, md_ener, para_env, error=error) + CALL get_econs_nvt_adiabatic (md_env, md_ener, para_env) END SELECT IF (init) THEN ! If the value was not read from input let's set it at the begin of the MD IF (constant == 0.0_dp) THEN constant = md_ener%constant - CALL set_md_env(md_env=md_env, constant=constant, error=error) + CALL set_md_env(md_env=md_env, constant=constant) END IF ELSE - CALL get_md_env(md_env=md_env, constant=constant, error=error) + CALL get_md_env(md_env=md_env, constant=constant) md_ener%delta_cons = (md_ener%constant - constant)/REAL(natom,KIND=dp)*kelvin END IF @@ -192,13 +189,11 @@ END SUBROUTINE compute_conserved_quantity !> \brief Calculates the number of QM degress of freedom !> \param md_env ... !> \param md_ener ... -!> \param error ... !> \retval nfree_qm ... ! ***************************************************************************** - FUNCTION calc_nfree_qm(md_env, md_ener, error) RESULT(nfree_qm) + FUNCTION calc_nfree_qm(md_env, md_ener) RESULT(nfree_qm) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), POINTER :: md_ener - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: nfree_qm CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_nfree_qm', & @@ -216,16 +211,15 @@ FUNCTION calc_nfree_qm(md_env, md_ener, error) RESULT(nfree_qm) NULLIFY(qmmm_env,qmmmx_env,subsys,particles,force_env,force_env_section) nfree_qm = 0 - CALL get_md_env (md_env, force_env=force_env, error=error) + CALL get_md_env (md_env, force_env=force_env) CALL force_env_get(force_env,& subsys=subsys,& qmmm_env=qmmm_env,& qmmmx_env=qmmmx_env,& - force_env_section=force_env_section,& - error=error) + force_env_section=force_env_section) IF(ASSOCIATED(qmmm_env)) THEN ! conventional QM/MM - CALL cp_subsys_get(subsys, particles=particles, error=error) + CALL cp_subsys_get(subsys, particles=particles) ! The degrees of freedom for the quantum part of the system ! are set to 3*Number of QM atoms and to simpar%nfree in case all the MM ! system is treated at QM level (not really QM/MM, just for consistency). @@ -236,8 +230,8 @@ FUNCTION calc_nfree_qm(md_env, md_ener, error) RESULT(nfree_qm) END IF IF(ASSOCIATED(qmmmx_env)) THEN ! doing force mixing - CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%INDICES",i_vals=cur_indices,error=error) - CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%LABELS",i_vals=cur_labels,error=error) + CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%INDICES",i_vals=cur_indices) + CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%LABELS",i_vals=cur_labels) nfree_qm = 0 DO ip=1, SIZE(cur_indices) IF (cur_labels(ip) >= force_mixing_label_QM_dynamics) THEN ! this is a QM atom @@ -255,16 +249,14 @@ END FUNCTION calc_nfree_qm !> \param md_env ... !> \param md_ener ... !> \param para_env ... -!> \param error ... !> \par History !> none !> \author gloria ! ***************************************************************************** - SUBROUTINE get_econs_nve ( md_env, md_ener, para_env, error ) + SUBROUTINE get_econs_nve ( md_env, md_ener, para_env) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), INTENT(inout) :: md_ener TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_econs_nve', & routineP = moduleN//':'//routineN @@ -276,11 +268,11 @@ SUBROUTINE get_econs_nve ( md_env, md_ener, para_env, error ) NULLIFY(force_env, thermostat_coeff,thermostat_shell) CALL get_md_env (md_env, force_env=force_env, thermostat_coeff=thermostat_coeff,& - thermostat_shell=thermostat_shell, error=error) + thermostat_shell=thermostat_shell) md_ener%constant = md_ener%ekin + md_ener%epot + md_ener%ekin_shell CALL get_thermostat_energies ( thermostat_shell, md_ener%thermostat_shell_pot,& - md_ener%thermostat_shell_kin, para_env, error=error ) + md_ener%thermostat_shell_kin, para_env) md_ener%constant = md_ener%constant + md_ener%thermostat_shell_kin + md_ener%thermostat_shell_pot END SUBROUTINE get_econs_nve @@ -290,16 +282,14 @@ END SUBROUTINE get_econs_nve !> \param md_env ... !> \param md_ener ... !> \param para_env ... -!> \param error ... !> \par History !> none !> \author gloria ! ***************************************************************************** - SUBROUTINE get_econs_nvt_adiabatic ( md_env, md_ener, para_env, error) + SUBROUTINE get_econs_nvt_adiabatic ( md_env, md_ener, para_env) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), INTENT(inout) :: md_ener TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_econs_nvt_adiabatic', & routineP = moduleN//':'//routineN @@ -310,13 +300,13 @@ SUBROUTINE get_econs_nvt_adiabatic ( md_env, md_ener, para_env, error) NULLIFY(force_env, thermostat_fast, thermostat_slow ) CALL get_md_env (md_env, force_env=force_env, thermostat_fast=thermostat_fast,& - thermostat_slow=thermostat_slow, error=error ) + thermostat_slow=thermostat_slow) CALL get_thermostat_energies ( thermostat_fast, md_ener%thermostat_fast_pot, & - md_ener%thermostat_fast_kin, para_env, error=error ) + md_ener%thermostat_fast_kin, para_env) md_ener%constant = md_ener% ekin + md_ener%epot + & md_ener%thermostat_fast_kin + md_ener%thermostat_fast_pot CALL get_thermostat_energies ( thermostat_slow, md_ener%thermostat_slow_pot, & - md_ener%thermostat_slow_kin, para_env, error=error ) + md_ener%thermostat_slow_kin, para_env) md_ener%constant = md_ener%constant + & md_ener%thermostat_slow_kin + md_ener%thermostat_slow_pot @@ -328,16 +318,14 @@ END SUBROUTINE get_econs_nvt_adiabatic !> \param md_env ... !> \param md_ener ... !> \param para_env ... -!> \param error ... !> \par History !> none !> \author gloria ! ***************************************************************************** - SUBROUTINE get_econs_nvt ( md_env, md_ener, para_env, error) + SUBROUTINE get_econs_nvt ( md_env, md_ener, para_env) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), INTENT(inout) :: md_ener TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_econs_nvt', & routineP = moduleN//':'//routineN @@ -349,14 +337,14 @@ SUBROUTINE get_econs_nvt ( md_env, md_ener, para_env, error) NULLIFY(force_env, thermostat_part, thermostat_coeff, thermostat_shell) CALL get_md_env (md_env, force_env=force_env, thermostat_part=thermostat_part,& - thermostat_coeff=thermostat_coeff, thermostat_shell=thermostat_shell, error=error ) + thermostat_coeff=thermostat_coeff, thermostat_shell=thermostat_shell) CALL get_thermostat_energies ( thermostat_part, md_ener%thermostat_part_pot, & - md_ener%thermostat_part_kin, para_env, error=error ) + md_ener%thermostat_part_kin, para_env) md_ener%constant = md_ener% ekin + md_ener%epot + md_ener%ekin_shell +& md_ener%thermostat_part_kin + md_ener%thermostat_part_pot CALL get_thermostat_energies ( thermostat_shell, md_ener%thermostat_shell_pot,& - md_ener%thermostat_shell_kin, para_env, error=error ) + md_ener%thermostat_shell_kin, para_env) md_ener%constant = md_ener%constant + md_ener%thermostat_shell_kin + md_ener%thermostat_shell_pot END SUBROUTINE get_econs_nvt @@ -366,16 +354,14 @@ END SUBROUTINE get_econs_nvt !> \param md_env ... !> \param md_ener ... !> \param para_env ... -!> \param error ... !> \par History !> none !> \author marcella (02-2008) ! ***************************************************************************** - SUBROUTINE get_econs_npe ( md_env, md_ener, para_env, error) + SUBROUTINE get_econs_npe ( md_env, md_ener, para_env) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), INTENT(inout) :: md_ener TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_econs_npe', & routineP = moduleN//':'//routineN @@ -390,9 +376,9 @@ SUBROUTINE get_econs_npe ( md_env, md_ener, para_env, error) NULLIFY(thermostat_baro, thermostat_shell, npt) CALL get_md_env ( md_env, thermostat_baro=thermostat_baro, & simpar = simpar, npt = npt, cell = box, & - thermostat_shell=thermostat_shell, error=error) + thermostat_shell=thermostat_shell) CALL get_baro_energies ( box, simpar, npt, md_ener%baro_kin, & - md_ener%baro_pot, error=error ) + md_ener%baro_pot) nfree = SIZE ( npt, 1 ) * SIZE ( npt, 2 ) md_ener%temp_baro = 2.0_dp * md_ener%baro_kin / nfree @@ -400,7 +386,7 @@ SUBROUTINE get_econs_npe ( md_env, md_ener, para_env, error) + md_ener%baro_kin + md_ener%baro_pot CALL get_thermostat_energies ( thermostat_shell, md_ener%thermostat_shell_pot, & - md_ener%thermostat_shell_kin, para_env, error=error) + md_ener%thermostat_shell_kin, para_env) md_ener%constant = md_ener%constant + md_ener%thermostat_shell_kin + & md_ener%thermostat_shell_pot @@ -412,16 +398,14 @@ END SUBROUTINE get_econs_npe !> \param md_env ... !> \param md_ener ... !> \param para_env ... -!> \param error ... !> \par History !> none !> \author gloria ! ***************************************************************************** - SUBROUTINE get_econs_npt ( md_env, md_ener, para_env, error) + SUBROUTINE get_econs_npt ( md_env, md_ener, para_env) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), INTENT(inout) :: md_ener TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_econs_npt', & routineP = moduleN//':'//routineN @@ -436,12 +420,12 @@ SUBROUTINE get_econs_npt ( md_env, md_ener, para_env, error) NULLIFY(thermostat_baro, thermostat_part, thermostat_shell, npt, simpar, box) CALL get_md_env ( md_env, thermostat_part=thermostat_part, thermostat_baro=thermostat_baro, & - simpar = simpar, npt = npt, cell = box, thermostat_shell=thermostat_shell, error=error) + simpar = simpar, npt = npt, cell = box, thermostat_shell=thermostat_shell) CALL get_thermostat_energies(thermostat_part, md_ener%thermostat_part_pot, & - md_ener%thermostat_part_kin, para_env, error=error ) + md_ener%thermostat_part_kin, para_env) CALL get_thermostat_energies(thermostat_baro, md_ener%thermostat_baro_pot,& - md_ener%thermostat_baro_kin, para_env, error=error) - CALL get_baro_energies ( box, simpar, npt, md_ener%baro_kin, md_ener%baro_pot, error=error ) + md_ener%thermostat_baro_kin, para_env) + CALL get_baro_energies ( box, simpar, npt, md_ener%baro_kin, md_ener%baro_pot) nfree = SIZE ( npt, 1 ) * SIZE ( npt, 2 ) md_ener%temp_baro = 2.0_dp * md_ener%baro_kin / nfree @@ -451,7 +435,7 @@ SUBROUTINE get_econs_npt ( md_env, md_ener, para_env, error) + md_ener%baro_kin + md_ener%baro_pot CALL get_thermostat_energies ( thermostat_shell, md_ener%thermostat_shell_pot, & - md_ener%thermostat_shell_kin, para_env, error=error ) + md_ener%thermostat_shell_kin, para_env) md_ener%constant = md_ener%constant + md_ener%thermostat_shell_kin + md_ener%thermostat_shell_pot END SUBROUTINE get_econs_npt @@ -460,15 +444,13 @@ END SUBROUTINE get_econs_npt !> \brief calculates conserved quantity for nph_uniaxial !> \param md_env ... !> \param md_ener ... -!> \param error ... !> \par History !> none !> \author cjm ! ***************************************************************************** - SUBROUTINE get_econs_nph_uniaxial ( md_env, md_ener, error) + SUBROUTINE get_econs_nph_uniaxial ( md_env, md_ener) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), INTENT(inout) :: md_ener - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_econs_nph_uniaxial', & routineP = moduleN//':'//routineN @@ -477,9 +459,9 @@ SUBROUTINE get_econs_nph_uniaxial ( md_env, md_ener, error) TYPE(npt_info_type), POINTER :: npt( :, : ) TYPE(simpar_type), POINTER :: simpar - CALL get_md_env ( md_env, simpar = simpar, npt = npt, cell = box, error=error ) + CALL get_md_env ( md_env, simpar = simpar, npt = npt, cell = box) - CALL get_baro_energies ( box, simpar, npt, md_ener%baro_kin, md_ener%baro_pot, error=error ) + CALL get_baro_energies ( box, simpar, npt, md_ener%baro_kin, md_ener%baro_pot) md_ener%temp_baro = 2.0_dp * md_ener%baro_kin md_ener%constant = md_ener%ekin + md_ener%epot + md_ener%baro_kin + md_ener%baro_pot END SUBROUTINE get_econs_nph_uniaxial @@ -491,17 +473,15 @@ END SUBROUTINE get_econs_nph_uniaxial !> \param tkind ... !> \param tshell ... !> \param group ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE get_part_ke ( md_env, md_ener, tkind, tshell, group, error) + SUBROUTINE get_part_ke ( md_env, md_ener, tkind, tshell, group) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), POINTER :: md_ener LOGICAL, INTENT(IN) :: tkind, tshell INTEGER, INTENT(IN) :: group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_part_ke', & routineP = moduleN//':'//routineN @@ -532,19 +512,18 @@ SUBROUTINE get_part_ke ( md_env, md_ener, tkind, tshell, group, error) failure = .FALSE. NULLIFY(force_env, qmmm_env, qmmmx_env, subsys, force_env_section) - CALL get_md_env ( md_env, force_env = force_env, error=error ) + CALL get_md_env ( md_env, force_env = force_env) CALL force_env_get(force_env,& subsys=subsys,& qmmm_env=qmmm_env,& qmmmx_env=qmmmx_env,& - force_env_section=force_env_section,& - error=error) + force_env_section=force_env_section) CALL cp_subsys_get(subsys=subsys,& atomic_kinds=atomic_kinds,& local_particles=local_particles,& particles=particles,shell_particles=shell_particles,& - core_particles=core_particles,error=error) + core_particles=core_particles) nparticle_kind = atomic_kinds%n_els atomic_kind_set => atomic_kinds%els @@ -684,8 +663,8 @@ SUBROUTINE get_part_ke ( md_env, md_ener, tkind, tshell, group, error) END IF IF(ASSOCIATED(qmmmx_env)) THEN ! doing force mixing - CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%INDICES",i_vals=cur_indices,error=error) - CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%LABELS",i_vals=cur_labels,error=error) + CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%INDICES",i_vals=cur_indices) + CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%LABELS",i_vals=cur_labels) DO i=1, SIZE(cur_indices) IF (cur_labels(i) >= force_mixing_label_QM_dynamics) THEN ! this is a QM atom iparticle = cur_indices(i) diff --git a/src/motion/md_ener_types.F b/src/motion/md_ener_types.F index 78f4f6c43b..c206004e88 100644 --- a/src/motion/md_ener_types.F +++ b/src/motion/md_ener_types.F @@ -58,15 +58,12 @@ MODULE md_ener_types ! ***************************************************************************** !> \brief retains the given md_ener structure !> \param md_ener : -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE create_md_ener(md_ener, error) + SUBROUTINE create_md_ener(md_ener) TYPE(md_ener_type), POINTER :: md_ener - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_md_ener', & routineP = moduleN//':'//routineN @@ -76,9 +73,9 @@ SUBROUTINE create_md_ener(md_ener, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(md_ener),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(md_ener),cp_failure_level,routineP,failure) ALLOCATE(md_ener,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_md_ener_id=last_md_ener_id+1 md_ener%id_nr=last_md_ener_id @@ -95,15 +92,12 @@ END SUBROUTINE create_md_ener ! ***************************************************************************** !> \brief retains the given md_ener structure !> \param md_ener : -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE retain_md_ener(md_ener, error) + SUBROUTINE retain_md_ener(md_ener) TYPE(md_ener_type), POINTER :: md_ener - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_md_ener', & routineP = moduleN//':'//routineN @@ -112,23 +106,20 @@ SUBROUTINE retain_md_ener(md_ener, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(md_ener),cp_failure_level,routineP,error,failure) - CPPrecondition(md_ener%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(md_ener),cp_failure_level,routineP,failure) + CPPrecondition(md_ener%ref_count>0,cp_failure_level,routineP,failure) md_ener%ref_count=md_ener%ref_count+1 END SUBROUTINE retain_md_ener ! ***************************************************************************** !> \brief releases the given md_ener structure !> \param md_ener : -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE release_md_ener(md_ener, error) + SUBROUTINE release_md_ener(md_ener) TYPE(md_ener_type), POINTER :: md_ener - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_md_ener', & routineP = moduleN//':'//routineN @@ -139,36 +130,36 @@ SUBROUTINE release_md_ener(md_ener, error) failure=.FALSE. IF (ASSOCIATED(md_ener)) THEN - CPPrecondition(md_ener%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(md_ener%ref_count>0,cp_failure_level,routineP,failure) md_ener%ref_count=md_ener%ref_count-1 IF (md_ener%ref_count==0) THEN IF(ASSOCIATED(md_ener%temp_kind))THEN DEALLOCATE(md_ener%temp_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(md_ener%ekin_kind))THEN DEALLOCATE(md_ener%ekin_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(md_ener%nfree_kind))THEN DEALLOCATE(md_ener%nfree_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(md_ener%temp_shell_kind))THEN DEALLOCATE(md_ener%temp_shell_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(md_ener%ekin_shell_kind))THEN DEALLOCATE(md_ener%ekin_shell_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(md_ener%nfree_shell_kind))THEN DEALLOCATE(md_ener%nfree_shell_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(md_ener,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END SUBROUTINE release_md_ener @@ -178,16 +169,13 @@ END SUBROUTINE release_md_ener !> \param md_ener : !> \param tkind ... !> \param tshell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE zero_md_ener(md_ener, tkind, tshell, error) + SUBROUTINE zero_md_ener(md_ener, tkind, tshell) TYPE(md_ener_type), POINTER :: md_ener LOGICAL, INTENT(IN) :: tkind, tshell - TYPE(cp_error_type), INTENT(inout) :: error md_ener%ekin = 0.0_dp md_ener%temp_part = 0.0_dp diff --git a/src/motion/md_energies.F b/src/motion/md_energies.F index f3cfd4091e..9c5b13d75c 100644 --- a/src/motion/md_energies.F +++ b/src/motion/md_energies.F @@ -98,17 +98,15 @@ MODULE md_energies !> \param md_ener ... !> \param force_env ... !> \param simpar ... -!> \param error ... !> \par History !> - 10-2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE initialize_md_ener(md_ener,force_env,simpar,error) + SUBROUTINE initialize_md_ener(md_ener,force_env,simpar) TYPE(md_ener_type), POINTER :: md_ener TYPE(force_env_type), POINTER :: force_env TYPE(simpar_type), POINTER :: simpar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_md_ener', & routineP = moduleN//':'//routineN @@ -126,13 +124,12 @@ SUBROUTINE initialize_md_ener(md_ener,force_env,simpar,error) NULLIFY(subsys) NULLIFY(atomic_kinds, atomic_kind_set, particles, shell_particles) - CPPrecondition(ASSOCIATED(md_ener),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(md_ener),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) - CALL force_env_get(force_env, subsys=subsys, error=error) + CALL force_env_get(force_env, subsys=subsys) CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) atomic_kind_set => atomic_kinds%els nkind = SIZE(atomic_kind_set) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & @@ -147,26 +144,26 @@ SUBROUTINE initialize_md_ener(md_ener,force_env,simpar,error) IF(simpar%temperature_per_kind) THEN ALLOCATE(md_ener%temp_kind(nkind), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(md_ener%ekin_kind(nkind), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(md_ener%nfree_kind(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) md_ener%nfree_kind = 0 IF(shell_adiabatic) THEN ALLOCATE(md_ener%temp_shell_kind(nkind), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(md_ener%ekin_shell_kind(nkind), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(md_ener%nfree_shell_kind(nkind), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) md_ener%nfree_shell_kind = 0 END IF END IF CALL zero_md_ener(md_ener, tkind=simpar%temperature_per_kind, & - tshell=shell_adiabatic, error=error) + tshell=shell_adiabatic) md_ener%epot = 0.0_dp END SUBROUTINE initialize_md_ener @@ -175,16 +172,14 @@ END SUBROUTINE initialize_md_ener !> \brief ... !> \param md_env ... !> \param md_ener ... -!> \param error ... !> \par History !> - 10-2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE md_energy(md_env, md_ener, error) + SUBROUTINE md_energy(md_env, md_ener) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), POINTER :: md_ener - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'md_energy', & routineP = moduleN//':'//routineN @@ -202,12 +197,12 @@ SUBROUTINE md_energy(md_env, md_ener, error) NULLIFY(atomic_kinds, atomic_kind_set, force_env,& particles, subsys, simpar) CALL get_md_env(md_env=md_env, force_env=force_env, & - simpar=simpar, error=error) + simpar=simpar) CALL force_env_get(force_env, & - potential_energy=md_ener%epot, subsys=subsys, error=error) + potential_energy=md_ener%epot, subsys=subsys) - CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, error=error) + CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds) atomic_kind_set => atomic_kinds%els CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & shell_adiabatic=shell_adiabatic) @@ -215,11 +210,11 @@ SUBROUTINE md_energy(md_env, md_ener, error) tkind = simpar%temperature_per_kind tshell = shell_adiabatic - CALL cp_subsys_get(subsys,particles=particles,error=error) + CALL cp_subsys_get(subsys,particles=particles) natom=particles%n_els CALL compute_conserved_quantity(md_env, md_ener, tkind=tkind,& - tshell=tshell, natom=natom, error=error) + tshell=tshell, natom=natom) END SUBROUTINE md_energy @@ -227,16 +222,13 @@ END SUBROUTINE md_energy !> \brief ... !> \param md_env ... !> \param md_ener ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - 10.2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE md_ener_reftraj(md_env,md_ener,error) + SUBROUTINE md_ener_reftraj(md_env,md_ener) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), POINTER :: md_ener - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'md_ener_reftraj', & routineP = moduleN//':'//routineN @@ -244,11 +236,11 @@ SUBROUTINE md_ener_reftraj(md_env,md_ener,error) TYPE(force_env_type), POINTER :: force_env TYPE(reftraj_type), POINTER :: reftraj - CALL zero_md_ener(md_ener, tkind=.FALSE., tshell=.FALSE., error=error) - CALL get_md_env(md_env=md_env, force_env=force_env, reftraj=reftraj, error=error) + CALL zero_md_ener(md_ener, tkind=.FALSE., tshell=.FALSE.) + CALL get_md_env(md_env=md_env, force_env=force_env, reftraj=reftraj) IF(reftraj%info%eval_ef) THEN - CALL force_env_get(force_env, potential_energy=md_ener%epot, error=error) + CALL force_env_get(force_env, potential_energy=md_ener%epot) ELSE md_ener%epot = reftraj%epot md_ener%delta_epot = (reftraj%epot - reftraj%epot0)/REAL(reftraj%natom, kind=dp)*kelvin @@ -260,17 +252,15 @@ END SUBROUTINE md_ener_reftraj !> \brief This routine computes the conserved quantity, temperature !> and things like that and prints them out !> \param md_env ... -!> \param error ... !> \par History !> - New MD data are appended to the old data (15.09.2003,MK) !> - 02.2008 - Teodoro Laino [tlaino] - University of Zurich !> Cleaning code and collecting the many commons routines.. !> \author CJM ! ***************************************************************************** - SUBROUTINE md_write_output(md_env, error) + SUBROUTINE md_write_output(md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'md_write_output', & routineP = moduleN//':'//routineN @@ -312,7 +302,7 @@ SUBROUTINE md_write_output(md_env, error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) ! Zeroing @@ -328,17 +318,17 @@ SUBROUTINE md_write_output(md_env, error) CALL get_md_env(md_env=md_env, itimes=itimes, t=time, used_time=used_time,& simpar=simpar, force_env=force_env, init=init, md_ener=md_ener,& reftraj=reftraj, thermostats=thermostats, barostat=barostat, & - para_env=para_env, averages=averages, thermal_regions=thermal_regions, error=error) + para_env=para_env, averages=averages, thermal_regions=thermal_regions) root_section => force_env%root_section - motion_section => section_vals_get_subs_vals(root_section,"MOTION",error=error) + motion_section => section_vals_get_subs_vals(root_section,"MOTION") - CALL force_env_get(force_env,cell=cell,subsys=subsys,qmmm_env=qmmm_env,error=error) + CALL force_env_get(force_env,cell=cell,subsys=subsys,qmmm_env=qmmm_env) - qmmm = calc_nfree_qm(md_env, md_ener, error) > 0 + qmmm = calc_nfree_qm(md_env, md_ener) > 0 is_mixed = (force_env%in_use == use_mixed_force) - CALL cp_subsys_get(subsys,particles=particles, virial=virial, error=error) + CALL cp_subsys_get(subsys,particles=particles, virial=virial) nat = particles%n_els dt = simpar%dt*simpar%dt_fact @@ -349,12 +339,12 @@ SUBROUTINE md_write_output(md_env, error) pv_scalar = pv_scalar + virial%pv_total(i,i) END DO pv_scalar = pv_scalar/3._dp/cell%deth - pv_scalar = cp_unit_from_cp2k(pv_scalar,"bar",error=error) + pv_scalar = cp_unit_from_cp2k(pv_scalar,"bar") pv_xx_nc = virial%pv_total(1,1)/cell%deth - pv_xx = cp_unit_from_cp2k(virial%pv_total(1,1)/cell%deth,"bar",error=error) + pv_xx = cp_unit_from_cp2k(virial%pv_total(1,1)/cell%deth,"bar") ENDIF - CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, error=error) + CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds) atomic_kind_set => atomic_kinds%els CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & shell_present=shell_present, & @@ -407,20 +397,19 @@ SUBROUTINE md_write_output(md_env, error) ! Compute average quantities CALL compute_averages(averages, force_env, md_ener, cell, virial, pv_scalar,& pv_xx, used_time, hugoniot, abc, cell_angle, nat, itimes, time, my_pos,& - my_act, error) + my_act) END IF ! Print md information CALL md_write_info_low(simpar, md_ener, qmmm, virial, reftraj, cell, abc,& cell_angle, itimes, dt, time, used_time, averages, econs, pv_scalar, pv_xx,& - hugoniot, nat, init, logger, motion_section, my_pos, my_act, error) + hugoniot, nat, init, logger, motion_section, my_pos, my_act) ! Real Ouput driven by the PRINT sections IF ((.NOT.init).OR.(itimes==0).OR.simpar%ensemble==reftraj_ensemble) THEN ! Print Energy ene = cp_print_key_unit_nr(logger,motion_section,"MD%PRINT%ENERGY",& - extension=".ener",file_position=my_pos, file_action=my_act, is_new_file=new_file,& - error=error) + extension=".ener",file_position=my_pos, file_action=my_act, is_new_file=new_file) IF (ene>0) THEN IF (new_file) THEN ! Please change also the corresponding format explaination below @@ -432,68 +421,68 @@ SUBROUTINE md_write_output(md_env, error) itimes,time*femtoseconds,md_ener%ekin,md_ener%temp_part, md_ener%epot,md_ener%constant,used_time CALL m_flush(ene) END IF - CALL cp_print_key_finished_output(ene,logger,motion_section,"MD%PRINT%ENERGY", error=error) + CALL cp_print_key_finished_output(ene,logger,motion_section,"MD%PRINT%ENERGY") ! Possibly Print MIXED Energy IF (is_mixed) THEN ener_mix=cp_print_key_unit_nr(logger,motion_section,"PRINT%MIXED_ENERGIES",& extension=".ener", file_position=my_pos, file_action=my_act,& - middle_name="mix", error=error) + middle_name="mix") IF (ener_mix>0) THEN WRITE (ener_mix,"(I8,F12.3,F20.9,"//cp_to_string(SIZE(force_env%mixed_env%energies))//"F20.9,F20.9)")& itimes,time*femtoseconds,md_ener%epot,force_env%mixed_env%energies,md_ener%constant CALL m_flush(ener_mix) END IF - CALL cp_print_key_finished_output(ener_mix,logger,motion_section,"PRINT%MIXED_ENERGIES", error=error) + CALL cp_print_key_finished_output(ener_mix,logger,motion_section,"PRINT%MIXED_ENERGIES") ENDIF ! Print QMMM translation vector if requested IF (qmmm) THEN trsl = cp_print_key_unit_nr(logger,motion_section,"PRINT%TRANSLATION_VECTOR",& - extension=".translation", middle_name="qmmm", error=error) + extension=".translation", middle_name="qmmm") IF (trsl>0) THEN WRITE(trsl,'(I10,3F15.10)')itimes,qmmm_env%qm%transl_v END IF CALL cp_print_key_finished_output(trsl,logger,motion_section,& - "PRINT%TRANSLATION_VECTOR", error=error) + "PRINT%TRANSLATION_VECTOR") END IF ! Write Structure data - CALL write_structure_data(particles%els,cell,motion_section,error) + CALL write_structure_data(particles%els,cell,motion_section) ! Print Coordinates CALL write_trajectory(force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - pos=my_pos, act=my_act, extended_xmol_title=.TRUE., error=error) + pos=my_pos, act=my_act, extended_xmol_title=.TRUE.) ! Print Velocities CALL write_trajectory(force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "VELOCITIES", my_pos, my_act, middle_name="vel", extended_xmol_title=.TRUE., error=error) + "VELOCITIES", my_pos, my_act, middle_name="vel", extended_xmol_title=.TRUE.) ! Print Force CALL write_trajectory(force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "FORCES", my_pos, my_act, middle_name="frc", extended_xmol_title=.TRUE., error=error) + "FORCES", my_pos, my_act, middle_name="frc", extended_xmol_title=.TRUE.) ! Print Force-Mixing labels CALL write_trajectory(force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "FORCE_MIXING_LABELS", my_pos, my_act, middle_name="fmlabels", extended_xmol_title=.TRUE., error=error) + "FORCE_MIXING_LABELS", my_pos, my_act, middle_name="fmlabels", extended_xmol_title=.TRUE.) ! Print Simulation Cell - CALL write_simulation_cell(cell, motion_section, itimes, time*femtoseconds, my_pos, my_act, error) + CALL write_simulation_cell(cell, motion_section, itimes, time*femtoseconds, my_pos, my_act) ! Print Thermostats status - CALL print_thermostats_status(thermostats, para_env, my_pos, my_act, itimes, time, error) + CALL print_thermostats_status(thermostats, para_env, my_pos, my_act, itimes, time) ! Print Barostat status - CALL print_barostat_status(barostat, simpar, my_pos, my_act, cell, itimes, time, error) + CALL print_barostat_status(barostat, simpar, my_pos, my_act, cell, itimes, time) ! Print Stress Tensor CALL write_stress_tensor(virial, cell, motion_section, itimes, time*femtoseconds,& - my_pos, my_act, error) + my_pos, my_act) ! Temperature per Kinds IF(simpar%temperature_per_kind) THEN tempkind=cp_print_key_unit_nr(logger,motion_section,"MD%PRINT%TEMP_KIND",& - extension=".temp",file_position=my_pos, file_action=my_act,error=error) + extension=".temp",file_position=my_pos, file_action=my_act) IF( tempkind > 0 ) THEN nkind = SIZE(md_ener%temp_kind) fmd="(I10,F20.3,"//TRIM(ADJUSTL(cp_to_string(nkind)))//"F20.9)" @@ -501,10 +490,10 @@ SUBROUTINE md_write_output(md_env, error) WRITE (tempkind,fmd)itimes,time*femtoseconds, md_ener%temp_kind(1:nkind) CALL m_flush(tempkind) END IF - CALL cp_print_key_finished_output(tempkind,logger,motion_section,"MD%PRINT%TEMP_KIND", error=error) + CALL cp_print_key_finished_output(tempkind,logger,motion_section,"MD%PRINT%TEMP_KIND") ELSE - print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%TEMP_KIND",error=error) - CALL cp_assert(.NOT.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file),& + print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%TEMP_KIND") + CALL cp_assert(.NOT.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file),& cp_warning_level,cp_assertion_failed,routineP,& "The print_key MD%PRINT%TEMP_KIND has been activated but the "//& "calculation of the temperature per kind has not been requested. "//& @@ -513,17 +502,17 @@ SUBROUTINE md_write_output(md_env, error) only_ionode=.TRUE.) END IF !Thermal Region - CALL print_thermal_regions_temperature(thermal_regions,itimes,time*femtoseconds,my_pos,my_act,error) + CALL print_thermal_regions_temperature(thermal_regions,itimes,time*femtoseconds,my_pos,my_act) ! Core/Shell Model IF(shell_present) THEN - CALL force_env_get(force_env, harmonic_shell=harm_shell, error=error) - CALL cp_subsys_get(subsys, shell_particles=shell_particles, core_particles=core_particles, error=error) + CALL force_env_get(force_env, harmonic_shell=harm_shell) + CALL cp_subsys_get(subsys, shell_particles=shell_particles, core_particles=core_particles) ! Print Shell Energy shene=cp_print_key_unit_nr(logger,motion_section,"MD%PRINT%SHELL_ENERGY",& extension=".shener",file_position=my_pos, file_action=my_act, & - file_form="FORMATTED", is_new_file=new_file,error=error) + file_form="FORMATTED", is_new_file=new_file) IF (shene>0) THEN IF(new_file) THEN WRITE (shene,'("#",3X,A,3X,A,3X,3(5X,A,5X))')"Step Nr.","Time[fs]","Kin.[a.u.]",& @@ -534,37 +523,37 @@ SUBROUTINE md_write_output(md_env, error) itimes,time*femtoseconds,md_ener%ekin_shell,md_ener%temp_shell,harm_shell CALL m_flush(shene) END IF - CALL cp_print_key_finished_output(shene,logger,motion_section,"MD%PRINT%SHELL_ENERGY", error=error) + CALL cp_print_key_finished_output(shene,logger,motion_section,"MD%PRINT%SHELL_ENERGY") ! Print Shell Coordinates CALL write_trajectory (force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "SHELL_TRAJECTORY", my_pos, my_act, "shpos", shell_particles, extended_xmol_title=.TRUE., error=error) + "SHELL_TRAJECTORY", my_pos, my_act, "shpos", shell_particles, extended_xmol_title=.TRUE.) IF(shell_adiabatic) THEN ! Print Shell Velocities CALL write_trajectory (force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "SHELL_VELOCITIES", my_pos, my_act, "shvel", shell_particles, extended_xmol_title=.TRUE., error=error) + "SHELL_VELOCITIES", my_pos, my_act, "shvel", shell_particles, extended_xmol_title=.TRUE.) ! Print Shell Forces CALL write_trajectory (force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "SHELL_FORCES", my_pos, my_act, "shfrc", shell_particles, extended_xmol_title=.TRUE., error=error) + "SHELL_FORCES", my_pos, my_act, "shfrc", shell_particles, extended_xmol_title=.TRUE.) ! Print Core Coordinates CALL write_trajectory (force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "CORE_TRAJECTORY", my_pos, my_act, "copos", core_particles, extended_xmol_title=.TRUE., error=error) + "CORE_TRAJECTORY", my_pos, my_act, "copos", core_particles, extended_xmol_title=.TRUE.) ! Print Core Velocities CALL write_trajectory (force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "CORE_VELOCITIES", my_pos, my_act, "covel", core_particles, extended_xmol_title=.TRUE., error=error) + "CORE_VELOCITIES", my_pos, my_act, "covel", core_particles, extended_xmol_title=.TRUE.) ! Print Core Forces CALL write_trajectory (force_env, root_section, itimes, time*femtoseconds, dt*femtoseconds, md_ener%epot,& - "CORE_FORCES", my_pos, my_act, "cofrc", core_particles, extended_xmol_title=.TRUE., error=error) + "CORE_FORCES", my_pos, my_act, "cofrc", core_particles, extended_xmol_title=.TRUE.) ! Temperature per Kinds IF(simpar%temperature_per_kind) THEN tempkind=cp_print_key_unit_nr(logger,motion_section,"MD%PRINT%TEMP_SHELL_KIND",& - extension=".shtemp", file_position=my_pos, file_action=my_act,error=error) + extension=".shtemp", file_position=my_pos, file_action=my_act) IF( tempkind > 0 ) THEN nkind = SIZE(md_ener%temp_shell_kind) fmd="(I10,F20.3,"//TRIM(ADJUSTL(cp_to_string(nkind)))//"F20.9)" @@ -573,10 +562,10 @@ SUBROUTINE md_write_output(md_env, error) CALL m_flush(tempkind) END IF CALL cp_print_key_finished_output(tempkind, logger, motion_section,& - "MD%PRINT%TEMP_SHELL_KIND", error=error) + "MD%PRINT%TEMP_SHELL_KIND") ELSE - print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%TEMP_SHELL_KIND",error=error) - CALL cp_assert(.NOT.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file),& + print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%TEMP_SHELL_KIND") + CALL cp_assert(.NOT.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file),& cp_warning_level,cp_assertion_failed,routineP,& "The print_key MD%PRINT%TEMP_SHELL_KIND has been activated but the "//& "calculation of the temperature per kind has not been requested. "//& @@ -588,7 +577,7 @@ SUBROUTINE md_write_output(md_env, error) END IF END IF init = .FALSE. - CALL set_md_env(md_env,init=init,error=error) + CALL set_md_env(md_env,init=init) CALL timestop(handle) END SUBROUTINE md_write_output @@ -617,7 +606,6 @@ END SUBROUTINE md_write_output !> \param motion_section ... !> \param my_pos ... !> \param my_act ... -!> \param error ... !> \par History !> - 10.2008 - Teodoro Laino [tlaino] - University of Zurich !> Refactoring: split into an independent routine. @@ -626,7 +614,7 @@ END SUBROUTINE md_write_output ! ***************************************************************************** SUBROUTINE md_write_info_low(simpar, md_ener, qmmm, virial, reftraj, cell,& abc, cell_angle, itimes, dt, time, used_time, averages, econs, pv_scalar, & - pv_xx, hugoniot, nat, init, logger, motion_section, my_pos, my_act, error) + pv_xx, hugoniot, nat, init, logger, motion_section, my_pos, my_act) TYPE(simpar_type), POINTER :: simpar TYPE(md_ener_type), POINTER :: md_ener @@ -647,7 +635,6 @@ SUBROUTINE md_write_info_low(simpar, md_ener, qmmm, virial, reftraj, cell,& TYPE(section_vals_type), POINTER :: motion_section CHARACTER(LEN=default_string_length), & INTENT(IN) :: my_pos, my_act - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'md_write_info_low', & routineP = moduleN//':'//routineN @@ -662,13 +649,13 @@ SUBROUTINE md_write_info_low(simpar, md_ener, qmmm, virial, reftraj, cell,& NULLIFY(enum, keyword, section) ! Print to the screen info about MD iw = cp_print_key_unit_nr(logger,motion_section,"MD%PRINT%PROGRAM_RUN_INFO",& - extension=".mdLog",file_position=my_pos,file_action=my_act,error=error) + extension=".mdLog",file_position=my_pos,file_action=my_act) ! Performing protocol relevant to the first step of an MD run IF (iw>0) THEN - CALL create_md_section(section,error=error) - keyword => section_get_keyword(section,"ENSEMBLE",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + CALL create_md_section(section) + keyword => section_get_keyword(section,"ENSEMBLE") + CALL keyword_get(keyword,enum=enum) IF (init) THEN ! Write initial values of quantities of interest @@ -729,7 +716,7 @@ SUBROUTINE md_write_info_low(simpar, md_ener, qmmm, virial, reftraj, cell,& ! Write seuquential values of quantities of interest WRITE (iw,'(/,T2,A)') REPEAT('*',79) WRITE (iw,'(T2,A,T61,A20)')& - 'ENSEMBLE TYPE = ',ADJUSTR(TRIM(enum_i2c(enum,simpar%ensemble,error=error))) + 'ENSEMBLE TYPE = ',ADJUSTR(TRIM(enum_i2c(enum,simpar%ensemble))) WRITE (iw,'(T2,A,T71,I10)')& 'STEP NUMBER = ', itimes IF (simpar%variable_dt) THEN @@ -810,9 +797,9 @@ SUBROUTINE md_write_info_low(simpar, md_ener, qmmm, virial, reftraj, cell,& WRITE (iw,'(T2,A,/)') REPEAT('*',79) END IF END IF - CALL section_release(section, error) + CALL section_release(section) CALL cp_print_key_finished_output(iw,logger,motion_section,& - "MD%PRINT%PROGRAM_RUN_INFO", error=error) + "MD%PRINT%PROGRAM_RUN_INFO") END SUBROUTINE md_write_info_low END MODULE md_energies diff --git a/src/motion/md_environment_types.F b/src/motion/md_environment_types.F index 70a48768f4..3f14facb78 100644 --- a/src/motion/md_environment_types.F +++ b/src/motion/md_environment_types.F @@ -97,15 +97,12 @@ MODULE md_environment_types !> \param md_section ... !> \param para_env ... !> \param force_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE md_env_create(md_env, md_section, para_env, force_env, error) + SUBROUTINE md_env_create(md_env, md_section, para_env, force_env) TYPE(md_environment_type), POINTER :: md_env TYPE(section_vals_type), POINTER :: md_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'md_env_create', & routineP = moduleN//':'//routineN @@ -116,7 +113,7 @@ SUBROUTINE md_env_create(md_env, md_section, para_env, force_env, error) failure = .FALSE. ALLOCATE(md_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_md_env_id=last_md_env_id+1 md_env%id_nr=last_md_env_id md_env%ref_count=1 @@ -135,15 +132,15 @@ SUBROUTINE md_env_create(md_env, md_section, para_env, force_env, error) NULLIFY(md_env%averages) NULLIFY(md_env%thermal_regions) md_env%para_env => para_env - CALL cp_para_env_retain(md_env%para_env, error=error) + CALL cp_para_env_retain(md_env%para_env) ALLOCATE( md_env%itimes, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( md_env%constant, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( md_env%used_time, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( md_env%t, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) md_env%itimes = -1 md_env%constant = 0.0_dp md_env%used_time = 0.0_dp @@ -151,25 +148,22 @@ SUBROUTINE md_env_create(md_env, md_section, para_env, force_env, error) md_env%init = .TRUE. md_env%first_time = .TRUE. md_env%ehrenfest_md = .FALSE. - averages_section => section_vals_get_subs_vals(md_section,"AVERAGES",error=error) - CALL create_averages(md_env%averages, averages_section, force_env=force_env, error=error) + averages_section => section_vals_get_subs_vals(md_section,"AVERAGES") + CALL create_averages(md_env%averages, averages_section, force_env=force_env) END SUBROUTINE md_env_create ! ***************************************************************************** !> \brief retains the given md env !> \param md_env the force environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE md_env_retain(md_env, error) + SUBROUTINE md_env_retain(md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'md_env_retain', & routineP = moduleN//':'//routineN @@ -178,25 +172,22 @@ SUBROUTINE md_env_retain(md_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(md_env),cp_failure_level,routineP,error,failure) - CPPrecondition(md_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(md_env),cp_failure_level,routineP,failure) + CPPrecondition(md_env%ref_count>0,cp_failure_level,routineP,failure) md_env%ref_count=md_env%ref_count+1 END SUBROUTINE md_env_retain ! ***************************************************************************** !> \brief releases the given md env !> \param md_env the md environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE md_env_release(md_env, error) + SUBROUTINE md_env_release(md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'md_env_release', & routineP = moduleN//':'//routineN @@ -207,31 +198,31 @@ SUBROUTINE md_env_release(md_env, error) failure=.FALSE. IF (ASSOCIATED(md_env)) THEN - CPPrecondition(md_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(md_env%ref_count>0,cp_failure_level,routineP,failure) md_env%ref_count=md_env%ref_count-1 IF (md_env%ref_count==0) THEN - CALL fe_env_release( md_env%fe_env, error=error) - CALL cp_para_env_release(md_env%para_env, error = error) + CALL fe_env_release( md_env%fe_env) + CALL cp_para_env_release(md_env%para_env) DEALLOCATE( md_env%itimes , stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE( md_env%constant , stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE( md_env%used_time , stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE( md_env%t , stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(md_env%cell) NULLIFY(md_env%simpar) - CALL release_barostat_type(md_env%barostat, error) - CALL release_thermostats(md_env%thermostats, error) - CALL release_reftraj(md_env%reftraj, error) - CALL release_md_ener(md_env%md_ener, error) - CALL force_env_release(md_env%force_env, error=error) - CALL release_averages(md_env%averages, error) - CALL release_thermal_regions(md_env%thermal_regions, error) + CALL release_barostat_type(md_env%barostat) + CALL release_thermostats(md_env%thermostats) + CALL release_reftraj(md_env%reftraj) + CALL release_md_ener(md_env%md_ener) + CALL force_env_release(md_env%force_env) + CALL release_averages(md_env%averages) + CALL release_thermal_regions(md_env%thermal_regions) DEALLOCATE(md_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END SUBROUTINE md_env_release @@ -264,14 +255,12 @@ END SUBROUTINE md_env_release !> \param averages ... !> \param thermal_regions ... !> \param ehrenfest_md ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE get_md_env(md_env, itimes, constant, used_time, cell, simpar, npt,& force_env, para_env, reftraj, t, init, first_time,fe_env, thermostats, barostat, & thermostat_coeff, thermostat_part, thermostat_shell, thermostat_baro,& thermostat_fast, thermostat_slow, md_ener, averages, & - thermal_regions,ehrenfest_md, error) + thermal_regions,ehrenfest_md) TYPE(md_environment_type), POINTER :: md_env INTEGER, OPTIONAL, POINTER :: itimes @@ -299,7 +288,6 @@ SUBROUTINE get_md_env(md_env, itimes, constant, used_time, cell, simpar, npt,& TYPE(thermal_regions_type), OPTIONAL, & POINTER :: thermal_regions LOGICAL, OPTIONAL :: ehrenfest_md - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_md_env', & routineP = moduleN//':'//routineN @@ -308,7 +296,7 @@ SUBROUTINE get_md_env(md_env, itimes, constant, used_time, cell, simpar, npt,& failure = .FALSE. check = ASSOCIATED(md_env) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) IF (PRESENT(itimes)) itimes => md_env%itimes IF (PRESENT(fe_env)) fe_env => md_env%fe_env IF (PRESENT(constant)) constant => md_env%constant @@ -378,12 +366,10 @@ END SUBROUTINE get_md_env !> \param averages ... !> \param thermal_regions ... !> \param ehrenfest_md ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE set_md_env(md_env, itimes, constant, cell, simpar, fe_env, force_env,& para_env, init, first_time,thermostats, barostat, reftraj, md_ener, averages,& - thermal_regions,ehrenfest_md, error) + thermal_regions,ehrenfest_md) TYPE(md_environment_type), POINTER :: md_env INTEGER, OPTIONAL, POINTER :: itimes @@ -406,7 +392,6 @@ SUBROUTINE set_md_env(md_env, itimes, constant, cell, simpar, fe_env, force_env, TYPE(thermal_regions_type), OPTIONAL, & POINTER :: thermal_regions LOGICAL, OPTIONAL :: ehrenfest_md - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_md_env', & routineP = moduleN//':'//routineN @@ -415,19 +400,19 @@ SUBROUTINE set_md_env(md_env, itimes, constant, cell, simpar, fe_env, force_env, failure = .FALSE. check = ASSOCIATED(md_env) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) IF(PRESENT (init)) md_env%init = init IF(PRESENT (first_time)) md_env%first_time = first_time IF (PRESENT(ehrenfest_md)) md_env%ehrenfest_md=ehrenfest_md IF(PRESENT(cell)) md_env%cell => cell IF(PRESENT(barostat)) THEN - CALL release_barostat_type(md_env%barostat, error=error) - CALL retain_barostat_type(barostat, error=error) + CALL release_barostat_type(md_env%barostat) + CALL retain_barostat_type(barostat) md_env%barostat => barostat END IF IF(PRESENT(thermostats)) THEN - CALL release_thermostats(md_env%thermostats, error=error) - CALL retain_thermostats(thermostats, error=error) + CALL release_thermostats(md_env%thermostats) + CALL retain_thermostats(thermostats) md_env%thermostats => thermostats END IF IF(PRESENT(simpar)) md_env%simpar => simpar @@ -437,31 +422,31 @@ SUBROUTINE set_md_env(md_env, itimes, constant, cell, simpar, fe_env, force_env, IF(PRESENT(para_env)) md_env%para_env => para_env IF(PRESENT(force_env)) THEN IF (ASSOCIATED(force_env)) THEN - CALL force_env_retain (force_env, error=error) + CALL force_env_retain (force_env) END IF IF (ASSOCIATED(md_env%force_env)) THEN - CALL force_env_release (md_env%force_env, error=error) + CALL force_env_release (md_env%force_env) END IF md_env%force_env => force_env END IF IF(PRESENT(reftraj)) THEN - CALL release_reftraj(md_env%reftraj, error=error) - CALL retain_reftraj(reftraj, error=error) + CALL release_reftraj(md_env%reftraj) + CALL retain_reftraj(reftraj) md_env%reftraj => reftraj END IF IF(PRESENT(md_ener)) THEN - CALL release_md_ener(md_env%md_ener, error=error) - CALL retain_md_ener(md_ener, error=error) + CALL release_md_ener(md_env%md_ener) + CALL retain_md_ener(md_ener) md_env%md_ener => md_ener END IF IF (PRESENT(averages)) THEN - CALL release_averages(md_env%averages, error=error) - CALL retain_averages(averages, error=error) + CALL release_averages(md_env%averages) + CALL retain_averages(averages) md_env%averages => averages END IF IF(PRESENT(thermal_regions)) THEN - CALL release_thermal_regions(md_env%thermal_regions, error=error) - CALL retain_thermal_regions(thermal_regions, error=error) + CALL release_thermal_regions(md_env%thermal_regions) + CALL retain_thermal_regions(thermal_regions) md_env%thermal_regions => thermal_regions END IF @@ -470,16 +455,13 @@ END SUBROUTINE set_md_env ! ***************************************************************************** !> \brief ... !> \param md_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval need_per_atom_wiener_process ... !> \par History !> 02.2012 created [noamb] !> \author Noam Bernstein ! ***************************************************************************** - FUNCTION need_per_atom_wiener_process(md_env, error) + FUNCTION need_per_atom_wiener_process(md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(INOUT) :: error LOGICAL :: need_per_atom_wiener_process ! return value diff --git a/src/motion/md_run.F b/src/motion/md_run.F index 59572b3a63..a713dfaf68 100644 --- a/src/motion/md_run.F +++ b/src/motion/md_run.F @@ -120,10 +120,8 @@ MODULE md_run !> \param hmc_e_initial ... !> \param hmc_e_final ... !> \param mdctrl ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_mol_dyn ( force_env, globenv, averages, rm_restart_info, hmc_e_initial, hmc_e_final, mdctrl, error ) + SUBROUTINE qs_mol_dyn ( force_env, globenv, averages, rm_restart_info, hmc_e_initial, hmc_e_final, mdctrl) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv @@ -132,7 +130,6 @@ SUBROUTINE qs_mol_dyn ( force_env, globenv, averages, rm_restart_info, hmc_e_ini LOGICAL, INTENT(IN), OPTIONAL :: rm_restart_info REAL(KIND=dp), OPTIONAL :: hmc_e_initial, hmc_e_final TYPE(mdctrl_type), OPTIONAL, POINTER :: mdctrl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_mol_dyn', & routineP = moduleN//':'//routineN @@ -147,22 +144,22 @@ SUBROUTINE qs_mol_dyn ( force_env, globenv, averages, rm_restart_info, hmc_e_ini IF (PRESENT(rm_restart_info)) my_rm_restart_info = rm_restart_info NULLIFY(md_env, para_env) para_env => force_env%para_env - motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION",error=error) - md_section => section_vals_get_subs_vals(motion_section,"MD",error=error) + motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION") + md_section => section_vals_get_subs_vals(motion_section,"MD") ! Real call to MD driver - Low Level - CALL md_env_create(md_env, md_section, para_env, force_env=force_env, error=error) - CALL set_md_env(md_env, averages=averages, error=error) + CALL md_env_create(md_env, md_section, para_env, force_env=force_env) + CALL set_md_env(md_env, averages=averages) IF(PRESENT(hmc_e_initial).AND.PRESENT(hmc_e_final))THEN CALL qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv, & - hmc_e_initial=hmc_e_initial,hmc_e_final=hmc_e_final, error=error) + hmc_e_initial=hmc_e_initial,hmc_e_final=hmc_e_final) ELSE - CALL qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv, mdctrl=mdctrl, error=error) + CALL qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv, mdctrl=mdctrl) ENDIF - CALL md_env_release(md_env, error=error) + CALL md_env_release(md_env) ! Clean restartable sections.. - IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section,error=error) + IF (my_rm_restart_info) CALL remove_restart_info(force_env%root_section) END SUBROUTINE qs_mol_dyn ! ***************************************************************************** @@ -175,14 +172,12 @@ END SUBROUTINE qs_mol_dyn !> \param hmc_e_initial ... !> \param hmc_e_final ... !> \param mdctrl ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - Cleaning (09.2007) Teodoro Laino [tlaino] - University of Zurich !> - Added lines to print out langevin regions (2014/02/04, LT) !> \author Creation (07.11.2002,MK) ! ***************************************************************************** - SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv, hmc_e_initial,hmc_e_final, mdctrl, error) + SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv, hmc_e_initial,hmc_e_final, mdctrl) TYPE(md_environment_type), POINTER :: md_env TYPE(section_vals_type), POINTER :: md_section, motion_section @@ -190,7 +185,6 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv TYPE(global_environment_type), POINTER :: globenv REAL(KIND=dp), OPTIONAL :: hmc_e_initial, hmc_e_final TYPE(mdctrl_type), OPTIONAL, POINTER :: mdctrl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_mol_dyn_low', & routineP = moduleN//':'//routineN @@ -225,8 +219,8 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv TYPE(virial_type), POINTER :: virial CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) failure=.FALSE. NULLIFY (particles, cell, simpar, itimes, used_time, subsys, & @@ -234,75 +228,75 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv reftraj_section, work_section, atomic_kinds, & local_particles, time, fe_env, free_energy_section, & constraint_section, thermal_regions, virial, subsys_i) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() para_env => force_env%para_env - global_section => section_vals_get_subs_vals(force_env%root_section,"GLOBAL",error=error) - free_energy_section =>section_vals_get_subs_vals(motion_section,"FREE_ENERGY",error=error) - constraint_section =>section_vals_get_subs_vals(motion_section,"CONSTRAINT",error=error) - CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem,error=error) + global_section => section_vals_get_subs_vals(force_env%root_section,"GLOBAL") + free_energy_section =>section_vals_get_subs_vals(motion_section,"FREE_ENERGY") + constraint_section =>section_vals_get_subs_vals(motion_section,"CONSTRAINT") + CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem) - CALL section_vals_val_get(global_section,"RUN_TYPE", i_val=run_type_id,error=error) - IF(run_type_id==ehrenfest) CALL set_md_env(md_env, ehrenfest_md=.TRUE., error=error) + CALL section_vals_val_get(global_section,"RUN_TYPE", i_val=run_type_id) + IF(run_type_id==ehrenfest) CALL set_md_env(md_env, ehrenfest_md=.TRUE.) - CALL create_simpar_type(simpar, error) + CALL create_simpar_type(simpar) force_env_section => force_env%force_env_section - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) - CALL cp_add_iter_level(logger%iter_info,"MD",error=error) - CALL cp_iterate(logger%iter_info,iter_nr=0,error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") + CALL cp_add_iter_level(logger%iter_info,"MD") + CALL cp_iterate(logger%iter_info,iter_nr=0) ! Read MD section - CALL read_md_section(simpar, motion_section, md_section, error) + CALL read_md_section(simpar, motion_section, md_section) ! Setup print_keys simpar%info_constraint = cp_print_key_unit_nr(logger,constraint_section,& - "CONSTRAINT_INFO",extension=".shakeLog",log_filename=.FALSE.,error=error) + "CONSTRAINT_INFO",extension=".shakeLog",log_filename=.FALSE.) simpar%lagrange_multipliers = cp_print_key_unit_nr(logger,constraint_section,& - "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.,error=error) + "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.) simpar%dump_lm = BTEST(cp_print_key_should_output(logger%iter_info,constraint_section,& - "LAGRANGE_MULTIPLIERS",error=error),cp_p_file) + "LAGRANGE_MULTIPLIERS"),cp_p_file) ! Create the structure for the md energies - CALL create_md_ener(md_ener, error=error) - CALL set_md_env(md_env, md_ener=md_ener, error=error) - CALL release_md_ener(md_ener, error=error) + CALL create_md_ener(md_ener) + CALL set_md_env(md_env, md_ener=md_ener) + CALL release_md_ener(md_ener) ! If requested setup Thermostats CALL create_thermostats(thermostats, md_section, force_env, simpar, para_env,& - globenv, global_section, error ) + globenv, global_section) ! If requested setup Barostat - CALL create_barostat_type(barostat, md_section, force_env, simpar, globenv, error ) + CALL create_barostat_type(barostat, md_section, force_env, simpar, globenv) ! If requested setup different thermal regions - CALL create_thermal_regions(thermal_regions, md_section, simpar, force_env, error ) + CALL create_thermal_regions(thermal_regions, md_section, simpar, force_env) ! If doing langevin_ensemble, then print out langevin_regions information upon request IF (simpar%ensemble == langevin_ensemble) THEN my_pos = "REWIND" my_act = "WRITE" CALL print_thermal_regions_langevin(thermal_regions, simpar, & - pos=my_pos, act=my_act, error=error) + pos=my_pos, act=my_act) END IF - CALL set_md_env(md_env, thermostats=thermostats, barostat=barostat, thermal_regions=thermal_regions,error=error) + CALL set_md_env(md_env, thermostats=thermostats, barostat=barostat, thermal_regions=thermal_regions) - CALL get_md_env(md_env, ehrenfest_md=ehrenfest_md, error=error) + CALL get_md_env(md_env, ehrenfest_md=ehrenfest_md) !If requested set up the REFTRAJ run IF(simpar%ensemble == reftraj_ensemble .AND. ehrenfest_md)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Ehrenfest MD does not support reftraj ensemble "//& CPSourceFileRef,& - error,failure) + failure) IF(simpar%ensemble == reftraj_ensemble) THEN - reftraj_section => section_vals_get_subs_vals(md_section,"REFTRAJ",error=error) - CALL create_reftraj(reftraj, reftraj_section, para_env, error=error) - CALL set_md_env(md_env, reftraj=reftraj, error=error) - CALL release_reftraj(reftraj,error=error) + reftraj_section => section_vals_get_subs_vals(md_section,"REFTRAJ") + CALL create_reftraj(reftraj, reftraj_section, para_env) + CALL set_md_env(md_env, reftraj=reftraj) + CALL release_reftraj(reftraj) END IF CALL force_env_get(force_env, subsys=subsys, cell=cell, & - force_env_section=force_env_section, error=error ) - CALL cp_subsys_get(subsys,virial=virial,error=error) + force_env_section=force_env_section) + CALL cp_subsys_get(subsys,virial=virial) ! Set V0 if needed IF (simpar%ensemble == nph_uniaxial_ensemble.OR.simpar%ensemble == nph_uniaxial_damped_ensemble) THEN @@ -311,31 +305,31 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv ! Initialize velocities possibly applying constraints at the zeroth MD step CALL section_vals_val_get(motion_section,"PRINT%RESTART%SPLIT_RESTART_FILE",& - l_val=write_binary_restart_file,error=error) + l_val=write_binary_restart_file) CALL setup_velocities(force_env,simpar,globenv,md_env,md_section,constraint_section, & - write_binary_restart_file,error) + write_binary_restart_file) ! Setup Free Energy Calculation (if required) - CALL fe_env_create (fe_env, free_energy_section, error) + CALL fe_env_create (fe_env, free_energy_section) CALL set_md_env(md_env=md_env, simpar=simpar, fe_env=fe_env, cell=cell,& - force_env=force_env, error=error) + force_env=force_env) ! Possibly initialize Wiener processes ![NB] Tested again within create_wiener_process. Why?? - IF (need_per_atom_wiener_process(md_env, error=error)) CALL create_wiener_process(md_env,error) + IF (need_per_atom_wiener_process(md_env)) CALL create_wiener_process(md_env) time_iter_start=m_walltime() CALL get_md_env(md_env, force_env=force_env, itimes=itimes, constant=constant,& - md_ener=md_ener, t=time, used_time=used_time, error=error) + md_ener=md_ener, t=time, used_time=used_time) ! Attach the time counter of the meta_env to the one of the MD - CALL set_meta_env(force_env%meta_env, time=time, error=error) + CALL set_meta_env(force_env%meta_env, time=time) ! Initialize the md_ener structure - CALL initialize_md_ener(md_ener, force_env, simpar, error=error) + CALL initialize_md_ener(md_ener, force_env, simpar) ! Check for ensembles requiring the stress tensor - takes into account the possibility for ! multiple force_evals @@ -352,12 +346,12 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv "Be sure the method you are using can compute the virial! "//& CPSourceFileRef,& - error,failure) + failure) IF (ASSOCIATED(force_env%sub_force_env)) THEN DO i = 1, SIZE(force_env%sub_force_env) IF (ASSOCIATED(force_env%sub_force_env(i)%force_env)) THEN - CALL force_env_get(force_env%sub_force_env(i)%force_env, subsys=subsys_i, error=error ) - CALL cp_subsys_get(subsys_i, virial=virial, error=error) + CALL force_env_get(force_env%sub_force_env(i)%force_env, subsys=subsys_i) + CALL cp_subsys_get(subsys_i, virial=virial) check = check .AND. virial%pv_availability END IF END DO @@ -367,32 +361,32 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv " the input file! You have to switch on the virial evaluation with the keyword: STRESS_TENSOR "//& " in each force_eval section. Be sure the method you are using can compute the virial!"//& CPSourceFileRef,& - error,failure) + failure) END IF ! Computing Forces at zero MD step IF (simpar%ensemble /= reftraj_ensemble) THEN - CALL section_vals_val_get(md_section,"STEP_START_VAL",i_val=itimes,error=error) - CALL section_vals_val_get(md_section,"TIME_START_VAL",r_val=time,error=error) - CALL section_vals_val_get(md_section,"ECONS_START_VAL",r_val=constant,error=error) - CALL cp_iterate(logger%iter_info,iter_nr=itimes,error=error) + CALL section_vals_val_get(md_section,"STEP_START_VAL",i_val=itimes) + CALL section_vals_val_get(md_section,"TIME_START_VAL",r_val=time) + CALL section_vals_val_get(md_section,"ECONS_START_VAL",r_val=constant) + CALL cp_iterate(logger%iter_info,iter_nr=itimes) IF(save_mem) THEN - work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) - CALL section_vals_remove_values(work_section, error) - work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY",error=error) - CALL section_vals_remove_values(work_section, error) - work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY") + CALL section_vals_remove_values(work_section) + work_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY") + CALL section_vals_remove_values(work_section) END IF IF(ehrenfest_md)THEN - CALL rt_prop_setup(force_env,error) + CALL rt_prop_setup(force_env) force_env%qs_env%rtp%dt=simpar%dt ELSE ![NB] Lets let all methods, even ones without consistent energies, succeed here. ! They'll fail in actual integrator if needed ! consistent_energies=.FALSE. by default - CALL force_env_calc_energy_force (force_env, calc_force=.TRUE., error=error) + CALL force_env_calc_energy_force (force_env, calc_force=.TRUE.) END IF IF(ASSOCIATED(force_env%qs_env))THEN @@ -403,10 +397,10 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv IF (ASSOCIATED(force_env%meta_env)) THEN ! Setup stuff for plumed if needed IF (force_env%meta_env%use_plumed .EQV. .TRUE.) THEN - CALL metadyn_initialise_plumed(force_env, simpar, itimes, error) + CALL metadyn_initialise_plumed(force_env, simpar, itimes) ELSE IF(force_env%meta_env%langevin) THEN - CALL create_wiener_process_cv(force_env%meta_env, error=error) + CALL create_wiener_process_cv(force_env%meta_env) ENDIF IF (force_env%meta_env%well_tempered) THEN force_env%meta_env%wttemperature = simpar%temp_ext @@ -417,7 +411,7 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv CALL cp_assert(check,cp_failure_level,cp_assertion_failed,routineP,& "Inconsistency between DELTA_T and WTGAMMA (both specified):"//& " please, verify that DELTA_T=(WTGAMMA-1)*TEMPERATURE",& - error,failure) + failure) ELSE force_env%meta_env%delta_t = dummy ENDIF @@ -427,44 +421,44 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv ENDIF force_env%meta_env%invdt = 1._dp/force_env%meta_env%delta_t ENDIF - CALL metadyn_forces(force_env,error=error) - CALL metadyn_write_colvar(force_env,error=error) + CALL metadyn_forces(force_env) + CALL metadyn_write_colvar(force_env) END IF ENDIF IF (simpar%do_respa)THEN CALL force_env_calc_energy_force (force_env%sub_force_env(1)%force_env,& - calc_force=.TRUE.,error=error) + calc_force=.TRUE.) END IF - CALL force_env_get( force_env, subsys=subsys, error=error ) + CALL force_env_get( force_env, subsys=subsys) CALL cp_subsys_get(subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& - particles=particles,virial=virial,error=error) + particles=particles,virial=virial) CALL virial_evaluate(atomic_kinds%els, particles%els, local_particles,& - virial, force_env%para_env%group, error=error) + virial, force_env%para_env%group) - CALL md_energy(md_env,md_ener,error) - CALL md_write_output(md_env, error) !inits the print env at itimes == 0 also writes trajectories + CALL md_energy(md_env,md_ener) + CALL md_write_output(md_env) !inits the print env at itimes == 0 also writes trajectories md_stride = 1 ELSE - CALL get_md_env(md_env, reftraj=reftraj, error=error) - CALL initialize_reftraj(reftraj, reftraj_section, md_env, error=error) + CALL get_md_env(md_env, reftraj=reftraj) + CALL initialize_reftraj(reftraj, reftraj_section, md_env) itimes = reftraj%info%first_snapshot -1 md_stride = reftraj%info%stride IF (ASSOCIATED(force_env%meta_env)) THEN IF (force_env%meta_env%use_plumed .EQV. .TRUE.) THEN - CALL metadyn_initialise_plumed(force_env, simpar, itimes, error) + CALL metadyn_initialise_plumed(force_env, simpar, itimes) END IF END IF END IF CALL cp_print_key_finished_output(simpar%info_constraint, logger,& - constraint_section,"CONSTRAINT_INFO",error=error) + constraint_section,"CONSTRAINT_INFO") CALL cp_print_key_finished_output(simpar%lagrange_multipliers, logger,& - constraint_section,"LAGRANGE_MULTIPLIERS",error=error) + constraint_section,"LAGRANGE_MULTIPLIERS") ! if we need the initial kinetic energy for Hybrid Monte Carlo IF(PRESENT(hmc_e_initial)) hmc_e_initial=md_ener%ekin @@ -481,26 +475,26 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv END IF IF(ehrenfest_md)force_env%qs_env%rtp%istep=istep - CALL cp_iterate(logger%iter_info,last=(istep==simpar%nsteps),iter_nr=itimes,error=error) + CALL cp_iterate(logger%iter_info,last=(istep==simpar%nsteps),iter_nr=itimes) ! Open possible Shake output units simpar%info_constraint = cp_print_key_unit_nr(logger,constraint_section,"CONSTRAINT_INFO",& - extension=".shakeLog",log_filename=.FALSE.,error=error) + extension=".shakeLog",log_filename=.FALSE.) simpar%lagrange_multipliers = cp_print_key_unit_nr(logger,constraint_section,& - "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.,error=error) + "LAGRANGE_MULTIPLIERS",extension=".LagrangeMultLog",log_filename=.FALSE.) simpar%dump_lm = BTEST(cp_print_key_should_output(logger%iter_info,constraint_section,& - "LAGRANGE_MULTIPLIERS",error=error),cp_p_file) + "LAGRANGE_MULTIPLIERS"),cp_p_file) ! Velocity Verlet Integrator - CALL velocity_verlet(md_env,globenv,error) + CALL velocity_verlet(md_env,globenv) ! Close Shake output if requested... CALL cp_print_key_finished_output(simpar%info_constraint, logger,& - constraint_section,"CONSTRAINT_INFO",error=error) + constraint_section,"CONSTRAINT_INFO") CALL cp_print_key_finished_output(simpar%lagrange_multipliers, logger,& - constraint_section,"LAGRANGE_MULTIPLIERS",error=error) + constraint_section,"LAGRANGE_MULTIPLIERS") ! Free Energy calculation - CALL free_energy_evaluate(md_env,should_stop,free_energy_section,error) + CALL free_energy_evaluate(md_env,should_stop,free_energy_section) IF (should_stop) EXIT @@ -513,38 +507,38 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv ! You can force to print the last step (for example if the method used ! to compute energy and forces is not SCF based) activating the print_key ! MOTION%MD%PRINT%FORCE_LAST. - CALL external_control(should_stop,"MD",globenv=globenv,error=error) + CALL external_control(should_stop,"MD",globenv=globenv) ! call external hook e.g. from global optimization IF (PRESENT(mdctrl)) & - CALL mdctrl_callback(mdctrl, md_env, should_stop, error) + CALL mdctrl_callback(mdctrl, md_env, should_stop) IF (should_stop) THEN - CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=itimes,error=error) - CALL md_output(md_env,md_section,force_env%root_section,should_stop,error=error) + CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=itimes) + CALL md_output(md_env,md_section,force_env%root_section,should_stop) IF(ehrenfest_md)THEN - CALL rt_prop_output(force_env%qs_env,ehrenfest,error=error) - CALL rt_write_input_restart(md_env,force_env,error) + CALL rt_prop_output(force_env%qs_env,ehrenfest) + CALL rt_write_input_restart(md_env,force_env) END IF EXIT END IF IF(simpar%ensemble /= reftraj_ensemble) THEN - CALL md_energy(md_env, md_ener, error) - CALL temperature_control(simpar, md_env, md_ener, force_env, logger, error) - CALL comvel_control(md_ener, force_env, md_section, logger, error) - CALL angvel_control(md_ener, force_env, md_section, logger, error) + CALL md_energy(md_env, md_ener) + CALL temperature_control(simpar, md_env, md_ener, force_env, logger) + CALL comvel_control(md_ener, force_env, md_section, logger) + CALL angvel_control(md_ener, force_env, md_section, logger) ELSE - CALL md_ener_reftraj(md_env, md_ener, error) + CALL md_ener_reftraj(md_env, md_ener) END IF time_iter_stop=m_walltime() used_time = time_iter_stop - time_iter_start time_iter_start=time_iter_stop - CALL md_output(md_env,md_section,force_env%root_section,should_stop,error=error) + CALL md_output(md_env,md_section,force_env%root_section,should_stop) IF(simpar%ensemble == reftraj_ensemble ) THEN - CALL write_output_reftraj(md_env,error=error) + CALL write_output_reftraj(md_env) END IF END DO @@ -552,7 +546,7 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv IF(PRESENT(hmc_e_final)) hmc_e_final=md_ener%ekin ! Remove the iteration level - CALL cp_rm_iter_level(logger%iter_info,"MD",error=error) + CALL cp_rm_iter_level(logger%iter_info,"MD") ! Clean up PLUMED IF (ASSOCIATED(force_env%meta_env)) THEN @@ -562,10 +556,10 @@ SUBROUTINE qs_mol_dyn_low(md_env, md_section, motion_section, force_env, globenv END IF ! Deallocate Thermostats and Barostats - CALL release_thermostats(thermostats, error=error) - CALL release_barostat_type(barostat, error=error) - CALL release_simpar_type(simpar, error) - CALL release_thermal_regions(thermal_regions, error) + CALL release_thermostats(thermostats) + CALL release_barostat_type(barostat) + CALL release_simpar_type(simpar) + CALL release_thermal_regions(thermal_regions) CALL timestop(handle) END SUBROUTINE qs_mol_dyn_low diff --git a/src/motion/md_util.F b/src/motion/md_util.F index 51feced4c3..cffc578ced 100644 --- a/src/motion/md_util.F +++ b/src/motion/md_util.F @@ -37,15 +37,13 @@ MODULE md_util !> \param md_section ... !> \param root_section ... !> \param forced_io ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE md_output(md_env,md_section,root_section,forced_io,error) + SUBROUTINE md_output(md_env,md_section,root_section,forced_io) TYPE(md_environment_type), POINTER :: md_env TYPE(section_vals_type), POINTER :: md_section, root_section LOGICAL, INTENT(IN) :: forced_io - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'md_output', & routineP = moduleN//':'//routineN @@ -57,13 +55,13 @@ SUBROUTINE md_output(md_env,md_section,root_section,forced_io,error) CALL timeset(routineN,handle) do_print = .TRUE. IF (forced_io) THEN - print_section => section_vals_get_subs_vals(md_section,"PRINT",error=error) - CALL section_vals_val_get(print_section,"FORCE_LAST",l_val=do_print,error=error) + print_section => section_vals_get_subs_vals(md_section,"PRINT") + CALL section_vals_val_get(print_section,"FORCE_LAST",l_val=do_print) END IF IF (do_print) THEN ! Dumps all files related to the MD run - CALL md_write_output(md_env, error) - CALL write_restart(md_env=md_env,root_section=root_section, error=error) + CALL md_write_output(md_env) + CALL write_restart(md_env=md_env,root_section=root_section) END IF CALL timestop(handle) diff --git a/src/motion/md_vel_utils.F b/src/motion/md_vel_utils.F index 38ca51b0c6..b7997aaf2f 100644 --- a/src/motion/md_vel_utils.F +++ b/src/motion/md_vel_utils.F @@ -325,18 +325,16 @@ END SUBROUTINE rescale_vel !> \param part ... !> \param md_env ... !> \param simpar ... -!> \param error ... !> \par History !> 2008-11 !> \author MI ! ***************************************************************************** - SUBROUTINE rescale_vel_region(part,md_env,simpar,error) + SUBROUTINE rescale_vel_region(part,md_env,simpar) TYPE(particle_type), DIMENSION(:), & POINTER :: part TYPE(md_environment_type), POINTER :: md_env TYPE(simpar_type), POINTER :: simpar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rescale_vel_region', & routineP = moduleN//':'//routineN @@ -349,7 +347,7 @@ SUBROUTINE rescale_vel_region(part,md_env,simpar,error) NULLIFY(thermal_regions, t_region) - CALL get_md_env(md_env,thermal_regions=thermal_regions,error=error) + CALL get_md_env(md_env,thermal_regions=thermal_regions) nfree_done = 0 DO ireg = 1,thermal_regions%nregions NULLIFY(t_region) @@ -424,18 +422,16 @@ END SUBROUTINE subtract_vcom !> \param is_fixed ... !> \param rcom ... !> \param vang ... -!> \param error ... !> \par History !> 2007-11-9: created !> \author Toon Verstraelen ! ***************************************************************************** - SUBROUTINE compute_vang(part,is_fixed,rcom,vang,error) + SUBROUTINE compute_vang(part,is_fixed,rcom,vang) TYPE(particle_type), DIMENSION(:), & POINTER :: part INTEGER, DIMENSION(:), INTENT(IN) :: is_fixed REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rcom REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: vang - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_vang', & routineP = moduleN//':'//routineN @@ -476,7 +472,7 @@ SUBROUTINE compute_vang(part,is_fixed,rcom,vang,error) ! Take the safest route, i.e. diagonalize the inertia tensor and solve ! the angular velocity only with the non-zero eigenvalues. A plain inversion ! would fail for linear molecules. - CALL diamat_all(iner, evals,error=error) + CALL diamat_all(iner, evals) vang(:) = 0.0_dp DO i=1,3 @@ -556,7 +552,6 @@ END SUBROUTINE subtract_vang !> \param core_part ... !> \param force_rescaling ... !> \param para_env ... -!> \param error ... !> \par History !> - is_fixed removed from particle_type !> - 2007-11-07: Cleanup (TV) @@ -565,7 +560,7 @@ END SUBROUTINE subtract_vang ! ***************************************************************************** SUBROUTINE initialize_velocities(simpar, part, force_env, globenv, md_env, & molecule_kinds, label, print_section, subsys_section, shell_present,& - shell_part, core_part, force_rescaling, para_env, error) + shell_part, core_part, force_rescaling, para_env) TYPE(simpar_type), POINTER :: simpar TYPE(particle_type), DIMENSION(:), & @@ -581,7 +576,6 @@ SUBROUTINE initialize_velocities(simpar, part, force_env, globenv, md_env, & POINTER :: shell_part, core_part LOGICAL, INTENT(IN) :: force_rescaling TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_velocities', & routineP = moduleN//':'//routineN @@ -613,8 +607,8 @@ SUBROUTINE initialize_velocities(simpar, part, force_env, globenv, md_env, & NULLIFY (molecule_kind_set) ! Logging - logger => cp_error_get_logger(error) - iw=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".log",error=error) + logger => cp_get_default_logger() + iw=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".log") IF (iw>0) THEN num_x = (79-LEN_TRIM(ADJUSTL(label))-2)/2 WRITE(my_format,'(A,I0,A,I0,A)')'(1X,',num_x,'("*"),1X,A,1X,',num_x,'("*"))' @@ -623,7 +617,7 @@ SUBROUTINE initialize_velocities(simpar, part, force_env, globenv, md_env, & ! Build a list of all fixed atoms (if any) ALLOCATE (is_fixed(natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) is_fixed = use_perd_none molecule_kind_set => molecule_kinds%els @@ -651,10 +645,10 @@ SUBROUTINE initialize_velocities(simpar, part, force_env, globenv, md_env, & CALL read_input_velocities(simpar, part, force_env, md_env, subsys_section,& - shell_present, shell_part, core_part, force_rescaling, para_env, is_fixed, success, error) + shell_present, shell_part, core_part, force_rescaling, para_env, is_fixed, success) IF(.NOT.success) & CALL generate_velocities(simpar, part, force_env, globenv, md_env, shell_present,& - shell_part, core_part, is_fixed, iw, error) + shell_part, core_part, is_fixed, iw) IF (iw>0) THEN @@ -662,20 +656,20 @@ SUBROUTINE initialize_velocities(simpar, part, force_env, globenv, md_env, & CALL compute_vcom(part,is_fixed,vcom,ecom) ekin = compute_ekin(part) - ecom IF (simpar%nfree == 0) THEN - CPPostcondition(ekin==0.0_dp,cp_failure_level,routineP,error,failure) + CPPostcondition(ekin==0.0_dp,cp_failure_level,routineP,failure) temp = 0.0_dp ELSE temp = 2.0_dp * ekin / REAL ( simpar%nfree,KIND=dp) END IF - tmp_r1 = cp_unit_from_cp2k(temp,"K",error=error) + tmp_r1 = cp_unit_from_cp2k(temp,"K") WRITE (iw, '( A, T61, F18.2, A2 )' ) ' Initial Temperature ', tmp_r1, " K" WRITE (iw, '( A, T21, F20.12 , F20.12 , F20.12 )' ) ' COM velocity:', vcom ( 1 ), vcom ( 2 ), vcom ( 3 ) ! compute and log rcom and vang if not periodic - CALL force_env_get(force_env, cell=cell, error=error) + CALL force_env_get(force_env, cell=cell) IF (SUM(cell%perd(1:3)) == 0) THEN CALL compute_rcom(part,is_fixed,rcom) - CALL compute_vang(part,is_fixed,rcom,vang,error) + CALL compute_vang(part,is_fixed,rcom,vang) WRITE (iw, '( A, T21, F20.12 , F20.12 , F20.12 )' ) ' COM position:', rcom ( 1 ), rcom ( 2 ), rcom ( 3 ) WRITE (iw, '( A, T21, F20.12 , F20.12 , F20.12 )' ) ' Angular velocity:', vang ( 1 ), vang ( 2 ), vang ( 3 ) END IF @@ -683,8 +677,8 @@ SUBROUTINE initialize_velocities(simpar, part, force_env, globenv, md_env, & END IF DEALLOCATE (is_fixed,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO", error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE initialize_velocities @@ -704,11 +698,10 @@ END SUBROUTINE initialize_velocities !> \param para_env ... !> \param is_fixed ... !> \param success ... -!> \param error ... !> \author CJM,MK,Toon Verstraelen ! ***************************************************************************** SUBROUTINE read_input_velocities(simpar, part, force_env, md_env, subsys_section,& - shell_present, shell_part, core_part, force_rescaling, para_env, is_fixed, success, error) + shell_present, shell_part, core_part, force_rescaling, para_env, is_fixed, success) TYPE(simpar_type), POINTER :: simpar TYPE(particle_type), DIMENSION(:), & POINTER :: part @@ -722,7 +715,6 @@ SUBROUTINE read_input_velocities(simpar, part, force_env, md_env, subsys_section TYPE(cp_para_env_type), POINTER :: para_env INTEGER, DIMENSION(:), INTENT(INOUT) :: is_fixed LOGICAL, INTENT(OUT) :: success - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_input_velocities', & routineP = moduleN//':'//routineN @@ -760,37 +752,37 @@ SUBROUTINE read_input_velocities(simpar, part, force_env, md_env, subsys_section ! Core-Shell Model nshell = 0 IF (shell_present) THEN - CPPostcondition(ASSOCIATED(core_part),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(shell_part),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(core_part),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(shell_part),cp_failure_level,routineP,failure) nshell = SIZE(shell_part) END IF - atomvel_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) - shellvel_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY",error=error) - corevel_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY",error=error) + atomvel_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") + shellvel_section => section_vals_get_subs_vals(subsys_section,"SHELL_VELOCITY") + corevel_section => section_vals_get_subs_vals(subsys_section,"CORE_VELOCITY") ! Read or initialize the particle velocities - CALL section_vals_get(atomvel_section,explicit=atomvel_explicit,error=error) - CALL section_vals_get(shellvel_section,explicit=shellvel_explicit,error=error) - CALL section_vals_get(corevel_section,explicit=corevel_explicit,error=error) - CPPostcondition(shellvel_explicit.EQV.corevel_explicit,cp_failure_level,routineP,error,failure) + CALL section_vals_get(atomvel_section,explicit=atomvel_explicit) + CALL section_vals_get(shellvel_section,explicit=shellvel_explicit) + CALL section_vals_get(corevel_section,explicit=corevel_explicit) + CPPostcondition(shellvel_explicit.EQV.corevel_explicit,cp_failure_level,routineP,failure) CALL read_binary_velocities("",part,force_env%root_section,para_env,& - subsys_section,atomvel_read,error) + subsys_section,atomvel_read) CALL read_binary_velocities("SHELL",shell_part,force_env%root_section,para_env,& - subsys_section,shellvel_read,error) + subsys_section,shellvel_read) CALL read_binary_velocities("CORE",core_part,force_env%root_section,para_env,& - subsys_section,corevel_read,error) + subsys_section,corevel_read) IF (.NOT.(atomvel_explicit.OR.atomvel_read)) RETURN success = .TRUE. IF (.NOT.atomvel_read) THEN ! Read the atom velocities if explicitly given in the input file - CALL section_vals_list_get(atomvel_section,"_DEFAULT_KEYWORD_",list=atom_list,error=error) + CALL section_vals_list_get(atomvel_section,"_DEFAULT_KEYWORD_",list=atom_list) DO i = 1, natoms - is_ok = cp_sll_val_next(atom_list,val,error=error) - CALL val_get(val,r_vals=vel,error=error) + is_ok = cp_sll_val_next(atom_list,val) + CALL val_get(val,r_vals=vel) part(i)%v = vel END DO END IF @@ -819,14 +811,14 @@ SUBROUTINE read_input_velocities(simpar, part, force_env, md_env, subsys_section IF (shellvel_explicit) THEN ! If the atoms positions are given (?) and core and shell velocities are ! present in the input, read the latter. - CALL section_vals_list_get(shellvel_section,"_DEFAULT_KEYWORD_",list=shell_list,error=error) - CALL section_vals_list_get(corevel_section,"_DEFAULT_KEYWORD_",list=core_list,error=error) + CALL section_vals_list_get(shellvel_section,"_DEFAULT_KEYWORD_",list=shell_list) + CALL section_vals_list_get(corevel_section,"_DEFAULT_KEYWORD_",list=core_list) DO i=1,nshell - is_ok = cp_sll_val_next(shell_list,val,error=error) - CALL val_get(val,r_vals=vel,error=error) + is_ok = cp_sll_val_next(shell_list,val) + CALL val_get(val,r_vals=vel) shell_part(i)%v = vel - is_ok = cp_sll_val_next(core_list,val,error=error) - CALL val_get(val,r_vals=vel,error=error) + is_ok = cp_sll_val_next(core_list,val) + CALL val_get(val,r_vals=vel) core_part(i)%v = vel END DO ELSE @@ -842,7 +834,7 @@ SUBROUTINE read_input_velocities(simpar, part, force_env, md_env, subsys_section ekin = compute_ekin(part) - ecom IF(simpar%do_thermal_region) THEN - CALL get_md_env (md_env, thermal_regions=thermal_regions, error=error) + CALL get_md_env (md_env, thermal_regions=thermal_regions) IF(ASSOCIATED(thermal_regions)) THEN rescale_regions = thermal_regions%force_rescaling END IF @@ -851,7 +843,7 @@ SUBROUTINE read_input_velocities(simpar, part, force_env, md_env, subsys_section END IF IF (simpar%nfree /= 0 .AND. (force_rescaling .OR. rescale_regions)) THEN IF(simpar%do_thermal_region) THEN - CALL rescale_vel_region(part,md_env,simpar,error=error) + CALL rescale_vel_region(part,md_env,simpar) ELSE CALL rescale_vel(part,simpar,ekin,vcom=vcom) END IF @@ -891,11 +883,10 @@ END SUBROUTINE read_input_velocities !> \param core_part ... !> \param is_fixed ... !> \param iw ... -!> \param error ... !> \author CJM,MK,Toon Verstraelen , Ole Schuett ! ***************************************************************************** SUBROUTINE generate_velocities(simpar, part, force_env, globenv, md_env,& - shell_present, shell_part, core_part, is_fixed, iw, error) + shell_present, shell_part, core_part, is_fixed, iw) TYPE(simpar_type), POINTER :: simpar TYPE(particle_type), DIMENSION(:), & POINTER :: part @@ -907,7 +898,6 @@ SUBROUTINE generate_velocities(simpar, part, force_env, globenv, md_env,& POINTER :: shell_part, core_part INTEGER, DIMENSION(:), INTENT(INOUT) :: is_fixed INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'generate_velocities', & routineP = moduleN//':'//routineN @@ -928,35 +918,35 @@ SUBROUTINE generate_velocities(simpar, part, force_env, globenv, md_env,& IF (mass.NE.0.0) THEN SELECT CASE(is_fixed(i)) CASE (use_perd_x) - part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) - part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) + part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) + part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) CASE (use_perd_y) - part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) - part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) + part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) + part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) CASE (use_perd_z) - part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) - part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) + part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) + part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) CASE (use_perd_xy) - part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) + part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) CASE (use_perd_xz) - part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) + part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) CASE (use_perd_yz) - part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) + part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) CASE (use_perd_none) - part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) - part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) - part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream,error=error) / SQRT(mass) + part(i)%v(1) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) + part(i)%v(2) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) + part(i)%v(3) = next_random_number(globenv%gaussian_rng_stream) / SQRT(mass) END SELECT END IF END DO - CALL normalize_velocities(simpar, part, force_env, md_env, is_fixed, error) - CALL soften_velocities(simpar, part, force_env, md_env, is_fixed, iw, error) + CALL normalize_velocities(simpar, part, force_env, md_env, is_fixed) + CALL soften_velocities(simpar, part, force_env, md_env, is_fixed, iw) ! Initialize the core and the shell velocity. Atom velocities are just ! copied so that the initial relative core-shell velocity is zero. IF (shell_present) THEN - CALL optimize_shell_core(force_env,part,shell_part, core_part, globenv, error=error) + CALL optimize_shell_core(force_env,part,shell_part, core_part, globenv) ENDIF END SUBROUTINE generate_velocities @@ -970,10 +960,9 @@ END SUBROUTINE generate_velocities !> \param md_env ... !> \param is_fixed ... !> \param iw ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE soften_velocities(simpar, part, force_env, md_env, is_fixed, iw, error) + SUBROUTINE soften_velocities(simpar, part, force_env, md_env, is_fixed, iw) TYPE(simpar_type), POINTER :: simpar TYPE(particle_type), DIMENSION(:), & POINTER :: part @@ -981,7 +970,6 @@ SUBROUTINE soften_velocities(simpar, part, force_env, md_env, is_fixed, iw, erro TYPE(md_environment_type), POINTER :: md_env INTEGER, DIMENSION(:), INTENT(INOUT) :: is_fixed INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'soften_velocities', & routineP = moduleN//':'//routineN @@ -1011,7 +999,7 @@ SUBROUTINE soften_velocities(simpar, part, force_env, md_env, is_fixed, iw, erro DO i = 1, SIZE(part) part(i)%r = part(i)%r + simpar%soften_delta * N(i,:) END DO - CALL force_env_calc_energy_force(force_env,error=error) + CALL force_env_calc_energy_force(force_env) ! calculate velocity update direction F_t DO i = 1, SIZE(part) @@ -1025,7 +1013,7 @@ SUBROUTINE soften_velocities(simpar, part, force_env, md_env, is_fixed, iw, erro part(i)%v = part(i)%v + simpar%soften_alpha * F_t(i,:) END DO - CALL normalize_velocities(simpar, part, force_env, md_env, is_fixed, error) + CALL normalize_velocities(simpar, part, force_env, md_env, is_fixed) END DO IF(iw>0) THEN @@ -1042,17 +1030,15 @@ END SUBROUTINE soften_velocities !> \param force_env ... !> \param md_env ... !> \param is_fixed ... -!> \param error ... !> \author CJM,MK,Toon Verstraelen , Ole Schuett ! ***************************************************************************** - SUBROUTINE normalize_velocities(simpar, part, force_env, md_env, is_fixed, error) + SUBROUTINE normalize_velocities(simpar, part, force_env, md_env, is_fixed) TYPE(simpar_type), POINTER :: simpar TYPE(particle_type), DIMENSION(:), & POINTER :: part TYPE(force_env_type), POINTER :: force_env TYPE(md_environment_type), POINTER :: md_env INTEGER, DIMENSION(:), INTENT(INOUT) :: is_fixed - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'normalize_velocities', & routineP = moduleN//':'//routineN @@ -1067,15 +1053,15 @@ SUBROUTINE normalize_velocities(simpar, part, force_env, md_env, is_fixed, error CALL compute_vcom(part,is_fixed,vcom) CALL subtract_vcom(part,is_fixed,vcom) ! If requested and the system is not periodic, subtract the angular velocity - CALL force_env_get(force_env, cell=cell, error=error) + CALL force_env_get(force_env, cell=cell) IF (SUM(cell%perd(1:3)) == 0 .AND. simpar%angvel_zero) THEN CALL compute_rcom(part,is_fixed,rcom) - CALL compute_vang(part,is_fixed,rcom,vang,error) + CALL compute_vang(part,is_fixed,rcom,vang) CALL subtract_vang(part,is_fixed,rcom,vang) END IF ! Rescale the velocities IF(simpar%do_thermal_region) THEN - CALL rescale_vel_region(part,md_env,simpar,error=error) + CALL rescale_vel_region(part,md_env,simpar) ELSE ekin = compute_ekin(part) CALL rescale_vel(part,simpar,ekin) @@ -1088,15 +1074,13 @@ END SUBROUTINE normalize_velocities !> \param subsys ... !> \param md_ener ... !> \param vsubtract ... -!> \param error ... !> \par History !> Teodoro Laino - University of Zurich - 09.2007 [tlaino] ! ***************************************************************************** - SUBROUTINE reset_vcom(subsys, md_ener, vsubtract, error) + SUBROUTINE reset_vcom(subsys, md_ener, vsubtract) TYPE(cp_subsys_type), POINTER :: subsys TYPE(md_ener_type), POINTER :: md_ener REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: vsubtract - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'reset_vcom', & routineP = moduleN//':'//routineN @@ -1121,8 +1105,7 @@ SUBROUTINE reset_vcom(subsys, md_ener, vsubtract, error) atomic_kinds=atomic_kinds,& particles=particles,& shell_particles=shell_particles,& - core_particles=core_particles,& - error=error) + core_particles=core_particles) ekin_old = md_ener%ekin ! Possibly subtract a quantity from all velocities @@ -1186,16 +1169,14 @@ END SUBROUTINE reset_vcom !> \param temp_expected ... !> \param temp_tol ... !> \param iw ... -!> \param error ... !> \par History !> Teodoro Laino - University of Zurich - 09.2007 [tlaino] ! ***************************************************************************** - SUBROUTINE scale_velocity(subsys, md_ener, temp_expected, temp_tol, iw, error) + SUBROUTINE scale_velocity(subsys, md_ener, temp_expected, temp_tol, iw) TYPE(cp_subsys_type), POINTER :: subsys TYPE(md_ener_type), POINTER :: md_ener REAL(KIND=dp), INTENT(IN) :: temp_expected, temp_tol INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_velocity', & routineP = moduleN//':'//routineN @@ -1212,7 +1193,7 @@ SUBROUTINE scale_velocity(subsys, md_ener, temp_expected, temp_tol, iw, error) md_ener%vcom = 0.0_dp md_ener%total_mass = 0.0_dp - CALL scale_velocity_low(subsys,scale,ireg=0,ekin=md_ener%ekin,vcom=md_ener%vcom,error=error) + CALL scale_velocity_low(subsys,scale,ireg=0,ekin=md_ener%ekin,vcom=md_ener%vcom) IF(md_ener%nfree /=0) THEN md_ener%temp_part = 2.0_dp*md_ener%ekin/REAL(md_ener%nfree,KIND=dp)*kelvin END IF @@ -1232,17 +1213,15 @@ END SUBROUTINE scale_velocity !> \param md_ener ... !> \param simpar ... !> \param iw ... -!> \param error ... !> \par author MI ! ***************************************************************************** - SUBROUTINE scale_velocity_region(md_env, subsys, md_ener, simpar, iw, error) + SUBROUTINE scale_velocity_region(md_env, subsys, md_ener, simpar, iw) TYPE(md_environment_type), POINTER :: md_env TYPE(cp_subsys_type), POINTER :: subsys TYPE(md_ener_type), POINTER :: md_ener TYPE(simpar_type), POINTER :: simpar INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_velocity_region', & routineP = moduleN//':'//routineN @@ -1260,9 +1239,9 @@ SUBROUTINE scale_velocity_region(md_env, subsys, md_ener, simpar, iw, error) TYPE(thermal_regions_type), POINTER :: thermal_regions NULLIFY( particles, part, thermal_regions, t_region) - CALL cp_subsys_get(subsys, particles=particles, error=error) + CALL cp_subsys_get(subsys, particles=particles) part => particles%els - CALL get_md_env(md_env, thermal_regions=thermal_regions, error=error) + CALL get_md_env(md_env, thermal_regions=thermal_regions) nregions = thermal_regions%nregions nfree_done = 0 @@ -1283,7 +1262,7 @@ SUBROUTINE scale_velocity_region(md_env, subsys, md_ener, simpar, iw, error) IF(t_region%temp_tol > 0.0_dp .AND. & ABS(t_region%temp_expected - t_region%temperature/kelvin) > t_region%temp_tol) THEN fscale = SQRT((t_region%temp_expected/t_region%temperature)*kelvin) - CALL scale_velocity_low(subsys,fscale,ireg,ekin,vcom,error) + CALL scale_velocity_low(subsys,fscale,ireg,ekin,vcom) t_region%temperature = 2.0_dp*ekin/REAL(nfree,KIND=dp)*kelvin temp_new(ireg) = t_region%temperature END IF @@ -1297,7 +1276,7 @@ SUBROUTINE scale_velocity_region(md_env, subsys, md_ener, simpar, iw, error) IF(simpar%temp_tol > 0.0_dp .AND. nfree>0) THEN IF (ABS(simpar%temp_ext - thermal_regions%temp_reg0/kelvin) > simpar%temp_tol) THEN fscale = SQRT((simpar%temp_ext/thermal_regions%temp_reg0)*kelvin) - CALL scale_velocity_low(subsys,fscale,0,ekin,vcom,error) + CALL scale_velocity_low(subsys,fscale,0,ekin,vcom) thermal_regions%temp_reg0 = 2.0_dp*ekin/REAL(nfree,KIND=dp)*kelvin temp_new(0) = thermal_regions%temp_reg0 END IF @@ -1327,16 +1306,14 @@ END SUBROUTINE scale_velocity_region !> \param ireg ... !> \param ekin ... !> \param vcom ... -!> \param error ... !> \par author MI ! ***************************************************************************** - SUBROUTINE scale_velocity_low(subsys,fscale,ireg,ekin,vcom,error) + SUBROUTINE scale_velocity_low(subsys,fscale,ireg,ekin,vcom) TYPE(cp_subsys_type), POINTER :: subsys REAL(KIND=dp), INTENT(IN) :: fscale INTEGER, INTENT(IN) :: ireg REAL(KIND=dp), INTENT(OUT) :: ekin, vcom(3) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_velocity_low', & routineP = moduleN//':'//routineN @@ -1361,7 +1338,7 @@ SUBROUTINE scale_velocity_low(subsys,fscale,ireg,ekin,vcom,error) vcom = 0.0_dp CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, particles=particles,& - shell_particles=shell_particles, core_particles=core_particles, error=error) + shell_particles=shell_particles, core_particles=core_particles) DO ikind=1,atomic_kinds%n_els atomic_kind => atomic_kinds%els(ikind) @@ -1433,16 +1410,14 @@ END SUBROUTINE scale_velocity_low !> \param temp_expected ... !> \param temp_tol ... !> \param iw ... -!> \param error ... !> \par History !> Teodoro Laino - University of Zurich - 09.2007 [tlaino] ! ***************************************************************************** - SUBROUTINE scale_velocity_internal(subsys, md_ener, temp_expected, temp_tol, iw, error) + SUBROUTINE scale_velocity_internal(subsys, md_ener, temp_expected, temp_tol, iw) TYPE(cp_subsys_type), POINTER :: subsys TYPE(md_ener_type), POINTER :: md_ener REAL(KIND=dp), INTENT(IN) :: temp_expected, temp_tol INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_velocity_internal', & routineP = moduleN//':'//routineN @@ -1471,7 +1446,7 @@ SUBROUTINE scale_velocity_internal(subsys, md_ener, temp_expected, temp_tol, iw md_ener%temp_shell = 0.0_dp CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, particles=particles, shell_particles=shell_particles,& - core_particles=core_particles, error=error) + core_particles=core_particles) DO ikind=1,atomic_kinds%n_els atomic_kind => atomic_kinds%els(ikind) @@ -1528,16 +1503,14 @@ END SUBROUTINE scale_velocity_internal !> \param temp_expected ... !> \param temp_tol ... !> \param iw ... -!> \param error ... !> \par History !> MI 02.2008 ! ***************************************************************************** - SUBROUTINE scale_velocity_baro(md_env, md_ener, temp_expected, temp_tol, iw, error) + SUBROUTINE scale_velocity_baro(md_env, md_ener, temp_expected, temp_tol, iw) TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), POINTER :: md_ener REAL(KIND=dp), INTENT(IN) :: temp_expected, temp_tol INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scale_velocity_baro', & routineP = moduleN//':'//routineN @@ -1548,7 +1521,7 @@ SUBROUTINE scale_velocity_baro(md_env, md_ener, temp_expected, temp_tol, iw, err TYPE(simpar_type), POINTER :: simpar NULLIFY( npt, simpar) - CALL get_md_env ( md_env, simpar = simpar, npt = npt, error=error) + CALL get_md_env ( md_env, simpar = simpar, npt = npt) IF (ABS(temp_expected - md_ener%temp_baro/kelvin) > temp_tol) THEN scale = 0.0_dp IF (md_ener%temp_baro>0.0_dp) scale = SQRT((temp_expected/md_ener%temp_baro)*kelvin) @@ -1586,20 +1559,18 @@ END SUBROUTINE scale_velocity_baro !> \param md_ener ... !> \param force_env ... !> \param logger ... -!> \param error ... !> \par History !> Creation (15.09.2003,MK) !> adapted to force_env (05.10.2003,fawzi) !> Cleaned (09.2007) Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE temperature_control(simpar, md_env, md_ener,force_env,logger, error) + SUBROUTINE temperature_control(simpar, md_env, md_ener,force_env,logger) TYPE(simpar_type), POINTER :: simpar TYPE(md_environment_type), POINTER :: md_env TYPE(md_ener_type), POINTER :: md_ener TYPE(force_env_type), POINTER :: force_env TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'temperature_control', & routineP = moduleN//':'//routineN @@ -1611,36 +1582,36 @@ SUBROUTINE temperature_control(simpar, md_env, md_ener,force_env,logger, error) CALL timeset(routineN,handle) NULLIFY(subsys, para_env) - CPPrecondition(ASSOCIATED(simpar),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(md_ener),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,subsys=subsys,para_env=para_env,error=error) + CPPrecondition(ASSOCIATED(simpar),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(md_ener),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CALL force_env_get(force_env,subsys=subsys,para_env=para_env) iw = cp_print_key_unit_nr(logger,force_env%root_section,"MOTION%MD%PRINT%PROGRAM_RUN_INFO",& - extension=".mdLog",error=error) + extension=".mdLog") ! Control the particle motion IF(simpar%do_thermal_region) THEN - CALL scale_velocity_region(md_env, subsys, md_ener, simpar, iw, error) + CALL scale_velocity_region(md_env, subsys, md_ener, simpar, iw) ELSE IF (simpar%temp_tol > 0.0_dp ) THEN - CALL scale_velocity(subsys, md_ener, simpar%temp_ext, simpar%temp_tol, iw, error) + CALL scale_velocity(subsys, md_ener, simpar%temp_ext, simpar%temp_tol, iw) END IF END IF ! Control the internal core-shell motion IF(simpar%temp_sh_tol > 0.0_dp) THEN - CALL scale_velocity_internal(subsys, md_ener, simpar%temp_sh_ext, simpar%temp_sh_tol, iw, error) + CALL scale_velocity_internal(subsys, md_ener, simpar%temp_sh_ext, simpar%temp_sh_tol, iw) END IF ! Control cell motion SELECT CASE (simpar%ensemble) CASE( nph_uniaxial_damped_ensemble, nph_uniaxial_ensemble, & npt_f_ensemble, npt_i_ensemble, npe_f_ensemble, npe_i_ensemble) IF(simpar%temp_baro_tol > 0.0_dp) THEN - CALL scale_velocity_baro(md_env, md_ener, simpar%temp_baro_ext, simpar%temp_baro_tol, iw, error) + CALL scale_velocity_baro(md_env, md_ener, simpar%temp_baro_ext, simpar%temp_baro_tol, iw) END IF END SELECT CALL cp_print_key_finished_output(iw,logger,force_env%root_section,& - "MOTION%MD%PRINT%PROGRAM_RUN_INFO", error=error) + "MOTION%MD%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE temperature_control @@ -1650,18 +1621,16 @@ END SUBROUTINE temperature_control !> \param force_env ... !> \param md_section ... !> \param logger ... -!> \param error ... !> \par History !> Creation (29.04.2007,MI) !> Cleaned (09.2007) Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE comvel_control(md_ener,force_env, md_section, logger, error) + SUBROUTINE comvel_control(md_ener,force_env, md_section, logger) TYPE(md_ener_type), POINTER :: md_ener TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: md_section TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'comvel_control', & routineP = moduleN//':'//routineN @@ -1674,31 +1643,31 @@ SUBROUTINE comvel_control(md_ener,force_env, md_section, logger, error) CALL timeset(routineN,handle) NULLIFY(subsys) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,subsys=subsys,error=error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CALL force_env_get(force_env,subsys=subsys) ! Print COMVEL and COM Position - iw = cp_print_key_unit_nr(logger,md_section,"PRINT%CENTER_OF_MASS",extension=".mdLog",error=error) + iw = cp_print_key_unit_nr(logger,md_section,"PRINT%CENTER_OF_MASS",extension=".mdLog") IF (iw>0) THEN WRITE (UNIT=iw,FMT="(/,T2,A,(T58,A3,F20.10))")& "Centre of mass motion (COM):","x =",md_ener%vcom(1),"y =",md_ener%vcom(2),"z =",md_ener%vcom(3) END IF - CALL cp_print_key_finished_output(iw,logger,md_section,"PRINT%CENTER_OF_MASS", error=error) + CALL cp_print_key_finished_output(iw,logger,md_section,"PRINT%CENTER_OF_MASS") ! If requested rescale COMVEL - CALL section_vals_val_get(md_section,"COMVEL_TOL",explicit=explicit,error=error) + CALL section_vals_val_get(md_section,"COMVEL_TOL",explicit=explicit) IF ( explicit ) THEN - CALL section_vals_val_get(md_section,"COMVEL_TOL",r_val=comvel_tol,error=error) + CALL section_vals_val_get(md_section,"COMVEL_TOL",r_val=comvel_tol) iw = cp_print_key_unit_nr(logger,md_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".mdLog",error=error) + extension=".mdLog") vel_com = SQRT(md_ener%vcom(1)**2+md_ener%vcom(2)**2+md_ener%vcom(3)**2) ! Subtract the velocity of the COM, if requested IF (vel_com > comvel_tol) THEN temp_old = md_ener%temp_part/kelvin vcom_old = md_ener%vcom - CALL reset_vcom( subsys, md_ener, vsubtract=vcom_old, error=error) - CALL scale_velocity(subsys, md_ener, temp_old, 0.0_dp, iw, error) + CALL reset_vcom( subsys, md_ener, vsubtract=vcom_old) + CALL scale_velocity(subsys, md_ener, temp_old, 0.0_dp, iw) IF (iw>0) THEN WRITE (UNIT=iw,FMT="(T2,'MD| ',A,3F16.10,A)") & "Old VCOM = ",vcom_old(1:3)," a.u.",& @@ -1706,7 +1675,7 @@ SUBROUTINE comvel_control(md_ener,force_env, md_section, logger, error) END IF END IF CALL cp_print_key_finished_output(iw,logger,md_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END IF CALL timestop(handle) @@ -1718,17 +1687,15 @@ END SUBROUTINE comvel_control !> \param force_env ... !> \param md_section ... !> \param logger ... -!> \param error ... !> \par History !> Creation (10.2009) Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE angvel_control(md_ener, force_env, md_section, logger, error) + SUBROUTINE angvel_control(md_ener, force_env, md_section, logger) TYPE(md_ener_type), POINTER :: md_ener TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: md_section TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'angvel_control', & routineP = moduleN//':'//routineN @@ -1752,24 +1719,24 @@ SUBROUTINE angvel_control(md_ener, force_env, md_section, logger, error) CALL timeset(routineN,handle) ! If requested rescale ANGVEL - CALL section_vals_val_get(md_section,"ANGVEL_TOL",explicit=explicit,error=error) + CALL section_vals_val_get(md_section,"ANGVEL_TOL",explicit=explicit) IF ( explicit ) THEN NULLIFY(subsys, cell) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CALL force_env_get(force_env,subsys=subsys,cell=cell,error=error) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CALL force_env_get(force_env,subsys=subsys,cell=cell) IF (SUM(cell%perd(1:3)) == 0) THEN - CALL section_vals_val_get(md_section,"ANGVEL_TOL",r_val=angvel_tol,error=error) + CALL section_vals_val_get(md_section,"ANGVEL_TOL",r_val=angvel_tol) iw = cp_print_key_unit_nr(logger,md_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".mdLog",error=error) + extension=".mdLog") CALL cp_subsys_get(subsys,molecule_kinds_new=molecule_kinds,& - particles=particles, error=error) + particles=particles) natoms = SIZE(particles%els) ! Build a list of all fixed atoms (if any) ALLOCATE (is_fixed(natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) is_fixed = use_perd_none molecule_kind_set => molecule_kinds%els @@ -1786,14 +1753,14 @@ SUBROUTINE angvel_control(md_ener, force_env, md_section, logger, error) ! If requested and the system is not periodic, subtract the angular velocity CALL compute_rcom(particles%els,is_fixed,rcom) - CALL compute_vang(particles%els,is_fixed,rcom,vang,error) + CALL compute_vang(particles%els,is_fixed,rcom,vang) IF (SQRT(DOT_PRODUCT(vang,vang))>angvel_tol) THEN CALL subtract_vang(particles%els,is_fixed,rcom,vang) ! Rescale velocities after removal temp_old = md_ener%temp_part/kelvin - CALL scale_velocity(subsys, md_ener, temp_old, 0.0_dp, iw, error) - CALL compute_vang(particles%els,is_fixed,rcom,vang_new,error) + CALL scale_velocity(subsys, md_ener, temp_old, 0.0_dp, iw) + CALL compute_vang(particles%els,is_fixed,rcom,vang_new) IF (iw>0) THEN WRITE (UNIT=iw,FMT="(T2,'MD| ',A,3F16.10,A)") & "Old VANG = ",vang(1:3)," a.u.",& @@ -1802,10 +1769,10 @@ SUBROUTINE angvel_control(md_ener, force_env, md_section, logger, error) END IF DEALLOCATE (is_fixed,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL cp_print_key_finished_output(iw,logger,md_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END IF END IF @@ -1821,13 +1788,11 @@ END SUBROUTINE angvel_control !> \param md_section ... !> \param constraint_section ... !> \param write_binary_restart_file ... -!> \param error ... !> \par History !> Teodoro Laino - University of Zurich - 09.2007 [tlaino] ! ***************************************************************************** SUBROUTINE setup_velocities(force_env, simpar, globenv, md_env, md_section, & - constraint_section, write_binary_restart_file, & - error) + constraint_section, write_binary_restart_file) TYPE(force_env_type), POINTER :: force_env TYPE(simpar_type), POINTER :: simpar @@ -1835,7 +1800,6 @@ SUBROUTINE setup_velocities(force_env, simpar, globenv, md_env, md_section, & TYPE(md_environment_type), POINTER :: md_env TYPE(section_vals_type), POINTER :: md_section, constraint_section LOGICAL, INTENT(IN) :: write_binary_restart_file - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_velocities', & routineP = moduleN//':'//routineN @@ -1866,23 +1830,22 @@ SUBROUTINE setup_velocities(force_env, simpar, globenv, md_env, md_section, & NULLIFY (shell_particles,core_particle_set,particle_set,shell_particle_set) NULLIFY (force_env_section,print_section,subsys_section) - print_section => section_vals_get_subs_vals(md_section,"PRINT",error=error) + print_section => section_vals_get_subs_vals(md_section,"PRINT") apply_cns0 = .FALSE. IF (simpar%constraint) THEN - CALL section_vals_val_get(constraint_section,"CONSTRAINT_INIT",l_val=apply_cns0,error=error) + CALL section_vals_val_get(constraint_section,"CONSTRAINT_INIT",l_val=apply_cns0) END IF ! Always initialize velocities and possibly restart them CALL force_env_get(force_env, subsys=subsys, cell=cell, para_env=para_env,& - force_env_section=force_env_section, error=error ) - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) + force_env_section=force_env_section) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") CALL cp_subsys_get(subsys,& atomic_kinds=atomic_kinds,& core_particles=core_particles,& molecule_kinds_new=molecule_kinds,& particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) CALL get_atomic_kind_set(atomic_kind_set=atomic_kinds%els,& shell_present=shell_present,& @@ -1902,9 +1865,9 @@ SUBROUTINE setup_velocities(force_env, simpar, globenv, md_env, md_section, & cp_fatal_level,cp_assertion_failed,routineP,& "Only the fixed atom constraint is implemented for core-shell models",& only_ionode=.TRUE.) -!MK CPPostcondition(.NOT.simpar%constraint,cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(shell_particles),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(core_particles),cp_failure_level,routineP,error,failure) +!MK CPPostcondition(.NOT.simpar%constraint,cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(shell_particles),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(core_particles),cp_failure_level,routineP,failure) shell_particle_set => shell_particles%els core_particle_set => core_particles%els END IF @@ -1914,44 +1877,43 @@ SUBROUTINE setup_velocities(force_env, simpar, globenv, md_env, md_section, & label="Velocities initialization",print_section=print_section, & subsys_section=subsys_section, shell_present=(shell_present.AND.shell_adiabatic), & shell_part=shell_particle_set, core_part=core_particle_set, force_rescaling=.FALSE., & - para_env=para_env,error=error) + para_env=para_env) ! Apply constraints if required and rescale velocities.. IF (simpar%ensemble /= reftraj_ensemble) THEN IF (apply_cns0) THEN - CALL force_env_calc_energy_force ( force_env, calc_force=.TRUE.,error=error) + CALL force_env_calc_energy_force ( force_env, calc_force=.TRUE.) CALL force_env_shake(force_env,shake_tol=simpar%shake_tol,& log_unit=simpar%info_constraint,lagrange_mult=simpar%lagrange_multipliers,& - dump_lm=simpar%dump_lm,compold=.TRUE.,error=error) + dump_lm=simpar%dump_lm,compold=.TRUE.) CALL force_env_rattle(force_env,shake_tol=simpar%shake_tol,& log_unit=simpar%info_constraint,lagrange_mult=simpar%lagrange_multipliers,& - dump_lm=simpar%dump_lm,reset=.TRUE.,error=error) + dump_lm=simpar%dump_lm,reset=.TRUE.) IF (simpar%do_respa)THEN CALL force_env_calc_energy_force (force_env%sub_force_env(1)%force_env,& - calc_force=.TRUE.,error=error) + calc_force=.TRUE.) CALL force_env_shake(force_env%sub_force_env(1)%force_env,& shake_tol=simpar%shake_tol,log_unit=simpar%info_constraint,& - lagrange_mult=simpar%lagrange_multipliers,dump_lm=simpar%dump_lm,compold=.TRUE.,error=error) + lagrange_mult=simpar%lagrange_multipliers,dump_lm=simpar%dump_lm,compold=.TRUE.) CALL force_env_rattle(force_env%sub_force_env(1)%force_env,& shake_tol=simpar%shake_tol,log_unit=simpar%info_constraint,& - lagrange_mult=simpar%lagrange_multipliers,dump_lm=simpar%dump_lm,reset=.TRUE.,error=error) + lagrange_mult=simpar%lagrange_multipliers,dump_lm=simpar%dump_lm,reset=.TRUE.) END IF ! Reinitialize velocities rescaling properly after rattle - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) - CALL update_subsys(subsys_section,force_env,.FALSE.,write_binary_restart_file,error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") + CALL update_subsys(subsys_section,force_env,.FALSE.,write_binary_restart_file) CALL initialize_velocities(simpar,particle_set, molecule_kinds=molecule_kinds,& force_env=force_env, globenv=globenv, md_env=md_env,& label="Re-Initializing velocities after applying constraints",print_section=print_section, & subsys_section=subsys_section, shell_present=(shell_present.AND.shell_adiabatic), & shell_part=shell_particle_set, core_part=core_particle_set, force_rescaling=.TRUE., & - para_env=para_env,error=error) + para_env=para_env) END IF END IF ! Perform setup for a cascade run - CALL initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& - error=error) + CALL initialize_cascade(simpar,particle_set,molecule_kinds,md_section) CALL timestop(handle) @@ -1963,20 +1925,17 @@ END SUBROUTINE setup_velocities !> \param particle_set ... !> \param molecule_kinds ... !> \param md_section ... -!> \param error ... !> \date 05.02.2012 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& - error) + SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section) TYPE(simpar_type), POINTER :: simpar TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(mol_kind_new_list_type), POINTER :: molecule_kinds TYPE(section_vals_type), POINTER :: md_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_cascade', & routineP = moduleN//':'//routineN @@ -2020,24 +1979,24 @@ SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& NULLIFY (logger) NULLIFY (val) - logger => cp_error_get_logger(error) - print_section => section_vals_get_subs_vals(md_section,"PRINT",error=error) - iw = cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".log",error=error) + logger => cp_get_default_logger() + print_section => section_vals_get_subs_vals(md_section,"PRINT") + iw = cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".log") - cascade_section => section_vals_get_subs_vals(md_section,"CASCADE",error=error) - CALL section_vals_val_get(cascade_section,"_SECTION_PARAMETERS_",l_val=init_cascade,error=error) + cascade_section => section_vals_get_subs_vals(md_section,"CASCADE") + CALL section_vals_val_get(cascade_section,"_SECTION_PARAMETERS_",l_val=init_cascade) nparticle = SIZE(particle_set) IF (init_cascade) THEN - CALL section_vals_val_get(cascade_section,"ENERGY",r_val=energy,error=error) + CALL section_vals_val_get(cascade_section,"ENERGY",r_val=energy) CALL cp_assert((energy >= 0.0_dp),cp_fatal_level,cp_assertion_failed,routineP,& "Error occurred reading &CASCADE section: Negative energy found",& only_ionode=.TRUE.) IF (iw > 0) THEN - ekin = cp_unit_from_cp2k(energy,"keV",error=error) + ekin = cp_unit_from_cp2k(energy,"keV") WRITE (UNIT=iw,FMT="(T2,A,T61,F20.6)")& "CASCADE| Energy [keV]",ekin WRITE (UNIT=iw,FMT="(T2,A)")& @@ -2045,9 +2004,9 @@ SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& END IF ! Read the atomic velocities given in the input file - atom_list_section => section_vals_get_subs_vals(cascade_section,"ATOM_LIST",error=error) - CALL section_vals_val_get(atom_list_section,"_DEFAULT_KEYWORD_",n_rep_val=natom,error=error) - CALL section_vals_list_get(atom_list_section,"_DEFAULT_KEYWORD_",list=atom_list,error=error) + atom_list_section => section_vals_get_subs_vals(cascade_section,"ATOM_LIST") + CALL section_vals_val_get(atom_list_section,"_DEFAULT_KEYWORD_",n_rep_val=natom) + CALL section_vals_list_get(atom_list_section,"_DEFAULT_KEYWORD_",list=atom_list) CALL cp_assert((natom > 0),cp_fatal_level,cp_assertion_failed,routineP,& "Error occurred reading &CASCADE section: No atom list found",& only_ionode=.TRUE.) @@ -2058,17 +2017,17 @@ SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& END IF ALLOCATE (atom_index(natom),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ALLOCATE (matom(natom),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ALLOCATE (vatom(3,natom),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ALLOCATE (weight(natom),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DO iatom=1,natom - is_ok = cp_sll_val_next(atom_list,val,error=error) - CALL val_get(val,c_val=line,error=error) + is_ok = cp_sll_val_next(atom_list,val) + CALL val_get(val,c_val=line) ! Read atomic index, velocity vector, and weight no_read_error = .FALSE. READ (UNIT=line,FMT=*,ERR=999) atom_index(iatom),vatom(1:3,iatom),weight(iatom) @@ -2115,7 +2074,7 @@ SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& WRITE (UNIT=iw,FMT="(T2,A,T11,A,3(11X,A),9X,A)")& "CASCADE| ","Atom index","v(x)","v(y)","v(z)","E(kin)" DO iatom=1,natom - ekin = cp_unit_from_cp2k(weight(iatom),"keV",error=error) + ekin = cp_unit_from_cp2k(weight(iatom),"keV") WRITE (UNIT=iw,FMT="(T2,A,I10,4(1X,F14.6))")& "CASCADE| ",atom_index(iatom),vatom(1:3,iatom),ekin END DO @@ -2129,18 +2088,18 @@ SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& END DO DEALLOCATE (atom_index,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (matom,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (vatom,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) DEALLOCATE (weight,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) IF (iw > 0) THEN ! Build a list of all fixed atoms (if any) ALLOCATE (is_fixed(nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) is_fixed = use_perd_none molecule_kind_set => molecule_kinds%els DO imolecule_kind=1,molecule_kinds%n_els @@ -2156,12 +2115,12 @@ SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& CALL compute_vcom(particle_set,is_fixed,vcom,ecom) ekin = compute_ekin(particle_set) - ecom IF (simpar%nfree == 0) THEN - CPPostcondition((ekin == 0.0_dp),cp_failure_level,routineP,error,failure) + CPPostcondition((ekin == 0.0_dp),cp_failure_level,routineP,failure) temp = 0.0_dp ELSE temp = 2.0_dp*ekin/REAL(simpar%nfree,KIND=dp) END IF - temperature = cp_unit_from_cp2k(temp,"K",error=error) + temperature = cp_unit_from_cp2k(temp,"K") WRITE (UNIT=iw,FMT="(T2,A)")& "CASCADE|" WRITE (UNIT=iw,FMT="(T2,A,T61,F18.2,A2)")& @@ -2169,20 +2128,20 @@ SUBROUTINE initialize_cascade(simpar,particle_set,molecule_kinds,md_section,& WRITE (UNIT=iw,FMT="(T2,A,T30,3(1X,ES16.8),/)")& "CASCADE| COM velocity: ",vcom(1:3) !MK ! compute and log rcom and vang if not periodic -!MK CALL force_env_get(force_env,cell=cell,error=error) +!MK CALL force_env_get(force_env,cell=cell) !MK IF (SUM(cell%perd(1:3)) == 0) THEN !MK CALL compute_rcom(particle_set,is_fixed,rcom) -!MK CALL compute_vang(particle_set,is_fixed,rcom,vang,error) +!MK CALL compute_vang(particle_set,is_fixed,rcom,vang) !MK WRITE (iw, '( A, T21, F20.12 , F20.12 , F20.12 )' ) ' COM position:',rcom(1:3) !MK WRITE (iw, '( A, T21, F20.12 , F20.12 , F20.12 )' ) ' Angular velocity:',vang(1:3) !MK END IF DEALLOCATE (is_fixed,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF - CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO") CALL timestop(handle) diff --git a/src/motion/mdctrl_methods.F b/src/motion/mdctrl_methods.F index b9696baf8f..909e4a2c25 100644 --- a/src/motion/mdctrl_methods.F +++ b/src/motion/mdctrl_methods.F @@ -33,14 +33,11 @@ MODULE mdctrl_methods !> \param mdctrl data which is passed on to the wrapped client-routine !> \param md_env contains the current state of the md_run !> \param should_stop can be used to abort the md_run -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE mdctrl_callback(mdctrl, md_env, should_stop, error) + SUBROUTINE mdctrl_callback(mdctrl, md_env, should_stop) TYPE(mdctrl_type), POINTER :: mdctrl TYPE(md_environment_type), POINTER :: md_env LOGICAL, INTENT(inout) :: should_stop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mdctrl_callback', & routineP = moduleN//':'//routineN @@ -48,11 +45,11 @@ SUBROUTINE mdctrl_callback(mdctrl, md_env, should_stop, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(md_env), cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mdctrl), cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(md_env), cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mdctrl), cp_failure_level,routineP,failure) IF(ASSOCIATED(mdctrl%glbopt)) THEN - CALL glbopt_md_callback(mdctrl%glbopt, md_env, should_stop, error) + CALL glbopt_md_callback(mdctrl%glbopt, md_env, should_stop) !ELSE IF(ASSOCIATED(mdctrl%your_own_hook)) THEN ... diff --git a/src/motion/neb_io.F b/src/motion/neb_io.F index b625388c11..fcaa935856 100644 --- a/src/motion/neb_io.F +++ b/src/motion/neb_io.F @@ -81,13 +81,11 @@ MODULE neb_io !> \brief Read data from the NEB input section !> \param neb_env ... !> \param neb_section ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE read_neb_section(neb_env, neb_section,error) + SUBROUTINE read_neb_section(neb_env, neb_section) TYPE(neb_type), POINTER :: neb_env TYPE(section_vals_type), POINTER :: neb_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_neb_section', & routineP = moduleN//':'//routineN @@ -96,22 +94,21 @@ SUBROUTINE read_neb_section(neb_env, neb_section,error) TYPE(section_vals_type), POINTER :: wrk_section failure = .FALSE. - CPPostcondition(ASSOCIATED(neb_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(neb_env),cp_failure_level,routineP,failure) neb_env%istep = 0 - CALL section_vals_val_get(neb_section,"BAND_TYPE",i_val=neb_env%id_type,error=error) - CALL section_vals_val_get(neb_section,"NUMBER_OF_REPLICA",i_val=neb_env%number_of_replica,error=error) - CALL section_vals_val_get(neb_section,"K_SPRING",r_val=neb_env%K,error=error) - CALL section_vals_val_get(neb_section,"ROTATE_FRAMES",l_val=neb_env%rotate_frames,error=error) - CALL section_vals_val_get(neb_section,"ALIGN_FRAMES",l_val=neb_env%align_frames,error=error) - CALL section_vals_val_get(neb_section,"OPTIMIZE_BAND%OPTIMIZE_END_POINTS",l_val=neb_env%optimize_end_points,& - error=error) + CALL section_vals_val_get(neb_section,"BAND_TYPE",i_val=neb_env%id_type) + CALL section_vals_val_get(neb_section,"NUMBER_OF_REPLICA",i_val=neb_env%number_of_replica) + CALL section_vals_val_get(neb_section,"K_SPRING",r_val=neb_env%K) + CALL section_vals_val_get(neb_section,"ROTATE_FRAMES",l_val=neb_env%rotate_frames) + CALL section_vals_val_get(neb_section,"ALIGN_FRAMES",l_val=neb_env%align_frames) + CALL section_vals_val_get(neb_section,"OPTIMIZE_BAND%OPTIMIZE_END_POINTS",l_val=neb_env%optimize_end_points) ! Climb Image NEB - CALL section_vals_val_get(neb_section,"CI_NEB%NSTEPS_IT",i_val=neb_env%nsteps_it,error=error) + CALL section_vals_val_get(neb_section,"CI_NEB%NSTEPS_IT",i_val=neb_env%nsteps_it) ! Band Optimization Type - CALL section_vals_val_get(neb_section,"OPTIMIZE_BAND%OPT_TYPE",i_val=neb_env%opt_type,error=error) + CALL section_vals_val_get(neb_section,"OPTIMIZE_BAND%OPT_TYPE",i_val=neb_env%opt_type) ! Use colvars - CALL section_vals_val_get(neb_section,"USE_COLVARS",l_val=neb_env%use_colvar,error=error) - CALL section_vals_val_get(neb_section,"POT_TYPE",i_val=neb_env%pot_type,error=error) + CALL section_vals_val_get(neb_section,"USE_COLVARS",l_val=neb_env%use_colvar) + CALL section_vals_val_get(neb_section,"POT_TYPE",i_val=neb_env%pot_type) ! Before continuing let's do some consistency check between keywords IF (neb_env%pot_type/=pot_neb_full) THEN ! Requires the use of colvars @@ -121,27 +118,27 @@ SUBROUTINE read_neb_section(neb_env, neb_section,error) " was requested without enabling the usage of COLVARS. Both methods"//& " are based on COLVARS definition."//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) ! Moreover let's check if the proper sections have been defined.. SELECT CASE(neb_env%pot_type) CASE(pot_neb_fe) - wrk_section => section_vals_get_subs_vals(neb_env%root_section,"MOTION%MD",error=error) - CALL section_vals_get(wrk_section,explicit=explicit, error=error) + wrk_section => section_vals_get_subs_vals(neb_env%root_section,"MOTION%MD") + CALL section_vals_get(wrk_section,explicit=explicit) CALL cp_assert(explicit,& cp_failure_level,cp_assertion_failed,routineP,& "A free energy BAND (colvars projected) calculation is requested"//& " but NONE MD section was defined in the input."//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) CASE(pot_neb_me) - wrk_section => section_vals_get_subs_vals(neb_env%root_section,"MOTION%GEO_OPT",error=error) - CALL section_vals_get(wrk_section,explicit=explicit, error=error) + wrk_section => section_vals_get_subs_vals(neb_env%root_section,"MOTION%GEO_OPT") + CALL section_vals_get(wrk_section,explicit=explicit) CALL cp_assert(explicit,& cp_failure_level,cp_assertion_failed,routineP,& "A minimum energy BAND (colvars projected) calculation is requested"//& " but NONE GEO_OPT section was defined in the input."//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) END SELECT ELSE CALL cp_assert(.NOT.neb_env%use_colvar,& @@ -149,11 +146,11 @@ SUBROUTINE read_neb_section(neb_env, neb_section,error) "A band calculation was requested with a full potential energy. USE_COLVAR cannot"//& " be set for this kind of calculation!"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) END IF ! String Method - CALL section_vals_val_get(neb_section,"STRING_METHOD%SMOOTHING",r_val=neb_env%smoothing,error=error) - CALL section_vals_val_get(neb_section,"STRING_METHOD%SPLINE_ORDER",i_val=neb_env%spline_order,error=error) + CALL section_vals_val_get(neb_section,"STRING_METHOD%SMOOTHING",r_val=neb_env%smoothing) + CALL section_vals_val_get(neb_section,"STRING_METHOD%SPLINE_ORDER",i_val=neb_env%spline_order) neb_env%reparametrize_frames =.FALSE. IF (neb_env%id_type==do_sm) THEN neb_env%reparametrize_frames =.TRUE. @@ -172,11 +169,10 @@ END SUBROUTINE read_neb_section !> \param energies ... !> \param distances ... !> \param output_unit ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE dump_neb_info(neb_env, coords, vels, forces, particle_set, logger,& - istep, energies, distances, output_unit, error) + istep, energies, distances, output_unit) TYPE(neb_type), POINTER :: neb_env TYPE(neb_var_type), POINTER :: coords TYPE(neb_var_type), OPTIONAL, POINTER :: vels, forces @@ -186,7 +182,6 @@ SUBROUTINE dump_neb_info(neb_env, coords, vels, forces, particle_set, logger,& INTEGER, INTENT(IN) :: istep REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: energies, distances INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dump_neb_info', & routineP = moduleN//':'//routineN @@ -208,85 +203,85 @@ SUBROUTINE dump_neb_info(neb_env, coords, vels, forces, particle_set, logger,& failure = .FALSE. CALL timeset(routineN,handle) ndig = CEILING(LOG10(REAL(neb_env%number_of_replica+1,KIND=dp))) - CALL force_env_get(neb_env%force_env, cell=cell, error=error) + CALL force_env_get(neb_env%force_env, cell=cell) DO irep = 1, neb_env%number_of_replica ndigl = CEILING(LOG10(REAL(irep+1,KIND=dp))) WRITE(line,'(A,'//cp_to_string(ndig)//'("0"),T'//cp_to_string(11+ndig+1-ndigl)//',I0)')"Replica_nr_",irep crd = cp_print_key_unit_nr(logger,neb_env%motion_print_section,"TRAJECTORY",& - extension=".xyz",file_form="FORMATTED", middle_name="pos-"//TRIM(line), error=error) + extension=".xyz",file_form="FORMATTED", middle_name="pos-"//TRIM(line)) IF (PRESENT(vels)) THEN vel = cp_print_key_unit_nr(logger,neb_env%motion_print_section,"VELOCITIES",& - extension=".xyz",file_form="FORMATTED", middle_name="vel-"//TRIM(line), error=error) + extension=".xyz",file_form="FORMATTED", middle_name="vel-"//TRIM(line)) END IF IF (PRESENT(forces)) THEN frc = cp_print_key_unit_nr(logger,neb_env%motion_print_section,"FORCES",& - extension=".xyz",file_form="FORMATTED", middle_name="force-"//TRIM(line), error=error) + extension=".xyz",file_form="FORMATTED", middle_name="force-"//TRIM(line)) END IF ! Dump Trajectory IF (crd>0) THEN ! Gather units of measure for output CALL section_vals_val_get(neb_env%motion_print_section,"TRAJECTORY%UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) ! This information can be digested by Molden WRITE (UNIT=title,FMT="(A,I8,A,F20.10)")" i =",istep,", E =",energies(irep) CALL write_particle_coordinates(particle_set,crd,dump_xmol,"POS",title,& - cell=cell,array=coords%xyz(:,irep),unit_conv=unit_conv,error=error) + cell=cell,array=coords%xyz(:,irep),unit_conv=unit_conv) CALL m_flush(crd) END IF ! Dump Velocities IF (vel>0.AND.PRESENT(vels)) THEN ! Gather units of measure for output CALL section_vals_val_get(neb_env%motion_print_section,"VELOCITIES%UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) WRITE (UNIT=title,FMT="(A,I8,A,F20.10)")" i =",istep,", E =",energies(irep) CALL write_particle_coordinates(particle_set,vel,dump_xmol,"VEL",title,& - cell=cell,array=vels%xyz(:,irep),unit_conv=unit_conv,error=error) + cell=cell,array=vels%xyz(:,irep),unit_conv=unit_conv) CALL m_flush(vel) END IF ! Dump Forces IF (frc>0.AND.PRESENT(forces)) THEN ! Gather units of measure for output CALL section_vals_val_get(neb_env%motion_print_section,"FORCES%UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) WRITE (UNIT=title,FMT="(A,I8,A,F20.10)")" i =",istep,", E =",energies(irep) CALL write_particle_coordinates(particle_set,frc,dump_xmol,"FRC",title,& - cell=cell,array=forces%xyz(:,irep),unit_conv=unit_conv,error=error) + cell=cell,array=forces%xyz(:,irep),unit_conv=unit_conv) CALL m_flush(frc) END IF CALL cp_print_key_finished_output(crd,logger,neb_env%motion_print_section,& - "TRAJECTORY", error=error) + "TRAJECTORY") IF (PRESENT(vels)) THEN CALL cp_print_key_finished_output(vel,logger,neb_env%motion_print_section,& - "VELOCITIES", error=error) + "VELOCITIES") END IF IF (PRESENT(forces)) THEN CALL cp_print_key_finished_output(frc,logger,neb_env%motion_print_section,& - "FORCES", error=error) + "FORCES") END IF END DO ! NEB summary info on screen IF (output_unit>0) THEN - tc_section => section_vals_get_subs_vals(neb_env%neb_section,"OPTIMIZE_BAND%MD%TEMP_CONTROL",error=error) - vc_section => section_vals_get_subs_vals(neb_env%neb_section,"OPTIMIZE_BAND%MD%VEL_CONTROL",error=error) + tc_section => section_vals_get_subs_vals(neb_env%neb_section,"OPTIMIZE_BAND%MD%TEMP_CONTROL") + vc_section => section_vals_get_subs_vals(neb_env%neb_section,"OPTIMIZE_BAND%MD%VEL_CONTROL") ALLOCATE(temperatures(neb_env%number_of_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ekin(neb_env%number_of_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL get_temperatures(vels,particle_set,temperatures,ekin=ekin,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL get_temperatures(vels,particle_set,temperatures,ekin=ekin) WRITE(output_unit,'(/)',ADVANCE="NO") WRITE(output_unit,FMT='(A,A)')' **************************************', & '*****************************************' NULLIFY(section,keyword,enum) - CALL create_band_section(section,error=error) - keyword => section_get_keyword(section,"BAND_TYPE",error=error) - CALL keyword_get(keyword,enum=enum,error=error) - mytype=TRIM(enum_i2c(enum,neb_env%id_type,error=error)) + CALL create_band_section(section) + keyword => section_get_keyword(section,"BAND_TYPE") + CALL keyword_get(keyword,enum=enum) + mytype=TRIM(enum_i2c(enum,neb_env%id_type)) WRITE(output_unit,FMT='(A,T61,A)')& ' BAND TYPE =',ADJUSTR(mytype) - CALL section_release(section,error=error) + CALL section_release(section) WRITE(output_unit,FMT='(A,T61,A)')& ' BAND TYPE OPTIMIZATION =',ADJUSTR ( neb_env%opt_type_label(1:20)) WRITE ( output_unit, '( A,T71,I10 )' )& @@ -294,27 +289,27 @@ SUBROUTINE dump_neb_info(neb_env, coords, vels, forces, particle_set, logger,& IF (neb_env%rotate_frames) WRITE ( output_unit, '( A,T71,L10 )' )& ' RMSD DISTANCE DEFINITION =',neb_env%rotate_frames ! velocity control parameters output - CALL section_vals_get(vc_section,explicit=explicit,error=error) + CALL section_vals_get(vc_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(vc_section,"PROJ_VELOCITY_VERLET",l_val=lval, error=error) + CALL section_vals_val_get(vc_section,"PROJ_VELOCITY_VERLET",l_val=lval) IF (lval) WRITE ( output_unit, '( A,T71,L10 )' )& ' PROJECTED VELOCITY VERLET =',lval - CALL section_vals_val_get(vc_section,"SD_LIKE", l_val=lval, error=error) + CALL section_vals_val_get(vc_section,"SD_LIKE", l_val=lval) IF (lval) WRITE ( output_unit, '( A,T71,L10)' )& ' STEEPEST DESCENT LIKE =',lval - CALL section_vals_val_get(vc_section,"ANNEALING", r_val=f_ann, error=error) + CALL section_vals_val_get(vc_section,"ANNEALING", r_val=f_ann) IF (f_ann/=1.0_dp) THEN WRITE ( output_unit, '( A,T71,F10.5)' )& ' ANNEALING FACTOR = ',f_ann END IF END IF ! temperature control parameters output - CALL section_vals_get(tc_section,explicit=explicit,error=error) + CALL section_vals_get(tc_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(tc_section,"TEMP_TOL_STEPS",i_val=ttst, error=error) + CALL section_vals_val_get(tc_section,"TEMP_TOL_STEPS",i_val=ttst) IF (istep<=ttst) THEN - CALL section_vals_val_get(tc_section,"TEMPERATURE",r_val=f_ann, error=error) - tmp_r1 = cp_unit_from_cp2k(f_ann,"K",error=error) + CALL section_vals_val_get(tc_section,"TEMPERATURE",r_val=f_ann) + tmp_r1 = cp_unit_from_cp2k(f_ann,"K") WRITE ( output_unit, '( A,T71,F10.5)' )& ' TEMPERATURE TARGET =',tmp_r1 END IF @@ -345,28 +340,27 @@ SUBROUTINE dump_neb_info(neb_env, coords, vels, forces, particle_set, logger,& WRITE(output_unit,FMT='(A,A)')' **************************************', & '*****************************************' DEALLOCATE(ekin,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(temperatures,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Ener file ener = cp_print_key_unit_nr(logger,neb_env%neb_section,"ENERGY",& - extension=".ener",file_form="FORMATTED", error=error) + extension=".ener",file_form="FORMATTED") IF (ener>0) THEN WRITE(line,'(I0)')2*neb_env%number_of_replica-1 WRITE(ener,'(I10,'//TRIM(line)//'(1X,F20.9))')istep,& energies, distances END IF CALL cp_print_key_finished_output(ener,logger,neb_env%neb_section,& - "ENERGY", error=error) + "ENERGY") ! Dump Restarts CALL cp_add_default_logger(logger) CALL write_restart(force_env=neb_env%force_env,& root_section=neb_env%root_section,& coords=coords,& - vels=vels,& - error=error) + vels=vels) CALL cp_rm_default_logger() CALL timestop(handle) @@ -420,13 +414,11 @@ END SUBROUTINE dump_replica_coordinates !> \param irep ... !> \param n_rep ... !> \param istep ... -!> \param error ... !> \author Teodoro Laino 06.2009 ! ***************************************************************************** - SUBROUTINE handle_band_file_names(rep_env, irep, n_rep, istep, error) + SUBROUTINE handle_band_file_names(rep_env, irep, n_rep, istep) TYPE(replica_env_type), POINTER :: rep_env INTEGER, INTENT(IN) :: irep, n_rep, istep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'handle_band_file_names', & routineP = moduleN//':'//routineN @@ -436,7 +428,6 @@ SUBROUTINE handle_band_file_names(rep_env, irep, n_rep, istep, error) INTEGER :: handle, handle2, i, ierr, j, & lp, unit_nr LOGICAL :: failure - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger, sub_logger TYPE(f_env_type), POINTER :: f_env TYPE(section_vals_type), POINTER :: root_section @@ -444,21 +435,21 @@ SUBROUTINE handle_band_file_names(rep_env, irep, n_rep, istep, error) CALL timeset(routineN,handle) failure = .FALSE. CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env,& - new_error=new_error, failure=failure, handle=handle2) - logger => cp_error_get_logger(new_error) - CALL force_env_get(f_env%force_env,root_section=root_section,error=new_error) + failure=failure, handle=handle2) + logger => cp_get_default_logger() + CALL force_env_get(f_env%force_env,root_section=root_section) j = irep + (rep_env%local_rep_indices(1)-1) ! Get replica_project_name replica_proj_name = get_replica_project_name(rep_env, n_rep, j) lp=LEN_TRIM(replica_proj_name) CALL section_vals_val_set(root_section,"GLOBAL%PROJECT_NAME",& - c_val=TRIM(replica_proj_name),error=error) + c_val=TRIM(replica_proj_name)) logger%iter_info%project_name=replica_proj_name ! We change the file on which is pointing the global logger and error output_file_path=replica_proj_name(1:lp)//".out" CALL section_vals_val_set(root_section,"GLOBAL%OUTPUT_FILE_NAME",& - c_val=TRIM(output_file_path),error=error) + c_val=TRIM(output_file_path)) IF (logger%default_global_unit_nr>0) THEN CALL close_file(logger%default_global_unit_nr) CALL open_file(file_name=output_file_path,file_status="UNKNOWN",& @@ -501,8 +492,8 @@ SUBROUTINE handle_band_file_names(rep_env, irep, n_rep, istep, error) END DO END SELECT - CALL f_env_rm_defaults(f_env=f_env,error=new_error,ierr=ierr,handle=handle2) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL f_env_rm_defaults(f_env=f_env,ierr=ierr,handle=handle2) + CPAssert(ierr==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE handle_band_file_names @@ -548,13 +539,11 @@ END FUNCTION get_replica_project_name !> replica !> \param rep_env ... !> \param neb_env ... -!> \param error ... !> \author Teodoro Laino 06.2009 ! ***************************************************************************** - SUBROUTINE neb_rep_env_map_info(rep_env, neb_env, error) + SUBROUTINE neb_rep_env_map_info(rep_env, neb_env) TYPE(replica_env_type), POINTER :: rep_env TYPE(neb_type), POINTER :: neb_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_rep_env_map_info', & routineP = moduleN//':'//routineN @@ -563,7 +552,6 @@ SUBROUTINE neb_rep_env_map_info(rep_env, neb_env, error) INTEGER :: handle2, ierr, irep, n_rep, & n_rep_neb, output_unit LOGICAL :: failure - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(f_env_type), POINTER :: f_env @@ -571,8 +559,8 @@ SUBROUTINE neb_rep_env_map_info(rep_env, neb_env, error) n_rep_neb = neb_env%number_of_replica n_rep = rep_env%nrep CALL f_env_add_defaults(f_env_id=rep_env%f_env_id, f_env=f_env,& - new_error=new_error, failure=failure, handle=handle2) - logger => cp_error_get_logger(new_error) + failure=failure, handle=handle2) + logger => cp_get_default_logger() output_unit = logger%default_global_unit_nr IF (output_unit > 0) THEN WRITE (UNIT=output_unit,FMT='(/,(T2,A79))')& @@ -603,8 +591,8 @@ SUBROUTINE neb_rep_env_map_info(rep_env, neb_env, error) CALL get_runtime_info() ! print footer CALL cp2k_footer(output_unit) - CALL f_env_rm_defaults(f_env=f_env,error=new_error,ierr=ierr,handle=handle2) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL f_env_rm_defaults(f_env=f_env,ierr=ierr,handle=handle2) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE neb_rep_env_map_info END MODULE neb_io diff --git a/src/motion/neb_md_utils.F b/src/motion/neb_md_utils.F index 6d3f93102e..dc7600896b 100644 --- a/src/motion/neb_md_utils.F +++ b/src/motion/neb_md_utils.F @@ -56,13 +56,12 @@ MODULE neb_md_utils !> \param iw ... !> \param globenv ... !> \param neb_env ... -!> \param error ... !> \par History !> 25.11.2010 Consider core-shell model (MK) !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE neb_initialize_velocity(vels,neb_section,particle_set,i_rep,iw,& - globenv,neb_env,error) + globenv,neb_env) REAL(KIND=dp), DIMENSION(:, :), POINTER :: vels TYPE(section_vals_type), POINTER :: neb_section @@ -71,7 +70,6 @@ SUBROUTINE neb_initialize_velocity(vels,neb_section,particle_set,i_rep,iw,& INTEGER, INTENT(IN) :: i_rep, iw TYPE(global_environment_type), POINTER :: globenv TYPE(neb_type), POINTER :: neb_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'neb_initialize_velocity', & routineP = moduleN//':'//routineN @@ -84,8 +82,8 @@ SUBROUTINE neb_initialize_velocity(vels,neb_section,particle_set,i_rep,iw,& TYPE(section_vals_type), POINTER :: md_section IF (neb_env%opt_type == band_md_opt) THEN - md_section => section_vals_get_subs_vals(neb_section,"OPTIMIZE_BAND%MD",error=error) - CALL section_vals_val_get(md_section,"TEMPERATURE",r_val=temp_ext,error=error) + md_section => section_vals_get_subs_vals(neb_section,"OPTIMIZE_BAND%MD") + CALL section_vals_val_get(md_section,"TEMPERATURE",r_val=temp_ext) ! Initialize velocity according to external temperature nparticle = SIZE(vels,1) natom = SIZE(particle_set) @@ -93,7 +91,7 @@ SUBROUTINE neb_initialize_velocity(vels,neb_section,particle_set,i_rep,iw,& vcom(1:3) = 0.0_dp vels(:,i_rep) = 0.0_dp DO k=1,nparticle - vels(k,i_rep) = next_random_number(globenv%gaussian_rng_stream,error=error) + vels(k,i_rep) = next_random_number(globenv%gaussian_rng_stream) END DO ! Check always if BAND is working in Cartesian or in internal coordinates ! If working in cartesian coordinates let's get rid of the COM @@ -148,7 +146,7 @@ SUBROUTINE neb_initialize_velocity(vels,neb_section,particle_set,i_rep,iw,& ! Dump information IF (iw > 0) THEN temp = 2.0_dp*akin/REAL(nvar,KIND=dp) - tmp_r1 = cp_unit_from_cp2k(temp,"K",error=error) + tmp_r1 = cp_unit_from_cp2k(temp,"K") WRITE (iw,'(A,T61,F18.2,A2)')& ' NEB| Initial Temperature ',tmp_r1," K" WRITE (iw,'(A,T61,F20.12)')& @@ -171,17 +169,15 @@ END SUBROUTINE neb_initialize_velocity !> \param vc_section ... !> \param output_unit ... !> \param istep ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE control_vels_a(vels, particle_set, tc_section, vc_section, & - output_unit, istep, error) + output_unit, istep) TYPE(neb_var_type), POINTER :: vels TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(section_vals_type), POINTER :: tc_section, vc_section INTEGER, INTENT(IN) :: output_unit, istep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'control_vels_a', & routineP = moduleN//':'//routineN @@ -195,23 +191,23 @@ SUBROUTINE control_vels_a(vels, particle_set, tc_section, vc_section, & failure = .FALSE. ! Temperature control - CALL section_vals_get(tc_section,explicit=explicit,error=error) + CALL section_vals_get(tc_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(tc_section,"TEMP_TOL_STEPS",i_val=temp_tol_steps, error=error) - CALL section_vals_val_get(tc_section,"TEMPERATURE",r_val=ext_temp, error=error) - CALL section_vals_val_get(tc_section,"TEMP_TOL",r_val=temp_tol, error=error) + CALL section_vals_val_get(tc_section,"TEMP_TOL_STEPS",i_val=temp_tol_steps) + CALL section_vals_val_get(tc_section,"TEMPERATURE",r_val=ext_temp) + CALL section_vals_val_get(tc_section,"TEMP_TOL",r_val=temp_tol) ALLOCATE(temperatures(SIZE(vels%wrk,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Computes temperatures - CALL get_temperatures(vels,particle_set,temperatures,factor=1.0_dp,error=error) + CALL get_temperatures(vels,particle_set,temperatures,factor=1.0_dp) ! Possibly rescale IF (istep<=temp_tol_steps) THEN DO i = 2, SIZE(vels%wrk,2)-1 temploc = temperatures(i) IF (ABS(temploc-ext_temp) > temp_tol) THEN IF (output_unit>0) THEN - tmp_r1 =cp_unit_from_cp2k(temploc,"K",error=error) - tmp_r2 =cp_unit_from_cp2k(ext_temp,"K",error=error) + tmp_r1 =cp_unit_from_cp2k(temploc,"K") + tmp_r2 =cp_unit_from_cp2k(ext_temp,"K") WRITE(output_unit,'(T2,"NEB| Replica Nr.",I5,'//& '" - Velocity rescaled from: ",F12.6," to: ",F12.6,".")')& i, tmp_r1, tmp_r2 @@ -223,12 +219,12 @@ SUBROUTINE control_vels_a(vels, particle_set, tc_section, vc_section, & END DO END IF DEALLOCATE(temperatures,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Annealing - CALL section_vals_get(vc_section,explicit=explicit,error=error) + CALL section_vals_get(vc_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(vc_section,"ANNEALING",r_val=f_annealing, error=error) + CALL section_vals_val_get(vc_section,"ANNEALING",r_val=f_annealing) DO i = 2, SIZE(vels%wrk,2)-1 vels%wrk(:,i) = f_annealing * vels%wrk(:,i) END DO @@ -240,13 +236,11 @@ END SUBROUTINE control_vels_a !> \param vels ... !> \param forces ... !> \param vc_section ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE control_vels_b(vels, forces, vc_section, error) + SUBROUTINE control_vels_b(vels, forces, vc_section) TYPE(neb_var_type), POINTER :: vels, forces TYPE(section_vals_type), POINTER :: vc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'control_vels_b', & routineP = moduleN//':'//routineN @@ -257,9 +251,9 @@ SUBROUTINE control_vels_b(vels, forces, vc_section, error) ! Check the sign of V.dot.F - CALL section_vals_get(vc_section,explicit=explicit,error=error) + CALL section_vals_get(vc_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(vc_section,"PROJ_VELOCITY_VERLET",l_val=lval, error=error) + CALL section_vals_val_get(vc_section,"PROJ_VELOCITY_VERLET",l_val=lval) IF (lval) THEN DO i = 2, SIZE(vels%wrk,2)-1 norm = DOT_PRODUCT(forces%wrk(:,i),forces%wrk(:,i)) @@ -271,7 +265,7 @@ SUBROUTINE control_vels_b(vels, forces, vc_section, error) END IF END DO END IF - CALL section_vals_val_get(vc_section,"SD_LIKE",l_val=lval, error=error) + CALL section_vals_val_get(vc_section,"SD_LIKE",l_val=lval) IF (lval) THEN DO i = 2, SIZE(vels%wrk,2)-1 vels%wrk(:,i) = 0.0_dp @@ -287,12 +281,11 @@ END SUBROUTINE control_vels_b !> \param temperatures ... !> \param ekin ... !> \param factor ... -!> \param error ... !> \par History !> 24.11.2010 rewritten to include core-shell model (MK) !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE get_temperatures(vels,particle_set,temperatures,ekin,factor,error) + SUBROUTINE get_temperatures(vels,particle_set,temperatures,ekin,factor) TYPE(neb_var_type), POINTER :: vels TYPE(particle_type), DIMENSION(:), & @@ -301,7 +294,6 @@ SUBROUTINE get_temperatures(vels,particle_set,temperatures,ekin,factor,error) REAL(KIND=dp), DIMENSION(:), & INTENT(OUT), OPTIONAL :: ekin REAL(KIND=dp), INTENT(IN), OPTIONAL :: factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_temperatures', & routineP = moduleN//':'//routineN diff --git a/src/motion/neb_methods.F b/src/motion/neb_methods.F index 4873cc336c..9ffdfab127 100644 --- a/src/motion/neb_methods.F +++ b/src/motion/neb_methods.F @@ -82,17 +82,15 @@ MODULE neb_methods !> \param input_declaration ... !> \param para_env ... !> \param globenv ... -!> \param error ... !> \author Teodoro Laino 09.2006 !> \note !> Based on the use of replica_env ! ***************************************************************************** - SUBROUTINE neb(input, input_declaration, para_env, globenv, error) + SUBROUTINE neb(input, input_declaration, para_env, globenv) TYPE(section_vals_type), POINTER :: input TYPE(section_type), POINTER :: input_declaration TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb', & routineP = moduleN//':'//routineN @@ -101,7 +99,6 @@ SUBROUTINE neb(input, input_declaration, para_env, globenv, error) output_unit, prep, & proc_dist_type, stat LOGICAL :: check, failure, row_force - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env @@ -117,15 +114,15 @@ SUBROUTINE neb(input, input_declaration, para_env, globenv, error) failure = .FALSE. NULLIFY(logger, subsys, f_env, rep_env) NULLIFY(forces, coords, vels, neb_env) - logger => cp_error_get_logger(error) - CALL cp_add_iter_level(logger%iter_info,"BAND",error=error) - motion_section => section_vals_get_subs_vals(input,"MOTION",error=error) - print_section => section_vals_get_subs_vals(motion_section,"PRINT",error=error) - neb_section => section_vals_get_subs_vals(motion_section,"BAND",error=error) + logger => cp_get_default_logger() + CALL cp_add_iter_level(logger%iter_info,"BAND") + motion_section => section_vals_get_subs_vals(input,"MOTION") + print_section => section_vals_get_subs_vals(motion_section,"PRINT") + neb_section => section_vals_get_subs_vals(motion_section,"BAND") output_unit=cp_print_key_unit_nr(logger,neb_section,"PROGRAM_RUN_INFO",& - extension=".nebLog",error=error) - CALL section_vals_val_get(neb_section,"NPROC_REP",i_val=prep, error=error) - CALL section_vals_val_get(neb_section,"PROC_DIST_TYPE",i_val=proc_dist_type, error=error) + extension=".nebLog") + CALL section_vals_val_get(neb_section,"NPROC_REP",i_val=prep) + CALL section_vals_val_get(neb_section,"PROC_DIST_TYPE",i_val=proc_dist_type) row_force = (proc_dist_type==do_rep_blocked) nrep = MAX(1,para_env%num_pe/prep) CALL cp_assert(.NOT.(nrep*prep/=para_env%num_pe.AND.output_unit>0),& @@ -136,81 +133,81 @@ SUBROUTINE neb(input, input_declaration, para_env, globenv, error) TRIM(ADJUSTL(cp_to_string(nrep)))//") . ["//& TRIM(ADJUSTL(cp_to_string(para_env%num_pe-nrep*prep)))//"] processors will be wasted! "//& CPSourceFileRef, only_ionode=.TRUE.) - force_env_section => section_vals_get_subs_vals(input,"FORCE_EVAL",error=error) + force_env_section => section_vals_get_subs_vals(input,"FORCE_EVAL") ! Create Replica Environments IF (output_unit>0) WRITE(output_unit,'(T2,"NEB|",A)')" Replica_env Setup. START" CALL rep_env_create(rep_env, para_env=para_env, input=input,& - input_declaration=input_declaration,nrep=nrep,prep=prep,row_force=row_force,error=error) - CPPostcondition(SIZE(rep_env%local_rep_indices)==1,cp_failure_level,routineP,error,failure) + input_declaration=input_declaration,nrep=nrep,prep=prep,row_force=row_force) + CPPostcondition(SIZE(rep_env%local_rep_indices)==1,cp_failure_level,routineP,failure) IF (output_unit>0) WRITE(output_unit,'(T2,"NEB|",A)')" Replica_env Setup. END" IF (ASSOCIATED(rep_env)) THEN CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure) - CALL force_env_get(f_env%force_env,subsys=subsys,error=error) + failure=failure) + CALL force_env_get(f_env%force_env,subsys=subsys) particle_set => subsys%particles%els ! Read NEB controlling parameters ALLOCATE (neb_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) neb_env%force_env => f_env%force_env neb_env%root_section => input neb_env%force_env_section => force_env_section neb_env%motion_print_section => print_section neb_env%neb_section => neb_section neb_env%nsize_xyz = rep_env%ndim - neb_env%nsize_int = number_of_colvar(f_env%force_env, error=error) + neb_env%nsize_int = number_of_colvar(f_env%force_env) check = (neb_env%nsize_xyz >= neb_env%nsize_int) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ! Check that teh used colvar are uniquely determined - check = (number_of_colvar(f_env%force_env, error=error) == & - number_of_colvar(f_env%force_env, unique=.TRUE., error=error)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) - CALL read_neb_section(neb_env,neb_section,error=error) + check = (number_of_colvar(f_env%force_env) == & + number_of_colvar(f_env%force_env, unique=.TRUE.)) + CPPostcondition(check,cp_failure_level,routineP,failure) + CALL read_neb_section(neb_env,neb_section) ! Print BAND header - iw2=cp_print_key_unit_nr(logger,neb_section,"BANNER",extension=".nebLog",error=error) + iw2=cp_print_key_unit_nr(logger,neb_section,"BANNER",extension=".nebLog") CALL band_header(iw2, neb_env%number_of_replica, nrep, prep) - CALL cp_print_key_finished_output(iw2,logger,neb_section,"BANNER", error=error) + CALL cp_print_key_finished_output(iw2,logger,neb_section,"BANNER") ! Allocate the principal vectors used in the BAND calculation - CALL neb_var_create(coords, neb_env, full_allocation=.TRUE., error=error) - CALL neb_var_create(forces, neb_env, error=error) - CALL neb_var_create(vels, neb_env, error=error) + CALL neb_var_create(coords, neb_env, full_allocation=.TRUE.) + CALL neb_var_create(forces, neb_env) + CALL neb_var_create(vels, neb_env) ! Collecting the coordinates of the starting replicas of the BAND calculation IF (output_unit>0) WRITE(output_unit,'(T2,"NEB|",A)')" Building initial set of coordinates. START" iw = cp_print_key_unit_nr(logger,neb_section,"PROGRAM_RUN_INFO/INITIAL_CONFIGURATION_INFO",& - extension=".nebLog",error=error) + extension=".nebLog") CALL build_replica_coords(neb_section,particle_set,coords,vels,neb_env,iw,globenv,& - rep_env%para_env,error) + rep_env%para_env) CALL cp_print_key_finished_output(iw,logger,neb_section,& - "PROGRAM_RUN_INFO/INITIAL_CONFIGURATION_INFO", error=error) + "PROGRAM_RUN_INFO/INITIAL_CONFIGURATION_INFO") IF (output_unit > 0) WRITE (output_unit,'(T2,"NEB|",A)')" Building initial set of coordinates. END" ! Print some additional info in the replica_env initialization file - CALL neb_rep_env_map_info(rep_env, neb_env, error) + CALL neb_rep_env_map_info(rep_env, neb_env) ! Perform NEB optimization SELECT CASE(neb_env%opt_type) CASE (band_md_opt) neb_env%opt_type_label = "MOLECULAR DYNAMICS" - md_section => section_vals_get_subs_vals(neb_section,"OPTIMIZE_BAND%MD",error=error) + md_section => section_vals_get_subs_vals(neb_section,"OPTIMIZE_BAND%MD") CALL neb_md(rep_env, neb_env, coords, vels, forces, particle_set, output_unit,& - md_section, logger, globenv, error) + md_section, logger, globenv) CASE (band_diis_opt) neb_env%opt_type_label = "DIIS" - diis_section => section_vals_get_subs_vals(neb_section,"OPTIMIZE_BAND%DIIS",error=error) + diis_section => section_vals_get_subs_vals(neb_section,"OPTIMIZE_BAND%DIIS") CALL neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output_unit,& - diis_section, logger, globenv, error) + diis_section, logger, globenv) END SELECT ! Release force_eval - CALL f_env_rm_defaults(f_env,new_error,ierr) + CALL f_env_rm_defaults(f_env,ierr) ! Release coords, vels and forces - CALL neb_var_release(coords, error) - CALL neb_var_release(forces, error) - CALL neb_var_release(vels, error) + CALL neb_var_release(coords) + CALL neb_var_release(forces) + CALL neb_var_release(vels) ! At the end let's destroy the environment of the BAND calculation DEALLOCATE(neb_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL rep_env_release(rep_env,error=error) + CALL rep_env_release(rep_env) CALL cp_print_key_finished_output(output_unit,logger,neb_section,& - "PROGRAM_RUN_INFO", error=error) - CALL cp_rm_iter_level(logger%iter_info,"BAND",error=error) + "PROGRAM_RUN_INFO") + CALL cp_rm_iter_level(logger%iter_info,"BAND") CALL timestop(handle) END SUBROUTINE neb @@ -226,11 +223,10 @@ END SUBROUTINE neb !> \param md_section ... !> \param logger ... !> \param globenv ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE neb_md(rep_env, neb_env, coords, vels, forces, particle_set, output_unit,& - md_section, logger, globenv, error) + md_section, logger, globenv) TYPE(replica_env_type), POINTER :: rep_env TYPE(neb_type), OPTIONAL, POINTER :: neb_env TYPE(neb_var_type), POINTER :: coords, vels, forces @@ -240,7 +236,6 @@ SUBROUTINE neb_md(rep_env, neb_env, coords, vels, forces, particle_set, output_u TYPE(section_vals_type), POINTER :: md_section TYPE(cp_logger_type), POINTER :: logger TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_md', & routineP = moduleN//':'//routineN @@ -260,29 +255,29 @@ SUBROUTINE neb_md(rep_env, neb_env, coords, vels, forces, particle_set, output_u CALL timeset(routineN,handle) failure = .FALSE. NULLIFY( Dcoords, tc_section, vc_section) - CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(vels),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(vels),cp_failure_level,routineP,failure) ! MD band for string methods type does not make anywa sense. Stop calculation. IF (neb_env%id_type==do_sm) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="MD band optimization and String Method incompatible.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Output unit iw=cp_print_key_unit_nr(logger,neb_env%neb_section,"REPLICA_INFO",& - extension=".replicaLog",error=error) - tc_section => section_vals_get_subs_vals(md_section,"TEMP_CONTROL",error=error) - vc_section => section_vals_get_subs_vals(md_section,"VEL_CONTROL",error=error) - CALL section_vals_val_get(md_section,"TIMESTEP",r_val=dt, error=error) - CALL section_vals_val_get(md_section,"MAX_STEPS",i_val=max_steps, error=error) + extension=".replicaLog") + tc_section => section_vals_get_subs_vals(md_section,"TEMP_CONTROL") + vc_section => section_vals_get_subs_vals(md_section,"VEL_CONTROL") + CALL section_vals_val_get(md_section,"TIMESTEP",r_val=dt) + CALL section_vals_val_get(md_section,"MAX_STEPS",i_val=max_steps) ! Initial setup for MD - CALL neb_var_create(Dcoords, neb_env, error=error) + CALL neb_var_create(Dcoords, neb_env) ALLOCATE (mass(SIZE(coords%wrk,1),neb_env%number_of_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (energies(neb_env%number_of_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (distances(neb_env%number_of_replica-1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Setting up the mass array IF (neb_env%use_colvar) THEN mass(:,:) = 0.5_dp*dt/massunit @@ -302,10 +297,10 @@ SUBROUTINE neb_md(rep_env, neb_env, coords, vels, forces, particle_set, output_u END IF ! Initializing forces array CALL reorient_images(neb_env%rotate_frames, particle_set, coords, vels,& - output_unit, distances, neb_env%number_of_replica, error=error) + output_unit, distances, neb_env%number_of_replica) neb_env%avg_distance = SQRT(SUM(distances*distances)/REAL(SIZE(distances),KIND=dp)) CALL neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& - particle_set, iw, error) + particle_set, iw) CALL dump_neb_info(neb_env=neb_env,& coords=coords,& @@ -316,31 +311,30 @@ SUBROUTINE neb_md(rep_env, neb_env, coords, vels, forces, particle_set, output_u istep=0,& energies=energies,& distances=distances,& - output_unit=output_unit,& - error=error) + output_unit=output_unit) md_opt_loop: DO istep = 1, max_steps - CALL cp_iterate(logger%iter_info,iter_nr=istep,error=error) + CALL cp_iterate(logger%iter_info,iter_nr=istep) ! Save the optimization step counter neb_env%istep = istep ! Velocity Verlet (first part) vels%wrk(:,:) = vels%wrk(:,:) + mass(:,:)*forces%wrk(:,:) ! Control on velocity - I part [rescale, annealing] CALL control_vels_a(vels, particle_set, tc_section, vc_section, output_unit,& - istep, error) + istep) ! Coordinate step Dcoords%wrk(:,:) = dt*vels%wrk(:,:) coords%wrk(:,:) = coords%wrk(:,:) + Dcoords%wrk(:,:) CALL reorient_images(neb_env%rotate_frames, particle_set, coords, vels,& - output_unit, distances, neb_env%number_of_replica, error=error) + output_unit, distances, neb_env%number_of_replica) neb_env%avg_distance = SQRT(SUM(distances*distances)/REAL(SIZE(distances),KIND=dp)) CALL neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& - particle_set, iw, error) + particle_set, iw) ! Check for an external exit command - CALL external_control(should_stop,"NEB",globenv=globenv,error=error) + CALL external_control(should_stop,"NEB",globenv=globenv) IF(should_stop) EXIT ! Control on velocity - II part [check vels VS forces, Steepest Descent like] - CALL control_vels_b(vels, forces, vc_section, error) + CALL control_vels_b(vels, forces, vc_section) ! Velocity Verlet (second part) vels%wrk(:,:) = vels%wrk(:,:) + mass(:,:)*forces%wrk(:,:) ! Dump Infos @@ -353,21 +347,20 @@ SUBROUTINE neb_md(rep_env, neb_env, coords, vels, forces, particle_set, output_u istep=istep,& energies=energies,& distances=distances,& - output_unit=output_unit,& - error=error) - converged = check_convergence(neb_env, Dcoords, forces, error) + output_unit=output_unit) + converged = check_convergence(neb_env, Dcoords, forces) IF (converged) EXIT END DO md_opt_loop DEALLOCATE (mass,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (energies,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (distances,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL neb_var_release(Dcoords, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL neb_var_release(Dcoords) CALL cp_print_key_finished_output(iw,logger,neb_env%neb_section,& - "REPLICA_INFO", error=error) + "REPLICA_INFO") CALL timestop(handle) END SUBROUTINE neb_md @@ -384,11 +377,10 @@ END SUBROUTINE neb_md !> \param diis_section ... !> \param logger ... !> \param globenv ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output_unit,& - diis_section, logger, globenv, error) + diis_section, logger, globenv) TYPE(replica_env_type), POINTER :: rep_env TYPE(neb_type), OPTIONAL, POINTER :: neb_env TYPE(neb_var_type), POINTER :: coords, vels, forces @@ -398,7 +390,6 @@ SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output TYPE(section_vals_type), POINTER :: diis_section TYPE(cp_logger_type), POINTER :: logger TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_diis', & routineP = moduleN//':'//routineN @@ -421,43 +412,43 @@ SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output NULLIFY(sline, crr, err) neb_env%opt_type_label = "SD" do_ls = .TRUE. - CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(vels),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(forces),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(vels),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(forces),cp_failure_level,routineP,failure) iw=cp_print_key_unit_nr(logger,neb_env%neb_section,"REPLICA_INFO",& - extension=".replicaLog",error=error) - CALL section_vals_val_get(diis_section,"MAX_STEPS",i_val=max_steps, error=error) - CALL section_vals_val_get(diis_section,"N_DIIS",i_val=n_diis, error=error) - CALL section_vals_val_get(diis_section,"STEPSIZE",r_val=stepsize0, error=error) - CALL section_vals_val_get(diis_section,"MAX_STEPSIZE",r_val=max_stepsize, error=error) - CALL section_vals_val_get(diis_section,"NO_LS",l_val=skip_ls, error=error) - CALL section_vals_val_get(diis_section,"MAX_SD_STEPS",i_val=max_sd_steps, error=error) - CALL section_vals_val_get(diis_section,"CHECK_DIIS",l_val=check_diis, error=error) + extension=".replicaLog") + CALL section_vals_val_get(diis_section,"MAX_STEPS",i_val=max_steps) + CALL section_vals_val_get(diis_section,"N_DIIS",i_val=n_diis) + CALL section_vals_val_get(diis_section,"STEPSIZE",r_val=stepsize0) + CALL section_vals_val_get(diis_section,"MAX_STEPSIZE",r_val=max_stepsize) + CALL section_vals_val_get(diis_section,"NO_LS",l_val=skip_ls) + CALL section_vals_val_get(diis_section,"MAX_SD_STEPS",i_val=max_sd_steps) + CALL section_vals_val_get(diis_section,"CHECK_DIIS",l_val=check_diis) iw2 = cp_print_key_unit_nr(logger,diis_section,"DIIS_INFO",& - extension=".diisLog",error=error) + extension=".diisLog") ! Initial setup for DIIS stepsize = stepsize0 ! Allocate type for Line Search direction - CALL neb_var_create(sline, neb_env, full_allocation=.TRUE., error=error) + CALL neb_var_create(sline, neb_env, full_allocation=.TRUE.) ! Array of error vectors ALLOCATE (err(PRODUCT(coords%size_wrk),n_diis),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (crr(PRODUCT(coords%size_wrk),n_diis),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (set_err(n_diis),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (energies(neb_env%number_of_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (distances(neb_env%number_of_replica-1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Initializing forces array CALL reorient_images(neb_env%rotate_frames, particle_set, coords, vels,& - output_unit, distances, neb_env%number_of_replica, error=error) + output_unit, distances, neb_env%number_of_replica) CALL reparametrize_images(neb_env%reparametrize_frames, neb_env%spline_order,& - neb_env%smoothing, coords%wrk, sline%wrk, distances, error) + neb_env%smoothing, coords%wrk, sline%wrk, distances) neb_env%avg_distance = SQRT(SUM(distances*distances)/REAL(SIZE(distances),KIND=dp)) CALL neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& - particle_set, iw, error) + particle_set, iw) ! Dump Infos CALL dump_neb_info(neb_env=neb_env,& coords=coords,& @@ -468,15 +459,14 @@ SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output energies=energies,& distances=distances,& vels=vels,& - output_unit=output_unit,& - error=error) + output_unit=output_unit) ! If rotation is requested let's apply it at the beginning of the ! Geometry optimization and then let's disable it neb_env%rotate_frames= .FALSE. ! Main SD/DIIS loop set_err = -1 DO istep = 1, max_steps - CALL cp_iterate(logger%iter_info,iter_nr=istep,error=error) + CALL cp_iterate(logger%iter_info,iter_nr=istep) neb_env%opt_type_label="SD" ! Save the optimization step counter neb_env%istep = istep @@ -490,7 +480,7 @@ SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output sline%wrk = forces%wrk / norm IF (do_ls.AND.(.NOT.skip_ls)) THEN CALL neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces,& - vels, particle_set, iw, output_unit, distances, diis_section, iw2, error) + vels, particle_set, iw, output_unit, distances, diis_section, iw2) IF (iw2>0) & WRITE(iw2,'(T2,A,T69,F12.6)')"SD| Stepsize in SD after linesearch",& stepsize @@ -502,7 +492,7 @@ SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output END IF sline%wrk = stepsize*sline%wrk diis_on = accept_diis_step(istep>max_sd_steps,n_diis,err,crr,set_err,sline,coords,& - check_diis,iw2,error) + check_diis,iw2) IF (diis_on) THEN neb_env%opt_type_label= "DIIS" END IF @@ -511,14 +501,14 @@ SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output coords%wrk = coords%wrk + sline%wrk ! Compute forces CALL reorient_images(neb_env%rotate_frames, particle_set, coords, vels,& - output_unit, distances, neb_env%number_of_replica, error) + output_unit, distances, neb_env%number_of_replica) CALL reparametrize_images(neb_env%reparametrize_frames, neb_env%spline_order,& - neb_env%smoothing, coords%wrk, sline%wrk, distances, error) + neb_env%smoothing, coords%wrk, sline%wrk, distances) neb_env%avg_distance = SQRT(SUM(distances*distances)/REAL(SIZE(distances),KIND=dp)) CALL neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& - particle_set, iw, error) + particle_set, iw) ! Check for an external exit command - CALL external_control(should_stop,"NEB",globenv=globenv,error=error) + CALL external_control(should_stop,"NEB",globenv=globenv) IF(should_stop) EXIT ! Dump Infos CALL dump_neb_info(neb_env=neb_env,& @@ -530,23 +520,22 @@ SUBROUTINE neb_diis(rep_env, neb_env, coords, vels, forces, particle_set, output energies=energies,& distances=distances,& vels=vels,& - output_unit=output_unit,& - error=error) + output_unit=output_unit) - converged = check_convergence(neb_env, sline, forces, error) + converged = check_convergence(neb_env, sline, forces) IF (converged) EXIT END DO DEALLOCATE (energies, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (distances, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (err, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (crr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (set_err, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL neb_var_release(sline, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL neb_var_release(sline) CALL timestop(handle) END SUBROUTINE neb_diis diff --git a/src/motion/neb_opt_utils.F b/src/motion/neb_opt_utils.F index 68f94ce9bf..add4600c5e 100644 --- a/src/motion/neb_opt_utils.F +++ b/src/motion/neb_opt_utils.F @@ -52,12 +52,11 @@ MODULE neb_opt_utils !> \param coords ... !> \param check_diis ... !> \param iw2 ... -!> \param error ... !> \retval accepted ... !> \author Teodoro Laino 10.2006 ! ***************************************************************************** FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& - check_diis,iw2,error) RESULT(accepted) + check_diis,iw2) RESULT(accepted) LOGICAL, INTENT(IN) :: apply_diis INTEGER, INTENT(IN) :: n_diis REAL(KIND=dp), DIMENSION(:, :), POINTER :: err, crr @@ -65,7 +64,6 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& TYPE(neb_var_type), POINTER :: sline, coords LOGICAL, INTENT(IN) :: check_diis INTEGER, INTENT(IN) :: iw2 - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: accepted CHARACTER(len=*), PARAMETER :: routineN = 'accept_diis_step', & @@ -86,7 +84,7 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_logger_get_default_io_unit(logger) failure = .FALSE. accepted = .FALSE. @@ -96,9 +94,9 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& set_err(nv) = 1 eps_svd = 1.0E-10_dp ALLOCATE(step(sline%size_wrk(1)*sline%size_wrk(2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ref(sline%size_wrk(1)*sline%size_wrk(2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) err(:,nv) = RESHAPE(sline%wrk, (/sline%size_wrk(1) *sline%size_wrk(2)/)) crr(:,nv) = RESHAPE(coords%wrk,(/coords%size_wrk(1)*coords%size_wrk(2)/)) jv = n_diis @@ -110,15 +108,15 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& IF (iw2>0) WRITE(iw2,'(A,I5,A)')"Applying DIIS equations with the last",& jv," error vectors" ALLOCATE(wrk(np,np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work(np,np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wrk_inv(np,np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cwrk(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(awrk(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) awrk = 0.0_dp wrk = 1.0_dp wrk(np,np) = 0.0_dp @@ -140,22 +138,22 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& work=TRANSPOSE(wrk) ! Workspace query ALLOCATE(iwork(8*np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(S(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(U(np,np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(VT(np,np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work_dgesdd(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lwork=-1 CALL DGESDD('S',np,np,work,np,S,U,np,vt,np,work_dgesdd,lwork,iwork,info) lwork=INT(work_dgesdd(1)) DEALLOCATE(work_dgesdd,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work_dgesdd(lwork),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL DGESDD('S',np,np,work,np,S,U,np,vt,np,work_dgesdd,lwork,iwork,info) ! Construct the inverse DO k=1,np @@ -169,15 +167,15 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& ENDDO CALL DGEMM('T','T',np,np,np,1.0_dp,VT,np,U,np,0.0_dp,wrk_inv,np) DEALLOCATE(iwork,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(S,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(U,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(VT,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work_dgesdd,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) cwrk = MATMUL(wrk_inv,awrk) ! Check the DIIS solution step = 0.0_dp @@ -189,34 +187,34 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& step = step - crr(:,n_diis) ref = err(:,n_diis) increase_error = check_diis_solution(jv,cwrk,step,ref,& - iw2,check_diis,error) + iw2,check_diis) ! possibly enlarge the error space IF (increase_error) THEN accepted = .TRUE. sline%wrk = RESHAPE(step,(/sline%size_wrk(1),sline%size_wrk(2)/)) ELSE DEALLOCATE(awrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cwrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk_inv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) EXIT END IF DEALLOCATE(awrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cwrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk_inv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO IF (iw2>0) THEN line ="Exiting DIIS accepting"//cp_to_string(MIN(n_diis,jv))//" errors." @@ -241,9 +239,9 @@ FUNCTION accept_diis_step(apply_diis, n_diis,err,crr,set_err,sline,coords,& END DO END IF DEALLOCATE(step,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ref,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END FUNCTION accept_diis_step @@ -255,17 +253,15 @@ END FUNCTION accept_diis_step !> \param ref ... !> \param output_unit ... !> \param check_diis ... -!> \param error ... !> \retval accepted ... !> \author Teodoro Laino 10.2006 ! ***************************************************************************** - FUNCTION check_diis_solution(nv, cwrk, step, ref, output_unit, check_diis, error)& + FUNCTION check_diis_solution(nv, cwrk, step, ref, output_unit, check_diis)& RESULT(accepted) INTEGER, INTENT(IN) :: nv REAL(KIND=dp), DIMENSION(:), POINTER :: cwrk, step, ref INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN) :: check_diis - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: accepted CHARACTER(len=*), PARAMETER :: routineN = 'check_diis_solution', & @@ -279,7 +275,7 @@ FUNCTION check_diis_solution(nv, cwrk, step, ref, output_unit, check_diis, error failure = .FALSE. accepted = .TRUE. ALLOCATE(tmp(SIZE(step)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (.NOT.failure) THEN IF (accepted) THEN ! (a) The direction of the DIIS step, can be compared to the reference step. @@ -330,7 +326,7 @@ FUNCTION check_diis_solution(nv, cwrk, step, ref, output_unit, check_diis, error END IF END IF DEALLOCATE(tmp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END FUNCTION check_diis_solution ! ***************************************************************************** @@ -349,12 +345,10 @@ END FUNCTION check_diis_solution !> \param distances ... !> \param diis_section ... !> \param iw2 ... -!> \param error ... !> \author Teodoro Laino 10.2006 ! ***************************************************************************** SUBROUTINE neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces,& - vels, particle_set, iw, output_unit, distances, diis_section, iw2, & - error) + vels, particle_set, iw, output_unit, distances, diis_section, iw2) REAL(KIND=dp), INTENT(INOUT) :: stepsize TYPE(neb_var_type), POINTER :: sline TYPE(replica_env_type), POINTER :: rep_env @@ -370,7 +364,6 @@ SUBROUTINE neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces,& INTENT(INOUT) :: distances TYPE(section_vals_type), POINTER :: diis_section INTEGER, INTENT(IN) :: iw2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_ls', & routineP = moduleN//':'//routineN @@ -386,9 +379,9 @@ SUBROUTINE neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces,& failure = .FALSE. ALLOCATE(Icoord(coords%size_wrk(1),coords%size_wrk(2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL section_vals_val_get(diis_section,"NP_LS", i_val=np, error=error) - CALL section_vals_val_get(diis_section,"MAX_STEPSIZE", r_val=max_stepsize, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL section_vals_val_get(diis_section,"NP_LS", i_val=np) + CALL section_vals_val_get(diis_section,"MAX_STEPSIZE", r_val=max_stepsize) Icoord(:,:) = coords%wrk xa = 0.0_dp ya = SUM(sline%wrk*forces%wrk) @@ -399,10 +392,10 @@ SUBROUTINE neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces,& i = i + 1 coords%wrk = Icoord + xb*sline%wrk CALL reorient_images(neb_env%rotate_frames, particle_set, coords, vels,& - output_unit, distances, neb_env%number_of_replica, error) + output_unit, distances, neb_env%number_of_replica) neb_env%avg_distance = SQRT(SUM(distances*distances)/REAL(SIZE(distances),KIND=dp)) CALL neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& - particle_set, iw, error) + particle_set, iw) yb = SUM(sline%wrk*forces%wrk) a = (ya-yb)/(2.0_dp*(xa-xb)) b = ya - 2.0_dp*a*xa @@ -430,7 +423,7 @@ SUBROUTINE neb_ls(stepsize, sline, rep_env, neb_env, coords, energies, forces,& stepsize = xc_cray coords%wrk = Icoord DEALLOCATE(Icoord,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE neb_ls END MODULE neb_opt_utils diff --git a/src/motion/neb_types.F b/src/motion/neb_types.F index f8ddc952e1..f28f489d64 100644 --- a/src/motion/neb_types.F +++ b/src/motion/neb_types.F @@ -72,15 +72,13 @@ MODULE neb_types !> \param neb_var ... !> \param neb_env ... !> \param full_allocation ... -!> \param error ... !> \date 05.2007 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE neb_var_create(neb_var, neb_env, full_allocation, error) + SUBROUTINE neb_var_create(neb_var, neb_env, full_allocation) TYPE(neb_var_type), POINTER :: neb_var TYPE(neb_type), POINTER :: neb_env LOGICAL, INTENT(IN), OPTIONAL :: full_allocation - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_var_create', & routineP = moduleN//':'//routineN @@ -89,30 +87,30 @@ SUBROUTINE neb_var_create(neb_var, neb_env, full_allocation, error) LOGICAL :: allocate_all, failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(neb_var),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(neb_var),cp_failure_level,routineP,failure) allocate_all = .FALSE. IF (PRESENT(full_allocation)) allocate_all = full_allocation neb_nr_replica = neb_env%number_of_replica ALLOCATE(neb_var, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(neb_var%xyz, neb_var%int, neb_var%wrk, neb_var%Mmatrix) IF (allocate_all) THEN ALLOCATE(neb_var%xyz(neb_env%nsize_xyz, neb_nr_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) neb_var%xyz = 0.0_dp END IF IF (neb_env%use_colvar) THEN neb_var%in_use = do_band_collective - CPPostcondition(neb_env%nsize_int>0,cp_failure_level,routineP,error,failure) + CPPostcondition(neb_env%nsize_int>0,cp_failure_level,routineP,failure) ALLOCATE(neb_var%int(neb_env%nsize_int, neb_nr_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) neb_var%int = 0.0_dp neb_var%wrk => neb_var%int ELSE neb_var%in_use = do_band_cartesian IF (.NOT.allocate_all) THEN ALLOCATE(neb_var%xyz(neb_env%nsize_xyz, neb_nr_replica),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) neb_var%xyz = 0.0_dp END IF neb_var%wrk => neb_var%xyz @@ -125,13 +123,11 @@ END SUBROUTINE neb_var_create ! ***************************************************************************** !> \brief Releases a variable type for BAND calculation !> \param neb_var ... -!> \param error ... !> \date 05.2007 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE neb_var_release(neb_var, error) + SUBROUTINE neb_var_release(neb_var) TYPE(neb_var_type), POINTER :: neb_var - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_var_release', & routineP = moduleN//':'//routineN @@ -140,18 +136,18 @@ SUBROUTINE neb_var_release(neb_var, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(neb_var),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(neb_var),cp_failure_level,routineP,failure) IF (ASSOCIATED(neb_var%xyz)) THEN DEALLOCATE(neb_var%xyz,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (neb_var%in_use==do_band_collective) THEN DEALLOCATE(neb_var%int,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(neb_var%wrk) DEALLOCATE(neb_var, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE neb_var_release diff --git a/src/motion/neb_utils.F b/src/motion/neb_utils.F index 4468e937b9..62595a05f0 100644 --- a/src/motion/neb_utils.F +++ b/src/motion/neb_utils.F @@ -95,11 +95,9 @@ MODULE neb_utils !> \param distance ... !> \param iw ... !> \param rotate ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE neb_replica_distance(particle_set,coords,i0,i,distance,iw,rotate,& - error) + SUBROUTINE neb_replica_distance(particle_set,coords,i0,i,distance,iw,rotate) TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particle_set TYPE(neb_var_type), POINTER :: coords @@ -107,7 +105,6 @@ SUBROUTINE neb_replica_distance(particle_set,coords,i0,i,distance,iw,rotate,& REAL(KIND=dp), INTENT(OUT) :: distance INTEGER, INTENT(IN) :: iw LOGICAL, INTENT(IN), OPTIONAL :: rotate - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_replica_distance', & routineP = moduleN//':'//routineN @@ -120,9 +117,9 @@ SUBROUTINE neb_replica_distance(particle_set,coords,i0,i,distance,iw,rotate,& ! The rotation of the replica is enabled exclusively when working in ! cartesian coordinates IF (my_rotate.AND.(coords%in_use == do_band_cartesian)) THEN - CPPostcondition(PRESENT(particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(particle_set),cp_failure_level,routineP,failure) CALL rmsd3(particle_set,coords%xyz(:,i),coords%xyz(:,i0),& - iw,rotate=my_rotate,error=error) + iw,rotate=my_rotate) END IF distance = SQRT(DOT_PRODUCT(coords%wrk(:,i)-coords%wrk(:,i0),& coords%wrk(:,i)-coords%wrk(:,i0))) @@ -139,11 +136,10 @@ END SUBROUTINE neb_replica_distance !> \param iw ... !> \param globenv ... !> \param para_env ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE build_replica_coords(neb_section, particle_set,& - coords, vels, neb_env, iw, globenv, para_env, error) + coords, vels, neb_env, iw, globenv, para_env) TYPE(section_vals_type), POINTER :: neb_section TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -152,7 +148,6 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& INTEGER, INTENT(IN) :: iw TYPE(global_environment_type), POINTER :: globenv TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_replica_coords', & routineP = moduleN//':'//routineN @@ -174,13 +169,13 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& NULLIFY (parser) CALL timeset(routineN,handle) failure = .FALSE. - CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(vels),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(vels),cp_failure_level,routineP,failure) neb_nr_replica = neb_env%number_of_replica - replica_section => section_vals_get_subs_vals(neb_section,"REPLICA",error=error) - CALL section_vals_get(replica_section,n_repetition=input_nr_replica,error=error) + replica_section => section_vals_get_subs_vals(neb_section,"REPLICA") + CALL section_vals_get(replica_section,n_repetition=input_nr_replica) ! Calculation is aborted if input replicas are more then the requested ones for the BAND.. - CPPostcondition((input_nr_replica<=neb_nr_replica),cp_failure_level,routineP,error,failure) + CPPostcondition((input_nr_replica<=neb_nr_replica),cp_failure_level,routineP,failure) ! Read in replicas coordinates skip_vel_section = (input_nr_replica /= neb_nr_replica) IF ((iw > 0).AND.skip_vel_section) THEN @@ -191,24 +186,24 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& ! Further check on velocity section... DO i_rep=1,input_nr_replica vel_section => section_vals_get_subs_vals(replica_section,"VELOCITY",& - i_rep_section=i_rep,error=error) - CALL section_vals_get(vel_section,explicit=explicit,error=error) + i_rep_section=i_rep) + CALL section_vals_get(vel_section,explicit=explicit) skip_vel_section = skip_vel_section.OR.(.NOT.explicit) END DO ! Setup cartesian coordinates and COLVAR (if requested) coords%xyz(:,:) = 0.0_dp DO i_rep=1,input_nr_replica coord_section => section_vals_get_subs_vals(replica_section,"COORD",& - i_rep_section=i_rep,error=error) - CALL section_vals_get(coord_section,explicit=explicit,error=error) + i_rep_section=i_rep) + CALL section_vals_get(coord_section,explicit=explicit) ! Cartesian Coordinates IF (explicit) THEN CALL section_vals_val_get(coord_section,"_DEFAULT_KEYWORD_",& - n_rep_val=natom,error=error) - CPPostcondition((natom == SIZE(particle_set)),cp_failure_level,routineP,error,failure) + n_rep_val=natom) + CPPostcondition((natom == SIZE(particle_set)),cp_failure_level,routineP,failure) DO iatom=1,natom CALL section_vals_val_get(coord_section,"_DEFAULT_KEYWORD_",& - i_rep_val=iatom,r_vals=rptr,error=error) + i_rep_val=iatom,r_vals=rptr) ic = 3*(iatom - 1) coords%xyz(ic+1:ic+3,i_rep) = rptr(1:3)*bohr ! Initially core and shell positions are set to the atomic positions @@ -220,18 +215,17 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& END DO ELSE CALL section_vals_val_get(replica_section,"COORD_FILE_NAME",& - i_rep_section=i_rep,c_val=filename,error=error) - CPPostcondition(TRIM(filename)/="",cp_failure_level,routineP,error,failure) - CALL parser_create(parser,filename,para_env=para_env,parse_white_lines=.TRUE.,& - error=error) - CALL parser_get_next_line(parser,1,error=error) + i_rep_section=i_rep,c_val=filename) + CPPostcondition(TRIM(filename)/="",cp_failure_level,routineP,failure) + CALL parser_create(parser,filename,para_env=para_env,parse_white_lines=.TRUE.) + CALL parser_get_next_line(parser,1) ! Start parser - CALL parser_get_object(parser,natom,error=error) - CPPostcondition((natom == SIZE(particle_set)),cp_failure_level,routineP,error,failure) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_object(parser,natom) + CPPostcondition((natom == SIZE(particle_set)),cp_failure_level,routineP,failure) + CALL parser_get_next_line(parser,1) DO iatom=1,natom ! Atom coordinates - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) CALL cp_assert(.NOT.my_end,cp_fatal_level,cp_assertion_failed,routineP,& "Number of lines in XYZ format not equal to the number of atoms."//& " Error in XYZ format for REPLICA coordinates. Very probably the"//& @@ -248,23 +242,23 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& coords%xyz(is+1:is+3,i_rep) = coords%xyz(ic+1:ic+3,i_rep) END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF ! Collective Variables IF (neb_env%use_colvar) THEN CALL section_vals_val_get(replica_section,"COLLECTIVE",& - i_rep_section=i_rep,n_rep_val=n_rep,error=error) + i_rep_section=i_rep,n_rep_val=n_rep) IF (n_rep /= 0) THEN ! Read the values of the collective variables NULLIFY (initial_colvars) CALL section_vals_val_get(replica_section,"COLLECTIVE",& - i_rep_section=i_rep,r_vals=initial_colvars,error=error) + i_rep_section=i_rep,r_vals=initial_colvars) check = (neb_env%nsize_int == SIZE(initial_colvars)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) coords%int(:,i_rep) = initial_colvars ELSE ! Compute the values of the collective variables - CALL eval_colvar(neb_env%force_env,coords%xyz(:,i_rep),coords%int(:,i_rep),error=error) + CALL eval_colvar(neb_env%force_env,coords%xyz(:,i_rep),coords%int(:,i_rep)) END IF END IF ! Dump cartesian and colvar info.. @@ -272,27 +266,27 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& ! Setup Velocities IF (skip_vel_section) THEN CALL neb_initialize_velocity(vels%wrk,neb_section,particle_set,& - i_rep,iw,globenv,neb_env,error) + i_rep,iw,globenv,neb_env) ELSE vel_section => section_vals_get_subs_vals(replica_section,"VELOCITY",& - i_rep_section=i_rep,error=error) + i_rep_section=i_rep) CALL section_vals_val_get(vel_section,"_DEFAULT_KEYWORD_",& - n_rep_val=nval,error=error) + n_rep_val=nval) ! Setup Velocities for collective or cartesian coordinates IF (neb_env%use_colvar) THEN nvar = SIZE(vels%wrk,1) - CPPostcondition((nval == nvar),cp_failure_level,routineP,error,failure) + CPPostcondition((nval == nvar),cp_failure_level,routineP,failure) DO ivar=1,nvar CALL section_vals_val_get(vel_section,"_DEFAULT_KEYWORD_",& - i_rep_val=ivar,r_vals=rptr,error=error) + i_rep_val=ivar,r_vals=rptr) vels%wrk(ivar,i_rep) = rptr(1) END DO ELSE natom = SIZE(particle_set) - CPPostcondition((nval == natom),cp_failure_level,routineP,error,failure) + CPPostcondition((nval == natom),cp_failure_level,routineP,failure) DO iatom=1,natom CALL section_vals_val_get(vel_section,"_DEFAULT_KEYWORD_",& - i_rep_val=iatom,r_vals=rptr,error=error) + i_rep_val=iatom,r_vals=rptr) ic = 3*(iatom - 1) vels%wrk(ic+1:ic+3,i_rep) = rptr(1:3) ! Initially set shell velocities to core velocity @@ -306,7 +300,7 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& END IF END DO ! i_rep ALLOCATE (distance(neb_nr_replica-1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (input_nr_replica < neb_nr_replica) THEN ! Interpolate missing replicas nr_replica_to_interpolate = neb_nr_replica - input_nr_replica @@ -319,7 +313,7 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& ! where to add a new image DO j=1,input_nr_replica-1 CALL neb_replica_distance(particle_set,coords,j,j+1,distance(j),iw,& - rotate=neb_env%align_frames,error=error) + rotate=neb_env%align_frames) END DO jtarg = MAXLOC(distance(1:input_nr_replica),1) IF (iw > 0) THEN @@ -345,7 +339,7 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& CALL dump_replica_coordinates(particle_set, coords, jtarg+1,& input_nr_replica, iw, neb_env%use_colvar) CALL neb_initialize_velocity(vels%wrk, neb_section, particle_set,& - jtarg+1, iw, globenv, neb_env, error) + jtarg+1, iw, globenv, neb_env) END DO END IF vels%wrk(:,1) = 0.0_dp @@ -356,10 +350,10 @@ SUBROUTINE build_replica_coords(neb_section, particle_set,& ! Rotate the frames in order to minimize the RMSD DO j=1,input_nr_replica-1 CALL neb_replica_distance(particle_set,coords,j,j+1,distance(j),iw,& - rotate=neb_env%align_frames,error=error) + rotate=neb_env%align_frames) END DO DEALLOCATE (distance,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -375,11 +369,10 @@ END SUBROUTINE build_replica_coords !> \param forces ... !> \param particle_set ... !> \param output_unit ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& - particle_set, output_unit, error) + particle_set, output_unit) TYPE(replica_env_type), POINTER :: rep_env TYPE(neb_type), OPTIONAL, POINTER :: neb_env TYPE(neb_var_type), POINTER :: coords @@ -388,7 +381,6 @@ SUBROUTINE neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'neb_calc_energy_forces', & routineP = moduleN//':'//routineN @@ -411,11 +403,11 @@ SUBROUTINE neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& nsize_wrk = coords%size_wrk(1) energies = 0.0_dp ALLOCATE(cvalues(n_int,n_rep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Mmatrix_tmp(n_int*n_int,n_rep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Mmatrix(n_int*n_int,n_rep_neb),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (output_unit>0) WRITE(output_unit,'(/,T2,A)')"NEB| Computing Energies and Forces" DO irep = 1, n_rep_neb, n_rep DO j = 0, n_rep-1 @@ -429,18 +421,18 @@ SUBROUTINE neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& END DO ! Fix file name for BAND replicas.. Each BAND replica has its own file ! independently from the number of replicas in replica_env.. - CALL handle_band_file_names(rep_env, irep, n_rep_neb, neb_env%istep, error) + CALL handle_band_file_names(rep_env, irep, n_rep_neb, neb_env%istep) ! Let's select the potential we want to use for the band calculation SELECT CASE(neb_env%pot_type) CASE(pot_neb_full) ! Full potential Energy - CALL rep_env_calc_e_f(rep_env, calc_f=.TRUE., error=error) + CALL rep_env_calc_e_f(rep_env, calc_f=.TRUE.) CASE(pot_neb_fe) ! Free Energy Case - CALL perform_replica_md (rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix_tmp, error) + CALL perform_replica_md (rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix_tmp) CASE(pot_neb_me) ! Minimum Potential Energy Case - CALL perform_replica_geo(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix_tmp, error) + CALL perform_replica_geo(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix_tmp) END SELECT DO j = 0, n_rep-1 @@ -485,48 +477,48 @@ SUBROUTINE neb_calc_energy_forces(rep_env, neb_env, coords, energies, forces,& END DO END DO DEALLOCATE(cvalues,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Mmatrix_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(neb_env)) THEN ! First identify the image of the chain with the higher potential energy ! First and last point of the band are never considered neb_env%nr_HE_image = MAXLOC(energies(2:n_rep_neb-1),1)+1 ALLOCATE(tangent(nsize_wrk),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Then modify image forces accordingly to the scheme chosen for the ! calculation. neb_env%spring_energy = 0.0_dp IF (neb_env%optimize_end_points) THEN ALLOCATE(tmp_a(SIZE(forces%wrk,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_b(SIZE(forces%wrk,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_a(:) = forces%wrk(:,1) tmp_b(:) = forces%wrk(:,SIZE(forces%wrk,2)) END IF DO i = 2, neb_env%number_of_replica - CALL get_tangent(neb_env,coords,i,tangent,energies,output_unit,error) + CALL get_tangent(neb_env,coords,i,tangent,energies,output_unit) CALL get_neb_force(neb_env,tangent,coords,i,forces,Mmatrix=Mmatrix,& - iw=output_unit,error=error) + iw=output_unit) END DO IF (neb_env%optimize_end_points) THEN forces%wrk(:,1) = tmp_a ! Image A forces%wrk(:,SIZE(forces%wrk,2)) = tmp_b ! Image B DEALLOCATE(tmp_a,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ! Nullify forces on the two end points images forces%wrk(:,1) = 0.0_dp ! Image A forces%wrk(:,SIZE(forces%wrk,2)) = 0.0_dp ! Image B END IF DEALLOCATE(tangent,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(Mmatrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE neb_calc_energy_forces @@ -539,23 +531,20 @@ END SUBROUTINE neb_calc_energy_forces !> \param n_rep_neb ... !> \param cvalues ... !> \param Mmatrix ... -!> \param error ... !> \author Teodoro Laino 01.2007 ! ***************************************************************************** - SUBROUTINE perform_replica_md(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix, error) + SUBROUTINE perform_replica_md(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix) TYPE(replica_env_type), POINTER :: rep_env TYPE(neb_var_type), POINTER :: coords INTEGER, INTENT(IN) :: irep, n_rep_neb REAL(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: cvalues, Mmatrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'perform_replica_md', & routineP = moduleN//':'//routineN INTEGER :: handle, handle2, ierr, j, n_el LOGICAL :: explicit, failure - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(f_env_type), POINTER :: f_env TYPE(global_environment_type), POINTER :: globenv @@ -564,35 +553,35 @@ SUBROUTINE perform_replica_md(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix CALL timeset(routineN,handle) failure = .FALSE. CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure, handle=handle2) - logger => cp_error_get_logger(new_error) + failure=failure, handle=handle2) + logger => cp_get_default_logger() CALL force_env_get(f_env%force_env,globenv=globenv,& - root_section=root_section,error=new_error) + root_section=root_section) j = rep_env%local_rep_indices(1)-1 n_el = 3*rep_env%nparticle Mmatrix = 0.0_dp ! Syncronize position on the replica procs CALL set_pos(rep_env%f_env_id,rep_env%r(:,j+1),n_el,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) ! IF (irep+j <= n_rep_neb) THEN logger%iter_info%iteration(2)=irep+j - CALL remove_restart_info(root_section,error=new_error) - md_section => section_vals_get_subs_vals(root_section,"MOTION%MD",error=error) - CALL section_vals_get(md_section,explicit=explicit,error=error) - CPAssert(explicit,cp_failure_level,routineP,error,failure) + CALL remove_restart_info(root_section) + md_section => section_vals_get_subs_vals(root_section,"MOTION%MD") + CALL section_vals_get(md_section,explicit=explicit) + CPAssert(explicit,cp_failure_level,routineP,failure) ! Let's syncronize the target of Collective Variables for this run - CALL set_colvars_target(coords%int(:,irep+j), f_env%force_env, error=error) + CALL set_colvars_target(coords%int(:,irep+j), f_env%force_env) ! Do a molecular dynamics and get back the derivative ! of the free energy w.r.t. the colvar and the metric tensor - CALL qs_mol_dyn(f_env%force_env,globenv=globenv,error=new_error) + CALL qs_mol_dyn(f_env%force_env,globenv=globenv) ! Collect the equilibrated coordinates CALL get_pos(rep_env%f_env_id, rep_env%r(1:n_el,j+1), n_el, ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) ! Write he gradients in the colvar coordinates into the replica_env array ! and copy back also the metric tensor.. ! work in progress.. - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) rep_env%f(:,j+1) = 0.0_dp Mmatrix = 0.0_dp ELSE @@ -601,12 +590,12 @@ SUBROUTINE perform_replica_md(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix cvalues(:,j+1) = 0.0_dp Mmatrix(:,j+1) = 0.0_dp END IF - CALL rep_env_sync(rep_env,rep_env%f,error=error) - CALL rep_env_sync(rep_env,rep_env%r,error=error) - CALL rep_env_sync(rep_env,cvalues, error=error) - CALL rep_env_sync(rep_env,Mmatrix, error=error) - CALL f_env_rm_defaults(f_env=f_env,error=new_error,ierr=ierr,handle=handle2) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL rep_env_sync(rep_env,rep_env%f) + CALL rep_env_sync(rep_env,rep_env%r) + CALL rep_env_sync(rep_env,cvalues) + CALL rep_env_sync(rep_env,Mmatrix) + CALL f_env_rm_defaults(f_env=f_env,ierr=ierr,handle=handle2) + CPAssert(ierr==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE perform_replica_md @@ -620,23 +609,20 @@ END SUBROUTINE perform_replica_md !> \param n_rep_neb ... !> \param cvalues ... !> \param Mmatrix ... -!> \param error ... !> \author Teodoro Laino 05.2007 ! ***************************************************************************** - SUBROUTINE perform_replica_geo(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix, error) + SUBROUTINE perform_replica_geo(rep_env, coords, irep, n_rep_neb, cvalues, Mmatrix) TYPE(replica_env_type), POINTER :: rep_env TYPE(neb_var_type), POINTER :: coords INTEGER, INTENT(IN) :: irep, n_rep_neb REAL(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: cvalues, Mmatrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'perform_replica_geo', & routineP = moduleN//':'//routineN INTEGER :: handle, handle2, ierr, j, n_el LOGICAL :: explicit, failure - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(f_env_type), POINTER :: f_env TYPE(global_environment_type), POINTER :: globenv @@ -645,55 +631,54 @@ SUBROUTINE perform_replica_geo(rep_env, coords, irep, n_rep_neb, cvalues, Mmatri CALL timeset(routineN,handle) failure = .FALSE. CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure, handle=handle2) - logger => cp_error_get_logger(new_error) + failure=failure, handle=handle2) + logger => cp_get_default_logger() CALL force_env_get(f_env%force_env,globenv=globenv,& - root_section=root_section,error=new_error) + root_section=root_section) j = rep_env%local_rep_indices(1)-1 n_el = 3*rep_env%nparticle Mmatrix = 0.0_dp ! Syncronize position on the replica procs CALL set_pos(rep_env%f_env_id,rep_env%r(:,j+1),n_el,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) IF (irep+j <= n_rep_neb) THEN logger%iter_info%iteration(2)=irep+j - CALL remove_restart_info(root_section,error=new_error) - geoopt_section => section_vals_get_subs_vals(root_section,"MOTION%GEO_OPT",error=error) - CALL section_vals_get(geoopt_section,explicit=explicit,error=error) - CPAssert(explicit,cp_failure_level,routineP,error,failure) + CALL remove_restart_info(root_section) + geoopt_section => section_vals_get_subs_vals(root_section,"MOTION%GEO_OPT") + CALL section_vals_get(geoopt_section,explicit=explicit) + CPAssert(explicit,cp_failure_level,routineP,failure) ! Let's syncronize the target of Collective Variables for this run - CALL set_colvars_target(coords%int(:,irep+j), f_env%force_env, error=error) + CALL set_colvars_target(coords%int(:,irep+j), f_env%force_env) ! Do a geometry optimization.. - CALL cp_geo_opt(f_env%force_env,globenv=globenv,error=new_error) + CALL cp_geo_opt(f_env%force_env,globenv=globenv) ! Once the geometry optimization is ended let's do a single run ! without any constraints/restraints CALL force_env_calc_energy_force ( f_env%force_env, & - calc_force=.TRUE., skip_external_control=.TRUE., error=error) + calc_force=.TRUE., skip_external_control=.TRUE.) ! Collect the optimized coordinates CALL get_pos(rep_env%f_env_id, rep_env%r(1:n_el,j+1), n_el, ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) ! Collect the gradients in cartesian coordinates CALL get_force(rep_env%f_env_id, rep_env%f(1:n_el,j+1), n_el, ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) ! Copy the energy CALL get_energy(rep_env%f_env_id, rep_env%f(n_el+1,j+1), ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) ! The gradients in the colvar coordinates CALL get_clv_force(f_env%force_env, rep_env%f(1:n_el,j+1), rep_env%r(1:n_el,j+1),& - SIZE(coords%xyz,1), SIZE(coords%wrk,1), cvalues(:,j+1), Mmatrix(:,j+1),& - error) + SIZE(coords%xyz,1), SIZE(coords%wrk,1), cvalues(:,j+1), Mmatrix(:,j+1)) ELSE rep_env%r(:,j+1) = 0.0_dp rep_env%f(:,j+1) = 0.0_dp cvalues(:,j+1) = 0.0_dp Mmatrix(:,j+1) = 0.0_dp END IF - CALL rep_env_sync(rep_env,rep_env%f,error=error) - CALL rep_env_sync(rep_env,rep_env%r,error=error) - CALL rep_env_sync(rep_env,cvalues, error=error) - CALL rep_env_sync(rep_env,Mmatrix, error=error) - CALL f_env_rm_defaults(f_env=f_env,error=new_error,ierr=ierr,handle=handle2) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL rep_env_sync(rep_env,rep_env%f) + CALL rep_env_sync(rep_env,rep_env%r) + CALL rep_env_sync(rep_env,cvalues) + CALL rep_env_sync(rep_env,Mmatrix) + CALL f_env_rm_defaults(f_env=f_env,ierr=ierr,handle=handle2) + CPAssert(ierr==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE perform_replica_geo @@ -705,17 +690,15 @@ END SUBROUTINE perform_replica_geo !> \param tangent ... !> \param energies ... !> \param iw ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE get_tangent(neb_env, coords, i, tangent, energies, iw, error) + SUBROUTINE get_tangent(neb_env, coords, i, tangent, energies, iw) TYPE(neb_type), POINTER :: neb_env TYPE(neb_var_type), POINTER :: coords INTEGER, INTENT(IN) :: i REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: tangent REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: energies INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_tangent', & routineP = moduleN//':'//routineN @@ -725,7 +708,7 @@ SUBROUTINE get_tangent(neb_env, coords, i, tangent, energies, iw, error) distance2, DVmax, Dvmin failure = .FALSE. - CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,failure) tangent(:) = 0.0_dp ! For the last point we don't need any tangent.. IF (i==neb_env%number_of_replica) RETURN @@ -735,9 +718,9 @@ SUBROUTINE get_tangent(neb_env, coords, i, tangent, energies, iw, error) tangent(:) = 0.0_dp CASE(do_b_neb) CALL neb_replica_distance(coords=coords,i0=i,i=i-1,distance=distance1,iw=iw,& - rotate=.FALSE.,error=error) + rotate=.FALSE.) CALL neb_replica_distance(coords=coords,i0=i+1,i=i,distance=distance2,iw=iw,& - rotate=.FALSE.,error=error) + rotate=.FALSE.) tangent(:) = (coords%wrk(:,i) -coords%wrk(:,i-1))/distance1 +& (coords%wrk(:,i+1)-coords%wrk(:,i) )/distance2 CASE(do_it_neb, do_ci_neb, do_d_neb) @@ -772,11 +755,10 @@ END SUBROUTINE get_tangent !> \param tag ... !> \param Mmatrix ... !> \param iw ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** RECURSIVE SUBROUTINE get_neb_force(neb_env,tangent,coords,i,forces,tag,Mmatrix,& - iw,error) + iw) TYPE(neb_type), POINTER :: neb_env REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: tangent TYPE(neb_var_type), POINTER :: coords @@ -786,7 +768,6 @@ RECURSIVE SUBROUTINE get_neb_force(neb_env,tangent,coords,i,forces,tag,Mmatrix,& REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: Mmatrix INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_neb_force', & routineP = moduleN//':'//routineN @@ -799,8 +780,8 @@ RECURSIVE SUBROUTINE get_neb_force(neb_env,tangent,coords,i,forces,tag,Mmatrix,& failure = .FALSE. my_tag = neb_env%id_type IF (PRESENT(tag)) my_tag = tag - CPPostcondition(ASSOCIATED(forces),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(forces),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(coords),cp_failure_level,routineP,failure) nsize_wrk = coords%size_wrk(1) ! All methods but not the classical elastic band will skip the force ! calculation for the last frame of the band @@ -816,10 +797,10 @@ RECURSIVE SUBROUTINE get_neb_force(neb_env,tangent,coords,i,forces,tag,Mmatrix,& END SELECT ! otherwise proceeed normally.. ALLOCATE (wrk(nsize_wrk),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Spring Energy CALL neb_replica_distance(coords=coords,i0=i-1,i=i,distance=distance1,iw=iw,& - rotate=.FALSE.,error=error) + rotate=.FALSE.) tmp = distance1-neb_env%avg_distance neb_env%spring_energy = neb_env%spring_energy + 0.5_dp*neb_env%k*tmp**2 SELECT CASE(my_tag) @@ -828,7 +809,7 @@ RECURSIVE SUBROUTINE get_neb_force(neb_env,tangent,coords,i,forces,tag,Mmatrix,& ! Elastic band - Hamiltonian formulation according the original Karplus/Elber ! formulation ALLOCATE(dtmp1(nsize_wrk),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! derivatives of the spring tmp = distance1-neb_env%avg_distance dtmp1(:) = 1.0_dp/distance1 * (coords%wrk(:,i)-coords%wrk(:,i-1)) @@ -841,46 +822,46 @@ RECURSIVE SUBROUTINE get_neb_force(neb_env,tangent,coords,i,forces,tag,Mmatrix,& tmp = 0.0_dp DO j = 2, neb_env%number_of_replica CALL neb_replica_distance(coords=coords,i0=j-1,i=j,distance=distance1,iw=iw,& - rotate=.FALSE.,error=error) + rotate=.FALSE.) tmp = tmp + distance1-neb_env%avg_distance END DO forces%wrk(:,i) = forces%wrk(:,i) + wrk * tmp forces%wrk(:,i-1) = forces%wrk(:,i-1) - wrk * tmp DEALLOCATE(dtmp1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(do_b_neb) ! Bisection NEB CALL cite_reference(Jonsson1998) wrk(:) = (coords%wrk(:,i+1)-2.0_dp*coords%wrk(:,i)+coords%wrk(:,i-1)) tmp = neb_env%k * DOT_PRODUCT(wrk,tangent) - wrk(:) = forces%wrk(:,i)-dot_product_band(neb_env,forces%wrk(:,i),tangent,Mmatrix,error)*tangent + wrk(:) = forces%wrk(:,i)-dot_product_band(neb_env,forces%wrk(:,i),tangent,Mmatrix)*tangent forces%wrk(:,i) = wrk + tmp * tangent CASE(do_it_neb) ! Improved tangent NEB CALL cite_reference(Jonsson2000_1) CALL neb_replica_distance(coords=coords,i0=i,i=i+1,distance=distance1,iw=iw,& - rotate=.FALSE.,error=error) + rotate=.FALSE.) CALL neb_replica_distance(coords=coords,i0=i-1,i=i,distance=distance2,iw=iw,& - rotate=.FALSE.,error=error) + rotate=.FALSE.) tmp = neb_env%k * (distance1-distance2) - wrk(:) = forces%wrk(:,i)-dot_product_band(neb_env,forces%wrk(:,i),tangent,Mmatrix,error)*tangent + wrk(:) = forces%wrk(:,i)-dot_product_band(neb_env,forces%wrk(:,i),tangent,Mmatrix)*tangent forces%wrk(:,i) = wrk + tmp * tangent CASE(do_ci_neb) ! Climbing Image NEB CALL cite_reference(Jonsson2000_2) IF (neb_env%istep<=neb_env%nsteps_it.OR.i/=neb_env%nr_HE_image) THEN - CALL get_neb_force(neb_env, tangent, coords, i, forces, do_it_neb, Mmatrix, iw, error) + CALL get_neb_force(neb_env, tangent, coords, i, forces, do_it_neb, Mmatrix, iw) ELSE wrk(:) = forces%wrk(:,i) - tmp = -2.0_dp*dot_product_band(neb_env,wrk,tangent,Mmatrix,error=error) + tmp = -2.0_dp*dot_product_band(neb_env,wrk,tangent,Mmatrix) forces%wrk(:,i) = wrk + tmp * tangent END IF CASE(do_d_neb) ! Doubly NEB CALL cite_reference(Wales2004) ALLOCATE(dtmp1(nsize_wrk),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - dtmp1(:) = forces%wrk(:,i)-dot_product_band(neb_env,forces%wrk(:,i),tangent,Mmatrix,error)*tangent + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + dtmp1(:) = forces%wrk(:,i)-dot_product_band(neb_env,forces%wrk(:,i),tangent,Mmatrix)*tangent forces%wrk(:,i) = dtmp1 tmp = SQRT(DOT_PRODUCT(dtmp1,dtmp1)) dtmp1(:) = dtmp1(:) / tmp @@ -891,10 +872,10 @@ RECURSIVE SUBROUTINE get_neb_force(neb_env,tangent,coords,i,forces,tag,Mmatrix,& dtmp1(:) = neb_env%k*(wrk(:) - tmp*dtmp1(:)) forces%wrk(:,i) = forces%wrk(:,i) + dtmp1(:) DEALLOCATE(dtmp1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE get_neb_force ! ***************************************************************************** @@ -905,16 +886,14 @@ END SUBROUTINE get_neb_force !> \param array1 ... !> \param array2 ... !> \param array3 ... -!> \param error ... !> \retval value ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - FUNCTION dot_product_band(neb_env, array1, array2, array3, error) RESULT(value) + FUNCTION dot_product_band(neb_env, array1, array2, array3) RESULT(value) TYPE(neb_type), POINTER :: neb_env REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: array1, array2 REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: array3 - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: value CHARACTER(len=*), PARAMETER :: routineN = 'dot_product_band', & @@ -930,7 +909,7 @@ FUNCTION dot_product_band(neb_env, array1, array2, array3, error) RESULT(value) (SIZE(array1)/=nsize_int).OR.& (SIZE(array3)/=nsize_int*nsize_int)) ! This condition should always be satisfied.. - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) value = DOT_PRODUCT(MATMUL(RESHAPE(array3,(/nsize_int,nsize_int/)),array1),array2) ELSE value = DOT_PRODUCT(array1,array2) @@ -947,11 +926,10 @@ END FUNCTION dot_product_band !> \param iw ... !> \param distances ... !> \param number_of_replica ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE reorient_images(rotate_frames, particle_set, coords, vels, iw,& - distances, number_of_replica, error) + distances, number_of_replica) LOGICAL, INTENT(IN) :: rotate_frames TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particle_set @@ -959,7 +937,6 @@ SUBROUTINE reorient_images(rotate_frames, particle_set, coords, vels, iw,& INTEGER, INTENT(IN) :: iw REAL(KIND=dp), DIMENSION(:), OPTIONAL :: distances INTEGER, INTENT(IN) :: number_of_replica - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reorient_images', & routineP = moduleN//':'//routineN @@ -980,7 +957,7 @@ SUBROUTINE reorient_images(rotate_frames, particle_set, coords, vels, iw,& ! cartesian coordinates IF (rotate_frames.AND.(coords%in_use==do_band_cartesian)) THEN CALL rmsd3(particle_set, coords%xyz(:,i), coords%xyz(:,i-1), iw,& - rotate=.TRUE., rot=rot, error=error) + rotate=.TRUE., rot=rot) ! Rotate velocities DO k = 1, SIZE(vels%xyz,1)/3 kind = (k-1)*3 @@ -990,7 +967,7 @@ SUBROUTINE reorient_images(rotate_frames, particle_set, coords, vels, iw,& END IF IF (PRESENT(distances)) THEN check = SIZE(distances)==(number_of_replica-1) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) xtmp=DOT_PRODUCT(coords%wrk(:,i)-coords%wrk(:,i-1),& coords%wrk(:,i)-coords%wrk(:,i-1)) distances(i-1)=SQRT(xtmp) @@ -1006,18 +983,16 @@ END SUBROUTINE reorient_images !> \param coords ... !> \param sline ... !> \param distances ... -!> \param error ... !> \author Teodoro Laino - Rodolphe Vuilleumier 09.2008 ! ***************************************************************************** SUBROUTINE reparametrize_images(reparametrize_frames, spline_order, smoothing,& - coords, sline, distances, error) + coords, sline, distances) LOGICAL, INTENT(IN) :: reparametrize_frames INTEGER, INTENT(IN) :: spline_order REAL(KIND=dp), INTENT(IN) :: smoothing REAL(KIND=dp), DIMENSION(:, :), POINTER :: coords, sline REAL(KIND=dp), DIMENSION(:) :: distances - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reparametrize_images', & routineP = moduleN//':'//routineN @@ -1031,7 +1006,7 @@ SUBROUTINE reparametrize_images(reparametrize_frames, spline_order, smoothing,& failure = .FALSE. IF (reparametrize_frames) THEN ALLOCATE(tmp_coords(SIZE(coords,1),SIZE(coords,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_coords(:,:) = coords ! Smoothing DO i = 2, SIZE(coords,2)-1 @@ -1069,11 +1044,11 @@ SUBROUTINE reparametrize_images(reparametrize_frames, spline_order, smoothing,& CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="String Method: Spline order greater than 1 not implemented.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END SELECT sline = coords - tmp_coords + sline DEALLOCATE(tmp_coords,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE reparametrize_images @@ -1082,14 +1057,12 @@ END SUBROUTINE reparametrize_images !> \param neb_env ... !> \param Dcoords ... !> \param forces ... -!> \param error ... !> \retval converged ... !> \author Teodoro Laino 10.2006 ! ***************************************************************************** - FUNCTION check_convergence(neb_env, Dcoords, forces, error) RESULT(converged) + FUNCTION check_convergence(neb_env, Dcoords, forces) RESULT(converged) TYPE(neb_type), POINTER :: neb_env TYPE(neb_var_type), POINTER :: Dcoords, forces - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: converged CHARACTER(len=*), PARAMETER :: routineN = 'check_convergence', & @@ -1107,12 +1080,12 @@ FUNCTION check_convergence(neb_env, Dcoords, forces, error) RESULT(converged) failure = .FALSE. NULLIFY(logger,cc_section) - logger => cp_error_get_logger(error) - cc_section => section_vals_get_subs_vals(neb_env%neb_section,"CONVERGENCE_CONTROL",error=error) - CALL section_vals_val_get(cc_section,"MAX_DR",r_val=max_dr,error=error) - CALL section_vals_val_get(cc_section,"MAX_FORCE",r_val=max_force,error=error) - CALL section_vals_val_get(cc_section,"RMS_DR",r_val=rms_dr,error=error) - CALL section_vals_val_get(cc_section,"RMS_FORCE",r_val=rms_force,error=error) + logger => cp_get_default_logger() + cc_section => section_vals_get_subs_vals(neb_env%neb_section,"CONVERGENCE_CONTROL") + CALL section_vals_val_get(cc_section,"MAX_DR",r_val=max_dr) + CALL section_vals_val_get(cc_section,"MAX_FORCE",r_val=max_force) + CALL section_vals_val_get(cc_section,"RMS_DR",r_val=rms_dr) + CALL section_vals_val_get(cc_section,"RMS_FORCE",r_val=rms_force) converged = .FALSE. labels = " NO" my_max_dr = MAXVAL(ABS(Dcoords%wrk)) @@ -1126,7 +1099,7 @@ FUNCTION check_convergence(neb_env, Dcoords, forces, error) RESULT(converged) IF (ALL(labels=="YES")) converged = .TRUE. iw=cp_print_key_unit_nr(logger,neb_env%neb_section,"CONVERGENCE_INFO",& - extension=".nebLog",error=error) + extension=".nebLog") IF (iw>0) THEN ! Print convergence info WRITE(iw,FMT='(A,A)')' **************************************', & @@ -1140,7 +1113,7 @@ FUNCTION check_convergence(neb_env, Dcoords, forces, error) RESULT(converged) '*****************************************' END IF CALL cp_print_key_finished_output(iw,logger,neb_env%neb_section,& - "CONVERGENCE_INFO", error=error) + "CONVERGENCE_INFO") END FUNCTION check_convergence END MODULE neb_utils diff --git a/src/motion/pint_gle.F b/src/motion/pint_gle.F index 084e6dd2c8..98eef25bb9 100644 --- a/src/motion/pint_gle.F +++ b/src/motion/pint_gle.F @@ -34,11 +34,9 @@ MODULE pint_gle ! ***************************************************************************** !> \brief ... !> \param pint_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pint_calc_gle_energy( pint_env, error) + SUBROUTINE pint_calc_gle_energy( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: i @@ -53,11 +51,9 @@ SUBROUTINE pint_calc_gle_energy( pint_env, error) ! ***************************************************************************** !> \brief ... !> \param pint_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pint_gle_init( pint_env, error) + SUBROUTINE pint_gle_init( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: i, ib, idim, imap, j LOGICAL :: failure @@ -75,7 +71,7 @@ SUBROUTINE pint_gle_init( pint_env, error) mf=1.0_dp/SQRT(pint_env%mass_fict(ib,idim)) rng_stream => pint_env%gle%nvt(i)%gaussian_rng_stream DO j = 1, pint_env%gle%ndim - rr(j) = next_random_number( rng_stream,error=error)*mf + rr(j) = next_random_number( rng_stream)*mf END DO pint_env%gle%nvt(i)%s = MATMUL(cc,rr) END DO @@ -85,11 +81,9 @@ END SUBROUTINE pint_gle_init ! ***************************************************************************** !> \brief ... !> \param pint_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pint_gle_step( pint_env, error) + SUBROUTINE pint_gle_step( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_gle_step', & routineP = moduleN//':'//routineN @@ -109,12 +103,12 @@ SUBROUTINE pint_gle_step( pint_env, error) ndim = gle%ndim ALLOCATE (s_tmp(ndim,gle%loc_num_gle),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) s_tmp = 0.0_dp ALLOCATE (e_tmp(ndim,gle%loc_num_gle),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (h_tmp(ndim,gle%loc_num_gle),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ideg = 1,gle%loc_num_gle imap = gle%map_info%index(ideg) @@ -126,12 +120,12 @@ SUBROUTINE pint_gle_step( pint_env, error) +0.5_dp*pint_env%mass_fict(ib,idim)*gle%nvt(ideg)%s(1)**2 s_tmp(1,imap) = gle%nvt(ideg)%s(1) rng_stream => gle%nvt(ideg)%gaussian_rng_stream - rr = next_random_number( rng_stream,error=error) + rr = next_random_number( rng_stream) mf=1.0_dp/SQRT(pint_env%mass_fict(ib,idim)) e_tmp(1,imap)= rr*mf DO iadd = 2,ndim s_tmp(iadd,imap) = gle%nvt(ideg)%s(iadd) - rr = next_random_number( rng_stream,error=error) + rr = next_random_number( rng_stream) e_tmp(iadd,imap) = rr*mf END DO END DO @@ -162,7 +156,7 @@ SUBROUTINE pint_gle_step( pint_env, error) END DO pint_env%e_kin_t=0.0_dp DEALLOCATE(e_tmp,s_tmp,h_tmp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE END MODULE diff --git a/src/motion/pint_io.F b/src/motion/pint_io.F index 0640bd0fbf..10c0426f0e 100644 --- a/src/motion/pint_io.F +++ b/src/motion/pint_io.F @@ -65,14 +65,12 @@ MODULE pint_io ! *************************************************************************** !> \brief Writes out a line of text to the default output unit. !> \param line ... -!> \param error ... !> \date 2009-07-10 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE pint_write_line(line,error) + SUBROUTINE pint_write_line(line) CHARACTER(len=*), INTENT(IN) :: line - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_write_line', & routineP = moduleN//':'//routineN @@ -82,7 +80,7 @@ SUBROUTINE pint_write_line(line,error) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_label = "PINT|" IF (logger%para_env%ionode) THEN @@ -97,16 +95,14 @@ END SUBROUTINE pint_write_line ! *************************************************************************** !> \brief Write out the trajectory of the centroid (positions and velocities) !> \param pint_env ... -!> \param error ... !> \par History !> various bug fixes - hforbert !> 2010-11-25 rewritten, added support for velocity printing, !> calc of the stddev of the beads turned off [lwalewski] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_write_centroids(pint_env,error) + SUBROUTINE pint_write_centroids(pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_write_centroids', & routineP = moduleN//':'//routineN @@ -124,7 +120,6 @@ SUBROUTINE pint_write_centroids(pint_env,error) LOGICAL :: failure, new_file REAL(kind=dp) :: nb, ss, unit_conv, vv TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env @@ -134,8 +129,8 @@ SUBROUTINE pint_write_centroids(pint_env,error) CALL timeset(routineN,handle1) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) IF (failure) THEN CALL timestop(handle1) RETURN @@ -156,30 +151,29 @@ SUBROUTINE pint_write_centroids(pint_env,error) ", E_vir =",pint_env%energy(e_kin_virial_id) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v) ! iterate over the properties that we know how to print ! (currently positions and velocities) DO id = 1, n_ids print_key => section_vals_get_subs_vals(pint_env%input,& - TRIM(sect_path(id)), error=error) + TRIM(sect_path(id))) should_output = cp_print_key_should_output(& iteration_info=logger%iter_info,& - basis_section=print_key, error=error) + basis_section=print_key) IF ( .NOT. BTEST(should_output,cp_p_file) ) CONTINUE ! get units of measure for output (if available) CALL section_vals_val_get(print_key,"UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) ! get the format for output - CALL section_vals_val_get(print_key,"FORMAT",i_val=outformat,& - error=error) + CALL section_vals_val_get(print_key,"FORMAT",i_val=outformat) SELECT CASE(outformat) CASE (dump_dcd,dump_dcd_aligned_cell) @@ -192,16 +186,15 @@ SUBROUTINE pint_write_centroids(pint_env,error) form="FORMATTED" ext=".xyz" CASE default - CPPostcondition(.FALSE.,cp_fatal_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_fatal_level,routineP,failure) END SELECT NULLIFY(f_env,cell,subsys) CALL f_env_add_defaults(f_env_id=pint_env%replicas%f_env_id,& - f_env=f_env,new_error=new_error, failure=failure, handle=handle) + f_env=f_env,failure=failure, handle=handle) CALL force_env_get(force_env=f_env%force_env,& - cell=cell, subsys=subsys, error=new_error) - CALL cp_subsys_get(subsys,particles=particles,& - error=new_error) + cell=cell, subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ! calculate and copy the requested property ! to the particles structure @@ -230,13 +223,12 @@ SUBROUTINE pint_write_centroids(pint_env,error) unit_nr = cp_print_key_unit_nr(logger=logger, & basis_section=print_key, print_key_path="", & extension=TRIM(ext), middle_name=TRIM(my_middle_name), & - local=.FALSE., file_form=form, is_new_file=new_file, & - error=new_error) + local=.FALSE., file_form=form, is_new_file=new_file) ! don't write the 0-th frame if the file already exists IF ( .NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step) ) THEN CALL cp_print_key_finished_output(unit_nr,logger,& - print_key, error=new_error) + print_key) CONTINUE END IF @@ -250,16 +242,15 @@ SUBROUTINE pint_write_centroids(pint_env,error) content=content_id(id), & title=title(id), & cell=cell, & - unit_conv=unit_conv, & - error=error) + unit_conv=unit_conv) CALL cp_print_key_finished_output(unit_nr,logger,& - print_key, "", local=.FALSE., error=new_error) + print_key, "", local=.FALSE.) END IF - CALL f_env_rm_defaults(f_env,new_error,ierr,handle) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL f_env_rm_defaults(f_env,ierr,handle) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END DO @@ -270,14 +261,12 @@ END SUBROUTINE pint_write_centroids ! *************************************************************************** !> \brief Write out the trajectory of the beads (positions and velocities) !> \param pint_env ... -!> \param error ... !> \par History !> 2010-11-25 added support for velocity printing [lwalewski] !> \author hforbert ! ***************************************************************************** - SUBROUTINE pint_write_trajectory(pint_env,error) + SUBROUTINE pint_write_trajectory(pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_write_trajectory', & routineP = moduleN//':'//routineN @@ -296,7 +285,6 @@ SUBROUTINE pint_write_trajectory(pint_env,error) LOGICAL :: failure, new_file REAL(kind=dp) :: unit_conv TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env @@ -306,8 +294,8 @@ SUBROUTINE pint_write_trajectory(pint_env,error) CALL timeset(routineN,handle1) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) IF (failure) THEN CALL timestop(handle1) RETURN @@ -321,30 +309,29 @@ SUBROUTINE pint_write_trajectory(pint_env,error) content_id(vel_id) = "VEL" NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v) ! iterate over the properties that we know how to print ! (currently positions and velocities) DO id = 1, n_ids print_key => section_vals_get_subs_vals(pint_env%input,& - TRIM(sect_path(id)), error=error) + TRIM(sect_path(id))) should_output = cp_print_key_should_output(& iteration_info=logger%iter_info,& - basis_section=print_key, error=error) + basis_section=print_key) IF ( .NOT. BTEST(should_output,cp_p_file) ) CONTINUE ! get units of measure for output (if available) CALL section_vals_val_get(print_key,"UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) ! get the format for output - CALL section_vals_val_get(print_key,"FORMAT",i_val=outformat,& - error=error) + CALL section_vals_val_get(print_key,"FORMAT",i_val=outformat) SELECT CASE(outformat) CASE (dump_dcd,dump_dcd_aligned_cell) @@ -357,16 +344,15 @@ SUBROUTINE pint_write_trajectory(pint_env,error) form="FORMATTED" ext=".xyz" CASE default - CPPostcondition(.FALSE.,cp_fatal_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_fatal_level,routineP,failure) END SELECT NULLIFY(f_env,cell,subsys) CALL f_env_add_defaults(f_env_id=pint_env%replicas%f_env_id,& - f_env=f_env,new_error=new_error, failure=failure, handle=handle) + f_env=f_env,failure=failure, handle=handle) CALL force_env_get(force_env=f_env%force_env,& - cell=cell, subsys=subsys, error=new_error) - CALL cp_subsys_get(subsys,particles=particles,& - error=new_error) + cell=cell, subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) ! iterate over beads DO ib = 1, pint_env%p @@ -390,13 +376,12 @@ SUBROUTINE pint_write_trajectory(pint_env,error) unit_nr = cp_print_key_unit_nr(logger=logger, & basis_section=print_key, print_key_path="", & extension=TRIM(ext), middle_name=TRIM(my_middle_name), & - local=.FALSE., file_form=form, is_new_file=new_file, & - error=new_error) + local=.FALSE., file_form=form, is_new_file=new_file) ! don't write the 0-th frame if the file already exists IF ( .NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step) ) THEN CALL cp_print_key_finished_output(unit_nr,logger,& - print_key, error=new_error) + print_key) CONTINUE END IF @@ -416,18 +401,17 @@ SUBROUTINE pint_write_trajectory(pint_env,error) content=content_id(id), & title=title, & cell=cell, & - unit_conv=unit_conv, & - error=error) + unit_conv=unit_conv) CALL cp_print_key_finished_output(unit_nr,logger,& - print_key, "", local=.FALSE., error=new_error) + print_key, "", local=.FALSE.) END IF END DO - CALL f_env_rm_defaults(f_env,new_error,ierr,handle) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL f_env_rm_defaults(f_env,ierr,handle) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END DO @@ -438,14 +422,12 @@ END SUBROUTINE pint_write_trajectory ! *************************************************************************** !> \brief Write center of mass (COM) position according to PINT%PRINT%COM !> \param pint_env ... -!> \param error ... !> \date 2010-02-17 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE pint_write_com( pint_env, error ) + SUBROUTINE pint_write_com( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_write_com', & routineP = moduleN//':'//routineN @@ -459,34 +441,34 @@ SUBROUTINE pint_write_com( pint_env, error ) TYPE(section_vals_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! decide whether to write anything or not NULLIFY(print_key) print_key => section_vals_get_subs_vals(pint_env%input, & - "MOTION%PINT%PRINT%COM", error=error) + "MOTION%PINT%PRINT%COM") should_output = BTEST(cp_print_key_should_output( & iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) + basis_section=print_key),cp_p_file) IF ( .NOT. should_output ) THEN RETURN END IF - com_r = pint_com_pos( pint_env, error ) + com_r = pint_com_pos( pint_env) DO ic = 1, 3 - com_r(ic) = cp_unit_from_cp2k(com_r(ic), "angstrom", error=error) + com_r(ic) = cp_unit_from_cp2k(com_r(ic), "angstrom") END DO unit_nr=cp_print_key_unit_nr(logger, print_key, is_new_file=new_file,& - middle_name="com-pos",extension=".xyz",error=error) + middle_name="com-pos",extension=".xyz") ! don't write the 0-th frame if the file already exists IF ( .NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step) ) THEN CALL cp_print_key_finished_output(unit_nr,logger,& - print_key, error=error) + print_key) RETURN END IF @@ -504,7 +486,7 @@ SUBROUTINE pint_write_com( pint_env, error ) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) RETURN END SUBROUTINE pint_write_com @@ -512,16 +494,13 @@ END SUBROUTINE pint_write_com ! *************************************************************************** !> \brief Writes out the energies according to PINT%PRINT%ENERGY !> \param pint_env path integral environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> various bug fixes [hforbert] !> 2009-11-16 energy components calc moved out of here [lwalewski] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_write_ener(pint_env,error) + SUBROUTINE pint_write_ener(pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_write_ener', & routineP = moduleN//':'//routineN @@ -533,24 +512,24 @@ SUBROUTINE pint_write_ener(pint_env,error) TYPE(section_vals_type), POINTER :: print_key failure = .FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) IF ( failure ) RETURN NULLIFY(print_key,logger) print_key => section_vals_get_subs_vals(pint_env%input, & - "MOTION%PINT%PRINT%ENERGY", error=error) - logger => cp_error_get_logger(error) + "MOTION%PINT%PRINT%ENERGY") + logger => cp_get_default_logger() IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) ) THEN + basis_section=print_key),cp_p_file) ) THEN unit_nr=cp_print_key_unit_nr(logger,print_key,middle_name="energy",& - extension=".dat",is_new_file=file_is_new,error=error ) + extension=".dat",is_new_file=file_is_new) ! don't write the 0-th frame if the file already exists IF ( .NOT. file_is_new .AND. (pint_env%iter .LE. pint_env%first_step) ) THEN CALL cp_print_key_finished_output(unit_nr,logger,& - print_key, error=error) + print_key) RETURN END IF @@ -571,7 +550,7 @@ SUBROUTINE pint_write_ener(pint_env,error) " CPU [s]" END IF - t=cp_unit_from_cp2k(pint_env%t,"fs",error=error) + t=cp_unit_from_cp2k(pint_env%t,"fs") ndof = pint_env%p IF ( pint_env%first_propagated_mode .EQ. 2 ) THEN @@ -579,7 +558,7 @@ SUBROUTINE pint_write_ener(pint_env,error) END IF temp = cp_unit_from_cp2k(2.0_dp*pint_env%e_kin_beads/& REAL(ndof,dp)/REAL(pint_env%ndim,dp),& - "K",error=error) + "K") WRITE (unit_nr,"(I8,1X,F12.3,1X,5(F20.9,1X),F12.1)")& pint_env%iter,& @@ -594,7 +573,7 @@ SUBROUTINE pint_write_ener(pint_env,error) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF RETURN @@ -604,15 +583,13 @@ END SUBROUTINE pint_write_ener ! *************************************************************************** !> \brief Write step info to the output file. !> \param pint_env ... -!> \param error ... !> \date 2009-11-16 !> \par History !> 2010-01-27 getting default unit nr now only on ionode [lwalewski] !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE pint_write_step_info( pint_env, error ) + SUBROUTINE pint_write_step_info( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_write_step_info', & routineP = moduleN//':'//routineN @@ -624,10 +601,10 @@ SUBROUTINE pint_write_step_info( pint_env, error ) TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() time_used = pint_env%time_per_step time_unit = "sec" @@ -670,14 +647,12 @@ END SUBROUTINE pint_write_step_info ! *************************************************************************** !> \brief Write radii of gyration according to PINT%PRINT%CENTROID_GYR !> \param pint_env ... -!> \param error ... !> \date 2011-01-07 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE pint_write_rgyr( pint_env, error ) + SUBROUTINE pint_write_rgyr( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_write_rgyr', & routineP = moduleN//':'//routineN @@ -691,25 +666,25 @@ SUBROUTINE pint_write_rgyr( pint_env, error ) TYPE(section_vals_type), POINTER :: print_key failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! decide whether to write anything or not NULLIFY(print_key) print_key => section_vals_get_subs_vals(pint_env%input, & - "MOTION%PINT%PRINT%CENTROID_GYR", error=error) + "MOTION%PINT%PRINT%CENTROID_GYR") should_output = BTEST(cp_print_key_should_output( & iteration_info=logger%iter_info,& - basis_section=print_key,error=error),cp_p_file) + basis_section=print_key),cp_p_file) IF ( .NOT. should_output ) THEN RETURN END IF ! get the units conversion factor - CALL section_vals_val_get(print_key,"UNIT",c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(print_key,"UNIT",c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) ! calculate the centroid positions nb=REAL(pint_env%p,dp) @@ -739,12 +714,12 @@ SUBROUTINE pint_write_rgyr( pint_env, error ) END DO unit_nr=cp_print_key_unit_nr(logger, print_key, is_new_file=new_file, & - middle_name="centroid-gyr",extension=".dat",error=error) + middle_name="centroid-gyr",extension=".dat") ! don't write the 0-th frame if the file already exists IF ( .NOT. new_file .AND. (pint_env%iter .LE. pint_env%first_step) ) THEN CALL cp_print_key_finished_output(unit_nr,logger,& - print_key, error=error) + print_key) RETURN END IF @@ -760,7 +735,7 @@ SUBROUTINE pint_write_rgyr( pint_env, error ) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) RETURN END SUBROUTINE pint_write_rgyr diff --git a/src/motion/pint_methods.F b/src/motion/pint_methods.F index f241849e7f..34c3a70fb1 100644 --- a/src/motion/pint_methods.F +++ b/src/motion/pint_methods.F @@ -116,7 +116,6 @@ MODULE pint_methods !> \param input ... !> \param input_declaration ... !> \param para_env ... -!> \param error ... !> \par History !> Fixed some bugs [hforbert] !> Added normal mode transformation [hforbert] @@ -124,12 +123,11 @@ MODULE pint_methods !> \note Might return an unassociated pointer in parallel on the processors !> that are not needed. ! ***************************************************************************** - SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) + SUBROUTINE pint_create(pint_env,input,input_declaration,para_env) TYPE(pint_env_type), POINTER :: pint_env TYPE(section_vals_type), POINTER :: input TYPE(section_type), POINTER :: input_declaration TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_create', & routineP = moduleN//':'//routineN @@ -141,7 +139,6 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) wrong_input REAL(kind=dp) :: mass REAL(kind=dp), DIMENSION(3, 2) :: seed - TYPE(cp_error_type) :: new_error TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env TYPE(particle_list_type), POINTER :: particles @@ -155,15 +152,14 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) failure=.FALSE. NULLIFY(f_env,subsys,particles, nose_section, gle_section) - CPPrecondition(.NOT.ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,error,failure) - CPPrecondition(input%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,failure) + CPPrecondition(input%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(rep_env) - pint_section => section_vals_get_subs_vals(input,"MOTION%PINT",& - error=error) - CALL section_vals_val_get(pint_section,"p",i_val=nrep,error=error) + pint_section => section_vals_get_subs_vals(input,"MOTION%PINT") + CALL section_vals_val_get(pint_section,"p",i_val=nrep) CALL section_vals_val_get(pint_section,"proc_per_replica",& - i_val=prep,error=error) + i_val=prep) ! Maybe let the user have his/her way as long as prep is ! within the bounds of number of CPUs?? IF ( (prep < 1) .OR. (prep > para_env%num_pe) .OR. & @@ -181,20 +177,20 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) ! after the rep_env_create has executed - the initialization of the ! replicas will run correctly anyways. ! TODO: modify rep_env so that it behaves better - CALL section_vals_val_get(input,"GLOBAL%PROJECT_NAME",c_val=project_name,error=error) - CALL section_vals_val_get(input,"GLOBAL%OUTPUT_FILE_NAME",c_val=output_file_name,error=error) + CALL section_vals_val_get(input,"GLOBAL%PROJECT_NAME",c_val=project_name) + CALL section_vals_val_get(input,"GLOBAL%OUTPUT_FILE_NAME",c_val=output_file_name) CALL rep_env_create(rep_env, para_env=para_env, input=input,& - input_declaration=input_declaration,nrep=nrep,prep=prep, row_force=.TRUE.,error=error) - CALL section_vals_val_set(input,"GLOBAL%PROJECT_NAME",c_val=TRIM(project_name),error=error) + input_declaration=input_declaration,nrep=nrep,prep=prep, row_force=.TRUE.) + CALL section_vals_val_set(input,"GLOBAL%PROJECT_NAME",c_val=TRIM(project_name)) IF ( LEN_TRIM(output_file_name) .GT. 0 ) THEN - CALL section_vals_val_set(input,"GLOBAL%OUTPUT_FILE_NAME",c_val=TRIM(output_file_name),error=error) + CALL section_vals_val_set(input,"GLOBAL%OUTPUT_FILE_NAME",c_val=TRIM(output_file_name)) ELSE - CALL section_vals_val_unset(input,"GLOBAL%OUTPUT_FILE_NAME",error=error) + CALL section_vals_val_unset(input,"GLOBAL%OUTPUT_FILE_NAME") END IF IF (.NOT. ASSOCIATED(rep_env)) RETURN ALLOCATE(pint_env,STAT=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) last_pint_id=last_pint_id+1 pint_env%id_nr=last_pint_id pint_env%ref_count=1 @@ -204,49 +200,45 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) pint_env%replicas => rep_env pint_env%ndim=rep_env%ndim pint_env%input => input - CALL section_vals_retain(pint_env%input,error=error) + CALL section_vals_retain(pint_env%input) ! get first step, last step, number of steps, etc CALL section_vals_val_get(input,"MOTION%PINT%ITERATION",& - i_val=itmp, error=error) + i_val=itmp) pint_env%first_step = itmp CALL section_vals_val_get(input,"MOTION%PINT%MAX_STEP",& - explicit=explicit, error=error) + explicit=explicit) IF ( explicit ) THEN CALL section_vals_val_get(input,"MOTION%PINT%MAX_STEP",& - i_val=itmp, error=error) + i_val=itmp) pint_env%last_step = itmp pint_env%num_steps = pint_env%last_step - pint_env%first_step ELSE CALL section_vals_val_get(input,"MOTION%PINT%NUM_STEPS",& - i_val=itmp, error=error) + i_val=itmp) pint_env%num_steps = itmp pint_env%last_step = pint_env%first_step + pint_env%num_steps END IF CALL section_vals_val_get(pint_section,"DT",& - r_val=pint_env%dt,error=error) + r_val=pint_env%dt) pint_env%t = pint_env%first_step * pint_env%dt - CALL section_vals_val_get(pint_section,"nrespa",i_val=pint_env%nrespa,& - error=error) - CALL section_vals_val_get(pint_section,"Temp",r_val=pint_env%kT,& - error=error) + CALL section_vals_val_get(pint_section,"nrespa",i_val=pint_env%nrespa) + CALL section_vals_val_get(pint_section,"Temp",r_val=pint_env%kT) CALL section_vals_val_get(pint_section,"T_TOL",& - r_val=pint_env%t_tol,error=error) + r_val=pint_env%t_tol) CALL section_vals_val_get(pint_section,"transformation",& - i_val=pint_env%transform, error=error) + i_val=pint_env%transform) NULLIFY(pint_env%tx,pint_env%tv,pint_env%tv_t,pint_env%tv_old,pint_env%tv_new,pint_env%tf) pint_env%nnos = 0 pint_env%pimd_thermostat = thermostat_none - nose_section => section_vals_get_subs_vals(input,"MOTION%PINT%NOSE",& - error=error) - CALL section_vals_get(nose_section, explicit=explicit, error=error) + nose_section => section_vals_get_subs_vals(input,"MOTION%PINT%NOSE") + CALL section_vals_get(nose_section, explicit=explicit) IF(explicit) THEN - CALL section_vals_val_get(nose_section,"nnos",i_val=pint_env%nnos,& - error=error) + CALL section_vals_val_get(nose_section,"nnos",i_val=pint_env%nnos) IF(pint_env%nnos>0)THEN pint_env%pimd_thermostat = thermostat_nose ALLOCATE(& @@ -256,7 +248,7 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) pint_env%tv_old(pint_env%nnos,pint_env%p,pint_env%ndim),& pint_env%tv_new(pint_env%nnos,pint_env%p,pint_env%ndim),& pint_env%tf(pint_env%nnos,pint_env%p,pint_env%ndim), STAT=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) pint_env%tx = 0._dp pint_env%tv = 0._dp pint_env%tv_t = 0._dp @@ -270,22 +262,21 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) !TODO ! v_tol not in current input structure ! should also probably be part of nose_section -! CALL section_vals_val_get(transform_section,"v_tol_nose",r_val=pint_env%v_tol,& -! error=error) +! CALL section_vals_val_get(transform_section,"v_tol_nose",r_val=pint_env%v_tol) !MK ... but we have to initialise v_tol pint_env%v_tol = 0.0_dp ! to be fixed NULLIFY (pint_env%randomG) - seed(:,:) = next_rng_seed(error=error) + seed(:,:) = next_rng_seed() CALL create_rng_stream(pint_env%randomG,& name="pint_randomG",& distribution_type=GAUSSIAN,& extended_precision=.TRUE.,& - seed=seed,error=error) + seed=seed) ALLOCATE(pint_env%e_pot_bead(pint_env%p),STAT=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) pint_env%e_pot_bead=0._dp pint_env%e_pot_h=0._dp pint_env%e_kin_beads=0._dp @@ -310,7 +301,7 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) pint_env%rtmp_ndim(pint_env%ndim), & pint_env%rtmp_natom(pint_env%ndim/3), & STAT=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) pint_env%x = 0._dp pint_env%v = 0._dp pint_env%f = 0._dp @@ -327,24 +318,23 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) IF (pint_env%transform == transformation_stage) THEN transform_section => section_vals_get_subs_vals(input,& - "MOTION%PINT%STAGING",error=error) + "MOTION%PINT%STAGING") CALL staging_env_create(pint_env%staging_env,transform_section,& - p=pint_env%p,kT=pint_env%kT, error=error) + p=pint_env%p,kT=pint_env%kT) ELSE transform_section => section_vals_get_subs_vals(input,& - "MOTION%PINT%NORMALMODE",error=error) + "MOTION%PINT%NORMALMODE") CALL normalmode_env_create(pint_env%normalmode_env,& - transform_section,p=pint_env%p,kT=pint_env%kT,error=error) + transform_section,p=pint_env%p,kT=pint_env%kT) wrong_input=pint_env%nrespa*twopi/(SQRT(pint_env%p/pint_env%normalmode_env%modefactor)*pint_env%kT)/pint_env%dt>10 - CPPostcondition(wrong_input,cp_warning_level,routineP,error,failure) + CPPostcondition(wrong_input,cp_warning_level,routineP,failure) END IF ALLOCATE(pint_env%mass(pint_env%ndim),STAT=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) CALL f_env_add_defaults(f_env_id=pint_env%replicas%f_env_id,& - f_env=f_env,new_error=new_error, failure=failure) - CALL force_env_get(force_env=f_env%force_env,subsys=subsys,& - error=new_error) - CALL cp_subsys_get(subsys,particles=particles,error=new_error) + f_env=f_env,failure=failure) + CALL force_env_get(force_env=f_env%force_env,subsys=subsys) + CALL cp_subsys_get(subsys,particles=particles) !TODO length of pint_env%mass is redundant idim=0 @@ -355,32 +345,31 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) pint_env%mass(idim)=mass END DO END DO - CALL f_env_rm_defaults(f_env,new_error,ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CALL f_env_rm_defaults(f_env,ierr) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE(pint_env%Q(pint_env%p),& pint_env%mass_beads(pint_env%p,pint_env%ndim),& pint_env%mass_fict(pint_env%p,pint_env%ndim),STAT=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) IF (pint_env%transform == transformation_stage) THEN CALL staging_init_masses(pint_env%staging_env,mass=pint_env%mass,& mass_beads=pint_env%mass_beads,mass_fict=pint_env%mass_fict,& - Q=pint_env%Q,error=error) + Q=pint_env%Q) ELSE CALL normalmode_init_masses(pint_env%normalmode_env, & mass=pint_env%mass, mass_beads=pint_env%mass_beads, & - mass_fict=pint_env%mass_fict, Q=pint_env%Q, error=error) + mass_fict=pint_env%mass_fict, Q=pint_env%Q) END IF NULLIFY(pint_env%gle) - gle_section => section_vals_get_subs_vals(input,"MOTION%PINT%GLE",& - error=error) - CALL section_vals_get(gle_section, explicit=explicit, error=error) + gle_section => section_vals_get_subs_vals(input,"MOTION%PINT%GLE") + CALL section_vals_get(gle_section, explicit=explicit) IF(explicit) THEN ALLOCATE(pint_env%gle,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) CALL gle_init(pint_env%gle, dt=pint_env%dt/pint_env%nrespa, temp=pint_env%kT,& - section=gle_section, error=error) + section=gle_section) IF (pint_env%pimd_thermostat==thermostat_none .AND. pint_env%gle%ndim .GT. 0) THEN pint_env%pimd_thermostat=thermostat_gle @@ -389,11 +378,11 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) pint_env%gle%loc_num_gle=pint_env%p*pint_env%ndim pint_env%gle%glob_num_gle=pint_env%gle%loc_num_gle ALLOCATE(pint_env%gle%map_info%index(pint_env%gle%loc_num_gle)) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO itmp = 1, pint_env%gle%loc_num_gle pint_env%gle%map_info%index(itmp)=itmp ENDDO - CALL gle_thermo_create(pint_env%gle,pint_env%gle%loc_num_gle,error) + CALL gle_thermo_create(pint_env%gle,pint_env%gle%loc_num_gle) ! here we should have read a_mat and c_mat; !we can therefore compute the matrices needed for the propagator @@ -405,12 +394,12 @@ SUBROUTINE pint_create(pint_env,input,input_declaration,para_env,error) MATMUL(pint_env%gle%c_mat,TRANSPOSE(pint_env%gle%gle_t))), & pint_env%gle%gle_s, pint_env%gle%ndim) ! and initialize the additional momenta - CALL pint_gle_init(pint_env, error) + CALL pint_gle_init(pint_env) END IF END IF CALL section_vals_val_get(pint_section,"FIX_CENTROID_POS",& - l_val=ltmp,error=error) + l_val=ltmp) IF ( ltmp .AND. (pint_env%transform .EQ. transformation_normal) ) THEN pint_env%first_propagated_mode = 2 ELSE @@ -426,13 +415,10 @@ END SUBROUTINE pint_create ! *************************************************************************** !> \brief Retain a path integral environment !> \param pint_env the pint_env to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pint_retain(pint_env,error) + SUBROUTINE pint_retain(pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_retain', & routineP = moduleN//':'//routineN @@ -441,8 +427,8 @@ SUBROUTINE pint_retain(pint_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) pint_env%ref_count=pint_env%ref_count+1 RETURN END SUBROUTINE pint_retain @@ -450,15 +436,12 @@ END SUBROUTINE pint_retain ! *************************************************************************** !> \brief Release a path integral environment !> \param pint_env the pint_env to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Added normal mode transformation [hforbert] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pint_release(pint_env,error) + SUBROUTINE pint_release(pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_release', & routineP = moduleN//':'//routineN @@ -469,75 +452,75 @@ SUBROUTINE pint_release(pint_env,error) failure=.FALSE. IF (ASSOCIATED(pint_env)) THEN - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) pint_env%ref_count=pint_env%ref_count-1 IF (pint_env%ref_count==0) THEN - CALL rep_env_release(pint_env%replicas,error=error) - CALL section_vals_release(pint_env%input,error=error) + CALL rep_env_release(pint_env%replicas) + CALL section_vals_release(pint_env%input) IF (ASSOCIATED(pint_env%staging_env)) THEN - CALL staging_release(pint_env%staging_env,error=error) + CALL staging_release(pint_env%staging_env) END IF IF (ASSOCIATED(pint_env%normalmode_env)) THEN - CALL normalmode_release(pint_env%normalmode_env,error=error) + CALL normalmode_release(pint_env%normalmode_env) END IF - CALL delete_rng_stream(pint_env%randomG,error=error) + CALL delete_rng_stream(pint_env%randomG) DEALLOCATE(pint_env%mass,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%e_pot_bead,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%x,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%v,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%f,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%external_f,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%mass_beads,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%mass_fict,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%ux,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%uv,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%uv_t,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%uv_new,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%uf,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%uf_h,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%rtmp_ndim,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%rtmp_natom,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) IF(pint_env%pimd_thermostat==thermostat_nose) THEN DEALLOCATE(pint_env%tx,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%tv,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%tv_t,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%tv_old,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%tv_new,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env%tf,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSEIF(pint_env%pimd_thermostat==thermostat_gle) THEN - CALL gle_dealloc(pint_env%gle, error=error) + CALL gle_dealloc(pint_env%gle) END IF DEALLOCATE(pint_env%Q,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pint_env,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF @@ -552,15 +535,12 @@ END SUBROUTINE pint_release !> \param para_env parallel environment !> \param input the input to test !> \param input_declaration ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_test(para_env,input,input_declaration,error) + SUBROUTINE pint_test(para_env,input,input_declaration) TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: input TYPE(section_type), POINTER :: input_declaration - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_test', & routineP = moduleN//':'//routineN @@ -575,20 +555,20 @@ SUBROUTINE pint_test(para_env,input,input_declaration,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,error,failure) - CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(input%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,failure) + CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(input%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(pint_env) - logger => cp_error_get_logger(error) - CALL pint_create(pint_env,input,input_declaration,para_env,error=error) + logger => cp_get_default_logger() + CALL pint_create(pint_env,input,input_declaration,para_env) IF (ASSOCIATED(pint_env)) THEN ALLOCATE(x1(pint_env%ndim,pint_env%p),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) x1(:,:)=pint_env%x - CALL pint_x2u(pint_env,error=error) + CALL pint_x2u(pint_env) pint_env%x=0._dp - CALL pint_u2x(pint_env,error=error) + CALL pint_u2x(pint_env) err=0._dp DO i=1,pint_env%ndim err=MAX(err,ABS(x1(1,i)-pint_env%x(1,i))) @@ -596,7 +576,7 @@ SUBROUTINE pint_test(para_env,input,input_declaration,error) CALL cp_log(logger,cp_note_level+1,routineP,"diff_r1="//cp_to_string(err),& local=.FALSE.) - CALL pint_calc_uf_h(pint_env,e_h=e_h,error=error) + CALL pint_calc_uf_h(pint_env,e_h=e_h) c=-pint_env%staging_env%w_p**2 pint_env%f=0._dp DO idim=1,pint_env%ndim @@ -607,7 +587,7 @@ SUBROUTINE pint_test(para_env,input,input_declaration,error) -pint_env%x(MODULO(ib,pint_env%p)+1,idim)) END DO END DO - CALL pint_f2uf(pint_env,error=error) + CALL pint_f2uf(pint_env) err=0._dp DO idim=1,pint_env%ndim DO ib=1,pint_env%p @@ -626,20 +606,17 @@ END SUBROUTINE pint_test !> \param input the input to test !> \param input_declaration ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 2003-11 created [fawzi] !> 2009-12-14 globenv parameter added to handle soft exit !> requests [lwalewski] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE do_pint_run( para_env, input, input_declaration, globenv, error ) + SUBROUTINE do_pint_run( para_env, input, input_declaration, globenv) TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: input TYPE(section_type), POINTER :: input_declaration TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_pint_run', & routineP = moduleN//':'//routineN @@ -658,19 +635,19 @@ SUBROUTINE do_pint_run( para_env, input, input_declaration, globenv, error ) failure=.FALSE. - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,error,failure) - CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(input%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,failure) + CPPrecondition(para_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(input%ref_count>0,cp_failure_level,routineP,failure) ! check if helium solvent is present NULLIFY(helium_section) helium_section => section_vals_get_subs_vals(input,& - "MOTION%PINT%HELIUM",error=error) - CALL section_vals_get(helium_section,explicit=explicit,error=error) + "MOTION%PINT%HELIUM") + CALL section_vals_get(helium_section,explicit=explicit) IF ( explicit ) THEN CALL section_vals_val_get(helium_section,"_SECTION_PARAMETERS_",& - l_val=solvent_present,error=error) + l_val=solvent_present) ELSE solvent_present = .FALSE. END IF @@ -678,7 +655,7 @@ SUBROUTINE do_pint_run( para_env, input, input_declaration, globenv, error ) ! check if there is anything but helium IF (solvent_present) THEN CALL section_vals_val_get(helium_section,"HELIUM_ONLY",& - l_val=helium_only,error=error) + l_val=helium_only) ELSE helium_only = .FALSE. END IF @@ -701,35 +678,35 @@ SUBROUTINE do_pint_run( para_env, input, input_declaration, globenv, error ) SELECT CASE (mode) CASE (helium_only_mid) - CALL helium_create(helium,input,error=error) - CALL helium_init(helium,pint_env,error) - CALL helium_do_run(helium,globenv,error) - CALL helium_release(helium,error=error) + CALL helium_create(helium,input) + CALL helium_init(helium,pint_env) + CALL helium_do_run(helium,globenv) + CALL helium_release(helium) CASE (solute_only_mid) - CALL pint_create(pint_env,input,input_declaration,para_env,error=error) - CALL pint_init(pint_env,error) - CALL pint_do_run(pint_env,globenv,error=error) - CALL pint_release(pint_env,error=error) + CALL pint_create(pint_env,input,input_declaration,para_env) + CALL pint_init(pint_env) + CALL pint_do_run(pint_env,globenv) + CALL pint_release(pint_env) CASE (solute_with_helium_mid) - CALL pint_create(pint_env,input,input_declaration,para_env,error=error) + CALL pint_create(pint_env,input,input_declaration,para_env) ! init pint wihtout helium forces (they are not yet initialized) - CALL pint_init(pint_env,error) + CALL pint_init(pint_env) ! init helium with solute's positions (they are already initialized) - CALL helium_create(helium,input,solute=pint_env,error=error) - CALL helium_init(helium,pint_env,error) + CALL helium_create(helium,input,solute=pint_env) + CALL helium_init(helium,pint_env) ! reinit pint forces with helium forces (they are now initialized) - CALL pint_init_f( pint_env, helium_solvent=helium, error=error ) + CALL pint_init_f( pint_env, helium_solvent=helium) - CALL pint_do_run(pint_env,globenv,helium=helium,error=error) - CALL helium_release(helium,error=error) - CALL pint_release(pint_env,error=error) + CALL pint_do_run(pint_env,globenv,helium=helium) + CALL helium_release(helium) + CALL pint_release(pint_env) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Unknown mode ("//TRIM(ADJUSTL(cp_to_string(mode)))//")",& - error,failure) + failure) END SELECT @@ -741,17 +718,15 @@ END SUBROUTINE do_pint_run ! *************************************************************************** !> \brief Reads the restart, initializes the beads, etc. !> \param pint_env ... -!> \param error ... !> \par History !> 11.2003 created [fawzi] !> actually ASSIGN input pointer [hforbert] !> 2010-12-16 turned into a wrapper routine [lwalewski] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pint_init(pint_env, error) + SUBROUTINE pint_init(pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_init', & routineP = moduleN//':'//routineN @@ -759,16 +734,16 @@ SUBROUTINE pint_init(pint_env, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) IF ( failure ) THEN RETURN END IF - CALL pint_init_x( pint_env, error ) - CALL pint_init_v( pint_env, error=error ) - CALL pint_init_t( pint_env, error=error ) - CALL pint_init_f( pint_env, error=error ) + CALL pint_init_x( pint_env) + CALL pint_init_v( pint_env) + CALL pint_init_t( pint_env) + CALL pint_init_f( pint_env) RETURN END SUBROUTINE pint_init @@ -777,7 +752,6 @@ END SUBROUTINE pint_init ! *************************************************************************** !> \brief Assign initial postions to the beads. !> \param pint_env ... -!> \param error ... !> \date 2010-12-15 !> \author Lukasz Walewski !> \note Initialization is done in the following way: @@ -790,10 +764,9 @@ END SUBROUTINE pint_init !> 4. apply Gaussian noise to the positions generated so far (if !> requested) ! ***************************************************************************** - SUBROUTINE pint_init_x( pint_env, error ) + SUBROUTINE pint_init_x( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_init_x', & routineP = moduleN//':'//routineN @@ -812,8 +785,8 @@ SUBROUTINE pint_init_x( pint_env, error ) TYPE(section_vals_type), POINTER :: input_section failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) IF ( failure ) THEN RETURN END IF @@ -827,35 +800,35 @@ SUBROUTINE pint_init_x( pint_env, error ) done_levy = .FALSE. CALL section_vals_val_get(pint_env%input,& "MOTION%PINT%INIT%LEVY_POS_SAMPLE",& - l_val=ltmp,error=error) + l_val=ltmp) CALL section_vals_val_get(pint_env%input,& "MOTION%PINT%INIT%LEVY_TEMP_FACTOR",& - r_val=tcorr,error=error) + r_val=tcorr) IF ( ltmp ) THEN NULLIFY(bx) ALLOCATE(bx(3*pint_env%p), STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) NULLIFY (rng_gaussian) CALL section_vals_val_get(pint_env%input,& - "MOTION%PINT%INIT%LEVY_SEED",i_val=input_seed,error=error) + "MOTION%PINT%INIT%LEVY_SEED",i_val=input_seed) seed(:,:) = REAL(input_seed,KIND=dp) -! seed(:,:) = next_rng_seed(error=error) +! seed(:,:) = next_rng_seed() CALL create_rng_stream(rng_gaussian,& name="tmp_rng_gaussian",& distribution_type=GAUSSIAN,& extended_precision=.TRUE.,& - seed=seed,error=error) + seed=seed) CALL section_vals_val_get(pint_env%input,& "MOTION%PINT%INIT%LEVY_CORRELATED",& - l_val=levycorr,error=error) + l_val=levycorr) IF ( levycorr ) THEN ! correlated Levy walk - the same path for all atoms x0 = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - CALL pint_levy_walk( x0, pint_env%p, 1.0_dp, bx, rng_gaussian, error ) + CALL pint_levy_walk( x0, pint_env%p, 1.0_dp, bx, rng_gaussian) idim = 0 DO ia = 1, pint_env%ndim/3 var = SQRT(1.0_dp/(pint_env%kT*tcorr*pint_env%mass(3*ia))) @@ -876,7 +849,7 @@ SUBROUTINE pint_init_x( pint_env, error ) x0(2) = pint_env%x(1,3*(ia-1)+2) x0(3) = pint_env%x(1,3*(ia-1)+3) var = SQRT(1.0_dp/(pint_env%kT*tcorr*pint_env%mass(3*ia))) - CALL pint_levy_walk( x0, pint_env%p, var, bx, rng_gaussian, error ) + CALL pint_levy_walk( x0, pint_env%p, var, bx, rng_gaussian) DO ic = 1, 3 idim = idim + 1 DO ib=1,pint_env%p @@ -887,30 +860,29 @@ SUBROUTINE pint_init_x( pint_env, error ) END IF - CALL delete_rng_stream(rng_gaussian,error=error) + CALL delete_rng_stream(rng_gaussian) DEALLOCATE(bx, STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) done_levy = .TRUE. END IF done_init = .FALSE. NULLIFY(input_section) input_section => section_vals_get_subs_vals(pint_env%input,& - "MOTION%PINT%BEADS%COORD",& - error=error) - CALL section_vals_get(input_section,explicit=explicit,error=error) + "MOTION%PINT%BEADS%COORD") + CALL section_vals_get(input_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CPPrecondition(n_rep_val==1,cp_failure_level,routineP,error,failure) + CPPrecondition(n_rep_val==1,cp_failure_level,routineP,failure) CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - r_vals=r_vals,error=error) + r_vals=r_vals) CALL cp_assert(SIZE(r_vals)==pint_env%p*pint_env%ndim,& cp_failure_level,cp_assertion_failed,& "Invalid size of MOTION%PINT%BEADS%COORD "//& CPSourceFileRef,& - routineP,error,failure) + routineP,failure) ic=0 DO idim=1,pint_env%ndim DO ib=1,pint_env%p @@ -925,15 +897,14 @@ SUBROUTINE pint_init_x( pint_env, error ) done_rand = .FALSE. CALL section_vals_val_get(pint_env%input,& "MOTION%PINT%INIT%RANDOMIZE_POS",& - l_val=ltmp,error=error) + l_val=ltmp) IF ( ltmp ) THEN DO idim=1,pint_env%ndim DO ib=1,pint_env%p pint_env%x(ib,idim) = pint_env%x(ib,idim) + & next_random_number(rng_stream=pint_env%randomG,& variance=pint_env%beta/& - SQRT(12.0_dp*pint_env%mass(idim)),& - error=error) + SQRT(12.0_dp*pint_env%mass(idim))) END DO END DO done_rand = .TRUE. @@ -947,7 +918,7 @@ SUBROUTINE pint_init_x( pint_env, error ) ELSE WRITE(msg,'(A,A)') TRIM(tmp), " hot start" END IF - CALL pint_write_line(msg, error) + CALL pint_write_line(msg) IF ( done_levy ) THEN WRITE(msg,'(A,F6.3)') "Levy walk at effective temperature: ", tcorr @@ -955,7 +926,7 @@ SUBROUTINE pint_init_x( pint_env, error ) IF ( done_rand ) THEN WRITE(msg,'(A)') "Added gaussian noise to the positions of the beads." - CALL pint_write_line(msg, error) + CALL pint_write_line(msg) END IF RETURN @@ -966,8 +937,6 @@ END SUBROUTINE pint_init_x !> \brief Initialize velocities !> \param pint_env the pint env in which you should initialize the !> velocity -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 2010-12-16 gathered all velocity-init code here [lwalewski] !> 2011-04-05 added centroid velocity initialization [lwalewski] @@ -985,9 +954,8 @@ END SUBROUTINE pint_init_x !> 6. set the vels according to the explicit values from the input !> if present ! ***************************************************************************** - SUBROUTINE pint_init_v( pint_env, error ) + SUBROUTINE pint_init_v( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_init_v', & routineP = moduleN//':'//routineN @@ -1007,32 +975,31 @@ SUBROUTINE pint_init_v( pint_env, error ) TYPE(section_vals_type), POINTER :: input_section failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) IF ( failure ) THEN RETURN END IF NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! read the velocities from the input file if they are given explicitly vels_present = .FALSE. NULLIFY(input_section) input_section => section_vals_get_subs_vals(pint_env%input,& - "FORCE_EVAL%SUBSYS%VELOCITY",& - error=error) - CALL section_vals_get(input_section,explicit=explicit,error=error) + "FORCE_EVAL%SUBSYS%VELOCITY") + CALL section_vals_get(input_section,explicit=explicit) IF ( explicit ) THEN CALL section_vals_val_get(input_section,"PINT_UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_to_cp2k(1.0_dp,TRIM(unit_str)) ! assign all the beads with the same velocities from FORCE_EVAL%SUBSYS%VELOCITY NULLIFY(r_vals) CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) stmp = "" WRITE(stmp,*) n_rep_val msg = "Invalid number of atoms in FORCE_EVAL%SUBSYS%VELOCITY ("//& @@ -1041,10 +1008,10 @@ SUBROUTINE pint_init_v( pint_env, error ) cp_failure_level, cp_assertion_failed,& routineP//" from "//& CPSourceFileRef,& - msg, error, failure) + msg,failure) DO ia = 1, pint_env%ndim/3 CALL section_vals_val_get(input_section, "_DEFAULT_KEYWORD_",& - i_rep_val=ia, r_vals=r_vals, error=error) + i_rep_val=ia, r_vals=r_vals) itmp = SIZE(r_vals) stmp = "" WRITE(stmp,*) itmp @@ -1054,7 +1021,7 @@ SUBROUTINE pint_init_v( pint_env, error ) cp_failure_level, cp_assertion_failed,& routineP//" from "//& CPSourceFileRef,& - msg, error, failure) + msg,failure) DO ib = 1, pint_env%p DO ic = 1, 3 idim = 3*(ia-1)+ic @@ -1088,7 +1055,7 @@ SUBROUTINE pint_init_v( pint_env, error ) target_t = pint_env%kT CALL section_vals_val_get(pint_env%input, & "MOTION%PINT%INIT%VELOCITY_SCALE",& - l_val=done_scale,error=error) + l_val=done_scale) IF (vels_present) THEN IF (done_scale) THEN ! rescale the velocities to match the target temperature @@ -1109,7 +1076,7 @@ SUBROUTINE pint_init_v( pint_env, error ) ! draw velocities from the M-B distribution... IF (vels_present) THEN ! ...for non-centroid modes only - CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v) first_mode = 2 ELSE ! ...for all the modes @@ -1119,8 +1086,7 @@ SUBROUTINE pint_init_v( pint_env, error ) DO ib = first_mode, SIZE(pint_env%uv,1) pint_env%uv(ib,idim) = & next_random_number(rng_stream=pint_env%randomG,& - variance=target_t/pint_env%mass_fict(ib,idim),& - error=error) + variance=target_t/pint_env%mass_fict(ib,idim)) END DO END DO @@ -1128,18 +1094,18 @@ SUBROUTINE pint_init_v( pint_env, error ) done_sped = .FALSE. CALL section_vals_val_get(pint_env%input,& "MOTION%PINT%INIT%CENTROID_SPEED",& - l_val=ltmp,error=error) + l_val=ltmp) IF (ltmp) THEN - CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_u2x(pint_env,ux=pint_env%uv,x=pint_env%v) DO idim=1,pint_env%ndim rtmp = next_random_number(rng_stream=pint_env%randomG,& - variance=pint_env%mass(idim)*pint_env%kT,& - error=error)/pint_env%mass(idim) + variance=pint_env%mass(idim)*pint_env%kT)& + /pint_env%mass(idim) DO ib=1,pint_env%p pint_env%v(ib,idim)=pint_env%v(ib,idim)+rtmp END DO END DO - CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v) done_sped = .TRUE. END IF @@ -1148,14 +1114,14 @@ SUBROUTINE pint_init_v( pint_env, error ) done_quench = .FALSE. CALL section_vals_val_get(pint_env%input,& "MOTION%PINT%INIT%VELOCITY_QUENCH",& - l_val=ltmp,error=error) + l_val=ltmp) IF (ltmp) THEN DO idim=1,pint_env%ndim DO ib=1,pint_env%p pint_env%v(ib,idim) = 0.0_dp END DO END DO - CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v) done_quench = .TRUE. END IF @@ -1164,21 +1130,20 @@ SUBROUTINE pint_init_v( pint_env, error ) done_init = .FALSE. NULLIFY(input_section) input_section => section_vals_get_subs_vals(pint_env%input,& - "MOTION%PINT%BEADS%VELOCITY",& - error=error) - CALL section_vals_get(input_section,explicit=explicit,error=error) + "MOTION%PINT%BEADS%VELOCITY") + CALL section_vals_get(input_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CPPrecondition(n_rep_val==1,cp_failure_level,routineP,error,failure) + CPPrecondition(n_rep_val==1,cp_failure_level,routineP,failure) CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - r_vals=r_vals,error=error) + r_vals=r_vals) CALL cp_assert(SIZE(r_vals)==pint_env%p*pint_env%ndim,& cp_failure_level,cp_assertion_failed,& "Invalid size of MOTION%PINT%BEAD%VELOCITY "//& CPSourceFileRef,& - routineP,error,failure) + routineP,failure) itmp=0 DO idim=1,pint_env%ndim DO ib=1,pint_env%p @@ -1186,12 +1151,12 @@ SUBROUTINE pint_init_v( pint_env, error ) pint_env%v(ib,idim)=r_vals(itmp) END DO END DO - CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v,error=error) + CALL pint_x2u(pint_env,ux=pint_env%uv,x=pint_env%v) done_init = .TRUE. END IF END IF - unit_conv = cp_unit_from_cp2k(1.0_dp,"K",error=error) + unit_conv = cp_unit_from_cp2k(1.0_dp,"K") WRITE(stmp1,'(F10.2)') target_t * unit_conv msg = "Bead velocities initialization:" IF ( done_init ) THEN @@ -1204,13 +1169,13 @@ SUBROUTINE pint_init_v( pint_env, error ) END IF msg = TRIM(ADJUSTL(msg))//" Maxwell-Boltzmann at "//TRIM(ADJUSTL(stmp1))//" K." END IF - CALL pint_write_line(msg, error) + CALL pint_write_line(msg) IF ( done_init .AND. done_quench ) THEN msg = "WARNING: exclusive options requested (velocity restart and quenching)" - CALL pint_write_line(msg, error) + CALL pint_write_line(msg) msg = "WARNING: velocity restart took precedence" - CALL pint_write_line(msg, error) + CALL pint_write_line(msg) END IF IF ( (.NOT. done_init) .AND. (.NOT. done_quench) ) THEN @@ -1219,11 +1184,11 @@ SUBROUTINE pint_init_v( pint_env, error ) WRITE(stmp2,'(F10.2)') target_t * unit_conv msg = "Scaled initial velocities from "//TRIM(ADJUSTL(stmp1))//& " to "//TRIM(ADJUSTL(stmp2))//" K as requested." - CALL pint_write_line(msg, error) + CALL pint_write_line(msg) END IF IF ( done_sped ) THEN msg = "Added random component to the initial centroid velocities." - CALL pint_write_line(msg, error) + CALL pint_write_line(msg) END IF END IF @@ -1235,16 +1200,14 @@ END SUBROUTINE pint_init_v !> \brief Assign initial postions and velocities to the thermostats. !> \param pint_env ... !> \param kT ... -!> \param error ... !> \date 2010-12-15 !> \author Lukasz Walewski !> \note Extracted from pint_init ! ***************************************************************************** - SUBROUTINE pint_init_t( pint_env, kT, error ) + SUBROUTINE pint_init_t( pint_env, kT) TYPE(pint_env_type), POINTER :: pint_env REAL(kind=dp), INTENT(in), OPTIONAL :: kT - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_init_t', & routineP = moduleN//':'//routineN @@ -1256,8 +1219,8 @@ SUBROUTINE pint_init_t( pint_env, kT, error ) TYPE(section_vals_type), POINTER :: input_section failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) IF ( failure ) THEN RETURN END IF @@ -1271,29 +1234,27 @@ SUBROUTINE pint_init_t( pint_env, kT, error ) DO inos=1,SIZE(pint_env%tv,1) pint_env%tv(inos,ib,idim) = & next_random_number(rng_stream=pint_env%randomG,& - variance=mykt/pint_env%Q(ib),& - error=error) + variance=mykt/pint_env%Q(ib)) END DO END DO END DO NULLIFY(input_section) input_section => section_vals_get_subs_vals(pint_env%input,& - "MOTION%PINT%NOSE%COORD",& - error=error) - CALL section_vals_get(input_section,explicit=explicit,error=error) + "MOTION%PINT%NOSE%COORD") + CALL section_vals_get(input_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CPPrecondition(n_rep_val==1,cp_failure_level,routineP,error,failure) + CPPrecondition(n_rep_val==1,cp_failure_level,routineP,failure) CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - r_vals=r_vals,error=error) + r_vals=r_vals) CALL cp_assert(SIZE(r_vals)==pint_env%p*pint_env%ndim*pint_env%nnos,& cp_failure_level,cp_assertion_failed,& "Invalid size of MOTION%PINT%NOSE%COORD "//& CPSourceFileRef,& - routineP,error,failure) + routineP,failure) ii=0 DO idim=1,pint_env%ndim DO ib=1,pint_env%p @@ -1308,21 +1269,20 @@ SUBROUTINE pint_init_t( pint_env, kT, error ) NULLIFY(input_section) input_section => section_vals_get_subs_vals(pint_env%input,& - "MOTION%PINT%NOSE%VELOCITY",& - error=error) - CALL section_vals_get(input_section,explicit=explicit,error=error) + "MOTION%PINT%NOSE%VELOCITY") + CALL section_vals_get(input_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CPPrecondition(n_rep_val==1,cp_failure_level,routineP,error,failure) + CPPrecondition(n_rep_val==1,cp_failure_level,routineP,failure) CALL section_vals_val_get(input_section,"_DEFAULT_KEYWORD_",& - r_vals=r_vals,error=error) + r_vals=r_vals) CALL cp_assert(SIZE(r_vals)==pint_env%p*pint_env%ndim*pint_env%nnos,& cp_failure_level,cp_assertion_failed,& "Invalid size of MOTION%PINT%NOSE%VELOCITY "//& CPSourceFileRef,& - routineP,error,failure) + routineP,failure) ii=0 DO idim=1,pint_env%ndim DO ib=1,pint_env%p @@ -1338,12 +1298,11 @@ SUBROUTINE pint_init_t( pint_env, kT, error ) ELSEIF(pint_env%pimd_thermostat==thermostat_gle) THEN NULLIFY(input_section) input_section => section_vals_get_subs_vals(pint_env%input,& - "MOTION%PINT%GLE",& - error=error) - CALL section_vals_get(input_section,explicit=explicit,error=error) + "MOTION%PINT%GLE") + CALL section_vals_get(input_section,explicit=explicit) IF (explicit) THEN CALL restart_gle(pint_env%gle,input_section,save_mem=.FALSE.,& - restart=gle_restart,error=error) + restart=gle_restart) END IF END IF @@ -1355,17 +1314,15 @@ END SUBROUTINE pint_init_t !> \brief Prepares the forces, etc. to perform an MD step !> \param pint_env ... !> \param helium_solvent ... -!> \param error ... !> \par History !> Added nh_energy calculation [hforbert] !> Bug fixes for no thermostats [hforbert] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_init_f( pint_env, helium_solvent, error ) + SUBROUTINE pint_init_f( pint_env, helium_solvent) TYPE(pint_env_type), POINTER :: pint_env TYPE(helium_solvent_type), OPTIONAL, & POINTER :: helium_solvent - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_init_f', & routineP = moduleN//':'//routineN @@ -1375,11 +1332,11 @@ SUBROUTINE pint_init_f( pint_env, helium_solvent, error ) REAL(kind=dp) :: e_h failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL pint_x2u(pint_env,error=error) - CALL pint_calc_uf_h(pint_env=pint_env,e_h=e_h,error=error) - CALL pint_calc_f(pint_env,error=error) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) + CALL pint_x2u(pint_env) + CALL pint_calc_uf_h(pint_env=pint_env,e_h=e_h) + CALL pint_calc_f(pint_env) ! add helium forces to the solute's internal ones ! Assume that helium has been already initialized and helium_solvent @@ -1389,15 +1346,15 @@ SUBROUTINE pint_init_f( pint_env, helium_solvent, error ) pint_env%f(:,:) = pint_env%f(:,:) + helium_solvent%force_avrg(:,:) END IF END IF - CALL pint_f2uf(pint_env,error=error) + CALL pint_f2uf(pint_env) ! set the centroid forces to 0 if FIX_CENTROID_POS IF ( pint_env%first_propagated_mode .EQ. 2 ) THEN pint_env%uf(1,:) = 0.0_dp END IF - CALL pint_calc_e_kin_beads_u(pint_env,error=error) - CALL pint_calc_e_vir(pint_env,error=error) + CALL pint_calc_e_kin_beads_u(pint_env) + CALL pint_calc_e_vir(pint_env) DO idim=1,SIZE(pint_env%uf_h,2) DO ib=pint_env%first_propagated_mode,SIZE(pint_env%uf_h,1) pint_env%uf_h(ib,idim)=pint_env%uf_h(ib,idim)& @@ -1425,7 +1382,7 @@ SUBROUTINE pint_init_f( pint_env, helium_solvent, error ) END DO END DO END DO - CALL pint_calc_nh_energy(pint_env,error=error) + CALL pint_calc_nh_energy(pint_env) END IF RETURN END SUBROUTINE pint_init_f @@ -1436,7 +1393,6 @@ END SUBROUTINE pint_init_f !> \param pint_env ... !> \param globenv ... !> \param helium ... -!> \param error ... !> \par History !> 2003-11 created [fawzi] !> renamed from pint_run to pint_do_run because of conflicting name @@ -1446,12 +1402,11 @@ END SUBROUTINE pint_init_f !> \author Fawzi Mohamed !> \note Everything should be read for an md step. ! ***************************************************************************** - SUBROUTINE pint_do_run(pint_env, globenv, helium, error) + SUBROUTINE pint_do_run(pint_env, globenv, helium) TYPE(pint_env_type), POINTER :: pint_env TYPE(global_environment_type), POINTER :: globenv TYPE(helium_solvent_type), OPTIONAL, & POINTER :: helium - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_do_run', & routineP = moduleN//':'//routineN @@ -1461,23 +1416,23 @@ SUBROUTINE pint_do_run(pint_env, globenv, helium, error) REAL(kind=dp) :: scal failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) NULLIFY(pint_env%logger) - pint_env%logger => cp_error_get_logger(error) + pint_env%logger => cp_get_default_logger() ! create iteration level and initialize iteration info - CALL cp_add_iter_level(pint_env%logger%iter_info,"MD",error=error) - CALL cp_iterate(pint_env%logger%iter_info,iter_nr=pint_env%first_step,error=error) + CALL cp_add_iter_level(pint_env%logger%iter_info,"MD") + CALL cp_iterate(pint_env%logger%iter_info,iter_nr=pint_env%first_step) pint_env%iter = pint_env%first_step ! write the properties at 0-th step - CALL pint_calc_energy(pint_env,error) - CALL pint_write_ener(pint_env,error=error) - CALL pint_write_centroids(pint_env,error=error) - CALL pint_write_trajectory(pint_env,error=error) - CALL pint_write_com(pint_env,error=error) - CALL pint_write_rgyr(pint_env,error=error) + CALL pint_calc_energy(pint_env) + CALL pint_write_ener(pint_env) + CALL pint_write_centroids(pint_env) + CALL pint_write_trajectory(pint_env) + CALL pint_write_com(pint_env) + CALL pint_write_rgyr(pint_env) ! main PIMD loop DO step = 1, pint_env%num_steps @@ -1485,7 +1440,7 @@ SUBROUTINE pint_do_run(pint_env, globenv, helium, error) pint_env%iter = pint_env%iter + 1 CALL cp_iterate(pint_env%logger%iter_info,& last=(step==pint_env%num_steps),& - iter_nr=pint_env%iter,error=error) + iter_nr=pint_env%iter) pint_env%t = pint_env%t + pint_env%dt IF (pint_env%t_tol > 0.0_dp) THEN @@ -1493,28 +1448,28 @@ SUBROUTINE pint_do_run(pint_env, globenv, helium, error) -pint_env%kT)>pint_env%t_tol) THEN scal=SQRT(pint_env%kT*(pint_env%p*pint_env%ndim)/(2.0_dp*pint_env%e_kin_beads)) pint_env%uv=scal*pint_env%uv - CALL pint_init_f(pint_env,helium_solvent=helium,error=error) + CALL pint_init_f(pint_env,helium_solvent=helium) END IF END IF - CALL pint_step(pint_env,helium_solvent=helium,error=error) + CALL pint_step(pint_env,helium_solvent=helium) - CALL pint_write_ener(pint_env,error=error) - CALL pint_write_centroids(pint_env,error=error) - CALL pint_write_trajectory(pint_env,error=error) - CALL pint_write_com(pint_env,error=error) - CALL pint_write_rgyr(pint_env,error=error) + CALL pint_write_ener(pint_env) + CALL pint_write_centroids(pint_env) + CALL pint_write_trajectory(pint_env) + CALL pint_write_com(pint_env) + CALL pint_write_rgyr(pint_env) CALL write_restart(root_section=pint_env%input,& - pint_env=pint_env, helium_env=helium, error=error) + pint_env=pint_env, helium_env=helium) ! exit from the main loop if soft exit has been requested - CALL external_control(should_stop,"MD",globenv=globenv,error=error) + CALL external_control(should_stop,"MD",globenv=globenv) IF (should_stop) EXIT END DO ! remove iteration level - CALL cp_rm_iter_level(pint_env%logger%iter_info,"MD",error=error) + CALL cp_rm_iter_level(pint_env%logger%iter_info,"MD") RETURN END SUBROUTINE pint_do_run @@ -1524,16 +1479,14 @@ END SUBROUTINE pint_do_run !> \brief Does an MD step (and nrespa harmonic evaluations) !> \param pint_env ... !> \param helium_solvent ... -!> \param error ... !> \par History !> various bug fixes [hforbert] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_step(pint_env,helium_solvent,error) + SUBROUTINE pint_step(pint_env,helium_solvent) TYPE(pint_env_type), POINTER :: pint_env TYPE(helium_solvent_type), OPTIONAL, & POINTER :: helium_solvent - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_step', & routineP = moduleN//':'//routineN @@ -1551,7 +1504,7 @@ SUBROUTINE pint_step(pint_env,helium_solvent,error) time_start = m_walltime() failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) rn=REAL(pint_env%nrespa,dp) dti=pint_env%dt/rn @@ -1594,22 +1547,22 @@ SUBROUTINE pint_step(pint_env,helium_solvent,error) ! calc forces at new pos - CALL pint_calc_uf_h(pint_env=pint_env,e_h=e_h,error=error) + CALL pint_calc_uf_h(pint_env=pint_env,e_h=e_h) IF (iresp==pint_env%nrespa) THEN - CALL pint_u2x(pint_env,error=error) - CALL pint_calc_f(pint_env,error=error) + CALL pint_u2x(pint_env) + CALL pint_calc_f(pint_env) ! perform helium step and add helium forces IF (PRESENT(helium_solvent)) THEN IF (ASSOCIATED(helium_solvent)) THEN helium_solvent%current_step = pint_env%iter - helium_solvent%origin = pint_com_pos(pint_env,error) - CALL helium_step( helium_solvent, pint_env, error ) + helium_solvent%origin = pint_com_pos(pint_env) + CALL helium_step( helium_solvent, pint_env) pint_env%f(:,:)=pint_env%f(:,:)+helium_solvent%force_avrg(:,:) END IF END IF - CALL pint_f2uf(pint_env,error=error) + CALL pint_f2uf(pint_env) pint_env%uf_h=pint_env%uf_h+rn*pint_env%uf END IF @@ -1664,7 +1617,7 @@ SUBROUTINE pint_step(pint_env,helium_solvent,error) -pint_env%tv(inos,:,:)*pint_env%tv(inos+1,:,:) END DO ELSEIF(pint_env%pimd_thermostat==thermostat_gle) THEN - CALL pint_gle_step(pint_env, error=error) + CALL pint_gle_step(pint_env) pint_env%uv=pint_env%uv_t ELSE pint_env%uv=pint_env%uv_t @@ -1672,7 +1625,7 @@ SUBROUTINE pint_step(pint_env,helium_solvent,error) END DO ! calculate the energy components - CALL pint_calc_energy( pint_env, error ) + CALL pint_calc_energy( pint_env) ! check that the number of MD steps matches ! the number of force evaluations done so far @@ -1685,13 +1638,13 @@ SUBROUTINE pint_step(pint_env,helium_solvent,error) ! cp_failure_level,cp_assertion_failed,routineP,& ! "md & force_eval lost sychro "//& ! CPSourceFileRef,& -! error,failure) +! failure) ! CALL f_env_rm_defaults(f_env,new_error,ierr) time_stop = m_walltime() pint_env%time_per_step = time_stop - time_start - CALL pint_write_step_info(pint_env,error) + CALL pint_write_step_info(pint_env) CALL timestop(handle) RETURN @@ -1701,25 +1654,23 @@ END SUBROUTINE pint_step ! *************************************************************************** !> \brief Calculate the energy components (private wrapper function) !> \param pint_env ... -!> \param error ... !> \date 2011-01-07 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE pint_calc_energy( pint_env, error ) + SUBROUTINE pint_calc_energy( pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_calc_energy', & routineP = moduleN//':'//routineN - CALL pint_calc_e_kin_beads_u(pint_env,error=error) - CALL pint_calc_e_vir(pint_env,error=error) + CALL pint_calc_e_kin_beads_u(pint_env) + CALL pint_calc_e_vir(pint_env) IF (pint_env%pimd_thermostat==thermostat_nose) THEN - CALL pint_calc_nh_energy(pint_env,error=error) + CALL pint_calc_nh_energy(pint_env) ELSEIF (pint_env%pimd_thermostat==thermostat_gle) THEN - CALL pint_calc_gle_energy(pint_env,error=error) + CALL pint_calc_gle_energy(pint_env) END IF pint_env%energy(e_kin_thermo_id) = & @@ -1744,16 +1695,13 @@ END SUBROUTINE pint_calc_energy !> \param pint_env the path integral environment in which the harmonic !> forces should be calculated !> \param e_h ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Added normal mode transformation [hforbert] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_calc_uf_h(pint_env,e_h,error) + SUBROUTINE pint_calc_uf_h(pint_env,e_h) TYPE(pint_env_type), POINTER :: pint_env REAL(KIND=dp), INTENT(OUT) :: e_h - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_calc_uf_h', & routineP = moduleN//':'//routineN @@ -1767,15 +1715,13 @@ SUBROUTINE pint_calc_uf_h(pint_env,e_h,error) pint_env%mass_beads,& pint_env%ux,& pint_env%uf_h,& - pint_env%e_pot_h,& - error=error) + pint_env%e_pot_h) ELSE CALL normalmode_calc_uf_h(pint_env%normalmode_env,& pint_env%mass_beads,& pint_env%ux,& pint_env%uf_h,& - pint_env%e_pot_h,& - error=error) + pint_env%e_pot_h) END IF e_h=pint_env%e_pot_h pint_env%uf_h=pint_env%uf_h/pint_env%mass_fict @@ -1790,13 +1736,11 @@ END SUBROUTINE pint_calc_uf_h !> \param x positions at which you want to evaluate the forces !> \param f the forces !> \param e potential energy on each bead -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 2009-06-15 moved helium calls out from here [lwalewski] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_calc_f(pint_env,x,f,e,error) + SUBROUTINE pint_calc_f(pint_env,x,f,e) TYPE(pint_env_type), POINTER :: pint_env REAL(kind=dp), DIMENSION(:, :), & INTENT(in), OPTIONAL, TARGET :: x @@ -1804,7 +1748,6 @@ SUBROUTINE pint_calc_f(pint_env,x,f,e,error) INTENT(out), OPTIONAL, TARGET :: f REAL(kind=dp), DIMENSION(:), & INTENT(out), OPTIONAL, TARGET :: e - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_calc_f', & routineP = moduleN//':'//routineN @@ -1816,8 +1759,8 @@ SUBROUTINE pint_calc_f(pint_env,x,f,e,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) my_x => pint_env%x IF (PRESENT(x)) my_x => x my_f => pint_env%f @@ -1829,7 +1772,7 @@ SUBROUTINE pint_calc_f(pint_env,x,f,e,error) pint_env%replicas%r(idim,ib)=my_x(ib,idim) END DO END DO - CALL rep_env_calc_e_f(pint_env%replicas,calc_f=.TRUE.,error=error) + CALL rep_env_calc_e_f(pint_env%replicas,calc_f=.TRUE.) DO idim=1,pint_env%ndim DO ib=1,pint_env%p !ljw: is that fine ? - idim <-> ib @@ -1846,18 +1789,15 @@ END SUBROUTINE pint_calc_f !> \param pint_env ... !> \param uv ... !> \param e_k ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Bug fix to give my_uv a default location if not given in call [hforbert] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_calc_e_kin_beads_u(pint_env,uv,e_k,error) + SUBROUTINE pint_calc_e_kin_beads_u(pint_env,uv,e_k) TYPE(pint_env_type), POINTER :: pint_env REAL(kind=dp), DIMENSION(:, :), & INTENT(in), OPTIONAL, TARGET :: uv REAL(kind=dp), INTENT(out), OPTIONAL :: e_k - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_calc_e_kin_beads_u', & routineP = moduleN//':'//routineN @@ -1869,8 +1809,8 @@ SUBROUTINE pint_calc_e_kin_beads_u(pint_env,uv,e_k,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) res=-1.0_dp my_uv => pint_env%uv IF (PRESENT(uv)) my_uv => uv @@ -1890,15 +1830,13 @@ END SUBROUTINE pint_calc_e_kin_beads_u !> \brief Calculate the virial estimator of the real (quantum) kinetic energy !> \param pint_env ... !> \param e_vir ... -!> \param error ... !> \author hforbert !> \note This subroutine modifies pint_env%energy(e_kin_virial_id) global !> variable [lwalewski] ! ***************************************************************************** - SUBROUTINE pint_calc_e_vir(pint_env,e_vir,error) + SUBROUTINE pint_calc_e_vir(pint_env,e_vir) TYPE(pint_env_type), POINTER :: pint_env REAL(kind=dp), INTENT(out), OPTIONAL :: e_vir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_calc_e_vir', & routineP = moduleN//':'//routineN @@ -1909,8 +1847,8 @@ SUBROUTINE pint_calc_e_vir(pint_env,e_vir,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) res=-1.0_dp res=0._dp DO idim=1,pint_env%ndim @@ -1934,13 +1872,10 @@ END SUBROUTINE pint_calc_e_vir !> \brief calculates the energy (potential and kinetic) of the Nose-Hoover !> chain thermostats !> \param pint_env the path integral environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_calc_nh_energy(pint_env,error) + SUBROUTINE pint_calc_nh_energy(pint_env) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_calc_nh_energy', & routineP = moduleN//':'//routineN @@ -1951,8 +1886,8 @@ SUBROUTINE pint_calc_nh_energy(pint_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) ekin=0._dp DO idim=1,pint_env%ndim DO ib=1,pint_env%p diff --git a/src/motion/pint_normalmode.F b/src/motion/pint_normalmode.F index 095bf87a2b..61a5bd402f 100644 --- a/src/motion/pint_normalmode.F +++ b/src/motion/pint_normalmode.F @@ -44,16 +44,13 @@ MODULE pint_normalmode !> \param normalmode_section ... !> \param p ... !> \param kT ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** - SUBROUTINE normalmode_env_create(normalmode_env,normalmode_section,p,kT,error) + SUBROUTINE normalmode_env_create(normalmode_env,normalmode_section,p,kT) TYPE(normalmode_env_type), POINTER :: normalmode_env TYPE(section_vals_type), POINTER :: normalmode_section INTEGER, INTENT(in) :: p REAL(kind=dp), INTENT(in) :: kT - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_env_create', & routineP = moduleN//':'//routineN @@ -64,13 +61,13 @@ SUBROUTINE normalmode_env_create(normalmode_env,normalmode_section,p,kT,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(normalmode_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(normalmode_env),cp_failure_level,routineP,failure) ALLOCATE(normalmode_env,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE(normalmode_env%x2u(p,p),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE(normalmode_env%u2x(p,p),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) last_normalmode_id=last_normalmode_id+1 normalmode_env%id_nr=last_normalmode_id normalmode_env%ref_count=1 @@ -78,11 +75,11 @@ SUBROUTINE normalmode_env_create(normalmode_env,normalmode_section,p,kT,error) normalmode_env%p=p CALL section_vals_val_get(normalmode_section,"Q_CENTROID", & - r_val=normalmode_env%Q_centroid,error=error) + r_val=normalmode_env%Q_centroid) CALL section_vals_val_get(normalmode_section,"Q_BEAD", & - r_val=normalmode_env%Q_bead,error=error) + r_val=normalmode_env%Q_bead) CALL section_vals_val_get(normalmode_section,"MODEFACTOR", & - r_val=normalmode_env%modefactor,error=error) + r_val=normalmode_env%modefactor) IF (normalmode_env%Q_centroid < 0.0_dp) THEN normalmode_env%Q_centroid = -normalmode_env%Q_centroid/(kT*p) @@ -121,14 +118,11 @@ END SUBROUTINE normalmode_env_create ! *************************************************************************** !> \brief releases the normalmode environment !> \param normalmode_env the normalmode_env to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** - SUBROUTINE normalmode_release(normalmode_env,error) + SUBROUTINE normalmode_release(normalmode_env) TYPE(normalmode_env_type), POINTER :: normalmode_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_release', & routineP = moduleN//':'//routineN @@ -139,15 +133,15 @@ SUBROUTINE normalmode_release(normalmode_env,error) failure=.FALSE. IF (ASSOCIATED(normalmode_env)) THEN - CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,failure) normalmode_env%ref_count=normalmode_env%ref_count-1 IF (normalmode_env%ref_count==0) THEN DEALLOCATE(normalmode_env%x2u,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(normalmode_env%u2x,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(normalmode_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(normalmode_env) @@ -158,14 +152,11 @@ END SUBROUTINE normalmode_release ! *************************************************************************** !> \brief retains a normalmode_env !> \param normalmode_env the normalmode_env to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** - SUBROUTINE normalmode_retain(normalmode_env,error) + SUBROUTINE normalmode_retain(normalmode_env) TYPE(normalmode_env_type), POINTER :: normalmode_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_retain', & routineP = moduleN//':'//routineN @@ -174,8 +165,8 @@ SUBROUTINE normalmode_retain(normalmode_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,error,failure) - CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,failure) + CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,failure) normalmode_env%ref_count=normalmode_env%ref_count+1 RETURN @@ -189,12 +180,10 @@ END SUBROUTINE normalmode_retain !> \param mass_beads masses of the beads !> \param mass_fict the fictitious masses !> \param Q masses of the nose thermostats -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** SUBROUTINE normalmode_init_masses(normalmode_env,mass,mass_beads,mass_fict,& - Q,error) + Q) TYPE(normalmode_env_type), POINTER :: normalmode_env REAL(kind=dp), DIMENSION(:), INTENT(in) :: mass @@ -202,7 +191,6 @@ SUBROUTINE normalmode_init_masses(normalmode_env,mass,mass_beads,mass_fict,& INTENT(out), OPTIONAL :: mass_beads, mass_fict REAL(kind=dp), DIMENSION(:), & INTENT(out), OPTIONAL :: Q - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_init_masses', & routineP = moduleN//':'//routineN @@ -243,17 +231,14 @@ END SUBROUTINE normalmode_init_masses !> \param normalmode_env the environment for the normal mode transformation !> \param ux will contain the u variable !> \param x the positions to transform -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** - SUBROUTINE normalmode_x2u(normalmode_env,ux,x,error) + SUBROUTINE normalmode_x2u(normalmode_env,ux,x) TYPE(normalmode_env_type), POINTER :: normalmode_env REAL(kind=dp), DIMENSION(:, :), & INTENT(out) :: ux REAL(kind=dp), DIMENSION(:, :), & INTENT(in) :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_x2u', & routineP = moduleN//':'//routineN @@ -262,8 +247,8 @@ SUBROUTINE normalmode_x2u(normalmode_env,ux,x,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,error,failure) - CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,failure) + CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,failure) CALL DGEMM('N','N',normalmode_env%p,SIZE(x,2),normalmode_env%p,1.0_dp,& normalmode_env%x2u(1,1),SIZE(normalmode_env%x2u,1),x(1,1),SIZE(x,1),& 0.0_dp,ux,SIZE(ux,1)) @@ -276,17 +261,14 @@ END SUBROUTINE normalmode_x2u !> \param normalmode_env the environment for the normal mode transformation !> \param ux the u variable (positions to be backtransformed) !> \param x will contain the positions -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** - SUBROUTINE normalmode_u2x(normalmode_env,ux,x,error) + SUBROUTINE normalmode_u2x(normalmode_env,ux,x) TYPE(normalmode_env_type), POINTER :: normalmode_env REAL(kind=dp), DIMENSION(:, :), & INTENT(in) :: ux REAL(kind=dp), DIMENSION(:, :), & INTENT(out) :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_u2x', & routineP = moduleN//':'//routineN @@ -295,8 +277,8 @@ SUBROUTINE normalmode_u2x(normalmode_env,ux,x,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,error,failure) - CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,failure) + CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,failure) CALL DGEMM('N','N',normalmode_env%p,SIZE(ux,2),normalmode_env%p,1.0_dp,& normalmode_env%u2x(1,1),SIZE(normalmode_env%u2x,1),ux(1,1),SIZE(ux,1),& 0.0_dp,x,SIZE(x,1)) @@ -308,17 +290,14 @@ END SUBROUTINE normalmode_u2x !> \param normalmode_env the environment for the normal mode transformation !> \param uf will contain the forces for the transformed variables afterwards !> \param f the forces to transform -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** - SUBROUTINE normalmode_f2uf(normalmode_env,uf,f,error) + SUBROUTINE normalmode_f2uf(normalmode_env,uf,f) TYPE(normalmode_env_type), POINTER :: normalmode_env REAL(kind=dp), DIMENSION(:, :), & INTENT(out) :: uf REAL(kind=dp), DIMENSION(:, :), & INTENT(in) :: f - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_f2uf', & routineP = moduleN//':'//routineN @@ -327,8 +306,8 @@ SUBROUTINE normalmode_f2uf(normalmode_env,uf,f,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,error,failure) - CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(normalmode_env),cp_failure_level,routineP,failure) + CPPrecondition(normalmode_env%ref_count>0,cp_failure_level,routineP,failure) CALL DGEMM('T','N',normalmode_env%p,SIZE(f,2),normalmode_env%p,1.0_dp,& normalmode_env%u2x(1,1),SIZE(normalmode_env%u2x,1),f(1,1),SIZE(f,1),& 0.0_dp,uf,SIZE(uf,1)) @@ -342,15 +321,12 @@ END SUBROUTINE normalmode_f2uf !> \param ux the positions of the beads in the staging basis !> \param uf_h the harmonic forces (not accelerations) !> \param e_h ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Harald Forbert ! ***************************************************************************** - SUBROUTINE normalmode_calc_uf_h(normalmode_env,mass_beads,ux,uf_h,e_h,error) + SUBROUTINE normalmode_calc_uf_h(normalmode_env,mass_beads,ux,uf_h,e_h) TYPE(normalmode_env_type), POINTER :: normalmode_env REAL(kind=dp), DIMENSION(:, :), POINTER :: mass_beads, ux, uf_h REAL(KIND=dp), INTENT(OUT) :: e_h - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'normalmode_calc_uf_h', & routineP = moduleN//':'//routineN diff --git a/src/motion/pint_public.F b/src/motion/pint_public.F index 974f4d2b4f..9455a5d28c 100644 --- a/src/motion/pint_public.F +++ b/src/motion/pint_public.F @@ -33,17 +33,15 @@ MODULE pint_public ! *************************************************************************** !> \brief Return the center of mass of the PI system !> \param pint_env ... -!> \param error ... !> \retval com_r ... !> \date 2009-07-24 !> \par History !> 2009-11-30 fixed serious bug in pint_env%x indexing [lwalewski] !> \author Lukasz Walewski ! ***************************************************************************** - FUNCTION pint_com_pos(pint_env,error) RESULT(com_r) + FUNCTION pint_com_pos(pint_env) RESULT(com_r) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(kind=dp), DIMENSION(3) :: com_r CHARACTER(len=*), PARAMETER :: routineN = 'pint_com_pos', & @@ -54,7 +52,7 @@ FUNCTION pint_com_pos(pint_env,error) RESULT(com_r) REAL(kind=dp) :: tmass failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) tmass = 0.0_dp com_r(:) = 0.0_dp @@ -78,15 +76,13 @@ END FUNCTION pint_com_pos ! *************************************************************************** !> \brief Return the center of geometry of the PI system !> \param pint_env ... -!> \param error ... !> \retval cntrd_r ... !> \date 2009-11-30 !> \author Lukasz Walewski ! ***************************************************************************** - FUNCTION pint_cog_pos(pint_env,error) RESULT(cntrd_r) + FUNCTION pint_cog_pos(pint_env) RESULT(cntrd_r) TYPE(pint_env_type), POINTER :: pint_env - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(kind=dp), DIMENSION(3) :: cntrd_r CHARACTER(len=*), PARAMETER :: routineN = 'pint_cog_pos', & @@ -96,7 +92,7 @@ FUNCTION pint_cog_pos(pint_env,error) RESULT(cntrd_r) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) cntrd_r(:) = 0.0_dp natoms = pint_env%ndim/3 @@ -119,14 +115,13 @@ END FUNCTION pint_cog_pos !> \param rng_gaussian ... !> \param x ... !> \param nout ... -!> \param error ... !> \date 2010-12-13 !> \author Lukasz Walewski !> \note This routine implements Levy argorithm (see e.g. Rev. Mod. Phys. !> 67 (1995) 279, eq. 5.35) and requires that n is a power of 2. The !> resulting bead positions are centered around (0,0,0). ! ***************************************************************************** - SUBROUTINE pint_free_part_bead_x( n, t, rng_gaussian, x, nout, error) + SUBROUTINE pint_free_part_bead_x( n, t, rng_gaussian, x, nout) ! !TODO this routine gives wrong spread of the particles, please fix before usage. ! @@ -135,7 +130,6 @@ SUBROUTINE pint_free_part_bead_x( n, t, rng_gaussian, x, nout, error) TYPE(rng_stream_type), POINTER :: rng_gaussian REAL(kind=dp), DIMENSION(:), POINTER :: x INTEGER, INTENT(OUT) :: nout - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_free_part_bead_x', & routineP = moduleN//':'//routineN @@ -191,8 +185,7 @@ SUBROUTINE pint_free_part_bead_x( n, t, rng_gaussian, x, nout, error) DO ic = 1, 3 xc = ( x(3*i1+ic) + x(3*i2+ic) ) / 2.0 xc = xc + next_random_number(rng_stream=rng_gaussian,& - variance=vrnc,& - error=error) + variance=vrnc) x(3*j+ic) = xc END DO nout = nout + 1 @@ -225,19 +218,17 @@ END SUBROUTINE pint_free_part_bead_x !> \param v ... !> \param x ... !> \param rng_gaussian ... -!> \param error ... !> \date 2011-01-06 !> \author Lukasz Walewski !> \note This routine implements Levy argorithm (Phys. Rev. 143 (1966) 58) ! ***************************************************************************** - SUBROUTINE pint_levy_walk( x0, n, v, x, rng_gaussian, error ) + SUBROUTINE pint_levy_walk( x0, n, v, x, rng_gaussian) REAL(kind=dp), DIMENSION(3), INTENT(IN) :: x0 INTEGER, INTENT(IN) :: n REAL(kind=dp), INTENT(IN) :: v REAL(kind=dp), DIMENSION(:), POINTER :: x TYPE(rng_stream_type), POINTER :: rng_gaussian - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_levy_walk', & routineP = moduleN//':'//routineN @@ -252,8 +243,7 @@ SUBROUTINE pint_levy_walk( x0, n, v, x, rng_gaussian, error ) DO ib = 1, n-1 DO ic = 1, 3 r = next_random_number(rng_stream=rng_gaussian,& - variance=1.0_dp,& - error=error) + variance=1.0_dp) tau_i = (REAL(ib,dp)-1.0_dp)/REAL(n,dp) tau_i1 = (REAL(ib+1,dp)-1.0_dp)/REAL(n,dp) x(ib*3+ic) = ( x((ib-1)*3+ic) * ( 1.0_dp-tau_i1 ) + & diff --git a/src/motion/pint_staging.F b/src/motion/pint_staging.F index 344684dcc2..500946048a 100644 --- a/src/motion/pint_staging.F +++ b/src/motion/pint_staging.F @@ -39,16 +39,13 @@ MODULE pint_staging !> \param staging_section ... !> \param p ... !> \param kT ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE staging_env_create(staging_env,staging_section,p,kT,error) + SUBROUTINE staging_env_create(staging_env,staging_section,p,kT) TYPE(staging_env_type), POINTER :: staging_env TYPE(section_vals_type), POINTER :: staging_section INTEGER, INTENT(in) :: p REAL(kind=dp), INTENT(in) :: kT - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_env_create', & routineP = moduleN//':'//routineN @@ -58,17 +55,15 @@ SUBROUTINE staging_env_create(staging_env,staging_section,p,kT,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(staging_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(staging_env),cp_failure_level,routineP,failure) ALLOCATE(staging_env,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) last_staging_id=last_staging_id+1 staging_env%id_nr=last_staging_id staging_env%ref_count=1 - CALL section_vals_val_get(staging_section,"j",i_val=staging_env%j,& - error=error) - CALL section_vals_val_get(staging_section,"Q_end",i_val=staging_env%j,& - error=error) + CALL section_vals_val_get(staging_section,"j",i_val=staging_env%j) + CALL section_vals_val_get(staging_section,"Q_end",i_val=staging_env%j) staging_env%p=p staging_env%nseg=staging_env%p/staging_env%j @@ -84,13 +79,10 @@ END SUBROUTINE staging_env_create ! *************************************************************************** !> \brief releases the staging environment !> \param staging_env the staging_env to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE staging_release(staging_env,error) + SUBROUTINE staging_release(staging_env) TYPE(staging_env_type), POINTER :: staging_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_release', & routineP = moduleN//':'//routineN @@ -101,11 +93,11 @@ SUBROUTINE staging_release(staging_env,error) failure=.FALSE. IF (ASSOCIATED(staging_env)) THEN - CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,failure) staging_env%ref_count=staging_env%ref_count-1 IF (staging_env%ref_count==0) THEN DEALLOCATE(staging_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(staging_env) @@ -115,13 +107,10 @@ END SUBROUTINE staging_release ! *************************************************************************** !> \brief retains a staging_env !> \param staging_env the staging_env to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE staging_retain(staging_env,error) + SUBROUTINE staging_retain(staging_env) TYPE(staging_env_type), POINTER :: staging_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_retain', & routineP = moduleN//':'//routineN @@ -130,8 +119,8 @@ SUBROUTINE staging_retain(staging_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,error,failure) - CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,failure) + CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,failure) staging_env%ref_count=staging_env%ref_count+1 RETURN END SUBROUTINE staging_retain @@ -144,21 +133,18 @@ END SUBROUTINE staging_retain !> \param mass_beads masses of the beads !> \param mass_fict the fictitious masses !> \param Q masses of the nose thermostats -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE staging_init_masses(staging_env,mass,mass_beads,mass_fict,& - Q,error) + Q) TYPE(staging_env_type), POINTER :: staging_env REAL(kind=dp), DIMENSION(:), INTENT(in) :: mass REAL(kind=dp), DIMENSION(:, :), & INTENT(out), OPTIONAL :: mass_beads, mass_fict REAL(kind=dp), DIMENSION(:), & INTENT(out), OPTIONAL :: Q - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_init_masses', & routineP = moduleN//':'//routineN @@ -178,7 +164,7 @@ SUBROUTINE staging_init_masses(staging_env,mass,mass_beads,mass_fict,& IF (PRESENT(mass_beads).OR.PRESENT(mass_fict)) THEN ALLOCATE(scal(staging_env%p),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO iseg=1,staging_env%nseg DO i=1,staging_env%j ! check order!!! scal(staging_env%j*(iseg-1)+i)=REAL(i,dp)/REAL(MAX(1,i-1),dp) @@ -214,17 +200,14 @@ END SUBROUTINE staging_init_masses !> \param staging_env the environment for the staging transformation !> \param ux will contain the u variable !> \param x the positions to transform -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE staging_x2u(staging_env,ux,x,error) + SUBROUTINE staging_x2u(staging_env,ux,x) TYPE(staging_env_type), POINTER :: staging_env REAL(kind=dp), DIMENSION(:, :), & INTENT(out) :: ux REAL(kind=dp), DIMENSION(:, :), & INTENT(in) :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_x2u', & routineP = moduleN//':'//routineN @@ -234,8 +217,8 @@ SUBROUTINE staging_x2u(staging_env,ux,x,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,error,failure) - CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,failure) + CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,failure) ux=x DO s=0,staging_env%nseg-1 DO k=2,staging_env%j @@ -254,17 +237,14 @@ END SUBROUTINE staging_x2u !> \param staging_env the environment for the staging transformation !> \param ux the u variable (positions to be backtransformed) !> \param x will contain the positions -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE staging_u2x(staging_env,ux,x,error) + SUBROUTINE staging_u2x(staging_env,ux,x) TYPE(staging_env_type), POINTER :: staging_env REAL(kind=dp), DIMENSION(:, :), & INTENT(in) :: ux REAL(kind=dp), DIMENSION(:, :), & INTENT(out) :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_u2x', & routineP = moduleN//':'//routineN @@ -276,13 +256,13 @@ SUBROUTINE staging_u2x(staging_env,ux,x,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,error,failure) - CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,failure) + CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,failure) j=staging_env%j const=REAL(j-1,dp)/REAL(j,dp) const2=1._dp/REAL(j,dp) ALLOCATE(iii(staging_env%nseg),jjj(staging_env%nseg),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,staging_env%nseg iii(i)=staging_env%j*(i-1)+1 !first el END DO @@ -311,17 +291,14 @@ END SUBROUTINE staging_u2x !> \param staging_env the environment for the staging transformation !> \param uf will contain the forces after for the transformed variable !> \param f the forces to transform -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE staging_f2uf(staging_env,uf,f,error) + SUBROUTINE staging_f2uf(staging_env,uf,f) TYPE(staging_env_type), POINTER :: staging_env REAL(kind=dp), DIMENSION(:, :), & INTENT(out) :: uf REAL(kind=dp), DIMENSION(:, :), & INTENT(in) :: f - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_f2uf', & routineP = moduleN//':'//routineN @@ -333,12 +310,12 @@ SUBROUTINE staging_f2uf(staging_env,uf,f,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,error,failure) - CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(staging_env),cp_failure_level,routineP,failure) + CPPrecondition(staging_env%ref_count>0,cp_failure_level,routineP,failure) const=REAL(staging_env%j-1,dp)/REAL(staging_env%j,dp) ALLOCATE(iii(staging_env%j),jjj(staging_env%j),& kkk(staging_env%j),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO ist=1,staging_env%j-1 iii(ist)=(ist-1)*staging_env%j+1 ! first el jjj(ist)=iii(ist)+staging_env%j-1 ! last el @@ -375,15 +352,12 @@ END SUBROUTINE staging_f2uf !> \param ux the positions of the beads in the staging basis !> \param uf_h the harmonic forces (not accelerations) !> \param e_h ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE staging_calc_uf_h(staging_env,mass_beads,ux,uf_h,e_h,error) + SUBROUTINE staging_calc_uf_h(staging_env,mass_beads,ux,uf_h,e_h) TYPE(staging_env_type), POINTER :: staging_env REAL(kind=dp), DIMENSION(:, :), POINTER :: mass_beads, ux, uf_h REAL(KIND=dp), INTENT(OUT) :: e_h - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'staging_calc_uf_h', & routineP = moduleN//':'//routineN @@ -400,7 +374,7 @@ SUBROUTINE staging_calc_uf_h(staging_env,mass_beads,ux,uf_h,e_h,error) ALLOCATE(iii(staging_env%nseg),jjj(staging_env%nseg),& kkk(staging_env%nseg),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO ist=1,staging_env%nseg iii(ist)=(ist-1)*staging_env%j+1 ! first el diff --git a/src/motion/pint_transformations.F b/src/motion/pint_transformations.F index e15df99ffe..92f46ff973 100644 --- a/src/motion/pint_transformations.F +++ b/src/motion/pint_transformations.F @@ -33,19 +33,16 @@ MODULE pint_transformations !> \param pint_env the path integral environment !> \param ux will contain the u variable (defaults to pint_env%ux) !> \param x the positions to transform (defaults to pint_env%x) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Added normal mode transformation [hforbert] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_x2u(pint_env,ux,x,error) + SUBROUTINE pint_x2u(pint_env,ux,x) TYPE(pint_env_type), POINTER :: pint_env REAL(kind=dp), DIMENSION(:, :), & INTENT(out), OPTIONAL, TARGET :: ux REAL(kind=dp), DIMENSION(:, :), & INTENT(in), OPTIONAL, TARGET :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_x2u', & routineP = moduleN//':'//routineN @@ -55,19 +52,19 @@ SUBROUTINE pint_x2u(pint_env,ux,x,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) my_x => pint_env%x my_ux => pint_env%ux IF (PRESENT(x)) my_x => x IF (PRESENT(ux)) my_ux => ux - CPPrecondition(ASSOCIATED(my_ux),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(my_x),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(my_ux),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(my_x),cp_failure_level,routineP,failure) IF (pint_env%transform == transformation_stage) THEN - CALL staging_x2u(pint_env%staging_env,ux=my_ux,x=my_x,error=error) + CALL staging_x2u(pint_env%staging_env,ux=my_ux,x=my_x) ELSE - CALL normalmode_x2u(pint_env%normalmode_env,ux=my_ux,x=my_x,error=error) + CALL normalmode_x2u(pint_env%normalmode_env,ux=my_ux,x=my_x) END IF RETURN END SUBROUTINE pint_x2u @@ -77,19 +74,16 @@ END SUBROUTINE pint_x2u !> \param pint_env path integral environment !> \param ux the u variable (positions to be backtransformed) !> \param x will contain the positions -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Added normal mode transformation by hforbert !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_u2x(pint_env,ux,x,error) + SUBROUTINE pint_u2x(pint_env,ux,x) TYPE(pint_env_type), POINTER :: pint_env REAL(kind=dp), DIMENSION(:, :), & INTENT(in), OPTIONAL, TARGET :: ux REAL(kind=dp), DIMENSION(:, :), & INTENT(out), OPTIONAL, TARGET :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_u2x', & routineP = moduleN//':'//routineN @@ -99,19 +93,19 @@ SUBROUTINE pint_u2x(pint_env,ux,x,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) my_x => pint_env%x my_ux => pint_env%ux IF (PRESENT(x)) my_x => x IF (PRESENT(ux)) my_ux => ux - CPPrecondition(ASSOCIATED(my_ux),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(my_x),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(my_ux),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(my_x),cp_failure_level,routineP,failure) IF (pint_env%transform == transformation_stage) THEN - CALL staging_u2x(pint_env%staging_env,ux=my_ux,x=my_x,error=error) + CALL staging_u2x(pint_env%staging_env,ux=my_ux,x=my_x) ELSE - CALL normalmode_u2x(pint_env%normalmode_env,ux=my_ux,x=my_x,error=error) + CALL normalmode_u2x(pint_env%normalmode_env,ux=my_ux,x=my_x) END IF RETURN END SUBROUTINE pint_u2x @@ -122,21 +116,18 @@ END SUBROUTINE pint_u2x !> \param uf will contain the accelerations for the transformed variables !> afterwards !> \param f the forces to transform -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> Added normal mode transformation [hforbert] !> Divide forces by the number of beads, since the replication !> environment (should) give raw forces [hforbert] !> \author fawzi ! ***************************************************************************** - SUBROUTINE pint_f2uf(pint_env,uf,f,error) + SUBROUTINE pint_f2uf(pint_env,uf,f) TYPE(pint_env_type), POINTER :: pint_env REAL(kind=dp), DIMENSION(:, :), & INTENT(out), OPTIONAL, TARGET :: uf REAL(kind=dp), DIMENSION(:, :), & INTENT(in), OPTIONAL, TARGET :: f - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pint_f2uf', & routineP = moduleN//':'//routineN @@ -146,19 +137,19 @@ SUBROUTINE pint_f2uf(pint_env,uf,f,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pint_env),cp_failure_level,routineP,failure) + CPPrecondition(pint_env%ref_count>0,cp_failure_level,routineP,failure) my_f => pint_env%f my_uf => pint_env%uf IF (PRESENT(f)) my_f => f IF (PRESENT(uf)) my_uf => uf - CPPrecondition(ASSOCIATED(my_uf),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(my_f),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(my_uf),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(my_f),cp_failure_level,routineP,failure) IF (pint_env%transform == transformation_stage) THEN - CALL staging_f2uf(pint_env%staging_env,uf=my_uf,f=my_f,error=error) + CALL staging_f2uf(pint_env%staging_env,uf=my_uf,f=my_f) ELSE - CALL normalmode_f2uf(pint_env%normalmode_env,uf=my_uf,f=my_f,error=error) + CALL normalmode_f2uf(pint_env%normalmode_env,uf=my_uf,f=my_f) END IF my_uf=my_uf/pint_env%mass_fict/REAL(pint_env%p,dp) RETURN diff --git a/src/motion/reftraj_types.F b/src/motion/reftraj_types.F index e2288910ed..500f0c171d 100644 --- a/src/motion/reftraj_types.F +++ b/src/motion/reftraj_types.F @@ -79,14 +79,12 @@ MODULE reftraj_types !> \param reftraj ... !> \param reftraj_section ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_reftraj(reftraj,reftraj_section,para_env,error) + SUBROUTINE create_reftraj(reftraj,reftraj_section,para_env) TYPE(reftraj_type), POINTER :: reftraj TYPE(section_vals_type), POINTER :: reftraj_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_reftraj', & routineP = moduleN//':'//routineN @@ -97,54 +95,50 @@ SUBROUTINE create_reftraj(reftraj,reftraj_section,para_env,error) failure = .FALSE. - CPPrecondition(.NOT. ASSOCIATED(reftraj),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT. ASSOCIATED(reftraj),cp_failure_level,routineP,failure) ALLOCATE(reftraj, stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) reftraj%ref_count = 1 NULLIFY(reftraj%info) NULLIFY(reftraj%msd) ALLOCATE(reftraj%info, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(reftraj%info%traj_parser) NULLIFY(reftraj%info%cell_parser) ! Initialize parser for trajectory - CALL section_vals_val_get(reftraj_section,"TRAJ_FILE_NAME",c_val=filename,error=error) - CALL parser_create(reftraj%info%traj_parser,filename,para_env=para_env,error=error) + CALL section_vals_val_get(reftraj_section,"TRAJ_FILE_NAME",c_val=filename) + CALL parser_create(reftraj%info%traj_parser,filename,para_env=para_env) - CALL section_vals_val_get(reftraj_section,"VARIABLE_VOLUME",l_val=reftraj%info%variable_volume,& - error=error) + CALL section_vals_val_get(reftraj_section,"VARIABLE_VOLUME",l_val=reftraj%info%variable_volume) IF(reftraj%info%variable_volume) THEN ! In case requested initialize parser for cell - CALL section_vals_val_get(reftraj_section,"CELL_FILE_NAME",c_val=filename,error=error) - CALL parser_create(reftraj%info%cell_parser,filename,para_env=para_env,error=error) + CALL section_vals_val_get(reftraj_section,"CELL_FILE_NAME",c_val=filename) + CALL parser_create(reftraj%info%cell_parser,filename,para_env=para_env) END IF - CALL section_vals_val_get(reftraj_section,"FIRST_SNAPSHOT",i_val=reftraj%info%first_snapshot,error=error) - CALL section_vals_val_get(reftraj_section,"LAST_SNAPSHOT",i_val=reftraj%info%last_snapshot,error=error) - CALL section_vals_val_get(reftraj_section,"STRIDE",i_val=reftraj%info%stride,error=error) - CALL section_vals_val_get(reftraj_section,"EVAL_ENERGY_FORCES",l_val=reftraj%info%eval_ef,error=error) + CALL section_vals_val_get(reftraj_section,"FIRST_SNAPSHOT",i_val=reftraj%info%first_snapshot) + CALL section_vals_val_get(reftraj_section,"LAST_SNAPSHOT",i_val=reftraj%info%last_snapshot) + CALL section_vals_val_get(reftraj_section,"STRIDE",i_val=reftraj%info%stride) + CALL section_vals_val_get(reftraj_section,"EVAL_ENERGY_FORCES",l_val=reftraj%info%eval_ef) CALL section_vals_val_get(reftraj_section,"MSD%_SECTION_PARAMETERS_",& - l_val=reftraj%info%msd,error=error) + l_val=reftraj%info%msd) END SUBROUTINE create_reftraj ! ***************************************************************************** !> \brief ... !> \param reftraj ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE retain_reftraj(reftraj, error) + SUBROUTINE retain_reftraj(reftraj) TYPE(reftraj_type), POINTER :: reftraj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_reftraj', & routineP = moduleN//':'//routineN @@ -154,7 +148,7 @@ SUBROUTINE retain_reftraj(reftraj, error) failure=.FALSE. IF (ASSOCIATED(reftraj)) THEN - CPPrecondition(reftraj%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(reftraj%ref_count>0,cp_failure_level,routineP,failure) reftraj%ref_count=reftraj%ref_count+1 END IF @@ -163,16 +157,13 @@ END SUBROUTINE retain_reftraj ! ***************************************************************************** !> \brief ... !> \param reftraj ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE release_reftraj(reftraj, error) + SUBROUTINE release_reftraj(reftraj) TYPE(reftraj_type), POINTER :: reftraj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_reftraj', & routineP = moduleN//':'//routineN @@ -182,41 +173,41 @@ SUBROUTINE release_reftraj(reftraj, error) failure=.FALSE. IF(ASSOCIATED(reftraj)) THEN - CPPrecondition(reftraj%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(reftraj%ref_count>0,cp_failure_level,routineP,failure) reftraj%ref_count=reftraj%ref_count-1 IF(reftraj%ref_count<1) THEN - CALL parser_release(reftraj%info%traj_parser,error=error) - CALL parser_release(reftraj%info%cell_parser,error=error) + CALL parser_release(reftraj%info%traj_parser) + CALL parser_release(reftraj%info%cell_parser) IF(ASSOCIATED(reftraj%info)) THEN DEALLOCATE (reftraj%info, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(reftraj%msd)) THEN DEALLOCATE(reftraj%msd%ref0_pos,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(reftraj%msd%msd_kind) THEN DEALLOCATE(reftraj%msd%val_msd_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(reftraj%msd%msd_molecule) THEN DEALLOCATE(reftraj%msd%val_msd_molecule,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(reftraj%msd%ref0_com_molecule,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(reftraj%msd%disp_atom) THEN DEALLOCATE(reftraj%msd%disp_atom_index,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(reftraj%msd%disp_atom_dr,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (reftraj%msd, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE( reftraj , stat=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF diff --git a/src/motion/reftraj_util.F b/src/motion/reftraj_util.F index b642e999bf..dd685092f3 100644 --- a/src/motion/reftraj_util.F +++ b/src/motion/reftraj_util.F @@ -70,18 +70,15 @@ MODULE reftraj_util !> \param reftraj ... !> \param reftraj_section ... !> \param md_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE initialize_reftraj(reftraj,reftraj_section,md_env,error) + SUBROUTINE initialize_reftraj(reftraj,reftraj_section,md_env) TYPE(reftraj_type), POINTER :: reftraj TYPE(section_vals_type), POINTER :: reftraj_section TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_reftraj', & routineP = moduleN//':'//routineN @@ -99,20 +96,20 @@ SUBROUTINE initialize_reftraj(reftraj,reftraj_section,md_env,error) NULLIFY (force_env, msd_section, particles, simpar, subsys) CALL get_md_env(md_env=md_env, force_env=force_env, para_env=para_env,& - simpar=simpar, error=error) - CALL force_env_get(force_env=force_env, subsys=subsys,error=error) - CALL cp_subsys_get(subsys=subsys, particles=particles,error=error) + simpar=simpar) + CALL force_env_get(force_env=force_env, subsys=subsys) + CALL cp_subsys_get(subsys=subsys, particles=particles) natom = particles%n_els my_end = .FALSE. nline_to_skip = 0 nskip = reftraj%info%first_snapshot-1 - CPPostcondition(nskip>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(nskip>=0,cp_failure_level,routineP,failure) IF(nskip > 0 ) THEN nline_to_skip = (natom+2)*nskip - CALL parser_get_next_line(reftraj%info%traj_parser,nline_to_skip,at_end=my_end,error=error) + CALL parser_get_next_line(reftraj%info%traj_parser,nline_to_skip,at_end=my_end) END IF reftraj%isnap = nskip @@ -125,7 +122,7 @@ SUBROUTINE initialize_reftraj(reftraj,reftraj_section,md_env,error) ! Cell File IF(reftraj%info%variable_volume) THEN IF(nskip > 0 ) THEN - CALL parser_get_next_line(reftraj%info%cell_parser,nskip,at_end=my_end,error=error) + CALL parser_get_next_line(reftraj%info%cell_parser,nskip,at_end=my_end) END IF CALL cp_assert(.NOT.my_end,cp_fatal_level,cp_assertion_failed,routineP,& "Reached the end of the cell file for REFTRAJ. Number of steps skipped "//& @@ -141,9 +138,9 @@ SUBROUTINE initialize_reftraj(reftraj,reftraj_section,md_env,error) END IF IF(reftraj%info%msd) THEN - msd_section => section_vals_get_subs_vals(reftraj_section,"MSD",error=error) + msd_section => section_vals_get_subs_vals(reftraj_section,"MSD") ! set up and printout - CALL initialize_msd_reftraj(reftraj%msd,msd_section,reftraj,md_env,error=error) + CALL initialize_msd_reftraj(reftraj%msd,msd_section,reftraj,md_env) END IF END SUBROUTINE initialize_reftraj @@ -154,18 +151,15 @@ END SUBROUTINE initialize_reftraj !> \param msd_section ... !> \param reftraj ... !> \param md_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE initialize_msd_reftraj(msd,msd_section,reftraj,md_env,error) + SUBROUTINE initialize_msd_reftraj(msd,msd_section,reftraj,md_env) TYPE(reftraj_msd_type), POINTER :: msd TYPE(section_vals_type), POINTER :: msd_section TYPE(reftraj_type), POINTER :: reftraj TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_msd_reftraj', & routineP = moduleN//':'//routineN @@ -198,10 +192,10 @@ SUBROUTINE initialize_msd_reftraj(msd,msd_section,reftraj,md_env,error) NULLIFY (molecule, molecules, molecule_kind, molecule_kind_set,& molecule_kinds, molecule_set, subsys, force_env, particles, particle_set) - CPPrecondition(.NOT. ASSOCIATED(msd),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT. ASSOCIATED(msd),cp_failure_level,routineP,failure) ALLOCATE(msd, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(msd%ref0_pos) NULLIFY(msd%ref0_com_molecule) @@ -210,36 +204,35 @@ SUBROUTINE initialize_msd_reftraj(msd,msd_section,reftraj,md_env,error) NULLIFY(msd%disp_atom_index) NULLIFY(msd%disp_atom_dr) - CALL get_md_env(md_env=md_env, force_env=force_env, para_env=para_env,& - error=error) - CALL force_env_get(force_env=force_env,subsys=subsys,error=error) - CALL cp_subsys_get(subsys=subsys, particles=particles,error=error) + CALL get_md_env(md_env=md_env, force_env=force_env, para_env=para_env) + CALL force_env_get(force_env=force_env,subsys=subsys) + CALL cp_subsys_get(subsys=subsys, particles=particles) particle_set => particles%els npart = SIZE(particle_set,1) msd%ref0_unit = -1 - CALL section_vals_val_get(msd_section,"REF0_FILENAME",c_val=filename,error=error) + CALL section_vals_val_get(msd_section,"REF0_FILENAME",c_val=filename) CALL open_file(TRIM(filename),unit_number=msd%ref0_unit) ALLOCATE(msd%ref0_pos(3,reftraj%natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) msd%ref0_pos = 0.0_dp IF (para_env%mepos==para_env%source) THEN REWIND(msd%ref0_unit) READ(msd%ref0_unit,*,ERR=999,END=998) natom_read - CPPostcondition(natom_read==reftraj%natom,cp_failure_level,routineP,error,failure) + CPPostcondition(natom_read==reftraj%natom,cp_failure_level,routineP,failure) READ(msd%ref0_unit,'(A)',ERR=999,END=998) title msd%total_mass = 0.0_dp msd%ref0_com = 0.0_dp DO iatom = 1,natom_read READ(msd%ref0_unit,*,ERR=999,END=998) AA, x, y, z name=TRIM(particle_set(iatom)%atomic_kind%element_symbol) - CPPostcondition((TRIM(AA)==name),cp_failure_level,routineP,error,failure) + CPPostcondition((TRIM(AA)==name),cp_failure_level,routineP,failure) - x = cp_unit_to_cp2k(x,"angstrom",error=error) - y = cp_unit_to_cp2k(y,"angstrom",error=error) - z = cp_unit_to_cp2k(z,"angstrom",error=error) + x = cp_unit_to_cp2k(x,"angstrom") + y = cp_unit_to_cp2k(y,"angstrom") + z = cp_unit_to_cp2k(z,"angstrom") msd%ref0_pos(1,iatom) = x msd%ref0_pos(2,iatom) = y msd%ref0_pos(3,iatom) = z @@ -257,45 +250,45 @@ SUBROUTINE initialize_msd_reftraj(msd,msd_section,reftraj,md_env,error) CALL mp_bcast(msd%ref0_pos,para_env%source,para_env%group) CALL mp_bcast(msd%ref0_com,para_env%source,para_env%group) - CALL section_vals_val_get(msd_section,"MSD_PER_KIND",l_val=msd%msd_kind,error=error) - CALL section_vals_val_get(msd_section,"MSD_PER_MOLKIND",l_val=msd%msd_molecule,error=error) - CALL section_vals_val_get(msd_section,"MSD_PER_REGION",l_val=msd%msd_region,error=error) + CALL section_vals_val_get(msd_section,"MSD_PER_KIND",l_val=msd%msd_kind) + CALL section_vals_val_get(msd_section,"MSD_PER_MOLKIND",l_val=msd%msd_molecule) + CALL section_vals_val_get(msd_section,"MSD_PER_REGION",l_val=msd%msd_region) - CALL section_vals_val_get(msd_section,"DISPLACED_ATOM",l_val=msd%disp_atom,error=error) + CALL section_vals_val_get(msd_section,"DISPLACED_ATOM",l_val=msd%disp_atom) IF(msd%disp_atom) THEN ALLOCATE(msd%disp_atom_index(npart),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) msd%disp_atom_index = 0 ALLOCATE(msd%disp_atom_dr(3,npart),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) msd%disp_atom_dr = 0.0_dp msd%msd_kind = .TRUE. END IF - CALL section_vals_val_get(msd_section,"DISPLACEMENT_TOL",r_val=tol,error=error) + CALL section_vals_val_get(msd_section,"DISPLACEMENT_TOL",r_val=tol) msd%disp_atom_tol = tol*tol IF(msd%msd_kind) THEN - CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds, error=error) + CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds) nkind = atomic_kinds%n_els ALLOCATE(msd%val_msd_kind(4,nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) msd%val_msd_kind = 0.0_dp END IF IF(msd%msd_molecule) THEN CALL cp_subsys_get(subsys=subsys, molecules_new=molecules,& - molecule_kinds_new=molecule_kinds,error=error) + molecule_kinds_new=molecule_kinds) nmolkind = molecule_kinds%n_els ALLOCATE(msd%val_msd_molecule(4,nmolkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) molecule_kind_set => molecule_kinds%els molecule_set => molecules%els nmol = molecules%n_els ALLOCATE(msd%ref0_com_molecule(3,nmol), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind = 1, nmolkind molecule_kind => molecule_kind_set(ikind) @@ -338,19 +331,16 @@ END SUBROUTINE initialize_msd_reftraj !> \param reftraj ... !> \param md_env ... !> \param particle_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE compute_msd_reftraj(reftraj,md_env,particle_set,error) + SUBROUTINE compute_msd_reftraj(reftraj,md_env,particle_set) TYPE(reftraj_type), POINTER :: reftraj TYPE(md_environment_type), POINTER :: md_env TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_msd_reftraj', & routineP = moduleN//':'//routineN @@ -383,11 +373,9 @@ SUBROUTINE compute_msd_reftraj(reftraj,md_env,particle_set,error) NULLIFY(local_molecules, molecule, molecule_kind, molecule_kinds,& molecule_kind_set, molecules, molecule_set) - CALL get_md_env(md_env=md_env, force_env=force_env, para_env=para_env,& - error=error) - CALL force_env_get(force_env=force_env,subsys=subsys,& - error=error) - CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds,error=error) + CALL get_md_env(md_env=md_env, force_env=force_env, para_env=para_env) + CALL force_env_get(force_env=force_env,subsys=subsys) + CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds) num_pe = para_env%num_pe mepos = para_env%mepos @@ -462,7 +450,7 @@ SUBROUTINE compute_msd_reftraj(reftraj,md_env,particle_set,error) IF(reftraj%msd%msd_molecule) THEN CALL cp_subsys_get(subsys=subsys, local_molecules_new=local_molecules, & - molecules_new=molecules, molecule_kinds_new=molecule_kinds, error=error) + molecules_new=molecules, molecule_kinds_new=molecule_kinds) nmolkind = molecule_kinds%n_els molecule_kind_set => molecule_kinds%els @@ -518,15 +506,12 @@ END SUBROUTINE compute_msd_reftraj ! ***************************************************************************** !> \brief ... !> \param md_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created !> \author MI ! ***************************************************************************** - SUBROUTINE write_output_reftraj(md_env,error) + SUBROUTINE write_output_reftraj(md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_output_reftraj', & routineP = moduleN//':'//routineN @@ -540,19 +525,18 @@ SUBROUTINE write_output_reftraj(md_env,error) TYPE(section_vals_type), POINTER :: reftraj_section, root_section NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(reftraj) NULLIFY(reftraj_section,root_section) CALL get_md_env(md_env=md_env, force_env=force_env, & - reftraj=reftraj, error=error) + reftraj=reftraj) - CALL force_env_get(force_env=force_env,root_section=root_section,& - error=error) + CALL force_env_get(force_env=force_env,root_section=root_section) reftraj_section => section_vals_get_subs_vals(root_section,& - "MOTION%MD%REFTRAJ",error=error) + "MOTION%MD%REFTRAJ") my_pos = "APPEND" my_act = "WRITE" @@ -569,8 +553,7 @@ SUBROUTINE write_output_reftraj(md_env,error) my_mittle ="k"//TRIM(ADJUSTL(cp_to_string(ikind))) out_msd = cp_print_key_unit_nr(logger,reftraj_section,"PRINT%MSD_KIND",& extension=".msd", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(my_mittle), & - error=error) + file_form="FORMATTED", middle_name=TRIM(my_mittle)) IF(out_msd>0) THEN WRITE(UNIT=out_msd,FMT="(I8, F12.3,4F20.10)") reftraj%itimes, & reftraj%time*femtoseconds, & @@ -578,7 +561,7 @@ SUBROUTINE write_output_reftraj(md_env,error) CALL m_flush(out_msd) END IF CALL cp_print_key_finished_output(out_msd,logger,reftraj_section,& - "PRINT%MSD_KIND", error=error) + "PRINT%MSD_KIND") END DO END IF IF(reftraj%msd%msd_molecule) THEN @@ -587,8 +570,7 @@ SUBROUTINE write_output_reftraj(md_env,error) my_mittle ="mk"//TRIM(ADJUSTL(cp_to_string(ikind))) out_msd = cp_print_key_unit_nr(logger,reftraj_section,"PRINT%MSD_MOLECULE",& extension=".msd", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(my_mittle), & - error=error) + file_form="FORMATTED", middle_name=TRIM(my_mittle)) IF(out_msd>0) THEN WRITE(UNIT=out_msd,FMT="(I8, F12.3,4F20.10)") reftraj%itimes, & reftraj%time*femtoseconds, & @@ -596,7 +578,7 @@ SUBROUTINE write_output_reftraj(md_env,error) CALL m_flush(out_msd) END IF CALL cp_print_key_finished_output(out_msd,logger,reftraj_section,& - "PRINT%MSD_MOLECULE", error=error) + "PRINT%MSD_MOLECULE") END DO END IF IF(reftraj%msd%disp_atom) THEN @@ -605,8 +587,7 @@ SUBROUTINE write_output_reftraj(md_env,error) my_mittle ="disp_at" out_msd = cp_print_key_unit_nr(logger,reftraj_section,"PRINT%DISPLACED_ATOM",& extension=".msd", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(my_mittle), & - error=error) + file_form="FORMATTED", middle_name=TRIM(my_mittle)) IF(out_msd>0 .AND. reftraj%msd%num_disp_atom>0) THEN IF(first_entry) THEN first_entry = .FALSE. @@ -623,7 +604,7 @@ SUBROUTINE write_output_reftraj(md_env,error) END DO ENDIF CALL cp_print_key_finished_output(out_msd,logger,reftraj_section,& - "PRINT%DISPLACED_ATOM", error=error) + "PRINT%DISPLACED_ATOM") END IF ENDIF ! msd reftraj%init = .FALSE. diff --git a/src/motion/rt_propagation.F b/src/motion/rt_propagation.F index 787a572028..73fe085511 100644 --- a/src/motion/rt_propagation.F +++ b/src/motion/rt_propagation.F @@ -88,13 +88,11 @@ MODULE rt_propagation !> \brief creates rtp_type, gets the initial state, either by reading MO's !> from file or calling SCF run !> \param force_env ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE rt_prop_setup(force_env,error) + SUBROUTINE rt_prop_setup(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_prop_setup', & routineP = moduleN//':'//routineN @@ -114,58 +112,57 @@ SUBROUTINE rt_prop_setup(force_env,error) failure=.FALSE. NULLIFY(qs_env,rtp_control,dft_control) - CALL force_env_get(force_env=force_env,qs_env=qs_env,globenv=globenv,error=error) - CALL get_qs_env(qs_env, dft_control=dft_control,energy=energy, error=error) + CALL force_env_get(force_env=force_env,qs_env=qs_env,globenv=globenv) + CALL get_qs_env(qs_env, dft_control=dft_control,energy=energy) rtp_control=>dft_control%rtp_control ! Takes care that an initial wavefunction/density is available ! Can either be by performing an scf loop or reading a restart - CALL rt_initial_guess(qs_env,force_env,rtp_control,error) + CALL rt_initial_guess(qs_env,force_env,rtp_control) ! Initializes the extrapolation - CALL get_qs_env(qs_env=qs_env,rtp=rtp,input=input,error=error) + CALL get_qs_env(qs_env=qs_env,rtp=rtp,input=input) aspc_order=rtp_control%aspc_order - CALL rtp_history_create(rtp,aspc_order,error=error) + CALL rtp_history_create(rtp,aspc_order) ! Reads the simulation parameters from the input - motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION",error=error) - md_section => section_vals_get_subs_vals(motion_section,"MD",error=error) - hfx_sections => section_vals_get_subs_vals(force_env%root_section,"FORCE_EVAL%DFT%XC%HF",error=error) - CALL section_vals_val_get(md_section,"TIMESTEP",r_val=qs_env%rtp%dt,error=error) - CALL section_vals_val_get(md_section,"STEP_START_VAL",i_val=qs_env%rtp%i_start,error=error) - CALL section_vals_val_get(md_section,"STEPS",i_val=rtp%nsteps,error=error) - - ls_scf_section => section_vals_get_subs_vals(input,"DFT%LS_SCF",error=error) - CALL section_vals_val_get(ls_scf_section,"EPS_FILTER",r_val=rtp%filter_eps,error=error) + motion_section => section_vals_get_subs_vals(force_env%root_section,"MOTION") + md_section => section_vals_get_subs_vals(motion_section,"MD") + hfx_sections => section_vals_get_subs_vals(force_env%root_section,"FORCE_EVAL%DFT%XC%HF") + CALL section_vals_val_get(md_section,"TIMESTEP",r_val=qs_env%rtp%dt) + CALL section_vals_val_get(md_section,"STEP_START_VAL",i_val=qs_env%rtp%i_start) + CALL section_vals_val_get(md_section,"STEPS",i_val=rtp%nsteps) + + ls_scf_section => section_vals_get_subs_vals(input,"DFT%LS_SCF") + CALL section_vals_val_get(ls_scf_section,"EPS_FILTER",r_val=rtp%filter_eps) IF(.NOT.qs_env%rtp%linear_scaling) rtp%filter_eps = 0.0_dp IF(rtp_control%acc_ref<1) rtp_control%acc_ref=1 rtp%filter_eps_small=rtp%filter_eps/rtp_control%acc_ref - CALL section_vals_val_get(ls_scf_section,"EPS_LANCZOS",r_val=rtp%lanzcos_threshold,error=error) - CALL section_vals_val_get(ls_scf_section,"MAX_ITER_LANCZOS",i_val=rtp%lanzcos_max_iter,error=error) - CALL section_vals_val_get(ls_scf_section,"SIGN_SQRT_ORDER",i_val=rtp%newton_schulz_order,error=error) - CALL section_vals_get(hfx_sections,explicit=rtp%do_hfx,error=error) + CALL section_vals_val_get(ls_scf_section,"EPS_LANCZOS",r_val=rtp%lanzcos_threshold) + CALL section_vals_val_get(ls_scf_section,"MAX_ITER_LANCZOS",i_val=rtp%lanzcos_max_iter) + CALL section_vals_val_get(ls_scf_section,"SIGN_SQRT_ORDER",i_val=rtp%newton_schulz_order) + CALL section_vals_get(hfx_sections,explicit=rtp%do_hfx) ! Hmm, not really like to initialize with the structure of S but I reckon it is ! done everywhere like this IF(rtp%do_hfx)& - CALL rtp_hfx_rebuild(qs_env,error) + CALL rtp_hfx_rebuild(qs_env) - CALL init_propagation_run(qs_env,error) + CALL init_propagation_run(qs_env) IF(.NOT.rtp_control%fixed_ions) THEN !derivativs of the overlap needed for EMD - CALL calc_S_derivs(qs_env,error) + CALL calc_S_derivs(qs_env) ! a bit hidden, but computes SinvH and SinvB (calc_SinvH for CN,EM and ARNOLDI) ! make_etrs_exp in case of ETRS in combination with TAYLOR and PADE END IF - CALL init_propagators(qs_env,error) + CALL init_propagators(qs_env) IF(rtp_control%fixed_ions) THEN - CALL run_propagation(qs_env,force_env,globenv,error) + CALL run_propagation(qs_env,force_env,globenv) ELSE rtp_control%initial_step=.TRUE. - CALL force_env_calc_energy_force(force_env,calc_force=.TRUE.,& - error=error) + CALL force_env_calc_energy_force(force_env,calc_force=.TRUE.) rtp_control%initial_step=.FALSE. rtp%energy_old=energy%total END IF @@ -176,13 +173,11 @@ END SUBROUTINE rt_prop_setup ! ***************************************************************************** !> \brief calculates the matrices needed in the first step of EMD/RTP !> \param qs_env ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE init_propagation_run(qs_env,error) + SUBROUTINE init_propagation_run(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), PARAMETER :: zero = 0.0_dp @@ -203,54 +198,52 @@ SUBROUTINE init_propagation_run(qs_env,error) CALL get_qs_env(qs_env,& rtp=rtp,& matrix_s=matrix_s,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) rtp_control=>dft_control%rtp_control IF(.NOT.rtp%linear_scaling) THEN - CALL get_qs_env(qs_env,mos=mos,error=error) - CALL get_rtp(rtp=rtp,mos_old=mos_old,mos_new=mos_new,error=error) + CALL get_qs_env(qs_env,mos=mos) + CALL get_rtp(rtp=rtp,mos_old=mos_old,mos_new=mos_new) IF(rtp_control%initial_wfn==use_scf_wfn)THEN IF (rtp_control%apply_delta_pulse) THEN IF(dft_control%qs_control%dftb)& - CALL build_dftb_overlap(qs_env,1,matrix_s,error) + CALL build_dftb_overlap(qs_env,1,matrix_s) IF (rtp_control%periodic) THEN - CALL apply_delta_pulse_periodic(qs_env,mos_old,mos_new,error) + CALL apply_delta_pulse_periodic(qs_env,mos_old,mos_new) ELSE - CALL apply_delta_pulse(qs_env,mos_old,mos_new,error) + CALL apply_delta_pulse(qs_env,mos_old,mos_new) ENDIF ELSE DO i=1,SIZE(mos) - CALL cp_fm_to_fm(mos(i)%mo_set%mo_coeff,mos_old(2*i-1)%matrix,error) - CALL cp_fm_set_all(mos_old(2*i)%matrix,zero,zero,error) + CALL cp_fm_to_fm(mos(i)%mo_set%mo_coeff,mos_old(2*i-1)%matrix) + CALL cp_fm_set_all(mos_old(2*i)%matrix,zero,zero) END DO ENDIF END IF DO i=1,SIZE(mos_old) - CALL cp_fm_to_fm(mos_old(i)%matrix,mos_new(i)%matrix,error) + CALL cp_fm_to_fm(mos_old(i)%matrix,mos_new(i)%matrix) END DO - CALL calc_update_rho(qs_env,error) + CALL calc_update_rho(qs_env) ELSE IF(qs_env%rtp%linear_scaling.AND.rtp_control%initial_wfn==use_scf_wfn) THEN CALL get_qs_env(qs_env,& matrix_ks=matrix_ks,& mos=mos,& - nelectron_spin=nelectron_spin,& - error=error) + nelectron_spin=nelectron_spin) IF(ASSOCIATED(mos)) THEN !The wavefunction was minimized by an mo based algorith. P is therefore calculated from the mos - CALL rt_initialize_rho_from_mos(rtp,mos,matrix_s,rtp_control%orthonormal,error=error) + CALL rt_initialize_rho_from_mos(rtp,mos,matrix_s,rtp_control%orthonormal) ELSE !The wavefunction was minimized using a linear scaling method. Because the rho in the qs_env has the sparsity of S !the matrix P needs to be recalculated from H - CALL rt_initialize_rho_from_ks(rtp,matrix_ks,matrix_s,nelectron_spin,rtp_control%orthonormal,error=error) + CALL rt_initialize_rho_from_ks(rtp,matrix_ks,matrix_s,nelectron_spin,rtp_control%orthonormal) ENDIF ENDIF - CALL calc_update_rho_sparse(qs_env,error) + CALL calc_update_rho_sparse(qs_env) END IF - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., error=error) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) END SUBROUTINE init_propagation_run @@ -260,15 +253,13 @@ END SUBROUTINE init_propagation_run !> \param qs_env ... !> \param force_env ... !> \param globenv ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE run_propagation(qs_env,force_env,globenv,error) + SUBROUTINE run_propagation(qs_env,force_env,globenv) TYPE(qs_environment_type), POINTER :: qs_env TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'run_propagation', & routineP = moduleN//':'//routineN @@ -288,9 +279,9 @@ SUBROUTINE run_propagation(qs_env,force_env,globenv,error) should_stop=.FALSE. CALL timeset(routineN,handle) NULLIFY(logger,dft_control,energy,rtp,rtp_control) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,rtp=rtp,energy=energy,error=error) + CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,rtp=rtp,energy=energy) rtp_control=>dft_control%rtp_control max_steps=rtp%nsteps @@ -301,47 +292,47 @@ SUBROUTINE run_propagation(qs_env,force_env,globenv,error) rtp%energy_old=energy%total time_iter_start=m_walltime() - CALL cp_add_iter_level(logger%iter_info,"MD",error=error) - CALL cp_iterate(logger%iter_info,iter_nr=0,error=error) + CALL cp_add_iter_level(logger%iter_info,"MD") + CALL cp_iterate(logger%iter_info,iter_nr=0) DO i_step=rtp%i_start+1,max_steps energy%efield_core=0.0_dp qs_env%sim_time=REAL(i_step,dp)*rtp%dt qs_env%sim_step=i_step rtp%istep=i_step-rtp%i_start - CALL calculate_ecore_efield(qs_env,.FALSE.,error=error) - CALL external_c_potential(qs_env,calculate_forces=.FALSE.,error=error) - CALL external_e_potential(qs_env,error=error) - CALL cp_iterate(logger%iter_info,last=(i_step==max_steps),iter_nr=i_step,error=error) + CALL calculate_ecore_efield(qs_env,.FALSE.) + CALL external_c_potential(qs_env,calculate_forces=.FALSE.) + CALL external_e_potential(qs_env) + CALL cp_iterate(logger%iter_info,last=(i_step==max_steps),iter_nr=i_step) rtp%converged=.FALSE. DO i_iter=1,max_iter IF(i_step==rtp%i_start+1.AND.i_iter==2.AND.rtp_control%hfx_redistribute)& - CALL qs_ks_did_change(qs_env%ks_env,s_mstruct_changed=.TRUE., error=error) + CALL qs_ks_did_change(qs_env%ks_env,s_mstruct_changed=.TRUE.) rtp%iter=i_iter - CALL propagation_step(qs_env,rtp, rtp_control, error=error) - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., error=error) + CALL propagation_step(qs_env,rtp, rtp_control) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) rtp%energy_new=energy%total IF(rtp%converged)EXIT - CALL rt_prop_output(qs_env,real_time_propagation,rtp%delta_iter,error=error) + CALL rt_prop_output(qs_env,real_time_propagation,rtp%delta_iter) END DO IF(rtp%converged)THEN - CALL external_control(should_stop,"MD",globenv=globenv,error=error) - IF (should_stop)CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=i_step,error=error) + CALL external_control(should_stop,"MD",globenv=globenv) + IF (should_stop)CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=i_step) time_iter_stop=m_walltime() used_time= time_iter_stop - time_iter_start time_iter_start=time_iter_stop - CALL rt_prop_output(qs_env,real_time_propagation,delta_iter=rtp%delta_iter,used_time=used_time,error=error) - CALL rt_write_input_restart(force_env=force_env,error=error) + CALL rt_prop_output(qs_env,real_time_propagation,delta_iter=rtp%delta_iter,used_time=used_time) + CALL rt_write_input_restart(force_env=force_env) IF (should_stop) EXIT ELSE EXIT END IF END DO - CALL cp_rm_iter_level(logger%iter_info,"MD",error=error) + CALL cp_rm_iter_level(logger%iter_info,"MD") IF(.NOT.rtp%converged)& CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"propagation did not converge, either increase MAX_ITER or use a smaller TIMESTEP",& - error,failure) + failure) CALL timestop(handle) @@ -352,15 +343,13 @@ END SUBROUTINE run_propagation !> file will contain the appropriate information !> \param md_env ... !> \param force_env ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE rt_write_input_restart(md_env,force_env,error) + SUBROUTINE rt_write_input_restart(md_env,force_env) TYPE(md_environment_type), OPTIONAL, & POINTER :: md_env TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_write_input_restart', & routineP = moduleN//':'//routineN @@ -369,15 +358,15 @@ SUBROUTINE rt_write_input_restart(md_env,force_env,error) rt_section root_section => force_env%root_section - motion_section => section_vals_get_subs_vals(root_section,"MOTION",error=error) - rt_section => section_vals_get_subs_vals(root_section,"FORCE_EVAL%DFT%REAL_TIME_PROPAGATION",error=error) - CALL section_vals_val_set(rt_section,"INITIAL_WFN",i_val=use_rt_restart,error=error) + motion_section => section_vals_get_subs_vals(root_section,"MOTION") + rt_section => section_vals_get_subs_vals(root_section,"FORCE_EVAL%DFT%REAL_TIME_PROPAGATION") + CALL section_vals_val_set(rt_section,"INITIAL_WFN",i_val=use_rt_restart) ! coming from RTP IF (.NOT. PRESENT(md_env)) THEN - CALL section_vals_val_set(motion_section,"MD%STEP_START_VAL",i_val=force_env%qs_env%sim_step,error=error) + CALL section_vals_val_set(motion_section,"MD%STEP_START_VAL",i_val=force_env%qs_env%sim_step) ENDIF - CALL write_restart(md_env=md_env,root_section=root_section,error=error) + CALL write_restart(md_env=md_env,root_section=root_section) END SUBROUTINE rt_write_input_restart @@ -387,15 +376,13 @@ END SUBROUTINE rt_write_input_restart !> \param qs_env ... !> \param force_env ... !> \param rtp_control ... -!> \param error ... !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE rt_initial_guess(qs_env,force_env,rtp_control,error) + SUBROUTINE rt_initial_guess(qs_env,force_env,rtp_control) TYPE(qs_environment_type), POINTER :: qs_env TYPE(force_env_type), POINTER :: force_env TYPE(rtp_control_type), POINTER :: rtp_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_initial_guess', & routineP = moduleN//':'//routineN @@ -410,7 +397,7 @@ SUBROUTINE rt_initial_guess(qs_env,force_env,rtp_control,error) TYPE(dft_control_type), POINTER :: dft_control NULLIFY(matrix_s,dft_control) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) SELECT CASE(rtp_control%initial_wfn) CASE(use_scf_wfn) @@ -420,15 +407,15 @@ SUBROUTINE rt_initial_guess(qs_env,force_env,rtp_control,error) !in the linear scaling case we need a correct kohn-sham matrix, which we cannot get with consistent energies IF(rtp_control%linear_scaling) energy_consistency=.FALSE. CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.,& - consistent_energies=energy_consistency,error=error) + consistent_energies=energy_consistency) qs_env%run_rtp=.TRUE. ALLOCATE(qs_env%rtp) - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) CALL rt_prop_create(qs_env%rtp,qs_env%mos,qs_env%mpools,dft_control,matrix_s(1)%matrix,& - rtp_control%linear_scaling,qs_env%mos_aux_fit,error) + rtp_control%linear_scaling,qs_env%mos_aux_fit) CASE(use_restart_wfn,use_rt_restart) - CALL qs_energies_init(qs_env, .FALSE. , error) + CALL qs_energies_init(qs_env, .FALSE.) IF(.NOT.rtp_control%linear_scaling.OR.rtp_control%initial_wfn==use_restart_wfn) THEN DO ispin=1,SIZE(qs_env%mos) CALL get_mo_set(qs_env%mos(ispin)%mo_set,mo_coeff=mo_coeff,homo=homo) @@ -436,31 +423,28 @@ SUBROUTINE rt_initial_guess(qs_env,force_env,rtp_control,error) CALL init_mo_set(qs_env%mos(ispin)%mo_set,& qs_env%mpools%ao_mo_fm_pools(ispin)%pool,& name="qs_env"//TRIM(ADJUSTL(cp_to_string(qs_env%id_nr)))//& - "%mo"//TRIM(ADJUSTL(cp_to_string(ispin))),& - error=error) + "%mo"//TRIM(ADJUSTL(cp_to_string(ispin)))) END IF END DO IF(dft_control%do_admm) THEN - CALL mpools_get(qs_env%mpools_aux_fit, ao_mo_fm_pools=ao_mo_fm_pools_aux_fit,& - error=error) - CPPrecondition(ASSOCIATED(qs_env%mos_aux_fit),cp_failure_level,routineP,error,failure) + CALL mpools_get(qs_env%mpools_aux_fit, ao_mo_fm_pools=ao_mo_fm_pools_aux_fit) + CPPrecondition(ASSOCIATED(qs_env%mos_aux_fit),cp_failure_level,routineP,failure) DO ispin=1,SIZE(qs_env%mos_aux_fit) CALL get_mo_set(qs_env%mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit,homo=homo) IF (.NOT.ASSOCIATED(mo_coeff_aux_fit)) THEN CALL init_mo_set(qs_env%mos_aux_fit(ispin)%mo_set,& ao_mo_fm_pools_aux_fit(ispin)%pool,& name="qs_env"//TRIM(ADJUSTL(cp_to_string(qs_env%id_nr)))//& - "%mo_aux_fit"//TRIM(ADJUSTL(cp_to_string(ispin))),& - error=error) + "%mo_aux_fit"//TRIM(ADJUSTL(cp_to_string(ispin)))) END IF END DO END IF ENDIF ALLOCATE(qs_env%rtp) - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) CALL rt_prop_create(qs_env%rtp,qs_env%mos,qs_env%mpools,dft_control,matrix_s(1)%matrix,& - rtp_control%linear_scaling,qs_env%mos_aux_fit,error) - CALL get_restart_wfn(qs_env,error) + rtp_control%linear_scaling,qs_env%mos_aux_fit) + CALL get_restart_wfn(qs_env) qs_env%run_rtp=.TRUE. END SELECT diff --git a/src/motion/shell_opt.F b/src/motion/shell_opt.F index d105771c75..930e3dcffd 100644 --- a/src/motion/shell_opt.F +++ b/src/motion/shell_opt.F @@ -57,11 +57,10 @@ MODULE shell_opt !> \param globenv ... !> \param tmp ... !> \param check ... -!> \param error ... !> \author ! ***************************************************************************** - SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_particle_set,globenv,tmp,check,error) + SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_particle_set,globenv,tmp,check) TYPE(force_env_type), POINTER :: force_env TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set, & @@ -71,7 +70,6 @@ SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_pa TYPE(tmp_variables_type), OPTIONAL, & POINTER :: tmp LOGICAL, INTENT(IN), OPTIONAL :: check - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'optimize_shell_core', & routineP = moduleN//':'//routineN @@ -92,17 +90,17 @@ SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_pa failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(globenv),cp_failure_level,routineP,failure) NULLIFY (gopt_param,force_env_section,gopt_env,dvec_sc,dvec_sc_0,root_section,geo_section) root_section => force_env%root_section force_env_section => force_env%force_env_section - geo_section => section_vals_get_subs_vals(root_section,"MOTION%SHELL_OPT",error=error) + geo_section => section_vals_get_subs_vals(root_section,"MOTION%SHELL_OPT") - CALL section_vals_get(geo_section, explicit=explicit, error=error) + CALL section_vals_get(geo_section, explicit=explicit) IF(.NOT. explicit) RETURN CALL timeset(routineN,handle) @@ -112,10 +110,10 @@ SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_pa IF(PRESENT(check)) my_check = check IF(my_check) THEN NULLIFY(subsys, para_env, atomic_kinds, local_particles) - CALL force_env_get(force_env=force_env, subsys=subsys, para_env=para_env, error=error) - CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds, local_particles=local_particles, error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, para_env=para_env) + CALL cp_subsys_get(subsys=subsys, atomic_kinds=atomic_kinds, local_particles=local_particles) CALL check_shell_core_distance(atomic_kinds,local_particles,particle_set,shell_particle_set,& - core_particle_set,para_env,optimize,error=error) + core_particle_set,para_env,optimize) IF(.NOT. optimize) THEN CALL timestop(handle) @@ -125,9 +123,9 @@ SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_pa nshell = SIZE(shell_particle_set) ALLOCATE(dvec_sc(3*nshell), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dvec_sc_0(3*nshell), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i= 1,nshell dvec_sc(1+3*(i-1)) = core_particle_set(i)%r(1)-shell_particle_set(i)%r(1) dvec_sc(2+3*(i-1)) = core_particle_set(i)%r(2)-shell_particle_set(i)%r(2) @@ -136,14 +134,14 @@ SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_pa dvec_sc_0 = dvec_sc - CALL gopt_param_read(gopt_param, geo_section, type_id=default_shellcore_method_id, error=error) + CALL gopt_param_read(gopt_param, geo_section, type_id=default_shellcore_method_id) CALL gopt_f_create(gopt_env, gopt_param, force_env=force_env, globenv=globenv,& - geo_opt_section=geo_section, error=error) + geo_opt_section=geo_section) - CALL cp_add_iter_level(logger%iter_info,"SHELL_OPT",error=error) + CALL cp_add_iter_level(logger%iter_info,"SHELL_OPT") gopt_env%eval_opt_geo = .FALSE. CALL geoopt_cg (force_env,gopt_param,globenv,& - geo_section, gopt_env, dvec_sc, do_update=do_update, error=error) + geo_section, gopt_env, dvec_sc, do_update=do_update) IF(.NOT.do_update) THEN DO i= 1,nshell shell_particle_set(i)%r(1) = -dvec_sc_0(1+3*(i-1)) + core_particle_set(i)%r(1) @@ -151,14 +149,14 @@ SUBROUTINE optimize_shell_core(force_env,particle_set,shell_particle_set,core_pa shell_particle_set(i)%r(3) = -dvec_sc_0(3+3*(i-1)) + core_particle_set(i)%r(3) END DO END IF - CALL cp_rm_iter_level(logger%iter_info,"SHELL_OPT",error=error) + CALL cp_rm_iter_level(logger%iter_info,"SHELL_OPT") - CALL gopt_f_release(gopt_env, error=error) - CALL gopt_param_release(gopt_param, error=error) + CALL gopt_f_release(gopt_env) + CALL gopt_param_release(gopt_param) DEALLOCATE(dvec_sc, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dvec_sc_0, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(PRESENT(tmp)) THEN DO i=1,nshell @@ -188,14 +186,13 @@ END SUBROUTINE optimize_shell_core !> \param core_particle_set ... !> \param para_env ... !> \param optimize ... -!> \param error ... !> \par History !> none !> \author MI (October 2008) !> I soliti ignoti ! ***************************************************************************** SUBROUTINE check_shell_core_distance(atomic_kinds,local_particles,particle_set,& - shell_particle_set,core_particle_set,para_env,optimize,error) + shell_particle_set,core_particle_set,para_env,optimize) TYPE(atomic_kind_list_type), POINTER :: atomic_kinds TYPE(distribution_1d_type), POINTER :: local_particles @@ -205,7 +202,6 @@ SUBROUTINE check_shell_core_distance(atomic_kinds,local_particles,particle_set,& core_particle_set TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(INOUT) :: optimize - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_shell_core_distance', & routineP = moduleN//':'//routineN diff --git a/src/motion/simpar_methods.F b/src/motion/simpar_methods.F index c4c17edb35..b57c137c34 100644 --- a/src/motion/simpar_methods.F +++ b/src/motion/simpar_methods.F @@ -53,14 +53,11 @@ MODULE simpar_methods !> \param simpar ... !> \param motion_section ... !> \param md_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE read_md_section(simpar, motion_section, md_section, error) + SUBROUTINE read_md_section(simpar, motion_section, md_section) TYPE(simpar_type), POINTER :: simpar TYPE(section_vals_type), POINTER :: motion_section, md_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_md_section', & routineP = moduleN//':'//routineN @@ -75,10 +72,10 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) TYPE(section_vals_type), POINTER :: print_key NULLIFY(logger, print_key,enum, keyword, section) - logger => cp_error_get_logger(error) - iw=cp_print_key_unit_nr(logger,md_section,"PRINT%PROGRAM_RUN_INFO",extension=".log",error=error) + logger => cp_get_default_logger() + iw=cp_print_key_unit_nr(logger,md_section,"PRINT%PROGRAM_RUN_INFO",extension=".log") - CALL read_md_low(simpar, motion_section, md_section, error) + CALL read_md_low(simpar, motion_section, md_section) IF (iw> 0) WRITE (iw, *) ! Begin setup Langevin dynamics @@ -88,9 +85,9 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) ! Normalization factor using a normal Gaussian random number distribution simpar%var_w = 2.0_dp*simpar%temp_ext*simpar%dt*(simpar%gamma + simpar%noisy_gamma) IF ( iw > 0 ) THEN - tmp_r1 = cp_unit_from_cp2k(simpar%gamma,"fs^-1",error=error) - tmp_r2 = cp_unit_from_cp2k(simpar%noisy_gamma, "fs^-1", error=error) - tmp_r3 = cp_unit_from_cp2k(simpar%shadow_gamma, "fs^-1", error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%gamma,"fs^-1") + tmp_r2 = cp_unit_from_cp2k(simpar%noisy_gamma, "fs^-1") + tmp_r3 = cp_unit_from_cp2k(simpar%shadow_gamma, "fs^-1") WRITE (UNIT=iw,FMT="(T2,A,T71,ES10.3)")& "LD| Gamma [1/fs] ",tmp_r1,& "LD| Noisy Gamma [1/fs]",tmp_r2,& @@ -100,30 +97,30 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) END IF ! Create section for output enumeration infos - CALL create_md_section(section,error=error) - keyword => section_get_keyword(section,"ENSEMBLE",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + CALL create_md_section(section) + keyword => section_get_keyword(section,"ENSEMBLE") + CALL keyword_get(keyword,enum=enum) !..write some information to output IF ( iw > 0 ) THEN WRITE ( iw, '( A )' ) ' MD| Molecular Dynamics Protocol ' WRITE ( iw, '( A,T61,A20)' ) ' MD| Ensemble Type ', & - ADJUSTR (TRIM(enum_i2c(enum,simpar%ensemble,error=error))) + ADJUSTR (TRIM(enum_i2c(enum,simpar%ensemble))) WRITE ( iw, '( A,T71,I10 )' ) ' MD| Number of Time Steps ', & simpar%nsteps IF (simpar%variable_dt ) THEN WRITE ( iw, '( A )' ) ' MD| Variable Time Step is activated ' - tmp_r1 = cp_unit_from_cp2k(simpar%dt,"fs",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%dt,"fs") WRITE ( iw, '( A,A2,A,T71,F10.2 )' ) ' MD| Max. Time Step [','fs','] ',tmp_r1 - tmp_r1 = cp_unit_from_cp2k(simpar%dr_tol,"angstrom",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%dr_tol,"angstrom") WRITE ( iw, '( A, T71, F10.4 )' ) ' MD| Max. atomic displacement permitted [A] ',tmp_r1 ELSE - tmp_r1 = cp_unit_from_cp2k(simpar%dt,"fs",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%dt,"fs") WRITE ( iw, '( A,A2,A,T71,F10.2 )' ) ' MD| Time Step [','fs','] ',tmp_r1 END IF - tmp_r1 = cp_unit_from_cp2k(simpar%temp_ext,"K",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%temp_ext,"K") WRITE ( iw, '( A,T71,F10.2 )' ) ' MD| Temperature [K] ', tmp_r1 - tmp_r1 = cp_unit_from_cp2k(simpar%temp_tol,"K",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%temp_tol,"K") WRITE ( iw, '( A,T71,F10.2 )' ) ' MD| Temperature tolerance [K] ', tmp_r1 IF ( simpar%annealing ) & @@ -137,10 +134,10 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) simpar%ensemble == npt_f_ensemble .OR. & simpar%ensemble == npe_i_ensemble .OR. & simpar%ensemble == npe_f_ensemble ) THEN - tmp_r1 = cp_unit_from_cp2k(simpar%p_ext,"bar",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%p_ext,"bar") WRITE ( iw, '( A,A3,A, T71, F10.2 )' ) & ' MD| Pressure [','Bar','] ', tmp_r1 - tmp_r1 = cp_unit_from_cp2k(simpar%tau_cell,"fs",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%tau_cell,"fs") WRITE ( iw, '( A,A4,A, T71, F10.2 )' ) & ' MD| Barostat time constant [','fs','] ', tmp_r1 END IF @@ -155,15 +152,15 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) simpar%shake_tol END IF - print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%PROGRAM_RUN_INFO",error=error) - CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint,error=error) + print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%PROGRAM_RUN_INFO") + CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint) WRITE ( iw, '( A,T63,i10,A )' ) ' MD| Print MD information every',iprint, ' step(s)' WRITE ( iw, '( A,T20,A,T71,A10 )' ) ' MD| File type','Print frequency[steps]', 'File names' - print_key => section_vals_get_subs_vals(motion_section,"PRINT%TRAJECTORY",error=error) - CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint,error=error) + print_key => section_vals_get_subs_vals(motion_section,"PRINT%TRAJECTORY") + CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint) filename = cp_print_key_generate_filename(logger,print_key,& - extension=".xyz",middle_name="pos",my_local=.FALSE.,error=error) + extension=".xyz",middle_name="pos",my_local=.FALSE.) WRITE ( iw, '( A,T20,i10,T31,A50 )' ) ' MD| Coordinates',iprint, & ADJUSTR ( TRIM(filename) ) @@ -174,32 +171,32 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) simpar%ensemble == npe_i_ensemble .OR. & simpar%ensemble == npe_f_ensemble) THEN - print_key => section_vals_get_subs_vals(motion_section,"PRINT%CELL",error=error) - CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint,error=error) + print_key => section_vals_get_subs_vals(motion_section,"PRINT%CELL") + CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint) filename = cp_print_key_generate_filename(logger,print_key,& - extension=".cell",my_local=.FALSE.,error=error) + extension=".cell",my_local=.FALSE.) WRITE ( iw, '( A,T20,i10,T31,A50 )' ) ' MD| Simulation Cell',iprint, & ADJUSTR ( TRIM(filename) ) END IF - print_key => section_vals_get_subs_vals(motion_section,"PRINT%VELOCITIES",error=error) - CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint,error=error) + print_key => section_vals_get_subs_vals(motion_section,"PRINT%VELOCITIES") + CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint) filename = cp_print_key_generate_filename(logger,print_key,& - extension=".xyz",middle_name="vel",my_local=.FALSE.,error=error) + extension=".xyz",middle_name="vel",my_local=.FALSE.) WRITE ( iw, '( A,T20,i10,T31,A50 )' ) ' MD| Velocities',iprint,& ADJUSTR ( TRIM(filename) ) - print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%ENERGY",error=error) - CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint,error=error) + print_key => section_vals_get_subs_vals(motion_section,"MD%PRINT%ENERGY") + CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint) filename =cp_print_key_generate_filename(logger,print_key,& - extension=".ener",my_local=.FALSE.,error=error) + extension=".ener",my_local=.FALSE.) WRITE ( iw, '( A,T20,i10,T31,A50 )' ) ' MD| Energies',iprint, & ADJUSTR ( TRIM(filename) ) - print_key => section_vals_get_subs_vals(motion_section,"PRINT%RESTART",error=error) - CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint,error=error) + print_key => section_vals_get_subs_vals(motion_section,"PRINT%RESTART") + CALL section_vals_val_get(print_key,"EACH%MD",i_val=iprint) filename = cp_print_key_generate_filename(logger,print_key,& - extension=".restart",my_local=.FALSE.,error=error) + extension=".restart",my_local=.FALSE.) WRITE ( iw, '( A,T20,i10,T31,A50 )' ) ' MD| Dump',iprint, & ADJUSTR ( TRIM(filename) ) @@ -207,13 +204,13 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) IF ( simpar%ensemble == nph_uniaxial_ensemble .OR. & simpar%ensemble == nph_uniaxial_damped_ensemble ) THEN WRITE ( iw, '( A )' ) ' SHOCK| Uniaxial Shock Parameters: ' - tmp_r1 = cp_unit_from_cp2k(simpar%v_shock,"m*s^-1",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%v_shock,"m*s^-1") WRITE ( iw, '( A,A4,A,T71,F10.4 )' ) & ' SHOCK| Shock Velocity [', 'm/s' ,'] ',tmp_r1 - tmp_r1 = cp_unit_from_cp2k(simpar%gamma_nph,"fs^-1",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%gamma_nph,"fs^-1") WRITE ( iw, '( A,A4,A,T71,F10.4 )' ) & ' SHOCK| Damping Coefficient [', '1/fs' ,'] ',tmp_r1 - tmp_r1 = cp_unit_from_cp2k(simpar%p0,"bar",error=error) + tmp_r1 = cp_unit_from_cp2k(simpar%p0,"bar") WRITE ( iw, '( A,A3,A, T71, F10.2 )' ) & ' SHOCK| Pressure [','Bar','] ', tmp_r1 WRITE ( iw, '( A,A4,A, T71, E10.4 )' ) & @@ -254,9 +251,9 @@ SUBROUTINE read_md_section(simpar, motion_section, md_section, error) END IF END IF END IF - CALL section_release(section, error) + CALL section_release(section) CALL cp_print_key_finished_output(iw,logger,md_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE read_md_section @@ -265,13 +262,11 @@ END SUBROUTINE read_md_section !> \param simpar ... !> \param motion_section ... !> \param md_section ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE read_md_low(simpar, motion_section, md_section, error) + SUBROUTINE read_md_low(simpar, motion_section, md_section) TYPE(simpar_type), POINTER :: simpar TYPE(section_vals_type), POINTER :: motion_section, md_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_md_low', & routineP = moduleN//':'//routineN @@ -281,33 +276,32 @@ SUBROUTINE read_md_low(simpar, motion_section, md_section, error) failure = .FALSE. NULLIFY(tmp_section) - CALL section_vals_val_get(md_section,"ENSEMBLE",i_val=simpar%ensemble,error=error) - CALL section_vals_val_get(md_section,"STEPS",i_val=simpar%nsteps,error=error) - CALL section_vals_val_get(md_section,"TEMPERATURE",r_val=simpar%temp_ext,error=error) - CALL section_vals_val_get(md_section,"TEMP_TOL",r_val=simpar%temp_tol,error=error) - CALL section_vals_val_get(md_section,"ANGVEL_ZERO",l_val=simpar%angvel_zero,error=error) - CALL section_vals_val_get(md_section,"TEMP_KIND",l_val=simpar%temperature_per_kind,error=error) - CALL section_vals_val_get(md_section,"SCALE_TEMP_KIND",l_val=simpar%scale_temperature_per_kind,error=error) - CALL section_vals_val_get(md_section,"ANNEALING",r_val=simpar%f_annealing,explicit=simpar%annealing,& - error=error) + CALL section_vals_val_get(md_section,"ENSEMBLE",i_val=simpar%ensemble) + CALL section_vals_val_get(md_section,"STEPS",i_val=simpar%nsteps) + CALL section_vals_val_get(md_section,"TEMPERATURE",r_val=simpar%temp_ext) + CALL section_vals_val_get(md_section,"TEMP_TOL",r_val=simpar%temp_tol) + CALL section_vals_val_get(md_section,"ANGVEL_ZERO",l_val=simpar%angvel_zero) + CALL section_vals_val_get(md_section,"TEMP_KIND",l_val=simpar%temperature_per_kind) + CALL section_vals_val_get(md_section,"SCALE_TEMP_KIND",l_val=simpar%scale_temperature_per_kind) + CALL section_vals_val_get(md_section,"ANNEALING",r_val=simpar%f_annealing,explicit=simpar%annealing) CALL section_vals_val_get(md_section,"ANNEALING_CELL",r_val=simpar%f_annealing_cell,& - explicit=simpar%annealing_cell,error=error) + explicit=simpar%annealing_cell) CALL section_vals_val_get(md_section,"DISPLACEMENT_TOL",r_val=simpar%dr_tol,& - explicit=simpar%variable_dt,error=error) - CALL section_vals_val_get(md_section,"TIMESTEP",r_val=simpar%dt,error=error) + explicit=simpar%variable_dt) + CALL section_vals_val_get(md_section,"TIMESTEP",r_val=simpar%dt) ! Initialize dt_fact to 1.0 simpar%dt_fact = 1.0_dp IF (simpar%ensemble == langevin_ensemble) THEN - CALL section_vals_val_get(md_section, "LANGEVIN%GAMMA", r_val=simpar%gamma, error=error) - CALL section_vals_val_get(md_section, "LANGEVIN%NOISY_GAMMA", r_val=simpar%noisy_gamma,error=error) - CALL section_vals_val_get(md_section, "LANGEVIN%SHADOW_GAMMA", r_val=simpar%shadow_gamma,error=error) + CALL section_vals_val_get(md_section, "LANGEVIN%GAMMA", r_val=simpar%gamma) + CALL section_vals_val_get(md_section, "LANGEVIN%NOISY_GAMMA", r_val=simpar%noisy_gamma) + CALL section_vals_val_get(md_section, "LANGEVIN%SHADOW_GAMMA", r_val=simpar%shadow_gamma) END IF - tmp_section => section_vals_get_subs_vals(motion_section,"CONSTRAINT",error=error) - CALL section_vals_get(tmp_section,explicit=simpar%constraint,error=error) + tmp_section => section_vals_get_subs_vals(motion_section,"CONSTRAINT") + CALL section_vals_get(tmp_section,explicit=simpar%constraint) IF (simpar%constraint) THEN - CALL section_vals_val_get(tmp_section,"SHAKE_TOLERANCE",r_val=simpar%shake_tol,error=error) + CALL section_vals_val_get(tmp_section,"SHAKE_TOLERANCE",r_val=simpar%shake_tol) CALL cp_assert(simpar%shake_tol>EPSILON(0.0_dp)*1000.0_dp,cp_warning_level,cp_assertion_failed,routineP,& "Shake tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "//& "This may lead to numerical problems. Setting up shake_tol to 1000*EPSILON! "//& @@ -315,7 +309,7 @@ SUBROUTINE read_md_low(simpar, motion_section, md_section, error) only_ionode=.TRUE.) simpar%shake_tol = MAX(EPSILON(0.0_dp)*1000.0_dp,simpar%shake_tol) - CALL section_vals_val_get(tmp_section,"ROLL_TOLERANCE",r_val=simpar%roll_tol,error=error) + CALL section_vals_val_get(tmp_section,"ROLL_TOLERANCE",r_val=simpar%roll_tol) CALL cp_assert(simpar%roll_tol>EPSILON(0.0_dp)*1000.0_dp,cp_warning_level,cp_assertion_failed,routineP,& "Roll tolerance lower than 1000*EPSILON, where EPSILON is the machine precision. "//& "This may lead to numerical problems. Setting up roll_tol to 1000*EPSILON! "//& @@ -325,51 +319,51 @@ SUBROUTINE read_md_low(simpar, motion_section, md_section, error) END IF IF (simpar%ensemble == nph_uniaxial_ensemble.OR.simpar%ensemble == nph_uniaxial_damped_ensemble) THEN - tmp_section => section_vals_get_subs_vals(md_section,"MSST",error=error) - CALL section_vals_val_get(tmp_section,"PRESSURE",r_val=simpar%p0,error=error) - CALL section_vals_val_get(tmp_section,"ENERGY",r_val=simpar%e0,error=error) - CALL section_vals_val_get(tmp_section,"VOLUME",r_val=simpar%v0,error=error) - CALL section_vals_val_get(tmp_section,"GAMMA",r_val=simpar%gamma_nph,error=error) + tmp_section => section_vals_get_subs_vals(md_section,"MSST") + CALL section_vals_val_get(tmp_section,"PRESSURE",r_val=simpar%p0) + CALL section_vals_val_get(tmp_section,"ENERGY",r_val=simpar%e0) + CALL section_vals_val_get(tmp_section,"VOLUME",r_val=simpar%v0) + CALL section_vals_val_get(tmp_section,"GAMMA",r_val=simpar%gamma_nph) IF (simpar%gamma_nph /= 0.0_dp) simpar%ensemble = nph_uniaxial_damped_ensemble - CALL section_vals_val_get(tmp_section,"CMASS",r_val=simpar%cmass,error=error) - CALL section_vals_val_get(tmp_section,"VSHOCK",r_val=simpar%v_shock,error=error) + CALL section_vals_val_get(tmp_section,"CMASS",r_val=simpar%cmass) + CALL section_vals_val_get(tmp_section,"VSHOCK",r_val=simpar%v_shock) END IF SELECT CASE (simpar%ensemble) CASE( nph_uniaxial_damped_ensemble, nph_uniaxial_ensemble, & npt_f_ensemble, npt_i_ensemble, npe_f_ensemble, npe_i_ensemble) - tmp_section => section_vals_get_subs_vals(md_section,"BAROSTAT",error=error) - CALL section_vals_val_get(tmp_section,"PRESSURE",r_val=simpar%p_ext,error=error) - CALL section_vals_val_get(tmp_section,"TIMECON",r_val=simpar%tau_cell,error=error) + tmp_section => section_vals_get_subs_vals(md_section,"BAROSTAT") + CALL section_vals_val_get(tmp_section,"PRESSURE",r_val=simpar%p_ext) + CALL section_vals_val_get(tmp_section,"TIMECON",r_val=simpar%tau_cell) END SELECT ! RESPA - tmp_section => section_vals_get_subs_vals(md_section,"RESPA",error=error) - CALL section_vals_get(tmp_section, explicit=simpar%do_respa, error=error) - CALL section_vals_val_get(tmp_section,"FREQUENCY",i_val=simpar%n_time_steps,error=error) + tmp_section => section_vals_get_subs_vals(md_section,"RESPA") + CALL section_vals_get(tmp_section, explicit=simpar%do_respa) + CALL section_vals_val_get(tmp_section,"FREQUENCY",i_val=simpar%n_time_steps) simpar%multi_time_switch = simpar%do_respa ! CORE-SHELL MODEL - tmp_section => section_vals_get_subs_vals(md_section,"SHELL",error=error) - CALL section_vals_val_get(tmp_section,"TEMPERATURE",r_val=simpar%temp_sh_ext,error=error) - CALL section_vals_val_get(tmp_section,"TEMP_TOL",r_val=simpar%temp_sh_tol,error=error) + tmp_section => section_vals_get_subs_vals(md_section,"SHELL") + CALL section_vals_val_get(tmp_section,"TEMPERATURE",r_val=simpar%temp_sh_ext) + CALL section_vals_val_get(tmp_section,"TEMP_TOL",r_val=simpar%temp_sh_tol) CALL section_vals_val_get(tmp_section,"DISPLACEMENT_SHELL_TOL",r_val=simpar%dsc_tol,& - explicit=explicit,error=error) + explicit=explicit) simpar%variable_dt = simpar%variable_dt.OR.explicit ! ADIABATIC DYNAMICS - tmp_section => section_vals_get_subs_vals(md_section,"ADIABATIC_DYNAMICS",error=error) - CALL section_vals_val_get(tmp_section,"TEMP_FAST",r_val=simpar%temp_fast,error=error) - CALL section_vals_val_get(tmp_section,"TEMP_SLOW",r_val=simpar%temp_slow,error=error) - CALL section_vals_val_get(tmp_section,"TEMP_TOL_FAST",r_val=simpar%temp_tol_fast,error=error) - CALL section_vals_val_get(tmp_section,"TEMP_TOL_SLOW",r_val=simpar%temp_tol_slow,error=error) - CALL section_vals_val_get(tmp_section,"N_RESP_FAST",i_val=simpar%n_resp_fast,error=error) + tmp_section => section_vals_get_subs_vals(md_section,"ADIABATIC_DYNAMICS") + CALL section_vals_val_get(tmp_section,"TEMP_FAST",r_val=simpar%temp_fast) + CALL section_vals_val_get(tmp_section,"TEMP_SLOW",r_val=simpar%temp_slow) + CALL section_vals_val_get(tmp_section,"TEMP_TOL_FAST",r_val=simpar%temp_tol_fast) + CALL section_vals_val_get(tmp_section,"TEMP_TOL_SLOW",r_val=simpar%temp_tol_slow) + CALL section_vals_val_get(tmp_section,"N_RESP_FAST",i_val=simpar%n_resp_fast) ! VELOCITY SOFTENING - tmp_section => section_vals_get_subs_vals(md_section,"VELOCITY_SOFTENING",error=error) - CALL section_vals_val_get(tmp_section,"STEPS",i_val=simpar%soften_nsteps,error=error) - CALL section_vals_val_get(tmp_section,"ALPHA",r_val=simpar%soften_alpha,error=error) - CALL section_vals_val_get(tmp_section,"DELTA",r_val=simpar%soften_delta,error=error) + tmp_section => section_vals_get_subs_vals(md_section,"VELOCITY_SOFTENING") + CALL section_vals_val_get(tmp_section,"STEPS",i_val=simpar%soften_nsteps) + CALL section_vals_val_get(tmp_section,"ALPHA",r_val=simpar%soften_alpha) + CALL section_vals_val_get(tmp_section,"DELTA",r_val=simpar%soften_delta) END SUBROUTINE read_md_low END MODULE simpar_methods diff --git a/src/motion/thermal_region_types.F b/src/motion/thermal_region_types.F index f2ddf01c05..ae86e89745 100644 --- a/src/motion/thermal_region_types.F +++ b/src/motion/thermal_region_types.F @@ -46,12 +46,10 @@ MODULE thermal_region_types ! ***************************************************************************** !> \brief allocate thermal_regions !> \param thermal_regions ... -!> \param error ... !> \author ! ***************************************************************************** - SUBROUTINE allocate_thermal_regions(thermal_regions,error) + SUBROUTINE allocate_thermal_regions(thermal_regions) TYPE(thermal_regions_type), POINTER :: thermal_regions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_thermal_regions', & routineP = moduleN//':'//routineN @@ -61,10 +59,10 @@ SUBROUTINE allocate_thermal_regions(thermal_regions,error) failure = .FALSE. check = .NOT.ASSOCIATED(thermal_regions) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) ALLOCATE(thermal_regions,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) thermal_regions%ref_count = 1 thermal_regions%nregions = 0 NULLIFY(thermal_regions%thermal_region) @@ -74,13 +72,11 @@ END SUBROUTINE allocate_thermal_regions ! ***************************************************************************** !> \brief retains thermal_regions !> \param thermal_regions ... -!> \param error ... !> \author ! ***************************************************************************** - SUBROUTINE retain_thermal_regions(thermal_regions,error) + SUBROUTINE retain_thermal_regions(thermal_regions) TYPE(thermal_regions_type), POINTER :: thermal_regions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_thermal_regions', & routineP = moduleN//':'//routineN @@ -89,7 +85,7 @@ SUBROUTINE retain_thermal_regions(thermal_regions,error) failure=.FALSE. IF (ASSOCIATED(thermal_regions)) THEN - CPPrecondition(thermal_regions%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(thermal_regions%ref_count>0,cp_failure_level,routineP,failure) thermal_regions%ref_count=thermal_regions%ref_count+1 END IF @@ -98,13 +94,11 @@ END SUBROUTINE retain_thermal_regions ! ***************************************************************************** !> \brief release thermal_regions !> \param thermal_regions ... -!> \param error ... !> \author ! ***************************************************************************** - SUBROUTINE release_thermal_regions(thermal_regions, error) + SUBROUTINE release_thermal_regions(thermal_regions) TYPE(thermal_regions_type), POINTER :: thermal_regions - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_thermal_regions', & routineP = moduleN//':'//routineN @@ -116,23 +110,23 @@ SUBROUTINE release_thermal_regions(thermal_regions, error) check = ASSOCIATED(thermal_regions) IF (check) THEN check = thermal_regions%ref_count>0 - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) thermal_regions%ref_count=thermal_regions%ref_count-1 IF (thermal_regions%ref_count<1) THEN IF (ASSOCIATED(thermal_regions%thermal_region)) THEN DO ireg = 1,SIZE(thermal_regions%thermal_region) DEALLOCATE(thermal_regions%thermal_region(ireg)%part_index,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(thermal_regions%thermal_region,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(thermal_regions%do_langevin)) THEN DEALLOCATE(thermal_regions%do_langevin, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF DEALLOCATE(thermal_regions, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF diff --git a/src/motion/thermal_region_utils.F b/src/motion/thermal_region_utils.F index 1b4742f682..ab053e19ba 100644 --- a/src/motion/thermal_region_utils.F +++ b/src/motion/thermal_region_utils.F @@ -62,17 +62,15 @@ MODULE thermal_region_utils !> \param md_section ... !> \param simpar ... !> \param force_env ... -!> \param error ... !> \par History !> - Added support for Langevin regions (2014/01/08, LT) !> \author ! ***************************************************************************** - SUBROUTINE create_thermal_regions(thermal_regions, md_section, simpar, force_env, error) + SUBROUTINE create_thermal_regions(thermal_regions, md_section, simpar, force_env) TYPE(thermal_regions_type), POINTER :: thermal_regions TYPE(section_vals_type), POINTER :: md_section TYPE(simpar_type), POINTER :: simpar TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_thermal_regions', & routineP = moduleN//':'//routineN @@ -94,9 +92,9 @@ SUBROUTINE create_thermal_regions(thermal_regions, md_section, simpar, force_env failure =.FALSE. NULLIFY(region_sections,t_region,thermal_region_section, particles,subsys,tmplist) - CALL allocate_thermal_regions(thermal_regions,error) - thermal_region_section => section_vals_get_subs_vals(md_section,"THERMAL_REGION",error=error) - CALL section_vals_get(thermal_region_section, explicit=explicit, error=error) + CALL allocate_thermal_regions(thermal_regions) + thermal_region_section => section_vals_get_subs_vals(md_section,"THERMAL_REGION") + CALL section_vals_get(thermal_region_section, explicit=explicit) IF (explicit) THEN apply_thermostat =(simpar%ensemble == nvt_ensemble) .OR.& (simpar%ensemble == npt_f_ensemble).OR.& @@ -118,24 +116,24 @@ SUBROUTINE create_thermal_regions(thermal_regions, md_section, simpar, force_env only_ionode=.TRUE.) END IF CALL section_vals_val_get(thermal_region_section, "FORCE_RESCALING", & - l_val=thermal_regions%force_rescaling, error=error) + l_val=thermal_regions%force_rescaling) region_sections => section_vals_get_subs_vals(thermal_region_section, & - "DEFINE_REGION", error=error) - CALL section_vals_get(region_sections, n_repetition=nregions, error=error) + "DEFINE_REGION") + CALL section_vals_get(region_sections, n_repetition=nregions) IF (nregions>0) THEN thermal_regions%nregions = nregions thermal_regions%section => thermal_region_section ALLOCATE(thermal_regions%thermal_region(nregions), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - CALL force_env_get(force_env, subsys=subsys,error=error) - CALL cp_subsys_get(subsys, particles=particles,error=error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + CALL force_env_get(force_env, subsys=subsys) + CALL cp_subsys_get(subsys, particles=particles) IF (simpar%ensemble == langevin_ensemble) THEN CALL cite_reference(Kantorovich2008) CALL cite_reference(Kantorovich2008a) CALL section_vals_val_get(thermal_region_section, "DO_LANGEVIN_DEFAULT", & - l_val=do_langevin_default, error=error) + l_val=do_langevin_default) ALLOCATE(thermal_regions%do_langevin(particles%n_els), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) thermal_regions%do_langevin = do_langevin_default END IF DO ireg = 1,nregions @@ -143,20 +141,20 @@ SUBROUTINE create_thermal_regions(thermal_regions, md_section, simpar, force_env t_region => thermal_regions%thermal_region(ireg) t_region%region_index = ireg CALL section_vals_val_get(region_sections,"LIST", & - i_rep_section=ireg, n_rep_val=nlist, error=error) + i_rep_section=ireg, n_rep_val=nlist) NULLIFY(t_region%part_index) t_region%npart = 0 IF (simpar%ensemble == langevin_ensemble) THEN CALL section_vals_val_get(region_sections, "DO_LANGEVIN", & - i_rep_section=ireg, l_val=do_langevin, error=error) + i_rep_section=ireg, l_val=do_langevin) END IF DO il = 1, nlist CALL section_vals_val_get(region_sections, "LIST", i_rep_section=ireg, & - i_rep_val=il, i_vals=tmplist, error=error) + i_rep_val=il, i_vals=tmplist) CALL reallocate(t_region%part_index,1,t_region%npart+SIZE(tmplist)) DO i = 1, SIZE(tmplist) ipart = tmplist(i) - CPPostcondition(((ipart>0).AND.(ipart<=particles%n_els)),cp_failure_level,routineP,error,failure) + CPPostcondition(((ipart>0).AND.(ipart<=particles%n_els)),cp_failure_level,routineP,failure) t_region%npart = t_region%npart + 1 t_region%part_index(t_region%npart) = ipart particles%els(ipart)%t_region_index = ireg @@ -166,19 +164,19 @@ SUBROUTINE create_thermal_regions(thermal_regions, md_section, simpar, force_env END DO END DO CALL section_vals_val_get(region_sections, "TEMPERATURE", i_rep_section=ireg, & - r_val=temp, error=error) + r_val=temp) t_region%temp_expected = temp CALL section_vals_val_get(region_sections, "TEMP_TOL", i_rep_section=ireg, & - r_val=temp_tol , error=error) + r_val=temp_tol) t_region%temp_tol = temp_tol END DO simpar%do_thermal_region = .TRUE. ELSE - CALL release_thermal_regions(thermal_regions,error) + CALL release_thermal_regions(thermal_regions) simpar%do_thermal_region = .FALSE. END IF ELSE - CALL release_thermal_regions(thermal_regions,error) + CALL release_thermal_regions(thermal_regions) simpar%do_thermal_region = .FALSE. END IF @@ -192,19 +190,17 @@ END SUBROUTINE create_thermal_regions !> \param time : simulation time of the time step !> \param pos : file position !> \param act : file action -!> \param error : wrapper for errors !> \par History !> - added doxygen header and changed subroutine name from !> print_thermal_regions to print_thermal_regions_temperature !> (2014/02/04, LT) !> \author ! ***************************************************************************** - SUBROUTINE print_thermal_regions_temperature(thermal_regions, itimes, time, pos, act, error) + SUBROUTINE print_thermal_regions_temperature(thermal_regions, itimes, time, pos, act) TYPE(thermal_regions_type), POINTER :: thermal_regions INTEGER, INTENT(IN) :: itimes REAL(KIND=dp), INTENT(IN) :: time CHARACTER(LEN=default_string_length) :: pos, act - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'print_thermal_regions_temperature', & @@ -219,14 +215,14 @@ SUBROUTINE print_thermal_regions_temperature(thermal_regions, itimes, time, pos, failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(thermal_regions)) THEN - print_key => section_vals_get_subs_vals(thermal_regions%section,"PRINT%TEMPERATURE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(thermal_regions%section,"PRINT%TEMPERATURE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN unit = cp_print_key_unit_nr(logger,thermal_regions%section,"PRINT%TEMPERATURE",& extension=".tregion",file_position=pos, & - file_action=act, is_new_file=new_file, error=error) + file_action=act, is_new_file=new_file) IF(unit > 0) THEN IF (new_file) THEN WRITE(unit,'(A)')"# Temperature per Region" @@ -234,7 +230,7 @@ SUBROUTINE print_thermal_regions_temperature(thermal_regions, itimes, time, pos, END IF nregions = thermal_regions%nregions ALLOCATE (temp(0:nregions), STAT=istat) - CPPrecondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(istat==0,cp_fatal_level,routineP,failure) temp = 0.0_dp temp(0) = thermal_regions%temp_reg0 DO ireg = 1,nregions @@ -244,9 +240,9 @@ SUBROUTINE print_thermal_regions_temperature(thermal_regions, itimes, time, pos, fmd=TRIM(fmd) WRITE(UNIT=unit,FMT=fmd) itimes,time, temp(0:nregions) DEALLOCATE(temp, STAT=istat) - CPPrecondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(istat==0,cp_fatal_level,routineP,failure) END IF - CALL cp_print_key_finished_output(unit,logger,thermal_regions%section,"PRINT%TEMPERATURE", error=error) + CALL cp_print_key_finished_output(unit,logger,thermal_regions%section,"PRINT%TEMPERATURE") END IF END IF END SUBROUTINE print_thermal_regions_temperature @@ -260,16 +256,14 @@ END SUBROUTINE print_thermal_regions_temperature !> \param simpar : wrapper for simulation parameters !> \param pos : file position !> \param act : file action -!> \param error : wrapper for errors !> \par History !> - created (2014/02/02, LT) !> \author Lianheng Tong [LT] (tonglianheng@gmail.com) ! ***************************************************************************** - SUBROUTINE print_thermal_regions_langevin(thermal_regions, simpar, pos, act, error) + SUBROUTINE print_thermal_regions_langevin(thermal_regions, simpar, pos, act) TYPE(thermal_regions_type), POINTER :: thermal_regions TYPE(simpar_type), POINTER :: simpar CHARACTER(LEN=default_string_length) :: pos, act - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'print_thermal_regions_langevin', & @@ -285,20 +279,19 @@ SUBROUTINE print_thermal_regions_langevin(thermal_regions, simpar, pos, act, err failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(thermal_regions)) THEN IF (ASSOCIATED(thermal_regions%do_langevin)) THEN print_key => section_vals_get_subs_vals(thermal_regions%section, & - "PRINT%LANGEVIN_REGIONS", & - error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key, error=error), & + "PRINT%LANGEVIN_REGIONS") + IF (BTEST(cp_print_key_should_output(logger%iter_info, print_key), & cp_p_file)) THEN print_unit = cp_print_key_unit_nr(logger, thermal_regions%section, & "PRINT%LANGEVIN_REGIONS", & extension=".lgv_regions", & file_position=pos, file_action=act, & - is_new_file=new_file, error=error) + is_new_file=new_file) IF (print_unit > 0) THEN IF (new_file) THEN WRITE (print_unit, '(A)') "# Atoms Undergoing Langevin MD" @@ -307,9 +300,9 @@ SUBROUTINE print_thermal_regions_langevin(thermal_regions, simpar, pos, act, err END IF natoms = SIZE(thermal_regions%do_langevin) ALLOCATE(temperature(natoms), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(region_id(natoms), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) temperature(:) = simpar%temp_ext region_id(:) = 0 DO ireg = 1, thermal_regions%nregions @@ -331,12 +324,12 @@ SUBROUTINE print_thermal_regions_langevin(thermal_regions, simpar, pos, act, err END IF END DO DEALLOCATE(region_id, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(temperature, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF CALL cp_print_key_finished_output(print_unit, logger, thermal_regions%section, & - "PRINT%LANGEVIN_REGIONS", error=error) + "PRINT%LANGEVIN_REGIONS") END IF END IF END IF diff --git a/src/motion/thermostat/al_system_dynamics.F b/src/motion/thermostat/al_system_dynamics.F index e0618365a6..ca5eade7f2 100644 --- a/src/motion/thermostat/al_system_dynamics.F +++ b/src/motion/thermostat/al_system_dynamics.F @@ -49,11 +49,10 @@ MODULE al_system_dynamics !> \param local_particles ... !> \param group ... !> \param vel ... -!> \param error ... !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** SUBROUTINE al_particles( al, force_env, molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, group, vel, error) + particle_set, local_molecules, local_particles, group, vel) TYPE(al_system_type), POINTER :: al TYPE(force_env_type), POINTER :: force_env @@ -64,7 +63,6 @@ SUBROUTINE al_particles( al, force_env, molecule_kind_set, molecule_set, & local_particles INTEGER, INTENT(IN) :: group REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'al_particles', & routineP = moduleN//':'//routineN @@ -82,44 +80,44 @@ SUBROUTINE al_particles( al, force_env, molecule_kind_set, molecule_set, & IF (al%tau_nh <= 0.0_dp) THEN CALL al_OU_step(0.5_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, vel, error) + particle_set, local_molecules, local_particles, vel) IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post OU") ELSE ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, vel, error) + particle_set, local_molecules, local_particles, vel) IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 1st OU") ! Compute the kinetic energy for the region to thermostat for the (T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel=vel, error=error) + local_molecules, molecule_set, group, vel=vel) ! quarter step of chi, and set vel drag factors for a half step - CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.TRUE., error=error) + CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.TRUE.) ! Now scale the particle velocities for a NH half step CALL vel_rescale_particles(map_info, molecule_kind_set, molecule_set, particle_set, & - local_molecules, my_shell_adiabatic, vel=vel, error=error) + local_molecules, my_shell_adiabatic, vel=vel) ! Recompute the kinetic energy for the region to thermostat (for the T dependent chi step) CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel=vel, error=error) + local_molecules, molecule_set, group, vel=vel) IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post rescale_vel") ! quarter step of chi - CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.FALSE., error=error) + CALL al_NH_quarter_step(al, map_info, set_half_step_vel_factors=.FALSE.) ! quarter step of Langevin using Ornstein-Uhlenbeck CALL al_OU_step(0.25_dp, al, force_env, map_info, molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, vel, error) + particle_set, local_molecules, local_particles, vel) IF (debug_this_module) & CALL dump_vel(molecule_kind_set, molecule_set, local_molecules, particle_set, vel, "post 2nd OU") ENDIF ! Recompute the final kinetic energy for the region to thermostat CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel=vel, error=error) + local_molecules, molecule_set, group, vel=vel) CALL timestop(handle) END SUBROUTINE al_particles @@ -175,10 +173,9 @@ END SUBROUTINE dump_vel !> \param local_molecules ... !> \param local_particles ... !> \param vel ... -!> \param error ... ! ***************************************************************************** SUBROUTINE al_OU_step(step, al, force_env, map_info, molecule_kind_set, molecule_set, & - particle_set, local_molecules, local_particles, vel, error) + particle_set, local_molecules, local_particles, vel) REAL(dp), INTENT(in) :: step TYPE(al_system_type), POINTER :: al TYPE(force_env_type), POINTER :: force_env @@ -189,7 +186,6 @@ SUBROUTINE al_OU_step(step, al, force_env, map_info, molecule_kind_set, molecule TYPE(distribution_1d_type), POINTER :: local_molecules, & local_particles REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'al_OU_step', & routineP = moduleN//':'//routineN @@ -224,26 +220,26 @@ SUBROUTINE al_OU_step(step, al, force_env, map_info, molecule_kind_set, molecule nparticle = SIZE(particle_set) nparticle_kind = SIZE(local_particles%n_el) ALLOCATE (w(3,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) w(:,:) = 0.0_dp check=(nparticle_kind <= SIZE(local_particles%n_el) .AND. nparticle_kind <= SIZE(local_particles%list)) - CPPrecondition(check, cp_failure_level, routineP, error, failure) + CPPrecondition(check, cp_failure_level, routineP,failure) check=ASSOCIATED(local_particles%local_particle_set) - CPPrecondition(check, cp_failure_level, routineP, error, failure) + CPPrecondition(check, cp_failure_level, routineP,failure) DO iparticle_kind=1,nparticle_kind nparticle_local = local_particles%n_el(iparticle_kind) check=(nparticle_local <= SIZE(local_particles%list(iparticle_kind)%array)) - CPPrecondition( check, cp_failure_level, routineP, error, failure) + CPPrecondition( check, cp_failure_level, routineP,failure) DO iparticle_local = 1, nparticle_local ipart = local_particles%list(iparticle_kind)%array(iparticle_local) rng_stream => local_particles%local_particle_set(iparticle_kind)%rng(iparticle_local)%stream - w(1,ipart) = next_random_number(rng_stream,variance=1.0_dp,error=error) - w(2,ipart) = next_random_number(rng_stream,variance=1.0_dp,error=error) - w(3,ipart) = next_random_number(rng_stream,variance=1.0_dp,error=error) + w(1,ipart) = next_random_number(rng_stream,variance=1.0_dp) + w(2,ipart) = next_random_number(rng_stream,variance=1.0_dp) + w(3,ipart) = next_random_number(rng_stream,variance=1.0_dp) END DO END DO - CALL fix_atom_control(force_env,error,w) + CALL fix_atom_control(force_env,w) ii = 0 DO ikind=1, SIZE(molecule_kind_set) @@ -268,7 +264,7 @@ SUBROUTINE al_OU_step(step, al, force_env, map_info, molecule_kind_set, molecule END DO DEALLOCATE (w,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE al_OU_step @@ -277,14 +273,12 @@ END SUBROUTINE al_OU_step !> \param al ... !> \param map_info ... !> \param set_half_step_vel_factors ... -!> \param error ... !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** - SUBROUTINE al_NH_quarter_step(al, map_info, set_half_step_vel_factors, error) + SUBROUTINE al_NH_quarter_step(al, map_info, set_half_step_vel_factors) TYPE(al_system_type), POINTER :: al TYPE(map_info_type), POINTER :: map_info LOGICAL, INTENT(in) :: set_half_step_vel_factors - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'al_NH_quarter_step', & routineP = moduleN//':'//routineN diff --git a/src/motion/thermostat/al_system_init.F b/src/motion/thermostat/al_system_init.F index 492e2f5d15..fa016d0927 100644 --- a/src/motion/thermostat/al_system_init.F +++ b/src/motion/thermostat/al_system_init.F @@ -45,12 +45,11 @@ MODULE al_system_init !> \param al ... !> \param al_section ... !> \param gci ... -!> \param error ... !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** SUBROUTINE initialize_al_part ( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, al, al_section,& - gci, error) + gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -61,7 +60,6 @@ SUBROUTINE initialize_al_part ( thermostat_info, simpar, local_molecules,& TYPE(al_system_type), POINTER :: al TYPE(section_vals_type), POINTER :: al_section TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_al_part', & routineP = moduleN//':'//routineN @@ -71,12 +69,12 @@ SUBROUTINE initialize_al_part ( thermostat_info, simpar, local_molecules,& restart=.FALSE. failure = .FALSE. CALL al_to_particle_mapping ( thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, al, para_env, gci, error ) + molecule, molecule_kind_set, al, para_env, gci) - CALL restart_al( al, al_section, restart, error) + CALL restart_al( al, al_section, restart) IF (.NOT. restart) THEN - CALL init_al_variables(al, error=error) + CALL init_al_variables(al) ENDIF END SUBROUTINE initialize_al_part @@ -84,11 +82,9 @@ END SUBROUTINE initialize_al_part ! ***************************************************************************** !> \brief ... !> \param al ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_al_variables(al,error) + SUBROUTINE init_al_variables(al) TYPE(al_system_type), POINTER :: al - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_al_variables', & routineP = moduleN//':'//routineN @@ -102,14 +98,12 @@ END SUBROUTINE init_al_variables !> \param al ... !> \param al_section ... !> \param restart ... -!> \param error ... !> \author Noam Bernstein [noamb] 02.2012 ! ***************************************************************************** - SUBROUTINE restart_al(al, al_section, restart, error) + SUBROUTINE restart_al(al, al_section, restart) TYPE(al_system_type), POINTER :: al TYPE(section_vals_type), POINTER :: al_section LOGICAL, INTENT(inout) :: restart - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'restart_al', & routineP = moduleN//':'//routineN @@ -123,17 +117,17 @@ SUBROUTINE restart_al(al, al_section, restart, error) ! Possibly restart the initial thermostat DOF value work_section => section_vals_get_subs_vals(section_vals=al_section,& - subsection_name="CHI", error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + subsection_name="CHI") + CALL section_vals_get(work_section,explicit=explicit) restart = explicit IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) IF (n_rep==al%glob_num_al) THEN DO i = 1, al%loc_num_al my_index = al%map_info%index(i) CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - i_rep_val=my_index,r_val=al%nvt(i)%chi,error=error) + i_rep_val=my_index,r_val=al%nvt(i)%chi) END DO ELSE CALL stop_program(routineN,moduleN,__LINE__,& @@ -144,20 +138,20 @@ SUBROUTINE restart_al(al, al_section, restart, error) ! Possibly restart the initial thermostat mass work_section => section_vals_get_subs_vals(section_vals=al_section,& - subsection_name="MASS", error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + subsection_name="MASS") + CALL section_vals_get(work_section,explicit=explicit) CALL cp_assert(restart.EQV.explicit,cp_failure_level,cp_assertion_failed,routineP,& "You need to define both CHI and MASS sections (or none) in the AD_LANGEVIN section",& - error=error, failure=failure) + failure=failure) restart = restart.and.explicit IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) IF (n_rep==al%glob_num_al) THEN DO i = 1, al%loc_num_al my_index = al%map_info%index(i) CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - i_rep_val=my_index,r_val=al%nvt(i)%mass,error=error) + i_rep_val=my_index,r_val=al%nvt(i)%mass) END DO ELSE CALL stop_program(routineN,moduleN,__LINE__,& diff --git a/src/motion/thermostat/al_system_mapping.F b/src/motion/thermostat/al_system_mapping.F index 56c0ba4a2c..facbdbaaeb 100644 --- a/src/motion/thermostat/al_system_mapping.F +++ b/src/motion/thermostat/al_system_mapping.F @@ -51,11 +51,10 @@ MODULE al_system_mapping !> \param al ... !> \param para_env ... !> \param gci ... -!> \param error ... !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** SUBROUTINE al_to_particle_mapping ( thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, al, para_env, gci, error) + molecule_set, molecule_kind_set, al, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -65,7 +64,6 @@ SUBROUTINE al_to_particle_mapping ( thermostat_info, simpar, local_molecules,& TYPE(al_system_type), POINTER :: al TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'al_to_particle_mapping', & routineP = moduleN//':'//routineN @@ -90,7 +88,7 @@ SUBROUTINE al_to_particle_mapping ( thermostat_info, simpar, local_molecules,& CALL setup_al_thermostat(al, thermostat_info, deg_of_freedom,& massive_atom_list, molecule_kind_set, local_molecules, molecule_set,& - para_env, natoms_local, simpar, sum_of_thermostats, gci, error=error) + para_env, natoms_local, simpar, sum_of_thermostats, gci) ! Sum up the number of degrees of freedom on each thermostat. ! first: initialize the target @@ -124,9 +122,9 @@ SUBROUTINE al_to_particle_mapping ( thermostat_info, simpar, local_molecules,& END IF DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_atom_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE al_to_particle_mapping @@ -146,12 +144,11 @@ END SUBROUTINE al_to_particle_mapping !> \param sum_of_thermostats ... !> \param gci ... !> \param shell ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2007 ! ***************************************************************************** SUBROUTINE setup_al_thermostat ( al, thermostat_info, deg_of_freedom,& massive_atom_list, molecule_kind_set, local_molecules, molecule_set,& - para_env, natoms_local, simpar, sum_of_thermostats, gci, shell, error) + para_env, natoms_local, simpar, sum_of_thermostats, gci, shell) TYPE(al_system_type), POINTER :: al TYPE(thermostat_info_type), POINTER :: thermostat_info @@ -166,7 +163,6 @@ SUBROUTINE setup_al_thermostat ( al, thermostat_info, deg_of_freedom,& INTEGER, INTENT(OUT) :: sum_of_thermostats TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN), OPTIONAL :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_al_thermostat', & routineP = moduleN//':'//routineN @@ -189,12 +185,12 @@ SUBROUTINE setup_al_thermostat ( al, thermostat_info, deg_of_freedom,& CALL thermostat_mapping_region(map_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local,& simpar, number, region, gci, do_shell, thermostat_info%map_loc_thermo_gen,& - sum_of_thermostats, error) + sum_of_thermostats) ! This is the local number of available thermostats al%loc_num_al = number al%glob_num_al = sum_of_thermostats - CALL al_thermo_create(al, error=error) + CALL al_thermo_create(al) END SUBROUTINE setup_al_thermostat diff --git a/src/motion/thermostat/barostat_types.F b/src/motion/thermostat/barostat_types.F index 778f2ef3bc..6e017aa904 100644 --- a/src/motion/thermostat/barostat_types.F +++ b/src/motion/thermostat/barostat_types.F @@ -69,20 +69,17 @@ MODULE barostat_types !> \param force_env ... !> \param simpar ... !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE create_barostat_type( barostat, md_section, force_env, simpar, & - globenv, error ) + globenv) TYPE(barostat_type), POINTER :: barostat TYPE(section_vals_type), POINTER :: md_section TYPE(force_env_type), POINTER :: force_env TYPE(simpar_type), POINTER :: simpar TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_barostat_type', & routineP = moduleN//':'//routineN @@ -94,9 +91,9 @@ SUBROUTINE create_barostat_type( barostat, md_section, force_env, simpar, & failure =.FALSE. check = .NOT.ASSOCIATED(barostat) - CPPrecondition(check,cp_failure_level,routineP,error,failure) - barostat_section => section_vals_get_subs_vals(md_section,"BAROSTAT",error=error) - CALL section_vals_get(barostat_section, explicit=explicit, error=error) + CPPrecondition(check,cp_failure_level,routineP,failure) + barostat_section => section_vals_get_subs_vals(md_section,"BAROSTAT") + CALL section_vals_get(barostat_section, explicit=explicit) IF (simpar%ensemble == npt_i_ensemble .OR. & simpar%ensemble == npt_f_ensemble .OR. & simpar%ensemble == npe_f_ensemble .OR. & @@ -104,28 +101,28 @@ SUBROUTINE create_barostat_type( barostat, md_section, force_env, simpar, & simpar%ensemble == nph_uniaxial_ensemble .OR. & simpar%ensemble == nph_uniaxial_damped_ensemble) THEN ALLOCATE(barostat, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_barostat_id_nr = last_barostat_id_nr + 1 barostat%id_nr = last_barostat_id_nr barostat%ref_count = 1 barostat%section => barostat_section NULLIFY(barostat%npt) - CALL force_env_get( force_env, cell=cell, error=error ) + CALL force_env_get( force_env, cell=cell) barostat%temp_ext = simpar%temp_baro_ext - CALL section_vals_val_get(barostat_section,"TEMP_TOL",r_val=simpar%temp_baro_tol,error=error) + CALL section_vals_val_get(barostat_section,"TEMP_TOL",r_val=simpar%temp_baro_tol) ! Initialize or possibly restart Barostat CALL initialize_npt (simpar, globenv, barostat%npt,& - cell, work_section=barostat_section, error=error) + cell, work_section=barostat_section) ! If none of the possible barostat has been allocated let's deallocate ! the full structure IF(.NOT.ASSOCIATED(barostat%npt)) THEN - CALL release_barostat_type(barostat, error) + CALL release_barostat_type(barostat) END IF ! User defined virial screening - CALL section_vals_val_get(barostat_section,"VIRIAL",i_val=barostat%virial_components,error=error) + CALL section_vals_val_get(barostat_section,"VIRIAL",i_val=barostat%virial_components) check = barostat%virial_components == do_clv_xyz .OR. simpar%ensemble == npt_f_ensemble CALL cp_assert(check,cp_failure_level,cp_assertion_failed,routineP,& "The screening of the components of the virial is available only with the NPT_F ensemble!"//& @@ -144,14 +141,12 @@ END SUBROUTINE create_barostat_type ! ***************************************************************************** !> \brief retains the given barostat !> \param barostat ... -!> \param error ... !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE retain_barostat_type(barostat,error) + SUBROUTINE retain_barostat_type(barostat) TYPE(barostat_type), POINTER :: barostat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_barostat_type', & routineP = moduleN//':'//routineN @@ -161,7 +156,7 @@ SUBROUTINE retain_barostat_type(barostat,error) failure=.FALSE. IF (ASSOCIATED(barostat)) THEN - CPPrecondition(barostat%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(barostat%ref_count>0,cp_failure_level,routineP,failure) barostat%ref_count=barostat%ref_count+1 END IF END SUBROUTINE retain_barostat_type @@ -169,15 +164,12 @@ END SUBROUTINE retain_barostat_type ! ***************************************************************************** !> \brief ... !> \param barostat ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE release_barostat_type(barostat, error) + SUBROUTINE release_barostat_type(barostat) TYPE(barostat_type), POINTER :: barostat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_barostat_type', & routineP = moduleN//':'//routineN @@ -188,16 +180,16 @@ SUBROUTINE release_barostat_type(barostat, error) failure =.FALSE. IF (ASSOCIATED(barostat)) THEN check = barostat%ref_count>0 - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) barostat%ref_count=barostat%ref_count-1 IF (barostat%ref_count<1) THEN IF ( ASSOCIATED ( barostat%npt ) ) THEN DEALLOCATE (barostat%npt , stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(barostat%section) DEALLOCATE(barostat, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF diff --git a/src/motion/thermostat/barostat_utils.F b/src/motion/thermostat/barostat_utils.F index 78ea671251..55e88f8ab9 100644 --- a/src/motion/thermostat/barostat_utils.F +++ b/src/motion/thermostat/barostat_utils.F @@ -44,19 +44,17 @@ MODULE barostat_utils !> \param npt ... !> \param baro_kin ... !> \param baro_pot ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE get_baro_energies ( cell, simpar, npt, baro_kin, baro_pot, error ) + SUBROUTINE get_baro_energies ( cell, simpar, npt, baro_kin, baro_pot) TYPE(cell_type), POINTER :: cell TYPE(simpar_type), INTENT(IN) :: simpar TYPE(npt_info_type), DIMENSION(:, :), & INTENT(IN) :: npt REAL(KIND=dp), INTENT(OUT) :: baro_kin, baro_pot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_baro_energies', & routineP = moduleN//':'//routineN @@ -97,17 +95,15 @@ END SUBROUTINE get_baro_energies !> \param cell ... !> \param itimes ... !> \param time ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 02.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE print_barostat_status ( barostat, simpar, my_pos, my_act, cell, itimes, time, error ) + SUBROUTINE print_barostat_status ( barostat, simpar, my_pos, my_act, cell, itimes, time) TYPE(barostat_type), POINTER :: barostat TYPE(simpar_type), INTENT(IN) :: simpar CHARACTER(LEN=default_string_length) :: my_pos, my_act TYPE(cell_type), POINTER :: cell INTEGER, INTENT(IN) :: itimes REAL(KIND=dp), INTENT(IN) :: time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_barostat_status', & routineP = moduleN//':'//routineN @@ -119,13 +115,12 @@ SUBROUTINE print_barostat_status ( barostat, simpar, my_pos, my_act, cell, itime failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(barostat)) THEN baro = cp_print_key_unit_nr(logger,barostat%section,"PRINT%ENERGY",& - extension=".bener",file_position=my_pos, file_action=my_act, is_new_file=new_file,& - error=error) - CALL get_baro_energies ( cell, simpar, barostat%npt, baro_kin, baro_pot, error ) + extension=".bener",file_position=my_pos, file_action=my_act, is_new_file=new_file) + CALL get_baro_energies ( cell, simpar, barostat%npt, baro_kin, baro_pot) nfree = SIZE(barostat%npt,1) * SIZE(barostat%npt, 2) temp = 2.0_dp * baro_kin / REAL(nfree,dp)*kelvin IF(baro > 0) THEN @@ -137,7 +132,7 @@ SUBROUTINE print_barostat_status ( barostat, simpar, my_pos, my_act, cell, itime baro_kin, temp, baro_pot, cell%deth*angstrom*angstrom*angstrom CALL m_flush(baro) END IF - CALL cp_print_key_finished_output(baro,logger,barostat%section,"PRINT%ENERGY", error=error) + CALL cp_print_key_finished_output(baro,logger,barostat%section,"PRINT%ENERGY") END IF END SUBROUTINE print_barostat_status diff --git a/src/motion/thermostat/csvr_system_dynamics.F b/src/motion/thermostat/csvr_system_dynamics.F index 0ac4f264b6..7148f9eca9 100644 --- a/src/motion/thermostat/csvr_system_dynamics.F +++ b/src/motion/thermostat/csvr_system_dynamics.F @@ -46,16 +46,14 @@ MODULE csvr_system_dynamics !> \param csvr ... !> \param npt ... !> \param group ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE csvr_barostat ( csvr, npt, group, error ) + SUBROUTINE csvr_barostat ( csvr, npt, group) TYPE(csvr_system_type), POINTER :: csvr TYPE(npt_info_type), DIMENSION(:, :), & INTENT(INOUT) :: npt INTEGER, INTENT(IN) :: group - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'csvr_barostat', & routineP = moduleN//':'//routineN @@ -67,19 +65,19 @@ SUBROUTINE csvr_barostat ( csvr, npt, group, error ) map_info => csvr%map_info ! Compute the kinetic energy of the barostat - CALL ke_region_baro(map_info, npt, group, error) + CALL ke_region_baro(map_info, npt, group) ! Apply the Canonical Sampling through Velocity Rescaling - CALL do_csvr(csvr, map_info, error) + CALL do_csvr(csvr, map_info) ! Now scale the particle velocities - CALL vel_rescale_baro(map_info, npt, error) + CALL vel_rescale_baro(map_info, npt) ! Re-Compute the kinetic energy of the barostat - CALL ke_region_baro(map_info, npt, group, error) + CALL ke_region_baro(map_info, npt, group) ! Compute thermostat energy - CALL do_csvr_eval_energy(csvr, map_info, error) + CALL do_csvr_eval_energy(csvr, map_info) CALL timestop(handle) END SUBROUTINE csvr_barostat @@ -98,13 +96,11 @@ END SUBROUTINE csvr_barostat !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE csvr_particles( csvr, molecule_kind_set, molecule_set, & particle_set, local_molecules, group, shell_adiabatic,& - shell_particle_set, core_particle_set, vel, shell_vel, core_vel,& - error) + shell_particle_set, core_particle_set, vel, shell_vel, core_vel) TYPE(csvr_system_type), POINTER :: csvr TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) @@ -117,7 +113,6 @@ SUBROUTINE csvr_particles( csvr, molecule_kind_set, molecule_set, & core_particle_set( : ) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'csvr_particles', & routineP = moduleN//':'//routineN @@ -133,22 +128,22 @@ SUBROUTINE csvr_particles( csvr, molecule_kind_set, molecule_set, & ! Compute the kinetic energy for the region to thermostat CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) ! Apply the Canonical Sampling through Velocity Rescaling - CALL do_csvr(csvr, map_info, error) + CALL do_csvr(csvr, map_info) ! Now scale the particle velocities CALL vel_rescale_particles(map_info, molecule_kind_set, molecule_set, particle_set,& local_molecules, my_shell_adiabatic, shell_particle_set,core_particle_set,& - vel, shell_vel, core_vel, error) + vel, shell_vel, core_vel) ! Re-Compute the kinetic energy for the region to thermostat CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) ! Compute thermostat energy - CALL do_csvr_eval_energy(csvr, map_info, error) + CALL do_csvr_eval_energy(csvr, map_info) CALL timestop(handle) END SUBROUTINE csvr_particles @@ -165,12 +160,10 @@ END SUBROUTINE csvr_particles !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE csvr_shells(csvr, atomic_kind_set, particle_set, local_particles, & - group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel,& - error) + group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel) TYPE(csvr_system_type), POINTER :: csvr TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) @@ -181,7 +174,6 @@ SUBROUTINE csvr_shells(csvr, atomic_kind_set, particle_set, local_particles, & core_particle_set(:) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'csvr_shells', & routineP = moduleN//':'//routineN @@ -194,21 +186,21 @@ SUBROUTINE csvr_shells(csvr, atomic_kind_set, particle_set, local_particles, & ! Compute the kinetic energy of the region to thermostat CALL ke_region_shells(map_info, particle_set, atomic_kind_set, local_particles,& - group, core_particle_set, shell_particle_set, core_vel, shell_vel, error) + group, core_particle_set, shell_particle_set, core_vel, shell_vel) ! Apply the Canonical Sampling through Velocity Rescaling - CALL do_csvr(csvr, map_info, error) + CALL do_csvr(csvr, map_info) ! Now scale the particle velocities CALL vel_rescale_shells(map_info, atomic_kind_set, particle_set, local_particles, & - shell_particle_set, core_particle_set, shell_vel, core_vel, vel, error) + shell_particle_set, core_particle_set, shell_vel, core_vel, vel) ! Re-Compute the kinetic energy of the region to thermostat CALL ke_region_shells(map_info, particle_set, atomic_kind_set, local_particles,& - group, core_particle_set, shell_particle_set, core_vel, shell_vel, error) + group, core_particle_set, shell_particle_set, core_vel, shell_vel) ! Compute thermostat energy - CALL do_csvr_eval_energy(csvr, map_info, error) + CALL do_csvr_eval_energy(csvr, map_info) CALL timestop(handle) END SUBROUTINE csvr_shells @@ -217,13 +209,11 @@ END SUBROUTINE csvr_shells !> \brief ... !> \param csvr ... !> \param map_info ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE do_csvr(csvr, map_info, error) + SUBROUTINE do_csvr(csvr, map_info) TYPE(csvr_system_type), POINTER :: csvr TYPE(map_info_type), POINTER :: map_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_csvr', & routineP = moduleN//':'//routineN @@ -244,7 +234,7 @@ SUBROUTINE do_csvr(csvr, map_info, error) taut = csvr%tau_csvr/csvr%dt_fact rng_stream => csvr%nvt(i)%gaussian_rng_stream map_info%v_scale(imap) = rescaling_factor(kin_energy, kin_target, ndeg, taut,& - rng_stream, error) + rng_stream) END DO END SUBROUTINE do_csvr @@ -253,13 +243,11 @@ END SUBROUTINE do_csvr !> \brief ... !> \param csvr ... !> \param map_info ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE do_csvr_eval_energy(csvr, map_info, error) + SUBROUTINE do_csvr_eval_energy(csvr, map_info) TYPE(csvr_system_type), POINTER :: csvr TYPE(map_info_type), POINTER :: map_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_csvr_eval_energy', & routineP = moduleN//':'//routineN diff --git a/src/motion/thermostat/csvr_system_init.F b/src/motion/thermostat/csvr_system_init.F index dcbb15d4d4..3b20c16e75 100644 --- a/src/motion/thermostat/csvr_system_init.F +++ b/src/motion/thermostat/csvr_system_init.F @@ -44,15 +44,13 @@ MODULE csvr_system_init !> \param simpar ... !> \param csvr ... !> \param csvr_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE initialize_csvr_baro ( simpar, csvr, csvr_section, error ) + SUBROUTINE initialize_csvr_baro ( simpar, csvr, csvr_section) TYPE(simpar_type), POINTER :: simpar TYPE(csvr_system_type), POINTER :: csvr TYPE(section_vals_type), POINTER :: csvr_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_csvr_baro', & routineP = moduleN//':'//routineN @@ -60,8 +58,8 @@ SUBROUTINE initialize_csvr_baro ( simpar, csvr, csvr_section, error ) LOGICAL :: failure failure = .FALSE. - CALL csvr_to_barostat_mapping ( simpar, csvr, error) - CALL restart_csvr( csvr, csvr_section, error) + CALL csvr_to_barostat_mapping ( simpar, csvr) + CALL restart_csvr( csvr, csvr_section) END SUBROUTINE initialize_csvr_baro @@ -76,12 +74,11 @@ END SUBROUTINE initialize_csvr_baro !> \param csvr ... !> \param csvr_section ... !> \param gci ... -!> \param error ... !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** SUBROUTINE initialize_csvr_part ( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, csvr, csvr_section,& - gci, error) + gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -92,7 +89,6 @@ SUBROUTINE initialize_csvr_part ( thermostat_info, simpar, local_molecules,& TYPE(csvr_system_type), POINTER :: csvr TYPE(section_vals_type), POINTER :: csvr_section TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_csvr_part', & routineP = moduleN//':'//routineN @@ -101,8 +97,8 @@ SUBROUTINE initialize_csvr_part ( thermostat_info, simpar, local_molecules,& failure = .FALSE. CALL csvr_to_particle_mapping ( thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, csvr, para_env, gci, error ) - CALL restart_csvr( csvr, csvr_section, error) + molecule, molecule_kind_set, csvr, para_env, gci) + CALL restart_csvr( csvr, csvr_section) END SUBROUTINE initialize_csvr_part @@ -117,12 +113,11 @@ END SUBROUTINE initialize_csvr_part !> \param csvr ... !> \param csvr_section ... !> \param gci ... -!> \param error ... !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** SUBROUTINE initialize_csvr_shell( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, csvr, csvr_section,& - gci, error) + gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -133,7 +128,6 @@ SUBROUTINE initialize_csvr_shell( thermostat_info, simpar, local_molecules,& TYPE(csvr_system_type), POINTER :: csvr TYPE(section_vals_type), POINTER :: csvr_section TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_csvr_shell', & routineP = moduleN//':'//routineN @@ -142,8 +136,8 @@ SUBROUTINE initialize_csvr_shell( thermostat_info, simpar, local_molecules,& failure = .FALSE. CALL csvr_to_shell_mapping(thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, csvr, para_env, gci, error) - CALL restart_csvr( csvr, csvr_section, error) + molecule, molecule_kind_set, csvr, para_env, gci) + CALL restart_csvr( csvr, csvr_section) END SUBROUTINE initialize_csvr_shell @@ -151,13 +145,11 @@ END SUBROUTINE initialize_csvr_shell !> \brief ... !> \param csvr ... !> \param csvr_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE restart_csvr(csvr, csvr_section, error) + SUBROUTINE restart_csvr(csvr, csvr_section) TYPE(csvr_system_type), POINTER :: csvr TYPE(section_vals_type), POINTER :: csvr_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'restart_csvr', & routineP = moduleN//':'//routineN @@ -171,16 +163,16 @@ SUBROUTINE restart_csvr(csvr, csvr_section, error) ! Possibly restart the initial thermostat energy work_section => section_vals_get_subs_vals(section_vals=csvr_section,& - subsection_name="THERMOSTAT_ENERGY", error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + subsection_name="THERMOSTAT_ENERGY") + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) IF (n_rep==csvr%glob_num_csvr) THEN DO i = 1, csvr%loc_num_csvr my_index = csvr%map_info%index(i) CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - i_rep_val=my_index,r_val=csvr%nvt(i)%thermostat_energy,error=error) + i_rep_val=my_index,r_val=csvr%nvt(i)%thermostat_energy) END DO ELSE CALL stop_program(routineN,moduleN,__LINE__,& @@ -191,19 +183,19 @@ SUBROUTINE restart_csvr(csvr, csvr_section, error) ! Possibly restart the random number generators for the different thermostats work_section => section_vals_get_subs_vals(section_vals=csvr_section,& - subsection_name="RNG_INIT", error=error) + subsection_name="RNG_INIT") - CALL section_vals_get(work_section,explicit=explicit,error=error) + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) IF (n_rep==csvr%glob_num_csvr) THEN DO i = 1, csvr%loc_num_csvr my_index = csvr%map_info%index(i) CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - i_rep_val=my_index,c_val=rng_record,error=error) + i_rep_val=my_index,c_val=rng_record) CALL read_rng_stream(rng_stream=csvr%nvt(i)%gaussian_rng_stream,& - rng_record=rng_record,error=error) + rng_record=rng_record) END DO ELSE CALL stop_program(routineN,moduleN,__LINE__,& diff --git a/src/motion/thermostat/csvr_system_mapping.F b/src/motion/thermostat/csvr_system_mapping.F index b8ebf295e1..f454695b0a 100644 --- a/src/motion/thermostat/csvr_system_mapping.F +++ b/src/motion/thermostat/csvr_system_mapping.F @@ -49,13 +49,11 @@ MODULE csvr_system_mapping !> \brief Creates the thermostatting for the barostat !> \param simpar ... !> \param csvr ... -!> \param error ... !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** - SUBROUTINE csvr_to_barostat_mapping ( simpar, csvr, error ) + SUBROUTINE csvr_to_barostat_mapping ( simpar, csvr) TYPE(simpar_type), POINTER :: simpar TYPE(csvr_system_type), POINTER :: csvr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csvr_to_barostat_mapping', & routineP = moduleN//':'//routineN @@ -81,8 +79,8 @@ SUBROUTINE csvr_to_barostat_mapping ( simpar, csvr, error ) ndeg = 1 ENDIF - CALL init_baro_map_info(map_info, ndeg, csvr%loc_num_csvr, error) - CALL csvr_thermo_create(csvr, error) + CALL init_baro_map_info(map_info, ndeg, csvr%loc_num_csvr) + CALL csvr_thermo_create(csvr) ! Now that we know how many there are stick this into csvr%nkt ! (number of degrees of freedom times k_B T ) @@ -108,11 +106,10 @@ END SUBROUTINE csvr_to_barostat_mapping !> \param csvr ... !> \param para_env ... !> \param gci ... -!> \param error ... !> \author Teodoro Laino [tlaino] 10.2007- University of Zurich ! ***************************************************************************** SUBROUTINE csvr_to_particle_mapping ( thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, csvr, para_env, gci, error) + molecule_set, molecule_kind_set, csvr, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -122,7 +119,6 @@ SUBROUTINE csvr_to_particle_mapping ( thermostat_info, simpar, local_molecules,& TYPE(csvr_system_type), POINTER :: csvr TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csvr_to_particle_mapping', & routineP = moduleN//':'//routineN @@ -147,7 +143,7 @@ SUBROUTINE csvr_to_particle_mapping ( thermostat_info, simpar, local_molecules,& CALL setup_csvr_thermostat(csvr, thermostat_info, deg_of_freedom,& massive_atom_list, molecule_kind_set, local_molecules, molecule_set,& - para_env, natoms_local, simpar, sum_of_thermostats, gci, error=error) + para_env, natoms_local, simpar, sum_of_thermostats, gci) ! Sum up the number of degrees of freedom on each thermostat. ! first: initialize the target @@ -181,9 +177,9 @@ SUBROUTINE csvr_to_particle_mapping ( thermostat_info, simpar, local_molecules,& END IF DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_atom_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE csvr_to_particle_mapping @@ -203,12 +199,11 @@ END SUBROUTINE csvr_to_particle_mapping !> \param sum_of_thermostats ... !> \param gci ... !> \param shell ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2007 ! ***************************************************************************** SUBROUTINE setup_csvr_thermostat ( csvr, thermostat_info, deg_of_freedom,& massive_atom_list, molecule_kind_set, local_molecules, molecule_set,& - para_env, natoms_local, simpar, sum_of_thermostats, gci, shell, error) + para_env, natoms_local, simpar, sum_of_thermostats, gci, shell) TYPE(csvr_system_type), POINTER :: csvr TYPE(thermostat_info_type), POINTER :: thermostat_info @@ -223,7 +218,6 @@ SUBROUTINE setup_csvr_thermostat ( csvr, thermostat_info, deg_of_freedom,& INTEGER, INTENT(OUT) :: sum_of_thermostats TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN), OPTIONAL :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_csvr_thermostat', & routineP = moduleN//':'//routineN @@ -246,12 +240,12 @@ SUBROUTINE setup_csvr_thermostat ( csvr, thermostat_info, deg_of_freedom,& CALL thermostat_mapping_region(map_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local,& simpar, number, region, gci, do_shell, thermostat_info%map_loc_thermo_gen,& - sum_of_thermostats, error) + sum_of_thermostats) ! This is the local number of available thermostats csvr%loc_num_csvr = number csvr%glob_num_csvr = sum_of_thermostats - CALL csvr_thermo_create(csvr, error=error) + CALL csvr_thermo_create(csvr) END SUBROUTINE setup_csvr_thermostat @@ -265,11 +259,10 @@ END SUBROUTINE setup_csvr_thermostat !> \param csvr ... !> \param para_env ... !> \param gci ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2007 ! ***************************************************************************** SUBROUTINE csvr_to_shell_mapping( thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, csvr, para_env, gci, error) + molecule_set, molecule_kind_set, csvr, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -279,7 +272,6 @@ SUBROUTINE csvr_to_shell_mapping( thermostat_info, simpar, local_molecules,& TYPE(csvr_system_type), POINTER :: csvr TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csvr_to_shell_mapping', & routineP = moduleN//':'//routineN @@ -304,7 +296,7 @@ SUBROUTINE csvr_to_shell_mapping( thermostat_info, simpar, local_molecules,& CALL setup_csvr_thermostat(csvr, thermostat_info, deg_of_freedom, massive_shell_list,& molecule_kind_set, local_molecules, molecule_set, para_env, nshell_local, & - simpar, sum_of_thermostats, gci, shell=.TRUE., error=error) + simpar, sum_of_thermostats, gci, shell=.TRUE.) map_info => csvr%map_info ! Sum up the number of degrees of freedom on each thermostat. @@ -329,9 +321,9 @@ SUBROUTINE csvr_to_shell_mapping( thermostat_info, simpar, local_molecules,& END DO DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_shell_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE csvr_to_shell_mapping diff --git a/src/motion/thermostat/extended_system_dynamics.F b/src/motion/thermostat/extended_system_dynamics.F index 191cca3254..2020e99614 100644 --- a/src/motion/thermostat/extended_system_dynamics.F +++ b/src/motion/thermostat/extended_system_dynamics.F @@ -51,19 +51,17 @@ MODULE extended_system_dynamics !> \param nhc ... !> \param npt ... !> \param group ... -!> \param error ... !> \date 13-DEC-2000 !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE lnhc_barostat ( nhc, npt, group, error ) + SUBROUTINE lnhc_barostat ( nhc, npt, group) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(npt_info_type), DIMENSION(:, :), & INTENT(INOUT) :: npt INTEGER, INTENT(IN) :: group - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lnhc_barostat', & routineP = moduleN//':'//routineN @@ -75,13 +73,13 @@ SUBROUTINE lnhc_barostat ( nhc, npt, group, error ) map_info => nhc%map_info ! Compute the kinetic energy of the barostat - CALL ke_region_baro(map_info, npt, group, error) + CALL ke_region_baro(map_info, npt, group) ! Calculate forces on the Nose-Hoover Thermostat and apply chains - CALL do_nhc(nhc, map_info, error) + CALL do_nhc(nhc, map_info) ! Now scale the particle velocities - CALL vel_rescale_baro(map_info, npt, error) + CALL vel_rescale_baro(map_info, npt) CALL timestop(handle) END SUBROUTINE lnhc_barostat @@ -100,15 +98,13 @@ END SUBROUTINE lnhc_barostat !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error ... !> \date 14-NOV-2000 !> \par History !> none ! ***************************************************************************** SUBROUTINE lnhc_particles( nhc, molecule_kind_set, molecule_set, & particle_set, local_molecules, group, shell_adiabatic,& - shell_particle_set, core_particle_set, vel, shell_vel, core_vel,& - error) + shell_particle_set, core_particle_set, vel, shell_vel, core_vel) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) @@ -121,7 +117,6 @@ SUBROUTINE lnhc_particles( nhc, molecule_kind_set, molecule_set, & core_particle_set( : ) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lnhc_particles', & routineP = moduleN//':'//routineN @@ -137,15 +132,15 @@ SUBROUTINE lnhc_particles( nhc, molecule_kind_set, molecule_set, & ! Compute the kinetic energy for the region to thermostat CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) ! Calculate forces on the Nose-Hoover Thermostat and apply chains - CALL do_nhc(nhc, map_info, error) + CALL do_nhc(nhc, map_info) ! Now scale the particle velocities CALL vel_rescale_particles(map_info, molecule_kind_set, molecule_set, particle_set,& local_molecules, my_shell_adiabatic, shell_particle_set,core_particle_set,& - vel, shell_vel, core_vel, error) + vel, shell_vel, core_vel) CALL timestop(handle) END SUBROUTINE lnhc_particles @@ -162,14 +157,12 @@ END SUBROUTINE lnhc_particles !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error ... !> \date 14-NOV-2000 !> \par History !> none ! ***************************************************************************** SUBROUTINE lnhc_shells(nhc, atomic_kind_set, particle_set, local_particles, & - group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel,& - error) + group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) @@ -180,7 +173,6 @@ SUBROUTINE lnhc_shells(nhc, atomic_kind_set, particle_set, local_particles, & core_particle_set(:) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lnhc_shells', & routineP = moduleN//':'//routineN @@ -193,14 +185,14 @@ SUBROUTINE lnhc_shells(nhc, atomic_kind_set, particle_set, local_particles, & ! Compute the kinetic energy of the region to thermostat CALL ke_region_shells(map_info, particle_set, atomic_kind_set, local_particles,& - group, core_particle_set, shell_particle_set, core_vel, shell_vel, error) + group, core_particle_set, shell_particle_set, core_vel, shell_vel) ! Calculate forces on the Nose-Hoover Thermostat and apply chains - CALL do_nhc(nhc, map_info, error) + CALL do_nhc(nhc, map_info) ! Now scale the particle velocities CALL vel_rescale_shells(map_info, atomic_kind_set, particle_set, local_particles, & - shell_particle_set, core_particle_set, shell_vel, core_vel, vel, error) + shell_particle_set, core_particle_set, shell_vel, core_vel, vel) CALL timestop(handle) END SUBROUTINE lnhc_shells @@ -209,13 +201,11 @@ END SUBROUTINE lnhc_shells !> \brief ... !> \param nhc ... !> \param map_info ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE do_nhc(nhc, map_info, error) + SUBROUTINE do_nhc(nhc, map_info) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(map_info_type), POINTER :: map_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_nhc', & routineP = moduleN//':'//routineN @@ -233,7 +223,7 @@ SUBROUTINE do_nhc(nhc, map_info, error) END DO ! Perform multiple time stepping using Yoshida - CALL multiple_step_yoshida(nhc,error) + CALL multiple_step_yoshida(nhc) END SUBROUTINE do_nhc @@ -299,15 +289,13 @@ END SUBROUTINE shell_scale_comv ! ***************************************************************************** !> \brief ... !> \param nhc ... -!> \param error ... !> \date 14-NOV-2000 !> \par History !> none ! ***************************************************************************** - SUBROUTINE multiple_step_yoshida(nhc,error) + SUBROUTINE multiple_step_yoshida(nhc) TYPE(lnhc_parameters_type), POINTER :: nhc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'multiple_step_yoshida', & routineP = moduleN//':'//routineN diff --git a/src/motion/thermostat/extended_system_init.F b/src/motion/thermostat/extended_system_init.F index 15ac785d44..bb11b9316b 100644 --- a/src/motion/thermostat/extended_system_init.F +++ b/src/motion/thermostat/extended_system_init.F @@ -69,10 +69,9 @@ MODULE extended_system_init !> \param npt_info ... !> \param cell ... !> \param work_section ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE initialize_npt ( simpar, globenv, npt_info, cell, work_section, error) + SUBROUTINE initialize_npt ( simpar, globenv, npt_info, cell, work_section) TYPE(simpar_type), POINTER :: simpar TYPE(global_environment_type), POINTER :: globenv @@ -80,7 +79,6 @@ SUBROUTINE initialize_npt ( simpar, globenv, npt_info, cell, work_section, error POINTER :: npt_info TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: work_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_npt', & routineP = moduleN//':'//routineN @@ -99,29 +97,29 @@ SUBROUTINE initialize_npt ( simpar, globenv, npt_info, cell, work_section, error failure=.FALSE. restart = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(npt_info),cp_fatal_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(npt_info),cp_fatal_level,routineP,failure) ! first allocating the npt_info_type if requested SELECT CASE ( simpar % ensemble ) CASE ( npt_i_ensemble, npe_i_ensemble ) ALLOCATE ( npt_info ( 1, 1 ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) npt_info ( :, : ) % eps = LOG ( cell % deth ) / 3.0_dp temp = simpar % temp_baro_ext CASE ( npt_f_ensemble, npe_f_ensemble ) ALLOCATE ( npt_info ( 3, 3 ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) temp = simpar % temp_baro_ext CASE ( nph_uniaxial_ensemble ) ALLOCATE ( npt_info ( 1, 1 ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) temp = simpar% temp_baro_ext CASE ( nph_uniaxial_damped_ensemble ) ALLOCATE ( npt_info ( 1, 1 ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) temp = simpar % temp_baro_ext CASE DEFAULT @@ -131,19 +129,19 @@ SUBROUTINE initialize_npt ( simpar, globenv, npt_info, cell, work_section, error IF (ASSOCIATED(npt_info)) THEN IF (ASSOCIATED(work_section)) THEN - work_section2 => section_vals_get_subs_vals(work_section,"VELOCITY",error=error) - CALL section_vals_get(work_section2, explicit=explicit, error=error) + work_section2 => section_vals_get_subs_vals(work_section,"VELOCITY") + CALL section_vals_get(work_section2, explicit=explicit) restart=explicit - work_section2 => section_vals_get_subs_vals(work_section,"MASS",error=error) - CALL section_vals_get(work_section2, explicit=explicit, error=error) + work_section2 => section_vals_get_subs_vals(work_section,"MASS") + CALL section_vals_get(work_section2, explicit=explicit) CALL cp_assert(restart.EQV.explicit,cp_failure_level,cp_assertion_failed,routineP,& "You need to define both VELOCITY and MASS section (or none) in the BAROSTAT section",& - error=error, failure=failure) + failure=failure) restart=explicit.AND.restart END IF IF ( restart ) THEN - CALL section_vals_val_get(work_section,"VELOCITY%_DEFAULT_KEYWORD_",r_vals=buffer,error=error) + CALL section_vals_val_get(work_section,"VELOCITY%_DEFAULT_KEYWORD_",r_vals=buffer) ind = 0 DO i = 1, SIZE(npt_info,1) DO j = 1, SIZE(npt_info,2) @@ -151,7 +149,7 @@ SUBROUTINE initialize_npt ( simpar, globenv, npt_info, cell, work_section, error npt_info ( i, j ) % v = buffer(ind) END DO END DO - CALL section_vals_val_get(work_section,"MASS%_DEFAULT_KEYWORD_",r_vals=buffer,error=error) + CALL section_vals_val_get(work_section,"MASS%_DEFAULT_KEYWORD_",r_vals=buffer) ind = 0 DO i = 1, SIZE(npt_info,1) DO j = 1, SIZE(npt_info,2) @@ -162,7 +160,7 @@ SUBROUTINE initialize_npt ( simpar, globenv, npt_info, cell, work_section, error ELSE CALL init_barostat_variables ( npt_info, simpar % tau_cell, temp, & simpar % nfree, simpar % ensemble, simpar % cmass,& - globenv ,error=error) + globenv) END IF END IF @@ -179,10 +177,9 @@ END SUBROUTINE initialize_npt !> \param nhc ... !> \param nose_section ... !> \param save_mem ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE initialize_nhc_baro ( simpar, para_env, globenv, nhc, nose_section, save_mem, error ) + SUBROUTINE initialize_nhc_baro ( simpar, para_env, globenv, nhc, nose_section, save_mem) TYPE(simpar_type), POINTER :: simpar TYPE(cp_para_env_type), POINTER :: para_env @@ -190,7 +187,6 @@ SUBROUTINE initialize_nhc_baro ( simpar, para_env, globenv, nhc, nose_section, s TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(section_vals_type), POINTER :: nose_section LOGICAL, INTENT(IN) :: save_mem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_nhc_baro', & routineP = moduleN//':'//routineN @@ -204,16 +200,16 @@ SUBROUTINE initialize_nhc_baro ( simpar, para_env, globenv, nhc, nose_section, s failure = .FALSE. restart = .FALSE. - CALL nhc_to_barostat_mapping ( simpar, nhc, error) + CALL nhc_to_barostat_mapping ( simpar, nhc) ! Set up the Yoshida weights IF ( nhc % nyosh > 0 ) THEN ALLOCATE ( nhc % dt_yosh ( 1 : nhc%nyosh ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) CALL set_yoshida_coef ( nhc, simpar % dt ) END IF - CALL restart_nose(nhc,nose_section,save_mem,restart,"","",para_env,error) + CALL restart_nose(nhc,nose_section,save_mem,restart,"","",para_env) IF (.NOT.restart) THEN ! Initializing thermostat forces and velocities for the Nose-Hoover @@ -223,11 +219,11 @@ SUBROUTINE initialize_nhc_baro ( simpar, para_env, globenv, nhc, nose_section, s temp = simpar%temp_baro_ext END SELECT IF ( nhc % nhc_len /= 0 ) THEN - CALL init_nhc_variables(nhc,temp,para_env,globenv,error=error) + CALL init_nhc_variables(nhc,temp,para_env,globenv) END IF END IF - CALL init_nhc_forces ( nhc, error=error) + CALL init_nhc_forces ( nhc) CALL timestop(handle) @@ -246,12 +242,11 @@ END SUBROUTINE initialize_nhc_baro !> \param nose_section ... !> \param gci ... !> \param save_mem ... -!> \param error ... !> \author CJM ! ***************************************************************************** SUBROUTINE initialize_nhc_slow ( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, globenv, nhc, nose_section,& - gci, save_mem, error) + gci, save_mem) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -264,7 +259,6 @@ SUBROUTINE initialize_nhc_slow ( thermostat_info, simpar, local_molecules,& TYPE(section_vals_type), POINTER :: nose_section TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN) :: save_mem - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_nhc_slow', & routineP = moduleN//':'//routineN @@ -279,26 +273,26 @@ SUBROUTINE initialize_nhc_slow ( thermostat_info, simpar, local_molecules,& ! fire up the thermostats, if not NVE CALL nhc_to_particle_mapping_slow ( thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, nhc, para_env, gci, error ) + molecule, molecule_kind_set, nhc, para_env, gci) ! Set up the Yoshida weights IF ( nhc % nyosh > 0 ) THEN ALLOCATE ( nhc % dt_yosh ( 1 : nhc%nyosh ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) CALL set_yoshida_coef ( nhc, simpar % dt) END IF - CALL restart_nose(nhc,nose_section,save_mem,restart,"","",para_env,error) + CALL restart_nose(nhc,nose_section,save_mem,restart,"","",para_env) IF (.NOT.restart) THEN ! Initializing thermostat forces and velocities for the Nose-Hoover ! Chain variables IF ( nhc % nhc_len /= 0 ) THEN - CALL init_nhc_variables(nhc,simpar%temp_slow,para_env,globenv,error=error) + CALL init_nhc_variables(nhc,simpar%temp_slow,para_env,globenv) END IF END IF - CALL init_nhc_forces ( nhc, error=error) + CALL init_nhc_forces ( nhc) CALL timestop(handle) @@ -317,12 +311,11 @@ END SUBROUTINE initialize_nhc_slow !> \param nose_section ... !> \param gci ... !> \param save_mem ... -!> \param error ... !> \author CJM ! ***************************************************************************** SUBROUTINE initialize_nhc_fast ( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, globenv, nhc, nose_section,& - gci, save_mem, error) + gci, save_mem) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -335,7 +328,6 @@ SUBROUTINE initialize_nhc_fast ( thermostat_info, simpar, local_molecules,& TYPE(section_vals_type), POINTER :: nose_section TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN) :: save_mem - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_nhc_fast', & routineP = moduleN//':'//routineN @@ -350,26 +342,26 @@ SUBROUTINE initialize_nhc_fast ( thermostat_info, simpar, local_molecules,& ! fire up the thermostats, if not NVE CALL nhc_to_particle_mapping_fast ( thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, nhc, para_env, gci, error ) + molecule, molecule_kind_set, nhc, para_env, gci) ! Set up the Yoshida weights IF ( nhc % nyosh > 0 ) THEN ALLOCATE ( nhc % dt_yosh ( 1 : nhc%nyosh ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) CALL set_yoshida_coef ( nhc, simpar % dt) END IF - CALL restart_nose(nhc,nose_section,save_mem,restart,"","",para_env,error) + CALL restart_nose(nhc,nose_section,save_mem,restart,"","",para_env) IF (.NOT.restart) THEN ! Initializing thermostat forces and velocities for the Nose-Hoover ! Chain variables IF ( nhc % nhc_len /= 0 ) THEN - CALL init_nhc_variables(nhc,simpar%temp_fast,para_env,globenv,error=error) + CALL init_nhc_variables(nhc,simpar%temp_fast,para_env,globenv) END IF END IF - CALL init_nhc_forces ( nhc, error=error) + CALL init_nhc_forces ( nhc) CALL timestop(handle) @@ -389,12 +381,11 @@ END SUBROUTINE initialize_nhc_fast !> \param gci ... !> \param save_mem ... !> \param binary_restart_file_name ... -!> \param error ... !> \author CJM ! ***************************************************************************** SUBROUTINE initialize_nhc_part ( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, globenv, nhc, nose_section,& - gci, save_mem, binary_restart_file_name, error) + gci, save_mem, binary_restart_file_name) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -408,7 +399,6 @@ SUBROUTINE initialize_nhc_part ( thermostat_info, simpar, local_molecules,& TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN) :: save_mem CHARACTER(LEN=*), INTENT(IN) :: binary_restart_file_name - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_nhc_part', & routineP = moduleN//':'//routineN @@ -423,27 +413,27 @@ SUBROUTINE initialize_nhc_part ( thermostat_info, simpar, local_molecules,& ! fire up the thermostats, if not NVE CALL nhc_to_particle_mapping ( thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, nhc, para_env, gci, error ) + molecule, molecule_kind_set, nhc, para_env, gci) ! Set up the Yoshida weights IF ( nhc % nyosh > 0 ) THEN ALLOCATE ( nhc % dt_yosh ( 1 : nhc%nyosh ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) CALL set_yoshida_coef ( nhc, simpar % dt) END IF CALL restart_nose(nhc,nose_section,save_mem,restart,binary_restart_file_name,& - "PARTICLE",para_env,error) + "PARTICLE",para_env) IF (.NOT.restart) THEN ! Initializing thermostat forces and velocities for the Nose-Hoover ! Chain variables IF ( nhc % nhc_len /= 0 ) THEN - CALL init_nhc_variables(nhc,simpar%temp_ext,para_env,globenv,error=error) + CALL init_nhc_variables(nhc,simpar%temp_ext,para_env,globenv) END IF END IF - CALL init_nhc_forces ( nhc, error=error) + CALL init_nhc_forces ( nhc) CALL timestop(handle) @@ -463,12 +453,11 @@ END SUBROUTINE initialize_nhc_part !> \param gci ... !> \param save_mem ... !> \param binary_restart_file_name ... -!> \param error ... !> \author MI ! ***************************************************************************** SUBROUTINE initialize_nhc_shell( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, globenv, nhc, nose_section,& - gci, save_mem, binary_restart_file_name, error) + gci, save_mem, binary_restart_file_name) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -482,7 +471,6 @@ SUBROUTINE initialize_nhc_shell( thermostat_info, simpar, local_molecules,& TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN) :: save_mem CHARACTER(LEN=*), INTENT(IN) :: binary_restart_file_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_nhc_shell', & routineP = moduleN//':'//routineN @@ -494,28 +482,28 @@ SUBROUTINE initialize_nhc_shell( thermostat_info, simpar, local_molecules,& failure = .FALSE. CALL nhc_to_shell_mapping(thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, nhc, para_env, gci, error) + molecule, molecule_kind_set, nhc, para_env, gci) restart = .FALSE. ! Set up the Yoshida weights IF ( nhc % nyosh > 0 ) THEN ALLOCATE ( nhc % dt_yosh ( 1 : nhc%nyosh ), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) CALL set_yoshida_coef ( nhc, simpar % dt ) END IF CALL restart_nose(nhc,nose_section,save_mem,restart,binary_restart_file_name,& - "SHELL",para_env,error) + "SHELL",para_env) IF (.NOT.restart) THEN ! Initialize thermostat forces and velocities ! Chain variables IF ( nhc % nhc_len /= 0 ) THEN - CALL init_nhc_variables (nhc, simpar%temp_sh_ext, para_env, globenv, error=error) + CALL init_nhc_variables (nhc, simpar%temp_sh_ext, para_env, globenv) END IF END IF - CALL init_nhc_forces ( nhc, error=error) + CALL init_nhc_forces ( nhc) CALL timestop(handle) @@ -606,14 +594,13 @@ END SUBROUTINE set_yoshida_coef !> \param binary_restart_file_name ... !> \param thermostat_name ... !> \param para_env ... -!> \param error ... !> \par History !> 24-07-07 created !> \author MI ! ***************************************************************************** SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& binary_restart_file_name,thermostat_name,& - para_env,error) + para_env) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(section_vals_type), POINTER :: nose_section @@ -622,7 +609,6 @@ SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& CHARACTER(LEN=*), INTENT(IN) :: binary_restart_file_name, & thermostat_name TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'restart_nose', & routineP = moduleN//':'//routineN @@ -643,7 +629,7 @@ SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& ! Read binary restart file, if available CALL read_binary_thermostats_nose(thermostat_name,nhc,binary_restart_file_name,& - restart,para_env,error) + restart,para_env) ELSE @@ -653,32 +639,29 @@ SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& restart = .FALSE. IF (ASSOCIATED(nose_section)) THEN - work_section => section_vals_get_subs_vals(nose_section,"VELOCITY",error=error) - CALL section_vals_get(work_section, explicit=explicit, error=error) + work_section => section_vals_get_subs_vals(nose_section,"VELOCITY") + CALL section_vals_get(work_section, explicit=explicit) restart=explicit - work_section => section_vals_get_subs_vals(nose_section,"COORD",error=error) - CALL section_vals_get(work_section, explicit=explicit, error=error) + work_section => section_vals_get_subs_vals(nose_section,"COORD") + CALL section_vals_get(work_section, explicit=explicit) CALL cp_assert(restart.or..not.explicit,cp_failure_level,cp_assertion_failed,routineP,& - "You need to define both VELOCITY and COORD and MASS and FORCE section (or none) in the NOSE section",& - error=error) + "You need to define both VELOCITY and COORD and MASS and FORCE section (or none) in the NOSE section") restart=explicit.and.restart - work_section => section_vals_get_subs_vals(nose_section,"MASS",error=error) - CALL section_vals_get(work_section, explicit=explicit, error=error) + work_section => section_vals_get_subs_vals(nose_section,"MASS") + CALL section_vals_get(work_section, explicit=explicit) CALL cp_assert(restart.or..not.explicit,cp_failure_level,cp_assertion_failed,routineP,& - "You need to define both VELOCITY and COORD and MASS and FORCE section (or none) in the NOSE section",& - error=error) + "You need to define both VELOCITY and COORD and MASS and FORCE section (or none) in the NOSE section") restart=explicit.and.restart - work_section => section_vals_get_subs_vals(nose_section,"FORCE",error=error) - CALL section_vals_get(work_section, explicit=explicit, error=error) + work_section => section_vals_get_subs_vals(nose_section,"FORCE") + CALL section_vals_get(work_section, explicit=explicit) CALL cp_assert(restart.or..not.explicit,cp_failure_level,cp_assertion_failed,routineP,& - "You need to define both VELOCITY and COORD and MASS and FORCE section (or none) in the NOSE section",& - error=error) + "You need to define both VELOCITY and COORD and MASS and FORCE section (or none) in the NOSE section") restart=explicit.and.restart END IF IF (restart) THEN map_info => nhc%map_info - CALL section_vals_val_get(nose_section,"COORD%_DEFAULT_KEYWORD_",r_vals=buffer,error=error) + CALL section_vals_val_get(nose_section,"COORD%_DEFAULT_KEYWORD_",r_vals=buffer) DO i = 1, SIZE ( nhc % nvt, 2) ind = map_info%index(i) ind = (ind-1) * nhc % nhc_len @@ -687,7 +670,7 @@ SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& nhc % nvt(j,i) % eta = buffer ( ind ) END DO END DO - CALL section_vals_val_get(nose_section,"VELOCITY%_DEFAULT_KEYWORD_",r_vals=buffer,error=error) + CALL section_vals_val_get(nose_section,"VELOCITY%_DEFAULT_KEYWORD_",r_vals=buffer) DO i = 1, SIZE ( nhc % nvt, 2) ind = map_info%index(i) ind = (ind-1) * nhc % nhc_len @@ -696,7 +679,7 @@ SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& nhc % nvt(j,i) % v = buffer ( ind ) END DO END DO - CALL section_vals_val_get(nose_section,"MASS%_DEFAULT_KEYWORD_",r_vals=buffer,error=error) + CALL section_vals_val_get(nose_section,"MASS%_DEFAULT_KEYWORD_",r_vals=buffer) DO i = 1, SIZE ( nhc % nvt, 2) ind = map_info%index(i) ind = (ind-1) * nhc % nhc_len @@ -705,7 +688,7 @@ SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& nhc % nvt(j,i) % mass = buffer ( ind ) END DO END DO - CALL section_vals_val_get(nose_section,"FORCE%_DEFAULT_KEYWORD_",r_vals=buffer,error=error) + CALL section_vals_val_get(nose_section,"FORCE%_DEFAULT_KEYWORD_",r_vals=buffer) DO i = 1, SIZE ( nhc % nvt, 2) ind = map_info%index(i) ind = (ind-1) * nhc % nhc_len @@ -718,17 +701,17 @@ SUBROUTINE restart_nose(nhc,nose_section,save_mem,restart,& IF (save_mem) THEN NULLIFY(work_section) - work_section => section_vals_get_subs_vals(nose_section,"COORD",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(nose_section,"COORD") + CALL section_vals_remove_values(work_section) NULLIFY(work_section) - work_section => section_vals_get_subs_vals(nose_section,"VELOCITY",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(nose_section,"VELOCITY") + CALL section_vals_remove_values(work_section) NULLIFY(work_section) - work_section => section_vals_get_subs_vals(nose_section,"FORCE",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(nose_section,"FORCE") + CALL section_vals_remove_values(work_section) NULLIFY(work_section) - work_section => section_vals_get_subs_vals(nose_section,"MASS",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(nose_section,"MASS") + CALL section_vals_remove_values(work_section) END IF END IF @@ -743,17 +726,15 @@ END SUBROUTINE restart_nose !> \param temp_ext ... !> \param para_env ... !> \param globenv ... -!> \param error ... !> \date 14-NOV-2000 !> \par History !> none ! ***************************************************************************** - SUBROUTINE init_nhc_variables ( nhc,temp_ext, para_env, globenv, error ) + SUBROUTINE init_nhc_variables ( nhc,temp_ext, para_env, globenv) TYPE(lnhc_parameters_type), POINTER :: nhc REAL(KIND=dp), INTENT(IN) :: temp_ext TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_nhc_variables', & routineP = moduleN//':'//routineN @@ -783,7 +764,7 @@ SUBROUTINE init_nhc_variables ( nhc,temp_ext, para_env, globenv, error ) tot_rn = nhc%glob_num_nhc*nhc%nhc_len ALLOCATE(array_of_rn( tot_rn), STAT = stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) array_of_rn(:) = 0.0_dp END SELECT @@ -792,7 +773,7 @@ SUBROUTINE init_nhc_variables ( nhc,temp_ext, para_env, globenv, error ) ! Map deterministically determined random number to nhc % v DO i = 1, nhc%loc_num_nhc DO j = 1, nhc % nhc_len - nhc%nvt(j,i)%v = next_random_number(globenv%gaussian_rng_stream,error=error) + nhc%nvt(j,i)%v = next_random_number(globenv%gaussian_rng_stream) END DO END DO @@ -829,7 +810,7 @@ SUBROUTINE init_nhc_variables ( nhc,temp_ext, para_env, globenv, error ) CASE DEFAULT DO i=1,tot_rn - array_of_rn(i) = next_random_number(globenv%gaussian_rng_stream,error=error) + array_of_rn(i) = next_random_number(globenv%gaussian_rng_stream) END DO ! Map deterministically determined random number to nhc % v DO i = 1, nhc%loc_num_nhc @@ -843,10 +824,10 @@ SUBROUTINE init_nhc_variables ( nhc,temp_ext, para_env, globenv, error ) END DO END DO DEALLOCATE ( array_of_rn, STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) number = nhc%glob_num_nhc - CALL get_nhc_energies(nhc, dum, akin, para_env, error=error) + CALL get_nhc_energies(nhc, dum, akin, para_env) ! scale velocities to get the correct initial temperature temp = 2.0_dp*akin/REAL(number) @@ -883,13 +864,12 @@ END SUBROUTINE init_nhc_variables !> \param ensemble ... !> \param cmass ... !> \param globenv ... -!> \param error ... !> \date 14-NOV-2000 !> \par History !> none ! ***************************************************************************** SUBROUTINE init_barostat_variables ( npt, tau_cell, temp_ext, nfree, ensemble, & - cmass, globenv, error ) + cmass, globenv) TYPE(npt_info_type), DIMENSION(:, :), & INTENT(INOUT) :: npt @@ -897,7 +877,6 @@ SUBROUTINE init_barostat_variables ( npt, tau_cell, temp_ext, nfree, ensemble, & INTEGER, INTENT(IN) :: nfree, ensemble REAL(KIND=dp), INTENT(IN) :: cmass TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_barostat_variables', & routineP = moduleN//':'//routineN @@ -931,7 +910,7 @@ SUBROUTINE init_barostat_variables ( npt, tau_cell, temp_ext, nfree, ensemble, & ! initializing velocities DO i = 1, SIZE ( npt,1) DO j = i, SIZE ( npt,2) - v = next_random_number(globenv%gaussian_rng_stream,error=error) + v = next_random_number(globenv%gaussian_rng_stream) ! Symmetrizing the initial barostat velocities to ensure ! no rotation of the cell under NPT_F npt(j,i) % v = v @@ -979,13 +958,11 @@ END SUBROUTINE init_barostat_variables ! ***************************************************************************** !> \brief Assigns extended parameters from the restart file. !> \param nhc ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE init_nhc_forces ( nhc, error) + SUBROUTINE init_nhc_forces ( nhc) TYPE(lnhc_parameters_type), POINTER :: nhc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_nhc_forces', & routineP = moduleN//':'//routineN @@ -997,7 +974,7 @@ SUBROUTINE init_nhc_forces ( nhc, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(nhc),cp_fatal_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(nhc),cp_fatal_level,routineP,failure) ! assign the forces DO i = 1, SIZE ( nhc % nvt, 2 ) DO j = 2, SIZE ( nhc % nvt, 1 ) diff --git a/src/motion/thermostat/extended_system_mapping.F b/src/motion/thermostat/extended_system_mapping.F index a54282e5ac..a895399e33 100644 --- a/src/motion/thermostat/extended_system_mapping.F +++ b/src/motion/thermostat/extended_system_mapping.F @@ -54,17 +54,15 @@ MODULE extended_system_mapping !> \brief Creates the thermostatting for the barostat !> \param simpar ... !> \param nhc ... -!> \param error ... !> \par History !> CJM, 20-Feb-01 : nhc structure allocated to zero when not in use !> JGH (10-Mar-2001) : set nhc variables to zero when not in use !> \author CJM ! ***************************************************************************** - SUBROUTINE nhc_to_barostat_mapping ( simpar, nhc, error ) + SUBROUTINE nhc_to_barostat_mapping ( simpar, nhc) TYPE(simpar_type), POINTER :: simpar TYPE(lnhc_parameters_type), POINTER :: nhc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nhc_to_barostat_mapping', & routineP = moduleN//':'//routineN @@ -93,10 +91,10 @@ SUBROUTINE nhc_to_barostat_mapping ( simpar, nhc, error ) number = 1 ENDIF - CALL init_baro_map_info(map_info, number, nhc%loc_num_nhc, error) + CALL init_baro_map_info(map_info, number, nhc%loc_num_nhc) ALLOCATE ( nhc%nvt(nhc%nhc_len, nhc%loc_num_nhc), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Now that we know how many there are stick this into nhc % nkt ! (number of degrees of freedom times k_B T ) DO i = 1, nhc%loc_num_nhc @@ -131,7 +129,6 @@ END SUBROUTINE nhc_to_barostat_mapping !> \param nhc ... !> \param para_env ... !> \param gci ... -!> \param error ... !> \par History !> 29-Nov-00 (JGH) correct counting of DOF if constraints are off !> CJM, 20-Feb-01 : nhc structure allocated to zero when not in use @@ -141,7 +138,7 @@ END SUBROUTINE nhc_to_barostat_mapping !> \author CJM ! ***************************************************************************** SUBROUTINE nhc_to_particle_mapping ( thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, nhc, para_env, gci, error) + molecule_set, molecule_kind_set, nhc, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -151,7 +148,6 @@ SUBROUTINE nhc_to_particle_mapping ( thermostat_info, simpar, local_molecules,& TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nhc_to_particle_mapping', & routineP = moduleN//':'//routineN @@ -180,7 +176,7 @@ SUBROUTINE nhc_to_particle_mapping ( thermostat_info, simpar, local_molecules,& CALL setup_nhc_thermostat(nhc, thermostat_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local, & - simpar, sum_of_thermostats, gci, error=error) + simpar, sum_of_thermostats, gci) ! Sum up the number of degrees of freedom on each thermostat. ! first: initialize the target @@ -220,9 +216,9 @@ SUBROUTINE nhc_to_particle_mapping ( thermostat_info, simpar, local_molecules,& nhc % nvt ( i, : ) % degrees_of_freedom = 1 END DO DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_atom_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Let's clean the arrays map_info%s_kin = 0.0_dp @@ -248,12 +244,11 @@ END SUBROUTINE nhc_to_particle_mapping !> \param sum_of_thermostats ... !> \param gci ... !> \param shell ... -!> \param error ... !> \author CJM -PNNL -2011 ! ***************************************************************************** SUBROUTINE setup_adiabatic_thermostat ( nhc, thermostat_info, deg_of_freedom,& massive_atom_list, molecule_kind_set, local_molecules, molecule_set,& - para_env, natoms_local, simpar, sum_of_thermostats, gci, shell, error) + para_env, natoms_local, simpar, sum_of_thermostats, gci, shell) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(thermostat_info_type), POINTER :: thermostat_info @@ -268,7 +263,6 @@ SUBROUTINE setup_adiabatic_thermostat ( nhc, thermostat_info, deg_of_freedom,& INTEGER, INTENT(OUT) :: sum_of_thermostats TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN), OPTIONAL :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_adiabatic_thermostat', & routineP = moduleN//':'//routineN @@ -294,9 +288,9 @@ SUBROUTINE setup_adiabatic_thermostat ( nhc, thermostat_info, deg_of_freedom,& CALL adiabatic_mapping_region(map_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local,& simpar, number, region, gci, do_shell, thermostat_info%map_loc_thermo_gen,& - sum_of_thermostats, error) + sum_of_thermostats) ALLOCATE (nhc%nvt(nhc%nhc_len,number),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Now that we know how many there are stick this into nhc%nkt ! (number of degrees of freedom times k_B T for the first thermostat @@ -318,12 +312,11 @@ END SUBROUTINE setup_adiabatic_thermostat !> \param nhc ... !> \param para_env ... !> \param gci ... -!> \param error ... !> \par History !> \author CJM ! ***************************************************************************** SUBROUTINE nhc_to_particle_mapping_slow ( thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, nhc, para_env, gci, error) + molecule_set, molecule_kind_set, nhc, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -333,7 +326,6 @@ SUBROUTINE nhc_to_particle_mapping_slow ( thermostat_info, simpar, local_molecul TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nhc_to_particle_mapping_slow', & routineP = moduleN//':'//routineN @@ -358,7 +350,7 @@ SUBROUTINE nhc_to_particle_mapping_slow ( thermostat_info, simpar, local_molecul CASE ( nvt_adiabatic_ensemble ) CALL setup_adiabatic_thermostat(nhc, thermostat_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local, & - simpar, sum_of_thermostats, gci, error=error) + simpar, sum_of_thermostats, gci) ! Sum up the number of degrees of freedom on each thermostat. ! first: initialize the target @@ -399,9 +391,9 @@ SUBROUTINE nhc_to_particle_mapping_slow ( thermostat_info, simpar, local_molecul nhc % nvt ( i, : ) % degrees_of_freedom = 1 END DO DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_atom_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Let's clean the arrays map_info%s_kin = 0.0_dp @@ -422,12 +414,11 @@ END SUBROUTINE nhc_to_particle_mapping_slow !> \param nhc ... !> \param para_env ... !> \param gci ... -!> \param error ... !> \par History !> \author CJM ! ***************************************************************************** SUBROUTINE nhc_to_particle_mapping_fast ( thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, nhc, para_env, gci, error) + molecule_set, molecule_kind_set, nhc, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -437,7 +428,6 @@ SUBROUTINE nhc_to_particle_mapping_fast ( thermostat_info, simpar, local_molecul TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nhc_to_particle_mapping_fast', & routineP = moduleN//':'//routineN @@ -462,7 +452,7 @@ SUBROUTINE nhc_to_particle_mapping_fast ( thermostat_info, simpar, local_molecul CASE ( nvt_adiabatic_ensemble ) CALL setup_adiabatic_thermostat(nhc, thermostat_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local, & - simpar, sum_of_thermostats, gci, error=error) + simpar, sum_of_thermostats, gci) ! Sum up the number of degrees of freedom on each thermostat. ! first: initialize the target @@ -503,9 +493,9 @@ SUBROUTINE nhc_to_particle_mapping_fast ( thermostat_info, simpar, local_molecul nhc % nvt ( i, : ) % degrees_of_freedom = 1 END DO DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_atom_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Let's clean the arrays map_info%s_kin = 0.0_dp @@ -531,12 +521,11 @@ END SUBROUTINE nhc_to_particle_mapping_fast !> \param sum_of_thermostats ... !> \param gci ... !> \param shell ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2007 ! ***************************************************************************** SUBROUTINE setup_nhc_thermostat ( nhc, thermostat_info, deg_of_freedom,& massive_atom_list, molecule_kind_set, local_molecules, molecule_set,& - para_env, natoms_local, simpar, sum_of_thermostats, gci, shell, error) + para_env, natoms_local, simpar, sum_of_thermostats, gci, shell) TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(thermostat_info_type), POINTER :: thermostat_info @@ -551,7 +540,6 @@ SUBROUTINE setup_nhc_thermostat ( nhc, thermostat_info, deg_of_freedom,& INTEGER, INTENT(OUT) :: sum_of_thermostats TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN), OPTIONAL :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_nhc_thermostat', & routineP = moduleN//':'//routineN @@ -577,10 +565,10 @@ SUBROUTINE setup_nhc_thermostat ( nhc, thermostat_info, deg_of_freedom,& CALL thermostat_mapping_region(map_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local,& simpar, number, region, gci, do_shell, thermostat_info%map_loc_thermo_gen,& - sum_of_thermostats, error) + sum_of_thermostats) ALLOCATE (nhc%nvt(nhc%nhc_len,number),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Now that we know how many there are stick this into nhc%nkt ! (number of degrees of freedom times k_B T for the first thermostat @@ -602,10 +590,9 @@ END SUBROUTINE setup_nhc_thermostat !> \param nhc ... !> \param para_env ... !> \param gci ... -!> \param error ... ! ***************************************************************************** SUBROUTINE nhc_to_shell_mapping( thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, nhc, para_env, gci, error) + molecule_set, molecule_kind_set, nhc, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -615,7 +602,6 @@ SUBROUTINE nhc_to_shell_mapping( thermostat_info, simpar, local_molecules,& TYPE(lnhc_parameters_type), POINTER :: nhc TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nhc_to_shell_mapping', & routineP = moduleN//':'//routineN @@ -643,7 +629,7 @@ SUBROUTINE nhc_to_shell_mapping( thermostat_info, simpar, local_molecules,& CALL setup_nhc_thermostat(nhc, thermostat_info, deg_of_freedom, massive_shell_list,& molecule_kind_set, local_molecules, molecule_set, para_env, nshell_local, & - simpar, sum_of_thermostats, gci, shell=.TRUE., error=error) + simpar, sum_of_thermostats, gci, shell=.TRUE.) map_info => nhc%map_info ! Sum up the number of degrees of freedom on each thermostat. @@ -673,9 +659,9 @@ SUBROUTINE nhc_to_shell_mapping( thermostat_info, simpar, local_molecules,& nhc % nvt ( i, : ) % degrees_of_freedom = 1 END DO DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_shell_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Let's clean the arrays map_info%s_kin = 0.0_dp diff --git a/src/motion/thermostat/gle_system_dynamics.F b/src/motion/thermostat/gle_system_dynamics.F index f1a401f790..6df4b78e97 100644 --- a/src/motion/thermostat/gle_system_dynamics.F +++ b/src/motion/thermostat/gle_system_dynamics.F @@ -72,13 +72,11 @@ MODULE gle_system_dynamics !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error ... !> \date !> \par History ! ***************************************************************************** SUBROUTINE gle_particles( gle, molecule_kind_set, molecule_set, particle_set, local_molecules, & - group, shell_adiabatic, shell_particle_set, core_particle_set, vel, shell_vel, core_vel,& - error) + group, shell_adiabatic, shell_particle_set, core_particle_set, vel, shell_vel, core_vel) TYPE(gle_type), POINTER :: gle TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) @@ -91,7 +89,6 @@ SUBROUTINE gle_particles( gle, molecule_kind_set, molecule_set, particle_set, l core_particle_set(:) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gle_particles', & routineP = moduleN//':'//routineN @@ -113,24 +110,24 @@ SUBROUTINE gle_particles( gle, molecule_kind_set, molecule_set, particle_set, l present_vel = PRESENT(vel) ndim = gle%ndim ALLOCATE (s_tmp(ndim,gle%loc_num_gle),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) s_tmp = 0.0_dp ALLOCATE (e_tmp(ndim,gle%loc_num_gle),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (h_tmp(ndim,gle%loc_num_gle),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) map_info => gle%map_info CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) DO ideg = 1, gle%loc_num_gle imap = gle%map_info%map_index(ideg) gle%nvt(ideg)%kin_energy = map_info%s_kin(imap) END DO CALL momentum_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) DO ideg = 1,gle%loc_num_gle imap = gle%map_info%map_index(ideg) @@ -138,11 +135,11 @@ SUBROUTINE gle_particles( gle, molecule_kind_set, molecule_set, particle_set, l gle%nvt(ideg)%s(1)= map_info%s_kin(imap) s_tmp(1,imap) = map_info%s_kin(imap) rng_stream => gle%nvt(ideg)%gaussian_rng_stream - rr = next_random_number( rng_stream,error=error) + rr = next_random_number( rng_stream) e_tmp(1,imap)= rr DO iadd = 2,ndim s_tmp(iadd,imap) = gle%nvt(ideg)%s(iadd) - rr = next_random_number( rng_stream,error=error) + rr = next_random_number( rng_stream) e_tmp(iadd,imap) = rr END DO END DO @@ -169,10 +166,10 @@ SUBROUTINE gle_particles( gle, molecule_kind_set, molecule_set, particle_set, l CALL vel_rescale_particles(map_info, molecule_kind_set, molecule_set, particle_set,& local_molecules, my_shell_adiabatic, shell_particle_set,core_particle_set,& - vel, shell_vel, core_vel, error) + vel, shell_vel, core_vel) CALL ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) DO ideg = 1, gle%loc_num_gle imap = gle%map_info%map_index(ideg) gle%nvt(ideg)%thermostat_energy = gle%nvt(ideg)%thermostat_energy + & @@ -180,7 +177,7 @@ SUBROUTINE gle_particles( gle, molecule_kind_set, molecule_set, particle_set, l END DO DEALLOCATE(e_tmp,s_tmp,h_tmp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE gle_particles @@ -198,12 +195,11 @@ END SUBROUTINE gle_particles !> \param gle_section ... !> \param gci ... !> \param save_mem ... -!> \param error ... !> \author ! ***************************************************************************** SUBROUTINE initialize_gle_part ( thermostat_info, simpar, local_molecules,& molecule, molecule_kind_set, para_env, gle, gle_section,& - gci, save_mem, error) + gci, save_mem) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -215,7 +211,6 @@ SUBROUTINE initialize_gle_part ( thermostat_info, simpar, local_molecules,& TYPE(section_vals_type), POINTER :: gle_section TYPE(global_constraint_type), POINTER :: gci LOGICAL, INTENT(IN) :: save_mem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_gle_part', & routineP = moduleN//':'//routineN @@ -227,12 +222,12 @@ SUBROUTINE initialize_gle_part ( thermostat_info, simpar, local_molecules,& restart = .FALSE. CALL gle_to_particle_mapping ( thermostat_info, simpar, local_molecules,& - molecule, molecule_kind_set, gle, para_env, gci, error ) + molecule, molecule_kind_set, gle, para_env, gci) IF ( gle % ndim /= 0 ) THEN - CALL init_gle_variables ( gle, error=error) + CALL init_gle_variables ( gle) END IF - CALL restart_gle(gle,gle_section,save_mem,restart,error) + CALL restart_gle(gle,gle_section,save_mem,restart) ! here we should have read a_mat and c_mat; whe can therefore compute S and T ! deterministic part of the propagator @@ -341,11 +336,10 @@ END SUBROUTINE gle_cholesky_stab !> \param gle ... !> \param para_env ... !> \param gci ... -!> \param error ... !> \author ! ***************************************************************************** SUBROUTINE gle_to_particle_mapping (thermostat_info, simpar, local_molecules,& - molecule_set, molecule_kind_set, gle, para_env, gci, error ) + molecule_set, molecule_kind_set, gle, para_env, gci) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(simpar_type), POINTER :: simpar @@ -355,7 +349,6 @@ SUBROUTINE gle_to_particle_mapping (thermostat_info, simpar, local_molecules,& TYPE(gle_type), POINTER :: gle TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gle_to_particle_mapping', & routineP = moduleN//':'//routineN @@ -391,14 +384,14 @@ SUBROUTINE gle_to_particle_mapping (thermostat_info, simpar, local_molecules,& CALL thermostat_mapping_region(map_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local,& simpar, number, region, gci, do_shell, thermostat_info%map_loc_thermo_gen,& - sum_of_thermostats, error) + sum_of_thermostats) ! This is the local number of available thermostats gle%loc_num_gle = number gle%glob_num_gle = sum_of_thermostats mal_size = SIZE(massive_atom_list) - CPPrecondition(mal_size/=0,cp_fatal_level,routineP,error,failure) - CALL gle_thermo_create(gle, mal_size, error=error) + CPPrecondition(mal_size/=0,cp_fatal_level,routineP,failure) + CALL gle_thermo_create(gle, mal_size) gle%mal(1:mal_size) = massive_atom_list(1:mal_size) ! Sum up the number of degrees of freedom on each thermostat. @@ -432,9 +425,9 @@ SUBROUTINE gle_to_particle_mapping (thermostat_info, simpar, local_molecules,& END DO END IF DEALLOCATE (deg_of_freedom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( massive_atom_list, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE gle_to_particle_mapping @@ -445,15 +438,13 @@ END SUBROUTINE gle_to_particle_mapping !> \param gle_section ... !> \param save_mem ... !> \param restart ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE restart_gle(gle, gle_section, save_mem, restart, error) + SUBROUTINE restart_gle(gle, gle_section, save_mem, restart) TYPE(gle_type), POINTER :: gle TYPE(section_vals_type), POINTER :: gle_section LOGICAL, INTENT(IN) :: save_mem LOGICAL, INTENT(OUT) :: restart - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'restart_gle', & routineP = moduleN//':'//routineN @@ -473,14 +464,14 @@ SUBROUTINE restart_gle(gle, gle_section, save_mem, restart, error) restart = .FALSE. IF (ASSOCIATED(gle_section)) THEN - work_section => section_vals_get_subs_vals(gle_section,"S",error=error) - CALL section_vals_get(work_section, explicit=explicit, error=error) + work_section => section_vals_get_subs_vals(gle_section,"S") + CALL section_vals_get(work_section, explicit=explicit) restart=explicit END IF IF (restart) THEN map_info => gle%map_info - CALL section_vals_val_get(gle_section,"S%_DEFAULT_KEYWORD_",r_vals=buffer,error=error) + CALL section_vals_val_get(gle_section,"S%_DEFAULT_KEYWORD_",r_vals=buffer) DO i = 1, SIZE ( gle % nvt, 1) ind = map_info%index(i) ind = (ind-1) * (gle% ndim) @@ -492,22 +483,22 @@ SUBROUTINE restart_gle(gle, gle_section, save_mem, restart, error) IF(save_mem) THEN NULLIFY(work_section) - work_section => section_vals_get_subs_vals(gle_section,"S",error=error) - CALL section_vals_remove_values(work_section, error) + work_section => section_vals_get_subs_vals(gle_section,"S") + CALL section_vals_remove_values(work_section) END IF ! Possibly restart the initial thermostat energy work_section => section_vals_get_subs_vals(section_vals=gle_section,& - subsection_name="THERMOSTAT_ENERGY", error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + subsection_name="THERMOSTAT_ENERGY") + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) IF (n_rep==gle%glob_num_gle) THEN DO i = 1, gle%loc_num_gle ind = map_info%index(i) CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - i_rep_val=ind,r_val=gle%nvt(i)%thermostat_energy,error=error) + i_rep_val=ind,r_val=gle%nvt(i)%thermostat_energy) END DO ELSE CALL stop_program(routineN,moduleN,__LINE__,& @@ -518,12 +509,12 @@ SUBROUTINE restart_gle(gle, gle_section, save_mem, restart, error) ! Possibly restart the random number generators for the different thermostats work_section => section_vals_get_subs_vals(section_vals=gle_section,& - subsection_name="RNG_INIT", error=error) + subsection_name="RNG_INIT") - CALL section_vals_get(work_section,explicit=explicit,error=error) + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) glob_num =gle%glob_num_gle loc_num =gle%loc_num_gle @@ -531,9 +522,9 @@ SUBROUTINE restart_gle(gle, gle_section, save_mem, restart, error) DO i = 1, loc_num ind = map_info%index(i) CALL section_vals_val_get(section_vals=work_section,keyword_name="_DEFAULT_KEYWORD_",& - i_rep_val=ind,c_val=rng_record,error=error) + i_rep_val=ind,c_val=rng_record) CALL read_rng_stream(rng_stream=gle%nvt(i)%gaussian_rng_stream,& - rng_record=rng_record,error=error) + rng_record=rng_record) END DO ELSE CALL stop_program(routineN,moduleN,__LINE__,& @@ -548,12 +539,10 @@ END SUBROUTINE restart_gle ! ***************************************************************************** !> \brief ... !> \param gle ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_gle_variables (gle, error) + SUBROUTINE init_gle_variables (gle) TYPE(gle_type), POINTER :: gle - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_gle_variables', & routineP = moduleN//':'//routineN @@ -571,7 +560,7 @@ SUBROUTINE init_gle_variables (gle, error) rng_stream => gle%nvt(i)%gaussian_rng_stream DO j = 1, gle%ndim ! here s should be properly initialized, when it is not read from restart - rr(j) = next_random_number( rng_stream,error=error) + rr(j) = next_random_number( rng_stream) END DO gle%nvt(i)%s = MATMUL(cc,rr) END DO diff --git a/src/motion/thermostat/input_cp2k_barostats.F b/src/motion/thermostat/input_cp2k_barostats.F index 001ecbfca4..2d940dc02b 100644 --- a/src/motion/thermostat/input_cp2k_barostats.F +++ b/src/motion/thermostat/input_cp2k_barostats.F @@ -49,13 +49,10 @@ MODULE input_cp2k_barostats ! ***************************************************************************** !> \brief ... !> \param section will contain the coeff section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_barostat_section(section, error) + SUBROUTINE create_barostat_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_barostat_section', & routineP = moduleN//':'//routineN @@ -66,40 +63,40 @@ SUBROUTINE create_barostat_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="barostat",& description="Parameters of barostat.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword,subsection,thermo_section) CALL keyword_create(keyword, name="PRESSURE",& description="Initial pressure",& usage="PRESSURE real",& - default_r_val=0._dp,unit_str='bar',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp,unit_str='bar') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TIMECON",& description="Barostat time constant",& usage="TIMECON real",& - default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs",error=error),& - unit_str='fs',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(1000.0_dp,"fs"),& + unit_str='fs') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE",& description="Barostat initial temperature. If not set, the ensemble temperature is used instead.",& usage="TEMPERATURE real",type_of_var=real_t,& - unit_str='K',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMP_TOL",& description="Maximum oscillation of the Barostat temperature imposed by rescaling.",& usage="TEMP_TOL real",default_r_val=0._dp, & - unit_str='K',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VIRIAL",& description="For NPT_F only: allows the screening of one or more components of the virial in order"//& @@ -107,37 +104,35 @@ SUBROUTINE create_barostat_section(section, error) usage="VIRIAL (XYZ | X | Y | Z | XY| XZ | YZ)",& enum_c_vals=s2a( "XYZ","X", "Y", "Z", "XY", "XZ", "YZ"),& enum_i_vals=(/ do_clv_xyz, do_clv_x, do_clv_y,do_clv_z, do_clv_xy, do_clv_xz, do_clv_yz/),& - default_i_val=do_clv_xyz, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_clv_xyz) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_velocity_section(subsection,"BAROSTAT",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_velocity_section(subsection,"BAROSTAT") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_mass_section(subsection,"BAROSTAT",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_mass_section(subsection,"BAROSTAT") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_thermostat_section(thermo_section, coupled_thermostat=.TRUE., error=error) - CALL section_add_subsection(section, thermo_section, error=error) - CALL section_release(thermo_section,error=error) + CALL create_thermostat_section(thermo_section, coupled_thermostat=.TRUE.) + CALL section_add_subsection(section, thermo_section) + CALL section_release(thermo_section) - CALL create_print_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_print_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_barostat_section ! ***************************************************************************** !> \brief Creates print section for barostat section !> \param section ... -!> \param error ... !> \author teo [tlaino] - University of Zurich - 02.2008 ! ***************************************************************************** - SUBROUTINE create_print_section(section, error) + SUBROUTINE create_print_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_print_section', & routineP = moduleN//':'//routineN @@ -147,18 +142,18 @@ SUBROUTINE create_print_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) NULLIFY(print_key) CALL section_create(section,name="PRINT",& description="Collects all print_keys for barostat",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL cp_print_key_section_create(print_key,"ENERGY",& description="Controls the output of kinetic energy, and potential energy "//& " of the defined barostat.", print_level=high_print_level, common_iter_levels=1,& - filename="",error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_print_section END MODULE input_cp2k_barostats diff --git a/src/motion/thermostat/thermostat_mapping.F b/src/motion/thermostat/thermostat_mapping.F index 68d8206d71..5e510efada 100644 --- a/src/motion/thermostat/thermostat_mapping.F +++ b/src/motion/thermostat/thermostat_mapping.F @@ -75,12 +75,11 @@ MODULE thermostat_mapping !> \param shell ... !> \param map_loc_thermo_gen ... !> \param sum_of_thermostats ... -!> \param error ... !> \author CJM - PNNL ! ***************************************************************************** SUBROUTINE adiabatic_mapping_region ( map_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local, simpar, & - number, region, gci, shell, map_loc_thermo_gen, sum_of_thermostats, error) + number, region, gci, shell, map_loc_thermo_gen, sum_of_thermostats) TYPE(map_info_type), POINTER :: map_info INTEGER, DIMENSION(:), POINTER :: deg_of_freedom, & @@ -97,7 +96,6 @@ SUBROUTINE adiabatic_mapping_region ( map_info, deg_of_freedom, massive_atom_lis LOGICAL, INTENT(IN) :: shell INTEGER, DIMENSION(:), POINTER :: map_loc_thermo_gen INTEGER, INTENT(INOUT) :: sum_of_thermostats - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'adiabatic_mapping_region', & routineP = moduleN//':'//routineN @@ -113,13 +111,13 @@ SUBROUTINE adiabatic_mapping_region ( map_info, deg_of_freedom, massive_atom_lis failure = .FALSE. NULLIFY ( const_mol, tot_const, point) - CPPostcondition(.NOT.ASSOCIATED(deg_of_freedom),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(massive_atom_list),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(deg_of_freedom),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(massive_atom_list),cp_failure_level,routineP,failure) nkind = SIZE(molecule_kind_set) CALL adiabatic_region_evaluate(map_info%dis_type, natoms_local, nmol_local,& const_mol, tot_const, point, local_molecules, molecule_kind_set, molecule_set,& - simpar, shell, error) + simpar, shell) ! Now we can allocate the target array s_kin and p_kin.. SELECT CASE(region) @@ -129,43 +127,42 @@ SUBROUTINE adiabatic_mapping_region ( map_info, deg_of_freedom, massive_atom_lis ! STOP PROGRAM END SELECT ALLOCATE (map_info%s_kin(nsize),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%v_scale(nsize),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%p_kin(3,natoms_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%p_scale(3,natoms_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! nullify thermostat pointers ! Allocate index array to 1 ALLOCATE ( map_info%index(1), STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE ( map_info%map_index(1), STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE (deg_of_freedom(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL massive_list_generate (molecule_set, molecule_kind_set, & - local_molecules, para_env, massive_atom_list, region, shell,& - error) + local_molecules, para_env, massive_atom_list, region, shell) CALL adiabatic_mapping_region_low(region, map_info, nkind, point,& deg_of_freedom, local_molecules, const_mol, massive_atom_list,& tot_const, molecule_set, number_of_thermostats, shell, gci,& - map_loc_thermo_gen, error) + map_loc_thermo_gen) number = number_of_thermostats sum_of_thermostats=number CALL mp_sum ( sum_of_thermostats, para_env%group ) ! check = (number==number_of_thermostats) -! CPPrecondition(check,cp_fatal_level,routineP,error,failure) +! CPPrecondition(check,cp_fatal_level,routineP,failure) DEALLOCATE (const_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (tot_const,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (point, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -187,12 +184,11 @@ END SUBROUTINE adiabatic_mapping_region !> \param shell ... !> \param gci ... !> \param map_loc_thermo_gen ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2007 ! ***************************************************************************** SUBROUTINE adiabatic_mapping_region_low( region, map_info, nkind, point,& deg_of_freedom, local_molecules, const_mol, massive_atom_list, tot_const,& - molecule_set, ntherm, shell, gci, map_loc_thermo_gen,error) + molecule_set, ntherm, shell, gci, map_loc_thermo_gen) INTEGER, INTENT(IN) :: region TYPE(map_info_type), POINTER :: map_info @@ -207,7 +203,6 @@ SUBROUTINE adiabatic_mapping_region_low( region, map_info, nkind, point,& LOGICAL, INTENT(IN) :: shell TYPE(global_constraint_type), POINTER :: gci INTEGER, DIMENSION(:), POINTER :: map_loc_thermo_gen - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'adiabatic_mapping_region_low', & routineP = moduleN//':'//routineN @@ -234,7 +229,7 @@ SUBROUTINE adiabatic_mapping_region_low( region, map_info, nkind, point,& IF ( region==do_region_global) THEN ! Global Region check = ( map_info%dis_type == do_thermo_communication ) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) DO ikind = 1, nkind DO jj = point ( 1, ikind ), point ( 2, ikind ) IF ( map_loc_thermo_gen ( jj ) /= HUGE ( 0 ) ) THEN @@ -306,7 +301,7 @@ SUBROUTINE adiabatic_mapping_region_low( region, map_info, nkind, point,& ELSE IF ( map_info%dis_type == do_thermo_communication ) THEN ! This case is quite rare and happens only when we have one molecular ! kind and one molecule.. - CPPostcondition(nkind==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nkind==1,cp_failure_level,routineP,failure) number = number + 1 ntherm = ntherm + 1 map_info%index(ntherm) = ntherm @@ -326,7 +321,7 @@ SUBROUTINE adiabatic_mapping_region_low( region, map_info, nkind, point,& END DO END DO ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF IF (nglob_cns/=0) THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -335,7 +330,7 @@ SUBROUTINE adiabatic_mapping_region_low( region, map_info, nkind, point,& ELSE IF ( region==do_region_massive) THEN ! Massive Region check = ( map_info%dis_type == do_thermo_no_communication ) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) DO ikind = 1, nkind nmol_local = local_molecules % n_el ( ikind ) DO imol_local = 1, nmol_local @@ -414,11 +409,10 @@ END SUBROUTINE adiabatic_mapping_region_low !> \param molecule_set ... !> \param simpar ... !> \param shell ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE adiabatic_region_evaluate(dis_type, natoms_local, nmol_local, const_mol,& - tot_const, point, local_molecules, molecule_kind_set, molecule_set, simpar, shell, error) + tot_const, point, local_molecules, molecule_kind_set, molecule_set, simpar, shell) INTEGER, INTENT(IN) :: dis_type INTEGER, INTENT(OUT) :: natoms_local, nmol_local INTEGER, DIMENSION(:), POINTER :: const_mol, tot_const @@ -428,7 +422,6 @@ SUBROUTINE adiabatic_region_evaluate(dis_type, natoms_local, nmol_local, const_m TYPE(molecule_type), POINTER :: molecule_set(:) TYPE(simpar_type), POINTER :: simpar LOGICAL, INTENT(IN) :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'adiabatic_region_evaluate', & routineP = moduleN//':'//routineN @@ -464,16 +457,16 @@ SUBROUTINE adiabatic_region_evaluate(dis_type, natoms_local, nmol_local, const_m END IF END DO - CPPostcondition(.NOT.ASSOCIATED(const_mol),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(tot_const),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(point),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(const_mol),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(tot_const),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(point),cp_failure_level,routineP,failure) IF ( dis_type == do_thermo_no_communication ) THEN ALLOCATE ( const_mol (nmol_local), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE ( tot_const (nmol_local), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE ( point (2, nmol_local), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) point (:,:)= 0 atm_offset = 0 @@ -520,11 +513,11 @@ SUBROUTINE adiabatic_region_evaluate(dis_type, natoms_local, nmol_local, const_m END DO ELSE IF ( dis_type == do_thermo_communication ) THEN ALLOCATE ( const_mol ( nkind ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( tot_const ( nkind ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( point ( 2, nkind ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) point ( :, : ) = 0 atm_offset = 0 ! nc keeps track of all constraints but not fixed ones.. @@ -571,12 +564,11 @@ END SUBROUTINE adiabatic_region_evaluate !> \param shell ... !> \param map_loc_thermo_gen ... !> \param sum_of_thermostats ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2007 ! ***************************************************************************** SUBROUTINE thermostat_mapping_region ( map_info, deg_of_freedom, massive_atom_list,& molecule_kind_set, local_molecules, molecule_set, para_env, natoms_local, simpar, & - number, region, gci, shell, map_loc_thermo_gen, sum_of_thermostats, error) + number, region, gci, shell, map_loc_thermo_gen, sum_of_thermostats) TYPE(map_info_type), POINTER :: map_info INTEGER, DIMENSION(:), POINTER :: deg_of_freedom, & @@ -592,7 +584,6 @@ SUBROUTINE thermostat_mapping_region ( map_info, deg_of_freedom, massive_atom_li LOGICAL, INTENT(IN) :: shell INTEGER, DIMENSION(:), POINTER :: map_loc_thermo_gen INTEGER, INTENT(IN) :: sum_of_thermostats - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'thermostat_mapping_region', & routineP = moduleN//':'//routineN @@ -608,13 +599,13 @@ SUBROUTINE thermostat_mapping_region ( map_info, deg_of_freedom, massive_atom_li failure = .FALSE. NULLIFY ( const_mol, tot_const, point) - CPPostcondition(.NOT.ASSOCIATED(deg_of_freedom),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(massive_atom_list),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(deg_of_freedom),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(massive_atom_list),cp_failure_level,routineP,failure) nkind = SIZE(molecule_kind_set) CALL mapping_region_evaluate(map_info%dis_type, natoms_local, nmol_local,& const_mol, tot_const, point, local_molecules, molecule_kind_set, molecule_set,& - region, simpar, shell, map_loc_thermo_gen, sum_of_thermostats, para_env, error) + region, simpar, shell, map_loc_thermo_gen, sum_of_thermostats, para_env) ! Now we can allocate the target array s_kin and p_kin.. SELECT CASE(region) @@ -624,38 +615,37 @@ SUBROUTINE thermostat_mapping_region ( map_info, deg_of_freedom, massive_atom_li nsize = sum_of_thermostats END SELECT ALLOCATE (map_info%s_kin(nsize),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%v_scale(nsize),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%p_kin(3,natoms_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%p_scale(3,natoms_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Allocate index array ALLOCATE ( map_info%index(number), STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE ( map_info%map_index(number), STAT=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE (deg_of_freedom(number),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL massive_list_generate (molecule_set, molecule_kind_set, & - local_molecules, para_env, massive_atom_list, region, shell,& - error) + local_molecules, para_env, massive_atom_list, region, shell) CALL thermostat_mapping_region_low(region, map_info, nkind, point,& deg_of_freedom, local_molecules, const_mol, massive_atom_list,& tot_const, molecule_set, number_of_thermostats, shell, gci,& - map_loc_thermo_gen, error) + map_loc_thermo_gen) check = (number==number_of_thermostats) - CPPrecondition(check,cp_fatal_level,routineP,error,failure) + CPPrecondition(check,cp_fatal_level,routineP,failure) DEALLOCATE (const_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (tot_const,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (point, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -677,12 +667,11 @@ END SUBROUTINE thermostat_mapping_region !> \param shell ... !> \param gci ... !> \param map_loc_thermo_gen ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich - 10.2007 ! ***************************************************************************** SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& deg_of_freedom, local_molecules, const_mol, massive_atom_list, tot_const,& - molecule_set, number, shell, gci, map_loc_thermo_gen,error) + molecule_set, number, shell, gci, map_loc_thermo_gen) INTEGER, INTENT(IN) :: region TYPE(map_info_type), POINTER :: map_info @@ -697,7 +686,6 @@ SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& LOGICAL, INTENT(IN) :: shell TYPE(global_constraint_type), POINTER :: gci INTEGER, DIMENSION(:), POINTER :: map_loc_thermo_gen - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'thermostat_mapping_region_low', & @@ -723,7 +711,7 @@ SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& IF ( region==do_region_global) THEN ! Global Region check = ( map_info%dis_type == do_thermo_communication ) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) DO ikind = 1, nkind DO jj = point ( 1, ikind ), point ( 2, ikind ) DO ii = 1, 3 @@ -740,13 +728,13 @@ SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& ELSE IF ( region==do_region_defined) THEN ! User defined Region to thermostat check = ( map_info%dis_type == do_thermo_communication ) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ! Lets' identify the matching of the local thermostat w.r.t. the global one itmp = SIZE(map_loc_thermo_gen) ALLOCATE(tmp(itmp),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wrk(itmp),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp(:) = map_loc_thermo_gen CALL sort(tmp, itmp, wrk) number = 1 @@ -762,9 +750,9 @@ SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& END IF END DO DEALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO jj = 1, SIZE(map_loc_thermo_gen) DO ii = 1, 3 imap = map_loc_thermo_gen(jj) @@ -799,7 +787,7 @@ SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& ELSE IF ( map_info%dis_type == do_thermo_communication ) THEN ! This case is quite rare and happens only when we have one molecular ! kind and one molecule.. - CPPostcondition(nkind==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nkind==1,cp_failure_level,routineP,failure) number = number + 1 map_info%index(number) = number map_info%map_index(number) = number @@ -811,7 +799,7 @@ SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& END DO END DO ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF IF (nglob_cns/=0) THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -820,7 +808,7 @@ SUBROUTINE thermostat_mapping_region_low(region, map_info, nkind, point,& ELSE IF ( region==do_region_massive) THEN ! Massive Region check = ( map_info%dis_type == do_thermo_no_communication ) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) DO ikind = 1, nkind nmol_local = local_molecules % n_el ( ikind ) DO imol_local = 1, nmol_local @@ -882,12 +870,11 @@ END SUBROUTINE thermostat_mapping_region_low !> \param map_loc_thermo_gen ... !> \param sum_of_thermostats ... !> \param para_env ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE mapping_region_evaluate(dis_type, natoms_local, nmol_local, const_mol,& tot_const, point, local_molecules, molecule_kind_set, molecule_set, region,& - simpar, shell, map_loc_thermo_gen, sum_of_thermostats, para_env, error) + simpar, shell, map_loc_thermo_gen, sum_of_thermostats, para_env) INTEGER, INTENT(IN) :: dis_type INTEGER, INTENT(OUT) :: natoms_local, nmol_local INTEGER, DIMENSION(:), POINTER :: const_mol, tot_const @@ -901,7 +888,6 @@ SUBROUTINE mapping_region_evaluate(dis_type, natoms_local, nmol_local, const_mol INTEGER, DIMENSION(:), POINTER :: map_loc_thermo_gen INTEGER, INTENT(IN) :: sum_of_thermostats TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mapping_region_evaluate', & routineP = moduleN//':'//routineN @@ -943,16 +929,16 @@ SUBROUTINE mapping_region_evaluate(dis_type, natoms_local, nmol_local, const_mol END IF END DO - CPPostcondition(.NOT.ASSOCIATED(const_mol),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(tot_const),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(point),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(const_mol),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(tot_const),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(point),cp_failure_level,routineP,failure) IF ( dis_type == do_thermo_no_communication ) THEN ALLOCATE ( const_mol (nmol_local), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE ( tot_const (nmol_local), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE ( point (2, nmol_local), STAT = stat ) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) point (:,:)= 0 atm_offset = 0 @@ -1001,11 +987,11 @@ SUBROUTINE mapping_region_evaluate(dis_type, natoms_local, nmol_local, const_mol IF (region==do_region_defined) THEN ! Setup of the arbitrary region ALLOCATE ( tot_const (sum_of_thermostats), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( point (2, 0), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( const_mol (0), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) atm_offset = 0 tot_const = 0 const_mol = 0 @@ -1133,11 +1119,11 @@ SUBROUTINE mapping_region_evaluate(dis_type, natoms_local, nmol_local, const_mol CALL mp_sum(tot_const, para_env%group) ELSE ALLOCATE ( const_mol ( nkind ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( tot_const ( nkind ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( point ( 2, nkind ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) point ( :, : ) = 0 atm_offset = 0 ! nc keeps track of all constraints but not fixed ones.. @@ -1177,10 +1163,9 @@ END SUBROUTINE mapping_region_evaluate !> \param massive_atom_list ... !> \param region ... !> \param shell ... -!> \param error ... ! ***************************************************************************** SUBROUTINE massive_list_generate ( molecule_set, molecule_kind_set, & - local_molecules, para_env, massive_atom_list, region, shell, error ) + local_molecules, para_env, massive_atom_list, region, shell) TYPE(molecule_type), POINTER :: molecule_set( : ) TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) @@ -1189,7 +1174,6 @@ SUBROUTINE massive_list_generate ( molecule_set, molecule_kind_set, & INTEGER, POINTER :: massive_atom_list( : ) INTEGER, INTENT(IN) :: region LOGICAL, INTENT(IN) :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'massive_list_generate', & routineP = moduleN//':'//routineN @@ -1236,18 +1220,18 @@ SUBROUTINE massive_list_generate ( molecule_set, molecule_kind_set, & END DO ALLOCATE(array_num_massive_atm(para_env%num_pe), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_allgather(num_massive_atm_local,array_num_massive_atm,para_env%group) num_massive_atm = SUM(array_num_massive_atm) ALLOCATE(massive_atom_list(num_massive_atm), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) offset = 0 DO iproc=1,para_env%num_pe ncount = array_num_massive_atm(iproc) ALLOCATE(work(ncount), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(para_env%mepos == (iproc-1)) THEN DO i=1,ncount work(i) = local_atm_list(i) @@ -1260,7 +1244,7 @@ SUBROUTINE massive_list_generate ( molecule_set, molecule_kind_set, & massive_atom_list(offset+i) = work(i) END DO DEALLOCATE(work, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) offset = offset + array_num_massive_atm(iproc) END DO @@ -1273,9 +1257,9 @@ SUBROUTINE massive_list_generate ( molecule_set, molecule_kind_set, & IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"work") DEALLOCATE(local_atm_list, STAT = stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(array_num_massive_atm, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1286,14 +1270,12 @@ END SUBROUTINE massive_list_generate !> \param map_info ... !> \param ndeg ... !> \param num_thermo ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich ! ***************************************************************************** - SUBROUTINE init_baro_map_info(map_info, ndeg, num_thermo, error) + SUBROUTINE init_baro_map_info(map_info, ndeg, num_thermo) TYPE(map_info_type), POINTER :: map_info INTEGER, INTENT(IN) :: ndeg, num_thermo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_baro_map_info', & routineP = moduleN//':'//routineN @@ -1304,18 +1286,18 @@ SUBROUTINE init_baro_map_info(map_info, ndeg, num_thermo, error) CALL timeset(routineN,handle) ALLOCATE (map_info%s_kin(num_thermo),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%v_scale(num_thermo),stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%p_kin(1,ndeg),stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%p_scale(1,ndeg),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Allocate the index array ALLOCATE (map_info%index(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (map_info%map_index(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Begin the mapping loop DO i = 1, ndeg diff --git a/src/motion/thermostat/thermostat_methods.F b/src/motion/thermostat/thermostat_methods.F index 102c79b948..67e4d77e68 100644 --- a/src/motion/thermostat/thermostat_methods.F +++ b/src/motion/thermostat/thermostat_methods.F @@ -100,14 +100,12 @@ MODULE thermostat_methods !> \param para_env ... !> \param globenv ... !> \param global_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & - para_env, globenv, global_section, error ) + para_env, globenv, global_section) TYPE(thermostats_type), POINTER :: thermostats TYPE(section_vals_type), POINTER :: md_section TYPE(force_env_type), POINTER :: force_env @@ -115,7 +113,6 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv TYPE(section_vals_type), POINTER :: global_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_thermostats', & routineP = moduleN//':'//routineN @@ -144,23 +141,23 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & NULLIFY(qmmm_env,cell) failure =.FALSE. - CALL allocate_thermostats(thermostats, error) - adiabatic_fast_section => section_vals_get_subs_vals(md_section,"ADIABATIC_DYNAMICS%THERMOSTAT_FAST",error=error) - adiabatic_slow_section => section_vals_get_subs_vals(md_section,"ADIABATIC_DYNAMICS%THERMOSTAT_SLOW",error=error) - thermo_part_section => section_vals_get_subs_vals(md_section,"THERMOSTAT",error=error) - thermo_shell_section => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT",error=error) - thermo_baro_section => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT",error=error) - barostat_section => section_vals_get_subs_vals(md_section,"BAROSTAT",error=error) - print_section => section_vals_get_subs_vals(md_section,"PRINT",error=error) - - CALL force_env_get(force_env, qmmm_env=qmmm_env, subsys=subsys, cell=cell, error=error ) - CALL section_vals_get(barostat_section, explicit=explicit_barostat_section, error=error) - CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem, error=error) - CALL section_vals_get(thermo_part_section, explicit=explicit_part, error=error) - CALL section_vals_get(thermo_shell_section, explicit=explicit_shell, error=error) - CALL section_vals_get(thermo_baro_section, explicit=explicit_baro, error=error) - CALL section_vals_get(adiabatic_fast_section, explicit=explicit_adiabatic_fast, error=error) - CALL section_vals_get(adiabatic_slow_section, explicit=explicit_adiabatic_slow, error=error) + CALL allocate_thermostats(thermostats) + adiabatic_fast_section => section_vals_get_subs_vals(md_section,"ADIABATIC_DYNAMICS%THERMOSTAT_FAST") + adiabatic_slow_section => section_vals_get_subs_vals(md_section,"ADIABATIC_DYNAMICS%THERMOSTAT_SLOW") + thermo_part_section => section_vals_get_subs_vals(md_section,"THERMOSTAT") + thermo_shell_section => section_vals_get_subs_vals(md_section,"SHELL%THERMOSTAT") + thermo_baro_section => section_vals_get_subs_vals(md_section,"BAROSTAT%THERMOSTAT") + barostat_section => section_vals_get_subs_vals(md_section,"BAROSTAT") + print_section => section_vals_get_subs_vals(md_section,"PRINT") + + CALL force_env_get(force_env, qmmm_env=qmmm_env, subsys=subsys, cell=cell) + CALL section_vals_get(barostat_section, explicit=explicit_barostat_section) + CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem) + CALL section_vals_get(thermo_part_section, explicit=explicit_part) + CALL section_vals_get(thermo_shell_section, explicit=explicit_shell) + CALL section_vals_get(thermo_baro_section, explicit=explicit_baro) + CALL section_vals_get(adiabatic_fast_section, explicit=explicit_adiabatic_fast) + CALL section_vals_get(adiabatic_slow_section, explicit=explicit_adiabatic_slow) apply_thermo_adiabatic = (simpar%ensemble==nvt_adiabatic_ensemble) @@ -181,48 +178,48 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & binary_restart_file_name = "" CALL section_vals_val_get(force_env%root_section,"EXT_RESTART%BINARY_RESTART_FILE_NAME",& - c_val=binary_restart_file_name,error=error) + c_val=binary_restart_file_name) ! Compute Degrees of Freedom IF ( simpar%ensemble==nvt_adiabatic_ensemble ) THEN CALL cite_reference(VandeVondele2002) region = do_region_global - region_section_fast => section_vals_get_subs_vals(adiabatic_fast_section,"DEFINE_REGION",error=error) - region_section_slow => section_vals_get_subs_vals(adiabatic_slow_section,"DEFINE_REGION",error=error) - IF (explicit_adiabatic_fast) CALL section_vals_val_get(adiabatic_fast_section,"REGION",i_val=region,error=error) - IF (explicit_adiabatic_slow) CALL section_vals_val_get(adiabatic_slow_section,"REGION",i_val=region,error=error) + region_section_fast => section_vals_get_subs_vals(adiabatic_fast_section,"DEFINE_REGION") + region_section_slow => section_vals_get_subs_vals(adiabatic_slow_section,"DEFINE_REGION") + IF (explicit_adiabatic_fast) CALL section_vals_val_get(adiabatic_fast_section,"REGION",i_val=region) + IF (explicit_adiabatic_slow) CALL section_vals_val_get(adiabatic_slow_section,"REGION",i_val=region) CALL cp_subsys_get(subsys, molecule_kinds_new=molecule_kinds_new, local_molecules_new=local_molecules,& - molecules_new=molecules_new, gci=gci, particles=particles, error=error) + molecules_new=molecules_new, gci=gci, particles=particles) CALL compute_nfree( cell, simpar, molecule_kinds_new%els,& - print_section, particles, gci, error) + print_section, particles, gci) IF (explicit_adiabatic_fast.AND.explicit_adiabatic_slow) THEN IF (apply_thermo_adiabatic) THEN CALL create_thermostat_type(thermostats%thermostat_fast, simpar, adiabatic_fast_section,& - label="FAST", error=error) + label="FAST") CALL create_thermostat_type(thermostats%thermostat_slow, simpar, adiabatic_slow_section,& - label="SLOW", error=error) + label="SLOW") CALL setup_adiabatic_thermostat_info(thermostats%thermostat_info_fast, & molecule_kinds_new%els, local_molecules, molecules_new, particles, & region, simpar%ensemble, region_sections=region_section_fast, & - qmmm_env=qmmm_env, error=error) + qmmm_env=qmmm_env) CALL setup_adiabatic_thermostat_info(thermostats%thermostat_info_slow, & molecule_kinds_new%els, local_molecules, molecules_new, particles,& region, simpar%ensemble, region_sections=region_section_slow, & - qmmm_env=qmmm_env, error=error) + qmmm_env=qmmm_env) ! Initialize or possibly restart Nose on Particles - work_section => section_vals_get_subs_vals(adiabatic_fast_section,"NOSE",error=error) + work_section => section_vals_get_subs_vals(adiabatic_fast_section,"NOSE") CALL initialize_nhc_fast(thermostats%thermostat_info_fast, simpar, local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, globenv,& thermostats%thermostat_fast%nhc, nose_section=work_section, gci=gci,& - save_mem=save_mem, error=error) - work_section => section_vals_get_subs_vals(adiabatic_slow_section,"NOSE",error=error) + save_mem=save_mem) + work_section => section_vals_get_subs_vals(adiabatic_slow_section,"NOSE") CALL initialize_nhc_slow(thermostats%thermostat_info_slow, simpar, local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, globenv,& thermostats%thermostat_slow%nhc, nose_section=work_section, gci=gci,& - save_mem=save_mem, error=error) + save_mem=save_mem) ENDIF ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& @@ -231,57 +228,56 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & CPSourceFileRef,& only_ionode=.TRUE.) END IF - CALL release_thermostat_info(thermostats%thermostat_info_fast, error) - CALL release_thermostat_info(thermostats%thermostat_info_slow, error) + CALL release_thermostat_info(thermostats%thermostat_info_fast) + CALL release_thermostat_info(thermostats%thermostat_info_slow) ELSE region = do_region_global - region_sections => section_vals_get_subs_vals(thermo_part_section,"DEFINE_REGION",error=error) - IF (explicit_part) CALL section_vals_val_get(thermo_part_section,"REGION",i_val=region,error=error) + region_sections => section_vals_get_subs_vals(thermo_part_section,"DEFINE_REGION") + IF (explicit_part) CALL section_vals_val_get(thermo_part_section,"REGION",i_val=region) CALL cp_subsys_get(subsys, molecule_kinds_new=molecule_kinds_new, local_molecules_new=local_molecules,& - molecules_new=molecules_new, gci=gci, particles=particles, error=error) + molecules_new=molecules_new, gci=gci, particles=particles) CALL compute_degrees_of_freedom(thermostats, cell, simpar, molecule_kinds_new%els,& local_molecules, molecules_new, particles, print_section, region_sections, gci,& - region, qmmm_env, error) + region, qmmm_env) ! Particles ! For constant temperature ensembles the thermostat is activated by default IF (explicit_part) THEN IF (apply_general_thermo) THEN CALL create_thermostat_type(thermostats%thermostat_part, simpar, thermo_part_section,& - label="PARTICLES", error=error) + label="PARTICLES") ! Initialize thermostat IF (thermostats%thermostat_part%type_of_thermostat == do_thermo_nose) THEN ! Initialize or possibly restart Nose on Particles - work_section => section_vals_get_subs_vals(thermo_part_section,"NOSE",error=error) + work_section => section_vals_get_subs_vals(thermo_part_section,"NOSE") CALL initialize_nhc_part(thermostats%thermostat_info_part, simpar, local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, globenv,& thermostats%thermostat_part%nhc, nose_section=work_section, gci=gci,& - save_mem=save_mem, binary_restart_file_name=binary_restart_file_name,& - error=error) + save_mem=save_mem, binary_restart_file_name=binary_restart_file_name) ELSE IF (thermostats%thermostat_part%type_of_thermostat==do_thermo_csvr) THEN ! Initialize or possibly restart CSVR thermostat on Particles - work_section => section_vals_get_subs_vals(thermo_part_section,"CSVR",error=error) + work_section => section_vals_get_subs_vals(thermo_part_section,"CSVR") CALL initialize_csvr_part(thermostats%thermostat_info_part,simpar,local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, & thermostats%thermostat_part%csvr, csvr_section=work_section,& - gci=gci, error=error) + gci=gci) ELSE IF (thermostats%thermostat_part%type_of_thermostat==do_thermo_al) THEN ! Initialize or possibly restart Ad-Langevin thermostat on Particles - work_section => section_vals_get_subs_vals(thermo_part_section,"AD_LANGEVIN",error=error) + work_section => section_vals_get_subs_vals(thermo_part_section,"AD_LANGEVIN") CALL initialize_al_part(thermostats%thermostat_info_part,simpar,local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, & thermostats%thermostat_part%al, al_section=work_section,& - gci=gci, error=error) + gci=gci) ELSE IF (thermostats%thermostat_part%type_of_thermostat==do_thermo_gle) THEN ! Initialize or possibly restart GLE thermostat on Particles - work_section => section_vals_get_subs_vals(thermo_part_section,"GLE",error=error) + work_section => section_vals_get_subs_vals(thermo_part_section,"GLE") CALL initialize_gle_part(thermostats%thermostat_info_part,simpar,local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, & thermostats%thermostat_part%gle, gle_section=work_section,& - gci=gci,save_mem=save_mem, error=error) + gci=gci,save_mem=save_mem) END IF CALL thermostat_info(thermostats%thermostat_part, "PARTICLES", thermo_part_section, & - simpar, para_env, error) + simpar, para_env) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "Thermostat for Particles has been defined but the ensemble provided "//& @@ -299,7 +295,7 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & END IF ! Core-Shell Model - CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, error=error) + CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds) CALL get_atomic_kind_set(atomic_kind_set=atomic_kinds%els,shell_present=shell_present) IF (shell_present) THEN IF (explicit_shell) THEN @@ -307,33 +303,31 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & ! It can be used to thermalize the shell-core motion when the temperature is not constant (nve, npe) IF (apply_thermo_shell) THEN CALL create_thermostat_type(thermostats%thermostat_shell, simpar, thermo_shell_section,& - label="SHELL", error=error) + label="SHELL") CALL get_atomic_kind_set(atomic_kind_set=atomic_kinds%els, shell_adiabatic=shell_adiabatic) - region_sections => section_vals_get_subs_vals(thermo_shell_section,"DEFINE_REGION",error=error) - CALL section_vals_val_get(thermo_shell_section,"REGION",i_val=region,error=error) + region_sections => section_vals_get_subs_vals(thermo_shell_section,"DEFINE_REGION") + CALL section_vals_val_get(thermo_shell_section,"REGION",i_val=region) CALL setup_thermostat_info(thermostats%thermostat_info_shell, molecule_kinds_new%els,& local_molecules, molecules_new, particles, region, simpar%ensemble, shell=shell_adiabatic,& - region_sections=region_sections, qmmm_env=qmmm_env, error=error) + region_sections=region_sections, qmmm_env=qmmm_env) IF (shell_adiabatic) THEN ! Initialize thermostat IF (thermostats%thermostat_shell%type_of_thermostat == do_thermo_nose) THEN ! Initialize or possibly restart Nose on Shells - work_section => section_vals_get_subs_vals(thermo_shell_section,"NOSE",error=error) + work_section => section_vals_get_subs_vals(thermo_shell_section,"NOSE") CALL initialize_nhc_shell(thermostats%thermostat_info_shell, simpar, local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, globenv,& thermostats%thermostat_shell%nhc, nose_section=work_section,gci=gci,& - save_mem=save_mem, binary_restart_file_name=binary_restart_file_name,& - error=error) + save_mem=save_mem, binary_restart_file_name=binary_restart_file_name) ELSE IF (thermostats%thermostat_shell%type_of_thermostat==do_thermo_csvr) THEN ! Initialize or possibly restart CSVR thermostat on Shells - work_section => section_vals_get_subs_vals(thermo_shell_section,"CSVR",error=error) + work_section => section_vals_get_subs_vals(thermo_shell_section,"CSVR") CALL initialize_csvr_shell(thermostats%thermostat_info_shell, simpar, local_molecules,& molecules_new%els, molecule_kinds_new%els, para_env, & - thermostats%thermostat_shell%csvr, csvr_section=work_section, gci=gci,& - error=error) + thermostats%thermostat_shell%csvr, csvr_section=work_section, gci=gci) END IF CALL thermostat_info(thermostats%thermostat_shell, "CORE-SHELL", thermo_shell_section, & - simpar, para_env, error) + simpar, para_env) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "Thermostat for Core-Shell motion only with adiabatic shell-model. "//& @@ -341,8 +335,8 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & "applied to Shells!"//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL release_thermostat_type(thermostats%thermostat_shell, error) - CALL release_thermostat_info(thermostats%thermostat_info_shell, error) + CALL release_thermostat_type(thermostats%thermostat_shell) + CALL release_thermostat_info(thermostats%thermostat_info_shell) END IF ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& @@ -363,39 +357,39 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & ! Barostat Temperature (not necessarily to be controlled by a thermostat) IF (explicit_barostat_section) THEN simpar%temp_baro_ext = simpar%temp_ext - CALL section_vals_val_get(md_section,"BAROSTAT%TEMPERATURE",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(md_section,"BAROSTAT%TEMPERATURE",n_rep_val=n_rep) IF (n_rep/=0) THEN - CALL section_vals_val_get(md_section,"BAROSTAT%TEMPERATURE",r_val=simpar%temp_baro_ext,error=error) - CPPostcondition(simpar%temp_baro_ext>=0.0_dp,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(md_section,"BAROSTAT%TEMPERATURE",r_val=simpar%temp_baro_ext) + CPPostcondition(simpar%temp_baro_ext>=0.0_dp,cp_failure_level,routineP,failure) END IF ! Setup Barostat Thermostat IF (apply_thermo_baro) THEN ! Check if we use the same thermostat as particles - CALL section_vals_val_get(thermo_baro_section,"TYPE",i_val=thermostat_type,error=error) + CALL section_vals_val_get(thermo_baro_section,"TYPE",i_val=thermostat_type) work_section => thermo_baro_section IF (thermostat_type==do_thermo_same_as_part) work_section => thermo_part_section CALL create_thermostat_type(thermostats%thermostat_baro, simpar, work_section, skip_region=.TRUE.,& - label="BAROSTAT", error=error) + label="BAROSTAT") ! Initialize thermostat IF (thermostats%thermostat_baro%type_of_thermostat==do_thermo_nose) THEN ! Initialize or possibly restart Nose on Barostat - work_section => section_vals_get_subs_vals(thermo_baro_section,"NOSE",error=error) + work_section => section_vals_get_subs_vals(thermo_baro_section,"NOSE") CALL initialize_nhc_baro(simpar, para_env, globenv, thermostats%thermostat_baro%nhc,& - nose_section=work_section, save_mem=save_mem, error=error) + nose_section=work_section, save_mem=save_mem) ELSE IF (thermostats%thermostat_baro%type_of_thermostat==do_thermo_csvr) THEN ! Initialize or possibly restart CSVR thermostat on Barostat - work_section => section_vals_get_subs_vals(thermo_baro_section,"CSVR",error=error) + work_section => section_vals_get_subs_vals(thermo_baro_section,"CSVR") CALL initialize_csvr_baro(simpar, thermostats%thermostat_baro%csvr,& - csvr_section=work_section, error=error) + csvr_section=work_section) END IF CALL thermostat_info(thermostats%thermostat_baro, "BAROSTAT", thermo_baro_section,& - simpar, para_env, error) + simpar, para_env) ! If thermostat for barostat uses a diffent kind than the one of the particles ! let's update infos in the input structure.. IF (thermostat_type==do_thermo_same_as_part) THEN - CALL update_thermo_baro_section(thermostats%thermostat_baro, thermo_baro_section, error) + CALL update_thermo_baro_section(thermostats%thermostat_baro, thermo_baro_section) END IF ELSE IF (explicit_baro) THEN @@ -406,13 +400,13 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & only_ionode=.TRUE.) END IF ! Let's remove the section - CALL section_vals_remove_values(thermo_baro_section, error) + CALL section_vals_remove_values(thermo_baro_section) END IF END IF ! Release the thermostats info.. - CALL release_thermostat_info(thermostats%thermostat_info_part, error) - CALL release_thermostat_info(thermostats%thermostat_info_shell, error) + CALL release_thermostat_info(thermostats%thermostat_info_part) + CALL release_thermostat_info(thermostats%thermostat_info_shell) ENDIF ! Adiabitic_NVT screening ! If no thermostats have been allocated deallocate the full structure @@ -421,7 +415,7 @@ SUBROUTINE create_thermostats(thermostats, md_section, force_env, simpar, & (.NOT.ASSOCIATED(thermostats%thermostat_baro)).AND.& (.NOT.ASSOCIATED(thermostats%thermostat_fast)).AND.& (.NOT.ASSOCIATED(thermostats%thermostat_slow)) ) THEN - CALL release_thermostats(thermostats, error) + CALL release_thermostats(thermostats) END IF END SUBROUTINE create_thermostats @@ -430,37 +424,34 @@ END SUBROUTINE create_thermostats !> \brief ... !> \param thermostat ... !> \param section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE update_thermo_baro_section(thermostat, section, error) + SUBROUTINE update_thermo_baro_section(thermostat, section) TYPE(thermostat_type), POINTER :: thermostat TYPE(section_vals_type), POINTER :: section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_thermo_baro_section', & routineP = moduleN//':'//routineN TYPE(section_vals_type), POINTER :: work_section - CALL section_vals_val_set(section,"TYPE",i_val=thermostat%type_of_thermostat,error=error) + CALL section_vals_val_set(section,"TYPE",i_val=thermostat%type_of_thermostat) SELECT CASE(thermostat%type_of_thermostat) CASE(do_thermo_nose) - work_section => section_vals_get_subs_vals(section,"NOSE",error=error) - CALL section_vals_val_set(work_section,"LENGTH",i_val=thermostat%nhc%nhc_len,error=error) - CALL section_vals_val_set(work_section,"YOSHIDA",i_val=thermostat%nhc%nyosh,error=error) - CALL section_vals_val_set(work_section,"TIMECON",r_val=thermostat%nhc%tau_nhc,error=error) - CALL section_vals_val_set(work_section,"MTS",i_val=thermostat%nhc%nc,error=error) + work_section => section_vals_get_subs_vals(section,"NOSE") + CALL section_vals_val_set(work_section,"LENGTH",i_val=thermostat%nhc%nhc_len) + CALL section_vals_val_set(work_section,"YOSHIDA",i_val=thermostat%nhc%nyosh) + CALL section_vals_val_set(work_section,"TIMECON",r_val=thermostat%nhc%tau_nhc) + CALL section_vals_val_set(work_section,"MTS",i_val=thermostat%nhc%nc) CASE(do_thermo_csvr) - work_section => section_vals_get_subs_vals(section,"CSVR",error=error) - CALL section_vals_val_set(work_section,"TIMECON",r_val=thermostat%csvr%tau_csvr,error=error) + work_section => section_vals_get_subs_vals(section,"CSVR") + CALL section_vals_val_set(work_section,"TIMECON",r_val=thermostat%csvr%tau_csvr) CASE(do_thermo_al) - work_section => section_vals_get_subs_vals(section,"AD_LANGEVIN",error=error) - CALL section_vals_val_set(work_section,"TIMECON_NH",r_val=thermostat%al%tau_nh,error=error) - CALL section_vals_val_set(work_section,"TIMECON_LANGEVIN",r_val=thermostat%al%tau_langevin,error=error) + work_section => section_vals_get_subs_vals(section,"AD_LANGEVIN") + CALL section_vals_val_set(work_section,"TIMECON_NH",r_val=thermostat%al%tau_nh) + CALL section_vals_val_set(work_section,"TIMECON_LANGEVIN",r_val=thermostat%al%tau_langevin) END SELECT END SUBROUTINE update_thermo_baro_section @@ -471,19 +462,16 @@ END SUBROUTINE update_thermo_baro_section !> \param section ... !> \param simpar ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE thermostat_info(thermostat, label, section, simpar, para_env, error) + SUBROUTINE thermostat_info(thermostat, label, section, simpar, para_env) TYPE(thermostat_type), POINTER :: thermostat CHARACTER(LEN=*), INTENT(IN) :: label TYPE(section_vals_type), POINTER :: section TYPE(simpar_type), POINTER :: simpar TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'thermostat_info', & routineP = moduleN//':'//routineN @@ -495,17 +483,17 @@ SUBROUTINE thermostat_info(thermostat, label, section, simpar, para_env, error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) - iw=cp_print_key_unit_nr(logger,section,"PRINT%THERMOSTAT_INFO",extension=".log",error=error) + logger => cp_get_default_logger() + iw=cp_print_key_unit_nr(logger,section,"PRINT%THERMOSTAT_INFO",extension=".log") ! Total Tehrmostat Energy - CALL get_thermostat_energies(thermostat, pot_energy, kin_energy, para_env, error=error) + CALL get_thermostat_energies(thermostat, pot_energy, kin_energy, para_env) IF (iw>0) THEN WRITE ( iw, '( /,A )' ) ' THERMOSTAT| Thermostat Info for '//TRIM(label) SELECT CASE(thermostat%type_of_thermostat) CASE(do_thermo_nose) WRITE ( iw, '( A,T63,A )' ) ' THERMOSTAT| Type of thermostat','Nose-Hoover-Chains' WRITE ( iw, '( A,T77,I4 )' ) ' THERMOSTAT| Nose-Hoover-Chain length ', thermostat%nhc%nhc_len - tmp = cp_unit_from_cp2k(thermostat%nhc%tau_nhc,"fs",error=error) + tmp = cp_unit_from_cp2k(thermostat%nhc%tau_nhc,"fs") WRITE ( iw, '( A,A4,A,T71,F10.2 )' ) & ' THERMOSTAT| Nose-Hoover-Chain time constant [', 'fs' ,'] ',tmp WRITE ( iw, '( A,T77,I4 )' ) ' THERMOSTAT| Order of Yoshida integrator ', & @@ -518,23 +506,23 @@ SUBROUTINE thermostat_info(thermostat, label, section, simpar, para_env, error) kin_energy CASE(do_thermo_csvr) WRITE ( iw, '( A,T44,A )' ) ' THERMOSTAT| Type of thermostat','Canonical Sampling/Velocity Rescaling' - tmp = cp_unit_from_cp2k(thermostat%csvr%tau_csvr,"fs",error=error)*0.5_dp*simpar%dt + tmp = cp_unit_from_cp2k(thermostat%csvr%tau_csvr,"fs")*0.5_dp*simpar%dt WRITE ( iw, '( A,A4,A,T71,F10.2 )' ) & ' THERMOSTAT| CSVR time constant [', 'fs' ,'] ',tmp WRITE ( iw, '( A,T69,F12.6 )' ) & ' THERMOSTAT| Initial Kinetic Energy ',kin_energy CASE(do_thermo_al) WRITE ( iw, '( A,T44,A )' ) ' THERMOSTAT| Type of thermostat','Adaptive Langevin' - tmp = cp_unit_from_cp2k(thermostat%al%tau_nh,"fs",error=error) + tmp = cp_unit_from_cp2k(thermostat%al%tau_nh,"fs") WRITE ( iw, '( A,A4,A,T71,F10.2 )' ) & ' THERMOSTAT| AD_LANGEVIN NH time constant [', 'fs' ,'] ',tmp - tmp = cp_unit_from_cp2k(thermostat%al%tau_langevin,"fs",error=error) + tmp = cp_unit_from_cp2k(thermostat%al%tau_langevin,"fs") WRITE ( iw, '( A,A4,A,T71,F10.2 )' ) & ' THERMOSTAT| AD_LANGEVIN Langevin time constant [', 'fs' ,'] ',tmp END SELECT WRITE ( iw, '( A,/ )' ) ' THERMOSTAT| End of Thermostat Info for '//TRIM(label) END IF - CALL cp_print_key_finished_output(iw,logger,section,"PRINT%THERMOSTAT_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,section,"PRINT%THERMOSTAT_INFO") END SUBROUTINE thermostat_info @@ -543,18 +531,15 @@ END SUBROUTINE thermostat_info !> \param thermostat ... !> \param npt ... !> \param group ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE apply_thermostat_baro(thermostat, npt, group, error) + SUBROUTINE apply_thermostat_baro(thermostat, npt, group) TYPE(thermostat_type), POINTER :: thermostat TYPE(npt_info_type), DIMENSION(:, :), & POINTER :: npt INTEGER, INTENT(IN) :: group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_thermostat_baro', & routineP = moduleN//':'//routineN @@ -565,12 +550,12 @@ SUBROUTINE apply_thermostat_baro(thermostat, npt, group, error) IF (ASSOCIATED(thermostat)) THEN IF (thermostat%type_of_thermostat==do_thermo_nose) THEN ! Apply Nose-Hoover Thermostat - CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,error,failure) - CALL lnhc_barostat ( thermostat%nhc, npt, group, error ) + CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,failure) + CALL lnhc_barostat ( thermostat%nhc, npt, group) ELSE IF (thermostat%type_of_thermostat==do_thermo_csvr) THEN ! Apply CSVR Thermostat - CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,error,failure) - CALL csvr_barostat ( thermostat%csvr, npt, group, error ) + CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,failure) + CALL csvr_barostat ( thermostat%csvr, npt, group) END IF END IF END SUBROUTINE apply_thermostat_baro @@ -591,15 +576,13 @@ END SUBROUTINE apply_thermostat_baro !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE apply_thermostat_particles(thermostat, force_env, molecule_kind_set, molecule_set,& particle_set, local_molecules, local_particles, group, shell_adiabatic, shell_particle_set,& - core_particle_set, vel, shell_vel, core_vel, error) + core_particle_set, vel, shell_vel, core_vel) TYPE(thermostat_type), POINTER :: thermostat TYPE(force_env_type), POINTER :: force_env @@ -614,7 +597,6 @@ SUBROUTINE apply_thermostat_particles(thermostat, force_env, molecule_kind_set, core_particle_set( : ) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_thermostat_particles', & routineP = moduleN//':'//routineN @@ -625,27 +607,27 @@ SUBROUTINE apply_thermostat_particles(thermostat, force_env, molecule_kind_set, IF (ASSOCIATED(thermostat)) THEN IF (thermostat%type_of_thermostat==do_thermo_nose) THEN ! Apply Nose-Hoover Thermostat - CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,failure) CALL lnhc_particles(thermostat%nhc,molecule_kind_set,molecule_set,& particle_set,local_molecules,group,shell_adiabatic,shell_particle_set,& - core_particle_set, vel, shell_vel, core_vel, error) + core_particle_set, vel, shell_vel, core_vel) ELSE IF (thermostat%type_of_thermostat==do_thermo_csvr) THEN ! Apply CSVR Thermostat - CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,failure) CALL csvr_particles(thermostat%csvr,molecule_kind_set,molecule_set,& particle_set,local_molecules,group,shell_adiabatic,shell_particle_set,& - core_particle_set, vel, shell_vel, core_vel, error) + core_particle_set, vel, shell_vel, core_vel) ELSE IF (thermostat%type_of_thermostat==do_thermo_al) THEN ! Apply AD_LANGEVIN Thermostat - CPPostcondition(ASSOCIATED(thermostat%al),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%al),cp_failure_level,routineP,failure) CALL al_particles(thermostat%al,force_env,molecule_kind_set,molecule_set,& - particle_set,local_molecules, local_particles, group, vel, error) + particle_set,local_molecules, local_particles, group, vel) ELSE IF (thermostat%type_of_thermostat==do_thermo_gle) THEN ! Apply GLE Thermostat - CPPostcondition(ASSOCIATED(thermostat%gle),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%gle),cp_failure_level,routineP,failure) CALL gle_particles(thermostat%gle,molecule_kind_set,molecule_set,& particle_set,local_molecules,group,shell_adiabatic,shell_particle_set,& - core_particle_set, vel, shell_vel, core_vel, error=error) + core_particle_set, vel, shell_vel, core_vel) END IF END IF END SUBROUTINE apply_thermostat_particles @@ -662,15 +644,13 @@ END SUBROUTINE apply_thermostat_particles !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE apply_thermostat_shells(thermostat,atomic_kind_set, particle_set,& local_particles, group, shell_particle_set, core_particle_set, vel, shell_vel,& - core_vel, error) + core_vel) TYPE(thermostat_type), POINTER :: thermostat TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) @@ -681,7 +661,6 @@ SUBROUTINE apply_thermostat_shells(thermostat,atomic_kind_set, particle_set,& core_particle_set(:) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_thermostat_shells', & routineP = moduleN//':'//routineN @@ -692,14 +671,14 @@ SUBROUTINE apply_thermostat_shells(thermostat,atomic_kind_set, particle_set,& IF (ASSOCIATED(thermostat)) THEN IF (thermostat%type_of_thermostat==do_thermo_nose) THEN ! Apply Nose-Hoover Thermostat - CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,failure) CALL lnhc_shells(thermostat%nhc, atomic_kind_set, particle_set, local_particles, & - group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel, error) + group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel) ELSE IF (thermostat%type_of_thermostat==do_thermo_csvr) THEN ! Apply CSVR Thermostat - CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,failure) CALL csvr_shells(thermostat%csvr, atomic_kind_set, particle_set, local_particles, & - group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel, error) + group, shell_particle_set, core_particle_set, vel, shell_vel, core_vel) END IF END IF END SUBROUTINE apply_thermostat_shells diff --git a/src/motion/thermostat/thermostat_types.F b/src/motion/thermostat/thermostat_types.F index 82bd6c1752..85b23a208c 100644 --- a/src/motion/thermostat/thermostat_types.F +++ b/src/motion/thermostat/thermostat_types.F @@ -102,15 +102,12 @@ MODULE thermostat_types ! ***************************************************************************** !> \brief ... !> \param thermostats ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE allocate_thermostats(thermostats, error ) + SUBROUTINE allocate_thermostats(thermostats) TYPE(thermostats_type), POINTER :: thermostats - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_thermostats', & routineP = moduleN//':'//routineN @@ -120,25 +117,25 @@ SUBROUTINE allocate_thermostats(thermostats, error ) failure =.FALSE. check = .NOT.ASSOCIATED(thermostats) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) ! Preliminary allocation for thermostats ALLOCATE(thermostats, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_thermostats_id_nr = last_thermostats_id_nr + 1 thermostats%id_nr = last_thermostats_id_nr thermostats%ref_count = 1 ! Thermostats Info ALLOCATE(thermostats%thermostat_info_part, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(thermostats%thermostat_info_shell, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !cjm ALLOCATE(thermostats%thermostat_info_fast, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(thermostats%thermostat_info_slow, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !cjm NULLIFY(thermostats%thermostat_info_part%map_loc_thermo_gen) @@ -159,14 +156,12 @@ END SUBROUTINE allocate_thermostats ! ***************************************************************************** !> \brief retains the full set of thermostats !> \param thermostats ... -!> \param error ... !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE retain_thermostats(thermostats,error) + SUBROUTINE retain_thermostats(thermostats) TYPE(thermostats_type), POINTER :: thermostats - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_thermostats', & routineP = moduleN//':'//routineN @@ -176,7 +171,7 @@ SUBROUTINE retain_thermostats(thermostats,error) failure=.FALSE. IF (ASSOCIATED(thermostats)) THEN - CPPrecondition(thermostats%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(thermostats%ref_count>0,cp_failure_level,routineP,failure) thermostats%ref_count=thermostats%ref_count+1 END IF @@ -185,15 +180,12 @@ END SUBROUTINE retain_thermostats ! ***************************************************************************** !> \brief ... !> \param thermostats ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE release_thermostats(thermostats, error) + SUBROUTINE release_thermostats(thermostats) TYPE(thermostats_type), POINTER :: thermostats - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_thermostats', & routineP = moduleN//':'//routineN @@ -205,35 +197,35 @@ SUBROUTINE release_thermostats(thermostats, error) check = ASSOCIATED(thermostats) IF (check) THEN check = thermostats%ref_count>0 - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) thermostats%ref_count=thermostats%ref_count-1 IF (thermostats%ref_count<1) THEN - CALL release_thermostat_info(thermostats%thermostat_info_part, error) - CALL release_thermostat_info(thermostats%thermostat_info_shell, error) + CALL release_thermostat_info(thermostats%thermostat_info_part) + CALL release_thermostat_info(thermostats%thermostat_info_shell) !cjm - CALL release_thermostat_info(thermostats%thermostat_info_fast, error) - CALL release_thermostat_info(thermostats%thermostat_info_slow, error) + CALL release_thermostat_info(thermostats%thermostat_info_fast) + CALL release_thermostat_info(thermostats%thermostat_info_slow) IF (ASSOCIATED(thermostats%thermostat_fast)) THEN - CALL release_thermostat_type(thermostats%thermostat_fast, error) + CALL release_thermostat_type(thermostats%thermostat_fast) END IF IF (ASSOCIATED(thermostats%thermostat_slow)) THEN - CALL release_thermostat_type(thermostats%thermostat_slow, error) + CALL release_thermostat_type(thermostats%thermostat_slow) END IF !cjm IF (ASSOCIATED(thermostats%thermostat_part)) THEN - CALL release_thermostat_type(thermostats%thermostat_part, error) + CALL release_thermostat_type(thermostats%thermostat_part) END IF IF (ASSOCIATED(thermostats%thermostat_shell)) THEN - CALL release_thermostat_type(thermostats%thermostat_shell, error) + CALL release_thermostat_type(thermostats%thermostat_shell) END IF IF (ASSOCIATED(thermostats%thermostat_baro)) THEN - CALL release_thermostat_type(thermostats%thermostat_baro, error) + CALL release_thermostat_type(thermostats%thermostat_baro) END IF IF (ASSOCIATED(thermostats%thermostat_coef)) THEN - CALL release_thermostat_type(thermostats%thermostat_coef, error) + CALL release_thermostat_type(thermostats%thermostat_coef) END IF DEALLOCATE(thermostats, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END SUBROUTINE release_thermostats @@ -245,18 +237,16 @@ END SUBROUTINE release_thermostats !> \param section ... !> \param skip_region ... !> \param label ... -!> \param error ... !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE create_thermostat_type(thermostat, simpar, section, skip_region, label, error) + SUBROUTINE create_thermostat_type(thermostat, simpar, section, skip_region, label) TYPE(thermostat_type), POINTER :: thermostat TYPE(simpar_type), POINTER :: simpar TYPE(section_vals_type), POINTER :: section LOGICAL, INTENT(IN), OPTIONAL :: skip_region CHARACTER(LEN=*), INTENT(IN) :: label - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_thermostat_type', & routineP = moduleN//':'//routineN @@ -270,7 +260,7 @@ SUBROUTINE create_thermostat_type(thermostat, simpar, section, skip_region, labe skip_region_loc = .FALSE. IF (PRESENT(skip_region)) skip_region_loc = skip_region ALLOCATE(thermostat, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_thermostat_id_nr = last_thermostat_id_nr + 1 thermostat%id_nr = last_thermostat_id_nr thermostat%ref_count = 1 @@ -282,34 +272,34 @@ SUBROUTINE create_thermostat_type(thermostat, simpar, section, skip_region, labe NULLIFY(thermostat%csvr) NULLIFY(thermostat%al) NULLIFY(thermostat%gle) - CALL section_vals_val_get(section,"TYPE",i_val=thermostat%type_of_thermostat,error=error) - IF (.NOT.skip_region_loc) CALL section_vals_val_get(section,"REGION",i_val=region,error=error) + CALL section_vals_val_get(section,"TYPE",i_val=thermostat%type_of_thermostat) + IF (.NOT.skip_region_loc) CALL section_vals_val_get(section,"REGION",i_val=region) IF (thermostat%type_of_thermostat==do_thermo_nose) THEN - nose_section => section_vals_get_subs_vals(section,"NOSE",error=error) + nose_section => section_vals_get_subs_vals(section,"NOSE") ALLOCATE(thermostat%nhc, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL lnhc_init(thermostat%nhc, nose_section, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL lnhc_init(thermostat%nhc, nose_section) thermostat%nhc%region = region ELSE IF (thermostat%type_of_thermostat==do_thermo_csvr) THEN - csvr_section => section_vals_get_subs_vals(section,"CSVR",error=error) + csvr_section => section_vals_get_subs_vals(section,"CSVR") ALLOCATE(thermostat%csvr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL csvr_init(thermostat%csvr, simpar, csvr_section, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL csvr_init(thermostat%csvr, simpar, csvr_section) thermostat%csvr%region=region ELSE IF (thermostat%type_of_thermostat==do_thermo_al) THEN - al_section => section_vals_get_subs_vals(section,"AD_LANGEVIN",error=error) + al_section => section_vals_get_subs_vals(section,"AD_LANGEVIN") ALLOCATE(thermostat%al, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL al_init(thermostat%al, simpar, al_section, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL al_init(thermostat%al, simpar, al_section) thermostat%al%region=region ELSE IF (thermostat%type_of_thermostat==do_thermo_gle) THEN - gle_section => section_vals_get_subs_vals(section,"GLE",error=error) + gle_section => section_vals_get_subs_vals(section,"GLE") ALLOCATE(thermostat%gle, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL gle_init(thermostat%gle, dt=simpar%dt, temp=simpar%temp_ext, & - section=gle_section, error=error) + section=gle_section) thermostat%gle%region=region - CPPostcondition(region==do_region_massive,cp_failure_level,routineP,error,failure) + CPPostcondition(region==do_region_massive,cp_failure_level,routineP,failure) END IF END SUBROUTINE create_thermostat_type @@ -317,15 +307,12 @@ END SUBROUTINE create_thermostat_type ! ***************************************************************************** !> \brief ... !> \param thermostat_info ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE release_thermostat_info(thermostat_info, error) + SUBROUTINE release_thermostat_info(thermostat_info) TYPE(thermostat_info_type), POINTER :: thermostat_info - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_thermostat_info', & routineP = moduleN//':'//routineN @@ -337,25 +324,22 @@ SUBROUTINE release_thermostat_info(thermostat_info, error) IF (ASSOCIATED(thermostat_info)) THEN IF (ASSOCIATED(thermostat_info%map_loc_thermo_gen)) THEN DEALLOCATE(thermostat_info%map_loc_thermo_gen, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(thermostat_info, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE release_thermostat_info ! ***************************************************************************** !> \brief ... !> \param thermostat ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE release_thermostat_type(thermostat, error) + SUBROUTINE release_thermostat_type(thermostat) TYPE(thermostat_type), POINTER :: thermostat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_thermostat_type', & routineP = moduleN//':'//routineN @@ -367,24 +351,24 @@ SUBROUTINE release_thermostat_type(thermostat, error) check = ASSOCIATED(thermostat) IF (check) THEN check = thermostat%ref_count>0 - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) thermostat%ref_count=thermostat%ref_count-1 IF (thermostat%ref_count<1) THEN NULLIFY(thermostat%section) IF (ASSOCIATED(thermostat%nhc)) THEN - CALL lnhc_dealloc(thermostat%nhc,error=error) + CALL lnhc_dealloc(thermostat%nhc) END IF IF (ASSOCIATED(thermostat%csvr)) THEN - CALL csvr_dealloc(thermostat%csvr,error=error) + CALL csvr_dealloc(thermostat%csvr) END IF IF (ASSOCIATED(thermostat%al)) THEN - CALL al_dealloc(thermostat%al,error=error) + CALL al_dealloc(thermostat%al) END IF IF (ASSOCIATED(thermostat%gle)) THEN - CALL gle_dealloc(thermostat%gle,error=error) + CALL gle_dealloc(thermostat%gle) END IF DEALLOCATE(thermostat, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END SUBROUTINE release_thermostat_type @@ -393,15 +377,13 @@ END SUBROUTINE release_thermostat_type !> \brief access internal structures of thermostats !> \param thermostats ... !> \param dt_fact ... -!> \param error ... !> \par History !> 10.2008 created [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE set_thermostats(thermostats, dt_fact, error) + SUBROUTINE set_thermostats(thermostats, dt_fact) TYPE(thermostats_type), POINTER :: thermostats REAL(KIND=dp), INTENT(IN), OPTIONAL :: dt_fact - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_thermostats', & routineP = moduleN//':'//routineN diff --git a/src/motion/thermostat/thermostat_utils.F b/src/motion/thermostat/thermostat_utils.F index 425efa2621..86c6a2da34 100644 --- a/src/motion/thermostat/thermostat_utils.F +++ b/src/motion/thermostat/thermostat_utils.F @@ -90,11 +90,10 @@ MODULE thermostat_utils !> \param print_section ... !> \param particles ... !> \param gci ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE compute_nfree ( cell, simpar, molecule_kind_set,& - print_section,particles, gci, error) + print_section,particles, gci) TYPE(cell_type), POINTER :: cell TYPE(simpar_type), POINTER :: simpar @@ -102,7 +101,6 @@ SUBROUTINE compute_nfree ( cell, simpar, molecule_kind_set,& TYPE(section_vals_type), POINTER :: print_section TYPE(particle_list_type), POINTER :: particles TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_nfree', & routineP = moduleN//':'//routineN @@ -121,7 +119,7 @@ SUBROUTINE compute_nfree ( cell, simpar, molecule_kind_set,& ! Compute degrees of freedom CALL rot_ana(particles%els, dof=roto_trasl_dof, rot_dof=rot_dof, & print_section=print_section, keep_rotations=.FALSE.,& - mass_weighted=.TRUE., natoms=natom, error=error) + mass_weighted=.TRUE., natoms=natom) roto_trasl_dof = roto_trasl_dof - MIN(SUM(cell%perd(1:3)),rot_dof) @@ -148,12 +146,11 @@ END SUBROUTINE compute_nfree !> \param gci ... !> \param region ... !> \param qmmm_env ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE compute_degrees_of_freedom ( thermostats, cell, simpar, molecule_kind_set,& local_molecules, molecules, particles, print_section, region_sections, gci,& - region, qmmm_env, error) + region, qmmm_env) TYPE(thermostats_type), POINTER :: thermostats TYPE(cell_type), POINTER :: cell @@ -166,7 +163,6 @@ SUBROUTINE compute_degrees_of_freedom ( thermostats, cell, simpar, molecule_kind TYPE(global_constraint_type), POINTER :: gci INTEGER, INTENT(IN) :: region TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_degrees_of_freedom', & routineP = moduleN//':'//routineN @@ -186,14 +182,14 @@ SUBROUTINE compute_degrees_of_freedom ( thermostats, cell, simpar, molecule_kind ! Compute degrees of freedom CALL rot_ana(particles%els, dof=roto_trasl_dof, rot_dof=rot_dof, & print_section=print_section, keep_rotations=.FALSE.,& - mass_weighted=.TRUE., natoms=natom, error=error) + mass_weighted=.TRUE., natoms=natom) roto_trasl_dof = roto_trasl_dof - MIN(SUM(cell%perd(1:3)),rot_dof) ! Collect info about thermostats CALL setup_thermostat_info(thermostats%thermostat_info_part, molecule_kind_set,& local_molecules, molecules, particles, region, simpar%ensemble, roto_trasl_dof, & - region_sections=region_sections, qmmm_env=qmmm_env, error=error) + region_sections=region_sections, qmmm_env=qmmm_env) ! Saving this value of simpar preliminar to the real count of constraints.. simpar%nfree_rot_transl = roto_trasl_dof @@ -202,9 +198,9 @@ SUBROUTINE compute_degrees_of_freedom ( thermostats, cell, simpar, molecule_kind nconstraint_ext = gci%ntot - gci%nrestraint simpar%nfree = 3*natom - nconstraint_int - nconstraint_ext - roto_trasl_dof - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") IF ( iw > 0 ) THEN WRITE ( iw, '( /, A )' ) ' Calculation of degrees of freedom' WRITE ( iw, '( T48, A, T71, I10 )' ) ' Number of atoms:', natom @@ -223,7 +219,7 @@ SUBROUTINE compute_degrees_of_freedom ( thermostats, cell, simpar, molecule_kind ' Number of Intermolecular restraints:', gci%nrestraint END IF CALL cp_print_key_finished_output(iw,logger,print_section,& - "PROGRAM_RUN_INFO", error=error) + "PROGRAM_RUN_INFO") END SUBROUTINE compute_degrees_of_freedom @@ -240,12 +236,10 @@ END SUBROUTINE compute_degrees_of_freedom !> \param shell ... !> \param region_sections ... !> \param qmmm_env ... -!> \param error ... !> \author 10.2011 CJM - PNNL ! ***************************************************************************** SUBROUTINE setup_adiabatic_thermostat_info(thermostat_info, molecule_kind_set, local_molecules,& - molecules, particles, region, ensemble, nfree, shell, region_sections, qmmm_env,& - error) + molecules, particles, region, ensemble, nfree, shell, region_sections, qmmm_env) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(molecule_kind_type), POINTER :: molecule_kind_set(:) TYPE(distribution_1d_type), POINTER :: local_molecules @@ -256,7 +250,6 @@ SUBROUTINE setup_adiabatic_thermostat_info(thermostat_info, molecule_kind_set, l LOGICAL, INTENT(IN), OPTIONAL :: shell TYPE(section_vals_type), POINTER :: region_sections TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'setup_adiabatic_thermostat_info', & @@ -288,7 +281,7 @@ SUBROUTINE setup_adiabatic_thermostat_info(thermostat_info, molecule_kind_set, l CALL get_adiabatic_region_info(region_sections, sum_of_thermostats,& thermolist=thermolist,& molecule_kind_set=molecule_kind_set,& - molecules=molecules, particles=particles, qmmm_env=qmmm_env, error=error) + molecules=molecules, particles=particles, qmmm_env=qmmm_env) ! map_loc_thermo_gen=>thermostat_info%map_loc_thermo_gen molecule_set => molecules%els @@ -365,7 +358,7 @@ SUBROUTINE setup_adiabatic_thermostat_info(thermostat_info, molecule_kind_set, l ! Now map the local atoms with the corresponding thermostat ALLOCATE(thermostat_info%map_loc_thermo_gen(natom_local),stat=stat) thermostat_info%map_loc_thermo_gen = HUGE ( 0 ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) natom_local = 0 DO ikind = 1, SIZE(molecule_kind_set) nmol_per_kind = local_molecules%n_el(ikind) @@ -425,7 +418,7 @@ SUBROUTINE setup_adiabatic_thermostat_info(thermostat_info, molecule_kind_set, l thermostat_info%dis_type = dis_type DEALLOCATE(thermolist, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE setup_adiabatic_thermostat_info @@ -438,12 +431,11 @@ END SUBROUTINE setup_adiabatic_thermostat_info !> \param molecules ... !> \param particles ... !> \param qmmm_env ... -!> \param error ... !> \author 10.2011 CJM -PNNL ! ***************************************************************************** SUBROUTINE get_adiabatic_region_info(region_sections, sum_of_thermostats,& thermolist, molecule_kind_set, molecules, particles,& - qmmm_env, error) + qmmm_env) TYPE(section_vals_type), POINTER :: region_sections INTEGER, INTENT(INOUT), OPTIONAL :: sum_of_thermostats INTEGER, DIMENSION(:), POINTER :: thermolist( : ) @@ -451,7 +443,6 @@ SUBROUTINE get_adiabatic_region_info(region_sections, sum_of_thermostats,& TYPE(mol_new_list_type), POINTER :: molecules TYPE(particle_list_type), POINTER :: particles TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_adiabatic_region_info', & routineP = moduleN//':'//routineN @@ -471,34 +462,34 @@ SUBROUTINE get_adiabatic_region_info(region_sections, sum_of_thermostats,& failure = .FALSE. NULLIFY(tmplist, tmpstringlist, thermolist, molecule_kind, molecule, molecule_set) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) -! CPPostcondition(.NOT.(ASSOCIATED(map_loc_thermo_gen)),cp_failure_level,routineP,error,failure) - CALL section_vals_get(region_sections, n_repetition=nregions, error=error) +! CPPostcondition(.NOT.(ASSOCIATED(map_loc_thermo_gen)),cp_failure_level,routineP,failure) + CALL section_vals_get(region_sections, n_repetition=nregions) ALLOCATE(thermolist(particles%n_els), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) thermolist = HUGE(0) molecule_set => molecules%els mregions = nregions itherm = 0 DO ig = 1, mregions - CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig, n_rep_val=n_rep, error=error) + CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig, n_rep_val=n_rep) DO jg = 1, n_rep - CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig,i_rep_val=jg,i_vals=tmplist, error=error) + CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig,i_rep_val=jg,i_vals=tmplist) DO i = 1, SIZE(tmplist) ipart = tmplist(i) - CPPostcondition(((ipart>0).AND.(ipart<=particles%n_els)),cp_failure_level,routineP,error,failure) + CPPostcondition(((ipart>0).AND.(ipart<=particles%n_els)),cp_failure_level,routineP,failure) IF (thermolist(ipart)==HUGE(0)) THEN itherm = itherm + 1 thermolist(ipart) = itherm ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END DO - CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,n_rep_val=n_rep, error=error) + CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,n_rep_val=n_rep) DO jg = 1, n_rep - CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,i_rep_val=jg,c_vals=tmpstringlist, error=error) + CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,i_rep_val=jg,c_vals=tmpstringlist) DO ilist = 1, SIZE(tmpstringlist) DO ikind = 1, SIZE(molecule_kind_set) molecule_kind => molecule_kind_set(ikind) @@ -511,7 +502,7 @@ SUBROUTINE get_adiabatic_region_info(region_sections, sum_of_thermostats,& itherm = itherm + 1 thermolist(ipart) = itherm ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END DO @@ -520,14 +511,12 @@ SUBROUTINE get_adiabatic_region_info(region_sections, sum_of_thermostats,& END DO END DO CALL setup_thermostat_subsys(region_sections, qmmm_env, thermolist, molecule_set,& - subsys_qm=.FALSE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions,& - error=error) + subsys_qm=.FALSE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions) CALL setup_thermostat_subsys(region_sections, qmmm_env, thermolist, molecule_set,& - subsys_qm=.TRUE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions,& - error=error) + subsys_qm=.TRUE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions) END DO - CPPostcondition(.NOT.ALL(thermolist==HUGE(0)),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ALL(thermolist==HUGE(0)),cp_failure_level,routineP,failure) ! natom_local = 0 ! DO ikind = 1, SIZE(molecule_kind_set) @@ -545,7 +534,7 @@ SUBROUTINE get_adiabatic_region_info(region_sections, sum_of_thermostats,& ! Now map the local atoms with the corresponding thermostat ! ALLOCATE(map_loc_thermo_gen(natom_local),stat=stat) ! map_loc_thermo_gen = HUGE ( 0 ) -! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) +! CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! natom_local = 0 ! DO ikind = 1, SIZE(molecule_kind_set) ! nmol_per_kind = local_molecules%n_el(ikind) @@ -563,7 +552,7 @@ SUBROUTINE get_adiabatic_region_info(region_sections, sum_of_thermostats,& ! END DO ! DEALLOCATE(thermolist, stat=stat) -! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) +! CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE get_adiabatic_region_info ! ***************************************************************************** !> \brief ... @@ -578,12 +567,10 @@ END SUBROUTINE get_adiabatic_region_info !> \param shell ... !> \param region_sections ... !> \param qmmm_env ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE setup_thermostat_info(thermostat_info, molecule_kind_set, local_molecules,& - molecules, particles, region, ensemble, nfree, shell, region_sections, qmmm_env,& - error) + molecules, particles, region, ensemble, nfree, shell, region_sections, qmmm_env) TYPE(thermostat_info_type), POINTER :: thermostat_info TYPE(molecule_kind_type), POINTER :: molecule_kind_set(:) TYPE(distribution_1d_type), POINTER :: local_molecules @@ -594,7 +581,6 @@ SUBROUTINE setup_thermostat_info(thermostat_info, molecule_kind_set, local_molec LOGICAL, INTENT(IN), OPTIONAL :: shell TYPE(section_vals_type), POINTER :: region_sections TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_thermostat_info', & routineP = moduleN//':'//routineN @@ -659,11 +645,11 @@ SUBROUTINE setup_thermostat_info(thermostat_info, molecule_kind_set, local_molec ! User defined region to thermostat.. nointer = .FALSE. ! Determine the number of thermostats defined in the input - CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats, error=error) + CALL section_vals_get(region_sections, n_repetition=sum_of_thermostats) CALL cp_assert((sum_of_thermostats>=1),cp_failure_level,cp_assertion_failed,routineP,& "Provide at least 1 region (&DEFINE_REGION) when using the thermostat type DEFINED"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) END SELECT ! Here we decide which parallel algorithm to use. @@ -701,7 +687,7 @@ SUBROUTINE setup_thermostat_info(thermostat_info, molecule_kind_set, local_molec CALL get_defined_region_info(region_sections, number, sum_of_thermostats,& map_loc_thermo_gen=thermostat_info%map_loc_thermo_gen,& local_molecules=local_molecules, molecule_kind_set=molecule_kind_set,& - molecules=molecules, particles=particles, qmmm_env=qmmm_env, error=error) + molecules=molecules, particles=particles, qmmm_env=qmmm_env) END IF END IF @@ -731,12 +717,11 @@ END SUBROUTINE setup_thermostat_info !> \param molecules ... !> \param particles ... !> \param qmmm_env ... -!> \param error ... !> \author 11.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& map_loc_thermo_gen, local_molecules, molecule_kind_set, molecules, particles,& - qmmm_env, error) + qmmm_env) TYPE(section_vals_type), POINTER :: region_sections INTEGER, INTENT(OUT), OPTIONAL :: number INTEGER, INTENT(INOUT), OPTIONAL :: sum_of_thermostats @@ -746,7 +731,6 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& TYPE(mol_new_list_type), POINTER :: molecules TYPE(particle_list_type), POINTER :: particles TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_defined_region_info', & routineP = moduleN//':'//routineN @@ -766,32 +750,32 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& failure = .FALSE. NULLIFY(tmplist, tmpstringlist, thermolist, molecule_kind, molecule, molecule_set) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPostcondition(.NOT.(ASSOCIATED(map_loc_thermo_gen)),cp_failure_level,routineP,error,failure) - CALL section_vals_get(region_sections, n_repetition=nregions, error=error) + CPPostcondition(.NOT.(ASSOCIATED(map_loc_thermo_gen)),cp_failure_level,routineP,failure) + CALL section_vals_get(region_sections, n_repetition=nregions) ALLOCATE(thermolist(particles%n_els), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) thermolist = HUGE(0) molecule_set => molecules%els mregions = nregions DO ig = 1, mregions - CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig, n_rep_val=n_rep, error=error) + CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig, n_rep_val=n_rep) DO jg = 1, n_rep - CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig,i_rep_val=jg,i_vals=tmplist, error=error) + CALL section_vals_val_get(region_sections,"LIST", i_rep_section=ig,i_rep_val=jg,i_vals=tmplist) DO i = 1, SIZE(tmplist) ipart = tmplist(i) - CPPostcondition(((ipart>0).AND.(ipart<=particles%n_els)),cp_failure_level,routineP,error,failure) + CPPostcondition(((ipart>0).AND.(ipart<=particles%n_els)),cp_failure_level,routineP,failure) IF (thermolist(ipart)==HUGE(0)) THEN thermolist(ipart) = ig ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END DO - CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,n_rep_val=n_rep, error=error) + CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,n_rep_val=n_rep) DO jg = 1, n_rep - CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,i_rep_val=jg,c_vals=tmpstringlist, error=error) + CALL section_vals_val_get(region_sections,"MOLNAME", i_rep_section=ig,i_rep_val=jg,c_vals=tmpstringlist) DO ilist = 1, SIZE(tmpstringlist) DO ikind = 1, SIZE(molecule_kind_set) molecule_kind => molecule_kind_set(ikind) @@ -803,7 +787,7 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& IF (thermolist(ipart)==HUGE(0)) THEN thermolist(ipart) = ig ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END DO @@ -812,11 +796,9 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& END DO END DO CALL setup_thermostat_subsys(region_sections, qmmm_env, thermolist, molecule_set,& - subsys_qm=.FALSE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions,& - error=error) + subsys_qm=.FALSE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions) CALL setup_thermostat_subsys(region_sections, qmmm_env, thermolist, molecule_set,& - subsys_qm=.TRUE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions,& - error=error) + subsys_qm=.TRUE., ig=ig, sum_of_thermostats=sum_of_thermostats, nregions=nregions) END DO ! Dump IO warning for not thermalized particles @@ -824,7 +806,7 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& nregions = nregions + 1 sum_of_thermostats = sum_of_thermostats + 1 ALLOCATE(tmp(COUNT(thermolist==HUGE(0))),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ilist = 0 DO i = 1, SIZE(thermolist) IF (thermolist(i)==HUGE(0)) THEN @@ -839,13 +821,13 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& WRITE (output_unit,'(A)')" WARNING| They will be included in a further unique thermostat!" END IF DEALLOCATE(tmp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CPPostcondition(ALL(thermolist/=HUGE(0)),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(thermolist/=HUGE(0)),cp_failure_level,routineP,failure) ! Now identify the local number of thermostats ALLOCATE(tmp(nregions),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp = 0 natom_local = 0 DO ikind = 1, SIZE(molecule_kind_set) @@ -862,11 +844,11 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& END DO number = SUM(tmp) DEALLOCATE(tmp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Now map the local atoms with the corresponding thermostat ALLOCATE(map_loc_thermo_gen(natom_local),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) natom_local = 0 DO ikind = 1, SIZE(molecule_kind_set) nmol_per_kind = local_molecules%n_el(ikind) @@ -882,7 +864,7 @@ SUBROUTINE get_defined_region_info(region_sections, number, sum_of_thermostats,& END DO DEALLOCATE(thermolist, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE get_defined_region_info ! ***************************************************************************** @@ -895,11 +877,10 @@ END SUBROUTINE get_defined_region_info !> \param ig ... !> \param sum_of_thermostats ... !> \param nregions ... -!> \param error ... !> \author 11.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE setup_thermostat_subsys(region_sections, qmmm_env, thermolist,& - molecule_set, subsys_qm, ig, sum_of_thermostats, nregions, error) + molecule_set, subsys_qm, ig, sum_of_thermostats, nregions) TYPE(section_vals_type), POINTER :: region_sections TYPE(qmmm_env_type), POINTER :: qmmm_env INTEGER, DIMENSION(:), POINTER :: thermolist @@ -908,7 +889,6 @@ SUBROUTINE setup_thermostat_subsys(region_sections, qmmm_env, thermolist,& LOGICAL, INTENT(IN) :: subsys_qm INTEGER, INTENT(IN) :: ig INTEGER, INTENT(INOUT) :: sum_of_thermostats, nregions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_thermostat_subsys', & routineP = moduleN//':'//routineN @@ -929,14 +909,14 @@ SUBROUTINE setup_thermostat_subsys(region_sections, qmmm_env, thermolist,& label2 = "MM_SUBSYS" END IF CALL section_vals_val_get(region_sections,TRIM(label1),i_rep_section=ig,& - n_rep_val=nrep,explicit=explicit,error=error) + n_rep_val=nrep,explicit=explicit) IF (nrep==1 .AND. explicit) THEN IF (ASSOCIATED(qmmm_env)) THEN atom_index1 => qmmm_env%qm%mm_atom_index IF (subsys_qm) THEN atom_index1 => qmmm_env%qm%qm_atom_index END IF - CALL section_vals_val_get(region_sections,TRIM(label1),i_val=thermo1,i_rep_section=ig,error=error) + CALL section_vals_val_get(region_sections,TRIM(label1),i_val=thermo1,i_rep_section=ig) SELECT CASE(thermo1) CASE(do_constr_atomic) DO i = 1, SIZE(atom_index1) @@ -985,15 +965,13 @@ END SUBROUTINE setup_thermostat_subsys !> \param map_info ... !> \param npt ... !> \param group ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE ke_region_baro(map_info, npt, group, error) + SUBROUTINE ke_region_baro(map_info, npt, group) TYPE(map_info_type), POINTER :: map_info TYPE(npt_info_type), DIMENSION(:, :), & INTENT(INOUT) :: npt INTEGER, INTENT(IN) :: group - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ke_region_baro', & routineP = moduleN//':'//routineN @@ -1021,14 +999,12 @@ END SUBROUTINE ke_region_baro !> \brief ... !> \param map_info ... !> \param npt ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** - SUBROUTINE vel_rescale_baro(map_info, npt, error) + SUBROUTINE vel_rescale_baro(map_info, npt) TYPE(map_info_type), POINTER :: map_info TYPE(npt_info_type), DIMENSION(:, :), & INTENT(INOUT) :: npt - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vel_rescale_baro', & routineP = moduleN//':'//routineN @@ -1054,11 +1030,10 @@ END SUBROUTINE vel_rescale_baro !> \param molecule_set ... !> \param group ... !> \param vel ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE ke_region_particles(map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) TYPE(map_info_type), POINTER :: map_info TYPE(particle_type), POINTER :: particle_set( : ) @@ -1067,7 +1042,6 @@ SUBROUTINE ke_region_particles(map_info, particle_set, molecule_kind_set,& TYPE(molecule_type), POINTER :: molecule_set( : ) INTEGER, INTENT(IN) :: group REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ke_region_particles', & routineP = moduleN//':'//routineN @@ -1127,11 +1101,10 @@ END SUBROUTINE ke_region_particles !> \param molecule_set ... !> \param group ... !> \param vel ... -!> \param error ... !> \author 07.2009 MI ! ***************************************************************************** SUBROUTINE momentum_region_particles (map_info, particle_set, molecule_kind_set,& - local_molecules, molecule_set, group, vel, error) + local_molecules, molecule_set, group, vel) TYPE(map_info_type), POINTER :: map_info TYPE(particle_type), POINTER :: particle_set( : ) @@ -1140,7 +1113,6 @@ SUBROUTINE momentum_region_particles (map_info, particle_set, molecule_kind_set, TYPE(molecule_type), POINTER :: molecule_set( : ) INTEGER, INTENT(IN) :: group REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'momentum_region_particles', & routineP = moduleN//':'//routineN @@ -1198,12 +1170,11 @@ END SUBROUTINE momentum_region_particles !> \param vel ... !> \param shell_vel ... !> \param core_vel ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE vel_rescale_particles(map_info, molecule_kind_set, molecule_set,& particle_set, local_molecules, shell_adiabatic, shell_particle_set,& - core_particle_set, vel, shell_vel, core_vel, error) + core_particle_set, vel, shell_vel, core_vel) TYPE(map_info_type), POINTER :: map_info TYPE(molecule_kind_type), POINTER :: molecule_kind_set( : ) @@ -1215,7 +1186,6 @@ SUBROUTINE vel_rescale_particles(map_info, molecule_kind_set, molecule_set,& core_particle_set( : ) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: vel(:,:), shell_vel(:,:), & core_vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vel_rescale_particles', & routineP = moduleN//':'//routineN @@ -1238,13 +1208,13 @@ SUBROUTINE vel_rescale_particles(map_info, molecule_kind_set, molecule_set,& ! Just few checks for consistency IF (present_vel) THEN IF (shell_adiabatic) THEN - CPPostcondition(PRESENT(shell_vel),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(core_vel),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(shell_vel),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(core_vel),cp_failure_level,routineP,failure) END IF ELSE IF (shell_adiabatic) THEN - CPPostcondition(PRESENT(shell_particle_set),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(shell_particle_set),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,failure) END IF END IF Kind: DO ikind = 1, SIZE ( molecule_kind_set ) @@ -1311,12 +1281,11 @@ END SUBROUTINE vel_rescale_particles !> \param shell_particle_set ... !> \param core_vel ... !> \param shell_vel ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE ke_region_shells(map_info, particle_set, atomic_kind_set,& local_particles, group, core_particle_set, shell_particle_set,& - core_vel, shell_vel, error) + core_vel, shell_vel) TYPE(map_info_type), POINTER :: map_info TYPE(particle_type), POINTER :: particle_set( : ) @@ -1326,7 +1295,6 @@ SUBROUTINE ke_region_shells(map_info, particle_set, atomic_kind_set,& TYPE(particle_type), OPTIONAL, POINTER :: core_particle_set(:), & shell_particle_set(:) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: core_vel(:,:), shell_vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ke_region_shells', & routineP = moduleN//':'//routineN @@ -1342,10 +1310,10 @@ SUBROUTINE ke_region_shells(map_info, particle_set, atomic_kind_set,& present_vel = PRESENT(shell_vel) ! Preliminary checks for consistency usage IF (present_vel) THEN - CPPostcondition(PRESENT(core_vel),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(core_vel),cp_failure_level,routineP,failure) ELSE - CPPostcondition(PRESENT(shell_particle_set),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(shell_particle_set),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,failure) END IF ! get force on first thermostat for all the chains in the system. map_info%v_scale = 1.0_dp @@ -1396,11 +1364,10 @@ END SUBROUTINE ke_region_shells !> \param shell_vel ... !> \param core_vel ... !> \param vel ... -!> \param error ... !> \author 10.2007 [tlaino] - Teodoro Laino - University of Zurich ! ***************************************************************************** SUBROUTINE vel_rescale_shells(map_info, atomic_kind_set, particle_set, local_particles, & - shell_particle_set, core_particle_set, shell_vel, core_vel, vel, error) + shell_particle_set, core_particle_set, shell_vel, core_vel, vel) TYPE(map_info_type), POINTER :: map_info TYPE(atomic_kind_type), POINTER :: atomic_kind_set( : ) @@ -1410,7 +1377,6 @@ SUBROUTINE vel_rescale_shells(map_info, atomic_kind_set, particle_set, local_par core_particle_set(:) REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: shell_vel(:,:), & core_vel(:,:), vel(:,:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vel_rescale_shells', & routineP = moduleN//':'//routineN @@ -1427,11 +1393,11 @@ SUBROUTINE vel_rescale_shells(map_info, atomic_kind_set, particle_set, local_par present_vel = PRESENT(vel) ! Preliminary checks for consistency usage IF (present_vel) THEN - CPPostcondition(PRESENT(shell_vel),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(core_vel),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(shell_vel),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(core_vel),cp_failure_level,routineP,failure) ELSE - CPPostcondition(PRESENT(shell_particle_set),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(shell_particle_set),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,failure) END IF ii = 0 nparticle_kind = SIZE(atomic_kind_set) @@ -1484,18 +1450,16 @@ END SUBROUTINE vel_rescale_shells !> \param para_env ... !> \param array_kin ... !> \param array_pot ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE get_nhc_energies ( nhc, nhc_pot, nhc_kin, para_env, array_kin, array_pot, error ) + SUBROUTINE get_nhc_energies ( nhc, nhc_pot, nhc_kin, para_env, array_kin, array_pot) TYPE(lnhc_parameters_type), POINTER :: nhc REAL(KIND=dp), INTENT(OUT) :: nhc_pot, nhc_kin TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: array_kin, array_pot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_nhc_energies', & routineP = moduleN//':'//routineN @@ -1507,9 +1471,9 @@ SUBROUTINE get_nhc_energies ( nhc, nhc_pot, nhc_kin, para_env, array_kin, array_ failure = .FALSE. number = nhc%glob_num_nhc ALLOCATE(akin(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE(vpot(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) akin = 0.0_dp vpot = 0.0_dp DO n = 1, nhc%loc_num_nhc @@ -1525,8 +1489,8 @@ SUBROUTINE get_nhc_energies ( nhc, nhc_pot, nhc_kin, para_env, array_kin, array_ CALL mp_sum(akin,para_env%group) CALL mp_sum(vpot,para_env%group) ELSE IF (nhc%map_info%dis_type==do_thermo_communication) THEN - CALL communication_thermo_low1(akin, number, para_env, error) - CALL communication_thermo_low1(vpot, number, para_env, error) + CALL communication_thermo_low1(akin, number, para_env) + CALL communication_thermo_low1(vpot, number, para_env) END IF nhc_kin = SUM(akin) nhc_pot = SUM(vpot) @@ -1534,26 +1498,26 @@ SUBROUTINE get_nhc_energies ( nhc, nhc_pot, nhc_kin, para_env, array_kin, array_ ! Possibly give back kinetic or potential energy arrays IF (PRESENT(array_pot)) THEN IF (ASSOCIATED(array_pot)) THEN - CPPrecondition(SIZE(array_pot)==number,cp_fatal_level,routineP,error,failure) + CPPrecondition(SIZE(array_pot)==number,cp_fatal_level,routineP,failure) ELSE ALLOCATE(array_pot(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF array_pot=vpot END IF IF (PRESENT(array_kin)) THEN IF (ASSOCIATED(array_kin)) THEN - CPPrecondition(SIZE(array_kin)==number,cp_fatal_level,routineP,error,failure) + CPPrecondition(SIZE(array_kin)==number,cp_fatal_level,routineP,failure) ELSE ALLOCATE(array_kin(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF array_kin=akin END IF DEALLOCATE(akin,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) DEALLOCATE(vpot,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END SUBROUTINE get_nhc_energies ! ***************************************************************************** @@ -1567,12 +1531,11 @@ END SUBROUTINE get_nhc_energies !> \param para_env ... !> \param array_pot ... !> \param array_kin ... -!> \param error ... !> \par History generalized MI [07.2009] !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE get_kin_energies(map_info,loc_num,glob_num,thermo_energy,thermostat_kin, & - para_env, array_pot, array_kin, error) + para_env, array_pot, array_kin) TYPE(map_info_type), POINTER :: map_info INTEGER, INTENT(IN) :: loc_num, glob_num @@ -1581,7 +1544,6 @@ SUBROUTINE get_kin_energies(map_info,loc_num,glob_num,thermo_energy,thermostat_k TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: array_pot, array_kin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_kin_energies', & routineP = moduleN//':'//routineN @@ -1593,7 +1555,7 @@ SUBROUTINE get_kin_energies(map_info,loc_num,glob_num,thermo_energy,thermostat_k failure = .FALSE. number = glob_num ALLOCATE(akin(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) akin = 0.0_dp DO n = 1, loc_num imap = map_info%index(n) @@ -1604,31 +1566,31 @@ SUBROUTINE get_kin_energies(map_info,loc_num,glob_num,thermo_energy,thermostat_k IF (map_info%dis_type==do_thermo_no_communication) THEN CALL mp_sum(akin,para_env%group) ELSE IF (map_info%dis_type==do_thermo_communication) THEN - CALL communication_thermo_low1(akin, number, para_env, error) + CALL communication_thermo_low1(akin, number, para_env) END IF thermostat_kin = SUM(akin) ! Possibly give back kinetic or potential energy arrays IF (PRESENT(array_pot)) THEN IF (ASSOCIATED(array_pot)) THEN - CPPrecondition(SIZE(array_pot)==number,cp_fatal_level,routineP,error,failure) + CPPrecondition(SIZE(array_pot)==number,cp_fatal_level,routineP,failure) ELSE ALLOCATE(array_pot(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF array_pot=0.0_dp END IF IF (PRESENT(array_kin)) THEN IF (ASSOCIATED(array_kin)) THEN - CPPrecondition(SIZE(array_kin)==number,cp_fatal_level,routineP,error,failure) + CPPrecondition(SIZE(array_kin)==number,cp_fatal_level,routineP,failure) ELSE ALLOCATE(array_kin(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF array_kin=akin END IF DEALLOCATE(akin,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END SUBROUTINE get_kin_energies ! ***************************************************************************** @@ -1642,12 +1604,11 @@ END SUBROUTINE get_kin_energies !> \param para_env ... !> \param temp_tot ... !> \param array_temp ... -!> \param error ... !> \par History generalized MI [07.2009] !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE get_temperatures ( map_info, loc_num, glob_num, nkt, dof, para_env,& - temp_tot, array_temp, error ) + temp_tot, array_temp) TYPE(map_info_type), POINTER :: map_info INTEGER, INTENT(IN) :: loc_num, glob_num REAL(dp), DIMENSION(:), INTENT(IN) :: nkt, dof @@ -1655,7 +1616,6 @@ SUBROUTINE get_temperatures ( map_info, loc_num, glob_num, nkt, dof, para_env,& REAL(KIND=dp), INTENT(OUT) :: temp_tot REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: array_temp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_temperatures', & routineP = moduleN//':'//routineN @@ -1669,9 +1629,9 @@ SUBROUTINE get_temperatures ( map_info, loc_num, glob_num, nkt, dof, para_env,& failure = .FALSE. number = glob_num ALLOCATE(akin(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ALLOCATE(deg_of_free(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) akin = 0.0_dp deg_of_free = 0.0_dp DO n = 1, loc_num @@ -1687,31 +1647,31 @@ SUBROUTINE get_temperatures ( map_info, loc_num, glob_num, nkt, dof, para_env,& CALL mp_sum(akin,para_env%group) CALL mp_sum(deg_of_free,para_env%group) ELSE IF (map_info%dis_type==do_thermo_communication) THEN - CALL communication_thermo_low1(akin, number, para_env, error) - CALL communication_thermo_low1(deg_of_free, number, para_env, error) + CALL communication_thermo_low1(akin, number, para_env) + CALL communication_thermo_low1(deg_of_free, number, para_env) END IF temp_tot = SUM(akin) fdeg_of_free = SUM(deg_of_free) temp_tot = temp_tot/fdeg_of_free - temp_tot = cp_unit_from_cp2k(temp_tot, "K_temp", error=error) + temp_tot = cp_unit_from_cp2k(temp_tot, "K_temp") ! Possibly give back temperatures of the full set of regions IF (PRESENT(array_temp)) THEN IF (ASSOCIATED(array_temp)) THEN - CPPrecondition(SIZE(array_temp)==number,cp_fatal_level,routineP,error,failure) + CPPrecondition(SIZE(array_temp)==number,cp_fatal_level,routineP,failure) ELSE ALLOCATE(array_temp(number),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ENDIF DO i = 1, number array_temp(i) = akin(i)/deg_of_free(i) - array_temp(i) = cp_unit_from_cp2k(array_temp(i), "K_temp", error=error) + array_temp(i) = cp_unit_from_cp2k(array_temp(i), "K_temp") END DO END IF DEALLOCATE(akin,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) DEALLOCATE(deg_of_free,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END SUBROUTINE get_temperatures ! ***************************************************************************** @@ -1722,17 +1682,15 @@ END SUBROUTINE get_temperatures !> \param para_env ... !> \param array_pot ... !> \param array_kin ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich ! ***************************************************************************** SUBROUTINE get_thermostat_energies ( thermostat, thermostat_pot, thermostat_kin, para_env,& - array_pot, array_kin, error ) + array_pot, array_kin) TYPE(thermostat_type), POINTER :: thermostat REAL(KIND=dp), INTENT(OUT) :: thermostat_pot, thermostat_kin TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: array_pot, array_kin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_thermostat_energies', & routineP = moduleN//':'//routineN @@ -1748,36 +1706,36 @@ SUBROUTINE get_thermostat_energies ( thermostat, thermostat_pot, thermostat_kin, IF (ASSOCIATED(thermostat)) THEN IF (thermostat%type_of_thermostat==do_thermo_nose) THEN ! Energy associated with the Nose-Hoover thermostat - CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,failure) CALL get_nhc_energies (thermostat%nhc, thermostat_pot, thermostat_kin, para_env,& - array_pot, array_kin, error ) + array_pot, array_kin) ELSE IF (thermostat%type_of_thermostat==do_thermo_csvr) THEN ! Energy associated with the CSVR thermostat - CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,failure) ALLOCATE(thermo_energy(thermostat%csvr%loc_num_csvr),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,thermostat%csvr%loc_num_csvr thermo_energy(i) = thermostat%csvr%nvt(i)%thermostat_energy END DO CALL get_kin_energies(thermostat%csvr%map_info,thermostat%csvr%loc_num_csvr,& thermostat%csvr%glob_num_csvr,thermo_energy,& - thermostat_kin, para_env, array_pot, array_kin, error=error) + thermostat_kin, para_env, array_pot, array_kin) DEALLOCATE(thermo_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF (thermostat%type_of_thermostat==do_thermo_gle) THEN ! Energy associated with the GLE thermostat - CPPostcondition(ASSOCIATED(thermostat%gle),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%gle),cp_failure_level,routineP,failure) ALLOCATE(thermo_energy(thermostat%gle%loc_num_gle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,thermostat%gle%loc_num_gle thermo_energy(i) = thermostat%gle%nvt(i)%thermostat_energy END DO CALL get_kin_energies(thermostat%gle%map_info,thermostat%gle%loc_num_gle,& thermostat%gle%glob_num_gle,thermo_energy,& - thermostat_kin, para_env, array_pot, array_kin, error=error) + thermostat_kin, para_env, array_pot, array_kin) DEALLOCATE(thermo_energy,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ![NB] nothing to do for Ad-Langevin? @@ -1792,16 +1750,14 @@ END SUBROUTINE get_thermostat_energies !> \param tot_temperature ... !> \param para_env ... !> \param array_temp ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 02.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE get_region_temperatures ( thermostat, tot_temperature, para_env, array_temp, error ) + SUBROUTINE get_region_temperatures ( thermostat, tot_temperature, para_env, array_temp) TYPE(thermostat_type), POINTER :: thermostat REAL(KIND=dp), INTENT(OUT) :: tot_temperature TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: array_temp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_region_temperatures', & routineP = moduleN//':'//routineN @@ -1815,75 +1771,75 @@ SUBROUTINE get_region_temperatures ( thermostat, tot_temperature, para_env, arra IF (ASSOCIATED(thermostat)) THEN IF (thermostat%type_of_thermostat==do_thermo_nose) THEN ! Energy associated with the Nose-Hoover thermostat - CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%nhc),cp_failure_level,routineP,failure) ALLOCATE(nkt(thermostat%nhc%loc_num_nhc), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dof(thermostat%nhc%loc_num_nhc), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,thermostat%nhc%loc_num_nhc nkt(i) = thermostat%nhc%nvt(1,i)%nkt dof(i) = REAL(thermostat%nhc%nvt(1,i)%degrees_of_freedom,KIND=dp) END DO CALL get_temperatures ( thermostat%nhc%map_info, thermostat%nhc%loc_num_nhc, & - thermostat%nhc%glob_num_nhc, nkt, dof, para_env, tot_temperature, array_temp, error ) + thermostat%nhc%glob_num_nhc, nkt, dof, para_env, tot_temperature, array_temp) DEALLOCATE(nkt, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dof, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF (thermostat%type_of_thermostat==do_thermo_csvr) THEN ! Energy associated with the CSVR thermostat - CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%csvr),cp_failure_level,routineP,failure) ALLOCATE(nkt(thermostat%csvr%loc_num_csvr), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dof(thermostat%csvr%loc_num_csvr), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,thermostat%csvr%loc_num_csvr nkt(i) = thermostat%csvr%nvt(i)%nkt dof(i) = REAL(thermostat%csvr%nvt(i)%degrees_of_freedom,KIND=dp) END DO CALL get_temperatures ( thermostat%csvr%map_info, thermostat%csvr%loc_num_csvr, & - thermostat%csvr%glob_num_csvr, nkt, dof, para_env, tot_temperature, array_temp, error ) + thermostat%csvr%glob_num_csvr, nkt, dof, para_env, tot_temperature, array_temp) DEALLOCATE(nkt, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dof, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF (thermostat%type_of_thermostat==do_thermo_al) THEN ! Energy associated with the AD_LANGEVIN thermostat - CPPostcondition(ASSOCIATED(thermostat%al),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%al),cp_failure_level,routineP,failure) ALLOCATE(nkt(thermostat%al%loc_num_al), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dof(thermostat%al%loc_num_al), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,thermostat%al%loc_num_al nkt(i) = thermostat%al%nvt(i)%nkt dof(i) = REAL(thermostat%al%nvt(i)%degrees_of_freedom,KIND=dp) END DO CALL get_temperatures ( thermostat%al%map_info, thermostat%al%loc_num_al, & - thermostat%al%glob_num_al, nkt, dof, para_env, tot_temperature, array_temp, error ) + thermostat%al%glob_num_al, nkt, dof, para_env, tot_temperature, array_temp) DEALLOCATE(nkt, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dof, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF (thermostat%type_of_thermostat==do_thermo_gle) THEN ! Energy associated with the GLE thermostat - CPPostcondition(ASSOCIATED(thermostat%gle),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(thermostat%gle),cp_failure_level,routineP,failure) ALLOCATE(nkt(thermostat%gle%loc_num_gle), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dof(thermostat%gle%loc_num_gle), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1,thermostat%gle%loc_num_gle nkt(i) = thermostat%gle%nvt(i)%nkt dof(i) = REAL(thermostat%gle%nvt(i)%degrees_of_freedom,KIND=dp) END DO CALL get_temperatures ( thermostat%gle%map_info, thermostat%gle%loc_num_gle, & - thermostat%gle%glob_num_gle, nkt, dof, para_env, tot_temperature, array_temp, error ) + thermostat%gle%glob_num_gle, nkt, dof, para_env, tot_temperature, array_temp) DEALLOCATE(nkt, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(dof, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -1897,16 +1853,14 @@ END SUBROUTINE get_region_temperatures !> \param my_act ... !> \param itimes ... !> \param time ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 02.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE print_thermostats_status(thermostats, para_env, my_pos, my_act, itimes, time, error) + SUBROUTINE print_thermostats_status(thermostats, para_env, my_pos, my_act, itimes, time) TYPE(thermostats_type), POINTER :: thermostats TYPE(cp_para_env_type), POINTER :: para_env CHARACTER(LEN=default_string_length) :: my_pos, my_act INTEGER, INTENT(IN) :: itimes REAL(KIND=dp), INTENT(IN) :: time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_thermostats_status', & routineP = moduleN//':'//routineN @@ -1917,16 +1871,16 @@ SUBROUTINE print_thermostats_status(thermostats, para_env, my_pos, my_act, itime IF (ASSOCIATED(thermostats)) THEN IF (ASSOCIATED(thermostats%thermostat_part)) THEN - CALL print_thermostat_status(thermostats%thermostat_part, para_env, my_pos, my_act, itimes, time, error) + CALL print_thermostat_status(thermostats%thermostat_part, para_env, my_pos, my_act, itimes, time) END IF IF (ASSOCIATED(thermostats%thermostat_shell)) THEN - CALL print_thermostat_status(thermostats%thermostat_shell, para_env, my_pos, my_act, itimes, time, error) + CALL print_thermostat_status(thermostats%thermostat_shell, para_env, my_pos, my_act, itimes, time) END IF IF (ASSOCIATED(thermostats%thermostat_coef)) THEN - CALL print_thermostat_status(thermostats%thermostat_coef, para_env, my_pos, my_act, itimes, time, error) + CALL print_thermostat_status(thermostats%thermostat_coef, para_env, my_pos, my_act, itimes, time) END IF IF (ASSOCIATED(thermostats%thermostat_baro)) THEN - CALL print_thermostat_status(thermostats%thermostat_baro, para_env, my_pos, my_act, itimes, time, error) + CALL print_thermostat_status(thermostats%thermostat_baro, para_env, my_pos, my_act, itimes, time) END IF END IF END SUBROUTINE print_thermostats_status @@ -1939,16 +1893,14 @@ END SUBROUTINE print_thermostats_status !> \param my_act ... !> \param itimes ... !> \param time ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 02.2008 - University of Zurich ! ***************************************************************************** - SUBROUTINE print_thermostat_status ( thermostat, para_env, my_pos, my_act, itimes, time, error ) + SUBROUTINE print_thermostat_status ( thermostat, para_env, my_pos, my_act, itimes, time) TYPE(thermostat_type), POINTER :: thermostat TYPE(cp_para_env_type), POINTER :: para_env CHARACTER(LEN=default_string_length) :: my_pos, my_act INTEGER, INTENT(IN) :: itimes REAL(KIND=dp), INTENT(IN) :: time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_thermostat_status', & routineP = moduleN//':'//routineN @@ -1964,16 +1916,16 @@ SUBROUTINE print_thermostat_status ( thermostat, para_env, my_pos, my_act, itime failure = .FALSE. NULLIFY(logger, print_key, array_pot, array_kin, array_temp) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(thermostat)) THEN ! Print Energies - print_key => section_vals_get_subs_vals(thermostat%section,"PRINT%ENERGY",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN - CALL get_thermostat_energies(thermostat, thermo_pot, thermo_kin, para_env, array_pot, array_kin, error) + print_key => section_vals_get_subs_vals(thermostat%section,"PRINT%ENERGY") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN + CALL get_thermostat_energies(thermostat, thermo_pot, thermo_kin, para_env, array_pot, array_kin) unit = cp_print_key_unit_nr(logger,thermostat%section,"PRINT%ENERGY",& extension="."//TRIM(thermostat%label)//".tener",file_position=my_pos, & - file_action=my_act, is_new_file=new_file, error=error) + file_action=my_act, is_new_file=new_file) IF(unit > 0) THEN IF (new_file) THEN WRITE(unit,'(A)')"# Thermostat Potential and Kinetic Energies - Total and per Region" @@ -1991,18 +1943,18 @@ SUBROUTINE print_thermostat_status ( thermostat, para_env, my_pos, my_act, itime CALL m_flush(unit) END IF DEALLOCATE(array_kin, stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) DEALLOCATE(array_pot, stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) - CALL cp_print_key_finished_output(unit,logger,thermostat%section,"PRINT%ENERGY", error=error) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) + CALL cp_print_key_finished_output(unit,logger,thermostat%section,"PRINT%ENERGY") END IF ! Print Temperatures of the regions - print_key => section_vals_get_subs_vals(thermostat%section,"PRINT%TEMPERATURE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN - CALL get_region_temperatures(thermostat, tot_temperature, para_env, array_temp, error) + print_key => section_vals_get_subs_vals(thermostat%section,"PRINT%TEMPERATURE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN + CALL get_region_temperatures(thermostat, tot_temperature, para_env, array_temp) unit = cp_print_key_unit_nr(logger,thermostat%section,"PRINT%TEMPERATURE",& extension="."//TRIM(thermostat%label)//".temp",file_position=my_pos,& - file_action=my_act, is_new_file=new_file, error=error) + file_action=my_act, is_new_file=new_file) IF(unit > 0) THEN IF (new_file) THEN WRITE(unit,'(A)')"# Temperature Total and per Region" @@ -2016,8 +1968,8 @@ SUBROUTINE print_thermostat_status ( thermostat, para_env, my_pos, my_act, itime CALL m_flush(unit) END IF DEALLOCATE(array_temp, stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) - CALL cp_print_key_finished_output(unit,logger,thermostat%section,"PRINT%TEMPERATURE", error=error) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) + CALL cp_print_key_finished_output(unit,logger,thermostat%section,"PRINT%TEMPERATURE") END IF END IF END SUBROUTINE print_thermostat_status @@ -2027,15 +1979,13 @@ END SUBROUTINE print_thermostat_status !> \param array ... !> \param number ... !> \param para_env ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 11.2007 ! ***************************************************************************** - SUBROUTINE communication_thermo_low1(array, number, para_env, error) + SUBROUTINE communication_thermo_low1(array, number, para_env) REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: array INTEGER, INTENT(IN) :: number TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'communication_thermo_low1', & routineP = moduleN//':'//routineN @@ -2046,7 +1996,7 @@ SUBROUTINE communication_thermo_low1(array, number, para_env, error) failure = .FALSE. ALLOCATE(work(para_env%num_pe),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) DO i = 1, number work = 0.0_dp work(para_env%mepos+1) = array(i) @@ -2055,7 +2005,7 @@ SUBROUTINE communication_thermo_low1(array, number, para_env, error) array(i) = 0.0_dp IF (ncheck/=0) THEN ALLOCATE(work2(ncheck),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ncheck = 0 DO icheck = 1, para_env%num_pe IF (work(icheck)/=0.0_dp) THEN @@ -2063,16 +2013,16 @@ SUBROUTINE communication_thermo_low1(array, number, para_env, error) work2(ncheck) = work(icheck) END IF END DO - CPPrecondition(ncheck==SIZE(work2),cp_fatal_level,routineP,error,failure) - CPPrecondition(ALL(work2==work2(1)),cp_fatal_level,routineP,error,failure) + CPPrecondition(ncheck==SIZE(work2),cp_fatal_level,routineP,failure) + CPPrecondition(ALL(work2==work2(1)),cp_fatal_level,routineP,failure) array(i) = work2(1) DEALLOCATE(work2,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF END DO DEALLOCATE(work,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END SUBROUTINE communication_thermo_low1 ! ***************************************************************************** @@ -2081,14 +2031,12 @@ END SUBROUTINE communication_thermo_low1 !> \param number1 ... !> \param number2 ... !> \param para_env ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 11.2007 ! ***************************************************************************** - SUBROUTINE communication_thermo_low2(array, number1, number2, para_env, error) + SUBROUTINE communication_thermo_low2(array, number1, number2, para_env) INTEGER, DIMENSION(:, :), INTENT(INOUT) :: array INTEGER, INTENT(IN) :: number1, number2 TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'communication_thermo_low2', & routineP = moduleN//':'//routineN @@ -2099,7 +2047,7 @@ SUBROUTINE communication_thermo_low2(array, number1, number2, para_env, error) failure = .FALSE. ALLOCATE(work(number1,para_env%num_pe),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) DO i = 1, number2 work = 0 work(:,para_env%mepos+1) = array(:,i) @@ -2113,7 +2061,7 @@ SUBROUTINE communication_thermo_low2(array, number1, number2, para_env, error) array(:,i) = 0 IF (ncheck/=0) THEN ALLOCATE(work2(number1,ncheck),stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) ncheck = 0 DO icheck = 1, para_env%num_pe IF (ANY(work(:,icheck)/=0)) THEN @@ -2121,17 +2069,17 @@ SUBROUTINE communication_thermo_low2(array, number1, number2, para_env, error) work2(:,ncheck) = work(:,icheck) END IF END DO - CPPrecondition(ncheck==SIZE(work2,2),cp_fatal_level,routineP,error,failure) + CPPrecondition(ncheck==SIZE(work2,2),cp_fatal_level,routineP,failure) DO j = 1, ncheck - CPPrecondition(ALL(work2(:,j)==work2(:,1)),cp_fatal_level,routineP,error,failure) + CPPrecondition(ALL(work2(:,j)==work2(:,1)),cp_fatal_level,routineP,failure) END DO array(:,i) = work2(:,1) DEALLOCATE(work2,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END IF END DO DEALLOCATE(work,stat=stat) - CPPrecondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPrecondition(stat==0,cp_fatal_level,routineP,failure) END SUBROUTINE communication_thermo_low2 END MODULE thermostat_utils diff --git a/src/motion/velocity_verlet_control.F b/src/motion/velocity_verlet_control.F index a1f1dbff6d..dc06282a06 100644 --- a/src/motion/velocity_verlet_control.F +++ b/src/motion/velocity_verlet_control.F @@ -41,16 +41,14 @@ MODULE velocity_verlet_control !> \brief ... !> \param md_env ... !> \param globenv ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** - SUBROUTINE velocity_verlet ( md_env, globenv, error ) + SUBROUTINE velocity_verlet ( md_env, globenv) TYPE(md_environment_type), POINTER :: md_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'velocity_verlet', & routineP = moduleN//':'//routineN @@ -62,7 +60,7 @@ SUBROUTINE velocity_verlet ( md_env, globenv, error ) CALL timeset (routineN, handle ) ! Get force environment - CALL get_md_env ( md_env, force_env=force_env, simpar=simpar, error=error) + CALL get_md_env ( md_env, force_env=force_env, simpar=simpar) ! RESPA implemented only for NVE IF(simpar%do_respa .AND. nve_ensemble.NE.simpar % ensemble) THEN @@ -77,32 +75,32 @@ SUBROUTINE velocity_verlet ( md_env, globenv, error ) "Integrator not implemented") CASE (nve_ensemble) IF(simpar%do_respa)THEN - CALL nve_respa(md_env,error) + CALL nve_respa(md_env) ELSE - CALL nve (md_env, globenv, error) + CALL nve (md_env, globenv) END IF CASE (nvt_ensemble) - CALL nvt (md_env, globenv, error) + CALL nvt (md_env, globenv) CASE (nvt_adiabatic_ensemble) - CALL nvt_adiabatic (md_env, globenv, error) + CALL nvt_adiabatic (md_env, globenv) CASE (isokin_ensemble) - CALL isokin (md_env, error) + CALL isokin (md_env) CASE (npt_i_ensemble) - CALL npt_i (md_env, globenv, error) + CALL npt_i (md_env, globenv) CASE (npt_f_ensemble) - CALL npt_f (md_env, globenv, error) + CALL npt_f (md_env, globenv) CASE (nph_uniaxial_ensemble) - CALL nph_uniaxial (md_env, error) + CALL nph_uniaxial (md_env) CASE (nph_uniaxial_damped_ensemble) - CALL nph_uniaxial_damped (md_env, error) + CALL nph_uniaxial_damped (md_env) CASE (reftraj_ensemble) - CALL reftraj (md_env, error) + CALL reftraj (md_env) CASE (langevin_ensemble) - CALL langevin(md_env, error) + CALL langevin(md_env) CASE (npe_f_ensemble) - CALL npt_f (md_env, globenv, error) + CALL npt_f (md_env, globenv) CASE (npe_i_ensemble) - CALL npt_i (md_env, globenv, error) + CALL npt_i (md_env, globenv) END SELECT CALL timestop(handle) diff --git a/src/motion/vibrational_analysis.F b/src/motion/vibrational_analysis.F index 7d045a239a..b93b384ab0 100644 --- a/src/motion/vibrational_analysis.F +++ b/src/motion/vibrational_analysis.F @@ -77,15 +77,13 @@ MODULE vibrational_analysis !> \param input_declaration ... !> \param para_env ... !> \param globenv ... -!> \param error ... !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) + SUBROUTINE vb_anal(input, input_declaration, para_env, globenv) TYPE(section_vals_type), POINTER :: input TYPE(section_type), POINTER :: input_declaration TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vb_anal', & routineP = moduleN//':'//routineN @@ -111,7 +109,6 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) REAL(KIND=dp), DIMENSION(:, :), POINTER :: D, dip_deriv, RotTrM REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: tmp_dip - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env @@ -126,57 +123,56 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) failure = .FALSE. NULLIFY(D, RotTrM, logger, subsys, f_env, particles, rep_env, intensities,& vib_section, print_section) - logger => cp_error_get_logger(error) - vib_section => section_vals_get_subs_vals(input,"VIBRATIONAL_ANALYSIS",error=error) - print_section => section_vals_get_subs_vals(vib_section,"PRINT",error=error) - output_unit=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".vibLog",error=error) - - CALL section_vals_val_get(vib_section,"DX",r_val=dx, error=error) - CALL section_vals_val_get(vib_section,"NPROC_REP",i_val=prep, error=error) - CALL section_vals_val_get(vib_section,"PROC_DIST_TYPE",i_val=proc_dist_type, error=error) + logger => cp_get_default_logger() + vib_section => section_vals_get_subs_vals(input,"VIBRATIONAL_ANALYSIS") + print_section => section_vals_get_subs_vals(vib_section,"PRINT") + output_unit=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".vibLog") + + CALL section_vals_val_get(vib_section,"DX",r_val=dx) + CALL section_vals_val_get(vib_section,"NPROC_REP",i_val=prep) + CALL section_vals_val_get(vib_section,"PROC_DIST_TYPE",i_val=proc_dist_type) row_force = (proc_dist_type==do_rep_blocked) - CALL section_vals_val_get(vib_section,"FULLY_PERIODIC",l_val=keep_rotations, error=error) - CALL section_vals_val_get(vib_section,"INTENSITIES",l_val=calc_intens, error=error) - mode_tracking_section=>section_vals_get_subs_vals(vib_section,"MODE_SELECTIVE",& - error=error) - CALL section_vals_get(mode_tracking_section,explicit=do_mode_tracking, error=error) + CALL section_vals_val_get(vib_section,"FULLY_PERIODIC",l_val=keep_rotations) + CALL section_vals_val_get(vib_section,"INTENSITIES",l_val=calc_intens) + mode_tracking_section=>section_vals_get_subs_vals(vib_section,"MODE_SELECTIVE") + CALL section_vals_get(mode_tracking_section,explicit=do_mode_tracking) nrep = MAX(1,para_env%num_pe/prep) prep = para_env%num_pe/nrep - iw=cp_print_key_unit_nr(logger,print_section,"BANNER",extension=".vibLog",error=error) + iw=cp_print_key_unit_nr(logger,print_section,"BANNER",extension=".vibLog") CALL vib_header(iw, nrep, prep) - CALL cp_print_key_finished_output(iw,logger,print_section,"BANNER",error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"BANNER") ! Just one force_env allowed - force_env_section => section_vals_get_subs_vals(input,"FORCE_EVAL",error=error) + force_env_section => section_vals_get_subs_vals(input,"FORCE_EVAL") ! Create Replica Environments CALL rep_env_create(rep_env, para_env=para_env, input=input,& - input_declaration=input_declaration,nrep=nrep,prep=prep,row_force=row_force,error=error) + input_declaration=input_declaration,nrep=nrep,prep=prep,row_force=row_force) IF (ASSOCIATED(rep_env)) THEN CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure) - CALL force_env_get(f_env%force_env,subsys=subsys,error=error) + failure=failure) + CALL force_env_get(f_env%force_env,subsys=subsys) particles => subsys%particles%els ! Decide which kind of Vibrational Analysis to perform IF (do_mode_tracking)THEN CALL ms_vb_anal(input,rep_env, para_env, globenv, particles,& - nrep,calc_intens,dx,output_unit, logger, error) - CALL f_env_rm_defaults(f_env,new_error,ierr) + nrep,calc_intens,dx,output_unit, logger) + CALL f_env_rm_defaults(f_env,ierr) ELSE - CALL get_moving_atoms(force_env=f_env%force_env,Ilist=Mlist,error=error) + CALL get_moving_atoms(force_env=f_env%force_env,Ilist=Mlist) something_frozen = SIZE(particles).NE.SIZE(Mlist) natoms=SIZE(Mlist) ncoord=natoms*3 ALLOCATE(Clist(ncoord), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mass(natoms), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pos0(ncoord), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Hessian(ncoord,ncoord),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calc_intens)THEN description='[DIPOLE]' ALLOCATE(tmp_dip(ncoord,3,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_dip=0._dp END IF Clist = 0 @@ -186,7 +182,7 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) Clist((i-1)*3+2) = (imap-1)*3+2 Clist((i-1)*3+3) = (imap-1)*3+3 mass(i) = particles(imap)%atomic_kind%mass - CPPostcondition(mass(i)>0.0_dp,cp_failure_level,routineP,error,failure) + CPPostcondition(mass(i)>0.0_dp,cp_failure_level,routineP,failure) mass(i)= SQRT(mass(i)) pos0((i-1)*3+1) = particles(imap)%r(1) pos0((i-1)*3+2) = particles(imap)%r(2) @@ -199,14 +195,14 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) IF (something_frozen) THEN nRotTrM = 0 ALLOCATE(RotTrM(natoms*3,nRotTrM),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL rot_ana(particles,RotTrM,nRotTrM,print_section,& - keep_rotations,mass_weighted=.TRUE.,natoms=natoms,error=error) + keep_rotations,mass_weighted=.TRUE.,natoms=natoms) END IF ! Generate the suitable rototranslating basis set CALL build_D_matrix(RotTrM,nRotTrM,D,full=.FALSE.,& - natoms=natoms,error=error) + natoms=natoms) ! ! Loop on atoms and coordinates ! @@ -224,18 +220,18 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) rep_env%r(imap,j) = rep_env%r(imap,j) + Dx END IF END DO - CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.,error=error) + CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.) DO j = 1, nrep IF(calc_intens)THEN IF (icoord+j <= ncoord) THEN CALL get_results(results=rep_env%results(j)%results,& description=description,& - n_rep=nres,error=error) + n_rep=nres) CALL get_results(results=rep_env%results(j)%results,& description=description,& values=tmp_dip(icoord+j,:,1),& - nval=nres,error=error) + nval=nres) END IF END IF IF (icoord+j <= ncoord) THEN @@ -278,7 +274,7 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) rep_env%r(imap,j) = rep_env%r(imap,j) - Dx END IF END DO - CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.,error=error) + CALL rep_env_calc_e_f(rep_env,calc_f=.TRUE.) DO j = 1, nrep IF (calc_intens) THEN @@ -286,11 +282,11 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) k=(icoord+j+2)/3 CALL get_results(results=rep_env%results(j)%results,& description=description,& - n_rep=nres,error=error) + n_rep=nres) CALL get_results(results=rep_env%results(j)%results,& description=description,& values=tmp_dip(icoord+j,:,2),& - nval=nres,error=error) + nval=nres) tmp_dip(icoord+j,:,1)=(tmp_dip(icoord+j,:,1)-tmp_dip(icoord+j,:,2))/(2.0_dp*Dx*mass(k)) END IF END IF @@ -342,7 +338,7 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) IF (output_unit>0) THEN WRITE(output_unit,'(T2,A)')"VIB| Hessian in cartesian coordinates" CALL write_particle_matrix(Hessian,particles,output_unit,el_per_part=3,& - Ilist=Mlist,error=error) + Ilist=Mlist) END IF ! Enforce symmetry in the Hessian DO i =1, ncoord @@ -353,27 +349,27 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) END DO nvib = ncoord-nRotTrM ALLOCATE(H_eigval1(ncoord),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(H_eigval2(SIZE(D,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Hint1(ncoord,ncoord),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Hint2(SIZE(D,2),SIZE(D,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rmass(SIZE(D,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(konst(SIZE(D,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calc_intens)THEN ALLOCATE(dip_deriv(3,SIZE(D,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dip_deriv=0.0_dp END IF ALLOCATE(intensities(SIZE(D,2)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) intensities= 0._dp Hint1(:,:) = Hessian - CALL diamat_all(Hint1,H_eigval1,error=error) + CALL diamat_all(Hint1,H_eigval1) IF (output_unit>0) THEN WRITE(output_unit,'(T2,"VIB| Cartesian Low frequencies ---",4G12.5)')& (H_eigval1(i),i=1,MIN(9,ncoord)) @@ -385,7 +381,7 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) dip_deriv(i,:)=MATMUL(tmp_dip(:,i,1),D) END DO END IF - CALL diamat_all(Hint2,H_eigval2,error=error) + CALL diamat_all(Hint2,H_eigval2) IF (output_unit>0) THEN WRITE(output_unit,'(T2,"VIB| Frequencies after removal of the rotations and translations")') ! Frequency at the moment are in a.u. @@ -424,7 +420,7 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) CALL vib_out(iw,nvib,D,konst,rmass,H_eigval2,particles,Mlist, intensities) END IF IF(.NOT.something_frozen) CALL molden_out(input,particles,H_eigval2,D,intensities,calc_intens,& - dump_only_positive=.FALSE.,logger=logger,error=error) + dump_only_positive=.FALSE.,logger=logger) ELSE IF (output_unit>0) THEN WRITE(output_unit,'(T2,"VIB| No further vibrational info. Detected a single atom")') @@ -432,42 +428,42 @@ SUBROUTINE vb_anal(input, input_declaration, para_env, globenv, error) END IF ! Deallocate working arrays DEALLOCATE(Clist,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Mlist,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(H_eigval1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(H_eigval2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Hint1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Hint2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rmass,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(konst,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mass, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pos0, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(D,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Hessian,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calc_intens)THEN DEALLOCATE(dip_deriv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_dip,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(intensities,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL f_env_rm_defaults(f_env,new_error,ierr) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL f_env_rm_defaults(f_env,ierr) END IF END IF - CALL cp_print_key_finished_output(output_unit,logger,print_section,"PROGRAM_RUN_INFO",error=error) - CALL rep_env_release(rep_env,error=error) + CALL cp_print_key_finished_output(output_unit,logger,print_section,"PROGRAM_RUN_INFO") + CALL rep_env_release(rep_env) CALL timestop(handle) END SUBROUTINE vb_anal @@ -475,13 +471,11 @@ END SUBROUTINE vb_anal !> \brief give back a list of moving atoms !> \param force_env ... !> \param Ilist ... -!> \param error ... !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE get_moving_atoms(force_env, Ilist, error) + SUBROUTINE get_moving_atoms(force_env, Ilist) TYPE(force_env_type), POINTER :: force_env INTEGER, DIMENSION(:), POINTER :: Ilist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_moving_atoms', & routineP = moduleN//':'//routineN @@ -505,10 +499,10 @@ SUBROUTINE get_moving_atoms(force_env, Ilist, error) failure = .FALSE. CALL timeset(routineN,handle) - CALL force_env_get(force_env=force_env, subsys=subsys, error=error) + CALL force_env_get(force_env=force_env, subsys=subsys) CALL cp_subsys_get(subsys=subsys,particles=particles, & - molecule_kinds_new=molecule_kinds, error=error) + molecule_kinds_new=molecule_kinds) nkind = molecule_kinds % n_els molecule_kind_set => molecule_kinds % els @@ -522,15 +516,15 @@ SUBROUTINE get_moving_atoms(force_env, Ilist, error) nfixed_atoms_total = nfixed_atoms_total + nfixed_atoms END DO ndim = SIZE(particle_set)-nfixed_atoms_total - CPPostcondition(ndim>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(ndim>=0,cp_failure_level,routineP,failure) ALLOCATE(Ilist(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (nfixed_atoms_total/=0) THEN ALLOCATE(ifixd_list(nfixed_atoms_total),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(work(nfixed_atoms_total),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nfixed_atoms_total = 0 DO ikind = 1, nkind molecule_kind => molecule_kind_set(ikind) @@ -559,9 +553,9 @@ SUBROUTINE get_moving_atoms(force_env, Ilist, error) END IF END DO Loop_count DEALLOCATE(ifixd_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(work,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE i = 1 ndim = 0 @@ -641,16 +635,14 @@ END SUBROUTINE vib_out !> \param Dout ... !> \param full ... !> \param natoms ... -!> \param error ... !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE build_D_matrix(mat,dof,Dout,full,natoms,error) + SUBROUTINE build_D_matrix(mat,dof,Dout,full,natoms) REAL(KIND=dp), DIMENSION(:, :), POINTER :: mat INTEGER, INTENT(IN) :: dof REAL(KIND=dp), DIMENSION(:, :), POINTER :: Dout LOGICAL, OPTIONAL :: full INTEGER, INTENT(IN) :: natoms - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_D_matrix', & routineP = moduleN//':'//routineN @@ -670,15 +662,15 @@ SUBROUTINE build_D_matrix(mat,dof,Dout,full,natoms,error) ! Generate the missing vectors of the orthogonal basis set nvib = 3*natoms-dof ALLOCATE(work(3*natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(D(3*natoms,3*natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Check First orthogonality in the first element of the basis set DO i = 1, dof D(:,i) = mat(:,i) DO j = i+1, dof norm = DOT_PRODUCT(mat(:,i),mat(:,j)) - CPPostcondition(ABS(norm) independent random number generator for each atom in all force !> environment and all the subsystems/fragments therein. !> \param md_env ... -!> \param error ... !> \par History !> Creation (06.07.2005,MK) ! ***************************************************************************** - SUBROUTINE create_wiener_process(md_env,error) + SUBROUTINE create_wiener_process(md_env) TYPE(md_environment_type), POINTER :: md_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_wiener_process', & routineP = moduleN//':'//routineN @@ -86,25 +84,25 @@ SUBROUTINE create_wiener_process(md_env,error) failure = .FALSE. NULLIFY(work_section,force_env) - CPPrecondition (ASSOCIATED(md_env),cp_failure_level,routineP,error,failure) + CPPrecondition (ASSOCIATED(md_env),cp_failure_level,routineP,failure) CALL get_md_env(md_env=md_env, force_env=force_env, para_env=para_env,& - simpar=simpar, error=error) + simpar=simpar) ![NB] shouldn't the calling process know if it's needed - IF (need_per_atom_wiener_process(md_env, error=error)) THEN + IF (need_per_atom_wiener_process(md_env)) THEN ! Load initial seed (not needed for a restart) - initial_seed = next_rng_seed(error=error) + initial_seed = next_rng_seed() CALL force_env_get(force_env,force_env_section=force_env_section,& - subsys=subsys,error=error) + subsys=subsys) - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") CALL cp_subsys_get(subsys=subsys,atomic_kinds=atomic_kinds,local_particles=local_particles,& - particles=particles,error=error) + particles=particles) nparticle_kind = atomic_kinds%n_els nparticle = particles%n_els @@ -112,12 +110,12 @@ SUBROUTINE create_wiener_process(md_env,error) ! Allocate the (local) data structures for the Wiener process ALLOCATE(local_particles%local_particle_set(nparticle_kind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iparticle_kind=1,nparticle_kind nparticle_local = local_particles%n_el(iparticle_kind) ALLOCATE (local_particles%local_particle_set(iparticle_kind)%rng(nparticle_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iparticle_local=1,nparticle_local NULLIFY (local_particles%local_particle_set(iparticle_kind)%rng(iparticle_local)%stream) END DO @@ -127,16 +125,16 @@ SUBROUTINE create_wiener_process(md_env,error) ! quite fast and in this way a broadcast is avoided. ALLOCATE (seed(3,2,nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) seed(:,:,1) = initial_seed DO iparticle=2,nparticle - seed(:,:,iparticle) = next_rng_seed(seed(:,:,iparticle-1),error=error) + seed(:,:,iparticle) = next_rng_seed(seed(:,:,iparticle-1)) END DO ! Update initial seed - initial_seed = next_rng_seed(seed(:,:,nparticle),error=error) + initial_seed = next_rng_seed(seed(:,:,nparticle)) ! Create a random number stream (Wiener process) for each particle @@ -148,20 +146,20 @@ SUBROUTINE create_wiener_process(md_env,error) CALL compress(name) CALL create_rng_stream(rng_stream=local_particles%local_particle_set(iparticle_kind)%& rng(iparticle_local)%stream,name=name,distribution_type=GAUSSIAN,& - extended_precision=.TRUE., seed=seed(:,:,iparticle),error=error) + extended_precision=.TRUE., seed=seed(:,:,iparticle)) END DO END DO DEALLOCATE (seed,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Possibly restart Wiener process NULLIFY (work_section) work_section => section_vals_get_subs_vals(section_vals=subsys_section,& - subsection_name="RNG_INIT", error=error) + subsection_name="RNG_INIT") CALL init_local_particle_set(distribution_1d=local_particles,& nparticle_kind=nparticle_kind, & - work_section=work_section,error=error) + work_section=work_section) END IF END SUBROUTINE create_wiener_process @@ -171,17 +169,15 @@ END SUBROUTINE create_wiener_process !> \param distribution_1d ... !> \param nparticle_kind ... !> \param work_section ... -!> \param error ... !> \par History !> 01.2014 moved from distribution_1d_types (Ole Schuett) ! ***************************************************************************** SUBROUTINE init_local_particle_set(distribution_1d,nparticle_kind,& - work_section,error) + work_section) TYPE(distribution_1d_type), POINTER :: distribution_1d INTEGER, INTENT(in) :: nparticle_kind TYPE(section_vals_type), POINTER :: work_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_local_particle_set', & routineP = moduleN//':'//routineN @@ -196,10 +192,10 @@ SUBROUTINE init_local_particle_set(distribution_1d,nparticle_kind,& failure = .FALSE. - CPPrecondition (ASSOCIATED(distribution_1d),cp_failure_level,routineP,error,failure) + CPPrecondition (ASSOCIATED(distribution_1d),cp_failure_level,routineP,failure) IF (ASSOCIATED(work_section)) THEN - CALL section_vals_get(work_section,explicit=explicit,error=error) + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN DO iparticle_kind=1,nparticle_kind nparticle_local = distribution_1d%n_el(iparticle_kind) @@ -209,13 +205,11 @@ SUBROUTINE init_local_particle_set(distribution_1d,nparticle_kind,& CALL section_vals_val_get(section_vals=work_section,& keyword_name="_DEFAULT_KEYWORD_",& i_rep_val=iparticle,& - c_val=rng_record,& - error=error) + c_val=rng_record) CALL read_rng_stream(rng_stream=distribution_1d%& local_particle_set(iparticle_kind)%& rng(iparticle_local)%stream,& - rng_record=rng_record,& - error=error) + rng_record=rng_record) END IF END DO END DO @@ -229,15 +223,13 @@ END SUBROUTINE init_local_particle_set !> metadynamics and initialize an !> independent random number generator for each COLVAR. !> \param meta_env ... -!> \param error ... !> \date 01.2009 !> \author Fabio Sterpone !> ! ***************************************************************************** - SUBROUTINE create_wiener_process_cv(meta_env,error) + SUBROUTINE create_wiener_process_cv(meta_env) TYPE(meta_env_type), POINTER :: meta_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_wiener_process_cv', & routineP = moduleN//':'//routineN @@ -252,7 +244,7 @@ SUBROUTINE create_wiener_process_cv(meta_env,error) failure=.FALSE. IF (.NOT.ASSOCIATED(meta_env)) RETURN - initial_seed = next_rng_seed(error=error) + initial_seed = next_rng_seed() DO i_c=1,meta_env%n_colvar NULLIFY (meta_env%rng(i_c)%stream) @@ -262,25 +254,25 @@ SUBROUTINE create_wiener_process_cv(meta_env,error) ! quite fast and in this way a broadcast is avoided. ALLOCATE (seed(3,2,meta_env%n_colvar),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) seed(:,:,1) = initial_seed DO i_c=2,meta_env%n_colvar - seed(:,:,i_c) = next_rng_seed(seed(:,:,i_c-1),error=error) + seed(:,:,i_c) = next_rng_seed(seed(:,:,i_c-1)) END DO ! Update initial seed - initial_seed = next_rng_seed(seed(:,:,meta_env%n_colvar),error=error) + initial_seed = next_rng_seed(seed(:,:,meta_env%n_colvar)) ! Create a random number stream (Wiener process) for each particle DO i_c=1,meta_env%n_colvar WRITE (UNIT=name,FMT="(A,I8)") "Wiener process for COLVAR",i_c CALL compress(name) CALL create_rng_stream(rng_stream=meta_env%rng(i_c)%stream,name=name,distribution_type=GAUSSIAN,& - extended_precision=.TRUE., seed=seed(:,:,i_c),error=error) + extended_precision=.TRUE., seed=seed(:,:,i_c)) END DO DEALLOCATE (seed,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE create_wiener_process_cv diff --git a/src/motion_utils.F b/src/motion_utils.F index 4b8a79ea1c..8f8281dde7 100644 --- a/src/motion_utils.F +++ b/src/motion_utils.F @@ -71,11 +71,10 @@ MODULE motion_utils !> \param mass_weighted ... !> \param natoms ... !> \param rot_dof ... -!> \param error ... !> \author Teodoro Laino 08.2006 ! ***************************************************************************** SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weighted,& - natoms, rot_dof, error) + natoms, rot_dof) TYPE(particle_type), DIMENSION(:), & POINTER :: particles REAL(KIND=dp), DIMENSION(:, :), & @@ -85,7 +84,6 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig LOGICAL, INTENT(IN) :: keep_rotations, mass_weighted INTEGER, INTENT(IN) :: natoms INTEGER, INTENT(OUT), OPTIONAL :: rot_dof - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rot_ana', & routineP = moduleN//':'//routineN @@ -101,12 +99,12 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig TYPE(cp_logger_type), POINTER :: logger CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. present_mat = PRESENT(mat) - CPPostcondition(ASSOCIATED(particles),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(particles),cp_failure_level,routineP,failure) IF (present_mat) THEN - CPPostcondition(.NOT.ASSOCIATED(mat),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(mat),cp_failure_level,routineP,failure) END IF IF (.NOT.keep_rotations) THEN rcom = 0.0_dp @@ -115,11 +113,11 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig DO iparticle = 1, natoms mass = 1.0_dp IF (mass_weighted) mass = particles(iparticle)%atomic_kind%mass - CPPostcondition(mass>=0.0_dp,cp_failure_level,routineP,error,failure) + CPPostcondition(mass>=0.0_dp,cp_failure_level,routineP,failure) masst = masst + mass rcom = particles(iparticle)%r * mass + rcom END DO - CPPostcondition(masst>0.0_dp,cp_failure_level,routineP,error,failure) + CPPostcondition(masst>0.0_dp,cp_failure_level,routineP,failure) rcom = rcom / masst ! Intertia Tensor Ip = 0.0_dp @@ -135,8 +133,8 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig Ip(2,3) = Ip(2,3) - mass * ( rm(2)*rm(3) ) END DO ! Diagonalize the Inertia Tensor - CALL diamat_all(Ip,Ip_eigval,error=error) - iw=cp_print_key_unit_nr(logger,print_section,"ROTATIONAL_INFO",extension=".vibLog",error=error) + CALL diamat_all(Ip,Ip_eigval) + iw=cp_print_key_unit_nr(logger,print_section,"ROTATIONAL_INFO",extension=".vibLog") IF (iw>0) THEN WRITE(iw,'(T2,A,3F12.6)')"ROT| Rotational Analysis Info " WRITE(iw,'(T2,A)')"ROT| Principal axes and moments of inertia in atomic units:" @@ -146,8 +144,8 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig WRITE(iw,'(T2,A,T27,3(3X,F15.9))')"ROT| Y",Ip(2,1),Ip(2,2),Ip(2,3) WRITE(iw,'(T2,A,T27,3(3X,F15.9))')"ROT| Z",Ip(3,1),Ip(3,2),Ip(3,3) END IF - CALL cp_print_key_finished_output(iw,logger,print_section,"ROTATIONAL_INFO",error=error) - iw=cp_print_key_unit_nr(logger,print_section,"ROTATIONAL_INFO/COORDINATES",extension=".vibLog",error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"ROTATIONAL_INFO") + iw=cp_print_key_unit_nr(logger,print_section,"ROTATIONAL_INFO/COORDINATES",extension=".vibLog") IF (iw>0) THEN WRITE(iw,'(/,T2,A)')"ROT| Standard Molecule Orientation - ANGSTROM " DO iparticle = 1, natoms @@ -156,11 +154,11 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig MATMUL(particles(iparticle)%r,Ip)*angstrom END DO END IF - CALL cp_print_key_finished_output(iw,logger,print_section,"ROTATIONAL_INFO/COORDINATES",error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"ROTATIONAL_INFO/COORDINATES") END IF ! Build up the Translational vectors ALLOCATE(Tr(natoms*3,3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Tr = 0.0_dp DO k = 1, 3 iseq = 0 @@ -181,7 +179,7 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig dof = 3 ! Build up the Rotational vectors ALLOCATE(Rot(natoms*3,3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lrot = 0 IF (.NOT.keep_rotations) THEN DO iparticle = 1, natoms @@ -224,17 +222,17 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig END IF IF (PRESENT(rot_dof)) rot_dof = COUNT(lrot==1) dof = dof + COUNT(lrot==1) - iw=cp_print_key_unit_nr(logger,print_section,"ROTATIONAL_INFO",extension=".vibLog",error=error) + iw=cp_print_key_unit_nr(logger,print_section,"ROTATIONAL_INFO",extension=".vibLog") IF (iw>0) THEN WRITE(iw,'(T2,A,I6)')"ROT| Numer of Rotovibrational vectors:",dof IF (dof==5) WRITE(iw,'(T2,A)')"ROT| Linear Molecule detected.." IF (dof==3.AND.(.NOT.keep_rotations)) WRITE(iw,'(T2,A)')"ROT| Single Atom detected.." END IF - CALL cp_print_key_finished_output(iw,logger,print_section,"ROTATIONAL_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"ROTATIONAL_INFO") IF (present_mat) THEN ! Give back the vectors generating the rototranslating Frame ALLOCATE(mat(natoms*3,dof),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iseq = 0 DO i = 1, 3 mat(:,i)=Tr(:,i) @@ -245,9 +243,9 @@ SUBROUTINE rot_ana(particles, mat, dof, print_section, keep_rotations, mass_weig END DO END IF DEALLOCATE(Tr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Rot,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE rot_ana @@ -265,13 +263,12 @@ END SUBROUTINE rot_ana !> \param middle_name ... !> \param particles ... !> \param extended_xmol_title ... -!> \param error ... !> \date 02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich !> \version 1.0 ! ***************************************************************************** SUBROUTINE write_trajectory (force_env, root_section, it, time, dtime, etot, pk_name,& - pos, act, middle_name, particles, extended_xmol_title, error) + pos, act, middle_name, particles, extended_xmol_title) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section INTEGER, INTENT(IN) :: it @@ -283,7 +280,6 @@ SUBROUTINE write_trajectory (force_env, root_section, it, time, dtime, etot, pk_ TYPE(particle_list_type), OPTIONAL, & POINTER :: particles LOGICAL, INTENT(IN), OPTIONAL :: extended_xmol_title - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_trajectory', & routineP = moduleN//':'//routineN @@ -313,7 +309,7 @@ SUBROUTINE write_trajectory (force_env, root_section, it, time, dtime, etot, pk_ failure = .FALSE. NULLIFY(logger, cell, subsys, my_particles, particle_set) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() id_label = logger%iter_info%level_name(logger%iter_info%n_rlevel) my_pos = "APPEND" my_act = "WRITE" @@ -338,19 +334,19 @@ SUBROUTINE write_trajectory (force_env, root_section, it, time, dtime, etot, pk_ id_dcd = "FML " id_wpc = "FORCE_MIXING_LABELS" CASE DEFAULT - CPPostcondition(.FALSE.,cp_fatal_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_fatal_level,routineP,failure) END SELECT charge_occup = .FALSE. charge_beta = .FALSE. charge_extended = .FALSE. - CALL force_env_get(force_env, cell=cell, subsys=subsys, error=error) + CALL force_env_get(force_env, cell=cell, subsys=subsys) IF (PRESENT(particles)) THEN - CPPostcondition(ASSOCIATED(particles),cp_fatal_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(particles),cp_fatal_level,routineP,failure) my_particles => particles ELSE - CALL cp_subsys_get(subsys=subsys, particles=my_particles,error=error) + CALL cp_subsys_get(subsys=subsys, particles=my_particles) END IF particle_set => my_particles%els nat=my_particles%n_els @@ -358,26 +354,25 @@ SUBROUTINE write_trajectory (force_env, root_section, it, time, dtime, etot, pk_ ! Gather units of measure for output (if available) IF (TRIM(my_pk_name) /= "FORCE_MIXING_LABELS") THEN CALL section_vals_val_get(root_section,"MOTION%PRINT%"//TRIM(my_pk_name)//"%UNIT",& - c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) ENDIF ! Get the otuput format - CALL get_output_format(root_section,"MOTION%PRINT%"//TRIM(my_pk_name),my_form,my_ext,error) + CALL get_output_format(root_section,"MOTION%PRINT%"//TRIM(my_pk_name),my_form,my_ext) traj_unit = cp_print_key_unit_nr(logger,root_section,"MOTION%PRINT%"//TRIM(my_pk_name),& extension=my_ext, file_position=my_pos, file_action=my_act,& - file_form=my_form, middle_name=TRIM(my_middle), is_new_file=new_file,& - error=error) + file_form=my_form, middle_name=TRIM(my_middle), is_new_file=new_file) IF (traj_unit > 0) THEN CALL section_vals_val_get(root_section,"MOTION%PRINT%"//TRIM(my_pk_name)//"%FORMAT",& - i_val=outformat,error=error) + i_val=outformat) title = "" SELECT CASE (outformat) CASE (dump_dcd,dump_dcd_aligned_cell) IF (new_file) THEN !Lets write the header for the coordinate dcd section_ref = "MOTION%PRINT%"//TRIM(my_pk_name)//"%EACH%"//TRIM(id_label) - iskip = section_get_ival(root_section,TRIM(section_ref),error=error) + iskip = section_get_ival(root_section,TRIM(section_ref)) WRITE (UNIT=traj_unit) id_dcd,0,it,iskip,0,0,0,0,0,0,REAL(dtime,KIND=sp),& 1,0,0,0,0,0,0,0,0,24 remark1 = "REMARK "//id_dcd//" DCD file created by "//TRIM(cp2k_version)//& @@ -402,11 +397,11 @@ SUBROUTINE write_trajectory (force_env, root_section, it, time, dtime, etot, pk_ CASE (dump_pdb) IF (id_wpc == "POS") THEN CALL section_vals_val_get(root_section,"MOTION%PRINT%TRAJECTORY%CHARGE_OCCUP",& - l_val=charge_occup,error=error) + l_val=charge_occup) CALL section_vals_val_get(root_section,"MOTION%PRINT%TRAJECTORY%CHARGE_BETA",& - l_val=charge_beta,error=error) + l_val=charge_beta) CALL section_vals_val_get(root_section,"MOTION%PRINT%TRAJECTORY%CHARGE_EXTENDED",& - l_val=charge_extended,error=error) + l_val=charge_extended) i = COUNT((/charge_occup,charge_beta,charge_extended/)) CALL cp_assert((i <= 1),cp_failure_level,cp_assertion_failed,routineP,& "Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected, "//& @@ -432,43 +427,42 @@ SUBROUTINE write_trajectory (force_env, root_section, it, time, dtime, etot, pk_ "Step ",it,", E = ",etot END IF CASE DEFAULT - CPPostcondition(.FALSE.,cp_fatal_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_fatal_level,routineP,failure) END SELECT IF (TRIM(my_pk_name) == "FORCE_MIXING_LABELS") THEN ALLOCATE (fml_array(3*SIZE(particle_set)),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) fml_array = 0.0_dp - CALL force_env_get(force_env, force_env_section=force_env_section, error=error) + CALL force_env_get(force_env, force_env_section=force_env_section) force_mixing_restart_section => section_vals_get_subs_vals(force_env_section, & "QMMM%FORCE_MIXING%RESTART_INFO",& - can_return_null=.TRUE., error=error) + can_return_null=.TRUE.) IF (ASSOCIATED(force_mixing_restart_section)) THEN - CALL section_vals_get(force_mixing_restart_section,explicit=explicit,error=error) + CALL section_vals_get(force_mixing_restart_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(force_mixing_restart_section,"INDICES",i_vals=force_mixing_indices,error=error) - CALL section_vals_val_get(force_mixing_restart_section,"LABELS",i_vals=force_mixing_labels,error=error) + CALL section_vals_val_get(force_mixing_restart_section,"INDICES",i_vals=force_mixing_indices) + CALL section_vals_val_get(force_mixing_restart_section,"LABELS",i_vals=force_mixing_labels) DO i=1, SIZE(force_mixing_indices) ii = force_mixing_indices(i) - CPPostcondition(ii <= SIZE(particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(ii <= SIZE(particle_set),cp_failure_level,routineP,failure) fml_array((ii-1)*3+1:(ii-1)*3+3) = force_mixing_labels(i) END DO ENDIF ENDIF CALL write_particle_coordinates(particle_set,traj_unit,outformat,TRIM(id_wpc),TRIM(title),cell,& - array=fml_array,error=error) + array=fml_array) DEALLOCATE (fml_array,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) ELSE CALL write_particle_coordinates(particle_set,traj_unit,outformat,TRIM(id_wpc),TRIM(title),cell,& unit_conv=unit_conv,& charge_occup=charge_occup,& charge_beta=charge_beta,& - charge_extended=charge_extended,& - error=error) + charge_extended=charge_extended) END IF END IF - CALL cp_print_key_finished_output(traj_unit,logger,root_section,"MOTION%PRINT%"//TRIM(my_pk_name),error=error) + CALL cp_print_key_finished_output(traj_unit,logger,root_section,"MOTION%PRINT%"//TRIM(my_pk_name)) CALL timestop(handle) @@ -480,15 +474,13 @@ END SUBROUTINE write_trajectory !> \param path ... !> \param my_form ... !> \param my_ext ... -!> \param error ... !> \author Teodoro Laino - University of Zurich - 07.2007 ! ***************************************************************************** - SUBROUTINE get_output_format(section,path,my_form,my_ext,error) + SUBROUTINE get_output_format(section,path,my_form,my_ext) TYPE(section_vals_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: path CHARACTER(LEN=*), INTENT(OUT) :: my_form, my_ext - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_output_format', & routineP = moduleN//':'//routineN @@ -496,9 +488,9 @@ SUBROUTINE get_output_format(section,path,my_form,my_ext,error) INTEGER :: output_format IF (PRESENT(path)) THEN - CALL section_vals_val_get(section,TRIM(path)//"%FORMAT",i_val=output_format,error=error) + CALL section_vals_val_get(section,TRIM(path)//"%FORMAT",i_val=output_format) ELSE - CALL section_vals_val_get(section,"FORMAT",i_val=output_format,error=error) + CALL section_vals_val_get(section,"FORMAT",i_val=output_format) END IF SELECT CASE (output_format) @@ -524,13 +516,12 @@ END SUBROUTINE get_output_format !> \param time ... !> \param pos ... !> \param act ... -!> \param error ... !> \date 02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich !> \version 1.0 ! ***************************************************************************** SUBROUTINE write_stress_tensor(virial,cell,motion_section,itimes,time,pos,& - act,error) + act) TYPE(virial_type), POINTER :: virial TYPE(cell_type), POINTER :: cell @@ -539,7 +530,6 @@ SUBROUTINE write_stress_tensor(virial,cell,motion_section,itimes,time,pos,& REAL(KIND=dp), INTENT(IN) :: time CHARACTER(LEN=default_string_length), & INTENT(IN), OPTIONAL :: pos, act - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_stress_tensor', & routineP = moduleN//':'//routineN @@ -551,7 +541,7 @@ SUBROUTINE write_stress_tensor(virial,cell,motion_section,itimes,time,pos,& TYPE(cp_logger_type), POINTER :: logger NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (virial%pv_availability) THEN my_pos = "APPEND" @@ -561,7 +551,7 @@ SUBROUTINE write_stress_tensor(virial,cell,motion_section,itimes,time,pos,& output_unit = cp_print_key_unit_nr(logger,motion_section,"PRINT%STRESS",& extension=".stress",file_position=my_pos,& file_action=my_act,file_form="FORMATTED",& - is_new_file=new_file,error=error) + is_new_file=new_file) ELSE output_unit = 0 END IF @@ -571,15 +561,15 @@ SUBROUTINE write_stress_tensor(virial,cell,motion_section,itimes,time,pos,& WRITE (UNIT=output_unit,FMT='(A,9(12X,A2," [bar]"),6X,A)')& "# Step Time [fs]","xx","xy","xz","yx","yy","yz","zx","zy","zz" END IF - pv_total_bar(1,1) = cp_unit_from_cp2k(virial%pv_total(1,1)/cell%deth,"bar",error=error) - pv_total_bar(1,2) = cp_unit_from_cp2k(virial%pv_total(1,2)/cell%deth,"bar",error=error) - pv_total_bar(1,3) = cp_unit_from_cp2k(virial%pv_total(1,3)/cell%deth,"bar",error=error) - pv_total_bar(2,1) = cp_unit_from_cp2k(virial%pv_total(2,1)/cell%deth,"bar",error=error) - pv_total_bar(2,2) = cp_unit_from_cp2k(virial%pv_total(2,2)/cell%deth,"bar",error=error) - pv_total_bar(2,3) = cp_unit_from_cp2k(virial%pv_total(2,3)/cell%deth,"bar",error=error) - pv_total_bar(3,1) = cp_unit_from_cp2k(virial%pv_total(3,1)/cell%deth,"bar",error=error) - pv_total_bar(3,2) = cp_unit_from_cp2k(virial%pv_total(3,2)/cell%deth,"bar",error=error) - pv_total_bar(3,3) = cp_unit_from_cp2k(virial%pv_total(3,3)/cell%deth,"bar",error=error) + pv_total_bar(1,1) = cp_unit_from_cp2k(virial%pv_total(1,1)/cell%deth,"bar") + pv_total_bar(1,2) = cp_unit_from_cp2k(virial%pv_total(1,2)/cell%deth,"bar") + pv_total_bar(1,3) = cp_unit_from_cp2k(virial%pv_total(1,3)/cell%deth,"bar") + pv_total_bar(2,1) = cp_unit_from_cp2k(virial%pv_total(2,1)/cell%deth,"bar") + pv_total_bar(2,2) = cp_unit_from_cp2k(virial%pv_total(2,2)/cell%deth,"bar") + pv_total_bar(2,3) = cp_unit_from_cp2k(virial%pv_total(2,3)/cell%deth,"bar") + pv_total_bar(3,1) = cp_unit_from_cp2k(virial%pv_total(3,1)/cell%deth,"bar") + pv_total_bar(3,2) = cp_unit_from_cp2k(virial%pv_total(3,2)/cell%deth,"bar") + pv_total_bar(3,3) = cp_unit_from_cp2k(virial%pv_total(3,3)/cell%deth,"bar") WRITE (UNIT=output_unit,FMT='(I8,F12.3,9(1X,F19.10))') itimes,time,& pv_total_bar(1,1),pv_total_bar(1,2),pv_total_bar(1,3),& pv_total_bar(2,1),pv_total_bar(2,2),pv_total_bar(2,3),& @@ -589,7 +579,7 @@ SUBROUTINE write_stress_tensor(virial,cell,motion_section,itimes,time,pos,& IF (virial%pv_availability) THEN CALL cp_print_key_finished_output(output_unit,logger,motion_section,& - "PRINT%STRESS",error=error) + "PRINT%STRESS") END IF END SUBROUTINE write_stress_tensor @@ -602,13 +592,11 @@ END SUBROUTINE write_stress_tensor !> \param time ... !> \param pos ... !> \param act ... -!> \param error ... !> \date 02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_simulation_cell(cell,motion_section,itimes,time,pos,act,& - error) + SUBROUTINE write_simulation_cell(cell,motion_section,itimes,time,pos,act) TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: motion_section @@ -616,7 +604,6 @@ SUBROUTINE write_simulation_cell(cell,motion_section,itimes,time,pos,act,& REAL(KIND=dp), INTENT(IN) :: time CHARACTER(LEN=default_string_length), & INTENT(IN), OPTIONAL :: pos, act - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_simulation_cell', & routineP = moduleN//':'//routineN @@ -627,7 +614,7 @@ SUBROUTINE write_simulation_cell(cell,motion_section,itimes,time,pos,act,& TYPE(cp_logger_type), POINTER :: logger NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_pos = "APPEND" my_act = "WRITE" @@ -637,7 +624,7 @@ SUBROUTINE write_simulation_cell(cell,motion_section,itimes,time,pos,act,& output_unit = cp_print_key_unit_nr(logger,motion_section,"PRINT%CELL",& extension=".cell",file_position=my_pos,& file_action=my_act,file_form="FORMATTED",& - is_new_file=new_file,error=error) + is_new_file=new_file) IF (output_unit > 0) THEN IF (new_file) THEN @@ -654,7 +641,7 @@ SUBROUTINE write_simulation_cell(cell,motion_section,itimes,time,pos,act,& END IF CALL cp_print_key_finished_output(output_unit,logger,motion_section,& - "PRINT%CELL",error=error) + "PRINT%CELL") END SUBROUTINE write_simulation_cell diff --git a/src/mp2.F b/src/mp2.F index be0864cfcc..a82930cdd1 100644 --- a/src/mp2.F +++ b/src/mp2.F @@ -116,13 +116,11 @@ MODULE mp2 !> \brief the main entry point for MP2 calculations !> \param qs_env ... !> \param calc_forces ... -!> \param error ... !> \author Mauro Del Ben ! ***************************************************************************** - SUBROUTINE mp2_main(qs_env,calc_forces,error) + SUBROUTINE mp2_main(qs_env,calc_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calc_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mp2_main', & routineP = moduleN//':'//routineN @@ -183,7 +181,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) NULLIFY(virial, dft_control, blacs_env) CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL cite_reference(DelBen2012) @@ -203,11 +201,10 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) matrix_s=matrix_s,& matrix_ks_aux_fit=matrix_ks_aux,& mp2_env=mp2_env,& - admm_env=admm_env,& - error=error) + admm_env=admm_env) unit_nr = cp_print_key_unit_nr(logger,input,"DFT%XC%WF_CORRELATION%MP2_INFO",& - extension=".mp2Log",error=error) + extension=".mp2Log") IF (unit_nr>0) THEN IF(mp2_env%method.NE.ri_rpa_method_gpw) THEN @@ -269,13 +266,13 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) natom = SIZE(particle_set,1) ALLOCATE(kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of) nkind = SIZE(atomic_kind_set,1) - CALL hfx_create_basis_types(basis_parameter,basis_info, qs_kind_set, do_admm=.FALSE., error=error) + CALL hfx_create_basis_types(basis_parameter,basis_info, qs_kind_set, do_admm=.FALSE.) dimen=0 max_nset=0 @@ -286,7 +283,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) END DO CALL get_mo_set( mo_set=mos(1)%mo_set,nao=nao) - CPPostcondition(dimen==nao,cp_failure_level,routineP,error,failure) + CPPostcondition(dimen==nao,cp_failure_level,routineP,failure) ! diagonalize the KS matrix in order to have the full set of MO's ! get S and KS matrices in fm_type (create also a working array) @@ -296,26 +293,26 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) NULLIFY(fm_struct) CALL cp_dbcsr_get_info(matrix_s(1)%matrix,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix_s,fm_struct,name="fm_matrix_s",error=error) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, fm_matrix_s, error=error) + ncol_global=nfullcols_total,para_env=para_env) + CALL cp_fm_create(fm_matrix_s,fm_struct,name="fm_matrix_s") + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, fm_matrix_s) - CALL cp_fm_create(fm_matrix_ks,fm_struct,name="fm_matrix_ks",error=error) + CALL cp_fm_create(fm_matrix_ks,fm_struct,name="fm_matrix_ks") - CALL cp_fm_create(fm_matrix_work,fm_struct,name="fm_matrix_work",error=error) - CALL cp_fm_set_all(matrix=fm_matrix_work,alpha=0.0_dp,error=error) + CALL cp_fm_create(fm_matrix_work,fm_struct,name="fm_matrix_work") + CALL cp_fm_set_all(matrix=fm_matrix_work,alpha=0.0_dp) - CALL cp_fm_struct_release(fm_struct,error=error) + CALL cp_fm_struct_release(fm_struct) - CALL cp_fm_get_info(matrix=fm_matrix_ks,nrow_block=nrow_block,ncol_block=ncol_block,error=error) + CALL cp_fm_get_info(matrix=fm_matrix_ks,nrow_block=nrow_block,ncol_block=ncol_block) ! calculate S^(-1/2) (cholescky decomposition) - CALL cp_fm_cholesky_decompose(fm_matrix_s,error=error) - CALL cp_fm_triangular_invert(fm_matrix_s,error=error) + CALL cp_fm_cholesky_decompose(fm_matrix_s) + CALL cp_fm_triangular_invert(fm_matrix_s) NULLIFY(mos_mp2) ALLOCATE(mos_mp2(nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1, nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,maxocc=maxocc,nelectron=nelectron) @@ -326,37 +323,32 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) nelectron=nelectron,& n_el_f=REAL(nelectron,dp),& maxocc=maxocc,& - flexible_electron_count=dft_control%relax_multiplicity,& - error=error) + flexible_electron_count=dft_control%relax_multiplicity) END DO NULLIFY(my_mpools) - CALL mpools_create(mpools=my_mpools,error=error) + CALL mpools_create(mpools=my_mpools) CALL mpools_rebuild_fm_pools(mpools=my_mpools,& mos=mos_mp2,& blacs_env=blacs_env,& - para_env=para_env,& - error=error) + para_env=para_env) DO ispin=1, nspins ! If ADMM we should make the ks matrix up-to-date IF(dft_control%do_admm) THEN - CALL admm_correct_for_eigenvalues(ispin, admm_env, matrix_ks(ispin)%matrix, & - error) + CALL admm_correct_for_eigenvalues(ispin, admm_env, matrix_ks(ispin)%matrix) END IF - CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix, fm_matrix_ks, error=error) + CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix, fm_matrix_ks) IF(dft_control%do_admm) THEN - CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, matrix_ks(ispin)%matrix, & - error) + CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, matrix_ks(ispin)%matrix) END IF CALL init_mo_set(mos_mp2(ispin)%mo_set,& my_mpools%ao_mo_fm_pools(ispin)%pool,& - name="mp2_mos",& - error=error) + name="mp2_mos") ! diagonalize KS matrix cholesky_method=cholesky_inverse @@ -365,21 +357,20 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) ortho=fm_matrix_s,& work=fm_matrix_work,& cholesky_method=cholesky_method,& - use_jacobi=.FALSE.,& - error=error) + use_jacobi=.FALSE.) END DO - CALL cp_fm_release(fm_matrix_s, error=error) - CALL cp_fm_release(fm_matrix_ks, error=error) - CALL cp_fm_release(fm_matrix_work, error=error) - CALL mpools_release(mpools=my_mpools, error=error) + CALL cp_fm_release(fm_matrix_s) + CALL cp_fm_release(fm_matrix_ks) + CALL cp_fm_release(fm_matrix_work) + CALL mpools_release(mpools=my_mpools) - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF",error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF") ! build the table of index t1=m_walltime() ALLOCATE(mp2_biel%index_table(natom,max_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL build_index_table(natom,max_nset,mp2_biel%index_table,basis_parameter,kind_of) @@ -397,11 +388,11 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) ! calculate the matrix sigma_x - vxc for G0W0 t3=0 IF(mp2_env%ri_rpa%do_ri_g0w0) THEN - CALL compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,E_ex_from_GW,t3,error) + CALL compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,E_ex_from_GW,t3) END IF IF(free_hfx_buffer) THEN CALL timeset(routineN//"_free_hfx",handle2) - CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf,error=error) + CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf) n_threads = 1 !$ n_threads = omp_get_max_threads() @@ -419,16 +410,16 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) END IF IF(.NOT. actual_x_data%memory_parameter%do_all_on_the_fly) THEN - CALL dealloc_containers(actual_x_data, hfx_do_eval_energy, error) - ! CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy, error) + CALL dealloc_containers(actual_x_data, hfx_do_eval_energy) + ! CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy) ! ! DO bin=1, my_bin_size ! maxval_container => actual_x_data%maxval_container(bin) ! integral_containers => actual_x_data%integral_containers(:,bin) - ! CALL hfx_init_container(maxval_container, actual_x_data%memory_parameter%actual_memory_usage, .FALSE., error) + ! CALL hfx_init_container(maxval_container, actual_x_data%memory_parameter%actual_memory_usage, .FALSE.) ! DO i=1,64 ! CALL hfx_init_container(integral_containers(i), & - ! actual_x_data%memory_parameter%actual_memory_usage, .FALSE., error) + ! actual_x_data%memory_parameter%actual_memory_usage, .FALSE.) ! END DO ! END DO END IF @@ -447,7 +438,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) CASE(mp2_method_laplace) CALL cp_unimplemented_error(fromWhere=routineP, & message="laplace not implemented",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE (mp2_method_direct) !DO i=1,SIZE(mos) ! CALL get_mo_set( mo_set=mos(i)%mo_set,& @@ -472,12 +463,12 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) eigenvalues=mo_eigenvalues,& mo_coeff=mo_coeff) ALLOCATE(C_alpha(dimen,dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Auto_alpha(dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_fm_get_submatrix(mo_coeff,C_alpha, 1, 1, dimen, dimen, .FALSE., error) + CALL cp_fm_get_submatrix(mo_coeff,C_alpha, 1, 1, dimen, dimen, .FALSE.) Auto_alpha(:)=mo_eigenvalues(:) ! get the beta coeff and eigenvalues @@ -486,12 +477,12 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) eigenvalues=mo_eigenvalues,& mo_coeff=mo_coeff) ALLOCATE(C_beta(dimen,dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Auto_beta(dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_fm_get_submatrix(mo_coeff,C_beta, 1, 1, dimen, dimen, .FALSE., error) + CALL cp_fm_get_submatrix(mo_coeff,C_beta, 1, 1, dimen, dimen, .FALSE.) Auto_beta(:)=mo_eigenvalues(:) ! calculate the alpha-alpha MP2 @@ -500,7 +491,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) Emp2_AA_ex=0.0_dp CALL mp2_direct_energy(dimen,nelec_alpha,nelec_alpha,mp2_biel,mp2_env,C_alpha,Auto_alpha,Emp2_AA,Emp2_AA_Cou,Emp2_AA_ex,& qs_env,rho,para_env, & - unit_nr,error=error) + unit_nr) IF (unit_nr>0) WRITE(unit_nr,'(T3,A,T56,F25.14)') 'MP2 Energy Alpha-Alpha = ', Emp2_AA IF (unit_nr>0) WRITE(unit_nr,*) @@ -509,7 +500,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) Emp2_BB_ex=0.0_dp CALL mp2_direct_energy(dimen,nelec_beta,nelec_beta,mp2_biel,mp2_env,C_beta,Auto_beta,Emp2_BB,Emp2_BB_Cou,Emp2_BB_ex,& qs_env,rho,para_env, & - unit_nr,error=error) + unit_nr) IF (unit_nr>0) WRITE(unit_nr,'(T3,A,T56,F25.14)') 'MP2 Energy Beta-Beta= ', Emp2_BB IF (unit_nr>0) WRITE(unit_nr,*) @@ -519,7 +510,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) CALL mp2_direct_energy(dimen,nelec_alpha,nelec_beta,mp2_biel,mp2_env,C_alpha,& Auto_alpha,Emp2_AB,Emp2_AB_Cou,Emp2_AB_ex,& qs_env,rho,para_env, & - unit_nr,C_beta,Auto_beta,error=error) + unit_nr,C_beta,Auto_beta) IF (unit_nr>0) WRITE(unit_nr,'(T3,A,T56,F25.14)') 'MP2 Energy Alpha-Beta= ', Emp2_AB IF (unit_nr>0) WRITE(unit_nr,*) @@ -538,18 +529,18 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) eigenvalues=mo_eigenvalues,& mo_coeff=mo_coeff) ALLOCATE(C(dimen,dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Auto(dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_fm_get_submatrix(mo_coeff,C, 1, 1, dimen, dimen, .FALSE., error) + CALL cp_fm_get_submatrix(mo_coeff,C, 1, 1, dimen, dimen, .FALSE.) Auto(:)=mo_eigenvalues(:) CALL mp2_direct_energy(dimen,nelectron/2,nelectron/2,mp2_biel,mp2_env,C,Auto,Emp2,Emp2_Cou,Emp2_ex,& qs_env,rho,para_env, & - unit_nr,error=error) + unit_nr) END IF @@ -566,12 +557,12 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) eigenvalues=mo_eigenvalues,& mo_coeff=mo_coeff) ALLOCATE(C(dimen,dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Auto(dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_fm_get_submatrix(mo_coeff,C, 1, 1, dimen, dimen, .FALSE., error) + CALL cp_fm_get_submatrix(mo_coeff,C, 1, 1, dimen, dimen, .FALSE.) Auto(:)=mo_eigenvalues(:) IF(nspins==2) THEN @@ -581,19 +572,19 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) eigenvalues=mo_eigenvalues,& mo_coeff=mo_coeff) ALLOCATE(C_beta(dimen,dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Auto_beta(dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_fm_get_submatrix(mo_coeff,C_beta, 1, 1, dimen, dimen, .FALSE., error) + CALL cp_fm_get_submatrix(mo_coeff,C_beta, 1, 1, dimen, dimen, .FALSE.) Auto_beta(:)=mo_eigenvalues(:) ! optimize basis CALL optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,natom,nelectron, & mp2_biel,mp2_env,C,Auto,& kind_of,qs_env,rho,para_env, & - unit_nr,error,& + unit_nr,& nelec_beta,C_beta,Auto_beta) ELSE @@ -601,7 +592,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) CALL optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,natom,nelectron/2, & mp2_biel,mp2_env,C,Auto,& kind_of,qs_env,rho,para_env, & - unit_nr,error) + unit_nr) END IF CASE (mp2_method_gpw) @@ -610,7 +601,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) ! go with mp2_gpw CALL mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& - mos_mp2,para_env,unit_nr,calc_forces,calc_ex,error) + mos_mp2,para_env,unit_nr,calc_forces,calc_ex) CASE (ri_mp2_method_gpw) ! check if calculate the exchange contribution @@ -618,7 +609,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) ! go with mp2_gpw CALL mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& - mos_mp2,para_env,unit_nr,calc_forces,calc_ex,error,do_ri_mp2=.TRUE.) + mos_mp2,para_env,unit_nr,calc_forces,calc_ex,do_ri_mp2=.TRUE.) CASE(ri_rpa_method_gpw) ! perform RI-RPA energy calculation (since most part of the calculation @@ -629,7 +620,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) ! go with ri_rpa_gpw CALL mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& - mos_mp2,para_env,unit_nr,calc_forces,calc_ex,error,do_ri_rpa=.TRUE.) + mos_mp2,para_env,unit_nr,calc_forces,calc_ex,do_ri_rpa=.TRUE.) CASE(ri_mp2_laplace) ! perform RI-SOS-Laplace-MP2 energy calculation, most part of the code in common @@ -640,10 +631,10 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) ! go with sos_laplace_mp2_gpw CALL mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& - mos_mp2,para_env,unit_nr,calc_forces,calc_ex,error,do_ri_sos_laplace_mp2=.TRUE.) + mos_mp2,para_env,unit_nr,calc_forces,calc_ex,do_ri_sos_laplace_mp2=.TRUE.) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT t2=m_walltime() IF (unit_nr>0) WRITE(unit_nr,*) @@ -687,7 +678,7 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) energy%total=energy%total+Emp2 DO ispin=1, nspins - CALL deallocate_mo_set(mo_set=mos_mp2(ispin)%mo_set,error=error) + CALL deallocate_mo_set(mo_set=mos_mp2(ispin)%mo_set) END DO DEALLOCATE(mos_mp2) @@ -708,15 +699,15 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) END IF IF(.NOT. actual_x_data%memory_parameter%do_all_on_the_fly) THEN - ! CALL dealloc_containers(actual_x_data, hfx_do_eval_energy, error) - CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy, error) + ! CALL dealloc_containers(actual_x_data, hfx_do_eval_energy) + CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy) DO bin=1, my_bin_size maxval_container => actual_x_data%maxval_container(bin) integral_containers => actual_x_data%integral_containers(:,bin) - CALL hfx_init_container(maxval_container, actual_x_data%memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(maxval_container, actual_x_data%memory_parameter%actual_memory_usage, .FALSE.) DO i=1,64 - CALL hfx_init_container(integral_containers(i), actual_x_data%memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(integral_containers(i), actual_x_data%memory_parameter%actual_memory_usage, .FALSE.) END DO END DO END IF @@ -725,20 +716,20 @@ SUBROUTINE mp2_main(qs_env,calc_forces,error) CALL timestop(handle2) END IF - CALL hfx_release_basis_types(basis_parameter,error) + CALL hfx_release_basis_types(basis_parameter) ! if required calculate the EXX contribution from the DFT density IF(mp2_env%method==ri_rpa_method_gpw) THEN do_exx=.FALSE. - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION%RI_RPA%HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_exx,error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION%RI_RPA%HF") + CALL section_vals_get(hfx_sections,explicit=do_exx) IF(do_exx) THEN - CALL calculate_exx(qs_env,unit_nr,mp2_env%ri_rpa%do_ri_g0w0,E_ex_from_GW,t3,error) + CALL calculate_exx(qs_env,unit_nr,mp2_env%ri_rpa%do_ri_g0w0,E_ex_from_GW,t3) END IF END IF CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%XC%WF_CORRELATION%MP2_INFO", error=error) + "DFT%XC%WF_CORRELATION%MP2_INFO") CALL timestop(handle) @@ -794,11 +785,10 @@ END SUBROUTINE build_index_table !> \param unit_nr ... !> \param C_j ... !> \param Auto_j ... -!> \param error ... ! ***************************************************************************** SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2,Emp2_Cou,Emp2_ex,& qs_env,rho,para_env, & - unit_nr,C_j,Auto_j,error) + unit_nr,C_j,Auto_j) INTEGER :: dimen, occ_i, occ_j TYPE(mp2_biel_type) :: mp2_biel TYPE(mp2_type), POINTER :: mp2_env @@ -813,7 +803,6 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, OPTIONAL :: C_j REAL(KIND=dp), DIMENSION(dimen), & OPTIONAL :: Auto_j - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mp2_direct_energy', & routineP = moduleN//':'//routineN @@ -865,7 +854,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, color_sub=para_env%mepos/mp2_env%mp2_num_proc CALL mp_comm_split_direct(para_env%group,comm_sub,color_sub) NULLIFY(para_env_sub) - CALL cp_para_env_create(para_env_sub,comm_sub,error=error) + CALL cp_para_env_create(para_env_sub,comm_sub) ! calculate the maximal size of the batch, according to the maximum RS size max_set=SIZE(mp2_biel%index_table,2) @@ -899,7 +888,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, total_I_size_batch_group=occ_i/number_i_subset IF(total_I_size_batch_group<1) total_I_size_batch_group=1 ALLOCATE(vector_batch_I_size_group(0:number_i_subset-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vector_batch_I_size_group=0 DO i=0, number_i_subset-1 @@ -920,7 +909,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, total_J_size_batch_group=occ_j/number_j_subset IF(total_J_size_batch_group<1) total_J_size_batch_group=1 ALLOCATE(vector_batch_J_size_group(0:number_j_subset-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vector_batch_J_size_group=0 DO i=0, number_J_subset-1 @@ -978,7 +967,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, ! create the size of the batches inside the group my_batch_size=my_I_batch_size ALLOCATE(batch_sizes(my_batch_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) batch_sizes=-HUGE(0) batch_number=0 @@ -994,11 +983,11 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, END IF ALLOCATE(batch_sizes_tmp(batch_number),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) batch_sizes_tmp(1:batch_number)=batch_sizes(1:batch_number) DEALLOCATE(batch_sizes) ALLOCATE(batch_sizes(batch_number),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) batch_sizes(:)=batch_sizes_tmp DEALLOCATE(batch_sizes_tmp) @@ -1013,7 +1002,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, END IF ! Batches sizes exceed the occupied orbitals allocated for group - CPPostcondition(SUM(batch_sizes)<=my_batch_size,cp_failure_level,routineP,error,failure) + CPPostcondition(SUM(batch_sizes)<=my_batch_size,cp_failure_level,routineP,failure) virt_i=dimen-occ_i virt_j=dimen-occ_j @@ -1032,7 +1021,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, counter=-1 ALLOCATE(ij_matrix(Ni_occupied,Nj_occupied),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ij_matrix=0 DO i=1, Ni_occupied @@ -1045,7 +1034,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, END DO ALLOCATE(ij_list_proc_temp(Ni_occupied*occ_j,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) elements_ij_proc=0 DO i=1, Ni_occupied @@ -1068,13 +1057,12 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, IF(.NOT.alpha_beta_case) THEN CALL mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_env,rho,para_env_sub,& mp2_biel,dimen,C_i,Auto_i,i_batch_start,Ni_occupied,occ_i,& - elements_ij_proc, ij_list_proc,Nj_occupied,j_batch_start,& - error=error) + elements_ij_proc, ij_list_proc,Nj_occupied,j_batch_start) ELSE CALL mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_env,rho,para_env_sub,& mp2_biel,dimen,C_i,Auto_i,i_batch_start,Ni_occupied,occ_i,& elements_ij_proc, ij_list_proc,Nj_occupied,j_batch_start,& - occ_j,C_j,Auto_j,error=error) + occ_j,C_j,Auto_j) END IF i_batch_start=i_batch_start+Ni_occupied @@ -1087,7 +1075,7 @@ SUBROUTINE mp2_direct_energy(dimen,occ_i,occ_j,mp2_biel,mp2_env,C_i,Auto_i,Emp2, CALL mp_sum(Emp2_Ex,para_env%group) CALL mp_sum(Emp2,para_env%group) - CALL cp_para_env_release(para_env_sub,error) + CALL cp_para_env_release(para_env_sub) CALL timestop(handle) @@ -1100,14 +1088,12 @@ END SUBROUTINE mp2_direct_energy !> \param do_gw ... !> \param E_ex_from_GW ... !> \param t3 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_exx(qs_env,unit_nr,do_gw,E_ex_from_GW,t3,error) + SUBROUTINE calculate_exx(qs_env,unit_nr,do_gw,E_ex_from_GW,t3) TYPE(qs_environment_type), POINTER :: qs_env INTEGER :: unit_nr LOGICAL :: do_gw REAL(KIND=dp) :: E_ex_from_GW, t3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_exx', & routineP = moduleN//':'//routineN @@ -1137,18 +1123,17 @@ SUBROUTINE calculate_exx(qs_env,unit_nr,do_gw,E_ex_from_GW,t3,error) para_env=para_env, & energy=energy, & rho=rho, & - matrix_ks=matrix_ks, & - error=error) + matrix_ks=matrix_ks) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION%RI_RPA%HF",error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION%RI_RPA%HF") - CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf,error=error) + CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf) ! put matrix_ks to zero DO i=1, SIZE(matrix_ks) - CALL cp_dbcsr_set(matrix_ks(i)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ks(i)%matrix,0.0_dp) END DO ! Remove the Exchange-correlation energy contributions from the total energy @@ -1172,7 +1157,7 @@ SUBROUTINE calculate_exx(qs_env,unit_nr,do_gw,E_ex_from_GW,t3,error) matrix_ks_2d(1:ns,1:1) => matrix_ks(1:ns) CALL integrate_four_center(qs_env, matrix_ks_2d, energy, rho_ao_2d, hfx_sections,& para_env, .TRUE., irep, .TRUE.,& - ispin=1, error=error, do_exx=.TRUE.) + ispin=1,do_exx=.TRUE.) END DO ! include the EXX contribution to the total energy @@ -1198,18 +1183,16 @@ END SUBROUTINE calculate_exx !> \param mos_mp2 ... !> \param energy_ex ... !> \param t3 ... -!> \param error ... !> \par History !> 04.2015 created !> \author Jan Wilhelm ! ***************************************************************************** - SUBROUTINE compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,energy_ex,t3,error) + SUBROUTINE compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,energy_ex,t3) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mp2_type), POINTER :: mp2_env TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos_mp2 REAL(KIND=dp) :: energy_ex, t3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'compute_vec_Sigma_x_minus_vxc_gw', & @@ -1251,62 +1234,61 @@ SUBROUTINE compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,energy_ex,t3, input=input,& dft_control=dft_control,& para_env=para_env,& - ks_env=ks_env,& - error=error) + ks_env=ks_env) ! GW on top of HFX with ADMM is not working. Please, converge an SCF with ADMM, ! print the restart file, remove the ADMM section, add the RPA and GW section, ! set very lax SCF convergence parameters to converge the SCF in one step. IF(dft_control%do_admm) STOP "GW on top of ADMM is not implemented." - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) ! initialize matrix_sigma_x_minus_vxc ALLOCATE(matrix_sigma_x_minus_vxc(SIZE(matrix_ks))) DO ispin=1,SIZE(matrix_ks) NULLIFY(matrix_sigma_x_minus_vxc(ispin)%matrix) - CALL cp_dbcsr_init_p(matrix_sigma_x_minus_vxc(ispin)%matrix,error=error) + CALL cp_dbcsr_init_p(matrix_sigma_x_minus_vxc(ispin)%matrix) CALL cp_dbcsr_copy(matrix_sigma_x_minus_vxc(ispin)%matrix,matrix_ks(ispin)%matrix,& - name="Matrix VXC of spin "//cp_to_string(ispin),error=error) - CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp,error=error) + name="Matrix VXC of spin "//cp_to_string(ispin)) + CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp) ENDDO ! set DFT functional to none and hfx_fraction to zero - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx) IF(do_hfx) THEN hfx_fraction = qs_env%x_data(1,1)%general_parameter%fraction qs_env%x_data(:,:)%general_parameter%fraction = 0.0_dp END IF - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") CALL section_vals_val_get(xc_section,"XC_FUNCTIONAL%_SECTION_PARAMETERS_",& - i_val=myfun,error=error) + i_val=myfun) CALL section_vals_val_set(xc_section,"XC_FUNCTIONAL%_SECTION_PARAMETERS_",& - i_val=xc_none,error=error) + i_val=xc_none) ! calculate KS-matrix without XC and without HF CALL qs_ks_build_kohn_sham_matrix(qs_env=qs_env, calculate_forces=.FALSE.,& - just_energy=.FALSE.,error=error) + just_energy=.FALSE.) ! set the DFT functional and HF fraction back CALL section_vals_val_set(xc_section,"XC_FUNCTIONAL%_SECTION_PARAMETERS_",& - i_val=myfun,error=error) + i_val=myfun) IF(do_hfx) THEN qs_env%x_data(:,:)%general_parameter%fraction = hfx_fraction END IF ! remove the single-particle part (kin. En + Hartree pot) and change the sign DO ispin=1,dft_control%nspins - CALL cp_dbcsr_add(matrix_sigma_x_minus_vxc(ispin)%matrix, matrix_ks(ispin)%matrix, -1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_sigma_x_minus_vxc(ispin)%matrix, matrix_ks(ispin)%matrix, -1.0_dp, 1.0_dp) END DO DO ispin=1,dft_control%nspins - CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ks(ispin)%matrix,0.0_dp) END DO - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION%RI_RPA%HF",error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION%RI_RPA%HF") - CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf,error=error) + CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf) CALL allocate_qs_energy(energy_dummy) @@ -1320,20 +1302,20 @@ SUBROUTINE compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,energy_ex,t3, matrix_ks_2d(1:ns,1:1) => matrix_ks(1:ns) CALL integrate_four_center(qs_env,matrix_ks_2d,energy_dummy,rho_ao_2d,hfx_sections,& para_env,.TRUE.,irep,.TRUE.,& - ispin=1,error=error,do_exx=.TRUE.) + ispin=1,do_exx=.TRUE.) END DO DO ispin=1,dft_control%nspins - CALL cp_dbcsr_add(matrix_sigma_x_minus_vxc(ispin)%matrix, matrix_ks(ispin)%matrix, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_sigma_x_minus_vxc(ispin)%matrix, matrix_ks(ispin)%matrix, 1.0_dp, 1.0_dp) END DO energy_ex = energy_dummy%ex CALL deallocate_qs_energy(energy_dummy) - CALL cp_dbcsr_init (mo_coeff_b, error) - CALL cp_dbcsr_desymmetrize(matrix_ks(1)%matrix,mo_coeff_b,error) - CALL cp_dbcsr_set(mo_coeff_b, 0.0_dp, error) + CALL cp_dbcsr_init (mo_coeff_b) + CALL cp_dbcsr_desymmetrize(matrix_ks(1)%matrix,mo_coeff_b) + CALL cp_dbcsr_set(mo_coeff_b, 0.0_dp) ! Transform matrix_sigma_x_minus_vxc to MO basis DO ispin=1,dft_control%nspins @@ -1346,25 +1328,24 @@ SUBROUTINE compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,energy_ex,t3, IF(ispin==1) THEN ALLOCATE(vec_Sigma_x_minus_vxc_gw(nmo,dft_control%nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_Sigma_x_minus_vxc_gw=0.0_dp END IF - CALL cp_dbcsr_set(mo_coeff_b, 0.0_dp, error) - CALL copy_fm_to_dbcsr(mo_coeff,mo_coeff_b,keep_sparsity=.TRUE.,& - error=error) + CALL cp_dbcsr_set(mo_coeff_b, 0.0_dp) + CALL copy_fm_to_dbcsr(mo_coeff,mo_coeff_b,keep_sparsity=.TRUE.) ! initialize matrix_tmp and matrix_tmp2 IF(ispin==1) THEN - CALL cp_dbcsr_init(matrix_tmp, error=error) - CALL cp_dbcsr_create(matrix_tmp,template=mo_coeff_b,error=error) - CALL cp_dbcsr_copy(matrix_tmp,mo_coeff_b,error=error) - CALL cp_dbcsr_set(matrix_tmp, 0.0_dp, error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_create(matrix_tmp,template=mo_coeff_b) + CALL cp_dbcsr_copy(matrix_tmp,mo_coeff_b) + CALL cp_dbcsr_set(matrix_tmp, 0.0_dp) - CALL cp_dbcsr_init(matrix_tmp_2, error=error) - CALL cp_dbcsr_create(matrix_tmp_2,template=mo_coeff_b,error=error) - CALL cp_dbcsr_copy(matrix_tmp_2,mo_coeff_b,error=error) - CALL cp_dbcsr_set(matrix_tmp_2, 0.0_dp, error) + CALL cp_dbcsr_init(matrix_tmp_2) + CALL cp_dbcsr_create(matrix_tmp_2,template=mo_coeff_b) + CALL cp_dbcsr_copy(matrix_tmp_2,mo_coeff_b) + CALL cp_dbcsr_set(matrix_tmp_2, 0.0_dp) END IF gw_corr_lev_occ=mp2_env%ri_g0w0%corr_mos_occ @@ -1390,31 +1371,31 @@ SUBROUTINE compute_vec_Sigma_x_minus_vxc_gw(qs_env,mp2_env,mos_mp2,energy_ex,t3, CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_sigma_x_minus_vxc(ispin)%matrix,& mo_coeff_b,0.0_dp,matrix_tmp,first_column=homo+1-gw_corr_lev_occ,& - last_column=homo+gw_corr_lev_virt,error=error) + last_column=homo+gw_corr_lev_virt) CALL cp_dbcsr_multiply('T','N',1.0_dp,mo_coeff_b,& matrix_tmp,0.0_dp,matrix_tmp_2,first_row=homo+1-gw_corr_lev_occ,& - last_row=homo+gw_corr_lev_virt,error=error) + last_row=homo+gw_corr_lev_virt) - CALL cp_dbcsr_get_diag(matrix_tmp_2,vec_Sigma_x_minus_vxc_gw(:,ispin),error=error) + CALL cp_dbcsr_get_diag(matrix_tmp_2,vec_Sigma_x_minus_vxc_gw(:,ispin)) - CALL cp_dbcsr_set(matrix_tmp, 0.0_dp, error) - CALL cp_dbcsr_set(matrix_tmp_2, 0.0_dp, error) + CALL cp_dbcsr_set(matrix_tmp, 0.0_dp) + CALL cp_dbcsr_set(matrix_tmp_2, 0.0_dp) END DO CALL mp_sum(vec_Sigma_x_minus_vxc_gw,para_env%group) - CALL cp_dbcsr_release(mo_coeff_b,error) - CALL cp_dbcsr_release(matrix_tmp,error) - CALL cp_dbcsr_release(matrix_tmp_2,error) + CALL cp_dbcsr_release(mo_coeff_b) + CALL cp_dbcsr_release(matrix_tmp) + CALL cp_dbcsr_release(matrix_tmp_2) DO ispin=1,SIZE(matrix_ks) - CALL cp_dbcsr_release_p(matrix_sigma_x_minus_vxc(ispin)%matrix,error=error) + CALL cp_dbcsr_release_p(matrix_sigma_x_minus_vxc(ispin)%matrix) END DO ALLOCATE(mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(nmo,dft_control%nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! store vec_Sigma_x_minus_vxc_gw in the mp2_environment mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:,:) = vec_Sigma_x_minus_vxc_gw(:,:) diff --git a/src/mp2_cphf.F b/src/mp2_cphf.F index 6827dbb731..ff9b9604d6 100644 --- a/src/mp2_cphf.F +++ b/src/mp2_cphf.F @@ -119,14 +119,13 @@ MODULE mp2_cphf !> \param homo ... !> \param Eigenval ... !> \param unit_nr ... -!> \param error ... !> \param Eigenval_beta ... !> \param homo_beta ... !> \param mo_coeff_beta ... !> \author Mauro Del Ben, Vladimir Rybkin ! ***************************************************************************** SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& - atomic_kind_set,mo_coeff,nmo,homo,Eigenval,unit_nr,error,& + atomic_kind_set,mo_coeff,nmo,homo,Eigenval,unit_nr,& Eigenval_beta,homo_beta,mo_coeff_beta) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mp2_type), POINTER :: mp2_env @@ -138,7 +137,6 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& INTEGER :: nmo, homo REAL(KIND=dp), DIMENSION(:) :: Eigenval INTEGER :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), DIMENSION(:), OPTIONAL :: Eigenval_beta INTEGER, OPTIONAL :: homo_beta TYPE(cp_fm_type), OPTIONAL, POINTER :: mo_coeff_beta @@ -220,10 +218,9 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& force=force,& virial=virial,& rho_core=rho_core,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) ! check if we have to calculate the virial use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -243,111 +240,111 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& ! pw stuff NULLIFY(poisson_env,pw_pools,auxbas_pw_pool) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools, poisson_env=poisson_env, error=error) + pw_pools=pw_pools, poisson_env=poisson_env) ! get some of the grids ready NULLIFY(rho_r%pw,rho_g%pw,pot_g%pw) CALL pw_pool_create_pw(auxbas_pw_pool,rho_r%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,rho_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,pot_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) ! hfx section NULLIFY(hfx_sections) - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,n_repetition=n_rep_hf,error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx,n_repetition=n_rep_hf) IF( do_hfx ) THEN CALL section_vals_val_get(hfx_sections, "TREAT_LSD_IN_CORE", l_val=hfx_treat_lsd_in_core,& - i_rep_section=1,error=error) + i_rep_section=1) END IF ! create work array NULLIFY(mat_mu_nu) - CALL cp_dbcsr_allocate_matrix_set(mat_mu_nu, dft_control%nspins, error) + CALL cp_dbcsr_allocate_matrix_set(mat_mu_nu, dft_control%nspins) DO ispin=1,dft_control%nspins ALLOCATE(mat_mu_nu(ispin)%matrix) - CALL cp_dbcsr_init(mat_mu_nu(ispin)%matrix,error=error) + CALL cp_dbcsr_init(mat_mu_nu(ispin)%matrix) CALL cp_dbcsr_create(matrix=mat_mu_nu(ispin)%matrix,& name="T_mu_nu",& dist=cp_dbcsr_distribution(matrix_s(1)%matrix), matrix_type=dbcsr_type_symmetric,& row_blk_size=cp_dbcsr_row_block_sizes(matrix_s(1)%matrix),& col_blk_size=cp_dbcsr_col_block_sizes(matrix_s(1)%matrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(mat_mu_nu(ispin)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(mat_mu_nu(ispin)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(mat_mu_nu(ispin)%matrix,sab_orb) + CALL cp_dbcsr_set(mat_mu_nu(ispin)%matrix,0.0_dp) END DO ALLOCATE(P_mu_nu%matrix) - CALL cp_dbcsr_init(P_mu_nu%matrix,error=error) - ! CALL cp_dbcsr_create(P_mu_nu%matrix,template=mat_mu_nu(1)%matrix,error=error) - ! CALL cp_dbcsr_copy(P_mu_nu%matrix,mat_mu_nu(1)%matrix,name="P_mu_nu",error=error) - CALL cp_dbcsr_copy(P_mu_nu%matrix,rho_ao(1)%matrix,name="P_mu_nu",error=error) - CALL cp_dbcsr_set(P_mu_nu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_init(P_mu_nu%matrix) + ! CALL cp_dbcsr_create(P_mu_nu%matrix,template=mat_mu_nu(1)%matrix) + ! CALL cp_dbcsr_copy(P_mu_nu%matrix,mat_mu_nu(1)%matrix,name="P_mu_nu") + CALL cp_dbcsr_copy(P_mu_nu%matrix,rho_ao(1)%matrix,name="P_mu_nu") + CALL cp_dbcsr_set(P_mu_nu%matrix,0.0_dp) NULLIFY(fm_G_mu_nu, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=dimen,error=error) - CALL cp_fm_create(fm_G_mu_nu, fm_struct_tmp, name="G_mu_nu",error=error) - CALL cp_fm_create(fm_back, fm_struct_tmp, name="fm_back",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(fm_G_mu_nu, 0.0_dp,error=error) - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=dimen) + CALL cp_fm_create(fm_G_mu_nu, fm_struct_tmp, name="G_mu_nu") + CALL cp_fm_create(fm_back, fm_struct_tmp, name="fm_back") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(fm_G_mu_nu, 0.0_dp) + CALL cp_fm_set_all(fm_back, 0.0_dp) NULLIFY(mo_coeff_o, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=homo,error=error) - CALL cp_fm_create(mo_coeff_o, fm_struct_tmp, name="mo_coeff_o",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(mo_coeff_o, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=homo) + CALL cp_fm_create(mo_coeff_o, fm_struct_tmp, name="mo_coeff_o") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(mo_coeff_o, 0.0_dp) CALL cp_fm_to_fm_submat(msource=mo_coeff, mtarget=mo_coeff_o, & nrow=dimen, ncol=homo, & s_firstrow=1, s_firstcol=1, & - t_firstrow=1, t_firstcol=1, error=error) + t_firstrow=1, t_firstcol=1) NULLIFY(mo_coeff_v, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=virtual,error=error) - CALL cp_fm_create(mo_coeff_v, fm_struct_tmp, name="mo_coeff_v",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(mo_coeff_v, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=virtual) + CALL cp_fm_create(mo_coeff_v, fm_struct_tmp, name="mo_coeff_v") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(mo_coeff_v, 0.0_dp) CALL cp_fm_to_fm_submat(msource=mo_coeff, mtarget=mo_coeff_v, & nrow=dimen, ncol=virtual, & s_firstrow=1, s_firstcol=homo+1, & - t_firstrow=1, t_firstcol=1, error=error) + t_firstrow=1, t_firstcol=1) IF (alpha_beta) THEN NULLIFY(mo_coeff_o_beta, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=homo_beta,error=error) - CALL cp_fm_create(mo_coeff_o_beta, fm_struct_tmp, name="mo_coeff_o_beta",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(mo_coeff_o_beta, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=homo_beta) + CALL cp_fm_create(mo_coeff_o_beta, fm_struct_tmp, name="mo_coeff_o_beta") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(mo_coeff_o_beta, 0.0_dp) CALL cp_fm_to_fm_submat(msource=mo_coeff_beta, mtarget=mo_coeff_o_beta, & nrow=dimen, ncol=homo_beta, & s_firstrow=1, s_firstcol=1, & - t_firstrow=1, t_firstcol=1, error=error) + t_firstrow=1, t_firstcol=1) NULLIFY(mo_coeff_v_beta, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=virtual_beta,error=error) - CALL cp_fm_create(mo_coeff_v_beta, fm_struct_tmp, name="mo_coeff_v_beta",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(mo_coeff_v_beta, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=virtual_beta) + CALL cp_fm_create(mo_coeff_v_beta, fm_struct_tmp, name="mo_coeff_v_beta") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(mo_coeff_v_beta, 0.0_dp) CALL cp_fm_to_fm_submat(msource=mo_coeff_beta, mtarget=mo_coeff_v_beta, & nrow=dimen, ncol=virtual_beta, & s_firstrow=1, s_firstcol=homo_beta+1, & - t_firstrow=1, t_firstcol=1, error=error) + t_firstrow=1, t_firstcol=1) ENDIF ! create a working rho environment NULLIFY(rho_work) - CALL qs_rho_create(rho_work, error) - CALL qs_rho_rebuild(rho=rho_work, qs_env=qs_env, rebuild_ao=.TRUE., rebuild_grids=.FALSE., error=error) + CALL qs_rho_create(rho_work) + CALL qs_rho_rebuild(rho=rho_work, qs_env=qs_env, rebuild_ao=.TRUE., rebuild_grids=.FALSE.) ! here we check if we have to reallocate the HFX container IF(mp2_env%ri_mp2%free_hfx_buffer) THEN @@ -369,15 +366,15 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& END IF IF(.NOT. actual_x_data%memory_parameter%do_all_on_the_fly) THEN - ! CALL dealloc_containers(actual_x_data, hfx_do_eval_energy, error) - CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy, error) + ! CALL dealloc_containers(actual_x_data, hfx_do_eval_energy) + CALL alloc_containers(actual_x_data, my_bin_size, hfx_do_eval_energy) DO bin=1, my_bin_size maxval_container => actual_x_data%maxval_container(bin) integral_containers => actual_x_data%integral_containers(:,bin) - CALL hfx_init_container(maxval_container, actual_x_data%memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(maxval_container, actual_x_data%memory_parameter%actual_memory_usage, .FALSE.) DO i=1,64 - CALL hfx_init_container(integral_containers(i), actual_x_data%memory_parameter%actual_memory_usage, .FALSE., error) + CALL hfx_init_container(integral_containers(i), actual_x_data%memory_parameter%actual_memory_usage, .FALSE.) END DO END DO END IF @@ -412,7 +409,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - L_jb,transf_type_out,error,& + L_jb,transf_type_out,& recalc_hfx_integrals=mp2_env%ri_mp2%free_hfx_buffer,& factor=factor) IF (alpha_beta) THEN @@ -422,7 +419,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo_beta,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - L_jb,transf_type_out,error, & + L_jb,transf_type_out,& mo_coeff_beta=mo_coeff_beta, & mo_coeff_o_beta=mo_coeff_o_beta, & mo_coeff_v_beta=mo_coeff_v_beta, & @@ -434,7 +431,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& Eigenval_beta,hfx_sections,energy,n_rep_hf,& poisson_env,rho_work,pot_g,rho_g,rho_r,mat_mu_nu,& P_mu_nu,P_mo_beta,fm_G_mu_nu,fm_back,transf_type_in,& - out_alpha,L_jb_beta,transf_type_out,error,factor=factor) + out_alpha,L_jb_beta,transf_type_out,factor=factor) ! Alpha-beta (Coulomb) part of L_jb(beta) CALL cphf_like_update(qs_env,para_env,homo_beta,virtual_beta,dimen,& mo_coeff_beta,mo_coeff_o_beta,mo_coeff_v_beta, & @@ -442,7 +439,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - L_jb_beta,transf_type_out,error, & + L_jb_beta,transf_type_out,& mo_coeff_beta=mo_coeff, & mo_coeff_o_beta=mo_coeff_o, & mo_coeff_v_beta=mo_coeff_v, & @@ -460,7 +457,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - L_jb,transf_type_out,error,factor=factor) + L_jb,transf_type_out,factor=factor) IF (alpha_beta) THEN ! Alpha-beta (Coulomb) part of L_jb(alpha) CALL cphf_like_update(qs_env,para_env,homo,virtual,dimen,& @@ -468,7 +465,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo_beta,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - L_jb,transf_type_out,error, & + L_jb,transf_type_out,& mo_coeff_beta=mo_coeff_beta, & mo_coeff_o_beta=mo_coeff_o_beta, & mo_coeff_v_beta=mo_coeff_v_beta, & @@ -480,7 +477,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& Eigenval_beta,hfx_sections,energy,n_rep_hf,& poisson_env,rho_work,pot_g,rho_g,rho_r,mat_mu_nu,& P_mu_nu,P_mo_beta,fm_G_mu_nu,fm_back,transf_type_in,& - out_alpha,L_jb_beta,transf_type_out,error,factor=factor) + out_alpha,L_jb_beta,transf_type_out,factor=factor) ! Alpha-beta (Coulomb) part of L_jb(beta) CALL cphf_like_update(qs_env,para_env,homo_beta,virtual_beta,dimen,& mo_coeff_beta,mo_coeff_o_beta,mo_coeff_v_beta, & @@ -488,7 +485,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - L_jb_beta,transf_type_out,error, & + L_jb_beta,transf_type_out,& mo_coeff_beta=mo_coeff, & mo_coeff_o_beta=mo_coeff_o, & mo_coeff_v_beta=mo_coeff_v, & @@ -498,17 +495,17 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& ! P_ia will contain the solution of these equations NULLIFY(P_ia, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo,ncol_global=virtual,error=error) - CALL cp_fm_create(P_ia, fm_struct_tmp, name="P_ia",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(P_ia, 0.0_dp,error=error) + nrow_global=homo,ncol_global=virtual) + CALL cp_fm_create(P_ia, fm_struct_tmp, name="P_ia") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(P_ia, 0.0_dp) IF (alpha_beta) THEN NULLIFY(P_ia_beta, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo_beta,ncol_global=virtual_beta,error=error) - CALL cp_fm_create(P_ia_beta, fm_struct_tmp, name="P_ia_beta",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(P_ia_beta, 0.0_dp,error=error) + nrow_global=homo_beta,ncol_global=virtual_beta) + CALL cp_fm_create(P_ia_beta, fm_struct_tmp, name="P_ia_beta") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(P_ia_beta, 0.0_dp) ENDIF IF (.NOT. alpha_beta) THEN @@ -516,42 +513,42 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& mo_coeff,mo_coeff_o,mo_coeff_v,Eigenval,blacs_env, & hfx_sections,energy,n_rep_hf, & poisson_env,rho_work,pot_g,rho_g,rho_r,mat_mu_nu, & - P_mu_nu,L_jb,fm_G_mu_nu,fm_back,P_ia,error) + P_mu_nu,L_jb,fm_G_mu_nu,fm_back,P_ia) ELSE CALL solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit_nr,& mo_coeff,mo_coeff_o,mo_coeff_v,Eigenval,blacs_env,& hfx_sections,energy,n_rep_hf,& poisson_env,rho_work,pot_g,rho_g,rho_r,mat_mu_nu,& - P_mu_nu,L_jb,fm_G_mu_nu,fm_back,P_ia,error,& + P_mu_nu,L_jb,fm_G_mu_nu,fm_back,P_ia,& homo_beta,Eigenval_beta,P_ia_beta, mo_coeff_beta,& mo_coeff_o_beta, mo_coeff_v_beta, L_jb_beta) ENDIF ! release Lagrangian - CALL cp_fm_release(L_jb,error=error) - IF (alpha_beta) CALL cp_fm_release(L_jb_beta,error=error) + CALL cp_fm_release(L_jb) + IF (alpha_beta) CALL cp_fm_release(L_jb_beta) ! update the MP2-MO density matrix with the occ-virt block CALL cp_fm_to_fm_submat(msource=P_ia, mtarget=P_mo, & nrow=homo, ncol=virtual, & s_firstrow=1, s_firstcol=1, & - t_firstrow=1, t_firstcol=homo+1, error=error) - CALL cp_fm_release(P_ia,error=error) + t_firstrow=1, t_firstcol=homo+1) + CALL cp_fm_release(P_ia) ! transpose P_MO matrix (easy way to symmetrize) - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) ! P_mo now is ready - CALL cp_fm_upper_to_full(matrix=P_mo, work=fm_back, error=error) + CALL cp_fm_upper_to_full(matrix=P_mo, work=fm_back) IF (alpha_beta) THEN ! update the MP2-MO density matrix with the occ-virt block CALL cp_fm_to_fm_submat(msource=P_ia_beta, mtarget=P_mo_beta, & nrow=homo_beta, ncol=virtual_beta, & s_firstrow=1, s_firstcol=1, & - t_firstrow=1, t_firstcol=homo_beta+1, error=error) - CALL cp_fm_release(P_ia_beta,error=error) + t_firstrow=1, t_firstcol=homo_beta+1) + CALL cp_fm_release(P_ia_beta) ! transpose P_MO matrix (easy way to symmetrize) - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) ! P_mo now is ready - CALL cp_fm_upper_to_full(matrix=P_mo_beta, work=fm_back, error=error) + CALL cp_fm_upper_to_full(matrix=P_mo_beta, work=fm_back) ENDIF ! do the final update to MP2 energy weighted matrix W_MO @@ -559,8 +556,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) IF(j_global<=homo) THEN @@ -586,8 +582,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) IF(j_global<=homo_beta) THEN @@ -624,7 +619,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - W_mo,transf_type_out,error,factor=factor) + W_mo,transf_type_out,factor=factor) IF (alpha_beta) THEN ! Alpha-beta (Coulomb) part of W_mo(III)(alpha) CALL cphf_like_update(qs_env,para_env,homo,virtual,dimen,& @@ -632,7 +627,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo_beta,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - W_mo,transf_type_out,error, & + W_mo,transf_type_out,& mo_coeff_beta=mo_coeff_beta, & mo_coeff_o_beta=mo_coeff_o_beta, & mo_coeff_v_beta=mo_coeff_v_beta, & @@ -644,7 +639,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& Eigenval_beta,hfx_sections,energy,n_rep_hf,& poisson_env,rho_work,pot_g,rho_g,rho_r,mat_mu_nu,& P_mu_nu,P_mo_beta,fm_G_mu_nu,fm_back,transf_type_in,& - out_alpha,W_mo_beta,transf_type_out,error,factor=factor) + out_alpha,W_mo_beta,transf_type_out,factor=factor) ! Alpha-beta (Coulomb) part of W_mo(III)(beta) CALL cphf_like_update(qs_env,para_env,homo_beta,virtual_beta,dimen,& mo_coeff_beta,mo_coeff_o_beta,mo_coeff_v_beta, & @@ -652,7 +647,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& P_mo,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - W_mo_beta,transf_type_out,error, & + W_mo_beta,transf_type_out,& mo_coeff_beta=mo_coeff, & mo_coeff_o_beta=mo_coeff_o, & mo_coeff_v_beta=mo_coeff_v, & @@ -661,24 +656,24 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& ! release DBCSR stuff DO ispin=1, dft_control%nspins - CALL cp_dbcsr_release(mat_mu_nu(ispin)%matrix,error=error) + CALL cp_dbcsr_release(mat_mu_nu(ispin)%matrix) DEALLOCATE(mat_mu_nu(ispin)%matrix,STAT=stat) END DO DEALLOCATE(mat_mu_nu,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_release(P_mu_nu%matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_release(P_mu_nu%matrix) DEALLOCATE(P_mu_nu%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! release fm stuff - CALL cp_fm_release(fm_G_mu_nu,error=error) - CALL cp_fm_release(mo_coeff_o,error=error) - CALL cp_fm_release(mo_coeff_v,error=error) + CALL cp_fm_release(fm_G_mu_nu) + CALL cp_fm_release(mo_coeff_o) + CALL cp_fm_release(mo_coeff_v) IF (alpha_beta) THEN - CALL cp_fm_release(mo_coeff_o_beta,error=error) - CALL cp_fm_release(mo_coeff_v_beta,error=error) + CALL cp_fm_release(mo_coeff_o_beta) + CALL cp_fm_release(mo_coeff_v_beta) ENDIF ! release rho stuff - CALL qs_rho_release(rho_struct=rho_work,error=error) + CALL qs_rho_release(rho_struct=rho_work) IF(.FALSE.) THEN ALLOCATE(mat_deb(dimen,dimen)) @@ -687,8 +682,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -703,8 +697,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -722,8 +715,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -738,8 +730,7 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -756,76 +747,68 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& ! backtransform into AO basis, since P_mo and W_mo ! are symmetric (in principle), no need to symmetrize ! first W_mo - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,dimen,dimen,1.0_dp,& mo_coeff,W_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(W_mo, 0.0_dp,error=error) + CALL cp_fm_set_all(W_mo, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,dimen,1.0_dp,& fm_back,mo_coeff,0.0_dp,W_mo,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) ! and P_mo - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,dimen,dimen,1.0_dp,& mo_coeff,P_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(P_mo, 0.0_dp,error=error) + CALL cp_fm_set_all(P_mo, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,dimen,1.0_dp,& fm_back,mo_coeff,0.0_dp,P_mo,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) IF (alpha_beta) THEN - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,dimen,dimen,1.0_dp,& mo_coeff_beta,W_mo_beta,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(W_mo_beta, 0.0_dp,error=error) + CALL cp_fm_set_all(W_mo_beta, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,dimen,1.0_dp,& fm_back,mo_coeff_beta,0.0_dp,W_mo_beta,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) ! and P_mo - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,dimen,dimen,1.0_dp,& mo_coeff_beta,P_mo_beta,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(P_mo_beta, 0.0_dp,error=error) + CALL cp_fm_set_all(P_mo_beta, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,dimen,1.0_dp,& fm_back,mo_coeff_beta,0.0_dp,P_mo_beta,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -834,72 +817,71 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& ENDIF ! copy W_mo into dbcsr - CALL copy_fm_to_dbcsr(W_mo, matrix_w_mp2(1)%matrix, keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(W_mo, matrix_w_mp2(1)%matrix, keep_sparsity=.TRUE.) IF (alpha_beta) THEN - CALL copy_fm_to_dbcsr(W_mo_beta, matrix_w_mp2(2)%matrix, keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(W_mo_beta, matrix_w_mp2(2)%matrix, keep_sparsity=.TRUE.) ENDIF ! create mp2 DBCSR density - CALL cp_dbcsr_allocate_matrix_set(matrix_p_mp2,dft_control%nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_p_mp2,dft_control%nspins) DO ispin=1, dft_control%nspins ALLOCATE(matrix_p_mp2(ispin)%matrix) - CALL cp_dbcsr_init(matrix_p_mp2(ispin)%matrix,error=error) + CALL cp_dbcsr_init(matrix_p_mp2(ispin)%matrix) CALL cp_dbcsr_copy(matrix_p_mp2(ispin)%matrix,rho_ao(ispin)%matrix,& - name="P MATRIX MP2",error=error) - CALL cp_dbcsr_set(matrix_p_mp2(ispin)%matrix,0.0_dp,error=error) + name="P MATRIX MP2") + CALL cp_dbcsr_set(matrix_p_mp2(ispin)%matrix,0.0_dp) IF (ispin == 1) & - CALL copy_fm_to_dbcsr(P_mo, matrix_p_mp2(ispin)%matrix,keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(P_mo, matrix_p_mp2(ispin)%matrix,keep_sparsity=.TRUE.) IF (ispin == 2) & - CALL copy_fm_to_dbcsr(P_mo_beta, matrix_p_mp2(ispin)%matrix,keep_sparsity=.TRUE.,error=error) + CALL copy_fm_to_dbcsr(P_mo_beta, matrix_p_mp2(ispin)%matrix,keep_sparsity=.TRUE.) END DO - CALL set_ks_env(ks_env, matrix_p_mp2=matrix_p_mp2, error=error) + CALL set_ks_env(ks_env, matrix_p_mp2=matrix_p_mp2) - CALL cp_fm_release(fm_back,error=error) + CALL cp_fm_release(fm_back) ! release remaining fm stuff - CALL cp_fm_release(W_mo,error=error) - CALL cp_fm_release(P_mo,error=error) + CALL cp_fm_release(W_mo) + CALL cp_fm_release(P_mo) IF (alpha_beta) THEN - CALL cp_fm_release(W_mo_beta,error=error) - CALL cp_fm_release(P_mo_beta,error=error) + CALL cp_fm_release(W_mo_beta) + CALL cp_fm_release(P_mo_beta) ENDIF ! update the core-forces with the MP2-density contribution ! put MP2 density on the grid IF (alpha_beta) THEN ! In alpha_beta case, get the joint density - CALL cp_dbcsr_add(matrix_p_mp2(1)%matrix,matrix_p_mp2(2)%matrix,1.0_dp,1.0_dp, error) + CALL cp_dbcsr_add(matrix_p_mp2(1)%matrix,matrix_p_mp2(2)%matrix,1.0_dp,1.0_dp) ENDIF CALL calculate_rho_elec(matrix_p=matrix_p_mp2(1)%matrix,& rho=rho_r,& rho_gspace=rho_g,& total_rho=tot_rho_r,& ks_env=ks_env,& - soft_valid=.FALSE.,& - error=error) + soft_valid=.FALSE.) ! calculate the MP2 potential - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) ! calculate core forces - CALL integrate_v_core_rspace(rho_r, qs_env, error=error) + CALL integrate_v_core_rspace(rho_r, qs_env) DO ikind=1,SIZE(atomic_kind_set) force(ikind)%mp2_sep= force(ikind)%rho_core force(ikind)%rho_core=0.0_dp ENDDO ! right contribution IF (alpha_beta) THEN ! In alpha_beta case, get the joint density - CALL cp_dbcsr_add(rho_ao(1)%matrix,rho_ao(2)%matrix,1.0_dp,1.0_dp, error) - CALL cp_dbcsr_add(matrix_ks(1)%matrix,matrix_ks(2)%matrix,1.0_dp,1.0_dp, error) + CALL cp_dbcsr_add(rho_ao(1)%matrix,rho_ao(2)%matrix,1.0_dp,1.0_dp) + CALL cp_dbcsr_add(matrix_ks(1)%matrix,matrix_ks(2)%matrix,1.0_dp,1.0_dp) ENDIF CALL integrate_v_rspace(v_rspace=rho_r,pmat=rho_ao(1),hmat=matrix_ks(1),& - qs_env=qs_env,calculate_forces=.TRUE.,error=error) + qs_env=qs_env,calculate_forces=.TRUE.) IF (alpha_beta) THEN ! In alpha_beta case, get the initial densities back - CALL cp_dbcsr_add(rho_ao(1)%matrix,rho_ao(2)%matrix,1.0_dp,-1.0_dp, error) - CALL cp_dbcsr_add(matrix_p_mp2(1)%matrix,matrix_p_mp2(2)%matrix,1.0_dp,-1.0_dp, error) - CALL cp_dbcsr_add(matrix_ks(1)%matrix,matrix_ks(2)%matrix,1.0_dp,-1.0_dp, error) + CALL cp_dbcsr_add(rho_ao(1)%matrix,rho_ao(2)%matrix,1.0_dp,-1.0_dp) + CALL cp_dbcsr_add(matrix_p_mp2(1)%matrix,matrix_p_mp2(2)%matrix,1.0_dp,-1.0_dp) + CALL cp_dbcsr_add(matrix_ks(1)%matrix,matrix_ks(2)%matrix,1.0_dp,-1.0_dp) ENDIF IF(use_virial) THEN @@ -909,22 +891,22 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& NULLIFY(temp_pw_g%pw) CALL pw_pool_create_pw(auxbas_pw_pool,temp_pw_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) DO i=1, 3 NULLIFY(dvg(i)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,dvg(i)%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) END DO ! make a copy of the MP2 density in G space - CALL pw_copy(rho_g%pw, temp_pw_g%pw, error=error) + CALL pw_copy(rho_g%pw, temp_pw_g%pw) ! calculate MP2-like-hartree potential derivatives DO i=1, 3 comp=0 comp(i)=1 - CALL pw_copy(pot_g%pw, dvg(i)%pw, error=error) - CALL pw_derive(dvg(i)%pw, comp, error=error) + CALL pw_copy(pot_g%pw, dvg(i)%pw) + CALL pw_derive(dvg(i)%pw, comp) END DO ! calculate total SCF density and potential @@ -933,47 +915,46 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& rho_gspace=rho_g,& total_rho=tot_rho_r,& ks_env=ks_env,& - soft_valid=.FALSE.,& - error=error) + soft_valid=.FALSE.) ! and associated potential - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) ! don't forget the core density - CALL pw_axpy(rho_core%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) + CALL pw_axpy(rho_core%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) ! finally update virial with the volume contribution - e_hartree=pw_integral_ab(temp_pw_g%pw, pot_g%pw, error=error) + e_hartree=pw_integral_ab(temp_pw_g%pw, pot_g%pw) h_stress=0.0_dp DO alpha=1, 3 comp=0 comp(alpha)=1 - CALL pw_copy(pot_g%pw, rho_g%pw, error=error) - CALL pw_derive(rho_g%pw, comp, error=error) + CALL pw_copy(pot_g%pw, rho_g%pw) + CALL pw_derive(rho_g%pw, comp) h_stress(alpha,alpha)=-e_hartree DO beta=alpha, 3 h_stress(alpha,beta)=h_stress(alpha,beta) & - -2.0_dp*pw_integral_ab(rho_g%pw, dvg(beta)%pw, error=error)/fourpi + -2.0_dp*pw_integral_ab(rho_g%pw, dvg(beta)%pw)/fourpi h_stress (beta,alpha)=h_stress(alpha,beta) END DO END DO virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe,dp) ! free stuff - CALL pw_pool_give_back_pw(auxbas_pw_pool,temp_pw_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,temp_pw_g%pw) DO i=1, 3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,dvg(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dvg(i)%pw) END DO CALL timestop(handle2) END IF DO ispin=1, dft_control%nspins - CALL cp_dbcsr_add(rho_ao(ispin)%matrix, matrix_p_mp2(ispin)%matrix, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(rho_ao(ispin)%matrix, matrix_p_mp2(ispin)%matrix, 1.0_dp, 1.0_dp) END DO ! release stuff - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw) CALL timestop(handle) @@ -1016,7 +997,6 @@ SUBROUTINE solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& !> \param out_alpha ... !> \param fm_mo_out ... !> \param transf_type_out ... -!> \param error ... !> \param recalc_hfx_integrals ... !> \param mo_coeff_beta ... !> \param mo_coeff_o_beta ... @@ -1031,7 +1011,7 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& fm_mo,fm_ao,fm_back,transf_type_in,out_alpha,& - fm_mo_out,transf_type_out,error,recalc_hfx_integrals, & + fm_mo_out,transf_type_out,recalc_hfx_integrals, & mo_coeff_beta,mo_coeff_o_beta,mo_coeff_v_beta, & homo_beta, virtual_beta, factor) TYPE(qs_environment_type), POINTER :: qs_env @@ -1054,7 +1034,6 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& REAL(KIND=dp) :: out_alpha TYPE(cp_fm_type), POINTER :: fm_mo_out INTEGER :: transf_type_out - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, OPTIONAL :: recalc_hfx_integrals TYPE(cp_fm_type), OPTIONAL, POINTER :: mo_coeff_beta, & mo_coeff_o_beta, & @@ -1089,25 +1068,23 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& my_recalc_hfx_integrals=.FALSE. IF(PRESENT(recalc_hfx_integrals)) my_recalc_hfx_integrals=recalc_hfx_integrals - CALL get_qs_env(qs_env, ks_env=ks_env, error=error) + CALL get_qs_env(qs_env, ks_env=ks_env) ! perform back transformation SELECT CASE(transf_type_in) CASE(1) IF (.NOT. alpha_beta) THEN ! occ-occ block - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,homo,homo,1.0_dp,& mo_coeff_o,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,homo,1.0_dp,& fm_back,mo_coeff_o,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1115,19 +1092,17 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& c_first_row=1) ELSE ! occ-occ block - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,homo_beta,homo_beta,1.0_dp,& mo_coeff_o_beta,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,homo_beta,1.0_dp,& fm_back,mo_coeff_o_beta,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1138,38 +1113,34 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& CASE(2) IF (.NOT. alpha_beta) THEN ! virt-virt block - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,virtual,virtual,1.0_dp,& mo_coeff_v,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=homo+1,& b_first_row=homo+1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,virtual,1.0_dp,& fm_back,mo_coeff_v,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) ELSE - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,virtual_beta,virtual_beta,1.0_dp,& mo_coeff_v_beta,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=homo_beta+1,& b_first_row=homo_beta+1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,virtual_beta,1.0_dp,& fm_back,mo_coeff_v_beta,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1179,29 +1150,26 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& CASE(3) IF (.NOT. alpha_beta) THEN - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,virtual,homo,1.0_dp,& mo_coeff_o,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,virtual,1.0_dp,& fm_back,mo_coeff_v,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) ! and symmetrize (here again multiply instead of transposing) - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','T',dimen,homo,virtual,1.0_dp,& mo_coeff_v,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1209,7 +1177,6 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& c_first_row=1) CALL cp_gemm('N','T',dimen,dimen,homo,0.5_dp,& fm_back,mo_coeff_o,0.5_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1221,8 +1188,7 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -1232,29 +1198,26 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& END DO END DO ELSE - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,virtual_beta,homo_beta,1.0_dp,& mo_coeff_o_beta,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,virtual_beta,1.0_dp,& fm_back,mo_coeff_v_beta,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) ! and symmetrize (here again multiply instead of transposing) - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','T',dimen,homo_beta,virtual_beta,1.0_dp,& mo_coeff_v_beta,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1262,7 +1225,6 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& c_first_row=1) CALL cp_gemm('N','T',dimen,dimen,homo_beta,0.5_dp,& fm_back,mo_coeff_o_beta,0.5_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1273,38 +1235,34 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& CASE(4) ! all-all block IF (.NOT. alpha_beta) THEN - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,dimen,dimen,1.0_dp,& mo_coeff,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,dimen,1.0_dp,& fm_back,mo_coeff,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) ELSE - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('N','N',dimen,dimen,dimen,1.0_dp,& mo_coeff_beta,fm_mo,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& c_first_col=1,& c_first_row=1) - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) CALL cp_gemm('N','T',dimen,dimen,dimen,1.0_dp,& fm_back,mo_coeff_beta,0.0_dp,fm_ao,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1317,33 +1275,32 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& END SELECT ! copy fm into DBCSR - CALL cp_dbcsr_set(P_mu_nu%matrix,0.0_dp,error=error) - CALL copy_fm_to_dbcsr(fm_ao, P_mu_nu%matrix, keep_sparsity=.TRUE., error=error) + CALL cp_dbcsr_set(P_mu_nu%matrix,0.0_dp) + CALL copy_fm_to_dbcsr(fm_ao, P_mu_nu%matrix, keep_sparsity=.TRUE.) ! calculate associated density CALL calculate_rho_elec(matrix_p=P_mu_nu%matrix,& rho=rho_r,& rho_gspace=rho_g,& total_rho=total_rho,& - ks_env=ks_env,error=error) + ks_env=ks_env) ! and calculate potential - CALL pw_poisson_solve(poisson_env, rho_g%pw, pair_energy, pot_g%pw, error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_poisson_solve(poisson_env, rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) ! integrate the potential - CALL cp_dbcsr_set(mat_mu_nu(1)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(mat_mu_nu(1)%matrix,0.0_dp) CALL integrate_v_rspace(rho_r,hmat=mat_mu_nu(1), & - qs_env=qs_env,calculate_forces=.FALSE.,compute_tau=.FALSE.,gapw=.FALSE.,& - error=error) + qs_env=qs_env,calculate_forces=.FALSE.,compute_tau=.FALSE.,gapw=.FALSE.) ! update with the exchange like contributions ! copy mat_mu_nu into rho_ao work ! Only for alpha-alpha and beta-beta IF (.NOT. alpha_beta) THEN - CALL qs_rho_get(rho_work, rho_ao=rho_work_ao, error=error) - CALL cp_dbcsr_set(rho_work_ao(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_copy(rho_work_ao(1)%matrix,P_mu_nu%matrix,error=error) + CALL qs_rho_get(rho_work, rho_ao=rho_work_ao) + CALL cp_dbcsr_set(rho_work_ao(1)%matrix,0.0_dp) + CALL cp_dbcsr_copy(rho_work_ao(1)%matrix,P_mu_nu%matrix) ! save old EX energy ex_energy=energy%ex DO irep=1, n_rep_hf @@ -1353,20 +1310,20 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& mat_2d(1:ns,1:1) => mat_mu_nu(1:ns) CALL integrate_four_center(qs_env, mat_2d, energy, rho_ao_2d, hfx_sections,& para_env, my_recalc_hfx_integrals, irep, .TRUE.,& - ispin=1, error=error) + ispin=1) END DO ! restore original EX energy energy%ex=ex_energy ENDIF ! scale by a factor 4.0 (closed shell) or 2.0 (open-shell) - CALL cp_dbcsr_scale(mat_mu_nu(1)%matrix,factor,error=error) + CALL cp_dbcsr_scale(mat_mu_nu(1)%matrix,factor) ! copy back to fm - CALL cp_fm_set_all(fm_ao, 0.0_dp,error=error) - CALL copy_dbcsr_to_fm(matrix=mat_mu_nu(1)%matrix, fm=fm_ao, error=error) - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) - CALL cp_fm_upper_to_full(fm_ao, fm_back, error) + CALL cp_fm_set_all(fm_ao, 0.0_dp) + CALL copy_dbcsr_to_fm(matrix=mat_mu_nu(1)%matrix, fm=fm_ao) + CALL cp_fm_set_all(fm_back, 0.0_dp) + CALL cp_fm_upper_to_full(fm_ao, fm_back) ! transform to MO basis, here we always sum the result into the input matrix SELECT CASE(transf_type_out) @@ -1375,10 +1332,9 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& ! at back transform. CASE(1) ! occ-virt block - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('T','N',homo,dimen,dimen,1.0_dp,& mo_coeff_o,fm_ao,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1386,7 +1342,6 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& c_first_row=1) CALL cp_gemm('N','N',homo,virtual,dimen,out_alpha,& fm_back,mo_coeff_v,1.0_dp,fm_mo_out,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1395,10 +1350,9 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& CASE(2) ! occ-occ block - CALL cp_fm_set_all(fm_back, 0.0_dp,error=error) + CALL cp_fm_set_all(fm_back, 0.0_dp) CALL cp_gemm('T','N',homo,dimen,dimen,1.0_dp,& mo_coeff_o,fm_ao,0.0_dp,fm_back,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1406,7 +1360,6 @@ SUBROUTINE cphf_like_update(qs_env,para_env,homo,virtual,dimen,& c_first_row=1) CALL cp_gemm('N','N',homo,homo,dimen,out_alpha,& fm_back,mo_coeff_o,1.0_dp,fm_mo_out,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1451,7 +1404,6 @@ END SUBROUTINE cphf_like_update !> \param fm_G_mu_nu ... !> \param fm_back ... !> \param P_ia ... -!> \param error ... !> \param homo_beta ... !> \param Eigenval_beta ... !> \param P_ia_beta ... @@ -1465,7 +1417,7 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit mo_coeff,mo_coeff_o,mo_coeff_v,Eigenval,blacs_env,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& - L_jb,fm_G_mu_nu,fm_back,P_ia,error,homo_beta,Eigenval_beta,& + L_jb,fm_G_mu_nu,fm_back,P_ia,homo_beta,Eigenval_beta,& P_ia_beta, mo_coeff_beta, mo_coeff_o_beta, mo_coeff_v_beta,& L_jb_beta) TYPE(qs_environment_type), POINTER :: qs_env @@ -1487,7 +1439,6 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit TYPE(cp_dbcsr_p_type) :: P_mu_nu TYPE(cp_fm_type), POINTER :: L_jb, fm_G_mu_nu, fm_back, & P_ia - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, OPTIONAL :: homo_beta REAL(KIND=dp), DIMENSION(:), OPTIONAL :: Eigenval_beta TYPE(cp_fm_type), OPTIONAL, POINTER :: P_ia_beta, mo_coeff_beta, & @@ -1553,16 +1504,16 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit ! create some work array NULLIFY(xk, pk, rk, Ap, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo,ncol_global=virtual,error=error) - CALL cp_fm_create(xk, fm_struct_tmp, name="xk",error=error) - CALL cp_fm_create(pk, fm_struct_tmp, name="pk",error=error) - CALL cp_fm_create(rk, fm_struct_tmp, name="rk",error=error) - CALL cp_fm_create(Ap, fm_struct_tmp, name="Ap",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(xk, 0.0_dp,error=error) - CALL cp_fm_set_all(pk, 0.0_dp,error=error) - CALL cp_fm_set_all(rk, 0.0_dp,error=error) - CALL cp_fm_set_all(Ap, 0.0_dp,error=error) + nrow_global=homo,ncol_global=virtual) + CALL cp_fm_create(xk, fm_struct_tmp, name="xk") + CALL cp_fm_create(pk, fm_struct_tmp, name="pk") + CALL cp_fm_create(rk, fm_struct_tmp, name="rk") + CALL cp_fm_create(Ap, fm_struct_tmp, name="Ap") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(xk, 0.0_dp) + CALL cp_fm_set_all(pk, 0.0_dp) + CALL cp_fm_set_all(rk, 0.0_dp) + CALL cp_fm_set_all(Ap, 0.0_dp) ! copy -L_jb into pk and rk pk%local_data(:,:)=-L_jb%local_data(:,:) @@ -1574,16 +1525,16 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit IF (alpha_beta) THEN NULLIFY(xk_b, pk_b, rk_b, Ap_b, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo_beta,ncol_global=virtual_beta,error=error) - CALL cp_fm_create(xk_b, fm_struct_tmp, name="xk",error=error) - CALL cp_fm_create(pk_b, fm_struct_tmp, name="pk",error=error) - CALL cp_fm_create(rk_b, fm_struct_tmp, name="rk",error=error) - CALL cp_fm_create(Ap_b, fm_struct_tmp, name="Ap",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(xk_b, 0.0_dp,error=error) - CALL cp_fm_set_all(pk_b, 0.0_dp,error=error) - CALL cp_fm_set_all(rk_b, 0.0_dp,error=error) - CALL cp_fm_set_all(Ap_b, 0.0_dp,error=error) + nrow_global=homo_beta,ncol_global=virtual_beta) + CALL cp_fm_create(xk_b, fm_struct_tmp, name="xk") + CALL cp_fm_create(pk_b, fm_struct_tmp, name="pk") + CALL cp_fm_create(rk_b, fm_struct_tmp, name="rk") + CALL cp_fm_create(Ap_b, fm_struct_tmp, name="Ap") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(xk_b, 0.0_dp) + CALL cp_fm_set_all(pk_b, 0.0_dp) + CALL cp_fm_set_all(rk_b, 0.0_dp) + CALL cp_fm_set_all(Ap_b, 0.0_dp) ! copy -L_jb_beta into pk_b and rk_b pk_b%local_data(:,:)=-L_jb_beta%local_data(:,:) @@ -1602,14 +1553,14 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit t1 = m_walltime() ! calculate matrix-vector product - CALL cp_fm_set_all(Ap, 0.0_dp,error=error) + CALL cp_fm_set_all(Ap, 0.0_dp) ! Full for closed shell. Alpha-alpha part of alpha for open shell. CALL cphf_like_update(qs_env,para_env,homo,virtual,dimen,& mo_coeff,mo_coeff_o,mo_coeff_v,Eigenval,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& pk,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - Ap,transf_type_out,error,factor=factor) + Ap,transf_type_out,factor=factor) IF (alpha_beta) THEN ! Alpha-beta part of alpha. CALL cphf_like_update(qs_env,para_env,homo,virtual,dimen,& @@ -1617,19 +1568,19 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& pk_b,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - Ap,transf_type_out,error, factor=factor, & + Ap,transf_type_out,factor=factor, & mo_coeff_beta=mo_coeff_beta, & mo_coeff_o_beta=mo_coeff_o_beta, & mo_coeff_v_beta=mo_coeff_v_beta, & homo_beta=homo_beta, virtual_beta=virtual_beta) ! Beta-beta part (Coulomb and XC) of beta. - CALL cp_fm_set_all(Ap_b, 0.0_dp,error=error) + CALL cp_fm_set_all(Ap_b, 0.0_dp) CALL cphf_like_update(qs_env,para_env,homo_beta,virtual_beta,dimen, & mo_coeff_beta,mo_coeff_o_beta,mo_coeff_v_beta, & Eigenval_beta,hfx_sections,energy,n_rep_hf,& poisson_env,rho_work,pot_g,rho_g,rho_r,mat_mu_nu,& P_mu_nu,Pk_b,fm_G_mu_nu,fm_back,transf_type_in,& - out_alpha,Ap_b,transf_type_out,error,factor=factor) + out_alpha,Ap_b,transf_type_out,factor=factor) ! Beta-alpha part of beta. CALL cphf_like_update(qs_env,para_env,homo_beta,virtual_beta,dimen,& mo_coeff_beta,mo_coeff_o_beta,mo_coeff_v_beta, & @@ -1637,7 +1588,7 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& pk,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - Ap_b,transf_type_out,error, factor=factor,& + Ap_b,transf_type_out,factor=factor,& mo_coeff_beta=mo_coeff, & mo_coeff_o_beta=mo_coeff_o, & mo_coeff_v_beta=mo_coeff_v, & @@ -1703,15 +1654,15 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit P_ia_beta%local_data(:,:)=xk_b%local_data(:,:) ENDIF - CALL cp_fm_release(xk,error=error) - CALL cp_fm_release(pk,error=error) - CALL cp_fm_release(rk,error=error) - CALL cp_fm_release(Ap,error=error) + CALL cp_fm_release(xk) + CALL cp_fm_release(pk) + CALL cp_fm_release(rk) + CALL cp_fm_release(Ap) IF (alpha_beta) THEN - CALL cp_fm_release(xk_b,error=error) - CALL cp_fm_release(pk_b,error=error) - CALL cp_fm_release(rk_b,error=error) - CALL cp_fm_release(Ap_b,error=error) + CALL cp_fm_release(xk_b) + CALL cp_fm_release(pk_b) + CALL cp_fm_release(rk_b) + CALL cp_fm_release(Ap_b) ENDIF ELSE @@ -1721,26 +1672,25 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit ! allocate stuff ALLOCATE(xn(1:max_num_iter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Ax(1:max_num_iter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! create fm structure NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo,ncol_global=virtual,error=error) + nrow_global=homo,ncol_global=virtual) ! create preconditioner (for now only orbital energy differences) NULLIFY(precond) - CALL cp_fm_create(precond, fm_struct_tmp, name="precond",error=error) - CALL cp_fm_set_all(precond,1.0_dp,error=error) + CALL cp_fm_create(precond, fm_struct_tmp, name="precond") + CALL cp_fm_set_all(precond,1.0_dp) CALL cp_fm_get_info(matrix=precond,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -1752,23 +1702,23 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit ! x(iiter) vector NULLIFY(b_i) - CALL cp_fm_create(b_i, fm_struct_tmp, name="b_i",error=error) - CALL cp_fm_set_all(b_i, 0.0_dp, error=error) + CALL cp_fm_create(b_i, fm_struct_tmp, name="b_i") + CALL cp_fm_set_all(b_i, 0.0_dp) b_i%local_data(:,:)=precond%local_data(:,:)*L_jb%local_data(:,:) ! create the residual vector (r), we check convergence on the norm of ! this vector r=(Ax-b) NULLIFY(residual) - CALL cp_fm_create(residual, fm_struct_tmp, name="residual",error=error) - CALL cp_fm_set_all(residual, 0.0_dp, error=error) + CALL cp_fm_create(residual, fm_struct_tmp, name="residual") + CALL cp_fm_set_all(residual, 0.0_dp) ! allocate array containing the various scalar products ALLOCATE(x_norm(1:max_num_iter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(xi_b(1:max_num_iter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(xi_Axi(1:max_num_iter,0:max_num_iter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_norm=0.0_dp xi_b=0.0_dp xi_Axi=0.0_dp @@ -1781,13 +1731,13 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit ! create and update x_i (orthogonalization with previous vectors) NULLIFY(xn(iiter)%matrix) - CALL cp_fm_create(xn(iiter)%matrix, fm_struct_tmp, name="xi",error=error) - CALL cp_fm_set_all(xn(iiter)%matrix, 0.0_dp, error=error) + CALL cp_fm_create(xn(iiter)%matrix, fm_struct_tmp, name="xi") + CALL cp_fm_set_all(xn(iiter)%matrix, 0.0_dp) ! first compute the projection of the actual b_i into all previous x_i ! already scaled with the norm of each x_i ALLOCATE(proj_bi_xj(iiter-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=1, iiter-1 proj_bi_xj(iiB)=0.0_dp proj_bi_xj(iiB)=accurate_sum(b_i%local_data(1:nrow_local,1:ncol_local)*& @@ -1803,19 +1753,19 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit xn(iiB)%matrix%local_data(:,:)*proj_bi_xj(iiB) END DO DEALLOCATE(proj_bi_xj,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! create Ax(iiter) that will store the matrix vector product for this cycle NULLIFY(Ax(iiter)%matrix) - CALL cp_fm_create(Ax(iiter)%matrix, fm_struct_tmp, name="Ai",error=error) - CALL cp_fm_set_all(Ax(iiter)%matrix, 0.0_dp, error=error) + CALL cp_fm_create(Ax(iiter)%matrix, fm_struct_tmp, name="Ai") + CALL cp_fm_set_all(Ax(iiter)%matrix, 0.0_dp) ! perform the matrix-vector product (CPHF like update) CALL cphf_like_update(qs_env,para_env,homo,virtual,dimen,& mo_coeff,mo_coeff_o,mo_coeff_v,Eigenval,& hfx_sections,energy,n_rep_hf,poisson_env,& rho_work,pot_g,rho_g,rho_r,mat_mu_nu,P_mu_nu,& xn(iiter)%matrix,fm_G_mu_nu,fm_back,transf_type_in,out_alpha,& - Ax(iiter)%matrix,transf_type_out,error,factor=factor) + Ax(iiter)%matrix,transf_type_out,factor=factor) ! in order to reduce the number of calls to mp_sum here we ! cluster all necessary scalar products into a sigle vector @@ -1824,7 +1774,7 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit ! iiter+1 -> ! iiter+2 -> ALLOCATE(temp_vals(iiter+2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) temp_vals=0.0_dp ! DO iiB=1, iiter @@ -1845,22 +1795,22 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit x_norm(iiter) = temp_vals(iiter+2) ! deallocate temp_vals DEALLOCATE(temp_vals,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! solve reduced system IF(ALLOCATED(A_small)) DEALLOCATE(A_small) IF(ALLOCATED(b_small)) DEALLOCATE(b_small) ALLOCATE(A_small(iiter,iiter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(b_small(iiter,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) A_small(1:iiter,1:iiter)=xi_Axi(1:iiter,1:iiter) b_small(1:iiter,1)=xi_b(1:iiter) CALL solve_system(matrix=A_small, mysize=iiter, eigenvectors=b_small) ! check for convergence - CALL cp_fm_set_all(residual, 0.0_dp, error=error) + CALL cp_fm_set_all(residual, 0.0_dp) DO iiB=1, iiter residual%local_data(1:nrow_local,1:ncol_local)=residual%local_data(1:nrow_local,1:ncol_local)+& b_small(iiB,1)*Ax(iiB)%matrix%local_data(1:nrow_local,1:ncol_local) @@ -1896,26 +1846,26 @@ SUBROUTINE solve_z_vector_eq_low(qs_env,mp2_env,para_env,homo,virtual,dimen,unit END DO DEALLOCATE(x_norm,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(xi_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(xi_Axi,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_fm_release(precond,error=error) - CALL cp_fm_release(b_i,error=error) - CALL cp_fm_release(residual,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_release(precond) + CALL cp_fm_release(b_i) + CALL cp_fm_release(residual) + CALL cp_fm_struct_release(fm_struct_tmp) ! release Ax, xn DO iiter=1, cycle_counter - CALL cp_fm_release(Ax(iiter)%matrix,error=error) - CALL cp_fm_release(xn(iiter)%matrix,error=error) + CALL cp_fm_release(Ax(iiter)%matrix) + CALL cp_fm_release(xn(iiter)%matrix) END DO DEALLOCATE(xn,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Ax,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF diff --git a/src/mp2_direct_method.F b/src/mp2_direct_method.F index 5ddf693501..105b0b31c1 100644 --- a/src/mp2_direct_method.F +++ b/src/mp2_direct_method.F @@ -92,8 +92,6 @@ MODULE mp2_direct_method !> \param C_beta ... !> \param Auto_beta ... !> \param Integ_MP2 ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2011 created [Mauro Del Ben] !> \author Mauro Del Ben @@ -101,7 +99,7 @@ MODULE mp2_direct_method SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_env,rho,para_env,& mp2_biel,dimen,C,Auto,i_batch_start,Ni_occupied,& occupied,elements_ij_proc, ij_list_proc,Nj_occupied,j_batch_start,& - occupied_beta,C_beta,Auto_beta,Integ_MP2,error) + occupied_beta,C_beta,Auto_beta,Integ_MP2) REAL(KIND=dp) :: Emp2, Emp2_Cou, Emp2_ex TYPE(mp2_type), POINTER :: mp2_env @@ -123,7 +121,6 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en OPTIONAL :: Auto_beta REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :, :), OPTIONAL :: Integ_MP2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'mp2_canonical_direct_single_batch', & @@ -254,15 +251,14 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en irep=1 - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env,& atomic_kind_set=atomic_kind_set,& cell=cell,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! kpoint info for coulomb4 cell_loop_info%dokp = .FALSE. @@ -318,8 +314,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en ! ** Rebuild neighbor lists in case the cell has changed (i.e. NPT MD) actual_x_data%periodic_parameter%number_of_shells = actual_x_data%periodic_parameter%mode CALL hfx_create_neighbor_cells(actual_x_data, actual_x_data%periodic_parameter%number_of_shells_from_input,& - cell, i_thread, & - error) + cell, i_thread) END IF @@ -362,13 +357,12 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en max_set = basis_info%max_set CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) natom = SIZE(particle_set,1) ALLOCATE(kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& kind_of=kind_of) @@ -389,24 +383,24 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en ENDDO !! Allocate the arrays for the integrals. ALLOCATE(primitive_integrals(nsgf_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) primitive_integrals = 0.0_dp ALLOCATE(ee_work(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_work2(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_buffer1(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_buffer2(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_primitives_tmp(nsgf_max**4),STAT=stat) ! XXXXX could be wrong - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nspins = dft_control%nspins ALLOCATE(max_contraction(max_set,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_contraction=0.0_dp max_pgf = 0 @@ -432,19 +426,19 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en ! ** Allocate buffers for pgf_lists nneighbors = SIZE(actual_x_data%neighbor_cells) ALLOCATE(pgf_list_ij(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_product_list(nneighbors**3), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nimages(max_pgf**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,max_pgf**2 ALLOCATE(pgf_list_ij(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO ! ** Set pointers @@ -474,14 +468,14 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en !! Parameters related to the potential 1/r, erf(wr)/r, erfc(wr/r) potential_parameter = actual_x_data%potential_parameter - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() private_lib = actual_x_data%lib !! Helper array to map local basis function indeces to global ones ALLOCATE(last_sgf_global(0:natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_sgf_global(0)=0 DO iatom=1,natom ikind = kind_of(iatom) @@ -500,13 +494,13 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en IF( .NOT. shm_master_x_data%screen_funct_is_initialized ) THEN CALL calc_pair_dist_radii(qs_env, basis_parameter,& shm_master_x_data%pair_dist_radii_pgf, max_set, max_pgf, eps_schwarz,& - n_threads, i_thread, error) + n_threads, i_thread) CALL calc_screening_functions(qs_env, basis_parameter, private_lib, shm_master_x_data%potential_parameter,& shm_master_x_data%screen_funct_coeffs_set,& shm_master_x_data%screen_funct_coeffs_kind, & shm_master_x_data%screen_funct_coeffs_pgf, & shm_master_x_data%pair_dist_radii_pgf,& - max_set, max_pgf, n_threads, i_thread, p_work, error) + max_set, max_pgf, n_threads, i_thread, p_work) shm_master_x_data%screen_funct_is_initialized = .TRUE. END IF @@ -518,16 +512,16 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en !!!!!!!!! ALLOCATE(list_ij%elements(natom**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(list_kl%elements(natom**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !!!!!!!!! coeffs_kind_max0=MAXVAL(screen_coeffs_kind(:,:)%x(2)) ALLOCATE(set_list_ij((max_set*natom)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(set_list_kl((max_set*natom)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !! precalculate maximum density matrix elements in blocks actual_x_data%pmax_block = 0.0_dp @@ -597,7 +591,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en ! orbital transformation is called for each processor, needs for balancing ! the point to point send ALLOCATE(proc_num_task(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) proc_num_task=0 @@ -639,7 +633,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en ! distribute the RS pair over all processor ALLOCATE(kl_list_proc(proc_num_task(para_env%mepos),3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) kl_list_proc=0 @@ -688,10 +682,10 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en total_num_RS_task=SUM(proc_num_task) ALLOCATE(task_counter_RS(total_num_RS_task,4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cost_RS(total_num_RS_task),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) task_counter_RS=0 cost_RS=0.0_dp @@ -761,7 +755,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en IF(ALLOCATED(BI1)) DEALLOCATE(BI1) ALLOCATE(BI1(dimen,Ni_occupied,nsgfb(jset),nsgfa(iset)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BI1=0.D+00 @@ -840,7 +834,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en IF(case_index==2) THEN IF(ALLOCATED(MNRS)) DEALLOCATE(MNRS) ALLOCATE(MNRS(nsgfd(lset),nsgfc(kset),nsgfb(jset),nsgfa(iset)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) MNRS=0.D+00 @@ -909,7 +903,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en iset,jset,kset,lset,& nsgfa(iset),nsgfb(jset),nsgfc(kset),nsgfd(lset),& i_batch_start,Ni_occupied,& - MNRS,C_T,mp2_biel,BI1,error) + MNRS,C_T,mp2_biel,BI1) ELSE task_counter_RS(global_counter,4)=task_counter_RS(global_counter,4)+1 @@ -932,24 +926,24 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en CALL transform_occupied_orbitals_second(dimen,iatom,jatom,iset,jset,& nsgfa(iset),nsgfb(jset),Ni_occupied,Nj_occupied,j_batch_start,& BI1,C_T,mp2_biel,para_env,elements_ij_proc,& - multiple,proc_map,BIb,error) + multiple,proc_map,BIb) ELSE CALL transform_occupied_orbitals_second_big(dimen,iatom,jatom,iset,jset,& nsgfa(iset),nsgfb(jset),Ni_occupied,Nj_occupied,j_batch_start,& ij_elem_max,BI1,C_T,mp2_biel,para_env,elements_ij_proc,& - proc_map,BIb,error) + proc_map,BIb) END IF ELSE IF(.NOT. mp2_env%direct_canonical%big_send) THEN CALL transform_occupied_orbitals_second(dimen,iatom,jatom,iset,jset,& nsgfa(iset),nsgfb(jset),Ni_occupied,Nj_occupied,j_batch_start,& BI1,C_beta_T,mp2_biel,para_env,elements_ij_proc,& - multiple,proc_map,BIb,error) + multiple,proc_map,BIb) ELSE CALL transform_occupied_orbitals_second_big(dimen,iatom,jatom,iset,jset,& nsgfa(iset),nsgfb(jset),Ni_occupied,Nj_occupied,j_batch_start,& ij_elem_max,BI1,C_beta_T,mp2_biel,para_env,elements_ij_proc,& - proc_map,BIb,error) + proc_map,BIb) END IF END IF END IF @@ -961,14 +955,14 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en CALL mp_sum(task_counter_RS,para_env%group) CALL mp_sum(cost_RS,para_env%group) ALLOCATE(task_counter_RS_temp(total_num_RS_task,4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cost_RS_temp(total_num_RS_task),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) step_size=1 ALLOCATE(same_size_kl_elements_counter((nsgf_max**2+1)/step_size+1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) same_size_kl_elements_counter=0 @@ -1018,7 +1012,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en DEALLOCATE(kl_list_proc) ALLOCATE(kl_list_proc(proc_num_task(para_env%mepos),2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) kl_list_proc=0 @@ -1045,7 +1039,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en IF(mp2_env%direct_canonical%big_send) THEN ALLOCATE(zero_mat_big(dimen,2,ij_elem_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -1071,10 +1065,10 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en elements_ij_proc_rec=size_parameter_rec(5) IF(.NOT. mp2_env%direct_canonical%big_send) THEN ALLOCATE(BIb_RS_mat_rec(dimen,Rsize_rec+Ssize_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(BIb_RS_mat_rec_big(dimen,Rsize_rec+Ssize_rec,ij_elem_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ELSE elements_ij_proc_rec=elements_ij_proc @@ -1113,7 +1107,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en END IF CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO @@ -1142,7 +1136,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en BIb_RS_mat_rec_big(1:dimen,Rsize_rec+1:Rsize_rec+Ssize_rec,1:elements_ij_proc) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF @@ -1161,27 +1155,27 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en DEALLOCATE(zero_mat_big) END IF - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() DEALLOCATE(primitive_integrals,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(.NOT.alpha_beta_case) THEN CALL transform_virtual_orbitals_and_accumulate(dimen,occupied,dimen-occupied,i_batch_start,& j_batch_start,BIb,C,Auto,elements_ij_proc,ij_list_proc,& - nspins,Emp2,Emp2_Cou,Emp2_ex,error=error) + nspins,Emp2,Emp2_Cou,Emp2_ex) ELSE CALL transform_virtual_orbitals_and_accumulate_ABcase(dimen,occupied,occupied_beta,dimen-occupied,dimen-occupied_beta,& i_batch_start,j_batch_start,& BIb,C,C_beta,Auto,Auto_beta,& - elements_ij_proc,ij_list_proc,Emp2,Emp2_Cou,error=error) + elements_ij_proc,ij_list_proc,Emp2,Emp2_Cou) DEALLOCATE(C_beta_T) END IF IF(copy_integrals) THEN IF(.NOT.alpha_beta_case) THEN ALLOCATE(Integ_MP2(dimen-occupied,dimen-occupied,occupied,occupied),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Integ_MP2=0.0_dp DO i=1, elements_ij_proc iiB=ij_list_proc(i,1) @@ -1190,7 +1184,7 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en END DO ELSE ALLOCATE(Integ_MP2(dimen-occupied,dimen-occupied_beta,occupied,occupied_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Integ_MP2=0.0_dp DO i=1, elements_ij_proc iiB=ij_list_proc(i,1) @@ -1202,30 +1196,30 @@ SUBROUTINE mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_en DEALLOCATE(BIb) DEALLOCATE(set_list_ij, set_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,max_pgf**2 DEALLOCATE(pgf_list_ij(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(pgf_list_ij, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_product_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(max_contraction, kind_of, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ee_work, ee_work2, ee_buffer1, ee_buffer2, ee_primitives_tmp, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(nimages, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(mp2_env%potential_parameter%potential_type == do_mp2_potential_TShPSC) THEN init_TShPSC_lmax = -1 @@ -1257,13 +1251,12 @@ END SUBROUTINE mp2_canonical_direct_single_batch !> \param C_T ... !> \param mp2_biel ... !> \param BI1 ... -!> \param error ... ! ***************************************************************************** SUBROUTINE transform_occupied_orbitals_first(dimen,latom,katom,jatom,iatom,& lset,kset,jset,iset,& Ssize,Rsize,Nsize,Msize,& i_batch_start,Ni_occupied,& - MNRS,C_T,mp2_biel,BI1,error) + MNRS,C_T,mp2_biel,BI1) INTEGER :: dimen, latom, katom, jatom, iatom, lset, kset, jset, iset, & Ssize, Rsize, Nsize, Msize, i_batch_start, Ni_occupied @@ -1273,7 +1266,6 @@ SUBROUTINE transform_occupied_orbitals_first(dimen,latom,katom,jatom,iatom,& TYPE(mp2_biel_type) :: mp2_biel REAL(KIND=dp), DIMENSION(dimen, & Ni_occupied, Rsize, Ssize) :: BI1 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'transform_occupied_orbitals_first', & @@ -1346,13 +1338,12 @@ END SUBROUTINE transform_occupied_orbitals_first !> \param multiple ... !> \param proc_map ... !> \param BIb ... -!> \param error ... ! ***************************************************************************** SUBROUTINE transform_occupied_orbitals_second(dimen,latom,katom,lset,kset,& Ssize,Rsize,Ni_occupied,Nj_occupied,j_batch_start,& BI1,C_T,mp2_biel,para_env,& elements_ij_proc,& - multiple,proc_map,BIb,error) + multiple,proc_map,BIb) INTEGER :: dimen, latom, katom, lset, & kset, Ssize, Rsize, & @@ -1368,7 +1359,6 @@ SUBROUTINE transform_occupied_orbitals_second(dimen,latom,katom,lset,kset,& *para_env%num_pe-1)) :: proc_map REAL(KIND=dp), DIMENSION(dimen, dimen, & elements_ij_proc) :: BIb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'transform_occupied_orbitals_second', & @@ -1415,7 +1405,7 @@ SUBROUTINE transform_occupied_orbitals_second(dimen,latom,katom,lset,kset,& S_offset_rec=size_parameter_rec(4) elements_ij_proc_rec=size_parameter_rec(5) ALLOCATE(BIb_RS_mat_rec(dimen,Rsize_rec+Ssize_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE elements_ij_proc_rec=elements_ij_proc @@ -1497,7 +1487,7 @@ SUBROUTINE transform_occupied_orbitals_second(dimen,latom,katom,lset,kset,& END IF CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO ! loop over the ij of the processor @@ -1532,13 +1522,12 @@ END SUBROUTINE transform_occupied_orbitals_second !> \param elements_ij_proc ... !> \param proc_map ... !> \param BIb ... -!> \param error ... ! ***************************************************************************** SUBROUTINE transform_occupied_orbitals_second_big(dimen,latom,katom,lset,kset,& Ssize,Rsize,Ni_occupied,Nj_occupied,j_batch_start,& ij_elem_max,BI1,C_T,mp2_biel,para_env,& elements_ij_proc,& - proc_map,BIb,error) + proc_map,BIb) INTEGER :: dimen, latom, katom, lset, kset, Ssize, Rsize, Ni_occupied, & Nj_occupied, j_batch_start, ij_elem_max @@ -1552,7 +1541,6 @@ SUBROUTINE transform_occupied_orbitals_second_big(dimen,latom,katom,lset,kset,& *para_env%num_pe-1)) :: proc_map REAL(KIND=dp), DIMENSION(dimen, dimen, & elements_ij_proc) :: BIb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'transform_occupied_orbitals_second_big', & @@ -1599,7 +1587,7 @@ SUBROUTINE transform_occupied_orbitals_second_big(dimen,latom,katom,lset,kset,& S_offset_rec=size_parameter_rec(4) elements_ij_proc_rec=size_parameter_rec(5) ALLOCATE(BIb_RS_mat_rec(dimen,Rsize_rec+Ssize_rec,ij_elem_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE elements_ij_proc_rec=elements_ij_proc END IF @@ -1675,7 +1663,7 @@ SUBROUTINE transform_occupied_orbitals_second_big(dimen,latom,katom,lset,kset,& BIb_RS_mat_rec(1:dimen,Rsize_rec+1:Rsize_rec+Ssize_rec,1:elements_ij_proc) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF(proc_send/=para_env%mepos) THEN @@ -1704,11 +1692,10 @@ END SUBROUTINE transform_occupied_orbitals_second_big !> \param Emp2 ... !> \param Emp2_Cou ... !> \param Emp2_ex ... -!> \param error ... ! ***************************************************************************** SUBROUTINE transform_virtual_orbitals_and_accumulate(dimen,occupied,virtual,i_batch_start,& j_batch_start,BIb,C,Auto,elements_ij_proc,& - ij_list_proc,nspins,Emp2,Emp2_Cou,Emp2_ex,error) + ij_list_proc,nspins,Emp2,Emp2_Cou,Emp2_ex) INTEGER :: dimen, occupied, virtual, & i_batch_start, j_batch_start @@ -1720,7 +1707,6 @@ SUBROUTINE transform_virtual_orbitals_and_accumulate(dimen,occupied,virtual,i_ba INTEGER, DIMENSION(elements_ij_proc, 2) :: ij_list_proc INTEGER :: nspins REAL(KIND=dp) :: Emp2, Emp2_Cou, Emp2_ex - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'transform_virtual_orbitals_and_accumulate', & @@ -1739,7 +1725,7 @@ SUBROUTINE transform_virtual_orbitals_and_accumulate(dimen,occupied,virtual,i_ba failure=.FALSE. ALLOCATE(BIa(dimen,virtual),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIa=zero DO index_ij=1, elements_ij_proc @@ -1751,7 +1737,7 @@ SUBROUTINE transform_virtual_orbitals_and_accumulate(dimen,occupied,virtual,i_ba DEALLOCATE(BIa) ALLOCATE(BIa(virtual,virtual),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIa=zero DO index_ij=1, elements_ij_proc @@ -1810,11 +1796,10 @@ END SUBROUTINE transform_virtual_orbitals_and_accumulate !> \param ij_list_proc ... !> \param Emp2 ... !> \param Emp2_Cou ... -!> \param error ... ! ***************************************************************************** SUBROUTINE transform_virtual_orbitals_and_accumulate_ABcase(dimen,occ_i,occ_j,virt_i,virt_j,i_batch_start,& j_batch_start,BIb,C_i,C_j,Auto_i,Auto_j,elements_ij_proc,& - ij_list_proc,Emp2,Emp2_Cou,error) + ij_list_proc,Emp2,Emp2_Cou) INTEGER :: dimen, occ_i, occ_j, virt_i, & virt_j, i_batch_start, & @@ -1826,7 +1811,6 @@ SUBROUTINE transform_virtual_orbitals_and_accumulate_ABcase(dimen,occ_i,occ_j,vi INTEGER :: elements_ij_proc INTEGER, DIMENSION(elements_ij_proc, 2) :: ij_list_proc REAL(KIND=dp) :: Emp2, Emp2_Cou - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'transform_virtual_orbitals_and_accumulate_ABcase', & @@ -1846,7 +1830,7 @@ SUBROUTINE transform_virtual_orbitals_and_accumulate_ABcase(dimen,occ_i,occ_j,vi failure=.FALSE. ALLOCATE(BIa(dimen,virt_i),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO index_ij=1, elements_ij_proc @@ -1867,7 +1851,7 @@ SUBROUTINE transform_virtual_orbitals_and_accumulate_ABcase(dimen,occ_i,occ_j,vi DEALLOCATE(BIa) ALLOCATE(BIa(virt_i,virt_j),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO index_ij=1, elements_ij_proc diff --git a/src/mp2_gpw.F b/src/mp2_gpw.F index e248478ab1..5a57a20056 100644 --- a/src/mp2_gpw.F +++ b/src/mp2_gpw.F @@ -135,14 +135,13 @@ MODULE mp2_gpw !> \param unit_nr ... !> \param calc_forces ... !> \param calc_ex ... -!> \param error ... !> \param do_ri_mp2 ... !> \param do_ri_rpa ... !> \param do_ri_sos_laplace_mp2 ... !> \author Mauro Del Ben and Joost VandeVondele ! ***************************************************************************** SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& - mos_mp2,para_env,unit_nr,calc_forces,calc_ex,error,do_ri_mp2,do_ri_rpa,& + mos_mp2,para_env,unit_nr,calc_forces,calc_ex,do_ri_mp2,do_ri_rpa,& do_ri_sos_laplace_mp2) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mp2_type), POINTER :: mp2_env @@ -154,7 +153,6 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& INTEGER :: unit_nr LOGICAL, INTENT(IN) :: calc_forces LOGICAL :: calc_ex - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, OPTIONAL :: do_ri_mp2, do_ri_rpa, & do_ri_sos_laplace_mp2 @@ -240,7 +238,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& nspins=SIZE(mos_mp2) ! ... setup needed to be able to qs_integrate in a subgroup. - CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env=qs_env, dft_control=dft_control) CALL get_mo_set(mo_set=mos_mp2(1)%mo_set, nelectron=nelectron,& eigenvalues=mo_eigenvalues,nmo=nmo,homo=homo,& mo_coeff=mo_coeff,nao=dimen) @@ -254,10 +252,10 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& color_sub=para_env%mepos/mp2_env%mp2_num_proc CALL mp_comm_split_direct(para_env%group,comm_sub,color_sub) NULLIFY(para_env_sub) - CALL cp_para_env_create(para_env_sub,comm_sub,error=error) + CALL cp_para_env_create(para_env_sub,comm_sub) ! each of the sub groups might need to generate output - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (para_env%mepos==para_env%source) THEN local_unit_nr=cp_logger_get_default_unit_nr(logger,local=.FALSE.) ELSE @@ -287,7 +285,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& NULLIFY(blacs_env_sub) CALL cp_blacs_env_create(blacs_env_sub,para_env_sub,& blacs_grid_layout,& - blacs_repeatable,error=error) + blacs_repeatable) ! get stuff CALL get_qs_env(qs_env,& @@ -298,8 +296,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& atomic_kind_set=atomic_kind_set,& molecule_set=molecule_set,& molecule_kind_set=molecule_kind_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! re-init the radii to be able to generate pair lists with MP2-appropriate screening eps_pgf_orb_old=dft_control%qs_control%eps_pgf_orb @@ -309,7 +306,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& dft_control%qs_control%eps_pgf_orb =mp2_env%mp2_gpw%eps_grid dft_control%qs_control%eps_rho_rspace=mp2_env%mp2_gpw%eps_grid dft_control%qs_control%eps_gvg_rspace=mp2_env%mp2_gpw%eps_grid - CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set, qs_kind_set, error) + CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set, qs_kind_set) ! get a distribution_1d NULLIFY(local_particles_sub,local_molecules_sub) @@ -319,8 +316,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& molecule_kind_set=molecule_kind_set,& molecule_set=molecule_set,& local_molecules=local_molecules_sub,& - force_env_section=qs_env%input,& - error=error) + force_env_section=qs_env%input) ! get a distribution_2d NULLIFY(distribution_2d_sub) @@ -332,53 +328,53 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& molecule_set=molecule_set,& distribution_2d=distribution_2d_sub,& blacs_env=blacs_env_sub,& - force_env_section=qs_env%input, error=error) + force_env_section=qs_env%input) ! Build the sub orbital-orbital overlap neighbor lists NULLIFY(sab_orb_sub) - CALL section_vals_val_get(qs_env%input,"DFT%SUBCELLS",r_val=subcells,error=error) + CALL section_vals_val_get(qs_env%input,"DFT%SUBCELLS",r_val=subcells) nkind = SIZE(atomic_kind_set) ALLOCATE (orb_present(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (orb_radius(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) orb_radius(:) = 0.0_dp ALLOCATE (pair_radius(nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom2d(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL atom2d_build(atom2d,orb_radius,orb_present,local_particles_sub,distribution_2d_sub,& atomic_kind_set,qs_kind_set,molecule_set,molecule_only=.FALSE.,dftb=.FALSE.,& - particle_set=particle_set,error=error) - CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius,error) + particle_set=particle_set) + CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius) CALL build_neighbor_lists(sab_orb_sub,particle_set,atom2d,cell,pair_radius,& - mic=.FALSE.,subcells=subcells,molecular=.FALSE.,name="sab_orb_sub",error=error) - CALL atom2d_cleanup(atom2d,error) + mic=.FALSE.,subcells=subcells,molecular=.FALSE.,name="sab_orb_sub") + CALL atom2d_cleanup(atom2d) DEALLOCATE (atom2d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(orb_present,orb_radius,pair_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! a dbcsr_dist ALLOCATE(dbcsr_dist_sub,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_dist2d_to_dist (distribution_2d_sub, dbcsr_dist_sub, unit_nr, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_dist2d_to_dist (distribution_2d_sub, dbcsr_dist_sub, unit_nr) ! build a dbcsr matrix the hard way natom = SIZE(particle_set) ALLOCATE (row_blk_sizes(natom), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes) ALLOCATE(mat_munu%matrix, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(mat_munu%matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(mat_munu%matrix) CALL cp_dbcsr_create(matrix=mat_munu%matrix,& name="(ai|munu)",& dist=dbcsr_dist_sub, matrix_type=dbcsr_type_symmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(mat_munu%matrix,sab_orb_sub,error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(mat_munu%matrix,sab_orb_sub) DEALLOCATE(row_blk_sizes) ! check if we want to do ri-g0w0 on top of ri-rpa @@ -388,11 +384,11 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& ! and the array of mos ALLOCATE(Eigenval(dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Eigenval(:)=mo_eigenvalues(:) IF (nspins==2) THEN ALLOCATE(Eigenval_beta(dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Eigenval_beta(:)=mo_eigenvalues_beta(:) ENDIF @@ -401,8 +397,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& ! output the two part of the C matrix (virtual, occupied) CALL replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dimen,homo,mat_munu,& mo_coeff_o,mo_coeff_v,mo_coeff_all,mo_coeff_gw,my_do_gw,& - gw_corr_lev_occ,gw_corr_lev_virt,& - error) + gw_corr_lev_occ,gw_corr_lev_virt) ! if open shell case replicate also the coefficient matrix for the beta orbitals IF(nspins==2) THEN @@ -412,15 +407,14 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& CALL replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff_beta,dimen,homo_beta,mat_munu,& mo_coeff_o_beta,mo_coeff_v_beta,mo_coeff_all_beta,mo_coeff_gw_beta,& - my_do_gw,gw_corr_lev_occ_beta,gw_corr_lev_virt_beta,& - error) + my_do_gw,gw_corr_lev_occ_beta,gw_corr_lev_virt_beta) END IF ! hack hack hack XXXXXXXXXXXXXXX rebuilds the pw_en with the new cutoffs progression_factor=dft_control%qs_control%progression_factor n_multigrid=SIZE(dft_control%qs_control%e_cutoff) ALLOCATE(e_cutoff_old(n_multigrid), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) e_cutoff_old(:)=dft_control%qs_control%e_cutoff cutoff_old=dft_control%qs_control%cutoff @@ -436,37 +430,37 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& ! a pw_env NULLIFY(pw_env_sub) - CALL pw_env_create(pw_env_sub,error) - CALL pw_env_rebuild(pw_env_sub,qs_env,para_env_sub,error) + CALL pw_env_create(pw_env_sub) + CALL pw_env_rebuild(pw_env_sub,qs_env,para_env_sub) CALL pw_env_get(pw_env_sub, auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env,error=error) + poisson_env=poisson_env) ! hack hack hack XXXXXXXXXXXXXXX ! now we need a task list, hard code skip_load_balance_distributed NULLIFY(task_list_sub) skip_load_balance_distributed=dft_control%qs_control%skip_load_balance_distributed - CALL allocate_task_list(task_list_sub,error) + CALL allocate_task_list(task_list_sub) CALL generate_qs_task_list(ks_env, task_list_sub, & reorder_rs_grid_ranks=.TRUE., soft_valid=.FALSE., & skip_load_balance_distributed=skip_load_balance_distributed,& - pw_env_external=pw_env_sub, sab_orb_external=sab_orb_sub, error=error) + pw_env_external=pw_env_sub, sab_orb_external=sab_orb_sub) ! get some of the grids ready NULLIFY(rho_r%pw,rho_g%pw,pot_g%pw) CALL pw_pool_create_pw(auxbas_pw_pool,rho_r%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,rho_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,pot_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) ! run the FFT once, to set up buffers and to take into account the memory rho_r%pw%cr3d = 0.0D0 - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) ! now we're kind of ready to go.... Emp2_S=0.0_dp @@ -483,7 +477,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& mo_coeff_o,mo_coeff_v,mo_coeff_all,mo_coeff_gw,mp2_env%mp2_gpw%eps_filter,unit_nr,& mp2_env%mp2_memory,mp2_env%calc_PQ_cond_num,calc_forces,blacs_env_sub,my_do_gw,& starts_B_all,sizes_B_all,ends_B_all,gw_corr_lev_occ,gw_corr_lev_virt,& - mp2_env%ri_g0w0%cutoff_rad_gw,mp2_env%ri_g0w0%do_truncation,error,& + mp2_env%ri_g0w0%cutoff_rad_gw,mp2_env%ri_g0w0%do_truncation,& BIb_C_beta,BIb_C_gw_beta,ends_B_virtual_beta,sizes_B_virtual_beta,starts_B_virtual_beta,& homo_beta,mo_coeff_o_beta,mo_coeff_v_beta,mo_coeff_all_beta,mo_coeff_gw_beta) ELSE @@ -496,7 +490,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& mo_coeff_o,mo_coeff_v,mo_coeff_all,mo_coeff_gw,mp2_env%mp2_gpw%eps_filter,unit_nr,& mp2_env%mp2_memory,mp2_env%calc_PQ_cond_num,calc_forces,blacs_env_sub,my_do_gw,& starts_B_all,sizes_B_all,ends_B_all,gw_corr_lev_occ,gw_corr_lev_virt,& - mp2_env%ri_g0w0%cutoff_rad_gw,mp2_env%ri_g0w0%do_truncation,error) + mp2_env%ri_g0w0%cutoff_rad_gw,mp2_env%ri_g0w0%do_truncation) END IF ELSE ! Canonical MP2-GPW @@ -508,7 +502,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& atomic_kind_set,qs_kind_set,mo_coeff,Eigenval,nmo,homo,rho_r,rho_g,pot_g,& mat_munu,pw_env_sub,poisson_env,auxbas_pw_pool,task_list_sub,& mo_coeff_o,mo_coeff_v,mp2_env%mp2_gpw%eps_filter,unit_nr,& - mp2_env%mp2_memory,calc_ex,blacs_env_sub,error,& + mp2_env%mp2_memory,calc_ex,blacs_env_sub,& homo_beta,mo_coeff_o_beta,mo_coeff_v_beta,Eigenval_beta,Emp2_AB) ! beta-beta component @@ -518,7 +512,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& atomic_kind_set,qs_kind_set,mo_coeff_beta,Eigenval_beta,nmo,homo_beta,rho_r,rho_g,pot_g,& mat_munu,pw_env_sub,poisson_env,auxbas_pw_pool,task_list_sub,& mo_coeff_o_beta,mo_coeff_v_beta,mp2_env%mp2_gpw%eps_filter,unit_nr,& - mp2_env%mp2_memory,calc_ex,blacs_env_sub,error) + mp2_env%mp2_memory,calc_ex,blacs_env_sub) ELSE ! closed shell case @@ -526,92 +520,92 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& atomic_kind_set,qs_kind_set,mo_coeff,Eigenval,nmo,homo,rho_r,rho_g,pot_g,& mat_munu,pw_env_sub,poisson_env,auxbas_pw_pool,task_list_sub,& mo_coeff_o,mo_coeff_v,mp2_env%mp2_gpw%eps_filter,unit_nr,& - mp2_env%mp2_memory,calc_ex,blacs_env_sub,error) + mp2_env%mp2_memory,calc_ex,blacs_env_sub) END IF END IF ! and now free the whole lot - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw) ! Free possibly large buffers allocated by dbcsr on the GPU, ! large hybrid dgemm/pdgemm's coming later will need the space. - CALL cp_dbcsr_clear_mempools(error) + CALL cp_dbcsr_clear_mempools() ! moved down - ! CALL deallocate_task_list(task_list_sub,error=error) - ! CALL pw_env_release(pw_env_sub, error=error) + ! CALL deallocate_task_list(task_list_sub) + ! CALL pw_env_release(pw_env_sub) IF(calc_forces) THEN ! make a copy of mo_coeff_o and mo_coeff_v NULLIFY(mp2_env%ri_grad%mo_coeff_o) - CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_o,error=error) - CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_o,mo_coeff_o,name="mo_coeff_o",error=error) + CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_o) + CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_o,mo_coeff_o,name="mo_coeff_o") NULLIFY(mp2_env%ri_grad%mo_coeff_v) - CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_v,error=error) - CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_v,mo_coeff_v,name="mo_coeff_v",error=error) + CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_v) + CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_v,mo_coeff_v,name="mo_coeff_v") IF (nspins == 2) THEN NULLIFY(mp2_env%ri_grad%mo_coeff_o_beta) - CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_o_beta,error=error) - CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_o_beta,mo_coeff_o_beta,name="mo_coeff_o_b",error=error) + CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_o_beta) + CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_o_beta,mo_coeff_o_beta,name="mo_coeff_o_b") NULLIFY(mp2_env%ri_grad%mo_coeff_v_beta) - CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_v_beta,error=error) - CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_v_beta,mo_coeff_v_beta,name="mo_coeff_v_b",error=error) + CALL cp_dbcsr_init_p(mp2_env%ri_grad%mo_coeff_v_beta) + CALL cp_dbcsr_copy(mp2_env%ri_grad%mo_coeff_v_beta,mo_coeff_v_beta,name="mo_coeff_v_b") ENDIF my_group_L_size=sizes_array(color_sub) my_group_L_start=starts_array(color_sub) my_group_L_end=ends_array(color_sub) END IF - CALL cp_dbcsr_release(mo_coeff_o,error=error) + CALL cp_dbcsr_release(mo_coeff_o) DEALLOCATE(mo_coeff_o, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_release(mo_coeff_v,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_release(mo_coeff_v) DEALLOCATE(mo_coeff_v, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(my_do_gw) THEN - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_release(mo_coeff_all,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_release(mo_coeff_all) DEALLOCATE(mo_coeff_all, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(nspins==2) THEN - CALL cp_dbcsr_release(mo_coeff_o_beta,error=error) + CALL cp_dbcsr_release(mo_coeff_o_beta) DEALLOCATE(mo_coeff_o_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_release(mo_coeff_v_beta,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_release(mo_coeff_v_beta) DEALLOCATE(mo_coeff_v_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(my_do_gw) THEN - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_release(mo_coeff_all_beta,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_release(mo_coeff_all_beta) DEALLOCATE(mo_coeff_all_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF IF(.NOT.calc_forces) THEN ! release stuff - CALL cp_dbcsr_release(mat_munu%matrix,error=error) + CALL cp_dbcsr_release(mat_munu%matrix) DEALLOCATE(mat_munu%matrix, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL cp_dbcsr_distribution_release(dbcsr_dist_sub) DEALLOCATE(dbcsr_dist_sub,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(sab_orb_sub) CALL deallocate_neighbor_list_set(sab_orb_sub(i)%neighbor_list_set) END DO DEALLOCATE(sab_orb_sub,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) - CALL distribution_2d_release(distribution_2d_sub,error=error) + CALL distribution_2d_release(distribution_2d_sub) - CALL distribution_1d_release(local_particles_sub,error=error) - CALL distribution_1d_release(local_molecules_sub,error=error) + CALL distribution_1d_release(local_particles_sub) + CALL distribution_1d_release(local_molecules_sub) END IF ! decide if to doing RI-RPA or RI-MP2 @@ -622,7 +616,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& ends_array,ends_B_virtual,ends_B_all,sizes_array,sizes_B_virtual,sizes_B_all,& starts_array,starts_B_virtual,starts_B_all,& Eigenval,nmo,homo,dimen_RI,gw_corr_lev_occ,gw_corr_lev_virt,& - unit_nr,error,my_do_ri_sos_laplace_mp2,my_do_gw,& + unit_nr,my_do_ri_sos_laplace_mp2,my_do_gw,& BIb_C_beta,homo_beta,Eigenval_beta,& ends_B_virtual_beta,sizes_B_virtual_beta, starts_B_virtual_beta,& BIb_C_gw_beta,gw_corr_lev_occ_beta,gw_corr_lev_virt_beta) @@ -631,7 +625,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& ends_array,ends_B_virtual,ends_B_all,sizes_array,sizes_B_virtual,sizes_B_all,& starts_array,starts_B_virtual,starts_B_all,& Eigenval,nmo,homo,dimen_RI,gw_corr_lev_occ,gw_corr_lev_virt,& - unit_nr,error,my_do_ri_sos_laplace_mp2,my_do_gw) + unit_nr,my_do_ri_sos_laplace_mp2,my_do_gw) END IF ELSE IF(my_do_ri_mp2) THEN @@ -640,20 +634,20 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& ! alpha-alpha component CALL mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,para_env_sub,color_sub,& ends_array,ends_B_virtual,sizes_array,sizes_B_virtual,starts_array,starts_B_virtual,& - Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,calc_ex,error,& + Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,calc_ex,& open_shell_SS=.TRUE.) ! beta-beta component CALL mp2_ri_gpw_compute_en(Emp2_BB,Emp2_Cou_BB,Emp2_EX_BB,BIb_C_beta,mp2_env,para_env,para_env_sub,color_sub,& ends_array,ends_B_virtual_beta,sizes_array,& sizes_B_virtual_beta,starts_array,starts_B_virtual_beta,& - Eigenval_beta,nmo,homo_beta,dimen_RI,unit_nr,calc_forces,calc_ex,error,& + Eigenval_beta,nmo,homo_beta,dimen_RI,unit_nr,calc_forces,calc_ex,& open_shell_SS=.TRUE.) ! alpha-beta case CALL mp2_ri_gpw_compute_en(Emp2_d_AB,Emp2_AB,Emp2_d2_AB,BIb_C,mp2_env,para_env,para_env_sub,color_sub,& ends_array,ends_B_virtual,sizes_array,sizes_B_virtual,starts_array,starts_B_virtual,& - Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,.FALSE.,error,& + Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,.FALSE.,& .FALSE.,BIb_C_beta,homo_beta,Eigenval_beta,& ends_B_virtual_beta,sizes_B_virtual_beta, starts_B_virtual_beta) @@ -661,7 +655,7 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& ! closed shell case CALL mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,para_env_sub,color_sub,& ends_array,ends_B_virtual,sizes_array,sizes_B_virtual,starts_array,starts_B_virtual,& - Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,calc_ex,error) + Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,calc_ex) END IF ! if we need forces time to calculate the MP2 non-separable contribution ! and start coputing the Largrangian @@ -671,31 +665,31 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& NULLIFY(rho_r%pw,rho_g%pw,pot_g%pw) CALL pw_pool_create_pw(auxbas_pw_pool,rho_r%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,rho_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,pot_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) ! the mu_nu matrix (again) ! XXXXXXXXXXXXXXXXXXXXXXXXX ! ! build a dbcsr matrix the hard way - ! CALL get_particle_set(particle_set=particle_set,nsgf=rbs,error=error) + ! CALL get_particle_set(particle_set=particle_set,nsgf=rbs) ! CALL array_nullify (row_blk_sizes) ! CALL array_new (row_blk_sizes, rbs, gift=.TRUE.) ! ALLOCATE(mat_munu%matrix, STAT=stat) - ! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - ! CALL cp_dbcsr_init(mat_munu%matrix,error=error) + ! CPPostcondition(stat==0,cp_failure_level,routineP,failure) + ! CALL cp_dbcsr_init(mat_munu%matrix) ! CALL cp_dbcsr_create(matrix=mat_munu%matrix,& ! name="(ai|munu)",& ! dist=dbcsr_dist_sub, & ! matrix_type=dbcsr_type_symmetric,& ! ! matrix_type=dbcsr_type_no_symmetry,& ! row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - ! nze=0, error=error) - ! CALL cp_dbcsr_alloc_block_from_nbl(mat_munu%matrix,sab_orb_sub,error) + ! nze=0) + ! CALL cp_dbcsr_alloc_block_from_nbl(mat_munu%matrix,sab_orb_sub) ! CALL array_release (row_blk_sizes) IF (nspins==2) THEN ! Open shell @@ -703,56 +697,56 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& particle_set,atomic_kind_set,qs_kind_set,mo_coeff,nmo,homo,dimen_RI,Eigenval,& my_group_L_start,my_group_L_end,my_group_L_size,rho_r,rho_g,pot_g,& mat_munu,pw_env_sub,poisson_env,auxbas_pw_pool,task_list_sub,& - blacs_env_sub,error,Eigenval_beta,homo_beta,mo_coeff_beta) + blacs_env_sub,Eigenval_beta,homo_beta,mo_coeff_beta) ELSE ! Closed shell CALL calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,cell, & particle_set,atomic_kind_set,qs_kind_set,mo_coeff,nmo,homo,dimen_RI,Eigenval,& my_group_L_start,my_group_L_end,my_group_L_size,rho_r,rho_g,pot_g,& mat_munu,pw_env_sub,poisson_env,auxbas_pw_pool,task_list_sub,& - blacs_env_sub,error) + blacs_env_sub) ENDIF ! release - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,pot_g%pw) - CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_o,error=error) + CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_o) DEALLOCATE(mp2_env%ri_grad%mo_coeff_o, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_v,error=error) + CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_v) DEALLOCATE(mp2_env%ri_grad%mo_coeff_v, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (nspins == 2) THEN - CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_o_beta,error=error) + CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_o_beta) DEALLOCATE(mp2_env%ri_grad%mo_coeff_o_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_v_beta,error=error) + CALL cp_dbcsr_release(mp2_env%ri_grad%mo_coeff_v_beta) DEALLOCATE(mp2_env%ri_grad%mo_coeff_v_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF - CALL cp_dbcsr_release(mat_munu%matrix,error=error) + CALL cp_dbcsr_release(mat_munu%matrix) DEALLOCATE(mat_munu%matrix, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL cp_dbcsr_distribution_release(dbcsr_dist_sub) DEALLOCATE(dbcsr_dist_sub,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(sab_orb_sub) CALL deallocate_neighbor_list_set(sab_orb_sub(i)%neighbor_list_set) END DO DEALLOCATE(sab_orb_sub,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) - CALL distribution_2d_release(distribution_2d_sub,error=error) + CALL distribution_2d_release(distribution_2d_sub) - CALL distribution_1d_release(local_particles_sub,error=error) - CALL distribution_1d_release(local_molecules_sub,error=error) + CALL distribution_1d_release(local_particles_sub) + CALL distribution_1d_release(local_molecules_sub) END IF END IF @@ -778,72 +772,72 @@ SUBROUTINE mp2_gpw_main(qs_env,mp2_env,Emp2,Emp2_Cou,Emp2_EX,Emp2_S,Emp2_T,& !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx ! moved from above IF(my_do_gw) THEN - CALL cp_dbcsr_release(mo_coeff_gw,error=error) + CALL cp_dbcsr_release(mo_coeff_gw) DEALLOCATE(mo_coeff_gw, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(nspins==2) THEN - CALL cp_dbcsr_release(mo_coeff_gw_beta,error=error) + CALL cp_dbcsr_release(mo_coeff_gw_beta) DEALLOCATE(mo_coeff_gw_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF - CALL deallocate_task_list(task_list_sub,error=error) + CALL deallocate_task_list(task_list_sub) - CALL pw_env_release(pw_env_sub, error=error) + CALL pw_env_release(pw_env_sub) ! CALL cp_dbcsr_distribution_release(dbcsr_dist_sub) ! DEALLOCATE(dbcsr_dist_sub,STAT=stat) - ! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + ! CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! DO i=1,SIZE(sab_orb_sub) ! CALL deallocate_neighbor_list_set(sab_orb_sub(i)%neighbor_list_set) ! END DO ! DEALLOCATE(sab_orb_sub,stat=stat) - ! CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + ! CPPostconditionNoFail(stat==0,cp_warning_level,routineP) - ! CALL distribution_2d_release(distribution_2d_sub,error=error) + ! CALL distribution_2d_release(distribution_2d_sub) - ! CALL distribution_1d_release(local_particles_sub,error=error) - ! CALL distribution_1d_release(local_molecules_sub,error=error) + ! CALL distribution_1d_release(local_particles_sub) + ! CALL distribution_1d_release(local_molecules_sub) !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx ! re-init the radii to be able to generate pair lists with MP2-appropriate screening dft_control%qs_control%eps_pgf_orb=eps_pgf_orb_old dft_control%qs_control%eps_rho_rspace=eps_rho_rspace_old dft_control%qs_control%eps_gvg_rspace=eps_gvg_rspace_old - CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set, qs_kind_set, error) + CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set, qs_kind_set) ! restore the initial value of the cutoff dft_control%qs_control%e_cutoff=e_cutoff_old dft_control%qs_control%cutoff=cutoff_old dft_control%qs_control%relative_cutoff=relative_cutoff_old - CALL cp_blacs_env_release(blacs_env_sub, error=error) + CALL cp_blacs_env_release(blacs_env_sub) CALL cp_rm_default_logger() CALL cp_logger_release(logger_sub) - CALL cp_para_env_release(para_env_sub,error=error) + CALL cp_para_env_release(para_env_sub) ! finally solve the z-vector equation if forces are required IF(calc_forces) THEN IF (nspins==2) THEN CALL solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& - atomic_kind_set,mo_coeff,nmo,homo,Eigenval,unit_nr,error,& + atomic_kind_set,mo_coeff,nmo,homo,Eigenval,unit_nr,& Eigenval_beta,homo_beta,mo_coeff_beta) ELSE CALL solve_z_vector_eq(qs_env,mp2_env,para_env,dft_control,& - atomic_kind_set,mo_coeff,nmo,homo,Eigenval,unit_nr,error) + atomic_kind_set,mo_coeff,nmo,homo,Eigenval,unit_nr) ENDIF END IF DEALLOCATE(Eigenval,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(nspins==2) THEN DEALLOCATE(Eigenval_beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -883,7 +877,6 @@ END SUBROUTINE mp2_gpw_main !> \param mp2_memory ... !> \param calc_ex ... !> \param blacs_env_sub ... -!> \param error ... !> \param homo_beta ... !> \param mo_coeff_o_beta ... !> \param mo_coeff_v_beta ... @@ -894,7 +887,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co cell,particle_set,atomic_kind_set,qs_kind_set,mo_coeff,Eigenval,nmo,homo,& rho_r,rho_g,pot_g,mat_munu,pw_env_sub,& poisson_env,auxbas_pw_pool,task_list_sub,mo_coeff_o,mo_coeff_v,eps_filter,unit_nr,& - mp2_memory,calc_ex,blacs_env_sub,error,homo_beta,mo_coeff_o_beta,mo_coeff_v_beta,Eigenval_beta,Emp2_AB) + mp2_memory,calc_ex,blacs_env_sub,homo_beta,mo_coeff_o_beta,mo_coeff_v_beta,Eigenval_beta,Emp2_AB) REAL(KIND=dp) :: Emp2, Emp2_Cou, Emp2_EX TYPE(qs_environment_type), POINTER :: qs_env @@ -923,7 +916,6 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co REAL(KIND=dp) :: mp2_memory LOGICAL :: calc_ex TYPE(cp_blacs_env_type), POINTER :: blacs_env_sub - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, OPTIONAL :: homo_beta TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: mo_coeff_o_beta, & mo_coeff_v_beta @@ -983,18 +975,18 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co PRESENT(Emp2_AB)) do_alpha_beta=.TRUE. ! initialize and create the matrix (ia|jnu) - CALL cp_dbcsr_init(matrix_ia_jnu,error=error) - CALL cp_dbcsr_create(matrix_ia_jnu,template=mo_coeff_o,error=error) + CALL cp_dbcsr_init(matrix_ia_jnu) + CALL cp_dbcsr_create(matrix_ia_jnu,template=mo_coeff_o) ! Allocate Sparse matrices: (ia|jb) - CALL cp_dbcsr_init(matrix_ia_jb,error=error) + CALL cp_dbcsr_init(matrix_ia_jb) CALL cp_dbcsr_m_by_n_from_template(matrix_ia_jb,template=mo_coeff_o,m=homo,n=nmo-homo,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ! set all to zero in such a way that the memory is actually allocated - CALL cp_dbcsr_set(matrix_ia_jnu,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_ia_jb,0.0_dp,error=error) - CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ia_jnu,0.0_dp) + CALL cp_dbcsr_set(matrix_ia_jb,0.0_dp) + CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp) IF(calc_ex) THEN ! create the analogous of matrix_ia_jb in fm type @@ -1002,24 +994,23 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co NULLIFY(fm_struct) CALL cp_dbcsr_get_info(matrix_ia_jb,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env_sub,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env_sub,error=error) - CALL cp_fm_create(fm_BIb_jb,fm_struct,name="fm_BIb_jb",error=error) + ncol_global=nfullcols_total,para_env=para_env_sub) + CALL cp_fm_create(fm_BIb_jb,fm_struct,name="fm_BIb_jb") - CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb, error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb) + CALL cp_fm_struct_release(fm_struct) CALL cp_fm_get_info(matrix=fm_BIb_jb,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) max_row_col_local=MAX(nrow_local,ncol_local) CALL mp_max(max_row_col_local,para_env_sub%group) ALLOCATE(local_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_col_row_info=0 ! 0,1 nrows local_col_row_info(0,1)=nrow_local @@ -1031,18 +1022,18 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co IF(do_alpha_beta) THEN ! initialize and create the matrix (ia|jnu) - CALL cp_dbcsr_init(matrix_ia_jnu_beta,error=error) - CALL cp_dbcsr_create(matrix_ia_jnu_beta,template=mo_coeff_o_beta,error=error) + CALL cp_dbcsr_init(matrix_ia_jnu_beta) + CALL cp_dbcsr_create(matrix_ia_jnu_beta,template=mo_coeff_o_beta) ! Allocate Sparse matrices: (ia|jb) - CALL cp_dbcsr_init(matrix_ia_jb_beta,error=error) + CALL cp_dbcsr_init(matrix_ia_jb_beta) CALL cp_dbcsr_m_by_n_from_template(matrix_ia_jb_beta,template=mo_coeff_o_beta,m=homo_beta,n=nmo-homo_beta,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) virtual_beta=nmo-homo_beta - CALL cp_dbcsr_set(matrix_ia_jnu_beta,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_ia_jb_beta,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ia_jnu_beta,0.0_dp) + CALL cp_dbcsr_set(matrix_ia_jb_beta,0.0_dp) END IF CALL m_memory(mem) @@ -1109,9 +1100,9 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co ENDIF ALLOCATE(vector_batch_I_size_group(0:p_best-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vector_batch_A_size_group(0:q_best-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vector_batch_I_size_group=max_batch_size_I IF(SUM(vector_batch_I_size_group)/=homo) THEN @@ -1173,14 +1164,14 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co CALL grep_occ_virt_wavefunc(para_env_sub,nmo,& my_I_occupied_start,my_I_occupied_end,my_I_batch_size,& my_A_virtual_start,my_A_virtual_end,my_A_batch_size,& - mo_coeff_o,mo_coeff_v,my_Cocc,my_Cvirt,error) + mo_coeff_o,mo_coeff_v,my_Cocc,my_Cvirt) ! divide the b states in the sub_group in such a way to create ! b_start and b_end for each proc inside the sub_group max_b_size=(virtual+para_env_sub%num_pe-1)/para_env_sub%num_pe ALLOCATE(vector_B_sizes(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vector_B_sizes=max_b_size IF(SUM(vector_B_sizes)/=virtual) THEN one=1 @@ -1210,7 +1201,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co ! A_start and B_start, communication will take place only among ! those proc that have the same A_start and B_start ALLOCATE(color_array(0:para_env_sub%num_pe-1,0:q_best-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) color_array=0 color_counter=0 DO j=0, q_best-1 @@ -1228,7 +1219,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co ! in mp_comm_split_direct the color is give by my_a_virtual_start and my_b_virtual_start CALL mp_comm_split_direct(para_env%group,comm_exchange,sub_sub_color) NULLIFY(para_env_exchange) - CALL cp_para_env_create(para_env_exchange,comm_exchange,error=error) + CALL cp_para_env_create(para_env_exchange,comm_exchange) ! crate the proc maps ALLOCATE(proc_map(-para_env_exchange%num_pe:2*para_env_exchange%num_pe-1)) @@ -1258,19 +1249,19 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co NULLIFY(psi_a%pw) CALL pw_pool_create_pw(auxbas_pw_pool,psi_a%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) ALLOCATE(psi_i(my_I_occupied_start:my_I_occupied_end),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=my_I_occupied_start, my_I_occupied_end NULLIFY(psi_i(i)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,psi_i(i)%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL calculate_wavefunction(mo_coeff,i,psi_i(i),rho_g, atomic_kind_set,& qs_kind_set,cell,dft_control,particle_set, & - pw_env_sub,external_vector=my_Cocc(:,i-my_I_occupied_start+1),error=error) + pw_env_sub,external_vector=my_Cocc(:,i-my_I_occupied_start+1)) END DO Emp2=0.0_dp @@ -1279,7 +1270,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co IF(do_alpha_beta) Emp2_AB=0.0_dp IF(calc_ex) THEN ALLOCATE(BIb_C(my_B_size,homo,my_I_batch_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timeset(routineN//"_loop",handle2) @@ -1290,7 +1281,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co ! psi_a CALL calculate_wavefunction(mo_coeff,a,psi_a,rho_g, atomic_kind_set,& qs_kind_set,cell,dft_control,particle_set, & - pw_env_sub,external_vector=my_Cvirt(:,a-(homo+my_A_virtual_start)+1),error=error) + pw_env_sub,external_vector=my_Cvirt(:,a-(homo+my_A_virtual_start)+1)) i_counter=0 DO i=my_I_occupied_start, my_I_occupied_end i_counter=i_counter+1 @@ -1298,37 +1289,37 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co ! potential CALL timeset(routineN//"_pot",handle3) rho_r%pw%cr3d = psi_i(i)%pw%cr3d * psi_a%pw%cr3d - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) CALL timestop(handle3) ! and finally (ia|munu) CALL timeset(routineN//"_int",handle3) - CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp) CALL integrate_v_rspace(rho_r,hmat=mat_munu,qs_env=qs_env,calculate_forces=.FALSE.,compute_tau=.FALSE.,gapw=.FALSE.,& - pw_env_external=pw_env_sub, task_list_external=task_list_sub, error=error) + pw_env_external=pw_env_sub, task_list_external=task_list_sub) CALL timestop(handle3) ! multiply and goooooooo ... CALL timeset(routineN//"_mult_o",handle3) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_o, & - 0.0_dp, matrix_ia_jnu, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jnu, filter_eps=eps_filter) IF(do_alpha_beta) THEN ! transform orbitals using the beta coeff matrix CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_o_beta, & - 0.0_dp, matrix_ia_jnu_beta, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jnu_beta, filter_eps=eps_filter) END IF CALL timestop(handle3) CALL timeset(routineN//"_mult_v",handle3) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, matrix_ia_jnu, mo_coeff_v, & - 0.0_dp, matrix_ia_jb, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jb, filter_eps=eps_filter) IF(do_alpha_beta) THEN ! transform orbitals using the beta coeff matrix CALL cp_dbcsr_multiply("T", "N", 1.0_dp, matrix_ia_jnu_beta, mo_coeff_v_beta, & - 0.0_dp, matrix_ia_jb_beta, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jb_beta, filter_eps=eps_filter) END IF CALL timestop(handle3) @@ -1370,11 +1361,10 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co ! b_start, b_end IF(calc_ex) THEN CALL timeset(routineN//"_E_Ex_1",handle3) - CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb, error=error) + CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb) CALL grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_C(1:my_B_size,1:homo,i_counter),max_row_col_local,& sub_proc_map,local_col_row_info,& - my_B_virtual_end,my_B_virtual_start,& - error) + my_B_virtual_end,my_B_virtual_start) CALL timestop(handle3) END IF @@ -1404,7 +1394,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co size_EX=exchange_group_sizes(proc_receive,3) ALLOCATE(BIb_EX(my_B_size,my_I_batch_size,size_EX),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_EX=0.0_dp EX_start_send=exchange_group_sizes(proc_send,1) @@ -1412,7 +1402,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co size_EX_send=exchange_group_sizes(proc_send,3) ALLOCATE(BIb_send(my_B_size,size_EX_send,my_I_batch_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_send(1:my_B_size,1:size_EX_send,1:my_I_batch_size)=BIb_C(1:my_B_size,EX_start_send:EX_end_send,1:my_I_batch_size) ! send and receive the exchange array @@ -1447,7 +1437,7 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co DEALLOCATE(my_Cvirt) IF(calc_ex) THEN - CALL cp_fm_release(fm_BIb_jb, error=error) + CALL cp_fm_release(fm_BIb_jb) DEALLOCATE(local_col_row_info) DEALLOCATE(BIb_C) END IF @@ -1455,21 +1445,21 @@ SUBROUTINE mp2_gpw_compute(Emp2,Emp2_Cou,Emp2_EX,qs_env,para_env,para_env_sub,co DEALLOCATE(sub_proc_map) DEALLOCATE(exchange_group_sizes) - CALL cp_para_env_release(para_env_exchange,error=error) + CALL cp_para_env_release(para_env_exchange) - CALL cp_dbcsr_release(matrix_ia_jnu,error=error) - CALL cp_dbcsr_release(matrix_ia_jb,error=error) + CALL cp_dbcsr_release(matrix_ia_jnu) + CALL cp_dbcsr_release(matrix_ia_jb) IF(do_alpha_beta) THEN - CALL cp_dbcsr_release(matrix_ia_jnu_beta,error=error) - CALL cp_dbcsr_release(matrix_ia_jb_beta,error=error) + CALL cp_dbcsr_release(matrix_ia_jnu_beta) + CALL cp_dbcsr_release(matrix_ia_jb_beta) END IF DO i=my_I_occupied_start, my_I_occupied_end - CALL pw_release(psi_i(i)%pw,error=error) + CALL pw_release(psi_i(i)%pw) END DO DEALLOCATE(psi_i) - CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_a%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_a%pw) CALL timestop(handle) @@ -1525,12 +1515,10 @@ SUBROUTINE estimate_memory_usage(wfn_size,p,q,num_w,nmo, virtual, homo,calc_ex,m !> \param local_col_row_info ... !> \param my_B_virtual_end ... !> \param my_B_virtual_start ... -!> \param error ... ! ***************************************************************************** SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& proc_map,local_col_row_info,& - my_B_virtual_end,my_B_virtual_start,& - error) + my_B_virtual_end,my_B_virtual_start) TYPE(cp_para_env_type), POINTER :: para_env_sub TYPE(cp_fm_type), POINTER :: fm_BIb_jb REAL(KIND=dp), DIMENSION(:, :) :: BIb_jb @@ -1539,7 +1527,6 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& INTEGER, ALLOCATABLE, DIMENSION(:, :) :: local_col_row_info INTEGER :: my_B_virtual_end, & my_B_virtual_start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'grep_my_integrals', & routineP = moduleN//':'//routineN @@ -1557,7 +1544,7 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& failure=.FALSE. ALLOCATE(rec_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_col_row_info(:,:)=local_col_row_info @@ -1565,11 +1552,11 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& ncol_rec=rec_col_row_info(0,2) ALLOCATE(row_indices_rec(nrow_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices_rec=rec_col_row_info(1:nrow_rec,1) ALLOCATE(col_indices_rec(ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices_rec=rec_col_row_info(1:ncol_rec,2) ! accumulate data on BIb_jb buffer starting from myself @@ -1601,15 +1588,15 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& ncol_rec=rec_col_row_info(0,2) ALLOCATE(row_indices_rec(nrow_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices_rec=rec_col_row_info(1:nrow_rec,1) ALLOCATE(col_indices_rec(ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices_rec=rec_col_row_info(1:ncol_rec,2) ALLOCATE(rec_BI(nrow_rec,ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_BI=0.0_dp ! then send and receive the real data @@ -1654,12 +1641,10 @@ END SUBROUTINE grep_my_integrals !> \param my_do_gw ... !> \param gw_corr_lev_occ ... !> \param gw_corr_lev_virt ... -!> \param error ... ! ***************************************************************************** SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dimen,homo,mat_munu,& mo_coeff_o,mo_coeff_v,mo_coeff_all,mo_coeff_gw,my_do_gw,& - gw_corr_lev_occ,gw_corr_lev_virt,& - error) + gw_corr_lev_occ,gw_corr_lev_virt) TYPE(mp2_type), POINTER :: mp2_env TYPE(cp_para_env_type), POINTER :: para_env, para_env_sub TYPE(cp_fm_type), POINTER :: mo_coeff @@ -1670,7 +1655,6 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime LOGICAL :: my_do_gw INTEGER :: gw_corr_lev_occ, & gw_corr_lev_virt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'replicate_mat_to_subgroup', & routineP = moduleN//':'//routineN @@ -1698,12 +1682,12 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime failure=.FALSE. ALLOCATE(sizes_array(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(starts_array(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts_array=0 ALLOCATE(ends_array(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends_array=0 DO iproc=0,para_env_sub%num_pe-1 @@ -1719,7 +1703,7 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime ! local storage for the C matrix ALLOCATE(C(my_mu_size,dimen),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) C=0.0_dp ! proc_map, vector that replicate the processor numbers also @@ -1727,7 +1711,7 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime ! needed to know which is the processor, to respect to another one, ! for a given shift ALLOCATE(proc_map(-para_env%num_pe:2*para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=0,para_env%num_pe-1 proc_map(iiB)=iiB proc_map(-iiB-1)=para_env%num_pe-iiB-1 @@ -1740,11 +1724,10 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime ncol_local=ncol_local,& row_indices=row_indices,& col_indices=col_indices,& - local_data=local_C_internal,& - error=error) + local_data=local_C_internal) ALLOCATE(local_C(nrow_local,ncol_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_C=local_C_internal(1:nrow_local,1:ncol_local) NULLIFY(local_C_internal) @@ -1752,7 +1735,7 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime CALL mp_max(max_row_col_local,para_env%group) ALLOCATE(local_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_col_row_info=0 ! 0,1 nrows local_col_row_info(0,1)=nrow_local @@ -1762,7 +1745,7 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime local_col_row_info(1:ncol_local,2)=col_indices(1:ncol_local) ALLOCATE(rec_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! accumulate data on C buffer starting from myself DO iiB=1, nrow_local @@ -1789,15 +1772,15 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime ncol_rec=rec_col_row_info(0,2) ALLOCATE(row_indices_rec(nrow_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices_rec=rec_col_row_info(1:nrow_rec,1) ALLOCATE(col_indices_rec(ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices_rec=rec_col_row_info(1:ncol_rec,2) ALLOCATE(rec_C(nrow_rec,ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_C=0.0_dp ! then send and receive the real data @@ -1817,7 +1800,7 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime local_col_row_info(:,:)=rec_col_row_info DEALLOCATE(local_C) ALLOCATE(local_C(nrow_rec,ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_C=rec_C DEALLOCATE(col_indices_rec) @@ -1831,7 +1814,7 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime ! proc_map, for the sub_group ALLOCATE(proc_map(-para_env_sub%num_pe:2*para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=0,para_env_sub%num_pe-1 proc_map(iiB)=iiB proc_map(-iiB-1)=para_env_sub%num_pe-iiB-1 @@ -1840,12 +1823,12 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime ! split the C matrix into occupied and virtual ALLOCATE(Cocc(my_mu_size,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Cocc(1:my_mu_size,1:homo)=C(1:my_mu_size,1:homo) virtual=dimen-homo ALLOCATE(Cvirt(my_mu_size,virtual),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Cvirt(1:my_mu_size,1:virtual)=C(1:my_mu_size,homo+1:dimen) ! create and fill mo_coeff_o, mo_coeff_v and mo_coeff_all @@ -1854,19 +1837,19 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime col_offset,i_global,j_global,my_mu_start,my_mu_end,& mat_munu,iter,& data_block,ends_array,proc_map, & - sizes_array,starts_array,error) + sizes_array,starts_array) CALL build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_v,Cvirt,& virtual,blk,row,col,row_size,col_size,row_offset,& col_offset,i_global,j_global,my_mu_start,my_mu_end,& mat_munu,iter,& data_block,ends_array,proc_map, & - sizes_array,starts_array,error) + sizes_array,starts_array) IF (my_do_gw) THEN ! also cut levels homo-gw_corr_lev_occ+1, ..., lumo+gw_corr_lev_virt-1 of C ALLOCATE(Cgw(my_mu_size,gw_corr_lev_occ+gw_corr_lev_virt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Cgw(1:my_mu_size,1:(gw_corr_lev_occ+gw_corr_lev_virt))=& C(1:my_mu_size,homo-gw_corr_lev_occ+1:homo+gw_corr_lev_virt) CALL build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_gw,Cgw,& @@ -1875,14 +1858,14 @@ SUBROUTINE replicate_mat_to_subgroup(mp2_env,para_env,para_env_sub,mo_coeff,dime col_offset,i_global,j_global,my_mu_start,my_mu_end,& mat_munu,iter,& data_block,ends_array,proc_map, & - sizes_array,starts_array,error) + sizes_array,starts_array) ! all levels CALL build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_all,C,& dimen,blk,row,col,row_size,col_size,row_offset,& col_offset,i_global,j_global,my_mu_start,my_mu_end,& mat_munu,iter,& data_block,ends_array,proc_map, & - sizes_array,starts_array,error) + sizes_array,starts_array) ELSE DEALLOCATE(C) @@ -1912,12 +1895,11 @@ END SUBROUTINE replicate_mat_to_subgroup !> \param mo_coeff_v ... !> \param my_Cocc ... !> \param my_Cvirt ... -!> \param error ... ! ***************************************************************************** SUBROUTINE grep_occ_virt_wavefunc(para_env_sub,dimen,& my_I_occupied_start,my_I_occupied_end,my_I_batch_size,& my_A_virtual_start,my_A_virtual_end,my_A_batch_size,& - mo_coeff_o,mo_coeff_v,my_Cocc,my_Cvirt,error) + mo_coeff_o,mo_coeff_v,my_Cocc,my_Cvirt) TYPE(cp_para_env_type), POINTER :: para_env_sub INTEGER :: dimen, my_I_occupied_start, my_I_occupied_end, & @@ -1925,7 +1907,6 @@ SUBROUTINE grep_occ_virt_wavefunc(para_env_sub,dimen,& TYPE(cp_dbcsr_type), POINTER :: mo_coeff_o, mo_coeff_v REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: my_Cocc, my_Cvirt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'grep_occ_virt_wavefunc', & routineP = moduleN//':'//routineN @@ -1942,11 +1923,11 @@ SUBROUTINE grep_occ_virt_wavefunc(para_env_sub,dimen,& failure=.FALSE. ALLOCATE(my_Cocc(dimen,my_I_batch_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_Cocc=0.0_dp ALLOCATE(my_Cvirt(dimen,my_A_batch_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_Cvirt=0.0_dp ! accumulate data from mo_coeff_o into Cocc @@ -2018,7 +1999,6 @@ END SUBROUTINE grep_occ_virt_wavefunc !> \param proc_map ... !> \param sizes_array ... !> \param starts_array ... -!> \param error ... !> \author Jan Wilhelm ! ***************************************************************************** SUBROUTINE build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_to_build,Cread,& @@ -2026,7 +2006,7 @@ SUBROUTINE build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_to_build,Cread,& col_offset,i_global,j_global,my_mu_start,my_mu_end,& mat_munu,iter,& data_block,ends_array,proc_map, & - sizes_array,starts_array,error) + sizes_array,starts_array) TYPE(mp2_type), POINTER :: mp2_env TYPE(cp_para_env_type), POINTER :: para_env_sub TYPE(cp_dbcsr_type), POINTER :: mo_coeff_to_build @@ -2039,7 +2019,6 @@ SUBROUTINE build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_to_build,Cread,& REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block INTEGER, ALLOCATABLE, DIMENSION(:) :: ends_array, proc_map, & sizes_array, starts_array - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_mo_coeff_v_o_all', & routineP = moduleN//':'//routineN @@ -2054,10 +2033,10 @@ SUBROUTINE build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_to_build,Cread,& failure=.FALSE. NULLIFY(mo_coeff_to_build) - CALL cp_dbcsr_init_p(mo_coeff_to_build,error=error) + CALL cp_dbcsr_init_p(mo_coeff_to_build) CALL cp_dbcsr_m_by_n_from_row_template(mo_coeff_to_build,template=mat_munu%matrix,n=number_of_level,& - sym=dbcsr_type_no_symmetry,data_type=dbcsr_type_real_default,error=error) - CALL cp_dbcsr_reserve_all_blocks(mo_coeff_to_build,error) + sym=dbcsr_type_no_symmetry,data_type=dbcsr_type_real_default) + CALL cp_dbcsr_reserve_all_blocks(mo_coeff_to_build) ! accumulate data on mo_coeff_to_build starting from myself @@ -2089,7 +2068,7 @@ SUBROUTINE build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_to_build,Cread,& rec_mu_size=sizes_array(proc_receive) ALLOCATE(rec_C(rec_mu_size,number_of_level),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_C=0.0_dp ! then send and receive the real data @@ -2116,7 +2095,7 @@ SUBROUTINE build_mo_coeff_v_o_all(mp2_env,para_env_sub,mo_coeff_to_build,Cread,& DEALLOCATE(rec_C) END DO - CALL cp_dbcsr_filter(mo_coeff_to_build,mp2_env%mp2_gpw%eps_filter,error=error) + CALL cp_dbcsr_filter(mo_coeff_to_build,mp2_env%mp2_gpw%eps_filter) DEALLOCATE(Cread) diff --git a/src/mp2_laplace.F b/src/mp2_laplace.F index 9e0c1c6376..d6af5b1832 100644 --- a/src/mp2_laplace.F +++ b/src/mp2_laplace.F @@ -56,7 +56,6 @@ MODULE mp2_laplace !> \param fm_mat_S ... !> \param fm_mat_Q_gemm ... !> \param fm_mat_Q ... -!> \param error ... !> \param homo_beta ... !> \param virtual_beta ... !> \param dimen_ia_beta ... @@ -67,7 +66,7 @@ MODULE mp2_laplace ! ***************************************************************************** SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtual,dimen_RI,dimen_ia,Eigenval,& num_integ_points,num_integ_group,color_rpa_group,& - fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,error,& + fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,& homo_beta,virtual_beta,dimen_ia_beta,Eigenval_beta,fm_mat_S_beta,& fm_mat_Q_gemm_beta,fm_mat_Q_beta) REAL(KIND=dp) :: Emp2 @@ -80,7 +79,6 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua color_rpa_group TYPE(cp_fm_type), POINTER :: fm_mat_S, fm_mat_Q_gemm, & fm_mat_Q - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, OPTIONAL :: homo_beta, virtual_beta, & dimen_ia_beta REAL(KIND=dp), DIMENSION(:), OPTIONAL :: Eigenval_beta @@ -126,7 +124,7 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua ! Calculate weights and exponents with minimax approximation ALLOCATE(awj(2*num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) awj=0.0_dp Emin=2.0_dp*(Eigenval(homo+1)-Eigenval(homo)) @@ -143,13 +141,13 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua IF(E_Range<2.0_dp) E_Range=2.0_dp ierr=0 - CALL get_minimax_coeff(num_integ_points,E_Range,awj,ierr,error) + CALL get_minimax_coeff(num_integ_points,E_Range,awj,ierr) ALLOCATE(aj(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) aj=0.0_dp ALLOCATE(wj(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wj=0.0_dp DO jquad=1, num_integ_points @@ -176,11 +174,11 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua ! initialize buffer for matrix redistribution CALL initialize_buffer(fm_mat_Q_gemm,fm_mat_Q,RPA_proc_map,buffer_rec,buffer_send,& number_of_rec,number_of_send,& - map_send_size,map_rec_size,local_size_source,para_env_RPA,error) + map_send_size,map_rec_size,local_size_source,para_env_RPA) IF(my_open_shell) THEN CALL initialize_buffer(fm_mat_Q_gemm_beta,fm_mat_Q_beta,RPA_proc_map,buffer_rec_beta,buffer_send_beta,& number_of_rec_beta,number_of_send_beta,& - map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA,error) + map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA) END IF Emp2=0.0_dp @@ -193,23 +191,22 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua IF(MODULO(jquad,num_integ_group)/=color_rpa_group) CYCLE !XXX ! copy fm_mat_S into fm_mat_G - !XXX CALL cp_fm_to_fm(source=fm_mat_S,destination=fm_mat_G,error=error) + !XXX CALL cp_fm_to_fm(source=fm_mat_S,destination=fm_mat_G) !XXX ! get info of fm_mat_G !XXX CALL cp_fm_get_info(matrix=fm_mat_G,& !XXX nrow_local=nrow_local,& !XXX ncol_local=ncol_local,& !XXX row_indices=row_indices,& - !XXX col_indices=col_indices,& - !XXX error=error) + !XXX col_indices=col_indices) + !XXX ! get info of fm_mat_S CALL cp_fm_get_info(matrix=fm_mat_S,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ! update G matrix with the new value of w and a IF(first_cycle) THEN @@ -250,37 +247,36 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua t_start=m_walltime() CALL cp_gemm(transa="T",transb="N",m=dimen_RI,n=dimen_RI,k=dimen_ia,alpha=1.0_dp,& matrix_a=fm_mat_S,matrix_b=fm_mat_S,beta=0.0_dp,& - matrix_c=fm_mat_Q_gemm,error=error) + matrix_c=fm_mat_Q_gemm) t_end=m_walltime() actual_flop_rate=2.0_dp*REAL(dimen_ia,KIND=dp)*dimen_RI*REAL(dimen_RI,KIND=dp)/(MAX(0.01_dp,t_end-t_start)) IF(para_env_RPA%mepos==0) my_flop_rate=my_flop_rate+actual_flop_rate my_num_dgemm_call=my_num_dgemm_call+1 ! copy/redistribute fm_mat_Q_gemm to fm_mat_Q - CALL cp_fm_set_all(matrix=fm_mat_Q,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_mat_Q,alpha=0.0_dp) CALL fm_redistribute(fm_mat_Q_gemm,fm_mat_Q,RPA_proc_map,buffer_rec,buffer_send,& number_of_send,& - map_send_size,map_rec_size,local_size_source,para_env_RPA,error) + map_send_size,map_rec_size,local_size_source,para_env_RPA) IF(my_open_shell) THEN !XXX the same for the beta spin !XXX ! copy fm_mat_S into fm_mat_G - !XXX CALL cp_fm_to_fm(source=fm_mat_S_beta,destination=fm_mat_G_beta,error=error) + !XXX CALL cp_fm_to_fm(source=fm_mat_S_beta,destination=fm_mat_G_beta) !XXX ! get info of fm_mat_G_beta !XXX CALL cp_fm_get_info(matrix=fm_mat_G_beta,& !XXX nrow_local=nrow_local,& !XXX ncol_local=ncol_local,& !XXX row_indices=row_indices,& - !XXX col_indices=col_indices,& - !XXX error=error) + !XXX col_indices=col_indices) + !XXX ! the same for the beta spin CALL cp_fm_get_info(matrix=fm_mat_S_beta,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ! update G matrix with the new value of w and a IF(first_cycle) THEN DO jjB=1, ncol_local @@ -322,17 +318,17 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua t_start=m_walltime() CALL cp_gemm(transa="T",transb="N",m=dimen_RI,n=dimen_RI,k=dimen_ia_beta,alpha=1.0_dp,& matrix_a=fm_mat_S_beta,matrix_b=fm_mat_S_beta,beta=0.0_dp,& - matrix_c=fm_mat_Q_gemm_beta,error=error) + matrix_c=fm_mat_Q_gemm_beta) t_end=m_walltime() actual_flop_rate=2.0_dp*REAL(dimen_ia_beta,KIND=dp)*dimen_RI*REAL(dimen_RI,KIND=dp)/(MAX(0.01_dp,t_end-t_start)) IF(para_env_RPA%mepos==0) my_flop_rate=my_flop_rate+actual_flop_rate my_num_dgemm_call=my_num_dgemm_call+1 ! copy/redistribute fm_mat_Q_gemm to fm_mat_Q - CALL cp_fm_set_all(matrix=fm_mat_Q_beta,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_mat_Q_beta,alpha=0.0_dp) CALL fm_redistribute(fm_mat_Q_gemm_beta,fm_mat_Q_beta,RPA_proc_map,buffer_rec_beta,buffer_send_beta,& number_of_send_beta,& - map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA,error) + map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA) END IF @@ -341,8 +337,7 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ! calcualte the trace of the product Q*Q trace_XX=0.0_dp @@ -377,12 +372,12 @@ SUBROUTINE laplace_minimax_approx(Emp2,para_env,para_env_RPA,unit_nr,homo,virtua ! release buffer CALL release_buffer(RPA_proc_map,buffer_rec,buffer_send,& number_of_rec,number_of_send,& - map_send_size,map_rec_size,local_size_source,error) + map_send_size,map_rec_size,local_size_source) IF(my_open_shell) THEN CALL release_buffer(RPA_proc_map,buffer_rec_beta,buffer_send_beta,& number_of_rec_beta,number_of_send_beta,& - map_send_size_beta,map_rec_size_beta,local_size_source_beta,error) + map_send_size_beta,map_rec_size_beta,local_size_source_beta) END IF DEALLOCATE(aj) diff --git a/src/mp2_optimize_ri_basis.F b/src/mp2_optimize_ri_basis.F index ce135d8c65..f23c030677 100644 --- a/src/mp2_optimize_ri_basis.F +++ b/src/mp2_optimize_ri_basis.F @@ -83,7 +83,6 @@ MODULE mp2_optimize_ri_basis !> \param rho ... !> \param para_env ... !> \param unit_nr ... -!> \param error ... !> \param homo_beta ... !> \param C_beta ... !> \param Auto_beta ... @@ -92,7 +91,7 @@ MODULE mp2_optimize_ri_basis SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,natom,homo, & mp2_biel,mp2_env,C,Auto,kind_of,& qs_env,rho,para_env, & - unit_nr,error,homo_beta,C_beta,Auto_beta) + unit_nr,homo_beta,C_beta,Auto_beta) REAL(KIND=dp) :: Emp2, Emp2_Cou, Emp2_ex, & Emp2_S, Emp2_T @@ -107,7 +106,6 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, OPTIONAL :: homo_beta REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :), OPTIONAL :: C_beta @@ -150,7 +148,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() open_shell_case=.FALSE. IF(PRESENT(homo_beta).AND.PRESENT(C_beta).AND.PRESENT(Auto_beta)) open_shell_case=.TRUE. @@ -176,11 +174,11 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato Emp2_AA=0.0_dp Emp2_AA_Cou=0.0_dp Emp2_AA_ex=0.0_dp - CALL calc_elem_ij_proc(homo,homo,para_env,elements_ij_proc,ij_list_proc,error) + CALL calc_elem_ij_proc(homo,homo,para_env,elements_ij_proc,ij_list_proc) CALL mp2_canonical_direct_single_batch(Emp2_AA,Emp2_AA_Cou,Emp2_AA_ex,mp2_env,qs_env,rho,para_env,& mp2_biel,dimen,C,Auto,0,homo,homo,& elements_ij_proc,ij_list_proc,homo,0,& - Integ_MP2=Integ_MP2_AA,error=error) + Integ_MP2=Integ_MP2_AA) CALL mp_sum(Emp2_AA_Cou,para_env%group) CALL mp_sum(Emp2_AA_Ex,para_env%group) CALL mp_sum(Emp2_AA,para_env%group) @@ -190,11 +188,11 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato Emp2_BB=0.0_dp Emp2_BB_Cou=0.0_dp Emp2_BB_ex=0.0_dp - CALL calc_elem_ij_proc(homo_beta,homo_beta,para_env,elements_ij_proc,ij_list_proc,error) + CALL calc_elem_ij_proc(homo_beta,homo_beta,para_env,elements_ij_proc,ij_list_proc) CALL mp2_canonical_direct_single_batch(Emp2_BB,Emp2_BB_Cou,Emp2_BB_ex,mp2_env,qs_env,rho,para_env,& mp2_biel,dimen,C_beta,Auto_beta,0,homo_beta,homo_beta,& elements_ij_proc,ij_list_proc,homo_beta,0,& - Integ_MP2=Integ_MP2_BB,error=error) + Integ_MP2=Integ_MP2_BB) CALL mp_sum(Emp2_BB_Cou,para_env%group) CALL mp_sum(Emp2_BB_Ex,para_env%group) CALL mp_sum(Emp2_BB,para_env%group) @@ -204,11 +202,11 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato Emp2_AB=0.0_dp Emp2_AB_Cou=0.0_dp Emp2_AB_ex=0.0_dp - CALL calc_elem_ij_proc(homo,homo_beta,para_env,elements_ij_proc,ij_list_proc,error) + CALL calc_elem_ij_proc(homo,homo_beta,para_env,elements_ij_proc,ij_list_proc) CALL mp2_canonical_direct_single_batch(Emp2_AB,Emp2_AB_Cou,Emp2_AB_ex,mp2_env,qs_env,rho,para_env,& mp2_biel,dimen,C,Auto,0,homo,homo,& elements_ij_proc, ij_list_proc,homo_beta,0,& - homo_beta,C_beta,Auto_beta,Integ_MP2=Integ_MP2_AB,error=error) + homo_beta,C_beta,Auto_beta,Integ_MP2=Integ_MP2_AB) CALL mp_sum(Emp2_AB_Cou,para_env%group) CALL mp_sum(Emp2_AB_Ex,para_env%group) CALL mp_sum(Emp2_AB,para_env%group) @@ -232,11 +230,11 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato ELSE ! close shell case - CALL calc_elem_ij_proc(homo,homo,para_env,elements_ij_proc,ij_list_proc,error) + CALL calc_elem_ij_proc(homo,homo,para_env,elements_ij_proc,ij_list_proc) CALL mp2_canonical_direct_single_batch(Emp2,Emp2_Cou,Emp2_ex,mp2_env,qs_env,rho,para_env,& mp2_biel,dimen,C,Auto,0,homo,homo,& elements_ij_proc,ij_list_proc,homo,0,& - Integ_MP2=Integ_MP2,error=error) + Integ_MP2=Integ_MP2) CALL mp_sum(Emp2_Cou,para_env%group) CALL mp_sum(Emp2_Ex,para_env%group) CALL mp_sum(Emp2,para_env%group) @@ -252,7 +250,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato color_sub=para_env%mepos/mp2_env%mp2_num_proc CALL mp_comm_split_direct(para_env%group,comm_sub,color_sub) NULLIFY(para_env_sub) - CALL cp_para_env_create(para_env_sub,comm_sub,error=error) + CALL cp_para_env_create(para_env_sub,comm_sub) IF (para_env%mepos==para_env%source) THEN local_unit_nr=cp_logger_get_default_unit_nr(logger,local=.FALSE.) @@ -265,11 +263,11 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato CALL cp_logger_set(logger_sub,local_filename="opt_RI_basis_localLog") CALL cp_add_default_logger(logger_sub) - CALL generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev,basis_was_assoc,error) + CALL generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev,basis_was_assoc) CALL read_RI_basis_set(qs_env,RI_basis_parameter,RI_basis_info,& natom,nkind,kind_of,index_table_RI,dimen_RI,& - basis_S0,error) + basis_S0) ndof=0 max_l_am=0 @@ -307,28 +305,28 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato ! Allocate stuff ALLOCATE(p(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) p=0.0_dp ALLOCATE(xi(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) xi=0.0_dp ALLOCATE(g(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) g=0.0_dp ALLOCATE(dg(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dg=0.0_dp ALLOCATE(hdg(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) hdg=0.0_dp ALLOCATE(pnew(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pnew=0.0_dp ALLOCATE(deriv(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) deriv=0.0_dp ALLOCATE(hessin(ndof,ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) hessin=0.0_dp DO i=1, ndof hessin(i,i)=1.0_dp @@ -336,17 +334,17 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato ! initialize trasformation function ALLOCATE(lower_B(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lower_B=0.0_dp ALLOCATE(max_dev(ndof),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_dev=0.0_dp ! Initialize the transformation function CALL init_transf(nkind,RI_basis_parameter,lower_B,max_dev,max_rel_dev) ! get the atomic kind set for writing the basis - CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,error=error) + CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set) ! Calculate RI-MO-ERI's CALL calc_energy_func(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,Emp2_RI,DRI,DI,& @@ -355,7 +353,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato kind_of,index_table_RI,mp2_biel,mp2_env,Auto,C,& RI_basis_parameter,RI_basis_info,basis_S0,& open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,para_env,unit_nr,& - .TRUE.,error) + .TRUE.) ! ! Calculate function (DI) derivatives with respect to the RI basis exponent CALL calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI,& @@ -366,7 +364,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,& para_env,para_env_sub,number_groups,color_sub,unit_nr,& p,lower_B,max_dev,& - deriv,error) + deriv) g(:)=deriv xi(:)=-g @@ -398,7 +396,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato IF(reset_boundary) THEN IF (unit_nr>0) WRITE(unit_nr,'(T3,A)') 'RESET BASIS: one of the exponent hits the boundary' CALL reset_basis(nkind,ndof,RI_basis_parameter,reset_edge,& - pnew,lower_B,max_dev,max_rel_dev,exp_limits,error) + pnew,lower_B,max_dev,max_rel_dev,exp_limits) p(:)=pnew xi=0.0_dp g=0.0_dp @@ -417,7 +415,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato kind_of,index_table_RI,mp2_biel,mp2_env,Auto,C,& RI_basis_parameter,RI_basis_info,basis_S0,& open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,para_env,unit_nr,& - .FALSE.,error) + .FALSE.) ! ! Calculate function (DI) derivatives with respect to the RI basis exponent CALL calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI,& Integ_MP2,Integ_MP2_AA,Integ_MP2_BB,Integ_MP2_AB,eps_step,& @@ -427,7 +425,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,& para_env,para_env_sub,number_groups,color_sub,unit_nr,& p,lower_B,max_dev,& - deriv,error) + deriv) g(:)=deriv xi(:)=-g @@ -442,7 +440,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato kind_of,index_table_RI,mp2_biel,mp2_env,Auto,C,& RI_basis_parameter,RI_basis_info,basis_S0,& open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,para_env,unit_nr,& - .FALSE.,error) + .FALSE.) ! update energy and direction DI=DI_new @@ -454,7 +452,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato WRITE(unit_nr,*) DO ikind=1, nkind CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=ri_aux_basis,& - basis_type="RI_AUX",error=error) + basis_type="RI_AUX") WRITE(unit_nr,'(T3,A,A)') atomic_kind_set(ikind)%element_symbol,' RI_opt_basis' WRITE(unit_nr,'(T3,I3)') RI_basis_parameter(ikind)%nset DO iset=1, RI_basis_parameter(ikind)%nset @@ -488,7 +486,7 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,& para_env,para_env_sub,number_groups,color_sub,unit_nr,& p,lower_B,max_dev,& - deriv,error) + deriv) ! g is the vector containing the old gradient dg(:)=deriv-g @@ -561,9 +559,9 @@ SUBROUTINE optimize_ri_basis_main(Emp2,Emp2_Cou,Emp2_ex,Emp2_S,Emp2_T,dimen,nato DEALLOCATE(index_table_RI) ! Release RI basis set - CALL release_RI_basis_set(RI_basis_parameter,basis_S0,error) + CALL release_RI_basis_set(RI_basis_parameter,basis_S0) - CALL cp_para_env_release(para_env_sub,error) + CALL cp_para_env_release(para_env_sub) CALL cp_rm_default_logger() CALL cp_logger_release(logger_sub) @@ -613,7 +611,6 @@ END SUBROUTINE optimize_ri_basis_main !> \param lower_B ... !> \param max_dev ... !> \param deriv ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI_ref,& Integ_MP2,Integ_MP2_AA,Integ_MP2_BB,Integ_MP2_AB,eps,& @@ -623,7 +620,7 @@ SUBROUTINE calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI_ref,& open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,& para_env,para_env_sub,number_groups,color_sub,unit_nr,& p,lower_B,max_dev,& - deriv,error) + deriv) REAL(KIND=dp) :: Emp2, Emp2_AA, Emp2_BB, & Emp2_AB, DI_ref REAL(KIND=dp), ALLOCATABLE, & @@ -654,7 +651,6 @@ SUBROUTINE calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI_ref,& INTEGER :: number_groups, color_sub, & unit_nr REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: p, lower_B, max_dev, deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_energy_func_der', & routineP = moduleN//':'//routineN @@ -684,7 +680,7 @@ SUBROUTINE calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI_ref,& ! ! calculate the numerical derivative ! ! The eps is the relative change of the exponent for the ! ! calculation of the numerical derivative - ! CPPostcondition(RI_basis_parameter(ikind)%npgf(iset)==1,cp_failure_level,routineP,error,failure) + ! CPPostcondition(RI_basis_parameter(ikind)%npgf(iset)==1,cp_failure_level,routineP,failure) ! step=eps*RI_basis_parameter(ikind)%zet(1,iset) ! temp=RI_basis_parameter(ikind)%zet(1,iset)+step ! step=temp-RI_basis_parameter(ikind)%zet(1,iset) @@ -692,7 +688,7 @@ SUBROUTINE calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI_ref,& ! in the new case eps is just the step length for calculating the numerical derivative - CPPostcondition(RI_basis_parameter(ikind)%npgf(iset)==1,cp_failure_level,routineP,error,failure) + CPPostcondition(RI_basis_parameter(ikind)%npgf(iset)==1,cp_failure_level,routineP,failure) orig_basis_val=RI_basis_parameter(ikind)%zet(1,iset) temp=p(ideriv)+step CALL transf_val(lower_B(ideriv), max_dev(ideriv), temp, new_basis_val) @@ -704,7 +700,7 @@ SUBROUTINE calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI_ref,& kind_of,index_table_RI,mp2_biel,mp2_env,Auto,C,& RI_basis_parameter,RI_basis_info,basis_S0,& open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,& - para_env_sub,unit_nr,.TRUE.,error) + para_env_sub,unit_nr,.TRUE.) RI_basis_parameter(ikind)%zet(1,iset)=orig_basis_val @@ -759,7 +755,6 @@ SUBROUTINE calc_energy_func_der(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,DI_ref,& !> \param para_env ... !> \param unit_nr ... !> \param no_write ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_energy_func(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,Emp2_RI,DRI,DI,& Integ_MP2,Integ_MP2_AA,Integ_MP2_BB,Integ_MP2_AB,& @@ -767,7 +762,7 @@ SUBROUTINE calc_energy_func(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,Emp2_RI,DRI,DI,& kind_of,index_table_RI,mp2_biel,mp2_env,Auto,C,& RI_basis_parameter,RI_basis_info,basis_S0,& open_shell_case,homo_beta,virtual_beta,Auto_beta,C_beta,para_env,unit_nr,& - no_write,error) + no_write) REAL(KIND=dp) :: Emp2, Emp2_AA, Emp2_BB, & Emp2_AB, Emp2_RI, DRI, DI REAL(KIND=dp), ALLOCATABLE, & @@ -796,7 +791,6 @@ SUBROUTINE calc_energy_func(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,Emp2_RI,DRI,DI,& TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: unit_nr LOGICAL :: no_write - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_energy_func', & routineP = moduleN//':'//routineN @@ -814,11 +808,11 @@ SUBROUTINE calc_energy_func(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,Emp2_RI,DRI,DI,& CALL libint_ri_mp2(dimen,dimen_RI,homo,natom,mp2_biel,mp2_env,C,& kind_of,RI_basis_parameter,RI_basis_info,basis_S0,index_table_RI,& - qs_env,para_env,Lai,error) + qs_env,para_env,Lai) IF(open_shell_case) THEN CALL libint_ri_mp2(dimen,dimen_RI,homo_beta,natom,mp2_biel,mp2_env,C_beta,& kind_of,RI_basis_parameter,RI_basis_info,basis_S0,index_table_RI,& - qs_env,para_env,Lai_beta,error) + qs_env,para_env,Lai_beta) END IF ! Contract integrals into energy @@ -827,19 +821,19 @@ SUBROUTINE calc_energy_func(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,Emp2_RI,DRI,DI,& CALL contract_integrals(DI_AA,Emp2_RI_AA,DRI_AA,Emp2_AA,homo,homo,virtual,virtual,& 1.0_dp,0.5_dp,.TRUE.,& Auto,Auto,Integ_MP2_AA,& - Lai,Lai,para_env,error) + Lai,Lai,para_env) ! beta-beta CALL contract_integrals(DI_BB,Emp2_RI_BB,DRI_BB,Emp2_BB,homo_beta,homo_beta,virtual_beta,virtual_beta,& 1.0_dp,0.5_dp,.TRUE.,& Auto_beta,Auto_beta,Integ_MP2_BB,& - Lai_beta,Lai_beta,para_env,error) + Lai_beta,Lai_beta,para_env) ! alpha-beta CALL contract_integrals(DI_AB,Emp2_RI_AB,DRI_AB,Emp2_AB*2.0_dp,homo,homo_beta,virtual,virtual_beta,& 1.0_dp,1.0_dp,.FALSE.,& Auto,Auto_beta,Integ_MP2_AB,& - Lai,Lai_beta,para_env,error) + Lai,Lai_beta,para_env) Emp2_RI=Emp2_RI_AA+Emp2_RI_BB+Emp2_RI_AB DRI=DRI_AA+DRI_BB+DRI_AB @@ -848,7 +842,7 @@ SUBROUTINE calc_energy_func(Emp2,Emp2_AA,Emp2_BB,Emp2_AB,Emp2_RI,DRI,DI,& CALL contract_integrals(DI,Emp2_RI,DRI,Emp2,homo,homo,virtual,virtual,& 2.0_dp,1.0_dp,.TRUE.,& Auto,Auto,Integ_MP2,& - Lai,Lai,para_env,error) + Lai,Lai,para_env) END IF IF(.NOT.no_write) THEN @@ -933,10 +927,9 @@ SUBROUTINE p2basis(nkind,RI_basis_parameter,Lower_B,max_dev,p) !> \param max_dev ... !> \param max_rel_dev ... !> \param exp_limits ... -!> \param error ... ! ***************************************************************************** SUBROUTINE reset_basis(nkind,ndof,RI_basis_parameter,reset_edge,& - pnew,lower_B,max_dev,max_rel_dev,exp_limits,error) + pnew,lower_B,max_dev,max_rel_dev,exp_limits) INTEGER :: nkind, ndof TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: RI_basis_parameter @@ -945,7 +938,6 @@ SUBROUTINE reset_basis(nkind,ndof,RI_basis_parameter,reset_edge,& max_rel_dev REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: exp_limits - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'reset_basis', & routineP = moduleN//':'//routineN @@ -992,10 +984,10 @@ SUBROUTINE reset_basis(nkind,ndof,RI_basis_parameter,reset_edge,& DO ikind=1, nkind am_max=MAXVAL(RI_basis_parameter(ikind)%lmax(:)) ALLOCATE(nf_per_l(0:am_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nf_per_l=0 ALLOCATE(max_min_exp_per_l(2,0:am_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_min_exp_per_l(1,:)=HUGE(0) max_min_exp_per_l(2,:)=-HUGE(0) @@ -1017,7 +1009,7 @@ SUBROUTINE reset_basis(nkind,ndof,RI_basis_parameter,reset_edge,& ! max_min_exp_per_l(1,0)=expo ALLOCATE(has_to_be_changed(0:am_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) has_to_be_changed=.FALSE. DO la=0, am_max pmax=-HUGE(0) @@ -1110,12 +1102,11 @@ SUBROUTINE reset_basis(nkind,ndof,RI_basis_parameter,reset_edge,& !> \param Lai ... !> \param Lai_beta ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE contract_integrals(DI,Emp2_RI,DRI,Emp2,homo,homo_beta,virtual,virtual_beta,& fact,fact2,calc_ex,& MOenerg,MOenerg_beta,abij,& - Lai,Lai_beta,para_env,error) + Lai,Lai_beta,para_env) REAL(KIND=dp) :: DI, Emp2_RI, DRI, Emp2 INTEGER :: homo, homo_beta, virtual, & virtual_beta @@ -1127,7 +1118,6 @@ SUBROUTINE contract_integrals(DI,Emp2_RI,DRI,Emp2,homo,homo_beta,virtual,virtual REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :) :: Lai, Lai_beta TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_integrals', & routineP = moduleN//':'//routineN @@ -1141,7 +1131,7 @@ SUBROUTINE contract_integrals(DI,Emp2_RI,DRI,Emp2,homo,homo_beta,virtual,virtual failure=.FALSE. ALLOCATE(mat_ab(virtual,virtual_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DI=0.0_dp Emp2_RI=0.0_dp @@ -1189,14 +1179,12 @@ SUBROUTINE contract_integrals(DI,Emp2_RI,DRI,Emp2,homo,homo_beta,virtual,virtual !> \param para_env ... !> \param elements_ij_proc ... !> \param ij_list_proc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calc_elem_ij_proc(homo,homo_beta,para_env,elements_ij_proc,ij_list_proc,error) + SUBROUTINE calc_elem_ij_proc(homo,homo_beta,para_env,elements_ij_proc,ij_list_proc) INTEGER :: homo, homo_beta TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: elements_ij_proc INTEGER, ALLOCATABLE, DIMENSION(:, :) :: ij_list_proc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_elem_ij_proc', & routineP = moduleN//':'//routineN @@ -1216,7 +1204,7 @@ SUBROUTINE calc_elem_ij_proc(homo,homo_beta,para_env,elements_ij_proc,ij_list_pr END DO ALLOCATE(ij_list_proc(elements_ij_proc,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ij_list_proc=0 ij_counter=-1 elements_ij_proc=0 @@ -1258,15 +1246,13 @@ SUBROUTINE transf_val(lower_B, max_dev, valin, valout) !> \param nkind ... !> \param max_rel_dev_output ... !> \param basis_was_assoc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_was_assoc,error) + SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_was_assoc) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mp2_type), POINTER :: mp2_env INTEGER :: nkind REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: max_rel_dev_output LOGICAL, ALLOCATABLE, DIMENSION(:) :: basis_was_assoc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'generate_RI_init_basis', & routineP = moduleN//':'//routineN @@ -1301,25 +1287,25 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ IF(ALLOCATED(mp2_env%ri_opt_param%RI_nset_per_l)) external_num_of_func=.TRUE. NULLIFY(qs_kind_set) - CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set, error=error) + CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set) nkind = SIZE(qs_kind_set,1) ALLOCATE(basis_was_assoc(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) basis_was_assoc=.FALSE. IF(external_num_of_func.AND.nkind>1) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "There are more than one kind of atom. The same pattern of functions, "//& "as specified by NUM_FUNC, will be used for all kinds.", & - error,only_ionode=.TRUE.) + only_ionode=.TRUE.) END IF DO ikind = 1, nkind NULLIFY(atom_kind) atom_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=atom_kind,basis_set=orb_basis_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=atom_kind,basis_set=orb_basis_a,basis_type="RI_AUX") ! save info if the basis was or not associated basis_was_assoc(ikind)=ASSOCIATED(orb_basis_a) @@ -1338,7 +1324,7 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ RI_max_am=max_am ALLOCATE(RI_num_sgf_per_l(0:RI_max_am),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_num_sgf_per_l=0 RI_nset=0 DO iset=1, nseta @@ -1349,13 +1335,13 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "The RI basis set optimizer can not handle contracted Gaussian. "//& "Calculation continue with only uncontracted functions.", & - error,only_ionode=.TRUE.) + only_ionode=.TRUE.) END IF END DO END DO ALLOCATE(exp_tab(MAXVAL(RI_num_sgf_per_l),0:RI_max_am),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) exp_tab=0.0_dp DO iii=0, RI_max_am iexpo=0 @@ -1371,17 +1357,17 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ ! sort exponents DO iii=0, RI_max_am ALLOCATE(ordered_pos(RI_num_sgf_per_l(iii)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ordered_pos=0 CALL sort(exp_tab(1:RI_num_sgf_per_l(iii),iii), RI_num_sgf_per_l(iii), ordered_pos) DEALLOCATE(ordered_pos) END DO ALLOCATE(RI_l_expo(RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_l_expo=0 ALLOCATE(RI_exponents(RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_exponents=0.0_dp iset=0 @@ -1396,7 +1382,7 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ ALLOCATE(max_rel_dev(RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_rel_dev=1.0_dp iset=0 DO iii=0, RI_max_am @@ -1418,11 +1404,11 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ DEALLOCATE(RI_num_sgf_per_l) ! deallocate the old basis before moving on - CALL remove_basis_from_container(qs_kind_set(ikind)%basis_sets,basis_type="RI_AUX",error=error) + CALL remove_basis_from_container(qs_kind_set(ikind)%basis_sets,basis_type="RI_AUX") ELSE - CALL get_qs_kind(qs_kind=atom_kind,basis_set=orb_basis_a,error=error) + CALL get_qs_kind(qs_kind=atom_kind,basis_set=orb_basis_a) sphi_a => orb_basis_a%sphi nseta = orb_basis_a%nset @@ -1452,13 +1438,13 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ END DO ALLOCATE(exponents(nexpo_shell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) exponents=0.0_dp ALLOCATE(l_expo(nexpo_shell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) l_expo=0 ALLOCATE(num_sgf_per_l(0:max_am),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) num_sgf_per_l=0 iexpo=0 DO iset = 1, nseta @@ -1479,13 +1465,13 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ END DO ALLOCATE(exp_tab(nexpo_shell,nexpo_shell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) exp_tab=0.0_dp ALLOCATE(l_tab(nexpo_shell,nexpo_shell),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) l_tab=0 ALLOCATE(tot_num_exp_per_l(0:max_am*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tot_num_exp_per_l=0 DO iexpo=1, nexpo_shell DO jexpo=iexpo, nexpo_shell @@ -1500,7 +1486,7 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ DEALLOCATE(exponents) ALLOCATE(max_min_exp_l(2,0:max_am*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_min_exp_l(1,:)=HUGE(0) max_min_exp_l(2,:)=-HUGE(0) @@ -1522,7 +1508,7 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ max_min_exp_l(2,:)=max_min_exp_l(2,:)/1.20_dp ALLOCATE(RI_num_sgf_per_l(0:max_am*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_num_sgf_per_l=0 SELECT CASE(basis_quality) @@ -1548,7 +1534,7 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ IF(RI_max_am>max_am*2) THEN DEALLOCATE(RI_num_sgf_per_l) ALLOCATE(RI_num_sgf_per_l(0:RI_max_am),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_num_sgf_per_l=0 END IF DO la=0, RI_max_am @@ -1597,15 +1583,15 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ RI_nset=SUM(RI_num_sgf_per_l) ALLOCATE(RI_exponents(RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_exponents=0.0_dp ALLOCATE(RI_l_expo(RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_l_expo=0 ALLOCATE(max_rel_dev(RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_rel_dev=1.0_dp iset=0 @@ -1647,27 +1633,27 @@ SUBROUTINE generate_RI_init_basis(qs_env,mp2_env,nkind,max_rel_dev_output,basis_ ! create the new basis NULLIFY(tmp_basis) - CALL create_ri_basis(tmp_basis,RI_nset,RI_l_expo,RI_exponents,error) - CALL add_basis_set_to_container(qs_kind_set(ikind)%basis_sets,tmp_basis,"RI_AUX",error=error) -!d CALL copy_gto_basis_set(tmp_basis,qs_kind_set(ikind)%ri_aux_basis_set,error) + CALL create_ri_basis(tmp_basis,RI_nset,RI_l_expo,RI_exponents) + CALL add_basis_set_to_container(qs_kind_set(ikind)%basis_sets,tmp_basis,"RI_AUX") +!d CALL copy_gto_basis_set(tmp_basis,qs_kind_set(ikind)%ri_aux_basis_set) DEALLOCATE(RI_exponents) DEALLOCATE(RI_l_expo) IF(.NOT.ALLOCATED(max_rel_dev_output)) THEN ALLOCATE(max_rel_dev_output(RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_rel_dev_output(:)=max_rel_dev ELSE ! make a copy RI_prev_size=SIZE(max_rel_dev_output) ALLOCATE(max_rel_dev_prev(RI_prev_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_rel_dev_prev(:)=max_rel_dev_output DEALLOCATE(max_rel_dev_output) ! reallocate and copy ALLOCATE(max_rel_dev_output(RI_prev_size+RI_nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_rel_dev_output(1:RI_prev_size)=max_rel_dev_prev max_rel_dev_output(RI_prev_size+1:RI_prev_size+RI_nset)=max_rel_dev DEALLOCATE(max_rel_dev_prev) @@ -1688,14 +1674,12 @@ END SUBROUTINE generate_RI_init_basis !> \param RI_nset ... !> \param RI_l_expo ... !> \param RI_exponents ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_ri_basis(gto_basis_set,RI_nset,RI_l_expo,RI_exponents,error) + SUBROUTINE create_ri_basis(gto_basis_set,RI_nset,RI_l_expo,RI_exponents) TYPE(gto_basis_set_type), POINTER :: gto_basis_set INTEGER :: RI_nset INTEGER, ALLOCATABLE, DIMENSION(:) :: RI_l_expo REAL(dp), ALLOCATABLE, DIMENSION(:) :: RI_exponents - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_ri_basis', & routineP = moduleN//':'//routineN @@ -1716,7 +1700,7 @@ SUBROUTINE create_ri_basis(gto_basis_set,RI_nset,RI_l_expo,RI_exponents,error) NULLIFY(lmax, lmin, npgf, nshell, l, n, zet, gcc) ! allocate the basis - CALL allocate_gto_basis_set(gto_basis_set,error) + CALL allocate_gto_basis_set(gto_basis_set) ! brute force nset = 0 @@ -1880,10 +1864,10 @@ SUBROUTINE create_ri_basis(gto_basis_set,RI_nset,RI_l_expo,RI_exponents,error) CALL reallocate(gto_basis_set%m,1,nsgf) CALL reallocate(gto_basis_set%norm_cgf,1,ncgf) ALLOCATE (gto_basis_set%cgf_symbol(ncgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (gto_basis_set%sgf_symbol(nsgf),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ncgf = 0 nsgf = 0 @@ -1911,7 +1895,7 @@ SUBROUTINE create_ri_basis(gto_basis_set,RI_nset,RI_l_expo,RI_exponents,error) END DO DEALLOCATE (gcc,l,lmax,lmin,n,npgf,nshell,zet,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/mp2_ri_gpw.F b/src/mp2_ri_gpw.F index 049e16b5c4..70da0b53eb 100644 --- a/src/mp2_ri_gpw.F +++ b/src/mp2_ri_gpw.F @@ -164,7 +164,6 @@ MODULE mp2_ri_gpw !> \param gw_corr_lev_virt ... !> \param rlength ... !> \param do_truncation_gw ... -!> \param error ... !> \param BIb_C_beta ... !> \param BIb_C_gw_beta ... !> \param ends_B_virtual_beta ... @@ -186,7 +185,7 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& mo_coeff_gw,eps_filter,unit_nr,& mp2_memory,calc_PQ_cond_num,calc_forces,blacs_env_sub,my_do_gw,& starts_B_all,sizes_B_all,ends_B_all,gw_corr_lev_occ,gw_corr_lev_virt,& - rlength,do_truncation_gw,error,& + rlength,do_truncation_gw,& BIb_C_beta,BIb_C_gw_beta,ends_B_virtual_beta,sizes_B_virtual_beta,starts_B_virtual_beta,& homo_beta,mo_coeff_o_beta,mo_coeff_v_beta,mo_coeff_all_beta,mo_coeff_gw_beta) REAL(KIND=dp), ALLOCATABLE, & @@ -229,7 +228,6 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& gw_corr_lev_virt REAL(KIND=dp) :: rlength LOGICAL :: do_truncation_gw - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :), OPTIONAL :: BIb_C_beta, BIb_C_gw_beta INTEGER, ALLOCATABLE, DIMENSION(:), & @@ -299,12 +297,12 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& fm_BIb_jb,"fm_BIb_jb",max_row_col_local,& nfullrows_total,nfullcols_total,nrow_local, & ncol_local,blacs_env_sub,& - para_env_sub,local_col_row_info,error) + para_env_sub,local_col_row_info) CALL create_parallelization_arrays(para_env_sub,ends_B_virtual,sizes_B_virtual,& starts_B_virtual,my_B_virtual_start,& my_B_virtual_end,my_B_size,& - virtual,error) + virtual) IF(do_alpha_beta) THEN @@ -317,12 +315,12 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& max_row_col_local_beta,& nfullrows_total,nfullcols_total,nrow_local, & ncol_local,blacs_env_sub,& - para_env_sub,local_col_row_info_beta,error) + para_env_sub,local_col_row_info_beta) CALL create_parallelization_arrays(para_env_sub,ends_B_virtual_beta,sizes_B_virtual_beta,& starts_B_virtual_beta,my_B_virtual_start_beta,& my_B_virtual_end_beta,my_B_size_beta,& - virtual_beta,error) + virtual_beta) END IF @@ -337,12 +335,12 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& max_row_col_local_gw,& nfullrows_total,nfullcols_total,nrow_local, & ncol_local,blacs_env_sub,& - para_env_sub,local_col_row_info_gw,error) + para_env_sub,local_col_row_info_gw) CALL create_parallelization_arrays(para_env_sub,ends_B_all,sizes_B_all,& starts_B_all,my_B_all_start,& my_B_all_end,my_B_all_size,& - nmo,error) + nmo) IF(do_alpha_beta) THEN ! deallocate local_col_row_info_gw, otherwise it gets twice allocated in create_intermediate_m @@ -353,7 +351,7 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& max_row_col_local_gw,& nfullrows_total,nfullcols_total,nrow_local, & ncol_local,blacs_env_sub,& - para_env_sub,local_col_row_info_gw,error) + para_env_sub,local_col_row_info_gw) ! we don"t need parallelization arrays for beta since the matrix sizes of B_nm^P is the same ! for the beta case and therefore the parallelization of beta is the same than for alpha @@ -378,7 +376,7 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& NULLIFY(psi_L%pw) CALL pw_pool_create_pw(auxbas_pw_pool,psi_L%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) ! calculate L^{-1} CALL calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& @@ -386,7 +384,7 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& mo_coeff,dft_control,psi_L,rho_r,rho_g,pot_g,pw_env_sub,poisson_env,& my_group_L_size,my_group_L_start,my_group_L_end,sab_orb_sub,& sizes_array,starts_array,ends_array,calc_PQ_cond_num,cond_num,& - num_small_eigen,auxbas_pw_pool,error) + num_small_eigen,auxbas_pw_pool) IF (unit_nr>0) WRITE (UNIT=unit_nr,FMT="(T3,A,T75,i6)")& "RI_INFO| Cholesky decomposition group size:", para_env_L%num_pe @@ -399,11 +397,10 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& ! replicate the necessary row of the L^{-1} matrix on each proc CALL grep_Lcols(para_env_L,dimen_RI,fm_matrix_L,& - my_group_L_start,my_group_L_end,my_group_L_size,my_Lrows,& - error) + my_group_L_start,my_group_L_end,my_group_L_size,my_Lrows) ! clean the L^{-1} matrix - CALL cp_fm_release(fm_matrix_L, error=error) - CALL cp_para_env_release(para_env_L,error=error) + CALL cp_fm_release(fm_matrix_L) + CALL cp_para_env_release(para_env_L) IF(calc_forces) THEN ! we need (P|Q)^(-1/2) for future use, just save it @@ -411,7 +408,7 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& itmp=get_limit(dimen_RI,para_env_sub%num_pe,para_env_sub%mepos) lll=itmp(2)-itmp(1)+1 ALLOCATE(qs_env%mp2_env%ri_grad%PQ_half(lll,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qs_env%mp2_env%ri_grad%PQ_half(:,:)=my_Lrows(itmp(1):itmp(2),1:my_group_L_size) END IF @@ -441,23 +438,23 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& ! array that will store the (ia|K) integrals ALLOCATE(BIb_C(my_group_L_size,my_B_size,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C=0.0_dp IF(do_alpha_beta) THEN ALLOCATE(BIb_C_beta(my_group_L_size,my_B_size_beta,homo_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_beta=0.0_dp END IF ! in the case of GW, we also need (nm|K) IF(my_do_gw) THEN ALLOCATE(BIb_C_gw(my_group_L_size,my_B_all_size,gw_corr_lev_total),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_gw=0.0_dp IF(do_alpha_beta) THEN ALLOCATE(BIb_C_gw_beta(my_group_L_size,my_B_all_size,gw_corr_lev_total),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_gw_beta=0.0_dp END IF END IF @@ -474,60 +471,57 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& CALL calculate_wavefunction(mo_coeff,1,psi_L,rho_g, atomic_kind_set, & qs_kind_set,cell,dft_control,particle_set, pw_env_sub,& basis_type="RI_AUX",& - external_vector=my_Lrows(:,LLL-my_group_L_start+1),& - error=error) + external_vector=my_Lrows(:,LLL-my_group_L_start+1)) CALL timeset(routineN//"_pot",handle3) rho_r%pw%cr3d = psi_L%pw%cr3d - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) CALL timestop(handle3) ! and finally (K|mu nu) CALL timeset(routineN//"_int",handle3) - CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp) CALL integrate_v_rspace(rho_r,hmat=mat_munu,qs_env=qs_env,calculate_forces=.FALSE.,compute_tau=.FALSE.,gapw=.FALSE.,& - pw_env_external=pw_env_sub, task_list_external=task_list_sub, error=error) + pw_env_external=pw_env_sub, task_list_external=task_list_sub) CALL timestop(handle3) ! multiply and goooooooo ... CALL timeset(routineN//"_mult_o",handle3) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_o, & - 0.0_dp, matrix_ia_jnu, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jnu, filter_eps=eps_filter) IF(do_alpha_beta) THEN ! transform orbitals using the beta coeff matrix CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_o_beta, & - 0.0_dp, matrix_ia_jnu_beta, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jnu_beta, filter_eps=eps_filter) END IF CALL timestop(handle3) CALL timeset(routineN//"_mult_v",handle3) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, matrix_ia_jnu, mo_coeff_v, & - 0.0_dp, matrix_ia_jb, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jb, filter_eps=eps_filter) IF(do_alpha_beta) THEN ! transform orbitals using the beta coeff matrix CALL cp_dbcsr_multiply("T", "N", 1.0_dp, matrix_ia_jnu_beta, mo_coeff_v_beta, & - 0.0_dp, matrix_ia_jb_beta, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_ia_jb_beta, filter_eps=eps_filter) END IF CALL timestop(handle3) ! now fill the matrix CALL timeset(routineN//"_E_Ex_1",handle3) - CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb, error=error) + CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb) CALL grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_C(i_counter,1:my_B_size,1:homo),max_row_col_local,& sub_proc_map,local_col_row_info,& - my_B_virtual_end,my_B_virtual_start,& - error) + my_B_virtual_end,my_B_virtual_start) IF(do_alpha_beta) THEN - CALL copy_dbcsr_to_fm(matrix_ia_jb_beta, fm_BIb_jb_beta, error=error) + CALL copy_dbcsr_to_fm(matrix_ia_jb_beta, fm_BIb_jb_beta) CALL grep_my_integrals(para_env_sub,fm_BIb_jb_beta,& BIb_C_beta(i_counter,1:my_B_size_beta,1:homo_beta),max_row_col_local_beta,& sub_proc_map,local_col_row_info_beta,& - my_B_virtual_end_beta,my_B_virtual_start_beta,& - error) + my_B_virtual_end_beta,my_B_virtual_start_beta) END IF CALL timestop(handle3) @@ -537,38 +531,36 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& ! transform (K|mu nu) to (K|nm), n corresponds to corrected GW levels, m is in nmo CALL timeset(routineN//"_mult_gw",handle3) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_gw, & - 0.0_dp, matrix_in_jnu, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_in_jnu, filter_eps=eps_filter) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, matrix_in_jnu, mo_coeff_all, & - 0.0_dp,matrix_in_jm,filter_eps=eps_filter, error=error) + 0.0_dp,matrix_in_jm,filter_eps=eps_filter) CALL timestop(handle3) CALL timeset(routineN//"_E_Ex_2_gw",handle3) - CALL copy_dbcsr_to_fm(matrix_in_jm, fm_BIb_gw, error=error) + CALL copy_dbcsr_to_fm(matrix_in_jm, fm_BIb_gw) CALL grep_my_integrals(para_env_sub,fm_BIb_gw,BIb_C_gw(i_counter,1:my_B_all_size,1:gw_corr_lev_total),& max_row_col_local_gw,& sub_proc_map,local_col_row_info_gw,& - my_B_all_end,my_B_all_start,& - error) + my_B_all_end,my_B_all_start) ! the same for beta IF(do_alpha_beta) THEN CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_gw_beta, & - 0.0_dp, matrix_in_jnu_beta, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_in_jnu_beta, filter_eps=eps_filter) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, matrix_in_jnu_beta, mo_coeff_all_beta, & - 0.0_dp,matrix_in_jm_beta,filter_eps=eps_filter, error=error) + 0.0_dp,matrix_in_jm_beta,filter_eps=eps_filter) CALL timestop(handle3) CALL timeset(routineN//"_E_Ex_2_gw",handle3) - CALL copy_dbcsr_to_fm(matrix_in_jm_beta, fm_BIb_gw_beta, error=error) + CALL copy_dbcsr_to_fm(matrix_in_jm_beta, fm_BIb_gw_beta) CALL grep_my_integrals(para_env_sub,fm_BIb_gw_beta,BIb_C_gw_beta(i_counter,1:my_B_all_size,1:gw_corr_lev_total),& max_row_col_local_gw,& sub_proc_map,local_col_row_info_gw,& - my_B_all_end,my_B_all_start,& - error) + my_B_all_end,my_B_all_start) END IF CALL timestop(handle3) @@ -604,45 +596,43 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& CALL calculate_wavefunction(mo_coeff,1,psi_L,rho_g, atomic_kind_set, & qs_kind_set,cell,dft_control,particle_set, pw_env_sub,& basis_type="RI_AUX",& - external_vector=my_Lrows(:,LLL-my_group_L_start+1),& - error=error) + external_vector=my_Lrows(:,LLL-my_group_L_start+1)) ALLOCATE(BIb_C_gw_trunc(my_group_L_size,my_B_all_size,gw_corr_lev_total),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_gw_trunc=0.0_dp CALL timeset(routineN//"_pot_trunc",handle3) rho_r%pw%cr3d = psi_L%pw%cr3d - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) CALL timestop(handle3) ! and finally (K|mu nu) CALL timeset(routineN//"_int_trunc",handle3) - CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp) CALL integrate_v_rspace(rho_r,hmat=mat_munu,qs_env=qs_env,calculate_forces=.FALSE.,compute_tau=.FALSE.,gapw=.FALSE.,& - pw_env_external=pw_env_sub, task_list_external=task_list_sub, error=error) + pw_env_external=pw_env_sub, task_list_external=task_list_sub) CALL timestop(handle3) CALL timeset(routineN//"_mult_gw_trunc",handle3) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_gw, & - 0.0_dp, matrix_in_jnu, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_in_jnu, filter_eps=eps_filter) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, matrix_in_jnu, mo_coeff_all, & - 0.0_dp,matrix_in_jm,filter_eps=eps_filter, error=error) + 0.0_dp,matrix_in_jm,filter_eps=eps_filter) CALL timestop(handle3) CALL timeset(routineN//"_E_Ex_2_trunc",handle3) - CALL copy_dbcsr_to_fm(matrix_in_jm, fm_BIb_gw, error=error) + CALL copy_dbcsr_to_fm(matrix_in_jm, fm_BIb_gw) CALL grep_my_integrals(para_env_sub,fm_BIb_gw,BIb_C_gw_trunc(i_counter,1:my_B_all_size,1:gw_corr_lev_total),& max_row_col_local_gw,& sub_proc_map,local_col_row_info_gw,& - my_B_all_end,my_B_all_start,& - error) + my_B_all_end,my_B_all_start) DO iiB=1,my_B_all_size DO jjB=1,gw_corr_lev_total @@ -669,31 +659,31 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C,BIb_C_gw,ends_array,ends_B_virtual,& DEALLOCATE(my_Lrows) - CALL cp_fm_release(fm_BIb_jb, error=error) + CALL cp_fm_release(fm_BIb_jb) DEALLOCATE(local_col_row_info) - CALL cp_dbcsr_release(matrix_ia_jnu,error=error) - CALL cp_dbcsr_release(matrix_ia_jb,error=error) + CALL cp_dbcsr_release(matrix_ia_jnu) + CALL cp_dbcsr_release(matrix_ia_jb) IF(do_alpha_beta) THEN - CALL cp_dbcsr_release(matrix_ia_jnu_beta,error=error) - CALL cp_dbcsr_release(matrix_ia_jb_beta,error=error) - CALL cp_fm_release(fm_BIb_jb_beta, error=error) + CALL cp_dbcsr_release(matrix_ia_jnu_beta) + CALL cp_dbcsr_release(matrix_ia_jb_beta) + CALL cp_fm_release(fm_BIb_jb_beta) DEALLOCATE(local_col_row_info_beta) END IF IF(my_do_gw) THEN - CALL cp_dbcsr_release(matrix_in_jnu,error=error) - CALL cp_dbcsr_release(matrix_in_jm,error=error) - CALL cp_fm_release(fm_BIb_gw, error=error) + CALL cp_dbcsr_release(matrix_in_jnu) + CALL cp_dbcsr_release(matrix_in_jm) + CALL cp_fm_release(fm_BIb_gw) DEALLOCATE(local_col_row_info_gw) IF(do_alpha_beta) THEN - CALL cp_dbcsr_release(matrix_in_jnu_beta,error=error) - CALL cp_dbcsr_release(matrix_in_jm_beta,error=error) - CALL cp_fm_release(fm_BIb_gw_beta, error=error) + CALL cp_dbcsr_release(matrix_in_jnu_beta) + CALL cp_dbcsr_release(matrix_in_jm_beta) + CALL cp_fm_release(fm_BIb_gw_beta) END IF END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_L%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_L%pw) DEALLOCATE(sub_proc_map) @@ -721,14 +711,13 @@ END SUBROUTINE mp2_ri_gpw_compute_in !> \param blacs_env_sub ... !> \param para_env_sub ... !> \param local_col_row_info ... -!> \param error ... !> \author Jan Wilhelm ! ***************************************************************************** SUBROUTINE create_intermediate_matrices(matrix_ia_jnu,matrix_ia_jb,mo_coeff_templ,size_1,size_2,& fm_BIb_jb,matrix_name_2,max_row_col_local,& nfullrows_total,nfullcols_total,nrow_local, & ncol_local,blacs_env_sub,& - para_env_sub,local_col_row_info,error) + para_env_sub,local_col_row_info) TYPE(cp_dbcsr_type) :: matrix_ia_jnu, matrix_ia_jb, & mo_coeff_templ @@ -742,7 +731,6 @@ SUBROUTINE create_intermediate_matrices(matrix_ia_jnu,matrix_ia_jb,mo_coeff_temp TYPE(cp_blacs_env_type), POINTER :: blacs_env_sub TYPE(cp_para_env_type), POINTER :: para_env_sub INTEGER, ALLOCATABLE, DIMENSION(:, :) :: local_col_row_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_intermediate_matrices', & routineP = moduleN//':'//routineN @@ -756,41 +744,40 @@ SUBROUTINE create_intermediate_matrices(matrix_ia_jnu,matrix_ia_jb,mo_coeff_temp failure=.FALSE. ! initialize and create the matrix (K|jnu) - CALL cp_dbcsr_init(matrix_ia_jnu,error=error) - CALL cp_dbcsr_create(matrix_ia_jnu,template=mo_coeff_templ,error=error) + CALL cp_dbcsr_init(matrix_ia_jnu) + CALL cp_dbcsr_create(matrix_ia_jnu,template=mo_coeff_templ) ! Allocate Sparse matrices: (K|jb) - CALL cp_dbcsr_init(matrix_ia_jb,error=error) + CALL cp_dbcsr_init(matrix_ia_jb) CALL cp_dbcsr_m_by_n_from_template(matrix_ia_jb,template=mo_coeff_templ,m=size_2,n=size_1,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ! set all to zero in such a way that the memory is actually allocated - CALL cp_dbcsr_set(matrix_ia_jnu,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_ia_jb,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_ia_jnu,0.0_dp) + CALL cp_dbcsr_set(matrix_ia_jb,0.0_dp) ! create the analogous of matrix_ia_jb in fm type NULLIFY(fm_BIb_jb) NULLIFY(fm_struct) CALL cp_dbcsr_get_info(matrix_ia_jb,nfullrows_total=nfullrows_total,nfullcols_total=nfullcols_total) CALL cp_fm_struct_create(fm_struct,context=blacs_env_sub,nrow_global=nfullrows_total,& - ncol_global=nfullcols_total,para_env=para_env_sub,error=error) - CALL cp_fm_create(fm_BIb_jb,fm_struct,name=matrix_name_2,error=error) + ncol_global=nfullcols_total,para_env=para_env_sub) + CALL cp_fm_create(fm_BIb_jb,fm_struct,name=matrix_name_2) - CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb, error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + CALL copy_dbcsr_to_fm(matrix_ia_jb, fm_BIb_jb) + CALL cp_fm_struct_release(fm_struct) CALL cp_fm_get_info(matrix=fm_BIb_jb,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) max_row_col_local=MAX(nrow_local,ncol_local) CALL mp_max(max_row_col_local,para_env_sub%group) ALLOCATE(local_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_col_row_info=0 ! 0,1 nrows local_col_row_info(0,1)=nrow_local @@ -815,17 +802,15 @@ END SUBROUTINE create_intermediate_matrices !> \param my_B_end ... !> \param my_B_size ... !> \param size_1 ... -!> \param error ... !> \author Jan Wilhelm ! ***************************************************************************** SUBROUTINE create_parallelization_arrays(para_env_sub,ends_B,sizes_B,starts_B,& - my_B_start,my_B_end,my_B_size,size_1,error) + my_B_start,my_B_end,my_B_size,size_1) TYPE(cp_para_env_type), POINTER :: para_env_sub INTEGER, ALLOCATABLE, DIMENSION(:) :: ends_B, sizes_B, starts_B INTEGER :: my_B_start, my_B_end, & my_B_size, size_1 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'create_parallelization_arrays', & @@ -840,13 +825,13 @@ SUBROUTINE create_parallelization_arrays(para_env_sub,ends_B,sizes_B,starts_B,& ! divide the b states in the sub_group in such a way to create ! b_start and b_end for each proc inside the sub_group ALLOCATE(sizes_B(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_B=0 ALLOCATE(starts_B(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts_B=0 ALLOCATE(ends_B(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends_B=0 DO iproc=0, para_env_sub%num_pe-1 @@ -899,14 +884,13 @@ END SUBROUTINE create_parallelization_arrays !> \param cond_num ... !> \param num_small_eigen ... !> \param auxbas_pw_pool ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& fm_matrix_L,ngroup,color_sub,dimen_RI,& mo_coeff,dft_control,psi_L,rho_r,rho_g,pot_g,pw_env_sub,poisson_env,& my_group_L_size,my_group_L_start,my_group_L_end,sab_orb_sub,& sizes_array,starts_array,ends_array,calc_PQ_cond_num,cond_num,& - num_small_eigen,auxbas_pw_pool,error) + num_small_eigen,auxbas_pw_pool) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env, para_env_sub, & para_env_L @@ -929,7 +913,6 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& REAL(KIND=dp) :: cond_num INTEGER :: num_small_eigen TYPE(pw_pool_type), POINTER :: auxbas_pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_Lmin1', & routineP = moduleN//':'//routineN @@ -1008,7 +991,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! get stuff CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set,& cell=cell, molecule_set=molecule_set,particle_set=particle_set,& - molecule_kind_set=molecule_kind_set,error=error) + molecule_kind_set=molecule_kind_set) ! blacs_env => qs_env%blacs_env @@ -1016,31 +999,31 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& natom = SIZE(particle_set) ALLOCATE (kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,kind_of=kind_of) DO ikind=1, nkind - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) - CPPrecondition(ASSOCIATED(basis_set_a),cp_failure_level,routineP,error,failure) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") + CPPrecondition(ASSOCIATED(basis_set_a),cp_failure_level,routineP,failure) END DO dimen_RI=0 DO iatom=1, natom ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),nsgf=nsgf,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),nsgf=nsgf,basis_type="RI_AUX") dimen_RI=dimen_RI+nsgf END DO ! calculate wich rows of L^{-1} to have ALLOCATE(sizes_array(0:ngroup-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_array=0 ALLOCATE(starts_array(0:ngroup-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts_array=0 ALLOCATE(ends_array(0:ngroup-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends_array=0 DO igroup=0,ngroup-1 @@ -1063,15 +1046,15 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! write arrays with number(=label) of every basis function, its quantum number (l,m) ! and the reference to the first basis function with (l,m) ALLOCATE(ref_matrix(dimen_RI,10),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! naolimits(iatom,iset,1/2)=begin/end reference entries in L_local_q ALLOCATE(naolimits(natom,100,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! array with reference (atom,set) for arbitrary (atom,set); ALLOCATE(ref_at_se_sgf_ofs(natom,100,4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) i_counter=0 @@ -1085,7 +1068,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& DO iatom=1, natom ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") la_max => basis_set_a%lmax la_min => basis_set_a%lmin @@ -1205,23 +1188,23 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! array with number of q_a basis function at an atom ALLOCATE(diffbf_noinbas(i_counter_diff_bf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! array with number of a basis function with first unique (l,m) combination ALLOCATE(diffbfatanyatom_noinbas(i_counter_diff_bf_at_any_atom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! array with number of q_a (at arbitrary atom) with q_a at specific atom ALLOCATE(diffbf_atom_arbitr_atom(i_counter_diff_bf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! array with atom and set number for every q_a bf ALLOCATE(atom_set_afo_diffbf(i_counter_diff_bf,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! array with atom and set number for every q_a bf ALLOCATE(atom_set_afo_diffbf_atanyatom(i_counter_diff_bf,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) j=1 DO i=1,dimen_RI @@ -1246,7 +1229,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! array with number of first set with quantum number l ALLOCATE(diffsets_atom_set_bf(i_counter_diff_sets,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! first set with new quantum number l is on atom 1, set 1 diffsets_atom_set_bf(1,1)=1 @@ -1309,7 +1292,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& PRINT *, 'naolimits' DO iatom=1,natom ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") nseta = basis_set_a%nset DO iset=1, nseta @@ -1320,7 +1303,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& PRINT *, 'ref_at_se_sgf_ofs' DO iatom=1,natom ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") nseta = basis_set_a%nset DO iset=1, nseta @@ -1345,7 +1328,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& my_group_L_q_end = naolimits(ref_matrix(my_group_L_end,3)+1,1,1)-1 ELSE nkind=kind_of(natom) - CALL get_qs_kind(qs_kind=qs_kind_set(nkind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(nkind),basis_set=basis_set_a,basis_type="RI_AUX") nseta = basis_set_a%nset my_group_L_q_end = naolimits(ref_matrix(my_group_L_end,3),nseta,2) END IF @@ -1353,13 +1336,13 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! calculate which potentials to calculate ALLOCATE(sizes_array_pot(0:ngroup-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_array_pot=0 ALLOCATE(starts_array_pot(0:ngroup-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts_array_pot=0 ALLOCATE(ends_array_pot(0:ngroup-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends_array_pot=0 DO igroup=0,ngroup-1 @@ -1381,10 +1364,10 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& exp_q = 0.5_dp ALLOCATE(rho_r_array(i_counter_diff_bf_at_any_atom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wf_vector(dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=my_group_pot_start,my_group_pot_end @@ -1398,7 +1381,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& jatom = atom_set_afo_diffbf_atanyatom(j,1) jset = atom_set_afo_diffbf_atanyatom(j,2) jkind = kind_of(jatom) - CALL get_qs_kind(qs_kind=qs_kind_set(jkind),basis_set=basis_set_b,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(jkind),basis_set=basis_set_b,basis_type="RI_AUX") zetb => basis_set_b%zet lb_max => basis_set_b%lmax @@ -1409,17 +1392,16 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& CALL calculate_wavefunction(mo_coeff,1,psi_L,rho_g, atomic_kind_set,& qs_kind_set,cell,dft_control,particle_set, pw_env_sub,& basis_type="RI_AUX",& - external_vector=wf_vector,& - error=error) + external_vector=wf_vector) ! set back the exponent zetb(1,jset) = zet_tmp rho_r%pw%cr3d = psi_L%pw%cr3d - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) ! Writing array of potential copied from xc/xc_rho_set_types.F @@ -1428,9 +1410,8 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& rho_r_array(j)%pw => rho_r%pw CALL pw_pool_create_pw(auxbas_pw_pool,rho_r_array(j)%pw,& - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) - CALL pw_copy(rho_r%pw,rho_r_array(j)%pw,error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy(rho_r%pw,rho_r_array(j)%pw) END DO @@ -1443,14 +1424,13 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& CALL calculate_wavefunction(mo_coeff,1,psi_L,rho_g, atomic_kind_set,& qs_kind_set,cell,dft_control,particle_set,pw_env_sub,& basis_type="RI_AUX",& - external_vector=wf_vector,& - error=error) + external_vector=wf_vector) rho_r%pw%cr3d = psi_L%pw%cr3d - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) END IF @@ -1465,9 +1445,8 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& rho_r_array(j)%pw => rho_r%pw CALL pw_pool_create_pw(auxbas_pw_pool,rho_r_array(j)%pw,& - use_data=REALDATA3D, in_space=REALSPACE,& - error=error) - CALL pw_copy(rho_r%pw,rho_r_array(j)%pw,error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy(rho_r%pw,rho_r_array(j)%pw) END IF END DO @@ -1475,17 +1454,17 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& color_exc=para_env_sub%mepos CALL mp_comm_split_direct(para_env%group,comm_exc,color_exc) NULLIFY(para_env_exc) - CALL cp_para_env_create(para_env_exc,comm_exc,error=error) + CALL cp_para_env_create(para_env_exc,comm_exc) ! collect all calculated potentials DO j=1,i_counter_diff_bf_at_any_atom CALL mp_sum(rho_r_array(j)%pw%cr3d,para_env_exc%group) END DO - CALL cp_para_env_release(para_env_exc,error=error) + CALL cp_para_env_release(para_env_exc) ALLOCATE(L_local_col_q(i_counter_diff_bf,my_group_L_q_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) L_local_col_q=0.0_dp @@ -1506,19 +1485,19 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& j_ref_set = atom_set_afo_diffbf_atanyatom(j_ref_bf,2) j_ref_kind = kind_of(j_ref_atom) - CALL get_qs_kind(qs_kind=qs_kind_set(j_ref_kind),basis_set=basis_set_b,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(j_ref_kind),basis_set=basis_set_b,basis_type="RI_AUX") zetb => basis_set_b%zet lb_max => basis_set_b%lmax NULLIFY(rs_v) NULLIFY(rs_descs) - CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v, error=error) + CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v) DO i=1,SIZE(rs_v) ! allocation - CALL rs_grid_retain(rs_v(i)%rs_grid,error=error) + CALL rs_grid_retain(rs_v(i)%rs_grid) END DO - CALL potential_pw2rs(rs_v,rho_r_array(j_ref_bf),pw_env_sub,error) + CALL potential_pw2rs(rs_v,rho_r_array(j_ref_bf),pw_env_sub) ! integrate the little bastards offset=0 @@ -1528,7 +1507,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& iset = diffsets_atom_set_bf(i,2) ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") first_sgfa => basis_set_a%first_sgf la_max => basis_set_a%lmax @@ -1601,8 +1580,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& o2=0,& map_consistent=.TRUE.,& eps_gvg_rspace=dft_control%qs_control%eps_gvg_rspace,& - calculate_forces=.FALSE.,& - error=error) + calculate_forces=.FALSE.) END DO CALL dgemm("T","N",nsgfa(iset),1,ncoa,& @@ -1625,7 +1603,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! deallocation DO i=1,SIZE(rs_v) - CALL rs_grid_release(rs_v(i)%rs_grid, error=error) + CALL rs_grid_release(rs_v(i)%rs_grid) END DO END DO !(q_alpha| loop @@ -1633,7 +1611,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! post cleanup DO j=1,i_counter_diff_bf_at_any_atom CALL pw_pool_give_back_pw(auxbas_pw_pool, rho_r_array(j)%pw,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) END DO DEALLOCATE(rho_r_array) @@ -1645,12 +1623,12 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! 3) Distribute (q_alpha|q_beta)_p to L_local_col ALLOCATE(L_local_col(dimen_RI,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) L_local_col=0.0_dp DO iatom=1, natom ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") first_sgfa => basis_set_a%first_sgf la_max => basis_set_a%lmax la_min => basis_set_a%lmin @@ -1668,7 +1646,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& DO jatom=1, natom jkind=kind_of(jatom) - CALL get_qs_kind(qs_kind=qs_kind_set(jkind),basis_set=basis_set_b,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(jkind),basis_set=basis_set_b,basis_type="RI_AUX") first_sgfb => basis_set_b%first_sgf lb_max => basis_set_b%lmax lb_min => basis_set_b%lmin @@ -1743,7 +1721,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& iatom=iatom,jatom=jatom,r=rac) ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") first_sgfa => basis_set_a%first_sgf la_max => basis_set_a%lmax la_min => basis_set_a%lmin @@ -1758,7 +1736,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& DO iset=1, nseta jkind=kind_of(jatom) - CALL get_qs_kind(qs_kind=qs_kind_set(jkind),basis_set=basis_set_b,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(jkind),basis_set=basis_set_b,basis_type="RI_AUX") first_sgfb => basis_set_b%first_sgf lb_max => basis_set_b%lmax lb_min => basis_set_b%lmin @@ -1790,14 +1768,14 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ALLOCATE(I_tmp(ncoa_a,nsgfb(jset)),STAT=istat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(I_tmp2(nsgfa(iset),nsgfb(jset)),STAT=istat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(f(0:la_max(iset)+lb_max(jset)+2),& v(ncoa_a,ncoa_b,la_max(iset)+lb_max(jset)+1),& vac(ncoa_a,ncoa_b),STAT=istat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) f=0.0_dp v=0.0_dp vac=0.0_dp @@ -1898,11 +1876,11 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! old algorithm ALLOCATE(L_local_col(dimen_RI,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) L_local_col=0.0_dp ALLOCATE(wf_vector(dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) i_counter=0 DO LLL=my_group_L_start, my_group_L_end @@ -1915,23 +1893,22 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& CALL calculate_wavefunction(mo_coeff,1,psi_L,rho_g, atomic_kind_set,& qs_kind_set,cell,dft_control,particle_set,pw_env_sub,& basis_type="RI_AUX",& - external_vector=wf_vector,& - error=error) + external_vector=wf_vector) CALL timeset(routineN//"_pot_lm",handle3) rho_r%pw%cr3d = psi_L%pw%cr3d - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) NULLIFY(rs_v) NULLIFY(rs_descs) - CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v, error=error) + CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v) DO i=1,SIZE(rs_v) - CALL rs_grid_retain(rs_v(i)%rs_grid,error=error) + CALL rs_grid_retain(rs_v(i)%rs_grid) END DO - CALL potential_pw2rs(rs_v,rho_r,pw_env_sub,error) + CALL potential_pw2rs(rs_v,rho_r,pw_env_sub) CALL timestop(handle3) @@ -1939,7 +1916,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& offset=0 DO iatom=1, natom ikind=kind_of(iatom) - CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX",error=error) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,basis_type="RI_AUX") first_sgfa => basis_set_a%first_sgf la_max => basis_set_a%lmax @@ -2014,8 +1991,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& o2=0,& map_consistent=.TRUE.,& eps_gvg_rspace=dft_control%qs_control%eps_gvg_rspace,& - calculate_forces=.FALSE.,& - error=error) + calculate_forces=.FALSE.) END DO CALL dgemm("T","N",nsgfa(iset),1,ncoa,& @@ -2033,7 +2009,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& END DO DO i=1,SIZE(rs_v) - CALL rs_grid_release(rs_v(i)%rs_grid, error=error) + CALL rs_grid_release(rs_v(i)%rs_grid) END DO END DO @@ -2072,18 +2048,18 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& color_L=para_env%mepos/best_group_size CALL mp_comm_split_direct(para_env%group,comm_L,color_L) NULLIFY(para_env_L) - CALL cp_para_env_create(para_env_L,comm_L,error=error) + CALL cp_para_env_create(para_env_L,comm_L) ! create the blacs_L NULLIFY(blacs_env_L) - CALL cp_blacs_env_create(blacs_env=blacs_env_L, para_env=para_env_L, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env_L, para_env=para_env_L) ! now create the exchange group (for communication only between members not belonging to the ! same group sub_sub_color=para_env_sub%mepos CALL mp_comm_split_direct(para_env_L%group,comm_exchange,sub_sub_color) NULLIFY(para_env_exchange) - CALL cp_para_env_create(para_env_exchange,comm_exchange,error=error) + CALL cp_para_env_create(para_env_exchange,comm_exchange) ! crate the proc maps ALLOCATE(proc_map(-para_env_exchange%num_pe:2*para_env_exchange%num_pe-1)) @@ -2095,13 +2071,13 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! create the information array ALLOCATE(sub_sizes_array(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sub_sizes_array=0 ALLOCATE(sub_starts_array(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sub_starts_array=0 ALLOCATE(sub_ends_array(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sub_ends_array=0 sub_sizes_array(para_env_exchange%mepos)=my_group_L_size @@ -2116,18 +2092,17 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& NULLIFY(fm_matrix_L) NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env_L,nrow_global=dimen_RI,& - ncol_global=dimen_RI,para_env=para_env_L,error=error) - CALL cp_fm_create(fm_matrix_L,fm_struct,name="fm_matrix_L",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=dimen_RI,para_env=para_env_L) + CALL cp_fm_create(fm_matrix_L,fm_struct,name="fm_matrix_L") + CALL cp_fm_struct_release(fm_struct) - CALL cp_fm_set_all(matrix=fm_matrix_L,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_matrix_L,alpha=0.0_dp) CALL cp_fm_get_info(matrix=fm_matrix_L,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) @@ -2167,7 +2142,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& DEALLOCATE(L_local_col) ALLOCATE(L_local_col(dimen_RI,rec_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) L_local_col(:,:)=L_external_col DEALLOCATE(L_external_col) @@ -2178,7 +2153,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& ! free the old exchange group stuff DEALLOCATE(proc_map) - CALL cp_para_env_release(para_env_exchange,error=error) + CALL cp_para_env_release(para_env_exchange) DEALLOCATE(sub_sizes_array) DEALLOCATE(sub_starts_array) @@ -2188,11 +2163,11 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& sub_sub_color=para_env_L%mepos CALL mp_comm_split_direct(para_env%group,comm_exchange,sub_sub_color) NULLIFY(para_env_exchange) - CALL cp_para_env_create(para_env_exchange,comm_exchange,error=error) + CALL cp_para_env_create(para_env_exchange,comm_exchange) CALL mp_sum(fm_matrix_L%local_data,para_env_exchange%group) - CALL cp_para_env_release(para_env_exchange,error=error) + CALL cp_para_env_release(para_env_exchange) cond_num=1.0_dp num_small_eigen=0 @@ -2202,19 +2177,19 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& NULLIFY(fm_matrix_L_diag) NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env_L,nrow_global=dimen_RI,& - ncol_global=dimen_RI,para_env=para_env_L,error=error) - CALL cp_fm_create(fm_matrix_L_diag,fm_struct,name="fm_matrix_L_diag",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ncol_global=dimen_RI,para_env=para_env_L) + CALL cp_fm_create(fm_matrix_L_diag,fm_struct,name="fm_matrix_L_diag") + CALL cp_fm_struct_release(fm_struct) - CALL cp_fm_set_all(matrix=fm_matrix_L_diag,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_matrix_L_diag,alpha=0.0_dp) - CALL cp_fm_to_fm(source=fm_matrix_L,destination=fm_matrix_L_diag,error=error) + CALL cp_fm_to_fm(source=fm_matrix_L,destination=fm_matrix_L_diag) ALLOCATE(egen_L(dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) egen_L=0.0_dp - CALL cp_fm_syevx(matrix=fm_matrix_L_diag,eigenvalues=egen_L,error=error) + CALL cp_fm_syevx(matrix=fm_matrix_L_diag,eigenvalues=egen_L) num_small_eigen=0 DO iiB=1, dimen_RI @@ -2223,24 +2198,23 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& cond_num=MAXVAL(ABS(egen_L))/MINVAL(ABS(egen_L)) - CALL cp_fm_release(fm_matrix_L_diag, error=error) + CALL cp_fm_release(fm_matrix_L_diag) DEALLOCATE(egen_L) END IF ! do cholesky decomposition - CALL cp_fm_cholesky_decompose(matrix=fm_matrix_L, n=dimen_RI, info_out=info_chol, error=error) - CPPostcondition(info_chol==0,cp_failure_level,routineP,error,failure) + CALL cp_fm_cholesky_decompose(matrix=fm_matrix_L, n=dimen_RI, info_out=info_chol) + CPPostcondition(info_chol==0,cp_failure_level,routineP,failure) - CALL cp_fm_triangular_invert(matrix_a=fm_matrix_L,uplo_tr='U',error=error) + CALL cp_fm_triangular_invert(matrix_a=fm_matrix_L,uplo_tr='U') ! clean the lower part of the L^{-1} matrix (just to not have surprises afterwards) CALL cp_fm_get_info(matrix=fm_matrix_L,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO iiB=1, nrow_local i_global=row_indices(iiB) DO jjB=1, ncol_local @@ -2250,7 +2224,7 @@ SUBROUTINE calculate_Lmin1(qs_env,para_env,para_env_sub,para_env_L,mp2_memory,& END DO ! release blacs_env - CALL cp_blacs_env_release(blacs_env_L,error=error) + CALL cp_blacs_env_release(blacs_env_L) CALL timestop(handle) @@ -2265,11 +2239,9 @@ END SUBROUTINE calculate_Lmin1 !> \param my_group_L_end ... !> \param my_group_L_size ... !> \param my_Lrows ... -!> \param error ... ! ***************************************************************************** SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& - my_group_L_start,my_group_L_end,my_group_L_size,my_Lrows,& - error) + my_group_L_start,my_group_L_end,my_group_L_size,my_Lrows) TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: dimen_RI TYPE(cp_fm_type), POINTER :: fm_matrix_L @@ -2278,7 +2250,6 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& my_group_L_size REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: my_Lrows - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'grep_Lcols', & routineP = moduleN//':'//routineN @@ -2299,7 +2270,7 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& CALL timeset(routineN,handle) ALLOCATE(my_Lrows(dimen_RI,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_Lrows=0.0_dp ! proc_map, vector that replicate the processor numbers also @@ -2307,7 +2278,7 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& ! needed to know which is the processor, to respect to another one, ! for a given shift ALLOCATE(proc_map(-para_env%num_pe:2*para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=0,para_env%num_pe-1 proc_map(iiB)=iiB proc_map(-iiB-1)=para_env%num_pe-iiB-1 @@ -2319,18 +2290,17 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& ncol_local=ncol_local,& row_indices=row_indices,& col_indices=col_indices,& - local_data=local_L_internal,& - error=error) + local_data=local_L_internal) ALLOCATE(local_L(nrow_local,ncol_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_L=local_L_internal(1:nrow_local,1:ncol_local) max_row_col_local=MAX(nrow_local,ncol_local) CALL mp_max(max_row_col_local,para_env%group) ALLOCATE(local_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_col_row_info=0 ! 0,1 nrows local_col_row_info(0,1)=nrow_local @@ -2340,7 +2310,7 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& local_col_row_info(1:ncol_local,2)=col_indices(1:ncol_local) ALLOCATE(rec_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! accumulate data on my_Lrows starting from myself DO jjB=1, ncol_local @@ -2369,15 +2339,15 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& ncol_rec=rec_col_row_info(0,2) ALLOCATE(row_indices_rec(nrow_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices_rec=rec_col_row_info(1:nrow_rec,1) ALLOCATE(col_indices_rec(ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices_rec=rec_col_row_info(1:ncol_rec,2) ALLOCATE(rec_L(nrow_rec,ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_L=0.0_dp ! then send and receive the real data @@ -2397,7 +2367,7 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& local_col_row_info(:,:)=rec_col_row_info DEALLOCATE(local_L) ALLOCATE(local_L(nrow_rec,ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_L=rec_L DEALLOCATE(col_indices_rec) @@ -2425,12 +2395,10 @@ SUBROUTINE grep_Lcols(para_env,dimen_RI,fm_matrix_L,& !> \param local_col_row_info ... !> \param my_B_virtual_end ... !> \param my_B_virtual_start ... -!> \param error ... ! ***************************************************************************** SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& proc_map,local_col_row_info,& - my_B_virtual_end,my_B_virtual_start,& - error) + my_B_virtual_end,my_B_virtual_start) TYPE(cp_para_env_type), POINTER :: para_env_sub TYPE(cp_fm_type), POINTER :: fm_BIb_jb REAL(KIND=dp), DIMENSION(:, :) :: BIb_jb @@ -2439,7 +2407,6 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& INTEGER, ALLOCATABLE, DIMENSION(:, :) :: local_col_row_info INTEGER :: my_B_virtual_end, & my_B_virtual_start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'grep_my_integrals', & routineP = moduleN//':'//routineN @@ -2457,7 +2424,7 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& failure=.FALSE. ALLOCATE(rec_col_row_info(0:max_row_col_local,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_col_row_info(:,:)=local_col_row_info @@ -2465,11 +2432,11 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& ncol_rec=rec_col_row_info(0,2) ALLOCATE(row_indices_rec(nrow_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices_rec=rec_col_row_info(1:nrow_rec,1) ALLOCATE(col_indices_rec(ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices_rec=rec_col_row_info(1:ncol_rec,2) ! accumulate data on BIb_jb buffer starting from myself @@ -2501,15 +2468,15 @@ SUBROUTINE grep_my_integrals(para_env_sub,fm_BIb_jb,BIb_jb,max_row_col_local,& ncol_rec=rec_col_row_info(0,2) ALLOCATE(row_indices_rec(nrow_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indices_rec=rec_col_row_info(1:nrow_rec,1) ALLOCATE(col_indices_rec(ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) col_indices_rec=rec_col_row_info(1:ncol_rec,2) ALLOCATE(rec_BI(nrow_rec,ncol_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_BI=0.0_dp ! then send and receive the real data @@ -2561,7 +2528,6 @@ END SUBROUTINE grep_my_integrals !> \param unit_nr ... !> \param calc_forces ... !> \param calc_ex ... -!> \param error ... !> \param open_shell_SS ... !> \param BIb_C_beta ... !> \param homo_beta ... @@ -2572,7 +2538,7 @@ END SUBROUTINE grep_my_integrals ! ***************************************************************************** SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,para_env_sub,color_sub,& ends_array,ends_B_virtual,sizes_array,sizes_B_virtual,starts_array,starts_B_virtual,& - Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,calc_ex,error,& + Eigenval,nmo,homo,dimen_RI,unit_nr,calc_forces,calc_ex,& open_shell_SS,BIb_C_beta,homo_beta,Eigenval_beta,& ends_B_virtual_beta,sizes_B_virtual_beta, starts_B_virtual_beta) REAL(KIND=dp) :: Emp2, Emp2_Cou, Emp2_EX @@ -2587,7 +2553,6 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa INTEGER :: nmo, homo, dimen_RI, unit_nr LOGICAL, INTENT(IN) :: calc_forces LOGICAL :: calc_ex - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, OPTIONAL :: open_shell_SS REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :), OPTIONAL :: BIb_C_beta @@ -2706,7 +2671,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa ! in the integ group ! sub_sub_color=para_env_sub%mepos CALL mp2_ri_create_group(BIb_C,para_env,para_env_sub,homo,color_sub, & - sizes_array,calc_forces,error,& + sizes_array,calc_forces,& comm_exchange,integ_group_size, my_B_size,iiB, my_group_L_end,& my_group_L_size, my_group_L_size_orig, my_group_L_start,my_new_group_L_size, & sub_sub_color,integ_group_pos2color_sub,new_sizes_array, proc_map, proc_map_rep, sizes_array_orig,& @@ -2721,10 +2686,10 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa ! Calculate the maximum number of ij pairs that have to be computed ! among groups CALL mp2_ri_communication(my_alpha_beta_case,total_ij_pairs,homo,homo_beta,num_IJ_blocks,& - block_size,ngroup,ij_map,color_sub,my_ij_pairs,error,my_open_shell_SS,unit_nr) + block_size,ngroup,ij_map,color_sub,my_ij_pairs,my_open_shell_SS,unit_nr) ALLOCATE(num_ij_pairs(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) num_ij_pairs=0 num_ij_pairs(para_env_exchange%mepos)=my_ij_pairs CALL mp_sum(num_ij_pairs,para_env_exchange%group) @@ -2736,13 +2701,13 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa CALL mp2_ri_allocate(local_ab, t_ab,mp2_env,homo,virtual,dimen_RI,my_B_size,& block_size,my_B_size_beta,my_group_L_size,local_i_aL,& local_j_aL,calc_forces, Y_i_aP, Y_j_aP, & - error, my_alpha_beta_case,& + my_alpha_beta_case,& my_beta_beta_case) ELSE CALL mp2_ri_allocate(local_ab, t_ab,mp2_env,homo,virtual,dimen_RI,my_B_size,& block_size,my_B_size_beta,my_group_L_size,local_i_aL,& local_j_aL,calc_forces, Y_i_aP, Y_j_aP_beta, & - error, my_alpha_beta_case,& + my_alpha_beta_case,& my_beta_beta_case,local_ba,virtual_beta) ENDIF @@ -2802,7 +2767,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa rec_L_size=sizes_array(proc_receive) ALLOCATE(BI_C_rec(rec_L_size,MAX(my_B_size,my_B_size_beta),my_block_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ij_index<=send_ij_index) THEN ! ij_counter_send=(ij_index-MIN(1,proc_send))*ngroup+proc_send @@ -2943,7 +2908,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa rec_B_virtual_start=starts_B_virtual(proc_receive) ALLOCATE(external_i_aL(dimen_RI,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_i_aL=0.0_dp CALL mp_sendrecv(local_i_aL(:,:,iiB),proc_send,& @@ -2970,7 +2935,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa rec_B_virtual_start=starts_B_virtual_beta(proc_receive) ALLOCATE(external_i_aL(dimen_RI,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_i_aL=0.0_dp CALL mp_sendrecv(local_j_aL(:,:,jjB),proc_send,& @@ -3048,7 +3013,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa send_B_virtual_start=starts_B_virtual(proc_send) ALLOCATE(external_ab(my_B_size,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp CALL mp_sendrecv(local_ab(send_B_virtual_start:send_B_virtual_end,1:my_B_size),proc_send,& @@ -3078,7 +3043,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa Y_i_aP = 0.0_dp Y_j_aP = 0.0_dp CALL mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtual,& - starts_B_virtual,Eigenval, homo, dimen_RI, error, iiB, jjB, my_B_size, & + starts_B_virtual,Eigenval, homo, dimen_RI,iiB, jjB, my_B_size, & my_B_virtual_end, my_B_virtual_start, my_i, my_j, virtual, & sub_proc_map,local_ab, t_ab,local_i_aL, local_j_aL,& my_open_shell_ss,my_alpha_alpha_case, my_beta_beta_case, Y_i_aP, Y_j_aP) @@ -3086,7 +3051,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa Y_i_aP = 0.0_dp Y_j_aP_beta = 0.0_dp CALL mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtual,& - starts_B_virtual,Eigenval, homo, dimen_RI, error, iiB, jjB, my_B_size, & + starts_B_virtual,Eigenval, homo, dimen_RI,iiB, jjB, my_B_size, & my_B_virtual_end, my_B_virtual_start, my_i, my_j, virtual, sub_proc_map, & local_ab, t_ab,local_i_aL, local_j_aL,my_open_shell_ss,my_alpha_alpha_case, & my_beta_beta_case, Y_i_aP, Y_j_aP_beta, Eigenval_beta,homo_beta,my_B_size_beta,& @@ -3150,7 +3115,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa IF(calc_forces) THEN ! Closed shell, alpha-alpha or beta-beta case IF ( (.NOT. my_alpha_beta_case)) THEN - CALL mp2_redistribute_gamma(mp2_env, error, ij_index, my_B_size,& + CALL mp2_redistribute_gamma(mp2_env,ij_index, my_B_size,& my_block_size, my_group_L_size, my_i, my_ij_pairs, my_j, ngroup, & num_integ_group, integ_group_pos2color_sub, num_ij_pairs, proc_map, & ij_map, ranges_info_array, Y_i_aP, Y_j_aP, para_env_exchange, & @@ -3158,7 +3123,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa my_beta_beta_case,my_alpha_beta_case,my_open_shell_ss) ELSE ! Alpha-beta case - CALL mp2_redistribute_gamma(mp2_env, error, ij_index, my_B_size,& + CALL mp2_redistribute_gamma(mp2_env,ij_index, my_B_size,& my_block_size, my_group_L_size, my_i, my_ij_pairs, my_j, ngroup, & num_integ_group, integ_group_pos2color_sub, num_ij_pairs, proc_map, & ij_map, ranges_info_array, Y_i_aP, Y_j_aP_beta, para_env_exchange, & @@ -3177,22 +3142,22 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa IF(calc_forces) THEN DEALLOCATE(Y_i_aP, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (.NOT. my_alpha_beta_case) THEN DEALLOCATE(Y_j_aP, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE DEALLOCATE(Y_j_aP_beta, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ALLOCATED(t_ab)) THEN DEALLOCATE(t_ab, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ! Deallocate additional integrals: alpha_beta case with forces IF (ALLOCATED(local_ba)) THEN DEALLOCATE(local_ba) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ! here we check if there are almost degenerate ij @@ -3205,13 +3170,13 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa IF (.NOT. my_alpha_beta_case) THEN CALL quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,my_open_shell_ss, & my_beta_beta_case,my_alpha_beta_case, Bib_C,unit_nr,dimen_RI,my_B_size,ngroup,num_integ_group, my_group_L_size, & - error,color_sub,ranges_info_array,para_env_exchange,para_env_sub,proc_map, & + color_sub,ranges_info_array,para_env_exchange,para_env_sub,proc_map, & my_B_virtual_start,my_B_virtual_end,sizes_array, ends_B_virtual,sizes_B_virtual, & starts_B_virtual,sub_proc_map,integ_group_pos2color_sub,local_ab) ELSE CALL quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,my_open_shell_ss, & my_beta_beta_case,my_alpha_beta_case,Bib_C,unit_nr,dimen_RI,my_B_size,ngroup,num_integ_group, my_group_L_size, & - error,color_sub,ranges_info_array,para_env_exchange,para_env_sub,proc_map, & + color_sub,ranges_info_array,para_env_exchange,para_env_sub,proc_map, & my_B_virtual_start,my_B_virtual_end,sizes_array, ends_B_virtual,sizes_B_virtual, & starts_B_virtual,sub_proc_map,integ_group_pos2color_sub,local_ab,BIb_C_beta,my_B_size_beta,& ends_B_virtual_beta,sizes_B_virtual_beta,starts_B_virtual_beta,my_B_virtual_start_beta,& @@ -3235,11 +3200,11 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa sub_P_color=para_env_sub%mepos CALL mp_comm_split_direct(para_env%group,comm_P,sub_P_color) NULLIFY(para_env_P) - CALL cp_para_env_create(para_env_P,comm_P,error=error) + CALL cp_para_env_create(para_env_P,comm_P) CALL mp_sum(mp2_env%ri_grad%P_ab,para_env_P%group) IF (my_alpha_beta_case) CALL mp_sum(mp2_env%ri_grad%P_ab_beta,para_env_P%group) ! release para_env_P - CALL cp_para_env_release(para_env_P,error=error) + CALL cp_para_env_release(para_env_P) ENDIF ! sum P_ij (later) @@ -3263,7 +3228,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa DEALLOCATE(sizes_array) iiB=SIZE(sizes_array_orig) ALLOCATE(sizes_array(0:iiB-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_array(:)=sizes_array_orig DEALLOCATE(sizes_array_orig) @@ -3292,7 +3257,7 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa ! sum Gamma and dereplicate ALLOCATE(BIb_C(homo,my_B_size,my_group_L_size)) IF (my_alpha_beta_case) ALLOCATE(BIb_C_beta(homo_beta,my_B_size_beta,my_group_L_size)) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO proc_shift=1, para_env_rep%num_pe-1 ! invert order proc_send=proc_map_rep(para_env_rep%mepos-proc_shift) @@ -3328,14 +3293,14 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa BIb_C(:,:,:)=mp2_env%ri_grad%Gamma_P_ia(1:homo,1:my_B_size,1:my_group_L_size) DEALLOCATE(mp2_env%ri_grad%Gamma_P_ia) ALLOCATE(mp2_env%ri_grad%Gamma_P_ia(homo,my_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%Gamma_P_ia(:,:,:)=BIb_C DEALLOCATE(BIb_C) IF (my_alpha_beta_case) THEN BIb_C_beta(:,:,:)=mp2_env%ri_grad%Gamma_P_ia_beta(1:homo_beta,1:my_B_size_beta,1:my_group_L_size) DEALLOCATE(mp2_env%ri_grad%Gamma_P_ia_beta) ALLOCATE(mp2_env%ri_grad%Gamma_P_ia_beta(homo_beta,my_B_size_beta,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%Gamma_P_ia_beta(:,:,:)=BIb_C_beta DEALLOCATE(BIb_C_beta) ENDIF @@ -3351,19 +3316,19 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa my_group_L_size,my_group_L_start,my_group_L_end,& my_B_size,my_B_virtual_start,& ends_array,ends_B_virtual,sizes_array,sizes_B_virtual,starts_array,starts_B_virtual,& - sub_proc_map,error,.TRUE.) + sub_proc_map,.TRUE.) IF (my_alpha_beta_case) THEN CALL complete_gamma(mp2_env,B_ia_Q_beta,dimen_RI,homo_beta,virtual_beta,para_env,para_env_sub, & ngroup,my_group_L_size,my_group_L_start,my_group_L_end,& my_B_size_beta,my_B_virtual_start_beta,& ends_array,ends_B_virtual_beta,sizes_array,sizes_B_virtual_beta,starts_array,& - starts_B_virtual_beta,sub_proc_map,error,.FALSE.) + starts_B_virtual_beta,sub_proc_map,.FALSE.) ENDIF ENDIF ! Here we restore BIb_C IF (my_open_shell_ss) THEN ALLOCATE(BIb_C(my_group_L_size,my_B_size,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C=0.0_dp ! copy the integrals (ia|Q) back DO jjB=1, homo @@ -3412,8 +3377,8 @@ SUBROUTINE mp2_ri_gpw_compute_en(Emp2,Emp2_Cou,Emp2_EX,BIb_C,mp2_env,para_env,pa END IF END IF - CALL cp_para_env_release(para_env_exchange,error=error) - CALL cp_para_env_release(para_env_rep,error=error) + CALL cp_para_env_release(para_env_exchange) + CALL cp_para_env_release(para_env_rep) my_flop_rate=my_flop_rate/REAL(MAX(my_num_dgemm_call,1),KIND=dp)/1.0E9_dp CALL mp_sum(my_flop_rate,para_env%group) @@ -3442,15 +3407,13 @@ END SUBROUTINE mp2_ri_gpw_compute_en !> \param my_new_group_L_size ... !> \param new_sizes_array ... !> \param ranges_info_array ... -!> \param error ... ! ***************************************************************************** SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange,para_env_rep,& homo,proc_map_rep,& sizes_array,& my_B_size,& my_group_L_size,my_group_L_start,my_group_L_end,& - my_new_group_L_size,new_sizes_array,ranges_info_array,& - error) + my_new_group_L_size,new_sizes_array,ranges_info_array) REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :) :: BIb_C TYPE(cp_para_env_type), POINTER :: para_env, para_env_sub, & @@ -3464,7 +3427,6 @@ SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange my_new_group_L_size INTEGER, ALLOCATABLE, DIMENSION(:) :: new_sizes_array INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: ranges_info_array - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'replicate_iaK_2intgroup', & routineP = moduleN//':'//routineN @@ -3487,7 +3449,7 @@ SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange sub_sub_color=para_env_sub%mepos*para_env_exchange%num_pe+para_env_exchange%mepos CALL mp_comm_split_direct(para_env%group,comm_rep,sub_sub_color) NULLIFY(para_env_rep) - CALL cp_para_env_create(para_env_rep,comm_rep,error=error) + CALL cp_para_env_create(para_env_rep,comm_rep) ! crate the proc maps ALLOCATE(proc_map_rep(-para_env_rep%num_pe:2*para_env_rep%num_pe-1)) @@ -3500,21 +3462,21 @@ SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange ! create the new limits for K according to the size ! of the integral group ALLOCATE(new_sizes_array(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) new_sizes_array=0 ALLOCATE(ranges_info_array(4,0:para_env_rep%num_pe-1,0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ranges_info_array=0 ! info array for replication ALLOCATE(rep_ends_array(0:para_env_rep%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rep_ends_array=0 ALLOCATE(rep_starts_array(0:para_env_rep%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rep_starts_array=0 ALLOCATE(rep_sizes_array(0:para_env_rep%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rep_sizes_array=0 rep_sizes_array(para_env_rep%mepos)=my_group_L_size @@ -3552,13 +3514,13 @@ SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange IF(.FALSE.) THEN ! replication scheme using mp_sendrecv ALLOCATE(BIb_C_copy(my_group_L_size,my_B_size,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_copy(:,:,:)=BIb_C DEALLOCATE(BIb_C) ALLOCATE(BIb_C(my_new_group_L_size,my_B_size,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C=0.0_dp start_point=ranges_info_array(3,0,para_env_exchange%mepos) @@ -3587,14 +3549,14 @@ SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange max_L_size=MAXVAL(sizes_array) ALLOCATE(BIb_C_copy(max_L_size,my_B_size,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_copy=0.0_dp BIb_C_copy(1:my_group_L_size,1:my_B_size,1:homo)=BIb_C DEALLOCATE(BIb_C) ALLOCATE(BIb_C_gather(max_L_size,my_B_size,homo,0:para_env_rep%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_gather=0.0_dp CALL mp_allgather(BIb_C_copy,BIb_C_gather,para_env_rep%group) @@ -3602,7 +3564,7 @@ SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange DEALLOCATE(BIb_C_copy) ALLOCATE(BIb_C(my_new_group_L_size,my_B_size,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C=0.0_dp ! reorder data @@ -3627,7 +3589,7 @@ SUBROUTINE replicate_iaK_2intgroup(BIb_C,para_env,para_env_sub,para_env_exchange DEALLOCATE(rep_starts_array) DEALLOCATE(rep_ends_array) - ! CALL cp_para_env_release(para_env_rep,error=error) + ! CALL cp_para_env_release(para_env_rep) CALL timestop(handle) @@ -3669,7 +3631,6 @@ SUBROUTINE write_array(mat) !> \param calc_forces ... !> \param Y_i_aP ... !> \param Y_j_aP ... -!> \param error ... !> \param alpha_beta ... !> \param beta_beta ... !> \param local_ba ... @@ -3678,7 +3639,7 @@ SUBROUTINE write_array(mat) SUBROUTINE mp2_ri_allocate(local_ab, t_ab,mp2_env,homo,virtual,dimen_RI,my_B_size,& block_size,my_B_size_beta,my_group_L_size,& local_i_aL,local_j_aL,calc_forces, & - Y_i_aP, Y_j_aP, error,alpha_beta,& + Y_i_aP, Y_j_aP,alpha_beta,& beta_beta,local_ba,virtual_beta) REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: local_ab, t_ab @@ -3692,7 +3653,6 @@ SUBROUTINE mp2_ri_allocate(local_ab, t_ab,mp2_env,homo,virtual,dimen_RI,my_B_siz LOGICAL :: calc_forces REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :) :: Y_i_aP, Y_j_aP - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: alpha_beta, beta_beta REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :), OPTIONAL :: local_ba @@ -3708,53 +3668,53 @@ SUBROUTINE mp2_ri_allocate(local_ab, t_ab,mp2_env,homo,virtual,dimen_RI,my_B_siz failure=.FALSE. ALLOCATE(local_i_aL(dimen_RI,my_B_size,block_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(local_j_aL(dimen_RI,my_B_size_beta,block_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(local_ab(virtual,my_B_size_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(calc_forces) THEN ALLOCATE(Y_i_aP(my_B_size,dimen_RI,block_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Y_i_aP=0.0_dp ! For closed-shell, alpha-alpha and beta-beta my_B_size_beta=my_b_size ! Not for alpha-beta case: Y_j_aP_beta is sent and received as Y_j_aP ALLOCATE(Y_j_aP(my_B_size_beta,dimen_RI,block_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Y_j_aP=0.0_dp ! Closed shell or alpha-alpha case IF (.NOT. (beta_beta .OR. alpha_beta)) THEN ALLOCATE(mp2_env%ri_grad%P_ij(homo,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mp2_env%ri_grad%P_ab(my_B_size,virtual),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%P_ij=0.0_dp mp2_env%ri_grad%P_ab=0.0_dp ALLOCATE(mp2_env%ri_grad%Gamma_P_ia(homo,my_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%Gamma_P_ia=0.0_dp ELSE IF (beta_beta) THEN ALLOCATE(mp2_env%ri_grad%P_ij_beta(homo,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mp2_env%ri_grad%P_ab_beta(my_B_size,virtual),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%P_ij_beta=0.0_dp mp2_env%ri_grad%P_ab_beta=0.0_dp ALLOCATE(mp2_env%ri_grad%Gamma_P_ia_beta(homo,my_B_size_beta,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%Gamma_P_ia_beta=0.0_dp ENDIF ENDIF IF (.NOT. alpha_beta) THEN ! For non-alpha-beta case we need amplitudes ALLOCATE(t_ab(virtual,my_B_size_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ! We need more integrals ALLOCATE(local_ba(virtual_beta,my_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF END IF ! @@ -3775,19 +3735,17 @@ END SUBROUTINE mp2_ri_allocate !> \param ij_map ... !> \param color_sub ... !> \param my_ij_pairs ... -!> \param error ... !> \param my_open_shell_SS ... !> \param unit_nr ... ! ***************************************************************************** SUBROUTINE mp2_ri_communication(my_alpha_beta_case,total_ij_pairs,homo,homo_beta,num_IJ_blocks,& - block_size,ngroup,ij_map,color_sub,my_ij_pairs,error,my_open_shell_SS,unit_nr) + block_size,ngroup,ij_map,color_sub,my_ij_pairs,my_open_shell_SS,unit_nr) LOGICAL :: my_alpha_beta_case INTEGER :: total_ij_pairs, homo, & homo_beta, num_IJ_blocks, & block_size, ngroup INTEGER, ALLOCATABLE, DIMENSION(:, :) :: ij_map INTEGER :: color_sub, my_ij_pairs - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: my_open_shell_SS INTEGER :: unit_nr @@ -3830,10 +3788,10 @@ SUBROUTINE mp2_ri_communication(my_alpha_beta_case,total_ij_pairs,homo,homo_beta total_ij_pairs_blocks=assigned_blocks+(total_ij_pairs-assigned_blocks*(block_size**2)) ALLOCATE(ij_marker(homo,homo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ij_marker=0 ALLOCATE(ij_map(total_ij_pairs_blocks,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ij_map=0 ij_counter=0 my_ij_pairs=0 @@ -3879,7 +3837,7 @@ SUBROUTINE mp2_ri_communication(my_alpha_beta_case,total_ij_pairs,homo,homo_beta ! alpha-beta case no index symmetry total_ij_pairs=homo*homo_beta ALLOCATE(ij_map(total_ij_pairs,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ij_map=0 ij_counter=0 my_ij_pairs=0 @@ -3907,7 +3865,6 @@ END SUBROUTINE mp2_ri_communication !> \param color_sub ... !> \param sizes_array ... !> \param calc_forces ... -!> \param error ... !> \param comm_exchange ... !> \param integ_group_size ... !> \param my_B_size ... @@ -3930,7 +3887,7 @@ END SUBROUTINE mp2_ri_communication !> \param num_integ_group ... ! ***************************************************************************** SUBROUTINE mp2_ri_create_group(BIb_C,para_env,para_env_sub,homo,color_sub, & - sizes_array,calc_forces,error,& + sizes_array,calc_forces,& comm_exchange,integ_group_size, my_B_size,iiB, my_group_L_end,& my_group_L_size, my_group_L_size_orig, my_group_L_start,my_new_group_L_size, & sub_sub_color,integ_group_pos2color_sub,new_sizes_array, proc_map, proc_map_rep, sizes_array_orig,& @@ -3941,7 +3898,6 @@ SUBROUTINE mp2_ri_create_group(BIb_C,para_env,para_env_sub,homo,color_sub, & INTEGER :: homo, color_sub INTEGER, ALLOCATABLE, DIMENSION(:) :: sizes_array LOGICAL, INTENT(IN) :: calc_forces - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: comm_exchange, integ_group_size, my_B_size, iiB, & my_group_L_end, my_group_L_size, my_group_L_size_orig, & my_group_L_start, my_new_group_L_size, sub_sub_color @@ -3966,7 +3922,7 @@ SUBROUTINE mp2_ri_create_group(BIb_C,para_env,para_env_sub,homo,color_sub, & sub_sub_color=para_env_sub%mepos*num_integ_group+color_sub/integ_group_size CALL mp_comm_split_direct(para_env%group,comm_exchange,sub_sub_color) NULLIFY(para_env_exchange) - CALL cp_para_env_create(para_env_exchange,comm_exchange,error=error) + CALL cp_para_env_create(para_env_exchange,comm_exchange) ! create the proc maps ALLOCATE(proc_map(-para_env_exchange%num_pe:2*para_env_exchange%num_pe-1)) @@ -3988,11 +3944,10 @@ SUBROUTINE mp2_ri_create_group(BIb_C,para_env,para_env_sub,homo,color_sub, & sizes_array,& my_B_size,& my_group_L_size,my_group_L_start,my_group_L_end,& - my_new_group_L_size,new_sizes_array,ranges_info_array,& - error) + my_new_group_L_size,new_sizes_array,ranges_info_array) ALLOCATE(integ_group_pos2color_sub(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) integ_group_pos2color_sub=0 integ_group_pos2color_sub(para_env_exchange%mepos)=color_sub CALL mp_sum(integ_group_pos2color_sub,para_env_exchange%group) @@ -4000,7 +3955,7 @@ SUBROUTINE mp2_ri_create_group(BIb_C,para_env,para_env_sub,homo,color_sub, & IF(calc_forces) THEN iiB=SIZE(sizes_array) ALLOCATE(sizes_array_orig(0:iiB-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_array_orig(:)=sizes_array END IF @@ -4009,7 +3964,7 @@ SUBROUTINE mp2_ri_create_group(BIb_C,para_env,para_env_sub,homo,color_sub, & DEALLOCATE(sizes_array) ALLOCATE(sizes_array(0:integ_group_size-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_array(:)=new_sizes_array DEALLOCATE(new_sizes_array) @@ -4200,7 +4155,6 @@ END SUBROUTINE mp2_ri_get_sizes !> \param Eigenval ... !> \param homo ... !> \param dimen_RI ... -!> \param error ... !> \param iiB ... !> \param jjB ... !> \param my_B_size ... @@ -4231,7 +4185,7 @@ END SUBROUTINE mp2_ri_get_sizes !> \param local_ba ... ! ***************************************************************************** SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtual, starts_B_virtual,& - Eigenval, homo, dimen_RI, error, iiB, jjB, my_B_size, & + Eigenval, homo, dimen_RI,iiB, jjB, my_B_size, & my_B_virtual_end, my_B_virtual_start, my_i, my_j, virtual, sub_proc_map,local_ab,& t_ab,local_i_aL, local_j_aL,open_ss,alpha_alpha,beta_beta,Y_i_aP,Y_j_aP, & eigenval_beta,homo_beta, my_B_size_beta,ends_B_virtual_beta,sizes_B_virtual_beta, & @@ -4242,12 +4196,8 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua sizes_B_virtual, & starts_B_virtual REAL(KIND=dp), DIMENSION(:) :: Eigenval - INTEGER :: homo, dimen_RI - TYPE(cp_error_type), INTENT(inout) :: error - INTEGER :: iiB, jjB, my_B_size, & - my_B_virtual_end, & - my_B_virtual_start, my_i, & - my_j, virtual + INTEGER :: homo, dimen_RI, iiB, jjB, my_B_size, my_B_virtual_end, & + my_B_virtual_start, my_i, my_j, virtual INTEGER, ALLOCATABLE, DIMENSION(:) :: sub_proc_map REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: local_ab, t_ab @@ -4411,7 +4361,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua ENDIF ALLOCATE(external_ab(virtual,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp IF (.NOT. alpha_beta) THEN @@ -4456,7 +4406,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua send_B_virtual_end=ends_B_virtual(proc_send) send_B_virtual_start=starts_B_virtual(proc_send) ALLOCATE(external_ab(virtual_beta,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp CALL mp_sendrecv(local_ba(1:virtual_beta,1:my_B_size),proc_send,& external_ab(1:virtual_beta,1:rec_B_size),proc_receive,& @@ -4471,11 +4421,11 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua IF((my_i/=my_j) .AND. (.NOT. alpha_beta)) THEN ALLOCATE(external_ab(my_B_size,virtual),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp ALLOCATE(send_ab(send_B_size,virtual),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_ab=0.0_dp CALL dgemm('N','T',send_B_size,virtual,my_B_size,1.0_dp,& @@ -4527,7 +4477,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua ENDIF ALLOCATE(external_ab(my_B_size,dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp ! DO proc_shift=1, para_env_sub%num_pe-1 @@ -4544,7 +4494,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua IF (.NOT. alpha_beta) THEN ALLOCATE(send_ab(send_B_size,dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_ab=0.0_dp CALL dgemm('N','T',send_B_size,dimen_RI,my_B_size,1.0_dp,& t_ab(send_B_virtual_start:send_B_virtual_end,1:my_B_size),send_B_size,& @@ -4560,7 +4510,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua ELSE ! Alpha-beta case ! Alpha-alpha part ALLOCATE(send_ab(send_B_size,dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_ab=0.0_dp CALL dgemm('N','T',send_B_size,dimen_RI,my_B_size_beta,1.0_dp,& local_ab(send_B_virtual_start:send_B_virtual_end,1:my_B_size_beta),send_B_size,& @@ -4577,7 +4527,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua IF (alpha_beta) THEN ! For beta-beta part (in alpha-beta case) we need a new parallel code ALLOCATE(external_ab(my_B_size_beta,dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp DO proc_shift=1, para_env_sub%num_pe-1 proc_send=sub_proc_map(para_env_sub%mepos+proc_shift) @@ -4587,7 +4537,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua send_B_virtual_end=ends_B_virtual_beta(proc_send) send_B_virtual_start=starts_B_virtual_beta(proc_send) ALLOCATE(send_ab(send_B_size,dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_ab=0.0_dp CALL dgemm('N','T',send_B_size,dimen_RI,my_B_size,1.0_dp,& @@ -4619,7 +4569,7 @@ SUBROUTINE mp2_update_P_gamma(mp2_env,para_env_sub,ends_B_virtual,sizes_B_virtua rec_B_virtual_start=starts_B_virtual(proc_receive) ALLOCATE(external_ab(dimen_RI,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp CALL mp_sendrecv(local_i_aL(1:dimen_RI,1:my_B_size,iiB), proc_send,& @@ -4645,7 +4595,6 @@ END SUBROUTINE mp2_update_P_gamma ! ***************************************************************************** !> \brief ... !> \param mp2_env ... -!> \param error ... !> \param ij_index ... !> \param my_B_size ... !> \param my_block_size ... @@ -4672,7 +4621,7 @@ END SUBROUTINE mp2_update_P_gamma !> \param open_shell ... !> \param my_b_size_beta ... ! ***************************************************************************** - SUBROUTINE mp2_redistribute_gamma(mp2_env,error, ij_index, my_B_size, & + SUBROUTINE mp2_redistribute_gamma(mp2_env,ij_index, my_B_size, & my_block_size, my_group_L_size, my_i, my_ij_pairs, my_j, ngroup, & num_integ_group, integ_group_pos2color_sub, num_ij_pairs, proc_map, & ij_map, ranges_info_array, Y_i_aP, Y_j_aP, para_env_exchange, & @@ -4680,7 +4629,6 @@ SUBROUTINE mp2_redistribute_gamma(mp2_env,error, ij_index, my_B_size, & alpha_beta,open_shell,my_b_size_beta) TYPE(mp2_type), POINTER :: mp2_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ij_index, my_B_size, my_block_size, my_group_L_size, my_i, & my_ij_pairs, my_j, ngroup, num_integ_group INTEGER, ALLOCATABLE, DIMENSION(:) :: integ_group_pos2color_sub, & @@ -4796,12 +4744,12 @@ SUBROUTINE mp2_redistribute_gamma(mp2_env,error, ij_index, my_B_size, & send_L_size=sizes_array(proc_send) IF (.NOT. alpha_beta) THEN ALLOCATE(BI_C_send(2*my_block_size,my_B_size,send_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(BI_C_send(my_block_size,my_B_size,send_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(BI_C_send_beta(my_block_size,my_B_size_beta,send_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timeset(routineN//"_comm2_w",handle2) BI_C_send=0.0_dp @@ -4866,12 +4814,12 @@ SUBROUTINE mp2_redistribute_gamma(mp2_env,error, ij_index, my_B_size, & IF (.NOT. alpha_beta) THEN ALLOCATE(BI_C_rec(2*rec_block_size,my_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(BI_C_rec(rec_block_size,my_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(BI_C_rec_beta(rec_block_size,my_B_size_beta,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF BI_C_rec=0.0_dp @@ -4994,12 +4942,12 @@ SUBROUTINE mp2_redistribute_gamma(mp2_env,error, ij_index, my_B_size, & IF (.NOT. alpha_beta) THEN ALLOCATE(BI_C_rec(2*rec_block_size,my_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(BI_C_rec(rec_block_size,my_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(BI_C_rec_beta(rec_block_size,my_B_size_beta,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF BI_C_rec=0.0_dp @@ -5121,7 +5069,6 @@ END SUBROUTINE mp2_redistribute_gamma !> \param ngroup ... !> \param num_integ_group ... !> \param my_group_L_size ... -!> \param error ... !> \param color_sub ... !> \param ranges_info_array ... !> \param para_env_exchange ... @@ -5149,7 +5096,7 @@ END SUBROUTINE mp2_redistribute_gamma ! ***************************************************************************** SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & beta_beta,alpha_beta, Bib_C,unit_nr,dimen_RI,my_B_size,ngroup,num_integ_group, my_group_L_size, & - error,color_sub,ranges_info_array,para_env_exchange,para_env_sub,proc_map, & + color_sub,ranges_info_array,para_env_exchange,para_env_sub,proc_map, & my_B_virtual_start,my_B_virtual_end,sizes_array, ends_B_virtual,sizes_B_virtual, & starts_B_virtual,sub_proc_map,integ_group_pos2color_sub,local_ab,BIb_C_beta,my_B_size_beta,& ends_B_virtual_beta,sizes_B_virtual_beta,starts_B_virtual_beta,my_B_virtual_start_beta,& @@ -5163,9 +5110,7 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & DIMENSION(:, :, :) :: BIb_C INTEGER :: unit_nr, dimen_RI, my_B_size, & ngroup, num_integ_group, & - my_group_L_size - TYPE(cp_error_type), INTENT(inout) :: error - INTEGER :: color_sub + my_group_L_size, color_sub INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: ranges_info_array TYPE(cp_para_env_type), POINTER :: para_env_exchange, & para_env_sub @@ -5225,10 +5170,10 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & IF (.NOT. alpha_beta) THEN CALL Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr,ngroup,& - beta_beta,alpha_beta,para_env_exchange,error,num_ijk,max_ijk,color_sub) + beta_beta,alpha_beta,para_env_exchange,num_ijk,max_ijk,color_sub) ELSE CALL Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr,ngroup,& - beta_beta,alpha_beta,para_env_exchange, error,num_ijk,max_ijk,color_sub, & + beta_beta,alpha_beta,para_env_exchange,num_ijk,max_ijk,color_sub, & Eigenval_beta,homo_beta,ijk_map_beta,num_ijk_beta,max_ijk_beta,my_ijk_beta) ENDIF @@ -5257,13 +5202,13 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & ENDIF ALLOCATE(local_i_aL(dimen_RI,size_B_i,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(local_j_aL(dimen_RI,size_B_j,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(local_k_aL(dimen_RI,size_B_k,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(t_ab(my_virtual,size_B_k),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ijk_index=1, max_ijk_loop IF (iloops .EQ. 2) my_ijk = my_ijk_beta @@ -5315,7 +5260,7 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & rec_L_size=sizes_array(proc_receive) ALLOCATE(BI_C_rec(rec_L_size,size_B_i,1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ijk_index<=send_ijk_index) THEN ! something to send @@ -5368,7 +5313,7 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & ELSE ! For beta_beta density, the size is different now !DEALLOCATE(BI_C_rec) !ALLOCATE(BI_C_rec(rec_L_size,size_B_j,1),STAT=stat) - !CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + !CPPostcondition(stat==0,cp_failure_level,routineP,failure) !BI_C_rec=0.0_dp CALL mp_sendrecv(BIb_C_beta(1:my_group_L_size,1:size_B_j,send_j),proc_send,& BI_C_rec(1:rec_L_size,1:size_B_j,1),proc_receive,& @@ -5436,7 +5381,7 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & IF (iloops .EQ. 2) THEN ! For alpha-beta case for beta-beta density the dimensions are different DEALLOCATE(local_ab) ALLOCATE(local_ab(virtual_beta,size_B_k)) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_ab=0.0_dp CALL dgemm('T','N',size_B_i,size_B_k,dimen_RI,1.0_dp,& local_i_aL(:,:,1),dimen_RI,local_k_aL(:,:,1),dimen_RI,& @@ -5461,7 +5406,7 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & ENDIF ALLOCATE(external_i_aL(dimen_RI,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_i_aL=0.0_dp CALL mp_sendrecv(local_i_aL(:,:,1),proc_send,& @@ -5523,7 +5468,7 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & send_B_virtual_start=starts_B_virtual(proc_send) ALLOCATE(external_ab(size_B_i,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_ab=0.0_dp CALL mp_sendrecv(local_ab(send_B_virtual_start:send_B_virtual_end,1:size_B_k),proc_send,& external_ab(1:size_B_i,1:rec_B_size),proc_receive, para_env_sub%group) @@ -5571,7 +5516,7 @@ SUBROUTINE quasi_degenerate_P_ij(mp2_env,Eigenval,homo,virtual,open_shell, & ENDIF ALLOCATE(external_i_aL(dimen_RI,rec_B_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) external_i_aL=0.0_dp CALL mp_sendrecv(local_j_aL(:,:,1),proc_send,& @@ -5729,7 +5674,6 @@ END SUBROUTINE Quasi_degenerate_P_ij !> \param beta_beta ... !> \param alpha_beta ... !> \param para_env_exchange ... -!> \param error ... !> \param num_ijk ... !> \param max_ijk ... !> \param color_sub ... @@ -5741,7 +5685,7 @@ END SUBROUTINE Quasi_degenerate_P_ij !> \param my_ijk_beta ... ! ***************************************************************************** SUBROUTINE Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr,ngroup,& - beta_beta,alpha_beta,para_env_exchange,error,num_ijk,max_ijk,color_sub,Eigenval_beta,& + beta_beta,alpha_beta,para_env_exchange,num_ijk,max_ijk,color_sub,Eigenval_beta,& homo_beta,ijk_map_beta,num_ijk_beta,max_ijk_beta,my_ijk_beta) INTEGER :: my_ijk, homo @@ -5751,7 +5695,6 @@ SUBROUTINE Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr INTEGER :: unit_nr, ngroup LOGICAL :: beta_beta, alpha_beta TYPE(cp_para_env_type), POINTER :: para_env_exchange - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, ALLOCATABLE, DIMENSION(:) :: num_ijk INTEGER :: max_ijk, color_sub REAL(KIND=dp), DIMENSION(:), OPTIONAL :: Eigenval_beta @@ -5798,7 +5741,7 @@ SUBROUTINE Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr ENDIF total_ijk=my_homo*num_sing_ij ALLOCATE(ijk_map(total_ijk,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ijk_map=0 my_ijk=0 @@ -5818,7 +5761,7 @@ SUBROUTINE Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr END DO ALLOCATE(num_ijk(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) num_ijk=0 num_ijk(para_env_exchange%mepos)=my_ijk CALL mp_sum(num_ijk,para_env_exchange%group) @@ -5837,7 +5780,7 @@ SUBROUTINE Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr ! total number of elemets that have to be computed total_ijk=homo*num_sing_ij ALLOCATE(ijk_map_beta(total_ijk,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ijk_map_beta=0 my_ijk_beta=0 ijk_counter=0 @@ -5855,7 +5798,7 @@ SUBROUTINE Find_quasi_degenerate_ij(my_ijk,homo,Eigenval,mp2_env,ijk_map,unit_nr END DO END DO ALLOCATE(num_ijk_beta(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) num_ijk_beta=0 num_ijk_beta(para_env_exchange%mepos)=my_ijk_beta CALL mp_sum(num_ijk_beta,para_env_exchange%group) diff --git a/src/mp2_ri_grad.F b/src/mp2_ri_grad.F index 605f52c1e4..3504db0e85 100644 --- a/src/mp2_ri_grad.F +++ b/src/mp2_ri_grad.F @@ -129,7 +129,6 @@ MODULE mp2_ri_grad !> \param auxbas_pw_pool ... !> \param task_list_sub ... !> \param blacs_env_sub ... -!> \param error ... !> \param Eigenval_beta ... !> \param homo_beta ... !> \param mo_coeff_beta ... @@ -139,7 +138,7 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c atomic_kind_set,qs_kind_set,mo_coeff,nmo,homo,dimen_RI,Eigenval,& my_group_L_start,my_group_L_end,my_group_L_size,rho_r,rho_g,pot_g,& mat_munu,pw_env_sub,poisson_env,auxbas_pw_pool,task_list_sub,& - blacs_env_sub,error,Eigenval_beta,homo_beta,mo_coeff_beta) + blacs_env_sub,Eigenval_beta,homo_beta,mo_coeff_beta) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mp2_type), POINTER :: mp2_env TYPE(cp_para_env_type), POINTER :: para_env, para_env_sub @@ -164,7 +163,6 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c TYPE(pw_pool_type), POINTER :: auxbas_pw_pool TYPE(task_list_type), POINTER :: task_list_sub TYPE(cp_blacs_env_type), POINTER :: blacs_env_sub - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), DIMENSION(:), OPTIONAL :: Eigenval_beta INTEGER, OPTIONAL :: homo_beta TYPE(cp_fm_type), OPTIONAL, POINTER :: mo_coeff_beta @@ -246,15 +244,15 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c ENDIF CALL get_qs_env(qs_env, ks_env=ks_env, molecule_set=molecule_set, & - molecule_kind_set=molecule_kind_set, error=error) + molecule_kind_set=molecule_kind_set) nkind = SIZE(atomic_kind_set) natom = SIZE(particle_set) ALLOCATE (kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind) itmp=get_limit(dimen_RI,para_env_sub%num_pe,para_env_sub%mepos) @@ -262,7 +260,7 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c my_P_end=itmp(2) my_P_size=itmp(2)-itmp(1)+1 ALLOCATE(G_PQ_local(dimen_RI,my_group_L_size),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) G_PQ_local=0.0_dp IF (.NOT. alpha_beta) THEN @@ -272,86 +270,86 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c 0.50_dp*(mp2_env%ri_grad%Gamma_PQ + mp2_env%ri_grad%Gamma_PQ_beta) ENDIF DEALLOCATE(mp2_env%ri_grad%Gamma_PQ,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (alpha_beta) THEN DEALLOCATE(mp2_env%ri_grad%Gamma_PQ_beta,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF CALL mp_sum(G_PQ_local,para_env_sub%group) ! deallocate here PQ_half, maybe usefull in the future DEALLOCATE(mp2_env%ri_grad%PQ_half,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! create matrix holding the back transformation (G_P_inu) ALLOCATE(matrix_P_inu%matrix) - CALL cp_dbcsr_init(matrix_P_inu%matrix,error=error) - CALL cp_dbcsr_create(matrix_P_inu%matrix,template=mo_coeff_o,error=error) + CALL cp_dbcsr_init(matrix_P_inu%matrix) + CALL cp_dbcsr_create(matrix_P_inu%matrix,template=mo_coeff_o) IF (alpha_beta) THEN ALLOCATE(matrix_P_inu_beta%matrix) - CALL cp_dbcsr_init(matrix_P_inu_beta%matrix,error=error) - CALL cp_dbcsr_create(matrix_P_inu_beta%matrix,template=mo_coeff_o_beta,error=error) + CALL cp_dbcsr_init(matrix_P_inu_beta%matrix) + CALL cp_dbcsr_create(matrix_P_inu_beta%matrix,template=mo_coeff_o_beta) ENDIF ! non symmetric matrix ALLOCATE(matrix_P_munu_nosym%matrix) - CALL cp_dbcsr_init(matrix_P_munu_nosym%matrix,error=error) + CALL cp_dbcsr_init(matrix_P_munu_nosym%matrix) CALL cp_dbcsr_create(matrix_P_munu_nosym%matrix,template=mat_munu%matrix,& - matrix_type=dbcsr_type_no_symmetry,error=error) - ! CALL cp_dbcsr_create(matrix_P_munu_nosym%matrix,template=mat_munu%matrix,error=error) + matrix_type=dbcsr_type_no_symmetry) + ! CALL cp_dbcsr_create(matrix_P_munu_nosym%matrix,template=mat_munu%matrix) ! CALL cp_dbcsr_copy(matrix_P_munu_nosym%matrix,mat_munu%matrix,& - ! name="matrix_P_munu_nosym",error=error) + ! name="matrix_P_munu_nosym") !XXXXXX - ! CALL cp_dbcsr_desymmetrize(mat_munu%matrix,matrix_P_munu_nosym%matrix,error=error) + ! CALL cp_dbcsr_desymmetrize(mat_munu%matrix,matrix_P_munu_nosym%matrix) ! create Lagrangian matrices in mixed AO/MO formalism ALLOCATE(Lag_mu_i_1%matrix) - CALL cp_dbcsr_init(Lag_mu_i_1%matrix,error=error) - CALL cp_dbcsr_create(Lag_mu_i_1%matrix,template=mo_coeff_o,error=error) - CALL cp_dbcsr_set(Lag_mu_i_1%matrix,0.0_dp,error=error) + CALL cp_dbcsr_init(Lag_mu_i_1%matrix) + CALL cp_dbcsr_create(Lag_mu_i_1%matrix,template=mo_coeff_o) + CALL cp_dbcsr_set(Lag_mu_i_1%matrix,0.0_dp) IF (alpha_beta) THEN ALLOCATE(Lag_mu_i_1_beta%matrix) - CALL cp_dbcsr_init(Lag_mu_i_1_beta%matrix,error=error) - CALL cp_dbcsr_create(Lag_mu_i_1_beta%matrix,template=mo_coeff_o_beta,error=error) - CALL cp_dbcsr_set(Lag_mu_i_1_beta%matrix,0.0_dp,error=error) + CALL cp_dbcsr_init(Lag_mu_i_1_beta%matrix) + CALL cp_dbcsr_create(Lag_mu_i_1_beta%matrix,template=mo_coeff_o_beta) + CALL cp_dbcsr_set(Lag_mu_i_1_beta%matrix,0.0_dp) ENDIF ALLOCATE(Lag_nu_a_2%matrix) - CALL cp_dbcsr_init(Lag_nu_a_2%matrix,error=error) - CALL cp_dbcsr_create(Lag_nu_a_2%matrix,template=mo_coeff_v,error=error) - CALL cp_dbcsr_set(Lag_nu_a_2%matrix,0.0_dp,error=error) + CALL cp_dbcsr_init(Lag_nu_a_2%matrix) + CALL cp_dbcsr_create(Lag_nu_a_2%matrix,template=mo_coeff_v) + CALL cp_dbcsr_set(Lag_nu_a_2%matrix,0.0_dp) IF (alpha_beta) THEN ALLOCATE(Lag_nu_a_2_beta%matrix) - CALL cp_dbcsr_init(Lag_nu_a_2_beta%matrix,error=error) - CALL cp_dbcsr_create(Lag_nu_a_2_beta%matrix,template=mo_coeff_v_beta,error=error) - CALL cp_dbcsr_set(Lag_nu_a_2_beta%matrix,0.0_dp,error=error) + CALL cp_dbcsr_init(Lag_nu_a_2_beta%matrix) + CALL cp_dbcsr_create(Lag_nu_a_2_beta%matrix,template=mo_coeff_v_beta) + CALL cp_dbcsr_set(Lag_nu_a_2_beta%matrix,0.0_dp) ENDIF ALLOCATE(matrix_P_munu%matrix) - CALL cp_dbcsr_init(matrix_P_munu%matrix,error=error) + CALL cp_dbcsr_init(matrix_P_munu%matrix) CALL cp_dbcsr_create(matrix_P_munu%matrix,template=mat_munu%matrix,& - matrix_type=dbcsr_type_symmetric,error=error) - ! CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp,error=error) + matrix_type=dbcsr_type_symmetric) + ! CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp) ! CALL cp_dbcsr_copy(matrix_P_munu%matrix,mat_munu%matrix,& - ! name="matrix_P_munu",error=error) + ! name="matrix_P_munu") ! wave function vector and supporting stuff ALLOCATE(wf_vector(dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(psi_L%pw) CALL pw_pool_create_pw(auxbas_pw_pool,psi_L%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) IF (alpha_beta) THEN NULLIFY(psi_L_beta%pw) CALL pw_pool_create_pw(auxbas_pw_pool,psi_L_beta%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) ENDIF ! get forces NULLIFY (force, virial) - CALL get_qs_env(qs_env=qs_env,force=force,virial=virial,error=error) + CALL get_qs_env(qs_env=qs_env,force=force,virial=virial) ! check if we want to calculate the virial use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -363,12 +361,12 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c NULLIFY(temp_pw_g%pw) CALL pw_pool_create_pw(auxbas_pw_pool,temp_pw_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) DO i=1, 3 NULLIFY(dvg(i)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,dvg(i)%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) END DO END IF @@ -380,48 +378,47 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c ! first back-transformation a->nu CALL timeset(routineN//"_back_v",handle3) - CALL cp_dbcsr_set(matrix_P_inu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_P_inu%matrix,0.0_dp) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, mo_coeff_v, G_P_ia(L_counter)%matrix, & - 0.0_dp, matrix_P_inu%matrix, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_P_inu%matrix, filter_eps=eps_filter) IF (alpha_beta) THEN - CALL cp_dbcsr_set(matrix_P_inu_beta%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_P_inu_beta%matrix,0.0_dp) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, mo_coeff_v_beta, G_P_ia_beta(L_counter)%matrix, & - 0.0_dp, matrix_P_inu_beta%matrix, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_P_inu_beta%matrix, filter_eps=eps_filter) ENDIF CALL timestop(handle3) ! second back-transformation i->mu CALL timeset(routineN//"_back_o",handle3) - CALL cp_dbcsr_set(matrix_P_munu_nosym%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_P_munu_nosym%matrix,0.0_dp) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, matrix_P_inu%matrix, mo_coeff_o, & - 0.0_dp, matrix_P_munu_nosym%matrix, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_P_munu_nosym%matrix, filter_eps=eps_filter) IF (alpha_beta) THEN - !CALL cp_dbcsr_set(matrix_P_munu_nosym%matrix,0.0_dp,error=error) + !CALL cp_dbcsr_set(matrix_P_munu_nosym%matrix,0.0_dp) CALL cp_dbcsr_multiply("N", "T", 0.5_dp, matrix_P_inu_beta%matrix, mo_coeff_o_beta, & - 0.5_dp, matrix_P_munu_nosym%matrix, filter_eps=eps_filter, error=error) + 0.5_dp, matrix_P_munu_nosym%matrix, filter_eps=eps_filter) ENDIF ! ! first back-transformation a->nu ! CALL timeset(routineN//"_back_v",handle3) - ! CALL cp_dbcsr_set(matrix_P_inu%matrix,0.0_dp,error=error) + ! CALL cp_dbcsr_set(matrix_P_inu%matrix,0.0_dp) ! CALL cp_dbcsr_multiply("N", "T", 1.0_dp, G_P_ia(L_counter)%matrix, mo_coeff_v, & - ! 0.0_dp, matrix_P_inu%matrix, filter_eps=eps_filter, error=error) + ! 0.0_dp, matrix_P_inu%matrix, filter_eps=eps_filter) ! CALL timestop(handle3) ! ! second back-transformation i->mu ! CALL timeset(routineN//"_back_o",handle3) - ! CALL cp_dbcsr_set(matrix_P_munu_nosym%matrix,0.0_dp,error=error) + ! CALL cp_dbcsr_set(matrix_P_munu_nosym%matrix,0.0_dp) ! CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mo_coeff_o, matrix_P_inu%matrix, & - ! 0.0_dp, matrix_P_munu_nosym%matrix, filter_eps=eps_filter, error=error) + ! 0.0_dp, matrix_P_munu_nosym%matrix, filter_eps=eps_filter) ! symmetrize - CALL cp_dbcsr_set(matrix_P_munu%matrix,0.0_dp,error=error) - CALL cp_dbcsr_transposed(matrix_P_munu%matrix,matrix_P_munu_nosym%matrix,& - error=error) + CALL cp_dbcsr_set(matrix_P_munu%matrix,0.0_dp) + CALL cp_dbcsr_transposed(matrix_P_munu%matrix,matrix_P_munu_nosym%matrix) CALL cp_dbcsr_add(matrix_P_munu%matrix,matrix_P_munu_nosym%matrix,& - alpha_scalar=2.0_dp,beta_scalar=2.0_dp,error=error) + alpha_scalar=2.0_dp,beta_scalar=2.0_dp) ! this is a trick to avoid that integrate_v_rspace starts to cry - CALL cp_dbcsr_copy_into_existing(mat_munu%matrix, matrix_P_munu%matrix, error) - CALL cp_dbcsr_copy(matrix_P_munu%matrix,mat_munu%matrix,error=error) + CALL cp_dbcsr_copy_into_existing(mat_munu%matrix, matrix_P_munu%matrix) + CALL cp_dbcsr_copy(matrix_P_munu%matrix,mat_munu%matrix) CALL timestop(handle3) @@ -433,34 +430,32 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c CALL calculate_wavefunction(mo_coeff,1,psi_L,rho_g, atomic_kind_set,& qs_kind_set,cell,dft_control,particle_set,pw_env_sub,& basis_type="RI_AUX",& - external_vector=wf_vector,& - error=error) + external_vector=wf_vector) rho_r%pw%cr3d = psi_L%pw%cr3d IF (alpha_beta) THEN CALL calculate_wavefunction(mo_coeff_beta,1,psi_L_beta,rho_g, atomic_kind_set,& qs_kind_set,cell,dft_control,particle_set, & pw_env_sub,basis_type='RI_AUX',& - external_vector=wf_vector,& - error=error) + external_vector=wf_vector) rho_r%pw%cr3d = 0.50_dp*(rho_r%pw%cr3d + psi_L_beta%pw%cr3d) ENDIF - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) CALL timestop(handle3) IF(use_virial) THEN ! make a copy of the density in G space ! calculate the potential derivatives in G space CALL timeset(routineN//"_Virial",handle3) - CALL pw_copy(rho_g%pw, temp_pw_g%pw, error=error) + CALL pw_copy(rho_g%pw, temp_pw_g%pw) DO i=1, 3 comp=0 comp(i)=1 - CALL pw_copy(pot_g%pw, dvg(i)%pw, error=error) - CALL pw_derive(dvg(i)%pw, comp, error=error) + CALL pw_copy(pot_g%pw, dvg(i)%pw) + CALL pw_derive(dvg(i)%pw, comp) END DO CALL timestop(handle3) END IF @@ -470,18 +465,18 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c CALL timeset(routineN//"_int_PQ",handle3) NULLIFY(rs_v) NULLIFY(rs_descs) - CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v, error=error) + CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v) DO i=1,SIZE(rs_v) - CALL rs_grid_retain(rs_v(i)%rs_grid,error=error) + CALL rs_grid_retain(rs_v(i)%rs_grid) END DO - CALL potential_pw2rs(rs_v,rho_r,pw_env_sub,error) + CALL potential_pw2rs(rs_v,rho_r,pw_env_sub) offset=0 DO iatom=1, natom ikind=kind_of(iatom) atom_a = atom_of_kind(iatom) CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,& - basis_type="RI_AUX",error=error) + basis_type="RI_AUX") first_sgfa => basis_set_a%first_sgf la_max => basis_set_a%lmax @@ -574,8 +569,7 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c eps_gvg_rspace=dft_control%qs_control%eps_gvg_rspace,& calculate_forces=.TRUE.,& force_a=force_a, force_b=force_b, & - use_virial=use_virial,my_virial_a=my_virial_a,my_virial_b=my_virial_b,& - error=error) + use_virial=use_virial,my_virial_a=my_virial_a,my_virial_b=my_virial_b) END DO @@ -600,22 +594,22 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c END DO DO i=1,SIZE(rs_v) - CALL rs_grid_release(rs_v(i)%rs_grid, error=error) + CALL rs_grid_release(rs_v(i)%rs_grid) END DO CALL timestop(handle3) ! here we are done with the 2 centers ! CALL cp_dbcsr_write_sparse_matrix(matrix_P_munu%matrix,4,12,qs_env,para_env_sub,& - ! output_unit=unit_nr,error=error) + ! output_unit=unit_nr) ! integrate the potential of the single gaussian and update ! 3-center forces CALL timeset(routineN//"_int",handle3) - CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(mat_munu%matrix,0.0_dp) CALL integrate_v_rspace(rho_r,hmat=mat_munu,pmat=matrix_P_munu,& qs_env=qs_env,calculate_forces=.TRUE.,compute_tau=.FALSE.,gapw=.FALSE.,& pw_env_external=pw_env_sub,& - task_list_external=task_list_sub, error=error) + task_list_external=task_list_sub) CALL timestop(handle3) ! update lagrangian @@ -623,43 +617,43 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c ! first contract mat_munu with the half back transformed Gamma_i_nu ! in order to update Lag_mu_i_1 CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, matrix_P_inu%matrix, & - 1.0_dp, Lag_mu_i_1%matrix, filter_eps=eps_filter, error=error) + 1.0_dp, Lag_mu_i_1%matrix, filter_eps=eps_filter) IF (alpha_beta) THEN CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, matrix_P_inu_beta%matrix, & - 1.0_dp, Lag_mu_i_1_beta%matrix, filter_eps=eps_filter, error=error) + 1.0_dp, Lag_mu_i_1_beta%matrix, filter_eps=eps_filter) ENDIF ! transform first index of mat_munu and store the result into matrix_P_inu - CALL cp_dbcsr_set(matrix_P_inu%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_P_inu%matrix,0.0_dp) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_o, & - 0.0_dp, matrix_P_inu%matrix, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_P_inu%matrix, filter_eps=eps_filter) IF (alpha_beta) THEN - CALL cp_dbcsr_set(matrix_P_inu_beta%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_P_inu_beta%matrix,0.0_dp) CALL cp_dbcsr_multiply("N", "N", 1.0_dp, mat_munu%matrix, mo_coeff_o_beta, & - 0.0_dp, matrix_P_inu_beta%matrix, filter_eps=eps_filter, error=error) + 0.0_dp, matrix_P_inu_beta%matrix, filter_eps=eps_filter) ENDIF ! contract the transformend matrix_P_inu with the untransformend Gamma_i_a ! in order to update Lag_nu_a_2 CALL cp_dbcsr_multiply("N", "N", -1.0_dp, matrix_P_inu%matrix, G_P_ia(L_counter)%matrix, & - 1.0_dp, Lag_nu_a_2%matrix, filter_eps=eps_filter, error=error) + 1.0_dp, Lag_nu_a_2%matrix, filter_eps=eps_filter) IF (alpha_beta) THEN CALL cp_dbcsr_multiply("N", "N", -1.0_dp, matrix_P_inu_beta%matrix, & G_P_ia_beta(L_counter)%matrix, 1.0_dp, Lag_nu_a_2_beta%matrix, & - filter_eps=eps_filter, error=error) + filter_eps=eps_filter) ENDIF ! release the actual gamma_P_ia - CALL cp_dbcsr_release(G_P_ia(L_counter)%matrix,error=error) + CALL cp_dbcsr_release(G_P_ia(L_counter)%matrix) DEALLOCATE(G_P_ia(L_counter)%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (alpha_beta) THEN - CALL cp_dbcsr_release(G_P_ia_beta(L_counter)%matrix,error=error) + CALL cp_dbcsr_release(G_P_ia_beta(L_counter)%matrix) DEALLOCATE(G_P_ia_beta(L_counter)%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle3) @@ -674,25 +668,24 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c CALL calculate_wavefunction(mo_coeff,1,psi_L,rho_g, atomic_kind_set, & qs_kind_set,cell,dft_control,particle_set,pw_env_sub,& basis_type="RI_AUX",& - external_vector=wf_vector,& - error=error) + external_vector=wf_vector) ! transfer to reciprocal space and calculate potential rho_r%pw%cr3d = psi_L%pw%cr3d - CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) + CALL pw_transfer(rho_r%pw, rho_g%pw) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) ! update virial with volume term (first calculate hartree like energy (diagonal part of the virial)) e_hartree=0.0_dp h_stress=0.0_dp - e_hartree=pw_integral_ab(temp_pw_g%pw, pot_g%pw, error=error) + e_hartree=pw_integral_ab(temp_pw_g%pw, pot_g%pw) DO alpha=1, 3 comp=0 comp(alpha)=1 - CALL pw_copy(pot_g%pw, rho_g%pw, error=error) - CALL pw_derive(rho_g%pw, comp, error=error) + CALL pw_copy(pot_g%pw, rho_g%pw) + CALL pw_derive(rho_g%pw, comp) h_stress(alpha,alpha)=-e_hartree DO beta=alpha, 3 h_stress(alpha,beta)=h_stress(alpha,beta) & - -2.0_dp*pw_integral_ab(rho_g%pw, dvg(beta)%pw, error=error)/fourpi + -2.0_dp*pw_integral_ab(rho_g%pw, dvg(beta)%pw)/fourpi h_stress (beta,alpha)=h_stress(alpha,beta) END DO END DO @@ -708,13 +701,13 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c total_rho=total_rho,& task_list_external=task_list_sub,& pw_env_external=pw_env_sub,& - ks_env=ks_env,error=error) + ks_env=ks_env) ! calculate associated hartree potential - ! CALL pw_transfer(rho_r%pw, rho_g%pw, error=error) + ! CALL pw_transfer(rho_r%pw, rho_g%pw) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw,error=error) - CALL pw_transfer(pot_g%pw, rho_r%pw, error=error) - CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol, error=error) + CALL pw_poisson_solve(poisson_env,rho_g%pw, pair_energy, pot_g%pw) + CALL pw_transfer(pot_g%pw, rho_r%pw) + CALL pw_scale(rho_r%pw,rho_r%pw%pw_grid%dvol) CALL timestop(handle3) IF(use_virial) THEN @@ -723,16 +716,16 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c CALL timeset(routineN//"_Virial",handle3) e_hartree=0.0_dp h_stress=0.0_dp - e_hartree=pw_integral_ab(temp_pw_g%pw, pot_g%pw, error=error) + e_hartree=pw_integral_ab(temp_pw_g%pw, pot_g%pw) DO alpha=1, 3 comp=0 comp(alpha)=1 - CALL pw_copy(pot_g%pw, rho_g%pw, error=error) - CALL pw_derive(rho_g%pw, comp, error=error) + CALL pw_copy(pot_g%pw, rho_g%pw) + CALL pw_derive(rho_g%pw, comp) h_stress(alpha,alpha)=-e_hartree DO beta=alpha, 3 h_stress(alpha,beta)=h_stress(alpha,beta) & - -2.0_dp*pw_integral_ab(rho_g%pw, dvg(beta)%pw, error=error)/fourpi + -2.0_dp*pw_integral_ab(rho_g%pw, dvg(beta)%pw)/fourpi h_stress (beta,alpha)=h_stress(alpha,beta) END DO END DO @@ -743,18 +736,18 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c ! integrate potential with auxiliary basis function derivatives NULLIFY(rs_v) NULLIFY(rs_descs) - CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v, error=error) + CALL pw_env_get(pw_env_sub, rs_descs=rs_descs, rs_grids=rs_v) DO i=1,SIZE(rs_v) - CALL rs_grid_retain(rs_v(i)%rs_grid,error=error) + CALL rs_grid_retain(rs_v(i)%rs_grid) END DO - CALL potential_pw2rs(rs_v,rho_r,pw_env_sub,error) + CALL potential_pw2rs(rs_v,rho_r,pw_env_sub) offset=0 DO iatom=1, natom ikind=kind_of(iatom) atom_a = atom_of_kind(iatom) CALL get_qs_kind(qs_kind=qs_kind_set(ikind),basis_set=basis_set_a,& - basis_type="RI_AUX",error=error) + basis_type="RI_AUX") first_sgfa => basis_set_a%first_sgf la_max => basis_set_a%lmax @@ -860,8 +853,7 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c eps_gvg_rspace=dft_control%qs_control%eps_gvg_rspace,& calculate_forces=.TRUE.,& force_a=force_a, force_b=force_b, & - use_virial=use_virial,my_virial_a=my_virial_a,my_virial_b=my_virial_b,& - error=error) + use_virial=use_virial,my_virial_a=my_virial_a,my_virial_b=my_virial_b) END DO @@ -885,54 +877,54 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c END DO DO i=1,SIZE(rs_v) - CALL rs_grid_release(rs_v(i)%rs_grid, error=error) + CALL rs_grid_release(rs_v(i)%rs_grid) END DO END DO CALL timestop(handle2) DEALLOCATE(G_PQ_local,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wf_vector,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_L%pw,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_L%pw) IF (alpha_beta) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_L_beta%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,psi_L_beta%pw) ENDIF IF(use_virial) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,temp_pw_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,temp_pw_g%pw) DO i=1, 3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,dvg(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dvg(i)%pw) END DO END IF - CALL cp_dbcsr_release(matrix_P_inu%matrix,error=error) + CALL cp_dbcsr_release(matrix_P_inu%matrix) DEALLOCATE(matrix_P_inu%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_release(matrix_P_munu_nosym%matrix,error=error) + CALL cp_dbcsr_release(matrix_P_munu_nosym%matrix) DEALLOCATE(matrix_P_munu_nosym%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_release(matrix_P_munu%matrix,error=error) + CALL cp_dbcsr_release(matrix_P_munu%matrix) DEALLOCATE(matrix_P_munu%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! release the full gamma_P_ia structure DEALLOCATE(G_P_ia,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Release G_P_ia_beta and and matrix_P_inu_beta IF (alpha_beta) THEN - CALL cp_dbcsr_release(matrix_P_inu_beta%matrix,error=error) + CALL cp_dbcsr_release(matrix_P_inu_beta%matrix) DEALLOCATE(matrix_P_inu_beta%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(G_P_ia_beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(kind_of) @@ -950,29 +942,29 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c ! Start with moving from the DBCSR to FM for the lagrangians NULLIFY(L1_mu_i, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env_sub,context=blacs_env_sub, & - nrow_global=dimen,ncol_global=homo,error=error) - CALL cp_fm_create(L1_mu_i, fm_struct_tmp,name="Lag_mu_i",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(L1_mu_i,0.0_dp,error=error) - CALL copy_dbcsr_to_fm(matrix=Lag_mu_i_1%matrix, fm=L1_mu_i, error=error) + nrow_global=dimen,ncol_global=homo) + CALL cp_fm_create(L1_mu_i, fm_struct_tmp,name="Lag_mu_i") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(L1_mu_i,0.0_dp) + CALL copy_dbcsr_to_fm(matrix=Lag_mu_i_1%matrix, fm=L1_mu_i) ! release Lag_mu_i_1 - CALL cp_dbcsr_release(Lag_mu_i_1%matrix,error=error) + CALL cp_dbcsr_release(Lag_mu_i_1%matrix) DEALLOCATE(Lag_mu_i_1%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(L2_nu_a, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env_sub,context=blacs_env_sub, & - nrow_global=dimen,ncol_global=virtual,error=error) - CALL cp_fm_create(L2_nu_a, fm_struct_tmp,name="Lag_nu_a",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(L2_nu_a,0.0_dp,error=error) - CALL copy_dbcsr_to_fm(matrix=Lag_nu_a_2%matrix, fm=L2_nu_a, error=error) + nrow_global=dimen,ncol_global=virtual) + CALL cp_fm_create(L2_nu_a, fm_struct_tmp,name="Lag_nu_a") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(L2_nu_a,0.0_dp) + CALL copy_dbcsr_to_fm(matrix=Lag_nu_a_2%matrix, fm=L2_nu_a) ! release Lag_nu_a_2 - CALL cp_dbcsr_release(Lag_nu_a_2%matrix,error=error) + CALL cp_dbcsr_release(Lag_nu_a_2%matrix) DEALLOCATE(Lag_nu_a_2%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! The same for the beta Lagrangians IF (alpha_beta) THEN @@ -981,29 +973,29 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c ! Start with moving from the DBCSR to FM for the lagrangians NULLIFY(L1_mu_i_beta, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env_sub,context=blacs_env_sub, & - nrow_global=dimen,ncol_global=homo_beta,error=error) - CALL cp_fm_create(L1_mu_i_beta, fm_struct_tmp,name="Lag_mu_i_beta",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(L1_mu_i_beta,0.0_dp,error=error) - CALL copy_dbcsr_to_fm(matrix=Lag_mu_i_1_beta%matrix, fm=L1_mu_i_beta, error=error) + nrow_global=dimen,ncol_global=homo_beta) + CALL cp_fm_create(L1_mu_i_beta, fm_struct_tmp,name="Lag_mu_i_beta") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(L1_mu_i_beta,0.0_dp) + CALL copy_dbcsr_to_fm(matrix=Lag_mu_i_1_beta%matrix, fm=L1_mu_i_beta) ! release Lag_mu_i_1 - CALL cp_dbcsr_release(Lag_mu_i_1_beta%matrix,error=error) + CALL cp_dbcsr_release(Lag_mu_i_1_beta%matrix) DEALLOCATE(Lag_mu_i_1_beta%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(L2_nu_a_beta, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env_sub,context=blacs_env_sub, & - nrow_global=dimen,ncol_global=virtual_beta,error=error) - CALL cp_fm_create(L2_nu_a_beta, fm_struct_tmp,name="Lag_nu_a_beta",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(L2_nu_a_beta,0.0_dp,error=error) - CALL copy_dbcsr_to_fm(matrix=Lag_nu_a_2_beta%matrix, fm=L2_nu_a_beta, error=error) + nrow_global=dimen,ncol_global=virtual_beta) + CALL cp_fm_create(L2_nu_a_beta, fm_struct_tmp,name="Lag_nu_a_beta") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(L2_nu_a_beta,0.0_dp) + CALL copy_dbcsr_to_fm(matrix=Lag_nu_a_2_beta%matrix, fm=L2_nu_a_beta) ! release Lag_nu_a_2 - CALL cp_dbcsr_release(Lag_nu_a_2_beta%matrix,error=error) + CALL cp_dbcsr_release(Lag_nu_a_2_beta%matrix) DEALLOCATE(Lag_nu_a_2_beta%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ! Set the factor to multiply P_ij (depends on the open or closed shell) @@ -1011,12 +1003,12 @@ SUBROUTINE calc_ri_mp2_nonsep(qs_env,mp2_env,para_env,para_env_sub,dft_control,c IF (alpha_beta) factor = 0.50_dp CALL create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_env_sub,& - Eigenval,L1_mu_i,L2_nu_a,error,factor,.FALSE.) + Eigenval,L1_mu_i,L2_nu_a,factor,.FALSE.) ! Alpha_beta_case IF (alpha_beta) THEN CALL create_W_P(qs_env,mp2_env,mo_coeff_beta,homo_beta,virtual_beta,dimen,para_env, & para_env_sub,Eigenval_beta,L1_mu_i_beta,L2_nu_a_beta, & - error,factor,.TRUE.) + factor,.TRUE.) ENDIF CALL timestop(handle) @@ -1036,12 +1028,11 @@ END SUBROUTINE calc_ri_mp2_nonsep !> \param Eigenval ... !> \param L1_mu_i ... !> \param L2_nu_a ... -!> \param error ... !> \param factor ... !> \param alpha_beta ... ! ***************************************************************************** SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_env_sub,& - Eigenval,L1_mu_i,L2_nu_a,error,factor,alpha_beta) + Eigenval,L1_mu_i,L2_nu_a,factor,alpha_beta) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mp2_type), POINTER :: mp2_env TYPE(cp_fm_type), POINTER :: mo_coeff @@ -1049,7 +1040,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e TYPE(cp_para_env_type), POINTER :: para_env, para_env_sub REAL(KIND=dp), DIMENSION(:) :: Eigenval TYPE(cp_fm_type), POINTER :: L1_mu_i, L2_nu_a - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: factor LOGICAL :: alpha_beta @@ -1098,24 +1088,24 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! create the globally distributed mixed lagrangian NULLIFY(blacs_env) - CALL get_qs_env(qs_env, blacs_env=blacs_env, error=error) + CALL get_qs_env(qs_env, blacs_env=blacs_env) NULLIFY(L_mu_q, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=dimen,error=error) - CALL cp_fm_create(L_mu_q, fm_struct_tmp, name="Lag_mu_q",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(L_mu_q, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=dimen) + CALL cp_fm_create(L_mu_q, fm_struct_tmp, name="Lag_mu_q") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(L_mu_q, 0.0_dp) ! create all information array ALLOCATE(pos_info(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pos_info=0 pos_info(para_env%mepos)=para_env_sub%mepos CALL mp_sum(pos_info,para_env%group) ALLOCATE(sub_proc_map(-para_env_sub%num_pe:2*para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sub_proc_map=0 DO i=0,para_env_sub%num_pe-1 sub_proc_map(i)=i @@ -1130,15 +1120,14 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e row_indices=row_indices,& col_indices=col_indices,& nrow_block=nrow_block,& - ncol_block=ncol_block,& - error=error) + ncol_block=ncol_block) myprow=L_mu_q%matrix_struct%context%mepos(1) mypcol=L_mu_q%matrix_struct%context%mepos(2) nprow =L_mu_q%matrix_struct%context%num_pe(1) npcol =L_mu_q%matrix_struct%context%num_pe(2) ALLOCATE(grid_2_mepos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_2_mepos=0 grid_2_mepos(myprow,mypcol)=para_env%mepos CALL mp_sum(grid_2_mepos,para_env%group) @@ -1150,22 +1139,21 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e row_indices=row_indices_1i,& col_indices=col_indices_1i,& nrow_block=nrow_block_1i,& - ncol_block=ncol_block_1i,& - error=error) + ncol_block=ncol_block_1i) myprow_1i=L1_mu_i%matrix_struct%context%mepos(1) mypcol_1i=L1_mu_i%matrix_struct%context%mepos(2) nprow_1i =L1_mu_i%matrix_struct%context%num_pe(1) npcol_1i =L1_mu_i%matrix_struct%context%num_pe(2) ALLOCATE(mepos_2_grid_1i(0:para_env_sub%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid_1i=0 mepos_2_grid_1i(para_env_sub%mepos,1)=myprow_1i mepos_2_grid_1i(para_env_sub%mepos,2)=mypcol_1i CALL mp_sum(mepos_2_grid_1i,para_env_sub%group) ALLOCATE(sizes_1i(2,0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_1i=0 sizes_1i(1,para_env_sub%mepos)=nrow_local_1i sizes_1i(2,para_env_sub%mepos)=ncol_local_1i @@ -1178,22 +1166,21 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e row_indices=row_indices_2a,& col_indices=col_indices_2a,& nrow_block=nrow_block_2a,& - ncol_block=ncol_block_2a,& - error=error) + ncol_block=ncol_block_2a) myprow_2a=L2_nu_a%matrix_struct%context%mepos(1) mypcol_2a=L2_nu_a%matrix_struct%context%mepos(2) nprow_2a =L2_nu_a%matrix_struct%context%num_pe(1) npcol_2a =L2_nu_a%matrix_struct%context%num_pe(2) ALLOCATE(mepos_2_grid_2a(0:para_env_sub%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid_2a=0 mepos_2_grid_2a(para_env_sub%mepos,1)=myprow_2a mepos_2_grid_2a(para_env_sub%mepos,2)=mypcol_2a CALL mp_sum(mepos_2_grid_2a,para_env_sub%group) ALLOCATE(sizes_2a(2,0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_2a=0 sizes_2a(1,para_env_sub%mepos)=nrow_local_2a sizes_2a(2,para_env_sub%mepos)=ncol_local_2a @@ -1211,7 +1198,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e color_exchange=para_env_sub%mepos CALL mp_comm_split_direct(para_env%group,comm_exchange,color_exchange) NULLIFY(para_env_exchange) - CALL cp_para_env_create(para_env_exchange,comm_exchange,error=error) + CALL cp_para_env_create(para_env_exchange,comm_exchange) ! crate the proc maps exchange and info ALLOCATE(proc_map_ex(-para_env_exchange%num_pe:2*para_env_exchange%num_pe-1)) DO i=0,para_env_exchange%num_pe-1 @@ -1220,12 +1207,12 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e proc_map_ex(para_env_exchange%num_pe+i)=i END DO ALLOCATE(pos_info_ex(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pos_info_ex=0 pos_info_ex(para_env%mepos)=para_env_exchange%mepos CALL mp_sum(pos_info_ex,para_env%group) ALLOCATE(sizes(2,0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes=0 sizes(1,para_env_exchange%mepos)=nrow_local sizes(2,para_env_exchange%mepos)=ncol_local @@ -1237,9 +1224,9 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e max_row_size=MAXVAL(sizes_1i(1,:)) max_col_size=MAXVAL(sizes_1i(2,:)) ALLOCATE(row_indeces_info_1i(2,max_row_size,0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(col_indeces_info_1i(2,max_col_size,0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indeces_info_1i=0 col_indeces_info_1i=0 ! row @@ -1269,9 +1256,9 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e max_row_size=MAXVAL(sizes_2a(1,:)) max_col_size=MAXVAL(sizes_2a(2,:)) ALLOCATE(row_indeces_info_2a(2,max_row_size,0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(col_indeces_info_2a(2,max_col_size,0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) row_indeces_info_2a=0 col_indeces_info_2a=0 ! row @@ -1301,7 +1288,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! 1) define the map for sending data in the subgroup starting with L1_mu_i CALL timeset(routineN//"_subinfo",handle2) ALLOCATE(map_send_size(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_send_size=0 DO jjB=1, ncol_local_1i ! j_global=col_indices_1i(jjB) @@ -1336,7 +1323,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e END DO ! and exchange data in order to create map_rec_size ALLOCATE(map_rec_size(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_rec_size=0 CALL mp_alltoall(map_send_size,map_rec_size,1,para_env_sub%group) CALL timestop(handle2) @@ -1353,10 +1340,10 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e END DO ! allocate the structure that will hold the messages to be sent ALLOCATE(buffer_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_counter=0 ALLOCATE(proc_2_send_pos(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) proc_2_send_pos=0 DO proc_shift=0, para_env_sub%num_pe-1 proc_send=sub_proc_map(para_env_sub%mepos+proc_shift) @@ -1365,7 +1352,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e send_counter=send_counter+1 ! allocate the sending buffer (msg) ALLOCATE(buffer_send(send_counter)%msg(size_send_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_send(send_counter)%msg=0.0_dp buffer_send(send_counter)%proc=proc_send proc_2_send_pos(proc_send)=send_counter @@ -1375,7 +1362,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! for doing that we need an array that keep track if the ! sequential increase of the index for each message ALLOCATE(iii_vet(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iii_vet=0 DO jjB=1, ncol_local_1i ! j_global=col_indices_1i(jjB) @@ -1397,7 +1384,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e END DO ! release the local data of L1_mu_i DEALLOCATE(L1_mu_i%local_data,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! and the same for L2_nu_a DO jjB=1, ncol_local_2a ! j_global=col_indices_2a(jjB)+homo @@ -1418,7 +1405,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e END DO END DO DEALLOCATE(L2_nu_a%local_data,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(proc_2_send_pos) DEALLOCATE(iii_vet) CALL timestop(handle2) @@ -1435,7 +1422,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e END IF END DO ALLOCATE(buffer_rec(number_of_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_counter=0 DO proc_shift=0, para_env_sub%num_pe-1 proc_receive=sub_proc_map(para_env_sub%mepos-proc_shift) @@ -1444,7 +1431,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e rec_counter=rec_counter+1 ! prepare the buffer for receive ALLOCATE(buffer_rec(rec_counter)%msg(size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_rec(rec_counter)%msg=0.0_dp buffer_rec(rec_counter)%proc=proc_receive ! post the message to be received (not need to send to myself) @@ -1456,7 +1443,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e END DO ! send messages ALLOCATE(req_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) req_send=mp_request_null send_counter=0 DO proc_shift=0, para_env_sub%num_pe-1 @@ -1482,12 +1469,12 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e CALL timeset(routineN//"_Bcyclic",handle2) ! first allocata new structure ALLOCATE(buffer_cyclic(0:para_env_exchange%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iproc=0, para_env_exchange%num_pe-1 rec_row_size=sizes(1,iproc) rec_col_size=sizes(2,iproc) ALLOCATE(buffer_cyclic(iproc)%msg(rec_row_size,rec_col_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_cyclic(iproc)%msg=0.0_dp END DO ! now collect data from other member of the subgroup and fill @@ -1588,9 +1575,9 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e max_row_size=MAXVAL(sizes(1,:)) max_col_size=MAXVAL(sizes(2,:)) ALLOCATE(mat_send(max_row_size,max_col_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mat_rec(max_row_size,max_col_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mat_send=0.0_dp mat_send(1:nrow_local,1:ncol_local)=buffer_cyclic(para_env_exchange%mepos)%msg(:,:) DEALLOCATE(buffer_cyclic(para_env_exchange%mepos)%msg) @@ -1624,10 +1611,10 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e DEALLOCATE(proc_map_ex) ! release para_env_exchange - CALL cp_para_env_release(para_env_exchange,error=error) + CALL cp_para_env_release(para_env_exchange) - CALL cp_fm_release(L1_mu_i,error=error) - CALL cp_fm_release(L2_nu_a,error=error) + CALL cp_fm_release(L1_mu_i) + CALL cp_fm_release(L2_nu_a) DEALLOCATE(pos_info_ex) DEALLOCATE(grid_2_mepos) DEALLOCATE(mepos_2_grid_1i) @@ -1641,14 +1628,13 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e CALL timeset(routineN//"_Pij",handle2) NULLIFY(fm_P_ij, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo,ncol_global=homo,error=error) - CALL cp_fm_create(fm_P_ij, fm_struct_tmp, name="fm_P_ij",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(fm_P_ij, 0.0_dp,error=error) + nrow_global=homo,ncol_global=homo) + CALL cp_fm_create(fm_P_ij, fm_struct_tmp, name="fm_P_ij") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(fm_P_ij, 0.0_dp) CALL cp_gemm('T','N',homo,homo,dimen,1.0_dp,& mo_coeff,L_mu_q,0.0_dp,fm_P_ij,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1658,7 +1644,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! or just recompute the transposed matrix CALL cp_gemm('T','N',homo,homo,dimen,-2.0_dp,& L_mu_q,mo_coeff,2.0_dp,fm_P_ij,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1669,8 +1654,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -1689,7 +1673,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e END DO END DO ! release fm_P_ij - CALL cp_fm_release(fm_P_ij,error=error) + CALL cp_fm_release(fm_P_ij) ! mp_sum it (we can avoid mp_sum, but for now let's keep it easy) IF (.NOT. alpha_beta) THEN CALL mp_sum(mp2_env%ri_grad%P_ij,para_env%group) @@ -1704,16 +1688,16 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e CALL timeset(routineN//"_PMO",handle2) NULLIFY(mp2_env%ri_grad%P_mo, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=dimen,error=error) - CALL cp_fm_create(mp2_env%ri_grad%P_mo, fm_struct_tmp, name="P_MP2_MO",error=error) - CALL cp_fm_set_all(mp2_env%ri_grad%P_mo, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=dimen) + CALL cp_fm_create(mp2_env%ri_grad%P_mo, fm_struct_tmp, name="P_MP2_MO") + CALL cp_fm_set_all(mp2_env%ri_grad%P_mo, 0.0_dp) ELSE CALL timeset(routineN//"_PMO",handle2) NULLIFY(mp2_env%ri_grad%P_mo_beta, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=dimen,ncol_global=dimen,error=error) - CALL cp_fm_create(mp2_env%ri_grad%P_mo_beta, fm_struct_tmp, name="P_MP2_MO",error=error) - CALL cp_fm_set_all(mp2_env%ri_grad%P_mo_beta, 0.0_dp,error=error) + nrow_global=dimen,ncol_global=dimen) + CALL cp_fm_create(mp2_env%ri_grad%P_mo_beta, fm_struct_tmp, name="P_MP2_MO") + CALL cp_fm_set_all(mp2_env%ri_grad%P_mo_beta, 0.0_dp) ENDIF ! start with the (easy) occ-occ block and locally held P_ab elements @@ -1728,8 +1712,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e row_indices=row_indices,& col_indices=col_indices,& nrow_block=nrow_block,& - ncol_block=ncol_block,& - error=error) + ncol_block=ncol_block) myprow=mp2_env%ri_grad%P_mo%matrix_struct%context%mepos(1) mypcol=mp2_env%ri_grad%P_mo%matrix_struct%context%mepos(2) nprow =mp2_env%ri_grad%P_mo%matrix_struct%context%num_pe(1) @@ -1741,8 +1724,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e row_indices=row_indices,& col_indices=col_indices,& nrow_block=nrow_block,& - ncol_block=ncol_block,& - error=error) + ncol_block=ncol_block) myprow=mp2_env%ri_grad%P_mo_beta%matrix_struct%context%mepos(1) mypcol=mp2_env%ri_grad%P_mo_beta%matrix_struct%context%mepos(2) nprow =mp2_env%ri_grad%P_mo_beta%matrix_struct%context%num_pe(1) @@ -1775,30 +1757,30 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! deallocate the local P_ij IF (.NOT. alpha_beta) THEN DEALLOCATE(mp2_env%ri_grad%P_ij,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE DEALLOCATE(mp2_env%ri_grad%P_ij_beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ! send around the sub_group the local data and check if we ! have to update our block with external elements ALLOCATE(mepos_2_grid(0:para_env_sub%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid=0 mepos_2_grid(para_env_sub%mepos,1)=myprow mepos_2_grid(para_env_sub%mepos,2)=mypcol CALL mp_sum(mepos_2_grid,para_env_sub%group) ALLOCATE(sizes(2,0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes=0 sizes(1,para_env_sub%mepos)=nrow_local sizes(2,para_env_sub%mepos)=ncol_local CALL mp_sum(sizes,para_env_sub%group) ALLOCATE(ab_rec(nrow_local,ncol_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO proc_shift=1, para_env_sub%num_pe-1 proc_send=sub_proc_map(para_env_sub%mepos+proc_shift) proc_receive=sub_proc_map(para_env_sub%mepos-proc_shift) @@ -1810,7 +1792,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e send_col_size=sizes(2,proc_send) ALLOCATE(ab_send(send_row_size,send_col_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ab_send=0.0_dp ! first loop over row since in this way we can cycle @@ -1861,10 +1843,10 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! deallocate the local P_ab' IF (.NOT. alpha_beta) THEN DEALLOCATE(mp2_env%ri_grad%P_ab,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE DEALLOCATE(mp2_env%ri_grad%P_ab_beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle2) @@ -1872,14 +1854,13 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e CALL timeset(routineN//"_WMO",handle2) IF (.NOT. alpha_beta) THEN NULLIFY(mp2_env%ri_grad%W_mo) - CALL cp_fm_create(mp2_env%ri_grad%W_mo, fm_struct_tmp, name="W_MP2_MO",error=error) - CALL cp_fm_set_all(mp2_env%ri_grad%W_mo, 0.0_dp,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(mp2_env%ri_grad%W_mo, fm_struct_tmp, name="W_MP2_MO") + CALL cp_fm_set_all(mp2_env%ri_grad%W_mo, 0.0_dp) + CALL cp_fm_struct_release(fm_struct_tmp) ! all block CALL cp_gemm('T','N',dimen,dimen,dimen,2.0_dp*factor,& L_mu_q,mo_coeff,0.0_dp,mp2_env%ri_grad%W_mo,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1889,7 +1870,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! occ-occ block CALL cp_gemm('T','N',homo,homo,dimen,-2.0_dp*factor,& L_mu_q,mo_coeff,0.0_dp,mp2_env%ri_grad%W_mo,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1899,7 +1879,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! occ-virt block CALL cp_gemm('T','N',homo,virtual,dimen,2.0_dp*factor,& mo_coeff,L_mu_q,0.0_dp,mp2_env%ri_grad%W_mo,& - error=error,& a_first_row=1,& b_first_col=homo+1,& b_first_row=1,& @@ -1907,14 +1886,13 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e c_first_row=1) ELSE NULLIFY(mp2_env%ri_grad%W_mo_beta) - CALL cp_fm_create(mp2_env%ri_grad%W_mo_beta, fm_struct_tmp, name="W_MP2_MO",error=error) - CALL cp_fm_set_all(mp2_env%ri_grad%W_mo_beta, 0.0_dp,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(mp2_env%ri_grad%W_mo_beta, fm_struct_tmp, name="W_MP2_MO") + CALL cp_fm_set_all(mp2_env%ri_grad%W_mo_beta, 0.0_dp) + CALL cp_fm_struct_release(fm_struct_tmp) ! all block CALL cp_gemm('T','N',dimen,dimen,dimen,2.0_dp*factor,& L_mu_q,mo_coeff,0.0_dp,mp2_env%ri_grad%W_mo_beta,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1924,7 +1902,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! occ-occ block CALL cp_gemm('T','N',homo,homo,dimen,-2.0_dp*factor,& L_mu_q,mo_coeff,0.0_dp,mp2_env%ri_grad%W_mo_beta,& - error=error,& a_first_row=1,& b_first_col=1,& b_first_row=1,& @@ -1934,7 +1911,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! occ-virt block CALL cp_gemm('T','N',homo,virtual,dimen,2.0_dp*factor,& mo_coeff,L_mu_q,0.0_dp,mp2_env%ri_grad%W_mo_beta,& - error=error,& a_first_row=1,& b_first_col=homo+1,& b_first_row=1,& @@ -1950,15 +1926,14 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e IF (.NOT. alpha_beta) THEN NULLIFY(mp2_env%ri_grad%L_jb, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo,ncol_global=virtual,error=error) - CALL cp_fm_create(mp2_env%ri_grad%L_jb, fm_struct_tmp, name="fm_L_jb",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(mp2_env%ri_grad%L_jb, 0.0_dp,error=error) + nrow_global=homo,ncol_global=virtual) + CALL cp_fm_create(mp2_env%ri_grad%L_jb, fm_struct_tmp, name="fm_L_jb") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(mp2_env%ri_grad%L_jb, 0.0_dp) ! first Virtual CALL cp_gemm('T','N',homo,virtual,dimen,2.0_dp*factor,& L_mu_q,mo_coeff,0.0_dp,mp2_env%ri_grad%L_jb,& - error=error,& a_first_row=1,& b_first_col=homo+1,& b_first_row=1,& @@ -1967,7 +1942,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! then occupied CALL cp_gemm('T','N',homo,virtual,dimen,2.0_dp*factor,& mo_coeff,L_mu_q,1.0_dp,mp2_env%ri_grad%L_jb,& - error=error,& a_first_row=1,& b_first_col=homo+1,& b_first_row=1,& @@ -1976,15 +1950,14 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ELSE NULLIFY(mp2_env%ri_grad%L_jb_beta, fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=homo,ncol_global=virtual,error=error) - CALL cp_fm_create(mp2_env%ri_grad%L_jb_beta, fm_struct_tmp, name="fm_L_jb",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_set_all(mp2_env%ri_grad%L_jb_beta, 0.0_dp,error=error) + nrow_global=homo,ncol_global=virtual) + CALL cp_fm_create(mp2_env%ri_grad%L_jb_beta, fm_struct_tmp, name="fm_L_jb") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_set_all(mp2_env%ri_grad%L_jb_beta, 0.0_dp) ! first Virtual CALL cp_gemm('T','N',homo,virtual,dimen,2.0_dp*factor,& L_mu_q,mo_coeff,0.0_dp,mp2_env%ri_grad%L_jb_beta,& - error=error,& a_first_row=1,& b_first_col=homo+1,& b_first_row=1,& @@ -1993,7 +1966,6 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e ! then occupied CALL cp_gemm('T','N',homo,virtual,dimen,2.0_dp*factor,& mo_coeff,L_mu_q,1.0_dp,mp2_env%ri_grad%L_jb_beta,& - error=error,& a_first_row=1,& b_first_col=homo+1,& b_first_row=1,& @@ -2001,7 +1973,7 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e c_first_row=1) ENDIF ! finally release L_mu_q - CALL cp_fm_release(L_mu_q,error=error) + CALL cp_fm_release(L_mu_q) CALL timestop(handle2) ! here we should be done next CPHF @@ -2014,15 +1986,13 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ELSE CALL cp_fm_get_info(matrix=mp2_env%ri_grad%L_jb_beta,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ENDIF DO jjB=1, ncol_local j_global=col_indices(jjB) @@ -2052,15 +2022,13 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ELSE CALL cp_fm_get_info(matrix=mp2_env%ri_grad%P_mo_beta,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ENDIF IF (.NOT. alpha_beta) THEN DO jjB=1, ncol_local @@ -2119,15 +2087,13 @@ SUBROUTINE create_W_P(qs_env,mp2_env,mo_coeff,homo,virtual,dimen,para_env,para_e nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ELSE CALL cp_fm_get_info(matrix=mp2_env%ri_grad%W_mo_beta,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ENDIF DO jjB=1, ncol_local diff --git a/src/mp2_ri_grad_util.F b/src/mp2_ri_grad_util.F index 421f8ff8e3..9e4e07f13e 100644 --- a/src/mp2_ri_grad_util.F +++ b/src/mp2_ri_grad_util.F @@ -83,7 +83,6 @@ MODULE mp2_ri_grad_util !> \param starts_array ... !> \param starts_B_virtual ... !> \param sub_proc_map ... -!> \param error ... !> \param alpha_case ... !> \author Mauro Del Ben ! ***************************************************************************** @@ -91,7 +90,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env my_group_L_size,my_group_L_start,my_group_L_end,& my_B_size,my_B_virtual_start,& ends_array,ends_B_virtual,sizes_array,sizes_B_virtual,starts_array,starts_B_virtual,& - sub_proc_map,error,alpha_case) + sub_proc_map,alpha_case) TYPE(mp2_type), POINTER :: mp2_env REAL(KIND=dp), ALLOCATABLE, & @@ -103,7 +102,6 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env INTEGER, ALLOCATABLE, DIMENSION(:) :: ends_array, ends_B_virtual, & sizes_array, sizes_B_virtual, starts_array, starts_B_virtual, & sub_proc_map - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: alpha_case CHARACTER(LEN=*), PARAMETER :: routineN = 'complete_gamma', & @@ -143,13 +141,13 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env ! now the data inside the group are divided into a ia x K matrix dimen_ia=homo*virtual ALLOCATE(sizes_ia(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_ia=0 ALLOCATE(starts_ia(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts_ia=0 ALLOCATE(ends_ia(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends_ia=0 DO iproc=0, para_env_sub%num_pe-1 @@ -165,7 +163,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env ! reorder data (first (ia|K)) ALLOCATE(BIb_C_2D(my_ia_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_2D=0.0_dp DO iiB=1, homo @@ -186,7 +184,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env rec_B_virtual_start=starts_B_virtual(proc_receive) ALLOCATE(BIb_C_rec(homo,rec_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_rec=0.0_dp CALL mp_sendrecv(B_ia_Q,proc_send,& @@ -208,7 +206,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env ! reorder data (Gamma) ALLOCATE(Gamma_2D(my_ia_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Gamma_2D=0.0_dp DO iiB=1, homo @@ -236,7 +234,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env rec_B_virtual_start=starts_B_virtual(proc_receive) ALLOCATE(BIb_C_rec(homo,rec_B_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_rec=0.0_dp IF (alpha_case) THEN @@ -268,29 +266,29 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env ! create the processor map and size arrays ALLOCATE(proc_map(-para_env%num_pe:2*para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) proc_map=0 ALLOCATE(sizes(2,0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes=0 ALLOCATE(starts(2,0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts=0 ALLOCATE(ends(2,0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends=0 ALLOCATE(pos_info(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pos_info=0 pos_info(para_env%mepos)=para_env_sub%mepos CALL mp_sum(pos_info,para_env%group) ALLOCATE(group_grid_2_mepos(0:para_env_sub%num_pe-1,0:ngroup-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) group_grid_2_mepos=0 ALLOCATE(mepos_2_grid_group(0:para_env%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid_group=0 DO i=0,para_env%num_pe-1 @@ -323,7 +321,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env ! create the blacs env NULLIFY(blacs_env) - CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env) ! create the fm matrix Gamma CALL array2fm(Gamma_2D,dimen_ia,dimen_RI,para_env,blacs_env,proc_map,& @@ -331,25 +329,25 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env my_group_L_start,my_group_L_end,& sizes,starts,ends,& group_grid_2_mepos,para_env_sub%num_pe,ngroup,& - fm_Y,error) + fm_Y) ! create the fm matrix B_ia_P CALL array2fm(BIb_C_2D,dimen_ia,dimen_RI,para_env,blacs_env,proc_map,& my_ia_start,my_ia_end,& my_group_L_start,my_group_L_end,& sizes,starts,ends,& group_grid_2_mepos,para_env_sub%num_pe,ngroup,& - fm_ia_P,error) + fm_ia_P) ! create PQ_half ! get the ranges and info for the (P|Q)^(-1/2) matrix ALLOCATE(sizes_P(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_P=0 ALLOCATE(starts_P(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts_P=0 ALLOCATE(ends_P(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends_P=0 DO iproc=0, para_env_sub%num_pe-1 itmp=get_limit(dimen_RI,para_env_sub%num_pe,iproc) @@ -382,24 +380,24 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env ! since we will need (P|Q)^(-1/2) in the future, make a copy IF (alpha_case) THEN ALLOCATE(mp2_env%ri_grad%Gamma_PQ(my_P_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%Gamma_PQ(:,:)=mp2_env%ri_grad%PQ_half CALL array2fm(mp2_env%ri_grad%Gamma_PQ,dimen_RI,dimen_RI,para_env,blacs_env,proc_map,& my_P_start,my_P_end,& my_group_L_start,my_group_L_end,& sizes,starts,ends,& group_grid_2_mepos,para_env_sub%num_pe,ngroup,& - PQ_half,error) + PQ_half) ELSE ALLOCATE(mp2_env%ri_grad%Gamma_PQ_beta(my_P_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mp2_env%ri_grad%Gamma_PQ_beta(:,:)=mp2_env%ri_grad%PQ_half CALL array2fm(mp2_env%ri_grad%Gamma_PQ_beta,dimen_RI,dimen_RI,para_env,blacs_env,proc_map,& my_P_start,my_P_end,& my_group_L_start,my_group_L_end,& sizes,starts,ends,& group_grid_2_mepos,para_env_sub%num_pe,ngroup,& - PQ_half,error) + PQ_half) ENDIF @@ -407,44 +405,44 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env NULLIFY(fm_Gamma) NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=dimen_ia,& - ncol_global=dimen_RI,para_env=para_env,error=error) + ncol_global=dimen_RI,para_env=para_env) ! for now we don't force the blocks ! CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=num_rows,& ! ncol_global=num_cols,para_env=para_env,& - ! nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.,error=error) - CALL cp_fm_create(fm_Gamma,fm_struct,name="fm_Gamma",error=error) - CALL cp_fm_set_all(matrix=fm_Gamma,alpha=0.0_dp,error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ! nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.) + CALL cp_fm_create(fm_Gamma,fm_struct,name="fm_Gamma") + CALL cp_fm_set_all(matrix=fm_Gamma,alpha=0.0_dp) + CALL cp_fm_struct_release(fm_struct) ! perform the matrix multiplication CALL cp_gemm(transa="N",transb="T", m=dimen_ia, n=dimen_RI, k=dimen_RI, alpha=1.0_dp,& matrix_a=fm_Y, matrix_b=PQ_half, beta=0.0_dp,& - matrix_c=fm_Gamma, error=error) + matrix_c=fm_Gamma) ! release the Y matrix - CALL cp_fm_release(fm_Y,error=error) + CALL cp_fm_release(fm_Y) ! complete gamma small (fm_Gamma_PQ) NULLIFY(fm_Gamma_PQ_temp) NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=dimen_RI,& - ncol_global=dimen_RI,para_env=para_env,error=error) + ncol_global=dimen_RI,para_env=para_env) ! create temp matrix - CALL cp_fm_create(fm_Gamma_PQ_temp,fm_struct,name="fm_Gamma_PQ_temp",error=error) - CALL cp_fm_set_all(matrix=fm_Gamma_PQ_temp,alpha=0.0_dp,error=error) + CALL cp_fm_create(fm_Gamma_PQ_temp,fm_struct,name="fm_Gamma_PQ_temp") + CALL cp_fm_set_all(matrix=fm_Gamma_PQ_temp,alpha=0.0_dp) CALL cp_gemm(transa="T",transb="N", m=dimen_RI, n=dimen_RI, k=dimen_ia, alpha=1.0_dp,& matrix_a=fm_Gamma, matrix_b=fm_ia_P, beta=0.0_dp,& - matrix_c=fm_Gamma_PQ_temp, error=error) - CALL cp_fm_release(fm_ia_P,error=error) + matrix_c=fm_Gamma_PQ_temp) + CALL cp_fm_release(fm_ia_P) ! create fm_Gamma_PQ matrix - CALL cp_fm_create(fm_Gamma_PQ,fm_struct,name="fm_Gamma_PQ",error=error) + CALL cp_fm_create(fm_Gamma_PQ,fm_struct,name="fm_Gamma_PQ") ! release the structure - CALL cp_fm_struct_release(fm_struct,error=error) - CALL cp_fm_set_all(matrix=fm_Gamma_PQ,alpha=0.0_dp,error=error) + CALL cp_fm_struct_release(fm_struct) + CALL cp_fm_set_all(matrix=fm_Gamma_PQ,alpha=0.0_dp) ! perfome matrix multiplication CALL cp_gemm(transa="N",transb="T", m=dimen_RI, n=dimen_RI, k=dimen_RI, alpha=1.0_dp,& matrix_a=fm_Gamma_PQ_temp, matrix_b=PQ_half, beta=0.0_dp,& - matrix_c=fm_Gamma_PQ, error=error) - CALL cp_fm_release(fm_Gamma_PQ_temp,error=error) - CALL cp_fm_release(PQ_half,error=error) + matrix_c=fm_Gamma_PQ) + CALL cp_fm_release(fm_Gamma_PQ_temp) + CALL cp_fm_release(PQ_half) IF(.FALSE.) THEN ALLOCATE(Gamma_2D(dimen_ia,dimen_RI)) @@ -453,8 +451,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -472,8 +469,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) DO jjB=1, ncol_local j_global=col_indices(jjB) DO iiB=1, nrow_local @@ -497,8 +493,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env ! END DO CALL cp_fm_get_info(matrix=fm_Gamma,& nrow_local=nrow_local,& - ncol_local=ncol_local,& - error=error) + ncol_local=ncol_local) sizes=0 sizes(1,para_env%mepos)=nrow_local sizes(2,para_env%mepos)=ncol_local @@ -511,13 +506,12 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env my_group_L_size,my_group_L_start,my_group_L_end,& sizes,group_grid_2_mepos,mepos_2_grid_group,& para_env_sub%num_pe,ngroup,& - fm_Gamma,error) + fm_Gamma) ! the same for the Gamma_PQ matrix CALL cp_fm_get_info(matrix=fm_Gamma_PQ,& nrow_local=nrow_local,& - ncol_local=ncol_local,& - error=error) + ncol_local=ncol_local) sizes=0 sizes(1,para_env%mepos)=nrow_local sizes(2,para_env%mepos)=ncol_local @@ -528,14 +522,14 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env my_group_L_size,my_group_L_start,my_group_L_end,& sizes,group_grid_2_mepos,mepos_2_grid_group,& para_env_sub%num_pe,ngroup,& - fm_Gamma_PQ,error) + fm_Gamma_PQ) ELSE CALL fm2array(mp2_env%ri_grad%Gamma_PQ_beta,dimen_RI,dimen_RI,para_env,proc_map,& my_P_size,my_P_start,my_P_end,& my_group_L_size,my_group_L_start,my_group_L_end,& sizes,group_grid_2_mepos,mepos_2_grid_group,& para_env_sub%num_pe,ngroup,& - fm_Gamma_PQ,error) + fm_Gamma_PQ) ENDIF IF(.FALSE.) THEN @@ -568,7 +562,7 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env CALL create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_proc_map,& my_ia_start,my_ia_end,my_group_L_size,& sizes_ia,starts_ia,ends_ia,& - mp2_env,error,alpha_case) + mp2_env,alpha_case) IF(.FALSE.) THEN @@ -619,11 +613,11 @@ SUBROUTINE complete_gamma(mp2_env,B_ia_Q,dimen_RI,homo,virtual,para_env,para_env DEALLOCATE(sizes,starts,ends) ! release fm_matrices - ! CALL cp_fm_release(fm_Gamma,error=error) - ! CALL cp_fm_release(fm_Gamma_PQ,error=error) + ! CALL cp_fm_release(fm_Gamma) + ! CALL cp_fm_release(fm_Gamma_PQ) ! release blacs_env - CALL cp_blacs_env_release(blacs_env,error=error) + CALL cp_blacs_env_release(blacs_env) CALL timestop(handle) @@ -648,14 +642,13 @@ END SUBROUTINE complete_gamma !> \param ngroup_row ... !> \param ngroup_col ... !> \param fm_mat ... -!> \param error ... ! ***************************************************************************** SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& my_start_row,my_end_row,& my_start_col,my_end_col,& sizes,starts,ends,& group_grid_2_mepos,ngroup_row,ngroup_col,& - fm_mat,error) + fm_mat) REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: mat2D @@ -669,7 +662,6 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& group_grid_2_mepos INTEGER :: ngroup_row, ngroup_col TYPE(cp_fm_type), POINTER :: fm_mat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'array2fm', & routineP = moduleN//':'//routineN @@ -703,14 +695,14 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& NULLIFY(fm_mat) NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=num_rows,& - ncol_global=num_cols,para_env=para_env,error=error) + ncol_global=num_cols,para_env=para_env) ! for now we don't force the blocks ! CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=num_rows,& ! ncol_global=num_cols,para_env=para_env,& - ! nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.,error=error) - CALL cp_fm_create(fm_mat,fm_struct,name="fm_mat",error=error) - CALL cp_fm_set_all(matrix=fm_mat,alpha=0.0_dp,error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + ! nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.) + CALL cp_fm_create(fm_mat,fm_struct,name="fm_mat") + CALL cp_fm_set_all(matrix=fm_mat,alpha=0.0_dp) + CALL cp_fm_struct_release(fm_struct) ! start filling procedure ! fill the matrix @@ -720,8 +712,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& row_indices=row_indices,& col_indices=col_indices,& nrow_block=nrow_block,& - ncol_block=ncol_block,& - error=error) + ncol_block=ncol_block) myprow=fm_mat%matrix_struct%context%mepos(1) mypcol=fm_mat%matrix_struct%context%mepos(2) nprow =fm_mat%matrix_struct%context%num_pe(1) @@ -732,10 +723,10 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& ! and supporting infos CALL timeset(routineN//"_info",handle2) ALLOCATE(grid_2_mepos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_2_mepos=0 ALLOCATE(mepos_2_grid(0:para_env%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid=0 ! fill the info array grid_2_mepos(myprow,mypcol)=para_env%mepos @@ -747,7 +738,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& ! 1) loop over my local data and define a map for the proc to send data ALLOCATE(map_send_size(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_send_size=0 DO jjB=my_start_col, my_end_col send_pcol=cp_fm_indxg2p(jjB,ncol_block,dummy_proc,& @@ -762,7 +753,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& ! 2) loop over my local data of fm_mat and define a map for the proc from which rec data ALLOCATE(map_rec_size(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_rec_size=0 part_row=FLOAT(num_rows)/FLOAT(ngroup_row) part_col=FLOAT(num_cols)/FLOAT(ngroup_col) @@ -830,12 +821,12 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& END DO ! allocate the structure that will hold the messages to be sent ALLOCATE(buffer_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! grid_ref_2_send_pos is an array (map) that given a pair ! (ref_send_prow,ref_send_pcol) returns ! the position in the buffer_send associated to that process ALLOCATE(grid_ref_2_send_pos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_ref_2_send_pos=0 ! finalize the allocation of buffer_send with the actual size ! of each message (actual size is size_send_buffer) @@ -847,7 +838,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& send_counter=send_counter+1 ! allocate the sending buffer (msg) ALLOCATE(buffer_send(send_counter)%msg(size_send_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_send(send_counter)%msg=0.0_dp buffer_send(send_counter)%proc=proc_send ! get the pointer to prow, pcol of the process that has @@ -863,7 +854,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& ! for doing that we need an array that keep track if the ! sequential increase of the index for each message ALLOCATE(iii_vet(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iii_vet=0 DO iiB=my_start_row, my_end_row send_prow=cp_fm_indxg2p(iiB,nrow_block,dummy_proc,& @@ -900,7 +891,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& END DO ALLOCATE(buffer_rec(number_of_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_counter=0 DO proc_shift=1, para_env%num_pe-1 @@ -910,7 +901,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& rec_counter=rec_counter+1 ! prepare the buffer for receive ALLOCATE(buffer_rec(rec_counter)%msg(size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_rec(rec_counter)%msg=0.0_dp buffer_rec(rec_counter)%proc=proc_receive ! post the message to be received @@ -921,7 +912,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& ! send messages ALLOCATE(req_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_counter=0 DO proc_shift=1, para_env%num_pe-1 proc_send=proc_map(para_env%mepos+proc_shift) @@ -946,7 +937,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& my_num_row_blocks=my_num_row_blocks+1 END DO ALLOCATE(blocks_ranges_row(2,my_num_row_blocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blocks_ranges_row=0 blocks_ranges_row(1,1)=row_indices(1) iii=1 @@ -964,7 +955,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& my_num_col_blocks=my_num_col_blocks+1 END DO ALLOCATE(blocks_ranges_col(2,my_num_col_blocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blocks_ranges_col=0 blocks_ranges_col(1,1)=col_indices(1) iii=1 @@ -998,7 +989,7 @@ SUBROUTINE array2fm(mat2D,num_rows,num_cols,para_env,blacs_env,proc_map,& END DO END DO ALLOCATE(index_col_rec(num_rec_cols),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) index_col_rec=0 iii=0 DO jjB=1, my_num_col_blocks @@ -1083,14 +1074,13 @@ END SUBROUTINE array2fm !> \param ngroup_row ... !> \param ngroup_col ... !> \param fm_mat ... -!> \param error ... ! ***************************************************************************** SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& my_rows,my_start_row,my_end_row,& my_cols,my_start_col,my_end_col,& sizes,group_grid_2_mepos,mepos_2_grid_group,& ngroup_row,ngroup_col,& - fm_mat,error) + fm_mat) REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: mat2D @@ -1104,7 +1094,6 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& mepos_2_grid_group INTEGER :: ngroup_row, ngroup_col TYPE(cp_fm_type), POINTER :: fm_mat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fm2array', & routineP = moduleN//':'//routineN @@ -1133,7 +1122,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& ! allocate the array ALLOCATE(mat2D(my_rows,my_cols),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mat2D=0.0_dp ! start procedure @@ -1144,8 +1133,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& row_indices=row_indices,& col_indices=col_indices,& nrow_block=nrow_block,& - ncol_block=ncol_block,& - error=error) + ncol_block=ncol_block) myprow=fm_mat%matrix_struct%context%mepos(1) mypcol=fm_mat%matrix_struct%context%mepos(2) nprow =fm_mat%matrix_struct%context%num_pe(1) @@ -1156,13 +1144,13 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& ! and supporting infos CALL timeset(routineN//"_info",handle2) ALLOCATE(grid_2_mepos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_2_mepos=0 ALLOCATE(mepos_2_grid(0:para_env%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid=0 ! ALLOCATE(mepos_2_grid_group(0:para_env%num_pe-1,2),STAT=stat) - ! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + ! CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! mepos_2_grid_group=0 ! fill the info array grid_2_mepos(myprow,mypcol)=para_env%mepos @@ -1175,7 +1163,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& ! 1) loop over my local data and define a map for the proc to send data ALLOCATE(map_send_size(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_send_size=0 part_row=FLOAT(num_rows)/FLOAT(ngroup_row) part_col=FLOAT(num_cols)/FLOAT(ngroup_col) @@ -1218,7 +1206,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& ! 2) loop over my local data of the array and define a map for the proc from which rec data ALLOCATE(map_rec_size(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_rec_size=0 DO jjB=my_start_col, my_end_col rec_pcol=cp_fm_indxg2p(jjB,ncol_block,dummy_proc,& @@ -1259,14 +1247,14 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& END DO ! allocate the structure that will hold the messages to be sent ALLOCATE(buffer_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! grid_ref_2_send_pos is an array (map) that given a pair ! (ref_send_prow,ref_send_pcol) returns ! the position in the buffer_send associated to that process ! ALLOCATE(grid_ref_2_send_pos(0:nprow-1,0:npcol-1),STAT=stat) ALLOCATE(grid_ref_2_send_pos(0:ngroup_row-1,0:ngroup_col-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_ref_2_send_pos=0 ! finalize the allocation of buffer_send with the actual size @@ -1279,7 +1267,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& send_counter=send_counter+1 ! allocate the sending buffer (msg) ALLOCATE(buffer_send(send_counter)%msg(size_send_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_send(send_counter)%msg=0.0_dp buffer_send(send_counter)%proc=proc_send ! get the pointer to prow, pcol of the process that has @@ -1295,7 +1283,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& ! for doing that we need an array that keep track if the ! sequential increase of the index for each message ALLOCATE(iii_vet(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iii_vet=0 DO jjB=1, ncol_local j_global=col_indices(jjB) @@ -1335,7 +1323,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& DEALLOCATE(iii_vet) DEALLOCATE(grid_ref_2_send_pos) - ! CALL cp_fm_release(fm_mat,error=error) + ! CALL cp_fm_release(fm_mat) CALL timestop(handle2) ! 5) similarly to what done for the buffer_send @@ -1352,7 +1340,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& END DO ALLOCATE(buffer_rec(number_of_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_counter=0 DO proc_shift=1, para_env%num_pe-1 @@ -1362,7 +1350,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& rec_counter=rec_counter+1 ! prepare the buffer for receive ALLOCATE(buffer_rec(rec_counter)%msg(size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_rec(rec_counter)%msg=0.0_dp buffer_rec(rec_counter)%proc=proc_receive ! post the message to be received @@ -1373,7 +1361,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& ! send messages ALLOCATE(req_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_counter=0 DO proc_shift=1, para_env%num_pe-1 proc_send=proc_map(para_env%mepos+proc_shift) @@ -1391,7 +1379,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& CALL timeset(routineN//"_fill",handle2) iiB=MAXVAL(sizes(1,:)) ALLOCATE(index_row_rec(iiB),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) index_row_rec=0 rec_counter=0 DO proc_shift=1, para_env%num_pe-1 @@ -1435,7 +1423,7 @@ SUBROUTINE fm2array(mat2D,num_rows,num_cols,para_env,proc_map,& END DO DEALLOCATE(buffer_rec) DEALLOCATE(index_row_rec) - CALL cp_fm_release(fm_mat,error=error) + CALL cp_fm_release(fm_mat) CALL timestop(handle2) ! 7) Finally wait for all messeges to be sent @@ -1466,13 +1454,12 @@ END SUBROUTINE fm2array !> \param starts_ia ... !> \param ends_ia ... !> \param mp2_env ... -!> \param error ... !> \param alpha_case ... ! ***************************************************************************** SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_proc_map,& my_ia_start,my_ia_end,my_group_L_size,& sizes_ia,starts_ia,ends_ia,& - mp2_env,error,alpha_case) + mp2_env,alpha_case) REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: Gamma_2D INTEGER :: homo, virtual, dimen_ia @@ -1482,7 +1469,6 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr my_group_L_size INTEGER, ALLOCATABLE, DIMENSION(:) :: sizes_ia, starts_ia, ends_ia TYPE(mp2_type), POINTER :: mp2_env - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: alpha_case CHARACTER(LEN=*), PARAMETER :: routineN = 'create_dbcsr_gamma', & @@ -1520,27 +1506,27 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr IF (alpha_case) THEN NULLIFY(mp2_env%ri_grad%G_P_ia) CALL cp_dbcsr_allocate_matrix_set(mp2_env%ri_grad%G_P_ia, & - my_group_L_size,error=error) + my_group_L_size) ELSE NULLIFY(mp2_env%ri_grad%G_P_ia_beta) CALL cp_dbcsr_allocate_matrix_set(mp2_env%ri_grad%G_P_ia_beta, & - my_group_L_size,error=error) + my_group_L_size) ENDIF ! create sub blacs env NULLIFY(blacs_env) - CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_sub, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_sub) ! create the fm_ia buffer matrix NULLIFY(fm_ia) NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=homo,& - ncol_global=virtual,para_env=para_env_sub,error=error) - CALL cp_fm_create(fm_ia,fm_struct,name="fm_ia",error=error) + ncol_global=virtual,para_env=para_env_sub) + CALL cp_fm_create(fm_ia,fm_struct,name="fm_ia") ! release structure - CALL cp_fm_struct_release(fm_struct,error=error) + CALL cp_fm_struct_release(fm_struct) ! release blacs_env - CALL cp_blacs_env_release(blacs_env,error=error) + CALL cp_blacs_env_release(blacs_env) ! get array information CALL cp_fm_get_info(matrix=fm_ia,& @@ -1549,8 +1535,7 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr row_indices=row_indices,& col_indices=col_indices,& nrow_block=nrow_block,& - ncol_block=ncol_block,& - error=error) + ncol_block=ncol_block) myprow=fm_ia%matrix_struct%context%mepos(1) mypcol=fm_ia%matrix_struct%context%mepos(2) nprow =fm_ia%matrix_struct%context%num_pe(1) @@ -1558,10 +1543,10 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr ! 0) create array containing the processes position and supporting infos ALLOCATE(grid_2_mepos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_2_mepos=0 ALLOCATE(mepos_2_grid(0:para_env_sub%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid=0 ! fill the info array grid_2_mepos(myprow,mypcol)=para_env_sub%mepos @@ -1573,7 +1558,7 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr ! loop over local index range and define the sending map ALLOCATE(map_send_size(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_send_size=0 DO iaia=my_ia_start, my_ia_end i_global=(iaia-1)/virtual+1 @@ -1588,7 +1573,7 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr ! loop over local data of fm_ia and define the receiving map ALLOCATE(map_rec_size(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_rec_size=0 part_ia=FLOAT(dimen_ia)/FLOAT(para_env_sub%num_pe) @@ -1620,10 +1605,10 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr END DO ! allocate the structure that will hold the messages to be sent ALLOCATE(buffer_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! and the map from the grid of processess to the message position ALLOCATE(grid_ref_2_send_pos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_ref_2_send_pos=0 ! finally allocate each message send_counter=0 @@ -1634,7 +1619,7 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr send_counter=send_counter+1 ! allocate the sending buffer (msg) ALLOCATE(buffer_send(send_counter)%msg(size_send_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_send(send_counter)%proc=proc_send ! get the pointer to prow, pcol of the process that has ! to receive this message @@ -1657,9 +1642,9 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr ! allocate the structure that will hold the messages to be received ! and relative indeces ALLOCATE(buffer_rec(number_of_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(indeces_rec(number_of_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! finally allocate each message and fill the array of indeces rec_counter=0 DO proc_shift=1, para_env_sub%num_pe-1 @@ -1669,11 +1654,11 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr rec_counter=rec_counter+1 ! prepare the buffer for receive ALLOCATE(buffer_rec(rec_counter)%msg(size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_rec(rec_counter)%proc=proc_receive ! create the indeces array ALLOCATE(indeces_rec(rec_counter)%map(2,size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) indeces_rec(rec_counter)%map=0 rec_iaia_start=starts_ia(proc_receive) rec_iaia_end=ends_ia(proc_receive) @@ -1701,7 +1686,7 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr IF(map_rec_size(para_env_sub%mepos)>0) THEN size_rec_buffer=map_rec_size(para_env_sub%mepos) ALLOCATE(indeces_map_my(2,size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) indeces_map_my=0 iii=0 DO iaia=my_ia_start, my_ia_end @@ -1724,15 +1709,15 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr ! auxiliary vector of indeces for the send buffer ALLOCATE(iii_vet(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! vector for the send requests ALLOCATE(req_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! loop over auxiliary basis function and redistribute into a fm ! and then compy the fm into a dbcsr matrix DO kkB=1, my_group_L_size ! zero the matries of the buffers and post the messages to be received - CALL cp_fm_set_all(matrix=fm_ia,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_ia,alpha=0.0_dp) rec_counter=0 DO proc_shift=1, para_env_sub%num_pe-1 proc_receive=sub_proc_map(para_env_sub%mepos-proc_shift) @@ -1806,18 +1791,18 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr ! now create the DBCSR matrix and copy fm_ia into it IF (alpha_case) THEN ALLOCATE(mp2_env%ri_grad%G_P_ia(kkB)%matrix) - CALL cp_dbcsr_init(mp2_env%ri_grad%G_P_ia(kkB)%matrix,error=error) + CALL cp_dbcsr_init(mp2_env%ri_grad%G_P_ia(kkB)%matrix) CALL cp_dbcsr_m_by_n_from_template(mp2_env%ri_grad%G_P_ia(kkB)%matrix, & template=mp2_env%ri_grad%mo_coeff_o,& - m=homo,n=virtual, sym=dbcsr_type_no_symmetry,error=error) - CALL copy_fm_to_dbcsr(fm_ia,mp2_env%ri_grad%G_P_ia(kkB)%matrix,keep_sparsity=.FALSE.,error=error) + m=homo,n=virtual, sym=dbcsr_type_no_symmetry) + CALL copy_fm_to_dbcsr(fm_ia,mp2_env%ri_grad%G_P_ia(kkB)%matrix,keep_sparsity=.FALSE.) ELSE ALLOCATE(mp2_env%ri_grad%G_P_ia_beta(kkB)%matrix) - CALL cp_dbcsr_init(mp2_env%ri_grad%G_P_ia_beta(kkB)%matrix,error=error) + CALL cp_dbcsr_init(mp2_env%ri_grad%G_P_ia_beta(kkB)%matrix) CALL cp_dbcsr_m_by_n_from_template(mp2_env%ri_grad%G_P_ia_beta(kkB)%matrix, & template=mp2_env%ri_grad%mo_coeff_o_beta,& - m=homo,n=virtual, sym=dbcsr_type_no_symmetry,error=error) - CALL copy_fm_to_dbcsr(fm_ia,mp2_env%ri_grad%G_P_ia_beta(kkB)%matrix,keep_sparsity=.FALSE.,error=error) + m=homo,n=virtual, sym=dbcsr_type_no_symmetry) + CALL copy_fm_to_dbcsr(fm_ia,mp2_env%ri_grad%G_P_ia_beta(kkB)%matrix,keep_sparsity=.FALSE.) ENDIF END DO @@ -1845,7 +1830,7 @@ SUBROUTINE create_dbcsr_gamma(Gamma_2D,homo,virtual,dimen_ia,para_env_sub,sub_pr DEALLOCATE(mepos_2_grid) ! release buffer matrix - CALL cp_fm_release(fm_ia,error=error) + CALL cp_fm_release(fm_ia) CALL timestop(handle) diff --git a/src/mp2_ri_libint.F b/src/mp2_ri_libint.F index a6cb6a4039..55f27dbac6 100644 --- a/src/mp2_ri_libint.F +++ b/src/mp2_ri_libint.F @@ -98,13 +98,12 @@ MODULE mp2_ri_libint !> \param qs_env ... !> \param para_env ... !> \param Lai ... -!> \param error ... ! ***************************************************************************** SUBROUTINE libint_ri_mp2(dimen,RI_dimen,occupied,natom,mp2_biel,mp2_env,C,& kind_of,& RI_basis_parameter,RI_basis_info,basis_S0,RI_index_table,& qs_env,para_env, & - Lai,error) + Lai) INTEGER :: dimen, RI_dimen, occupied, & natom TYPE(mp2_biel_type) :: mp2_biel @@ -121,7 +120,6 @@ SUBROUTINE libint_ri_mp2(dimen,RI_dimen,occupied,natom,mp2_biel,mp2_env,C,& TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :) :: Lai - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'libint_ri_mp2', & routineP = moduleN//':'//routineN @@ -138,13 +136,13 @@ SUBROUTINE libint_ri_mp2(dimen,RI_dimen,occupied,natom,mp2_biel,mp2_env,C,& IF(ASSOCIATED(basis_S0)) DEALLOCATE(basis_S0) CALL read_RI_basis_set(qs_env,RI_basis_parameter,RI_basis_info,& natom,nkind,kind_of,RI_index_table,RI_dimen,& - basis_S0,error) + basis_S0) END IF CALL calc_lai_libint(mp2_env,qs_env,para_env,& mp2_biel,dimen,C,occupied,& RI_basis_parameter,RI_basis_info,RI_index_table,RI_dimen,basis_S0,& - Lai,error) + Lai) CALL timestop(handle) @@ -161,14 +159,13 @@ END SUBROUTINE libint_ri_mp2 !> \param RI_index_table ... !> \param RI_dimen ... !> \param basis_S0 ... -!> \param error ... !> \par History !> 08.2013 created [Mauro Del Ben] !> \author Mauro Del Ben ! ***************************************************************************** SUBROUTINE read_RI_basis_set(qs_env,RI_basis_parameter,RI_basis_info,& natom,nkind,kind_of,RI_index_table,RI_dimen,& - basis_S0,error) + basis_S0) TYPE(qs_environment_type), POINTER :: qs_env TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: RI_basis_parameter @@ -179,7 +176,6 @@ SUBROUTINE read_RI_basis_set(qs_env,RI_basis_parameter,RI_basis_info,& INTEGER :: RI_dimen TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: basis_S0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_RI_basis_set', & routineP = moduleN//':'//routineN @@ -202,13 +198,13 @@ SUBROUTINE read_RI_basis_set(qs_env,RI_basis_parameter,RI_basis_info,& NULLIFY(RI_basis_parameter) NULLIFY(qs_kind_set) - CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set, error=error) + CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set) nkind = SIZE(qs_kind_set,1) ALLOCATE(RI_basis_parameter(nkind), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(basis_S0(nkind), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_set = 0 DO ikind = 1,nkind NULLIFY(atom_kind) @@ -216,19 +212,19 @@ SUBROUTINE read_RI_basis_set(qs_env,RI_basis_parameter,RI_basis_info,& ! here we reset the initial RI basis such that we can ! work with non-normalized auxiliary basis functions CALL get_qs_kind(qs_kind=atom_kind,& - basis_set=orb_basis_a,basis_type="RI_AUX",error=error) + basis_set=orb_basis_a,basis_type="RI_AUX") IF(.NOT.(ASSOCIATED(orb_basis_a))) THEN CALL stop_program(routineN,moduleN,__LINE__,"Initial RI auxiliary basis not specified.") END IF orb_basis_a%gcc=1.0_dp orb_basis_a%norm_type = 1 - CALL init_aux_basis_set(orb_basis_a,error) + CALL init_aux_basis_set(orb_basis_a) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxsgf=RI_basis_info%max_sgf,& maxnset=RI_basis_info%max_set,& maxlgto=RI_basis_info%max_am,& - basis_type="RI_AUX",error=error) + basis_type="RI_AUX") CALL get_gto_basis_set(gto_basis_set=orb_basis_a, & lmax=RI_basis_parameter(ikind)%lmax, & lmin=RI_basis_parameter(ikind)%lmin, & @@ -318,7 +314,7 @@ SUBROUTINE read_RI_basis_set(qs_env,RI_basis_parameter,RI_basis_info,& END DO END DO ALLOCATE(RI_basis_parameter(ikind)%sphi_ext(max_coeff,0:max_am_kind, max_pgf_kind, nseta), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RI_basis_parameter(ikind)%sphi_ext = 0.0_dp END DO @@ -373,15 +369,13 @@ END SUBROUTINE read_RI_basis_set !> only in the case of basis optimization) !> \param RI_basis_parameter ... !> \param basis_S0 ... -!> \param error ... !> \par History !> 08.2013 created [Mauro Del Ben] !> \author Mauro Del Ben ! ***************************************************************************** - SUBROUTINE release_RI_basis_set(RI_basis_parameter,basis_S0,error) + SUBROUTINE release_RI_basis_set(RI_basis_parameter,basis_S0) TYPE(hfx_basis_type), DIMENSION(:), & POINTER :: RI_basis_parameter, basis_S0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'release_RI_basis_set', & routineP = moduleN//':'//routineN @@ -394,44 +388,44 @@ SUBROUTINE release_RI_basis_set(RI_basis_parameter,basis_S0,error) ! RI basis DO i=1,SIZE(RI_basis_parameter) DEALLOCATE(RI_basis_parameter(i)%nsgfl,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(RI_basis_parameter(i)%sphi_ext,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(RI_basis_parameter,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! S0 basis DO i=1, SIZE(basis_S0) DEALLOCATE(basis_S0(i)%set_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%lmax,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%lmin,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%npgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%nsgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%nshell,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%pgf_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%sphi,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%zet,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%first_sgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%nl,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%nsgfl,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_S0(i)%sphi_ext,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(basis_S0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_RI_basis_set @@ -450,8 +444,6 @@ END SUBROUTINE release_RI_basis_set !> \param RI_dimen ... !> \param basis_S0 ... !> \param Lai ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2013 created [Mauro Del Ben] !> \author Mauro Del Ben @@ -459,7 +451,7 @@ END SUBROUTINE release_RI_basis_set SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& mp2_biel,dimen,C,occupied,& RI_basis_parameter,RI_basis_info,RI_index_table,RI_dimen,basis_S0,& - Lai,error) + Lai) TYPE(mp2_type), POINTER :: mp2_env TYPE(qs_environment_type), POINTER :: qs_env @@ -477,7 +469,6 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& POINTER :: basis_S0 REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :, :) :: Lai - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_lai_libint', & routineP = moduleN//':'//routineN @@ -587,14 +578,13 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& irep=1 - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env,& atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& cell=cell,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! kpoint variable needed inside coulomb4 cell_loop_info%dokp = .FALSE. @@ -649,8 +639,7 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& ! ** Rebuild neighbor lists in case the cell has changed (i.e. NPT MD) actual_x_data%periodic_parameter%number_of_shells = actual_x_data%periodic_parameter%mode CALL hfx_create_neighbor_cells(actual_x_data, actual_x_data%periodic_parameter%number_of_shells_from_input,& - cell, i_thread, & - error) + cell, i_thread) END IF screening_parameter = actual_x_data%screening_parameter @@ -690,13 +679,12 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& max_set = MAX(basis_info%max_set,RI_basis_info%max_set) CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) natom = SIZE(particle_set,1) ALLOCATE(kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of) @@ -724,24 +712,24 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& ENDDO !! Allocate the arrays for the integrals. ALLOCATE(primitive_integrals(nsgf_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) primitive_integrals = 0.0_dp ALLOCATE(ee_work(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_work2(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_buffer1(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_buffer2(ncos_max**4),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ee_primitives_tmp(nsgf_max**4),STAT=stat) ! XXXXX could be wrong - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nspins = dft_control%nspins ALLOCATE(max_contraction(max_set,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) max_contraction=0.0_dp max_pgf = 0 @@ -767,19 +755,19 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& ! ** Allocate buffers for pgf_lists nneighbors = SIZE(actual_x_data%neighbor_cells) ALLOCATE(pgf_list_ij(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(max_pgf**2), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_product_list(nneighbors**3), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nimages(max_pgf**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,max_pgf**2 ALLOCATE(pgf_list_ij(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pgf_list_kl(i)%image_list(nneighbors), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO ! ** Set pointers @@ -809,13 +797,13 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& !! Parameters related to the potential 1/r, erf(wr)/r, erfc(wr/r) potential_parameter = actual_x_data%potential_parameter - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() private_lib = actual_x_data%lib !!! Helper array to map local basis function indeces to global ones ALLOCATE(last_sgf_global(0:natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_sgf_global(0)=0 DO iatom=1,natom ikind = kind_of(iatom) @@ -825,13 +813,13 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& IF( .NOT. shm_master_x_data%screen_funct_is_initialized ) THEN CALL calc_pair_dist_radii(qs_env, basis_parameter,& shm_master_x_data%pair_dist_radii_pgf, max_set, max_pgf, eps_schwarz,& - n_threads, i_thread, error) + n_threads, i_thread) CALL calc_screening_functions(qs_env, basis_parameter, private_lib, shm_master_x_data%potential_parameter,& shm_master_x_data%screen_funct_coeffs_set,& shm_master_x_data%screen_funct_coeffs_kind, & shm_master_x_data%screen_funct_coeffs_pgf, & shm_master_x_data%pair_dist_radii_pgf,& - max_set, max_pgf, n_threads, i_thread, p_work, error) + max_set, max_pgf, n_threads, i_thread, p_work) shm_master_x_data%screen_funct_is_initialized = .TRUE. END IF @@ -861,7 +849,7 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& ! start computing the L matrix ALLOCATE(L_full_matrix(RI_dimen,RI_dimen), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) L_full_matrix=0.0_dp counter_L_blocks=0 @@ -1043,30 +1031,30 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& ! create a sub blacs_env NULLIFY(blacs_env) - CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env) NULLIFY(fm_matrix_L) NULLIFY(fm_struct_L) CALL cp_fm_struct_create(fm_struct_L,context=blacs_env,nrow_global=RI_dimen,& - ncol_global=RI_dimen,para_env=para_env,error=error) - CALL cp_fm_create(fm_matrix_L,fm_struct_L,name="fm_matrix_L",error=error) - CALL cp_fm_struct_release(fm_struct_L,error=error) - CALL cp_blacs_env_release(blacs_env, error) + ncol_global=RI_dimen,para_env=para_env) + CALL cp_fm_create(fm_matrix_L,fm_struct_L,name="fm_matrix_L") + CALL cp_fm_struct_release(fm_struct_L) + CALL cp_blacs_env_release(blacs_env) CALL cp_fm_set_submatrix(fm=fm_matrix_L,new_values=L_full_matrix,start_row=1,start_col=1,& - n_rows=RI_dimen, n_cols=RI_dimen, error=error) + n_rows=RI_dimen, n_cols=RI_dimen) info_chol=0 - CALL cp_fm_cholesky_decompose(matrix=fm_matrix_L, n=RI_dimen, info_out=info_chol, error=error) - CPPostcondition(info_chol==0,cp_failure_level,routineP,error,failure) + CALL cp_fm_cholesky_decompose(matrix=fm_matrix_L, n=RI_dimen, info_out=info_chol) + CPPostcondition(info_chol==0,cp_failure_level,routineP,failure) ! triangual invert - CALL cp_fm_triangular_invert(matrix_a=fm_matrix_L,uplo_tr='U',error=error) + CALL cp_fm_triangular_invert(matrix_a=fm_matrix_L,uplo_tr='U') ! replicate L matrix to each proc L_full_matrix=0.0_dp - CALL cp_fm_get_submatrix(fm_matrix_L, L_full_matrix, 1, 1, RI_dimen, RI_dimen, .FALSE., error) - CALL cp_fm_release(fm_matrix_L,error=error) + CALL cp_fm_get_submatrix(fm_matrix_L, L_full_matrix, 1, 1, RI_dimen, RI_dimen, .FALSE.) + CALL cp_fm_release(fm_matrix_L) ! clean lower part DO iiB=1, RI_dimen @@ -1074,11 +1062,11 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& END DO ALLOCATE(list_kl%elements(natom**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeffs_kind_max0=MAXVAL(screen_coeffs_kind(:,:)%x(2)) ALLOCATE(set_list_kl((max_set*natom)**2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !! precalculate maximum density matrix elements in blocks actual_x_data%pmax_block = 0.0_dp @@ -1105,7 +1093,7 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& virtual=dimen-occupied ALLOCATE(Lai(RI_dimen,virtual,occupied),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lai=0.0_dp DO iatom=1, natom @@ -1158,7 +1146,7 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& L_B_i_end=RI_index_table(iatom,iset)+nsgfa(iset)-1 ALLOCATE(BI1(dimen,dimen,nsgfa(iset)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BI1=0.0_dp DO i_list_kl=1,list_kl%n_element @@ -1239,7 +1227,7 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& IF(ALLOCATED(MNRS)) DEALLOCATE(MNRS) ALLOCATE(MNRS(nsgfd(lset),nsgfc(kset),nsgfa(iset)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) MNRS=0.0_dp @@ -1351,30 +1339,30 @@ SUBROUTINE calc_lai_libint(mp2_env,qs_env,para_env,& ! END DO DEALLOCATE(set_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,max_pgf**2 DEALLOCATE(pgf_list_ij(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl(i)%image_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(pgf_list_ij, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_list_kl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pgf_product_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(max_contraction, kind_of, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ee_work, ee_work2, ee_buffer1, ee_buffer2, ee_primitives_tmp, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(nimages, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(mp2_env%potential_parameter%potential_type == do_mp2_potential_TShPSC) THEN init_TShPSC_lmax = -1 diff --git a/src/mp2_setup.F b/src/mp2_setup.F index ffd46f82e7..c2e2f61037 100644 --- a/src/mp2_setup.F +++ b/src/mp2_setup.F @@ -41,12 +41,10 @@ MODULE mp2_setup !> \brief ... !> \param input ... !> \param mp2_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_mp2_section(input,mp2_env,error) + SUBROUTINE read_mp2_section(input,mp2_env) TYPE(section_vals_type), POINTER :: input TYPE(mp2_type), INTENT(INOUT) :: mp2_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_mp2_section', & routineP = moduleN//':'//routineN @@ -58,116 +56,116 @@ SUBROUTINE read_mp2_section(input,mp2_env,error) TYPE(section_vals_type), POINTER :: mp2_section CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure=.FALSE. - mp2_section => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION",error=error) + mp2_section => section_vals_get_subs_vals(input,"DFT%XC%WF_CORRELATION") ! should come from input - CALL section_vals_val_get(mp2_section,"METHOD",i_val=mp2_env%method,error=error) - CALL section_vals_val_get(mp2_section,"MEMORY",r_val=mp2_env%mp2_memory,error=error) - CALL section_vals_val_get(mp2_section,"SCALE_S",r_val=mp2_env%scale_S,error=error) - CALL section_vals_val_get(mp2_section,"SCALE_T",r_val=mp2_env%scale_T,error=error) - CALL section_vals_val_get(mp2_section,"GROUP_SIZE",i_val=mp2_env%mp2_num_proc,error=error) - CALL section_vals_val_get(mp2_section,"DIRECT_CANONICAL%BIG_SEND",l_val=mp2_env%direct_canonical%big_send,error=error) - CALL section_vals_val_get(mp2_section,"ROW_BLOCK",i_val=mp2_env%block_size_row,error=error) - CALL section_vals_val_get(mp2_section,"COL_BLOCK",i_val=mp2_env%block_size_col,error=error) - CALL section_vals_val_get(mp2_section,"CALC_COND_NUM",l_val=mp2_env%calc_PQ_cond_num,error=error) + CALL section_vals_val_get(mp2_section,"METHOD",i_val=mp2_env%method) + CALL section_vals_val_get(mp2_section,"MEMORY",r_val=mp2_env%mp2_memory) + CALL section_vals_val_get(mp2_section,"SCALE_S",r_val=mp2_env%scale_S) + CALL section_vals_val_get(mp2_section,"SCALE_T",r_val=mp2_env%scale_T) + CALL section_vals_val_get(mp2_section,"GROUP_SIZE",i_val=mp2_env%mp2_num_proc) + CALL section_vals_val_get(mp2_section,"DIRECT_CANONICAL%BIG_SEND",l_val=mp2_env%direct_canonical%big_send) + CALL section_vals_val_get(mp2_section,"ROW_BLOCK",i_val=mp2_env%block_size_row) + CALL section_vals_val_get(mp2_section,"COL_BLOCK",i_val=mp2_env%block_size_col) + CALL section_vals_val_get(mp2_section,"CALC_COND_NUM",l_val=mp2_env%calc_PQ_cond_num) CALL section_vals_val_get(mp2_section,"INTERACTION_POTENTIAL%POTENTIAL_TYPE",& - i_val=mp2_env%potential_parameter%potential_type, error=error) + i_val=mp2_env%potential_parameter%potential_type) CALL section_vals_val_get(mp2_section,"INTERACTION_POTENTIAL%TRUNCATION_RADIUS",& - r_val=mp2_env%potential_parameter%truncation_radius, error=error) + r_val=mp2_env%potential_parameter%truncation_radius) CALL section_vals_val_get(mp2_section,"INTERACTION_POTENTIAL%TShPSC_DATA",& - c_val=mp2_env%potential_parameter%filename, error=error) + c_val=mp2_env%potential_parameter%filename) CALL section_vals_val_get(mp2_section,"WFC_GPW%EPS_FILTER",& - r_val=mp2_env%mp2_gpw%eps_filter, error=error) + r_val=mp2_env%mp2_gpw%eps_filter) CALL section_vals_val_get(mp2_section,"WFC_GPW%EPS_GRID",& - r_val=mp2_env%mp2_gpw%eps_grid, error=error) + r_val=mp2_env%mp2_gpw%eps_grid) CALL section_vals_val_get(mp2_section,"WFC_GPW%CUTOFF",& - r_val=mp2_env%mp2_gpw%cutoff, error=error) + r_val=mp2_env%mp2_gpw%cutoff) CALL section_vals_val_get(mp2_section,"WFC_GPW%REL_CUTOFF",& - r_val=mp2_env%mp2_gpw%relative_cutoff, error=error) + r_val=mp2_env%mp2_gpw%relative_cutoff) CALL section_vals_val_get(mp2_section,"WFC_GPW%MULTIPOLE_TWO_CENT_INT",& - l_val=mp2_env%mp2_gpw%do_mult_2c, error=error) + l_val=mp2_env%mp2_gpw%do_mult_2c) CALL section_vals_val_get(mp2_section,"WFC_GPW%PRINT_LEVEL",& - i_val=mp2_env%mp2_gpw%print_level, error=error) + i_val=mp2_env%mp2_gpw%print_level) CALL section_vals_val_get(mp2_section,"RI_RPA%RPA_NUM_QUAD_POINTS",& - i_val=mp2_env%ri_rpa%rpa_num_quad_points, error=error) + i_val=mp2_env%ri_rpa%rpa_num_quad_points) CALL section_vals_val_get(mp2_section,"RI_RPA%SIZE_FREQ_INTEG_GROUP",& - i_val=mp2_env%ri_rpa%rpa_integ_group_size, error=error) + i_val=mp2_env%ri_rpa%rpa_integ_group_size) CALL section_vals_val_get(mp2_section,"RI_RPA%MM_STYLE",& - i_val=mp2_env%ri_rpa%mm_style, error=error) + i_val=mp2_env%ri_rpa%mm_style) CALL section_vals_val_get(mp2_section,"RI_RPA%MINIMAX_QUADRATURE",& - l_val=mp2_env%ri_rpa%minimax_quad, error=error) + l_val=mp2_env%ri_rpa%minimax_quad) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0",& - l_val=mp2_env%ri_rpa%do_ri_g0w0, error=error) + l_val=mp2_env%ri_rpa%do_ri_g0w0) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%CORR_MOS_OCC",& - i_val=mp2_env%ri_g0w0%corr_mos_occ, error=error) + i_val=mp2_env%ri_g0w0%corr_mos_occ) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%CORR_MOS_VIRT",& - i_val=mp2_env%ri_g0w0%corr_mos_virt, error=error) + i_val=mp2_env%ri_g0w0%corr_mos_virt) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%SCALING",& - r_val=mp2_env%ri_g0w0%scaling, error=error) + r_val=mp2_env%ri_g0w0%scaling) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%NUMB_POLES",& - i_val=mp2_env%ri_g0w0%num_poles, error=error) + i_val=mp2_env%ri_g0w0%num_poles) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%OMEGA_MAX_FIT",& - r_val=mp2_env%ri_g0w0%omega_max_fit, error=error) + r_val=mp2_env%ri_g0w0%omega_max_fit) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%STOP_CRIT",& - r_val=mp2_env%ri_g0w0%stop_crit, error=error) + r_val=mp2_env%ri_g0w0%stop_crit) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%MAX_ITER_FIT",& - i_val=mp2_env%ri_g0w0%max_iter_fit, error=error) + i_val=mp2_env%ri_g0w0%max_iter_fit) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%CHECK_FIT",& - l_val=mp2_env%ri_g0w0%check_fit, error=error) + l_val=mp2_env%ri_g0w0%check_fit) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%CROSSING_SEARCH",& - i_val=mp2_env%ri_g0w0%crossing_search, error=error) + i_val=mp2_env%ri_g0w0%crossing_search) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%FERMI_LEVEL_OFFSET",& - r_val=mp2_env%ri_g0w0%fermi_level_offset, error=error) + r_val=mp2_env%ri_g0w0%fermi_level_offset) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%CUTOFF_RADIUS",& - r_val=mp2_env%ri_g0w0%cutoff_rad_gw, error=error) + r_val=mp2_env%ri_g0w0%cutoff_rad_gw) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%TRUNCATION",& - l_val=mp2_env%ri_g0w0%do_truncation, error=error) + l_val=mp2_env%ri_g0w0%do_truncation) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%EV_SC_ITER",& - i_val=mp2_env%ri_g0w0%iter_ev_sc, error=error) + i_val=mp2_env%ri_g0w0%iter_ev_sc) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%HF_LIKE_EV_START",& - l_val=mp2_env%ri_g0w0%hf_like_ev_start, error=error) + l_val=mp2_env%ri_g0w0%hf_like_ev_start) CALL section_vals_val_get(mp2_section,"RI_RPA%RI_G0W0%PRINT_GW_DETAILS",& - l_val=mp2_env%ri_g0w0%print_gw_details, error=error) + l_val=mp2_env%ri_g0w0%print_gw_details) CALL section_vals_val_get(mp2_section,"RI_LAPLACE%QUADRATURE_POINTS",& - i_val=mp2_env%ri_laplace%n_quadrature, error=error) + i_val=mp2_env%ri_laplace%n_quadrature) CALL section_vals_val_get(mp2_section,"RI_LAPLACE%SIZE_INTEG_GROUP",& - i_val=mp2_env%ri_laplace%integ_group_size, error=error) + i_val=mp2_env%ri_laplace%integ_group_size) CALL section_vals_val_get(mp2_section,"RI_MP2%BLOCK_SIZE",& - i_val=mp2_env%ri_mp2%block_size, error=error) + i_val=mp2_env%ri_mp2%block_size) CALL section_vals_val_get(mp2_section,"RI_MP2%EPS_CANONICAL",& - r_val=mp2_env%ri_mp2%eps_canonical, error=error) + r_val=mp2_env%ri_mp2%eps_canonical) CALL section_vals_val_get(mp2_section,"RI_MP2%FREE_HFX_BUFFER",& - l_val=mp2_env%ri_mp2%free_hfx_buffer, error=error) + l_val=mp2_env%ri_mp2%free_hfx_buffer) CALL section_vals_val_get(mp2_section,"CPHF%MAX_ITER",& - i_val=mp2_env%ri_grad%cphf_max_num_iter, error=error) + i_val=mp2_env%ri_grad%cphf_max_num_iter) CALL section_vals_val_get(mp2_section,"CPHF%EPS_CONV",& - r_val=mp2_env%ri_grad%cphf_eps_conv, error=error) + r_val=mp2_env%ri_grad%cphf_eps_conv) CALL section_vals_val_get(mp2_section,"OPT_RI_BASIS%DELTA_I_REL",& - r_val=mp2_env%ri_opt_param%DI_rel, error=error) + r_val=mp2_env%ri_opt_param%DI_rel) CALL section_vals_val_get(mp2_section,"OPT_RI_BASIS%DELTA_RI",& - r_val=mp2_env%ri_opt_param%DRI, error=error) + r_val=mp2_env%ri_opt_param%DRI) CALL section_vals_val_get(mp2_section,"OPT_RI_BASIS%EPS_DERIV",& - r_val=mp2_env%ri_opt_param%eps_step, error=error) + r_val=mp2_env%ri_opt_param%eps_step) CALL section_vals_val_get(mp2_section,"OPT_RI_BASIS%MAX_ITER",& - i_val=mp2_env%ri_opt_param%max_num_iter, error=error) + i_val=mp2_env%ri_opt_param%max_num_iter) CALL section_vals_val_get(mp2_section,"OPT_RI_BASIS%BASIS_SIZE",& - i_val=mp2_env%ri_opt_param%basis_quality, error=error) + i_val=mp2_env%ri_opt_param%basis_quality) NULLIFY(tmplist) CALL section_vals_val_get(mp2_section,"OPT_RI_BASIS%NUM_FUNC",& - i_vals=tmplist, error=error) + i_vals=tmplist) IF(tmplist(1)>0) THEN ALLOCATE(mp2_env%ri_opt_param%RI_nset_per_l(0:SIZE(tmplist)-1)) mp2_env%ri_opt_param%RI_nset_per_l=0 @@ -178,7 +176,7 @@ SUBROUTINE read_mp2_section(input,mp2_env,error) ! print some info about the MP2 parameters unit_nr = cp_print_key_unit_nr(logger,mp2_section,"MP2_INFO",& - extension=".mp2Log",error=error) + extension=".mp2Log") IF ((mp2_env%method .NE. mp2_method_none) .AND. unit_nr>0) THEN WRITE(unit_nr,'(T2,A)') "" SELECT CASE(mp2_env%method) @@ -195,12 +193,12 @@ SUBROUTINE read_mp2_section(input,mp2_env,error) CASE(mp2_ri_optimize_basis) WRITE(unit_nr,'(T2,A)') "MP2| Optimize RI auxiliary basis" CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT WRITE(unit_nr,'(T2,A)') "" ENDIF CALL cp_print_key_finished_output(unit_nr,logger,mp2_section,& - "MP2_INFO", error=error) + "MP2_INFO") CALL timestop(handle) diff --git a/src/mp2_types.F b/src/mp2_types.F index 178adb2d67..45de2fdf80 100644 --- a/src/mp2_types.F +++ b/src/mp2_types.F @@ -188,11 +188,9 @@ MODULE mp2_types ! ***************************************************************************** !> \brief ... !> \param mp2_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mp2_env_release(mp2_env,error) + SUBROUTINE mp2_env_release(mp2_env) TYPE(mp2_type), POINTER :: mp2_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mp2_env_release', & routineP = moduleN//':'//routineN @@ -204,15 +202,15 @@ SUBROUTINE mp2_env_release(mp2_env,error) CALL timeset(routineN,handle) - CPPostcondition(ASSOCIATED(mp2_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(mp2_env),cp_failure_level,routineP,failure) ! release the HFX section for the EXX calculation IF(ASSOCIATED(mp2_env%ri_rpa%x_data)) THEN - CALL hfx_release(mp2_env%ri_rpa%x_data, error=error) + CALL hfx_release(mp2_env%ri_rpa%x_data) END IF DEALLOCATE(mp2_env,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -221,11 +219,9 @@ END SUBROUTINE mp2_env_release ! ***************************************************************************** !> \brief ... !> \param mp2_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mp2_env_create(mp2_env,error) + SUBROUTINE mp2_env_create(mp2_env) TYPE(mp2_type), POINTER :: mp2_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mp2_env_create', & routineP = moduleN//':'//routineN @@ -237,10 +233,10 @@ SUBROUTINE mp2_env_create(mp2_env,error) CALL timeset(routineN,handle) - CPPostcondition(.NOT.ASSOCIATED(mp2_env),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(mp2_env),cp_failure_level,routineP,failure) ALLOCATE(mp2_env,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(mp2_env%ri_rpa%x_data) diff --git a/src/mscfg_methods.F b/src/mscfg_methods.F index 9a60774689..ce4c682ac8 100644 --- a/src/mscfg_methods.F +++ b/src/mscfg_methods.F @@ -67,16 +67,14 @@ MODULE mscfg_methods !> \brief Prepare data for calculations on isolated molecules. !> \param globenv ... !> \param force_env ... -!> \param error ... !> \par History !> 10.2014 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE loop_over_molecules(globenv,force_env,error) + SUBROUTINE loop_over_molecules(globenv,force_env) TYPE(global_environment_type), POINTER :: globenv TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'loop_over_molecules', & routineP = moduleN//':'//routineN @@ -93,11 +91,10 @@ SUBROUTINE loop_over_molecules(globenv,force_env,error) failure = .FALSE. - CALL force_env_get(force_env,qs_env=qs_env,error=error) - CPPostcondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CALL force_env_get(force_env,qs_env=qs_env) + CPPostcondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& - molecule_set=molecule_set,& - error=error) + molecule_set=molecule_set) nmols=SIZE(molecule_set) @@ -110,12 +107,10 @@ SUBROUTINE loop_over_molecules(globenv,force_env,error) mol_to_first_atom=first_atom_of_frag,& mol_to_last_atom=last_atom_of_frag,& mol_to_charge=charge_of_frag,& - mol_to_multiplicity=multip_of_frag,& - error=error) + mol_to_multiplicity=multip_of_frag) CALL calcs_on_isolated_molecules(force_env, globenv, nmols,& - first_atom_of_frag, last_atom_of_frag, charge_of_frag, multip_of_frag, & - error) + first_atom_of_frag, last_atom_of_frag, charge_of_frag, multip_of_frag) DEALLOCATE(first_atom_of_frag) DEALLOCATE(last_atom_of_frag) @@ -134,14 +129,12 @@ END SUBROUTINE loop_over_molecules !> \param last_atom_of_frag ... !> \param charge_of_frag ... !> \param multip_of_frag ... -!> \param error ... !> \par History !> 10.2014 created !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE calcs_on_isolated_molecules(force_env, globenv, nfrags,& - first_atom_of_frag, last_atom_of_frag, charge_of_frag, multip_of_frag, & - error) + first_atom_of_frag, last_atom_of_frag, charge_of_frag, multip_of_frag) TYPE(force_env_type), POINTER :: force_env TYPE(global_environment_type), POINTER :: globenv @@ -149,7 +142,6 @@ SUBROUTINE calcs_on_isolated_molecules(force_env, globenv, nfrags,& INTEGER, DIMENSION(:), INTENT(IN) :: first_atom_of_frag, & last_atom_of_frag, & charge_of_frag, multip_of_frag - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calcs_on_isolated_molecules', & routineP = moduleN//':'//routineN @@ -185,28 +177,28 @@ SUBROUTINE calcs_on_isolated_molecules(force_env, globenv, nfrags,& NULLIFY(subsys_loc, subsys, particles, para_env, cell, atom_index, atom_type, & force_env_section, qs_env_loc, mscfg_env, qs_env, qs_energy) CALL force_env_get(force_env, force_env_section=force_env_section, & - qs_env=qs_env, error=error) - CALL section_vals_val_get(force_env_section,"METHOD",i_val=force_method,error=error) - CPPostcondition(force_method.eq.do_qs,cp_failure_level,routineP,error,failure) + qs_env=qs_env) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=force_method) + CPPostcondition(force_method.eq.do_qs,cp_failure_level,routineP,failure) root_section => force_env%root_section - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) - dft_section => section_vals_get_subs_vals(force_env_section,"DFT",error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") + dft_section => section_vals_get_subs_vals(force_env_section,"DFT") ! ! Save several global settings to restore them after the loop: ! charge, multiplicity, ALMO flag ! - CALL section_vals_val_get(dft_section,"CHARGE",i_val=global_charge, error=error) - CALL section_vals_val_get(dft_section,"MULTIPLICITY",i_val=global_multpl, error=error) - qs_section => section_vals_get_subs_vals(dft_section,"QS",error=error) - CALL section_vals_val_get(qs_section,"ALMO_SCF",l_val=global_almo_scf_keyword, error=error) + CALL section_vals_val_get(dft_section,"CHARGE",i_val=global_charge) + CALL section_vals_val_get(dft_section,"MULTIPLICITY",i_val=global_multpl) + qs_section => section_vals_get_subs_vals(dft_section,"QS") + CALL section_vals_val_get(qs_section,"ALMO_SCF",l_val=global_almo_scf_keyword) ! ! Get access to critical data before the loop ! CALL force_env_get(force_env=force_env, subsys=subsys, para_env=para_env,& - cell=cell, error=error) - CALL cp_subsys_get(subsys, particles=particles, error=error) - CALL get_qs_env(qs_env, mscfg_env=mscfg_env, error=error) - CPPostcondition(ASSOCIATED(mscfg_env),cp_failure_level,routineP,error,failure) + cell=cell) + CALL cp_subsys_get(subsys, particles=particles) + CALL get_qs_env(qs_env, mscfg_env=mscfg_env) + CPPostcondition(ASSOCIATED(mscfg_env),cp_failure_level,routineP,failure) ! ! These flags determine the options of molecular runs (e.g. cell size) ! @@ -217,7 +209,7 @@ SUBROUTINE calcs_on_isolated_molecules(force_env, globenv, nfrags,& ! Until molecular_scf_guess_env is destroyed it will keep ! the results of fragment calculations ! - CALL molecular_scf_guess_env_init(mscfg_env, nfrags, error=error) + CALL molecular_scf_guess_env_init(mscfg_env, nfrags) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -235,12 +227,12 @@ SUBROUTINE calcs_on_isolated_molecules(force_env, globenv, nfrags,& ! ! Turn ALMO SCF flag off ! - CALL section_vals_val_set(qs_section,"ALMO_SCF",l_val=.FALSE., error=error) + CALL section_vals_val_set(qs_section,"ALMO_SCF",l_val=.FALSE.) ! ! Setup the charge and multiplicity of the molecule ! - CALL section_vals_val_set(dft_section,"CHARGE",i_val=charge_of_frag(ifrag), error=error) - CALL section_vals_val_set(dft_section,"MULTIPLICITY",i_val=multip_of_frag(ifrag), error=error) + CALL section_vals_val_set(dft_section,"CHARGE",i_val=charge_of_frag(ifrag)) + CALL section_vals_val_set(dft_section,"MULTIPLICITY",i_val=multip_of_frag(ifrag)) ! ! Create a list of atoms in the current molecule ! @@ -255,7 +247,7 @@ SUBROUTINE calcs_on_isolated_molecules(force_env, globenv, nfrags,& ! Get atom type names ! ALLOCATE(atom_type(isize), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, isize my_targ = atom_index(j) DO k = 1, SIZE(particles%els) @@ -270,60 +262,58 @@ SUBROUTINE calcs_on_isolated_molecules(force_env, globenv, nfrags,& CALL create_small_subsys(subsys_loc, big_subsys=subsys,& small_para_env=para_env, small_cell=cell,sub_atom_index=atom_index,& sub_atom_kind_name=atom_type,para_env=para_env,& - force_env_section=force_env_section,subsys_section=subsys_section,error=error) - CALL qs_env_create(qs_env_loc, globenv,error=error) + force_env_section=force_env_section,subsys_section=subsys_section) + CALL qs_env_create(qs_env_loc, globenv) CALL qs_init(qs_env_loc, para_env, globenv, root_section, cp_subsys=subsys_loc,& force_env_section=force_env_section, subsys_section=subsys_section,& - use_motion_section=.FALSE., error=error) - CALL cp_subsys_release(subsys_loc,error=error) + use_motion_section=.FALSE.) + CALL cp_subsys_release(subsys_loc) ! ! Print-out fragment info ! CALL print_frag_info(atom_index, atom_type, ifrag, nfrags, & - charge_of_frag(ifrag), multip_of_frag(ifrag), error) + charge_of_frag(ifrag), multip_of_frag(ifrag)) ! ! Run calculations on a subsystem ! - CALL qs_energies(qs_env_loc, error=error) + CALL qs_energies(qs_env_loc) ! ! Get the desired results (energy and MOs) out ! - CALL get_qs_env(qs_env_loc, mos=mos_of_frag, energy=qs_energy, error=error) + CALL get_qs_env(qs_env_loc, mos=mos_of_frag, energy=qs_energy) ! ! Store all desired results of fragment calculations in the fragment_env ! of the qs_env to use them later as needed ! mscfg_env%energy_of_frag(ifrag) = qs_energy%total nmosets_of_frag=SIZE(mos_of_frag) - CPPostcondition(nmosets_of_frag.le.mscfg_max_moset_size,cp_failure_level,routineP,error,failure) + CPPostcondition(nmosets_of_frag.le.mscfg_max_moset_size,cp_failure_level,routineP,failure) mscfg_env%nmosets_of_frag(ifrag)=nmosets_of_frag DO imo=1,nmosets_of_frag ! the matrices have been allocated already - copy the results there - CALL cp_dbcsr_init(mscfg_env%mos_of_frag(ifrag,imo),error) + CALL cp_dbcsr_init(mscfg_env%mos_of_frag(ifrag,imo)) CALL cp_dbcsr_create(mscfg_env%mos_of_frag(ifrag,imo),& template=mos_of_frag(imo)%mo_set%mo_coeff_b,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) + matrix_type=dbcsr_type_no_symmetry) CALL cp_dbcsr_copy(mscfg_env%mos_of_frag(ifrag,imo),& - mos_of_frag(imo)%mo_set%mo_coeff_b,& - error=error) + mos_of_frag(imo)%mo_set%mo_coeff_b) ENDDO ! ! Clean up ! NULLIFY(qs_energy) - CALL qs_env_release(qs_env_loc, error=error) + CALL qs_env_release(qs_env_loc) DEALLOCATE(atom_index, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(atom_type, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO - CALL section_vals_val_set(dft_section,"CHARGE",i_val=global_charge, error=error) - CALL section_vals_val_set(dft_section,"MULTIPLICITY",i_val=global_multpl, error=error) - CALL section_vals_val_set(qs_section,"ALMO_SCF",l_val=global_almo_scf_keyword, error=error) + CALL section_vals_val_set(dft_section,"CHARGE",i_val=global_charge) + CALL section_vals_val_set(dft_section,"MULTIPLICITY",i_val=global_multpl) + CALL section_vals_val_set(qs_section,"ALMO_SCF",l_val=global_almo_scf_keyword) CALL timestop(handle) @@ -337,20 +327,18 @@ END SUBROUTINE calcs_on_isolated_molecules !> \param nfrags ... !> \param charge ... !> \param multpl ... -!> \param error variable to control error logging, stopping,... !> \par History !> 07.2005 created as a part of BSSE calculations [tlaino] !> 10.2014 adapted to ALMO guess calculations [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE print_frag_info(atom_index, atom_type, frag, nfrags, charge, & - multpl, error) + multpl) INTEGER, DIMENSION(:), POINTER :: atom_index CHARACTER(len=default_string_length), & DIMENSION(:), POINTER :: atom_type INTEGER, INTENT(IN) :: frag, nfrags, charge, multpl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_frag_info', & routineP = moduleN//':'//routineN @@ -362,7 +350,7 @@ SUBROUTINE print_frag_info(atom_index, atom_type, frag, nfrags, charge, & failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN iw=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -393,16 +381,14 @@ END SUBROUTINE print_frag_info ! ***************************************************************************** !> \brief Is the loop over molecules requested? !> \param force_env ... -!> \param error ... !> \retval do_mol_loop ... !> \par History !> 10.2014 created [Rustam Z. Khaliullin] !> \author Rustam Z. Khaliullin ! ***************************************************************************** - FUNCTION do_mol_loop(force_env, error) + FUNCTION do_mol_loop(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: do_mol_loop CHARACTER(LEN=*), PARAMETER :: routineN = 'do_mol_loop', & @@ -424,16 +410,16 @@ FUNCTION do_mol_loop(force_env, error) is_crystal = .FALSE. NULLIFY(qs_env, mscfg_env, force_env_section, subsection) - CALL force_env_get(force_env, force_env_section=force_env_section, error=error) - CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id,error=error) + CALL force_env_get(force_env, force_env_section=force_env_section) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id) IF (method_name_id.eq.do_qs) THEN - CALL force_env_get(force_env, qs_env=qs_env, error=error) - CPPostcondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CALL force_env_get(force_env, qs_env=qs_env) + CPPostcondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env, mscfg_env=mscfg_env, error=error) - CPPostcondition(ASSOCIATED(mscfg_env),cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env, mscfg_env=mscfg_env) + CPPostcondition(ASSOCIATED(mscfg_env),cp_failure_level,routineP,failure) !!!! RZK-warning: All decisions are based on the values of input keywords !!!! The real danger is that many of these keywords might not be even @@ -442,18 +428,18 @@ FUNCTION do_mol_loop(force_env, error) ! check ALMO SCF guess option NULLIFY(subsection) - subsection => section_vals_get_subs_vals(force_env_section,"DFT%ALMO_SCF",error=error) - CALL section_vals_val_get(subsection,"ALMO_SCF_GUESS",i_val=almo_guess_type, error=error) + subsection => section_vals_get_subs_vals(force_env_section,"DFT%ALMO_SCF") + CALL section_vals_val_get(subsection,"ALMO_SCF_GUESS",i_val=almo_guess_type) ! check SCF guess option NULLIFY(subsection) - subsection => section_vals_get_subs_vals(force_env_section,"DFT%SCF",error=error) - CALL section_vals_val_get(subsection,"SCF_GUESS",i_val=scf_guess_type, error=error) + subsection => section_vals_get_subs_vals(force_env_section,"DFT%SCF") + CALL section_vals_val_get(subsection,"SCF_GUESS",i_val=scf_guess_type) ! check ALMO EDA options NULLIFY(subsection) - !!!LATER subsection => section_vals_get_subs_vals(force_env_section,"DFT%ALMO_SCF%ALMO_DA",error=error) - !!!LATER CALL section_vals_val_get(subsection,"FRZ_TERM",i_val=frz_term_type, error=error) + !!!LATER subsection => section_vals_get_subs_vals(force_env_section,"DFT%ALMO_SCF%ALMO_DA") + !!!LATER CALL section_vals_val_get(subsection,"FRZ_TERM",i_val=frz_term_type) frz_term_type = almo_frz_none ! Are we doing the loop ? diff --git a/src/mscfg_types.F b/src/mscfg_types.F index 17cc8a23b7..98760ab440 100644 --- a/src/mscfg_types.F +++ b/src/mscfg_types.F @@ -71,16 +71,14 @@ MODULE mscfg_types !> \brief Allocates data !> \param env ... !> \param nfrags - number of entries -!> \param error ... !> \par History !> 2014.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE molecular_scf_guess_env_init(env,nfrags,error) + SUBROUTINE molecular_scf_guess_env_init(env,nfrags) TYPE(molecular_scf_guess_env_type) :: env INTEGER, INTENT(IN) :: nfrags - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'molecular_scf_guess_env_init', & routineP = moduleN//':'//routineN @@ -89,7 +87,7 @@ SUBROUTINE molecular_scf_guess_env_init(env,nfrags,error) !IF (env%nfrags.ne.0) THEN ! ! do not allow re-initialization ! ! to prevent recursive calls -! CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) +! CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) !ENDIF env%nfrags = nfrags @@ -104,15 +102,13 @@ END SUBROUTINE molecular_scf_guess_env_init ! ***************************************************************************** !> \brief Destroyes both data and environment !> \param env ... -!> \param error ... !> \par History !> 2014.10 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE molecular_scf_guess_env_destroy(env,error) + SUBROUTINE molecular_scf_guess_env_destroy(env) TYPE(molecular_scf_guess_env_type) :: env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'molecular_scf_guess_env_destroy', & @@ -123,7 +119,7 @@ SUBROUTINE molecular_scf_guess_env_destroy(env,error) IF (ALLOCATED(env%mos_of_frag)) THEN DO ifrag=1,SIZE(env%mos_of_frag,1) DO jfrag=1,env%nmosets_of_frag(ifrag) - CALL cp_dbcsr_release(env%mos_of_frag(ifrag,jfrag),error=error) + CALL cp_dbcsr_release(env%mos_of_frag(ifrag,jfrag)) ENDDO ENDDO DEALLOCATE(env%mos_of_frag) @@ -140,18 +136,16 @@ END SUBROUTINE molecular_scf_guess_env_destroy !> \param mscfg_env - env containing MOs of fragments !> \param matrix_out - all existing blocks will be deleted! !> \param iset - which set of MOs in mscfg_env has to be converted (e.g. spin) -!> \param error ... !> \par History !> 10.2014 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** - SUBROUTINE get_matrix_from_submatrices(mscfg_env, matrix_out, iset, error) + SUBROUTINE get_matrix_from_submatrices(mscfg_env, matrix_out, iset) TYPE(molecular_scf_guess_env_type), & INTENT(IN) :: mscfg_env TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_out INTEGER, INTENT(IN) :: iset - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_matrix_from_submatrices', & routineP = moduleN//':'//routineN @@ -164,14 +158,13 @@ SUBROUTINE get_matrix_from_submatrices(mscfg_env, matrix_out, iset, error) CALL timeset(routineN,handle) - CPPostcondition(iset.le.mscfg_max_moset_size,cp_failure_level,routineP,error,failure) + CPPostcondition(iset.le.mscfg_max_moset_size,cp_failure_level,routineP,failure) - CALL cp_dbcsr_init(matrix_temp,error) + CALL cp_dbcsr_init(matrix_temp) CALL cp_dbcsr_create(matrix_temp,& template=matrix_out,& - matrix_type=dbcsr_type_no_symmetry,& - error=error) - CALL cp_dbcsr_set(matrix_out, 0.0_dp, error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_set(matrix_out, 0.0_dp) matrix_size(1) = cp_dbcsr_nfullrows_total(matrix_out) matrix_size(2) = cp_dbcsr_nfullcols_total(matrix_out) @@ -182,15 +175,15 @@ SUBROUTINE get_matrix_from_submatrices(mscfg_env, matrix_out, iset, error) DO ifrag=1, mscfg_env%nfrags - CPPostcondition(iset.le.mscfg_env%nmosets_of_frag(ifrag),cp_failure_level,routineP,error,failure) + CPPostcondition(iset.le.mscfg_env%nmosets_of_frag(ifrag),cp_failure_level,routineP,failure) submatrix_size(1) = cp_dbcsr_nfullrows_total(mscfg_env%mos_of_frag(ifrag,iset)) submatrix_size(2) = cp_dbcsr_nfullcols_total(mscfg_env%mos_of_frag(ifrag,iset)) CALL copy_submatrix_into_matrix(mscfg_env%mos_of_frag(ifrag,iset),& - matrix_temp, offset, submatrix_size, matrix_size, error) + matrix_temp, offset, submatrix_size, matrix_size) - CALL cp_dbcsr_add(matrix_out,matrix_temp,1.0_dp,1.0_dp,error=error) + CALL cp_dbcsr_add(matrix_out,matrix_temp,1.0_dp,1.0_dp) offset(1)=offset(1)+submatrix_size(1) offset(2)=offset(2)+submatrix_size(2) @@ -201,10 +194,10 @@ SUBROUTINE get_matrix_from_submatrices(mscfg_env, matrix_out, iset, error) ! is exactly the same as the size of the big matrix ! This is to prevent unexpected conversion errors ! If however such conversion is intended - remove these safeguards - CPPostcondition(offset(1).eq.matrix_size(1),cp_failure_level,routineP,error,failure) - CPPostcondition(offset(2).eq.matrix_size(2),cp_failure_level,routineP,error,failure) + CPPostcondition(offset(1).eq.matrix_size(1),cp_failure_level,routineP,failure) + CPPostcondition(offset(2).eq.matrix_size(2),cp_failure_level,routineP,failure) - CALL cp_dbcsr_release(matrix_temp,error=error) + CALL cp_dbcsr_release(matrix_temp) CALL timestop (handle) @@ -217,19 +210,17 @@ END SUBROUTINE get_matrix_from_submatrices !> \param offset ... !> \param submatrix_size ... !> \param matrix_size ... -!> \param error ... !> \par History !> 10.2014 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE copy_submatrix_into_matrix(submatrix_in, matrix_out,& - offset, submatrix_size, matrix_size, error) + offset, submatrix_size, matrix_size) TYPE(cp_dbcsr_type), INTENT(IN) :: submatrix_in TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_out INTEGER, DIMENSION(2), INTENT(IN) :: offset, submatrix_size, & matrix_size - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'copy_submatrix_into_matrix', & routineP = moduleN//':'//routineN @@ -323,18 +314,18 @@ SUBROUTINE copy_submatrix_into_matrix(submatrix_in, matrix_out,& reuse_arrays=.TRUE.) ! Create big the matrix - CALL cp_dbcsr_init(matrix_new,error=error) + CALL cp_dbcsr_init(matrix_new) CALL cp_dbcsr_create(matrix_new, "BIG_AND_FAKE",& dist_new, dbcsr_type_no_symmetry,& row_sizes_new, col_sizes_new,& - reuse_arrays=.TRUE., error=error) + reuse_arrays=.TRUE.) CALL cp_dbcsr_distribution_release(dist_new) - !CALL cp_dbcsr_finalize(matrix_new,error=error) + !CALL cp_dbcsr_finalize(matrix_new) ! copy blocks of the small matrix to the big matrix !mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(cp_dbcsr_distribution(matrix_new))) - CALL cp_dbcsr_work_create(matrix_new, work_mutable=.TRUE., error=error) + CALL cp_dbcsr_work_create(matrix_new, work_mutable=.TRUE.) ! iterate over local blocks of the small matrix CALL cp_dbcsr_iterator_start(iter,submatrix_in) @@ -353,22 +344,21 @@ SUBROUTINE copy_submatrix_into_matrix(submatrix_in, matrix_out,& iblock_col+add_blocks_before(2),& p_new_block) - CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(p_new_block,1).eq.SIZE(data_p,1),cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(p_new_block,2).eq.SIZE(data_p,2),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_new_block),cp_failure_level,routineP,failure) + CPPostcondition(SIZE(p_new_block,1).eq.SIZE(data_p,1),cp_failure_level,routineP,failure) + CPPostcondition(SIZE(p_new_block,2).eq.SIZE(data_p,2),cp_failure_level,routineP,failure) p_new_block(:,:) = data_p(:,:) ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_finalize(matrix_new,error=error) + CALL cp_dbcsr_finalize(matrix_new) ! finally call complete redistribute to get the matrix of the entire system - CALL cp_dbcsr_set(matrix_out, 0.0_dp, error=error) - CALL cp_dbcsr_complete_redistribute(matrix_new, matrix_out,& - error=error); - CALL cp_dbcsr_release (matrix_new, error=error) + CALL cp_dbcsr_set(matrix_out, 0.0_dp) + CALL cp_dbcsr_complete_redistribute(matrix_new, matrix_out) + CALL cp_dbcsr_release (matrix_new) END SUBROUTINE copy_submatrix_into_matrix diff --git a/src/mulliken.F b/src/mulliken.F index 3f1f4b3d34..5a68e57544 100644 --- a/src/mulliken.F +++ b/src/mulliken.F @@ -59,7 +59,6 @@ MODULE mulliken !> \param order_p ... !> \param ks_matrix ... !> \param w_matrix ... -!> \param error ... !> \par History !> 06.2004 created [Joost VandeVondele] !> \note @@ -68,7 +67,7 @@ MODULE mulliken !> needed for orbital and ionic forces respectively ! ***************************************************************************** SUBROUTINE mulliken_restraint(mulliken_restraint_control,para_env, & - s_matrix,p_matrix,energy,order_p,ks_matrix,w_matrix,error) + s_matrix,p_matrix,energy,order_p,ks_matrix,w_matrix) TYPE(mulliken_restraint_type), & INTENT(IN) :: mulliken_restraint_control TYPE(cp_para_env_type), POINTER :: para_env @@ -78,7 +77,6 @@ SUBROUTINE mulliken_restraint(mulliken_restraint_control,para_env, & REAL(KIND=dp), OPTIONAL :: energy, order_p TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: ks_matrix, w_matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_restraint', & routineP = moduleN//':'//routineN @@ -389,12 +387,11 @@ END SUBROUTINE compute_dcharges !> \param qs_kind_set ... !> \param scr unit for output !> \param title ... -!> \param error ... !> \par History !> 06.2004 adapted to remove explicit matrix multiply [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE mulliken_charges_a(p_matrix,s_matrix,para_env,particle_set, & - qs_kind_set,scr,title,error) + qs_kind_set,scr,title) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: p_matrix @@ -406,7 +403,6 @@ SUBROUTINE mulliken_charges_a(p_matrix,s_matrix,para_env,particle_set, & POINTER :: qs_kind_set INTEGER :: scr CHARACTER(LEN=*) :: title - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_charges_a', & routineP = moduleN//':'//routineN @@ -418,20 +414,20 @@ SUBROUTINE mulliken_charges_a(p_matrix,s_matrix,para_env,particle_set, & CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(p_matrix),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(s_matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_matrix),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(s_matrix),cp_failure_level,routineP,failure) ! here we get the numbers for charges nspin=SIZE(p_matrix) CALL cp_dbcsr_get_info(s_matrix,nblkrows_total=nblock) ALLOCATE(charges(nblock,nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL compute_charges(p_matrix,s_matrix,charges,para_env) - CALL print_atomic_charges(particle_set,qs_kind_set,scr,title,electronic_charges=charges,error=error) + CALL print_atomic_charges(particle_set,qs_kind_set,scr,title,electronic_charges=charges) DEALLOCATE(charges,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -443,16 +439,14 @@ END SUBROUTINE mulliken_charges_a !> \param s_matrix ... !> \param para_env ... !> \param mcharge ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mulliken_charges_b(p_matrix,s_matrix,para_env,mcharge,error) + SUBROUTINE mulliken_charges_b(p_matrix,s_matrix,para_env,mcharge) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: p_matrix TYPE(cp_dbcsr_type), POINTER :: s_matrix TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:, :), POINTER :: mcharge - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_charges_b', & routineP = moduleN//':'//routineN @@ -476,15 +470,13 @@ END SUBROUTINE mulliken_charges_b !> \param para_env ... !> \param mcharge ... !> \param dmcharge ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mulliken_charges_c(p_matrix,s_matrix,para_env,mcharge,dmcharge,error) + SUBROUTINE mulliken_charges_c(p_matrix,s_matrix,para_env,mcharge,dmcharge) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: p_matrix, s_matrix TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:, :), POINTER :: mcharge, dmcharge - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_charges_c', & routineP = moduleN//':'//routineN @@ -510,12 +502,11 @@ END SUBROUTINE mulliken_charges_c !> \param qs_kind_set ... !> \param scr unit for output !> \param title ... -!> \param error ... !> \par History !> 06.2004 adapted to remove explicit matrix multiply [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE mulliken_charges_akp(p_matrix_kp,s_matrix_kp,para_env,particle_set, & - qs_kind_set,scr,title,error) + qs_kind_set,scr,title) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: p_matrix_kp, s_matrix_kp @@ -526,7 +517,6 @@ SUBROUTINE mulliken_charges_akp(p_matrix_kp,s_matrix_kp,para_env,particle_set, & POINTER :: qs_kind_set INTEGER :: scr CHARACTER(LEN=*) :: title - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_charges_akp', & routineP = moduleN//':'//routineN @@ -542,13 +532,13 @@ SUBROUTINE mulliken_charges_akp(p_matrix_kp,s_matrix_kp,para_env,particle_set, & CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(p_matrix_kp),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(s_matrix_kp),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_matrix_kp),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(s_matrix_kp),cp_failure_level,routineP,failure) nspin=SIZE(p_matrix) CALL cp_dbcsr_get_info(s_matrix,nblkrows_total=nblock) ALLOCATE(charges(nblock,nspin),charges_im(nblock,nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) charges = 0.0_dp DO ic=1,SIZE(s_matrix_kp,2) @@ -560,10 +550,10 @@ SUBROUTINE mulliken_charges_akp(p_matrix_kp,s_matrix_kp,para_env,particle_set, & charges(:,:) = charges(:,:) + charges_im(:,:) END DO - CALL print_atomic_charges(particle_set,qs_kind_set,scr,title,electronic_charges=charges,error=error) + CALL print_atomic_charges(particle_set,qs_kind_set,scr,title,electronic_charges=charges) DEALLOCATE(charges,charges_im,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -575,15 +565,13 @@ END SUBROUTINE mulliken_charges_akp !> \param s_matrix_kp ... !> \param para_env ... !> \param mcharge ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mulliken_charges_bkp(p_matrix_kp,s_matrix_kp,para_env,mcharge,error) + SUBROUTINE mulliken_charges_bkp(p_matrix_kp,s_matrix_kp,para_env,mcharge) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: p_matrix_kp, s_matrix_kp TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:, :), POINTER :: mcharge - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_charges_bkp', & routineP = moduleN//':'//routineN @@ -605,7 +593,7 @@ SUBROUTINE mulliken_charges_bkp(p_matrix_kp,s_matrix_kp,para_env,mcharge,error) natom = SIZE(mcharge,1) nspin = SIZE(mcharge,2) ALLOCATE(mcharge_im(natom,nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ic=1,SIZE(s_matrix_kp,2) NULLIFY(p_matrix,s_matrix) @@ -618,7 +606,7 @@ SUBROUTINE mulliken_charges_bkp(p_matrix_kp,s_matrix_kp,para_env,mcharge,error) END DO DEALLOCATE(mcharge_im,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF @@ -633,16 +621,14 @@ END SUBROUTINE mulliken_charges_bkp !> \param para_env ... !> \param mcharge ... !> \param dmcharge ... -!> \param error ... ! ***************************************************************************** SUBROUTINE mulliken_charges_ckp(p_matrix_kp,s_matrix_kp,para_env,& - mcharge,dmcharge,error) + mcharge,dmcharge) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: p_matrix_kp, s_matrix_kp TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:, :), POINTER :: mcharge, dmcharge - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mulliken_charges_ckp', & routineP = moduleN//':'//routineN @@ -665,7 +651,7 @@ SUBROUTINE mulliken_charges_ckp(p_matrix_kp,s_matrix_kp,para_env,& nspin = SIZE(mcharge,2) nder = SIZE(dmcharge,2) ALLOCATE(mcharge_im(natom,nspin),dmcharge_im(natom,nder),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ic=1,SIZE(s_matrix_kp,2) NULLIFY(p_matrix,s_matrix) @@ -679,7 +665,7 @@ SUBROUTINE mulliken_charges_ckp(p_matrix_kp,s_matrix_kp,para_env,& END DO DEALLOCATE(mcharge_im,dmcharge_im,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF diff --git a/src/optbas_fenv_manipulation.F b/src/optbas_fenv_manipulation.F index 6a472e9d34..71082ae281 100644 --- a/src/optbas_fenv_manipulation.F +++ b/src/optbas_fenv_manipulation.F @@ -85,14 +85,12 @@ MODULE optbas_fenv_manipulation !> \param basis_optimization ... !> \param bas_id ... !> \param input_file ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE modify_input_settings(basis_optimization,bas_id,input_file,error) + SUBROUTINE modify_input_settings(basis_optimization,bas_id,input_file) TYPE(basis_optimization_type) :: basis_optimization INTEGER :: bas_id TYPE(section_vals_type), POINTER :: input_file - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'modify_input_settings', & routineP = moduleN//':'//routineN @@ -104,39 +102,39 @@ SUBROUTINE modify_input_settings(basis_optimization,bas_id,input_file,error) feval_section, kind_section, & subsys_section - feval_section => section_vals_get_subs_vals(input_file,"FORCE_EVAL",error=error) - dft_section => section_vals_get_subs_vals(feval_section,"DFT",error=error) - admm_section => section_vals_get_subs_vals(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD",error=error) - subsys_section => section_vals_get_subs_vals(feval_section,"SUBSYS",error=error) - kind_section => section_vals_get_subs_vals(subsys_section,"KIND",error=error) + feval_section => section_vals_get_subs_vals(input_file,"FORCE_EVAL") + dft_section => section_vals_get_subs_vals(feval_section,"DFT") + admm_section => section_vals_get_subs_vals(dft_section,"AUXILIARY_DENSITY_MATRIX_METHOD") + subsys_section => section_vals_get_subs_vals(feval_section,"SUBSYS") + kind_section => section_vals_get_subs_vals(subsys_section,"KIND") CALL section_vals_val_set(feval_section,"PRINT%DISTRIBUTION%_SECTION_PARAMETERS_",& - i_val=debug_print_level,error=error) + i_val=debug_print_level) CALL section_vals_val_set(dft_section,"SCF%PRINT%TOTAL_DENSITIES%_SECTION_PARAMETERS_",& - i_val=debug_print_level,error=error) + i_val=debug_print_level) CALL section_vals_val_set(dft_section,"SCF%PRINT%DETAILED_ENERGY%_SECTION_PARAMETERS_",& - i_val=debug_print_level,error=error) - CALL section_vals_add_values(admm_section,error) + i_val=debug_print_level) + CALL section_vals_add_values(admm_section) CALL section_vals_val_set(admm_section,"ADMM_PURIFICATION_METHOD",& - i_val=do_admm_purify_mo_diag,error=error) - CALL section_vals_val_set(admm_section,"METHOD",i_val=do_admm_basis_projection,error=error) + i_val=do_admm_purify_mo_diag) + CALL section_vals_val_set(admm_section,"METHOD",i_val=do_admm_basis_projection) ! add the new basis file containing the templates to the basis file list - CALL section_vals_val_get(dft_section,"BASIS_SET_FILE_NAME",n_rep_val=nbasis,error=error) + CALL section_vals_val_get(dft_section,"BASIS_SET_FILE_NAME",n_rep_val=nbasis) CALL section_vals_val_set(dft_section,"BASIS_SET_FILE_NAME",i_rep_val=nbasis+1,& - c_val=basis_optimization%work_basis_file,error=error) + c_val=basis_optimization%work_basis_file) ! Set the auxilarry basis in the kind sections - CALL section_vals_get(kind_section,n_repetition=nkind,error=error) + CALL section_vals_get(kind_section,n_repetition=nkind) DO ikind=1,nkind CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",& - c_val=atom,i_rep_section=ikind,error=error) + c_val=atom,i_rep_section=ikind) CALL uppercase(atom) CALL section_vals_val_get(kind_section,"BASIS_SET",& - c_val=orig_basis,i_rep_section=ikind,error=error) + c_val=orig_basis,i_rep_section=ikind) CALL section_vals_val_set(kind_section,"AUX_FIT_BASIS_SET",& - c_val=orig_basis,i_rep_section=ikind,error=error) + c_val=orig_basis,i_rep_section=ikind) DO jkind=1,basis_optimization%nkind IF(atom==basis_optimization%kind_basis(jkind)%element)THEN @@ -144,7 +142,7 @@ SUBROUTINE modify_input_settings(basis_optimization,bas_id,input_file,error) ibasis=basis_optimization%combination(bas_id,jkind) CALL section_vals_val_set(kind_section,"AUX_FIT_BASIS_SET",& c_val=TRIM(ADJUSTL(basis_optimization%kind_basis(jkind)%flex_basis(ibasis)%basis_name)),& - i_rep_section=ikind,error=error) + i_rep_section=ikind) EXIT END IF END DO @@ -155,11 +153,9 @@ END SUBROUTINE modify_input_settings ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_mo_sets(qs_env,error) + SUBROUTINE allocate_mo_sets(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_mo_sets', & routineP = moduleN//':'//routineN @@ -194,35 +190,30 @@ SUBROUTINE allocate_mo_sets(qs_env,error) scf_control=scf_control,& particle_set=particle_set,& admm_env=admm_env,& - para_env=para_env,& - error=error) - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) + para_env=para_env) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") - CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools,& - error=error) + CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools) DO ispin=1,dft_control%nspins IF (.NOT.ASSOCIATED(mos(ispin)%mo_set%mo_coeff)) THEN CALL init_mo_set(mos(ispin)%mo_set,& ao_mo_fm_pools(ispin)%pool,& name="qs_env"//TRIM(ADJUSTL(cp_to_string(qs_env%id_nr)))//& - "%mo"//TRIM(ADJUSTL(cp_to_string(ispin))),& - error=error) + "%mo"//TRIM(ADJUSTL(cp_to_string(ispin)))) END IF END DO CALL read_mo_set(mos,atomic_kind_set,qs_kind_set,particle_set,para_env,& id_nr=0,multiplicity=dft_control%multiplicity,dft_section=dft_section,& - natom_mismatch=natom_mismatch,error=error) + natom_mismatch=natom_mismatch) - CALL mpools_get(qs_env%mpools_aux_fit, ao_mo_fm_pools=ao_mo_fm_pools_aux_fit,& - error=error) + CALL mpools_get(qs_env%mpools_aux_fit, ao_mo_fm_pools=ao_mo_fm_pools_aux_fit) DO ispin=1,dft_control%nspins IF (.NOT.ASSOCIATED(mos_aux_fit(ispin)%mo_set%mo_coeff)) THEN CALL init_mo_set(mos_aux_fit(ispin)%mo_set,& ao_mo_fm_pools_aux_fit(ispin)%pool,& name="qs_env"//TRIM(ADJUSTL(cp_to_string(qs_env%id_nr)))//& - "%mo_aux_fit"//TRIM(ADJUSTL(cp_to_string(ispin))),& - error=error) + "%mo_aux_fit"//TRIM(ADJUSTL(cp_to_string(ispin)))) END IF END DO @@ -231,11 +222,9 @@ END SUBROUTINE allocate_mo_sets ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_ks_matrix(qs_env,error) + SUBROUTINE calculate_ks_matrix(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ks_matrix', & routineP = moduleN//':'//routineN @@ -248,18 +237,18 @@ SUBROUTINE calculate_ks_matrix(qs_env,error) NULLIFY(rho, dft_control, rho_ao) - CALL qs_energies_init(qs_env,.FALSE.,error) - CALL get_qs_env(qs_env, rho=rho, dft_control=dft_control, error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_energies_init(qs_env,.FALSE.) + CALL get_qs_env(qs_env, rho=rho, dft_control=dft_control) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1, dft_control%nspins - CALL calculate_density_matrix(qs_env%mos(ispin)%mo_set,rho_ao(ispin)%matrix,error=error) + CALL calculate_density_matrix(qs_env%mos(ispin)%mo_set,rho_ao(ispin)%matrix) END DO - CALL qs_rho_update_rho(rho, qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.,error=error) + CALL qs_rho_update_rho(rho, qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) qs_env%requires_mo_derivs=.FALSE. dft_control%do_admm=.FALSE. dft_control%do_admm_mo=.FALSE. - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., error=error) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.) dft_control%do_admm=.TRUE. dft_control%do_admm_mo=.TRUE. @@ -271,14 +260,12 @@ END SUBROUTINE calculate_ks_matrix !> \param matrix_s_inv ... !> \param para_env ... !> \param context ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_overlap_inverse(matrix_s,matrix_s_inv,para_env,context,error) + SUBROUTINE calculate_overlap_inverse(matrix_s,matrix_s_inv,para_env,context) TYPE(cp_dbcsr_type), POINTER :: matrix_s TYPE(cp_fm_type), POINTER :: matrix_s_inv TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: context - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_overlap_inverse', & routineP = moduleN//':'//routineN @@ -289,17 +276,17 @@ SUBROUTINE calculate_overlap_inverse(matrix_s,matrix_s_inv,para_env,context,erro CALL cp_dbcsr_get_info(matrix_s,nfullrows_total=nao) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=nao,& - para_env=para_env, context=context,error=error) - - CALL cp_fm_create(matrix_s_inv,matrix_struct=fm_struct_tmp,error=error) - CALL cp_fm_create(work1,matrix_struct=fm_struct_tmp,error=error) - CALL copy_dbcsr_to_fm(matrix_s,matrix_s_inv,error=error) - CALL cp_fm_upper_to_full(matrix_s_inv,work1,error=error) - CALL cp_fm_cholesky_decompose(matrix_s_inv,error=error) - CALL cp_fm_cholesky_invert(matrix_s_inv,error=error) - CALL cp_fm_upper_to_full(matrix_s_inv,work1,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error) - CALL cp_fm_release(work1,error=error) + para_env=para_env, context=context) + + CALL cp_fm_create(matrix_s_inv,matrix_struct=fm_struct_tmp) + CALL cp_fm_create(work1,matrix_struct=fm_struct_tmp) + CALL copy_dbcsr_to_fm(matrix_s,matrix_s_inv) + CALL cp_fm_upper_to_full(matrix_s_inv,work1) + CALL cp_fm_cholesky_decompose(matrix_s_inv) + CALL cp_fm_cholesky_invert(matrix_s_inv) + CALL cp_fm_upper_to_full(matrix_s_inv,work1) + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_release(work1) END SUBROUTINE calculate_overlap_inverse @@ -307,12 +294,10 @@ END SUBROUTINE calculate_overlap_inverse !> \brief ... !> \param ks_env ... !> \param S_type ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_overlap(ks_env,S_type,error) + SUBROUTINE calculate_overlap(ks_env,S_type) TYPE(qs_ks_env_type), POINTER :: ks_env CHARACTER(LEN=*) :: S_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_overlap', & routineP = moduleN//':'//routineN @@ -327,36 +312,31 @@ SUBROUTINE calculate_overlap(ks_env,S_type,error) IF(S_type=="S_AB")THEN CALL get_ks_env(ks_env,& matrix_s=matrix_s,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) CALL build_overlap_matrix(ks_env,matrix_s=matrix_s,& matrix_name="OVERLAP",& basis_type_a="ORB",& basis_type_b="ORB", & - sab_nl=sab_orb,& - error=error) - CALL set_ks_env(ks_env,matrix_s=matrix_s,error=error) + sab_nl=sab_orb) + CALL set_ks_env(ks_env,matrix_s=matrix_s) ELSE IF(S_type=="S_AB_AUX")THEN CALL get_ks_env(ks_env,& matrix_s_aux_fit=matrix_s_aux_fit,& matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb,& sab_aux_fit=sab_aux_fit,& - sab_aux_fit_vs_orb=sab_aux_fit_vs_orb,& - error=error) + sab_aux_fit_vs_orb=sab_aux_fit_vs_orb) CALL build_overlap_matrix(ks_env,matrix_s=matrix_s_aux_fit,& matrix_name="AUX_FIT_OVERLAP",& basis_type_a="AUX_FIT",& basis_type_b="AUX_FIT", & - sab_nl=sab_aux_fit,& - error=error) + sab_nl=sab_aux_fit) CALL build_overlap_matrix(ks_env,matrix_s=matrix_s_aux_fit_vs_orb,& matrix_name="MIXED_OVERLAP",& basis_type_a="AUX_FIT",& basis_type_b="ORB", & - sab_nl=sab_aux_fit_vs_orb,& - error=error) + sab_nl=sab_aux_fit_vs_orb) CALL set_ks_env(ks_env,matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb,& - matrix_s_aux_fit=matrix_s_aux_fit,error=error) + matrix_s_aux_fit=matrix_s_aux_fit) END IF END SUBROUTINE calculate_overlap @@ -364,11 +344,9 @@ END SUBROUTINE calculate_overlap ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_opt_admm_env(qs_env,error) + SUBROUTINE create_opt_admm_env(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_opt_admm_env', & routineP = moduleN//':'//routineN @@ -389,11 +367,10 @@ SUBROUTINE create_opt_admm_env(qs_env,error) mos=mos,& mos_aux_fit=mos_aux_fit,& particle_set=particle_set,& - para_env=para_env,& - error=error) + para_env=para_env) natoms = SIZE(particle_set,1) CALL admm_env_create(qs_env%admm_env, dft_control%admm_control, mos, mos_aux_fit,& - para_env, natoms, error) + para_env, natoms) END SUBROUTINE create_opt_admm_env @@ -402,13 +379,11 @@ END SUBROUTINE create_opt_admm_env !> \param opt_bas ... !> \param bas_id ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE update_basis_set(opt_bas,bas_id,qs_env,error) + SUBROUTINE update_basis_set(opt_bas,bas_id,qs_env) TYPE(basis_optimization_type) :: opt_bas INTEGER :: bas_id TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_basis_set', & routineP = moduleN//':'//routineN @@ -423,7 +398,7 @@ SUBROUTINE update_basis_set(opt_bas,bas_id,qs_env,error) POINTER :: qs_kind_set CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,& - atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set,error=error) + atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set) DO ikind=1,SIZE(qs_kind_set) DO jkind=1,opt_bas%nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=elem) @@ -431,14 +406,14 @@ SUBROUTINE update_basis_set(opt_bas,bas_id,qs_env,error) IF(elem==opt_bas%kind_basis(jkind)%element)THEN ibasis=opt_bas%combination(bas_id,jkind) CALL get_basis_from_container(qs_kind_set(ikind)%basis_sets,basis_set=gto_basis,& - basis_type="AUX_FIT",error=error) - CALL transfer_data_to_gto(gto_basis,opt_bas%kind_basis(jkind)%flex_basis(ibasis),error) - CALL init_orb_basis_set(gto_basis,error) + basis_type="AUX_FIT") + CALL transfer_data_to_gto(gto_basis,opt_bas%kind_basis(jkind)%flex_basis(ibasis)) + CALL init_orb_basis_set(gto_basis) END IF END DO END DO - CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set,qs_kind_set,error) + CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set,qs_kind_set) END SUBROUTINE update_basis_set @@ -446,12 +421,10 @@ END SUBROUTINE update_basis_set !> \brief ... !> \param gto_basis ... !> \param basis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE transfer_data_to_gto(gto_basis,basis,error) + SUBROUTINE transfer_data_to_gto(gto_basis,basis) TYPE(gto_basis_set_type), POINTER :: gto_basis TYPE(flex_basis_type) :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'transfer_data_to_gto', & routineP = moduleN//':'//routineN diff --git a/src/optbas_opt_utils.F b/src/optbas_opt_utils.F index 8d83d9e643..809cb5452d 100644 --- a/src/optbas_opt_utils.F +++ b/src/optbas_opt_utils.F @@ -38,16 +38,14 @@ MODULE optbas_opt_utils !> \param Q ... !> \param tmp1 ... !> \param energy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE evaluate_energy(mos,matrix_ks,S_inv_orb,Q,tmp1,energy,error) + SUBROUTINE evaluate_energy(mos,matrix_ks,S_inv_orb,Q,tmp1,energy) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks TYPE(cp_fm_type), POINTER :: S_inv_orb, Q, tmp1 REAL(KIND=dp) :: energy - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'evaluate_energy', & routineP = moduleN//':'//routineN @@ -57,33 +55,33 @@ SUBROUTINE evaluate_energy(mos,matrix_ks,S_inv_orb,Q,tmp1,energy,error) TYPE(cp_fm_type), POINTER :: mo_coeff, QS_inv, tmp, tmp2, & work, work_orb - CALL cp_fm_create(QS_inv,matrix_struct=Q%matrix_struct,error=error) - CALL cp_fm_create(tmp,matrix_struct=Q%matrix_struct,error=error) - CALL cp_fm_create(tmp2,matrix_struct=tmp1%matrix_struct,error=error) - CALL cp_fm_create(work,matrix_struct=S_inv_orb%matrix_struct,error=error) - CALL cp_fm_create(work_orb,matrix_struct=S_inv_orb%matrix_struct,error=error) - CALL cp_fm_get_info(Q,nrow_global=naux,ncol_global=norb,error=error) - CALL cp_gemm('N','N',naux,norb,norb,1.0_dp,Q,S_inv_orb,0.0_dp,QS_inv,error) + CALL cp_fm_create(QS_inv,matrix_struct=Q%matrix_struct) + CALL cp_fm_create(tmp,matrix_struct=Q%matrix_struct) + CALL cp_fm_create(tmp2,matrix_struct=tmp1%matrix_struct) + CALL cp_fm_create(work,matrix_struct=S_inv_orb%matrix_struct) + CALL cp_fm_create(work_orb,matrix_struct=S_inv_orb%matrix_struct) + CALL cp_fm_get_info(Q,nrow_global=naux,ncol_global=norb) + CALL cp_gemm('N','N',naux,norb,norb,1.0_dp,Q,S_inv_orb,0.0_dp,QS_inv) energy=0.0_dp DO ispin=1,SIZE(matrix_ks) - CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,work,error=error) - CALL cp_fm_upper_to_full(work,work_orb,error=error) + CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,work) + CALL cp_fm_upper_to_full(work,work_orb) CALL get_mo_set(mos(ispin)%mo_set,nmo=nmo,mo_coeff=mo_coeff) - CALL cp_gemm('N','N',naux,norb,norb,1.0_dp,QS_inv,work,0.0_dp,tmp,error) - CALL cp_gemm('N','T',naux,naux,norb,1.0_dp,tmp,QS_inv,0.0_dp,tmp1,error) - CALL cp_gemm('N','T',naux,naux,nmo,1.0_dp,mo_coeff,mo_coeff,0.0_dp,tmp2,error) - CALL cp_fm_trace(tmp1,tmp2,tmp_energy,error) + CALL cp_gemm('N','N',naux,norb,norb,1.0_dp,QS_inv,work,0.0_dp,tmp) + CALL cp_gemm('N','T',naux,naux,norb,1.0_dp,tmp,QS_inv,0.0_dp,tmp1) + CALL cp_gemm('N','T',naux,naux,nmo,1.0_dp,mo_coeff,mo_coeff,0.0_dp,tmp2) + CALL cp_fm_trace(tmp1,tmp2,tmp_energy) energy=energy+tmp_energy*(3.0_dp-REAL(SIZE(matrix_ks),dp)) END DO - CALL cp_fm_release(work_orb,error) - CALL cp_fm_release(QS_inv,error) - CALL cp_fm_release(tmp,error) - CALL cp_fm_release(tmp2,error) - CALL cp_fm_release(work,error) - CALL cp_fm_release(work_orb,error) + CALL cp_fm_release(work_orb) + CALL cp_fm_release(QS_inv) + CALL cp_fm_release(tmp) + CALL cp_fm_release(tmp2) + CALL cp_fm_release(work) + CALL cp_fm_release(work_orb) END SUBROUTINE evaluate_energy @@ -96,15 +94,13 @@ END SUBROUTINE evaluate_energy !> \param admm_env ... !> \param fval ... !> \param S_cond_number ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE evaluate_fval(mos,mos_aux_fit,Q,Snew,admm_env,fval,S_cond_number,error) + SUBROUTINE evaluate_fval(mos,mos_aux_fit,Q,Snew,admm_env,fval,S_cond_number) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos, mos_aux_fit TYPE(cp_dbcsr_type), POINTER :: Q, Snew TYPE(admm_type), POINTER :: admm_env REAL(KIND=dp) :: fval, S_cond_number - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'evaluate_fval', & routineP = moduleN//':'//routineN @@ -119,7 +115,7 @@ SUBROUTINE evaluate_fval(mos,mos_aux_fit,Q,Snew,admm_env,fval,S_cond_number,erro nao_orb = admm_env%nao_orb nspins = SIZE(mos) - CALL copy_dbcsr_to_fm(Q,admm_env%Q,error) + CALL copy_dbcsr_to_fm(Q,admm_env%Q) fval=0.0_dp DO ispin=1,nspins nmo = admm_env%nmo(ispin) @@ -127,14 +123,14 @@ SUBROUTINE evaluate_fval(mos,mos_aux_fit,Q,Snew,admm_env,fval,S_cond_number,erro CALL get_mo_set(mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) CALL cp_gemm('N','N',nao_aux_fit,nmo,nao_orb,-2.0_dp,admm_env%Q,mo_coeff,& - 0.0_dp,admm_env%work_aux_nmo(ispin)%matrix,error) - CALL cp_fm_trace(mo_coeff_aux_fit,admm_env%work_aux_nmo(ispin)%matrix,trace,error) + 0.0_dp,admm_env%work_aux_nmo(ispin)%matrix) + CALL cp_fm_trace(mo_coeff_aux_fit,admm_env%work_aux_nmo(ispin)%matrix,trace) fval=fval+trace+2.0_dp*nmo END DO ALLOCATE(eigenvalues(nao_aux_fit)) - CALL copy_dbcsr_to_fm(Snew,admm_env%work_aux_aux,error) - CALL cp_fm_syevd(admm_env%work_aux_aux,admm_env%work_aux_aux2,eigenvalues,error=error) + CALL copy_dbcsr_to_fm(Snew,admm_env%work_aux_aux) + CALL cp_fm_syevd(admm_env%work_aux_aux,admm_env%work_aux_aux2,eigenvalues) S_cond_number=MAXVAL(ABS(eigenvalues))/MAX(MINVAL(ABS(eigenvalues)),EPSILON(0.0_dp)) DEALLOCATE(eigenvalues) diff --git a/src/optimize_basis.F b/src/optimize_basis.F index 97d719e5cb..c1de7f9757 100644 --- a/src/optimize_basis.F +++ b/src/optimize_basis.F @@ -72,14 +72,12 @@ MODULE optimize_basis !> \param input_declaration ... !> \param root_section ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE run_optimize_basis(input_declaration,root_section,para_env,error) + SUBROUTINE run_optimize_basis(input_declaration,root_section,para_env) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'run_optimize_basis', & routineP = moduleN//':'//routineN @@ -89,9 +87,9 @@ SUBROUTINE run_optimize_basis(input_declaration,root_section,para_env,error) CALL timeset(routineN,handle) - CALL optimize_basis_init_read_input(opt_bas,root_section,para_env,error) + CALL optimize_basis_init_read_input(opt_bas,root_section,para_env) - CALL driver_para_opt_basis(opt_bas,input_declaration,para_env,error) + CALL driver_para_opt_basis(opt_bas,input_declaration,para_env) CALL deallocate_basis_optimization_type(opt_bas) CALL timestop(handle) @@ -104,15 +102,13 @@ END SUBROUTINE run_optimize_basis !> \param opt_bas ... !> \param input_declaration ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE driver_para_opt_basis(opt_bas,input_declaration,para_env,error) + SUBROUTINE driver_para_opt_basis(opt_bas,input_declaration,para_env) TYPE(basis_optimization_type) :: opt_bas TYPE(section_type), POINTER :: input_declaration TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'driver_para_opt_basis', & routineP = moduleN//':'//routineN @@ -129,7 +125,7 @@ SUBROUTINE driver_para_opt_basis(opt_bas,input_declaration,para_env,error) n_subgroups=SIZE(opt_bas%group_partition),group_partition=opt_bas%group_partition) opt_bas%opt_id = group_distribution(para_env%mepos)+1 - CALL driver_optimization_para_low(opt_bas,input_declaration,para_env,opt_group,error) + CALL driver_optimization_para_low(opt_bas,input_declaration,para_env,opt_group) CALL mp_comm_free(opt_group) CALL timestop(handle) @@ -143,16 +139,14 @@ END SUBROUTINE driver_para_opt_basis !> \param input_declaration ... !> \param para_env_top ... !> \param mpi_comm_opt ... -!> \param top_error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE driver_optimization_para_low(opt_bas,input_declaration,para_env_top,mpi_comm_opt,top_error) + SUBROUTINE driver_optimization_para_low(opt_bas,input_declaration,para_env_top,mpi_comm_opt) TYPE(basis_optimization_type) :: opt_bas TYPE(section_type), POINTER :: input_declaration TYPE(cp_para_env_type), POINTER :: para_env_top INTEGER :: mpi_comm_opt - TYPE(cp_error_type), INTENT(INOUT) :: top_error CHARACTER(len=*), PARAMETER :: routineN = 'driver_optimization_para_low', & routineP = moduleN//':'//routineN @@ -162,7 +156,6 @@ SUBROUTINE driver_optimization_para_low(opt_bas,input_declaration,para_env_top,m INTEGER, ALLOCATABLE, DIMENSION(:) :: f_env_id LOGICAL :: failure, write_basis REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tot_time - TYPE(cp_error_type) :: error TYPE(cp_fm_p_type), ALLOCATABLE, & DIMENSION(:) :: matrix_S_inv TYPE(cp_para_env_type), POINTER :: para_env @@ -181,27 +174,27 @@ SUBROUTINE driver_optimization_para_low(opt_bas,input_declaration,para_env_top,m ALLOCATE(matrix_s_inv(SIZE(opt_bas%comp_group(mp_id)%member_list))) CALL cp_para_env_create(para_env, group=mpi_comm_opt,& - owns_group=.FALSE.,error=error) + owns_group=.FALSE.) - CALL init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_inv,para_env,mpi_comm_opt,error) + CALL init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_inv,para_env,mpi_comm_opt) - CALL init_free_vars(opt_bas,error) + CALL init_free_vars(opt_bas) tot_time=0.0_dp ! ======= The real optimization loop ======= DO iopt=0,opt_bas%powell_param%maxfun CALL compute_residuum_vectors(opt_bas,f_env_id,matrix_S_inv,tot_time,& - para_env_top,para_env,iopt,error,top_error) + para_env_top,para_env,iopt) IF(para_env_top%ionode)& CALL powell_optimize (opt_bas%powell_param%nvar, opt_bas%x_opt , opt_bas%powell_param) IF(.NOT.para_env_top%ionode)opt_bas%x_opt=0.0_dp CALL mp_bcast(opt_bas%powell_param%state,para_env_top%source,para_env_top%group) CALL mp_sum(opt_bas%x_opt,para_env_top%group) - CALL update_free_vars(opt_bas,error) + CALL update_free_vars(opt_bas) write_basis=MOD(iopt,opt_bas%write_frequency)==0 CALL update_derived_basis_sets(opt_bas,write_basis,opt_bas%output_basis_file,& - para_env_top,top_error) + para_env_top) IF(opt_bas%powell_param%state==-1)EXIT END DO @@ -213,19 +206,19 @@ SUBROUTINE driver_optimization_para_low(opt_bas,input_declaration,para_env_top,m IF(.NOT.para_env_top%ionode)opt_bas%x_opt=0.0_dp CALL mp_sum(opt_bas%x_opt,para_env_top%group) - CALL update_free_vars(opt_bas,error) + CALL update_free_vars(opt_bas) CALL update_derived_basis_sets(opt_bas,.TRUE.,opt_bas%output_basis_file,& - para_env_top,top_error) + para_env_top) ! ====== get rid of the f_env again ===== DO icalc=SIZE(opt_bas%comp_group(mp_id)%member_list),1,-1 - CALL f_env_get_from_id(f_env_id(icalc),f_env,error) + CALL f_env_get_from_id(f_env_id(icalc),f_env) CALL destroy_force_env(f_env_id(icalc), stat) - CALL cp_fm_release(matrix_s_inv(icalc)%matrix,error) + CALL cp_fm_release(matrix_s_inv(icalc)%matrix) END DO DEALLOCATE(f_env_id); DEALLOCATE(tot_time); DEALLOCATE(matrix_S_inv) - CALL cp_para_env_release(para_env,error=error) + CALL cp_para_env_release(para_env) CALL timestop(handle) END SUBROUTINE driver_optimization_para_low @@ -241,20 +234,16 @@ END SUBROUTINE driver_optimization_para_low !> \param para_env_top ... !> \param para_env ... !> \param iopt ... -!> \param error ... -!> \param top_error ... -!>\author Florian Schiffmann ! ***************************************************************************** SUBROUTINE compute_residuum_vectors(opt_bas,f_env_id,matrix_S_inv,tot_time,& - para_env_top,para_env,iopt,error,top_error) + para_env_top,para_env,iopt) TYPE(basis_optimization_type) :: opt_bas INTEGER, ALLOCATABLE, DIMENSION(:) :: f_env_id TYPE(cp_fm_p_type), DIMENSION(:) :: matrix_S_inv REAL(KIND=dp), DIMENSION(:) :: tot_time TYPE(cp_para_env_type), POINTER :: para_env_top, para_env INTEGER :: iopt - TYPE(cp_error_type) :: error, top_error CHARACTER(len=*), PARAMETER :: routineN = 'compute_residuum_vectors', & routineP = moduleN//':'//routineN @@ -287,25 +276,24 @@ SUBROUTINE compute_residuum_vectors(opt_bas,f_env_id,matrix_S_inv,tot_time,& start_time(icalc)=m_walltime() CALL get_set_and_basis_id(opt_bas%comp_group(mp_id)%member_list(icalc),opt_bas,set_id,bas_id) - CALL f_env_get_from_id(f_env_id(icalc),f_env,error) + CALL f_env_get_from_id(f_env_id(icalc),f_env) force_env => f_env%force_env - CALL force_env_get(force_env,qs_env=qs_env,error=error) - CALL get_qs_env(qs_env, ks_env=ks_env, error=error) - CALL update_basis_set(opt_bas,bas_id,qs_env,error) - CALL build_qs_neighbor_lists(qs_env,para_env,molecular=.FALSE.,force_env_section=qs_env%input,error=error) - CALL calculate_overlap(ks_env,"S_AB_AUX",error) + CALL force_env_get(force_env,qs_env=qs_env) + CALL get_qs_env(qs_env, ks_env=ks_env) + CALL update_basis_set(opt_bas,bas_id,qs_env) + CALL build_qs_neighbor_lists(qs_env,para_env,molecular=.FALSE.,force_env_section=qs_env%input) + CALL calculate_overlap(ks_env,"S_AB_AUX") CALL get_qs_env(qs_env,& matrix_ks=matrix_ks,& matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb,& - matrix_s_aux_fit=matrix_s_aux_fit,& - error=error) + matrix_s_aux_fit=matrix_s_aux_fit) CALL admm_fit_mo_coeffs(qs_env%admm_env, matrix_s_aux_fit,& matrix_s_aux_fit_vs_orb, qs_env%mos, qs_env%mos_aux_fit,& - geometry_did_change=.TRUE. , error=error) + geometry_did_change=.TRUE.) CALL evaluate_fval(qs_env%mos,qs_env%mos_aux_fit,matrix_s_aux_fit_vs_orb(1)%matrix,& - matrix_s_aux_fit(1)%matrix,qs_env%admm_env,f_vec(my_id),cond_vec(my_id),error) + matrix_s_aux_fit(1)%matrix,qs_env%admm_env,f_vec(my_id),cond_vec(my_id)) CALL evaluate_energy(qs_env%mos_aux_fit,matrix_ks,matrix_s_inv(icalc)%matrix,qs_env%admm_env%Q,& - qs_env%admm_env%work_aux_aux,energy(my_id),error) + qs_env%admm_env%work_aux_aux,energy(my_id)) my_time(my_id)=m_walltime()-start_time(icalc) IF(.NOT.para_env%ionode)THEN @@ -329,7 +317,7 @@ SUBROUTINE compute_residuum_vectors(opt_bas,f_env_id,matrix_S_inv,tot_time,& CALL mp_sync(para_env_top%group) ! output info if required - CALL output_opt_info(f_vec,cond_vec,my_time,tot_time,opt_bas,iopt,para_env_top,top_error) + CALL output_opt_info(f_vec,cond_vec,my_time,tot_time,opt_bas,iopt,para_env_top) DEALLOCATE(f_vec); DEALLOCATE(my_time); DEALLOCATE(cond_vec); DEALLOCATE(energy) CALL timestop(handle) @@ -344,11 +332,9 @@ END SUBROUTINE compute_residuum_vectors !> \param matrix_s_inv ... !> \param para_env ... !> \param mpi_comm_opt ... -!> \param error ... -!>\author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_inv,para_env,mpi_comm_opt,error) + SUBROUTINE init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_inv,para_env,mpi_comm_opt) TYPE(basis_optimization_type) :: opt_bas INTEGER, ALLOCATABLE, DIMENSION(:) :: f_env_id @@ -356,7 +342,6 @@ SUBROUTINE init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_ TYPE(cp_fm_p_type), DIMENSION(:) :: matrix_S_inv TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: mpi_comm_opt - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_training_force_envs', & routineP = moduleN//':'//routineN @@ -368,8 +353,6 @@ SUBROUTINE init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_ TYPE(cp_blacs_env_type), POINTER :: blacs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_s - TYPE(cp_error_type), ALLOCATABLE, & - DIMENSION(:) :: suberror TYPE(f_env_type), POINTER :: f_env TYPE(force_env_type), POINTER :: force_env TYPE(qs_environment_type), POINTER :: qs_env @@ -381,7 +364,6 @@ SUBROUTINE init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_ mp_id=opt_bas%opt_id CALL m_getcwd(main_dir) - ALLOCATE(suberror(SIZE(opt_bas%comp_group(mp_id)%member_list))) ! ======= Create f_env for all calculations in MPI group ======= DO icalc=1,SIZE(opt_bas%comp_group(mp_id)%member_list) @@ -389,13 +371,13 @@ SUBROUTINE init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_ ! parse the input of the training sets CALL get_set_and_basis_id(opt_bas%comp_group(mp_id)%member_list(icalc),opt_bas,set_id,bas_id) CALL m_chdir(TRIM(opt_bas%training_dir(set_id)),ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) input_file => read_input(input_declaration,& opt_bas%training_input(set_id),& initial_variables=empty_initial_variables, & - para_env=para_env,error=error) + para_env=para_env) - CALL modify_input_settings(opt_bas,bas_id,input_file,error) + CALL modify_input_settings(opt_bas,bas_id,input_file) CALL create_force_env(f_env_id(icalc), & input_declaration=input_declaration,& input_path=opt_bas%training_input(set_id),& @@ -406,26 +388,25 @@ SUBROUTINE init_training_force_envs(opt_bas,f_env_id,input_declaration,matrix_s_ ! some weirdness with the default stacks defaults have to be addded to get the ! correct default program name this causes trouble with the timer stack if kept - CALL f_env_add_defaults(f_env_id(icalc), f_env, suberror(icalc), failure) + CALL f_env_add_defaults(f_env_id(icalc), f_env, failure) force_env => f_env%force_env - CALL force_env_get(force_env,qs_env=qs_env,error=error) - CALL allocate_mo_sets(qs_env,error) - CALL f_env_rm_defaults(f_env, suberror(icalc),stat) - CALL get_qs_env(qs_env, ks_env=ks_env, error=error) + CALL force_env_get(force_env,qs_env=qs_env) + CALL allocate_mo_sets(qs_env) + CALL f_env_rm_defaults(f_env,stat) + CALL get_qs_env(qs_env, ks_env=ks_env) CALL build_qs_neighbor_lists(qs_env,para_env,molecular=.FALSE.,& - force_env_section=qs_env%input,error=error) - CALL calculate_overlap(ks_env,"S_AB",error) - CALL get_qs_env(qs_env, matrix_s=matrix_s, blacs_env=blacs_env, error=error) + force_env_section=qs_env%input) + CALL calculate_overlap(ks_env,"S_AB") + CALL get_qs_env(qs_env, matrix_s=matrix_s, blacs_env=blacs_env) CALL calculate_overlap_inverse(matrix_s(1)%matrix,matrix_s_inv(icalc)%matrix,& - para_env,blacs_env,error) - CALL calculate_ks_matrix(qs_env,suberror(icalc)) + para_env,blacs_env) + CALL calculate_ks_matrix(qs_env) - CALL create_opt_admm_env(qs_env,error) - CALL section_vals_release(input_file,error=error) + CALL create_opt_admm_env(qs_env) + CALL section_vals_release(input_file) CALL m_chdir(TRIM(ADJUSTL(main_dir)),ierr) END DO - DEALLOCATE(suberror) CALL timestop(handle) @@ -434,13 +415,11 @@ END SUBROUTINE init_training_force_envs ! ***************************************************************************** !> \brief variable update from the powell vector for all sets !> \param opt_bas ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE update_free_vars(opt_bas,error) + SUBROUTINE update_free_vars(opt_bas) TYPE(basis_optimization_type) :: opt_bas - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_free_vars', & routineP = moduleN//':'//routineN @@ -451,7 +430,7 @@ SUBROUTINE update_free_vars(opt_bas,error) ix=0 DO ikind=1,opt_bas%nkind DO iset=1,opt_bas%kind_basis(ikind)%flex_basis(0)%nsets - CALL update_subset_freevars(opt_bas%kind_basis(ikind)%flex_basis(0)%subset(iset),ix,opt_bas%x_opt,error) + CALL update_subset_freevars(opt_bas%kind_basis(ikind)%flex_basis(0)%subset(iset),ix,opt_bas%x_opt) END DO END DO CALL timestop(handle) @@ -463,15 +442,13 @@ END SUBROUTINE update_free_vars !> \param subset ... !> \param ix ... !> \param x ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE update_subset_freevars(subset,ix,x,error) + SUBROUTINE update_subset_freevars(subset,ix,x) TYPE(subset_type) :: subset INTEGER :: ix REAL(KIND=dp), DIMENSION(:) :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_subset_freevars', & routineP = moduleN//':'//routineN @@ -526,13 +503,11 @@ END SUBROUTINE update_subset_freevars ! ***************************************************************************** !> \brief variable initialization for the powell vector for all sets !> \param opt_bas ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE init_free_vars(opt_bas,error) + SUBROUTINE init_free_vars(opt_bas) TYPE(basis_optimization_type) :: opt_bas - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_free_vars', & routineP = moduleN//':'//routineN @@ -543,7 +518,7 @@ SUBROUTINE init_free_vars(opt_bas,error) ix=0 DO ikind=1,opt_bas%nkind DO iset=1,opt_bas%kind_basis(ikind)%flex_basis(0)%nsets - CALL init_subset_freevars(opt_bas%kind_basis(ikind)%flex_basis(0)%subset(iset),ix,opt_bas%x_opt,error) + CALL init_subset_freevars(opt_bas%kind_basis(ikind)%flex_basis(0)%subset(iset),ix,opt_bas%x_opt) END DO END DO CALL timestop(handle) @@ -556,15 +531,13 @@ END SUBROUTINE init_free_vars !> \param subset ... !> \param ix ... !> \param x ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE init_subset_freevars(subset,ix,x,error) + SUBROUTINE init_subset_freevars(subset,ix,x) TYPE(subset_type) :: subset INTEGER :: ix REAL(KIND=dp), DIMENSION(:) :: x - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_subset_freevars', & routineP = moduleN//':'//routineN @@ -609,17 +582,15 @@ END SUBROUTINE init_subset_freevars !> \param opt_bas ... !> \param iopt ... !> \param para_env_top ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE output_opt_info(f_vec,cond_vec,my_time,tot_time,opt_bas,iopt,para_env_top,error) + SUBROUTINE output_opt_info(f_vec,cond_vec,my_time,tot_time,opt_bas,iopt,para_env_top) REAL(KIND=dp), DIMENSION(:) :: f_vec, cond_vec, my_time, & tot_time TYPE(basis_optimization_type) :: opt_bas INTEGER :: iopt TYPE(cp_para_env_type), POINTER :: para_env_top - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'output_opt_info', & routineP = moduleN//':'//routineN @@ -629,7 +600,7 @@ SUBROUTINE output_opt_info(f_vec,cond_vec,my_time,tot_time,opt_bas,iopt,para_en TYPE(cp_logger_type), POINTER :: logger CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() tot_time=tot_time+my_time diff --git a/src/optimize_basis_utils.F b/src/optimize_basis_utils.F index b2778a0e4f..d87934f579 100644 --- a/src/optimize_basis_utils.F +++ b/src/optimize_basis_utils.F @@ -48,15 +48,13 @@ MODULE optimize_basis_utils !> \param opt_bas ... !> \param root_section ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE optimize_basis_init_read_input(opt_bas,root_section,para_env,error) + SUBROUTINE optimize_basis_init_read_input(opt_bas,root_section,para_env) TYPE(basis_optimization_type) :: opt_bas TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'optimize_basis_init_read_input', & @@ -67,23 +65,23 @@ SUBROUTINE optimize_basis_init_read_input(opt_bas,root_section,para_env,error) TYPE(section_vals_type), POINTER :: kind_section, optbas_section, & powell_section, train_section - optbas_section => section_vals_get_subs_vals(root_section,"OPTIMIZE_BASIS",error=error) - powell_section => section_vals_get_subs_vals(optbas_section,"OPTIMIZATION",error=error) - train_section => section_vals_get_subs_vals(optbas_section,"TRAINING_FILES",error=error) - kind_section => section_vals_get_subs_vals(optbas_section,"FIT_KIND",error=error) + optbas_section => section_vals_get_subs_vals(root_section,"OPTIMIZE_BASIS") + powell_section => section_vals_get_subs_vals(optbas_section,"OPTIMIZATION") + train_section => section_vals_get_subs_vals(optbas_section,"TRAINING_FILES") + kind_section => section_vals_get_subs_vals(optbas_section,"FIT_KIND") - CALL section_vals_val_get(optbas_section,"BASIS_TEMPLATE_FILE",c_val=opt_bas%template_basis_file,error=error) - CALL section_vals_val_get(optbas_section,"BASIS_WORK_FILE",c_val=opt_bas%work_basis_file,error=error) - CALL section_vals_val_get(optbas_section,"BASIS_OUTPUT_FILE",c_val=opt_bas%output_basis_file,error=error) + CALL section_vals_val_get(optbas_section,"BASIS_TEMPLATE_FILE",c_val=opt_bas%template_basis_file) + CALL section_vals_val_get(optbas_section,"BASIS_WORK_FILE",c_val=opt_bas%work_basis_file) + CALL section_vals_val_get(optbas_section,"BASIS_OUTPUT_FILE",c_val=opt_bas%output_basis_file) CALL m_getcwd(main_dir) opt_bas%work_basis_file=TRIM(ADJUSTL(main_dir))//"/"//TRIM(ADJUSTL(opt_bas%work_basis_file)) - CALL section_vals_val_get(optbas_section,"WRITE_FREQUENCY",i_val=opt_bas%write_frequency,error=error) - CALL section_vals_val_get(optbas_section,"USE_CONDITION_NUMBER",l_val=opt_bas%use_condition_number,error=error) + CALL section_vals_val_get(optbas_section,"WRITE_FREQUENCY",i_val=opt_bas%write_frequency) + CALL section_vals_val_get(optbas_section,"USE_CONDITION_NUMBER",l_val=opt_bas%use_condition_number) - CALL generate_initial_basis(kind_section,opt_bas,para_env,error) + CALL generate_initial_basis(kind_section,opt_bas,para_env) - CALL section_vals_get(train_section,n_repetition=opt_bas%ntraining_sets,error=error) + CALL section_vals_get(train_section,n_repetition=opt_bas%ntraining_sets) CALL cp_assert(opt_bas%ntraining_sets/=0,cp_fatal_level,cp_assertion_failed,& routineP,"No training set was specified in the Input",& only_ionode=.TRUE.) @@ -92,48 +90,46 @@ SUBROUTINE optimize_basis_init_read_input(opt_bas,root_section,para_env,error) ALLOCATE(opt_bas%training_dir(opt_bas%ntraining_sets)) DO iset=1,opt_bas%ntraining_sets CALL section_vals_val_get(train_section,"DIRECTORY",c_val=opt_bas%training_dir(iset),& - i_rep_section=iset,error=error) + i_rep_section=iset) CALL section_vals_val_get(train_section,"INPUT_FILE_NAME",c_val=opt_bas%training_input(iset),& - i_rep_section=iset,error=error) + i_rep_section=iset) END DO - CALL init_powell_var(opt_bas%powell_param,powell_section,error) + CALL init_powell_var(opt_bas%powell_param,powell_section) opt_bas%powell_param%nvar=SIZE(opt_bas%x_opt) - CALL generate_derived_basis_sets(opt_bas,para_env,error) + CALL generate_derived_basis_sets(opt_bas,para_env) - CALL generate_basis_combinations(opt_bas,optbas_section,error) + CALL generate_basis_combinations(opt_bas,optbas_section) - CALL section_vals_val_get(optbas_section,"RESIDUUM_WEIGHT",n_rep_val=nrep,error=error) + CALL section_vals_val_get(optbas_section,"RESIDUUM_WEIGHT",n_rep_val=nrep) ALLOCATE(opt_bas%fval_weight(0:opt_bas%ncombinations)) opt_bas%fval_weight=1.0_dp DO iweight=1,nrep CALL section_vals_val_get(optbas_section,"RESIDUUM_WEIGHT",r_val=opt_bas%fval_weight(iweight-1),& - i_rep_val=iweight,error=error) + i_rep_val=iweight) END DO - CALL section_vals_val_get(optbas_section,"CONDITION_WEIGHT",n_rep_val=nrep,error=error) + CALL section_vals_val_get(optbas_section,"CONDITION_WEIGHT",n_rep_val=nrep) ALLOCATE(opt_bas%condition_weight(0:opt_bas%ncombinations)) opt_bas%condition_weight=1.0_dp DO iweight=1,nrep CALL section_vals_val_get(optbas_section,"CONDITION_WEIGHT",r_val=opt_bas%condition_weight(iweight-1),& - i_rep_val=iweight,error=error) + i_rep_val=iweight) END DO - CALL generate_computation_groups(opt_bas,optbas_section,para_env,error) + CALL generate_computation_groups(opt_bas,optbas_section,para_env) - CALL print_opt_info(opt_bas,error) + CALL print_opt_info(opt_bas) END SUBROUTINE optimize_basis_init_read_input ! ***************************************************************************** !> \brief ... !> \param opt_bas ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE print_opt_info(opt_bas,error) + SUBROUTINE print_opt_info(opt_bas) TYPE(basis_optimization_type) :: opt_bas - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_opt_info', & routineP = moduleN//':'//routineN @@ -141,7 +137,7 @@ SUBROUTINE print_opt_info(opt_bas,error) INTEGER :: icomb, ikind, unit_nr TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_nr=-1 IF(logger%para_env%ionode)& unit_nr=cp_logger_get_default_unit_nr(logger) @@ -167,13 +163,11 @@ END SUBROUTINE print_opt_info !> are fitted at the same time (if not specified create all possible) !> \param opt_bas ... !> \param optbas_section ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE generate_basis_combinations(opt_bas,optbas_section,error) + SUBROUTINE generate_basis_combinations(opt_bas,optbas_section) TYPE(basis_optimization_type) :: opt_bas TYPE(section_vals_type), POINTER :: optbas_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_basis_combinations', & routineP = moduleN//':'//routineN @@ -184,7 +178,7 @@ SUBROUTINE generate_basis_combinations(opt_bas,optbas_section,error) !setup the basis combinations to optimize - CALL section_vals_val_get(optbas_section,"BASIS_COMBINATIONS",explicit=explicit,n_rep_val=n_rep,error=error) + CALL section_vals_val_get(optbas_section,"BASIS_COMBINATIONS",explicit=explicit,n_rep_val=n_rep) IF(.NOT.explicit)THEN opt_bas%ncombinations=1 ALLOCATE(tmp_i(opt_bas%nkind)) @@ -215,7 +209,7 @@ SUBROUTINE generate_basis_combinations(opt_bas,optbas_section,error) opt_bas%ncombinations=n_rep ALLOCATE(opt_bas%combination(opt_bas%ncombinations,opt_bas%nkind)) DO i=1,n_rep - CALL section_vals_val_get(optbas_section,"BASIS_COMBINATIONS",i_vals=i_vals,i_rep_val=i,error=error) + CALL section_vals_val_get(optbas_section,"BASIS_COMBINATIONS",i_vals=i_vals,i_rep_val=i) opt_bas%combination(i,:)=i_vals(:) END DO END IF @@ -257,15 +251,13 @@ SUBROUTINE get_set_and_basis_id(calc_id,opt_bas,set_id,bas_id) !> \param opt_bas ... !> \param optbas_section ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE generate_computation_groups(opt_bas,optbas_section,para_env,error) + SUBROUTINE generate_computation_groups(opt_bas,optbas_section,para_env) TYPE(basis_optimization_type) :: opt_bas TYPE(section_vals_type), POINTER :: optbas_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_computation_groups', & routineP = moduleN//':'//routineN @@ -277,7 +269,7 @@ SUBROUTINE generate_computation_groups(opt_bas,optbas_section,para_env,error) nproc=para_env%num_pe ncalc=opt_bas%ncombinations*opt_bas%ntraining_sets - CALL section_vals_val_get(optbas_section,"GROUP_PARTITION",explicit=explicit,error=error) + CALL section_vals_val_get(optbas_section,"GROUP_PARTITION",explicit=explicit) ! No input information available, try to equally distribute IF(.NOT.explicit)THEN @@ -312,7 +304,7 @@ SUBROUTINE generate_computation_groups(opt_bas,optbas_section,para_env,error) ELSE ! Group partition from input. see if all systems can be assigned. If not add to existing group - CALL section_vals_val_get(optbas_section,"GROUP_PARTITION",i_vals=i_vals,error=error) + CALL section_vals_val_get(optbas_section,"GROUP_PARTITION",i_vals=i_vals) isize=SIZE(i_vals) nptot=SUM(i_vals) CALL cp_assert(nptot==nproc,cp_fatal_level,cp_assertion_failed,& @@ -355,15 +347,13 @@ END SUBROUTINE generate_computation_groups !> \param write_it ... !> \param output_file ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE update_derived_basis_sets(opt_bas,write_it,output_file,para_env,error) + SUBROUTINE update_derived_basis_sets(opt_bas,write_it,output_file,para_env) TYPE(basis_optimization_type) :: opt_bas LOGICAL :: write_it CHARACTER(LEN=default_path_length) :: output_file TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_derived_basis_sets', & routineP = moduleN//':'//routineN @@ -374,7 +364,7 @@ SUBROUTINE update_derived_basis_sets(opt_bas,write_it,output_file,para_env,error DO ibasis=1,opt_bas%kind_basis(ikind)%nbasis_deriv CALL update_used_parts(opt_bas%kind_basis(ikind)%deriv_info(ibasis),& opt_bas%kind_basis(ikind)%flex_basis(0),& - opt_bas%kind_basis(ikind)%flex_basis(ibasis),error) + opt_bas%kind_basis(ikind)%flex_basis(ibasis)) END DO END DO @@ -401,14 +391,12 @@ END SUBROUTINE update_derived_basis_sets !> \param info_new ... !> \param basis ... !> \param basis_new ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE update_used_parts(info_new,basis,basis_new,error) + SUBROUTINE update_used_parts(info_new,basis,basis_new) TYPE(derived_basis_info) :: info_new TYPE(flex_basis_type) :: basis, basis_new - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_used_parts', & routineP = moduleN//':'//routineN @@ -436,14 +424,12 @@ END SUBROUTINE update_used_parts !> \brief Initial generation of the basis set from the file and DERIVED_SET !> \param opt_bas ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE generate_derived_basis_sets(opt_bas,para_env,error) + SUBROUTINE generate_derived_basis_sets(opt_bas,para_env) TYPE(basis_optimization_type) :: opt_bas TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_derived_basis_sets', & routineP = moduleN//':'//routineN @@ -452,7 +438,7 @@ SUBROUTINE generate_derived_basis_sets(opt_bas,para_env,error) unit_nr DO ikind=1,opt_bas%nkind - CALL init_deriv_info_ref(opt_bas%kind_basis(ikind)%deriv_info(0),opt_bas%kind_basis(ikind)%flex_basis(0),error) + CALL init_deriv_info_ref(opt_bas%kind_basis(ikind)%deriv_info(0),opt_bas%kind_basis(ikind)%flex_basis(0)) ! initialize the reference set used as template for the rest DO ibasis=1,opt_bas%kind_basis(ikind)%nbasis_deriv iref=opt_bas%kind_basis(ikind)%deriv_info(ibasis)%reference_set @@ -460,7 +446,7 @@ SUBROUTINE generate_derived_basis_sets(opt_bas,para_env,error) IF(iref==jbasis)CALL setup_used_parts_init_basis(opt_bas%kind_basis(ikind)%deriv_info(ibasis),& opt_bas%kind_basis(ikind)%deriv_info(iref),& opt_bas%kind_basis(ikind)%flex_basis(0),& - opt_bas%kind_basis(ikind)%flex_basis(ibasis),error) + opt_bas%kind_basis(ikind)%flex_basis(ibasis)) END DO END DO END DO @@ -522,14 +508,12 @@ END SUBROUTINE write_basis !> \param info_ref ... !> \param basis ... !> \param basis_new ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE setup_used_parts_init_basis(info_new,info_ref,basis,basis_new,error) + SUBROUTINE setup_used_parts_init_basis(info_new,info_ref,basis,basis_new) TYPE(derived_basis_info) :: info_new, info_ref TYPE(flex_basis_type) :: basis, basis_new - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_used_parts_init_basis', & routineP = moduleN//':'//routineN @@ -566,7 +550,7 @@ SUBROUTINE setup_used_parts_init_basis(info_new,info_ref,basis,basis_new,error) DO i=1,basis%nsets IF(info_new%in_use_set(i))THEN jset=jset+1 - CALL create_new_subset(basis%subset(i),basis_new%subset(jset),info_new%use_contr(jset)%in_use,error) + CALL create_new_subset(basis%subset(i),basis_new%subset(jset),info_new%use_contr(jset)%in_use) END IF END DO @@ -577,14 +561,12 @@ END SUBROUTINE setup_used_parts_init_basis !> \param subset ... !> \param subset_new ... !> \param in_use ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE create_new_subset(subset,subset_new,in_use,error) + SUBROUTINE create_new_subset(subset,subset_new,in_use) TYPE(subset_type) :: subset, subset_new LOGICAL, DIMENSION(:) :: in_use - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_new_subset', & routineP = moduleN//':'//routineN @@ -630,14 +612,12 @@ END SUBROUTINE create_new_subset !> \brief for completeness generate the derived info for set 0(reference from file) !> \param info ... !> \param basis ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE init_deriv_info_ref(info,basis,error) + SUBROUTINE init_deriv_info_ref(info,basis) TYPE(derived_basis_info) :: info TYPE(flex_basis_type) :: basis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_deriv_info_ref', & routineP = moduleN//':'//routineN @@ -659,15 +639,13 @@ END SUBROUTINE init_deriv_info_ref !> \param kind_section ... !> \param opt_bas ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE generate_initial_basis(kind_section,opt_bas,para_env,error) + SUBROUTINE generate_initial_basis(kind_section,opt_bas,para_env) TYPE(section_vals_type), POINTER :: kind_section TYPE(basis_optimization_type) :: opt_bas TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_initial_basis', & routineP = moduleN//':'//routineN @@ -677,29 +655,29 @@ SUBROUTINE generate_initial_basis(kind_section,opt_bas,para_env,error) TYPE(section_vals_type), POINTER :: set_section failure=.FALSE. - CALL section_vals_get(kind_section,n_repetition=opt_bas%nkind,error=error) + CALL section_vals_get(kind_section,n_repetition=opt_bas%nkind) ALLOCATE(opt_bas%kind_basis(opt_bas%nkind)) ! counter to get the number of free variables in optimization variable_counter=0 DO ikind=1,opt_bas%nkind CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",c_val=opt_bas%kind_basis(ikind)%element,& - i_rep_section=ikind,error=error) + i_rep_section=ikind) CALL section_vals_val_get(kind_section,"BASIS_SET",c_val=opt_bas%kind_basis(ikind)%basis_name,& - i_rep_section=ikind,error=error) + i_rep_section=ikind) set_section=>section_vals_get_subs_vals(kind_section,"DERIVED_BASIS_SETS",& - i_rep_section=ikind,error=error) - CALL section_vals_get(set_section,n_repetition=opt_bas%kind_basis(ikind)%nbasis_deriv,explicit=explicit,error=error) + i_rep_section=ikind) + CALL section_vals_get(set_section,n_repetition=opt_bas%kind_basis(ikind)%nbasis_deriv,explicit=explicit) IF(.NOT.explicit)opt_bas%kind_basis(ikind)%nbasis_deriv=0 ALLOCATE(opt_bas%kind_basis(ikind)%flex_basis(0:opt_bas%kind_basis(ikind)%nbasis_deriv)) ALLOCATE(opt_bas%kind_basis(ikind)%deriv_info(0:opt_bas%kind_basis(ikind)%nbasis_deriv)) CALL fill_basis_template(kind_section, opt_bas%kind_basis(ikind)%flex_basis(0), opt_bas%template_basis_file,& - opt_bas%kind_basis(ikind)%element,opt_bas%kind_basis(ikind)%basis_name,para_env,ikind,error) + opt_bas%kind_basis(ikind)%element,opt_bas%kind_basis(ikind)%basis_name,para_env,ikind) - CALL setup_exp_constraints(kind_section, opt_bas%kind_basis(ikind)%flex_basis(0),error) + CALL setup_exp_constraints(kind_section, opt_bas%kind_basis(ikind)%flex_basis(0)) - CALL parse_derived_basis(kind_section,opt_bas%kind_basis(ikind)%deriv_info,ikind,error) + CALL parse_derived_basis(kind_section,opt_bas%kind_basis(ikind)%deriv_info,ikind) variable_counter= variable_counter+opt_bas%kind_basis(ikind)%flex_basis(0)%nopt END DO @@ -708,10 +686,10 @@ SUBROUTINE generate_initial_basis(kind_section,opt_bas,para_env,error) variable_counter=0 DO ikind=1,opt_bas%nkind - CALL assign_x_to_basis(opt_bas%x_opt, opt_bas%kind_basis(ikind)%flex_basis(0),variable_counter,error) + CALL assign_x_to_basis(opt_bas%x_opt, opt_bas%kind_basis(ikind)%flex_basis(0),variable_counter) END DO - CPPostcondition(variable_counter==SIZE(opt_bas%x_opt),cp_failure_level,routineP,error,failure) + CPPostcondition(variable_counter==SIZE(opt_bas%x_opt),cp_failure_level,routineP,failure) END SUBROUTINE generate_initial_basis @@ -720,15 +698,13 @@ END SUBROUTINE generate_initial_basis !> \param kind_section ... !> \param deriv_info ... !> \param ikind ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE parse_derived_basis(kind_section,deriv_info,ikind,error) + SUBROUTINE parse_derived_basis(kind_section,deriv_info,ikind) TYPE(section_vals_type), POINTER :: kind_section TYPE(derived_basis_info), DIMENSION(:) :: deriv_info INTEGER :: ikind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'parse_derived_basis', & routineP = moduleN//':'//routineN @@ -741,31 +717,31 @@ SUBROUTINE parse_derived_basis(kind_section,deriv_info,ikind,error) nsets=SIZE(deriv_info)-1 set1_section=>section_vals_get_subs_vals(kind_section,"DERIVED_BASIS_SETS",& - i_rep_section=ikind,error=error) + i_rep_section=ikind) DO jset=1,nsets ! stracnge but as derive info is allcated from 0 to n the count over here has to be shifted iset=jset+1 - CALL section_vals_val_get(set1_section,"REFERENCE_SET",i_vals=i_vals, i_rep_section=jset,error=error) + CALL section_vals_val_get(set1_section,"REFERENCE_SET",i_vals=i_vals, i_rep_section=jset) deriv_info(iset)%reference_set=i_vals(1) CALL section_vals_val_get(set1_section,"REMOVE_CONTRACTION",explicit=explicit,n_rep_val=n_rep,& - i_rep_section=jset,error=error) + i_rep_section=jset) deriv_info(iset)%ncontr=n_rep IF(explicit)THEN ALLOCATE(deriv_info(iset)%remove_contr(n_rep,3)) DO i_rep=1,n_rep CALL section_vals_val_get(set1_section,"REMOVE_CONTRACTION",i_rep_val=i_rep,i_vals=i_vals,& - i_rep_section=jset,error=error) + i_rep_section=jset) deriv_info(iset)%remove_contr(i_rep,:)=i_vals(:) END DO END IF CALL section_vals_val_get(set1_section,"REMOVE_SET",explicit=explicit,n_rep_val=n_rep,& - i_rep_section=jset,error=error) + i_rep_section=jset) deriv_info(iset)%nsets=n_rep IF(explicit)THEN ALLOCATE(deriv_info(iset)%remove_set(n_rep)) DO i_rep=1,n_rep CALL section_vals_val_get(set1_section,"REMOVE_SET",i_rep_val=i_rep,i_vals=i_vals,& - i_rep_section=jset,error=error) + i_rep_section=jset) deriv_info(iset)%remove_set(i_rep)=i_vals(1) END DO END IF @@ -777,14 +753,12 @@ END SUBROUTINE parse_derived_basis !> \brief get low level information about constraint on exponents !> \param kind1_section ... !> \param flex_basis ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE setup_exp_constraints(kind1_section,flex_basis,error) + SUBROUTINE setup_exp_constraints(kind1_section,flex_basis) TYPE(section_vals_type), POINTER :: kind1_section TYPE(flex_basis_type) :: flex_basis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_exp_constraints', & routineP = moduleN//':'//routineN @@ -794,12 +768,12 @@ SUBROUTINE setup_exp_constraints(kind1_section,flex_basis,error) LOGICAL :: is_bound, is_varlim TYPE(section_vals_type), POINTER :: const_section - const_section=>section_vals_get_subs_vals(kind1_section,"CONSTRAIN_EXPONENTS",error=error) - CALL section_vals_get(const_section,n_repetition=nrep,error=error) + const_section=>section_vals_get_subs_vals(kind1_section,"CONSTRAIN_EXPONENTS") + CALL section_vals_get(const_section,n_repetition=nrep) DO irep=1,nrep - CALL section_vals_val_get(const_section,"USE_EXP",i_vals=def_exp,i_rep_section=irep,error=error) - CALL section_vals_val_get(const_section,"BOUNDARIES",explicit=is_bound,i_rep_section=irep,error=error) - CALL section_vals_val_get(const_section,"MAX_VAR_FRACTION",explicit=is_varlim,i_rep_section=irep,error=error) + CALL section_vals_val_get(const_section,"USE_EXP",i_vals=def_exp,i_rep_section=irep) + CALL section_vals_val_get(const_section,"BOUNDARIES",explicit=is_bound,i_rep_section=irep) + CALL section_vals_val_get(const_section,"MAX_VAR_FRACTION",explicit=is_varlim,i_rep_section=irep) CALL cp_assert(.NOT.(is_bound.AND.is_varlim),cp_fatal_level,cp_assertion_failed,& routineP,"Exponent has two constraints. This is not possible at the moment."//& " Please change input.",only_ionode=.TRUE.) @@ -810,13 +784,13 @@ SUBROUTINE setup_exp_constraints(kind1_section,flex_basis,error) DO iset=1,flex_basis%nsets IF(def_exp(2)==-1)THEN DO ipgf=1,flex_basis%subset(iset)%nexp - CALL set_constraint(flex_basis,iset,ipgf,const_section,is_bound,is_varlim,irep,error) + CALL set_constraint(flex_basis,iset,ipgf,const_section,is_bound,is_varlim,irep) END DO ELSE CALL cp_assert(def_exp(2).gt.flex_basis%subset(iset)%nexp,cp_fatal_level,cp_assertion_failed,& routineP,"Exponent declared in constraint is larger than number of exponents in the set"//& " Please change input.",only_ionode=.TRUE.) - CALL set_constraint(flex_basis,iset,def_exp(2),const_section,is_bound,is_varlim,irep,error) + CALL set_constraint(flex_basis,iset,def_exp(2),const_section,is_bound,is_varlim,irep) END IF END DO ELSE @@ -825,13 +799,13 @@ SUBROUTINE setup_exp_constraints(kind1_section,flex_basis,error) " Please change input.",only_ionode=.TRUE.) IF(def_exp(2)==-1)THEN DO ipgf=1,flex_basis%subset(iset)%nexp - CALL set_constraint(flex_basis,def_exp(1),ipgf,const_section,is_bound,is_varlim,irep,error) + CALL set_constraint(flex_basis,def_exp(1),ipgf,const_section,is_bound,is_varlim,irep) END DO ELSE CALL cp_assert(def_exp(2).le.flex_basis%subset(def_exp(1))%nexp,cp_fatal_level,cp_assertion_failed,& routineP,"Exponent declared in constraint is larger than number of exponents in the set"//& " Please change input.",only_ionode=.TRUE.) - CALL set_constraint(flex_basis,def_exp(1),def_exp(2),const_section,is_bound,is_varlim,irep,error) + CALL set_constraint(flex_basis,def_exp(1),def_exp(2),const_section,is_bound,is_varlim,irep) END IF END IF END DO @@ -848,17 +822,15 @@ END SUBROUTINE setup_exp_constraints !> \param is_bound ... !> \param is_varlim ... !> \param irep ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE set_constraint(flex_basis,iset,ipgf,const_section,is_bound,is_varlim,irep,error) + SUBROUTINE set_constraint(flex_basis,iset,ipgf,const_section,is_bound,is_varlim,irep) TYPE(flex_basis_type) :: flex_basis INTEGER :: iset, ipgf TYPE(section_vals_type), POINTER :: const_section LOGICAL :: is_bound, is_varlim INTEGER :: irep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_constraint', & routineP = moduleN//':'//routineN @@ -872,7 +844,7 @@ SUBROUTINE set_constraint(flex_basis,iset,ipgf,const_section,is_bound,is_varlim, flex_basis%subset(iset)%exp_has_const(ipgf)=.TRUE. IF(is_bound)THEN flex_basis%subset(iset)%exp_const(ipgf)%const_type=0 - CALL section_vals_val_get(const_section,"BOUNDARIES",r_vals=r_vals,i_rep_section=irep,error=error) + CALL section_vals_val_get(const_section,"BOUNDARIES",r_vals=r_vals,i_rep_section=irep) flex_basis%subset(iset)%exp_const(ipgf)%llim=MINVAL(r_vals) flex_basis%subset(iset)%exp_const(ipgf)%ulim=MAXVAL(r_vals) r_val=flex_basis%subset(iset)%exps(ipgf) @@ -887,7 +859,7 @@ SUBROUTINE set_constraint(flex_basis,iset,ipgf,const_section,is_bound,is_varlim, END IF IF(is_varlim)THEN flex_basis%subset(iset)%exp_const(ipgf)%const_type=1 - CALL section_vals_val_get(const_section,"MAX_VAR_FRACTION",r_vals=r_vals,i_rep_section=irep,error=error) + CALL section_vals_val_get(const_section,"MAX_VAR_FRACTION",r_vals=r_vals,i_rep_section=irep) flex_basis%subset(iset)%exp_const(ipgf)%var_fac=r_vals(1) flex_basis%subset(iset)%exp_const(ipgf)%init=flex_basis%subset(iset)%exps(ipgf) END IF @@ -899,15 +871,13 @@ END SUBROUTINE set_constraint !> \param x ... !> \param basis ... !> \param x_ind ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE assign_x_to_basis(x,basis,x_ind,error) + SUBROUTINE assign_x_to_basis(x,basis,x_ind) REAL(KIND=dp), DIMENSION(:) :: x TYPE(flex_basis_type) :: basis INTEGER :: x_ind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'assign_x_to_basis', & routineP = moduleN//':'//routineN @@ -942,18 +912,16 @@ END SUBROUTINE assign_x_to_basis !> \param basis_name ... !> \param para_env ... !> \param ikind ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE fill_basis_template(kind1_section, flex_basis, template_basis_file, element, basis_name, para_env, ikind,error) + SUBROUTINE fill_basis_template(kind1_section, flex_basis, template_basis_file, element, basis_name, para_env, ikind) TYPE(section_vals_type), POINTER :: kind1_section TYPE(flex_basis_type) :: flex_basis CHARACTER(LEN=default_path_length) :: template_basis_file CHARACTER(LEN=default_string_length) :: element, basis_name TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: ikind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fill_basis_template', & routineP = moduleN//':'//routineN @@ -962,12 +930,12 @@ SUBROUTINE fill_basis_template(kind1_section, flex_basis, template_basis_file, e iset, nrep INTEGER, DIMENSION(:), POINTER :: switch - CALL parse_basis( flex_basis, template_basis_file, element, basis_name, para_env, error ) + CALL parse_basis( flex_basis, template_basis_file, element, basis_name, para_env) ! get the optimizable parameters. Many way to modify them but in the end only logical matrix ! is either set or values get flipped according to the input CALL section_vals_val_get(kind1_section,"INITIAL_DEGREES_OF_FREEDOM", i_val=idof,& - i_rep_section=ikind, error=error) + i_rep_section=ikind) DO iset=1,flex_basis%nsets SELECT CASE(idof) CASE(do_opt_none) @@ -986,36 +954,36 @@ SUBROUTINE fill_basis_template(kind1_section, flex_basis, template_basis_file, e END SELECT END DO - CALL section_vals_val_get(kind1_section,"SWITCH_CONTRACTION_STATE",n_rep_val=nrep,i_rep_section=ikind,error=error) + CALL section_vals_val_get(kind1_section,"SWITCH_CONTRACTION_STATE",n_rep_val=nrep,i_rep_section=ikind) DO irep=1, nrep CALL section_vals_val_get(kind1_section,"SWITCH_CONTRACTION_STATE", i_rep_val=irep,& - i_rep_section=ikind,i_vals=switch,error=error) + i_rep_section=ikind,i_vals=switch) icont=convert_l_contr_to_entry(flex_basis%subset(switch(1))%lmin,flex_basis%subset(switch(1))%l,switch(3),switch(2)) DO ipgf=1, flex_basis%subset(switch(1))%nexp flex_basis%subset(switch(1))%opt_coeff(ipgf,icont)=.NOT.flex_basis%subset(switch(1))%opt_coeff(ipgf,icont) END DO END DO - CALL section_vals_val_get(kind1_section,"SWITCH_COEFF_STATE",n_rep_val=nrep,i_rep_section=ikind,error=error) + CALL section_vals_val_get(kind1_section,"SWITCH_COEFF_STATE",n_rep_val=nrep,i_rep_section=ikind) DO irep=1, nrep CALL section_vals_val_get(kind1_section,"SWITCH_COEFF_STATE", i_rep_val=irep,& - i_rep_section=ikind,i_vals=switch,error=error) + i_rep_section=ikind,i_vals=switch) icont=convert_l_contr_to_entry(flex_basis%subset(switch(1))%lmin,flex_basis%subset(switch(1))%l,switch(3),switch(2)) flex_basis%subset(switch(1))%opt_coeff(switch(4),icont)=& .NOT.flex_basis%subset(switch(1))%opt_coeff(switch(4),icont) END DO - CALL section_vals_val_get(kind1_section,"SWITCH_EXP_STATE",n_rep_val=nrep,i_rep_section=ikind,error=error) + CALL section_vals_val_get(kind1_section,"SWITCH_EXP_STATE",n_rep_val=nrep,i_rep_section=ikind) DO irep=1, nrep CALL section_vals_val_get(kind1_section,"SWITCH_EXP_STATE", i_rep_val=irep,& - i_rep_section=ikind,i_vals=switch,error=error) + i_rep_section=ikind,i_vals=switch) flex_basis%subset(switch(1))%opt_exps(switch(2))=.NOT.flex_basis%subset(switch(1))%opt_exps(switch(2)) END DO - CALL section_vals_val_get(kind1_section,"SWITCH_SET_STATE",n_rep_val=nrep,i_rep_section=ikind,error=error) + CALL section_vals_val_get(kind1_section,"SWITCH_SET_STATE",n_rep_val=nrep,i_rep_section=ikind) DO irep=1, nrep CALL section_vals_val_get(kind1_section,"SWITCH_SET_STATE", i_rep_val=irep,& - i_rep_section=ikind,i_vals=switch,error=error) + i_rep_section=ikind,i_vals=switch) DO ipgf=1, flex_basis%subset(switch(2))%nexp SELECT CASE(switch(1)) CASE(0) ! switch all states in the set @@ -1096,16 +1064,14 @@ END FUNCTION convert_l_contr_to_entry !> \param element ... !> \param basis_name ... !> \param para_env ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE parse_basis(flex_basis, template_basis_file,element, basis_name, para_env ,error) + SUBROUTINE parse_basis(flex_basis, template_basis_file,element, basis_name, para_env) TYPE(flex_basis_type) :: flex_basis CHARACTER(LEN=default_path_length) :: template_basis_file CHARACTER(LEN=default_string_length) :: element, basis_name TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'parse_basis', & routineP = moduleN//':'//routineN @@ -1122,10 +1088,10 @@ SUBROUTINE parse_basis(flex_basis, template_basis_file,element, basis_name, para CALL uppercase(element) CALL uppercase(basis_name) NULLIFY(parser) - CALL parser_create(parser,template_basis_file,para_env=para_env,error=error) + CALL parser_create(parser,template_basis_file,para_env=para_env) search_loop: DO - CALL parser_search_string(parser,TRIM(basis_name),.TRUE.,found,line,error=error) + CALL parser_search_string(parser,TRIM(basis_name),.TRUE.,found,line) IF(found)THEN match = .FALSE. CALL uppercase(line) @@ -1138,10 +1104,10 @@ SUBROUTINE parse_basis(flex_basis, template_basis_file,element, basis_name, para IF ( (INDEX(line2,element2(:strlen1)) > 0).AND.& (INDEX(line2,basis_name2(:strlen2)) > 0) ) match = .TRUE. IF (match) THEN - CALL parser_get_object(parser,flex_basis%nsets,newline=.TRUE.,error=error) + CALL parser_get_object(parser,flex_basis%nsets,newline=.TRUE.) ALLOCATE(flex_basis%subset(flex_basis%nsets)) DO iset=1,flex_basis%nsets - CALL parse_subset(parser,flex_basis%subset(iset),error) + CALL parse_subset(parser,flex_basis%subset(iset)) END DO basis_found = .TRUE. EXIT @@ -1150,7 +1116,7 @@ SUBROUTINE parse_basis(flex_basis, template_basis_file,element, basis_name, para EXIT search_loop END IF END DO search_loop - CALL parser_release(parser,error=error) + CALL parser_release(parser) IF( .NOT. basis_found ) CALL stop_program(routineN,moduleN,__LINE__,& "The requested basis set <"//TRIM(basis_name)//& @@ -1163,14 +1129,12 @@ END SUBROUTINE parse_basis !> \brief Read the subset information from the template basis file !> \param parser ... !> \param subset ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE parse_subset(parser,subset,error) + SUBROUTINE parse_subset(parser,subset) TYPE(cp_parser_type), POINTER :: parser TYPE(subset_type) :: subset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'parse_subset', & routineP = moduleN//':'//routineN @@ -1182,10 +1146,10 @@ SUBROUTINE parse_subset(parser,subset,error) REAL(KIND=dp), POINTER :: r_val line_att="" - CALL parser_get_object(parser,subset%n,newline=.TRUE.,error=error) - CALL parser_get_object(parser,subset%lmin,error=error) - CALL parser_get_object(parser,subset%lmax,error=error) - CALL parser_get_object(parser,subset%nexp,error=error) + CALL parser_get_object(parser,subset%n,newline=.TRUE.) + CALL parser_get_object(parser,subset%lmin) + CALL parser_get_object(parser,subset%lmax) + CALL parser_get_object(parser,subset%nexp) subset%nl=subset%lmax-subset%lmin+1 ALLOCATE(r_val) ALLOCATE(subset%l(subset%nl)) @@ -1197,7 +1161,7 @@ SUBROUTINE parse_subset(parser,subset,error) ALLOCATE(subset%exp_const(subset%nexp)) ALLOCATE(subset%exp_x_ind(subset%nexp)) DO ishell=1,subset%nl - CALL parser_get_object(parser,subset%l(ishell),error=error) + CALL parser_get_object(parser,subset%l(ishell)) END DO subset%ncon_tot=SUM(subset%l) ALLOCATE(subset%coeff(subset%nexp,subset%ncon_tot)) @@ -1205,10 +1169,10 @@ SUBROUTINE parse_subset(parser,subset,error) subset%opt_coeff=.FALSE. ALLOCATE(subset%coeff_x_ind(subset%nexp,subset%ncon_tot)) DO ipgf=1,subset%nexp - CALL parser_get_object(parser,r_val,newline=.TRUE.,error=error) + CALL parser_get_object(parser,r_val,newline=.TRUE.) subset%exps(ipgf)=r_val DO ishell=1,subset%ncon_tot - CALL parser_get_object(parser,r_val,error=error) + CALL parser_get_object(parser,r_val) subset%coeff(ipgf,ishell)=r_val END DO END DO @@ -1239,13 +1203,11 @@ END SUBROUTINE parse_subset !> \brief Initialize the variables for the powell optimizer !> \param p_param ... !> \param powell_section ... -!> \param error ... !> \author Florian Schiffmann ! ***************************************************************************** - SUBROUTINE init_powell_var(p_param,powell_section,error) + SUBROUTINE init_powell_var(p_param,powell_section) TYPE(opt_state_type) :: p_param - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_powell_var',& routineP = moduleN//':'//routineN @@ -1256,9 +1218,9 @@ SUBROUTINE init_powell_var(p_param,powell_section,error) p_param%nvar=0 p_param%iprint=0 p_param%unit=default_output_unit - CALL section_vals_val_get(powell_section,"ACCURACY",r_val=p_param%rhoend,error=error) - CALL section_vals_val_get(powell_section,"STEP_SIZE",r_val=p_param%rhobeg,error=error) - CALL section_vals_val_get(powell_section,"MAX_FUN",i_val=p_param%maxfun,error=error) + CALL section_vals_val_get(powell_section,"ACCURACY",r_val=p_param%rhoend) + CALL section_vals_val_get(powell_section,"STEP_SIZE",r_val=p_param%rhobeg) + CALL section_vals_val_get(powell_section,"MAX_FUN",i_val=p_param%maxfun) END SUBROUTINE init_powell_var diff --git a/src/optimize_input.F b/src/optimize_input.F index 79876867b1..8b9e7026d8 100644 --- a/src/optimize_input.F +++ b/src/optimize_input.F @@ -102,14 +102,12 @@ MODULE optimize_input !> \param input_declaration ... !> \param root_section ... !> \param para_env ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE run_optimize_input(input_declaration, root_section, para_env, error) + SUBROUTINE run_optimize_input(input_declaration, root_section, para_env) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'run_optimize_input', & routineP = moduleN//':'//routineN @@ -126,30 +124,30 @@ SUBROUTINE run_optimize_input(input_declaration, root_section, para_env, error) oi_env%start_time=m_walltime() - CALL parse_input(oi_env,root_section,error) + CALL parse_input(oi_env,root_section) ! if we have been asked to randomize the variables, we do this. IF (oi_env%randomize_variables.NE.0.0_dp) THEN NULLIFY(rng_stream) seed=REAL(oi_env%seed,KIND=dp) - CALL create_rng_stream(rng_stream,"run_optimize_input",distribution_type=UNIFORM,seed=seed,error=error) + CALL create_rng_stream(rng_stream,"run_optimize_input",distribution_type=UNIFORM,seed=seed) DO i_var=1,SIZE(oi_env%variables,1) IF (.NOT.oi_env%variables(i_var)%fixed) THEN ! change with a random percentage the variable - random_number = next_random_number(rng_stream,error=error) + random_number = next_random_number(rng_stream) oi_env%variables(i_var)%value=oi_env%variables(i_var)%value* & (1.0_dp+(2*random_number-1.0_dp)*oi_env%randomize_variables/100.0_dp) ENDIF ENDDO - CALL delete_rng_stream(rng_stream,error=error) + CALL delete_rng_stream(rng_stream) ENDIF ! proceed to actual methods SELECT CASE(oi_env%method) CASE(opt_force_matching) - CALL force_matching(oi_env,input_declaration,root_section,para_env,error) + CALL force_matching(oi_env,input_declaration,root_section,para_env) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) @@ -162,15 +160,13 @@ END SUBROUTINE run_optimize_input !> \param input_declaration ... !> \param root_section ... !> \param para_env ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) + SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env) TYPE(oi_env_type) :: oi_env TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'force_matching', & routineP = moduleN//':'//routineN @@ -201,8 +197,8 @@ SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) CALL timeset(routineN,handle) - logger=>cp_error_get_logger(error) - CALL cp_add_iter_level(logger%iter_info,"POWELL_OPT",error=error) + logger=>cp_get_default_logger() + CALL cp_add_iter_level(logger%iter_info,"POWELL_OPT") output_unit = cp_logger_get_default_io_unit(logger) IF (output_unit>0) THEN @@ -211,7 +207,7 @@ SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) ! do IO of ref traj / frc / cell NULLIFY(cell_traj_read,force_traj_read,pos_traj_read,energy_traj_read) - CALL read_reference_data(oi_env,para_env,force_traj_read,pos_traj_read,energy_traj_read,cell_traj_read,error) + CALL read_reference_data(oi_env,para_env,force_traj_read,pos_traj_read,energy_traj_read,cell_traj_read) n_atom=SIZE(pos_traj_read,2) ! adjust read data with respect to start/stop/stride @@ -328,7 +324,7 @@ SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) ! if required get the energy of this set of params IF (state == 2) THEN - CALL cp_iterate(logger%iter_info,last=.FALSE.,error=error) + CALL cp_iterate(logger%iter_info,last=.FALSE.) ! create a new force env, updating the free vars as needed DO i_free_var=1,n_free_var @@ -408,16 +404,15 @@ SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) ! the history file with the trajectory of the parameters history_unit=cp_print_key_unit_nr(logger,root_section,"OPTIMIZE_INPUT%HISTORY", & - extension=".dat",error=error) + extension=".dat") IF (history_unit>0) THEN WRITE (UNIT=history_unit,FMT="(I20,F20.12,1000F20.12)") oi_env%iter_start_val + ostate%nf, ostate%f, free_vars END IF - CALL cp_print_key_finished_output(history_unit,logger,root_section,"OPTIMIZE_INPUT%HISTORY", & - error=error) + CALL cp_print_key_finished_output(history_unit,logger,root_section,"OPTIMIZE_INPUT%HISTORY") ! the energy profile for all frames energies_unit=cp_print_key_unit_nr(logger,root_section,"OPTIMIZE_INPUT%FORCE_MATCHING%COMPARE_ENERGIES", & - file_position="REWIND",extension=".dat",error=error) + file_position="REWIND",extension=".dat") IF (energies_unit>0) THEN WRITE (UNIT=energies_unit,FMT="(A20,A20,A20,A20)") "#frame","ref","fit","diff" DO i_frame=1,n_frames @@ -426,12 +421,11 @@ SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) WRITE (UNIT=energies_unit,FMT="(I20,F20.12,F20.12,F20.12)") i_frame,e1,e2,e1-e2 ENDDO END IF - CALL cp_print_key_finished_output(energies_unit,logger,root_section,"OPTIMIZE_INPUT%FORCE_MATCHING%COMPARE_ENERGIES", & - error=error) + CALL cp_print_key_finished_output(energies_unit,logger,root_section,"OPTIMIZE_INPUT%FORCE_MATCHING%COMPARE_ENERGIES") ! the force profile for all frames energies_unit=cp_print_key_unit_nr(logger,root_section,"OPTIMIZE_INPUT%FORCE_MATCHING%COMPARE_FORCES", & - file_position="REWIND",extension=".dat",error=error) + file_position="REWIND",extension=".dat") IF (energies_unit>0) THEN WRITE (UNIT=energies_unit,FMT="(A20,A20,A20,A20)") "#frame","normalized diff","diff","ref","ref sum" DO i_frame=1,n_frames @@ -442,31 +436,30 @@ SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) WRITE (UNIT=energies_unit,FMT="(I20,F20.12,F20.12,F20.12,2F20.12)") i_frame,e1/e2,e1,e2,e3,e4 ENDDO END IF - CALL cp_print_key_finished_output(energies_unit,logger,root_section,"OPTIMIZE_INPUT%FORCE_MATCHING%COMPARE_FORCES", & - error=error) + CALL cp_print_key_finished_output(energies_unit,logger,root_section,"OPTIMIZE_INPUT%FORCE_MATCHING%COMPARE_FORCES") ! a restart file with the current values of the parameters restart_unit = cp_print_key_unit_nr(logger,root_section,"OPTIMIZE_INPUT%RESTART", extension=".restart",& - file_position="REWIND", do_backup=.TRUE., error=error) + file_position="REWIND", do_backup=.TRUE.) IF (restart_unit>0) THEN - oi_section => section_vals_get_subs_vals(root_section,"OPTIMIZE_INPUT",error=error) - CALL section_vals_val_set(oi_section,"ITER_START_VAL",i_val=oi_env%iter_start_val + ostate%nf,error=error) - variable_section => section_vals_get_subs_vals(oi_section,"VARIABLE",error=error) + oi_section => section_vals_get_subs_vals(root_section,"OPTIMIZE_INPUT") + CALL section_vals_val_set(oi_section,"ITER_START_VAL",i_val=oi_env%iter_start_val + ostate%nf) + variable_section => section_vals_get_subs_vals(oi_section,"VARIABLE") DO i_free_var=1,n_free_var CALL section_vals_val_set(variable_section,"VALUE",i_rep_section=free_var_index(i_free_var), & - r_val=free_vars(i_free_var),error=error) + r_val=free_vars(i_free_var)) ENDDO CALL write_restart_header(restart_unit) - CALL section_vals_write(root_section,unit_nr=restart_unit,hide_root=.TRUE., error=error) + CALL section_vals_write(root_section,unit_nr=restart_unit,hide_root=.TRUE.) ENDIF - CALL cp_print_key_finished_output(restart_unit,logger,root_section,"OPTIMIZE_INPUT%RESTART", error=error) + CALL cp_print_key_finished_output(restart_unit,logger,root_section,"OPTIMIZE_INPUT%RESTART") ENDIF IF ( state == -1 ) EXIT - CALL external_control(should_stop,"OPTIMIZE_INPUT",target_time=oi_env%target_time,start_time=oi_env%start_time,error=error) + CALL external_control(should_stop,"OPTIMIZE_INPUT",target_time=oi_env%target_time,start_time=oi_env%start_time) IF (should_stop) EXIT @@ -497,7 +490,7 @@ SUBROUTINE force_matching(oi_env,input_declaration,root_section,para_env, error) ENDDO ENDIF - CALL cp_rm_iter_level(logger%iter_info,"POWELL_OPT",error=error) + CALL cp_rm_iter_level(logger%iter_info,"POWELL_OPT") ! deallocate for cleanup IF (ASSOCIATED(cell_traj)) DEALLOCATE(cell_traj) @@ -518,10 +511,9 @@ END SUBROUTINE force_matching !> \param pos_traj position !> \param energy_traj energies, as extracted from the forces file !> \param cell_traj cell parameters, as extracted from a CP2K cell file -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE read_reference_data(oi_env,para_env,force_traj,pos_traj,energy_traj,cell_traj,error) + SUBROUTINE read_reference_data(oi_env,para_env,force_traj,pos_traj,energy_traj,cell_traj) TYPE(oi_env_type) :: oi_env TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:, :, :), & @@ -529,7 +521,6 @@ SUBROUTINE read_reference_data(oi_env,para_env,force_traj,pos_traj,energy_traj,c REAL(KIND=dp), DIMENSION(:), POINTER :: energy_traj REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: cell_traj - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_reference_data', & routineP = moduleN//':'//routineN @@ -558,9 +549,9 @@ SUBROUTINE read_reference_data(oi_env,para_env,force_traj,pos_traj,energy_traj,c "The reference trajectory file name is empty"//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL parser_create(local_parser,filename,para_env=para_env,error=error) + CALL parser_create(local_parser,filename,para_env=para_env) DO - CALL parser_read_line(local_parser,1,at_end=at_end,error=error) + CALL parser_read_line(local_parser,1,at_end=at_end) IF (at_end) EXIT READ(local_parser%input_line,FMT="(I8)") nread n_frames=n_frames+1 @@ -571,17 +562,17 @@ SUBROUTINE read_reference_data(oi_env,para_env,force_traj,pos_traj,energy_traj,c ENDIF ! title line - CALL parser_read_line(local_parser,1,error=error) + CALL parser_read_line(local_parser,1) ! actual coordinates DO i = 1,nread - CALL parser_read_line(local_parser,1,error=error) + CALL parser_read_line(local_parser,1) READ(local_parser%input_line(1:LEN_TRIM(local_parser%input_line)),*) AA,vec pos_traj(:,i,n_frames)=vec*bohr END DO ENDDO - CALL parser_release(local_parser,error=error) + CALL parser_release(local_parser) n_frames_current=n_frames CALL reallocate(energy_traj,1,n_frames_current) @@ -594,14 +585,14 @@ SUBROUTINE read_reference_data(oi_env,para_env,force_traj,pos_traj,energy_traj,c "The reference force file name is empty"//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL parser_create(local_parser,filename,para_env=para_env,error=error) + CALL parser_create(local_parser,filename,para_env=para_env) DO iframe=1,n_frames - CALL parser_read_line(local_parser,1,error=error) + CALL parser_read_line(local_parser,1) READ(local_parser%input_line,FMT="(I8)") nread ! title line test_ok = .FALSE. - CALL parser_read_line(local_parser,1,error=error) + CALL parser_read_line(local_parser,1) READ(local_parser%input_line,FMT="(T6,I8,T23,F12.3,T41,F20.10)",ERR=999) trj_itimes, trj_time, trj_epot test_ok = .TRUE. 999 CONTINUE @@ -615,25 +606,25 @@ SUBROUTINE read_reference_data(oi_env,para_env,force_traj,pos_traj,energy_traj,c ! actual forces, in a.u. DO i = 1,nread - CALL parser_read_line(local_parser,1,error=error) + CALL parser_read_line(local_parser,1) READ(local_parser%input_line(1:LEN_TRIM(local_parser%input_line)),*) AA,vec force_traj(:,i,iframe)=vec END DO ENDDO - CALL parser_release(local_parser,error=error) + CALL parser_release(local_parser) ! and cell, which is optional NULLIFY(cell_traj) filename=oi_env%fm_env%ref_cell_file_name IF (filename.NE."") THEN - CALL parser_create(local_parser,filename,para_env=para_env,error=error) + CALL parser_create(local_parser,filename,para_env=para_env) ALLOCATE(cell_traj(3,3,n_frames)) DO iframe=1,n_frames - CALL parser_read_line(local_parser,1,error=error) - CALL parse_cell_line(local_parser%input_line, cell_itimes, cell_time, cell_traj(:,:,iframe), vol, error) + CALL parser_read_line(local_parser,1) + CALL parse_cell_line(local_parser%input_line, cell_itimes, cell_time, cell_traj(:,:,iframe), vol) ENDDO - CALL parser_release(local_parser,error=error) + CALL parser_release(local_parser) ENDIF CALL timestop(handle) @@ -644,13 +635,11 @@ END SUBROUTINE read_reference_data !> \brief parses the input section, and stores in the optimize input environment !> \param oi_env optimize input environment !> \param root_section ... -!> \param error ... !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE parse_input(oi_env,root_section,error) + SUBROUTINE parse_input(oi_env,root_section) TYPE(oi_env_type) :: oi_env TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'parse_input', & routineP = moduleN//':'//routineN @@ -663,54 +652,54 @@ SUBROUTINE parse_input(oi_env,root_section,error) CALL timeset(routineN,handle) failure=.FALSE. - CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=oi_env%project_name,error=error) - CALL section_vals_val_get(root_section,"GLOBAL%SEED",i_val=oi_env%seed,error=error) + CALL section_vals_val_get(root_section,"GLOBAL%PROJECT",c_val=oi_env%project_name) + CALL section_vals_val_get(root_section,"GLOBAL%SEED",i_val=oi_env%seed) CALL cp2k_get_walltime(section=root_section, keyword_name="GLOBAL%WALLTIME", & - walltime=oi_env%target_time, error=error) + walltime=oi_env%target_time) - oi_section => section_vals_get_subs_vals(root_section,"OPTIMIZE_INPUT",error=error) - variable_section => section_vals_get_subs_vals(oi_section,"VARIABLE",error=error) + oi_section => section_vals_get_subs_vals(root_section,"OPTIMIZE_INPUT") + variable_section => section_vals_get_subs_vals(oi_section,"VARIABLE") - CALL section_vals_val_get(oi_section,"ACCURACY", r_val=oi_env%rhoend, error=error) - CALL section_vals_val_get(oi_section,"STEP_SIZE", r_val=oi_env%rhobeg, error=error) - CALL section_vals_val_get(oi_section,"MAX_FUN", i_val=oi_env%maxfun, error=error) - CALL section_vals_val_get(oi_section,"ITER_START_VAL", i_val=oi_env%iter_start_val, error=error) - CALL section_vals_val_get(oi_section,"RANDOMIZE_VARIABLES", r_val=oi_env%randomize_variables, error=error) + CALL section_vals_val_get(oi_section,"ACCURACY", r_val=oi_env%rhoend) + CALL section_vals_val_get(oi_section,"STEP_SIZE", r_val=oi_env%rhobeg) + CALL section_vals_val_get(oi_section,"MAX_FUN", i_val=oi_env%maxfun) + CALL section_vals_val_get(oi_section,"ITER_START_VAL", i_val=oi_env%iter_start_val) + CALL section_vals_val_get(oi_section,"RANDOMIZE_VARIABLES", r_val=oi_env%randomize_variables) - CALL section_vals_get(variable_section,explicit=explicit, n_repetition=n_var, error=error) + CALL section_vals_get(variable_section,explicit=explicit, n_repetition=n_var) IF (explicit) THEN ALLOCATE(oi_env%variables(1:n_var)) DO ivar=1,n_var CALL section_vals_val_get(variable_section,"VALUE",i_rep_section=ivar, & - r_val=oi_env%variables(ivar)%value, error=error) + r_val=oi_env%variables(ivar)%value) CALL section_vals_val_get(variable_section,"FIXED",i_rep_section=ivar, & - l_val=oi_env%variables(ivar)%fixed, error=error) + l_val=oi_env%variables(ivar)%fixed) CALL section_vals_val_get(variable_section,"LABEL",i_rep_section=ivar, & - c_val=oi_env%variables(ivar)%label, error=error) + c_val=oi_env%variables(ivar)%label) ENDDO ENDIF - CALL section_vals_val_get(oi_section,"METHOD",i_val=oi_env%method,error=error) + CALL section_vals_val_get(oi_section,"METHOD",i_val=oi_env%method) SELECT CASE(oi_env%method) CASE(opt_force_matching) - fm_section => section_vals_get_subs_vals(oi_section,"FORCE_MATCHING",error=error) - CALL section_vals_val_get(fm_section,"REF_TRAJ_FILE_NAME",c_val=oi_env%fm_env%ref_traj_file_name,error=error) - CALL section_vals_val_get(fm_section,"REF_FORCE_FILE_NAME",c_val=oi_env%fm_env%ref_force_file_name,error=error) - CALL section_vals_val_get(fm_section,"REF_CELL_FILE_NAME",c_val=oi_env%fm_env%ref_cell_file_name,error=error) - CALL section_vals_val_get(fm_section,"OPTIMIZE_FILE_NAME",c_val=oi_env%fm_env%optimize_file_name,error=error) - CALL section_vals_val_get(fm_section,"FRAME_START",i_val=oi_env%fm_env%frame_start,error=error) - CALL section_vals_val_get(fm_section,"FRAME_STOP",i_val=oi_env%fm_env%frame_stop,error=error) - CALL section_vals_val_get(fm_section,"FRAME_STRIDE",i_val=oi_env%fm_env%frame_stride,error=error) - CALL section_vals_val_get(fm_section,"FRAME_COUNT",i_val=oi_env%fm_env%frame_count,error=error) - - CALL section_vals_val_get(fm_section,"GROUP_SIZE",i_val=oi_env%fm_env%group_size,error=error) - - CALL section_vals_val_get(fm_section,"ENERGY_WEIGHT",r_val=oi_env%fm_env%energy_weight,error=error) - CALL section_vals_val_get(fm_section,"SHIFT_MM",r_val=oi_env%fm_env%shift_mm,error=error) - CALL section_vals_val_get(fm_section,"SHIFT_QM",r_val=oi_env%fm_env%shift_qm,error=error) - CALL section_vals_val_get(fm_section,"SHIFT_AVERAGE",l_val=oi_env%fm_env%shift_average,error=error) + fm_section => section_vals_get_subs_vals(oi_section,"FORCE_MATCHING") + CALL section_vals_val_get(fm_section,"REF_TRAJ_FILE_NAME",c_val=oi_env%fm_env%ref_traj_file_name) + CALL section_vals_val_get(fm_section,"REF_FORCE_FILE_NAME",c_val=oi_env%fm_env%ref_force_file_name) + CALL section_vals_val_get(fm_section,"REF_CELL_FILE_NAME",c_val=oi_env%fm_env%ref_cell_file_name) + CALL section_vals_val_get(fm_section,"OPTIMIZE_FILE_NAME",c_val=oi_env%fm_env%optimize_file_name) + CALL section_vals_val_get(fm_section,"FRAME_START",i_val=oi_env%fm_env%frame_start) + CALL section_vals_val_get(fm_section,"FRAME_STOP",i_val=oi_env%fm_env%frame_stop) + CALL section_vals_val_get(fm_section,"FRAME_STRIDE",i_val=oi_env%fm_env%frame_stride) + CALL section_vals_val_get(fm_section,"FRAME_COUNT",i_val=oi_env%fm_env%frame_count) + + CALL section_vals_val_get(fm_section,"GROUP_SIZE",i_val=oi_env%fm_env%group_size) + + CALL section_vals_val_get(fm_section,"ENERGY_WEIGHT",r_val=oi_env%fm_env%energy_weight) + CALL section_vals_val_get(fm_section,"SHIFT_MM",r_val=oi_env%fm_env%shift_mm) + CALL section_vals_val_get(fm_section,"SHIFT_QM",r_val=oi_env%fm_env%shift_qm) + CALL section_vals_val_get(fm_section,"SHIFT_AVERAGE",l_val=oi_env%fm_env%shift_average) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) diff --git a/src/pair_potential.F b/src/pair_potential.F index a8b0daca65..9c4e0a7888 100644 --- a/src/pair_potential.F +++ b/src/pair_potential.F @@ -127,13 +127,12 @@ END SUBROUTINE init_genpot !> \param do_zbl ... !> \param shift_cutoff ... !> \param nonbonded_type ... -!> \param error ... !> \par History !> Teo 2006.05 : Improved speed and accuracy. Linear scaling of the setup ! ***************************************************************************** SUBROUTINE spline_nonbond_control(spline_env, potparm, atomic_kind_set, & eps_spline, max_energy, rlow_nb, emax_spline, npoints, iw, iw2, iw3, do_zbl, & - shift_cutoff, nonbonded_type, error) + shift_cutoff, nonbonded_type) TYPE(spline_environment_type), POINTER :: spline_env TYPE(pair_potential_pp_type), POINTER :: potparm @@ -144,7 +143,6 @@ SUBROUTINE spline_nonbond_control(spline_env, potparm, atomic_kind_set, & INTEGER, INTENT(IN) :: npoints, iw, iw2, iw3 LOGICAL, INTENT(IN) :: do_zbl, shift_cutoff CHARACTER(LEN=*), INTENT(IN) :: nonbonded_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_nonbond_control', & routineP = moduleN//':'//routineN @@ -202,7 +200,7 @@ SUBROUTINE spline_nonbond_control(spline_env, potparm, atomic_kind_set, & ! Do nothing.. CASE DEFAULT ! Never reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Special case for EAM SELECT CASE(pot%type(k)) @@ -232,7 +230,7 @@ SUBROUTINE spline_nonbond_control(spline_env, potparm, atomic_kind_set, & CALL generate_spline_low(spline_env%spl_pp(n)%spl_p, npoints_spline, locut, & hicut, eps_spline, iw, iw2, i, j, n, ncount, max_energy, pot, & energy_cutoff, found_locut, do_zbl, atomic_kind_set, & - nonbonded_type, error) + nonbonded_type) pot%undef = .FALSE. ! Unique Spline working only for a pure LJ potential.. @@ -344,14 +342,13 @@ END SUBROUTINE get_spline_cutoff !> \param do_zbl ... !> \param atomic_kind_set ... !> \param nonbonded_type ... -!> \param error ... !> \par History !> Splitting in order to make some season cleaning.. !> \author Teodoro Laino [tlaino] 2007.06 ! ***************************************************************************** SUBROUTINE generate_spline_low(spl_p, npoints, locut, hicut, eps_spline, & iw, iw2, i, j, n, ncount, max_energy, pot, energy_cutoff, & - found_locut, do_zbl, atomic_kind_set, nonbonded_type, error) + found_locut, do_zbl, atomic_kind_set, nonbonded_type) TYPE(spline_data_p_type), DIMENSION(:), & POINTER :: spl_p @@ -366,7 +363,6 @@ SUBROUTINE generate_spline_low(spl_p, npoints, locut, hicut, eps_spline, & TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set CHARACTER(LEN=*), INTENT(IN) :: nonbonded_type - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_spline_low', & routineP = moduleN//':'//routineN @@ -384,9 +380,9 @@ SUBROUTINE generate_spline_low(spl_p, npoints, locut, hicut, eps_spline, & TYPE(spline_factor_type), POINTER :: spl_f NULLIFY (logger,spl_f) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL spline_factor_create(spl_f, error) + CALL spline_factor_create(spl_f) mfac = 5 IF (npoints>0) THEN fixed_spline_points=.TRUE. @@ -554,7 +550,7 @@ SUBROUTINE generate_spline_low(spl_p, npoints, locut, hicut, eps_spline, & CALL close_file(unit_number=unit_number) END IF - CALL spline_factor_release(spl_f,error) + CALL spline_factor_release(spl_f) END SUBROUTINE generate_spline_low @@ -565,18 +561,16 @@ END SUBROUTINE generate_spline_low !> \param atomic_kind_set ... !> \param do_zbl ... !> \param shift_cutoff ... -!> \param error ... !> \author Teodoro Laino [tlaino] 2006.05 ! ***************************************************************************** SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & - shift_cutoff, error) + shift_cutoff) TYPE(spline_environment_type), POINTER :: spline_env TYPE(pair_potential_pp_type), POINTER :: potparm TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set LOGICAL, INTENT(IN) :: do_zbl, shift_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_nonbond_storage', & routineP = moduleN//':'//routineN @@ -600,7 +594,7 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & END DO END DO ALLOCATE(tmp_index(ntype,ntype),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! nunique = 0 tmp_index = HUGE(0) @@ -648,11 +642,11 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & CASE (nn_type) nvar = nvar CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Setup a table of the indexes.. ALLOCATE(my_index(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) n = 0 nk = 0 DO i = 1, ntype @@ -667,7 +661,7 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & END DO IF (nvar /=0) THEN ALLOCATE(pot_par(ndim,nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) n = 0 nk = 0 DO i = 1, ntype @@ -760,7 +754,7 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & CASE (nn_type) ! no checks CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (ANY(potential_single_allocation==pot_target)) THEN pot_par(nk,:) = REAL(pot_target, KIND=dp) @@ -770,13 +764,13 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & END DO ! Main Sorting Loop ALLOCATE(Rwork(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Iwork1(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Iwork2(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wtmp(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL sort(pot_par(:,1),ndim,Iwork1) ! Sort all the other components of the potential DO k = 2, nvar @@ -828,18 +822,18 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & END DO END DO DEALLOCATE(wtmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Iwork1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Iwork2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Rwork,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! ! Let's determine the number of unique potentials and tag them ! ALLOCATE(Cwork(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Cwork(:) = pot_par(1,:) locij = my_index(1) CALL get_indexes(locij,ntype,tmpij0) @@ -854,7 +848,7 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & ! check the array components CALL compare_pot(potparm%pot(tmpij(1) ,tmpij(2) )%pot,& potparm%pot(tmpij0(1),tmpij0(2))%pot,& - check, error) + check) CASE(gp_type) check = .TRUE. IF (ASSOCIATED(potparm%pot(tmpij(1) ,tmpij(2) )%pot%set(1)%gp%parameters).AND.& @@ -881,7 +875,7 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & nunique = nunique + 1 iend = j - 1 CALL set_potparm_index(potparm, my_index(istart:iend), pot_target, & - ntype, tmpij, atomic_kind_set, shift_cutoff, do_zbl, error) + ntype, tmpij, atomic_kind_set, shift_cutoff, do_zbl) ! DO i = istart, iend locij = my_index(i) @@ -896,7 +890,7 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & nunique = nunique + 1 iend = ndim CALL set_potparm_index(potparm, my_index(istart:iend), pot_target, & - ntype, tmpij, atomic_kind_set, shift_cutoff, do_zbl, error) + ntype, tmpij, atomic_kind_set, shift_cutoff, do_zbl) DO i = istart, iend locij = my_index(i) CALL get_indexes(locij,ntype,tmpij) @@ -904,16 +898,16 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & tmp_index(tmpij(2),tmpij(1))=nunique END DO DEALLOCATE(Cwork,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pot_par,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE nunique = nunique + 1 CALL set_potparm_index(potparm, my_index, pot_target, ntype, tmpij,& - atomic_kind_set, shift_cutoff, do_zbl, error) + atomic_kind_set, shift_cutoff, do_zbl) END IF DEALLOCATE(my_index,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO ! Multiple defined potential n = 0 @@ -926,14 +920,14 @@ SUBROUTINE get_nonbond_storage(spline_env, potparm, atomic_kind_set, do_zbl, & tmp_index(j,i) = nunique ! CALL set_potparm_index(potparm, (/n/), multi_type, ntype, tmpij, & - atomic_kind_set, shift_cutoff, do_zbl, error) + atomic_kind_set, shift_cutoff, do_zbl) END DO END DO ! Concluding the postprocess.. - CALL spline_env_create(spline_env, ntype, nunique, error=error) + CALL spline_env_create(spline_env, ntype, nunique) spline_env%spltab=tmp_index DEALLOCATE(tmp_index,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE get_nonbond_storage @@ -948,11 +942,10 @@ END SUBROUTINE get_nonbond_storage !> \param atomic_kind_set ... !> \param shift_cutoff ... !> \param do_zbl ... -!> \param error ... !> \author Teodoro Laino [tlaino] 2007.06 ! ***************************************************************************** SUBROUTINE set_potparm_index(potparm, my_index, pot_target, ntype, tmpij_out,& - atomic_kind_set, shift_cutoff, do_zbl, error) + atomic_kind_set, shift_cutoff, do_zbl) TYPE(pair_potential_pp_type), POINTER :: potparm INTEGER, INTENT(IN) :: my_index(:), pot_target, ntype @@ -960,7 +953,6 @@ SUBROUTINE set_potparm_index(potparm, my_index, pot_target, ntype, tmpij_out,& TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set LOGICAL, INTENT(IN) :: shift_cutoff, do_zbl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_potparm_index', & routineP = moduleN//':'//routineN @@ -984,9 +976,9 @@ SUBROUTINE set_potparm_index(potparm, my_index, pot_target, ntype, tmpij_out,& nvalues = SIZE(my_index) IF ((pot_target==lj_type).OR.(pot_target==lj_charmm_type)) THEN ALLOCATE(sigma6(nvalues),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wrk(nvalues),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) min_sigma6= HUGE(0.0_dp) m_epsilon =-HUGE(0.0_dp) DO i = 1, nvalues @@ -995,7 +987,7 @@ SUBROUTINE set_potparm_index(potparm, my_index, pot_target, ntype, tmpij_out,& pot => potparm%pot(tmpij(1),tmpij(2))%pot ! Preliminary check.. check = SIZE(pot%type)==1 - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) sigma6(i) = pot%set(1)%lj%sigma6 l_epsilon = pot%set(1)%lj%epsilon @@ -1011,9 +1003,9 @@ SUBROUTINE set_potparm_index(potparm, my_index, pot_target, ntype, tmpij_out,& IF (m_epsilon == -HUGE(0.0_dp)) m_epsilon = 0.0_dp IF (min_sigma6 == HUGE(0.0_dp)) min_sigma6 = 0.0_dp DEALLOCATE(sigma6,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE min_val = MINVAL(my_index(:)) END IF @@ -1031,7 +1023,7 @@ SUBROUTINE set_potparm_index(potparm, my_index, pot_target, ntype, tmpij_out,& value = my_index(i) CALL get_indexes(value,ntype,tmpij) pot => potparm%pot(tmpij(1),tmpij(2))%pot - CALL spline_factor_create(pot%spl_f, error) + CALL spline_factor_create(pot%spl_f) pot%spl_f%rcutsq_f = 1.0_dp pot%spl_f%rscale = 1.0_dp pot%spl_f%fscale = 1.0_dp @@ -1044,7 +1036,7 @@ SUBROUTINE set_potparm_index(potparm, my_index, pot_target, ntype, tmpij_out,& pot => potparm%pot(tmpij(1),tmpij(2))%pot check = SIZE(pot%type)==1 - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ! Undef potential.. this will be used to compute the splines.. IF ((pot_target==lj_type).OR.(pot_target==lj_charmm_type)) THEN l_sigma6 = pot%set(1)%lj%sigma6 diff --git a/src/pair_potential_types.F b/src/pair_potential_types.F index 45a178288a..9146a396ba 100644 --- a/src/pair_potential_types.F +++ b/src/pair_potential_types.F @@ -291,14 +291,12 @@ MODULE pair_potential_types !> \param pot1 ... !> \param pot2 ... !> \param compare ... -!> \param error ... !> \author Teodoro Laino [teo] 05.2006 ! ***************************************************************************** - SUBROUTINE compare_pot(pot1, pot2, compare, error) + SUBROUTINE compare_pot(pot1, pot2, compare) TYPE(pair_potential_single_type), & POINTER :: pot1, pot2 LOGICAL, INTENT(OUT) :: compare - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compare_pot', & routineP = moduleN//':'//routineN @@ -310,14 +308,14 @@ SUBROUTINE compare_pot(pot1, pot2, compare, error) compare=.FALSE. ! Preliminary checks - CPPostcondition(ASSOCIATED(pot1%type),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(pot2%type),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pot1%type),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(pot2%type),cp_failure_level,routineP,failure) IF (SIZE(pot1%type)/=SIZE(pot2%type)) RETURN IF (ANY(pot1%type/=pot2%type)) RETURN ! Checking the real values of parameters - CPPostcondition(ASSOCIATED(pot1%set),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(pot2%set),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pot1%set),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(pot2%set),cp_failure_level,routineP,failure) DO i = 1, SIZE(pot1%type) mycompare = .FALSE. SELECT CASE(pot1%type(i)) @@ -407,14 +405,12 @@ END SUBROUTINE compare_pot !> \brief Creates the potential parameter type !> \param potparm ... !> \param nset ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_single_create(potparm, nset, error) + SUBROUTINE pair_potential_single_create(potparm, nset) TYPE(pair_potential_single_type), & POINTER :: potparm INTEGER, INTENT(IN), OPTIONAL :: nset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_single_create', & routineP = moduleN//':'//routineN @@ -423,16 +419,16 @@ SUBROUTINE pair_potential_single_create(potparm, nset, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(potparm),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(potparm),cp_failure_level,routineP,failure) ALLOCATE(potparm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) lnset = 1 IF (PRESENT(nset)) lnset = nset ! Standard allocation to size 1 ALLOCATE(potparm%type(lnset), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(potparm%set(lnset), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY( potparm%spl_f,& potparm%pair_spline_data) DO i = 1, lnset @@ -452,19 +448,17 @@ SUBROUTINE pair_potential_single_create(potparm, nset, error) potparm%set(i)%siepmann,& potparm%set(i)%ftd) END DO - CALL pair_potential_single_clean(potparm, error) + CALL pair_potential_single_clean(potparm) END SUBROUTINE pair_potential_single_create ! ***************************************************************************** !> \brief Cleans the potential parameter type !> \param potparm ... -!> \param error ... !> \author unknown ! ***************************************************************************** - SUBROUTINE pair_potential_single_clean(potparm, error) + SUBROUTINE pair_potential_single_clean(potparm) TYPE(pair_potential_single_type), & POINTER :: potparm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_single_clean', & routineP = moduleN//':'//routineN @@ -482,26 +476,26 @@ SUBROUTINE pair_potential_single_clean(potparm, error) potparm % at2 = 'NULL' potparm % rcutsq = 0.0_dp IF (ASSOCIATED( potparm % pair_spline_data ))& - CALL spline_data_p_release ( potparm % pair_spline_data ,error=error) + CALL spline_data_p_release ( potparm % pair_spline_data) IF (ASSOCIATED( potparm % spl_f ))& - CALL spline_factor_release ( potparm % spl_f ,error=error) + CALL spline_factor_release ( potparm % spl_f) DO i = 1, SIZE(potparm%type) potparm%set(i)%rmin = not_initialized potparm%set(i)%rmax = not_initialized - CALL pair_potential_lj_clean (potparm%set(i)%lj, error=error) - CALL pair_potential_williams_clean (potparm%set(i)%willis, error=error) - CALL pair_potential_goodwin_clean (potparm%set(i)%goodwin, error=error) - CALL pair_potential_eam_clean (potparm%set(i)%eam, error=error) - CALL pair_potential_quip_clean (potparm%set(i)%quip, error=error) - CALL pair_potential_buck4r_clean (potparm%set(i)%buck4r, error=error) - CALL pair_potential_buckmo_clean (potparm%set(i)%buckmo, error=error) - CALL pair_potential_bmhft_clean (potparm%set(i)%ft, error=error) - CALL pair_potential_bmhftd_clean (potparm%set(i)%ftd, error=error) - CALL pair_potential_ipbv_clean (potparm%set(i)%ipbv, error=error) - CALL pair_potential_gp_clean (potparm%set(i)%gp, error=error) - CALL pair_potential_tersoff_clean (potparm%set(i)%tersoff, error=error) - CALL pair_potential_siepmann_clean (potparm%set(i)%siepmann, error=error) + CALL pair_potential_lj_clean (potparm%set(i)%lj) + CALL pair_potential_williams_clean (potparm%set(i)%willis) + CALL pair_potential_goodwin_clean (potparm%set(i)%goodwin) + CALL pair_potential_eam_clean (potparm%set(i)%eam) + CALL pair_potential_quip_clean (potparm%set(i)%quip) + CALL pair_potential_buck4r_clean (potparm%set(i)%buck4r) + CALL pair_potential_buckmo_clean (potparm%set(i)%buckmo) + CALL pair_potential_bmhft_clean (potparm%set(i)%ft) + CALL pair_potential_bmhftd_clean (potparm%set(i)%ftd) + CALL pair_potential_ipbv_clean (potparm%set(i)%ipbv) + CALL pair_potential_gp_clean (potparm%set(i)%gp) + CALL pair_potential_tersoff_clean (potparm%set(i)%tersoff) + CALL pair_potential_siepmann_clean (potparm%set(i)%siepmann) END DO END SUBROUTINE pair_potential_single_clean @@ -509,13 +503,11 @@ END SUBROUTINE pair_potential_single_clean !> \brief Copy two potential parameter type !> \param potparm_source ... !> \param potparm_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_single_copy(potparm_source, potparm_dest, error) + SUBROUTINE pair_potential_single_copy(potparm_source, potparm_dest) TYPE(pair_potential_single_type), & POINTER :: potparm_source, potparm_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_single_copy', & routineP = moduleN//':'//routineN @@ -524,11 +516,11 @@ SUBROUTINE pair_potential_single_copy(potparm_source, potparm_dest, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(potparm_source),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(potparm_source),cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(potparm_dest)) THEN - CALL pair_potential_single_create(potparm_dest,SIZE(potparm_source%type),error) + CALL pair_potential_single_create(potparm_dest,SIZE(potparm_source%type)) ELSE - CALL pair_potential_single_clean(potparm_dest, error) + CALL pair_potential_single_clean(potparm_dest) END IF potparm_dest % type = potparm_source % type potparm_dest % shell_type = potparm_source % shell_type @@ -539,29 +531,29 @@ SUBROUTINE pair_potential_single_copy(potparm_source, potparm_dest, error) potparm_dest % at2 = potparm_source % at2 potparm_dest % rcutsq = potparm_source % rcutsq IF (ASSOCIATED( potparm_source % pair_spline_data )) THEN - CALL spline_data_p_copy ( potparm_source % pair_spline_data, potparm_dest % pair_spline_data, error=error ) + CALL spline_data_p_copy ( potparm_source % pair_spline_data, potparm_dest % pair_spline_data) END IF IF (ASSOCIATED( potparm_source % spl_f )) THEN - CALL spline_factor_copy ( potparm_source % spl_f, potparm_dest % spl_f, error=error ) + CALL spline_factor_copy ( potparm_source % spl_f, potparm_dest % spl_f) END IF DO i = 1, SIZE(potparm_source%type) potparm_dest%set(i)%rmin = potparm_source%set(i)%rmin potparm_dest%set(i)%rmax = potparm_source%set(i)%rmax - CALL pair_potential_lj_copy (potparm_source%set(i)%lj, potparm_dest%set(i)%lj, error=error) - CALL pair_potential_williams_copy (potparm_source%set(i)%willis, potparm_dest%set(i)%willis, error=error) - CALL pair_potential_goodwin_copy (potparm_source%set(i)%goodwin, potparm_dest%set(i)%goodwin, error=error) - CALL pair_potential_eam_copy (potparm_source%set(i)%eam, potparm_dest%set(i)%eam, error=error) - CALL pair_potential_quip_copy (potparm_source%set(i)%quip, potparm_dest%set(i)%quip, error=error) - CALL pair_potential_bmhft_copy (potparm_source%set(i)%ft, potparm_dest%set(i)%ft, error=error) - CALL pair_potential_bmhftd_copy (potparm_source%set(i)%ftd, potparm_dest%set(i)%ftd, error=error) - CALL pair_potential_ipbv_copy (potparm_source%set(i)%ipbv, potparm_dest%set(i)%ipbv, error=error) - CALL pair_potential_buck4r_copy (potparm_source%set(i)%buck4r, potparm_dest%set(i)%buck4r, error=error) - CALL pair_potential_buckmo_copy (potparm_source%set(i)%buckmo, potparm_dest%set(i)%buckmo, error=error) - CALL pair_potential_gp_copy (potparm_source%set(i)%gp, potparm_dest%set(i)%gp, error=error) - CALL pair_potential_tersoff_copy (potparm_source%set(i)%tersoff, potparm_dest%set(i)%tersoff, error=error) - CALL pair_potential_siepmann_copy (potparm_source%set(i)%siepmann, potparm_dest%set(i)%siepmann, error=error) + CALL pair_potential_lj_copy (potparm_source%set(i)%lj, potparm_dest%set(i)%lj) + CALL pair_potential_williams_copy (potparm_source%set(i)%willis, potparm_dest%set(i)%willis) + CALL pair_potential_goodwin_copy (potparm_source%set(i)%goodwin, potparm_dest%set(i)%goodwin) + CALL pair_potential_eam_copy (potparm_source%set(i)%eam, potparm_dest%set(i)%eam) + CALL pair_potential_quip_copy (potparm_source%set(i)%quip, potparm_dest%set(i)%quip) + CALL pair_potential_bmhft_copy (potparm_source%set(i)%ft, potparm_dest%set(i)%ft) + CALL pair_potential_bmhftd_copy (potparm_source%set(i)%ftd, potparm_dest%set(i)%ftd) + CALL pair_potential_ipbv_copy (potparm_source%set(i)%ipbv, potparm_dest%set(i)%ipbv) + CALL pair_potential_buck4r_copy (potparm_source%set(i)%buck4r, potparm_dest%set(i)%buck4r) + CALL pair_potential_buckmo_copy (potparm_source%set(i)%buckmo, potparm_dest%set(i)%buckmo) + CALL pair_potential_gp_copy (potparm_source%set(i)%gp, potparm_dest%set(i)%gp) + CALL pair_potential_tersoff_copy (potparm_source%set(i)%tersoff, potparm_dest%set(i)%tersoff) + CALL pair_potential_siepmann_copy (potparm_source%set(i)%siepmann, potparm_dest%set(i)%siepmann) END DO END SUBROUTINE pair_potential_single_copy @@ -570,13 +562,11 @@ END SUBROUTINE pair_potential_single_copy !> Used in case of multiple_potential definition !> \param potparm_source ... !> \param potparm_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_single_add(potparm_source, potparm_dest, error) + SUBROUTINE pair_potential_single_add(potparm_source, potparm_dest) TYPE(pair_potential_single_type), & POINTER :: potparm_source, potparm_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_single_add', & routineP = moduleN//':'//routineN @@ -587,15 +577,15 @@ SUBROUTINE pair_potential_single_add(potparm_source, potparm_dest, error) POINTER :: potparm_tmp failure = .FALSE. - CPPostcondition(ASSOCIATED(potparm_source),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(potparm_source),cp_failure_level,routineP,failure) ! At this level we expect all splines types ! be not allocated.. No sense add splines at this level.. in case fail! check = (.NOT.ASSOCIATED( potparm_source % pair_spline_data )).AND.& (.NOT.ASSOCIATED( potparm_source % spl_f )) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) check = (.NOT.ASSOCIATED( potparm_dest % pair_spline_data )).AND.& (.NOT.ASSOCIATED( potparm_dest % spl_f )) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ! Increase the size of the destination potparm (in case) and copy the new data size_source = SIZE(potparm_source%type) allocate_new = .NOT.ASSOCIATED(potparm_dest) @@ -617,13 +607,13 @@ SUBROUTINE pair_potential_single_add(potparm_source, potparm_dest, error) (ASSOCIATED(potparm_dest%set(1)%siepmann)) IF (.NOT.check) THEN allocate_new = .TRUE. - CALL pair_potential_single_release(potparm_dest, error) + CALL pair_potential_single_release(potparm_dest) END IF END IF END IF IF (allocate_new) THEN size_dest = 0 - CALL pair_potential_single_create(potparm_dest,size_source,error) + CALL pair_potential_single_create(potparm_dest,size_source) potparm_dest % shell_type = potparm_source % shell_type potparm_dest % undef = potparm_source % undef potparm_dest % no_mb = potparm_source % no_mb @@ -634,9 +624,9 @@ SUBROUTINE pair_potential_single_add(potparm_source, potparm_dest, error) ELSE size_dest = SIZE(potparm_dest%type) NULLIFY(potparm_tmp) - CALL pair_potential_single_copy(potparm_dest,potparm_tmp,error) - CALL pair_potential_single_release(potparm_dest, error) - CALL pair_potential_single_create(potparm_dest,size_dest+size_source,error) + CALL pair_potential_single_copy(potparm_dest,potparm_tmp) + CALL pair_potential_single_release(potparm_dest) + CALL pair_potential_single_create(potparm_dest,size_dest+size_source) ! Copy back original informations.. potparm_dest % shell_type = potparm_tmp % shell_type potparm_dest % undef = potparm_tmp % undef @@ -649,21 +639,21 @@ SUBROUTINE pair_potential_single_add(potparm_source, potparm_dest, error) potparm_dest%type(i) = potparm_tmp%type(i) potparm_dest%set(i)%rmin = potparm_tmp%set(i)%rmin potparm_dest%set(i)%rmax = potparm_tmp%set(i)%rmax - CALL pair_potential_lj_copy (potparm_tmp%set(i)%lj, potparm_dest%set(i)%lj, error=error) - CALL pair_potential_williams_copy (potparm_tmp%set(i)%willis, potparm_dest%set(i)%willis, error=error) - CALL pair_potential_goodwin_copy (potparm_tmp%set(i)%goodwin, potparm_dest%set(i)%goodwin, error=error) - CALL pair_potential_eam_copy (potparm_tmp%set(i)%eam, potparm_dest%set(i)%eam, error=error) - CALL pair_potential_quip_copy (potparm_tmp%set(i)%quip, potparm_dest%set(i)%quip, error=error) - CALL pair_potential_bmhft_copy (potparm_tmp%set(i)%ft, potparm_dest%set(i)%ft, error=error) - CALL pair_potential_bmhftd_copy (potparm_tmp%set(i)%ftd, potparm_dest%set(i)%ftd, error=error) - CALL pair_potential_ipbv_copy (potparm_tmp%set(i)%ipbv, potparm_dest%set(i)%ipbv, error=error) - CALL pair_potential_buck4r_copy (potparm_tmp%set(i)%buck4r, potparm_dest%set(i)%buck4r, error=error) - CALL pair_potential_buckmo_copy (potparm_tmp%set(i)%buckmo, potparm_dest%set(i)%buckmo, error=error) - CALL pair_potential_gp_copy (potparm_tmp%set(i)%gp, potparm_dest%set(i)%gp, error=error) - CALL pair_potential_tersoff_copy (potparm_tmp%set(i)%tersoff, potparm_dest%set(i)%tersoff, error=error) - CALL pair_potential_siepmann_copy (potparm_tmp%set(i)%siepmann, potparm_dest%set(i)%siepmann, error=error) + CALL pair_potential_lj_copy (potparm_tmp%set(i)%lj, potparm_dest%set(i)%lj) + CALL pair_potential_williams_copy (potparm_tmp%set(i)%willis, potparm_dest%set(i)%willis) + CALL pair_potential_goodwin_copy (potparm_tmp%set(i)%goodwin, potparm_dest%set(i)%goodwin) + CALL pair_potential_eam_copy (potparm_tmp%set(i)%eam, potparm_dest%set(i)%eam) + CALL pair_potential_quip_copy (potparm_tmp%set(i)%quip, potparm_dest%set(i)%quip) + CALL pair_potential_bmhft_copy (potparm_tmp%set(i)%ft, potparm_dest%set(i)%ft) + CALL pair_potential_bmhftd_copy (potparm_tmp%set(i)%ftd, potparm_dest%set(i)%ftd) + CALL pair_potential_ipbv_copy (potparm_tmp%set(i)%ipbv, potparm_dest%set(i)%ipbv) + CALL pair_potential_buck4r_copy (potparm_tmp%set(i)%buck4r, potparm_dest%set(i)%buck4r) + CALL pair_potential_buckmo_copy (potparm_tmp%set(i)%buckmo, potparm_dest%set(i)%buckmo) + CALL pair_potential_gp_copy (potparm_tmp%set(i)%gp, potparm_dest%set(i)%gp) + CALL pair_potential_tersoff_copy (potparm_tmp%set(i)%tersoff, potparm_dest%set(i)%tersoff) + CALL pair_potential_siepmann_copy (potparm_tmp%set(i)%siepmann, potparm_dest%set(i)%siepmann) END DO - CALL pair_potential_single_release ( potparm_tmp, error ) + CALL pair_potential_single_release ( potparm_tmp) END IF ! Further check with main option with source and dest (already filled with few informations) check= (potparm_dest % shell_type == potparm_source % shell_type).AND.& @@ -673,39 +663,37 @@ SUBROUTINE pair_potential_single_add(potparm_source, potparm_dest, error) (potparm_dest % at1 == potparm_source % at1 ).AND.& (potparm_dest % at2 == potparm_source % at2 ).AND.& (potparm_dest % rcutsq == potparm_source % rcutsq ) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ! Now copy the new pair_potential type DO i = size_dest+1, size_dest+size_source j = i-size_dest potparm_dest%type(i) = potparm_source%type(j) potparm_dest%set(i)%rmin = potparm_source%set(j)%rmin potparm_dest%set(i)%rmax = potparm_source%set(j)%rmax - CALL pair_potential_lj_copy (potparm_source%set(j)%lj, potparm_dest%set(i)%lj, error=error) - CALL pair_potential_williams_copy (potparm_source%set(j)%willis, potparm_dest%set(i)%willis, error=error) - CALL pair_potential_goodwin_copy (potparm_source%set(j)%goodwin, potparm_dest%set(i)%goodwin, error=error) - CALL pair_potential_eam_copy (potparm_source%set(j)%eam, potparm_dest%set(i)%eam, error=error) - CALL pair_potential_quip_copy (potparm_source%set(j)%quip, potparm_dest%set(i)%quip, error=error) - CALL pair_potential_bmhft_copy (potparm_source%set(j)%ft, potparm_dest%set(i)%ft, error=error) - CALL pair_potential_bmhftd_copy (potparm_source%set(j)%ftd, potparm_dest%set(i)%ftd, error=error) - CALL pair_potential_ipbv_copy (potparm_source%set(j)%ipbv, potparm_dest%set(i)%ipbv, error=error) - CALL pair_potential_buck4r_copy (potparm_source%set(j)%buck4r, potparm_dest%set(i)%buck4r, error=error) - CALL pair_potential_buckmo_copy (potparm_source%set(j)%buckmo, potparm_dest%set(i)%buckmo, error=error) - CALL pair_potential_gp_copy (potparm_source%set(j)%gp, potparm_dest%set(i)%gp, error=error) - CALL pair_potential_tersoff_copy (potparm_source%set(j)%tersoff, potparm_dest%set(i)%tersoff, error=error) - CALL pair_potential_siepmann_copy (potparm_source%set(j)%siepmann, potparm_dest%set(i)%siepmann, error=error) + CALL pair_potential_lj_copy (potparm_source%set(j)%lj, potparm_dest%set(i)%lj) + CALL pair_potential_williams_copy (potparm_source%set(j)%willis, potparm_dest%set(i)%willis) + CALL pair_potential_goodwin_copy (potparm_source%set(j)%goodwin, potparm_dest%set(i)%goodwin) + CALL pair_potential_eam_copy (potparm_source%set(j)%eam, potparm_dest%set(i)%eam) + CALL pair_potential_quip_copy (potparm_source%set(j)%quip, potparm_dest%set(i)%quip) + CALL pair_potential_bmhft_copy (potparm_source%set(j)%ft, potparm_dest%set(i)%ft) + CALL pair_potential_bmhftd_copy (potparm_source%set(j)%ftd, potparm_dest%set(i)%ftd) + CALL pair_potential_ipbv_copy (potparm_source%set(j)%ipbv, potparm_dest%set(i)%ipbv) + CALL pair_potential_buck4r_copy (potparm_source%set(j)%buck4r, potparm_dest%set(i)%buck4r) + CALL pair_potential_buckmo_copy (potparm_source%set(j)%buckmo, potparm_dest%set(i)%buckmo) + CALL pair_potential_gp_copy (potparm_source%set(j)%gp, potparm_dest%set(i)%gp) + CALL pair_potential_tersoff_copy (potparm_source%set(j)%tersoff, potparm_dest%set(i)%tersoff) + CALL pair_potential_siepmann_copy (potparm_source%set(j)%siepmann, potparm_dest%set(i)%siepmann) END DO END SUBROUTINE pair_potential_single_add ! ***************************************************************************** !> \brief Release Data-structure that constains potential parameters of a single pair !> \param potparm ... -!> \param error ... !> \author Teodoro Laino [Teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_single_release ( potparm, error ) + SUBROUTINE pair_potential_single_release ( potparm) TYPE(pair_potential_single_type), & POINTER :: potparm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'pair_potential_single_release', & @@ -715,30 +703,30 @@ SUBROUTINE pair_potential_single_release ( potparm, error ) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(potparm),cp_failure_level,routineP,error,failure) - CALL spline_data_p_release( potparm% pair_spline_data ,error=error) - CALL spline_factor_release( potparm% spl_f, error=error ) + CPPostcondition(ASSOCIATED(potparm),cp_failure_level,routineP,failure) + CALL spline_data_p_release( potparm% pair_spline_data) + CALL spline_factor_release( potparm% spl_f) DO i = 1, SIZE(potparm%type) - CALL pair_potential_ipbv_release ( potparm%set(i)%ipbv, error=error ) - CALL pair_potential_lj_release ( potparm%set(i)%lj, error=error ) - CALL pair_potential_bmhft_release ( potparm%set(i)%ft, error=error ) - CALL pair_potential_bmhftd_release ( potparm%set(i)%ftd, error=error ) - CALL pair_potential_williams_release ( potparm%set(i)%willis, error=error ) - CALL pair_potential_goodwin_release ( potparm%set(i)%goodwin, error=error ) - CALL pair_potential_eam_release ( potparm%set(i)%eam, error=error ) - CALL pair_potential_quip_release ( potparm%set(i)%quip, error=error ) - CALL pair_potential_buck4r_release ( potparm%set(i)%buck4r, error=error ) - CALL pair_potential_buckmo_release ( potparm%set(i)%buckmo, error=error ) - CALL pair_potential_gp_release ( potparm%set(i)%gp, error=error ) - CALL pair_potential_tersoff_release ( potparm%set(i)%tersoff, error=error ) - CALL pair_potential_siepmann_release ( potparm%set(i)%siepmann, error=error ) + CALL pair_potential_ipbv_release ( potparm%set(i)%ipbv) + CALL pair_potential_lj_release ( potparm%set(i)%lj) + CALL pair_potential_bmhft_release ( potparm%set(i)%ft) + CALL pair_potential_bmhftd_release ( potparm%set(i)%ftd) + CALL pair_potential_williams_release ( potparm%set(i)%willis) + CALL pair_potential_goodwin_release ( potparm%set(i)%goodwin) + CALL pair_potential_eam_release ( potparm%set(i)%eam) + CALL pair_potential_quip_release ( potparm%set(i)%quip) + CALL pair_potential_buck4r_release ( potparm%set(i)%buck4r) + CALL pair_potential_buckmo_release ( potparm%set(i)%buckmo) + CALL pair_potential_gp_release ( potparm%set(i)%gp) + CALL pair_potential_tersoff_release ( potparm%set(i)%tersoff) + CALL pair_potential_siepmann_release ( potparm%set(i)%siepmann) END DO DEALLOCATE(potparm%type, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(potparm%set, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(potparm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY ( potparm ) END SUBROUTINE pair_potential_single_release @@ -746,13 +734,11 @@ END SUBROUTINE pair_potential_single_release !> \brief Data-structure that constains potential parameters !> \param potparm ... !> \param nkinds ... -!> \param error ... !> \author unknown ! ***************************************************************************** - SUBROUTINE pair_potential_pp_create ( potparm, nkinds, error ) + SUBROUTINE pair_potential_pp_create ( potparm, nkinds) TYPE(pair_potential_pp_type), POINTER :: potparm INTEGER, INTENT(IN) :: nkinds - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_pp_create', & routineP = moduleN//':'//routineN @@ -761,11 +747,11 @@ SUBROUTINE pair_potential_pp_create ( potparm, nkinds, error ) LOGICAL :: failure failure=.FALSE. - CPPostcondition(.NOT.ASSOCIATED(potparm),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(potparm),cp_failure_level,routineP,failure) ALLOCATE ( potparm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( potparm%pot( nkinds, nkinds ), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nkinds DO j = 1, nkinds NULLIFY ( potparm%pot(i,j)%pot ) @@ -774,7 +760,7 @@ SUBROUTINE pair_potential_pp_create ( potparm, nkinds, error ) ! Use no-redundancy in the potential definition DO i = 1, nkinds DO j = i, nkinds - CALL pair_potential_single_create(potparm%pot( i, j)%pot, error=error) + CALL pair_potential_single_create(potparm%pot( i, j)%pot) potparm%pot( j, i )%pot => potparm%pot( i, j )%pot END DO END DO @@ -783,15 +769,13 @@ END SUBROUTINE pair_potential_pp_create ! ***************************************************************************** !> \brief Release Data-structure that constains potential parameters !> \param potparm ... -!> \param error ... !> \par History !> Teodoro Laino [Teo] 11.2005 : Reorganizing the structures to optimize !> memory management !> \author unknown ! ***************************************************************************** - SUBROUTINE pair_potential_pp_release ( potparm, error ) + SUBROUTINE pair_potential_pp_release ( potparm) TYPE(pair_potential_pp_type), POINTER :: potparm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_pp_release', & routineP = moduleN//':'//routineN @@ -804,15 +788,15 @@ SUBROUTINE pair_potential_pp_release ( potparm, error ) IF (ASSOCIATED (potparm%pot)) THEN DO i = 1, SIZE ( potparm%pot, 1 ) DO j = i, SIZE ( potparm%pot, 2 ) - CALL pair_potential_single_release(potparm%pot( i, j )%pot, error) + CALL pair_potential_single_release(potparm%pot( i, j )%pot) NULLIFY(potparm%pot( j, i )%pot) END DO END DO DEALLOCATE(potparm%pot, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE ( potparm, stat = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY ( potparm ) END SUBROUTINE pair_potential_pp_release @@ -823,13 +807,11 @@ END SUBROUTINE pair_potential_pp_release !> \param ndim ... !> \param ub ... !> \param lb ... -!> \param error ... !> \author unknown ! ***************************************************************************** - SUBROUTINE pair_potential_p_create ( potparm, ndim, ub, lb, error ) + SUBROUTINE pair_potential_p_create ( potparm, ndim, ub, lb) TYPE(pair_potential_p_type), POINTER :: potparm INTEGER, INTENT(IN), OPTIONAL :: ndim, ub, lb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_p_create', & routineP = moduleN//':'//routineN @@ -838,46 +820,44 @@ SUBROUTINE pair_potential_p_create ( potparm, ndim, ub, lb, error ) LOGICAL :: failure failure=.FALSE. - CPPostcondition(.NOT.ASSOCIATED(potparm),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(potparm),cp_failure_level,routineP,failure) ALLOCATE ( potparm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(ndim)) THEN loc_lb = 1 loc_ub = ndim ALLOCATE ( potparm%pot( loc_lb : loc_ub ), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(lb).OR.PRESENT(ub)) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(lb).AND.PRESENT(ub)) THEN loc_lb = lb loc_ub = ub ALLOCATE ( potparm%pot( loc_lb : loc_ub ), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(ndim)) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF DO i = loc_lb, loc_ub NULLIFY ( potparm%pot(i)%pot) - CALL pair_potential_single_create(potparm%pot(i)%pot, error=error) + CALL pair_potential_single_create(potparm%pot(i)%pot) END DO END SUBROUTINE pair_potential_p_create ! ***************************************************************************** !> \brief Release Data-structure that constains potential parameters !> \param potparm ... -!> \param error ... !> \par History !> Teodoro Laino [Teo] 11.2005 : Reorganizing the structures to optimize !> memory management !> \author unknown ! ***************************************************************************** - SUBROUTINE pair_potential_p_release ( potparm, error ) + SUBROUTINE pair_potential_p_release ( potparm) TYPE(pair_potential_p_type), POINTER :: potparm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_potential_p_release', & routineP = moduleN//':'//routineN @@ -890,13 +870,13 @@ SUBROUTINE pair_potential_p_release ( potparm, error ) IF ( ASSOCIATED ( potparm ) ) THEN IF (ASSOCIATED (potparm%pot)) THEN DO i = 1, SIZE ( potparm%pot ) - CALL pair_potential_single_release(potparm%pot( i )%pot, error) + CALL pair_potential_single_release(potparm%pot( i )%pot) END DO DEALLOCATE(potparm%pot, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE ( potparm, stat = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY ( potparm ) END SUBROUTINE pair_potential_p_release @@ -907,13 +887,11 @@ END SUBROUTINE pair_potential_p_release !> \param dest ... !> \param istart ... !> \param iend ... -!> \param error ... !> \author Teodoro Laino [Teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_p_copy(source, dest, istart, iend, error) + SUBROUTINE pair_potential_p_copy(source, dest, istart, iend) TYPE(pair_potential_p_type), POINTER :: source, dest INTEGER, INTENT(IN), OPTIONAL :: istart, iend - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_p_copy', & routineP = moduleN//':'//routineN @@ -922,16 +900,16 @@ SUBROUTINE pair_potential_p_copy(source, dest, istart, iend, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(source),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(dest),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(source),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(dest),cp_failure_level,routineP,failure) l_start = LBOUND(source%pot,1) l_end = UBOUND(source%pot,1) IF (PRESENT(istart)) l_start = istart IF (PRESENT(iend)) l_end = iend DO i = l_start, l_end IF (.NOT.ASSOCIATED(source%pot(i)%pot)) & - CALL pair_potential_single_create(source%pot(i)%pot, error=error) - CALL pair_potential_single_copy(source%pot(i)%pot,dest%pot(i)%pot,error=error) + CALL pair_potential_single_create(source%pot(i)%pot) + CALL pair_potential_single_copy(source%pot(i)%pot,dest%pot(i)%pot) END DO END SUBROUTINE pair_potential_p_copy @@ -954,17 +932,15 @@ END SUBROUTINE pair_potential_p_copy !> \param gp ... !> \param tersoff ... !> \param siepmann ... -!> \param error ... !> \author Teodoro Laino [Teo] 11.2005 ! ***************************************************************************** SUBROUTINE pair_potential_reallocate(p,lb1_new,ub1_new,lj,lj_charmm,williams,& goodwin,eam,quip,bmhft,bmhftd,ipbv,buck4r,buckmo,gp,tersoff,& - siepmann,error) + siepmann) TYPE(pair_potential_p_type), POINTER :: p INTEGER, INTENT(IN) :: lb1_new, ub1_new LOGICAL, INTENT(IN), OPTIONAL :: lj, lj_charmm, williams, goodwin, eam, & quip, bmhft, bmhftd, ipbv, buck4r, buckmo, gp, tersoff, siepmann - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_reallocate', & routineP = moduleN//':'//routineN @@ -999,85 +975,85 @@ SUBROUTINE pair_potential_reallocate(p,lb1_new,ub1_new,lj,lj_charmm,williams,& check = .NOT.(llj_charmm.OR.lwilliams.OR.lgoodwin.OR.leam.OR.lquip.OR.lbmhft& .OR.lbmhftd.OR.lipbv.OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff& .OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (llj_charmm) THEN ipot = lj_charmm_type check = .NOT.(llj.OR.lwilliams.OR.lgoodwin.OR.leam.OR.lquip.OR.lbmhft.OR.lbmhftd.OR.lipbv& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lwilliams) THEN ipot = wl_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lbmhft.OR.lbmhftd.OR.lipbv& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lgoodwin) THEN ipot = gw_type check = .NOT.(llj.OR.llj_charmm.OR.lwilliams.OR.leam.OR.lquip.OR.lbmhft.OR.lbmhftd.OR.lipbv& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (leam) THEN ipot = ea_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.lwilliams.OR.lquip.OR.lbmhft.OR.lbmhftd.OR.lipbv& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lquip) THEN ipot = quip_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.lwilliams.OR.leam.OR.lbmhft.OR.lbmhftd.OR.lipbv& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lbmhft) THEN ipot = ft_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lwilliams.OR.lbmhftd.OR.lipbv& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lbmhftd) THEN ipot = ftd_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lwilliams.OR.lbmhft.OR.lipbv& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lipbv) THEN ipot = ip_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lwilliams.OR.lbmhft.OR.lbmhftd& .OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lbuck4r) THEN ipot = b4_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lwilliams.OR.lbmhft.OR.lbmhftd& .OR.lipbv.OR.lbuckmo.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lbuckmo) THEN ipot = bm_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lwilliams.OR.lbmhft.OR.lbmhftd& .OR.lipbv.OR.lbuck4r.OR.lgp.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (ltersoff) THEN ipot = tersoff_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lwilliams.OR.lbmhft.OR.lbmhftd& .OR.lipbv.OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lsiepmann) THEN ipot = siepmann_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lquip.OR.lwilliams.OR.lbmhft.OR.lbmhftd& .OR.lipbv.OR.lbuck4r.OR.lbuckmo.OR.lgp.OR.ltersoff) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF IF (lgp) THEN ipot = gp_type check = .NOT.(llj.OR.llj_charmm.OR.lgoodwin.OR.leam.OR.lwilliams.OR.lbmhft.OR.lbmhftd& .OR.lipbv.OR.lbuck4r.OR.lbuckmo.OR.ltersoff.OR.lsiepmann) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END IF lb1_old = 0 @@ -1085,19 +1061,19 @@ SUBROUTINE pair_potential_reallocate(p,lb1_new,ub1_new,lj,lj_charmm,williams,& IF (ASSOCIATED(p)) THEN lb1_old = LBOUND(p%pot,1) ub1_old = UBOUND(p%pot,1) - CALL pair_potential_p_create(work, lb=lb1_old, ub=ub1_old, error=error) - CALL pair_potential_p_copy(p, work, error=error) - CALL pair_potential_p_release(p, error=error) + CALL pair_potential_p_create(work, lb=lb1_old, ub=ub1_old) + CALL pair_potential_p_copy(p, work) + CALL pair_potential_p_release(p) END IF - CALL pair_potential_p_create(p, lb=lb1_new, ub=ub1_new, error=error) + CALL pair_potential_p_create(p, lb=lb1_new, ub=ub1_new) IF (ASSOCIATED(work)) THEN - CALL pair_potential_p_copy(work, p, istart=lb1_old, iend=ub1_old, error=error) + CALL pair_potential_p_copy(work, p, istart=lb1_old, iend=ub1_old) END IF std_dim = 1 DO i = ub1_old+1, ub1_new check = (SIZE(p%pot(i)%pot%type)==std_dim).AND.(SIZE(p%pot(i)%pot%type)==std_dim) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) p % pot ( i ) % pot % type = nn_type p % pot ( i ) % pot % shell_type = nosh_nosh p % pot ( i ) % pot % undef = .TRUE. @@ -1109,48 +1085,46 @@ SUBROUTINE pair_potential_reallocate(p,lb1_new,ub1_new,lj,lj_charmm,williams,& p % pot ( i ) % pot % set(std_dim) % rmax = not_initialized SELECT CASE (ipot) CASE (lj_type,lj_charmm_type) - CALL pair_potential_lj_create(p%pot(i)%pot%set(std_dim)%lj, error=error) + CALL pair_potential_lj_create(p%pot(i)%pot%set(std_dim)%lj) CASE (wl_type) - CALL pair_potential_williams_create(p%pot(i)%pot%set(std_dim)%willis, error=error) + CALL pair_potential_williams_create(p%pot(i)%pot%set(std_dim)%willis) CASE (gw_type) - CALL pair_potential_goodwin_create(p%pot(i)%pot%set(std_dim)%goodwin, error=error) + CALL pair_potential_goodwin_create(p%pot(i)%pot%set(std_dim)%goodwin) CASE (ea_type) - CALL pair_potential_eam_create(p%pot(i)%pot%set(std_dim)%eam, error=error) + CALL pair_potential_eam_create(p%pot(i)%pot%set(std_dim)%eam) CASE (quip_type) - CALL pair_potential_quip_create(p%pot(i)%pot%set(std_dim)%quip, error=error) + CALL pair_potential_quip_create(p%pot(i)%pot%set(std_dim)%quip) CASE (ft_type) - CALL pair_potential_bmhft_create(p%pot(i)%pot%set(std_dim)%ft, error=error) + CALL pair_potential_bmhft_create(p%pot(i)%pot%set(std_dim)%ft) CASE (ftd_type) - CALL pair_potential_bmhftd_create(p%pot(i)%pot%set(std_dim)%ftd, error=error) + CALL pair_potential_bmhftd_create(p%pot(i)%pot%set(std_dim)%ftd) CASE (ip_type) - CALL pair_potential_ipbv_create(p%pot(i)%pot%set(std_dim)%ipbv, error=error) + CALL pair_potential_ipbv_create(p%pot(i)%pot%set(std_dim)%ipbv) CASE (b4_type) - CALL pair_potential_buck4r_create(p%pot(i)%pot%set(std_dim)%buck4r, error=error) + CALL pair_potential_buck4r_create(p%pot(i)%pot%set(std_dim)%buck4r) CASE (bm_type) - CALL pair_potential_buckmo_create(p%pot(i)%pot%set(std_dim)%buckmo, error=error) + CALL pair_potential_buckmo_create(p%pot(i)%pot%set(std_dim)%buckmo) CASE (gp_type) - CALL pair_potential_gp_create(p%pot(i)%pot%set(std_dim)%gp, error=error) + CALL pair_potential_gp_create(p%pot(i)%pot%set(std_dim)%gp) CASE (tersoff_type) - CALL pair_potential_tersoff_create(p%pot(i)%pot%set(std_dim)%tersoff, error=error) + CALL pair_potential_tersoff_create(p%pot(i)%pot%set(std_dim)%tersoff) CASE (siepmann_type) - CALL pair_potential_siepmann_create(p%pot(i)%pot%set(std_dim)%siepmann, error=error) + CALL pair_potential_siepmann_create(p%pot(i)%pot%set(std_dim)%siepmann) END SELECT NULLIFY ( p%pot(i)%pot%spl_f ) NULLIFY ( p%pot(i)%pot%pair_spline_data ) END DO - IF (ASSOCIATED(work)) CALL pair_potential_p_release(work, error=error) + IF (ASSOCIATED(work)) CALL pair_potential_p_release(work) END SUBROUTINE pair_potential_reallocate ! ***************************************************************************** !> \brief Creates the generic potential type !> \param gp ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_gp_create(gp, error) + SUBROUTINE pair_potential_gp_create(gp) TYPE(gp_pot_type), POINTER :: gp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_gp_create', & routineP = moduleN//':'//routineN @@ -1159,24 +1133,22 @@ SUBROUTINE pair_potential_gp_create(gp, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(gp),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(gp),cp_failure_level,routineP,failure) ALLOCATE(gp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (gp%parameters) NULLIFY (gp%values) - CALL pair_potential_gp_clean(gp, error=error) + CALL pair_potential_gp_clean(gp) END SUBROUTINE pair_potential_gp_create ! ***************************************************************************** !> \brief Copy two generic potential type !> \param gp_source ... !> \param gp_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_gp_copy(gp_source, gp_dest, error) + SUBROUTINE pair_potential_gp_copy(gp_source, gp_dest) TYPE(gp_pot_type), POINTER :: gp_source, gp_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_gp_copy', & routineP = moduleN//':'//routineN @@ -1186,21 +1158,21 @@ SUBROUTINE pair_potential_gp_copy(gp_source, gp_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(gp_source)) RETURN - IF (ASSOCIATED(gp_dest)) CALL pair_potential_gp_release(gp_dest, error=error) - CALL pair_potential_gp_create(gp_dest, error=error) + IF (ASSOCIATED(gp_dest)) CALL pair_potential_gp_release(gp_dest) + CALL pair_potential_gp_create(gp_dest) gp_dest%myid = gp_source%myid gp_dest%potential = gp_source%potential gp_dest%variables = gp_source%variables IF (ASSOCIATED(gp_source%parameters)) THEN idim = SIZE(gp_source%parameters) ALLOCATE(gp_dest%parameters(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gp_dest%parameters = gp_source%parameters END IF IF (ASSOCIATED(gp_source%values)) THEN idim = SIZE(gp_source%values) ALLOCATE(gp_dest%values(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) gp_dest%values = gp_source%values END IF END SUBROUTINE pair_potential_gp_copy @@ -1208,12 +1180,10 @@ END SUBROUTINE pair_potential_gp_copy ! ***************************************************************************** !> \brief Cleans the generic potential type !> \param gp ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_gp_clean(gp, error) + SUBROUTINE pair_potential_gp_clean(gp) TYPE(gp_pot_type), POINTER :: gp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_gp_clean', & routineP = moduleN//':'//routineN @@ -1228,23 +1198,21 @@ SUBROUTINE pair_potential_gp_clean(gp, error) gp%variables = "" IF (ASSOCIATED(gp%values)) THEN DEALLOCATE(gp%values,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(gp%parameters)) THEN DEALLOCATE(gp%parameters,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE pair_potential_gp_clean ! ***************************************************************************** !> \brief Destroys the generic potential type !> \param gp ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_gp_release(gp, error) + SUBROUTINE pair_potential_gp_release(gp) TYPE(gp_pot_type), POINTER :: gp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_gp_release', & routineP = moduleN//':'//routineN @@ -1256,14 +1224,14 @@ SUBROUTINE pair_potential_gp_release(gp, error) IF (ASSOCIATED(gp)) THEN IF (ASSOCIATED(gp%parameters)) THEN DEALLOCATE(gp%parameters, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(gp%values)) THEN DEALLOCATE(gp%values, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(gp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(gp) END SUBROUTINE pair_potential_gp_release @@ -1271,12 +1239,10 @@ END SUBROUTINE pair_potential_gp_release ! ***************************************************************************** !> \brief Cleans the LJ potential type !> \param lj ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_lj_create(lj, error) + SUBROUTINE pair_potential_lj_create(lj) TYPE(lj_pot_type), POINTER :: lj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_lj_create', & routineP = moduleN//':'//routineN @@ -1285,22 +1251,20 @@ SUBROUTINE pair_potential_lj_create(lj, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(lj),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(lj),cp_failure_level,routineP,failure) ALLOCATE(lj, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_lj_clean(lj, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_lj_clean(lj) END SUBROUTINE pair_potential_lj_create ! ***************************************************************************** !> \brief Copy two LJ potential type !> \param lj_source ... !> \param lj_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_lj_copy(lj_source, lj_dest, error) + SUBROUTINE pair_potential_lj_copy(lj_source, lj_dest) TYPE(lj_pot_type), POINTER :: lj_source, lj_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_lj_copy', & routineP = moduleN//':'//routineN @@ -1309,8 +1273,8 @@ SUBROUTINE pair_potential_lj_copy(lj_source, lj_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(lj_source)) RETURN - IF (ASSOCIATED(lj_dest)) CALL pair_potential_lj_release(lj_dest, error=error) - CALL pair_potential_lj_create(lj_dest, error=error) + IF (ASSOCIATED(lj_dest)) CALL pair_potential_lj_release(lj_dest) + CALL pair_potential_lj_create(lj_dest) lj_dest%epsilon = lj_source%epsilon lj_dest%sigma6 = lj_source%sigma6 lj_dest%sigma12 = lj_source%sigma12 @@ -1319,12 +1283,10 @@ END SUBROUTINE pair_potential_lj_copy ! ***************************************************************************** !> \brief Creates the LJ potential type !> \param lj ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_lj_clean(lj, error) + SUBROUTINE pair_potential_lj_clean(lj) TYPE(lj_pot_type), POINTER :: lj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_lj_clean', & routineP = moduleN//':'//routineN @@ -1341,12 +1303,10 @@ END SUBROUTINE pair_potential_lj_clean ! ***************************************************************************** !> \brief Destroys the LJ potential type !> \param lj ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_lj_release(lj, error) + SUBROUTINE pair_potential_lj_release(lj) TYPE(lj_pot_type), POINTER :: lj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_lj_release', & routineP = moduleN//':'//routineN @@ -1357,7 +1317,7 @@ SUBROUTINE pair_potential_lj_release(lj, error) failure = .FALSE. IF (ASSOCIATED(lj)) THEN DEALLOCATE(lj, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(lj) END SUBROUTINE pair_potential_lj_release @@ -1365,12 +1325,10 @@ END SUBROUTINE pair_potential_lj_release ! ***************************************************************************** !> \brief Creates the WILLIAMS potential type !> \param willis ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_williams_create(willis, error) + SUBROUTINE pair_potential_williams_create(willis) TYPE(williams_pot_type), POINTER :: willis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_williams_create', & @@ -1380,22 +1338,20 @@ SUBROUTINE pair_potential_williams_create(willis, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(willis),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(willis),cp_failure_level,routineP,failure) ALLOCATE(willis, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_williams_clean(willis, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_williams_clean(willis) END SUBROUTINE pair_potential_williams_create ! ***************************************************************************** !> \brief Copy two WILLIAMS potential type !> \param willis_source ... !> \param willis_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_williams_copy(willis_source, willis_dest, error) + SUBROUTINE pair_potential_williams_copy(willis_source, willis_dest) TYPE(williams_pot_type), POINTER :: willis_source, willis_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_williams_copy', & routineP = moduleN//':'//routineN @@ -1404,8 +1360,8 @@ SUBROUTINE pair_potential_williams_copy(willis_source, willis_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(willis_source)) RETURN - IF (ASSOCIATED(willis_dest)) CALL pair_potential_williams_release(willis_dest, error=error) - CALL pair_potential_williams_create(willis_dest, error=error) + IF (ASSOCIATED(willis_dest)) CALL pair_potential_williams_release(willis_dest) + CALL pair_potential_williams_create(willis_dest) willis_dest%a = willis_source%a willis_dest%b = willis_source%b willis_dest%c = willis_source%c @@ -1414,12 +1370,10 @@ END SUBROUTINE pair_potential_williams_copy ! ***************************************************************************** !> \brief Creates the WILLIAMS potential type !> \param willis ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_williams_clean(willis, error) + SUBROUTINE pair_potential_williams_clean(willis) TYPE(williams_pot_type), POINTER :: willis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_williams_clean', & @@ -1437,12 +1391,10 @@ END SUBROUTINE pair_potential_williams_clean ! ***************************************************************************** !> \brief Destroys the WILLIAMS potential type !> \param willis ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_williams_release(willis, error) + SUBROUTINE pair_potential_williams_release(willis) TYPE(williams_pot_type), POINTER :: willis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_williams_release', & @@ -1454,7 +1406,7 @@ SUBROUTINE pair_potential_williams_release(willis, error) failure = .FALSE. IF (ASSOCIATED(willis)) THEN DEALLOCATE(willis, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(willis) END SUBROUTINE pair_potential_williams_release @@ -1462,12 +1414,10 @@ END SUBROUTINE pair_potential_williams_release ! ***************************************************************************** !> \brief Creates the GOODWIN potential type !> \param goodwin ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_goodwin_create(goodwin, error) + SUBROUTINE pair_potential_goodwin_create(goodwin) TYPE(goodwin_pot_type), POINTER :: goodwin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_goodwin_create', & @@ -1477,22 +1427,20 @@ SUBROUTINE pair_potential_goodwin_create(goodwin, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(goodwin),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(goodwin),cp_failure_level,routineP,failure) ALLOCATE(goodwin, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_goodwin_clean(goodwin, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_goodwin_clean(goodwin) END SUBROUTINE pair_potential_goodwin_create ! ***************************************************************************** !> \brief Copy two GOODWIN potential type !> \param goodwin_source ... !> \param goodwin_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_goodwin_copy(goodwin_source, goodwin_dest, error) + SUBROUTINE pair_potential_goodwin_copy(goodwin_source, goodwin_dest) TYPE(goodwin_pot_type), POINTER :: goodwin_source, goodwin_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_goodwin_copy', & routineP = moduleN//':'//routineN @@ -1501,8 +1449,8 @@ SUBROUTINE pair_potential_goodwin_copy(goodwin_source, goodwin_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(goodwin_source)) RETURN - IF (ASSOCIATED(goodwin_dest)) CALL pair_potential_goodwin_release(goodwin_dest, error=error) - CALL pair_potential_goodwin_create(goodwin_dest, error=error) + IF (ASSOCIATED(goodwin_dest)) CALL pair_potential_goodwin_release(goodwin_dest) + CALL pair_potential_goodwin_create(goodwin_dest) goodwin_dest%vr0 = goodwin_source%vr0 goodwin_dest%d = goodwin_source%d goodwin_dest%dc = goodwin_source%dc @@ -1513,12 +1461,10 @@ END SUBROUTINE pair_potential_goodwin_copy ! ***************************************************************************** !> \brief Creates the GOODWIN potential type !> \param goodwin ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_goodwin_clean(goodwin, error) + SUBROUTINE pair_potential_goodwin_clean(goodwin) TYPE(goodwin_pot_type), POINTER :: goodwin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_goodwin_clean', & routineP = moduleN//':'//routineN @@ -1537,12 +1483,10 @@ END SUBROUTINE pair_potential_goodwin_clean ! ***************************************************************************** !> \brief Destroys the GOODWIN potential type !> \param goodwin ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_goodwin_release(goodwin, error) + SUBROUTINE pair_potential_goodwin_release(goodwin) TYPE(goodwin_pot_type), POINTER :: goodwin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_goodwin_release', & @@ -1554,7 +1498,7 @@ SUBROUTINE pair_potential_goodwin_release(goodwin, error) failure = .FALSE. IF (ASSOCIATED(goodwin)) THEN DEALLOCATE(goodwin, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(goodwin) END SUBROUTINE pair_potential_goodwin_release @@ -1562,12 +1506,10 @@ END SUBROUTINE pair_potential_goodwin_release ! ***************************************************************************** !> \brief Creates the EAM potential type !> \param eam ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_eam_create(eam, error) + SUBROUTINE pair_potential_eam_create(eam) TYPE(eam_pot_type), POINTER :: eam - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_eam_create', & routineP = moduleN//':'//routineN @@ -1576,24 +1518,22 @@ SUBROUTINE pair_potential_eam_create(eam, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(eam),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(eam),cp_failure_level,routineP,failure) ALLOCATE(eam, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(eam%rho, eam%phi, eam%frho, eam%rhoval, eam%rval,& eam%rhop, eam%phip, eam%frhop) - CALL pair_potential_eam_clean(eam, error=error) + CALL pair_potential_eam_clean(eam) END SUBROUTINE pair_potential_eam_create ! ***************************************************************************** !> \brief Copy two EAM potential type !> \param eam_source ... !> \param eam_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_eam_copy(eam_source, eam_dest, error) + SUBROUTINE pair_potential_eam_copy(eam_source, eam_dest) TYPE(eam_pot_type), POINTER :: eam_source, eam_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_eam_copy', & routineP = moduleN//':'//routineN @@ -1602,8 +1542,8 @@ SUBROUTINE pair_potential_eam_copy(eam_source, eam_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(eam_source)) RETURN - IF (ASSOCIATED(eam_dest)) CALL pair_potential_eam_release(eam_dest, error=error) - CALL pair_potential_eam_create(eam_dest, error=error) + IF (ASSOCIATED(eam_dest)) CALL pair_potential_eam_release(eam_dest) + CALL pair_potential_eam_create(eam_dest) eam_dest%eam_file_name = eam_source%eam_file_name eam_dest%drar = eam_source%drar eam_dest%drhoar = eam_source%drhoar @@ -1631,12 +1571,10 @@ END SUBROUTINE pair_potential_eam_copy ! ***************************************************************************** !> \brief Creates the EAM potential type !> \param eam ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_eam_clean(eam, error) + SUBROUTINE pair_potential_eam_clean(eam) TYPE(eam_pot_type), POINTER :: eam - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_eam_clean', & routineP = moduleN//':'//routineN @@ -1663,12 +1601,10 @@ END SUBROUTINE pair_potential_eam_clean ! ***************************************************************************** !> \brief Destroys the EAM potential type !> \param eam ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_eam_release(eam, error) + SUBROUTINE pair_potential_eam_release(eam) TYPE(eam_pot_type), POINTER :: eam - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_eam_release', & routineP = moduleN//':'//routineN @@ -1680,50 +1616,48 @@ SUBROUTINE pair_potential_eam_release(eam, error) IF (ASSOCIATED(eam)) THEN IF (ASSOCIATED(eam%rho)) THEN DEALLOCATE(eam%rho, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(eam%rhop)) THEN DEALLOCATE(eam%rhop, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(eam%phi)) THEN DEALLOCATE(eam%phi, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(eam%phip)) THEN DEALLOCATE(eam%phip, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(eam%frho)) THEN DEALLOCATE(eam%frho, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(eam%frhop)) THEN DEALLOCATE(eam%frhop, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(eam%rval)) THEN DEALLOCATE(eam%rval, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(eam%rhoval)) THEN DEALLOCATE(eam%rhoval, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(eam, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE pair_potential_eam_release ! ***************************************************************************** !> \brief Creates the QUIP potential type !> \param quip ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_quip_create(quip, error) + SUBROUTINE pair_potential_quip_create(quip) TYPE(quip_pot_type), POINTER :: quip - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_quip_create', & routineP = moduleN//':'//routineN @@ -1732,25 +1666,23 @@ SUBROUTINE pair_potential_quip_create(quip, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(quip),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(quip),cp_failure_level,routineP,failure) ALLOCATE(quip, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) quip%quip_file_name="" quip%init_args="" quip%calc_args="" - CALL pair_potential_quip_clean(quip, error=error) + CALL pair_potential_quip_clean(quip) END SUBROUTINE pair_potential_quip_create ! ***************************************************************************** !> \brief Copy two QUIP potential type !> \param quip_source ... !> \param quip_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_quip_copy(quip_source, quip_dest, error) + SUBROUTINE pair_potential_quip_copy(quip_source, quip_dest) TYPE(quip_pot_type), POINTER :: quip_source, quip_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_quip_copy', & routineP = moduleN//':'//routineN @@ -1759,8 +1691,8 @@ SUBROUTINE pair_potential_quip_copy(quip_source, quip_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(quip_source)) RETURN - IF (ASSOCIATED(quip_dest)) CALL pair_potential_quip_release(quip_dest, error=error) - CALL pair_potential_quip_create(quip_dest, error=error) + IF (ASSOCIATED(quip_dest)) CALL pair_potential_quip_release(quip_dest) + CALL pair_potential_quip_create(quip_dest) quip_dest%quip_file_name = quip_source%quip_file_name quip_dest%init_args = quip_source%init_args quip_dest%calc_args = quip_source%calc_args @@ -1769,12 +1701,10 @@ END SUBROUTINE pair_potential_quip_copy ! ***************************************************************************** !> \brief Creates the QUIP potential type !> \param quip ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_quip_clean(quip, error) + SUBROUTINE pair_potential_quip_clean(quip) TYPE(quip_pot_type), POINTER :: quip - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_quip_clean', & routineP = moduleN//':'//routineN @@ -1791,12 +1721,10 @@ END SUBROUTINE pair_potential_quip_clean ! ***************************************************************************** !> \brief Destroys the QUIP potential type !> \param quip ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_quip_release(quip, error) + SUBROUTINE pair_potential_quip_release(quip) TYPE(quip_pot_type), POINTER :: quip - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_quip_release', & routineP = moduleN//':'//routineN @@ -1807,19 +1735,17 @@ SUBROUTINE pair_potential_quip_release(quip, error) failure = .FALSE. IF (ASSOCIATED(quip)) THEN DEALLOCATE(quip, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE pair_potential_quip_release ! ***************************************************************************** !> \brief Creates the BMHFT (TOSI-FUMI) potential type !> \param ft ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_bmhft_create(ft, error) + SUBROUTINE pair_potential_bmhft_create(ft) TYPE(ft_pot_type), POINTER :: ft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_bmhft_create', & routineP = moduleN//':'//routineN @@ -1828,22 +1754,20 @@ SUBROUTINE pair_potential_bmhft_create(ft, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(ft),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(ft),cp_failure_level,routineP,failure) ALLOCATE(ft, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_bmhft_clean(ft, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_bmhft_clean(ft) END SUBROUTINE pair_potential_bmhft_create ! ***************************************************************************** !> \brief Copy two BMHFT (TOSI-FUMI) potential type !> \param ft_source ... !> \param ft_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_bmhft_copy(ft_source, ft_dest, error) + SUBROUTINE pair_potential_bmhft_copy(ft_source, ft_dest) TYPE(ft_pot_type), POINTER :: ft_source, ft_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_bmhft_copy', & routineP = moduleN//':'//routineN @@ -1852,8 +1776,8 @@ SUBROUTINE pair_potential_bmhft_copy(ft_source, ft_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(ft_source)) RETURN - IF (ASSOCIATED(ft_dest)) CALL pair_potential_bmhft_release(ft_dest, error=error) - CALL pair_potential_bmhft_create(ft_dest, error=error) + IF (ASSOCIATED(ft_dest)) CALL pair_potential_bmhft_release(ft_dest) + CALL pair_potential_bmhft_create(ft_dest) ft_dest%A = ft_source%A ft_dest%B = ft_source%B ft_dest%C = ft_source%C @@ -1863,12 +1787,10 @@ END SUBROUTINE pair_potential_bmhft_copy ! ***************************************************************************** !> \brief Creates the BMHFT (TOSI-FUMI) potential type !> \param ft ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_bmhft_clean(ft, error) + SUBROUTINE pair_potential_bmhft_clean(ft) TYPE(ft_pot_type), POINTER :: ft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_bmhft_clean', & routineP = moduleN//':'//routineN @@ -1886,12 +1808,10 @@ END SUBROUTINE pair_potential_bmhft_clean ! ***************************************************************************** !> \brief Destroys the BMHFT potential type !> \param ft ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_bmhft_release(ft, error) + SUBROUTINE pair_potential_bmhft_release(ft) TYPE(ft_pot_type), POINTER :: ft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_bmhft_release', & routineP = moduleN//':'//routineN @@ -1902,7 +1822,7 @@ SUBROUTINE pair_potential_bmhft_release(ft, error) failure = .FALSE. IF (ASSOCIATED(ft)) THEN DEALLOCATE(ft, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(ft) END SUBROUTINE pair_potential_bmhft_release @@ -1910,12 +1830,10 @@ END SUBROUTINE pair_potential_bmhft_release ! ***************************************************************************** !> \brief Creates the BMHFTD (damped TOSI-FUMI) potential type !> \param ftd ... -!> \param error ... !> \author Mathieu Salanne 05.2010 ! ***************************************************************************** - SUBROUTINE pair_potential_bmhftd_create(ftd, error) + SUBROUTINE pair_potential_bmhftd_create(ftd) TYPE(ftd_pot_type), POINTER :: ftd - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_bmhftd_create', & routineP = moduleN//':'//routineN @@ -1924,22 +1842,20 @@ SUBROUTINE pair_potential_bmhftd_create(ftd, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(ftd),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(ftd),cp_failure_level,routineP,failure) ALLOCATE(ftd, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_bmhftd_clean(ftd, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_bmhftd_clean(ftd) END SUBROUTINE pair_potential_bmhftd_create ! ***************************************************************************** !> \brief Copy two BMHFTD (Damped TOSI-FUMI) potential type !> \param ftd_source ... !> \param ftd_dest ... -!> \param error ... !> \author Mathieu Salanne 05.2010 ! ***************************************************************************** - SUBROUTINE pair_potential_bmhftd_copy(ftd_source, ftd_dest, error) + SUBROUTINE pair_potential_bmhftd_copy(ftd_source, ftd_dest) TYPE(ftd_pot_type), POINTER :: ftd_source, ftd_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_bmhftd_copy', & routineP = moduleN//':'//routineN @@ -1948,8 +1864,8 @@ SUBROUTINE pair_potential_bmhftd_copy(ftd_source, ftd_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(ftd_source)) RETURN - IF (ASSOCIATED(ftd_dest)) CALL pair_potential_bmhftd_release(ftd_dest, error=error) - CALL pair_potential_bmhftd_create(ftd_dest, error=error) + IF (ASSOCIATED(ftd_dest)) CALL pair_potential_bmhftd_release(ftd_dest) + CALL pair_potential_bmhftd_create(ftd_dest) ftd_dest%A = ftd_source%A ftd_dest%B = ftd_source%B ftd_dest%C = ftd_source%C @@ -1960,12 +1876,10 @@ END SUBROUTINE pair_potential_bmhftd_copy ! ***************************************************************************** !> \brief Cleans the BMHFTD (damped TOSI-FUMI) potential type !> \param ftd ... -!> \param error ... !> \author Mathieu Salanne ! ***************************************************************************** - SUBROUTINE pair_potential_bmhftd_clean(ftd, error) + SUBROUTINE pair_potential_bmhftd_clean(ftd) TYPE(ftd_pot_type), POINTER :: ftd - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_bmhftd_clean', & routineP = moduleN//':'//routineN @@ -1984,12 +1898,10 @@ END SUBROUTINE pair_potential_bmhftd_clean ! ***************************************************************************** !> \brief Destroys the BMHFTD potential type !> \param ftd ... -!> \param error ... !> \author Mathieu Salanne 05.2010 ! ***************************************************************************** - SUBROUTINE pair_potential_bmhftd_release(ftd, error) + SUBROUTINE pair_potential_bmhftd_release(ftd) TYPE(ftd_pot_type), POINTER :: ftd - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_bmhftd_release', & @@ -2001,7 +1913,7 @@ SUBROUTINE pair_potential_bmhftd_release(ftd, error) failure = .FALSE. IF (ASSOCIATED(ftd)) THEN DEALLOCATE(ftd, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(ftd) END SUBROUTINE pair_potential_bmhftd_release @@ -2009,12 +1921,10 @@ END SUBROUTINE pair_potential_bmhftd_release ! ***************************************************************************** !> \brief Creates the IPBV potential type !> \param ipbv ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_ipbv_create(ipbv, error) + SUBROUTINE pair_potential_ipbv_create(ipbv) TYPE(ipbv_pot_type), POINTER :: ipbv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_ipbv_create', & routineP = moduleN//':'//routineN @@ -2023,22 +1933,20 @@ SUBROUTINE pair_potential_ipbv_create(ipbv, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(ipbv),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(ipbv),cp_failure_level,routineP,failure) ALLOCATE(ipbv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_ipbv_clean(ipbv, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_ipbv_clean(ipbv) END SUBROUTINE pair_potential_ipbv_create ! ***************************************************************************** !> \brief Copy two IPBV potential type !> \param ipbv_source ... !> \param ipbv_dest ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_ipbv_copy(ipbv_source, ipbv_dest, error) + SUBROUTINE pair_potential_ipbv_copy(ipbv_source, ipbv_dest) TYPE(ipbv_pot_type), POINTER :: ipbv_source, ipbv_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_ipbv_copy', & routineP = moduleN//':'//routineN @@ -2047,8 +1955,8 @@ SUBROUTINE pair_potential_ipbv_copy(ipbv_source, ipbv_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(ipbv_source)) RETURN - IF (ASSOCIATED(ipbv_dest)) CALL pair_potential_ipbv_release(ipbv_dest, error=error) - CALL pair_potential_ipbv_create(ipbv_dest, error=error) + IF (ASSOCIATED(ipbv_dest)) CALL pair_potential_ipbv_release(ipbv_dest) + CALL pair_potential_ipbv_create(ipbv_dest) ipbv_dest%a = ipbv_source%a ipbv_dest%rcore = ipbv_source%rcore ipbv_dest%b = ipbv_source%b @@ -2058,12 +1966,10 @@ END SUBROUTINE pair_potential_ipbv_copy ! ***************************************************************************** !> \brief Creates the IPBV potential type !> \param ipbv ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_ipbv_clean(ipbv, error) + SUBROUTINE pair_potential_ipbv_clean(ipbv) TYPE(ipbv_pot_type), POINTER :: ipbv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_ipbv_clean', & routineP = moduleN//':'//routineN @@ -2081,12 +1987,10 @@ END SUBROUTINE pair_potential_ipbv_clean ! ***************************************************************************** !> \brief Destroys the IPBV potential type !> \param ipbv ... -!> \param error ... !> \author Teodoro Laino [teo] 11.2005 ! ***************************************************************************** - SUBROUTINE pair_potential_ipbv_release(ipbv, error) + SUBROUTINE pair_potential_ipbv_release(ipbv) TYPE(ipbv_pot_type), POINTER :: ipbv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_ipbv_release', & routineP = moduleN//':'//routineN @@ -2097,7 +2001,7 @@ SUBROUTINE pair_potential_ipbv_release(ipbv, error) failure = .FALSE. IF (ASSOCIATED(ipbv)) THEN DEALLOCATE(ipbv, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(ipbv) END SUBROUTINE pair_potential_ipbv_release @@ -2105,12 +2009,10 @@ END SUBROUTINE pair_potential_ipbv_release ! ***************************************************************************** !> \brief Creates the Buckingham 4 ranges potential type !> \param buck4r ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buck4r_create(buck4r, error) + SUBROUTINE pair_potential_buck4r_create(buck4r) TYPE(buck4ran_pot_type), POINTER :: buck4r - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_buck4r_create', & routineP = moduleN//':'//routineN @@ -2119,22 +2021,20 @@ SUBROUTINE pair_potential_buck4r_create(buck4r, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(buck4r),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(buck4r),cp_failure_level,routineP,failure) ALLOCATE(buck4r, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_buck4r_clean(buck4r, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_buck4r_clean(buck4r) END SUBROUTINE pair_potential_buck4r_create ! ***************************************************************************** !> \brief Copy two Buckingham 4 ranges potential type !> \param buck4r_source ... !> \param buck4r_dest ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buck4r_copy(buck4r_source, buck4r_dest, error) + SUBROUTINE pair_potential_buck4r_copy(buck4r_source, buck4r_dest) TYPE(buck4ran_pot_type), POINTER :: buck4r_source, buck4r_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_buck4r_copy', & routineP = moduleN//':'//routineN @@ -2143,8 +2043,8 @@ SUBROUTINE pair_potential_buck4r_copy(buck4r_source, buck4r_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(buck4r_source)) RETURN - IF (ASSOCIATED(buck4r_dest)) CALL pair_potential_buck4r_release(buck4r_dest, error=error) - CALL pair_potential_buck4r_create(buck4r_dest, error=error) + IF (ASSOCIATED(buck4r_dest)) CALL pair_potential_buck4r_release(buck4r_dest) + CALL pair_potential_buck4r_create(buck4r_dest) buck4r_dest%a = buck4r_source%a buck4r_dest%b = buck4r_source%b buck4r_dest%c = buck4r_source%c @@ -2160,12 +2060,10 @@ END SUBROUTINE pair_potential_buck4r_copy ! ***************************************************************************** !> \brief Creates the Buckingham 4 ranges potential type !> \param buck4r ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buck4r_clean(buck4r, error) + SUBROUTINE pair_potential_buck4r_clean(buck4r) TYPE(buck4ran_pot_type), POINTER :: buck4r - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_buck4r_clean', & routineP = moduleN//':'//routineN @@ -2189,12 +2087,10 @@ END SUBROUTINE pair_potential_buck4r_clean ! ***************************************************************************** !> \brief Destroys the Buckingham 4 ranges potential type !> \param buck4r ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buck4r_release(buck4r, error) + SUBROUTINE pair_potential_buck4r_release(buck4r) TYPE(buck4ran_pot_type), POINTER :: buck4r - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_buck4r_release', & @@ -2206,7 +2102,7 @@ SUBROUTINE pair_potential_buck4r_release(buck4r, error) failure = .FALSE. IF (ASSOCIATED(buck4r)) THEN DEALLOCATE(buck4r, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(buck4r) END SUBROUTINE pair_potential_buck4r_release @@ -2214,12 +2110,10 @@ END SUBROUTINE pair_potential_buck4r_release ! ***************************************************************************** !> \brief Creates the Buckingham plus Morse potential type !> \param buckmo ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buckmo_create(buckmo, error) + SUBROUTINE pair_potential_buckmo_create(buckmo) TYPE(buckmorse_pot_type), POINTER :: buckmo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_buckmo_create', & routineP = moduleN//':'//routineN @@ -2228,22 +2122,20 @@ SUBROUTINE pair_potential_buckmo_create(buckmo, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(buckmo),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(buckmo),cp_failure_level,routineP,failure) ALLOCATE(buckmo, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_buckmo_clean(buckmo, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_buckmo_clean(buckmo) END SUBROUTINE pair_potential_buckmo_create ! ***************************************************************************** !> \brief Copy two Buckingham plus Morse potential type !> \param buckmo_source ... !> \param buckmo_dest ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buckmo_copy(buckmo_source, buckmo_dest, error) + SUBROUTINE pair_potential_buckmo_copy(buckmo_source, buckmo_dest) TYPE(buckmorse_pot_type), POINTER :: buckmo_source, buckmo_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_buckmo_copy', & routineP = moduleN//':'//routineN @@ -2252,8 +2144,8 @@ SUBROUTINE pair_potential_buckmo_copy(buckmo_source, buckmo_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(buckmo_source)) RETURN - IF (ASSOCIATED(buckmo_dest)) CALL pair_potential_buckmo_release(buckmo_dest, error=error) - CALL pair_potential_buckmo_create(buckmo_dest, error=error) + IF (ASSOCIATED(buckmo_dest)) CALL pair_potential_buckmo_release(buckmo_dest) + CALL pair_potential_buckmo_create(buckmo_dest) buckmo_dest%f0 = buckmo_source%f0 buckmo_dest%a1 = buckmo_source%a1 buckmo_dest%a2 = buckmo_source%a2 @@ -2268,12 +2160,10 @@ END SUBROUTINE pair_potential_buckmo_copy ! ***************************************************************************** !> \brief Creates the Buckingham plus Morse potential type !> \param buckmo ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buckmo_clean(buckmo, error) + SUBROUTINE pair_potential_buckmo_clean(buckmo) TYPE(buckmorse_pot_type), POINTER :: buckmo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_buckmo_clean', & routineP = moduleN//':'//routineN @@ -2296,12 +2186,10 @@ END SUBROUTINE pair_potential_buckmo_clean ! ***************************************************************************** !> \brief Destroys the Buckingham plus Morse potential type !> \param buckmo ... -!> \param error ... !> \author MI 10.2006 ! ***************************************************************************** - SUBROUTINE pair_potential_buckmo_release(buckmo, error) + SUBROUTINE pair_potential_buckmo_release(buckmo) TYPE(buckmorse_pot_type), POINTER :: buckmo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_buckmo_release', & @@ -2313,7 +2201,7 @@ SUBROUTINE pair_potential_buckmo_release(buckmo, error) failure = .FALSE. IF (ASSOCIATED(buckmo)) THEN DEALLOCATE(buckmo, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(buckmo) END SUBROUTINE pair_potential_buckmo_release @@ -2322,11 +2210,9 @@ END SUBROUTINE pair_potential_buckmo_release !> \brief Creates the Tersoff potential type !> (Tersoff, J. PRB 39(8), 5566, 1989) !> \param tersoff ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_tersoff_create(tersoff, error) + SUBROUTINE pair_potential_tersoff_create(tersoff) TYPE(tersoff_pot_type), POINTER :: tersoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_tersoff_create', & @@ -2336,10 +2222,10 @@ SUBROUTINE pair_potential_tersoff_create(tersoff, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(tersoff),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(tersoff),cp_failure_level,routineP,failure) ALLOCATE(tersoff, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_tersoff_clean(tersoff, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_tersoff_clean(tersoff) END SUBROUTINE pair_potential_tersoff_create ! ***************************************************************************** @@ -2347,11 +2233,9 @@ END SUBROUTINE pair_potential_tersoff_create !> (Tersoff, J. PRB 39(8), 5566, 1989) !> \param tersoff_source ... !> \param tersoff_dest ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_tersoff_copy(tersoff_source, tersoff_dest, error) + SUBROUTINE pair_potential_tersoff_copy(tersoff_source, tersoff_dest) TYPE(tersoff_pot_type), POINTER :: tersoff_source, tersoff_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_tersoff_copy', & routineP = moduleN//':'//routineN @@ -2360,8 +2244,8 @@ SUBROUTINE pair_potential_tersoff_copy(tersoff_source, tersoff_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(tersoff_source)) RETURN - IF (ASSOCIATED(tersoff_dest)) CALL pair_potential_tersoff_release(tersoff_dest, error=error) - CALL pair_potential_tersoff_create(tersoff_dest, error=error) + IF (ASSOCIATED(tersoff_dest)) CALL pair_potential_tersoff_release(tersoff_dest) + CALL pair_potential_tersoff_create(tersoff_dest) tersoff_dest%A = tersoff_source%A tersoff_dest%B = tersoff_source%B tersoff_dest%lambda1 = tersoff_source%lambda1 @@ -2382,11 +2266,9 @@ END SUBROUTINE pair_potential_tersoff_copy !> \brief Creates the Tersoff potential type !> (Tersoff, J. PRB 39(8), 5566, 1989) !> \param tersoff ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_tersoff_clean(tersoff, error) + SUBROUTINE pair_potential_tersoff_clean(tersoff) TYPE(tersoff_pot_type), POINTER :: tersoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_tersoff_clean', & routineP = moduleN//':'//routineN @@ -2415,11 +2297,9 @@ END SUBROUTINE pair_potential_tersoff_clean !> \brief Destroys the Tersoff !> (Tersoff, J. PRB 39(8), 5566, 1989) !> \param tersoff ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_tersoff_release(tersoff, error) + SUBROUTINE pair_potential_tersoff_release(tersoff) TYPE(tersoff_pot_type), POINTER :: tersoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_tersoff_release', & @@ -2431,7 +2311,7 @@ SUBROUTINE pair_potential_tersoff_release(tersoff, error) failure = .FALSE. IF (ASSOCIATED(tersoff)) THEN DEALLOCATE(tersoff, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(tersoff) END SUBROUTINE pair_potential_tersoff_release @@ -2440,11 +2320,9 @@ END SUBROUTINE pair_potential_tersoff_release !> \brief Creates the Siepmann-Sprik potential type !> (Siepmann and Sprik, J. Chem. Phys. 102(1) 511, 1995) !> \param siepmann ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_siepmann_create(siepmann, error) + SUBROUTINE pair_potential_siepmann_create(siepmann) TYPE(siepmann_pot_type), POINTER :: siepmann - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_siepmann_create', & @@ -2454,21 +2332,19 @@ SUBROUTINE pair_potential_siepmann_create(siepmann, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(siepmann),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(siepmann),cp_failure_level,routineP,failure) ALLOCATE(siepmann, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pair_potential_siepmann_clean(siepmann, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pair_potential_siepmann_clean(siepmann) END SUBROUTINE pair_potential_siepmann_create ! ***************************************************************************** !> \brief Copy two Siepmann potential type !> (Siepmann and Sprik, J. Chem. Phys. 102(1) 511, 1995) !> \param siepmann_source ... !> \param siepmann_dest ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_siepmann_copy(siepmann_source, siepmann_dest, error) + SUBROUTINE pair_potential_siepmann_copy(siepmann_source, siepmann_dest) TYPE(siepmann_pot_type), POINTER :: siepmann_source, siepmann_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pair_potential_siepmann_copy', & routineP = moduleN//':'//routineN @@ -2477,8 +2353,8 @@ SUBROUTINE pair_potential_siepmann_copy(siepmann_source, siepmann_dest, error) failure = .FALSE. IF (.NOT.ASSOCIATED(siepmann_source)) RETURN - IF (ASSOCIATED(siepmann_dest)) CALL pair_potential_siepmann_release(siepmann_dest, error=error) - CALL pair_potential_siepmann_create(siepmann_dest, error=error) + IF (ASSOCIATED(siepmann_dest)) CALL pair_potential_siepmann_release(siepmann_dest) + CALL pair_potential_siepmann_create(siepmann_dest) siepmann_dest%B = siepmann_source%B siepmann_dest%D = siepmann_source%D siepmann_dest%E = siepmann_source%E @@ -2492,11 +2368,9 @@ END SUBROUTINE pair_potential_siepmann_copy !> \brief Creates the Siepmann-Sprik potential type !> (Siepmann and Sprik, J. Chem. Phys. 102(1) 511, 1995) !> \param siepmann ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_siepmann_clean(siepmann, error) + SUBROUTINE pair_potential_siepmann_clean(siepmann) TYPE(siepmann_pot_type), POINTER :: siepmann - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_siepmann_clean', & @@ -2519,11 +2393,9 @@ END SUBROUTINE pair_potential_siepmann_clean !> \brief Destroys the Siepmann-Sprik potential !> (Siepmann and Sprik, J. Chem. Phys. 102(1) 511, 1995) !> \param siepmann ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_potential_siepmann_release(siepmann, error) + SUBROUTINE pair_potential_siepmann_release(siepmann) TYPE(siepmann_pot_type), POINTER :: siepmann - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'pair_potential_siepmann_release', & @@ -2535,7 +2407,7 @@ SUBROUTINE pair_potential_siepmann_release(siepmann, error) failure = .FALSE. IF (ASSOCIATED(siepmann)) THEN DEALLOCATE(siepmann, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(siepmann) END SUBROUTINE pair_potential_siepmann_release diff --git a/src/particle_methods.F b/src/particle_methods.F index 09eb04196f..e5298aa26c 100644 --- a/src/particle_methods.F +++ b/src/particle_methods.F @@ -86,7 +86,6 @@ MODULE particle_methods !> \param last_sgf ... !> \param nsgf ... !> \param basis ... -!> \param error ... !> \date 14.01.2002 !> \par History !> - particle type cleaned (13.10.2003,MK) @@ -95,7 +94,7 @@ MODULE particle_methods !> \version 1.0 ! ***************************************************************************** SUBROUTINE get_particle_set(particle_set,qs_kind_set,first_sgf,last_sgf,nsgf,& - basis,error) + basis) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -105,7 +104,6 @@ SUBROUTINE get_particle_set(particle_set,qs_kind_set,first_sgf,last_sgf,nsgf,& OPTIONAL :: first_sgf, last_sgf, nsgf TYPE(gto_basis_set_p_type), & DIMENSION(:), OPTIONAL, POINTER :: basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_particle_set', & routineP = moduleN//':'//routineN @@ -115,17 +113,17 @@ SUBROUTINE get_particle_set(particle_set,qs_kind_set,first_sgf,last_sgf,nsgf,& LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) nparticle = SIZE(particle_set) IF (PRESENT(first_sgf)) THEN - CPPrecondition(SIZE(first_sgf) >= nparticle,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(first_sgf) >= nparticle,cp_failure_level,routineP,failure) END IF IF (PRESENT(last_sgf)) THEN - CPPrecondition(SIZE(last_sgf) >= nparticle,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(last_sgf) >= nparticle,cp_failure_level,routineP,failure) END IF IF (PRESENT(nsgf)) THEN - CPPrecondition(SIZE(nsgf) >= nparticle,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(nsgf) >= nparticle,cp_failure_level,routineP,failure) END IF IF (PRESENT(first_sgf).OR.PRESENT(last_sgf).OR.PRESENT(nsgf)) THEN @@ -135,7 +133,7 @@ SUBROUTINE get_particle_set(particle_set,qs_kind_set,first_sgf,last_sgf,nsgf,& IF (PRESENT(basis)) THEN CALL get_gto_basis_set(gto_basis_set=basis(ikind)%gto_basis_set,nsgf=ns) ELSE - CALL get_qs_kind(qs_kind_set(ikind), nsgf=ns, error=error) + CALL get_qs_kind(qs_kind_set(ikind), nsgf=ns) END IF IF (PRESENT(nsgf)) nsgf(iparticle) = ns IF (PRESENT(first_sgf)) first_sgf(iparticle) = isgf + 1 @@ -167,7 +165,6 @@ END SUBROUTINE get_particle_set !> \param charge_occup ... !> \param charge_beta ... !> \param charge_extended ... -!> \param error ... !> \date 14.01.2002 !> \author MK !> \version 1.0 @@ -175,7 +172,7 @@ END SUBROUTINE get_particle_set SUBROUTINE write_particle_coordinates(particle_set,iunit,output_format,& content,title,cell,array,unit_conv,& charge_occup,charge_beta,& - charge_extended,error) + charge_extended) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -187,7 +184,6 @@ SUBROUTINE write_particle_coordinates(particle_set,iunit,output_format,& REAL(KIND=dp), INTENT(IN), OPTIONAL :: unit_conv LOGICAL, INTENT(IN), OPTIONAL :: charge_occup, charge_beta, & charge_extended - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_particle_coordinates', & routineP = moduleN//':'//routineN @@ -320,15 +316,15 @@ SUBROUTINE write_particle_coordinates(particle_set,iunit,output_format,& ! Cell vector a is aligned with the x axis and the cell vector b lies ! in the xy plane. NULLIFY (cell_dcd) - CALL cell_create(cell_dcd,error=error) - CALL cell_clone(cell,cell_dcd,error=error) + CALL cell_create(cell_dcd) + CALL cell_clone(cell,cell_dcd) angles(1) = angle_alpha/degree angles(2) = angle_beta/degree angles(3) = angle_gamma/degree CALL set_cell_param(cell_dcd,abc,angles,& - do_init_cell=.TRUE.,error=error) + do_init_cell=.TRUE.) h(1:3,1:3) = MATMUL(cell_dcd%hmat(1:3,1:3),cell%h_inv(1:3,1:3)) - CALL cell_release(cell_dcd,error=error) + CALL cell_release(cell_dcd) END IF ALLOCATE (arr(3,natom),STAT=stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -443,7 +439,7 @@ SUBROUTINE write_particle_coordinates(particle_set,iunit,output_format,& ELSE qeff = 0.0_dp END IF - IF (ASSOCIATED(shell)) CALL get_shell(shell=shell,charge=qeff,error=error) + IF (ASSOCIATED(shell)) CALL get_shell(shell=shell,charge=qeff) WRITE (UNIT=line( 1: 6),FMT="(A6)") "ATOM " WRITE (UNIT=line( 7:11),FMT="(I5)") MODULO(iatom,100000) WRITE (UNIT=line(13:16),FMT="(A4)") ADJUSTL(name) @@ -492,18 +488,16 @@ END SUBROUTINE write_particle_coordinates !> \param particle_set ... !> \param subsys_section ... !> \param charges ... -!> \param error ... !> \date 05.06.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** SUBROUTINE write_fist_particle_coordinates(particle_set,subsys_section,& - charges, error) + charges) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(section_vals_type), POINTER :: subsys_section REAL(KIND=dp), DIMENSION(:), POINTER :: charges - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'write_fist_particle_coordinates', & @@ -519,12 +513,12 @@ SUBROUTINE write_fist_particle_coordinates(particle_set,subsys_section,& NULLIFY (logger) NULLIFY (shell_kind) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%ATOMIC_COORDINATES",extension=".coordLog",error=error) + "PRINT%ATOMIC_COORDINATES",extension=".coordLog") - CALL section_vals_val_get(subsys_section,"PRINT%ATOMIC_COORDINATES%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(subsys_section,"PRINT%ATOMIC_COORDINATES%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) CALL uppercase(unit_str) IF (iw > 0) THEN WRITE (UNIT=iw,FMT="(/,/,T2,A)")& @@ -544,8 +538,7 @@ SUBROUTINE write_fist_particle_coordinates(particle_set,subsys_section,& IF (ASSOCIATED(shell_kind)) THEN CALL get_shell(shell=shell_kind,& charge_core=qcore,& - charge_shell=qshell,& - error=error) + charge_shell=qshell) qeff = qcore + qshell END IF WRITE (UNIT=iw,& @@ -557,7 +550,7 @@ SUBROUTINE write_fist_particle_coordinates(particle_set,subsys_section,& END IF CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%ATOMIC_COORDINATES", error=error) + "PRINT%ATOMIC_COORDINATES") END SUBROUTINE write_fist_particle_coordinates @@ -567,12 +560,11 @@ END SUBROUTINE write_fist_particle_coordinates !> \param qs_kind_set ... !> \param subsys_section ... !> \param label ... -!> \param error ... !> \date 05.06.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_qs_particle_coordinates(particle_set,qs_kind_set,subsys_section,label,error) + SUBROUTINE write_qs_particle_coordinates(particle_set,qs_kind_set,subsys_section,label) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -580,7 +572,6 @@ SUBROUTINE write_qs_particle_coordinates(particle_set,qs_kind_set,subsys_section POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section CHARACTER(LEN=*), INTENT(IN) :: label - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'write_qs_particle_coordinates', & @@ -596,12 +587,12 @@ SUBROUTINE write_qs_particle_coordinates(particle_set,qs_kind_set,subsys_section CALL timeset(routineN,handle) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%ATOMIC_COORDINATES",extension=".coordLog",error=error) + "PRINT%ATOMIC_COORDINATES",extension=".coordLog") - CALL section_vals_val_get(subsys_section,"PRINT%ATOMIC_COORDINATES%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(subsys_section,"PRINT%ATOMIC_COORDINATES%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (iw>0) THEN WRITE (UNIT=iw,FMT="(/,/,T2,A)")& "MODULE "//TRIM(label)//": ATOMIC COORDINATES IN "//TRIM(unit_str) @@ -616,7 +607,7 @@ SUBROUTINE write_qs_particle_coordinates(particle_set,qs_kind_set,subsys_section element_symbol=element_symbol,& mass=mass,& z=z) - CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff) WRITE (UNIT=iw,& FMT="(T2,I7,1X,I5,1X,A2,1X,I3,3F12.6,4X,F6.2,2X,F11.4)")& iatom,ikind,element_symbol,z,& @@ -626,7 +617,7 @@ SUBROUTINE write_qs_particle_coordinates(particle_set,qs_kind_set,subsys_section END IF CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%ATOMIC_COORDINATES", error=error) + "PRINT%ATOMIC_COORDINATES") CALL timestop(handle) @@ -637,18 +628,16 @@ END SUBROUTINE write_qs_particle_coordinates !> \param particle_set ... !> \param cell ... !> \param subsys_section ... -!> \param error ... !> \date 06.10.2000 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_particle_distances(particle_set,cell,subsys_section,error) + SUBROUTINE write_particle_distances(particle_set,cell,subsys_section) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_particle_distances', & routineP = moduleN//':'//routineN @@ -668,17 +657,17 @@ SUBROUTINE write_particle_distances(particle_set,cell,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%INTERATOMIC_DISTANCES",extension=".distLog",error=error) + "PRINT%INTERATOMIC_DISTANCES",extension=".distLog") - CALL section_vals_val_get(subsys_section,"PRINT%INTERATOMIC_DISTANCES%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(subsys_section,"PRINT%INTERATOMIC_DISTANCES%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (iw>0) THEN CALL get_cell(cell=cell, periodic=periodic) natom = SIZE(particle_set) ALLOCATE (distance_matrix(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) distance_matrix(:,:) = 0.0_dp DO iatom=1,natom DO jatom=iatom+1,natom @@ -694,11 +683,11 @@ SUBROUTINE write_particle_distances(particle_set,cell,subsys_section,error) WRITE (UNIT=iw,FMT="(/,/,T2,A)")& "INTERATOMIC DISTANCES IN "//TRIM(unit_str) - CALL write_particle_matrix(distance_matrix,particle_set,iw,error=error) + CALL write_particle_matrix(distance_matrix,particle_set,iw) END IF CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%INTERATOMIC_DISTANCES", error=error) + "PRINT%INTERATOMIC_DISTANCES") CALL timestop(handle) @@ -711,16 +700,14 @@ END SUBROUTINE write_particle_distances !> \param iw ... !> \param el_per_part ... !> \param Ilist ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_particle_matrix(matrix,particle_set,iw,el_per_part,Ilist,error) + SUBROUTINE write_particle_matrix(matrix,particle_set,iw,el_per_part,Ilist) REAL(KIND=dp), DIMENSION(:, :) :: matrix TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set INTEGER, INTENT(IN) :: iw INTEGER, INTENT(IN), OPTIONAL :: el_per_part INTEGER, DIMENSION(:), OPTIONAL, POINTER :: Ilist - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=2) :: element_symbol INTEGER :: from, i, iatom, icol, jatom, & @@ -772,19 +759,17 @@ END SUBROUTINE write_particle_matrix !> \param particle_set ... !> \param cell ... !> \param input_section ... -!> \param error ... !> \date 11.03.04 !> \par History !> Recovered (23.03.06,MK) !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_structure_data(particle_set,cell,input_section,error) + SUBROUTINE write_structure_data(particle_set,cell,input_section) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: input_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_structure_data', & routineP = moduleN//':'//routineN @@ -810,28 +795,25 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) NULLIFY (section) string = "" - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger=logger,& basis_section=input_section,& print_key_path="PRINT%STRUCTURE_DATA",& - extension=".coordLog",& - error=error) + extension=".coordLog") - CALL section_vals_val_get(input_section,"PRINT%STRUCTURE_DATA%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(input_section,"PRINT%STRUCTURE_DATA%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) CALL uppercase(unit_str) IF (iw > 0) THEN natom = SIZE(particle_set) section => section_vals_get_subs_vals(section_vals=input_section,& - subsection_name="PRINT%STRUCTURE_DATA",& - error=error) + subsection_name="PRINT%STRUCTURE_DATA") WRITE (UNIT=iw,FMT="(/,T2,A)") "REQUESTED STRUCTURE DATA" ! Print the requested atomic position vectors CALL section_vals_val_get(section_vals=section,& keyword_name="POSITION",& - n_rep_val=n_rep,& - error=error) + n_rep_val=n_rep) IF (n_rep > 0) THEN WRITE (UNIT=iw,FMT="(/,T3,A,/)")& "Position vectors r(i) of the atoms i in "//TRIM(unit_str) @@ -840,8 +822,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) CALL section_vals_val_get(section_vals=section,& keyword_name="POSITION",& i_rep_val=i_rep,& - i_vals=atomic_indices,& - error=error) + i_vals=atomic_indices) n_vals = SIZE(atomic_indices) new_size = old_size + n_vals CALL reallocate(index_list,1,new_size) @@ -849,10 +830,10 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) old_size = new_size END DO ALLOCATE (work(new_size),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) CALL sort(index_list,new_size,work) DEALLOCATE (work,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) DO i=1,new_size WRITE (UNIT=string,FMT="(A,I0,A)") "(",index_list(i),")" IF ((index_list(i) < 1).OR.(index_list(i) > natom)) THEN @@ -868,14 +849,13 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) "r"//TRIM(string),"=",pbc(particle_set(index_list(i))%r(1:3),cell)*conv END DO DEALLOCATE (index_list,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) END IF ! Print the requested atomic position vectors in scaled coordinates CALL section_vals_val_get(section_vals=section,& keyword_name="POSITION_SCALED",& - n_rep_val=n_rep,& - error=error) + n_rep_val=n_rep) IF (n_rep > 0) THEN WRITE (UNIT=iw,FMT="(/,T3,A,/)")& "Position vectors s(i) of the atoms i in scaled coordinates" @@ -884,8 +864,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) CALL section_vals_val_get(section_vals=section,& keyword_name="POSITION_SCALED",& i_rep_val=i_rep,& - i_vals=atomic_indices,& - error=error) + i_vals=atomic_indices) n_vals = SIZE(atomic_indices) new_size = old_size + n_vals CALL reallocate(index_list,1,new_size) @@ -893,10 +872,10 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) old_size = new_size END DO ALLOCATE (work(new_size),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) CALL sort(index_list,new_size,work) DEALLOCATE (work,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) DO i=1,new_size WRITE (UNIT=string,FMT="(A,I0,A)") "(",index_list(i),")" IF ((index_list(i) < 1).OR.(index_list(i) > natom)) THEN @@ -914,14 +893,13 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) "s"//TRIM(string),"=",s(1:3) END DO DEALLOCATE (index_list,STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) END IF ! Print the requested distances CALL section_vals_val_get(section_vals=section,& keyword_name="DISTANCE",& - n_rep_val=n,& - error=error) + n_rep_val=n) IF (n > 0) THEN WRITE (UNIT=iw,FMT="(/,T3,A,/)")& "Distance vector r(i,j) between the atom i and j in "//& @@ -930,8 +908,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) CALL section_vals_val_get(section_vals=section,& keyword_name="DISTANCE",& i_rep_val=i,& - i_vals=atomic_indices,& - error=error) + i_vals=atomic_indices) string = "" WRITE (UNIT=string,FMT="(A,2(I0,A))")& "(",atomic_indices(1),",",atomic_indices(2),")" @@ -954,8 +931,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) ! Print the requested angles CALL section_vals_val_get(section_vals=section,& keyword_name="ANGLE",& - n_rep_val=n,& - error=error) + n_rep_val=n) IF (n > 0) THEN WRITE (UNIT=iw,FMT="(/,T3,A,/)")& "Angle a(i,j,k) between the atomic distance vectors r(j,i) and "//& @@ -964,8 +940,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) CALL section_vals_val_get(section_vals=section,& keyword_name="ANGLE",& i_rep_val=i,& - i_vals=atomic_indices,& - error=error) + i_vals=atomic_indices) string = "" WRITE (UNIT=string,FMT="(A,3(I0,A))")& "(",atomic_indices(1),",",atomic_indices(2),",",atomic_indices(3),")" @@ -988,8 +963,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) ! Print the requested dihedral angles CALL section_vals_val_get(section_vals=section,& keyword_name="DIHEDRAL_ANGLE",& - n_rep_val=n,& - error=error) + n_rep_val=n) IF (n > 0) THEN WRITE (UNIT=iw,FMT="(/,T3,A,/)")& "Dihedral angle d(i,j,k,l) between the planes (i,j,k) and (j,k,l) "//& @@ -998,8 +972,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) CALL section_vals_val_get(section_vals=section,& keyword_name="DIHEDRAL_ANGLE",& i_rep_val=i,& - i_vals=atomic_indices,& - error=error) + i_vals=atomic_indices) string = "" WRITE (UNIT=string,FMT="(A,4(I0,A))")& "(",atomic_indices(1),",",atomic_indices(2),",",& @@ -1023,7 +996,7 @@ SUBROUTINE write_structure_data(particle_set,cell,input_section,error) END IF END IF CALL cp_print_key_finished_output(iw,logger,input_section,& - "PRINT%STRUCTURE_DATA", error=error) + "PRINT%STRUCTURE_DATA") CALL timestop(handle) diff --git a/src/paw_proj_set_types.F b/src/paw_proj_set_types.F index 4c312c97f9..45d70f391b 100644 --- a/src/paw_proj_set_types.F +++ b/src/paw_proj_set_types.F @@ -91,13 +91,11 @@ MODULE paw_proj_set_types ! ***************************************************************************** !> \brief Allocate projector type for GAPW !> \param paw_proj_set ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_paw_proj_set(paw_proj_set,error) + SUBROUTINE allocate_paw_proj_set(paw_proj_set) TYPE(paw_proj_set_type), POINTER :: paw_proj_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_paw_proj_set', & routineP = moduleN//':'//routineN @@ -106,10 +104,10 @@ SUBROUTINE allocate_paw_proj_set(paw_proj_set,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(paw_proj_set)) CALL deallocate_paw_proj_set(paw_proj_set,error) + IF (ASSOCIATED(paw_proj_set)) CALL deallocate_paw_proj_set(paw_proj_set) ALLOCATE (paw_proj_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (paw_proj_set%nprj) NULLIFY (paw_proj_set%lx) @@ -146,12 +144,10 @@ END SUBROUTINE allocate_paw_proj_set ! ***************************************************************************** !> \brief Deallocate a projector-type set data set. !> \param paw_proj_set ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_paw_proj_set(paw_proj_set,error) + SUBROUTINE deallocate_paw_proj_set(paw_proj_set) TYPE(paw_proj_set_type), POINTER :: paw_proj_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_paw_proj_set', & routineP = moduleN//':'//routineN @@ -162,60 +158,60 @@ SUBROUTINE deallocate_paw_proj_set(paw_proj_set,error) failure = .FALSE. DEALLOCATE (paw_proj_set%zisomin,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%zprjisomin,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%nprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%lx,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%ly,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%lz,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%ll,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%m,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%first_prj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%last_prj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%first_prjs,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%zetprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%cprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%cprj_s,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%csprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%local_oce_cphi_h,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%local_oce_cphi_s,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%local_oce_sphi_h,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%local_oce_sphi_s,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%sphi_h,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%sphi_s,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%gccprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%isoprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%rzetprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%o2nindex,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set%n2oindex,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (paw_proj_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_paw_proj_set ! ***************************************************************************** @@ -226,11 +222,10 @@ END SUBROUTINE deallocate_paw_proj_set !> \param qs_control ... !> \param max_rad_local_type ... !> \param force_env_section ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** SUBROUTINE projectors(paw_proj,orb_basis,rc,qs_control,max_rad_local_type,& - force_env_section,error) + force_env_section) TYPE(paw_proj_set_type), POINTER :: paw_proj TYPE(gto_basis_set_type), POINTER :: orb_basis @@ -238,7 +233,6 @@ SUBROUTINE projectors(paw_proj,orb_basis,rc,qs_control,max_rad_local_type,& TYPE(qs_control_type), INTENT(IN) :: qs_control REAL(dp), INTENT(IN) :: max_rad_local_type TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'projectors', & routineP = moduleN//':'//routineN @@ -256,7 +250,7 @@ SUBROUTINE projectors(paw_proj,orb_basis,rc,qs_control,max_rad_local_type,& eps_orb = qs_control%eps_pgf_orb CALL build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & - rc,eps_orb,max_rad_local,force_env_section,error) + rc,eps_orb,max_rad_local,force_env_section) END SUBROUTINE projectors @@ -271,18 +265,16 @@ END SUBROUTINE projectors !> \param eps_orb ... !> \param max_rad_local ... !> \param force_env_section ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & - rc,eps_orb,max_rad_local,force_env_section,error) + rc,eps_orb,max_rad_local,force_env_section) TYPE(paw_proj_set_type), POINTER :: paw_proj TYPE(gto_basis_set_type), POINTER :: orb_basis REAL(dp), INTENT(IN) :: eps_fit, eps_iso, eps_svd, & rc, eps_orb, max_rad_local TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_projector', & routineP = moduleN//':'//routineN @@ -313,14 +305,14 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY (first_cgf,first_sgf,last_cgf,last_sgf,gcc,l,set_radius,set_radius2) NULLIFY (cphi,sphi,lmax,lmin,npgf,nshell,zet,zetp,smat,work,gcca) failure =.FALSE. - CPPrecondition(ASSOCIATED(paw_proj),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(orb_basis),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(paw_proj),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(orb_basis),cp_failure_level,routineP,failure) IF(.NOT. failure) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis,name=bsname,& @@ -333,22 +325,22 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & gcc=gcca) paw_proj%maxl = maxl - CPPrecondition(.NOT. ASSOCIATED(paw_proj%zisomin),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT. ASSOCIATED(paw_proj%zprjisomin),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT. ASSOCIATED(paw_proj%nprj),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT. ASSOCIATED(paw_proj%zisomin),cp_failure_level,routineP,failure) + CPPrecondition(.NOT. ASSOCIATED(paw_proj%zprjisomin),cp_failure_level,routineP,failure) + CPPrecondition(.NOT. ASSOCIATED(paw_proj%nprj),cp_failure_level,routineP,failure) ALLOCATE(paw_proj%zisomin(0:maxl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%zisomin(0:maxl) = 0.0_dp ALLOCATE(paw_proj%zprjisomin(0:maxl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%zprjisomin(0:maxl) = 0.0_dp ALLOCATE(paw_proj%nprj(0:maxl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%nprj(0:maxl) = 0 output_unit = cp_print_key_unit_nr(logger,force_env_section,& - "DFT%PRINT%GAPW%PROJECTORS",extension=".Log",error=error) + "DFT%PRINT%GAPW%PROJECTORS",extension=".Log") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A)")& @@ -356,7 +348,7 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & END IF ALLOCATE(set_radius(nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) set_radius = 0.0_dp DO iset = 1,nset DO is = 1,nshell(iset) @@ -366,7 +358,7 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & END DO ! iset ALLOCATE(set_radius2(maxpgf,0:maxl,nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) set_radius2 = 0.0_dp DO iset = 1,nset DO lshell = lmin(iset),lmax(iset) @@ -395,16 +387,16 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & ! *** Allocate exponents and coefficients *** ALLOCATE(paw_proj%zetprj(maxnprj,0:maxl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%zetprj(1:maxnprj,0:maxl)=0.0_dp ALLOCATE(paw_proj%gccprj(maxnprj,maxpgf,0:maxl,nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%gccprj=0.0_dp ALLOCATE(paw_proj%rzetprj(maxnprj,0:maxl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%rzetprj(1:maxnprj,0:maxl)=0.0_dp ALLOCATE(paw_proj%isoprj(maxnprj,0:maxl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%isoprj = .FALSE. mp = 0 @@ -419,11 +411,11 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & np = paw_proj%nprj(lshell) ALLOCATE(isoprj(np),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) isoprj = .FALSE. ALLOCATE(zet(np),zetp(np),gcc(np,np),smat(np,np),work(np,np),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) zet(:) = 0.0_dp zetp(:) = 0.0_dp @@ -517,11 +509,11 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & ENDDO ! FIXME ... catch the case where np == 0 - CPPrecondition(np > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(np > 0,cp_failure_level,routineP,failure) ! *** Compute inverse of the transpose *** IF (eps_svd.EQ.0.0_dp) THEN - CALL invert_matrix(smat,gcc,my_error,"T",error=error) + CALL invert_matrix(smat,gcc,my_error,"T") ELSE work=TRANSPOSE(smat) ! workspace query @@ -596,19 +588,19 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & ! *** Release the working storage for the current value lshell *** DEALLOCATE(isoprj,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(gcc,zet,zetp,smat,work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO ! lshell CALL cp_print_key_finished_output(output_unit,logger,force_env_section,& - "DFT%PRINT%GAPW%PROJECTORS",error=error) + "DFT%PRINT%GAPW%PROJECTORS") ! *** Release the working storage for the current value lshell *** DEALLOCATE(set_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(set_radius2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! *** Count primitives basis functions for the projectors paw_proj%ncgauprj = 0 @@ -708,23 +700,23 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & ! local coefficients for the one center expansions : oce ! the coefficients are calculated for the full and soft expansions ALLOCATE(paw_proj%local_oce_cphi_h(maxco,ncgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%local_oce_cphi_h = 0.0_dp ALLOCATE(paw_proj%local_oce_sphi_h(maxco,nsgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%local_oce_sphi_h = 0.0_dp ALLOCATE(paw_proj%sphi_h(maxco,nsgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%sphi_h = 0.0_dp ALLOCATE(paw_proj%local_oce_cphi_s(maxco,ncgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%local_oce_cphi_s = 0.0_dp ALLOCATE(paw_proj%local_oce_sphi_s(maxco,nsgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%local_oce_sphi_s = 0.0_dp ALLOCATE(paw_proj%sphi_s(maxco,nsgf),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%sphi_s = 0.0_dp ! *** Cartesian *** @@ -816,9 +808,9 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & !Index transformation OLD-NEW ALLOCATE(paw_proj%o2nindex(maxso*nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(paw_proj%n2oindex(maxso*nset),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%o2nindex = 0 paw_proj%n2oindex = 0 ico = 1 @@ -842,7 +834,7 @@ SUBROUTINE build_projector(paw_proj,orb_basis,eps_fit,eps_iso,eps_svd, & paw_proj%nsatbas = mp paw_proj%nsotot = nset*maxso ALLOCATE(paw_proj%csprj(nsgauprj,mp),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) paw_proj%csprj = 0._dp DO k=1,mp ico = paw_proj%n2oindex(k) diff --git a/src/pexsi_interface.F b/src/pexsi_interface.F index 68c966795c..9890dab2ba 100644 --- a/src/pexsi_interface.F +++ b/src/pexsi_interface.F @@ -70,14 +70,13 @@ MODULE pexsi_interface !> \param ordering ... !> \param npSymbFact ... !> \param verbosity ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_pexsi_set_options(pexsi_options, temperature, gap, deltaE, numPole, & isInertiaCount, maxPEXSIIter, muMin0, muMax0, mu0, & muInertiaTolerance, muInertiaExpansion, & muPEXSISafeGuard, numElectronPEXSITolerance, & matrixType, isSymbolicFactorize, ordering, & - npSymbFact, verbosity, error) + npSymbFact, verbosity) TYPE(cp_pexsi_options), INTENT(INOUT) :: pexsi_options REAL(KIND=real_8), INTENT(IN), OPTIONAL :: temperature, gap, deltaE @@ -90,7 +89,6 @@ SUBROUTINE cp_pexsi_set_options(pexsi_options, temperature, gap, deltaE, numPole isSymbolicFactorize, & ordering, npSymbFact, & verbosity - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_pexsi_set_options', & routineP = moduleN//':'//routineN @@ -122,7 +120,7 @@ SUBROUTINE cp_pexsi_set_options(pexsi_options, temperature, gap, deltaE, numPole #else CALL cp_assert (.FALSE., cp_fatal_level, cp_assertion_failed, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END SUBROUTINE cp_pexsi_set_options @@ -147,14 +145,13 @@ END SUBROUTINE cp_pexsi_set_options !> \param ordering ... !> \param npSymbFact ... !> \param verbosity ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_pexsi_get_options(pexsi_options, temperature, gap, deltaE, numPole, & isInertiaCount, maxPEXSIIter, muMin0, muMax0, mu0, & muInertiaTolerance, muInertiaExpansion, & muPEXSISafeGuard, numElectronPEXSITolerance, & matrixType, isSymbolicFactorize, ordering, & - npSymbFact, verbosity, error) + npSymbFact, verbosity) TYPE(cp_pexsi_options), INTENT(IN) :: pexsi_options REAL(KIND=real_8), INTENT(OUT), OPTIONAL :: temperature, gap, deltaE INTEGER, INTENT(OUT), OPTIONAL :: numPole, isInertiaCount, & @@ -166,7 +163,6 @@ SUBROUTINE cp_pexsi_get_options(pexsi_options, temperature, gap, deltaE, numPole isSymbolicFactorize, & ordering, npSymbFact, & verbosity - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_pexsi_get_options', & routineP = moduleN//':'//routineN @@ -217,18 +213,16 @@ SUBROUTINE cp_pexsi_get_options(pexsi_options, temperature, gap, deltaE, numPole IF(PRESENT(verbosity)) verbosity = -1 CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END SUBROUTINE cp_pexsi_get_options ! ***************************************************************************** !> \brief ... !> \param pexsi_options ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_pexsi_set_default_options(pexsi_options, error) + SUBROUTINE cp_pexsi_set_default_options(pexsi_options) TYPE(cp_pexsi_options), INTENT(OUT) :: pexsi_options - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_pexsi_set_default_options', & routineP = moduleN//':'//routineN @@ -238,7 +232,7 @@ SUBROUTINE cp_pexsi_set_default_options(pexsi_options, error) #else CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END SUBROUTINE cp_pexsi_set_default_options @@ -248,13 +242,11 @@ END SUBROUTINE cp_pexsi_set_default_options !> \param numProcRow ... !> \param numProcCol ... !> \param outputFileIndex ... -!> \param error ... !> \retval cp_pexsi_plan_initialize ... ! ***************************************************************************** - FUNCTION cp_pexsi_plan_initialize(comm, numProcRow, numProcCol, outputFileIndex, error) + FUNCTION cp_pexsi_plan_initialize(comm, numProcRow, numProcCol, outputFileIndex) INTEGER, INTENT(IN) :: comm, numProcRow, numProcCol, & outputFileIndex - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER(KIND=int_8) :: cp_pexsi_plan_initialize CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_pexsi_plan_initialize', & @@ -267,12 +259,12 @@ FUNCTION cp_pexsi_plan_initialize(comm, numProcRow, numProcCol, outputFileIndex, numProcCol, outputFileIndex, info) CALL cp_assert(info .EQ. 0, cp_fatal_level, cp_internal_error, routineP,& "Pexsi returned an error. Consider logPEXSI0 for details.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) CALL timestop(handle) #else CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END FUNCTION cp_pexsi_plan_initialize @@ -289,12 +281,11 @@ END FUNCTION cp_pexsi_plan_initialize !> \param HnzvalLocal ... !> \param isSIdentity ... !> \param SnzvalLocal ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_pexsi_load_real_symmetric_hs_matrix(plan,pexsi_options,nrows,nnz, & nnzLocal,numColLocal,colptrLocal, & rowindLocal,HnzvalLocal,isSIdentity, & - SnzvalLocal,error) + SnzvalLocal) INTEGER(KIND=int_8), INTENT(IN) :: plan TYPE(cp_pexsi_options), INTENT(IN) :: pexsi_options INTEGER, INTENT(IN) :: nrows, nnz, nnzLocal, & @@ -303,7 +294,6 @@ SUBROUTINE cp_pexsi_load_real_symmetric_hs_matrix(plan,pexsi_options,nrows,nnz, REAL(KIND=real_8), INTENT(IN) :: HnzvalLocal(*) INTEGER, INTENT(IN) :: isSIdentity REAL(KIND=real_8), INTENT(IN) :: SnzvalLocal(*) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'cp_pexsi_load_real_symmetric_hs_matrix', & @@ -319,12 +309,12 @@ SUBROUTINE cp_pexsi_load_real_symmetric_hs_matrix(plan,pexsi_options,nrows,nnz, HnzvalLocal,isSIdentity,SnzvalLocal,info) CALL cp_assert(info .EQ. 0, cp_fatal_level, cp_internal_error, routineP, & "Pexsi returned an error. Consider logPEXSI0 for details.", & - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) CALL timestop(handle) #else CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END SUBROUTINE cp_pexsi_load_real_symmetric_hs_matrix @@ -339,11 +329,10 @@ END SUBROUTINE cp_pexsi_load_real_symmetric_hs_matrix !> \param muMaxInertia ... !> \param numTotalInertiaIter ... !> \param numTotalPEXSIIter ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_pexsi_dft_driver(plan,pexsi_options,numElectronExact,muPEXSI, & numElectronPEXSI,muMinInertia,muMaxInertia, & - numTotalInertiaIter,numTotalPEXSIIter,error) + numTotalInertiaIter,numTotalPEXSIIter) INTEGER(KIND=int_8), INTENT(IN) :: plan TYPE(cp_pexsi_options), INTENT(IN) :: pexsi_options REAL(KIND=real_8), INTENT(IN) :: numElectronExact @@ -351,7 +340,6 @@ SUBROUTINE cp_pexsi_dft_driver(plan,pexsi_options,numElectronExact,muPEXSI, & muMinInertia, muMaxInertia INTEGER, INTENT(out) :: numTotalInertiaIter, & numTotalPEXSIIter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_pexsi_dft_driver', & routineP = moduleN//':'//routineN @@ -365,7 +353,7 @@ SUBROUTINE cp_pexsi_dft_driver(plan,pexsi_options,numElectronExact,muPEXSI, & numTotalInertiaIter,numTotalPEXSIIter,info) CALL cp_assert(info .EQ. 0, cp_fatal_level, cp_internal_error, routineP,& "Pexsi returned an error. Consider logPEXSI0 for details.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) CALL timestop(handle) #else ! assign intent-out arguments to silence compiler warnings @@ -377,7 +365,7 @@ SUBROUTINE cp_pexsi_dft_driver(plan,pexsi_options,numElectronExact,muPEXSI, & numTotalPEXSIIter = -1 CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END SUBROUTINE cp_pexsi_dft_driver @@ -390,15 +378,13 @@ END SUBROUTINE cp_pexsi_dft_driver !> \param totalEnergyH ... !> \param totalEnergyS ... !> \param totalFreeEnergy ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cp_pexsi_retrieve_real_symmetric_dft_matrix(plan,DMnzvalLocal,EDMnzvalLocal, & FDMnzvalLocal,totalEnergyH, & - totalEnergyS,totalFreeEnergy,error) + totalEnergyS,totalFreeEnergy) INTEGER(KIND=int_8), INTENT(IN) :: plan REAL(KIND=real_8), INTENT(out) :: DMnzvalLocal(*), EDMnzvalLocal(*), & FDMnzvalLocal(*), totalEnergyH, totalEnergyS, totalFreeEnergy - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'cp_pexsi_retrieve_real_symmetric_dft_matrix', & @@ -414,7 +400,7 @@ SUBROUTINE cp_pexsi_retrieve_real_symmetric_dft_matrix(plan,DMnzvalLocal,EDMnzva totalEnergyS,totalFreeEnergy,info) CALL cp_assert(info .EQ. 0, cp_fatal_level, cp_internal_error, routineP,& "Pexsi returned an error. Consider logPEXSI0 for details.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) CALL timestop(handle) #else ! assign intent-out arguments to silence compiler warnings @@ -427,18 +413,16 @@ SUBROUTINE cp_pexsi_retrieve_real_symmetric_dft_matrix(plan,DMnzvalLocal,EDMnzva CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END SUBROUTINE cp_pexsi_retrieve_real_symmetric_dft_matrix ! ***************************************************************************** !> \brief ... !> \param plan ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp_pexsi_plan_finalize(plan,error) + SUBROUTINE cp_pexsi_plan_finalize(plan) INTEGER(KIND=int_8), INTENT(IN) :: plan - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_pexsi_plan_finalize', & routineP = moduleN//':'//routineN @@ -450,12 +434,12 @@ SUBROUTINE cp_pexsi_plan_finalize(plan,error) CALL f_ppexsi_plan_finalize(plan,info) CALL cp_assert(info .EQ. 0, cp_fatal_level, cp_internal_error, routineP,& "Pexsi returned an error. Consider logPEXSI0 for details.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) CALL timestop(handle) #else CALL cp_assert (.FALSE., cp_fatal_level, cp_internal_error, routineN, & "Requires linking to the PEXSI library.",& - only_ionode = .TRUE., error=error) + only_ionode = .TRUE.) #endif END SUBROUTINE diff --git a/src/pexsi_methods.F b/src/pexsi_methods.F index 054f1c7e77..ec16ce5b16 100644 --- a/src/pexsi_methods.F +++ b/src/pexsi_methods.F @@ -69,16 +69,14 @@ MODULE pexsi_methods !> \brief Read CP2K input section PEXSI and pass it to the PEXSI environment !> \param pexsi_section ... !> \param pexsi_env ... -!> \param error ... !> \par History !> 11.2014 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** - SUBROUTINE pexsi_init_read_input(pexsi_section, pexsi_env, error) + SUBROUTINE pexsi_init_read_input(pexsi_section, pexsi_env) TYPE(section_vals_type), INTENT(IN), & POINTER :: pexsi_section TYPE(lib_pexsi_env), INTENT(INOUT) :: pexsi_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pexsi_init_read_input', & routineP = moduleN//':'//routineN @@ -96,51 +94,51 @@ SUBROUTINE pexsi_init_read_input(pexsi_section, pexsi_env, error) ! of fixed sparsity pattern) CALL section_vals_val_get(pexsi_section,"TEMPERATURE",& - r_val=temperature,error=error) + r_val=temperature) CALL section_vals_val_get(pexsi_section,"GAP",& - r_val=gap,error=error) + r_val=gap) CALL section_vals_val_get(pexsi_section,"NUM_POLE",& - i_val=numPole,error=error) + i_val=numPole) CALL section_vals_val_get(pexsi_section,"IS_INERTIA_COUNT",& - l_val=isInertiaCount,error=error) + l_val=isInertiaCount) CALL section_vals_val_get(pexsi_section,"MAX_PEXSI_ITER",& - i_val=maxPEXSIIter,error=error) + i_val=maxPEXSIIter) CALL section_vals_val_get(pexsi_section,"MU_MIN_0",& - r_val=muMin0,error=error) + r_val=muMin0) CALL section_vals_val_get(pexsi_section,"MU_MAX_0",& - r_val=muMax0,error=error) + r_val=muMax0) CALL section_vals_val_get(pexsi_section,"MU_INERTIA_TOLERANCE",& - r_val=muInertiaTolerance,error=error) + r_val=muInertiaTolerance) CALL section_vals_val_get(pexsi_section,"MU_INERTIA_EXPANSION",& - r_val=muInertiaExpansion,error=error) + r_val=muInertiaExpansion) CALL section_vals_val_get(pexsi_section,"MU_PEXSI_SAFE_GUARD",& - r_val=muPEXSISafeGuard,error=error) + r_val=muPEXSISafeGuard) CALL section_vals_val_get(pexsi_section,"NUM_ELECTRON_INITIAL_TOLERANCE",& - r_val=numElectronInitialTolerance,error=error) + r_val=numElectronInitialTolerance) CALL section_vals_val_get(pexsi_section,"NUM_ELECTRON_PEXSI_TOLERANCE",& - r_val=numElectronTargetTolerance,error=error) + r_val=numElectronTargetTolerance) CALL section_vals_val_get(pexsi_section,"ORDERING",& - i_val=ordering,error=error) + i_val=ordering) CALL section_vals_val_get(pexsi_section,"NP_SYMB_FACT",& - i_val=npSymbFact,error=error) + i_val=npSymbFact) CALL section_vals_val_get(pexsi_section,"VERBOSITY",& - i_val=verbosity,error=error) + i_val=verbosity) CALL section_vals_val_get(pexsi_section,"MIN_RANKS_PER_POLE",& - i_val=min_ranks_per_pole,error=error) + i_val=min_ranks_per_pole) CALL section_vals_val_get(pexsi_section,"CSR_SCREENING",& - l_val=csr_screening,error=error) + l_val=csr_screening) isInertiaCount_int = MERGE(1,0,isInertiaCount) ! is integer in PEXSI ! Set default options inside PEXSI - CALL cp_pexsi_set_default_options(pexsi_env%options,error) + CALL cp_pexsi_set_default_options(pexsi_env%options) ! Pass CP2K input to PEXSI options CALL cp_pexsi_set_options(pexsi_env%options, temperature = temperature, gap = gap,& numPole = numPole, isInertiaCount = isInertiaCount_int, maxPEXSIIter = maxPEXSIIter, & muMin0 = muMin0, muMax0 = muMax0, muInertiaTolerance = muInertiaTolerance,& muInertiaExpansion = muInertiaExpansion, muPEXSISafeGuard = muPEXSISafeGuard,& - ordering = ordering, npSymbFact = npSymbFact, verbosity = verbosity, error = error) + ordering = ordering, npSymbFact = npSymbFact, verbosity = verbosity) pexsi_env%num_ranks_per_pole = min_ranks_per_pole ! not a PEXSI option pexsi_env%csr_screening = csr_screening @@ -159,13 +157,11 @@ END SUBROUTINE pexsi_init_read_input !> \param pexsi_env ... !> \param template_matrix DBCSR matrix that defines the block structure and !> sparsity pattern of all matrices that are sent to PEXSI -!> \param error ... ! ***************************************************************************** - SUBROUTINE pexsi_init_scf(ks_env, pexsi_env, template_matrix, error) + SUBROUTINE pexsi_init_scf(ks_env, pexsi_env, template_matrix) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(lib_pexsi_env), INTENT(INOUT) :: pexsi_env TYPE(cp_dbcsr_type), INTENT(IN) :: template_matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pexsi_init_scf', & routineP = moduleN//':'//routineN @@ -175,7 +171,7 @@ SUBROUTINE pexsi_init_scf(ks_env, pexsi_env, template_matrix, error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -183,54 +179,53 @@ SUBROUTINE pexsi_init_scf(ks_env, pexsi_env, template_matrix, error) ENDIF ! Create template matrices fixing sparsity pattern for PEXSI - CALL cp_dbcsr_init(pexsi_env%dbcsr_template_matrix_sym, error) - CALL cp_dbcsr_init(pexsi_env%dbcsr_template_matrix_nonsym, error) - CALL cp_dbcsr_init(pexsi_env%csr_sparsity, error) + CALL cp_dbcsr_init(pexsi_env%dbcsr_template_matrix_sym) + CALL cp_dbcsr_init(pexsi_env%dbcsr_template_matrix_nonsym) + CALL cp_dbcsr_init(pexsi_env%csr_sparsity) IF (cp_dbcsr_has_symmetry (template_matrix)) THEN CALL cp_dbcsr_copy(pexsi_env%dbcsr_template_matrix_sym, template_matrix,& - "symmetric template matrix for CSR conversion", error=error) + "symmetric template matrix for CSR conversion") CALL cp_dbcsr_desymmetrize(pexsi_env%dbcsr_template_matrix_sym, & - pexsi_env%dbcsr_template_matrix_nonsym, error) + pexsi_env%dbcsr_template_matrix_nonsym) ELSE CALL cp_dbcsr_copy(pexsi_env%dbcsr_template_matrix_nonsym, template_matrix,& - "non-symmetric template matrix for CSR conversion", error=error) + "non-symmetric template matrix for CSR conversion") CALL cp_dbcsr_copy(pexsi_env%dbcsr_template_matrix_sym, template_matrix,& - "symmetric template matrix for CSR conversion", error=error) + "symmetric template matrix for CSR conversion") ENDIF CALL cp_dbcsr_create(pexsi_env%csr_sparsity, "CSR sparsity", & template = pexsi_env%dbcsr_template_matrix_sym, & - data_type=dbcsr_type_real_4, error=error) - CALL cp_dbcsr_copy(pexsi_env%csr_sparsity, pexsi_env%dbcsr_template_matrix_sym, error=error) + data_type=dbcsr_type_real_4) + CALL cp_dbcsr_copy(pexsi_env%csr_sparsity, pexsi_env%dbcsr_template_matrix_sym) - CALL cp_dbcsr_to_csr_screening(ks_env, pexsi_env%csr_sparsity, error) + CALL cp_dbcsr_to_csr_screening(ks_env, pexsi_env%csr_sparsity) - IF (.NOT. pexsi_env%csr_screening) CALL cp_dbcsr_set (pexsi_env%csr_sparsity, 1.0, error) + IF (.NOT. pexsi_env%csr_screening) CALL cp_dbcsr_set (pexsi_env%csr_sparsity, 1.0) CALL cp_csr_create_from_dbcsr(pexsi_env%dbcsr_template_matrix_nonsym, & pexsi_env%csr_mat_s, & csr_eqrow_floor_dist, & csr_sparsity = pexsi_env%csr_sparsity, & - numnodes = pexsi_env%num_ranks_per_pole, & - error = error) + numnodes = pexsi_env%num_ranks_per_pole) IF (unit_nr>0) WRITE(unit_nr,"(/T2,A)") "SPARSITY OF THE OVERLAP MATRIX IN CSR FORMAT" - CALL cp_csr_print_sparsity(pexsi_env%csr_mat_s, unit_nr, error) + CALL cp_csr_print_sparsity(pexsi_env%csr_mat_s, unit_nr) - CALL cp_convert_dbcsr_to_csr(pexsi_env%dbcsr_template_matrix_nonsym, pexsi_env%csr_mat_s, error=error) + CALL cp_convert_dbcsr_to_csr(pexsi_env%dbcsr_template_matrix_nonsym, pexsi_env%csr_mat_s) - CALL cp_csr_create(pexsi_env%csr_mat_ks, pexsi_env%csr_mat_s, error = error) - CALL cp_csr_create(pexsi_env%csr_mat_p, pexsi_env%csr_mat_s, error = error) - CALL cp_csr_create(pexsi_env%csr_mat_E, pexsi_env%csr_mat_s, error = error) - CALL cp_csr_create(pexsi_env%csr_mat_F, pexsi_env%csr_mat_s, error = error) + CALL cp_csr_create(pexsi_env%csr_mat_ks, pexsi_env%csr_mat_s) + CALL cp_csr_create(pexsi_env%csr_mat_p, pexsi_env%csr_mat_s) + CALL cp_csr_create(pexsi_env%csr_mat_E, pexsi_env%csr_mat_s) + CALL cp_csr_create(pexsi_env%csr_mat_F, pexsi_env%csr_mat_s) DO ispin=1, pexsi_env%nspin - CALL cp_dbcsr_init(pexsi_env%matrix_w(ispin)%matrix, error) + CALL cp_dbcsr_init(pexsi_env%matrix_w(ispin)%matrix) CALL cp_dbcsr_create(pexsi_env%matrix_w(ispin)%matrix, "W matrix",& - template = template_matrix, matrix_type=dbcsr_type_no_symmetry, error = error) + template = template_matrix, matrix_type=dbcsr_type_no_symmetry) ENDDO - CALL cp_pexsi_set_options(pexsi_env%options, numElectronPEXSITolerance = pexsi_env%tol_nel_initial, error=error) + CALL cp_pexsi_set_options(pexsi_env%options, numElectronPEXSITolerance = pexsi_env%tol_nel_initial) CALL timestop(handle) @@ -240,12 +235,10 @@ END SUBROUTINE pexsi_init_scf !> \brief Deallocations and post-processing after SCF !> \param pexsi_env ... !> \param mu_spin ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pexsi_finalize_scf(pexsi_env,mu_spin,error) + SUBROUTINE pexsi_finalize_scf(pexsi_env,mu_spin) TYPE(lib_pexsi_env), INTENT(INOUT) :: pexsi_env REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: mu_spin - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pexsi_finalize_scf', & routineP = moduleN//':'//routineN @@ -256,7 +249,7 @@ SUBROUTINE pexsi_finalize_scf(pexsi_env,mu_spin,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -274,17 +267,17 @@ SUBROUTINE pexsi_finalize_scf(pexsi_env,mu_spin,error) " PEXSI| Chemical potential (a.u.):", mu_total ENDIF - CALL cp_dbcsr_release(pexsi_env%dbcsr_template_matrix_sym, error) - CALL cp_dbcsr_release(pexsi_env%dbcsr_template_matrix_nonsym, error) - CALL cp_dbcsr_release(pexsi_env%csr_sparsity,error) - CALL cp_csr_destroy(pexsi_env%csr_mat_p, error) - CALL cp_csr_destroy(pexsi_env%csr_mat_ks, error) - CALL cp_csr_destroy(pexsi_env%csr_mat_s, error) - CALL cp_csr_destroy(pexsi_env%csr_mat_E, error) - CALL cp_csr_destroy(pexsi_env%csr_mat_F, error) + CALL cp_dbcsr_release(pexsi_env%dbcsr_template_matrix_sym) + CALL cp_dbcsr_release(pexsi_env%dbcsr_template_matrix_nonsym) + CALL cp_dbcsr_release(pexsi_env%csr_sparsity) + CALL cp_csr_destroy(pexsi_env%csr_mat_p) + CALL cp_csr_destroy(pexsi_env%csr_mat_ks) + CALL cp_csr_destroy(pexsi_env%csr_mat_s) + CALL cp_csr_destroy(pexsi_env%csr_mat_E) + CALL cp_csr_destroy(pexsi_env%csr_mat_F) DO ispin = 1, pexsi_env%nspin - CALL cp_dbcsr_release(pexsi_env%max_ev_vector(ispin), error) - CALL cp_dbcsr_release(pexsi_env%matrix_w(ispin)%matrix, error) + CALL cp_dbcsr_release(pexsi_env%max_ev_vector(ispin)) + CALL cp_dbcsr_release(pexsi_env%matrix_w(ispin)%matrix) ENDDO CALL timestop(handle) pexsi_env%tol_nel_initial = pexsi_env%tol_nel_target ! Turn off adaptive threshold for subsequent SCF cycles @@ -303,13 +296,12 @@ END SUBROUTINE pexsi_finalize_scf !> \param[out] mu chemical potential calculated by PEXSI !> \param[in] iscf SCF step !> \param[in] ispin Number of spin -!> \param error ... !> \par History !> 11.2014 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, matrix_s,& - nelectron_exact, mu, iscf, ispin, error) + nelectron_exact, mu, iscf, ispin) TYPE(lib_pexsi_env), INTENT(INOUT) :: pexsi_env TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p TYPE(cp_dbcsr_p_type), INTENT(INOUT) :: matrix_w @@ -318,7 +310,6 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m INTEGER, INTENT(IN) :: nelectron_exact REAL(KIND=dp), INTENT(OUT) :: mu INTEGER, INTENT(IN) :: iscf, ispin - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_matrix_pexsi', & routineP = moduleN//':'//routineN @@ -339,7 +330,7 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m CALL timeset(routineN,handle) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -355,25 +346,25 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m CALL cp_assert(cp_dbcsr_has_symmetry (matrix_ks),& cp_fatal_level, cp_internal_error, routineP,& "PEXSI interface expects a non-symmetric DBCSR Kohn-Sham matrix",& - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) CALL cp_assert(cp_dbcsr_has_symmetry (matrix_s),& cp_fatal_level, cp_internal_error, routineP,& "PEXSI interface expects a non-symmetric DBCSR overlap matrix",& - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) ! Assertion on datatype CALL cp_assert((pexsi_env%csr_mat_s%nzval_local%data_type .EQ. dbcsr_type_real_8) & .AND. (pexsi_env%csr_mat_ks%nzval_local%data_type .EQ. dbcsr_type_real_8), & cp_fatal_level,cp_wrong_args_error, routineP,& "Complex data type not supported by PEXSI",& - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) ! Assertion on number of non-zero elements !(TODO: update when PEXSI changes to Long Int) CALL cp_assert(pexsi_env%csr_mat_s%nze_total .LT. INT(2,kind=int_8)**31,& cp_fatal_level, cp_internal_error, routineP,& "Total number of non-zero elements of CSR matrix is too large to be handled by PEXSI",& - only_ionode=.TRUE., error=error) + only_ionode=.TRUE.) ENDIF mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(cp_dbcsr_distribution(matrix_ks))) @@ -381,18 +372,18 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m ! Convert DBCSR matrices to PEXSI CSR format. Intermediate step to template matrix ! needed in order to retain the initial sparsity pattern that is required for the ! conversion to CSR format. - CALL cp_dbcsr_copy_into_existing(pexsi_env%dbcsr_template_matrix_sym, matrix_s, error) + CALL cp_dbcsr_copy_into_existing(pexsi_env%dbcsr_template_matrix_sym, matrix_s) CALL cp_convert_dbcsr_to_csr(pexsi_env%dbcsr_template_matrix_sym, & - pexsi_env%csr_mat_s,error=error) + pexsi_env%csr_mat_s) CALL cp_dbcsr_copy_into_existing(pexsi_env%dbcsr_template_matrix_sym, & - matrix_ks, error) + matrix_ks) CALL cp_convert_dbcsr_to_csr(pexsi_env%dbcsr_template_matrix_sym, & - pexsi_env%csr_mat_ks,error=error) + pexsi_env%csr_mat_ks) ! Get PEXSI input delta_E (upper bound for largest eigenvalue) using Arnoldi NULLIFY(arnoldi_matrices) - CALL cp_dbcsr_allocate_matrix_set(arnoldi_matrices, 2, error) + CALL cp_dbcsr_allocate_matrix_set(arnoldi_matrices, 2) arnoldi_matrices(1)%matrix => matrix_ks arnoldi_matrices(2)%matrix => matrix_s CALL cp_dbcsr_setup_arnoldi_data(my_arnoldi,arnoldi_matrices,max_iter=20,& @@ -400,32 +391,32 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m generalized_ev=.TRUE.,iram=.FALSE.) IF(iscf .GT. 1) CALL cp_set_arnoldi_initial_vector(my_arnoldi, & pexsi_env%max_ev_vector(ispin)) - CALL cp_dbcsr_arnoldi_ev(arnoldi_matrices,my_arnoldi,error) + CALL cp_dbcsr_arnoldi_ev(arnoldi_matrices,my_arnoldi) delta_E = REAL(get_selected_ritz_val(my_arnoldi,1),dp) ! increase delta_E a bit to make sure that it really is an upper bound delta_E = delta_E + 1.0E-2_dp*ABS(delta_E) CALL get_selected_ritz_vec(my_arnoldi,1,arnoldi_matrices(1)%matrix, & - pexsi_env%max_ev_vector(ispin),error) + pexsi_env%max_ev_vector(ispin)) CALL deallocate_arnoldi_data(my_arnoldi) DEALLOCATE(arnoldi_matrices) nelectron_exact_pexsi = nelectron_exact - CALL cp_pexsi_set_options(pexsi_env%options, deltaE=delta_E, error=error) + CALL cp_pexsi_set_options(pexsi_env%options, deltaE=delta_E) ! Set PEXSI options appropriately for first SCF iteration IF (iscf .EQ. 1) THEN ! Get option isInertiaCount to reset it later on and set it to 1 for first SCF iteration - CALL cp_pexsi_get_options(pexsi_env%options, isInertiaCount = isInertiaCount, error = error) + CALL cp_pexsi_get_options(pexsi_env%options, isInertiaCount = isInertiaCount) CALL cp_pexsi_set_options(pexsi_env%options, isInertiaCount = 1, & - isSymbolicFactorize = 1, error=error) + isSymbolicFactorize = 1) ENDIF ! Write PEXSI options to output CALL cp_pexsi_get_options(pexsi_env%options, isInertiaCount = isInertiaCount_out, & isSymbolicFactorize = is_symbolic_factorize, & muMin0 = mu_min_in, muMax0 = mu_max_in, & - NumElectronPEXSITolerance=nel_tol, error = error) + NumElectronPEXSITolerance=nel_tol) ! IF(unit_nr>0) WRITE(unit_nr,'(/A,I4,A,I4)') " PEXSI| SCF", iscf, & @@ -457,18 +448,16 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m pexsi_env%csr_mat_ks%colind_local,& pexsi_env%csr_mat_ks%nzval_local%r_dp,& S_not_identity,& - pexsi_env%csr_mat_s%nzval_local%r_dp,& - error) + pexsi_env%csr_mat_s%nzval_local%r_dp) ! convert to spin restricted before passing number of electrons to PEXSI CALL convert_nspin_cp2k_pexsi(cp2k_to_pexsi, & - numElectron=nelectron_exact_pexsi, error=error) + numElectron=nelectron_exact_pexsi) ! Call DFT driver of PEXSI doing the actual calculation CALL cp_pexsi_dft_driver(pexsi_env%plan, pexsi_env%options,& nelectron_exact_pexsi,mu,nelectron_out,mu_min_out,mu_max_out,& - n_total_inertia_iter,n_total_pexsi_iter,& - error) + n_total_inertia_iter,n_total_pexsi_iter) ! Check convergence nelectron_diff = nelectron_out - nelectron_exact_pexsi @@ -502,8 +491,7 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m pexsi_env%csr_mat_p%nzval_local%r_dp,& pexsi_env%csr_mat_E%nzval_local%r_dp,& pexsi_env%csr_mat_F%nzval_local%r_dp,& - energy_H,energy_S,free_energy,& - error) + energy_H,energy_S,free_energy) ! calculate entropic energy contribution -TS = A - U kTS = (free_energy - energy_H) ENDIF @@ -513,30 +501,29 @@ SUBROUTINE density_matrix_pexsi(pexsi_env, matrix_p, matrix_w, kTS, matrix_ks, m ! Convert PEXSI CSR matrices to DBCSR matrices CALL cp_convert_csr_to_dbcsr(pexsi_env%dbcsr_template_matrix_nonsym, & - pexsi_env%csr_mat_p, error) - CALL cp_dbcsr_copy(matrix_p, pexsi_env%dbcsr_template_matrix_nonsym, error=error) + pexsi_env%csr_mat_p) + CALL cp_dbcsr_copy(matrix_p, pexsi_env%dbcsr_template_matrix_nonsym) CALL cp_convert_csr_to_dbcsr(pexsi_env%dbcsr_template_matrix_nonsym, & - pexsi_env%csr_mat_E, error) - CALL cp_dbcsr_copy(matrix_w%matrix, pexsi_env%dbcsr_template_matrix_nonsym, error=error) + pexsi_env%csr_mat_E) + CALL cp_dbcsr_copy(matrix_w%matrix, pexsi_env%dbcsr_template_matrix_nonsym) ! Convert to spin unrestricted CALL convert_nspin_cp2k_pexsi(pexsi_to_cp2k, matrix_p = matrix_p, & - matrix_w = matrix_w, kTS = kTS, error = error) + matrix_w = matrix_w, kTS = kTS) ! Pass resulting mu as initial guess for next SCF to PEXSI CALL cp_pexsi_set_options(pexsi_env%options, mu0=mu,muMin0=mu_min_out, & - muMax0=mu_max_out, error= error) + muMax0=mu_max_out) ! Reset isInertiaCount according to user input IF (iscf .EQ. 1) THEN CALL cp_pexsi_set_options(pexsi_env%options, isInertiaCount = & - isInertiaCount, error= error) + isInertiaCount) ENDIF ! Turn off symbolic factorization for subsequent calls IF (first_call) THEN - CALL cp_pexsi_set_options(pexsi_env%options, isSymbolicFactorize = 0, & - error= error) + CALL cp_pexsi_set_options(pexsi_env%options, isSymbolicFactorize = 0) ENDIF CALL timestop(handle) @@ -559,15 +546,13 @@ END SUBROUTINE density_matrix_pexsi !> with delta_scf as initial convergence error !> \param check_convergence is set to .FALSE. if convergence in number of electrons !> will not be achieved in next SCF step -!> \param error ... ! ***************************************************************************** SUBROUTINE pexsi_set_convergence_tolerance(pexsi_env, delta_scf, eps_scf, initialize, & - check_convergence, error) + check_convergence) TYPE(lib_pexsi_env), INTENT(INOUT) :: pexsi_env REAL(KIND=dp), INTENT(IN) :: delta_scf, eps_scf LOGICAL, INTENT(IN) :: initialize LOGICAL, INTENT(OUT) :: check_convergence - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'pexsi_set_convergence_tolerance', & @@ -595,7 +580,7 @@ SUBROUTINE pexsi_set_convergence_tolerance(pexsi_env, delta_scf, eps_scf, initia check_convergence = (tol_nel.LE.pexsi_env%tol_nel_target) - CALL cp_pexsi_set_options(pexsi_env%options, numElectronPEXSITolerance = tol_nel, error=error) + CALL cp_pexsi_set_options(pexsi_env%options, numElectronPEXSITolerance = tol_nel) CALL timestop(handle) END SUBROUTINE @@ -606,12 +591,11 @@ SUBROUTINE pexsi_set_convergence_tolerance(pexsi_env, delta_scf, eps_scf, initia !> \param qs_env ... !> \param kTS ... !> \param matrix_w ... -!> \param error ... !> \par History !> 12.2014 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** - SUBROUTINE pexsi_to_qs(ls_scf_env, qs_env, kTS, matrix_w, error) + SUBROUTINE pexsi_to_qs(ls_scf_env, qs_env, kTS, matrix_w) TYPE(ls_scf_env_type) :: ls_scf_env TYPE(qs_environment_type), & INTENT(INOUT), POINTER :: qs_env @@ -619,7 +603,6 @@ SUBROUTINE pexsi_to_qs(ls_scf_env, qs_env, kTS, matrix_w, error) INTENT(IN), OPTIONAL :: kTS TYPE(cp_dbcsr_p_type), DIMENSION(:), & INTENT(IN), OPTIONAL :: matrix_w - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pexsi_to_qs', & routineP = moduleN//':'//routineN @@ -636,21 +619,21 @@ SUBROUTINE pexsi_to_qs(ls_scf_env, qs_env, kTS, matrix_w, error) NULLIFY(energy) ! get a useful output_unit - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE unit_nr=-1 ENDIF - CALL get_qs_env(qs_env, energy = energy, matrix_w = matrix_w_qs, error=error) + CALL get_qs_env(qs_env, energy = energy, matrix_w = matrix_w_qs) IF (PRESENT(matrix_w)) THEN DO ispin=1, ls_scf_env%nspins CALL matrix_ls_to_qs(matrix_w_qs(ispin)%matrix, matrix_w(ispin)%matrix,& - ls_scf_env%ls_mstruct, error=error) + ls_scf_env%ls_mstruct) IF (ls_scf_env%nspins.EQ.1) CALL cp_dbcsr_scale(matrix_w_qs(ispin)%matrix, & - 2.0_dp,error=error) + 2.0_dp) ENDDO ENDIF diff --git a/src/pexsi_types.F b/src/pexsi_types.F index 3a6a638f7f..610c4e6cb5 100644 --- a/src/pexsi_types.F +++ b/src/pexsi_types.F @@ -112,15 +112,13 @@ MODULE pexsi_types !> \param pexsi_env All data needed by PEXSI !> \param mp_group message-passing group ID !> \param nspin number of spins -!> \param error ... !> \par History !> 11.2014 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** - SUBROUTINE lib_pexsi_init(pexsi_env, mp_group, nspin, error) + SUBROUTINE lib_pexsi_init(pexsi_env, mp_group, nspin) TYPE(lib_pexsi_env), INTENT(INOUT) :: pexsi_env INTEGER, INTENT(IN) :: mp_group, nspin - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lib_pexsi_init', & routineP = moduleN//':'//routineN @@ -129,7 +127,7 @@ SUBROUTINE lib_pexsi_init(pexsi_env, mp_group, nspin, error) npSymbFact, numnodes, unit_nr TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -158,11 +156,10 @@ SUBROUTINE lib_pexsi_init(pexsi_env, mp_group, nspin, error) pexsi_env%num_ranks_per_pole = pexsi_env%num_ranks_per_pole + 1 ENDDO - CALL cp_pexsi_get_options(pexsi_env%options,npSymbFact=npSymbFact,error=error) + CALL cp_pexsi_get_options(pexsi_env%options,npSymbFact=npSymbFact) IF ((npSymbFact .GT. pexsi_env%num_ranks_per_pole) .OR. (npSymbFact .EQ. 0)) THEN ! Use maximum possible number of ranks for symbolic factorization - CALL cp_pexsi_set_options(pexsi_env%options, npSymbFact=pexsi_env%num_ranks_per_pole, & - error=error) + CALL cp_pexsi_set_options(pexsi_env%options, npSymbFact=pexsi_env%num_ranks_per_pole) ENDIF ! Create dimensions for MPI cartesian grid for PEXSI @@ -180,12 +177,12 @@ SUBROUTINE lib_pexsi_init(pexsi_env, mp_group, nspin, error) ! Initialize PEXSI pexsi_env%plan = cp_pexsi_plan_initialize(pexsi_env%mp_group,pexsi_env%mp_dims(1),& - pexsi_env%mp_dims(2),mynode,error) + pexsi_env%mp_dims(2),mynode) pexsi_env%do_adaptive_tol_nel = .FALSE. ! Print PEXSI infos - IF(unit_nr>0) CALL print_pexsi_info(pexsi_env, unit_nr, error) + IF(unit_nr>0) CALL print_pexsi_info(pexsi_env, unit_nr) CALL timestop(handle) END SUBROUTINE lib_pexsi_init @@ -193,14 +190,12 @@ END SUBROUTINE lib_pexsi_init ! ***************************************************************************** !> \brief Release all PEXSI data !> \param pexsi_env ... -!> \param error ... !> \par History !> 11.2014 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** - SUBROUTINE lib_pexsi_finalize(pexsi_env, error) + SUBROUTINE lib_pexsi_finalize(pexsi_env) TYPE(lib_pexsi_env), INTENT(INOUT) :: pexsi_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lib_pexsi_finalize', & routineP = moduleN//':'//routineN @@ -208,7 +203,7 @@ SUBROUTINE lib_pexsi_finalize(pexsi_env, error) INTEGER :: handle, ispin CALL timeset(routineN,handle) - CALL cp_pexsi_plan_finalize(pexsi_env%plan, error) + CALL cp_pexsi_plan_finalize(pexsi_env%plan) DEALLOCATE(pexsi_env%kTS) DEALLOCATE(pexsi_env%max_ev_vector) DO ispin = 1, pexsi_env%nspin @@ -227,12 +222,11 @@ END SUBROUTINE lib_pexsi_finalize !> \param matrix_p ... !> \param matrix_w ... !> \param kTS ... -!> \param error ... !> \par History !> 01.2015 created [Patrick Seewald] !> \author Patrick Seewald ! ***************************************************************************** - SUBROUTINE convert_nspin_cp2k_pexsi(direction, numElectron, matrix_p, matrix_w, kTS, error) + SUBROUTINE convert_nspin_cp2k_pexsi(direction, numElectron, matrix_p, matrix_w, kTS) INTEGER, INTENT(IN) :: direction REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: numElectron TYPE(cp_dbcsr_type), INTENT(INOUT), & @@ -240,7 +234,6 @@ SUBROUTINE convert_nspin_cp2k_pexsi(direction, numElectron, matrix_p, matrix_w, TYPE(cp_dbcsr_p_type), INTENT(INOUT), & OPTIONAL :: matrix_w REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: kTS - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'convert_nspin_cp2k_pexsi', & routineP = moduleN//':'//routineN @@ -258,8 +251,8 @@ SUBROUTINE convert_nspin_cp2k_pexsi(direction, numElectron, matrix_p, matrix_w, END SELECT IF (PRESENT(numElectron)) numElectron = scaling*numElectron - IF (PRESENT(matrix_p)) CALL cp_dbcsr_scale(matrix_p, scaling, error=error) - IF (PRESENT(matrix_w)) CALL cp_dbcsr_scale(matrix_w%matrix, scaling, error=error) + IF (PRESENT(matrix_p)) CALL cp_dbcsr_scale(matrix_p, scaling) + IF (PRESENT(matrix_w)) CALL cp_dbcsr_scale(matrix_w%matrix, scaling) IF (PRESENT(kTS)) kTS = scaling*kTS CALL timestop(handle) @@ -269,12 +262,10 @@ END SUBROUTINE convert_nspin_cp2k_pexsi !> \brief Print relevant options of PEXSI !> \param pexsi_env ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE print_pexsi_info(pexsi_env,unit_nr, error) + SUBROUTINE print_pexsi_info(pexsi_env,unit_nr) TYPE(lib_pexsi_env), INTENT(IN) :: pexsi_env INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: mynode, npSymbFact, numnodes, & numPole, ordering @@ -286,8 +277,7 @@ SUBROUTINE print_pexsi_info(pexsi_env,unit_nr, error) CALL cp_pexsi_get_options(pexsi_env%options, temperature=temperature, gap=gap, & numPole=numPole, muMin0=muMin0, muMax0=muMax0, muInertiaTolerance=& muInertiaTolerance, muInertiaExpansion=muInertiaExpansion, & - muPEXSISafeGuard=muPEXSISafeGuard, ordering=ordering, npSymbFact=npSymbFact, & - error = error) + muPEXSISafeGuard=muPEXSISafeGuard, ordering=ordering, npSymbFact=npSymbFact) WRITE(unit_nr,'(/A)') " PEXSI| Initialized with parameters" WRITE(unit_nr,'(A,T61,E20.3)') " PEXSI| Electronic temperature", temperature diff --git a/src/pme.F b/src/pme.F index 784d7bbef0..cba7da83cd 100644 --- a/src/pme.F +++ b/src/pme.F @@ -87,7 +87,6 @@ MODULE pme !> \param use_virial ... !> \param charges ... !> \param atprop ... -!> \param error ... !> \par History !> JGH (15-Mar-2001) : New electrostatic calculation and pressure tensor !> JGH (21-Mar-2001) : Complete rewrite @@ -97,7 +96,7 @@ MODULE pme ! ***************************************************************************** SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & fg_coulomb, pv_g, shell_particle_set, core_particle_set,& - fgshell_coulomb, fgcore_coulomb, use_virial, charges, atprop, error ) + fgshell_coulomb, fgcore_coulomb, use_virial, charges, atprop) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw TYPE(cell_type), POINTER :: box @@ -116,7 +115,6 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges TYPE(atprop_type), POINTER :: atprop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pme_evaluate', & routineP = moduleN//':'//routineN @@ -146,7 +144,7 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & NULLIFY( poisson_env, rden, drpot) failure = .FALSE. CALL cite_reference(Darden1993) - CALL ewald_env_get (ewald_env, alpha=alpha, group = group ,error=error) + CALL ewald_env_get (ewald_env, alpha=alpha, group = group) CALL ewald_pw_get (ewald_pw, pw_big_pool=pw_big_pool, & pw_small_pool=pw_small_pool, rs_desc=rs_desc,& poisson_env=poisson_env, dg = dg ) @@ -161,8 +159,8 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & CALL structure_factor_init(exp_igr) IF(PRESENT(shell_particle_set)) THEN - CPPostcondition(ASSOCIATED(shell_particle_set),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(core_particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(shell_particle_set),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(core_particle_set),cp_failure_level,routineP,failure) nshell=SIZE(shell_particle_set) CALL structure_factor_allocate ( grid_s%bounds, npart, exp_igr, & allocate_centre = .TRUE., allocate_shell_e=.TRUE., allocate_shell_centre = .TRUE., nshell=nshell ) @@ -173,12 +171,12 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & END IF CALL pw_pool_create_pw ( pw_small_pool, rhos1%pw, & - use_data = REALDATA3D ,error=error) + use_data = REALDATA3D) CALL pw_pool_create_pw ( pw_small_pool, rhos2%pw, & - use_data = REALDATA3D ,error=error) + use_data = REALDATA3D) - CALL rs_grid_create(rden, rs_desc, error=error) - CALL rs_grid_set_box ( grid_b, rs=rden, error=error ) + CALL rs_grid_create(rden, rs_desc) + CALL rs_grid_set_box ( grid_b, rs=rden) CALL rs_grid_zero ( rden ) IF ( rden%desc%parallel .AND. rden%desc%distributed ) THEN @@ -209,7 +207,7 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & IF(is1_core .OR. is2_core) THEN CALL get_patch ( dg, particle_set, exp_igr, box, p1, p2, grid_b, grid_s, & rhos1, rhos2 , is1_core=is1_core, is2_core=is2_core, & - core_particle_set=core_particle_set, charges=charges, error=error ) + core_particle_set=core_particle_set, charges=charges) ! add boxes to real space grid (big box) IF(is1_core) THEN @@ -224,7 +222,7 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & END IF ELSE CALL get_patch ( dg, particle_set, exp_igr, box, p1, p2, grid_b, grid_s, & - rhos1, rhos2 , charges=charges, error=error ) + rhos1, rhos2 , charges=charges) ! add boxes to real space grid (big box) CALL dg_sum_patch ( rden, rhos1, exp_igr%centre ( :, p1 ) ) IF ( p2 /= 0 ) CALL dg_sum_patch ( rden, rhos2, exp_igr%centre ( :, p2 ) ) @@ -239,15 +237,15 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & IF ( p1 == 0 .AND. p2 == 0 ) EXIT ! calculate function on small boxes (we use double packing in FFT) CALL get_patch ( dg, shell_particle_set, exp_igr, box, p1, p2, grid_b, grid_s, & - rhos1, rhos2, is1_shell=.TRUE., is2_shell=.TRUE. , charges=charges, error=error) + rhos1, rhos2, is1_shell=.TRUE., is2_shell=.TRUE. , charges=charges) ! add boxes to real space grid (big box) CALL dg_sum_patch ( rpot, rhos1, exp_igr%shell_centre ( :, p1 ) ) IF ( p2 /= 0 ) CALL dg_sum_patch ( rpot, rhos2, exp_igr%shell_centre ( :, p2 ) ) END DO END IF - CALL pw_pool_create_pw ( pw_big_pool, rhob_r, use_data = REALDATA3D, in_space = REALSPACE ,error=error) - CALL rs_pw_transfer ( rden, rhob_r, rs2pw, error=error) + CALL pw_pool_create_pw ( pw_big_pool, rhob_r, use_data = REALDATA3D, in_space = REALSPACE) + CALL rs_pw_transfer ( rden, rhob_r, rs2pw) !-------------- ELECTROSTATIC CALCULATION ----------- @@ -256,19 +254,19 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & NULLIFY(dphi_g ( i )%pw) CALL pw_pool_create_pw ( pw_big_pool, dphi_g ( i )%pw, & use_data = COMPLEXDATA1D, & - in_space = RECIPROCALSPACE ,error=error) + in_space = RECIPROCALSPACE) END DO CALL pw_pool_create_pw ( pw_big_pool, phi_r, & use_data = REALDATA3D, & - in_space = REALSPACE ,error=error) + in_space = REALSPACE) - CALL pw_poisson_solve ( poisson_env, rhob_r, vg_coulomb, phi_r, dphi_g, h_stress ,error=error) + CALL pw_poisson_solve ( poisson_env, rhob_r, vg_coulomb, phi_r, dphi_g, h_stress) ! atomic energies IF (atprop%energy .OR. atprop%stress) THEN dvols = rhos1%pw%pw_grid%dvol - CALL rs_grid_create (rpot, rs_desc, error=error) - CALL rs_pw_transfer (rpot, phi_r, pw2rs, error=error) + CALL rs_grid_create (rpot, rs_desc) + CALL rs_pw_transfer (rpot, phi_r, pw2rs) ipart = 0 DO CALL set_list ( particle_set, npart, exp_igr%centre, p1, rden, ipart, exp_igr %core_centre) @@ -276,7 +274,7 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & IF ( p1 == 0 .AND. p2 == 0 ) EXIT ! integrate box and potential CALL get_patch ( dg, particle_set, exp_igr, box, p1, p2, grid_b, grid_s, & - rhos1, rhos2 , charges=charges, error=error ) + rhos1, rhos2 , charges=charges) ! add boxes to real space grid (big box) CALL dg_sum_patch_force_1d ( rpot, rhos1, exp_igr%centre(:,p1), fat1 ) IF (atprop%energy) THEN @@ -302,12 +300,10 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & IF (atprop%stress) THEN CALL pw_pool_create_pw ( pw_big_pool, phi_g, & use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE,& - error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw ( pw_big_pool, rhob_g, & use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE,& - error=error) + in_space = RECIPROCALSPACE) ffa = ( 0.5_dp / dg_rho0%zet ( 1 ) ) ** 2 ffb = 1.0_dp / fourpi DO i = 1, 3 @@ -317,12 +313,12 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & END DO IF(grid_b%have_g0) phi_g%cc(1) = 0.0_dp DO j = 1, i - CALL pw_copy ( phi_g, rhob_g, error=error) + CALL pw_copy ( phi_g, rhob_g) nd = 0 nd ( j ) = 1 - CALL pw_derive ( rhob_g, nd , error=error) - CALL pw_transfer ( rhob_g, rhob_r, error=error) - CALL rs_pw_transfer ( rpot, rhob_r, pw2rs, error=error) + CALL pw_derive ( rhob_g, nd) + CALL pw_transfer ( rhob_g, rhob_r) + CALL rs_pw_transfer ( rpot, rhob_r, pw2rs) ipart = 0 DO @@ -331,7 +327,7 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & IF ( p1 == 0 .AND. p2 == 0 ) EXIT ! integrate box and potential CALL get_patch ( dg, particle_set, exp_igr, box, p1, p2, grid_b, grid_s, & - rhos1, rhos2 , charges=charges, error=error ) + rhos1, rhos2 , charges=charges) ! add boxes to real space grid (big box) CALL dg_sum_patch_force_1d ( rpot, rhos1, exp_igr%centre(:,p1), fat1 ) atprop%atstress(i,j,p1) = atprop%atstress(i,j,p1) + fat1*dvols @@ -344,13 +340,13 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & END DO END DO END DO - CALL pw_pool_give_back_pw ( pw_big_pool, phi_g ,error=error) - CALL pw_pool_give_back_pw ( pw_big_pool, rhob_g ,error=error) + CALL pw_pool_give_back_pw ( pw_big_pool, phi_g) + CALL pw_pool_give_back_pw ( pw_big_pool, rhob_g) END IF - CALL rs_grid_release ( rpot, error=error) + CALL rs_grid_release ( rpot) END IF - CALL pw_pool_give_back_pw ( pw_big_pool, phi_r ,error=error) + CALL pw_pool_give_back_pw ( pw_big_pool, phi_r) !---------- END OF ELECTROSTATIC CALCULATION -------- @@ -359,7 +355,7 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & IF ((use_virial).AND.(PRESENT(pv_g))) THEN DO i = 1, 3 DO j = i, 3 - f_stress ( i, j ) = pw_integral_a2b ( dphi_g ( i )%pw, dphi_g ( j )%pw, error=error) + f_stress ( i, j ) = pw_integral_a2b ( dphi_g ( i )%pw, dphi_g ( j )%pw) f_stress ( j, i ) = f_stress ( i, j ) END DO END DO @@ -371,16 +367,16 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & !--------END OF STRESS TENSOR CALCULATION ----------- ALLOCATE ( drpot(1:3), STAT=ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO i = 1, 3 - CALL rs_grid_create(drpot(i)%rs_grid, rs_desc, error=error ) - CALL rs_grid_set_box ( grid_b, rs=drpot(i)%rs_grid, error=error ) - CALL pw_transfer ( dphi_g ( i )%pw, rhob_r, error=error) - CALL pw_pool_give_back_pw ( pw_big_pool, dphi_g ( i )%pw ,error=error) - CALL rs_pw_transfer ( drpot ( i )%rs_grid, rhob_r, pw2rs,error=error) + CALL rs_grid_create(drpot(i)%rs_grid, rs_desc) + CALL rs_grid_set_box ( grid_b, rs=drpot(i)%rs_grid) + CALL pw_transfer ( dphi_g ( i )%pw, rhob_r) + CALL pw_pool_give_back_pw ( pw_big_pool, dphi_g ( i )%pw) + CALL rs_pw_transfer ( drpot ( i )%rs_grid, rhob_r, pw2rs) END DO - CALL pw_pool_give_back_pw ( pw_big_pool, rhob_r ,error=error) + CALL pw_pool_give_back_pw ( pw_big_pool, rhob_r) !----------------- FORCE CALCULATION ---------------- @@ -474,17 +470,17 @@ SUBROUTINE pme_evaluate ( ewald_env, ewald_pw, box, particle_set, vg_coulomb, & !------------------CLEANING UP ---------------------- - CALL rs_grid_release(rden, error=error) + CALL rs_grid_release(rden) IF (ASSOCIATED(drpot)) THEN DO i = 1, 3 - CALL rs_grid_release(drpot(i)%rs_grid, error=error) + CALL rs_grid_release(drpot(i)%rs_grid) END DO DEALLOCATE ( drpot, STAT = ierr ) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF - CALL pw_pool_give_back_pw ( pw_small_pool, rhos1%pw ,error=error) - CALL pw_pool_give_back_pw ( pw_small_pool, rhos2%pw ,error=error) + CALL pw_pool_give_back_pw ( pw_small_pool, rhos1%pw) + CALL pw_pool_give_back_pw ( pw_small_pool, rhos2%pw) CALL structure_factor_deallocate ( exp_igr ) CALL timestop(handle) @@ -509,14 +505,13 @@ END SUBROUTINE pme_evaluate !> \param is2_shell ... !> \param core_particle_set ... !> \param charges ... -!> \param error ... !> \par History !> JGH (23-Mar-2001) : Switch to integer from particle list pointers !> \author JGH (21-Mar-2001) ! ***************************************************************************** SUBROUTINE get_patch ( dg, particle_set, exp_igr, box, p1, p2, & grid_b, grid_s, rhos1, rhos2 , is1_core, is2_core, is1_shell,& - is2_shell, core_particle_set, charges, error) + is2_shell, core_particle_set, charges) TYPE(dg_type), POINTER :: dg TYPE(particle_type), DIMENSION(:), & @@ -532,7 +527,6 @@ SUBROUTINE get_patch ( dg, particle_set, exp_igr, box, p1, p2, & OPTIONAL, POINTER :: core_particle_set REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_patch', & routineP = moduleN//':'//routineN @@ -558,7 +552,7 @@ SUBROUTINE get_patch ( dg, particle_set, exp_igr, box, p1, p2, & IF(PRESENT(is1_core)) my_is1_core = is1_core IF(PRESENT(is2_core)) my_is2_core = is2_core IF(my_is1_core .OR. my_is2_core) THEN - CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(core_particle_set),cp_failure_level,routineP,failure) END IF my_is1_shell = .FALSE. my_is2_shell = .FALSE. diff --git a/src/population_analyses.F b/src/population_analyses.F index 076cf3d196..f5ccc00197 100644 --- a/src/population_analyses.F +++ b/src/population_analyses.F @@ -75,16 +75,14 @@ MODULE population_analyses !> \param qs_env ... !> \param output_unit ... !> \param print_level ... -!> \param error ... !> \date 06.07.2010 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE lowdin_population_analysis(qs_env,output_unit,print_level,error) + SUBROUTINE lowdin_population_analysis(qs_env,output_unit,print_level) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: output_unit, print_level - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lowdin_population_analysis', & routineP = moduleN//':'//routineN @@ -143,36 +141,35 @@ SUBROUTINE lowdin_population_analysis(qs_env,output_unit,print_level,error) rho=rho,& scf_control=scf_control,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrixkp_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrixkp_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,failure) IF(SIZE(matrixkp_s,2) > 1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Lowdin population analysis not implemented for k-points.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSE sm_s => matrixkp_s(1,1)%matrix ! Overlap matrix in sparse format - CALL qs_rho_get(rho, rho_ao_kp=matrixkp_p, error=error) ! Density matrices in sparse format + CALL qs_rho_get(rho, rho_ao_kp=matrixkp_p) ! Density matrices in sparse format matrix_p => matrixkp_p(:,1) nspin = SIZE(matrix_p,1) ! Get the total number of contracted spherical Gaussian basis functions - CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf,error=error) + CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf) ! Provide an array to store the orbital populations for each spin ALLOCATE (orbpop(nsgf,nspin),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) orbpop(:,:) = 0.0_dp ! Write headline @@ -185,27 +182,22 @@ SUBROUTINE lowdin_population_analysis(qs_env,output_unit,print_level,error) para_env=para_env,& context=blacs_env,& nrow_global=nsgf,& - ncol_global=nsgf,& - error=error) + ncol_global=nsgf) CALL cp_fm_create(matrix=fm_s_half,& matrix_struct=fmstruct,& - name="S^(1/2) MATRIX",& - error=error) + name="S^(1/2) MATRIX") CALL cp_fm_create(matrix=fm_work1,& matrix_struct=fmstruct,& - name="FULL WORK MATRIX 1",& - error=error) + name="FULL WORK MATRIX 1") headline = "SYMMETRICALLY ORTHOGONALISED DENSITY MATRIX" CALL cp_fm_create(matrix=fm_work2,& matrix_struct=fmstruct,& - name=TRIM(headline),& - error=error) - CALL cp_fm_struct_release(fmstruct=fmstruct,& - error=error) + name=TRIM(headline)) + CALL cp_fm_struct_release(fmstruct=fmstruct) ! Build full S^(1/2) matrix (computationally expensive) - CALL copy_dbcsr_to_fm(sm_s,fm_s_half,error=error) - CALL cp_fm_power(fm_s_half,fm_work1,0.5_dp,scf_control%eps_eigval,ndep,error=error) + CALL copy_dbcsr_to_fm(sm_s,fm_s_half) + CALL cp_fm_power(fm_s_half,fm_work1,0.5_dp,scf_control%eps_eigval,ndep) CALL cp_assert((ndep == 0),cp_warning_level,cp_assertion_failed,routineP,& "Overlap matrix exhibits linear dependencies. At least some "//& "eigenvalues have been quenched.",only_ionode=.TRUE.) @@ -214,7 +206,7 @@ SUBROUTINE lowdin_population_analysis(qs_env,output_unit,print_level,error) DO ispin=1,nspin sm_p => matrix_p(ispin)%matrix ! Density matrix for spin ispin in sparse format ! Calculate S^(1/2)*P*S^(1/2) as a full matrix (Lowdin) - CALL cp_dbcsr_sm_fm_multiply(sm_p,fm_s_half,fm_work1,nsgf,error=error) + CALL cp_dbcsr_sm_fm_multiply(sm_p,fm_s_half,fm_work1,nsgf) CALL cp_gemm(transa="N",& transb="N",& m=nsgf,& @@ -224,8 +216,7 @@ SUBROUTINE lowdin_population_analysis(qs_env,output_unit,print_level,error) matrix_a=fm_s_half,& matrix_b=fm_work1,& beta=0.0_dp,& - matrix_c=fm_work2,& - error=error) + matrix_c=fm_work2) IF (print_level > 2) THEN ! Write the full Lowdin population matrix IF (nspin > 1) THEN @@ -236,24 +227,24 @@ SUBROUTINE lowdin_population_analysis(qs_env,output_unit,print_level,error) END IF END IF CALL write_fm_with_basis_info(fm_work2,4,6,qs_env,para_env,& - output_unit=output_unit,error=error) + output_unit=output_unit) END IF - CALL cp_fm_get_diag(fm_work2,orbpop(:,ispin),error) + CALL cp_fm_get_diag(fm_work2,orbpop(:,ispin)) END DO ! next spin ispin ! Write atomic populations and charges IF (output_unit > 0) THEN print_gop = (print_level > 1) ! Print also orbital populations - CALL write_orbpop(orbpop,atomic_kind_set,qs_kind_set,particle_set,output_unit,print_gop,error) + CALL write_orbpop(orbpop,atomic_kind_set,qs_kind_set,particle_set,output_unit,print_gop) END IF ! Release local working storage - CALL cp_fm_release(matrix=fm_s_half,error=error) - CALL cp_fm_release(matrix=fm_work1,error=error) - CALL cp_fm_release(matrix=fm_work2,error=error) + CALL cp_fm_release(matrix=fm_s_half) + CALL cp_fm_release(matrix=fm_work1) + CALL cp_fm_release(matrix=fm_work2) IF (ASSOCIATED(orbpop)) THEN DEALLOCATE (orbpop,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF END IF @@ -268,16 +259,14 @@ END SUBROUTINE lowdin_population_analysis !> \param qs_env ... !> \param output_unit ... !> \param print_level ... -!> \param error ... !> \date 10.07.2010 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE mulliken_population_analysis(qs_env,output_unit,print_level,error) + SUBROUTINE mulliken_population_analysis(qs_env,output_unit,print_level) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: output_unit, print_level - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mulliken_population_analysis', & routineP = moduleN//':'//routineN @@ -329,30 +318,29 @@ SUBROUTINE mulliken_population_analysis(qs_env,output_unit,print_level,error) matrix_s_kp=matrix_s,& particle_set=particle_set,& rho=rho,& - para_env=para_env,& - error=error) + para_env=para_env) - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) ! Density matrices in sparse format + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) ! Density matrices in sparse format nspin = SIZE(matrix_p,1) ! Get the total number of contracted spherical Gaussian basis functions CALL get_atomic_kind_set(atomic_kind_set,natom=natom) - CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf,error=error) + CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf) ALLOCATE (first_sgf_atom(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) first_sgf_atom(:) = 0 - CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf_atom, error=error) + CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf_atom) ! Provide an array to store the orbital populations for each spin ALLOCATE (orbpop(nsgf,nspin),STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) orbpop(:,:) = 0.0_dp ! Write headline @@ -366,25 +354,24 @@ SUBROUTINE mulliken_population_analysis(qs_env,output_unit,print_level,error) IF (print_level > 2) THEN sm_s => matrix_s(1,1)%matrix ! Overlap matrix in sparse format ALLOCATE (sm_ps,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) headline = "MULLIKEN NET ATOMIC ORBITAL AND OVERLAP POPULATION MATRIX" - CALL cp_dbcsr_init(sm_ps,error=error) + CALL cp_dbcsr_init(sm_ps) CALL cp_dbcsr_copy(matrix_b=sm_ps,& matrix_a=sm_s,& - name=TRIM(headline),& - error=error) + name=TRIM(headline)) END IF ! Build Mulliken population matrix for each spin DO ispin=1,nspin DO ic=1,SIZE(matrix_s,2) IF (print_level > 2) THEN - CALL cp_dbcsr_set(sm_ps,0.0_dp,error=error) + CALL cp_dbcsr_set(sm_ps,0.0_dp) END IF sm_s => matrix_s(1,ic)%matrix ! Overlap matrix in sparse format sm_p => matrix_p(ispin,ic)%matrix ! Density matrix for spin ispin in sparse format ! Calculate Hadamard product of P and S as sparse matrix (Mulliken) - ! CALL cp_dbcsr_hadamard_product(sm_p,sm_s,sm_ps,error=error) + ! CALL cp_dbcsr_hadamard_product(sm_p,sm_s,sm_ps) CALL cp_dbcsr_iterator_start(iter,sm_s) DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) CALL cp_dbcsr_iterator_next_block(iter,iatom,jatom,s_block,blk) @@ -400,7 +387,7 @@ SUBROUTINE mulliken_population_analysis(qs_env,output_unit,print_level,error) col=jatom,& block=ps_block,& found=found) - CPPostcondition(ASSOCIATED(ps_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ps_block),cp_failure_level,routineP,failure) END IF sgfb = first_sgf_atom(jatom) @@ -436,8 +423,7 @@ SUBROUTINE mulliken_population_analysis(qs_env,output_unit,print_level,error) END IF END IF CALL cp_dbcsr_write_sparse_matrix(sm_ps,4,6,qs_env,para_env,& - output_unit=output_unit,& - error=error) + output_unit=output_unit) END IF END DO @@ -446,18 +432,18 @@ SUBROUTINE mulliken_population_analysis(qs_env,output_unit,print_level,error) ! Write atomic populations and charges IF (output_unit > 0) THEN print_gop = (print_level > 1) ! Print also orbital populations - CALL write_orbpop(orbpop,atomic_kind_set, qs_kind_set,particle_set,output_unit,print_gop,error) + CALL write_orbpop(orbpop,atomic_kind_set, qs_kind_set,particle_set,output_unit,print_gop) END IF ! Release local working storage - IF (ASSOCIATED(sm_ps)) CALL cp_dbcsr_deallocate_matrix(sm_ps,error=error) + IF (ASSOCIATED(sm_ps)) CALL cp_dbcsr_deallocate_matrix(sm_ps) IF (ASSOCIATED(orbpop)) THEN DEALLOCATE (orbpop,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) END IF IF (ALLOCATED(first_sgf_atom)) THEN DEALLOCATE (first_sgf_atom,STAT=stat) - CPPostconditionNoFail((stat == 0),cp_warning_level,routineP,error) + CPPostconditionNoFail((stat == 0),cp_warning_level,routineP) END IF IF (output_unit > 0) THEN @@ -478,13 +464,12 @@ END SUBROUTINE mulliken_population_analysis !> \param particle_set ... !> \param output_unit ... !> \param print_orbital_contributions ... -!> \param error ... !> \date 07.07.2010 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** SUBROUTINE write_orbpop(orbpop,atomic_kind_set,qs_kind_set,particle_set,output_unit,& - print_orbital_contributions,error) + print_orbital_contributions) REAL(KIND=dp), DIMENSION(:, :), POINTER :: orbpop TYPE(atomic_kind_type), DIMENSION(:), & @@ -495,7 +480,6 @@ SUBROUTINE write_orbpop(orbpop,atomic_kind_set,qs_kind_set,particle_set,output_u POINTER :: particle_set INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN) :: print_orbital_contributions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_orbpop', & routineP = moduleN//':'//routineN @@ -521,14 +505,14 @@ SUBROUTINE write_orbpop(orbpop,atomic_kind_set,qs_kind_set,particle_set,output_u NULLIFY (orb_basis_set) NULLIFY (sgf_symbol) - CPPrecondition(ASSOCIATED(orbpop),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(orbpop),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(particle_set),cp_failure_level,routineP,failure) nspin = SIZE(orbpop,2) CALL get_atomic_kind_set(atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf,error=error) + CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf) ! Select and write headline IF (nspin == 1) THEN @@ -558,7 +542,7 @@ SUBROUTINE write_orbpop(orbpop,atomic_kind_set,qs_kind_set,particle_set,output_u CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind,& element_symbol=element_symbol,& kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, zeff=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, zeff=zeff) IF (ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& diff --git a/src/preconditioner.F b/src/preconditioner.F index 3463541840..c86583552d 100644 --- a/src/preconditioner.F +++ b/src/preconditioner.F @@ -88,14 +88,13 @@ MODULE preconditioner !> \param energy_gap ... !> \param mixed_precision ... !> \param convert_precond_to_dbcsr ... -!> \param error ... !> \par History !> 09.2014 removed some unused or unfinished methods !> removed sparse preconditioners and the !> sparse approximate inverse at rev 14341 [Florian Schiffmann] ! ***************************************************************************** SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, matrix_h, matrix_s, & - matrix_t, mo_set, energy_gap, mixed_precision, convert_precond_to_dbcsr, error) + matrix_t, mo_set, energy_gap, mixed_precision, convert_precond_to_dbcsr) TYPE(preconditioner_type) :: preconditioner_env INTEGER, INTENT(IN) :: precon_type, solver_type @@ -105,7 +104,6 @@ SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, mat REAL(KIND=dp) :: energy_gap LOGICAL, INTENT(IN), OPTIONAL :: mixed_precision, & convert_precond_to_dbcsr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_preconditioner', & routineP = moduleN//':'//routineN @@ -125,7 +123,7 @@ SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, mat CALL get_mo_set(mo_set=mo_set, mo_coeff=mo_coeff, mo_coeff_b=mo_coeff_b) use_mo_coeff_b = mo_set%use_mo_coeff_b - CALL cp_fm_get_info(mo_coeff,ncol_global=k,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=k) ! Starting some matrix mess, check where to store the result in preconditioner_env, fm or dbcsr_matrix my_convert_precond_to_dbcsr = .FALSE. @@ -149,7 +147,7 @@ SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, mat ! if it wasn't anyway IF(preconditioner_env%solver==ot_precond_solver_update)& CALL transfer_fm_to_dbcsr(preconditioner_env%fm,preconditioner_env%dbcsr_matrix,& - matrix_h,my_mixed_precision,error) + matrix_h,my_mixed_precision) needs_full_spectrum=.FALSE. needs_homo=.FALSE. @@ -159,7 +157,7 @@ SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, mat needs_full_spectrum=.TRUE. ! both of them need the coefficients as fm's, more matrix mess IF(use_mo_coeff_b) THEN - CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff,error=error) + CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff) ENDIF CASE (ot_precond_full_single) needs_homo=.TRUE. @@ -176,7 +174,7 @@ SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, mat energy_homo=0.0_dp IF (needs_full_spectrum) THEN ALLOCATE(eigenvalues_ot(k),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! XXXXXXXXXXXXXXXX do not touch the initial MOs, could be harmful for either ! the case of non-equivalent MOs but also for the derivate ! we could already have all eigenvalues e.g. full_all and we could skip this @@ -187,10 +185,10 @@ SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, mat CALL calculate_subspace_eigenvalues(mo_coeff_b,matrix_h,& eigenvalues_ot, do_rotation = .FALSE.,& para_env=mo_coeff%matrix_struct%para_env,& - blacs_env=mo_coeff%matrix_struct%context,error=error) + blacs_env=mo_coeff%matrix_struct%context) ELSE CALL calculate_subspace_eigenvalues(mo_coeff,matrix_h,& - eigenvalues_ot, do_rotation = .FALSE.,error=error) + eigenvalues_ot, do_rotation = .FALSE.) ENDIF IF (k>0) energy_homo=eigenvalues_ot(k) ELSE @@ -207,26 +205,26 @@ SUBROUTINE make_preconditioner(preconditioner_env, precon_type, solver_type, mat preconditioner_env%in_use=precon_type CALL make_preconditioner_matrix(preconditioner_env, matrix_h, matrix_s, matrix_t, mo_coeff,& energy_homo, eigenvalues_ot, energy_gap, & - my_solver_type, error) + my_solver_type) - CALL solve_preconditioner(my_solver_type,preconditioner_env,matrix_s,matrix_h,my_mixed_precision,error) + CALL solve_preconditioner(my_solver_type,preconditioner_env,matrix_s,matrix_h,my_mixed_precision) ! Here comes more matrix mess, make sure to output the correct matrix format, ! A bit pointless to convert the cholesky factorized version as it doesn't work in ! dbcsr form and will crash later,... IF(my_convert_precond_to_dbcsr) THEN CALL transfer_fm_to_dbcsr(preconditioner_env%fm,preconditioner_env%dbcsr_matrix,& - matrix_h,my_mixed_precision,error) + matrix_h,my_mixed_precision) ELSE CALL transfer_dbcsr_to_fm(preconditioner_env%dbcsr_matrix,preconditioner_env%fm, & preconditioner_env%para_env, preconditioner_env%ctxt,& - my_mixed_precision,error) + my_mixed_precision) ENDIF IF (needs_full_spectrum) THEN DEALLOCATE(eigenvalues_ot,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle) @@ -240,15 +238,13 @@ END SUBROUTINE make_preconditioner !> \param preconditioner ... !> \param prec_type ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE restart_preconditioner(qs_env,preconditioner,prec_type,nspins,error) + SUBROUTINE restart_preconditioner(qs_env,preconditioner,prec_type,nspins) TYPE(qs_environment_type), POINTER :: qs_env TYPE(preconditioner_p_type), & DIMENSION(:), POINTER :: preconditioner INTEGER, INTENT(IN) :: prec_type, nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restart_preconditioner', & routineP = moduleN//':'//routineN @@ -259,21 +255,21 @@ SUBROUTINE restart_preconditioner(qs_env,preconditioner,prec_type,nspins,error) TYPE(cp_para_env_type), POINTER :: para_env NULLIFY(para_env, blacs_env) - CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env, error=error) + CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) IF (ASSOCIATED(preconditioner)) THEN SELECT CASE(prec_type) CASE(ot_precond_full_all,ot_precond_full_single) ! these depend on the ks matrix DO ispin=1,SIZE(preconditioner) - CALL destroy_preconditioner(preconditioner(ispin)%preconditioner,error=error) + CALL destroy_preconditioner(preconditioner(ispin)%preconditioner) DEALLOCATE(preconditioner(ispin)%preconditioner) ENDDO DEALLOCATE(preconditioner,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CASE(ot_precond_none,ot_precond_full_kinetic,ot_precond_s_inverse,ot_precond_full_single_inverse) ! these are 'independent' ! do nothing CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF @@ -282,16 +278,16 @@ SUBROUTINE restart_preconditioner(qs_env,preconditioner,prec_type,nspins,error) SELECT CASE(prec_type) CASE(ot_precond_full_all,ot_precond_full_single_inverse) ALLOCATE(preconditioner(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE DEFAULT ALLOCATE(preconditioner(1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT DO ispin=1,SIZE(preconditioner) ALLOCATE(preconditioner(ispin)%preconditioner) CALL init_preconditioner(preconditioner(ispin)%preconditioner,& para_env=para_env,& - blacs_env=blacs_env,error=error) + blacs_env=blacs_env) ENDDO END IF @@ -311,12 +307,11 @@ END SUBROUTINE restart_preconditioner !> \param has_unit_metric ... !> \param mixed_precision ... !> \param convert_to_dbcsr ... -!> \param error ... ! ***************************************************************************** SUBROUTINE prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,& ot_preconditioner,prec_type,solver_type,& energy_gap,nspins,has_unit_metric,mixed_precision,& - convert_to_dbcsr,error) + convert_to_dbcsr) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mo_set_p_type), DIMENSION(:), & @@ -331,7 +326,6 @@ SUBROUTINE prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,& LOGICAL, INTENT(IN), OPTIONAL :: has_unit_metric, & mixed_precision, & convert_to_dbcsr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'prepare_preconditioner', & routineP = moduleN//':'//routineN @@ -361,18 +355,17 @@ SUBROUTINE prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,& CALL get_qs_env(qs_env,& dft_control=dft_control,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) IF(dft_control%qs_control%semi_empirical .OR. dft_control%qs_control%dftb) THEN IF(prec_type==ot_precond_full_kinetic) THEN msg="Full_kinetic not available for semi-empirical methods" - CPErrorMessage(cp_failure_level,routineP,TRIM(msg),error) + CPErrorMessage(cp_failure_level,routineP,TRIM(msg)) END IF matrix_t => matrix_s(1)%matrix ELSE - CPPrecondition(.NOT. my_has_unit_metric,cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env, kinetic=kinetic, error=error) + CPPrecondition(.NOT. my_has_unit_metric,cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env, kinetic=kinetic) matrix_t => kinetic(1)%matrix END IF @@ -394,15 +387,15 @@ SUBROUTINE prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,& do_rotation = .TRUE., & co_rotate=qs_env%mo_derivs(ispin)%matrix,& para_env=para_env,& - blacs_env=blacs_env,error=error) + blacs_env=blacs_env) ELSEIF(use_mo_coeff_b) THEN CALL calculate_subspace_eigenvalues(mo_coeff_b,matrix_ks(ispin)%matrix,& do_rotation = .TRUE., & para_env=para_env,& - blacs_env=blacs_env,error=error) + blacs_env=blacs_env) ELSE CALL calculate_subspace_eigenvalues(mo_coeff,matrix_ks(ispin)%matrix,& - do_rotation = .TRUE., error=error) + do_rotation = .TRUE.) END IF END DO CASE DEFAULT @@ -424,8 +417,7 @@ SUBROUTINE prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,& matrix_h=matrix_ks(icall)%matrix,& mo_set=mos(icall)%mo_set,& energy_gap=energy_gap,& - convert_precond_to_dbcsr=my_convert_to_dbcsr,& - error=error) + convert_precond_to_dbcsr=my_convert_to_dbcsr) ELSE CALL make_preconditioner(ot_preconditioner(icall)%preconditioner, & prec_type, & @@ -436,8 +428,7 @@ SUBROUTINE prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,& mo_set=mos(icall)%mo_set,& energy_gap=energy_gap,& mixed_precision=my_mixed_precision,& - convert_precond_to_dbcsr=my_convert_to_dbcsr,& - error=error) + convert_precond_to_dbcsr=my_convert_to_dbcsr) END IF END DO END SELECT diff --git a/src/preconditioner_apply.F b/src/preconditioner_apply.F index 1fa483225c..d46e626718 100644 --- a/src/preconditioner_apply.F +++ b/src/preconditioner_apply.F @@ -51,13 +51,11 @@ MODULE preconditioner_apply !> \param preconditioner_env ... !> \param matrix_in ... !> \param matrix_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_preconditioner_fm(preconditioner_env, matrix_in, matrix_out, error) + SUBROUTINE apply_preconditioner_fm(preconditioner_env, matrix_in, matrix_out) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: matrix_in, matrix_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_preconditioner_fm', & routineP = moduleN//':'//routineN @@ -70,15 +68,15 @@ SUBROUTINE apply_preconditioner_fm(preconditioner_env, matrix_in, matrix_out, er CASE (0) CALL stop_program(routineN,moduleN,__LINE__,"No preconditioner in use") CASE (ot_precond_full_single) - CALL apply_full_single(preconditioner_env, matrix_in, matrix_out,error=error) + CALL apply_full_single(preconditioner_env, matrix_in, matrix_out) CASE (ot_precond_full_all) - CALL apply_full_all(preconditioner_env, matrix_in, matrix_out,error=error) + CALL apply_full_all(preconditioner_env, matrix_in, matrix_out) CASE(ot_precond_full_kinetic,ot_precond_full_single_inverse,ot_precond_s_inverse) SELECT CASE (preconditioner_env%solver) CASE(ot_precond_solver_inv_chol,ot_precond_solver_update) - CALL apply_full_single(preconditioner_env, matrix_in, matrix_out,error=error) + CALL apply_full_single(preconditioner_env, matrix_in, matrix_out) CASE(ot_precond_solver_direct) - CALL apply_full_direct(preconditioner_env, matrix_in, matrix_out,error=error) + CALL apply_full_direct(preconditioner_env, matrix_in, matrix_out) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"Solver not implemented") END SELECT @@ -95,13 +93,11 @@ END SUBROUTINE apply_preconditioner_fm !> \param preconditioner_env ... !> \param matrix_in ... !> \param matrix_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_preconditioner_dbcsr(preconditioner_env, matrix_in, matrix_out, error) + SUBROUTINE apply_preconditioner_dbcsr(preconditioner_env, matrix_in, matrix_out) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type) :: matrix_in, matrix_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_preconditioner_dbcsr', & routineP = moduleN//':'//routineN @@ -114,16 +110,16 @@ SUBROUTINE apply_preconditioner_dbcsr(preconditioner_env, matrix_in, matrix_out, CASE (0) CALL stop_program(routineN,moduleN,__LINE__,"No preconditioner in use") CASE (ot_precond_full_single) - CALL apply_single(preconditioner_env, matrix_in, matrix_out,error=error) + CALL apply_single(preconditioner_env, matrix_in, matrix_out) CASE (ot_precond_full_all) - CALL apply_all(preconditioner_env, matrix_in, matrix_out,error=error) + CALL apply_all(preconditioner_env, matrix_in, matrix_out) CASE(ot_precond_full_kinetic,ot_precond_full_single_inverse,ot_precond_s_inverse) SELECT CASE (preconditioner_env%solver) CASE(ot_precond_solver_inv_chol,ot_precond_solver_update) - CALL apply_single(preconditioner_env, matrix_in, matrix_out,error=error) + CALL apply_single(preconditioner_env, matrix_in, matrix_out) CASE(ot_precond_solver_direct) CALL stop_program(routineN,moduleN,__LINE__,"Apply_full_direct not supported with ot") - !CALL apply_full_direct(preconditioner_env, matrix_in, matrix_out,error=error) + !CALL apply_full_direct(preconditioner_env, matrix_in, matrix_out) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"Wrong solver") END SELECT @@ -140,13 +136,11 @@ END SUBROUTINE apply_preconditioner_dbcsr !> \param preconditioner_env ... !> \param matrix_in ... !> \param matrix_out ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE apply_full_single(preconditioner_env, matrix_in, matrix_out,error) +SUBROUTINE apply_full_single(preconditioner_env, matrix_in, matrix_out) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: matrix_in, matrix_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_full_single', & routineP = moduleN//':'//routineN @@ -155,9 +149,9 @@ SUBROUTINE apply_full_single(preconditioner_env, matrix_in, matrix_out,error) CALL timeset(routineN,handle) - CALL cp_fm_get_info(matrix_in,nrow_global=n,ncol_global=k,error=error) + CALL cp_fm_get_info(matrix_in,nrow_global=n,ncol_global=k) CALL cp_gemm('N','N',n,k,n,1.0_dp,preconditioner_env%fm, & - matrix_in,0.0_dp,matrix_out,error=error) + matrix_in,0.0_dp,matrix_out) CALL timestop(handle) END SUBROUTINE apply_full_single @@ -167,13 +161,11 @@ END SUBROUTINE apply_full_single !> \param preconditioner_env ... !> \param matrix_in ... !> \param matrix_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_single(preconditioner_env, matrix_in, matrix_out,error) + SUBROUTINE apply_single(preconditioner_env, matrix_in, matrix_out) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type) :: matrix_in, matrix_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_single', & routineP = moduleN//':'//routineN @@ -186,7 +178,7 @@ SUBROUTINE apply_single(preconditioner_env, matrix_in, matrix_out,error) CALL stop_program(routineN,moduleN,__LINE__,& "NOT ASSOCIATED preconditioner_env%dbcsr_matrix") CALL cp_dbcsr_multiply('N','N',1.0_dp,preconditioner_env%dbcsr_matrix,matrix_in,& - 0.0_dp,matrix_out,error=error) + 0.0_dp,matrix_out) CALL timestop(handle) @@ -198,13 +190,11 @@ END SUBROUTINE apply_single !> \param preconditioner_env ... !> \param matrix_in ... !> \param matrix_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_full_direct(preconditioner_env, matrix_in, matrix_out,error) + SUBROUTINE apply_full_direct(preconditioner_env, matrix_in, matrix_out) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: matrix_in, matrix_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_full_direct', & routineP = moduleN//':'//routineN @@ -214,14 +204,14 @@ SUBROUTINE apply_full_direct(preconditioner_env, matrix_in, matrix_out,error) CALL timeset(routineN,handle) - CALL cp_fm_get_info(matrix_in,nrow_global=n,ncol_global=k,error=error) + CALL cp_fm_get_info(matrix_in,nrow_global=n,ncol_global=k) CALL cp_fm_create(work,matrix_in%matrix_struct,name="apply_full_single",& - use_sp=matrix_in%use_sp,error=error) + use_sp=matrix_in%use_sp) CALL cp_fm_cholesky_restore(matrix_in,k,preconditioner_env%fm,work,& - & "SOLVE",transa="T",error=error) + & "SOLVE",transa="T") CALL cp_fm_cholesky_restore(work,k,preconditioner_env%fm,matrix_out,& - & "SOLVE",transa="N",error=error) - CALL cp_fm_release(work,error=error) + & "SOLVE",transa="N") + CALL cp_fm_release(work) CALL timestop(handle) @@ -232,13 +222,11 @@ END SUBROUTINE apply_full_direct !> \param preconditioner_env ... !> \param matrix_in ... !> \param matrix_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_full_all(preconditioner_env, matrix_in, matrix_out, error) + SUBROUTINE apply_full_all(preconditioner_env, matrix_in, matrix_out) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: matrix_in, matrix_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_full_all', & routineP = moduleN//':'//routineN @@ -252,15 +240,15 @@ SUBROUTINE apply_full_all(preconditioner_env, matrix_in, matrix_out, error) CALL timeset(routineN,handle) - CALL cp_fm_get_info(matrix_in,nrow_global=n,ncol_global=k,error=error) + CALL cp_fm_get_info(matrix_in,nrow_global=n,ncol_global=k) - CALL cp_fm_create(matrix_tmp,matrix_in%matrix_struct,name="apply_full_all",error=error) + CALL cp_fm_create(matrix_tmp,matrix_in%matrix_struct,name="apply_full_all") CALL cp_fm_get_info(matrix_tmp, nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices, local_data=local_data,error=error) + row_indices=row_indices, col_indices=col_indices, local_data=local_data) ! CALL cp_gemm('T','N',n,k,n,1.0_dp,preconditioner_env%fm, & - matrix_in,0.0_dp,matrix_tmp,error=error) + matrix_in,0.0_dp,matrix_tmp) ! do the right scaling DO j=1,ncol_local @@ -273,9 +261,9 @@ SUBROUTINE apply_full_all(preconditioner_env, matrix_in, matrix_out, error) ! mult back CALL cp_gemm('N','N',n,k,n,1.0_dp,preconditioner_env%fm, & - matrix_tmp,0.0_dp,matrix_out,error=error) + matrix_tmp,0.0_dp,matrix_out) - CALL cp_fm_release(matrix_tmp,error=error) + CALL cp_fm_release(matrix_tmp) CALL timestop(handle) @@ -286,13 +274,11 @@ END SUBROUTINE apply_full_all !> \param preconditioner_env ... !> \param matrix_in ... !> \param matrix_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_all(preconditioner_env, matrix_in, matrix_out, error) + SUBROUTINE apply_all(preconditioner_env, matrix_in, matrix_out) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type) :: matrix_in, matrix_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_all', & routineP = moduleN//':'//routineN @@ -307,10 +293,10 @@ SUBROUTINE apply_all(preconditioner_env, matrix_in, matrix_out, error) CALL timeset(routineN,handle) - CALL cp_dbcsr_init(matrix_tmp,error=error) - CALL cp_dbcsr_copy(matrix_tmp,matrix_in,name="apply_full_all",error=error) + CALL cp_dbcsr_init(matrix_tmp) + CALL cp_dbcsr_copy(matrix_tmp,matrix_in,name="apply_full_all") CALL cp_dbcsr_multiply('T','N',1.0_dp,preconditioner_env%dbcsr_matrix, & - matrix_in,0.0_dp,matrix_tmp,error=error) + matrix_in,0.0_dp,matrix_tmp) ! do the right scaling CALL cp_dbcsr_iterator_start(iter, matrix_tmp) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) @@ -330,8 +316,8 @@ SUBROUTINE apply_all(preconditioner_env, matrix_in, matrix_out, error) ! mult back CALL cp_dbcsr_multiply('N','N',1.0_dp,preconditioner_env%dbcsr_matrix, & - matrix_tmp,0.0_dp,matrix_out,error=error) - CALL cp_dbcsr_release(matrix_tmp, error=error) + matrix_tmp,0.0_dp,matrix_out) + CALL cp_dbcsr_release(matrix_tmp) CALL timestop(handle) END SUBROUTINE apply_all diff --git a/src/preconditioner_makes.F b/src/preconditioner_makes.F index cec0635d8b..d2140fb675 100644 --- a/src/preconditioner_makes.F +++ b/src/preconditioner_makes.F @@ -75,11 +75,10 @@ MODULE preconditioner_makes !> \param eigenvalues_ot ... !> \param energy_gap ... !> \param my_solver_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE make_preconditioner_matrix(preconditioner_env, matrix_h, matrix_s, matrix_t, mo_coeff,& energy_homo, eigenvalues_ot, energy_gap,& - my_solver_type, error) + my_solver_type) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type), POINTER :: matrix_h TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_s, matrix_t @@ -88,7 +87,6 @@ SUBROUTINE make_preconditioner_matrix(preconditioner_env, matrix_h, matrix_s, ma REAL(KIND=dp), DIMENSION(:), POINTER :: eigenvalues_ot REAL(KIND=dp) :: energy_gap INTEGER :: my_solver_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_preconditioner_matrix', & routineP = moduleN//':'//routineN @@ -106,28 +104,27 @@ SUBROUTINE make_preconditioner_matrix(preconditioner_env, matrix_h, matrix_s, ma "Only PRECOND_SOLVER DEFAULT for the moment") IF ( PRESENT(matrix_s) ) THEN CALL make_full_single(preconditioner_env, preconditioner_env%fm,& - matrix_h, matrix_s, energy_homo, energy_gap ,error=error) + matrix_h, matrix_s, energy_homo, energy_gap) ELSE CALL make_full_single_ortho(preconditioner_env, preconditioner_env%fm,& - matrix_h, energy_homo, energy_gap ,error=error) + matrix_h, energy_homo, energy_gap) END IF CASE (ot_precond_s_inverse) IF(my_solver_type.EQ.ot_precond_solver_default) my_solver_type=ot_precond_solver_inv_chol IF (.NOT. PRESENT(matrix_s) ) & CALL stop_program(routineN,moduleN,__LINE__, "Type for S=1 not implemented") - CALL make_full_s_inverse(preconditioner_env,matrix_s,error) + CALL make_full_s_inverse(preconditioner_env,matrix_s) CASE (ot_precond_full_kinetic) IF(my_solver_type.EQ.ot_precond_solver_default) my_solver_type=ot_precond_solver_inv_chol IF (.NOT.( PRESENT(matrix_s) .AND. PRESENT(matrix_t) )) & CALL stop_program(routineN,moduleN,__LINE__,"Type for S=1 not implemented") - CALL make_full_kinetic(preconditioner_env, matrix_t, matrix_s, energy_gap, & - error=error) + CALL make_full_kinetic(preconditioner_env, matrix_t, matrix_s, energy_gap) CASE (ot_precond_full_single_inverse) IF(my_solver_type.EQ.ot_precond_solver_default) my_solver_type=ot_precond_solver_inv_chol CALL make_full_single_inverse(preconditioner_env, mo_coeff, matrix_h, energy_gap, & - matrix_s=matrix_s,error=error) + matrix_s=matrix_s) CASE (ot_precond_full_all) IF(my_solver_type.NE.ot_precond_solver_default) THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -135,10 +132,10 @@ SUBROUTINE make_preconditioner_matrix(preconditioner_env, matrix_h, matrix_s, ma ENDIF IF ( PRESENT(matrix_s) ) THEN CALL make_full_all(preconditioner_env,mo_coeff,matrix_h, matrix_s, & - eigenvalues_ot, energy_gap,error=error) + eigenvalues_ot, energy_gap) ELSE CALL make_full_all_ortho(preconditioner_env,mo_coeff,matrix_h, & - eigenvalues_ot, energy_gap,error=error) + eigenvalues_ot, energy_gap) END IF CASE DEFAULT @@ -151,12 +148,10 @@ END SUBROUTINE make_preconditioner_matrix !> \brief Simply takes the overlap matrix as preconditioner !> \param preconditioner_env ... !> \param matrix_s ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE make_full_s_inverse(preconditioner_env, matrix_s, error) + SUBROUTINE make_full_s_inverse(preconditioner_env, matrix_s) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type), POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_s_inverse', & routineP = moduleN//':'//routineN @@ -167,13 +162,13 @@ SUBROUTINE make_full_s_inverse(preconditioner_env, matrix_s, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) IF(.NOT.ASSOCIATED(preconditioner_env%sparse_matrix)) THEN ALLOCATE(preconditioner_env%sparse_matrix) - CALL cp_dbcsr_init(preconditioner_env%sparse_matrix,error=error) + CALL cp_dbcsr_init(preconditioner_env%sparse_matrix) END IF - CALL cp_dbcsr_copy(preconditioner_env%sparse_matrix,matrix_s,name="full_kinetic",error=error) + CALL cp_dbcsr_copy(preconditioner_env%sparse_matrix,matrix_s,name="full_kinetic") CALL timestop(handle) @@ -186,14 +181,12 @@ END SUBROUTINE make_full_s_inverse !> \param matrix_t ... !> \param matrix_s ... !> \param energy_gap ... -!> \param error ... ! ***************************************************************************** SUBROUTINE make_full_kinetic(preconditioner_env, matrix_t, matrix_s, & - energy_gap, error) + energy_gap) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type), POINTER :: matrix_t, matrix_s REAL(KIND=dp) :: energy_gap - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_kinetic', & routineP = moduleN//':'//routineN @@ -205,19 +198,19 @@ SUBROUTINE make_full_kinetic(preconditioner_env, matrix_t, matrix_s, & failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(matrix_t),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_t),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) IF(.NOT.ASSOCIATED(preconditioner_env%sparse_matrix)) THEN ALLOCATE(preconditioner_env%sparse_matrix) - CALL cp_dbcsr_init(preconditioner_env%sparse_matrix,error=error) + CALL cp_dbcsr_init(preconditioner_env%sparse_matrix) END IF - CALL cp_dbcsr_copy(preconditioner_env%sparse_matrix,matrix_t,name="full_kinetic",error=error) + CALL cp_dbcsr_copy(preconditioner_env%sparse_matrix,matrix_t,name="full_kinetic") shift=MAX(0.0_dp,energy_gap) CALL cp_dbcsr_add(preconditioner_env%sparse_matrix,matrix_s,& - alpha_scalar=1.0_dp,beta_scalar=shift,error=error) + alpha_scalar=1.0_dp,beta_scalar=shift) CALL timestop(handle) @@ -231,15 +224,13 @@ END SUBROUTINE make_full_kinetic !> \param matrix_s ... !> \param energy_homo ... !> \param energy_gap ... -!> \param error ... ! ***************************************************************************** SUBROUTINE make_full_single(preconditioner_env, fm, matrix_h, matrix_s, & - energy_homo, energy_gap , error) + energy_homo, energy_gap) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: fm TYPE(cp_dbcsr_type), POINTER :: matrix_h, matrix_s REAL(KIND=dp) :: energy_homo, energy_gap - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_single', & routineP = moduleN//':'//routineN @@ -254,36 +245,36 @@ SUBROUTINE make_full_single(preconditioner_env, fm, matrix_h, matrix_s, & NULLIFY(fm_h,fm_s,fm_struct_tmp,evals) IF (ASSOCIATED(fm)) THEN - CALL cp_fm_release(fm,error=error) + CALL cp_fm_release(fm) ENDIF CALL cp_dbcsr_get_info(matrix_h,nfullrows_total=n) ALLOCATE(evals(n)) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=n,ncol_global=n,& context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(fm,fm_struct_tmp, name="preconditioner",error=error) - CALL cp_fm_create(fm_h,fm_struct_tmp, name="fm_h",error=error) - CALL cp_fm_create(fm_s,fm_struct_tmp, name="fm_s",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(fm,fm_struct_tmp, name="preconditioner") + CALL cp_fm_create(fm_h,fm_struct_tmp, name="fm_h") + CALL cp_fm_create(fm_s,fm_struct_tmp, name="fm_s") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL copy_dbcsr_to_fm(matrix_h,fm_h,error=error) - CALL copy_dbcsr_to_fm(matrix_s,fm_s,error=error) - CALL cp_fm_cholesky_decompose(fm_s,error=error) - CALL cp_fm_cholesky_reduce(fm_h,fm_s,error=error) - CALL choose_eigv_solver(fm_h,fm,evals,error=error) - CALL cp_fm_cholesky_restore(fm,n,fm_s,fm_h,"SOLVE",error=error) + CALL copy_dbcsr_to_fm(matrix_h,fm_h) + CALL copy_dbcsr_to_fm(matrix_s,fm_s) + CALL cp_fm_cholesky_decompose(fm_s) + CALL cp_fm_cholesky_reduce(fm_h,fm_s) + CALL choose_eigv_solver(fm_h,fm,evals) + CALL cp_fm_cholesky_restore(fm,n,fm_s,fm_h,"SOLVE") DO i=1,n evals(i)=1.0_dp/MAX(evals(i)-energy_homo,energy_gap) ENDDO - CALL cp_fm_to_fm(fm_h,fm,error=error) + CALL cp_fm_to_fm(fm_h,fm) CALL cp_fm_column_scale(fm,evals) - CALL cp_gemm('N','T',n,n,n,1.0_dp,fm,fm_h,0.0_dp,fm_s,error=error) - CALL cp_fm_to_fm(fm_s,fm,error=error) + CALL cp_gemm('N','T',n,n,n,1.0_dp,fm,fm_h,0.0_dp,fm_s) + CALL cp_fm_to_fm(fm_s,fm) DEALLOCATE(evals) - CALL cp_fm_release(fm_h,error=error) - CALL cp_fm_release(fm_s,error=error) + CALL cp_fm_release(fm_h) + CALL cp_fm_release(fm_s) CALL timestop(handle) @@ -296,15 +287,13 @@ END SUBROUTINE make_full_single !> \param matrix_h ... !> \param energy_homo ... !> \param energy_gap ... -!> \param error ... ! ***************************************************************************** SUBROUTINE make_full_single_ortho(preconditioner_env, fm, matrix_h, & - energy_homo, energy_gap , error) + energy_homo, energy_gap) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: fm TYPE(cp_dbcsr_type), POINTER :: matrix_h REAL(KIND=dp) :: energy_homo, energy_gap - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_single_ortho', & routineP = moduleN//':'//routineN @@ -318,33 +307,33 @@ SUBROUTINE make_full_single_ortho(preconditioner_env, fm, matrix_h, & NULLIFY(fm_h,fm_s,fm_struct_tmp,evals) IF (ASSOCIATED(fm)) THEN - CALL cp_fm_release(fm,error=error) + CALL cp_fm_release(fm) ENDIF CALL cp_dbcsr_get_info(matrix_h,nfullrows_total=n) ALLOCATE(evals(n)) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=n,ncol_global=n,& context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(fm,fm_struct_tmp, name="preconditioner",error=error) - CALL cp_fm_create(fm_h,fm_struct_tmp, name="fm_h",error=error) - CALL cp_fm_create(fm_s,fm_struct_tmp, name="fm_s",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(fm,fm_struct_tmp, name="preconditioner") + CALL cp_fm_create(fm_h,fm_struct_tmp, name="fm_h") + CALL cp_fm_create(fm_s,fm_struct_tmp, name="fm_s") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL copy_dbcsr_to_fm(matrix_h,fm_h,error=error) + CALL copy_dbcsr_to_fm(matrix_h,fm_h) - CALL choose_eigv_solver(fm_h,fm,evals,error=error) + CALL choose_eigv_solver(fm_h,fm,evals) DO i=1,n evals(i)=1.0_dp/MAX(evals(i)-energy_homo,energy_gap) ENDDO - CALL cp_fm_to_fm(fm,fm_h,error=error) + CALL cp_fm_to_fm(fm,fm_h) CALL cp_fm_column_scale(fm,evals) - CALL cp_gemm('N','T',n,n,n,1.0_dp,fm,fm_h,0.0_dp,fm_s,error=error) - CALL cp_fm_to_fm(fm_s,fm,error=error) + CALL cp_gemm('N','T',n,n,n,1.0_dp,fm,fm_h,0.0_dp,fm_s) + CALL cp_fm_to_fm(fm_s,fm) DEALLOCATE(evals) - CALL cp_fm_release(fm_h,error=error) - CALL cp_fm_release(fm_s,error=error) + CALL cp_fm_release(fm_h) + CALL cp_fm_release(fm_s) CALL timestop(handle) @@ -359,7 +348,6 @@ END SUBROUTINE make_full_single_ortho !> \param c0_evals ... !> \param energy_gap should be a slight underestimate of the physical energy gap for almost all systems !> the c0 are already ritz states of (h,s) -!> \param error ... !> \par History !> 10.2006 made more stable [Joost VandeVondele] !> \note @@ -370,13 +358,12 @@ END SUBROUTINE make_full_single_ortho !> the lagrangian multipliers in the OT minimization (i.e. if the c0 here is different !> from the c0 used in the OT setup, there will be a bug). ! ***************************************************************************** -SUBROUTINE make_full_all(preconditioner_env, matrix_c0, matrix_h, matrix_s, c0_evals, energy_gap, error) +SUBROUTINE make_full_all(preconditioner_env, matrix_c0, matrix_h, matrix_s, c0_evals, energy_gap) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: matrix_c0 TYPE(cp_dbcsr_type), POINTER :: matrix_h, matrix_s REAL(KIND=dp), DIMENSION(:), POINTER :: c0_evals REAL(KIND=dp) :: energy_gap - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_all', & routineP = moduleN//':'//routineN @@ -392,23 +379,23 @@ SUBROUTINE make_full_all(preconditioner_env, matrix_c0, matrix_h, matrix_s, c0_e CALL timeset(routineN,handle) - IF (ASSOCIATED(preconditioner_env%fm)) CALL cp_fm_release(preconditioner_env%fm,error) - CALL cp_fm_get_info(matrix_c0,nrow_global=n,ncol_global=k,error=error) + IF (ASSOCIATED(preconditioner_env%fm)) CALL cp_fm_release(preconditioner_env%fm) + CALL cp_fm_get_info(matrix_c0,nrow_global=n,ncol_global=k) CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=n,ncol_global=n, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(preconditioner_env%fm,fm_struct_tmp,name="preconditioner_env%fm",error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(preconditioner_env%fm,fm_struct_tmp,name="preconditioner_env%fm") matrix_pre=>preconditioner_env%fm - CALL cp_fm_create(ortho,fm_struct_tmp,name="ortho",error=error) - CALL cp_fm_create(matrix_tmp,fm_struct_tmp,name="matrix_tmp",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(ortho,fm_struct_tmp,name="ortho") + CALL cp_fm_create(matrix_tmp,fm_struct_tmp,name="matrix_tmp") + CALL cp_fm_struct_release(fm_struct_tmp) ALLOCATE(preconditioner_env%full_evals(n)) ALLOCATE(preconditioner_env%occ_evals(k)) ! 0) cholesky decompose the overlap matrix, if this fails the basis is singular, ! more than EPS_DEFAULT - CALL copy_dbcsr_to_fm(matrix_s,ortho,error=error) - CALL cp_fm_cholesky_decompose(ortho,error=error) + CALL copy_dbcsr_to_fm(matrix_s,ortho) + CALL cp_fm_cholesky_decompose(ortho) ! 1) Construct a new H matrix, which has the current C0 as eigenvectors, ! possibly shifted by an amount lambda, @@ -416,75 +403,75 @@ SUBROUTINE make_full_all(preconditioner_env, matrix_c0, matrix_h, matrix_s, c0_e ! with P=C0 C0 ^ T ! (1 - PS)^T H (1-PS) + (PS)^T (H - lambda S ) (PS) ! we exploit that the C0 are already the ritz states of H - CALL cp_fm_create(matrix_sc0,matrix_c0%matrix_struct,name="sc0",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s,matrix_c0,matrix_sc0,k,error=error) - CALL cp_fm_create(matrix_hc0,matrix_c0%matrix_struct,name="hc0",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_h,matrix_c0,matrix_hc0,k,error=error) + CALL cp_fm_create(matrix_sc0,matrix_c0%matrix_struct,name="sc0") + CALL cp_dbcsr_sm_fm_multiply(matrix_s,matrix_c0,matrix_sc0,k) + CALL cp_fm_create(matrix_hc0,matrix_c0%matrix_struct,name="hc0") + CALL cp_dbcsr_sm_fm_multiply(matrix_h,matrix_c0,matrix_hc0,k) ! An aside, try to estimate the error on the ritz values, we'll need it later on - CALL cp_fm_create(matrix_shc0,matrix_c0%matrix_struct,name="shc0",error=error) - CALL cp_fm_cholesky_restore(matrix_hc0,k,ortho,matrix_shc0,"SOLVE",transa="T",error=error) + CALL cp_fm_create(matrix_shc0,matrix_c0%matrix_struct,name="shc0") + CALL cp_fm_cholesky_restore(matrix_hc0,k,ortho,matrix_shc0,"SOLVE",transa="T") CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=k,ncol_global=k, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1") + CALL cp_fm_struct_release(fm_struct_tmp) ! since we only use diagonal elements this is a bit of a waste - CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_shc0,matrix_shc0,0.0_dp,matrix_s1,error=error) + CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_shc0,matrix_shc0,0.0_dp,matrix_s1) ALLOCATE(diag(k)) - CALL cp_fm_get_diag(matrix_s1,diag,error=error) + CALL cp_fm_get_diag(matrix_s1,diag) error_estimate=MAXVAL(SQRT(ABS(diag-c0_evals**2))) DEALLOCATE(diag) - CALL cp_fm_release(matrix_s1,error=error) - CALL cp_fm_release(matrix_shc0,error=error) + CALL cp_fm_release(matrix_s1) + CALL cp_fm_release(matrix_shc0) ! we'll only use the energy gap, if our estimate of the error on the eigenvalues ! is small enough. A large error combined with a small energy gap would otherwise lead to ! an aggressive but bad preconditioner. Only when the error is small (MD), we can precondition ! aggressively preconditioner_env%energy_gap= MAX(energy_gap,error_estimate*fudge_factor) - CALL copy_dbcsr_to_fm(matrix_h,matrix_tmp,error=error) - CALL cp_fm_upper_to_full(matrix_tmp,matrix_pre,error=error) + CALL copy_dbcsr_to_fm(matrix_h,matrix_tmp) + CALL cp_fm_upper_to_full(matrix_tmp,matrix_pre) ! tmp = H ( 1 - PS ) - CALL cp_gemm('N','T',n,n,k,-1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp,error=error) + CALL cp_gemm('N','T',n,n,k,-1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp) CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=k,ncol_global=n, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(matrix_left,fm_struct_tmp,name="matrix_left",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_gemm('T','N',k,n,n,1.0_dp,matrix_c0,matrix_tmp,0.0_dp,matrix_left,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(matrix_left,fm_struct_tmp,name="matrix_left") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_gemm('T','N',k,n,n,1.0_dp,matrix_c0,matrix_tmp,0.0_dp,matrix_left) ! tmp = (1 - PS)^T H (1-PS) - CALL cp_gemm('N','N',n,n,k,-1.0_dp,matrix_sc0,matrix_left,1.0_dp,matrix_tmp,error=error) - CALL cp_fm_release(matrix_left,error=error) + CALL cp_gemm('N','N',n,n,k,-1.0_dp,matrix_sc0,matrix_left,1.0_dp,matrix_tmp) + CALL cp_fm_release(matrix_left) ALLOCATE(shifted_evals(k)) lambda = lambda_base + error_estimate shifted_evals=c0_evals - lambda - CALL cp_fm_to_fm(matrix_sc0,matrix_hc0,error=error) + CALL cp_fm_to_fm(matrix_sc0,matrix_hc0) CALL cp_fm_column_scale(matrix_hc0,shifted_evals) - CALL cp_gemm('N','T',n,n,k,1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp,error=error) + CALL cp_gemm('N','T',n,n,k,1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp) ! 2) diagonalize this operator - CALL cp_fm_cholesky_reduce(matrix_tmp,ortho,error=error) - CALL choose_eigv_solver(matrix_tmp,matrix_pre,preconditioner_env%full_evals,error=error) - CALL cp_fm_cholesky_restore(matrix_pre,n,ortho,matrix_tmp,"SOLVE",error=error) - CALL cp_fm_to_fm(matrix_tmp,matrix_pre,error=error) + CALL cp_fm_cholesky_reduce(matrix_tmp,ortho) + CALL choose_eigv_solver(matrix_tmp,matrix_pre,preconditioner_env%full_evals) + CALL cp_fm_cholesky_restore(matrix_pre,n,ortho,matrix_tmp,"SOLVE") + CALL cp_fm_to_fm(matrix_tmp,matrix_pre) ! test that the subspace remained conserved IF (.FALSE.) THEN CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=k,ncol_global=k, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1",error=error) - CALL cp_fm_create(matrix_s2,fm_struct_tmp,name="matrix_s2",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1") + CALL cp_fm_create(matrix_s2,fm_struct_tmp,name="matrix_s2") + CALL cp_fm_struct_release(fm_struct_tmp) ALLOCATE(norms(k)) - CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_sc0,matrix_tmp,0.0_dp,matrix_s1,error=error) - CALL choose_eigv_solver(matrix_s1,matrix_s2,norms,error=error) + CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_sc0,matrix_tmp,0.0_dp,matrix_s1) + CALL choose_eigv_solver(matrix_s1,matrix_s2,norms) WRITE(*,*) "matrix norm deviation (should be close to zero): ", MAXVAL(ABS(ABS(norms)-1.0_dp)) DEALLOCATE(norms) - CALL cp_fm_release(matrix_s1,error=error) - CALL cp_fm_release(matrix_s2,error=error) + CALL cp_fm_release(matrix_s1) + CALL cp_fm_release(matrix_s2) ENDIF ! 3) replace the lowest k evals and evecs with what they should be @@ -493,10 +480,10 @@ SUBROUTINE make_full_all(preconditioner_env, matrix_c0, matrix_h, matrix_s, c0_e preconditioner_env%full_evals(1:k)=c0_evals CALL cp_fm_to_fm(matrix_c0,matrix_pre,k,1,1) - CALL cp_fm_release(matrix_sc0,error=error) - CALL cp_fm_release(matrix_hc0,error=error) - CALL cp_fm_release(ortho,error=error) - CALL cp_fm_release(matrix_tmp,error=error) + CALL cp_fm_release(matrix_sc0) + CALL cp_fm_release(matrix_hc0) + CALL cp_fm_release(ortho) + CALL cp_fm_release(matrix_tmp) DEALLOCATE(shifted_evals) CALL timestop(handle) @@ -509,16 +496,14 @@ END SUBROUTINE make_full_all !> \param matrix_h ... !> \param c0_evals ... !> \param energy_gap ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE make_full_all_ortho(preconditioner_env, matrix_c0, matrix_h, c0_evals, energy_gap, error) +SUBROUTINE make_full_all_ortho(preconditioner_env, matrix_c0, matrix_h, c0_evals, energy_gap) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: matrix_c0 TYPE(cp_dbcsr_type), POINTER :: matrix_h REAL(KIND=dp), DIMENSION(:), POINTER :: c0_evals REAL(KIND=dp) :: energy_gap - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_all_ortho', & routineP = moduleN//':'//routineN @@ -536,15 +521,15 @@ SUBROUTINE make_full_all_ortho(preconditioner_env, matrix_c0, matrix_h, c0_evals CALL timeset(routineN,handle) - IF (ASSOCIATED(preconditioner_env%fm)) CALL cp_fm_release(preconditioner_env%fm,error) - CALL cp_fm_get_info(matrix_c0,nrow_global=n,ncol_global=k,error=error) + IF (ASSOCIATED(preconditioner_env%fm)) CALL cp_fm_release(preconditioner_env%fm) + CALL cp_fm_get_info(matrix_c0,nrow_global=n,ncol_global=k) CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=n,ncol_global=n, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(preconditioner_env%fm,fm_struct_tmp,name="preconditioner_env%fm",error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(preconditioner_env%fm,fm_struct_tmp,name="preconditioner_env%fm") matrix_pre=>preconditioner_env%fm - CALL cp_fm_create(matrix_tmp,fm_struct_tmp,name="matrix_tmp",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(matrix_tmp,fm_struct_tmp,name="matrix_tmp") + CALL cp_fm_struct_release(fm_struct_tmp) ALLOCATE(preconditioner_env%full_evals(n)) ALLOCATE(preconditioner_env%occ_evals(k)) @@ -554,73 +539,73 @@ SUBROUTINE make_full_all_ortho(preconditioner_env, matrix_c0, matrix_h, c0_evals ! with P=C0 C0 ^ T ! (1 - PS)^T H (1-PS) + (PS)^T (H - lambda S ) (PS) ! we exploit that the C0 are already the ritz states of H - CALL cp_fm_create(matrix_sc0,matrix_c0%matrix_struct,name="sc0",error=error) - CALL cp_fm_to_fm(matrix_c0,matrix_sc0,error=error) - CALL cp_fm_create(matrix_hc0,matrix_c0%matrix_struct,name="hc0",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_h,matrix_c0,matrix_hc0,k,error=error) + CALL cp_fm_create(matrix_sc0,matrix_c0%matrix_struct,name="sc0") + CALL cp_fm_to_fm(matrix_c0,matrix_sc0) + CALL cp_fm_create(matrix_hc0,matrix_c0%matrix_struct,name="hc0") + CALL cp_dbcsr_sm_fm_multiply(matrix_h,matrix_c0,matrix_hc0,k) ! An aside, try to estimate the error on the ritz values, we'll need it later on CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=k,ncol_global=k, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1") + CALL cp_fm_struct_release(fm_struct_tmp) ! since we only use diagonal elements this is a bit of a waste - CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_hc0,matrix_hc0,0.0_dp,matrix_s1,error=error) + CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_hc0,matrix_hc0,0.0_dp,matrix_s1) ALLOCATE(diag(k)) - CALL cp_fm_get_diag(matrix_s1,diag,error=error) + CALL cp_fm_get_diag(matrix_s1,diag) error_estimate=MAXVAL(SQRT(ABS(diag-c0_evals**2))) DEALLOCATE(diag) - CALL cp_fm_release(matrix_s1,error=error) + CALL cp_fm_release(matrix_s1) ! we'll only use the energy gap, if our estimate of the error on the eigenvalues ! is small enough. A large error combined with a small energy gap would otherwise lead to ! an aggressive but bad preconditioner. Only when the error is small (MD), we can precondition ! aggressively preconditioner_env%energy_gap= MAX(energy_gap,error_estimate*fudge_factor) - CALL copy_dbcsr_to_fm(matrix_h,matrix_tmp,error=error) - CALL cp_fm_upper_to_full(matrix_tmp,matrix_pre,error=error) + CALL copy_dbcsr_to_fm(matrix_h,matrix_tmp) + CALL cp_fm_upper_to_full(matrix_tmp,matrix_pre) ! tmp = H ( 1 - PS ) - CALL cp_gemm('N','T',n,n,k,-1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp,error=error) + CALL cp_gemm('N','T',n,n,k,-1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp) CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=k,ncol_global=n, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(matrix_left,fm_struct_tmp,name="matrix_left",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_gemm('T','N',k,n,n,1.0_dp,matrix_c0,matrix_tmp,0.0_dp,matrix_left,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(matrix_left,fm_struct_tmp,name="matrix_left") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_gemm('T','N',k,n,n,1.0_dp,matrix_c0,matrix_tmp,0.0_dp,matrix_left) ! tmp = (1 - PS)^T H (1-PS) - CALL cp_gemm('N','N',n,n,k,-1.0_dp,matrix_sc0,matrix_left,1.0_dp,matrix_tmp,error=error) - CALL cp_fm_release(matrix_left,error=error) + CALL cp_gemm('N','N',n,n,k,-1.0_dp,matrix_sc0,matrix_left,1.0_dp,matrix_tmp) + CALL cp_fm_release(matrix_left) ALLOCATE(shifted_evals(k)) lambda = lambda_base + error_estimate shifted_evals=c0_evals - lambda - CALL cp_fm_to_fm(matrix_sc0,matrix_hc0,error=error) + CALL cp_fm_to_fm(matrix_sc0,matrix_hc0) CALL cp_fm_column_scale(matrix_hc0,shifted_evals) - CALL cp_gemm('N','T',n,n,k,1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp,error=error) + CALL cp_gemm('N','T',n,n,k,1.0_dp,matrix_hc0,matrix_sc0,1.0_dp,matrix_tmp) ! 2) diagonalize this operator - CALL choose_eigv_solver(matrix_tmp,matrix_pre,preconditioner_env%full_evals,error=error) + CALL choose_eigv_solver(matrix_tmp,matrix_pre,preconditioner_env%full_evals) ! test that the subspace remained conserved IF (.FALSE.) THEN - CALL cp_fm_to_fm(matrix_pre,matrix_tmp,error=error) + CALL cp_fm_to_fm(matrix_pre,matrix_tmp) CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=k,ncol_global=k, & context=preconditioner_env%ctxt, & - para_env=preconditioner_env%para_env,error=error) - CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1",error=error) - CALL cp_fm_create(matrix_s2,fm_struct_tmp,name="matrix_s2",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=preconditioner_env%para_env) + CALL cp_fm_create(matrix_s1,fm_struct_tmp,name="matrix_s1") + CALL cp_fm_create(matrix_s2,fm_struct_tmp,name="matrix_s2") + CALL cp_fm_struct_release(fm_struct_tmp) ALLOCATE(norms(k)) - CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_sc0,matrix_tmp,0.0_dp,matrix_s1,error=error) - CALL choose_eigv_solver(matrix_s1,matrix_s2,norms,error=error) + CALL cp_gemm('T','N',k,k,n,1.0_dp,matrix_sc0,matrix_tmp,0.0_dp,matrix_s1) + CALL choose_eigv_solver(matrix_s1,matrix_s2,norms) WRITE(*,*) "matrix norm deviation (should be close to zero): ", MAXVAL(ABS(ABS(norms)-1.0_dp)) DEALLOCATE(norms) - CALL cp_fm_release(matrix_s1,error=error) - CALL cp_fm_release(matrix_s2,error=error) + CALL cp_fm_release(matrix_s1) + CALL cp_fm_release(matrix_s2) ENDIF ! 3) replace the lowest k evals and evecs with what they should be @@ -629,9 +614,9 @@ SUBROUTINE make_full_all_ortho(preconditioner_env, matrix_c0, matrix_h, c0_evals preconditioner_env%full_evals(1:k)=c0_evals CALL cp_fm_to_fm(matrix_c0,matrix_pre,k,1,1) - CALL cp_fm_release(matrix_sc0,error=error) - CALL cp_fm_release(matrix_hc0,error=error) - CALL cp_fm_release(matrix_tmp,error=error) + CALL cp_fm_release(matrix_sc0) + CALL cp_fm_release(matrix_hc0) + CALL cp_fm_release(matrix_tmp) DEALLOCATE(shifted_evals) CALL timestop(handle) @@ -654,15 +639,13 @@ END SUBROUTINE make_full_all_ortho !> \param matrix_h Kohn-Sham matrix (dbcsr) !> \param energy_gap an additional shift in lambda=-E_homo+energy_gap !> \param matrix_s the overlap matrix if not orthonormal (dbcsr, optional) -!> \param error ... ! ***************************************************************************** -SUBROUTINE make_full_single_inverse(preconditioner_env, matrix_c0, matrix_h, energy_gap, matrix_s, error) +SUBROUTINE make_full_single_inverse(preconditioner_env, matrix_c0, matrix_h, energy_gap, matrix_s) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_fm_type), POINTER :: matrix_c0 TYPE(cp_dbcsr_type), POINTER :: matrix_h REAL(KIND=dp) :: energy_gap TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_single_inverse', & routineP = moduleN//':'//routineN @@ -678,39 +661,39 @@ SUBROUTINE make_full_single_inverse(preconditioner_env, matrix_c0, matrix_h, ene CALL timeset(routineN,handle) ! Allocate all working matrices needed - CALL cp_fm_get_info(matrix_c0,nrow_global=n,ncol_global=k,error=error) - CALL cp_dbcsr_init(mo_dbcsr,error) + CALL cp_fm_get_info(matrix_c0,nrow_global=n,ncol_global=k) + CALL cp_dbcsr_init(mo_dbcsr) ! copy the fm MO's to a sparse matrix, can be solved better if the sparse version is already present ! but for the time beeing this will do - CALL cp_fm_to_dbcsr_row_template(mo_dbcsr,matrix_c0,matrix_h,error) - CALL cp_dbcsr_init(dbcsr_sc,error) - CALL cp_dbcsr_create(dbcsr_sc,template=mo_dbcsr,error=error) - CALL cp_dbcsr_init(dbcsr_hc,error) - CALL cp_dbcsr_create(dbcsr_hc,template=mo_dbcsr,error=error) - CALL cp_dbcsr_init(dbcsr_cThc,error) - CALL cp_dbcsr_m_by_n_from_template(dbcsr_cThc,matrix_h,k,k,sym=dbcsr_type_symmetric,error=error) + CALL cp_fm_to_dbcsr_row_template(mo_dbcsr,matrix_c0,matrix_h) + CALL cp_dbcsr_init(dbcsr_sc) + CALL cp_dbcsr_create(dbcsr_sc,template=mo_dbcsr) + CALL cp_dbcsr_init(dbcsr_hc) + CALL cp_dbcsr_create(dbcsr_hc,template=mo_dbcsr) + CALL cp_dbcsr_init(dbcsr_cThc) + CALL cp_dbcsr_m_by_n_from_template(dbcsr_cThc,matrix_h,k,k,sym=dbcsr_type_symmetric) ! Check whether the output matrix was already created, if not do it now IF(.NOT.ASSOCIATED(preconditioner_env%sparse_matrix)) THEN ALLOCATE(preconditioner_env%sparse_matrix) - CALL cp_dbcsr_init(preconditioner_env%sparse_matrix,error=error) + CALL cp_dbcsr_init(preconditioner_env%sparse_matrix) END IF ! Put the first term of the preconditioner (H) into the output matrix - CALL cp_dbcsr_copy(preconditioner_env%sparse_matrix,matrix_h,error=error) + CALL cp_dbcsr_copy(preconditioner_env%sparse_matrix,matrix_h) ! Precompute some matrices ! S*C, if orthonormal this will be simply C so a copy will do IF(PRESENT(matrix_s))THEN - CALL cp_dbcsr_multiply("N", "N",1.0_dp,matrix_s,mo_dbcsr,0.0_dp,dbcsr_sc,error=error) + CALL cp_dbcsr_multiply("N", "N",1.0_dp,matrix_s,mo_dbcsr,0.0_dp,dbcsr_sc) ELSE - CALL cp_dbcsr_copy(dbcsr_sc,mo_dbcsr,error=error) + CALL cp_dbcsr_copy(dbcsr_sc,mo_dbcsr) END IF !----------------------------compute the occupied subspace and shift it ------------------------------------ ! cT*H*C which will be used to shift the occupied states to 0 - CALL cp_dbcsr_multiply("N", "N",1.0_dp,matrix_h,mo_dbcsr,0.0_dp,dbcsr_hc,error=error) - CALL cp_dbcsr_multiply("T", "N",1.0_dp,mo_dbcsr,dbcsr_hc,0.0_dp,dbcsr_cThc,error=error) + CALL cp_dbcsr_multiply("N", "N",1.0_dp,matrix_h,mo_dbcsr,0.0_dp,dbcsr_hc) + CALL cp_dbcsr_multiply("T", "N",1.0_dp,mo_dbcsr,dbcsr_hc,0.0_dp,dbcsr_cThc) ! Compute the Energy of the HOMO. We will use this as a reference energy ALLOCATE(matrices(1)) @@ -719,21 +702,20 @@ SUBROUTINE make_full_single_inverse(preconditioner_env, matrix_c0, matrix_h, ene nval_request=1, nrestarts=8, generalized_ev=.FALSE.,iram=.FALSE.) IF(ASSOCIATED(preconditioner_env%max_ev_vector))& CALL cp_set_arnoldi_initial_vector(my_arnoldi,preconditioner_env%max_ev_vector) - CALL cp_dbcsr_arnoldi_ev(matrices,my_arnoldi,error) + CALL cp_dbcsr_arnoldi_ev(matrices,my_arnoldi) max_ev=REAL(get_selected_ritz_val(my_arnoldi,1),dp) ! save the ev as guess for the next time IF(.NOT.ASSOCIATED(preconditioner_env%max_ev_vector))ALLOCATE(preconditioner_env%max_ev_vector) - CALL get_selected_ritz_vec(my_arnoldi,1,matrices(1)%matrix,preconditioner_env%max_ev_vector,error) + CALL get_selected_ritz_vec(my_arnoldi,1,matrices(1)%matrix,preconditioner_env%max_ev_vector) CALL deallocate_arnoldi_data(my_arnoldi) DEALLOCATE(matrices) ! Lets shift the occupied states a bit further up, -1.0 because we gonna subtract it from H - CALL cp_dbcsr_add_on_diag(dbcsr_cThc,-0.5_dp,error=error) + CALL cp_dbcsr_add_on_diag(dbcsr_cThc,-0.5_dp) ! Get the AO representation of the shift (see above why S is needed), W-matrix like object - CALL cp_dbcsr_multiply("N", "N",2.0_dp,dbcsr_sc,dbcsr_cThc,0.0_dp,dbcsr_hc,error=error) - CALL cp_dbcsr_multiply("N", "T",-1.0_dp,dbcsr_hc,dbcsr_sc,1.0_dp,preconditioner_env%sparse_matrix,& - error=error) + CALL cp_dbcsr_multiply("N", "N",2.0_dp,dbcsr_sc,dbcsr_cThc,0.0_dp,dbcsr_hc) + CALL cp_dbcsr_multiply("N", "T",-1.0_dp,dbcsr_hc,dbcsr_sc,1.0_dp,preconditioner_env%sparse_matrix) !-------------------------------------compute eigenvalues of H ---------------------------------------------- ! Setup the arnoldi procedure to compute the lowest ev. if S is present this has to be the generalized ev @@ -753,12 +735,12 @@ SUBROUTINE make_full_single_inverse(preconditioner_env, matrix_c0, matrix_h, ene CALL cp_set_arnoldi_initial_vector(my_arnoldi,preconditioner_env%min_ev_vector) ! compute the LUMO energy - CALL cp_dbcsr_arnoldi_ev(matrices,my_arnoldi,error) + CALL cp_dbcsr_arnoldi_ev(matrices,my_arnoldi) min_eV=REAL(get_selected_ritz_val(my_arnoldi,1),dp) ! save the lumo vector for restarting in the next step IF(.NOT.ASSOCIATED(preconditioner_env%min_ev_vector))ALLOCATE(preconditioner_env%min_ev_vector) - CALL get_selected_ritz_vec(my_arnoldi,1,matrices(1)%matrix,preconditioner_env%min_ev_vector,error) + CALL get_selected_ritz_vec(my_arnoldi,1,matrices(1)%matrix,preconditioner_env%min_ev_vector) CALL deallocate_arnoldi_data(my_arnoldi) DEALLOCATE(matrices) @@ -772,15 +754,15 @@ SUBROUTINE make_full_single_inverse(preconditioner_env, matrix_c0, matrix_h, ene pre_shift=0.0_dp END IF IF(PRESENT(matrix_s))THEN - CALL cp_dbcsr_add(preconditioner_env%sparse_matrix,matrix_s,1.0_dp,pre_shift,error=error) + CALL cp_dbcsr_add(preconditioner_env%sparse_matrix,matrix_s,1.0_dp,pre_shift) ELSE - CALL cp_dbcsr_add_on_diag(preconditioner_env%sparse_matrix,pre_shift,error=error) + CALL cp_dbcsr_add_on_diag(preconditioner_env%sparse_matrix,pre_shift) END IF - CALL cp_dbcsr_release(mo_dbcsr,error=error) - CALL cp_dbcsr_release(dbcsr_hc,error=error) - CALL cp_dbcsr_release(dbcsr_sc,error=error) - CALL cp_dbcsr_release(dbcsr_cThc,error=error) + CALL cp_dbcsr_release(mo_dbcsr) + CALL cp_dbcsr_release(dbcsr_hc) + CALL cp_dbcsr_release(dbcsr_sc) + CALL cp_dbcsr_release(dbcsr_cThc) CALL timestop(handle) diff --git a/src/preconditioner_solvers.F b/src/preconditioner_solvers.F index 7e2a0844b6..c4b40f7c06 100644 --- a/src/preconditioner_solvers.F +++ b/src/preconditioner_solvers.F @@ -62,16 +62,14 @@ MODULE preconditioner_solvers !> \param matrix_s ... !> \param matrix_h ... !> \param my_mixed_precision ... -!> \param error ... ! ***************************************************************************** SUBROUTINE solve_preconditioner(my_solver_type, preconditioner_env, matrix_s, & - matrix_h, my_mixed_precision, error) + matrix_h, my_mixed_precision) INTEGER :: my_solver_type TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_s TYPE(cp_dbcsr_type), POINTER :: matrix_h LOGICAL :: my_mixed_precision - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'solve_preconditioner', & routineP = moduleN//':'//routineN @@ -85,12 +83,12 @@ SUBROUTINE solve_preconditioner(my_solver_type, preconditioner_env, matrix_s, & ! ! compute the full inverse preconditioner_env%solver=ot_precond_solver_inv_chol - CALL make_full_inverse_cholesky(preconditioner_env, matrix_s, my_mixed_precision, error=error) + CALL make_full_inverse_cholesky(preconditioner_env, matrix_s, my_mixed_precision) CASE (ot_precond_solver_direct) ! ! prepare for the direct solver preconditioner_env%solver=ot_precond_solver_direct - CALL make_full_fact_cholesky(preconditioner_env, matrix_s, my_mixed_precision, error) + CALL make_full_fact_cholesky(preconditioner_env, matrix_s, my_mixed_precision) CASE (ot_precond_solver_update) ! ! uses an update of the full inverse (needs to be computed the first time) @@ -98,18 +96,18 @@ SUBROUTINE solve_preconditioner(my_solver_type, preconditioner_env, matrix_s, & occ_matrix=1.0_dp IF(ASSOCIATED(preconditioner_env%sparse_matrix))THEN IF(preconditioner_env%condition_num<0.0_dp)& - CALL estimate_cond_num(preconditioner_env%sparse_matrix, preconditioner_env%condition_num, error) + CALL estimate_cond_num(preconditioner_env%sparse_matrix, preconditioner_env%condition_num) CALL cp_dbcsr_filter(preconditioner_env%sparse_matrix,& - 1.0_dp/ preconditioner_env%condition_num*0.01_dp, error=error) + 1.0_dp/ preconditioner_env%condition_num*0.01_dp) occ_matrix=cp_dbcsr_get_occupation(preconditioner_env%sparse_matrix) END IF ! check whether we are in the first step and if it is a good idea to use cholesky (matrix sparsity) IF(preconditioner_env%solver.NE.ot_precond_solver_update.AND.occ_matrix>0.5_dp)THEN preconditioner_env%solver=ot_precond_solver_update - CALL make_full_inverse_cholesky(preconditioner_env, matrix_s, my_mixed_precision, error=error) + CALL make_full_inverse_cholesky(preconditioner_env, matrix_s, my_mixed_precision) ELSE preconditioner_env%solver=ot_precond_solver_update - CALL make_inverse_update(preconditioner_env, matrix_h, my_mixed_precision, error) + CALL make_inverse_update(preconditioner_env, matrix_h, my_mixed_precision) END IF CASE (ot_precond_solver_default) preconditioner_env%solver=ot_precond_solver_default @@ -125,15 +123,12 @@ END SUBROUTINE solve_preconditioner !> \param preconditioner_env ... !> \param matrix_s ... !> \param mixed_precision ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE make_full_inverse_cholesky(preconditioner_env, matrix_s, mixed_precision, & - error) + SUBROUTINE make_full_inverse_cholesky(preconditioner_env, matrix_s, mixed_precision) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_s LOGICAL, INTENT(IN) :: mixed_precision - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_inverse_cholesky', & routineP = moduleN//':'//routineN @@ -150,15 +145,15 @@ SUBROUTINE make_full_inverse_cholesky(preconditioner_env, matrix_s, mixed_precis ! if stuff was stored in fm anyway this simple returns CALL transfer_dbcsr_to_fm(preconditioner_env%sparse_matrix, preconditioner_env%fm, & preconditioner_env%para_env, preconditioner_env%ctxt, & - mixed_precision, error) + mixed_precision) fm=>preconditioner_env%fm NULLIFY(fm_work) - CALL cp_fm_create(fm_work, fm%matrix_struct, name="fm_work", use_sp=mixed_precision, error=error) + CALL cp_fm_create(fm_work, fm%matrix_struct, name="fm_work", use_sp=mixed_precision) ! ! compute the inverse of SPD matrix fm using the Cholesky factorization - CALL cp_fm_cholesky_decompose(fm, info_out=info, error=error) + CALL cp_fm_cholesky_decompose(fm, info_out=info) ! ! if fm not SPD we go with the overlap matrix @@ -166,16 +161,16 @@ SUBROUTINE make_full_inverse_cholesky(preconditioner_env, matrix_s, mixed_precis ! ! just the overlap matrix IF(PRESENT(matrix_s)) THEN - CALL copy_dbcsr_to_fm(matrix_s, fm, error=error) - CALL cp_fm_cholesky_decompose(fm, error=error) + CALL copy_dbcsr_to_fm(matrix_s, fm) + CALL cp_fm_cholesky_decompose(fm) ELSE - CALL cp_fm_set_all(fm, alpha=0._dp, beta=1._dp, error=error) + CALL cp_fm_set_all(fm, alpha=0._dp, beta=1._dp) ENDIF ENDIF - CALL cp_fm_cholesky_invert(fm, error=error) + CALL cp_fm_cholesky_invert(fm) - CALL cp_fm_upper_to_full(fm, fm_work, error=error) - CALL cp_fm_release(fm_work, error=error) + CALL cp_fm_upper_to_full(fm, fm_work) + CALL cp_fm_release(fm_work) CALL timestop(handle) @@ -187,14 +182,12 @@ END SUBROUTINE make_full_inverse_cholesky !> \param preconditioner_env ... !> \param matrix_s ... !> \param mixed_precision ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE make_full_fact_cholesky(preconditioner_env, matrix_s, mixed_precision, error) + SUBROUTINE make_full_fact_cholesky(preconditioner_env, matrix_s, mixed_precision) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_s LOGICAL, INTENT(IN) :: mixed_precision - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_full_fact_cholesky', & routineP = moduleN//':'//routineN @@ -211,12 +204,12 @@ SUBROUTINE make_full_fact_cholesky(preconditioner_env, matrix_s, mixed_precision ! if stuff was stored in fm anyway this simple returns CALL transfer_dbcsr_to_fm(preconditioner_env%sparse_matrix, preconditioner_env%fm, & preconditioner_env%para_env, preconditioner_env%ctxt, & - mixed_precision, error) + mixed_precision) fm=>preconditioner_env%fm ! ! compute the inverse of SPD matrix fm using the Cholesky factorization - CALL cp_fm_cholesky_decompose(fm, error=error) + CALL cp_fm_cholesky_decompose(fm) failure = .FALSE. ! ! if fm not SPD we go with the overlap matrix @@ -224,10 +217,10 @@ SUBROUTINE make_full_fact_cholesky(preconditioner_env, matrix_s, mixed_precision ! ! just the overlap matrix IF(PRESENT(matrix_s)) THEN - CALL copy_dbcsr_to_fm(matrix_s, fm, error=error) - CALL cp_fm_cholesky_decompose(fm, error=error) + CALL copy_dbcsr_to_fm(matrix_s, fm) + CALL cp_fm_cholesky_decompose(fm) ELSE - CALL cp_fm_set_all(fm, alpha=0._dp, beta=1._dp, error=error) + CALL cp_fm_set_all(fm, alpha=0._dp, beta=1._dp) ENDIF ENDIF @@ -240,13 +233,11 @@ END SUBROUTINE make_full_fact_cholesky !> \param preconditioner_env ... !> \param matrix_h as S is not always present this is a safe template for the transfer !> \param mixed_precision ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE make_inverse_update(preconditioner_env, matrix_h, mixed_precision, error) + SUBROUTINE make_inverse_update(preconditioner_env, matrix_h, mixed_precision) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_dbcsr_type), POINTER :: matrix_h LOGICAL, INTENT(IN) :: mixed_precision - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_inverse_update', & routineP = moduleN//':'//routineN @@ -264,22 +255,22 @@ SUBROUTINE make_inverse_update(preconditioner_env, matrix_h, mixed_precision, er ! Maybe I gonna add a fm Hotelling, ... for now the same as above make sure we are dbcsr CALL transfer_fm_to_dbcsr(preconditioner_env%fm, preconditioner_env%sparse_matrix, & - matrix_h, mixed_precision, error) + matrix_h, mixed_precision) IF(.NOT.ASSOCIATED(preconditioner_env%dbcsr_matrix))THEN use_guess=.FALSE. - CALL cp_dbcsr_init_p(preconditioner_env%dbcsr_matrix, error) + CALL cp_dbcsr_init_p(preconditioner_env%dbcsr_matrix) CALL cp_dbcsr_create(preconditioner_env%dbcsr_matrix, "prec_dbcsr", & - template=matrix_h, matrix_type=dbcsr_type_no_symmetry, error=error) + template=matrix_h, matrix_type=dbcsr_type_no_symmetry) END IF ! Try to get a reasonbale guess for the filtering threshold filter_eps=1.0_dp/preconditioner_env%condition_num*0.1_dp ! Agressive filtering on the initial guess is needed to avoid fill ins and retain sparsity - CALL cp_dbcsr_filter(preconditioner_env%dbcsr_matrix, filter_eps*100.0_dp, error=error) + CALL cp_dbcsr_filter(preconditioner_env%dbcsr_matrix, filter_eps*100.0_dp) ! We don't need a high accuracy for the inverse so 0.4 is reasonable for convergence CALL invert_Hotelling(preconditioner_env%dbcsr_matrix, preconditioner_env%sparse_matrix, filter_eps*10.0_dp, & - use_inv_as_guess=use_guess, norm_convergence=0.4_dp, filter_eps=filter_eps, error=error) + use_inv_as_guess=use_guess, norm_convergence=0.4_dp, filter_eps=filter_eps) CALL timestop(handle) @@ -290,12 +281,10 @@ END SUBROUTINE make_inverse_update !> arnoldi iterations !> \param matrix ... !> \param cond_num ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE estimate_cond_num(matrix, cond_num, error) + SUBROUTINE estimate_cond_num(matrix, cond_num) TYPE(cp_dbcsr_type), POINTER :: matrix REAL(KIND=dp) :: cond_num - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'estimate_cond_num', & routineP = moduleN//':'//routineN @@ -314,13 +303,13 @@ SUBROUTINE estimate_cond_num(matrix, cond_num, error) ! compute the minimum ev CALL cp_dbcsr_setup_arnoldi_data(my_arnoldi, matrices, max_iter=20, threshold=5.0E-4_dp, selection_crit=2, & nval_request=1, nrestarts=15, generalized_ev=.FALSE., iram=.FALSE.) - CALL cp_dbcsr_arnoldi_ev(matrices, my_arnoldi, error) + CALL cp_dbcsr_arnoldi_ev(matrices, my_arnoldi) max_ev=REAL(get_selected_ritz_val(my_arnoldi, 1), dp) CALL deallocate_arnoldi_data(my_arnoldi) CALL cp_dbcsr_setup_arnoldi_data(my_arnoldi, matrices, max_iter=20, threshold=5.0E-4_dp, selection_crit=3, & nval_request=1, nrestarts=15, generalized_ev=.FALSE., iram=.FALSE.) - CALL cp_dbcsr_arnoldi_ev(matrices, my_arnoldi, error) + CALL cp_dbcsr_arnoldi_ev(matrices, my_arnoldi) min_ev=REAL(get_selected_ritz_val(my_arnoldi, 1), dp) CALL deallocate_arnoldi_data(my_arnoldi) @@ -336,14 +325,12 @@ END SUBROUTINE estimate_cond_num !> \param dbcsr_matrix a dbcsr matrix, gets create from a template !> \param template_mat the template which is used for the structure !> \param mixed_precision whether to use single or double precision -!> \param error ... ! ***************************************************************************** - SUBROUTINE transfer_fm_to_dbcsr(fm_matrix, dbcsr_matrix, template_mat, mixed_precision, error) + SUBROUTINE transfer_fm_to_dbcsr(fm_matrix, dbcsr_matrix, template_mat, mixed_precision) TYPE(cp_fm_type), POINTER :: fm_matrix TYPE(cp_dbcsr_type), POINTER :: dbcsr_matrix, template_mat LOGICAL :: mixed_precision - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'transfer_fm_to_dbcsr', & routineP = moduleN//':'//routineN @@ -353,24 +340,24 @@ SUBROUTINE transfer_fm_to_dbcsr(fm_matrix, dbcsr_matrix, template_mat, mixed_pre CALL timeset(routineN, handle) IF(ASSOCIATED(fm_matrix))THEN IF(.NOT.ASSOCIATED(dbcsr_matrix)) THEN - CALL cp_dbcsr_init_p(dbcsr_matrix, error=error) + CALL cp_dbcsr_init_p(dbcsr_matrix) IF(mixed_precision) THEN CALL cp_dbcsr_create(dbcsr_matrix, "transfered_matrix", & cp_dbcsr_distribution(template_mat), dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(template_mat), cp_dbcsr_col_block_sizes(template_mat), & - nze=0, data_type=dbcsr_type_real_4, error=error) + nze=0, data_type=dbcsr_type_real_4) ELSE CALL cp_dbcsr_create(dbcsr_matrix, "preconditioner_env%dbcsr_matrix", & cp_dbcsr_distribution(template_mat), dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(template_mat), cp_dbcsr_col_block_sizes(template_mat), & - nze=0, data_type=dbcsr_type_real_default, error=error) + nze=0, data_type=dbcsr_type_real_default) ENDIF ENDIF -! CALL cp_fm_create(fm_tmp, matrix_struct=fm_matrix%matrix_struct, error=error) -! CALL cp_fm_upper_to_full(fm_matrix, fm_tmp, error) - CALL copy_fm_to_dbcsr(fm_matrix, dbcsr_matrix, error=error) -! CALL cp_fm_release(fm_tmp, error) - CALL cp_fm_release(fm_matrix, error) +! CALL cp_fm_create(fm_tmp, matrix_struct=fm_matrix%matrix_struct) +! CALL cp_fm_upper_to_full(fm_matrix, fm_tmp) + CALL copy_fm_to_dbcsr(fm_matrix, dbcsr_matrix) +! CALL cp_fm_release(fm_tmp) + CALL cp_fm_release(fm_matrix) END IF CALL timestop(handle) @@ -384,16 +371,14 @@ END SUBROUTINE transfer_fm_to_dbcsr !> \param para_env the para_env !> \param context the blacs context !> \param mixed_precision whether to use single or double precision -!> \param error ... ! ***************************************************************************** - SUBROUTINE transfer_dbcsr_to_fm(dbcsr_matrix, fm_matrix, para_env, context, mixed_precision, error) + SUBROUTINE transfer_dbcsr_to_fm(dbcsr_matrix, fm_matrix, para_env, context, mixed_precision) TYPE(cp_dbcsr_type), POINTER :: dbcsr_matrix TYPE(cp_fm_type), POINTER :: fm_matrix TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: context LOGICAL :: mixed_precision - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'transfer_dbcsr_to_fm', & routineP = moduleN//':'//routineN @@ -406,17 +391,17 @@ SUBROUTINE transfer_dbcsr_to_fm(dbcsr_matrix, fm_matrix, para_env, context, mixe NULLIFY(fm_struct_tmp) IF (ASSOCIATED(fm_matrix)) THEN - CALL cp_fm_release(fm_matrix, error=error) + CALL cp_fm_release(fm_matrix) ENDIF CALL cp_dbcsr_get_info(dbcsr_matrix, nfullrows_total=n) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=n, ncol_global=n, & - context=context, para_env=para_env, error=error) - CALL cp_fm_create(fm_matrix, fm_struct_tmp, use_sp=mixed_precision , error=error) - CALL cp_fm_struct_release(fm_struct_tmp, error=error) + context=context, para_env=para_env) + CALL cp_fm_create(fm_matrix, fm_struct_tmp, use_sp=mixed_precision) + CALL cp_fm_struct_release(fm_struct_tmp) - CALL copy_dbcsr_to_fm(dbcsr_matrix, fm_matrix, error=error) - CALL cp_dbcsr_release(dbcsr_matrix, error) + CALL copy_dbcsr_to_fm(dbcsr_matrix, fm_matrix) + CALL cp_dbcsr_release(dbcsr_matrix) DEALLOCATE(dbcsr_matrix) END IF diff --git a/src/preconditioner_types.F b/src/preconditioner_types.F index 9f5f3d2654..c7682e9544 100644 --- a/src/preconditioner_types.F +++ b/src/preconditioner_types.F @@ -82,14 +82,12 @@ FUNCTION preconditioner_in_use(preconditioner) !> \param preconditioner_env ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_preconditioner(preconditioner_env,para_env,blacs_env, error) + SUBROUTINE init_preconditioner(preconditioner_env,para_env,blacs_env) TYPE(preconditioner_type) :: preconditioner_env TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error NULLIFY(preconditioner_env%sparse_matrix) NULLIFY(preconditioner_env%fm) @@ -107,20 +105,18 @@ SUBROUTINE init_preconditioner(preconditioner_env,para_env,blacs_env, error) preconditioner_env%condition_num=-1.0_dp preconditioner_env%ihistory=0 - CALL cp_para_env_retain(preconditioner_env%para_env,error=error) - CALL cp_blacs_env_retain(preconditioner_env%ctxt,error=error) + CALL cp_para_env_retain(preconditioner_env%para_env) + CALL cp_blacs_env_retain(preconditioner_env%ctxt) END SUBROUTINE init_preconditioner ! ***************************************************************************** !> \brief ... !> \param preconditioner_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE destroy_preconditioner(preconditioner_env, error) + SUBROUTINE destroy_preconditioner(preconditioner_env) TYPE(preconditioner_type) :: preconditioner_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'destroy_preconditioner', & routineP = moduleN//':'//routineN @@ -130,21 +126,21 @@ SUBROUTINE destroy_preconditioner(preconditioner_env, error) CALL timeset(routineN,handle) IF (ASSOCIATED(preconditioner_env%sparse_matrix)) THEN - CALL cp_dbcsr_deallocate_matrix(preconditioner_env%sparse_matrix,error=error) + CALL cp_dbcsr_deallocate_matrix(preconditioner_env%sparse_matrix) NULLIFY(preconditioner_env%sparse_matrix) ENDIF IF (ASSOCIATED(preconditioner_env%fm)) THEN - CALL cp_fm_release(preconditioner_env%fm,error=error) + CALL cp_fm_release(preconditioner_env%fm) ENDIF IF (ASSOCIATED(preconditioner_env%dbcsr_matrix)) THEN - CALL cp_dbcsr_release_p (preconditioner_env%dbcsr_matrix, error=error) + CALL cp_dbcsr_release_p (preconditioner_env%dbcsr_matrix) ENDIF IF (ASSOCIATED(preconditioner_env%max_ev_vector)) THEN - CALL cp_dbcsr_release_p (preconditioner_env%max_ev_vector, error=error) + CALL cp_dbcsr_release_p (preconditioner_env%max_ev_vector) ENDIF IF (ASSOCIATED(preconditioner_env%min_ev_vector)) THEN - CALL cp_dbcsr_release_p (preconditioner_env%min_ev_vector, error=error) + CALL cp_dbcsr_release_p (preconditioner_env%min_ev_vector) ENDIF IF (ASSOCIATED(preconditioner_env%occ_evals)) THEN DEALLOCATE(preconditioner_env%occ_evals) @@ -154,12 +150,12 @@ SUBROUTINE destroy_preconditioner(preconditioner_env, error) ENDIF IF (ASSOCIATED(preconditioner_env%inverse_history)) THEN DO i=1,SIZE(preconditioner_env%inverse_history) - CALL cp_dbcsr_release_p (preconditioner_env%inverse_history(i)%matrix, error=error) + CALL cp_dbcsr_release_p (preconditioner_env%inverse_history(i)%matrix) END DO DEALLOCATE(preconditioner_env%inverse_history) ENDIF - CALL cp_para_env_release(preconditioner_env%para_env,error=error) - CALL cp_blacs_env_release(preconditioner_env%ctxt,error=error) + CALL cp_para_env_release(preconditioner_env%para_env) + CALL cp_blacs_env_release(preconditioner_env%ctxt) preconditioner_env%in_use=0 diff --git a/src/pw/cp_linked_list_3d_r.F b/src/pw/cp_linked_list_3d_r.F index 3c1a384e74..edde100bb4 100644 --- a/src/pw/cp_linked_list_3d_r.F +++ b/src/pw/cp_linked_list_3d_r.F @@ -4,8 +4,8 @@ !-----------------------------------------------------------------------------! ! less not much meningful... and defines oly a partial ordering. -#define CP_SLL_R_LESS_Q(el1,el2,error) ( ALL(el1 < el2) ) -#define CP_SLL_R_EQUAL_Q(el1,el2,error) ( ALL(el1 == el2) ) +#define CP_SLL_R_LESS_Q(el1,el2) ( ALL(el1 < el2) ) +#define CP_SLL_R_EQUAL_Q(el1,el2) ( ALL(el1 == el2) ) ! ***************************************************************************** @@ -208,19 +208,16 @@ MODULE cp_linked_list_3d_r !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_3d_r_create(sll,first_el,rest) TYPE(cp_sll_3d_r_type), POINTER :: sll REAL(kind=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: first_el TYPE(cp_sll_3d_r_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_create', & routineP = moduleN//':'//routineN @@ -235,7 +232,7 @@ SUBROUTINE cp_sll_3d_r_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el => first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -246,8 +243,6 @@ END SUBROUTINE cp_sll_3d_r_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -255,14 +250,13 @@ END SUBROUTINE cp_sll_3d_r_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_dealloc(sll,error) + SUBROUTINE cp_sll_3d_r_dealloc(sll) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_3d_r_rm_all_el(sll,error) + CALL cp_sll_3d_r_rm_all_el(sll) END SUBROUTINE cp_sll_3d_r_dealloc ! * low-level * @@ -270,15 +264,12 @@ END SUBROUTINE cp_sll_3d_r_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_dealloc_node(sll,error) + SUBROUTINE cp_sll_3d_r_dealloc_node(sll) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_dealloc_node', & routineP = moduleN//':'//routineN @@ -289,7 +280,7 @@ SUBROUTINE cp_sll_3d_r_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_3d_r_dealloc_node ! ============= get/set ============ @@ -301,19 +292,16 @@ END SUBROUTINE cp_sll_3d_r_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_3d_r_set(sll,first_el,rest) TYPE(cp_sll_3d_r_type), POINTER :: sll REAL(kind=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: first_el TYPE(cp_sll_3d_r_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_set', & routineP = moduleN//':'//routineN @@ -324,9 +312,9 @@ SUBROUTINE cp_sll_3d_r_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_3d_r_create(sll,first_el,rest,error) + CALL cp_sll_3d_r_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el => first_el @@ -341,13 +329,11 @@ END SUBROUTINE cp_sll_3d_r_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_3d_r_get(sll,first_el,rest,empty,length) TYPE(cp_sll_3d_r_type), POINTER :: sll REAL(kind=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: first_el @@ -355,7 +341,6 @@ SUBROUTINE cp_sll_3d_r_get(sll,first_el,rest,empty,length,error) POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_get', & routineP = moduleN//':'//routineN @@ -365,7 +350,7 @@ SUBROUTINE cp_sll_3d_r_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -374,23 +359,20 @@ SUBROUTINE cp_sll_3d_r_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_3d_r_get_length(sll,error=error) + length = cp_sll_3d_r_get_length(sll) END IF END SUBROUTINE cp_sll_3d_r_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_3d_r_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_3d_r_get_first_el(sll) RESULT(res) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: res @@ -402,7 +384,7 @@ FUNCTION cp_sll_3d_r_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res => sll%first_el @@ -413,8 +395,6 @@ END FUNCTION cp_sll_3d_r_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -422,10 +402,9 @@ END FUNCTION cp_sll_3d_r_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_3d_r_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_3d_r_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_3d_r_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_3d_r_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_get_rest', & @@ -448,7 +427,7 @@ FUNCTION cp_sll_3d_r_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -466,16 +445,13 @@ END FUNCTION cp_sll_3d_r_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_3d_r_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_3d_r_get_empty(sll) RESULT(res) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_get_empty', & @@ -487,8 +463,6 @@ END FUNCTION cp_sll_3d_r_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -496,9 +470,8 @@ END FUNCTION cp_sll_3d_r_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_3d_r_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_3d_r_get_length(sll) RESULT(res) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_get_length', & @@ -522,8 +495,6 @@ END FUNCTION cp_sll_3d_r_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -531,10 +502,9 @@ END FUNCTION cp_sll_3d_r_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_3d_r_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_3d_r_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_3d_r_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: res @@ -547,14 +517,14 @@ FUNCTION cp_sll_3d_r_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_3d_r_get_rest(sll, iter=-1,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=-1) ELSE - pos => cp_sll_3d_r_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res => pos%first_el END FUNCTION cp_sll_3d_r_get_el_at @@ -565,20 +535,17 @@ END FUNCTION cp_sll_3d_r_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_3d_r_set_el_at(sll,index,value) TYPE(cp_sll_3d_r_type), POINTER :: sll INTEGER, INTENT(in) :: index REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_set_el_at', & routineP = moduleN//':'//routineN @@ -589,11 +556,11 @@ SUBROUTINE cp_sll_3d_r_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_3d_r_get_rest(sll, iter=-1,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=-1) ELSE - pos => cp_sll_3d_r_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el => value END SUBROUTINE cp_sll_3d_r_set_el_at @@ -605,18 +572,15 @@ END SUBROUTINE cp_sll_3d_r_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_3d_r_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_3d_r_next(iterator,el_att) RESULT(res) TYPE(cp_sll_3d_r_type), POINTER :: iterator REAL(kind=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_next', & @@ -638,19 +602,16 @@ END FUNCTION cp_sll_3d_r_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_insert_el(sll,el,error) + SUBROUTINE cp_sll_3d_r_insert_el(sll,el) TYPE(cp_sll_3d_r_type), POINTER :: sll REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_insert_el', & routineP = moduleN//':'//routineN @@ -660,24 +621,21 @@ SUBROUTINE cp_sll_3d_r_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_3d_r_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_3d_r_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_rm_first_el(sll,error) + SUBROUTINE cp_sll_3d_r_rm_first_el(sll) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_rm_first_el', & routineP = moduleN//':'//routineN @@ -690,12 +648,12 @@ SUBROUTINE cp_sll_3d_r_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_3d_r_dealloc_node(node_to_rm,error=error) + CALL cp_sll_3d_r_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_3d_r_rm_first_el @@ -705,20 +663,17 @@ END SUBROUTINE cp_sll_3d_r_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_3d_r_insert_el_at(sll,el,index) TYPE(cp_sll_3d_r_type), POINTER :: sll REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_insert_el_at', & routineP = moduleN//':'//routineN @@ -729,15 +684,15 @@ SUBROUTINE cp_sll_3d_r_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_3d_r_insert_el(sll,el,error=error) + CALL cp_sll_3d_r_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_3d_r_get_rest(sll, iter=-1,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=-1) ELSE - pos => cp_sll_3d_r_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_3d_r_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_3d_r_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_3d_r_insert_el_at @@ -745,18 +700,15 @@ END SUBROUTINE cp_sll_3d_r_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_3d_r_rm_el_at(sll,index) TYPE(cp_sll_3d_r_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_rm_el_at', & routineP = moduleN//':'//routineN @@ -767,35 +719,32 @@ SUBROUTINE cp_sll_3d_r_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_3d_r_rm_first_el(sll,error=error) + CALL cp_sll_3d_r_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_3d_r_get_rest(sll, iter=-1,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=-1) ELSE - pos => cp_sll_3d_r_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_3d_r_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_3d_r_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_3d_r_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_3d_r_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_3d_r_rm_all_el(sll,error) + SUBROUTINE cp_sll_3d_r_rm_all_el(sll) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_rm_all_el', & routineP = moduleN//':'//routineN @@ -806,7 +755,7 @@ SUBROUTINE cp_sll_3d_r_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_3d_r_dealloc_node(actual_node,error=error) + CALL cp_sll_3d_r_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -816,16 +765,13 @@ END SUBROUTINE cp_sll_3d_r_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_3d_r_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_3d_r_to_array(sll) RESULT(res) TYPE(cp_sll_3d_r_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_3d_r_p_type), DIMENSION(:), & POINTER :: res @@ -838,14 +784,14 @@ FUNCTION cp_sll_3d_r_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_3d_r_get_length(sll,error) + len=cp_sll_3d_r_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i)%array => iter%first_el - IF (.NOT.(cp_sll_3d_r_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_3d_r_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_3d_r_to_array @@ -853,17 +799,14 @@ END FUNCTION cp_sll_3d_r_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_3d_r_from_array(array,error) RESULT(res) +FUNCTION cp_sll_3d_r_from_array(array) RESULT(res) TYPE(cp_3d_r_p_type), DIMENSION(:), & INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_3d_r_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_from_array', & @@ -875,14 +818,12 @@ FUNCTION cp_sll_3d_r_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_3d_r_create(res,& - first_el=array(1)%array,& - error=error) + first_el=array(1)%array) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_3d_r_create(last_el%rest,& - first_el=array(i)%array,& - error=error) + first_el=array(i)%array) last_el => last_el%rest END DO END FUNCTION cp_sll_3d_r_from_array @@ -896,14 +837,12 @@ END FUNCTION cp_sll_3d_r_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_3d_r_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_3d_r_type), POINTER :: sll REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: el @@ -911,7 +850,6 @@ SUBROUTINE cp_sll_3d_r_insert_ordered(sll,el,insert_equals,& LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_3d_r_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_insert_ordered', & routineP = moduleN//':'//routineN @@ -927,13 +865,13 @@ SUBROUTINE cp_sll_3d_r_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_3d_r_create(sll,first_el=el,error=error) + CALL cp_sll_3d_r_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_R_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_R_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_R_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_3d_r_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_R_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_3d_r_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -941,22 +879,22 @@ SUBROUTINE cp_sll_3d_r_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_3d_r_insert_el(iter%rest,el,error=error) + CALL cp_sll_3d_r_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_R_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_R_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_R_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_3d_r_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_R_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_3d_r_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_3d_r_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_3d_r_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_3d_r_insert_ordered @@ -971,14 +909,12 @@ END SUBROUTINE cp_sll_3d_r_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_3d_r_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_3d_r_type), POINTER :: sll REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: el @@ -995,7 +931,6 @@ END FUNCTION compare_function LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_3d_r_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_3d_r_insert_ordered2', & routineP = moduleN//':'//routineN @@ -1012,7 +947,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_3d_r_create(sll,first_el=el,error=error) + CALL cp_sll_3d_r_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1020,7 +955,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_3d_r_insert_el(sll,el,error=error) + CALL cp_sll_3d_r_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1028,7 +963,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_3d_r_insert_el(iter%rest,el,error=error) + CALL cp_sll_3d_r_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1036,15 +971,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_3d_r_insert_el(iter%rest,el,error=error) + CALL cp_sll_3d_r_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_3d_r_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_3d_r_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_3d_r_insert_ordered2 @@ -1061,8 +996,8 @@ END SUBROUTINE cp_sll_3d_r_insert_ordered2 ! common_dir = "../common/" ! defines = ! "! less not much meningful... and defines oly a partial ordering. -! #define CP_SLL_R_LESS_Q(el1,el2,error) ( all(el1 < el2) ) -! #define CP_SLL_R_EQUAL_Q(el1,el2,error) ( all(el1 == el2) ) +! #define CP_SLL_R_LESS_Q(el1,el2) ( all(el1 < el2) ) +! #define CP_SLL_R_EQUAL_Q(el1,el2) ( all(el1 == el2) ) ! " ! equalQ = "CP_SLL_R_EQUAL_Q" ! lessQ = "CP_SLL_R_LESS_Q" diff --git a/src/pw/cp_linked_list_pw.F b/src/pw/cp_linked_list_pw.F index 9babbc2694..9352969096 100644 --- a/src/pw/cp_linked_list_pw.F +++ b/src/pw/cp_linked_list_pw.F @@ -4,8 +4,8 @@ !-----------------------------------------------------------------------------! ! less not much meaningful... -#define CP_SLL_PW_LESS_Q(el1,el2,error) ( el1 %id_nr < el2 %id_nr ) -#define CP_SLL_PW_EQUAL_Q(el1,el2,error) ( el1 %id_nr == el2 %id_nr ) +#define CP_SLL_PW_LESS_Q(el1,el2) ( el1 %id_nr < el2 %id_nr ) +#define CP_SLL_PW_EQUAL_Q(el1,el2) ( el1 %id_nr == el2 %id_nr ) ! ***************************************************************************** @@ -210,17 +210,14 @@ MODULE cp_linked_list_pw !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_pw_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_pw_create(sll,first_el,rest) TYPE(cp_sll_pw_type), POINTER :: sll TYPE(pw_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_pw_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_create', & routineP = moduleN//':'//routineN @@ -235,7 +232,7 @@ SUBROUTINE cp_sll_pw_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el => first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -246,8 +243,6 @@ END SUBROUTINE cp_sll_pw_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -255,14 +250,13 @@ END SUBROUTINE cp_sll_pw_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_pw_dealloc(sll,error) + SUBROUTINE cp_sll_pw_dealloc(sll) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_pw_rm_all_el(sll,error) + CALL cp_sll_pw_rm_all_el(sll) END SUBROUTINE cp_sll_pw_dealloc ! * low-level * @@ -270,15 +264,12 @@ END SUBROUTINE cp_sll_pw_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_pw_dealloc_node(sll,error) + SUBROUTINE cp_sll_pw_dealloc_node(sll) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_dealloc_node', & routineP = moduleN//':'//routineN @@ -289,7 +280,7 @@ SUBROUTINE cp_sll_pw_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_pw_dealloc_node ! ============= get/set ============ @@ -301,17 +292,14 @@ END SUBROUTINE cp_sll_pw_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_pw_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_pw_set(sll,first_el,rest) TYPE(cp_sll_pw_type), POINTER :: sll TYPE(pw_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_pw_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_set', & routineP = moduleN//':'//routineN @@ -322,9 +310,9 @@ SUBROUTINE cp_sll_pw_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_pw_create(sll,first_el,rest,error) + CALL cp_sll_pw_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el => first_el @@ -339,19 +327,16 @@ END SUBROUTINE cp_sll_pw_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_pw_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_pw_get(sll,first_el,rest,empty,length) TYPE(cp_sll_pw_type), POINTER :: sll TYPE(pw_type), OPTIONAL, POINTER :: first_el TYPE(cp_sll_pw_type), OPTIONAL, POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_get', & routineP = moduleN//':'//routineN @@ -361,7 +346,7 @@ SUBROUTINE cp_sll_pw_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -370,23 +355,20 @@ SUBROUTINE cp_sll_pw_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_pw_get_length(sll,error=error) + length = cp_sll_pw_get_length(sll) END IF END SUBROUTINE cp_sll_pw_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_pw_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_pw_get_first_el(sll) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(pw_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_get_first_el', & @@ -397,7 +379,7 @@ FUNCTION cp_sll_pw_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res => sll%first_el @@ -408,8 +390,6 @@ END FUNCTION cp_sll_pw_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -417,10 +397,9 @@ END FUNCTION cp_sll_pw_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_pw_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_pw_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_pw_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_get_rest', & @@ -443,7 +422,7 @@ FUNCTION cp_sll_pw_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -461,16 +440,13 @@ END FUNCTION cp_sll_pw_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_pw_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_pw_get_empty(sll) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_get_empty', & @@ -482,8 +458,6 @@ END FUNCTION cp_sll_pw_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -491,9 +465,8 @@ END FUNCTION cp_sll_pw_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_pw_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_pw_get_length(sll) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_get_length', & @@ -517,8 +490,6 @@ END FUNCTION cp_sll_pw_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -526,10 +497,9 @@ END FUNCTION cp_sll_pw_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_pw_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_pw_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error TYPE(pw_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_get_el_at', & @@ -541,14 +511,14 @@ FUNCTION cp_sll_pw_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_pw_get_rest(sll, iter=-1,error=error) + pos => cp_sll_pw_get_rest(sll, iter=-1) ELSE - pos => cp_sll_pw_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_pw_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res => pos%first_el END FUNCTION cp_sll_pw_get_el_at @@ -559,19 +529,16 @@ END FUNCTION cp_sll_pw_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_pw_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_pw_set_el_at(sll,index,value) TYPE(cp_sll_pw_type), POINTER :: sll INTEGER, INTENT(in) :: index TYPE(pw_type), POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_set_el_at', & routineP = moduleN//':'//routineN @@ -582,11 +549,11 @@ SUBROUTINE cp_sll_pw_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_pw_get_rest(sll, iter=-1,error=error) + pos => cp_sll_pw_get_rest(sll, iter=-1) ELSE - pos => cp_sll_pw_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_pw_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el => value END SUBROUTINE cp_sll_pw_set_el_at @@ -598,17 +565,14 @@ END SUBROUTINE cp_sll_pw_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_pw_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_pw_next(iterator,el_att) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: iterator TYPE(pw_type), OPTIONAL, POINTER :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_next', & @@ -630,18 +594,15 @@ END FUNCTION cp_sll_pw_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_pw_insert_el(sll,el,error) + SUBROUTINE cp_sll_pw_insert_el(sll,el) TYPE(cp_sll_pw_type), POINTER :: sll TYPE(pw_type), POINTER :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_insert_el', & routineP = moduleN//':'//routineN @@ -651,24 +612,21 @@ SUBROUTINE cp_sll_pw_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_pw_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_pw_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_pw_rm_first_el(sll,error) + SUBROUTINE cp_sll_pw_rm_first_el(sll) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_rm_first_el', & routineP = moduleN//':'//routineN @@ -681,12 +639,12 @@ SUBROUTINE cp_sll_pw_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_pw_dealloc_node(node_to_rm,error=error) + CALL cp_sll_pw_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_pw_rm_first_el @@ -696,19 +654,16 @@ END SUBROUTINE cp_sll_pw_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_pw_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_pw_insert_el_at(sll,el,index) TYPE(cp_sll_pw_type), POINTER :: sll TYPE(pw_type), POINTER :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_insert_el_at', & routineP = moduleN//':'//routineN @@ -719,15 +674,15 @@ SUBROUTINE cp_sll_pw_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_pw_insert_el(sll,el,error=error) + CALL cp_sll_pw_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_pw_get_rest(sll, iter=-1,error=error) + pos => cp_sll_pw_get_rest(sll, iter=-1) ELSE - pos => cp_sll_pw_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_pw_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_pw_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_pw_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_pw_insert_el_at @@ -735,18 +690,15 @@ END SUBROUTINE cp_sll_pw_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_pw_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_pw_rm_el_at(sll,index) TYPE(cp_sll_pw_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_rm_el_at', & routineP = moduleN//':'//routineN @@ -757,35 +709,32 @@ SUBROUTINE cp_sll_pw_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_pw_rm_first_el(sll,error=error) + CALL cp_sll_pw_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_pw_get_rest(sll, iter=-1,error=error) + pos => cp_sll_pw_get_rest(sll, iter=-1) ELSE - pos => cp_sll_pw_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_pw_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_pw_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_pw_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_pw_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_pw_rm_all_el(sll,error) + SUBROUTINE cp_sll_pw_rm_all_el(sll) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_rm_all_el', & routineP = moduleN//':'//routineN @@ -796,7 +745,7 @@ SUBROUTINE cp_sll_pw_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_pw_dealloc_node(actual_node,error=error) + CALL cp_sll_pw_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -806,16 +755,13 @@ END SUBROUTINE cp_sll_pw_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_pw_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_pw_to_array(sll) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(pw_p_type), DIMENSION(:), POINTER :: res INTEGER :: i, len, stat @@ -827,14 +773,14 @@ FUNCTION cp_sll_pw_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_pw_get_length(sll,error) + len=cp_sll_pw_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i)%pw => iter%first_el - IF (.NOT.(cp_sll_pw_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_pw_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_pw_to_array @@ -842,17 +788,14 @@ END FUNCTION cp_sll_pw_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_pw_from_array(array,error) RESULT(res) +FUNCTION cp_sll_pw_from_array(array) RESULT(res) TYPE(pw_p_type), DIMENSION(:), & INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_pw_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_from_array', & @@ -864,14 +807,12 @@ FUNCTION cp_sll_pw_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_pw_create(res,& - first_el=array(1)%pw,& - error=error) + first_el=array(1)%pw) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_pw_create(last_el%rest,& - first_el=array(i)%pw,& - error=error) + first_el=array(i)%pw) last_el => last_el%rest END DO END FUNCTION cp_sll_pw_from_array @@ -885,20 +826,17 @@ END FUNCTION cp_sll_pw_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_pw_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_pw_type), POINTER :: sll TYPE(pw_type), POINTER :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_pw_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_insert_ordered', & routineP = moduleN//':'//routineN @@ -914,13 +852,13 @@ SUBROUTINE cp_sll_pw_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_pw_create(sll,first_el=el,error=error) + CALL cp_sll_pw_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_PW_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_PW_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_PW_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_pw_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_PW_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_pw_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -928,22 +866,22 @@ SUBROUTINE cp_sll_pw_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_pw_insert_el(iter%rest,el,error=error) + CALL cp_sll_pw_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_PW_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_PW_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_PW_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_pw_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_PW_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_pw_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_pw_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_pw_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_pw_insert_ordered @@ -958,14 +896,12 @@ END SUBROUTINE cp_sll_pw_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_pw_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_pw_type), POINTER :: sll TYPE(pw_type), POINTER :: el INTERFACE @@ -981,7 +917,6 @@ END FUNCTION compare_function LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_pw_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_pw_insert_ordered2', & routineP = moduleN//':'//routineN @@ -998,7 +933,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_pw_create(sll,first_el=el,error=error) + CALL cp_sll_pw_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1006,7 +941,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_pw_insert_el(sll,el,error=error) + CALL cp_sll_pw_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1014,7 +949,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_pw_insert_el(iter%rest,el,error=error) + CALL cp_sll_pw_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1022,15 +957,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_pw_insert_el(iter%rest,el,error=error) + CALL cp_sll_pw_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_pw_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_pw_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_pw_insert_ordered2 @@ -1048,8 +983,8 @@ END SUBROUTINE cp_sll_pw_insert_ordered2 ! common_dir = "../common" ! defines = ! "! less not much meaningful... -! #define CP_SLL_PW_LESS_Q(el1,el2,error) ( el1 %id_nr < el2 %id_nr ) -! #define CP_SLL_PW_EQUAL_Q(el1,el2,error) ( el1 %id_nr == el2 %id_nr ) +! #define CP_SLL_PW_LESS_Q(el1,el2) ( el1 %id_nr < el2 %id_nr ) +! #define CP_SLL_PW_EQUAL_Q(el1,el2) ( el1 %id_nr == el2 %id_nr ) ! " ! equalQ = "CP_SLL_PW_EQUAL_Q" ! lessQ = "CP_SLL_PW_LESS_Q" diff --git a/src/pw/cp_linked_list_rs.F b/src/pw/cp_linked_list_rs.F index 17c29bc352..3699711f78 100644 --- a/src/pw/cp_linked_list_rs.F +++ b/src/pw/cp_linked_list_rs.F @@ -4,8 +4,8 @@ !-----------------------------------------------------------------------------! ! less not much meningful... -#define CP_SLL_RS_LESS_Q(el1,el2,error) ( el1%id_nr < el2%id_nr ) -#define CP_SLL_RS_EQUAL_Q(el1,el2,error) ( el1%id_nr == el2%id_nr ) +#define CP_SLL_RS_LESS_Q(el1,el2) ( el1%id_nr < el2%id_nr ) +#define CP_SLL_RS_EQUAL_Q(el1,el2) ( el1%id_nr == el2%id_nr ) ! ***************************************************************************** @@ -209,18 +209,15 @@ MODULE cp_linked_list_rs !> \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_rs_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_rs_create(sll,first_el,rest) TYPE(cp_sll_rs_type), POINTER :: sll TYPE(realspace_grid_type), OPTIONAL, & POINTER :: first_el TYPE(cp_sll_rs_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_create', & routineP = moduleN//':'//routineN @@ -235,7 +232,7 @@ SUBROUTINE cp_sll_rs_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el => first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -246,8 +243,6 @@ END SUBROUTINE cp_sll_rs_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -255,14 +250,13 @@ END SUBROUTINE cp_sll_rs_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_rs_dealloc(sll,error) + SUBROUTINE cp_sll_rs_dealloc(sll) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_rs_rm_all_el(sll,error) + CALL cp_sll_rs_rm_all_el(sll) END SUBROUTINE cp_sll_rs_dealloc ! * low-level * @@ -270,15 +264,12 @@ END SUBROUTINE cp_sll_rs_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_rs_dealloc_node(sll,error) + SUBROUTINE cp_sll_rs_dealloc_node(sll) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_dealloc_node', & routineP = moduleN//':'//routineN @@ -289,7 +280,7 @@ SUBROUTINE cp_sll_rs_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_rs_dealloc_node ! ============= get/set ============ @@ -301,18 +292,15 @@ END SUBROUTINE cp_sll_rs_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_rs_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_rs_set(sll,first_el,rest) TYPE(cp_sll_rs_type), POINTER :: sll TYPE(realspace_grid_type), OPTIONAL, & POINTER :: first_el TYPE(cp_sll_rs_type), OPTIONAL, POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_set', & routineP = moduleN//':'//routineN @@ -323,9 +311,9 @@ SUBROUTINE cp_sll_rs_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_rs_create(sll,first_el,rest,error) + CALL cp_sll_rs_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el => first_el @@ -340,20 +328,17 @@ END SUBROUTINE cp_sll_rs_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_rs_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_rs_get(sll,first_el,rest,empty,length) TYPE(cp_sll_rs_type), POINTER :: sll TYPE(realspace_grid_type), OPTIONAL, & POINTER :: first_el TYPE(cp_sll_rs_type), OPTIONAL, POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_get', & routineP = moduleN//':'//routineN @@ -363,7 +348,7 @@ SUBROUTINE cp_sll_rs_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -372,23 +357,20 @@ SUBROUTINE cp_sll_rs_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_rs_get_length(sll,error=error) + length = cp_sll_rs_get_length(sll) END IF END SUBROUTINE cp_sll_rs_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_rs_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_rs_get_first_el(sll) RESULT(res) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(realspace_grid_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_get_first_el', & @@ -399,7 +381,7 @@ FUNCTION cp_sll_rs_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res => sll%first_el @@ -410,8 +392,6 @@ END FUNCTION cp_sll_rs_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -419,10 +399,9 @@ END FUNCTION cp_sll_rs_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_rs_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_rs_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_rs_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_rs_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_get_rest', & @@ -445,7 +424,7 @@ FUNCTION cp_sll_rs_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -463,16 +442,13 @@ END FUNCTION cp_sll_rs_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_rs_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_rs_get_empty(sll) RESULT(res) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_get_empty', & @@ -484,8 +460,6 @@ END FUNCTION cp_sll_rs_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -493,9 +467,8 @@ END FUNCTION cp_sll_rs_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_rs_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_rs_get_length(sll) RESULT(res) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_get_length', & @@ -519,8 +492,6 @@ END FUNCTION cp_sll_rs_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -528,10 +499,9 @@ END FUNCTION cp_sll_rs_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_rs_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_rs_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_rs_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error TYPE(realspace_grid_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_get_el_at', & @@ -543,14 +513,14 @@ FUNCTION cp_sll_rs_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_rs_get_rest(sll, iter=-1,error=error) + pos => cp_sll_rs_get_rest(sll, iter=-1) ELSE - pos => cp_sll_rs_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_rs_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res => pos%first_el END FUNCTION cp_sll_rs_get_el_at @@ -561,19 +531,16 @@ END FUNCTION cp_sll_rs_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_rs_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_rs_set_el_at(sll,index,value) TYPE(cp_sll_rs_type), POINTER :: sll INTEGER, INTENT(in) :: index TYPE(realspace_grid_type), POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_set_el_at', & routineP = moduleN//':'//routineN @@ -584,11 +551,11 @@ SUBROUTINE cp_sll_rs_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_rs_get_rest(sll, iter=-1,error=error) + pos => cp_sll_rs_get_rest(sll, iter=-1) ELSE - pos => cp_sll_rs_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_rs_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el => value END SUBROUTINE cp_sll_rs_set_el_at @@ -600,18 +567,15 @@ END SUBROUTINE cp_sll_rs_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_rs_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_rs_next(iterator,el_att) RESULT(res) TYPE(cp_sll_rs_type), POINTER :: iterator TYPE(realspace_grid_type), OPTIONAL, & POINTER :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_next', & @@ -633,18 +597,15 @@ END FUNCTION cp_sll_rs_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_rs_insert_el(sll,el,error) + SUBROUTINE cp_sll_rs_insert_el(sll,el) TYPE(cp_sll_rs_type), POINTER :: sll TYPE(realspace_grid_type), POINTER :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_insert_el', & routineP = moduleN//':'//routineN @@ -654,24 +615,21 @@ SUBROUTINE cp_sll_rs_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_rs_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_rs_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_rs_rm_first_el(sll,error) + SUBROUTINE cp_sll_rs_rm_first_el(sll) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_rm_first_el', & routineP = moduleN//':'//routineN @@ -684,12 +642,12 @@ SUBROUTINE cp_sll_rs_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_rs_dealloc_node(node_to_rm,error=error) + CALL cp_sll_rs_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_rs_rm_first_el @@ -699,19 +657,16 @@ END SUBROUTINE cp_sll_rs_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_rs_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_rs_insert_el_at(sll,el,index) TYPE(cp_sll_rs_type), POINTER :: sll TYPE(realspace_grid_type), POINTER :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_insert_el_at', & routineP = moduleN//':'//routineN @@ -722,15 +677,15 @@ SUBROUTINE cp_sll_rs_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_rs_insert_el(sll,el,error=error) + CALL cp_sll_rs_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_rs_get_rest(sll, iter=-1,error=error) + pos => cp_sll_rs_get_rest(sll, iter=-1) ELSE - pos => cp_sll_rs_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_rs_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_rs_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_rs_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_rs_insert_el_at @@ -738,18 +693,15 @@ END SUBROUTINE cp_sll_rs_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_rs_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_rs_rm_el_at(sll,index) TYPE(cp_sll_rs_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_rm_el_at', & routineP = moduleN//':'//routineN @@ -760,35 +712,32 @@ SUBROUTINE cp_sll_rs_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_rs_rm_first_el(sll,error=error) + CALL cp_sll_rs_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_rs_get_rest(sll, iter=-1,error=error) + pos => cp_sll_rs_get_rest(sll, iter=-1) ELSE - pos => cp_sll_rs_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_rs_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_rs_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_rs_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_rs_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_rs_rm_all_el(sll,error) + SUBROUTINE cp_sll_rs_rm_all_el(sll) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_rm_all_el', & routineP = moduleN//':'//routineN @@ -799,7 +748,7 @@ SUBROUTINE cp_sll_rs_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_rs_dealloc_node(actual_node,error=error) + CALL cp_sll_rs_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -809,16 +758,13 @@ END SUBROUTINE cp_sll_rs_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_rs_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_rs_to_array(sll) RESULT(res) TYPE(cp_sll_rs_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(realspace_grid_p_type), & DIMENSION(:), POINTER :: res @@ -831,14 +777,14 @@ FUNCTION cp_sll_rs_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_rs_get_length(sll,error) + len=cp_sll_rs_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i)%rs_grid => iter%first_el - IF (.NOT.(cp_sll_rs_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_rs_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_rs_to_array @@ -846,17 +792,14 @@ END FUNCTION cp_sll_rs_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_rs_from_array(array,error) RESULT(res) +FUNCTION cp_sll_rs_from_array(array) RESULT(res) TYPE(realspace_grid_p_type), & DIMENSION(:), INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_rs_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_from_array', & @@ -868,14 +811,12 @@ FUNCTION cp_sll_rs_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_rs_create(res,& - first_el=array(1)%rs_grid,& - error=error) + first_el=array(1)%rs_grid) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_rs_create(last_el%rest,& - first_el=array(i)%rs_grid,& - error=error) + first_el=array(i)%rs_grid) last_el => last_el%rest END DO END FUNCTION cp_sll_rs_from_array @@ -889,20 +830,17 @@ END FUNCTION cp_sll_rs_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_rs_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_rs_type), POINTER :: sll TYPE(realspace_grid_type), POINTER :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_rs_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_insert_ordered', & routineP = moduleN//':'//routineN @@ -918,13 +856,13 @@ SUBROUTINE cp_sll_rs_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_rs_create(sll,first_el=el,error=error) + CALL cp_sll_rs_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.CP_SLL_RS_LESS_Q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_RS_LESS_Q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.CP_SLL_RS_LESS_Q(el,sll%first_el,error=error)) THEN - CALL cp_sll_rs_insert_el(sll,el,error=error) + IF (i_eq.OR.CP_SLL_RS_LESS_Q(el,sll%first_el)) THEN + CALL cp_sll_rs_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -932,22 +870,22 @@ SUBROUTINE cp_sll_rs_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_rs_insert_el(iter%rest,el,error=error) + CALL cp_sll_rs_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.CP_SLL_RS_LESS_Q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.CP_SLL_RS_LESS_Q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. CP_SLL_RS_LESS_Q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_rs_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. CP_SLL_RS_LESS_Q(el,iter%rest%first_el)) THEN + CALL cp_sll_rs_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_rs_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_rs_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_rs_insert_ordered @@ -962,14 +900,12 @@ END SUBROUTINE cp_sll_rs_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_rs_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_rs_type), POINTER :: sll TYPE(realspace_grid_type), POINTER :: el INTERFACE @@ -984,7 +920,6 @@ END FUNCTION compare_function LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_rs_type), OPTIONAL, POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_rs_insert_ordered2', & routineP = moduleN//':'//routineN @@ -1001,7 +936,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_rs_create(sll,first_el=el,error=error) + CALL cp_sll_rs_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1009,7 +944,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_rs_insert_el(sll,el,error=error) + CALL cp_sll_rs_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1017,7 +952,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_rs_insert_el(iter%rest,el,error=error) + CALL cp_sll_rs_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1025,15 +960,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_rs_insert_el(iter%rest,el,error=error) + CALL cp_sll_rs_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_rs_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_rs_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_rs_insert_ordered2 @@ -1050,8 +985,8 @@ END SUBROUTINE cp_sll_rs_insert_ordered2 ! common_dir = "../common" ! defines = ! "! less not much meningful... -! #define CP_SLL_RS_LESS_Q(el1,el2,error) ( el1%id_nr < el2%id_nr ) -! #define CP_SLL_RS_EQUAL_Q(el1,el2,error) ( el1%id_nr == el2%id_nr ) +! #define CP_SLL_RS_LESS_Q(el1,el2) ( el1%id_nr < el2%id_nr ) +! #define CP_SLL_RS_EQUAL_Q(el1,el2) ( el1%id_nr == el2%id_nr ) ! " ! equalQ = "CP_SLL_RS_EQUAL_Q" ! lessQ = "CP_SLL_RS_LESS_Q" diff --git a/src/pw/dct.F b/src/pw/dct.F index 9b4809df05..1abbed4198 100644 --- a/src/pw/dct.F +++ b/src/pw/dct.F @@ -78,16 +78,14 @@ MODULE dct !> \brief Initializes a dct_type !> \param pw_grid the original plane wave grid !> \param dct_env dct_type to be initialized -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dct_type_init(pw_grid, dct_env, error) + SUBROUTINE dct_type_init(pw_grid, dct_env) TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid TYPE(dct_type), INTENT(INOUT) :: dct_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dct_type_init', & routineP = moduleN//':'//routineN @@ -98,12 +96,12 @@ SUBROUTINE dct_type_init(pw_grid, dct_env, error) CALL get_dests_srcs_pid(pw_grid, & dct_env%dests_expand, dct_env%srcs_expand, dct_env%flipg_stat, & - dct_env%dests_shrink, dct_env%srcs_shrink, error) + dct_env%dests_shrink, dct_env%srcs_shrink) CALL expansion_bounds(pw_grid, & dct_env%srcs_expand, dct_env%flipg_stat, & dct_env%bounds_shftd, dct_env%bounds_local_shftd, & dct_env%recv_msgs_bnds, dct_env%dct_bounds, & - dct_env%dct_bounds_local, error) + dct_env%dct_bounds_local) CALL timestop(handle) @@ -117,18 +115,16 @@ END SUBROUTINE dct_type_init !> \param dct_pw_grid DCT plane-wave grid !> \param dct_aux_pw_grid auxiliary DCT plane-wave grid (i.e an expanded pw grid !> whose local bounds are decided internally by cp2k) -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE setup_dct_pw_grids(pw_grid, cell_hmat, dct_pw_grid, dct_aux_pw_grid, error) + SUBROUTINE setup_dct_pw_grids(pw_grid, cell_hmat, dct_pw_grid, dct_aux_pw_grid) TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid REAL(dp), DIMENSION(3, 3), INTENT(IN) :: cell_hmat TYPE(pw_grid_type), INTENT(INOUT), & POINTER :: dct_pw_grid, dct_aux_pw_grid - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_dct_pw_grids', & routineP = moduleN//':'//routineN @@ -144,11 +140,11 @@ SUBROUTINE setup_dct_pw_grids(pw_grid, cell_hmat, dct_pw_grid, dct_aux_pw_grid, CALL timeset(routineN,handle) - CALL get_dests_srcs_pid(pw_grid, dests_expand, srcs_expand, flipg_stat, dests_shrink, srcs_shrink, error) + CALL get_dests_srcs_pid(pw_grid, dests_expand, srcs_expand, flipg_stat, dests_shrink, srcs_shrink) CALL expansion_bounds(pw_grid, srcs_expand, flipg_stat, bounds_shftd, bounds_local_shftd, & - recv_msgs_bnds, bounds_new, bounds_local_new, error) - CALL pw_grid_create(dct_pw_grid, pw_grid%para%rs_group, local=.FALSE., error=error) - CALL pw_grid_create(dct_aux_pw_grid, pw_grid%para%rs_group, local=.FALSE., error=error) + recv_msgs_bnds, bounds_new, bounds_local_new) + CALL pw_grid_create(dct_pw_grid, pw_grid%para%rs_group, local=.FALSE.) + CALL pw_grid_create(dct_aux_pw_grid, pw_grid%para%rs_group, local=.FALSE.) hmat2 = 0.0_dp hmat2(1,1) = 2*(cell_hmat(1,1) - pw_grid%dr(1)) @@ -168,14 +164,12 @@ SUBROUTINE setup_dct_pw_grids(pw_grid, cell_hmat, dct_pw_grid, dct_aux_pw_grid, bounds=bounds_new, & rs_dims = pw_grid%para%rs_dims, & blocked = blocked, & - bounds_local=bounds_local_new, & - error=error) + bounds_local=bounds_local_new) CALL pw_grid_setup(hmat2, dct_aux_pw_grid, & bounds=bounds_new, & rs_dims = pw_grid%para%rs_dims, & - blocked = blocked, & - error=error) + blocked = blocked) CALL timestop(handle) @@ -190,19 +184,17 @@ END SUBROUTINE setup_dct_pw_grids !> \param flipg_stat flipping status for the received data chunks (pw_expand) !> \param dests_shrink list of the destination processes (pw_shrink) !> \param srcs_shrink list of the source proceses (pw_shrink) -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE get_dests_srcs_pid(pw_grid, dests_expand, srcs_expand, flipg_stat, & - dests_shrink, srcs_shrink, error) + dests_shrink, srcs_shrink) TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid INTEGER, DIMENSION(4), INTENT(OUT) :: dests_expand, srcs_expand, & flipg_stat, dests_shrink INTEGER, INTENT(OUT) :: srcs_shrink - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_dests_srcs_pid', & routineP = moduleN//':'//routineN @@ -364,13 +356,12 @@ END SUBROUTINE get_dests_srcs_pid !> \param bounds_shftd bounds of the original grid shifted to have g0 in the middle of the cell !> \param pw_in the original plane wave data !> \param pw_expanded the pw data after expansion -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, bounds_shftd, & - pw_in, pw_expanded, error) + pw_in, pw_expanded) INTEGER, DIMENSION(2, 3, 4), INTENT(IN) :: recv_msgs_bnds INTEGER, DIMENSION(4), INTENT(IN) :: dests_expand, srcs_expand, & @@ -378,7 +369,6 @@ SUBROUTINE pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, boun INTEGER, DIMENSION(2, 3), INTENT(IN) :: bounds_shftd TYPE(pw_type), INTENT(IN), POINTER :: pw_in TYPE(pw_type), INTENT(INOUT), POINTER :: pw_expanded - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_expand', & routineP = moduleN//':'//routineN @@ -465,13 +455,13 @@ SUBROUTINE pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, boun ALLOCATE(pcs(i)%msg(lb1:ub1, lb2:ub2, lb3:ub3)) pcs(i)%msg = recv_msgs(i)%msg CASE(UD_FLIPPED) - CALL flipud(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd, error) + CALL flipud(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd) CASE(LR_FLIPPED) - CALL fliplr(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd, error) + CALL fliplr(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd) CASE(BF_FLIPPED) - CALL flipbf(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd, error) + CALL flipbf(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd) CASE(ROTATED) - CALL rot180(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd, error) + CALL rot180(recv_msgs(i)%msg, pcs(i)%msg, bounds_shftd) END SELECT END DO ! concatenate the received (flipped) data store the result as catd @@ -497,7 +487,7 @@ SUBROUTINE pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, boun END DO ! flip catd from back to front - CALL flipbf(catd, catd_flipdbf, bounds_shftd, error) + CALL flipbf(catd, catd_flipdbf, bounds_shftd) ! concatenate catd and catd_flipdbf to get cr3d_xpndd ALLOCATE(cr3d_xpndd(lb1_new:ub1_new, lb2_new:ub2_new, lb3_new:ub3_new)) cr3d_xpndd(:,:,lb3_new:ind) = catd @@ -524,20 +514,18 @@ END SUBROUTINE pw_expand !> \param bounds_local_shftd local bounds of the original grid after shifting !> \param pw_in the original plane wave data !> \param pw_shrinked the shrinked plane wave data -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, & - pw_in, pw_shrinked, error) + pw_in, pw_shrinked) INTEGER, DIMENSION(4), INTENT(IN) :: dests_shrink INTEGER, INTENT(IN) :: srcs_shrink INTEGER, DIMENSION(2, 3), INTENT(IN) :: bounds_local_shftd TYPE(pw_type), INTENT(IN), POINTER :: pw_in TYPE(pw_type), INTENT(INOUT), POINTER :: pw_shrinked - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_shrink', & routineP = moduleN//':'//routineN @@ -641,20 +629,17 @@ END SUBROUTINE pw_shrink !> \param cr3d_in input array !> \param cr3d_out output array !> \param bounds the bounds of the output array -!> \param error cp2k error -!> !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE flipud(cr3d_in, cr3d_out, bounds, error) + SUBROUTINE flipud(cr3d_in, cr3d_out, bounds) REAL(dp), DIMENSION(:, :, :), & INTENT(IN), POINTER :: cr3d_in REAL(dp), DIMENSION(:, :, :), & INTENT(OUT), POINTER :: cr3d_out INTEGER, DIMENSION(2, 3), INTENT(IN) :: bounds - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'flipud', & routineP = moduleN//':'//routineN @@ -699,20 +684,17 @@ END SUBROUTINE flipud !> \param cr3d_in input array !> \param cr3d_out output array !> \param bounds the bounds of the output array -!> \param error cp2k error -!> !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE fliplr(cr3d_in, cr3d_out, bounds, error) + SUBROUTINE fliplr(cr3d_in, cr3d_out, bounds) REAL(dp), DIMENSION(:, :, :), & INTENT(IN), POINTER :: cr3d_in REAL(dp), DIMENSION(:, :, :), & INTENT(OUT), POINTER :: cr3d_out INTEGER, DIMENSION(2, 3), INTENT(IN) :: bounds - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fliplr', & routineP = moduleN//':'//routineN @@ -756,20 +738,17 @@ END SUBROUTINE fliplr !> \param cr3d_in input array !> \param cr3d_out output array !> \param bounds the bounds of the output array -!> \param error cp2k error -!> !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE flipbf(cr3d_in, cr3d_out, bounds, error) + SUBROUTINE flipbf(cr3d_in, cr3d_out, bounds) REAL(dp), DIMENSION(:, :, :), & INTENT(IN), POINTER :: cr3d_in REAL(dp), DIMENSION(:, :, :), & INTENT(OUT), POINTER :: cr3d_out INTEGER, DIMENSION(2, 3), INTENT(IN) :: bounds - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'flipbf', & routineP = moduleN//':'//routineN @@ -813,20 +792,17 @@ END SUBROUTINE flipbf !> \param cr3d_in input array !> \param cr3d_out output array !> \param bounds the bounds of the output array -!> \param error cp2k error -!> !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE rot180(cr3d_in, cr3d_out, bounds, error) + SUBROUTINE rot180(cr3d_in, cr3d_out, bounds) REAL(dp), DIMENSION(:, :, :), & INTENT(IN), POINTER :: cr3d_in REAL(dp), DIMENSION(:, :, :), & INTENT(OUT), POINTER :: cr3d_out INTEGER, DIMENSION(2, 3), INTENT(IN) :: bounds - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rot180', & routineP = moduleN//':'//routineN @@ -876,14 +852,13 @@ END SUBROUTINE rot180 !> \param recv_msgs_bnds bounds of the messages to be received (pw_expand) !> \param bounds_new new global lower and upper bounds !> \param bounds_local_new new local lower and upper bounds -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE expansion_bounds(pw_grid, srcs_expand, flipg_stat, & bounds_shftd, bounds_local_shftd, & - recv_msgs_bnds, bounds_new, bounds_local_new, error) + recv_msgs_bnds, bounds_new, bounds_local_new) TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid INTEGER, DIMENSION(4), INTENT(IN) :: srcs_expand, flipg_stat @@ -891,7 +866,6 @@ SUBROUTINE expansion_bounds(pw_grid, srcs_expand, flipg_stat, & bounds_local_shftd INTEGER, DIMENSION(2, 3, 4), INTENT(OUT) :: recv_msgs_bnds INTEGER, DIMENSION(2, 3), INTENT(OUT) :: bounds_new, bounds_local_new - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'expansion_bounds', & routineP = moduleN//':'//routineN @@ -1152,16 +1126,14 @@ END FUNCTION rot180_bounds_local !> \brief Copies pw_old to pw_new that has different local bounds. !> \param pw_old input pw data !> \param pw_new output pw data -!> \param error cp2k error !> \par History !> 12.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE pw_adjust_bounds_local(pw_old, pw_new, error) + SUBROUTINE pw_adjust_bounds_local(pw_old, pw_new) TYPE(pw_type), INTENT(IN), POINTER :: pw_old TYPE(pw_type), INTENT(INOUT), POINTER :: pw_new - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_adjust_bounds_local', & routineP = moduleN//':'//routineN @@ -1229,19 +1201,19 @@ SUBROUTINE pw_adjust_bounds_local(pw_old, pw_new, error) ! sweep edge data CALL dim1_sweep(pw_old%cr3d, bounds_local_new(:,1), wnbr_pid, enbr_pid, & - rs_group, color, e_rmsg, w_rmsg, dim1swp_stat, error) + rs_group, color, e_rmsg, w_rmsg, dim1swp_stat) CALL dim2_sweep(pw_old%cr3d, bounds_local_new(:,2), nnbr_pid, snbr_pid, & - rs_group, color, n_rmsg, s_rmsg, dim2swp_stat, error) + rs_group, color, n_rmsg, s_rmsg, dim2swp_stat) ! sweep corner data IF (dim1swp_stat(1) .NE. nomsg_received) THEN CALL dim2_sweep(w_rmsg, bounds_local_new(:,2), nnbr_pid, snbr_pid, & - rs_group, color, nw_rmsg, sw_rmsg, wdim2swp_stat, error) + rs_group, color, nw_rmsg, sw_rmsg, wdim2swp_stat) ELSE wdim2swp_stat = nomsg_received END IF IF (dim1swp_stat(2) .NE. nomsg_received) THEN CALL dim2_sweep(e_rmsg, bounds_local_new(:,2), nnbr_pid, snbr_pid, & - rs_group, color, ne_rmsg, se_rmsg, edim2swp_stat, error) + rs_group, color, ne_rmsg, se_rmsg, edim2swp_stat) ELSE edim2swp_stat = nomsg_received END IF @@ -1316,13 +1288,12 @@ END SUBROUTINE pw_adjust_bounds_local !> \param e_rmsg received message from the east neighbor !> \param w_rmsg received message from the west neighbor !> \param sweep_stat sweeping status -!> \param error cp2k error !> \par History !> 12.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE dim1_sweep(arr3d_old, dim1blcl_new, wnbr_pid, enbr_pid, & - mp_group, color, e_rmsg, w_rmsg, sweep_stat, error) + mp_group, color, e_rmsg, w_rmsg, sweep_stat) REAL(dp), DIMENSION(:, :, :), & INTENT(IN), POINTER :: arr3d_old @@ -1332,7 +1303,6 @@ SUBROUTINE dim1_sweep(arr3d_old, dim1blcl_new, wnbr_pid, enbr_pid, & REAL(dp), DIMENSION(:, :, :), & INTENT(OUT), POINTER :: e_rmsg, w_rmsg INTEGER, DIMENSION(2), INTENT(OUT) :: sweep_stat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dim1_sweep', & routineP = moduleN//':'//routineN @@ -1462,13 +1432,12 @@ END SUBROUTINE dim1_sweep !> \param n_rmsg received message from the north neighbor !> \param s_rmsg received message from the south neighbor !> \param sweep_stat data sweeping status -!> \param error cp2k error !> \par History !> 12.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE dim2_sweep(arr3d_old, dim2blcl_new, nnbr_pid, snbr_pid, & - mp_group, color, n_rmsg, s_rmsg, sweep_stat, error) + mp_group, color, n_rmsg, s_rmsg, sweep_stat) REAL(dp), DIMENSION(:, :, :), & INTENT(IN), POINTER :: arr3d_old @@ -1478,7 +1447,6 @@ SUBROUTINE dim2_sweep(arr3d_old, dim2blcl_new, nnbr_pid, snbr_pid, & REAL(dp), DIMENSION(:, :, :), & INTENT(OUT), POINTER :: n_rmsg, s_rmsg INTEGER, DIMENSION(2), INTENT(OUT) :: sweep_stat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dim2_sweep', & routineP = moduleN//':'//routineN diff --git a/src/pw/dg_rho0_types.F b/src/pw/dg_rho0_types.F index b3d6780fe7..5851873b8a 100644 --- a/src/pw/dg_rho0_types.F +++ b/src/pw/dg_rho0_types.F @@ -122,12 +122,10 @@ END SUBROUTINE dg_rho0_get ! ***************************************************************************** !> \brief create the dg_rho0 structure !> \param dg_rho0 ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE dg_rho0_create ( dg_rho0, error ) + SUBROUTINE dg_rho0_create ( dg_rho0) TYPE(dg_rho0_type), POINTER :: dg_rho0 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dg_rho0_create', & routineP = moduleN//':'//routineN @@ -135,7 +133,7 @@ SUBROUTINE dg_rho0_create ( dg_rho0, error ) INTEGER :: istat ALLOCATE ( dg_rho0, stat=istat ) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) NULLIFY ( dg_rho0 % gcc ) NULLIFY ( dg_rho0 % zet ) dg_rho0 % cutoff_radius = 0.0_dp @@ -152,17 +150,14 @@ END SUBROUTINE dg_rho0_create ! ***************************************************************************** !> \brief retains the given dg_rho0_type !> \param dg_rho0 the dg_rho0_type to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE dg_rho0_retain ( dg_rho0, error) + SUBROUTINE dg_rho0_retain ( dg_rho0) TYPE(dg_rho0_type), POINTER :: dg_rho0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dg_rho0_retain', & routineP = moduleN//':'//routineN @@ -171,25 +166,22 @@ SUBROUTINE dg_rho0_retain ( dg_rho0, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(dg_rho0),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(dg_rho0%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(dg_rho0),cp_failure_level,routineP,failure) + CPPreconditionNoFail(dg_rho0%ref_count>0,cp_failure_level,routineP) dg_rho0%ref_count=dg_rho0%ref_count+1 END SUBROUTINE dg_rho0_retain ! ***************************************************************************** !> \brief releases the given dg_rho0_type !> \param dg_rho0 the dg_rho0_type to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE dg_rho0_release(dg_rho0, error) + SUBROUTINE dg_rho0_release(dg_rho0) TYPE(dg_rho0_type), POINTER :: dg_rho0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dg_rho0_release', & routineP = moduleN//':'//routineN @@ -200,22 +192,22 @@ SUBROUTINE dg_rho0_release(dg_rho0, error) failure=.FALSE. IF (ASSOCIATED(dg_rho0)) THEN - CPPreconditionNoFail(dg_rho0%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(dg_rho0%ref_count>0,cp_failure_level,routineP) dg_rho0%ref_count=dg_rho0%ref_count-1 IF (dg_rho0%ref_count==0) THEN IF ( ASSOCIATED ( dg_rho0 % gcc ) ) THEN DEALLOCATE ( dg_rho0 % gcc, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( dg_rho0 % zet ) ) THEN DEALLOCATE ( dg_rho0 % zet, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF - CALL pw_release ( dg_rho0 % density % pw ,error=error) + CALL pw_release ( dg_rho0 % density % pw) NULLIFY ( dg_rho0 % gcc ) NULLIFY ( dg_rho0 % zet ) DEALLOCATE ( dg_rho0 , stat = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(dg_rho0) @@ -225,24 +217,22 @@ END SUBROUTINE dg_rho0_release !> \brief ... !> \param dg_rho0 ... !> \param pw_grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dg_rho0_init ( dg_rho0, pw_grid, error ) + SUBROUTINE dg_rho0_init ( dg_rho0, pw_grid) TYPE(dg_rho0_type), POINTER :: dg_rho0 TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dg_rho0_init', & routineP = moduleN//':'//routineN - CALL pw_release ( dg_rho0 % density % pw ,error=error) + CALL pw_release ( dg_rho0 % density % pw) SELECT CASE ( dg_rho0 % type ) CASE ( do_ewald_ewald ) - CALL pw_create ( dg_rho0 % density % pw, pw_grid, REALDATA3D ,error=error) - CALL dg_rho0_pme_gauss ( dg_rho0 % density, dg_rho0 % zet ( 1 ),error=error) + CALL pw_create ( dg_rho0 % density % pw, pw_grid, REALDATA3D) + CALL dg_rho0_pme_gauss ( dg_rho0 % density, dg_rho0 % zet ( 1 )) CASE ( do_ewald_pme ) - CALL pw_create ( dg_rho0 % density % pw, pw_grid, REALDATA3D ,error=error) - CALL dg_rho0_pme_gauss ( dg_rho0 % density, dg_rho0 % zet ( 1 ),error=error) + CALL pw_create ( dg_rho0 % density % pw, pw_grid, REALDATA3D) + CALL dg_rho0_pme_gauss ( dg_rho0 % density, dg_rho0 % zet ( 1 )) CASE ( do_ewald_spme ) CALL stop_program(routineN,moduleN,__LINE__,'SPME type not implemented') END SELECT @@ -253,13 +243,11 @@ END SUBROUTINE dg_rho0_init !> \brief ... !> \param dg_rho0 ... !> \param alpha ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dg_rho0_pme_gauss ( dg_rho0, alpha, error) + SUBROUTINE dg_rho0_pme_gauss ( dg_rho0, alpha) TYPE(pw_p_type), INTENT(INOUT) :: dg_rho0 REAL(KIND=dp), INTENT(IN) :: alpha - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dg_rho0_pme_gauss', & routineP = moduleN//':'//routineN @@ -297,7 +285,7 @@ SUBROUTINE dg_rho0_pme_gauss ( dg_rho0, alpha, error) n0 = bds ( 1, 3 ) END IF - CALL pw_zero ( dg_rho0%pw,error=error) + CALL pw_zero ( dg_rho0%pw) rho0 => dg_rho0 % pw % cr3d diff --git a/src/pw/dg_types.F b/src/pw/dg_types.F index daf432816c..b6edf3c722 100644 --- a/src/pw/dg_types.F +++ b/src/pw/dg_types.F @@ -66,12 +66,10 @@ END SUBROUTINE dg_get ! ***************************************************************************** !> \brief create the dg structure !> \param dg ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE dg_create ( dg, error ) + SUBROUTINE dg_create ( dg) TYPE(dg_type), POINTER :: dg - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dg_create', & routineP = moduleN//':'//routineN @@ -80,9 +78,9 @@ SUBROUTINE dg_create ( dg, error ) TYPE(dg_rho0_type), POINTER :: dg_rho0 ALLOCATE ( dg, stat=istat ) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) NULLIFY ( dg_rho0 ) - CALL dg_rho0_create ( dg_rho0, error ) + CALL dg_rho0_create ( dg_rho0) dg % dg_rho0 => dg_rho0 last_dg_id=last_dg_id+1 dg%id_nr=last_dg_id @@ -93,17 +91,14 @@ END SUBROUTINE dg_create ! ***************************************************************************** !> \brief retains the given dg_type !> \param dg the dg_type to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE dg_retain ( dg, error) + SUBROUTINE dg_retain ( dg) TYPE(dg_type), POINTER :: dg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dg_retain', & routineP = moduleN//':'//routineN @@ -112,25 +107,22 @@ SUBROUTINE dg_retain ( dg, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(dg),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(dg%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(dg),cp_failure_level,routineP,failure) + CPPreconditionNoFail(dg%ref_count>0,cp_failure_level,routineP) dg%ref_count=dg%ref_count+1 END SUBROUTINE dg_retain ! ***************************************************************************** !> \brief releases the given dg_type !> \param dg the dg_type to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE dg_release(dg, error) + SUBROUTINE dg_release(dg) TYPE(dg_type), POINTER :: dg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dg_release', & routineP = moduleN//':'//routineN @@ -141,12 +133,12 @@ SUBROUTINE dg_release(dg, error) failure=.FALSE. IF (ASSOCIATED(dg)) THEN - CPPreconditionNoFail(dg%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(dg%ref_count>0,cp_failure_level,routineP) dg%ref_count=dg%ref_count-1 IF (dg%ref_count==0) THEN - CALL dg_rho0_release ( dg % dg_rho0, error = error ) + CALL dg_rho0_release ( dg % dg_rho0) DEALLOCATE ( dg, stat = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(dg) @@ -157,21 +149,19 @@ END SUBROUTINE dg_release !> \param dg ... !> \param dg_rho0 ... !> \param grid_index ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE dg_set ( dg, dg_rho0, grid_index, error ) + SUBROUTINE dg_set ( dg, dg_rho0, grid_index) TYPE(dg_type), POINTER :: dg TYPE(dg_rho0_type), OPTIONAL, POINTER :: dg_rho0 INTEGER, OPTIONAL :: grid_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dg_set', & routineP = moduleN//':'//routineN IF ( PRESENT ( dg_rho0 ) ) THEN - CALL dg_rho0_retain ( dg_rho0 ,error=error) - CALL dg_rho0_release ( dg % dg_rho0 ,error=error) + CALL dg_rho0_retain ( dg_rho0) + CALL dg_rho0_release ( dg % dg_rho0) dg % dg_rho0 => dg_rho0 END IF IF ( PRESENT ( grid_index ) ) dg % grid_index = grid_index diff --git a/src/pw/dgs.F b/src/pw/dgs.F index f3f6fb289c..84b9666dd9 100644 --- a/src/pw/dgs.F +++ b/src/pw/dgs.F @@ -91,10 +91,9 @@ MODULE dgs !> \param rs_dims ... !> \param iounit ... !> \param fft_usage ... -!> \param error ... ! ***************************************************************************** SUBROUTINE dg_pme_grid_setup ( b_cell_hmat, npts_s, cutoff_radius, grid_s, grid_b, & - grid_ref, rs_dims, iounit, fft_usage, error ) + grid_ref, rs_dims, iounit, fft_usage) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: b_cell_hmat @@ -106,23 +105,21 @@ SUBROUTINE dg_pme_grid_setup ( b_cell_hmat, npts_s, cutoff_radius, grid_s, grid_ OPTIONAL :: rs_dims INTEGER, INTENT(IN), OPTIONAL :: iounit LOGICAL, INTENT(IN), OPTIONAL :: fft_usage - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER, DIMENSION(2, 3) :: bo REAL(KIND=dp) :: cutoff, ecut REAL(KIND=dp), DIMENSION(3, 3) :: s_cell_hmat, unit_cell_hmat - CALL dg_find_cutoff (b_cell_hmat, npts_s, cutoff_radius, grid_s, grid_b, cutoff ,error=error) + CALL dg_find_cutoff (b_cell_hmat, npts_s, cutoff_radius, grid_s, grid_b, cutoff) ecut = 0.5_dp * cutoff * cutoff bo = grid_b % bounds IF ( PRESENT ( grid_ref ) ) THEN CALL pw_grid_setup (b_cell_hmat, grid_b, bounds=bo, cutoff=ecut, spherical=.TRUE.,& - ref_grid = grid_ref, rs_dims=rs_dims, iounit=iounit, fft_usage=fft_usage,& - error=error) + ref_grid = grid_ref, rs_dims=rs_dims, iounit=iounit, fft_usage=fft_usage) ELSE CALL pw_grid_setup (b_cell_hmat, grid_b, bounds=bo, cutoff=ecut, spherical=.TRUE.,& - rs_dims=rs_dims, iounit=iounit, fft_usage=fft_usage, error=error) + rs_dims=rs_dims, iounit=iounit, fft_usage=fft_usage) ENDIF CALL dg_find_basis ( grid_b % npts, b_cell_hmat, unit_cell_hmat) @@ -130,8 +127,7 @@ SUBROUTINE dg_pme_grid_setup ( b_cell_hmat, npts_s, cutoff_radius, grid_s, grid_ CALL dg_set_cell ( grid_s % npts, unit_cell_hmat, s_cell_hmat ) bo = grid_s % bounds - CALL pw_grid_setup (s_cell_hmat, grid_s, bounds=bo, cutoff=ecut, iounit=iounit, fft_usage=fft_usage,& - error=error) + CALL pw_grid_setup (s_cell_hmat, grid_s, bounds=bo, cutoff=ecut, iounit=iounit, fft_usage=fft_usage) END SUBROUTINE dg_pme_grid_setup @@ -166,10 +162,9 @@ END FUNCTION get_cell_lengths !> \param grid_s ... !> \param grid_b ... !> \param cutoff ... -!> \param error ... ! ***************************************************************************** SUBROUTINE dg_find_cutoff (b_cell_hmat, npts_s, cutoff_radius, grid_s, & - grid_b, cutoff, error) + grid_b, cutoff) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: b_cell_hmat @@ -177,7 +172,6 @@ SUBROUTINE dg_find_cutoff (b_cell_hmat, npts_s, cutoff_radius, grid_s, & REAL(KIND=dp), INTENT(IN) :: cutoff_radius TYPE(pw_grid_type), POINTER :: grid_s, grid_b REAL(KIND=dp), INTENT(OUT) :: cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dg_find_cutoff', & routineP = moduleN//':'//routineN @@ -231,7 +225,7 @@ SUBROUTINE dg_find_cutoff (b_cell_hmat, npts_s, cutoff_radius, grid_s, & grid_s % grid_span = HALFSPACE grid_s % npts = nout - cutoff = pw_find_cutoff ( grid_b % npts, b_cell_h_inv, error=error) + cutoff = pw_find_cutoff ( grid_b % npts, b_cell_h_inv) END SUBROUTINE dg_find_cutoff @@ -256,13 +250,11 @@ END SUBROUTINE dg_get_spacing !> \param b_cell_hmat ... !> \param grid_b ... !> \param grid_s ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE dg_grid_change (b_cell_hmat, grid_b, grid_s, error) +SUBROUTINE dg_grid_change (b_cell_hmat, grid_b, grid_s) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: b_cell_hmat TYPE(pw_grid_type), POINTER :: grid_b, grid_s - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), DIMENSION(3, 3) :: s_cell_hmat, unit_cell_hmat diff --git a/src/pw/dielectric_methods.F b/src/pw/dielectric_methods.F index 60f5fd8786..806c40dc29 100644 --- a/src/pw/dielectric_methods.F +++ b/src/pw/dielectric_methods.F @@ -56,17 +56,15 @@ MODULE dielectric_methods !> \param dielectric the dielectric data type to be allocated !> \param pw_pool pool of pw grid !> \param dielectric_params dielectric parameters read from input file -!> \param error cp2k error !> \par History !> 06.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dielectric_create(dielectric, pw_pool, dielectric_params, error) + SUBROUTINE dielectric_create(dielectric, pw_pool, dielectric_params) TYPE(dielectric_type), INTENT(INOUT), & POINTER :: dielectric TYPE(pw_pool_type), POINTER :: pw_pool TYPE(dielectric_parameters), INTENT(IN) :: dielectric_params - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dielectric_create', & routineP = moduleN//':'//routineN @@ -80,19 +78,16 @@ SUBROUTINE dielectric_create(dielectric, pw_pool, dielectric_params, error) NULLIFY(dielectric%eps) NULLIFY(dielectric%deps_drho) CALL pw_pool_create_pw(pw_pool, dielectric%eps, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(pw_pool, dielectric%deps_drho, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) dielectric%eps%cr3d = 1.0_dp - CALL pw_zero(dielectric%deps_drho, error) + CALL pw_zero(dielectric%deps_drho) DO i = 1, 3 NULLIFY(dielectric%dln_eps(i)%pw) CALL pw_pool_create_pw(pw_pool, dielectric%dln_eps(i)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) - CALL pw_zero(dielectric%dln_eps(i)%pw, error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(dielectric%dln_eps(i)%pw) END DO dielectric%params = dielectric_params dielectric%params%times_called = 0 @@ -109,14 +104,13 @@ END SUBROUTINE dielectric_create !> \param pw_pool pool of plane wave grid !> \param rho electronic density !> \param rho_core core density -!> \param error cp2k error !> \par History !> 06.2014 created [Hossein Bani-Hashemian] !> 12.2014 added finite difference derivatives [Hossein Bani-Hashemian] !> 07.2015 density-independent dielectric regions [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dielectric_compute(dielectric, diel_rs_grid, pw_pool, rho, rho_core, error) + SUBROUTINE dielectric_compute(dielectric, diel_rs_grid, pw_pool, rho, rho_core) TYPE(dielectric_type), INTENT(INOUT), & POINTER :: dielectric @@ -125,7 +119,6 @@ SUBROUTINE dielectric_compute(dielectric, diel_rs_grid, pw_pool, rho, rho_core, TYPE(pw_type), INTENT(IN), POINTER :: rho TYPE(pw_type), INTENT(IN), OPTIONAL, & POINTER :: rho_core - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dielectric_compute', & routineP = moduleN//':'//routineN @@ -154,46 +147,45 @@ SUBROUTINE dielectric_compute(dielectric, diel_rs_grid, pw_pool, rho, rho_core, (derivative_method .EQ. derivative_fft_use_deps))) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "The specified derivative method is not compatible with the type of "//& - "the dielectric constant function.", error) + "the dielectric constant function.") END IF NULLIFY(rho_elec_rs) - CALL pw_pool_create_pw(pw_pool, rho_elec_rs, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool, rho_elec_rs, use_data=REALDATA3D, in_space=REALSPACE) ! for evaluating epsilon make sure rho is in the real space - CALL pw_transfer(rho, rho_elec_rs, error=error) + CALL pw_transfer(rho, rho_elec_rs) IF (PRESENT(rho_core)) THEN ! make sure rho_core is in the real space CALL pw_pool_create_pw(pw_pool, rho_core_rs, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) - CALL pw_transfer(rho_core, rho_core_rs, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_transfer(rho_core, rho_core_rs) IF (dielectric%params%dielec_core_correction) THEN ! use (rho_elec - rho_core) to compute dielectric to avoid obtaining spurious ! epsilon in the core region - CALL pw_axpy(rho_core_rs, rho_elec_rs, - 2.0_dp , error=error) + CALL pw_axpy(rho_core_rs, rho_elec_rs, - 2.0_dp) ELSE - CALL pw_axpy(rho_core_rs, rho_elec_rs, - 1.0_dp , error=error) + CALL pw_axpy(rho_core_rs, rho_elec_rs, - 1.0_dp) END IF - CALL pw_pool_give_back_pw(pw_pool, rho_core_rs, error=error) + CALL pw_pool_give_back_pw(pw_pool, rho_core_rs) ELSE CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & - "For dielectric constant larger than 1, rho_core has to be present.", error) + "For dielectric constant larger than 1, rho_core has to be present.") END IF ! calculate the dielectric constant SELECT CASE(dielec_functiontype) CASE(rho_dependent) CALL dielectric_constant_sccs(rho_elec_rs, dielectric%eps, dielectric%deps_drho, & - eps0, rho_max, rho_min, error) + eps0, rho_max, rho_min) CASE(spatially_dependent) IF (times_called .EQ. 0) THEN - CALL dielectric_constant_spatially_dependent(dielectric%eps, pw_pool, dielectric%params, error) + CALL dielectric_constant_spatially_dependent(dielectric%eps, pw_pool, dielectric%params) END IF CASE(spatially_rho_dependent) CALL dielectric_constant_spatially_rho_dependent(rho_elec_rs, dielectric%eps, & - dielectric%deps_drho, pw_pool, dielectric%params, error) + dielectric%deps_drho, pw_pool, dielectric%params) END SELECT ! derivatives @@ -203,36 +195,36 @@ SUBROUTINE dielectric_compute(dielectric, diel_rs_grid, pw_pool, rho, rho_core, SELECT CASE (derivative_method) CASE (derivative_cd3, derivative_cd5, derivative_cd7, derivative_fft) NULLIFY(ln_eps) - CALL pw_pool_create_pw(pw_pool,ln_eps,use_data=REALDATA3D,in_space=REALSPACE,error=error) + CALL pw_pool_create_pw(pw_pool,ln_eps,use_data=REALDATA3D,in_space=REALSPACE) ln_eps%cr3d = LOG(dielectric%eps%cr3d) CASE (derivative_fft_use_deps) DO i = 1, 3 NULLIFY(deps(i)%pw) - CALL pw_pool_create_pw(pw_pool,deps(i)%pw,use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_zero(deps(i)%pw, error) + CALL pw_pool_create_pw(pw_pool,deps(i)%pw,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(deps(i)%pw) END DO CASE (derivative_fft_use_drho) DO i = 1, 3 NULLIFY(deps(i)%pw, drho(i)%pw) - CALL pw_pool_create_pw(pw_pool,deps(i)%pw,use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_pool_create_pw(pw_pool,drho(i)%pw,use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_zero(deps(i)%pw, error) - CALL pw_zero(drho(i)%pw, error) + CALL pw_pool_create_pw(pw_pool,deps(i)%pw,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool,drho(i)%pw,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(deps(i)%pw) + CALL pw_zero(drho(i)%pw) END DO END SELECT SELECT CASE (derivative_method) CASE (derivative_cd3) - CALL derive_fdm_cd3(ln_eps, dielectric%dln_eps, diel_rs_grid, error) + CALL derive_fdm_cd3(ln_eps, dielectric%dln_eps, diel_rs_grid) CASE (derivative_cd5) - CALL derive_fdm_cd5(ln_eps, dielectric%dln_eps, diel_rs_grid, error) + CALL derive_fdm_cd5(ln_eps, dielectric%dln_eps, diel_rs_grid) CASE (derivative_cd7) - CALL derive_fdm_cd7(ln_eps, dielectric%dln_eps, diel_rs_grid, error) + CALL derive_fdm_cd7(ln_eps, dielectric%dln_eps, diel_rs_grid) CASE (derivative_fft) - CALL derive_fft(ln_eps, dielectric%dln_eps, pw_pool, error) + CALL derive_fft(ln_eps, dielectric%dln_eps, pw_pool) CASE (derivative_fft_use_deps) ! \Nabla ln(\eps) = \frac{\Nabla \eps}{\eps} - CALL derive_fft(dielectric%eps, deps, pw_pool, error) + CALL derive_fft(dielectric%eps, deps, pw_pool) lb(1:3) = rho%pw_grid%bounds_local(1,1:3) ub(1:3) = rho%pw_grid%bounds_local(2,1:3) @@ -253,7 +245,7 @@ SUBROUTINE dielectric_compute(dielectric, diel_rs_grid, pw_pool, rho, rho_core, CASE (derivative_fft_use_drho) ! \Nabla \eps = \Nabla \rho \cdot \frac{\partial \eps}{\partial \rho} ! \Nabla ln(\eps) = \frac{\Nabla \eps}{\eps} - CALL derive_fft(rho_elec_rs, drho, pw_pool, error) + CALL derive_fft(rho_elec_rs, drho, pw_pool) DO i = 1, 3 deps(i)%pw%cr3d = drho(i)%pw%cr3d * dielectric%deps_drho%cr3d dielectric%dln_eps(i)%pw%cr3d = deps(i)%pw%cr3d / dielectric%eps%cr3d @@ -262,20 +254,20 @@ SUBROUTINE dielectric_compute(dielectric, diel_rs_grid, pw_pool, rho, rho_core, SELECT CASE (derivative_method) CASE (derivative_cd3, derivative_cd5, derivative_cd7, derivative_fft) - CALL pw_pool_give_back_pw(pw_pool, ln_eps, error=error) + CALL pw_pool_give_back_pw(pw_pool, ln_eps) CASE (derivative_fft_use_deps) DO i = 1, 3 - CALL pw_pool_give_back_pw(pw_pool, deps(i)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, deps(i)%pw) END DO CASE (derivative_fft_use_drho) DO i = 1, 3 - CALL pw_pool_give_back_pw(pw_pool, drho(i)%pw, error=error) - CALL pw_pool_give_back_pw(pw_pool, deps(i)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, drho(i)%pw) + CALL pw_pool_give_back_pw(pw_pool, deps(i)%pw) END DO END SELECT END IF - CALL pw_pool_give_back_pw(pw_pool, rho_elec_rs, error=error) + CALL pw_pool_give_back_pw(pw_pool, rho_elec_rs) dielectric%params%times_called = dielectric%params%times_called + 1 @@ -292,16 +284,14 @@ END SUBROUTINE dielectric_compute !> \param eps0 dielectric constant in the bulk of the solvent !> \param rho_max upper density threshold !> \param rho_min lower density threshold -!> \param error ... !> \par History !> 06.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dielectric_constant_sccs(rho, eps, deps_drho, eps0, rho_max, rho_min, error) + SUBROUTINE dielectric_constant_sccs(rho, eps, deps_drho, eps0, rho_max, rho_min) TYPE(pw_type), POINTER :: rho, eps, deps_drho REAL(KIND=dp), INTENT(IN) :: eps0, rho_max, rho_min - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dielectric_constant_sccs', & routineP = moduleN//':'//routineN @@ -315,7 +305,7 @@ SUBROUTINE dielectric_constant_sccs(rho, eps, deps_drho, eps0, rho_max, rho_min, IF (eps0 .LT. 1.0_dp) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "The dielectric constant has to be greater than or equal to 1.", error) + "The dielectric constant has to be greater than or equal to 1.") END IF bounds_local = rho%pw_grid%bounds_local @@ -361,7 +351,6 @@ END SUBROUTINE dielectric_constant_sccs !> \param x_locl x grid vetor of the simulation box local to this process !> \param y_locl y grid vetor of the simulation box local to this process !> \param z_locl z grid vetor of the simulation box local to this process -!> \param error cp2k error !> \par History !> 07.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian @@ -369,7 +358,7 @@ END SUBROUTINE dielectric_constant_sccs SUBROUTINE dielectric_constant_aa_cuboidal(eps, dielec_const, pw_pool, zeta, & x_xtnt, y_xtnt, z_xtnt, & x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, error) + x_locl, y_locl, z_locl) TYPE(pw_type), POINTER :: eps REAL(KIND=dp), INTENT(IN) :: dielec_const @@ -379,7 +368,6 @@ SUBROUTINE dielectric_constant_aa_cuboidal(eps, dielec_const, pw_pool, zeta, & REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(IN) :: x_glbl, y_glbl, z_glbl, & x_locl, y_locl, z_locl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dielectric_constant_aa_cuboidal', & @@ -401,7 +389,7 @@ SUBROUTINE dielectric_constant_aa_cuboidal(eps, dielec_const, pw_pool, zeta, & IF (dielec_const .LT. 1.0_dp) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "The dielectric constant has to be greater than or equal to 1.", error) + "The dielectric constant has to be greater than or equal to 1.") END IF pw_grid => eps%pw_grid @@ -419,11 +407,11 @@ SUBROUTINE dielectric_constant_aa_cuboidal(eps, dielec_const, pw_pool, zeta, & IF (n_forb_xtnts .GT. 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "The given extents for the dielectric region are outside the range of "//& - "the simulation cell.", error) + "the simulation cell.") END IF - CALL pw_pool_create_pw(pw_pool, eps_tmp, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_copy(eps, eps_tmp, error=error) + CALL pw_pool_create_pw(pw_pool, eps_tmp, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy(eps, eps_tmp) bounds_local = pw_grid%bounds_local lb1 = bounds_local(1,1); ub1 = bounds_local(2,1) @@ -442,8 +430,8 @@ SUBROUTINE dielectric_constant_aa_cuboidal(eps, dielec_const, pw_pool, zeta, & END DO END DO - CALL pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, eps_tmp, eps, error) - CALL pw_pool_give_back_pw(pw_pool, eps_tmp, error=error) + CALL pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, eps_tmp, eps) + CALL pw_pool_give_back_pw(pw_pool, eps_tmp) CALL timestop(handle) @@ -464,7 +452,6 @@ END SUBROUTINE dielectric_constant_aa_cuboidal !> \param x_locl x grid vetor of the simulation box local to this process !> \param y_locl y grid vetor of the simulation box local to this process !> \param z_locl z grid vetor of the simulation box local to this process -!> \param error cp2k error !> \par History !> 07.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian @@ -472,7 +459,7 @@ END SUBROUTINE dielectric_constant_aa_cuboidal SUBROUTINE dielectric_constant_xaa_annular(eps, dielec_const, pw_pool, zeta, & x_xtnt, base_center, base_radii, & x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, error) + x_locl, y_locl, z_locl) TYPE(pw_type), POINTER :: eps REAL(KIND=dp), INTENT(IN) :: dielec_const @@ -483,7 +470,6 @@ SUBROUTINE dielectric_constant_xaa_annular(eps, dielec_const, pw_pool, zeta, & REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(IN) :: x_glbl, y_glbl, z_glbl, & x_locl, y_locl, z_locl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dielectric_constant_xaa_annular', & @@ -506,7 +492,7 @@ SUBROUTINE dielectric_constant_xaa_annular(eps, dielec_const, pw_pool, zeta, & IF (dielec_const .LT. 1.0_dp) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "The dielectric constant has to be greater than or equal to 1.", error) + "The dielectric constant has to be greater than or equal to 1.") END IF pw_grid => eps%pw_grid @@ -525,11 +511,11 @@ SUBROUTINE dielectric_constant_xaa_annular(eps, dielec_const, pw_pool, zeta, & IF (n_forb_xtnts .GT. 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "The given extents for the dielectric region are outside the range of "//& - "the simulation cell.", error) + "the simulation cell.") END IF - CALL pw_pool_create_pw(pw_pool, eps_tmp, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_copy(eps, eps_tmp, error=error) + CALL pw_pool_create_pw(pw_pool, eps_tmp, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy(eps, eps_tmp) bounds_local = pw_grid%bounds_local lb1 = bounds_local(1,1); ub1 = bounds_local(2,1) @@ -549,8 +535,8 @@ SUBROUTINE dielectric_constant_xaa_annular(eps, dielec_const, pw_pool, zeta, & END DO END DO - CALL pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, eps_tmp, eps, error) - CALL pw_pool_give_back_pw(pw_pool, eps_tmp, error=error) + CALL pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, eps_tmp, eps) + CALL pw_pool_give_back_pw(pw_pool, eps_tmp) CALL timestop(handle) @@ -561,17 +547,15 @@ END SUBROUTINE dielectric_constant_xaa_annular !> \param eps dielectric constant function !> \param pw_pool pool of planewave grid !> \param dielectric_params dielectric parameters read from input file -!> \param error cp2k error !> \par History !> 07.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dielectric_constant_spatially_dependent(eps, pw_pool, dielectric_params, error) + SUBROUTINE dielectric_constant_spatially_dependent(eps, pw_pool, dielectric_params) TYPE(pw_type), POINTER :: eps TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(dielectric_parameters), INTENT(IN) :: dielectric_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dielectric_constant_spatially_dependent', & @@ -593,12 +577,12 @@ SUBROUTINE dielectric_constant_spatially_dependent(eps, pw_pool, dielectric_para n_aa_cuboidal = dielectric_params%n_aa_cuboidal n_xaa_annular = dielectric_params%n_xaa_annular pw_grid => pw_pool%pw_grid - CALL setup_grid_axes(pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, error) + CALL setup_grid_axes(pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) n_dielectric_region = n_aa_cuboidal + n_xaa_annular IF (n_dielectric_region .EQ. 0) THEN CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & - "No density independent dielectric region is defined.", error) + "No density independent dielectric region is defined.") END IF DO j = 1, n_aa_cuboidal @@ -610,7 +594,7 @@ SUBROUTINE dielectric_constant_spatially_dependent(eps, pw_pool, dielectric_para dielectric_params%aa_cuboidal_yxtnt(:,j), & dielectric_params%aa_cuboidal_zxtnt(:,j), & x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, error) + x_locl, y_locl, z_locl) END DO DO j = 1, n_xaa_annular @@ -623,7 +607,7 @@ SUBROUTINE dielectric_constant_spatially_dependent(eps, pw_pool, dielectric_para dielectric_params%xaa_annular_xxtnt(:,j), & base_center, base_radii, & x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, error) + x_locl, y_locl, z_locl) END DO CALL timestop(handle) @@ -639,18 +623,16 @@ END SUBROUTINE dielectric_constant_spatially_dependent !> \param deps_drho derivative of the dielectric constant wrt the density !> \param pw_pool pool of planewave grid !> \param dielectric_params dielectric parameters read from input file -!> \param error cp2k error !> \par History !> 07.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE dielectric_constant_spatially_rho_dependent(rho, eps, deps_drho, & - pw_pool, dielectric_params, error) + pw_pool, dielectric_params) TYPE(pw_type), POINTER :: rho, eps, deps_drho TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(dielectric_parameters), INTENT(IN) :: dielectric_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dielectric_constant_spatially_rho_dependent', & @@ -664,26 +646,26 @@ SUBROUTINE dielectric_constant_spatially_rho_dependent(rho, eps, deps_drho, & IF (dielectric_params%eps0 .LT. 1.0_dp) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "The dielectric constant has to be greater than or equal to 1.", error) + "The dielectric constant has to be greater than or equal to 1.") END IF - CALL pw_pool_create_pw(pw_pool, eps_sptldep, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, swch_func, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, dswch_func_drho, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_zero(eps_sptldep, error=error) - CALL pw_zero(swch_func, error=error) - CALL pw_zero(dswch_func_drho, error=error) + CALL pw_pool_create_pw(pw_pool, eps_sptldep, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, swch_func, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, dswch_func_drho, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(eps_sptldep) + CALL pw_zero(swch_func) + CALL pw_zero(dswch_func_drho) - CALL dielectric_constant_spatially_dependent(eps_sptldep, pw_pool, dielectric_params, error) + CALL dielectric_constant_spatially_dependent(eps_sptldep, pw_pool, dielectric_params) CALL dielectric_constant_sccs(rho, swch_func, dswch_func_drho, 2.0_dp, & - dielectric_params%rho_max, dielectric_params%rho_min, error) + dielectric_params%rho_max, dielectric_params%rho_min) eps%cr3d = ( (swch_func%cr3d - 1.0_dp) * (eps_sptldep%cr3d - 1.0_dp) ) + 1.0_dp deps_drho%cr3d = dswch_func_drho%cr3d * (eps_sptldep%cr3d - 1.0_dp) - CALL pw_pool_give_back_pw(pw_pool, dswch_func_drho, error=error) - CALL pw_pool_give_back_pw(pw_pool, swch_func, error=error) - CALL pw_pool_give_back_pw(pw_pool, eps_sptldep, error=error) + CALL pw_pool_give_back_pw(pw_pool, dswch_func_drho) + CALL pw_pool_give_back_pw(pw_pool, swch_func) + CALL pw_pool_give_back_pw(pw_pool, eps_sptldep) CALL timestop(handle) @@ -694,15 +676,13 @@ END SUBROUTINE dielectric_constant_spatially_rho_dependent !> \param f input funcition !> \param df derivative of f !> \param pw_pool pool of plane-wave grid -!> \param error cp2k error ! ***************************************************************************** - SUBROUTINE derive_fft(f, df, pw_pool, error) + SUBROUTINE derive_fft(f, df, pw_pool) TYPE(pw_type), POINTER :: f TYPE(pw_p_type), DIMENSION(3), & INTENT(INOUT) :: df TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'derive_fft', & routineP = moduleN//':'//routineN @@ -716,21 +696,20 @@ SUBROUTINE derive_fft(f, df, pw_pool, error) DO i = 1, 2 NULLIFY (work_gs(i)%pw) CALL pw_pool_create_pw(pw_pool, work_gs(i)%pw, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) END DO - CALL pw_transfer(f, work_gs(1)%pw, error=error) + CALL pw_transfer(f, work_gs(1)%pw) DO i = 1, 3 nd(:) = 0 nd(i) = 1 - CALL pw_copy(work_gs(1)%pw, work_gs(2)%pw, error=error) - CALL pw_derive(work_gs(2)%pw, nd(:), error=error) - CALL pw_transfer(work_gs(2)%pw, df(i)%pw, error=error) + CALL pw_copy(work_gs(1)%pw, work_gs(2)%pw) + CALL pw_derive(work_gs(2)%pw, nd(:)) + CALL pw_transfer(work_gs(2)%pw, df(i)%pw) END DO DO i = 1, 2 - CALL pw_pool_give_back_pw(pw_pool, work_gs(i)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, work_gs(i)%pw) END DO CALL timestop(handle) diff --git a/src/pw/dielectric_types.F b/src/pw/dielectric_types.F index db9208f4d3..1c429bb6d6 100644 --- a/src/pw/dielectric_types.F +++ b/src/pw/dielectric_types.F @@ -77,17 +77,14 @@ MODULE dielectric_types !> \brief deallocates dielectric data type !> \param dielectric the dielectric data type to be released !> \param pw_pool pool of the plane wave grid -!> \param error cp2k error -!> !> \par History !> 06.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dielectric_release(dielectric, pw_pool, error) + SUBROUTINE dielectric_release(dielectric, pw_pool) TYPE(dielectric_type), POINTER :: dielectric TYPE(pw_pool_type), INTENT(IN), & OPTIONAL, POINTER :: pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dielectric_release', & routineP = moduleN//':'//routineN @@ -101,21 +98,21 @@ SUBROUTINE dielectric_release(dielectric, pw_pool, error) IF (can_give_back) can_give_back = ASSOCIATED(pw_pool) IF (can_give_back) THEN CALL pw_pool_give_back_pw(pw_pool, dielectric%eps,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_pw(pw_pool, dielectric%deps_drho,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) DO i = 1, 3 CALL pw_pool_give_back_pw(pw_pool, dielectric%dln_eps(i)%pw,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) END DO ELSE - CALL pw_release(dielectric%eps, error = error) - CALL pw_release(dielectric%deps_drho, error = error) + CALL pw_release(dielectric%eps) + CALL pw_release(dielectric%deps_drho) DO i = 1, 3 - CALL pw_release(dielectric%dln_eps(i)%pw, error=error) + CALL pw_release(dielectric%dln_eps(i)%pw) END DO END IF - CALL dielectric_parameters_dealloc(dielectric%params, error=error) + CALL dielectric_parameters_dealloc(dielectric%params) DEALLOCATE(dielectric) END IF @@ -126,17 +123,14 @@ END SUBROUTINE dielectric_release ! ***************************************************************************** !> \brief deallocates dielectric_parameters type !> \param dielec_params dielectric parameters -!> \param error cp2k error -!> !> \par History !> 07.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dielectric_parameters_dealloc(dielec_params, error) + SUBROUTINE dielectric_parameters_dealloc(dielec_params) TYPE(dielectric_parameters), & INTENT(INOUT) :: dielec_params - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dielectric_parameters_dealloc', & diff --git a/src/pw/dirichlet_bc_methods.F b/src/pw/dirichlet_bc_methods.F index 9aca684c6a..f270d5296c 100644 --- a/src/pw/dirichlet_bc_methods.F +++ b/src/pw/dirichlet_bc_methods.F @@ -58,19 +58,17 @@ MODULE dirichlet_bc_methods !> \param pw_pool pool of plane wave grid !> \param poisson_params poisson_env parameters !> \param dbcs the DBC region to be created -!> \param error cp2k error !> \par History !> 10.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) + SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(pw_poisson_parameter_type), & INTENT(INOUT) :: poisson_params TYPE(dirichlet_bc_p_type), & DIMENSION(:), INTENT(INOUT), POINTER :: dbcs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dirichlet_boundary_region_setup', & @@ -90,7 +88,7 @@ SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -105,14 +103,14 @@ SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) n_xaa_cylindrical = poisson_params%dbc_params%n_xaa_cylindrical xaa_cylindrical_nsides => poisson_params%dbc_params%xaa_cylindrical_nsides pw_grid => pw_pool%pw_grid - CALL setup_grid_axes(pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, error) + CALL setup_grid_axes(pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) n_dbcs = n_aa_planar + n_aa_cuboidal + n_planar + SUM(xaa_cylindrical_nsides) SELECT CASE (poisson_params%ps_implicit_params%boundary_condition) CASE (MIXED_BC, MIXED_PERIODIC_BC) IF (n_dbcs .EQ. 0) THEN CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & - "No Dirichlet region is defined.", error) + "No Dirichlet region is defined.") END IF ALLOCATE(dbcs(n_dbcs)) @@ -139,10 +137,10 @@ SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) poisson_params%dbc_params%aa_planar_yxtnt(:,j), & poisson_params%dbc_params%aa_planar_zxtnt(:,j), & v_D, smooth, zeta, dbc_id, dbcs(j)%dirichlet_bc, & - verbose, error) + verbose) CALL dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose, error) + x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose) END DO l = n_aa_planar @@ -164,10 +162,10 @@ SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) poisson_params%dbc_params%aa_cuboidal_yxtnt(:,j - l), & poisson_params%dbc_params%aa_cuboidal_zxtnt(:,j - l), & v_D, smooth, zeta, dbc_id, dbcs(j)%dirichlet_bc, & - verbose, error) + verbose) CALL dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose, error) + x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose) END DO l = n_aa_planar + n_aa_cuboidal @@ -189,10 +187,10 @@ SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) poisson_params%dbc_params%planar_Bvtx(:,j - l), & poisson_params%dbc_params%planar_Cvtx(:,j - l), & v_D, smooth, zeta, dbc_id, dbcs(j)%dirichlet_bc, & - verbose, error) + verbose) CALL dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose, error) + x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose) END DO l = n_aa_planar + n_aa_cuboidal + n_planar @@ -217,7 +215,7 @@ SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) x_locl, y_locl, z_locl, & poisson_params%dbc_params%xaa_cylindrical_xxtnt(:,j), & base_center, base_radius, v_D, smooth, zeta, n_prtn, & - dbcs(ind_start : ind_end), apx_type, verbose, error) + dbcs(ind_start : ind_end), apx_type, verbose) l = l + xaa_cylindrical_nsides(j) END DO @@ -227,7 +225,7 @@ SUBROUTINE dirichlet_boundary_region_setup(pw_pool, poisson_params, dbcs, error) END SELECT ! we won't need parameters anymore so deallocate them - CALL dirichlet_bc_parameters_dealloc(poisson_params%dbc_params, error) + CALL dirichlet_bc_parameters_dealloc(poisson_params%dbc_params) CALL timestop(handle) @@ -249,14 +247,12 @@ END SUBROUTINE dirichlet_boundary_region_setup !> \param z_locl z grid vetor of the simulation box local to this process !> \param dirichlet_bc the dirichlet_bc object to be partitioned !> \param verbose whether or not to print out the coordinates of the vertices -!> \param error cp2k error -!> !> \par History !> 10.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, dirichlet_bc, verbose, error) + x_locl, y_locl, z_locl, dirichlet_bc, verbose) REAL(dp), INTENT(IN) :: v_D LOGICAL, INTENT(IN) :: smooth @@ -269,7 +265,6 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ TYPE(dirichlet_bc_type), INTENT(INOUT), & POINTER :: dirichlet_bc LOGICAL, INTENT(IN) :: verbose - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dirichlet_bc_partition', & routineP = moduleN//':'//routineN @@ -284,7 +279,7 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -302,9 +297,9 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ ALLOCATE(rectangle_aa) CALL convert_to_aa_rectangle(dirichlet_bc%rectangle, rectangle_aa, & - phi1, rot_axis1, phi2, rot_axis2, error) - CALL partition_aa_rectangle_into_tiles(rectangle_aa, x_glbl, y_glbl, z_glbl, n_prtn, tiles, error) - CALL cs_rectangle_release(rectangle_aa, error=error) + phi1, rot_axis1, phi2, rot_axis2) + CALL partition_aa_rectangle_into_tiles(rectangle_aa, x_glbl, y_glbl, z_glbl, n_prtn, tiles) + CALL cs_rectangle_release(rectangle_aa) n_tiles = SIZE(tiles) dirichlet_bc%n_tiles = n_tiles @@ -317,9 +312,9 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ ALLOCATE(dirichlet_bc%tiles(k)%tile%rectangle) ALLOCATE(rectangle_tmp) CALL rotate_rectangle(tiles(k)%tile%rectangle, phi2, rot_axis2, BWROT, & - rectangle_tmp, error) + rectangle_tmp) CALL rotate_rectangle(rectangle_tmp, phi1, rot_axis1, BWROT, & - dirichlet_bc%tiles(k)%tile%rectangle, error) + dirichlet_bc%tiles(k)%tile%rectangle) dirichlet_bc%tiles(k)%tile%tile_id = 8000 + k dirichlet_bc%tiles(k)%tile%v_D = v_D @@ -328,8 +323,8 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ dirichlet_bc%tiles(k)%tile%mollifier_zeta = zeta CALL pw_pool_create_pw(pw_pool, dirichlet_bc%tiles(k)%tile%tile_pw, & - use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_zero(dirichlet_bc%tiles(k)%tile%tile_pw, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(dirichlet_bc%tiles(k)%tile%tile_pw) IF ((unit_nr .GT. 0) .AND. verbose) THEN WRITE(unit_nr,'(T7,A,I5)') "tile", k @@ -340,24 +335,24 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ END IF CALL voxelize_rectangle(dirichlet_bc%tiles(k)%tile%rectangle, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, dirichlet_bc%tiles(k)%tile%tile_pw, error) + x_locl, y_locl, z_locl, dirichlet_bc%tiles(k)%tile%tile_pw) tile_npts = NINT(SUM(dirichlet_bc%tiles(k)%tile%tile_pw%cr3d),KIND=KIND(tile_npts)) CALL mp_sum(tile_npts, pw_pool%pw_grid%para%group) dirichlet_bc%tiles(k)%tile%npts = tile_npts - CALL cs_rectangle_release(rectangle_tmp, error) + CALL cs_rectangle_release(rectangle_tmp) END DO IF ((unit_nr .GT. 0) .AND. verbose) WRITE(unit_nr, '(T3,A)') REPEAT('=', 78) DO k = 1, n_tiles - CALL cs_rectangle_release(tiles(k)%tile%rectangle, error) + CALL cs_rectangle_release(tiles(k)%tile%rectangle) DEALLOCATE(tiles(k)%tile) END DO DEALLOCATE(tiles) CASE (AA_CUBOIDAL) - CALL partition_aa_cuboid_into_tiles(dirichlet_bc%box, x_glbl, y_glbl, z_glbl, n_prtn, tiles, error) + CALL partition_aa_cuboid_into_tiles(dirichlet_bc%box, x_glbl, y_glbl, z_glbl, n_prtn, tiles) n_tiles = SIZE(tiles) dirichlet_bc%n_tiles = n_tiles ALLOCATE(dirichlet_bc%tiles(n_tiles)) @@ -373,8 +368,8 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ dirichlet_bc%tiles(k)%tile%mollifier_zeta = zeta CALL pw_pool_create_pw(pw_pool, dirichlet_bc%tiles(k)%tile%tile_pw, & - use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_zero(dirichlet_bc%tiles(k)%tile%tile_pw, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(dirichlet_bc%tiles(k)%tile%tile_pw) IF ((unit_nr .GT. 0) .AND. verbose) THEN WRITE(unit_nr,'(T7,A,I5)') "tile", k @@ -386,7 +381,7 @@ SUBROUTINE dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_ END IF CALL voxelize_aa_cuboid(dirichlet_bc%tiles(k)%tile%box, x_locl, y_locl, z_locl, & - dirichlet_bc%tiles(k)%tile%tile_pw, error) + dirichlet_bc%tiles(k)%tile%tile_pw) tile_npts = NINT(SUM(dirichlet_bc%tiles(k)%tile%tile_pw%cr3d),KIND=KIND(tile_npts)) CALL mp_sum(tile_npts, pw_pool%pw_grid%para%group) dirichlet_bc%tiles(k)%tile%npts = tile_npts @@ -429,7 +424,6 @@ END SUBROUTINE dirichlet_bc_partition !> \param dbcs the x-axis-aligned cylindrical gate region to be created !> \param apx_type the type of the n-gonal prism approximating the cylinder !> \param verbose whether or not to print out the coordinates of the vertices -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian @@ -437,7 +431,7 @@ END SUBROUTINE dirichlet_bc_partition SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, & x_xtnt, base_center, base_radius, v_D, smooth, zeta, & - n_prtn, dbcs, apx_type, verbose, error) + n_prtn, dbcs, apx_type, verbose) TYPE(pw_pool_type), POINTER :: pw_pool REAL(dp), ALLOCATABLE, DIMENSION(:), & @@ -452,7 +446,6 @@ SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & DIMENSION(:), INTENT(INOUT) :: dbcs INTEGER, INTENT(IN), OPTIONAL :: apx_type LOGICAL, INTENT(IN) :: verbose - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_xaa_cylindrical_dbc', & routineP = moduleN//':'//routineN @@ -470,7 +463,7 @@ SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -491,7 +484,7 @@ SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & IF( (x_xtnt(1) .LT. x_glbl(glb1)) .OR. (x_xtnt(2) .GT. x_glbl(gub1)+dx) ) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP, & "The length of the cylindrical Dirichlet region is larger than the "//& - "x range of the simulation cell.", error) + "x range of the simulation cell.") END IF forb_xtnt1 = base_center(1)-base_radius .LT. x_glbl(glb1) forb_xtnt2 = base_center(1)+base_radius .GT. x_glbl(gub1)+dx @@ -499,7 +492,7 @@ SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & forb_xtnt4 = base_center(2)+base_radius .GT. y_glbl(gub2)+dy IF( forb_xtnt1 .OR. forb_xtnt2 .OR. forb_xtnt3 .OR. forb_xtnt4 ) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP, & - "The cylinder does not fit entirely inside the simulation cell.", error) + "The cylinder does not fit entirely inside the simulation cell.") END IF intern_apx_type = CIRCUMSCRIBED @@ -521,11 +514,11 @@ SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & h = base_radius/COS(0.5*theta) ! circumscribed uniform prism ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Unknown approximation type for cylinder.",error) + "Unknown approximation type for cylinder.") END IF IF( h .GT. MINVAL((/Ly, Lz/)) ) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP, & - "Reduce the base radius!", error) + "Reduce the base radius!") END IF delta_alpha = 0.05_dp @@ -557,7 +550,7 @@ SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & D = (/ xub , yub(j) , zub(j) /) ALLOCATE(dbcs(j)%dirichlet_bc%rectangle) - CALL cs_rectangle_create(dbcs(j)%dirichlet_bc%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(dbcs(j)%dirichlet_bc%rectangle, A, B, C, D) dbcs(j)%dirichlet_bc%n_tiles = 1 @@ -572,7 +565,7 @@ SUBROUTINE create_xaa_cylindrical_dbc(pw_pool, & END IF CALL dirichlet_bc_partition(v_D, smooth, zeta, n_prtn, pw_pool, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose, error) + x_locl, y_locl, z_locl, dbcs(j)%dirichlet_bc, verbose) END DO CALL timestop(handle) @@ -593,13 +586,12 @@ END SUBROUTINE create_xaa_cylindrical_dbc !> \param dbc_id unique ID for the planar Dirichlet region !> \param dirichlet_bc the dirichlet_bc object to be created !> \param verbose whether or not to print out the coordinates of the vertices -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE create_aa_planar_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, & - v_D, smooth, zeta, dbc_id, dirichlet_bc, verbose, error) + v_D, smooth, zeta, dbc_id, dirichlet_bc, verbose) REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(IN) :: x_glbl, y_glbl, z_glbl @@ -611,7 +603,6 @@ SUBROUTINE create_aa_planar_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, TYPE(dirichlet_bc_type), INTENT(INOUT), & POINTER :: dirichlet_bc LOGICAL, INTENT(IN) :: verbose - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_aa_planar_dbc', & routineP = moduleN//':'//routineN @@ -629,7 +620,7 @@ SUBROUTINE create_aa_planar_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -657,7 +648,7 @@ SUBROUTINE create_aa_planar_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, IF (n_forb_xtnts .GT. 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "The given extents for the Dirichlet region are outside the range of "//& - "the simulation cell.", error) + "the simulation cell.") END IF xxtnt_fst = find_fst_ge(x_glbl, x_xtnt(1)) @@ -680,7 +671,7 @@ SUBROUTINE create_aa_planar_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, C = (/ xub, ylb, zlb /) D = (/ xub, yub, zlb /) ALLOCATE(dirichlet_bc%rectangle) - CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D) dirichlet_bc%n_tiles = 1 ELSE IF (ABS(y_xtnt(1)-y_xtnt(2)) .LE. small_value) THEN A = (/ xlb, ylb, zub /) @@ -688,7 +679,7 @@ SUBROUTINE create_aa_planar_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, C = (/ xub, ylb, zlb /) D = (/ xub, ylb, zub /) ALLOCATE(dirichlet_bc%rectangle) - CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D) dirichlet_bc%n_tiles = 1 ELSE IF (ABS(x_xtnt(1)-x_xtnt(2)) .LE. small_value) THEN A = (/ xlb, ylb, zub /) @@ -696,12 +687,12 @@ SUBROUTINE create_aa_planar_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, C = (/ xlb, yub, zlb /) D = (/ xlb, yub, zub /) ALLOCATE(dirichlet_bc%rectangle) - CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D) dirichlet_bc%n_tiles = 1 ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "According to the given extents, the Dirichlet region is not axis-aligned or a plane. "//& - "Try the input section PLANAR or AA_CUBOIDAL instead.",error) + "Try the input section PLANAR or AA_CUBOIDAL instead.") END IF IF ((unit_nr .GT. 0) .AND. verbose) THEN @@ -731,13 +722,12 @@ END SUBROUTINE create_aa_planar_dbc !> \param dbc_id unique ID for the planar Dirichlet region !> \param dirichlet_bc the dirichlet_bc object to be created !> \param verbose whether or not to print out the coordinates of the vertices -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE create_arbitrary_planar_dbc(x_glbl, y_glbl, z_glbl, A, B, C, v_D, & - smooth, zeta, dbc_id, dirichlet_bc, verbose, error) + smooth, zeta, dbc_id, dirichlet_bc, verbose) REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(IN) :: x_glbl, y_glbl, z_glbl @@ -749,7 +739,6 @@ SUBROUTINE create_arbitrary_planar_dbc(x_glbl, y_glbl, z_glbl, A, B, C, v_D, & TYPE(dirichlet_bc_type), INTENT(INOUT), & POINTER :: dirichlet_bc LOGICAL, INTENT(IN) :: verbose - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_arbitrary_planar_dbc', & routineP = moduleN//':'//routineN @@ -765,7 +754,7 @@ SUBROUTINE create_arbitrary_planar_dbc(x_glbl, y_glbl, z_glbl, A, B, C, v_D, & CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -784,7 +773,7 @@ SUBROUTINE create_arbitrary_planar_dbc(x_glbl, y_glbl, z_glbl, A, B, C, v_D, & are_orthogonal = ABS( DOT_PRODUCT(AB, BC)/(SQRT(SUM(AB**2)) * SQRT(SUM(BC**2))) ) .LE. small_value IF (.NOT. are_orthogonal) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP, & - "The given vertices for defining a planar Dirichlet region do not form orthogonal edges.", error) + "The given vertices for defining a planar Dirichlet region do not form orthogonal edges.") END IF A_is_inside = ((A(1) .GT. x_glbl(glb1)) .AND. (A(1) .LT. x_glbl(gub1)+dx)) .AND. & @@ -802,13 +791,13 @@ SUBROUTINE create_arbitrary_planar_dbc(x_glbl, y_glbl, z_glbl, A, B, C, v_D, & IF (.NOT. (A_is_inside .AND. B_is_inside .AND. C_is_inside .AND. D_is_inside)) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP, & "At least one of the given vertices for defining a planar Dirichlet "//& - "region is outside the simulation box.", error) + "region is outside the simulation box.") END IF are_coplanar = ABS(DOT_PRODUCT(vector_product(AB, AC), AD)) .LE. small_value IF (.NOT. are_coplanar) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP, & - "The given vertices for defining a planar Dirichlet region are not coplanar.", error) + "The given vertices for defining a planar Dirichlet region are not coplanar.") END IF cm(1) = (A(1) + B(1) + C(1) + D(1))/4.0_dp @@ -823,13 +812,13 @@ SUBROUTINE create_arbitrary_planar_dbc(x_glbl, y_glbl, z_glbl, A, B, C, v_D, & (ABS(dist1-dist4) .LE. small_value) IF (.NOT. is_rectangle) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP, & - "The given vertices for defining a planar Dirichlet region do not form a rectangle.", error) + "The given vertices for defining a planar Dirichlet region do not form a rectangle.") END IF dirichlet_bc%dbc_id = dbc_id dirichlet_bc%dbc_geom = PLANAR ALLOCATE(dirichlet_bc%rectangle) - CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(dirichlet_bc%rectangle, A, B, C, D) dirichlet_bc%n_tiles = 1 dirichlet_bc%v_D = v_D dirichlet_bc%smooth = smooth @@ -861,13 +850,12 @@ END SUBROUTINE create_arbitrary_planar_dbc !> \param dbc_id unique ID for the planar Dirichlet region !> \param dirichlet_bc the dirichlet_bc object to be created !> \param verbose whether or not to print out the coordinates of the vertices -!> \param error cp2k error !> \par History !> 12.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE create_aa_cuboidal_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt, & - v_D, smooth, zeta, dbc_id, dirichlet_bc, verbose, error) + v_D, smooth, zeta, dbc_id, dirichlet_bc, verbose) REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(IN) :: x_glbl, y_glbl, z_glbl @@ -879,7 +867,6 @@ SUBROUTINE create_aa_cuboidal_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt TYPE(dirichlet_bc_type), INTENT(INOUT), & POINTER :: dirichlet_bc LOGICAL, INTENT(IN) :: verbose - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_aa_cuboidal_dbc', & routineP = moduleN//':'//routineN @@ -897,7 +884,7 @@ SUBROUTINE create_aa_cuboidal_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -925,7 +912,7 @@ SUBROUTINE create_aa_cuboidal_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt IF (n_forb_xtnts .GT. 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "The given extents for the Dirichlet region are outside the range of "//& - "the simulation cell.", error) + "the simulation cell.") END IF xxtnt_fst = find_fst_ge(x_glbl, x_xtnt(1)) @@ -947,7 +934,7 @@ SUBROUTINE create_aa_cuboidal_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt (ABS(x_xtnt(1)-x_xtnt(2)) .LE. small_value)) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "According to the given extents, the region's geometry is not a cuboid. "//& - "Try the input section AA_PLANAR instead.",error) + "Try the input section AA_PLANAR instead.") END IF box_vtx(1:3,1) = (/xlb, ylb, zlb/) @@ -960,7 +947,7 @@ SUBROUTINE create_aa_cuboidal_dbc(x_glbl, y_glbl, z_glbl, x_xtnt, y_xtnt, z_xtnt box_vtx(1:3,8) = (/xub, yub, zub/) ALLOCATE(dirichlet_bc%box) - CALL cs_box_create(dirichlet_bc%box, box_vtx, error) + CALL cs_box_create(dirichlet_bc%box, box_vtx) dirichlet_bc%n_tiles = 1 IF ((unit_nr .GT. 0) .AND. verbose) THEN diff --git a/src/pw/dirichlet_bc_types.F b/src/pw/dirichlet_bc_types.F index 070761b024..d7aaf2f009 100644 --- a/src/pw/dirichlet_bc_types.F +++ b/src/pw/dirichlet_bc_types.F @@ -277,19 +277,16 @@ MODULE dirichlet_bc_types !> \brief releases the defined Dirichlet boundary region !> \param gates the DBC region to be released !> \param pw_pool pool of the plane wave grid -!> \param error cp2k error -!> !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dirichlet_boundary_region_release(gates, pw_pool, error) + SUBROUTINE dirichlet_boundary_region_release(gates, pw_pool) TYPE(dirichlet_bc_p_type), & DIMENSION(:), INTENT(INOUT), POINTER :: gates TYPE(pw_pool_type), INTENT(IN), & OPTIONAL, POINTER :: pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dirichlet_boundary_region_release', & @@ -307,20 +304,20 @@ SUBROUTINE dirichlet_boundary_region_release(gates, pw_pool, error) DO i = 1, n_gates dbc_geom = gates(i)%dirichlet_bc%dbc_geom IF (dbc_geom .EQ. AA_CUBOIDAL) THEN - CALL cs_box_release(gates(i)%dirichlet_bc%box, error=error) + CALL cs_box_release(gates(i)%dirichlet_bc%box) ELSE - CALL cs_rectangle_release(gates(i)%dirichlet_bc%rectangle, error=error) + CALL cs_rectangle_release(gates(i)%dirichlet_bc%rectangle) END IF n_tiles = gates(i)%dirichlet_bc%n_tiles DO k = 1, n_tiles tile_geom = gates(i)%dirichlet_bc%tiles(k)%tile%tile_geom - CALL pw_pool_give_back_pw(pw_pool, gates(i)%dirichlet_bc%tiles(k)%tile%tile_pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, gates(i)%dirichlet_bc%tiles(k)%tile%tile_pw) IF (tile_geom .EQ. rectangular_tile) THEN - CALL cs_rectangle_release(gates(i)%dirichlet_bc%tiles(k)%tile%rectangle, error) + CALL cs_rectangle_release(gates(i)%dirichlet_bc%tiles(k)%tile%rectangle) ELSE IF (tile_geom .EQ. cuboidal_tile) THEN - CALL cs_box_release(gates(i)%dirichlet_bc%tiles(k)%tile%box, error) + CALL cs_box_release(gates(i)%dirichlet_bc%tiles(k)%tile%box) END IF DEALLOCATE(gates(i)%dirichlet_bc%tiles(k)%tile) @@ -333,20 +330,20 @@ SUBROUTINE dirichlet_boundary_region_release(gates, pw_pool, error) DO i = 1, n_gates dbc_geom = gates(i)%dirichlet_bc%dbc_geom IF (dbc_geom .EQ. AA_CUBOIDAL) THEN - CALL cs_box_release(gates(i)%dirichlet_bc%box, error=error) + CALL cs_box_release(gates(i)%dirichlet_bc%box) ELSE - CALL cs_rectangle_release(gates(i)%dirichlet_bc%rectangle, error=error) + CALL cs_rectangle_release(gates(i)%dirichlet_bc%rectangle) END IF n_tiles = gates(i)%dirichlet_bc%n_tiles DO k = 1, n_tiles tile_geom = gates(i)%dirichlet_bc%tiles(k)%tile%tile_geom - CALL pw_release(gates(i)%dirichlet_bc%tiles(k)%tile%tile_pw, error=error) + CALL pw_release(gates(i)%dirichlet_bc%tiles(k)%tile%tile_pw) IF (tile_geom .EQ. rectangular_tile) THEN - CALL cs_rectangle_release(gates(i)%dirichlet_bc%tiles(k)%tile%rectangle, error) + CALL cs_rectangle_release(gates(i)%dirichlet_bc%tiles(k)%tile%rectangle) ELSE IF (tile_geom .EQ. cuboidal_tile) THEN - CALL cs_box_release(gates(i)%dirichlet_bc%tiles(k)%tile%box, error) + CALL cs_box_release(gates(i)%dirichlet_bc%tiles(k)%tile%box) END IF DEALLOCATE(gates(i)%dirichlet_bc%tiles(k)%tile) @@ -366,17 +363,14 @@ END SUBROUTINE dirichlet_boundary_region_release ! ***************************************************************************** !> \brief deallocates dirichlet_bc_parameters type !> \param dbc_params dbc parameters -!> \param error cp2k error -!> !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dirichlet_bc_parameters_dealloc(dbc_params, error) + SUBROUTINE dirichlet_bc_parameters_dealloc(dbc_params) TYPE(dirichlet_bc_parameters), & INTENT(INOUT) :: dbc_params - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'dirichlet_bc_parameters_dealloc', & @@ -424,16 +418,14 @@ END SUBROUTINE dirichlet_bc_parameters_dealloc !> \param segment the segment to be created !> \param A coordinates of the end point A !> \param B coordinates of the end point B -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_segment_create(segment, A, B, error) + SUBROUTINE cs_segment_create(segment, A, B) TYPE(cs_segment), INTENT(INOUT), POINTER :: segment REAL(dp), DIMENSION(3), INTENT(IN) :: A, B - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_segment_create', & routineP = moduleN//':'//routineN @@ -456,17 +448,15 @@ END SUBROUTINE cs_segment_create !> \param A coordinates of the vertex A !> \param B coordinates of the vertex B !> \param tag unique tag to be assigned to the edge -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_edge_create(edge, A, B, tag, error) + SUBROUTINE cs_edge_create(edge, A, B, tag) TYPE(cs_edge), INTENT(INOUT), POINTER :: edge REAL(dp), DIMENSION(3), INTENT(IN) :: A, B INTEGER, INTENT(IN) :: tag - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_edge_create', & routineP = moduleN//':'//routineN @@ -476,7 +466,7 @@ SUBROUTINE cs_edge_create(edge, A, B, tag, error) CALL timeset(routineN,handle) ALLOCATE(edge%segment) - CALL cs_segment_create(edge%segment, A, B, error) + CALL cs_segment_create(edge%segment, A, B) edge%tag = tag CALL timestop(handle) @@ -489,16 +479,14 @@ END SUBROUTINE cs_edge_create !> \param A coordinates of the vertex A !> \param B coordinates of the vertex B !> \param C coordinates of the vertex C -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_plane_ABC_create(plane, A, B, C, error) + SUBROUTINE cs_plane_ABC_create(plane, A, B, C) TYPE(cs_plane), INTENT(INOUT), POINTER :: plane REAL(dp), DIMENSION(3), INTENT(IN) :: A, B, C - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_plane_ABC_create', & routineP = moduleN//':'//routineN @@ -524,8 +512,8 @@ SUBROUTINE cs_plane_ABC_create(plane, A, B, C, error) plane%C = C ALLOCATE(plane%AB, plane%AC) - CALL cs_segment_create(plane%AB, A, B, error) - CALL cs_segment_create(plane%AC, A, C, error) + CALL cs_segment_create(plane%AB, A, B) + CALL cs_segment_create(plane%AC, A, C) AB_norm = SQRT(SUM(AB**2)) AC_norm = SQRT(SUM(AC**2)) @@ -534,11 +522,11 @@ SUBROUTINE cs_plane_ABC_create(plane, A, B, C, error) IF ( (AB_norm .LE. small_value) .OR. (AC_norm.LE. small_value) .OR. (BC_norm .LE. small_value) ) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Not enough points to define a cartesian space plane. "//& - "Please increase the cutoff.",error) + "Please increase the cutoff.") ELSE IF ( SUM(ABS(ABxAC)) .LE. small_value ) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Unable to define a cartesian space plane. Reason: A, B, C are collinear. "//& - "Please increase the cutoff.",error) + "Please increase the cutoff.") ELSE plane%normal = ABxAC plane%unit_normal = plane%normal / SQRT(SUM(plane%normal**2)) @@ -556,16 +544,14 @@ END SUBROUTINE cs_plane_ABC_create !> \param plane the plane to be created !> \param A coordinates of a point on the plane !> \param n the unit normal vector to the plane -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_plane_An_create(plane, A, n, error) + SUBROUTINE cs_plane_An_create(plane, A, n) TYPE(cs_plane), INTENT(INOUT), POINTER :: plane REAL(dp), DIMENSION(3), INTENT(IN) :: A, n - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_plane_An_create', & routineP = moduleN//':'//routineN @@ -604,8 +590,8 @@ SUBROUTINE cs_plane_An_create(plane, A, n, error) plane%C = C ALLOCATE(plane%AB, plane%AC) - CALL cs_segment_create(plane%AB, A, B, error) - CALL cs_segment_create(plane%AC, A, C, error) + CALL cs_segment_create(plane%AB, A, B) + CALL cs_segment_create(plane%AC, A, C) ! NB: the Housholder procedure is quite stable no need to check if the points are collinear ! or any two of them coincide plane%normal = n @@ -623,17 +609,15 @@ END SUBROUTINE cs_plane_An_create !> \param A coordinates of the vertex A !> \param B coordinates of the vertex B !> \param C coordinates of the vertex C -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_triangle_create(triangle, A, B, C, error) + SUBROUTINE cs_triangle_create(triangle, A, B, C) TYPE(cs_triangle), INTENT(INOUT), & POINTER :: triangle REAL(dp), DIMENSION(3), INTENT(IN) :: A, B, C - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_triangle_create', & routineP = moduleN//':'//routineN @@ -648,18 +632,18 @@ SUBROUTINE cs_triangle_create(triangle, A, B, C, error) triangle%B = B triangle%C = C ALLOCATE(triangle%plane) - CALL cs_plane_create(triangle%plane, A, B, C, error) + CALL cs_plane_create(triangle%plane, A, B, C) triangle%vertices(:,1) = A triangle%vertices(:,2) = B triangle%vertices(:,3) = C - CALL sort_vertices(triangle%vertices, A, triangle%plane%unit_normal, error) + CALL sort_vertices(triangle%vertices, A, triangle%plane%unit_normal) tri_vertices = triangle%vertices ALLOCATE(edge) DO i = 0, 2 tag = (i+1)*10 + MOD(i+1, 3)+1 - CALL cs_edge_create(edge, tri_vertices(:,i), tri_vertices(:,MOD(i+1, 3)), tag, error) + CALL cs_edge_create(edge, tri_vertices(:,i), tri_vertices(:,MOD(i+1, 3)), tag) triangle%edges(i+1) = edge END DO DEALLOCATE(edge) @@ -675,17 +659,15 @@ END SUBROUTINE cs_triangle_create !> \param B coordinates of the vertex B !> \param C coordinates of the vertex C !> \param D coordinates of the vertex D -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_rectangle_ABCD_create(rectangle, A, B, C, D, error) + SUBROUTINE cs_rectangle_ABCD_create(rectangle, A, B, C, D) TYPE(cs_rectangle), INTENT(INOUT), & POINTER :: rectangle REAL(dp), DIMENSION(3), INTENT(IN) :: A, B, C, D - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_rectangle_ABCD_create', & routineP = moduleN//':'//routineN @@ -701,19 +683,19 @@ SUBROUTINE cs_rectangle_ABCD_create(rectangle, A, B, C, D, error) rectangle%C = C rectangle%D = D ALLOCATE(rectangle%plane) - CALL cs_plane_create(rectangle%plane, A, B, C, error) + CALL cs_plane_create(rectangle%plane, A, B, C) rectangle%vertices(:,1) = A rectangle%vertices(:,2) = B rectangle%vertices(:,3) = C rectangle%vertices(:,4) = D - CALL sort_vertices(rectangle%vertices, A, rectangle%plane%unit_normal, error) + CALL sort_vertices(rectangle%vertices, A, rectangle%plane%unit_normal) rect_vertices = rectangle%vertices ALLOCATE(edge) DO i = 0, 3 tag = (i+1)*10 + MOD(i+1, 4)+1 - CALL cs_edge_create(edge, rect_vertices(:,i), rect_vertices(:,MOD(i+1, 4)), tag, error) + CALL cs_edge_create(edge, rect_vertices(:,i), rect_vertices(:,MOD(i+1, 4)), tag) rectangle%edges(i+1) = edge END DO DEALLOCATE(edge) @@ -730,17 +712,15 @@ END SUBROUTINE cs_rectangle_ABCD_create !> \param A coordinates of the vertex A !> \param B coordinates of the vertex B !> \param C coordinates of the vertex C -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_rectangle_ABC_create(rectangle, A, B, C, error) + SUBROUTINE cs_rectangle_ABC_create(rectangle, A, B, C) TYPE(cs_rectangle), INTENT(INOUT), & POINTER :: rectangle REAL(dp), DIMENSION(3), INTENT(IN) :: A, B, C - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_rectangle_ABC_create', & routineP = moduleN//':'//routineN @@ -759,19 +739,19 @@ SUBROUTINE cs_rectangle_ABC_create(rectangle, A, B, C, error) rectangle%C = C rectangle%D = D ALLOCATE(rectangle%plane) - CALL cs_plane_create(rectangle%plane, A, B, C, error) + CALL cs_plane_create(rectangle%plane, A, B, C) rectangle%vertices(:,1) = A rectangle%vertices(:,2) = B rectangle%vertices(:,3) = C rectangle%vertices(:,4) = D - CALL sort_vertices(rectangle%vertices, A, rectangle%plane%unit_normal, error) + CALL sort_vertices(rectangle%vertices, A, rectangle%plane%unit_normal) rect_vertices = rectangle%vertices ALLOCATE(edge) DO i = 0, 3 tag = (i+1)*10 + MOD(i+1, 4)+1 - CALL cs_edge_create(edge, rect_vertices(:,i), rect_vertices(:,MOD(i+1, 4)), tag, error) + CALL cs_edge_create(edge, rect_vertices(:,i), rect_vertices(:,MOD(i+1, 4)), tag) rectangle%edges(i+1) = edge END DO DEALLOCATE(edge) @@ -784,17 +764,15 @@ END SUBROUTINE cs_rectangle_ABC_create !> \brief generates a polygon given the coordinates of its vertices !> \param polygon the polygon to be created !> \param vertices coordinates of the vertices of the polygon -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_polygon_create(polygon, vertices, error) + SUBROUTINE cs_polygon_create(polygon, vertices) TYPE(cs_polygon), INTENT(INOUT), POINTER :: polygon REAL(dp), DIMENSION(:, :), INTENT(IN), & POINTER :: vertices - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_polygon_create', & routineP = moduleN//':'//routineN @@ -819,7 +797,7 @@ SUBROUTINE cs_polygon_create(polygon, vertices, error) B = vertices(:,2) C = vertices(:,3) IF (num_vertices .EQ. 3) THEN - CALL cs_plane_create(polygon%plane, A, B, C, error) + CALL cs_plane_create(polygon%plane, A, B, C) ELSE ! this is a 3-sum problem but the number of vertices is limited so ! a naive implementation should be alright @@ -843,7 +821,7 @@ SUBROUTINE cs_polygon_create(polygon, vertices, error) END DO ! if no 3 vertices are noncollinear, the solution will be using a higher ! cutoff. This will be captured here: - CALL cs_plane_create(polygon%plane, A, B, C, error) + CALL cs_plane_create(polygon%plane, A, B, C) END IF ! assume vertices are already sorted @@ -852,7 +830,7 @@ SUBROUTINE cs_polygon_create(polygon, vertices, error) ALLOCATE(edge) DO i = 0, num_vertices-1 tag = (i+1)*10 + MOD(i+1, num_vertices)+1 - CALL cs_edge_create(edge, py_vertices(:,i), py_vertices(:,MOD(i+1, num_vertices)), tag, error) + CALL cs_edge_create(edge, py_vertices(:,i), py_vertices(:,MOD(i+1, num_vertices)), tag) polygon%edges(i+1) = edge END DO DEALLOCATE(edge) @@ -868,17 +846,15 @@ END SUBROUTINE cs_polygon_create !> \param B coordinates of the vertex B !> \param C coordinates of the vertex C !> \param tag unique tag to be assigned to the face -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_face_create(face, A, B, C, tag, error) + SUBROUTINE cs_face_create(face, A, B, C, tag) TYPE(cs_face), INTENT(INOUT), POINTER :: face REAL(dp), DIMENSION(3), INTENT(IN) :: A, B, C INTEGER, INTENT(IN) :: tag - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_face_create', & routineP = moduleN//':'//routineN @@ -888,7 +864,7 @@ SUBROUTINE cs_face_create(face, A, B, C, tag, error) CALL timeset(routineN,handle) ALLOCATE(face%rectangle) - CALL cs_rectangle_create(face%rectangle, A, B, C, error) + CALL cs_rectangle_create(face%rectangle, A, B, C) face%tag = tag CALL timestop(handle) @@ -900,16 +876,14 @@ END SUBROUTINE cs_face_create !> coordinates of its vertices !> \param box the box to be generated !> \param vertices vertices of the box -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_box_create(box, vertices, error) + SUBROUTINE cs_box_create(box, vertices) TYPE(cs_box), INTENT(INOUT), POINTER :: box REAL(dp), DIMENSION(3, 8), INTENT(IN) :: vertices - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_box_create', & routineP = moduleN//':'//routineN @@ -931,25 +905,25 @@ SUBROUTINE cs_box_create(box, vertices, error) ! |/ |/ ! 2--------3 ! faces are taged in a way that vertices are counter-clockwise with respect to the outer unit normal to the face - CALL cs_face_create(face, vertices(:,2), vertices(:,1), vertices(:,4), 1432, error); box%faces(1) = face - CALL cs_face_create(face, vertices(:,1), vertices(:,6), vertices(:,5), 1654, error); box%faces(2) = face - CALL cs_face_create(face, vertices(:,2), vertices(:,7), vertices(:,6), 2761, error); box%faces(3) = face - CALL cs_face_create(face, vertices(:,6), vertices(:,7), vertices(:,8), 6785, error); box%faces(4) = face - CALL cs_face_create(face, vertices(:,7), vertices(:,2), vertices(:,3), 7238, error); box%faces(5) = face - CALL cs_face_create(face, vertices(:,8), vertices(:,3), vertices(:,4), 8345, error); box%faces(6) = face - - CALL cs_edge_create(edge, vertices(:,1), vertices(:,2), 12, error); box%edges(1) = edge - CALL cs_edge_create(edge, vertices(:,2), vertices(:,3), 23, error); box%edges(2) = edge - CALL cs_edge_create(edge, vertices(:,3), vertices(:,4), 34, error); box%edges(3) = edge - CALL cs_edge_create(edge, vertices(:,4), vertices(:,1), 41, error); box%edges(4) = edge - CALL cs_edge_create(edge, vertices(:,5), vertices(:,6), 56, error); box%edges(5) = edge - CALL cs_edge_create(edge, vertices(:,6), vertices(:,7), 67, error); box%edges(6) = edge - CALL cs_edge_create(edge, vertices(:,7), vertices(:,8), 78, error); box%edges(7) = edge - CALL cs_edge_create(edge, vertices(:,8), vertices(:,5), 85, error); box%edges(8) = edge - CALL cs_edge_create(edge, vertices(:,7), vertices(:,2), 72, error); box%edges(9) = edge - CALL cs_edge_create(edge, vertices(:,8), vertices(:,3), 83, error); box%edges(10) = edge - CALL cs_edge_create(edge, vertices(:,5), vertices(:,4), 54, error); box%edges(11) = edge - CALL cs_edge_create(edge, vertices(:,6), vertices(:,1), 61, error); box%edges(12) = edge + CALL cs_face_create(face, vertices(:,2), vertices(:,1), vertices(:,4), 1432); box%faces(1) = face + CALL cs_face_create(face, vertices(:,1), vertices(:,6), vertices(:,5), 1654); box%faces(2) = face + CALL cs_face_create(face, vertices(:,2), vertices(:,7), vertices(:,6), 2761); box%faces(3) = face + CALL cs_face_create(face, vertices(:,6), vertices(:,7), vertices(:,8), 6785); box%faces(4) = face + CALL cs_face_create(face, vertices(:,7), vertices(:,2), vertices(:,3), 7238); box%faces(5) = face + CALL cs_face_create(face, vertices(:,8), vertices(:,3), vertices(:,4), 8345); box%faces(6) = face + + CALL cs_edge_create(edge, vertices(:,1), vertices(:,2), 12); box%edges(1) = edge + CALL cs_edge_create(edge, vertices(:,2), vertices(:,3), 23); box%edges(2) = edge + CALL cs_edge_create(edge, vertices(:,3), vertices(:,4), 34); box%edges(3) = edge + CALL cs_edge_create(edge, vertices(:,4), vertices(:,1), 41); box%edges(4) = edge + CALL cs_edge_create(edge, vertices(:,5), vertices(:,6), 56); box%edges(5) = edge + CALL cs_edge_create(edge, vertices(:,6), vertices(:,7), 67); box%edges(6) = edge + CALL cs_edge_create(edge, vertices(:,7), vertices(:,8), 78); box%edges(7) = edge + CALL cs_edge_create(edge, vertices(:,8), vertices(:,5), 85); box%edges(8) = edge + CALL cs_edge_create(edge, vertices(:,7), vertices(:,2), 72); box%edges(9) = edge + CALL cs_edge_create(edge, vertices(:,8), vertices(:,3), 83); box%edges(10) = edge + CALL cs_edge_create(edge, vertices(:,5), vertices(:,4), 54); box%edges(11) = edge + CALL cs_edge_create(edge, vertices(:,6), vertices(:,1), 61); box%edges(12) = edge DEALLOCATE(edge, face) @@ -962,17 +936,15 @@ END SUBROUTINE cs_box_create !> \param intersection the intersection object to be created !> \param intxn_type intersection type !> \param n_intersections the number of vertices of the intersection object -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_intersection_obj_create(intersection, intxn_type, n_intersections, error) + SUBROUTINE cs_intersection_obj_create(intersection, intxn_type, n_intersections) TYPE(cs_intersection_obj), POINTER :: intersection INTEGER, INTENT(IN) :: intxn_type INTEGER, INTENT(IN), OPTIONAL :: n_intersections - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_intersection_obj_create', & routineP = moduleN//':'//routineN @@ -1017,12 +989,11 @@ END SUBROUTINE cs_intersection_obj_create !> \param grid_segment_index the indices of the coordinates of the vertex labeled 'A' !> \param dr the grid spacing !> \param alignment the alignment of the segment -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, alignment, error) + SUBROUTINE cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, alignment) TYPE(cs_grid_segment), INTENT(INOUT), & POINTER :: grid_seg @@ -1030,7 +1001,6 @@ SUBROUTINE cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, alig INTEGER, DIMENSION(3), INTENT(IN) :: grid_segment_index REAL(dp), DIMENSION(3), INTENT(IN) :: dr INTEGER, INTENT(IN) :: alignment - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_grid_segment_create', & routineP = moduleN//':'//routineN @@ -1064,7 +1034,7 @@ SUBROUTINE cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, alig END SELECT ALLOCATE(grid_seg%segment) - CALL cs_segment_create(grid_seg%segment, A, B, error) + CALL cs_segment_create(grid_seg%segment, A, B) grid_seg%is_on = .FALSE. @@ -1080,12 +1050,11 @@ END SUBROUTINE cs_grid_segment_create !> \param grid_tile_index the indices of the coordinates of the vertex labeled 'A' !> \param dr the grid spacing !> \param alignment alignment of the tile -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, alignment, error) + SUBROUTINE cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, alignment) TYPE(cs_grid_tile), INTENT(INOUT), & POINTER :: grid_tile @@ -1093,7 +1062,6 @@ SUBROUTINE cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, alignment INTEGER, DIMENSION(3), INTENT(IN) :: grid_tile_index REAL(dp), DIMENSION(3), INTENT(IN) :: dr INTEGER, INTENT(IN) :: alignment - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_grid_tile_create', & routineP = moduleN//':'//routineN @@ -1133,7 +1101,7 @@ SUBROUTINE cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, alignment END SELECT ALLOCATE(grid_tile%rectangle) - CALL cs_rectangle_create(grid_tile%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(grid_tile%rectangle, A, B, C, D) grid_tile%is_on = .FALSE. @@ -1148,18 +1116,16 @@ END SUBROUTINE cs_grid_tile_create !> \param origin the coordinates of the vertex labeled '1' !> \param voxel_index the indices of the coordinates of the vertex labeled '1' !> \param dr the grid spacing -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_voxel_create(voxel, origin, voxel_index, dr, error) + SUBROUTINE cs_voxel_create(voxel, origin, voxel_index, dr) TYPE(cs_voxel), INTENT(INOUT), POINTER :: voxel REAL(dp), DIMENSION(3), INTENT(IN) :: origin INTEGER, DIMENSION(3), INTENT(IN) :: voxel_index REAL(dp), DIMENSION(3), INTENT(IN) :: dr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_voxel_create', & routineP = moduleN//':'//routineN @@ -1189,7 +1155,7 @@ SUBROUTINE cs_voxel_create(voxel, origin, voxel_index, dr, error) vertices(:,8) = (/ox+dx, oy+dy, oz+dz/) ALLOCATE(voxel%box) - CALL cs_box_create(voxel%box, vertices, error) + CALL cs_box_create(voxel%box, vertices) voxel%is_on = .FALSE. @@ -1200,15 +1166,13 @@ END SUBROUTINE cs_voxel_create ! ***************************************************************************** !> \brief releases a cs_segment data object !> \param segment the segment to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_segment_release(segment, error) + SUBROUTINE cs_segment_release(segment) TYPE(cs_segment), POINTER :: segment - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_segment_release', & routineP = moduleN//':'//routineN @@ -1220,21 +1184,19 @@ END SUBROUTINE cs_segment_release ! ***************************************************************************** !> \brief releases a cs_edge data object !> \param edge the edge to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_edge_release(edge, error) + SUBROUTINE cs_edge_release(edge) TYPE(cs_edge), POINTER :: edge - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_edge_release', & routineP = moduleN//':'//routineN IF(ASSOCIATED(edge)) THEN - CALL cs_segment_release(edge%segment, error) + CALL cs_segment_release(edge%segment) DEALLOCATE(edge) END IF @@ -1243,15 +1205,13 @@ END SUBROUTINE cs_edge_release ! ***************************************************************************** !> \brief releases a cs_plane data object !> \param plane the plane to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_plane_release(plane, error) + SUBROUTINE cs_plane_release(plane) TYPE(cs_plane), POINTER :: plane - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_plane_release', & routineP = moduleN//':'//routineN @@ -1266,15 +1226,13 @@ END SUBROUTINE cs_plane_release ! ***************************************************************************** !> \brief releases a cs_triangle data object !> \param triangle the triangle to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_triangle_release(triangle, error) + SUBROUTINE cs_triangle_release(triangle) TYPE(cs_triangle), POINTER :: triangle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_triangle_release', & routineP = moduleN//':'//routineN @@ -1285,7 +1243,7 @@ SUBROUTINE cs_triangle_release(triangle, error) DO i = 1, 3 DEALLOCATE(triangle%edges(i)%segment) END DO - CALL cs_plane_release(triangle%plane, error) + CALL cs_plane_release(triangle%plane) DEALLOCATE(triangle) END IF @@ -1294,15 +1252,13 @@ END SUBROUTINE cs_triangle_release ! ***************************************************************************** !> \brief releases a cs_rectangle data object !> \param rectangle the rectangle to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_rectangle_release(rectangle, error) + SUBROUTINE cs_rectangle_release(rectangle) TYPE(cs_rectangle), POINTER :: rectangle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_rectangle_release', & routineP = moduleN//':'//routineN @@ -1313,7 +1269,7 @@ SUBROUTINE cs_rectangle_release(rectangle, error) DO i = 1, 4 DEALLOCATE(rectangle%edges(i)%segment) END DO - CALL cs_plane_release(rectangle%plane, error) + CALL cs_plane_release(rectangle%plane) DEALLOCATE(rectangle) END IF @@ -1322,15 +1278,13 @@ END SUBROUTINE cs_rectangle_release ! ***************************************************************************** !> \brief releases a cs_polygon data type !> \param polygon the polygon to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_polygon_release(polygon, error) + SUBROUTINE cs_polygon_release(polygon) TYPE(cs_polygon), POINTER :: polygon - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_polygon_release', & routineP = moduleN//':'//routineN @@ -1343,7 +1297,7 @@ SUBROUTINE cs_polygon_release(polygon, error) DEALLOCATE(polygon%edges(i)%segment) END DO DEALLOCATE(polygon%edges) - CALL cs_plane_release(polygon%plane, error) + CALL cs_plane_release(polygon%plane) DEALLOCATE(polygon) END IF @@ -1352,21 +1306,19 @@ END SUBROUTINE cs_polygon_release ! ***************************************************************************** !> \brief releases a cs_face data object !> \param face the face to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_face_release(face, error) + SUBROUTINE cs_face_release(face) TYPE(cs_face), POINTER :: face - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_face_release', & routineP = moduleN//':'//routineN IF(ASSOCIATED(face)) THEN - CALL cs_rectangle_release(face%rectangle, error) + CALL cs_rectangle_release(face%rectangle) DEALLOCATE(face) END IF @@ -1375,15 +1327,13 @@ END SUBROUTINE cs_face_release ! ***************************************************************************** !> \brief releases a cs_box data object !> \param box the box to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_box_release(box, error) + SUBROUTINE cs_box_release(box) TYPE(cs_box), POINTER :: box - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_box_release', & routineP = moduleN//':'//routineN @@ -1395,7 +1345,7 @@ SUBROUTINE cs_box_release(box, error) DEALLOCATE(box%edges(i)%segment) END DO DO i = 1, 6 - CALL cs_rectangle_release(box%faces(i)%rectangle, error) + CALL cs_rectangle_release(box%faces(i)%rectangle) END DO DEALLOCATE(box) END IF @@ -1405,15 +1355,13 @@ END SUBROUTINE cs_box_release ! ***************************************************************************** !> \brief releases a cs_intersection data object !> \param intersection the intersection object to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_intersection_obj_release(intersection, error) + SUBROUTINE cs_intersection_obj_release(intersection) TYPE(cs_intersection_obj), POINTER :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_intersection_obj_release', & routineP = moduleN//':'//routineN @@ -1425,13 +1373,13 @@ SUBROUTINE cs_intersection_obj_release(intersection, error) CASE(PT_INTXN) ! do nothing CASE(SEG_INTXN) - CALL cs_segment_release(intersection%segment, error) + CALL cs_segment_release(intersection%segment) CASE(TRI_INTXN) - CALL cs_triangle_release(intersection%triangle, error) + CALL cs_triangle_release(intersection%triangle) CASE(RECT_INTXN) - CALL cs_rectangle_release(intersection%rectangle, error) + CALL cs_rectangle_release(intersection%rectangle) CASE(PY_INTXN) - CALL cs_polygon_release(intersection%polygon, error) + CALL cs_polygon_release(intersection%polygon) END SELECT DEALLOCATE(intersection) END IF @@ -1441,21 +1389,19 @@ END SUBROUTINE cs_intersection_obj_release ! ***************************************************************************** !> \brief releases a cs_grid_segment data object !> \param grid_seg the grid_segment to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_grid_segment_release(grid_seg, error) + SUBROUTINE cs_grid_segment_release(grid_seg) TYPE(cs_grid_segment), POINTER :: grid_seg - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_grid_segment_release', & routineP = moduleN//':'//routineN IF(ASSOCIATED(grid_seg)) THEN - CALL cs_segment_release(grid_seg%segment, error) + CALL cs_segment_release(grid_seg%segment) DEALLOCATE(grid_seg) END IF @@ -1464,21 +1410,19 @@ END SUBROUTINE cs_grid_segment_release ! ***************************************************************************** !> \brief releases a cs_grid_tile data object !> \param grid_tile the grid_tile to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_grid_tile_release(grid_tile, error) + SUBROUTINE cs_grid_tile_release(grid_tile) TYPE(cs_grid_tile), POINTER :: grid_tile - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_grid_tile_release', & routineP = moduleN//':'//routineN IF(ASSOCIATED(grid_tile)) THEN - CALL cs_rectangle_release(grid_tile%rectangle, error) + CALL cs_rectangle_release(grid_tile%rectangle) DEALLOCATE(grid_tile) END IF @@ -1487,21 +1431,19 @@ END SUBROUTINE cs_grid_tile_release ! ***************************************************************************** !> \brief releases a cs_voxel data object !> \param voxel the voxel to be released -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cs_voxel_release(voxel, error) + SUBROUTINE cs_voxel_release(voxel) TYPE(cs_voxel), POINTER :: voxel - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cs_voxel_release', & routineP = moduleN//':'//routineN IF(ASSOCIATED(voxel)) THEN - CALL cs_box_release(voxel%box, error) + CALL cs_box_release(voxel%box) DEALLOCATE(voxel) END IF @@ -1520,16 +1462,14 @@ END SUBROUTINE cs_voxel_release !> \param vertices the vertices to be sorted !> \param O reference vertex !> \param unit_normal the unit normal to the polygon's plane -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE sort_vertices(vertices, O, unit_normal, error) + SUBROUTINE sort_vertices(vertices, O, unit_normal) REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: vertices REAL(dp), DIMENSION(3), INTENT(IN) :: O, unit_normal - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sort_vertices', & routineP = moduleN//':'//routineN @@ -1618,16 +1558,14 @@ END SUBROUTINE sort_vertices !> \brief casts a triangle to a polygon !> \param triangle the triangle to be casted !> \param polygon the output polygon -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cast_triangle_to_polygon(triangle, polygon, error) + SUBROUTINE cast_triangle_to_polygon(triangle, polygon) TYPE(cs_triangle), INTENT(IN), POINTER :: triangle TYPE(cs_polygon), INTENT(INOUT), POINTER :: polygon - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cast_triangle_to_polygon', & routineP = moduleN//':'//routineN @@ -1638,7 +1576,7 @@ SUBROUTINE cast_triangle_to_polygon(triangle, polygon, error) CALL timeset(routineN,handle) py_vertices => triangle%vertices - CALL cs_polygon_create(polygon, py_vertices, error=error) + CALL cs_polygon_create(polygon, py_vertices) CALL timestop(handle) @@ -1648,16 +1586,14 @@ END SUBROUTINE cast_triangle_to_polygon !> \brief casts a rectangle to a polygon !> \param rectangle the rectangle to be casted !> \param polygon the output polygon -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE cast_rectangle_to_polygon(rectangle, polygon, error) + SUBROUTINE cast_rectangle_to_polygon(rectangle, polygon) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle TYPE(cs_polygon), INTENT(INOUT), POINTER :: polygon - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cast_rectangle_to_polygon', & routineP = moduleN//':'//routineN @@ -1668,7 +1604,7 @@ SUBROUTINE cast_rectangle_to_polygon(rectangle, polygon, error) CALL timeset(routineN,handle) py_vertices => rectangle%vertices - CALL cs_polygon_create(polygon, py_vertices, error=error) + CALL cs_polygon_create(polygon, py_vertices) CALL timestop(handle) diff --git a/src/pw/dirichlet_bc_utils.F b/src/pw/dirichlet_bc_utils.F index c358e5d58c..24affa1147 100644 --- a/src/pw/dirichlet_bc_utils.F +++ b/src/pw/dirichlet_bc_utils.F @@ -311,18 +311,16 @@ END FUNCTION is_inside_polygon !> \brief Removes duplicate vertices from an array of vertices !> \param vertices_in array containing the coordinates of a set of vertices !> \param vertices_out array containing unique vertices in vertices_in -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE remove_duplicate_vertices(vertices_in, vertices_out, error) + SUBROUTINE remove_duplicate_vertices(vertices_in, vertices_out) REAL(dp), ALLOCATABLE, DIMENSION(:, :), & INTENT(IN) :: vertices_in REAL(dp), ALLOCATABLE, DIMENSION(:, :), & INTENT(OUT) :: vertices_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_duplicate_vertices', & routineP = moduleN//':'//routineN @@ -366,13 +364,12 @@ END SUBROUTINE remove_duplicate_vertices !> \param z_locl z grid vetor of the simulation box local to this process !> \param aabb_extents global extents !> \param aabb_extents_local local extents -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE compute_rectangle_aabb_extents(rectangle, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, aabb_extents, aabb_extents_local, error) + x_locl, y_locl, z_locl, aabb_extents, aabb_extents_local) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle REAL(dp), ALLOCATABLE, DIMENSION(:), & @@ -380,7 +377,6 @@ SUBROUTINE compute_rectangle_aabb_extents(rectangle, x_glbl, y_glbl, z_glbl, & x_locl, y_locl, z_locl INTEGER, DIMENSION(2, 3), INTENT(OUT) :: aabb_extents, & aabb_extents_local - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'compute_rectangle_aabb_extents', & @@ -479,12 +475,11 @@ END SUBROUTINE compute_rectangle_aabb_extents !> \param phi the rotation angle !> \param rot_axis the rotation axis !> \param project whether or not to project -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE rotate_rectangle_onto_plane(rectangle, plane, rectangle_rot, phi, rot_axis, project, error) + SUBROUTINE rotate_rectangle_onto_plane(rectangle, plane, rectangle_rot, phi, rot_axis, project) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle TYPE(cs_plane), INTENT(IN), POINTER :: plane @@ -494,7 +489,6 @@ SUBROUTINE rotate_rectangle_onto_plane(rectangle, plane, rectangle_rot, phi, rot REAL(dp), DIMENSION(3), INTENT(OUT), & OPTIONAL :: rot_axis LOGICAL, INTENT(IN), OPTIONAL :: project - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rotate_rectangle_onto_plane', & routineP = moduleN//':'//routineN @@ -521,10 +515,10 @@ SUBROUTINE rotate_rectangle_onto_plane(rectangle, plane, rectangle_rot, phi, rot IF (ABS(ABS(n1dotn2) - 1) .LE. small_value) THEN ! project it onto the plane if the user wants IF (intern_project .EQV. .TRUE.) THEN - CALL project_rectangle_onto_plane(rectangle, plane, rectangle_rot, error) + CALL project_rectangle_onto_plane(rectangle, plane, rectangle_rot) ELSE CALL cs_rectangle_create(rectangle_rot, rectangle%A, rectangle%B, & - rectangle%C, rectangle%D, error) + rectangle%C, rectangle%D) ! rectangle_rot = rectangle END IF intern_rot_axis = n2 @@ -536,11 +530,11 @@ SUBROUTINE rotate_rectangle_onto_plane(rectangle, plane, rectangle_rot, phi, rot intern_phi = angle(n1, n2) ALLOCATE(rectangle_tmp) - CALL rotate_rectangle(rectangle, intern_phi, intern_rot_axis, FWROT, rectangle_tmp, error) + CALL rotate_rectangle(rectangle, intern_phi, intern_rot_axis, FWROT, rectangle_tmp) IF (intern_project .EQV. .TRUE.) THEN - CALL project_rectangle_onto_plane(rectangle_tmp, plane, rectangle_rot, error) - CALL cs_rectangle_release(rectangle_tmp, error=error) + CALL project_rectangle_onto_plane(rectangle_tmp, plane, rectangle_rot) + CALL cs_rectangle_release(rectangle_tmp) ELSE rectangle_rot = rectangle_tmp DEALLOCATE(rectangle_tmp) @@ -561,12 +555,11 @@ END SUBROUTINE rotate_rectangle_onto_plane !> \param rot_axis the rotation axis !> \param direction forward or backward rotation !> \param rectangle_rot the rotated rectangle -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE rotate_rectangle(rectangle, phi, rot_axis, direction, rectangle_rot, error) + SUBROUTINE rotate_rectangle(rectangle, phi, rot_axis, direction, rectangle_rot) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle REAL(dp), INTENT(IN) :: phi @@ -574,7 +567,6 @@ SUBROUTINE rotate_rectangle(rectangle, phi, rot_axis, direction, rectangle_rot, INTEGER, INTENT(IN) :: direction TYPE(cs_rectangle), INTENT(INOUT), & POINTER :: rectangle_rot - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rotate_rectangle', & routineP = moduleN//':'//routineN @@ -595,7 +587,7 @@ SUBROUTINE rotate_rectangle(rectangle, phi, rot_axis, direction, rectangle_rot, Bprime = rotate_vector(rectangle%B, intern_phi, rot_axis) Cprime = rotate_vector(rectangle%C, intern_phi, rot_axis) Dprime = rotate_vector(rectangle%D, intern_phi, rot_axis) - CALL cs_rectangle_create(rectangle_rot, Aprime, Bprime, Cprime, Dprime, error) + CALL cs_rectangle_create(rectangle_rot, Aprime, Bprime, Cprime, Dprime) CALL timestop(handle) @@ -612,12 +604,11 @@ END SUBROUTINE rotate_rectangle !> \param rot_axis1 the first rotation axis !> \param phi2 the second rotation angle !> \param rot_axis2 the second rotation axis -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE convert_to_aa_rectangle(rectangle, rectangle_aa, phi1, rot_axis1, phi2, rot_axis2, error) + SUBROUTINE convert_to_aa_rectangle(rectangle, rectangle_aa, phi1, rot_axis1, phi2, rot_axis2) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle TYPE(cs_rectangle), INTENT(INOUT), & @@ -626,7 +617,6 @@ SUBROUTINE convert_to_aa_rectangle(rectangle, rectangle_aa, phi1, rot_axis1, phi REAL(dp), DIMENSION(3), INTENT(OUT) :: rot_axis1 REAL(dp), INTENT(OUT) :: phi2 REAL(dp), DIMENSION(3), INTENT(OUT) :: rot_axis2 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_to_aa_rectangle', & routineP = moduleN//':'//routineN @@ -646,9 +636,9 @@ SUBROUTINE convert_to_aa_rectangle(rectangle, rectangle_aa, phi1, rot_axis1, phi l = MAXLOC(ABS(rectangle%plane%unit_normal),1) p_normal = 0.0_dp p_normal(l) = 1.0_dp - CALL cs_plane_create(plane, O, p_normal, error) + CALL cs_plane_create(plane, O, p_normal) ! rotate the rectangle onto the plane - CALL rotate_rectangle_onto_plane(rectangle, plane, rectangle_rot, phi1, rot_axis1, .FALSE., error) + CALL rotate_rectangle_onto_plane(rectangle, plane, rectangle_rot, phi1, rot_axis1, .FALSE.) ! test if the rotated rectangle is axis-aligned AB = rectangle_rot%B - rectangle_rot%A @@ -665,7 +655,7 @@ SUBROUTINE convert_to_aa_rectangle(rectangle, rectangle_aa, phi1, rot_axis1, phi rot_axis2 = rot_axis1 phi2 = 0.0_dp CALL cs_rectangle_create(rectangle_aa, rectangle_rot%A, rectangle_rot%B, & - rectangle_rot%C, rectangle_rot%D, error) + rectangle_rot%C, rectangle_rot%D) ELSE IF (ABS(ABS(AB_e1_ang*degree) - 90.0_dp) .LE. small_value) THEN rot_axis2 = e1 @@ -692,11 +682,11 @@ SUBROUTINE convert_to_aa_rectangle(rectangle, rectangle_aa, phi1, rot_axis1, phi phi2 = AB_e1_ang END IF END IF - CALL rotate_rectangle(rectangle_rot, phi2, rot_axis2, FWROT , rectangle_aa, error) + CALL rotate_rectangle(rectangle_rot, phi2, rot_axis2, FWROT , rectangle_aa) END IF - CALL cs_rectangle_release(rectangle_rot, error=error) - CALL cs_plane_release(plane, error=error) + CALL cs_rectangle_release(rectangle_rot) + CALL cs_plane_release(plane) CALL timestop(handle) END SUBROUTINE convert_to_aa_rectangle @@ -706,18 +696,16 @@ END SUBROUTINE convert_to_aa_rectangle !> \param rectangle the rectangle to be projected !> \param plane the given plane !> \param rectangle_proj the projected rectangle -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE project_rectangle_onto_plane(rectangle, plane, rectangle_proj, error) + SUBROUTINE project_rectangle_onto_plane(rectangle, plane, rectangle_proj) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle TYPE(cs_plane), INTENT(IN), POINTER :: plane TYPE(cs_rectangle), INTENT(INOUT), & POINTER :: rectangle_proj - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'project_rectangle_onto_plane', & routineP = moduleN//':'//routineN @@ -741,7 +729,7 @@ SUBROUTINE project_rectangle_onto_plane(rectangle, plane, rectangle_proj, error) Cprime = rectangle%C - ndotPC * plane%unit_normal Dprime = rectangle%D - ndotPD * plane%unit_normal - CALL cs_rectangle_create(rectangle_proj, Aprime, Bprime, Cprime, Dprime, error) + CALL cs_rectangle_create(rectangle_proj, Aprime, Bprime, Cprime, Dprime) CALL timestop(handle) @@ -757,12 +745,11 @@ END SUBROUTINE project_rectangle_onto_plane !> \param n_prtn vetor of size 3 specifying the number of times that the x, y and !> z interval (defining the region) should be partitioned into !> \param tiles the obtained tiles -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE partition_aa_rectangle_into_tiles(rectangle, x_glbl, y_glbl, z_glbl, n_prtn, tiles, error) + SUBROUTINE partition_aa_rectangle_into_tiles(rectangle, x_glbl, y_glbl, z_glbl, n_prtn, tiles) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle REAL(dp), ALLOCATABLE, DIMENSION(:), & @@ -770,7 +757,6 @@ SUBROUTINE partition_aa_rectangle_into_tiles(rectangle, x_glbl, y_glbl, z_glbl, INTEGER, DIMENSION(3), INTENT(IN) :: n_prtn TYPE(tile_p_type), DIMENSION(:), & INTENT(OUT), POINTER :: tiles - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'partition_aa_rectangle_into_tiles', & @@ -877,7 +863,7 @@ SUBROUTINE partition_aa_rectangle_into_tiles(rectangle, x_glbl, y_glbl, z_glbl, ALLOCATE(tiles(k)%tile) tiles(k)%tile%tile_id = k ALLOCATE(tiles(k)%tile%rectangle) - CALL cs_rectangle_create(tiles(k)%tile%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(tiles(k)%tile%rectangle, A, B, C, D) tiles(k)%tile%npts = xprtn_npts(i) * yprtn_npts(j) k = k + 1 @@ -897,7 +883,7 @@ SUBROUTINE partition_aa_rectangle_into_tiles(rectangle, x_glbl, y_glbl, z_glbl, ALLOCATE(tiles(k)%tile) tiles(k)%tile%tile_id = k ALLOCATE(tiles(k)%tile%rectangle) - CALL cs_rectangle_create(tiles(k)%tile%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(tiles(k)%tile%rectangle, A, B, C, D) tiles(k)%tile%npts = xprtn_npts(i) * zprtn_npts(j) k = k + 1 @@ -917,7 +903,7 @@ SUBROUTINE partition_aa_rectangle_into_tiles(rectangle, x_glbl, y_glbl, z_glbl, ALLOCATE(tiles(k)%tile) tiles(k)%tile%tile_id = k ALLOCATE(tiles(k)%tile%rectangle) - CALL cs_rectangle_create(tiles(k)%tile%rectangle, A, B, C, D, error) + CALL cs_rectangle_create(tiles(k)%tile%rectangle, A, B, C, D) tiles(k)%tile%npts = yprtn_npts(i) * zprtn_npts(j) k = k + 1 @@ -941,12 +927,11 @@ END SUBROUTINE partition_aa_rectangle_into_tiles !> \param n_prtn vetor of size 3 specifying the number of times that the x, y and !> z interval (defining the region) should be partitioned into !> \param tiles the obtained tiles -!> \param error cp2k error !> \par History !> 12.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE partition_aa_cuboid_into_tiles(box, x_glbl, y_glbl, z_glbl, n_prtn, tiles, error) + SUBROUTINE partition_aa_cuboid_into_tiles(box, x_glbl, y_glbl, z_glbl, n_prtn, tiles) TYPE(cs_box), INTENT(IN), POINTER :: box REAL(dp), ALLOCATABLE, DIMENSION(:), & @@ -954,7 +939,6 @@ SUBROUTINE partition_aa_cuboid_into_tiles(box, x_glbl, y_glbl, z_glbl, n_prtn, t INTEGER, DIMENSION(3), INTENT(IN) :: n_prtn TYPE(tile_p_type), DIMENSION(:), & INTENT(OUT), POINTER :: tiles - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'partition_aa_cuboid_into_tiles', & @@ -1043,7 +1027,7 @@ SUBROUTINE partition_aa_cuboid_into_tiles(box, x_glbl, y_glbl, z_glbl, n_prtn, t ALLOCATE(tiles(k)%tile) tiles(k)%tile%tile_id = k ALLOCATE(tiles(k)%tile%box) - CALL cs_box_create(tiles(k)%tile%box, tile_vtx, error) + CALL cs_box_create(tiles(k)%tile%box, tile_vtx) tiles(k)%tile%npts = xprtn_npts(ii)*yprtn_npts(jj)*zprtn_npts(kk) k = k + 1 @@ -1061,17 +1045,15 @@ END SUBROUTINE partition_aa_cuboid_into_tiles !> \param segment2 segment 2 !> \param plane the plane that includes both segment 1 and segment 2 !> \param intersection the intersection of the two segments -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE coplanar_segment_segment_intersection(segment1, segment2, plane, intersection, error) + SUBROUTINE coplanar_segment_segment_intersection(segment1, segment2, plane, intersection) TYPE(cs_segment), POINTER, INTENT(IN) :: segment1, segment2 TYPE(cs_plane), POINTER, INTENT(IN) :: plane TYPE(cs_intersection_obj), POINTER, INTENT(INOUT) :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'coplanar_segment_segment_intersection', & routineP = moduleN//':'//routineN @@ -1108,10 +1090,10 @@ SUBROUTINE coplanar_segment_segment_intersection(segment1, segment2, plane, inte tnum = SQRT(SUM(vector_product(AC, CD)**2)) tden = SQRT(SUM(vector_product(AB, CD)**2)) ! I might need to check if tden is non-zero or is less than small_val ???? - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = A + AB * tnum / tden ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error= error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF CALL timestop(handle) @@ -1148,18 +1130,16 @@ END SUBROUTINE coplanar_segment_segment_intersection !> \param segment input segment !> \param plane input plane !> \param intersection the intersection of the plane and the segment -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE segment_plane_intersection(segment, plane, intersection, error) + SUBROUTINE segment_plane_intersection(segment, plane, intersection) TYPE(cs_segment), INTENT(IN), POINTER :: segment TYPE(cs_plane), INTENT(IN), POINTER :: plane TYPE(cs_intersection_obj), & INTENT(INOUT), POINTER :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'segment_plane_intersection', & routineP = moduleN//':'//routineN @@ -1176,11 +1156,11 @@ SUBROUTINE segment_plane_intersection(segment, plane, intersection, error) IF (ABS(ndotAB) .LE. small_value) THEN ! AB is entirely on the plane ... return A and B IF ((plane%d - ndotA) .EQ. 0.0_dp) THEN - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) intersection%segment = segment ! 0 intersection ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF ! if AB and the plane are NOT parallel ELSE @@ -1189,11 +1169,11 @@ SUBROUTINE segment_plane_intersection(segment, plane, intersection, error) IF (((0 .LE. t) .AND. (t .LE. 1)) .OR. & (ABS(t) .LE. small_value) .OR. & (ABS(t-1) .LE. small_value)) THEN - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = segment%A + (t * segment%AB) ! 0 intersection ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF END IF @@ -1206,18 +1186,16 @@ END SUBROUTINE segment_plane_intersection !> \param segment input segment !> \param rectangle input rectangle !> \param intersection the intersection of the segment and the rectangle -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection, error) + SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection) TYPE(cs_segment), INTENT(IN), POINTER :: segment TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle TYPE(cs_intersection_obj), & INTENT(INOUT), POINTER :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'segment_rectangle_intersection', & @@ -1238,18 +1216,18 @@ SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection, erro plane => rectangle%plane ! check if the segment crosses the rectangle's plane - CALL segment_plane_intersection(segment, plane, seg_pln_intxn, error) + CALL segment_plane_intersection(segment, plane, seg_pln_intxn) SELECT CASE (seg_pln_intxn%intxn_type) ! the segment does not cross the rectangle's plane CASE (NO_INTXN) - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) ! the segment crosses the rectangle's plane at one point CASE (PT_INTXN) IF (is_inside_rectangle(seg_pln_intxn%point, rectangle)) THEN - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = seg_pln_intxn%point ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF ! the segment and the rectangle are coplanar CASE (SEG_INTXN) @@ -1258,7 +1236,7 @@ SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection, erro ! the both ends of the segment, A and B, are inside the rectangle IF (is_inside_rectangle(A, rectangle) .AND. is_inside_rectangle(B, rectangle)) THEN - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) intersection%segment => seg_pln_intxn%segment ! A is inside rectangle and B is not inside @@ -1268,20 +1246,20 @@ SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection, erro DO i = 1, 4 rect_edge => rectangle%edges(i) CALL coplanar_segment_segment_intersection(rect_edge%segment, segment, & - plane, seg_seg_intxn, error) + plane, seg_seg_intxn) IF (seg_seg_intxn%intxn_type .NE. NO_INTXN) THEN crossing_pt = seg_seg_intxn%point EXIT END IF END DO IF (are_equal(crossing_pt, A)) THEN - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = A ELSE - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) - CALL cs_segment_create(intersection%segment, A, crossing_pt, error=error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) + CALL cs_segment_create(intersection%segment, A, crossing_pt) END IF - CALL cs_intersection_obj_release(seg_seg_intxn, error) + CALL cs_intersection_obj_release(seg_seg_intxn) ! A is not inside rectangle and B is inside ELSE IF (.NOT. is_inside_rectangle(A, rectangle) .AND. is_inside_rectangle(B, rectangle)) THEN @@ -1290,20 +1268,20 @@ SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection, erro DO i = 1, 4 rect_edge => rectangle%edges(i) CALL coplanar_segment_segment_intersection(rect_edge%segment, segment, & - plane, seg_seg_intxn, error) + plane, seg_seg_intxn) IF (seg_seg_intxn%intxn_type .NE. NO_INTXN) THEN crossing_pt = seg_seg_intxn%point EXIT END IF END DO IF (are_equal(crossing_pt, B)) THEN - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = B ELSE - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) - CALL cs_segment_create(intersection%segment, crossing_pt, B, error=error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) + CALL cs_segment_create(intersection%segment, crossing_pt, B) END IF - CALL cs_intersection_obj_release(seg_seg_intxn, error) + CALL cs_intersection_obj_release(seg_seg_intxn) ! A and B are not inside rectangle ELSE @@ -1314,7 +1292,7 @@ SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection, erro DO i = 1, 4 rect_edge => rectangle%edges(i) CALL coplanar_segment_segment_intersection(rect_edge%segment, segment, & - plane, seg_seg_intxn, error) + plane, seg_seg_intxn) n_intxn_tot = n_intxn_tot + seg_seg_intxn%n_intxn all_intxn(:,j) = seg_seg_intxn%point j = j + seg_seg_intxn%n_intxn @@ -1325,30 +1303,29 @@ SUBROUTINE segment_rectangle_intersection(segment, rectangle, intersection, erro IF (n_intxn_tot .NE. 0) THEN ! if there is any intersection remove duplicate points - CALL remove_duplicate_vertices(valid_intxn, unique_intxn, error) + CALL remove_duplicate_vertices(valid_intxn, unique_intxn) n_intersections = SIZE(unique_intxn)/3 SELECT CASE (n_intersections) CASE (1) - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = unique_intxn(:,1) CASE (2) - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) CALL cs_segment_create(intersection%segment, & - unique_intxn(:,1), unique_intxn(:,2), & - error) + unique_intxn(:,1), unique_intxn(:,2)) CASE DEFAULT END SELECT ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF DEALLOCATE(valid_intxn) - CALL cs_intersection_obj_release(seg_seg_intxn, error) + CALL cs_intersection_obj_release(seg_seg_intxn) END IF END SELECT ! status of the segment wrt the rectangle's plane - CALL cs_intersection_obj_release(seg_pln_intxn, error) + CALL cs_intersection_obj_release(seg_pln_intxn) CALL timestop(handle) END SUBROUTINE segment_rectangle_intersection @@ -1360,18 +1337,16 @@ END SUBROUTINE segment_rectangle_intersection !> \param plane input plane !> \param box input box !> \param intersection the intersection of the plane and the box -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE plane_box_intersection(plane, box, intersection, error) + SUBROUTINE plane_box_intersection(plane, box, intersection) TYPE(cs_plane), INTENT(IN), POINTER :: plane TYPE(cs_box), INTENT(IN), POINTER :: box TYPE(cs_intersection_obj), & INTENT(INOUT), POINTER :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'plane_box_intersection', & routineP = moduleN//':'//routineN @@ -1395,7 +1370,7 @@ SUBROUTINE plane_box_intersection(plane, box, intersection, error) j = 1 DO i = 1, 12 CALL segment_plane_intersection(box%edges(i)%segment, plane, & - seg_pln_intxn, error) + seg_pln_intxn) n_intxn_tot = n_intxn_tot + seg_pln_intxn%n_intxn SELECT CASE (seg_pln_intxn%intxn_type) CASE (PT_INTXN) @@ -1403,11 +1378,11 @@ SUBROUTINE plane_box_intersection(plane, box, intersection, error) CASE (SEG_INTXN) all_intxn(:,j) = seg_pln_intxn%segment%A all_intxn(:,j+1) = seg_pln_intxn%segment%B - CALL cs_segment_release(seg_pln_intxn%segment, error) + CALL cs_segment_release(seg_pln_intxn%segment) END SELECT j = j + seg_pln_intxn%n_intxn END DO - CALL cs_intersection_obj_release(seg_pln_intxn, error) + CALL cs_intersection_obj_release(seg_pln_intxn) ! get actual intersection points i.e. remove infinity points ALLOCATE(valid_intxn(3,n_intxn_tot)) @@ -1415,18 +1390,18 @@ SUBROUTINE plane_box_intersection(plane, box, intersection, error) IF (n_intxn_tot .NE. 0) THEN ! if there is any intersection remove duplicate points - CALL remove_duplicate_vertices(valid_intxn, unique_intxn, error) + CALL remove_duplicate_vertices(valid_intxn, unique_intxn) n_intersections = SIZE(unique_intxn)/3 SELECT CASE (n_intersections) CASE (1) - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = unique_intxn(:,1) CASE (2) A = unique_intxn(:,1) B = unique_intxn(:,2) - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) - CALL cs_segment_create(intersection%segment, A, B, error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) + CALL cs_segment_create(intersection%segment, A, B) CASE (3) A = unique_intxn(:,1) B = unique_intxn(:,2) @@ -1436,17 +1411,17 @@ SUBROUTINE plane_box_intersection(plane, box, intersection, error) ABxAC = vector_product(AB, AC) ! if the three points are collinear IF ( SUM(ABS(ABxAC)) .LE. small_value ) THEN - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) - CALL cs_segment_create(intersection%segment, A, B, error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) + CALL cs_segment_create(intersection%segment, A, B) ELSE - CALL cs_intersection_obj_create(intersection, TRI_INTXN, error=error) - CALL cs_triangle_create(intersection%triangle, A, B, C, error) + CALL cs_intersection_obj_create(intersection, TRI_INTXN) + CALL cs_triangle_create(intersection%triangle, A, B, C) END IF ! CASE (4) ! consider rectangle as a regular polygon CASE DEFAULT - CALL cs_intersection_obj_create(intersection, PY_INTXN, n_intersections, error=error) + CALL cs_intersection_obj_create(intersection, PY_INTXN, n_intersections) ALLOCATE(intersection_points(3,n_intersections)) intersection_points(:,:) = unique_intxn(:,1:n_intersections) @@ -1454,16 +1429,16 @@ SUBROUTINE plane_box_intersection(plane, box, intersection, error) ! sort intersection points O = intersection_points(:,1) ! reference vertex unit_normal = plane%unit_normal - IF (n_intersections .GT. 3) CALL sort_vertices(intersection_points, O, unit_normal, error) + IF (n_intersections .GT. 3) CALL sort_vertices(intersection_points, O, unit_normal) polygon_vertices => intersection_points - CALL cs_polygon_create(intersection%polygon, polygon_vertices, error=error) + CALL cs_polygon_create(intersection%polygon, polygon_vertices) DEALLOCATE(intersection_points) END SELECT ELSE ! if there is no intersection - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF DEALLOCATE(valid_intxn) @@ -1479,17 +1454,15 @@ END SUBROUTINE plane_box_intersection !> \param polygon input polygon !> \param rectangle input rectangle !> \param intersection the intersection of the polygon and the rectangle -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE coplanar_polygon_rectangle_intersection(polygon, rectangle, intersection, error) + SUBROUTINE coplanar_polygon_rectangle_intersection(polygon, rectangle, intersection) TYPE(cs_polygon), INTENT(IN), POINTER :: polygon TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle TYPE(cs_intersection_obj), & INTENT(INOUT), POINTER :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'coplanar_polygon_rectangle_intersection', & @@ -1547,7 +1520,7 @@ SUBROUTINE coplanar_polygon_rectangle_intersection(polygon, rectangle, intersect py_edge => polygon%edges(i) rect_edge => rectangle%edges(j) CALL coplanar_segment_segment_intersection(py_edge%segment, rect_edge%segment, & - plane, seg_seg_intxn, error) + plane, seg_seg_intxn) crossing_pts(:,k) = seg_seg_intxn%point counter = counter + seg_seg_intxn%n_intxn k = k + 1 @@ -1572,18 +1545,18 @@ SUBROUTINE coplanar_polygon_rectangle_intersection(polygon, rectangle, intersect IF (counter .NE. 0) THEN ! if there is any intersection remove duplicate points - CALL remove_duplicate_vertices(valid_vertices, unique_vertices, error) + CALL remove_duplicate_vertices(valid_vertices, unique_vertices) ovlp_n_vtx = SIZE(unique_vertices)/3 SELECT CASE (ovlp_n_vtx) CASE (1) - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = unique_vertices(:,1) CASE (2) A = unique_vertices(:,1) B = unique_vertices(:,2) - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) - CALL cs_segment_create(intersection%segment, A, B, error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) + CALL cs_segment_create(intersection%segment, A, B) CASE (3) A = unique_vertices(:,1) B = unique_vertices(:,2) @@ -1593,17 +1566,17 @@ SUBROUTINE coplanar_polygon_rectangle_intersection(polygon, rectangle, intersect ABxAC = vector_product(AB, AC) ! if the three points are collinear IF ( SUM(ABS(ABxAC)) .LE. small_value ) THEN - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) - CALL cs_segment_create(intersection%segment, A, B, error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) + CALL cs_segment_create(intersection%segment, A, B) ELSE - CALL cs_intersection_obj_create(intersection, TRI_INTXN, error=error) - CALL cs_triangle_create(intersection%triangle, A, B, C, error) + CALL cs_intersection_obj_create(intersection, TRI_INTXN) + CALL cs_triangle_create(intersection%triangle, A, B, C) END IF ! CASE (4) ! consider rectangle as a regular polygon CASE DEFAULT - CALL cs_intersection_obj_create(intersection, PY_INTXN, ovlp_n_vtx, error=error) + CALL cs_intersection_obj_create(intersection, PY_INTXN, ovlp_n_vtx) ALLOCATE(overlap_vertices(3,ovlp_n_vtx)) overlap_vertices(:,:) = unique_vertices(:,1:ovlp_n_vtx) @@ -1611,20 +1584,20 @@ SUBROUTINE coplanar_polygon_rectangle_intersection(polygon, rectangle, intersect ! sort intersection points O = overlap_vertices(:,1) unit_normal = plane%unit_normal - IF (ovlp_n_vtx .GT. 3) CALL sort_vertices(overlap_vertices, O, unit_normal, error) + IF (ovlp_n_vtx .GT. 3) CALL sort_vertices(overlap_vertices, O, unit_normal) ovlp_vertices => overlap_vertices - CALL cs_polygon_create(intersection%polygon, ovlp_vertices, error=error) + CALL cs_polygon_create(intersection%polygon, ovlp_vertices) DEALLOCATE(overlap_vertices) END SELECT ELSE ! if there is no intersection - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF DEALLOCATE(internal_pts, crossing_pts, all_pts, valid_vertices) - CALL cs_intersection_obj_release(seg_seg_intxn, error) + CALL cs_intersection_obj_release(seg_seg_intxn) CALL timestop(handle) @@ -1635,17 +1608,15 @@ END SUBROUTINE coplanar_polygon_rectangle_intersection !> \param rectangle1 rectangle 1 !> \param rectangle2 rectangle 2 !> \param intersection the intersection between rectangle 1 and rectangle 2 -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE rectangle_rectangle_intersection(rectangle1, rectangle2, intersection, error) + SUBROUTINE rectangle_rectangle_intersection(rectangle1, rectangle2, intersection) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle1, rectangle2 TYPE(cs_intersection_obj), & INTENT(INOUT), POINTER :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'rectangle_rectangle_intersection', & @@ -1679,13 +1650,13 @@ SUBROUTINE rectangle_rectangle_intersection(rectangle1, rectangle2, intersection ! rectangles are co-planar IF (n1dotA1A2 .EQ. 0.0_dp) THEN ALLOCATE(polygon_tmp) - CALL cast_rectangle_to_polygon(rectangle1, polygon_tmp, error) + CALL cast_rectangle_to_polygon(rectangle1, polygon_tmp) CALL coplanar_polygon_rectangle_intersection(polygon_tmp, rectangle2, & - intersection, error) - CALL cs_polygon_release(polygon_tmp, error) + intersection) + CALL cs_polygon_release(polygon_tmp) ! rectangles are parallel but not co-planar ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF ! rectangles are not parallel ELSE @@ -1712,7 +1683,7 @@ SUBROUTINE rectangle_rectangle_intersection(rectangle1, rectangle2, intersection j = 1 DO i = 1, 4 CALL segment_rectangle_intersection(rectangle1%edges(i)%segment, rectangle2, & - seg_rect_intxn, error) + seg_rect_intxn) n_intxn_tot = n_intxn_tot + seg_rect_intxn%n_intxn SELECT CASE (seg_rect_intxn%intxn_type) CASE (PT_INTXN) @@ -1720,11 +1691,11 @@ SUBROUTINE rectangle_rectangle_intersection(rectangle1, rectangle2, intersection CASE (SEG_INTXN) all_intxn(:,j) = seg_rect_intxn%segment%A all_intxn(:,j+1) = seg_rect_intxn%segment%B - CALL cs_segment_release(seg_rect_intxn%segment, error) + CALL cs_segment_release(seg_rect_intxn%segment) END SELECT j = j + seg_rect_intxn%n_intxn END DO - CALL cs_intersection_obj_release(seg_rect_intxn, error) + CALL cs_intersection_obj_release(seg_rect_intxn) ! get actual intersection points i.e. remove infinity points ALLOCATE(valid_intxn(3,n_intxn_tot)) @@ -1732,27 +1703,26 @@ SUBROUTINE rectangle_rectangle_intersection(rectangle1, rectangle2, intersection IF (n_intxn_tot .NE. 0) THEN ! if there is any intersection remove duplicate points - CALL remove_duplicate_vertices(valid_intxn, unique_intxn, error) + CALL remove_duplicate_vertices(valid_intxn, unique_intxn) n_intersections = SIZE(unique_intxn)/3 SELECT CASE (n_intersections) CASE (1) - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = unique_intxn(:,1) CASE (2) - CALL cs_intersection_obj_create(intersection, SEG_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, SEG_INTXN) CALL cs_segment_create(intersection%segment, & - unique_intxn(:,1), unique_intxn(:,2), & - error) + unique_intxn(:,1), unique_intxn(:,2)) END SELECT ELSE ! if there is no intersection - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF ! rectangles are not parallel and do not intersect ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF END IF @@ -1765,18 +1735,16 @@ END SUBROUTINE rectangle_rectangle_intersection !> \param rectangle input rectangle !> \param box input box !> \param intersection the intersection of the rectangle and the box -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE rectangle_box_intersection(rectangle, box, intersection, error) + SUBROUTINE rectangle_box_intersection(rectangle, box, intersection) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle TYPE(cs_box), INTENT(IN), POINTER :: box TYPE(cs_intersection_obj), & INTENT(INOUT), POINTER :: intersection - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rectangle_box_intersection', & routineP = moduleN//':'//routineN @@ -1790,34 +1758,34 @@ SUBROUTINE rectangle_box_intersection(rectangle, box, intersection, error) ALLOCATE(pln_box_intxn) ! first find the intersection of the rectangle's plane with the box - CALL plane_box_intersection(rectangle%plane, box, pln_box_intxn, error) + CALL plane_box_intersection(rectangle%plane, box, pln_box_intxn) ! then find the overlap of the intersection with the rectangle SELECT CASE (pln_box_intxn%intxn_type) CASE (NO_INTXN) - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) CASE (PT_INTXN) IF (is_inside_rectangle(pln_box_intxn%point, rectangle)) THEN - CALL cs_intersection_obj_create(intersection, PT_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, PT_INTXN) intersection%point = pln_box_intxn%point ELSE - CALL cs_intersection_obj_create(intersection, NO_INTXN, error=error) + CALL cs_intersection_obj_create(intersection, NO_INTXN) END IF CASE (SEG_INTXN) CALL segment_rectangle_intersection(pln_box_intxn%segment, rectangle, & - intersection, error) + intersection) CASE (TRI_INTXN) ALLOCATE(polygon_tmp) - CALL cast_triangle_to_polygon(pln_box_intxn%triangle, polygon_tmp, error) + CALL cast_triangle_to_polygon(pln_box_intxn%triangle, polygon_tmp) CALL coplanar_polygon_rectangle_intersection(polygon_tmp, rectangle, & - intersection, error) - CALL cs_polygon_release(polygon_tmp, error) + intersection) + CALL cs_polygon_release(polygon_tmp) CASE DEFAULT CALL coplanar_polygon_rectangle_intersection(pln_box_intxn%polygon, rectangle, & - intersection, error) + intersection) END SELECT - CALL cs_intersection_obj_release(pln_box_intxn, error) + CALL cs_intersection_obj_release(pln_box_intxn) CALL timestop(handle) @@ -1827,17 +1795,15 @@ END SUBROUTINE rectangle_box_intersection !> \brief toggles a grid_segment on if a given rectangle intersects with it !> \param grid_seg grid segment whose end points to be weighted !> \param rectangle the given rectangle -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE toggle_grid_segment(grid_seg, rectangle, error) + SUBROUTINE toggle_grid_segment(grid_seg, rectangle) TYPE(cs_grid_segment), INTENT(INOUT), & POINTER :: grid_seg TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'toggle_grid_segment', & routineP = moduleN//':'//routineN @@ -1848,7 +1814,7 @@ SUBROUTINE toggle_grid_segment(grid_seg, rectangle, error) CALL timeset(routineN,handle) ALLOCATE(seg_rect_intxn) - CALL segment_rectangle_intersection(grid_seg%segment, rectangle, seg_rect_intxn, error) + CALL segment_rectangle_intersection(grid_seg%segment, rectangle, seg_rect_intxn) IF (seg_rect_intxn%intxn_type .EQ. NO_INTXN) THEN grid_seg%is_on = .FALSE. @@ -1858,7 +1824,7 @@ SUBROUTINE toggle_grid_segment(grid_seg, rectangle, error) grid_seg%weight = 1 END IF - CALL cs_intersection_obj_release(seg_rect_intxn, error) + CALL cs_intersection_obj_release(seg_rect_intxn) CALL timestop(handle) END SUBROUTINE toggle_grid_segment @@ -1867,17 +1833,15 @@ END SUBROUTINE toggle_grid_segment !> \brief toggles a grid_tile on if a given rectangle intersects with it !> \param grid_tile grid tile whose vertices to be weighted !> \param rectangle input rectangle -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE toggle_grid_tile(grid_tile, rectangle, error) + SUBROUTINE toggle_grid_tile(grid_tile, rectangle) TYPE(cs_grid_tile), INTENT(INOUT), & POINTER :: grid_tile TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'toggle_grid_tile', & routineP = moduleN//':'//routineN @@ -1888,7 +1852,7 @@ SUBROUTINE toggle_grid_tile(grid_tile, rectangle, error) CALL timeset(routineN,handle) ALLOCATE(rect_rect_intxn) - CALL rectangle_rectangle_intersection(rectangle, grid_tile%rectangle, rect_rect_intxn, error) + CALL rectangle_rectangle_intersection(rectangle, grid_tile%rectangle, rect_rect_intxn) IF (rect_rect_intxn%intxn_type .EQ. NO_INTXN) THEN grid_tile%is_on = .FALSE. @@ -1898,7 +1862,7 @@ SUBROUTINE toggle_grid_tile(grid_tile, rectangle, error) grid_tile%weight = 1 END IF - CALL cs_intersection_obj_release(rect_rect_intxn, error) + CALL cs_intersection_obj_release(rect_rect_intxn) CALL timestop(handle) @@ -1908,16 +1872,14 @@ END SUBROUTINE toggle_grid_tile !> \brief toggles a voxel on if a given rectangle intersects with it !> \param voxel voxel whose vertices to be weighted !> \param rectangle the given rectangle -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE toggle_voxel(voxel, rectangle, error) + SUBROUTINE toggle_voxel(voxel, rectangle) TYPE(cs_voxel), INTENT(INOUT), POINTER :: voxel TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'toggle_voxel', & routineP = moduleN//':'//routineN @@ -1927,7 +1889,7 @@ SUBROUTINE toggle_voxel(voxel, rectangle, error) CALL timeset(routineN,handle) ALLOCATE(rect_box_intxn) - CALL rectangle_box_intersection(rectangle, voxel%box, rect_box_intxn, error) + CALL rectangle_box_intersection(rectangle, voxel%box, rect_box_intxn) IF (rect_box_intxn%intxn_type .EQ. NO_INTXN) THEN voxel%is_on = .FALSE. @@ -1937,7 +1899,7 @@ SUBROUTINE toggle_voxel(voxel, rectangle, error) voxel%weight = 1 END IF - CALL cs_intersection_obj_release(rect_box_intxn, error) + CALL cs_intersection_obj_release(rect_box_intxn) CALL timestop(handle) END SUBROUTINE toggle_voxel @@ -1999,17 +1961,15 @@ END FUNCTION local_domain_type !> \brief maps the weights of vertices of a grid segment on a pw data type !> \param grid_seg input grid segment !> \param pw the output plane wave data type -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE convert_grid_segment_to_grid(grid_seg, pw, error) + SUBROUTINE convert_grid_segment_to_grid(grid_seg, pw) TYPE(cs_grid_segment), INTENT(IN), & POINTER :: grid_seg TYPE(pw_type), INTENT(INOUT) :: pw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_grid_segment_to_grid', & routineP = moduleN//':'//routineN @@ -2049,16 +2009,14 @@ END SUBROUTINE convert_grid_segment_to_grid !> \brief maps the weights of vertices of a grid tile on a pw data type !> \param grid_tile input grid tile !> \param pw the output plane wave data type -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE convert_grid_tile_to_grid(grid_tile, pw, error) + SUBROUTINE convert_grid_tile_to_grid(grid_tile, pw) TYPE(cs_grid_tile), INTENT(IN), POINTER :: grid_tile TYPE(pw_type), INTENT(INOUT) :: pw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_grid_tile_to_grid', & routineP = moduleN//':'//routineN @@ -2104,16 +2062,14 @@ END SUBROUTINE convert_grid_tile_to_grid !> \brief maps the weights of vertices of a voxel on a pw data type !> \param voxel input voxel !> \param pw the output plane wave data type -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE convert_voxel_to_grid(voxel, pw, error) + SUBROUTINE convert_voxel_to_grid(voxel, pw) TYPE(cs_voxel), INTENT(IN), POINTER :: voxel TYPE(pw_type), INTENT(INOUT) :: pw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_voxel_to_grid', & routineP = moduleN//':'//routineN @@ -2156,20 +2112,18 @@ END SUBROUTINE convert_voxel_to_grid !> \param y_locl y grid vetor of the simulation box local to this process !> \param z_locl z grid vetor of the simulation box local to this process !> \param pw pw grid data to be created -!> \param error cp2k error !> \par History !> 09.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, pw, error) + x_locl, y_locl, z_locl, pw) TYPE(cs_rectangle), INTENT(IN), POINTER :: rectangle REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(IN) :: x_glbl, y_glbl, z_glbl, & x_locl, y_locl, z_locl TYPE(pw_type), INTENT(INOUT) :: pw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'voxelize_rectangle', & routineP = moduleN//':'//routineN @@ -2196,7 +2150,7 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ld_type = local_domain_type(bounds_local) CALL compute_rectangle_aabb_extents(rectangle, x_glbl, y_glbl, z_glbl, & - x_locl, y_locl, z_locl, aabb_extents, aabb_extents_local, error) + x_locl, y_locl, z_locl, aabb_extents, aabb_extents_local) SELECT CASE (ld_type) ! if the current process's local domain is a box: @@ -2207,10 +2161,10 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ALLOCATE(voxel) origin = (/x_locl(i),y_locl(j),z_locl(k)/) voxel_index = (/i,j,k/) - CALL cs_voxel_create(voxel, origin, voxel_index, dr, error) - CALL toggle_voxel(voxel, rectangle, error) - CALL convert_voxel_to_grid(voxel, pw, error) - CALL cs_voxel_release(voxel, error) + CALL cs_voxel_create(voxel, origin, voxel_index, dr) + CALL toggle_voxel(voxel, rectangle) + CALL convert_voxel_to_grid(voxel, pw) + CALL cs_voxel_release(voxel) END DO END DO END DO @@ -2223,10 +2177,10 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ALLOCATE(grid_tile) origin = (/x_locl(lb1),y_locl(j),z_locl(k)/) grid_tile_index = (/lb1,j,k/) - CALL cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, ld_type, error) - CALL toggle_grid_tile(grid_tile, rectangle, error) - CALL convert_grid_tile_to_grid(grid_tile, pw, error) - CALL cs_grid_tile_release(grid_tile, error) + CALL cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, ld_type) + CALL toggle_grid_tile(grid_tile, rectangle) + CALL convert_grid_tile_to_grid(grid_tile, pw) + CALL cs_grid_tile_release(grid_tile) END DO END DO CASE (xz_aligned_rectangle) @@ -2237,10 +2191,10 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ALLOCATE(grid_tile) origin = (/x_locl(i),y_locl(lb2),z_locl(k)/) grid_tile_index = (/i,lb2,k/) - CALL cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, ld_type, error) - CALL toggle_grid_tile(grid_tile, rectangle, error) - CALL convert_grid_tile_to_grid(grid_tile, pw, error) - CALL cs_grid_tile_release(grid_tile, error) + CALL cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, ld_type) + CALL toggle_grid_tile(grid_tile, rectangle) + CALL convert_grid_tile_to_grid(grid_tile, pw) + CALL cs_grid_tile_release(grid_tile) END DO END DO CASE (xy_aligned_rectangle) @@ -2251,10 +2205,10 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ALLOCATE(grid_tile) origin = (/x_locl(i),y_locl(j),z_locl(lb3)/) grid_tile_index = (/i,j,lb3/) - CALL cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, ld_type, error) - CALL toggle_grid_tile(grid_tile, rectangle, error) - CALL convert_grid_tile_to_grid(grid_tile, pw, error) - CALL cs_grid_tile_release(grid_tile, error) + CALL cs_grid_tile_create(grid_tile, origin, grid_tile_index, dr, ld_type) + CALL toggle_grid_tile(grid_tile, rectangle) + CALL convert_grid_tile_to_grid(grid_tile, pw) + CALL cs_grid_tile_release(grid_tile) END DO END DO ! if the current process's local domain is a segment: @@ -2264,10 +2218,10 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ALLOCATE(grid_seg) origin = (/x_locl(lb1),y_locl(lb2),z_locl(k)/) grid_segment_index = (/lb1,lb2,k/) - CALL cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, ld_type, error) - CALL toggle_grid_segment(grid_seg, rectangle, error) - CALL convert_grid_segment_to_grid(grid_seg, pw, error) - CALL cs_grid_segment_release(grid_seg, error) + CALL cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, ld_type) + CALL toggle_grid_segment(grid_seg, rectangle) + CALL convert_grid_segment_to_grid(grid_seg, pw) + CALL cs_grid_segment_release(grid_seg) END DO CASE (yaxis_aligned_segment) ! DO j = lb2, ub2-1 @@ -2275,10 +2229,10 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ALLOCATE(grid_seg) origin = (/x_locl(lb1),y_locl(j),z_locl(lb3)/) grid_segment_index = (/lb1,j,lb3/) - CALL cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, ld_type, error) - CALL toggle_grid_segment(grid_seg, rectangle, error) - CALL convert_grid_segment_to_grid(grid_seg, pw, error) - CALL cs_grid_segment_release(grid_seg, error) + CALL cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, ld_type) + CALL toggle_grid_segment(grid_seg, rectangle) + CALL convert_grid_segment_to_grid(grid_seg, pw) + CALL cs_grid_segment_release(grid_seg) END DO CASE (xaxis_aligned_segment) ! DO i = lb1, ub1-1 @@ -2286,10 +2240,10 @@ SUBROUTINE voxelize_rectangle(rectangle, x_glbl, y_glbl, z_glbl, & ALLOCATE(grid_seg) origin = (/x_locl(i),y_locl(lb2),z_locl(lb3)/) grid_segment_index = (/i,lb2,lb3/) - CALL cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, ld_type, error) - CALL toggle_grid_segment(grid_seg, rectangle, error) - CALL convert_grid_segment_to_grid(grid_seg, pw, error) - CALL cs_grid_segment_release(grid_seg, error) + CALL cs_grid_segment_create(grid_seg, origin, grid_segment_index, dr, ld_type) + CALL toggle_grid_segment(grid_seg, rectangle) + CALL convert_grid_segment_to_grid(grid_seg, pw) + CALL cs_grid_segment_release(grid_seg) END DO CASE (single_grid_point) ! if the current process's local domain is a point: @@ -2320,18 +2274,16 @@ END SUBROUTINE voxelize_rectangle !> \param y_locl y grid vetor of the simulation box local to this process !> \param z_locl z grid vetor of the simulation box local to this process !> \param pw pw grid data to be created -!> \param error cp2k error !> \par History !> 09.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE voxelize_aa_cuboid(cuboid, x_locl, y_locl, z_locl, pw, error) + SUBROUTINE voxelize_aa_cuboid(cuboid, x_locl, y_locl, z_locl, pw) TYPE(cs_box), INTENT(IN), POINTER :: cuboid REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(IN) :: x_locl, y_locl, z_locl TYPE(pw_type), INTENT(INOUT) :: pw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'voxelize_aa_cuboid', & routineP = moduleN//':'//routineN diff --git a/src/pw/fft_tools.F b/src/pw/fft_tools.F index 16c8e12547..392216e705 100644 --- a/src/pw/fft_tools.F +++ b/src/pw/fft_tools.F @@ -193,18 +193,16 @@ END FUNCTION cudaHostAlloc !> \param pool_limit ... !> \param wisdom_file ... !> \param plan_style ... -!> \param error ... !> \author JGH ! ***************************************************************************** SUBROUTINE init_fft ( fftlib, alltoall, fftsg_sizes, pool_limit, wisdom_file,& - plan_style, error ) + plan_style) CHARACTER(LEN=*), INTENT(IN) :: fftlib LOGICAL, INTENT(IN) :: alltoall, fftsg_sizes INTEGER, INTENT(IN) :: pool_limit CHARACTER(LEN=*), INTENT(IN) :: wisdom_file INTEGER, INTENT(IN) :: plan_style - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_fft', & routineP = moduleN//':'//routineN @@ -221,8 +219,8 @@ SUBROUTINE init_fft ( fftlib, alltoall, fftsg_sizes, pool_limit, wisdom_file,& CALL fft_do_init(fft_type,wisdom_file) ! setup the FFT scratch pool, if one is associated, clear first - CALL release_fft_scratch_pool(error) - CALL init_fft_scratch_pool(error) + CALL release_fft_scratch_pool() + CALL init_fft_scratch_pool() END SUBROUTINE init_fft @@ -230,21 +228,19 @@ END SUBROUTINE init_fft !> \brief does whatever is needed to finalize the current fft setup !> \param para_env ... !> \param wisdom_file ... -!> \param error ... !> \par History !> 10.2007 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE finalize_fft( para_env, wisdom_file, error ) + SUBROUTINE finalize_fft( para_env, wisdom_file) TYPE(cp_para_env_type), POINTER :: para_env CHARACTER(LEN=*), INTENT(IN) :: wisdom_file - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'finalize_fft', & routineP = moduleN//':'//routineN ! release the FFT scratch pool - CALL release_fft_scratch_pool(error) + CALL release_fft_scratch_pool() ! finalize fft libs @@ -384,12 +380,11 @@ SUBROUTINE fft3d_s ( fsign, n, zin, zout, scale, status, debug ) output_unit, sign, stat LOGICAL :: fft_in_place, test REAL(KIND=dp) :: in_sum, norm, out_sum - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger TYPE(fft_scratch_type), POINTER :: fft_scratch CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) IF ( PRESENT ( scale ) ) THEN @@ -424,7 +419,7 @@ SUBROUTINE fft3d_s ( fsign, n, zin, zout, scale, status, debug ) END IF sign = fsign - CALL get_fft_scratch(fft_scratch,tf_type=400,n=n,error=error) + CALL get_fft_scratch(fft_scratch,tf_type=400,n=n) IF ( fft_in_place ) THEN zoptr => zdum @@ -441,7 +436,7 @@ SUBROUTINE fft3d_s ( fsign, n, zin, zout, scale, status, debug ) ENDIF END IF - CALL release_fft_scratch(fft_scratch,error) + CALL release_fft_scratch(fft_scratch) IF ( PRESENT ( zout ) ) THEN lo ( 1 ) = SIZE ( zout ,1 ) @@ -526,13 +521,12 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & INTEGER, ALLOCATABLE, DIMENSION(:) :: p2p LOGICAL :: test REAL(KIND=dp) :: norm, sum_data - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger TYPE(fft_scratch_sizes) :: fft_scratch_size TYPE(fft_scratch_type), POINTER :: fft_scratch CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) IF ( PRESENT ( debug ) ) THEN @@ -644,7 +638,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & CALL stop_program(routineN,moduleN,__LINE__,& "This processor distribution is not supported.") END IF - CALL get_fft_scratch(fft_scratch,tf_type=300,n=n,fft_sizes=fft_scratch_size,error=error) + CALL get_fft_scratch(fft_scratch,tf_type=300,n=n,fft_sizes=fft_scratch_size) IF ( sign == FWFFT ) THEN ! cin -> gin @@ -678,7 +672,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & END IF ! Exchange data ( transpose of matrix ) - CALL cube_transpose_2 ( qbuf, rs_group, bo(:,:,:,1), bo(:,:,:,2), rbuf, fft_scratch, error ) + CALL cube_transpose_2 ( qbuf, rs_group, bo(:,:,:,1), bo(:,:,:,2), rbuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( rbuf ) ) @@ -705,7 +699,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & ! Exchange data ( transpose of matrix ) and sort CALL xz_to_yz ( pbuf, rs_group, r_dim, g_pos, p2p, yzp, nyzray, & - bo ( :, : , : , 2 ), qbuf, fft_scratch, error ) + bo ( :, : , : , 2 ), qbuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( qbuf ) ) @@ -758,7 +752,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & ! Exchange data ( transpose of matrix ) and sort CALL yz_to_xz ( pbuf, rs_group, r_dim, g_pos, p2p, yzp, nyzray, & - bo ( :, : , : , 2 ), qbuf, fft_scratch, error ) + bo ( :, : , : , 2 ), qbuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( qbuf ) ) @@ -784,7 +778,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & END IF ! Exchange data ( transpose of matrix ) - CALL cube_transpose_1 ( rbuf, rs_group, bo(:,:,:,2), bo(:,:,:,1), pbuf, fft_scratch, error ) + CALL cube_transpose_1 ( rbuf, rs_group, bo(:,:,:,2), bo(:,:,:,1), pbuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( pbuf ) ) @@ -815,7 +809,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & ENDIF - CALL release_fft_scratch(fft_scratch,error) + CALL release_fft_scratch(fft_scratch) ELSE @@ -825,7 +819,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & ! direction x ! - CALL get_fft_scratch(fft_scratch,tf_type=200,n=n,fft_sizes=fft_scratch_size,error=error) + CALL get_fft_scratch(fft_scratch,tf_type=200,n=n,fft_sizes=fft_scratch_size) sbuf => fft_scratch%r1buf tbuf => fft_scratch%tbuf @@ -861,7 +855,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & ! Exchange data ( transpose of matrix ) and sort CALL yz_to_x ( tbuf, gs_group, g_pos, p2p, yzp, nyzray, & - bo ( :, :, :, 2 ), sbuf, fft_scratch, error ) + bo ( :, :, :, 2 ), sbuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( sbuf ) ) @@ -908,7 +902,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & ! Exchange data ( transpose of matrix ) and sort CALL x_to_yz ( sbuf, gs_group, g_pos, p2p, yzp, nyzray, & - bo ( :, :, :, 2 ), tbuf, fft_scratch, error ) + bo ( :, :, :, 2 ), tbuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( tbuf ) ) @@ -934,7 +928,7 @@ SUBROUTINE fft3d_ps ( fsign, n, cin, gin, gs_group, rs_group, yzp, nyzray, & "Illegal fsign parameter.") ENDIF - CALL release_fft_scratch(fft_scratch,error) + CALL release_fft_scratch(fft_scratch) ENDIF @@ -986,7 +980,6 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) INTEGER, DIMENSION(2) :: dim, pos LOGICAL :: failure, test REAL(KIND=dp) :: norm, sum_data - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger TYPE(fft_scratch_sizes) :: fft_scratch_size TYPE(fft_scratch_type), POINTER :: fft_scratch @@ -1013,7 +1006,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) failure = .FALSE. CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) CALL mp_environ ( np, dim, pos, group ) @@ -1084,7 +1077,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) ! First case; two stages of communication ! - CALL get_fft_scratch(fft_scratch,tf_type=100,n=n,fft_sizes=fft_scratch_size,error=error) + CALL get_fft_scratch(fft_scratch,tf_type=100,n=n,fft_sizes=fft_scratch_size) IF ( sign == FWFFT ) THEN ! Stage 1 -> 3 @@ -1114,7 +1107,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) END IF END IF - CALL cube_transpose_2 ( bbuf, group, bo(:,:,:,1), bo(:,:,:,2), abuf, fft_scratch, error ) + CALL cube_transpose_2 ( bbuf, group, bo(:,:,:,1), bo(:,:,:,2), abuf, fft_scratch) bbuf => fft_scratch%a4buf @@ -1140,7 +1133,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) END IF END IF - CALL cube_transpose_4 ( bbuf, group, bo(:,:,:,2), bo(:,:,:,3), abuf, fft_scratch, error ) + CALL cube_transpose_4 ( bbuf, group, bo(:,:,:,2), bo(:,:,:,3), abuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( abuf ) ) @@ -1191,7 +1184,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) END IF END IF - CALL cube_transpose_3 ( bbuf, group, bo(:,:,:,3), bo(:,:,:,2), abuf, fft_scratch, error ) + CALL cube_transpose_3 ( bbuf, group, bo(:,:,:,3), bo(:,:,:,2), abuf, fft_scratch) bbuf => fft_scratch%a3buf @@ -1217,7 +1210,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) END IF END IF - CALL cube_transpose_1 ( bbuf, group, bo(:,:,:,2), bo(:,:,:,1), abuf, fft_scratch, error ) + CALL cube_transpose_1 ( bbuf, group, bo(:,:,:,2), bo(:,:,:,1), abuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( abuf ) ) @@ -1244,7 +1237,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) "Illegal fsign parameter.") END IF - CALL release_fft_scratch(fft_scratch,error) + CALL release_fft_scratch(fft_scratch) ELSEIF ( DIM ( 2 ) == 1 ) THEN @@ -1252,7 +1245,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) ! Second case; one stage of communication ! - CALL get_fft_scratch(fft_scratch,tf_type=101,n=n,fft_sizes=fft_scratch_size,error=error) + CALL get_fft_scratch(fft_scratch,tf_type=101,n=n,fft_sizes=fft_scratch_size) IF ( sign == FWFFT ) THEN ! Stage 1 -> 3 @@ -1284,7 +1277,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) END IF END IF - CALL cube_transpose_6 ( bbuf, group, bo(:,:,:,1), bo(:,:,:,3), abuf, fft_scratch, error ) + CALL cube_transpose_6 ( bbuf, group, bo(:,:,:,1), bo(:,:,:,3), abuf, fft_scratch) IF ( test ) THEN sum_data = ABS ( SUM ( abuf ) ) @@ -1334,7 +1327,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) END IF END IF - CALL cube_transpose_5 ( bbuf, group, bo(:,:,:,3), bo(:,:,:,1), abuf, fft_scratch, error ) + CALL cube_transpose_5 ( bbuf, group, bo(:,:,:,3), bo(:,:,:,1), abuf, fft_scratch) bbuf => fft_scratch%a3buf @@ -1367,7 +1360,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug ) "Illegal fsign parameter.") ENDIF - CALL release_fft_scratch(fft_scratch,error) + CALL release_fft_scratch(fft_scratch) ELSE @@ -1395,12 +1388,11 @@ END SUBROUTINE fft3d_pb !> \param bo ... !> \param tb ... !> \param fft_scratch ... -!> \param error ... !> \par History !> 15. Feb. 2006 : single precision all_to_all !> \author JGH (14-Jan-2001) ! ***************************************************************************** - SUBROUTINE x_to_yz ( sb, group, my_pos, p2p, yzp, nray, bo, tb, fft_scratch, error ) + SUBROUTINE x_to_yz ( sb, group, my_pos, p2p, yzp, nray, bo, tb, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: sb @@ -1412,7 +1404,6 @@ SUBROUTINE x_to_yz ( sb, group, my_pos, p2p, yzp, nray, bo, tb, fft_scratch, err COMPLEX(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT) :: tb TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'x_to_yz', & routineP = moduleN//':'//routineN @@ -1510,12 +1501,11 @@ END SUBROUTINE x_to_yz !> \param bo ... !> \param sb ... !> \param fft_scratch ... -!> \param error ... !> \par History !> 15. Feb. 2006 : single precision all_to_all !> \author JGH (14-Jan-2001) ! ***************************************************************************** - SUBROUTINE yz_to_x ( tb, group, my_pos, p2p, yzp, nray, bo, sb, fft_scratch, error ) + SUBROUTINE yz_to_x ( tb, group, my_pos, p2p, yzp, nray, bo, sb, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :, :), & INTENT(IN) :: tb @@ -1527,7 +1517,6 @@ SUBROUTINE yz_to_x ( tb, group, my_pos, p2p, yzp, nray, bo, sb, fft_scratch, err COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: sb TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'yz_to_x', & routineP = moduleN//':'//routineN @@ -1627,12 +1616,11 @@ END SUBROUTINE yz_to_x !> \param bo ... !> \param tb ... !> \param fft_scratch ... -!> \param error ... !> \par History !> 15. Feb. 2006 : single precision all_to_all !> \author JGH (18-Jan-2001) ! ***************************************************************************** - SUBROUTINE yz_to_xz ( sb, group, dims, my_pos, p2p, yzp, nray, bo, tb, fft_scratch, error ) + SUBROUTINE yz_to_xz ( sb, group, dims, my_pos, p2p, yzp, nray, bo, tb, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: sb @@ -1646,7 +1634,6 @@ SUBROUTINE yz_to_xz ( sb, group, dims, my_pos, p2p, yzp, nray, bo, tb, fft_scrat COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: tb TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'yz_to_xz', & routineP = moduleN//':'//routineN @@ -1841,12 +1828,11 @@ END SUBROUTINE yz_to_xz !> \param bo ... !> \param tb ... !> \param fft_scratch ... -!> \param error ... !> \par History !> 15. Feb. 2006 : single precision all_to_all !> \author JGH (19-Jan-2001) ! ***************************************************************************** - SUBROUTINE xz_to_yz ( sb, group, dims, my_pos, p2p, yzp, nray, bo, tb, fft_scratch, error ) + SUBROUTINE xz_to_yz ( sb, group, dims, my_pos, p2p, yzp, nray, bo, tb, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: sb @@ -1860,7 +1846,6 @@ SUBROUTINE xz_to_yz ( sb, group, dims, my_pos, p2p, yzp, nray, bo, tb, fft_scrat COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: tb TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xz_to_yz', & routineP = moduleN//':'//routineN @@ -2041,12 +2026,11 @@ END SUBROUTINE xz_to_yz !> \param boout ... !> \param sout ... !> \param fft_scratch ... -!> \param error ... !> \par History !> none !> \author JGH (20-Jan-2001) ! ***************************************************************************** - SUBROUTINE cube_transpose_1 ( cin, group, boin, boout, sout, fft_scratch, error ) + SUBROUTINE cube_transpose_1 ( cin, group, boin, boout, sout, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: cin @@ -2055,7 +2039,6 @@ SUBROUTINE cube_transpose_1 ( cin, group, boin, boout, sout, fft_scratch, error COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: sout TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cube_transpose_1', & routineP = moduleN//':'//routineN @@ -2140,9 +2123,8 @@ END SUBROUTINE cube_transpose_1 !> \param boout ... !> \param sout ... !> \param fft_scratch ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cube_transpose_2 ( cin, group, boin, boout, sout, fft_scratch, error ) + SUBROUTINE cube_transpose_2 ( cin, group, boin, boout, sout, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: cin @@ -2151,7 +2133,6 @@ SUBROUTINE cube_transpose_2 ( cin, group, boin, boout, sout, fft_scratch, error COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: sout TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cube_transpose_2', & routineP = moduleN//':'//routineN @@ -2234,9 +2215,8 @@ END SUBROUTINE cube_transpose_2 !> \param boout ... !> \param sout ... !> \param fft_scratch ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cube_transpose_3 ( cin, group, boin, boout, sout, fft_scratch, error ) + SUBROUTINE cube_transpose_3 ( cin, group, boin, boout, sout, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: cin @@ -2245,7 +2225,6 @@ SUBROUTINE cube_transpose_3 ( cin, group, boin, boout, sout, fft_scratch, error COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: sout TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cube_transpose_3', & routineP = moduleN//':'//routineN @@ -2343,9 +2322,8 @@ END SUBROUTINE cube_transpose_3 !> \param boout ... !> \param sout ... !> \param fft_scratch ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cube_transpose_4 ( cin, group, boin, boout, sout, fft_scratch, error ) + SUBROUTINE cube_transpose_4 ( cin, group, boin, boout, sout, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: cin @@ -2354,7 +2332,6 @@ SUBROUTINE cube_transpose_4 ( cin, group, boin, boout, sout, fft_scratch, error COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: sout TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cube_transpose_4', & routineP = moduleN//':'//routineN @@ -2448,9 +2425,8 @@ END SUBROUTINE cube_transpose_4 !> \param boout ... !> \param sout ... !> \param fft_scratch ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cube_transpose_5 ( cin, group, boin, boout, sout, fft_scratch, error ) + SUBROUTINE cube_transpose_5 ( cin, group, boin, boout, sout, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: cin @@ -2459,7 +2435,6 @@ SUBROUTINE cube_transpose_5 ( cin, group, boin, boout, sout, fft_scratch, error COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: sout TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cube_transpose_5', & routineP = moduleN//':'//routineN @@ -2548,9 +2523,8 @@ END SUBROUTINE cube_transpose_5 !> \param boout ... !> \param sout ... !> \param fft_scratch ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cube_transpose_6 ( cin, group, boin, boout, sout, fft_scratch, error ) + SUBROUTINE cube_transpose_6 ( cin, group, boin, boout, sout, fft_scratch) COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: cin @@ -2559,7 +2533,6 @@ SUBROUTINE cube_transpose_6 ( cin, group, boin, boout, sout, fft_scratch, error COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: sout TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cube_transpose_6', & routineP = moduleN//':'//routineN @@ -2637,11 +2610,9 @@ END SUBROUTINE cube_transpose_6 ! ***************************************************************************** !> \brief ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_fft_scratch_pool(error) + SUBROUTINE init_fft_scratch_pool() - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_fft_scratch_pool', & routineP = moduleN//':'//routineN @@ -2650,13 +2621,13 @@ SUBROUTINE init_fft_scratch_pool(error) LOGICAL :: failure failure = .FALSE. - CALL release_fft_scratch_pool(error) + CALL release_fft_scratch_pool() ! Allocate first scratch and mark it as used ALLOCATE (fft_scratch_first,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE (fft_scratch_first%fft_scratch,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) NULLIFY(fft_scratch_first%fft_scratch_next) fft_scratch_first%fft_scratch%fft_scratch_id=0 fft_scratch_first%fft_scratch%in_use=.TRUE. @@ -2709,11 +2680,9 @@ END SUBROUTINE init_fft_scratch_pool ! ***************************************************************************** !> \brief ... !> \param fft_scratch ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) + SUBROUTINE deallocate_fft_scratch_type(fft_scratch) TYPE(fft_scratch_type), INTENT(INOUT) :: fft_scratch - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_fft_scratch_type', & routineP = moduleN//':'//routineN @@ -2729,15 +2698,15 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) ! deallocate structures IF(ASSOCIATED(fft_scratch%ziptr)) THEN DEALLOCATE(fft_scratch%ziptr,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%zoptr)) THEN DEALLOCATE(fft_scratch%zoptr,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%p1buf)) THEN DEALLOCATE(fft_scratch%p1buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%p2buf)) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2746,7 +2715,7 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) #else DEALLOCATE(fft_scratch%p2buf,STAT=ierr) #endif - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%p3buf)) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2755,7 +2724,7 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) #else DEALLOCATE(fft_scratch%p3buf,STAT=ierr) #endif - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%p4buf)) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2764,7 +2733,7 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) #else DEALLOCATE(fft_scratch%p4buf,STAT=ierr) #endif - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%p5buf)) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2773,11 +2742,11 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) #else DEALLOCATE(fft_scratch%p5buf,STAT=ierr) #endif - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%p6buf)) THEN DEALLOCATE(fft_scratch%p6buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%p7buf)) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2786,7 +2755,7 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) #else DEALLOCATE(fft_scratch%p7buf,STAT=ierr) #endif - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%r1buf)) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2795,11 +2764,11 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) #else DEALLOCATE(fft_scratch%r1buf,STAT=ierr) #endif - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%r2buf)) THEN DEALLOCATE(fft_scratch%r2buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%tbuf)) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2808,112 +2777,112 @@ SUBROUTINE deallocate_fft_scratch_type(fft_scratch,error) #else DEALLOCATE(fft_scratch%tbuf,STAT=ierr) #endif - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%a1buf)) THEN DEALLOCATE(fft_scratch%a1buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%a2buf)) THEN DEALLOCATE(fft_scratch%a2buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%a3buf)) THEN DEALLOCATE(fft_scratch%a3buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%a4buf)) THEN DEALLOCATE(fft_scratch%a4buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%a5buf)) THEN DEALLOCATE(fft_scratch%a5buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%a6buf)) THEN DEALLOCATE(fft_scratch%a6buf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%scount)) THEN DEALLOCATE(fft_scratch%scount,fft_scratch%rcount,& fft_scratch%sdispl,fft_scratch%rdispl,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%rr)) THEN DEALLOCATE(fft_scratch%rr,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%xzbuf)) THEN DEALLOCATE(fft_scratch%xzbuf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%yzbuf)) THEN DEALLOCATE(fft_scratch%yzbuf,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%xzbuf_sgl)) THEN DEALLOCATE(fft_scratch%xzbuf_sgl,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%yzbuf_sgl)) THEN DEALLOCATE(fft_scratch%yzbuf_sgl,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%ss)) THEN DEALLOCATE(fft_scratch%ss,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%tt)) THEN DEALLOCATE(fft_scratch%tt,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%pgrid)) THEN DEALLOCATE(fft_scratch%pgrid,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%pgcube)) THEN DEALLOCATE(fft_scratch%pgcube,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%xcor)) THEN DEALLOCATE(fft_scratch%xcor,fft_scratch%zcor,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%pzcoord)) THEN DEALLOCATE(fft_scratch%pzcoord,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%xzcount)) THEN DEALLOCATE(fft_scratch%xzcount,fft_scratch%yzcount,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) DEALLOCATE(fft_scratch%xzdispl,fft_scratch%yzdispl,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) fft_scratch%in=0 fft_scratch%rsratio=1._dp END IF IF(ASSOCIATED(fft_scratch%rbuf1)) THEN DEALLOCATE(fft_scratch%rbuf1,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%rbuf2)) THEN DEALLOCATE(fft_scratch%rbuf2,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%rbuf3)) THEN DEALLOCATE(fft_scratch%rbuf3,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%rbuf4)) THEN DEALLOCATE(fft_scratch%rbuf4,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%rbuf5)) THEN DEALLOCATE(fft_scratch%rbuf5,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(fft_scratch%rbuf6)) THEN DEALLOCATE(fft_scratch%rbuf6,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF IF (fft_scratch%cart_sub_comm(1) .NE. mp_comm_null) THEN @@ -2935,11 +2904,9 @@ END SUBROUTINE deallocate_fft_scratch_type ! ***************************************************************************** !> \brief ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_fft_scratch_pool(error) + SUBROUTINE release_fft_scratch_pool() - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_fft_scratch_pool', & routineP = moduleN//':'//routineN @@ -2960,12 +2927,12 @@ SUBROUTINE release_fft_scratch_pool(error) fft_scratch => fft_scratch_current%fft_scratch_next NULLIFY(fft_scratch_current%fft_scratch_next) - CALL deallocate_fft_scratch_type(fft_scratch_current%fft_scratch,error) + CALL deallocate_fft_scratch_type(fft_scratch_current%fft_scratch) DEALLOCATE(fft_scratch_current%fft_scratch,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) DEALLOCATE(fft_scratch_current,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ELSE EXIT END IF @@ -2977,10 +2944,8 @@ END SUBROUTINE release_fft_scratch_pool ! ***************************************************************************** !> \brief ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE resize_fft_scratch_pool(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE resize_fft_scratch_pool() CHARACTER(len=*), PARAMETER :: routineN = 'resize_fft_scratch_pool', & routineP = moduleN//':'//routineN @@ -3027,11 +2992,11 @@ SUBROUTINE resize_fft_scratch_pool(error) fft_scratch_current%fft_scratch_next=>fft_scratch_old%fft_scratch_next ! deallocate the element - CALL deallocate_fft_scratch_type(fft_scratch_old%fft_scratch,error) + CALL deallocate_fft_scratch_type(fft_scratch_old%fft_scratch) DEALLOCATE(fft_scratch_old%fft_scratch,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) DEALLOCATE(fft_scratch_old,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ELSE fft_scratch_current=>fft_scratch_current%fft_scratch_next @@ -3055,15 +3020,13 @@ END SUBROUTINE resize_fft_scratch_pool !> \param tf_type ... !> \param n ... !> \param fft_sizes ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) + SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes) TYPE(fft_scratch_type), POINTER :: fft_scratch INTEGER, INTENT(IN) :: tf_type INTEGER, DIMENSION(:), INTENT(IN) :: n TYPE(fft_scratch_sizes), INTENT(IN), & OPTIONAL :: fft_sizes - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_fft_scratch', & routineP = moduleN//':'//routineN @@ -3089,7 +3052,7 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) ! this is the place to check that the scratch_pool does not grow without limits ! before we add a new scratch check the size of the pool and release some of the list if needed - CALL resize_fft_scratch_pool(error) + CALL resize_fft_scratch_pool() ! get the required scratch tick_fft_pool=tick_fft_pool+1 @@ -3132,9 +3095,9 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) ! We cannot find the scratch type in this pool ! Generate a new scratch set ALLOCATE (fft_scratch_new,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE (fft_scratch_new%fft_scratch,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) fft_scratch_new%fft_scratch%group = 0 NULLIFY(fft_scratch_new%fft_scratch%ziptr) NULLIFY(fft_scratch_new%fft_scratch%zoptr) @@ -3187,7 +3150,7 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) SELECT CASE (tf_type) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) CASE (100) ! fft3d_pb: full cube distribution mx1 = fft_sizes%mx1 my1 = fft_sizes%my1 @@ -3196,17 +3159,17 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) my3 = fft_sizes%my3 mz3 = fft_sizes%mz3 ALLOCATE ( fft_scratch_new%fft_scratch%a1buf(mx1*my1,n(3)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a2buf(n(3),mx1*my1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a3buf(mx2*mz2,n(2)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a4buf(n(2),mx2*mz2),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a5buf(my3*mz3,n(1)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a6buf(n(1),my3*mz3),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) fft_scratch_new%fft_scratch%group = fft_sizes%gs_group CALL mp_environ ( nn, dim, pos, fft_sizes%rs_group ) @@ -3218,13 +3181,13 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) mcz2 = fft_sizes%mcz2 mcy3 = fft_sizes%mcy3 ALLOCATE ( fft_scratch_new%fft_scratch%rbuf1(mx2*my1*mcz2,0:DIM(2)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%rbuf2(mx1*my1*mcz2,0:DIM(2)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%rbuf3(mx2*mz3*mcy3,0:DIM(1)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%rbuf4(mx2*mz2*mcy3,0:DIM(1)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) dims = (/.TRUE.,.FALSE./) CALL mp_cart_sub( fft_sizes%rs_group, dims, fft_scratch_new%fft_scratch%cart_sub_comm(1)) @@ -3263,18 +3226,18 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) my3 = fft_sizes%my3 mz3 = fft_sizes%mz3 ALLOCATE ( fft_scratch_new%fft_scratch%a1buf(mx1*my1,n(3)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a2buf(n(3),mx1*my1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) fft_scratch_new%fft_scratch%group = fft_sizes%gs_group ALLOCATE ( fft_scratch_new%fft_scratch%a3buf(mx1*mz1,n(2)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a4buf(n(2),mx1*mz1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a5buf(my3*mz3,n(1)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%a6buf(n(1),my3*mz3),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL mp_environ ( nn, dim, pos, fft_sizes%rs_group ) CALL mp_cart_rank ( fft_sizes%rs_group, pos, fft_scratch_new%fft_scratch%mip ) @@ -3282,9 +3245,9 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) fft_scratch_new%fft_scratch%pos = pos mcy3 = fft_sizes%mcy3 ALLOCATE ( fft_scratch_new%fft_scratch%rbuf5(mx1*mz3*mcy3,0:DIM(1)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%rbuf6(mx1*mz1*mcy3,0:DIM(1)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) !set up fft plans CALL fft_create_plan_1dm(fft_scratch_new%fft_scratch%fft_plan(1), fft_type, FWFFT, .TRUE., n(3), mx1*my1, & @@ -3316,30 +3279,30 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) length = INT(2 * dp_size * MAX(mmax,1) * MAX(lmax,1), KIND=C_SIZE_T) ierr = cudaHostAlloc(cptr_r1buf, length, cudaHostAllocDefault) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL c_f_pointer(cptr_r1buf, fft_scratch_new%fft_scratch%r1buf, (/MAX(mmax,1),MAX(lmax,1)/)) length = INT(2 * dp_size * MAX(ny,1) * MAX(nz,1) * MAX(nx,1), KIND=C_SIZE_T) ierr = cudaHostAlloc(cptr_tbuf, length, cudaHostAllocDefault) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL c_f_pointer(cptr_tbuf, fft_scratch_new%fft_scratch%tbuf, (/MAX(ny,1),MAX(nz,1),MAX(nx,1)/)) #else ALLOCATE ( fft_scratch_new%fft_scratch%r1buf(mmax,lmax),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%tbuf(ny,nz,nx),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) #endif fft_scratch_new%fft_scratch%group = fft_sizes%gs_group ALLOCATE ( fft_scratch_new%fft_scratch%r2buf(lg,mg),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) nm = nmray*mx2 IF ( alltoall_sgl ) THEN ALLOCATE ( fft_scratch_new%fft_scratch%ss(mmax,lmax),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%tt(nm,0:np-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ELSE ALLOCATE ( fft_scratch_new%fft_scratch%rr(nm,0:np-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF !set up fft plans @@ -3372,67 +3335,67 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) nbx = fft_sizes%nbx nbz = fft_sizes%nbz ALLOCATE ( fft_scratch_new%fft_scratch%p1buf(mx1*my1,n(3)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%p6buf(lg,mg),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) length = INT(2 * dp_size * MAX(n(3),1) * MAX(mx1*my1,1), KIND=C_SIZE_T) ierr = cudaHostAlloc(cptr_p2buf, length, cudaHostAllocDefault) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL c_f_pointer(cptr_p2buf, fft_scratch_new%fft_scratch%p2buf, (/MAX(n(3),1),MAX(mx1*my1,1)/)) length = INT(2 * dp_size * MAX(mx2*mz2,1) * MAX(n(2),1), KIND=C_SIZE_T) ierr = cudaHostAlloc(cptr_p3buf, length, cudaHostAllocDefault) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL c_f_pointer(cptr_p3buf, fft_scratch_new%fft_scratch%p3buf, (/MAX(mx2*mz2,1),MAX(n(2),1)/)) length = INT(2 * dp_size * MAX(n(2),1) * MAX(mx2*mz2,1), KIND=C_SIZE_T) ierr = cudaHostAlloc(cptr_p4buf, length, cudaHostAllocDefault) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL c_f_pointer(cptr_p4buf, fft_scratch_new%fft_scratch%p4buf, (/MAX(n(2),1),MAX(mx2*mz2,1)/)) length = INT(2 * dp_size * MAX(nyzray,1) * MAX(n(1),1), KIND=C_SIZE_T) ierr = cudaHostAlloc(cptr_p5buf, length, cudaHostAllocDefault) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL c_f_pointer(cptr_p5buf, fft_scratch_new%fft_scratch%p5buf, (/MAX(nyzray,1),MAX(n(1),1)/)) length = INT(2 * dp_size * MAX(mg,1) * MAX(lg,1), KIND=C_SIZE_T) ierr = cudaHostAlloc(cptr_p7buf, length, cudaHostAllocDefault) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) CALL c_f_pointer(cptr_p7buf, fft_scratch_new%fft_scratch%p7buf, (/MAX(mg,1),MAX(lg,1)/)) #else ALLOCATE ( fft_scratch_new%fft_scratch%p2buf(n(3),mx1*my1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%p3buf(mx2*mz2,n(2)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%p4buf(n(2),mx2*mz2),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%p5buf(nyzray,n(1)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%p7buf(mg,lg),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) #endif IF ( alltoall_sgl ) THEN ALLOCATE ( fft_scratch_new%fft_scratch%yzbuf_sgl(mg*lg),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%xzbuf_sgl(n(2)*mx2*mz2),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ELSE ALLOCATE ( fft_scratch_new%fft_scratch%yzbuf(mg*lg),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%xzbuf(n(2)*mx2*mz2),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF ALLOCATE ( fft_scratch_new%fft_scratch%pgrid(0:m1-1,0:m2-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%xcor(nbx),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%zcor(nbz),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%pzcoord(0:np-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%xzcount(0:np-1), & fft_scratch_new%fft_scratch%yzcount(0:np-1) ) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%xzdispl(0:np-1), & fft_scratch_new%fft_scratch%yzdispl(0:np-1) ) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) fft_scratch_new%fft_scratch%in=0 fft_scratch_new%fft_scratch%rsratio=1._dp fft_scratch_new%fft_scratch%group = fft_sizes%gs_group @@ -3444,9 +3407,9 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) mcz1 = fft_sizes%mcz1 mcz2 = fft_sizes%mcz2 ALLOCATE ( fft_scratch_new%fft_scratch%rbuf1(mx2*my1*mcz2,0:DIM(2)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%rbuf2(mx1*my1*mcz2,0:DIM(2)-1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) dims = (/.FALSE.,.TRUE./) CALL mp_cart_sub( fft_sizes%rs_group, dims, fft_scratch_new%fft_scratch%cart_sub_comm(2)) @@ -3489,9 +3452,9 @@ SUBROUTINE get_fft_scratch(fft_scratch,tf_type,n,fft_sizes,error) CASE (400) ! serial FFT np = 0 ALLOCATE ( fft_scratch_new%fft_scratch%ziptr(n(1),n(2),n(3)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) ALLOCATE ( fft_scratch_new%fft_scratch%zoptr(n(1),n(2),n(3)),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) !in place plans CALL fft_create_plan_3d(fft_scratch_new%fft_scratch%fft_plan(1), fft_type, .TRUE., FWFFT, n, & @@ -3528,12 +3491,10 @@ END SUBROUTINE get_fft_scratch ! ***************************************************************************** !> \brief ... !> \param fft_scratch ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_fft_scratch(fft_scratch,error) + SUBROUTINE release_fft_scratch(fft_scratch) TYPE(fft_scratch_type), POINTER :: fft_scratch - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_fft_scratch', & routineP = moduleN//':'//routineN @@ -3557,7 +3518,7 @@ SUBROUTINE release_fft_scratch(fft_scratch,error) fft_scratch_current => fft_scratch_current%fft_scratch_next ELSE ! We cannot find the scratch type in this pool - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) EXIT END IF END DO diff --git a/src/pw/lgrid_types.F b/src/pw/lgrid_types.F index 897bd193c9..62d17aae6a 100644 --- a/src/pw/lgrid_types.F +++ b/src/pw/lgrid_types.F @@ -43,17 +43,14 @@ MODULE lgrid_types !> The grid is not allocated !> \param lgrid the lgrid that gets created !> \param rs_descs the rs grid descriptors used to set the lgrid size -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2011 created [IAB] !> \author Iain Bethune ! ***************************************************************************** -SUBROUTINE lgrid_create(lgrid,rs_descs,error) +SUBROUTINE lgrid_create(lgrid,rs_descs) TYPE(lgrid_type), POINTER :: lgrid TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lgrid_create', & routineP = moduleN//':'//routineN @@ -63,9 +60,9 @@ SUBROUTINE lgrid_create(lgrid,rs_descs,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(lgrid),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(lgrid),cp_failure_level,routineP,failure) ALLOCATE(lgrid, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(lgrid%r) lgrid%ref_count=1 ! Find the maximum number of grid points needed @@ -79,15 +76,12 @@ END SUBROUTINE lgrid_create ! ***************************************************************************** !> \brief retains the lgrid (see doc/ReferenceCounting.html) !> \param lgrid the lgrid_type to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2011 created [IAB] !> \author Iain Bethune ! ***************************************************************************** -SUBROUTINE lgrid_retain(lgrid,error) +SUBROUTINE lgrid_retain(lgrid) TYPE(lgrid_type), POINTER :: lgrid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lgrid_retain', & routineP = moduleN//':'//routineN @@ -96,23 +90,20 @@ SUBROUTINE lgrid_retain(lgrid,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(lgrid),cp_failure_level,routineP,error,failure) - CPPrecondition(lgrid%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(lgrid),cp_failure_level,routineP,failure) + CPPrecondition(lgrid%ref_count>0,cp_failure_level,routineP,failure) lgrid%ref_count=lgrid%ref_count+1 END SUBROUTINE lgrid_retain ! ***************************************************************************** !> \brief releases the given lgrid (see doc/ReferenceCounting.html) !> \param lgrid the lgrid_type to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2011 created [IAB] !> \author Iain Bethune ! ***************************************************************************** -SUBROUTINE lgrid_release(lgrid, error) +SUBROUTINE lgrid_release(lgrid) TYPE(lgrid_type), POINTER :: lgrid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lgrid_release', & routineP = moduleN//':'//routineN @@ -122,15 +113,15 @@ SUBROUTINE lgrid_release(lgrid, error) failure=.FALSE. IF (ASSOCIATED(lgrid)) THEN - CPPrecondition(lgrid%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(lgrid%ref_count>0,cp_failure_level,routineP,failure) lgrid%ref_count=lgrid%ref_count-1 IF (lgrid%ref_count<1) THEN IF (ASSOCIATED(lgrid%r)) THEN DEALLOCATE (lgrid%r,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE (lgrid,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(lgrid) END IF END IF @@ -140,16 +131,13 @@ SUBROUTINE lgrid_release(lgrid, error) !> \brief allocates the lgrid for a given number of threads !> \param lgrid the lgrid_type for which the grid will be allocated !> \param nthreads how many threads to allocate for -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2011 created [IAB] !> \author Iain Bethune ! ***************************************************************************** -SUBROUTINE lgrid_allocate_grid(lgrid, nthreads, error) +SUBROUTINE lgrid_allocate_grid(lgrid, nthreads) TYPE(lgrid_type), POINTER :: lgrid INTEGER, INTENT(in) :: nthreads - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lgrid_allocate_grid', & routineP = moduleN//':'//routineN @@ -157,8 +145,8 @@ SUBROUTINE lgrid_allocate_grid(lgrid, nthreads, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(lgrid),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(.NOT. ASSOCIATED(lgrid%r),cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(lgrid),cp_failure_level,routineP,failure) + CPPreconditionNoFail(.NOT. ASSOCIATED(lgrid%r),cp_failure_level,routineP) ALLOCATE(lgrid%r(lgrid%ldim*nthreads)) END SUBROUTINE diff --git a/src/pw/mt_util.F b/src/pw/mt_util.F index d256847976..fb8073060c 100644 --- a/src/pw/mt_util.F +++ b/src/pw/mt_util.F @@ -52,11 +52,10 @@ MODULE mt_util !> \param special_dimension ... !> \param slab_size ... !> \param super_ref_pw_grid ... -!> \param error ... !> \author Teodoro Laino (16.06.2004) ! ***************************************************************************** SUBROUTINE MTin_create_screen_fn(screen_function, pw_pool, method, alpha, & - special_dimension, slab_size, super_ref_pw_grid, error) + special_dimension, slab_size, super_ref_pw_grid) TYPE(pw_type), POINTER :: screen_function TYPE(pw_pool_type), POINTER :: pw_pool INTEGER, INTENT(IN) :: method @@ -64,7 +63,6 @@ SUBROUTINE MTin_create_screen_fn(screen_function, pw_pool, method, alpha, & INTEGER, INTENT(IN) :: special_dimension REAL(KIND=dp), INTENT(in) :: slab_size TYPE(pw_grid_type), POINTER :: super_ref_pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'MTin_create_screen_fn', & routineP = moduleN//':'//routineN @@ -84,33 +82,29 @@ SUBROUTINE MTin_create_screen_fn(screen_function, pw_pool, method, alpha, & ! CALL cite_reference(Martyna1999) IF (ASSOCIATED(super_ref_pw_grid)) THEN - CALL pw_pool_create ( pw_pool_aux, pw_grid = super_ref_pw_grid ,error=error) + CALL pw_pool_create ( pw_pool_aux, pw_grid = super_ref_pw_grid) END IF CALL pw_pool_create_pw(pw_pool, screen_function, use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) - CALL pw_zero( screen_function, error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero( screen_function) SELECT CASE( method ) CASE(MT0D) IF (ASSOCIATED(pw_pool_aux)) THEN - CALL pw_pool_create_pw(pw_pool_aux, Vloc, use_data=REALDATA3D, in_space=REALSPACE,& - error=error) - CALL pw_pool_create_pw(pw_pool_aux, Vlocg, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE,& - error=error) + CALL pw_pool_create_pw(pw_pool_aux, Vloc, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool_aux, Vlocg, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) ELSE - CALL pw_pool_create_pw(pw_pool, Vloc, use_data=REALDATA3D, in_space=REALSPACE,& - error=error) - CALL pw_pool_create_pw(pw_pool, Vlocg, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE,& - error=error) + CALL pw_pool_create_pw(pw_pool, Vloc, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, Vlocg, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) END IF CALL mt0din( Vloc, alpha) - CALL pw_transfer ( Vloc, Vlocg, error=error) - CALL pw_axpy(Vlocg, screen_function, error=error) + CALL pw_transfer ( Vloc, Vlocg) + CALL pw_axpy(Vlocg, screen_function) IF (ASSOCIATED(pw_pool_aux)) THEN - CALL pw_pool_give_back_pw(pw_pool_aux, Vloc, error=error) - CALL pw_pool_give_back_pw(pw_pool_aux, Vlocg, error=error) + CALL pw_pool_give_back_pw(pw_pool_aux, Vloc) + CALL pw_pool_give_back_pw(pw_pool_aux, Vlocg) ELSE - CALL pw_pool_give_back_pw(pw_pool, Vloc, error=error) - CALL pw_pool_give_back_pw(pw_pool, Vlocg, error=error) + CALL pw_pool_give_back_pw(pw_pool, Vloc) + CALL pw_pool_give_back_pw(pw_pool, Vlocg) END IF ! ! Get rid of the analytical FT of the erf(a*r)/r @@ -136,10 +130,10 @@ SUBROUTINE MTin_create_screen_fn(screen_function, pw_pool, method, alpha, & IF ( screen_function% pw_grid % have_g0 ) screen_function%cc ( 1 ) = pi * zlength*zlength / 2.0_dp CASE(MT1D) iz = special_dimension ! iz is the direction with PBC - CALL mt1din(screen_function,error) - CALL cp_unimplemented_error(routineP, "MT1D unimplemented", error, cp_failure_level) + CALL mt1din(screen_function) + CALL cp_unimplemented_error(routineP, "MT1D unimplemented",cp_failure_level) END SELECT - CALL pw_pool_release ( pw_pool_aux, error=error ) + CALL pw_pool_release ( pw_pool_aux) CALL timestop(handle) END SUBROUTINE MTin_create_screen_fn @@ -213,12 +207,10 @@ END SUBROUTINE Mt0din !> according the scheme published on: !> Martyna and Tuckerman, J. Chem. Phys. Vol. 121, No. 23, 11949 !> \param screen_function ... -!> \param error ... !> \author Teodoro Laino (11.2005) ! ***************************************************************************** - SUBROUTINE mt1din(screen_function,error) + SUBROUTINE mt1din(screen_function) TYPE(pw_type), POINTER :: screen_function - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mt1din', & routineP = moduleN//':'//routineN diff --git a/src/pw/ps_implicit_methods.F b/src/pw/ps_implicit_methods.F index bf9cfdd7b4..cc6c5815b3 100644 --- a/src/pw/ps_implicit_methods.F +++ b/src/pw/ps_implicit_methods.F @@ -105,13 +105,12 @@ MODULE ps_implicit_methods !> \param dct_aux_pw_grid ... !> \param green green function for FFT based inverse Laplacian !> \param ps_implicit_env implicit env to be created -!> \param error cp2k error !> \par History !> 06.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE ps_implicit_create(pw_pool, poisson_params, dct_pw_grid, dct_aux_pw_grid, & - green, ps_implicit_env, error) + green, ps_implicit_env) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(pw_poisson_parameter_type), & @@ -121,7 +120,6 @@ SUBROUTINE ps_implicit_create(pw_pool, poisson_params, dct_pw_grid, dct_aux_pw_g POINTER :: green TYPE(ps_implicit_type), INTENT(INOUT), & POINTER :: ps_implicit_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ps_implicit_create', & routineP = moduleN//':'//routineN @@ -142,28 +140,28 @@ SUBROUTINE ps_implicit_create(pw_pool, poisson_params, dct_pw_grid, dct_aux_pw_g ps_implicit_env%params%dbc_params = poisson_params%dbc_params ! create dielectric NULLIFY(ps_implicit_env%dielectric) - CALL dielectric_create(ps_implicit_env%dielectric, pw_pool, poisson_params%dielectric_params, error) + CALL dielectric_create(ps_implicit_env%dielectric, pw_pool, poisson_params%dielectric_params) NULLIFY(ps_implicit_env%initial_guess) NULLIFY(ps_implicit_env%v_eps) - CALL pw_pool_create_pw(pw_pool, ps_implicit_env%v_eps, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_zero(ps_implicit_env%v_eps, error) + CALL pw_pool_create_pw(pw_pool, ps_implicit_env%v_eps, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(ps_implicit_env%v_eps) NULLIFY(ps_implicit_env%cstr_charge) - CALL pw_pool_create_pw(pw_pool, ps_implicit_env%cstr_charge, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_zero(ps_implicit_env%cstr_charge, error) + CALL pw_pool_create_pw(pw_pool, ps_implicit_env%cstr_charge, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(ps_implicit_env%cstr_charge) ps_implicit_env%ehartree = 0.0_dp ps_implicit_env%times_called = 0 IF ((poisson_params%ps_implicit_params%boundary_condition .EQ. MIXED_BC) .OR. & (poisson_params%ps_implicit_params%boundary_condition .EQ. NEUMANN_BC)) THEN - CALL dct_type_init(pw_pool%pw_grid, ps_implicit_env%dct_env, error) + CALL dct_type_init(pw_pool%pw_grid, ps_implicit_env%dct_env) END IF ! prepare dirichlet bc - CALL dirichlet_boundary_region_setup(pw_pool, poisson_params, ps_implicit_env%gates, error) + CALL dirichlet_boundary_region_setup(pw_pool, poisson_params, ps_implicit_env%gates) CALL ps_implicit_prepare_blocks(pw_pool, dct_pw_grid, dct_aux_pw_grid, green, poisson_params, & - ps_implicit_env, error) + ps_implicit_env) END IF @@ -177,19 +175,16 @@ END SUBROUTINE ps_implicit_create !> \param density electron density !> \param v_new electrostatic potential !> \param ehartree Hartree energy -!> \param error cp2k error -!> !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE implicit_poisson_solver_periodic(poisson_env, density, v_new, ehartree, error) + SUBROUTINE implicit_poisson_solver_periodic(poisson_env, density, v_new, ehartree) TYPE(pw_poisson_type), POINTER :: poisson_env TYPE(pw_type), INTENT(IN), POINTER :: density TYPE(pw_type), INTENT(INOUT), POINTER :: v_new REAL(dp), INTENT(OUT), OPTIONAL :: ehartree - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'implicit_poisson_solver_periodic', & @@ -223,57 +218,57 @@ SUBROUTINE implicit_poisson_solver_periodic(poisson_env, density, v_new, ehartre times_called = ps_implicit_env%times_called ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool, error) + IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) - CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE) IF (use_zero_initial_guess) THEN - CALL pw_zero(v0, error=error) + CALL pw_zero(v0) ELSE - CALL pw_copy(ps_implicit_env%initial_guess, v0, error) + CALL pw_copy(ps_implicit_env%initial_guess, v0) END IF g%cr3d = fourpi * density%cr3d / dielectric%eps%cr3d - CALL pw_copy(v0, v_old, error=error) + CALL pw_copy(v0, v_old) ! res_old = g - \Delta(v_old) - P(v_old) - CALL apply_poisson_operator(pw_pool, green, dielectric, v_old, res_old, error) - CALL pw_scale(res_old, - 1.0_dp, error) - CALL pw_axpy(g, res_old, error=error) + CALL apply_poisson_operator(pw_pool, green, dielectric, v_old, res_old) + CALL pw_scale(res_old, - 1.0_dp) + CALL pw_axpy(g, res_old) ! evaluate \Delta^-1(res_old) - CALL apply_inv_laplace_operator(pw_pool, green, res_old, QAinvxres, error) + CALL apply_inv_laplace_operator(pw_pool, green, res_old, QAinvxres) iter = 1 DO ! v_new = v_old + \omega * QAinvxres_old - CALL pw_scale(QAinvxres, omega, error=error) - CALL pw_copy(QAinvxres, v_new, error=error) - CALL pw_axpy(v_old, v_new, error=error) + CALL pw_scale(QAinvxres, omega) + CALL pw_copy(QAinvxres, v_new) + CALL pw_axpy(v_old, v_new) ! res_new = res_old - \omega * ( \Delta(QAinvxres_old) + P(QAinvxres_old) ) ! = (1 - \omega) * res_old - \omega * PxQAinvxres - CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres , error=error) - CALL pw_copy(PxQAinvxres, res_new, error=error) - CALL pw_scale(res_new, - 1.0_dp , error) - CALL pw_axpy(res_old, res_new, 1.0_dp - omega, error=error) + CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres) + CALL pw_copy(PxQAinvxres, res_new) + CALL pw_scale(res_new, - 1.0_dp) + CALL pw_axpy(res_old, res_new, 1.0_dp - omega) ! compute the error CALL ps_implicit_compute_error(pw_pool, green, res_new, v_old, v_new, QAinvxres, & - pres_error, nabs_error, error) + pres_error, nabs_error) ! output - CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit, error) + CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit) IF (PRESENT(ehartree)) THEN - CALL ps_implicit_compute_ehartree(density, v_new, ehartree, error) - CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree, error) + CALL ps_implicit_compute_ehartree(density, v_new, ehartree) + CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree) ps_implicit_env%ehartree = ehartree ELSE IF (outp_unit .GT. 0) WRITE(outp_unit, '(A1,/)') @@ -283,30 +278,30 @@ SUBROUTINE implicit_poisson_solver_periodic(poisson_env, density, v_new, ehartre reached_max_iter = iter .GT. max_iter reached_tol = pres_error .LE. tol IF (pres_error .GT. large_error) CALL cp_assert( .FALSE. , cp_failure_level, cp_assertion_failed, & - routineP, "Poisson solver did not converge.", error) + routineP, "Poisson solver did not converge.") ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT ! v_old = v_new, res_old = res_new - CALL pw_copy(v_new, v_old, error=error) - CALL pw_copy(res_new, res_old, error=error) + CALL pw_copy(v_new, v_old) + CALL pw_copy(res_new, res_old) END DO IF ((times_called .NE. 0) .AND. (.NOT. use_zero_initial_guess)) & - CALL pw_copy(v_new, ps_implicit_env%initial_guess, error) + CALL pw_copy(v_new, ps_implicit_env%initial_guess) IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric - CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps, error) + CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps) - CALL pw_pool_give_back_pw(pw_pool, g, error=error) - CALL pw_pool_give_back_pw(pw_pool, v0, error=error) - CALL pw_pool_give_back_pw(pw_pool, v_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_new, error=error) - CALL pw_pool_give_back_pw(pw_pool, QAinvxres, error=error) - CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres, error=error) + CALL pw_pool_give_back_pw(pw_pool, g) + CALL pw_pool_give_back_pw(pw_pool, v0) + CALL pw_pool_give_back_pw(pw_pool, v_old) + CALL pw_pool_give_back_pw(pw_pool, res_old) + CALL pw_pool_give_back_pw(pw_pool, res_new) + CALL pw_pool_give_back_pw(pw_pool, QAinvxres) + CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres) CALL timestop(handle) @@ -319,19 +314,16 @@ END SUBROUTINE implicit_poisson_solver_periodic !> \param density electron density !> \param v_new electrostatic potential !> \param ehartree Hartree energy -!> \param error cp2k error -!> !> \par History !> 02.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE implicit_poisson_solver_neumann(poisson_env, density, v_new, ehartree, error) + SUBROUTINE implicit_poisson_solver_neumann(poisson_env, density, v_new, ehartree) TYPE(pw_poisson_type), POINTER :: poisson_env TYPE(pw_type), INTENT(IN), POINTER :: density TYPE(pw_type), INTENT(INOUT), POINTER :: v_new REAL(dp), INTENT(OUT), OPTIONAL :: ehartree - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'implicit_poisson_solver_neumann', & @@ -368,33 +360,33 @@ SUBROUTINE implicit_poisson_solver_neumann(poisson_env, density, v_new, ehartree times_called = ps_implicit_env%times_called ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool, error) - - CALL pw_pool_create(pw_pool_xpndd, pw_grid=poisson_env%dct_pw_grid, error=error) - CALL pw_pool_create(aux_pw_pool_xpndd, pw_grid=poisson_env%dct_aux_pw_grid, error=error) - CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) + IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) + + CALL pw_pool_create(pw_pool_xpndd, pw_grid=poisson_env%dct_pw_grid) + CALL pw_pool_create(aux_pw_pool_xpndd, pw_grid=poisson_env%dct_aux_pw_grid) + CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE) IF (use_zero_initial_guess) THEN - CALL pw_zero(v0, error=error) + CALL pw_zero(v0) ELSE - CALL pw_copy(ps_implicit_env%initial_guess, v0, error) + CALL pw_copy(ps_implicit_env%initial_guess, v0) END IF g%cr3d = fourpi * density%cr3d / dielectric%eps%cr3d - CALL pw_copy(v0, v_old, error=error) + CALL pw_copy(v0, v_old) ! res_old = g - \Delta(v_old) - P(v_old) CALL apply_poisson_operator(pw_pool, green, dielectric, pw_pool_xpndd, aux_pw_pool_xpndd, dct_env, & - adjust_local_bounds, v_old, res_old, error) - CALL pw_scale(res_old, - 1.0_dp, error) - CALL pw_axpy(g, res_old, error=error) + adjust_local_bounds, v_old, res_old) + CALL pw_scale(res_old, - 1.0_dp) + CALL pw_axpy(g, res_old) ! evaluate \Delta^-1(res_old) CALL apply_inv_laplace_operator(pw_pool_xpndd, aux_pw_pool_xpndd, green, & @@ -402,31 +394,31 @@ SUBROUTINE implicit_poisson_solver_neumann(poisson_env, density, v_new, ehartree dct_env%srcs_expand, dct_env%flipg_stat, & dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_shftd, dct_env%bounds_local_shftd, & - adjust_local_bounds, res_old, QAinvxres, error) + adjust_local_bounds, res_old, QAinvxres) iter = 1 DO ! v_new = v_old + \omega * QAinvxres_old - CALL pw_scale(QAinvxres, omega, error=error) - CALL pw_copy(QAinvxres, v_new, error=error) - CALL pw_axpy(v_old, v_new, error=error) + CALL pw_scale(QAinvxres, omega) + CALL pw_copy(QAinvxres, v_new) + CALL pw_axpy(v_old, v_new) ! res_new = res_old - \omega * ( \Delta(QAinvxres_old) + P(QAinvxres_old) ) ! = (1 - \omega) * res_old - \omega * PxQAinvxres - CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres , error=error) - CALL pw_copy(PxQAinvxres, res_new, error=error) - CALL pw_scale(res_new, - 1.0_dp , error) - CALL pw_axpy(res_old, res_new, 1.0_dp - omega, error=error) + CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres) + CALL pw_copy(PxQAinvxres, res_new) + CALL pw_scale(res_new, - 1.0_dp) + CALL pw_axpy(res_old, res_new, 1.0_dp - omega) ! compute the error CALL ps_implicit_compute_error(pw_pool, green, pw_pool_xpndd, aux_pw_pool_xpndd, dct_env, res_new, & - v_old, v_new, QAinvxres, adjust_local_bounds, pres_error, nabs_error, error) + v_old, v_new, QAinvxres, adjust_local_bounds, pres_error, nabs_error) ! output - CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit, error) + CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit) IF (PRESENT(ehartree)) THEN - CALL ps_implicit_compute_ehartree(density, v_new, ehartree, error) - CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree, error) + CALL ps_implicit_compute_ehartree(density, v_new, ehartree) + CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree) ps_implicit_env%ehartree = ehartree ELSE IF (outp_unit .GT. 0) WRITE(outp_unit, '(A1,/)') @@ -436,32 +428,32 @@ SUBROUTINE implicit_poisson_solver_neumann(poisson_env, density, v_new, ehartree reached_max_iter = iter .GT. max_iter reached_tol = pres_error .LE. tol IF (pres_error .GT. large_error) CALL cp_assert( .FALSE. , cp_failure_level, cp_assertion_failed, & - routineP, "Poisson solver did not converge.", error) + routineP, "Poisson solver did not converge.") ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (reached_max_iter .OR. reached_tol) EXIT ! v_old = v_new, res_old = res_new - CALL pw_copy(v_new, v_old, error=error) - CALL pw_copy(res_new, res_old, error=error) + CALL pw_copy(v_new, v_old) + CALL pw_copy(res_new, res_old) END DO IF ((times_called .NE. 0) .AND. (.NOT. use_zero_initial_guess)) & - CALL pw_copy(v_new, ps_implicit_env%initial_guess, error) + CALL pw_copy(v_new, ps_implicit_env%initial_guess) IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric - CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps, error) - - CALL pw_pool_give_back_pw(pw_pool, g, error=error) - CALL pw_pool_give_back_pw(pw_pool, v0, error=error) - CALL pw_pool_give_back_pw(pw_pool, v_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_new, error=error) - CALL pw_pool_give_back_pw(pw_pool, QAinvxres, error=error) - CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres, error=error) - CALL pw_pool_release(aux_pw_pool_xpndd, error=error) - CALL pw_pool_release(pw_pool_xpndd, error=error) + CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps) + + CALL pw_pool_give_back_pw(pw_pool, g) + CALL pw_pool_give_back_pw(pw_pool, v0) + CALL pw_pool_give_back_pw(pw_pool, v_old) + CALL pw_pool_give_back_pw(pw_pool, res_old) + CALL pw_pool_give_back_pw(pw_pool, res_new) + CALL pw_pool_give_back_pw(pw_pool, QAinvxres) + CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres) + CALL pw_pool_release(aux_pw_pool_xpndd) + CALL pw_pool_release(pw_pool_xpndd) CALL timestop(handle) @@ -473,19 +465,16 @@ END SUBROUTINE implicit_poisson_solver_neumann !> \param density electron density !> \param v_new electrostatic potential !> \param ehartree Hartree energy -!> \param error cp2k error -!> !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE implicit_poisson_solver_mixed_periodic(poisson_env, density, v_new, ehartree, error) + SUBROUTINE implicit_poisson_solver_mixed_periodic(poisson_env, density, v_new, ehartree) TYPE(pw_poisson_type), POINTER :: poisson_env TYPE(pw_type), INTENT(IN), POINTER :: density TYPE(pw_type), INTENT(INOUT), POINTER :: v_new REAL(dp), INTENT(OUT), OPTIONAL :: ehartree - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'implicit_poisson_solver_mixed_periodic', & @@ -554,7 +543,7 @@ SUBROUTINE implicit_poisson_solver_mixed_periodic(poisson_env, density, v_new, e END IF ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool, error) + IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) ALLOCATE(B (n_tiles_tot, data_size)) ALLOCATE(Bt(data_size, n_tiles_tot)) @@ -584,53 +573,53 @@ SUBROUTINE implicit_poisson_solver_mixed_periodic(poisson_env, density, v_new, e ALLOCATE(v_new1D(data_size)) ALLOCATE(Bxv_new(n_tiles_tot)) - CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, Axvbar, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, Axvbar, use_data=REALDATA3D, in_space=REALSPACE) IF (use_zero_initial_guess) THEN - CALL pw_zero(v0, error=error) + CALL pw_zero(v0) lambda0 = 0.0_dp ELSE - CALL pw_copy(ps_implicit_env%initial_guess, v0, error) + CALL pw_copy(ps_implicit_env%initial_guess, v0) lambda0(:) = ps_implicit_env%initial_lambda END IF g%cr3d = fourpi * density%cr3d / dielectric%eps%cr3d g_avg = accurate_sum(g%cr3d) / ngpts - CALL pw_copy(v0, v_old, error=error) + CALL pw_copy(v0, v_old) lambda_old(:)= lambda0 ! res_old = g - \Delta(v_old) - P(v_old) - B^t * \lambda_old - CALL apply_poisson_operator(pw_pool, green, dielectric, v_old, res_old, error) - CALL pw_scale(res_old, - 1.0_dp, error) - CALL pw_axpy(g, res_old, error=error) + CALL apply_poisson_operator(pw_pool, green, dielectric, v_old, res_old) + CALL pw_scale(res_old, - 1.0_dp) + CALL pw_axpy(g, res_old) IF (data_size .NE. 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_old, 1, 0.0_dp, Btxlambda_old, 1) END IF - CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_old, Btxlambda_old3D, error) + CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_old, Btxlambda_old3D) res_old%cr3d = res_old%cr3d - Btxlambda_old3D ! evaluate \Delta^-1(res_old) - CALL apply_inv_laplace_operator(pw_pool, green, res_old, QAinvxres, error) + CALL apply_inv_laplace_operator(pw_pool, green, res_old, QAinvxres) iter = 1 DO ! v_new (v_bar) = v_old + \omega * QAinvxres_old - CALL pw_scale(QAinvxres, omega, error=error) - CALL pw_copy(QAinvxres, v_new, error=error) - CALL pw_axpy(v_old, v_new, error=error) + CALL pw_scale(QAinvxres, omega) + CALL pw_copy(QAinvxres, v_new) + CALL pw_axpy(v_old, v_new) ! evaluate 1^t * (g - \Delta(\bar{v}) - P(\bar{v})) ! = 1^t * (g - P(\bar{v})) - CALL apply_P_operator(pw_pool, dielectric, v_new, Axvbar, error=error) + CALL apply_P_operator(pw_pool, dielectric, v_new, Axvbar) Axvbar_avg = accurate_sum(Axvbar%cr3d) / ngpts gminusAxvbar_avg = g_avg - Axvbar_avg CALL mp_sum(gminusAxvbar_avg, pw_grid%para%group) @@ -654,24 +643,24 @@ SUBROUTINE implicit_poisson_solver_mixed_periodic(poisson_env, density, v_new, e IF (data_size .NE. 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_new, 1, 0.0_dp, Btxlambda_new, 1) END IF - CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_new, Btxlambda_new3D, error) + CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_new, Btxlambda_new3D) ! res_new = res_old - \omega * ( \Delta(QAinvxres_old) + P(QAinvxres_old) ) - B^t * ( \lambda_new - \lambda_old ) ! = (1 - \omega) * res_old - \omega * P(QAinvxres_old) - B^t * ( \lambda_new - \lambda_old ) - CALL pw_zero(res_new, error=error) - CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres, error=error) - CALL pw_axpy(PxQAinvxres, res_new, - 1.0_dp, error=error) - CALL pw_axpy(res_old, res_new, 1.0_dp - omega, error=error) + CALL pw_zero(res_new) + CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres) + CALL pw_axpy(PxQAinvxres, res_new, - 1.0_dp) + CALL pw_axpy(res_old, res_new, 1.0_dp - omega) res_new%cr3d = res_new%cr3d + Btxlambda_old3D - Btxlambda_new3D ! compute the error CALL ps_implicit_compute_error(pw_pool, green, res_new, v_old, v_new, QAinvxres, & - pres_error, nabs_error, error) + pres_error, nabs_error) ! output - CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit, error) + CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit) IF (PRESENT(ehartree)) THEN - CALL ps_implicit_compute_ehartree(dielectric, density, Btxlambda_new3D, v_new, ehartree, error) - CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree, error) + CALL ps_implicit_compute_ehartree(dielectric, density, Btxlambda_new3D, v_new, ehartree) + CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree) ps_implicit_env%ehartree = ehartree ELSE IF (outp_unit .GT. 0) WRITE(outp_unit, '(A1,/)') @@ -703,35 +692,35 @@ SUBROUTINE implicit_poisson_solver_mixed_periodic(poisson_env, density, v_new, e reached_tol = pres_error .LE. tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (pres_error .GT. large_error) CALL cp_assert( .FALSE. , cp_failure_level, cp_assertion_failed, & - routineP, "Poisson solver did not converge.", error) + routineP, "Poisson solver did not converge.") IF (reached_max_iter .OR. reached_tol) EXIT ! update - CALL pw_copy(v_new, v_old, error=error) + CALL pw_copy(v_new, v_old) lambda_old(:) = lambda_new - CALL pw_copy(res_new, res_old, error=error) + CALL pw_copy(res_new, res_old) Btxlambda_old3D(:,:,:) = Btxlambda_new3D END DO IF ((times_called .NE. 0) .AND. (.NOT. use_zero_initial_guess)) THEN - CALL pw_copy(v_new, ps_implicit_env%initial_guess, error) + CALL pw_copy(v_new, ps_implicit_env%initial_guess) ps_implicit_env%initial_lambda = lambda_new END IF ps_implicit_env%cstr_charge%cr3d = Btxlambda_new3D IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric - CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps, error) + CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps) - CALL pw_pool_give_back_pw(pw_pool, g, error=error) - CALL pw_pool_give_back_pw(pw_pool, v0, error=error) - CALL pw_pool_give_back_pw(pw_pool, v_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_new, error=error) - CALL pw_pool_give_back_pw(pw_pool, QAinvxres, error=error) - CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres, error=error) - CALL pw_pool_give_back_pw(pw_pool, Axvbar, error=error) + CALL pw_pool_give_back_pw(pw_pool, g) + CALL pw_pool_give_back_pw(pw_pool, v0) + CALL pw_pool_give_back_pw(pw_pool, v_old) + CALL pw_pool_give_back_pw(pw_pool, res_old) + CALL pw_pool_give_back_pw(pw_pool, res_new) + CALL pw_pool_give_back_pw(pw_pool, QAinvxres) + CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres) + CALL pw_pool_give_back_pw(pw_pool, Axvbar) CALL timestop(handle) @@ -743,19 +732,16 @@ END SUBROUTINE implicit_poisson_solver_mixed_periodic !> \param density electron density !> \param v_new electrostatic potential !> \param ehartree Hartree energy -!> \param error cp2k error -!> !> \par History !> 10.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE implicit_poisson_solver_mixed(poisson_env, density, v_new, ehartree, error) + SUBROUTINE implicit_poisson_solver_mixed(poisson_env, density, v_new, ehartree) TYPE(pw_poisson_type), POINTER :: poisson_env TYPE(pw_type), INTENT(IN), POINTER :: density TYPE(pw_type), INTENT(INOUT), POINTER :: v_new REAL(dp), INTENT(OUT), OPTIONAL :: ehartree - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'implicit_poisson_solver_mixed', & @@ -827,7 +813,7 @@ SUBROUTINE implicit_poisson_solver_mixed(poisson_env, density, v_new, ehartree, END IF ! check if this is the first scf iteration - IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool, error) + IF (times_called .EQ. 0) CALL ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) ALLOCATE(B (n_tiles_tot, data_size)) ALLOCATE(Bt(data_size, n_tiles_tot)) @@ -857,40 +843,40 @@ SUBROUTINE implicit_poisson_solver_mixed(poisson_env, density, v_new, ehartree, ALLOCATE(v_new1D(data_size)) ALLOCATE(Bxv_new(n_tiles_tot)) - CALL pw_pool_create(pw_pool_xpndd, pw_grid=poisson_env%dct_pw_grid, error=error) - CALL pw_pool_create(aux_pw_pool_xpndd, pw_grid=poisson_env%dct_aux_pw_grid, error=error) - CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, Axvbar, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create(pw_pool_xpndd, pw_grid=poisson_env%dct_pw_grid) + CALL pw_pool_create(aux_pw_pool_xpndd, pw_grid=poisson_env%dct_aux_pw_grid) + CALL pw_pool_create_pw(pw_pool, g, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v0, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, v_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_old, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, res_new, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, QAinvxres, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, PxQAinvxres, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, Axvbar, use_data=REALDATA3D, in_space=REALSPACE) IF (use_zero_initial_guess) THEN - CALL pw_zero(v0, error=error) + CALL pw_zero(v0) lambda0 = 0.0_dp ELSE - CALL pw_copy(ps_implicit_env%initial_guess, v0, error) + CALL pw_copy(ps_implicit_env%initial_guess, v0) lambda0(:) = ps_implicit_env%initial_lambda END IF g%cr3d = fourpi * density%cr3d / dielectric%eps%cr3d g_avg = accurate_sum(g%cr3d) / ngpts - CALL pw_copy(v0, v_old, error=error) + CALL pw_copy(v0, v_old) lambda_old(:)= lambda0 ! res_old = g - \Delta(v_old) - P(v_old) - B^t * \lambda_old CALL apply_poisson_operator(pw_pool, green, dielectric, pw_pool_xpndd, aux_pw_pool_xpndd, dct_env, & - adjust_local_bounds, v_old, res_old, error) - CALL pw_scale(res_old, - 1.0_dp, error) - CALL pw_axpy(g, res_old, error=error) + adjust_local_bounds, v_old, res_old) + CALL pw_scale(res_old, - 1.0_dp) + CALL pw_axpy(g, res_old) IF (data_size .NE. 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_old, 1, 0.0_dp, Btxlambda_old, 1) END IF - CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_old, Btxlambda_old3D, error) + CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_old, Btxlambda_old3D) res_old%cr3d = res_old%cr3d - Btxlambda_old3D ! evaluate \Delta^-1(res_old) @@ -899,19 +885,19 @@ SUBROUTINE implicit_poisson_solver_mixed(poisson_env, density, v_new, ehartree, dct_env%srcs_expand, dct_env%flipg_stat, & dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_shftd, dct_env%bounds_local_shftd, & - adjust_local_bounds, res_old, QAinvxres, error) + adjust_local_bounds, res_old, QAinvxres) iter = 1 DO ! v_new (v_bar) = v_old + \omega * QAinvxres_old - CALL pw_scale(QAinvxres, omega, error=error) - CALL pw_copy(QAinvxres, v_new, error=error) - CALL pw_axpy(v_old, v_new, error=error) + CALL pw_scale(QAinvxres, omega) + CALL pw_copy(QAinvxres, v_new) + CALL pw_axpy(v_old, v_new) ! evaluate 1^t * (g - \Delta(\bar{v}) - P(\bar{v})) ! = 1^t * (g - P(\bar{v})) - CALL apply_P_operator(pw_pool, dielectric, v_new, Axvbar, error=error) + CALL apply_P_operator(pw_pool, dielectric, v_new, Axvbar) Axvbar_avg = accurate_sum(Axvbar%cr3d) / ngpts gminusAxvbar_avg = g_avg - Axvbar_avg CALL mp_sum(gminusAxvbar_avg, pw_grid%para%group) @@ -935,24 +921,24 @@ SUBROUTINE implicit_poisson_solver_mixed(poisson_env, density, v_new, ehartree, IF (data_size .NE. 0) THEN CALL DGEMV('N', data_size, n_tiles_tot, 1.0_dp, Bt, data_size, lambda_new, 1, 0.0_dp, Btxlambda_new, 1) END IF - CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_new, Btxlambda_new3D, error) + CALL convert_1dto3d(ps_implicit_env%idx_1dto3d, Btxlambda_new, Btxlambda_new3D) ! res_new = res_old - \omega * ( \Delta(QAinvxres_old) + P(QAinvxres_old) ) - B^t * ( \lambda_new - \lambda_old ) ! = (1 - \omega) * res_old - \omega * P(QAinvxres_old) - B^t * ( \lambda_new - \lambda_old ) - CALL pw_zero(res_new, error=error) - CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres, error=error) - CALL pw_axpy(PxQAinvxres, res_new, - 1.0_dp, error=error) - CALL pw_axpy(res_old, res_new, 1.0_dp - omega, error=error) + CALL pw_zero(res_new) + CALL apply_P_operator(pw_pool, dielectric, QAinvxres, PxQAinvxres) + CALL pw_axpy(PxQAinvxres, res_new, - 1.0_dp) + CALL pw_axpy(res_old, res_new, 1.0_dp - omega) res_new%cr3d = res_new%cr3d - Btxlambda_new3D + Btxlambda_old3D ! compute the error CALL ps_implicit_compute_error(pw_pool, green, pw_pool_xpndd, aux_pw_pool_xpndd, dct_env, res_new, & - v_old, v_new, QAinvxres, adjust_local_bounds, pres_error, nabs_error, error) + v_old, v_new, QAinvxres, adjust_local_bounds, pres_error, nabs_error) ! output - CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit, error) + CALL ps_implicit_output(iter, pres_error, nabs_error, outp_unit) IF (PRESENT(ehartree)) THEN - CALL ps_implicit_compute_ehartree(dielectric, density, Btxlambda_new3D, v_new, ehartree, error) - CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree, error) + CALL ps_implicit_compute_ehartree(dielectric, density, Btxlambda_new3D, v_new, ehartree) + CALL ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree) ps_implicit_env%ehartree = ehartree ELSE IF (outp_unit .GT. 0) WRITE(outp_unit, '(A1,/)') @@ -984,37 +970,37 @@ SUBROUTINE implicit_poisson_solver_mixed(poisson_env, density, v_new, ehartree, reached_tol = pres_error .LE. tol ps_implicit_env%times_called = ps_implicit_env%times_called + 1 IF (pres_error .GT. large_error) CALL cp_assert( .FALSE. , cp_failure_level, cp_assertion_failed, & - routineP, "Poisson solver did not converge.", error) + routineP, "Poisson solver did not converge.") IF (reached_max_iter .OR. reached_tol) EXIT ! update - CALL pw_copy(v_new, v_old, error=error) + CALL pw_copy(v_new, v_old) lambda_old(:) = lambda_new - CALL pw_copy(res_new, res_old, error=error) + CALL pw_copy(res_new, res_old) Btxlambda_old3D(:,:,:) = Btxlambda_new3D END DO IF ((times_called .NE. 0) .AND. (.NOT. use_zero_initial_guess)) THEN - CALL pw_copy(v_new, ps_implicit_env%initial_guess, error) + CALL pw_copy(v_new, ps_implicit_env%initial_guess) ps_implicit_env%initial_lambda = lambda_new END IF ps_implicit_env%cstr_charge%cr3d = Btxlambda_new3D IF (PRESENT(ehartree)) ehartree = ps_implicit_env%ehartree ! compute the extra contribution to the Hamiltonian due to the presence of dielectric - CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps, error) - - CALL pw_pool_give_back_pw(pw_pool, g, error=error) - CALL pw_pool_give_back_pw(pw_pool, v0, error=error) - CALL pw_pool_give_back_pw(pw_pool, v_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_old, error=error) - CALL pw_pool_give_back_pw(pw_pool, res_new, error=error) - CALL pw_pool_give_back_pw(pw_pool, QAinvxres, error=error) - CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres, error=error) - CALL pw_pool_give_back_pw(pw_pool, Axvbar, error=error) - CALL pw_pool_release(aux_pw_pool_xpndd, error=error) - CALL pw_pool_release(pw_pool_xpndd, error=error) + CALL ps_implicit_compute_veps(pw_pool, dielectric, v_new, ps_implicit_env%v_eps) + + CALL pw_pool_give_back_pw(pw_pool, g) + CALL pw_pool_give_back_pw(pw_pool, v0) + CALL pw_pool_give_back_pw(pw_pool, v_old) + CALL pw_pool_give_back_pw(pw_pool, res_old) + CALL pw_pool_give_back_pw(pw_pool, res_new) + CALL pw_pool_give_back_pw(pw_pool, QAinvxres) + CALL pw_pool_give_back_pw(pw_pool, PxQAinvxres) + CALL pw_pool_give_back_pw(pw_pool, Axvbar) + CALL pw_pool_release(aux_pw_pool_xpndd) + CALL pw_pool_release(pw_pool_xpndd) CALL timestop(handle) @@ -1024,17 +1010,15 @@ END SUBROUTINE implicit_poisson_solver_mixed !> \brief allocates and zeroises initial guess for implicit (iterative) Poisson solver !> \param ps_implicit_env the implicit env contaning the initial guess !> \param pw_pool pool of pw grid -!> \param error cp2k error !> \par History !> 06.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE ps_implicit_initial_guess_create(ps_implicit_env, pw_pool, error) + SUBROUTINE ps_implicit_initial_guess_create(ps_implicit_env, pw_pool) TYPE(ps_implicit_type), INTENT(INOUT), & POINTER :: ps_implicit_env TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'ps_implicit_initial_guess_create', & @@ -1046,9 +1030,8 @@ SUBROUTINE ps_implicit_initial_guess_create(ps_implicit_env, pw_pool, error) n_tiles_tot = SIZE(ps_implicit_env%v_D) CALL pw_pool_create_pw(pw_pool, ps_implicit_env%initial_guess, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) - CALL pw_zero(ps_implicit_env%initial_guess, error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(ps_implicit_env%initial_guess) ALLOCATE(ps_implicit_env%initial_lambda(n_tiles_tot)) ps_implicit_env%initial_lambda = 0.0_dp @@ -1064,13 +1047,12 @@ END SUBROUTINE ps_implicit_initial_guess_create !> \param green green functions for FFT based inverse Laplacian !> \param poisson_params paramaters of the poisson_env !> \param ps_implicit_env the implicit_env that stores the blocks -!> \param error cp2k error !> \par History !> 10.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid, green, & - poisson_params, ps_implicit_env, error) + poisson_params, ps_implicit_env) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool_orig TYPE(pw_grid_type), INTENT(IN), POINTER :: dct_pw_grid, dct_aux_pw_grid @@ -1080,7 +1062,6 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid INTENT(IN) :: poisson_params TYPE(ps_implicit_type), INTENT(INOUT), & POINTER :: ps_implicit_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ps_implicit_prepare_blocks', & routineP = moduleN//':'//routineN @@ -1109,7 +1090,7 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid pw_grid_orig => pw_pool_orig%pw_grid - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN unit_nr = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -1171,10 +1152,10 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid ALLOCATE(R(n_tiles_tot+1, n_tiles_tot+1)) ALLOCATE(work_arr(n_tiles_tot+1), ipiv(n_tiles_tot+1)) ! LAPACK work and ipiv arrays - CALL setup_grid_axes(pw_grid_orig, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, error) + CALL setup_grid_axes(pw_grid_orig, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) ! prepare pw_pool for evaluating inverse Laplacian of tile_pw's using DCT - CALL pw_pool_create(pw_pool_xpndd, pw_grid=dct_pw_grid, error=error) - CALL pw_pool_create(aux_pw_pool_xpndd, pw_grid=dct_aux_pw_grid, error=error) + CALL pw_pool_create(pw_pool_xpndd, pw_grid=dct_pw_grid) + CALL pw_pool_create(aux_pw_pool_xpndd, pw_grid=dct_aux_pw_grid) ! set up B, B^t, (\Delta^-1)*B^t indx1 = 1 @@ -1186,47 +1167,47 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid IF (smooth) THEN DO i = 1, n_tiles tile_pw => ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw - CALL pw_pool_create_pw(pw_pool_orig, pw_in, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_mollifier(pw_pool_orig, zeta, x_glbl, y_glbl, z_glbl, tile_pw, pw_in, error) + CALL pw_pool_create_pw(pw_pool_orig, pw_in, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_mollifier(pw_pool_orig, zeta, x_glbl, y_glbl, z_glbl, tile_pw, pw_in) smooth_tile_npts = accurate_sum(pw_in%cr3d) CALL mp_sum(smooth_tile_npts, pw_grid_orig%para%group) - CALL pw_scale(pw_in, 1.0_dp / smooth_tile_npts, error) ! normalize tile_pw + CALL pw_scale(pw_in, 1.0_dp / smooth_tile_npts) ! normalize tile_pw ps_implicit_env%Bt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_in%cr3d, (/data_size/)) - CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE) CALL apply_inv_laplace_operator(pw_pool_xpndd, aux_pw_pool_xpndd, green, & dct_env%recv_msgs_bnds, dct_env%dests_expand, & dct_env%srcs_expand, dct_env%flipg_stat, & dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_shftd, dct_env%bounds_local_shftd, & - adjust_local_bounds, pw_in, pw_out, error) + adjust_local_bounds, pw_in, pw_out) QAinvxBt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_out%cr3d, (/data_size/)) ! the electrostatic potential has opposite sign by internal convention ps_implicit_env%v_D(indx1+i-1) = -1.0_dp * ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%v_D - CALL pw_pool_give_back_pw(pw_pool_orig, pw_out, error=error) - CALL pw_pool_give_back_pw(pw_pool_orig, pw_in, error=error) + CALL pw_pool_give_back_pw(pw_pool_orig, pw_out) + CALL pw_pool_give_back_pw(pw_pool_orig, pw_in) END DO ELSE DO i = 1, n_tiles pw_in => ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw tile_npts = ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%npts - CALL pw_scale(pw_in, 1.0_dp / tile_npts, error) ! normalize tile_pw + CALL pw_scale(pw_in, 1.0_dp / tile_npts) ! normalize tile_pw ps_implicit_env%Bt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_in%cr3d, (/data_size/)) - CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE) CALL apply_inv_laplace_operator(pw_pool_xpndd, aux_pw_pool_xpndd, green, & dct_env%recv_msgs_bnds, dct_env%dests_expand, & dct_env%srcs_expand, dct_env%flipg_stat, & dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_shftd, dct_env%bounds_local_shftd, & - adjust_local_bounds, pw_in, pw_out, error) + adjust_local_bounds, pw_in, pw_out) QAinvxBt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_out%cr3d, (/data_size/)) ! the electrostatic potential has opposite sign by internal convention ps_implicit_env%v_D(indx1+i-1) = -1.0_dp * ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%v_D - CALL pw_pool_give_back_pw(pw_pool_orig, pw_out, error=error) + CALL pw_pool_give_back_pw(pw_pool_orig, pw_out) END DO END IF indx1 = indx2 + 1 @@ -1254,14 +1235,14 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid CALL DGETRF(n_tiles_tot+1, n_tiles_tot+1, ps_implicit_env%Rinv, n_tiles_tot+1, ipiv, info) IF (info .NE. 0) CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & - "you need to reduce the number of tiles.", error) + "you need to reduce the number of tiles.") CALL DGETRI(n_tiles_tot+1, ps_implicit_env%Rinv, n_tiles_tot+1, ipiv, work_arr, n_tiles_tot+1, info) IF (info .NE. 0) CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & - "Inversion of R failed!", error) + "Inversion of R failed!") DEALLOCATE(QAinvxBt, Bxunit_vec, R, work_arr, ipiv) - CALL pw_pool_release(pw_pool_xpndd, error=error) - CALL pw_pool_release(aux_pw_pool_xpndd, error=error) + CALL pw_pool_release(pw_pool_xpndd) + CALL pw_pool_release(aux_pw_pool_xpndd) done_preparing = .TRUE. CALL mp_sum(done_preparing, pw_grid_orig%para%group) @@ -1302,7 +1283,7 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid ALLOCATE(R(n_tiles_tot+1, n_tiles_tot+1)) ALLOCATE(work_arr(n_tiles_tot+1), ipiv(n_tiles_tot+1)) - CALL setup_grid_axes(pw_grid_orig, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, error) + CALL setup_grid_axes(pw_grid_orig, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) ! set up B, B^t, (\Delta^-1)*B^t indx1 = 1 @@ -1314,37 +1295,37 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid IF (smooth) THEN DO i = 1, n_tiles tile_pw => ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw - CALL pw_pool_create_pw(pw_pool_orig, pw_in, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_mollifier(pw_pool_orig, zeta, x_glbl, y_glbl, z_glbl, tile_pw, pw_in, error) + CALL pw_pool_create_pw(pw_pool_orig, pw_in, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_mollifier(pw_pool_orig, zeta, x_glbl, y_glbl, z_glbl, tile_pw, pw_in) smooth_tile_npts = accurate_sum(pw_in%cr3d) CALL mp_sum(smooth_tile_npts, pw_grid_orig%para%group) - CALL pw_scale(pw_in, 1.0_dp / smooth_tile_npts, error) ! normalize tile_pw + CALL pw_scale(pw_in, 1.0_dp / smooth_tile_npts) ! normalize tile_pw ps_implicit_env%Bt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_in%cr3d, (/data_size/)) - CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL apply_inv_laplace_operator(pw_pool_orig, green, pw_in, pw_out, error) + CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE) + CALL apply_inv_laplace_operator(pw_pool_orig, green, pw_in, pw_out) QAinvxBt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_out%cr3d, (/data_size/)) ! the electrostatic potential has opposite sign by internal convention ps_implicit_env%v_D(indx1+i-1) = -1.0_dp * ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%v_D - CALL pw_pool_give_back_pw(pw_pool_orig, pw_out, error=error) - CALL pw_pool_give_back_pw(pw_pool_orig, pw_in, error=error) + CALL pw_pool_give_back_pw(pw_pool_orig, pw_out) + CALL pw_pool_give_back_pw(pw_pool_orig, pw_in) END DO ELSE DO i = 1, n_tiles pw_in => ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw tile_npts = ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%npts - CALL pw_scale(pw_in, 1.0_dp / tile_npts, error) ! normalize tile_pw + CALL pw_scale(pw_in, 1.0_dp / tile_npts) ! normalize tile_pw ps_implicit_env%Bt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_in%cr3d, (/data_size/)) - CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL apply_inv_laplace_operator(pw_pool_orig, green, pw_in, pw_out, error) + CALL pw_pool_create_pw(pw_pool_orig, pw_out, use_data=REALDATA3D, in_space=REALSPACE) + CALL apply_inv_laplace_operator(pw_pool_orig, green, pw_in, pw_out) QAinvxBt(ps_implicit_env%idx_1dto3d, indx1+i-1) = RESHAPE(pw_out%cr3d, (/data_size/)) ! the electrostatic potential has opposite sign by internal convention ps_implicit_env%v_D(indx1+i-1) = -1.0_dp * ps_implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%v_D - CALL pw_pool_give_back_pw(pw_pool_orig, pw_out, error=error) + CALL pw_pool_give_back_pw(pw_pool_orig, pw_out) END DO END IF indx1 = indx2 + 1 @@ -1372,10 +1353,10 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid CALL DGETRF(n_tiles_tot+1, n_tiles_tot+1, ps_implicit_env%Rinv, n_tiles_tot+1, ipiv, info) IF (info .NE. 0) CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & "R is (nearly) singular! Either two Dirichlet constraints are identical or "// & - "you need to reduce the number of tiles.", error) + "you need to reduce the number of tiles.") CALL DGETRI(n_tiles_tot+1, ps_implicit_env%Rinv, n_tiles_tot+1, ipiv, work_arr, n_tiles_tot+1, info) IF (info .NE. 0) CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & - "Inversion of R failed!", error) + "Inversion of R failed!") DEALLOCATE(QAinvxBt, Bxunit_vec, R, work_arr, ipiv) @@ -1404,7 +1385,7 @@ SUBROUTINE ps_implicit_prepare_blocks(pw_pool_orig, dct_pw_grid, dct_aux_pw_grid CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP, & "Please specify the type of boundary conditions using the "//& - "input file keyword BOUNDARY_CONDITIONS.", error) + "input file keyword BOUNDARY_CONDITIONS.") END SELECT CALL timestop(handle) @@ -1418,19 +1399,17 @@ END SUBROUTINE ps_implicit_prepare_blocks !> \param dielectric dielectric_type contaning eps !> \param v input matrix !> \param Pxv action of the operator P on v -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE apply_P_operator(pw_pool, dielectric, v, Pxv, error) + SUBROUTINE apply_P_operator(pw_pool, dielectric, v, Pxv) TYPE(pw_pool_type), POINTER :: pw_pool TYPE(dielectric_type), INTENT(IN), & POINTER :: dielectric TYPE(pw_type), INTENT(IN), POINTER :: v TYPE(pw_type), INTENT(INOUT), POINTER :: Pxv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_P_operator', & routineP = moduleN//':'//routineN @@ -1443,17 +1422,16 @@ SUBROUTINE apply_P_operator(pw_pool, dielectric, v, Pxv, error) dln_eps = dielectric%dln_eps DO i = 1, 3 CALL pw_pool_create_pw(pw_pool, dv(i)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) END DO - CALL derive_fft(v, dv, pw_pool, error) + CALL derive_fft(v, dv, pw_pool) Pxv%cr3d = - ( dv(1)%pw%cr3d * dln_eps(1)%pw%cr3d + & dv(2)%pw%cr3d * dln_eps(2)%pw%cr3d + & dv(3)%pw%cr3d * dln_eps(3)%pw%cr3d ) DO i = 1, 3 - CALL pw_pool_give_back_pw(pw_pool, dv(i)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, dv(i)%pw) END DO CALL timestop(handle) @@ -1466,19 +1444,17 @@ END SUBROUTINE apply_P_operator !> \param green green functions for FFT based inverse Laplacian !> \param pw_in pw_in (density) !> \param pw_out pw_out (potential) -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE apply_inv_laplace_operator_fft(pw_pool, green, pw_in, pw_out, error) + SUBROUTINE apply_inv_laplace_operator_fft(pw_pool, green, pw_in, pw_out) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(greens_fn_type), INTENT(IN), & POINTER :: green TYPE(pw_type), INTENT(IN), POINTER :: pw_in TYPE(pw_type), INTENT(INOUT), POINTER :: pw_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'apply_inv_laplace_operator_fft', & @@ -1498,16 +1474,15 @@ SUBROUTINE apply_inv_laplace_operator_fft(pw_pool, green, pw_in, pw_out, error) ng = SIZE(pw_grid%gsq) CALL pw_pool_create_pw(pw_pool, pw_in_gs, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) - CALL pw_transfer(pw_in, pw_in_gs, error=error) + CALL pw_transfer(pw_in, pw_in_gs) DO ig = 1, ng pw_in_gs%cc(ig) = prefactor * pw_in_gs%cc(ig) * green%influence_fn%cc(ig) END DO - CALL pw_transfer(pw_in_gs, pw_out, error=error) + CALL pw_transfer(pw_in_gs, pw_out) - CALL pw_pool_give_back_pw(pw_pool, pw_in_gs, error=error) + CALL pw_pool_give_back_pw(pw_pool, pw_in_gs) CALL timestop(handle) @@ -1530,7 +1505,6 @@ END SUBROUTINE apply_inv_laplace_operator_fft !> \param adjust_local_bounds whether or not to adjust local bounds !> \param pw_in input data !> \param pw_out output data -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian @@ -1538,7 +1512,7 @@ END SUBROUTINE apply_inv_laplace_operator_fft SUBROUTINE apply_inv_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, green, & recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, dests_shrink, & srcs_shrink, bounds_shftd, bounds_local_shftd, adjust_local_bounds, & - pw_in, pw_out, error) + pw_in, pw_out) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool_xpndd, & aux_pw_pool_xpndd @@ -1552,7 +1526,6 @@ SUBROUTINE apply_inv_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, gree LOGICAL, INTENT(in) :: adjust_local_bounds TYPE(pw_type), INTENT(IN), POINTER :: pw_in TYPE(pw_type), INTENT(INOUT), POINTER :: pw_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'apply_inv_laplace_operator_dct', & @@ -1576,62 +1549,54 @@ SUBROUTINE apply_inv_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, gree IF (adjust_local_bounds) THEN CALL pw_pool_create_pw(pw_pool_xpndd, pw_in_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(aux_pw_pool_xpndd, pw_in_xpndd_adj, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(aux_pw_pool_xpndd, pw_in_xpndd_gs, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(aux_pw_pool_xpndd, pw_out_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(pw_pool_xpndd, pw_out_xpndd_adj, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, bounds_shftd, & - pw_in, pw_in_xpndd, error) - CALL pw_adjust_bounds_local(pw_in_xpndd, pw_in_xpndd_adj, error) - CALL pw_transfer(pw_in_xpndd_adj, pw_in_xpndd_gs, debug=.FALSE., error=error) + pw_in, pw_in_xpndd) + CALL pw_adjust_bounds_local(pw_in_xpndd, pw_in_xpndd_adj) + CALL pw_transfer(pw_in_xpndd_adj, pw_in_xpndd_gs, debug=.FALSE.) DO ig = 1, ng_xpndd pw_in_xpndd_gs%cc(ig) = prefactor * pw_in_xpndd_gs%cc(ig) * green%dct_influence_fn%cc(ig) END DO - CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE., error=error) - CALL pw_adjust_bounds_local(pw_out_xpndd, pw_out_xpndd_adj, error) - CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd_adj, pw_out, error) + CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE.) + CALL pw_adjust_bounds_local(pw_out_xpndd, pw_out_xpndd_adj) + CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd_adj, pw_out) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd, error=error) - CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_adj, error=error) - CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_gs, error=error) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd_adj, error=error) - CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_out_xpndd, error=error) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd) + CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_adj) + CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_gs) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd_adj) + CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_out_xpndd) ELSE CALL pw_pool_create_pw(pw_pool_xpndd, pw_in_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(pw_pool_xpndd, pw_in_xpndd_gs, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(pw_pool_xpndd, pw_out_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, bounds_shftd, & - pw_in, pw_in_xpndd, error) - CALL pw_transfer(pw_in_xpndd, pw_in_xpndd_gs, debug=.FALSE., error=error) + pw_in, pw_in_xpndd) + CALL pw_transfer(pw_in_xpndd, pw_in_xpndd_gs, debug=.FALSE.) DO ig = 1, ng_xpndd pw_in_xpndd_gs%cc(ig) = prefactor * pw_in_xpndd_gs%cc(ig) * green%dct_influence_fn%cc(ig) END DO - CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE., error=error) - CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd, pw_out, error) + CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE.) + CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd, pw_out) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd, error=error) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd_gs, error=error) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd, error=error) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd_gs) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd) END IF @@ -1645,19 +1610,17 @@ END SUBROUTINE apply_inv_laplace_operator_dct !> \param green green functions for FFT based inverse Laplacian !> \param pw_in pw_in (potential) !> \param pw_out pw_out (density) -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE apply_laplace_operator_fft(pw_pool, green, pw_in, pw_out, error) + SUBROUTINE apply_laplace_operator_fft(pw_pool, green, pw_in, pw_out) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(greens_fn_type), INTENT(IN), & POINTER :: green TYPE(pw_type), INTENT(IN), POINTER :: pw_in TYPE(pw_type), INTENT(INOUT), POINTER :: pw_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_laplace_operator_fft', & routineP = moduleN//':'//routineN @@ -1678,10 +1641,9 @@ SUBROUTINE apply_laplace_operator_fft(pw_pool, green, pw_in, pw_out, error) have_g0 = green%influence_fn%pw_grid%have_g0 CALL pw_pool_create_pw(pw_pool, pw_in_gs, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) - CALL pw_transfer(pw_in, pw_in_gs, error=error) + CALL pw_transfer(pw_in, pw_in_gs) IF (have_g0) THEN g0_index = green%influence_fn%pw_grid%first_gne0 - 1 @@ -1691,9 +1653,9 @@ SUBROUTINE apply_laplace_operator_fft(pw_pool, green, pw_in, pw_out, error) pw_in_gs%cc(ig) = prefactor * (pw_in_gs%cc(ig) / green%influence_fn%cc(ig)) END DO - CALL pw_transfer(pw_in_gs, pw_out, error=error) + CALL pw_transfer(pw_in_gs, pw_out) - CALL pw_pool_give_back_pw(pw_pool, pw_in_gs, error=error) + CALL pw_pool_give_back_pw(pw_pool, pw_in_gs) CALL timestop(handle) @@ -1715,7 +1677,6 @@ END SUBROUTINE apply_laplace_operator_fft !> \param adjust_local_bounds whether or not to adjust local bounds !> \param pw_in input data !> \param pw_out output data -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian @@ -1723,7 +1684,7 @@ END SUBROUTINE apply_laplace_operator_fft SUBROUTINE apply_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, green, & recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, dests_shrink, & srcs_shrink, bounds_shftd, bounds_local_shftd, adjust_local_bounds, & - pw_in, pw_out, error) + pw_in, pw_out) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool_xpndd, & aux_pw_pool_xpndd @@ -1737,7 +1698,6 @@ SUBROUTINE apply_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, green, & LOGICAL, INTENT(IN) :: adjust_local_bounds TYPE(pw_type), INTENT(IN), POINTER :: pw_in TYPE(pw_type), INTENT(INOUT), POINTER :: pw_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_laplace_operator_dct', & routineP = moduleN//':'//routineN @@ -1762,25 +1722,20 @@ SUBROUTINE apply_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, green, & IF (adjust_local_bounds) THEN CALL pw_pool_create_pw(pw_pool_xpndd, pw_in_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(aux_pw_pool_xpndd, pw_in_xpndd_adj, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(aux_pw_pool_xpndd, pw_in_xpndd_gs, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(aux_pw_pool_xpndd, pw_out_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(pw_pool_xpndd, pw_out_xpndd_adj, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, bounds_shftd, & - pw_in, pw_in_xpndd, error) - CALL pw_adjust_bounds_local(pw_in_xpndd, pw_in_xpndd_adj, error) - CALL pw_transfer(pw_in_xpndd_adj, pw_in_xpndd_gs, debug=.FALSE., error=error) + pw_in, pw_in_xpndd) + CALL pw_adjust_bounds_local(pw_in_xpndd, pw_in_xpndd_adj) + CALL pw_transfer(pw_in_xpndd_adj, pw_in_xpndd_gs, debug=.FALSE.) IF (have_g0) THEN g0_index = green%dct_influence_fn%pw_grid%first_gne0 - 1 @@ -1790,31 +1745,28 @@ SUBROUTINE apply_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, green, & pw_in_xpndd_gs%cc(ig) = prefactor * (pw_in_xpndd_gs%cc(ig) / green%dct_influence_fn%cc(ig)) END DO - CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE., error=error) - CALL pw_adjust_bounds_local(pw_out_xpndd, pw_out_xpndd_adj, error) - CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd_adj, pw_out, error) + CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE.) + CALL pw_adjust_bounds_local(pw_out_xpndd, pw_out_xpndd_adj) + CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd_adj, pw_out) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd, error=error) - CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_adj, error=error) - CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_gs, error=error) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd_adj, error=error) - CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_out_xpndd, error=error) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd) + CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_adj) + CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_in_xpndd_gs) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd_adj) + CALL pw_pool_give_back_pw(aux_pw_pool_xpndd, pw_out_xpndd) ELSE CALL pw_pool_create_pw(pw_pool_xpndd, pw_in_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pool_create_pw(pw_pool_xpndd, pw_in_xpndd_gs, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(pw_pool_xpndd, pw_out_xpndd, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_expand(recv_msgs_bnds, dests_expand, srcs_expand, flipg_stat, bounds_shftd, & - pw_in, pw_in_xpndd, error) - CALL pw_transfer(pw_in_xpndd, pw_in_xpndd_gs, debug=.FALSE., error=error) + pw_in, pw_in_xpndd) + CALL pw_transfer(pw_in_xpndd, pw_in_xpndd_gs, debug=.FALSE.) IF (have_g0) THEN g0_index = green%dct_influence_fn%pw_grid%first_gne0 - 1 @@ -1824,12 +1776,12 @@ SUBROUTINE apply_laplace_operator_dct(pw_pool_xpndd, aux_pw_pool_xpndd, green, & pw_in_xpndd_gs%cc(ig) = prefactor * (pw_in_xpndd_gs%cc(ig) / green%dct_influence_fn%cc(ig)) END DO - CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE., error=error) - CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd, pw_out, error) + CALL pw_transfer(pw_in_xpndd_gs, pw_out_xpndd, debug=.FALSE.) + CALL pw_shrink(dests_shrink, srcs_shrink, bounds_local_shftd, pw_out_xpndd, pw_out) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd, error=error) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd_gs, error=error) - CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd, error=error) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_in_xpndd_gs) + CALL pw_pool_give_back_pw(pw_pool_xpndd, pw_out_xpndd) END IF @@ -1844,12 +1796,11 @@ END SUBROUTINE apply_laplace_operator_dct !> \param dielectric dielectric environment !> \param v potential !> \param density density -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE apply_poisson_operator_fft(pw_pool, green, dielectric, v, density, error) + SUBROUTINE apply_poisson_operator_fft(pw_pool, green, dielectric, v, density) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(greens_fn_type), INTENT(IN), & @@ -1858,7 +1809,6 @@ SUBROUTINE apply_poisson_operator_fft(pw_pool, green, dielectric, v, density, er POINTER :: dielectric TYPE(pw_type), INTENT(IN), POINTER :: v TYPE(pw_type), INTENT(INOUT), POINTER :: density - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_poisson_operator_fft', & routineP = moduleN//':'//routineN @@ -1869,14 +1819,13 @@ SUBROUTINE apply_poisson_operator_fft(pw_pool, green, dielectric, v, density, er CALL timeset(routineN,handle) CALL pw_pool_create_pw(pw_pool, Pxv, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) - CALL apply_P_operator(pw_pool, dielectric, v, Pxv, error=error) - CALL apply_laplace_operator(pw_pool, green, v, density, error=error) - CALL pw_axpy(Pxv, density, error=error) + CALL apply_P_operator(pw_pool, dielectric, v, Pxv) + CALL apply_laplace_operator(pw_pool, green, v, density) + CALL pw_axpy(Pxv, density) - CALL pw_pool_give_back_pw(pw_pool, Pxv, error=error) + CALL pw_pool_give_back_pw(pw_pool, Pxv) CALL timestop(handle) @@ -1894,13 +1843,12 @@ END SUBROUTINE apply_poisson_operator_fft !> \param adjust_local_bounds whether or not to adjust local bounds !> \param v potential !> \param density density -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE apply_poisson_operator_dct(pw_pool, green, dielectric, pw_pool_xpndd, aux_pw_pool_xpndd, & - dct_env, adjust_local_bounds, v, density, error) + dct_env, adjust_local_bounds, v, density) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(greens_fn_type), INTENT(IN), & @@ -1913,7 +1861,6 @@ SUBROUTINE apply_poisson_operator_dct(pw_pool, green, dielectric, pw_pool_xpndd, LOGICAL, INTENT(IN) :: adjust_local_bounds TYPE(pw_type), INTENT(IN), POINTER :: v TYPE(pw_type), INTENT(INOUT), POINTER :: density - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_poisson_operator_dct', & routineP = moduleN//':'//routineN @@ -1924,19 +1871,18 @@ SUBROUTINE apply_poisson_operator_dct(pw_pool, green, dielectric, pw_pool_xpndd, CALL timeset(routineN,handle) CALL pw_pool_create_pw(pw_pool, Pxv, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) - CALL apply_P_operator(pw_pool, dielectric, v, Pxv, error=error) + CALL apply_P_operator(pw_pool, dielectric, v, Pxv) CALL apply_laplace_operator(pw_pool_xpndd, aux_pw_pool_xpndd, green, & dct_env%recv_msgs_bnds, dct_env%dests_expand, & dct_env%srcs_expand, dct_env%flipg_stat, & dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_shftd, dct_env%bounds_local_shftd, & - adjust_local_bounds, v, density, error) - CALL pw_axpy(Pxv, density, error=error) + adjust_local_bounds, v, density) + CALL pw_axpy(Pxv, density) - CALL pw_pool_give_back_pw(pw_pool, Pxv, error=error) + CALL pw_pool_give_back_pw(pw_pool, Pxv) CALL timestop(handle) @@ -1952,19 +1898,17 @@ END SUBROUTINE apply_poisson_operator_dct !> \param dielectric dielectric environment !> \param v Hartree potential !> \param v_eps v_eps -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE ps_implicit_compute_veps(pw_pool, dielectric, v, v_eps, error) + SUBROUTINE ps_implicit_compute_veps(pw_pool, dielectric, v, v_eps) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(dielectric_type), INTENT(IN), & POINTER :: dielectric TYPE(pw_type), INTENT(IN), POINTER :: v TYPE(pw_type), INTENT(INOUT), POINTER :: v_eps - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ps_implicit_compute_veps', & routineP = moduleN//':'//routineN @@ -1980,24 +1924,22 @@ SUBROUTINE ps_implicit_compute_veps(pw_pool, dielectric, v, v_eps, error) deps_drho => dielectric%deps_drho CALL pw_pool_create_pw(pw_pool, dv2, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) DO i = 1, 3 CALL pw_pool_create_pw(pw_pool, dv(i)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) END DO - CALL derive_fft(v, dv, pw_pool, error) + CALL derive_fft(v, dv, pw_pool) ! evaluate |\nabla_r(v)|^2 dv2%cr3d = dv(1)%pw%cr3d ** 2 + dv(2)%pw%cr3d ** 2 + dv(3)%pw%cr3d ** 2 v_eps%cr3d = - (1.0_dp / eightpi) * (dv2%cr3d * deps_drho%cr3d) - CALL pw_pool_give_back_pw(pw_pool, dv2, error=error) + CALL pw_pool_give_back_pw(pw_pool, dv2) DO i = 1, 3 - CALL pw_pool_give_back_pw(pw_pool, dv(i)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, dv(i)%pw) END DO CALL timestop(handle) @@ -2009,16 +1951,14 @@ END SUBROUTINE ps_implicit_compute_veps !> \param density electronic density !> \param v Hartree potential !> \param ehartree Hartree energy -!> \param error cp2k error !> \par History !> 06.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE compute_ehartree_periodic_bc(density, v, ehartree, error) + SUBROUTINE compute_ehartree_periodic_bc(density, v, ehartree) TYPE(pw_type), INTENT(IN), POINTER :: density, v REAL(dp), INTENT(OUT) :: ehartree - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_ehartree_periodic_bc', & routineP = moduleN//':'//routineN @@ -2028,7 +1968,7 @@ SUBROUTINE compute_ehartree_periodic_bc(density, v, ehartree, error) CALL timeset(routineN,handle) ! E_H = \frac{1}{2} * \int \rho * v dr - ehartree = 0.5_dp * pw_integral_ab(density, v, error) + ehartree = 0.5_dp * pw_integral_ab(density, v) CALL timestop(handle) @@ -2042,12 +1982,11 @@ END SUBROUTINE compute_ehartree_periodic_bc !> and B^t is the transpose of the boundary operator !> \param v Hartree potential !> \param ehartree Hartree energy -!> \param error cp2k error !> \par History !> 06.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE compute_ehartree_mixed_bc(dielectric, density, Btxlambda, v, ehartree, error) + SUBROUTINE compute_ehartree_mixed_bc(dielectric, density, Btxlambda, v, ehartree) TYPE(dielectric_type), INTENT(IN), & POINTER :: dielectric @@ -2056,7 +1995,6 @@ SUBROUTINE compute_ehartree_mixed_bc(dielectric, density, Btxlambda, v, ehartree DIMENSION(:, :, :), INTENT(IN) :: Btxlambda TYPE(pw_type), INTENT(IN), POINTER :: v REAL(dp), INTENT(OUT) :: ehartree - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_ehartree_mixed_bc', & routineP = moduleN//':'//routineN @@ -2100,13 +2038,12 @@ END SUBROUTINE compute_ehartree_mixed_bc !> \param QAinvxres_new \Delta^-1(res_new) !> \param pres_error preconditioned residual norm error !> \param nabs_error normalized absolute error -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE compute_error_periodic_bc(pw_pool, green, res_new, v_old, v_new,& - QAinvxres_new, pres_error, nabs_error, error) + QAinvxres_new, pres_error, nabs_error) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(greens_fn_type), INTENT(IN), & @@ -2114,7 +2051,6 @@ SUBROUTINE compute_error_periodic_bc(pw_pool, green, res_new, v_old, v_new,& TYPE(pw_type), INTENT(IN), POINTER :: res_new, v_old, v_new TYPE(pw_type), INTENT(INOUT), POINTER :: QAinvxres_new REAL(dp), INTENT(OUT) :: pres_error, nabs_error - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_error_periodic_bc', & routineP = moduleN//':'//routineN @@ -2127,7 +2063,7 @@ SUBROUTINE compute_error_periodic_bc(pw_pool, green, res_new, v_old, v_new,& vol = pw_pool%pw_grid%vol ! evaluate \Delta^-1(res) = \Delta^-1 (g - \Delta(v_new) - P(v_new) + Bt \lambda) - CALL apply_inv_laplace_operator(pw_pool, green, res_new, QAinvxres_new, error) + CALL apply_inv_laplace_operator(pw_pool, green, res_new, QAinvxres_new) ! (normalized) preconditioned residual norm error : pres_error = accurate_sum(QAinvxres_new%cr3d(:,:,:)**2) CALL mp_sum(pres_error, pw_pool%pw_grid%para%group) @@ -2158,14 +2094,13 @@ END SUBROUTINE compute_error_periodic_bc !> \param adjust_local_bounds whether or not to adjust local bounds !> \param pres_error preconditioned residual norm error !> \param nabs_error normalized absolute error -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE compute_error_mixed_bc(pw_pool, green, pw_pool_xpndd, aux_pw_pool_xpndd, & dct_env, res_new, v_old, v_new, QAinvxres_new, & - adjust_local_bounds, pres_error, nabs_error, error) + adjust_local_bounds, pres_error, nabs_error) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool TYPE(greens_fn_type), INTENT(IN), & @@ -2177,7 +2112,6 @@ SUBROUTINE compute_error_mixed_bc(pw_pool, green, pw_pool_xpndd, aux_pw_pool_xpn TYPE(pw_type), INTENT(INOUT), POINTER :: QAinvxres_new LOGICAL, INTENT(in) :: adjust_local_bounds REAL(dp), INTENT(OUT) :: pres_error, nabs_error - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_error_mixed_bc', & routineP = moduleN//':'//routineN @@ -2195,7 +2129,7 @@ SUBROUTINE compute_error_mixed_bc(pw_pool, green, pw_pool_xpndd, aux_pw_pool_xpn dct_env%srcs_expand, dct_env%flipg_stat, & dct_env%dests_shrink, dct_env%srcs_shrink, & dct_env%bounds_shftd, dct_env%bounds_local_shftd, & - adjust_local_bounds, res_new, QAinvxres_new, error) + adjust_local_bounds, res_new, QAinvxres_new) ! (normalized) preconditioned residual norm error : pres_error = accurate_sum(QAinvxres_new%cr3d(:,:,:)**2) CALL mp_sum(pres_error, pw_pool%pw_grid%para%group) @@ -2217,17 +2151,15 @@ END SUBROUTINE compute_error_mixed_bc !> \param pres_error preconditioned residual norm error !> \param nabs_error normalized absolute error !> \param outp_unit output unit -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE ps_implicit_output(iter, pres_error, nabs_error, outp_unit, error) + SUBROUTINE ps_implicit_output(iter, pres_error, nabs_error, outp_unit) INTEGER, INTENT(IN) :: iter REAL(dp), INTENT(IN) :: pres_error, nabs_error INTEGER, INTENT(OUT) :: outp_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ps_implicit_output', & routineP = moduleN//':'//routineN @@ -2237,7 +2169,7 @@ SUBROUTINE ps_implicit_output(iter, pres_error, nabs_error, outp_unit, error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos .EQ. logger%para_env%source) THEN outp_unit = cp_logger_get_default_unit_nr(logger, local=.TRUE.) ELSE @@ -2268,17 +2200,15 @@ END SUBROUTINE ps_implicit_output !> \param ps_implicit_env the implicit poisson solver environment !> \param outp_unit output unit !> \param ehartree Hartree energy -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree, error) + SUBROUTINE ps_implicit_report_ehartree(ps_implicit_env, outp_unit, ehartree) TYPE(ps_implicit_type) :: ps_implicit_env INTEGER, INTENT(IN) :: outp_unit REAL(dp), INTENT(IN) :: ehartree - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ps_implicit_report_ehartree', & routineP = moduleN//':'//routineN @@ -2297,15 +2227,13 @@ END SUBROUTINE ps_implicit_report_ehartree !> \param f input funcition !> \param df derivative of f !> \param pw_pool pool of plane-wave grid -!> \param error cp2k error ! ***************************************************************************** - SUBROUTINE derive_fft(f, df, pw_pool, error) + SUBROUTINE derive_fft(f, df, pw_pool) TYPE(pw_type), POINTER :: f TYPE(pw_p_type), DIMENSION(3), & INTENT(INOUT) :: df TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'derive_fft', & routineP = moduleN//':'//routineN @@ -2319,21 +2247,20 @@ SUBROUTINE derive_fft(f, df, pw_pool, error) DO i = 1, 2 NULLIFY (work_gs(i)%pw) CALL pw_pool_create_pw(pw_pool, work_gs(i)%pw, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) END DO - CALL pw_transfer(f, work_gs(1)%pw, error=error) + CALL pw_transfer(f, work_gs(1)%pw) DO i = 1, 3 nd(:) = 0 nd(i) = 1 - CALL pw_copy(work_gs(1)%pw, work_gs(2)%pw, error=error) - CALL pw_derive(work_gs(2)%pw, nd(:), error=error) - CALL pw_transfer(work_gs(2)%pw, df(i)%pw, error=error) + CALL pw_copy(work_gs(1)%pw, work_gs(2)%pw) + CALL pw_derive(work_gs(2)%pw, nd(:)) + CALL pw_transfer(work_gs(2)%pw, df(i)%pw) END DO DO i = 1, 2 - CALL pw_pool_give_back_pw(pw_pool, work_gs(i)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, work_gs(i)%pw) END DO CALL timestop(handle) @@ -2345,9 +2272,8 @@ END SUBROUTINE derive_fft !> \param idx_1dto3d mapping of indices !> \param arr1d input 1D array !> \param arr3d input 3D array -!> \param error cp2k error ! ***************************************************************************** - SUBROUTINE convert_1dto3d(idx_1dto3d, arr1d, arr3d, error) + SUBROUTINE convert_1dto3d(idx_1dto3d, arr1d, arr3d) INTEGER, DIMENSION(:), INTENT(IN), & POINTER :: idx_1dto3d @@ -2355,7 +2281,6 @@ SUBROUTINE convert_1dto3d(idx_1dto3d, arr1d, arr3d, error) INTENT(IN) :: arr1d REAL(dp), ALLOCATABLE, & DIMENSION(:, :, :), INTENT(INOUT) :: arr3d - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_1dto3d', & routineP = moduleN//':'//routineN diff --git a/src/pw/ps_implicit_types.F b/src/pw/ps_implicit_types.F index 7d1a1e8e42..8a63ea7f75 100644 --- a/src/pw/ps_implicit_types.F +++ b/src/pw/ps_implicit_types.F @@ -75,17 +75,14 @@ MODULE ps_implicit_types !> \brief Deallocates ps_implicit !> \param implicit_env the implicit_env to be deallocated !> \param pw_pool pool of plane-wave grid -!> \param error cp2k error -!> !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE ps_implicit_release(implicit_env, pw_pool, error) + SUBROUTINE ps_implicit_release(implicit_env, pw_pool) TYPE(ps_implicit_type), POINTER :: implicit_env TYPE(pw_pool_type), INTENT(IN), & OPTIONAL, POINTER :: pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ps_implicit_release', & routineP = moduleN//':'//routineN @@ -100,18 +97,18 @@ SUBROUTINE ps_implicit_release(implicit_env, pw_pool, error) IF (can_give_back) can_give_back = ASSOCIATED(pw_pool) IF (can_give_back) THEN CALL pw_pool_give_back_pw(pw_pool, implicit_env%initial_guess, & - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_pw(pw_pool, implicit_env%v_eps, & - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_pw(pw_pool, implicit_env%cstr_charge, & - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) CALL dirichlet_boundary_region_release(implicit_env%gates, & - pw_pool=pw_pool, error=error) + pw_pool=pw_pool) ELSE - CALL pw_release(implicit_env%initial_guess, error=error) - CALL pw_release(implicit_env%v_eps, error=error) - CALL pw_release(implicit_env%cstr_charge, error=error) - CALL dirichlet_boundary_region_release(implicit_env%gates, error=error) + CALL pw_release(implicit_env%initial_guess) + CALL pw_release(implicit_env%v_eps) + CALL pw_release(implicit_env%cstr_charge) + CALL dirichlet_boundary_region_release(implicit_env%gates) END IF DEALLOCATE(implicit_env%initial_lambda) @@ -122,7 +119,7 @@ SUBROUTINE ps_implicit_release(implicit_env, pw_pool, error) DEALLOCATE(implicit_env%v_D) DEALLOCATE(implicit_env%idx_1dto3d) - CALL dielectric_release(implicit_env%dielectric,pw_pool,error) + CALL dielectric_release(implicit_env%dielectric,pw_pool) DEALLOCATE(implicit_env) END IF diff --git a/src/pw/ps_wavelet_base.F b/src/pw/ps_wavelet_base.F index d5e1e77acb..a1ab3abfad 100644 --- a/src/pw/ps_wavelet_base.F +++ b/src/pw/ps_wavelet_base.F @@ -44,7 +44,7 @@ MODULE ps_wavelet_base !> \param zf& ... ! ***************************************************************************** SUBROUTINE P_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,zf& - ,scal,hx,hy,hz,mpi_group,error) + ,scal,hx,hy,hz,mpi_group) INTEGER, INTENT(in) :: n1, n2, n3, nd1, nd2, nd3, & md1, md2, md3, nproc, iproc REAL(KIND=dp), & @@ -52,7 +52,6 @@ SUBROUTINE P_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,zf& INTENT(inout) :: zf REAL(KIND=dp), INTENT(in) :: scal, hx, hy, hz INTEGER, INTENT(in) :: mpi_group - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, PARAMETER :: ncache_optimal = 8*1024 @@ -877,7 +876,6 @@ END SUBROUTINE multkernel !> \param scal factor of renormalization of the FFT in order to acheve unitarity !> and the correct dimension !> \param mpi_group ... -!> \param error ... !> \date October 2006 !> \author S. Goedecker, L. Genovese !> \note As transform lengths most products of the prime factors 2,3,5 are allowed. @@ -892,7 +890,7 @@ END SUBROUTINE multkernel !> GNU General Public License, see http://www.gnu.org/copyleft/gpl.txt . ! ***************************************************************************** SUBROUTINE S_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,pot,zf,& - scal,mpi_group,error) + scal,mpi_group) INTEGER, INTENT(in) :: n1, n2, n3, nd1, nd2, nd3, & md1, md2, md3, nproc, iproc REAL(KIND=dp), & @@ -903,7 +901,6 @@ SUBROUTINE S_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,pot,zf,& INTENT(inout) :: zf REAL(KIND=dp), INTENT(in) :: scal INTEGER, INTENT(in) :: mpi_group - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'S_PoissonSolver', & routineP = moduleN//':'//routineN @@ -1684,7 +1681,6 @@ END SUBROUTINE unscramble_pack !> \param scal factor of renormalization of the FFT in order to acheve unitarity !> and the correct dimension !> \param mpi_group ... -!> \param error ... !> \date February 2006 !> \author S. Goedecker, L. Genovese !> \note As transform lengths @@ -1700,7 +1696,7 @@ END SUBROUTINE unscramble_pack !> GNU General Public License, see http://www.gnu.org/copyleft/gpl.txt . ! ***************************************************************************** SUBROUTINE F_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,pot,zf,& - scal,mpi_group,error) + scal,mpi_group) INTEGER, INTENT(in) :: n1, n2, n3, nd1, nd2, nd3, & md1, md2, md3, nproc, iproc REAL(KIND=dp), & @@ -1711,7 +1707,6 @@ SUBROUTINE F_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,pot,zf,& INTENT(inout) :: zf REAL(KIND=dp), INTENT(in) :: scal INTEGER, INTENT(in) :: mpi_group - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER, PARAMETER :: ncache_optimal = 8*1024 diff --git a/src/pw/ps_wavelet_kernel.F b/src/pw/ps_wavelet_kernel.F index 5b340da758..2b871bf571 100644 --- a/src/pw/ps_wavelet_kernel.F +++ b/src/pw/ps_wavelet_kernel.F @@ -67,7 +67,6 @@ MODULE ps_wavelet_kernel !> kernel is injective. This will divide by two each direction, !> since the kernel for the zero-padded convolution is real and symmetric. !> \param mpi_group ... -!> \param error ... !> \date February 2007 !> \author Luigi Genovese !> \note Due to the fact that the kernel dimensions are unknown before the calling, the kernel @@ -76,7 +75,7 @@ MODULE ps_wavelet_kernel !> the nd1,nd2,nd3 arguments to the PS_dim4allocation routine, then eliminating the pointer !> declaration. ! ***************************************************************************** - SUBROUTINE createKernel(geocode,n01,n02,n03,hx,hy,hz,itype_scf,iproc,nproc,kernel,mpi_group,error) + SUBROUTINE createKernel(geocode,n01,n02,n03,hx,hy,hz,itype_scf,iproc,nproc,kernel,mpi_group) CHARACTER(len=1), INTENT(in) :: geocode INTEGER, INTENT(in) :: n01, n02, n03 @@ -84,7 +83,6 @@ SUBROUTINE createKernel(geocode,n01,n02,n03,hx,hy,hz,itype_scf,iproc,nproc,kerne INTEGER, INTENT(in) :: itype_scf, iproc, nproc REAL(KIND=dp), POINTER :: kernel(:) INTEGER, INTENT(in) :: mpi_group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'createKernel', & routineP = moduleN//':'//routineN @@ -103,7 +101,7 @@ SUBROUTINE createKernel(geocode,n01,n02,n03,hx,hy,hz,itype_scf,iproc,nproc,kerne md1,md2,md3,nd1,nd2,nd3,nproc) ALLOCATE(kernel(1),stat=i_all) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) nlimd=n2 nlimk=0 @@ -113,12 +111,12 @@ SUBROUTINE createKernel(geocode,n01,n02,n03,hx,hy,hz,itype_scf,iproc,nproc,kerne md1,md2,md3,nd1,nd2,nd3,nproc) ALLOCATE(kernel(nd1*nd2*nd3/nproc),stat=i_all) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !the kernel must be built and scattered to all the processes CALL Surfaces_Kernel(n1,n2,n3,m3,nd1,nd2,nd3,hx,hz,hy,& - itype_scf,kernel,iproc,nproc,mpi_group,error) + itype_scf,kernel,iproc,nproc,mpi_group) !last plane calculated for the density and the kernel nlimd=n2 @@ -131,10 +129,10 @@ SUBROUTINE createKernel(geocode,n01,n02,n03,hx,hy,hz,itype_scf,iproc,nproc,kerne md1,md2,md3,nd1,nd2,nd3,nproc) ALLOCATE(kernel(nd1*nd2*nd3/nproc),stat=i_all) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !the kernel must be built and scattered to all the processes CALL Free_Kernel(n01,n02,n03,n1,n2,n3,nd1,nd2,nd3,hgrid,& - itype_scf,iproc,nproc,kernel,mpi_group,error) + itype_scf,iproc,nproc,kernel,mpi_group) !last plane calculated for the density and the kernel nlimd=n2/2 @@ -144,7 +142,7 @@ SUBROUTINE createKernel(geocode,n01,n02,n03,hx,hy,hz,itype_scf,iproc,nproc,kerne CALL cp_assert(.FALSE.,cp_assertion_failed,& cp_failure_level,routineP,& - "No wavelet based poisson solver for given geometry",error,failure) + "No wavelet based poisson solver for given geometry",failure) END IF !!! IF (iproc==0) THEN @@ -224,12 +222,11 @@ END SUBROUTINE createKernel !> \param iproc Number of process !> \param nproc number of processes !> \param mpi_group ... -!> \param error ... !> \date October 2006 !> \author L. Genovese ! ***************************************************************************** SUBROUTINE Surfaces_Kernel(n1,n2,n3,m3,nker1,nker2,nker3,h1,h2,h3,& - itype_scf,karray,iproc,nproc,mpi_group,error) + itype_scf,karray,iproc,nproc,mpi_group) INTEGER, INTENT(in) :: n1, n2, n3, m3, nker1, nker2, & nker3 @@ -239,7 +236,6 @@ SUBROUTINE Surfaces_Kernel(n1,n2,n3,m3,nker1,nker2,nker3,h1,h2,h3,& DIMENSION(nker1, nker2, nker3/nproc), & INTENT(out) :: karray INTEGER, INTENT(in) :: mpi_group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'Surfaces_Kernel', & routineP = moduleN//':'//routineN @@ -343,7 +339,7 @@ SUBROUTINE Surfaces_Kernel(n1,n2,n3,m3,nker1,nker2,nker3,h1,h2,h3,& i_all = i_all + i_stat ALLOCATE(y_scf(0:n_scf),stat=i_stat) i_all = i_all + i_stat - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !Build the scaling function CALL scaling_function(itype_scf,n_scf,n_range,x_scf,y_scf) @@ -389,7 +385,7 @@ SUBROUTINE Surfaces_Kernel(n1,n2,n3,m3,nker1,nker2,nker3,h1,h2,h3,& ALLOCATE(before(7),stat=i_stat) i_all = i_all + i_stat - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !constants pi=4._dp*ATAN(1._dp) @@ -435,7 +431,7 @@ SUBROUTINE Surfaces_Kernel(n1,n2,n3,m3,nker1,nker2,nker3,h1,h2,h3,& shift=1 CALL calculates_green_opt_muzero(n_range,n_scf,ipolyord,x_scf,y_scf,& - cpol(1,ipolyord),dx,kernel_scf,error) + cpol(1,ipolyord),dx,kernel_scf) !copy of the first zero value halfft_cache(1,1,1)=0._dp @@ -471,7 +467,7 @@ SUBROUTINE Surfaces_Kernel(n1,n2,n3,m3,nker1,nker2,nker3,h1,h2,h3,& mu1=2._dp*pi*SQRT((ponx/h1)**2+(pony/h2)**2)*h3 CALL calculates_green_opt(n_range,n_scf,itype_scf,ipolyord,x_scf,y_scf,& - cpol(1,ipolyord),mu1,dx,kernel_scf,error) + cpol(1,ipolyord),mu1,dx,kernel_scf) !readjust the coefficient and define the final kernel @@ -578,7 +574,7 @@ SUBROUTINE Surfaces_Kernel(n1,n2,n3,m3,nker1,nker2,nker3,h1,h2,h3,& i_all=i_all+i_stat DEALLOCATE(y_scf,stat=i_stat) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) END SUBROUTINE Surfaces_Kernel @@ -594,9 +590,8 @@ END SUBROUTINE Surfaces_Kernel !> \param mu ... !> \param hres ... !> \param g_mu ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE calculates_green_opt(n,n_scf,itype_scf,intorder,xval,yval,c,mu,hres,g_mu,error) +SUBROUTINE calculates_green_opt(n,n_scf,itype_scf,intorder,xval,yval,c,mu,hres,g_mu) INTEGER, INTENT(in) :: n, n_scf, itype_scf, intorder REAL(KIND=dp), DIMENSION(0:n_scf), & INTENT(in) :: xval, yval @@ -604,7 +599,6 @@ SUBROUTINE calculates_green_opt(n,n_scf,itype_scf,intorder,xval,yval,c,mu,hres,g INTENT(in) :: c REAL(KIND=dp), INTENT(in) :: mu, hres REAL(KIND=dp), DIMENSION(n), INTENT(out) :: g_mu - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculates_green_opt', & routineP = moduleN//':'//routineN @@ -640,7 +634,7 @@ SUBROUTINE calculates_green_opt(n,n_scf,itype_scf,intorder,xval,yval,c,mu,hres,g nrec=2**n_iter*n ALLOCATE(green(-nrec:nrec),stat=i_all) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !initialization of the branching value ikern=0 @@ -720,7 +714,7 @@ SUBROUTINE calculates_green_opt(n,n_scf,itype_scf,intorder,xval,yval,c,mu,hres,g END DO !now we must calculate the recursion ALLOCATE(green1(-nrec:nrec),stat=i_all) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !Start the iteration to go from mu0 to mu CALL scf_recursion(itype_scf,n_iter,nrec,green(-nrec),green1(-nrec)) @@ -734,7 +728,7 @@ SUBROUTINE calculates_green_opt(n,n_scf,itype_scf,intorder,xval,yval,c,mu,hres,g DEALLOCATE(green,stat=i_all) DEALLOCATE(green1,stat=i_stat) - CPPostcondition(i_stat+i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_stat+i_all==0,cp_failure_level,routineP,failure) END SUBROUTINE calculates_green_opt @@ -748,9 +742,8 @@ END SUBROUTINE calculates_green_opt !> \param c ... !> \param hres ... !> \param green ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE calculates_green_opt_muzero(n,n_scf,intorder,xval,yval,c,hres,green,error) +SUBROUTINE calculates_green_opt_muzero(n,n_scf,intorder,xval,yval,c,hres,green) INTEGER, INTENT(in) :: n, n_scf, intorder REAL(KIND=dp), DIMENSION(0:n_scf), & INTENT(in) :: xval, yval @@ -758,7 +751,6 @@ SUBROUTINE calculates_green_opt_muzero(n,n_scf,intorder,xval,yval,c,hres,green,e INTENT(in) :: c REAL(KIND=dp), INTENT(in) :: hres REAL(KIND=dp), DIMENSION(n), INTENT(out) :: green - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, iend, ikern, ivalue, izero REAL(KIND=dp) :: c0, c1, filter, gl0, gl1, & @@ -895,12 +887,11 @@ END SUBROUTINE indices !> \param nproc ... !> \param karray ... !> \param mpi_group ... -!> \param error ... !> \date February 2006 !> \author T. Deutsch, L. Genovese ! ***************************************************************************** SUBROUTINE Free_Kernel(n01,n02,n03,nfft1,nfft2,nfft3,n1k,n2k,n3k,& - hgrid,itype_scf,iproc,nproc,karray,mpi_group,error) + hgrid,itype_scf,iproc,nproc,karray,mpi_group) INTEGER, INTENT(in) :: n01, n02, n03, nfft1, nfft2, & nfft3, n1k, n2k, n3k @@ -910,7 +901,6 @@ SUBROUTINE Free_Kernel(n01,n02,n03,nfft1,nfft2,nfft3,n1k,n2k,n3k,& DIMENSION(n1k, n2k, n3k/nproc), & INTENT(out) :: karray INTEGER, INTENT(in) :: mpi_group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'Free_Kernel', & routineP = moduleN//':'//routineN @@ -963,7 +953,7 @@ SUBROUTINE Free_Kernel(n01,n02,n03,nfft1,nfft2,nfft3,n1k,n2k,n3k,& !this will be the array of the kernel in the real space ALLOCATE(kp(n1h+1,n3h+1,nker2/nproc),stat=i_all) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !defining proper extremes for the calculation of the !local part of the kernel @@ -980,7 +970,7 @@ SUBROUTINE Free_Kernel(n01,n02,n03,nfft1,nfft2,nfft3,n1k,n2k,n3k,& i_all = i_all + i_stat ALLOCATE(y_scf(0:n_scf),stat=i_stat) i_all = i_all + i_stat - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !Build the scaling function CALL scaling_function(itype_scf,n_scf,n_range,x_scf,y_scf) @@ -995,7 +985,7 @@ SUBROUTINE Free_Kernel(n01,n02,n03,nfft1,nfft2,nfft3,n1k,n2k,n3k,& i_all = i_all + i_stat ALLOCATE(kern_1_scf(-n_range:n_range),stat=i_stat) i_all = i_all + i_stat - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) !Lengthes of the box (use FFT dimension) a1 = hgrid * REAL(n01,KIND=dp) @@ -1083,18 +1073,18 @@ SUBROUTINE Free_Kernel(n01,n02,n03,nfft1,nfft2,nfft3,n1k,n2k,n3k,& DEALLOCATE(x_scf,stat=i_stat) i_all=i_all+i_stat DEALLOCATE(y_scf,stat=i_stat) - CPPostcondition(i_all+i_stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all+i_stat==0,cp_failure_level,routineP,failure) !!!!END KERNEL CONSTRUCTION !!$ if(iproc .eq. 0) print *,"Do a 3D PHalFFT for the kernel" CALL kernelfft(nfft1,nfft2,nfft3,nker1,nker2,nker3,n1k,n2k,n3k,nproc,iproc,& - kp,karray,mpi_group,error) + kp,karray,mpi_group) !De-allocations DEALLOCATE(kp,stat=i_all) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) END SUBROUTINE Free_Kernel @@ -1151,7 +1141,6 @@ END SUBROUTINE inserthalf !> \param zr Distributed Kernel FFT !> zr(2,i1,i2,i3) !> \param mpi_group ... -!> \param error ... !> \date February 2006 !> \par Restrictions !> Copyright (C) Stefan Goedecker, Cornell University, Ithaca, USA, 1994 @@ -1165,7 +1154,7 @@ END SUBROUTINE inserthalf !> The detailed table with allowed transform lengths can !> be found in subroutine CTRIG ! ***************************************************************************** -SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_group,error) +SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_group) INTEGER, INTENT(in) :: n1, n2, n3, nd1, nd2, nd3, & nk1, nk2, nk3, nproc, iproc @@ -1176,7 +1165,6 @@ SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_grou DIMENSION(nk1, nk2, nk3/nproc), & INTENT(inout) :: zr INTEGER, INTENT(in) :: mpi_group - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kernelfft', & routineP = moduleN//':'//routineN @@ -1208,11 +1196,11 @@ SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_grou !Body !check input - CPPrecondition (nd1.GE.n1,cp_failure_level,routineP,error,failure) - CPPrecondition (nd2.GE.n2 ,cp_failure_level,routineP,error,failure) - CPPrecondition (nd3.GE.n3/2+1 ,cp_failure_level,routineP,error,failure) - CPPrecondition (MOD(nd3,nproc).EQ.0 ,cp_failure_level,routineP,error,failure) - CPPrecondition (MOD(nd2,nproc).EQ.0 ,cp_failure_level,routineP,error,failure) + CPPrecondition (nd1.GE.n1,cp_failure_level,routineP,failure) + CPPrecondition (nd2.GE.n2 ,cp_failure_level,routineP,failure) + CPPrecondition (nd3.GE.n3/2+1 ,cp_failure_level,routineP,failure) + CPPrecondition (MOD(nd3,nproc).EQ.0 ,cp_failure_level,routineP,failure) + CPPrecondition (MOD(nd2,nproc).EQ.0 ,cp_failure_level,routineP,failure) !defining work arrays dimensions ncache=ncache_optimal @@ -1257,7 +1245,7 @@ SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_grou ALLOCATE(zmpi1(2,n1,nd2/nproc,nd3/nproc,nproc),stat=i_stat) zmpi1 = 0.0_dp END IF - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) zmpi2 = 0.0_dp !calculating the FFT work arrays (beware on the HalFFT in n3 dimension) @@ -1275,7 +1263,7 @@ SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_grou !transform along z axis lot=ncache/(2*n3) - CPPostcondition(lot.GE.1,cp_failure_level,routineP,error,failure) + CPPostcondition(lot.GE.1,cp_failure_level,routineP,failure) DO j2=1,nd2/nproc !this condition ensures that we manage only the interesting part for the FFT @@ -1326,7 +1314,7 @@ SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_grou !transform along x axis lot=ncache/(4*n1) - CPPostcondition(lot.GE.1,cp_failure_level,routineP,error,failure) + CPPostcondition(lot.GE.1,cp_failure_level,routineP,failure) DO j=1,n2,lot ma=j @@ -1359,7 +1347,7 @@ SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_grou !transform along y axis, and taking only the first half lot=ncache/(4*n2) - CPPostcondition(lot.GE.1,cp_failure_level,routineP,error,failure) + CPPostcondition(lot.GE.1,cp_failure_level,routineP,failure) DO j=1,nk1,lot ma=j @@ -1420,7 +1408,7 @@ SUBROUTINE kernelfft(n1,n2,n3,nd1,nd2,nd3,nk1,nk2,nk3,nproc,iproc,zf,zr,mpi_grou DEALLOCATE(cosinarr,stat=i_stat) i_all=i_all+i_stat IF (nproc.GT.1) DEALLOCATE(zmpi1,stat=i_stat) - CPPostcondition(i_all==0,cp_failure_level,routineP,error,failure) + CPPostcondition(i_all==0,cp_failure_level,routineP,failure) END SUBROUTINE kernelfft diff --git a/src/pw/ps_wavelet_methods.F b/src/pw/ps_wavelet_methods.F index 20e027a38e..de959cdff7 100644 --- a/src/pw/ps_wavelet_methods.F +++ b/src/pw/ps_wavelet_methods.F @@ -52,16 +52,13 @@ MODULE ps_wavelet_methods !> \param poisson_params ... !> \param wavelet wavelet to create !> \param pw_grid the grid that is used to create the wavelet kernel -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Flroian Schiffmann ! ***************************************************************************** - SUBROUTINE ps_wavelet_create(poisson_params,wavelet,pw_grid, error) + SUBROUTINE ps_wavelet_create(poisson_params,wavelet,pw_grid) TYPE(pw_poisson_parameter_type), & INTENT(IN) :: poisson_params TYPE(ps_wavelet_type), POINTER :: wavelet TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ps_wavelet_create', & routineP = moduleN//':'//routineN @@ -79,7 +76,7 @@ SUBROUTINE ps_wavelet_create(poisson_params,wavelet,pw_grid, error) failure=.FALSE. ALLOCATE(wavelet, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nx = pw_grid % npts ( 1 ) ny = pw_grid % npts ( 2 ) @@ -105,14 +102,14 @@ SUBROUTINE ps_wavelet_create(poisson_params,wavelet,pw_grid, error) IF (hx.NE.hy) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Poisson solver for non cubic cells not yet implemented",& - error=error,failure=failure) + failure=failure) IF(hz.NE.hy) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Poisson solver for non cubic cells not yet implemented",& - error=error,failure=failure) + failure=failure) END IF - CALL RS_z_slice_distribution(wavelet,pw_grid, error) + CALL RS_z_slice_distribution(wavelet,pw_grid) CALL timestop(handle) END SUBROUTINE ps_wavelet_create @@ -121,13 +118,11 @@ END SUBROUTINE ps_wavelet_create !> \brief ... !> \param wavelet ... !> \param pw_grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE RS_z_slice_distribution(wavelet,pw_grid, error) + SUBROUTINE RS_z_slice_distribution(wavelet,pw_grid) TYPE(ps_wavelet_type), POINTER :: wavelet TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'RS_z_slice_distribution', & routineP = moduleN//':'//routineN @@ -169,10 +164,10 @@ SUBROUTINE RS_z_slice_distribution(wavelet,pw_grid, error) z_dim=md2/nproc !!!!!!!!! indicies y and z are interchanged !!!!!!! ALLOCATE(wavelet%rho_z_sliced(md1,md3,z_dim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL createKernel(geocode,nx,ny,nz,hx,hy,hz,wavelet%itype_scf,iproc,nproc,wavelet%karray,& - pw_grid % para % rs_group ,error) + pw_grid % para % rs_group) CALL timestop(handle) END SUBROUTINE RS_z_slice_distribution @@ -182,14 +177,12 @@ END SUBROUTINE RS_z_slice_distribution !> \param density ... !> \param wavelet ... !> \param pw_grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cp2k_distribution_to_z_slices (density , wavelet, pw_grid, error) + SUBROUTINE cp2k_distribution_to_z_slices (density , wavelet, pw_grid) TYPE(pw_type), POINTER :: density TYPE(ps_wavelet_type), POINTER :: wavelet TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp2k_distribution_to_z_slices', & @@ -209,7 +202,7 @@ SUBROUTINE cp2k_distribution_to_z_slices (density , wavelet, pw_grid, error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(wavelet),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wavelet),cp_failure_level,routineP,failure) nproc=PRODUCT(pw_grid % para % rs_dims) iproc=pw_grid % para % rs_mpo @@ -363,14 +356,12 @@ END SUBROUTINE cp2k_distribution_to_z_slices !> \param density ... !> \param wavelet ... !> \param pw_grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE z_slices_to_cp2k_distribution(density , wavelet, pw_grid, error) + SUBROUTINE z_slices_to_cp2k_distribution(density , wavelet, pw_grid) TYPE(pw_type), POINTER :: density TYPE(ps_wavelet_type), POINTER :: wavelet TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'z_slices_to_cp2k_distribution', & @@ -388,7 +379,7 @@ SUBROUTINE z_slices_to_cp2k_distribution(density , wavelet, pw_grid, error) REAL(KIND=dp), DIMENSION(:), POINTER :: rbuf, sbuf failure=.FALSE. - CPPrecondition(ASSOCIATED(wavelet),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wavelet),cp_failure_level,routineP,failure) nproc=PRODUCT(pw_grid % para % rs_dims) iproc=pw_grid % para % rs_mpo @@ -499,13 +490,11 @@ END SUBROUTINE z_slices_to_cp2k_distribution !> \brief ... !> \param wavelet ... !> \param pw_grid ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ps_wavelet_solve(wavelet,pw_grid,error) + SUBROUTINE ps_wavelet_solve(wavelet,pw_grid) TYPE(ps_wavelet_type), POINTER :: wavelet TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ps_wavelet_solve', & routineP = moduleN//':'//routineN @@ -527,7 +516,7 @@ SUBROUTINE ps_wavelet_solve(wavelet,pw_grid,error) hz = pw_grid % dr ( 3 ) CALL PSolver(geocode,iproc,nproc,nx,ny,nz,hx,hy,hz,& - wavelet%rho_z_sliced,wavelet%karray,pw_grid,error) + wavelet%rho_z_sliced,wavelet%karray,pw_grid) CALL timestop(handle) END SUBROUTINE ps_wavelet_solve diff --git a/src/pw/ps_wavelet_types.F b/src/pw/ps_wavelet_types.F index 0173961c12..9bc660cab5 100644 --- a/src/pw/ps_wavelet_types.F +++ b/src/pw/ps_wavelet_types.F @@ -47,12 +47,10 @@ MODULE ps_wavelet_types ! ***************************************************************************** !> \brief ... !> \param wavelet ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ps_wavelet_release(wavelet,error) + SUBROUTINE ps_wavelet_release(wavelet) TYPE(ps_wavelet_type), POINTER :: wavelet - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ps_wavelet_release', & routineP = moduleN//':'//routineN diff --git a/src/pw/ps_wavelet_util.F b/src/pw/ps_wavelet_util.F index 6e92f2731b..383c86cdf3 100644 --- a/src/pw/ps_wavelet_util.F +++ b/src/pw/ps_wavelet_util.F @@ -73,7 +73,6 @@ MODULE ps_wavelet_util !> dimensions that are related to the output of the PS_dim4allocation routine !> it MUST be created by following the same geocode as the Poisson Solver. !> \param pw_grid ... -!> \param error ... !> \date February 2007 !> \author Luigi Genovese !> \note The dimensions of the arrays must be compatible with geocode, nproc, @@ -81,7 +80,7 @@ MODULE ps_wavelet_util !> is IMPERATIVE to use the PS_dim4allocation routine for calculation arrays sizes. ! ***************************************************************************** SUBROUTINE PSolver(geocode,iproc,nproc,n01,n02,n03,hx,hy,hz,& - rhopot,karray,pw_grid,error) + rhopot,karray,pw_grid) CHARACTER(len=1), INTENT(in) :: geocode INTEGER, INTENT(in) :: iproc, nproc, n01, n02, n03 REAL(KIND=dp), INTENT(in) :: hx, hy, hz @@ -89,7 +88,6 @@ SUBROUTINE PSolver(geocode,iproc,nproc,n01,n02,n03,hx,hy,hz,& INTENT(inout) :: rhopot REAL(KIND=dp), DIMENSION(*), INTENT(in) :: karray TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i1, i2, i3, i_all, i_stat, iend, istart, j2, m1, m2, m3, md1, & md2, md3, n1, n2, n3, nd1, nd2, nd3, nlim, nwb, nwbl, nwbr, nxc, nxcl, & @@ -177,17 +175,17 @@ SUBROUTINE PSolver(geocode,iproc,nproc,n01,n02,n03,hx,hy,hz,& !no powers of hgrid because they are incorporated in the plane wave treatment scal=1._dp/REAL(n1*n2*n3,KIND=dp) CALL P_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,zf,& - scal,hx,hy,hz,pw_grid%para%rs_group,error) + scal,hx,hy,hz,pw_grid%para%rs_group) ELSE IF (geocode == 'S') THEN !only one power of hgrid scal=hy/REAL(n1*n2*n3,KIND=dp) CALL S_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,karray,zf,& - scal,pw_grid%para%rs_group,error) + scal,pw_grid%para%rs_group) ELSE IF (geocode == 'F') THEN hgrid=MAX(hx,hy,hz) scal=hgrid**3/REAL(n1*n2*n3,KIND=dp) CALL F_PoissonSolver(n1,n2,n3,nd1,nd2,nd3,md1,md2,md3,nproc,iproc,karray,zf,& - scal,pw_grid%para%rs_group,error) + scal,pw_grid%para%rs_group) factor=0.5_dp*hgrid**3 END IF diff --git a/src/pw/pw_cuda.F b/src/pw/pw_cuda.F index 1b6b35ad2b..35f09593a5 100644 --- a/src/pw/pw_cuda.F +++ b/src/pw/pw_cuda.F @@ -285,14 +285,12 @@ END SUBROUTINE pw_cuda_finalize !> \param pw1 ... !> \param pw2 ... !> \param scale ... -!> \param error ... !> \author Benjamin G Levine ! ***************************************************************************** - SUBROUTINE pw_cuda_r3dc1d_3d(pw1, pw2, scale, error) + SUBROUTINE pw_cuda_r3dc1d_3d(pw1, pw2, scale) TYPE(pw_type), TARGET, INTENT(IN) :: pw1 TYPE(pw_type), TARGET, INTENT(INOUT) :: pw2 REAL(KIND=dp) :: scale - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_r3dc1d_3d', & routineP = moduleN//':'//routineN @@ -334,14 +332,12 @@ END SUBROUTINE pw_cuda_r3dc1d_3d !> \param pw1 ... !> \param pw2 ... !> \param scale ... -!> \param error ... !> \author Benjamin G Levine ! ***************************************************************************** - SUBROUTINE pw_cuda_c1dr3d_3d(pw1, pw2, scale, error) + SUBROUTINE pw_cuda_c1dr3d_3d(pw1, pw2, scale) TYPE(pw_type), TARGET, INTENT(IN) :: pw1 TYPE(pw_type), TARGET, INTENT(INOUT) :: pw2 REAL(KIND=dp) :: scale - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_c1dr3d_3d', & routineP = moduleN//':'//routineN @@ -385,14 +381,12 @@ END SUBROUTINE pw_cuda_c1dr3d_3d !> \param pw1 ... !> \param pw2 ... !> \param scale ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_r3dc1d_3d_ps(pw1, pw2, scale, error) + SUBROUTINE pw_cuda_r3dc1d_3d_ps(pw1, pw2, scale) TYPE(pw_type), TARGET, INTENT(IN) :: pw1 TYPE(pw_type), TARGET, INTENT(INOUT) :: pw2 REAL(KIND=dp) :: scale - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_r3dc1d_3d_ps', & routineP = moduleN//':'//routineN @@ -501,7 +495,7 @@ SUBROUTINE pw_cuda_r3dc1d_3d_ps(pw1, pw2, scale, error) CALL stop_program(routineN,moduleN,__LINE__,& "This processor distribution is not supported.") - CALL get_fft_scratch(fft_scratch, tf_type = 300, n = n, fft_sizes = fft_scratch_size, error = error) + CALL get_fft_scratch(fft_scratch, tf_type = 300, n = n, fft_sizes = fft_scratch_size) ! assign buffers qbuf => fft_scratch%p2buf @@ -510,25 +504,25 @@ SUBROUTINE pw_cuda_r3dc1d_3d_ps(pw1, pw2, scale, error) sbuf => fft_scratch%p5buf ! FFT along z - CALL pw_cuda_cf(pw1, qbuf, error) + CALL pw_cuda_cf(pw1, qbuf) ! Exchange data ( transpose of matrix ) - CALL cube_transpose_2(qbuf, rs_group, bo(:,:,:,1), bo(:,:,:,2), rbuf, fft_scratch, error) + CALL cube_transpose_2(qbuf, rs_group, bo(:,:,:,1), bo(:,:,:,2), rbuf, fft_scratch) ! FFT along y ! use the inbuild fft-lib ! CALL fft_1dm(fft_scratch%fft_plan(2), rbuf, pbuf, 1.0_dp, stat) ! or cufft (works faster, but is only faster if plans are stored) - CALL pw_cuda_f(rbuf, pbuf, +1, n(2), mx2*mz2, error) + CALL pw_cuda_f(rbuf, pbuf, +1, n(2), mx2*mz2) ! Exchange data ( transpose of matrix ) and sort CALL xz_to_yz(pbuf, rs_group, r_dim, g_pos, p2p, yzp, nyzray, & - bo(:,:,:,2), sbuf, fft_scratch, error) + bo(:,:,:,2), sbuf, fft_scratch) ! FFT along x - CALL pw_cuda_fg(sbuf, pw2, scale, error) + CALL pw_cuda_fg(sbuf, pw2, scale) - CALL release_fft_scratch(fft_scratch, error) + CALL release_fft_scratch(fft_scratch) ELSE ! @@ -537,23 +531,23 @@ SUBROUTINE pw_cuda_r3dc1d_3d_ps(pw1, pw2, scale, error) ! direction x ! - CALL get_fft_scratch(fft_scratch, tf_type = 200, n = n, fft_sizes = fft_scratch_size, error = error) + CALL get_fft_scratch(fft_scratch, tf_type = 200, n = n, fft_sizes = fft_scratch_size) ! assign buffers tbuf => fft_scratch%tbuf sbuf => fft_scratch%r1buf ! FFT along y and z - CALL pw_cuda_cff(pw1, tbuf, error) + CALL pw_cuda_cff(pw1, tbuf) ! Exchange data ( transpose of matrix ) and sort CALL yz_to_x(tbuf, gs_group, g_pos, p2p, yzp, nyzray, & - bo(:,:,:,2), sbuf, fft_scratch, error) + bo(:,:,:,2), sbuf, fft_scratch) ! FFT along x - CALL pw_cuda_fg(sbuf, pw2, scale, error) + CALL pw_cuda_fg(sbuf, pw2, scale) - CALL release_fft_scratch(fft_scratch,error) + CALL release_fft_scratch(fft_scratch) ENDIF @@ -579,14 +573,12 @@ END SUBROUTINE pw_cuda_r3dc1d_3d_ps !> \param pw1 ... !> \param pw2 ... !> \param scale ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_c1dr3d_3d_ps(pw1, pw2, scale, error) + SUBROUTINE pw_cuda_c1dr3d_3d_ps(pw1, pw2, scale) TYPE(pw_type), TARGET, INTENT(IN) :: pw1 TYPE(pw_type), TARGET, INTENT(INOUT) :: pw2 REAL(KIND=dp) :: scale - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_c1dr3d_3d_ps', & routineP = moduleN//':'//routineN @@ -696,7 +688,7 @@ SUBROUTINE pw_cuda_c1dr3d_3d_ps(pw1, pw2, scale, error) CALL stop_program(routineN,moduleN,__LINE__,& "This processor distribution is not supported.") - CALL get_fft_scratch(fft_scratch, tf_type = 300, n = n, fft_sizes = fft_scratch_size, error = error) + CALL get_fft_scratch(fft_scratch, tf_type = 300, n = n, fft_sizes = fft_scratch_size) ! assign buffers pbuf => fft_scratch%p7buf @@ -705,28 +697,28 @@ SUBROUTINE pw_cuda_c1dr3d_3d_ps(pw1, pw2, scale, error) sbuf => fft_scratch%p2buf ! FFT along x - CALL pw_cuda_sf(pw1, pbuf, scale, error) + CALL pw_cuda_sf(pw1, pbuf, scale) ! Exchange data ( transpose of matrix ) and sort IF (pw1%pw_grid%grid_span /= FULLSPACE) CALL zero_c(qbuf) CALL yz_to_xz(pbuf, rs_group, r_dim, g_pos, p2p, yzp, nyzray, & - bo(:,:,:,2), qbuf, fft_scratch, error) + bo(:,:,:,2), qbuf, fft_scratch) ! FFT along y ! use the inbuild fft-lib ! CALL fft_1dm(fft_scratch%fft_plan(5), qbuf, rbuf, 1.0_dp, stat) ! or cufft (works faster, but is only faster if plans are stored) - CALL pw_cuda_f(qbuf, rbuf, -1, n(2), mx2*mz2, error) + CALL pw_cuda_f(qbuf, rbuf, -1, n(2), mx2*mz2) ! Exchange data ( transpose of matrix ) IF (pw1%pw_grid%grid_span /= FULLSPACE) CALL zero_c(sbuf) - CALL cube_transpose_1(rbuf, rs_group, bo(:,:,:,2), bo(:,:,:,1), sbuf, fft_scratch, error) + CALL cube_transpose_1(rbuf, rs_group, bo(:,:,:,2), bo(:,:,:,1), sbuf, fft_scratch) ! FFT along z - CALL pw_cuda_fc(sbuf, pw2, error) + CALL pw_cuda_fc(sbuf, pw2) - CALL release_fft_scratch(fft_scratch, error) + CALL release_fft_scratch(fft_scratch) ELSE ! @@ -735,24 +727,24 @@ SUBROUTINE pw_cuda_c1dr3d_3d_ps(pw1, pw2, scale, error) ! direction x ! - CALL get_fft_scratch(fft_scratch, tf_type = 200, n = n, fft_sizes = fft_scratch_size, error = error) + CALL get_fft_scratch(fft_scratch, tf_type = 200, n = n, fft_sizes = fft_scratch_size) ! assign buffers sbuf => fft_scratch%r1buf tbuf => fft_scratch%tbuf ! FFT along x - CALL pw_cuda_sf(pw1, sbuf, scale, error) + CALL pw_cuda_sf(pw1, sbuf, scale) ! Exchange data ( transpose of matrix ) and sort IF (pw1%pw_grid%grid_span /= FULLSPACE) CALL zero_c(tbuf) CALL x_to_yz (sbuf, gs_group, g_pos, p2p, yzp, nyzray, & - bo(:,:,:,2), tbuf, fft_scratch, error) + bo(:,:,:,2), tbuf, fft_scratch) ! FFT along y and z - CALL pw_cuda_ffc(tbuf, pw2, error) + CALL pw_cuda_ffc(tbuf, pw2) - CALL release_fft_scratch(fft_scratch,error) + CALL release_fft_scratch(fft_scratch) ENDIF @@ -777,14 +769,12 @@ END SUBROUTINE pw_cuda_c1dr3d_3d_ps !> \brief perform a parallel real_to_complex copy followed by a 2D-FFT on the gpu !> \param pw1 ... !> \param pwbuf ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_cff (pw1, pwbuf, error) + SUBROUTINE pw_cuda_cff (pw1, pwbuf) TYPE(pw_type), TARGET, INTENT(IN) :: pw1 COMPLEX(KIND=dp), DIMENSION(:,:,:), & POINTER, INTENT(INOUT) :: pwbuf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_cff', & routineP = moduleN//':'//routineN @@ -818,14 +808,12 @@ END SUBROUTINE pw_cuda_cff !> \brief perform a parallel 2D-FFT followed by a complex_to_real copy on the gpu !> \param pwbuf ... !> \param pw2 ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_ffc (pwbuf, pw2, error) + SUBROUTINE pw_cuda_ffc (pwbuf, pw2) COMPLEX(KIND=dp), DIMENSION(:,:,:), & POINTER, INTENT(IN) :: pwbuf TYPE(pw_type), TARGET, INTENT(INOUT) :: pw2 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_ffc', & routineP = moduleN//':'//routineN @@ -859,14 +847,12 @@ END SUBROUTINE pw_cuda_ffc !> \brief perform a parallel real_to_complex copy followed by a 1D-FFT on the gpu !> \param pw1 ... !> \param pwbuf ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_cf (pw1, pwbuf, error) + SUBROUTINE pw_cuda_cf (pw1, pwbuf) TYPE(pw_type), TARGET, INTENT(IN) :: pw1 COMPLEX(KIND=dp), DIMENSION(:,:), & POINTER, INTENT(INOUT) :: pwbuf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_cf', & routineP = moduleN//':'//routineN @@ -900,14 +886,12 @@ END SUBROUTINE pw_cuda_cf !> \brief perform a parallel 1D-FFT followed by a complex_to_real copy on the gpu !> \param pwbuf ... !> \param pw2 ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_fc (pwbuf, pw2, error) + SUBROUTINE pw_cuda_fc (pwbuf, pw2) COMPLEX(KIND=dp), DIMENSION(:,:), & POINTER, INTENT(IN) :: pwbuf TYPE(pw_type), TARGET, INTENT(INOUT) :: pw2 - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_fc', & routineP = moduleN//':'//routineN @@ -943,10 +927,9 @@ END SUBROUTINE pw_cuda_fc !> \param dir ... !> \param n ... !> \param m ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_f(pwbuf1, pwbuf2, dir, n, m, error) + SUBROUTINE pw_cuda_f(pwbuf1, pwbuf2, dir, n, m) COMPLEX(KIND=dp), DIMENSION(:,:), & POINTER, INTENT(IN) :: pwbuf1 COMPLEX(KIND=dp), DIMENSION(:,:), & @@ -954,7 +937,6 @@ SUBROUTINE pw_cuda_f(pwbuf1, pwbuf2, dir, n, m, error) INTEGER, INTENT(IN) :: dir INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: m - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_f', & routineP = moduleN//':'//routineN @@ -981,15 +963,13 @@ END SUBROUTINE pw_cuda_f !> \param pwbuf ... !> \param pw2 ... !> \param scale ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_fg (pwbuf, pw2, scale, error) + SUBROUTINE pw_cuda_fg (pwbuf, pw2, scale) COMPLEX(KIND=dp), DIMENSION(:,:), & POINTER, INTENT(IN) :: pwbuf TYPE(pw_type), TARGET, INTENT(INOUT) :: pw2 REAL(KIND=dp), INTENT(IN) :: scale - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_fg', & routineP = moduleN//':'//routineN @@ -1029,15 +1009,13 @@ END SUBROUTINE pw_cuda_fg !> \param pw1 ... !> \param pwbuf ... !> \param scale ... -!> \param error ... !> \author Andreas Gloess ! ***************************************************************************** - SUBROUTINE pw_cuda_sf (pw1, pwbuf, scale, error) + SUBROUTINE pw_cuda_sf (pw1, pwbuf, scale) TYPE(pw_type), TARGET, INTENT(IN) :: pw1 COMPLEX(KIND=dp), DIMENSION(:,:), & POINTER, INTENT(INOUT) :: pwbuf REAL(KIND=dp), INTENT(IN) :: scale - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_cuda_sf', & routineP = moduleN//':'//routineN diff --git a/src/pw/pw_grid_info.F b/src/pw/pw_grid_info.F index db44087f06..72eb2e901b 100644 --- a/src/pw/pw_grid_info.F +++ b/src/pw/pw_grid_info.F @@ -39,11 +39,10 @@ MODULE pw_grid_info !> \param icommensurate ... !> \param ref_grid ... !> \param n_orig ... -!> \param error ... !> \retval n ... ! ***************************************************************************** FUNCTION pw_grid_init_setup ( hmat, cutoff, spherical, odd, fft_usage, ncommensurate,& - icommensurate, ref_grid, n_orig, error) RESULT(n) + icommensurate, ref_grid, n_orig) RESULT(n) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: hmat @@ -52,7 +51,6 @@ FUNCTION pw_grid_init_setup ( hmat, cutoff, spherical, odd, fft_usage, ncommensu INTEGER, INTENT(IN) :: ncommensurate, icommensurate TYPE(pw_grid_type), INTENT(IN), OPTIONAL :: ref_grid INTEGER, INTENT(IN), OPTIONAL :: n_orig(3) - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, DIMENSION(3) :: n CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_init_setup', & @@ -63,20 +61,20 @@ FUNCTION pw_grid_init_setup ( hmat, cutoff, spherical, odd, fft_usage, ncommensu IF (ncommensurate>0) THEN my_icommensurate=icommensurate - CPPrecondition(icommensurate>0,cp_failure_level,routineP,error,failure) - CPPrecondition(icommensurate<=ncommensurate,cp_failure_level,routineP,error,failure) + CPPrecondition(icommensurate>0,cp_failure_level,routineP,failure) + CPPrecondition(icommensurate<=ncommensurate,cp_failure_level,routineP,failure) ELSE my_icommensurate=0 END IF IF (my_icommensurate>1) THEN - CPPostcondition(PRESENT(ref_grid),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(ref_grid),cp_failure_level,routineP,failure) n=ref_grid%npts/2**(my_icommensurate-1) - CPPostcondition(ALL(ref_grid%npts==n*2**(my_icommensurate-1)),cp_failure_level,routineP,error,failure) - CPPostcondition(ALL(pw_grid_n_for_fft(n,error=error)==n),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(ref_grid%npts==n*2**(my_icommensurate-1)),cp_failure_level,routineP,failure) + CPPostcondition(ALL(pw_grid_n_for_fft(n)==n),cp_failure_level,routineP,failure) ELSE n=pw_grid_find_n(hmat,cutoff=cutoff, fft_usage=fft_usage, ncommensurate=ncommensurate,& - spherical=spherical, odd=odd, n_orig=n_orig, error=error) + spherical=spherical, odd=odd, n_orig=n_orig) END IF END FUNCTION pw_grid_init_setup @@ -90,13 +88,11 @@ END FUNCTION pw_grid_init_setup !> \param odd ... !> \param ncommensurate ... !> \param n_orig ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval n ... !> \author fawzi ! ***************************************************************************** FUNCTION pw_grid_find_n ( hmat, cutoff, fft_usage, spherical, odd, ncommensurate,& - n_orig, error) RESULT(n) + n_orig) RESULT(n) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: hmat @@ -104,7 +100,6 @@ FUNCTION pw_grid_find_n ( hmat, cutoff, fft_usage, spherical, odd, ncommensurate LOGICAL, INTENT(IN) :: fft_usage, spherical, odd INTEGER, INTENT(IN) :: ncommensurate INTEGER, INTENT(IN), OPTIONAL :: n_orig(3) - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, DIMENSION(3) :: n CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_find_n', & @@ -126,19 +121,19 @@ FUNCTION pw_grid_find_n ( hmat, cutoff, fft_usage, spherical, odd, ncommensurate ELSE my_icommensurate=0 ENDIF - CPPrecondition(my_icommensurate <= my_ncommensurate,cp_failure_level,routineP,error,failure) - CPPrecondition((my_icommensurate > 0 .OR. my_ncommensurate <= 0),cp_failure_level,routineP,error,failure) - CPPrecondition(my_ncommensurate >= 0,cp_failure_level,routineP,error,failure) + CPPrecondition(my_icommensurate <= my_ncommensurate,cp_failure_level,routineP,failure) + CPPrecondition((my_icommensurate > 0 .OR. my_ncommensurate <= 0),cp_failure_level,routineP,failure) + CPPrecondition(my_ncommensurate >= 0,cp_failure_level,routineP,failure) IF (PRESENT(n_orig)) THEN n = n_orig ELSE - CPPrecondition(cutoff>0.0_dp,cp_failure_level,routineP,error,failure) - n= pw_grid_n_from_cutoff (hmat, cutoff, error=error) + CPPrecondition(cutoff>0.0_dp,cp_failure_level,routineP,failure) + n= pw_grid_n_from_cutoff (hmat, cutoff) END IF IF (fft_usage) THEN - n=pw_grid_n_for_fft(n,odd=odd,error=error) + n=pw_grid_n_for_fft(n,odd=odd) IF (.NOT.spherical) THEN ntest = n @@ -178,7 +173,7 @@ FUNCTION pw_grid_find_n ( hmat, cutoff, fft_usage, spherical, odd, ncommensurate IF (my_ncommensurate>0) THEN DO my_icommensurate=1,my_ncommensurate ftest = ANY( MODULO(n,2**(my_ncommensurate-my_icommensurate)).NE.0 ) - CPPostcondition(.NOT. ftest,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT. ftest,cp_failure_level,routineP,failure) END DO ENDIF @@ -189,17 +184,14 @@ END FUNCTION pw_grid_find_n !> ffts !> \param n the minimum number of points you want !> \param odd if the number has to be odd -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval nout ... !> \author fawzi !> \note !> result<=n ! ***************************************************************************** - FUNCTION pw_grid_n_for_fft(n,odd,error) RESULT(nout) + FUNCTION pw_grid_n_for_fft(n,odd) RESULT(nout) INTEGER, DIMENSION(3), INTENT(in) :: n LOGICAL, INTENT(in), OPTIONAL :: odd - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, DIMENSION(3) :: nout CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_n_for_fft', & @@ -210,7 +202,7 @@ FUNCTION pw_grid_n_for_fft(n,odd,error) RESULT(nout) failure=.FALSE. my_odd=.FALSE. IF (PRESENT(odd)) my_odd=odd - CPPrecondition(ALL(n>=0),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(n>=0),cp_failure_level,routineP,failure) IF (my_odd) THEN CALL fft_radix_operations ( n(1), nout(1), FFT_RADIX_NEXT_ODD ) CALL fft_radix_operations ( n(2), nout(2), FFT_RADIX_NEXT_ODD ) @@ -227,7 +219,6 @@ END FUNCTION pw_grid_n_for_fft !> \brief Find the number of points that give at least the requested cutoff !> \param hmat ... !> \param cutoff ... -!> \param error ... !> \retval n ... !> \par History !> JGH (21-12-2000) : Simplify parameter list, bounds will be global @@ -240,12 +231,11 @@ END FUNCTION pw_grid_n_for_fft !> \author apsi !> Christopher Mundy ! ***************************************************************************** - FUNCTION pw_grid_n_from_cutoff ( hmat, cutoff, error ) RESULT(n) + FUNCTION pw_grid_n_from_cutoff ( hmat, cutoff) RESULT(n) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: hmat REAL(KIND=dp), INTENT(IN) :: cutoff - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, DIMENSION(3) :: n CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_n_from_cutoff', & @@ -260,7 +250,7 @@ FUNCTION pw_grid_n_from_cutoff ( hmat, cutoff, error ) RESULT(n) DO i=1,3 alat(i) = SUM ( hmat(:,i)**2 ) ENDDO - CPPostcondition(ALL(alat/=0._dp),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(alat/=0._dp),cp_failure_level,routineP,failure) IF ( failure ) THEN n = -HUGE(0) ELSE @@ -272,14 +262,11 @@ END FUNCTION pw_grid_n_from_cutoff ! ***************************************************************************** !> \brief returns the bounds that distribute n points evenly around 0 !> \param npts the number of points in each direction -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval bounds ... !> \author fawzi ! ***************************************************************************** - FUNCTION pw_grid_bounds_from_n(npts,error) RESULT(bounds) + FUNCTION pw_grid_bounds_from_n(npts) RESULT(bounds) INTEGER, DIMENSION(3), INTENT(in) :: npts - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, DIMENSION(2, 3) :: bounds CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_bounds_from_n', & @@ -295,7 +282,6 @@ END FUNCTION pw_grid_bounds_from_n !> *** This routine calculates the cutoff in MOMENTUM UNITS! *** !> \param npts ... !> \param h_inv ... -!> \param error ... !> \retval cutoff ... !> \par History !> JGH (20-12-2000) : Deleted some strange comments @@ -306,12 +292,11 @@ END FUNCTION pw_grid_bounds_from_n !> of PW on processors. !> npts is the grid size for the full box. ! ***************************************************************************** - FUNCTION pw_find_cutoff ( npts, h_inv, error ) RESULT(cutoff) + FUNCTION pw_find_cutoff ( npts, h_inv) RESULT(cutoff) INTEGER, DIMENSION(:), INTENT(IN) :: npts REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: h_inv - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp) :: cutoff CHARACTER(len=*), PARAMETER :: routineN = 'pw_find_cutoff', & diff --git a/src/pw/pw_grids.F b/src/pw/pw_grids.F index d4e61683e7..e6bd2da467 100644 --- a/src/pw/pw_grids.F +++ b/src/pw/pw_grids.F @@ -107,17 +107,15 @@ END FUNCTION cudaFreeHost !> \param pw_grid ... !> \param pe_group ... !> \param local ... -!> \param error ... !> \par History !> JGH (21-Feb-2003) : initialize pw_grid%reference !> \author JGH (7-Feb-2001) & fawzi ! ***************************************************************************** - SUBROUTINE pw_grid_create ( pw_grid, pe_group, local, error ) + SUBROUTINE pw_grid_create ( pw_grid, pe_group, local) TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, INTENT(in) :: pe_group LOGICAL, INTENT(IN), OPTIONAL :: local - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_create', & routineP = moduleN//':'//routineN @@ -128,9 +126,9 @@ SUBROUTINE pw_grid_create ( pw_grid, pe_group, local, error ) failure =.FALSE. my_local=.FALSE. IF (PRESENT(local)) my_local = local - CPPrecondition(.NOT.ASSOCIATED(pw_grid),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(pw_grid),cp_failure_level,routineP,failure) ALLOCATE(pw_grid,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) pw_grid % bounds = 0 pw_grid % cutoff = 0.0_dp pw_grid % grid_span = FULLSPACE @@ -217,13 +215,12 @@ END FUNCTION pw_grid_compare !> \param orthorhombic ... !> \param gvectors ... !> \param gsquare ... -!> \param error ... !> \par History !> none !> \author JGH (17-Nov-2007) ! ***************************************************************************** SUBROUTINE get_pw_grid_info(pw_grid, id_nr, mode, vol, dvol, npts, ngpts,& - ngpts_cut,dr, cutoff, orthorhombic, gvectors,gsquare,error) + ngpts_cut,dr, cutoff, orthorhombic, gvectors,gsquare) TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, INTENT(OUT), OPTIONAL :: id_nr, mode @@ -239,7 +236,6 @@ SUBROUTINE get_pw_grid_info(pw_grid, id_nr, mode, vol, dvol, npts, ngpts,& POINTER :: gvectors REAL(dp), DIMENSION(:), OPTIONAL, & POINTER :: gsquare - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_pw_grid_info', & routineP = moduleN//':'//routineN @@ -247,7 +243,7 @@ SUBROUTINE get_pw_grid_info(pw_grid, id_nr, mode, vol, dvol, npts, ngpts,& LOGICAL :: failure failure=.FALSE. - CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP,failure) IF ( PRESENT(id_nr) ) id_nr = pw_grid%id_nr IF ( PRESENT(mode) ) mode = pw_grid%para%mode @@ -272,13 +268,11 @@ END SUBROUTINE get_pw_grid_info !> \param bounds ... !> \param cutoff ... !> \param spherical ... -!> \param error ... !> \par History !> none !> \author JGH (19-Nov-2007) ! ***************************************************************************** - SUBROUTINE set_pw_grid_info(pw_grid, grid_span, npts, bounds, cutoff, spherical,& - error) + SUBROUTINE set_pw_grid_info(pw_grid, grid_span, npts, bounds, cutoff, spherical) TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, INTENT(in), OPTIONAL :: grid_span @@ -288,7 +282,6 @@ SUBROUTINE set_pw_grid_info(pw_grid, grid_span, npts, bounds, cutoff, spherical, OPTIONAL :: bounds REAL(KIND=dp), INTENT(IN), OPTIONAL :: cutoff LOGICAL, INTENT(IN), OPTIONAL :: spherical - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_pw_grid_info', & routineP = moduleN//':'//routineN @@ -296,7 +289,7 @@ SUBROUTINE set_pw_grid_info(pw_grid, grid_span, npts, bounds, cutoff, spherical, LOGICAL :: failure failure=.FALSE. - CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP,failure) IF ( PRESENT(grid_span) ) THEN pw_grid%grid_span = grid_span @@ -304,13 +297,13 @@ SUBROUTINE set_pw_grid_info(pw_grid, grid_span, npts, bounds, cutoff, spherical, IF ( PRESENT(bounds) .AND. PRESENT(npts) ) THEN pw_grid%bounds = bounds pw_grid%npts = npts - CPPostcondition(ALL(npts==bounds(2,:)-bounds(1,:)+1),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(npts==bounds(2,:)-bounds(1,:)+1),cp_failure_level,routineP,failure) ELSE IF ( PRESENT(bounds) ) THEN pw_grid%bounds = bounds pw_grid%npts = bounds(2,:)-bounds(1,:)+1 ELSE IF ( PRESENT(npts) ) THEN pw_grid%npts = npts - pw_grid%bounds = pw_grid_bounds_from_n(npts,error) + pw_grid%bounds = pw_grid_bounds_from_n(npts) END IF IF ( PRESENT(cutoff) ) THEN pw_grid%cutoff = cutoff @@ -341,15 +334,13 @@ END SUBROUTINE set_pw_grid_info !> \param ref_grid ... !> \param rs_dims ... !> \param iounit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author JGH (21-Dec-2007) !> \note !> this is the function that should be used in the future ! ***************************************************************************** SUBROUTINE pw_grid_setup (cell_hmat, pw_grid, grid_span, cutoff, bounds, bounds_local, npts, & spherical, odd, fft_usage, ncommensurate, icommensurate, blocked, ref_grid,& - rs_dims, iounit, error ) + rs_dims, iounit) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: cell_hmat @@ -367,7 +358,6 @@ SUBROUTINE pw_grid_setup (cell_hmat, pw_grid, grid_span, cutoff, bounds, bounds_ INTEGER, DIMENSION(2), INTENT(in), & OPTIONAL :: rs_dims INTEGER, INTENT(in), OPTIONAL :: iounit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_setup', & routineP = moduleN//':'//routineN @@ -392,7 +382,7 @@ SUBROUTINE pw_grid_setup (cell_hmat, pw_grid, grid_span, cutoff, bounds, bounds_ IF ( PRESENT(grid_span) ) THEN - CALL set_pw_grid_info ( pw_grid, grid_span=grid_span, error=error) + CALL set_pw_grid_info ( pw_grid, grid_span=grid_span) END IF IF ( PRESENT(spherical) ) THEN @@ -428,47 +418,47 @@ SUBROUTINE pw_grid_setup (cell_hmat, pw_grid, grid_span, cutoff, bounds, bounds_ IF ( PRESENT(bounds) ) THEN IF ( PRESENT(cutoff) ) THEN CALL set_pw_grid_info ( pw_grid, bounds=bounds, cutoff=cutoff, & - spherical=my_spherical, error=error) + spherical=my_spherical) ELSE n = bounds(2,:) - bounds(1,:) + 1 - my_cutoff = pw_find_cutoff ( n, cell_h_inv, error=error) + my_cutoff = pw_find_cutoff ( n, cell_h_inv) my_cutoff = 0.5_dp * my_cutoff * my_cutoff CALL set_pw_grid_info ( pw_grid, bounds=bounds, cutoff=my_cutoff, & - spherical=my_spherical, error=error) + spherical=my_spherical) END IF ELSE IF ( PRESENT(npts) ) THEN n = npts IF ( PRESENT(cutoff) ) THEN my_cutoff=cutoff ELSE - my_cutoff = pw_find_cutoff ( npts, cell_h_inv, error=error) + my_cutoff = pw_find_cutoff ( npts, cell_h_inv) my_cutoff = 0.5_dp * my_cutoff * my_cutoff END IF IF ( my_fft_usage ) THEN n = pw_grid_init_setup(cell_hmat, cutoff=my_cutoff,& spherical=my_spherical, odd=my_odd, fft_usage=my_fft_usage,& ncommensurate=my_ncommensurate, icommensurate=my_icommensurate,& - ref_grid=ref_grid, n_orig=n, error=error) + ref_grid=ref_grid, n_orig=n) END IF CALL set_pw_grid_info ( pw_grid, npts=n, cutoff=my_cutoff, & - spherical=my_spherical, error=error) + spherical=my_spherical) ELSE IF ( PRESENT(cutoff) ) THEN n = pw_grid_init_setup(cell_hmat,cutoff=cutoff,& spherical=my_spherical,odd=my_odd,fft_usage=my_fft_usage,& ncommensurate=my_ncommensurate,icommensurate=my_icommensurate,& - ref_grid=ref_grid,error=error) + ref_grid=ref_grid) CALL set_pw_grid_info ( pw_grid, npts=n, cutoff=cutoff, & - spherical=my_spherical, error=error) + spherical=my_spherical) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "BOUNDS, NPTS or CUTOFF have to be specified") END IF CALL pw_grid_setup_internal (cell_hmat, cell_h_inv, cell_deth, pw_grid, bounds_local=bounds_local, & - blocked=blocked, ref_grid=ref_grid, rs_dims=rs_dims, iounit=iounit, error=error ) + blocked=blocked, ref_grid=ref_grid, rs_dims=rs_dims, iounit=iounit) #if defined ( __PW_CUDA ) - CALL pw_grid_create_ghatmap ( pw_grid, error ) + CALL pw_grid_create_ghatmap ( pw_grid) #endif CALL timestop(handle) @@ -478,14 +468,12 @@ END SUBROUTINE pw_grid_setup ! ***************************************************************************** !> \brief sets up a combined index for CUDA gather and scatter !> \param pw_grid ... -!> \param error ... !> \author Gloess Andreas (xx-Dec-2012) ! ***************************************************************************** - SUBROUTINE pw_grid_create_ghatmap ( pw_grid, error ) + SUBROUTINE pw_grid_create_ghatmap ( pw_grid) TYPE(pw_grid_type), INTENT(INOUT), & POINTER :: pw_grid - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_create_ghatmap', & routineP = moduleN//':'//routineN @@ -501,8 +489,8 @@ SUBROUTINE pw_grid_create_ghatmap ( pw_grid, error ) ! some checks failure=.FALSE. - CPPrecondition(ASSOCIATED(pw_grid), cp_failure_level, routineP, error, failure) - CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP, error,failure) + CPPrecondition(ASSOCIATED(pw_grid), cp_failure_level, routineP,failure) + CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP,failure) ! mapping of map_x( g_hat(i,j)) to g_hatmap ! the second index is for switching from gather(1) to scatter(2) @@ -579,8 +567,6 @@ END SUBROUTINE pw_grid_create_ghatmap !> \param ref_grid ... !> \param rs_dims ... !> \param iounit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> JGH (20-Dec-2000) : Adapted for parallel use !> JGH (28-Feb-2001) : New optional argument fft_usage @@ -596,7 +582,7 @@ END SUBROUTINE pw_grid_create_ghatmap !> this is the function that should be used in the future ! ***************************************************************************** SUBROUTINE pw_grid_setup_internal (cell_hmat, cell_h_inv, cell_deth, pw_grid, bounds_local, & - blocked, ref_grid, rs_dims, iounit, error ) + blocked, ref_grid, rs_dims, iounit) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: cell_hmat, cell_h_inv REAL(KIND=dp), INTENT(IN) :: cell_deth @@ -608,7 +594,6 @@ SUBROUTINE pw_grid_setup_internal (cell_hmat, cell_h_inv, cell_deth, pw_grid, bo INTEGER, DIMENSION(2), INTENT(in), & OPTIONAL :: rs_dims INTEGER, INTENT(in), OPTIONAL :: iounit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_setup_internal', & routineP = moduleN//':'//routineN @@ -623,8 +608,8 @@ SUBROUTINE pw_grid_setup_internal (cell_hmat, cell_h_inv, cell_deth, pw_grid, bo CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,failure) + CPPrecondition(pw_grid%ref_count>0,cp_failure_level,routineP,failure) ! set pointer to possible reference grid @@ -645,38 +630,38 @@ SUBROUTINE pw_grid_setup_internal (cell_hmat, cell_h_inv, cell_deth, pw_grid, bo ! the indices in yz_mask are from -n/2 .. n/2 shifted by n/2 + 1 ! these are not mapped indices ! ALLOCATE ( yz_mask ( n(2), n(3) ), STAT = allocstat ) - CPPrecondition(allocstat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat==0,cp_failure_level,routineP,failure) CALL pw_grid_count ( cell_h_inv, pw_grid, ecut, yz_mask ) ! Check if reference grid is compatible IF ( PRESENT ( ref_grid ) ) THEN - CPPrecondition(pw_grid % para % mode == ref_grid % para % mode,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid % para % mode == ref_grid % para % mode,cp_failure_level,routineP,failure) IF ( pw_grid % para % mode == PW_MODE_DISTRIBUTED ) THEN CALL mp_comm_compare(pw_grid % para % group, ref_grid % para % group, ires ) - CPPrecondition(ires <= 3,cp_failure_level,routineP,error,failure) !FM make it >3 ? + CPPrecondition(ires <= 3,cp_failure_level,routineP,failure) !FM make it >3 ? END IF - CPPrecondition(pw_grid % grid_span == ref_grid % grid_span,cp_failure_level,routineP,error,failure) - CPPrecondition(pw_grid % spherical .EQV. ref_grid % spherical,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid % grid_span == ref_grid % grid_span,cp_failure_level,routineP,failure) + CPPrecondition(pw_grid % spherical .EQV. ref_grid % spherical,cp_failure_level,routineP,failure) END IF ! Distribute grid CALL pw_grid_distribute ( pw_grid, yz_mask, bounds_local=bounds_local, ref_grid=ref_grid, blocked=blocked, & - rs_dims=rs_dims ,error=error) + rs_dims=rs_dims) ! Allocate the grid fields CALL pw_grid_allocate ( pw_grid, pw_grid % ngpts_cut_local, & - pw_grid % bounds, error ) + pw_grid % bounds) ! Fill in the grid structure - CALL pw_grid_assign ( cell_h_inv, pw_grid, ecut, error ) + CALL pw_grid_assign ( cell_h_inv, pw_grid, ecut) ! Sort g vector wrt length (only local for each processor) - CALL pw_grid_sort ( pw_grid, ref_grid, error ) + CALL pw_grid_sort ( pw_grid, ref_grid) - CALL pw_grid_remap ( pw_grid, yz_mask, error ) + CALL pw_grid_remap ( pw_grid, yz_mask) DEALLOCATE ( yz_mask , STAT=allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) CALL cell2grid(cell_hmat, cell_h_inv, cell_deth, pw_grid) ! @@ -684,7 +669,7 @@ SUBROUTINE pw_grid_setup_internal (cell_hmat, cell_h_inv, cell_deth, pw_grid, bo ! IF(PRESENT(iounit)) THEN - CALL pw_grid_print ( pw_grid, iounit, error ) + CALL pw_grid_print ( pw_grid, iounit) END IF CALL timestop(handle) @@ -735,14 +720,12 @@ END SUBROUTINE cell2grid !> \brief Output of information on pw_grid !> \param pw_grid ... !> \param info ... -!> \param error ... !> \author JGH[18-05-2007] from earlier versions ! ***************************************************************************** - SUBROUTINE pw_grid_print ( pw_grid, info, error ) + SUBROUTINE pw_grid_print ( pw_grid, info) TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, INTENT(IN) :: info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_print', & routineP = moduleN//':'//routineN @@ -855,14 +838,13 @@ END SUBROUTINE pw_grid_print !> \param ref_grid ... !> \param blocked ... !> \param rs_dims ... -!> \param error ... !> \par History !> JGH (01-Mar-2001) optional reference grid !> JGH (22-May-2002) bug fix for pre_tag and HALFSPACE grids !> JGH (09-Sep-2003) reduce scaling for distribution !> \author JGH (22-12-2000) ! ***************************************************************************** - SUBROUTINE pw_grid_distribute ( pw_grid, yz_mask, bounds_local, ref_grid, blocked, rs_dims, error) + SUBROUTINE pw_grid_distribute ( pw_grid, yz_mask, bounds_local, ref_grid, blocked, rs_dims) TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, DIMENSION(:, :), INTENT(INOUT) :: yz_mask @@ -872,7 +854,6 @@ SUBROUTINE pw_grid_distribute ( pw_grid, yz_mask, bounds_local, ref_grid, blocke INTEGER, INTENT(IN), OPTIONAL :: blocked INTEGER, DIMENSION(2), INTENT(in), & OPTIONAL :: rs_dims - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_distribute', & routineP = moduleN//':'//routineN @@ -894,7 +875,7 @@ SUBROUTINE pw_grid_distribute ( pw_grid, yz_mask, bounds_local, ref_grid, blocke lbz = pw_grid % bounds ( 1, 3 ) pw_grid % ngpts = PRODUCT ( INT(pw_grid % npts,KIND=int_8) ) - CPPrecondition(ALL(pw_grid%para%rs_dims==0),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(pw_grid%para%rs_dims==0),cp_failure_level,routineP,failure) IF (PRESENT(rs_dims)) THEN pw_grid%para%rs_dims=rs_dims END IF @@ -915,9 +896,9 @@ SUBROUTINE pw_grid_distribute ( pw_grid, yz_mask, bounds_local, ref_grid, blocke pw_grid % bounds_local = pw_grid % bounds pw_grid % npts_local = pw_grid % npts -CPPrecondition(pw_grid%ngpts_cut \brief ... !> \param yz_mask ... !> \param yz_index ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE order_mask ( yz_mask, yz_index, error ) + SUBROUTINE order_mask ( yz_mask, yz_index) INTEGER, DIMENSION(:, :), INTENT(IN) :: yz_mask INTEGER, DIMENSION(:, :), INTENT(OUT) :: yz_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'order_mask', & routineP = moduleN//':'//routineN @@ -1556,18 +1535,16 @@ END SUBROUTINE pw_grid_count !> \param h_inv ... !> \param pw_grid ... !> \param cutoff ... -!> \param error ... !> \par History !> JGH (29-12-2000) : Adapted for parallel use !> \author apsi !> Christopher Mundy ! ***************************************************************************** - SUBROUTINE pw_grid_assign ( h_inv, pw_grid, cutoff, error ) + SUBROUTINE pw_grid_assign ( h_inv, pw_grid, cutoff) REAL(KIND=dp), DIMENSION(3, 3) :: h_inv TYPE(pw_grid_type), POINTER :: pw_grid REAL(KIND=dp), INTENT(IN) :: cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_assign', & routineP = moduleN//':'//routineN @@ -1702,11 +1679,11 @@ SUBROUTINE pw_grid_assign ( h_inv, pw_grid, cutoff, error ) END IF ! Check the number of g-vectors for grid - CPPrecondition(pw_grid % ngpts_cut_local == gpt,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid % ngpts_cut_local == gpt,cp_failure_level,routineP,failure) IF ( pw_grid % para % mode == PW_MODE_DISTRIBUTED ) THEN gpt_global = gpt CALL mp_sum ( gpt_global, pw_grid % para % group ) - CPPrecondition(pw_grid % ngpts_cut == gpt_global,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid % ngpts_cut == gpt_global,cp_failure_level,routineP,failure) ENDIF pw_grid % have_g0 = .FALSE. @@ -1803,7 +1780,6 @@ END SUBROUTINE pw_grid_set_maps !> \param pw_grid ... !> \param ng ... !> \param bounds ... -!> \param error ... !> \par History !> JGH (20-12-2000) : Added status variable !> Bounds of arrays now from calling routine, this @@ -1811,13 +1787,12 @@ END SUBROUTINE pw_grid_set_maps !> \author apsi !> Christopher Mundy ! ***************************************************************************** - SUBROUTINE pw_grid_allocate ( pw_grid, ng, bounds, error ) + SUBROUTINE pw_grid_allocate ( pw_grid, ng, bounds) ! Argument TYPE(pw_grid_type), INTENT(INOUT) :: pw_grid INTEGER, INTENT(IN) :: ng INTEGER, DIMENSION(:, :), INTENT(IN) :: bounds - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_allocate', & routineP = moduleN//':'//routineN @@ -1837,11 +1812,11 @@ SUBROUTINE pw_grid_allocate ( pw_grid, ng, bounds, error ) failure = .FALSE. ALLOCATE ( pw_grid % g ( 3, ng ), STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( pw_grid % gsq ( ng ), STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( pw_grid % g_hat ( 3, ng ), STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) nmaps = 1 IF (pw_grid%grid_span == HALFSPACE) nmaps = 2 @@ -1854,35 +1829,35 @@ SUBROUTINE pw_grid_allocate ( pw_grid, ng, bounds, error ) #else ALLOCATE(pw_grid%g_hatmap(1, 1), STAT = allocstat) #endif - CPPrecondition(allocstat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(allocstat==0, cp_failure_level, routineP,failure) IF (pw_grid%para%mode == PW_MODE_DISTRIBUTED) THEN ALLOCATE ( pw_grid % grays ( pw_grid%npts(1), & pw_grid%para%nyzray(pw_grid%para%my_pos) ), & STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) END IF ALLOCATE ( pw_grid % mapl % pos ( bounds ( 1, 1 ):bounds ( 2, 1 ) ), & STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( pw_grid % mapl % neg ( bounds ( 1, 1 ):bounds ( 2, 1 ) ), & STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( pw_grid % mapm % pos ( bounds ( 1, 2 ):bounds ( 2, 2 ) ), & STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( pw_grid % mapm % neg ( bounds ( 1, 2 ):bounds ( 2, 2 ) ), & STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( pw_grid % mapn % pos ( bounds ( 1, 3 ):bounds ( 2, 3 ) ), & STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( pw_grid % mapn % neg ( bounds ( 1, 3 ):bounds ( 2, 3 ) ), & STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1892,7 +1867,6 @@ END SUBROUTINE pw_grid_allocate !> \brief Sort g-vectors according to length !> \param pw_grid ... !> \param ref_grid ... -!> \param error ... !> \par History !> JGH (20-12-2000) : allocate idx, ng = SIZE ( pw_grid % gsq ) the !> sorting is local and independent from parallelisation @@ -1908,12 +1882,11 @@ END SUBROUTINE pw_grid_allocate !> \author apsi !> Christopher Mundy ! ***************************************************************************** - SUBROUTINE pw_grid_sort ( pw_grid, ref_grid, error ) + SUBROUTINE pw_grid_sort ( pw_grid, ref_grid) ! Argument TYPE(pw_grid_type), INTENT(INOUT) :: pw_grid TYPE(pw_grid_type), INTENT(IN), OPTIONAL :: ref_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_sort', & routineP = moduleN//':'//routineN @@ -1933,15 +1906,15 @@ SUBROUTINE pw_grid_sort ( pw_grid, ref_grid, error ) ng = SIZE ( pw_grid % gsq ) ALLOCATE ( idx ( ng ), STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ! grids are (locally) ordered by length of G-vectors CALL sort ( pw_grid % gsq, ng, idx ) ! within shells order wrt x,y,z - CALL sort_shells ( pw_grid % gsq, pw_grid % g_hat, idx, error ) + CALL sort_shells ( pw_grid % gsq, pw_grid % g_hat, idx) ALLOCATE ( real_tmp ( 3, ng ), STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) DO i=1,ng real_tmp(1,i)= pw_grid % g (1,idx (i)) real_tmp(2,i)= pw_grid % g (2,idx (i)) @@ -1953,10 +1926,10 @@ SUBROUTINE pw_grid_sort ( pw_grid, ref_grid, error ) pw_grid % g (3,i)=real_tmp(3,i) ENDDO DEALLOCATE ( real_tmp, STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ALLOCATE ( int_tmp ( 3, ng ), STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) DO i=1,ng int_tmp(1,i)= pw_grid % g_hat (1,idx (i)) int_tmp(2,i)= pw_grid % g_hat (2,idx (i)) @@ -1968,10 +1941,10 @@ SUBROUTINE pw_grid_sort ( pw_grid, ref_grid, error ) pw_grid % g_hat (3,i)=int_tmp(3,i) ENDDO DEALLOCATE ( int_tmp, STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) DEALLOCATE ( idx, STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) ! check if ordering is compatible to reference grid IF ( PRESENT ( ref_grid ) ) THEN @@ -1985,7 +1958,7 @@ SUBROUTINE pw_grid_sort ( pw_grid, ref_grid, error ) END IF ELSE ALLOCATE ( pw_grid%gidx(1:ngr), STAT = allocstat ) - CPPrecondition(allocstat == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(allocstat == 0,cp_failure_level,routineP,failure) pw_grid%gidx = 0 ! first try as many trivial associations as possible it = 0 @@ -2101,15 +2074,13 @@ END SUBROUTINE pw_grid_sort !> \param gsq ... !> \param g_hat ... !> \param idx ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE sort_shells ( gsq, g_hat, idx, error ) + SUBROUTINE sort_shells ( gsq, g_hat, idx) ! Argument REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: gsq INTEGER, DIMENSION(:, :), INTENT(IN) :: g_hat INTEGER, DIMENSION(:), INTENT(INOUT) :: idx - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'sort_shells', & routineP = moduleN//':'//routineN @@ -2135,13 +2106,13 @@ SUBROUTINE sort_shells ( gsq, g_hat, idx, error ) IF ( ABS ( gsq ( ig ) - s_begin ) < small ) THEN s2 = ig ELSE - CALL redist ( g_hat, idx, s1, s2, error) + CALL redist ( g_hat, idx, s1, s2) s_begin = gsq ( ig ) s1 = ig s2 = ig END IF END DO - CALL redist ( g_hat, idx, s1, s2, error ) + CALL redist ( g_hat, idx, s1, s2) CALL timestop(handle) @@ -2153,15 +2124,13 @@ END SUBROUTINE sort_shells !> \param idx ... !> \param s1 ... !> \param s2 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE redist ( g_hat, idx, s1, s2, error ) + SUBROUTINE redist ( g_hat, idx, s1, s2) ! Argument INTEGER, DIMENSION(:, :), INTENT(IN) :: g_hat INTEGER, DIMENSION(:), INTENT(INOUT) :: idx INTEGER, INTENT(IN) :: s1, s2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'redist', & routineP = moduleN//':'//routineN @@ -2176,9 +2145,9 @@ SUBROUTINE redist ( g_hat, idx, s1, s2, error ) IF ( s2 <= s1 ) RETURN ns = s2 - s1 + 1 ALLOCATE ( indl ( ns ), STAT = info ) - CPPrecondition(info == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(info == 0,cp_failure_level,routineP,failure) ALLOCATE ( slen ( ns ), STAT = info ) - CPPrecondition(info == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(info == 0,cp_failure_level,routineP,failure) DO i = s1, s2 ii = idx ( i ) @@ -2196,9 +2165,9 @@ SUBROUTINE redist ( g_hat, idx, s1, s2, error ) idx ( s1:s2 ) = indl ( 1:ns ) DEALLOCATE ( indl, STAT = info ) - CPPrecondition(info == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(info == 0,cp_failure_level,routineP,failure) DEALLOCATE ( slen, STAT = info ) - CPPrecondition(info == 0,cp_failure_level,routineP,error,failure) + CPPrecondition(info == 0,cp_failure_level,routineP,failure) END SUBROUTINE redist @@ -2206,17 +2175,15 @@ END SUBROUTINE redist !> \brief Reorder yzq and yzp arrays for parallel FFT according to FFT mapping !> \param pw_grid ... !> \param yz ... -!> \param error ... !> \par History !> none !> \author JGH (17-Jan-2001) ! ***************************************************************************** - SUBROUTINE pw_grid_remap ( pw_grid, yz, error ) + SUBROUTINE pw_grid_remap ( pw_grid, yz) ! Argument TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, DIMENSION(:, :), INTENT(OUT) :: yz - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_remap', & routineP = moduleN//':'//routineN @@ -2270,7 +2237,7 @@ SUBROUTINE pw_grid_remap ( pw_grid, yz, error ) END DO END DO - CPPrecondition(is == pw_grid % para % nyzray ( ip ),cp_failure_level,routineP,error,failure) + CPPrecondition(is == pw_grid % para % nyzray ( ip ),cp_failure_level,routineP,failure) CALL mp_sum ( pw_grid % para % yzp, pw_grid % para % group ) CALL timestop(handle) @@ -2337,17 +2304,14 @@ END SUBROUTINE pw_grid_change ! ***************************************************************************** !> \brief retains the given pw grid !> \param pw_grid the pw grid to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE pw_grid_retain(pw_grid, error) + SUBROUTINE pw_grid_retain(pw_grid) TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_retain', & routineP = moduleN//':'//routineN @@ -2356,26 +2320,23 @@ SUBROUTINE pw_grid_retain(pw_grid, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(pw_grid%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,failure) + CPPreconditionNoFail(pw_grid%ref_count>0,cp_failure_level,routineP) pw_grid%ref_count=pw_grid%ref_count+1 END SUBROUTINE pw_grid_retain ! ***************************************************************************** !> \brief releases the given pw grid !> \param pw_grid the pw grid to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE pw_grid_release(pw_grid, error) + SUBROUTINE pw_grid_release(pw_grid) TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_release', & routineP = moduleN//':'//routineN @@ -2390,24 +2351,24 @@ SUBROUTINE pw_grid_release(pw_grid, error) failure=.FALSE. IF (ASSOCIATED(pw_grid)) THEN - CPPreconditionNoFail(pw_grid%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(pw_grid%ref_count>0,cp_failure_level,routineP) pw_grid%ref_count=pw_grid%ref_count-1 IF (pw_grid%ref_count==0) THEN IF ( ASSOCIATED ( pw_grid % gidx ) ) THEN DEALLOCATE ( pw_grid % gidx, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % g ) ) THEN DEALLOCATE ( pw_grid % g, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % gsq ) ) THEN DEALLOCATE ( pw_grid % gsq, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % g_hat ) ) THEN DEALLOCATE ( pw_grid % g_hat, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % g_hatmap ) ) THEN #if defined ( __PW_CUDA ) && !defined ( __PW_CUDA_NO_HOSTALLOC ) @@ -2416,52 +2377,52 @@ SUBROUTINE pw_grid_release(pw_grid, error) #else DEALLOCATE ( pw_grid % g_hatmap, STAT = stat ) #endif - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % grays ) ) THEN DEALLOCATE ( pw_grid % grays, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % mapl % pos ) ) THEN DEALLOCATE ( pw_grid % mapl % pos, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % mapm % pos ) ) THEN DEALLOCATE ( pw_grid % mapm % pos, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % mapn % pos ) ) THEN DEALLOCATE ( pw_grid % mapn % pos, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % mapl % neg ) ) THEN DEALLOCATE ( pw_grid % mapl % neg, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % mapm % neg ) ) THEN DEALLOCATE ( pw_grid % mapm % neg, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % mapn % neg ) ) THEN DEALLOCATE ( pw_grid % mapn % neg, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % para % bo ) ) THEN DEALLOCATE ( pw_grid % para % bo, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( pw_grid % para % mode == PW_MODE_DISTRIBUTED ) THEN IF ( ASSOCIATED ( pw_grid % para % yzp ) ) THEN DEALLOCATE ( pw_grid % para % yzp, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % para % yzq ) ) THEN DEALLOCATE ( pw_grid % para % yzq, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF ( ASSOCIATED ( pw_grid % para % nyzray ) ) THEN DEALLOCATE ( pw_grid % para % nyzray, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF ! also release groups @@ -2470,12 +2431,12 @@ SUBROUTINE pw_grid_release(pw_grid, error) CALL mp_comm_free ( pw_grid % para % rs_group ) IF ( ASSOCIATED ( pw_grid % para % pos_of_x ) ) THEN DEALLOCATE ( pw_grid % para % pos_of_x, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF(ASSOCIATED(pw_grid)) THEN DEALLOCATE(pw_grid, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END IF diff --git a/src/pw/pw_methods.F b/src/pw/pw_methods.F index e7ef044ce1..2d0186107d 100644 --- a/src/pw/pw_methods.F +++ b/src/pw/pw_methods.F @@ -79,15 +79,13 @@ MODULE pw_methods ! ***************************************************************************** !> \brief Set values of a pw type to zero !> \param pw ... -!> \param error ... !> \par History !> none !> \author apsi ! ***************************************************************************** - SUBROUTINE pw_zero ( pw, error ) + SUBROUTINE pw_zero ( pw) TYPE(pw_type), INTENT(INOUT) :: pw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero', & routineP = moduleN//':'//routineN @@ -98,7 +96,7 @@ SUBROUTINE pw_zero ( pw, error ) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) IF ( pw%in_use == REALDATA1D ) THEN ns = SIZE(pw%cr) pw%cr(:) = 0._dp @@ -124,7 +122,6 @@ END SUBROUTINE pw_zero !> \brief copy a pw type variable !> \param pw1 ... !> \param pw2 ... -!> \param error ... !> \par History !> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if !> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE @@ -134,10 +131,9 @@ END SUBROUTINE pw_zero !> Currently only copying of respective types allowed, !> in order to avoid errors ! ***************************************************************************** - SUBROUTINE pw_copy ( pw1, pw2, error) + SUBROUTINE pw_copy ( pw1, pw2) TYPE(pw_type), INTENT(IN) :: pw1 TYPE(pw_type), INTENT(INOUT) :: pw2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy', & routineP = moduleN//':'//routineN @@ -150,15 +146,15 @@ SUBROUTINE pw_copy ( pw1, pw2, error) failure = .FALSE. CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) - CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,failure) IF ( pw1%pw_grid %id_nr /= pw2%pw_grid %id_nr ) THEN IF ( pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical ) THEN - IF ( pw_compatible (pw1%pw_grid, pw2%pw_grid, error=error) ) THEN + IF ( pw_compatible (pw1%pw_grid, pw2%pw_grid) ) THEN IF ( pw1%in_use == COMPLEXDATA1D .AND. & pw2%in_use == COMPLEXDATA1D .AND. & @@ -215,7 +211,7 @@ SUBROUTINE pw_copy ( pw1, pw2, error) pw2%cc ( i ) = pw1%cc ( j ) END DO ELSE - CALL pw_zero ( pw2, error=error) + CALL pw_zero ( pw2) !$omp parallel do private(i,j) default(none) shared(ng1,pw1,pw2) DO i = 1, ng1 j = pw2%pw_grid%gidx ( i ) @@ -230,7 +226,7 @@ SUBROUTINE pw_copy ( pw1, pw2, error) pw2%cc ( i ) = pw1%cc ( j ) END DO ELSE - CALL pw_zero ( pw2, error=error) + CALL pw_zero ( pw2) !$omp parallel do private(i,j) default(none) shared(pw1,pw2,ng1) DO i = 1, ng1 j = pw1%pw_grid%gidx ( i ) @@ -309,15 +305,13 @@ END SUBROUTINE pw_copy !> \brief multiplies pw coeffs with a number !> \param pw ... !> \param a ... -!> \param error ... !> \par History !> 11.2004 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE pw_scale( pw, a , error) + SUBROUTINE pw_scale( pw, a) TYPE(pw_type), INTENT(INOUT) :: pw REAL(KIND=dp), INTENT(IN) :: a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale', & routineP = moduleN//':'//routineN @@ -328,7 +322,7 @@ SUBROUTINE pw_scale( pw, a , error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) SELECT CASE ( pw%in_use ) CASE ( REALDATA1D ) @@ -356,7 +350,6 @@ END SUBROUTINE pw_scale !> \brief Calculate the derivative of a plane wave vector !> \param pw ... !> \param n ... -!> \param error ... !> \par History !> JGH (06-10-2002) allow only for inplace derivatives !> \author JGH (25-Feb-2001) @@ -364,11 +357,10 @@ END SUBROUTINE pw_scale !> Calculate the derivative dx^n(1) dy^n(2) dz^n(3) PW !> PW has to be in RECIPROCALSPACE and data in use is COMPLEXDATA1D ! ***************************************************************************** - SUBROUTINE pw_derive ( pw, n, error ) + SUBROUTINE pw_derive ( pw, n) TYPE(pw_type), INTENT(INOUT) :: pw INTEGER, DIMENSION(3), INTENT(IN) :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_derive', & routineP = moduleN//':'//routineN @@ -380,8 +372,8 @@ SUBROUTINE pw_derive ( pw, n, error ) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(n>=0),cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ALL(n>=0),cp_failure_level,routineP,failure) m = SUM ( n ) im = CMPLX ( 0.0_dp, 1.0_dp,KIND=dp) ** m @@ -460,19 +452,17 @@ END SUBROUTINE pw_derive !> \param pwdr2 ... !> \param i ... !> \param j ... -!> \param error ... !> \par History !> none !> \author JGH (05-May-2006) !> \note !> PW has to be in RECIPROCALSPACE and data in use is COMPLEXDATA1D ! ***************************************************************************** - SUBROUTINE pw_dr2 ( pw, pwdr2, i, j, error) + SUBROUTINE pw_dr2 ( pw, pwdr2, i, j) TYPE(pw_type), INTENT(IN) :: pw TYPE(pw_type), INTENT(INOUT) :: pwdr2 INTEGER, INTENT(IN) :: i, j - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_dr2', & routineP = moduleN//':'//routineN @@ -483,7 +473,7 @@ SUBROUTINE pw_dr2 ( pw, pwdr2, i, j, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) flop = 0.0_dp o3 = 1._dp/3._dp @@ -526,7 +516,6 @@ END SUBROUTINE pw_dr2 !> \param pwdr2_gg ... !> \param i ... !> \param j ... -!> \param error ... !> \par History !> none !> \author RD (20-Nov-2006) @@ -534,12 +523,11 @@ END SUBROUTINE pw_dr2 !> PW has to be in RECIPROCALSPACE and data in use is COMPLEXDATA1D !> Adapted from pw_dr2 ! ***************************************************************************** - SUBROUTINE pw_dr2_gg ( pw, pwdr2_gg, i, j, error) + SUBROUTINE pw_dr2_gg ( pw, pwdr2_gg, i, j) TYPE(pw_type), INTENT(IN) :: pw TYPE(pw_type), INTENT(INOUT) :: pwdr2_gg INTEGER, INTENT(IN) :: i, j - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: cnt, handle, ig LOGICAL :: failure @@ -549,7 +537,7 @@ SUBROUTINE pw_dr2_gg ( pw, pwdr2_gg, i, j, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) flop = 0.0_dp o3 = 1._dp/3._dp @@ -594,18 +582,16 @@ END SUBROUTINE pw_dr2_gg !> \param pw ... !> \param ecut ... !> \param sigma ... -!> \param error ... !> \par History !> none !> \author JGH (09-June-2006) !> \note !> PW has to be in RECIPROCALSPACE and data in use is COMPLEXDATA1D ! ***************************************************************************** - SUBROUTINE pw_smoothing ( pw, ecut, sigma, error) + SUBROUTINE pw_smoothing ( pw, ecut, sigma) TYPE(pw_type), INTENT(INOUT) :: pw REAL(KIND=dp), INTENT(IN) :: ecut, sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_smoothing', & routineP = moduleN//':'//routineN @@ -616,7 +602,7 @@ SUBROUTINE pw_smoothing ( pw, ecut, sigma, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) flop = 0.0_dp @@ -649,19 +635,17 @@ END SUBROUTINE pw_smoothing !> \param pw1 ... !> \param pw2 ... !> \param debug ... -!> \param error ... !> \par History !> JGH (13-Mar-2001) : added gather/scatter cases !> \author JGH (25-Feb-2001) !> \note !> Copy routine that allows for in_space changes ! ***************************************************************************** - SUBROUTINE pw_transfer ( pw1, pw2, debug, error) + SUBROUTINE pw_transfer ( pw1, pw2, debug) TYPE(pw_type), INTENT(IN), TARGET :: pw1 TYPE(pw_type), INTENT(INOUT), TARGET :: pw2 LOGICAL, INTENT(IN), OPTIONAL :: debug - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_transfer', & routineP = moduleN//':'//routineN @@ -674,13 +658,13 @@ SUBROUTINE pw_transfer ( pw1, pw2, debug, error) CALL m_memory() failure = .FALSE. - CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,failure) IF ( pw1%in_space == REALSPACE .AND. pw2%in_space == REALSPACE ) THEN ! simple copy should do - CALL pw_copy ( pw1, pw2, error=error) + CALL pw_copy ( pw1, pw2) ELSEIF ( pw1%in_space == RECIPROCALSPACE .AND. & pw2%in_space == RECIPROCALSPACE ) THEN @@ -688,15 +672,15 @@ SUBROUTINE pw_transfer ( pw1, pw2, debug, error) IF ( pw1%in_use == pw2%in_use ) THEN ! simple copy should do - CALL pw_copy ( pw1, pw2, error=error) + CALL pw_copy ( pw1, pw2) ELSE ! we have to gather/scatter the data IF ( pw1%in_use == COMPLEXDATA1D ) THEN - CALL pw_scatter ( pw1, pw2%cc3d, error=error) + CALL pw_scatter ( pw1, pw2%cc3d) ELSEIF ( pw2%in_use == COMPLEXDATA1D ) THEN - CALL pw_gather ( pw2, pw1%cc3d, error=error) + CALL pw_gather ( pw2, pw1%cc3d) ELSE CALL stop_program(routineN,moduleN,__LINE__, "Do not know what to do" ) END IF @@ -706,7 +690,7 @@ SUBROUTINE pw_transfer ( pw1, pw2, debug, error) ELSE ! FFT needed, all further tests done in fft_wrap_pw1pw2 - CALL fft_wrap_pw1pw2 ( pw1, pw2, debug, error=error) + CALL fft_wrap_pw1pw2 ( pw1, pw2, debug) END IF @@ -720,7 +704,6 @@ END SUBROUTINE pw_transfer !> \param pw1 ... !> \param pw2 ... !> \param alpha ... -!> \param error ... !> \par History !> JGH (21-Feb-2003) : added reference grid functionality !> JGH (01-Dec-2007) : rename and remove complex alpha @@ -729,12 +712,11 @@ END SUBROUTINE pw_transfer !> Currently only summing up of respective types allowed, !> in order to avoid errors ! ***************************************************************************** - SUBROUTINE pw_axpy ( pw1, pw2, alpha, error) + SUBROUTINE pw_axpy ( pw1, pw2, alpha) TYPE(pw_type), INTENT(IN) :: pw1 TYPE(pw_type), INTENT(INOUT) :: pw2 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy', & routineP = moduleN//':'//routineN @@ -747,11 +729,11 @@ SUBROUTINE pw_axpy ( pw1, pw2, alpha, error) failure = .FALSE. CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) - CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,failure) my_alpha=1.0_dp IF (PRESENT(alpha)) my_alpha=alpha @@ -808,7 +790,7 @@ SUBROUTINE pw_axpy ( pw1, pw2, alpha, error) CALL stop_program(routineN,moduleN,__LINE__,"No suitable data field") END IF - ELSE IF ( pw_compatible ( pw1%pw_grid, pw2%pw_grid, error=error) ) THEN + ELSE IF ( pw_compatible ( pw1%pw_grid, pw2%pw_grid) ) THEN IF ( pw1%in_use == COMPLEXDATA1D .AND. & pw2%in_use == COMPLEXDATA1D .AND. & @@ -940,18 +922,16 @@ END SUBROUTINE pw_axpy !> \param pw ... !> \param c ... !> \param scale ... -!> \param error ... !> \par History !> none !> \author JGH ! ***************************************************************************** - SUBROUTINE pw_gather_s ( pw, c, scale, error) + SUBROUTINE pw_gather_s ( pw, c, scale) TYPE(pw_type), INTENT(INOUT) :: pw COMPLEX(KIND=dp), DIMENSION(:, :, :), & INTENT(IN) :: c REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_gather_s', & routineP = moduleN//':'//routineN @@ -964,7 +944,7 @@ SUBROUTINE pw_gather_s ( pw, c, scale, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) IF ( pw%in_use /= COMPLEXDATA1D ) THEN CALL stop_program(routineN,moduleN,__LINE__,"Data field has to be COMPLEXDATA1D") @@ -1017,15 +997,13 @@ END SUBROUTINE pw_gather_s !> \param pw ... !> \param c ... !> \param scale ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pw_gather_p ( pw, c, scale, error) + SUBROUTINE pw_gather_p ( pw, c, scale) TYPE(pw_type), INTENT(INOUT), TARGET :: pw COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: c REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_gather_p', & routineP = moduleN//':'//routineN @@ -1039,7 +1017,7 @@ SUBROUTINE pw_gather_p ( pw, c, scale, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) IF ( pw%in_use /= COMPLEXDATA1D ) THEN CALL stop_program(routineN,moduleN,__LINE__,"Data field has to be COMPLEXDATA1D") @@ -1101,18 +1079,16 @@ END SUBROUTINE pw_gather_p !> \param pw ... !> \param c ... !> \param scale ... -!> \param error ... !> \par History !> none !> \author JGH ! ***************************************************************************** - SUBROUTINE pw_scatter_s ( pw, c, scale, error) + SUBROUTINE pw_scatter_s ( pw, c, scale) TYPE(pw_type), INTENT(IN) :: pw COMPLEX(KIND=dp), DIMENSION(:, :, :), & INTENT(INOUT) :: c REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_scatter_s', & routineP = moduleN//':'//routineN @@ -1125,7 +1101,7 @@ SUBROUTINE pw_scatter_s ( pw, c, scale, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) IF ( pw%in_use /= COMPLEXDATA1D ) THEN CALL stop_program(routineN,moduleN,__LINE__,"Data field has to be COMPLEXDATA1D") @@ -1216,15 +1192,13 @@ END SUBROUTINE pw_scatter_s !> \param pw ... !> \param c ... !> \param scale ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pw_scatter_p ( pw, c, scale, error) + SUBROUTINE pw_scatter_p ( pw, c, scale) TYPE(pw_type), INTENT(IN), TARGET :: pw COMPLEX(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: c REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_scatter_p', & routineP = moduleN//':'//routineN @@ -1238,7 +1212,7 @@ SUBROUTINE pw_scatter_p ( pw, c, scale, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count>0,cp_failure_level,routineP,failure) IF ( pw%in_use /= COMPLEXDATA1D ) THEN CALL stop_program(routineN,moduleN,__LINE__,"Data field has to be COMPLEXDATA1D") @@ -1342,7 +1316,6 @@ END SUBROUTINE pw_scatter_p !> \param pw1 ... !> \param pw2 ... !> \param debug ... -!> \param error ... !> \par History !> JGH (30-12-2000): New setup of functions and adaptation to parallelism !> JGH (04-01-2001): Moved routine from pws to this module, only covers @@ -1351,12 +1324,11 @@ END SUBROUTINE pw_scatter_p !> \note !> fft_wrap_pw1pw2 ! ***************************************************************************** - SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) + SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug) TYPE(pw_type), INTENT(IN), TARGET :: pw1 TYPE(pw_type), INTENT(INOUT), TARGET :: pw2 LOGICAL, INTENT(IN), OPTIONAL :: debug - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2', & routineP = moduleN//':'//routineN @@ -1377,13 +1349,13 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) failure = .FALSE. CALL timeset(routineN,handle2) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) CALL timeset(routineN//"_"//TRIM(ADJUSTL(cp_to_string( & CEILING (pw1%pw_grid%cutoff/10)*10))),handle) - CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw1%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(pw2%ref_count>0,cp_failure_level,routineP,failure) NULLIFY ( c_in ) NULLIFY ( c_out ) @@ -1420,7 +1392,7 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) n => pw1%pw_grid%npts - mode = fftselect ( pw1%in_use, pw2%in_use, pw1%in_space, error=error) + mode = fftselect ( pw1%in_use, pw2%in_use, pw1%in_space) IF ( pw1%pw_grid%para%mode == PW_MODE_LOCAL ) THEN @@ -1464,21 +1436,21 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) CALL fft3d ( dir, n, c_in, c_out, scale = norm, debug = test ) ! gather results IF ( test .AND. output_unit > 0 ) WRITE ( output_unit,'(A)') " PW_GATHER : 3d -> 1d " - CALL pw_gather ( pw2, c_out, error = error) + CALL pw_gather ( pw2, c_out) DEALLOCATE ( c_out, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE ( "FW_R3DC1D" ) #if defined (__PW_CUDA) - CALL pw_cuda_r3dc1d_3d(pw1, pw2, scale = norm, error = error) + CALL pw_cuda_r3dc1d_3d(pw1, pw2, scale = norm) #else ALLOCATE ( c_out( n(1), n(2), n(3) ), STAT = stat ) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "c_out",2*dp_size*PRODUCT(n(1:3))) CALL copy_rc(pw1%cr3d,c_out) CALL fft3d ( dir, n, c_out, scale = norm, debug = test ) - CALL pw_gather ( pw2, c_out, error = error) + CALL pw_gather ( pw2, c_out) DEALLOCATE ( c_out, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) #endif CASE ( "BW_C3DC3D" ) c_in => pw1%cc3d @@ -1494,28 +1466,28 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) IF ( test .AND. output_unit > 0 ) WRITE ( output_unit,'(A)') " REAL part " pw2%cr3d = REAL ( c_out,KIND=dp) DEALLOCATE ( c_out, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE ( "BW_C1DC3D" ) c_out => pw2%cc3d IF ( test .AND. output_unit > 0 ) WRITE ( output_unit,'(A)') " PW_SCATTER : 3d -> 1d " - CALL pw_scatter ( pw1, c_out, error=error) + CALL pw_scatter ( pw1, c_out) CALL fft3d ( dir, n, c_out, scale = norm, debug = test ) CASE ( "BW_C1DR3D" ) #if defined (__PW_CUDA) - CALL pw_cuda_c1dr3d_3d(pw1, pw2, scale = norm, error = error) + CALL pw_cuda_c1dr3d_3d(pw1, pw2, scale = norm) #else ALLOCATE ( c_out( n(1), n(2), n(3) ), STAT = stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "c_out",2*dp_size*PRODUCT(n(1:3))) IF ( test .AND. output_unit > 0 ) WRITE ( output_unit,'(A)') " PW_SCATTER : 3d -> 1d " - CALL pw_scatter ( pw1, c_out, error = error) + CALL pw_scatter ( pw1, c_out) ! transform CALL fft3d ( dir, n, c_out, scale = norm, debug = test ) ! use real part only IF ( test .AND. output_unit > 0 ) WRITE ( output_unit,'(A)') " REAL part " CALL copy_cr(c_out,pw2%cr3d) DEALLOCATE ( c_out, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) #endif END SELECT @@ -1545,8 +1517,8 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) my_pos = pw1%pw_grid%para%my_pos nrays = pw1%pw_grid%para%nyzray ( my_pos ) grays => pw1%pw_grid%grays - CPPostcondition(SIZE(grays,1)==n(1),cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(grays,2)==nrays,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(grays,1)==n(1),cp_failure_level,routineP,failure) + CPPostcondition(SIZE(grays,2)==nrays,cp_failure_level,routineP,failure) SELECT CASE ( mode ) CASE DEFAULT @@ -1570,7 +1542,7 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) !..prepare output IF ( test .AND. pw1%pw_grid%para%group_head .AND. output_unit > 0 ) & WRITE ( output_unit,'(A)') " PW_GATHER : 2d -> 1d " - CALL pw_gather ( pw2, grays, error=error) + CALL pw_gather ( pw2, grays) CASE ( "FW_R3DC1D" ) #if defined (__PW_CUDA) ! (no ray dist. is not efficient in CUDA) @@ -1579,7 +1551,7 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) use_pw_cuda = .FALSE. #endif IF (use_pw_cuda) THEN - CALL pw_cuda_r3dc1d_3d_ps(pw1, pw2, scale = norm, error = error) + CALL pw_cuda_r3dc1d_3d_ps(pw1, pw2, scale = norm) ELSE !..prepare input nloc = pw1%pw_grid%npts_local @@ -1601,16 +1573,16 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) !..prepare output IF ( test .AND. pw1%pw_grid%para%group_head .AND. output_unit > 0 ) & WRITE ( output_unit,'(A)') " PW_GATHER : 2d -> 1d " - CALL pw_gather ( pw2, grays, error=error) + CALL pw_gather ( pw2, grays) DEALLOCATE ( c_in, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CASE ( "BW_C1DC3D" ) !..prepare input IF ( test .AND. pw1%pw_grid%para%group_head .AND. output_unit > 0 ) & WRITE ( output_unit,'(A)') " PW_SCATTER : 2d -> 1d " CALL zero_c(grays) - CALL pw_scatter ( pw1, grays, error=error) + CALL pw_scatter ( pw1, grays) c_in => pw2%cc3d !..transform IF ( pw1%pw_grid%para%ray_distribution ) THEN @@ -1631,13 +1603,13 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) use_pw_cuda = .FALSE. #endif IF (use_pw_cuda) THEN - CALL pw_cuda_c1dr3d_3d_ps(pw1, pw2, scale = norm, error = error) + CALL pw_cuda_c1dr3d_3d_ps(pw1, pw2, scale = norm) ELSE !..prepare input IF ( test .AND. pw1%pw_grid%para%group_head .AND. output_unit > 0 ) & WRITE ( output_unit,'(A)') " PW_SCATTER : 2d -> 1d " CALL zero_c(grays) - CALL pw_scatter ( pw1, grays, error=error) + CALL pw_scatter ( pw1, grays) nloc = pw2%pw_grid%npts_local ALLOCATE ( c_in( nloc(1), nloc(2), nloc(3) ), STAT = stat ) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -1657,7 +1629,7 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug, error) WRITE ( output_unit,'(A)') " Real part " CALL copy_cr(c_in,pw2%cr3d) DEALLOCATE ( c_in, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SELECT @@ -1680,12 +1652,10 @@ END SUBROUTINE fft_wrap_pw1pw2 !> \param use1 ... !> \param use2 ... !> \param space1 ... -!> \param error ... !> \retval mode ... ! ***************************************************************************** - FUNCTION fftselect ( use1, use2, space1, error) RESULT ( mode ) + FUNCTION fftselect ( use1, use2, space1) RESULT ( mode ) INTEGER, INTENT(IN) :: use1, use2, space1 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=9) :: mode CHARACTER(len=*), PARAMETER :: routineN = 'fftselect', & @@ -1736,16 +1706,13 @@ END FUNCTION fftselect !> optional long_description arg?) !> \param pw the pw data to output !> \param unit_nr the unit to output to -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_write(pw, unit_nr, error) + SUBROUTINE pw_write(pw, unit_nr) TYPE(pw_type), INTENT(in) :: pw INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_write', & routineP = moduleN//':'//routineN @@ -1819,12 +1786,10 @@ END SUBROUTINE pw_write !> \brief ... !> \param grida ... !> \param gridb ... -!> \param error ... !> \retval compat ... ! ***************************************************************************** - FUNCTION pw_compatible ( grida, gridb, error) RESULT ( compat ) + FUNCTION pw_compatible ( grida, gridb) RESULT ( compat ) TYPE(pw_grid_type), INTENT(IN) :: grida, gridb - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: compat CHARACTER(len=*), PARAMETER :: routineN = 'pw_compatible', & @@ -1849,16 +1814,14 @@ END FUNCTION pw_compatible !> only returns the real part of it ...... !> \param pw1 ... !> \param pw2 ... -!> \param error ... !> \retval integral_value ... !> \par History !> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case !> \author apsi ! ***************************************************************************** - FUNCTION pw_integral_ab ( pw1, pw2, error) RESULT ( integral_value ) + FUNCTION pw_integral_ab ( pw1, pw2) RESULT ( integral_value ) TYPE(pw_type), INTENT(IN) :: pw1, pw2 - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: integral_value CHARACTER(len=*), PARAMETER :: routineN = 'pw_integral_ab', & @@ -1926,13 +1889,11 @@ END FUNCTION pw_integral_ab !> \brief ... !> \param pw1 ... !> \param pw2 ... -!> \param error ... !> \retval integral_value ... ! ***************************************************************************** - FUNCTION pw_integral_a2b ( pw1, pw2, error) RESULT ( integral_value ) + FUNCTION pw_integral_a2b ( pw1, pw2) RESULT ( integral_value ) TYPE(pw_type), INTENT(IN) :: pw1, pw2 - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: integral_value CHARACTER(len=*), PARAMETER :: routineN = 'pw_integral_a2b', & @@ -1974,18 +1935,16 @@ END FUNCTION pw_integral_a2b !> \brief Calculate the structure factor for point r !> \param sf ... !> \param r ... -!> \param error ... !> \par History !> none !> \author JGH (05-May-2006) !> \note !> PW has to be in RECIPROCALSPACE and data in use is COMPLEXDATA1D ! ***************************************************************************** - SUBROUTINE pw_structure_factor ( sf, r, error) + SUBROUTINE pw_structure_factor ( sf, r) TYPE(pw_type), INTENT(INOUT) :: sf REAL(KIND=dp), DIMENSION(:), INTENT(in) :: r - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_structure_factor', & routineP = moduleN//':'//routineN @@ -1996,7 +1955,7 @@ SUBROUTINE pw_structure_factor ( sf, r, error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(sf%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(sf%ref_count>0,cp_failure_level,routineP,failure) flop = 0.0_dp IF ( sf%in_space == RECIPROCALSPACE .AND. & @@ -2026,15 +1985,13 @@ END SUBROUTINE pw_structure_factor !> \param fun ... !> \param isign ... !> \param oprt ... -!> \param error ... !> \retval total_fun ... ! ***************************************************************************** - FUNCTION pw_integrate_function(fun,isign,oprt,error) RESULT(total_fun) + FUNCTION pw_integrate_function(fun,isign,oprt) RESULT(total_fun) TYPE(pw_type), INTENT(IN) :: fun INTEGER, INTENT(IN), OPTIONAL :: isign CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: total_fun CHARACTER(len=*), PARAMETER :: routineN = 'pw_integrate_function', & diff --git a/src/pw/pw_poisson_methods.F b/src/pw/pw_poisson_methods.F index ceaa3270f9..1f1db2a35a 100644 --- a/src/pw/pw_poisson_methods.F +++ b/src/pw/pw_poisson_methods.F @@ -84,13 +84,11 @@ MODULE pw_poisson_methods !> and used to solve the poisson equation like the green function and !> all the things allocated in pw_poisson_rebuild !> \param poisson_env ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE pw_poisson_cleanup (poisson_env, error) + SUBROUTINE pw_poisson_cleanup (poisson_env) TYPE(pw_poisson_type), POINTER :: poisson_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_cleanup', & routineP = moduleN//':'//routineN @@ -99,14 +97,14 @@ SUBROUTINE pw_poisson_cleanup (poisson_env, error) TYPE(pw_pool_type), POINTER :: pw_pool failure=.FALSE. - CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,error,failure) - CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,failure) + CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(pw_pool) IF (ASSOCIATED(poisson_env%pw_pools)) THEN pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool END IF - CALL pw_green_release(poisson_env%green_fft,pw_pool=pw_pool,error=error) + CALL pw_green_release(poisson_env%green_fft,pw_pool=pw_pool) poisson_env%rebuild=.TRUE. END SUBROUTINE pw_poisson_cleanup @@ -114,13 +112,10 @@ END SUBROUTINE pw_poisson_cleanup ! ***************************************************************************** !> \brief checks if pw_poisson_rebuild has to be called and calls it if needed !> \param poisson_env the object to be checked -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pw_poisson_check(poisson_env,error) + SUBROUTINE pw_poisson_check(poisson_env) TYPE(pw_poisson_type), POINTER :: poisson_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_check', & routineP = moduleN//':'//routineN @@ -131,11 +126,11 @@ SUBROUTINE pw_poisson_check(poisson_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,error,failure) - CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(poisson_env%pw_pools),cp_failure_level,routineP,error,failure) - CPPrecondition(poisson_env%pw_level>=LBOUND(poisson_env%pw_pools,1),cp_failure_level,routineP,error,failure) - CPPrecondition(poisson_env%pw_level<=UBOUND(poisson_env%pw_pools,1),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,failure) + CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(poisson_env%pw_pools),cp_failure_level,routineP,failure) + CPPrecondition(poisson_env%pw_level>=LBOUND(poisson_env%pw_pools,1),cp_failure_level,routineP,failure) + CPPrecondition(poisson_env%pw_level<=UBOUND(poisson_env%pw_pools,1),cp_failure_level,routineP,failure) green => poisson_env%green_fft wavelet => poisson_env%wavelet rebuild=poisson_env%rebuild @@ -170,12 +165,12 @@ SUBROUTINE pw_poisson_check(poisson_env,error) CASE(pw_poisson_wavelet) rebuild=(poisson_env%parameters%wavelet_scf_type/=wavelet%itype_scf).OR.rebuild CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF IF (rebuild) THEN poisson_env%rebuild=.TRUE. - CALL pw_poisson_cleanup(poisson_env,error=error) + CALL pw_poisson_cleanup(poisson_env) END IF END SUBROUTINE pw_poisson_check @@ -183,16 +178,13 @@ END SUBROUTINE pw_poisson_check !> \brief rebuilds all the internal values needed to use the poisson solver !> \param poisson_env the environment to rebuild !> \param density ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> rebuilds if poisson_env%rebuild is true ! ***************************************************************************** - SUBROUTINE pw_poisson_rebuild(poisson_env,density,error) + SUBROUTINE pw_poisson_rebuild(poisson_env,density) TYPE(pw_poisson_type), POINTER :: poisson_env TYPE(pw_type), OPTIONAL, POINTER :: density - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_rebuild', & routineP = moduleN//':'//routineN @@ -203,39 +195,37 @@ SUBROUTINE pw_poisson_rebuild(poisson_env,density,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,error,failure) - CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(poisson_env%pw_pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,failure) + CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(poisson_env%pw_pools),cp_failure_level,routineP,failure) IF (poisson_env%rebuild) THEN - CALL pw_poisson_cleanup(poisson_env,error=error) + CALL pw_poisson_cleanup(poisson_env) SELECT CASE (poisson_env%parameters%solver) CASE (pw_poisson_periodic, pw_poisson_analytic, pw_poisson_mt, pw_poisson_multipole) CALL pw_green_create(poisson_env%green_fft,cell_hmat=poisson_env%cell_hmat,& pw_pool=poisson_env%pw_pools(poisson_env%pw_level)%pool,& poisson_params=poisson_env%parameters,& mt_super_ref_pw_grid=poisson_env%mt_super_ref_pw_grid,& - dct_pw_grid=poisson_env%dct_aux_pw_grid,& - error=error) + dct_pw_grid=poisson_env%dct_aux_pw_grid) CASE (pw_poisson_wavelet) - CPPrecondition(ASSOCIATED(density%pw_grid),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(density%pw_grid),cp_failure_level,routineP,failure) CALL ps_wavelet_create(poisson_env%parameters,poisson_env%wavelet,& - density%pw_grid,error) + density%pw_grid) CASE (pw_poisson_implicit) CALL pw_green_create(poisson_env%green_fft,cell_hmat=poisson_env%cell_hmat,& pw_pool=poisson_env%pw_pools(poisson_env%pw_level)%pool,& poisson_params=poisson_env%parameters,& mt_super_ref_pw_grid=poisson_env%mt_super_ref_pw_grid,& - dct_pw_grid=poisson_env%dct_pw_grid,& - error=error) + dct_pw_grid=poisson_env%dct_pw_grid) CALL ps_implicit_create(poisson_env%pw_pools(poisson_env%pw_level)%pool, & poisson_env%parameters, & poisson_env%dct_pw_grid, & poisson_env%dct_aux_pw_grid, & - poisson_env%green_fft, poisson_env%implicit_env, error) + poisson_env%green_fft, poisson_env%implicit_env) CASE (pw_poisson_none) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT poisson_env%rebuild=.FALSE. END IF @@ -255,13 +245,12 @@ END SUBROUTINE pw_poisson_rebuild !> \param dvhartree ... !> \param h_stress ... !> \param rho_core ... -!> \param error ... !> \par History !> JGH (13-Mar-2001) : completely revised !> \author apsi ! ***************************************************************************** SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& - dvhartree, h_stress, rho_core, error ) + dvhartree, h_stress, rho_core) TYPE(pw_poisson_type), POINTER :: poisson_env TYPE(pw_type), POINTER :: density @@ -271,7 +260,6 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& REAL(KIND=dp), DIMENSION(3, 3), & INTENT(OUT), OPTIONAL :: h_stress TYPE(pw_p_type), OPTIONAL, POINTER :: rho_core - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_solve', & routineP = moduleN//':'//routineN @@ -289,9 +277,9 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,error,failure) - CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL pw_poisson_rebuild(poisson_env,density,error=error) + CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,failure) + CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,failure) + CALL pw_poisson_rebuild(poisson_env,density) poisson_params => poisson_env%parameters @@ -302,14 +290,13 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& pw_pool => poisson_env%pw_pools(poisson_env%pw_level)%pool pw_grid => pw_pool % pw_grid IF ( PRESENT ( vhartree ) ) THEN - CPPrecondition(ASSOCIATED(vhartree),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(vhartree),cp_failure_level,routineP,failure) CALL cp_assert(pw_grid_compare(pw_pool%pw_grid,vhartree%pw_grid),cp_assertion_failed,& cp_failure_level,routineP,& - "vhartree has a different grid than the poisson solver",error,failure) + "vhartree has a different grid than the poisson solver",failure) END IF ! density in G space - CALL pw_pool_create_pw ( pw_pool, rhog, use_data=COMPLEXDATA1D,in_space = RECIPROCALSPACE,& - error=error) + CALL pw_pool_create_pw ( pw_pool, rhog, use_data=COMPLEXDATA1D,in_space = RECIPROCALSPACE) ! apply the greens function ng = SIZE ( pw_grid % gsq ) @@ -319,23 +306,23 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& SELECT CASE (poisson_env%green_fft%method) CASE (PERIODIC3D,ANALYTIC2D,ANALYTIC1D,ANALYTIC0D,MT2D,MT1D,MT0D,MULTIPOLE0D) - CALL pw_transfer(density,rhog,error=error) + CALL pw_transfer(density,rhog) IF (PRESENT(ehartree).AND.(.NOT.PRESENT(vhartree))) THEN CALL pw_pool_create_pw(pw_pool,tmpg,use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) - CALL pw_copy(rhog,tmpg,error=error) + in_space=RECIPROCALSPACE) + CALL pw_copy(rhog,tmpg) END IF DO ig=1,ng rhog%cc(ig) = rhog%cc(ig)*poisson_env%green_fft%influence_fn%cc(ig) END DO IF (PRESENT(vhartree)) THEN - CALL pw_transfer(rhog,vhartree,error=error) + CALL pw_transfer(rhog,vhartree) IF (PRESENT(ehartree)) THEN - ehartree = 0.5_dp*pw_integral_ab(density,vhartree,error=error) + ehartree = 0.5_dp*pw_integral_ab(density,vhartree) END IF ELSE IF (PRESENT(ehartree)) THEN - ehartree = 0.5_dp*pw_integral_ab(rhog,tmpg,error=error) - CALL pw_pool_give_back_pw(pw_pool,tmpg,error=error) + ehartree = 0.5_dp*pw_integral_ab(rhog,tmpg) + CALL pw_pool_give_back_pw(pw_pool,tmpg) END IF CASE (PS_IMPLICIT) @@ -344,62 +331,62 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& CALL dielectric_compute(poisson_env%implicit_env%dielectric, & poisson_env%diel_rs_grid,& poisson_env%pw_pools(poisson_env%pw_level)%pool, & - density, rho_core=rho_core%pw, error=error) + density, rho_core=rho_core%pw) END IF - CALL pw_pool_create_pw(pw_pool, rhor, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, vhartree_rs, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_transfer(density, rhor, error=error) + CALL pw_pool_create_pw(pw_pool, rhor, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, vhartree_rs, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_transfer(density, rhor) SELECT CASE (poisson_params%ps_implicit_params%boundary_condition) CASE (PERIODIC_BC) CALL implicit_poisson_solver_periodic(poisson_env, rhor, vhartree_rs, & - ehartree=ehartree, error=error) + ehartree=ehartree) CASE (NEUMANN_BC) CALL implicit_poisson_solver_neumann(poisson_env, rhor, vhartree_rs, & - ehartree=ehartree, error=error) + ehartree=ehartree) CASE (MIXED_PERIODIC_BC) CALL implicit_poisson_solver_mixed_periodic(poisson_env, rhor, vhartree_rs, & - ehartree=ehartree, error=error) + ehartree=ehartree) CASE (MIXED_BC) CALL implicit_poisson_solver_mixed(poisson_env, rhor, vhartree_rs, & - ehartree=ehartree, error=error) + ehartree=ehartree) END SELECT - IF (PRESENT(vhartree)) CALL pw_transfer(vhartree_rs, vhartree, error=error) - IF (PRESENT(dvhartree)) CALL pw_transfer(rhor, rhog, error=error) + IF (PRESENT(vhartree)) CALL pw_transfer(vhartree_rs, vhartree) + IF (PRESENT(dvhartree)) CALL pw_transfer(rhor, rhog) IF (PRESENT(h_stress)) THEN CALL cp_unimplemented_error(routineP, & - "No stress tensor is implemented for the implicit Poisson solver.",error) + "No stress tensor is implemented for the implicit Poisson solver.") END IF - CALL pw_pool_give_back_pw(pw_pool, rhor, error=error) - CALL pw_pool_give_back_pw(pw_pool, vhartree_rs, error=error) + CALL pw_pool_give_back_pw(pw_pool, rhor) + CALL pw_pool_give_back_pw(pw_pool, vhartree_rs) CASE DEFAULT CALL cp_unimplemented_error(routineP,"unknown poisson method "//& - cp_to_string(poisson_env%green_fft%method),error) + cp_to_string(poisson_env%green_fft%method)) END SELECT CASE (use_rs_grid) - CALL pw_pool_create_pw(pw_pool,rhor,use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_transfer(density,rhor,error=error) - CALL cp2k_distribution_to_z_slices(rhor,poisson_env%wavelet,rhor%pw_grid,error) - CALL ps_wavelet_solve(poisson_env%wavelet,rhor%pw_grid,error) - CALL z_slices_to_cp2k_distribution(rhor,poisson_env% wavelet,rhor%pw_grid,error) + CALL pw_pool_create_pw(pw_pool,rhor,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_transfer(density,rhor) + CALL cp2k_distribution_to_z_slices(rhor,poisson_env%wavelet,rhor%pw_grid) + CALL ps_wavelet_solve(poisson_env%wavelet,rhor%pw_grid) + CALL z_slices_to_cp2k_distribution(rhor,poisson_env% wavelet,rhor%pw_grid) IF (PRESENT(vhartree)) THEN - CALL pw_transfer(rhor,vhartree,error=error) + CALL pw_transfer(rhor,vhartree) IF (PRESENT(ehartree)) THEN - ehartree = 0.5_dp*pw_integral_ab(density,vhartree,error=error) + ehartree = 0.5_dp*pw_integral_ab(density,vhartree) END IF ELSE IF (PRESENT(ehartree)) THEN - ehartree = 0.5_dp*pw_integral_ab(density,rhor,error=error) + ehartree = 0.5_dp*pw_integral_ab(density,rhor) END IF IF (PRESENT(h_stress).OR.PRESENT(dvhartree)) THEN - CALL pw_transfer(rhor,rhog,error=error) + CALL pw_transfer(rhor,rhog) END IF - CALL pw_pool_give_back_pw(pw_pool,rhor,error=error) + CALL pw_pool_give_back_pw(pw_pool,rhor) END SELECT @@ -408,16 +395,16 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& DO i = 1, 3 NULLIFY(dvg(i)%pw) CALL pw_pool_create_pw (pw_pool, dvg ( i )%pw, use_data=COMPLEXDATA1D,& - in_space= RECIPROCALSPACE,error=error) + in_space= RECIPROCALSPACE) n = 0 n ( i ) = 1 - CALL pw_copy ( rhog, dvg ( i )%pw , error=error) - CALL pw_derive ( dvg ( i )%pw, n , error=error) + CALL pw_copy ( rhog, dvg ( i )%pw) + CALL pw_derive ( dvg ( i )%pw, n) END DO ! save the derivatives IF ( PRESENT ( dvhartree ) ) THEN DO i = 1, 3 - CALL pw_transfer ( dvg ( i )%pw, dvhartree ( i ) % pw , error=error) + CALL pw_transfer ( dvg ( i )%pw, dvhartree ( i ) % pw) END DO END IF ! Calculate the contribution to the stress tensor this is only the contribution from @@ -429,7 +416,7 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& h_stress ( alpha, alpha ) = ehartree DO beta = alpha, 3 h_stress ( alpha, beta ) = h_stress ( alpha, beta ) & - + ffa * pw_integral_ab ( dvg ( alpha )%pw, dvg ( beta )%pw , error=error) + + ffa * pw_integral_ab ( dvg ( alpha )%pw, dvg ( beta )%pw) h_stress ( beta, alpha ) = h_stress ( alpha, beta ) END DO END DO @@ -447,7 +434,7 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& alpha = poisson_env%green_fft%special_dimension h_stress(:,alpha) = 0.0_dp h_stress(alpha,:) = 0.0_dp - CALL cp_unimplemented_error(routineP,"Stress Tensor not tested for 2D systems.",error) + CALL cp_unimplemented_error(routineP,"Stress Tensor not tested for 2D systems.") CASE(ANALYTIC1D, MT1D) ! Zero the 2 non-periodic components DO alpha = 1, 3 @@ -459,13 +446,13 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& END IF END DO END DO - CALL cp_unimplemented_error(routineP,"Stress Tensor not tested for 1D systems.",error) + CALL cp_unimplemented_error(routineP,"Stress Tensor not tested for 1D systems.") CASE(ANALYTIC0D, MT0D, MULTIPOLE0D) ! Zero the full stress tensor h_stress = 0.0_dp CASE DEFAULT CALL cp_unimplemented_error(routineP,"unknown poisson method"//& - cp_to_string(poisson_env%green_fft%method),error) + cp_to_string(poisson_env%green_fft%method)) END SELECT CASE(use_rs_grid) @@ -479,10 +466,10 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& alpha = poisson_env%wavelet%special_dimension h_stress(:,alpha) = 0.0_dp h_stress(alpha,:) = 0.0_dp - CALL cp_unimplemented_error(routineP,"Stress Tensor not tested for 2D systems.",error) + CALL cp_unimplemented_error(routineP,"Stress Tensor not tested for 2D systems.") CASE(WAVELET1D) ! Zero the 2 non-periodic components - CALL cp_unimplemented_error(routineP,"WAVELET 1D not implemented!", error) + CALL cp_unimplemented_error(routineP,"WAVELET 1D not implemented!") CASE(WAVELET0D) ! Zero the full stress tensor h_stress = 0.0_dp @@ -492,11 +479,11 @@ SUBROUTINE pw_poisson_solve ( poisson_env, density, ehartree, vhartree,& END IF DO i = 1, 3 - CALL pw_pool_give_back_pw ( pw_pool, dvg ( i )%pw, error=error ) + CALL pw_pool_give_back_pw ( pw_pool, dvg ( i )%pw) END DO END IF - CALL pw_pool_give_back_pw (pw_pool, rhog, error=error ) + CALL pw_pool_give_back_pw (pw_pool, rhog) CALL timestop(handle) @@ -517,7 +504,6 @@ END SUBROUTINE pw_poisson_solve !> \param dct_pw_grid ... !> \param dct_aux_pw_grid ... !> \param force_rebuild ... -!> \param error ... !> \author fawzi !> \note !> Checks everything at the end. This means that after *each* call to @@ -525,7 +511,7 @@ END SUBROUTINE pw_poisson_solve !> you have to set everything at once. Change this behaviour? ! ***************************************************************************** SUBROUTINE pw_poisson_set ( poisson_env, cell_hmat, parameters, pw_pools, use_level, & - mt_super_ref_pw_grid, dct_pw_grid, dct_aux_pw_grid, force_rebuild, error ) + mt_super_ref_pw_grid, dct_pw_grid, dct_aux_pw_grid, force_rebuild) TYPE(pw_poisson_type), POINTER :: poisson_env REAL(KIND=dp), DIMENSION(3, 3), & @@ -538,7 +524,6 @@ SUBROUTINE pw_poisson_set ( poisson_env, cell_hmat, parameters, pw_pools, use_le TYPE(pw_grid_type), OPTIONAL, POINTER :: mt_super_ref_pw_grid, & dct_pw_grid, dct_aux_pw_grid LOGICAL, INTENT(in), OPTIONAL :: force_rebuild - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_set', & routineP = moduleN//':'//routineN @@ -555,13 +540,13 @@ SUBROUTINE pw_poisson_set ( poisson_env, cell_hmat, parameters, pw_pools, use_le IF (PRESENT(cell_hmat)) THEN IF (ANY(poisson_env%cell_hmat /= cell_hmat)) & - CALL pw_poisson_cleanup(poisson_env,error=error) + CALL pw_poisson_cleanup(poisson_env) poisson_env%cell_hmat(:,:) = cell_hmat(:,:) poisson_env%rebuild=.TRUE. END IF IF (PRESENT(pw_pools)) THEN - CPPrecondition(ASSOCIATED(pw_pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_pools),cp_failure_level,routineP,failure) same=.FALSE. IF (ASSOCIATED(poisson_env%pw_pools)) THEN same=SIZE(poisson_env%pw_pools)==SIZE(pw_pools) @@ -574,8 +559,8 @@ SUBROUTINE pw_poisson_set ( poisson_env, cell_hmat, parameters, pw_pools, use_le END IF IF (.NOT.same) THEN poisson_env%rebuild=.TRUE. - CALL pw_pools_copy(pw_pools,tmp_pools,error=error) - CALL pw_pools_dealloc(poisson_env%pw_pools,error=error) + CALL pw_pools_copy(pw_pools,tmp_pools) + CALL pw_pools_dealloc(poisson_env%pw_pools) poisson_env%pw_pools => tmp_pools END IF END IF @@ -584,25 +569,25 @@ SUBROUTINE pw_poisson_set ( poisson_env, cell_hmat, parameters, pw_pools, use_le IF (PRESENT(dct_pw_grid)) THEN IF (ASSOCIATED(dct_pw_grid)) THEN - CALL pw_grid_retain(dct_pw_grid,error=error) + CALL pw_grid_retain(dct_pw_grid) END IF - CALL pw_grid_release(poisson_env%dct_pw_grid,error=error) + CALL pw_grid_release(poisson_env%dct_pw_grid) poisson_env%dct_pw_grid => dct_pw_grid END IF IF (PRESENT(dct_aux_pw_grid)) THEN IF (ASSOCIATED(dct_aux_pw_grid)) THEN - CALL pw_grid_retain(dct_aux_pw_grid,error=error) + CALL pw_grid_retain(dct_aux_pw_grid) END IF - CALL pw_grid_release(poisson_env%dct_aux_pw_grid,error=error) + CALL pw_grid_release(poisson_env%dct_aux_pw_grid) poisson_env%dct_aux_pw_grid => dct_aux_pw_grid END IF IF (PRESENT(mt_super_ref_pw_grid)) THEN IF (ASSOCIATED(mt_super_ref_pw_grid)) THEN - CALL pw_grid_retain(mt_super_ref_pw_grid,error=error) + CALL pw_grid_retain(mt_super_ref_pw_grid) END IF - CALL pw_grid_release(poisson_env%mt_super_ref_pw_grid,error=error) + CALL pw_grid_release(poisson_env%mt_super_ref_pw_grid) poisson_env%mt_super_ref_pw_grid => mt_super_ref_pw_grid END IF @@ -610,7 +595,7 @@ SUBROUTINE pw_poisson_set ( poisson_env, cell_hmat, parameters, pw_pools, use_le IF (force_rebuild) poisson_env%rebuild=.TRUE. END IF - CALL pw_poisson_check(poisson_env,error=error) + CALL pw_poisson_check(poisson_env) CALL timestop(handle) diff --git a/src/pw/pw_poisson_types.F b/src/pw/pw_poisson_types.F index 130e6c7e94..d9bca2b427 100644 --- a/src/pw/pw_poisson_types.F +++ b/src/pw/pw_poisson_types.F @@ -187,11 +187,10 @@ MODULE pw_poisson_types !> \param pw_pool ... !> \param mt_super_ref_pw_grid ... !> \param dct_pw_grid ... -!> \param error ... !> \author Fawzi, based on previous functions by JGH and Teo ! ***************************************************************************** SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & - mt_super_ref_pw_grid, dct_pw_grid, error ) + mt_super_ref_pw_grid, dct_pw_grid) TYPE(greens_fn_type), POINTER :: green TYPE(pw_poisson_parameter_type), & INTENT(IN) :: poisson_params @@ -200,7 +199,6 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & TYPE(pw_pool_type), POINTER :: pw_pool TYPE(pw_grid_type), POINTER :: mt_super_ref_pw_grid, & dct_pw_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_green_create', & routineP = moduleN//':'//routineN @@ -216,9 +214,9 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & TYPE(pw_type), POINTER :: dct_gf, gf failure = .FALSE. - CPPrecondition(.NOT.(ASSOCIATED(green)),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.(ASSOCIATED(green)),cp_failure_level,routineP,failure) ALLOCATE(green, stat=stat) - CPPostcondition(stat == 0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_fatal_level,routineP,failure) green%p3m=.FALSE. green%special_dimension = 0 green%radius = 0.0_dp @@ -242,7 +240,7 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & NULLIFY (green%dct_influence_fn) NULLIFY (green%screen_fn) - !CPPrecondition(cell%orthorhombic,cp_failure_level,routineP,error,failure) + !CPPrecondition(cell%orthorhombic,cp_failure_level,routineP,failure) DO i=1,3 abc(i)=cell_hmat(i,i) END DO @@ -254,14 +252,14 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & IF (dim /= 3) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Illegal combination of periodicity and Poisson solver periodic3d",& - error=error,failure=failure) + failure=failure) END IF CASE (pw_poisson_multipole) green%method = MULTIPOLE0D IF (dim /= 0) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Illegal combination of periodicity and Poisson solver mulipole0d",& - error=error,failure=failure) + failure=failure) END IF CASE (pw_poisson_analytic) SELECT CASE (dim) @@ -284,7 +282,7 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & CASE (3) green%method = PERIODIC3D CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT CASE (pw_poisson_mt) green%MT_rel_cutoff = poisson_params%mt_rel_cutoff @@ -310,22 +308,22 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & CASE (3) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Illegal combination of periodicity and Poisson solver (MT)",& - error=error,failure=failure) + failure=failure) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT CASE (pw_poisson_implicit) green%method = PS_IMPLICIT CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "An unknown Poisson solver was specified",error,failure) + "An unknown Poisson solver was specified",failure) END SELECT ! allocate influence function,... SELECT CASE ( green % method ) CASE ( PERIODIC3D, ANALYTIC2D, ANALYTIC1D, ANALYTIC0D, MT2D, MT1D, MT0D, MULTIPOLE0D, PS_IMPLICIT ) CALL pw_pool_create_pw ( pw_pool, green % influence_fn,& - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE ,error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) IF (poisson_params%ewald_type==do_ewald_spme) THEN green%p3m = .TRUE. @@ -333,11 +331,11 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & green%p3m_alpha = poisson_params%ewald_alpha n=green % p3m_order ALLOCATE ( green%p3m_coeff ( -(n-1):n-1, 0:n-1 ), stat = stat ) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) CALL spme_coeff_calculate ( n, green%p3m_coeff ) CALL pw_pool_create_pw ( pw_pool, green % p3m_charge, use_data=REALDATA1D, & - in_space=RECIPROCALSPACE,error=error) - CALL influence_factor ( green ,error=error) + in_space=RECIPROCALSPACE) + CALL influence_factor ( green) CALL calc_p3m_charge(green) ELSE green % p3m = .FALSE. @@ -348,19 +346,19 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & CALL MTin_create_screen_fn(green%screen_fn,pw_pool=pw_pool,method=green%method,& alpha=green%MT_alpha, & special_dimension=green%special_dimension, slab_size=green%slab_size, & - super_ref_pw_grid=mt_super_ref_pw_grid, error=error) + super_ref_pw_grid=mt_super_ref_pw_grid) CASE(PS_IMPLICIT) IF ((poisson_params%ps_implicit_params%boundary_condition .EQ. MIXED_BC) .OR. & (poisson_params%ps_implicit_params%boundary_condition .EQ. NEUMANN_BC)) THEN - CALL pw_pool_create(pw_pool_xpndd, pw_grid=dct_pw_grid, error=error) + CALL pw_pool_create(pw_pool_xpndd, pw_grid=dct_pw_grid) CALL pw_pool_create_pw(pw_pool_xpndd, green%dct_influence_fn, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, error=error) - CALL pw_pool_release(pw_pool_xpndd, error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_pool_release(pw_pool_xpndd) END IF END SELECT CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! initialize influence function @@ -455,7 +453,7 @@ SUBROUTINE pw_green_create ( green, poisson_params, cell_hmat, pw_pool, & END IF CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE pw_green_create @@ -463,12 +461,10 @@ END SUBROUTINE pw_green_create ! ***************************************************************************** !> \brief retains the type !> \param gftype ... -!> \param error ... !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE pw_green_retain(gftype,error) + SUBROUTINE pw_green_retain(gftype) TYPE(greens_fn_type), POINTER :: gftype - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_green_retain', & routineP = moduleN//':'//routineN @@ -477,8 +473,8 @@ SUBROUTINE pw_green_retain(gftype,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(gftype),cp_failure_level,routineP,error,failure) - CPPrecondition(gftype%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gftype),cp_failure_level,routineP,failure) + CPPrecondition(gftype%ref_count>0,cp_failure_level,routineP,failure) gftype%ref_count=gftype%ref_count+1 END SUBROUTINE pw_green_retain @@ -486,16 +482,14 @@ END SUBROUTINE pw_green_retain !> \brief destroys the type (deallocates data) !> \param gftype ... !> \param pw_pool ... -!> \param error ... !> \par History !> none !> \author Joost VandeVondele !> Teodoro Laino ! ***************************************************************************** - SUBROUTINE pw_green_release ( gftype, pw_pool, error ) + SUBROUTINE pw_green_release ( gftype, pw_pool) TYPE(greens_fn_type), POINTER :: gftype TYPE(pw_pool_type), OPTIONAL, POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_green_release', & routineP = moduleN//':'//routineN @@ -505,32 +499,32 @@ SUBROUTINE pw_green_release ( gftype, pw_pool, error ) failure = .FALSE. IF (ASSOCIATED(gftype)) THEN - CPPrecondition(gftype%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(gftype%ref_count>0,cp_failure_level,routineP,failure) gftype%ref_count=gftype%ref_count-1 IF (gftype%ref_count==0) THEN can_give_back=PRESENT(pw_pool) IF (can_give_back) can_give_back=ASSOCIATED(pw_pool) IF (can_give_back) THEN CALL pw_pool_give_back_pw(pw_pool,gftype%influence_fn,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_pw(pw_pool,gftype%dct_influence_fn,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_pw(pw_pool,gftype%screen_fn,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_pw(pw_pool,gftype%p3m_charge,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) ELSE - CALL pw_release(gftype%influence_fn,error=error) - CALL pw_release(gftype%dct_influence_fn,error=error) - CALL pw_release(gftype%screen_fn,error=error) - CALL pw_release(gftype % p3m_charge, error=error) + CALL pw_release(gftype%influence_fn) + CALL pw_release(gftype%dct_influence_fn) + CALL pw_release(gftype%screen_fn) + CALL pw_release(gftype % p3m_charge) END IF IF (ASSOCIATED(gftype % p3m_bm2)) & DEALLOCATE ( gftype % p3m_bm2 ) IF (ASSOCIATED(gftype % p3m_coeff)) & DEALLOCATE ( gftype % p3m_coeff ) DEALLOCATE(gftype, stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) END IF END IF NULLIFY(gftype) @@ -540,14 +534,12 @@ END SUBROUTINE pw_green_release !> \brief Calculates the influence_factor for the !> SPME Green's function in reciprocal space''' !> \param gftype ... -!> \param error ... !> \par History !> none !> \author DH (29-Mar-2001) ! ***************************************************************************** - SUBROUTINE influence_factor ( gftype, error ) + SUBROUTINE influence_factor ( gftype) TYPE(greens_fn_type), POINTER :: gftype - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'influence_factor', & routineP = moduleN//':'//routineN @@ -561,8 +553,8 @@ SUBROUTINE influence_factor ( gftype, error ) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: m_assign failure=.FALSE. - CPPrecondition(ASSOCIATED(gftype),cp_failure_level,routineP,error,failure) - CPPrecondition(gftype%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gftype),cp_failure_level,routineP,failure) + CPPrecondition(gftype%ref_count>0,cp_failure_level,routineP,failure) n = gftype % p3m_order ! calculate the assignment function values @@ -573,16 +565,16 @@ SUBROUTINE influence_factor ( gftype, error ) IF (LBOUND(gftype % p3m_bm2,2)/=MINVAL(lb(:)).OR.& UBOUND(gftype % p3m_bm2,2)/=MAXVAL(ub(:))) THEN DEALLOCATE(gftype % p3m_bm2,stat=ierr) - CPPostcondition(ierr==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_fatal_level,routineP,failure) END IF END IF IF (.NOT.ASSOCIATED(gftype % p3m_bm2)) THEN ALLOCATE ( gftype % p3m_bm2 ( 3, MINVAL(lb(:)):MAXVAL(ub(:)) ), STAT = ierr ) - CPPostcondition(ierr==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_fatal_level,routineP,failure) END IF ALLOCATE ( m_assign ( 0:n-2 ), STAT = ierr ) - CPPostcondition(ierr==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_fatal_level,routineP,failure) m_assign = 0.0_dp DO k = 0, n-2 j = -(n-1) + 2 * k @@ -610,7 +602,7 @@ SUBROUTINE influence_factor ( gftype, error ) END DO DEALLOCATE ( m_assign, STAT = ierr ) - CPPostconditionNoFail(ierr==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(ierr==0,cp_warning_level,routineP) END SUBROUTINE influence_factor ! ***************************************************************************** @@ -651,15 +643,13 @@ END SUBROUTINE calc_p3m_charge !> pw_poisson_solver !> Call pw_poisson_release when you have finished !> \param poisson_env ... -!> \param error ... !> \par History !> none !> \author JGH (12-Mar-2001) ! ***************************************************************************** - SUBROUTINE pw_poisson_create ( poisson_env, error ) + SUBROUTINE pw_poisson_create ( poisson_env) TYPE(pw_poisson_type), POINTER :: poisson_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_create', & routineP = moduleN//':'//routineN @@ -669,9 +659,9 @@ SUBROUTINE pw_poisson_create ( poisson_env, error ) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(poisson_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(poisson_env),cp_failure_level,routineP,failure) ALLOCATE(poisson_env,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) last_poisson_id=last_poisson_id+1 poisson_env%id_nr=last_poisson_id poisson_env%ref_count=1 @@ -693,13 +683,10 @@ END SUBROUTINE pw_poisson_create ! ***************************************************************************** !> \brief retains the pw_poisson_env !> \param poisson_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pw_poisson_retain(poisson_env,error) + SUBROUTINE pw_poisson_retain(poisson_env) TYPE(pw_poisson_type), POINTER :: poisson_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_retain', & routineP = moduleN//':'//routineN @@ -708,23 +695,21 @@ SUBROUTINE pw_poisson_retain(poisson_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(poisson_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(poisson_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(poisson_env%ref_count>0,cp_failure_level,routineP) poisson_env%ref_count=poisson_env%ref_count+1 END SUBROUTINE pw_poisson_retain ! ***************************************************************************** !> \brief releases the poisson solver !> \param poisson_env ... -!> \param error ... !> \par History !> none !> \author fawzi (11.2002) ! ***************************************************************************** - SUBROUTINE pw_poisson_release ( poisson_env, error) + SUBROUTINE pw_poisson_release ( poisson_env) TYPE(pw_poisson_type), POINTER :: poisson_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_release', & routineP = moduleN//':'//routineN @@ -734,22 +719,22 @@ SUBROUTINE pw_poisson_release ( poisson_env, error) failure=.FALSE. IF (ASSOCIATED(poisson_env)) THEN - CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(poisson_env%ref_count>0,cp_failure_level,routineP,failure) poisson_env%ref_count=poisson_env%ref_count-1 IF (poisson_env%ref_count==0) THEN IF (ASSOCIATED(poisson_env%pw_pools)) THEN - CALL pw_pools_dealloc(poisson_env%pw_pools,error=error) + CALL pw_pools_dealloc(poisson_env%pw_pools) END IF - CALL pw_green_release(poisson_env%green_fft,error=error) - CALL pw_grid_release(poisson_env%mt_super_ref_pw_grid,error=error) - CALL ps_wavelet_release(poisson_env%wavelet,error=error) - CALL ps_implicit_release(poisson_env%implicit_env,error=error) - CALL pw_grid_release(poisson_env%dct_pw_grid,error=error) - CALL pw_grid_release(poisson_env%dct_aux_pw_grid,error=error) - CALL rs_grid_release(poisson_env%diel_rs_grid,error=error) + CALL pw_green_release(poisson_env%green_fft) + CALL pw_grid_release(poisson_env%mt_super_ref_pw_grid) + CALL ps_wavelet_release(poisson_env%wavelet) + CALL ps_implicit_release(poisson_env%implicit_env) + CALL pw_grid_release(poisson_env%dct_pw_grid) + CALL pw_grid_release(poisson_env%dct_aux_pw_grid) + CALL rs_grid_release(poisson_env%diel_rs_grid) DEALLOCATE(poisson_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF diff --git a/src/pw/pw_pool_types.F b/src/pw/pw_pool_types.F index d58858128d..e006c9c10d 100644 --- a/src/pw/pw_pool_types.F +++ b/src/pw/pw_pool_types.F @@ -110,17 +110,14 @@ MODULE pw_pool_types !> \param pool the pool to create !> \param pw_grid the grid that is used to create the pw !> \param max_cache ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_pool_create(pool, pw_grid, max_cache, error) + SUBROUTINE pw_pool_create(pool, pw_grid, max_cache) TYPE(pw_pool_type), POINTER :: pool TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, OPTIONAL :: max_cache - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_create', & routineP = moduleN//':'//routineN @@ -130,12 +127,12 @@ SUBROUTINE pw_pool_create(pool, pw_grid, max_cache, error) TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ALLOCATE(pool, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pool%pw_grid => pw_grid - CALL pw_grid_retain(pw_grid,error=error) + CALL pw_grid_retain(pw_grid) last_pw_pool_id_nr=last_pw_pool_id_nr+1 pool%id_nr=last_pw_pool_id_nr pool%ref_count=1 @@ -154,15 +151,12 @@ END SUBROUTINE pw_pool_create ! ***************************************************************************** !> \brief retains the pool (see cp2k/doc/ReferenceCounting.html) !> \param pool the pool to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_pool_retain(pool,error) + SUBROUTINE pw_pool_retain(pool) TYPE(pw_pool_type), POINTER :: pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_retain', & routineP = moduleN//':'//routineN @@ -171,10 +165,10 @@ SUBROUTINE pw_pool_retain(pool,error) TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) pool%ref_count=pool%ref_count+1 IF (debug_this_module) THEN @@ -188,15 +182,12 @@ END SUBROUTINE pw_pool_retain ! ***************************************************************************** !> \brief deallocates all the cached grids !> \param pool the pool to flush -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_pool_flush_cache(pool, error) + SUBROUTINE pw_pool_flush_cache(pool) TYPE(pw_pool_type), POINTER :: pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_flush_cache', & routineP = moduleN//':'//routineN @@ -212,10 +203,10 @@ SUBROUTINE pw_pool_flush_cache(pool, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(iterator,array_iterator,pw_el,array_att) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (debug_this_module) THEN WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& fmt="(' *** pw_pool ',i4,' is flushing the cache')") pool%id_nr @@ -224,63 +215,60 @@ SUBROUTINE pw_pool_flush_cache(pool, error) iterator => pool%real1d_pw DO - IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT - CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) + IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el)) EXIT + CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,failure) pw_el%ref_count=1 - CALL pw_release(pw_el,error=error) + CALL pw_release(pw_el) END DO - CALL cp_sll_pw_dealloc(pool%real1d_pw,error=error) + CALL cp_sll_pw_dealloc(pool%real1d_pw) iterator => pool%real3d_pw DO - IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT - CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) + IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el)) EXIT + CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,failure) pw_el%ref_count=1 - CALL pw_release(pw_el, error=error) + CALL pw_release(pw_el) END DO - CALL cp_sll_pw_dealloc(pool%real3d_pw,error=error) + CALL cp_sll_pw_dealloc(pool%real3d_pw) iterator => pool%complex1d_pw DO - IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT - CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) + IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el)) EXIT + CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,failure) pw_el%ref_count=1 - CALL pw_release(pw_el, error=error) + CALL pw_release(pw_el) END DO - CALL cp_sll_pw_dealloc(pool%complex1d_pw,error=error) + CALL cp_sll_pw_dealloc(pool%complex1d_pw) iterator => pool%complex3d_pw DO - IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT - CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) + IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el)) EXIT + CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,failure) pw_el%ref_count=1 - CALL pw_release(pw_el, error=error) + CALL pw_release(pw_el) END DO - CALL cp_sll_pw_dealloc(pool%complex3d_pw,error=error) + CALL cp_sll_pw_dealloc(pool%complex3d_pw) array_iterator => pool%real3d_array DO - IF (.NOT.cp_sll_3d_r_next(array_iterator,el_att=array_att,& - error=error)) EXIT + IF (.NOT.cp_sll_3d_r_next(array_iterator,el_att=array_att)& + ) EXIT DEALLOCATE(array_att,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END DO - CALL cp_sll_3d_r_dealloc(pool%real3d_array,error=error) + CALL cp_sll_3d_r_dealloc(pool%real3d_array) END SUBROUTINE pw_pool_flush_cache ! ***************************************************************************** !> \brief releases the given pool (see cp2k/doc/ReferenceCounting.html) !> \param pool the pool to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_pool_release(pool,error) + SUBROUTINE pw_pool_release(pool) TYPE(pw_pool_type), POINTER :: pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_release', & routineP = moduleN//':'//routineN @@ -290,10 +278,10 @@ SUBROUTINE pw_pool_release(pool,error) TYPE(cp_logger_type), POINTER :: logger failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(pool)) THEN - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) pool%ref_count=pool%ref_count-1 IF (debug_this_module) THEN WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& @@ -303,13 +291,13 @@ SUBROUTINE pw_pool_release(pool,error) END IF IF (pool%ref_count==0) THEN pool%ref_count=1 - CALL pw_pool_flush_cache(pool,error=error) + CALL pw_pool_flush_cache(pool) pool%ref_count=0 - CPPrecondition(ASSOCIATED(pool%pw_grid),cp_warning_level,routineP,error,failure) - CALL pw_grid_release(pool%pw_grid,error=error) + CPPrecondition(ASSOCIATED(pool%pw_grid),cp_warning_level,routineP,failure) + CALL pw_grid_release(pool%pw_grid) DEALLOCATE(pool,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF NULLIFY(pool) @@ -318,7 +306,6 @@ END SUBROUTINE pw_pool_release ! ***************************************************************************** !> \brief tries to pop an element from the given list (no error on failure) !> \param list the list to pop -!> \param error ... !> \retval res ... !> \par History !> 08.2002 created [fawzi] @@ -326,14 +313,13 @@ END SUBROUTINE pw_pool_release !> \note !> private function ! ***************************************************************************** - FUNCTION try_pop(list,error) RESULT(res) + FUNCTION try_pop(list) RESULT(res) TYPE(cp_sll_pw_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error TYPE(pw_type), POINTER :: res IF (ASSOCIATED(list)) THEN - res => cp_sll_pw_get_first_el(list,error=error) - CALL cp_sll_pw_rm_first_el(list,error=error) + res => cp_sll_pw_get_first_el(list) + CALL cp_sll_pw_rm_first_el(list) ELSE NULLIFY(res) END IF @@ -346,18 +332,15 @@ END FUNCTION try_pop !> \param use_data which data it uses: REALDATA1D, COMPLEXDATA1D, !> REALDATA3D, COMPLEXDATA3D !> \param in_space in which space it is: REALSPACE, RECIPROCALSPACE -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_pool_create_pw(pool, pw, use_data, in_space, error) + SUBROUTINE pw_pool_create_pw(pool, pw, use_data, in_space) TYPE(pw_pool_type), POINTER :: pool TYPE(pw_type), POINTER :: pw INTEGER, INTENT(in) :: use_data INTEGER, INTENT(in), OPTIONAL :: in_space - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_create_pw', & routineP = moduleN//':'//routineN @@ -373,33 +356,33 @@ SUBROUTINE pw_pool_create_pw(pool, pw, use_data, in_space, error) CALL timeset(routineN,handle) NULLIFY(pw) NULLIFY(cr3d_ptr) - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) SELECT CASE(use_data) CASE (REALDATA1D) - pw => try_pop(pool%real1d_pw,error=error) + pw => try_pop(pool%real1d_pw) CASE (REALDATA3D) - pw => try_pop(pool%real3d_pw,error=error) + pw => try_pop(pool%real3d_pw) IF (.NOT.ASSOCIATED(pw)) THEN IF (ASSOCIATED(pool%real3d_array)) THEN - cr3d_ptr => cp_sll_3d_r_get_first_el(pool%real3d_array,error=error) - CALL cp_sll_3d_r_rm_first_el(pool%real3d_array,error=error) + cr3d_ptr => cp_sll_3d_r_get_first_el(pool%real3d_array) + CALL cp_sll_3d_r_rm_first_el(pool%real3d_array) END IF END IF CASE (COMPLEXDATA1D) - pw => try_pop(pool%complex1d_pw,error=error) + pw => try_pop(pool%complex1d_pw) CASE (COMPLEXDATA3D) - pw => try_pop(pool%complex3d_pw,error=error) + pw => try_pop(pool%complex3d_pw) CASE default ! unknown use_data - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (.NOT.ASSOCIATED(pw)) THEN CALL pw_create(pw, pool%pw_grid, use_data=use_data, & - cr3d_ptr=cr3d_ptr,error=error) + cr3d_ptr=cr3d_ptr) IF (debug_this_module) THEN IF (ASSOCIATED(cr3d_ptr)) THEN WRITE(unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& @@ -412,11 +395,11 @@ SUBROUTINE pw_pool_create_pw(pool, pw, use_data, in_space, error) END IF CALL pw_write(& unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& - pw=pw, error=error) + pw=pw) CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) END IF ELSE - CPPrecondition(pw%ref_count==0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count==0,cp_failure_level,routineP,failure) pw%ref_count=1 IF (debug_this_module) THEN WRITE(unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& @@ -424,7 +407,7 @@ SUBROUTINE pw_pool_create_pw(pool, pw, use_data, in_space, error) pool%id_nr,pw%id_nr CALL pw_write(& unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& - pw=pw, error=error) + pw=pw) CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) END IF END IF @@ -443,17 +426,14 @@ END SUBROUTINE pw_pool_create_pw !> \param accept_non_compatible if non compatible pw should be accepted !> (they will be destroied). Defaults to false (and thus stops with !> an error) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_pool_give_back_pw(pool, pw, accept_non_compatible, error) + SUBROUTINE pw_pool_give_back_pw(pool, pw, accept_non_compatible) TYPE(pw_pool_type), POINTER :: pool TYPE(pw_type), POINTER :: pw LOGICAL, INTENT(in), OPTIONAL :: accept_non_compatible - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_give_back_pw', & routineP = moduleN//':'//routineN @@ -465,25 +445,25 @@ SUBROUTINE pw_pool_give_back_pw(pool, pw, accept_non_compatible, error) failure=.FALSE. my_accept_non_compatible=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (PRESENT(accept_non_compatible)) my_accept_non_compatible=accept_non_compatible CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,failure) + CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(pw)) THEN - CPPrecondition(my_accept_non_compatible,cp_warning_level,routineP,error,failure) + CPPrecondition(my_accept_non_compatible,cp_warning_level,routineP,failure) failure=.TRUE. END IF IF (.NOT. failure) THEN - CPPrecondition(pw%ref_count==1,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count==1,cp_failure_level,routineP,failure) IF (.NOT.pw_grid_compare(pw%pw_grid,pool%pw_grid)) THEN IF (debug_this_module) THEN WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& fmt="(' *** pw_pool ',i4,' giving back incompatible pw ',i4)")& pool%id_nr, pw%id_nr CALL pw_write(unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& - pw=pw,error=error) + pw=pw) CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) END IF @@ -491,8 +471,8 @@ SUBROUTINE pw_pool_give_back_pw(pool, pw, accept_non_compatible, error) cp_failure_level, cp_assertion_failed, routineP,& "pool cannot reuse pw of another grid "//& CPSourceFileRef,& - error=error,failure=failure) - CALL pw_release(pw,error=error) + failure=failure) + CALL pw_release(pw) failure=.TRUE. END IF END IF @@ -504,43 +484,41 @@ SUBROUTINE pw_pool_give_back_pw(pool, pw, accept_non_compatible, error) fmt="(' *** pw_pool ',i4,' giving back pw ',i4)")& pool%id_nr, pw%id_nr CALL pw_write(unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& - pw=pw,error=error) + pw=pw) CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) END IF SELECT CASE(pw%in_use) CASE(REALDATA1D) - IF (cp_sll_pw_get_length(pool%real1d_pw,error=error) REALDATA3D, allocating it if none is present in the pool !> \param pw_pool the pool that caches the cr3d !> \param cr3d the pointer that will contain the array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE pw_pool_create_cr3d(pw_pool,cr3d,error) +SUBROUTINE pw_pool_create_cr3d(pw_pool,cr3d) TYPE(pw_pool_type), POINTER :: pw_pool REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: cr3d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_create_cr3d', & routineP = moduleN//':'//routineN @@ -623,22 +596,22 @@ SUBROUTINE pw_pool_create_cr3d(pw_pool,cr3d,error) failure=.FALSE. NULLIFY(pw) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_pool%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(cr3d),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) + CPPrecondition(pw_pool%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(cr3d),cp_failure_level,routineP,failure) IF (ASSOCIATED(pw_pool%real3d_array)) THEN - cr3d => cp_sll_3d_r_get_first_el(pw_pool%real3d_array,error=error) - CALL cp_sll_3d_r_rm_first_el(pw_pool%real3d_array,error=error) + cr3d => cp_sll_3d_r_get_first_el(pw_pool%real3d_array) + CALL cp_sll_3d_r_rm_first_el(pw_pool%real3d_array) ELSE - pw => try_pop(pw_pool%real3d_pw,error=error) + pw => try_pop(pw_pool%real3d_pw) IF (ASSOCIATED(pw)) THEN - CPPrecondition(pw%ref_count==0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw%ref_count==0,cp_failure_level,routineP,failure) pw%ref_count=1 cr3d => pw%cr3d NULLIFY(pw%cr3d) - CALL pw_release(pw, error=error) + CALL pw_release(pw) END IF END IF IF (.NOT.ASSOCIATED(cr3d)) THEN @@ -646,7 +619,7 @@ SUBROUTINE pw_pool_create_cr3d(pw_pool,cr3d,error) pw_pool%pw_grid%bounds_local(1,2):pw_pool%pw_grid%bounds_local(2,2),& pw_pool%pw_grid%bounds_local(1,3):pw_pool%pw_grid%bounds_local(2,3)),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (debug_this_module) THEN WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& fmt="(' *** pw_pool ',i4,' created cr3d')") pw_pool%id_nr @@ -666,18 +639,15 @@ END SUBROUTINE pw_pool_create_cr3d !> \param cr3d the pointer that will contain the array !> \param accept_non_compatible if true deallocates the non compatible !> arrays passed in, if false (the default) stops with an error -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE pw_pool_give_back_cr3d(pw_pool,cr3d,accept_non_compatible,error) +SUBROUTINE pw_pool_give_back_cr3d(pw_pool,cr3d,accept_non_compatible) TYPE(pw_pool_type), POINTER :: pw_pool REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: cr3d LOGICAL, INTENT(in), OPTIONAL :: accept_non_compatible - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_give_back_cr3d', & routineP = moduleN//':'//routineN @@ -689,11 +659,11 @@ SUBROUTINE pw_pool_give_back_cr3d(pw_pool,cr3d,accept_non_compatible,error) failure=.FALSE. my_accept_non_compatible=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (PRESENT(accept_non_compatible)) my_accept_non_compatible=accept_non_compatible - CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_pool%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) + CPPrecondition(pw_pool%ref_count>0,cp_failure_level,routineP,failure) IF (ASSOCIATED(cr3d)) THEN IF (debug_this_module) THEN WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& @@ -704,17 +674,16 @@ SUBROUTINE pw_pool_give_back_cr3d(pw_pool,cr3d,accept_non_compatible,error) pw_pool%pw_grid%bounds_local(2,:)==UBOUND(cr3d), & pw_pool%pw_grid%bounds_local(2,:)=LBOUND(cr3d) ) ) - CPPrecondition(compatible.OR.my_accept_non_compatible,cp_failure_level,routineP,error,failure) + CPPrecondition(compatible.OR.my_accept_non_compatible,cp_failure_level,routineP,failure) IF (compatible) THEN - IF (cp_sll_3d_r_get_length(pw_pool%real3d_array,error=error) \param use_data which data it uses: REALDATA1D, COMPLEXDATA1D, !> REALDATA3D, COMPLEXDATA3D !> \param in_space ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2004 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_pools_create_pws(pools, pws, use_data, in_space, error) +SUBROUTINE pw_pools_create_pws(pools, pws, use_data, in_space) TYPE(pw_pool_p_type), DIMENSION(:), & POINTER :: pools TYPE(pw_p_type), DIMENSION(:), POINTER :: pws INTEGER, INTENT(in) :: use_data INTEGER, INTENT(in), OPTIONAL :: in_space - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_create_pws', & routineP = moduleN//':'//routineN @@ -767,13 +733,13 @@ SUBROUTINE pw_pools_create_pws(pools, pws, use_data, in_space, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,failure) ALLOCATE(pws(SIZE(pools)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(pools) NULLIFY(pws(i)%pw) CALL pw_pool_create_pw(pools(i)%pool,pws(i)%pw,use_data,& - in_space=in_space,error=error) + in_space=in_space) END DO END SUBROUTINE pw_pools_create_pws @@ -781,17 +747,14 @@ END SUBROUTINE pw_pools_create_pws !> \brief returns the pw part of the coefficents into the pools !> \param pools the pools that will cache the pws %pw !> \param pws the coefficents to give back -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_pools_give_back_pws(pools, pws, error) +SUBROUTINE pw_pools_give_back_pws(pools, pws) TYPE(pw_pool_p_type), DIMENSION(:), & POINTER :: pools TYPE(pw_p_type), DIMENSION(:), POINTER :: pws - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_give_back_pws', & routineP = moduleN//':'//routineN @@ -801,30 +764,27 @@ SUBROUTINE pw_pools_give_back_pws(pools, pws, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pws),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(pws)==SIZE(pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pws),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(pws)==SIZE(pools),cp_failure_level,routineP,failure) DO i=1,SIZE(pools) - CALL pw_pool_give_back_pw(pools(i)%pool,pws(i)%pw,error=error) + CALL pw_pool_give_back_pw(pools(i)%pool,pws(i)%pw) END DO DEALLOCATE(pws,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END SUBROUTINE pw_pools_give_back_pws ! ***************************************************************************** !> \brief copies a multigrid pool, the underlying pools are shared !> \param source_pools the pools to copy !> \param target_pools will hold the copy of the pools -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_pools_copy(source_pools, target_pools, error) +SUBROUTINE pw_pools_copy(source_pools, target_pools) TYPE(pw_pool_p_type), DIMENSION(:), & POINTER :: source_pools, target_pools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_copy', & routineP = moduleN//':'//routineN @@ -834,12 +794,12 @@ SUBROUTINE pw_pools_copy(source_pools, target_pools, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(source_pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(source_pools),cp_failure_level,routineP,failure) ALLOCATE(target_pools(SIZE(source_pools)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(source_pools) target_pools(i)%pool => source_pools(i)%pool - CALL pw_pool_retain(source_pools(i)%pool, error=error) + CALL pw_pool_retain(source_pools(i)%pool) END DO END SUBROUTINE pw_pools_copy @@ -847,16 +807,13 @@ END SUBROUTINE pw_pools_copy !> \brief deallocates the given pools (releasing each of the underlying !> pools) !> \param pools the pols to deallocate -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_pools_dealloc(pools,error) +SUBROUTINE pw_pools_dealloc(pools) TYPE(pw_pool_p_type), DIMENSION(:), & POINTER :: pools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_dealloc', & routineP = moduleN//':'//routineN @@ -868,10 +825,10 @@ SUBROUTINE pw_pools_dealloc(pools,error) IF (ASSOCIATED(pools)) THEN DO i=1,SIZE(pools) - CALL pw_pool_release(pools(i)%pool, error=error) + CALL pw_pool_release(pools(i)%pool) END DO DEALLOCATE(pools,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF NULLIFY(pools) END SUBROUTINE pw_pools_dealloc @@ -879,16 +836,13 @@ END SUBROUTINE pw_pools_dealloc ! ***************************************************************************** !> \brief deallocates all the cached grids !> \param pools the pools to flush -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_pools_flush_cache(pools,error) +SUBROUTINE pw_pools_flush_cache(pools) TYPE(pw_pool_p_type), DIMENSION(:), & POINTER :: pools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_flush_cache', & routineP = moduleN//':'//routineN @@ -898,9 +852,9 @@ SUBROUTINE pw_pools_flush_cache(pools,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,failure) DO i=1,SIZE(pools) - CALL pw_pool_flush_cache(pools(i)%pool,error=error) + CALL pw_pool_flush_cache(pools(i)%pool) END DO END SUBROUTINE pw_pools_flush_cache @@ -908,16 +862,13 @@ END SUBROUTINE pw_pools_flush_cache !> \brief writes the actual contents of the pw_pool !> \param pw_pool ... !> \param unit_nr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE pw_pool_write(pw_pool,unit_nr,error) +SUBROUTINE pw_pool_write(pw_pool,unit_nr) TYPE(pw_pool_type), POINTER :: pw_pool INTEGER :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_write', & routineP = moduleN//':'//routineN @@ -935,28 +886,28 @@ SUBROUTINE pw_pool_write(pw_pool,unit_nr,error) WRITE (unit=unit_nr, fmt="('real1d_pw=(')",advance="no") iter => pw_pool%real1d_pw - DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) + DO WHILE(cp_sll_pw_next(iter,el_att=pw_att)) WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr END DO WRITE (unit=unit_nr, fmt="('),')") WRITE (unit=unit_nr, fmt="('real3d_pw=(')",advance="no") iter => pw_pool%real3d_pw - DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) + DO WHILE(cp_sll_pw_next(iter,el_att=pw_att)) WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr END DO WRITE (unit=unit_nr, fmt="('),')") WRITE (unit=unit_nr, fmt="('complex1d_pw=(')",advance="no") iter => pw_pool%complex1d_pw - DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) + DO WHILE(cp_sll_pw_next(iter,el_att=pw_att)) WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr END DO WRITE (unit=unit_nr, fmt="('),')") WRITE (unit=unit_nr, fmt="('complex3d_pw=(')",advance="no") iter => pw_pool%complex3d_pw - DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) + DO WHILE(cp_sll_pw_next(iter,el_att=pw_att)) WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr END DO WRITE (unit=unit_nr, fmt="(')')") diff --git a/src/pw/pw_spline_utils.F b/src/pw/pw_spline_utils.F index e5a7097a94..c4bdb1ea55 100644 --- a/src/pw/pw_spline_utils.F +++ b/src/pw/pw_spline_utils.F @@ -127,17 +127,14 @@ MODULE pw_spline_utils !> interpolates the given values !> \param spline_g on entry the FFT of the values to interpolate as cc, !> will contain the FFT of the coefficents of the spline -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed !> \note !> does not work with spherical cutoff ! ***************************************************************************** - SUBROUTINE pw_spline2_interpolate_values_g(spline_g,error) + SUBROUTINE pw_spline2_interpolate_values_g(spline_g) TYPE(pw_type), POINTER :: spline_g - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'pw_spline2_interpolate_values_g', & @@ -156,15 +153,15 @@ SUBROUTINE pw_spline2_interpolate_values_g(spline_g,error) n_tot(1:3) = spline_g%pw_grid%npts (1:3) gbo = spline_g%pw_grid%bounds - CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,failure) ALLOCATE(cosIVals(gbo(1,1):gbo(2,1)),cosJVals(gbo(1,2):gbo(2,2)),& cosKVals(gbo(1,3):gbo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeff=twopi/n_tot(1) !$omp parallel do private(i) default(none) shared(cosIVals,coeff,gbo) @@ -198,7 +195,7 @@ SUBROUTINE pw_spline2_interpolate_values_g(spline_g,error) END DO DEALLOCATE(cosIVals, cosJVals, cosKVals, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE pw_spline2_interpolate_values_g @@ -208,8 +205,6 @@ END SUBROUTINE pw_spline2_interpolate_values_g !> interpolates the given values !> \param spline_g on entry the FFT of the values to interpolate as cc, !> will contain the FFT of the coefficents of the spline -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed @@ -218,9 +213,8 @@ END SUBROUTINE pw_spline2_interpolate_values_g !> stupid distribution for cos calculation, it should calculate only the !> needed cos, and avoid the mp_sum ! ***************************************************************************** - SUBROUTINE pw_spline3_interpolate_values_g(spline_g,error) + SUBROUTINE pw_spline3_interpolate_values_g(spline_g) TYPE(pw_type), POINTER :: spline_g - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'pw_spline3_interpolate_values_g', & @@ -239,16 +233,16 @@ SUBROUTINE pw_spline3_interpolate_values_g(spline_g,error) n_tot(1:3) = spline_g%pw_grid%npts (1:3) gbo = spline_g%pw_grid%bounds - CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,failure) ALLOCATE(cosIVals(gbo(1,1):gbo(2,1)),& cosJVals(gbo(1,2):gbo(2,2)),& cosKVals(gbo(1,3):gbo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeff=twopi/n_tot(1) !$omp parallel do private(i) default(none) shared(cosIVals,coeff,gbo) @@ -288,7 +282,7 @@ SUBROUTINE pw_spline3_interpolate_values_g(spline_g,error) END DO DEALLOCATE(cosIVals, cosJVals, cosKVals, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE pw_spline3_interpolate_values_g @@ -299,15 +293,12 @@ END SUBROUTINE pw_spline3_interpolate_values_g !> pw_spline_interpolate_values_g) !> \param spline_g on entry the FFT of the coefficents of the spline as cr3d, !> will contain the FFT of the values of the spline -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_spline2_evaluate_values_g(spline_g,error) + SUBROUTINE pw_spline2_evaluate_values_g(spline_g) TYPE(pw_type), POINTER :: spline_g - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline2_evaluate_values_g', & routineP = moduleN//':'//routineN @@ -328,15 +319,15 @@ SUBROUTINE pw_spline2_evaluate_values_g(spline_g,error) gbo = spline_g%pw_grid%bounds inv64=1.0_dp/64.0_dp - CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,failure) ALLOCATE(cosIVals(gbo(1,1):gbo(2,1)),cosJVals(gbo(1,2):gbo(2,2)), & cosKVals(gbo(1,3):gbo(2,3)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeff=twopi/n_tot(1) !$omp parallel do default(none) private(i) shared(gbo,cosIVals,coeff) @@ -368,7 +359,7 @@ SUBROUTINE pw_spline2_evaluate_values_g(spline_g,error) spline_g%cc(ii)=spline_g%cc(ii)*coeff END DO DEALLOCATE(cosIVals, cosJVals, cosKVals, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE pw_spline2_evaluate_values_g @@ -382,8 +373,6 @@ END SUBROUTINE pw_spline2_evaluate_values_g !> element, coeffs(2) the coeff of the 6 element with distance 1, !> coeff(3) the coeff of the 12 elements at distance sqrt(2), !> coeff(4) the coeff of the 8 elements at distance sqrt(3). -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2003 created [fawzi] !> \author Fawzi Mohamed @@ -393,10 +382,9 @@ END SUBROUTINE pw_spline2_evaluate_values_g !> is equivalent to pw_spline3_evaluate_values_g, with !> coeff=(/ 27._dp/64._dp, 9._dp/128._dp, 3._dp/256._dp, 1._dp/512._dp /) ! ***************************************************************************** - SUBROUTINE pw_nn_smear_g(spline_g,coeffs,error) + SUBROUTINE pw_nn_smear_g(spline_g,coeffs) TYPE(pw_type), POINTER :: spline_g REAL(KIND=dp), DIMENSION(4), INTENT(in) :: coeffs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_nn_smear_g', & routineP = moduleN//':'//routineN @@ -422,15 +410,15 @@ SUBROUTINE pw_nn_smear_g(spline_g,coeffs,error) r_coeffs(3)=r_coeffs(3)*4.0_dp r_coeffs(4)=r_coeffs(4)*8.0_dp - CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,failure) ALLOCATE(cosIVals(gbo(1,1):gbo(2,1)),cosJVals(gbo(1,2):gbo(2,2)), & cosKVals(gbo(1,3):gbo(2,3)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeff=twopi/n_tot(1) !$omp parallel do private(i) default(none) shared(gbo,coeff,cosIVals) @@ -462,7 +450,7 @@ SUBROUTINE pw_nn_smear_g(spline_g,coeffs,error) spline_g%cc(ii)=spline_g%cc(ii)*coeff END DO DEALLOCATE(cosIVals, cosJVals, cosKVals, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE pw_nn_smear_g @@ -473,15 +461,12 @@ END SUBROUTINE pw_nn_smear_g !> pw_spline_interpolate_values_g) !> \param spline_g on entry the FFT of the values to interpolate as cc3d, !> will contain the FFT of the coefficents of the spline -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_spline3_evaluate_values_g(spline_g,error) + SUBROUTINE pw_spline3_evaluate_values_g(spline_g) TYPE(pw_type), POINTER :: spline_g - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline3_evaluate_values_g', & routineP = moduleN//':'//routineN @@ -502,15 +487,15 @@ SUBROUTINE pw_spline3_evaluate_values_g(spline_g,error) gbo = spline_g%pw_grid%bounds inv27=1.0_dp/27.0_dp - CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.spline_g%pw_grid%spherical,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,failure) ALLOCATE(cosIVals(gbo(1,1):gbo(2,1)),cosJVals(gbo(1,2):gbo(2,2)), & cosKVals(gbo(1,3):gbo(2,3)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeff=twopi/n_tot(1) !$omp parallel do private(i) default(none) shared(coeff,cosIVals,gbo) @@ -549,7 +534,7 @@ SUBROUTINE pw_spline3_evaluate_values_g(spline_g,error) spline_g%cc(ii)=spline_g%cc(ii)*coeff END DO DEALLOCATE(cosIVals, cosJVals, cosKVals, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE pw_spline3_evaluate_values_g @@ -560,17 +545,14 @@ END SUBROUTINE pw_spline3_evaluate_values_g !> \param transpose if true applies the transpose of the map (defaults to !> false) !> \param scale a scaling factor (defaults to 1.0) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE pw_spline_scale_deriv(deriv_vals_r,transpose,scale,error) + SUBROUTINE pw_spline_scale_deriv(deriv_vals_r,transpose,scale) TYPE(pw_p_type), DIMENSION(3) :: deriv_vals_r LOGICAL, INTENT(in), OPTIONAL :: transpose REAL(KIND=dp), INTENT(in), OPTIONAL :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline_scale_deriv', & routineP = moduleN//':'//routineN @@ -656,18 +638,15 @@ END SUBROUTINE pw_spline_scale_deriv !> \param spline_g on entry the FFT of the coefficents of the spline !> will contain the FFT of the derivative !> \param idir direction of the derivative -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed !> \note !> the distance between gridpoints is assumed to be 1 ! ***************************************************************************** - SUBROUTINE pw_spline3_deriv_g(spline_g,idir,error) + SUBROUTINE pw_spline3_deriv_g(spline_g,idir) TYPE(pw_type), POINTER :: spline_g INTEGER, INTENT(in) :: idir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline3_deriv_g', & routineP = moduleN//':'//routineN @@ -688,16 +667,16 @@ SUBROUTINE pw_spline3_deriv_g(spline_g,idir,error) bo = spline_g%pw_grid%bounds_local gbo = spline_g%pw_grid%bounds - CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(.not.spline_g%pw_grid%spherical,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(.not.spline_g%pw_grid%spherical,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,failure) ALLOCATE(csIVals(gbo(1,1):gbo(2,1)),& csJVals(gbo(1,2):gbo(2,2)),& csKVals(gbo(1,3):gbo(2,3)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeff=twopi/n_tot(1) IF (idir==1) THEN @@ -791,7 +770,7 @@ SUBROUTINE pw_spline3_deriv_g(spline_g,idir,error) END SELECT DEALLOCATE(csIVals, csJVals, csKVals, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE pw_spline3_deriv_g @@ -802,18 +781,15 @@ END SUBROUTINE pw_spline3_deriv_g !> \param spline_g on entry the FFT of the coefficents of the spline !> will contain the FFT of the derivative !> \param idir direction of the derivative -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2003 created [fawzi] !> \author Fawzi Mohamed !> \note !> the distance between gridpoints is assumed to be 1 ! ***************************************************************************** - SUBROUTINE pw_spline2_deriv_g(spline_g,idir,error) + SUBROUTINE pw_spline2_deriv_g(spline_g,idir) TYPE(pw_type), POINTER :: spline_g INTEGER, INTENT(in) :: idir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline2_deriv_g', & routineP = moduleN//':'//routineN @@ -833,15 +809,15 @@ SUBROUTINE pw_spline2_deriv_g(spline_g,idir,error) n_tot(1:3) = spline_g%pw_grid%npts (1:3) bo = spline_g%pw_grid%bounds - CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(.not.spline_g%pw_grid%spherical,cp_failure_level,routineP,error,failure) - CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_g),cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_use==COMPLEXDATA1D,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%in_space==RECIPROCALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(.not.spline_g%pw_grid%spherical,cp_failure_level,routineP,failure) + CPPrecondition(spline_g%pw_grid%grid_span==FULLSPACE,cp_failure_level,routineP,failure) ALLOCATE(csIVals(bo(1,1):bo(2,1)),csJVals(bo(1,2):bo(2,2)),& csKVals(bo(1,3):bo(2,3)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coeff=twopi/n_tot(1) IF (idir==1) THEN @@ -935,7 +911,7 @@ SUBROUTINE pw_spline2_deriv_g(spline_g,idir,error) END SELECT DEALLOCATE(csIVals, csJVals, csKVals, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE pw_spline2_deriv_g @@ -1175,11 +1151,9 @@ END SUBROUTINE pw_compose_stripe2 !> \param pw_in pw to be able to get the needed meta data about in_val and !> out_val !> \param bo boundaries of in_val and out_val -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE pw_nn_compose_r_work(weights,in_val,out_val,pw_in,bo,error) +SUBROUTINE pw_nn_compose_r_work(weights,in_val,out_val,pw_in,bo) REAL(kind=dp), DIMENSION(0:2, 0:2, 0:2) :: weights INTEGER, DIMENSION(2, 3) :: bo TYPE(pw_type), POINTER :: pw_in @@ -1189,7 +1163,6 @@ SUBROUTINE pw_nn_compose_r_work(weights,in_val,out_val,pw_in,bo,error) REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, & 1), bo(1, 2):bo(2, 2), bo(1, 3):bo(2, & 3)), INTENT(in) :: in_val - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_nn_compose_r_work', & routineP = moduleN//':'//routineN @@ -1217,7 +1190,7 @@ SUBROUTINE pw_nn_compose_r_work(weights,in_val,out_val,pw_in,bo,error) ALLOCATE(l_boundary(bo(1,2):bo(2,2),bo(1,3):bo(2,3)),& u_boundary(bo(1,2):bo(2,2),bo(1,3):bo(2,3)),& tmp(bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp(:,:)=pw_in%cr3d(bo(2,1),:,:) CALL mp_sendrecv(tmp,pw_in%pw_grid%para%pos_of_x(& gbo(1,1)+MODULO(bo(2,1)+1-gbo(1,1),gbo(2,1)-gbo(1,1)+1)),& @@ -1231,7 +1204,7 @@ SUBROUTINE pw_nn_compose_r_work(weights,in_val,out_val,pw_in,bo,error) gbo(1,1)+MODULO(bo(2,1)+1-gbo(1,1),gbo(2,1)-gbo(1,1)+1)),& pw_in%pw_grid%para%group) DEALLOCATE(tmp,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF !$omp parallel do default(none) private(k,kw,myk,j,jw,myj,in_val_f,& @@ -1262,7 +1235,7 @@ SUBROUTINE pw_nn_compose_r_work(weights,in_val,out_val,pw_in,bo,error) END DO IF (has_boundary) THEN DEALLOCATE(l_boundary,u_boundary,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE pw_nn_compose_r_work @@ -1271,16 +1244,13 @@ END SUBROUTINE pw_nn_compose_r_work !> \param weights a 3x3x3 array with the linear operator !> \param pw_in the argument for the linear operator !> \param pw_out place where the value of the linear oprator should be added -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> has specialized versions for derivative operator (with central values==0) ! ***************************************************************************** -SUBROUTINE pw_nn_compose_r(weights, pw_in, pw_out,error) +SUBROUTINE pw_nn_compose_r(weights, pw_in, pw_out) REAL(kind=dp), DIMENSION(0:2, 0:2, 0:2) :: weights TYPE(pw_type), POINTER :: pw_in, pw_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_nn_compose_r', & routineP = moduleN//':'//routineN @@ -1290,20 +1260,19 @@ SUBROUTINE pw_nn_compose_r(weights, pw_in, pw_out,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(pw_in),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_in%in_space==REALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(pw_in%in_use==REALDATA3D,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_out),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_out%in_space==REALSPACE,cp_failure_level,routineP,error,failure) - CPPrecondition(pw_out%in_use==REALDATA3D,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_in),cp_failure_level,routineP,failure) + CPPrecondition(pw_in%in_space==REALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(pw_in%in_use==REALDATA3D,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_out),cp_failure_level,routineP,failure) + CPPrecondition(pw_out%in_space==REALSPACE,cp_failure_level,routineP,failure) + CPPrecondition(pw_out%in_use==REALDATA3D,cp_failure_level,routineP,failure) IF (.NOT.ALL(pw_in%pw_grid%bounds_local(:,2:3) == pw_in%pw_grid%bounds(:,2:3))) THEN CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& - "wrong pw distribution",error,failure) + "wrong pw distribution",failure) END IF CALL pw_nn_compose_r_work(weights=weights,in_val=pw_in%cr3d,& - out_val=pw_out%cr3d,pw_in=pw_in,bo=pw_in%pw_grid%bounds_local,& - error=error) + out_val=pw_out%cr3d,pw_in=pw_in,bo=pw_in%pw_grid%bounds_local) CALL timestop(handle) END SUBROUTINE pw_nn_compose_r @@ -1316,8 +1285,6 @@ END SUBROUTINE pw_nn_compose_r !> element, coeffs(2) the coeff of the 6 element with distance 1, !> coeff(3) the coeff of the 12 elements at distance sqrt(2), !> coeff(4) the coeff of the 8 elements at distance sqrt(3). -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed !> \note !> does not normalize the smear to 1. @@ -1325,10 +1292,9 @@ END SUBROUTINE pw_nn_compose_r !> is equivalent to pw_spline3_evaluate_values_g, with !> coeff=(/ 27._dp/64._dp, 9._dp/128._dp, 3._dp/256._dp, 1._dp/512._dp /) ! ***************************************************************************** - SUBROUTINE pw_nn_smear_r(pw_in,pw_out,coeffs,error) + SUBROUTINE pw_nn_smear_r(pw_in,pw_out,coeffs) TYPE(pw_type), POINTER :: pw_in, pw_out REAL(KIND=dp), DIMENSION(4), INTENT(in) :: coeffs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_nn_smear_r', & routineP = moduleN//':'//routineN @@ -1345,8 +1311,7 @@ SUBROUTINE pw_nn_smear_r(pw_in,pw_out,coeffs,error) END DO END DO - CALL pw_nn_compose_r(weights=weights,pw_in=pw_in,pw_out=pw_out,& - error=error) + CALL pw_nn_compose_r(weights=weights,pw_in=pw_in,pw_out=pw_out) END SUBROUTINE pw_nn_smear_r ! ***************************************************************************** @@ -1366,8 +1331,6 @@ END SUBROUTINE pw_nn_smear_r !> element, coeffs(2) the coeff of the 4 element with distance 1, !> coeff(3) the coeff of the 4 elements at distance sqrt(2) !> \param idir ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed !> \note !> with coeff=(/ 2.0_dp/9.0_dp, 1.0_dp/18.0_dp, 1.0_dp/72.0_dp /) @@ -1376,11 +1339,10 @@ END SUBROUTINE pw_nn_smear_r !> to pw_spline2_deriv_r !> coeff=(/ 25._dp/72._dp, 5._dp/144, 1._dp/288._dp /) ! ***************************************************************************** - SUBROUTINE pw_nn_deriv_r(pw_in,pw_out,coeffs,idir,error) + SUBROUTINE pw_nn_deriv_r(pw_in,pw_out,coeffs,idir) TYPE(pw_type), POINTER :: pw_in, pw_out REAL(KIND=dp), DIMENSION(3), INTENT(in) :: coeffs INTEGER :: idir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_nn_deriv_r', & routineP = moduleN//':'//routineN @@ -1404,7 +1366,7 @@ SUBROUTINE pw_nn_deriv_r(pw_in,pw_out,coeffs,idir,error) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"invalid idir ("//TRIM(cp_to_string(idir))//")",& - error,failure) + failure) END SELECT IF (idirVal==0) THEN weights(i,j,k)=0.0_dp @@ -1415,8 +1377,7 @@ SUBROUTINE pw_nn_deriv_r(pw_in,pw_out,coeffs,idir,error) END DO END DO - CALL pw_nn_compose_r(weights=weights,pw_in=pw_in,pw_out=pw_out,& - error=error) + CALL pw_nn_compose_r(weights=weights,pw_in=pw_in,pw_out=pw_out) END SUBROUTINE pw_nn_deriv_r ! ***************************************************************************** @@ -1452,8 +1413,6 @@ END SUBROUTINE pw_nn_deriv_r !> (used if pbc is false) !> \param pbc if periodic boundary conditions should be applied !> \param safe_computation ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> coarse looping is continuos, I did not check if keeping the fine looping @@ -1466,7 +1425,7 @@ END SUBROUTINE pw_nn_deriv_r !> probabily irrelevant because it is not critical) [fawzi]. ! ***************************************************************************** SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& - weights_1d,w_border0,w_border1,pbc,safe_computation,error) + weights_1d,w_border0,w_border1,pbc,safe_computation) TYPE(pw_type), POINTER :: coarse_coeffs_pw, & fine_values_pw REAL(kind=dp), DIMENSION(4), INTENT(in) :: weights_1d @@ -1474,7 +1433,6 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& REAL(kind=dp), DIMENSION(3), INTENT(in) :: w_border1 LOGICAL, INTENT(in) :: pbc LOGICAL, INTENT(in), OPTIONAL :: safe_computation - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_coarse2fine', & routineP = moduleN//':'//routineN @@ -1508,7 +1466,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& CALL mp_comm_compare(coarse_coeffs_pw%pw_grid%para%group,& fine_values_pw%pw_grid%para%group,ii) IF (ii>1) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF my_coarse_bo=coarse_coeffs_pw%pw_grid%bounds_local coarse_gbo=coarse_coeffs_pw%pw_grid%bounds @@ -1536,11 +1494,11 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& has_i_lbound=(fine_gbo(1,1)/=fine_bo(1,1)).or.pbc.and.is_split IF (pbc) THEN - CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+1+f_shift),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,failure) + CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+1+f_shift),cp_failure_level,routineP,failure) ELSE - CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+f_shift),cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+f_shift),cp_failure_level,routineP,failure) + CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,failure) END IF coarse_coeffs => coarse_coeffs_pw%cr3d @@ -1557,7 +1515,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& ALLOCATE(send_size(0:n_procs-1),send_offset(0:n_procs-1),& sent_size(0:n_procs-1),rcv_size(0:n_procs-1), & rcv_offset(0:n_procs-1),real_rcv_size(0:n_procs-1), stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ! ** rcv size count @@ -1639,7 +1597,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& send_tot_size=send_tot_size+send_size(ip) END DO ALLOCATE(send_buf(0:send_tot_size-1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) rcv_tot_size=0 DO ip=0,n_procs-1 @@ -1651,10 +1609,10 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& cp_failure_level,cp_assertion_failed,routineP,& "Error calculating rcv_tot_size "//& CPSourceFileRef,& - error,failure) + failure) END IF ALLOCATE(rcv_buf(0:rcv_tot_size-1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ! ** fill send buffer @@ -1748,11 +1706,11 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& END DO END IF - CPPostcondition(ALL(sent_size(:n_procs-2)==send_offset(1:)),cp_failure_level,routineP,error,failure) - CPPostcondition(sent_size(n_procs-1)==send_tot_size,cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(sent_size(:n_procs-2)==send_offset(1:)),cp_failure_level,routineP,failure) + CPPostcondition(sent_size(n_procs-1)==send_tot_size,cp_failure_level,routineP,failure) ! test send/rcv sizes CALL mp_alltoall(send_size,real_rcv_size,1,coarse_coeffs_pw%pw_grid%para%group) - CPAssert(ALL(real_rcv_size==rcv_size),cp_failure_level,routineP,error,failure) + CPAssert(ALL(real_rcv_size==rcv_size),cp_failure_level,routineP,failure) ! all2all CALL mp_alltoall( sb=send_buf, scount=send_size, sdispl=send_offset,& rb=rcv_buf, rcount=rcv_size, rdispl=rcv_offset, & @@ -1764,7 +1722,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& ALLOCATE(coarse_coeffs(coarse_bo(1,1):coarse_bo(2,1),& coarse_bo(1,2):coarse_bo(2,2),& coarse_bo(1,3):coarse_bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) my_lb=MAX(coarse_gbo(1,1),coarse_bo(1,1)) my_ub=MIN(coarse_gbo(2,1),coarse_bo(2,1)) @@ -1823,14 +1781,14 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& sent_size(p_old)=sent_size(p_old)+coarse_slice_size END DO - CPPostcondition(ALL(sent_size(0:n_procs-2)==rcv_offset(1:)),cp_failure_level,routineP,error,failure) - CPPostcondition(sent_size(n_procs-1)==rcv_tot_size,cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(sent_size(0:n_procs-2)==rcv_offset(1:)),cp_failure_level,routineP,failure) + CPPostcondition(sent_size(n_procs-1)==rcv_tot_size,cp_failure_level,routineP,failure) ! dealloc DEALLOCATE(send_size,send_offset, rcv_size, rcv_offset, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(send_buf,rcv_buf,real_rcv_size,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle2) END IF @@ -1859,7 +1817,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& CASE(-3) wk=w_border1(3) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CYCLE END SELECT ELSE @@ -1871,7 +1829,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& CASE(-1) wk=w_border1(1) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CYCLE END SELECT END IF @@ -2007,7 +1965,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& cp_assertion_failed,routineN,& "unexpected start index "//& TRIM(cp_to_string(coarse_bo(1,1)))//" "//& - TRIM(cp_to_string(fi)),error,failure) + TRIM(cp_to_string(fi)),failure) END IF END IF fi=fi+1 @@ -2016,7 +1974,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& ww0(1)*v0+ww0(2)*v1+& ww0(3)*v2 ELSE - CPPrecondition(fi+1==fine_bo(1,1),cp_failure_level,routineP,error,failure) + CPPrecondition(fi+1==fine_bo(1,1),cp_failure_level,routineP,failure) END IF ! CALL timestop(handle2) ! CALL timeset(routineN//"_core",handle2) @@ -2232,7 +2190,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& fine_values(fi,fj,fk)=fine_values(fi,fj,fk)+& w_border0*wj*v2 END IF - CPPostcondition(fi==fine_bo(2,1),cp_failure_level,routineP,error,failure) + CPPostcondition(fi==fine_bo(2,1),cp_failure_level,routineP,failure) END IF ! CALL timestop(handle2) END DO @@ -2242,7 +2200,7 @@ SUBROUTINE add_coarse2fine(coarse_coeffs_pw,fine_values_pw,& IF (is_split) THEN DEALLOCATE(coarse_coeffs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF CALL timestop(handle) END SUBROUTINE add_coarse2fine @@ -2279,14 +2237,12 @@ END SUBROUTINE add_coarse2fine !> (w_border1(1) is the weight of the coefficent at the border) !> \param pbc ... !> \param safe_computation ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> see coarse2fine for some relevant notes ! ***************************************************************************** SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& - weights_1d,w_border0,w_border1,pbc,safe_computation,error) + weights_1d,w_border0,w_border1,pbc,safe_computation) TYPE(pw_type), POINTER :: fine_values_pw, & coarse_coeffs_pw REAL(kind=dp), DIMENSION(4), INTENT(in) :: weights_1d @@ -2294,7 +2250,6 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& REAL(kind=dp), DIMENSION(3), INTENT(in) :: w_border1 LOGICAL, INTENT(in) :: pbc LOGICAL, INTENT(in), OPTIONAL :: safe_computation - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_fine2coarse', & routineP = moduleN//':'//routineN @@ -2349,19 +2304,19 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& has_i_lbound=(fine_gbo(1,1)/=fine_bo(1,1)).or.pbc.and.is_split IF (pbc) THEN - CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+f_shift+1),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,failure) + CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+f_shift+1),cp_failure_level,routineP,failure) ELSE - CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+f_shift),cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(fine_gbo(2,:)==2*coarse_gbo(2,:)+f_shift),cp_failure_level,routineP,failure) + CPPrecondition(ALL(fine_gbo(1,:)==2*coarse_gbo(1,:)+f_shift),cp_failure_level,routineP,failure) END IF - CPPrecondition(coarse_gbo(2,1)-coarse_gbo(1,2)>1,cp_failure_level,routineP,error,failure) + CPPrecondition(coarse_gbo(2,1)-coarse_gbo(1,2)>1,cp_failure_level,routineP,failure) local_data=is_split ! ANY(coarse_bo/=my_coarse_bo) IF (local_data) THEN ALLOCATE(coarse_coeffs(coarse_bo(1,1):coarse_bo(2,1),& coarse_bo(1,2):coarse_bo(2,2),& coarse_bo(1,3):coarse_bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) coarse_coeffs=0._dp ELSE coarse_coeffs => coarse_coeffs_pw%cr3d @@ -2397,7 +2352,7 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& CASE(-3) wk=w_border1(3) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CYCLE END SELECT ELSE @@ -2409,7 +2364,7 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& CASE(-1) wk=w_border1(1) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CYCLE END SELECT END IF @@ -2439,7 +2394,7 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& CASE(-3) wj=w_border1(3)*wk CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CYCLE END SELECT ELSE @@ -2451,7 +2406,7 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& CASE(3) wj=w_border1(3)*wk CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CYCLE END SELECT END IF @@ -2593,11 +2548,11 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "FLOOR((fine_bo(2,1)-f_shift(1))/2._dp)-coarse_bo(1,1)>=4",& - error,failure) + failure) END IF rest_b=MODULO(FLOOR((fine_bo(2,1)-f_shift(1))/2._dp)-coarse_bo(1,1)-6,4) i=FLOOR((fine_bo(2,1)-f_shift(1))/2._dp)-3-rest_b+4 - CPPrecondition(fi==(i-2)*2+f_shift(1),cp_failure_level,routineP,error,failure) + CPPrecondition(fi==(i-2)*2+f_shift(1),cp_failure_level,routineP,failure) IF (rest_b>0) THEN fi=fi+1 vv0=fine_values(fi,fj,fk) @@ -2799,7 +2754,7 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& +wj*(w_border1(1)*vv0+w_border0*vv1) END IF END IF - CPPostcondition(fi==fine_bo(2,1),cp_failure_level,routineP,error,failure) + CPPostcondition(fi==fine_bo(2,1),cp_failure_level,routineP,failure) END IF END DO END DO @@ -2816,7 +2771,7 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& sent_size(0:n_procs-1),rcv_size(0:n_procs-1), & rcv_offset(0:n_procs-1), pp_lb(0:n_procs-1),& pp_ub(0:n_procs-1),real_rcv_size(0:n_procs-1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ! ** send size count @@ -2889,9 +2844,9 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& cp_failure_level,cp_assertion_failed,routineP,& "Error calculating send_tot_size "//& CPSourceFileRef,& - error,failure) + failure) ALLOCATE(send_buf(0:send_tot_size-1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) rcv_tot_size=0 DO ip=0,n_procs-1 @@ -2899,7 +2854,7 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& rcv_tot_size=rcv_tot_size+rcv_size(ip) END DO ALLOCATE(rcv_buf(0:rcv_tot_size-1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ! ** fill send buffer @@ -2920,26 +2875,26 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& cp_failure_level,cp_assertion_failed,routineP,& "error 1 filling send buffer "//& CPSourceFileRef,& - error,failure) + failure) CALL cp_assert(sent_size(n_procs-1)==send_tot_size,& cp_failure_level,cp_assertion_failed,routineP,& "error 2 filling send buffer "//& CPSourceFileRef,& - error,failure) + failure) IF (local_data) THEN DEALLOCATE(coarse_coeffs,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ELSE NULLIFY(coarse_coeffs) END IF - CPPostcondition(ALL(sent_size(:n_procs-2)==send_offset(1:)),cp_failure_level,routineP,error,failure) - CPPostcondition(sent_size(n_procs-1)==send_tot_size,cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(sent_size(:n_procs-2)==send_offset(1:)),cp_failure_level,routineP,failure) + CPPostcondition(sent_size(n_procs-1)==send_tot_size,cp_failure_level,routineP,failure) ! test send/rcv sizes CALL mp_alltoall(send_size,real_rcv_size,1,coarse_coeffs_pw%pw_grid%para%group) - CPAssert(ALL(real_rcv_size==rcv_size),cp_failure_level,routineP,error,failure) + CPAssert(ALL(real_rcv_size==rcv_size),cp_failure_level,routineP,failure) ! all2all CALL mp_alltoall( sb=send_buf, scount=send_size, sdispl=send_offset,& rb=rcv_buf, rcount=rcv_size, rdispl=rcv_offset, & @@ -2995,23 +2950,23 @@ SUBROUTINE add_fine2coarse(fine_values_pw,coarse_coeffs_pw,& cp_failure_level,cp_assertion_failed,routineP,& "error 1 handling the rcv buffer "//& CPSourceFileRef,& - error,failure) + failure) CALL cp_assert(sent_size(n_procs-1)==rcv_tot_size,& cp_failure_level,cp_assertion_failed,routineP,& "error 2 handling the rcv buffer "//& CPSourceFileRef,& - error,failure) + failure) ! dealloc DEALLOCATE(send_size,send_offset, rcv_size, rcv_offset, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(send_buf,rcv_buf,real_rcv_size, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(pp_ub,pp_lb,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle2) ELSE - CPPostcondition(.NOT.local_data,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.local_data,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -3025,17 +2980,14 @@ END SUBROUTINE add_fine2coarse !> precondition !> \param pbc if periodic boundary conditions should be applied !> \param transpose ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE pw_spline_precond_create(preconditioner,precond_kind,& - pool,pbc,transpose,error) + pool,pbc,transpose) TYPE(pw_spline_precond_type), POINTER :: preconditioner INTEGER, INTENT(in) :: precond_kind TYPE(pw_pool_type), POINTER :: pool LOGICAL, INTENT(in) :: pbc, transpose - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline_precond_create', & routineP = moduleN//':'//routineN @@ -3046,7 +2998,7 @@ SUBROUTINE pw_spline_precond_create(preconditioner,precond_kind,& failure=.FALSE. ALLOCATE(preconditioner,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) last_precond_id=last_precond_id+1 preconditioner%id_nr=last_precond_id preconditioner%ref_count=1 @@ -3054,8 +3006,8 @@ SUBROUTINE pw_spline_precond_create(preconditioner,precond_kind,& preconditioner%pool => pool preconditioner%pbc=pbc preconditioner%transpose=transpose - CALL pw_pool_retain(pool,error=error) - CALL pw_spline_precond_set_kind(preconditioner,precond_kind,error=error) + CALL pw_pool_retain(pool) + CALL pw_spline_precond_set_kind(preconditioner,precond_kind) END SUBROUTINE pw_spline_precond_create ! ***************************************************************************** @@ -3064,16 +3016,13 @@ END SUBROUTINE pw_spline_precond_create !> \param precond_kind the new kind of preconditioner to use !> \param pbc ... !> \param transpose ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE pw_spline_precond_set_kind(preconditioner,precond_kind,pbc,& - transpose,error) + transpose) TYPE(pw_spline_precond_type), POINTER :: preconditioner INTEGER, INTENT(in) :: precond_kind LOGICAL, INTENT(in), OPTIONAL :: pbc, transpose - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline_precond_set_kind', & routineP = moduleN//':'//routineN @@ -3083,8 +3032,8 @@ SUBROUTINE pw_spline_precond_set_kind(preconditioner,precond_kind,pbc,& failure=.FALSE. - CPPrecondition(ASSOCIATED(preconditioner),cp_failure_level,routineP,error,failure) - CPPrecondition(preconditioner%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(preconditioner),cp_failure_level,routineP,failure) + CPPrecondition(preconditioner%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(transpose)) preconditioner%transpose=transpose do_3d_coeff=.FALSE. preconditioner%kind=precond_kind @@ -3123,7 +3072,7 @@ SUBROUTINE pw_spline_precond_set_kind(preconditioner,precond_kind,pbc,& preconditioner%normalize=.FALSE. do_3d_coeff=.TRUE. CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (do_3d_coeff) THEN s=1._dp @@ -3158,13 +3107,10 @@ END SUBROUTINE pw_spline_precond_set_kind ! ***************************************************************************** !> \brief retains the preconditioner !> \param preconditioner the preconditioner to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pw_spline_precond_retain(preconditioner,error) + SUBROUTINE pw_spline_precond_retain(preconditioner) TYPE(pw_spline_precond_type), POINTER :: preconditioner - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline_precond_retain', & routineP = moduleN//':'//routineN @@ -3173,21 +3119,18 @@ SUBROUTINE pw_spline_precond_retain(preconditioner,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(preconditioner),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(preconditioner%ref_count>1,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(preconditioner),cp_failure_level,routineP,failure) + CPPreconditionNoFail(preconditioner%ref_count>1,cp_failure_level,routineP) preconditioner%ref_count=preconditioner%ref_count+1 END SUBROUTINE pw_spline_precond_retain ! ***************************************************************************** !> \brief releases the preconditioner !> \param preconditioner the preconditioner to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pw_spline_precond_release(preconditioner,error) + SUBROUTINE pw_spline_precond_release(preconditioner) TYPE(pw_spline_precond_type), POINTER :: preconditioner - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline_precond_release', & routineP = moduleN//':'//routineN @@ -3198,12 +3141,12 @@ SUBROUTINE pw_spline_precond_release(preconditioner,error) failure=.FALSE. IF (ASSOCIATED(preconditioner)) THEN - CPPreconditionNoFail(preconditioner%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(preconditioner%ref_count>0,cp_failure_level,routineP) preconditioner%ref_count=preconditioner%ref_count-1 IF (preconditioner%ref_count==0) THEN - CALL pw_pool_release(preconditioner%pool,error=error) + CALL pw_pool_release(preconditioner%pool) DEALLOCATE(preconditioner,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE pw_spline_precond_release @@ -3214,14 +3157,11 @@ END SUBROUTINE pw_spline_precond_release !> \param preconditioner the preconditioner to apply !> \param in_v the grid on which the preconditioner should be applied !> \param out_v place to store the preconditioner applied on v_out -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pw_spline_do_precond(preconditioner,in_v,out_v,error) + SUBROUTINE pw_spline_do_precond(preconditioner,in_v,out_v) TYPE(pw_spline_precond_type), POINTER :: preconditioner TYPE(pw_type), POINTER :: in_v, out_v - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_spline_do_precond', & routineP = moduleN//':'//routineN @@ -3230,35 +3170,35 @@ SUBROUTINE pw_spline_do_precond(preconditioner,in_v,out_v,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(preconditioner),cp_failure_level,routineP,error,failure) - CPPrecondition(preconditioner%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(preconditioner),cp_failure_level,routineP,failure) + CPPrecondition(preconditioner%ref_count>0,cp_failure_level,routineP,failure) SELECT CASE(preconditioner%kind) CASE(no_precond) - CALL pw_copy(in_v,out_v,error=error) + CALL pw_copy(in_v,out_v) CASE (precond_spl3_aint,precond_spl3_1) - CALL pw_zero(out_v,error=error) + CALL pw_zero(out_v) IF (preconditioner%pbc) THEN CALL pw_nn_smear_r(pw_in=in_v,pw_out=out_v,& - coeffs=preconditioner%coeffs,error=error) + coeffs=preconditioner%coeffs) ELSE CALL pw_nn_compose_r_no_pbc(weights_1d=preconditioner%coeffs_1d,& pw_in=in_v, pw_out=out_v, sharpen=preconditioner%sharpen,& normalize=preconditioner%normalize,& - transpose=preconditioner%transpose,error=error) + transpose=preconditioner%transpose) END IF CASE(precond_spl3_3,precond_spl3_2,precond_spl3_aint2) - CALL pw_zero(out_v,error=error) + CALL pw_zero(out_v) IF (preconditioner%pbc) THEN CALL pw_nn_smear_r(pw_in=in_v,pw_out=out_v,& - coeffs=preconditioner%coeffs,error=error) + coeffs=preconditioner%coeffs) ELSE CALL pw_nn_compose_r_no_pbc(weights_1d=preconditioner%coeffs_1d,& pw_in=in_v, pw_out=out_v, sharpen=preconditioner%sharpen,& normalize=preconditioner%normalize, smooth_boundary=.TRUE.,& - transpose=preconditioner%transpose,error=error) + transpose=preconditioner%transpose) END IF CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE pw_spline_do_precond @@ -3276,28 +3216,23 @@ END SUBROUTINE pw_spline_do_precond !> \param eps_r the requested precision on the residual !> \param eps_x the requested precision on the solution !> \param max_iter maximum number of iteration allowed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** FUNCTION find_coeffs(values,coeffs,linOp,preconditioner, pool, & - eps_r,eps_x,max_iter,error) RESULT(res) + eps_r,eps_x,max_iter) RESULT(res) TYPE(pw_type), POINTER :: values, coeffs INTERFACE ! ***************************************************************************** - SUBROUTINE linOp(pw_in,pw_out,error) + SUBROUTINE linOp(pw_in,pw_out) USE pw_types, ONLY: pw_type - USE cp_error_handling, ONLY: cp_error_type TYPE(pw_type), POINTER :: pw_in,pw_out - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE linOp END INTERFACE TYPE(pw_spline_precond_type), POINTER :: preconditioner TYPE(pw_pool_type), POINTER :: pool REAL(kind=dp), INTENT(in) :: eps_r, eps_x INTEGER, INTENT(in) :: max_iter - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'find_coeffs', & @@ -3315,52 +3250,48 @@ END SUBROUTINE linOp last=.FALSE. res=.FALSE. - logger => cp_error_get_logger(error) - CALL pw_pool_create_pw(pool,r,use_data=REALDATA3D,in_space=REALSPACE,& - error=error) - CALL pw_pool_create_pw(pool,z,use_data=REALDATA3D,in_space=REALSPACE,& - error=error) - CALL pw_pool_create_pw(pool,p,use_data=REALDATA3D,in_space=REALSPACE,& - error=error) - CALL pw_pool_create_pw(pool,Ap,use_data=REALDATA3D,in_space=REALSPACE,& - error=error) - - !CALL cp_add_iter_level(logger%iter_info,level_name="SPLINE_FIND_COEFFS",error=error) + logger => cp_get_default_logger() + CALL pw_pool_create_pw(pool,r,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_pool_create_pw(pool,z,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_pool_create_pw(pool,p,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_pool_create_pw(pool,Ap,use_data=REALDATA3D,in_space=REALSPACE) + + !CALL cp_add_iter_level(logger%iter_info,level_name="SPLINE_FIND_COEFFS") ext_do:DO iiter=1,max_iter,10 - CALL pw_zero(r,error=error) - CALL linOp(pw_in=coeffs,pw_out=r,error=error) + CALL pw_zero(r) + CALL linOp(pw_in=coeffs,pw_out=r) r%cr3d=-r%cr3d - CALL pw_axpy(values,r,error=error) - CALL pw_spline_do_precond(preconditioner,in_v=r,out_v=z,error=error) - CALL pw_copy(z,p,error=error) - r_z=pw_integral_ab(r,z,error=error) + CALL pw_axpy(values,r) + CALL pw_spline_do_precond(preconditioner,in_v=r,out_v=z) + CALL pw_copy(z,p) + r_z=pw_integral_ab(r,z) DO iter=iiter,MIN(iiter+9,max_iter) - eps_r_att=SQRT(pw_integral_ab(r,r,error=error)) + eps_r_att=SQRT(pw_integral_ab(r,r)) IF (eps_r_att==0._dp) THEN eps_x_att=0._dp last=.TRUE. ELSE - CALL pw_zero(Ap,error=error) - CALL linOp(pw_in=p,pw_out=Ap,error=error) - alpha=r_z/pw_integral_ab(Ap,p,error=error) + CALL pw_zero(Ap) + CALL linOp(pw_in=p,pw_out=Ap) + alpha=r_z/pw_integral_ab(Ap,p) - CALL pw_axpy(p,coeffs,alpha=alpha,error=error) + CALL pw_axpy(p,coeffs,alpha=alpha) - eps_x_att=alpha*SQRT(pw_integral_ab(p,p,error=error)) ! try to spare if unneded? + eps_x_att=alpha*SQRT(pw_integral_ab(p,p)) ! try to spare if unneded? IF (eps_r_att \param normalize ... !> \param transpose ... !> \param smooth_boundary ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE pw_nn_compose_r_no_pbc(weights_1d,pw_in,pw_out,& - sharpen,normalize,transpose,smooth_boundary,error) + sharpen,normalize,transpose,smooth_boundary) REAL(kind=dp), DIMENSION(-1:1) :: weights_1d TYPE(pw_type), POINTER :: pw_in, pw_out LOGICAL, INTENT(in), OPTIONAL :: sharpen, normalize, & transpose, smooth_boundary - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_nn_compose_r_no_pbc', & routineP = moduleN//':'//routineN @@ -3437,8 +3365,8 @@ SUBROUTINE pw_nn_compose_r_no_pbc(weights_1d,pw_in,pw_out,& IF (PRESENT(transpose)) my_transpose=transpose my_smooth_boundary=.FALSE. IF (PRESENT(smooth_boundary)) my_smooth_boundary=smooth_boundary - CPAssert(.not.my_normalize.OR.my_sharpen,cp_failure_level,routineP,error,failure) - CPAssert(.NOT.my_smooth_boundary.OR..NOT.my_sharpen,cp_failure_level,routineP,error,failure) + CPAssert(.not.my_normalize.OR.my_sharpen,cp_failure_level,routineP,failure) + CPAssert(.NOT.my_smooth_boundary.OR..NOT.my_sharpen,cp_failure_level,routineP,failure) DO i=1,3 s(i)=bo(2,i)-bo(1,i)+1 END DO @@ -3451,7 +3379,7 @@ SUBROUTINE pw_nn_compose_r_no_pbc(weights_1d,pw_in,pw_out,& ALLOCATE(l_boundary(bo(1,2):bo(2,2),bo(1,3):bo(2,3)),& u_boundary(bo(1,2):bo(2,2),bo(1,3):bo(2,3)),& tmp(bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp(:,:)=pw_in%cr3d(bo(2,1),:,:) CALL mp_sendrecv(tmp,pw_in%pw_grid%para%pos_of_x(& gbo(1,1)+MODULO(bo(2,1)+1-gbo(1,1),gbo(2,1)-gbo(1,1)+1)),& @@ -3465,7 +3393,7 @@ SUBROUTINE pw_nn_compose_r_no_pbc(weights_1d,pw_in,pw_out,& gbo(1,1)+MODULO(bo(2,1)+1-gbo(1,1),gbo(2,1)-gbo(1,1)+1)),& pw_in%pw_grid%para%group) DEALLOCATE(tmp,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF n_els=s(1) @@ -3562,7 +3490,7 @@ SUBROUTINE pw_nn_compose_r_no_pbc(weights_1d,pw_in,pw_out,& IF (has_l_boundary) THEN IF (my_transpose) THEN IF (s(1)==1) THEN - CPAssert(.not.has_u_boundary,cp_failure_level,routineP,error,failure) + CPAssert(.not.has_u_boundary,cp_failure_level,routineP,failure) in_val_tmp=u_boundary(myj,myk) ELSE in_val_tmp=in_val(bo(1,1)+1,myj,myk) @@ -3620,7 +3548,7 @@ SUBROUTINE pw_nn_compose_r_no_pbc(weights_1d,pw_in,pw_out,& IF (my_transpose) THEN in_val_l=in_val(bo(2,1),myj,myk) IF (s(1)==1) THEN - CPAssert(.not.has_l_boundary,cp_failure_level,routineP,error,failure) + CPAssert(.not.has_l_boundary,cp_failure_level,routineP,failure) in_val_tmp=l_boundary(myj,myk) ELSE in_val_tmp=in_val(bo(2,1)-1,myj,myk) @@ -3740,7 +3668,7 @@ SUBROUTINE pw_nn_compose_r_no_pbc(weights_1d,pw_in,pw_out,& IF (is_split) THEN DEALLOCATE(l_boundary,u_boundary,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE pw_nn_compose_r_no_pbc @@ -3748,46 +3676,38 @@ END SUBROUTINE pw_nn_compose_r_no_pbc !> \brief ... !> \param pw_in ... !> \param pw_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE spl3_nopbc(pw_in,pw_out,error) + SUBROUTINE spl3_nopbc(pw_in,pw_out) TYPE(pw_type), POINTER :: pw_in, pw_out - TYPE(cp_error_type), INTENT(inout) :: error - CALL pw_zero(pw_out,error=error) + CALL pw_zero(pw_out) CALL pw_nn_compose_r_no_pbc(weights_1d=spl3_1d_coeffs0,pw_in=pw_in,& - pw_out=pw_out,sharpen=.FALSE.,normalize=.FALSE.,error=error) + pw_out=pw_out,sharpen=.FALSE.,normalize=.FALSE.) END SUBROUTINE spl3_nopbc ! ***************************************************************************** !> \brief ... !> \param pw_in ... !> \param pw_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE spl3_nopbct(pw_in,pw_out,error) + SUBROUTINE spl3_nopbct(pw_in,pw_out) TYPE(pw_type), POINTER :: pw_in, pw_out - TYPE(cp_error_type), INTENT(inout) :: error - CALL pw_zero(pw_out,error=error) + CALL pw_zero(pw_out) CALL pw_nn_compose_r_no_pbc(weights_1d=spl3_1d_coeffs0,pw_in=pw_in,& - pw_out=pw_out,sharpen=.FALSE.,normalize=.FALSE.,transpose=.TRUE.,& - error=error) + pw_out=pw_out,sharpen=.FALSE.,normalize=.FALSE.,transpose=.TRUE.) END SUBROUTINE spl3_nopbct ! ***************************************************************************** !> \brief ... !> \param pw_in ... !> \param pw_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE spl3_pbc(pw_in,pw_out,error) + SUBROUTINE spl3_pbc(pw_in,pw_out) TYPE(pw_type), POINTER :: pw_in, pw_out - TYPE(cp_error_type), INTENT(inout) :: error - CALL pw_zero(pw_out,error=error) - CALL pw_nn_smear_r(pw_in,pw_out,coeffs=spline3_coeffs,& - error=error) + CALL pw_zero(pw_out) + CALL pw_nn_smear_r(pw_in,pw_out,coeffs=spline3_coeffs) END SUBROUTINE spl3_pbc ! ***************************************************************************** @@ -3795,8 +3715,6 @@ END SUBROUTINE spl3_pbc !> input vector (vec) !> \param vec ... !> \param pw ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval val ... !> \par History !> 12.2007 Adapted for use with distributed grids [rdeclerck] @@ -3804,10 +3722,9 @@ END SUBROUTINE spl3_pbc !> \note !> Requires the Spline coefficients to be computed with PBC ! ***************************************************************************** - FUNCTION Eval_Interp_Spl3_pbc(vec,pw,error) RESULT(val) + FUNCTION Eval_Interp_Spl3_pbc(vec,pw) RESULT(val) REAL(KIND=dp), DIMENSION(3), INTENT(in) :: vec TYPE(pw_type), POINTER :: pw - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: val CHARACTER(len=*), PARAMETER :: routineN = 'Eval_Interp_Spl3_pbc', & @@ -3953,8 +3870,6 @@ END FUNCTION Eval_Interp_Spl3_pbc !> function on the generic input vector (vec) !> \param vec ... !> \param pw ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval val ... !> \par History !> 12.2007 Adapted for use with distributed grids [rdeclerck] @@ -3962,10 +3877,9 @@ END FUNCTION Eval_Interp_Spl3_pbc !> \note !> Requires the Spline coefficients to be computed with PBC ! ***************************************************************************** - FUNCTION Eval_d_Interp_Spl3_pbc(vec,pw,error) RESULT(val) + FUNCTION Eval_d_Interp_Spl3_pbc(vec,pw) RESULT(val) REAL(KIND=dp), DIMENSION(3), INTENT(in) :: vec TYPE(pw_type), POINTER :: pw - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: val(3) CHARACTER(len=*), PARAMETER :: routineN = 'Eval_d_Interp_Spl3_pbc', & diff --git a/src/pw/pw_types.F b/src/pw/pw_types.F index cb58d4eba0..367d7b2d7f 100644 --- a/src/pw/pw_types.F +++ b/src/pw/pw_types.F @@ -76,17 +76,14 @@ MODULE pw_types ! ***************************************************************************** !> \brief retains a pw type !> \param pw the pw to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE pw_retain(pw, error) + SUBROUTINE pw_retain(pw) TYPE(pw_type), POINTER :: pw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_retain', & routineP = moduleN//':'//routineN @@ -95,25 +92,22 @@ SUBROUTINE pw_retain(pw, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pw),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(pw%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(pw),cp_failure_level,routineP,failure) + CPPreconditionNoFail(pw%ref_count>0,cp_failure_level,routineP) pw%ref_count=pw%ref_count+1 END SUBROUTINE pw_retain ! ***************************************************************************** !> \brief releases the given pw !> \param pw the pw to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** -SUBROUTINE pw_release(pw, error) +SUBROUTINE pw_release(pw) TYPE(pw_type), POINTER :: pw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_release', & routineP = moduleN//':'//routineN @@ -124,7 +118,7 @@ SUBROUTINE pw_release(pw, error) failure=.FALSE. IF (ASSOCIATED(pw)) THEN - CPPreconditionNoFail(pw%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(pw%ref_count>0,cp_failure_level,routineP) pw%ref_count=pw%ref_count-1 IF (pw%ref_count==0) THEN pw%ref_count=1 @@ -133,28 +127,28 @@ SUBROUTINE pw_release(pw, error) SELECT CASE(pw % in_use) CASE (REALDATA1D) DEALLOCATE ( pw % cr, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CASE(COMPLEXDATA1D) DEALLOCATE ( pw % cc, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CASE(REALDATA3D) IF (ASSOCIATED(pw%cr3d)) THEN !FM optimizations of pools might have removed the 3d field to cache it DEALLOCATE ( pw % cr3d, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF CASE(COMPLEXDATA3D) DEALLOCATE ( pw % cc3d, STAT = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CASE(NODATA) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "unknown data type "//cp_to_string(pw%in_use),error,failure) + "unknown data type "//cp_to_string(pw%in_use),failure) END SELECT - CALL pw_grid_release(pw%pw_grid, error=error) + CALL pw_grid_release(pw%pw_grid) pw%ref_count=0 DEALLOCATE(pw, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(pw) @@ -168,20 +162,17 @@ END SUBROUTINE pw_release !> \param in_space in which space the pw is (real or reciprocal) !> \param cr3d_ptr pointer with the cr3d data (make sense only if !> use_data==REALDATA3D) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr, error) +SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr) TYPE(pw_type), POINTER :: pw TYPE(pw_grid_type), POINTER :: pw_grid INTEGER, INTENT(in) :: use_data INTEGER, INTENT(in), OPTIONAL :: in_space REAL(KIND=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: cr3d_ptr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_create', & routineP = moduleN//':'//routineN @@ -194,10 +185,10 @@ SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr, error) failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(.NOT.ASSOCIATED(pw),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(pw),cp_failure_level,routineP,failure) ALLOCATE(pw,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - logger => cp_error_get_logger(error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + logger => cp_get_default_logger() IF (debug_this_module) THEN WRITE (cp_logger_get_default_unit_nr(logger),"('*** allocated pw ***')") IF (PRESENT(cr3d_ptr)) THEN @@ -210,7 +201,7 @@ SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr, error) IF (PRESENT(cr3d_ptr)) THEN IF (ASSOCIATED(cr3d_ptr)) THEN - CPAssertNoFail(use_data==REALDATA3D,cp_failure_level,routineP,error) + CPAssertNoFail(use_data==REALDATA3D,cp_failure_level,routineP) END IF END IF @@ -220,7 +211,7 @@ SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr, error) NULLIFY ( pw % pw_grid ) pw % in_use = use_data pw % pw_grid => pw_grid - CALL pw_grid_retain(pw%pw_grid, error=error) + CALL pw_grid_retain(pw%pw_grid) pw % in_space = NOSPACE bounds => pw % pw_grid % bounds_local @@ -231,18 +222,18 @@ SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr, error) SELECT CASE(use_data) CASE(REALDATA1D) ALLOCATE ( pw % cr ( pw % pw_grid % ngpts_cut_local ), STAT = stat ) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) CASE(COMPLEXDATA1D) ALLOCATE ( pw % cc ( pw % pw_grid % ngpts_cut_local ), STAT = stat ) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) CASE (REALDATA3D) IF (PRESENT(cr3d_ptr)) THEN IF (ASSOCIATED(cr3d_ptr)) THEN IF (ALL(bounds(1,:) <= bounds(2,:))) THEN - CPPreconditionNoFail(ALL(LBOUND(cr3d_ptr)==bounds(1,:)),cp_failure_level,routineP,error) - CPPreconditionNoFail(ALL(UBOUND(cr3d_ptr)==bounds(2,:)),cp_failure_level,routineP,error) + CPPreconditionNoFail(ALL(LBOUND(cr3d_ptr)==bounds(1,:)),cp_failure_level,routineP) + CPPreconditionNoFail(ALL(UBOUND(cr3d_ptr)==bounds(2,:)),cp_failure_level,routineP) END IF pw%cr3d => cr3d_ptr END IF @@ -252,7 +243,7 @@ SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr, error) bounds ( 1, 1 ) : bounds ( 2, 1 ), & bounds ( 1, 2 ) : bounds ( 2, 2 ), & bounds ( 1, 3 ) : bounds ( 2, 3 ) ), STAT = stat ) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) END IF CASE(COMPLEXDATA3D) @@ -260,11 +251,11 @@ SUBROUTINE pw_create(pw, pw_grid, use_data, in_space, cr3d_ptr, error) bounds ( 1, 1 ) : bounds ( 2, 1 ), & bounds ( 1, 2 ) : bounds ( 2, 2 ), & bounds ( 1, 3 ) : bounds ( 2, 3 ) ), STAT = stat ) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) CASE(NODATA) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "unknown data type",error,failure) + "unknown data type",failure) END SELECT IF (PRESENT(in_space)) pw%in_space=in_space CALL timestop(handle) diff --git a/src/pw/realspace_grid_cube.F b/src/pw/realspace_grid_cube.F index 636d7a00ba..3bfd3c2343 100644 --- a/src/pw/realspace_grid_cube.F +++ b/src/pw/realspace_grid_cube.F @@ -40,9 +40,8 @@ MODULE realspace_grid_cube !> \param particles_z ... !> \param stride ... !> \param zero_tails ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pw_to_cube ( pw, unit_nr, title, particles_r, particles_z, stride, zero_tails, error ) + SUBROUTINE pw_to_cube ( pw, unit_nr, title, particles_r, particles_z, stride, zero_tails) TYPE(pw_type), POINTER :: pw INTEGER, INTENT(IN) :: unit_nr CHARACTER(*), INTENT(IN), OPTIONAL :: title @@ -52,7 +51,6 @@ SUBROUTINE pw_to_cube ( pw, unit_nr, title, particles_r, particles_z, stride, ze OPTIONAL :: particles_z INTEGER, DIMENSION(:), OPTIONAL, POINTER :: stride LOGICAL, INTENT(IN), OPTIONAL :: zero_tails - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_to_cube', & routineP = moduleN//':'//routineN @@ -81,9 +79,9 @@ SUBROUTINE pw_to_cube ( pw, unit_nr, title, particles_r, particles_z, stride, ze ELSE my_stride = stride(1:3) END IF - CPPrecondition(my_stride(1)>0,cp_failure_level,routineP,error,failure) - CPPrecondition(my_stride(2)>0,cp_failure_level,routineP,error,failure) - CPPrecondition(my_stride(3)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(my_stride(1)>0,cp_failure_level,routineP,failure) + CPPrecondition(my_stride(2)>0,cp_failure_level,routineP,failure) + CPPrecondition(my_stride(3)>0,cp_failure_level,routineP,failure) END IF IF (unit_nr>0) THEN @@ -96,10 +94,10 @@ SUBROUTINE pw_to_cube ( pw, unit_nr, title, particles_r, particles_z, stride, ze WRITE(unit_nr,*) "No Title" ENDIF - CPPrecondition(PRESENT(particles_z) .EQV. PRESENT(particles_r),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(particles_z) .EQV. PRESENT(particles_r),cp_failure_level,routineP,failure) np=0 IF(PRESENT(particles_z)) THEN - CPPrecondition(SIZE(particles_z) == SIZE(particles_r, dim=2),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(particles_z) == SIZE(particles_r, dim=2),cp_failure_level,routineP,failure) ! cube files can only be written for 99999 particles due to a format limitation (I5) ! so we limit the number of particles written. np=MIN(99999,SIZE(particles_z)) @@ -133,7 +131,7 @@ SUBROUTINE pw_to_cube ( pw, unit_nr, title, particles_r, particles_z, stride, ze U3=pw%pw_grid%bounds(2,3) ALLOCATE(buf(L3:U3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_rank = pw%pw_grid%para%my_pos gid = pw%pw_grid%para%group @@ -146,10 +144,10 @@ SUBROUTINE pw_to_cube ( pw, unit_nr, title, particles_r, particles_z, stride, ze IF (unit_nr>0) checksum=1 CALL mp_sum(checksum,gid) - CPPostcondition(checksum==1,cp_failure_level,routineP,error,failure) + CPPostcondition(checksum==1,cp_failure_level,routineP,failure) CALL mp_maxloc(rank,gid) - CPPostcondition(rank(1)>0,cp_failure_level,routineP,error,failure) + CPPostcondition(rank(1)>0,cp_failure_level,routineP,failure) dest = rank(2) DO I1=L1,U1,my_stride(1) @@ -214,16 +212,14 @@ END SUBROUTINE pw_to_cube !> \param grid pw to read from cube file !> \param filename name of cube file !> \param scaling scale values before storing -!> \param error ... !> \date 01.2014 !> \author M.Watkins ! ***************************************************************************** - SUBROUTINE cube_to_pw(grid, filename, scaling, error) + SUBROUTINE cube_to_pw(grid, filename, scaling) TYPE(pw_type), POINTER :: grid CHARACTER(len=*), INTENT(in) :: filename REAL(kind=dp), INTENT(in) :: scaling - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cube_to_pw', & routineP = moduleN//':'//routineN @@ -239,7 +235,7 @@ SUBROUTINE cube_to_pw(grid, filename, scaling, error) REAL(kind=dp), DIMENSION(3) :: dr, rdum TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) failure=.FALSE. diff --git a/src/pw/realspace_grid_types.F b/src/pw/realspace_grid_types.F index 65deafc79b..65511f2d97 100644 --- a/src/pw/realspace_grid_types.F +++ b/src/pw/realspace_grid_types.F @@ -194,7 +194,6 @@ END FUNCTION rs_grid_locate_rank !> \param pw_grid ... !> \param input_settings ... !> \param border_points ... -!> \param error ... !> \par History !> JGH (08-Jun-2003) : nsmax <= 0 indicates fully replicated grid !> Iain Bethune (05-Sep-2008) : modified cut heuristic @@ -205,13 +204,12 @@ END FUNCTION rs_grid_locate_rank !> (27.11.2013, Matthias Krack) !> \author JGH (18-Mar-2001) ! ***************************************************************************** - SUBROUTINE rs_grid_create_descriptor ( desc, pw_grid, input_settings, border_points, error) + SUBROUTINE rs_grid_create_descriptor ( desc, pw_grid, input_settings, border_points) TYPE(realspace_grid_desc_type), POINTER :: desc TYPE(pw_grid_type), POINTER :: pw_grid TYPE(realspace_grid_input_type), & INTENT(IN) :: input_settings INTEGER, INTENT(IN), OPTIONAL :: border_points - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rs_grid_create_descriptor', & routineP = moduleN//':'//routineN @@ -225,7 +223,7 @@ SUBROUTINE rs_grid_create_descriptor ( desc, pw_grid, input_settings, border_poi CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,failure) IF (PRESENT(border_points)) THEN border_size = border_points @@ -234,14 +232,14 @@ SUBROUTINE rs_grid_create_descriptor ( desc, pw_grid, input_settings, border_poi END IF ALLOCATE(desc,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_sync(pw_grid % para % group) NULLIFY(desc % rank2coord,desc % coord2rank,desc % lb_global,desc % ub_global,desc % x2coord,desc % y2coord,desc % z2coord) desc % pw => pw_grid - CALL pw_grid_retain(desc%pw,error=error) + CALL pw_grid_retain(desc%pw) desc % dh = pw_grid%dh desc % dh_inv = pw_grid%dh_inv @@ -411,19 +409,19 @@ SUBROUTINE rs_grid_create_descriptor ( desc, pw_grid, input_settings, border_poi ! set up global info about the distribution ALLOCATE( desc % rank2coord(3,0:desc % group_size-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( desc % coord2rank(0:desc % group_dim(1)-1,0:desc % group_dim(2)-1,0:desc % group_dim(3)-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( desc % lb_global(3,0:desc % group_size-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( desc % ub_global(3,0:desc % group_size-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( desc % x2coord(desc % lb(1):desc % ub(1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( desc % y2coord(desc % lb(2):desc % ub(2)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE( desc % z2coord(desc % lb(3):desc % ub(3)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=0, desc% group_size - 1 ! Calculate coordinates in a row-major order (to be SMP-friendly) @@ -505,12 +503,10 @@ END SUBROUTINE rs_grid_create_descriptor !> \brief ... !> \param rs ... !> \param desc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rs_grid_create ( rs, desc, error) + SUBROUTINE rs_grid_create ( rs, desc) TYPE(realspace_grid_type), POINTER :: rs TYPE(realspace_grid_desc_type), POINTER :: desc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rs_grid_create', & routineP = moduleN//':'//routineN @@ -521,13 +517,13 @@ SUBROUTINE rs_grid_create ( rs, desc, error) CALL timeset(routineN,handle) ALLOCATE(rs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_rs_id = last_rs_id+1 rs % id_nr = last_rs_id rs % ref_count = 1 rs % desc => desc - CALL rs_grid_retain_descriptor(rs % desc, error) + CALL rs_grid_retain_descriptor(rs % desc) IF (desc%pw%para%mode == PW_MODE_LOCAL) THEN ! The corresponding group has dimension 1 @@ -565,13 +561,13 @@ SUBROUTINE rs_grid_create ( rs, desc, error) ALLOCATE ( rs % r (rs % lb_local(1):rs % ub_local(1), & rs % lb_local(2):rs % ub_local(2), & rs % lb_local(3):rs % ub_local(3)), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( rs % px ( desc % npts ( 1 ) ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( rs % py ( desc % npts ( 2 ) ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( rs % pz ( desc % npts ( 3 ) ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -589,16 +585,14 @@ END SUBROUTINE rs_grid_create !> a physical rank to the 'rank' of data owned by that process and vice versa !> \param desc ... !> \param real2virtual ... -!> \param error ... !> \par History !> 04-2009 created [Iain Bethune] !> (c) The Numerical Algorithms Group (NAG) Ltd, 2009 on behalf of the HECToR project ! ***************************************************************************** - SUBROUTINE rs_grid_reorder_ranks(desc, real2virtual, error) + SUBROUTINE rs_grid_reorder_ranks(desc, real2virtual) TYPE(realspace_grid_desc_type), POINTER :: desc INTEGER, DIMENSION(:), INTENT(IN) :: real2virtual - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rs_grid_reorder_ranks', & routineP = moduleN//':'//routineN @@ -627,13 +621,11 @@ SUBROUTINE rs_grid_reorder_ranks(desc, real2virtual, error) !> \brief Print information on grids to output !> \param rs ... !> \param iounit ... -!> \param error ... !> \author JGH (17-May-2007) ! ***************************************************************************** - SUBROUTINE rs_grid_print ( rs, iounit, error) + SUBROUTINE rs_grid_print ( rs, iounit) TYPE(realspace_grid_type), POINTER :: rs INTEGER, INTENT(in) :: iounit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rs_grid_print', & routineP = moduleN//':'//routineN @@ -712,18 +704,16 @@ END SUBROUTINE rs_grid_print !> \param rs ... !> \param pw ... !> \param dir ... -!> \param error ... !> \par History !> JGH (15-Feb-2003) reduced additional memory usage !> Joost VandeVondele (Sep-2003) moved from sum/bcast to shift !> \author JGH (18-Mar-2001) ! ***************************************************************************** - SUBROUTINE rs_pw_transfer ( rs, pw, dir, error) + SUBROUTINE rs_pw_transfer ( rs, pw, dir) TYPE(realspace_grid_type), POINTER :: rs TYPE(pw_type), POINTER :: pw INTEGER, INTENT(IN) :: dir - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_pw_transfer', & routineP = moduleN//':'//routineN @@ -748,16 +738,16 @@ SUBROUTINE rs_pw_transfer ( rs, pw, dir, error) CALL stop_program(routineN,moduleN,__LINE__,"Direction must be rs2pw or pw2rs") IF (rs%desc%distributed) THEN - CALL rs_pw_transfer_distributed(rs,pw,dir,error) + CALL rs_pw_transfer_distributed(rs,pw,dir) ELSE IF (rs%desc%parallel) THEN - CALL rs_pw_transfer_replicated(rs,pw,dir,error) + CALL rs_pw_transfer_replicated(rs,pw,dir) ELSE ! treat simple serial case locally IF (dir == rs2pw) THEN IF (pw%in_use == REALDATA3D) THEN IF (rs%desc%border == 0) THEN CALL dcopy(SIZE(rs%r),rs%r,1,pw%cr3d,1) ELSE - CPPrecondition(LBOUND(pw%cr3d,3) .EQ. rs%lb_real(3),cp_failure_level,routineP,error,failure) + CPPrecondition(LBOUND(pw%cr3d,3) .EQ. rs%lb_real(3),cp_failure_level,routineP,failure) !$omp parallel do default(none) shared(pw,rs) DO i = rs%lb_real(3),rs%ub_real(3) pw%cr3d(:,:,i) = rs%r(rs%lb_real(1):rs%ub_real(1),& @@ -769,7 +759,7 @@ SUBROUTINE rs_pw_transfer ( rs, pw, dir, error) IF (rs%desc%border == 0) THEN CALL copy_rc(rs%r,pw%cc3d) ELSE - CPPrecondition(LBOUND(pw%cr3d,3) .EQ. rs%lb_real(3),cp_failure_level,routineP,error,failure) + CPPrecondition(LBOUND(pw%cr3d,3) .EQ. rs%lb_real(3),cp_failure_level,routineP,failure) !$omp parallel do default(none) shared(pw,rs) DO i = rs%lb_real(3),rs%ub_real(3) pw%cc3d(:,:,i) = CMPLX(rs%r(rs%lb_real(1):rs%ub_real(1),& @@ -872,16 +862,14 @@ END SUBROUTINE rs_pw_transfer !> \param rs ... !> \param pw ... !> \param dir == rs2pw or dir == pw2rs -!> \param error ... !> \note !> rs2pw sums all data on the rs grid into the respective pw grid !> pw2rs will scatter all pw data to the rs grids ! ***************************************************************************** - SUBROUTINE rs_pw_transfer_replicated(rs,pw,dir,error) + SUBROUTINE rs_pw_transfer_replicated(rs,pw,dir) TYPE(realspace_grid_type), POINTER :: rs TYPE(pw_type), POINTER :: pw INTEGER, INTENT(IN) :: dir - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_pw_transfer_replicated', & routineP = moduleN//':'//routineN @@ -906,13 +894,13 @@ SUBROUTINE rs_pw_transfer_replicated(rs,pw,dir,error) group = pw % pw_grid % para % rs_group mepos = pw % pw_grid % para % rs_mpo ALLOCATE ( rcount ( 0 : np - 1 ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ip = 1, np rcount ( ip-1 ) = PRODUCT ( bo(2,:,ip) - bo(1,:,ip) + 1 ) END DO nma = MAXVAL ( rcount ( 0 : np - 1 ) ) ALLOCATE(sendbuf(nma),recvbuf(nma), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sendbuf=1.0E99_dp ; recvbuf=1.0E99_dp ! init mpi'ed buffers to silence warnings under valgrind grid=>rs%r @@ -1040,11 +1028,11 @@ SUBROUTINE rs_pw_transfer_replicated(rs,pw,dir,error) END IF DEALLOCATE ( rcount, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( sendbuf, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recvbuf, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE rs_pw_transfer_replicated @@ -1054,7 +1042,6 @@ END SUBROUTINE rs_pw_transfer_replicated !> \param rs ... !> \param pw ... !> \param dir ... -!> \param error ... !> \par History !> 12.2007 created [Matt Watkins] !> 9.2008 reduced amount of halo data sent [Iain Bethune] @@ -1072,11 +1059,10 @@ END SUBROUTINE rs_pw_transfer_replicated !> exchange is that the border region is rather large (e.g. 20 points) and that it might overlap !> with the central domain of several CPUs (i.e. next nearest neighbors) ! ***************************************************************************** - SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) + SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir) TYPE(realspace_grid_type), POINTER :: rs TYPE(pw_type), POINTER :: pw INTEGER, INTENT(IN) :: dir - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_pw_transfer_distributed', & routineP = moduleN//':'//routineN @@ -1127,9 +1113,9 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) IF ( rs % desc % perd (idir) .NE. 1) THEN ALLOCATE ( dshifts ( 0:rs % desc % neighbours (idir ) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( ushifts ( 0:rs % desc % neighbours (idir ) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ushifts = 0 dshifts = 0 @@ -1185,14 +1171,14 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) ! post the recieve ALLOCATE ( recv_buf_3d_down (lb_recv_down(1):ub_recv_down(1), & lb_recv_down(2):ub_recv_down(2), lb_recv_down(3):ub_recv_down(3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_irecv (recv_buf_3d_down, source_down, rs % desc % group, req(1)) ! now allocate, pack and send the send buffer nn = PRODUCT ( ub_send_down - lb_send_down + 1 ) ALLOCATE ( send_buf_3d_down ( lb_send_down(1):ub_send_down(1), & lb_send_down(2):ub_send_down(2), lb_send_down(3):ub_send_down(3) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$omp parallel default(none), & !$omp private(lb,ub,my_id,num_threads), & @@ -1247,14 +1233,14 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) ! post the recieve ALLOCATE ( recv_buf_3d_up (lb_recv_up(1):ub_recv_up(1), & lb_recv_up(2):ub_recv_up(2), lb_recv_up(3):ub_recv_up(3)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_irecv(recv_buf_3d_up, source_up, rs % desc % group, req(2)) ! now allocate,pack and send the send buffer nn = PRODUCT ( ub_send_up - lb_send_up + 1 ) ALLOCATE ( send_buf_3d_up ( lb_send_up(1):ub_send_up(1), & lb_send_up(2):ub_send_up(2), lb_send_up(3):ub_send_up(3) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$omp parallel default(none), & !$omp private(lb,ub,my_id,num_threads), & @@ -1302,7 +1288,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) !$omp end parallel END IF DEALLOCATE( recv_buf_3d_down, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ! only some procs may need later shifts @@ -1326,7 +1312,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) !$omp end parallel END IF DEALLOCATE( recv_buf_3d_up, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO @@ -1336,15 +1322,15 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) CALL mp_waitall (req(3:4)) DEALLOCATE( send_buf_3d_down, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE( send_buf_3d_up, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE ( dshifts, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( ushifts, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -1354,7 +1340,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) ! This is the real redistribution ALLOCATE ( bounds ( 0:pw % pw_grid % para % group_size - 1, 1:4 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! work out the pw grid points each proc holds DO i = 0, pw % pw_grid % para % group_size - 1 @@ -1365,17 +1351,17 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) ENDDO ALLOCATE ( send_tasks ( 0:pw % pw_grid % para % group_size -1,1:6 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( send_sizes ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( send_disps ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_tasks ( 0:pw % pw_grid % para % group_size -1,1:6 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_sizes ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_disps ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_tasks(:,1)=1 send_tasks(:,2)=0 send_tasks(:,3)=1 @@ -1464,12 +1450,12 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) recv_disps(i) = recv_disps(i-1) + recv_sizes(i-1) ENDDO - CPPrecondition(SUM(send_sizes)==PRODUCT(ub_recv - lb_recv + 1),cp_failure_level,routineP,error,failure) + CPPrecondition(SUM(send_sizes)==PRODUCT(ub_recv - lb_recv + 1),cp_failure_level,routineP,failure) ALLOCATE ( send_bufs ( 0:rs % desc % group_size - 1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_bufs ( 0:rs % desc % group_size - 1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 0, rs % desc % group_size - 1 IF ( send_sizes(i) .NE. 0 ) THEN @@ -1485,7 +1471,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) END DO ALLOCATE (recv_reqs (0:rs % desc % group_size - 1), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) recv_reqs = mp_request_null DO i = 0, rs % desc % group_size - 1 @@ -1512,7 +1498,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) !$omp end parallel do ALLOCATE (send_reqs (0:rs % desc % group_size - 1), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_reqs = mp_request_null DO i = 0, rs % desc % group_size - 1 @@ -1541,9 +1527,9 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) CALL mp_waitall(send_reqs) DEALLOCATE ( recv_reqs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_reqs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 0, rs % desc % group_size - 1 IF ( ASSOCIATED(send_bufs(i)%array ) ) THEN @@ -1555,25 +1541,25 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) END DO DEALLOCATE ( send_bufs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_bufs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_tasks, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_sizes, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_disps, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_tasks, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_sizes, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_disps, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (debug_this_module) THEN ! safety check, to be removed once we're absolute sure the routine is correct - pw_sum=pw_integrate_function(pw,error=error) + pw_sum=pw_integrate_function(pw) IF (ABS(pw_sum-rs_sum)/MAX(1.0_dp,ABS(pw_sum),ABS(rs_sum))>EPSILON(rs_sum)*1000) THEN WRITE(error_string,'(A,6(1X,I4.4),3F25.16)') "rs_pw_transfer_distributed", & rs % desc % npts, rs % desc % group_dim, pw_sum,rs_sum,ABS(pw_sum-rs_sum) @@ -1592,7 +1578,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) ! This is the real redistribution ALLOCATE ( bounds ( 0:pw % pw_grid % para % group_size - 1, 1:4 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 0, pw % pw_grid % para % group_size - 1 bounds ( i , 1:2 ) = pw % pw_grid % para % bo (1:2,1,i,1) @@ -1602,17 +1588,17 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) ENDDO ALLOCATE ( send_tasks ( 0:pw % pw_grid % para % group_size -1,1:6 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( send_sizes ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( send_disps ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_tasks ( 0:pw % pw_grid % para % group_size -1,1:6 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_sizes ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_disps ( 0:pw % pw_grid % para % group_size -1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_tasks = 0 send_tasks(:,1)=1 @@ -1714,12 +1700,12 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) recv_disps(i) = recv_disps(i-1) + recv_sizes(i-1) ENDDO - CPPrecondition(SUM(recv_sizes)==PRODUCT(ub_recv - lb_recv + 1),cp_failure_level,routineP,error,failure) + CPPrecondition(SUM(recv_sizes)==PRODUCT(ub_recv - lb_recv + 1),cp_failure_level,routineP,failure) ALLOCATE ( send_bufs ( 0:rs % desc % group_size - 1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( recv_bufs ( 0:rs % desc % group_size - 1 ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 0, rs % desc % group_size - 1 IF ( send_sizes(i) .NE. 0 ) THEN @@ -1735,7 +1721,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) END DO ALLOCATE (recv_reqs (0:rs % desc % group_size - 1), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) recv_reqs = mp_request_null DO i = 0, rs % desc % group_size - 1 @@ -1762,7 +1748,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) !$omp end parallel do ALLOCATE (send_reqs (0:rs % desc % group_size - 1), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_reqs = mp_request_null DO i = 0, rs % desc % group_size - 1 @@ -1792,9 +1778,9 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) CALL mp_waitall(send_reqs) DEALLOCATE ( recv_reqs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_reqs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 0, rs % desc % group_size - 1 IF ( ASSOCIATED(send_bufs(i)%array ) ) THEN @@ -1806,21 +1792,21 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) END DO DEALLOCATE ( send_bufs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_bufs, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_tasks, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_sizes, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_disps, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_tasks, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_sizes, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( recv_disps, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! now pass wings around halo_swapped = .FALSE. @@ -1830,9 +1816,9 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) IF ( rs % desc % perd (idir) /= 1) THEN ALLOCATE ( dshifts ( 0:rs % desc % neighbours (idir ) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( ushifts ( 0:rs % desc % neighbours (idir ) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ushifts = 0 dshifts = 0 @@ -1888,7 +1874,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) nn = PRODUCT ( ub_recv_down - lb_recv_down + 1 ) ALLOCATE ( recv_buf_3d_down ( lb_recv_down(1):ub_recv_down(1), & lb_recv_down(2):ub_recv_down(2), lb_recv_down(3):ub_recv_down(3) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! recv buffer is now ready, so post the recieve CALL mp_irecv (recv_buf_3d_down, source_down, rs % desc % group, req(1)) @@ -1897,7 +1883,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) nn = PRODUCT ( ub_send_down - lb_send_down + 1 ) ALLOCATE ( send_buf_3d_down ( lb_send_down(1):ub_send_down(1), & lb_send_down(2):ub_send_down(2), lb_send_down(3):ub_send_down(3) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$omp parallel default(none), & !$omp private(lb,ub,my_id,num_threads), & @@ -1953,7 +1939,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) nn = PRODUCT ( ub_recv_up - lb_recv_up + 1 ) ALLOCATE ( recv_buf_3d_up ( lb_recv_up(1):ub_recv_up(1), & lb_recv_up(2):ub_recv_up(2), lb_recv_up(3):ub_recv_up(3) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! recv buffer is now ready, so post the recieve @@ -1963,7 +1949,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) nn = PRODUCT ( ub_send_up - lb_send_up + 1 ) ALLOCATE ( send_buf_3d_up ( lb_send_up(1):ub_send_up(1), & lb_send_up(2):ub_send_up(2), lb_send_up(3):ub_send_up(3) ), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$omp parallel default(none), & !$omp private(lb,ub,my_id,num_threads), & @@ -2010,7 +1996,7 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) END IF DEALLOCATE ( recv_buf_3d_down, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ! only some procs may need later shifts @@ -2033,22 +2019,22 @@ SUBROUTINE rs_pw_transfer_distributed(rs,pw,dir,error) END IF DEALLOCATE ( recv_buf_3d_up, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL mp_waitall (req(3:4)) DEALLOCATE ( send_buf_3d_down, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( send_buf_3d_up, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE ( ushifts, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( dshifts, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF halo_swapped (idir) = .TRUE. @@ -2138,25 +2124,23 @@ END SUBROUTINE rs_grid_mult_and_add !> This is needed for variable cell simulations !> \param pw_grid ... !> \param rs ... -!> \param error ... !> \par History !> none !> \author JGH (15-May-2007) ! ***************************************************************************** - SUBROUTINE rs_grid_set_box ( pw_grid, rs, error ) + SUBROUTINE rs_grid_set_box ( pw_grid, rs) TYPE(pw_grid_type), POINTER :: pw_grid TYPE(realspace_grid_type), POINTER :: rs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_grid_set_box', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rs),cp_failure_level,routineP,error,failure) - CPPrecondition(rs%desc % grid_id==pw_grid%id_nr,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_grid),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rs),cp_failure_level,routineP,failure) + CPPrecondition(rs%desc % grid_id==pw_grid%id_nr,cp_failure_level,routineP,failure) rs % desc % dh = pw_grid%dh rs % desc % dh_inv = pw_grid%dh_inv @@ -2165,15 +2149,12 @@ END SUBROUTINE rs_grid_set_box ! ***************************************************************************** !> \brief retains the given rs grid (see doc/ReferenceCounting.html) !> \param rs_grid the grid to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE rs_grid_retain(rs_grid, error) + SUBROUTINE rs_grid_retain(rs_grid) TYPE(realspace_grid_type), POINTER :: rs_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_grid_retain', & routineP = moduleN//':'//routineN @@ -2182,23 +2163,20 @@ SUBROUTINE rs_grid_retain(rs_grid, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(rs_grid),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(rs_grid%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(rs_grid),cp_failure_level,routineP,failure) + CPPreconditionNoFail(rs_grid%ref_count>0,cp_failure_level,routineP) rs_grid%ref_count=rs_grid%ref_count+1 END SUBROUTINE rs_grid_retain ! ***************************************************************************** !> \brief retains the given rs grid descriptor (see doc/ReferenceCounting.html) !> \param rs_desc the grid descriptor to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2009 created [Iain Bethune] !> (c) The Numerical Algorithms Group (NAG) Ltd, 2009 on behalf of the HECToR project ! ***************************************************************************** - SUBROUTINE rs_grid_retain_descriptor(rs_desc, error) + SUBROUTINE rs_grid_retain_descriptor(rs_desc) TYPE(realspace_grid_desc_type), POINTER :: rs_desc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_grid_retain_descriptor', & routineP = moduleN//':'//routineN @@ -2207,23 +2185,20 @@ SUBROUTINE rs_grid_retain_descriptor(rs_desc, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(rs_desc),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(rs_desc%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(rs_desc),cp_failure_level,routineP,failure) + CPPreconditionNoFail(rs_desc%ref_count>0,cp_failure_level,routineP) rs_desc%ref_count=rs_desc%ref_count+1 END SUBROUTINE rs_grid_retain_descriptor ! ***************************************************************************** !> \brief releases the given rs grid (see doc/ReferenceCounting.html) !> \param rs_grid the rs grid to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE rs_grid_release(rs_grid,error) + SUBROUTINE rs_grid_release(rs_grid) TYPE(realspace_grid_type), POINTER :: rs_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_grid_release', & routineP = moduleN//':'//routineN @@ -2234,23 +2209,23 @@ SUBROUTINE rs_grid_release(rs_grid,error) failure=.FALSE. IF (ASSOCIATED(rs_grid)) THEN - CPPreconditionNoFail(rs_grid%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(rs_grid%ref_count>0,cp_failure_level,routineP) rs_grid%ref_count=rs_grid%ref_count-1 IF (rs_grid%ref_count==0) THEN - CALL rs_grid_release_descriptor(rs_grid % desc, error=error) + CALL rs_grid_release_descriptor(rs_grid % desc) allocated_rs_grid_count=allocated_rs_grid_count-1 DEALLOCATE ( rs_grid % r, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_grid % px , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_grid % py , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_grid % pz , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rs_grid, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(rs_grid) END IF END IF @@ -2259,15 +2234,12 @@ END SUBROUTINE rs_grid_release ! ***************************************************************************** !> \brief releases the given rs grid descriptor (see doc/ReferenceCounting.html) !> \param rs_desc the rs grid descriptor to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2009 created [Iain Bethune] !> (c) The Numerical Algorithms Group (NAG) Ltd, 2009 on behalf of the HECToR project ! ***************************************************************************** - SUBROUTINE rs_grid_release_descriptor(rs_desc,error) + SUBROUTINE rs_grid_release_descriptor(rs_desc) TYPE(realspace_grid_desc_type), POINTER :: rs_desc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rs_grid_release_descriptor', & routineP = moduleN//':'//routineN @@ -2278,41 +2250,41 @@ SUBROUTINE rs_grid_release_descriptor(rs_desc,error) failure=.FALSE. IF (ASSOCIATED(rs_desc)) THEN - CPPreconditionNoFail(rs_desc%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(rs_desc%ref_count>0,cp_failure_level,routineP) rs_desc%ref_count=rs_desc%ref_count-1 IF (rs_desc%ref_count==0) THEN - CALL pw_grid_release(rs_desc%pw,error=error) + CALL pw_grid_release(rs_desc%pw) IF ( rs_desc % parallel ) THEN ! release the group communicator CALL mp_comm_free ( rs_desc % group ) DEALLOCATE ( rs_desc % virtual2real, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_desc % real2virtual, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (rs_desc % distributed) THEN DEALLOCATE ( rs_desc % rank2coord , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_desc % coord2rank , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_desc % lb_global , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_desc % ub_global , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_desc % x2coord , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_desc % y2coord , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( rs_desc % z2coord , STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(rs_desc, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(rs_desc) END IF END IF diff --git a/src/pw/rs_methods.F b/src/pw/rs_methods.F index 7e2ae6e43c..7a043ed12f 100644 --- a/src/pw/rs_methods.F +++ b/src/pw/rs_methods.F @@ -53,20 +53,18 @@ MODULE rs_methods !> \param f input function !> \param df derivative of f !> \param rs_grid real-space grid -!> \param error cp2k error !> \par History: !> - Creation (15.11.2013,MK) !> - Refactored and moved here from qs_sccs.F (12.2014, Hossein Bani-Hashemian) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE derive_fdm_cd3(f,df,rs_grid,error) + SUBROUTINE derive_fdm_cd3(f,df,rs_grid) TYPE(pw_type), POINTER :: f TYPE(pw_p_type), DIMENSION(3), & INTENT(OUT) :: df TYPE(realspace_grid_type), POINTER :: rs_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'derive_fdm_cd3', & routineP = moduleN//':'//routineN @@ -85,13 +83,13 @@ SUBROUTINE derive_fdm_cd3(f,df,rs_grid,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,failure) ! Setup rs_desc => rs_grid%desc - CALL rs_pw_transfer(rs_grid,f,pw2rs,error=error) + CALL rs_pw_transfer(rs_grid,f,pw2rs) DO i=1,3 - CALL rs_grid_create(drs_grid(i)%rs_grid,rs_desc,error=error) + CALL rs_grid_create(drs_grid(i)%rs_grid,rs_desc) CALL rs_grid_zero(drs_grid(i)%rs_grid) END DO @@ -120,8 +118,8 @@ SUBROUTINE derive_fdm_cd3(f,df,rs_grid,error) ! Cleanup DO i=1,3 - CALL rs_pw_transfer(drs_grid(i)%rs_grid, df(i)%pw,rs2pw,error=error) - CALL rs_grid_release(drs_grid(i)%rs_grid,error=error) + CALL rs_pw_transfer(drs_grid(i)%rs_grid, df(i)%pw,rs2pw) + CALL rs_grid_release(drs_grid(i)%rs_grid) END DO CALL timestop(handle) @@ -133,20 +131,18 @@ END SUBROUTINE derive_fdm_cd3 !> \param f input function !> \param df derivative of f !> \param rs_grid real-space grid -!> \param error cp2k error !> \par History: !> - Creation (15.11.2013,MK) !> - Refactored and moved here from qs_sccs.F (12.2014, Hossein Bani-Hashemian) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE derive_fdm_cd5(f,df,rs_grid,error) + SUBROUTINE derive_fdm_cd5(f,df,rs_grid) TYPE(pw_type), POINTER :: f TYPE(pw_p_type), DIMENSION(3), & INTENT(INOUT) :: df TYPE(realspace_grid_type), POINTER :: rs_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'derive_fdm_cd5', & routineP = moduleN//':'//routineN @@ -165,13 +161,13 @@ SUBROUTINE derive_fdm_cd5(f,df,rs_grid,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,failure) ! Setup rs_desc => rs_grid%desc - CALL rs_pw_transfer(rs_grid,f,pw2rs,error=error) + CALL rs_pw_transfer(rs_grid,f,pw2rs) DO i=1,3 - CALL rs_grid_create(drs_grid(i)%rs_grid,rs_desc,error=error) + CALL rs_grid_create(drs_grid(i)%rs_grid,rs_desc) CALL rs_grid_zero(drs_grid(i)%rs_grid) END DO @@ -200,8 +196,8 @@ SUBROUTINE derive_fdm_cd5(f,df,rs_grid,error) ! Cleanup DO i=1,3 - CALL rs_pw_transfer(drs_grid(i)%rs_grid, df(i)%pw,rs2pw,error=error) - CALL rs_grid_release(drs_grid(i)%rs_grid,error=error) + CALL rs_pw_transfer(drs_grid(i)%rs_grid, df(i)%pw,rs2pw) + CALL rs_grid_release(drs_grid(i)%rs_grid) END DO CALL timestop(handle) @@ -213,20 +209,18 @@ END SUBROUTINE derive_fdm_cd5 !> \param f input function !> \param df derivative of f !> \param rs_grid real-space grid -!> \param error cp2k error !> \par History: !> - Creation (15.11.2013,MK) !> - Refactored and moved here from qs_sccs.F (12.2014, Hossein Bani-Hashemian) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE derive_fdm_cd7(f,df,rs_grid,error) + SUBROUTINE derive_fdm_cd7(f,df,rs_grid) TYPE(pw_type), POINTER :: f TYPE(pw_p_type), DIMENSION(3), & INTENT(OUT) :: df TYPE(realspace_grid_type), POINTER :: rs_grid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'derive_fdm_cd7', & routineP = moduleN//':'//routineN @@ -245,13 +239,13 @@ SUBROUTINE derive_fdm_cd7(f,df,rs_grid,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,failure) ! Setup rs_desc => rs_grid%desc - CALL rs_pw_transfer(rs_grid,f,pw2rs,error=error) + CALL rs_pw_transfer(rs_grid,f,pw2rs) DO i=1,3 - CALL rs_grid_create(drs_grid(i)%rs_grid,rs_desc,error=error) + CALL rs_grid_create(drs_grid(i)%rs_grid,rs_desc) CALL rs_grid_zero(drs_grid(i)%rs_grid) END DO @@ -283,8 +277,8 @@ SUBROUTINE derive_fdm_cd7(f,df,rs_grid,error) ! Cleanup DO i=1,3 - CALL rs_pw_transfer(drs_grid(i)%rs_grid, df(i)%pw,rs2pw,error=error) - CALL rs_grid_release(drs_grid(i)%rs_grid,error=error) + CALL rs_pw_transfer(drs_grid(i)%rs_grid, df(i)%pw,rs2pw) + CALL rs_grid_release(drs_grid(i)%rs_grid) END DO CALL timestop(handle) @@ -301,19 +295,17 @@ END SUBROUTINE derive_fdm_cd7 !> \param x_locl x grid vetor of the simulation box local to this process !> \param y_locl y grid vetor of the simulation box local to this process !> \param z_locl z grid vetor of the simulation box local to this process -!> \param error cp2k error !> \par History !> 07.2014 created [Hossein Bani-Hashemian] !> 07.2015 moved here from dirichlet_bc_utils.F [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE setup_grid_axes(pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, error) + SUBROUTINE setup_grid_axes(pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid REAL(dp), ALLOCATABLE, DIMENSION(:), & INTENT(OUT) :: x_glbl, y_glbl, z_glbl, & x_locl, y_locl, z_locl - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_grid_axes', & routineP = moduleN//':'//routineN @@ -399,13 +391,12 @@ END SUBROUTINE setup_grid_axes !> \param z_glbl z grid vetor of the simulation box !> \param pw_in the input function !> \param pw_out the convoluted function -!> \param error cp2k error !> \par History !> 10.2014 created [Hossein Bani-Hashemian] !> 07.2015 moved here from ps_implicit_methods.F [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, pw_in, pw_out, error) + SUBROUTINE pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, pw_in, pw_out) TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool REAL(dp), INTENT(IN) :: zeta @@ -413,7 +404,6 @@ SUBROUTINE pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, pw_in, pw_out, er INTENT(IN) :: x_glbl, y_glbl, z_glbl TYPE(pw_type), INTENT(IN), POINTER :: pw_in TYPE(pw_type), INTENT(INOUT), POINTER :: pw_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_mollifier', & routineP = moduleN//':'//routineN @@ -438,12 +428,12 @@ SUBROUTINE pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, pw_in, pw_out, er lb2 = bounds_local(1,2); ub2 = bounds_local(2,2) lb3 = bounds_local(1,3); ub3 = bounds_local(2,3) - CALL pw_pool_create_pw(pw_pool, G, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, G_gs, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, pw_in_gs, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, pw_out_gs, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool, G, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(pw_pool, G_gs, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_pool_create_pw(pw_pool, pw_in_gs, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_pool_create_pw(pw_pool, pw_out_gs, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) - CALL pw_zero(G, error=error) + CALL pw_zero(G) xmin = x_glbl(bounds(1,1)); xmax = x_glbl(bounds(2,1)) ymin = y_glbl(bounds(1,2)); ymax = y_glbl(bounds(2,2)) zmin = z_glbl(bounds(1,3)); zmax = z_glbl(bounds(2,3)) @@ -472,19 +462,19 @@ SUBROUTINE pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, pw_in, pw_out, er END DO END DO END DO - CALL pw_scale(G, (1.0_dp/zeta)**3, error) - normfact = pw_integrate_function(G,error=error) - CALL pw_scale(G, 1.0_dp/normfact, error) + CALL pw_scale(G, (1.0_dp/zeta)**3) + normfact = pw_integrate_function(G) + CALL pw_scale(G, 1.0_dp/normfact) - CALL pw_transfer(G, G_gs, error=error) - CALL pw_transfer(pw_in, pw_in_gs, error=error) + CALL pw_transfer(G, G_gs) + CALL pw_transfer(pw_in, pw_in_gs) pw_out_gs%cc = G_gs%cc * pw_in_gs%cc - CALL pw_transfer(pw_out_gs, pw_out, error=error) + CALL pw_transfer(pw_out_gs, pw_out) ! multiply by the reciprocal of the forward Fourier transform normalization prefactor (here 1/N, by convention) - CALL pw_scale(pw_out, REAL(pw_grid%ngpts,KIND=dp), error=error) + CALL pw_scale(pw_out, REAL(pw_grid%ngpts,KIND=dp)) ! from discrete convolution to continuous convolution - CALL pw_scale(pw_out, pw_grid%dvol, error=error) + CALL pw_scale(pw_out, pw_grid%dvol) DO k = lb3, ub3 DO j = lb2, ub2 @@ -494,10 +484,10 @@ SUBROUTINE pw_mollifier(pw_pool, zeta, x_glbl, y_glbl, z_glbl, pw_in, pw_out, er END DO END DO - CALL pw_pool_give_back_pw(pw_pool, G, error=error) - CALL pw_pool_give_back_pw(pw_pool, G_gs, error=error) - CALL pw_pool_give_back_pw(pw_pool, pw_in_gs, error=error) - CALL pw_pool_give_back_pw(pw_pool, pw_out_gs, error=error) + CALL pw_pool_give_back_pw(pw_pool, G) + CALL pw_pool_give_back_pw(pw_pool, G_gs) + CALL pw_pool_give_back_pw(pw_pool, pw_in_gs) + CALL pw_pool_give_back_pw(pw_pool, pw_out_gs) CALL timestop(handle) CONTAINS diff --git a/src/pw_env_methods.F b/src/pw_env_methods.F index 974659bb56..4ff4e9fc5b 100644 --- a/src/pw_env_methods.F +++ b/src/pw_env_methods.F @@ -110,15 +110,12 @@ MODULE pw_env_methods ! ***************************************************************************** !> \brief creates a pw_env, if qs_env is given calls pw_env_rebuild !> \param pw_env the pw_env that gets created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_env_create(pw_env,error) +SUBROUTINE pw_env_create(pw_env) TYPE(pw_env_type), POINTER :: pw_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_env_create', & routineP = moduleN//':'//routineN @@ -130,9 +127,9 @@ SUBROUTINE pw_env_create(pw_env,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(pw_env),cp_failure_level,routineP,failure) ALLOCATE(pw_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(pw_env%pw_pools, pw_env%gridlevel_info,pw_env%poisson_env, & pw_env%cube_info, pw_env%rs_descs, pw_env%rs_grids, & pw_env%xc_pw_pool, pw_env%vdw_pw_pool, pw_env%lgrid, & @@ -149,18 +146,15 @@ END SUBROUTINE pw_env_create !> \param pw_env the environment to rebuild !> \param qs_env the qs_env where to get the cell, cutoffs,... !> \param external_para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) +SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env) TYPE(pw_env_type), POINTER :: pw_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), OPTIONAL, & POINTER :: external_para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_env_rebuild', & routineP = moduleN//':'//routineN @@ -226,38 +220,37 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) cell=cell,& para_env=para_env,& input=input,& - dispersion_env=dispersion_env,& - error=error) - - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL pw_pool_release(pw_env%vdw_pw_pool,error=error) - CALL pw_pool_release(pw_env%xc_pw_pool,error=error) - CALL pw_pools_dealloc(pw_env%pw_pools,error=error) + dispersion_env=dispersion_env) + + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,failure) + CALL pw_pool_release(pw_env%vdw_pw_pool) + CALL pw_pool_release(pw_env%xc_pw_pool) + CALL pw_pools_dealloc(pw_env%pw_pools) IF (ASSOCIATED(pw_env%rs_descs)) THEN DO i=1, SIZE(pw_env%rs_descs) - CALL rs_grid_release_descriptor(pw_env%rs_descs(i)%rs_desc, error=error) + CALL rs_grid_release_descriptor(pw_env%rs_descs(i)%rs_desc) END DO DEALLOCATE(pw_env%rs_descs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(pw_env%rs_grids)) THEN DO i=1, SIZE(pw_env%rs_grids) - CALL rs_grid_release(pw_env%rs_grids(i)%rs_grid, error=error) + CALL rs_grid_release(pw_env%rs_grids(i)%rs_grid) END DO DEALLOCATE(pw_env%rs_grids,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL lgrid_release(pw_env%lgrid,error) + CALL lgrid_release(pw_env%lgrid) IF (ASSOCIATED(pw_env%gridlevel_info)) THEN - CALL destroy_gaussian_gridlevel(pw_env%gridlevel_info,error=error) + CALL destroy_gaussian_gridlevel(pw_env%gridlevel_info) ELSE ALLOCATE(pw_env%gridlevel_info,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(dft_control%qs_control%gapw) THEN - CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole,error=error) - CPPostcondition(ASSOCIATED(rho0_mpole),cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole) + CPPostcondition(ASSOCIATED(rho0_mpole),cp_failure_level,routineP,failure) CALL get_rho0_mpole(rho0_mpole=rho0_mpole,& zet0_h=zet0,max_rpgf0_s=max_rpgf0_s) END IF @@ -267,7 +260,7 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) CALL destroy_cube_info(pw_env%cube_info(igrid_level)) END DO DEALLOCATE(pw_env%cube_info,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF NULLIFY(pw_env%pw_pools, pw_env%cube_info) @@ -279,12 +272,12 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) IF (PRESENT(external_para_env)) THEN para_env=>external_para_env - CPPostcondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) ENDIF ! interpolation section - pw_env%interp_section => section_vals_get_subs_vals(input,"DFT%MGRID%INTERPOLATOR",error=error) + pw_env%interp_section => section_vals_get_subs_vals(input,"DFT%MGRID%INTERPOLATOR") - CALL get_qs_env ( qs_env, use_ref_cell = use_ref_cell ,error=error) + CALL get_qs_env ( qs_env, use_ref_cell = use_ref_cell) IF (use_ref_cell) THEN my_cell => cell_ref ELSE @@ -293,20 +286,20 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) rel_cutoff = dft_control%qs_control%relative_cutoff cutoff => dft_control%qs_control%e_cutoff CALL section_vals_val_get(input,"DFT%XC%XC_GRID%USE_FINER_GRID",& - l_val=uf_grid,error=error) + l_val=uf_grid) ngrid_level = SIZE(cutoff) ! init gridlevel_info XXXXXXXXX setup mapping to the effective cutoff ? ! XXXXXXXXX the cutoff array here is more a 'wish-list' ! XXXXXXXXX same holds for radius print_section=>section_vals_get_subs_vals(input, & - "PRINT%GRID_INFORMATION",error=error) + "PRINT%GRID_INFORMATION") CALL init_gaussian_gridlevel(pw_env%gridlevel_info,& ngrid_levels=ngrid_level,cutoff=cutoff,rel_cutoff=rel_cutoff, & - print_section=print_section,error=error) + print_section=print_section) ! init pw_grids and pools ALLOCATE(pw_pools(ngrid_level),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (dft_control % qs_control % commensurate_mgrids) THEN ncommensurate=ngrid_level @@ -331,14 +324,14 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) CALL setup_super_ref_grid(super_ref_grid,mt_super_ref_grid,& xc_super_ref_grid, cutilev, grid_span, spherical, my_cell, para_env, & qs_env%input, ncommensurate, uf_grid=uf_grid,& - print_section=print_section,error=error) + print_section=print_section) old_pw_grid => super_ref_grid ! ! Setup of the multi-grid pw_grid and pw_pools ! - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iounit = cp_print_key_unit_nr(logger,print_section,'',& - extension='.Log',error=error) + extension='.Log') IF ( dft_control % qs_control % pw_grid_opt % spherical ) THEN grid_span = HALFSPACE @@ -359,10 +352,10 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) ! methods that require smoothing or nearest neighbor have to use a plane distributed setup ! find the xc properties (FIXME this could miss other xc sections that operate on the grid ...) - CALL get_qs_env(qs_env=qs_env,input=input,error=error) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) - xc_deriv_method_id=section_get_ival(xc_section,"XC_GRID%XC_DERIV",error) - xc_smooth_method_id=section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO",error) + CALL get_qs_env(qs_env=qs_env,input=input) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") + xc_deriv_method_id=section_get_ival(xc_section,"XC_GRID%XC_DERIV") + xc_smooth_method_id=section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO") smooth_required=.FALSE. SELECT CASE(xc_deriv_method_id) CASE(xc_deriv_pw,xc_deriv_collocate,xc_deriv_spline3,xc_deriv_spline2) @@ -371,7 +364,7 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) xc_deriv_spline3_smooth,xc_deriv_nn10_smooth,xc_deriv_nn50_smooth) smooth_required=smooth_required.OR..TRUE. CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT SELECT CASE(xc_smooth_method_id) CASE(xc_rho_no_smooth) @@ -379,28 +372,26 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) CASE(xc_rho_spline2_smooth,xc_rho_spline3_smooth,xc_rho_nn10,xc_rho_nn50) smooth_required=smooth_required.OR..TRUE. CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! EPR, NMR, EFG can require splines. If the linres/EFG section is present we assume ! it could be on and splines might be used (not quite sure if this is due to their use of splines or something else) linres_section => section_vals_get_subs_vals(section_vals=input,& - subsection_name="PROPERTIES%LINRES",& - error=error) - CALL section_vals_get(linres_section,explicit=linres_present,error=error) + subsection_name="PROPERTIES%LINRES") + CALL section_vals_get(linres_section,explicit=linres_present) IF (linres_present) THEN smooth_required=smooth_required.OR..TRUE. ENDIF efg_section => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%ELECTRIC_FIELD_GRADIENT",& - error=error) - CALL section_vals_get(efg_section,explicit=efg_present,error=error) + subsection_name="DFT%PRINT%ELECTRIC_FIELD_GRADIENT") + CALL section_vals_get(efg_section,explicit=efg_present) IF (efg_present) THEN smooth_required=smooth_required.OR..TRUE. ENDIF DO igrid_level=1,ngrid_level - CALL pw_grid_create(pw_grid,para_env%group,error=error) + CALL pw_grid_create(pw_grid,para_env%group) cutilev = cutoff(igrid_level) @@ -431,7 +422,7 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) blocked=do_pw_grid_blocked_false,& ref_grid=old_pw_grid,& rs_dims=distribution_layout,& - iounit=iounit,error=error) + iounit=iounit) old_pw_grid => pw_grid ELSE CALL pw_grid_setup(my_cell%hmat,pw_grid,grid_span=grid_span,& @@ -440,7 +431,7 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) ncommensurate=ncommensurate,icommensurate=igrid_level,& blocked=blocked_id,& rs_dims=distribution_layout,& - iounit=iounit,error=error) + iounit=iounit) old_pw_grid => pw_grid END IF ELSE @@ -451,20 +442,20 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) blocked=do_pw_grid_blocked_false,& ref_grid=old_pw_grid,& rs_dims=distribution_layout,& - iounit=iounit,error=error) + iounit=iounit) END IF ! init pw_pools NULLIFY(pw_pools(igrid_level)%pool) - CALL pw_pool_create(pw_pools(igrid_level)%pool,pw_grid=pw_grid,error=error) + CALL pw_pool_create(pw_pools(igrid_level)%pool,pw_grid=pw_grid) - CALL pw_grid_release(pw_grid,error=error) + CALL pw_grid_release(pw_grid) END DO pw_env%pw_pools => pw_pools - CALL cp_print_key_finished_output(iounit,logger,print_section,'',error=error) + CALL cp_print_key_finished_output(iounit,logger,print_section,'') ! init auxbas_grid DO i=1,ngrid_level @@ -474,11 +465,11 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) ! init xc_pool IF (ASSOCIATED(xc_super_ref_grid)) THEN CALL pw_pool_create(pw_env%xc_pw_pool,& - pw_grid=xc_super_ref_grid,error=error) - CALL pw_grid_release(xc_super_ref_grid,error=error) + pw_grid=xc_super_ref_grid) + CALL pw_grid_release(xc_super_ref_grid) ELSE pw_env%xc_pw_pool => pw_pools(pw_env%auxbas_grid)%pool - CALL pw_pool_retain(pw_env%xc_pw_pool,error=error) + CALL pw_pool_retain(pw_env%xc_pw_pool) END IF ! init vdw_pool @@ -489,8 +480,8 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) END IF END IF IF (set_vdw_pool) THEN - CPPrecondition(ASSOCIATED(old_pw_grid),cp_failure_level,routineP,error,failure) - CALL pw_grid_create(vdw_grid,para_env%group,error=error) + CPPrecondition(ASSOCIATED(old_pw_grid),cp_failure_level,routineP,failure) + CALL pw_grid_create(vdw_grid,para_env%group) CALL pw_grid_setup(my_cell%hmat,vdw_grid,grid_span=grid_span,& cutoff=dispersion_env%pw_cutoff,& spherical=spherical,odd=odd,fft_usage=.TRUE.,& @@ -498,29 +489,28 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) blocked=do_pw_grid_blocked_false,& ref_grid=old_pw_grid,& rs_dims=distribution_layout,& - iounit=iounit,error=error) - CALL pw_pool_create(pw_env%vdw_pw_pool,pw_grid=vdw_grid,error=error) - CALL pw_grid_release(vdw_grid,error=error) + iounit=iounit) + CALL pw_pool_create(pw_env%vdw_pw_pool,pw_grid=vdw_grid) + CALL pw_grid_release(vdw_grid) ELSE pw_env%vdw_pw_pool => pw_pools(pw_env%auxbas_grid)%pool - CALL pw_pool_retain(pw_env%vdw_pw_pool,error=error) + CALL pw_pool_retain(pw_env%vdw_pw_pool) END IF ! complete init of the poisson_env IF (.NOT.ASSOCIATED(pw_env%poisson_env)) THEN - CALL pw_poisson_create(pw_env%poisson_env,error=error) + CALL pw_poisson_create(pw_env%poisson_env) END IF - poisson_section => section_vals_get_subs_vals(input,"DFT%POISSON",& - error=error) + poisson_section => section_vals_get_subs_vals(input,"DFT%POISSON") - CALL pw_poisson_read_parameters(poisson_section, poisson_params, error) + CALL pw_poisson_read_parameters(poisson_section, poisson_params) CALL pw_poisson_set(pw_env%poisson_env,cell_hmat=my_cell%hmat,pw_pools=pw_env%pw_pools,& parameters=poisson_params,mt_super_ref_pw_grid=mt_super_ref_grid,& dct_pw_grid=dct_pw_grid, dct_aux_pw_grid=dct_aux_pw_grid,& - use_level=pw_env%auxbas_grid,error=error) - CALL pw_grid_release(mt_super_ref_grid,error=error) - CALL pw_grid_release(dct_pw_grid,error=error) - CALL pw_grid_release(dct_aux_pw_grid,error=error) + use_level=pw_env%auxbas_grid) + CALL pw_grid_release(mt_super_ref_grid) + CALL pw_grid_release(dct_pw_grid) + CALL pw_grid_release(dct_aux_pw_grid) ! ! If reference cell is present, then use pw_grid_change to keep bounds constant... ! do not re-init the Gaussian grid level (fix the gridlevel on which the pgf should go. @@ -530,11 +520,11 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) CALL pw_grid_change ( cell%hmat, pw_pools ( igrid_level ) % pool % pw_grid ) ENDDO IF (set_vdw_pool) CALL pw_grid_change( cell%hmat, pw_env%vdw_pw_pool%pw_grid ) - CALL pw_poisson_read_parameters(poisson_section, poisson_params, error) + CALL pw_poisson_read_parameters(poisson_section, poisson_params) CALL pw_poisson_set(pw_env%poisson_env,cell_hmat=cell%hmat,pw_pools=pw_env%pw_pools,& parameters=poisson_params,mt_super_ref_pw_grid=mt_super_ref_grid,& dct_pw_grid=dct_pw_grid, dct_aux_pw_grid=dct_aux_pw_grid,& - use_level=pw_env%auxbas_grid,error=error) + use_level=pw_env%auxbas_grid) END IF ! setup dct_pw_grid (an extended pw_grid) for Discrete Cosine Transformation (DCT) @@ -542,7 +532,7 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) (poisson_params%ps_implicit_params%boundary_condition .EQ. NEUMANN_BC)) THEN CALL setup_dct_pw_grids(pw_env%poisson_env%pw_pools(pw_env%poisson_env%pw_level)%pool%pw_grid,& my_cell%hmat, & - pw_env%poisson_env%dct_pw_grid, pw_env%poisson_env%dct_aux_pw_grid, error) + pw_env%poisson_env%dct_pw_grid, pw_env%poisson_env%dct_aux_pw_grid) END IF ! setup real space grid for finite difference derivatives of dielectric constant function IF ( poisson_params%has_dielectric .AND. & @@ -551,8 +541,7 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) (poisson_params%dielectric_params%derivative_method .EQ. derivative_cd7))) THEN CALL setup_diel_rs_grid(pw_env%poisson_env%diel_rs_grid, & poisson_params%dielectric_params%derivative_method, input, & - pw_env%poisson_env%pw_pools(pw_env%poisson_env%pw_level)%pool%pw_grid,& - error) + pw_env%poisson_env%pw_pools(pw_env%poisson_env%pw_level)%pool%pw_grid) END IF ! @@ -563,9 +552,9 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) ! ALLOCATE(radius(ngrid_level),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL compute_max_radius(radius, pw_env, qs_env, error) + CALL compute_max_radius(radius, pw_env, qs_env) ! ! @@ -573,13 +562,13 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) ! ! ALLOCATE(rs_descs(ngrid_level),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rs_grids(ngrid_level),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (pw_env%cube_info(ngrid_level),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) higher_grid_layout=(/-1,-1,-1/) DO igrid_level=1,ngrid_level @@ -590,35 +579,35 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) pw_grid%dr(:), pw_grid%dh(:,:), pw_grid%dh_inv(:,:), pw_grid%orthorhombic,& radius(igrid_level)) - rs_grid_section=>section_vals_get_subs_vals(input,"DFT%MGRID%RS_GRID",error=error) + rs_grid_section=>section_vals_get_subs_vals(input,"DFT%MGRID%RS_GRID") CALL init_input_type(input_settings,nsmax=2*MAX(1,return_cube_max_iradius(pw_env%cube_info(igrid_level)))+1,& rs_grid_section=rs_grid_section,ilevel=igrid_level,& - higher_grid_layout=higher_grid_layout,error=error) + higher_grid_layout=higher_grid_layout) NULLIFY(rs_descs(igrid_level)%rs_desc) - CALL rs_grid_create_descriptor(rs_descs(igrid_level)%rs_desc,pw_grid,input_settings, error=error) + CALL rs_grid_create_descriptor(rs_descs(igrid_level)%rs_desc,pw_grid,input_settings) IF (rs_descs(igrid_level)%rs_desc%distributed) higher_grid_layout=rs_descs(igrid_level)%rs_desc%group_dim NULLIFY(rs_grids(igrid_level)%rs_grid) - CALL rs_grid_create(rs_grids(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc, error=error) + CALL rs_grid_create(rs_grids(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc) END DO pw_env%rs_descs => rs_descs pw_env%rs_grids => rs_grids DEALLOCATE(radius,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Initialise the lgrids which may be used by OpenMP threads in QS routines ! (but don't yet allocate the lgrid, in case we don't need it) - CALL lgrid_create(pw_env%lgrid, pw_env%rs_descs, error) + CALL lgrid_create(pw_env%lgrid, pw_env%rs_descs) ! Print grid information - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iounit = cp_print_key_unit_nr(logger,print_section,'',& - extension='.Log',error=error) + extension='.Log') IF (iounit > 0) THEN SELECT CASE (poisson_params%solver) CASE(pw_poisson_periodic) @@ -717,13 +706,13 @@ SUBROUTINE pw_env_rebuild(pw_env, qs_env, external_para_env, error) END IF END IF should_output = BTEST(cp_print_key_should_output(logger%iter_info,& - print_section,'',error=error),cp_p_file) + print_section,''),cp_p_file) IF (should_output) THEN DO igrid_level=1,ngrid_level - CALL rs_grid_print(rs_grids(igrid_level)%rs_grid,iounit,error=error) + CALL rs_grid_print(rs_grids(igrid_level)%rs_grid,iounit) END DO END IF - CALL cp_print_key_finished_output(iounit,logger,print_section,"",error=error) + CALL cp_print_key_finished_output(iounit,logger,print_section,"") CALL timestop(handle) @@ -735,16 +724,14 @@ END SUBROUTINE pw_env_rebuild !> \param radius ... !> \param pw_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 10.2010 refactored [Joost VandeVondele] !> \author Joost VandeVondele ! ***************************************************************************** -SUBROUTINE compute_max_radius(radius, pw_env, qs_env, error) +SUBROUTINE compute_max_radius(radius, pw_env, qs_env) REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: radius TYPE(pw_env_type), POINTER :: pw_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_max_radius', & routineP = moduleN//':'//routineN @@ -778,11 +765,11 @@ SUBROUTINE compute_max_radius(radius, pw_env, qs_env, error) NULLIFY(dft_control, qs_kind_set, rho0_mpole) CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set, & - dft_control=dft_control, error=error) + dft_control=dft_control) IF(dft_control%qs_control%gapw) THEN - CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole,error=error) - CPPostcondition(ASSOCIATED(rho0_mpole),cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole) + CPPostcondition(ASSOCIATED(rho0_mpole),cp_failure_level,routineP,failure) CALL get_rho0_mpole(rho0_mpole=rho0_mpole,zet0_h=zet0,max_rpgf0_s=max_rpgf0_s) END IF @@ -826,7 +813,7 @@ SUBROUTINE compute_max_radius(radius, pw_env, qs_env, error) ! this should, at a give point be changed ! so that also for the core a multigrid is used CALL get_qs_kind(qs_kind_set(ikind),& - alpha_core_charge=alpha,ccore_charge=core_charge,error=error) + alpha_core_charge=alpha,ccore_charge=core_charge) IF (alpha > 0.0_dp .AND. core_charge.NE.0.0_dp) THEN maxradius=MAX(maxradius,exp_radius( 0, alpha, & @@ -841,7 +828,7 @@ SUBROUTINE compute_max_radius(radius, pw_env, qs_env, error) ! IF(basis_type=="LRI" .AND. dft_control%qs_control%lri_optbas) CYCLE CALL get_qs_kind(qs_kind=qs_kind,& - basis_set=orb_basis_set,basis_type=basis_type,error=error) + basis_set=orb_basis_set,basis_type=basis_type) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE @@ -852,7 +839,7 @@ SUBROUTINE compute_max_radius(radius, pw_env, qs_env, error) qs_kind => qs_kind_set(jkind) CALL get_qs_kind(qs_kind=qs_kind,& - basis_set=orb_basis_set,basis_type=basis_type,error=error) + basis_set=orb_basis_set,basis_type=basis_type) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE CALL get_gto_basis_set(gto_basis_set=orb_basis_set, & @@ -926,15 +913,13 @@ END SUBROUTINE compute_max_radius !> \param my_ncommensurate ... !> \param uf_grid ... !> \param print_section ... -!> \param error ... !> \author 03-2005 Teodoro Laino [teo] !> \note !> move somewere else? ! ***************************************************************************** SUBROUTINE setup_super_ref_grid(super_ref_pw_grid,mt_super_ref_pw_grid,& xc_super_ref_pw_grid, cutilev, grid_span, spherical,& - cell_ref, para_env, input, my_ncommensurate, uf_grid,print_section, & - error) + cell_ref, para_env, input, my_ncommensurate, uf_grid,print_section) TYPE(pw_grid_type), POINTER :: super_ref_pw_grid, & mt_super_ref_pw_grid, & xc_super_ref_pw_grid @@ -947,7 +932,6 @@ SUBROUTINE setup_super_ref_grid(super_ref_pw_grid,mt_super_ref_pw_grid,& INTEGER, INTENT(IN) :: my_ncommensurate LOGICAL, INTENT(in) :: uf_grid TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_super_ref_grid', & routineP = moduleN//':'//routineN @@ -960,60 +944,59 @@ SUBROUTINE setup_super_ref_grid(super_ref_pw_grid,mt_super_ref_pw_grid,& failure = .FALSE. NULLIFY(poisson_section) - CPPrecondition(.NOT.ASSOCIATED(mt_super_ref_pw_grid),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(xc_super_ref_pw_grid),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(super_ref_pw_grid),cp_failure_level,routineP,error,failure) - poisson_section => section_vals_get_subs_vals(input,"DFT%POISSON",error=error) - CALL section_vals_val_get(poisson_section,"POISSON_SOLVER",i_val=my_val,error=error) + CPPrecondition(.NOT.ASSOCIATED(mt_super_ref_pw_grid),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(xc_super_ref_pw_grid),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(super_ref_pw_grid),cp_failure_level,routineP,failure) + poisson_section => section_vals_get_subs_vals(input,"DFT%POISSON") + CALL section_vals_val_get(poisson_section,"POISSON_SOLVER",i_val=my_val) ! ! Check if grids will be the same... In this case we don't use a super-reference grid ! mt_s_grid=.FALSE. IF (my_val==pw_poisson_mt) THEN CALL section_vals_val_get(poisson_section,"MT%REL_CUTOFF",& - r_val=mt_rel_cutoff,error=error) + r_val=mt_rel_cutoff) IF (mt_rel_cutoff>1._dp) mt_s_grid=.TRUE. END IF - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iounit = cp_print_key_unit_nr(logger,print_section,"",& - extension=".Log",error=error) + extension=".Log") IF (uf_grid) THEN - CALL pw_grid_create(xc_super_ref_pw_grid,para_env%group,error=error) + CALL pw_grid_create(xc_super_ref_pw_grid,para_env%group) CALL pw_grid_setup(cell_ref%hmat, xc_super_ref_pw_grid, grid_span=grid_span,& cutoff=4._dp*cutilev,spherical=spherical,odd=.FALSE., fft_usage=.TRUE., & ncommensurate=my_ncommensurate,icommensurate=1,& blocked=do_pw_grid_blocked_false, rs_dims=(/para_env%num_pe,1/),& - iounit=iounit,error=error) + iounit=iounit) super_ref_pw_grid => xc_super_ref_pw_grid END IF IF (mt_s_grid) THEN - CALL pw_grid_create(mt_super_ref_pw_grid,para_env%group,error=error) + CALL pw_grid_create(mt_super_ref_pw_grid,para_env%group) IF (ASSOCIATED(xc_super_ref_pw_grid)) THEN CALL cp_unimplemented_error(routineP,& - "special grid for mt and fine xc grid not compatible",& - error=error) + "special grid for mt and fine xc grid not compatible") ELSE my_cutilev=cutilev*mt_rel_cutoff no = pw_grid_init_setup(cell_ref%hmat,cutoff=cutilev,spherical=spherical,& - odd=.FALSE.,fft_usage=.TRUE.,ncommensurate=0,icommensurate=1,error=error) + odd=.FALSE.,fft_usage=.TRUE.,ncommensurate=0,icommensurate=1) nn = pw_grid_init_setup(cell_ref%hmat,cutoff=my_cutilev,spherical=spherical,& - odd=.FALSE.,fft_usage=.TRUE.,ncommensurate=0,icommensurate=1,error=error) + odd=.FALSE.,fft_usage=.TRUE.,ncommensurate=0,icommensurate=1) ! bug appears for nn==no, also in old versions - CPPrecondition(ALL(nn>no),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(nn>no),cp_failure_level,routineP,failure) CALL pw_grid_setup(cell_ref%hmat, mt_super_ref_pw_grid, & cutoff=my_cutilev,spherical=spherical,fft_usage=.TRUE., & blocked=do_pw_grid_blocked_false, rs_dims=(/para_env%num_pe,1/),& - iounit=iounit,error=error) + iounit=iounit) super_ref_pw_grid => mt_super_ref_pw_grid END IF END IF CALL cp_print_key_finished_output(iounit,logger,print_section,& - "",error=error) + "") END SUBROUTINE setup_super_ref_grid ! ***************************************************************************** @@ -1023,18 +1006,16 @@ END SUBROUTINE setup_super_ref_grid !> \param method preferred finite difference derivative method !> \param input input file !> \param pw_grid plane-wave grid -!> \param error cp2k error !> \par History !> 12.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE setup_diel_rs_grid(diel_rs_grid, method, input, pw_grid, error) + SUBROUTINE setup_diel_rs_grid(diel_rs_grid, method, input, pw_grid) TYPE(realspace_grid_type), POINTER :: diel_rs_grid INTEGER, INTENT(IN) :: method TYPE(section_vals_type), POINTER :: input TYPE(pw_grid_type), POINTER :: pw_grid - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_diel_rs_grid', & routineP = moduleN//':'//routineN @@ -1047,7 +1028,7 @@ SUBROUTINE setup_diel_rs_grid(diel_rs_grid, method, input, pw_grid, error) CALL timeset(routineN,handle) NULLIFY (rs_desc) - rs_grid_section => section_vals_get_subs_vals(input,"DFT%MGRID%RS_GRID",error=error) + rs_grid_section => section_vals_get_subs_vals(input,"DFT%MGRID%RS_GRID") SELECT CASE (method) CASE (derivative_cd3) border_points = 1 @@ -1057,11 +1038,11 @@ SUBROUTINE setup_diel_rs_grid(diel_rs_grid, method, input, pw_grid, error) border_points = 3 END SELECT CALL init_input_type(input_settings,2*border_points+1,rs_grid_section,& - 1,(/-1,-1,-1/),error) + 1,(/-1,-1,-1/)) CALL rs_grid_create_descriptor(rs_desc,pw_grid,input_settings,& - border_points=border_points,error=error) - CALL rs_grid_create(diel_rs_grid,rs_desc,error=error) - CALL rs_grid_release_descriptor(rs_desc,error=error) + border_points=border_points) + CALL rs_grid_create(diel_rs_grid,rs_desc) + CALL rs_grid_release_descriptor(rs_desc) CALL timestop(handle) diff --git a/src/pw_env_types.F b/src/pw_env_types.F index 5aaa305e6b..779e674ac7 100644 --- a/src/pw_env_types.F +++ b/src/pw_env_types.F @@ -108,16 +108,13 @@ MODULE pw_env_types !> \param vdw_pw_pool ... !> \param poisson_env ... !> \param interp_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> For the other see the attributes of pw_env_type !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE pw_env_get(pw_env, pw_pools, cube_info, gridlevel_info,& auxbas_pw_pool,auxbas_grid,auxbas_rs_desc,auxbas_rs_grid,rs_descs,rs_grids,lgrid,& - xc_pw_pool, vdw_pw_pool, poisson_env, interp_section, error) + xc_pw_pool, vdw_pw_pool, poisson_env, interp_section) TYPE(pw_env_type), POINTER :: pw_env TYPE(pw_pool_p_type), DIMENSION(:), & OPTIONAL, POINTER :: pw_pools @@ -140,7 +137,6 @@ SUBROUTINE pw_env_get(pw_env, pw_pools, cube_info, gridlevel_info,& TYPE(pw_poisson_type), OPTIONAL, POINTER :: poisson_env TYPE(section_vals_type), OPTIONAL, & POINTER :: interp_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_env_get', & routineP = moduleN//':'//routineN @@ -149,8 +145,8 @@ SUBROUTINE pw_env_get(pw_env, pw_pools, cube_info, gridlevel_info,& failure=.FALSE. - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(pw_pools)) pw_pools => pw_env%pw_pools IF (PRESENT(rs_descs)) rs_descs => pw_env%rs_descs IF (PRESENT(rs_grids)) rs_grids => pw_env%rs_grids @@ -176,15 +172,12 @@ END SUBROUTINE pw_env_get ! ***************************************************************************** !> \brief retains the pw_env (see doc/ReferenceCounting.html) !> \param pw_env the pw_env to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_env_retain(pw_env,error) +SUBROUTINE pw_env_retain(pw_env) TYPE(pw_env_type), POINTER :: pw_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_env_retain', & routineP = moduleN//':'//routineN @@ -193,8 +186,8 @@ SUBROUTINE pw_env_retain(pw_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,failure) pw_env%ref_count=pw_env%ref_count+1 END SUBROUTINE pw_env_retain @@ -202,16 +195,13 @@ END SUBROUTINE pw_env_retain !> \brief releases the given pw_env (see doc/ReferenceCounting.html) !> \param pw_env the pw_env to release !> \param kg ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_env_release(pw_env, kg, error) +SUBROUTINE pw_env_release(pw_env, kg) TYPE(pw_env_type), POINTER :: pw_env LOGICAL, OPTIONAL :: kg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_env_release', & routineP = moduleN//':'//routineN @@ -223,52 +213,52 @@ SUBROUTINE pw_env_release(pw_env, kg, error) my_kg = .FALSE. IF(PRESENT(kg)) my_kg = kg IF (ASSOCIATED(pw_env)) THEN - CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_env%ref_count>0,cp_failure_level,routineP,failure) pw_env%ref_count=pw_env%ref_count-1 IF (pw_env%ref_count<1) THEN - CALL pw_poisson_release(pw_env%poisson_env, error=error) - CALL pw_pools_dealloc(pw_env%pw_pools,error=error) + CALL pw_poisson_release(pw_env%poisson_env) + CALL pw_pools_dealloc(pw_env%pw_pools) IF (ASSOCIATED(pw_env%gridlevel_info)) THEN IF(my_kg) THEN DEALLOCATE (pw_env%gridlevel_info%cutoff,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CALL section_vals_release(pw_env%gridlevel_info%print_section,error=error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CALL section_vals_release(pw_env%gridlevel_info%print_section) DEALLOCATE (pw_env%gridlevel_info%count,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE - CALL destroy_gaussian_gridlevel(pw_env%gridlevel_info, error=error) + CALL destroy_gaussian_gridlevel(pw_env%gridlevel_info) END IF DEALLOCATE(pw_env%gridlevel_info,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(pw_env%cube_info)) THEN DO igrid_level=1,SIZE(pw_env%cube_info) CALL destroy_cube_info(pw_env%cube_info(igrid_level)) END DO DEALLOCATE(pw_env%cube_info,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF - CALL pw_pool_release(pw_env%xc_pw_pool,error=error) - CALL pw_pool_release(pw_env%vdw_pw_pool,error=error) + CALL pw_pool_release(pw_env%xc_pw_pool) + CALL pw_pool_release(pw_env%vdw_pw_pool) IF (ASSOCIATED(pw_env%rs_descs)) THEN DO i=1, SIZE(pw_env%rs_descs) - CALL rs_grid_release_descriptor(pw_env%rs_descs(i)%rs_desc, error=error) + CALL rs_grid_release_descriptor(pw_env%rs_descs(i)%rs_desc) END DO DEALLOCATE(pw_env%rs_descs, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(pw_env%rs_grids)) THEN DO i=1, SIZE(pw_env%rs_grids) - CALL rs_grid_release(pw_env%rs_grids(i)%rs_grid, error=error) + CALL rs_grid_release(pw_env%rs_grids(i)%rs_grid) END DO DEALLOCATE(pw_env%rs_grids, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(pw_env%lgrid)) THEN - CALL lgrid_release(pw_env%lgrid,error) + CALL lgrid_release(pw_env%lgrid) END IF DEALLOCATE(pw_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(pw_env) @@ -277,15 +267,12 @@ END SUBROUTINE pw_env_release ! ***************************************************************************** !> \brief flushes the cached pws !> \param pw_env the pw_env to be flushed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE pw_env_flush_cache(pw_env,error) +SUBROUTINE pw_env_flush_cache(pw_env) TYPE(pw_env_type), POINTER :: pw_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_env_flush_cache', & routineP = moduleN//':'//routineN @@ -294,9 +281,9 @@ SUBROUTINE pw_env_flush_cache(pw_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) IF (ASSOCIATED(pw_env%pw_pools)) THEN - CALL pw_pools_flush_cache(pw_env%pw_pools,error=error) + CALL pw_pools_flush_cache(pw_env%pw_pools) END IF END SUBROUTINE pw_env_flush_cache diff --git a/src/pw_poisson_read_input.F b/src/pw_poisson_read_input.F index a8ef73d5dd..afb3b99a35 100644 --- a/src/pw_poisson_read_input.F +++ b/src/pw_poisson_read_input.F @@ -49,17 +49,15 @@ MODULE pw_poisson_read_input !> \brief Reads the POISSON input-section and into pw_poisson_parameter_type. !> \param poisson_section ... !> \param params ... -!> \param error ... !> \par History !> 01.2014 Code moved into separate module from pw_poisson_types, !> pw_poisson_methods and ps_wavelet_types. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE pw_poisson_read_parameters(poisson_section, params, error) + SUBROUTINE pw_poisson_read_parameters(poisson_section, params) TYPE(section_vals_type), POINTER :: poisson_section TYPE(pw_poisson_parameter_type), & INTENT(INOUT) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_poisson_read_parameters', & routineP = moduleN//':'//routineN @@ -72,42 +70,42 @@ SUBROUTINE pw_poisson_read_parameters(poisson_section, params, error) NULLIFY(ewald_section, mt_section, wavelet_section) failure=.FALSE. - CALL section_vals_val_get(poisson_section,"POISSON_SOLVER",i_val=params%solver,error=error) + CALL section_vals_val_get(poisson_section,"POISSON_SOLVER",i_val=params%solver) ! Decoding PERIODIC depending on chosen solver, ! because not all solvers support every possible periodicity - CALL section_vals_val_get(poisson_section,"PERIODIC",i_val=periodic,error=error) + CALL section_vals_val_get(poisson_section,"PERIODIC",i_val=periodic) SELECT CASE (params%solver) CASE(pw_poisson_periodic,pw_poisson_analytic,pw_poisson_mt,pw_poisson_multipole) - CALL decode_periodic_green(periodic, params, error) + CALL decode_periodic_green(periodic, params) CASE(pw_poisson_wavelet) - CALL decode_periodic_wavelet(periodic, params, error) + CALL decode_periodic_wavelet(periodic, params) CASE(pw_poisson_implicit) CASE(pw_poisson_none) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! parsing EWALD subsection params%ewald_type = do_ewald_none - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD", can_return_null=.TRUE., error=error) + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD", can_return_null=.TRUE.) IF ( ASSOCIATED(ewald_section) ) THEN - CALL section_vals_val_get(ewald_section,"EWALD_TYPE",i_val=params%ewald_type,error=error) - CALL section_vals_val_get(ewald_section,"o_spline", i_val=params%ewald_o_spline,error=error) - CALL section_vals_val_get(ewald_section,"alpha",r_val=params%ewald_alpha,error=error) + CALL section_vals_val_get(ewald_section,"EWALD_TYPE",i_val=params%ewald_type) + CALL section_vals_val_get(ewald_section,"o_spline", i_val=params%ewald_o_spline) + CALL section_vals_val_get(ewald_section,"alpha",r_val=params%ewald_alpha) ENDIF ! parsing MT subsection - mt_section => section_vals_get_subs_vals(poisson_section,"MT",error=error) - CALL section_vals_val_get(mt_section,"REL_CUTOFF",r_val=params%mt_rel_cutoff,error=error) - CALL section_vals_val_get(mt_section,"ALPHA",r_val=params%mt_alpha,error=error) + mt_section => section_vals_get_subs_vals(poisson_section,"MT") + CALL section_vals_val_get(mt_section,"REL_CUTOFF",r_val=params%mt_rel_cutoff) + CALL section_vals_val_get(mt_section,"ALPHA",r_val=params%mt_alpha) ! parsing WAVELET subsection - wavelet_section => section_vals_get_subs_vals(poisson_section,"WAVELET",error=error) - CALL section_vals_val_get(wavelet_section,"SCF_TYPE",i_val=params%wavelet_scf_type,error=error) + wavelet_section => section_vals_get_subs_vals(poisson_section,"WAVELET") + CALL section_vals_val_get(wavelet_section,"SCF_TYPE",i_val=params%wavelet_scf_type) ! parsing IMPLICIT subsection - CALL ps_implicit_read_parameters(poisson_section, params, error) + CALL ps_implicit_read_parameters(poisson_section, params) END SUBROUTINE pw_poisson_read_parameters @@ -115,14 +113,12 @@ END SUBROUTINE pw_poisson_read_parameters !> \brief Helper routien for pw_poisson_read_parameters !> \param periodic ... !> \param params ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE decode_periodic_green(periodic, params, error) + SUBROUTINE decode_periodic_green(periodic, params) INTEGER, INTENT(IN) :: periodic TYPE(pw_poisson_parameter_type), & INTENT(INOUT) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'decode_periodic_green', & routineP = moduleN//':'//routineN @@ -149,10 +145,10 @@ SUBROUTINE decode_periodic_green(periodic, params, error) CASE(use_perd_none) params%periodic = (/0,0,0/) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! check for consistent use of periodicity (cell <-> Poisson solver) - !CPPostcondition(ALL(perd == cell%perd),cp_fatal_level,routineP,error,failure) + !CPPostcondition(ALL(perd == cell%perd),cp_fatal_level,routineP,failure) END SUBROUTINE decode_periodic_green @@ -161,14 +157,12 @@ END SUBROUTINE decode_periodic_green !> \brief Helper routien for pw_poisson_read_parameters !> \param periodic ... !> \param params ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE decode_periodic_wavelet(periodic, params, error) + SUBROUTINE decode_periodic_wavelet(periodic, params) INTEGER, INTENT(IN) :: periodic TYPE(pw_poisson_parameter_type), & INTENT(INOUT) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'decode_periodic_wavelet', & routineP = moduleN//':'//routineN @@ -193,9 +187,9 @@ SUBROUTINE decode_periodic_wavelet(periodic, params, error) CASE(use_perd_x,use_perd_y,use_perd_z,use_perd_xy,use_perd_yz) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Poisson solver for this periodicity not yet implemented",& - error=error,failure=failure) + failure=failure) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE decode_periodic_wavelet @@ -205,16 +199,14 @@ END SUBROUTINE decode_periodic_wavelet !> pw_poisson_parameter_type !> \param poisson_section poisson section to be read from input !> \param params poisson_env parameters -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE ps_implicit_read_parameters(poisson_section, params, error) + SUBROUTINE ps_implicit_read_parameters(poisson_section, params) TYPE(section_vals_type), POINTER :: poisson_section TYPE(pw_poisson_parameter_type), & INTENT(INOUT) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ps_implicit_read_parameters', & routineP = moduleN//':'//routineN @@ -227,24 +219,24 @@ SUBROUTINE ps_implicit_read_parameters(poisson_section, params, error) NULLIFY(ps_implicit_section, dielectric_section, dbc_section) ! parsing IMPLICIT subsection - ps_implicit_section => section_vals_get_subs_vals(poisson_section, "IMPLICIT", error=error) + ps_implicit_section => section_vals_get_subs_vals(poisson_section, "IMPLICIT") CALL section_vals_val_get(ps_implicit_section, "BOUNDARY_CONDITIONS", & - i_val=params%ps_implicit_params%boundary_condition, error=error) + i_val=params%ps_implicit_params%boundary_condition) CALL section_vals_val_get(ps_implicit_section, "ZERO_INITIAL_GUESS", & - l_val=params%ps_implicit_params%zero_initial_guess, error=error) - CALL section_vals_val_get(ps_implicit_section, "max_iter", i_val=params%ps_implicit_params%max_iter, error=error) - CALL section_vals_val_get(ps_implicit_section, "tol", r_val=params%ps_implicit_params%tol, error=error) - CALL section_vals_val_get(ps_implicit_section, "omega", r_val=params%ps_implicit_params%omega, error=error) + l_val=params%ps_implicit_params%zero_initial_guess) + CALL section_vals_val_get(ps_implicit_section, "max_iter", i_val=params%ps_implicit_params%max_iter) + CALL section_vals_val_get(ps_implicit_section, "tol", r_val=params%ps_implicit_params%tol) + CALL section_vals_val_get(ps_implicit_section, "omega", r_val=params%ps_implicit_params%omega) ! parsing DIELECTRIC subsection - dielectric_section => section_vals_get_subs_vals(ps_implicit_section, "DIELECTRIC", error=error) - CALL section_vals_get(dielectric_section, explicit=has_dielectric, error=error) + dielectric_section => section_vals_get_subs_vals(ps_implicit_section, "DIELECTRIC") + CALL section_vals_get(dielectric_section, explicit=has_dielectric) params%has_dielectric = has_dielectric - CALL dielectric_read_parameters(dielectric_section, params, error) + CALL dielectric_read_parameters(dielectric_section, params) ! parsing DIRICHLET_BC subsection - dbc_section => section_vals_get_subs_vals(ps_implicit_section, "DIRICHLET_BC", error=error) - CALL dirichlet_bc_read_parameters(dbc_section, params, error) + dbc_section => section_vals_get_subs_vals(ps_implicit_section, "DIRICHLET_BC") + CALL dirichlet_bc_read_parameters(dbc_section, params) END SUBROUTINE ps_implicit_read_parameters @@ -253,16 +245,14 @@ END SUBROUTINE ps_implicit_read_parameters !> pw_poisson_parameter_type !> \param dielectric_section dielectric section to be read from input !> \param params poisson_env parameters -!> \param error cp2k error !> \par History !> 07.2015 created [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dielectric_read_parameters(dielectric_section, params, error) + SUBROUTINE dielectric_read_parameters(dielectric_section, params) TYPE(section_vals_type), POINTER :: dielectric_section TYPE(pw_poisson_parameter_type), & INTENT(INOUT) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dielectric_read_parameters', & routineP = moduleN//':'//routineN @@ -277,19 +267,19 @@ SUBROUTINE dielectric_read_parameters(dielectric_section, params, error) xaa_annular_section CALL section_vals_val_get(dielectric_section, "DIELECTRIC_CORE_CORRECTION", & - l_val=params%dielectric_params%dielec_core_correction, error=error) + l_val=params%dielectric_params%dielec_core_correction) CALL section_vals_val_get(dielectric_section, "DIELECTRIC_FUNCTION_TYPE", & - i_val=params%dielectric_params%dielec_functiontype, error=error) - CALL section_vals_val_get(dielectric_section, "epsilon", r_val=params%dielectric_params%eps0, error=error) - CALL section_vals_val_get(dielectric_section, "rho_min", r_val=params%dielectric_params%rho_min, error=error) - CALL section_vals_val_get(dielectric_section, "rho_max", r_val=params%dielectric_params%rho_max, error=error) + i_val=params%dielectric_params%dielec_functiontype) + CALL section_vals_val_get(dielectric_section, "epsilon", r_val=params%dielectric_params%eps0) + CALL section_vals_val_get(dielectric_section, "rho_min", r_val=params%dielectric_params%rho_min) + CALL section_vals_val_get(dielectric_section, "rho_max", r_val=params%dielectric_params%rho_max) CALL section_vals_val_get(dielectric_section, "DERIVATIVE_METHOD", & - i_val=params%dielectric_params%derivative_method, error=error) + i_val=params%dielectric_params%derivative_method) - aa_cuboidal_section => section_vals_get_subs_vals(dielectric_section, "DIELEC_AA_CUBOIDAL", error=error) - xaa_annular_section => section_vals_get_subs_vals(dielectric_section, "DIELEC_XAA_ANNULAR", error=error) - CALL section_vals_get(aa_cuboidal_section, explicit=aa_cuboidal_explicit, n_repetition=n_aac_rep, error=error) - CALL section_vals_get(xaa_annular_section, explicit=xaa_annular_explicit, n_repetition=n_xaaa_rep, error=error) + aa_cuboidal_section => section_vals_get_subs_vals(dielectric_section, "DIELEC_AA_CUBOIDAL") + xaa_annular_section => section_vals_get_subs_vals(dielectric_section, "DIELEC_XAA_ANNULAR") + CALL section_vals_get(aa_cuboidal_section, explicit=aa_cuboidal_explicit, n_repetition=n_aac_rep) + CALL section_vals_get(xaa_annular_section, explicit=xaa_annular_explicit, n_repetition=n_xaaa_rep) IF (params%solver .EQ. pw_poisson_implicit) THEN @@ -303,15 +293,15 @@ SUBROUTINE dielectric_read_parameters(dielectric_section, params, error) NULLIFY(aa_cuboidal_xxtnt, aa_cuboidal_yxtnt, aa_cuboidal_zxtnt) DO i = 1, n_aac_rep CALL section_vals_val_get(aa_cuboidal_section,"epsilon" ,& - i_rep_section=i,r_val=eps,error=error) + i_rep_section=i,r_val=eps) CALL section_vals_val_get(aa_cuboidal_section,"zeta" ,& - i_rep_section=i,r_val=zeta,error=error) + i_rep_section=i,r_val=zeta) CALL section_vals_val_get(aa_cuboidal_section,"X_xtnt",& - i_rep_section=i,r_vals=aa_cuboidal_xxtnt,error=error) + i_rep_section=i,r_vals=aa_cuboidal_xxtnt) CALL section_vals_val_get(aa_cuboidal_section,"Y_xtnt",& - i_rep_section=i,r_vals=aa_cuboidal_yxtnt,error=error) + i_rep_section=i,r_vals=aa_cuboidal_yxtnt) CALL section_vals_val_get(aa_cuboidal_section,"Z_xtnt",& - i_rep_section=i,r_vals=aa_cuboidal_zxtnt,error=error) + i_rep_section=i,r_vals=aa_cuboidal_zxtnt) params%dielectric_params%aa_cuboidal_eps(i) = eps params%dielectric_params%aa_cuboidal_zeta(i) = zeta params%dielectric_params%aa_cuboidal_xxtnt(:,i) = aa_cuboidal_xxtnt @@ -331,15 +321,15 @@ SUBROUTINE dielectric_read_parameters(dielectric_section, params, error) NULLIFY(xaa_annular_xxtnt, xaa_annular_bctr, xaa_annular_brad) DO i = 1, n_xaaa_rep CALL section_vals_val_get(xaa_annular_section,"epsilon" ,& - i_rep_section=i,r_val=eps,error=error) + i_rep_section=i,r_val=eps) CALL section_vals_val_get(xaa_annular_section,"zeta" ,& - i_rep_section=i,r_val=zeta,error=error) + i_rep_section=i,r_val=zeta) CALL section_vals_val_get(xaa_annular_section,"X_xtnt" ,& - i_rep_section=i,r_vals=xaa_annular_xxtnt,error=error) + i_rep_section=i,r_vals=xaa_annular_xxtnt) CALL section_vals_val_get(xaa_annular_section,"base_center",& - i_rep_section=i,r_vals=xaa_annular_bctr,error=error) + i_rep_section=i,r_vals=xaa_annular_bctr) CALL section_vals_val_get(xaa_annular_section,"base_radii",& - i_rep_section=i,r_vals=xaa_annular_brad,error=error) + i_rep_section=i,r_vals=xaa_annular_brad) params%dielectric_params%xaa_annular_eps(i) = eps params%dielectric_params%xaa_annular_zeta(i) = zeta params%dielectric_params%xaa_annular_xxtnt(:,i) = xaa_annular_xxtnt @@ -358,17 +348,15 @@ END SUBROUTINE dielectric_read_parameters !> pw_poisson_parameter_type !> \param dbc_section dirichlet_bc section to be read from input !> \param params poisson_env parameters -!> \param error cp2k error !> \par History !> 08.2014 created [Hossein Bani-Hashemian] !> 07.2015 refactored [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE dirichlet_bc_read_parameters(dbc_section, params, error) + SUBROUTINE dirichlet_bc_read_parameters(dbc_section, params) TYPE(section_vals_type), POINTER :: dbc_section TYPE(pw_poisson_parameter_type), & INTENT(INOUT) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dirichlet_bc_read_parameters', & routineP = moduleN//':'//routineN @@ -392,15 +380,15 @@ SUBROUTINE dirichlet_bc_read_parameters(dbc_section, params, error) planar_section, & xaa_cylindrical_section - CALL section_vals_val_get(dbc_section, "VERBOSE_OUTPUT", l_val=params%dbc_params%verbose_output, error=error) - aa_planar_section => section_vals_get_subs_vals(dbc_section, "AA_PLANAR", error=error) - planar_section => section_vals_get_subs_vals(dbc_section, "PLANAR", error=error) - xaa_cylindrical_section => section_vals_get_subs_vals(dbc_section, "XAA_CYLINDRICAL", error=error) - aa_cuboidal_section => section_vals_get_subs_vals(dbc_section, "AA_CUBOIDAL", error=error) - CALL section_vals_get(aa_planar_section, explicit=aa_planar_explicit, n_repetition=n_aap_rep, error=error) - CALL section_vals_get(planar_section, explicit=planar_explicit, n_repetition=n_p_rep, error=error) - CALL section_vals_get(xaa_cylindrical_section, explicit=xaa_cylindrical_explicit, n_repetition=n_xaac_rep, error=error) - CALL section_vals_get(aa_cuboidal_section, explicit=aa_cuboidal_explicit, n_repetition=n_aac_rep, error=error) + CALL section_vals_val_get(dbc_section, "VERBOSE_OUTPUT", l_val=params%dbc_params%verbose_output) + aa_planar_section => section_vals_get_subs_vals(dbc_section, "AA_PLANAR") + planar_section => section_vals_get_subs_vals(dbc_section, "PLANAR") + xaa_cylindrical_section => section_vals_get_subs_vals(dbc_section, "XAA_CYLINDRICAL") + aa_cuboidal_section => section_vals_get_subs_vals(dbc_section, "AA_CUBOIDAL") + CALL section_vals_get(aa_planar_section, explicit=aa_planar_explicit, n_repetition=n_aap_rep) + CALL section_vals_get(planar_section, explicit=planar_explicit, n_repetition=n_p_rep) + CALL section_vals_get(xaa_cylindrical_section, explicit=xaa_cylindrical_explicit, n_repetition=n_xaac_rep) + CALL section_vals_get(aa_cuboidal_section, explicit=aa_cuboidal_explicit, n_repetition=n_aac_rep) IF (params%solver .EQ. pw_poisson_implicit) THEN IF (aa_planar_explicit) THEN @@ -415,65 +403,65 @@ SUBROUTINE dirichlet_bc_read_parameters(dbc_section, params, error) NULLIFY(aa_planar_xxtnt, aa_planar_yxtnt, aa_planar_zxtnt, aa_planar_nprtn) DO i = 1, n_aap_rep CALL section_vals_val_get(aa_planar_section,"v_D" ,& - i_rep_section=i,r_val=v_D,error=error) + i_rep_section=i,r_val=v_D) CALL section_vals_val_get(aa_planar_section,"zeta" ,& - i_rep_section=i,r_val=zeta,error=error) + i_rep_section=i,r_val=zeta) CALL section_vals_val_get(aa_planar_section,"smooth",& - i_rep_section=i,l_val=smooth,error=error) + i_rep_section=i,l_val=smooth) params%dbc_params%aa_planar_vD(i) = v_D params%dbc_params%aa_planar_zeta(i) = zeta params%dbc_params%aa_planar_smooth(i) = smooth CALL section_vals_val_get(aa_planar_section,"PARALLEL_PLANE",& - i_rep_section=i,i_val=parallel_plane,error=error) + i_rep_section=i,i_val=parallel_plane) CALL section_vals_val_get(aa_planar_section,"INTERCEPT",& - i_rep_section=i,r_val=intercept,error=error) + i_rep_section=i,r_val=intercept) SELECT CASE (parallel_plane) CASE (xy_aligned_rectangle) CALL section_vals_val_get(aa_planar_section,"X_xtnt",& - i_rep_section=i,r_vals=aa_planar_xxtnt,error=error) + i_rep_section=i,r_vals=aa_planar_xxtnt) CALL section_vals_val_get(aa_planar_section,"Y_xtnt",& - i_rep_section=i,r_vals=aa_planar_yxtnt,error=error) + i_rep_section=i,r_vals=aa_planar_yxtnt) params%dbc_params%aa_planar_xxtnt(:,i) = aa_planar_xxtnt params%dbc_params%aa_planar_yxtnt(:,i) = aa_planar_yxtnt params%dbc_params%aa_planar_zxtnt(:,i) = intercept CALL section_vals_val_get(aa_planar_section,"n_prtn",& - i_rep_section=i,i_vals=aa_planar_nprtn,error=error) + i_rep_section=i,i_vals=aa_planar_nprtn) params%dbc_params%aa_planar_nprtn(1,i) = aa_planar_nprtn(1) params%dbc_params%aa_planar_nprtn(2,i) = aa_planar_nprtn(2) params%dbc_params%aa_planar_nprtn(3,i) = 1 CASE (yz_aligned_rectangle) CALL section_vals_val_get(aa_planar_section,"Y_xtnt",& - i_rep_section=i,r_vals=aa_planar_yxtnt,error=error) + i_rep_section=i,r_vals=aa_planar_yxtnt) CALL section_vals_val_get(aa_planar_section,"Z_xtnt",& - i_rep_section=i,r_vals=aa_planar_zxtnt,error=error) + i_rep_section=i,r_vals=aa_planar_zxtnt) params%dbc_params%aa_planar_xxtnt(:,i) = intercept params%dbc_params%aa_planar_yxtnt(:,i) = aa_planar_yxtnt params%dbc_params%aa_planar_zxtnt(:,i) = aa_planar_zxtnt CALL section_vals_val_get(aa_planar_section,"n_prtn",& - i_rep_section=i,i_vals=aa_planar_nprtn,error=error) + i_rep_section=i,i_vals=aa_planar_nprtn) params%dbc_params%aa_planar_nprtn(1,i) = 1 params%dbc_params%aa_planar_nprtn(2,i) = aa_planar_nprtn(1) params%dbc_params%aa_planar_nprtn(3,i) = aa_planar_nprtn(2) CASE (xz_aligned_rectangle) CALL section_vals_val_get(aa_planar_section,"X_xtnt",& - i_rep_section=i,r_vals=aa_planar_xxtnt,error=error) + i_rep_section=i,r_vals=aa_planar_xxtnt) CALL section_vals_val_get(aa_planar_section,"Z_xtnt",& - i_rep_section=i,r_vals=aa_planar_zxtnt,error=error) + i_rep_section=i,r_vals=aa_planar_zxtnt) params%dbc_params%aa_planar_xxtnt(:,i) = aa_planar_xxtnt params%dbc_params%aa_planar_yxtnt(:,i) = intercept params%dbc_params%aa_planar_zxtnt(:,i) = aa_planar_zxtnt CALL section_vals_val_get(aa_planar_section,"n_prtn",& - i_rep_section=i,i_vals=aa_planar_nprtn,error=error) + i_rep_section=i,i_vals=aa_planar_nprtn) params%dbc_params%aa_planar_nprtn(1,i) = aa_planar_nprtn(1) params%dbc_params%aa_planar_nprtn(2,i) = 1 @@ -496,19 +484,19 @@ SUBROUTINE dirichlet_bc_read_parameters(dbc_section, params, error) NULLIFY(planar_Avtx, planar_Bvtx, planar_Cvtx, planar_nprtn) DO i = 1, n_p_rep CALL section_vals_val_get(planar_section,"v_D" ,& - i_rep_section=i,r_val=v_D,error=error) + i_rep_section=i,r_val=v_D) CALL section_vals_val_get(planar_section,"zeta" ,& - i_rep_section=i,r_val=zeta,error=error) + i_rep_section=i,r_val=zeta) CALL section_vals_val_get(planar_section,"smooth",& - i_rep_section=i,l_val=smooth,error=error) + i_rep_section=i,l_val=smooth) CALL section_vals_val_get(planar_section,"A" ,& - i_rep_section=i,r_vals=planar_Avtx,error=error) + i_rep_section=i,r_vals=planar_Avtx) CALL section_vals_val_get(planar_section,"B" ,& - i_rep_section=i,r_vals=planar_Bvtx,error=error) + i_rep_section=i,r_vals=planar_Bvtx) CALL section_vals_val_get(planar_section,"C" ,& - i_rep_section=i,r_vals=planar_Cvtx,error=error) + i_rep_section=i,r_vals=planar_Cvtx) CALL section_vals_val_get(planar_section,"n_prtn",& - i_rep_section=i,i_vals=planar_nprtn,error=error) + i_rep_section=i,i_vals=planar_nprtn) params%dbc_params%planar_vD(i) = v_D params%dbc_params%planar_zeta(i) = zeta params%dbc_params%planar_smooth(i) = smooth @@ -534,23 +522,23 @@ SUBROUTINE dirichlet_bc_read_parameters(dbc_section, params, error) NULLIFY(xaa_cylindrical_xxtnt, xaa_cylindrical_bctr, xaa_cylindrical_nprtn) DO i = 1, n_xaac_rep CALL section_vals_val_get(xaa_cylindrical_section,"v_D" ,& - i_rep_section=i,r_val=v_D,error=error) + i_rep_section=i,r_val=v_D) CALL section_vals_val_get(xaa_cylindrical_section,"zeta" ,& - i_rep_section=i,r_val=zeta,error=error) + i_rep_section=i,r_val=zeta) CALL section_vals_val_get(xaa_cylindrical_section,"smooth" ,& - i_rep_section=i,l_val=smooth,error=error) + i_rep_section=i,l_val=smooth) CALL section_vals_val_get(xaa_cylindrical_section,"X_xtnt" ,& - i_rep_section=i,r_vals=xaa_cylindrical_xxtnt,error=error) + i_rep_section=i,r_vals=xaa_cylindrical_xxtnt) CALL section_vals_val_get(xaa_cylindrical_section,"base_center",& - i_rep_section=i,r_vals=xaa_cylindrical_bctr,error=error) + i_rep_section=i,r_vals=xaa_cylindrical_bctr) CALL section_vals_val_get(xaa_cylindrical_section,"base_radius",& - i_rep_section=i,r_val=xaa_cylindrical_brad,error=error) + i_rep_section=i,r_val=xaa_cylindrical_brad) CALL section_vals_val_get(xaa_cylindrical_section,"n_sides" ,& - i_rep_section=i,i_val=xaa_cylindrical_nsides,error=error) + i_rep_section=i,i_val=xaa_cylindrical_nsides) CALL section_vals_val_get(xaa_cylindrical_section,"apx_type" ,& - i_rep_section=i,i_val=xaa_cylindrical_apxtyp,error=error) + i_rep_section=i,i_val=xaa_cylindrical_apxtyp) CALL section_vals_val_get(xaa_cylindrical_section,"n_prtn" ,& - i_rep_section=i,i_vals=xaa_cylindrical_nprtn,error=error) + i_rep_section=i,i_vals=xaa_cylindrical_nprtn) params%dbc_params%xaa_cylindrical_vD(i) = v_D params%dbc_params%xaa_cylindrical_zeta(i) = zeta params%dbc_params%xaa_cylindrical_smooth(i) = smooth @@ -577,19 +565,19 @@ SUBROUTINE dirichlet_bc_read_parameters(dbc_section, params, error) NULLIFY(aa_cuboidal_xxtnt, aa_cuboidal_yxtnt, aa_cuboidal_zxtnt, aa_cuboidal_nprtn) DO i = 1, n_aac_rep CALL section_vals_val_get(aa_cuboidal_section,"v_D" ,& - i_rep_section=i,r_val=v_D,error=error) + i_rep_section=i,r_val=v_D) CALL section_vals_val_get(aa_cuboidal_section,"zeta" ,& - i_rep_section=i,r_val=zeta,error=error) + i_rep_section=i,r_val=zeta) CALL section_vals_val_get(aa_cuboidal_section,"smooth",& - i_rep_section=i,l_val=smooth,error=error) + i_rep_section=i,l_val=smooth) CALL section_vals_val_get(aa_cuboidal_section,"X_xtnt",& - i_rep_section=i,r_vals=aa_cuboidal_xxtnt,error=error) + i_rep_section=i,r_vals=aa_cuboidal_xxtnt) CALL section_vals_val_get(aa_cuboidal_section,"Y_xtnt",& - i_rep_section=i,r_vals=aa_cuboidal_yxtnt,error=error) + i_rep_section=i,r_vals=aa_cuboidal_yxtnt) CALL section_vals_val_get(aa_cuboidal_section,"Z_xtnt",& - i_rep_section=i,r_vals=aa_cuboidal_zxtnt,error=error) + i_rep_section=i,r_vals=aa_cuboidal_zxtnt) CALL section_vals_val_get(aa_cuboidal_section,"n_prtn",& - i_rep_section=i,i_vals=aa_cuboidal_nprtn,error=error) + i_rep_section=i,i_vals=aa_cuboidal_nprtn) params%dbc_params%aa_cuboidal_vD(i) = v_D params%dbc_params%aa_cuboidal_zeta(i) = zeta params%dbc_params%aa_cuboidal_smooth(i) = smooth diff --git a/src/qmmm_create.F b/src/qmmm_create.F index c20302c0a8..6315138e2d 100644 --- a/src/qmmm_create.F +++ b/src/qmmm_create.F @@ -95,15 +95,13 @@ MODULE qmmm_create !> \param use_motion_section ... !> \param prev_subsys ... !> \param ignore_outside_box ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& force_env_section, qmmm_section, subsys_section, use_motion_section, prev_subsys, & - ignore_outside_box, error) + ignore_outside_box) TYPE(qmmm_env_type), POINTER :: qmmm_env TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env @@ -113,7 +111,6 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& LOGICAL, INTENT(IN) :: use_motion_section TYPE(cp_subsys_type), OPTIONAL, POINTER :: prev_subsys LOGICAL, INTENT(in), OPTIONAL :: ignore_outside_box - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_create', & routineP = moduleN//':'//routineN @@ -160,25 +157,24 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& NULLIFY(fist_scale_charge_link, print_section, fist_nonbond_env) NULLIFY(print_gen, logger, mm_el_pot_radius_corr, super_cell, pw_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! citations CALL cite_reference(Laino2005) ! Input section... IF (.NOT.ASSOCIATED(subsys_section)) THEN - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",& - error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") END IF - qmmm_periodic => section_vals_get_subs_vals(qmmm_section,"PERIODIC",error=error) - multipole_section => section_vals_get_subs_vals(qmmm_section,"PERIODIC%MULTIPOLE",error=error) - print_section => section_vals_get_subs_vals(qmmm_section,"PRINT",error=error) - print_gen => section_vals_get_subs_vals(print_section,"PROGRAM_RUN_INFO",error=error) - iw = cp_print_key_unit_nr(logger,print_gen,"", extension=".log",error=error) + qmmm_periodic => section_vals_get_subs_vals(qmmm_section,"PERIODIC") + multipole_section => section_vals_get_subs_vals(qmmm_section,"PERIODIC%MULTIPOLE") + print_section => section_vals_get_subs_vals(qmmm_section,"PRINT") + print_gen => section_vals_get_subs_vals(print_section,"PROGRAM_RUN_INFO") + iw = cp_print_key_unit_nr(logger,print_gen,"", extension=".log") ! Create QM/MM Environments.. - CALL qmmm_env_qm_create(qmmm_env_qm,error=error) - CALL qmmm_env_mm_create(qmmm_env_mm,error=error) + CALL qmmm_env_qm_create(qmmm_env_qm) + CALL qmmm_env_mm_create(qmmm_env_mm) ! Set up QM/MM Options CALL setup_qmmm_vars_mm(qmmm_section,& @@ -188,8 +184,7 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& mm_link_scale_factor,& fist_scale_charge_link,& qmmm_coupl_type,& - qmmm_link,& - error=error) + qmmm_link) qmmm_env_mm%qm_atom_index => qm_atom_index qmmm_env_mm%mm_link_atoms => mm_link_atoms @@ -198,7 +193,7 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& qmmm_env_mm%qmmm_coupl_type = qmmm_coupl_type qmmm_env_mm%qmmm_link = qmmm_link ! Center the qm subsys into the qm box - CALL section_vals_val_get(qmmm_section,"CENTER",i_val=center_i,error=error) + CALL section_vals_val_get(qmmm_section,"CENTER",i_val=center_i) IF (center_i == do_qmmm_center_never) THEN qmmm_env_qm%center_qm_subsys = .FALSE. qmmm_env_qm%center_qm_subsys0 = .FALSE. @@ -213,24 +208,24 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& "Unknown type of CENTER! "//CPSourceFileRef, only_ionode=.TRUE.) ENDIF - CALL section_vals_val_get(qmmm_section,"CENTER_TYPE",i_val=center_i,error=error) + CALL section_vals_val_get(qmmm_section,"CENTER_TYPE",i_val=center_i) qmmm_env_qm%center_qm_subsys_pbc_aware = (center_i == do_qmmm_center_pbc_aware) ! Compatibility with the QM/MM in CPMD code - CALL section_vals_val_get(qmmm_section,"NOCOMPATIBILITY",l_val=nocompatibility,error=error) + CALL section_vals_val_get(qmmm_section,"NOCOMPATIBILITY",l_val=nocompatibility) qmmm_env_qm%compatibility = .NOT.nocompatibility ! Parallel scheme for the long range CALL section_vals_val_get(qmmm_section,"PARALLEL_SCHEME",& - i_val=qmmm_env_qm%par_scheme,error=error) + i_val=qmmm_env_qm%par_scheme) ! Periodic boundary condition calculation - CALL section_vals_get(qmmm_periodic,explicit=explicit,error=error) + CALL section_vals_get(qmmm_periodic,explicit=explicit) qmmm_env_qm%periodic = explicit !multipole section is switched on by default; switched off only if explicitly stated IF(qmmm_env_qm%periodic) qmmm_env_qm%multipole = .TRUE. - CALL section_vals_get(multipole_section,explicit=explicit,error=error) - CALL section_vals_val_get(multipole_section,"_SECTION_PARAMETERS_",i_val=use_multipole,error=error) + CALL section_vals_get(multipole_section,explicit=explicit) + CALL section_vals_val_get(multipole_section,"_SECTION_PARAMETERS_",i_val=use_multipole) IF (explicit.and.use_multipole==do_multipole_section_off) qmmm_env_qm%multipole = .FALSE. IF (explicit.and.use_multipole==do_multipole_section_on) qmmm_env_qm%multipole = .TRUE. IF (qmmm_env_qm%periodic.and.qmmm_env_qm%multipole) CALL cite_reference(Laino2006) @@ -244,12 +239,12 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& END IF ! First Initialize Fist... - CALL section_vals_val_set(force_env_section,"METHOD",i_val=do_fist,error=error) - CALL fist_env_create(fist_env, para_env=para_env, error=error) - CALL fist_env_set(fist_env, qmmm=.TRUE., qmmm_env=qmmm_env_mm, error=error) + CALL section_vals_val_set(force_env_section,"METHOD",i_val=do_fist) + CALL fist_env_create(fist_env, para_env=para_env) + CALL fist_env_set(fist_env, qmmm=.TRUE., qmmm_env=qmmm_env_mm) CALL fist_init(fist_env, root_section, para_env, force_env_section,& - subsys_section, use_motion_section, prev_subsys=prev_subsys, error=error ) - CALL fist_env_get(fist_env, subsys=subsys_mm, cell=mm_cell, error=error) + subsys_section, use_motion_section, prev_subsys=prev_subsys) + CALL fist_env_get(fist_env, subsys=subsys_mm, cell=mm_cell) ! Set up QM/MM Options CALL setup_qmmm_vars_qm (qmmm_section,& @@ -262,8 +257,7 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& qmmm_coupl_type,& eps_mm_rspace,& qmmm_link,& - para_env,& - error) + para_env) qmmm_env_qm%qm_atom_index => qm_atom_index qmmm_env_qm%mm_atom_index => mm_atom_index @@ -281,7 +275,7 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& IF (qmmm_link) THEN IF (ASSOCIATED(mm_link_atoms)) THEN ALLOCATE(qmmm_env_qm%mm_link_atoms(SIZE(mm_link_atoms)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qmmm_env_qm%mm_link_atoms = mm_link_atoms END IF END IF @@ -293,7 +287,7 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& qmmm_env_qm%num_image_mm_atoms ENDIF WRITE(iw,'(A)')" QM cell ::" - CALL write_cell(qm_cell_small, subsys_section, error=error) + CALL write_cell(qm_cell_small, subsys_section) END IF CALL get_cell(qm_cell_small, abc=abc_qm) CALL get_cell(mm_cell, abc=abc_mm) @@ -305,13 +299,13 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& ENDIF ! Assign charges and mm_el_pot_radius from fist_topology - CALL fist_env_get(fist_env, fist_nonbond_env=fist_nonbond_env, error=error) + CALL fist_env_get(fist_env, fist_nonbond_env=fist_nonbond_env) ALLOCATE(mm_atom_chrg(SIZE(mm_atom_index)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mm_el_pot_radius(SIZE(mm_atom_index)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mm_el_pot_radius_corr(SIZE(mm_atom_index)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mm_atom_chrg = 0.0_dp mm_el_pot_radius = 0.0_dp mm_el_pot_radius_corr = 0.0_dp @@ -323,8 +317,7 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& mm_el_pot_radius_corr=mm_el_pot_radius_corr,& mm_atom_index=mm_atom_index,& mm_link_atoms=mm_link_atoms,& - mm_link_scale_factor=mm_link_scale_factor,& - error=error) + mm_link_scale_factor=mm_link_scale_factor) qmmm_env_qm%mm_atom_chrg => mm_atom_chrg qmmm_env_qm%mm_el_pot_radius => mm_el_pot_radius @@ -334,15 +327,15 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& qmmm_link_Imomm = .FALSE. IF (qmmm_link) THEN CALL setup_qmmm_links(qmmm_section, qmmm_links, mm_el_pot_radius, & - mm_el_pot_radius_corr, mm_atom_index, iw, error=error) + mm_el_pot_radius_corr, mm_atom_index, iw) qmmm_env_qm%qmmm_links => qmmm_links - CALL print_qmmm_links(qmmm_section, qmmm_links, error) + CALL print_qmmm_links(qmmm_section, qmmm_links) - CALL add_set_release (qmmm_env_qm%added_charges, error=error) + CALL add_set_release (qmmm_env_qm%added_charges) CALL move_or_add_atoms(qmmm_section, move_mm_charges, add_mm_charges, & mm_atom_chrg, mm_el_pot_radius, mm_el_pot_radius_corr,& - added_charges, mm_atom_index, error) + added_charges, mm_atom_index) qmmm_env_qm%move_mm_charges = move_mm_charges qmmm_env_qm%add_mm_charges = add_mm_charges qmmm_env_qm%added_charges => added_charges @@ -351,47 +344,47 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& CALL print_qmmm_charges(mm_atom_index, mm_atom_chrg, mm_el_pot_radius,& mm_el_pot_radius_corr, qmmm_env_qm%added_charges,& - qmmm_section, nocompatibility, error) + qmmm_section, nocompatibility) IF (qmmm_env_qm%image_charge) THEN - CALL print_image_charge_info(qmmm_env_qm, qmmm_section, error) + CALL print_image_charge_info(qmmm_env_qm, qmmm_section) ENDIF - CALL section_vals_val_get(qmmm_section,"DELTA_CHARGE",i_val=delta_charge,error=error) - CALL section_vals_val_get(force_env_section,"DFT%CHARGE",i_val=orig_charge,error=error) - CALL section_vals_val_set(force_env_section,"DFT%CHARGE",i_val=orig_charge+delta_charge,error=error) + CALL section_vals_val_get(qmmm_section,"DELTA_CHARGE",i_val=delta_charge) + CALL section_vals_val_get(force_env_section,"DFT%CHARGE",i_val=orig_charge) + CALL section_vals_val_set(force_env_section,"DFT%CHARGE",i_val=orig_charge+delta_charge) - CALL section_vals_val_set(force_env_section,"METHOD",i_val=do_qs,error=error) + CALL section_vals_val_set(force_env_section,"METHOD",i_val=do_qs) CALL create_small_subsys(subsys_qm,& big_subsys=subsys_mm,small_para_env=para_env,& small_cell=qm_cell_small,sub_atom_index=qm_atom_index,& sub_atom_kind_name=qm_atom_type, para_env=para_env, & force_env_section=force_env_section, subsys_section=subsys_section, & - ignore_outside_box=ignore_outside_box, error=error) + ignore_outside_box=ignore_outside_box) IF (qmmm_link_imomm) CALL qmmm_link_Imomm_coord(qmmm_links, subsys_qm%particles%els,& - qm_atom_index, error) - CALL qs_env_create(qs_env, globenv, error=error) + qm_atom_index) + CALL qs_env_create(qs_env, globenv) CALL qs_init(qs_env, para_env, globenv, root_section, cp_subsys=subsys_qm,& cell=qm_cell_small, qmmm=.TRUE., qmmm_env_qm=qmmm_env_qm,& force_env_section=force_env_section, subsys_section=subsys_section,& - use_motion_section=use_motion_section, error=error) - CALL cp_subsys_release(subsys_qm,error=error) + use_motion_section=use_motion_section) + CALL cp_subsys_release(subsys_qm) IF (qmmm_env_qm%periodic) THEN IF (.NOT.ASSOCIATED(super_cell)) THEN ALLOCATE (super_cell,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL cell_clone(mm_cell, super_cell,error=error) - CALL set_qs_env(qs_env, super_cell=super_cell, qmmm_periodic=qmmm_env_qm%periodic, error=error) - CALL cell_release(super_cell, error=error) + CALL cell_clone(mm_cell, super_cell) + CALL set_qs_env(qs_env, super_cell=super_cell, qmmm_periodic=qmmm_env_qm%periodic) + CALL cell_release(super_cell) END IF - CALL section_vals_val_set(force_env_section,"DFT%CHARGE",i_val=orig_charge,error=error) - CALL cp_print_key_finished_output(iw,logger,print_gen,"", error=error) + CALL section_vals_val_set(force_env_section,"DFT%CHARGE",i_val=orig_charge) + CALL cp_print_key_finished_output(iw,logger,print_gen,"") iw2 = cp_print_key_unit_nr(logger,qmmm_section,"PRINT%PROGRAM_BANNER",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") CALL qmmm_header(iw2) CALL cp_print_key_finished_output(iw2,logger,qmmm_section,& - "PRINT%PROGRAM_BANNER",error=error) + "PRINT%PROGRAM_BANNER") ! ! Initialize MM Potential fitted with Gaussian ! @@ -401,23 +394,20 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& mm_atom_chrg=mm_atom_chrg,& added_charges=qmmm_env_qm%added_charges,& print_section=print_section,& - qmmm_section=qmmm_section,& - error=error) + qmmm_section=qmmm_section) ! ! Initialize the MM potential stored on vector ! CALL qmmm_init_potential(qmmm_env_qm=qmmm_env_qm,& mm_cell=mm_cell,& added_charges=qmmm_env_qm%added_charges,& - print_section=print_section,& - error=error) + print_section=print_section) ! ! Initialize the qmmm_pw_grid ! - CALL get_qs_env(qs_env, pw_env=pw_env, error=error) + CALL get_qs_env(qs_env, pw_env=pw_env) CALL qmmm_pw_grid_init(qmmm_env=qmmm_env_qm,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) ! ! Initialize the MM periodic potential ! @@ -429,16 +419,14 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& added_charges=qmmm_env_qm%added_charges,& qmmm_periodic=qmmm_periodic,& print_section=print_section,& - mm_atom_chrg=mm_atom_chrg,& - error=error) + mm_atom_chrg=mm_atom_chrg) ! ! Preparing for PBC... ! CALL setup_origin_mm_cell(qmmm_section, qmmm_env_qm, qm_cell_small,& - dr=pw_env%pw_pools(pw_env%auxbas_grid)%pool%pw_grid%dr,& - error=error) + dr=pw_env%pw_pools(pw_env%auxbas_grid)%pool%pw_grid%dr) - CALL cell_release(qm_cell_small, error) + CALL cell_release(qm_cell_small) ! assemble the actuall qmmm_env ALLOCATE(qmmm_env) @@ -448,9 +436,9 @@ SUBROUTINE qmmm_env_create(qmmm_env, root_section, para_env, globenv,& ! The qmmm_env inherits our ref_cout for qmmm_env_qm, fist_env, qs_env ! An expection is qmmm_env_mm, because it's buried in the fist_env - CALL qmmm_env_mm_release(qmmm_env_mm, error) + CALL qmmm_env_mm_release(qmmm_env_mm) - CALL section_vals_val_set(force_env_section,"METHOD",i_val=do_qmmm,error=error) + CALL section_vals_val_set(force_env_section,"METHOD",i_val=do_qmmm) DEALLOCATE(qm_atom_type) CALL timestop(handle) diff --git a/src/qmmm_elpot.F b/src/qmmm_elpot.F index 2e356de1ca..0fcc560186 100644 --- a/src/qmmm_elpot.F +++ b/src/qmmm_elpot.F @@ -50,15 +50,12 @@ MODULE qmmm_elpot !> \param mm_cell ... !> \param compatibility ... !> \param print_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& - pgfs, mm_cell, compatibility, print_section,& - error) + pgfs, mm_cell, compatibility, print_section) INTEGER, INTENT(IN) :: qmmm_coupl_type REAL(KIND=dp), DIMENSION(:), POINTER :: mm_el_pot_radius TYPE(qmmm_pot_p_type), DIMENSION(:), & @@ -68,7 +65,6 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& TYPE(cell_type), POINTER :: mm_cell LOGICAL, INTENT(IN) :: compatibility TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_potential_init', & routineP = moduleN//':'//routineN @@ -88,7 +84,7 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& TYPE(cp_logger_type), POINTER :: logger TYPE(qmmm_gaussian_type), POINTER :: pgf - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) Rmin = 0.0_dp Rmax = SQRT(mm_cell%hmat(1,1)**2+& @@ -100,11 +96,11 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& ! IF (SIZE(mm_el_pot_radius) /= 0) THEN ALLOCATE(radius(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) radius(1) = mm_el_pot_radius(1) ELSE ALLOCATE(radius(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END IF Loop_on_all_values: DO I = 2, SIZE(mm_el_pot_radius) Found=.FALSE. @@ -122,15 +118,15 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& END IF END DO Loop_on_all_values ! - CPPrecondition(.NOT.ASSOCIATED(potentials),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(potentials),cp_failure_level,routineP,failure) ALLOCATE(potentials(SIZE(radius)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) Potential_Type: DO K = 1, SIZE(radius) rc = radius(K) ALLOCATE(potentials(K)%Pot, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE(qmmm_coupl_type) CASE(do_qmmm_coulomb) NULLIFY(pot0_2) @@ -138,7 +134,7 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& NULLIFY(pot0_2) CASE(do_qmmm_gauss,do_qmmm_swave) ALLOCATE(pot0_2(2,np), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT SELECT CASE(qmmm_coupl_type) @@ -169,7 +165,7 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& END DO END IF pgf => pgfs(K)%pgf - CPPostcondition(pgf%Elp_Radius==rc,cp_failure_level,routineP,error,failure) + CPPostcondition(pgf%Elp_Radius==rc,cp_failure_level,routineP,failure) ig_start = 1 IF (compatibility.AND.(qmmm_coupl_type==do_qmmm_gauss)) ig_start = 2 DO Ig = ig_start, pgf%number_of_gaussians @@ -188,11 +184,11 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& END DO ! Print info on the unidimensional MM electrostatic potential - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,"MM_POTENTIAL",& - error=error),cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,"MM_POTENTIAL")& + ,cp_p_file)) THEN WRITE(rc_s,'(F6.3)')rc unit_nr = cp_print_key_unit_nr(logger,print_section,"MM_POTENTIAL",& - extension="_rc="//TRIM(ADJUSTL(rc_s))//".data",error=error) + extension="_rc="//TRIM(ADJUSTL(rc_s))//".data") IF (unit_nr>0) THEN WRITE(unit_nr,'(A)')"# MM ELECTROSTATIC POTENTIAL - UNIDIMENSIONAL - ATOMIC UNITS" WRITE(unit_nr,'(A,I5)')"# MM ELECTROSTATIC POTENTIAL - Nr. of Gaussians:",pgf%number_of_gaussians @@ -213,18 +209,18 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& END DO END IF CALL cp_print_key_finished_output(unit_nr,logger,print_section,& - "MM_POTENTIAL", error=error) + "MM_POTENTIAL") END IF CASE DEFAULT DEALLOCATE(potentials(K)%Pot) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) NULLIFY(potentials(K)%Pot) IF (output_unit>0) WRITE(output_unit,'(A)')" QMMM Potential - Spline Interpolation - not Initialized!" CYCLE Potential_Type END SELECT NULLIFY(mm_atom_index) ALLOCATE(mm_atom_index(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ! Build mm_atom_index List DO J= 1, SIZE(mm_el_pot_radius) IF (rc.EQ.mm_el_pot_radius(J)) THEN @@ -242,7 +238,7 @@ SUBROUTINE qmmm_potential_init(qmmm_coupl_type, mm_el_pot_radius, potentials,& END DO Potential_Type DEALLOCATE(radius, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END SUBROUTINE qmmm_potential_init ! ***************************************************************************** diff --git a/src/qmmm_force.F b/src/qmmm_force.F index e5e9f68adc..f084261d1c 100644 --- a/src/qmmm_force.F +++ b/src/qmmm_force.F @@ -63,17 +63,14 @@ MODULE qmmm_force !> \param calc_force if also the forces should be calculated !> \param consistent_energies ... !> \param linres ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qmmm_calc_energy_force(qmmm_env,calc_force,consistent_energies,linres,error) + SUBROUTINE qmmm_calc_energy_force(qmmm_env,calc_force,consistent_energies,linres) TYPE(qmmm_env_type), POINTER :: qmmm_env LOGICAL, INTENT(IN) :: calc_force, & consistent_energies, linres - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_calc_energy_force', & routineP = moduleN//':'//routineN @@ -105,30 +102,30 @@ SUBROUTINE qmmm_calc_energy_force(qmmm_env,calc_force,consistent_energies,linres qmmm_link = .FALSE. qmmm_link_imomm = .FALSE. qmmm_added_chrg = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) NULLIFY(subsys_mm, subsys_qm, subsys, qm_atom_index,particles_mm,particles_qm, qm_cell, mm_cell) NULLIFY(force_env_section, print_key, results_qmmm, results_qm, results_mm) - CALL get_qs_env(qmmm_env%qs_env, input=force_env_section, error=error) - print_key => section_vals_get_subs_vals(force_env_section,"QMMM%PRINT%DIPOLE",error=error) + CALL get_qs_env(qmmm_env%qs_env, input=force_env_section) + print_key => section_vals_get_subs_vals(force_env_section,"QMMM%PRINT%DIPOLE") - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,failure) - CALL apply_qmmm_translate(qmmm_env,error) + CALL apply_qmmm_translate(qmmm_env) - CALL fist_env_get(qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm,error=error) - CALL get_qs_env(qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm,error=error) + CALL fist_env_get(qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm) + CALL get_qs_env(qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm) qm_atom_index => qmmm_env%qm%qm_atom_index qmmm_link = qmmm_env%qm%qmmm_link qmmm_links => qmmm_env%qm%qmmm_links qmmm_added_chrg = (qmmm_env%qm%move_mm_charges .OR. qmmm_env%qm%add_mm_charges) IF (qmmm_link) THEN - CPPrecondition(ASSOCIATED(qmmm_links),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qmmm_links),cp_failure_level,routineP,failure) IF (ASSOCIATED(qmmm_links%imomm)) qmmm_link_imomm = (SIZE(qmmm_links%imomm) /= 0) END IF - CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,failure) particles_mm => subsys_mm%particles%els particles_qm => subsys_qm%particles%els @@ -145,69 +142,67 @@ SUBROUTINE qmmm_calc_energy_force(qmmm_env,calc_force,consistent_energies,linres CALL cp_assert(check, cp_failure_level, cp_assertion_failed, routinep,& "QM/MM QM atoms must be fully contained in the same image of the QM box "//& "- No wrapping of coordinates is allowed! "//& - CPSourceFileRef,error) + CPSourceFileRef) END DO END DO ! If present QM/MM links (just IMOMM) correct the position of the qm-link atom - IF (qmmm_link_imomm) CALL qmmm_link_Imomm_coord(qmmm_links, particles_qm, qm_atom_index, error) + IF (qmmm_link_imomm) CALL qmmm_link_Imomm_coord(qmmm_links, particles_qm, qm_atom_index) ! If add charges get their position NOW! - IF (qmmm_added_chrg) CALL qmmm_added_chrg_coord(qmmm_env%qm, particles_mm, error) + IF (qmmm_added_chrg) CALL qmmm_added_chrg_coord(qmmm_env%qm, particles_mm) ! Initialize ks_qmmm_env - CALL ks_qmmm_env_rebuild(qs_env=qmmm_env%qs_env, qmmm_env=qmmm_env%qm,error=error) + CALL ks_qmmm_env_rebuild(qs_env=qmmm_env%qs_env, qmmm_env=qmmm_env%qm) ! Compute the short range QM/MM Electrostatic Potential CALL qmmm_el_coupling(qs_env=qmmm_env%qs_env,& qmmm_env=qmmm_env%qm,& mm_particles=particles_mm,& - mm_cell=mm_cell,& - error=error) + mm_cell=mm_cell) ! Fist - CALL fist_calc_energy_force(qmmm_env%fist_env, error=error) + CALL fist_calc_energy_force(qmmm_env%fist_env) ! Print Out information on fist energy calculation... - CALL fist_env_get(qmmm_env%fist_env,thermo=fist_energy,error=error) + CALL fist_env_get(qmmm_env%fist_env,thermo=fist_energy) energy_mm = fist_energy%pot - CALL cp_subsys_get(subsys_mm, results=results_mm, error=error) + CALL cp_subsys_get(subsys_mm, results=results_mm) ! QS - CALL qs_calc_energy_force(qmmm_env%qs_env,calc_force,consistent_energies,linres,error) + CALL qs_calc_energy_force(qmmm_env%qs_env,calc_force,consistent_energies,linres) ! QM/MM Interaction Potential forces CALL qmmm_forces(qmmm_env%qs_env,& qmmm_env%qm,particles_mm,& mm_cell=mm_cell,& - calc_force=calc_force,& - error=error) + calc_force=calc_force) ! Forces of quadratic wall on QM atoms - CALL apply_qmmm_walls(qmmm_env,error) + CALL apply_qmmm_walls(qmmm_env) ! Print Out information on QS energy calculation... - CALL get_qs_env(qmmm_env%qs_env, energy=qs_energy, error=error) + CALL get_qs_env(qmmm_env%qs_env, energy=qs_energy) energy_qm = qs_energy%total - CALL cp_subsys_get(subsys_qm, results=results_qm, error=error) + CALL cp_subsys_get(subsys_qm, results=results_qm) !TODO: is really results_qm == results_qmmm ??? - CALL cp_subsys_get(subsys_qm, results=results_qmmm, error=error) + CALL cp_subsys_get(subsys_qm, results=results_qmmm) IF (calc_force) THEN ! If present QM/MM links (just IMOMM) correct the position of the qm-link atom - IF (qmmm_link_imomm) CALL qmmm_link_Imomm_forces(qmmm_links,particles_qm,qm_atom_index,error) + IF (qmmm_link_imomm) CALL qmmm_link_Imomm_forces(qmmm_links,particles_qm,qm_atom_index) particles_mm => subsys_mm%particles%els DO ip=1,SIZE(qm_atom_index) particles_mm(qm_atom_index(ip))%f=particles_mm(qm_atom_index(ip))%f+particles_qm(ip)%f END DO ! If add charges get rid of their derivatives right NOW! - IF (qmmm_added_chrg) CALL qmmm_added_chrg_forces(qmmm_env%qm, particles_mm, error) + IF (qmmm_added_chrg) CALL qmmm_added_chrg_forces(qmmm_env%qm, particles_mm) END IF ! Handle some output output_unit = cp_print_key_unit_nr(logger,force_env_section,"QMMM%PRINT%DERIVATIVES",& - extension=".Log",error=error) + extension=".Log") IF (output_unit>0) THEN WRITE (unit=output_unit,fmt='(/1X,A,F15.9)')"Energy after QMMM calculation: ",energy_qm IF (calc_force) THEN @@ -218,31 +213,31 @@ SUBROUTINE qmmm_calc_energy_force(qmmm_env,calc_force,consistent_energies,linres END IF END IF CALL cp_print_key_finished_output(output_unit,logger,force_env_section,& - "QMMM%PRINT%DERIVATIVES",error=error) + "QMMM%PRINT%DERIVATIVES") ! Dipole - print_key => section_vals_get_subs_vals(force_env_section,"QMMM%PRINT%DIPOLE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),& + print_key => section_vals_get_subs_vals(force_env_section,"QMMM%PRINT%DIPOLE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),& cp_p_file)) THEN description ='[DIPOLE]' - CALL get_results(results=results_qm,description=description,n_rep=nres,error=error) - CPPrecondition(nres<=1,cp_failure_level,routineP,error,failure) - CALL get_results(results=results_mm,description=description,n_rep=nres,error=error) - CPPrecondition(nres<=1,cp_failure_level,routineP,error,failure) - CALL get_results(results=results_qm,description=description,values=dip_qm,error=error) - CALL get_results(results=results_mm,description=description,values=dip_mm,error=error) + CALL get_results(results=results_qm,description=description,n_rep=nres) + CPPrecondition(nres<=1,cp_failure_level,routineP,failure) + CALL get_results(results=results_mm,description=description,n_rep=nres) + CPPrecondition(nres<=1,cp_failure_level,routineP,failure) + CALL get_results(results=results_qm,description=description,values=dip_qm) + CALL get_results(results=results_mm,description=description,values=dip_mm) dip_qmmm = dip_qm + dip_mm - CALL cp_results_erase(results=results_qmmm,description=description,error=error) - CALL put_results(results=results_qmmm,description=description,values=dip_qmmm,error=error) + CALL cp_results_erase(results=results_qmmm,description=description) + CALL put_results(results=results_qmmm,description=description,values=dip_qmmm) output_unit = cp_print_key_unit_nr(logger,force_env_section,"QMMM%PRINT%DIPOLE",& - extension=".Dipole",error=error) + extension=".Dipole") IF (output_unit>0) THEN WRITE(unit=output_unit,fmt="(A)")"QMMM TOTAL DIPOLE" WRITE(unit=output_unit,fmt="(A,T31,A,T88,A)")& "# iter_level","dipole(x,y,z)[atomic units]",& "dipole(x,y,z)[debye]" - iter=cp_iter_string(logger%iter_info,error=error) + iter=cp_iter_string(logger%iter_info) WRITE(unit=output_unit,fmt="(a,6(es18.8))")& iter(1:15), dip_qmmm, dip_qmmm*debye END IF diff --git a/src/qmmm_gaussian_init.F b/src/qmmm_gaussian_init.F index e82084b00f..c2665d7595 100644 --- a/src/qmmm_gaussian_init.F +++ b/src/qmmm_gaussian_init.F @@ -58,8 +58,6 @@ MODULE qmmm_gaussian_init !> \param compatibility ... !> \param print_section ... !> \param qmmm_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino @@ -67,7 +65,7 @@ MODULE qmmm_gaussian_init SUBROUTINE qmmm_gaussian_initialize(qmmm_gaussian_fns, para_env, pw_env,& mm_el_pot_radius, mm_el_pot_radius_corr, & qmmm_coupl_type, eps_mm_rspace, maxradius, maxchrg, compatibility,& - print_section, qmmm_section, error) + print_section, qmmm_section) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: qmmm_gaussian_fns TYPE(cp_para_env_type), POINTER :: para_env @@ -80,7 +78,6 @@ SUBROUTINE qmmm_gaussian_initialize(qmmm_gaussian_fns, para_env, pw_env,& REAL(KIND=dp), INTENT(IN) :: maxchrg LOGICAL, INTENT(IN) :: compatibility TYPE(section_vals_type), POINTER :: print_section, qmmm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_gaussian_initialize', & routineP = moduleN//':'//routineN @@ -101,14 +98,14 @@ SUBROUTINE qmmm_gaussian_initialize(qmmm_gaussian_fns, para_env, pw_env,& NULLIFY(mypgf, gridlevel_info, radius, c_radius, logger) failure = .FALSE. - logger => cp_error_get_logger(error) - CALL section_vals_val_get(qmmm_section,"USE_GEEP_LIB",i_val=num_geep_gauss,error=error) + logger => cp_get_default_logger() + CALL section_vals_val_get(qmmm_section,"USE_GEEP_LIB",i_val=num_geep_gauss) IF (num_geep_gauss == 0) THEN use_geep_lib = .FALSE. ELSE use_geep_lib = .TRUE. - CPPostcondition(num_geep_gauss>=min_geep_lib_gauss,cp_failure_level,routineP,error,failure) - CPPostcondition(num_geep_gauss<=max_geep_lib_gauss,cp_failure_level,routineP,error,failure) + CPPostcondition(num_geep_gauss>=min_geep_lib_gauss,cp_failure_level,routineP,failure) + CPPostcondition(num_geep_gauss<=max_geep_lib_gauss,cp_failure_level,routineP,failure) END IF SELECT CASE(qmmm_coupl_type) CASE(do_qmmm_gauss,do_qmmm_swave) @@ -116,9 +113,9 @@ SUBROUTINE qmmm_gaussian_initialize(qmmm_gaussian_fns, para_env, pw_env,& ! Preprocessing... ! ALLOCATE(radius(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(c_radius(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) Ndim = SIZE(radius) Loop_on_all_values: DO I = 1, SIZE(mm_el_pot_radius) Found=.FALSE. @@ -143,19 +140,19 @@ SUBROUTINE qmmm_gaussian_initialize(qmmm_gaussian_fns, para_env, pw_env,& CALL REALLOCATE(c_radius,1,Ndim-1) ELSE IF (Ndim-1 == 0) THEN DEALLOCATE(radius,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) DEALLOCATE(c_radius,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,Failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,Failure) END IF ! ALLOCATE(qmmm_gaussian_fns(Ndim-1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) DO I = 1, Ndim-1 NULLIFY(qmmm_gaussian_fns(I)%pgf) ALLOCATE(qmmm_gaussian_fns(I)%pgf, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) NULLIFY(qmmm_gaussian_fns(I)%pgf%Ak) NULLIFY(qmmm_gaussian_fns(I)%pgf%Gk) NULLIFY(qmmm_gaussian_fns(I)%pgf%grid_level) @@ -167,35 +164,34 @@ SUBROUTINE qmmm_gaussian_initialize(qmmm_gaussian_fns, para_env, pw_env,& END DO IF (ASSOCIATED(radius)) THEN DEALLOCATE(radius,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END IF IF (ASSOCIATED(c_radius)) THEN DEALLOCATE(c_radius,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END IF ! IF (use_geep_lib) THEN IF (qmmm_coupl_type==do_qmmm_gauss) THEN CALL set_mm_potential_erf(qmmm_gaussian_fns,& - compatibility, num_geep_gauss, error) + compatibility, num_geep_gauss) ELSEIF (qmmm_coupl_type==do_qmmm_swave) THEN CALL set_mm_potential_swave(qmmm_gaussian_fns,& - num_geep_gauss, error) + num_geep_gauss) END IF ELSE CALL read_mm_potential(para_env, qmmm_gaussian_fns,& - (compatibility.AND.(qmmm_coupl_type==do_qmmm_gauss)), qmmm_section, error) + (compatibility.AND.(qmmm_coupl_type==do_qmmm_gauss)), qmmm_section) END IF ! - CALL pw_env_get(pw_env,pw_pools=pools, gridlevel_info=gridlevel_info,& - error=error) + CALL pw_env_get(pw_env,pw_pools=pools, gridlevel_info=gridlevel_info) ALLOCATE(maxradius(SIZE(pools)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) maxradius = 0.0_dp DO J = 1, SIZE(qmmm_gaussian_fns) mypgf => qmmm_gaussian_fns(J)%pgf ALLOCATE(mypgf%grid_level(SIZE(mypgf%Ak)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mypgf%grid_level=0 mymaxradius = 0.0_dp DO I = 1, mypgf%number_of_gaussians @@ -214,9 +210,9 @@ SUBROUTINE qmmm_gaussian_initialize(qmmm_gaussian_fns, para_env, pw_env,& ! End of gaussian initialization... CASE DEFAULT output_unit =cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") IF (output_unit>0) WRITE(output_unit,'(A)')" QMMM Gaussian Data Not Initialized!" - CALL cp_print_key_finished_output(output_unit,logger,print_section,"PROGRAM_RUN_INFO",error=error) + CALL cp_print_key_finished_output(output_unit,logger,print_section,"PROGRAM_RUN_INFO") END SELECT END SUBROUTINE qmmm_gaussian_initialize diff --git a/src/qmmm_gaussian_input.F b/src/qmmm_gaussian_input.F index cb4c932810..d3621691de 100644 --- a/src/qmmm_gaussian_input.F +++ b/src/qmmm_gaussian_input.F @@ -131,20 +131,17 @@ MODULE qmmm_gaussian_input !> \param qmmm_gaussian_fns ... !> \param compatibility ... !> \param qmmm_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE read_mm_potential(para_env, qmmm_gaussian_fns,& - compatibility, qmmm_section, error) + compatibility, qmmm_section) TYPE(cp_para_env_type), POINTER :: para_env TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: qmmm_gaussian_fns LOGICAL, INTENT(IN) :: compatibility TYPE(section_vals_type), POINTER :: qmmm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_mm_potential', & routineP = moduleN//':'//routineN @@ -159,20 +156,20 @@ SUBROUTINE read_mm_potential(para_env, qmmm_gaussian_fns,& TYPE(cp_logger_type), POINTER :: logger TYPE(cp_parser_type), POINTER :: parser - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) Nval = SIZE(qmmm_gaussian_fns) Ival = 0 CALL section_vals_val_get(qmmm_section,"MM_POTENTIAL_FILE_NAME",& - c_val=mm_potential_file_name,error=error) + c_val=mm_potential_file_name) NULLIFY(parser) - CALL parser_create(parser,mm_potential_file_name,para_env=para_env,error=error) + CALL parser_create(parser,mm_potential_file_name,para_env=para_env) search_loop: DO Ftarget = "&MM_FIT_POT" IF (Ival.EQ.Nval) EXIT search_loop - CALL parser_search_string(parser,Ftarget,.TRUE.,found,line,error=error) + CALL parser_search_string(parser,Ftarget,.TRUE.,found,line) IF (Found) THEN ! ! Structure example of the MM fit potential file: @@ -189,10 +186,10 @@ SUBROUTINE read_mm_potential(para_env, qmmm_gaussian_fns,& ! 0.0790169 4.82046 Bohr ! &END ! - CALL parser_get_object (parser,Ftarget,newline=.TRUE.,error=error) - CPPostcondition(TRIM(Ftarget)=="RADIUS",cp_failure_level,routineP,error,Failure) - CALL parser_get_object (parser,radius,error=error) - CALL parser_get_object (parser,units,error=error) + CALL parser_get_object (parser,Ftarget,newline=.TRUE.) + CPPostcondition(TRIM(Ftarget)=="RADIUS",cp_failure_level,routineP,Failure) + CALL parser_get_object (parser,radius) + CALL parser_get_object (parser,units) CALL uppercase (units) fconv = 1.0_dp IF (TRIM(units).EQ."ANGSTROM") fconv = bohr @@ -210,7 +207,7 @@ SUBROUTINE read_mm_potential(para_env, qmmm_gaussian_fns,& Ival = Ival + 1 IRad = J ! Read Rmin, Rmax - CALL parser_get_object(parser,qmmm_gaussian_fns(J)%pgf%Number_of_Gaussians,newline=.TRUE.,error=error) + CALL parser_get_object(parser,qmmm_gaussian_fns(J)%pgf%Number_of_Gaussians,newline=.TRUE.) ! Allocate Vectors istart = 1 IF (compatibility) THEN @@ -219,18 +216,18 @@ SUBROUTINE read_mm_potential(para_env, qmmm_gaussian_fns,& END IF NOG = qmmm_gaussian_fns(IRad)%pgf%Number_of_Gaussians ALLOCATE(qmmm_gaussian_fns(IRad)%pgf%Ak(NOG),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(qmmm_gaussian_fns(IRad)%pgf%Gk(NOG),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) IF (compatibility) THEN my_radius = qmmm_gaussian_fns(J)%pgf%Elp_Radius_corr qmmm_gaussian_fns(IRad)%pgf%Ak(1) = 1.0_dp/radius - 2.0_dp/(rootpi*radius) qmmm_gaussian_fns(IRad)%pgf%Gk(1) = my_radius END IF DO J = istart, qmmm_gaussian_fns(IRad)%pgf%Number_of_Gaussians - CALL parser_get_object(parser,qmmm_gaussian_fns(IRad)%pgf%Ak(J),newline=.TRUE.,error=error) - CALL parser_get_object(parser,qmmm_gaussian_fns(IRad)%pgf%Gk(J),error=error) - CALL parser_get_object(parser,units,error=error) + CALL parser_get_object(parser,qmmm_gaussian_fns(IRad)%pgf%Ak(J),newline=.TRUE.) + CALL parser_get_object(parser,qmmm_gaussian_fns(IRad)%pgf%Gk(J)) + CALL parser_get_object(parser,units) CALL uppercase (units) fconv = 1.0_dp IF (TRIM(units).EQ."ANGSTROM") fconv = bohr @@ -245,7 +242,7 @@ SUBROUTINE read_mm_potential(para_env, qmmm_gaussian_fns,& END DO search_loop - CALL parser_release(parser,error=error) + CALL parser_release(parser) END SUBROUTINE read_mm_potential @@ -254,19 +251,16 @@ END SUBROUTINE read_mm_potential !> \param qmmm_gaussian_fns ... !> \param compatibility ... !> \param num_geep_gauss ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE set_mm_potential_erf(qmmm_gaussian_fns, & - compatibility, num_geep_gauss, error) + compatibility, num_geep_gauss) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: qmmm_gaussian_fns LOGICAL, INTENT(IN) :: compatibility INTEGER, INTENT(IN) :: num_geep_gauss - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_mm_potential_erf', & routineP = moduleN//':'//routineN @@ -324,9 +318,9 @@ SUBROUTINE set_mm_potential_erf(qmmm_gaussian_fns, & END SELECT NOG = qmmm_gaussian_fns(IRad)%pgf%Number_of_Gaussians ALLOCATE(qmmm_gaussian_fns(IRad)%pgf%Ak(NOG),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(qmmm_gaussian_fns(IRad)%pgf%Gk(NOG),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) IF (compatibility) THEN my_radius = qmmm_gaussian_fns(IRad)%pgf%Elp_Radius_corr qmmm_gaussian_fns(IRad)%pgf%Ak(1) = 1.0_dp/radius - 2.0_dp/(rootpi*radius) @@ -700,18 +694,15 @@ END SUBROUTINE set_mm_potential_erf !> \brief set the GEEP information for the S-WAVE expansion !> \param qmmm_gaussian_fns ... !> \param num_geep_gauss ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2007 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE set_mm_potential_swave(qmmm_gaussian_fns, & - num_geep_gauss, error) + num_geep_gauss) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: qmmm_gaussian_fns INTEGER, INTENT(IN) :: num_geep_gauss - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_mm_potential_swave', & routineP = moduleN//':'//routineN @@ -765,9 +756,9 @@ SUBROUTINE set_mm_potential_swave(qmmm_gaussian_fns, & END SELECT NOG = qmmm_gaussian_fns(IRad)%pgf%Number_of_Gaussians ALLOCATE(qmmm_gaussian_fns(IRad)%pgf%Ak(NOG),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(qmmm_gaussian_fns(IRad)%pgf%Gk(NOG),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) SELECT CASE(num_geep_gauss) CASE(2) qmmm_gaussian_fns(IRad)%pgf%Ak(istart+1) = s2_a1 diff --git a/src/qmmm_gpw_energy.F b/src/qmmm_gpw_energy.F index 315c398093..139d4c53cc 100644 --- a/src/qmmm_gpw_energy.F +++ b/src/qmmm_gpw_energy.F @@ -88,19 +88,16 @@ MODULE qmmm_gpw_energy !> \param qmmm_env ... !> \param mm_particles ... !> \param mm_cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell,error) + SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(particle_type), DIMENSION(:), & POINTER :: mm_particles TYPE(cell_type), POINTER :: mm_cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_el_coupling', & routineP = moduleN//':'//routineN @@ -121,7 +118,7 @@ SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell,error) CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(ks_qmmm_env_loc, pw_pools, pw_env,input_section, dft_control) CALL get_qs_env(qs_env=qs_env,& pw_env=pw_env,& @@ -129,25 +126,24 @@ SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell,error) input=input_section,& ks_qmmm_env=ks_qmmm_env_loc,& subsys=subsys,& - dft_control=dft_control,& - error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + dft_control=dft_control) + CALL qs_subsys_get(subsys,particles=particles) - CALL pw_env_get(pw_env=pw_env, pw_pools=pw_pools, error=error) - print_section => section_vals_get_subs_vals(input_section,"QMMM%PRINT",error=error) + CALL pw_env_get(pw_env=pw_env, pw_pools=pw_pools) + print_section => section_vals_get_subs_vals(input_section,"QMMM%PRINT") iw = cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") IF (iw>0) & WRITE(iw,'(T2,"QMMM|",1X,A)')"Information on the QM/MM Electrostatic Potential:" ! ! Initializing vectors: ! Zeroing v_qmmm_rspace - CALL pw_zero(ks_qmmm_env_loc%v_qmmm_rspace%pw,error=error) + CALL pw_zero(ks_qmmm_env_loc%v_qmmm_rspace%pw) IF (dft_control%qs_control%semi_empirical) THEN ! SEMIEMPIRICAL SELECT CASE(qmmm_env%qmmm_coupl_type) CASE(do_qmmm_coulomb,do_qmmm_none) - CALL build_se_qmmm_matrix(qs_env,qmmm_env,mm_particles,mm_cell,para_env,error) + CALL build_se_qmmm_matrix(qs_env,qmmm_env,mm_particles,mm_cell,para_env) IF( qmmm_env%qmmm_coupl_type==do_qmmm_none) THEN IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')& "No QM/MM Electrostatic coupling. Just Mechanical Coupling!" @@ -155,14 +151,14 @@ SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell,error) CASE (do_qmmm_pcharge) CALL cp_unimplemented_error(fromWhere=routineP, & message="Point charge QM/MM electrostatic coupling not yet implemented for SE.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE (do_qmmm_gauss,do_qmmm_swave) CALL cp_unimplemented_error(fromWhere=routineP, & message="GAUSS or SWAVE QM/MM electrostatic coupling not yet implemented for SE.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE DEFAULT IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')"Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSEIF (dft_control%qs_control%dftb) THEN ! DFTB @@ -170,18 +166,18 @@ SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell,error) CASE(do_qmmm_none) IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')& "No QM/MM Electrostatic coupling. Just Mechanical Coupling!" - CALL build_dftb_qmmm_matrix_zero(qs_env,para_env,error) + CALL build_dftb_qmmm_matrix_zero(qs_env,para_env) CASE(do_qmmm_coulomb) - CALL build_dftb_qmmm_matrix(qs_env,qmmm_env,mm_particles,mm_cell,para_env,error) + CALL build_dftb_qmmm_matrix(qs_env,qmmm_env,mm_particles,mm_cell,para_env) CASE(do_qmmm_pcharge) - CALL build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,mm_particles,mm_cell,para_env,error) + CALL build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,mm_particles,mm_cell,para_env) CASE (do_qmmm_gauss,do_qmmm_swave) CALL cp_unimplemented_error(fromWhere=routineP, & message="GAUSS or SWAVE QM/MM electrostatic coupling not implemented for DFTB.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE DEFAULT IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')"Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSE ! QS @@ -189,17 +185,17 @@ SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell,error) CASE(do_qmmm_coulomb) CALL cp_unimplemented_error(fromWhere=routineP, & message="Coulomb QM/MM electrostatic coupling not implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_pcharge) CALL cp_unimplemented_error(fromWhere=routineP, & message="Point Charge QM/MM electrostatic coupling not implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_gauss,do_qmmm_swave) IF (iw>0) & WRITE(iw,'(T2,"QMMM|",1X,A)')& "QM/MM Coupling computed collocating the Gaussian Potential Functions." interp_section => section_vals_get_subs_vals(input_section,& - "QMMM%INTERPOLATOR",error=error) + "QMMM%INTERPOLATOR") CALL qmmm_elec_with_gaussian(qmmm_env=qmmm_env,& v_qmmm=ks_qmmm_env_loc%v_qmmm_rspace,& mm_particles=mm_particles,& @@ -211,30 +207,29 @@ SUBROUTINE qmmm_el_coupling(qs_env,qmmm_env,mm_particles,mm_cell,error) auxbas_grid=qmmm_env%gridlevel_info%auxbas_grid,& coarser_grid=qmmm_env%gridlevel_info%coarser_grid,& interp_section=interp_section,& - mm_cell=mm_cell,& - error=error) + mm_cell=mm_cell) CASE(do_qmmm_none) IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')& "No QM/MM Electrostatic coupling. Just Mechanical Coupling!" CASE DEFAULT IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')"Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Dump info on the electrostatic potential if requested IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,& - "POTENTIAL",error=error),cp_p_file)) THEN + "POTENTIAL"),cp_p_file)) THEN iw2 = cp_print_key_unit_nr(logger,print_section,"POTENTIAL",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") CALL cp_pw_to_cube(ks_qmmm_env_loc%v_qmmm_rspace%pw,iw2,& particles=particles,& - stride=section_get_ivals(print_section,"POTENTIAL%STRIDE",error),& - title="QM/MM: MM ELECTROSTATIC POTENTIAL ", error=error) + stride=section_get_ivals(print_section,"POTENTIAL%STRIDE"),& + title="QM/MM: MM ELECTROSTATIC POTENTIAL ") CALL cp_print_key_finished_output(iw2,logger,print_section,& - "POTENTIAL", error=error) + "POTENTIAL") END IF END IF CALL cp_print_key_finished_output(iw,logger,print_section,& - "PROGRAM_RUN_INFO", error=error) + "PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE qmmm_el_coupling @@ -253,15 +248,13 @@ END SUBROUTINE qmmm_el_coupling !> \param coarser_grid ... !> \param interp_section ... !> \param mm_cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& aug_pools, cube_info, para_env, eps_mm_rspace, pw_pools,& - auxbas_grid, coarser_grid, interp_section, mm_cell, error) + auxbas_grid, coarser_grid, interp_section, mm_cell) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(pw_p_type), INTENT(INOUT) :: v_qmmm TYPE(particle_type), DIMENSION(:), & @@ -277,7 +270,6 @@ SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& INTEGER, INTENT(IN) :: auxbas_grid, coarser_grid TYPE(section_vals_type), POINTER :: interp_section TYPE(cell_type), POINTER :: mm_cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_elec_with_gaussian', & routineP = moduleN//':'//routineN @@ -289,17 +281,17 @@ SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& TYPE(pw_p_type), DIMENSION(:), POINTER :: grids failure=.FALSE. - CPPrecondition(ASSOCIATED(mm_particles),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_chrg),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_index),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(aug_pools),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_pools),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mm_particles),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_chrg),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_index),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(aug_pools),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_pools),cp_failure_level,routineP,failure) !Statements CALL timeset(routineN,handle) ngrids=SIZE(pw_pools) - CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE,error=error) + CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE) DO igrid=1,ngrids - CALL pw_zero(grids(igrid)%pw,error=error) + CALL pw_zero(grids(igrid)%pw) END DO CALL qmmm_elec_with_gaussian_low( grids, mm_particles,& @@ -308,7 +300,7 @@ SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& auxbas_grid, coarser_grid, qmmm_env%potentials, & mm_cell=mm_cell, dOmmOqm=qmmm_env%dOmmOqm, periodic=qmmm_env%periodic, & per_potentials=qmmm_env%per_potentials, par_scheme=qmmm_env%par_scheme, & - qmmm_spherical_cutoff=qmmm_env%spherical_cutoff, error=error) + qmmm_spherical_cutoff=qmmm_env%spherical_cutoff) IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL qmmm_elec_with_gaussian_low( grids, qmmm_env%added_charges%added_particles, & @@ -318,7 +310,7 @@ SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& coarser_grid, qmmm_env%added_charges%potentials, & mm_cell=mm_cell, dOmmOqm=qmmm_env%dOmmOqm, periodic=qmmm_env%periodic, & per_potentials=qmmm_env%per_potentials, par_scheme=qmmm_env%par_scheme, & - qmmm_spherical_cutoff=qmmm_env%spherical_cutoff, error=error) + qmmm_spherical_cutoff=qmmm_env%spherical_cutoff) END IF ! Sumup all contributions according the parallelization scheme IF (qmmm_env%par_scheme==do_par_atom) THEN @@ -327,7 +319,7 @@ SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& END DO END IF ! RealSpace Interpolation - CALL section_vals_val_get(interp_section,"kind", i_val=kind_interp, error=error) + CALL section_vals_val_get(interp_section,"kind", i_val=kind_interp) SELECT CASE(kind_interp) CASE(spline3_nopbc_interp, spline3_pbc_interp) ! Spline Iterpolator @@ -337,12 +329,11 @@ SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& CALL pw_prolongate_s3(grids(Ilevel )%pw,& grids(Ilevel-1)%pw,& aug_pools(Ilevel)%pool,& - param_section=interp_section,& - error=error) + param_section=interp_section) END DO CALL timestop(handle2) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT lb = v_qmmm%pw%pw_grid%bounds_local(1,:) ub = v_qmmm%pw%pw_grid%bounds_local(2,:) @@ -351,7 +342,7 @@ SUBROUTINE qmmm_elec_with_gaussian(qmmm_env, v_qmmm, mm_particles,& lb(2):ub(2),& lb(3):ub(3) ) - CALL pw_pools_give_back_pws(aug_pools,grids,error=error) + CALL pw_pools_give_back_pws(aug_pools,grids) CALL timestop(handle) END SUBROUTINE qmmm_elec_with_gaussian @@ -376,8 +367,6 @@ END SUBROUTINE qmmm_elec_with_gaussian !> \param per_potentials ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error variable to control error logging ,stopping,... -!> see module cp_error_handling !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino @@ -386,7 +375,7 @@ SUBROUTINE qmmm_elec_with_gaussian_low( tmp_grid, mm_particles, mm_charges,& mm_atom_index, cube_info, para_env, & eps_mm_rspace, pgfs, auxbas_grid, coarser_grid, & potentials, mm_cell, dOmmOqm, periodic, per_potentials, par_scheme, & - qmmm_spherical_cutoff, error) + qmmm_spherical_cutoff) TYPE(pw_p_type), DIMENSION(:), POINTER :: tmp_grid TYPE(particle_type), DIMENSION(:), & POINTER :: mm_particles @@ -408,7 +397,6 @@ SUBROUTINE qmmm_elec_with_gaussian_low( tmp_grid, mm_particles, mm_charges,& DIMENSION(:), POINTER :: per_potentials INTEGER, INTENT(IN) :: par_scheme REAL(KIND=dp), INTENT(IN) :: qmmm_spherical_cutoff(2) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_elec_with_gaussian_low', & routineNb = 'qmmm_elec_gaussian_low', routineP = moduleN//':'//routineN @@ -432,11 +420,11 @@ SUBROUTINE qmmm_elec_with_gaussian_low( tmp_grid, mm_particles, mm_charges,& CALL timeset(routineNb//"_G",handle2) bo2 = tmp_grid(auxbas_grid)%pw%pw_grid%bounds ALLOCATE (xdat(bo2(1,1):bo2(2,1)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ydat(bo2(1,2):bo2(2,2)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (zdat(bo2(1,3):bo2(2,3)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (par_scheme==do_par_atom) myind = 0 Radius: DO IRadTyp = 1, SIZE(pgfs) pgf => pgfs(IRadTyp)%pgf @@ -462,7 +450,7 @@ SUBROUTINE qmmm_elec_with_gaussian_low( tmp_grid, mm_particles, mm_charges,& W = mm_charges(LIndMM) * height ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) W = W * sph_chrg_factor END IF IF (ABS(W)<= EPSILON(0.0_dp)) CYCLE Atoms @@ -484,15 +472,15 @@ SUBROUTINE qmmm_elec_with_gaussian_low( tmp_grid, mm_particles, mm_charges,& END DO Radius IF (ASSOCIATED(xdat)) THEN DEALLOCATE (xdat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(ydat)) THEN DEALLOCATE (ydat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(zdat)) THEN DEALLOCATE (zdat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle2) CALL timeset(routineNb//"_R",handle2) @@ -508,8 +496,7 @@ SUBROUTINE qmmm_elec_with_gaussian_low( tmp_grid, mm_particles, mm_charges,& mm_cell=mm_cell,& dOmmOqm=dOmmOqm,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) ELSE ! Long Range Part of the QM/MM Potential with Gaussians CALL qmmm_elec_with_gaussian_LR (pgfs=pgfs,& @@ -522,8 +509,7 @@ SUBROUTINE qmmm_elec_with_gaussian_low( tmp_grid, mm_particles, mm_charges,& mm_cell=mm_cell,& dOmmOqm=dOmmOqm,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) END IF CALL timestop(handle2) CALL timestop(handle) @@ -546,8 +532,6 @@ END SUBROUTINE qmmm_elec_with_gaussian_low !> \param dOmmOqm ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2004 created [tlaino] !> \author Teodoro Laino @@ -557,7 +541,7 @@ END SUBROUTINE qmmm_elec_with_gaussian_low ! ***************************************************************************** SUBROUTINE qmmm_elec_with_gaussian_LG(pgfs, cgrid, mm_charges, mm_atom_index,& mm_particles, para_env, per_potentials,& - mm_cell, dOmmOqm, par_scheme, qmmm_spherical_cutoff, error) + mm_cell, dOmmOqm, par_scheme, qmmm_spherical_cutoff) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: pgfs TYPE(pw_type), POINTER :: cgrid @@ -572,7 +556,6 @@ SUBROUTINE qmmm_elec_with_gaussian_LG(pgfs, cgrid, mm_charges, mm_atom_index,& REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: dOmmOqm INTEGER, INTENT(IN) :: par_scheme REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: qmmm_spherical_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_elec_with_gaussian_LG', & routineP = moduleN//':'//routineN @@ -622,7 +605,7 @@ SUBROUTINE qmmm_elec_with_gaussian_LG(pgfs, cgrid, mm_charges, mm_atom_index,& qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) qt = qt * sph_chrg_factor END IF IF (ABS(qt)<= EPSILON(0.0_dp)) CYCLE Atoms @@ -764,15 +747,13 @@ END SUBROUTINE qmmm_elec_with_gaussian_LG !> \param dOmmOqm ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_elec_with_gaussian_LR(pgfs, grid, mm_charges, mm_atom_index,& mm_particles, para_env, potentials,& - mm_cell, dOmmOqm, par_scheme, qmmm_spherical_cutoff, error) + mm_cell, dOmmOqm, par_scheme, qmmm_spherical_cutoff) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: pgfs TYPE(pw_type), POINTER :: grid @@ -787,7 +768,6 @@ SUBROUTINE qmmm_elec_with_gaussian_LR(pgfs, grid, mm_charges, mm_atom_index,& REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: dOmmOqm INTEGER, INTENT(IN) :: par_scheme REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: qmmm_spherical_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_elec_with_gaussian_LR', & routineP = moduleN//':'//routineN @@ -835,7 +815,7 @@ SUBROUTINE qmmm_elec_with_gaussian_LR(pgfs, grid, mm_charges, mm_atom_index,& qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) qt = qt * sph_chrg_factor END IF IF (ABS(qt)<= EPSILON(0.0_dp)) CYCLE Atoms diff --git a/src/qmmm_gpw_forces.F b/src/qmmm_gpw_forces.F index bfa26a0d8c..f59f1d70b0 100644 --- a/src/qmmm_gpw_forces.F +++ b/src/qmmm_gpw_forces.F @@ -96,19 +96,17 @@ MODULE qmmm_gpw_forces !> \param mm_particles ... !> \param calc_force ... !> \param mm_cell ... -!> \param error ... !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) + SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(particle_type), DIMENSION(:), & POINTER :: mm_particles LOGICAL, INTENT(in), OPTIONAL :: calc_force TYPE(cell_type), POINTER :: mm_cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_forces', & routineP = moduleN//':'//routineN @@ -149,24 +147,23 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) para_env=para_env,& input=input_section,& rho0_s_gs=rho0_s_gs,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ks_qmmm_env_loc => qs_env%ks_qmmm_env - interp_section => section_vals_get_subs_vals(input_section,"QMMM%INTERPOLATOR",error=error) - print_section => section_vals_get_subs_vals(input_section,"QMMM%PRINT",error=error) + interp_section => section_vals_get_subs_vals(input_section,"QMMM%INTERPOLATOR") + print_section => section_vals_get_subs_vals(input_section,"QMMM%PRINT") iw=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") gapw = dft_control%qs_control%gapw ! If forces are required allocate these temporary arrays IF (need_f) THEN ALLOCATE(Forces(3,qmmm_env%num_mm_atoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Forces_added_charges(3,qmmm_env%added_charges%num_mm_atoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Forces(:,:) = 0.0_dp Forces_added_charges(:,:) = 0.0_dp END IF @@ -175,21 +172,21 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) SELECT CASE(qmmm_env%qmmm_coupl_type) CASE(do_qmmm_coulomb) CALL deriv_se_qmmm_matrix(qs_env,qmmm_env,mm_particles,mm_cell,para_env,& - need_f,Forces,Forces_added_charges,error) + need_f,Forces,Forces_added_charges) CASE(do_qmmm_pcharge) CALL cp_unimplemented_error(fromWhere=routineP, & message="Point Charge QM/MM electrostatic coupling not yet implemented for SE.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_gauss,do_qmmm_swave) CALL cp_unimplemented_error(fromWhere=routineP, & message="GAUSS or SWAVE QM/MM electrostatic coupling not yet implemented for SE.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_none) IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')& "- No QM/MM Electrostatic coupling. Just Mechanical Coupling!" CASE DEFAULT IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')"Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSEIF (dft_control%qs_control%dftb) THEN ! DFTB @@ -199,17 +196,17 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) "- No QM/MM Electrostatic coupling. Just Mechanical Coupling!" CASE(do_qmmm_coulomb) CALL deriv_dftb_qmmm_matrix(qs_env,qmmm_env,mm_particles,mm_cell,para_env,& - need_f,Forces,Forces_added_charges,error) + need_f,Forces,Forces_added_charges) CASE(do_qmmm_pcharge) CALL deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,mm_particles,mm_cell,para_env,& - need_f,Forces,Forces_added_charges,error) + need_f,Forces,Forces_added_charges) CASE(do_qmmm_gauss,do_qmmm_swave) CALL cp_unimplemented_error(fromWhere=routineP, & message="GAUSS or SWAVE QM/MM electrostatic coupling not yet implemented for DFTB.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE DEFAULT IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')"Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (need_f) THEN Forces(:,:) = Forces(:,:) / REAL(para_env%num_pe,KIND=dp) @@ -219,42 +216,39 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) ! GPW/GAPW CALL pw_env_get(pw_env=pw_env,& pw_pools=pw_pools,& - auxbas_pw_pool=auxbas_pool,& - error=error) + auxbas_pw_pool=auxbas_pool) CALL pw_pool_create_pw(auxbas_pool,rho_tot_r,& in_space=REALSPACE,& - use_data=REALDATA3D,& - error=error) + use_data=REALDATA3D) ! IF GAPW the core charge is replaced by the compensation charge IF(gapw) THEN IF( dft_control%qs_control%gapw_control%nopaw_as_gpw) THEN - CALL pw_transfer(rho_core%pw,rho_tot_r,error=error) - energy%qmmm_nu = pw_integral_ab ( rho_tot_r, ks_qmmm_env_loc%v_qmmm_rspace%pw,error=error) + CALL pw_transfer(rho_core%pw,rho_tot_r) + energy%qmmm_nu = pw_integral_ab ( rho_tot_r, ks_qmmm_env_loc%v_qmmm_rspace%pw) CALL pw_pool_create_pw(auxbas_pool,rho_tot_r2,& in_space=REALSPACE,& - use_data=REALDATA3D,& - error=error) - CALL pw_transfer(rho0_s_gs%pw,rho_tot_r2,error=error) - CALL pw_axpy(rho_tot_r2,rho_tot_r,error=error) - CALL pw_pool_give_back_pw(auxbas_pool,rho_tot_r2,accept_non_compatible=.TRUE.,error=error) + use_data=REALDATA3D) + CALL pw_transfer(rho0_s_gs%pw,rho_tot_r2) + CALL pw_axpy(rho_tot_r2,rho_tot_r) + CALL pw_pool_give_back_pw(auxbas_pool,rho_tot_r2,accept_non_compatible=.TRUE.) ELSE - CALL pw_transfer(rho0_s_gs%pw,rho_tot_r,error=error) + CALL pw_transfer(rho0_s_gs%pw,rho_tot_r) ! ! QM/MM Nuclear Electrostatic Potential already included through rho0 ! energy%qmmm_nu = 0.0_dp END IF ELSE - CALL pw_transfer(rho_core%pw,rho_tot_r,error=error) + CALL pw_transfer(rho_core%pw,rho_tot_r) ! ! Computes the QM/MM Nuclear Electrostatic Potential ! - energy%qmmm_nu = pw_integral_ab ( rho_tot_r, ks_qmmm_env_loc%v_qmmm_rspace%pw,error=error) + energy%qmmm_nu = pw_integral_ab ( rho_tot_r, ks_qmmm_env_loc%v_qmmm_rspace%pw) END IF IF (need_f) THEN ! DO ispin=1,SIZE(rho_r) - CALL pw_axpy(rho_r(ispin)%pw,rho_tot_r,error=error) + CALL pw_axpy(rho_r(ispin)%pw,rho_tot_r) END DO IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')"Evaluating forces on MM atoms due to the:" ! Electrostatic Interaction type... @@ -262,11 +256,11 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) CASE(do_qmmm_coulomb) CALL cp_unimplemented_error(fromWhere=routineP, & message="Coulomb QM/MM electrostatic coupling not implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_pcharge) CALL cp_unimplemented_error(fromWhere=routineP, & message="Point Charge QM/MM electrostatic coupling not yet implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_gauss,do_qmmm_swave) IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')& "- QM/MM Coupling computed collocating the Gaussian Potential Functions." @@ -284,14 +278,13 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) Forces_added_charges=Forces_added_charges,& interp_section=interp_section,& iw=iw,& - mm_cell=mm_cell,& - error=error) + mm_cell=mm_cell) CASE(do_qmmm_none) IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')& "- No QM/MM Electrostatic coupling. Just Mechanical Coupling!" CASE DEFAULT IF (iw>0) WRITE(iw,'(T2,"QMMM|",1X,A)')"- Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF END IF @@ -325,8 +318,7 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) mm_atom_index=qmmm_env%mm_atom_index,& num_mm_atoms=qmmm_env%num_mm_atoms,& interp_section=interp_section,& - mm_cell=mm_cell,& - error=error) + mm_cell=mm_cell) END IF ENDIF END IF @@ -334,7 +326,7 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) IF ((.NOT.dft_control%qs_control%semi_empirical).AND.& (.NOT.dft_control%qs_control%dftb)) THEN CALL pw_pool_give_back_pw(auxbas_pool,rho_tot_r,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) END IF IF (iw>0) THEN IF(.NOT. gapw) WRITE(iw,'(T2,"QMMM|",1X,A,T66,F15.9)')& @@ -366,7 +358,7 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) mm_particles(IndMM)%f(:) = - Forces(:,Imm) + mm_particles(IndMM)%f(:) END DO DEALLOCATE(Forces, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN DO Imm = 1, qmmm_env%added_charges%num_mm_atoms IndMM = qmmm_env%added_charges%mm_atom_index(Imm) @@ -376,10 +368,9 @@ SUBROUTINE qmmm_forces(qs_env,qmmm_env,mm_particles,calc_force,mm_cell,error) END DO END IF DEALLOCATE(Forces_added_charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO",& - error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE qmmm_forces @@ -403,7 +394,6 @@ END SUBROUTINE qmmm_forces !> \param interp_section ... !> \param iw ... !> \param mm_cell ... -!> \param error ... !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino @@ -411,7 +401,7 @@ END SUBROUTINE qmmm_forces SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & aug_pools, auxbas_grid, coarser_grid, cube_info, para_env, & eps_mm_rspace, pw_pools, Forces, Forces_added_charges, & - interp_section, iw, mm_cell, error) + interp_section, iw, mm_cell) TYPE(pw_type), POINTER :: rho TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(particle_type), DIMENSION(:), & @@ -429,7 +419,6 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & TYPE(section_vals_type), POINTER :: interp_section INTEGER, INTENT(IN) :: iw TYPE(cell_type), POINTER :: mm_cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_forces_with_gaussian', & routineP = moduleN//':'//routineN @@ -448,15 +437,15 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & failure=.FALSE. CALL timeset(routineN,handle) NULLIFY(grids,tmp) - CPPrecondition(ASSOCIATED(mm_particles),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_chrg),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_index),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(Forces),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mm_particles),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_chrg),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qmmm_env%mm_atom_index),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(Forces),cp_failure_level,routineP,failure) !Statements ngrids=SIZE(pw_pools) - CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE,error=error) + CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE) DO igrid=1,ngrids - CALL pw_zero(grids(igrid)%pw,error=error) + CALL pw_zero(grids(igrid)%pw) END DO ! Collocate Density on multigrids lb = rho%pw_grid%bounds_local(1,:) @@ -497,7 +486,7 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & ALLOCATE(tmp(rho%pw_grid%bounds_local(1,2):rho%pw_grid%bounds_local(2,2),& rho%pw_grid%bounds_local(1,3):rho%pw_grid%bounds_local(2,3)),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp=rho%cr3d(lb(1),:,:) CALL mp_isend(msgin=tmp,dest=pos_of_x(rho%pw_grid%bounds(2,1)),comm=group,& request=request,tag=112) @@ -506,7 +495,7 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & ALLOCATE(tmp(rho%pw_grid%bounds_local(1,2):rho%pw_grid%bounds_local(2,2),& rho%pw_grid%bounds_local(1,3):rho%pw_grid%bounds_local(2,3)),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_irecv(msgout=tmp,source=pos_of_x(rho%pw_grid%bounds(1,1)),& comm=group,request=request,tag=112) CALL mp_wait(request) @@ -524,7 +513,7 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & END IF IF (ASSOCIATED(tmp)) THEN DEALLOCATE(tmp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(tmp) END IF ! Further setup of parallelization scheme @@ -532,7 +521,7 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & CALL mp_sum(grids(auxbas_grid)%pw%cr3d,para_env%group) END IF ! RealSpace Interpolation - CALL section_vals_val_get(interp_section,"kind", i_val=kind_interp, error=error) + CALL section_vals_val_get(interp_section,"kind", i_val=kind_interp) SELECT CASE(kind_interp) CASE(spline3_nopbc_interp, spline3_pbc_interp) ! Spline Interpolator @@ -540,11 +529,10 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & CALL pw_restrict_s3(grids(Igrid )%pw,& grids(Igrid+1)%pw,& aug_pools(Igrid+1)%pool,& - param_section=interp_section,& - error=error) + param_section=interp_section) END DO CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL qmmm_force_with_gaussian_low(grids, mm_particles,& @@ -552,7 +540,7 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & qmmm_env%num_mm_atoms, cube_info, para_env, eps_mm_rspace, auxbas_grid, & coarser_grid, qmmm_env%pgfs, qmmm_env%potentials, Forces, aug_pools, & mm_cell, qmmm_env%dOmmOqm, qmmm_env%periodic, qmmm_env%per_potentials, & - iw, qmmm_env%par_scheme, qmmm_env%spherical_cutoff, error) + iw, qmmm_env%par_scheme, qmmm_env%spherical_cutoff) IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL qmmm_force_with_gaussian_low(grids, qmmm_env%added_charges%added_particles,& @@ -561,10 +549,10 @@ SUBROUTINE qmmm_forces_with_gaussian(rho, qmmm_env, mm_particles, & cube_info, para_env, eps_mm_rspace, auxbas_grid, coarser_grid, qmmm_env%added_charges%pgfs,& qmmm_env%added_charges%potentials, Forces_added_charges, aug_pools, mm_cell, & qmmm_env%dOmmOqm, qmmm_env%periodic, qmmm_env%per_potentials, iw, qmmm_env%par_scheme,& - qmmm_env%spherical_cutoff, error) + qmmm_env%spherical_cutoff) END IF - CALL pw_pools_give_back_pws(aug_pools,grids,error=error) + CALL pw_pools_give_back_pws(aug_pools,grids) CALL timestop(handle) END SUBROUTINE qmmm_forces_with_gaussian @@ -594,7 +582,6 @@ END SUBROUTINE qmmm_forces_with_gaussian !> \param iw ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error ... !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino @@ -603,7 +590,7 @@ SUBROUTINE qmmm_force_with_gaussian_low(grids, mm_particles, mm_charges, & mm_atom_index, num_mm_atoms, cube_info, para_env, & eps_mm_rspace, auxbas_grid, coarser_grid, pgfs, potentials, Forces, & aug_pools, mm_cell, dOmmOqm, periodic, per_potentials, iw, par_scheme,& - qmmm_spherical_cutoff, error) + qmmm_spherical_cutoff) TYPE(pw_p_type), DIMENSION(:), POINTER :: grids TYPE(particle_type), DIMENSION(:), & POINTER :: mm_particles @@ -629,7 +616,6 @@ SUBROUTINE qmmm_force_with_gaussian_low(grids, mm_particles, mm_charges, & DIMENSION(:), POINTER :: per_potentials INTEGER, INTENT(IN) :: iw, par_scheme REAL(KIND=dp), INTENT(IN) :: qmmm_spherical_cutoff(2) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_force_with_gaussian_low', & routineNb = 'qmmm_forces_gaussian_low', & @@ -670,11 +656,11 @@ SUBROUTINE qmmm_force_with_gaussian_low(grids, mm_particles, mm_charges, & dvol = grids(ilevel)%pw%pw_grid%dvol bo = grids(ilevel) % pw % pw_grid % bounds_local ALLOCATE (xdat(2,bo(1,1):bo(2,1)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ydat(2,bo(1,2):bo(2,2)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (zdat(2,bo(1,3):bo(2,3)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Atoms: DO Imm = 1, SIZE(pot%mm_atom_index) IF (par_scheme==do_par_atom) THEN myind = myind + 1 @@ -687,7 +673,7 @@ SUBROUTINE qmmm_force_with_gaussian_low(grids, mm_particles, mm_charges, & force = 0.0_dp ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) W = W * sph_chrg_factor END IF IF (ABS(W)<= EPSILON(0.0_dp)) CYCLE Atoms @@ -723,16 +709,15 @@ SUBROUTINE qmmm_force_with_gaussian_low(grids, mm_particles, mm_charges, & mm_cell=mm_cell,& auxbas_grid=auxbas_grid,& n_rep_real=n_rep_real,& - iw=iw,& - error=error) + iw=iw) END IF END DO Atoms DEALLOCATE (xdat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (ydat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (zdat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO Gaussian END DO Radius CALL timestop(handle2) @@ -753,8 +738,7 @@ SUBROUTINE qmmm_force_with_gaussian_low(grids, mm_particles, mm_charges, & dOmmOqm=dOmmOqm,& iw=iw,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) ELSE CALL qmmm_forces_with_gaussian_LR (pgfs=pgfs,& cgrid=grids(coarser_grid)%pw,& @@ -771,8 +755,7 @@ SUBROUTINE qmmm_force_with_gaussian_low(grids, mm_particles, mm_charges, & dOmmOqm=dOmmOqm,& iw=iw,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) END IF CALL timestop(handle2) CALL timestop(handle) @@ -798,14 +781,13 @@ END SUBROUTINE qmmm_force_with_gaussian_low !> \param iw ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error ... !> \par History !> 08.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_forces_with_gaussian_LG (pgfs,cgrid,num_mm_atoms,mm_charges,mm_atom_index,& mm_particles,para_env, coarser_grid_level,Forces, per_potentials,& - aug_pools, mm_cell, dOmmOqm, iw, par_scheme, qmmm_spherical_cutoff, error) + aug_pools, mm_cell, dOmmOqm, iw, par_scheme, qmmm_spherical_cutoff) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: pgfs TYPE(pw_type), POINTER :: cgrid @@ -825,7 +807,6 @@ SUBROUTINE qmmm_forces_with_gaussian_LG (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: dOmmOqm INTEGER, INTENT(IN) :: iw, par_scheme REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: qmmm_spherical_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_forces_with_gaussian_LG', & routineP = moduleN//':'//routineN @@ -855,7 +836,7 @@ SUBROUTINE qmmm_forces_with_gaussian_LG (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ CALL timeset(routineN,handle) NULLIFY(grid) ALLOCATE(LForces(3,num_mm_atoms), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) LForces = 0.0_dp dr1c = cgrid%pw_grid%dr(1) dr2c = cgrid%pw_grid%dr(2) @@ -887,7 +868,7 @@ SUBROUTINE qmmm_forces_with_gaussian_LG (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) qt = qt * sph_chrg_factor END IF IF (ABS(qt)<= EPSILON(0.0_dp)) CYCLE Atoms @@ -1193,11 +1174,10 @@ SUBROUTINE qmmm_forces_with_gaussian_LG (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ dOmmOqm=dOmmOqm,& iw=iw,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) END IF DEALLOCATE(LForces, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE qmmm_forces_with_gaussian_LG @@ -1221,14 +1201,13 @@ END SUBROUTINE qmmm_forces_with_gaussian_LG !> \param iw ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error ... !> \par History !> 08.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_forces_with_gaussian_LR (pgfs,cgrid,num_mm_atoms,mm_charges,mm_atom_index,& mm_particles,para_env, coarser_grid_level,Forces, potentials,& - aug_pools, mm_cell, dOmmOqm, iw, par_scheme, qmmm_spherical_cutoff,error) + aug_pools, mm_cell, dOmmOqm, iw, par_scheme, qmmm_spherical_cutoff) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: pgfs TYPE(pw_type), POINTER :: cgrid @@ -1248,7 +1227,6 @@ SUBROUTINE qmmm_forces_with_gaussian_LR (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: dOmmOqm INTEGER, INTENT(IN) :: iw, par_scheme REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: qmmm_spherical_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_forces_with_gaussian_LR', & routineP = moduleN//':'//routineN @@ -1273,7 +1251,7 @@ SUBROUTINE qmmm_forces_with_gaussian_LR (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ CALL timeset(routineN,handle) failure = .FALSE. ALLOCATE(LForces(3,num_mm_atoms), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) LForces = 0.0_dp n1 = cgrid%pw_grid%npts(1) n2 = cgrid%pw_grid%npts(2) @@ -1301,7 +1279,7 @@ SUBROUTINE qmmm_forces_with_gaussian_LR (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ qt = mm_charges(LIndMM) ! Possible Spherical Cutoff IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, ra, sph_chrg_factor) qt = qt * sph_chrg_factor END IF IF (ABS(qt)<= EPSILON(0.0_dp)) CYCLE Atoms @@ -1379,12 +1357,11 @@ SUBROUTINE qmmm_forces_with_gaussian_LR (pgfs,cgrid,num_mm_atoms,mm_charges,mm_ dOmmOqm=dOmmOqm,& iw=iw,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) END IF DEALLOCATE(LForces, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE qmmm_forces_with_gaussian_LR @@ -1401,14 +1378,13 @@ END SUBROUTINE qmmm_forces_with_gaussian_LR !> \param num_mm_atoms ... !> \param interp_section ... !> \param mm_cell ... -!> \param error ... !> \par History !> 08.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_debug_forces(rho,qs_env,qmmm_env,Analytical_Forces,& mm_particles,mm_atom_index,num_mm_atoms,& - interp_section,mm_cell,error) + interp_section,mm_cell) TYPE(pw_type), POINTER :: rho TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env @@ -1419,7 +1395,6 @@ SUBROUTINE qmmm_debug_forces(rho,qs_env,qmmm_env,Analytical_Forces,& INTEGER, INTENT(IN) :: num_mm_atoms TYPE(section_vals_type), POINTER :: interp_section TYPE(cell_type), POINTER :: mm_cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_debug_forces', & routineP = moduleN//':'//routineN @@ -1445,17 +1420,16 @@ SUBROUTINE qmmm_debug_forces(rho,qs_env,qmmm_env,Analytical_Forces,& CALL get_qs_env(qs_env=qs_env,& pw_env=pw_env,& input=input_section,& - para_env=para_env,& - error=error) + para_env=para_env) - print_section => section_vals_get_subs_vals(input_section,"QMMM%PRINT",error=error) - logger => cp_error_get_logger(error) - iw=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".qmmmLog",error=error) - CALL pw_env_get(pw_env=pw_env, pw_pools=pw_pools, error=error) + print_section => section_vals_get_subs_vals(input_section,"QMMM%PRINT") + logger => cp_get_default_logger() + iw=cp_print_key_unit_nr(logger,print_section,"PROGRAM_RUN_INFO",extension=".qmmmLog") + CALL pw_env_get(pw_env=pw_env, pw_pools=pw_pools) CALL pw_pool_create_pw(pw_pools(1)%pool, v_qmmm_rspace%pw,& - use_data=REALDATA3D, in_space=REALSPACE,error=error) + use_data=REALDATA3D, in_space=REALSPACE) ALLOCATE(Num_Forces(3,num_mm_atoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ks_qmmm_env_loc => qs_env%ks_qmmm_env IF (iw>0) WRITE(iw,'(/A)')"DEBUG SECTION:" Atoms: DO I = 1, num_mm_atoms @@ -1465,16 +1439,16 @@ SUBROUTINE qmmm_debug_forces(rho,qs_env,qmmm_env,Analytical_Forces,& energy = 0.0_dp Diff: DO K = 1, 2 mm_particles(IndMM)%r(J) = Coord_save + (-1)**K * Dx - CALL pw_zero(v_qmmm_rspace%pw,error=error) + CALL pw_zero(v_qmmm_rspace%pw) SELECT CASE(qmmm_env%qmmm_coupl_type) CASE(do_qmmm_coulomb) CALL cp_unimplemented_error(fromWhere=routineP, & message="Coulomb QM/MM electrostatic coupling not implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_pcharge) CALL cp_unimplemented_error(fromWhere=routineP, & message="Point Charge QM/MM electrostatic coupling not implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_gauss,do_qmmm_swave) CALL qmmm_elec_with_gaussian(qmmm_env=qmmm_env,& v_qmmm=v_qmmm_rspace,& @@ -1487,15 +1461,14 @@ SUBROUTINE qmmm_debug_forces(rho,qs_env,qmmm_env,Analytical_Forces,& auxbas_grid=qmmm_env%gridlevel_info%auxbas_grid,& coarser_grid=qmmm_env%gridlevel_info%coarser_grid,& interp_section=interp_section,& - mm_cell=mm_cell,& - error=error) + mm_cell=mm_cell) CASE(do_qmmm_none) CYCLE Diff CASE DEFAULT IF (iw>0) WRITE(iw,'(T3,A)')"Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT - energy(K) = pw_integral_ab ( rho, v_qmmm_rspace%pw ,error=error) + energy(K) = pw_integral_ab ( rho, v_qmmm_rspace%pw) END DO Diff IF (iw>0) THEN WRITE(iw,'(A,I6,A,I3,A,2F15.9)')& @@ -1510,11 +1483,11 @@ SUBROUTINE qmmm_debug_forces(rho,qs_env,qmmm_env,Analytical_Forces,& CASE(do_qmmm_coulomb) CALL cp_unimplemented_error(fromWhere=routineP, & message="Coulomb QM/MM electrostatic coupling not implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_pcharge) CALL cp_unimplemented_error(fromWhere=routineP, & message="Point Charge QM/MM electrostatic coupling not implemented for GPW/GAPW.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(do_qmmm_gauss,do_qmmm_swave) IF (iw>0) WRITE(iw,'(/A/)')"CHECKING NUMERICAL Vs ANALYTICAL FORCES (Err%):" DO I = 1, num_mm_atoms @@ -1529,21 +1502,21 @@ SUBROUTINE qmmm_debug_forces(rho,qs_env,qmmm_env,Analytical_Forces,& WRITE(iw,100)IndMM,Analytical_Forces(1,I),Num_Forces(1,I),Err(1),& Analytical_Forces(2,I),Num_Forces(2,I),Err(2),& Analytical_Forces(3,I),Num_Forces(3,I),Err(3) - CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,error,failure) + CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,failure) END DO CASE(do_qmmm_none) IF (iw>0) WRITE(iw,'(T3,A)')"No QM/MM Derivatives to debug. Just Mechanical Coupling!" CASE DEFAULT IF (iw>0) WRITE(iw,'(T3,A)')"Unknown Coupling..." - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"PROGRAM_RUN_INFO") - CALL pw_pool_give_back_pw ( pw_pools(1)%pool, v_qmmm_rspace%pw, error=error) + CALL pw_pool_give_back_pw ( pw_pools(1)%pool, v_qmmm_rspace%pw) DEALLOCATE(Num_Forces,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) 100 FORMAT(I5,2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ") END SUBROUTINE qmmm_debug_forces @@ -1563,14 +1536,13 @@ END SUBROUTINE qmmm_debug_forces !> \param auxbas_grid ... !> \param n_rep_real ... !> \param iw ... -!> \param error ... !> \par History !> 08.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE debug_integrate_gf_rspace_NoPBC(ilevel, zetp, rp, W, pwgrid, cube_info,& eps_mm_rspace, aug_pools, debug_force,& - mm_cell,auxbas_grid, n_rep_real, iw, error) + mm_cell,auxbas_grid, n_rep_real, iw) INTEGER, INTENT(IN) :: ilevel REAL(KIND=dp), INTENT(IN) :: zetp REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rp @@ -1585,7 +1557,6 @@ SUBROUTINE debug_integrate_gf_rspace_NoPBC(ilevel, zetp, rp, W, pwgrid, cube_inf INTEGER, INTENT(IN) :: auxbas_grid INTEGER, DIMENSION(3), INTENT(IN) :: n_rep_real INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'debug_integrate_gf_rspace_NoPBC', & @@ -1608,24 +1579,24 @@ SUBROUTINE debug_integrate_gf_rspace_NoPBC(ilevel, zetp, rp, W, pwgrid, cube_inf NULLIFY(grids) !Statements ngrids = SIZE(aug_pools) - CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE,error=error) + CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE) DO igrid=1,ngrids - CALL pw_zero(grids(igrid)%pw,error=error) + CALL pw_zero(grids(igrid)%pw) END DO bo2 = grids(auxbas_grid)%pw%pw_grid%bounds ALLOCATE (xdat(bo2(1,1):bo2(2,1)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (ydat(bo2(1,2):bo2(2,2)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (zdat(bo2(1,3):bo2(2,3)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Icount = Icount + 1 DO i = 1, 3 DO k = 1, 2 myrp = rp myrp(i) = myrp(i) + (-1.0_dp)**k * Dx - CALL pw_zero(grids(ilevel)%pw,error=error) + CALL pw_zero(grids(ilevel)%pw) CALL collocate_gf_rspace_NoPBC(zetp=zetp,& rp=myrp,& scale=-1.0_dp,& @@ -1640,7 +1611,7 @@ SUBROUTINE debug_integrate_gf_rspace_NoPBC(ilevel, zetp, rp, W, pwgrid, cube_inf n_rep_real=n_rep_real,& mm_cell=mm_cell) - energy(k) = pw_integral_ab(pwgrid, grids(ilevel)%pw,error=error) + energy(k) = pw_integral_ab(pwgrid, grids(ilevel)%pw) END DO force(i) = ( energy(2) - energy(1) ) / (2.0_dp * Dx) END DO @@ -1654,24 +1625,24 @@ SUBROUTINE debug_integrate_gf_rspace_NoPBC(ilevel, zetp, rp, W, pwgrid, cube_inf WRITE(iw,100)Icount, debug_force(1), force(1), Err(1),& debug_force(2), force(2), Err(2),& debug_force(3), force(3), Err(3) - CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,error,failure) + CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,failure) IF (ASSOCIATED(xdat)) THEN DEALLOCATE (xdat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(ydat)) THEN DEALLOCATE (ydat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(zdat)) THEN DEALLOCATE (zdat, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF - CALL pw_pools_give_back_pws(aug_pools,grids,error=error) + CALL pw_pools_give_back_pws(aug_pools,grids) CALL timestop(handle) 100 FORMAT("Collocation : ",I5,2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ") END SUBROUTINE debug_integrate_gf_rspace_NoPBC @@ -1694,14 +1665,13 @@ END SUBROUTINE debug_integrate_gf_rspace_NoPBC !> \param iw ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error ... !> \par History !> 08.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE debug_qmmm_forces_with_gauss_LG(pgfs,aug_pools, rho, mm_charges, mm_atom_index,& mm_particles, num_mm_atoms, coarser_grid_level, per_potentials,& - debug_force, para_env, mm_cell,dOmmOqm,iw,par_scheme,qmmm_spherical_cutoff,error) + debug_force, para_env, mm_cell,dOmmOqm,iw,par_scheme,qmmm_spherical_cutoff) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: pgfs @@ -1722,7 +1692,6 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LG(pgfs,aug_pools, rho, mm_charges, mm_a REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: dOmmOqm INTEGER, INTENT(IN) :: iw, par_scheme REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: qmmm_spherical_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'debug_qmmm_forces_with_gauss_LG', & @@ -1738,13 +1707,13 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LG(pgfs,aug_pools, rho, mm_charges, mm_a TYPE(pw_p_type), DIMENSION(:), POINTER :: grids ALLOCATE(Num_Forces(3,num_mm_atoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(grids) CALL timeset(routineN,handle) ngrids = SIZE(aug_pools) - CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE,error=error) + CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE) DO igrid=1,ngrids - CALL pw_zero(grids(igrid)%pw,error=error) + CALL pw_zero(grids(igrid)%pw) END DO Atoms: DO I = 1, num_mm_atoms IndMM = mm_atom_index(I) @@ -1753,7 +1722,7 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LG(pgfs,aug_pools, rho, mm_charges, mm_a energy = 0.0_dp Diff: DO K = 1, 2 mm_particles(IndMM)%r(J) = Coord_save + (-1)**K * Dx - CALL pw_zero(grids(coarser_grid_level)%pw,error=error) + CALL pw_zero(grids(coarser_grid_level)%pw) CALL qmmm_elec_with_gaussian_LG (pgfs=pgfs,& cgrid=grids(coarser_grid_level)%pw,& @@ -1765,10 +1734,9 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LG(pgfs,aug_pools, rho, mm_charges, mm_a mm_cell=mm_cell,& dOmmOqm=dOmmOqm,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) - energy(K) = pw_integral_ab ( rho, grids(coarser_grid_level)%pw ,error=error) + energy(K) = pw_integral_ab ( rho, grids(coarser_grid_level)%pw) END DO Diff IF (iw>0)& WRITE(iw,'(A,I6,A,I3,A,2F15.9)')& @@ -1790,14 +1758,14 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LG(pgfs,aug_pools, rho, mm_charges, mm_a WRITE(iw,100)IndMM,debug_force(1,I),Num_Forces(1,I),Err(1),& debug_force(2,I),Num_Forces(2,I),Err(2),& debug_force(3,I),Num_Forces(3,I),Err(3) - CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,error,failure) + CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,failure) END DO DEALLOCATE(Num_Forces,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_pools_give_back_pws(aug_pools,grids,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_pools_give_back_pws(aug_pools,grids) CALL timestop(handle) 100 FORMAT("MM Atom LR : ",I5,2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ") END SUBROUTINE debug_qmmm_forces_with_gauss_LG @@ -1820,14 +1788,13 @@ END SUBROUTINE debug_qmmm_forces_with_gauss_LG !> \param iw ... !> \param par_scheme ... !> \param qmmm_spherical_cutoff ... -!> \param error ... !> \par History !> 08.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE debug_qmmm_forces_with_gauss_LR(pgfs,aug_pools, rho, mm_charges, mm_atom_index,& mm_particles, num_mm_atoms, coarser_grid_level, potentials,& - debug_force, para_env, mm_cell,dOmmOqm,iw, par_scheme, qmmm_spherical_cutoff, error) + debug_force, para_env, mm_cell,dOmmOqm,iw, par_scheme, qmmm_spherical_cutoff) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: pgfs @@ -1848,7 +1815,6 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LR(pgfs,aug_pools, rho, mm_charges, mm_a REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: dOmmOqm INTEGER, INTENT(IN) :: iw, par_scheme REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: qmmm_spherical_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'debug_qmmm_forces_with_gauss_LR', & @@ -1864,13 +1830,13 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LR(pgfs,aug_pools, rho, mm_charges, mm_a TYPE(pw_p_type), DIMENSION(:), POINTER :: grids ALLOCATE(Num_Forces(3,num_mm_atoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(grids) CALL timeset(routineN,handle) ngrids = SIZE(aug_pools) - CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE,error=error) + CALL pw_pools_create_pws(aug_pools,grids,use_data=REALDATA3D,in_space=REALSPACE) DO igrid=1,ngrids - CALL pw_zero(grids(igrid)%pw,error=error) + CALL pw_zero(grids(igrid)%pw) END DO Atoms: DO I = 1, num_mm_atoms IndMM = mm_atom_index(I) @@ -1879,7 +1845,7 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LR(pgfs,aug_pools, rho, mm_charges, mm_a energy = 0.0_dp Diff: DO K = 1, 2 mm_particles(IndMM)%r(J) = Coord_save + (-1)**K * Dx - CALL pw_zero(grids(coarser_grid_level)%pw,error=error) + CALL pw_zero(grids(coarser_grid_level)%pw) CALL qmmm_elec_with_gaussian_LR (pgfs=pgfs,& grid=grids(coarser_grid_level)%pw,& @@ -1891,10 +1857,9 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LR(pgfs,aug_pools, rho, mm_charges, mm_a mm_cell=mm_cell,& dOmmOqm=dOmmOqm,& par_scheme=par_scheme,& - qmmm_spherical_cutoff=qmmm_spherical_cutoff,& - error=error) + qmmm_spherical_cutoff=qmmm_spherical_cutoff) - energy(K) = pw_integral_ab ( rho, grids(coarser_grid_level)%pw ,error=error) + energy(K) = pw_integral_ab ( rho, grids(coarser_grid_level)%pw) END DO Diff IF (iw>0)& WRITE(iw,'(A,I6,A,I3,A,2F15.9)')& @@ -1916,14 +1881,14 @@ SUBROUTINE debug_qmmm_forces_with_gauss_LR(pgfs,aug_pools, rho, mm_charges, mm_a WRITE(iw,100)IndMM,debug_force(1,I),Num_Forces(1,I),Err(1),& debug_force(2,I),Num_Forces(2,I),Err(2),& debug_force(3,I),Num_Forces(3,I),Err(3) - CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,error,failure) - CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,error,failure) + CPPostcondition(ABS(Err(1))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(2))<=MaxErr,cp_failure_level,routineP,failure) + CPPostcondition(ABS(Err(3))<=MaxErr,cp_failure_level,routineP,failure) END DO DEALLOCATE(Num_Forces,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_pools_give_back_pws(aug_pools,grids,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_pools_give_back_pws(aug_pools,grids) CALL timestop(handle) 100 FORMAT("MM Atom LR : ",I5,2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ",2F15.9," ( ",F7.2," ) ") END SUBROUTINE debug_qmmm_forces_with_gauss_LR diff --git a/src/qmmm_image_charge.F b/src/qmmm_image_charge.F index e018366f19..6596605774 100644 --- a/src/qmmm_image_charge.F +++ b/src/qmmm_image_charge.F @@ -93,18 +93,15 @@ MODULE qmmm_image_charge !> \param energy structure where energies are stored !> \param qmmm_env qmmm environment !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calculate_image_pot(v_hartree_rspace,rho_hartree_gspace,energy,& - qmmm_env,qs_env,error) + qmmm_env,qs_env) TYPE(pw_p_type), INTENT(IN) :: v_hartree_rspace, & rho_hartree_gspace TYPE(qs_energy_type), POINTER :: energy TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_image_pot', & routineP = moduleN//':'//routineN @@ -121,29 +118,27 @@ SUBROUTINE calculate_image_pot(v_hartree_rspace,rho_hartree_gspace,energy,& IF(qs_env%calc_image_preconditioner) THEN IF(qmmm_env%image_charge_pot%image_restart) THEN CALL restart_image_matrix(image_matrix=qs_env%image_matrix,& - qs_env=qs_env,qmmm_env=qmmm_env,& - error=error) + qs_env=qs_env,qmmm_env=qmmm_env) ELSE CALL calculate_image_matrix(image_matrix=qs_env%image_matrix,& - qs_env=qs_env,qmmm_env=qmmm_env,& - error=error) + qs_env=qs_env,qmmm_env=qmmm_env) ENDIF ENDIF CALL calc_image_coeff_iterative(v_hartree_rspace=v_hartree_rspace,& coeff=qs_env%image_coeff,qmmm_env=qmmm_env,& - qs_env=qs_env,error=error) + qs_env=qs_env) ELSE CALL calc_image_coeff_gaussalgorithm(v_hartree_rspace=v_hartree_rspace,& coeff=qs_env%image_coeff,qmmm_env=qmmm_env,& - qs_env=qs_env,error=error) + qs_env=qs_env) ENDIF ! calculate the image/metal potential with the optimized coefficients CALL calculate_potential_metal(v_metal_rspace=& qs_env%ks_qmmm_env%v_metal_rspace,coeff=qs_env%image_coeff,& rho_hartree_gspace=rho_hartree_gspace,& - energy=energy,qs_env=qs_env,error=error) + energy=energy,qs_env=qs_env) CALL timestop(handle) @@ -158,18 +153,15 @@ END SUBROUTINE calculate_image_pot !> rho_metal=sum_a c_a*g_a !> \param qmmm_env qmmm environment !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calc_image_coeff_gaussalgorithm(v_hartree_rspace,coeff,qmmm_env,& - qs_env,error) + qs_env) TYPE(pw_p_type), INTENT(IN) :: v_hartree_rspace REAL(KIND=dp), DIMENSION(:), POINTER :: coeff TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'calc_image_coeff_gaussalgorithm', & @@ -191,15 +183,15 @@ SUBROUTINE calc_image_coeff_gaussalgorithm(v_hartree_rspace,coeff,qmmm_env,& natom=SIZE(qmmm_env%image_charge_pot%image_mm_list) ALLOCATE(pot_const(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(.NOT.ASSOCIATED(coeff)) THEN ALLOCATE(coeff(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF coeff=0.0_dp CALL integrate_potential_ga_rspace(v_hartree_rspace,qmmm_env,qs_env,& - pot_const,error=error) + pot_const) !add integral V0*ga(r) pot_const(:)=-pot_const(:)+V0*SQRT((pi/eta)**3) @@ -207,12 +199,12 @@ SUBROUTINE calc_image_coeff_gaussalgorithm(v_hartree_rspace,coeff,qmmm_env,& !LU factorization of T by DGETRF done in calculate_image_matrix CALL DGETRS('N',natom,1,qs_env%image_matrix,natom,qs_env%ipiv,& pot_const,natom,info) - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) coeff = pot_const DEALLOCATE(pot_const,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -225,18 +217,15 @@ END SUBROUTINE calc_image_coeff_gaussalgorithm !> rho_metal=sum_a c_a*g_a !> \param qmmm_env qmmm environment !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calc_image_coeff_iterative(v_hartree_rspace,coeff,qmmm_env,& - qs_env,error) + qs_env) TYPE(pw_p_type), INTENT(IN) :: v_hartree_rspace REAL(KIND=dp), DIMENSION(:), POINTER :: coeff TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_image_coeff_iterative', & routineP = moduleN//':'//routineN @@ -256,7 +245,7 @@ SUBROUTINE calc_image_coeff_iterative(v_hartree_rspace,coeff,qmmm_env,& NULLIFY(pot_const,vmetal_const,logger,input) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() !minus sign V0: account for the fact that v_hartree has the opposite sign V0=-qmmm_env%image_charge_pot%V0 @@ -264,24 +253,24 @@ SUBROUTINE calc_image_coeff_iterative(v_hartree_rspace,coeff,qmmm_env,& natom=SIZE(qmmm_env%image_charge_pot%image_mm_list) ALLOCATE(pot_const(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vmetal_const(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(r(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(d(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(z(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Ad(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(.NOT.ASSOCIATED(coeff)) THEN ALLOCATE(coeff(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL integrate_potential_ga_rspace(v_hartree_rspace,qmmm_env,qs_env,& - pot_const,error=error) + pot_const) !add integral V0*ga(r) pot_const(:)=-pot_const(:)+V0*SQRT((pi/eta)**3) @@ -297,9 +286,9 @@ SUBROUTINE calc_image_coeff_iterative(v_hartree_rspace,coeff,qmmm_env,& !calculate first guess of image/metal potential CALL calculate_potential_metal(v_metal_rspace=v_metal_rspace_guess,& - coeff=coeff,qs_env=qs_env,error=error) + coeff=coeff,qs_env=qs_env) CALL integrate_potential_ga_rspace(potential=v_metal_rspace_guess,& - qmmm_env=qmmm_env,qs_env=qs_env,int_res=vmetal_const,error=error) + qmmm_env=qmmm_env,qs_env=qs_env,int_res=vmetal_const) ! modify coefficients iteratively r=pot_const-vmetal_const @@ -311,10 +300,10 @@ SUBROUTINE calc_image_coeff_iterative(v_hartree_rspace,coeff,qmmm_env,& !calculate A*d Ad=0.0_dp CALL calculate_potential_metal(v_metal_rspace=& - auxpot_Ad_rspace,coeff=d,qs_env=qs_env,error=error) + auxpot_Ad_rspace,coeff=d,qs_env=qs_env) CALL integrate_potential_ga_rspace(potential=& auxpot_Ad_rspace,qmmm_env=qmmm_env,& - qs_env=qs_env,int_res=Ad,error=error) + qs_env=qs_env,int_res=Ad) alpha=rsold/DOT_PRODUCT(d,Ad) coeff=coeff+alpha*d @@ -324,25 +313,24 @@ SUBROUTINE calc_image_coeff_iterative(v_hartree_rspace,coeff,qmmm_env,& rsnew=DOT_PRODUCT(r,z) iter_steps=iter_steps+1 IF(SQRT(rsnew)<1.0E-08) THEN - CALL pw_release(auxpot_Ad_rspace%pw,error=error) + CALL pw_release(auxpot_Ad_rspace%pw) EXIT END IF d=z+rsnew/rsold*d rsold=rsnew - CALL pw_release(auxpot_Ad_rspace%pw,error=error) + CALL pw_release(auxpot_Ad_rspace%pw) ENDDO ! print iteration info CALL get_qs_env(qs_env=qs_env,& - input=input,& - error=error) + input=input) output_unit=cp_print_key_unit_nr(logger,input,& "QMMM%PRINT%PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") IF (output_unit>0) WRITE (UNIT=output_unit,FMT="(T3,A,T74,I7)")& "Number of iteration steps for determination of image coefficients:",iter_steps CALL cp_print_key_finished_output(output_unit,logger,input,& - "QMMM%PRINT%PROGRAM_RUN_INFO", error=error) + "QMMM%PRINT%PROGRAM_RUN_INFO") IF(iter_steps.lt.25) THEN @@ -351,17 +339,17 @@ SUBROUTINE calc_image_coeff_iterative(v_hartree_rspace,coeff,qmmm_env,& qs_env%calc_image_preconditioner=.TRUE. ENDIF - CALL pw_release(v_metal_rspace_guess%pw,error=error) + CALL pw_release(v_metal_rspace_guess%pw) DEALLOCATE(pot_const,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(vmetal_const,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(d,z,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Ad,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -376,11 +364,9 @@ END SUBROUTINE calc_image_coeff_iterative !> \param atom_num atom index, needed when calculating image_matrix !> \param atom_num_ref index of reference atom, needed when calculating !> image_matrix -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE integrate_potential_ga_rspace(potential,qmmm_env,qs_env,int_res,& - atom_num,atom_num_ref,error) + atom_num,atom_num_ref) TYPE(pw_p_type), INTENT(IN) :: potential @@ -388,7 +374,6 @@ SUBROUTINE integrate_potential_ga_rspace(potential,qmmm_env,qs_env,int_res,& TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), DIMENSION(:), POINTER :: int_res INTEGER, INTENT(IN), OPTIONAL :: atom_num, atom_num_ref - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'integrate_potential_ga_rspace', & @@ -414,19 +399,18 @@ SUBROUTINE integrate_potential_ga_rspace(potential,qmmm_env,qs_env,int_res,& NULLIFY(cores,hab,cell,auxbas_rs_desc,pw_env,para_env,& dft_control,rs_v) ALLOCATE (hab(1,1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) CALL pw_env_get(pw_env=pw_env,auxbas_rs_desc=auxbas_rs_desc, & - auxbas_rs_grid=rs_v,error=error) - CALL rs_grid_retain(rs_v,error=error) - CALL rs_pw_transfer(rs_v,potential%pw,pw2rs,error=error) + auxbas_rs_grid=rs_v) + CALL rs_grid_retain(rs_v) + CALL rs_pw_transfer(rs_v,potential%pw,pw2rs) CALL get_qs_env(qs_env=qs_env,& cell=cell,& dft_control=dft_control,& - para_env=para_env,pw_env=pw_env,& - error=error) + para_env=para_env,pw_env=pw_env) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -477,7 +461,7 @@ SUBROUTINE integrate_potential_ga_rspace(potential,qmmm_env,qs_env,int_res,& 0,0.0_dp,0,ra,(/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,& rs_v,cell,pw_env%cube_info(1),hab,o1=0,o2=0,& eps_gvg_rspace=eps_rho_rspace, calculate_forces=.FALSE.,& - use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + use_subpatch=.TRUE.,subpatch_pattern=0_int_8) int_res(iatom) = hab(1,1) @@ -486,9 +470,9 @@ SUBROUTINE integrate_potential_ga_rspace(potential,qmmm_env,qs_env,int_res,& CALL mp_sum(int_res,para_env%group) DEALLOCATE (hab,cores,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) CALL timestop(handle) @@ -503,18 +487,15 @@ END SUBROUTINE integrate_potential_ga_rspace !> for the metal (MM) atoms !> \param qmmm_env qmmm environment !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE integrate_potential_devga_rspace(potential,coeff,forces,qmmm_env,& - qs_env,error) + qs_env) TYPE(pw_p_type), INTENT(IN) :: potential REAL(KIND=dp), DIMENSION(:), POINTER :: coeff REAL(KIND=dp), DIMENSION(:, :), POINTER :: forces TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'integrate_potential_devga_rspace', & @@ -543,28 +524,28 @@ SUBROUTINE integrate_potential_devga_rspace(potential,coeff,forces,qmmm_env,& use_virial=.FALSE. ALLOCATE (hab(1,1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (pab(1,1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) CALL pw_env_get(pw_env=pw_env,auxbas_rs_desc=auxbas_rs_desc, & - auxbas_rs_grid=rs_v,error=error) - CALL rs_grid_retain(rs_v,error=error) - CALL rs_pw_transfer(rs_v,potential%pw,pw2rs,error=error) + auxbas_rs_grid=rs_v) + CALL rs_grid_retain(rs_v) + CALL rs_pw_transfer(rs_v,potential%pw,pw2rs) CALL get_qs_env(qs_env=qs_env,& cell=cell,& dft_control=dft_control,& para_env=para_env,pw_env=pw_env,& - virial=virial,error=error) + virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Virial not implemented for image charge method", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -573,7 +554,7 @@ SUBROUTINE integrate_potential_devga_rspace(potential,coeff,forces,qmmm_env,& IF(.NOT.ASSOCIATED(forces)) THEN ALLOCATE(forces(3,natom), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF forces(:,:)=0.0_dp @@ -611,7 +592,7 @@ SUBROUTINE integrate_potential_devga_rspace(potential,coeff,forces,qmmm_env,& rs_v,cell,pw_env%cube_info(1),hab,pab,o1=0,o2=0,& eps_gvg_rspace=eps_rho_rspace, calculate_forces=.TRUE.,& force_a=force_a,force_b=force_b,use_subpatch=.TRUE.,& - subpatch_pattern=0_int_8,error=error) + subpatch_pattern=0_int_8) force_a(:)=coeff(iatom)*force_a(:) forces(:,iatom) = force_a(:) @@ -621,12 +602,12 @@ SUBROUTINE integrate_potential_devga_rspace(potential,coeff,forces,qmmm_env,& CALL mp_sum(forces,para_env%group) DEALLOCATE (hab,pab,cores,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) ! print info on gradients if wanted - CALL print_gradients_image_atoms(forces, qs_env, error) + CALL print_gradients_image_atoms(forces, qs_env) CALL timestop(handle) @@ -638,14 +619,11 @@ END SUBROUTINE integrate_potential_devga_rspace !> in case coefficients are estimated not iteratively !> \param qs_env qs environment !> \param qmmm_env qmmm environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE conditional_calc_image_matrix(qs_env,qmmm_env,error) + SUBROUTINE conditional_calc_image_matrix(qs_env,qmmm_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'conditional_calc_image_matrix', & @@ -655,14 +633,12 @@ SUBROUTINE conditional_calc_image_matrix(qs_env,qmmm_env,error) SELECT CASE(qmmm_env%image_charge_pot%state_image_matrix) CASE(calc_always) CALL calculate_image_matrix(image_matrix=qs_env%image_matrix,& - ipiv=qs_env%ipiv,qs_env=qs_env,qmmm_env=qmmm_env,& - error=error) + ipiv=qs_env%ipiv,qs_env=qs_env,qmmm_env=qmmm_env) CASE(calc_once) !if all image atoms are fully constrained, calculate image matrix !only for the first MD or GEO_OPT step CALL calculate_image_matrix(image_matrix=qs_env%image_matrix,& - ipiv=qs_env%ipiv,qs_env=qs_env,qmmm_env=qmmm_env,& - error=error) + ipiv=qs_env%ipiv,qs_env=qs_env,qmmm_env=qmmm_env) qmmm_env%image_charge_pot%state_image_matrix = calc_once_done CALL cp_assert(.NOT.qmmm_env%center_qm_subsys0,cp_warning_level,& cp_assertion_failed,routineP,"The image atoms are fully "//& @@ -686,16 +662,13 @@ END SUBROUTINE conditional_calc_image_matrix !> \param ipiv pivoting prior to DGETRS (for Gaussian elimination) !> \param qs_env qs environment !> \param qmmm_env qmmm environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE calculate_image_matrix(image_matrix,ipiv,qs_env,qmmm_env,error) + SUBROUTINE calculate_image_matrix(image_matrix,ipiv,qs_env,qmmm_env) REAL(KIND=dp), DIMENSION(:, :), POINTER :: image_matrix INTEGER, DIMENSION(:), OPTIONAL, POINTER :: ipiv TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_image_matrix', & routineP = moduleN//':'//routineN @@ -717,34 +690,34 @@ SUBROUTINE calculate_image_matrix(image_matrix,ipiv,qs_env,qmmm_env,error) NULLIFY(pw_env, auxbas_pw_pool, poisson_env, para_env, int_res,& input, logger) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() natom=SIZE(qmmm_env%image_charge_pot%image_mm_list) IF (.NOT.ASSOCIATED(image_matrix)) THEN ALLOCATE(image_matrix(natom,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (PRESENT(ipiv)) THEN IF (.NOT.ASSOCIATED(ipiv)) THEN ALLOCATE(ipiv(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDIF ALLOCATE(int_res(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) image_matrix=0.0_dp IF(PRESENT(ipiv)) ipiv=0 CALL get_qs_env(qs_env, pw_env=pw_env,para_env=para_env,& - input=input,error=error) + input=input) !print info output_unit=cp_print_key_unit_nr(logger,input,& "QMMM%PRINT%PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") IF (qmmm_env%image_charge_pot%coeff_iterative) THEN IF (output_unit>0) WRITE (UNIT=output_unit,FMT="(T3,A)")& "Calculating image matrix" @@ -753,44 +726,40 @@ SUBROUTINE calculate_image_matrix(image_matrix,ipiv,qs_env,qmmm_env,error) "Calculating image matrix" ENDIF CALL cp_print_key_finished_output(output_unit,logger,input,& - "QMMM%PRINT%PROGRAM_RUN_INFO", error=error) + "QMMM%PRINT%PROGRAM_RUN_INFO") CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env, error=error) + poisson_env=poisson_env) CALL pw_pool_create_pw(auxbas_pw_pool,& rho_gb%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& vb_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& vb_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) ! calculate vb only once for one reference atom iatom_ref = 1 ! !collocate gaussian of reference MM atom on grid - CALL pw_zero(rho_gb%pw, error=error) - CALL calculate_rho_single_gaussian(rho_gb,qs_env,iatom_ref,error) + CALL pw_zero(rho_gb%pw) + CALL calculate_rho_single_gaussian(rho_gb,qs_env,iatom_ref) !calculate potential vb like hartree potential - CALL pw_zero(vb_gspace%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_gb%pw,vhartree=vb_gspace%pw,& - error=error) - CALL pw_zero(vb_rspace%pw, error=error) - CALL pw_transfer(vb_gspace%pw,vb_rspace%pw,error=error) - CALL pw_scale(vb_rspace%pw,vb_rspace%pw%pw_grid%dvol,error=error) + CALL pw_zero(vb_gspace%pw) + CALL pw_poisson_solve(poisson_env,rho_gb%pw,vhartree=vb_gspace%pw) + CALL pw_zero(vb_rspace%pw) + CALL pw_transfer(vb_gspace%pw,vb_rspace%pw) + CALL pw_scale(vb_rspace%pw,vb_rspace%pw%pw_grid%dvol) DO iatom=1,natom !calculate integral vb_rspace*ga int_res=0.0_dp CALL integrate_potential_ga_rspace(vb_rspace,qs_env%qmmm_env_qm,& qs_env,int_res,atom_num=iatom,& - atom_num_ref=iatom_ref,error=error) + atom_num_ref=iatom_ref) image_matrix(iatom,iatom:natom)=int_res(iatom:natom) image_matrix(iatom+1:natom,iatom)=int_res(iatom+1:natom) END DO @@ -798,29 +767,29 @@ SUBROUTINE calculate_image_matrix(image_matrix,ipiv,qs_env,qmmm_env,error) IF (qmmm_env%image_charge_pot%coeff_iterative) THEN !inversion --> preconditioner matrix for CG CALL DPOTRF('L',natom,qs_env%image_matrix,natom,stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) CALL DPOTRI('L',natom,qs_env%image_matrix,natom,stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) DO j=1,natom DO k=j+1,natom qs_env%image_matrix(j,k)=qs_env%image_matrix(k,j) ENDDO ENDDO - CALL write_image_matrix(qs_env%image_matrix,qs_env,error) + CALL write_image_matrix(qs_env%image_matrix,qs_env) ELSE !pivoting prior to DGETRS (Gaussian elimination) IF(PRESENT(ipiv)) THEN CALL DGETRF(natom,natom,image_matrix,natom,ipiv,stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF ENDIF - CALL pw_release(vb_gspace%pw,error=error) - CALL pw_release(vb_rspace%pw,error=error) - CALL pw_release(rho_gb%pw,error=error) + CALL pw_release(vb_gspace%pw) + CALL pw_release(vb_rspace%pw) + CALL pw_release(rho_gb%pw) DEALLOCATE(int_res,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) @@ -835,18 +804,15 @@ END SUBROUTINE calculate_image_matrix !> \param rho_hartree_gspace Kohn Sham density in reciprocal space !> \param energy structure where energies are stored !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calculate_potential_metal(v_metal_rspace,coeff,rho_hartree_gspace,energy,& - qs_env,error) + qs_env) TYPE(pw_p_type), INTENT(INOUT) :: v_metal_rspace REAL(KIND=dp), DIMENSION(:), POINTER :: coeff TYPE(pw_p_type), INTENT(IN), OPTIONAL :: rho_hartree_gspace TYPE(qs_energy_type), OPTIONAL, POINTER :: energy TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_potential_metal', & routineP = moduleN//':'//routineN @@ -868,51 +834,47 @@ SUBROUTINE calculate_potential_metal(v_metal_rspace,coeff,rho_hartree_gspace,ene en_vmetal_rhohartree=0.0_dp en_external=0.0_dp - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env,error=error) + poisson_env=poisson_env) CALL pw_pool_create_pw(auxbas_pw_pool,& rho_metal%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& v_metal_gspace%pw, & use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& v_metal_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) - CALL pw_zero(rho_metal%pw,error=error) + CALL pw_zero(rho_metal%pw) CALL calculate_rho_metal(rho_metal,coeff,total_rho_metal=total_rho_metal,& - qs_env=qs_env,error=error) + qs_env=qs_env) - CALL pw_zero(v_metal_gspace%pw, error=error) + CALL pw_zero(v_metal_gspace%pw) CALL pw_poisson_solve(poisson_env,rho_metal%pw,& - vhartree=v_metal_gspace%pw,error=error) + vhartree=v_metal_gspace%pw) IF(PRESENT(rho_hartree_gspace)) THEN en_vmetal_rhohartree=0.5_dp*pw_integral_ab(v_metal_gspace%pw,& - rho_hartree_gspace%pw,error=error) + rho_hartree_gspace%pw) en_external=qs_env%qmmm_env_qm%image_charge_pot%V0*total_rho_metal energy%image_charge=en_vmetal_rhohartree-0.5_dp*en_external CALL print_image_energy_terms(en_vmetal_rhohartree,en_external,& - total_rho_metal,qs_env,error) + total_rho_metal,qs_env) ENDIF - CALL pw_zero(v_metal_rspace%pw, error=error) - CALL pw_transfer(v_metal_gspace%pw,v_metal_rspace%pw,error=error) - CALL pw_scale(v_metal_rspace%pw,v_metal_rspace%pw%pw_grid%dvol,& - error=error) - CALL pw_release(v_metal_gspace%pw,error=error) - CALL pw_release(rho_metal%pw,error=error) + CALL pw_zero(v_metal_rspace%pw) + CALL pw_transfer(v_metal_gspace%pw,v_metal_rspace%pw) + CALL pw_scale(v_metal_rspace%pw,v_metal_rspace%pw%pw_grid%dvol) + CALL pw_release(v_metal_gspace%pw) + CALL pw_release(rho_metal%pw) CALL timestop(handle) @@ -923,15 +885,12 @@ END SUBROUTINE calculate_potential_metal !> \param v_hartree Hartree potential (in real space) !> \param v_metal potential generated by rho_metal (in real space) !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE add_image_pot_to_hartree_pot(v_hartree,v_metal,qs_env,error) + SUBROUTINE add_image_pot_to_hartree_pot(v_hartree,v_metal,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: v_hartree TYPE(pw_p_type), INTENT(IN) :: v_metal TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_image_pot_to_hartree_pot', & routineP = moduleN//':'//routineN @@ -945,22 +904,21 @@ SUBROUTINE add_image_pot_to_hartree_pot(v_hartree,v_metal,qs_env,error) NULLIFY(input,logger) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() !add image charge potential v_hartree%pw%cr3d = v_hartree%pw%cr3d + v_metal%pw%cr3d ! print info CALL get_qs_env(qs_env=qs_env,& - input=input,& - error=error) + input=input) output_unit=cp_print_key_unit_nr(logger,input,& "QMMM%PRINT%PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") IF (output_unit>0) WRITE (UNIT=output_unit,FMT="(T3,A)")& "Adding image charge potential to the Hartree potential." CALL cp_print_key_finished_output(output_unit,logger,input,& - "QMMM%PRINT%PROGRAM_RUN_INFO", error=error) + "QMMM%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -971,14 +929,11 @@ END SUBROUTINE add_image_pot_to_hartree_pot !> calculating image coefficients iteratively !> \param image_matrix matrix T !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE write_image_matrix(image_matrix,qs_env,error) + SUBROUTINE write_image_matrix(image_matrix,qs_env) REAL(KIND=dp), DIMENSION(:, :), POINTER :: image_matrix TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_image_matrix', & routineP = moduleN//':'//routineN @@ -993,20 +948,18 @@ SUBROUTINE write_image_matrix(image_matrix,qs_env,error) CALL timeset(routineN,handle) NULLIFY(qmmm_section, print_key, logger, para_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. rst_unit = -1 CALL get_qs_env(qs_env=qs_env,para_env=para_env,& - input=qmmm_section,& - error=error) + input=qmmm_section) print_key => section_vals_get_subs_vals(qmmm_section,& - "QMMM%PRINT%IMAGE_CHARGE_RESTART",& - error=error) + "QMMM%PRINT%IMAGE_CHARGE_RESTART") IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qmmm_section,"QMMM%PRINT%IMAGE_CHARGE_RESTART",error=error),& + qmmm_section,"QMMM%PRINT%IMAGE_CHARGE_RESTART"),& cp_p_file)) THEN rst_unit = cp_print_key_unit_nr(logger,qmmm_section,& @@ -1014,19 +967,18 @@ SUBROUTINE write_image_matrix(image_matrix,qs_env,error) extension=".Image",& file_status="REPLACE",& file_action="WRITE",& - file_form="UNFORMATTED",& - error=error) + file_form="UNFORMATTED") IF(rst_unit>0) filename = cp_print_key_generate_filename(logger,& print_key, extension=".IMAGE", & - my_local=.FALSE.,error=error) + my_local=.FALSE.) IF(rst_unit>0) THEN WRITE(rst_unit) image_matrix ENDIF CALL cp_print_key_finished_output(rst_unit,logger,qmmm_section,& - "QMMM%PRINT%IMAGE_CHARGE_RESTART", error=error) + "QMMM%PRINT%IMAGE_CHARGE_RESTART") ENDIF CALL timestop(handle) @@ -1039,15 +991,12 @@ END SUBROUTINE write_image_matrix !> \param image_matrix matrix T !> \param qs_env qs environment !> \param qmmm_env qmmm environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE restart_image_matrix(image_matrix,qs_env,qmmm_env,error) + SUBROUTINE restart_image_matrix(image_matrix,qs_env,qmmm_env) REAL(KIND=dp), DIMENSION(:, :), POINTER :: image_matrix TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restart_image_matrix', & routineP = moduleN//':'//routineN @@ -1063,7 +1012,7 @@ SUBROUTINE restart_image_matrix(image_matrix,qs_env,qmmm_env,error) CALL timeset(routineN,handle) NULLIFY(qmmm_section, logger, para_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. exist= .FALSE. rst_unit=-1 @@ -1072,17 +1021,16 @@ SUBROUTINE restart_image_matrix(image_matrix,qs_env,qmmm_env,error) IF (.NOT.ASSOCIATED(image_matrix)) THEN ALLOCATE(image_matrix(natom,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF image_matrix=0.0_dp CALL get_qs_env(qs_env=qs_env,para_env=para_env,& - input=qmmm_section,& - error=error) + input=qmmm_section) CALL section_vals_val_get(qmmm_section,"QMMM%IMAGE_CHARGE%IMAGE_RESTART_FILE_NAME",& - c_val=image_filename, error=error) + c_val=image_filename) INQUIRE(FILE=image_filename, exist=exist) @@ -1103,7 +1051,7 @@ SUBROUTINE restart_image_matrix(image_matrix,qs_env,qmmm_env,error) output_unit=cp_print_key_unit_nr(logger,qmmm_section,& "QMMM%PRINT%PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") IF (output_unit>0) WRITE (UNIT=output_unit,FMT="(T3,A)")& "Restarted image matrix" ELSE @@ -1122,15 +1070,12 @@ END SUBROUTINE restart_image_matrix !> \param forces structure storing the force contribution of the image charges !> for the metal (MM) atoms (actually these are only the gradients) !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_gradients_image_atoms(forces,qs_env,error) + SUBROUTINE print_gradients_image_atoms(forces,qs_env) REAL(KIND=dp), DIMENSION(:, :), POINTER :: forces TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_gradients_image_atoms', & routineP = moduleN//':'//routineN @@ -1142,7 +1087,7 @@ SUBROUTINE print_gradients_image_atoms(forces,qs_env,error) TYPE(section_vals_type), POINTER :: input NULLIFY(input, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() sum_gradients=0.0_dp natom=SIZE(qs_env%qmmm_env_qm%image_charge_pot%image_mm_list) @@ -1151,10 +1096,10 @@ SUBROUTINE print_gradients_image_atoms(forces,qs_env,error) sum_gradients(:)=sum_gradients(:)+forces(:,iatom) ENDDO - CALL get_qs_env(qs_env=qs_env,input=input,error=error) + CALL get_qs_env(qs_env=qs_env,input=input) output_unit = cp_print_key_unit_nr(logger,input,& - "QMMM%PRINT%DERIVATIVES",extension=".Log",error=error) + "QMMM%PRINT%DERIVATIVES",extension=".Log") IF(output_unit>0) THEN WRITE (unit=output_unit,fmt="(/1X,A)")& "Image gradients [a.u.] on MM image charge atoms after QMMM calculation: " @@ -1173,7 +1118,7 @@ SUBROUTINE print_gradients_image_atoms(forces,qs_env,error) ENDIF CALL cp_print_key_finished_output(output_unit,logger,input,& - "QMMM%PRINT%DERIVATIVES",error=error) + "QMMM%PRINT%DERIVATIVES") END SUBROUTINE print_gradients_image_atoms @@ -1181,14 +1126,11 @@ END SUBROUTINE print_gradients_image_atoms !> \brief Print image coefficients !> \param image_coeff expansion coefficients of the image charge density !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_image_coefficients(image_coeff,qs_env,error) + SUBROUTINE print_image_coefficients(image_coeff,qs_env) REAL(KIND=dp), DIMENSION(:), POINTER :: image_coeff TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_image_coefficients', & routineP = moduleN//':'//routineN @@ -1200,7 +1142,7 @@ SUBROUTINE print_image_coefficients(image_coeff,qs_env,error) TYPE(section_vals_type), POINTER :: input NULLIFY(input, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() sum_coeff=0.0_dp natom=SIZE(qs_env%qmmm_env_qm%image_charge_pot%image_mm_list) @@ -1210,10 +1152,10 @@ SUBROUTINE print_image_coefficients(image_coeff,qs_env,error) sum_coeff=sum_coeff+image_coeff(iatom) ENDDO - CALL get_qs_env(qs_env=qs_env,input=input,error=error) + CALL get_qs_env(qs_env=qs_env,input=input) output_unit = cp_print_key_unit_nr(logger,input,& - "QMMM%PRINT%IMAGE_CHARGE_INFO",extension=".Log",error=error) + "QMMM%PRINT%IMAGE_CHARGE_INFO",extension=".Log") IF(output_unit>0) THEN WRITE (unit=output_unit,fmt="(/)") WRITE (unit=output_unit,fmt="(T2,A)")& @@ -1236,7 +1178,7 @@ SUBROUTINE print_image_coefficients(image_coeff,qs_env,error) ENDIF CALL cp_print_key_finished_output(output_unit,logger,input,& - "QMMM%PRINT%IMAGE_CHARGE_INFO",error=error) + "QMMM%PRINT%IMAGE_CHARGE_INFO") END SUBROUTINE print_image_coefficients @@ -1248,16 +1190,13 @@ END SUBROUTINE print_image_coefficients !> to an external potential, i.e. V0*total_rho_metal !> \param total_rho_metal total induced image charge density !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE print_image_energy_terms(en_vmetal_rhohartree,en_external,& - total_rho_metal,qs_env,error) + total_rho_metal,qs_env) REAL(KIND=dp), INTENT(IN) :: en_vmetal_rhohartree, & en_external, total_rho_metal TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_image_energy_terms', & routineP = moduleN//':'//routineN @@ -1267,12 +1206,12 @@ SUBROUTINE print_image_energy_terms(en_vmetal_rhohartree,en_external,& TYPE(section_vals_type), POINTER :: input NULLIFY(input, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL get_qs_env(qs_env=qs_env,input=input,error=error) + CALL get_qs_env(qs_env=qs_env,input=input) output_unit = cp_print_key_unit_nr(logger,input,& - "QMMM%PRINT%IMAGE_CHARGE_INFO",extension=".Log",error=error) + "QMMM%PRINT%IMAGE_CHARGE_INFO",extension=".Log") IF(output_unit>0) THEN WRITE (unit=output_unit,fmt="(T3,A,T56,F25.14)")& @@ -1287,7 +1226,7 @@ SUBROUTINE print_image_energy_terms(en_vmetal_rhohartree,en_external,& ENDIF CALL cp_print_key_finished_output(output_unit,logger,input,& - "QMMM%PRINT%IMAGE_CHARGE_INFO",error=error) + "QMMM%PRINT%IMAGE_CHARGE_INFO") END SUBROUTINE print_image_energy_terms diff --git a/src/qmmm_init.F b/src/qmmm_init.F index f8cb57d434..2689d27014 100644 --- a/src/qmmm_init.F +++ b/src/qmmm_init.F @@ -94,15 +94,13 @@ MODULE qmmm_init !> \param mm_atom_index ... !> \param mm_link_atoms ... !> \param mm_link_scale_factor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE assign_mm_charges_and_radius(subsys, charges, mm_atom_chrg,mm_el_pot_radius,& mm_el_pot_radius_corr, mm_atom_index, mm_link_atoms,& - mm_link_scale_factor, error) + mm_link_scale_factor) TYPE(cp_subsys_type), POINTER :: subsys REAL(KIND=dp), DIMENSION(:), POINTER :: charges REAL(dp), DIMENSION(:), POINTER :: mm_atom_chrg, & @@ -110,7 +108,6 @@ SUBROUTINE assign_mm_charges_and_radius(subsys, charges, mm_atom_chrg,mm_el_pot_ mm_el_pot_radius_corr INTEGER, DIMENSION(:), POINTER :: mm_atom_index, mm_link_atoms REAL(dp), DIMENSION(:), POINTER :: mm_link_scale_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'assign_mm_charges_and_radius', & routineP = moduleN//':'//routineN @@ -124,7 +121,7 @@ SUBROUTINE assign_mm_charges_and_radius(subsys, charges, mm_atom_chrg,mm_el_pot_ POINTER :: particle_set NULLIFY(particle_set, my_kind) - CALL cp_subsys_get(subsys=subsys,particles=particles,error=error) + CALL cp_subsys_get(subsys=subsys,particles=particles) particle_set => particles%els DO I = 1, SIZE(mm_atom_index) @@ -162,14 +159,12 @@ END SUBROUTINE assign_mm_charges_and_radius !> \param added_charges ... !> \param qmmm_section ... !> \param nocompatibility ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE print_qmmm_charges(mm_atom_index, mm_atom_chrg, mm_el_pot_radius, mm_el_pot_radius_corr,& - added_charges, qmmm_section, nocompatibility, error) + added_charges, qmmm_section, nocompatibility) INTEGER, DIMENSION(:), POINTER :: mm_atom_index REAL(dp), DIMENSION(:), POINTER :: mm_atom_chrg, & mm_el_pot_radius, & @@ -177,7 +172,6 @@ SUBROUTINE print_qmmm_charges(mm_atom_index, mm_atom_chrg, mm_el_pot_radius, mm_ TYPE(add_set_type), POINTER :: added_charges TYPE(section_vals_type), POINTER :: qmmm_section LOGICAL, INTENT(IN) :: nocompatibility - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_qmmm_charges', & routineP = moduleN//':'//routineN @@ -187,9 +181,9 @@ SUBROUTINE print_qmmm_charges(mm_atom_index, mm_atom_chrg, mm_el_pot_radius, mm_ TYPE(cp_logger_type), POINTER :: logger qtot = 0.0_dp - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw=cp_print_key_unit_nr(logger,qmmm_section,"PRINT%QMMM_CHARGES",& - extension=".log",error=error) + extension=".log") IF (iw>0) THEN WRITE(iw,FMT="(/,T2,A)") REPEAT("-",79) WRITE(iw,FMT='(/5X,A)')"MM POINT CHARGES GENERATING THE QM/MM ELECTROSTATIC POTENTIAL" @@ -234,23 +228,20 @@ SUBROUTINE print_qmmm_charges(mm_atom_index, mm_atom_chrg, mm_el_pot_radius, mm_ WRITE(iw,FMT="(/,T2,A,/)") REPEAT("-",79) END IF CALL cp_print_key_finished_output(iw,logger,qmmm_section,& - "PRINT%QMMM_CHARGES", error=error) + "PRINT%QMMM_CHARGES") END SUBROUTINE print_qmmm_charges ! ***************************************************************************** !> \brief Print info on qm/mm links !> \param qmmm_section ... !> \param qmmm_links ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE print_qmmm_links( qmmm_section, qmmm_links, error) + SUBROUTINE print_qmmm_links( qmmm_section, qmmm_links) TYPE(section_vals_type), POINTER :: qmmm_section TYPE(qmmm_links_type), POINTER :: qmmm_links - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_qmmm_links', & routineP = moduleN//':'//routineN @@ -259,8 +250,8 @@ SUBROUTINE print_qmmm_links( qmmm_section, qmmm_links, error) REAL(KIND=dp) :: alpha TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) - iw=cp_print_key_unit_nr(logger,qmmm_section,"PRINT%qmmm_link_info", extension=".log",error=error) + logger => cp_get_default_logger() + iw=cp_print_key_unit_nr(logger,qmmm_section,"PRINT%qmmm_link_info", extension=".log") IF (iw>0) THEN IF (ASSOCIATED(qmmm_links)) THEN WRITE(iw,FMT="(/,T2, A)") REPEAT("-",73) @@ -293,7 +284,7 @@ SUBROUTINE print_qmmm_links( qmmm_section, qmmm_links, error) END IF END IF CALL cp_print_key_finished_output(iw,logger,qmmm_section,& - "PRINT%qmmm_link_info", error=error) + "PRINT%qmmm_link_info") END SUBROUTINE print_qmmm_links ! ***************************************************************************** @@ -305,22 +296,19 @@ END SUBROUTINE print_qmmm_links !> \param added_charges ... !> \param print_section ... !> \param qmmm_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 1.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_init_gaussian_type(qmmm_env_qm, para_env, & mm_atom_chrg, qs_env, added_charges, print_section, & - qmmm_section, error ) + qmmm_section) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env_qm TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:), POINTER :: mm_atom_chrg TYPE(qs_environment_type), POINTER :: qs_env TYPE(add_set_type), POINTER :: added_charges TYPE(section_vals_type), POINTER :: print_section, qmmm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_init_gaussian_type', & routineP = moduleN//':'//routineN @@ -336,7 +324,7 @@ SUBROUTINE qmmm_init_gaussian_type(qmmm_env_qm, para_env, & NULLIFY(maxradius, maxradius2, pw_env) maxchrg = MAXVAL(ABS(mm_atom_chrg(:))) - CALL get_qs_env(qs_env, pw_env=pw_env, error=error) + CALL get_qs_env(qs_env, pw_env=pw_env) IF (qmmm_env_qm%add_mm_charges) maxchrg=MAX(maxchrg,MAXVAL(ABS(added_charges%mm_atom_chrg(:)))) CALL qmmm_gaussian_initialize(qmmm_gaussian_fns=qmmm_env_qm%pgfs,& para_env=para_env,& @@ -349,8 +337,7 @@ SUBROUTINE qmmm_init_gaussian_type(qmmm_env_qm, para_env, & maxchrg=maxchrg,& compatibility=qmmm_env_qm%compatibility,& print_section=print_section,& - qmmm_section=qmmm_section,& - error=error) + qmmm_section=qmmm_section) IF (qmmm_env_qm%move_mm_charges.OR.qmmm_env_qm%add_mm_charges) THEN CALL qmmm_gaussian_initialize(qmmm_gaussian_fns=added_charges%pgfs,& @@ -364,8 +351,7 @@ SUBROUTINE qmmm_init_gaussian_type(qmmm_env_qm, para_env, & maxchrg=maxchrg,& compatibility=qmmm_env_qm%compatibility,& print_section=print_section,& - qmmm_section=qmmm_section,& - error=error) + qmmm_section=qmmm_section) SELECT CASE(qmmm_env_qm%qmmm_coupl_type) CASE(do_qmmm_gauss,do_qmmm_swave,do_qmmm_pcharge) @@ -375,7 +361,7 @@ SUBROUTINE qmmm_init_gaussian_type(qmmm_env_qm, para_env, & END SELECT IF (ASSOCIATED(maxradius2)) DEALLOCATE(maxradius2, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF qmmm_env_qm%maxradius => maxradius @@ -388,19 +374,16 @@ END SUBROUTINE qmmm_init_gaussian_type !> \param mm_cell ... !> \param added_charges ... !> \param print_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 1.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_init_potential(qmmm_env_qm, mm_cell, & - added_charges, print_section, error) + added_charges, print_section) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env_qm TYPE(cell_type), POINTER :: mm_cell TYPE(add_set_type), POINTER :: added_charges TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qmmm_init_potential', & routineP = moduleN//':'//routineN @@ -411,8 +394,7 @@ SUBROUTINE qmmm_init_potential(qmmm_env_qm, mm_cell, & pgfs=qmmm_env_qm%pgfs,& mm_cell=mm_cell,& compatibility=qmmm_env_qm%compatibility,& - print_section=print_section,& - error=error) + print_section=print_section) IF (qmmm_env_qm%move_mm_charges.OR.qmmm_env_qm%add_mm_charges) THEN @@ -422,8 +404,7 @@ SUBROUTINE qmmm_init_potential(qmmm_env_qm, mm_cell, & pgfs=added_charges%pgfs,& mm_cell=mm_cell,& compatibility=qmmm_env_qm%compatibility,& - print_section=print_section,& - error=error) + print_section=print_section) END IF END SUBROUTINE qmmm_init_potential @@ -439,14 +420,12 @@ END SUBROUTINE qmmm_init_potential !> \param qmmm_periodic ... !> \param print_section ... !> \param mm_atom_chrg ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 7.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_init_periodic_potential(qmmm_env_qm, qm_cell_small, mm_cell, para_env, qs_env,& - added_charges, qmmm_periodic, print_section, mm_atom_chrg, error) + added_charges, qmmm_periodic, print_section, mm_atom_chrg) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env_qm TYPE(cell_type), POINTER :: qm_cell_small, mm_cell TYPE(cp_para_env_type), POINTER :: para_env @@ -454,7 +433,6 @@ SUBROUTINE qmmm_init_periodic_potential(qmmm_env_qm, qm_cell_small, mm_cell, par TYPE(add_set_type), POINTER :: added_charges TYPE(section_vals_type), POINTER :: qmmm_periodic, print_section REAL(KIND=dp), DIMENSION(:), POINTER :: mm_atom_chrg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qmmm_init_periodic_potential', & routineP = moduleN//':'//routineN @@ -465,21 +443,20 @@ SUBROUTINE qmmm_init_periodic_potential(qmmm_env_qm, qm_cell_small, mm_cell, par IF (qmmm_env_qm%periodic) THEN NULLIFY(dft_control) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) IF(dft_control%qs_control%semi_empirical) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="QM/MM periodic calculations not implemented for semi empirical methods", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) ELSE IF(dft_control%qs_control%dftb) THEN CALL qmmm_ewald_potential_init(qmmm_env_qm%ewald_env, qmmm_env_qm%ewald_pw,& qmmm_coupl_type=qmmm_env_qm%qmmm_coupl_type, mm_cell=mm_cell,& - para_env=para_env, qmmm_periodic=qmmm_periodic, print_section=print_section,& - error=error) + para_env=para_env, qmmm_periodic=qmmm_periodic, print_section=print_section) ELSE IF(dft_control%qs_control%scptb) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="QM/MM periodic calculations not implemented for SCPTB method", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) ELSE ! setup for GPW/GPAW @@ -499,8 +476,7 @@ SUBROUTINE qmmm_init_periodic_potential(qmmm_env_qm, qm_cell_small, mm_cell, par eps_mm_rspace=qmmm_env_qm%eps_mm_rspace,& maxchrg=maxchrg,& ncp =qmmm_env_qm%aug_pools(SIZE(qmmm_env_qm%aug_pools))%pool%pw_grid%npts,& - ncpl=qmmm_env_qm%aug_pools(SIZE(qmmm_env_qm%aug_pools))%pool%pw_grid%npts_local,& - error=error) + ncpl=qmmm_env_qm%aug_pools(SIZE(qmmm_env_qm%aug_pools))%pool%pw_grid%npts_local) IF (qmmm_env_qm%move_mm_charges.OR.qmmm_env_qm%add_mm_charges) THEN @@ -517,8 +493,7 @@ SUBROUTINE qmmm_init_periodic_potential(qmmm_env_qm, qm_cell_small, mm_cell, par eps_mm_rspace=qmmm_env_qm%eps_mm_rspace,& maxchrg=maxchrg,& ncp =qmmm_env_qm%aug_pools(SIZE(qmmm_env_qm%aug_pools))%pool%pw_grid%npts,& - ncpl=qmmm_env_qm%aug_pools(SIZE(qmmm_env_qm%aug_pools))%pool%pw_grid%npts_local,& - error=error) + ncpl=qmmm_env_qm%aug_pools(SIZE(qmmm_env_qm%aug_pools))%pool%pw_grid%npts_local) END IF END IF @@ -540,15 +515,13 @@ END SUBROUTINE qmmm_init_periodic_potential !> \param eps_mm_rspace ... !> \param qmmm_link ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& qm_atom_index, mm_atom_index, qm_cell_small, qmmm_coupl_type, eps_mm_rspace,& - qmmm_link, para_env, error) + qmmm_link, para_env) TYPE(section_vals_type), POINTER :: qmmm_section TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(cp_subsys_type), POINTER :: subsys_mm @@ -560,7 +533,6 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& REAL(KIND=dp), INTENT(OUT) :: eps_mm_rspace LOGICAL, INTENT(OUT) :: qmmm_link TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_qmmm_vars_qm', & routineP = moduleN//':'//routineN @@ -585,18 +557,18 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& qmmm_link = .FALSE. failure = .FALSE. - CALL section_vals_get(qmmm_section,explicit=explicit,error=error) + CALL section_vals_get(qmmm_section,explicit=explicit) IF (explicit) THEN ! ! QM_CELL ! - cell_section => section_vals_get_subs_vals(qmmm_section,"CELL",error=error) + cell_section => section_vals_get_subs_vals(qmmm_section,"CELL") CALL read_cell( qm_cell_small, qm_cell_small, cell_section=cell_section,& - check_for_ref=.FALSE., para_env=para_env, error=error) - CALL section_vals_val_get(qmmm_section,"E_COUPL",i_val=qmmm_coupl_type,error=error) - CALL section_vals_val_get(qmmm_section,"EPS_MM_RSPACE",r_val=eps_mm_rspace,error=error) - CALL section_vals_val_get(qmmm_section,"SPHERICAL_CUTOFF",r_vals=tmp_sph_cut,error=error) - CPPostcondition(SIZE(tmp_sph_cut)==2,cp_failure_level,routineP,error,failure) + check_for_ref=.FALSE., para_env=para_env) + CALL section_vals_val_get(qmmm_section,"E_COUPL",i_val=qmmm_coupl_type) + CALL section_vals_val_get(qmmm_section,"EPS_MM_RSPACE",r_val=eps_mm_rspace) + CALL section_vals_val_get(qmmm_section,"SPHERICAL_CUTOFF",r_vals=tmp_sph_cut) + CPPostcondition(SIZE(tmp_sph_cut)==2,cp_failure_level,routineP,failure) qmmm_env%spherical_cutoff = tmp_sph_cut IF (qmmm_env%spherical_cutoff(1)<=0.0_dp) THEN qmmm_env%spherical_cutoff(2) = 0.0_dp @@ -606,14 +578,13 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& CALL cp_assert(tmp_radius>0.0_dp,cp_failure_level,cp_assertion_failed,routineP,& "SPHERICAL_CUTOFF(1) > 20*SPHERICAL_CUTOFF(1)! Please correct parameters for "//& "the Spherical Cutoff in order to satisfy the previous condition!"//& - CPSourceFileRef,error,failure) + CPSourceFileRef,failure) END IF ! ! Initialization of arrays and core_charge_radius... ! tmp_radius=0.0_dp - CALL cp_subsys_get(subsys=subsys_mm,atomic_kinds=atomic_kinds,& - error=error) + CALL cp_subsys_get(subsys=subsys_mm,atomic_kinds=atomic_kinds) DO Ikind = 1, SIZE(atomic_kinds%els) atomic_kind => atomic_kinds%els(Ikind) CALL get_atomic_kind(atomic_kind=atomic_kind,& @@ -628,17 +599,16 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& qm_atom_index=qm_atom_index,& qm_atom_type=qm_atom_type,& mm_link_atoms=mm_link_atoms,& - qmmm_link=qmmm_link,& - error=error) + qmmm_link=qmmm_link) ! ! MM_KINDS ! - mm_kinds => section_vals_get_subs_vals(qmmm_section,"MM_KIND",error=error) - CALL section_vals_get(mm_kinds,explicit=explicit,n_repetition=nkind,error=error) + mm_kinds => section_vals_get_subs_vals(qmmm_section,"MM_KIND") + CALL section_vals_get(mm_kinds,explicit=explicit,n_repetition=nkind) ! ! Default ! - tmp_radius = cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom",error=error) + tmp_radius = cp_unit_to_cp2k(RADIUS_QMMM_DEFAULT,"angstrom") Set_Radius_Pot_0: DO IkindR = 1, SIZE(atomic_kinds%els) atomic_kind => atomic_kinds%els(IkindR) CALL get_atomic_kind(atomic_kind=atomic_kind,name=atmname) @@ -655,13 +625,12 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& IF (explicit) THEN DO ikind=1,nkind CALL section_vals_val_get(mm_kinds,"_SECTION_PARAMETERS_",i_rep_section=ikind,& - c_val=mm_atom_kind,error=error) - CALL section_vals_val_get(mm_kinds,"RADIUS",i_rep_section=ikind,r_val=tmp_radius,error=error) + c_val=mm_atom_kind) + CALL section_vals_val_get(mm_kinds,"RADIUS",i_rep_section=ikind,r_val=tmp_radius) tmp_radius_c = tmp_radius - CALL section_vals_val_get(mm_kinds,"CORR_RADIUS",i_rep_section=ikind,n_rep_val=n_rep_val,& - error=error) + CALL section_vals_val_get(mm_kinds,"CORR_RADIUS",i_rep_section=ikind,n_rep_val=n_rep_val) IF (n_rep_val == 1) CALL section_vals_val_get(mm_kinds,"CORR_RADIUS",i_rep_section=ikind,& - r_val=tmp_radius_c,error=error) + r_val=tmp_radius_c) Set_Radius_Pot_1: DO IkindR = 1, SIZE(atomic_kinds%els) atomic_kind => atomic_kinds%els(IkindR) CALL get_atomic_kind(atomic_kind=atomic_kind,name=atmname) @@ -681,13 +650,13 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& !Image charge section - image_charge_section => section_vals_get_subs_vals(qmmm_section,"IMAGE_CHARGE",error=error) - CALL section_vals_get(image_charge_section,explicit=qmmm_env%image_charge,error=error) + image_charge_section => section_vals_get_subs_vals(qmmm_section,"IMAGE_CHARGE") + CALL section_vals_get(image_charge_section,explicit=qmmm_env%image_charge) ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "QMMM section not present in input file!"//& - CPSourceFileRef,error,failure) + CPSourceFileRef,failure) ENDIF ! ! Build MM atoms list @@ -710,34 +679,34 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& IF (icount <= size_mm_system) mm_atom_index(icount) = i END IF END DO - CPPostcondition(icount==size_mm_system,cp_failure_level,routineP,error,failure) + CPPostcondition(icount==size_mm_system,cp_failure_level,routineP,failure) IF (ASSOCIATED(mm_link_atoms)) THEN DEALLOCATE(mm_link_atoms, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Build image charge atom list + set up variables ! IF (qmmm_env%image_charge) THEN CALL section_vals_val_get(image_charge_section,"MM_ATOM_LIST",& - explicit=explicit,error=error) + explicit=explicit) IF(explicit) qmmm_env%image_charge_pot%all_mm=.FALSE. IF(qmmm_env%image_charge_pot%all_mm) THEN qmmm_env%image_charge_pot%image_mm_list => mm_atom_index ELSE CALL setup_image_atom_list(image_charge_section,qmmm_env,& - qm_atom_index,subsys_mm,error) + qm_atom_index,subsys_mm) END IF qmmm_env%image_charge_pot%particles_all => subsys_mm%particles%els CALL section_vals_val_get(image_charge_section,"EXT_POTENTIAL",& - r_val=qmmm_env%image_charge_pot%V0,error=error) + r_val=qmmm_env%image_charge_pot%V0) CALL section_vals_val_get(image_charge_section,"WIDTH",& - r_val=qmmm_env%image_charge_pot%eta,error=error) + r_val=qmmm_env%image_charge_pot%eta) CALL section_vals_val_get(image_charge_section,"DETERM_COEFF",& - i_val=my_type,error=error) + i_val=my_type) SELECT CASE(my_type) CASE(do_qmmm_image_calcmatrix) qmmm_env%image_charge_pot%coeff_iterative=.FALSE. @@ -746,8 +715,7 @@ SUBROUTINE setup_qmmm_vars_qm( qmmm_section, qmmm_env, subsys_mm, qm_atom_type,& END SELECT CALL section_vals_val_get(image_charge_section,"RESTART_IMAGE_MATRIX",& - l_val=qmmm_env%image_charge_pot%image_restart,& - error=error) + l_val=qmmm_env%image_charge_pot%image_restart) END IF END SUBROUTINE setup_qmmm_vars_qm @@ -762,8 +730,6 @@ END SUBROUTINE setup_qmmm_vars_qm !> \param fist_scale_charge_link ... !> \param qmmm_coupl_type ... !> \param qmmm_link ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino @@ -771,7 +737,7 @@ END SUBROUTINE setup_qmmm_vars_qm SUBROUTINE setup_qmmm_vars_mm( qmmm_section, qmmm_env, qm_atom_index, & mm_link_atoms, mm_link_scale_factor, & fist_scale_charge_link, qmmm_coupl_type,& - qmmm_link, error) + qmmm_link) TYPE(section_vals_type), POINTER :: qmmm_section TYPE(qmmm_env_mm_type), POINTER :: qmmm_env INTEGER, DIMENSION(:), POINTER :: qm_atom_index, mm_link_atoms @@ -779,7 +745,6 @@ SUBROUTINE setup_qmmm_vars_mm( qmmm_section, qmmm_env, qm_atom_index, & fist_scale_charge_link INTEGER, INTENT(OUT) :: qmmm_coupl_type LOGICAL, INTENT(OUT) :: qmmm_link - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_qmmm_vars_mm', & routineP = moduleN//':'//routineN @@ -789,21 +754,21 @@ SUBROUTINE setup_qmmm_vars_mm( qmmm_section, qmmm_env, qm_atom_index, & NULLIFY(qmmm_ff_section) qmmm_link = .FALSE. - CALL section_vals_get(qmmm_section,explicit=explicit,error=error) + CALL section_vals_get(qmmm_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(qmmm_section,"E_COUPL",i_val=qmmm_coupl_type,error=error) + CALL section_vals_val_get(qmmm_section,"E_COUPL",i_val=qmmm_coupl_type) CALL setup_qm_atom_list(qmmm_section,qm_atom_index=qm_atom_index,qmmm_link=qmmm_link,& mm_link_atoms=mm_link_atoms, mm_link_scale_factor = mm_link_scale_factor,& - fist_scale_charge_link=fist_scale_charge_link, error=error) + fist_scale_charge_link=fist_scale_charge_link) ! ! Do we want to use a different FF for the non-bonded QM/MM interactions? ! - qmmm_ff_section => section_vals_get_subs_vals(qmmm_section,"FORCEFIELD",error=error) - CALL section_vals_get(qmmm_ff_section,explicit=qmmm_env%use_qmmm_ff,error=error) + qmmm_ff_section => section_vals_get_subs_vals(qmmm_section,"FORCEFIELD") + CALL section_vals_get(qmmm_ff_section,explicit=qmmm_env%use_qmmm_ff) IF (qmmm_env%use_qmmm_ff) THEN CALL section_vals_val_get(qmmm_ff_section,"MULTIPLE_POTENTIAL",& - l_val=qmmm_env%multiple_potential,error=error) - CALL read_qmmm_ff_section(qmmm_ff_section, qmmm_env%inp_info, error=error) + l_val=qmmm_env%multiple_potential) + CALL read_qmmm_ff_section(qmmm_ff_section, qmmm_env%inp_info) END IF END IF END SUBROUTINE setup_qmmm_vars_mm @@ -813,16 +778,13 @@ END SUBROUTINE setup_qmmm_vars_mm !> interactions !> \param qmmm_ff_section ... !> \param inp_info ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE read_qmmm_ff_section(qmmm_ff_section, inp_info, error) + SUBROUTINE read_qmmm_ff_section(qmmm_ff_section, inp_info) TYPE(section_vals_type), POINTER :: qmmm_ff_section TYPE(input_info_type), POINTER :: inp_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_qmmm_ff_section', & routineP = moduleN//':'//routineN @@ -836,64 +798,64 @@ SUBROUTINE read_qmmm_ff_section(qmmm_ff_section, inp_info, error) ! ! NONBONDED ! - lj_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%LENNARD-JONES",error=error) - wl_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%WILLIAMS",error=error) - gd_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%GOODWIN",error=error) - gp_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%GENPOT",error=error) - CALL section_vals_get(lj_section,n_repetition=n_lj,error=error) + lj_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%LENNARD-JONES") + wl_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%WILLIAMS") + gd_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%GOODWIN") + gp_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED%GENPOT") + CALL section_vals_get(lj_section,n_repetition=n_lj) np = n_lj IF (n_lj /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,np,lj_charmm=.TRUE.,error=error) - CALL read_lj_section(inp_info%nonbonded,lj_section, start=0, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,np,lj_charmm=.TRUE.) + CALL read_lj_section(inp_info%nonbonded,lj_section, start=0) END IF - CALL section_vals_get(wl_section,n_repetition=n_wl,error=error) + CALL section_vals_get(wl_section,n_repetition=n_wl) np = n_lj + n_wl IF (n_wl /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,np,williams=.TRUE.,error=error) - CALL read_wl_section(inp_info%nonbonded,wl_section, start=n_lj, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,np,williams=.TRUE.) + CALL read_wl_section(inp_info%nonbonded,wl_section, start=n_lj) END IF - CALL section_vals_get(gd_section,n_repetition=n_gd,error=error) + CALL section_vals_get(gd_section,n_repetition=n_gd) np = n_lj + n_wl + n_gd IF (n_gd /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,np,goodwin=.TRUE.,error=error) - CALL read_gd_section(inp_info%nonbonded,gd_section, start=n_lj+n_wl, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,np,goodwin=.TRUE.) + CALL read_gd_section(inp_info%nonbonded,gd_section, start=n_lj+n_wl) END IF - CALL section_vals_get(gp_section,n_repetition=n_gp,error=error) + CALL section_vals_get(gp_section,n_repetition=n_gp) np = n_lj + n_wl + n_gd + n_gp IF (n_gp /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded,1,np,gp=.TRUE.,error=error) - CALL read_gp_section(inp_info%nonbonded,gp_section, start=n_lj+n_wl+n_gd, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded,1,np,gp=.TRUE.) + CALL read_gp_section(inp_info%nonbonded,gp_section, start=n_lj+n_wl+n_gd) END IF ! ! NONBONDED14 ! - lj_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%LENNARD-JONES",error=error) - wl_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%WILLIAMS",error=error) - gd_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%GOODWIN",error=error) - gp_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%GENPOT",error=error) - CALL section_vals_get(lj_section,n_repetition=n_lj,error=error) + lj_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%LENNARD-JONES") + wl_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%WILLIAMS") + gd_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%GOODWIN") + gp_section => section_vals_get_subs_vals(qmmm_ff_section,"NONBONDED14%GENPOT") + CALL section_vals_get(lj_section,n_repetition=n_lj) np = n_lj IF (n_lj /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,lj_charmm=.TRUE.,error=error) - CALL read_lj_section(inp_info%nonbonded14,lj_section, start=0, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,lj_charmm=.TRUE.) + CALL read_lj_section(inp_info%nonbonded14,lj_section, start=0) END IF - CALL section_vals_get(wl_section,n_repetition=n_wl,error=error) + CALL section_vals_get(wl_section,n_repetition=n_wl) np = n_lj + n_wl IF (n_wl /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,williams=.TRUE.,error=error) - CALL read_wl_section(inp_info%nonbonded14,wl_section, start=n_lj, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,williams=.TRUE.) + CALL read_wl_section(inp_info%nonbonded14,wl_section, start=n_lj) END IF - CALL section_vals_get(gd_section,n_repetition=n_gd,error=error) + CALL section_vals_get(gd_section,n_repetition=n_gd) np = n_lj + n_wl + n_gd IF (n_gd /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,goodwin=.TRUE.,error=error) - CALL read_gd_section(inp_info%nonbonded14,gd_section, start=n_lj+n_wl, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,goodwin=.TRUE.) + CALL read_gd_section(inp_info%nonbonded14,gd_section, start=n_lj+n_wl) END IF - CALL section_vals_get(gp_section,n_repetition=n_gp,error=error) + CALL section_vals_get(gp_section,n_repetition=n_gp) np = n_lj + n_wl + n_gd + n_gp IF (n_gp /= 0) THEN - CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,gp=.TRUE.,error=error) - CALL read_gp_section(inp_info%nonbonded14,gp_section, start=n_lj+n_wl+n_gd, error=error) + CALL pair_potential_reallocate(inp_info%nonbonded14,1,np,gp=.TRUE.) + CALL read_gp_section(inp_info%nonbonded14,gp_section, start=n_lj+n_wl+n_gd) END IF END SUBROUTINE read_qmmm_ff_section @@ -907,14 +869,12 @@ END SUBROUTINE read_qmmm_ff_section !> \param mm_link_scale_factor ... !> \param qmmm_link ... !> \param fist_scale_charge_link ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE setup_qm_atom_list(qmmm_section,qm_atom_index,qm_atom_type,& - mm_link_atoms, mm_link_scale_factor, qmmm_link, fist_scale_charge_link, error) + mm_link_atoms, mm_link_scale_factor, qmmm_link, fist_scale_charge_link) TYPE(section_vals_type), POINTER :: qmmm_section INTEGER, DIMENSION(:), OPTIONAL, POINTER :: qm_atom_index CHARACTER(len=default_string_length), & @@ -925,7 +885,6 @@ SUBROUTINE setup_qm_atom_list(qmmm_section,qm_atom_index,qm_atom_type,& LOGICAL, INTENT(OUT), OPTIONAL :: qmmm_link REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: fist_scale_charge_link - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_qm_atom_list', & routineP = moduleN//':'//routineN @@ -948,29 +907,28 @@ SUBROUTINE setup_qm_atom_list(qmmm_section,qm_atom_index,qm_atom_type,& ! ! QM_KINDS ! - qm_kinds => section_vals_get_subs_vals(qmmm_section,"QM_KIND",error=error) - CALL section_vals_get(qm_kinds,n_repetition=nkind,error=error) + qm_kinds => section_vals_get_subs_vals(qmmm_section,"QM_KIND") + CALL section_vals_get(qm_kinds,n_repetition=nkind) DO ikind=1,nkind - CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,n_rep_val=n_var,& - error=error) + CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,n_rep_val=n_var) DO k = 1, n_var CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,i_rep_val=k,& - i_vals=mm_indexes,error=error) + i_vals=mm_indexes) num_qm_atom_tot = num_qm_atom_tot + SIZE(mm_indexes) END DO END DO ! ! QM/MM LINKS ! - qmmm_links => section_vals_get_subs_vals(qmmm_section,"LINK",error=error) - CALL section_vals_get(qmmm_links,explicit=explicit,error=error) + qmmm_links => section_vals_get_subs_vals(qmmm_section,"LINK") + CALL section_vals_get(qmmm_links,explicit=explicit) IF (explicit) THEN qmmm_link = .TRUE. - CALL section_vals_get(qmmm_links,n_repetition=nlinks,error=error) + CALL section_vals_get(qmmm_links,n_repetition=nlinks) ! Take care of the various link types DO ikind = 1, nlinks CALL section_vals_val_get(qmmm_links,"LINK_TYPE",i_rep_section=ikind,& - i_val=link_type,error=error) + i_val=link_type) SELECT CASE(link_type) CASE(do_qmmm_link_imomm) num_qm_atom_tot = num_qm_atom_tot + 1 @@ -980,38 +938,37 @@ SUBROUTINE setup_qm_atom_list(qmmm_section,qm_atom_index,qm_atom_type,& CASE(do_qmmm_link_gho) ! do nothing for the moment CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO END IF IF (PRESENT(mm_link_scale_factor).AND.(link_involv_mm /= 0)) & ALLOCATE(mm_link_scale_factor(link_involv_mm), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(fist_scale_charge_link).AND.(link_involv_mm /= 0)) & ALLOCATE(fist_scale_charge_link(link_involv_mm), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(mm_link_atoms).AND.(link_involv_mm /= 0)) & ALLOCATE(mm_link_atoms(link_involv_mm),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(qm_atom_index)) ALLOCATE(qm_atom_index(num_qm_atom_tot),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(qm_atom_type)) ALLOCATE(qm_atom_type(num_qm_atom_tot),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(qm_atom_index)) qm_atom_index = 0 IF (PRESENT(qm_atom_type)) qm_atom_type = " " num_qm_atom_tot = 1 DO ikind=1,nkind - CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,n_rep_val=n_var,& - error=error) + CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,n_rep_val=n_var) DO k = 1, n_var CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,i_rep_val=k,& - i_vals=mm_indexes,error=error) + i_vals=mm_indexes) IF (PRESENT(qm_atom_index)) THEN qm_atom_index(num_qm_atom_tot:num_qm_atom_tot + SIZE(mm_indexes)-1) = mm_indexes(:) END IF IF (PRESENT(qm_atom_type)) THEN CALL section_vals_val_get(qm_kinds,"_SECTION_PARAMETERS_",i_rep_section=ikind,& - c_val=qm_atom_kind,error=error) + c_val=qm_atom_kind) qm_atom_type (num_qm_atom_tot:num_qm_atom_tot + SIZE(mm_indexes)-1) = qm_atom_kind END IF num_qm_atom_tot = num_qm_atom_tot + SIZE(mm_indexes) @@ -1023,35 +980,30 @@ SUBROUTINE setup_qm_atom_list(qmmm_section,qm_atom_index,qm_atom_type,& IF (explicit) THEN DO ikind = 1, nlinks IF (PRESENT(qm_atom_type)) THEN - CALL section_vals_val_get(qmmm_links,"QM_KIND",i_rep_section=ikind,c_val=qm_link_element,& - error=error) + CALL section_vals_val_get(qmmm_links,"QM_KIND",i_rep_section=ikind,c_val=qm_link_element) qm_atom_type (num_qm_atom_tot:num_qm_atom_tot) = TRIM(qm_link_element)//"_LINK" END IF IF (PRESENT(qm_atom_index)) THEN - CALL section_vals_val_get(qmmm_links,"MM_INDEX",i_rep_section=ikind,i_val=mm_index,& - error=error) - CPPostcondition(ALL(qm_atom_index/=mm_index),cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(qmmm_links,"MM_INDEX",i_rep_section=ikind,i_val=mm_index) + CPPostcondition(ALL(qm_atom_index/=mm_index),cp_failure_level,routineP,failure) qm_atom_index(num_qm_atom_tot:num_qm_atom_tot ) = mm_index num_qm_atom_tot = num_qm_atom_tot + 1 END IF IF (PRESENT(mm_link_atoms).AND.(link_involv_mm /= 0)) THEN - CALL section_vals_val_get(qmmm_links,"MM_INDEX",i_rep_section=ikind,i_val=mm_index,& - error=error) + CALL section_vals_val_get(qmmm_links,"MM_INDEX",i_rep_section=ikind,i_val=mm_index) mm_link_atoms (ikind) = mm_index END IF IF (PRESENT(mm_link_scale_factor).AND.(link_involv_mm /= 0)) THEN - CALL section_vals_val_get(qmmm_links,"QMMM_SCALE_FACTOR",i_rep_section=ikind,r_val=scale_f,& - error=error) + CALL section_vals_val_get(qmmm_links,"QMMM_SCALE_FACTOR",i_rep_section=ikind,r_val=scale_f) mm_link_scale_factor(ikind) = scale_f END IF IF (PRESENT(fist_scale_charge_link).AND.(link_involv_mm /= 0)) THEN - CALL section_vals_val_get(qmmm_links,"FIST_SCALE_FACTOR",i_rep_section=ikind,r_val=scale_f,& - error=error) + CALL section_vals_val_get(qmmm_links,"FIST_SCALE_FACTOR",i_rep_section=ikind,r_val=scale_f) fist_scale_charge_link(ikind) = scale_f END IF END DO END IF - CPPostcondition(num_qm_atom_tot-1==SIZE(qm_atom_index),cp_failure_level,routineP,error,failure) + CPPostcondition(num_qm_atom_tot-1==SIZE(qm_atom_index),cp_failure_level,routineP,failure) END SUBROUTINE setup_qm_atom_list @@ -1063,21 +1015,18 @@ END SUBROUTINE setup_qm_atom_list !> \param mm_el_pot_radius_corr ... !> \param mm_atom_index ... !> \param iw ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE setup_qmmm_links(qmmm_section, qmmm_links, mm_el_pot_radius, mm_el_pot_radius_corr,& - mm_atom_index, iw, error) + mm_atom_index, iw) TYPE(section_vals_type), POINTER :: qmmm_section TYPE(qmmm_links_type), POINTER :: qmmm_links REAL(KIND=dp), DIMENSION(:), POINTER :: mm_el_pot_radius, & mm_el_pot_radius_corr INTEGER, DIMENSION(:), POINTER :: mm_atom_index INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_qmmm_links', & routineP = moduleN//':'//routineN @@ -1096,53 +1045,53 @@ SUBROUTINE setup_qmmm_links(qmmm_section, qmmm_links, mm_el_pot_radius, mm_el_p n_imomm = 0 n_gho = 0 n_pseudo= 0 - qmmm_link_section => section_vals_get_subs_vals(qmmm_section,"LINK",error=error) - CALL section_vals_get(qmmm_link_section,n_repetition=nlinks,error=error) - CPPostcondition(nlinks /= 0,cp_failure_level,routineP,error,failure) + qmmm_link_section => section_vals_get_subs_vals(qmmm_section,"LINK") + CALL section_vals_get(qmmm_link_section,n_repetition=nlinks) + CPPostcondition(nlinks /= 0,cp_failure_level,routineP,failure) DO ikind= 1, nlinks - CALL section_vals_val_get(qmmm_link_section,"LINK_TYPE",i_rep_section=ikind,i_val=link_type,error=error) + CALL section_vals_val_get(qmmm_link_section,"LINK_TYPE",i_rep_section=ikind,i_val=link_type) IF (link_type == do_qmmm_link_imomm) n_imomm = n_imomm + 1 IF (link_type == do_qmmm_link_gho ) n_gho = n_gho + 1 IF (link_type == do_qmmm_link_pseudo) n_pseudo = n_pseudo + 1 END DO n_tot = n_imomm + n_gho + n_pseudo - CPPostcondition(n_tot /= 0,cp_failure_level,routineP,error,failure) + CPPostcondition(n_tot /= 0,cp_failure_level,routineP,failure) ALLOCATE(qmmm_links, stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) NULLIFY(qmmm_links%imomm,& qmmm_links%pseudo) ! IMOMM IF ( n_imomm /= 0 ) THEN ALLOCATE(qmmm_links%imomm(n_imomm), stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) ALLOCATE(wrk_tmp(n_imomm), stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) DO ikind = 1, n_imomm NULLIFY(qmmm_links%imomm(ikind)%link) ALLOCATE(qmmm_links%imomm(ikind)%link,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) END DO n_imomm = 0 DO ikind = 1, nlinks - CALL section_vals_val_get(qmmm_link_section,"LINK_TYPE",i_rep_section=ikind,i_val=link_type,error=error) + CALL section_vals_val_get(qmmm_link_section,"LINK_TYPE",i_rep_section=ikind,i_val=link_type) IF (link_type == do_qmmm_link_imomm) THEN n_imomm = n_imomm + 1 - CALL section_vals_val_get(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index,error=error) - CALL section_vals_val_get(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index,error=error) - CALL section_vals_val_get(qmmm_link_section,"ALPHA_IMOMM",i_rep_section=ikind,r_val=alpha,error=error) - CALL section_vals_val_get(qmmm_link_section,"RADIUS",i_rep_section=ikind,n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index) + CALL section_vals_val_get(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index) + CALL section_vals_val_get(qmmm_link_section,"ALPHA_IMOMM",i_rep_section=ikind,r_val=alpha) + CALL section_vals_val_get(qmmm_link_section,"RADIUS",i_rep_section=ikind,n_rep_val=n_rep_val) qmmm_links%imomm(n_imomm)%link%qm_index = qm_index qmmm_links%imomm(n_imomm)%link%mm_index = mm_index qmmm_links%imomm(n_imomm)%link%alpha = alpha wrk_tmp(n_imomm) = mm_index IF (n_rep_val == 1) THEN - CALL section_vals_val_get(qmmm_link_section,"RADIUS",i_rep_section=ikind,r_val=my_radius,error=error) + CALL section_vals_val_get(qmmm_link_section,"RADIUS",i_rep_section=ikind,r_val=my_radius) WHERE ( mm_atom_index == mm_index ) mm_el_pot_radius = my_radius WHERE ( mm_atom_index == mm_index ) mm_el_pot_radius_corr = my_radius END IF - CALL section_vals_val_get(qmmm_link_section,"CORR_RADIUS",i_rep_section=ikind,n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(qmmm_link_section,"CORR_RADIUS",i_rep_section=ikind,n_rep_val=n_rep_val) IF (n_rep_val == 1) THEN - CALL section_vals_val_get(qmmm_link_section,"CORR_RADIUS",i_rep_section=ikind,r_val=my_radius,error=error) + CALL section_vals_val_get(qmmm_link_section,"CORR_RADIUS",i_rep_section=ikind,r_val=my_radius) WHERE ( mm_atom_index == mm_index ) mm_el_pot_radius_corr = my_radius END IF END IF @@ -1154,28 +1103,28 @@ SUBROUTINE setup_qmmm_links(qmmm_section, qmmm_links, mm_el_pot_radius, mm_el_p IF (COUNT(wrk_tmp == wrk_tmp(ikind)) > 1) THEN WRITE(iw,'(/A)')"In the IMOMM scheme no more than one QM atom can be bounded to the same MM atom." WRITE(iw, '(A)')"Multiple link MM atom not allowed. Check your link sections." - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(wrk_tmp, stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) END IF ! PSEUDO IF ( n_pseudo /= 0 ) THEN ALLOCATE(qmmm_links%pseudo(n_pseudo), stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) DO ikind = 1, n_pseudo NULLIFY(qmmm_links%pseudo(ikind)%link) ALLOCATE(qmmm_links%pseudo(ikind)%link,stat=stat) - CPPostcondition(stat == 0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat == 0,cp_failure_level,routineP,failure) END DO n_pseudo = 0 DO ikind = 1, nlinks - CALL section_vals_val_get(qmmm_link_section,"LINK_TYPE",i_rep_section=ikind,i_val=link_type,error=error) + CALL section_vals_val_get(qmmm_link_section,"LINK_TYPE",i_rep_section=ikind,i_val=link_type) IF (link_type == do_qmmm_link_pseudo) THEN n_pseudo = n_pseudo + 1 - CALL section_vals_val_get(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index,error=error) - CALL section_vals_val_get(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index,error=error) + CALL section_vals_val_get(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index) + CALL section_vals_val_get(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index) qmmm_links%pseudo(n_pseudo)%link%qm_index = qm_index qmmm_links%pseudo(n_pseudo)%link%mm_index = mm_index END IF @@ -1185,7 +1134,7 @@ SUBROUTINE setup_qmmm_links(qmmm_section, qmmm_links, mm_el_pot_radius, mm_el_p IF ( n_gho /= 0) THEN ! not yet implemented ! still to define : type, implementation into QS - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE setup_qmmm_links @@ -1199,15 +1148,13 @@ END SUBROUTINE setup_qmmm_links !> \param mm_el_pot_radius_corr ... !> \param added_charges ... !> \param mm_atom_index ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE move_or_add_atoms(qmmm_section, move_mm_charges, add_mm_charges, & mm_atom_chrg, mm_el_pot_radius, mm_el_pot_radius_corr,& - added_charges, mm_atom_index, error) + added_charges, mm_atom_index) TYPE(section_vals_type), POINTER :: qmmm_section LOGICAL, INTENT(OUT) :: move_mm_charges, & add_mm_charges @@ -1216,7 +1163,6 @@ SUBROUTINE move_or_add_atoms(qmmm_section, move_mm_charges, add_mm_charges, & mm_el_pot_radius_corr TYPE(add_set_type), POINTER :: added_charges INTEGER, DIMENSION(:), POINTER :: mm_atom_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'move_or_add_atoms', & routineP = moduleN//':'//routineN @@ -1234,19 +1180,19 @@ SUBROUTINE move_or_add_atoms(qmmm_section, move_mm_charges, add_mm_charges, & move_mm_charges = .FALSE. add_mm_charges = .FALSE. NULLIFY( qmmm_link_section, move_section, add_section) - qmmm_link_section => section_vals_get_subs_vals(qmmm_section,"LINK",error=error) - CALL section_vals_get(qmmm_link_section,n_repetition=nlinks,error=error) - CPPostcondition(nlinks /= 0,cp_failure_level,routineP,error,failure) + qmmm_link_section => section_vals_get_subs_vals(qmmm_section,"LINK") + CALL section_vals_get(qmmm_link_section,n_repetition=nlinks) + CPPostcondition(nlinks /= 0,cp_failure_level,routineP,failure) icount = 0 n_move_tot = 0 n_add_tot = 0 DO ikind= 1, nlinks move_section => section_vals_get_subs_vals(qmmm_link_section,"MOVE_MM_CHARGE",& - i_rep_section=ikind, error=error) - CALL section_vals_get(move_section,n_repetition=n_moves,error=error) + i_rep_section=ikind) + CALL section_vals_get(move_section,n_repetition=n_moves) add_section => section_vals_get_subs_vals(qmmm_link_section,"ADD_MM_CHARGE",& - i_rep_section=ikind, error=error) - CALL section_vals_get(add_section,n_repetition=n_adds,error=error) + i_rep_section=ikind) + CALL section_vals_get(add_section,n_repetition=n_adds) n_move_tot = n_move_tot + n_moves n_add_tot = n_add_tot + n_adds END DO @@ -1256,62 +1202,61 @@ SUBROUTINE move_or_add_atoms(qmmm_section, move_mm_charges, add_mm_charges, & ! ! create add_set_type ! - CALL create_add_set_type(added_charges, ndim=icount, error=error) + CALL create_add_set_type(added_charges, ndim=icount) ! ! Fill in structures ! icount = 0 DO ikind= 1, nlinks move_section => section_vals_get_subs_vals(qmmm_link_section,"MOVE_MM_CHARGE",& - i_rep_section=ikind, error=error) - CALL section_vals_get(move_section, explicit=explicit, n_repetition=n_moves, error=error) + i_rep_section=ikind) + CALL section_vals_get(move_section, explicit=explicit, n_repetition=n_moves) ! ! Moving charge atoms ! IF (explicit) THEN DO i_add = 1, n_moves icount = icount + 1 - CALL section_vals_val_get(move_section,"ATOM_INDEX_1",i_val=Index1,i_rep_section=i_add,error=error) - CALL section_vals_val_get(move_section,"ATOM_INDEX_2",i_val=Index2,i_rep_section=i_add,error=error) - CALL section_vals_val_get(move_section,"ALPHA",r_val=alpha,i_rep_section=i_add,error=error) - CALL section_vals_val_get(move_section,"RADIUS",r_val=radius,i_rep_section=i_add,error=error) - CALL section_vals_val_get(move_section,"CORR_RADIUS",n_rep_val=n_rep_val,i_rep_section=i_add,error=error) + CALL section_vals_val_get(move_section,"ATOM_INDEX_1",i_val=Index1,i_rep_section=i_add) + CALL section_vals_val_get(move_section,"ATOM_INDEX_2",i_val=Index2,i_rep_section=i_add) + CALL section_vals_val_get(move_section,"ALPHA",r_val=alpha,i_rep_section=i_add) + CALL section_vals_val_get(move_section,"RADIUS",r_val=radius,i_rep_section=i_add) + CALL section_vals_val_get(move_section,"CORR_RADIUS",n_rep_val=n_rep_val,i_rep_section=i_add) c_radius = radius IF (n_rep_val == 1) & - CALL section_vals_val_get(move_section,"CORR_RADIUS",r_val=c_radius,i_rep_section=i_add,error=error) + CALL section_vals_val_get(move_section,"CORR_RADIUS",r_val=c_radius,i_rep_section=i_add) CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius,& mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius,& mm_el_pot_radius_corr=mm_el_pot_radius_corr,& - mm_atom_index=mm_atom_index, move=n_moves, Ind1=ind1,& - error=error) + mm_atom_index=mm_atom_index, move=n_moves, Ind1=ind1) END DO mm_atom_chrg(ind1) = 0.0_dp END IF add_section => section_vals_get_subs_vals(qmmm_link_section,"ADD_MM_CHARGE",& - i_rep_section=ikind, error=error) - CALL section_vals_get(add_section, explicit=explicit, n_repetition=n_adds, error=error) + i_rep_section=ikind) + CALL section_vals_get(add_section, explicit=explicit, n_repetition=n_adds) ! ! Adding charge atoms ! IF (explicit) THEN DO i_add = 1, n_adds icount = icount + 1 - CALL section_vals_val_get(add_section,"ATOM_INDEX_1",i_val=Index1,i_rep_section=i_add,error=error) - CALL section_vals_val_get(add_section,"ATOM_INDEX_2",i_val=Index2,i_rep_section=i_add,error=error) - CALL section_vals_val_get(add_section,"ALPHA",r_val=alpha,i_rep_section=i_add,error=error) - CALL section_vals_val_get(add_section,"RADIUS",r_val=radius,i_rep_section=i_add,error=error) - CALL section_vals_val_get(add_section,"CHARGE",r_val=charge,i_rep_section=i_add,error=error) - CALL section_vals_val_get(add_section,"CORR_RADIUS",n_rep_val=n_rep_val,i_rep_section=i_add,error=error) + CALL section_vals_val_get(add_section,"ATOM_INDEX_1",i_val=Index1,i_rep_section=i_add) + CALL section_vals_val_get(add_section,"ATOM_INDEX_2",i_val=Index2,i_rep_section=i_add) + CALL section_vals_val_get(add_section,"ALPHA",r_val=alpha,i_rep_section=i_add) + CALL section_vals_val_get(add_section,"RADIUS",r_val=radius,i_rep_section=i_add) + CALL section_vals_val_get(add_section,"CHARGE",r_val=charge,i_rep_section=i_add) + CALL section_vals_val_get(add_section,"CORR_RADIUS",n_rep_val=n_rep_val,i_rep_section=i_add) c_radius = radius IF (n_rep_val == 1) & - CALL section_vals_val_get(add_section,"CORR_RADIUS",r_val=c_radius,i_rep_section=i_add,error=error) + CALL section_vals_val_get(add_section,"CORR_RADIUS",r_val=c_radius,i_rep_section=i_add) CALL set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, charge,& mm_atom_chrg=mm_atom_chrg, mm_el_pot_radius=mm_el_pot_radius,& mm_el_pot_radius_corr=mm_el_pot_radius_corr,& - mm_atom_index=mm_atom_index, error=error) + mm_atom_index=mm_atom_index) END DO END IF END DO @@ -1334,14 +1279,12 @@ END SUBROUTINE move_or_add_atoms !> \param mm_atom_index ... !> \param move ... !> \param ind1 ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius, c_radius, charge,& - mm_atom_chrg, mm_el_pot_radius, mm_el_pot_radius_corr, mm_atom_index, move, ind1, error) + mm_atom_chrg, mm_el_pot_radius, mm_el_pot_radius_corr, mm_atom_index, move, ind1) TYPE(add_set_type), POINTER :: added_charges INTEGER, INTENT(IN) :: icount, Index1, Index2 REAL(KIND=dp), INTENT(IN) :: alpha, radius, c_radius @@ -1352,7 +1295,6 @@ SUBROUTINE set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius INTEGER, DIMENSION(:), POINTER :: mm_atom_index INTEGER, INTENT(in), OPTIONAL :: move INTEGER, INTENT(OUT), OPTIONAL :: ind1 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_add_set_type', & routineP = moduleN//':'//routineN @@ -1374,7 +1316,7 @@ SUBROUTINE set_add_set_type(added_charges, icount, Index1, Index2, alpha, radius i = i+1 END DO GetId IF (PRESENT(ind1)) ind1 = i - CPPostcondition(i<=SIZE(mm_atom_index),cp_failure_level,routineP,error,failure) + CPPostcondition(i<=SIZE(mm_atom_index),cp_failure_level,routineP,failure) IF (.NOT.PRESENT(charge)) my_charge = mm_atom_chrg(i)/REAL(my_move,KIND=dp) IF (my_radius == 0.0_dp) my_radius = mm_el_pot_radius(i) IF (my_c_radius == 0.0_dp) my_c_radius = mm_el_pot_radius_corr(i) @@ -1396,19 +1338,16 @@ END SUBROUTINE set_add_set_type !> \param qmmm_env ... !> \param qm_cell_small ... !> \param dr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE setup_origin_mm_cell(qmmm_section, qmmm_env, qm_cell_small, & - dr, error) + dr) TYPE(section_vals_type), POINTER :: qmmm_section TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(cell_type), POINTER :: qm_cell_small REAL(KIND=dp), DIMENSION(3), INTENT(in) :: dr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_origin_mm_cell', & routineP = moduleN//':'//routineN @@ -1422,17 +1361,17 @@ SUBROUTINE setup_origin_mm_cell(qmmm_section, qmmm_env, qm_cell_small, & tmp(1) = qm_cell_small%hmat(1,1) tmp(2) = qm_cell_small%hmat(2,2) tmp(3) = qm_cell_small%hmat(3,3) - CPPostcondition(ALL(tmp>0),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(tmp>0),cp_failure_level,routineP,failure) qmmm_env%dOmmOqm = tmp/2.0_dp ! This is unit vector to translate the QM system in order to center it ! in QM cell - CALL section_vals_val_get(qmmm_section,"CENTER_GRID",l_val=center_grid,error=error) + CALL section_vals_val_get(qmmm_section,"CENTER_GRID",l_val=center_grid) IF (center_grid) THEN qmmm_env%utrasl = dr ELSE qmmm_env%utrasl = 1.0_dp ENDIF - CALL section_vals_val_get(qmmm_section,"INITIAL_TRANSLATION_VECTOR",r_vals=vec,error=error) + CALL section_vals_val_get(qmmm_section,"INITIAL_TRANSLATION_VECTOR",r_vals=vec) qmmm_env%transl_v = vec END SUBROUTINE setup_origin_mm_cell @@ -1442,20 +1381,17 @@ END SUBROUTINE setup_origin_mm_cell !> \param qmmm_env ... !> \param qm_atom_index ... !> \param subsys_mm ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2012 created !> \author Dorothea Golze ! ***************************************************************************** SUBROUTINE setup_image_atom_list(image_charge_section, qmmm_env,& - qm_atom_index, subsys_mm, error) + qm_atom_index, subsys_mm) TYPE(section_vals_type), POINTER :: image_charge_section TYPE(qmmm_env_qm_type), POINTER :: qmmm_env INTEGER, DIMENSION(:), POINTER :: qm_atom_index TYPE(cp_subsys_type), POINTER :: subsys_mm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_image_atom_list', & routineP = moduleN//':'//routineN @@ -1477,22 +1413,22 @@ SUBROUTINE setup_image_atom_list(image_charge_section, qmmm_env,& max_index=0 CALL section_vals_val_get(image_charge_section,"MM_ATOM_LIST",& - n_rep_val=n_var,error=error) + n_rep_val=n_var) DO i = 1, n_var CALL section_vals_val_get(image_charge_section,"MM_ATOM_LIST",& - i_rep_val=i,i_vals=mm_indexes,error=error) + i_rep_val=i,i_vals=mm_indexes) num_image_mm_atom = num_image_mm_atom + SIZE(mm_indexes) END DO ALLOCATE(qmmm_env%image_charge_pot%image_mm_list(num_image_mm_atom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qmmm_env%image_charge_pot%image_mm_list=0 num_image_mm_atom=1 DO i = 1, n_var CALL section_vals_val_get(image_charge_section,"MM_ATOM_LIST",& - i_rep_val=i,i_vals=mm_indexes,error=error) + i_rep_val=i,i_vals=mm_indexes) qmmm_env%image_charge_pot%image_mm_list(num_image_mm_atom:num_image_mm_atom & + SIZE(mm_indexes)-1) = mm_indexes(:) num_image_mm_atom = num_image_mm_atom + SIZE(mm_indexes) @@ -1503,10 +1439,10 @@ SUBROUTINE setup_image_atom_list(image_charge_section, qmmm_env,& max_index=SIZE(subsys_mm%particles%els) - CPPrecondition(SIZE(qmmm_env%image_charge_pot%image_mm_list) /= 0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(qmmm_env%image_charge_pot%image_mm_list) /= 0,cp_failure_level,routineP,failure) imageind_in_range=(MAXVAL(qmmm_env%image_charge_pot%image_mm_list)<= max_index)& .AND.(MINVAL(qmmm_env%image_charge_pot%image_mm_list) > 0) - CPPostcondition(imageind_in_range,cp_failure_level,routineP,error,failure) + CPPostcondition(imageind_in_range,cp_failure_level,routineP,failure) DO i=1,num_image_mm_atom atom_a=qmmm_env%image_charge_pot%image_mm_list(i) @@ -1562,17 +1498,14 @@ END SUBROUTINE setup_image_atom_list !> \brief Print info on image charges !> \param qmmm_env ... !> \param qmmm_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2012 created !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE print_image_charge_info(qmmm_env, qmmm_section, error) + SUBROUTINE print_image_charge_info(qmmm_env, qmmm_section) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(section_vals_type), POINTER :: qmmm_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_image_charge_info', & routineP = moduleN//':'//routineN @@ -1581,13 +1514,13 @@ SUBROUTINE print_image_charge_info(qmmm_env, qmmm_section, error) REAL(KIND=dp) :: eta, eta_conv, V0, V0_conv TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw=cp_print_key_unit_nr(logger,qmmm_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") eta=qmmm_env%image_charge_pot%eta - eta_conv = cp_unit_from_cp2k(eta,"angstrom",power=-2,error=error) + eta_conv = cp_unit_from_cp2k(eta,"angstrom",power=-2) V0=qmmm_env%image_charge_pot%V0 - V0_conv = cp_unit_from_cp2k(V0,"volt",error=error) + V0_conv = cp_unit_from_cp2k(V0,"volt") IF (iw>0) THEN WRITE(iw,FMT="(T25,A)")"IMAGE CHARGE PARAMETERS" @@ -1604,7 +1537,7 @@ SUBROUTINE print_image_charge_info(qmmm_env, qmmm_section, error) WRITE(iw,FMT="(/,T2,A,/)") REPEAT("-",79) END IF CALL cp_print_key_finished_output(iw,logger,qmmm_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE print_image_charge_info diff --git a/src/qmmm_links_methods.F b/src/qmmm_links_methods.F index 2b955cf333..33f4143859 100644 --- a/src/qmmm_links_methods.F +++ b/src/qmmm_links_methods.F @@ -36,18 +36,15 @@ MODULE qmmm_links_methods !> \param qmmm_links ... !> \param particles ... !> \param qm_atom_index ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_link_Imomm_coord( qmmm_links, particles, qm_atom_index, error) + SUBROUTINE qmmm_link_Imomm_coord( qmmm_links, particles, qm_atom_index) TYPE(qmmm_links_type), POINTER :: qmmm_links TYPE(particle_type), DIMENSION(:), & POINTER :: particles INTEGER, DIMENSION(:), POINTER :: qm_atom_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_link_Imomm_coord', & routineP = moduleN//':'//routineN @@ -60,7 +57,7 @@ SUBROUTINE qmmm_link_Imomm_coord( qmmm_links, particles, qm_atom_index, error) failure = .FALSE. n_imomm = SIZE(qmmm_links%imomm) - CPPrecondition(n_imomm /= 0,cp_failure_level,routineP,error,failure) + CPPrecondition(n_imomm /= 0,cp_failure_level,routineP,failure) DO ilink = 1, n_imomm my_link => qmmm_links%imomm(ilink)%link qm_index = my_link%qm_index @@ -94,18 +91,15 @@ END SUBROUTINE qmmm_link_Imomm_coord !> \param qmmm_links ... !> \param particles_qm ... !> \param qm_atom_index ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_link_Imomm_forces(qmmm_links, particles_qm, qm_atom_index, error) + SUBROUTINE qmmm_link_Imomm_forces(qmmm_links, particles_qm, qm_atom_index) TYPE(qmmm_links_type), POINTER :: qmmm_links TYPE(particle_type), DIMENSION(:), & POINTER :: particles_qm INTEGER, DIMENSION(:), POINTER :: qm_atom_index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_link_Imomm_forces', & routineP = moduleN//':'//routineN @@ -118,7 +112,7 @@ SUBROUTINE qmmm_link_Imomm_forces(qmmm_links, particles_qm, qm_atom_index, erro failure = .FALSE. n_imomm = SIZE(qmmm_links%imomm) - CPPrecondition(n_imomm /= 0,cp_failure_level,routineP,error,failure) + CPPrecondition(n_imomm /= 0,cp_failure_level,routineP,failure) DO ilink = 1, n_imomm my_link => qmmm_links%imomm(ilink)%link qm_index = my_link%qm_index @@ -152,17 +146,14 @@ END SUBROUTINE qmmm_link_Imomm_forces !> \brief correct the position for added charges in qm/mm link scheme !> \param qmmm_env ... !> \param particles ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_added_chrg_coord(qmmm_env, particles, error) + SUBROUTINE qmmm_added_chrg_coord(qmmm_env, particles) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_added_chrg_coord', & routineP = moduleN//':'//routineN @@ -188,17 +179,14 @@ END SUBROUTINE qmmm_added_chrg_coord !> \brief correct the forces due to the added charges in qm/mm link scheme !> \param qmmm_env ... !> \param particles ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2005 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_added_chrg_forces(qmmm_env, particles, error) + SUBROUTINE qmmm_added_chrg_forces(qmmm_env, particles) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(particle_type), DIMENSION(:), & POINTER :: particles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_added_chrg_forces', & routineP = moduleN//':'//routineN diff --git a/src/qmmm_per_elpot.F b/src/qmmm_per_elpot.F index 5cb4e8d0b6..d01ebc80ce 100644 --- a/src/qmmm_per_elpot.F +++ b/src/qmmm_per_elpot.F @@ -70,15 +70,13 @@ MODULE qmmm_per_elpot !> \param maxchrg ... !> \param ncp ... !> \param ncpl ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& pgfs, qm_cell_small, mm_cell, para_env, compatibility, qmmm_periodic, print_section,& - eps_mm_rspace, maxchrg, ncp, ncpl, error) + eps_mm_rspace, maxchrg, ncp, ncpl) INTEGER, INTENT(IN) :: qmmm_coupl_type TYPE(qmmm_per_pot_p_type), & DIMENSION(:), POINTER :: per_potentials @@ -92,7 +90,6 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& TYPE(section_vals_type), POINTER :: qmmm_periodic, print_section REAL(KIND=dp), INTENT(IN) :: eps_mm_rspace, maxchrg INTEGER, INTENT(IN) :: ncp(3), ncpl(3) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_per_potential_init', & routineP = moduleN//':'//routineN @@ -111,13 +108,13 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& NULLIFY(Lg, gx, gy, gz) ncoarset = PRODUCT(ncp) ncoarsel = PRODUCT(ncpl) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) Rmax = SQRT(mm_cell%hmat(1,1)**2+& mm_cell%hmat(2,2)**2+& mm_cell%hmat(3,3)**2 ) - CALL section_vals_val_get(qmmm_periodic,"GMAX",r_val=Gmax,error=error) - CALL section_vals_val_get(qmmm_periodic,"REPLICA",i_val=n_rep_real_val,error=error) + CALL section_vals_val_get(qmmm_periodic,"GMAX",r_val=Gmax) + CALL section_vals_val_get(qmmm_periodic,"REPLICA",i_val=n_rep_real_val) fac = 2.0e0_dp*Pi/(/mm_cell%hmat(1,1),mm_cell%hmat(2,2),mm_cell%hmat(3,3)/) Kmax = CEILING(Gmax/Fac) Vol = mm_cell%hmat(1,1)*& @@ -128,28 +125,28 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& n_rep_real = n_rep_real_val IF (compatibility.AND.(qmmm_coupl_type==do_qmmm_gauss)) ig_start = 2 - CPPrecondition(.NOT.ASSOCIATED(per_potentials),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(per_potentials),cp_failure_level,routineP,failure) ALLOCATE(per_potentials(SIZE(pgfs)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) - CPPrecondition(SIZE(pgfs)==SIZE(potentials),cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) + CPPrecondition(SIZE(pgfs)==SIZE(potentials),cp_failure_level,routineP,failure) Potential_Type: DO K = 1, SIZE(pgfs) rc = pgfs(K)%pgf%Elp_Radius ALLOCATE(per_potentials(K)%Pot, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE(qmmm_coupl_type) CASE(do_qmmm_coulomb,do_qmmm_pcharge) ! Not yet implemented for this case - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE(do_qmmm_gauss,do_qmmm_swave) ALLOCATE(Lg(Ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gx(Ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gy(Ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(gz(Ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT LG = 0.0_dp @@ -160,7 +157,7 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& SELECT CASE(qmmm_coupl_type) CASE(do_qmmm_coulomb,do_qmmm_pcharge) ! Not yet implemented for this case - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE(do_qmmm_gauss,do_qmmm_swave) pgf => pgfs(K)%pgf idim = 0 @@ -214,7 +211,7 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& box (2) = (qm_cell_small%hmat(2,2) - mm_cell%hmat(2,2))/2.0_dp box (3) = (qm_cell_small%hmat(3,3) - mm_cell%hmat(3,3))/2.0_dp IF (ANY(box > 0.0_dp)) THEN - CPPostcondition(.FALSE.,cp_fatal_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_fatal_level,routineP,failure) END IF n_rep_real(1) = CEILING(( box(1) + mymaxradius ) / mm_cell%hmat(1,1)) n_rep_real(2) = CEILING(( box(2) + mymaxradius ) / mm_cell%hmat(2,2)) @@ -223,7 +220,7 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& CASE DEFAULT DEALLOCATE(per_potentials(K)%Pot) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) NULLIFY(per_potentials(K)%Pot) IF (output_unit>0) WRITE(output_unit,'(A)')" QMMM Periodic Potential - not Initialized!" CYCLE Potential_Type @@ -231,7 +228,7 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& NULLIFY(mm_atom_index) ALLOCATE(mm_atom_index(SIZE(potentials(K)%pot%mm_atom_index)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) mm_atom_index = potentials(K)%pot%mm_atom_index NULLIFY(per_potentials(K)%Pot%LG, per_potentials(K)%Pot%mm_atom_index,& @@ -240,11 +237,10 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& Gmax=Gmax, Kmax=Kmax, n_rep_real=n_rep_real,& Fac=Fac, mm_atom_index=mm_atom_index, & mm_cell=mm_cell, para_env=para_env,& - qmmm_per_section=qmmm_periodic, print_section=print_section,& - error=error) + qmmm_per_section=qmmm_periodic, print_section=print_section) iw=cp_print_key_unit_nr(logger,print_section,"PERIODIC_INFO",& - extension=".log",error=error) + extension=".log") IF ( iw > 0) THEN npt = REAL(ncoarset,KIND=dp)*REAL(ndim,KIND=dp)*REAL(SIZE(mm_atom_index),KIND=dp) npl = REAL(ncoarsel,KIND=dp)*REAL(ndim,KIND=dp)*REAL(SIZE(mm_atom_index),KIND=dp) @@ -261,7 +257,7 @@ SUBROUTINE qmmm_per_potential_init(qmmm_coupl_type, per_potentials, potentials,& WRITE (UNIT=iw,FMT="(T2,A)") REPEAT("-",79) END IF CALL cp_print_key_finished_output(iw,logger,print_section,& - "PERIODIC_INFO", error=error) + "PERIODIC_INFO") END DO Potential_Type @@ -283,15 +279,12 @@ END SUBROUTINE qmmm_per_potential_init !> \param para_env ... !> \param qmmm_per_section ... !> \param print_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_per_pot_type_create(Pot, LG, gx, gy, gz, GMax, Kmax, n_rep_real,& - Fac, mm_atom_index, mm_cell, para_env, qmmm_per_section, print_section,& - error) + Fac, mm_atom_index, mm_cell, para_env, qmmm_per_section, print_section) TYPE(qmmm_per_pot_type), POINTER :: Pot REAL(KIND=dp), DIMENSION(:), POINTER :: LG, gx, gy, gz REAL(KIND=dp), INTENT(IN) :: Gmax @@ -302,7 +295,6 @@ SUBROUTINE qmmm_per_pot_type_create(Pot, LG, gx, gy, gz, GMax, Kmax, n_rep_real, TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: qmmm_per_section, & print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_per_pot_type_create', & routineP = moduleN//':'//routineN @@ -329,14 +321,14 @@ SUBROUTINE qmmm_per_pot_type_create(Pot, LG, gx, gy, gz, GMax, Kmax, n_rep_real, NULLIFY(Pot%pw_grid) NULLIFY(Pot%pw_pool) NULLIFY(Pot%TabLR, ngrids) - CALL section_vals_val_get(qmmm_per_section,"ngrids", i_vals=ngrids, error=error) + CALL section_vals_val_get(qmmm_per_section,"ngrids", i_vals=ngrids) npts = ngrids hmat = mm_cell%hmat - grid_print_section=> section_vals_get_subs_vals(print_section,"GRID_INFORMATION",error=error) + grid_print_section=> section_vals_get_subs_vals(print_section,"GRID_INFORMATION") CALL Setup_Ewald_Spline(pw_grid=Pot%pw_grid, pw_pool=Pot%pw_pool, coeff=Pot%TabLR,& LG=LG, gx=gx, gy=gy, gz=gz, hmat=hmat, npts=npts, param_section=qmmm_per_section,& - tag="qmmm",para_env=para_env, print_section=grid_print_section,error=error) + tag="qmmm",para_env=para_env, print_section=grid_print_section) END SUBROUTINE qmmm_per_pot_type_create @@ -351,21 +343,18 @@ END SUBROUTINE qmmm_per_pot_type_create !> \param para_env ... !> \param qmmm_periodic ... !> \param print_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2014 created [JGH] !> \author JGH ! ***************************************************************************** SUBROUTINE qmmm_ewald_potential_init(ewald_env,ewald_pw,qmmm_coupl_type, mm_cell, para_env,& - qmmm_periodic, print_section, error) + qmmm_periodic, print_section) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw INTEGER, INTENT(IN) :: qmmm_coupl_type TYPE(cell_type), POINTER :: mm_cell TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: qmmm_periodic, print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_ewald_potential_init', & routineP = moduleN//':'//routineN @@ -379,43 +368,43 @@ SUBROUTINE qmmm_ewald_potential_init(ewald_env,ewald_pw,qmmm_coupl_type, mm_cell ewald_section, poisson_section failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ounit = cp_logger_get_default_io_unit(logger) - CPPrecondition(.NOT.ASSOCIATED(ewald_env),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(ewald_pw),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(ewald_env),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(ewald_pw),cp_failure_level,routineP,failure) ! Create Ewald environments - poisson_section => section_vals_get_subs_vals(qmmm_periodic,"POISSON",error=error) - CALL ewald_env_create(ewald_env,para_env,error=error) - CALL ewald_env_set(ewald_env,poisson_section=poisson_section,error=error) - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD",error=error) - CALL read_ewald_section(ewald_env,ewald_section,error=error) - ewald_print_section => section_vals_get_subs_vals(print_section,"GRID_INFORMATION",error=error) - CALL ewald_pw_create(ewald_pw,ewald_env,mm_cell,mm_cell,print_section=ewald_print_section,error=error) + poisson_section => section_vals_get_subs_vals(qmmm_periodic,"POISSON") + CALL ewald_env_create(ewald_env,para_env) + CALL ewald_env_set(ewald_env,poisson_section=poisson_section) + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD") + CALL read_ewald_section(ewald_env,ewald_section) + ewald_print_section => section_vals_get_subs_vals(print_section,"GRID_INFORMATION") + CALL ewald_pw_create(ewald_pw,ewald_env,mm_cell,mm_cell,print_section=ewald_print_section) CALL ewald_env_get(ewald_env,ewald_type=ewald_type,do_multipoles=do_multipoles,& - gmax=gmax,o_spline=o_spline,alpha=alpha,rcut=rcut,error=error) + gmax=gmax,o_spline=o_spline,alpha=alpha,rcut=rcut) IF(do_multipoles) CALL cp_unimplemented_error(fromWhere=routineP,& message="No multipole force fields allowed in QM-QM Ewald long range correction",& - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) SELECT CASE(qmmm_coupl_type) CASE(do_qmmm_coulomb) CALL cp_unimplemented_error(fromWhere=routineP, & message="QM-QM long range correction not possible with COULOMB coupling", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) CASE(do_qmmm_pcharge) ! OK CASE(do_qmmm_gauss,do_qmmm_swave) CALL cp_unimplemented_error(fromWhere=routineP, & message="QM-QM long range correction not possible with GAUSS/SWAVE coupling", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) CASE DEFAULT ! We should never get to this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT - iw=cp_print_key_unit_nr(logger,print_section,"PERIODIC_INFO",extension=".log",error=error) + iw=cp_print_key_unit_nr(logger,print_section,"PERIODIC_INFO",extension=".log") IF ( iw > 0) THEN WRITE (UNIT=iw,FMT="(/,T2,A)") REPEAT("-",79) WRITE (UNIT=iw,FMT="(T2,A,T20,A,T80,A)")"-","QMMM PERIODIC BOUNDARY CONDITION INFO","-" @@ -425,15 +414,15 @@ SUBROUTINE qmmm_ewald_potential_init(ewald_env,ewald_pw,qmmm_coupl_type, mm_cell CASE(do_ewald_none) CALL cp_unimplemented_error(fromWhere=routineP, & message="QM-QM long range correction not compatible with Ewald=NONE", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) CASE(do_ewald_pme) CALL cp_unimplemented_error(fromWhere=routineP, & message="QM-QM long range correction not possible with Ewald=PME", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) CASE(do_ewald_ewald) CALL cp_unimplemented_error(fromWhere=routineP, & message="QM-QM long range correction not possible with Ewald method", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) CASE(do_ewald_spme) WRITE (UNIT=iw,FMT="(T2,A,T35,A,T75,A,T80,A)")"-","Ewald type","SPME","-" WRITE (UNIT=iw,FMT="(T2,A,T35,A,T61,3I6,T80,A)")"-","GMAX values",gmax,"-" @@ -443,7 +432,7 @@ SUBROUTINE qmmm_ewald_potential_init(ewald_env,ewald_pw,qmmm_coupl_type, mm_cell END SELECT WRITE (UNIT=iw,FMT="(T2,A)") REPEAT("-",79) END IF - CALL cp_print_key_finished_output(iw,logger,print_section,"PERIODIC_INFO", error=error) + CALL cp_print_key_finished_output(iw,logger,print_section,"PERIODIC_INFO") END SUBROUTINE qmmm_ewald_potential_init diff --git a/src/qmmm_pw_grid.F b/src/qmmm_pw_grid.F index 3d4b50e825..b60b05a4a6 100644 --- a/src/qmmm_pw_grid.F +++ b/src/qmmm_pw_grid.F @@ -45,16 +45,13 @@ MODULE qmmm_pw_grid !> has [0,L] as boundaries. !> \param qmmm_env ... !> \param pw_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_pw_grid_init(qmmm_env, pw_env, error) + SUBROUTINE qmmm_pw_grid_init(qmmm_env, pw_env) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env TYPE(pw_env_type), POINTER :: pw_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_pw_grid_init', & routineP = moduleN//':'//routineN @@ -75,14 +72,13 @@ SUBROUTINE qmmm_pw_grid_init(qmmm_env, pw_env, error) IF ((qmmm_env%qmmm_coupl_type == do_qmmm_gauss).OR.(qmmm_env%qmmm_coupl_type == do_qmmm_swave)) THEN CALL pw_env_get(pw_env=pw_env,& pw_pools=pw_pools,& - auxbas_grid=auxbas_grid,& - error=error) + auxbas_grid=auxbas_grid) ! IF (ASSOCIATED(qmmm_env%aug_pools)) THEN - CALL pw_pools_dealloc(qmmm_env%aug_pools,error=error) + CALL pw_pools_dealloc(qmmm_env%aug_pools) END IF ALLOCATE(qmmm_env%aug_pools(SIZE(pw_pools)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! DO Ilevel = 1, SIZE(pw_pools) NULLIFY(pool, qmmm_env%aug_pools(Ilevel)%pool) @@ -95,16 +91,16 @@ SUBROUTINE qmmm_pw_grid_init(qmmm_env, pw_env, error) END IF CALL pw_grid_create_copy_no_pbc(pool%pw_grid,el_struct, & - pw_mode=pw_mode, error=error) + pw_mode=pw_mode) CALL pw_pool_create(qmmm_env%aug_pools(Ilevel)%pool,& - pw_grid=el_struct,error=error) + pw_grid=el_struct) Maxdr = MAX(Maxdr,el_struct%dr) Mindr = MIN(Mindr,el_struct%dr) IF (ALL(Maxdr.EQ.el_struct%dr)) qmmm_env%gridlevel_info%coarser_grid = Ilevel IF (ALL(Mindr.EQ.el_struct%dr)) qmmm_env%gridlevel_info%auxbas_grid = Ilevel - CALL pw_grid_release(el_struct,error=error) + CALL pw_grid_release(el_struct) END DO END IF @@ -117,8 +113,6 @@ END SUBROUTINE qmmm_pw_grid_init !> \param pw_grid_in the pw grid to duplicate !> \param pw_grid_out the output pw_grid_type !> \param pw_mode ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2004 created [tlaino] !> 04.2005 completly rewritten the duplicate routine, fixed parallel @@ -127,10 +121,9 @@ END SUBROUTINE qmmm_pw_grid_init !> 06.2007 moved to new module [jgh] !> \author Fawzi, Teo ! ***************************************************************************** - SUBROUTINE pw_grid_create_copy_no_pbc(pw_grid_in, pw_grid_out, pw_mode, error) + SUBROUTINE pw_grid_create_copy_no_pbc(pw_grid_in, pw_grid_out, pw_mode) TYPE(pw_grid_type), POINTER :: pw_grid_in, pw_grid_out INTEGER, INTENT(IN), OPTIONAL :: pw_mode - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pw_grid_create_copy_no_pbc', & routineP = moduleN//':'//routineN @@ -141,11 +134,11 @@ SUBROUTINE pw_grid_create_copy_no_pbc(pw_grid_in, pw_grid_out, pw_mode, error) failure = .FALSE. - CPPrecondition(pw_grid_in%ngpts_cut>0,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(pw_grid_out),cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid_in%ngpts_cut>0,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(pw_grid_out),cp_failure_level,routineP,failure) pw_mode_loc = pw_grid_in%para%mode IF (PRESENT(pw_mode)) pw_mode_loc = pw_mode - CALL pw_grid_create(pw_grid_out, pw_grid_in%para%group,error=error) + CALL pw_grid_create(pw_grid_out, pw_grid_in%para%group) qmmm_grid_tag = qmmm_grid_tag + 1 pw_grid_out %id_nr = qmmm_grid_tag pw_grid_out % ref_count = 1 @@ -194,7 +187,7 @@ SUBROUTINE pw_grid_create_copy_no_pbc(pw_grid_in, pw_grid_out, pw_mode, error) pw_grid_out % para % nyzray,& pw_grid_out % para % bo) ALLOCATE(pos_of_x(pw_grid_out%bounds(1,1):pw_grid_out%bounds(2,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pos_of_x(:pw_grid_out%bounds(2,1)-1)=pw_grid_in%para%pos_of_x pos_of_x(pw_grid_out%bounds(2,1))=pos_of_x(pw_grid_out%bounds(2,1)-1) pw_grid_out%para%pos_of_x => pos_of_x @@ -207,7 +200,7 @@ SUBROUTINE pw_grid_create_copy_no_pbc(pw_grid_in, pw_grid_out, pw_mode, error) pw_grid_out % para % rs_mpo = pw_grid_in % para % rs_mpo NULLIFY(pw_grid_out%g,pw_grid_out%gsq,pw_grid_out%g_hat) - CPPrecondition(pw_grid_in%grid_span==FULLSPACE,cp_failure_level,routineP,error,failure) + CPPrecondition(pw_grid_in%grid_span==FULLSPACE,cp_failure_level,routineP,failure) pw_grid_out%grid_span=pw_grid_in%grid_span pw_grid_out%have_g0=.FALSE. pw_grid_out%first_gne0=HUGE(0) diff --git a/src/qmmm_se_energy.F b/src/qmmm_se_energy.F index 44f3ae12d2..3328a9b14a 100644 --- a/src/qmmm_se_energy.F +++ b/src/qmmm_se_energy.F @@ -84,10 +84,9 @@ MODULE qmmm_se_energy !> \param particles_mm ... !> \param mm_cell ... !> \param para_env ... -!> \param error ... !> \author Teodoro Laino 04.2007 [created] ! ***************************************************************************** - SUBROUTINE build_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,error) + SUBROUTINE build_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env @@ -95,7 +94,6 @@ SUBROUTINE build_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,er POINTER :: particles_mm TYPE(cell_type), POINTER :: mm_cell TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_se_qmmm_matrix', & routineP = moduleN//':'//routineN @@ -129,34 +127,31 @@ SUBROUTINE build_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,er failure = .FALSE. CALL timeset(routineN,handle) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY (matrix_s, atomic_kind_set, qs_kind_set, energy) NULLIFY (se_kind_a, se_kind_mm, se_taper, particles_qm, ks_env, sab_orb) - CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input,error=error) + CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input) CALL get_qs_env(qs_env,& ks_env=ks_env,& matrix_s=matrix_s,& energy=energy,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) CALL build_overlap_matrix(ks_env,matrix_s=matrix_s,& matrix_name="OVERLAP",& basis_type_a="ORB",& basis_type_b="ORB", & - sab_nl=sab_orb,& - error=error) + sab_nl=sab_orb) - CALL set_ks_env(ks_env,matrix_s=matrix_s,error=error) + CALL set_ks_env(ks_env,matrix_s=matrix_s) CALL get_qs_env(qs_env=qs_env,& se_taper=se_taper,& atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& ks_qmmm_env=ks_qmmm_env_loc,& dft_control=dft_control,& - particle_set=particles_qm,& - error=error) + particle_set=particles_qm) SELECT CASE (dft_control%qs_control%method_id) CASE (do_method_am1,do_method_rm1,do_method_mndo,do_method_pdg,& @@ -174,27 +169,27 @@ SUBROUTINE build_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,er max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.) ! Allocate the core Hamiltonian matrix - CALL cp_dbcsr_allocate_matrix_set(ks_qmmm_env_loc%matrix_h,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(ks_qmmm_env_loc%matrix_h,1) ALLOCATE(ks_qmmm_env_loc%matrix_h(1)%matrix, STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_init(ks_qmmm_env_loc%matrix_h(1)%matrix,error) + CALL cp_dbcsr_init(ks_qmmm_env_loc%matrix_h(1)%matrix) CALL cp_dbcsr_copy(ks_qmmm_env_loc%matrix_h(1)%matrix,matrix_s(1)%matrix,& - name="QMMM HAMILTONIAN MATRIX",error=error) - CALL cp_dbcsr_set(ks_qmmm_env_loc%matrix_h(1)%matrix,0.0_dp,error) + name="QMMM HAMILTONIAN MATRIX") + CALL cp_dbcsr_set(ks_qmmm_env_loc%matrix_h(1)%matrix,0.0_dp) SELECT CASE(qmmm_env%qmmm_coupl_type) CASE(do_qmmm_coulomb,do_qmmm_gauss,do_qmmm_swave,do_qmmm_pcharge) ! Create a fake semi-empirical type to handle the classical atom - CALL semi_empirical_create(se_kind_mm,error) - CALL se_param_set_default(se_kind_mm,0,do_method_pchg,error) + CALL semi_empirical_create(se_kind_mm) + CALL se_param_set_default(se_kind_mm,0,do_method_pchg) itype = get_se_type(se_kind_mm%typ) nkind = SIZE(atomic_kind_set) enuclear = 0.0_dp Kinds: DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=list) - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) CALL get_se_param(se_kind_a,& defined=defined,& natorb=natorb_a) @@ -224,8 +219,7 @@ SUBROUTINE build_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,er se_int_control,& anag,& qmmm_env%spherical_cutoff,& - particles_qm,& - error) + particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL build_se_qmmm_matrix_low(h_block_a,& @@ -243,27 +237,26 @@ SUBROUTINE build_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,er se_int_control,& anag,& qmmm_env%spherical_cutoff,& - particles_qm,& - error) + particles_qm) END IF END IF END DO Atoms END DO Kinds CALL mp_sum(enuclear,para_env%group) energy%qmmm_nu = enuclear - CALL semi_empirical_release(se_kind_mm,error) + CALL semi_empirical_release(se_kind_mm) CASE(do_qmmm_none) ! Zero Matrix - CALL cp_dbcsr_set(ks_qmmm_env_loc%matrix_h(1)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(ks_qmmm_env_loc%matrix_h(1)%matrix,0.0_dp) END SELECT IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"QMMM%PRINT%QMMM_MATRIX",error=error),cp_p_file)) THEN + qs_env%input,"QMMM%PRINT%QMMM_MATRIX"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"QMMM%PRINT%QMMM_MATRIX",& - extension=".Log",error=error) + extension=".Log") CALL cp_dbcsr_write_sparse_matrix(ks_qmmm_env_loc%matrix_h(1)%matrix,4,6,qs_env,para_env,& - scale=1.0_dp,output_unit=iw,error=error) + scale=1.0_dp,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "QMMM%PRINT%QMMM_MATRIX", error=error) + "QMMM%PRINT%QMMM_MATRIX") END IF CALL timestop(handle) @@ -288,13 +281,12 @@ END SUBROUTINE build_se_qmmm_matrix !> \param anag ... !> \param qmmm_spherical_cutoff ... !> \param particles_qm ... -!> \param error ... !> \author Teodoro Laino 04.2007 [created] ! ***************************************************************************** SUBROUTINE build_se_qmmm_matrix_low(h_block_a, se_kind_a, se_kind_mm, potentials,& particles_mm, mm_charges, mm_atom_index,& mm_cell, IndQM, enuclear, itype, se_taper, se_int_control, anag, & - qmmm_spherical_cutoff, particles_qm, error) + qmmm_spherical_cutoff, particles_qm) REAL(KIND=dp), DIMENSION(:, :), POINTER :: h_block_a TYPE(semi_empirical_type), POINTER :: se_kind_a, se_kind_mm @@ -314,7 +306,6 @@ SUBROUTINE build_se_qmmm_matrix_low(h_block_a, se_kind_a, se_kind_mm, potentials REAL(KIND=dp), INTENT(IN) :: qmmm_spherical_cutoff(2) TYPE(particle_type), DIMENSION(:), & POINTER :: particles_qm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_se_qmmm_matrix_low', & routineP = moduleN//':'//routineN @@ -344,14 +335,14 @@ SUBROUTINE build_se_qmmm_matrix_low(h_block_a, se_kind_a, se_kind_mm, potentials se_kind_mm%zeff = mm_charges(Imm) ! Computes the screening factor for the spherical cutoff (if defined) IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor) se_kind_mm%zeff = se_kind_mm%zeff * sph_chrg_factor END IF IF (ABS(se_kind_mm%zeff)<=EPSILON(0.0_dp)) CYCLE CALL rotnuc (se_kind_a, se_kind_mm, rij, itype=itype, e1b=e1b, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) CALL corecore(se_kind_a, se_kind_mm, rij, itype=itype, enuc=enuc, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) enuclear = enuclear + enuc ! Contribution to the iatom block ! Computation of the QMMM core matrix diff --git a/src/qmmm_se_forces.F b/src/qmmm_se_forces.F index 75fec5fded..63f13b4ace 100644 --- a/src/qmmm_se_forces.F +++ b/src/qmmm_se_forces.F @@ -74,11 +74,10 @@ MODULE qmmm_se_forces !> \param calc_force ... !> \param Forces ... !> \param Forces_added_charges ... -!> \param error ... !> \author Teodoro Laino 04.2007 [created] ! ***************************************************************************** SUBROUTINE deriv_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& - calc_force, Forces, Forces_added_charges, error) + calc_force, Forces, Forces_added_charges) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env @@ -88,7 +87,6 @@ SUBROUTINE deriv_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(in), OPTIONAL :: calc_force REAL(KIND=dp), DIMENSION(:, :), POINTER :: Forces, Forces_added_charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deriv_se_qmmm_matrix', & routineP = moduleN//':'//routineN @@ -129,8 +127,7 @@ SUBROUTINE deriv_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& ks_qmmm_env=ks_qmmm_env_loc,& dft_control=dft_control,& particle_set=particles_qm,& - natom=number_qm_atoms,& - error=error) + natom=number_qm_atoms) SELECT CASE (dft_control%qs_control%method_id) CASE (do_method_rm1,do_method_am1,do_method_mndo,do_method_pdg,& do_method_pm3,do_method_pm6,do_method_mndod,do_method_pnnl) @@ -148,20 +145,20 @@ SUBROUTINE deriv_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& ! Create a fake semi-empirical type to handle the classical atom ALLOCATE(Forces_QM(3,number_qm_atoms),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL semi_empirical_create(se_kind_mm,error) - CALL se_param_set_default(se_kind_mm,0,do_method_pchg,error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL semi_empirical_create(se_kind_mm) + CALL se_param_set_default(se_kind_mm,0,do_method_pchg) itype = get_se_type(se_kind_mm%typ) nkind = SIZE(atomic_kind_set) enuclear = 0.0_dp Forces_QM= 0.0_dp - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao=matrix_p) DO ispin = 1, dft_control%nspins iqm = 0 Kinds: DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=list) - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) CALL get_se_param(se_kind_a,& defined=defined,& natorb=natorb_a) @@ -193,8 +190,7 @@ SUBROUTINE deriv_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& anag,& delta,& qmmm_env%spherical_cutoff,& - particles_qm,& - error) + particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL deriv_se_qmmm_matrix_low(p_block_a,& @@ -214,20 +210,19 @@ SUBROUTINE deriv_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& anag,& delta,& qmmm_env%spherical_cutoff,& - particles_qm,& - error) + particles_qm) END IF END IF END DO Atoms END DO Kinds END DO - CPPrecondition(iqm==number_qm_atoms,cp_failure_level,routineP,error,failure) + CPPrecondition(iqm==number_qm_atoms,cp_failure_level,routineP,failure) ! Transfer QM gradients to the QM particles.. CALL mp_sum(Forces_QM, para_env%group) iqm = 0 DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=list) - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) CALL get_se_param(se_kind_a,& defined=defined,& natorb=natorb_a) @@ -241,8 +236,8 @@ SUBROUTINE deriv_se_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& ! MM forces will be handled directly from the QMMM module in the same way ! as for GPW/GAPW methods DEALLOCATE(Forces_QM,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL semi_empirical_release(se_kind_mm,error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL semi_empirical_release(se_kind_mm) END IF CALL timestop(handle) @@ -269,13 +264,12 @@ END SUBROUTINE deriv_se_qmmm_matrix !> \param delta ... !> \param qmmm_spherical_cutoff ... !> \param particles_qm ... -!> \param error ... !> \author Teodoro Laino 04.2007 [created] ! ***************************************************************************** SUBROUTINE deriv_se_qmmm_matrix_low(p_block_a, se_kind_a, se_kind_mm,& potentials, particles_mm, mm_charges, mm_atom_index, & mm_cell, IndQM, itype, forces, forces_qm, se_taper,& - se_int_control, anag, delta, qmmm_spherical_cutoff, particles_qm, error) + se_int_control, anag, delta, qmmm_spherical_cutoff, particles_qm) REAL(KIND=dp), DIMENSION(:, :), POINTER :: p_block_a TYPE(semi_empirical_type), POINTER :: se_kind_a, se_kind_mm @@ -297,7 +291,6 @@ SUBROUTINE deriv_se_qmmm_matrix_low(p_block_a, se_kind_a, se_kind_mm,& qmmm_spherical_cutoff(2) TYPE(particle_type), DIMENSION(:), & POINTER :: particles_qm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deriv_se_qmmm_matrix_low', & routineP = moduleN//':'//routineN @@ -326,17 +319,17 @@ SUBROUTINE deriv_se_qmmm_matrix_low(p_block_a, se_kind_a, se_kind_mm,& se_kind_mm%zeff = mm_charges(Imm) ! Computes the screening factor for the spherical cutoff IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor) se_kind_mm%zeff = se_kind_mm%zeff * sph_chrg_factor END IF IF (ABS(se_kind_mm%zeff)<=EPSILON(0.0_dp)) CYCLE ! Integrals derivatives involving QM - MM atoms CALL drotnuc(se_kind_a, se_kind_mm, rij, itype=itype, de1b=de1b,& se_int_control=se_int_control, anag=anag, delta=delta, & - se_taper=se_taper, error=error) + se_taper=se_taper) CALL dcorecore(se_kind_a, se_kind_mm, rij, itype=itype, denuc=denuc,& se_int_control=se_int_control, anag=anag, delta=delta, & - se_taper=se_taper, error=error) + se_taper=se_taper) ! Nucler - Nuclear term force_ab(1:3)=-denuc(1:3) ! Force contribution from the QMMM Hamiltonian diff --git a/src/qmmm_topology_util.F b/src/qmmm_topology_util.F index 849deab9b2..5f1ac8a68c 100644 --- a/src/qmmm_topology_util.F +++ b/src/qmmm_topology_util.F @@ -38,18 +38,16 @@ MODULE qmmm_topology_util !> \param topology ... !> \param qmmm_env ... !> \param subsys_section ... -!> \param error ... !> \par History !> 11.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_coordinate_control(topology, qmmm_env, subsys_section, error) + SUBROUTINE qmmm_coordinate_control(topology, qmmm_env, subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(qmmm_env_mm_type), POINTER :: qmmm_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_coordinate_control', & routineP = moduleN//':'//routineN @@ -62,17 +60,17 @@ SUBROUTINE qmmm_coordinate_control(topology, qmmm_env, subsys_section, error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") IF (iw>0) WRITE(iw,*) " Entering qmmm_coordinate_control" ! ! setting ilast and ifirst for QM molecule ! - CPPostcondition(SIZE(qmmm_env%qm_atom_index) /= 0,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(qmmm_env%qm_atom_index) /= 0,cp_failure_level,routineP,failure) qmmm_index_in_range=(MAXVAL(qmmm_env%qm_atom_index)<=SIZE(topology%atom_info%id_atmname)) & .AND.(MINVAL(qmmm_env%qm_atom_index)>0) - CPPostcondition(qmmm_index_in_range,cp_failure_level,routineP,error,failure) + CPPostcondition(qmmm_index_in_range,cp_failure_level,routineP,failure) DO iatm = 1, SIZE(qmmm_env%qm_atom_index) topology%atom_info%id_atmname(qmmm_env%qm_atom_index(iatm)) = str2id(s2s("_QM_"//& TRIM(id2str(topology%atom_info%id_atmname(qmmm_env%qm_atom_index(iatm)))))) @@ -96,7 +94,7 @@ SUBROUTINE qmmm_coordinate_control(topology, qmmm_env, subsys_section, error) ! IF (iw>0) WRITE(iw,*) " Exiting qmmm_coordinate_control" CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") CALL timestop(handle) END SUBROUTINE qmmm_coordinate_control @@ -105,19 +103,17 @@ END SUBROUTINE qmmm_coordinate_control !> \param molecule_set ... !> \param qmmm_env ... !> \param subsys_section ... -!> \param error ... !> \par History !> 12.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** SUBROUTINE qmmm_connectivity_control(molecule_set,& - qmmm_env, subsys_section, error) + qmmm_env, subsys_section) TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set TYPE(qmmm_env_mm_type), POINTER :: qmmm_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_connectivity_control', & routineP = moduleN//':'//routineN @@ -136,10 +132,10 @@ SUBROUTINE qmmm_connectivity_control(molecule_set,& NULLIFY(qm_atom_index, qm_molecule_index, molecule, molecule_kind) failure = .FALSE. detected_link = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) qm_mol_num = 0 qm_atom_index => qmmm_env%qm_atom_index @@ -153,7 +149,7 @@ SUBROUTINE qmmm_connectivity_control(molecule_set,& END DO ! ALLOCATE(qm_molecule_index(qm_mol_num), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qm_mol_num = 0 DO imolecule=1,SIZE(molecule_set) IF (iw>0) WRITE(iw,*)"Entering molecule number ::",imolecule @@ -180,7 +176,7 @@ SUBROUTINE qmmm_connectivity_control(molecule_set,& " no LINK section was provided in the Input file!",& " This very probably can be identified as an error in the specified QM",& " indexes or in a missing LINK section. Check your structure!" - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF qm_molecule_index(qm_mol_num) = imolecule @@ -191,7 +187,7 @@ SUBROUTINE qmmm_connectivity_control(molecule_set,& qmmm_env%qm_molecule_index => qm_molecule_index IF(iw>0) WRITE(iw,*) " QM molecule index ::",qm_molecule_index CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") CALL timestop(handle) END SUBROUTINE qmmm_connectivity_control diff --git a/src/qmmm_types.F b/src/qmmm_types.F index 9f775a2bec..27ed4b82ec 100644 --- a/src/qmmm_types.F +++ b/src/qmmm_types.F @@ -44,14 +44,12 @@ MODULE qmmm_types !> \param subsys ... !> \param potential_energy ... !> \param kinetic_energy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qmmm_env_get(qmmm_env,subsys,potential_energy,kinetic_energy,error) + SUBROUTINE qmmm_env_get(qmmm_env,subsys,potential_energy,kinetic_energy) TYPE(qmmm_env_type), POINTER :: qmmm_env TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys REAL(KIND=dp), INTENT(OUT), OPTIONAL :: potential_energy, & kinetic_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_get', & routineP = moduleN//':'//routineN @@ -63,21 +61,21 @@ SUBROUTINE qmmm_env_get(qmmm_env,subsys,potential_energy,kinetic_energy,error) failure=.FALSE. NULLIFY(qs_energy, thermo) - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(kinetic_energy)) THEN - CALL fist_env_get(qmmm_env%fist_env,thermo=thermo,error=error) + CALL fist_env_get(qmmm_env%fist_env,thermo=thermo) kinetic_energy = thermo%kin END IF IF (PRESENT(subsys)) THEN - CALL fist_env_get(qmmm_env%fist_env,subsys=subsys,error=error) + CALL fist_env_get(qmmm_env%fist_env,subsys=subsys) ENDIF IF (PRESENT(potential_energy)) THEN ! get the underlying energies from primary subsys. This is the only subsys ! for conventional QM/MM, and force-mixing knows to put relevant energy there. - CALL fist_env_get(qmmm_env%fist_env, thermo=thermo, error=error) - CALL get_qs_env(qmmm_env%qs_env,energy=qs_energy,error=error) + CALL fist_env_get(qmmm_env%fist_env, thermo=thermo) + CALL get_qs_env(qmmm_env%qs_env,energy=qs_energy) potential_energy = thermo%pot + qs_energy%total ENDIF END SUBROUTINE qmmm_env_get @@ -86,13 +84,10 @@ END SUBROUTINE qmmm_env_get ! ***************************************************************************** !> \brief releases the given qmmm_env (see doc/ReferenceCounting.html) !> \param qmmm_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qmmm_env_release(qmmm_env,error) + SUBROUTINE qmmm_env_release(qmmm_env) TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_release', & routineP = moduleN//':'//routineN @@ -102,12 +97,12 @@ SUBROUTINE qmmm_env_release(qmmm_env,error) failure=.FALSE. IF (ASSOCIATED(qmmm_env)) THEN - CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP) qmmm_env%ref_count=qmmm_env%ref_count-1 IF (qmmm_env%ref_count==0) THEN - CALL qs_env_release(qmmm_env%qs_env, error) - CALL fist_env_release(qmmm_env%fist_env, error) - CALL qmmm_env_qm_release(qmmm_env%qm, error) + CALL qs_env_release(qmmm_env%qs_env) + CALL fist_env_release(qmmm_env%fist_env) + CALL qmmm_env_qm_release(qmmm_env%qm) DEALLOCATE(qmmm_env) END IF END IF @@ -117,13 +112,10 @@ END SUBROUTINE qmmm_env_release ! ***************************************************************************** !> \brief ... !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qmmm_env_retain(qmmm_env,error) + SUBROUTINE qmmm_env_retain(qmmm_env) TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_retain', & routineP = moduleN//':'//routineN @@ -132,8 +124,8 @@ SUBROUTINE qmmm_env_retain(qmmm_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP) qmmm_env%ref_count=qmmm_env%ref_count+1 END SUBROUTINE qmmm_env_retain diff --git a/src/qmmm_types_low.F b/src/qmmm_types_low.F index 5bfdfcb7ea..f280494de6 100644 --- a/src/qmmm_types_low.F +++ b/src/qmmm_types_low.F @@ -232,13 +232,10 @@ MODULE qmmm_types_low ! ***************************************************************************** !> \brief ... !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_env_mm_create(qmmm_env, error) + SUBROUTINE qmmm_env_mm_create(qmmm_env) TYPE(qmmm_env_mm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_mm_create', & routineP = moduleN//':'//routineN @@ -247,9 +244,9 @@ SUBROUTINE qmmm_env_mm_create(qmmm_env, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) ALLOCATE(qmmm_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qmmm_env%ref_count=1 last_qmmm_env_id_nr=last_qmmm_env_id_nr+1 qmmm_env%id_nr=last_qmmm_env_id_nr @@ -263,20 +260,17 @@ SUBROUTINE qmmm_env_mm_create(qmmm_env, error) qmmm_env%qmmm_link = .FALSE. qmmm_env%use_qmmm_ff = .FALSE. ALLOCATE(qmmm_env%inp_info, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL init_inp_info(qmmm_env%inp_info) END SUBROUTINE qmmm_env_mm_create ! ***************************************************************************** !> \brief ... !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_env_mm_retain(qmmm_env,error) + SUBROUTINE qmmm_env_mm_retain(qmmm_env) TYPE(qmmm_env_mm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_mm_retain', & routineP = moduleN//':'//routineN @@ -285,22 +279,19 @@ SUBROUTINE qmmm_env_mm_retain(qmmm_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP) qmmm_env%ref_count=qmmm_env%ref_count+1 END SUBROUTINE qmmm_env_mm_retain ! ***************************************************************************** !> \brief releases the given qmmm_env (see doc/ReferenceCounting.html) !> \param qmmm_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed !> Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_env_mm_release(qmmm_env,error) + SUBROUTINE qmmm_env_mm_release(qmmm_env) TYPE(qmmm_env_mm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_mm_release', & routineP = moduleN//':'//routineN @@ -310,37 +301,37 @@ SUBROUTINE qmmm_env_mm_release(qmmm_env,error) failure=.FALSE. IF (ASSOCIATED(qmmm_env)) THEN - CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP) qmmm_env%ref_count=qmmm_env%ref_count-1 IF (qmmm_env%ref_count==0) THEN IF (ASSOCIATED(qmmm_env%qm_atom_index)) THEN DEALLOCATE(qmmm_env%qm_atom_index,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%qm_molecule_index)) THEN DEALLOCATE(qmmm_env%qm_molecule_index,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%mm_link_atoms)) THEN DEALLOCATE(qmmm_env%mm_link_atoms,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%mm_link_scale_factor)) THEN DEALLOCATE(qmmm_env%mm_link_scale_factor,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%fist_scale_charge_link)) THEN DEALLOCATE(qmmm_env%fist_scale_charge_link,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%inp_info)) THEN - CALL deallocate_inp_info(qmmm_env%inp_info,error) + CALL deallocate_inp_info(qmmm_env%inp_info) DEALLOCATE(qmmm_env%inp_info,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF DEALLOCATE(qmmm_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF END IF NULLIFY(qmmm_env) @@ -349,13 +340,10 @@ END SUBROUTINE qmmm_env_mm_release ! ***************************************************************************** !> \brief ... !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qmmm_env_qm_create(qmmm_env, error) + SUBROUTINE qmmm_env_qm_create(qmmm_env) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_qm_create', & routineP = moduleN//':'//routineN @@ -364,9 +352,9 @@ SUBROUTINE qmmm_env_qm_create(qmmm_env, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) ALLOCATE(qmmm_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qmmm_env%ref_count=1 last_qmmm_env_id_nr=last_qmmm_env_id_nr+1 qmmm_env%id_nr=last_qmmm_env_id_nr @@ -395,20 +383,17 @@ SUBROUTINE qmmm_env_qm_create(qmmm_env, error) qmmm_env%num_image_mm_atoms=0 qmmm_env%gridlevel_info%auxbas_grid = 0 qmmm_env%gridlevel_info%coarser_grid = 0 - CALL create_add_set_type(qmmm_env%added_charges, ndim=0, error=error) - CALL create_image_charge_type(qmmm_env%image_charge_pot,error=error) + CALL create_add_set_type(qmmm_env%added_charges, ndim=0) + CALL create_image_charge_type(qmmm_env%image_charge_pot) END SUBROUTINE qmmm_env_qm_create ! ***************************************************************************** !> \brief retains the qmmm_env !> \param qmmm_env the qmmm_env to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qmmm_env_qm_retain(qmmm_env,error) + SUBROUTINE qmmm_env_qm_retain(qmmm_env) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_qm_retain', & routineP = moduleN//':'//routineN @@ -417,22 +402,19 @@ SUBROUTINE qmmm_env_qm_retain(qmmm_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP) qmmm_env%ref_count=qmmm_env%ref_count+1 END SUBROUTINE qmmm_env_qm_retain ! ***************************************************************************** !> \brief releases the given qmmm_env (see doc/ReferenceCounting.html) !> \param qmmm_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed !> Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_env_qm_release(qmmm_env,error) + SUBROUTINE qmmm_env_qm_release(qmmm_env) TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_env_qm_release', & routineP = moduleN//':'//routineN @@ -442,72 +424,72 @@ SUBROUTINE qmmm_env_qm_release(qmmm_env,error) failure=.FALSE. IF (ASSOCIATED(qmmm_env)) THEN - CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(qmmm_env%ref_count>0,cp_failure_level,routineP) qmmm_env%ref_count=qmmm_env%ref_count-1 IF (qmmm_env%ref_count==0) THEN IF (ASSOCIATED(qmmm_env%qm_atom_index)) THEN DEALLOCATE(qmmm_env%qm_atom_index,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%maxradius)) THEN DEALLOCATE(qmmm_env%maxradius,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%mm_atom_index)) THEN DEALLOCATE(qmmm_env%mm_atom_index,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%mm_link_atoms)) THEN DEALLOCATE(qmmm_env%mm_link_atoms,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%mm_atom_chrg)) THEN DEALLOCATE(qmmm_env%mm_atom_chrg,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%mm_el_pot_radius)) THEN DEALLOCATE(qmmm_env%mm_el_pot_radius,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%mm_el_pot_radius_corr)) THEN DEALLOCATE(qmmm_env%mm_el_pot_radius_corr,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%pgfs)) THEN - CALL pgfs_release(qmmm_env%pgfs, error) + CALL pgfs_release(qmmm_env%pgfs) DEALLOCATE(qmmm_env%pgfs,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%Potentials)) THEN - CALL qmmm_pot_type_dealloc(qmmm_env%Potentials,error=error) + CALL qmmm_pot_type_dealloc(qmmm_env%Potentials) DEALLOCATE(qmmm_env%Potentials,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%Per_Potentials)) THEN - CALL qmmm_per_pot_type_dealloc(qmmm_env%Per_Potentials,error=error) + CALL qmmm_per_pot_type_dealloc(qmmm_env%Per_Potentials) DEALLOCATE(qmmm_env%Per_Potentials,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_env%aug_pools)) THEN - CALL pw_pools_dealloc(qmmm_env%aug_pools,error=error) + CALL pw_pools_dealloc(qmmm_env%aug_pools) END IF IF (ASSOCIATED(qmmm_env%qmmm_links)) THEN - CALL qmmm_links_dealloc(qmmm_env%qmmm_links, error=error) + CALL qmmm_links_dealloc(qmmm_env%qmmm_links) END IF IF (ASSOCIATED(qmmm_env%added_charges)) THEN - CALL add_set_release(qmmm_env%added_charges, error=error) + CALL add_set_release(qmmm_env%added_charges) END IF IF (ASSOCIATED(qmmm_env%image_charge_pot)) THEN - CALL qmmm_image_charge_dealloc(qmmm_env%image_charge_pot,error=error) + CALL qmmm_image_charge_dealloc(qmmm_env%image_charge_pot) END IF IF (ASSOCIATED(qmmm_env%ewald_env)) THEN - CALL ewald_env_release(qmmm_env%ewald_env,error=error) + CALL ewald_env_release(qmmm_env%ewald_env) END IF IF (ASSOCIATED(qmmm_env%ewald_pw)) THEN - CALL ewald_pw_release(qmmm_env%ewald_pw,error=error) + CALL ewald_pw_release(qmmm_env%ewald_pw) END IF DEALLOCATE(qmmm_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF END IF NULLIFY(qmmm_env) @@ -516,14 +498,11 @@ END SUBROUTINE qmmm_env_qm_release ! ***************************************************************************** !> \brief deallocates the pgfs type !> \param pgfs ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE pgfs_release(pgfs, error) + SUBROUTINE pgfs_release(pgfs) TYPE(qmmm_gaussian_p_type), & DIMENSION(:), POINTER :: pgfs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pgfs_release', & routineP = moduleN//':'//routineN @@ -536,18 +515,18 @@ SUBROUTINE pgfs_release(pgfs, error) IF (ASSOCIATED(pgfs(I)%pgf)) THEN IF (ASSOCIATED(pgfs(I)%pgf%Ak)) THEN DEALLOCATE(pgfs(I)%pgf%Ak,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END IF IF (ASSOCIATED(pgfs(I)%pgf%Gk)) THEN DEALLOCATE(pgfs(I)%pgf%Gk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END IF IF (ASSOCIATED(pgfs(I)%pgf%grid_level)) THEN DEALLOCATE(pgfs(I)%pgf%grid_level,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END IF DEALLOCATE(pgfs(I)%pgf,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END IF END DO END SUBROUTINE pgfs_release @@ -555,13 +534,10 @@ END SUBROUTINE pgfs_release ! ***************************************************************************** !> \brief deallocates the qmmm_links structure !> \param qmmm_links ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_links_dealloc(qmmm_links, error) + SUBROUTINE qmmm_links_dealloc(qmmm_links) TYPE(qmmm_links_type), POINTER :: qmmm_links - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_links_dealloc', & routineP = moduleN//':'//routineN @@ -571,33 +547,30 @@ SUBROUTINE qmmm_links_dealloc(qmmm_links, error) IF (ASSOCIATED(qmmm_links%imomm)) THEN DO i = 1, SIZE(qmmm_links%imomm) IF (ASSOCIATED(qmmm_links%imomm(i)%link)) DEALLOCATE(qmmm_links%imomm(i)%link, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END DO DEALLOCATE(qmmm_links%imomm, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(qmmm_links%pseudo)) THEN DO i = 1, SIZE(qmmm_links%pseudo) IF (ASSOCIATED(qmmm_links%pseudo(i)%link)) DEALLOCATE(qmmm_links%pseudo(i)%link, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END DO DEALLOCATE(qmmm_links%pseudo, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF DEALLOCATE(qmmm_links, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END SUBROUTINE qmmm_links_dealloc ! **************************************************************************** !> \brief deallocates the image_charge_pot structure !> \param image_charge_pot ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE qmmm_image_charge_dealloc(image_charge_pot, error) + SUBROUTINE qmmm_image_charge_dealloc(image_charge_pot) TYPE(image_charge_type), POINTER :: image_charge_pot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_image_charge_dealloc', & routineP = moduleN//':'//routineN @@ -608,15 +581,15 @@ SUBROUTINE qmmm_image_charge_dealloc(image_charge_pot, error) IF (ASSOCIATED(image_charge_pot%image_mm_list)) THEN IF(.NOT.image_charge_pot%all_mm) THEN DEALLOCATE(image_charge_pot%image_mm_list, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF END IF IF (ASSOCIATED(image_charge_pot%image_forcesMM)) THEN DEALLOCATE(image_charge_pot%image_forcesMM, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF DEALLOCATE(image_charge_pot, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF END SUBROUTINE qmmm_image_charge_dealloc @@ -624,14 +597,11 @@ END SUBROUTINE qmmm_image_charge_dealloc ! ***************************************************************************** !> \brief deallocates the qmmm_pot_type structure !> \param Potentials ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_pot_type_dealloc(Potentials, error) + SUBROUTINE qmmm_pot_type_dealloc(Potentials) TYPE(qmmm_pot_p_type), DIMENSION(:), & POINTER :: Potentials - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_pot_type_dealloc', & routineP = moduleN//':'//routineN @@ -642,14 +612,14 @@ SUBROUTINE qmmm_pot_type_dealloc(Potentials, error) IF (ASSOCIATED(Potentials(I)%Pot)) THEN IF (ASSOCIATED(Potentials(I)%Pot%pot0_2)) THEN DEALLOCATE(Potentials(I)%Pot%pot0_2,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(Potentials(I)%Pot%mm_atom_index)) THEN DEALLOCATE(Potentials(I)%Pot%mm_atom_index,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF DEALLOCATE(Potentials(I)%Pot,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF END DO @@ -659,14 +629,11 @@ END SUBROUTINE qmmm_pot_type_dealloc !> \brief deallocates the qmmm_per_pot_type structure !> for QM/MM periodic boundary conditions !> \param Per_Potentials ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_per_pot_type_dealloc(Per_Potentials, error) + SUBROUTINE qmmm_per_pot_type_dealloc(Per_Potentials) TYPE(qmmm_per_pot_p_type), & DIMENSION(:), POINTER :: Per_Potentials - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_per_pot_type_dealloc', & routineP = moduleN//':'//routineN @@ -677,37 +644,37 @@ SUBROUTINE qmmm_per_pot_type_dealloc(Per_Potentials, error) IF (ASSOCIATED(Per_Potentials(I)%Pot)) THEN IF (ASSOCIATED(Per_Potentials(I)%Pot%LG)) THEN DEALLOCATE(Per_Potentials(I)%Pot%LG,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(Per_Potentials(I)%Pot%gx)) THEN DEALLOCATE(Per_Potentials(I)%Pot%gx,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(Per_Potentials(I)%Pot%gy)) THEN DEALLOCATE(Per_Potentials(I)%Pot%gy,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(Per_Potentials(I)%Pot%gz)) THEN DEALLOCATE(Per_Potentials(I)%Pot%gz,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(Per_Potentials(I)%Pot%mm_atom_index)) THEN DEALLOCATE(Per_Potentials(I)%Pot%mm_atom_index,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(Per_Potentials(I)%Pot%TabLR)) THEN - CALL pw_pool_give_back_pw ( Per_Potentials(I)%Pot%pw_pool, Per_Potentials(I)%Pot%TabLR,error=error) + CALL pw_pool_give_back_pw ( Per_Potentials(I)%Pot%pw_pool, Per_Potentials(I)%Pot%TabLR) END IF IF (ASSOCIATED(Per_Potentials(I)%Pot%pw_pool)) THEN - CALL pw_pool_release ( Per_Potentials(I)%Pot%pw_pool, error=error) - CPPostconditionNoFail(.NOT.ASSOCIATED(Per_Potentials(I)%Pot%pw_pool),cp_failure_level,routineP,error) + CALL pw_pool_release ( Per_Potentials(I)%Pot%pw_pool) + CPPostconditionNoFail(.NOT.ASSOCIATED(Per_Potentials(I)%Pot%pw_pool),cp_failure_level,routineP) END IF IF (ASSOCIATED(Per_Potentials(I)%Pot%pw_grid)) THEN - CALL pw_grid_release ( Per_Potentials(I)%Pot%pw_grid, error=error) - CPPostconditionNoFail(.NOT.ASSOCIATED(Per_Potentials(I)%Pot%pw_grid),cp_failure_level,routineP,error) + CALL pw_grid_release ( Per_Potentials(I)%Pot%pw_grid) + CPPostconditionNoFail(.NOT.ASSOCIATED(Per_Potentials(I)%Pot%pw_grid),cp_failure_level,routineP) END IF DEALLOCATE(Per_Potentials(I)%Pot,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF END DO @@ -716,13 +683,10 @@ END SUBROUTINE qmmm_per_pot_type_dealloc ! ***************************************************************************** !> \brief deallocates the add_set_release !> \param added_charges ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE add_set_release(added_charges, error) + SUBROUTINE add_set_release(added_charges) TYPE(add_set_type), POINTER :: added_charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_set_release', & routineP = moduleN//':'//routineN @@ -732,44 +696,44 @@ SUBROUTINE add_set_release(added_charges, error) IF (ASSOCIATED(added_charges)) THEN IF (ASSOCIATED(added_charges%add_env)) THEN DEALLOCATE(added_charges%add_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(added_charges%added_particles)) THEN - CALL deallocate_particle_set(added_charges%added_particles,error) + CALL deallocate_particle_set(added_charges%added_particles) END IF IF (ASSOCIATED(added_charges%mm_atom_index)) THEN DEALLOCATE(added_charges%mm_atom_index, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(added_charges%mm_atom_chrg)) THEN DEALLOCATE(added_charges%mm_atom_chrg, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(added_charges%mm_el_pot_radius)) THEN DEALLOCATE(added_charges%mm_el_pot_radius, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(added_charges%mm_el_pot_radius_corr)) THEN DEALLOCATE(added_charges%mm_el_pot_radius_corr, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(added_charges%Potentials)) THEN - CALL qmmm_pot_type_dealloc(added_charges%Potentials, error) + CALL qmmm_pot_type_dealloc(added_charges%Potentials) DEALLOCATE(added_charges%Potentials,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(added_charges%Per_Potentials)) THEN - CALL qmmm_per_pot_type_dealloc(added_charges%Per_Potentials, error) + CALL qmmm_per_pot_type_dealloc(added_charges%Per_Potentials) DEALLOCATE(added_charges%Per_Potentials,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF IF (ASSOCIATED(added_charges%pgfs)) THEN - CALL pgfs_release(added_charges%pgfs, error) + CALL pgfs_release(added_charges%pgfs) DEALLOCATE(added_charges%pgfs,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF DEALLOCATE(added_charges, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) END IF END SUBROUTINE add_set_release @@ -777,14 +741,11 @@ END SUBROUTINE add_set_release !> \brief creates the add_set_type structure !> \param added_charges ... !> \param ndim ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE create_add_set_type(added_charges, ndim, error) + SUBROUTINE create_add_set_type(added_charges, ndim) TYPE(add_set_type), POINTER :: added_charges INTEGER, INTENT(IN) :: ndim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_add_set_type', & routineP = moduleN//':'//routineN @@ -793,9 +754,9 @@ SUBROUTINE create_add_set_type(added_charges, ndim, error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(added_charges)) CALL add_set_release(added_charges, error) + IF (ASSOCIATED(added_charges)) CALL add_set_release(added_charges) ALLOCATE(added_charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) NULLIFY(added_charges%add_env,& added_charges%mm_atom_index,& @@ -813,28 +774,25 @@ SUBROUTINE create_add_set_type(added_charges, ndim, error) ! Allocate leave out just potential and pgfs... ! ALLOCATE(added_charges%add_env(ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) - CALL allocate_particle_set(added_charges%added_particles,ndim,error) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) + CALL allocate_particle_set(added_charges%added_particles,ndim) ALLOCATE(added_charges%mm_atom_index(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(added_charges%mm_atom_chrg(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(added_charges%mm_el_pot_radius(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(added_charges%mm_el_pot_radius_corr(ndim), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) END SUBROUTINE create_add_set_type ! ***************************************************************************** !> \brief creates the image_charge_type structure !> \param image_charge_pot ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE create_image_charge_type(image_charge_pot,error) + SUBROUTINE create_image_charge_type(image_charge_pot) TYPE(image_charge_type), POINTER :: image_charge_pot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_image_charge_type', & routineP = moduleN//':'//routineN @@ -843,9 +801,9 @@ SUBROUTINE create_image_charge_type(image_charge_pot,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(image_charge_pot)) CALL qmmm_image_charge_dealloc(image_charge_pot, error) + IF (ASSOCIATED(image_charge_pot)) CALL qmmm_image_charge_dealloc(image_charge_pot) ALLOCATE(image_charge_pot, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) NULLIFY(image_charge_pot%image_mm_list,& image_charge_pot%particles_all,& diff --git a/src/qmmm_util.F b/src/qmmm_util.F index be2bb3b9fb..6329f3ee46 100644 --- a/src/qmmm_util.F +++ b/src/qmmm_util.F @@ -52,15 +52,12 @@ MODULE qmmm_util !> \brief Apply QM quadratic walls in order to avoid QM atoms escaping from !> the QM Box !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2008 created !> \author Benjamin G Levine ! ***************************************************************************** - SUBROUTINE apply_qmmm_walls(qmmm_env, error) + SUBROUTINE apply_qmmm_walls(qmmm_env) TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_qmmm_walls', & routineP = moduleN//':'//routineN @@ -71,12 +68,12 @@ SUBROUTINE apply_qmmm_walls(qmmm_env, error) TYPE(section_vals_type), POINTER :: qmmmx_section, walls_section failure = .FALSE. - walls_section => section_vals_get_subs_vals(qmmm_env%qs_env%input,"QMMM%WALLS",error=error) - qmmmx_section => section_vals_get_subs_vals(qmmm_env%qs_env%input,"QMMM%FORCE_MIXING",error=error) - CALL section_vals_get(qmmmx_section,explicit=do_qmmm_force_mixing,error=error) - CALL section_vals_get(walls_section, explicit=explicit, error=error) + walls_section => section_vals_get_subs_vals(qmmm_env%qs_env%input,"QMMM%WALLS") + qmmmx_section => section_vals_get_subs_vals(qmmm_env%qs_env%input,"QMMM%FORCE_MIXING") + CALL section_vals_get(qmmmx_section,explicit=do_qmmm_force_mixing) + CALL section_vals_get(walls_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(walls_section,"TYPE",i_val=iwall_type,error=error) + CALL section_vals_val_get(walls_section,"TYPE",i_val=iwall_type) SELECT CASE(iwall_type) CASE(do_qmmm_wall_quadratic) IF(do_qmmm_force_mixing) THEN @@ -84,7 +81,7 @@ SUBROUTINE apply_qmmm_walls(qmmm_env, error) "Quadratic walls for QM/MM are not implemented (or useful), when "//& "force mixing is active. Skipping!"//CPSourceFileRef) ELSE - CALL apply_qmmm_walls_quadratic(qmmm_env, walls_section, error) + CALL apply_qmmm_walls_quadratic(qmmm_env, walls_section) ENDIF CASE(do_qmmm_wall_reflective) ! Do nothing.. reflective walls are applied directly in the integrator @@ -97,15 +94,12 @@ END SUBROUTINE apply_qmmm_walls !> \brief Apply reflective QM walls in order to avoid QM atoms escaping from !> the QM Box !> \param force_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2007 created [tlaino] - Zurich University !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE apply_qmmm_walls_reflective(force_env, error) + SUBROUTINE apply_qmmm_walls_reflective(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_qmmm_walls_reflective', & routineP = moduleN//':'//routineN @@ -128,12 +122,12 @@ SUBROUTINE apply_qmmm_walls_reflective(force_env, error) IF(force_env%in_use/=use_qmmm .AND. force_env%in_use/=use_qmmmx) RETURN - walls_section => section_vals_get_subs_vals(force_env%root_section,"FORCE_EVAL%QMMM%WALLS",error=error) - CALL section_vals_get(walls_section, explicit=explicit, error=error) + walls_section => section_vals_get_subs_vals(force_env%root_section,"FORCE_EVAL%QMMM%WALLS") + CALL section_vals_get(walls_section, explicit=explicit) IF (explicit) THEN NULLIFY(list) - CALL section_vals_val_get(walls_section,"WALL_SKIN",r_vals=list,error=error) - CALL section_vals_val_get(walls_section,"TYPE",i_val=iwall_type,error=error) + CALL section_vals_val_get(walls_section,"WALL_SKIN",r_vals=list) + CALL section_vals_val_get(walls_section,"TYPE",i_val=iwall_type) skin(:) = list(:) ELSE ![NB] @@ -151,13 +145,13 @@ SUBROUTINE apply_qmmm_walls_reflective(force_env, error) ! from here on we can be sure that it's conventional QM/MM - CPPrecondition(ASSOCIATED(force_env%qmmm_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%qmmm_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env%qmmm_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%qmmm_env%ref_count>0,cp_failure_level,routineP,failure) - CALL fist_env_get(force_env%qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm,error=error) - CALL get_qs_env(force_env%qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm,error=error) + CALL fist_env_get(force_env%qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm) + CALL get_qs_env(force_env%qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm) qm_atom_index => force_env%qmmm_env%qm%qm_atom_index - CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,failure) qm_cell_diag = (/qm_cell%hmat(1,1),& qm_cell%hmat(2,2),& @@ -221,16 +215,13 @@ END SUBROUTINE apply_qmmm_walls_reflective !> the QM Box !> \param qmmm_env ... !> \param walls_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2008 created !> \author Benjamin G Levine ! ***************************************************************************** - SUBROUTINE apply_qmmm_walls_quadratic(qmmm_env, walls_section, error) + SUBROUTINE apply_qmmm_walls_quadratic(qmmm_env, walls_section) TYPE(qmmm_env_type), POINTER :: qmmm_env TYPE(section_vals_type), POINTER :: walls_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_qmmm_walls_quadratic', & routineP = moduleN//':'//routineN @@ -249,16 +240,16 @@ SUBROUTINE apply_qmmm_walls_quadratic(qmmm_env, walls_section, error) TYPE(qs_energy_type), POINTER :: energy NULLIFY(list) - CALL section_vals_val_get(walls_section,"WALL_SKIN",r_vals=list,error=error) - CALL section_vals_val_get(walls_section,"K",r_val=k,error=error) - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(walls_section,"WALL_SKIN",r_vals=list) + CALL section_vals_val_get(walls_section,"K",r_val=k) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,failure) - CALL fist_env_get(qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm,error=error) - CALL get_qs_env(qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm,error=error) + CALL fist_env_get(qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm) + CALL get_qs_env(qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm) qm_atom_index => qmmm_env%qm%qm_atom_index - CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,failure) skin(:) = list(:) @@ -319,7 +310,7 @@ SUBROUTINE apply_qmmm_walls_quadratic(qmmm_env, walls_section, error) ENDIF ENDDO - CALL get_qs_env(qs_env=qmmm_env%qs_env, energy=energy,error=error) + CALL get_qs_env(qs_env=qmmm_env%qs_env, energy=energy) energy%total = energy%total + wallenergy END SUBROUTINE apply_qmmm_walls_quadratic @@ -332,15 +323,13 @@ END SUBROUTINE apply_qmmm_walls_quadratic !> \param subsys_qm ... !> \param qm_atom_index ... !> \param saved_pos ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_qmmm_wrap(subsys_mm, mm_cell, subsys_qm, qm_atom_index, saved_pos, error) + SUBROUTINE apply_qmmm_wrap(subsys_mm, mm_cell, subsys_qm, qm_atom_index, saved_pos) TYPE(cp_subsys_type), POINTER :: subsys_mm TYPE(cell_type), POINTER :: mm_cell TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys_qm INTEGER, DIMENSION(:), OPTIONAL, POINTER :: qm_atom_index REAL(dp), ALLOCATABLE :: saved_pos(:,:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_qmmm_wrap', & routineP = moduleN//':'//routineN @@ -374,14 +363,12 @@ END SUBROUTINE apply_qmmm_wrap !> \param subsys_qm ... !> \param qm_atom_index ... !> \param saved_pos ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_qmmm_unwrap(subsys_mm, subsys_qm, qm_atom_index, saved_pos, error) + SUBROUTINE apply_qmmm_unwrap(subsys_mm, subsys_qm, qm_atom_index, saved_pos) TYPE(cp_subsys_type), POINTER :: subsys_mm TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys_qm INTEGER, DIMENSION(:), OPTIONAL, POINTER :: qm_atom_index REAL(dp), ALLOCATABLE :: saved_pos(:,:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_qmmm_unwrap', & routineP = moduleN//':'//routineN @@ -406,15 +393,12 @@ END SUBROUTINE apply_qmmm_unwrap !> \brief Apply translation to the full system in order to center the QM !> system into the QM box !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2007 created [tlaino] - Zurich University !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE apply_qmmm_translate(qmmm_env,error) + SUBROUTINE apply_qmmm_translate(qmmm_env) TYPE(qmmm_env_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_qmmm_translate', & routineP = moduleN//':'//routineN @@ -439,17 +423,17 @@ SUBROUTINE apply_qmmm_translate(qmmm_env,error) TYPE(section_vals_type), POINTER :: subsys_section failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(subsys_mm, subsys_qm, qm_atom_index, particles_mm, particles_qm,& subsys_section, qm_cell, mm_cell, qs_kind_set) - CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qmmm_env),cp_failure_level,routineP,failure) + CPPrecondition(qmmm_env%ref_count>0,cp_failure_level,routineP,failure) - CALL fist_env_get(qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm,error=error) - CALL get_qs_env(qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm,error=error) + CALL fist_env_get(qmmm_env%fist_env,cell=mm_cell,subsys=subsys_mm) + CALL get_qs_env(qmmm_env%qs_env,cell=qm_cell,cp_subsys=subsys_qm) qm_atom_index => qmmm_env%qm%qm_atom_index - CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qm_atom_index),cp_failure_level,routineP,failure) particles_qm => subsys_qm%particles%els particles_mm => subsys_mm%particles%els @@ -548,13 +532,13 @@ SUBROUTINE apply_qmmm_translate(qmmm_env,error) particles_qm(ip)%r=particles_mm(qm_atom_index(ip))%r END DO - subsys_section => section_vals_get_subs_vals(qmmm_env%qs_env%input, "SUBSYS",error=error) + subsys_section => section_vals_get_subs_vals(qmmm_env%qs_env%input, "SUBSYS") - CALL get_qs_env(qs_env=qmmm_env%qs_env,qs_kind_set=qs_kind_set,error=error) - CALL write_qs_particle_coordinates(particles_qm,qs_kind_set,subsys_section,"QM/MM first QM, then MM (0 charges)",error) + CALL get_qs_env(qs_env=qmmm_env%qs_env,qs_kind_set=qs_kind_set) + CALL write_qs_particle_coordinates(particles_qm,qs_kind_set,subsys_section,"QM/MM first QM, then MM (0 charges)") ALLOCATE(charges(SIZE(particles_mm))) charges = 0.0_dp - CALL write_fist_particle_coordinates(particles_mm,subsys_section,charges,error) + CALL write_fist_particle_coordinates(particles_mm,subsys_section,charges) DEALLOCATE(charges) @@ -664,17 +648,14 @@ END FUNCTION qmmm_find_closest !> \param spherical_cutoff ... !> \param rij ... !> \param factor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2008 created !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE spherical_cutoff_factor(spherical_cutoff, rij, factor, error) + SUBROUTINE spherical_cutoff_factor(spherical_cutoff, rij, factor) REAL(KIND=dp), DIMENSION(2), INTENT(IN) :: spherical_cutoff REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij REAL(KIND=dp), INTENT(OUT) :: factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spherical_cutoff_factor', & routineP = moduleN//':'//routineN @@ -690,12 +671,10 @@ END SUBROUTINE spherical_cutoff_factor ! ***************************************************************************** !> \brief ... !> \param force_env ... -!> \param error ... !> \retval active ... ! ***************************************************************************** - RECURSIVE FUNCTION qmmm_force_mixing_active(force_env, error) RESULT(active) + RECURSIVE FUNCTION qmmm_force_mixing_active(force_env) RESULT(active) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: active INTEGER :: iforce_eval, nforce_eval @@ -703,9 +682,9 @@ RECURSIVE FUNCTION qmmm_force_mixing_active(force_env, error) RESULT(active) active = .FALSE. qmmm_force_mixing_section => section_vals_get_subs_vals(force_env%force_env_section,"QMMM%FORCE_MIXING",& - can_return_null=.TRUE.,error=error) + can_return_null=.TRUE.) IF (ASSOCIATED(qmmm_force_mixing_section)) CALL section_vals_get(qmmm_force_mixing_section,& - explicit=active,error=error) + explicit=active) IF (active) RETURN @@ -715,7 +694,7 @@ RECURSIVE FUNCTION qmmm_force_mixing_active(force_env, error) RESULT(active) ! if the current force env is QMMM, then any sub force envs are dups ! of it generated by FORCE_MIXING, so explicitly avoid recursing into those IF (force_env%in_use /= use_qmmm) THEN - active = qmmm_force_mixing_active(force_env%sub_force_env(iforce_eval)%force_env, error) + active = qmmm_force_mixing_active(force_env%sub_force_env(iforce_eval)%force_env) IF (active) RETURN ENDIF END DO diff --git a/src/qmmmx_create.F b/src/qmmmx_create.F index fcfe4a87ad..08557a2859 100644 --- a/src/qmmmx_create.F +++ b/src/qmmmx_create.F @@ -42,14 +42,12 @@ MODULE qmmmx_create !> \param force_env_section ... !> \param subsys_section ... !> \param use_motion_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2012 created [noam] !> \author Noam Bernstein ! ***************************************************************************** SUBROUTINE qmmmx_env_create(qmmmx_env, root_section, para_env, globenv,& - force_env_section, subsys_section, use_motion_section, error) + force_env_section, subsys_section, use_motion_section) TYPE(qmmmx_env_type), POINTER :: qmmmx_env TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env @@ -57,7 +55,6 @@ SUBROUTINE qmmmx_env_create(qmmmx_env, root_section, para_env, globenv,& TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section LOGICAL, INTENT(IN) :: use_motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmmx_env_create', & routineP = moduleN//':'//routineN @@ -70,31 +67,31 @@ SUBROUTINE qmmmx_env_create(qmmmx_env, root_section, para_env, globenv,& NULLIFY(dummy_qmmm_env) - qmmm_section => section_vals_get_subs_vals(force_env_section,"QMMM",error=error) + qmmm_section => section_vals_get_subs_vals(force_env_section,"QMMM") CALL qmmm_env_create(dummy_qmmm_env, root_section, para_env, globenv,& force_env_section, qmmm_section, subsys_section, use_motion_section, & - ignore_outside_box = .TRUE., error=error) - CALL qmmm_env_get(dummy_qmmm_env, subsys=subsys, error=error) + ignore_outside_box = .TRUE.) + CALL qmmm_env_get(dummy_qmmm_env, subsys=subsys) - CALL update_force_mixing_labels(subsys, qmmm_section, error=error) + CALL update_force_mixing_labels(subsys, qmmm_section) ! using CUR_INDICES and CUR_LABELS, create appropriate QM_KIND sections for two QM/MM calculations - CALL setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_section, qmmm_extended_section, error=error) + CALL setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_section, qmmm_extended_section) ALLOCATE(qmmmx_env) CALL qmmm_env_create(qmmmx_env%core, root_section, para_env, globenv,& force_env_section, qmmm_core_section, subsys_section, use_motion_section, & - ignore_outside_box = .TRUE., error=error) + ignore_outside_box = .TRUE.) CALL qmmm_env_create(qmmmx_env%ext, root_section, para_env, globenv,& force_env_section, qmmm_extended_section, subsys_section, use_motion_section, & - ignore_outside_box = .TRUE., error=error) + ignore_outside_box = .TRUE.) - CALL section_vals_release(qmmm_core_section, error=error) - CALL section_vals_release(qmmm_extended_section, error=error) - CALL qmmm_env_release(dummy_qmmm_env,error=error) + CALL section_vals_release(qmmm_core_section) + CALL section_vals_release(qmmm_extended_section) + CALL qmmm_env_release(dummy_qmmm_env) END SUBROUTINE qmmmx_env_create diff --git a/src/qmmmx_force.F b/src/qmmmx_force.F index e8f5b0d035..a0a1596a17 100644 --- a/src/qmmmx_force.F +++ b/src/qmmmx_force.F @@ -55,19 +55,16 @@ MODULE qmmmx_force !> \param consistent_energies ... !> \param linres ... !> \param require_consistent_energy_force ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE qmmmx_calc_energy_force(qmmmx_env,calc_force,consistent_energies,linres,& - require_consistent_energy_force,error) + require_consistent_energy_force) TYPE(qmmmx_env_type), POINTER :: qmmmx_env LOGICAL, INTENT(IN) :: calc_force, & consistent_energies, linres LOGICAL, INTENT(IN), OPTIONAL :: require_consistent_energy_force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmmx_calc_energy_force', & routineP = moduleN//':'//routineN @@ -93,23 +90,23 @@ SUBROUTINE qmmmx_calc_energy_force(qmmmx_env,calc_force,consistent_energies,linr CALL cp_assert(.NOT.require_consistent_energy_force,& cp_failure_level,cp_assertion_failed,routineP,& "qmmmx_energy_and_forces got require_consistent_energy_force but force mixing is active. "//& - CPSourceFileRef,error,failure) + CPSourceFileRef,failure) ENDIF ! Possibly translate the system - CALL apply_qmmmx_translate(qmmmx_env, error) + CALL apply_qmmmx_translate(qmmmx_env) ! actual energy force calculation - CALL qmmmx_calc_energy_force_low(qmmmx_env%ext, calc_force, consistent_energies, linres, "ext", error=error) - CALL qmmmx_calc_energy_force_low(qmmmx_env%core, calc_force, consistent_energies, linres, "core", error=error) + CALL qmmmx_calc_energy_force_low(qmmmx_env%ext, calc_force, consistent_energies, linres, "ext") + CALL qmmmx_calc_energy_force_low(qmmmx_env%core, calc_force, consistent_energies, linres, "core") ! get forces from subsys of each sub force env - CALL qmmm_env_get(qmmmx_env%core, subsys=subsys_qmmm_core, error=error) - CALL qmmm_env_get(qmmmx_env%ext, subsys=subsys_qmmm_extended, error=error) + CALL qmmm_env_get(qmmmx_env%core, subsys=subsys_qmmm_core) + CALL qmmm_env_get(qmmmx_env%ext, subsys=subsys_qmmm_extended) - CALL get_qs_env(qmmmx_env%ext%qs_env, input=force_env_section, error=error) - CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%INDICES",i_vals=cur_indices,error=error) - CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%LABELS",i_vals=cur_labels,error=error) + CALL get_qs_env(qmmmx_env%ext%qs_env, input=force_env_section) + CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%INDICES",i_vals=cur_indices) + CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%RESTART_INFO%LABELS",i_vals=cur_labels) particles_qmmm_extended => subsys_qmmm_extended%particles%els particles_qmmm_core => subsys_qmmm_core%particles%els @@ -122,10 +119,10 @@ SUBROUTINE qmmmx_calc_energy_force(qmmmx_env,calc_force,consistent_energies,linr ! zero momentum CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%MOMENTUM_CONSERVATION_TYPE",& - i_val=mom_conserv_type,error=error) + i_val=mom_conserv_type) IF (mom_conserv_type /= do_fm_mom_conserv_none) THEN CALL section_vals_val_get(force_env_section,"QMMM%FORCE_MIXING%MOMENTUM_CONSERVATION_REGION",& - i_val=mom_conserv_region,error=error) + i_val=mom_conserv_region) IF (mom_conserv_region == do_fm_mom_conserv_core) THEN mom_conserv_min_label = force_mixing_label_QM_core @@ -137,7 +134,7 @@ SUBROUTINE qmmmx_calc_energy_force(qmmmx_env,calc_force,consistent_energies,linr CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Got unknown MOMENTUM_CONSERVATION_REGION (not CORE, QM, or BUFFER) !"//& CPSourceFileRef,& - error,failure) + failure) ENDIF total_f = 0.0_dp @@ -168,7 +165,7 @@ SUBROUTINE qmmmx_calc_energy_force(qmmmx_env,calc_force,consistent_energies,linr ENDIF ENDIF - CALL qmmm_env_get(qmmmx_env%ext, subsys=subsys_primary, error=error) + CALL qmmm_env_get(qmmmx_env%ext, subsys=subsys_primary) particles_primary => subsys_primary%particles%els DO ip=1,SIZE(particles_qmmm_core) particles_primary(ip)%f=particles_qmmm_core(ip)%f @@ -183,14 +180,12 @@ END SUBROUTINE qmmmx_calc_energy_force !> \param consistent_energies ... !> \param linres ... !> \param label ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qmmmx_calc_energy_force_low(qmmm_env,calc_force,consistent_energies,linres,label,error) + SUBROUTINE qmmmx_calc_energy_force_low(qmmm_env,calc_force,consistent_energies,linres,label) TYPE(qmmm_env_type), POINTER :: qmmm_env LOGICAL, INTENT(IN) :: calc_force, & consistent_energies, linres CHARACTER(*) :: label - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmmx_calc_energy_force_low', & routineP = moduleN//':'//routineN @@ -208,28 +203,28 @@ SUBROUTINE qmmmx_calc_energy_force_low(qmmm_env,calc_force,consistent_energies,l NULLIFY(mm_cell,subsys_qm,subsys_mm,qm_atom_index) - CALL get_qs_env(qmmm_env%qs_env, input=force_env_section, error=error) + CALL get_qs_env(qmmm_env%qs_env, input=force_env_section) ! rewrite RESTART%FILENAME CALL section_vals_val_get(force_env_section, "DFT%SCF%PRINT%RESTART%FILENAME",& - c_val=old_restart_fn, error=error) + c_val=old_restart_fn) new_restart_fn = TRIM(old_restart_fn)//"-"//TRIM(label) CALL section_vals_val_set(force_env_section, "DFT%SCF%PRINT%RESTART%FILENAME",& - c_val=new_restart_fn, error=error) + c_val=new_restart_fn) ! rewrite RESTART_HISTORY%FILENAME CALL section_vals_val_get(force_env_section, "DFT%SCF%PRINT%RESTART_HISTORY%FILENAME",& - c_val=old_restart_hist_fn, error=error) + c_val=old_restart_hist_fn) new_restart_hist_fn = TRIM(old_restart_hist_fn)//"-"//TRIM(label) CALL section_vals_val_set(force_env_section, "DFT%SCF%PRINT%RESTART_HISTORY%FILENAME",& - c_val=new_restart_hist_fn, error=error) + c_val=new_restart_hist_fn) ! wrap positions before QM/MM calculation. ! Required if diffusion causes atoms outside of periodic box get added to QM - CALL fist_env_get(qmmm_env%fist_env, cell=mm_cell,subsys=subsys_mm,error=error) - CALL get_qs_env(qmmm_env%qs_env, cp_subsys=subsys_qm,error=error) + CALL fist_env_get(qmmm_env%fist_env, cell=mm_cell,subsys=subsys_mm) + CALL get_qs_env(qmmm_env%qs_env, cp_subsys=subsys_qm) qm_atom_index => qmmm_env%qm%qm_atom_index - CALL apply_qmmm_wrap(subsys_mm, mm_cell, subsys_qm, qm_atom_index, saved_pos, error) + CALL apply_qmmm_wrap(subsys_mm, mm_cell, subsys_qm, qm_atom_index, saved_pos) ! Turn off box translation, it was already performed by apply_qmmmx_translate(), ! the particles coordinates will still be copied from MM to QM. @@ -237,19 +232,19 @@ SUBROUTINE qmmmx_calc_energy_force_low(qmmm_env,calc_force,consistent_energies,l qmmm_env%qm%do_translate = .FALSE. ! actual energy force calculation - CALL qmmm_calc_energy_force(qmmm_env, calc_force, consistent_energies, linres, error) + CALL qmmm_calc_energy_force(qmmm_env, calc_force, consistent_energies, linres) ! restore do_translate qmmm_env%qm%do_translate = saved_do_translate ! restore unwrapped positions - CALL apply_qmmm_unwrap(subsys_mm, subsys_qm, qm_atom_index, saved_pos, error) + CALL apply_qmmm_unwrap(subsys_mm, subsys_qm, qm_atom_index, saved_pos) ! restore RESTART filenames CALL section_vals_val_set(force_env_section, "DFT%SCF%PRINT%RESTART%FILENAME",& - c_val=old_restart_fn, error=error) + c_val=old_restart_fn) CALL section_vals_val_set(force_env_section, "DFT%SCF%PRINT%RESTART_HISTORY%FILENAME",& - c_val=old_restart_hist_fn, error=error) + c_val=old_restart_hist_fn) END SUBROUTINE qmmmx_calc_energy_force_low diff --git a/src/qmmmx_types.F b/src/qmmmx_types.F index feebe6ea0b..9a48da79a0 100644 --- a/src/qmmmx_types.F +++ b/src/qmmmx_types.F @@ -36,14 +36,12 @@ MODULE qmmmx_types !> \param subsys ... !> \param potential_energy ... !> \param kinetic_energy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qmmmx_env_get(qmmmx_env,subsys,potential_energy,kinetic_energy,error) + SUBROUTINE qmmmx_env_get(qmmmx_env,subsys,potential_energy,kinetic_energy) TYPE(qmmmx_env_type), POINTER :: qmmmx_env TYPE(cp_subsys_type), OPTIONAL, POINTER :: subsys REAL(KIND=dp), INTENT(OUT), OPTIONAL :: potential_energy, & kinetic_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmmx_env_get', & routineP = moduleN//':'//routineN @@ -52,16 +50,15 @@ SUBROUTINE qmmmx_env_get(qmmmx_env,subsys,potential_energy,kinetic_energy,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qmmmx_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qmmmx_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qmmmx_env),cp_failure_level,routineP,failure) + CPPrecondition(qmmmx_env%ref_count>0,cp_failure_level,routineP,failure) ! get the underlying energies from primary subsys. This is the only subsys ! for conventional QM/MM, and force-mixing knows to put relevant energy there. CALL qmmm_env_get(qmmmx_env%ext,& kinetic_energy=kinetic_energy,& potential_energy=potential_energy,& - subsys=subsys,& - error=error) + subsys=subsys) END SUBROUTINE qmmmx_env_get @@ -69,13 +66,10 @@ END SUBROUTINE qmmmx_env_get ! ***************************************************************************** !> \brief ... !> \param qmmmx_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qmmmx_env_retain(qmmmx_env,error) + SUBROUTINE qmmmx_env_retain(qmmmx_env) TYPE(qmmmx_env_type), POINTER :: qmmmx_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmmx_env_retain', & routineP = moduleN//':'//routineN @@ -84,8 +78,8 @@ SUBROUTINE qmmmx_env_retain(qmmmx_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qmmmx_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(qmmmx_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(qmmmx_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(qmmmx_env%ref_count>0,cp_failure_level,routineP) qmmmx_env%ref_count = qmmmx_env%ref_count+1 END SUBROUTINE qmmmx_env_retain @@ -93,13 +87,10 @@ END SUBROUTINE qmmmx_env_retain ! ***************************************************************************** !> \brief releases the given qmmmx_env (see doc/ReferenceCounting.html) !> \param qmmmx_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qmmmx_env_release(qmmmx_env,error) + SUBROUTINE qmmmx_env_release(qmmmx_env) TYPE(qmmmx_env_type), POINTER :: qmmmx_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmmx_env_release', & routineP = moduleN//':'//routineN @@ -109,11 +100,11 @@ SUBROUTINE qmmmx_env_release(qmmmx_env,error) failure=.FALSE. IF (ASSOCIATED(qmmmx_env)) THEN - CPPreconditionNoFail(qmmmx_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(qmmmx_env%ref_count>0,cp_failure_level,routineP) qmmmx_env%ref_count = qmmmx_env%ref_count-1 IF (qmmmx_env%ref_count==0) THEN - CALL qmmm_env_release(qmmmx_env%core, error) - CALL qmmm_env_release(qmmmx_env%ext, error) + CALL qmmm_env_release(qmmmx_env%core) + CALL qmmm_env_release(qmmmx_env%ext) DEALLOCATE(qmmmx_env) END IF END IF diff --git a/src/qmmmx_update.F b/src/qmmmx_update.F index 2fa22d16e2..22c10dda30 100644 --- a/src/qmmmx_update.F +++ b/src/qmmmx_update.F @@ -45,12 +45,10 @@ MODULE qmmmx_update !> \brief ... !> \param force_env ... !> \param root_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qmmmx_update_force_env(force_env, root_section, error) + SUBROUTINE qmmmx_update_force_env(force_env, root_section) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmmx_update_force_env', & routineP = moduleN//':'//routineN @@ -70,62 +68,62 @@ SUBROUTINE qmmmx_update_force_env(force_env, root_section, error) IF (.NOT. ASSOCIATED(force_env)) RETURN IF (.NOT. ASSOCIATED(force_env%force_env_section)) RETURN ! these two should never happen, because the sections exist, but just in case... - qmmm_section => section_vals_get_subs_vals(force_env%force_env_section,"QMMM",can_return_null=.TRUE.,error=error) + qmmm_section => section_vals_get_subs_vals(force_env%force_env_section,"QMMM",can_return_null=.TRUE.) IF (.NOT. ASSOCIATED(qmmm_section)) RETURN - qmmm_force_mixing => section_vals_get_subs_vals(qmmm_section,"FORCE_MIXING",can_return_null=.TRUE.,error=error) + qmmm_force_mixing => section_vals_get_subs_vals(qmmm_section,"FORCE_MIXING",can_return_null=.TRUE.) IF (.NOT. ASSOCIATED(qmmm_force_mixing)) RETURN - CALL section_vals_get(qmmm_force_mixing,explicit=force_mixing_active,error=error) + CALL section_vals_get(qmmm_force_mixing,explicit=force_mixing_active) IF(.NOT.force_mixing_active) RETURN IF(.NOT.ASSOCIATED(force_env%qmmmx_env)) STOP "qmmmx_update_force_env: force_env%qmmmx not associated" - CALL force_env_get(force_env, subsys=subsys, error=error) - CALL update_force_mixing_labels(subsys, qmmm_section, labels_changed=labels_changed, error=error) + CALL force_env_get(force_env, subsys=subsys) + CALL update_force_mixing_labels(subsys, qmmm_section, labels_changed=labels_changed) IF (.NOT. labels_changed) RETURN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "Adaptive force-mixing labels changed, rebuilding QM/MM calculations! "//& CPSourceFileRef,only_ionode=.TRUE.) - CALL update_force_eval(force_env, root_section, .FALSE., error) + CALL update_force_eval(force_env, root_section, .FALSE.) ALLOCATE(new_qmmmx_env) ! using CUR_INDICES and CUR_LABELS, create appropriate QM_KIND sections for two QM/MM calculations - CALL setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_section, qmmm_extended_section,error=error) + CALL setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_section, qmmm_extended_section) - subsys_section => section_vals_get_subs_vals(force_env%force_env_section,"SUBSYS",error=error) + subsys_section => section_vals_get_subs_vals(force_env%force_env_section,"SUBSYS") ![ADAPT] no sure about use_motion_section CALL qmmm_env_create(new_qmmmx_env%core,& force_env%root_section, force_env%para_env, force_env%globenv,& force_env%force_env_section, qmmm_core_section, subsys_section, use_motion_section=.TRUE., & - prev_subsys=subsys, ignore_outside_box=.TRUE., error=error) + prev_subsys=subsys, ignore_outside_box=.TRUE.) CALL qmmm_env_create(new_qmmmx_env%ext, & force_env%root_section, force_env%para_env, force_env%globenv,& force_env%force_env_section, qmmm_extended_section, subsys_section, use_motion_section=.TRUE., & - prev_subsys=subsys, ignore_outside_box=.TRUE., error=error) + prev_subsys=subsys, ignore_outside_box=.TRUE.) ! [NB] need to copy wiener process data, since it's not recreated when ! fist subsys is recreated by qmmm_env_create - CALL qmmm_env_get(force_env%qmmmx_env%core, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, local_particles=local_particles, error=error) - CALL qmmm_env_get(new_qmmmx_env%core, subsys=subsys_new, error=error) - CALL cp_subsys_get(subsys_new, atomic_kinds=new_atomic_kinds, local_particles=new_local_particles, error=error) + CALL qmmm_env_get(force_env%qmmmx_env%core, subsys=subsys) + CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, local_particles=local_particles) + CALL qmmm_env_get(new_qmmmx_env%core, subsys=subsys_new) + CALL cp_subsys_get(subsys_new, atomic_kinds=new_atomic_kinds, local_particles=new_local_particles) IF (ASSOCIATED(local_particles%local_particle_set)) THEN - CALL copy_wiener_process(atomic_kinds, local_particles, new_atomic_kinds, new_local_particles, error=error) + CALL copy_wiener_process(atomic_kinds, local_particles, new_atomic_kinds, new_local_particles) ENDIF - CALL qmmm_env_get(force_env%qmmmx_env%ext, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, local_particles=local_particles, error=error) - CALL qmmm_env_get(new_qmmmx_env%ext, subsys=subsys_new, error=error) - CALL cp_subsys_get(subsys_new, atomic_kinds=new_atomic_kinds, local_particles=new_local_particles, error=error) + CALL qmmm_env_get(force_env%qmmmx_env%ext, subsys=subsys) + CALL cp_subsys_get(subsys, atomic_kinds=atomic_kinds, local_particles=local_particles) + CALL qmmm_env_get(new_qmmmx_env%ext, subsys=subsys_new) + CALL cp_subsys_get(subsys_new, atomic_kinds=new_atomic_kinds, local_particles=new_local_particles) IF (ASSOCIATED(local_particles%local_particle_set)) THEN - CALL copy_wiener_process(atomic_kinds, local_particles, new_atomic_kinds, new_local_particles, error=error) + CALL copy_wiener_process(atomic_kinds, local_particles, new_atomic_kinds, new_local_particles) ENDIF - CALL section_vals_release(qmmm_core_section, error=error) - CALL section_vals_release(qmmm_extended_section, error=error) + CALL section_vals_release(qmmm_core_section) + CALL section_vals_release(qmmm_extended_section) ! release old qmmmx_env and point to new one - CALL qmmmx_env_release(force_env%qmmmx_env,error=error) + CALL qmmmx_env_release(force_env%qmmmx_env) force_env%qmmmx_env => new_qmmmx_env END SUBROUTINE qmmmx_update_force_env @@ -137,15 +135,13 @@ END SUBROUTINE qmmmx_update_force_env !> \param from_local_particles ... !> \param to_local_particle_kinds ... !> \param to_local_particles ... -!> \param error ... ! ***************************************************************************** SUBROUTINE copy_wiener_process(from_local_particle_kinds, from_local_particles,& - to_local_particle_kinds, to_local_particles,error) + to_local_particle_kinds, to_local_particles) TYPE(atomic_kind_list_type), POINTER :: from_local_particle_kinds TYPE(distribution_1d_type), POINTER :: from_local_particles TYPE(atomic_kind_list_type), POINTER :: to_local_particle_kinds TYPE(distribution_1d_type), POINTER :: to_local_particles - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'copy_wiener_process', & routineP = moduleN//':'//routineN @@ -157,11 +153,11 @@ SUBROUTINE copy_wiener_process(from_local_particle_kinds, from_local_particles,& LOGICAL :: failure, found_it CALL timeset(routineN,handle) - CPPrecondition (ASSOCIATED(from_local_particles),cp_failure_level,routineP,error,failure) - CPPrecondition (ASSOCIATED(to_local_particles),cp_failure_level,routineP,error,failure) + CPPrecondition (ASSOCIATED(from_local_particles),cp_failure_level,routineP,failure) + CPPrecondition (ASSOCIATED(to_local_particles),cp_failure_level,routineP,failure) IF (.NOT. ASSOCIATED(from_local_particles%local_particle_set)) RETURN - CPPrecondition (.NOT. ASSOCIATED(to_local_particles%local_particle_set),cp_failure_level,routineP,error,failure) + CPPrecondition (.NOT. ASSOCIATED(to_local_particles%local_particle_set),cp_failure_level,routineP,failure) from_nparticle_kind = from_local_particle_kinds%n_els to_nparticle_kind = to_local_particle_kinds%n_els @@ -175,7 +171,7 @@ SUBROUTINE copy_wiener_process(from_local_particle_kinds, from_local_particles,& DO to_iparticle_kind=1, to_nparticle_kind tot_to_nparticle_local = tot_to_nparticle_local + to_local_particles%n_el(to_iparticle_kind) END DO - CPPrecondition (tot_from_nparticle_local == tot_to_nparticle_local, cp_failure_level,routineP,error,failure) + CPPrecondition (tot_from_nparticle_local == tot_to_nparticle_local, cp_failure_level,routineP,failure) ALLOCATE(to_local_particles%local_particle_set(to_nparticle_kind)) DO to_iparticle_kind=1, to_nparticle_kind @@ -201,7 +197,7 @@ SUBROUTINE copy_wiener_process(from_local_particle_kinds, from_local_particles,& EXIT ENDIF END DO - CPPostcondition (found_it, cp_failure_level,routineP,error,failure) + CPPostcondition (found_it, cp_failure_level,routineP,failure) END DO ! to_iparticle_local diff --git a/src/qmmmx_util.F b/src/qmmmx_util.F index 411fcadbd2..9be028310f 100644 --- a/src/qmmmx_util.F +++ b/src/qmmmx_util.F @@ -65,15 +65,12 @@ MODULE qmmmx_util !> \brief Apply translation to the full system in order to center the QM !> system into the QM box !> \param qmmmx_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2007 created [tlaino] - Zurich University !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE apply_qmmmx_translate(qmmmx_env,error) + SUBROUTINE apply_qmmmx_translate(qmmmx_env) TYPE(qmmmx_env_type), POINTER :: qmmmx_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_qmmmx_translate', & routineP = moduleN//':'//routineN @@ -90,19 +87,19 @@ SUBROUTINE apply_qmmmx_translate(qmmmx_env,error) NULLIFY(particles_core, particles_extended) ! want to center extended, and make core consistent with that - CALL apply_qmmm_translate(qmmmx_env%ext,error) + CALL apply_qmmm_translate(qmmmx_env%ext) ! translate core fist particles - CALL qmmm_env_get(qmmmx_env%ext, subsys=subsys_extended, error=error) - CALL cp_subsys_get(subsys_extended, cell=cell_extended, error=error) - CALL qmmm_env_get(qmmmx_env%core, subsys=subsys_core, error=error) - CALL cp_subsys_get(subsys_core, cell=cell_core, error=error) + CALL qmmm_env_get(qmmmx_env%ext, subsys=subsys_extended) + CALL cp_subsys_get(subsys_extended, cell=cell_extended) + CALL qmmm_env_get(qmmmx_env%core, subsys=subsys_core) + CALL cp_subsys_get(subsys_core, cell=cell_core) particles_extended => subsys_extended%particles%els particles_core => subsys_core%particles%els DO ip=1,SIZE(particles_extended) particles_core(ip)%r = particles_extended(ip)%r END DO - CALL cell_copy(cell_extended, cell_core, error) + CALL cell_copy(cell_extended, cell_core) ! The core QM particles will be updated the regular call ! to apply_qmmm_translate() from within qmmm_calc_energy_force() @@ -114,17 +111,14 @@ END SUBROUTINE apply_qmmmx_translate !> \param subsys ... !> \param qmmm_section ... !> \param labels_changed ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2012 created [noam] !> \author Noam Bernstein ! ***************************************************************************** - SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed, error) + SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed) TYPE(cp_subsys_type), POINTER :: subsys TYPE(section_vals_type), POINTER :: qmmm_section LOGICAL, OPTIONAL :: labels_changed - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_force_mixing_labels', & routineP = moduleN//':'//routineN @@ -157,29 +151,29 @@ SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed, erro qm_kind_section, & restart_section - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) IF (debug_this_module.AND.output_unit>0) WRITE(output_unit,*) "BOB starting update_force_mixing_labels" ! get cur indices, labels - force_mixing_section => section_vals_get_subs_vals3(qmmm_section,"FORCE_MIXING",error=error) - CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels, error=error) + force_mixing_section => section_vals_get_subs_vals3(qmmm_section,"FORCE_MIXING") + CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels) IF (debug_this_module.AND.output_unit>0) WRITE(output_unit,*) "BOB got cur_indices ",SIZE(cur_indices) IF (debug_this_module.AND.output_unit>0) WRITE(output_unit,*) "BOB got cur_labels ",SIZE(cur_labels) ! read from input ![NB] breakable bonds will come from here, too NULLIFY(r_core, r_qm, r_buf, adaptive_exclude_molecules,broken_bonds) - CALL section_vals_val_get(force_mixing_section,"R_CORE",r_vals=r_core,error=error) - CALL section_vals_val_get(force_mixing_section,"R_QM",r_vals=r_qm,error=error) + CALL section_vals_val_get(force_mixing_section,"R_CORE",r_vals=r_core) + CALL section_vals_val_get(force_mixing_section,"R_QM",r_vals=r_qm) CALL section_vals_val_get(force_mixing_section,"QM_EXTENDED_SEED_IS_ONLY_CORE_LIST",& - l_val=QM_extended_seed_is_core_list,error=error) - CALL section_vals_val_get(force_mixing_section,"R_BUF",r_vals=r_buf,error=error) - CALL section_vals_val_get(force_mixing_section,"MAX_N_QM",i_val=max_n_qm,error=error) + l_val=QM_extended_seed_is_core_list) + CALL section_vals_val_get(force_mixing_section,"R_BUF",r_vals=r_buf) + CALL section_vals_val_get(force_mixing_section,"MAX_N_QM",i_val=max_n_qm) - CALL section_vals_val_get(force_mixing_section,"ADAPTIVE_EXCLUDE_MOLECULES",n_rep_val=n_rep_exclude,error=error) + CALL section_vals_val_get(force_mixing_section,"ADAPTIVE_EXCLUDE_MOLECULES",n_rep_val=n_rep_exclude) IF (n_rep_exclude > 0) THEN - CALL section_vals_val_get(force_mixing_section,"ADAPTIVE_EXCLUDE_MOLECULES",c_vals=adaptive_exclude_molecules,error=error) + CALL section_vals_val_get(force_mixing_section,"ADAPTIVE_EXCLUDE_MOLECULES",c_vals=adaptive_exclude_molecules) ENDIF ![NB] need to read real list from input ! should be 2xN_bb integer arrays, with (1,:) indices of inside atoms, and (2,:) indices of outside atoms @@ -188,7 +182,7 @@ SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed, erro ! get particles, molecules NULLIFY(particles,molecules) - CALL cp_subsys_get(subsys=subsys, particles=particles,molecules_new=molecules, error=error) + CALL cp_subsys_get(subsys=subsys, particles=particles,molecules_new=molecules) particle_set => particles%els molecule_set => molecules%els @@ -205,20 +199,20 @@ SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed, erro ! neighbor list for various hysteretic distance calls NULLIFY(cell) - CALL cp_subsys_get(subsys, cell=cell, error=error) + CALL cp_subsys_get(subsys, cell=cell) NULLIFY(nlist) - CALL make_neighbor_list(force_mixing_section, subsys, cell, MAX(r_core(2), r_qm(2), r_buf(2)), nlist, error) + CALL make_neighbor_list(force_mixing_section, subsys, cell, MAX(r_core(2), r_qm(2), r_buf(2)), nlist) ! create labels for core_list from QM_KIND NULLIFY(mm_index_entry) - qm_kind_section => section_vals_get_subs_vals3(qmmm_section,"QM_KIND",error=error) - CALL section_vals_get(qm_kind_section,n_repetition=n_rep_section,error=error) + qm_kind_section => section_vals_get_subs_vals3(qmmm_section,"QM_KIND") + CALL section_vals_get(qm_kind_section,n_repetition=n_rep_section) n_new = 0 DO i_rep_section=1,n_rep_section - CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,n_rep_val=n_rep_val) DO i_rep_val=1,n_rep_val CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,i_rep_val=i_rep_val, & - i_vals=mm_index_entry, error=error) + i_vals=mm_index_entry) DO ip=1, SIZE(mm_index_entry) CALL add_new_label(mm_index_entry(ip), force_mixing_label_QM_core_list, n_new, new_indices, new_labels, & new_full_labels, max_n_qm) @@ -233,15 +227,15 @@ SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed, erro ! create labels for non adaptive QM and buffer regions from *_NON_ADAPTIVE&QM_KIND sections non_adaptive_section => section_vals_get_subs_vals(qmmm_section,"FORCE_MIXING%QM_NON_ADAPTIVE",& - can_return_null=.TRUE.,error=error) + can_return_null=.TRUE.) IF (ASSOCIATED(non_adaptive_section)) THEN - qm_kind_section => section_vals_get_subs_vals3(non_adaptive_section,"QM_KIND",error=error) - CALL section_vals_get(qm_kind_section,n_repetition=n_rep_section,error=error) + qm_kind_section => section_vals_get_subs_vals3(non_adaptive_section,"QM_KIND") + CALL section_vals_get(qm_kind_section,n_repetition=n_rep_section) DO i_rep_section=1,n_rep_section - CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,n_rep_val=n_rep_val) DO i_rep_val=1,n_rep_val CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,i_rep_val=i_rep_val, & - i_vals=mm_index_entry, error=error) + i_vals=mm_index_entry) DO ip=1, SIZE(mm_index_entry) CALL add_new_label(mm_index_entry(ip), force_mixing_label_QM_dynamics_list, n_new, new_indices, new_labels, & new_full_labels, max_n_qm) @@ -254,15 +248,15 @@ SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed, erro WRITE(output_unit,*) "BOB core_list + non adaptive QM new_labels ",new_labels(1:n_new) ENDIF non_adaptive_section => section_vals_get_subs_vals(qmmm_section,"FORCE_MIXING%BUFFER_NON_ADAPTIVE",& - can_return_null=.TRUE.,error=error) + can_return_null=.TRUE.) IF (ASSOCIATED(non_adaptive_section)) THEN - qm_kind_section => section_vals_get_subs_vals3(non_adaptive_section,"QM_KIND",error=error) - CALL section_vals_get(qm_kind_section,n_repetition=n_rep_section,error=error) + qm_kind_section => section_vals_get_subs_vals3(non_adaptive_section,"QM_KIND") + CALL section_vals_get(qm_kind_section,n_repetition=n_rep_section) DO i_rep_section=1,n_rep_section - CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,n_rep_val=n_rep_val) DO i_rep_val=1,n_rep_val CALL section_vals_val_get(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section,i_rep_val=i_rep_val, & - i_vals=mm_index_entry, error=error) + i_vals=mm_index_entry) DO ip=1, SIZE(mm_index_entry) CALL add_new_label(mm_index_entry(ip), force_mixing_label_buffer_list, n_new, new_indices, new_labels, & new_full_labels, max_n_qm) @@ -347,17 +341,17 @@ SUBROUTINE update_force_mixing_labels(subsys, qmmm_section, labels_changed, erro CALL reallocate(new_labels,1,n_new) ! save info in input structure - restart_section => section_vals_get_subs_vals(qmmm_section, "FORCE_MIXING%RESTART_INFO", error=error) - CALL section_vals_get(restart_section,explicit=explicit,error=error) - IF (explicit) CALL section_vals_remove_values(restart_section,error) - CALL section_vals_val_set(restart_section,"INDICES",i_vals_ptr=new_indices,error=error) - CALL section_vals_val_set(restart_section,"LABELS",i_vals_ptr=new_labels,error=error) + restart_section => section_vals_get_subs_vals(qmmm_section, "FORCE_MIXING%RESTART_INFO") + CALL section_vals_get(restart_section,explicit=explicit) + IF (explicit) CALL section_vals_remove_values(restart_section) + CALL section_vals_val_set(restart_section,"INDICES",i_vals_ptr=new_indices) + CALL section_vals_val_set(restart_section,"LABELS",i_vals_ptr=new_labels) DEALLOCATE(cur_indices, cur_labels) - CALL fist_neighbor_deallocate(nlist,error) + CALL fist_neighbor_deallocate(nlist) ![NB] perhap be controlled by some &PRINT section? - CALL cp_subsys_get(subsys, para_env=para_env, error=error) + CALL cp_subsys_get(subsys, para_env=para_env) IF (para_env%ionode .AND. output_unit > 0) THEN WRITE(unit=output_unit, fmt='(A,A,I6,A,I5,A,I5,A,I5)') & "QMMM FORCE MIXING final count (not including links): ",& @@ -543,15 +537,13 @@ END SUBROUTINE add_layer_hysteretically !> \param cell ... !> \param r_max ... !> \param nlist ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE make_neighbor_list(force_mixing_section, subsys, cell, r_max, nlist, error) + SUBROUTINE make_neighbor_list(force_mixing_section, subsys, cell, r_max, nlist) TYPE(section_vals_type), POINTER :: force_mixing_section TYPE(cp_subsys_type), POINTER :: subsys TYPE(cell_type), POINTER :: cell REAL(dp) :: r_max TYPE(fist_neighbor_type), POINTER :: nlist - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_neighbor_list', & routineP = moduleN//':'//routineN @@ -593,7 +585,7 @@ SUBROUTINE make_neighbor_list(force_mixing_section, subsys, cell, r_max, nlist, cell=cell, r_max=r_max_a, r_minsq=r_minsq_a, & ei_scale14=1.0_dp, vdw_scale14=1.0_dp, nonbonded=nlist, & para_env=subsys%para_env, build_from_scratch=.TRUE., geo_check=.FALSE., & - mm_section=force_mixing_section, error=error) + mm_section=force_mixing_section) DEALLOCATE(r_max_a, r_minsq_a) @@ -611,18 +603,15 @@ END SUBROUTINE make_neighbor_list !> \param qmmm_section ... !> \param qmmm_core_section ... !> \param qmmm_extended_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2012 created [noam] !> \author Noam Bernstein ! ***************************************************************************** - SUBROUTINE setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_section, qmmm_extended_section, error) + SUBROUTINE setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_section, qmmm_extended_section) TYPE(cp_subsys_type), POINTER :: subsys TYPE(section_vals_type), POINTER :: qmmm_section, & qmmm_core_section, & qmmm_extended_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'setup_force_mixing_qmmm_sections', & @@ -645,47 +634,46 @@ SUBROUTINE setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_sect output_unit = cp_logger_get_default_unit_nr() ! create new qmmm sections for core and extended - CALL section_vals_duplicate(qmmm_section, qmmm_core_section, error=error) - CALL section_vals_duplicate(qmmm_section, qmmm_extended_section, error=error) + CALL section_vals_duplicate(qmmm_section, qmmm_core_section) + CALL section_vals_duplicate(qmmm_section, qmmm_extended_section) ! remove LINKs (specified by user for core) from extended - link_section => section_vals_get_subs_vals(qmmm_extended_section, "LINK", can_return_null=.TRUE., error=error) + link_section => section_vals_get_subs_vals(qmmm_extended_section, "LINK", can_return_null=.TRUE.) IF (ASSOCIATED(link_section)) THEN - CALL section_vals_remove_values(link_section,error) + CALL section_vals_remove_values(link_section) END IF ! for LINKs to be added to extended buffer_non_adaptive_section => section_vals_get_subs_vals(qmmm_extended_section, "FORCE_MIXING%BUFFER_NON_ADAPTIVE", & - can_return_null=.TRUE., error=error) - link_section => section_vals_get_subs_vals(buffer_non_adaptive_section, "LINK", can_return_null=.TRUE., error=error) + can_return_null=.TRUE.) + link_section => section_vals_get_subs_vals(buffer_non_adaptive_section, "LINK", can_return_null=.TRUE.) IF (ASSOCIATED(link_section)) THEN NULLIFY(dup_link_section) - CALL section_vals_duplicate(link_section, dup_link_section, error=error) - CALL section_vals_set_subs_vals(qmmm_extended_section, "LINK", dup_link_section, error=error) - CALL section_vals_release(dup_link_section, error=error) + CALL section_vals_duplicate(link_section, dup_link_section) + CALL section_vals_set_subs_vals(qmmm_extended_section, "LINK", dup_link_section) + CALL section_vals_release(dup_link_section) ENDIF IF (debug_this_module.AND.output_unit>0) THEN - link_section => section_vals_get_subs_vals(qmmm_core_section, "LINK", can_return_null=.TRUE., error=error) + link_section => section_vals_get_subs_vals(qmmm_core_section, "LINK", can_return_null=.TRUE.) WRITE(output_unit,*) "core section has LINKs ",ASSOCIATED(link_section) - CALL section_vals_write(link_section,unit_nr=6,error=error) - link_section => section_vals_get_subs_vals(qmmm_extended_section, "LINK", can_return_null=.TRUE., error=error) + CALL section_vals_write(link_section,unit_nr=6) + link_section => section_vals_get_subs_vals(qmmm_extended_section, "LINK", can_return_null=.TRUE.) WRITE(output_unit,*) "extended section has LINKs ",ASSOCIATED(link_section) - CALL section_vals_write(link_section,unit_nr=6,error=error) + CALL section_vals_write(link_section,unit_nr=6) ENDIF - force_mixing_section => section_vals_get_subs_vals(qmmm_section,"FORCE_MIXING",error=error) + force_mixing_section => section_vals_get_subs_vals(qmmm_section,"FORCE_MIXING") ! get QM_KIND_ELEMENT_MAPPING - CALL section_vals_val_get(force_mixing_section,"QM_KIND_ELEMENT_MAPPING",n_rep_val=n_elements,error=error) + CALL section_vals_val_get(force_mixing_section,"QM_KIND_ELEMENT_MAPPING",n_rep_val=n_elements) ALLOCATE(elem_mapping(2,n_elements)) DO ielem=1,n_elements - CALL section_vals_val_get(force_mixing_section,"QM_KIND_ELEMENT_MAPPING",i_rep_val=ielem,c_vals=elem_mapping_entry,& - error=error) + CALL section_vals_val_get(force_mixing_section,"QM_KIND_ELEMENT_MAPPING",i_rep_val=ielem,c_vals=elem_mapping_entry) elem_mapping(1:2,ielem) = elem_mapping_entry(1:2) END DO ! get CUR_INDICES, CUR_LABELS - CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels, error=error) + CALL get_force_mixing_indices(force_mixing_section, cur_indices, cur_labels) CALL cp_assert(SIZE(cur_indices) > 0,cp_failure_level,cp_assertion_failed,routineP,& "cur_indices is empty, found no QM atoms"//CPSourceFileRef) @@ -715,8 +703,8 @@ SUBROUTINE setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_sect END DO ! pre-existing QM_KIND section specifies list of core atom - qm_kind_section => section_vals_get_subs_vals3(qmmm_section,"QM_KIND",error=error) - CALL section_vals_get(qm_kind_section,n_repetition=i_rep_section_core,error=error) + qm_kind_section => section_vals_get_subs_vals3(qmmm_section,"QM_KIND") + CALL section_vals_get(qm_kind_section,n_repetition=i_rep_section_core) CALL cp_assert(i_rep_section_core > 0,cp_failure_level,cp_assertion_failed,routineP,& "Force-mixing QM didn't find any QM_KIND sections, "//& "so no core specified!"//CPSourceFileRef) @@ -733,52 +721,52 @@ SUBROUTINE setup_force_mixing_qmmm_sections(subsys, qmmm_section, qmmm_core_sect IF (cur_labels(ip) > force_mixing_label_none .AND. & cur_labels(ip) /= force_mixing_label_QM_core_list .AND. & cur_labels(ip) /= force_mixing_label_termination) THEN - qm_kind_section => section_vals_get_subs_vals3(qmmm_extended_section,"QM_KIND",error=error) + qm_kind_section => section_vals_get_subs_vals3(qmmm_extended_section,"QM_KIND") IF (new_element_extended) THEN ! add new QM_KIND section for this element i_rep_section_extended = i_rep_section_extended + 1 - CALL section_vals_add_values(qm_kind_section,error=error) + CALL section_vals_add_values(qm_kind_section) CALL section_vals_val_set(qm_kind_section,"_SECTION_PARAMETERS_",i_rep_section=i_rep_section_extended, & - c_val=elem_mapping(2,ielem),error=error) + c_val=elem_mapping(2,ielem)) i_rep_val_extended = 0 new_element_extended = .FALSE. ENDIF i_rep_val_extended = i_rep_val_extended + 1 CALL section_vals_val_set(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section_extended, & - i_rep_val=i_rep_val_extended, i_val=cur_indices(ip),error=error) + i_rep_val=i_rep_val_extended, i_val=cur_indices(ip)) ENDIF ! is a non-termination QM atom ! core ! if current particle is a core QM atom, and not in core list (those the user ! gave explicit QM_KIND sections for, need to make a QM_KIND section for it IF (cur_labels(ip) == force_mixing_label_QM_core) THEN - qm_kind_section => section_vals_get_subs_vals3(qmmm_core_section,"QM_KIND",error=error) + qm_kind_section => section_vals_get_subs_vals3(qmmm_core_section,"QM_KIND") IF (new_element_core) THEN ! add new QM_KIND section for this element i_rep_section_core = i_rep_section_core + 1 - CALL section_vals_add_values(qm_kind_section,error=error) + CALL section_vals_add_values(qm_kind_section) CALL section_vals_val_set(qm_kind_section,"_SECTION_PARAMETERS_",i_rep_section=i_rep_section_core, & - c_val=elem_mapping(2,ielem),error=error) + c_val=elem_mapping(2,ielem)) i_rep_val_core = 0 new_element_core = .FALSE. ENDIF i_rep_val_core = i_rep_val_core + 1 CALL section_vals_val_set(qm_kind_section,"MM_INDEX",i_rep_section=i_rep_section_core, & - i_rep_val=i_rep_val_core, i_val=cur_indices(ip),error=error) + i_rep_val=i_rep_val_core, i_val=cur_indices(ip)) ENDIF ! is a non-termination QM atom END DO ! atom index ip END DO ! element index ielem - CALL section_vals_val_get(force_mixing_section,"EXTENDED_DELTA_CHARGE",i_val=delta_charge,error=error) - CALL section_vals_val_set(qmmm_extended_section,"DELTA_CHARGE",i_val=delta_charge,error=error) + CALL section_vals_val_get(force_mixing_section,"EXTENDED_DELTA_CHARGE",i_val=delta_charge) + CALL section_vals_val_set(qmmm_extended_section,"DELTA_CHARGE",i_val=delta_charge) ![NB] check DEALLOCATE(elem_mapping, cur_indices, cur_labels) IF (debug_this_module.AND.output_unit>0) THEN WRITE(output_unit,*) "qmmm_core_section" - CALL section_vals_write(qmmm_core_section,unit_nr=6,error=error) + CALL section_vals_write(qmmm_core_section,unit_nr=6) WRITE(output_unit,*) "qmmm_extended_section" - CALL section_vals_write(qmmm_extended_section,unit_nr=6,error=error) + CALL section_vals_write(qmmm_extended_section,unit_nr=6) ENDIF END SUBROUTINE setup_force_mixing_qmmm_sections @@ -788,12 +776,10 @@ END SUBROUTINE setup_force_mixing_qmmm_sections !> \param force_mixing_section ... !> \param indices ... !> \param labels ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_force_mixing_indices(force_mixing_section, indices, labels, error) + SUBROUTINE get_force_mixing_indices(force_mixing_section, indices, labels) TYPE(section_vals_type), POINTER :: force_mixing_section INTEGER, POINTER :: indices(:), labels(:) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_force_mixing_indices', & routineP = moduleN//':'//routineN @@ -806,8 +792,8 @@ SUBROUTINE get_force_mixing_indices(force_mixing_section, indices, labels, error TYPE(section_vals_type), POINTER :: restart_section NULLIFY(indices, labels) - restart_section => section_vals_get_subs_vals(force_mixing_section, "RESTART_INFO", error=error) - CALL section_vals_get(restart_section,explicit=explicit,error=error) + restart_section => section_vals_get_subs_vals(force_mixing_section, "RESTART_INFO") + CALL section_vals_get(restart_section,explicit=explicit) IF (.NOT. explicit) THEN ! no old indices, labels, return empty arrays ALLOCATE(indices(0)) ALLOCATE(labels(0)) @@ -815,34 +801,34 @@ SUBROUTINE get_force_mixing_indices(force_mixing_section, indices, labels, error ENDIF ![NB] maybe switch to reallocatable array - CALL section_vals_val_get(restart_section,"INDICES",n_rep_val=n_reps,error=error) + CALL section_vals_val_get(restart_section,"INDICES",n_rep_val=n_reps) n_indices=0 DO i_rep_val = 1,n_reps CALL section_vals_val_get(restart_section,"INDICES",& - i_rep_val=i_rep_val,i_vals=indices_entry,error=error) + i_rep_val=i_rep_val,i_vals=indices_entry) n_indices = n_indices + SIZE(indices_entry) END DO ALLOCATE(indices(n_indices)) n_indices=0 DO i_rep_val = 1,n_reps CALL section_vals_val_get(restart_section,"INDICES",& - i_rep_val=i_rep_val,i_vals=indices_entry,error=error) + i_rep_val=i_rep_val,i_vals=indices_entry) indices(n_indices+1:n_indices+SIZE(indices_entry)) = indices_entry n_indices = n_indices + SIZE(indices_entry) END DO - CALL section_vals_val_get(restart_section,"LABELS",n_rep_val=n_reps,error=error) + CALL section_vals_val_get(restart_section,"LABELS",n_rep_val=n_reps) n_labels=0 DO i_rep_val = 1,n_reps CALL section_vals_val_get(restart_section,"LABELS",& - i_rep_val=i_rep_val,i_vals=labels_entry,error=error) + i_rep_val=i_rep_val,i_vals=labels_entry) n_labels = n_labels + SIZE(labels_entry) END DO ALLOCATE(labels(n_labels)) n_labels=0 DO i_rep_val = 1,n_reps CALL section_vals_val_get(restart_section,"LABELS",& - i_rep_val=i_rep_val,i_vals=labels_entry,error=error) + i_rep_val=i_rep_val,i_vals=labels_entry) labels(n_labels+1:n_labels+SIZE(labels_entry)) = labels_entry n_labels = n_labels + SIZE(labels_entry) END DO diff --git a/src/qs_block_davidson_types.F b/src/qs_block_davidson_types.F index 57497d8b28..ae2623fb2a 100644 --- a/src/qs_block_davidson_types.F +++ b/src/qs_block_davidson_types.F @@ -52,15 +52,13 @@ MODULE qs_block_davidson_types !> \param bdav_env ... !> \param nspins ... !> \param scf_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE block_davidson_env_create(bdav_env,nspins,scf_section,error) + SUBROUTINE block_davidson_env_create(bdav_env,nspins,scf_section) TYPE(davidson_type), DIMENSION(:), & POINTER :: bdav_env INTEGER, INTENT(IN) :: nspins TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'block_davidson_env_create', & routineP = moduleN//':'//routineN @@ -70,9 +68,9 @@ SUBROUTINE block_davidson_env_create(bdav_env,nspins,scf_section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(bdav_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(bdav_env),cp_failure_level,routineP,failure) ALLOCATE(bdav_env(nspins), stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO ispin = 1,nspins NULLIFY(bdav_env(ispin)%H_block_mat) NULLIFY(bdav_env(ispin)%H_block_vec) @@ -82,23 +80,23 @@ SUBROUTINE block_davidson_env_create(bdav_env,nspins,scf_section,error) NULLIFY(bdav_env(ispin)%matrix_pz) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DAVIDSON%PRECONDITIONER",& - i_val=bdav_env(ispin)%prec_type,error=error) + i_val=bdav_env(ispin)%prec_type) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DAVIDSON%PRECOND_SOLVER",& - i_val=bdav_env(ispin)%solver_type,error=error) + i_val=bdav_env(ispin)%solver_type) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DAVIDSON%ENERGY_GAP",& - r_val=bdav_env(ispin)%energy_gap,error=error) + r_val=bdav_env(ispin)%energy_gap) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DAVIDSON%NEW_PREC_EACH",& - i_val=bdav_env(ispin)%niter_new_prec,error=error) + i_val=bdav_env(ispin)%niter_new_prec) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%MAX_ITER",& - i_val=bdav_env(ispin)%max_iter,error=error) + i_val=bdav_env(ispin)%max_iter) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%EPS_ITER",& - r_val=bdav_env(ispin)%eps_iter,error=error) + r_val=bdav_env(ispin)%eps_iter) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DAVIDSON%FIRST_PREC",& - i_val=bdav_env(ispin)%first_prec,error=error) + i_val=bdav_env(ispin)%first_prec) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DAVIDSON%CONV_MOS_PERCENT",& - r_val=bdav_env(ispin)%conv_percent,error=error) + r_val=bdav_env(ispin)%conv_percent) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DAVIDSON%SPARSE_MOS",& - l_val=bdav_env(ispin)%use_sparse_mos,error=error) + l_val=bdav_env(ispin)%use_sparse_mos) END DO @@ -110,14 +108,12 @@ END SUBROUTINE block_davidson_env_create !> \param mo_coeff ... !> \param nao ... !> \param nmo ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE block_davidson_allocate(bdav_env,mo_coeff, nao, nmo,error) + SUBROUTINE block_davidson_allocate(bdav_env,mo_coeff, nao, nmo) TYPE(davidson_type) :: bdav_env TYPE(cp_fm_type), POINTER :: mo_coeff INTEGER, INTENT(IN) :: nao, nmo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'block_davidson_allocate', & routineP = moduleN//':'//routineN @@ -134,19 +130,19 @@ SUBROUTINE block_davidson_allocate(bdav_env,mo_coeff, nao, nmo,error) nmox2 = 2*nmo ! CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nmox2, ncol_global=nmox2,& ! para_env=mo_coeff%matrix_struct%para_env, & -! context=mo_coeff%matrix_struct%context,error=error) -! CALL cp_fm_create(bdav_env%H_block_mat,fm_struct_tmp,name="H_dav",error=error) -! CALL cp_fm_create(bdav_env%S_block_mat,fm_struct_tmp,name="S_dav",error=error) -! CALL cp_fm_create(bdav_env%H_block_vec,fm_struct_tmp,name="C_dav",error=error) -! CALL cp_fm_create(bdav_env%W_block_mat,fm_struct_tmp,name="W_dav",error=error) -! CALL cp_fm_struct_release(fm_struct_tmp,error=error) +! context=mo_coeff%matrix_struct%context) +! CALL cp_fm_create(bdav_env%H_block_mat,fm_struct_tmp,name="H_dav") +! CALL cp_fm_create(bdav_env%S_block_mat,fm_struct_tmp,name="S_dav") +! CALL cp_fm_create(bdav_env%H_block_vec,fm_struct_tmp,name="C_dav") +! CALL cp_fm_create(bdav_env%W_block_mat,fm_struct_tmp,name="W_dav") +! CALL cp_fm_struct_release(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=nmo,& para_env=mo_coeff%matrix_struct%para_env, & - context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create(bdav_env%matrix_z,fm_struct_tmp,name="Z_mat",error=error) - CALL cp_fm_create(bdav_env%matrix_pz,fm_struct_tmp,name="Z_mat",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(bdav_env%matrix_z,fm_struct_tmp,name="Z_mat") + CALL cp_fm_create(bdav_env%matrix_pz,fm_struct_tmp,name="Z_mat") + CALL cp_fm_struct_release(fm_struct_tmp) CALL timestop(handle) @@ -155,13 +151,11 @@ END SUBROUTINE block_davidson_allocate ! ***************************************************************************** !> \brief ... !> \param bdav_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE block_davidson_deallocate(bdav_env,error) + SUBROUTINE block_davidson_deallocate(bdav_env) TYPE(davidson_type), DIMENSION(:), & POINTER :: bdav_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'block_davidson_deallocate', & routineP = moduleN//':'//routineN @@ -176,12 +170,12 @@ SUBROUTINE block_davidson_deallocate(bdav_env,error) nspins = SIZE(bdav_env) DO ispin = 1,nspins - CALL cp_fm_release(bdav_env(ispin)%matrix_z,error=error) - CALL cp_fm_release(bdav_env(ispin)%matrix_pz,error=error) -! CALL cp_fm_release(bdav_env(ispin)%H_block_mat,error=error) -! CALL cp_fm_release(bdav_env(ispin)%S_block_mat,error=error) -! CALL cp_fm_release(bdav_env(ispin)%W_block_mat,error=error) -! CALL cp_fm_release(bdav_env(ispin)%H_block_vec,error=error) + CALL cp_fm_release(bdav_env(ispin)%matrix_z) + CALL cp_fm_release(bdav_env(ispin)%matrix_pz) +! CALL cp_fm_release(bdav_env(ispin)%H_block_mat) +! CALL cp_fm_release(bdav_env(ispin)%S_block_mat) +! CALL cp_fm_release(bdav_env(ispin)%W_block_mat) +! CALL cp_fm_release(bdav_env(ispin)%H_block_vec) END DO @@ -192,13 +186,11 @@ END SUBROUTINE block_davidson_deallocate ! ***************************************************************************** !> \brief ... !> \param bdav_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE block_davidson_release(bdav_env,error) + SUBROUTINE block_davidson_release(bdav_env) TYPE(davidson_type), DIMENSION(:), & POINTER :: bdav_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'block_davidson_release', & routineP = moduleN//':'//routineN @@ -214,17 +206,17 @@ SUBROUTINE block_davidson_release(bdav_env,error) DO ispin = 1,nspins IF(ASSOCIATED(bdav_env(ispin)%matrix_z)) THEN - CALL cp_fm_release(bdav_env(ispin)%matrix_z,error=error) - CALL cp_fm_release(bdav_env(ispin)%matrix_pz,error=error) + CALL cp_fm_release(bdav_env(ispin)%matrix_z) + CALL cp_fm_release(bdav_env(ispin)%matrix_pz) END IF -! CALL cp_fm_release(bdav_env(ispin)%H_block_mat,error=error) -! CALL cp_fm_release(bdav_env(ispin)%S_block_mat,error=error) -! CALL cp_fm_release(bdav_env(ispin)%W_block_mat,error=error) -! CALL cp_fm_release(bdav_env(ispin)%H_block_vec,error=error) +! CALL cp_fm_release(bdav_env(ispin)%H_block_mat) +! CALL cp_fm_release(bdav_env(ispin)%S_block_mat) +! CALL cp_fm_release(bdav_env(ispin)%W_block_mat) +! CALL cp_fm_release(bdav_env(ispin)%H_block_vec) END DO DEALLOCATE(bdav_env,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF diff --git a/src/qs_charges_types.F b/src/qs_charges_types.F index 9314a0be2d..8a2b30168b 100644 --- a/src/qs_charges_types.F +++ b/src/qs_charges_types.F @@ -54,19 +54,16 @@ MODULE qs_charges_types !> \param nspins ... !> \param total_rho_core_rspace ... !> \param total_rho_gspace ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE qs_charges_create(qs_charges,nspins,total_rho_core_rspace, & - total_rho_gspace, error) + total_rho_gspace) TYPE(qs_charges_type), POINTER :: qs_charges INTEGER, INTENT(in) :: nspins REAL(KIND=dp), INTENT(in), OPTIONAL :: total_rho_core_rspace, & total_rho_gspace - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_charges_create', & routineP = moduleN//':'//routineN @@ -77,7 +74,7 @@ SUBROUTINE qs_charges_create(qs_charges,nspins,total_rho_core_rspace, & failure=.FALSE. ALLOCATE(qs_charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qs_charges%total_rho_core_rspace=0.0_dp IF (PRESENT(total_rho_core_rspace)) & qs_charges%total_rho_core_rspace=total_rho_core_rspace @@ -89,10 +86,10 @@ SUBROUTINE qs_charges_create(qs_charges,nspins,total_rho_core_rspace, & qs_charges%total_rho_soft_gspace = 0.0_dp qs_charges%background = 0.0_dp ALLOCATE(qs_charges%total_rho1_hard(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qs_charges%total_rho1_hard(:) = 0.0_dp ALLOCATE(qs_charges%total_rho1_soft(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qs_charges%total_rho1_soft(:) = 0.0_dp qs_charges%ref_count=1 END SUBROUTINE qs_charges_create @@ -100,15 +97,12 @@ END SUBROUTINE qs_charges_create ! ***************************************************************************** !> \brief retains the given qs_charges (see cp2k/doc/ReferenceCounting.html) !> \param qs_charges the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE qs_charges_retain(qs_charges, error) +SUBROUTINE qs_charges_retain(qs_charges) TYPE(qs_charges_type), POINTER :: qs_charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_charges_retain', & routineP = moduleN//':'//routineN @@ -117,23 +111,20 @@ SUBROUTINE qs_charges_retain(qs_charges, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qs_charges),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_charges%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_charges),cp_failure_level,routineP,failure) + CPPrecondition(qs_charges%ref_count>0,cp_failure_level,routineP,failure) qs_charges%ref_count=qs_charges%ref_count+1 END SUBROUTINE qs_charges_retain ! ***************************************************************************** !> \brief releases the charges object (see cp2k/doc/ReferenceCounting.html) !> \param qs_charges the object to be released -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE qs_charges_release(qs_charges, error) +SUBROUTINE qs_charges_release(qs_charges) TYPE(qs_charges_type), POINTER :: qs_charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_charges_release', & routineP = moduleN//':'//routineN @@ -144,13 +135,13 @@ SUBROUTINE qs_charges_release(qs_charges, error) failure=.FALSE. IF (ASSOCIATED(qs_charges)) THEN - CPPrecondition(qs_charges%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(qs_charges%ref_count>0,cp_failure_level,routineP,failure) qs_charges%ref_count=qs_charges%ref_count-1 IF (qs_charges%ref_count<1) THEN DEALLOCATE(qs_charges%total_rho1_hard,stat=stat) DEALLOCATE(qs_charges%total_rho1_soft,stat=stat) DEALLOCATE(qs_charges,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(qs_charges) diff --git a/src/qs_collocate_density.F b/src/qs_collocate_density.F index ea540b02f1..7ce495551b 100644 --- a/src/qs_collocate_density.F +++ b/src/qs_collocate_density.F @@ -173,14 +173,12 @@ MODULE qs_collocate_density !> \param scp ... !> \param qs_env ... !> \param scpv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_scp_charge(scp,qs_env,scpv,error) + SUBROUTINE calculate_scp_charge(scp,qs_env,scpv) TYPE(pw_p_type), INTENT(INOUT) :: scp TYPE(qs_environment_type), POINTER :: qs_env TYPE(scp_vector_type), POINTER :: scpv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_scp_charge', & routineP = moduleN//':'//routineN @@ -223,31 +221,31 @@ SUBROUTINE calculate_scp_charge(scp,qs_env,scpv,error) dft_control=dft_control,& cell=cell,& particle_set=particle_set,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) + auxbas_pw_pool=auxbas_pw_pool) cube_info=pw_env%cube_info(1) - CALL rs_grid_retain(rs_rho, error=error) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,defined=defined,lmaxscp=lmaxscp,ag=alpha) IF (.NOT.defined) CYCLE ni = ncoset(lmaxscp) ALLOCATE(pab(ni,1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) nthread = 1 ithread=0 ALLOCATE(cores(natom),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) cores = 0 npme = 0 @@ -289,17 +287,17 @@ SUBROUTINE calculate_scp_charge(scp,qs_env,scpv,error) CALL collocate_pgf_product_rspace(lmaxscp,alpha,0,0,0.0_dp,0,ra,& (/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,1.0_dp,pab,0,0,rs_rho,& cell,cube_info,eps_rho_rspace,ga_gb_function=FUNC_AB,& - ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) END DO DEALLOCATE ( pab, cores, STAT=ierr ) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END DO - CALL rs_pw_transfer(rs_rho,scp%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,scp%pw,rs2pw) + CALL rs_grid_release(rs_rho) CALL timestop(handle) @@ -308,13 +306,11 @@ END SUBROUTINE calculate_scp_charge !> \brief computes the density of the non-linear core correction on the grid !> \param rho_nlcc ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_rho_nlcc(rho_nlcc,qs_env,error) + SUBROUTINE calculate_rho_nlcc(rho_nlcc,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: rho_nlcc TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_nlcc', & routineP = moduleN//':'//routineN @@ -357,19 +353,19 @@ SUBROUTINE calculate_rho_nlcc(rho_nlcc,qs_env,error) cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) + auxbas_pw_pool=auxbas_pw_pool) cube_info=pw_env%cube_info(1) ! be careful in parallel nsmax is choosen with multigrid in mind! - CALL rs_grid_retain(rs_rho, error=error) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential, error=error) + CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential) IF (.NOT.ASSOCIATED(gth_potential)) CYCLE CALL get_potential(potential=gth_potential,nlcc_present=nlcc,nexp_nlcc=nexp_nlcc,& @@ -384,7 +380,7 @@ SUBROUTINE calculate_rho_nlcc(rho_nlcc,qs_env,error) ni = ncoset(2*nc-2) ALLOCATE(pab(ni,1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) pab = 0._dp nthread = 1 @@ -441,7 +437,7 @@ SUBROUTINE calculate_rho_nlcc(rho_nlcc,qs_env,error) n = coset(2,2,2) pab(n,1) = 6._dp*cval_nlcc(4,iexp_nlcc)/alpha**6 CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO IF (dft_control%nspins==2) pab=pab*0.5_dp @@ -471,12 +467,12 @@ SUBROUTINE calculate_rho_nlcc(rho_nlcc,qs_env,error) CALL collocate_pgf_product_rspace(ni,1/(2*alpha**2),0,0,0.0_dp,0,ra,& (/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,1.0_dp,pab,0,0,rs_rho,& cell,cube_info,eps_rho_rspace,ga_gb_function=FUNC_AB,& - ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) END DO DEALLOCATE ( pab, STAT=ierr ) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END DO @@ -484,11 +480,11 @@ SUBROUTINE calculate_rho_nlcc(rho_nlcc,qs_env,error) IF (ASSOCIATED(cores)) THEN DEALLOCATE (cores,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF - CALL rs_pw_transfer(rs_rho,rho_nlcc%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,rho_nlcc%pw,rs2pw) + CALL rs_grid_release(rs_rho) CALL timestop(handle) @@ -498,13 +494,11 @@ END SUBROUTINE calculate_rho_nlcc !> \brief computes the local pseudopotential (without erf term) on the grid !> \param vppl ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_ppl_grid(vppl,qs_env,error) + SUBROUTINE calculate_ppl_grid(vppl,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: vppl TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ppl_grid', & routineP = moduleN//':'//routineN @@ -546,19 +540,19 @@ SUBROUTINE calculate_ppl_grid(vppl,qs_env,error) cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) + auxbas_pw_pool=auxbas_pw_pool) cube_info=pw_env%cube_info(1) ! be careful in parallel nsmax is choosen with multigrid in mind! - CALL rs_grid_retain(rs_rho, error=error) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace DO ikind=1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential, error=error) + CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential) IF (.NOT.ASSOCIATED(gth_potential)) CYCLE CALL get_potential(potential=gth_potential,alpha_ppl=alpha,nexp_ppl=lppl,cexp_ppl=cexp_ppl) @@ -567,7 +561,7 @@ SUBROUTINE calculate_ppl_grid(vppl,qs_env,error) ni = ncoset(2*lppl-2) ALLOCATE(pab(ni,1),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) pab = 0._dp nthread = 1 @@ -624,7 +618,7 @@ SUBROUTINE calculate_ppl_grid(vppl,qs_env,error) n = coset(2,2,2) pab(n,1) = 6._dp*cexp_ppl(4) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO @@ -654,23 +648,23 @@ SUBROUTINE calculate_ppl_grid(vppl,qs_env,error) CALL collocate_pgf_product_rspace(ni,alpha,0,0,0.0_dp,0,ra,& (/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,1.0_dp,pab,0,0,rs_rho,& cell,cube_info,eps_rho_rspace,ga_gb_function=FUNC_AB,& - ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) END DO ENDIF DEALLOCATE ( pab, STAT=ierr ) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END DO IF (ASSOCIATED(cores)) THEN DEALLOCATE (cores,STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) END IF - CALL rs_pw_transfer(rs_rho,vppl%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,vppl%pw,rs2pw) + CALL rs_grid_release(rs_rho) CALL timestop(handle) @@ -681,17 +675,14 @@ END SUBROUTINE calculate_ppl_grid !> \brief Collocates an arbitrary density from the aux_basis_set onto a grid. !> \param total_rho Gives back the integral of the collocated density !> \param qs_env The QS environment of matter -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2005 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env, error) + SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env) REAL(KIND=dp), INTENT(OUT) :: total_rho TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'collocate_atomic_charge_density', & @@ -736,14 +727,14 @@ SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env, error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set, cell=cell, & atomic_kind_set=atomic_kind_set,& particle_set=particle_set, pw_env=pw_env, rho=rho, & - dft_control=dft_control, error=error) + dft_control=dft_control) - CALL qs_rho_get(rho, rho_r=rho_r, rho_g=rho_g, tot_rho_r=tot_rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r, rho_g=rho_g, tot_rho_r=tot_rho_r) cube_info => pw_env%cube_info eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -752,24 +743,22 @@ SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env, error) gridlevel_info=>pw_env%gridlevel_info ! *** set up the pw multi-grids *** ! - CPPrecondition(ASSOCIATED(pw_env), cp_failure_level, routineP, error, failure) - CALL pw_env_get(pw_env=pw_env, rs_grids=rs_rho, pw_pools=pw_pools, error=error) + CPPrecondition(ASSOCIATED(pw_env), cp_failure_level, routineP,failure) + CALL pw_env_get(pw_env=pw_env, rs_grids=rs_rho, pw_pools=pw_pools) CALL pw_pools_create_pws(pw_pools, mgrid_rspace, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) CALL pw_pools_create_pws(pw_pools, mgrid_gspace, & - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) ! *** set up the rs multi-grids *** ! DO igrid_level = 1,gridlevel_info%ngrid_levels - CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid, error=error) + CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid) CALL rs_grid_zero(rs_rho(igrid_level)%rs_grid) END DO - CALL get_qs_kind_set(qs_kind_set=qs_kind_set, maxco=maxco, error=error) + CALL get_qs_kind_set(qs_kind_set=qs_kind_set, maxco=maxco) ALLOCATE (pab(maxco,1),STAT=ierr) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "pab",maxco*dp_size) @@ -780,7 +769,7 @@ SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env, error) DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX") CALL get_gto_basis_set(gto_basis_set=aux_basis_set, lmax=la_max, lmin=la_min, zet=zeta, & nset=nseta, npgf=npgfa, sphi=sphi_a, first_sgf=first_sgfa, nsgf_set=nsgfa) @@ -814,7 +803,7 @@ SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env, error) cube_info=cube_info(igrid_level),& eps_rho_rspace=eps_rho_rspace,& ga_gb_function=FUNC_AB, ithread=ithread, & - map_consistent=map_consistent,use_subpatch=.FALSE.,error=error) + map_consistent=map_consistent,use_subpatch=.FALSE.) END DO END DO END DO @@ -827,30 +816,29 @@ SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env, error) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"work") IF (gridlevel_info%ngrid_levels==1) THEN - CALL rs_pw_transfer(rs=rs_rho(1)%rs_grid, pw=rho_r(1)%pw, dir=rs2pw,error=error) - CALL rs_grid_release(rs_rho(1)%rs_grid, error=error) - CALL pw_transfer(rho_r(1)%pw, rho_g(1)%pw,error=error) + CALL rs_pw_transfer(rs=rs_rho(1)%rs_grid, pw=rho_r(1)%pw, dir=rs2pw) + CALL rs_grid_release(rs_rho(1)%rs_grid) + CALL pw_transfer(rho_r(1)%pw, rho_g(1)%pw) IF (rho_r(1)%pw%pw_grid%spherical) THEN - CALL pw_transfer(rho_g(1)%pw, rho_r(1)%pw,error=error) + CALL pw_transfer(rho_g(1)%pw, rho_r(1)%pw) END IF ELSE DO igrid_level = 1,gridlevel_info%ngrid_levels CALL rs_pw_transfer(rs=rs_rho(igrid_level)%rs_grid, & - pw=mgrid_rspace(igrid_level)%pw, dir=rs2pw, error=error) - CALL rs_grid_release(rs_rho(igrid_level)%rs_grid, error=error) + pw=mgrid_rspace(igrid_level)%pw, dir=rs2pw) + CALL rs_grid_release(rs_rho(igrid_level)%rs_grid) END DO - CALL pw_zero(rho_g(1)%pw,error=error) + CALL pw_zero(rho_g(1)%pw) DO igrid_level=1, gridlevel_info%ngrid_levels CALL pw_transfer(mgrid_rspace(igrid_level)%pw, & - mgrid_gspace(igrid_level)%pw,error=error) - CALL pw_axpy(mgrid_gspace(igrid_level)%pw, rho_g(1)%pw,& - error=error) + mgrid_gspace(igrid_level)%pw) + CALL pw_axpy(mgrid_gspace(igrid_level)%pw, rho_g(1)%pw) END DO - CALL pw_transfer(rho_g(1)%pw, rho_r(1)%pw,error=error) + CALL pw_transfer(rho_g(1)%pw, rho_r(1)%pw) END IF - total_rho = pw_integrate_function(rho_r(1)%pw,isign=-1,error=error) + total_rho = pw_integrate_function(rho_r(1)%pw,isign=-1) tot_rho_r(:) = total_rho unit_nr=cp_logger_get_default_io_unit(logger) IF (unit_nr>0) THEN @@ -858,10 +846,10 @@ SUBROUTINE collocate_atomic_charge_density(total_rho, qs_env, error) END IF ! *** give back the multi-grids *** ! - CALL pw_pools_give_back_pws(pw_pools, mgrid_gspace, error=error) - CALL pw_pools_give_back_pws(pw_pools, mgrid_rspace, error=error) + CALL pw_pools_give_back_pws(pw_pools, mgrid_gspace) + CALL pw_pools_give_back_pws(pw_pools, mgrid_rspace) - CALL qs_rho_set(rho, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) CALL timestop(handle) @@ -874,20 +862,18 @@ END SUBROUTINE collocate_atomic_charge_density !> \param qs_env ... !> \param lri_coef ... !> \param total_rho ... -!> \param error ... !> \par History !> 04.2013 !> \author Dorothea Golze ! ***************************************************************************** SUBROUTINE calculate_lri_rho_elec(lri_rho_g, lri_rho_r, qs_env, & - lri_coef, total_rho, error) + lri_coef, total_rho) TYPE(pw_p_type), INTENT(INOUT) :: lri_rho_g, lri_rho_r TYPE(qs_environment_type), POINTER :: qs_env TYPE(lri_kind_type), DIMENSION(:), & POINTER :: lri_coef REAL(KIND=dp), INTENT(OUT) :: total_rho - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_lri_rho_elec', & routineP = moduleN//':'//routineN @@ -934,13 +920,13 @@ SUBROUTINE calculate_lri_rho_elec(lri_rho_g, lri_rho_r, qs_env, & CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set,& atomic_kind_set=atomic_kind_set,& cell=cell, particle_set=particle_set, & pw_env=pw_env,& - dft_control=dft_control, error=error) + dft_control=dft_control) cube_info => pw_env%cube_info eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -948,28 +934,26 @@ SUBROUTINE calculate_lri_rho_elec(lri_rho_g, lri_rho_r, qs_env, & gridlevel_info=>pw_env%gridlevel_info ! *** set up the pw multi-grids *** ! - CPPrecondition(ASSOCIATED(pw_env), cp_failure_level, routineP, error, failure) - CALL pw_env_get(pw_env=pw_env, rs_grids=rs_rho, pw_pools=pw_pools, error=error) + CPPrecondition(ASSOCIATED(pw_env), cp_failure_level, routineP,failure) + CALL pw_env_get(pw_env=pw_env, rs_grids=rs_rho, pw_pools=pw_pools) CALL pw_pools_create_pws(pw_pools, mgrid_rspace, & use_data=REALDATA3D,& - in_space=REALSPACE, & - error=error) + in_space=REALSPACE) CALL pw_pools_create_pws(pw_pools, mgrid_gspace, & use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) ! *** set up the rs multi-grids *** ! DO igrid_level = 1,gridlevel_info%ngrid_levels - CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid, error=error) + CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid) CALL rs_grid_zero(rs_rho(igrid_level)%rs_grid) END DO !take maxco from the LRI basis set! CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& - maxco=maxco,basis_type="LRI", error=error) + maxco=maxco,basis_type="LRI") ALLOCATE (pab(maxco,1),STAT=ierr) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -981,7 +965,7 @@ SUBROUTINE calculate_lri_rho_elec(lri_rho_g, lri_rho_r, qs_env, & DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI") !Take the lri basis set here! CALL get_gto_basis_set(gto_basis_set=lri_basis_set, lmax=la_max,& @@ -1048,8 +1032,7 @@ SUBROUTINE calculate_lri_rho_elec(lri_rho_g, lri_rho_r, qs_env, & cube_info=cube_info(igrid_level),& eps_rho_rspace=eps_rho_rspace,& ga_gb_function=FUNC_AB, & - map_consistent=map_consistent,& - error=error) + map_consistent=map_consistent) ENDIF END DO @@ -1066,29 +1049,28 @@ SUBROUTINE calculate_lri_rho_elec(lri_rho_g, lri_rho_r, qs_env, & DEALLOCATE (pab,STAT=ierr) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"pab") - CALL pw_zero(lri_rho_g%pw,error=error) - CALL pw_zero(lri_rho_r%pw,error=error) + CALL pw_zero(lri_rho_g%pw) + CALL pw_zero(lri_rho_r%pw) DO igrid_level = 1,gridlevel_info%ngrid_levels - CALL pw_zero(mgrid_rspace(igrid_level)%pw,error=error) + CALL pw_zero(mgrid_rspace(igrid_level)%pw) CALL rs_pw_transfer(rs=rs_rho(igrid_level)%rs_grid, & - pw=mgrid_rspace(igrid_level)%pw, dir=rs2pw, error=error) - CALL rs_grid_release(rs_rho(igrid_level)%rs_grid, error=error) + pw=mgrid_rspace(igrid_level)%pw, dir=rs2pw) + CALL rs_grid_release(rs_rho(igrid_level)%rs_grid) END DO DO igrid_level=1, gridlevel_info%ngrid_levels - CALL pw_zero(mgrid_gspace(igrid_level)%pw,error=error) + CALL pw_zero(mgrid_gspace(igrid_level)%pw) CALL pw_transfer(mgrid_rspace(igrid_level)%pw, & - mgrid_gspace(igrid_level)%pw,error=error) - CALL pw_axpy(mgrid_gspace(igrid_level)%pw, lri_rho_g%pw,& - error=error) + mgrid_gspace(igrid_level)%pw) + CALL pw_axpy(mgrid_gspace(igrid_level)%pw, lri_rho_g%pw) END DO - CALL pw_transfer(lri_rho_g%pw,lri_rho_r%pw,error=error) - total_rho = pw_integrate_function(lri_rho_r%pw,isign=-1,error=error) + CALL pw_transfer(lri_rho_g%pw,lri_rho_r%pw) + total_rho = pw_integrate_function(lri_rho_r%pw,isign=-1) ! *** give back the multi-grids *** ! - CALL pw_pools_give_back_pws(pw_pools, mgrid_gspace, error=error) - CALL pw_pools_give_back_pws(pw_pools, mgrid_rspace, error=error) + CALL pw_pools_give_back_pws(pw_pools, mgrid_gspace) + CALL pw_pools_give_back_pws(pw_pools, mgrid_rspace) CALL timestop(handle) @@ -1100,15 +1082,13 @@ END SUBROUTINE calculate_lri_rho_elec !> \param total_rho ... !> \param qs_env ... !> \param only_nopaw ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_rho_core(rho_core,total_rho,qs_env,only_nopaw,error) + SUBROUTINE calculate_rho_core(rho_core,total_rho,qs_env,only_nopaw) TYPE(pw_p_type), INTENT(INOUT) :: rho_core REAL(KIND=dp), INTENT(OUT) :: total_rho TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN), OPTIONAL :: only_nopaw - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_core', & routineP = moduleN//':'//routineN @@ -1152,12 +1132,12 @@ SUBROUTINE calculate_rho_core(rho_core,total_rho,qs_env,only_nopaw,error) cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) + auxbas_pw_pool=auxbas_pw_pool) cube_info=pw_env%cube_info(1) ! be careful in parallel nsmax is choosen with multigrid in mind! - CALL rs_grid_retain(rs_rho, error=error) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -1165,7 +1145,7 @@ SUBROUTINE calculate_rho_core(rho_core,total_rho,qs_env,only_nopaw,error) DO ikind=1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom,& - alpha_core_charge=alpha, ccore_charge=pab(1,1), error=error) + alpha_core_charge=alpha, ccore_charge=pab(1,1)) IF(my_only_nopaw .AND. paw_atom ) CYCLE IF (alpha == 0.0_dp .OR. pab(1,1)== 0.0_dp) CYCLE @@ -1202,7 +1182,7 @@ SUBROUTINE calculate_rho_core(rho_core,total_rho,qs_env,only_nopaw,error) CALL collocate_pgf_product_rspace(0,alpha,0,0,0.0_dp,0,ra,& (/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,-1.0_dp,pab,0,0,rs_rho,& cell,cube_info,eps_rho_rspace,ga_gb_function=FUNC_AB,& - ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + ithread=ithread,use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) END DO ENDIF @@ -1217,16 +1197,16 @@ SUBROUTINE calculate_rho_core(rho_core,total_rho,qs_env,only_nopaw,error) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"pab") CALL pw_pool_create_pw(auxbas_pw_pool, rhoc_r%pw, & - use_data=REALDATA3D,in_space=REALSPACE, error=error) + use_data=REALDATA3D,in_space=REALSPACE) - CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw) + CALL rs_grid_release(rs_rho) - total_rho = pw_integrate_function(rhoc_r%pw,isign=-1,error=error) + total_rho = pw_integrate_function(rhoc_r%pw,isign=-1) - CALL pw_transfer(rhoc_r%pw,rho_core%pw,error=error) + CALL pw_transfer(rhoc_r%pw,rho_core%pw) - CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw) CALL timestop(handle) @@ -1237,18 +1217,15 @@ END SUBROUTINE calculate_rho_core !> \param rho_gb charge density generated by a single gaussian !> \param qs_env qs environment !> \param iatom_in atom index -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2011 created !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE calculate_rho_single_gaussian(rho_gb,qs_env,iatom_in,error) + SUBROUTINE calculate_rho_single_gaussian(rho_gb,qs_env,iatom_in) TYPE(pw_p_type), INTENT(INOUT) :: rho_gb TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iatom_in - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'calculate_rho_single_gaussian', & @@ -1276,10 +1253,10 @@ SUBROUTINE calculate_rho_single_gaussian(rho_gb,qs_env,iatom_in,error) CALL get_qs_env(qs_env=qs_env,& cell=cell,& dft_control=dft_control,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL rs_grid_retain(rs_rho, error=error) + auxbas_pw_pool=auxbas_pw_pool) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -1303,21 +1280,21 @@ SUBROUTINE calculate_rho_single_gaussian(rho_gb,qs_env,iatom_in,error) CALL collocate_pgf_product_rspace(0,qs_env%qmmm_env_qm%image_charge_pot%eta,& 0,0,0.0_dp,0,ra,(/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,1.0_dp,pab,0,0,rs_rho,& cell,pw_env%cube_info(1),eps_rho_rspace,ga_gb_function=FUNC_AB,& - use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) ENDIF DEALLOCATE (pab,STAT=ierr) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"pab") CALL pw_pool_create_pw(auxbas_pw_pool, rhoc_r%pw, & - use_data=REALDATA3D,in_space=REALSPACE, error=error) + use_data=REALDATA3D,in_space=REALSPACE) - CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw) + CALL rs_grid_release(rs_rho) - CALL pw_transfer(rhoc_r%pw,rho_gb%pw,error=error) + CALL pw_transfer(rhoc_r%pw,rho_gb%pw) - CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw) CALL timestop(handle) @@ -1330,19 +1307,16 @@ END SUBROUTINE calculate_rho_single_gaussian !> rho_metal=sum_a c_a*g_a !> \param total_rho_metal total induced image charge density !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2012 created !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE calculate_rho_metal(rho_metal,coeff,total_rho_metal,qs_env,error) + SUBROUTINE calculate_rho_metal(rho_metal,coeff,total_rho_metal,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: rho_metal REAL(KIND=dp), DIMENSION(:), POINTER :: coeff REAL(KIND=dp), INTENT(OUT), OPTIONAL :: total_rho_metal TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_metal', & routineP = moduleN//':'//routineN @@ -1372,10 +1346,10 @@ SUBROUTINE calculate_rho_metal(rho_metal,coeff,total_rho_metal,qs_env,error) CALL get_qs_env(qs_env=qs_env,& cell=cell,& dft_control=dft_control,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL rs_grid_retain(rs_rho, error=error) + auxbas_pw_pool=auxbas_pw_pool) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -1408,7 +1382,7 @@ SUBROUTINE calculate_rho_metal(rho_metal,coeff,total_rho_metal,qs_env,error) CALL collocate_pgf_product_rspace(0,qs_env%qmmm_env_qm%image_charge_pot%eta,& 0,0,0.0_dp,0,ra,(/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,coeff(iatom),pab,0,0,rs_rho,& cell,pw_env%cube_info(1),eps_rho_rspace,ga_gb_function=FUNC_AB,& - use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) ENDDO ENDIF @@ -1416,17 +1390,17 @@ SUBROUTINE calculate_rho_metal(rho_metal,coeff,total_rho_metal,qs_env,error) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"pab") CALL pw_pool_create_pw(auxbas_pw_pool, rhoc_r%pw, & - use_data=REALDATA3D,in_space=REALSPACE, error=error) + use_data=REALDATA3D,in_space=REALSPACE) - CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw) + CALL rs_grid_release(rs_rho) IF(PRESENT(total_rho_metal)) & !minus sign: account for the fact that rho_metal has opposite sign - total_rho_metal = pw_integrate_function(rhoc_r%pw,isign=-1,error=error) + total_rho_metal = pw_integrate_function(rhoc_r%pw,isign=-1) - CALL pw_transfer(rhoc_r%pw,rho_metal%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw, error=error) + CALL pw_transfer(rhoc_r%pw,rho_metal%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw) CALL timestop(handle) @@ -1438,19 +1412,16 @@ END SUBROUTINE calculate_rho_metal !> \param qs_env qs environment !> \param eta width of single Gaussian !> \param iatom_in atom index -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2012 created !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE calculate_rho_resp_single(rho_gb,qs_env,eta,iatom_in,error) + SUBROUTINE calculate_rho_resp_single(rho_gb,qs_env,eta,iatom_in) TYPE(pw_p_type), INTENT(INOUT) :: rho_gb TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), INTENT(IN) :: eta INTEGER, INTENT(IN) :: iatom_in - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_resp_single', & routineP = moduleN//':'//routineN @@ -1480,10 +1451,10 @@ SUBROUTINE calculate_rho_resp_single(rho_gb,qs_env,eta,iatom_in,error) cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL rs_grid_retain(rs_rho, error=error) + auxbas_pw_pool=auxbas_pw_pool) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -1506,21 +1477,21 @@ SUBROUTINE calculate_rho_resp_single(rho_gb,qs_env,eta,iatom_in,error) CALL collocate_pgf_product_rspace(0,eta,0,0,0.0_dp,0,ra,& (/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,1.0_dp,pab,0,0,rs_rho,& cell,pw_env%cube_info(1),eps_rho_rspace,ga_gb_function=FUNC_AB,& - use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) ENDIF DEALLOCATE (pab,STAT=ierr) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"pab") CALL pw_pool_create_pw(auxbas_pw_pool, rhoc_r%pw, & - use_data=REALDATA3D,in_space=REALSPACE, error=error) + use_data=REALDATA3D,in_space=REALSPACE) - CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw) + CALL rs_grid_release(rs_rho) - CALL pw_transfer(rhoc_r%pw,rho_gb%pw,error=error) + CALL pw_transfer(rhoc_r%pw,rho_gb%pw) - CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw) CALL timestop(handle) @@ -1534,20 +1505,17 @@ END SUBROUTINE calculate_rho_resp_single !> \param natom number of atoms !> \param eta width of single Gaussian !> \param qs_env qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2012 created !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE calculate_rho_resp_all(rho_resp,coeff,natom,eta,qs_env,error) + SUBROUTINE calculate_rho_resp_all(rho_resp,coeff,natom,eta,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: rho_resp REAL(KIND=dp), DIMENSION(:), POINTER :: coeff INTEGER, INTENT(IN) :: natom REAL(KIND=dp), INTENT(IN) :: eta TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_resp_all', & routineP = moduleN//':'//routineN @@ -1580,10 +1548,10 @@ SUBROUTINE calculate_rho_resp_all(rho_resp,coeff,natom,eta,qs_env,error) cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_grid=rs_rho,& - auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL rs_grid_retain(rs_rho, error=error) + auxbas_pw_pool=auxbas_pw_pool) + CALL rs_grid_retain(rs_rho) CALL rs_grid_zero(rs_rho) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace @@ -1613,7 +1581,7 @@ SUBROUTINE calculate_rho_resp_all(rho_resp,coeff,natom,eta,qs_env,error) CALL collocate_pgf_product_rspace(0,eta,& 0,0,0.0_dp,0,ra,(/0.0_dp,0.0_dp,0.0_dp/),0.0_dp,coeff(iatom),pab,0,0,rs_rho,& cell,pw_env%cube_info(1),eps_rho_rspace,ga_gb_function=FUNC_AB,& - use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern,error=error) + use_subpatch=.TRUE.,subpatch_pattern=subpatch_pattern) ENDDO ENDIF @@ -1621,13 +1589,13 @@ SUBROUTINE calculate_rho_resp_all(rho_resp,coeff,natom,eta,qs_env,error) IF (ierr /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"pab") CALL pw_pool_create_pw(auxbas_pw_pool, rhoc_r%pw, & - use_data=REALDATA3D,in_space=REALSPACE, error=error) + use_data=REALDATA3D,in_space=REALSPACE) - CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho, error=error) + CALL rs_pw_transfer(rs_rho,rhoc_r%pw,rs2pw) + CALL rs_grid_release(rs_rho) - CALL pw_transfer(rhoc_r%pw,rho_resp%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw, error=error) + CALL pw_transfer(rhoc_r%pw,rho_resp%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool, rhoc_r%pw) CALL timestop(handle) @@ -1649,7 +1617,6 @@ END SUBROUTINE calculate_rho_resp_all !> \param idir ... !> \param task_list_external ... !> \param pw_env_external ... -!> \param error ... !> \par History !> IAB (15-Feb-2010): Added OpenMP parallelisation to task loop !> (c) The Numerical Algorithms Group (NAG) Ltd, 2010 on behalf of the HECToR project @@ -1659,7 +1626,7 @@ END SUBROUTINE calculate_rho_resp_all ! ***************************************************************************** SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho,& ks_env, soft_valid, compute_tau, compute_grad, & - basis_type, der_type, idir, task_list_external, pw_env_external, error) + basis_type, der_type, idir, task_list_external, pw_env_external) TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_p TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -1673,7 +1640,6 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, INTEGER, INTENT(IN), OPTIONAL :: der_type, idir TYPE(task_list_type), OPTIONAL, POINTER :: task_list_external TYPE(pw_env_type), OPTIONAL, POINTER :: pw_env_external - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_elec', & routineP = moduleN//':'//routineN @@ -1729,7 +1695,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(PRESENT(matrix_p).OR.PRESENT(matrix_p_kp),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrix_p).OR.PRESENT(matrix_p_kp),cp_failure_level,routineP,failure) do_kp = PRESENT(matrix_p_kp) NULLIFY(qs_kind, cell, dft_control, orb_basis_set, deltap, & @@ -1784,24 +1750,21 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) SELECT CASE (my_basis_type) CASE ("ORB") CALL get_ks_env(ks_env,& task_list=task_list,& - task_list_soft=task_list_soft,& - error=error) + task_list_soft=task_list_soft) CASE ("AUX_FIT") CALL get_ks_env(ks_env,& task_list_aux_fit=task_list,& - task_list_soft=task_list_soft,& - error=error) + task_list_soft=task_list_soft) END SELECT nimages = dft_control%nimages - CPPrecondition(nimages==1.OR.do_kp,cp_failure_level,routineP,error,failure) + CPPrecondition(nimages==1.OR.do_kp,cp_failure_level,routineP,failure) IF (PRESENT(pw_env_external)) pw_env => pw_env_external IF (PRESENT(task_list_external)) task_list=>task_list_external @@ -1817,7 +1780,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, maxco=maxco,& maxsgf=maxsgf,& maxsgf_set=maxsgf_set,& - basis_type=my_basis_type, error=error) + basis_type=my_basis_type) CALL reallocate(pabt,1,maxco,1,maxco,0,nthread-1) CALL reallocate(workt,1,maxco,1,maxsgf_set,0,nthread-1) @@ -1829,7 +1792,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, qs_kind => qs_kind_set(ikind) CALL get_qs_kind(qs_kind=qs_kind,& softb = my_soft, & - basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + basis_set=orb_basis_set, basis_type=my_basis_type) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE @@ -1842,7 +1805,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ! get the task lists IF (my_soft) task_list=>task_list_soft - CPPrecondition(ASSOCIATED(task_list),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(task_list),cp_failure_level,routineP,failure) tasks =>task_list%tasks dist_ab=>task_list%dist_ab atom_pair_send=>task_list%atom_pair_send @@ -1850,16 +1813,16 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ntasks=task_list%ntasks ! *** set up the pw multi-grids - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_rho, lgrid=lgrid, error=error) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_rho, lgrid=lgrid) ! *** set up the rs multi-grids - CPPrecondition(ASSOCIATED(rs_rho),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rs_descs),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(lgrid),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rs_rho),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rs_descs),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(lgrid),cp_failure_level,routineP,failure) distributed_rs_grids=.FALSE. DO igrid_level=1,gridlevel_info%ngrid_levels - CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid, error=error) + CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid) CALL rs_grid_zero(rs_rho(igrid_level)%rs_grid) IF ( rs_rho(igrid_level)%rs_grid%desc%distributed ) THEN distributed_rs_grids=.TRUE. @@ -1868,7 +1831,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, IF ( nthread > 1 ) THEN IF (.NOT. ASSOCIATED(lgrid%r)) THEN - CALL lgrid_allocate_grid(lgrid, nthread, error) + CALL lgrid_allocate_grid(lgrid, nthread) ENDIF END IF @@ -1879,22 +1842,22 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ! distributed rs grids require a matrix that will be changed ! whereas this is not the case for replicated grids NULLIFY(deltap) - CALL cp_dbcsr_allocate_matrix_set(deltap,nimages,error=error) + CALL cp_dbcsr_allocate_matrix_set(deltap,nimages) IF (distributed_rs_grids) THEN DO img=1,nimages ALLOCATE(deltap(img)%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(deltap(img)%matrix, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(deltap(img)%matrix) END DO ! this matrix has no strict sparsity pattern in parallel ! deltap%sparsity_id=-1 IF(do_kp) THEN DO img=1,nimages CALL cp_dbcsr_copy(deltap(img)%matrix,matrix_p_kp(img)%matrix,& - name="DeltaP",error=error) + name="DeltaP") END DO ELSE - CALL cp_dbcsr_copy(deltap(1)%matrix,matrix_p,name="DeltaP",error=error) + CALL cp_dbcsr_copy(deltap(1)%matrix,matrix_p,name="DeltaP") END IF ELSE IF(do_kp) THEN @@ -1909,7 +1872,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ! distribute the matrix IF (distributed_rs_grids) THEN CALL rs_distribute_matrix (rs_descs, deltap, atom_pair_send, atom_pair_recv, & - natoms, nimages, scatter=.TRUE., error=error) + natoms, nimages, scatter=.TRUE.) ENDIF ! map all tasks on the grids @@ -1925,7 +1888,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, !$omp private(npgfa,nseta,nsgfa,sphi_a,zeta,first_sgfb,lb_max,lb_min,npgfb), & !$omp private(nsetb,nsgfb,sphi_b,zetb,p_block,found), & !$omp private(atom_pair_changed,ncoa,sgfa,ncob,sgfb,rab,rab2,ra,rb,zetp), & -!$omp private(na1,na2,nb1,nb2,scale,use_subpatch,rab_inv,ithread,error,failure,lb,ub,n), & +!$omp private(na1,na2,nb1,nb2,scale,use_subpatch,rab_inv,ithread,failure,lb,ub,n), & !$omp private(itask,nz,nxy,nzsize,nrlevel,nblock,lbw,lbr,nr,igrid_level_dummy) ithread = 0 @@ -1970,7 +1933,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, IF(ikind .NE. ikind_old ) THEN CALL get_qs_kind(qs_kind_set(ikind), softb = my_soft, & - basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + basis_set=orb_basis_set, basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfa,& lmax=la_max,& @@ -1984,7 +1947,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, IF (jkind .NE. jkind_old ) THEN CALL get_qs_kind(qs_kind_set(jkind), softb = my_soft, & - basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + basis_set=orb_basis_set, basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfb,& lmax=lb_max,& @@ -1998,7 +1961,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, CALL cp_dbcsr_get_block_p(matrix=deltap(img)%matrix,& row=brow,col=bcol,BLOCK=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) iatom_old = iatom jatom_old = jatom @@ -2084,7 +2047,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, idir=my_idir,& lgrid=lgrid,ithread=ithread, & map_consistent=map_consistent,use_subpatch=use_subpatch,& - subpatch_pattern=tasks(6,itask),error=error) + subpatch_pattern=tasks(6,itask)) ELSE rab_inv=-rab CALL collocate_pgf_product_rspace(& @@ -2097,7 +2060,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, idir=my_idir,& lgrid=lgrid,ithread=ithread, & map_consistent=map_consistent,use_subpatch=use_subpatch,& - subpatch_pattern=tasks(6,itask),error=error) + subpatch_pattern=tasks(6,itask)) END IF ELSE IF (iatom <= jatom) THEN @@ -2110,7 +2073,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ga_gb_function=ga_gb_function, & idir=my_idir,& map_consistent=map_consistent,use_subpatch=use_subpatch,& - subpatch_pattern=tasks(6,itask),error=error) + subpatch_pattern=tasks(6,itask)) ELSE rab_inv=-rab CALL collocate_pgf_product_rspace(& @@ -2122,7 +2085,7 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ga_gb_function=ga_gb_function, & idir=my_idir,& map_consistent=map_consistent,use_subpatch=use_subpatch,& - subpatch_pattern=tasks(6,itask),error=error) + subpatch_pattern=tasks(6,itask)) END IF END IF END DO loop_tasks @@ -2181,21 +2144,21 @@ SUBROUTINE calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ! *** Release work storage *** IF (distributed_rs_grids) THEN - CALL cp_dbcsr_deallocate_matrix_set ( deltap ,error=error) + CALL cp_dbcsr_deallocate_matrix_set ( deltap) ELSE DO img=1,nimages NULLIFY(deltap(img)%matrix) END DO DEALLOCATE (deltap,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE (pabt,workt,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL density_rs2pw(pw_env,rs_rho,rho,rho_gspace,error=error) + CALL density_rs2pw(pw_env,rs_rho,rho,rho_gspace) - total_rho = pw_integrate_function(rho%pw,isign=-1,error=error) + total_rho = pw_integrate_function(rho%pw,isign=-1) CALL timestop(handle) @@ -2211,11 +2174,10 @@ END SUBROUTINE calculate_rho_elec !> \param qs_env ... !> \param soft_valid ... !> \param basis_type ... -!> \param error ... !> \note this is an alternative to calculate the gradient through FFTs ! ***************************************************************************** SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& - soft_valid, basis_type,error) + soft_valid, basis_type) TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_p TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -2225,7 +2187,6 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN), OPTIONAL :: soft_valid CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: basis_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_drho_elec', & routineP = moduleN//':'//routineN @@ -2280,7 +2241,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& failure=.FALSE. - CPPrecondition(PRESENT(matrix_p).OR.PRESENT(matrix_p_kp),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrix_p).OR.PRESENT(matrix_p_kp),cp_failure_level,routineP,failure) do_kp = PRESENT(matrix_p_kp) NULLIFY(qs_kind, cell, dft_control, orb_basis_set, deltap, & @@ -2308,20 +2269,17 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& dft_control=dft_control,& particle_set=particle_set,& sab_orb=sab_orb,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) SELECT CASE (my_basis_type) CASE ("ORB") CALL get_qs_env(qs_env=qs_env,& task_list=task_list,& - task_list_soft=task_list_soft,& - error=error) + task_list_soft=task_list_soft) CASE ("AUX_FIT") CALL get_qs_env(qs_env=qs_env,& task_list_aux_fit=task_list,& - task_list_soft=task_list_soft,& - error=error) + task_list_soft=task_list_soft) END SELECT ! *** assign from pw_env @@ -2334,13 +2292,13 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& maxco=maxco,& maxsgf=maxsgf,& maxsgf_set=maxsgf_set,& - basis_type=my_basis_type, error=error) + basis_type=my_basis_type) CALL reallocate(pabt,1,maxco,1,maxco,0,nthread-1) CALL reallocate(workt,1,maxco,1,maxsgf_set,0,nthread-1) ! find maximum numbers nimages = dft_control%nimages - CPPrecondition((nimages==1 .OR. do_kp),cp_failure_level,routineP,error,failure) + CPPrecondition((nimages==1 .OR. do_kp),cp_failure_level,routineP,failure) natoms = SIZE( particle_set ) maxset=0 @@ -2349,7 +2307,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& qs_kind => qs_kind_set(ikind) CALL get_qs_kind(qs_kind=qs_kind,& softb = my_soft, & - basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + basis_set=orb_basis_set, basis_type=my_basis_type) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE @@ -2362,7 +2320,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& ! get the task lists IF (my_soft) task_list=>task_list_soft - CPPrecondition(ASSOCIATED(task_list),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(task_list),cp_failure_level,routineP,failure) tasks =>task_list%tasks dist_ab=>task_list%dist_ab atom_pair_send=>task_list%atom_pair_send @@ -2370,10 +2328,10 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& ntasks=task_list%ntasks ! *** set up the rs multi-grids - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_rho, error=error) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_rho) DO igrid_level=1,gridlevel_info%ngrid_levels - CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid, error=error) + CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid) distributed_rs_grids=rs_rho(igrid_level)%rs_grid%desc%distributed END DO @@ -2384,20 +2342,20 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& ! distributed rs grids require a matrix that will be changed ! whereas this is not the case for replicated grids ALLOCATE(deltap(nimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (distributed_rs_grids) THEN DO img=1,nimages - CALL cp_dbcsr_init(deltap(img)%matrix, error=error) + CALL cp_dbcsr_init(deltap(img)%matrix) END DO ! this matrix has no strict sparsity pattern in parallel ! deltap%sparsity_id=-1 IF(do_kp) THEN DO img=1,nimages CALL cp_dbcsr_copy(deltap(img)%matrix,matrix_p_kp(img)%matrix,& - name="DeltaP",error=error) + name="DeltaP") END DO ELSE - CALL cp_dbcsr_copy(deltap(1)%matrix,matrix_p,name="DeltaP",error=error) + CALL cp_dbcsr_copy(deltap(1)%matrix,matrix_p,name="DeltaP") END IF ELSE IF(do_kp) THEN @@ -2412,7 +2370,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& ! distribute the matrix IF (distributed_rs_grids) THEN CALL rs_distribute_matrix (rs_descs, deltap, atom_pair_send, atom_pair_recv, & - natoms, nimages, scatter=.TRUE., error=error) + natoms, nimages, scatter=.TRUE.) ENDIF ! map all tasks on the grids @@ -2452,7 +2410,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& IF(ikind .NE. ikind_old ) THEN CALL get_qs_kind(qs_kind_set(ikind), softb = my_soft, & - basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + basis_set=orb_basis_set, basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfa,& lmax=la_max,& @@ -2466,7 +2424,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& IF (jkind .NE. jkind_old ) THEN CALL get_qs_kind(qs_kind_set(jkind), softb = my_soft, & - basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + basis_set=orb_basis_set, basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfb,& lmax=lb_max,& @@ -2480,7 +2438,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& CALL cp_dbcsr_get_block_p(matrix=deltap(img)%matrix,& row=brow,col=bcol,BLOCK=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) iatom_old = iatom jatom_old = jatom @@ -2564,7 +2522,7 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& eps_rho_rspace,& ga_gb_function=FUNC_DABpADB, & idir=idir, & - map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask),error=error) + map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask)) ELSE rab_inv=-rab CALL collocate_pgf_product_rspace(& @@ -2575,34 +2533,34 @@ SUBROUTINE calculate_drho_elec(matrix_p,matrix_p_kp,drho,drho_gspace,qs_env,& eps_rho_rspace,& ga_gb_function=FUNC_DABpADB, & idir=idir, & - map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask),error=error) + map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask)) END IF END DO loop_tasks - CALL density_rs2pw_basic(pw_env,rs_rho,drho(idir),drho_gspace(idir),error=error) + CALL density_rs2pw_basic(pw_env,rs_rho,drho(idir),drho_gspace(idir)) END DO loop_xyz ! *** Release work storage *** IF (ASSOCIATED(rs_rho)) THEN DO i=1, SIZE(rs_rho) - CALL rs_grid_release(rs_rho(i)%rs_grid, error=error) + CALL rs_grid_release(rs_rho(i)%rs_grid) END DO END IF IF (distributed_rs_grids) THEN - CALL cp_dbcsr_deallocate_matrix_set ( deltap ,error=error) + CALL cp_dbcsr_deallocate_matrix_set ( deltap) ELSE DO img=1,nimages NULLIFY(deltap(img)%matrix) END DO DEALLOCATE (deltap,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE (pabt,workt,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -2622,7 +2580,6 @@ END SUBROUTINE calculate_drho_elec !> \param pw_env ... !> \param basis_type ... !> \param external_vector ... -!> \param error ... !> \par History !> 08.2002 created [Joost VandeVondele] !> 03.2006 made independent of qs_env [Joost VandeVondele] @@ -2636,7 +2593,7 @@ END SUBROUTINE calculate_drho_elec ! ***************************************************************************** SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & atomic_kind_set,qs_kind_set,cell,dft_control,particle_set, & - pw_env, basis_type,external_vector,error) + pw_env, basis_type,external_vector) TYPE(cp_fm_type), POINTER :: mo_vectors INTEGER :: ivector @@ -2652,7 +2609,6 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & TYPE(pw_env_type), POINTER :: pw_env CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: basis_type REAL(KIND=dp), DIMENSION(:), OPTIONAL :: external_vector - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_wavefunction', & routineP = moduleN//':'//routineN @@ -2703,7 +2659,7 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & IF (stat.NE.0) CALL stop_memory(routineN,moduleN,__LINE__,"eigenvector",dp_size*nao) eigenvector=external_vector ELSE - CALL cp_fm_get_info(matrix=mo_vectors,nrow_global=nao, error=error) + CALL cp_fm_get_info(matrix=mo_vectors,nrow_global=nao) ALLOCATE (eigenvector(nao),STAT=stat) IF (stat.NE.0) CALL stop_memory(routineN,moduleN,__LINE__,"eigenvector",dp_size*nao) DO i=1,nao @@ -2712,20 +2668,20 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & ENDIF ! *** set up the pw multi-grids - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) CALL pw_env_get(pw_env, rs_grids=rs_rho, pw_pools=pw_pools, & - cube_info=cube_info, gridlevel_info=gridlevel_info, error=error) + cube_info=cube_info, gridlevel_info=gridlevel_info) CALL pw_pools_create_pws(pw_pools,mgrid_gspace,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pools_create_pws(pw_pools,mgrid_rspace,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) ! *** set up rs multi-grids DO igrid_level=1,gridlevel_info%ngrid_levels - CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid, error=error) + CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid) CALL rs_grid_zero(rs_rho(igrid_level)%rs_grid) END DO @@ -2736,7 +2692,7 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & CALL get_qs_kind_set(qs_kind_set,& maxco=maxco,& maxsgf_set=maxsgf_set,& - basis_type=my_basis_type, error=error) + basis_type=my_basis_type) ALLOCATE (pab(maxco,1),STAT=stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -2753,7 +2709,7 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & DO iatom=1,natom ikind = particle_set(iatom)%atomic_kind%kind_number - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfa,& lmax=la_max,& @@ -2823,7 +2779,7 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & 0,0.0_dp,0,& ra,rab,rab2,scale,pab,na1-1,0,& rs_rho(igrid_level)%rs_grid,cell,cube_info(igrid_level),& - eps_rho_rspace,map_consistent=.TRUE.,ga_gb_function=FUNC_AB,error=error) + eps_rho_rspace,map_consistent=.TRUE.,ga_gb_function=FUNC_AB) END DO @@ -2835,19 +2791,18 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & DO igrid_level=1,gridlevel_info%ngrid_levels CALL rs_pw_transfer(rs_rho(igrid_level)%rs_grid,& - mgrid_rspace(igrid_level)%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho(igrid_level)%rs_grid, error=error) + mgrid_rspace(igrid_level)%pw,rs2pw) + CALL rs_grid_release(rs_rho(igrid_level)%rs_grid) ENDDO - CALL pw_zero(rho_gspace%pw,error=error) + CALL pw_zero(rho_gspace%pw) DO igrid_level=1,gridlevel_info%ngrid_levels CALL pw_transfer(mgrid_rspace(igrid_level)%pw,& - mgrid_gspace(igrid_level)%pw,error=error) - CALL pw_axpy(mgrid_gspace(igrid_level)%pw,rho_gspace%pw,& - error=error) + mgrid_gspace(igrid_level)%pw) + CALL pw_axpy(mgrid_gspace(igrid_level)%pw,rho_gspace%pw) END DO - CALL pw_transfer(rho_gspace%pw,rho%pw,error=error) + CALL pw_transfer(rho_gspace%pw,rho%pw) ! Release work storage DEALLOCATE (eigenvector,STAT=stat) @@ -2860,8 +2815,8 @@ SUBROUTINE calculate_wavefunction(mo_vectors,ivector,rho,rho_gspace, & IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"work") ! give back the pw multi-grids - CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace,error=error) - CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace,error=error) + CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace) + CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace) CALL timestop(handle) @@ -2898,7 +2853,6 @@ END SUBROUTINE calculate_wavefunction !> \param rsbuf ... !> \param use_subpatch ... !> \param subpatch_pattern ... -!> \param error ... ! ***************************************************************************** SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& lb_max,zetb,lb_min,& @@ -2909,7 +2863,7 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& map_consistent,& collocate_rho0,& rpgf0_s,idir,ir,rsgauge,rsbuf,& - use_subpatch,subpatch_pattern,error) + use_subpatch,subpatch_pattern) INTEGER, INTENT(IN) :: la_max REAL(KIND=dp), INTENT(IN) :: zeta @@ -2933,7 +2887,6 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& TYPE(realspace_grid_type), POINTER, OPTIONAL :: rsgauge,rsbuf LOGICAL, OPTIONAL :: use_subpatch INTEGER(KIND=int_8), OPTIONAL, INTENT(IN):: subpatch_pattern - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'collocate_pgf_product_rspace', & routineP = moduleN//':'//routineN @@ -2976,7 +2929,7 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& IF(PRESENT(use_subpatch)) THEN IF(use_subpatch)THEN subpatch_collocate = .TRUE. - CPPrecondition(PRESENT(subpatch_pattern),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(subpatch_pattern),cp_failure_level,routineP,failure) ENDIF ENDIF @@ -3062,7 +3015,7 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& o2_local=0 pab_local=pab_local * 0.5_dp CASE(FUNC_ADBmDAB) - CPPrecondition(PRESENT(idir),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(idir),cp_failure_level,routineP,failure) la_max_local=la_max+1 la_min_local=MAX(la_min-1,0) lb_max_local=lb_max+1 @@ -3094,7 +3047,7 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& o1_local=0 o2_local=0 CASE(FUNC_DABpADB) - CPPrecondition(PRESENT(idir),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(idir),cp_failure_level,routineP,failure) la_max_local=la_max+1 la_min_local=MAX(la_min-1,0) lb_max_local=lb_max+1 @@ -3217,8 +3170,8 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& o1_local=0 o2_local=0 CASE(FUNC_ARDBmDARB) - CPPrecondition(PRESENT(idir),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(ir),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(idir),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(ir),cp_failure_level,routineP,failure) la_max_local=la_max+1 la_min_local=MAX(la_min-1,0) lb_max_local=lb_max+2 @@ -3251,7 +3204,7 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& o1_local=0 o2_local=0 CASE(FUNC_ARB) - CPPrecondition(PRESENT(ir),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(ir),cp_failure_level,routineP,failure) la_max_local=la_max la_min_local=la_min lb_max_local=lb_max+1 @@ -3286,7 +3239,7 @@ SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,& o1_local=o1 o2_local=o2 CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ng(:) = rsgrid%desc%npts(:) @@ -3490,7 +3443,7 @@ SUBROUTINE collocate_ortho() offset=MODULO(cubecenter(i)+lb_cube(i)+rsgrid%desc%lb(i)-rsgrid%lb_local(i),ng(i))+1-lb_cube(i) ! check for out of bounds IF (ub_cube(i)+offset>UBOUND(grid,i).OR.lb_cube(i)+offset \param pmat ... !> \param ecore ... !> \param nspin ... -!> \param error ... !> \date 29.07.2014 !> \par History !> - none !> \author JGH !> \version 1.0 ! ***************************************************************************** - SUBROUTINE calculate_ptrace_gamma(hmat,pmat,ecore,nspin,error) + SUBROUTINE calculate_ptrace_gamma(hmat,pmat,ecore,nspin) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: hmat, pmat REAL(KIND=dp), INTENT(OUT) :: ecore INTEGER, INTENT(IN) :: nspin - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ptrace_gamma', & routineP = moduleN//':'//routineN @@ -99,7 +97,7 @@ SUBROUTINE calculate_ptrace_gamma(hmat,pmat,ecore,nspin,error) ecore = 0.0_dp DO ispin=1,nspin etr=0.0_dp - CALL cp_dbcsr_trace(hmat(1)%matrix,pmat(ispin)%matrix,etr,error=error) + CALL cp_dbcsr_trace(hmat(1)%matrix,pmat(ispin)%matrix,etr) ecore = ecore + etr END DO @@ -115,18 +113,16 @@ END SUBROUTINE calculate_ptrace_gamma !> \param pmat P matrices !> \param ecore Tr(HP) output !> \param nspin Number of P matrices -!> \param error CP2K error handling !> \date 29.07.2014 !> \author JGH !> \version 1.0 ! ***************************************************************************** - SUBROUTINE calculate_ptrace_kp(hmat,pmat,ecore,nspin,error) + SUBROUTINE calculate_ptrace_kp(hmat,pmat,ecore,nspin) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: hmat, pmat REAL(KIND=dp), INTENT(OUT) :: ecore INTEGER, INTENT(IN) :: nspin - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ptrace_kp', & routineP = moduleN//':'//routineN @@ -142,7 +138,7 @@ SUBROUTINE calculate_ptrace_kp(hmat,pmat,ecore,nspin,error) DO ispin=1,nspin DO ic = 1, nc etr=0.0_dp - CALL cp_dbcsr_trace(hmat(1,ic)%matrix,pmat(ispin,ic)%matrix,etr,error=error) + CALL cp_dbcsr_trace(hmat(1,ic)%matrix,pmat(ispin,ic)%matrix,etr) ecore = ecore + etr END DO END DO @@ -160,7 +156,6 @@ END SUBROUTINE calculate_ptrace_kp !> \param h ... !> \param p ... !> \param ecore ... -!> \param error ... !> \date 03.05.2001 !> \par History !> - simplified taking advantage of new non-redundant matrix @@ -169,11 +164,10 @@ END SUBROUTINE calculate_ptrace_kp !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE calculate_ptrace_1(h,p,ecore,error) + SUBROUTINE calculate_ptrace_1(h,p,ecore) TYPE(cp_dbcsr_type), POINTER :: h, p REAL(KIND=dp), INTENT(OUT) :: ecore - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ptrace_1', & routineP = moduleN//':'//routineN @@ -183,7 +177,7 @@ SUBROUTINE calculate_ptrace_1(h,p,ecore,error) CALL timeset(routineN,handle) ecore = 0.0_dp - CALL cp_dbcsr_trace(h,p,ecore,error=error) + CALL cp_dbcsr_trace(h,p,ecore) CALL timestop(handle) @@ -196,7 +190,6 @@ END SUBROUTINE calculate_ptrace_1 !> \param calculate_forces ... !> \param molecular ... !> \param E_overlap_core ... -!> \param error ... !> \date 30.04.2001 !> \par History !> - Force calculation added (03.06.2002,MK) @@ -207,13 +200,12 @@ END SUBROUTINE calculate_ptrace_1 !> \version 1.0 ! ***************************************************************************** SUBROUTINE calculate_ecore_overlap(qs_env,para_env,calculate_forces,molecular, & - E_overlap_core,error) + E_overlap_core) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(IN) :: calculate_forces LOGICAL, INTENT(IN), OPTIONAL :: molecular REAL(KIND=dp), INTENT(OUT), OPTIONAL :: E_overlap_core - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ecore_overlap', & routineP = moduleN//':'//routineN @@ -272,7 +264,7 @@ SUBROUTINE calculate_ecore_overlap(qs_env,para_env,calculate_forces,molecular, & force=force,& sab_core=sab_core,& atprop=atprop,& - virial = virial,error=error) + virial = virial) CALL get_cell(cell=cell,periodic=periodic) @@ -283,14 +275,14 @@ SUBROUTINE calculate_ecore_overlap(qs_env,para_env,calculate_forces,molecular, & use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ALLOCATE (alpha(nkind),radius(nkind),zeff(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) alpha(:) = 0.0_dp radius(:) = 0.0_dp zeff(:) = 0.0_dp IF (calculate_forces) THEN ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, atom_of_kind=atom_of_kind) END IF @@ -298,7 +290,7 @@ SUBROUTINE calculate_ecore_overlap(qs_env,para_env,calculate_forces,molecular, & IF (ASSOCIATED(atprop)) THEN IF (atprop%energy) THEN atenergy = .TRUE. - CALL atprop_array_init(atprop%atecc,natom,error) + CALL atprop_array_init(atprop%atecc,natom) END IF END IF @@ -306,7 +298,7 @@ SUBROUTINE calculate_ecore_overlap(qs_env,para_env,calculate_forces,molecular, & CALL get_qs_kind(qs_kind_set(ikind),& alpha_core_charge=alpha(ikind),& core_charge_radius=radius(ikind),& - zeff=zeff(ikind), error=error) + zeff=zeff(ikind)) END DO ecore_overlap = 0.0_dp @@ -339,7 +331,7 @@ SUBROUTINE calculate_ecore_overlap(qs_env,para_env,calculate_forces,molecular, & force(ikind)%core_overlap(:,atom_a) = force(ikind)%core_overlap(:,atom_a) + deab(:) force(jkind)%core_overlap(:,atom_b) = force(jkind)%core_overlap(:,atom_b) - deab(:) IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, 1._dp, deab, rab, error) + CALL virial_pair_force ( virial%pv_virial, 1._dp, deab, rab) END IF END IF END IF @@ -347,10 +339,10 @@ SUBROUTINE calculate_ecore_overlap(qs_env,para_env,calculate_forces,molecular, & CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (alpha,radius,zeff,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE (atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL mp_sum(ecore_overlap,group) @@ -369,15 +361,13 @@ END SUBROUTINE calculate_ecore_overlap !> \brief Calculate the self energy of the core charge distribution. !> \param qs_env ... !> \param E_self_core ... -!> \param error ... !> \date 27.04.2001 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE calculate_ecore_self(qs_env,E_self_core,error) + SUBROUTINE calculate_ecore_self(qs_env,E_self_core) TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), INTENT(OUT), OPTIONAL :: E_self_core - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_ecore_self', & routineP = moduleN//':'//routineN @@ -403,13 +393,13 @@ SUBROUTINE calculate_ecore_self(qs_env,E_self_core,error) CALL timeset(routineN,handle) CALL get_qs_env(qs_env=qs_env, atomic_kind_set=atomic_kind_set,& - qs_kind_set=qs_kind_set,energy=energy,atprop=atprop,error=error) + qs_kind_set=qs_kind_set,energy=energy,atprop=atprop) ecore_self = 0.0_dp DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom) - CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff, alpha_core_charge=alpha_core_charge, error=error) + CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff, alpha_core_charge=alpha_core_charge) ecore_self = ecore_self - REAL(natom,dp)*zeff**2*SQRT(alpha_core_charge) END DO @@ -422,13 +412,13 @@ SUBROUTINE calculate_ecore_self(qs_env,E_self_core,error) IF (atprop%energy) THEN ! atomic energy CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,& - local_particles=local_particles,error=error) + local_particles=local_particles) natom = SIZE(particle_set) - CALL atprop_array_init(atprop%ateself,natom,error) + CALL atprop_array_init(atprop%ateself,natom) DO ikind=1,SIZE(atomic_kind_set) nparticle_local = local_particles%n_el(ikind) - CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff,alpha_core_charge=alpha_core_charge, error=error) + CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff,alpha_core_charge=alpha_core_charge) es = zeff**2*SQRT(alpha_core_charge)/SQRT(twopi) DO iparticle_local = 1, nparticle_local iatom = local_particles%list(ikind)%array(iparticle_local) diff --git a/src/qs_core_hamiltonian.F b/src/qs_core_hamiltonian.F index 6d43dbbec5..e36d21188a 100644 --- a/src/qs_core_hamiltonian.F +++ b/src/qs_core_hamiltonian.F @@ -145,16 +145,14 @@ MODULE qs_core_hamiltonian !> \brief Cosntruction of the QS Core Hamiltonian Matrix !> \param qs_env ... !> \param calculate_forces ... -!> \param error ... !> \author Creation (11.03.2002,MK) !> Non-redundant calculation of the non-local part of the GTH PP (22.05.2003,MK) !> New parallelization scheme (27.06.2003,MK) ! ***************************************************************************** - SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) + SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'build_core_hamiltonian_matrix', & @@ -206,7 +204,7 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) ENDIF NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY (atomic_kind_set) NULLIFY (qs_kind_set) @@ -222,8 +220,7 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) virial=virial,& para_env=para_env,& ks_env=ks_env,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! is this a orbital-free method calculation ofdft = dft_control%qs_control%ofgpw @@ -246,9 +243,9 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) nders = 0 IF (calculate_forces) THEN nder = 1 - CALL get_qs_env(qs_env=qs_env,force=force,matrix_w_kp=matrix_w,error=error) - CALL get_qs_env(qs_env=qs_env,rho=rho,error=error) - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL get_qs_env(qs_env=qs_env,force=force,matrix_w_kp=matrix_w) + CALL get_qs_env(qs_env=qs_env,rho=rho) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) ! *** If LSD, then combine alpha density and beta density to ! *** total density: alpha <- alpha + beta and ! *** spin density: beta <- alpha - beta @@ -258,16 +255,16 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimages CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-2.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-2.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_w(1,img)%matrix, matrix_w(2,img)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) END DO END IF ELSE IF (cp_print_key_should_output(logger%iter_info,qs_env%input,& - "DFT%PRINT%AO_MATRICES/DERIVATIVES",error=error)/=0) THEN + "DFT%PRINT%AO_MATRICES/DERIVATIVES")/=0) THEN nder = 1 ELSE nder = 0 @@ -275,9 +272,9 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) END IF IF ((cp_print_key_should_output(logger%iter_info,qs_env%input,& - "DFT%PRINT%AO_MATRICES/OVERLAP",error=error)/=0.AND.& + "DFT%PRINT%AO_MATRICES/OVERLAP")/=0.AND.& BTEST(cp_print_key_should_output(logger%iter_info,qs_env%input,& - "DFT%PRINT%AO_MATRICES/DERIVATIVES",error=error),cp_p_file))) THEN + "DFT%PRINT%AO_MATRICES/DERIVATIVES"),cp_p_file))) THEN nders = 1 END IF @@ -296,9 +293,9 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) maxder = ncoset(nder) NULLIFY (matrix_s,matrix_t) - CALL get_qs_env(qs_env=qs_env, kinetic_kp=matrix_t, matrix_s_kp=matrix_s, error=error) + CALL get_qs_env(qs_env=qs_env, kinetic_kp=matrix_t, matrix_s_kp=matrix_s) NULLIFY (sab_orb) - CALL get_qs_env(qs_env=qs_env, sab_orb=sab_orb, error=error) + CALL get_qs_env(qs_env=qs_env, sab_orb=sab_orb) IF (calculate_forces) THEN ! S matrix CALL build_overlap_matrix(ks_env,nderivative=nders,matrixkp_s=matrix_s,& @@ -306,8 +303,7 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) basis_type_a="ORB",& basis_type_b="ORB", & sab_nl=sab_orb,calculate_forces=.TRUE.,& - matrixkp_p=matrix_w,& - error=error) + matrixkp_p=matrix_w) ! T matrix IF (.NOT.ofdft) & CALL build_kinetic_matrix(ks_env,matrixkp_t=matrix_t,& @@ -315,60 +311,55 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) basis_type="ORB",& sab_nl=sab_orb,calculate_forces=.TRUE.,& matrixkp_p=matrix_p,& - eps_filter=eps_filter,& - error=error) + eps_filter=eps_filter) ELSE ! S matrix CALL build_overlap_matrix(ks_env,nderivative=nders,matrixkp_s=matrix_s,& matrix_name="OVERLAP MATRIX",& basis_type_a="ORB",& basis_type_b="ORB", & - sab_nl=sab_orb,& - error=error) + sab_nl=sab_orb) ! T matrix IF (.NOT.ofdft) & CALL build_kinetic_matrix(ks_env,matrixkp_t=matrix_t,& matrix_name="KINETIC ENERGY MATRIX",& basis_type="ORB",& sab_nl=sab_orb,& - eps_filter=eps_filter,& - error=error) + eps_filter=eps_filter) IF(dft_control%do_admm) THEN NULLIFY(matrix_s_aux_fit,matrix_s_aux_fit_vs_orb,& sab_aux_fit,sab_aux_fit_vs_orb) CALL get_qs_env(qs_env=qs_env, matrix_s_aux_fit=matrix_s_aux_fit, & - sab_aux_fit=sab_aux_fit, error=error) + sab_aux_fit=sab_aux_fit) CALL build_overlap_matrix(ks_env,matrix_s=matrix_s_aux_fit,& matrix_name="AUX_FIT_OVERLAP",& basis_type_a="AUX_FIT",& basis_type_b="AUX_FIT", & - sab_nl=sab_aux_fit,& - error=error) - CALL set_ks_env(ks_env,matrix_s_aux_fit=matrix_s_aux_fit,error=error) + sab_nl=sab_aux_fit) + CALL set_ks_env(ks_env,matrix_s_aux_fit=matrix_s_aux_fit) CALL get_qs_env(qs_env=qs_env, matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb, & - sab_aux_fit_vs_orb=sab_aux_fit_vs_orb, error=error) + sab_aux_fit_vs_orb=sab_aux_fit_vs_orb) CALL build_overlap_matrix(ks_env,matrix_s=matrix_s_aux_fit_vs_orb,& matrix_name="MIXED_OVERLAP",& basis_type_a="AUX_FIT",& basis_type_b="ORB", & - sab_nl=sab_aux_fit_vs_orb,& - error=error) - CALL set_ks_env(ks_env,matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb,error=error) + sab_nl=sab_aux_fit_vs_orb) + CALL set_ks_env(ks_env,matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb) END IF END IF ! initialize H matrix NULLIFY(matrix_h) - CALL get_qs_env(qs_env=qs_env, matrix_h_kp=matrix_h, error=error) - CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,nimages,error) + CALL get_qs_env(qs_env=qs_env, matrix_h_kp=matrix_h) + CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,nimages) DO img=1,nimages ALLOCATE(matrix_h(1,img)%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_h(1,img)%matrix, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_h(1,img)%matrix) IF (.NOT.ofdft) THEN CALL cp_dbcsr_copy(matrix_h(1,img)%matrix,matrix_t(1,img)%matrix,& - name="CORE HAMILTONIAN MATRIX",error=error) + name="CORE HAMILTONIAN MATRIX") ! relativistic atomic correction to kinetic energy END IF END DO @@ -376,7 +367,7 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) IF(qs_env%rel_control%rel_method /= rel_none)THEN IF(qs_env%rel_control%rel_transformation == rel_trans_atom)THEN CALL build_atomic_relmat(matrix_h(1,1)%matrix, & - atomic_kind_set, qs_kind_set, particle_set, error) + atomic_kind_set, qs_kind_set, particle_set) END IF END IF END IF @@ -384,9 +375,9 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) ! *** Allocate the matrix of coefficients for one center expansions NULLIFY(oce) IF(dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN - CALL get_qs_env(qs_env=qs_env,oce=oce,error=error) - CALL create_oce_set(oce,error=error) - CALL allocate_oce_set(oce,nkind,error=error) + CALL get_qs_env(qs_env=qs_env,oce=oce) + CALL create_oce_set(oce) + CALL allocate_oce_set(oce,nkind) ! force analytic ppl calcuation for GAPW methods dft_control%qs_control%do_ppl_method=do_ppl_analytic ENDIF @@ -396,11 +387,10 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) sac_ae=sac_ae,& sac_ppl=sac_ppl,& sap_ppnl=sap_ppnl,& - sap_oce=sap_oce,& - error=error) + sap_oce=sap_oce) CALL get_qs_kind_set(qs_kind_set,& gth_potential_present=gth_potential_present,& - all_potential_present=all_potential_present,error=error) + all_potential_present=all_potential_present) ppl_present = ASSOCIATED(sac_ppl) IF (calculate_forces) THEN @@ -411,9 +401,9 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimages CALL cp_dbcsr_add(matrix_p(1,img)%matrix, matrix_p(2,img)%matrix, & - alpha_scalar= 0.5_dp, beta_scalar=0.5_dp,error=error) + alpha_scalar= 0.5_dp, beta_scalar=0.5_dp) CALL cp_dbcsr_add(matrix_p(2,img)%matrix, matrix_p(1,img)%matrix, & - alpha_scalar=-1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-1.0_dp, beta_scalar=1.0_dp) END DO END IF END IF @@ -421,68 +411,67 @@ SUBROUTINE build_core_hamiltonian_matrix(qs_env,calculate_forces,error) ! prepare for k-points NULLIFY(cell_to_index) IF (nimages>1) THEN - CALL get_ks_env(ks_env=ks_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_ks_env(ks_env=ks_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF ! *** compute the ppl contribution to the core hamiltonian *** IF (ppl_present) THEN IF(dft_control%qs_control%do_ppl_method==do_ppl_analytic) THEN CALL build_core_ppl(matrix_h, matrix_p, force, virial, calculate_forces, use_virial, nder,& - qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ppl, nimages, cell_to_index, error) + qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ppl, nimages, cell_to_index) END IF END IF ! *** compute the nuclear attraction contribution to the core hamiltonian *** IF (all_potential_present) THEN CALL build_core_ae(matrix_h, matrix_p, force, virial, calculate_forces, use_virial, nder,& - qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ae, nimages, cell_to_index, error) + qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ae, nimages, cell_to_index) END IF ! *** compute the ppnl contribution to the core hamiltonian *** eps_ppnl = dft_control%qs_control%eps_ppnl CALL build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, use_virial, nder,& - qs_kind_set, atomic_kind_set, particle_set, sab_orb, sap_ppnl, eps_ppnl, nimages, cell_to_index, error) + qs_kind_set, atomic_kind_set, particle_set, sab_orb, sap_ppnl, eps_ppnl, nimages, cell_to_index) ! *** GAPW one-center-expansion (oce) matrices IF(dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN eps_fit = dft_control%qs_control%gapw_control%eps_fit IF (ASSOCIATED(sap_oce)) & CALL build_oce_matrices(oce%intac,calculate_forces,nder,qs_kind_set,particle_set,& - sap_oce,eps_fit,error) + sap_oce,eps_fit) END IF ! *** LRIGPW matrices IF(lrigpw) THEN - CALL get_qs_env(qs_env=qs_env,lri_env=lri_env,error=error) - CALL build_lri_matrices(lri_env,qs_env,calculate_forces,error) + CALL get_qs_env(qs_env=qs_env,lri_env=lri_env) + CALL build_lri_matrices(lri_env,qs_env,calculate_forces) END IF ! *** KG atomic potentials for nonadditive kinetic energy IF (kgpot) THEN - CALL get_qs_env(qs_env=qs_env,kg_env=kg_env,dbcsr_dist=dbcsr_dist,error=error) + CALL get_qs_env(qs_env=qs_env,kg_env=kg_env,dbcsr_dist=dbcsr_dist) CALL build_tnadd_mat(kg_env, matrix_p, force, virial, calculate_forces, use_virial,& - qs_kind_set, atomic_kind_set, particle_set, sab_orb, dbcsr_dist, error) + qs_kind_set, atomic_kind_set, particle_set, sab_orb, dbcsr_dist) END IF ! *** Put the core Hamiltonian matrix in the QS environment *** - CALL set_qs_env(qs_env, oce=oce, error=error) + CALL set_qs_env(qs_env, oce=oce) CALL set_ks_env(ks_env,& matrix_s_kp=matrix_s,& kinetic_kp=matrix_t,& - matrix_h_kp=matrix_h,& - error=error) + matrix_h_kp=matrix_h) IF(qs_env%rel_control%rel_method /= rel_none)THEN IF(qs_env%rel_control%rel_transformation /= rel_trans_atom)THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Relativistic corrections of this type are currently not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END IF ! Print matrices if requested - CALL dump_info_core_hamiltonian(qs_env, calculate_forces, error) + CALL dump_info_core_hamiltonian(qs_env, calculate_forces) CALL timestop(handle) END SUBROUTINE build_core_hamiltonian_matrix @@ -493,9 +482,8 @@ END SUBROUTINE build_core_hamiltonian_matrix !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param particle_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_atomic_relmat(matrix_h, atomic_kind_set, qs_kind_set, particle_set, error) + SUBROUTINE build_atomic_relmat(matrix_h, atomic_kind_set, qs_kind_set, particle_set) TYPE(cp_dbcsr_type), POINTER :: matrix_h TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -503,7 +491,6 @@ SUBROUTINE build_atomic_relmat(matrix_h, atomic_kind_set, qs_kind_set, particle_ POINTER :: qs_kind_set TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_atomic_relmat', & routineP = moduleN//':'//routineN @@ -518,7 +505,7 @@ SUBROUTINE build_atomic_relmat(matrix_h, atomic_kind_set, qs_kind_set, particle_ failure = .FALSE. natom = SIZE(particle_set) ALLOCATE (kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,kind_of=kind_of) @@ -527,14 +514,14 @@ SUBROUTINE build_atomic_relmat(matrix_h, atomic_kind_set, qs_kind_set, particle_ CALL cp_dbcsr_iterator_next_block(iter, iatom, jatom, hblock, blk) IF (iatom==jatom) THEN ikind = kind_of(iatom) - CALL get_qs_kind(qs_kind_set(ikind),reltmat=reltmat,error=error) + CALL get_qs_kind(qs_kind_set(ikind),reltmat=reltmat) hblock = hblock + reltmat END IF END DO CALL cp_dbcsr_iterator_stop(iter) DEALLOCATE (kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE build_atomic_relmat @@ -543,12 +530,10 @@ END SUBROUTINE build_atomic_relmat !> Hamiltonian Matrix !> \param qs_env ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dump_info_core_hamiltonian(qs_env, calculate_forces, error) + SUBROUTINE dump_info_core_hamiltonian(qs_env, calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dump_info_core_hamiltonian', & routineP = moduleN//':'//routineN @@ -566,113 +551,112 @@ SUBROUTINE dump_info_core_hamiltonian(qs_env, calculate_forces, error) CALL timeset(routineN,handle) NULLIFY (logger, matrix_v, matrix_s, para_env) - logger => cp_error_get_logger(error) - CALL get_qs_env(qs_env, para_env=para_env, error=error) + logger => cp_get_default_logger() + CALL get_qs_env(qs_env, para_env=para_env) ! Print the distribution of the overlap matrix blocks ! this duplicates causes duplicate printing at the force calc IF (.NOT.calculate_forces) THEN IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"PRINT%DISTRIBUTION",error=error),cp_p_file)) THEN + qs_env%input,"PRINT%DISTRIBUTION"),cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,qs_env%input,"PRINT%DISTRIBUTION",& - extension=".distribution",error=error) - CALL get_qs_env(qs_env, matrix_s_kp=matrixkp_s, error=error) - CALL cp_dbcsr_write_matrix_dist(matrixkp_s(1,1)%matrix,output_unit,para_env,error) - CALL cp_print_key_finished_output(output_unit,logger,qs_env%input,"PRINT%DISTRIBUTION",& - error=error) + extension=".distribution") + CALL get_qs_env(qs_env, matrix_s_kp=matrixkp_s) + CALL cp_dbcsr_write_matrix_dist(matrixkp_s(1,1)%matrix,output_unit,para_env) + CALL cp_print_key_finished_output(output_unit,logger,qs_env%input,"PRINT%DISTRIBUTION") END IF END IF ! Print the overlap integral matrix, if requested IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/OVERLAP",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/OVERLAP"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/OVERLAP",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL get_qs_env(qs_env, matrix_s_kp=matrixkp_s, error=error) + CALL get_qs_env(qs_env, matrix_s_kp=matrixkp_s) IF (ASSOCIATED(matrixkp_s)) THEN DO ic=1,SIZE(matrixkp_s,2) CALL cp_dbcsr_write_sparse_matrix(matrixkp_s(1,ic)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END DO IF (BTEST(cp_print_key_should_output(logger%iter_info,qs_env%input,& - "DFT%PRINT%AO_MATRICES/DERIVATIVES",error=error),cp_p_file) & + "DFT%PRINT%AO_MATRICES/DERIVATIVES"),cp_p_file) & .AND. ASSOCIATED(matrix_s)) THEN DO ic=1,SIZE(matrixkp_s,2) DO i=2,SIZE(matrix_s) CALL cp_dbcsr_write_sparse_matrix(matrixkp_s(i,ic)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END DO END DO END IF END IF CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/OVERLAP", error=error) + "DFT%PRINT%AO_MATRICES/OVERLAP") END IF ! Print the kinetic energy integral matrix, if requested IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/KINETIC_ENERGY",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/KINETIC_ENERGY"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/KINETIC_ENERGY",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL get_qs_env(qs_env, kinetic_kp=matrixkp_t, error=error) + CALL get_qs_env(qs_env, kinetic_kp=matrixkp_t) IF (ASSOCIATED(matrixkp_t)) THEN DO ic=1,SIZE(matrixkp_t,2) CALL cp_dbcsr_write_sparse_matrix(matrixkp_t(1,ic)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END DO END IF CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/KINETIC_ENERGY", error=error) + "DFT%PRINT%AO_MATRICES/KINETIC_ENERGY") END IF ! Print the potential energy matrix, if requested IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/POTENTIAL_ENERGY",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/POTENTIAL_ENERGY"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/POTENTIAL_ENERGY",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL get_qs_env(qs_env,matrix_h_kp=matrixkp_h,kinetic_kp=matrixkp_t,error=error) + CALL get_qs_env(qs_env,matrix_h_kp=matrixkp_h,kinetic_kp=matrixkp_t) IF (ASSOCIATED(matrixkp_h)) THEN IF (SIZE(matrixkp_h,2) == 1) THEN - CALL cp_dbcsr_allocate_matrix_set(matrix_v,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_v,1) ALLOCATE (matrix_v(1)%matrix) - CALL cp_dbcsr_init(matrix_v(1)%matrix, error=error) - CALL cp_dbcsr_copy(matrix_v(1)%matrix,matrixkp_h(1,1)%matrix,name="POTENTIAL ENERGY MATRIX",error=error) + CALL cp_dbcsr_init(matrix_v(1)%matrix) + CALL cp_dbcsr_copy(matrix_v(1)%matrix,matrixkp_h(1,1)%matrix,name="POTENTIAL ENERGY MATRIX") CALL cp_dbcsr_add(matrix_v(1)%matrix,matrixkp_t(1,1)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_v(1)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_deallocate_matrix_set(matrix_v,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) + CALL cp_dbcsr_write_sparse_matrix(matrix_v(1)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_deallocate_matrix_set(matrix_v) ELSE CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of potential energy matrix not implemented for k-points", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF END IF CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/POTENTIAL_ENERGY", error=error) + "DFT%PRINT%AO_MATRICES/POTENTIAL_ENERGY") END IF ! Print the core Hamiltonian matrix, if requested IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL get_qs_env(qs_env, matrix_h_kp=matrixkp_h, error=error) + CALL get_qs_env(qs_env, matrix_h_kp=matrixkp_h) IF (ASSOCIATED(matrixkp_h)) THEN DO ic=1,SIZE(matrixkp_h,2) CALL cp_dbcsr_write_sparse_matrix(matrixkp_h(1,ic)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END DO END IF CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN", error=error) + "DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN") END IF CALL timestop(handle) diff --git a/src/qs_density_mixing_types.F b/src/qs_density_mixing_types.F index 15db6700af..78374f9257 100644 --- a/src/qs_density_mixing_types.F +++ b/src/qs_density_mixing_types.F @@ -84,17 +84,15 @@ MODULE qs_density_mixing_types !> \param mixing_section ... !> \param mixing_method ... !> \param ecut ... -!> \param error ... !> \par History !> 05.2009 created [MI] !> \author [MI] ! ***************************************************************************** - SUBROUTINE mixing_storage_create(mixing_store, mixing_section, mixing_method, ecut, error) + SUBROUTINE mixing_storage_create(mixing_store, mixing_section, mixing_method, ecut) TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(section_vals_type), POINTER :: mixing_section INTEGER, INTENT(IN) :: mixing_method REAL(dp), INTENT(IN) :: ecut - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixing_storage_create', & routineP = moduleN//':'//routineN @@ -105,9 +103,9 @@ SUBROUTINE mixing_storage_create(mixing_store, mixing_section, mixing_method, e failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(mixing_store),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(mixing_store),cp_failure_level,routineP,failure) ALLOCATE(mixing_store, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) mixing_store%ref_count=1 mixing_store%nbuffer=0 @@ -148,12 +146,12 @@ SUBROUTINE mixing_storage_create(mixing_store, mixing_section, mixing_method, e NULLIFY(mixing_store%cpc_h_lastres) NULLIFY(mixing_store%cpc_s_lastres) - CALL section_vals_val_get(mixing_section,"ALPHA",r_val=mixing_store%alpha,error=error) - CALL section_vals_val_get(mixing_section,"BETA",r_val=mixing_store%beta,error=error) - CALL section_vals_val_get(mixing_section,"N_SIMPLE_MIX",i_val=mixing_store%n_simple_mix,error=error) - CALL section_vals_val_get(mixing_section,"NBUFFER",i_val=mixing_store%nbuffer,error=error) - CALL section_vals_val_get(mixing_section,"NSKIP",i_val=mixing_store%nskip_mixing,error=error) - CALL section_vals_val_get(mixing_section,"MAX_GVEC_EXP",r_val=mixing_store%max_gvec_exp,error=error) + CALL section_vals_val_get(mixing_section,"ALPHA",r_val=mixing_store%alpha) + CALL section_vals_val_get(mixing_section,"BETA",r_val=mixing_store%beta) + CALL section_vals_val_get(mixing_section,"N_SIMPLE_MIX",i_val=mixing_store%n_simple_mix) + CALL section_vals_val_get(mixing_section,"NBUFFER",i_val=mixing_store%nbuffer) + CALL section_vals_val_get(mixing_section,"NSKIP",i_val=mixing_store%nskip_mixing) + CALL section_vals_val_get(mixing_section,"MAX_GVEC_EXP",r_val=mixing_store%max_gvec_exp) IF(mixing_store%max_gvec_exp > 0._dp) THEN alpha = 0.25_dp/mixing_store%max_gvec_exp @@ -166,20 +164,20 @@ SUBROUTINE mixing_storage_create(mixing_store, mixing_section, mixing_method, e CASE(gspace_mixing_nr) mixing_store%nbuffer = 1 CASE(pulay_mixing_nr) - CALL section_vals_val_get(mixing_section,"PULAY_ALPHA",r_val=mixing_store%pulay_alpha,error=error) - CALL section_vals_val_get(mixing_section,"PULAY_BETA",r_val=mixing_store%pulay_beta,error=error) + CALL section_vals_val_get(mixing_section,"PULAY_ALPHA",r_val=mixing_store%pulay_alpha) + CALL section_vals_val_get(mixing_section,"PULAY_BETA",r_val=mixing_store%pulay_beta) CASE(broyden_mixing_nr) - CALL section_vals_val_get(mixing_section,"BROY_W0",r_val=mixing_store%broy_w0,error=error) + CALL section_vals_val_get(mixing_section,"BROY_W0",r_val=mixing_store%broy_w0) mixing_store%bconst = 20.0_dp CASE(broyden_mixing_new_nr) - CALL section_vals_val_get(mixing_section,"BROY_WREF",r_val=mixing_store%wc,error=error) - CALL section_vals_val_get(mixing_section,"BROY_WMAX",r_val=mixing_store%wmax,error=error) + CALL section_vals_val_get(mixing_section,"BROY_WREF",r_val=mixing_store%wc) + CALL section_vals_val_get(mixing_section,"BROY_WMAX",r_val=mixing_store%wmax) mixing_store%bconst = 20.0_dp mixing_store%p_metric_method=1 CASE(multisecant_mixing_nr) - CALL section_vals_val_get(mixing_section,"REGULARIZATION",r_val=mixing_store%reg_par,error=error) - CALL section_vals_val_get(mixing_section,"MAX_STEP",r_val=mixing_store%sigma_max,error=error) - CALL section_vals_val_get(mixing_section,"R_FACTOR",r_val=mixing_store%r_step,error=error) + CALL section_vals_val_get(mixing_section,"REGULARIZATION",r_val=mixing_store%reg_par) + CALL section_vals_val_get(mixing_section,"MAX_STEP",r_val=mixing_store%sigma_max) + CALL section_vals_val_get(mixing_section,"R_FACTOR",r_val=mixing_store%r_step) END SELECT END SUBROUTINE mixing_storage_create @@ -187,14 +185,12 @@ END SUBROUTINE mixing_storage_create ! ***************************************************************************** !> \brief releases a mixing_storage !> \param mixing_store ... -!> \param error ... !> \par History !> 05.2009 created [MI] !> \author [MI] ! ***************************************************************************** - SUBROUTINE mixing_storage_release(mixing_store,error) + SUBROUTINE mixing_storage_release(mixing_store) TYPE(mixing_storage_type), POINTER :: mixing_store - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixing_storage_release', & routineP = moduleN//':'//routineN @@ -205,71 +201,71 @@ SUBROUTINE mixing_storage_release(mixing_store,error) failure=.FALSE. IF (ASSOCIATED(mixing_store)) THEN - CPPreconditionNoFail(mixing_store%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(mixing_store%ref_count>0,cp_failure_level,routineP) mixing_store%ref_count=mixing_store%ref_count-1 IF (mixing_store%ref_count==0) THEN IF (ASSOCIATED(mixing_store%kerker_factor)) THEN DEALLOCATE(mixing_store%kerker_factor,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%special_metric)) THEN DEALLOCATE(mixing_store%special_metric,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%pulay_matrix)) THEN DEALLOCATE(mixing_store%pulay_matrix,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%rhoin_buffer)) THEN DO i = 1,SIZE(mixing_store%rhoin_buffer,2) DO j = 1,SIZE(mixing_store%rhoin_buffer,1) DEALLOCATE(mixing_store%rhoin_buffer(j,i)%cc,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO END DO DEALLOCATE(mixing_store%rhoin_buffer,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%paw)) THEN DEALLOCATE(mixing_store%paw,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%cpc_h_in)) THEN DO j = 1,SIZE(mixing_store%cpc_h_in,2) DO k = 1,SIZE(mixing_store%cpc_h_in,1) IF(ASSOCIATED(mixing_store%cpc_h_in(k,j)%r_coef)) THEN DEALLOCATE(mixing_store%cpc_h_in(k,j)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%cpc_s_in(k,j)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END DO DEALLOCATE(mixing_store%cpc_h_in,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%cpc_s_in,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%cpc_h_old)) THEN DO j = 1,SIZE(mixing_store%cpc_h_old,2) DO k = 1,SIZE(mixing_store%cpc_h_old,1) IF(ASSOCIATED(mixing_store%cpc_h_old(k,j)%r_coef)) THEN DEALLOCATE(mixing_store%cpc_h_old(k,j)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%cpc_s_old(k,j)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END DO DEALLOCATE(mixing_store%cpc_h_old,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%cpc_s_old,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%dcpc_h_in)) THEN DO i = 1,SIZE(mixing_store%dcpc_h_in,3) @@ -277,144 +273,144 @@ SUBROUTINE mixing_storage_release(mixing_store,error) DO k = 1,SIZE(mixing_store%dcpc_h_in,1) IF(ASSOCIATED(mixing_store%dcpc_h_in(k,j,i)%r_coef)) THEN DEALLOCATE(mixing_store%dcpc_h_in(k,j,i)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%dcpc_s_in(k,j,i)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END DO END DO DEALLOCATE(mixing_store%dcpc_h_in,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%dcpc_s_in,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%cpc_h_lastres)) THEN DO j = 1,SIZE(mixing_store%cpc_h_lastres,2) DO k = 1,SIZE(mixing_store%cpc_h_lastres,1) IF(ASSOCIATED(mixing_store%cpc_h_lastres(k,j)%r_coef)) THEN DEALLOCATE(mixing_store%cpc_h_lastres(k,j)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%cpc_s_lastres(k,j)%r_coef,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END DO DEALLOCATE(mixing_store%cpc_h_lastres,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(mixing_store%cpc_s_lastres,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%res_buffer)) THEN DO i = 1,SIZE(mixing_store%res_buffer,2) DO j = 1,SIZE(mixing_store%res_buffer,1) DEALLOCATE(mixing_store%res_buffer(j,i)%cc,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO END DO DEALLOCATE(mixing_store%res_buffer,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%norm_res_buffer)) THEN DEALLOCATE(mixing_store%norm_res_buffer,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%ig_global_index)) THEN DEALLOCATE(mixing_store%ig_global_index,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%drho_buffer)) THEN DO i = 1,SIZE(mixing_store%drho_buffer,2) DO j = 1,SIZE(mixing_store%drho_buffer,1) DEALLOCATE(mixing_store%drho_buffer(j,i)%cc,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO END DO DEALLOCATE(mixing_store%drho_buffer,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(mixing_store%last_res)) THEN DO i = 1,SIZE(mixing_store%last_res) DEALLOCATE(mixing_store%last_res(i)%cc,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO DEALLOCATE(mixing_store%last_res,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%rhoin)) THEN DO i = 1,SIZE(mixing_store%rhoin) DEALLOCATE(mixing_store%rhoin(i)%cc,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO DEALLOCATE(mixing_store%rhoin,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%rhoin_old)) THEN DO i = 1,SIZE(mixing_store%rhoin_old) DEALLOCATE(mixing_store%rhoin_old(i)%cc,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO DEALLOCATE(mixing_store%rhoin_old,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%p_metric))THEN DEALLOCATE(mixing_store%p_metric, STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%weight))THEN DEALLOCATE(mixing_store%weight, STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%fmat))THEN DEALLOCATE(mixing_store%fmat, STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%delta_res))THEN DO i = 1,SIZE(mixing_store%delta_res,2) DO j = 1,SIZE(mixing_store%delta_res,1) DEALLOCATE(mixing_store%delta_res(j,i)%cc, STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO END DO DEALLOCATE(mixing_store%delta_res,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%u_vec))THEN DO i = 1,SIZE(mixing_store%u_vec,2) DO j = 1,SIZE(mixing_store%u_vec,1) DEALLOCATE(mixing_store%u_vec(j,i)%cc, STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO END DO DEALLOCATE(mixing_store%u_vec,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(mixing_store%z_vec))THEN DO i = 1,SIZE(mixing_store%z_vec,2) DO j = 1,SIZE(mixing_store%z_vec,1) DEALLOCATE(mixing_store%z_vec(j,i)%cc, STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO END DO DEALLOCATE(mixing_store%z_vec,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(mixing_store, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF NULLIFY(mixing_store) END IF @@ -426,7 +422,6 @@ END SUBROUTINE mixing_storage_release !> be used only with diagonalization methods, i.e. not with OT !> \param section ... !> \param ls_scf ... -!> \param error ... !> \date 20.02.2009 !> \par History !> 02.2015 moved here from input_cp2k_dft.F, modified for use in LS SCF @@ -434,11 +429,10 @@ END SUBROUTINE mixing_storage_release !> \author MI !> \version 1.0 ! ***************************************************************************** - SUBROUTINE create_mixing_section(section, ls_scf, error) + SUBROUTINE create_mixing_section(section, ls_scf) TYPE(section_type), POINTER :: section LOGICAL, INTENT(IN), OPTIONAL :: ls_scf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_mixing_section', & routineP = moduleN//':'//routineN @@ -450,7 +444,7 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) IF (PRESENT(ls_scf)) THEN IF (ls_scf) THEN @@ -479,8 +473,7 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) "on OT.",& n_keywords=16,& n_subsections=0,& - repeats=.FALSE.,& - error=error) + repeats=.FALSE.) NULLIFY (keyword) @@ -489,10 +482,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) description="Controls the activation of the mixing procedure",& usage="&MIXING ON",& default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) IF (.NOT. ls) THEN default_mix = direct_p_mix @@ -519,11 +511,10 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) "Direct mixing of new and old density matrices",& "Mixing of the potential in reciprocal space using the Kerker damping",& "Pulay mixing","Broyden mixing","Broyden mixing second version",& - "Multisecant scheme for mixing" ),& - error=error) + "Multisecant scheme for mixing" )) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="ALPHA",& @@ -532,10 +523,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=0.4_dp,& - usage="ALPHA 0.2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALPHA 0.2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="BETA",& @@ -548,10 +538,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) type_of_var=real_t,& default_r_val=0.5_dp,& unit_str="bohr^-1",& - usage="BETA 1.5",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BETA 1.5") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="PULAY_ALPHA",& @@ -560,10 +549,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=0.0_dp,& - usage="PULAY_ALPHA 0.2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PULAY_ALPHA 0.2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="PULAY_BETA",& @@ -572,24 +560,23 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=1.0_dp,& - usage="PULAY_BETA 0.2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PULAY_BETA 0.2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NMIXING",& description="Minimal number of density mixing (should be greater than 0),"//& "before starting DIIS",& - usage="NMIXING 1", default_i_val=2,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NMIXING 1", default_i_val=2) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NBUFFER",& variants=s2a("NPULAY","NBROYDEN","NMULTISECANT"),& description="Number of previous steps stored for the actual mixing scheme",& - usage="NBUFFER 2", default_i_val=4,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NBUFFER 2", default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="BROY_W0",& @@ -598,10 +585,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=0.01_dp,& - usage="BROY_W0 0.03",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BROY_W0 0.03") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="BROY_WREF",& @@ -610,10 +596,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=100.0_dp,& - usage="BROY_WREF 0.2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BROY_WREF 0.2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="BROY_WMAX",& @@ -622,10 +607,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=30.0_dp,& - usage="BROY_WMAX 10.0",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BROY_WMAX 10.0") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="REGULARIZATION",& @@ -636,10 +620,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=0.00001_dp,& - usage="REGULARIZATION 0.000001",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="REGULARIZATION 0.000001") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="MAX_STEP",& @@ -650,10 +633,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=0.1_dp,& - usage="MAX_STEP .2",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_STEP .2") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,& name="R_FACTOR",& @@ -664,24 +646,23 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=0.05_dp,& - usage="R_FACTOR .12",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="R_FACTOR .12") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NSKIP",& variants=(/"NSKIP_MIXING"/),& description="Number of initial iteration for which the mixing is skipped",& - usage="NSKIP 10", default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NSKIP 10", default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_SIMPLE_MIX",& variants=(/"NSIMPLEMIX"/),& description="Number of kerker damping iterations before starting other mixing procedures",& - usage="NSIMPLEMIX", default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NSIMPLEMIX", default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_GVEC_EXP",& description="Restricts the G-space mixing to lower part of G-vector spectrum,"//& @@ -691,10 +672,9 @@ SUBROUTINE create_mixing_section(section, ls_scf, error) n_var=1,& type_of_var=real_t,& default_r_val=-1._dp,& - usage="MAX_GVEC_EXP 3.",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MAX_GVEC_EXP 3.") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mixing_section diff --git a/src/qs_dftb3_methods.F b/src/qs_dftb3_methods.F index 814fc45a4a..5ac1962d2a 100644 --- a/src/qs_dftb3_methods.F +++ b/src/qs_dftb3_methods.F @@ -63,10 +63,9 @@ MODULE qs_dftb3_methods !> \param energy ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& - calculate_forces,just_energy,error) + calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -75,7 +74,6 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& REAL(dp), DIMENSION(:) :: mcharge TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_dftb3_diagonal', & routineP = moduleN//':'//routineN @@ -120,12 +118,12 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& ! Energy CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,& - qs_kind_set=qs_kind_set,atprop=atprop,error=error) + qs_kind_set=qs_kind_set,atprop=atprop) eb3 = 0.0_dp - CALL get_qs_env(qs_env=qs_env,local_particles=local_particles,error=error) + CALL get_qs_env(qs_env=qs_env,local_particles=local_particles) DO ikind=1,SIZE(local_particles%n_el) - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,dudq=ua,zeff=zeff) DO ia=1,local_particles%n_el(ikind) iatom=local_particles%list(ikind)%array(ia) @@ -138,26 +136,26 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& END IF END DO END DO - CALL get_qs_env(qs_env=qs_env,para_env=para_env,error=error) + CALL get_qs_env(qs_env=qs_env,para_env=para_env) CALL mp_sum(eb3,para_env%group) energy%dftb3 = eb3 ! Forces and Virial IF ( calculate_forces ) THEN CALL get_qs_env(qs_env=qs_env,matrix_s_kp=matrix_s,natom=natom,force=force,& - cell=cell,virial=virial,particle_set=particle_set,error=error) + cell=cell,virial=virial,particle_set=particle_set) ! virial use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& kind_of=kind_of,atom_of_kind=atom_of_kind) - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) IF ( SIZE(matrix_p,1) == 2) THEN DO ic=1,SIZE(matrix_p,2) CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END DO END IF ! @@ -165,11 +163,11 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& NULLIFY(cell_to_index) IF (nimg>1) THEN NULLIFY(kpoints) - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF NULLIFY(n_list) - CALL get_qs_env(qs_env=qs_env,sab_orb=n_list,error=error) + CALL get_qs_env(qs_env=qs_env,sab_orb=n_list) CALL neighbor_list_iterator_create(nl_iterator,n_list) DO WHILE (neighbor_list_iterate(nl_iterator)==0) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,& @@ -185,16 +183,16 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& ic = 1 ELSE ic = cell_to_index(cellind(1),cellind(2),cellind(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) END IF ikind = kind_of(iatom) atom_i = atom_of_kind(iatom) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,dudq=ui) jkind = kind_of(jatom) atom_j = atom_of_kind(jatom) - CALL get_qs_kind(qs_kind_set(jkind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(jkind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,dudq=uj) ! gmij = -0.5_dp*(ui*mcharge(iatom)**2 + uj*mcharge(jatom)**2) @@ -202,12 +200,12 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1,ic)%matrix,& row=irow,col=icol,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO i=1,3 NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i,ic)%matrix,& row=irow,col=icol,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) IF(irow==iatom) THEN fi = -gmij*SUM(pblock*dsblock) ELSE @@ -218,10 +216,10 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& fij(i) = fi END DO IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij, error) + CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij) IF(atprop%stress) THEN - CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij, error) - CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij, error) + CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij) + CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij) END IF END IF @@ -229,32 +227,32 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& CALL neighbor_list_iterator_release(nl_iterator) ! DEALLOCATE (atom_of_kind,kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF ( SIZE(matrix_p,1) == 2 ) THEN DO ic=1,SIZE(matrix_p,2) CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END DO END IF END IF ! KS matrix IF ( .NOT. just_energy ) THEN - CALL get_qs_env(qs_env=qs_env,matrix_s_kp=matrix_s,natom=natom,error=error) + CALL get_qs_env(qs_env=qs_env,matrix_s_kp=matrix_s,natom=natom) ALLOCATE (kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,kind_of=kind_of) ! nimg = SIZE(ks_matrix,2) NULLIFY(cell_to_index) IF (nimg>1) THEN NULLIFY(kpoints) - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF NULLIFY(n_list) - CALL get_qs_env(qs_env=qs_env,sab_orb=n_list,error=error) + CALL get_qs_env(qs_env=qs_env,sab_orb=n_list) CALL neighbor_list_iterator_create(nl_iterator,n_list) DO WHILE (neighbor_list_iterate(nl_iterator)==0) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,& @@ -267,26 +265,26 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& ic = 1 ELSE ic = cell_to_index(cellind(1),cellind(2),cellind(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) END IF ikind = kind_of(iatom) - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,dudq=ui) jkind = kind_of(jatom) - CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,dudq=uj) gmij = -0.5_dp*(ui*mcharge(iatom)**2 + uj*mcharge(jatom)**2) ! NULLIFY(sblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1,ic)%matrix,& row=irow,col=icol,block=sblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO is=1,SIZE(ks_matrix,1) NULLIFY(ksblock) CALL cp_dbcsr_get_block_p(matrix=ks_matrix(is,ic)%matrix,& row=irow,col=icol,block=ksblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ksblock = ksblock - 0.5_dp*gmij*sblock END DO @@ -294,7 +292,7 @@ SUBROUTINE build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& CALL neighbor_list_iterator_release(nl_iterator) ! DEALLOCATE (kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) diff --git a/src/qs_dftb_coulomb.F b/src/qs_dftb_coulomb.F index a18fd24148..39b069f31a 100644 --- a/src/qs_dftb_coulomb.F +++ b/src/qs_dftb_coulomb.F @@ -117,10 +117,9 @@ MODULE qs_dftb_coulomb !> \param energy ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& - calculate_forces,just_energy,error) + calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -129,7 +128,6 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& REAL(dp), DIMENSION(:) :: mcharge TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_dftb_coulomb', & routineP = moduleN//':'//routineN @@ -190,7 +188,7 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& natom = SIZE(mcharge) ALLOCATE(gmcharge(natom,nmat),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) gmcharge = 0._dp CALL get_qs_env(qs_env,& @@ -199,25 +197,24 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& cell=cell,& virial=virial,& atprop=atprop,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF ( calculate_forces ) THEN use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) END IF ALLOCATE(mcin(natom,1),mcout(natom,1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mcin(:,1) = mcharge(:) DO i=1,nmat mcout = 0._dp - CALL cp_dbcsr_multiply_local(gamma_matrix(i)%matrix,mcin,mcout,ncol=1,error=error) + CALL cp_dbcsr_multiply_local(gamma_matrix(i)%matrix,mcin,mcout,ncol=1) gmcharge(:,i) = mcout(:,1) END DO DEALLOCATE(mcin,mcout,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF ( calculate_forces .AND. use_virial ) THEN CALL cp_dbcsr_iterator_start(iter, gamma_matrix(1)%matrix) @@ -232,19 +229,19 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& END DO rij = particle_set(iatom)%r - particle_set(jatom)%r rij = pbc(rij,cell) - CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij, error) + CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij) IF (atprop%stress) THEN - CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij, error) - CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij, error) + CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij) + CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij) END IF ENDDO CALL cp_dbcsr_iterator_stop(iter) END IF IF (atprop%energy) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE (particle_set) - CALL atprop_array_init(atprop%atecoul,natom,error) + CALL atprop_array_init(atprop%atecoul,natom) END IF ! 1/R contribution @@ -253,33 +250,32 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& ! Ewald sum NULLIFY(ewald_env,ewald_pw) CALL get_qs_env(qs_env=qs_env,& - ewald_env=ewald_env,ewald_pw=ewald_pw,& - error=error) + ewald_env=ewald_env,ewald_pw=ewald_pw) CALL get_cell(cell=cell,periodic=periodic,deth=deth) - CALL ewald_env_get(ewald_env,alpha=alpha,ewald_type=ewald_type,error=error) - CALL get_qs_env(qs_env=qs_env,sab_tbe=n_list,error=error) + CALL ewald_env_get(ewald_env,alpha=alpha,ewald_type=ewald_type) + CALL get_qs_env(qs_env=qs_env,sab_tbe=n_list) CALL dftb_ewald_overlap(gmcharge,mcharge,alpha,n_list,& - virial,use_virial,atprop,error=error) + virial,use_virial,atprop) SELECT CASE(ewald_type) CASE DEFAULT - CALL cp_unimplemented_error(routineP,"Invalid Ewald type",error) + CALL cp_unimplemented_error(routineP,"Invalid Ewald type") CASE(do_ewald_none) - CPErrorMessage(cp_failure_level,routineP,"Not allowed with DFTB",error) - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Not allowed with DFTB") + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE(do_ewald_ewald) CALL cp_unimplemented_error(routineP,& - "Standard Ewald not implemented in DFTB",error) + "Standard Ewald not implemented in DFTB") CASE(do_ewald_pme) CALL cp_unimplemented_error(routineP,& - "PME not implemented in DFTB",error) + "PME not implemented in DFTB") CASE(do_ewald_spme) CALL dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,cell,& - gmcharge,mcharge,calculate_forces,virial,use_virial,atprop,error) + gmcharge,mcharge,calculate_forces,virial,use_virial,atprop) END SELECT ELSE ! direct sum CALL get_qs_env(qs_env=qs_env,& - local_particles=local_particles,error=error) + local_particles=local_particles) DO ikind=1,SIZE(local_particles%n_el) DO ia=1,local_particles%n_el(ikind) iatom=local_particles%list(ikind)%array(ia) @@ -296,13 +292,13 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& END DO END DO END DO - CPPostcondition(.NOT.use_virial,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.use_virial,cp_failure_level,routineP,failure) END IF CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& - force=force,para_env=para_env,error=error) + force=force,para_env=para_env) CALL mp_sum(gmcharge(:,1),para_env%group) IF (do_ewald) THEN @@ -316,9 +312,9 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& energy%hartree = energy%hartree + 0.5_dp*SUM(mcharge(:)*gmcharge(:,1)) IF(atprop%energy) THEN CALL get_qs_env(qs_env=qs_env,& - local_particles=local_particles,error=error) + local_particles=local_particles) DO ikind=1,SIZE(local_particles%n_el) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,zeff=zeff) DO ia=1,local_particles%n_el(ikind) iatom=local_particles%list(ikind)%array(ia) @@ -330,7 +326,7 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& IF ( calculate_forces ) THEN ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& kind_of=kind_of,& @@ -349,26 +345,26 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& END IF IF ( .NOT. just_energy ) THEN - CALL get_qs_env(qs_env=qs_env,matrix_s_kp=matrix_s,error=error) - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL get_qs_env(qs_env=qs_env,matrix_s_kp=matrix_s) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) nimg = dft_control%nimages NULLIFY(cell_to_index) IF (nimg>1) THEN NULLIFY(kpoints) - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF IF ( calculate_forces .AND. SIZE(matrix_p,1) == 2) THEN DO img=1,nimg CALL cp_dbcsr_add(matrix_p(1,img)%matrix,matrix_p(2,img)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END DO END IF NULLIFY(n_list) - CALL get_qs_env(qs_env=qs_env,sab_orb=n_list,error=error) + CALL get_qs_env(qs_env=qs_env,sab_orb=n_list) CALL neighbor_list_iterator_create(nl_iterator,n_list) DO WHILE (neighbor_list_iterate(nl_iterator)==0) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,& @@ -381,7 +377,7 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& ic = 1 ELSE ic = cell_to_index(cellind(1),cellind(2),cellind(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) END IF gmij = 0.5_dp*(gmcharge(iatom,1)+gmcharge(jatom,1)) @@ -389,12 +385,12 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& NULLIFY(sblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1,ic)%matrix,& row=irow,col=icol,block=sblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO is=1,SIZE(ks_matrix,1) NULLIFY(ksblock) CALL cp_dbcsr_get_block_p(matrix=ks_matrix(is,ic)%matrix,& row=irow,col=icol,block=ksblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ksblock = ksblock - gmij*sblock END DO @@ -407,22 +403,22 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1,ic)%matrix,& row=irow,col=icol,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO i=1,3 NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i,ic)%matrix,& row=irow,col=icol,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) fi = -2.0_dp*gmij*SUM(pblock*dsblock) force(ikind)%rho_elec(i,atom_i) = force(ikind)%rho_elec(i,atom_i) + fi force(jkind)%rho_elec(i,atom_j) = force(jkind)%rho_elec(i,atom_j) - fi fij(i) = fi END DO IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij, error) + CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij) IF (atprop%stress) THEN - CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij, error) - CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij, error) + CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij) + CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij) END IF END IF END IF @@ -433,7 +429,7 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& IF ( calculate_forces .AND. SIZE(matrix_p,1) == 2) THEN DO img=1,nimg CALL cp_dbcsr_add(matrix_p(1,img)%matrix,matrix_p(2,img)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END DO END IF END IF @@ -441,21 +437,21 @@ SUBROUTINE build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& IF ( dft_control%qs_control%dftb_control%dftb3_diagonal ) THEN ! Diagonal 3rd order correction (DFTB3) CALL build_dftb3_diagonal(qs_env,ks_matrix,rho,mcharge,energy,& - calculate_forces,just_energy,error) + calculate_forces,just_energy) END IF ! QMMM IF(qs_env%qmmm .AND. qs_env%qmmm_periodic) THEN CALL build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& - calculate_forces,just_energy,error) + calculate_forces,just_energy) END IF IF ( calculate_forces ) THEN DEALLOCATE (atom_of_kind,kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(gmcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -470,10 +466,9 @@ END SUBROUTINE build_dftb_coulomb !> \param energy ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& - calculate_forces,just_energy,error) + calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -482,7 +477,6 @@ SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& REAL(dp), DIMENSION(:) :: mcharge TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_dftb_coulomb_qmqm', & routineP = moduleN//':'//routineN @@ -534,7 +528,7 @@ SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& natom = SIZE(mcharge) ALLOCATE(gmcharge(natom,nmat),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) gmcharge = 0._dp CALL get_qs_env(qs_env,& @@ -543,8 +537,7 @@ SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& cell=cell,& virial=virial,& atprop=atprop,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF ( calculate_forces ) THEN use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -552,21 +545,21 @@ SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& ! Qm-QM long range correction for QMMM calculations ! no atomic energy evaluation - CPPrecondition(.NOT.atprop%energy,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.atprop%energy,cp_failure_level,routineP,failure) ! no stress tensor possible for QMMM - CPPrecondition(.NOT.use_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.use_virial,cp_failure_level,routineP,failure) qmmm_env_qm => qs_env%qmmm_env_qm ewald_env => qmmm_env_qm%ewald_env ewald_pw => qmmm_env_qm%ewald_pw - CALL get_qs_env(qs_env=qs_env,super_cell=mm_cell,error=error) + CALL get_qs_env(qs_env=qs_env,super_cell=mm_cell) CALL get_cell(cell=mm_cell,periodic=periodic,deth=deth) - CALL ewald_env_get(ewald_env,alpha=alpha,ewald_type=ewald_type,error=error) + CALL ewald_env_get(ewald_env,alpha=alpha,ewald_type=ewald_type) gmcharge = 0.0_dp ! direct sum for overlap and local correction CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& local_particles=local_particles,& - force=force,para_env=para_env,error=error) + force=force,para_env=para_env) DO ikind=1,SIZE(local_particles%n_el) DO ia=1,local_particles%n_el(ikind) iatom=local_particles%list(ikind)%array(ia) @@ -600,19 +593,19 @@ SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& SELECT CASE(ewald_type) CASE DEFAULT - CALL cp_unimplemented_error(routineP,"Invalid Ewald type",error) + CALL cp_unimplemented_error(routineP,"Invalid Ewald type") CASE(do_ewald_none) - CPErrorMessage(cp_failure_level,routineP,"Not allowed with DFTB",error) - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Not allowed with DFTB") + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE(do_ewald_ewald) CALL cp_unimplemented_error(routineP,& - "Standard Ewald not implemented in DFTB",error) + "Standard Ewald not implemented in DFTB") CASE(do_ewald_pme) CALL cp_unimplemented_error(routineP,& - "PME not implemented in DFTB",error) + "PME not implemented in DFTB") CASE(do_ewald_spme) CALL dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,mm_cell,& - gmcharge,mcharge,calculate_forces,virial,use_virial,atprop,error) + gmcharge,mcharge,calculate_forces,virial,use_virial,atprop) END SELECT ! CALL mp_sum(gmcharge(:,1),para_env%group) @@ -627,19 +620,19 @@ SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& ! IF ( calculate_forces ) THEN ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& kind_of=kind_of,& atom_of_kind=atom_of_kind) END IF ! IF ( .NOT. just_energy ) THEN - CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s,error=error) - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s) + CALL qs_rho_get(rho, rho_ao=matrix_p) IF ( calculate_forces .AND. SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END IF CALL cp_dbcsr_iterator_start(iter, ks_matrix(1,1)%matrix) @@ -675,16 +668,16 @@ SUBROUTINE build_dftb_coulomb_qmqm(qs_env,ks_matrix,rho,mcharge,energy,& CALL cp_dbcsr_iterator_stop(iter) IF ( calculate_forces .AND. SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END IF END IF IF ( calculate_forces ) THEN DEALLOCATE (atom_of_kind,kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(gmcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -702,10 +695,9 @@ END SUBROUTINE build_dftb_coulomb_qmqm !> \param virial ... !> \param use_virial ... !> \param atprop ... -!> \param error ... ! ***************************************************************************** SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& - gmcharge,mcharge,calculate_forces,virial,use_virial,atprop,error) + gmcharge,mcharge,calculate_forces,virial,use_virial,atprop) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw @@ -720,7 +712,6 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& TYPE(virial_type), POINTER :: virial LOGICAL, INTENT(in) :: use_virial TYPE(atprop_type), POINTER :: atprop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dftb_spme_evaluate', & routineP = moduleN//':'//routineN @@ -752,28 +743,28 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& !-------------- INITIALISATION --------------------- failure = .FALSE. CALL ewald_env_get ( ewald_env, alpha=alpha, o_spline = o_spline, group = group, & - para_env=para_env, error=error) + para_env=para_env) NULLIFY(green, poisson_env, pw_pool) CALL ewald_pw_get ( ewald_pw, pw_big_pool=pw_pool, rs_desc=rs_desc, & poisson_env=poisson_env) - CALL pw_poisson_rebuild(poisson_env,error=error) + CALL pw_poisson_rebuild(poisson_env) green => poisson_env%green_fft grid_spme => pw_pool % pw_grid - CALL get_pw_grid_info(grid_spme,dvol=dvols,npts=npts,error=error) + CALL get_pw_grid_info(grid_spme,dvol=dvols,npts=npts) npart = SIZE ( particle_set ) n = o_spline ALLOCATE ( rhos ( n, n, n ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL rs_grid_create(rden, rs_desc, error=error) - CALL rs_grid_set_box ( grid_spme, rs=rden, error=error ) + CALL rs_grid_create(rden, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=rden) CALL rs_grid_zero ( rden ) ALLOCATE ( center ( 3, npart ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( particle_set, box, center, npts, n ) !-------------- DENSITY CALCULATION ---------------- @@ -792,14 +783,14 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& END DO CALL pw_pool_create_pw ( pw_pool, rhob_r, use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) - CALL rs_pw_transfer ( rden, rhob_r, rs2pw, error=error) + CALL rs_pw_transfer ( rden, rhob_r, rs2pw) ! transform density to G space and add charge function CALL pw_pool_create_pw ( pw_pool, rhob_g, use_data = COMPLEXDATA1D, & - in_space = RECIPROCALSPACE ,error=error) - CALL pw_transfer ( rhob_r, rhob_g, error=error) + in_space = RECIPROCALSPACE) + CALL pw_transfer ( rhob_r, rhob_g) ! update charge function rhob_g % cc = rhob_g % cc * green % p3m_charge % cr @@ -809,26 +800,26 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& DO i = 1, 3 NULLIFY(dphi_g(i)%pw) CALL pw_pool_create_pw ( pw_pool, dphi_g ( i )%pw, & - use_data = COMPLEXDATA1D,in_space = RECIPROCALSPACE, error=error) + use_data = COMPLEXDATA1D,in_space = RECIPROCALSPACE) END DO CALL pw_pool_create_pw ( pw_pool, phi_g, & - use_data = COMPLEXDATA1D, in_space = RECIPROCALSPACE, error=error) + use_data = COMPLEXDATA1D, in_space = RECIPROCALSPACE) IF ( use_virial ) THEN - CALL pw_poisson_solve ( poisson_env, rhob_g, vgc, phi_g, dphi_g, h_stress=h_stress, error=error) + CALL pw_poisson_solve ( poisson_env, rhob_g, vgc, phi_g, dphi_g, h_stress=h_stress) ELSE - CALL pw_poisson_solve ( poisson_env, rhob_g, vgc, phi_g, dphi_g, error=error) + CALL pw_poisson_solve ( poisson_env, rhob_g, vgc, phi_g, dphi_g) END IF - CALL rs_grid_create(rpot, rs_desc, error=error ) - CALL rs_grid_set_box ( grid_spme, rs=rpot, error=error ) + CALL rs_grid_create(rpot, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=rpot) ! Atomic Stress IF (atprop%stress .AND. use_virial) THEN CALL rs_grid_zero ( rpot ) rhob_g%cc = phi_g%cc * green%p3m_charge%cr - CALL pw_transfer ( rhob_g, rhob_r, error=error) - CALL rs_pw_transfer ( rpot, rhob_r, pw2rs, error=error) + CALL pw_transfer ( rhob_g, rhob_r) + CALL rs_pw_transfer ( rpot, rhob_r, pw2rs) ipart = 0 DO CALL set_list ( particle_set, npart, center, p1, rden, ipart ) @@ -843,7 +834,7 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& END DO CALL pw_pool_create_pw ( pw_pool, phib_g, & - use_data = COMPLEXDATA1D, in_space = RECIPROCALSPACE, error=error) + use_data = COMPLEXDATA1D, in_space = RECIPROCALSPACE) ffa = ( 0.5_dp / alpha ) ** 2 ffb = 1.0_dp / fourpi DO i = 1, 3 @@ -855,11 +846,11 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& DO j = 1, i nd = 0 nd ( j ) = 1 - CALL pw_copy ( phib_g, rhob_g, error=error) - CALL pw_derive ( rhob_g, nd , error=error) + CALL pw_copy ( phib_g, rhob_g) + CALL pw_derive ( rhob_g, nd) rhob_g%cc = rhob_g%cc * green%p3m_charge%cr - CALL pw_transfer ( rhob_g, rhob_r, error=error) - CALL rs_pw_transfer ( rpot, rhob_r, pw2rs, error=error) + CALL pw_transfer ( rhob_g, rhob_r) + CALL rs_pw_transfer ( rpot, rhob_r, pw2rs) ipart = 0 DO @@ -876,17 +867,17 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& END DO END DO - CALL pw_pool_give_back_pw ( pw_pool, phib_g ,error=error) + CALL pw_pool_give_back_pw ( pw_pool, phib_g) END IF - CALL pw_pool_give_back_pw ( pw_pool, rhob_g ,error=error) + CALL pw_pool_give_back_pw ( pw_pool, rhob_g) CALL rs_grid_zero ( rpot ) phi_g%cc = phi_g%cc * green%p3m_charge%cr - CALL pw_transfer ( phi_g, rhob_r, error=error) - CALL pw_pool_give_back_pw ( pw_pool, phi_g ,error=error) - CALL rs_pw_transfer ( rpot, rhob_r, pw2rs, error=error) + CALL pw_transfer ( phi_g, rhob_r) + CALL pw_pool_give_back_pw ( pw_pool, phi_g) + CALL rs_pw_transfer ( rpot, rhob_r, pw2rs) !---------- END OF ELECTROSTATIC CALCULATION -------- @@ -895,7 +886,7 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& IF ( use_virial ) THEN DO i = 1, 3 DO j = i, 3 - f_stress(i,j) = pw_integral_a2b(dphi_g(i)%pw,dphi_g(j)%pw,error=error) + f_stress(i,j) = pw_integral_a2b(dphi_g(i)%pw,dphi_g(j)%pw) f_stress(j,i) = f_stress(i,j) END DO END DO @@ -909,21 +900,21 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& ! move derivative of potential to real space grid and ! multiply by charge function in g-space ALLOCATE ( drpot(1:3), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, 3 - CALL rs_grid_create(drpot(i)%rs_grid, rs_desc, error=error) - CALL rs_grid_set_box ( grid_spme, rs=drpot(i)%rs_grid, error=error ) + CALL rs_grid_create(drpot(i)%rs_grid, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=drpot(i)%rs_grid) dphi_g ( i ) % pw % cc = dphi_g ( i ) % pw % cc * green % p3m_charge % cr - CALL pw_transfer ( dphi_g ( i )%pw, rhob_r, error=error) - CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw ,error=error) - CALL rs_pw_transfer ( drpot ( i ) % rs_grid, rhob_r, pw2rs, error=error) + CALL pw_transfer ( dphi_g ( i )%pw, rhob_r) + CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw) + CALL rs_pw_transfer ( drpot ( i ) % rs_grid, rhob_r, pw2rs) END DO ELSE DO i = 1, 3 - CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw ,error=error) + CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw) END DO END IF - CALL pw_pool_give_back_pw ( pw_pool, rhob_r ,error=error) + CALL pw_pool_give_back_pw ( pw_pool, rhob_r) !----------------- FORCE CALCULATION ---------------- @@ -953,21 +944,21 @@ SUBROUTINE dftb_spme_evaluate (ewald_env,ewald_pw,particle_set,box,& !------------------CLEANING UP ---------------------- - CALL rs_grid_release(rden, error=error) - CALL rs_grid_release(rpot, error=error) + CALL rs_grid_release(rden) + CALL rs_grid_release(rpot) IF ( calculate_forces ) THEN IF (ASSOCIATED(drpot)) THEN DO i = 1, 3 - CALL rs_grid_release(drpot(i)%rs_grid, error=error) + CALL rs_grid_release(drpot(i)%rs_grid) END DO DEALLOCATE ( drpot, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF DEALLOCATE ( rhos, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -982,9 +973,8 @@ END SUBROUTINE dftb_spme_evaluate !> \param virial ... !> \param use_virial ... !> \param atprop ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dftb_ewald_overlap(gmcharge,mcharge,alpha,n_list,virial,use_virial,atprop,error) + SUBROUTINE dftb_ewald_overlap(gmcharge,mcharge,alpha,n_list,virial,use_virial,atprop) REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: gmcharge @@ -995,7 +985,6 @@ SUBROUTINE dftb_ewald_overlap(gmcharge,mcharge,alpha,n_list,virial,use_virial,at TYPE(virial_type), POINTER :: virial LOGICAL, INTENT(IN) :: use_virial TYPE(atprop_type), POINTER :: atprop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dftb_ewald_overlap', & routineP = moduleN//':'//routineN @@ -1028,10 +1017,10 @@ SUBROUTINE dftb_ewald_overlap(gmcharge,mcharge,alpha,n_list,virial,use_virial,at END IF IF ( use_virial ) THEN pfr = -dfr*mcharge(iatom)*mcharge(jatom) - CALL virial_pair_force ( virial%pv_virial, -pfr, rij, rij, error) + CALL virial_pair_force ( virial%pv_virial, -pfr, rij, rij) IF ( atprop%stress ) THEN - CALL virial_pair_force ( atprop%atstress(:,:,iatom), -0.5_dp*pfr, rij, rij, error) - CALL virial_pair_force ( atprop%atstress(:,:,jatom), -0.5_dp*pfr, rij, rij, error) + CALL virial_pair_force ( atprop%atstress(:,:,iatom), -0.5_dp*pfr, rij, rij) + CALL virial_pair_force ( atprop%atstress(:,:,jatom), -0.5_dp*pfr, rij, rij) END IF END IF END IF diff --git a/src/qs_dftb_dispersion.F b/src/qs_dftb_dispersion.F index d42ce5ec8f..338ad4bf23 100644 --- a/src/qs_dftb_dispersion.F +++ b/src/qs_dftb_dispersion.F @@ -58,14 +58,12 @@ MODULE qs_dftb_dispersion !> \param qs_env ... !> \param para_env ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_dftb_dispersion(qs_env,para_env,calculate_forces,error) + SUBROUTINE calculate_dftb_dispersion(qs_env,para_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_dftb_dispersion', & routineP = moduleN//':'//routineN @@ -79,7 +77,7 @@ SUBROUTINE calculate_dftb_dispersion(qs_env,para_env,calculate_forces,error) failure = .FALSE. CALL get_qs_env(qs_env=qs_env,& energy=energy,& - dft_control=dft_control,error=error) + dft_control=dft_control) energy%dispersion = 0._dp @@ -87,13 +85,13 @@ SUBROUTINE calculate_dftb_dispersion(qs_env,para_env,calculate_forces,error) IF ( dftb_control%dispersion ) THEN SELECT CASE (dftb_control%dispersion_type) CASE (dispersion_uff) - CALL calculate_dispersion_uff(qs_env,para_env,calculate_forces,error) + CALL calculate_dispersion_uff(qs_env,para_env,calculate_forces) CASE (dispersion_d3) - CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,error=error) + CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env) CALL calculate_dispersion_pairpot(qs_env,dispersion_env,& - energy%dispersion,calculate_forces,error) + energy%dispersion,calculate_forces) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF @@ -104,14 +102,12 @@ END SUBROUTINE calculate_dftb_dispersion !> \param qs_env ... !> \param para_env ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_dispersion_uff(qs_env,para_env,calculate_forces,error) + SUBROUTINE calculate_dispersion_uff(qs_env,para_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_dispersion_uff', & routineP = moduleN//':'//routineN @@ -157,7 +153,7 @@ SUBROUTINE calculate_dispersion_uff(qs_env,para_env,calculate_forces,error) atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& virial=virial,atprop=atprop,& - dft_control=dft_control,error=error) + dft_control=dft_control) energy%dispersion = 0._dp @@ -166,15 +162,15 @@ SUBROUTINE calculate_dispersion_uff(qs_env,para_env,calculate_forces,error) IF ( dftb_control%dispersion ) THEN NULLIFY (dftb_potential) - CALL get_qs_env(qs_env=qs_env,dftb_potential=dftb_potential,error=error) + CALL get_qs_env(qs_env=qs_env,dftb_potential=dftb_potential) IF(calculate_forces) THEN NULLIFY (force,particle_set) CALL get_qs_env(qs_env=qs_env,& particle_set=particle_set,& - force=force,error=error) + force=force) natom = SIZE (particle_set) ALLOCATE (atom_of_kind(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ELSE @@ -182,21 +178,21 @@ SUBROUTINE calculate_dispersion_uff(qs_env,para_env,calculate_forces,error) END IF nkind = SIZE(atomic_kind_set) ALLOCATE (define_kind(nkind),rc_kind(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind_a) CALL get_dftb_atom_param(dftb_kind_a,defined=define_kind(ikind),rcdisp=rc_kind(ikind)) END DO evdw = 0._dp IF (atprop%energy) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE (particle_set) - CALL atprop_array_init(atprop%atevdw,natom,error) + CALL atprop_array_init(atprop%atevdw,natom) END IF - CALL get_qs_env(qs_env=qs_env,sab_vdw=sab_vdw,error=error) + CALL get_qs_env(qs_env=qs_env,sab_vdw=sab_vdw) CALL neighbor_list_iterator_create(nl_iterator,sab_vdw) DO WHILE (neighbor_list_iterate(nl_iterator)==0) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,iatom=iatom,jatom=jatom,r=rij) @@ -256,10 +252,10 @@ SUBROUTINE calculate_dispersion_uff(qs_env,para_env,calculate_forces,error) atprop%atevdw(jatom) = atprop%atevdw(jatom) + 0.5_dp*eij END IF IF(calculate_forces .AND. (dr > 0.001_dp) .AND. use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rij) IF (atprop%stress) THEN - CALL virial_pair_force(atprop%atstress(:,:,iatom),-0.5_dp,fdij,rij,error) - CALL virial_pair_force(atprop%atstress(:,:,jatom),-0.5_dp,fdij,rij,error) + CALL virial_pair_force(atprop%atstress(:,:,iatom),-0.5_dp,fdij,rij) + CALL virial_pair_force(atprop%atstress(:,:,jatom),-0.5_dp,fdij,rij) END IF END IF END IF @@ -268,7 +264,7 @@ SUBROUTINE calculate_dispersion_uff(qs_env,para_env,calculate_forces,error) IF(calculate_forces) THEN DEALLOCATE (atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! set dispersion energy diff --git a/src/qs_dftb_matrices.F b/src/qs_dftb_matrices.F index b80f6733f6..4e5c1069b0 100644 --- a/src/qs_dftb_matrices.F +++ b/src/qs_dftb_matrices.F @@ -139,14 +139,12 @@ MODULE qs_dftb_matrices !> \param qs_env ... !> \param para_env ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) + SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_dftb_matrices', & routineP = moduleN//':'//routineN @@ -223,7 +221,7 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) END DO NULLIFY(logger, virial, atprop) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY (matrix_h,matrix_s,matrix_p,matrix_w,gamma_matrix,atomic_kind_set,& qs_kind_set,sab_orb,ks_env) @@ -236,24 +234,23 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) matrix_s_kp=matrix_s,& atprop=atprop,& dft_control=dft_control,& - ks_env=ks_env,& - error=error) + ks_env=ks_env) dftb_control => dft_control%qs_control%dftb_control nimg = dft_control%nimages ! Allocate the overlap and Hamiltonian matrix - CALL get_qs_env(qs_env=qs_env,sab_orb=sab_orb,error=error) + CALL get_qs_env(qs_env=qs_env,sab_orb=sab_orb) nderivatives=0 IF(dftb_control%self_consistent .AND. calculate_forces)nderivatives=1 - CALL setup_matrices2(qs_env,nderivatives,nimg,matrix_s,"OVERLAP",sab_orb,error) - CALL setup_matrices2(qs_env,0,nimg,matrix_h,"CORE HAMILTONIAN",sab_orb,error) - CALL set_ks_env(ks_env,matrix_s_kp=matrix_s,error=error) - CALL set_ks_env(ks_env,matrix_h_kp=matrix_h,error=error) + CALL setup_matrices2(qs_env,nderivatives,nimg,matrix_s,"OVERLAP",sab_orb) + CALL setup_matrices2(qs_env,0,nimg,matrix_h,"CORE HAMILTONIAN",sab_orb) + CALL set_ks_env(ks_env,matrix_s_kp=matrix_s) + CALL set_ks_env(ks_env,matrix_h_kp=matrix_h) NULLIFY (dftb_potential) - CALL get_qs_env(qs_env=qs_env,dftb_potential=dftb_potential,error=error) + CALL get_qs_env(qs_env=qs_env,dftb_potential=dftb_potential) NULLIFY (particle_set) - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) ! gamma matrix allocation IF ( dftb_control%self_consistent ) THEN @@ -263,8 +260,8 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) nmat=1 END IF CALL get_qs_env(qs_env=qs_env,& - gamma_matrix=gamma_matrix,error=error) - CALL setup_gamma(qs_env,nmat,gamma_matrix,sab_orb,error) + gamma_matrix=gamma_matrix) + CALL setup_gamma(qs_env,nmat,gamma_matrix,sab_orb) END IF IF(calculate_forces) THEN @@ -273,20 +270,20 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) rho=rho,& matrix_w_kp=matrix_w,& virial=virial,& - force=force,error=error) - CALL qs_rho_get(rho,rho_ao_kp=matrix_p,error=error) + force=force) + CALL qs_rho_get(rho,rho_ao_kp=matrix_p) IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimg CALL cp_dbcsr_add(matrix_p(1,img)%matrix,matrix_p(2,img)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_w(1,img)%matrix,matrix_w(2,img)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END DO END IF natom = SIZE(particle_set) ALLOCATE (atom_of_kind(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -294,13 +291,13 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) ! atomic energy decomposition IF (atprop%energy) THEN natom = SIZE(particle_set) - CALL atprop_array_init(atprop%atecc,natom,error) + CALL atprop_array_init(atprop%atecc,natom) END IF NULLIFY(cell_to_index) IF (nimg>1) THEN - CALL get_ks_env(ks_env=ks_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_ks_env(ks_env=ks_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF erep = 0._dp @@ -312,13 +309,13 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,& iatom=iatom,jatom=jatom,inode=inode,r=rij,cell=cell) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind_a) CALL get_dftb_atom_param(dftb_kind_a,& defined=defined,lmax=lmaxi,skself=skself,& eta=eta_a,natorb=natorb_a) IF (.NOT.defined .OR. natorb_a < 1) CYCLE - CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_kind_b, error=error) + CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_kind_b) CALL get_dftb_atom_param(dftb_kind_b,& defined=defined,lmax=lmaxj,eta=eta_b,natorb=natorb_b) @@ -332,7 +329,7 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) ngrdcut = dftb_param_ij%ngrdcut dgrd = dftb_param_ij%dgrd ddr = dgrd*0.1_dp - CPPrecondition(dftb_param_ij%llm==dftb_param_ji%llm,cp_failure_level,routineP,error,failure) + CPPrecondition(dftb_param_ij%llm==dftb_param_ji%llm,cp_failure_level,routineP,failure) llm = dftb_param_ij%llm fmatij => dftb_param_ij%fmat smatij => dftb_param_ij%smat @@ -356,7 +353,7 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) ic = 1 ELSE ic = cell_to_index(cell(1),cell(2),cell(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) END IF icol = MAX(iatom,jatom) @@ -364,14 +361,14 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) NULLIFY(sblock,fblock,gblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1,ic)%matrix,& row=irow,col=icol,BLOCK=sblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=matrix_h(1,ic)%matrix,& row=irow,col=icol,BLOCK=fblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) IF ( dftb_control%self_consistent ) THEN CALL cp_dbcsr_get_block_p(matrix=gamma_matrix(1)%matrix,& row=irow,col=icol,BLOCK=gblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END IF @@ -379,21 +376,21 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) NULLIFY (pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1,ic)%matrix,& row=irow,col=icol,block=pblock,found=found) - CPPrecondition(ASSOCIATED(pblock),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pblock),cp_failure_level,routineP,failure) NULLIFY (wblock) CALL cp_dbcsr_get_block_p(matrix=matrix_w(1,ic)%matrix,& row=irow,col=icol,block=wblock,found=found) - CPPrecondition(ASSOCIATED(wblock),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wblock),cp_failure_level,routineP,failure) IF ( dftb_control%self_consistent ) THEN DO i=2,4 NULLIFY(dsblocks(i)%block) CALL cp_dbcsr_get_block_p(matrix=matrix_s(i,ic)%matrix,& row=irow,col=icol,BLOCK=dsblocks(i)%block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) NULLIFY (dgblocks(i)%block) CALL cp_dbcsr_get_block_p(matrix=gamma_matrix(i)%matrix,& row=irow,col=icol,BLOCK=dgblocks(i)%block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END DO END IF END IF @@ -419,7 +416,7 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) IF ( irow == iatom ) f0=-1.0_dp ALLOCATE (dfblock(n1,n2),dsblock(n1,n2),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,3 drij = rij @@ -445,23 +442,23 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) force_ab(i) = force_ab(i) + foab force_w(i) = force_w(i) + fow IF ( dftb_control%self_consistent ) THEN - CPPrecondition(ASSOCIATED(dsblocks(i+1)%block),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dsblocks(i+1)%block),cp_failure_level,routineP,failure) dsblocks(i+1)%block = dsblocks(i+1)%block + dsblock END IF ENDDO IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -f0, force_ab, rij, error) - CALL virial_pair_force ( virial%pv_virial, -f0, force_w, rij, error) + CALL virial_pair_force ( virial%pv_virial, -f0, force_ab, rij) + CALL virial_pair_force ( virial%pv_virial, -f0, force_w, rij) IF (atprop%stress) THEN f1 = 0.5_dp*f0 - CALL virial_pair_force (atprop%atstress(:,:,iatom),-f1,force_ab,rij,error) - CALL virial_pair_force (atprop%atstress(:,:,iatom),-f1,force_w,rij,error) - CALL virial_pair_force (atprop%atstress(:,:,jatom),-f1,force_ab,rij,error) - CALL virial_pair_force (atprop%atstress(:,:,jatom),-f1,force_w,rij,error) + CALL virial_pair_force (atprop%atstress(:,:,iatom),-f1,force_ab,rij) + CALL virial_pair_force (atprop%atstress(:,:,iatom),-f1,force_w,rij) + CALL virial_pair_force (atprop%atstress(:,:,jatom),-f1,force_ab,rij) + CALL virial_pair_force (atprop%atstress(:,:,jatom),-f1,force_w,rij) END IF END IF DEALLOCATE (dfblock,dsblock,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -497,7 +494,7 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) drm = dr - ddr dgam = 0.5_dp*(gamma_rab_sr(drp,ga,gb,hb_para)-gamma_rab_sr(drm,ga,gb,hb_para))/ddr DO i=1,3 - CPPrecondition(ASSOCIATED(dgblocks(i+1)%block),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dgblocks(i+1)%block),cp_failure_level,routineP,failure) IF ( irow == iatom ) THEN dgblocks(i+1)%block(1,1)= dgblocks(i+1)%block(1,1) + dgam*rij(i)/dr ELSE @@ -527,10 +524,10 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) force(jkind)%repulsive(:,atom_b) =& force(jkind)%repulsive(:,atom_b) + force_rr(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, force_rr, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, force_rr, rij) IF(atprop%stress) THEN - CALL virial_pair_force(atprop%atstress(:,:,iatom),-0.5_dp,force_rr,rij,error) - CALL virial_pair_force(atprop%atstress(:,:,jatom),-0.5_dp,force_rr,rij,error) + CALL virial_pair_force(atprop%atstress(:,:,iatom),-0.5_dp,force_rr,rij) + CALL virial_pair_force(atprop%atstress(:,:,jatom),-0.5_dp,force_rr,rij) END IF END IF END IF @@ -541,18 +538,18 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) IF ( dftb_control%self_consistent ) THEN DO i=1,SIZE(gamma_matrix) - CALL cp_dbcsr_finalize(gamma_matrix(i)%matrix,error=error) + CALL cp_dbcsr_finalize(gamma_matrix(i)%matrix) ENDDO - CALL set_ks_env(ks_env,gamma_matrix=gamma_matrix,error=error) + CALL set_ks_env(ks_env,gamma_matrix=gamma_matrix) ENDIF DO i=1,SIZE(matrix_s,1) DO img=1,nimg - CALL cp_dbcsr_finalize(matrix_s(i,img)%matrix,error=error) + CALL cp_dbcsr_finalize(matrix_s(i,img)%matrix) END DO ENDDO DO i=1,SIZE(matrix_h,1) DO img=1,nimg - CALL cp_dbcsr_finalize(matrix_h(i,img)%matrix,error=error) + CALL cp_dbcsr_finalize(matrix_h(i,img)%matrix) END DO ENDDO @@ -561,52 +558,52 @@ SUBROUTINE build_dftb_matrices(qs_env,para_env,calculate_forces,error) energy%repulsive = erep IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) DO img=1,nimg CALL cp_dbcsr_write_sparse_matrix(matrix_h(1,img)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END DO CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN", error=error) + "DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/OVERLAP",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/OVERLAP"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/OVERLAP",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) DO img=1,nimg CALL cp_dbcsr_write_sparse_matrix(matrix_s(1,img)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/DERIVATIVES",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/DERIVATIVES"),cp_p_file)) THEN DO i=2,SIZE(matrix_s,1) CALL cp_dbcsr_write_sparse_matrix(matrix_s(i,img)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END DO END IF END DO CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/OVERLAP", error=error) + "DFT%PRINT%AO_MATRICES/OVERLAP") END IF IF (calculate_forces) THEN IF (SIZE(matrix_p,1) == 2) THEN DO img=1,nimg CALL cp_dbcsr_add(matrix_p(1,img)%matrix,matrix_p(2,img)%matrix,alpha_scalar=1.0_dp,& - beta_scalar=-1.0_dp,error=error) + beta_scalar=-1.0_dp) END DO END IF DEALLOCATE(atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -618,12 +615,10 @@ END SUBROUTINE build_dftb_matrices !> \param qs_env ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_dftb_ks_matrix(qs_env,calculate_forces,just_energy,error) + SUBROUTINE build_dftb_ks_matrix(qs_env,calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_dftb_ks_matrix', & routineP = moduleN//':'//routineN @@ -661,9 +656,9 @@ SUBROUTINE build_dftb_ks_matrix(qs_env,calculate_forces,just_energy,error) CALL timeset(routineN,handle) NULLIFY(dft_control, logger, scf_section,matrix_p, particle_set, ks_env,& ks_matrix, rho, energy) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure=.FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& dft_control=dft_control,& @@ -674,42 +669,41 @@ SUBROUTINE build_dftb_ks_matrix(qs_env,calculate_forces,just_energy,error) ks_env=ks_env,& matrix_ks_kp=ks_matrix,& rho=rho,& - energy=energy,& - error=error) + energy=energy) energy%hartree = 0.0_dp energy%qmmm_el = 0.0_dp - scf_section => section_vals_get_subs_vals(qs_env%input,"DFT%SCF",error=error) + scf_section => section_vals_get_subs_vals(qs_env%input,"DFT%SCF") nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(matrix_h),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_h),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) DO ispin=1,nspins DO img=1,SIZE(ks_matrix,2) ! copy the core matrix into the fock matrix - CALL cp_dbcsr_copy(ks_matrix(ispin,img)%matrix,matrix_h(1,img)%matrix,error=error) + CALL cp_dbcsr_copy(ks_matrix(ispin,img)%matrix,matrix_h(1,img)%matrix) END DO END DO IF ( dft_control%qs_control%dftb_control%self_consistent ) THEN ! Mulliken charges CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,& - matrix_s_kp=matrix_s,error=error) - CALL qs_rho_get(rho,rho_ao_kp=matrix_p,error=error) + matrix_s_kp=matrix_s) + CALL qs_rho_get(rho,rho_ao_kp=matrix_p) natom=SIZE(particle_set) ALLOCATE(charges(natom,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! - CALL mulliken_charges(matrix_p,matrix_s,para_env,charges,error=error) + CALL mulliken_charges(matrix_p,matrix_s,para_env,charges) ! ALLOCATE(mcharge(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom) - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,zeff=zeff) DO iatom=1,natom atom_a = atomic_kind_set(ikind)%atom_list(iatom) @@ -717,26 +711,26 @@ SUBROUTINE build_dftb_ks_matrix(qs_env,calculate_forces,just_energy,error) END DO END DO DEALLOCATE(charges,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL build_dftb_coulomb(qs_env,ks_matrix,rho,mcharge,energy,& - calculate_forces,just_energy,error) + calculate_forces,just_energy) DEALLOCATE(mcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (qs_env%qmmm) THEN - CPPrecondition(SIZE(ks_matrix,2)==1,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(ks_matrix,2)==1,cp_failure_level,routineP,failure) DO ispin = 1, nspins ! If QM/MM sumup the 1el Hamiltonian CALL cp_dbcsr_add(ks_matrix(ispin,1)%matrix,qs_env%ks_qmmm_env%matrix_h(1)%matrix,& - 1.0_dp,1.0_dp,error=error) - CALL qs_rho_get(rho,rho_ao=matrix_p1,error=error) + 1.0_dp,1.0_dp) + CALL qs_rho_get(rho,rho_ao=matrix_p1) ! Compute QM/MM Energy CALL cp_dbcsr_trace(qs_env%ks_qmmm_env%matrix_h(1)%matrix,& - matrix_p1(ispin)%matrix,trace=qmmm_el,error=error) + matrix_p1(ispin)%matrix,trace=qmmm_el) energy%qmmm_el = energy%qmmm_el + qmmm_el END DO pc_ener = qs_env%ks_qmmm_env%pc_ener @@ -747,7 +741,7 @@ SUBROUTINE build_dftb_ks_matrix(qs_env,calculate_forces,just_energy,error) energy%repulsive + energy%dispersion + energy%dftb3 output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%DETAILED_ENERGY",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,(T9,A,T60,F20.10))")& "Repulsive pair potential energy: ",energy%repulsive,& @@ -764,19 +758,19 @@ SUBROUTINE build_dftb_ks_matrix(qs_env,calculate_forces,just_energy,error) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%DETAILED_ENERGY", error=error) + "PRINT%DETAILED_ENERGY") ! here we compute dE/dC if needed. Assumes dE/dC is H_{ks}C (plus occupation numbers) IF (qs_env%requires_mo_derivs .AND. .NOT. just_energy) THEN - CPPrecondition(SIZE(ks_matrix,2)==1,cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array,error=error) + CPPrecondition(SIZE(ks_matrix,2)==1,cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array) DO ispin=1,SIZE(mo_derivs) CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff_b=mo_coeff, occupation_numbers=occupation_numbers ) IF(.NOT.mo_array(ispin)%mo_set%use_mo_coeff_b) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL cp_dbcsr_multiply('n','n',1.0_dp,ks_matrix(ispin,1)%matrix,mo_coeff,& - 0.0_dp,mo_derivs(ispin)%matrix, error=error) + 0.0_dp,mo_derivs(ispin)%matrix) ENDDO ENDIF @@ -789,15 +783,13 @@ END SUBROUTINE build_dftb_ks_matrix !> \param qs_env ... !> \param nderivative ... !> \param matrix_s ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) + SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: nderivative TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_dftb_overlap', & routineP = moduleN//':'//routineN @@ -849,25 +841,25 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) END DO NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY ( atomic_kind_set, qs_kind_set, sab_orb) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& - dft_control=dft_control,error=error) + dft_control=dft_control) dftb_control => dft_control%qs_control%dftb_control NULLIFY (dftb_potential) CALL get_qs_env(qs_env=qs_env,& - dftb_potential=dftb_potential,error=error) + dftb_potential=dftb_potential) nkind = SIZE(atomic_kind_set) ! Allocate the overlap matrix - CALL get_qs_env(qs_env=qs_env,sab_orb=sab_orb,error=error) - CALL setup_matrices1(qs_env,nderivative,matrix_s,'OVERLAP',sab_orb,error) + CALL get_qs_env(qs_env=qs_env,sab_orb=sab_orb) + CALL setup_matrices1(qs_env,nderivative,matrix_s,'OVERLAP',sab_orb) CALL neighbor_list_iterator_create(nl_iterator,sab_orb) DO WHILE (neighbor_list_iterate(nl_iterator)==0) @@ -875,14 +867,14 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) iatom=iatom,jatom=jatom,inode=inode,r=rij) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom) - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind_a) CALL get_dftb_atom_param(dftb_kind_a,& defined=defined,lmax=lmaxi,skself=skself,& natorb=natorb_a) IF (.NOT.defined .OR. natorb_a < 1) CYCLE - CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_kind_b, error=error) + CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_kind_b) CALL get_dftb_atom_param(dftb_kind_b,& defined=defined,lmax=lmaxj,natorb=natorb_b) @@ -896,7 +888,7 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) ngrdcut = dftb_param_ij%ngrdcut dgrd = dftb_param_ij%dgrd ddr = dgrd*0.1_dp - CPPrecondition(dftb_param_ij%llm==dftb_param_ji%llm,cp_failure_level,routineP,error,failure) + CPPrecondition(dftb_param_ij%llm==dftb_param_ji%llm,cp_failure_level,routineP,failure) llm = dftb_param_ij%llm smatij => dftb_param_ij%smat smatji => dftb_param_ji%smat @@ -909,7 +901,7 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) NULLIFY(sblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1)%matrix,& row=irow,col=icol,BLOCK=sblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) IF (nderivative.gt.0) THEN DO i=2,SIZE(matrix_s,1) @@ -934,7 +926,7 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) indder=1 ! used to put the 2nd derivatives in the correct matric (5=xx,8=yy,10=zz) ALLOCATE (dsblock1(n1,n2,3),dsblock(n1,n2),dsblockm(n1,n2),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) dsblock1=0.0_dp DO i=1,3 dsblock=0._dp; dsblockm=0.0_dp @@ -953,7 +945,7 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) dsblock = dsblock-dsblockm dsblock = dsblock/(2.0_dp*ddr) - CPPrecondition(ASSOCIATED(dsblocks(i+1)%block),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dsblocks(i+1)%block),cp_failure_level,routineP,failure) dsblocks(i+1)%block = dsblocks(i+1)%block + dsblock IF(nderivative.gt.1) THEN indder=indder+5-i @@ -987,7 +979,7 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) END IF DEALLOCATE (dsblock1,dsblock,dsblockm,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF END IF @@ -995,7 +987,7 @@ SUBROUTINE build_dftb_overlap(qs_env,nderivative,matrix_s,error) CALL neighbor_list_iterator_release(nl_iterator) DO i=1,SIZE(matrix_s,1) - CALL cp_dbcsr_finalize(matrix_s(i)%matrix,error=error) + CALL cp_dbcsr_finalize(matrix_s(i)%matrix) ENDDO CALL timestop(handle) @@ -1009,10 +1001,9 @@ END SUBROUTINE build_dftb_overlap !> \param particles_mm ... !> \param mm_cell ... !> \param para_env ... -!> \param error ... !> \author JGH 10.2014 [created] ! ***************************************************************************** - SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,error) + SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env @@ -1020,7 +1011,6 @@ SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, POINTER :: particles_mm TYPE(cell_type), POINTER :: mm_cell TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_dftb_qmmm_matrix', & routineP = moduleN//':'//routineN @@ -1059,16 +1049,15 @@ SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, particle_set=particles_qm,& qs_kind_set=qs_kind_set,& rho=rho,& - natom=natom,& - error=error) + natom=natom) dftb_control => dft_control%qs_control%dftb_control - CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input,error=error) + CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input) NULLIFY(matrix_s) - CALL build_dftb_overlap(qs_env,0,matrix_s,error) + CALL build_dftb_overlap(qs_env,0,matrix_s) ALLOCATE(qpot(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qpot = 0.0_dp pc_ener = 0.0_dp @@ -1076,7 +1065,7 @@ SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,zeff=zeff,& defined=defined,eta=eta_a,natorb=natorb) ! use mm charge smearing for non-scc cases @@ -1086,28 +1075,28 @@ SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, iatom = list(i) CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,& - qmmm_env%spherical_cutoff,particles_qm,error) + qmmm_env%spherical_cutoff,particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,qmmm_env%spherical_cutoff,& - particles_qm,error) + particles_qm) END IF pc_ener = pc_ener + qpot(iatom)*zeff END DO END DO ! Allocate the core Hamiltonian matrix - CALL get_qs_env(qs_env=qs_env,ks_qmmm_env=ks_qmmm_env_loc,error=error) + CALL get_qs_env(qs_env=qs_env,ks_qmmm_env=ks_qmmm_env_loc) matrix_h => ks_qmmm_env_loc%matrix_h - CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_h,1) ALLOCATE(matrix_h(1)%matrix,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_h(1)%matrix,error) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_h(1)%matrix) CALL cp_dbcsr_copy(matrix_h(1)%matrix,matrix_s(1)%matrix,& - name="QMMM HAMILTONIAN MATRIX",error=error) - CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp,error) + name="QMMM HAMILTONIAN MATRIX") + CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp) CALL cp_dbcsr_iterator_start(iter, matrix_s(1)%matrix) DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) @@ -1115,7 +1104,7 @@ SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, NULLIFY(hblock) CALL cp_dbcsr_get_block_p(matrix=matrix_h(1)%matrix,& row=iatom,col=jatom,block=hblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) hblock = hblock - 0.5_dp*sblock*(qpot(iatom)+qpot(jatom)) END DO CALL cp_dbcsr_iterator_stop(iter) @@ -1124,9 +1113,9 @@ SUBROUTINE build_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, ks_qmmm_env_loc%pc_ener = pc_ener DEALLOCATE(qpot,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_deallocate_matrix_set ( matrix_s, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( matrix_s) CALL timestop(handle) @@ -1136,14 +1125,12 @@ END SUBROUTINE build_dftb_qmmm_matrix !> \brief Constructs an empty 1-el DFTB hamiltonian !> \param qs_env ... !> \param para_env ... -!> \param error ... !> \author JGH 10.2014 [created] ! ***************************************************************************** - SUBROUTINE build_dftb_qmmm_matrix_zero(qs_env,para_env,error) + SUBROUTINE build_dftb_qmmm_matrix_zero(qs_env,para_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_dftb_qmmm_matrix_zero', & routineP = moduleN//':'//routineN @@ -1158,24 +1145,24 @@ SUBROUTINE build_dftb_qmmm_matrix_zero(qs_env,para_env,error) failure = .FALSE. - CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input,error=error) + CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input) NULLIFY(matrix_s) - CALL build_dftb_overlap(qs_env,0,matrix_s,error) + CALL build_dftb_overlap(qs_env,0,matrix_s) ! Allocate the core Hamiltonian matrix - CALL get_qs_env(qs_env=qs_env,ks_qmmm_env=ks_qmmm_env_loc,error=error) + CALL get_qs_env(qs_env=qs_env,ks_qmmm_env=ks_qmmm_env_loc) matrix_h => ks_qmmm_env_loc%matrix_h - CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_h,1) ALLOCATE(matrix_h(1)%matrix,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_h(1)%matrix,error) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_h(1)%matrix) CALL cp_dbcsr_copy(matrix_h(1)%matrix,matrix_s(1)%matrix,& - name="QMMM HAMILTONIAN MATRIX",error=error) - CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp,error) + name="QMMM HAMILTONIAN MATRIX") + CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp) ks_qmmm_env_loc%matrix_h => matrix_h ks_qmmm_env_loc%pc_ener = 0.0_dp - CALL cp_dbcsr_deallocate_matrix_set ( matrix_s, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( matrix_s) CALL timestop(handle) @@ -1188,10 +1175,9 @@ END SUBROUTINE build_dftb_qmmm_matrix_zero !> \param particles_mm ... !> \param mm_cell ... !> \param para_env ... -!> \param error ... !> \author JGH 10.2014 [created] ! ***************************************************************************** - SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_env,error) + SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env @@ -1199,7 +1185,6 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e POINTER :: particles_mm TYPE(cell_type), POINTER :: mm_cell TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_dftb_qmmm_matrix_pc', & routineP = moduleN//':'//routineN @@ -1244,47 +1229,46 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e particle_set=particles_qm,& qs_kind_set=qs_kind_set,& rho=rho,& - natom=natom,& - error=error) + natom=natom) dftb_control => dft_control%qs_control%dftb_control - CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input,error=error) + CALL build_qs_neighbor_lists(qs_env,para_env,force_env_section=qs_env%input) NULLIFY(matrix_s) - CALL build_dftb_overlap(qs_env,0,matrix_s,error) + CALL build_dftb_overlap(qs_env,0,matrix_s) ALLOCATE(qpot(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qpot = 0.0_dp pc_ener = 0.0_dp ! Create Ewald environments - poisson_section => section_vals_get_subs_vals(qs_env%input,"MM%POISSON",error=error) - CALL ewald_env_create(ewald_env,para_env,error=error) - CALL ewald_env_set(ewald_env,poisson_section=poisson_section,error=error) - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD",error=error) - CALL read_ewald_section(ewald_env,ewald_section,error=error) - print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION",error=error) - CALL ewald_pw_create(ewald_pw,ewald_env,mm_cell,mm_cell,print_section=print_section,error=error) - - CALL ewald_env_get(ewald_env,ewald_type=ewald_type,do_multipoles=do_multipoles,do_ipol=do_ipol,error=error) + poisson_section => section_vals_get_subs_vals(qs_env%input,"MM%POISSON") + CALL ewald_env_create(ewald_env,para_env) + CALL ewald_env_set(ewald_env,poisson_section=poisson_section) + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD") + CALL read_ewald_section(ewald_env,ewald_section) + print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION") + CALL ewald_pw_create(ewald_pw,ewald_env,mm_cell,mm_cell,print_section=print_section) + + CALL ewald_env_get(ewald_env,ewald_type=ewald_type,do_multipoles=do_multipoles,do_ipol=do_ipol) IF(do_multipoles) CALL cp_unimplemented_error(fromWhere=routineP, & - message="No multipole force fields allowed in DFTB QM/MM", error=error, error_level=cp_fatal_level) + message="No multipole force fields allowed in DFTB QM/MM",error_level=cp_fatal_level) IF(do_ipol /= do_fist_pol_none) CALL cp_unimplemented_error(fromWhere=routineP, & - message="No polarizable force fields allowed in DFTB QM/MM", error=error, error_level=cp_fatal_level) + message="No polarizable force fields allowed in DFTB QM/MM",error_level=cp_fatal_level) SELECT CASE(ewald_type) CASE(do_ewald_pme) CALL cp_unimplemented_error(fromWhere=routineP, & - message="PME Ewald type not implemented for DFTB/QMMM", error=error, error_level=cp_fatal_level) + message="PME Ewald type not implemented for DFTB/QMMM",error_level=cp_fatal_level) CASE(do_ewald_ewald,do_ewald_spme) DO ipot = 1,SIZE(qmmm_env%Potentials) Pot => qmmm_env%Potentials(ipot)%Pot nmm = SIZE(Pot%mm_atom_index) ! get a 'clean' mm particle set NULLIFY(atoms_mm) - CALL allocate_particle_set(atoms_mm,nmm,error) + CALL allocate_particle_set(atoms_mm,nmm) ALLOCATE(charges_mm(nmm),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO Imp=1,nmm Imm = Pot%mm_atom_index(Imp) IndMM = qmmm_env%mm_atom_index(Imm) @@ -1294,14 +1278,14 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e END DO IF(ewald_type == do_ewald_ewald) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Ewald not implemented for DFTB/QMMM", error=error, error_level=cp_fatal_level) + message="Ewald not implemented for DFTB/QMMM",error_level=cp_fatal_level) ELSE IF(ewald_type == do_ewald_spme) THEN ! spme electrostatic potential - CALL spme_potential(ewald_env,ewald_pw,mm_cell,atoms_mm,charges_mm,particles_qm,qpot,error ) + CALL spme_potential(ewald_env,ewald_pw,mm_cell,atoms_mm,charges_mm,particles_qm,qpot) END IF - CALL deallocate_particle_set(atoms_mm,error) + CALL deallocate_particle_set(atoms_mm) DEALLOCATE(charges_mm,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN DO ipot = 1,SIZE(qmmm_env%added_charges%Potentials) @@ -1309,9 +1293,9 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e nmm = SIZE(Pot%mm_atom_index) ! get a 'clean' mm particle set NULLIFY(atoms_mm) - CALL allocate_particle_set(atoms_mm,nmm,error) + CALL allocate_particle_set(atoms_mm,nmm) ALLOCATE(charges_mm(nmm),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO Imp=1,nmm Imm = Pot%mm_atom_index(Imp) IndMM = qmmm_env%added_charges%mm_atom_index(Imm) @@ -1321,28 +1305,28 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e END DO IF(ewald_type == do_ewald_ewald) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Ewald not implemented for DFTB/QMMM", error=error, error_level=cp_fatal_level) + message="Ewald not implemented for DFTB/QMMM",error_level=cp_fatal_level) ELSE IF(ewald_type == do_ewald_spme) THEN ! spme electrostatic potential - CALL spme_potential(ewald_env,ewald_pw,mm_cell,atoms_mm,charges_mm,particles_qm,qpot,error ) + CALL spme_potential(ewald_env,ewald_pw,mm_cell,atoms_mm,charges_mm,particles_qm,qpot) END IF - CALL deallocate_particle_set(atoms_mm,error) + CALL deallocate_particle_set(atoms_mm) DEALLOCATE(charges_mm,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END IF CALL mp_sum(qpot,para_env%group) ! Add Ewald and DFTB short range corrections ! This is effectively using a minimum image convention! ! Set rcutoff to values compatible with alpha Ewald - CALL ewald_env_get(ewald_env,rcut=rcutoff(1),alpha=alpha,error=error) + CALL ewald_env_get(ewald_env,rcut=rcutoff(1),alpha=alpha) rcutoff(2) = 0.025_dp*rcutoff(1) rcutoff(1) = 2.0_dp*rcutoff(1) nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,zeff=zeff,& defined=defined,eta=eta_a,natorb=natorb) ! use mm charge smearing for non-scc cases @@ -1352,18 +1336,18 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e iatom = list(i) CALL build_mm_pot(qpot(iatom),1,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,rcutoff,& - particles_qm,error) + particles_qm) CALL build_mm_pot(qpot(iatom),2,alpha,qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,rcutoff,& - particles_qm,error) + particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL build_mm_pot(qpot(iatom),1,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& - qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm,error) + qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm) CALL build_mm_pot(qpot(iatom),2,alpha,qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& - qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm,error) + qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm) END IF pc_ener = pc_ener + qpot(iatom)*zeff END DO @@ -1374,7 +1358,7 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,zeff=zeff,& defined=defined,eta=eta_a,natorb=natorb) ! use mm charge smearing for non-scc cases @@ -1384,32 +1368,32 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e iatom = list(i) CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,& - qmmm_env%spherical_cutoff,particles_qm,error) + qmmm_env%spherical_cutoff,particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,qmmm_env%spherical_cutoff,& - particles_qm,error) + particles_qm) END IF pc_ener = pc_ener + qpot(iatom)*zeff END DO END DO CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & - message="Unknown Ewald type!", error=error, error_level=cp_fatal_level) + message="Unknown Ewald type!",error_level=cp_fatal_level) END SELECT ! Allocate the core Hamiltonian matrix - CALL get_qs_env(qs_env=qs_env,ks_qmmm_env=ks_qmmm_env_loc,error=error) + CALL get_qs_env(qs_env=qs_env,ks_qmmm_env=ks_qmmm_env_loc) matrix_h => ks_qmmm_env_loc%matrix_h - CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_h,1) ALLOCATE(matrix_h(1)%matrix,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_h(1)%matrix,error) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_h(1)%matrix) CALL cp_dbcsr_copy(matrix_h(1)%matrix,matrix_s(1)%matrix,& - name="QMMM HAMILTONIAN MATRIX",error=error) - CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp,error) + name="QMMM HAMILTONIAN MATRIX") + CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp) CALL cp_dbcsr_iterator_start(iter, matrix_s(1)%matrix) DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) @@ -1417,7 +1401,7 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e NULLIFY(hblock) CALL cp_dbcsr_get_block_p(matrix=matrix_h(1)%matrix,& row=iatom,col=jatom,block=hblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) hblock = hblock - 0.5_dp*sblock*(qpot(iatom)+qpot(jatom)) END DO CALL cp_dbcsr_iterator_stop(iter) @@ -1426,13 +1410,13 @@ SUBROUTINE build_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e ks_qmmm_env_loc%pc_ener = pc_ener DEALLOCATE(qpot,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Release Ewald environment - CALL ewald_env_release(ewald_env,error=error) - CALL ewald_pw_release(ewald_pw,error=error) + CALL ewald_env_release(ewald_env) + CALL ewald_pw_release(ewald_pw) - CALL cp_dbcsr_deallocate_matrix_set ( matrix_s, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( matrix_s) CALL timestop(handle) @@ -1448,11 +1432,10 @@ END SUBROUTINE build_dftb_qmmm_matrix_pc !> \param calc_force ... !> \param Forces ... !> \param Forces_added_charges ... -!> \param error ... !> \author JGH 10.2014 [created] ! ***************************************************************************** SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& - calc_force, Forces, Forces_added_charges, error) + calc_force, Forces, Forces_added_charges) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env @@ -1462,7 +1445,6 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(in), OPTIONAL :: calc_force REAL(KIND=dp), DIMENSION(:, :), POINTER :: Forces, Forces_added_charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deriv_dftb_qmmm_matrix', & routineP = moduleN//':'//routineN @@ -1502,27 +1484,26 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, ks_qmmm_env=ks_qmmm_env_loc,& dft_control=dft_control,& particle_set=particles_qm,& - natom=number_qm_atoms,& - error=error) + natom=number_qm_atoms) dftb_control => dft_control%qs_control%dftb_control NULLIFY(matrix_s) - CALL build_dftb_overlap(qs_env,1,matrix_s,error) - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL build_dftb_overlap(qs_env,1,matrix_s) + CALL qs_rho_get(rho, rho_ao=matrix_p) nspins = dft_control%nspins nkind = SIZE(atomic_kind_set) ! Mulliken charges ALLOCATE(charges(number_qm_atoms,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! - CALL mulliken_charges(matrix_p,matrix_s(1)%matrix,para_env,charges,error=error) + CALL mulliken_charges(matrix_p,matrix_s(1)%matrix,para_env,charges) ! ALLOCATE(mcharge(number_qm_atoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom) - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) DO iatom=1,natom atom_a = atomic_kind_set(ikind)%atom_list(iatom) @@ -1530,13 +1511,13 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, END DO END DO DEALLOCATE(charges,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(qpot(number_qm_atoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qpot = 0.0_dp ALLOCATE(Forces_QM(3,number_qm_atoms),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) Forces_QM= 0.0_dp ! calculate potential and forces from classical charges @@ -1544,7 +1525,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,& defined=defined,eta=eta_a,natorb=natorb) ! use mm charge smearing for non-scc cases @@ -1555,20 +1536,20 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, iqm = iqm + 1 CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,& - qmmm_env%spherical_cutoff,particles_qm,error) + qmmm_env%spherical_cutoff,particles_qm) CALL build_mm_dpot(mcharge(iatom),0,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,Forces,Forces_QM(:,iqm),& - qmmm_env%spherical_cutoff,particles_qm,error) + qmmm_env%spherical_cutoff,particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,qmmm_env%spherical_cutoff,& - particles_qm,error) + particles_qm) CALL build_mm_dpot(mcharge(iatom),0,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,Forces_added_charges,& - Forces_QM(:,iqm),qmmm_env%spherical_cutoff,particles_qm,error) + Forces_QM(:,iqm),qmmm_env%spherical_cutoff,particles_qm) END IF END DO END DO @@ -1578,7 +1559,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,defined=defined,natorb=natorb) IF (.NOT.defined .OR. natorb < 1) CYCLE DO i = 1, SIZE(list) @@ -1592,7 +1573,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, Forces_QM = 0.0_dp IF ( SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END IF ! CALL cp_dbcsr_iterator_start(iter, matrix_s(1)%matrix) @@ -1605,12 +1586,12 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1)%matrix,& row=iatom,col=jatom,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO i=1,3 NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i)%matrix,& row=iatom,col=jatom,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) fi = -2.0_dp*gmij*SUM(pblock*dsblock) Forces_QM(i,iatom) = Forces_QM(i,iatom) + fi Forces_QM(i,jatom) = Forces_QM(i,jatom) - fi @@ -1620,7 +1601,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, ! IF ( SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END IF ! ! Transfer QM gradients to the QM particles.. @@ -1635,16 +1616,16 @@ SUBROUTINE deriv_dftb_qmmm_matrix(qs_env,qmmm_env,particles_mm,mm_cell,para_env, END DO ! DEALLOCATE(mcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! MM forces will be handled directly from the QMMM module in the same way ! as for GPW/GAPW methods DEALLOCATE(Forces_QM,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(qpot,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_deallocate_matrix_set ( matrix_s, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( matrix_s) END IF CALL timestop(handle) @@ -1661,11 +1642,10 @@ END SUBROUTINE deriv_dftb_qmmm_matrix !> \param calc_force ... !> \param Forces ... !> \param Forces_added_charges ... -!> \param error ... !> \author JGH 10.2014 [created] ! ***************************************************************************** SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_env,& - calc_force, Forces, Forces_added_charges, error) + calc_force, Forces, Forces_added_charges) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env @@ -1675,7 +1655,6 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(in), OPTIONAL :: calc_force REAL(KIND=dp), DIMENSION(:, :), POINTER :: Forces, Forces_added_charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deriv_dftb_qmmm_matrix_pc', & routineP = moduleN//':'//routineN @@ -1723,27 +1702,26 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e ks_qmmm_env=ks_qmmm_env_loc,& dft_control=dft_control,& particle_set=particles_qm,& - natom=number_qm_atoms,& - error=error) + natom=number_qm_atoms) dftb_control => dft_control%qs_control%dftb_control NULLIFY(matrix_s) - CALL build_dftb_overlap(qs_env,1,matrix_s,error) - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL build_dftb_overlap(qs_env,1,matrix_s) + CALL qs_rho_get(rho, rho_ao=matrix_p) nspins = dft_control%nspins nkind = SIZE(atomic_kind_set) ! Mulliken charges ALLOCATE(charges(number_qm_atoms,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! - CALL mulliken_charges(matrix_p,matrix_s(1)%matrix,para_env,charges,error=error) + CALL mulliken_charges(matrix_p,matrix_s(1)%matrix,para_env,charges) ! ALLOCATE(mcharge(number_qm_atoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom) - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind, zeff=zeff) DO iatom=1,natom atom_a = atomic_kind_set(ikind)%atom_list(iatom) @@ -1751,43 +1729,43 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e END DO END DO DEALLOCATE(charges,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(qpot(number_qm_atoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qpot = 0.0_dp ALLOCATE(Forces_QM(3,number_qm_atoms),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) Forces_QM= 0.0_dp ! Create Ewald environments - poisson_section => section_vals_get_subs_vals(qs_env%input,"MM%POISSON",error=error) - CALL ewald_env_create(ewald_env,para_env,error=error) - CALL ewald_env_set(ewald_env,poisson_section=poisson_section,error=error) - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD",error=error) - CALL read_ewald_section(ewald_env,ewald_section,error=error) - print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION",error=error) - CALL ewald_pw_create(ewald_pw,ewald_env,mm_cell,mm_cell,print_section=print_section,error=error) - - CALL ewald_env_get(ewald_env,ewald_type=ewald_type,do_multipoles=do_multipoles,do_ipol=do_ipol,error=error) + poisson_section => section_vals_get_subs_vals(qs_env%input,"MM%POISSON") + CALL ewald_env_create(ewald_env,para_env) + CALL ewald_env_set(ewald_env,poisson_section=poisson_section) + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD") + CALL read_ewald_section(ewald_env,ewald_section) + print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION") + CALL ewald_pw_create(ewald_pw,ewald_env,mm_cell,mm_cell,print_section=print_section) + + CALL ewald_env_get(ewald_env,ewald_type=ewald_type,do_multipoles=do_multipoles,do_ipol=do_ipol) IF(do_multipoles) CALL cp_unimplemented_error(fromWhere=routineP, & - message="No multipole force fields allowed in DFTB QM/MM", error=error, error_level=cp_fatal_level) + message="No multipole force fields allowed in DFTB QM/MM",error_level=cp_fatal_level) IF(do_ipol /= do_fist_pol_none) CALL cp_unimplemented_error(fromWhere=routineP, & - message="No polarizable force fields allowed in DFTB QM/MM", error=error, error_level=cp_fatal_level) + message="No polarizable force fields allowed in DFTB QM/MM",error_level=cp_fatal_level) SELECT CASE(ewald_type) CASE(do_ewald_pme) CALL cp_unimplemented_error(fromWhere=routineP, & - message="PME Ewald type not implemented for DFTB/QMMM", error=error, error_level=cp_fatal_level) + message="PME Ewald type not implemented for DFTB/QMMM",error_level=cp_fatal_level) CASE(do_ewald_ewald,do_ewald_spme) DO ipot = 1,SIZE(qmmm_env%Potentials) Pot => qmmm_env%Potentials(ipot)%Pot nmm = SIZE(Pot%mm_atom_index) ! get a 'clean' mm particle set NULLIFY(atoms_mm) - CALL allocate_particle_set(atoms_mm,nmm,error) + CALL allocate_particle_set(atoms_mm,nmm) ALLOCATE(charges_mm(nmm),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO Imp=1,nmm Imm = Pot%mm_atom_index(Imp) IndMM = qmmm_env%mm_atom_index(Imm) @@ -1797,25 +1775,25 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e END DO ! force array for mm atoms ALLOCATE(Forces_MM(3,nmm),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) Forces_MM= 0.0_dp IF(ewald_type == do_ewald_ewald) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Ewald not implemented for DFTB/QMMM", error=error, error_level=cp_fatal_level) + message="Ewald not implemented for DFTB/QMMM",error_level=cp_fatal_level) ELSE IF(ewald_type == do_ewald_spme) THEN ! spme electrostatic potential CALL spme_potential(ewald_env,ewald_pw,mm_cell,atoms_mm,charges_mm, & - particles_qm,qpot,error ) + particles_qm,qpot) ! forces QM CALL spme_forces(ewald_env,ewald_pw,mm_cell,atoms_mm,charges_mm, & - particles_qm,mcharge,Forces_QM,error ) + particles_qm,mcharge,Forces_QM) ! forces MM CALL spme_forces(ewald_env,ewald_pw,mm_cell,particles_qm,mcharge,& - atoms_mm,charges_mm,Forces_MM,error) + atoms_mm,charges_mm,Forces_MM) END IF - CALL deallocate_particle_set(atoms_mm,error) + CALL deallocate_particle_set(atoms_mm) DEALLOCATE(charges_mm,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! transfer MM forces CALL mp_sum(Forces_MM,para_env%group) DO Imp=1,nmm @@ -1823,7 +1801,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e Forces(:,Imm) = Forces(:,Imm) - Forces_MM(:,Imp) END DO DEALLOCATE(Forces_MM,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN @@ -1832,9 +1810,9 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e nmm = SIZE(Pot%mm_atom_index) ! get a 'clean' mm particle set NULLIFY(atoms_mm) - CALL allocate_particle_set(atoms_mm,nmm,error) + CALL allocate_particle_set(atoms_mm,nmm) ALLOCATE(charges_mm(nmm),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO Imp=1,nmm Imm = Pot%mm_atom_index(Imp) IndMM = qmmm_env%added_charges%mm_atom_index(Imm) @@ -1844,23 +1822,23 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e END DO ! force array for mm atoms ALLOCATE(Forces_MM(3,nmm),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) Forces_MM= 0.0_dp IF(ewald_type == do_ewald_ewald) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Ewald not implemented for DFTB/QMMM", error=error, error_level=cp_fatal_level) + message="Ewald not implemented for DFTB/QMMM",error_level=cp_fatal_level) ELSE IF(ewald_type == do_ewald_spme) THEN ! spme electrostatic potential CALL spme_potential(ewald_env,ewald_pw,mm_cell,atoms_mm,& - charges_mm,particles_qm,qpot,error ) + charges_mm,particles_qm,qpot) ! forces QM CALL spme_forces(ewald_env,ewald_pw,mm_cell,atoms_mm,charges_mm,& - particles_qm,mcharge,Forces_QM,error ) + particles_qm,mcharge,Forces_QM) ! forces MM CALL spme_forces(ewald_env,ewald_pw,mm_cell,particles_qm,mcharge,& - atoms_mm,charges_mm,Forces_MM,error) + atoms_mm,charges_mm,Forces_MM) END IF - CALL deallocate_particle_set(atoms_mm,error) + CALL deallocate_particle_set(atoms_mm) ! transfer MM forces CALL mp_sum(Forces_MM,para_env%group) DO Imp=1,nmm @@ -1868,16 +1846,16 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e Forces_added_charges(:,Imm) = Forces_added_charges(:,Imm) - Forces_MM(:,Imp) END DO DEALLOCATE(Forces_MM,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END IF CALL mp_sum(qpot,para_env%group) CALL mp_sum(Forces_QM, para_env%group) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! Add Ewald and DFTB short range corrections ! This is effectively using a minimum image convention! ! Set rcutoff to values compatible with alpha Ewald - CALL ewald_env_get(ewald_env,rcut=rcutoff(1),alpha=alpha,error=error) + CALL ewald_env_get(ewald_env,rcut=rcutoff(1),alpha=alpha) rcutoff(2) = 0.025_dp*rcutoff(1) rcutoff(1) = 2.0_dp*rcutoff(1) nkind = SIZE(atomic_kind_set) @@ -1885,7 +1863,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,& defined=defined,eta=eta_a,natorb=natorb) ! use mm charge smearing for non-scc cases @@ -1895,31 +1873,31 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e iatom = list(i) iqm = iqm + 1 CALL build_mm_pot(qpot(iatom),1,eta_a(0),qmmm_env%Potentials,particles_mm,& - qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm,error) + qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm) CALL build_mm_dpot(mcharge(iatom),1,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,Forces,Forces_QM(:,iqm),& - rcutoff,particles_qm,error) + rcutoff,particles_qm) CALL build_mm_pot(qpot(iatom),2,alpha,qmmm_env%Potentials,particles_mm,& - qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm,error) + qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm) CALL build_mm_dpot(mcharge(iatom),2,alpha,qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,Forces,Forces_QM(:,iqm),& - rcutoff,particles_qm,error) + rcutoff,particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL build_mm_pot(qpot(iatom),1,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& - qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm,error) + qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm) CALL build_mm_dpot(mcharge(iatom),1,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,Forces_added_charges,Forces_QM(:,iqm),& - rcutoff,particles_qm,error) + rcutoff,particles_qm) CALL build_mm_pot(qpot(iatom),2,alpha,qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& - qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm,error) + qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,rcutoff,particles_qm) CALL build_mm_dpot(mcharge(iatom),2,alpha,qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,Forces_added_charges,Forces_QM(:,iqm),& - rcutoff,particles_qm,error) + rcutoff,particles_qm) END IF END DO END DO @@ -1931,7 +1909,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,& defined=defined,eta=eta_a,natorb=natorb) ! use mm charge smearing for non-scc cases @@ -1942,26 +1920,26 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e iqm = iqm + 1 CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,& - qmmm_env%spherical_cutoff,particles_qm,error) + qmmm_env%spherical_cutoff,particles_qm) CALL build_mm_dpot(mcharge(iatom),0,eta_a(0),qmmm_env%Potentials,particles_mm,& qmmm_env%mm_atom_chrg,qmmm_env%mm_atom_index,mm_cell,iatom,Forces,Forces_QM(:,iqm),& - qmmm_env%spherical_cutoff,particles_qm,error) + qmmm_env%spherical_cutoff,particles_qm) ! Possibly added charges IF (qmmm_env%move_mm_charges.OR.qmmm_env%add_mm_charges) THEN CALL build_mm_pot(qpot(iatom),0,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,qmmm_env%spherical_cutoff,& - particles_qm,error) + particles_qm) CALL build_mm_dpot(mcharge(iatom),0,eta_a(0),qmmm_env%added_charges%potentials,& qmmm_env%added_charges%added_particles,qmmm_env%added_charges%mm_atom_chrg,& qmmm_env%added_charges%mm_atom_index,mm_cell,iatom,Forces_added_charges,& - Forces_QM(:,iqm),qmmm_env%spherical_cutoff,particles_qm,error) + Forces_QM(:,iqm),qmmm_env%spherical_cutoff,particles_qm) END IF END DO END DO CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & - message="Unknown Ewald type!", error=error, error_level=cp_fatal_level) + message="Unknown Ewald type!",error_level=cp_fatal_level) END SELECT ! Transfer QM gradients to the QM particles.. @@ -1969,7 +1947,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=list) NULLIFY(dftb_kind) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,defined=defined,natorb=natorb) IF (.NOT.defined .OR. natorb < 1) CYCLE DO i = 1, SIZE(list) @@ -1983,7 +1961,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e Forces_QM = 0.0_dp IF ( SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END IF ! CALL cp_dbcsr_iterator_start(iter, matrix_s(1)%matrix) @@ -1996,12 +1974,12 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1)%matrix,& row=iatom,col=jatom,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO i=1,3 NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i)%matrix,& row=iatom,col=jatom,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) fi = -2.0_dp*gmij*SUM(pblock*dsblock) Forces_QM(i,iatom) = Forces_QM(i,iatom) + fi Forces_QM(i,jatom) = Forces_QM(i,jatom) - fi @@ -2011,7 +1989,7 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e ! IF ( SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END IF ! ! Transfer QM gradients to the QM particles.. @@ -2026,20 +2004,20 @@ SUBROUTINE deriv_dftb_qmmm_matrix_pc(qs_env,qmmm_env,particles_mm,mm_cell,para_e END DO ! DEALLOCATE(mcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! MM forces will be handled directly from the QMMM module in the same way ! as for GPW/GAPW methods DEALLOCATE(Forces_QM,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(qpot,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Release Ewald environment - CALL ewald_env_release(ewald_env,error=error) - CALL ewald_pw_release(ewald_pw,error=error) + CALL ewald_env_release(ewald_env) + CALL ewald_pw_release(ewald_pw) - CALL cp_dbcsr_deallocate_matrix_set ( matrix_s, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( matrix_s) END IF @@ -2060,11 +2038,10 @@ END SUBROUTINE deriv_dftb_qmmm_matrix_pc !> \param IndQM ... !> \param qmmm_spherical_cutoff ... !> \param particles_qm ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_mm_pot(qpot, pot_type, qm_alpha, potentials,& particles_mm, mm_charges, mm_atom_index, mm_cell, IndQM, & - qmmm_spherical_cutoff, particles_qm, error) + qmmm_spherical_cutoff, particles_qm) REAL(KIND=dp), INTENT(INOUT) :: qpot INTEGER, INTENT(IN) :: pot_type @@ -2080,7 +2057,6 @@ SUBROUTINE build_mm_pot(qpot, pot_type, qm_alpha, potentials,& REAL(KIND=dp), INTENT(IN) :: qmmm_spherical_cutoff(2) TYPE(particle_type), DIMENSION(:), & POINTER :: particles_qm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_mm_pot', & routineP = moduleN//':'//routineN @@ -2110,7 +2086,7 @@ SUBROUTINE build_mm_pot(qpot, pot_type, qm_alpha, potentials,& qeff = mm_charges(Imm) ! Computes the screening factor for the spherical cutoff (if defined) IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor) qeff = qeff * sph_chrg_factor END IF IF (ABS(qeff)<=qsmall) CYCLE @@ -2148,11 +2124,10 @@ END SUBROUTINE build_mm_pot !> \param forces_qm ... !> \param qmmm_spherical_cutoff ... !> \param particles_qm ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_mm_dpot(qcharge, pot_type, qm_alpha, potentials,& particles_mm, mm_charges, mm_atom_index, mm_cell, IndQM, & - forces, forces_qm, qmmm_spherical_cutoff, particles_qm, error) + forces, forces_qm, qmmm_spherical_cutoff, particles_qm) REAL(KIND=dp), INTENT(IN) :: qcharge INTEGER, INTENT(IN) :: pot_type @@ -2171,7 +2146,6 @@ SUBROUTINE build_mm_dpot(qcharge, pot_type, qm_alpha, potentials,& REAL(KIND=dp), INTENT(IN) :: qmmm_spherical_cutoff(2) TYPE(particle_type), DIMENSION(:), & POINTER :: particles_qm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_mm_dpot', & routineP = moduleN//':'//routineN @@ -2202,7 +2176,7 @@ SUBROUTINE build_mm_dpot(qcharge, pot_type, qm_alpha, potentials,& ! Computes the screening factor for the spherical cutoff (if defined) ! We neglect derivative of cutoff function for gradients!!! IF (qmmm_spherical_cutoff(1)>0.0_dp) THEN - CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor, error) + CALL spherical_cutoff_factor(qmmm_spherical_cutoff, rij, sph_chrg_factor) qeff = qeff * sph_chrg_factor END IF IF (ABS(qeff)<=qsmall) CYCLE @@ -2282,9 +2256,8 @@ END SUBROUTINE compute_block_sk !> \param matrices ... !> \param mnames ... !> \param sab_nl ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE setup_matrices1(qs_env,nderivative,matrices,mnames,sab_nl,error) + SUBROUTINE setup_matrices1(qs_env,nderivative,matrices,mnames,sab_nl) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: nderivative @@ -2293,7 +2266,6 @@ SUBROUTINE setup_matrices1(qs_env,nderivative,matrices,mnames,sab_nl,error) CHARACTER(LEN=*) :: mnames TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_matrices1', & routineP = moduleN//':'//routineN @@ -2321,34 +2293,33 @@ SUBROUTINE setup_matrices1(qs_env,nderivative,matrices,mnames,sab_nl,error) qs_kind_set=qs_kind_set,& particle_set=particle_set,& dbcsr_dist=dbcsr_dist,& - neighbor_list_id=neighbor_list_id, & - error=error) + neighbor_list_id=neighbor_list_id) nkind = SIZE(atomic_kind_set) natom = SIZE(particle_set) - CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf, error=error) + CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) nmat = 0 IF(nderivative==0)nmat=1 IF(nderivative==1)nmat=4 IF(nderivative==2)nmat=10 - CPPostcondition(nmat>0,cp_failure_level,routineP,error,failure) + CPPostcondition(nmat>0,cp_failure_level,routineP,failure) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) - CALL cp_dbcsr_allocate_matrix_set(matrices,nmat,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrices,nmat) ! Up to 2nd derivative take care to get the symmetries correct DO i=1,nmat @@ -2361,20 +2332,19 @@ SUBROUTINE setup_matrices1(qs_env,nderivative,matrices,mnames,sab_nl,error) matnames=TRIM(mnames)//" MATRIX DFTB" END IF ALLOCATE(matrices(i)%matrix) - CALL cp_dbcsr_init(matrices(i)%matrix, error=error) + CALL cp_dbcsr_init(matrices(i)%matrix) CALL cp_dbcsr_create(matrix=matrices(i)%matrix, & name=TRIM(matnames), & dist=dbcsr_dist, matrix_type=symmetry_type,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrices(i)%matrix,sab_nl,error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(matrices(i)%matrix,sab_nl) END DO DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(row_blk_sizes) @@ -2388,9 +2358,8 @@ END SUBROUTINE setup_matrices1 !> \param matrices ... !> \param mnames ... !> \param sab_nl ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE setup_matrices2(qs_env,nderivative,nimg,matrices,mnames,sab_nl,error) + SUBROUTINE setup_matrices2(qs_env,nderivative,nimg,matrices,mnames,sab_nl) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: nderivative, nimg @@ -2399,7 +2368,6 @@ SUBROUTINE setup_matrices2(qs_env,nderivative,nimg,matrices,mnames,sab_nl,error) CHARACTER(LEN=*) :: mnames TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_matrices2', & routineP = moduleN//':'//routineN @@ -2427,34 +2395,33 @@ SUBROUTINE setup_matrices2(qs_env,nderivative,nimg,matrices,mnames,sab_nl,error) qs_kind_set=qs_kind_set,& particle_set=particle_set,& dbcsr_dist=dbcsr_dist,& - neighbor_list_id=neighbor_list_id, & - error=error) + neighbor_list_id=neighbor_list_id) nkind = SIZE(atomic_kind_set) natom = SIZE(particle_set) - CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf, error=error) + CALL get_qs_kind_set(qs_kind_set,nsgf=nsgf) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) nmat = 0 IF(nderivative==0)nmat=1 IF(nderivative==1)nmat=4 IF(nderivative==2)nmat=10 - CPPostcondition(nmat>0,cp_failure_level,routineP,error,failure) + CPPostcondition(nmat>0,cp_failure_level,routineP,failure) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) - CALL cp_dbcsr_allocate_matrix_set(matrices,nmat,nimg,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrices,nmat,nimg) ! Up to 2nd derivative take care to get the symmetries correct DO img=1,nimg @@ -2468,21 +2435,20 @@ SUBROUTINE setup_matrices2(qs_env,nderivative,nimg,matrices,mnames,sab_nl,error) matnames=TRIM(mnames)//" MATRIX DFTB" END IF ALLOCATE(matrices(i,img)%matrix) - CALL cp_dbcsr_init(matrices(i,img)%matrix, error=error) + CALL cp_dbcsr_init(matrices(i,img)%matrix) CALL cp_dbcsr_create(matrix=matrices(i,img)%matrix, & name=TRIM(matnames), & dist=dbcsr_dist, matrix_type=symmetry_type,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrices(i,img)%matrix,sab_nl,error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(matrices(i,img)%matrix,sab_nl) END DO END DO DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(row_blk_sizes) @@ -2494,9 +2460,8 @@ END SUBROUTINE setup_matrices2 !> \param nmat ... !> \param gammat ... !> \param sab_nl ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE setup_gamma(qs_env,nmat,gammat,sab_nl,error) + SUBROUTINE setup_gamma(qs_env,nmat,gammat,sab_nl) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: nmat @@ -2504,7 +2469,6 @@ SUBROUTINE setup_gamma(qs_env,nmat,gammat,sab_nl,error) POINTER :: gammat TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_gamma', & routineP = moduleN//':'//routineN @@ -2520,52 +2484,49 @@ SUBROUTINE setup_gamma(qs_env,nmat,gammat,sab_nl,error) CALL get_qs_env(qs_env=qs_env,& particle_set=particle_set,& neighbor_list_id=neighbor_list_id,& - dbcsr_dist=dbcsr_dist,& - error=error) + dbcsr_dist=dbcsr_dist) natom = SIZE(particle_set) nrow = natom ncol = natom ALLOCATE (felem(natom),lelem(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO iatom = 1, natom felem(iatom) = iatom lelem(iatom) = iatom ENDDO ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (felem, row_blk_sizes, lelem) - CALL cp_dbcsr_allocate_matrix_set(gammat,nmat,error=error) + CALL cp_dbcsr_allocate_matrix_set(gammat,nmat) ALLOCATE(gammat(1)%matrix,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(gammat(1)%matrix, error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(gammat(1)%matrix) CALL cp_dbcsr_create(matrix=gammat(1)%matrix, & name="GAMMA MATRIX", & dist=dbcsr_dist, matrix_type=dbcsr_type_symmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) + nze=0, mutable_work=.TRUE.) DO i=2,nmat ALLOCATE(gammat(i)%matrix) - CALL cp_dbcsr_init(gammat(i)%matrix, error=error) + CALL cp_dbcsr_init(gammat(i)%matrix) CALL cp_dbcsr_create(matrix=gammat(i)%matrix, & name="DERIVATIVE GAMMA MATRIX", & dist=dbcsr_dist, matrix_type=dbcsr_type_antisymmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) + nze=0, mutable_work=.TRUE.) END DO DEALLOCATE (row_blk_sizes,felem,lelem,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! setup the matrices using the neighbor list DO i=1,nmat - CALL cp_dbcsr_alloc_block_from_nbl(gammat(i)%matrix,sab_nl,error) + CALL cp_dbcsr_alloc_block_from_nbl(gammat(i)%matrix,sab_nl) END DO END SUBROUTINE setup_gamma diff --git a/src/qs_dftb_parameters.F b/src/qs_dftb_parameters.F index 8ccffc8ba7..b4bd35b735 100644 --- a/src/qs_dftb_parameters.F +++ b/src/qs_dftb_parameters.F @@ -72,10 +72,9 @@ MODULE qs_dftb_parameters !> \param dftb_potential ... !> \param subsys_section ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_potential,& - subsys_section,para_env,error) + subsys_section,para_env) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & @@ -85,7 +84,6 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot DIMENSION(:, :), POINTER :: dftb_potential TYPE(section_vals_type), POINTER :: subsys_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dftb_param_init', & routineP = moduleN//':'//routineN @@ -117,11 +115,11 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot failure = .FALSE. output_unit = -1 NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info,subsys_section,& - "PRINT%KINDS/BASIS_SET",error=error),cp_p_file)) THEN + "PRINT%KINDS/BASIS_SET"),cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%KINDS",extension=".Log",error=error) + "PRINT%KINDS",extension=".Log") IF ( output_unit > 0 ) THEN WRITE(output_unit,"(/,A)") " DFTB| A set of relativistic DFTB "//& "parameters for material sciences." @@ -145,18 +143,18 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot " M. Krause et al, JCP 115 6596 (2001)" END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%KINDS",error=error) + "PRINT%KINDS") END IF sklist = (dftb_control%sk_file_list /= "") nkind = SIZE(atomic_kind_set) ALLOCATE(sk_files(nkind,nkind),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ! allocate potential structures ALLOCATE(dftb_potential(nkind,nkind),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) - CALL qs_dftb_pairpot_init(dftb_potential,error) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) + CALL qs_dftb_pairpot_init(dftb_potential) DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind),name=iname,element_symbol=iel) @@ -185,16 +183,16 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot file_name = TRIM(dftb_control%sk_file_path)//"/"//& TRIM(dftb_control%sk_file_list) NULLIFY(parser) - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) DO at_end = .FALSE. - CALL parser_get_next_line(parser,1,at_end,error=error) + CALL parser_get_next_line(parser,1,at_end) IF ( at_end ) EXIT - CALL parser_get_object(parser,name_a,lower_to_upper=.TRUE.,error=error) - CALL parser_get_object(parser,name_b,lower_to_upper=.TRUE.,error=error) + CALL parser_get_object(parser,name_a,lower_to_upper=.TRUE.) + CALL parser_get_object(parser,name_b,lower_to_upper=.TRUE.) !Checking Names IF ( (iname==name_a .AND. jname==name_b) ) THEN - CALL parser_get_object(parser,skfn,string_length=8,error=error) + CALL parser_get_object(parser,skfn,string_length=8) sk_files(ikind,jkind) = TRIM(dftb_control%sk_file_path)//"/"//& TRIM(skfn) found = .TRUE. @@ -202,14 +200,14 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot END IF !Checking Element IF ( (iel==name_a .AND. jel==name_b) ) THEN - CALL parser_get_object(parser,skfn,string_length=8,error=error) + CALL parser_get_object(parser,skfn,string_length=8) sk_files(ikind,jkind) = TRIM(dftb_control%sk_file_path)//"/"//& TRIM(skfn) found = .TRUE. EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "Failure in assigning KINDS <"//TRIM(iname)//"> and <"//TRIM(jname)//& @@ -223,17 +221,17 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), z=z,name=iname) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) IF (.NOT.ASSOCIATED(dftb_atom_a)) THEN - CALL allocate_dftb_atom_param(dftb_atom_a,error=error) - CALL set_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a,error=error) + CALL allocate_dftb_atom_param(dftb_atom_a) + CALL set_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) END IF ! read all pairs, equal kind first jkind = ikind CALL get_atomic_kind(atomic_kind_set(jkind), name=jname) - CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_atom_b, error=error) + CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_atom_b) IF (output_unit > 0) THEN WRITE(output_unit,"(A,T30,A50)") " DFTB| Reading parameter file ",& @@ -279,14 +277,13 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,& z=z,zeff=SUM(occupation),defined=.TRUE.,& - skself=skself,energy=energy,eta=eta,occupation=occupation,& - error=error) + skself=skself,energy=energy,eta=eta,occupation=occupation) ! Slater-Koster table ALLOCATE(fmat(ngrd,10),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ALLOCATE(smat(ngrd,10),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) IF ( para_env%ionode ) THEN DO k=1,ngrd READ (runit,fmt=*,END=1,err=1) fwork(1:10),swork(1:10) @@ -328,7 +325,7 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot ! l=2 (d) is maximum lmax = MIN ( 2, lmax ) CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,& - lmax=lmax, natorb=(lmax+1)**2, error=error) + lmax=lmax, natorb=(lmax+1)**2) spdim = 0 IF ( n_urpoly == 0 ) THEN @@ -342,9 +339,9 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot ! spline dimension and left-hand cutoff READ (runit,fmt=*,END=1,err=1) spdim,s_cut ALLOCATE(spxr(spdim,2),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ALLOCATE(scoeff(spdim,4),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ! e-functions describing left-hand extrapolation READ (runit,fmt=*,END=1,err=1) srep(1:3) DO isp = 1,spdim-1 @@ -365,9 +362,9 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot CALL mp_bcast(spdim,para_env%source,para_env%group) IF ( spdim > 0 .AND. (.NOT. para_env%ionode)) THEN ALLOCATE(spxr(spdim,2),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ALLOCATE(scoeff(spdim,4),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) END IF IF(spdim > 0) THEN CALL mp_bcast(spxr,para_env%source,para_env%group) @@ -390,7 +387,7 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot END DO END DO CALL qs_dftb_pairpot_create(dftb_potential(ikind,jkind),& - ngrd,llm,spdim,error) + ngrd,llm,spdim) ! repulsive potential dftb_potential(ikind,jkind)%n_urpoly = n_urpoly @@ -416,14 +413,14 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot END IF DEALLOCATE(fmat,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) DEALLOCATE(smat,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) IF(spdim > 0) THEN DEALLOCATE(spxr,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) DEALLOCATE(scoeff,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) END IF END DO @@ -431,18 +428,18 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot ! no all other pairs DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), z=z,name=iname) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) IF (.NOT.ASSOCIATED(dftb_atom_a)) THEN - CALL allocate_dftb_atom_param(dftb_atom_a,error=error) - CALL set_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a,error=error) + CALL allocate_dftb_atom_param(dftb_atom_a) + CALL set_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) END IF DO jkind = 1, nkind IF ( ikind == jkind ) CYCLE CALL get_atomic_kind(atomic_kind_set(jkind), name=jname) - CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_atom_b, error=error) + CALL get_qs_kind(qs_kind_set(jkind), dftb_parameter=dftb_atom_b) IF (output_unit > 0) THEN WRITE(output_unit,"(A,T30,A50)") " DFTB| Reading parameter file ",& @@ -485,9 +482,9 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot ! Slater-Koster table ALLOCATE(fmat(ngrd,10),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ALLOCATE(smat(ngrd,10),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) IF ( para_env%ionode ) THEN DO k=1,ngrd READ (runit,fmt=*,END=1,err=1) fwork(1:10),swork(1:10) @@ -510,9 +507,9 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot ! spline dimension and left-hand cutoff READ (runit,fmt=*,END=1,err=1) spdim,s_cut ALLOCATE(spxr(spdim,2),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ALLOCATE(scoeff(spdim,4),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ! e-functions describing left-hand extrapolation READ (runit,fmt=*,END=1,err=1) srep(1:3) DO isp = 1,spdim-1 @@ -533,9 +530,9 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot CALL mp_bcast(spdim,para_env%source,para_env%group) IF ( spdim > 0 .AND. (.NOT. para_env%ionode)) THEN ALLOCATE(spxr(spdim,2),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ALLOCATE(scoeff(spdim,4),STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) END IF IF(spdim > 0) THEN CALL mp_bcast(spxr,para_env%source,para_env%group) @@ -558,7 +555,7 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot END DO END DO CALL qs_dftb_pairpot_create(dftb_potential(ikind,jkind),& - ngrd,llm,spdim,error) + ngrd,llm,spdim) ! repulsive potential dftb_potential(ikind,jkind)%n_urpoly = n_urpoly @@ -584,21 +581,21 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot END IF DEALLOCATE(fmat,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) DEALLOCATE(smat,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) IF(spdim > 0) THEN DEALLOCATE(spxr,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) DEALLOCATE(scoeff,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) END IF END DO END DO DEALLOCATE(sk_files,STAT=istat) - CPPostcondition(istat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(istat==0,cp_fatal_level,routineP,failure) ! read dispersion parameters (UFF type) IF ( dftb_control%dispersion ) THEN @@ -608,32 +605,32 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot TRIM(dftb_control%uff_force_field) DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=iname) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) m = LEN_TRIM(iname) NULLIFY(parser) - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) found = .FALSE. DO at_end = .FALSE. - CALL parser_get_next_line(parser,1,at_end,error=error) + CALL parser_get_next_line(parser,1,at_end) IF ( at_end ) EXIT - CALL parser_get_object(parser,name_a,error=error) + CALL parser_get_object(parser,name_a) ! parser is no longer removing leading quotes IF(name_a(1:1) == '"') name_a(1:m) = name_a(2:m+1) IF ( name_a(1:m) == TRIM(iname) ) THEN - CALL parser_get_object(parser,rb,error=error) - CALL parser_get_object(parser,rb,error=error) - CALL parser_get_object(parser,ra,error=error) - CALL parser_get_object(parser,da,error=error) + CALL parser_get_object(parser,rb) + CALL parser_get_object(parser,rb) + CALL parser_get_object(parser,ra) + CALL parser_get_object(parser,da) found = .TRUE. ra = ra/angstrom da = da/kcalmol - CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,name=iname,xi=ra,di=da,error=error) + CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,name=iname,xi=ra,di=da) EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END DO END IF @@ -641,32 +638,32 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot ! extract simple atom interaction radii DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) radmax = (dftb_potential(ikind,ikind)%ngrdcut + 1) * & dftb_potential(ikind,ikind)%dgrd*0.5_dp - CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,cutoff=radmax,error=error) + CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,cutoff=radmax) END DO DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a, error=error) - CALL get_dftb_atom_param(dftb_parameter=dftb_atom_a,cutoff=ra,error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) + CALL get_dftb_atom_param(dftb_parameter=dftb_atom_a,cutoff=ra) DO jkind = 1, nkind - CALL get_qs_kind(qs_kind_set(jkind),dftb_parameter=dftb_atom_b, error=error) - CALL get_dftb_atom_param(dftb_parameter=dftb_atom_b,cutoff=rb,error=error) + CALL get_qs_kind(qs_kind_set(jkind),dftb_parameter=dftb_atom_b) + CALL get_dftb_atom_param(dftb_parameter=dftb_atom_b,cutoff=rb) radmax = (dftb_potential(ikind,jkind)%ngrdcut + 1) * & dftb_potential(ikind,jkind)%dgrd IF ( ra+rb < radmax ) THEN ra = ra + (radmax-ra-rb)*0.5_dp rb = rb + (radmax-ra-rb)*0.5_dp - CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,cutoff=ra,error=error) - CALL set_dftb_atom_param(dftb_parameter=dftb_atom_b,cutoff=rb,error=error) + CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,cutoff=ra) + CALL set_dftb_atom_param(dftb_parameter=dftb_atom_b,cutoff=rb) END IF END DO END DO ! set correct core charge in potential DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a, error=error) - CALL get_dftb_atom_param(dftb_parameter=dftb_atom_a,zeff=zeff,error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom_a) + CALL get_dftb_atom_param(dftb_parameter=dftb_atom_a,zeff=zeff) CALL set_potential(potential=qs_kind_set(ikind)%all_potential,& zeff=zeff,zeff_correction=0.0_dp) END DO @@ -674,9 +671,9 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot ! setup DFTB3 parameters IF ( dftb_control%dftb3_diagonal ) THEN DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind), dftb3_param=db, error=error) - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_atom_a, error=error) - CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,dudq=db,error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb3_param=db) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_atom_a) + CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,dudq=db) END DO END IF @@ -685,12 +682,12 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot IF ( dftb_control%dispersion_type == dispersion_uff ) THEN eps_disp = dftb_control%eps_disp DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_atom_a, error=error) - CALL get_dftb_atom_param(dftb_parameter=dftb_atom_a,xi=ra,di=da,error=error) + CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_atom_a) + CALL get_dftb_atom_param(dftb_parameter=dftb_atom_a,xi=ra,di=da) rcdisp = 0._dp DO jkind = 1, nkind - CALL get_qs_kind(qs_kind_set(jkind),dftb_parameter=dftb_atom_b, error=error) - CALL get_dftb_atom_param(dftb_parameter=dftb_atom_b,xi=rb,di=db,error=error) + CALL get_qs_kind(qs_kind_set(jkind),dftb_parameter=dftb_atom_b) + CALL get_dftb_atom_param(dftb_parameter=dftb_atom_b,xi=rb,di=db) xij = SQRT(ra*rb) dij = SQRT(da*db) dftb_potential(ikind,jkind)%xij = xij @@ -704,7 +701,7 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot rmax6 = ((8._dp*pi*dij/eps_disp)*xij**6)**0.25_dp rcdisp = MAX(rcdisp,rmax6*0.5_dp) END DO - CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,rcdisp=rcdisp,error=error) + CALL set_dftb_atom_param(dftb_parameter=dftb_atom_a,rcdisp=rcdisp) END DO END IF END IF @@ -712,7 +709,7 @@ SUBROUTINE qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_pot RETURN 1 CONTINUE - CPPostcondition(.FALSE.,cp_fatal_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_fatal_level,routineP,failure) END SUBROUTINE qs_dftb_param_init diff --git a/src/qs_dftb_types.F b/src/qs_dftb_types.F index f49226a71d..fb4ce5e172 100644 --- a/src/qs_dftb_types.F +++ b/src/qs_dftb_types.F @@ -77,12 +77,10 @@ MODULE qs_dftb_types ! ***************************************************************************** !> \brief ... !> \param pairpot ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dftb_pairpot_init(pairpot,error) + SUBROUTINE qs_dftb_pairpot_init(pairpot) TYPE(qs_dftb_pairpot_type), & DIMENSION(:, :), POINTER :: pairpot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dftb_pairpot_init', & routineP = moduleN//':'//routineN @@ -106,12 +104,10 @@ END SUBROUTINE qs_dftb_pairpot_init !> \param ngrd ... !> \param llm ... !> \param spdim ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dftb_pairpot_create(pairpot,ngrd,llm,spdim,error) + SUBROUTINE qs_dftb_pairpot_create(pairpot,ngrd,llm,spdim) TYPE(qs_dftb_pairpot_type) :: pairpot INTEGER, INTENT(IN) :: ngrd, llm, spdim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dftb_pairpot_create', & routineP = moduleN//':'//routineN @@ -124,29 +120,27 @@ SUBROUTINE qs_dftb_pairpot_create(pairpot,ngrd,llm,spdim,error) IF ( spdim > 0 ) THEN ALLOCATE(pairpot%spxr(spdim,2),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ALLOCATE(pairpot%scoeff(spdim,4),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ALLOCATE(pairpot%fmat(ngrd,llm),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ALLOCATE(pairpot%smat(ngrd,llm),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END SUBROUTINE qs_dftb_pairpot_create ! ***************************************************************************** !> \brief ... !> \param pairpot ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dftb_pairpot_release(pairpot,error) + SUBROUTINE qs_dftb_pairpot_release(pairpot) TYPE(qs_dftb_pairpot_type), & DIMENSION(:, :), POINTER :: pairpot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dftb_pairpot_release', & routineP = moduleN//':'//routineN @@ -163,24 +157,24 @@ SUBROUTINE qs_dftb_pairpot_release(pairpot,error) DO j=1,n2 IF (ASSOCIATED(pairpot(i,j)%spxr)) THEN DEALLOCATE(pairpot(i,j)%spxr,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(pairpot(i,j)%scoeff)) THEN DEALLOCATE(pairpot(i,j)%scoeff,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(pairpot(i,j)%smat)) THEN DEALLOCATE(pairpot(i,j)%smat,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(pairpot(i,j)%fmat)) THEN DEALLOCATE(pairpot(i,j)%fmat,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END DO DEALLOCATE(pairpot,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE qs_dftb_pairpot_release diff --git a/src/qs_dftb_utils.F b/src/qs_dftb_utils.F index 6d183c5e9b..1489a45383 100644 --- a/src/qs_dftb_utils.F +++ b/src/qs_dftb_utils.F @@ -36,12 +36,10 @@ MODULE qs_dftb_utils ! ***************************************************************************** !> \brief ... !> \param dftb_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_dftb_atom_param(dftb_parameter,error) + SUBROUTINE allocate_dftb_atom_param(dftb_parameter) TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_dftb_atom_param', & routineP = moduleN//':'//routineN @@ -50,10 +48,10 @@ SUBROUTINE allocate_dftb_atom_param(dftb_parameter,error) LOGICAL :: failure IF (ASSOCIATED(dftb_parameter)) & - CALL deallocate_dftb_atom_param(dftb_parameter,error) + CALL deallocate_dftb_atom_param(dftb_parameter) ALLOCATE (dftb_parameter,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) dftb_parameter % defined = .FALSE. dftb_parameter % name = "" @@ -76,12 +74,10 @@ END SUBROUTINE allocate_dftb_atom_param ! ***************************************************************************** !> \brief ... !> \param dftb_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_dftb_atom_param(dftb_parameter,error) + SUBROUTINE deallocate_dftb_atom_param(dftb_parameter) TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_dftb_atom_param', & routineP = moduleN//':'//routineN @@ -89,9 +85,9 @@ SUBROUTINE deallocate_dftb_atom_param(dftb_parameter,error) INTEGER :: istat LOGICAL :: failure - CPPrecondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,failure) DEALLOCATE (dftb_parameter,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_dftb_atom_param @@ -114,10 +110,9 @@ END SUBROUTINE deallocate_dftb_atom_param !> \param di ... !> \param rcdisp ... !> \param dudq ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_dftb_atom_param(dftb_parameter,name,typ,defined,z,zeff,natorb,& - lmax,skself,occupation,eta,energy,cutoff,xi,di,rcdisp,dudq,error) + lmax,skself,occupation,eta,energy,cutoff,xi,di,rcdisp,dudq) TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter CHARACTER(LEN=default_string_length), & @@ -129,15 +124,13 @@ SUBROUTINE get_dftb_atom_param(dftb_parameter,name,typ,defined,z,zeff,natorb,& REAL(KIND=dp), DIMENSION(0:3), OPTIONAL :: skself, occupation, eta REAL(KIND=dp), OPTIONAL :: energy, cutoff, xi, di, & rcdisp, dudq - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_dftb_atom_param', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,failure) IF (PRESENT(name)) name = dftb_parameter%name IF (PRESENT(typ)) typ = dftb_parameter%typ @@ -177,10 +170,9 @@ END SUBROUTINE get_dftb_atom_param !> \param di ... !> \param rcdisp ... !> \param dudq ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_dftb_atom_param(dftb_parameter,name,typ,defined,z,zeff,natorb,& - lmax,skself,occupation,eta,energy,cutoff,xi,di,rcdisp,dudq,error) + lmax,skself,occupation,eta,energy,cutoff,xi,di,rcdisp,dudq) TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter CHARACTER(LEN=default_string_length), & @@ -192,14 +184,13 @@ SUBROUTINE set_dftb_atom_param(dftb_parameter,name,typ,defined,z,zeff,natorb,& REAL(KIND=dp), DIMENSION(0:3), OPTIONAL :: skself, occupation, eta REAL(KIND=dp), OPTIONAL :: energy, cutoff, xi, di, & rcdisp, dudq - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_dftb_atom_param', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,failure) IF (PRESENT(name)) dftb_parameter%name = name IF (PRESENT(typ)) dftb_parameter%typ = typ @@ -224,13 +215,11 @@ END SUBROUTINE set_dftb_atom_param !> \brief ... !> \param dftb_parameter ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_dftb_atom_param(dftb_parameter,subsys_section,error) + SUBROUTINE write_dftb_atom_param(dftb_parameter,subsys_section) TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_dftb_atom_param', & routineP = moduleN//':'//routineN @@ -242,17 +231,17 @@ SUBROUTINE write_dftb_atom_param(dftb_parameter,subsys_section,error) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(dftb_parameter).AND.& BTEST(cp_print_key_should_output(logger%iter_info,subsys_section,& - "PRINT%KINDS/POTENTIAL",error=error),cp_p_file)) THEN + "PRINT%KINDS/POTENTIAL"),cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,subsys_section,"PRINT%KINDS",& - extension=".Log",error=error) + extension=".Log") IF (output_unit >0) THEN CALL get_dftb_atom_param(dftb_parameter,name=name,typ=typ,defined=defined,& - z=z,zeff=zeff,natorb=natorb,lmax=lmax,error=error) + z=z,zeff=zeff,natorb=natorb,lmax=lmax) WRITE (UNIT=output_unit,FMT="(/,A,T67,A14)")& " DFTB parameters: ",TRIM(name) @@ -267,7 +256,7 @@ SUBROUTINE write_dftb_atom_param(dftb_parameter,subsys_section,error) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%KINDS",error=error) + "PRINT%KINDS") END IF END SUBROUTINE write_dftb_atom_param diff --git a/src/qs_diis.F b/src/qs_diis.F index dd2b34fc88..4efdd23aa3 100644 --- a/src/qs_diis.F +++ b/src/qs_diis.F @@ -77,17 +77,14 @@ MODULE qs_diis !> \brief Allocates an SCF DIIS buffer !> \param diis_buffer the buffer to create !> \param nbuffer ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE qs_diis_b_create(diis_buffer,nbuffer,error) + SUBROUTINE qs_diis_b_create(diis_buffer,nbuffer) TYPE(qs_diis_buffer_type), POINTER :: diis_buffer INTEGER, INTENT(in) :: nbuffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_diis_b_create', & routineP = moduleN//':'//routineN @@ -102,7 +99,7 @@ SUBROUTINE qs_diis_b_create(diis_buffer,nbuffer,error) failure = .FALSE. ALLOCATE(diis_buffer,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (diis_buffer%b_matrix) NULLIFY (diis_buffer%error) @@ -124,8 +121,6 @@ END SUBROUTINE qs_diis_b_create !> \param matrix_struct the structure for the matrix of the buffer !> \param nspin ... !> \param scf_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - Creation (07.05.2001, Matthias Krack) !> - Changed to BLACS matrix usage (08.06.2001,MK) @@ -135,13 +130,12 @@ END SUBROUTINE qs_diis_b_create !> check to allocate matrixes only when needed, using a linked list? ! ***************************************************************************** SUBROUTINE qs_diis_b_check_i_alloc(diis_buffer,matrix_struct,nspin,& - scf_section,error) + scf_section) TYPE(qs_diis_buffer_type), POINTER :: diis_buffer TYPE(cp_fm_struct_type), POINTER :: matrix_struct INTEGER, INTENT(IN) :: nspin TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_diis_b_check_i_alloc', & routineP = moduleN//':'//routineN @@ -157,10 +151,10 @@ SUBROUTINE qs_diis_b_check_i_alloc(diis_buffer,matrix_struct,nspin,& failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,error,failure) - CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,failure) + CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,failure) nbuffer = diis_buffer%nbuffer @@ -178,7 +172,7 @@ SUBROUTINE qs_diis_b_check_i_alloc(diis_buffer,matrix_struct,nspin,& "%error("//& TRIM(ADJUSTL(cp_to_string(ibuffer)))//","//& TRIM(ADJUSTL(cp_to_string(ibuffer)))//")",& - matrix_struct=matrix_struct,error=error) + matrix_struct=matrix_struct) END DO END DO END IF @@ -197,7 +191,7 @@ SUBROUTINE qs_diis_b_check_i_alloc(diis_buffer,matrix_struct,nspin,& "%parameter("//& TRIM(ADJUSTL(cp_to_string(ibuffer)))//","//& TRIM(ADJUSTL(cp_to_string(ibuffer)))//")",& - matrix_struct=matrix_struct,error=error) + matrix_struct=matrix_struct) END DO END DO END IF @@ -209,13 +203,13 @@ SUBROUTINE qs_diis_b_check_i_alloc(diis_buffer,matrix_struct,nspin,& (nbuffer + 1)**2*dp_size) diis_buffer%b_matrix = 0.0_dp output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%DIIS_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit > 0) THEN WRITE (UNIT=output_unit,FMT="(/,T9,A)")& "DIIS | The SCF DIIS buffer was allocated and initialized" END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%DIIS_INFO",error=error) + "PRINT%DIIS_INFO") END IF CALL timestop(handle) @@ -236,8 +230,6 @@ END SUBROUTINE qs_diis_b_check_i_alloc !> \param s_matrix ... !> \param scf_section ... !> \param roks ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - Creation (07.05.2001, Matthias Krack) !> - Changed to BLACS matrix usage (08.06.2001, MK) @@ -246,8 +238,7 @@ END SUBROUTINE qs_diis_b_check_i_alloc !> \author Matthias Krack ! ***************************************************************************** SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& - diis_step,eps_diis,nmixing,s_matrix,scf_section,roks,& - error) + diis_step,eps_diis,nmixing,s_matrix,scf_section,roks) TYPE(qs_diis_buffer_type), POINTER :: diis_buffer TYPE(mo_set_p_type), DIMENSION(:), & @@ -264,7 +255,6 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& OPTIONAL, POINTER :: s_matrix TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(IN), OPTIONAL :: roks - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_diis_b_step', & routineP = moduleN//':'//routineN @@ -305,7 +295,7 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& IF (PRESENT(nmixing)) my_nmixing = nmixing NULLIFY (c,new_errors,old_errors,parameters,matrix_struct,a,b,occa,occb) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Quick return, if no DIIS is requested @@ -315,13 +305,11 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& END IF CALL cp_fm_get_info(kc(1)%matrix,& - matrix_struct=matrix_struct,& - error=error) + matrix_struct=matrix_struct) CALL qs_diis_b_check_i_alloc(diis_buffer,& matrix_struct=matrix_struct,& nspin=nspin,& - scf_section=scf_section,& - error=error) + scf_section=scf_section) error_max = 0.0_dp @@ -345,7 +333,7 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& ! Copy the Kohn-Sham matrix K to the DIIS buffer - CALL cp_fm_to_fm(kc(ispin)%matrix,parameters,error=error) + CALL cp_fm_to_fm(kc(ispin)%matrix,parameters) IF (my_roks) THEN @@ -360,24 +348,24 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& occ(imo) = SQRT(occa(imo) + occb(imo)) END DO - CALL cp_fm_to_fm(c,sc,error=error) + CALL cp_fm_to_fm(c,sc) CALL cp_fm_column_scale(sc,occ(1:homo)) ! KC <- K*C - CALL cp_fm_symm("L","U",nao,homo,1.0_dp,parameters,sc,0.0_dp,kc(ispin)%matrix,error=error) + CALL cp_fm_symm("L","U",nao,homo,1.0_dp,parameters,sc,0.0_dp,kc(ispin)%matrix) IF (PRESENT(s_matrix)) THEN - CALL copy_dbcsr_to_fm(s_matrix(1)%matrix,new_errors,error=error) + CALL copy_dbcsr_to_fm(s_matrix(1)%matrix,new_errors) ! SC <- S*C - CALL cp_fm_symm("L","U",nao,homo,1.0_dp,new_errors,c,0.0_dp,sc,error=error) + CALL cp_fm_symm("L","U",nao,homo,1.0_dp,new_errors,c,0.0_dp,sc) CALL cp_fm_column_scale(sc,occ(1:homo)) END IF ! new_errors <- KC*(SC)^T - (SC)*(KC)^T = K*P*S - S*P*K ! or for an orthogonal basis ! new_errors <- KC*C^T - C*(KC)^T = K*P - P*K with S = I - CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,sc,kc(ispin)%matrix, 0.0_dp,new_errors,error=error) - CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,kc(ispin)%matrix,sc,-1.0_dp,new_errors,error=error) + CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,sc,kc(ispin)%matrix, 0.0_dp,new_errors) + CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,kc(ispin)%matrix,sc,-1.0_dp,new_errors) DEALLOCATE (occ,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"occ") @@ -385,25 +373,25 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& ELSE ! KC <- K*C - CALL cp_fm_symm("L","U",nao,homo,maxocc,parameters,c,0.0_dp,kc(ispin)%matrix,error=error) + CALL cp_fm_symm("L","U",nao,homo,maxocc,parameters,c,0.0_dp,kc(ispin)%matrix) IF (PRESENT(s_matrix)) THEN ! I guess that this copy can be avoided for LSD - CALL copy_dbcsr_to_fm(s_matrix(1)%matrix,new_errors,error=error) + CALL copy_dbcsr_to_fm(s_matrix(1)%matrix,new_errors) ! sc <- S*C - CALL cp_fm_symm("L","U",nao,homo,2.0_dp,new_errors,c,0.0_dp,sc,error=error) + CALL cp_fm_symm("L","U",nao,homo,2.0_dp,new_errors,c,0.0_dp,sc) ! new_errors <- KC*(SC)^T - (SC)*(KC)^T = K*P*S - S*P*K - CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,sc,kc(ispin)%matrix, 0.0_dp,new_errors,error=error) - CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,kc(ispin)%matrix,sc,-1.0_dp,new_errors,error=error) + CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,sc,kc(ispin)%matrix, 0.0_dp,new_errors) + CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,kc(ispin)%matrix,sc,-1.0_dp,new_errors) ELSE ! new_errors <- KC*(C)^T - C*(KC)^T = K*P - P*K - CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,c,kc(ispin)%matrix, 0.0_dp,new_errors,error=error) - CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,kc(ispin)%matrix,c,-1.0_dp,new_errors,error=error) + CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,c,kc(ispin)%matrix, 0.0_dp,new_errors) + CALL cp_gemm("N","T",nao,nao,homo,1.0_dp,kc(ispin)%matrix,c,-1.0_dp,new_errors) END IF END IF - CALL cp_fm_maxabsval(new_errors,tmp,error=error) + CALL cp_fm_maxabsval(new_errors,tmp) error_max = MAX(error_max,tmp) END DO @@ -413,7 +401,7 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& diis_step = ((diis_buffer%ncall >= my_nmixing).AND.(delta < eps_diis)) output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%DIIS_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit > 0) THEN WRITE (UNIT=output_unit,FMT="(/,T9,A,I4,/,(T9,A,ES12.3))")& "DIIS | Current SCF DIIS buffer size: ",nb,& @@ -447,7 +435,7 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& DO ispin=1,nspin old_errors => diis_buffer%error(jb,ispin)%matrix new_errors => diis_buffer%error(ib,ispin)%matrix - CALL cp_fm_trace(old_errors,new_errors,tmp,error=error) + CALL cp_fm_trace(old_errors,new_errors,tmp) b(jb,ib) = b(jb,ib) + tmp END DO b(ib,jb) = b(jb,ib) @@ -485,7 +473,7 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& ! Solve the linear DIIS equation system - CALL diamat_all(b(1:nb1,1:nb1),ev(1:nb1),error=error) + CALL diamat_all(b(1:nb1,1:nb1),ev(1:nb1)) a(1:nb1,1:nb1) = b(1:nb1,1:nb1) @@ -521,10 +509,10 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& ! Update Kohn-Sham matrix DO ispin=1,nspin - CALL cp_fm_set_all(kc(ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(kc(ispin)%matrix,0.0_dp) DO jb=1,nb parameters => diis_buffer%parameter(jb,ispin)%matrix - CALL cp_fm_scale_and_add(1.0_dp,kc(ispin)%matrix,-ev(jb),parameters,error=error) + CALL cp_fm_scale_and_add(1.0_dp,kc(ispin)%matrix,-ev(jb),parameters) END DO END DO @@ -539,13 +527,13 @@ SUBROUTINE qs_diis_b_step(diis_buffer,mo_array,kc,sc,delta,error_max,& DO ispin=1,nspin parameters => diis_buffer%parameter(ib,ispin)%matrix - CALL cp_fm_to_fm(parameters,kc(ispin)%matrix,error=error) + CALL cp_fm_to_fm(parameters,kc(ispin)%matrix) END DO END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%DIIS_INFO",error=error) + "PRINT%DIIS_INFO") CALL timestop(handle) @@ -554,16 +542,13 @@ END SUBROUTINE qs_diis_b_step ! ***************************************************************************** !> \brief clears the buffer !> \param diis_buffer the buffer to clear -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE qs_diis_b_clear(diis_buffer,error) + SUBROUTINE qs_diis_b_clear(diis_buffer) TYPE(qs_diis_buffer_type), POINTER :: diis_buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_diis_b_clear', & routineP = moduleN//':'//routineN @@ -577,8 +562,8 @@ SUBROUTINE qs_diis_b_clear(diis_buffer,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,error,failure) - CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,failure) + CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,failure) diis_buffer%ncall = 0 @@ -599,15 +584,13 @@ END SUBROUTINE qs_diis_b_clear !> \param nmixing ... !> \param s_matrix ... !> \param threshold ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - Adapted for LS-SCF (10-11-14) from qs_diis_b_step !> \author Fredy W. Aquino ! ***************************************************************************** SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & - diis_step,eps_diis,nmixing,s_matrix,threshold,error) + diis_step,eps_diis,nmixing,s_matrix,threshold) ! Note.- Input: ls_scf_env%matrix_p(ispin) , Density Matrix ! matrix_ks (from qs_env) , Kohn-Sham Matrix (IN/OUT) @@ -621,7 +604,6 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & INTEGER, INTENT(IN), OPTIONAL :: nmixing TYPE(cp_dbcsr_type), OPTIONAL :: s_matrix REAL(KIND=dp), INTENT(IN) :: threshold - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_diis_b_step_4lscf', & routineP = moduleN//':'//routineN @@ -646,7 +628,7 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & my_nmixing = 2 IF (PRESENT(nmixing)) my_nmixing = nmixing NULLIFY (new_errors,old_errors,parameters,a,b) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Quick return, if no DIIS is requested IF (diis_buffer%nbuffer < 1) THEN CALL timestop(handle) @@ -656,29 +638,27 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & ! Getting current Kohn-Sham matrix from qs_env CALL get_qs_env(qs_env, & para_env=para_env, & - matrix_ks=matrix_ks, & - error=error) + matrix_ks=matrix_ks) CALL qs_diis_b_check_i_alloc_sparse( & diis_buffer, & ls_scf_env, & - nspin, & - error) + nspin) error_max = 0.0_dp ib = MODULO(diis_buffer%ncall,diis_buffer%nbuffer) + 1 diis_buffer%ncall = diis_buffer%ncall + 1 nb = MIN(diis_buffer%ncall,diis_buffer%nbuffer) ! Create scratch arrays - CALL cp_dbcsr_init(matrix_tmp,error=error) + CALL cp_dbcsr_init(matrix_tmp) CALL cp_dbcsr_create(matrix_tmp, & template=ls_scf_env%matrix_ks(1),& - matrix_type='N',error=error) - CALL cp_dbcsr_set(matrix_tmp,0.0_dp,error=error) ! reset matrix - CALL cp_dbcsr_init(matrix_KSerr_t,error=error) + matrix_type='N') + CALL cp_dbcsr_set(matrix_tmp,0.0_dp) ! reset matrix + CALL cp_dbcsr_init(matrix_KSerr_t) CALL cp_dbcsr_create(matrix_KSerr_t,& template=ls_scf_env%matrix_ks(1),& - matrix_type='N',error=error) - CALL cp_dbcsr_set(matrix_KSerr_t,0.0_dp,error=error) ! reset matrix + matrix_type='N') + CALL cp_dbcsr_set(matrix_KSerr_t,0.0_dp) ! reset matrix DO ispin=1,nspin ! ------ Loop-ispin----START @@ -686,8 +666,7 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & parameters => diis_buffer%parameter(ib,ispin)%matrix ! Copy the Kohn-Sham matrix K to the DIIS buffer CALL cp_dbcsr_copy(parameters, & ! out - matrix_ks(ispin)%matrix, & ! in - error=error) + matrix_ks(ispin)%matrix) ! in IF (PRESENT(s_matrix)) THEN ! if-s_matrix ---------- START ! Calculate Kohn-Sham error (non-orthogonal)= K*P*S-(K*P*S)^T @@ -696,22 +675,20 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & 1.0_dp,ls_scf_env%matrix_p(ispin),& s_matrix, & 0.0_dp,matrix_tmp, & - filter_eps=threshold, error=error) + filter_eps=threshold) ! new_errors= K*P*S CALL cp_dbcsr_multiply("N", "N", & 1.0_dp,matrix_ks(ispin)%matrix, & matrix_tmp, & 0.0_dp,new_errors, & - filter_eps=threshold,error=error) + filter_eps=threshold) ! matrix_KSerr_t= transpose(K*P*S) CALL cp_dbcsr_transposed(matrix_KSerr_t, & - new_errors, & - error=error) + new_errors) ! new_errors=K*P*S-transpose(K*P*S) CALL cp_dbcsr_add(new_errors, & matrix_KSerr_t, & - 1.0_dp,-1.0_dp, & - error=error) + 1.0_dp,-1.0_dp) ELSE ! if-s_matrix ---------- MID ! Calculate Kohn-Sham error (orthogonal)= K*P - P*K ! new_errors=K*P @@ -719,16 +696,14 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & 1.0_dp,matrix_ks(ispin)%matrix, & ls_scf_env%matrix_p(ispin),& 0.0_dp,new_errors, & - filter_eps=threshold,error=error) + filter_eps=threshold) ! matrix_KSerr_t= transpose(K*P) CALL cp_dbcsr_transposed(matrix_KSerr_t, & - new_errors, & - error=error) + new_errors) ! new_errors=K*P-transpose(K*P) CALL cp_dbcsr_add(new_errors, & matrix_KSerr_t, & - 1.0_dp,-1.0_dp, & - error=error) + 1.0_dp,-1.0_dp) END IF ! if-s_matrix ---------- END tmp=cp_dbcsr_maxabs(new_errors) @@ -762,8 +737,7 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & new_errors => diis_buffer%error(ib,ispin)%matrix CALL cp_dbcsr_trace(old_errors, & new_errors, & - tmp, & ! out : < f_i | f_j > - error=error) + tmp) ! out : < f_i | f_j > b(jb,ib) = b(jb,ib) + tmp END DO ! end-loop-ispin b(ib,jb) = b(jb,ib) @@ -790,7 +764,7 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & b(nb1 ,1:nb) = -1.0_dp b(nb1 , nb1) = 0.0_dp ! Solve the linear DIIS equation system - CALL diamat_all(b(1:nb1,1:nb1),ev(1:nb1),error=error) + CALL diamat_all(b(1:nb1,1:nb1),ev(1:nb1)) a(1:nb1,1:nb1) = b(1:nb1,1:nb1) DO jb=1,nb1 IF (ABS(ev(jb)) < eigenvalue_threshold) THEN @@ -811,13 +785,11 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & DO ispin=1,nspin CALL cp_dbcsr_set(matrix_ks(ispin)%matrix, & ! reset matrix - 0.0_dp, & - error=error) + 0.0_dp) DO jb=1,nb parameters => diis_buffer%parameter(jb,ispin)%matrix CALL cp_dbcsr_add(matrix_ks(ispin)%matrix,parameters, & - 1.0_dp,-ev(jb), & - error=error) + 1.0_dp,-ev(jb)) END DO ! end-loop-jb END DO ! end-loop-ispin ENDIF ! if-iscf-to-updateKS------ END @@ -833,12 +805,11 @@ SUBROUTINE qs_diis_b_step_4lscf(diis_buffer,qs_env,ls_scf_env,unit_nr,iscf, & DO ispin=1,nspin parameters => diis_buffer%parameter(ib,ispin)%matrix CALL cp_dbcsr_copy(parameters, & ! out - matrix_ks(ispin)%matrix, & ! in - error=error) + matrix_ks(ispin)%matrix) ! in ENDDO ! end-loop-ispin END IF - CALL cp_dbcsr_release(matrix_tmp ,error=error) - CALL cp_dbcsr_release(matrix_KSerr_t,error=error) + CALL cp_dbcsr_release(matrix_tmp) + CALL cp_dbcsr_release(matrix_KSerr_t) CALL timestop(handle) END SUBROUTINE qs_diis_b_step_4lscf @@ -848,8 +819,6 @@ END SUBROUTINE qs_diis_b_step_4lscf !> \param diis_buffer the buffer to initialize !> \param ls_scf_env ... !> \param nspin ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - Adapted from qs_diis_b_check_i_alloc for sparse matrices and !> used in LS-SCF module (ls_scf_main) (10-11-14) @@ -859,13 +828,12 @@ END SUBROUTINE qs_diis_b_step_4lscf ! ***************************************************************************** SUBROUTINE qs_diis_b_check_i_alloc_sparse(diis_buffer,ls_scf_env, & - nspin,error) + nspin) TYPE(qs_diis_buffer_type_sparse), & POINTER :: diis_buffer TYPE(ls_scf_env_type) :: ls_scf_env INTEGER, INTENT(IN) :: nspin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'qs_diis_b_check_i_alloc_sparse', & @@ -882,10 +850,10 @@ SUBROUTINE qs_diis_b_check_i_alloc_sparse(diis_buffer,ls_scf_env, & failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,error,failure) - CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,failure) + CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,failure) nbuffer = diis_buffer%nbuffer @@ -897,12 +865,11 @@ SUBROUTINE qs_diis_b_check_i_alloc_sparse(diis_buffer,ls_scf_env, & DO ispin=1,nspin DO ibuffer=1,nbuffer ALLOCATE (diis_buffer%error(ibuffer,ispin)%matrix,STAT=istat) - CALL cp_dbcsr_init(diis_buffer%error(ibuffer,ispin)%matrix, & - error=error) + CALL cp_dbcsr_init(diis_buffer%error(ibuffer,ispin)%matrix) CALL cp_dbcsr_create(diis_buffer%error(ibuffer,ispin)%matrix, & template=ls_scf_env%matrix_ks(1),& - matrix_type='N',error=error) + matrix_type='N') END DO END DO END IF @@ -915,11 +882,10 @@ SUBROUTINE qs_diis_b_check_i_alloc_sparse(diis_buffer,ls_scf_env, & DO ispin=1,nspin DO ibuffer=1,nbuffer ALLOCATE (diis_buffer%parameter(ibuffer,ispin)%matrix,STAT=istat) - CALL cp_dbcsr_init(diis_buffer%parameter(ibuffer,ispin)%matrix, & - error=error) + CALL cp_dbcsr_init(diis_buffer%parameter(ibuffer,ispin)%matrix) CALL cp_dbcsr_create(diis_buffer%parameter(ibuffer,ispin)%matrix, & template=ls_scf_env%matrix_ks(1),& - matrix_type='N',error=error) + matrix_type='N') END DO END DO END IF @@ -940,18 +906,15 @@ END SUBROUTINE qs_diis_b_check_i_alloc_sparse ! ***************************************************************************** !> \brief clears the DIIS buffer in LS-SCF calculation !> \param diis_buffer the buffer to clear -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10-11-14 created [FA] modified from qs_diis_b_clear !> \author Fredy W. Aquino ! ***************************************************************************** - SUBROUTINE qs_diis_b_clear_sparse(diis_buffer,error) + SUBROUTINE qs_diis_b_clear_sparse(diis_buffer) TYPE(qs_diis_buffer_type_sparse), & POINTER :: diis_buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_diis_b_clear_sparse', & routineP = moduleN//':'//routineN @@ -965,8 +928,8 @@ SUBROUTINE qs_diis_b_clear_sparse(diis_buffer,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,error,failure) - CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,failure) + CPPrecondition(diis_buffer%ref_count>0,cp_failure_level,routineP,failure) diis_buffer%ncall = 0 @@ -978,18 +941,15 @@ END SUBROUTINE qs_diis_b_clear_sparse !> \brief Allocates an SCF DIIS buffer for LS-SCF calculation !> \param diis_buffer the buffer to create !> \param nbuffer ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10-11-14 created [FA] modified from qs_diis_b_create !> \author Fredy W. Aquino ! ***************************************************************************** - SUBROUTINE qs_diis_b_create_sparse(diis_buffer,nbuffer,error) + SUBROUTINE qs_diis_b_create_sparse(diis_buffer,nbuffer) TYPE(qs_diis_buffer_type_sparse), & POINTER :: diis_buffer INTEGER, INTENT(in) :: nbuffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_diis_b_create_sparse', & routineP = moduleN//':'//routineN @@ -1004,7 +964,7 @@ SUBROUTINE qs_diis_b_create_sparse(diis_buffer,nbuffer,error) failure = .FALSE. ALLOCATE(diis_buffer,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (diis_buffer%b_matrix) NULLIFY (diis_buffer%error) diff --git a/src/qs_diis_types.F b/src/qs_diis_types.F index 8948f25321..11f72fd9fb 100644 --- a/src/qs_diis_types.F +++ b/src/qs_diis_types.F @@ -75,15 +75,12 @@ MODULE qs_diis_types ! ***************************************************************************** !> \brief retains a diis buffer (see doc/ReferenceCounting.html) !> \param diis_buffer the buffer to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE qs_diis_b_retain(diis_buffer,error) +SUBROUTINE qs_diis_b_retain(diis_buffer) TYPE(qs_diis_buffer_type), POINTER :: diis_buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_diis_b_retain', & routineP = moduleN//':'//routineN @@ -92,23 +89,20 @@ SUBROUTINE qs_diis_b_retain(diis_buffer,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(diis_buffer%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(diis_buffer),cp_failure_level,routineP,failure) + CPPreconditionNoFail(diis_buffer%ref_count>0,cp_failure_level,routineP) diis_buffer%ref_count=diis_buffer%ref_count+1 END SUBROUTINE qs_diis_b_retain ! ***************************************************************************** !> \brief releases the given diis buffer (see doc/ReferenceCounting.html) !> \param diis_buffer the buffer to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE qs_diis_b_release(diis_buffer,error) +SUBROUTINE qs_diis_b_release(diis_buffer) TYPE(qs_diis_buffer_type), POINTER :: diis_buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_diis_b_release', & routineP = moduleN//':'//routineN @@ -119,34 +113,33 @@ SUBROUTINE qs_diis_b_release(diis_buffer,error) failure=.FALSE. IF (ASSOCIATED(diis_buffer)) THEN - CPPreconditionNoFail(diis_buffer%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(diis_buffer%ref_count>0,cp_failure_level,routineP) diis_buffer%ref_count=diis_buffer%ref_count-1 IF (diis_buffer%ref_count<1) THEN IF (ASSOCIATED(diis_buffer%b_matrix)) THEN DEALLOCATE(diis_buffer%b_matrix,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(diis_buffer%error)) THEN DO j=1,SIZE(diis_buffer%error,2) DO i=1,SIZE(diis_buffer%error,1) - CALL cp_fm_release(diis_buffer%error(i,j)%matrix,error=error) + CALL cp_fm_release(diis_buffer%error(i,j)%matrix) END DO END DO DEALLOCATE(diis_buffer%error,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(diis_buffer%parameter)) THEN DO j=1,SIZE(diis_buffer%parameter,2) DO i=1,SIZE(diis_buffer%parameter,1) - CALL cp_fm_release(diis_buffer%parameter(i,j)%matrix,& - error=error) + CALL cp_fm_release(diis_buffer%parameter(i,j)%matrix) END DO END DO DEALLOCATE(diis_buffer%parameter,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(diis_buffer,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE qs_diis_b_release @@ -154,17 +147,14 @@ END SUBROUTINE qs_diis_b_release ! ***************************************************************************** !> \brief releases the given diis buffer (see doc/ReferenceCounting.html) !> \param diis_buffer the buffer to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10-11-14 created [FA] modified from qs_diis_b_release !> \author Fredy W. Aquino ! ***************************************************************************** -SUBROUTINE qs_diis_b_release_sparse(diis_buffer,error) +SUBROUTINE qs_diis_b_release_sparse(diis_buffer) TYPE(qs_diis_buffer_type_sparse), & POINTER :: diis_buffer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_diis_b_release_sparse', & routineP = moduleN//':'//routineN @@ -177,32 +167,30 @@ SUBROUTINE qs_diis_b_release_sparse(diis_buffer,error) IF (ASSOCIATED(diis_buffer)) THEN IF (ASSOCIATED(diis_buffer%b_matrix)) THEN DEALLOCATE(diis_buffer%b_matrix,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(diis_buffer%error)) THEN DO j=1,SIZE(diis_buffer%error,2) DO i=1,SIZE(diis_buffer%error,1) - CALL cp_dbcsr_release(diis_buffer%error(i,j)%matrix, & - error=error) + CALL cp_dbcsr_release(diis_buffer%error(i,j)%matrix) DEALLOCATE(diis_buffer%error(i,j)%matrix) END DO END DO DEALLOCATE(diis_buffer%error,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(diis_buffer%parameter)) THEN DO j=1,SIZE(diis_buffer%parameter,2) DO i=1,SIZE(diis_buffer%parameter,1) - CALL cp_dbcsr_release(diis_buffer%parameter(i,j)%matrix, & - error=error) + CALL cp_dbcsr_release(diis_buffer%parameter(i,j)%matrix) DEALLOCATE(diis_buffer%parameter(i,j)%matrix) END DO END DO DEALLOCATE(diis_buffer%parameter,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(diis_buffer,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE qs_diis_b_release_sparse diff --git a/src/qs_dispersion_nonloc.F b/src/qs_dispersion_nonloc.F index 70953d4b83..4f43caa63f 100644 --- a/src/qs_dispersion_nonloc.F +++ b/src/qs_dispersion_nonloc.F @@ -70,12 +70,10 @@ MODULE qs_dispersion_nonloc !> \brief ... !> \param dispersion_env ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dispersion_nonloc_init(dispersion_env,para_env,error) + SUBROUTINE qs_dispersion_nonloc_init(dispersion_env,para_env) TYPE(qs_dispersion_type), POINTER :: dispersion_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dispersion_nonloc_init', & routineP = moduleN//':'//routineN @@ -118,7 +116,7 @@ SUBROUTINE qs_dispersion_nonloc_init(dispersion_env,para_env,error) CALL mp_bcast(dispersion_env%r_max,para_env%source,para_env%group) ALLOCATE(dispersion_env%q_mesh(nqs),dispersion_env%kernel(0:nr_points,nqs,nqs),& dispersion_env%d2phi_dk2(0:nr_points,nqs,nqs),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dispersion_env%nqs = nqs dispersion_env%nr_points = nr_points IF(para_env%source==para_env%mepos) THEN @@ -150,7 +148,7 @@ SUBROUTINE qs_dispersion_nonloc_init(dispersion_env,para_env,error) CALL mp_bcast(dispersion_env%d2phi_dk2,para_env%source,para_env%group) ! 2nd derivates for interpolation ALLOCATE(dispersion_env%d2y_dx2(nqs,nqs),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL initialize_spline_interpolation (dispersion_env%q_mesh, dispersion_env%d2y_dx2) ! dispersion_env%q_cut = dispersion_env%q_mesh(nqs) @@ -176,10 +174,9 @@ END SUBROUTINE qs_dispersion_nonloc_init !> \param xc_pw_pool ... !> \param para_env ... !> \param virial ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& - dispersion_env,energy_only,pw_pool,xc_pw_pool,para_env,virial,error) + dispersion_env,energy_only,pw_pool,xc_pw_pool,para_env,virial) TYPE(pw_p_type), DIMENSION(:), POINTER :: vxc_rho, rho_r, rho_g REAL(KIND=dp), INTENT(OUT) :: edispersion TYPE(qs_dispersion_type), POINTER :: dispersion_env @@ -187,7 +184,6 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& TYPE(pw_pool_type), POINTER :: pw_pool, xc_pw_pool TYPE(cp_para_env_type), POINTER :: para_env TYPE(virial_type), OPTIONAL, POINTER :: virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_dispersion_nonloc', & routineP = moduleN//':'//routineN @@ -213,9 +209,9 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(rho_r),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho_g),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_r),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho_g),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) IF (PRESENT(virial)) THEN use_virial = virial%pv_calculate.AND.(.NOT.virial%pv_numer) @@ -223,43 +219,43 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& use_virial = .FALSE. ENDIF IF(use_virial) THEN - CPPrecondition(.NOT.energy_only,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.energy_only,cp_failure_level,routineP,failure) END IF IF (.NOT. energy_only) THEN - CPPrecondition(ASSOCIATED(vxc_rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(vxc_rho),cp_failure_level,routineP,failure) END IF b_value = dispersion_env%b_value beta = 0.03125_dp * (3.0_dp / (b_value**2.0_dp) )**0.75_dp ! tempory arrays for FFT - CALL pw_pool_create_pw(pw_pool, tmp_g, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, error=error) - CALL pw_pool_create_pw(pw_pool, tmp_r, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool, tmp_g, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_pool_create_pw(pw_pool, tmp_r, use_data=REALDATA3D, in_space=REALSPACE) ! get density derivatives nspin=SIZE(rho_r) ALLOCATE ( drho_r(3,nspin), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspin DO idir=1,3 NULLIFY(drho_r(idir,ispin)%pw) CALL pw_pool_create_pw(pw_pool,drho_r(idir,ispin)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_transfer ( rho_g(ispin)%pw, tmp_g, error=error) - CALL pw_derive ( tmp_g, nd(:,idir) ,error=error) - CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_transfer ( rho_g(ispin)%pw, tmp_g) + CALL pw_derive ( tmp_g, nd(:,idir)) + CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw) END DO END DO np = SIZE(tmp_r%cr3d) ALLOCATE ( rho(np), drho(np,3), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rho = 0.0_dp drho = 0.0_dp DO ispin=1,nspin - CPPrecondition(rho_r(ispin)%pw%in_use==REALDATA3D,cp_failure_level,routineP,error,failure) - CALL pw_transfer ( rho_g(ispin)%pw, tmp_g, error=error) - CALL pw_transfer ( tmp_g, tmp_r, error=error) + CPPrecondition(rho_r(ispin)%pw%in_use==REALDATA3D,cp_failure_level,routineP,failure) + CALL pw_transfer ( rho_g(ispin)%pw, tmp_g) + CALL pw_transfer ( tmp_g, tmp_r) rho(:) = rho(:) + RESHAPE(tmp_r%cr3d,(/np/)) drho(:,1) = drho(:,1) + RESHAPE(drho_r(1,ispin)%pw%cr3d,(/np/)) drho(:,2) = drho(:,2) + RESHAPE(drho_r(2,ispin)%pw%cr3d,(/np/)) @@ -275,7 +271,7 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& IF (energy_only) THEN ALLOCATE ( q0(np), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE (dispersion_env%nl_type) CASE DEFAULT STOP 'Unknown vdW-DF functional' @@ -286,7 +282,7 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& END SELECT ELSE ALLOCATE ( q0(np), dq0_drho(np), dq0_dgradrho(np), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE (dispersion_env%nl_type) CASE DEFAULT STOP 'Unknown vdW-DF functional' @@ -312,7 +308,7 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& !! for the convolution (equation 11 of SOLER). !! -------------------------------------------------------------------------------------------------- ALLOCATE ( thetas(np,dispersion_env%nqs), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !! Interpolate the P_i polynomials defined in equation 3 in SOLER for the particular !! q0 values we have. CALL spline_interpolation(dispersion_env%q_mesh, dispersion_env%d2y_dx2, q0, thetas) @@ -345,12 +341,12 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& n2 = SIZE(tmp_r%cr3d,2) n3 = SIZE(tmp_r%cr3d,3) ALLOCATE ( thetas_g(dispersion_env%nqs), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,dispersion_env%nqs tmp_r%cr3d = RESHAPE(thetas(:,i),(/n1,n2,n3/)) NULLIFY(thetas_g(i)%pw) - CALL pw_pool_create_pw(pw_pool, thetas_g(i)%pw, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, error=error) - CALL pw_transfer ( tmp_r, thetas_g(i)%pw ,error=error) + CALL pw_pool_create_pw(pw_pool, thetas_g(i)%pw, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_transfer ( tmp_r, thetas_g(i)%pw) END DO grid => thetas_g(1)%pw%pw_grid !! --------------------------------------------------------------------------------------------- @@ -362,7 +358,7 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& CALL mp_sum(sumnp,para_env%group) IF (use_virial) THEN ! calculates kernel contribution to stress - CALL vdW_energy(thetas_g, dispersion_env, Ec_nl, energy_only, virial, error=error) + CALL vdW_energy(thetas_g, dispersion_env, Ec_nl, energy_only, virial) SELECT CASE (dispersion_env%nl_type) CASE (vdw_nl_RVV10) Ec_nl = 0.5_dp*Ec_nl + beta*SUM(rho(:))*grid%vol/sumnp @@ -373,7 +369,7 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& virial%pv_xc(idir,idir) = virial%pv_xc(idir,idir) + Ec_nl END DO ELSE - CALL vdW_energy(thetas_g, dispersion_env, Ec_nl, energy_only, error=error) + CALL vdW_energy(thetas_g, dispersion_env, Ec_nl, energy_only) SELECT CASE (dispersion_env%nl_type) CASE (vdw_nl_RVV10) Ec_nl = 0.5_dp*Ec_nl + beta*SUM(rho(:))*grid%vol/sumnp @@ -387,7 +383,7 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& !! Inverse Fourier transform the u_i(k) to get the u_i(r) of SOLER equation 11. !!----------------------------------------------------------------------------- DO i=1,dispersion_env%nqs - CALL pw_transfer ( thetas_g(i)%pw, tmp_r ,error=error) + CALL pw_transfer ( thetas_g(i)%pw, tmp_r) thetas(:,i) = RESHAPE(tmp_r%cr3d,(/np/)) END DO !! ------------------------------------------------------------------------- @@ -398,68 +394,68 @@ SUBROUTINE calculate_dispersion_nonloc(vxc_rho,rho_r,rho_g,edispersion,& !! to access grid points outside their allocated regions. !! ------------------------------------------------------------------------- ALLOCATE ( potential(np), hpot(np), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(use_virial) THEN ! calculates gradient contribution to stress grid => tmp_g%pw_grid CALL get_potential(q0, dq0_drho, dq0_dgradrho, rho, thetas, potential, hpot, & - dispersion_env, drho, grid%dvol, virial, error=error) + dispersion_env, drho, grid%dvol, virial) ELSE CALL get_potential(q0, dq0_drho, dq0_dgradrho, rho, thetas, potential, hpot, & - dispersion_env, error=error) + dispersion_env) END IF SELECT CASE (dispersion_env%nl_type) CASE (vdw_nl_RVV10) potential(:) = 0.5_dp*potential(:) + beta hpot(:) = 0.5_dp*hpot(:) END SELECT - CALL pw_pool_create_pw(pw_pool, vxc_r, use_data=REALDATA3D, in_space=REALSPACE, error=error) + CALL pw_pool_create_pw(pw_pool, vxc_r, use_data=REALDATA3D, in_space=REALSPACE) vxc_r%cr3d = RESHAPE(potential,(/n1,n2,n3/)) DO idir=1,3 tmp_r%cr3d = 0.0_dp DO ispin=1,nspin tmp_r%cr3d = tmp_r%cr3d + RESHAPE(hpot,(/n1,n2,n3/)) * drho_r(idir,ispin)%pw%cr3d END DO - CALL pw_transfer ( tmp_r, tmp_g ,error=error) - CALL pw_derive ( tmp_g, nd(:,idir) ,error=error) - CALL pw_transfer ( tmp_g, tmp_r ,error=error) - CALL pw_axpy(tmp_r,vxc_r,-1._dp,error) + CALL pw_transfer ( tmp_r, tmp_g) + CALL pw_derive ( tmp_g, nd(:,idir)) + CALL pw_transfer ( tmp_g, tmp_r) + CALL pw_axpy(tmp_r,vxc_r,-1._dp) END DO - CALL pw_transfer ( vxc_r, tmp_g ,error=error) - CALL pw_pool_give_back_pw(pw_pool, vxc_r, error=error) - CALL pw_pool_create_pw(xc_pw_pool, vxc_r, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_pool_create_pw(xc_pw_pool, vxc_g, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, error=error) - CALL pw_transfer ( tmp_g, vxc_g ,error=error) - CALL pw_transfer ( vxc_g, vxc_r ,error=error) + CALL pw_transfer ( vxc_r, tmp_g) + CALL pw_pool_give_back_pw(pw_pool, vxc_r) + CALL pw_pool_create_pw(xc_pw_pool, vxc_r, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_pool_create_pw(xc_pw_pool, vxc_g, use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_transfer ( tmp_g, vxc_g) + CALL pw_transfer ( vxc_g, vxc_r) DO ispin=1,nspin - CALL pw_axpy(vxc_r,vxc_rho(ispin)%pw,1._dp,error) + CALL pw_axpy(vxc_r,vxc_rho(ispin)%pw,1._dp) END DO - CALL pw_pool_give_back_pw(xc_pw_pool, vxc_r, error=error) - CALL pw_pool_give_back_pw(xc_pw_pool, vxc_g, error=error) + CALL pw_pool_give_back_pw(xc_pw_pool, vxc_r) + CALL pw_pool_give_back_pw(xc_pw_pool, vxc_g) END IF DEALLOCATE ( thetas, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,dispersion_env%nqs - CALL pw_pool_give_back_pw(pw_pool, thetas_g(i)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, thetas_g(i)%pw) END DO DO ispin=1,nspin DO idir=1,3 - CALL pw_pool_give_back_pw(pw_pool, drho_r(idir,ispin)%pw, error=error) + CALL pw_pool_give_back_pw(pw_pool, drho_r(idir,ispin)%pw) END DO END DO - CALL pw_pool_give_back_pw(pw_pool, tmp_r, error=error) - CALL pw_pool_give_back_pw(pw_pool, tmp_g, error=error) + CALL pw_pool_give_back_pw(pw_pool, tmp_r) + CALL pw_pool_give_back_pw(pw_pool, tmp_g) DEALLOCATE ( rho, drho, drho_r, thetas_g, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (energy_only) THEN DEALLOCATE ( q0, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE DEALLOCATE ( q0, dq0_drho, dq0_dgradrho, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -476,16 +472,14 @@ END SUBROUTINE calculate_dispersion_nonloc !> \param vdW_xc_energy ... !> \param energy_only ... !> \param virial ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vdW_energy(thetas_g, dispersion_env, vdW_xc_energy, energy_only, virial, error) + SUBROUTINE vdW_energy(thetas_g, dispersion_env, vdW_xc_energy, energy_only, virial) TYPE(pw_p_type), ALLOCATABLE, & DIMENSION(:) :: thetas_g TYPE(qs_dispersion_type), POINTER :: dispersion_env REAL(KIND=dp), INTENT(OUT) :: vdW_xc_energy LOGICAL, INTENT(IN) :: energy_only TYPE(virial_type), OPTIONAL, POINTER :: virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'vdW_energy', & routineP = moduleN//':'//routineN @@ -508,9 +502,9 @@ SUBROUTINE vdW_energy(thetas_g, dispersion_env, vdW_xc_energy, energy_only, viri CALL timeset(routineN,handle) nqs = dispersion_env%nqs ALLOCATE(kernel_of_k(nqs,nqs),dkernel_of_dk(nqs,nqs),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(theta(nqs),thetam(nqs),theta_g(nqs),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(virial)) THEN use_virial = .TRUE. @@ -524,7 +518,7 @@ SUBROUTINE vdW_energy(thetas_g, dispersion_env, vdW_xc_energy, energy_only, viri IF (.NOT.energy_only) THEN ALLOCATE(u_vdW(grid%ngpts_cut_local,nqs),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) u_vdW(:,:) = CMPLX(0.0_dp,0.0_dp,KIND=dp) END IF @@ -540,8 +534,8 @@ SUBROUTINE vdW_energy(thetas_g, dispersion_env, vdW_xc_energy, energy_only, viri g2_last = g2 igs = igs + 1 g = SQRT(g2) - CALL interpolate_kernel(g,kernel_of_k,dispersion_env,error) - IF (use_virial) CALL interpolate_dkernel_dk(g,dkernel_of_dk,dispersion_env,error) + CALL interpolate_kernel(g,kernel_of_k,dispersion_env) + IF (use_virial) CALL interpolate_dkernel_dk(g,dkernel_of_dk,dispersion_env) END IF DO iq=1,nqs theta(iq) = thetas_g(iq)%pw%cc(ig) @@ -583,12 +577,12 @@ SUBROUTINE vdW_energy(thetas_g, dispersion_env, vdW_xc_energy, energy_only, viri END DO END DO DEALLOCATE(u_vdW,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(theta,thetam,theta_g,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kernel_of_k,dkernel_of_dk,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -616,10 +610,9 @@ END SUBROUTINE vdW_energy !> \param drho ... !> \param dvol ... !> \param virial ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_potential(q0, dq0_drho, dq0_dgradrho, total_rho, u_vdW, potential, h_prefactor, & - dispersion_env, drho, dvol, virial, error) + dispersion_env, drho, dvol, virial) REAL(dp), DIMENSION(:), INTENT(in) :: q0, dq0_drho, dq0_dgradrho, & total_rho @@ -629,7 +622,6 @@ SUBROUTINE get_potential(q0, dq0_drho, dq0_dgradrho, total_rho, u_vdW, potential REAL(dp), DIMENSION(:, :), OPTIONAL :: drho REAL(dp), INTENT(IN), OPTIONAL :: dvol TYPE(virial_type), OPTIONAL, POINTER :: virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_potential', & routineP = moduleN//':'//routineN @@ -648,8 +640,8 @@ SUBROUTINE get_potential(q0, dq0_drho, dq0_dgradrho, total_rho, u_vdW, potential IF (PRESENT(virial)) THEN use_virial = .TRUE. - CPPrecondition(PRESENT(drho),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(dvol),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(drho),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(dvol),cp_failure_level,routineP,failure) ELSE use_virial = .FALSE. END IF @@ -663,7 +655,7 @@ SUBROUTINE get_potential(q0, dq0_drho, dq0_dgradrho, total_rho, u_vdW, potential q_mesh => dispersion_env%q_mesh nqs = dispersion_env%nqs ALLOCATE(y(nqs),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i_grid = 1,SIZE(u_vdw,1) q_low = 1 @@ -732,7 +724,7 @@ SUBROUTINE get_potential(q0, dq0_drho, dq0_dgradrho, total_rho, u_vdW, potential END DO END DO DEALLOCATE(y,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1228,14 +1220,12 @@ END SUBROUTINE initialize_spline_interpolation !> \param k ... !> \param kernel_of_k ... !> \param dispersion_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE interpolate_kernel(k, kernel_of_k, dispersion_env,error) + SUBROUTINE interpolate_kernel(k, kernel_of_k, dispersion_env) REAL(dp), INTENT(in) :: k REAL(dp), INTENT(inout) :: kernel_of_k(:,:) TYPE(qs_dispersion_type), POINTER :: dispersion_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'interpolate_kernel', & routineP = moduleN//':'//routineN @@ -1257,7 +1247,7 @@ SUBROUTINE interpolate_kernel(k, kernel_of_k, dispersion_env,error) !! interpolation. In that case, a kernel file should be generated with a larger number !! of radial points. !! ------------------------------------------------------------------------------------- - CPPrecondition(k < Nr_points*dk,cp_failure_level,routineP,error,failure) + CPPrecondition(k < Nr_points*dk,cp_failure_level,routineP,failure) !! ------------------------------------------------------------------------------------- kernel_of_k = 0.0_dp !! This integer division figures out which bin k is in since the kernel @@ -1299,13 +1289,11 @@ END SUBROUTINE interpolate_kernel !> \param k ... !> \param dkernel_of_dk ... !> \param dispersion_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE interpolate_dkernel_dk(k, dkernel_of_dk, dispersion_env, error) + SUBROUTINE interpolate_dkernel_dk(k, dkernel_of_dk, dispersion_env) REAL(dp), INTENT(in) :: k REAL(dp), INTENT(inout) :: dkernel_of_dk(:,:) TYPE(qs_dispersion_type), POINTER :: dispersion_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'interpolate_dkernel_dk', & routineP = moduleN//':'//routineN @@ -1323,7 +1311,7 @@ SUBROUTINE interpolate_dkernel_dk(k, dkernel_of_dk, dispersion_env, error) kernel => dispersion_env%kernel d2phi_dk2 => dispersion_env%d2phi_dk2 - CPPrecondition(k < Nr_points*dk,cp_failure_level,routineP,error,failure) + CPPrecondition(k < Nr_points*dk,cp_failure_level,routineP,failure) dkernel_of_dk = 0.0_dp k_i = INT(k/dk) diff --git a/src/qs_dispersion_pairpot.F b/src/qs_dispersion_pairpot.F index f79444dd2c..fbbada3e7b 100644 --- a/src/qs_dispersion_pairpot.F +++ b/src/qs_dispersion_pairpot.F @@ -99,9 +99,8 @@ MODULE qs_dispersion_pairpot !> \param dispersion_env ... !> \param pp_section ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,pp_section,para_env,error) + SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,pp_section,para_env) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & @@ -110,7 +109,6 @@ SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env TYPE(section_vals_type), OPTIONAL, & POINTER :: pp_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dispersion_pairpot_init', & routineP = moduleN//':'//routineN @@ -152,21 +150,21 @@ SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env dispersion_env%max_elem = max_elem dispersion_env%maxc = maxc ALLOCATE(dispersion_env%maxci(max_elem),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dispersion_env%c6ab(max_elem,max_elem,maxc,maxc,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dispersion_env%r0ab(max_elem,max_elem),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dispersion_env%rcov(max_elem),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dispersion_env%r2r4(max_elem),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dispersion_env%cn(max_elem),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! get filename of parameter file filename = dispersion_env%parameter_file_name - CALL dftd3_c6_param(dispersion_env%c6ab,dispersion_env%maxci,filename,para_env,error) + CALL dftd3_c6_param(dispersion_env%c6ab,dispersion_env%maxci,filename,para_env) CALL setr0ab(dispersion_env%r0ab,dispersion_env%rcov,dispersion_env%r2r4) ! the default coordination numbers CALL setcn(dispersion_env%cn) @@ -202,17 +200,17 @@ SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind),element_symbol=symbol,z=elem) ALLOCATE(disp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE (vdw_type) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (xc_vdw_fun_none) disp%defined = .FALSE. CASE (xc_vdw_fun_pairpot) ! setup information on pair potentials SELECT CASE (dispersion_env%pp_type) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (vdw_pairpot_dftd2) CALL cite_reference(Grimme2006) disp%type = dftd2_pp @@ -221,10 +219,10 @@ SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env ! check for local parameters found = .FALSE. IF (PRESENT(pp_section)) THEN - CALL section_vals_val_get(pp_section,"ATOMPARM",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(pp_section,"ATOMPARM",n_rep_val=n_rep) DO i=1,n_rep CALL section_vals_val_get(pp_section,"ATOMPARM", i_rep_val=i,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) IF ( TRIM(tmpstringlist(1)) == TRIM(symbol) ) THEN ! we assume the parameters are in atomic units! READ(tmpstringlist(2),*) disp%c6 @@ -236,30 +234,30 @@ SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env END IF IF ( .NOT. found ) THEN ! check for internal parameters - CALL dftd2_param(elem,disp%c6,disp%vdw_radii,found,error) + CALL dftd2_param(elem,disp%c6,disp%vdw_radii,found) END IF IF ( .NOT. found ) THEN ! check on file INQUIRE (FILE=filename,EXIST=is_available) IF (is_available) THEN NULLIFY(parser) - CALL parser_create(parser,filename,para_env=para_env,error=error) + CALL parser_create(parser,filename,para_env=para_env) DO at_end = .FALSE. - CALL parser_get_next_line(parser,1,at_end,error=error) + CALL parser_get_next_line(parser,1,at_end) IF ( at_end ) EXIT - CALL parser_get_object(parser,aname,error=error) + CALL parser_get_object(parser,aname) IF ( TRIM(aname) == TRIM(symbol) ) THEN - CALL parser_get_object(parser,disp%c6,error=error) + CALL parser_get_object(parser,disp%c6) ! we have to change the units J*nm^6*mol^-1 -> Hartree*Bohr^6 disp%c6 = disp%c6 * 1000._dp*bohr**6/kjmol - CALL parser_get_object(parser,disp%vdw_radii,error=error) + CALL parser_get_object(parser,disp%vdw_radii) disp%vdw_radii = disp%vdw_radii*bohr found = .TRUE. EXIT END IF END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF END IF IF ( found ) THEN @@ -277,27 +275,27 @@ SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env ! Check for coordination numbers IF (PRESENT(pp_section)) THEN - CALL section_vals_val_get(pp_section,"KIND_COORDINATION_NUMBERS", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(pp_section,"KIND_COORDINATION_NUMBERS", n_rep_val=n_rep) IF (n_rep > 0) THEN ALLOCATE(dispersion_env%cnkind(n_rep),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,n_rep CALL section_vals_val_get(pp_section,"KIND_COORDINATION_NUMBERS", i_rep_val=i,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) READ(tmpstringlist(1),*) dispersion_env%cnkind(i)%cnum READ(tmpstringlist(2),*) dispersion_env%cnkind(i)%kind END DO END IF - CALL section_vals_val_get(pp_section,"ATOM_COORDINATION_NUMBERS", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(pp_section,"ATOM_COORDINATION_NUMBERS", n_rep_val=n_rep) IF (n_rep > 0) THEN ALLOCATE(dispersion_env%cnlist(n_rep),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,n_rep CALL section_vals_val_get(pp_section,"ATOM_COORDINATION_NUMBERS", i_rep_val=i,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) nl = SIZE(tmpstringlist) ALLOCATE(dispersion_env%cnlist(i)%atom(nl-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) dispersion_env%cnlist(i)%natom = nl-1 READ(tmpstringlist(1),*) dispersion_env%cnlist(i)%cnum DO j=1,nl-1 @@ -315,8 +313,8 @@ SUBROUTINE qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env "Please provide a valid set of parameters through the input section or "//& "through an external file! "//& CPSourceFileRef,& - error=error,failure=failure) - CALL set_qs_kind(qs_kind_set(ikind),dispersion=disp,error=error) + failure=failure) + CALL set_qs_kind(qs_kind_set(ikind),dispersion=disp) END DO CALL timestop(handle) @@ -329,12 +327,10 @@ END SUBROUTINE qs_dispersion_pairpot_init !> \brief ... !> \param scaling ... !> \param vdw_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scaling_init(scaling,vdw_section,error) + SUBROUTINE qs_scaling_init(scaling,vdw_section) REAL(KIND=dp), INTENT(inout) :: scaling TYPE(section_vals_type), POINTER :: vdw_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scaling_init', & routineP = moduleN//':'//routineN @@ -344,14 +340,14 @@ SUBROUTINE qs_scaling_init(scaling,vdw_section,error) failure = .FALSE. - CALL section_vals_val_get(vdw_section,"PAIR_POTENTIAL%REFERENCE_FUNCTIONAL",c_val=functional,error=error) + CALL section_vals_val_get(vdw_section,"PAIR_POTENTIAL%REFERENCE_FUNCTIONAL",c_val=functional) SELECT CASE (TRIM(functional)) CASE DEFAULT ! unknown functional CALL cp_unimplemented_error(fromWhere=routineP, & message="No DFT-D2 s6 value available for this functional:"//TRIM(functional), & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE ("BLYP") scaling = 1.20_dp CASE ("B3LYP") @@ -380,12 +376,10 @@ END SUBROUTINE qs_scaling_init !> \param sr6 ... !> \param s8 ... !> \param vdw_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scaling_dftd3(s6,sr6,s8,vdw_section,error) + SUBROUTINE qs_scaling_dftd3(s6,sr6,s8,vdw_section) REAL(KIND=dp), INTENT(inout) :: s6, sr6, s8 TYPE(section_vals_type), POINTER :: vdw_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scaling_dftd3', & routineP = moduleN//':'//routineN @@ -395,7 +389,7 @@ SUBROUTINE qs_scaling_dftd3(s6,sr6,s8,vdw_section,error) failure = .FALSE. - CALL section_vals_val_get(vdw_section,"PAIR_POTENTIAL%REFERENCE_FUNCTIONAL",c_val=functional,error=error) + CALL section_vals_val_get(vdw_section,"PAIR_POTENTIAL%REFERENCE_FUNCTIONAL",c_val=functional) ! values for different functionals from: ! http://www.thch.uni-bonn.de/tc/downloads/DFT-D3/functionals.html @@ -404,7 +398,7 @@ SUBROUTINE qs_scaling_dftd3(s6,sr6,s8,vdw_section,error) ! unknown functional CALL cp_unimplemented_error(fromWhere=routineP, & message="No DFT-D3 values available for this functional:"//TRIM(functional), & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE ("B1B95") s6 = 1.000_dp sr6 = 1.613_dp @@ -622,12 +616,10 @@ END SUBROUTINE qs_scaling_dftd3 !> \param s8 ... !> \param a2 ... !> \param vdw_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scaling_dftd3bj(s6,a1,s8,a2,vdw_section,error) + SUBROUTINE qs_scaling_dftd3bj(s6,a1,s8,a2,vdw_section) REAL(KIND=dp), INTENT(inout) :: s6, a1, s8, a2 TYPE(section_vals_type), POINTER :: vdw_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scaling_dftd3bj', & routineP = moduleN//':'//routineN @@ -637,7 +629,7 @@ SUBROUTINE qs_scaling_dftd3bj(s6,a1,s8,a2,vdw_section,error) failure = .FALSE. - CALL section_vals_val_get(vdw_section,"PAIR_POTENTIAL%REFERENCE_FUNCTIONAL",c_val=functional,error=error) + CALL section_vals_val_get(vdw_section,"PAIR_POTENTIAL%REFERENCE_FUNCTIONAL",c_val=functional) ! values for different functionals from: ! http://www.thch.uni-bonn.de/tc/downloads/DFT-D3/functionalsbj.html @@ -646,7 +638,7 @@ SUBROUTINE qs_scaling_dftd3bj(s6,a1,s8,a2,vdw_section,error) ! unknown functional CALL cp_unimplemented_error(fromWhere=routineP, & message="No DFT-D3(BJ) values available for this functional:"//TRIM(functional), & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE ("B1B95") s6 = 1.0000_dp a1 = 0.2092_dp @@ -852,15 +844,13 @@ END SUBROUTINE qs_scaling_dftd3bj !> \param dispersion_env ... !> \param energy ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_forces,error) + SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_dispersion_type), POINTER :: dispersion_env REAL(KIND=dp), INTENT(OUT) :: energy LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_dispersion_pairpot', & routineP = moduleN//':'//routineN @@ -928,7 +918,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f NULLIFY (atomic_kind_set,qs_kind_set,sab_cn,sab_vdw) CALL get_qs_env(qs_env=qs_env, atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& - cell=cell, virial=virial, para_env=para_env, atprop=atprop, error=error) + cell=cell, virial=virial, para_env=para_env, atprop=atprop) debugx = dispersion_env%verbose debugall = debugx @@ -936,10 +926,10 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f nkind = SIZE(atomic_kind_set) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF(ASSOCIATED(dispersion_env%dftd_section)) THEN unit_nr = cp_print_key_unit_nr(logger,dispersion_env%dftd_section,"PRINT_DFTD",& - extension=".dftd",error=error) + extension=".dftd") ELSE unit_nr = -1 END IF @@ -948,9 +938,9 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f atenergy = atprop%energy IF (atenergy) THEN NULLIFY (particle_set) - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE(particle_set) - CALL atprop_array_init(atprop%atevdw,natom,error) + CALL atprop_array_init(atprop%atevdw,natom) atener => atprop%atevdw END IF atstress = atprop%stress @@ -971,13 +961,13 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f END IF NULLIFY (particle_set) - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE(particle_set) IF (calculate_forces .OR. debugall) THEN NULLIFY (force) - CALL get_qs_env(qs_env=qs_env,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,force=force) ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, atom_of_kind=atom_of_kind,kind_of=kind_of) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) IF (use_virial .AND. debugall) THEN @@ -986,15 +976,15 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f ELSE IF ( ( dispersion_env%pp_type == vdw_pairpot_dftd3 .OR.& dispersion_env%pp_type == vdw_pairpot_dftd3bj) .AND. dispersion_env%doabc ) THEN ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, atom_of_kind=atom_of_kind,kind_of=kind_of) END IF ALLOCATE (dodisp(nkind),ghost(nkind),atomnumber(nkind),c6d2(nkind),radd2(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), z=za) - CALL get_qs_kind(qs_kind_set(ikind), dispersion=disp_a, ghost=ghost_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind), dispersion=disp_a, ghost=ghost_a) dodisp(ikind)=disp_a%defined ghost(ikind)=ghost_a atomnumber(ikind)=za @@ -1002,7 +992,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f radd2(ikind)=disp_a%vdw_radii END DO ALLOCATE (rcpbc(3,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO iatom=1,natom rcpbc(:,iatom) = pbc(particle_set(iatom)%r(:),cell) END DO @@ -1058,18 +1048,18 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f END IF ! Calculate coordination numbers NULLIFY (particle_set) - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE (particle_set) ALLOCATE (cnumbers(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) cnumbers = 0._dp IF(calculate_forces .OR. debugall) THEN ALLOCATE (dcnum(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) dcnum(:)%neighbors=0 DO iatom=1,natom ALLOCATE (dcnum(iatom)%nlist(10),dcnum(iatom)%dvals(10),dcnum(iatom)%rik(3,10),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO END IF sab_cn => dispersion_env%sab_cn @@ -1118,7 +1108,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f CALL mp_sum(cnumbers,para_env%group) ! for parallel runs we have to update dcnum on all processors IF(calculate_forces .OR. debugall) THEN - CALL dcnum_distribute(dcnum,para_env,error) + CALL dcnum_distribute(dcnum,para_env) IF (unit_nr>0 .AND. SIZE(dcnum)>0) THEN WRITE(unit_nr,*) WRITE(unit_nr,*) " ATOM Coordination Neighbors" @@ -1149,7 +1139,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f IF (dispersion_env%c9cnst) THEN IF (unit_nr>0) WRITE(unit_nr,*) " Use reference coordination numbers for C9 term" ALLOCATE (cnumfix(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) cnumfix = 0._dp ! first use the default values DO iatom=1,natom @@ -1162,8 +1152,8 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f DO i=1,SIZE(dispersion_env%cnkind) ikind=dispersion_env%cnkind(i)%kind cnum=dispersion_env%cnkind(i)%cnum - CPPrecondition(ikind <= nkind,cp_failure_level,routineP,error,failure) - CPPrecondition(ikind > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(ikind <= nkind,cp_failure_level,routineP,failure) + CPPrecondition(ikind > 0,cp_failure_level,routineP,failure) CALL get_atomic_kind(atomic_kind_set(ikind), natom=na,atom_list=atom_list) DO ia=1,na iatom=atom_list(ia) @@ -1226,11 +1216,11 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(ikind)%dispersion(:,atom_a) = force(ikind)%dispersion(:,atom_a) - fdij(:) force(jkind)%dispersion(:,atom_b) = force(jkind)%dispersion(:,atom_b) + fdij(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rij) END IF IF(atstress) THEN - CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rij, error) - CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rij, error) + CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rij) + CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rij) END IF END IF IF(atenergy) THEN @@ -1264,7 +1254,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f ELSE CALL cp_unimplemented_error(fromWhere=routineP, & message="Unknown DFT-D3 damping function:", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF evdw = evdw - e6 - e8 e6tot = e6tot - e6 @@ -1286,7 +1276,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f ELSE CALL cp_unimplemented_error(fromWhere=routineP, & message="Unknown DFT-D3 damping function:", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF fdij(:) = (de6+de8) * rij(:)/dr * fac atom_a = atom_of_kind(iatom) @@ -1294,11 +1284,11 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(ikind)%dispersion(:,atom_a) = force(ikind)%dispersion(:,atom_a) - fdij(:) force(jkind)%dispersion(:,atom_b) = force(jkind)%dispersion(:,atom_b) + fdij(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rij) END IF IF(atstress) THEN - CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rij, error) - CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rij, error) + CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rij) + CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rij) END IF ! forces from the r-dependence of the coordination numbers IF(idmp==1) THEN @@ -1316,7 +1306,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f ELSE CALL cp_unimplemented_error(fromWhere=routineP, & message="Unknown DFT-D3 damping function:", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DO i=1,dcnum(iatom)%neighbors katom=dcnum(iatom)%nlist(i) @@ -1328,11 +1318,11 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(ikind)%dispersion(:,atom_a) = force(ikind)%dispersion(:,atom_a) - fdik(:) force(kkind)%dispersion(:,atom_c) = force(kkind)%dispersion(:,atom_c) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF IF(atstress) THEN - CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdik, rik, error) - CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdik, rik, error) + CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdik, rik) + CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdik, rik) END IF END DO DO i=1,dcnum(jatom)%neighbors @@ -1345,17 +1335,17 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(jkind)%dispersion(:,atom_b) = force(jkind)%dispersion(:,atom_b) - fdik(:) force(kkind)%dispersion(:,atom_c) = force(kkind)%dispersion(:,atom_c) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF IF(atstress) THEN - CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdik, rik, error) - CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdik, rik, error) + CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdik, rik) + CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdik, rik) END IF END DO END IF IF (dispersion_env%doabc) THEN CALL get_iterator_info(nl_iterator,cell=cell_b) - hashb = cellhash(cell_b,ncell,error) + hashb = cellhash(cell_b,ncell) is000 = (ALL(cell_b == 0)) rb0(:) = MATMUL(cell%hmat,cell_b) ra(:) = pbc(particle_set(iatom)%r(:),cell) @@ -1367,7 +1357,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f cell_c(1) = icx cell_c(2) = icy cell_c(3) = icz - hashc = cellhash(cell_c,ncell,error) + hashc = cellhash(cell_c,ncell) IF(is000 .AND. (ALL(cell_c == 0))) THEN ! CASE 1: all atoms in (000), use only ordered triples kstart=MAX(jatom+1,iatom+1) @@ -1453,11 +1443,11 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(ikind)%dispersion(:,atom_a) = force(ikind)%dispersion(:,atom_a) - fdij(:) force(jkind)%dispersion(:,atom_b) = force(jkind)%dispersion(:,atom_b) + fdij(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rab, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rab) END IF IF(atstress) THEN - CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rab, error) - CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rab, error) + CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rab) + CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rab) END IF fdij(:) = de91*rbc(:)/r2bc fdij(:) = fdij(:) + dea*s1*s2*s3 * rbc(:)/r2bc @@ -1465,11 +1455,11 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(jkind)%dispersion(:,atom_b) = force(jkind)%dispersion(:,atom_b) - fdij(:) force(kkind)%dispersion(:,atom_c) = force(kkind)%dispersion(:,atom_c) + fdij(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rbc, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rbc) END IF IF(atstress) THEN - CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rbc, error) - CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdij, rbc, error) + CALL virial_pair_force ( atstr(:,:,jatom), -0.5_dp, fdij, rbc) + CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdij, rbc) END IF fdij(:) = de91*rca(:)/r2ca fdij(:) = fdij(:) + dea*s1*s2*s3 * rca(:)/r2ca @@ -1477,11 +1467,11 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(kkind)%dispersion(:,atom_c) = force(kkind)%dispersion(:,atom_c) - fdij(:) force(ikind)%dispersion(:,atom_a) = force(ikind)%dispersion(:,atom_a) + fdij(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rca, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdij, rca) END IF IF(atstress) THEN - CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rca, error) - CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdij, rca, error) + CALL virial_pair_force ( atstr(:,:,iatom), -0.5_dp, fdij, rca) + CALL virial_pair_force ( atstr(:,:,katom), -0.5_dp, fdij, rca) END IF IF (.NOT. dispersion_env%c9cnst) THEN ! forces from the r-dependence of the coordination numbers @@ -1501,7 +1491,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(ikind)%dispersion(:,atom_a) = force(ikind)%dispersion(:,atom_a) - fdik(:) force(lkind)%dispersion(:,atom_d) = force(lkind)%dispersion(:,atom_d) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF END DO DO i=1,dcnum(jatom)%neighbors @@ -1516,7 +1506,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(jkind)%dispersion(:,atom_b) = force(jkind)%dispersion(:,atom_b) - fdik(:) force(lkind)%dispersion(:,atom_d) = force(lkind)%dispersion(:,atom_d) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF END DO @@ -1535,7 +1525,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(jkind)%dispersion(:,atom_b) = force(jkind)%dispersion(:,atom_b) - fdik(:) force(lkind)%dispersion(:,atom_d) = force(lkind)%dispersion(:,atom_d) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF END DO DO i=1,dcnum(katom)%neighbors @@ -1550,7 +1540,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(kkind)%dispersion(:,atom_c) = force(kkind)%dispersion(:,atom_c) - fdik(:) force(lkind)%dispersion(:,atom_d) = force(lkind)%dispersion(:,atom_d) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF END DO @@ -1569,7 +1559,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(kkind)%dispersion(:,atom_c) = force(kkind)%dispersion(:,atom_c) - fdik(:) force(lkind)%dispersion(:,atom_d) = force(lkind)%dispersion(:,atom_d) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF END DO DO i=1,dcnum(iatom)%neighbors @@ -1584,7 +1574,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f force(ikind)%dispersion(:,atom_a) = force(ikind)%dispersion(:,atom_a) - fdik(:) force(lkind)%dispersion(:,atom_d) = force(lkind)%dispersion(:,atom_d) + fdik(:) IF ( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fdik, rik) END IF END DO END IF @@ -1611,7 +1601,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f ! Long range correction (atomic contributions not implemented) IF (dispersion_env%lrc) THEN ALLOCATE (cnkind(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) cnkind = 0._dp ! first use the default values DO ikind=1,nkind @@ -1627,11 +1617,11 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f END IF DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=na, z=za) - CALL get_qs_kind(qs_kind_set(ikind), dispersion=disp_a, ghost=ghost_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind), dispersion=disp_a, ghost=ghost_a) IF (.NOT.disp_a%defined .OR. ghost_a) CYCLE DO jkind=1,nkind CALL get_atomic_kind(atomic_kind_set(jkind), natom=nb, z=zb) - CALL get_qs_kind(qs_kind_set(jkind), dispersion=disp_b, ghost=ghost_b,error=error) + CALL get_qs_kind(qs_kind_set(jkind), dispersion=disp_b, ghost=ghost_b) IF (.NOT.disp_b%defined .OR. ghost_b) CYCLE CALL getc6(maxc,max_elem,dispersion_env%c6ab,dispersion_env%maxci,za,zb,& cnkind(ikind),cnkind(jkind),dispersion_env%k3,cc6ab,dcc6aba,dcc6abb) @@ -1641,7 +1631,7 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f IF (dispersion_env%doabc) THEN DO kkind=1,nkind CALL get_atomic_kind(atomic_kind_set(kkind), natom=nc, z=zc) - CALL get_qs_kind(qs_kind_set(kkind), dispersion=disp_c, ghost=ghost_c,error=error) + CALL get_qs_kind(qs_kind_set(kkind), dispersion=disp_c, ghost=ghost_c) IF (.NOT.disp_c%defined .OR. ghost_c) CYCLE CALL getc6(maxc,max_elem,dispersion_env%c6ab,dispersion_env%maxci,za,zb,& cnkind(ikind),cnkind(jkind),dispersion_env%k3,cc6ab,dcc6aba,dcc6abb) @@ -1661,25 +1651,25 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f END DO END IF DEALLOCATE (cnkind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF IF ( dispersion_env%pp_type == vdw_pairpot_dftd3 .OR.& dispersion_env%pp_type == vdw_pairpot_dftd3bj ) THEN DEALLOCATE (cnumbers,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF ( dispersion_env%doabc .AND. dispersion_env%c9cnst ) THEN DEALLOCATE (cnumfix,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(calculate_forces .OR. debugall) THEN DO iatom=1,natom DEALLOCATE (dcnum(iatom)%nlist,dcnum(iatom)%dvals,dcnum(iatom)%rik,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE (dcnum,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -1751,15 +1741,15 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env,dispersion_env,energy,calculate_f IF(calculate_forces .OR. debugall .OR. dispersion_env%doabc) THEN DEALLOCATE(atom_of_kind,kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (dodisp,ghost,atomnumber,rcpbc,radd2,c6d2,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(ASSOCIATED(dispersion_env%dftd_section)) THEN CALL cp_print_key_finished_output(unit_nr,logger,dispersion_env%dftd_section,& - "PRINT_DFTD", error=error) + "PRINT_DFTD") END IF END IF @@ -1772,12 +1762,10 @@ END SUBROUTINE calculate_dispersion_pairpot !> \brief ... !> \param cell ... !> \param ncell ... -!> \param error ... !> \retval hash ... ! ***************************************************************************** - FUNCTION cellhash(cell,ncell,error) RESULT(hash) + FUNCTION cellhash(cell,ncell) RESULT(hash) INTEGER, DIMENSION(3), INTENT(IN) :: cell, ncell - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: hash CHARACTER(LEN=*), PARAMETER :: routineN = 'cellhash', & @@ -1787,7 +1775,7 @@ FUNCTION cellhash(cell,ncell,error) RESULT(hash) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ALL(ABS(cell)<=ncell),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(ABS(cell)<=ncell),cp_failure_level,routineP,failure) ix = cell(1) IF (ix/=0) THEN @@ -1815,14 +1803,12 @@ END FUNCTION cellhash !> \param c6 ... !> \param r ... !> \param found ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dftd2_param(z,c6,r,found,error) + SUBROUTINE dftd2_param(z,c6,r,found) INTEGER, INTENT(in) :: z REAL(KIND=dp), INTENT(inout) :: c6, r LOGICAL, INTENT(inout) :: found - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dftd2_param', & routineP = moduleN//':'//routineN @@ -1872,15 +1858,13 @@ END SUBROUTINE dftd2_param !> \param maxci ... !> \param filename ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dftd3_c6_param(c6ab,maxci,filename,para_env,error) + SUBROUTINE dftd3_c6_param(c6ab,maxci,filename,para_env) REAL(KIND=dp), DIMENSION(:, :, :, :, :) :: c6ab INTEGER, DIMENSION(:) :: maxci CHARACTER(LEN=*) :: filename TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dftd3_c6_param', & routineP = moduleN//':'//routineN @@ -1899,7 +1883,7 @@ SUBROUTINE dftd3_c6_param(c6ab,maxci,filename,para_env,error) CALL mp_bcast(nl,para_env%source,para_env%group) CALL mp_bcast(nlines,para_env%source,para_env%group) ALLOCATE(pars(nl),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(para_env%source==para_env%mepos) THEN READ(funit,*) pars(1:nl) CALL close_file(unit_number=funit) @@ -1927,7 +1911,7 @@ SUBROUTINE dftd3_c6_param(c6ab,maxci,filename,para_env,error) ENDDO DEALLOCATE(pars,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE dftd3_c6_param @@ -2973,13 +2957,11 @@ END SUBROUTINE getc6 !> \brief ... !> \param dcnum ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dcnum_distribute(dcnum,para_env,error) + SUBROUTINE dcnum_distribute(dcnum,para_env) TYPE(dcnum_type), DIMENSION(:) :: dcnum TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dcnum_distribute', & routineP = moduleN//':'//routineN @@ -3000,7 +2982,7 @@ SUBROUTINE dcnum_distribute(dcnum,para_env,error) natom=SIZE(dcnum) !pack my dcnum data ALLOCATE (nloc(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ia=1,natom nloc(ia)=dcnum(ia)%neighbors END DO @@ -3008,7 +2990,7 @@ SUBROUTINE dcnum_distribute(dcnum,para_env,error) ntmax = ntot CALL mp_max(ntmax,group) ALLOCATE (list(ntmax),dvals(ntmax),rik(3,ntmax),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) list=0 dvals=0._dp rik=0._dp @@ -3048,9 +3030,9 @@ SUBROUTINE dcnum_distribute(dcnum,para_env,error) END DO END DO DEALLOCATE (nloc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (list,dvals,rik,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE dcnum_distribute diff --git a/src/qs_dispersion_types.F b/src/qs_dispersion_types.F index 288d1268a0..a2d9f46d97 100644 --- a/src/qs_dispersion_types.F +++ b/src/qs_dispersion_types.F @@ -115,12 +115,10 @@ MODULE qs_dispersion_types ! ***************************************************************************** !> \brief ... !> \param dispersion_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dispersion_release (dispersion_env,error) + SUBROUTINE qs_dispersion_release (dispersion_env) TYPE(qs_dispersion_type), POINTER :: dispersion_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dispersion_release', & routineP = moduleN//':'//routineN @@ -131,46 +129,46 @@ SUBROUTINE qs_dispersion_release (dispersion_env,error) IF (ASSOCIATED(dispersion_env%maxci)) THEN ! DFT-D3 arrays DEALLOCATE(dispersion_env%maxci, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(dispersion_env%c6ab, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(dispersion_env%r0ab, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(dispersion_env%rcov, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(dispersion_env%r2r4, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(dispersion_env%cn, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) IF (ASSOCIATED(dispersion_env%cnkind)) THEN DEALLOCATE(dispersion_env%cnkind, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(dispersion_env%cnlist)) THEN DO i=1,SIZE(dispersion_env%cnlist) DEALLOCATE(dispersion_env%cnlist(i)%atom, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END DO DEALLOCATE(dispersion_env%cnlist, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF ! vdD-DF IF (ASSOCIATED(dispersion_env%q_mesh)) THEN DEALLOCATE(dispersion_env%q_mesh, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(dispersion_env%kernel)) THEN DEALLOCATE(dispersion_env%kernel, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(dispersion_env%d2phi_dk2)) THEN DEALLOCATE(dispersion_env%d2phi_dk2, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(dispersion_env%d2y_dx2)) THEN DEALLOCATE(dispersion_env%d2y_dx2, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ! neighborlists IF (ASSOCIATED(dispersion_env%sab_vdw)) THEN @@ -178,18 +176,18 @@ SUBROUTINE qs_dispersion_release (dispersion_env,error) CALL deallocate_neighbor_list_set(dispersion_env%sab_vdw(iab)%neighbor_list_set) END DO DEALLOCATE(dispersion_env%sab_vdw,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(dispersion_env%sab_cn)) THEN DO iab=1,SIZE(dispersion_env%sab_cn) CALL deallocate_neighbor_list_set(dispersion_env%sab_cn(iab)%neighbor_list_set) END DO DEALLOCATE(dispersion_env%sab_cn,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(dispersion_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF diff --git a/src/qs_dispersion_utils.F b/src/qs_dispersion_utils.F index 44b640f70d..d9febbe4f7 100644 --- a/src/qs_dispersion_utils.F +++ b/src/qs_dispersion_utils.F @@ -52,12 +52,10 @@ MODULE qs_dispersion_utils !> \brief ... !> \param dispersion_env ... !> \param xc_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dispersion_env_set(dispersion_env,xc_section,error) + SUBROUTINE qs_dispersion_env_set(dispersion_env,xc_section) TYPE(qs_dispersion_type), POINTER :: dispersion_env TYPE(section_vals_type), POINTER :: xc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_dispersion_env_set', & routineP = moduleN//':'//routineN @@ -67,7 +65,7 @@ SUBROUTINE qs_dispersion_env_set(dispersion_env,xc_section,error) TYPE(section_vals_type), POINTER :: nl_section, pp_section, & vdw_section, xc_fun_section - CPPrecondition(ASSOCIATED(dispersion_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dispersion_env),cp_failure_level,routineP,failure) failure = .FALSE. ! set general defaults @@ -82,24 +80,24 @@ SUBROUTINE qs_dispersion_env_set(dispersion_env,xc_section,error) NULLIFY(dispersion_env%sab_vdw,dispersion_env%sab_cn) NULLIFY(dispersion_env%dftd_section) NULLIFY(vdw_section,xc_fun_section) - vdw_section => section_vals_get_subs_vals(xc_section,"vdw_potential",error=error) - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",error=error) - CALL section_vals_val_get(vdw_section, "POTENTIAL_TYPE", i_val=dispersion_env%type, error=error) + vdw_section => section_vals_get_subs_vals(xc_section,"vdw_potential") + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") + CALL section_vals_val_get(vdw_section, "POTENTIAL_TYPE", i_val=dispersion_env%type) IF ( dispersion_env%type == xc_vdw_fun_pairpot ) THEN NULLIFY(pp_section) - pp_section => section_vals_get_subs_vals(vdw_section,"PAIR_POTENTIAL",error=error) - CALL section_vals_val_get(pp_section, "VERBOSE_OUTPUT", l_val=dispersion_env%verbose, error=error) - CALL section_vals_val_get(pp_section, "TYPE", i_val=dispersion_env%pp_type, error=error) + pp_section => section_vals_get_subs_vals(vdw_section,"PAIR_POTENTIAL") + CALL section_vals_val_get(pp_section, "VERBOSE_OUTPUT", l_val=dispersion_env%verbose) + CALL section_vals_val_get(pp_section, "TYPE", i_val=dispersion_env%pp_type) IF ( dispersion_env%pp_type == vdw_pairpot_dftd2 ) THEN ! functional parameters for Grimme D2 type - CALL section_vals_val_get(pp_section, "EXP_PRE", r_val=dispersion_env%exp_pre, error=error) - CALL section_vals_val_get(pp_section, "SCALING" ,explicit=explicit,error=error) + CALL section_vals_val_get(pp_section, "EXP_PRE", r_val=dispersion_env%exp_pre) + CALL section_vals_val_get(pp_section, "SCALING" ,explicit=explicit) IF ( .NOT. explicit ) THEN - CALL section_vals_val_get(pp_section, "REFERENCE_FUNCTIONAL" ,explicit=exfun,error=error) - CPPostcondition(exfun,cp_failure_level,routineP,error,failure) - CALL qs_scaling_init(dispersion_env%scaling,vdw_section,error) + CALL section_vals_val_get(pp_section, "REFERENCE_FUNCTIONAL" ,explicit=exfun) + CPPostcondition(exfun,cp_failure_level,routineP,failure) + CALL qs_scaling_init(dispersion_env%scaling,vdw_section) ELSE - CALL section_vals_val_get(pp_section, "SCALING", r_val=dispersion_env%scaling, error=error) + CALL section_vals_val_get(pp_section, "SCALING", r_val=dispersion_env%scaling) END IF ELSE dispersion_env%exp_pre=0._dp @@ -108,28 +106,28 @@ SUBROUTINE qs_dispersion_env_set(dispersion_env,xc_section,error) IF ( dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & dispersion_env%pp_type == vdw_pairpot_dftd3bj ) THEN ! functional parameters for Grimme DFT-D3 type - CALL section_vals_val_get(pp_section, "EPS_CN", r_val=dispersion_env%eps_cn, error=error) - CALL section_vals_val_get(pp_section, "CALCULATE_C9_TERM" ,l_val=dispersion_env%doabc,error=error) - CALL section_vals_val_get(pp_section, "REFERENCE_C9_TERM" ,l_val=dispersion_env%c9cnst,error=error) - CALL section_vals_val_get(pp_section, "LONG_RANGE_CORRECTION" ,l_val=dispersion_env%lrc,error=error) + CALL section_vals_val_get(pp_section, "EPS_CN", r_val=dispersion_env%eps_cn) + CALL section_vals_val_get(pp_section, "CALCULATE_C9_TERM" ,l_val=dispersion_env%doabc) + CALL section_vals_val_get(pp_section, "REFERENCE_C9_TERM" ,l_val=dispersion_env%c9cnst) + CALL section_vals_val_get(pp_section, "LONG_RANGE_CORRECTION" ,l_val=dispersion_env%lrc) IF ( dispersion_env%pp_type == vdw_pairpot_dftd3 ) THEN - CALL section_vals_val_get(pp_section, "D3_SCALING" ,explicit=explicit,error=error) + CALL section_vals_val_get(pp_section, "D3_SCALING" ,explicit=explicit) ELSE IF ( dispersion_env%pp_type == vdw_pairpot_dftd3bj ) THEN - CALL section_vals_val_get(pp_section, "D3BJ_SCALING" ,explicit=explicit,error=error) + CALL section_vals_val_get(pp_section, "D3BJ_SCALING" ,explicit=explicit) END IF IF ( .NOT. explicit ) THEN - CALL section_vals_val_get(pp_section, "REFERENCE_FUNCTIONAL" ,explicit=exfun,error=error) - CPPostcondition(exfun,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(pp_section, "REFERENCE_FUNCTIONAL" ,explicit=exfun) + CPPostcondition(exfun,cp_failure_level,routineP,failure) IF ( dispersion_env%pp_type == vdw_pairpot_dftd3 ) THEN - CALL qs_scaling_dftd3(dispersion_env%s6,dispersion_env%sr6,dispersion_env%s8,vdw_section,error) + CALL qs_scaling_dftd3(dispersion_env%s6,dispersion_env%sr6,dispersion_env%s8,vdw_section) ELSE IF ( dispersion_env%pp_type == vdw_pairpot_dftd3bj ) THEN CALL qs_scaling_dftd3bj(dispersion_env%s6,dispersion_env%a1,dispersion_env%s8,& - dispersion_env%a2,vdw_section,error) + dispersion_env%a2,vdw_section) END IF ELSE IF ( dispersion_env%pp_type == vdw_pairpot_dftd3 ) THEN ! zero damping - CALL section_vals_val_get(pp_section, "D3_SCALING", r_vals=scal, error=error) + CALL section_vals_val_get(pp_section, "D3_SCALING", r_vals=scal) dispersion_env%s6 =scal(1) dispersion_env%sr6 =scal(2) dispersion_env%s8 =scal(3) @@ -137,7 +135,7 @@ SUBROUTINE qs_dispersion_env_set(dispersion_env,xc_section,error) dispersion_env%a2 =0.0_dp ELSE IF ( dispersion_env%pp_type == vdw_pairpot_dftd3bj ) THEN ! BJ damping - CALL section_vals_val_get(pp_section, "D3BJ_SCALING", r_vals=scal, error=error) + CALL section_vals_val_get(pp_section, "D3BJ_SCALING", r_vals=scal) dispersion_env%s6 =scal(1) dispersion_env%a1 =scal(2) dispersion_env%s8 =scal(3) @@ -153,21 +151,21 @@ SUBROUTINE qs_dispersion_env_set(dispersion_env,xc_section,error) dispersion_env%a2=0._dp dispersion_env%eps_cn=0._dp END IF - CALL section_vals_val_get(pp_section, "R_CUTOFF", r_val=dispersion_env%rc_disp, error=error) + CALL section_vals_val_get(pp_section, "R_CUTOFF", r_val=dispersion_env%rc_disp) CALL section_vals_val_get(pp_section,"PARAMETER_FILE_NAME",& - c_val=dispersion_env%parameter_file_name,error=error) + c_val=dispersion_env%parameter_file_name) ! set DFTD section for output handling dispersion_env%dftd_section => pp_section ELSE IF ( dispersion_env%type == xc_vdw_fun_nonloc ) THEN NULLIFY(nl_section) - nl_section => section_vals_get_subs_vals(vdw_section,"NON_LOCAL",error=error) - CALL section_vals_val_get(nl_section, "VERBOSE_OUTPUT", l_val=dispersion_env%verbose, error=error) + nl_section => section_vals_get_subs_vals(vdw_section,"NON_LOCAL") + CALL section_vals_val_get(nl_section, "VERBOSE_OUTPUT", l_val=dispersion_env%verbose) CALL section_vals_val_get(nl_section,"KERNEL_FILE_NAME",& - c_val=dispersion_env%kernel_file_name,error=error) - CALL section_vals_val_get(nl_section, "TYPE", i_val=dispersion_env%nl_type, error=error) - CALL section_vals_val_get(nl_section, "CUTOFF", r_val=dispersion_env%pw_cutoff, error=error) + c_val=dispersion_env%kernel_file_name) + CALL section_vals_val_get(nl_section, "TYPE", i_val=dispersion_env%nl_type) + CALL section_vals_val_get(nl_section, "CUTOFF", r_val=dispersion_env%pw_cutoff) dispersion_env%pw_cutoff = 0.5_dp * dispersion_env%pw_cutoff - CALL section_vals_val_get(nl_section, "PARAMETERS", r_vals=params, error=error) + CALL section_vals_val_get(nl_section, "PARAMETERS", r_vals=params) dispersion_env%b_value = params(1) dispersion_env%c_value = params(2) END IF @@ -180,13 +178,11 @@ END SUBROUTINE qs_dispersion_env_set !> \param qs_env ... !> \param dispersion_env ... !> \param ounit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_write_dispersion(qs_env,dispersion_env,ounit,error) + SUBROUTINE qs_write_dispersion(qs_env,dispersion_env,ounit) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_dispersion_type), POINTER :: dispersion_env INTEGER, INTENT(in), OPTIONAL :: ounit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_write_dispersion', & routineP = moduleN//':'//routineN @@ -208,11 +204,11 @@ SUBROUTINE qs_write_dispersion(qs_env,dispersion_env,ounit,error) output_unit = ounit ELSE NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") output_unit = cp_print_key_unit_nr(logger,dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log",error=error) + "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log") END IF IF (output_unit>0) THEN @@ -225,11 +221,11 @@ SUBROUTINE qs_write_dispersion(qs_env,dispersion_env,ounit,error) WRITE (output_unit, fmt="(' vdW POTENTIAL| ',T35,'Cutoff Radius [Bohr]:',T73,F8.2)") dispersion_env%rc_disp WRITE (output_unit, fmt="(' vdW POTENTIAL| ',T35,'Scaling Factor:',T73,F8.4)") dispersion_env%scaling WRITE (output_unit, fmt="(' vdW POTENTIAL| ',T35,'Exp Prefactor for Damping:',T73,F8.1)") dispersion_env%exp_pre - CALL get_qs_env(qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,error=error) + CALL get_qs_env(qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set) nkind = SIZE(atomic_kind_set) DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind),element_symbol=symbol) - CALL get_qs_kind(qs_kind_set(ikind),dispersion=disp, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dispersion=disp) IF ( disp%defined ) THEN WRITE (output_unit, fmt="(' vdW PARAMETER| ',T18,'Atom=',A2,"//& "T28,'C6[J*nm^6*mol^-1]=',F8.4,T63,'r(vdW)[A]=',F8.4)") & @@ -271,7 +267,7 @@ SUBROUTINE qs_write_dispersion(qs_env,dispersion_env,ounit,error) SELECT CASE (dispersion_env%nl_type) CASE DEFAULT ! unknown functional - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (vdw_nl_DRSLL) WRITE (output_unit, & fmt="(' vdW POTENTIAL| ','DRSLL Functional: M. Dion et al, PRL 92: 246401 (2004)')") @@ -297,7 +293,7 @@ SUBROUTINE qs_write_dispersion(qs_env,dispersion_env,ounit,error) END IF IF(.NOT.PRESENT(ounit)) THEN CALL cp_print_key_finished_output(output_unit,logger,dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",error=error) + "PRINT%DFT_CONTROL_PARAMETERS") END IF END SUBROUTINE qs_write_dispersion diff --git a/src/qs_efield_berry.F b/src/qs_efield_berry.F index 9aa8eb093f..47b8f286c4 100644 --- a/src/qs_efield_berry.F +++ b/src/qs_efield_berry.F @@ -102,13 +102,11 @@ MODULE qs_efield_berry !> \param qs_env ... !> \param just_energy ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_efield_berry_phase(qs_env,just_energy,calculate_forces,error) + SUBROUTINE qs_efield_berry_phase(qs_env,just_energy,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: just_energy, calculate_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_efield_berry_phase', & routineP = moduleN//':'//routineN @@ -121,14 +119,14 @@ SUBROUTINE qs_efield_berry_phase(qs_env,just_energy,calculate_forces,error) NULLIFY(dft_control) CALL get_qs_env(qs_env,s_mstruct_changed=s_mstruct_changed,& - dft_control=dft_control,error=error) + dft_control=dft_control) IF(dft_control%apply_period_efield)THEN - IF(s_mstruct_changed) CALL qs_efield_integrals(qs_env,error) + IF(s_mstruct_changed) CALL qs_efield_integrals(qs_env) IF(dft_control%period_efield%displacement_field) THEN - CALL qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) + CALL qs_dispfield_derivatives(qs_env,just_energy,calculate_forces) ELSE - CALL qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) + CALL qs_efield_derivatives(qs_env,just_energy,calculate_forces) END IF END IF @@ -139,12 +137,10 @@ END SUBROUTINE qs_efield_berry_phase ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_efield_integrals (qs_env,error) + SUBROUTINE qs_efield_integrals (qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_efield_integrals', & routineP = moduleN//':'//routineN @@ -160,30 +156,30 @@ SUBROUTINE qs_efield_integrals (qs_env,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,error=error) + CALL get_qs_env(qs_env=qs_env,dft_control=dft_control) NULLIFY (matrix_s) - CALL get_qs_env(qs_env=qs_env,efield=efield,cell=cell,matrix_s=matrix_s,error=error) - CALL init_efield_matrices(efield,error) + CALL get_qs_env(qs_env=qs_env,efield=efield,cell=cell,matrix_s=matrix_s) + CALL init_efield_matrices(efield) ALLOCATE(cosmat(3),sinmat(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,3 ALLOCATE(cosmat(i)%matrix,sinmat(i)%matrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(cosmat(i)%matrix,error=error) - CALL cp_dbcsr_init(sinmat(i)%matrix, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(cosmat(i)%matrix) + CALL cp_dbcsr_init(sinmat(i)%matrix) - CALL cp_dbcsr_copy(cosmat(i)%matrix,matrix_s(1)%matrix,'COS MAT',error=error) - CALL cp_dbcsr_copy(sinmat(i)%matrix,matrix_s(1)%matrix,'SIN MAT',error=error) - CALL cp_dbcsr_set(cosmat(i)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(sinmat(i)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_copy(cosmat(i)%matrix,matrix_s(1)%matrix,'COS MAT') + CALL cp_dbcsr_copy(sinmat(i)%matrix,matrix_s(1)%matrix,'SIN MAT') + CALL cp_dbcsr_set(cosmat(i)%matrix,0.0_dp) + CALL cp_dbcsr_set(sinmat(i)%matrix,0.0_dp) kvec(:) = twopi*cell%h_inv(i,:) - CALL build_berry_moment_matrix(qs_env,cosmat(i)%matrix,sinmat(i)%matrix,kvec,error) + CALL build_berry_moment_matrix(qs_env,cosmat(i)%matrix,sinmat(i)%matrix,kvec) END DO CALL set_efield_matrices(efield=efield,cosmat=cosmat,sinmat=sinmat) - CALL set_qs_env(qs_env=qs_env,efield=efield,error=error) + CALL set_qs_env(qs_env=qs_env,efield=efield) CALL timestop(handle) END SUBROUTINE qs_efield_integrals @@ -193,12 +189,10 @@ END SUBROUTINE qs_efield_integrals !> \param qs_env ... !> \param just_energy ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) + SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: just_energy, calculate_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_efield_derivatives', & routineP = moduleN//':'//routineN @@ -271,10 +265,10 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) NULLIFY(dft_control,cell,particle_set) CALL get_qs_env(qs_env,dft_control=dft_control,cell=cell,& - particle_set=particle_set,virial=virial,error=error) + particle_set=particle_set,virial=virial) NULLIFY(qs_kind_set,efield,para_env,sab_orb) CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set,& - efield=efield,energy=energy,para_env=para_env,sab_orb=sab_orb,error=error) + efield=efield,energy=energy,para_env=para_env,sab_orb=sab_orb) ! calculate stress only if forces requested also use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -283,7 +277,7 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Stress tensor for periodic E-field not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF fieldpol=dft_control%period_efield%polarisation @@ -297,15 +291,15 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) ! nuclear contribution natom = SIZE(particle_set) IF (calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,force=force) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,atom_of_kind=atom_of_kind) END IF zi(:) = CMPLX ( 1._dp, 0._dp, dp ) DO ia = 1,natom CALL get_atomic_kind(particle_set(ia)%atomic_kind,kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind),core_charge=charge,error=error) + CALL get_qs_kind(qs_kind_set(ikind),core_charge=charge) ria = particle_set(ia)%r ria = pbc(ria,cell) DO idir = 1, 3 @@ -323,88 +317,88 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) END IF IF (use_virial) THEN IF(para_env%mepos==0) & - CALL virial_pair_force ( virial%pv_virial, 1.0_dp, forcea, ria, error) + CALL virial_pair_force ( virial%pv_virial, 1.0_dp, forcea, ria) END IF END DO qi = AIMAG(LOG(zi)) ! check uniform occupation NULLIFY(mos) - CALL get_qs_env(qs_env=qs_env,mos=mos,error=error) + CALL get_qs_env(qs_env=qs_env,mos=mos) DO ispin = 1,dft_control%nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,maxocc=occ,uniform_occupation=uniform) IF (.NOT.uniform) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments for non uniform MOs' occupation numbers not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO NULLIFY (mo_derivs) - CALL get_qs_env(qs_env=qs_env,mo_derivs=mo_derivs,error=error) + CALL get_qs_env(qs_env=qs_env,mo_derivs=mo_derivs) ! initialize all work matrices needed ALLOCATE ( op_fm_set( 2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( opvec( 2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( eigrmat( dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( inv_mat( dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( inv_work(2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( mo_derivs_tmp(SIZE(mo_derivs)), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( mo_coeff_tmp(SIZE(mo_derivs)), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Allocate temp matrices for the wavefunction derivatives DO ispin = 1, dft_control%nspins NULLIFY(tmp_fm_struct,mo_coeff) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff,nao=nao,nmo=nmo) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmo,& - ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create (mo_derivs_tmp(ispin)%matrix,mo_coeff%matrix_struct,error=error) - CALL cp_fm_create (mo_coeff_tmp(ispin)%matrix,mo_coeff%matrix_struct,error=error) - CALL copy_dbcsr_to_fm(mo_derivs(ispin)%matrix,mo_derivs_tmp(ispin)%matrix,error=error) + ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context) + CALL cp_fm_create (mo_derivs_tmp(ispin)%matrix,mo_coeff%matrix_struct) + CALL cp_fm_create (mo_coeff_tmp(ispin)%matrix,mo_coeff%matrix_struct) + CALL copy_dbcsr_to_fm(mo_derivs(ispin)%matrix,mo_derivs_tmp(ispin)%matrix) DO i = 1, SIZE(op_fm_set,1) - CALL cp_fm_create (opvec(i,ispin)%matrix,mo_coeff%matrix_struct,error=error) + CALL cp_fm_create (opvec(i,ispin)%matrix,mo_coeff%matrix_struct) NULLIFY(op_fm_set(i,ispin)%matrix) - CALL cp_fm_create (op_fm_set(i,ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create (inv_work(i,ispin)%matrix,op_fm_set(i,ispin)%matrix%matrix_struct,error=error) + CALL cp_fm_create (op_fm_set(i,ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create (inv_work(i,ispin)%matrix,op_fm_set(i,ispin)%matrix%matrix_struct) END DO - CALL cp_cfm_create (eigrmat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct,error=error) - CALL cp_cfm_create (inv_mat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_cfm_create (eigrmat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct) + CALL cp_cfm_create (inv_mat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct) + CALL cp_fm_struct_release(tmp_fm_struct) END DO ! temp matrices for force calculation IF(calculate_forces)THEN NULLIFY (matrix_s) - CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s,error=error) + CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s) ALLOCATE(tempmat(2,dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins ALLOCATE(tempmat(1,ispin)%matrix,tempmat(2,ispin)%matrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tempmat(1,ispin)%matrix,error=error) - CALL cp_dbcsr_init(tempmat(2,ispin)%matrix, error=error) - CALL cp_dbcsr_copy(tempmat(1,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT',error=error) - CALL cp_dbcsr_copy(tempmat(2,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT',error=error) - CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tempmat(1,ispin)%matrix) + CALL cp_dbcsr_init(tempmat(2,ispin)%matrix) + CALL cp_dbcsr_copy(tempmat(1,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT') + CALL cp_dbcsr_copy(tempmat(2,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT') + CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp) + CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp) END DO ! integration - CALL get_qs_kind_set(qs_kind_set,maxco=ldab,maxsgf=lsab,error=error) + CALL get_qs_kind_set(qs_kind_set,maxco=ldab,maxsgf=lsab) ALLOCATE(cosab(ldab,ldab),sinab(ldab,ldab),work(ldab,ldab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dcosab(ldab,ldab,3),dsinab(ldab,ldab,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) lsab = MAX(ldab,lsab) DO i=1,3 ALLOCATE(dcost(i,1)%block(lsab,lsab),dsint(i,1)%block(lsab,lsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dcost(i,2)%block(lsab,lsab),dsint(i,2)%block(lsab,lsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO END IF @@ -421,24 +415,24 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) DO ispin=1, dft_control%nspins ! spin IF(mos(ispin)%mo_set%use_mo_coeff_b)THEN CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,mo_coeff_b=mo_coeff_b,nmo=nmo) - CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff_tmp(ispin)%matrix,error=error) + CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff_tmp(ispin)%matrix) ELSE CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,mo_coeff=mo_coeff_tmp(ispin)%matrix,nmo=nmo) END IF - CALL cp_dbcsr_sm_fm_multiply(cosmat,mo_coeff_tmp(ispin)%matrix,opvec(1,ispin)%matrix,ncol=nmo,error=error) + CALL cp_dbcsr_sm_fm_multiply(cosmat,mo_coeff_tmp(ispin)%matrix,opvec(1,ispin)%matrix,ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff_tmp(ispin)%matrix,opvec(1,ispin)%matrix,0.0_dp,& - op_fm_set(1,ispin)%matrix,error=error) - CALL cp_dbcsr_sm_fm_multiply(sinmat,mo_coeff_tmp(ispin)%matrix,opvec(2,ispin)%matrix,ncol=nmo,error=error) + op_fm_set(1,ispin)%matrix) + CALL cp_dbcsr_sm_fm_multiply(sinmat,mo_coeff_tmp(ispin)%matrix,opvec(2,ispin)%matrix,ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff_tmp(ispin)%matrix,opvec(2,ispin)%matrix,0.0_dp,& - op_fm_set(2,ispin)%matrix,error=error) + op_fm_set(2,ispin)%matrix) ENDDO !second step invert C^T S_berry C zdet = one DO ispin = 1, dft_control%nspins - CALL cp_cfm_add_fm(zero,eigrmat(ispin)%matrix,one,op_fm_set(1,ispin)%matrix,error) - CALL cp_cfm_add_fm(one,eigrmat(ispin)%matrix,-zone,op_fm_set(2,ispin)%matrix,error) - CALL cp_cfm_set_all(inv_mat(ispin)%matrix,zero,one,error) - CALL cp_cfm_solve(eigrmat(ispin)%matrix,inv_mat(ispin)%matrix,zdeta,error) + CALL cp_cfm_add_fm(zero,eigrmat(ispin)%matrix,one,op_fm_set(1,ispin)%matrix) + CALL cp_cfm_add_fm(one,eigrmat(ispin)%matrix,-zone,op_fm_set(2,ispin)%matrix) + CALL cp_cfm_set_all(inv_mat(ispin)%matrix,zero,one) + CALL cp_cfm_solve(eigrmat(ispin)%matrix,inv_mat(ispin)%matrix,zdeta) zdet = zdet*zdeta END DO zi(idir) = zdet**occ @@ -452,9 +446,9 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) inv_work(2,ispin)%matrix%local_data(:,:)=AIMAG(inv_mat(ispin)%matrix%local_data(:,:)) CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,nmo=nmo) CALL cp_gemm("N","N",nao,nmo,nmo,focc,opvec(1,ispin)%matrix,inv_work(2,ispin)%matrix,& - 1.0_dp,mo_derivs_tmp(ispin)%matrix,error) + 1.0_dp,mo_derivs_tmp(ispin)%matrix) CALL cp_gemm("N","N",nao,nmo,nmo,-focc,opvec(2,ispin)%matrix,inv_work(1,ispin)%matrix,& - 1.0_dp,mo_derivs_tmp(ispin)%matrix,error) + 1.0_dp,mo_derivs_tmp(ispin)%matrix) END DO END IF @@ -467,25 +461,25 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) ! calculate: C [C^T S_berry C]^(-1) C^T ! Store this matrix in DBCSR form (only S overlap blocks) DO ispin=1,dft_control%nspins - CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp) + CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp) CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,nmo=nmo) CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mo_coeff_tmp(ispin)%matrix,inv_work(1,ispin)%matrix,0.0_dp,& - opvec(1,ispin)%matrix,error=error) + opvec(1,ispin)%matrix) CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mo_coeff_tmp(ispin)%matrix,inv_work(2,ispin)%matrix,0.0_dp,& - opvec(2,ispin)%matrix,error=error) + opvec(2,ispin)%matrix) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=tempmat(1,ispin)%matrix,& - matrix_v=opvec(1,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo,error=error) + matrix_v=opvec(1,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=tempmat(2,ispin)%matrix,& - matrix_v=opvec(2,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo,error=error) + matrix_v=opvec(2,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo) END DO ! Calculation of derivative integrals (da|eikr|b) and (a|eikr|db) ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -591,16 +585,16 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) NULLIFY (rblock,iblock) CALL cp_dbcsr_get_block_p(matrix=tempmat(1,ispin)%matrix,& row=irow,col=icol,BLOCK=rblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=tempmat(2,ispin)%matrix,& row=irow,col=icol,BLOCK=iblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) n1 = SIZE(rblock,1) n2 = SIZE(rblock,2) - CPPostcondition(SIZE(iblock,1)==n1,cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(iblock,2)==n2,cp_failure_level,routineP,error,failure) - CPPostcondition(lsab>=n1,cp_failure_level,routineP,error,failure) - CPPostcondition(lsab>=n2,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(iblock,1)==n1,cp_failure_level,routineP,failure) + CPPostcondition(SIZE(iblock,2)==n2,cp_failure_level,routineP,failure) + CPPostcondition(lsab>=n1,cp_failure_level,routineP,failure) + CPPostcondition(lsab>=n2,cp_failure_level,routineP,failure) IF (iatom <= jatom) THEN DO i=1,3 forcea(i) = forcea(i) + SUM(rblock(1:n1,1:n2)*dsint(i,1)%block(1:n1,1:n2)) & @@ -621,14 +615,14 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) force(jkind)%efield(1:3,atom_b)=force(jkind)%efield(1:3,atom_b)-fab*fpolvec(idir)*forceb(1:3) IF (use_virial) THEN f0 = -fab*fpolvec(idir) - CALL virial_pair_force ( virial%pv_virial, f0, forcea, ra, error) - CALL virial_pair_force ( virial%pv_virial, f0, forceb, rb, error) + CALL virial_pair_force ( virial%pv_virial, f0, forcea, ra) + CALL virial_pair_force ( virial%pv_virial, f0, forceb, rb) END IF END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -669,7 +663,7 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) IF(.NOT.just_energy) THEN ! Add the result to mo_derivativs DO ispin=1, dft_control%nspins - CALL copy_fm_to_dbcsr(mo_derivs_tmp(ispin)%matrix,mo_derivs(ispin)%matrix,error=error) + CALL copy_fm_to_dbcsr(mo_derivs_tmp(ispin)%matrix,mo_derivs(ispin)%matrix) END DO IF (use_virial) THEN ti = 0.0_dp @@ -687,36 +681,36 @@ SUBROUTINE qs_efield_derivatives(qs_env,just_energy,calculate_forces,error) END IF DO ispin = 1, dft_control%nspins - CALL cp_cfm_release(eigrmat(ispin)%matrix,error=error) - CALL cp_cfm_release(inv_mat(ispin)%matrix,error=error) - CALL cp_fm_release(mo_derivs_tmp(ispin)%matrix,error=error) - CALL cp_fm_release(mo_coeff_tmp(ispin)%matrix,error=error) + CALL cp_cfm_release(eigrmat(ispin)%matrix) + CALL cp_cfm_release(inv_mat(ispin)%matrix) + CALL cp_fm_release(mo_derivs_tmp(ispin)%matrix) + CALL cp_fm_release(mo_coeff_tmp(ispin)%matrix) DO i = 1, SIZE ( op_fm_set, 1 ) - CALL cp_fm_release(opvec(i,ispin)%matrix,error=error) - CALL cp_fm_release(op_fm_set(i,ispin)%matrix,error=error) - CALL cp_fm_release(inv_work(i,ispin)%matrix,error=error) + CALL cp_fm_release(opvec(i,ispin)%matrix) + CALL cp_fm_release(op_fm_set(i,ispin)%matrix) + CALL cp_fm_release(inv_work(i,ispin)%matrix) END DO END DO DEALLOCATE(inv_mat,inv_work,op_fm_set,opvec,eigrmat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mo_coeff_tmp,mo_derivs_tmp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(calculate_forces)THEN DO ikind=1,SIZE(atomic_kind_set) CALL mp_sum(force(ikind)%efield,para_env%group) END DO DEALLOCATE(atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cosab,sinab,work,dcosab,dsinab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,3 DEALLOCATE(dcost(i,1)%block,dsint(i,1)%block,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(dcost(i,2)%block,dsint(i,2)%block,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO - CALL cp_dbcsr_deallocate_matrix_set(tempmat,error) + CALL cp_dbcsr_deallocate_matrix_set(tempmat) END IF CALL timestop(handle) @@ -727,12 +721,10 @@ END SUBROUTINE qs_efield_derivatives !> \param qs_env ... !> \param just_energy ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) + SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: just_energy, calculate_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_dispfield_derivatives', & routineP = moduleN//':'//routineN @@ -805,10 +797,10 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) NULLIFY(dft_control,cell,particle_set) CALL get_qs_env(qs_env,dft_control=dft_control,cell=cell,& - particle_set=particle_set,virial=virial,error=error) + particle_set=particle_set,virial=virial) NULLIFY(qs_kind_set,efield,para_env,sab_orb) CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set,& - efield=efield,energy=energy,para_env=para_env,sab_orb=sab_orb,error=error) + efield=efield,energy=energy,para_env=para_env,sab_orb=sab_orb) ! calculate stress only if forces requested also use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -817,7 +809,7 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Stress tensor for periodic D-field not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF fieldpol=dft_control%period_efield%polarisation @@ -830,18 +822,18 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) ! nuclear contribution to polarization natom = SIZE(particle_set) IF (calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,force=force) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,atom_of_kind=atom_of_kind) ALLOCATE (force_tmp(natom,3,3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) force_tmp = 0.0_dp END IF zi(:) = CMPLX ( 1._dp, 0._dp, dp ) DO ia = 1,natom CALL get_atomic_kind(particle_set(ia)%atomic_kind,kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind),core_charge=charge,error=error) + CALL get_qs_kind(qs_kind_set(ikind),core_charge=charge) ria = particle_set(ia)%r ria = pbc(ria,cell) DO idir = 1, 3 @@ -862,83 +854,83 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) ! check uniform occupation NULLIFY(mos) - CALL get_qs_env(qs_env=qs_env,mos=mos,error=error) + CALL get_qs_env(qs_env=qs_env,mos=mos) DO ispin = 1,dft_control%nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,maxocc=occ,uniform_occupation=uniform) IF (.NOT.uniform) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments for non uniform MOs' occupation numbers not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO ! initialize all work matrices needed NULLIFY (mo_derivs) - CALL get_qs_env(qs_env=qs_env,mo_derivs=mo_derivs,error=error) + CALL get_qs_env(qs_env=qs_env,mo_derivs=mo_derivs) ALLOCATE ( op_fm_set( 2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( opvec( 2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( eigrmat( dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( inv_mat( dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( inv_work(2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( mo_derivs_tmp(3,SIZE(mo_derivs)), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( mo_coeff_tmp(SIZE(mo_derivs)), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Allocate temp matrices for the wavefunction derivatives DO ispin = 1, dft_control%nspins NULLIFY(tmp_fm_struct,mo_coeff) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff,nao=nao,nmo=nmo) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmo,& - ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create (mo_coeff_tmp(ispin)%matrix,mo_coeff%matrix_struct,error=error) + ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context) + CALL cp_fm_create (mo_coeff_tmp(ispin)%matrix,mo_coeff%matrix_struct) DO i=1,3 - CALL cp_fm_create (mo_derivs_tmp(i,ispin)%matrix,mo_coeff%matrix_struct,error=error) - CALL cp_fm_set_all (matrix=mo_derivs_tmp(i,ispin)%matrix,alpha=0.0_dp,error=error) + CALL cp_fm_create (mo_derivs_tmp(i,ispin)%matrix,mo_coeff%matrix_struct) + CALL cp_fm_set_all (matrix=mo_derivs_tmp(i,ispin)%matrix,alpha=0.0_dp) END DO DO i = 1, SIZE(op_fm_set,1) - CALL cp_fm_create (opvec(i,ispin)%matrix,mo_coeff%matrix_struct,error=error) + CALL cp_fm_create (opvec(i,ispin)%matrix,mo_coeff%matrix_struct) NULLIFY(op_fm_set(i,ispin)%matrix) - CALL cp_fm_create (op_fm_set(i,ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create (inv_work(i,ispin)%matrix,op_fm_set(i,ispin)%matrix%matrix_struct,error=error) + CALL cp_fm_create (op_fm_set(i,ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create (inv_work(i,ispin)%matrix,op_fm_set(i,ispin)%matrix%matrix_struct) END DO - CALL cp_cfm_create (eigrmat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct,error=error) - CALL cp_cfm_create (inv_mat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_cfm_create (eigrmat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct) + CALL cp_cfm_create (inv_mat(ispin)%matrix,op_fm_set(1,ispin)%matrix%matrix_struct) + CALL cp_fm_struct_release(tmp_fm_struct) END DO ! temp matrices for force calculation IF(calculate_forces)THEN NULLIFY (matrix_s) - CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s,error=error) + CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s) ALLOCATE(tempmat(2,dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins ALLOCATE(tempmat(1,ispin)%matrix,tempmat(2,ispin)%matrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tempmat(1,ispin)%matrix,error=error) - CALL cp_dbcsr_init(tempmat(2,ispin)%matrix, error=error) - CALL cp_dbcsr_copy(tempmat(1,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT',error=error) - CALL cp_dbcsr_copy(tempmat(2,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT',error=error) - CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tempmat(1,ispin)%matrix) + CALL cp_dbcsr_init(tempmat(2,ispin)%matrix) + CALL cp_dbcsr_copy(tempmat(1,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT') + CALL cp_dbcsr_copy(tempmat(2,ispin)%matrix,matrix_s(1)%matrix,'TEMPMAT') + CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp) + CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp) END DO ! integration - CALL get_qs_kind_set(qs_kind_set,maxco=ldab,maxsgf=lsab,error=error) + CALL get_qs_kind_set(qs_kind_set,maxco=ldab,maxsgf=lsab) ALLOCATE(cosab(ldab,ldab),sinab(ldab,ldab),work(ldab,ldab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dcosab(ldab,ldab,3),dsinab(ldab,ldab,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) lsab = MAX(lsab,ldab) DO i=1,3 ALLOCATE(dcost(i,1)%block(lsab,lsab),dsint(i,1)%block(lsab,lsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dcost(i,2)%block(lsab,lsab),dsint(i,2)%block(lsab,lsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO END IF @@ -953,24 +945,24 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) DO ispin=1, dft_control%nspins ! spin IF(mos(ispin)%mo_set%use_mo_coeff_b)THEN CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,mo_coeff_b=mo_coeff_b,nmo=nmo) - CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff_tmp(ispin)%matrix,error=error) + CALL copy_dbcsr_to_fm(mo_coeff_b,mo_coeff_tmp(ispin)%matrix) ELSE CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,mo_coeff=mo_coeff_tmp(ispin)%matrix,nmo=nmo) END IF - CALL cp_dbcsr_sm_fm_multiply(cosmat,mo_coeff_tmp(ispin)%matrix,opvec(1,ispin)%matrix,ncol=nmo,error=error) + CALL cp_dbcsr_sm_fm_multiply(cosmat,mo_coeff_tmp(ispin)%matrix,opvec(1,ispin)%matrix,ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff_tmp(ispin)%matrix,opvec(1,ispin)%matrix,0.0_dp,& - op_fm_set(1,ispin)%matrix,error=error) - CALL cp_dbcsr_sm_fm_multiply(sinmat,mo_coeff_tmp(ispin)%matrix,opvec(2,ispin)%matrix,ncol=nmo,error=error) + op_fm_set(1,ispin)%matrix) + CALL cp_dbcsr_sm_fm_multiply(sinmat,mo_coeff_tmp(ispin)%matrix,opvec(2,ispin)%matrix,ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff_tmp(ispin)%matrix,opvec(2,ispin)%matrix,0.0_dp,& - op_fm_set(2,ispin)%matrix,error=error) + op_fm_set(2,ispin)%matrix) ENDDO !second step invert C^T S_berry C zdet = one DO ispin = 1, dft_control%nspins - CALL cp_cfm_add_fm(zero,eigrmat(ispin)%matrix,one,op_fm_set(1,ispin)%matrix,error) - CALL cp_cfm_add_fm(one,eigrmat(ispin)%matrix,-zone,op_fm_set(2,ispin)%matrix,error) - CALL cp_cfm_set_all(inv_mat(ispin)%matrix,zero,one,error) - CALL cp_cfm_solve(eigrmat(ispin)%matrix,inv_mat(ispin)%matrix,zdeta,error) + CALL cp_cfm_add_fm(zero,eigrmat(ispin)%matrix,one,op_fm_set(1,ispin)%matrix) + CALL cp_cfm_add_fm(one,eigrmat(ispin)%matrix,-zone,op_fm_set(2,ispin)%matrix) + CALL cp_cfm_set_all(inv_mat(ispin)%matrix,zero,one) + CALL cp_cfm_solve(eigrmat(ispin)%matrix,inv_mat(ispin)%matrix,zdeta) zdet = zdet*zdeta END DO zi(idir) = zdet**occ @@ -985,9 +977,9 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) DO i=1,3 focc = hmat(idir,i) CALL cp_gemm("N","N",nao,nmo,nmo,focc,opvec(1,ispin)%matrix,inv_work(2,ispin)%matrix,& - 1.0_dp,mo_derivs_tmp(idir,ispin)%matrix,error) + 1.0_dp,mo_derivs_tmp(idir,ispin)%matrix) CALL cp_gemm("N","N",nao,nmo,nmo,-focc,opvec(2,ispin)%matrix,inv_work(1,ispin)%matrix,& - 1.0_dp,mo_derivs_tmp(idir,ispin)%matrix,error) + 1.0_dp,mo_derivs_tmp(idir,ispin)%matrix) END DO END DO END IF @@ -1001,25 +993,25 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) ! calculate: C [C^T S_berry C]^(-1) C^T ! Store this matrix in DBCSR form (only S overlap blocks) DO ispin=1,dft_control%nspins - CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(tempmat(1,ispin)%matrix,0.0_dp) + CALL cp_dbcsr_set(tempmat(2,ispin)%matrix,0.0_dp) CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,nmo=nmo) CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mo_coeff_tmp(ispin)%matrix,inv_work(1,ispin)%matrix,0.0_dp,& - opvec(1,ispin)%matrix,error=error) + opvec(1,ispin)%matrix) CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,mo_coeff_tmp(ispin)%matrix,inv_work(2,ispin)%matrix,0.0_dp,& - opvec(2,ispin)%matrix,error=error) + opvec(2,ispin)%matrix) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=tempmat(1,ispin)%matrix,& - matrix_v=opvec(1,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo,error=error) + matrix_v=opvec(1,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=tempmat(2,ispin)%matrix,& - matrix_v=opvec(2,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo,error=error) + matrix_v=opvec(2,ispin)%matrix,matrix_g=mo_coeff_tmp(ispin)%matrix,ncol=nmo) END DO ! Calculation of derivative integrals (da|eikr|b) and (a|eikr|db) ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -1122,16 +1114,16 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) NULLIFY (rblock,iblock) CALL cp_dbcsr_get_block_p(matrix=tempmat(1,ispin)%matrix,& row=irow,col=icol,BLOCK=rblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=tempmat(2,ispin)%matrix,& row=irow,col=icol,BLOCK=iblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) n1 = SIZE(rblock,1) n2 = SIZE(rblock,2) - CPPostcondition(SIZE(iblock,1)==n1,cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(iblock,2)==n2,cp_failure_level,routineP,error,failure) - CPPostcondition(lsab>=n1,cp_failure_level,routineP,error,failure) - CPPostcondition(lsab>=n2,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(iblock,1)==n1,cp_failure_level,routineP,failure) + CPPostcondition(SIZE(iblock,2)==n2,cp_failure_level,routineP,failure) + CPPostcondition(lsab>=n1,cp_failure_level,routineP,failure) + CPPostcondition(lsab>=n2,cp_failure_level,routineP,failure) IF (iatom <= jatom) THEN DO i=1,3 forcea(i) = forcea(i) + SUM(rblock(1:n1,1:n2)*dsint(i,1)%block(1:n1,1:n2)) & @@ -1155,7 +1147,7 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END DO @@ -1207,14 +1199,14 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) END DO ! Add the result to mo_derivativs DO ispin=1, dft_control%nspins - CALL copy_dbcsr_to_fm(mo_derivs(ispin)%matrix,mo_coeff_tmp(ispin)%matrix,error=error) + CALL copy_dbcsr_to_fm(mo_derivs(ispin)%matrix,mo_coeff_tmp(ispin)%matrix) DO idir=1,3 CALL cp_fm_scale_and_add(1.0_dp,mo_coeff_tmp(ispin)%matrix,di(idir),& - mo_derivs_tmp(idir,ispin)%matrix,error) + mo_derivs_tmp(idir,ispin)%matrix) END DO END DO DO ispin=1, dft_control%nspins - CALL copy_fm_to_dbcsr(mo_coeff_tmp(ispin)%matrix,mo_derivs(ispin)%matrix,error=error) + CALL copy_fm_to_dbcsr(mo_coeff_tmp(ispin)%matrix,mo_derivs(ispin)%matrix) END DO END IF @@ -1229,40 +1221,40 @@ SUBROUTINE qs_dispfield_derivatives(qs_env,just_energy,calculate_forces,error) END IF DO ispin = 1, dft_control%nspins - CALL cp_cfm_release(eigrmat(ispin)%matrix,error=error) - CALL cp_cfm_release(inv_mat(ispin)%matrix,error=error) - CALL cp_fm_release(mo_coeff_tmp(ispin)%matrix,error=error) + CALL cp_cfm_release(eigrmat(ispin)%matrix) + CALL cp_cfm_release(inv_mat(ispin)%matrix) + CALL cp_fm_release(mo_coeff_tmp(ispin)%matrix) DO i=1,3 - CALL cp_fm_release(mo_derivs_tmp(i,ispin)%matrix,error=error) + CALL cp_fm_release(mo_derivs_tmp(i,ispin)%matrix) END DO DO i = 1, SIZE ( op_fm_set, 1 ) - CALL cp_fm_release(opvec(i,ispin)%matrix,error=error) - CALL cp_fm_release(op_fm_set(i,ispin)%matrix,error=error) - CALL cp_fm_release(inv_work(i,ispin)%matrix,error=error) + CALL cp_fm_release(opvec(i,ispin)%matrix) + CALL cp_fm_release(op_fm_set(i,ispin)%matrix) + CALL cp_fm_release(inv_work(i,ispin)%matrix) END DO END DO DEALLOCATE(inv_mat,inv_work,op_fm_set,opvec,eigrmat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mo_coeff_tmp,mo_derivs_tmp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(calculate_forces)THEN DO ikind=1,SIZE(atomic_kind_set) CALL mp_sum(force(ikind)%efield,para_env%group) END DO DEALLOCATE(atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (force_tmp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cosab,sinab,work,dcosab,dsinab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,3 DEALLOCATE(dcost(i,1)%block,dsint(i,1)%block,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(dcost(i,2)%block,dsint(i,2)%block,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO - CALL cp_dbcsr_deallocate_matrix_set(tempmat,error) + CALL cp_dbcsr_deallocate_matrix_set(tempmat) END IF CALL timestop(handle) diff --git a/src/qs_efield_local.F b/src/qs_efield_local.F index 47d7625651..3cd77f6ca4 100644 --- a/src/qs_efield_local.F +++ b/src/qs_efield_local.F @@ -76,13 +76,11 @@ MODULE qs_efield_local !> \param qs_env ... !> \param just_energy ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_efield_local_operator(qs_env,just_energy,calculate_forces,error) + SUBROUTINE qs_efield_local_operator(qs_env,just_energy,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: just_energy, calculate_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_efield_local_operator', & routineP = moduleN//':'//routineN @@ -96,12 +94,12 @@ SUBROUTINE qs_efield_local_operator(qs_env,just_energy,calculate_forces,error) NULLIFY(dft_control) CALL get_qs_env(qs_env,s_mstruct_changed=s_mstruct_changed,& - dft_control=dft_control,error=error) + dft_control=dft_control) IF(dft_control%apply_efield)THEN rpoint = 0.0_dp - IF(s_mstruct_changed) CALL qs_efield_integrals(qs_env,rpoint,error) - CALL qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,error) + IF(s_mstruct_changed) CALL qs_efield_integrals(qs_env,rpoint) + CALL qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces) END IF CALL timestop(handle) @@ -112,13 +110,11 @@ END SUBROUTINE qs_efield_local_operator !> \brief ... !> \param qs_env ... !> \param rpoint ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_efield_integrals (qs_env,rpoint,error) + SUBROUTINE qs_efield_integrals (qs_env,rpoint) TYPE(qs_environment_type), POINTER :: qs_env REAL(dp), DIMENSION(3), INTENT(IN) :: rpoint - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_efield_integrals', & routineP = moduleN//':'//routineN @@ -132,24 +128,24 @@ SUBROUTINE qs_efield_integrals (qs_env,rpoint,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,error=error) + CALL get_qs_env(qs_env=qs_env,dft_control=dft_control) NULLIFY (matrix_s) - CALL get_qs_env(qs_env=qs_env,efield=efield,matrix_s=matrix_s,error=error) - CALL init_efield_matrices(efield,error) + CALL get_qs_env(qs_env=qs_env,efield=efield,matrix_s=matrix_s) + CALL init_efield_matrices(efield) ALLOCATE(dipmat(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,3 ALLOCATE(dipmat(i)%matrix,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(dipmat(i)%matrix,error=error) - CALL cp_dbcsr_copy(dipmat(i)%matrix,matrix_s(1)%matrix,'DIP MAT',error=error) - CALL cp_dbcsr_set(dipmat(i)%matrix,0.0_dp,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(dipmat(i)%matrix) + CALL cp_dbcsr_copy(dipmat(i)%matrix,matrix_s(1)%matrix,'DIP MAT') + CALL cp_dbcsr_set(dipmat(i)%matrix,0.0_dp) END DO - CALL build_local_moment_matrix(qs_env,dipmat,1,rpoint,error=error) + CALL build_local_moment_matrix(qs_env,dipmat,1,rpoint) CALL set_efield_matrices(efield=efield,dipmat=dipmat) - CALL set_qs_env(qs_env=qs_env,efield=efield,error=error) + CALL set_qs_env(qs_env=qs_env,efield=efield) CALL timestop(handle) END SUBROUTINE qs_efield_integrals @@ -160,13 +156,11 @@ END SUBROUTINE qs_efield_integrals !> \param rpoint ... !> \param just_energy ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,error) + SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rpoint LOGICAL :: just_energy, calculate_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_efield_mo_derivatives', & routineP = moduleN//':'//routineN @@ -219,10 +213,10 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e NULLIFY(dft_control,cell,particle_set) CALL get_qs_env(qs_env,dft_control=dft_control,cell=cell,& - particle_set=particle_set,error=error) + particle_set=particle_set) NULLIFY(qs_kind_set,efield,para_env,sab_orb) CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set,& - efield=efield,energy=energy,para_env=para_env,sab_orb=sab_orb,error=error) + efield=efield,energy=energy,para_env=para_env,sab_orb=sab_orb) fieldpol=dft_control%efield_fields(1)%efield%polarisation*& dft_control%efield_fields(1)%efield%strength @@ -230,15 +224,15 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e ! nuclear contribution natom = SIZE(particle_set) IF (calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,force=force) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,atom_of_kind=atom_of_kind) END IF ci = 0.0_dp DO ia = 1,natom CALL get_atomic_kind(particle_set(ia)%atomic_kind,kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind),core_charge=charge,error=error) + CALL get_qs_kind(qs_kind_set(ikind),core_charge=charge) ria = particle_set(ia)%r - rpoint ria = pbc(ria,cell) ci(:) = ci(:) + charge * ria(:) @@ -256,11 +250,11 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e ! Energy dipmat => efield%dipmat NULLIFY(rho,matrix_p) - CALL get_qs_env(qs_env=qs_env,rho=rho,error=error) - CALL qs_rho_get(rho,rho_ao=matrix_p,error=error) + CALL get_qs_env(qs_env=qs_env,rho=rho) + CALL qs_rho_get(rho,rho_ao=matrix_p) DO ispin = 1,SIZE(matrix_p) DO idir=1,3 - CALL cp_dbcsr_trace(matrix_p(ispin)%matrix,dipmat(idir)%matrix,tmp,error=error) + CALL cp_dbcsr_trace(matrix_p(ispin)%matrix,dipmat(idir)%matrix,tmp) ener_field = ener_field + fieldpol(idir)*tmp END DO END DO @@ -270,11 +264,11 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e ! Update KS matrix NULLIFY(matrix_ks) - CALL get_qs_env(qs_env=qs_env,matrix_ks=matrix_ks,error=error) + CALL get_qs_env(qs_env=qs_env,matrix_ks=matrix_ks) DO ispin = 1,SIZE(matrix_ks) DO idir=1,3 CALL cp_dbcsr_add(matrix_ks(ispin)%matrix,dipmat(idir)%matrix, & - alpha_scalar=1.0_dp,beta_scalar=fieldpol(idir),error=error) + alpha_scalar=1.0_dp,beta_scalar=fieldpol(idir)) END DO END DO @@ -284,10 +278,10 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e natom = SIZE(particle_set) ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -354,7 +348,7 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e IF(SIZE(matrix_p) > 1) THEN NULLIFY(p_block_b) CALL cp_dbcsr_get_block_p(matrix_p(2)%matrix,irow,icol,p_block_b,found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END IF forcea = 0.0_dp forceb = 0.0_dp @@ -369,7 +363,7 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e ! Calculate the primitive integrals (da|O|b) and (a|O|db) ldab = MAX(ncoa,ncob) ALLOCATE (work(ldab,ldab),pmat(ncoa,ncob),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Decontract P matrix block pmat = 0.0_dp DO i=1,SIZE(matrix_p) @@ -397,10 +391,10 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e CALL dipole_force(la_max(iset),npgfa(iset),zeta(:,iset),rpgfa(:,iset),la_min(iset),& lb_max(jset),npgfb(jset),zetb(:,jset),rpgfb(:,jset),lb_min(jset),& - 1,rac,rbc,pmat,forcea,forceb,error) + 1,rac,rbc,pmat,forcea,forceb) DEALLOCATE (work,pmat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO END DO @@ -414,7 +408,7 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -424,7 +418,7 @@ SUBROUTINE qs_efield_mo_derivatives(qs_env,rpoint,just_energy,calculate_forces,e CALL mp_sum(force(ikind)%efield,para_env%group) END DO DEALLOCATE (atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) diff --git a/src/qs_elec_field.F b/src/qs_elec_field.F index 3f3dac0315..261a719145 100644 --- a/src/qs_elec_field.F +++ b/src/qs_elec_field.F @@ -67,19 +67,17 @@ MODULE qs_elec_field !> \param qs_env ... !> \param matrix_efg ... !> \param rc ... -!> \param error ... !> \date 27.02.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** - SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc,error) + SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_efg REAL(dp), DIMENSION(3), INTENT(IN) :: rc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_efg_matrix', & routineP = moduleN//':'//routineN @@ -125,7 +123,7 @@ SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc,error) NULLIFY(cell,sab_orb,qs_kind_set,particle_set,para_env) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& @@ -133,8 +131,7 @@ SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc,error) neighbor_list_id=neighbor_list_id,& para_env=para_env,& sab_orb=sab_orb,& - cell=cell,& - error=error) + cell=cell) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -143,7 +140,7 @@ SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc,error) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxco,& maxlgto=maxlgto,& - maxsgf=maxsgf,error=error) + maxsgf=maxsgf) ldai = ncoset(maxlgto+2) CALL init_orbital_pointers(ldai) @@ -175,7 +172,7 @@ SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc,error) "basis_set_list",nkind) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -263,7 +260,7 @@ SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc,error) rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),& rpgfb(:,jset),zetb(:,jset),& - rac,rbc,rab,efgab,SIZE(rr_work,1),SIZE(rr_work,2),rr_work,error) + rac,rbc,rab,efgab,SIZE(rr_work,1),SIZE(rr_work,2),rr_work) ! *** Contraction step *** @@ -319,19 +316,19 @@ SUBROUTINE build_efg_matrix(qs_env,matrix_efg,rc,error) ! Print the electric field gradient matrix, if requested IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/EFG",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/EFG"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/EFG",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL cp_dbcsr_write_sparse_matrix(matrix_efg(1)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_efg(2)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_efg(3)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_efg(4)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_efg(5)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_efg(6)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) + CALL cp_dbcsr_write_sparse_matrix(matrix_efg(1)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_write_sparse_matrix(matrix_efg(2)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_write_sparse_matrix(matrix_efg(3)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_write_sparse_matrix(matrix_efg(4)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_write_sparse_matrix(matrix_efg(5)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_write_sparse_matrix(matrix_efg(6)%matrix,4,after,qs_env,para_env,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/EFG", error=error) + "DFT%PRINT%AO_MATRICES/EFG") END IF CALL timestop(handle) diff --git a/src/qs_electric_field_gradient.F b/src/qs_electric_field_gradient.F index e4e5eee5e5..8b73713693 100644 --- a/src/qs_electric_field_gradient.F +++ b/src/qs_electric_field_gradient.F @@ -85,12 +85,10 @@ MODULE qs_electric_field_gradient ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_efg_calc(qs_env,error) + SUBROUTINE qs_efg_calc(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_efg_calc', & routineP = moduleN//':'//routineN @@ -140,7 +138,7 @@ SUBROUTINE qs_efg_calc(qs_env,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() chk_spl = 0.0_dp efg_units = Joule/a_bohr**2/e_charge * 1.e-21_dp @@ -152,19 +150,17 @@ SUBROUTINE qs_efg_calc(qs_env,error) atomic_kind_set=atomic_kind_set,& rho_atom_set=rho_atom_set,pw_env=pw_env,& particle_set=particle_set,para_env=para_env,& - input=input,error=error) + input=input) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") efg_interpolation = section_get_lval(section_vals=dft_section,& - keyword_name="PRINT%ELECTRIC_FIELD_GRADIENT%INTERPOLATION",& - error=error) + keyword_name="PRINT%ELECTRIC_FIELD_GRADIENT%INTERPOLATION") efg_debug = section_get_lval(section_vals=dft_section,& - keyword_name="PRINT%ELECTRIC_FIELD_GRADIENT%DEBUG",& - error=error) + keyword_name="PRINT%ELECTRIC_FIELD_GRADIENT%DEBUG") CALL section_vals_val_get(dft_section,& "PRINT%ELECTRIC_FIELD_GRADIENT%GSPACE_SMOOTHING",& - r_vals=rvals,error=error) + r_vals=rvals) ecut = rvals(1) sigma = rvals(2) IF (ecut == 0._dp .AND. sigma <= 0._dp) THEN @@ -173,21 +169,20 @@ SUBROUTINE qs_efg_calc(qs_env,error) sigma = 1._dp ! not used, just to have vars defined ELSEIF (ecut == -1._dp .AND. sigma == -1._dp) THEN smoothing = .TRUE. - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,dvr2rs%pw, & - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) ecut = 2._dp * dvr2rs%pw%pw_grid%cutoff * 0.875_dp sigma = 2._dp * dvr2rs%pw%pw_grid%cutoff * 0.125_dp - CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2rs%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2rs%pw) ELSE smoothing = .TRUE. END IF - CPPostcondition(ecut > 0._dp,cp_failure_level,routineP,error,failure) - CPPostcondition(sigma > 0._dp,cp_failure_level,routineP,error,failure) + CPPostcondition(ecut > 0._dp,cp_failure_level,routineP,failure) + CPPostcondition(sigma > 0._dp,cp_failure_level,routineP,failure) unit_nr=cp_print_key_unit_nr(logger,dft_section,"PRINT%ELECTRIC_FIELD_GRADIENT",& - extension=".efg",log_filename=.FALSE.,error=error) + extension=".efg",log_filename=.FALSE.) IF (unit_nr > 0) THEN WRITE(unit_nr,"(/,A,/)") " ELECTRIC FIELD GRADIENTS [10**21 V/m^2]" @@ -212,95 +207,88 @@ SUBROUTINE qs_efg_calc(qs_env,error) natom = SIZE(particle_set,1) ALLOCATE (efg_tensor(3,3,natom),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) efg_tensor = 0._dp IF ( efg_debug ) THEN ALLOCATE (efg_pw(3,3,natom),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) efg_pw = 0._dp END IF ALLOCATE (efg_diagval(3,natom),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) efg_diagval = 0._dp ALLOCATE (vh0(1:natom,-2:2),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vh0 = 0._dp ALLOCATE (dvr2(6),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (dvspl(6),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) !prepare calculation CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env,error=error) - IF (gapw) CALL prepare_gapw_den(qs_env,do_rho0=.TRUE.,error=error) + poisson_env=poisson_env) + IF (gapw) CALL prepare_gapw_den(qs_env,do_rho0=.TRUE.) !calculate electrostatic potential CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_gspace%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,rho_tot_gspace%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) - CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho) CALL pw_poisson_solve(poisson_env,rho_tot_gspace%pw,ehartree,& - v_hartree_gspace%pw,error=error) + v_hartree_gspace%pw) ! smoothing of potential - IF ( smoothing ) CALL pw_smoothing(v_hartree_gspace%pw,ecut,sigma,error=error) + IF ( smoothing ) CALL pw_smoothing(v_hartree_gspace%pw,ecut,sigma) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw) DO i=1,3 DO j=1,i ij=(i*(i-1))/2+j CALL pw_pool_create_pw(auxbas_pw_pool,dvr2(ij)%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) - CALL pw_dr2 ( v_hartree_gspace%pw, dvr2(ij)%pw, i, j, error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL pw_dr2 ( v_hartree_gspace%pw, dvr2(ij)%pw, i, j) END DO END DO IF ( .NOT. efg_interpolation ) THEN CALL pw_pool_create_pw(auxbas_pw_pool,structure_factor%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) ELSE interp_section => section_vals_get_subs_vals(dft_section,& - "PRINT%ELECTRIC_FIELD_GRADIENT%INTERPOLATOR",error=error) + "PRINT%ELECTRIC_FIELD_GRADIENT%INTERPOLATOR") CALL section_vals_val_get(interp_section,"aint_precond", & - i_val=aint_precond, error=error) - CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind, error=error) - CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter, error=error) - CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r, error=error) - CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x, error=error) + i_val=aint_precond) + CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind) + CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter) + CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r) + CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x) CALL pw_pool_create_pw(auxbas_pw_pool,dvr2rs%pw, & - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) DO i=1,6 CALL pw_pool_create_pw(auxbas_pw_pool,dvspl(i)%pw, & - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) - CALL pw_transfer ( dvr2(i)%pw, dvr2rs%pw , error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_transfer ( dvr2(i)%pw, dvr2rs%pw) ! calculate spline coefficients CALL pw_spline_precond_create(precond,precond_kind=aint_precond,& - pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.,error=error) - CALL pw_spline_do_precond(precond,dvr2rs%pw,dvspl(i)%pw,error=error) - CALL pw_spline_precond_set_kind(precond,precond_kind,error=error) + pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.) + CALL pw_spline_do_precond(precond,dvr2rs%pw,dvspl(i)%pw) + CALL pw_spline_precond_set_kind(precond,precond_kind) success=find_coeffs(values=dvr2rs%pw,coeffs=dvspl(i)%pw,& linOp=spl3_pbc,preconditioner=precond,pool=auxbas_pw_pool, & - eps_r=eps_r,eps_x=eps_x,max_iter=max_iter, & - error=error) - CPPostconditionNoFail(success,cp_warning_level,routineP,error) - CALL pw_spline_precond_release(precond,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2(i)%pw,error=error) + eps_r=eps_r,eps_x=eps_x,max_iter=max_iter) + CPPostconditionNoFail(success,cp_warning_level,routineP) + CALL pw_spline_precond_release(precond) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2(i)%pw) END DO - CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2rs%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2rs%pw) END IF nkind = SIZE(qs_kind_set) @@ -308,7 +296,7 @@ SUBROUTINE qs_efg_calc(qs_env,error) DO ikind = 1,nkind NULLIFY(atom_list) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list,natom=natomkind) - CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom,error=error) + CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom) DO iat = 1,natomkind iatom = atom_list(iat) ra = particle_set(iatom)%r @@ -316,21 +304,21 @@ SUBROUTINE qs_efg_calc(qs_env,error) DO i=1,3 DO j=1,i ij=(i*(i-1))/2+j - efg_val = Eval_Interp_Spl3_pbc(ra,dvspl(ij)%pw,error) + efg_val = Eval_Interp_Spl3_pbc(ra,dvspl(ij)%pw) efg_tensor(i,j,iatom)=-efg_val efg_tensor(j,i,iatom)=efg_tensor(i,j,iatom) IF ( efg_debug ) THEN chk_spl = chk_spl + efg_val + & - SUM(Eval_d_Interp_Spl3_pbc(ra,dvspl(ij)%pw,error)) + SUM(Eval_d_Interp_Spl3_pbc(ra,dvspl(ij)%pw)) END IF END DO END DO ELSE - CALL pw_structure_factor(structure_factor%pw,ra,error=error) + CALL pw_structure_factor(structure_factor%pw,ra) DO i=1,3 DO j=1,i ij=(i*(i-1))/2+j - efg_tensor(i,j,iatom)=-pw_integral_ab(dvr2(ij)%pw,structure_factor%pw,error=error) + efg_tensor(i,j,iatom)=-pw_integral_ab(dvr2(ij)%pw,structure_factor%pw) efg_tensor(j,i,iatom)=efg_tensor(i,j,iatom) END DO END DO @@ -343,7 +331,7 @@ SUBROUTINE qs_efg_calc(qs_env,error) IF( paw_atom) THEN CALL vlimit_atom(para_env,vh0,rho_atom_set,qs_kind_set(ikind),& - atom_list,natomkind,nspins,error) + atom_list,natomkind,nspins) DO iat = 1,natomkind iatom = atom_list(iat) efg_tensor(1,1,iatom)=efg_tensor(1,1,iatom) & @@ -409,32 +397,32 @@ SUBROUTINE qs_efg_calc(qs_env,error) END IF ENDDO - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw) IF ( .NOT. efg_interpolation ) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,structure_factor%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,structure_factor%pw) DO i=1,6 - CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dvr2(i)%pw) END DO ELSE DO i=1,6 - CALL pw_pool_give_back_pw(auxbas_pw_pool,dvspl(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dvspl(i)%pw) END DO END IF DEALLOCATE (efg_tensor,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF ( efg_debug ) THEN DEALLOCATE (efg_pw,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (vh0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (dvr2,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (dvspl,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -449,10 +437,9 @@ END SUBROUTINE qs_efg_calc !> \param atom_list ... !> \param natom ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** SUBROUTINE vlimit_atom(para_env,vlimit,rho_atom_set,qs_kind,& - atom_list,natom,nspins,error) + atom_list,natom,nspins) ! calculate : Limit(r->0) V_hartree(r)/r^2 @@ -464,7 +451,6 @@ SUBROUTINE vlimit_atom(para_env,vlimit,rho_atom_set,qs_kind,& TYPE(qs_kind_type), INTENT(IN) :: qs_kind INTEGER, DIMENSION(:), INTENT(IN) :: atom_list INTEGER, INTENT(IN) :: natom, nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vlimit_atom', & routineP = moduleN//':'//routineN @@ -493,7 +479,7 @@ SUBROUTINE vlimit_atom(para_env,vlimit,rho_atom_set,qs_kind,& NULLIFY(lmin,lmax,npgf,zet,my_CG,coeff) CALL get_qs_kind(qs_kind=qs_kind, basis_set=orb_basis,& - paw_proj_set=paw_proj,harmonics=harmonics, error=error) + paw_proj_set=paw_proj,harmonics=harmonics) CALL get_gto_basis_set(gto_basis_set=orb_basis,lmax=lmax,lmin=lmin,& maxl=maxl,npgf=npgf,nset=nset,zet=zet,& @@ -513,17 +499,17 @@ SUBROUTINE vlimit_atom(para_env,vlimit,rho_atom_set,qs_kind,& my_CG => harmonics%my_CG ALLOCATE(CPC_sphere(nsoset(maxl),nsoset(maxl)),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) m1s = 0 DO iset1 = 1,nset m2s = 0 DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local,error) - CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local) + CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,failure) n1s = nsoset(lmax(iset1)) DO ipgf1 = 1,npgf(iset1) @@ -533,7 +519,7 @@ SUBROUTINE vlimit_atom(para_env,vlimit,rho_atom_set,qs_kind,& iso1_first = o2nindex(iso1_first) iso1_last = o2nindex(iso1_last) i1 = iso1_last - iso1_first + 1 - CPPrecondition(size1==i1,cp_failure_level,routineP,error,failure) + CPPrecondition(size1==i1,cp_failure_level,routineP,failure) i1 = nsoset(lmin(iset1)-1)+1 n2s=nsoset(lmax(iset2)) @@ -544,7 +530,7 @@ SUBROUTINE vlimit_atom(para_env,vlimit,rho_atom_set,qs_kind,& iso2_first = o2nindex(iso2_first) iso2_last = o2nindex(iso2_last) i2 = iso2_last - iso2_first + 1 - CPPrecondition(size2==i2,cp_failure_level,routineP,error,failure) + CPPrecondition(size2==i2,cp_failure_level,routineP,failure) i2 = nsoset(lmin(iset2)-1)+1 zet12 = zet(ipgf1,iset1)+zet(ipgf2,iset2) @@ -606,9 +592,9 @@ SUBROUTINE vlimit_atom(para_env,vlimit,rho_atom_set,qs_kind,& CALL mp_sum(vlimit,para_env%group) DEALLOCATE(CPC_sphere,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cg_list,cg_n_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE vlimit_atom diff --git a/src/qs_energy.F b/src/qs_energy.F index 403804ea85..7ad909e51a 100644 --- a/src/qs_energy.F +++ b/src/qs_energy.F @@ -44,7 +44,6 @@ MODULE qs_energy !> \param qs_env ... !> \param consistent_energies ... !> \param calc_forces ... -!> \param error ... !> \date 29.10.2002 !> \par History !> - consistent_energies option added (25.08.2005, TdK) @@ -53,12 +52,10 @@ MODULE qs_energy !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE qs_energies (qs_env, consistent_energies, calc_forces, & - error) + SUBROUTINE qs_energies (qs_env, consistent_energies, calc_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN), OPTIONAL :: consistent_energies, & calc_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies', & routineP = moduleN//':'//routineN @@ -68,11 +65,11 @@ SUBROUTINE qs_energies (qs_env, consistent_energies, calc_forces, & my_calc_forces = .FALSE. IF(PRESENT(calc_forces)) my_calc_forces = calc_forces - CALL qs_env_rebuild_pw_env(qs_env, error=error) + CALL qs_env_rebuild_pw_env(qs_env) - CALL get_qs_env(qs_env=qs_env,run_rtp=run_rtp,error=error) + CALL get_qs_env(qs_env=qs_env,run_rtp=run_rtp) IF(.NOT.run_rtp)THEN - CALL qs_energies_scf(qs_env, consistent_energies, my_calc_forces, error) + CALL qs_energies_scf(qs_env, consistent_energies, my_calc_forces) END IF END SUBROUTINE qs_energies @@ -83,19 +80,16 @@ END SUBROUTINE qs_energies !> \param qs_env ... !> \param consistent_energies ... !> \param calc_forces ... -!> \param error ... !> \date 29.10.2002 !> \par History !> - consistent_energies option added (25.08.2005, TdK) !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE qs_energies_scf (qs_env, consistent_energies, calc_forces, & - error) + SUBROUTINE qs_energies_scf (qs_env, consistent_energies, calc_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN), OPTIONAL :: consistent_energies LOGICAL, INTENT(IN) :: calc_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies_scf', & routineP = moduleN//':'//routineN @@ -107,28 +101,28 @@ SUBROUTINE qs_energies_scf (qs_env, consistent_energies, calc_forces, & CALL timeset(routineN,handle) NULLIFY(dft_control, energy) - CALL qs_energies_init(qs_env, calc_forces, error=error) - CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, energy=energy, error=error) + CALL qs_energies_init(qs_env, calc_forces) + CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, energy=energy) ! *** Perform a SCF run *** IF (dft_control%qs_control%do_ls_scf) THEN - CALL ls_scf(qs_env=qs_env, error=error) + CALL ls_scf(qs_env=qs_env) ELSE IF (dft_control%qs_control%do_almo_scf) THEN - CALL almo_entry_scf(qs_env=qs_env, calc_forces=calc_forces, error=error) + CALL almo_entry_scf(qs_env=qs_env, calc_forces=calc_forces) ELSE - CALL scf(qs_env=qs_env, error=error) + CALL scf(qs_env=qs_env) ! Compute MP2 energy - CALL qs_energies_mp2(qs_env, calc_forces, error=error) + CALL qs_energies_mp2(qs_env, calc_forces) ! if calculate forces, time to compute the w matrix - CALL qs_energies_compute_matrix_w(qs_env,calc_forces,error=error) + CALL qs_energies_compute_matrix_w(qs_env,calc_forces) END IF IF (PRESENT(consistent_energies)) THEN IF (consistent_energies) THEN - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.TRUE., error=error) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.TRUE.) ! add MP2 energy if necessary IF(ASSOCIATED(qs_env%mp2_env)) THEN energy%total = energy%total + energy%mp2 @@ -136,7 +130,7 @@ SUBROUTINE qs_energies_scf (qs_env, consistent_energies, calc_forces, & END IF END IF - CALL qs_energies_properties(qs_env,error=error) + CALL qs_energies_properties(qs_env) CALL timestop(handle) diff --git a/src/qs_energy_utils.F b/src/qs_energy_utils.F index cf9f3c7c3e..30a27676dc 100644 --- a/src/qs_energy_utils.F +++ b/src/qs_energy_utils.F @@ -111,15 +111,13 @@ MODULE qs_energy_utils !> setup and calculations for a qs energy calculation !> \param qs_env ... !> \param calc_forces ... -!> \param error ... !> \par History !> 05.2013 created [Florian Schiffmann] ! ***************************************************************************** - SUBROUTINE qs_energies_init(qs_env, calc_forces, error) + SUBROUTINE qs_energies_init(qs_env, calc_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calc_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies_init', & routineP = moduleN//':'//routineN @@ -138,44 +136,43 @@ SUBROUTINE qs_energies_init(qs_env, calc_forces, error) failure = .FALSE. NULLIFY(ks_env, matrix_w, matrix_w_mp2, matrix_s, dft_control) - CALL qs_energies_init_kg(qs_env,molecule_only,error) - CALL qs_energies_init_hamiltonians(qs_env,calc_forces,molecule_only,error) - CALL qs_ks_allocate_basics(qs_env,error) - CALL get_qs_env(qs_env, has_unit_metric=has_unit_metric, error=error) + CALL qs_energies_init_kg(qs_env,molecule_only) + CALL qs_energies_init_hamiltonians(qs_env,calc_forces,molecule_only) + CALL qs_ks_allocate_basics(qs_env) + CALL get_qs_env(qs_env, has_unit_metric=has_unit_metric) ! if need forces allocate energy weighted density matrices IF (calc_forces.AND..NOT.has_unit_metric) THEN CALL get_qs_env(qs_env,& ks_env=ks_env,& matrix_s_kp=matrix_s,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) nspin = dft_control%nspins nimg = dft_control%nimages matrix => matrix_s(1,1)%matrix - CALL cp_dbcsr_allocate_matrix_set(matrix_w,nspin,nimg,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_w,nspin,nimg) DO ispin=1,nspin DO img=1,nimg ALLOCATE(matrix_w(ispin,img)%matrix,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_w(ispin,img)%matrix,error=error) - CALL cp_dbcsr_copy(matrix_w(ispin,img)%matrix,matrix,name="W MATRIX",error=error) - CALL cp_dbcsr_set(matrix_w(ispin,img)%matrix,0.0_dp,error=error) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) + CALL cp_dbcsr_init(matrix_w(ispin,img)%matrix) + CALL cp_dbcsr_copy(matrix_w(ispin,img)%matrix,matrix,name="W MATRIX") + CALL cp_dbcsr_set(matrix_w(ispin,img)%matrix,0.0_dp) END DO END DO - CALL set_ks_env(ks_env,matrix_w_kp=matrix_w,error=error) + CALL set_ks_env(ks_env,matrix_w_kp=matrix_w) IF (ASSOCIATED(qs_env%mp2_env)) THEN ! create the MP2 energy weighted density matrix - CALL cp_dbcsr_allocate_matrix_set(matrix_w_mp2,dft_control%nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_w_mp2,dft_control%nspins) DO ispin=1,nspin ALLOCATE(matrix_w_mp2(ispin)%matrix,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_w_mp2(ispin)%matrix,error=error) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) + CALL cp_dbcsr_init(matrix_w_mp2(ispin)%matrix) CALL cp_dbcsr_copy(matrix_w_mp2(ispin)%matrix,matrix,& - name="W MATRIX MP2",error=error) - CALL cp_dbcsr_set(matrix_w_mp2(ispin)%matrix,0.0_dp,error=error) + name="W MATRIX MP2") + CALL cp_dbcsr_set(matrix_w_mp2(ispin)%matrix,0.0_dp) END DO - CALL set_ks_env(ks_env,matrix_w_mp2=matrix_w_mp2,error=error) + CALL set_ks_env(ks_env,matrix_w_mp2=matrix_w_mp2) END IF ENDIF @@ -186,15 +183,13 @@ END SUBROUTINE qs_energies_init !> settings into separate subroutine !> \param qs_env ... !> \param molecule_only ... -!> \param error ... !> \par History !> 05.2013 created [Florian Schiffmann] ! ***************************************************************************** - SUBROUTINE qs_energies_init_kg(qs_env,molecule_only,error) + SUBROUTINE qs_energies_init_kg(qs_env,molecule_only) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL :: molecule_only - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies_init_kg', & routineP = moduleN//':'//routineN @@ -209,14 +204,14 @@ SUBROUTINE qs_energies_init_kg(qs_env,molecule_only,error) NULLIFY(dft_control,para_env) molecule_only = .FALSE. - CALL get_qs_env(qs_env, dft_control=dft_control, para_env=para_env, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control, para_env=para_env) IF (dft_control%qs_control%do_kg) THEN ! create neighbor lists with molecular blocks molecule_only = .TRUE. ! get the set of molecules - CALL get_qs_env(qs_env=qs_env, molecule_set=molecule_set, natom=natom, error=error) + CALL get_qs_env(qs_env=qs_env, molecule_set=molecule_set, natom=natom) qs_env%kg_env%natom = natom @@ -224,29 +219,29 @@ SUBROUTINE qs_energies_init_kg(qs_env,molecule_only,error) qs_env%kg_env%molecule_set => molecule_set ! build the (new) full neighborlist - CALL kg_build_neighborlist(qs_env, sab_orb=qs_env%kg_env%sab_orb_full, error=error) + CALL kg_build_neighborlist(qs_env, sab_orb=qs_env%kg_env%sab_orb_full) IF (.NOT.ALLOCATED(qs_env%kg_env%atom_to_molecule)) THEN ALLOCATE(qs_env%kg_env%atom_to_molecule(natom)) ! get the mapping from atoms to molecules - CALL molecule_of_atom(molecule_set, atom_to_mol=qs_env%kg_env%atom_to_molecule, error=error) + CALL molecule_of_atom(molecule_set, atom_to_mol=qs_env%kg_env%atom_to_molecule) END IF IF (qs_env%kg_env%tnadd_method == kg_tnadd_embed) THEN ! allocate the subset list IF (.NOT.ASSOCIATED(qs_env%kg_env%subset_of_mol)) ALLOCATE(qs_env%kg_env%subset_of_mol(SIZE(molecule_set))) - CALL kg_build_subsets(qs_env%kg_env, para_env, error) + CALL kg_build_subsets(qs_env%kg_env, para_env) DO isubset=1,qs_env%kg_env%nsubsets ! build the (new) molecular neighborlist of the current subset CALL kg_build_neighborlist(qs_env, sab_orb=qs_env%kg_env%subset(isubset)%sab_orb, molecular=.TRUE., & - subset_of_mol=qs_env%kg_env%subset_of_mol, current_subset=isubset, error=error) + subset_of_mol=qs_env%kg_env%subset_of_mol, current_subset=isubset) END DO ELSE IF (qs_env%kg_env%tnadd_method == kg_tnadd_atomic) THEN ! build the A-C list for the nonadditive kinetic energy potential - CALL kg_build_neighborlist(qs_env, sac_kin=qs_env%kg_env%sac_kin, error=error) + CALL kg_build_neighborlist(qs_env, sac_kin=qs_env%kg_env%sac_kin) END IF END IF @@ -260,17 +255,15 @@ END SUBROUTINE qs_energies_init_kg !> \param qs_env QS environment !> \param calc_forces Calculate forces !> \param molecule_only restrict neighbor list to molecules -!> \param error CP2K error handling !> \par History !> 05.2013 created [Florian Schiffmann] !> 08.2014 Kpoints [JGH] ! ***************************************************************************** - SUBROUTINE qs_energies_init_hamiltonians(qs_env,calc_forces,molecule_only,error) + SUBROUTINE qs_energies_init_hamiltonians(qs_env,calc_forces,molecule_only) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calc_forces LOGICAL :: molecule_only - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'qs_energies_init_hamiltonians', & @@ -295,17 +288,16 @@ SUBROUTINE qs_energies_init_hamiltonians(qs_env,calc_forces,molecule_only,error) dft_control=dft_control,& para_env=para_env,& kpoints=kpoints,& - do_kpoints=do_kpoints,& - error=error) + do_kpoints=do_kpoints) ! create neighbor lists for standard use in QS CALL build_qs_neighbor_lists(qs_env,para_env,molecular=molecule_only,& - force_env_section=input,error=error) + force_env_section=input) ! calculate cell index for k-point calculations IF(do_kpoints) THEN - CALL get_qs_env(qs_env, sab_kp=sab_nl, error=error) - CALL kpoint_init_cell_index(kpoints, sab_nl, para_env, dft_control, error) + CALL get_qs_env(qs_env, sab_kp=sab_nl) + CALL kpoint_init_cell_index(kpoints, sab_nl, para_env, dft_control) ENDIF dft_control%qs_control%becke_control%need_pot=.TRUE. @@ -313,43 +305,43 @@ SUBROUTINE qs_energies_init_hamiltonians(qs_env,calc_forces,molecule_only,error) ! Calculate the overlap and the core Hamiltonian integral matrix IF ( dft_control%qs_control%semi_empirical ) THEN CALL build_se_core_matrix(qs_env=qs_env, para_env=para_env,& - calculate_forces=.FALSE.,error=error) - CALL qs_env_update_s_mstruct(qs_env,error=error) - CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.FALSE., error=error) - CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,energy=energy,error=error) - CALL calculate_dispersion_pairpot(qs_env,dispersion_env,energy%dispersion,calc_forces,error) + calculate_forces=.FALSE.) + CALL qs_env_update_s_mstruct(qs_env) + CALL se_core_core_interaction(qs_env, para_env, calculate_forces=.FALSE.) + CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,energy=energy) + CALL calculate_dispersion_pairpot(qs_env,dispersion_env,energy%dispersion,calc_forces) ELSEIF ( dft_control%qs_control%dftb ) THEN CALL build_dftb_matrices(qs_env=qs_env, para_env=para_env,& - calculate_forces=.FALSE.,error=error) + calculate_forces=.FALSE.) CALL calculate_dftb_dispersion(qs_env=qs_env, para_env=para_env,& - calculate_forces=.FALSE.,error=error) - CALL qs_env_update_s_mstruct(qs_env,error=error) + calculate_forces=.FALSE.) + CALL qs_env_update_s_mstruct(qs_env) ELSEIF ( dft_control%qs_control%scptb ) THEN - CALL build_scptb_core_matrix(qs_env=qs_env,calculate_forces=.FALSE.,error=error) - CALL qs_env_update_s_mstruct(qs_env,error=error) - CALL scptb_core_interaction(qs_env,calculate_forces=.FALSE.,error=error) - CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,energy=energy,error=error) - CALL calculate_dispersion_pairpot(qs_env,dispersion_env,energy%dispersion,calc_forces,error) + CALL build_scptb_core_matrix(qs_env=qs_env,calculate_forces=.FALSE.) + CALL qs_env_update_s_mstruct(qs_env) + CALL scptb_core_interaction(qs_env,calculate_forces=.FALSE.) + CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,energy=energy) + CALL calculate_dispersion_pairpot(qs_env,dispersion_env,energy%dispersion,calc_forces) ELSE - CALL build_core_hamiltonian_matrix(qs_env=qs_env,calculate_forces=.FALSE.,error=error) - CALL qs_env_update_s_mstruct(qs_env,error=error) - CALL calculate_ecore_self(qs_env,error=error) - CALL calculate_ecore_efield(qs_env,calculate_forces=.FALSE.,error=error) - CALL calculate_ecore_overlap(qs_env, para_env, calculate_forces=.FALSE.,error=error) + CALL build_core_hamiltonian_matrix(qs_env=qs_env,calculate_forces=.FALSE.) + CALL qs_env_update_s_mstruct(qs_env) + CALL calculate_ecore_self(qs_env) + CALL calculate_ecore_efield(qs_env,calculate_forces=.FALSE.) + CALL calculate_ecore_overlap(qs_env, para_env, calculate_forces=.FALSE.) !swap external_e_potential before external_c_potential, to ensure !that external potential on grid is loaded before calculating energy of cores - CALL external_e_potential(qs_env,error=error) + CALL external_e_potential(qs_env) IF (.NOT. dft_control%qs_control%gapw ) THEN - CALL external_c_potential(qs_env,calculate_forces=.FALSE.,error=error) + CALL external_c_potential(qs_env,calculate_forces=.FALSE.) END IF ! ZMP addition to read external density - CALL external_read_density(qs_env,error) + CALL external_read_density(qs_env) ! Add possible pair potential dispersion energy - Evaluate first so we can print ! energy info at the end of the SCF - CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,energy=energy,error=error) - CALL calculate_dispersion_pairpot(qs_env,dispersion_env,energy%dispersion,calc_forces,error) + CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,energy=energy) + CALL calculate_dispersion_pairpot(qs_env,dispersion_env,energy%dispersion,calc_forces) END IF @@ -362,15 +354,13 @@ END SUBROUTINE qs_energies_init_hamiltonians !> into separate subroutine !> \param qs_env ... !> \param calc_forces ... -!> \param error ... !> \par History !> 05.2013 created [Florian Schiffmann] ! ***************************************************************************** - SUBROUTINE qs_energies_compute_matrix_w(qs_env,calc_forces,error) + SUBROUTINE qs_energies_compute_matrix_w(qs_env,calc_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calc_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies_compute_matrix_w', & routineP = moduleN//':'//routineN @@ -404,10 +394,10 @@ SUBROUTINE qs_energies_compute_matrix_w(qs_env,calc_forces,error) failure = .FALSE. ! if calculate forces, time to compute the w matrix - CALL get_qs_env(qs_env, has_unit_metric=has_unit_metric, error=error) + CALL get_qs_env(qs_env, has_unit_metric=has_unit_metric) IF (calc_forces.AND..NOT.has_unit_metric) THEN - CALL get_qs_env(qs_env, do_kpoints=do_kpoints, error=error) + CALL get_qs_env(qs_env, do_kpoints=do_kpoints) IF(do_kpoints) THEN @@ -416,31 +406,31 @@ SUBROUTINE qs_energies_compute_matrix_w(qs_env,calc_forces,error) matrix_s_kp=matrix_s_kp,& sab_orb=sab_nl,& mos=mos,& - kpoints=kpoints, error=error) + kpoints=kpoints) CALL get_mo_set(mos(1)%mo_set,mo_coeff=mo_coeff,nao=nao) CALL cp_fm_struct_create(fmstruct=ao_ao_fmstruct, nrow_global=nao, ncol_global=nao,& - template_fmstruct=mo_coeff%matrix_struct, error=error) + template_fmstruct=mo_coeff%matrix_struct) ALLOCATE(fmwork(2),STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) DO is=1,SIZE(fmwork) NULLIFY(fmwork(is)%matrix) - CALL cp_fm_create(fmwork(is)%matrix,matrix_struct=ao_ao_fmstruct,error=error) + CALL cp_fm_create(fmwork(is)%matrix,matrix_struct=ao_ao_fmstruct) END DO - CALL cp_fm_struct_release(ao_ao_fmstruct,error=error) + CALL cp_fm_struct_release(ao_ao_fmstruct) ! energy weighted density matrices in k-space - CALL kpoint_density_matrices(kpoints,energy_weighted=.TRUE.,error=error) + CALL kpoint_density_matrices(kpoints,energy_weighted=.TRUE.) ! energy weighted density matrices in real space CALL kpoint_density_transform(kpoints,matrix_w_kp,.TRUE.,& - matrix_s_kp(1,1)%matrix,sab_nl,fmwork,error) + matrix_s_kp(1,1)%matrix,sab_nl,fmwork) DO is=1,SIZE(fmwork) - CALL cp_fm_release(fmwork(is)%matrix,error=error) + CALL cp_fm_release(fmwork(is)%matrix) END DO DEALLOCATE(fmwork,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) ELSE @@ -454,10 +444,9 @@ SUBROUTINE qs_energies_compute_matrix_w(qs_env,calc_forces,error) scf_control=scf_control,& mos=mos,& rho=rho,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) nspin = SIZE(mos) DO ispin=1,nspin @@ -466,29 +455,28 @@ SUBROUTINE qs_energies_compute_matrix_w(qs_env,calc_forces,error) IF (scf_control%use_ot) THEN IF (ispin > 1) THEN ! not very elegant, indeed ... - CALL cp_dbcsr_set(matrix_w(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_w(ispin)%matrix,0.0_dp) ELSE CALL calculate_w_matrix_ot(mo_set,mo_derivs(ispin)%matrix,& - matrix_w(ispin)%matrix,matrix_s(1)%matrix,error=error) + matrix_w(ispin)%matrix,matrix_s(1)%matrix) END IF ELSE CALL calculate_w_matrix(mo_set=mo_set,& matrix_ks=matrix_ks(ispin)%matrix,& matrix_p=rho_ao(ispin)%matrix,& - matrix_w=matrix_w(ispin)%matrix,& - error=error) + matrix_w=matrix_w(ispin)%matrix) END IF ELSE IF (scf_control%use_ot) THEN CALL calculate_w_matrix_ot(mo_set,mo_derivs(ispin)%matrix,& - matrix_w(ispin)%matrix,matrix_s(1)%matrix,error=error) + matrix_w(ispin)%matrix,matrix_s(1)%matrix) ELSE - CALL calculate_w_matrix(mo_set,matrix_w(ispin)%matrix,error=error) + CALL calculate_w_matrix(mo_set,matrix_w(ispin)%matrix) END IF END IF ! if MP2 time to update the W matrix with the MP2 contribution IF(ASSOCIATED(qs_env%mp2_env)) THEN - CALL cp_dbcsr_add(matrix_w(ispin)%matrix, matrix_w_mp2(ispin)%matrix, 1.0_dp, -1.0_dp, error) + CALL cp_dbcsr_add(matrix_w(ispin)%matrix, matrix_w_mp2(ispin)%matrix, 1.0_dp, -1.0_dp) END IF END DO @@ -504,14 +492,12 @@ END SUBROUTINE qs_energies_compute_matrix_w !> \brief Refactoring of qs_energies_scf. Moves computation of properties !> into separate subroutine !> \param qs_env ... -!> \param error ... !> \par History !> 05.2013 created [Florian Schiffmann] ! ***************************************************************************** - SUBROUTINE qs_energies_properties(qs_env,error) + SUBROUTINE qs_energies_properties(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies_properties', & routineP = moduleN//':'//routineN @@ -538,23 +524,22 @@ SUBROUTINE qs_energies_properties(qs_env,error) atprop=atprop,& energy=energy,& v_hartree_rspace=v_hartree_rspace%pw,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) IF (atprop%energy) THEN - CALL qs_energies_mulliken(qs_env,error) + CALL qs_energies_mulliken(qs_env) IF ( .NOT.dft_control%qs_control%semi_empirical .AND. & .NOT.dft_control%qs_control%dftb) THEN ! Nuclear charge correction - CALL integrate_v_core_rspace(v_hartree_rspace,qs_env,error=error) + CALL integrate_v_core_rspace(v_hartree_rspace,qs_env) ! Kohn-Sham Functional corrections END IF - CALL atprop_array_add(atprop%atener,atprop%ateb,error) - CALL atprop_array_add(atprop%atener,atprop%ateself,error) - CALL atprop_array_add(atprop%atener,atprop%atexc,error) - CALL atprop_array_add(atprop%atener,atprop%atecoul,error) - CALL atprop_array_add(atprop%atener,atprop%atevdw,error) - CALL atprop_array_add(atprop%atener,atprop%atecc,error) - CALL atprop_array_add(atprop%atener,atprop%ate1c,error) + CALL atprop_array_add(atprop%atener,atprop%ateb) + CALL atprop_array_add(atprop%atener,atprop%ateself) + CALL atprop_array_add(atprop%atener,atprop%atexc) + CALL atprop_array_add(atprop%atener,atprop%atecoul) + CALL atprop_array_add(atprop%atener,atprop%atevdw) + CALL atprop_array_add(atprop%atener,atprop%atecc) + CALL atprop_array_add(atprop%atener,atprop%ate1c) END IF ! ********** Calculate the electron transfer coupling elements******** @@ -564,41 +549,39 @@ SUBROUTINE qs_energies_properties(qs_env,error) qs_env%et_coupling%energy=energy%total qs_env%et_coupling%keep_matrix=.TRUE. qs_env%et_coupling%first_run=.TRUE. - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.TRUE., error=error) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.TRUE.) qs_env%et_coupling%first_run=.FALSE. IF(dft_control%qs_control%ddapc_restraint)THEN - rest_b_section => section_vals_get_subs_vals(input,"PROPERTIES%ET_COUPLING%DDAPC_RESTRAINT_B",& - error=error) + rest_b_section => section_vals_get_subs_vals(input,"PROPERTIES%ET_COUPLING%DDAPC_RESTRAINT_B") CALL read_ddapc_section(qs_control=dft_control%qs_control,& - ddapc_restraint_section=rest_b_section,error=error) + ddapc_restraint_section=rest_b_section) END IF IF(dft_control%qs_control%becke_restraint)THEN - rest_b_section => section_vals_get_subs_vals(input,"PROPERTIES%ET_COUPLING%BECKE_RESTRAINT_B",& - error=error) + rest_b_section => section_vals_get_subs_vals(input,"PROPERTIES%ET_COUPLING%BECKE_RESTRAINT_B") CALL read_becke_section(qs_control=dft_control%qs_control,& - becke_section=rest_b_section,error=error) + becke_section=rest_b_section) END IF - CALL scf(qs_env=qs_env, error=error) + CALL scf(qs_env=qs_env) qs_env%et_coupling%keep_matrix=.TRUE. - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.TRUE., error=error) - CALL calc_et_coupling(qs_env,error) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.TRUE.) + CALL calc_et_coupling(qs_env) IF(dft_control%qs_control%becke_restraint)THEN - CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_give_back_pw(auxbas_pw_pool,& - dft_control%qs_control%becke_control%becke_pot%pw,error=error) + dft_control%qs_control%becke_control%becke_pot%pw) dft_control%qs_control%becke_control%need_pot=.TRUE. END IF END IF !Properties IF(dft_control%do_xas_calculation) THEN - CALL xas(qs_env, dft_control, error=error) + CALL xas(qs_env, dft_control) END IF ! Compute Linear Response properties as post-scf IF(.NOT. qs_env%linres_run) THEN - CALL linres_calculation_low(qs_env, error=error) + CALL linres_calculation_low(qs_env) END IF @@ -610,15 +593,13 @@ END SUBROUTINE qs_energies_properties ! ***************************************************************************** !> \brief Use a simple Mulliken-like energy decomposition !> \param qs_env ... -!> \param error ... !> \date 07.2011 !> \author JHU !> \version 1.0 ! ***************************************************************************** - SUBROUTINE qs_energies_mulliken(qs_env,error) + SUBROUTINE qs_energies_mulliken(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies_mulliken', & routineP = moduleN//':'//routineN @@ -631,17 +612,17 @@ SUBROUTINE qs_energies_mulliken(qs_env,error) NULLIFY(atprop,matrix_h,matrix_ks,rho,rho_ao) CALL get_qs_env(qs_env=qs_env,matrix_ks=matrix_ks,matrix_h=matrix_h,& - rho=rho,atprop=atprop,error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + rho=rho,atprop=atprop) + CALL qs_rho_get(rho, rho_ao=rho_ao) IF(atprop%energy) THEN ! E = 0.5*Tr(H*P+F*P) atprop%atener = 0._dp DO ispin = 1,SIZE(rho_ao) CALL atom_trace(matrix_h(1)%matrix,rho_ao(ispin)%matrix,& - 0.5_dp,atprop%atener,error) + 0.5_dp,atprop%atener) CALL atom_trace(matrix_ks(ispin)%matrix,rho_ao(ispin)%matrix,& - 0.5_dp,atprop%atener,error) + 0.5_dp,atprop%atener) END DO END IF @@ -654,17 +635,15 @@ END SUBROUTINE qs_energies_mulliken !> \param bmat ... !> \param factor ... !> \param atrace ... -!> \param error ... !> \par History !> 06.2004 created [Joost VandeVondele] !> \note !> charges are computed per spin in the LSD case ! ***************************************************************************** - SUBROUTINE atom_trace(amat,bmat,factor,atrace,error) + SUBROUTINE atom_trace(amat,bmat,factor,atrace) TYPE(cp_dbcsr_type), POINTER :: amat, bmat REAL(kind=dp), INTENT(IN) :: factor REAL(KIND=dp), DIMENSION(:), POINTER :: atrace - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom_trace', & routineP = moduleN//':'//routineN @@ -677,7 +656,7 @@ SUBROUTINE atom_trace(amat,bmat,factor,atrace,error) TYPE(cp_dbcsr_iterator) :: iter CALL cp_dbcsr_get_info(bmat,nblkrows_total=nblock) - CPPostcondition(nblock==SIZE(atrace),cp_warning_level,routineP,error,failure) + CPPostcondition(nblock==SIZE(atrace),cp_warning_level,routineP,failure) CALL cp_dbcsr_iterator_start(iter, bmat) DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) @@ -706,13 +685,11 @@ END SUBROUTINE atom_trace !> \brief Enters the mp2 part of cp2k !> \param qs_env ... !> \param calc_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_energies_mp2(qs_env,calc_forces,error) + SUBROUTINE qs_energies_mp2(qs_env,calc_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calc_forces - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_energies_mp2', & routineP = moduleN//':'//routineN @@ -724,9 +701,9 @@ SUBROUTINE qs_energies_mp2(qs_env,calc_forces,error) IF (ASSOCIATED(qs_env%mp2_env)) THEN CALL external_control(should_stop,"MP2",target_time=qs_env%target_time, & - start_time = qs_env%start_time,error=error) + start_time = qs_env%start_time) - CALL mp2_main(qs_env=qs_env,calc_forces=calc_forces,error=error) + CALL mp2_main(qs_env=qs_env,calc_forces=calc_forces) ! no forces so far with MP2 (except one electron systems ;-) ! IF (qs_env%energy%mp2.NE.0.0_dp .AND. calc_forces) THEN diff --git a/src/qs_environment.F b/src/qs_environment.F index 19dd960435..823a9a2845 100644 --- a/src/qs_environment.F +++ b/src/qs_environment.F @@ -210,11 +210,10 @@ MODULE qs_environment !> \param force_env_section ... !> \param subsys_section ... !> \param use_motion_section ... -!> \param error ... !> \author Creation (22.05.2000,MK) ! ***************************************************************************** SUBROUTINE qs_init(qs_env,para_env,globenv,root_section,cp_subsys,cell,cell_ref,qmmm,& - qmmm_env_qm,force_env_section,subsys_section,use_motion_section,error) + qmmm_env_qm,force_env_section,subsys_section,use_motion_section) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env @@ -228,7 +227,6 @@ SUBROUTINE qs_init(qs_env,para_env,globenv,root_section,cp_subsys,cell,cell_ref, TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section LOGICAL, INTENT(IN) :: use_motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_init', & routineP = moduleN//':'//routineN @@ -259,9 +257,9 @@ SUBROUTINE qs_init(qs_env,para_env,globenv,root_section,cp_subsys,cell,cell_ref, qs_kind_set, kpoint_section, dft_section, & subsys, ks_env, dft_control, blacs_env) - CALL set_qs_env(qs_env,input=force_env_section,error=error) + CALL set_qs_env(qs_env,input=force_env_section) IF (.NOT.ASSOCIATED(subsys_section)) THEN - subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS",error=error) + subsys_section => section_vals_get_subs_vals(force_env_section,"SUBSYS") END IF ! QMMM @@ -276,14 +274,14 @@ SUBROUTINE qs_init(qs_env,para_env,globenv,root_section,cp_subsys,cell,cell_ref, END IF qs_env%qmmm_env_qm => qmmm_env_qm END IF - CALL set_qs_env(qs_env=qs_env,qmmm=my_qmmm,error=error) + CALL set_qs_env(qs_env=qs_env,qmmm=my_qmmm) ! Possibly initialize arrays for SE - CALL section_vals_val_get(force_env_section,"DFT%QS%METHOD",i_val=method_id,error=error) + CALL section_vals_val_get(force_env_section,"DFT%QS%METHOD",i_val=method_id) SELECT CASE (method_id) CASE ( do_method_rm1, do_method_am1, do_method_mndo, do_method_pdg,& do_method_pm3, do_method_pm6, do_method_mndod, do_method_pnnl ) - CALL init_se_intd_array(error) + CALL init_se_intd_array() CASE DEFAULT ! Do nothing END SELECT @@ -292,12 +290,11 @@ SUBROUTINE qs_init(qs_env,para_env,globenv,root_section,cp_subsys,cell,cell_ref, force_env_section=force_env_section,& subsys_section=subsys_section,& use_motion_section=use_motion_section,& - cp_subsys=cp_subsys, cell=cell, cell_ref=cell_ref, & - error=error) + cp_subsys=cp_subsys, cell=cell, cell_ref=cell_ref) - CALL qs_ks_env_create(ks_env, error=error) - CALL set_ks_env(ks_env, subsys=subsys, error=error) - CALL set_qs_env(qs_env, ks_env=ks_env, error=error) + CALL qs_ks_env_create(ks_env) + CALL set_ks_env(ks_env, subsys=subsys) + CALL set_qs_env(qs_env, ks_env=ks_env) CALL qs_subsys_get(subsys,& cell=my_cell,& @@ -305,110 +302,109 @@ SUBROUTINE qs_init(qs_env,para_env,globenv,root_section,cp_subsys,cell,cell_ref, use_ref_cell=use_ref_cell,& atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) - CALL set_ks_env(ks_env, para_env=para_env, error=error) + CALL set_ks_env(ks_env, para_env=para_env) CALL cp_blacs_env_create(blacs_env, para_env, globenv%blacs_grid_layout,& - globenv%blacs_repeatable,error=error) - CALL set_ks_env(ks_env, blacs_env=blacs_env, error=error) - CALL cp_blacs_env_release(blacs_env,error=error) + globenv%blacs_repeatable) + CALL set_ks_env(ks_env, blacs_env=blacs_env) + CALL cp_blacs_env_release(blacs_env) ! *** Setup the grids for the G-space Interpolation if any CALL cp_ddapc_ewald_create(qs_env%cp_ddapc_ewald, qmmm_decoupl, my_cell,& - force_env_section, subsys_section, para_env, error) + force_env_section, subsys_section, para_env) CALL qs_init_subsys(qs_env,para_env,subsys,my_cell,my_cell_ref,use_ref_cell,& - root_section,subsys_section,error=error) + root_section,subsys_section) ! kpoints - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) - kpoint_section => section_vals_get_subs_vals(qs_env%input,"DFT%KPOINTS",error=error) - CALL read_kpoint_section(kpoints,kpoint_section,error) - CALL kpoint_initialize(kpoints, particle_set, my_cell, error) - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) - CALL write_kpoint_info(kpoints,dft_section,error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) + kpoint_section => section_vals_get_subs_vals(qs_env%input,"DFT%KPOINTS") + CALL read_kpoint_section(kpoints,kpoint_section) + CALL kpoint_initialize(kpoints, particle_set, my_cell) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") + CALL write_kpoint_info(kpoints,dft_section) kpoints%para_env => para_env - CALL cp_para_env_retain(para_env, error) - CALL get_qs_env(qs_env=qs_env,blacs_env=blacs_env,error=error) + CALL cp_para_env_retain(para_env) + CALL get_qs_env(qs_env=qs_env,blacs_env=blacs_env) kpoints%blacs_env_all => blacs_env - CALL cp_blacs_env_retain(blacs_env, error) - CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints,error=error) + CALL cp_blacs_env_retain(blacs_env) + CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints) IF(do_kpoints) THEN - CALL kpoint_env_initialize(kpoints, error) - CALL kpoint_initialize_mos(kpoints, qs_env%mos, error) - CALL get_qs_env(qs_env=qs_env, wf_history=wf_history, error=error) - CALL wfi_create_for_kp(wf_history, error) + CALL kpoint_env_initialize(kpoints) + CALL kpoint_initialize_mos(kpoints, qs_env%mos) + CALL get_qs_env(qs_env=qs_env, wf_history=wf_history) + CALL wfi_create_for_kp(wf_history) END IF do_hfx =.FALSE. - hfx_section => section_vals_get_subs_vals(qs_env%input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_section,explicit=do_hfx,error=error) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + hfx_section => section_vals_get_subs_vals(qs_env%input,"DFT%XC%HF") + CALL section_vals_get(hfx_section,explicit=do_hfx) + CALL get_qs_env(qs_env, dft_control=dft_control) IF (do_hfx) THEN ! Retrieve particle_set and atomic_kind_set (needed for both kinds of initialization) natom=SIZE(particle_set) CALL hfx_create(qs_env%x_data, para_env, hfx_section, natom, atomic_kind_set,& - qs_kind_set, dft_control, my_cell, error=error) + qs_kind_set, dft_control, my_cell) END IF - mp2_section => section_vals_get_subs_vals(qs_env%input,"DFT%XC%WF_CORRELATION",error=error) - CALL section_vals_get(mp2_section,explicit=mp2_present,error=error) + mp2_section => section_vals_get_subs_vals(qs_env%input,"DFT%XC%WF_CORRELATION") + CALL section_vals_get(mp2_section,explicit=mp2_present) IF (mp2_present) THEN - CALL mp2_env_create(qs_env%mp2_env,error) - CALL read_mp2_section(qs_env%input,qs_env%mp2_env,error) + CALL mp2_env_create(qs_env%mp2_env) + CALL read_mp2_section(qs_env%input,qs_env%mp2_env) ! create the EXX section if necessary do_exx =.FALSE. - hfx_section => section_vals_get_subs_vals(qs_env%input,"DFT%XC%WF_CORRELATION%RI_RPA%HF",error=error) - CALL section_vals_get(hfx_section,explicit=do_exx,error=error) + hfx_section => section_vals_get_subs_vals(qs_env%input,"DFT%XC%WF_CORRELATION%RI_RPA%HF") + CALL section_vals_get(hfx_section,explicit=do_exx) IF (do_exx) THEN ! Retrieve particle_set and atomic_kind_set (needed for both kinds of initialization) natom=SIZE(particle_set) CALL hfx_create(qs_env%mp2_env%ri_rpa%x_data, para_env, hfx_section, natom, atomic_kind_set,& - qs_kind_set, dft_control, my_cell, error=error, do_exx=.TRUE.) + qs_kind_set, dft_control, my_cell,do_exx=.TRUE.) END IF END IF IF (dft_control%qs_control%do_kg) THEN CALL cite_reference(Iannuzzi2006) - CALL kg_env_create(qs_env%kg_env, qs_env%input, error) + CALL kg_env_create(qs_env%kg_env, qs_env%input) END IF et_coupling_section => section_vals_get_subs_vals(qs_env%input,& - "PROPERTIES%ET_COUPLING",error=error) - CALL section_vals_get(et_coupling_section,explicit=do_et,error=error) - IF (do_et) CALL et_coupling_create(qs_env%et_coupling,error=error) + "PROPERTIES%ET_COUPLING") + CALL section_vals_get(et_coupling_section,explicit=do_et) + IF (do_et) CALL et_coupling_create(qs_env%et_coupling) ! lri env IF (method_id == do_method_lrigpw.OR.dft_control%qs_control%lri_optbas) THEN - CALL lri_env_init(qs_env, force_env_section, qs_kind_set, error) + CALL lri_env_init(qs_env, force_env_section, qs_kind_set) END IF - transport_section => section_vals_get_subs_vals(qs_env%input,"DFT%TRANSPORT",error=error) - CALL section_vals_get(transport_section,explicit=qs_env%do_transport,error=error) + transport_section => section_vals_get_subs_vals(qs_env%input,"DFT%TRANSPORT") + CALL section_vals_get(transport_section,explicit=qs_env%do_transport) IF (qs_env%do_transport) THEN - CALL transport_env_create(qs_env,error) + CALL transport_env_create(qs_env) END IF IF (dft_control%qs_control%do_ls_scf) THEN - CALL ls_scf_create(qs_env,error) + CALL ls_scf_create(qs_env) ENDIF ! see if we have atomic relativistic corrections - CALL get_qs_env(qs_env,rel_control=rel_control,error=error) + CALL get_qs_env(qs_env,rel_control=rel_control) IF (rel_control%rel_method /= rel_none) THEN IF (rel_control%rel_transformation == rel_trans_atom) THEN nkind = SIZE(atomic_kind_set) DO ikind=1,nkind NULLIFY(rtmat) - CALL calculate_atomic_relkin(atomic_kind_set(ikind), qs_kind_set(ikind),rel_control,rtmat,error) - IF(ASSOCIATED(rtmat)) CALL set_qs_kind(qs_kind_set(ikind), reltmat=rtmat,error=error) + CALL calculate_atomic_relkin(atomic_kind_set(ikind), qs_kind_set(ikind),rel_control,rtmat) + IF(ASSOCIATED(rtmat)) CALL set_qs_kind(qs_kind_set(ikind), reltmat=rtmat) END DO END IF END IF - CALL qs_subsys_release(subsys, error=error) - CALL qs_ks_release(ks_env, error=error) + CALL qs_subsys_release(subsys) + CALL qs_ks_release(ks_env) END SUBROUTINE qs_init ! ***************************************************************************** @@ -421,11 +417,10 @@ END SUBROUTINE qs_init !> \param use_ref_cell ... !> \param root_section ... !> \param subsys_section ... -!> \param error ... !> \author Creation (22.05.2000,MK) ! ***************************************************************************** SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& - root_section,subsys_section,error) + root_section,subsys_section) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env @@ -433,7 +428,6 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& TYPE(cell_type), POINTER :: cell, cell_ref LOGICAL, INTENT(in) :: use_ref_cell TYPE(section_vals_type), POINTER :: root_section, subsys_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_init_subsys', & routineP = moduleN//':'//routineN @@ -494,7 +488,7 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& failure = .FALSE. CALL timeset(routineN,handle) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) was_present = .FALSE. @@ -509,28 +503,27 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& NULLIFY (dft_section) NULLIFY (et_coupling_section) NULLIFY (ks_env) - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) - qs_section => section_vals_get_subs_vals(dft_section,"QS",error=error) - et_coupling_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%ET_COUPLING",error=error) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") + qs_section => section_vals_get_subs_vals(dft_section,"QS") + et_coupling_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%ET_COUPLING") CALL qs_subsys_get(subsys, particle_set=particle_set,& qs_kind_set=qs_kind_set,& atomic_kind_set=atomic_kind_set,& molecule_set=molecule_set,& - molecule_kind_set=molecule_kind_set,& - error=error) + molecule_kind_set=molecule_kind_set) ! *** Read the input section with the DFT control parameters *** - CALL read_dft_control(dft_control,dft_section,error=error) + CALL read_dft_control(dft_control,dft_section) IF (dft_control % do_tddfpt_calculation) THEN CALL read_tddfpt_control(dft_control%tddfpt_control, & - dft_section,error) + dft_section) END IF ! *** Print the Quickstep program banner (copyright and version number) *** - iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%PROGRAM_BANNER",extension=".Log",error=error) - CALL section_vals_val_get(qs_section,"METHOD",i_val=method_id,error=error) + iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%PROGRAM_BANNER",extension=".Log") + CALL section_vals_val_get(qs_section,"METHOD",i_val=method_id) SELECT CASE (method_id) CASE DEFAULT CALL qs_header(iw) @@ -544,83 +537,83 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& END SELECT CALL cp_print_key_finished_output(iw,logger,dft_section,& - "PRINT%PROGRAM_BANNER",error=error) + "PRINT%PROGRAM_BANNER") ! *** Read the input section with the Quickstep control parameters *** - CALL read_qs_section(dft_control%qs_control,qs_section,error=error) + CALL read_qs_section(dft_control%qs_control,qs_section) ! ******* check if any kind of electron transfer calculation has to be performed - CALL section_vals_val_get(et_coupling_section,"TYPE_OF_CONSTRAINT",i_val=my_ival,error=error) + CALL section_vals_val_get(et_coupling_section,"TYPE_OF_CONSTRAINT",i_val=my_ival) dft_control%qs_control%et_coupling_calc=.FALSE. IF (my_ival==do_et_ddapc)THEN - et_ddapc_section => section_vals_get_subs_vals(et_coupling_section,"DDAPC_RESTRAINT_A",error=error) + et_ddapc_section => section_vals_get_subs_vals(et_coupling_section,"DDAPC_RESTRAINT_A") dft_control%qs_control%et_coupling_calc=.TRUE. dft_control%qs_control%ddapc_restraint=.TRUE. - CALL read_ddapc_section(dft_control%qs_control,ddapc_restraint_section=et_ddapc_section,error=error) + CALL read_ddapc_section(dft_control%qs_control,ddapc_restraint_section=et_ddapc_section) ENDIF IF (my_ival==do_et_becke)THEN dft_control%qs_control%becke_restraint=.TRUE. dft_control%qs_control%et_coupling_calc=.TRUE. - et_becke_section => section_vals_get_subs_vals(et_coupling_section,"BECKE_RESTRAINT_A",error=error) - CALL read_becke_section(dft_control%qs_control,et_becke_section,error) + et_becke_section => section_vals_get_subs_vals(et_coupling_section,"BECKE_RESTRAINT_A") + CALL read_becke_section(dft_control%qs_control,et_becke_section) END IF - CALL read_mgrid_section(dft_control%qs_control,dft_section,para_env=para_env,error=error) + CALL read_mgrid_section(dft_control%qs_control,dft_section,para_env=para_env) ! Create relativistic control section - CALL rel_c_create(rel_control,error=error) - CALL rel_c_read_parameters(rel_control,dft_section,error=error) - CALL set_qs_env(qs_env,rel_control=rel_control,error=error) - CALL rel_c_release(rel_control,error=error) + CALL rel_c_create(rel_control) + CALL rel_c_read_parameters(rel_control,dft_section) + CALL set_qs_env(qs_env,rel_control=rel_control) + CALL rel_c_release(rel_control) ! *** Read DFTB parameter files *** IF ( dft_control%qs_control%method == "DFTB" ) THEN NULLIFY (ewald_env,ewald_pw,dftb_potential) dftb_control => dft_control%qs_control%dftb_control CALL qs_dftb_param_init (atomic_kind_set,qs_kind_set,dftb_control,dftb_potential,& - subsys_section=subsys_section,para_env=para_env,error=error) - CALL set_qs_env(qs_env,dftb_potential=dftb_potential,error=error) + subsys_section=subsys_section,para_env=para_env) + CALL set_qs_env(qs_env,dftb_potential=dftb_potential) ! check for Ewald IF ( dftb_control%do_ewald ) THEN - CALL ewald_env_create(ewald_env,para_env,error=error) - poisson_section => section_vals_get_subs_vals(dft_section,"POISSON",error=error) - CALL ewald_env_set(ewald_env,poisson_section=poisson_section,error=error) - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD",error=error) - print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION",error=error) - CALL read_ewald_section(ewald_env,ewald_section,error=error) - CALL ewald_pw_create(ewald_pw,ewald_env,cell,cell_ref,print_section=print_section,error=error) - CALL set_qs_env(qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw,error=error) - CALL ewald_env_release(ewald_env,error=error) - CALL ewald_pw_release(ewald_pw,error=error) + CALL ewald_env_create(ewald_env,para_env) + poisson_section => section_vals_get_subs_vals(dft_section,"POISSON") + CALL ewald_env_set(ewald_env,poisson_section=poisson_section) + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD") + print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION") + CALL read_ewald_section(ewald_env,ewald_section) + CALL ewald_pw_create(ewald_pw,ewald_env,cell,cell_ref,print_section=print_section) + CALL set_qs_env(qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) + CALL ewald_env_release(ewald_env) + CALL ewald_pw_release(ewald_pw) END IF ELSE IF ( dft_control%qs_control%method == "SCPTB" ) THEN scptb_control => dft_control%qs_control%scptb_control - print_section => section_vals_get_subs_vals(subsys_section,"PRINT",error=error) - CALL scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_section,para_env,error) + print_section => section_vals_get_subs_vals(subsys_section,"PRINT") + CALL scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_section,para_env) ! check for Ewald IF ( scptb_control%do_ewald ) THEN - CALL ewald_env_create(ewald_env,para_env,error=error) - poisson_section => section_vals_get_subs_vals(dft_section,"POISSON",error=error) - CALL ewald_env_set(ewald_env,poisson_section=poisson_section,error=error) - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD",error=error) - print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION",error=error) - CALL read_ewald_section(ewald_env,ewald_section,error=error) - CALL ewald_pw_create(ewald_pw,ewald_env,cell,cell_ref,print_section=print_section,error=error) - CALL set_qs_env(qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw,error=error) - CALL ewald_env_release(ewald_env,error=error) - CALL ewald_pw_release(ewald_pw,error=error) + CALL ewald_env_create(ewald_env,para_env) + poisson_section => section_vals_get_subs_vals(dft_section,"POISSON") + CALL ewald_env_set(ewald_env,poisson_section=poisson_section) + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD") + print_section => section_vals_get_subs_vals(qs_env%input,"PRINT%GRID_INFORMATION") + CALL read_ewald_section(ewald_env,ewald_section) + CALL ewald_pw_create(ewald_pw,ewald_env,cell,cell_ref,print_section=print_section) + CALL set_qs_env(qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) + CALL ewald_env_release(ewald_env) + CALL ewald_pw_release(ewald_pw) END IF END IF ! DFT+U - CALL get_qs_kind_set(qs_kind_set, dft_plus_u_atom_present=dft_control%dft_plus_u,error=error) + CALL get_qs_kind_set(qs_kind_set, dft_plus_u_atom_present=dft_control%dft_plus_u) ! *** Check basis and fill in missing parts *** CALL check_qs_kind_set(qs_kind_set,dft_control,para_env,& - subsys_section=subsys_section,error=error) + subsys_section=subsys_section) ! *** Check that no all-electron potential is present if GPW or GAPW_XC - CALL get_qs_kind_set(qs_kind_set, all_potential_present=all_potential_present,error=error) + CALL get_qs_kind_set(qs_kind_set, all_potential_present=all_potential_present) IF ( (dft_control%qs_control%method == "GPW") .OR. & (dft_control%qs_control%method == "GAPW_XC") .OR. & (dft_control%qs_control%method == "OFGPW") ) THEN @@ -633,7 +626,7 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& ! *** Initialize the spherical harmonics and *** ! *** the orbital transformation matrices *** - CALL get_qs_kind_set(qs_kind_set, maxlgto=maxlgto, maxlppl=maxlppl, maxlppnl=maxlppnl,error=error) + CALL get_qs_kind_set(qs_kind_set, maxlgto=maxlgto, maxlppl=maxlppl, maxlppnl=maxlppnl) lmax_sphere = dft_control%qs_control%gapw_control%lmax_sphere IF(lmax_sphere .LT.0) THEN @@ -641,7 +634,7 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& dft_control%qs_control%gapw_control%lmax_sphere= lmax_sphere END IF IF(dft_control%qs_control%method == "LRIGPW".OR.dft_control%qs_control%lri_optbas) THEN - CALL get_qs_kind_set(qs_kind_set,maxlgto=maxlgto_lri,basis_type="LRI",error=error) + CALL get_qs_kind_set(qs_kind_set,maxlgto=maxlgto_lri,basis_type="LRI") !take maxlgto from lri basis if larger (usually) maxlgto = MAX(maxlgto,maxlgto_lri) END IF @@ -650,38 +643,38 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& CALL init_orbital_pointers(maxl) output_unit = cp_print_key_unit_nr(logger,root_section,"GLOBAL%PRINT/SPHERICAL_HARMONICS",& - extension=".Log",error=error) - CALL init_spherical_harmonics(maxl,output_unit,error) + extension=".Log") + CALL init_spherical_harmonics(maxl,output_unit) CALL cp_print_key_finished_output(output_unit,logger,root_section,& - "GLOBAL%PRINT/SPHERICAL_HARMONICS",error=error) + "GLOBAL%PRINT/SPHERICAL_HARMONICS") ! *** Initialise the qs_kind_set *** - CALL init_qs_kind_set(qs_kind_set,error) + CALL init_qs_kind_set(qs_kind_set) ! *** Initialise GAPW soft basis and projectors IF(dft_control%qs_control%method == "GAPW" .OR. & dft_control%qs_control%method == "GAPW_XC") THEN qs_control => dft_control%qs_control gapw_control => dft_control%qs_control%gapw_control - CALL init_gapw_basis_set(qs_kind_set,qs_control,qs_env%input,error) + CALL init_gapw_basis_set(qs_kind_set,qs_control,qs_env%input) ENDIF ! *** Initialize the pretabulation for the calculation of the *** ! *** incomplete Gamma function F_n(t) after McMurchie-Davidson *** - CALL get_qs_kind_set(qs_kind_set, maxlgto=maxlgto,error=error) + CALL get_qs_kind_set(qs_kind_set, maxlgto=maxlgto) maxl = MAX(3*maxlgto + 1,0) CALL init_md_ftable(maxl) ! *** Initialize the atomic interaction radii *** - CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set,qs_kind_set,error) + CALL init_interaction_radii(dft_control%qs_control,atomic_kind_set,qs_kind_set) - CALL write_pgf_orb_radii("orb",atomic_kind_set,qs_kind_set,subsys_section,error) - CALL write_pgf_orb_radii("aux",atomic_kind_set,qs_kind_set,subsys_section,error) - CALL write_pgf_orb_radii("lri",atomic_kind_set,qs_kind_set,subsys_section,error) - CALL write_core_charge_radii(atomic_kind_set,qs_kind_set,subsys_section,error) - CALL write_ppl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) - CALL write_ppnl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) - CALL write_paw_radii(atomic_kind_set,qs_kind_set,subsys_section,error) + CALL write_pgf_orb_radii("orb",atomic_kind_set,qs_kind_set,subsys_section) + CALL write_pgf_orb_radii("aux",atomic_kind_set,qs_kind_set,subsys_section) + CALL write_pgf_orb_radii("lri",atomic_kind_set,qs_kind_set,subsys_section) + CALL write_core_charge_radii(atomic_kind_set,qs_kind_set,subsys_section) + CALL write_ppl_radii(atomic_kind_set,qs_kind_set,subsys_section) + CALL write_ppnl_radii(atomic_kind_set,qs_kind_set,subsys_section) + CALL write_paw_radii(atomic_kind_set,qs_kind_set,subsys_section) ! *** Distribute molecules and atoms using the new data structures *** @@ -691,12 +684,11 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& molecule_kind_set=molecule_kind_set,& molecule_set=molecule_set,& local_molecules=local_molecules,& - force_env_section=qs_env%input,& - error=error) + force_env_section=qs_env%input) ! *** SCF parameters *** - CALL scf_c_create(scf_control,error=error) - CALL scf_c_read_parameters(scf_control,dft_section,error=error) + CALL scf_c_create(scf_control) + CALL scf_c_read_parameters(scf_control,dft_section) ! *** Allocate the data structure for Quickstep energies *** CALL allocate_qs_energy(energy) @@ -709,56 +701,53 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& IF (dft_control%qs_control%dftb) THEN IF (dft_control%qs_control%dftb_control%orthogonal_basis) has_unit_metric = .TRUE. END IF - CALL set_qs_env(qs_env,has_unit_metric=has_unit_metric,error=error) + CALL set_qs_env(qs_env,has_unit_metric=has_unit_metric) ! *** Activate the interpolation *** CALL wfi_create(wf_history,& interpolation_method_nr=& dft_control%qs_control%wf_interpolation_method_nr,& extrapolation_order = dft_control%qs_control%wf_extrapolation_order,& - has_unit_metric = has_unit_metric, & - error=error) + has_unit_metric = has_unit_metric) ! *** Set the current Quickstep environment *** CALL set_qs_env(qs_env=qs_env,& scf_control=scf_control,& - wf_history=wf_history,& - error=error) + wf_history=wf_history) CALL qs_subsys_set(subsys,& cell_ref=cell_ref,& use_ref_cell=use_ref_cell,& energy=energy,& - force=force,& - error=error) + force=force) - CALL get_qs_env(qs_env, ks_env=ks_env, error=error) - CALL set_ks_env(ks_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, ks_env=ks_env) + CALL set_ks_env(ks_env, dft_control=dft_control) CALL qs_subsys_set(subsys,local_molecules_new=local_molecules,& - local_particles=local_particles,cell=cell,error=error) + local_particles=local_particles,cell=cell) - CALL distribution_1d_release(local_particles,error=error) - CALL distribution_1d_release(local_molecules,error=error) - CALL scf_c_release(scf_control,error=error) - CALL wfi_release(wf_history,error=error) - CALL dft_control_release(dft_control, error=error) + CALL distribution_1d_release(local_particles) + CALL distribution_1d_release(local_molecules) + CALL scf_c_release(scf_control) + CALL wfi_release(wf_history) + CALL dft_control_release(dft_control) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& dft_control=dft_control,& - scf_control=scf_control,error=error) + scf_control=scf_control) ! decide what conditions need mo_derivs ! right now, this only appears to be OT IF (dft_control%qs_control%do_ls_scf .OR. & dft_control%qs_control%do_almo_scf) THEN - CALL set_qs_env(qs_env=qs_env,requires_mo_derivs=.FALSE.,error=error) + CALL set_qs_env(qs_env=qs_env,requires_mo_derivs=.FALSE.) ELSE IF (scf_control%use_ot) THEN - CALL set_qs_env(qs_env=qs_env,requires_mo_derivs=.TRUE.,error=error) + CALL set_qs_env(qs_env=qs_env,requires_mo_derivs=.TRUE.) ELSE - CALL set_qs_env(qs_env=qs_env,requires_mo_derivs=.FALSE.,error=error) + CALL set_qs_env(qs_env=qs_env,requires_mo_derivs=.FALSE.) ENDIF ENDIF @@ -769,24 +758,24 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& IF (dft_control%qs_control%method_id == do_method_gapw .OR. & dft_control%qs_control%method_id == do_method_gapw_xc) THEN ! *** Allocate and initialize the set of atomic densities *** - CALL init_rho_atom(qs_env,gapw_control,error=error) + CALL init_rho_atom(qs_env,gapw_control) IF(dft_control%qs_control%method_id /= do_method_gapw_xc) THEN - CALL get_qs_env(qs_env=qs_env,natom=natom,error=error) + CALL get_qs_env(qs_env=qs_env,natom=natom) ! *** Allocate and initialize the compensation density rho0 *** - CALL init_rho0(qs_env,gapw_control,error=error) + CALL init_rho0(qs_env,gapw_control) ! *** Allocate and Initialize the local coulomb term *** - CALL init_coulomb_local(qs_env%hartree_local,natom,error=error) + CALL init_coulomb_local(qs_env%hartree_local,natom) END IF ELSE IF (dft_control%qs_control%method_id == do_method_lrigpw) THEN ! allocate local ri environment ELSE IF(dft_control%qs_control%semi_empirical) THEN NULLIFY(se_store_int_env, se_nddo_mpole, se_nonbond_env) natom = SIZE(particle_set) - se_section => section_vals_get_subs_vals(qs_section,"SE",error=error) + se_section => section_vals_get_subs_vals(qs_section,"SE") se_control => dft_control%qs_control%se_control ! Make the cutoff radii choice a bit smarter - CALL se_cutoff_compatible(se_control, se_section, cell, output_unit, error) + CALL se_cutoff_compatible(se_control, se_section, cell, output_unit) SELECT CASE ( dft_control%qs_control%method_id) CASE DEFAULT @@ -794,57 +783,55 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& do_method_pm6,do_method_mndod,do_method_pnnl) ! Neighbor lists have to be MAX(interaction range, orbital range) ! set new kind radius - CALL init_se_nlradius(se_control,atomic_kind_set,qs_kind_set,subsys_section,error) + CALL init_se_nlradius(se_control,atomic_kind_set,qs_kind_set,subsys_section) END SELECT ! Initialize to zero the max multipole to treat in the EWALD scheme.. se_control%max_multipole = do_multipole_none ! check for Ewald IF (se_control%do_ewald .OR. se_control%do_ewald_gks) THEN - CALL ewald_env_create(ewald_env,para_env,error=error) - poisson_section => section_vals_get_subs_vals(dft_section,"POISSON",error=error) - CALL ewald_env_set(ewald_env,poisson_section=poisson_section,error=error) - ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD",error=error) + CALL ewald_env_create(ewald_env,para_env) + poisson_section => section_vals_get_subs_vals(dft_section,"POISSON") + CALL ewald_env_set(ewald_env,poisson_section=poisson_section) + ewald_section => section_vals_get_subs_vals(poisson_section,"EWALD") print_section => section_vals_get_subs_vals(qs_env%input,& - "PRINT%GRID_INFORMATION",error=error) - CALL read_ewald_section(ewald_env,ewald_section,error=error) + "PRINT%GRID_INFORMATION") + CALL read_ewald_section(ewald_env,ewald_section) ! Create ewald grids CALL ewald_pw_create(ewald_pw,ewald_env,cell,cell_ref,& - print_section=print_section,error=error) + print_section=print_section) ! Initialize ewald grids - CALL ewald_pw_grid_update(ewald_pw, ewald_env, cell%hmat, error) + CALL ewald_pw_grid_update(ewald_pw, ewald_env, cell%hmat) ! Setup the nonbond environment (real space part of Ewald) - CALL ewald_env_get(ewald_env, rcut=ewald_rcut, error=error) + CALL ewald_env_get(ewald_env, rcut=ewald_rcut) ! Setup the maximum level of multipoles to be treated in the periodic SE scheme IF (se_control%do_ewald) THEN - CALL ewald_env_get(ewald_env, max_multipole=se_control%max_multipole, error=error) + CALL ewald_env_get(ewald_env, max_multipole=se_control%max_multipole) ENDIF CALL section_vals_val_get(se_section,"NEIGHBOR_LISTS%VERLET_SKIN",& - r_val=verlet_skin,error=error) + r_val=verlet_skin) CALL fist_nonbond_env_create(se_nonbond_env, atomic_kind_set, & do_nonbonded=.TRUE., verlet_skin=verlet_skin, ewald_rcut=ewald_rcut, & - ei_scale14=0.0_dp, vdw_scale14=0.0_dp, shift_cutoff=.FALSE., & - error=error) + ei_scale14=0.0_dp, vdw_scale14=0.0_dp, shift_cutoff=.FALSE.) ! Create and Setup NDDO multipole environment - CALL nddo_mpole_setup(se_nddo_mpole, natom, error) + CALL nddo_mpole_setup(se_nddo_mpole, natom) CALL set_qs_env(qs_env,ewald_env=ewald_env, ewald_pw=ewald_pw,& - se_nonbond_env=se_nonbond_env, se_nddo_mpole=se_nddo_mpole,& - error=error) - CALL ewald_env_release(ewald_env,error=error) - CALL ewald_pw_release(ewald_pw,error=error) + se_nonbond_env=se_nonbond_env, se_nddo_mpole=se_nddo_mpole) + CALL ewald_env_release(ewald_env) + CALL ewald_pw_release(ewald_pw) ! Handle the residual integral part 1/R^3 CALL semi_empirical_expns3_setup(qs_kind_set, se_control,& - dft_control%qs_control%method_id,error) + dft_control%qs_control%method_id) END IF ! Taper function CALL se_taper_create(se_taper, se_control%integral_screening, se_control%do_ewald,& se_control%taper_cou, se_control%range_cou, & se_control%taper_exc, se_control%range_exc, & se_control%taper_scr, se_control%range_scr, & - se_control%taper_lrc, se_control%range_lrc, error) - CALL set_qs_env(qs_env, se_taper=se_taper, error=error) + se_control%taper_lrc, se_control%range_lrc) + CALL set_qs_env(qs_env, se_taper=se_taper) ! Store integral environment - CALL semi_empirical_si_create(se_store_int_env, se_section, error=error) - CALL set_qs_env(qs_env, se_store_int_env=se_store_int_env, error=error) + CALL semi_empirical_si_create(se_store_int_env, se_section) + CALL set_qs_env(qs_env, se_store_int_env=se_store_int_env) ENDIF ! Initialize possible dispersion parameters @@ -854,23 +841,23 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& dft_control%qs_control%method_id == do_method_lrigpw .OR. & dft_control%qs_control%method_id == do_method_ofgpw) THEN ALLOCATE(dispersion_env,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(xc_section) - xc_section => section_vals_get_subs_vals(dft_section,"XC",error=error) - CALL qs_dispersion_env_set(dispersion_env,xc_section,error) + xc_section => section_vals_get_subs_vals(dft_section,"XC") + CALL qs_dispersion_env_set(dispersion_env,xc_section) IF ( dispersion_env%type == xc_vdw_fun_pairpot ) THEN NULLIFY(pp_section) - pp_section => section_vals_get_subs_vals(xc_section,"VDW_POTENTIAL%PAIR_POTENTIAL",error=error) - CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,pp_section,para_env,error) + pp_section => section_vals_get_subs_vals(xc_section,"VDW_POTENTIAL%PAIR_POTENTIAL") + CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,pp_section,para_env) ELSE IF ( dispersion_env%type == xc_vdw_fun_nonloc ) THEN NULLIFY(nl_section) - nl_section => section_vals_get_subs_vals(xc_section,"VDW_POTENTIAL%NON_LOCAL",error=error) - CALL qs_dispersion_nonloc_init(dispersion_env,para_env,error) + nl_section => section_vals_get_subs_vals(xc_section,"VDW_POTENTIAL%NON_LOCAL") + CALL qs_dispersion_nonloc_init(dispersion_env,para_env) END IF - CALL set_qs_env(qs_env, dispersion_env=dispersion_env, error=error) + CALL set_qs_env(qs_env, dispersion_env=dispersion_env) ELSE IF (dft_control%qs_control%method_id == do_method_scptb) THEN ALLOCATE(dispersion_env,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! set general defaults dispersion_env%doabc=.FALSE. dispersion_env%c9cnst=.FALSE. @@ -892,14 +879,14 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& dispersion_env%exp_pre = 0._dp dispersion_env%scaling = 0._dp dispersion_env%parameter_file_name = scptb_control%dispersion_parameter_file - CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,para_env=para_env,error=error) + CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,para_env=para_env) ELSE dispersion_env%type = xc_vdw_fun_none END IF - CALL set_qs_env(qs_env, dispersion_env=dispersion_env, error=error) + CALL set_qs_env(qs_env, dispersion_env=dispersion_env) ELSE IF (dft_control%qs_control%method_id == do_method_dftb) THEN ALLOCATE(dispersion_env,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! set general defaults dispersion_env%doabc=.FALSE. dispersion_env%c9cnst=.FALSE. @@ -921,14 +908,14 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& dispersion_env%exp_pre = 0._dp dispersion_env%scaling = 0._dp dispersion_env%parameter_file_name = dftb_control%dispersion_parameter_file - CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,para_env=para_env,error=error) + CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,para_env=para_env) ELSE dispersion_env%type = xc_vdw_fun_none END IF - CALL set_qs_env(qs_env, dispersion_env=dispersion_env, error=error) + CALL set_qs_env(qs_env, dispersion_env=dispersion_env) ELSE IF(dft_control%qs_control%semi_empirical) THEN ALLOCATE(dispersion_env,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! set general defaults dispersion_env%doabc=.FALSE. dispersion_env%c9cnst=.FALSE. @@ -950,15 +937,15 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& dispersion_env%exp_pre = 0._dp dispersion_env%scaling = 0._dp dispersion_env%parameter_file_name = se_control%dispersion_parameter_file - CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,para_env=para_env,error=error) + CALL qs_dispersion_pairpot_init(atomic_kind_set,qs_kind_set,dispersion_env,para_env=para_env) ELSE dispersion_env%type = xc_vdw_fun_none END IF - CALL set_qs_env(qs_env, dispersion_env=dispersion_env, error=error) + CALL set_qs_env(qs_env, dispersion_env=dispersion_env) END IF ! *** Allocate the MO data types *** - CALL get_qs_kind_set(qs_kind_set, nsgf=n_ao, nelectron=nelectron,error=error) + CALL get_qs_kind_set(qs_kind_set, nsgf=n_ao, nelectron=nelectron) ! the total number of electrons nelectron = nelectron - dft_control%charge @@ -1065,8 +1052,7 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& ! store the number of electrons once an for all CALL qs_subsys_set(subsys,& nelectron_total=nelectron,& - nelectron_spin=nelectron_spin,& - error=error) + nelectron_spin=nelectron_spin) ! Check and set number of added (unoccupied) MOs CALL cp_assert((scf_control%added_mos(1) <= n_ao - n_mo(1)),cp_warning_level,& @@ -1108,7 +1094,7 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& ! *** Some options require that all MOs are computed ... *** IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,& - "PRINT%MO/CARTESIAN",error=error),& + "PRINT%MO/CARTESIAN"),& cp_p_file).OR.& (scf_control%level_shift /= 0.0_dp).OR.& (scf_control%diagonalization%eps_jacobi /= 0.0_dp).OR.& @@ -1150,7 +1136,7 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& NULLIFY(mos) ELSE ALLOCATE (mos(dft_control%nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins NULLIFY (mos(ispin)%mo_set) CALL allocate_mo_set(mo_set=mos(ispin)%mo_set,& @@ -1159,19 +1145,18 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& nelectron=nelectron_spin(ispin),& n_el_f=REAL(nelectron_spin(ispin),dp),& maxocc=maxocc,& - flexible_electron_count=dft_control%relax_multiplicity,& - error=error) + flexible_electron_count=dft_control%relax_multiplicity) END DO END IF - CALL set_qs_env(qs_env,mos=mos,error=error) + CALL set_qs_env(qs_env,mos=mos) ! If we use auxiliary density matrix methods , set mo_set_aux_fit IF( dft_control%do_admm ) THEN CALL get_qs_kind_set(qs_kind_set, nelectron=nelectron, nsgf=n_ao_aux_fit, & - basis_type="AUX_FIT",error=error) + basis_type="AUX_FIT") ALLOCATE (mos_aux_fit(dft_control%nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins NULLIFY (mos_aux_fit(ispin)%mo_set) @@ -1181,15 +1166,14 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& nelectron=nelectron_spin(ispin),& n_el_f=REAL(nelectron_spin(ispin),dp),& maxocc=maxocc,& - flexible_electron_count=dft_control%relax_multiplicity,& - error=error) + flexible_electron_count=dft_control%relax_multiplicity) END DO - CALL set_qs_env(qs_env,mos_aux_fit=mos_aux_fit,error=error) + CALL set_qs_env(qs_env,mos_aux_fit=mos_aux_fit) END IF ! Print the DFT control parameters - CALL write_dft_control(dft_control,dft_section,error) + CALL write_dft_control(dft_control,dft_section) ! Print the vdW control parameters IF (dft_control%qs_control%method_id == do_method_gpw .OR. & @@ -1199,56 +1183,56 @@ SUBROUTINE qs_init_subsys(qs_env,para_env,subsys,cell,cell_ref,use_ref_cell,& dft_control%qs_control%method_id == do_method_scptb .OR. & dft_control%qs_control%method_id == do_method_dftb .OR. & dft_control%qs_control%method_id == do_method_ofgpw) THEN - CALL get_qs_env(qs_env,dispersion_env=dispersion_env,error=error) - CALL qs_write_dispersion(qs_env,dispersion_env,error=error) + CALL get_qs_env(qs_env,dispersion_env=dispersion_env) + CALL qs_write_dispersion(qs_env,dispersion_env) END IF ! Print the Quickstep control parameters - CALL write_qs_control(dft_control%qs_control,dft_section,error) + CALL write_qs_control(dft_control%qs_control,dft_section) ! Print XES/XAS control parameters IF (dft_control%do_xas_calculation) THEN CALL cite_reference(Iannuzzi2007) -! CALL write_xas_control(dft_control%xas_control,dft_section,error=error) +! CALL write_xas_control(dft_control%xas_control,dft_section) END IF ! Print the unnormalized basis set information (input data) - CALL write_gto_basis_sets(qs_kind_set,subsys_section,error=error) + CALL write_gto_basis_sets(qs_kind_set,subsys_section) ! Print the atomic kind set - CALL write_qs_kind_set(qs_kind_set,subsys_section,error) + CALL write_qs_kind_set(qs_kind_set,subsys_section) ! Print the molecule kind set - CALL write_molecule_kind_set(molecule_kind_set,subsys_section,error) + CALL write_molecule_kind_set(molecule_kind_set,subsys_section) ! Print the total number of kinds, atoms, basis functions etc. - CALL write_total_numbers(qs_kind_set,particle_set,qs_env%input,error) + CALL write_total_numbers(qs_kind_set,particle_set,qs_env%input) ! Print the atomic coordinates - CALL write_qs_particle_coordinates(particle_set, qs_kind_set, subsys_section,label="QUICKSTEP",error=error) + CALL write_qs_particle_coordinates(particle_set, qs_kind_set, subsys_section,label="QUICKSTEP") ! Print the interatomic distances - CALL write_particle_distances(particle_set,cell,subsys_section,error) + CALL write_particle_distances(particle_set,cell,subsys_section) ! Print the requested structure data - CALL write_structure_data(particle_set,cell,subsys_section,error) + CALL write_structure_data(particle_set,cell,subsys_section) ! Print symmetry information - CALL write_symmetry(particle_set,cell,subsys_section,error) + CALL write_symmetry(particle_set,cell,subsys_section) ! Print the SCF parameters IF ((.NOT. dft_control%qs_control%do_ls_scf) .AND. & (.NOT. dft_control%qs_control%do_almo_scf) ) THEN - CALL scf_c_write_parameters(scf_control,dft_section,error=error) + CALL scf_c_write_parameters(scf_control,dft_section) ENDIF ! Sets up pw_env, qs_charges, mpools ... - CALL qs_env_setup(qs_env,cp_logger_get_default_io_unit(logger),error) + CALL qs_env_setup(qs_env,cp_logger_get_default_io_unit(logger)) ! Allocate and Initialie rho0 soft on the global grid IF(dft_control%qs_control%method == "GAPW") THEN - CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole,error=error) - CALL rho0_s_grid_create(qs_env, rho0_mpole, error=error) + CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole) + CALL rho0_s_grid_create(qs_env, rho0_mpole) END IF IF (output_unit>0) CALL m_flush(output_unit) @@ -1262,17 +1246,15 @@ END SUBROUTINE qs_init_subsys !> \param qs_kind_set ... !> \param particle_set ... !> \param force_env_section ... -!> \param error ... !> \author Creation (06.10.2000) ! ***************************************************************************** - SUBROUTINE write_total_numbers(qs_kind_set,particle_set,force_env_section,error) + SUBROUTINE write_total_numbers(qs_kind_set,particle_set,force_env_section) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_total_numbers', & routineP = moduleN//':'//routineN @@ -1284,9 +1266,9 @@ SUBROUTINE write_total_numbers(qs_kind_set,particle_set,force_env_section,error) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,force_env_section,"PRINT%TOTAL_NUMBERS",& - extension=".Log",error=error) + extension=".Log") IF (output_unit>0) THEN natom = SIZE(particle_set) @@ -1300,7 +1282,7 @@ SUBROUTINE write_total_numbers(qs_kind_set,particle_set,force_env_section,error) nsgf=nsgf,& nshell=nshell,& maxlppl=maxlppl,& - maxlppnl=maxlppnl,error=error) + maxlppnl=maxlppnl) WRITE (UNIT=output_unit,FMT="(/,/,T2,A)")& "TOTAL NUMBERS AND MAXIMUM NUMBERS" @@ -1347,7 +1329,7 @@ SUBROUTINE write_total_numbers(qs_kind_set,particle_set,force_env_section,error) END IF CALL cp_print_key_finished_output(output_unit,logger,force_env_section,& - "PRINT%TOTAL_NUMBERS",error=error) + "PRINT%TOTAL_NUMBERS") END SUBROUTINE write_total_numbers diff --git a/src/qs_environment_methods.F b/src/qs_environment_methods.F index e65adcc4d3..012b3f16c4 100644 --- a/src/qs_environment_methods.F +++ b/src/qs_environment_methods.F @@ -102,17 +102,14 @@ MODULE qs_environment_methods !> Initializes pools, charges and pw_env. !> \param qs_env the qs_env to set up !> \param unit_nr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE qs_env_setup(qs_env,unit_nr,error) +SUBROUTINE qs_env_setup(qs_env,unit_nr) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_env_setup', & routineP = moduleN//':'//routineN @@ -160,47 +157,44 @@ SUBROUTINE qs_env_setup(qs_env,unit_nr,error) para_env=para_env,& blacs_env=blacs_env,& cell=cell,& - ks_env=ks_env,& - error=error) + ks_env=ks_env) - CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,failure) ! allocate qs_charges - CALL qs_charges_create(qs_charges,nspins=dft_control%nspins,error=error) - CALL set_qs_env(qs_env, qs_charges=qs_charges,error=error) - CALL qs_charges_release(qs_charges,error=error) + CALL qs_charges_create(qs_charges,nspins=dft_control%nspins) + CALL set_qs_env(qs_env, qs_charges=qs_charges) + CALL qs_charges_release(qs_charges) ! outer scf setup IF (scf_control%outer_scf%have_scf) THEN - nvariables=outer_loop_variables_count(scf_control,error=error) + nvariables=outer_loop_variables_count(scf_control) nhistory=scf_control%outer_scf%extrapolation_order ALLOCATE(outer_scf_history(nvariables,nhistory),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CALL set_qs_env(qs_env,outer_scf_history=outer_scf_history,error=error) - CALL set_qs_env(qs_env,outer_scf_ihistory=0,error=error) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CALL set_qs_env(qs_env,outer_scf_history=outer_scf_history) + CALL set_qs_env(qs_env,outer_scf_ihistory=0) ENDIF ! set up pw_env - CALL qs_env_rebuild_pw_env(qs_env, error=error) + CALL qs_env_rebuild_pw_env(qs_env) ! rebuilds fm_pools ! XXXX should get rid of the mpools IF (ASSOCIATED(qs_env%mos)) THEN CALL mpools_rebuild_fm_pools(qs_env%mpools,mos=qs_env%mos,& - blacs_env=blacs_env, para_env=para_env,& - error=error) + blacs_env=blacs_env, para_env=para_env) ENDIF ! If we use auxiliary density matrix methods rebuild fm_pools IF(dft_control%do_admm) THEN CALL get_qs_kind_set(qs_kind_set, nsgf=n_ao_aux_fit,& - basis_type="AUX_FIT",error=error) + basis_type="AUX_FIT") CALL mpools_rebuild_fm_pools(qs_env%mpools_aux_fit,mos=qs_env%mos_aux_fit,& - blacs_env=blacs_env, para_env=para_env,& - error=error) + blacs_env=blacs_env, para_env=para_env) END IF ! create 2d distribution @@ -213,16 +207,16 @@ SUBROUTINE qs_env_setup(qs_env,unit_nr,error) molecule_set=molecule_set,& distribution_2d=distribution_2d,& blacs_env=blacs_env,& - force_env_section=qs_env%input, error=error) + force_env_section=qs_env%input) ! and use it to create the dbcsr_dist, which should be the sole user of distribution_2d by now. ALLOCATE(dbcsr_dist) - CALL cp_dbcsr_dist2d_to_dist(distribution_2d, dbcsr_dist, unit_nr, error) - CALL set_ks_env(ks_env, dbcsr_dist=dbcsr_dist, error=error) + CALL cp_dbcsr_dist2d_to_dist(distribution_2d, dbcsr_dist, unit_nr) + CALL set_ks_env(ks_env, dbcsr_dist=dbcsr_dist) ! also keep distribution_2d in qs_env - CALL set_ks_env(ks_env, distribution_2d=distribution_2d, error=error) - CALL distribution_2d_release(distribution_2d, error=error) + CALL set_ks_env(ks_env, distribution_2d=distribution_2d) + CALL distribution_2d_release(distribution_2d) CALL timestop(handle) @@ -234,15 +228,12 @@ END SUBROUTINE qs_env_setup !> Should be called after the atoms have moved and the new overlap !> has been calculated. !> \param qs_env the environment to update -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE qs_env_update_s_mstruct(qs_env,error) +SUBROUTINE qs_env_update_s_mstruct(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_env_update_s_mstruct', & routineP = moduleN//':'//routineN @@ -256,27 +247,26 @@ SUBROUTINE qs_env_update_s_mstruct(qs_env,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) NULLIFY(dft_control) CALL get_qs_env(qs_env,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! *** updates rho core *** NULLIFY(rho_core) - CALL get_qs_env(qs_env,rho_core=rho_core,error=error) + CALL get_qs_env(qs_env,rho_core=rho_core) IF(dft_control%qs_control%gapw) THEN qs_env%qs_charges%total_rho_core_rspace=qs_env%local_rho_set%rhoz_tot IF(dft_control%qs_control%gapw_control%nopaw_as_gpw) THEN - CPPrecondition(ASSOCIATED(rho_core),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_core),cp_failure_level,routineP,failure) CALL calculate_rho_core(rho_core, & - qs_env%qs_charges%total_rho_core_rspace,qs_env,only_nopaw=.TRUE.,error=error) + qs_env%qs_charges%total_rho_core_rspace,qs_env,only_nopaw=.TRUE.) ELSE IF (ASSOCIATED(rho_core)) THEN - CALL pw_release(rho_core%pw,error=error) + CALL pw_release(rho_core%pw) DEALLOCATE(rho_core,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDIF ENDIF ! force analytic ppl calculation @@ -288,46 +278,46 @@ SUBROUTINE qs_env_update_s_mstruct(qs_env,error) ELSE IF(dft_control%qs_control%scptb) THEN !?? ELSE - CPPrecondition(ASSOCIATED(rho_core),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_core),cp_failure_level,routineP,failure) CALL calculate_rho_core(rho_core, & - qs_env%qs_charges%total_rho_core_rspace,qs_env,error=error) + qs_env%qs_charges%total_rho_core_rspace,qs_env) END IF ! calculate local pseudopotential on grid do_ppl = dft_control%qs_control%do_ppl_method==do_ppl_grid IF ( do_ppl ) THEN NULLIFY(vppl) - CALL get_qs_env(qs_env,vppl=vppl,error=error) - CPPrecondition(ASSOCIATED(vppl),cp_failure_level,routineP,error,failure) - CALL calculate_ppl_grid(vppl,qs_env,error=error) + CALL get_qs_env(qs_env,vppl=vppl) + CPPrecondition(ASSOCIATED(vppl),cp_failure_level,routineP,failure) + CALL calculate_ppl_grid(vppl,qs_env) END IF ! compute the rho_nlcc NULLIFY(rho_nlcc,rho_nlcc_g) - CALL get_qs_env(qs_env,rho_nlcc=rho_nlcc,rho_nlcc_g=rho_nlcc_g,error=error) + CALL get_qs_env(qs_env,rho_nlcc=rho_nlcc,rho_nlcc_g=rho_nlcc_g) IF (ASSOCIATED(rho_nlcc)) THEN - CALL calculate_rho_nlcc(rho_nlcc,qs_env,error=error) - CALL pw_transfer(rho_nlcc%pw,rho_nlcc_g%pw,error=error) + CALL calculate_rho_nlcc(rho_nlcc,qs_env) + CALL pw_transfer(rho_nlcc%pw,rho_nlcc_g%pw) ENDIF ! allocates and creates the task_list - CALL qs_create_task_list(qs_env,error) + CALL qs_create_task_list(qs_env) ! *** environment for ddapc *** IF (ASSOCIATED(qs_env%cp_ddapc_env)) THEN - CALL cp_ddapc_release(qs_env%cp_ddapc_env,error) + CALL cp_ddapc_release(qs_env%cp_ddapc_env) END IF - CALL cp_ddapc_init(qs_env,error) + CALL cp_ddapc_init(qs_env) ! *** tell ks_env *** - CALL qs_ks_did_change(qs_env%ks_env,s_mstruct_changed=.TRUE.,error=error) + CALL qs_ks_did_change(qs_env%ks_env,s_mstruct_changed=.TRUE.) ! *** Updates rho structure *** - CALL qs_env_rebuild_rho(qs_env=qs_env,error=error) + CALL qs_env_rebuild_rho(qs_env=qs_env) ! *** tell scf_env *** IF (ASSOCIATED(qs_env%scf_env)) THEN - CALL scf_env_did_change(qs_env%scf_env,error=error) + CALL scf_env_did_change(qs_env%scf_env) END IF CALL timestop(handle) @@ -337,11 +327,9 @@ END SUBROUTINE qs_env_update_s_mstruct ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE qs_create_task_list(qs_env, error) +SUBROUTINE qs_create_task_list(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_create_task_list', & routineP = moduleN//':'//routineN @@ -359,46 +347,46 @@ SUBROUTINE qs_create_task_list(qs_env, error) CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(ks_env, dft_control) - CALL get_qs_env(qs_env, ks_env=ks_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, ks_env=ks_env, dft_control=dft_control) skip_load_balance_distributed=dft_control%qs_control%skip_load_balance_distributed IF (.NOT. (dft_control%qs_control%semi_empirical .OR. dft_control%qs_control%dftb) ) THEN ! generate task lists (non-soft) IF (.NOT. dft_control%qs_control%gapw) THEN - CALL get_ks_env(ks_env, task_list=task_list, error=error) + CALL get_ks_env(ks_env, task_list=task_list) IF (.NOT. ASSOCIATED(task_list)) THEN - CALL allocate_task_list(task_list,error) - CALL set_ks_env(ks_env, task_list=task_list, error=error) + CALL allocate_task_list(task_list) + CALL set_ks_env(ks_env, task_list=task_list) ENDIF CALL generate_qs_task_list(ks_env, task_list, & reorder_rs_grid_ranks=.TRUE., soft_valid=.FALSE., & - skip_load_balance_distributed=skip_load_balance_distributed, error=error) + skip_load_balance_distributed=skip_load_balance_distributed) ENDIF ! generate the soft task list IF (dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc) THEN - CALL get_ks_env(ks_env, task_list_soft=task_list, error=error) + CALL get_ks_env(ks_env, task_list_soft=task_list) IF (.NOT. ASSOCIATED(task_list)) THEN - CALL allocate_task_list(task_list,error) - CALL set_ks_env(ks_env, task_list_soft=task_list, error=error) + CALL allocate_task_list(task_list) + CALL set_ks_env(ks_env, task_list_soft=task_list) ENDIF CALL generate_qs_task_list(ks_env, task_list, & reorder_rs_grid_ranks=.TRUE., soft_valid = .TRUE., & - skip_load_balance_distributed=skip_load_balance_distributed, error=error) + skip_load_balance_distributed=skip_load_balance_distributed) ENDIF ENDIF IF( dft_control%do_admm) THEN ! generate the aux_fit task list - CALL get_ks_env(ks_env, task_list_aux_fit=task_list, error=error) + CALL get_ks_env(ks_env, task_list_aux_fit=task_list) IF (.NOT. ASSOCIATED(task_list)) THEN - CALL allocate_task_list(task_list,error) - CALL set_ks_env(ks_env, task_list_aux_fit=task_list, error=error) + CALL allocate_task_list(task_list) + CALL set_ks_env(ks_env, task_list_aux_fit=task_list) ENDIF - CALL get_ks_env(ks_env,sab_aux_fit=sab_orb,error=error) + CALL get_ks_env(ks_env,sab_aux_fit=sab_orb) CALL generate_qs_task_list(ks_env, task_list,& reorder_rs_grid_ranks=.FALSE.,soft_valid=.FALSE.,basis_type="AUX_FIT", & skip_load_balance_distributed=skip_load_balance_distributed, & - sab_orb_external=sab_orb,error=error) + sab_orb_external=sab_orb) END IF IF (dft_control%qs_control%do_kg) THEN @@ -409,7 +397,7 @@ SUBROUTINE qs_create_task_list(qs_env, error) IF (ASSOCIATED(qs_env%kg_env%subset)) THEN DO isub=1,qs_env%kg_env%nsubsets IF (ASSOCIATED(qs_env%kg_env%subset(isub)%task_list)) & - CALL deallocate_task_list(qs_env%kg_env%subset(isub)%task_list, error) + CALL deallocate_task_list(qs_env%kg_env%subset(isub)%task_list) END DO ELSE ALLOCATE(qs_env%kg_env%subset(qs_env%kg_env%nsubsets)) @@ -417,14 +405,13 @@ SUBROUTINE qs_create_task_list(qs_env, error) DO isub=1, qs_env%kg_env%nsubsets - CALL allocate_task_list(qs_env%kg_env%subset(isub)%task_list, error) + CALL allocate_task_list(qs_env%kg_env%subset(isub)%task_list) ! generate the subset task list from the neighborlist CALL generate_qs_task_list(ks_env, qs_env%kg_env%subset(isub)%task_list, & reorder_rs_grid_ranks=.FALSE., soft_valid = soft_valid, & skip_load_balance_distributed=skip_load_balance_distributed, & - sab_orb_external=qs_env%kg_env%subset(isub)%sab_orb, & - error=error) + sab_orb_external=qs_env%kg_env%subset(isub)%sab_orb) END DO @@ -439,15 +426,12 @@ END SUBROUTINE qs_create_task_list ! ***************************************************************************** !> \brief rebuilds the pw_env in the given qs_env, allocating it if necessary !> \param qs_env the qs_env whose pw_env has to be rebuilt -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE qs_env_rebuild_pw_env(qs_env,error) +SUBROUTINE qs_env_rebuild_pw_env(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_env_rebuild_pw_env', & routineP = moduleN//':'//routineN @@ -474,202 +458,202 @@ SUBROUTINE qs_env_rebuild_pw_env(qs_env,error) NULLIFY(rho0_mpole,rho0_gs,rho0_rs) NULLIFY(ewald_env,ewald_pw,new_pw_env,external_vxc,rho_core,rho_nlcc,rho_nlcc_g,vee,vppl) - CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=new_pw_env, error=error) + CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=new_pw_env) IF (.NOT.ASSOCIATED(new_pw_env)) THEN - CALL pw_env_create(new_pw_env,error=error) - CALL set_ks_env(ks_env, pw_env=new_pw_env, error=error) - CALL pw_env_release(new_pw_env,error=error) + CALL pw_env_create(new_pw_env) + CALL set_ks_env(ks_env, pw_env=new_pw_env) + CALL pw_env_release(new_pw_env) ENDIF CALL get_qs_env(qs_env, pw_env=new_pw_env, dft_control=dft_control,& - cell=cell, error=error) + cell=cell) IF(ANY(new_pw_env%cell_hmat/=cell%hmat)) THEN ! only rebuild if nessecary new_pw_env%cell_hmat = cell%hmat - CALL pw_env_rebuild(new_pw_env,qs_env=qs_env,error=error) + CALL pw_env_rebuild(new_pw_env,qs_env=qs_env) ! reallocate rho_core - CALL get_qs_env(qs_env, pw_env=new_pw_env, rho_core=rho_core,error=error) - CPPrecondition(ASSOCIATED(new_pw_env),cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env, pw_env=new_pw_env, rho_core=rho_core) + CPPrecondition(ASSOCIATED(new_pw_env),cp_failure_level,routineP,failure) IF(dft_control%qs_control%gapw) THEN IF (ASSOCIATED(rho_core)) THEN - CALL pw_release(rho_core%pw,error=error) + CALL pw_release(rho_core%pw) DEALLOCATE(rho_core,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF(dft_control%qs_control%gapw_control%nopaw_as_gpw ) THEN ALLOCATE(rho_core,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool, rho_core%pw, & - use_data=COMPLEXDATA1D, error=error) + use_data=COMPLEXDATA1D) rho_core%pw%in_space=RECIPROCALSPACE - CALL set_ks_env(ks_env, rho_core=rho_core,error=error) + CALL set_ks_env(ks_env, rho_core=rho_core) END IF - CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole,error=error) + CALL get_qs_env(qs_env=qs_env,rho0_mpole=rho0_mpole) IF(ASSOCIATED(rho0_mpole)) THEN rho0_rs => rho0_mpole%rho0_s_rs rho0_gs => rho0_mpole%rho0_s_gs IF(ASSOCIATED(rho0_rs)) THEN - CALL pw_release(rho0_rs%pw,error=error) + CALL pw_release(rho0_rs%pw) DEALLOCATE(rho0_rs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ALLOCATE(rho0_rs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool, rho0_rs%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) rho0_mpole%rho0_s_rs => rho0_rs IF(ASSOCIATED(rho0_gs)) THEN - CALL pw_release(rho0_gs%pw,error=error) + CALL pw_release(rho0_gs%pw) DEALLOCATE(rho0_gs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ALLOCATE(rho0_gs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool, rho0_gs%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) rho0_mpole%rho0_s_gs => rho0_gs END IF ELSE IF (dft_control%qs_control%semi_empirical) THEN IF (dft_control%qs_control%se_control%do_ewald .OR. & dft_control%qs_control%se_control%do_ewald_gks) THEN ! rebuild Ewald environment - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw,error=error) - CALL ewald_pw_grid_update(ewald_pw,ewald_env,cell%hmat,error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) + CALL ewald_pw_grid_update(ewald_pw,ewald_env,cell%hmat) END IF ELSE IF (dft_control%qs_control%dftb) THEN IF (dft_control%qs_control%dftb_control%do_ewald) THEN ! rebuild Ewald environment - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw,error=error) - CALL ewald_pw_grid_update(ewald_pw,ewald_env,cell%hmat,error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) + CALL ewald_pw_grid_update(ewald_pw,ewald_env,cell%hmat) END IF ELSE IF (dft_control%qs_control%scptb) THEN IF (dft_control%qs_control%scptb_control%do_ewald) THEN ! rebuild Ewald environment - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw,error=error) - CALL ewald_pw_grid_update(ewald_pw,ewald_env,cell%hmat,error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) + CALL ewald_pw_grid_update(ewald_pw,ewald_env,cell%hmat) END IF ELSE IF (ASSOCIATED(rho_core)) THEN - CALL pw_release(rho_core%pw,error=error) + CALL pw_release(rho_core%pw) DEALLOCATE(rho_core,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ALLOCATE(rho_core,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool, rho_core%pw, & - use_data=COMPLEXDATA1D, error=error) + use_data=COMPLEXDATA1D) rho_core%pw%in_space=RECIPROCALSPACE - CALL set_ks_env(ks_env, rho_core=rho_core,error=error) + CALL set_ks_env(ks_env, rho_core=rho_core) END IF ! reallocate vppl (realspace grid of local pseudopotential IF (dft_control%qs_control%do_ppl_method==do_ppl_grid) THEN NULLIFY(vppl) - CALL get_qs_env(qs_env,pw_env=new_pw_env,vppl=vppl,error=error) + CALL get_qs_env(qs_env,pw_env=new_pw_env,vppl=vppl) IF (ASSOCIATED(vppl)) THEN - CALL pw_release(vppl%pw,error=error) + CALL pw_release(vppl%pw) DEALLOCATE(vppl,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ALLOCATE(vppl,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, vppl%pw, use_data=REALDATA3D, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, vppl%pw, use_data=REALDATA3D) vppl%pw%in_space=REALSPACE - CALL set_ks_env(ks_env,vppl=vppl,error=error) + CALL set_ks_env(ks_env,vppl=vppl) END IF ! reallocate rho_nlcc - CALL has_nlcc(nlcc,qs_env,error) + CALL has_nlcc(nlcc,qs_env) IF (nlcc) THEN ! right now, not working with gapw/gapw_xc, needs implementation in the GAPW XC routines IF (dft_control%qs_control%gapw_xc .OR. dft_control%qs_control%gapw) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Non linear core correction for GAPW not implemented",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ENDIF ! the realspace version NULLIFY(rho_nlcc) - CALL get_qs_env(qs_env,pw_env=new_pw_env,rho_nlcc=rho_nlcc,error=error) + CALL get_qs_env(qs_env,pw_env=new_pw_env,rho_nlcc=rho_nlcc) IF (ASSOCIATED(rho_nlcc)) THEN - CALL pw_release(rho_nlcc%pw,error=error) + CALL pw_release(rho_nlcc%pw) DEALLOCATE(rho_nlcc,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ALLOCATE(rho_nlcc,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, rho_nlcc%pw, use_data=REALDATA3D, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, rho_nlcc%pw, use_data=REALDATA3D) rho_nlcc%pw%in_space=REALSPACE - CALL set_ks_env(ks_env,rho_nlcc=rho_nlcc,error=error) + CALL set_ks_env(ks_env,rho_nlcc=rho_nlcc) ! the g-space version NULLIFY(rho_nlcc_g) - CALL get_qs_env(qs_env,pw_env=new_pw_env,rho_nlcc_g=rho_nlcc_g,error=error) + CALL get_qs_env(qs_env,pw_env=new_pw_env,rho_nlcc_g=rho_nlcc_g) IF (ASSOCIATED(rho_nlcc_g)) THEN - CALL pw_release(rho_nlcc_g%pw,error=error) + CALL pw_release(rho_nlcc_g%pw) DEALLOCATE(rho_nlcc_g,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ALLOCATE(rho_nlcc_g,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, rho_nlcc_g%pw, use_data=COMPLEXDATA1D, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, rho_nlcc_g%pw, use_data=COMPLEXDATA1D) rho_nlcc_g%pw%in_space=RECIPROCALSPACE - CALL set_ks_env(ks_env,rho_nlcc_g=rho_nlcc_g,error=error) + CALL set_ks_env(ks_env,rho_nlcc_g=rho_nlcc_g) END IF ! reallocate vee: external electrostatic potential IF (dft_control%apply_external_potential) THEN NULLIFY(vee) - CALL get_qs_env(qs_env,pw_env=new_pw_env,vee=vee,error=error) + CALL get_qs_env(qs_env,pw_env=new_pw_env,vee=vee) IF (ASSOCIATED(vee)) THEN - CALL pw_release(vee%pw,error=error) + CALL pw_release(vee%pw) DEALLOCATE(vee,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ALLOCATE(vee,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, vee%pw, use_data=REALDATA3D, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, vee%pw, use_data=REALDATA3D) vee%pw%in_space=REALSPACE - CALL set_ks_env(ks_env,vee=vee,error=error) + CALL set_ks_env(ks_env,vee=vee) dft_control%eval_external_potential=.TRUE. END IF ! ZMP Reallocate external_vxc: external vxc potential IF (dft_control%apply_external_vxc) THEN NULLIFY(external_vxc) - CALL get_qs_env(qs_env,pw_env=new_pw_env,external_vxc=external_vxc,error=error) + CALL get_qs_env(qs_env,pw_env=new_pw_env,external_vxc=external_vxc) IF (ASSOCIATED(external_vxc)) THEN - CALL pw_release(external_vxc%pw,error=error) + CALL pw_release(external_vxc%pw) DEALLOCATE(external_vxc,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ALLOCATE(external_vxc,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, external_vxc%pw, use_data=REALDATA3D, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, external_vxc%pw, use_data=REALDATA3D) external_vxc%pw%in_space=REALSPACE - CALL set_qs_env(qs_env,external_vxc=external_vxc,error=error) + CALL set_qs_env(qs_env,external_vxc=external_vxc) dft_control%read_external_vxc=.TRUE. END IF - CALL get_ks_env(ks_env, v_hartree_rspace=v_hartree_rspace, error=error) + CALL get_ks_env(ks_env, v_hartree_rspace=v_hartree_rspace) IF (ASSOCIATED(v_hartree_rspace)) & - CALL pw_release(v_hartree_rspace, error=error) - CALL get_qs_env(qs_env,pw_env=new_pw_env,error=error) - CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_release(v_hartree_rspace) + CALL get_qs_env(qs_env,pw_env=new_pw_env) + CALL pw_env_get(new_pw_env,auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool, v_hartree_rspace,& - use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL set_ks_env(ks_env, v_hartree_rspace=v_hartree_rspace, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL set_ks_env(ks_env, v_hartree_rspace=v_hartree_rspace) ENDIF CALL timestop(handle) @@ -680,13 +664,11 @@ END SUBROUTINE qs_env_rebuild_pw_env !> \brief finds if a given qs run needs to use nlcc !> \param nlcc ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE has_nlcc(nlcc,qs_env,error) + SUBROUTINE has_nlcc(nlcc,qs_env) LOGICAL :: nlcc TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'has_nlcc', & routineP = moduleN//':'//routineN @@ -699,9 +681,9 @@ SUBROUTINE has_nlcc(nlcc,qs_env,error) nlcc=.FALSE. - CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set,error=error) + CALL get_qs_env(qs_env=qs_env,qs_kind_set=qs_kind_set) DO ikind=1,SIZE(qs_kind_set) - CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential,error=error) + CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential) IF (.NOT.ASSOCIATED(gth_potential)) CYCLE CALL get_potential(potential=gth_potential,nlcc_present=nlcc_present) nlcc=nlcc.OR.nlcc_present @@ -716,8 +698,6 @@ END SUBROUTINE has_nlcc !> \param rebuild_ao if it is necessary to rebuild rho_ao. Defaults to true. !> \param rebuild_grids if it in necessary to rebuild rho_r and rho_g. !> Defaults to false. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 10.2002 created [fawzi] !> \author Fawzi Mohamed @@ -727,10 +707,9 @@ END SUBROUTINE has_nlcc !> is ugly and should be removed. !> If necessary rho is created from scratch. ! ***************************************************************************** -SUBROUTINE qs_env_rebuild_rho(qs_env, rebuild_ao, rebuild_grids, error) +SUBROUTINE qs_env_rebuild_rho(qs_env, rebuild_ao, rebuild_grids) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in), OPTIONAL :: rebuild_ao, rebuild_grids - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_env_rebuild_rho', & routineP = moduleN//':'//routineN @@ -751,30 +730,29 @@ SUBROUTINE qs_env_rebuild_rho(qs_env, rebuild_ao, rebuild_grids, error) rho_xc=rho_xc,& rho_aux_fit=rho_aux_fit,& rho_aux_fit_buffer=rho_aux_fit_buffer,& - rho_external=rho_external,& - error=error) + rho_external=rho_external) gapw_xc=dft_control%qs_control%gapw_xc do_admm = dft_control%do_admm CALL qs_rho_rebuild(rho,qs_env=qs_env,& - rebuild_ao=rebuild_ao, rebuild_grids=rebuild_grids, error=error) + rebuild_ao=rebuild_ao, rebuild_grids=rebuild_grids) IF(gapw_xc) THEN CALL qs_rho_rebuild(rho_xc,qs_env=qs_env,& - rebuild_ao=rebuild_ao, rebuild_grids=rebuild_grids, error=error) + rebuild_ao=rebuild_ao, rebuild_grids=rebuild_grids) END IF IF(do_admm) THEN CALL qs_rho_rebuild(rho_aux_fit,qs_env=qs_env,& rebuild_ao=rebuild_ao, rebuild_grids=rebuild_grids, & - admm=.TRUE., error=error) + admm=.TRUE.) CALL qs_rho_rebuild(rho_aux_fit_buffer,qs_env=qs_env,& rebuild_ao=rebuild_ao, rebuild_grids=rebuild_grids, & - admm=.TRUE., error=error) + admm=.TRUE.) END IF ! ZMP rebuilding external density IF (dft_control%apply_external_density) THEN CALL qs_rho_rebuild(rho_external,qs_env=qs_env,& - rebuild_grids=rebuild_grids, error=error) + rebuild_grids=rebuild_grids) dft_control%read_external_density=.TRUE. ENDIF diff --git a/src/qs_environment_types.F b/src/qs_environment_types.F index 9e54e8d8e7..c5bd9397da 100644 --- a/src/qs_environment_types.F +++ b/src/qs_environment_types.F @@ -443,7 +443,6 @@ MODULE qs_environment_types !> \param potential_changed ... !> \param forces_up_to_date ... !> \param mscfg_env ... -!> \param error ... !> \date 23.01.2002 !> \author MK !> \version 1.0 @@ -472,8 +471,7 @@ SUBROUTINE get_qs_env(qs_env,atomic_kind_set,qs_kind_set,cell,super_cell,cell_re se_taper,se_store_int_env,se_nddo_mpole,se_nonbond_env, admm_env, admm_dm, & lri_env,lri_density,dispersion_env, vee,rho_external,external_vxc,mask,& mp2_env,kg_env,WannierCentres,atprop,ls_scf_env,do_transport, transport_env,v_hartree_rspace,& - s_mstruct_changed,rho_changed,potential_changed,forces_up_to_date,mscfg_env,& - error) + s_mstruct_changed,rho_changed,potential_changed,forces_up_to_date,mscfg_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(atomic_kind_type), DIMENSION(:), & OPTIONAL, POINTER :: atomic_kind_set @@ -634,7 +632,6 @@ SUBROUTINE get_qs_env(qs_env,atomic_kind_set,qs_kind_set,cell,super_cell,cell_re forces_up_to_date TYPE(molecular_scf_guess_env_type), & OPTIONAL, POINTER :: mscfg_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_qs_env', & routineP = moduleN//':'//routineN @@ -644,9 +641,9 @@ SUBROUTINE get_qs_env(qs_env,atomic_kind_set,qs_kind_set,cell,super_cell,cell_re failure=.FALSE. NULLIFY(rho0_m) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env%ks_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env%ks_env),cp_failure_level,routineP,failure) IF (PRESENT(outer_scf_history)) outer_scf_history=>qs_env%outer_scf_history IF (PRESENT(outer_scf_ihistory)) outer_scf_ihistory=qs_env%outer_scf_ihistory @@ -816,8 +813,7 @@ SUBROUTINE get_qs_env(qs_env,atomic_kind_set,qs_kind_set,cell,super_cell,cell_re blacs_env=blacs_env,& nelectron_total=nelectron_total,& nelectron_spin=nelectron_spin,& - admm_dm=admm_dm,& - error=error) + admm_dm=admm_dm) END SUBROUTINE get_qs_env @@ -825,16 +821,14 @@ END SUBROUTINE get_qs_env !> \brief Initialise the QUICKSTEP environment. !> \param qs_env ... !> \param globenv ... -!> \param error ... !> \date 25.01.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE init_qs_env(qs_env,globenv,error) + SUBROUTINE init_qs_env(qs_env,globenv) TYPE(qs_environment_type), POINTER :: qs_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error NULLIFY (qs_env%ls_scf_env) NULLIFY (qs_env%transport_env) @@ -890,8 +884,8 @@ SUBROUTINE init_qs_env(qs_env,globenv,error) qs_env%outer_scf_ihistory=0 qs_env%broyden_adaptive_sigma=-1.0_dp - CALL local_rho_set_create(qs_env%local_rho_set, error=error) - CALL hartree_local_create(qs_env%hartree_local, error=error) + CALL local_rho_set_create(qs_env%local_rho_set) + CALL hartree_local_create(qs_env%hartree_local) qs_env%ref_count=1 last_qs_env_id_nr=last_qs_env_id_nr+1 qs_env%id_nr=last_qs_env_id_nr @@ -977,7 +971,6 @@ END SUBROUTINE init_qs_env !> \param mp2_env ... !> \param kg_env ... !> \param WannierCentres ... -!> \param error ... !> \date 23.01.2002 !> \author MK !> \version 1.0 @@ -995,7 +988,7 @@ SUBROUTINE set_qs_env(qs_env,super_cell,& outer_scf_history,outer_scf_ihistory,x_data,et_coupling,dftb_potential,& se_taper,se_store_int_env,se_nddo_mpole,se_nonbond_env,admm_env,ls_scf_env,& do_transport, transport_env,lri_env,lri_density,dispersion_env,mp2_env,kg_env,& - WannierCentres,error) + WannierCentres) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cell_type), OPTIONAL, POINTER :: super_cell @@ -1082,7 +1075,6 @@ SUBROUTINE set_qs_env(qs_env,super_cell,& POINTER :: kg_env TYPE(wannier_centres_type), & DIMENSION(:), OPTIONAL, POINTER :: WannierCentres - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_qs_env', & routineP = moduleN//':'//routineN @@ -1090,13 +1082,13 @@ SUBROUTINE set_qs_env(qs_env,super_cell,& LOGICAL :: failure failure=.FALSE. -! CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) +! CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(mp2_env)) qs_env%mp2_env=>mp2_env IF (PRESENT(kg_env)) qs_env%kg_env => kg_env IF (PRESENT(super_cell)) THEN - CALL cell_retain(super_cell, error=error) - CALL cell_release(qs_env%super_cell,error=error) + CALL cell_retain(super_cell) + CALL cell_release(qs_env%super_cell) qs_env%super_cell => super_cell END IF ! @@ -1122,103 +1114,103 @@ SUBROUTINE set_qs_env(qs_env,super_cell,& IF (PRESENT(efield)) qs_env%efield=>efield IF (PRESENT(ewald_env)) THEN ! accept also null pointers? - CALL ewald_env_retain(ewald_env,error=error) - CALL ewald_env_release(qs_env%ewald_env,error=error) + CALL ewald_env_retain(ewald_env) + CALL ewald_env_release(qs_env%ewald_env) qs_env%ewald_env => ewald_env END IF IF (PRESENT(ewald_pw)) THEN ! accept also null pointers? - CALL ewald_pw_retain(ewald_pw,error=error) - CALL ewald_pw_release(qs_env%ewald_pw,error=error) + CALL ewald_pw_retain(ewald_pw) + CALL ewald_pw_release(qs_env%ewald_pw) qs_env%ewald_pw => ewald_pw END IF IF (PRESENT(scf_control)) THEN ! accept also null pointers? - CALL scf_c_retain(scf_control,error=error) - CALL scf_c_release(qs_env%scf_control,error=error) + CALL scf_c_retain(scf_control) + CALL scf_c_release(qs_env%scf_control) qs_env%scf_control => scf_control END IF IF (PRESENT(rel_control)) THEN ! accept also null pointers? - CALL rel_c_retain(rel_control,error=error) - CALL rel_c_release(qs_env%rel_control,error=error) + CALL rel_c_retain(rel_control) + CALL rel_c_release(qs_env%rel_control) qs_env%rel_control => rel_control END IF IF (PRESENT(linres_control)) THEN ! accept also null pointers? - CALL linres_control_retain(linres_control,error=error) - CALL linres_control_release(qs_env%linres_control,error=error) + CALL linres_control_retain(linres_control) + CALL linres_control_release(qs_env%linres_control) qs_env%linres_control => linres_control END IF ! ZMP associating variables IF (PRESENT(rho_external)) THEN ! accepts also null pointers ! - IF (ASSOCIATED(rho_external)) CALL qs_rho_retain(rho_external,error=error) - CALL qs_rho_release(qs_env%rho_external,error=error) + IF (ASSOCIATED(rho_external)) CALL qs_rho_retain(rho_external) + CALL qs_rho_release(qs_env%rho_external) qs_env%rho_external => rho_external END IF IF (PRESENT(external_vxc)) qs_env%external_vxc => external_vxc IF (PRESENT(mask)) qs_env%mask => mask IF (PRESENT(qs_charges)) THEN - CALL qs_charges_retain(qs_charges,error=error) - CALL qs_charges_release(qs_env%qs_charges,error=error) + CALL qs_charges_retain(qs_charges) + CALL qs_charges_release(qs_env%qs_charges) qs_env%qs_charges => qs_charges END IF IF (PRESENT(ks_qmmm_env)) THEN - CALL qs_ks_qmmm_retain(ks_qmmm_env, error=error) - CALL qs_ks_qmmm_release(qs_env%ks_qmmm_env, error=error) + CALL qs_ks_qmmm_retain(ks_qmmm_env) + CALL qs_ks_qmmm_release(qs_env%ks_qmmm_env) qs_env%ks_qmmm_env => ks_qmmm_env END IF IF (PRESENT(ks_env)) THEN ! accept also null pointers? - CALL qs_ks_retain(ks_env, error=error) - CALL qs_ks_release(qs_env%ks_env, error=error) + CALL qs_ks_retain(ks_env) + CALL qs_ks_release(qs_env%ks_env) qs_env%ks_env => ks_env END IF IF (PRESENT(wf_history)) THEN ! accept also null pointers ? - CALL wfi_retain(wf_history,error=error) - CALL wfi_release(qs_env%wf_history,error=error) + CALL wfi_retain(wf_history) + CALL wfi_release(qs_env%wf_history) qs_env%wf_history => wf_history END IF IF (PRESENT(scf_env)) THEN ! accept also null pointers ? - CALL scf_env_retain(scf_env,error=error) - CALL scf_env_release(qs_env%scf_env, error=error) + CALL scf_env_retain(scf_env) + CALL scf_env_release(qs_env%scf_env) qs_env%scf_env => scf_env END IF IF (PRESENT(xas_env)) THEN ! accept also null pointers? - CALL xas_env_retain(xas_env, error=error) - CALL xas_env_release(qs_env%xas_env, error=error) + CALL xas_env_retain(xas_env) + CALL xas_env_release(qs_env%xas_env) qs_env%xas_env => xas_env END IF IF (PRESENT(mpools)) THEN - CALL mpools_retain(mpools,error=error) - CALL mpools_release(qs_env%mpools, error=error) + CALL mpools_retain(mpools) + CALL mpools_release(qs_env%mpools) qs_env%mpools => mpools END IF IF (PRESENT(mpools_aux_fit)) THEN - CALL mpools_retain(mpools_aux_fit,error=error) - CALL mpools_release(qs_env%mpools_aux_fit, error=error) + CALL mpools_retain(mpools_aux_fit) + CALL mpools_release(qs_env%mpools_aux_fit) qs_env%mpools_aux_fit => mpools_aux_fit END IF IF (PRESENT(rho_atom_set)) THEN - CALL set_local_rho(qs_env%local_rho_set,rho_atom_set=rho_atom_set,error=error) + CALL set_local_rho(qs_env%local_rho_set,rho_atom_set=rho_atom_set) END IF IF (PRESENT(rho0_atom_set)) THEN - CALL set_local_rho(qs_env%local_rho_set,rho0_atom_set=rho0_atom_set,error=error) + CALL set_local_rho(qs_env%local_rho_set,rho0_atom_set=rho0_atom_set) END IF IF (PRESENT(rho0_mpole)) THEN - CALL set_local_rho(qs_env%local_rho_set,rho0_mpole=rho0_mpole,error=error) + CALL set_local_rho(qs_env%local_rho_set,rho0_mpole=rho0_mpole) END IF IF (PRESENT(rhoz_set)) THEN - CALL set_local_rho(qs_env%local_rho_set,rhoz_set=rhoz_set,error=error) + CALL set_local_rho(qs_env%local_rho_set,rhoz_set=rhoz_set) END IF IF (PRESENT(rhoz_tot)) qs_env%local_rho_set%rhoz_tot = rhoz_tot IF (PRESENT(ecoul_1c)) THEN CALL set_hartree_local(qs_env%hartree_local,ecoul_1c=ecoul_1c) END IF IF (PRESENT(input)) THEN - CALL section_vals_retain(input,error=error) - CALL section_vals_release(qs_env%input,error=error) + CALL section_vals_retain(input) + CALL section_vals_release(qs_env%input) qs_env%input => input END IF IF (PRESENT(cp_ddapc_env)) THEN - CALL cp_ddapc_retain(cp_ddapc_env, error=error) - CALL cp_ddapc_release(qs_env%cp_ddapc_env, error=error) + CALL cp_ddapc_retain(cp_ddapc_env) + CALL cp_ddapc_release(qs_env%cp_ddapc_env) qs_env%cp_ddapc_env => cp_ddapc_env END IF IF (PRESENT(cp_ddapc_ewald)) THEN @@ -1228,19 +1220,19 @@ SUBROUTINE set_qs_env(qs_env,super_cell,& IF (PRESENT(et_coupling))qs_env%et_coupling => et_coupling IF (PRESENT(dftb_potential))qs_env%dftb_potential => dftb_potential IF (PRESENT(se_taper)) THEN - CALL se_taper_release(qs_env%se_taper,error=error) + CALL se_taper_release(qs_env%se_taper) qs_env%se_taper => se_taper END IF IF (PRESENT(se_store_int_env)) THEN - CALL semi_empirical_si_release(qs_env%se_store_int_env,error=error) + CALL semi_empirical_si_release(qs_env%se_store_int_env) qs_env%se_store_int_env => se_store_int_env END IF IF (PRESENT(se_nddo_mpole)) THEN - CALL nddo_mpole_release(qs_env%se_nddo_mpole,error=error) + CALL nddo_mpole_release(qs_env%se_nddo_mpole) qs_env%se_nddo_mpole => se_nddo_mpole END IF IF (PRESENT(se_nonbond_env)) THEN - CALL fist_nonbond_env_release(qs_env%se_nonbond_env,error) + CALL fist_nonbond_env_release(qs_env%se_nonbond_env) qs_env%se_nonbond_env => se_nonbond_env END IF IF( PRESENT(admm_env) ) qs_env%admm_env => admm_env @@ -1254,16 +1246,13 @@ END SUBROUTINE set_qs_env !> \brief allocates and intitializes a qs_env !> \param qs_env the object to create !> \param globenv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qs_env_create(qs_env,globenv,error) + SUBROUTINE qs_env_create(qs_env,globenv) TYPE(qs_environment_type), POINTER :: qs_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_env_create', & routineP = moduleN//':'//routineN @@ -1274,22 +1263,19 @@ SUBROUTINE qs_env_create(qs_env,globenv,error) failure=.FALSE. ALLOCATE(qs_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL init_qs_env(qs_env, globenv=globenv, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL init_qs_env(qs_env, globenv=globenv) END SUBROUTINE qs_env_create ! ***************************************************************************** !> \brief retains the given qs_env (see doc/ReferenceCounting.html) !> \param qs_env the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qs_env_retain(qs_env,error) + SUBROUTINE qs_env_retain(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_env_retain', & routineP = moduleN//':'//routineN @@ -1298,23 +1284,20 @@ SUBROUTINE qs_env_retain(qs_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) qs_env%ref_count=qs_env%ref_count+1 END SUBROUTINE qs_env_retain ! ***************************************************************************** !> \brief releases the given qs_env (see doc/ReferenceCounting.html) !> \param qs_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qs_env_release(qs_env,error) + SUBROUTINE qs_env_release(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_env_release', & routineP = moduleN//':'//routineN @@ -1325,87 +1308,86 @@ SUBROUTINE qs_env_release(qs_env,error) failure=.FALSE. IF (ASSOCIATED(qs_env)) THEN - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) qs_env%ref_count=qs_env%ref_count-1 IF (qs_env%ref_count<1) THEN - CALL cell_release(qs_env%super_cell,error=error) + CALL cell_release(qs_env%super_cell) IF (ASSOCIATED(qs_env%mos)) THEN DO i=1,SIZE(qs_env%mos) - CALL deallocate_mo_set(qs_env%mos(i)%mo_set,error=error) + CALL deallocate_mo_set(qs_env%mos(i)%mo_set) END DO DEALLOCATE(qs_env%mos, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(qs_env%mos_aux_fit)) THEN DO i=1,SIZE(qs_env%mos_aux_fit) - CALL deallocate_mo_set(qs_env%mos_aux_fit(i)%mo_set,error=error) + CALL deallocate_mo_set(qs_env%mos_aux_fit(i)%mo_set) END DO DEALLOCATE(qs_env%mos_aux_fit, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(qs_env%mo_derivs)) THEN DO I=1,SIZE(qs_env%mo_derivs) - CALL cp_dbcsr_release_p(qs_env%mo_derivs(I)%matrix, error=error) + CALL cp_dbcsr_release_p(qs_env%mo_derivs(I)%matrix) ENDDO DEALLOCATE(qs_env%mo_derivs, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(qs_env%mo_derivs_aux_fit)) THEN DO I=1,SIZE(qs_env%mo_derivs_aux_fit) - CALL cp_fm_release(qs_env%mo_derivs_aux_fit(I)%matrix,error=error) + CALL cp_fm_release(qs_env%mo_derivs_aux_fit(I)%matrix) ENDDO DEALLOCATE(qs_env%mo_derivs_aux_fit, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(qs_env%mo_loc_history)) THEN DO I=1,SIZE(qs_env%mo_loc_history) - CALL cp_fm_release(qs_env%mo_loc_history(I)%matrix,error=error) + CALL cp_fm_release(qs_env%mo_loc_history(I)%matrix) ENDDO DEALLOCATE(qs_env%mo_loc_history, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(qs_env%rtp))THEN - CALL rt_prop_release(qs_env%rtp,error) + CALL rt_prop_release(qs_env%rtp) DEALLOCATE (qs_env%rtp) END IF IF (ASSOCIATED(qs_env%outer_scf_history)) THEN DEALLOCATE(qs_env%outer_scf_history,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) qs_env%outer_scf_ihistory=0 ENDIF - IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce,error) + IF (ASSOCIATED(qs_env%oce)) CALL deallocate_oce_set(qs_env%oce) IF (ASSOCIATED(qs_env%local_rho_set)) THEN - CALL local_rho_set_release(qs_env%local_rho_set,error=error) + CALL local_rho_set_release(qs_env%local_rho_set) END IF IF (ASSOCIATED(qs_env%hartree_local)) THEN - CALL hartree_local_release(qs_env%hartree_local,error=error) + CALL hartree_local_release(qs_env%hartree_local) END IF - CALL scf_c_release(qs_env%scf_control, error=error) - CALL rel_c_release(qs_env%rel_control, error=error) + CALL scf_c_release(qs_env%scf_control) + CALL rel_c_release(qs_env%rel_control) IF(ASSOCIATED(qs_env%linres_control)) THEN - CALL linres_control_release(qs_env%linres_control, error=error) + CALL linres_control_release(qs_env%linres_control) END IF IF (ASSOCIATED(qs_env%ls_scf_env)) THEN - CALL ls_scf_release(qs_env%ls_scf_env,error) + CALL ls_scf_release(qs_env%ls_scf_env) ENDIF - CALL molecular_scf_guess_env_destroy(qs_env%molecular_scf_guess_env,& - error=error) + CALL molecular_scf_guess_env_destroy(qs_env%molecular_scf_guess_env) IF (ASSOCIATED(qs_env%transport_env)) THEN - CALL transport_env_release(qs_env%transport_env,error) + CALL transport_env_release(qs_env%transport_env) ENDIF !Only if do_xas_calculation IF(ASSOCIATED(qs_env%xas_env)) THEN - CALL xas_env_release(qs_env%xas_env,error=error) + CALL xas_env_release(qs_env%xas_env) END IF - CALL ewald_env_release(qs_env%ewald_env, error=error) - CALL ewald_pw_release(qs_env%ewald_pw, error=error) + CALL ewald_env_release(qs_env%ewald_env) + CALL ewald_pw_release(qs_env%ewald_pw) IF (ASSOCIATED(qs_env%image_matrix)) THEN DEALLOCATE(qs_env%image_matrix) ENDIF @@ -1417,81 +1399,81 @@ SUBROUTINE qs_env_release(qs_env,error) ENDIF ! ZMP IF(ASSOCIATED(qs_env%rho_external)) THEN - CALL qs_rho_release(qs_env%rho_external, error=error) + CALL qs_rho_release(qs_env%rho_external) END IF IF (ASSOCIATED(qs_env%external_vxc)) THEN - CALL pw_release(qs_env%external_vxc%pw,error=error) + CALL pw_release(qs_env%external_vxc%pw) DEALLOCATE(qs_env%external_vxc) ENDIF IF (ASSOCIATED(qs_env%mask)) THEN - CALL pw_release(qs_env%mask%pw,error=error) + CALL pw_release(qs_env%mask%pw) DEALLOCATE(qs_env%mask) ENDIF - CALL qs_charges_release(qs_env%qs_charges, error=error) - CALL qs_ks_release(qs_env%ks_env, error=error) - CALL qs_ks_qmmm_release(qs_env%ks_qmmm_env, error=error) - CALL wfi_release(qs_env%wf_history,error=error) - CALL scf_env_release(qs_env%scf_env, error=error) - CALL mpools_release(qs_env%mpools,error=error) - CALL mpools_release(qs_env%mpools_aux_fit,error=error) - CALL section_vals_release(qs_env%input,error=error) - CALL cp_ddapc_release(qs_env%cp_ddapc_env, error=error) - CALL cp_ddapc_ewald_release(qs_env%cp_ddapc_ewald, error=error) - CALL efield_berry_release(qs_env%efield,error=error) + CALL qs_charges_release(qs_env%qs_charges) + CALL qs_ks_release(qs_env%ks_env) + CALL qs_ks_qmmm_release(qs_env%ks_qmmm_env) + CALL wfi_release(qs_env%wf_history) + CALL scf_env_release(qs_env%scf_env) + CALL mpools_release(qs_env%mpools) + CALL mpools_release(qs_env%mpools_aux_fit) + CALL section_vals_release(qs_env%input) + CALL cp_ddapc_release(qs_env%cp_ddapc_env) + CALL cp_ddapc_ewald_release(qs_env%cp_ddapc_ewald) + CALL efield_berry_release(qs_env%efield) IF(ASSOCIATED(qs_env%x_data)) THEN - CALL hfx_release(qs_env%x_data, error=error) + CALL hfx_release(qs_env%x_data) END IF IF(ASSOCIATED(qs_env%et_coupling)) THEN - CALL et_coupling_release(qs_env%et_coupling,error) + CALL et_coupling_release(qs_env%et_coupling) END IF IF (ASSOCIATED(qs_env%dftb_potential)) THEN - CALL qs_dftb_pairpot_release(qs_env%dftb_potential,error) + CALL qs_dftb_pairpot_release(qs_env%dftb_potential) END IF IF (ASSOCIATED(qs_env%se_taper)) THEN - CALL se_taper_release(qs_env%se_taper, error) + CALL se_taper_release(qs_env%se_taper) END IF IF (ASSOCIATED(qs_env%se_store_int_env)) THEN - CALL semi_empirical_si_release(qs_env%se_store_int_env, error) + CALL semi_empirical_si_release(qs_env%se_store_int_env) END IF IF (ASSOCIATED(qs_env%se_nddo_mpole)) THEN - CALL nddo_mpole_release(qs_env%se_nddo_mpole, error) + CALL nddo_mpole_release(qs_env%se_nddo_mpole) END IF IF (ASSOCIATED(qs_env%se_nonbond_env)) THEN - CALL fist_nonbond_env_release(qs_env%se_nonbond_env,error) + CALL fist_nonbond_env_release(qs_env%se_nonbond_env) END IF IF (ASSOCIATED(qs_env%admm_env)) THEN - CALL admm_env_release(qs_env%admm_env, error) + CALL admm_env_release(qs_env%admm_env) END IF IF (ASSOCIATED(qs_env%lri_env)) THEN - CALL lri_env_release(qs_env%lri_env, error) + CALL lri_env_release(qs_env%lri_env) END IF IF (ASSOCIATED(qs_env%lri_density)) THEN - CALL lri_density_release(qs_env%lri_density, error) + CALL lri_density_release(qs_env%lri_density) END IF IF (ASSOCIATED(qs_env%mp2_env)) THEN - CALL mp2_env_release(qs_env%mp2_env, error) + CALL mp2_env_release(qs_env%mp2_env) END IF IF (ASSOCIATED(qs_env%kg_env)) THEN - CALL kg_env_release(qs_env%kg_env, error) + CALL kg_env_release(qs_env%kg_env) END IF ! dispersion - CALL qs_dispersion_release(qs_env%dispersion_env,error) + CALL qs_dispersion_release(qs_env%dispersion_env) IF( ASSOCIATED(qs_env%WannierCentres)) THEN DO i=1,SIZE(qs_env%WannierCentres) DEALLOCATE(qs_env%WannierCentres(i)%WannierHamDiag, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(qs_env%WannierCentres(i)%centres, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDDO DEALLOCATE(qs_env%WannierCentres, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ! now we are ready to deallocate the full structure DEALLOCATE(qs_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(qs_env) diff --git a/src/qs_epr_hyp.F b/src/qs_epr_hyp.F index c6ede51f9c..3c59d9a9a1 100644 --- a/src/qs_epr_hyp.F +++ b/src/qs_epr_hyp.F @@ -72,13 +72,10 @@ MODULE qs_epr_hyp ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_epr_hyp_calc(qs_env,error) + SUBROUTINE qs_epr_hyp_calc(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_epr_hyp_calc', & routineP = moduleN//':'//routineN @@ -126,15 +123,15 @@ SUBROUTINE qs_epr_hyp_calc(qs_env,error) logger, dft_section, para_env, particle_set, rho, rho_atom, & rho_atom_set, rhototspin_elec_gspace, hypaniso_gspace, rho_g) - logger => cp_error_get_logger(error) - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) + logger => cp_get_default_logger() + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") output_unit = cp_print_key_unit_nr(logger,dft_section,& "PRINT%HYPERFINE_COUPLING_TENSOR",& - extension=".eprhyp",log_filename=.FALSE.,error=error) + extension=".eprhyp",log_filename=.FALSE.) CALL section_vals_val_get(dft_section,& "PRINT%HYPERFINE_COUPLING_TENSOR%INTERACTION_RADIUS",& - r_val=int_radius,error=error) - CALL section_vals_val_get(dft_section,"LSD",l_val=lsd,error=error) + r_val=int_radius) + CALL section_vals_val_get(dft_section,"LSD",l_val=lsd) IF ( .NOT. lsd ) THEN ! EPR calculation only for LSD @@ -151,8 +148,7 @@ SUBROUTINE qs_epr_hyp_calc(qs_env,error) CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,cell=cell,& rho=rho,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& rho_atom_set=rho_atom_set,pw_env=pw_env,& - particle_set=particle_set,para_env=para_env,& - error=error) + particle_set=particle_set,para_env=para_env) group = para_env%group IF (output_unit>0) THEN @@ -164,11 +160,11 @@ SUBROUTINE qs_epr_hyp_calc(qs_env,error) ! allocate hyperfine matrices natom = SIZE(particle_set,1) ALLOCATE (hypaniso(3,3,natom),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (hypiso(natom),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (hypiso_one(natom),STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! set the matrices to zero hypiso = 0.0_dp @@ -183,7 +179,7 @@ SUBROUTINE qs_epr_hyp_calc(qs_env,error) atom_list=atom_list,natom=natomkind,z=z) CALL get_qs_kind(qs_kind_set(ikind),harmonics=harmonics,& - grid_atom=grid_atom,paw_atom=paw_atom,hard_radius=hard_radius,error=error) + grid_atom=grid_atom,paw_atom=paw_atom,hard_radius=hard_radius) IF(.NOT. paw_atom) CYCLE ! skip the rest and go to next atom type @@ -296,39 +292,36 @@ SUBROUTINE qs_epr_hyp_calc(qs_env,error) ! Now calculate the soft electronic spin density in reciprocal space (g-space) ! Plane waves grid to assemble the soft electronic spin density CALL pw_env_get(pw_env=pw_env,& - auxbas_pw_pool=auxbas_pw_pool,& - error=error) + auxbas_pw_pool=auxbas_pw_pool) ALLOCATE (rhototspin_elec_gspace,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(auxbas_pw_pool,& rhototspin_elec_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(rhototspin_elec_gspace%pw,error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero(rhototspin_elec_gspace%pw) pw_grid => rhototspin_elec_gspace%pw%pw_grid ! Load the contribution of the soft electronic density - CALL qs_rho_get(rho, rho_g=rho_g, error=error) - CPPrecondition(SIZE(rho_g)>1,cp_failure_level,routineP,error,failure) - CALL pw_axpy(rho_g(1)%pw,rhototspin_elec_gspace%pw,error=error) - CALL pw_axpy(rho_g(2)%pw,rhototspin_elec_gspace%pw,alpha=-1._dp,error=error) + CALL qs_rho_get(rho, rho_g=rho_g) + CPPrecondition(SIZE(rho_g)>1,cp_failure_level,routineP,failure) + CALL pw_axpy(rho_g(1)%pw,rhototspin_elec_gspace%pw) + CALL pw_axpy(rho_g(2)%pw,rhototspin_elec_gspace%pw,alpha=-1._dp) ! grid to assemble anisotropic hyperfine terms ALLOCATE (hypaniso_gspace,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(auxbas_pw_pool,& hypaniso_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) DO idir1=1,3 DO idir2=idir1,3 ! tensor symmetry - CALL pw_zero(hypaniso_gspace%pw,error=error) + CALL pw_zero(hypaniso_gspace%pw) CALL pw_dr2_gg ( rhototspin_elec_gspace%pw, hypaniso_gspace%pw, & - idir1, idir2,error=error) + idir1, idir2) DO iatom=1,natom sum = 0.0_dp ra(:) = pbc(particle_set(iatom)%r,cell) @@ -344,13 +337,13 @@ SUBROUTINE qs_epr_hyp_calc(qs_env,error) END DO ! idir2 END DO ! idir1 - CALL pw_pool_give_back_pw(auxbas_pw_pool,rhototspin_elec_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rhototspin_elec_gspace%pw) DEALLOCATE (rhototspin_elec_gspace,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL pw_pool_give_back_pw(auxbas_pw_pool,hypaniso_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,hypaniso_gspace%pw) DEALLOCATE (hypaniso_gspace,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Multiply hyperfine matrices with constant*gyromagnetic ratio's ! to have it in units of Mhz. @@ -398,11 +391,11 @@ SUBROUTINE qs_epr_hyp_calc(qs_env,error) ! Deallocate the remainings ... DEALLOCATE (hypiso,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (hypiso_one,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (hypaniso,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE qs_epr_hyp_calc diff --git a/src/qs_external_density.F b/src/qs_external_density.F index dd766f3516..32cd08ec0e 100644 --- a/src/qs_external_density.F +++ b/src/qs_external_density.F @@ -52,14 +52,12 @@ MODULE qs_external_density ! ***************************************************************************** !> \brief Computes the external density on the grid !> \param qs_env ... -!> \param error ... !> \date 03.2011 !> \author D. Varsano ! ***************************************************************************** - SUBROUTINE external_read_density(qs_env,error) + SUBROUTINE external_read_density(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'external_read_density', & routineP = moduleN//':'//routineN @@ -98,33 +96,30 @@ SUBROUTINE external_read_density(qs_env,error) rho_external=rho_external,& input=input,& pw_env=pw_env,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF (dft_control%apply_external_density) THEN CALL qs_rho_get(rho_external,& rho_r=rho_ext_r,& rho_g=rho_ext_g,& - tot_rho_r=tot_rho_r_ext,& - error=error) + tot_rho_r=tot_rho_r_ext) gridlevel_info=>pw_env%gridlevel_info - CALL pw_env_get(pw_env, rs_descs=rs_descs, error=error) + CALL pw_env_get(pw_env, rs_descs=rs_descs) ALLOCATE (rs_rho_ext(gridlevel_info%ngrid_levels),STAT=stat) DO igrid_level=1,gridlevel_info%ngrid_levels CALL rs_grid_create(rs_rho_ext(igrid_level)%rs_grid,& - rs_descs(igrid_level)%rs_desc, error=error) + rs_descs(igrid_level)%rs_desc) CALL rs_grid_zero(rs_rho_ext(igrid_level)%rs_grid) ENDDO igrid_level=igrid_level-1 - ext_den_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_DENSITY",& - error=error) - CALL section_vals_val_get(ext_den_section,"FILE_DENSITY",c_val=filename,error=error) + ext_den_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_DENSITY") + CALL section_vals_val_get(ext_den_section,"FILE_DENSITY",c_val=filename) gid = rho_ext_r(1)%pw%pw_grid%para%group my_rank = rho_ext_r(1)%pw%pw_grid%para%my_pos @@ -210,8 +205,8 @@ SUBROUTINE external_read_density(qs_env,error) ENDIF - CALL density_rs2pw(pw_env,rs_rho_ext,rho=rho_ext_r(1),rho_gspace=rho_ext_g(1),error=error) - tot_rho_r_ext(1) = pw_integrate_function(rho_ext_r(1)%pw,isign=1,error=error) + CALL density_rs2pw(pw_env,rs_rho_ext,rho=rho_ext_r(1),rho_gspace=rho_ext_g(1)) + tot_rho_r_ext(1) = pw_integrate_function(rho_ext_r(1)%pw,isign=1) IF (my_rank == 0) THEN WRITE(*,FMT="(T3,A,T61,F20.10)") "ZMP| Total external charge: ",& tot_rho_r_ext(1) @@ -227,14 +222,12 @@ END SUBROUTINE external_read_density ! ***************************************************************************** !> \brief Read external vxc potential !> \param qs_env ... -!> \param error ... !> \date 03.2011 !> \author DV ! ***************************************************************************** - SUBROUTINE external_read_vxc(qs_env,error) + SUBROUTINE external_read_vxc(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'external_read_vxc', & routineP = moduleN//':'//routineN @@ -259,10 +252,9 @@ SUBROUTINE external_read_vxc(qs_env,error) cell=cell,& external_vxc=vxc_ext,& input=input,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF (dft_control%apply_external_vxc) THEN - ext_vxc_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_VXC",error=error) + ext_vxc_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_VXC") IF (dft_control%read_external_vxc) THEN dr=vxc_ext%pw%pw_grid%dr dvol=vxc_ext%pw%pw_grid%dvol @@ -275,7 +267,7 @@ SUBROUTINE external_read_vxc(qs_env,error) lbounds(i) = bo_local(1,i) ubounds(i) = bo_local(2,i) ENDDO - CALL section_vals_val_get(ext_vxc_section,"FILE_VXC",c_val=filename,error=error) + CALL section_vals_val_get(ext_vxc_section,"FILE_VXC",c_val=filename) WRITE(*,*) "NOW READING VXC FILE: ", filename extunit=get_unit_number() CALL open_file(file_name=filename,file_status="OLD",& diff --git a/src/qs_external_potential.F b/src/qs_external_potential.F index bc22f5e3ac..5e484b930b 100644 --- a/src/qs_external_potential.F +++ b/src/qs_external_potential.F @@ -57,14 +57,12 @@ MODULE qs_external_potential ! ***************************************************************************** !> \brief Computes the external potential on the grid !> \param qs_env ... -!> \param error ... !> \date 12.2009 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE external_e_potential(qs_env,error) + SUBROUTINE external_e_potential(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'external_e_potential', & routineP = moduleN//':'//routineN @@ -85,17 +83,16 @@ SUBROUTINE external_e_potential(qs_env,error) CALL get_qs_env(qs_env,& vee=v_ee,& input=input,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF(dft_control%apply_external_potential)THEN - ext_pot_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_POTENTIAL",error=error) - CALL section_vals_val_get(ext_pot_section,"STATIC",l_val=static_potential,error=error) - CALL section_vals_val_get(ext_pot_section,"READ_FROM_CUBE",l_val=read_from_cube,error=error) + ext_pot_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_POTENTIAL") + CALL section_vals_val_get(ext_pot_section,"STATIC",l_val=static_potential) + CALL section_vals_val_get(ext_pot_section,"READ_FROM_CUBE",l_val=read_from_cube) IF ((.NOT.static_potential).OR.dft_control%eval_external_potential) THEN IF (read_from_cube) THEN - CALL section_vals_val_get(ext_pot_section,"SCALING_FACTOR",r_val=scaling_factor,error=error) - CALL cube_to_pw(v_ee%pw, 'pot.cube', scaling_factor, error) + CALL section_vals_val_get(ext_pot_section,"SCALING_FACTOR",r_val=scaling_factor) + CALL cube_to_pw(v_ee%pw, 'pot.cube', scaling_factor) dft_control%eval_external_potential = .FALSE. ELSE dr=v_ee%pw%pw_grid%dr @@ -111,7 +108,7 @@ SUBROUTINE external_e_potential(qs_env,error) grid_p(1)=(i-bo_global(1,1))*dr(1) grid_p(2)=(j-bo_global(1,2))*dr(2) grid_p(3)=(k-bo_global(1,3))*dr(3) - CALL get_external_potential(grid_p, ext_pot_section, func=efunc, error=error) + CALL get_external_potential(grid_p, ext_pot_section, func=efunc) v_ee%pw%cr3d(i,j,k)= v_ee%pw%cr3d(i,j,k)+efunc END DO END DO @@ -127,15 +124,13 @@ END SUBROUTINE external_e_potential !> \brief Computes the force and the energy due to the external potential on the cores !> \param qs_env ... !> \param calculate_forces ... -!> \param error ... !> \date 12.2009 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE external_c_potential(qs_env,calculate_forces,error) + SUBROUTINE external_c_potential(qs_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, OPTIONAL :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'external_c_potential', & routineP = moduleN//':'//routineN @@ -171,26 +166,25 @@ SUBROUTINE external_c_potential(qs_env,calculate_forces,error) particle_set=particle_set,& input=input,& cell=cell,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF(dft_control%apply_external_potential)THEN IF (dft_control%eval_external_potential) THEN !ensure that external potential is loaded to grid - CALL external_e_potential(qs_env,error) + CALL external_e_potential(qs_env) END IF my_force=.FALSE. IF(PRESENT(calculate_forces)) my_force=calculate_forces - ext_pot_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_POTENTIAL",error=error) + ext_pot_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_POTENTIAL") ee_core_ener=0.0_dp nkind = SIZE(atomic_kind_set) !check if external potential on grid has been loaded from a file instead of giving a function - CALL section_vals_val_get(ext_pot_section,"READ_FROM_CUBE",l_val=pot_on_grid,error=error) - IF(pot_on_grid) CALL get_qs_env(qs_env,vee=v_ee,input=input,error=error) + CALL section_vals_val_get(ext_pot_section,"READ_FROM_CUBE",l_val=pot_on_grid) + IF(pot_on_grid) CALL get_qs_env(qs_env,vee=v_ee,input=input) DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=list,natom=natom) - CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff,error=error) + CALL get_qs_kind(qs_kind_set(ikind), zeff=zeff) natom = SIZE(list) DO iatom=1,natom @@ -205,14 +199,14 @@ SUBROUTINE external_c_potential(qs_env,calculate_forces,error) !otherwise evaluate the given function IF(pot_on_grid) THEN CALL interpolate_external_potential(r, v_ee%pw, func=efunc, & - dfunc=dfunc, calc_derivatives=my_force, error=error) + dfunc=dfunc, calc_derivatives=my_force) ELSE CALL get_external_potential(r, ext_pot_section, func=efunc, & - dfunc=dfunc, calc_derivatives=my_force, error=error) + dfunc=dfunc, calc_derivatives=my_force) END IF ee_core_ener=ee_core_ener+zeff*efunc IF(my_force)THEN - CALL get_qs_env(qs_env=qs_env,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,force=force) force(ikind)%eev(:,iatom)=dfunc*zeff END IF END DO @@ -229,19 +223,17 @@ END SUBROUTINE external_c_potential !> \param func external potential at r !> \param dfunc derivative of the external potential at r !> \param calc_derivatives Whether to calulate dfunc -!> \param error ... !> \date 12.2009 !> \par History !> 12.2009 created [tlaino] !> 11.2014 reading external cube file added [Juha Ritala & Matt Watkins] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE get_external_potential(r, ext_pot_section, func, dfunc, calc_derivatives, error) + SUBROUTINE get_external_potential(r, ext_pot_section, func, dfunc, calc_derivatives) REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r TYPE(section_vals_type), POINTER :: ext_pot_section REAL(KIND=dp), INTENT(OUT), OPTIONAL :: func, dfunc(3) LOGICAL, INTENT(IN), OPTIONAL :: calc_derivatives - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_external_potential', & routineP = moduleN//':'//routineN @@ -261,11 +253,11 @@ SUBROUTINE get_external_potential(r, ext_pot_section, func, dfunc, calc_derivati my_force = .FALSE. IF (PRESENT(calc_derivatives)) my_force=calc_derivatives check=PRESENT(dfunc).EQV.PRESENT(calc_derivatives) - CPPrecondition(check,cp_failure_level,routineP,error,failure) - CALL section_vals_val_get(ext_pot_section,"DX",r_val=dx,error=error) - CALL section_vals_val_get(ext_pot_section,"ERROR_LIMIT",r_val=lerr,error=error) + CPPrecondition(check,cp_failure_level,routineP,failure) + CALL section_vals_val_get(ext_pot_section,"DX",r_val=dx) + CALL section_vals_val_get(ext_pot_section,"ERROR_LIMIT",r_val=lerr) CALL get_generic_info(ext_pot_section, "FUNCTION", coupling_function, my_par, my_val,& - input_variables=(/"X","Y","Z"/), i_rep_sec=1,error=error) + input_variables=(/"X","Y","Z"/), i_rep_sec=1) CALL initf(1) CALL parsef(1,TRIM(coupling_function),my_par) @@ -285,15 +277,15 @@ SUBROUTINE get_external_potential(r, ext_pot_section, func, dfunc, calc_derivati CALL cp_assert(.FALSE.,cp_warning_level,-300,routineP,& 'ASSERTION (cond) failed at line '//cp_to_string(__LINE__)//& ' Error '//TRIM(this_error)//' in computing numerical derivatives larger then'//& - TRIM(def_error)//' .',error=error,only_ionode=.TRUE.) + TRIM(def_error)//' .',only_ionode=.TRUE.) END IF dfunc(j)=dedf END DO END IF DEALLOCATE(my_par,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(my_val,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL finalizef() CALL timestop(handle) END SUBROUTINE get_external_potential @@ -306,14 +298,12 @@ END SUBROUTINE get_external_potential !> \param func value of vee at r !> \param dfunc derivatives of vee at r !> \param calc_derivatives calc dfunc -!> \param error ... ! ***************************************************************************** - SUBROUTINE interpolate_external_potential(r, grid, func, dfunc, calc_derivatives, error) + SUBROUTINE interpolate_external_potential(r, grid, func, dfunc, calc_derivatives) REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r TYPE(pw_type), POINTER :: grid REAL(KIND=dp), INTENT(OUT), OPTIONAL :: func, dfunc(3) LOGICAL, INTENT(IN), OPTIONAL :: calc_derivatives - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'interpolate_external_potential', & @@ -337,7 +327,7 @@ SUBROUTINE interpolate_external_potential(r, grid, func, dfunc, calc_derivatives my_force = .FALSE. IF (PRESENT(calc_derivatives)) my_force=calc_derivatives check=PRESENT(dfunc).EQV.PRESENT(calc_derivatives) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) IF (my_force) THEN ALLOCATE(grid_buffer(0:3,0:3,0:3)) diff --git a/src/qs_fb_atomic_halo_types.F b/src/qs_fb_atomic_halo_types.F index a32c309c1a..9cfbc03aff 100644 --- a/src/qs_fb_atomic_halo_types.F +++ b/src/qs_fb_atomic_halo_types.F @@ -139,14 +139,12 @@ MODULE qs_fb_atomic_halo_types !> \brief Retains an fb_atomic_halo object !> \param atomic_halo the fb_atomic_halo object, its content must !> not be NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_retain(atomic_halo, error) + SUBROUTINE fb_atomic_halo_retain(atomic_halo) ! note INTENT(IN) is okay because the obj pointer contained in the ! obj type will not be changed TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_retain', & routineP = moduleN//':'//routineN @@ -154,8 +152,8 @@ SUBROUTINE fb_atomic_halo_retain(atomic_halo, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP, error, failure) - CPPreconditionNoFail(atomic_halo%obj%ref_count>0, cp_failure_level, routineP, error) + CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP,failure) + CPPreconditionNoFail(atomic_halo%obj%ref_count>0, cp_failure_level, routineP) atomic_halo%obj%ref_count = atomic_halo%obj%ref_count + 1 END SUBROUTINE fb_atomic_halo_retain @@ -165,12 +163,10 @@ END SUBROUTINE fb_atomic_halo_retain !> \param atomic_halo the fb_atomic_halo object, its content must !> not be UNDEFINED, and the subroutine does nothing !> if the content points to NULL -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_release(atomic_halo, error) + SUBROUTINE fb_atomic_halo_release(atomic_halo) TYPE(fb_atomic_halo_obj), INTENT(INOUT) :: atomic_halo - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_release', & routineP = moduleN//':'//routineN @@ -180,7 +176,7 @@ SUBROUTINE fb_atomic_halo_release(atomic_halo, error) failure = .FALSE. IF (ASSOCIATED(atomic_halo%obj)) THEN - CPPreconditionNoFail(atomic_halo%obj%ref_count>0, cp_failure_level, routineP, error) + CPPreconditionNoFail(atomic_halo%obj%ref_count>0, cp_failure_level, routineP) atomic_halo%obj%ref_count = atomic_halo%obj%ref_count - 1 IF (atomic_halo%obj%ref_count == 0) THEN atomic_halo%obj%ref_count = 1 @@ -190,11 +186,11 @@ SUBROUTINE fb_atomic_halo_release(atomic_halo, error) ! FORTRAN standard (and thus becomes compiler dependent and unreliable) ! after the following DEALLOCATE DEALLOCATE(atomic_halo%obj%halo_atoms, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF atomic_halo%obj%ref_count = 0 DEALLOCATE(atomic_halo%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(atomic_halo%obj) @@ -259,12 +255,10 @@ END FUNCTION fb_atomic_halo_has_data !> \brief Creates and initialises an empty fb_atomic_halo object !> \param atomic_halo the fb_atomic_halo object, its content must !> be NULL and cannot be UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_create(atomic_halo, error) + SUBROUTINE fb_atomic_halo_create(atomic_halo) TYPE(fb_atomic_halo_obj), INTENT(INOUT) :: atomic_halo - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_create', & routineP = moduleN//':'//routineN @@ -273,9 +267,9 @@ SUBROUTINE fb_atomic_halo_create(atomic_halo, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP,failure) ALLOCATE(atomic_halo%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) atomic_halo%obj%owner_atom = 0 atomic_halo%obj%owner_id_in_halo = 0 atomic_halo%obj%natoms = 0 @@ -293,12 +287,10 @@ END SUBROUTINE fb_atomic_halo_create !> \brief Initialises an fb_atomic_halo object, and makes it empty !> \param atomic_halo the fb_atomic_halo object, its content must !> not be NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_init(atomic_halo, error) + SUBROUTINE fb_atomic_halo_init(atomic_halo) TYPE(fb_atomic_halo_obj), INTENT(INOUT) :: atomic_halo - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_init', & routineP = moduleN//':'//routineN @@ -307,11 +299,11 @@ SUBROUTINE fb_atomic_halo_init(atomic_halo, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP,failure) ! if halo_atoms are associated, then deallocate and de-associate IF (ASSOCIATED(atomic_halo%obj%halo_atoms)) THEN DEALLOCATE(atomic_halo%obj%halo_atoms, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(atomic_halo%obj%halo_atoms) END IF atomic_halo%obj%owner_atom = 0 @@ -337,7 +329,6 @@ END SUBROUTINE fb_atomic_halo_init !> atomic_halo%obj%halo_atoms !> \param sorted [OPTIONAL]: if present, outputs atomic_halo%obj%sorted !> \param cost [OPTIONAL]: if present, outputs atomic_halo%obj%cost -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atomic_halo_get(atomic_halo, & @@ -347,15 +338,13 @@ SUBROUTINE fb_atomic_halo_get(atomic_halo, & nelectrons, & halo_atoms, & sorted, & - cost, & - error) + cost) TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo INTEGER, INTENT(OUT), OPTIONAL :: owner_atom, owner_id_in_halo, & natoms, nelectrons INTEGER, DIMENSION(:), OPTIONAL, POINTER :: halo_atoms LOGICAL, INTENT(OUT), OPTIONAL :: sorted REAL(KIND=dp), INTENT(OUT), OPTIONAL :: cost - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_get', & routineP = moduleN//':'//routineN @@ -363,7 +352,7 @@ SUBROUTINE fb_atomic_halo_get(atomic_halo, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP,failure) IF (PRESENT(owner_atom)) owner_atom = atomic_halo%obj%owner_atom IF (PRESENT(owner_id_in_halo)) owner_id_in_halo = atomic_halo%obj%owner_id_in_halo IF (PRESENT(natoms)) natoms = atomic_halo%obj%natoms @@ -390,7 +379,6 @@ END SUBROUTINE fb_atomic_halo_get !> contents of halo_atoms to atomic_halo%obj%halo_atoms !> \param sorted [OPTIONAL]: if present, sets atomic_halo%obj%sorted = sorted !> \param cost [OPTIONAL]: if present, sets atomic_halo%obj%cost = cost -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atomic_halo_set(atomic_halo, & @@ -400,15 +388,13 @@ SUBROUTINE fb_atomic_halo_set(atomic_halo, & nelectrons, & halo_atoms, & sorted, & - cost, & - error) + cost) TYPE(fb_atomic_halo_obj), INTENT(INOUT) :: atomic_halo INTEGER, INTENT(IN), OPTIONAL :: owner_atom, owner_id_in_halo, & natoms, nelectrons INTEGER, DIMENSION(:), OPTIONAL, POINTER :: halo_atoms LOGICAL, INTENT(IN), OPTIONAL :: sorted REAL(KIND=dp), INTENT(IN), OPTIONAL :: cost - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_set', & routineP = moduleN//':'//routineN @@ -417,7 +403,7 @@ SUBROUTINE fb_atomic_halo_set(atomic_halo, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atomic_halo%obj), cp_failure_level, routineP,failure) IF (PRESENT(owner_atom)) atomic_halo%obj%owner_atom = owner_atom IF (PRESENT(owner_id_in_halo)) atomic_halo%obj%owner_id_in_halo = owner_id_in_halo IF (PRESENT(natoms)) atomic_halo%obj%natoms = natoms @@ -425,7 +411,7 @@ SUBROUTINE fb_atomic_halo_set(atomic_halo, & IF (PRESENT(halo_atoms)) THEN IF (ASSOCIATED(atomic_halo%obj%halo_atoms)) THEN DEALLOCATE(atomic_halo%obj%halo_atoms, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF atomic_halo%obj%halo_atoms => halo_atoms END IF @@ -439,12 +425,10 @@ END SUBROUTINE fb_atomic_halo_set !> \brief Sort the list of atomic indices in the halo in accending order. !> The atomic_halo must not be empty !> \param atomic_halo the atomic_halo object -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_sort(atomic_halo, error) + SUBROUTINE fb_atomic_halo_sort(atomic_halo) TYPE(fb_atomic_halo_obj), INTENT(INOUT) :: atomic_halo - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_sort', & routineP = moduleN//':'//routineN @@ -454,12 +438,12 @@ SUBROUTINE fb_atomic_halo_sort(atomic_halo, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(SIZE(atomic_halo%obj%halo_atoms) > 0, cp_failure_level, routineP, error, failure) + CPPrecondition(SIZE(atomic_halo%obj%halo_atoms) > 0, cp_failure_level, routineP,failure) ALLOCATE(tmp_index(atomic_halo%obj%natoms), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL sort(atomic_halo%obj%halo_atoms, atomic_halo%obj%natoms, tmp_index) DEALLOCATE(tmp_index, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) atomic_halo%obj%sorted = .TRUE. END SUBROUTINE fb_atomic_halo_sort @@ -473,19 +457,16 @@ END SUBROUTINE fb_atomic_halo_sort !> \param iatom_halo the atomic index inside the halo !> \param found returns true if given atom is in the halo, otherwise !> false -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atomic_halo_atom_global2halo(atomic_halo, & iatom_global, & iatom_halo, & - found, & - error) + found) TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo INTEGER, INTENT(IN) :: iatom_global INTEGER, INTENT(OUT) :: iatom_halo LOGICAL, INTENT(OUT) :: found - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'fb_atomic_halo_atom_global2halo', & @@ -497,7 +478,7 @@ SUBROUTINE fb_atomic_halo_atom_global2halo(atomic_halo, & CALL timeset(routineN, handle) failure = .FALSE. - CPPrecondition(atomic_halo%obj%sorted, cp_failure_level, routineP, error, failure) + CPPrecondition(atomic_halo%obj%sorted, cp_failure_level, routineP,failure) iatom_halo = locate(atomic_halo%obj%halo_atoms, iatom_global) IF (iatom_halo == 0) THEN found = .FALSE. @@ -560,21 +541,19 @@ END FUNCTION fb_atomic_halo_nelectrons_estimate_Z !> \param qs_kind_set : cp2k qs_kind objects, provides information on the !> number of contracted gaussian functions each kind !> has -!> \param error ... !> \retval cost : computation cost w.r.t. the filter matrix !> calculation for this atomic halo !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** FUNCTION fb_atomic_halo_cost(atomic_halo, & particle_set, & - qs_kind_set,error) & + qs_kind_set) & RESULT(cost) TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo TYPE(particle_type), DIMENSION(:), & INTENT(IN) :: particle_set TYPE(qs_kind_type), DIMENSION(:), & INTENT(IN) :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: cost CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_cost', & @@ -588,7 +567,7 @@ FUNCTION fb_atomic_halo_cost(atomic_halo, & CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind, & kind_number=ikind) CALL get_qs_kind(qs_kind=qs_kind_set(ikind), & - ncgf=ncgf,error=error) + ncgf=ncgf) cost = cost + REAL(ncgf, dp) END DO ! diagonalisation is N**3 process, so cost must reflect that @@ -608,7 +587,6 @@ END FUNCTION fb_atomic_halo_cost !> array of halo atoms corresponding to the owner atom !> \param nhalo_atoms : outputs number of halo atoms !> \param owner_id_in_halo : the index of the owner atom in the halo_atoms list -!> \param error : CP2K error handler container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atomic_halo_build_halo_atoms(owner_atom, & @@ -617,8 +595,7 @@ SUBROUTINE fb_atomic_halo_build_halo_atoms(owner_atom, & pair_radii, & halo_atoms, & nhalo_atoms, & - owner_id_in_halo, & - error) + owner_id_in_halo) INTEGER, INTENT(IN) :: owner_atom TYPE(particle_type), DIMENSION(:), & INTENT(IN) :: particle_set @@ -627,7 +604,6 @@ SUBROUTINE fb_atomic_halo_build_halo_atoms(owner_atom, & INTENT(IN) :: pair_radii INTEGER, DIMENSION(:), POINTER :: halo_atoms INTEGER, INTENT(OUT) :: nhalo_atoms, owner_id_in_halo - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'fb_atomic_halo_build_halo_atoms', & @@ -642,7 +618,7 @@ SUBROUTINE fb_atomic_halo_build_halo_atoms(owner_atom, & failure = .FALSE. check_ok = .NOT. ASSOCIATED(halo_atoms) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) NULLIFY(atomic_kind) @@ -652,7 +628,7 @@ SUBROUTINE fb_atomic_halo_build_halo_atoms(owner_atom, & kind_number=ikind) natoms_global = SIZE(particle_set) ALLOCATE(halo_atoms(natoms_global), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) owner_id_in_halo = 0 nhalo_atoms = 0 DO jatom = 1, natoms_global @@ -684,13 +660,11 @@ END SUBROUTINE fb_atomic_halo_build_halo_atoms !> \brief Retains an fb_atomic_halo_list object !> \param atomic_halos the fb_atomic_halo object, its content must !> not be NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_retain(atomic_halos, error) + SUBROUTINE fb_atomic_halo_list_retain(atomic_halos) TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_list_retain', & routineP = moduleN//':'//routineN @@ -698,8 +672,8 @@ SUBROUTINE fb_atomic_halo_list_retain(atomic_halos, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP, error, failure) - CPPreconditionNoFail(atomic_halos%obj%ref_count>0, cp_failure_level, routineP, error) + CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP,failure) + CPPreconditionNoFail(atomic_halos%obj%ref_count>0, cp_failure_level, routineP) atomic_halos%obj%ref_count = atomic_halos%obj%ref_count + 1 END SUBROUTINE fb_atomic_halo_list_retain @@ -708,13 +682,11 @@ END SUBROUTINE fb_atomic_halo_list_retain !> \brief Releases an fb_atomic_halo_list object !> \param atomic_halos the fb_atomic_halo object, its content must !> not be UNDEFINED, and does nothing if it is NULL -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_release(atomic_halos, error) + SUBROUTINE fb_atomic_halo_list_release(atomic_halos) TYPE(fb_atomic_halo_list_obj), & INTENT(INOUT) :: atomic_halos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_list_release', & routineP = moduleN//':'//routineN @@ -724,20 +696,20 @@ SUBROUTINE fb_atomic_halo_list_release(atomic_halos, error) failure = .FALSE. IF (ASSOCIATED(atomic_halos%obj)) THEN - CPPreconditionNoFail(atomic_halos%obj%ref_count>0, cp_failure_level, routineP, error) + CPPreconditionNoFail(atomic_halos%obj%ref_count>0, cp_failure_level, routineP) atomic_halos%obj%ref_count = atomic_halos%obj%ref_count - 1 IF (atomic_halos%obj%ref_count == 0) THEN atomic_halos%obj%ref_count = 1 IF (ASSOCIATED(atomic_halos%obj%halos)) THEN DO ii = 1, SIZE(atomic_halos%obj%halos) - CALL fb_atomic_halo_release(atomic_halos%obj%halos(ii), error=error) + CALL fb_atomic_halo_release(atomic_halos%obj%halos(ii)) END DO DEALLOCATE(atomic_halos%obj%halos, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF atomic_halos%obj%ref_count = 0 DEALLOCATE(atomic_halos%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(atomic_halos%obj) @@ -807,13 +779,11 @@ END SUBROUTINE fb_atomic_halo_list_associate !> \brief Creates and initialises an empty fb_atomic_halo_list object !> \param atomic_halos the fb_atomic_halo object, its content must !> not be NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_create(atomic_halos, error) + SUBROUTINE fb_atomic_halo_list_create(atomic_halos) TYPE(fb_atomic_halo_list_obj), & INTENT(INOUT) :: atomic_halos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_list_create', & routineP = moduleN//':'//routineN @@ -822,9 +792,9 @@ SUBROUTINE fb_atomic_halo_list_create(atomic_halos, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP,failure) ALLOCATE(atomic_halos%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) atomic_halos%obj%nhalos = 0 atomic_halos%obj%max_nhalos = 0 NULLIFY(atomic_halos%obj%halos) @@ -838,13 +808,11 @@ END SUBROUTINE fb_atomic_halo_list_create !> \brief Initialises an fb_atomic_halo_list object and make it empty !> \param atomic_halos the fb_atomic_halo object, its content must !> not be NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_init(atomic_halos, error) + SUBROUTINE fb_atomic_halo_list_init(atomic_halos) TYPE(fb_atomic_halo_list_obj), & INTENT(INOUT) :: atomic_halos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_list_init', & routineP = moduleN//':'//routineN @@ -853,14 +821,14 @@ SUBROUTINE fb_atomic_halo_list_init(atomic_halos, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP,failure) ! if the arrays are associated, then deallocate and de-associate IF (ASSOCIATED(atomic_halos%obj%halos)) THEN DO ii = 1, SIZE(atomic_halos%obj%halos) - CALL fb_atomic_halo_release(atomic_halos%obj%halos(ii), error) + CALL fb_atomic_halo_release(atomic_halos%obj%halos(ii)) END DO DEALLOCATE(atomic_halos%obj%halos, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(atomic_halos%obj%halos) END IF atomic_halos%obj%nhalos = 0 @@ -877,16 +845,14 @@ END SUBROUTINE fb_atomic_halo_list_init !> \param nhalos [OPTIONAL]: if present, gives nhalos = atomic_halos%obj%nhalos !> \param max_nhalos [OPTIONAL]: if present, gives max_nhalos = atomic_halos%obj%max_nhalos !> \param halos [OPTIONAL]: if present, gives halos => atomic_halos%obj%halos -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_get(atomic_halos, nhalos, max_nhalos, halos, error) + SUBROUTINE fb_atomic_halo_list_get(atomic_halos, nhalos, max_nhalos, halos) TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos INTEGER, INTENT(OUT), OPTIONAL :: nhalos, max_nhalos TYPE(fb_atomic_halo_obj), DIMENSION(:), & OPTIONAL, POINTER :: halos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_list_get', & routineP = moduleN//':'//routineN @@ -894,7 +860,7 @@ SUBROUTINE fb_atomic_halo_list_get(atomic_halos, nhalos, max_nhalos, halos, erro LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP,failure) IF (PRESENT(nhalos)) nhalos = atomic_halos%obj%nhalos IF (PRESENT(max_nhalos)) max_nhalos = atomic_halos%obj%max_nhalos IF (PRESENT(halos)) halos => atomic_halos%obj%halos @@ -911,16 +877,14 @@ END SUBROUTINE fb_atomic_halo_list_get !> \param max_nhalos [OPTIONAL]: if present, sets atomic_halos%obj%max_nhalos = max_nhalos !> \param halos [OPTIONAL]: if present, reallocates atomic_halos%obj%halos !> to the size of halos -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_set(atomic_halos, nhalos, max_nhalos, halos, error) + SUBROUTINE fb_atomic_halo_list_set(atomic_halos, nhalos, max_nhalos, halos) TYPE(fb_atomic_halo_list_obj), & INTENT(INOUT) :: atomic_halos INTEGER, INTENT(IN), OPTIONAL :: nhalos, max_nhalos TYPE(fb_atomic_halo_obj), DIMENSION(:), & OPTIONAL, POINTER :: halos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_list_set', & routineP = moduleN//':'//routineN @@ -929,16 +893,16 @@ SUBROUTINE fb_atomic_halo_list_set(atomic_halos, nhalos, max_nhalos, halos, erro LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atomic_halos%obj), cp_failure_level, routineP,failure) IF (PRESENT(nhalos)) atomic_halos%obj%nhalos = nhalos IF (PRESENT(max_nhalos)) atomic_halos%obj%max_nhalos = max_nhalos IF (PRESENT(halos)) THEN IF (ASSOCIATED(atomic_halos%obj%halos)) THEN DO ihalo = 1, SIZE(atomic_halos%obj%halos) - CALL fb_atomic_halo_release(atomic_halos%obj%halos(ihalo), error) + CALL fb_atomic_halo_release(atomic_halos%obj%halos(ihalo)) END DO DEALLOCATE(atomic_halos%obj%halos, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF atomic_halos%obj%halos => halos END IF @@ -951,15 +915,13 @@ END SUBROUTINE fb_atomic_halo_list_set !> \param atomic_halos the fb_atomic_halo object !> \param para_env pointer to a para_env_type object containing MPI info !> \param fb_section pointer to the input section to filtered basis method -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_write(atomic_halos, para_env, fb_section, error) + SUBROUTINE fb_atomic_halo_list_write(atomic_halos, para_env, fb_section) TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: fb_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_atomic_halo_list_write', & routineP = moduleN//':'//routineN @@ -976,10 +938,10 @@ SUBROUTINE fb_atomic_halo_list_write(atomic_halos, para_env, fb_section, error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info, fb_section, & - "PRINT%ATOMIC_HALOS", error=error), & + "PRINT%ATOMIC_HALOS"), & cp_p_file)) THEN print_unit = cp_print_key_unit_nr(logger=logger, & basis_section=fb_section, & @@ -989,8 +951,7 @@ SUBROUTINE fb_atomic_halo_list_write(atomic_halos, para_env, fb_section, error) log_filename=.FALSE., & file_position="REWIND", & file_action="WRITE", & - is_new_file=new_file, & - error=error) + is_new_file=new_file) mype = para_env%mepos ! print headline string = "" @@ -1005,14 +966,12 @@ SUBROUTINE fb_atomic_halo_list_write(atomic_halos, para_env, fb_section, error) ! print content CALL fb_atomic_halo_list_get(atomic_halos=atomic_halos, & nhalos=nhalos, & - halos=halos, & - error=error) + halos=halos) DO ihalo = 1, nhalos CALL fb_atomic_halo_get(halos(ihalo), & owner_atom=owner_atom, & natoms=nhalo_atoms, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) WRITE (UNIT=print_unit, FMT="(2X,I6,A)", ADVANCE="no") & owner_atom, " : " DO jatom = 1, nhalo_atoms @@ -1023,7 +982,7 @@ SUBROUTINE fb_atomic_halo_list_write(atomic_halos, para_env, fb_section, error) END DO ! finish CALL cp_print_key_finished_output(print_unit, logger, fb_section, & - "PRINT%ATOMIC_HALOS", error=error) + "PRINT%ATOMIC_HALOS") END IF END SUBROUTINE fb_atomic_halo_list_write @@ -1034,15 +993,13 @@ END SUBROUTINE fb_atomic_halo_list_write !> \param atomic_halos : the fb_atomic_halo object !> \param para_env : pointer to a para_env_type object containing MPI info !> \param scf_section : pointer to the scf input section -!> \param error : CP2K data container for error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_atomic_halo_list_write_info(atomic_halos, para_env, scf_section, error) + SUBROUTINE fb_atomic_halo_list_write_info(atomic_halos, para_env, scf_section) TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'fb_atomic_halo_list_write_info', & @@ -1058,25 +1015,22 @@ SUBROUTINE fb_atomic_halo_list_write_info(atomic_halos, para_env, scf_section, e failure = .FALSE. NULLIFY(logger, halos) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_nr = cp_print_key_unit_nr(logger, scf_section, & "PRINT%FILTER_MATRIX", & - extension="", & - error=error) + extension="") ! obtain data CALL fb_atomic_halo_list_get(atomic_halos=atomic_halos, & halos=halos, & - nhalos=nhalos, & - error=error) + nhalos=nhalos) max_natoms = 0 min_natoms = HUGE(0) total_n_halo_atoms = 0 total_n_halos = nhalos DO ihalo = 1, nhalos CALL fb_atomic_halo_get(atomic_halo=halos(ihalo), & - natoms=nhalo_atoms, & - error=error) + natoms=nhalo_atoms) total_n_halo_atoms = total_n_halo_atoms + nhalo_atoms max_natoms = MAX(max_natoms, nhalo_atoms) min_natoms = MIN(min_natoms, nhalo_atoms) @@ -1103,7 +1057,7 @@ SUBROUTINE fb_atomic_halo_list_write_info(atomic_halos, para_env, scf_section, e END IF ! finish CALL cp_print_key_finished_output(unit_nr, logger, scf_section, & - "PRINT%FILTER_MATRIX", error=error) + "PRINT%FILTER_MATRIX") END SUBROUTINE fb_atomic_halo_list_write_info diff --git a/src/qs_fb_atomic_matrix_methods.F b/src/qs_fb_atomic_matrix_methods.F index 1b48531c42..83fd5b8d13 100644 --- a/src/qs_fb_atomic_matrix_methods.F +++ b/src/qs_fb_atomic_matrix_methods.F @@ -69,7 +69,6 @@ MODULE qs_fb_atomic_matrix_methods !> atomic matrix !> \param blk_col_start : first col in each atomic blk col in the !> atomic matrix -!> \param error : the data container for CP2K error logs !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atmatrix_calc_size(dbcsr_mat, & @@ -77,13 +76,11 @@ SUBROUTINE fb_atmatrix_calc_size(dbcsr_mat, & nrows, & ncols, & blk_row_start, & - blk_col_start, & - error) + blk_col_start) TYPE(cp_dbcsr_type), POINTER :: dbcsr_mat TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo INTEGER, INTENT(OUT) :: nrows, ncols INTEGER, DIMENSION(:), INTENT(OUT) :: blk_row_start, blk_col_start - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_atmatrix_calc_size', & routineP = moduleN//':'//routineN @@ -102,12 +99,11 @@ SUBROUTINE fb_atmatrix_calc_size(dbcsr_mat, & col_block_size_data => cp_dbcsr_col_block_sizes(dbcsr_mat) CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) check_ok = SIZE(blk_row_start) .GE. (natoms_in_halo + 1) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = SIZE(blk_col_start) .GE. (natoms_in_halo + 1) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) blk_row_start = 0 blk_col_start = 0 nrows = 0 @@ -141,7 +137,6 @@ END SUBROUTINE fb_atmatrix_calc_size !> atomic matrix !> \param blk_col_start : first col in each atomic blk col in the !> atomic matrix -!> \param error : the data container for CP2K error logs !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & @@ -149,15 +144,13 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & para_env, & atomic_matrix, & blk_row_start, & - blk_col_start, & - error) + blk_col_start) TYPE(cp_dbcsr_type), POINTER :: dbcsr_mat TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo TYPE(cp_para_env_type), POINTER :: para_env REAL(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: atomic_matrix INTEGER, DIMENSION(:), INTENT(IN) :: blk_row_start, blk_col_start - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_atmatrix_construct', & routineP = moduleN//':'//routineN @@ -193,26 +186,23 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & END IF ! generate send and receiv atomic pairs - CALL fb_com_atom_pairs_create(atom_pairs_send, error) - CALL fb_com_atom_pairs_create(atom_pairs_recv, error) + CALL fb_com_atom_pairs_create(atom_pairs_send) + CALL fb_com_atom_pairs_create(atom_pairs_recv) CALL fb_atmatrix_generate_com_pairs(dbcsr_mat, & atomic_halo, & para_env, & atom_pairs_send, & - atom_pairs_recv, & - error) + atom_pairs_recv) ! get com pair informations CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_send, & pairs=pairs_send, & npairs=npairs_send, & - natoms_encode=send_encode, & - error=error) + natoms_encode=send_encode) CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_recv, & pairs=pairs_recv, & npairs=npairs_recv, & - natoms_encode=recv_encode, & - error=error) + natoms_encode=recv_encode) ! get para_env info numprocs = para_env%num_pe @@ -223,13 +213,13 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & ! allocate temporary arrays for send ALLOCATE(send_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup send buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_send, & @@ -239,21 +229,20 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & send_sizes, & send_disps, & send_pair_count, & - send_pair_disps, & - error) + send_pair_disps) ! allocate send buffer ALLOCATE(send_buf(SUM(send_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! allocate temporary arrays for recv ALLOCATE(recv_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup recv buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_recv, & @@ -263,11 +252,10 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & recv_sizes, & recv_disps, & recv_pair_count, & - recv_pair_disps, & - error) + recv_pair_disps) ! allocate recv buffer ALLOCATE(recv_buf(SUM(recv_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! do packing DO ipe = 1, numprocs ! need to reuse send_sizes as an accumulative displacement, so recalculate @@ -303,15 +291,15 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & ! cleanup temporary arrays no longer needed DEALLOCATE(send_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! do unpacking DO ipe = 1, numprocs @@ -329,12 +317,12 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & ! this particular atomic_halo CALL fb_atomic_halo_atom_global2halo(atomic_halo, & iatom, iatom_in_halo, & - found, error) - CPPostcondition(found, cp_failure_level, routineP, error, failure) + found) + CPPostcondition(found, cp_failure_level, routineP,failure) CALL fb_atomic_halo_atom_global2halo(atomic_halo, & jatom, jatom_in_halo, & - found, error) - CPPostcondition(found, cp_failure_level, routineP, error, failure) + found) + CPPostcondition(found, cp_failure_level, routineP,failure) ! put block into the full conventional matrix DO jj = 1, ncols_blk DO ii = 1, nrows_blk @@ -351,17 +339,17 @@ SUBROUTINE fb_atmatrix_construct(dbcsr_mat, & ! cleanup rest of the temporary arrays DEALLOCATE(recv_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - CALL fb_com_atom_pairs_release(atom_pairs_send, error) - CALL fb_com_atom_pairs_release(atom_pairs_recv, error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + CALL fb_com_atom_pairs_release(atom_pairs_send) + CALL fb_com_atom_pairs_release(atom_pairs_recv) CALL timestop(handle) @@ -385,21 +373,18 @@ END SUBROUTINE fb_atmatrix_construct !> atomic matrix !> \param blk_col_start : first col in each atomic blk col in the !> atomic matrix -!> \param error : the data container for CP2K error logs !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atmatrix_construct_2(matrix_storage, & atomic_halo, & atomic_matrix, & blk_row_start, & - blk_col_start, & - error) + blk_col_start) TYPE(fb_matrix_data_obj), INTENT(IN) :: matrix_storage TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo REAL(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: atomic_matrix INTEGER, DIMENSION(:), INTENT(IN) :: blk_row_start, blk_col_start - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_atmatrix_construct_2', & routineP = moduleN//':'//routineN @@ -416,9 +401,9 @@ SUBROUTINE fb_atmatrix_construct_2(matrix_storage, & failure = .FALSE. check_ok = fb_matrix_data_has_data(matrix_storage) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = fb_atomic_halo_has_data(atomic_halo) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) NULLIFY(halo_atoms, blk_p) @@ -430,8 +415,7 @@ SUBROUTINE fb_atmatrix_construct_2(matrix_storage, & ! get atomic halo information CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) ! construct atomic matrix using data from matrix_storage DO iatom = 1, natoms_in_halo @@ -442,8 +426,7 @@ SUBROUTINE fb_atmatrix_construct_2(matrix_storage, & iatom_global, & jatom_global, & blk_p, & - found, & - error) + found) ! copy data to atomic_matrix if found IF (found) THEN DO jj = 1, SIZE(blk_p, 2) @@ -475,22 +458,19 @@ END SUBROUTINE fb_atmatrix_construct_2 !> data to be sent !> \param atom_pairs_recv : list of atom blocks from remote DBCSR matrix !> data to be recveived -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atmatrix_generate_com_pairs(dbcsr_mat, & atomic_halo, & para_env, & atom_pairs_send, & - atom_pairs_recv, & - error) + atom_pairs_recv) TYPE(cp_dbcsr_type), POINTER :: dbcsr_mat TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo TYPE(cp_para_env_type), POINTER :: para_env TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs_send, & atom_pairs_recv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_atmatrix_generate_com_pairs', & @@ -517,21 +497,20 @@ SUBROUTINE fb_atmatrix_generate_com_pairs(dbcsr_mat, & ! initialise atom_pairs_send and atom_pairs_receive IF (fb_com_atom_pairs_has_data(atom_pairs_send)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_send, error) + CALL fb_com_atom_pairs_init(atom_pairs_send) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_send, error) + CALL fb_com_atom_pairs_create(atom_pairs_send) END IF IF (fb_com_atom_pairs_has_data(atom_pairs_recv)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_recv, error) + CALL fb_com_atom_pairs_init(atom_pairs_recv) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_recv, error) + CALL fb_com_atom_pairs_create(atom_pairs_recv) END IF ! get atomic halo information CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) ! get the total number of atoms, we can obtain this directly ! from the global block row dimension of the dbcsr matrix @@ -551,7 +530,7 @@ SUBROUTINE fb_atmatrix_generate_com_pairs(dbcsr_mat, & ntasks_recv = natoms_in_halo*natoms_in_halo ALLOCATE(tasks_recv(TASK_N_RECORDS,ntasks_recv), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! now that tasks_recv has been allocated, generate the tasks itask = 1 @@ -586,26 +565,24 @@ SUBROUTINE fb_atmatrix_generate_com_pairs(dbcsr_mat, & END DO ! iatom ! create tasks - CALL fb_com_tasks_create(com_tasks_recv, error) - CALL fb_com_tasks_create(com_tasks_send, error) + CALL fb_com_tasks_create(com_tasks_recv) + CALL fb_com_tasks_create(com_tasks_send) CALL fb_com_tasks_set(com_tasks=com_tasks_recv, & task_dim=TASK_N_RECORDS, & ntasks=ntasks_recv, & nencode=nblkrows_total, & - tasks=tasks_recv, & - error=error) + tasks=tasks_recv) ! genearte the send task list (tasks_send) from the recv task list CALL fb_com_tasks_transpose_dest_src(com_tasks_recv, ">", com_tasks_send, & - para_env, error) + para_env) CALL fb_com_tasks_get(com_tasks=com_tasks_send, & ntasks=ntasks_send, & tasks=tasks_send, & - nencode=nencode, & - error=error) + nencode=nencode) ! because the atomic_halos and the neighbor_list_set used to ! generate the sparse structure of the DBCSR matrix do not @@ -640,13 +617,12 @@ SUBROUTINE fb_atmatrix_generate_com_pairs(dbcsr_mat, & ! tasks_send is set through the pointer already CALL fb_com_tasks_set(com_tasks=com_tasks_send, & - ntasks=ntasks_send, & - error=error) + ntasks=ntasks_send) ! now, re-distribute the new send tasks list to other processors ! to build the updated recv tasks list CALL fb_com_tasks_transpose_dest_src(com_tasks_recv, "<", com_tasks_send, & - para_env, error) + para_env) ! task lists are now complete, now construct the atom_pairs_send ! and atom_pairs_recv from the tasks lists @@ -654,18 +630,16 @@ SUBROUTINE fb_atmatrix_generate_com_pairs(dbcsr_mat, & atom_pairs=atom_pairs_send, & natoms_encode=nencode, & send_or_recv="send", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) CALL fb_com_tasks_build_atom_pairs(com_tasks=com_tasks_recv, & atom_pairs=atom_pairs_recv, & natoms_encode=nencode, & send_or_recv="recv", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) ! cleanup - CALL fb_com_tasks_release(com_tasks_recv, error) - CALL fb_com_tasks_release(com_tasks_send, error) + CALL fb_com_tasks_release(com_tasks_recv) + CALL fb_com_tasks_release(com_tasks_send) CALL timestop(handle) @@ -685,15 +659,13 @@ END SUBROUTINE fb_atmatrix_generate_com_pairs !> data to be sent !> \param atom_pairs_recv : list of atom blocks from remote DBCSR matrix !> data to be recveived -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & atomic_halos, & para_env, & atom_pairs_send, & - atom_pairs_recv, & - error) + atom_pairs_recv) TYPE(cp_dbcsr_type), POINTER :: dbcsr_mat TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos @@ -701,7 +673,6 @@ SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs_send, & atom_pairs_recv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_atmatrix_generate_com_pairs_2', & @@ -730,21 +701,20 @@ SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & ! initialise atom_pairs_send and atom_pairs_receive IF (fb_com_atom_pairs_has_data(atom_pairs_send)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_send, error) + CALL fb_com_atom_pairs_init(atom_pairs_send) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_send, error) + CALL fb_com_atom_pairs_create(atom_pairs_send) END IF IF (fb_com_atom_pairs_has_data(atom_pairs_recv)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_recv, error) + CALL fb_com_atom_pairs_init(atom_pairs_recv) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_recv, error) + CALL fb_com_atom_pairs_create(atom_pairs_recv) END IF ! get atomic halo list information CALL fb_atomic_halo_list_get(atomic_halos=atomic_halos, & nhalos=nhalos, & - halos=halos, & - error=error) + halos=halos) ! get the total number of atoms, we can obtain this directly ! from the global block row dimension of the dbcsr matrix CALL cp_dbcsr_get_info(matrix=dbcsr_mat, & @@ -754,12 +724,11 @@ SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & ntasks_recv = 0 DO ihalo = 1, nhalos CALL fb_atomic_halo_get(atomic_halo=halos(ihalo), & - natoms=natoms_in_halo, & - error=error) + natoms=natoms_in_halo) ntasks_recv = ntasks_recv + natoms_in_halo*natoms_in_halo END DO ALLOCATE(tasks_recv(TASK_N_RECORDS,ntasks_recv), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! now that tasks_recv has been allocated, generate the tasks @@ -769,8 +738,7 @@ SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & DO ihalo = 1, nhalos CALL fb_atomic_halo_get(atomic_halo=halos(ihalo), & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) DO iatom = 1, natoms_in_halo iatom_global = halo_atoms(iatom) DO jatom = 1, natoms_in_halo @@ -803,25 +771,23 @@ SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & END DO ! ihalo ! create tasks - CALL fb_com_tasks_create(com_tasks_recv, error) - CALL fb_com_tasks_create(com_tasks_send, error) + CALL fb_com_tasks_create(com_tasks_recv) + CALL fb_com_tasks_create(com_tasks_send) CALL fb_com_tasks_set(com_tasks=com_tasks_recv, & task_dim=TASK_N_RECORDS, & ntasks=ntasks_recv, & nencode=nblkrows_total, & - tasks=tasks_recv, & - error=error) + tasks=tasks_recv) ! genearte the send task list (tasks_send) from the recv task list CALL fb_com_tasks_transpose_dest_src(com_tasks_recv, ">", com_tasks_send, & - para_env, error) + para_env) CALL fb_com_tasks_get(com_tasks=com_tasks_send, & ntasks=ntasks_send, & tasks=tasks_send, & - nencode=nencode, & - error=error) + nencode=nencode) ! because the atomic_halos and the neighbor_list_set used to ! generate the sparse structure of the DBCSR matrix do not @@ -856,13 +822,12 @@ SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & ! tasks_send is set through the pointer already CALL fb_com_tasks_set(com_tasks=com_tasks_send, & - ntasks=ntasks_send, & - error=error) + ntasks=ntasks_send) ! now, re-distribute the new send tasks list to other processors ! to build the updated recv tasks list CALL fb_com_tasks_transpose_dest_src(com_tasks_recv, "<", com_tasks_send, & - para_env, error) + para_env) ! task lists are now complete, now construct the atom_pairs_send ! and atom_pairs_recv from the tasks lists @@ -870,18 +835,16 @@ SUBROUTINE fb_atmatrix_generate_com_pairs_2(dbcsr_mat, & atom_pairs=atom_pairs_send, & natoms_encode=nencode, & send_or_recv="send", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) CALL fb_com_tasks_build_atom_pairs(com_tasks=com_tasks_recv, & atom_pairs=atom_pairs_recv, & natoms_encode=nencode, & send_or_recv="recv", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) ! cleanup - CALL fb_com_tasks_release(com_tasks_recv, error) - CALL fb_com_tasks_release(com_tasks_send, error) + CALL fb_com_tasks_release(com_tasks_recv) + CALL fb_com_tasks_release(com_tasks_send) CALL timestop(handle) diff --git a/src/qs_fb_com_tasks_types.F b/src/qs_fb_com_tasks_types.F index 2d9d14b5f7..3846b2e1eb 100644 --- a/src/qs_fb_com_tasks_types.F +++ b/src/qs_fb_com_tasks_types.F @@ -161,12 +161,10 @@ MODULE qs_fb_com_tasks_types !> \brief Retains an fb_com_tasks object !> \param com_tasks the fb_com_tasks object, its content must not be !> NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_tasks_retain(com_tasks, error) + SUBROUTINE fb_com_tasks_retain(com_tasks) TYPE(fb_com_tasks_obj), INTENT(IN) :: com_tasks - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_tasks_retain', & routineP = moduleN//':'//routineN @@ -174,8 +172,8 @@ SUBROUTINE fb_com_tasks_retain(com_tasks, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP, error, failure) - CPPreconditionNoFail(com_tasks%obj%ref_count>0, cp_failure_level, routineP, error) + CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP,failure) + CPPreconditionNoFail(com_tasks%obj%ref_count>0, cp_failure_level, routineP) com_tasks%obj%ref_count = com_tasks%obj%ref_count + 1 END SUBROUTINE fb_com_tasks_retain @@ -184,12 +182,10 @@ END SUBROUTINE fb_com_tasks_retain !> \brief Retains an fb_com_atom_pairs object !> \param atom_pairs the fb_com_atom_pairs object, its content must not be !> NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_atom_pairs_retain(atom_pairs, error) + SUBROUTINE fb_com_atom_pairs_retain(atom_pairs) TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_atom_pairs_retain', & routineP = moduleN//':'//routineN @@ -197,8 +193,8 @@ SUBROUTINE fb_com_atom_pairs_retain(atom_pairs, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP, error, failure) - CPPreconditionNoFail(atom_pairs%obj%ref_count>0, cp_failure_level, routineP, error) + CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP,failure) + CPPreconditionNoFail(atom_pairs%obj%ref_count>0, cp_failure_level, routineP) atom_pairs%obj%ref_count = atom_pairs%obj%ref_count + 1 END SUBROUTINE fb_com_atom_pairs_retain @@ -208,12 +204,10 @@ END SUBROUTINE fb_com_atom_pairs_retain !> \param com_tasks the fb_com_tasks object, its content must not be !> UNDEFINED, and the subroutine does nothing if the !> content points to NULL -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_tasks_release(com_tasks, error) + SUBROUTINE fb_com_tasks_release(com_tasks) TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_tasks_release', & routineP = moduleN//':'//routineN @@ -223,17 +217,17 @@ SUBROUTINE fb_com_tasks_release(com_tasks, error) failure = .FALSE. IF (ASSOCIATED(com_tasks%obj)) THEN - CPPreconditionNoFail(com_tasks%obj%ref_count>0, cp_failure_level, routineP, error) + CPPreconditionNoFail(com_tasks%obj%ref_count>0, cp_failure_level, routineP) com_tasks%obj%ref_count = com_tasks%obj%ref_count - 1 IF (com_tasks%obj%ref_count == 0) THEN com_tasks%obj%ref_count = 1 IF (ASSOCIATED(com_tasks%obj%tasks)) THEN DEALLOCATE(com_tasks%obj%tasks, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF com_tasks%obj%ref_count = 0 DEALLOCATE(com_tasks%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(com_tasks%obj) @@ -246,13 +240,11 @@ END SUBROUTINE fb_com_tasks_release !> \param atom_pairs the fb_com_atom_pairs object, its content must not !> be UNDEFINED, and the subroutine does nothing if !> the content points to NULL -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_atom_pairs_release(atom_pairs, error) + SUBROUTINE fb_com_atom_pairs_release(atom_pairs) TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_atom_pairs_release', & routineP = moduleN//':'//routineN @@ -262,17 +254,17 @@ SUBROUTINE fb_com_atom_pairs_release(atom_pairs, error) failure = .FALSE. IF (ASSOCIATED(atom_pairs%obj)) THEN - CPPreconditionNoFail(atom_pairs%obj%ref_count>0, cp_failure_level, routineP, error) + CPPreconditionNoFail(atom_pairs%obj%ref_count>0, cp_failure_level, routineP) atom_pairs%obj%ref_count = atom_pairs%obj%ref_count - 1 IF (atom_pairs%obj%ref_count == 0) THEN atom_pairs%obj%ref_count = 1 IF (ASSOCIATED(atom_pairs%obj%pairs)) THEN DEALLOCATE(atom_pairs%obj%pairs, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF atom_pairs%obj%ref_count = 0 DEALLOCATE(atom_pairs%obj, stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(atom_pairs%obj) @@ -391,12 +383,10 @@ END FUNCTION fb_com_atom_pairs_has_data !> \brief Creates and initialises an empty fb_com_tasks object !> \param com_tasks the fb_com_tasks object, its content must be NULL !> and cannot be UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_tasks_create(com_tasks, error) + SUBROUTINE fb_com_tasks_create(com_tasks) TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_tasks_create', & routineP = moduleN//':'//routineN @@ -405,9 +395,9 @@ SUBROUTINE fb_com_tasks_create(com_tasks, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(com_tasks%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(com_tasks%obj), cp_failure_level, routineP,failure) ALLOCATE(com_tasks%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) com_tasks%obj%task_dim = TASK_N_RECORDS com_tasks%obj%ntasks = 0 com_tasks%obj%nencode = 0 @@ -422,13 +412,11 @@ END SUBROUTINE fb_com_tasks_create !> \brief Creates and initialises an empty fb_com_atom_pairs object !> \param atom_pairs the fb_com_atom_pairs object, its content must be !> NULL and cannot be UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_atom_pairs_create(atom_pairs, error) + SUBROUTINE fb_com_atom_pairs_create(atom_pairs) TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_atom_pairs_create', & routineP = moduleN//':'//routineN @@ -437,9 +425,9 @@ SUBROUTINE fb_com_atom_pairs_create(atom_pairs, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP,failure) ALLOCATE(atom_pairs%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) atom_pairs%obj%npairs = 0 atom_pairs%obj%natoms_encode = 0 NULLIFY(atom_pairs%obj%pairs) @@ -453,12 +441,10 @@ END SUBROUTINE fb_com_atom_pairs_create !> \brief Initialises an fb_com_tasks object, and makes it empty !> \param com_tasks the fb_com_tasks object, its content must not be !> NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_tasks_init(com_tasks, error) + SUBROUTINE fb_com_tasks_init(com_tasks) TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_tasks_init', & routineP = moduleN//':'//routineN @@ -467,10 +453,10 @@ SUBROUTINE fb_com_tasks_init(com_tasks, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP,failure) IF (ASSOCIATED(com_tasks%obj%tasks)) THEN DEALLOCATE(com_tasks%obj%tasks, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(com_tasks%obj%tasks) END IF com_tasks%obj%task_dim = TASK_N_RECORDS @@ -483,13 +469,11 @@ END SUBROUTINE fb_com_tasks_init !> \brief Initialises an fb_com_atom_pairs object, and makes it empty !> \param atom_pairs the fb_com_atom_pairs object, its content must not !> be NULL or UNDEFINED -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_com_atom_pairs_init(atom_pairs, error) + SUBROUTINE fb_com_atom_pairs_init(atom_pairs) TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_atom_pairs_init', & routineP = moduleN//':'//routineN @@ -498,10 +482,10 @@ SUBROUTINE fb_com_atom_pairs_init(atom_pairs, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP,failure) IF (ASSOCIATED(atom_pairs%obj%pairs)) THEN DEALLOCATE(atom_pairs%obj%pairs, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(atom_pairs%obj%pairs) END IF atom_pairs%obj%npairs = 0 @@ -519,20 +503,17 @@ END SUBROUTINE fb_com_atom_pairs_init !> \param ntasks [OPTIONAL]: if present, outputs com_tasks%obj%ntasks !> \param nencode [OPTIONAL]: if present, outputs com_tasks%obj%nencode !> \param tasks [OPTIONAL]: if present, outputs pointer com_tasks%obj%tasks -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_tasks_get(com_tasks, & task_dim, & ntasks, & nencode, & - tasks, & - error) + tasks) TYPE(fb_com_tasks_obj), INTENT(IN) :: com_tasks INTEGER, INTENT(OUT), OPTIONAL :: task_dim, ntasks, nencode INTEGER(KIND=int_8), DIMENSION(:, :), & OPTIONAL, POINTER :: tasks - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_tasks_get', & routineP = moduleN//':'//routineN @@ -540,7 +521,7 @@ SUBROUTINE fb_com_tasks_get(com_tasks, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP,failure) IF (PRESENT(task_dim)) task_dim = com_tasks%obj%task_dim IF (PRESENT(ntasks)) ntasks = com_tasks%obj%ntasks IF (PRESENT(nencode)) nencode = com_tasks%obj%nencode @@ -557,19 +538,16 @@ END SUBROUTINE fb_com_tasks_get !> \param npairs [OPTIONAL]: if present, outputs atom_pairs%obj%npairs !> \param natoms_encode [OPTIONAL]: if present, outputs atom_pairs%obj%natoms_encode !> \param pairs [OPTIONAL]: if present, outputs pointer atom_pairs%obj%pairs -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_atom_pairs_get(atom_pairs, & npairs, & natoms_encode, & - pairs, & - error) + pairs) TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs INTEGER, INTENT(OUT), OPTIONAL :: npairs, natoms_encode INTEGER(KIND=int_8), DIMENSION(:), & OPTIONAL, POINTER :: pairs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_atom_pairs_get', & routineP = moduleN//':'//routineN @@ -577,7 +555,7 @@ SUBROUTINE fb_com_atom_pairs_get(atom_pairs, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP,failure) IF (PRESENT(npairs)) npairs = atom_pairs%obj%npairs IF (PRESENT(natoms_encode)) natoms_encode = atom_pairs%obj%natoms_encode IF (PRESENT(pairs)) pairs => atom_pairs%obj%pairs @@ -594,20 +572,17 @@ END SUBROUTINE fb_com_atom_pairs_get !> \param ntasks [OPTIONAL]: if present, sets com_tasks%obj%ntasks !> \param nencode [OPTIONAL]: if present, sets com_tasks%obj%nencode !> \param tasks [OPTIONAL]: if present, associates pointer com_tasks%obj%tasks -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_tasks_set(com_tasks, & task_dim, & ntasks, & nencode, & - tasks, & - error) + tasks) TYPE(fb_com_tasks_obj), INTENT(INOUT) :: com_tasks INTEGER, INTENT(IN), OPTIONAL :: task_dim, ntasks, nencode INTEGER(KIND=int_8), DIMENSION(:, :), & OPTIONAL, POINTER :: tasks - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_tasks_set', & routineP = moduleN//':'//routineN @@ -616,14 +591,14 @@ SUBROUTINE fb_com_tasks_set(com_tasks, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(com_tasks%obj), cp_failure_level, routineP,failure) IF (PRESENT(task_dim)) com_tasks%obj%task_dim = task_dim IF (PRESENT(ntasks)) com_tasks%obj%ntasks = ntasks IF (PRESENT(nencode)) com_tasks%obj%nencode = nencode IF (PRESENT(tasks)) THEN IF (ASSOCIATED(com_tasks%obj%tasks)) THEN DEALLOCATE(com_tasks%obj%tasks, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF com_tasks%obj%tasks => tasks END IF @@ -639,20 +614,17 @@ END SUBROUTINE fb_com_tasks_set !> \param npairs [OPTIONAL]: if present, sets atom_pairs%obj%npairs !> \param natoms_encode [OPTIONAL]: if present, sets atom_pairs%obj%natoms_encode !> \param pairs [OPTIONAL]: if present, associates pointer atom_pairs%obj%pairs -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_atom_pairs_set(atom_pairs, & npairs, & natoms_encode, & - pairs, & - error) + pairs) TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs INTEGER, INTENT(IN), OPTIONAL :: npairs, natoms_encode INTEGER(KIND=int_8), DIMENSION(:), & OPTIONAL, POINTER :: pairs - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_com_atom_pairs_set', & routineP = moduleN//':'//routineN @@ -661,13 +633,13 @@ SUBROUTINE fb_com_atom_pairs_set(atom_pairs, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(atom_pairs%obj), cp_failure_level, routineP,failure) IF (PRESENT(npairs)) atom_pairs%obj%npairs = npairs IF (PRESENT(natoms_encode)) atom_pairs%obj%natoms_encode = natoms_encode IF (PRESENT(pairs)) THEN IF (ASSOCIATED(atom_pairs%obj%pairs)) THEN DEALLOCATE(atom_pairs%obj%pairs, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF atom_pairs%obj%pairs => pairs END IF @@ -688,19 +660,16 @@ END SUBROUTINE fb_com_atom_pairs_set !> having the src process id equal to my_id !> \param para_env CP2K parallel environment object that stores MPI related !> information of the current run -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_tasks_transpose_dest_src(tasks_dest_is_me, & direction, & tasks_src_is_me, & - para_env, & - error) + para_env) TYPE(fb_com_tasks_obj), INTENT(INOUT) :: tasks_dest_is_me CHARACTER, INTENT(IN) :: direction TYPE(fb_com_tasks_obj), INTENT(INOUT) :: tasks_src_is_me TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_com_tasks_transpose_dest_src', & @@ -728,33 +697,31 @@ SUBROUTINE fb_com_tasks_transpose_dest_src(tasks_dest_is_me, & task_dim=task_dim, & ntasks=ntasks_in, & tasks=tasks_in, & - nencode=nencode, & - error=error) + nencode=nencode) rank_pos = TASK_DEST ELSE CALL fb_com_tasks_get(com_tasks=tasks_dest_is_me, & task_dim=task_dim, & ntasks=ntasks_in, & tasks=tasks_in, & - nencode=nencode, & - error=error) + nencode=nencode) rank_pos = TASK_SRC END IF ! allocate local arrays ALLOCATE(send_sizes(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_disps(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_buf(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_sizes(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_disps(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_buf(para_env%num_pe), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! first count how many local recv/send tasks need to be sent to ! other processes, and share this information with the other @@ -792,13 +759,13 @@ SUBROUTINE fb_com_tasks_transpose_dest_src(tasks_dest_is_me, & ! reallocate send and recv buffers to the correct sizes for ! transferring the actual tasks DEALLOCATE(send_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_buf(SUM(send_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_buf(SUM(recv_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! now that the send buffer is of correct size, do packing ! send_buf and recv_buf may be zero sized @@ -820,17 +787,17 @@ SUBROUTINE fb_com_tasks_transpose_dest_src(tasks_dest_is_me, & ! deallocate send buffers DEALLOCATE(send_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! allocate the output task list ntasks_out = SUM(recv_sizes) / task_dim ! this will not be deallocated in this subroutine ALLOCATE(tasks_out(task_dim,ntasks_out), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! do unpacking itask = 0 @@ -850,24 +817,22 @@ SUBROUTINE fb_com_tasks_transpose_dest_src(tasks_dest_is_me, & task_dim=task_dim, & ntasks=ntasks_out, & tasks=tasks_out, & - nencode=nencode, & - error=error) + nencode=nencode) ELSE CALL fb_com_tasks_set(com_tasks=tasks_src_is_me, & task_dim=task_dim, & ntasks=ntasks_out, & tasks=tasks_out, & - nencode=nencode, & - error=error) + nencode=nencode) END IF ! deallocate recv buffers DEALLOCATE(recv_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -891,22 +856,19 @@ END SUBROUTINE fb_com_tasks_transpose_dest_src !> process !> \param symmetric whether the matrix the blocks are to be taken from !> is symmetric -!> \param error CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_tasks_build_atom_pairs(com_tasks, & atom_pairs, & natoms_encode, & send_or_recv, & - symmetric, & - error) + symmetric) TYPE(fb_com_tasks_obj), INTENT(IN) :: com_tasks TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs INTEGER, INTENT(IN) :: natoms_encode CHARACTER(len=*), INTENT(IN) :: send_or_recv LOGICAL, INTENT(IN), OPTIONAL :: symmetric - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_com_tasks_build_atom_pairs', & @@ -931,10 +893,10 @@ SUBROUTINE fb_com_tasks_build_atom_pairs(com_tasks, & NULLIFY(pairs, tasks) check_ok = fb_com_atom_pairs_has_data(atom_pairs) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! initialise atom_pairs - CALL fb_com_atom_pairs_init(atom_pairs, error) + CALL fb_com_atom_pairs_init(atom_pairs) IF (TRIM(send_or_recv) == "send") THEN rank_pos = TASK_DEST @@ -950,11 +912,10 @@ SUBROUTINE fb_com_tasks_build_atom_pairs(com_tasks, & CALL fb_com_tasks_get(com_tasks=com_tasks, & ntasks=ntasks, & - tasks=tasks, & - error=error) + tasks=tasks) ALLOCATE(pairs(ntasks), STAT=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) ! we can have cases where ntasks == 0 IF (SIZE(pairs) > 0) pairs = 0 npairs = ntasks @@ -986,11 +947,11 @@ SUBROUTINE fb_com_tasks_build_atom_pairs(com_tasks, & ! than once) IF (npairs > 0) THEN ALLOCATE(tmp_index(npairs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! only sort the actual pairs recorded in the send list CALL sort(pairs, npairs, tmp_index) DEALLOCATE(tmp_index, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ! remove duplicates @@ -1010,8 +971,7 @@ SUBROUTINE fb_com_tasks_build_atom_pairs(com_tasks, & CALL fb_com_atom_pairs_set(atom_pairs=atom_pairs, & pairs=pairs, & npairs=npairs, & - natoms_encode=natoms_encode, & - error=error) + natoms_encode=natoms_encode) CALL timestop(handle) @@ -1156,7 +1116,6 @@ END SUBROUTINE fb_com_atom_pairs_decode !> location in atom_pairs array for !> all the pairs to be sent to or recv !> from process ipe -!> \param error : cp2k error container !> \param row_map : optional blk row map for the DBCSR blocks !> \param col_map : optional blk col map for the DBCSR blocks !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk @@ -1169,7 +1128,6 @@ SUBROUTINE fb_com_atom_pairs_calc_buffer_sizes(atom_pairs, & sendrecv_disps, & sendrecv_pair_counts, & sendrecv_pair_disps, & - error, & row_map, & col_map) TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs @@ -1179,7 +1137,6 @@ SUBROUTINE fb_com_atom_pairs_calc_buffer_sizes(atom_pairs, & sendrecv_disps, & sendrecv_pair_counts, & sendrecv_pair_disps - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER, DIMENSION(:), INTENT(IN), & OPTIONAL :: row_map, col_map @@ -1202,16 +1159,15 @@ SUBROUTINE fb_com_atom_pairs_calc_buffer_sizes(atom_pairs, & SIZE(sendrecv_disps) == nprocs .AND. & SIZE(sendrecv_pair_counts) == nprocs .AND. & SIZE(sendrecv_pair_disps) == nprocs - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = fb_com_atom_pairs_has_data(atom_pairs) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs, & pairs=pairs, & npairs=npairs, & - natoms_encode=natoms_encode, & - error=error) + natoms_encode=natoms_encode) sendrecv_sizes = 0 sendrecv_pair_counts = 0 @@ -1252,21 +1208,18 @@ END SUBROUTINE fb_com_atom_pairs_calc_buffer_sizes !> \param para_env : CP2K parallel environment !> \param matrix_storage : the fb_matrix_data object to store the !> received DBCSR matrix blocks -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & atom_pairs_send, & atom_pairs_recv, & para_env, & - matrix_storage, & - error) + matrix_storage) TYPE(cp_dbcsr_type), POINTER :: dbcsr_mat TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs_send, & atom_pairs_recv TYPE(cp_para_env_type), POINTER :: para_env TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_storage - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_com_atom_pairs_gather_blks', & @@ -1294,23 +1247,21 @@ SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & row_block_size_data, col_block_size_data) check_ok = fb_com_atom_pairs_has_data(atom_pairs_send) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = fb_com_atom_pairs_has_data(atom_pairs_send) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = fb_matrix_data_has_data(matrix_storage) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! get com pair informations CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_send, & pairs=pairs_send, & npairs=npairs_send, & - natoms_encode=send_encode, & - error=error) + natoms_encode=send_encode) CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_recv, & pairs=pairs_recv, & npairs=npairs_recv, & - natoms_encode=recv_encode, & - error=error) + natoms_encode=recv_encode) ! get para_env info numprocs = para_env%num_pe @@ -1320,13 +1271,13 @@ SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & ! allocate temporary arrays for send ALLOCATE(send_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup send buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_send, & @@ -1336,22 +1287,21 @@ SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & send_sizes, & send_disps, & send_pair_count, & - send_pair_disps, & - error) + send_pair_disps) ! allocate send buffer ALLOCATE(send_buf(SUM(send_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! allocate temporary arrays for recv ALLOCATE(recv_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup recv buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_recv, & @@ -1361,12 +1311,11 @@ SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & recv_sizes, & recv_disps, & recv_pair_count, & - recv_pair_disps, & - error) + recv_pair_disps) ! allocate recv buffer ALLOCATE(recv_buf(SUM(recv_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! do packing DO ipe = 1, numprocs @@ -1403,22 +1352,22 @@ SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & ! cleanup temporary arrays no longer needed DEALLOCATE(send_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! unpack into matrix_data object NULLIFY(mat_block) nrows_blk_max = MAXVAL(row_block_size_data) ncols_blk_max = MAXVAL(col_block_size_data) ALLOCATE(mat_block(nrows_blk_max,ncols_blk_max), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ipe = 1, numprocs recv_sizes(ipe) = 0 DO ipair = 1, recv_pair_count(ipe) @@ -1427,7 +1376,7 @@ SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & nrows_blk = row_block_size_data(iatom) ncols_blk = col_block_size_data(jatom) ! ALLOCATE(mat_block(nrows_blk,ncols_blk), STAT=stat) - ! CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) mat_block(:,:) = 0.0_dp DO jj = 1, ncols_blk DO ii = 1, nrows_blk @@ -1438,27 +1387,26 @@ SUBROUTINE fb_com_atom_pairs_gather_blks(dbcsr_mat, & END DO ! jj CALL fb_matrix_data_add(matrix_storage, & iatom, jatom, & - mat_block(1:nrows_blk, 1:ncols_blk), & - error) + mat_block(1:nrows_blk, 1:ncols_blk)) recv_sizes(ipe) = recv_sizes(ipe) + nrows_blk*ncols_blk ! DEALLOCATE(mat_block, STAT=stat) - ! CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) END DO ! ipair END DO ! ipe DEALLOCATE(mat_block, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! cleanup rest of the temporary arrays DEALLOCATE(recv_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -1479,21 +1427,18 @@ END SUBROUTINE fb_com_atom_pairs_gather_blks !> \param para_env : CP2K parallel environment !> \param dbcsr_mat : the DBCSR matrix where the matrix blocks will be !> distributed to -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & atom_pairs_send, & atom_pairs_recv, & para_env, & - dbcsr_mat, & - error) + dbcsr_mat) TYPE(fb_matrix_data_obj), INTENT(IN) :: matrix_storage TYPE(fb_com_atom_pairs_obj), INTENT(IN) :: atom_pairs_send, & atom_pairs_recv TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_dbcsr_type), POINTER :: dbcsr_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_com_atom_pairs_distribute_blks', & @@ -1521,23 +1466,21 @@ SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & row_block_size_data, col_block_size_data) check_ok = fb_com_atom_pairs_has_data(atom_pairs_send) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = fb_com_atom_pairs_has_data(atom_pairs_send) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = fb_matrix_data_has_data(matrix_storage) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! get com pair informations CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_send, & pairs=pairs_send, & npairs=npairs_send, & - natoms_encode=send_encode, & - error=error) + natoms_encode=send_encode) CALL fb_com_atom_pairs_get(atom_pairs=atom_pairs_recv, & pairs=pairs_recv, & npairs=npairs_recv, & - natoms_encode=recv_encode, & - error=error) + natoms_encode=recv_encode) ! get para_env info numprocs = para_env%num_pe @@ -1547,13 +1490,13 @@ SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & ! allocate temporary arrays for send ALLOCATE(send_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup send buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_send, & @@ -1563,22 +1506,21 @@ SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & send_sizes, & send_disps, & send_pair_count, & - send_pair_disps, & - error) + send_pair_disps) ! allocate send buffer ALLOCATE(send_buf(SUM(send_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! allocate temporary arrays for recv ALLOCATE(recv_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup recv buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(atom_pairs_recv, & @@ -1588,12 +1530,11 @@ SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & recv_sizes, & recv_disps, & recv_pair_count, & - recv_pair_disps, & - error) + recv_pair_disps) ! allocate recv buffer ALLOCATE(recv_buf(SUM(recv_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! do packing DO ipe = 1, numprocs @@ -1604,8 +1545,7 @@ SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & pe, iatom, jatom, send_encode) CALL fb_matrix_data_get(matrix_storage, & iatom, jatom, & - mat_block, found, & - error) + mat_block, found) IF (.NOT. found) THEN CALL stop_program(routineN, moduleN, __LINE__, "Matrix block not found") ELSE @@ -1630,15 +1570,15 @@ SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & ! cleanup temporary arrays no longer needed DEALLOCATE(send_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! unpack into DBCSR matrix DO ipe = 1, numprocs @@ -1658,15 +1598,15 @@ SUBROUTINE fb_com_atom_pairs_distribute_blks(matrix_storage, & ! cleanup rest of the temporary arrays DEALLOCATE(recv_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! dbcsr matrix is not finalised in this subroutine diff --git a/src/qs_fb_distribution_methods.F b/src/qs_fb_distribution_methods.F index 3381a26801..94b181cc51 100644 --- a/src/qs_fb_distribution_methods.F +++ b/src/qs_fb_distribution_methods.F @@ -112,14 +112,12 @@ MODULE qs_fb_distribution_methods !> \param fb_env : the filter matrix environment !> \param qs_env : quickstep environment !> \param scf_section : SCF input section -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) + SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_build', & routineP = moduleN//':'//routineN @@ -162,8 +160,7 @@ SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) ! obtain relevant data from fb_env, qs_env CALL fb_env_get(fb_env=fb_env, & - rcut=rcut, & - error=error) + rcut=rcut) CALL get_qs_env(qs_env=qs_env, & natom=natoms, & particle_set=particle_set, & @@ -171,62 +168,58 @@ SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) nkind=nkinds, & cell=cell, & para_env=para_env, & - matrix_ks=mat_ks, & - error=error) + matrix_ks=mat_ks) nprocs = para_env%num_pe my_pe = para_env%mepos + 1 ! counting from 1 ! for each global atom, build atomic halo and get the associated cost ALLOCATE(pair_radii(nkinds,nkinds), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_build_pair_radii(rcut, nkinds, pair_radii) - CALL fb_atomic_halo_create(atomic_halo, error) + CALL fb_atomic_halo_create(atomic_halo) ALLOCATE(cost_per_atom(natoms), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO iatom = 1, natoms - CALL fb_atomic_halo_init(atomic_halo, error) + CALL fb_atomic_halo_init(atomic_halo) CALL fb_atomic_halo_build_halo_atoms(iatom, & particle_set, & cell, & pair_radii, & halo_atoms, & nhalo_atoms, & - owner_id_in_halo, & - error) + owner_id_in_halo) CALL fb_atomic_halo_set(atomic_halo=atomic_halo, & owner_atom=iatom, & natoms=nhalo_atoms, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) NULLIFY(halo_atoms) - cost_per_atom(iatom) = fb_atomic_halo_cost(atomic_halo, particle_set, qs_kind_set, error=error) + cost_per_atom(iatom) = fb_atomic_halo_cost(atomic_halo, particle_set, qs_kind_set) END DO DEALLOCATE(pair_radii, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - CALL fb_atomic_halo_release(atomic_halo, error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + CALL fb_atomic_halo_release(atomic_halo) ! build the preferred_procs_set according to DBCSR mat H ALLOCATE(preferred_procs_set(natoms), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(common_set_ids(natoms), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_build_preferred_procs(mat_ks(1)%matrix, & natoms, & preferred_procs_set, & common_set_ids, & - n_common_sets, & - error) + n_common_sets) ! for each atomic halo, construct distribution_element, and assign ! the element to a processors using preferred_procs_set in a ! round-robin manner ALLOCATE(dist(nprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ipe = 1, nprocs - CALL fb_distribution_init(dist=dist(ipe), error=error) + CALL fb_distribution_init(dist=dist(ipe)) END DO ALLOCATE(pos_in_preferred_list(n_common_sets), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) pos_in_preferred_list(:) = 0 DO iatom = 1, natoms element%id = iatom @@ -236,25 +229,25 @@ SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) MOD(pos_in_preferred_list(i_common_set), & preferred_procs_set(iatom)%nprocs) + 1 ipe = preferred_procs_set(iatom)%list(pos_in_preferred_list(i_common_set)) - CALL fb_distribution_add(dist(ipe), element, error) + CALL fb_distribution_add(dist(ipe), element) END DO DEALLOCATE(pos_in_preferred_list, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(common_set_ids, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(cost_per_atom, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! sort processors according to the overall cost of their assigned ! corresponding distribution ALLOCATE(cost_per_proc(nprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ipe = 1, nprocs cost_per_proc(ipe) = dist(ipe)%cost END DO ALLOCATE(pe(nprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL sort(cost_per_proc, nprocs, pe) ! now that cost_per_proc is sorted, ipe's no longer give mpi ! ranks, the correct one to use should be pe(ipe) @@ -264,7 +257,7 @@ SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) average_cost = SUM(cost_per_proc) / REAL(nprocs, dp) DEALLOCATE(cost_per_proc, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! loop over the processors, starting with the highest cost, move ! atoms one by one: @@ -290,8 +283,7 @@ SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) IF ((pref_pe .NE. pe(ipe)) .AND. acceptable_move) THEN CALL fb_distribution_move(dist(pe(ipe)), & lowest_cost_ind, & - dist(pref_pe), & - error) + dist(pref_pe)) move_happened = .TRUE. EXIT preferred END IF @@ -311,8 +303,7 @@ SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) IF ((pe(ii) .NE. pe(ipe)) .AND. acceptable_move) THEN CALL fb_distribution_move(dist(pe(ipe)), & lowest_cost_ind, & - dist(pe(ii)), & - error) + dist(pe(ii))) move_happened = .TRUE. EXIT next_in_line END IF @@ -330,49 +321,47 @@ SUBROUTINE fb_distribution_build(fb_env, qs_env, scf_section, error) END DO ! ipe DEALLOCATE(pe, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ii = 1, SIZE(preferred_procs_set) - CALL fb_preferred_procs_list_release(preferred_procs_set(ii), error) + CALL fb_preferred_procs_list_release(preferred_procs_set(ii)) END DO DEALLOCATE(preferred_procs_set, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! generate local atoms from dist ALLOCATE(local_atoms_all(natoms), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(local_atoms_starts(nprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(local_atoms_sizes(nprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_distribution_to_local_atoms(dist, & local_atoms_all, & local_atoms_starts, & - local_atoms_sizes, & - error) + local_atoms_sizes) ALLOCATE(local_atoms(local_atoms_sizes(my_pe)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) lb = local_atoms_starts(my_pe) ub = local_atoms_starts(my_pe) + local_atoms_sizes(my_pe) - 1 local_atoms(1:local_atoms_sizes(my_pe)) = local_atoms_all(lb:ub) CALL fb_env_set(fb_env=fb_env, & local_atoms=local_atoms, & - nlocal_atoms=local_atoms_sizes(my_pe), & - error=error) + nlocal_atoms=local_atoms_sizes(my_pe)) ! write out info - CALL fb_distribution_write_info(dist, scf_section, error) + CALL fb_distribution_write_info(dist, scf_section) DEALLOCATE(local_atoms_all, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(local_atoms_starts, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(local_atoms_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ipe = 1, SIZE(dist) - CALL fb_distribution_release(dist(ipe), error) + CALL fb_distribution_release(dist(ipe)) END DO DEALLOCATE(dist, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -409,14 +398,12 @@ END FUNCTION fb_distribution_acceptable_move !> \brief Write out information on the load distribution on processors !> \param dist_set : set of distributions for the processors !> \param scf_section : SCF input section -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_write_info(dist_set, scf_section, error) + SUBROUTINE fb_distribution_write_info(dist_set, scf_section) TYPE(fb_distribution_list), & DIMENSION(:), INTENT(IN) :: dist_set TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_write_info', & routineP = moduleN//':'//routineN @@ -452,11 +439,10 @@ SUBROUTINE fb_distribution_write_info(dist_set, scf_section, error) min_cost = MIN(min_cost, dist_set(ii)%cost) END DO - logger => cp_error_get_logger(error=error) + logger => cp_get_default_logger() unit_nr = cp_print_key_unit_nr(logger, scf_section, & "PRINT%FILTER_MATRIX", & - extension="", & - error=error) + extension="") IF (unit_nr > 0) THEN WRITE (UNIT=unit_nr, FMT="(/,A,I6,A)") & @@ -476,7 +462,7 @@ SUBROUTINE fb_distribution_write_info(dist_set, scf_section, error) " FILTER_MAT_DIAG| (* cost is calculated as sum of cube of atomic matrix sizes)" END IF CALL cp_print_key_finished_output(unit_nr, logger, scf_section, & - "PRINT%FILTER_MATRIX", error=error) + "PRINT%FILTER_MATRIX") END SUBROUTINE fb_distribution_write_info ! ***************************************************************************** @@ -489,22 +475,19 @@ END SUBROUTINE fb_distribution_write_info !> col will have the same preferred list. This list !> maps each atom to their corresponding group !> \param n_common_sets : number of unique preferred lists (groups) -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_build_preferred_procs(dbcsr_mat, & natoms, & preferred_procs_set, & common_set_ids, & - n_common_sets, & - error) + n_common_sets) TYPE(cp_dbcsr_type), POINTER :: dbcsr_mat INTEGER, INTENT(IN) :: natoms TYPE(fb_preferred_procs_list), & DIMENSION(:), INTENT(INOUT) :: preferred_procs_set INTEGER, DIMENSION(:), INTENT(OUT) :: common_set_ids INTEGER, INTENT(OUT) :: n_common_sets - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_build_preferred_procs', & routineP = moduleN//':'//routineN @@ -517,11 +500,11 @@ SUBROUTINE fb_build_preferred_procs(dbcsr_mat, & failure = .FALSE. check_ok = natoms .LE. cp_dbcsr_nblkcols_total(dbcsr_mat) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = SIZE(preferred_procs_set) .GE. natoms - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = SIZE(common_set_ids) .GE. natoms - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) CALL cp_dbcsr_get_info(dbcsr_mat, distribution=dbcsr_dist, proc_col_dist=col_dist) dbcsr_mp = dbcsr_distribution_mp(dbcsr_dist) @@ -530,10 +513,10 @@ SUBROUTINE fb_build_preferred_procs(dbcsr_mat, & DO icol = 1, natoms IF (ASSOCIATED(preferred_procs_set(icol)%list)) THEN DEALLOCATE(preferred_procs_set(icol)%list, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ALLOCATE(preferred_procs_set(icol)%list(nprows), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) pcol = col_dist(icol) ! dbcsr prow and pcol counts from 0 DO prow = 0, nprows-1 @@ -553,13 +536,11 @@ END SUBROUTINE fb_build_preferred_procs ! ***************************************************************************** !> \brief Release a preferred_procs_list !> \param preferred_procs_list : the preferred procs list in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_preferred_procs_list_release(preferred_procs_list, error) + SUBROUTINE fb_preferred_procs_list_release(preferred_procs_list) TYPE(fb_preferred_procs_list), & INTENT(INOUT) :: preferred_procs_list - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'fb_preferred_procs_list_release', & @@ -571,7 +552,7 @@ SUBROUTINE fb_preferred_procs_list_release(preferred_procs_list, error) failure = .FALSE. IF (ASSOCIATED(preferred_procs_list%list)) THEN DEALLOCATE(preferred_procs_list%list, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF END SUBROUTINE fb_preferred_procs_list_release @@ -584,20 +565,17 @@ END SUBROUTINE fb_preferred_procs_list_release !> \param local_atoms_starts : starting position in local_atoms array for !> each processor !> \param local_atoms_sizes : number of atoms local to each processor -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_distribution_to_local_atoms(dist_set, & local_atoms, & local_atoms_starts, & - local_atoms_sizes, & - error) + local_atoms_sizes) TYPE(fb_distribution_list), & DIMENSION(:), INTENT(IN) :: dist_set INTEGER, DIMENSION(:), INTENT(OUT) :: local_atoms, & local_atoms_starts, & local_atoms_sizes - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'fb_distribution_to_local_atoms', & @@ -611,9 +589,9 @@ SUBROUTINE fb_distribution_to_local_atoms(dist_set, & n_procs = SIZE(dist_set) check_ok = SIZE(local_atoms_starts) .GE. n_procs - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = SIZE(local_atoms_sizes) .GE. n_procs - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) local_atoms(:) = 0 local_atoms_starts(:) = 0 @@ -634,14 +612,12 @@ END SUBROUTINE fb_distribution_to_local_atoms !> \brief Initialise a distribution !> \param dist : the distribution in question !> \param nmax : [OPTIONAL] size of the list array to be allocated -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_init(dist, nmax, error) + SUBROUTINE fb_distribution_init(dist, nmax) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist INTEGER, INTENT(IN), OPTIONAL :: nmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_init', & routineP = moduleN//':'//routineN @@ -654,12 +630,12 @@ SUBROUTINE fb_distribution_init(dist, nmax, error) IF (PRESENT(nmax)) my_nmax = nmax IF (ASSOCIATED(dist%list)) THEN DEALLOCATE(dist%list, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF NULLIFY(dist%list) IF (my_nmax .GT. 0) THEN ALLOCATE(dist%list(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ii = 1, SIZE(dist%list) dist%list(ii)%id = 0 dist%list(ii)%cost = 0.0_dp @@ -673,14 +649,12 @@ END SUBROUTINE fb_distribution_init !> \brief Resize the list array in a distribution !> \param dist : The distribution in question !> \param nmax : new size of the list array -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_resize(dist, nmax, error) + SUBROUTINE fb_distribution_resize(dist, nmax) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist INTEGER, INTENT(IN) :: nmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_resize', & routineP = moduleN//':'//routineN @@ -694,11 +668,11 @@ SUBROUTINE fb_distribution_resize(dist, nmax, error) IF (.NOT. ASSOCIATED(dist%list)) THEN my_nmax = MAX(nmax, 1) ALLOCATE(dist%list(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ELSE my_nmax = MAX(nmax, dist%nelements) ALLOCATE(new_list(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ii = 1, SIZE(new_list) new_list(ii)%id = 0 new_list(ii)%cost = 0.0_dp @@ -707,7 +681,7 @@ SUBROUTINE fb_distribution_resize(dist, nmax, error) new_list(ii) = dist%list(ii) END DO DEALLOCATE(dist%list, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) dist%list => new_list END IF END SUBROUTINE fb_distribution_resize @@ -716,15 +690,13 @@ END SUBROUTINE fb_distribution_resize !> \brief Add an atom (element) to a distribution !> \param dist : the distribution in question !> \param element : the element to be added -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_add(dist, element, error) + SUBROUTINE fb_distribution_add(dist, element) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist TYPE(fb_distribution_element), & INTENT(IN) :: element - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_add', & routineP = moduleN//':'//routineN @@ -737,9 +709,9 @@ SUBROUTINE fb_distribution_add(dist, element, error) ! resize list if necessary IF (.NOT. ASSOCIATED(dist%list)) THEN - CALL fb_distribution_resize(dist, new_nelements, error=error) + CALL fb_distribution_resize(dist, new_nelements) ELSE IF (new_nelements*ENLARGE_RATIO .GT. SIZE(dist%list)) THEN - CALL fb_distribution_resize(dist, SIZE(dist%list)*EXPAND_FACTOR, error) + CALL fb_distribution_resize(dist, SIZE(dist%list)*EXPAND_FACTOR) END IF ! assuming the list of elements is always sorted with respect to cost ! slot the new element into the appropriate spot @@ -798,14 +770,12 @@ END FUNCTION fb_distribution_find_slot !> \brief Remove the pos-th element from a distribution !> \param dist : the distribution in question !> \param pos : index of the element in the list array -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_remove_ind(dist, pos, error) + SUBROUTINE fb_distribution_remove_ind(dist, pos) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist INTEGER, INTENT(IN) :: pos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_remove_ind', & routineP = moduleN//':'//routineN @@ -815,7 +785,7 @@ SUBROUTINE fb_distribution_remove_ind(dist, pos, error) failure = .FALSE. check_ok = pos .GT. 0 - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) IF (pos .LE. dist%nelements) THEN dist%cost = dist%cost - dist%list(pos)%cost DO ii = pos, dist%nelements-1 @@ -826,7 +796,7 @@ SUBROUTINE fb_distribution_remove_ind(dist, pos, error) dist%nelements = dist%nelements - 1 ! auto resize if required IF (dist%nelements*REDUCE_RATIO .LT. SIZE(dist%list)) THEN - CALL fb_distribution_resize(dist, dist%nelements/SHRINK_FACTOR, error) + CALL fb_distribution_resize(dist, dist%nelements/SHRINK_FACTOR) END IF END IF END SUBROUTINE fb_distribution_remove_ind @@ -835,15 +805,13 @@ END SUBROUTINE fb_distribution_remove_ind !> \brief Remove a given element from a distribution !> \param dist : the distribution in question !> \param element : the element in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_remove_el(dist, element, error) + SUBROUTINE fb_distribution_remove_el(dist, element) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist TYPE(fb_distribution_element), & INTENT(IN) :: element - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_remove_el', & routineP = moduleN//':'//routineN @@ -857,7 +825,7 @@ SUBROUTINE fb_distribution_remove_el(dist, element, error) EXIT END IF END DO - CALL fb_distribution_remove_ind(dist, pos, error) + CALL fb_distribution_remove_ind(dist, pos) END SUBROUTINE fb_distribution_remove_el ! ***************************************************************************** @@ -865,16 +833,14 @@ END SUBROUTINE fb_distribution_remove_el !> \param dist_from : the source distribution !> \param pos : index of the element in the source distribution !> \param dist_to : the destination distribution -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_move_ind(dist_from, pos, dist_to, error) + SUBROUTINE fb_distribution_move_ind(dist_from, pos, dist_to) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist_from INTEGER, INTENT(IN) :: pos TYPE(fb_distribution_list), & INTENT(INOUT) :: dist_to - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_move_ind', & routineP = moduleN//':'//routineN @@ -884,12 +850,12 @@ SUBROUTINE fb_distribution_move_ind(dist_from, pos, dist_to, error) failure = .FALSE. check_ok = ASSOCIATED(dist_from%list) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = pos .LE. dist_from%nelements - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) element = dist_from%list(pos) - CALL fb_distribution_add(dist_to, element, error) - CALL fb_distribution_remove(dist_from, pos, error) + CALL fb_distribution_add(dist_to, element) + CALL fb_distribution_remove(dist_from, pos) END SUBROUTINE fb_distribution_move_ind ! ***************************************************************************** @@ -897,17 +863,15 @@ END SUBROUTINE fb_distribution_move_ind !> \param dist_from : the source distribution !> \param element : the element in question !> \param dist_to : the destination distribution -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_move_el(dist_from, element, dist_to, error) + SUBROUTINE fb_distribution_move_el(dist_from, element, dist_to) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist_from TYPE(fb_distribution_element), & INTENT(IN) :: element TYPE(fb_distribution_list), & INTENT(INOUT) :: dist_to - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_move_el', & routineP = moduleN//':'//routineN @@ -916,21 +880,19 @@ SUBROUTINE fb_distribution_move_el(dist_from, element, dist_to, error) failure = .FALSE. check_ok = ASSOCIATED(dist_from%list) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) - CALL fb_distribution_add(dist_to, element, error) - CALL fb_distribution_remove(dist_from, element, error) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) + CALL fb_distribution_add(dist_to, element) + CALL fb_distribution_remove(dist_from, element) END SUBROUTINE fb_distribution_move_el ! ***************************************************************************** !> \brief Release a distribution !> \param dist : the distribution in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_distribution_release(dist, error) + SUBROUTINE fb_distribution_release(dist) TYPE(fb_distribution_list), & INTENT(INOUT) :: dist - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_distribution_release', & routineP = moduleN//':'//routineN @@ -941,7 +903,7 @@ SUBROUTINE fb_distribution_release(dist, error) failure = .FALSE. IF (ASSOCIATED(dist%list)) THEN DEALLOCATE(dist%list, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF END SUBROUTINE fb_distribution_release diff --git a/src/qs_fb_env_methods.F b/src/qs_fb_env_methods.F index f651a15c50..15741841e7 100644 --- a/src/qs_fb_env_methods.F +++ b/src/qs_fb_env_methods.F @@ -125,7 +125,6 @@ MODULE qs_fb_env_methods !> \param matrix_s : DBCSR system (unfiltered) input overlap matrix !> \param scf_section : SCF input section !> \param diis_step : whether we are doing a DIIS step -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_env_do_diag(fb_env, & @@ -133,15 +132,13 @@ SUBROUTINE fb_env_do_diag(fb_env, & matrix_ks, & matrix_s, & scf_section, & - diis_step, & - error) + diis_step) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks, matrix_s TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(INOUT) :: diis_step - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_env_do_diag', & routineP = moduleN//':'//routineN @@ -209,8 +206,7 @@ SUBROUTINE fb_env_do_diag(fb_env, & para_env=para_env, & blacs_env=blacs_env, & particle_set=particle_set, & - mos=mos, & - error=error) + mos=mos) nspin = SIZE(matrix_ks) @@ -220,8 +216,7 @@ SUBROUTINE fb_env_do_diag(fb_env, & DO ispin = 1, nspin CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix, & - scf_env%scf_work1(ispin)%matrix, & - error=error) + scf_env%scf_work1(ispin)%matrix) END DO eps_diis = scf_control%eps_diis @@ -231,8 +226,7 @@ SUBROUTINE fb_env_do_diag(fb_env, & CALL qs_diis_b_step(scf_env%scf_diis_buffer, mos, scf_env%scf_work1, & scf_env%scf_work2, scf_env%iter_delta, & diis_error, diis_step, eps_diis, scf_control%nmixing, & - s_matrix=matrix_s, scf_section=scf_section, & - error=error) + s_matrix=matrix_s, scf_section=scf_section) ELSE diis_step = .FALSE. END IF @@ -258,19 +252,17 @@ SUBROUTINE fb_env_do_diag(fb_env, & CALL fb_env_get(fb_env=fb_env, & filter_temperature=filter_temp, & - atomic_halos=atomic_halos, & - error=error) + atomic_halos=atomic_halos) ! construct trial functions CALL get_mo_set(mo_set=mos(1)%mo_set, maxocc=maxocc) - CALL fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) + CALL fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc) CALL fb_env_get(fb_env=fb_env, & - trial_fns=trial_fns, & - error=error) + trial_fns=trial_fns) ! allocate filter matrix (matrix_filter(ispin)%matrix are ! nullified by cp_dbcsr_allocate_matrix_set) - CALL cp_dbcsr_allocate_matrix_set(matrix_filter, nspin, error) + CALL cp_dbcsr_allocate_matrix_set(matrix_filter, nspin) DO ispin = 1, nspin ! get system-wide fermi energy and occupancy, we use this to ! define the filter function used for the filter matrix @@ -286,12 +278,12 @@ SUBROUTINE fb_env_do_diag(fb_env, & ! NULLIFY(matrix_ks_desymm%matrix) ALLOCATE(matrix_ks_desymm%matrix) - CALL cp_dbcsr_init(matrix_ks_desymm%matrix, error) - CALL cp_dbcsr_desymmetrize(matrix_ks(ispin)%matrix, matrix_ks_desymm%matrix, error) + CALL cp_dbcsr_init(matrix_ks_desymm%matrix) + CALL cp_dbcsr_desymmetrize(matrix_ks(ispin)%matrix, matrix_ks_desymm%matrix) NULLIFY(matrix_s_desymm%matrix) ALLOCATE(matrix_s_desymm%matrix) - CALL cp_dbcsr_init(matrix_s_desymm%matrix, error) - CALL cp_dbcsr_desymmetrize(matrix_s(1)%matrix, matrix_s_desymm%matrix, error) + CALL cp_dbcsr_init(matrix_s_desymm%matrix) + CALL cp_dbcsr_desymmetrize(matrix_s(1)%matrix, matrix_s_desymm%matrix) ! ---------------------------------------------------------------------- ! get filter matrix name @@ -311,13 +303,11 @@ SUBROUTINE fb_env_do_diag(fb_env, & ! fermi_level=fermi_level, & ! filter_temp=filter_temp, & ! name=name, & - ! filter_mat=matrix_filter(ispin)%matrix, & - ! error=error) + ! filter_mat=matrix_filter(ispin)%matrix) !END:ORIG:LT:2015/01/2 !BEG:REPL:LT:2015/01/2 CALL fb_env_get(fb_env=fb_env, & - collective_com=collective_com, & - error=error) + collective_com=collective_com) IF (collective_com) THEN CALL fb_fltrmat_build_2(H_mat=matrix_ks_desymm%matrix, & S_mat=matrix_s_desymm%matrix, & @@ -328,8 +318,7 @@ SUBROUTINE fb_env_do_diag(fb_env, & fermi_level=fermi_level, & filter_temp=filter_temp, & name=name, & - filter_mat=matrix_filter(ispin)%matrix, & - error=error) + filter_mat=matrix_filter(ispin)%matrix) ELSE CALL fb_fltrmat_build(H_mat=matrix_ks_desymm%matrix, & S_mat=matrix_s_desymm%matrix, & @@ -340,15 +329,14 @@ SUBROUTINE fb_env_do_diag(fb_env, & fermi_level=fermi_level, & filter_temp=filter_temp, & name=name, & - filter_mat=matrix_filter(ispin)%matrix, & - error=error) + filter_mat=matrix_filter(ispin)%matrix) END IF !END:REPL:LT:2015/01/2 ! ---------------------------------------------------------------------- ! Deallocate the desymmetrised matrices - CALL cp_dbcsr_release(matrix_ks_desymm%matrix, error) - CALL cp_dbcsr_release(matrix_s_desymm%matrix, error) + CALL cp_dbcsr_release(matrix_ks_desymm%matrix) + CALL cp_dbcsr_release(matrix_s_desymm%matrix) DEALLOCATE(matrix_ks_desymm%matrix) DEALLOCATE(matrix_s_desymm%matrix) ! ---------------------------------------------------------------------- @@ -375,7 +363,7 @@ SUBROUTINE fb_env_do_diag(fb_env, & ! requires a new mo_set (molecular orbitals | eigenvectors) and ! the corresponding matrix pools for the eigenvector coefficients ALLOCATE(mos_filtered(nspin), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ispin = 1, nspin CALL get_mo_set(mo_set=mos(ispin)%mo_set, & maxocc=maxocc, & @@ -388,19 +376,17 @@ SUBROUTINE fb_env_do_diag(fb_env, & nelectron=nelectron, & n_el_f=REAL(nelectron, dp), & maxocc=maxocc, & - flexible_electron_count=flexible_electron_count, & - error=error) + flexible_electron_count=flexible_electron_count) END DO ! ispin - CALL mpools_create(mpools=my_mpools, error=error) + CALL mpools_create(mpools=my_mpools) CALL mpools_rebuild_fm_pools(mpools=my_mpools,& mos=mos_filtered,& blacs_env=blacs_env,& - para_env=para_env,& - error=error) + para_env=para_env) ! create DBCSR filtered KS matrix, this is reused for each spin ! channel - CALL cp_dbcsr_init(matrix_filtered_ks, error=error) + CALL cp_dbcsr_init(matrix_filtered_ks) ! both row_blk_size and col_blk_size should be that of ! col_blk_size of the filter matrix CALL cp_dbcsr_create(matrix=matrix_filtered_ks, & @@ -409,9 +395,8 @@ SUBROUTINE fb_env_do_diag(fb_env, & matrix_type=dbcsr_type_no_symmetry, & row_blk_size=filtered_rowORcol_block_sizes, & col_blk_size=filtered_rowORcol_block_sizes, & - nze=0, & - error=error) - CALL cp_dbcsr_finalize(matrix_filtered_ks, error=error) + nze=0) + CALL cp_dbcsr_finalize(matrix_filtered_ks) ! create DBCSR filtered S (overlap) matrix. Note that ! matrix_s(1)%matrix is the orginal overlap matrix---the rest in @@ -420,7 +405,7 @@ SUBROUTINE fb_env_do_diag(fb_env, & ! matrix, and does depend on spin, the filtered S also becomes ! spin dependent. Nevertheless this matrix is reused for each spin ! channel - CALL cp_dbcsr_init(matrix_filtered_s, error=error) + CALL cp_dbcsr_init(matrix_filtered_s) ! both row_blk_size and col_blk_size should be that of ! col_blk_size of the filter matrix CALL cp_dbcsr_create(matrix=matrix_filtered_s, & @@ -429,12 +414,11 @@ SUBROUTINE fb_env_do_diag(fb_env, & matrix_type=dbcsr_type_no_symmetry, & row_blk_size=filtered_rowORcol_block_sizes, & col_blk_size=filtered_rowORcol_block_sizes, & - nze=0, & - error=error) - CALL cp_dbcsr_finalize(matrix_filtered_s, error=error) + nze=0) + CALL cp_dbcsr_finalize(matrix_filtered_s) ! create temporary matrix for constructing filtered KS and S - CALL cp_dbcsr_init(matrix_tmp, error=error) + CALL cp_dbcsr_init(matrix_tmp) ! the temporary matrix won't be square CALL cp_dbcsr_create(matrix=matrix_tmp, & name=TRIM("TEMPORARY_MATRIX"), & @@ -442,32 +426,28 @@ SUBROUTINE fb_env_do_diag(fb_env, & matrix_type=dbcsr_type_no_symmetry, & row_blk_size=original_rowORcol_block_sizes, & col_blk_size=filtered_rowORcol_block_sizes, & - nze=0, & - error=error) - CALL cp_dbcsr_finalize(matrix_tmp, error=error) + nze=0) + CALL cp_dbcsr_finalize(matrix_tmp) ! create fm format matrices used for diagonalisation CALL cp_fm_struct_create(fmstruct=fm_struct, & para_env=para_env, & context=blacs_env, & nrow_global=filtered_nfullrowsORcols_total, & - ncol_global=filtered_nfullrowsORcols_total, & - error=error) + ncol_global=filtered_nfullrowsORcols_total) ! both fm_matrix_filtered_s and fm_matrix_filtered_ks are reused ! for each spin channel CALL cp_fm_create(fm_matrix_filtered_s, & fm_struct, & - name="FM_MATRIX_FILTERED_S", & - error=error) + name="FM_MATRIX_FILTERED_S") CALL cp_fm_create(fm_matrix_filtered_ks, & fm_struct, & - name="FM_MATRIX_FILTERED_KS", & - error=error) + name="FM_MATRIX_FILTERED_KS") ! creaate work matrix - CALL cp_fm_create(fm_matrix_work, fm_struct, name="FM_MATRIX_WORK", error=error) - CALL cp_fm_create(fm_matrix_ortho, fm_struct, name="FM_MATRIX_ORTHO", error=error) + CALL cp_fm_create(fm_matrix_work, fm_struct, name="FM_MATRIX_WORK") + CALL cp_fm_create(fm_matrix_ortho, fm_struct, name="FM_MATRIX_ORTHO") ! all fm matrices are created, so can release fm_struct - CALL cp_fm_struct_release(fm_struct, error=error) + CALL cp_fm_struct_release(fm_struct) ! construct filtered KS, S matrix and diagonalise DO ispin = 1, nspin @@ -475,30 +455,29 @@ SUBROUTINE fb_env_do_diag(fb_env, & ! construct filtered KS matrix CALL cp_dbcsr_multiply("N", "N", 1.0_dp, & matrix_ks(ispin)%matrix, matrix_filter(ispin)%matrix, & - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, & matrix_filter(ispin)%matrix, matrix_tmp, & - 0.0_dp, matrix_filtered_ks, error=error) + 0.0_dp, matrix_filtered_ks) ! construct filtered S_matrix CALL cp_dbcsr_multiply("N", "N", 1.0_dp, & matrix_s(1)%matrix, matrix_filter(ispin)%matrix, & - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("T", "N", 1.0_dp, & matrix_filter(ispin)%matrix, matrix_tmp, & - 0.0_dp, matrix_filtered_s, error=error) + 0.0_dp, matrix_filtered_s) ! now that we have the filtered KS and S matrices for this spin ! channel, perform ordinary diagonalisation ! convert DBCSR matrices to fm format - CALL copy_dbcsr_to_fm(matrix_filtered_s, fm_matrix_filtered_s, error=error) - CALL copy_dbcsr_to_fm(matrix_filtered_ks, fm_matrix_filtered_ks, error=error) + CALL copy_dbcsr_to_fm(matrix_filtered_s, fm_matrix_filtered_s) + CALL copy_dbcsr_to_fm(matrix_filtered_ks, fm_matrix_filtered_ks) ! setup matrix pools for the molecular orbitals CALL init_mo_set(mos_filtered(ispin)%mo_set,& my_mpools%ao_mo_fm_pools(ispin)%pool,& - name="FILTERED_MOS",& - error=error) + name="FILTERED_MOS") ! now diagonalise CALL fb_env_eigensolver(fm_matrix_filtered_ks, & @@ -507,17 +486,16 @@ SUBROUTINE fb_env_do_diag(fb_env, & fm_matrix_ortho, & fm_matrix_work, & eps_eigval, & - ndep, & - error) + ndep) END DO ! ispin ! release temporary matrices - CALL cp_dbcsr_release(matrix_filtered_s, error) - CALL cp_dbcsr_release(matrix_filtered_ks, error) - CALL cp_fm_release(fm_matrix_filtered_s, error=error) - CALL cp_fm_release(fm_matrix_filtered_ks, error=error) - CALL cp_fm_release(fm_matrix_work, error=error) - CALL cp_fm_release(fm_matrix_ortho, error=error) + CALL cp_dbcsr_release(matrix_filtered_s) + CALL cp_dbcsr_release(matrix_filtered_ks) + CALL cp_fm_release(fm_matrix_filtered_s) + CALL cp_fm_release(fm_matrix_filtered_ks) + CALL cp_fm_release(fm_matrix_work) + CALL cp_fm_release(fm_matrix_ortho) ! ---------------------------------------------------------------------- ! Construct New Density Matrix @@ -526,15 +504,14 @@ SUBROUTINE fb_env_do_diag(fb_env, & ! calculate filtered molecular orbital occupation numbers and fermi ! level etc CALL set_mo_occupation(mo_array=mos_filtered, & - smear=scf_control%smear, & - error=error) + smear=scf_control%smear) ! get the filtered density matrix and then convert back to the ! full basis version in scf_env ready to be used outside this ! subroutine ALLOCATE(matrix_filtered_p, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - CALL cp_dbcsr_init(matrix_filtered_p, error=error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + CALL cp_dbcsr_init(matrix_filtered_p) ! the filtered density matrix should have the same sparse ! structure as the original density matrix, we must copy the ! sparse structure here, since construction of the density matrix @@ -548,39 +525,36 @@ SUBROUTINE fb_env_do_diag(fb_env, & matrix_type=cp_dbcsr_get_matrix_type(scf_env%p_mix_new(1,1)%matrix), & row_blk_size=filtered_rowORcol_block_sizes, & col_blk_size=filtered_rowORcol_block_sizes, & - nze=0, & - error=error) - CALL cp_dbcsr_finalize(matrix_filtered_p, error=error) + nze=0) + CALL cp_dbcsr_finalize(matrix_filtered_p) CALL fb_dbcsr_copy_sparse_struct(matrix_filtered_p, & - scf_env%p_mix_new(1,1)%matrix, & - error) + scf_env%p_mix_new(1,1)%matrix) ! old implementation, using sab_orb to allocate the blocks in matrix_filtered_p - ! CALL get_qs_env(qs_env=qs_env, sab_orb=sab_orb, error=error) - ! CALL cp_dbcsr_alloc_block_from_nbl(matrix_filtered_p, sab_orb, error=error) - CALL cp_dbcsr_set(matrix_filtered_p, 0.0_dp, error=error) + ! CALL get_qs_env(qs_env=qs_env, sab_orb=sab_orb) + ! CALL cp_dbcsr_alloc_block_from_nbl(matrix_filtered_p, sab_orb) + CALL cp_dbcsr_set(matrix_filtered_p, 0.0_dp) DO ispin = 1, nspin ! calculate matrix_filtered_p CALL calculate_density_matrix(mos_filtered(ispin)%mo_set, & - matrix_filtered_p, & - error=error) + matrix_filtered_p) ! convert back to full basis p CALL cp_dbcsr_multiply("N", "N", 1.0_dp, & matrix_filter(ispin)%matrix, matrix_filtered_p, & - 0.0_dp, matrix_tmp, error=error) + 0.0_dp, matrix_tmp) CALL cp_dbcsr_multiply("N", "T", 1.0_dp, & matrix_tmp, matrix_filter(ispin)%matrix, & 0.0_dp, scf_env%p_mix_new(ispin,1)%matrix, & - retain_sparsity=.TRUE., error=error) + retain_sparsity=.TRUE.) ! note that we want to retain the sparse structure of ! scf_env%p_mix_new END DO ! ispin ! release temporary matrices - CALL cp_dbcsr_release(matrix_tmp, error) - CALL cp_dbcsr_release(matrix_filtered_p, error) + CALL cp_dbcsr_release(matrix_tmp) + CALL cp_dbcsr_release(matrix_filtered_p) DEALLOCATE(matrix_filtered_p, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! ---------------------------------------------------------------------- ! Update MOs @@ -608,13 +582,11 @@ SUBROUTINE fb_env_do_diag(fb_env, & para_env=para_env, & context=blacs_env, & nrow_global=original_nfullrowsORcols_total, & - ncol_global=filtered_nfullrowsORcols_total, & - error=error) + ncol_global=filtered_nfullrowsORcols_total) CALL cp_fm_create(fm_matrix_filter, & filter_fm_struct, & - name="FM_MATRIX_FILTER", & - error=error) - CALL cp_fm_struct_release(filter_fm_struct, error=error) + name="FM_MATRIX_FILTER") + CALL cp_fm_struct_release(filter_fm_struct) DO ispin = 1, nspin ! now the full basis mo_set should only contain the reduced @@ -633,8 +605,7 @@ SUBROUTINE fb_env_do_diag(fb_env, & homo=homo_filtered, & lfomo=lfomo_filtered, & kTS=kTS_filtered, & - mu=mu_filtered, & - error=error) + mu=mu_filtered) ! now set the arrays and fm_matrices CALL get_mo_set(mo_set=mos(ispin)%mo_set, & nmo=nmo, & @@ -649,32 +620,31 @@ SUBROUTINE fb_env_do_diag(fb_env, & occ(:) = 0.0_dp occ(1:my_nmo) = occ_filtered(1:my_nmo) ! convert mo_coeff_filtered back to original basis - CALL cp_fm_set_all(matrix=mo_coeff, alpha=0.0_dp, error=error) - CALL copy_dbcsr_to_fm(matrix_filter(ispin)%matrix, fm_matrix_filter, error=error) + CALL cp_fm_set_all(matrix=mo_coeff, alpha=0.0_dp) + CALL copy_dbcsr_to_fm(matrix_filter(ispin)%matrix, fm_matrix_filter) CALL cp_fm_gemm("N", "N", & original_nfullrowsORcols_total, & my_nmo, & filtered_nfullrowsORcols_total, & 1.0_dp, fm_matrix_filter, mo_coeff_filtered, & - 0.0_dp, mo_coeff, error=error) + 0.0_dp, mo_coeff) END DO ! ispin ! release temporary matrices - CALL cp_fm_release(fm_matrix_filter, error=error) + CALL cp_fm_release(fm_matrix_filter) ! ---------------------------------------------------------------------- ! Final Clean Up ! ---------------------------------------------------------------------- - CALL mpools_release(mpools=my_mpools, error=error) + CALL mpools_release(mpools=my_mpools) DO ispin = 1, nspin - CALL deallocate_mo_set(mo_set=mos_filtered(ispin)%mo_set, & - error=error) + CALL deallocate_mo_set(mo_set=mos_filtered(ispin)%mo_set) END DO DEALLOCATE(mos_filtered, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - CALL cp_dbcsr_deallocate_matrix_set(matrix_filter, error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + CALL cp_dbcsr_deallocate_matrix_set(matrix_filter) CALL timestop(handle) @@ -698,17 +668,15 @@ END SUBROUTINE fb_env_do_diag !> \param ndep : if the overlap is not positive definite, then ndep > 0, !> and equals to the number of linear dependent basis functions !> in the filtered basis set -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_env_eigensolver(fm_KS, fm_S, mo_set, fm_ortho, & - fm_work, eps_eigval, ndep, error) + fm_work, eps_eigval, ndep) TYPE(cp_fm_type), POINTER :: fm_KS, fm_S TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_fm_type), POINTER :: fm_ortho, fm_work REAL(KIND=dp), INTENT(IN) :: eps_eigval INTEGER, INTENT(OUT) :: ndep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_eigensolver', & routineP = moduleN//':'//routineN @@ -727,13 +695,13 @@ SUBROUTINE fb_env_eigensolver(fm_KS, fm_S, mo_set, fm_ortho, & ndep = 0 ! first, obtain orthogonalisation (ortho) matrix - CALL cp_fm_to_fm(fm_S, fm_ortho, error=error) - CALL cp_fm_cholesky_decompose(fm_ortho, info_out=info, error=error) + CALL cp_fm_to_fm(fm_S, fm_ortho) + CALL cp_fm_cholesky_decompose(fm_ortho, info_out=info) IF (info == 0) THEN ! we are able to use cholesky inverse method - CALL cp_fm_triangular_invert(fm_ortho, error=error) + CALL cp_fm_triangular_invert(fm_ortho) ! solve eigen equation using inverse of cholesky U - CALL cp_fm_upper_to_full(fm_KS, fm_work, error=error) + CALL cp_fm_upper_to_full(fm_KS, fm_work) CALL cp_fm_triangular_multiply(fm_ortho, & fm_KS, & side="R", & @@ -742,8 +710,7 @@ SUBROUTINE fb_env_eigensolver(fm_KS, fm_S, mo_set, fm_ortho, & uplo_tr="U", & n_rows=nao, & n_cols=nao, & - alpha=1.0_dp, & - error=error) + alpha=1.0_dp) CALL cp_fm_triangular_multiply(fm_ortho, & fm_KS, & side="L", & @@ -752,9 +719,8 @@ SUBROUTINE fb_env_eigensolver(fm_KS, fm_S, mo_set, fm_ortho, & uplo_tr="U", & n_rows=nao, & n_cols=nao, & - alpha=1.0_dp, & - error=error) - CALL choose_eigv_solver(fm_KS, fm_work, mo_eigenvalues, error=error) + alpha=1.0_dp) + CALL choose_eigv_solver(fm_KS, fm_work, mo_eigenvalues) CALL cp_fm_triangular_multiply(fm_ortho, & fm_work, & side="L", & @@ -763,24 +729,23 @@ SUBROUTINE fb_env_eigensolver(fm_KS, fm_S, mo_set, fm_ortho, & uplo_tr="U", & n_rows=nao, & n_cols=nmo, & - alpha=1.0_dp, & - error=error) + alpha=1.0_dp) CALL cp_fm_to_fm(fm_work, mo_coeff, nmo, 1, 1) ELSE ! cholesky decomposition has failed, revert to calculating ! ortho as S^-1/2 using diagonalisation of S, and solve ! accordingly - CALL cp_fm_to_fm(fm_S, fm_ortho, error=error) + CALL cp_fm_to_fm(fm_S, fm_ortho) CALL cp_fm_power(fm_ortho, fm_work, -0.5_dp, & - eps_eigval, ndep, error=error) + eps_eigval, ndep) ! solve eigen equatoin using S^-1/2 CALL cp_fm_symm("L", "U", nao, nao, 1.0_dp, fm_KS, fm_ortho, & - 0.0_dp, fm_work, error=error) + 0.0_dp, fm_work) CALL cp_gemm("T", "N", nao, nao, nao, 1.0_dp, fm_ortho, & - fm_work, 0.0_dp, fm_KS, error=error) - CALL choose_eigv_solver(fm_KS, fm_work, mo_eigenvalues, error=error) + fm_work, 0.0_dp, fm_KS) + CALL choose_eigv_solver(fm_KS, fm_work, mo_eigenvalues) CALL cp_gemm("N", "N", nao, nmo, nao, 1.0_dp, fm_ortho, & - fm_work, 0.0_dp, mo_coeff, error=error) + fm_work, 0.0_dp, mo_coeff) END IF CALL timestop(handle) @@ -792,14 +757,12 @@ END SUBROUTINE fb_env_eigensolver !> \brief Read input sections for filter matrix method !> \param fb_env : the filter matrix environment !> \param scf_section : SCF input section -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_read_input(fb_env, scf_section, error) + SUBROUTINE fb_env_read_input(fb_env, scf_section) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_read_input', & routineP = moduleN//':'//routineN @@ -815,29 +778,22 @@ SUBROUTINE fb_env_read_input(fb_env, scf_section, error) NULLIFY(fb_section) fb_section => section_vals_get_subs_vals(scf_section, & - "DIAGONALIZATION%FILTER_MATRIX", & - error=error) + "DIAGONALIZATION%FILTER_MATRIX") ! filter_temperature CALL section_vals_val_get(fb_section, "FILTER_TEMPERATURE", & - r_val=r_val, & - error=error) + r_val=r_val) CALL fb_env_set(fb_env=fb_env, & - filter_temperature=r_val, & - error=error) + filter_temperature=r_val) ! auto_cutoff_scale CALL section_vals_val_get(fb_section, "AUTO_CUTOFF_SCALE", & - r_val=r_val, & - error=error) + r_val=r_val) CALL fb_env_set(fb_env=fb_env, & - auto_cutoff_scale=r_val, & - error=error) + auto_cutoff_scale=r_val) ! communication model CALL section_vals_val_get(fb_section, "COLLECTIVE_COMMUNICATION", & - l_val=l_val, & - error=error) + l_val=l_val) CALL fb_env_set(fb_env=fb_env, & - collective_com=l_val, & - error=error) + collective_com=l_val) CALL timestop(handle) @@ -850,13 +806,11 @@ END SUBROUTINE fb_env_read_input !> ranges for each kind !> \param fb_env : the filter matrix environment !> \param qs_env : quickstep environment -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_build_rcut_auto(fb_env, qs_env, error) + SUBROUTINE fb_env_build_rcut_auto(fb_env, qs_env) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_build_rcut_auto', & routineP = moduleN//':'//routineN @@ -880,15 +834,13 @@ SUBROUTINE fb_env_build_rcut_auto(fb_env, qs_env, error) CALL get_qs_env(qs_env=qs_env, & qs_kind_set=qs_kind_set, & - dft_control=dft_control, & - error=error) + dft_control=dft_control) CALL fb_env_get(fb_env=fb_env, & - auto_cutoff_scale=auto_cutoff_scale, & - error=error) + auto_cutoff_scale=auto_cutoff_scale) nkinds = SIZE(qs_kind_set) ALLOCATE(rcut(nkinds), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! reading from the other parts of the code, it seemed that ! aux_fit_basis_set is only used when do_admm is TRUE. This can be @@ -898,11 +850,11 @@ SUBROUTINE fb_env_build_rcut_auto(fb_env, qs_env, error) ! calculations, and if not set, the task list is generated using ! the default basis_set="ORB". ALLOCATE(basis_set_list(nkinds), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (dft_control%do_admm) THEN - CALL basis_set_list_setup(basis_set_list, "AUX_FIT", qs_kind_set, error=error) + CALL basis_set_list_setup(basis_set_list, "AUX_FIT", qs_kind_set) ELSE - CALL basis_set_list_setup(basis_set_list, "ORB", qs_kind_set, error=error) + CALL basis_set_list_setup(basis_set_list, "ORB", qs_kind_set) END IF DO ikind = 1, nkinds @@ -912,12 +864,11 @@ SUBROUTINE fb_env_build_rcut_auto(fb_env, qs_env, error) END DO CALL fb_env_set(fb_env=fb_env, & - rcut=rcut, & - error=error) + rcut=rcut) ! cleanup DEALLOCATE(basis_set_list, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -932,14 +883,12 @@ END SUBROUTINE fb_env_build_rcut_auto !> positions and their kinds as well as which particles !> are local to this process !> \param scf_section : SCF input section, for printing output -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section, error) + SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_build_atomic_halos', & routineP = moduleN//':'//routineN @@ -967,7 +916,7 @@ SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section, error) failure = .FALSE. - CPPrecondition(fb_env_has_data(fb_env), cp_failure_level, routineP, error, failure) + CPPrecondition(fb_env_has_data(fb_env), cp_failure_level, routineP,failure) NULLIFY(cell, halos, halo_atoms, rcut, particle_set, para_env, & qs_kind_set, local_atoms) @@ -977,11 +926,10 @@ SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section, error) CALL fb_env_get(fb_env=fb_env, & rcut=rcut, & local_atoms=local_atoms, & - nlocal_atoms=natoms_local, & - error=error) + nlocal_atoms=natoms_local) ! create atomic_halos - CALL fb_atomic_halo_list_create(atomic_halos, error) + CALL fb_atomic_halo_list_create(atomic_halos) ! get the number of atoms and kinds: CALL get_qs_env(qs_env=qs_env, & @@ -990,8 +938,7 @@ SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section, error) qs_kind_set=qs_kind_set, & nkind=nkinds_global, & para_env=para_env, & - cell=cell, & - error=error) + cell=cell) ! get the maximum number of local atoms across the procs. max_natoms_local = natoms_local @@ -999,18 +946,17 @@ SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section, error) ! create the halos, one for each local atom ALLOCATE(halos(natoms_local), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ihalo = 1, natoms_local CALL fb_atomic_halo_nullify(halos(ihalo)) - CALL fb_atomic_halo_create(halos(ihalo), error) + CALL fb_atomic_halo_create(halos(ihalo)) END DO CALL fb_atomic_halo_list_set(atomic_halos=atomic_halos, & nhalos=natoms_local, & - max_nhalos=max_natoms_local, & - error=error) + max_nhalos=max_natoms_local) ! build halos ALLOCATE(pair_radii(nkinds_global,nkinds_global), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_build_pair_radii(rcut, nkinds_global, pair_radii) ihalo = 0 DO iatom = 1, natoms_local @@ -1021,14 +967,12 @@ SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section, error) pair_radii, & halo_atoms, & nhalo_atoms, & - owner_id_in_halo, & - error) + owner_id_in_halo) CALL fb_atomic_halo_set(atomic_halo=halos(ihalo), & owner_atom=local_atoms(iatom), & owner_id_in_halo=owner_id_in_halo, & natoms=nhalo_atoms, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) ! prepare halo_atoms for another halo, do not deallocate, as ! original data is being pointed at by the atomic halo data ! structure @@ -1037,31 +981,27 @@ SUBROUTINE fb_env_build_atomic_halos(fb_env, qs_env, scf_section, error) nelectrons = fb_atomic_halo_nelectrons_estimate_Z(halos(ihalo), & particle_set) ! calculate cost - cost = fb_atomic_halo_cost(halos(ihalo), particle_set, qs_kind_set, error=error) + cost = fb_atomic_halo_cost(halos(ihalo), particle_set, qs_kind_set) CALL fb_atomic_halo_set(atomic_halo=halos(ihalo), & nelectrons=nelectrons, & - cost=cost, & - error=error) + cost=cost) ! sort atomic halo - CALL fb_atomic_halo_sort(halos(ihalo), error) + CALL fb_atomic_halo_sort(halos(ihalo)) END DO ! iatom DEALLOCATE(pair_radii, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! finalise CALL fb_atomic_halo_list_set(atomic_halos=atomic_halos, & - halos=halos, & - error=error) + halos=halos) CALL fb_env_set(fb_env=fb_env, & - atomic_halos=atomic_halos, & - error=error) - CALL fb_atomic_halo_list_release(atomic_halos, error) + atomic_halos=atomic_halos) + CALL fb_atomic_halo_list_release(atomic_halos) ! print info CALL fb_atomic_halo_list_write_info(atomic_halos, & para_env, & - scf_section, & - error) + scf_section) CALL timestop(handle) @@ -1075,15 +1015,13 @@ END SUBROUTINE fb_env_build_atomic_halos !> \param fb_env : the filter matrix environment !> \param qs_env : quickstep environment !> \param maxocc : maximum occupancy for an orbital -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) + SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), INTENT(IN) :: maxocc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_build_trial_fns_auto', & routineP = moduleN//':'//routineN @@ -1105,17 +1043,16 @@ SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) CALL timeset(routineN, handle) failure = .FALSE. - CPPrecondition(fb_env_has_data(fb_env), cp_failure_level, routineP, error, failure) + CPPrecondition(fb_env_has_data(fb_env), cp_failure_level, routineP,failure) NULLIFY(nfunctions, functions, basis_set, basis_set_list, qs_kind_set, dft_control) CALL fb_trial_fns_nullify(trial_fns) ! create a new trial_fn object - CALL fb_trial_fns_create(trial_fns, error) + CALL fb_trial_fns_create(trial_fns) CALL get_qs_env(qs_env=qs_env, & qs_kind_set=qs_kind_set, & - dft_control=dft_control, & - error=error) + dft_control=dft_control) nkinds = SIZE(qs_kind_set) @@ -1127,15 +1064,15 @@ SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) ! calculations, and if not set, the task list is generated using ! the default basis_set="ORB". ALLOCATE(basis_set_list(nkinds), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (dft_control%do_admm) THEN - CALL basis_set_list_setup(basis_set_list, "AUX_FIT", qs_kind_set, error=error) + CALL basis_set_list_setup(basis_set_list, "AUX_FIT", qs_kind_set) ELSE - CALL basis_set_list_setup(basis_set_list, "ORB", qs_kind_set, error=error) + CALL basis_set_list_setup(basis_set_list, "ORB", qs_kind_set) END IF ALLOCATE(nfunctions(nkinds), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) nfunctions = 0 DO ikind = 1, nkinds @@ -1146,7 +1083,7 @@ SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) lmax=lmax, & nshell=nshell) CALL get_qs_kind(qs_kind=qs_kind_set(ikind), & - zeff=zeff,error=error) + zeff=zeff) bset1: DO iset = 1, nset ! old_lshell = lmax(iset) @@ -1179,7 +1116,7 @@ SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) ! functions max_n_trial = MAXVAL(nfunctions) ALLOCATE(functions(max_n_trial,nkinds), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) functions(:,:) = 0 ! redo the loops to get the trial function indices within the basis set DO ikind = 1, nkinds @@ -1190,7 +1127,7 @@ SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) lmax=lmax, & nshell=nshell) CALL get_qs_kind(qs_kind=qs_kind_set(ikind), & - zeff=zeff,error=error) + zeff=zeff) icgf = 0 itrial = 0 bset2: DO iset = 1, nset @@ -1225,17 +1162,15 @@ SUBROUTINE fb_env_build_trial_fns_auto(fb_env, qs_env, maxocc, error) ! set trial_functions CALL fb_trial_fns_set(trial_fns=trial_fns, & nfunctions=nfunctions, & - functions=functions, & - error=error) + functions=functions) ! set fb_env CALL fb_env_set(fb_env=fb_env, & - trial_fns=trial_fns, & - error=error) - CALL fb_trial_fns_release(trial_fns, error) + trial_fns=trial_fns) + CALL fb_trial_fns_release(trial_fns) ! cleanup DEALLOCATE(basis_set_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1250,14 +1185,12 @@ END SUBROUTINE fb_env_build_trial_fns_auto !> \param matrix_out : DBCSR matrix whose blocks are to be allocated !> \param matrix_in : DBCSR matrix with exising sparse structure that !> is to be copied -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_dbcsr_copy_sparse_struct(matrix_out, matrix_in, error) + SUBROUTINE fb_dbcsr_copy_sparse_struct(matrix_out, matrix_in) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_out TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_in - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_dbcsr_copy_sparse_struct', & routineP = moduleN//':'//routineN @@ -1278,9 +1211,9 @@ SUBROUTINE fb_dbcsr_copy_sparse_struct(matrix_out, matrix_in, error) nblks = nblkrows_total * nblkcols_total ALLOCATE(rows(nblks), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(cols(nblks), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) rows(:) = 0 cols(:) = 0 iblk = 0 @@ -1293,14 +1226,14 @@ SUBROUTINE fb_dbcsr_copy_sparse_struct(matrix_out, matrix_in, error) nblks = nblks + 1 END DO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_reserve_blocks(matrix_out, rows(1:nblks), cols(1:nblks), error=error) - CALL cp_dbcsr_finalize(matrix_out, error=error) + CALL cp_dbcsr_reserve_blocks(matrix_out, rows(1:nblks), cols(1:nblks)) + CALL cp_dbcsr_finalize(matrix_out) ! cleanup DEALLOCATE(rows, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(cols, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END SUBROUTINE fb_dbcsr_copy_sparse_struct @@ -1311,14 +1244,12 @@ END SUBROUTINE fb_dbcsr_copy_sparse_struct !> \param fb_env : the filter matrix environment !> \param qs_env : quickstep environment !> \param scf_section : SCF input section -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_write_info(fb_env, qs_env, scf_section, error) + SUBROUTINE fb_env_write_info(fb_env, qs_env, scf_section) TYPE(fb_env_obj), INTENT(IN) :: fb_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_write_info', & routineP = moduleN//':'//routineN @@ -1339,22 +1270,19 @@ SUBROUTINE fb_env_write_info(fb_env, qs_env, scf_section, error) NULLIFY(rcut, atomic_kind_set, logger) CALL get_qs_env(qs_env=qs_env, & - atomic_kind_set=atomic_kind_set, & - error=error) + atomic_kind_set=atomic_kind_set) CALL fb_env_get(fb_env=fb_env, & filter_temperature=filter_temperature, & auto_cutoff_scale=auto_cutoff_scale, & rcut=rcut, & - collective_com=collective_com, & - error=error) + collective_com=collective_com) nkinds = SIZE(atomic_kind_set) - logger => cp_error_get_logger(error=error) + logger => cp_get_default_logger() unit_nr = cp_print_key_unit_nr(logger, scf_section, & "PRINT%FILTER_MATRIX", & - extension="", & - error=error) + extension="") IF (unit_nr > 0) THEN IF (collective_com) THEN WRITE (UNIT=unit_nr, FMT="(/,A,T71,A)") & @@ -1367,7 +1295,7 @@ SUBROUTINE fb_env_write_info(fb_env, qs_env, scf_section, error) END IF WRITE (UNIT=unit_nr, FMT="(A,T71,g10.4)") & " FILTER_MAT_DIAG| Filter temperature [K]:", & - cp_unit_from_cp2k(filter_temperature, "K", error=error) + cp_unit_from_cp2k(filter_temperature, "K") WRITE (UNIT=unit_nr, FMT="(A,T71,f10.4)") & " FILTER_MAT_DIAG| Filter temperature [a.u.]:", & filter_temperature @@ -1384,7 +1312,7 @@ SUBROUTINE fb_env_write_info(fb_env, qs_env, scf_section, error) END DO ! ikind END IF CALL cp_print_key_finished_output(unit_nr, logger, scf_section, & - "PRINT%FILTER_MATRIX", error=error) + "PRINT%FILTER_MATRIX") CALL timestop(handle) diff --git a/src/qs_fb_env_types.F b/src/qs_fb_env_types.F index 6444f9dc73..f4584d8018 100644 --- a/src/qs_fb_env_types.F +++ b/src/qs_fb_env_types.F @@ -97,13 +97,10 @@ MODULE qs_fb_env_types ! ********************************************************************** !> \brief retains the given fb_env !> \param fb_env : the fb_env to retain -!> \param error : variable to control error logging, stopping, ... -!> see module cp_error_handling !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_retain(fb_env, error) + SUBROUTINE fb_env_retain(fb_env) TYPE(fb_env_obj), INTENT(IN) :: fb_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_retain', & routineP = moduleN//':'//routineN @@ -111,8 +108,8 @@ SUBROUTINE fb_env_retain(fb_env, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP, error, failure) - CPPreconditionNoFail(fb_env%obj%ref_count>0, cp_failure_level, routineP, error) + CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP,failure) + CPPreconditionNoFail(fb_env%obj%ref_count>0, cp_failure_level, routineP) fb_env%obj%ref_count = fb_env%obj%ref_count + 1 END SUBROUTINE fb_env_retain @@ -121,13 +118,10 @@ END SUBROUTINE fb_env_retain !> \brief releases a given fb_env !> \brief ... !> \param fb_env : the fb_env to release -!> \param error : variable to control error logging, stopping, ... -!> see module cp_error_handling !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_release(fb_env, error) + SUBROUTINE fb_env_release(fb_env) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_release', & routineP = moduleN//':'//routineN @@ -137,23 +131,23 @@ SUBROUTINE fb_env_release(fb_env, error) failure = .FALSE. IF (ASSOCIATED(fb_env%obj)) THEN - CPPreconditionNoFail(fb_env%obj%ref_count>0, cp_failure_level, routineP, error) + CPPreconditionNoFail(fb_env%obj%ref_count>0, cp_failure_level, routineP) fb_env%obj%ref_count = fb_env%obj%ref_count - 1 IF (fb_env%obj%ref_count == 0) THEN fb_env%obj%ref_count = 1 IF (ASSOCIATED(fb_env%obj%rcut)) THEN DEALLOCATE(fb_env%obj%rcut, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF (ASSOCIATED(fb_env%obj%local_atoms)) THEN DEALLOCATE(fb_env%obj%local_atoms, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF - CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos, error) - CALL fb_trial_fns_release(fb_env%obj%trial_fns, error) + CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos) + CALL fb_trial_fns_release(fb_env%obj%trial_fns) fb_env%obj%ref_count = 0 DEALLOCATE(fb_env%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(fb_env%obj) @@ -219,13 +213,10 @@ END FUNCTION fb_env_has_data !> \brief creates an empty fb_env object !> \param fb_env : its content must be a NULL fb_env pointer on input, !> and the output returns an empty fb_env object -!> \param error : variable to control error logging, stopping, ... -!> see module cp_error_handling !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_create(fb_env, error) + SUBROUTINE fb_env_create(fb_env) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_create', & routineP = moduleN//':'//routineN @@ -234,9 +225,9 @@ SUBROUTINE fb_env_create(fb_env, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(fb_env%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(fb_env%obj), cp_failure_level, routineP,failure) ALLOCATE(fb_env%obj, STAT=stat) - CPPostconditionNoFail(stat==0, cp_failure_level, routineP, error) + CPPostconditionNoFail(stat==0, cp_failure_level, routineP) NULLIFY(fb_env%obj%rcut) CALL fb_atomic_halo_list_nullify(fb_env%obj%atomic_halos) CALL fb_trial_fns_nullify(fb_env%obj%trial_fns) @@ -256,13 +247,10 @@ END SUBROUTINE fb_env_create !> \brief ... !> \param fb_env : the fb_env object, which must not be NULL or !> UNDEFINED upon entry -!> \param error : variable to control error logging, stopping, ... -!> see module cp_error_handling !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_env_init(fb_env, error) + SUBROUTINE fb_env_init(fb_env) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_init', & routineP = moduleN//':'//routineN @@ -271,20 +259,20 @@ SUBROUTINE fb_env_init(fb_env, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP,failure) IF (ASSOCIATED(fb_env%obj%rcut)) THEN DEALLOCATE(fb_env%obj%rcut, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(fb_env%obj%rcut) END IF - CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos, error) - CALL fb_trial_fns_release(fb_env%obj%trial_fns, error) + CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos) + CALL fb_trial_fns_release(fb_env%obj%trial_fns) fb_env%obj%filter_temperature = 0.0_dp fb_env%obj%auto_cutoff_scale = 1.0_dp fb_env%obj%collective_com = .TRUE. IF (ASSOCIATED(fb_env%obj%local_atoms)) THEN DEALLOCATE(fb_env%obj%local_atoms, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(fb_env%obj%local_atoms) END IF fb_env%obj%nlocal_atoms = 0 @@ -307,8 +295,6 @@ END SUBROUTINE fb_env_init !> \param collective_com : outputs pointer to trial_fns !> \param local_atoms : outputs pointer to local_atoms !> \param nlocal_atoms : outputs pointer to nlocal_atoms -!> \param error : variable to control error logging, stopping, ... -!> see module cp_error_handling !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_env_get(fb_env, & @@ -319,8 +305,7 @@ SUBROUTINE fb_env_get(fb_env, & trial_fns, & collective_com, & local_atoms, & - nlocal_atoms, & - error) + nlocal_atoms) TYPE(fb_env_obj), INTENT(IN) :: fb_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: rcut @@ -333,7 +318,6 @@ SUBROUTINE fb_env_get(fb_env, & LOGICAL, INTENT(OUT), OPTIONAL :: collective_com INTEGER, DIMENSION(:), OPTIONAL, POINTER :: local_atoms INTEGER, INTENT(OUT), OPTIONAL :: nlocal_atoms - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_get', & routineP = moduleN//':'//routineN @@ -341,8 +325,8 @@ SUBROUTINE fb_env_get(fb_env, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP, error, failure) - CPPrecondition(fb_env%obj%ref_count>0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP,failure) + CPPrecondition(fb_env%obj%ref_count>0, cp_failure_level, routineP,failure) IF (PRESENT(rcut)) & rcut => fb_env%obj%rcut IF (PRESENT(filter_temperature)) & @@ -374,8 +358,6 @@ END SUBROUTINE fb_env_get !> \param collective_com : sets collective_com attribute of fb_env (optional) !> \param local_atoms : sets local_atoms attribute of fb_env (optional) !> \param nlocal_atoms : sets nlocal_atoms attribute of fb_env (optional) -!> \param error : variable to control error logging, stopping, ... -!> see module cp_error_handling !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_env_set(fb_env, & @@ -386,8 +368,7 @@ SUBROUTINE fb_env_set(fb_env, & trial_fns, & collective_com, & local_atoms, & - nlocal_atoms, & - error) + nlocal_atoms) TYPE(fb_env_obj), INTENT(INOUT) :: fb_env REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: rcut @@ -400,7 +381,6 @@ SUBROUTINE fb_env_set(fb_env, & LOGICAL, INTENT(IN), OPTIONAL :: collective_com INTEGER, DIMENSION(:), OPTIONAL, POINTER :: local_atoms INTEGER, INTENT(IN), OPTIONAL :: nlocal_atoms - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_env_set', & routineP = moduleN//':'//routineN @@ -409,11 +389,11 @@ SUBROUTINE fb_env_set(fb_env, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(fb_env%obj), cp_failure_level, routineP,failure) IF (PRESENT(rcut)) THEN IF (ASSOCIATED(fb_env%obj%rcut)) THEN DEALLOCATE(fb_env%obj%rcut, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF fb_env%obj%rcut => rcut END IF @@ -423,14 +403,14 @@ SUBROUTINE fb_env_set(fb_env, & fb_env%obj%auto_cutoff_scale = auto_cutoff_scale IF (PRESENT(atomic_halos)) THEN IF (fb_atomic_halo_list_has_data(atomic_halos)) & - CALL fb_atomic_halo_list_retain(atomic_halos, error) - CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos, error) + CALL fb_atomic_halo_list_retain(atomic_halos) + CALL fb_atomic_halo_list_release(fb_env%obj%atomic_halos) CALL fb_atomic_halo_list_associate(fb_env%obj%atomic_halos, atomic_halos) END IF IF (PRESENT(trial_fns)) THEN IF (fb_trial_fns_has_data(trial_fns)) & - CALL fb_trial_fns_retain(trial_fns, error) - CALL fb_trial_fns_release(fb_env%obj%trial_fns, error) + CALL fb_trial_fns_retain(trial_fns) + CALL fb_trial_fns_release(fb_env%obj%trial_fns) CALL fb_trial_fns_associate(fb_env%obj%trial_fns, trial_fns) END IF IF (PRESENT(collective_com)) & @@ -438,7 +418,7 @@ SUBROUTINE fb_env_set(fb_env, & IF (PRESENT(local_atoms)) THEN IF (ASSOCIATED(fb_env%obj%local_atoms)) THEN DEALLOCATE(fb_env%obj%local_atoms, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF fb_env%obj%local_atoms => local_atoms END IF diff --git a/src/qs_fb_filter_matrix_methods.F b/src/qs_fb_filter_matrix_methods.F index a1341ed3f9..be255ae21d 100644 --- a/src/qs_fb_filter_matrix_methods.F +++ b/src/qs_fb_filter_matrix_methods.F @@ -90,7 +90,6 @@ MODULE qs_fb_filter_matrix_methods !> filter function !> \param name : name given to the filter matrix !> \param filter_mat : DBCSR format filter matrix -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_fltrmat_build(H_mat, & @@ -102,8 +101,7 @@ SUBROUTINE fb_fltrmat_build(H_mat, & fermi_level, & filter_temp, & name, & - filter_mat, & - error) + filter_mat) TYPE(cp_dbcsr_type), POINTER :: H_mat, S_mat TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos @@ -114,7 +112,6 @@ SUBROUTINE fb_fltrmat_build(H_mat, & REAL(KIND=dp), INTENT(IN) :: fermi_level, filter_temp CHARACTER(LEN=*), INTENT(IN) :: name TYPE(cp_dbcsr_type), POINTER :: filter_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_fltrmat_build', & routineP = moduleN//':'//routineN @@ -142,12 +139,11 @@ SUBROUTINE fb_fltrmat_build(H_mat, & CALL fb_atomic_halo_nullify(dummy_atomic_halo) ! filter_mat must be of a dissassociated status (i.e. brand new) - CPPrecondition(.NOT.ASSOCIATED(filter_mat), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(filter_mat), cp_failure_level, routineP,failure) ! get trial function information CALL fb_trial_fns_get(trial_fns=trial_fns, & - nfunctions=ntfns, & - error=error) + nfunctions=ntfns) ! calculate the row_blk_size and col_blk_size arrays for ! constructing the filter matrix in DBCSR format @@ -157,7 +153,7 @@ SUBROUTINE fb_fltrmat_build(H_mat, & row_blk_size=row_blk_size, & distribution=dbcsr_dist) ALLOCATE(col_blk_size(nblkcols_total), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) col_blk_size = 0 DO iblkcol = 1, nblkcols_total atomic_kind => particle_set(iblkcol)%atomic_kind @@ -173,37 +169,34 @@ SUBROUTINE fb_fltrmat_build(H_mat, & symmetry_string = dbcsr_type_no_symmetry ! create empty filter matrix ALLOCATE(filter_mat, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - CALL cp_dbcsr_init(filter_mat, error=error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + CALL cp_dbcsr_init(filter_mat) CALL cp_dbcsr_create(matrix=filter_mat, & name=name_string, & dist=dbcsr_dist, & matrix_type=symmetry_string, & row_blk_size=row_blk_size, & col_blk_size=col_blk_size, & - nze=0, & - error=error) + nze=0) DEALLOCATE(col_blk_size, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atomic_halo_list_get(atomic_halos=atomic_halos, & nhalos=nhalos, & max_nhalos=max_nhalos, & - halos=halos, & - error=error) + halos=halos) ! create dummy empty atomic halo - CALL fb_atomic_halo_create(dummy_atomic_halo, error) + CALL fb_atomic_halo_create(dummy_atomic_halo) ALLOCATE(dummy_halo_atoms(0), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atomic_halo_set(atomic_halo=dummy_atomic_halo, & owner_atom=0, & owner_id_in_halo=0, & natoms=0, & halo_atoms=dummy_halo_atoms, & nelectrons=0, & - sorted=.TRUE., & - error=error) + sorted=.TRUE.) send_data_only = .FALSE. @@ -221,8 +214,7 @@ SUBROUTINE fb_fltrmat_build(H_mat, & particle_set, & fermi_level, & filter_temp, & - filter_mat, & - error) + filter_mat) ELSE CALL fb_fltrmat_add_blkcol(H_mat, & S_mat, & @@ -232,16 +224,15 @@ SUBROUTINE fb_fltrmat_build(H_mat, & particle_set, & fermi_level, & filter_temp, & - filter_mat, & - error) + filter_mat) END IF ! send_data_only END DO ! finalise the filter matrix - CALL cp_dbcsr_finalize(filter_mat, error=error) + CALL cp_dbcsr_finalize(filter_mat) ! cleanup - CALL fb_atomic_halo_release(dummy_atomic_halo, error) + CALL fb_atomic_halo_release(dummy_atomic_halo) CALL timestop(handle) @@ -268,7 +259,6 @@ END SUBROUTINE fb_fltrmat_build !> filter function !> \param name : name given to the filter matrix !> \param filter_mat : DBCSR format filter matrix -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_fltrmat_build_2(H_mat, & @@ -280,8 +270,7 @@ SUBROUTINE fb_fltrmat_build_2(H_mat, & fermi_level, & filter_temp, & name, & - filter_mat, & - error) + filter_mat) TYPE(cp_dbcsr_type), POINTER :: H_mat, S_mat TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos @@ -292,7 +281,6 @@ SUBROUTINE fb_fltrmat_build_2(H_mat, & REAL(KIND=dp), INTENT(IN) :: fermi_level, filter_temp CHARACTER(LEN=*), INTENT(IN) :: name TYPE(cp_dbcsr_type), POINTER :: filter_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_fltrmat_build_2', & routineP = moduleN//':'//routineN @@ -320,15 +308,14 @@ SUBROUTINE fb_fltrmat_build_2(H_mat, & ! filter_mat must be of a dissassociated status (i.e. brand new) check_ok = .NOT. ASSOCIATED(filter_mat) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! get total number of atoms natoms_global = SIZE(particle_set) ! get trial function information CALL fb_trial_fns_get(trial_fns=trial_fns, & - nfunctions=ntfns, & - error=error) + nfunctions=ntfns) ! calculate the row_blk_size and col_blk_size arrays for ! constructing the filter matrix in DBCSR format @@ -338,7 +325,7 @@ SUBROUTINE fb_fltrmat_build_2(H_mat, & row_blk_size=row_blk_size, & distribution=dbcsr_dist) ALLOCATE(col_blk_size(nblkcols_total), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) col_blk_size = 0 DO iblkcol = 1, nblkcols_total atomic_kind => particle_set(iblkcol)%atomic_kind @@ -352,18 +339,17 @@ SUBROUTINE fb_fltrmat_build_2(H_mat, & CALL uppercase(name_string) ! create empty filter matrix (it is always non-symmetric as it is non-square) ALLOCATE(filter_mat, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) - CALL cp_dbcsr_init(filter_mat, error=error) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) + CALL cp_dbcsr_init(filter_mat) CALL cp_dbcsr_create(matrix=filter_mat, & name=name_string, & dist=dbcsr_dist, & matrix_type=dbcsr_type_no_symmetry, & row_blk_size=row_blk_size, & col_blk_size=col_blk_size, & - nze=0, & - error=error) + nze=0) DEALLOCATE(col_blk_size, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! get all the blocks required for constructing atomic matrics, and ! store it in a fb_matrix_data object @@ -371,70 +357,59 @@ SUBROUTINE fb_fltrmat_build_2(H_mat, & CALL fb_matrix_data_nullify(S_mat_data) CALL fb_com_atom_pairs_nullify(atmatrix_blks_send) CALL fb_com_atom_pairs_nullify(atmatrix_blks_recv) - CALL fb_com_atom_pairs_create(atmatrix_blks_send, error) - CALL fb_com_atom_pairs_create(atmatrix_blks_recv, error) + CALL fb_com_atom_pairs_create(atmatrix_blks_send) + CALL fb_com_atom_pairs_create(atmatrix_blks_recv) ! H matrix CALL fb_atmatrix_generate_com_pairs_2(H_mat, & atomic_halos, & para_env, & atmatrix_blks_send, & - atmatrix_blks_recv, & - error) + atmatrix_blks_recv) CALL fb_com_atom_pairs_get(atom_pairs=atmatrix_blks_recv, & - npairs=nblks_recv, & - error=error) + npairs=nblks_recv) CALL fb_matrix_data_create(H_mat_data, & nblks_recv, & - natoms_global, & - error) + natoms_global) CALL fb_com_atom_pairs_gather_blks(H_mat, & atmatrix_blks_send, & atmatrix_blks_recv, & para_env, & - H_mat_data, & - error) + H_mat_data) ! S matrix CALL fb_atmatrix_generate_com_pairs_2(S_mat, & atomic_halos, & para_env, & atmatrix_blks_send, & - atmatrix_blks_recv, & - error) + atmatrix_blks_recv) CALL fb_com_atom_pairs_get(atom_pairs=atmatrix_blks_recv, & - npairs=nblks_recv, & - error=error) + npairs=nblks_recv) CALL fb_matrix_data_create(S_mat_data, & nblks_recv, & - natoms_global, & - error) + natoms_global) CALL fb_com_atom_pairs_gather_blks(S_mat, & atmatrix_blks_send, & atmatrix_blks_recv, & para_env, & - S_mat_data, & - error) + S_mat_data) ! cleanup - CALL fb_com_atom_pairs_release(atmatrix_blks_send, error) - CALL fb_com_atom_pairs_release(atmatrix_blks_recv, error) + CALL fb_com_atom_pairs_release(atmatrix_blks_send) + CALL fb_com_atom_pairs_release(atmatrix_blks_recv) ! make filter matrix blocks one by one and store in an ! matrix_data_obj CALL fb_matrix_data_nullify(filter_mat_data) CALL fb_atomic_halo_list_get(atomic_halos=atomic_halos, & nhalos=nhalos, & - halos=halos, & - error=error) + halos=halos) nmax = 0 DO ihalo = 1, nhalos CALL fb_atomic_halo_get(atomic_halo=halos(ihalo), & - natoms=natoms_in_halo, & - error=error) + natoms=natoms_in_halo) nmax = nmax + natoms_in_halo END DO CALL fb_matrix_data_create(filter_mat_data, & nmax, & - natoms_global, & - error) + natoms_global) DO ihalo = 1, nhalos CALL fb_fltrmat_add_blkcol_2(H_mat, & S_mat, & @@ -445,38 +420,35 @@ SUBROUTINE fb_fltrmat_build_2(H_mat, & particle_set, & fermi_level, & filter_temp, & - filter_mat_data, & - error) + filter_mat_data) END DO ! clean up - CALL fb_matrix_data_release(H_mat_data, error) - CALL fb_matrix_data_release(S_mat_data, error) + CALL fb_matrix_data_release(H_mat_data) + CALL fb_matrix_data_release(S_mat_data) ! distribute the relevant blocks from the matrix_data_obj to DBCSR ! filter matrix CALL fb_com_atom_pairs_nullify(filter_mat_blks_send) CALL fb_com_atom_pairs_nullify(filter_mat_blks_recv) - CALL fb_com_atom_pairs_create(filter_mat_blks_send, error) - CALL fb_com_atom_pairs_create(filter_mat_blks_recv, error) + CALL fb_com_atom_pairs_create(filter_mat_blks_send) + CALL fb_com_atom_pairs_create(filter_mat_blks_recv) CALL fb_fltrmat_generate_com_pairs_2(filter_mat, & atomic_halos, & para_env, & filter_mat_blks_send, & - filter_mat_blks_recv, & - error) + filter_mat_blks_recv) CALL fb_com_atom_pairs_distribute_blks(filter_mat_data, & filter_mat_blks_send, & filter_mat_blks_recv, & para_env, & - filter_mat, & - error) + filter_mat) ! cleanup - CALL fb_com_atom_pairs_release(filter_mat_blks_send, error) - CALL fb_com_atom_pairs_release(filter_mat_blks_recv, error) - CALL fb_matrix_data_release(filter_mat_data, error) + CALL fb_com_atom_pairs_release(filter_mat_blks_send) + CALL fb_com_atom_pairs_release(filter_mat_blks_recv) + CALL fb_matrix_data_release(filter_mat_data) ! finalise matrix - CALL cp_dbcsr_finalize(filter_mat, error=error) + CALL cp_dbcsr_finalize(filter_mat) CALL timestop(handle) @@ -501,7 +473,6 @@ END SUBROUTINE fb_fltrmat_build_2 !> \param filter_temp : the filter temperature used for defining the !> filter function !> \param filter_mat : DBCSR format filter matrix -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & @@ -512,8 +483,7 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & particle_set, & fermi_level, & filter_temp, & - filter_mat, & - error) + filter_mat) TYPE(cp_dbcsr_type), POINTER :: H_mat, S_mat TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo TYPE(fb_trial_fns_obj), INTENT(IN) :: trial_fns @@ -522,7 +492,6 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & POINTER :: particle_set REAL(KIND=dp), INTENT(IN) :: fermi_level, filter_temp TYPE(cp_dbcsr_type), POINTER :: filter_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_fltrmat_add_blkcol', & routineP = moduleN//':'//routineN @@ -563,22 +532,19 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & ! ---------------------------------------------------------------------- ! generate send and recv atom pairs - CALL fb_com_atom_pairs_create(com_pairs_send, error) - CALL fb_com_atom_pairs_create(com_pairs_recv, error) + CALL fb_com_atom_pairs_create(com_pairs_send) + CALL fb_com_atom_pairs_create(com_pairs_recv) CALL fb_fltrmat_generate_com_pairs(filter_mat, & atomic_halo, & para_env, & com_pairs_send, & - com_pairs_recv, & - error) + com_pairs_recv) CALL fb_com_atom_pairs_get(atom_pairs=com_pairs_send, & natoms_encode=send_encode, & - pairs=pairs_send, & - error=error) + pairs=pairs_send) CALL fb_com_atom_pairs_get(atom_pairs=com_pairs_recv, & natoms_encode=recv_encode, & - pairs=pairs_recv, & - error=error) + pairs=pairs_recv) ! get para_env info numprocs = para_env%num_pe @@ -587,14 +553,13 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & ! obtain trail function information CALL fb_trial_fns_get(trial_fns=trial_fns, & nfunctions=ntfns, & - functions=tfns, & - error=error) + functions=tfns) ! obtain row and col block size data for filter matrix row_block_size_data => cp_dbcsr_row_block_sizes(H_mat) natoms_global = SIZE(particle_set) ALLOCATE(col_block_size_data(natoms_global), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO jatom_global = 1, natoms_global atomic_kind => particle_set(jatom_global)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, kind_number=jkind) @@ -603,13 +568,13 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & ! allocate temporary arrays for send ALLOCATE(send_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(send_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup send buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(com_pairs_send, & numprocs, & @@ -618,21 +583,20 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & send_sizes, & send_disps, & send_pair_count, & - send_pair_disps, & - error) + send_pair_disps) ! allocate send buffer ALLOCATE(send_buf(SUM(send_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! allocate temporary array for recv ALLOCATE(recv_sizes(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_count(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(recv_pair_disps(numprocs), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! setup recv buffer sizes CALL fb_com_atom_pairs_calc_buffer_sizes(com_pairs_recv, & numprocs, & @@ -641,11 +605,10 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & recv_sizes, & recv_disps, & recv_pair_count, & - recv_pair_disps, & - error) + recv_pair_disps) ! allocate recv buffer ALLOCATE(recv_buf(SUM(recv_sizes)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! ---------------------------------------------------------------------- ! Construct atomic filter matrix for this atomic_halo @@ -653,65 +616,59 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) ! construct atomic matrix for H for atomic_halo ALLOCATE(atomic_H_blk_row_start(natoms_in_halo + 1), & atomic_H_blk_col_start(natoms_in_halo + 1), & STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & ncols_atmatrix, & atomic_H_blk_row_start, & - atomic_H_blk_col_start, & - error) + atomic_H_blk_col_start) ALLOCATE(atomic_H(nrows_atmatrix,ncols_atmatrix), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_construct(H_mat, & atomic_halo, & para_env, & atomic_H, & atomic_H_blk_row_start, & - atomic_H_blk_col_start, & - error) + atomic_H_blk_col_start) ! construct atomic matrix for S for atomic_halo ALLOCATE(atomic_S_blk_row_start(natoms_in_halo + 1), & atomic_S_blk_col_start(natoms_in_halo + 1), & STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & ncols_atmatrix, & atomic_S_blk_row_start, & - atomic_S_blk_col_start, & - error) + atomic_S_blk_col_start) ALLOCATE(atomic_S(nrows_atmatrix,ncols_atmatrix), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_construct(S_mat, & atomic_halo, & para_env, & atomic_S, & atomic_S_blk_row_start, & - atomic_S_blk_col_start, & - error) + atomic_S_blk_col_start) ! construct the atomic filter matrix ALLOCATE(atomic_filter_mat(nrows_atmatrix,ncols_atmatrix), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! calculate atomic filter matrix only if it is non-zero sized IF (nrows_atmatrix > 0 .AND. ncols_atmatrix > 0) THEN CALL fb_fltrmat_build_atomic_fltrmat(atomic_H, & atomic_S, & fermi_level, & filter_temp, & - atomic_filter_mat, & - error) + atomic_filter_mat) END IF ! ---------------------------------------------------------------------- @@ -721,7 +678,7 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & ! preconstruct iatom_global to iatom_in_halo map ALLOCATE(ind_in_halo(natoms_global), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ind_in_halo = 0 DO iatom_in_halo = 1, natoms_in_halo iatom_global = halo_atoms(iatom_in_halo) @@ -738,9 +695,9 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & pe, iatom_global, jatom_global, & send_encode) iatom_in_halo = ind_in_halo(iatom_global) - CPPostcondition(iatom_in_halo>0, cp_failure_level, routineP, error, failure) + CPPostcondition(iatom_in_halo>0, cp_failure_level, routineP,failure) jatom_in_halo = ind_in_halo(jatom_global) - CPPostcondition(jatom_in_halo>0, cp_failure_level, routineP, error, failure) + CPPostcondition(jatom_in_halo>0, cp_failure_level, routineP,failure) atomic_kind => particle_set(jatom_global)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, & kind_number=jkind) @@ -775,17 +732,17 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & END DO ! ipe DEALLOCATE(atomic_H, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_H_blk_row_start, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_S, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_S_blk_row_start, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_filter_mat, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(ind_in_halo, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! ---------------------------------------------------------------------- ! Do communication @@ -800,15 +757,15 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & CALL timestop(handle_mpi) DEALLOCATE(send_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(send_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! ---------------------------------------------------------------------- ! Unpack the recv buffer and add the blocks to correct parts of @@ -833,16 +790,16 @@ SUBROUTINE fb_fltrmat_add_blkcol(H_mat, & ! cleanup rest of the temporary arrays DEALLOCATE(recv_buf, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_sizes, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_count, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(recv_pair_disps, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) - CALL fb_com_atom_pairs_release(com_pairs_send, error) - CALL fb_com_atom_pairs_release(com_pairs_recv, error) + CALL fb_com_atom_pairs_release(com_pairs_send) + CALL fb_com_atom_pairs_release(com_pairs_recv) ! cannot finalise the matrix until all blocks has been added @@ -869,7 +826,6 @@ END SUBROUTINE fb_fltrmat_add_blkcol !> filter function !> \param filter_mat_data : local storage for the the computed filter matrix !> blocks -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & @@ -881,8 +837,7 @@ SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & particle_set, & fermi_level, & filter_temp, & - filter_mat_data, & - error) + filter_mat_data) TYPE(cp_dbcsr_type), POINTER :: H_mat, S_mat TYPE(fb_matrix_data_obj), INTENT(IN) :: H_mat_data, S_mat_data TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo @@ -891,7 +846,6 @@ SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & POINTER :: particle_set REAL(KIND=dp), INTENT(IN) :: fermi_level, filter_temp TYPE(fb_matrix_data_obj), INTENT(INOUT) :: filter_mat_data - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fb_fltrmat_add_blkcol_2', & routineP = moduleN//':'//routineN @@ -916,21 +870,20 @@ SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & NULLIFY(atomic_kind, halo_atoms, ntfns, row_block_size_data, tfns) check_ok = fb_matrix_data_has_data(H_mat_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = fb_matrix_data_has_data(S_mat_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! obtain trial function information CALL fb_trial_fns_get(trial_fns=trial_fns, & nfunctions=ntfns, & - functions=tfns, & - error=error) + functions=tfns) ! obtain row and col block size data for filter matrix row_block_size_data => cp_dbcsr_row_block_sizes(H_mat) natoms_global = SIZE(particle_set) ALLOCATE(col_block_size_data(natoms_global), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO jatom_global = 1, natoms_global atomic_kind => particle_set(jatom_global)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, kind_number=jkind) @@ -943,62 +896,56 @@ SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) ! construct atomic matrix for H for atomic_halo ALLOCATE(atomic_H_blk_row_start(natoms_in_halo + 1), & atomic_H_blk_col_start(natoms_in_halo + 1), & STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_calc_size(H_mat, & atomic_halo, & nrows_atmatrix, & ncols_atmatrix, & atomic_H_blk_row_start, & - atomic_H_blk_col_start, & - error) + atomic_H_blk_col_start) ALLOCATE(atomic_H(nrows_atmatrix,ncols_atmatrix), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_construct_2(H_mat_data, & atomic_halo, & atomic_H, & atomic_H_blk_row_start, & - atomic_H_blk_col_start, & - error) + atomic_H_blk_col_start) ! construct atomic matrix for S for atomic_halo ALLOCATE(atomic_S_blk_row_start(natoms_in_halo + 1), & atomic_S_blk_col_start(natoms_in_halo + 1), & STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_calc_size(S_mat, & atomic_halo, & nrows_atmatrix, & ncols_atmatrix, & atomic_S_blk_row_start, & - atomic_S_blk_col_start, & - error) + atomic_S_blk_col_start) ALLOCATE(atomic_S(nrows_atmatrix,ncols_atmatrix), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_atmatrix_construct_2(S_mat_data, & atomic_halo, & atomic_S, & atomic_S_blk_row_start, & - atomic_S_blk_col_start, & - error) + atomic_S_blk_col_start) ! construct the atomic filter matrix ALLOCATE(atomic_filter_mat(nrows_atmatrix,ncols_atmatrix), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! calculate atomic filter matrix only if it is non-zero sized IF (nrows_atmatrix > 0 .AND. ncols_atmatrix > 0) THEN CALL fb_fltrmat_build_atomic_fltrmat(atomic_H, & atomic_S, & fermi_level, & filter_temp, & - atomic_filter_mat, & - error) + atomic_filter_mat) END IF ! ---------------------------------------------------------------------- @@ -1007,12 +954,11 @@ SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & owner_atom=jatom_global, & - owner_id_in_halo=jatom_in_halo, & - error=error) + owner_id_in_halo=jatom_in_halo) nrows_blk_max = MAXVAL(row_block_size_data) ncols_blk_max = MAXVAL(ntfns) ALLOCATE(mat_blk(nrows_blk_max,ncols_blk_max), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) mat_blk(:,:) = 0.0_dp DO iatom_in_halo = 1, natoms_in_halo iatom_global = halo_atoms(iatom_in_halo) @@ -1023,7 +969,7 @@ SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & ncols_blk = ntfns(jkind) ! ALLOCATE(mat_blk(nrows_blk,ncols_blk) STAT=stat) - ! CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! do it column-wise one trial function at a time DO itrial = 1, ntfns(jkind) @@ -1052,25 +998,24 @@ SUBROUTINE fb_fltrmat_add_blkcol_2(H_mat, & CALL fb_matrix_data_add(filter_mat_data, & iatom_global, & jatom_global, & - mat_blk(1:nrows_blk, 1:ncols_blk), & - error) + mat_blk(1:nrows_blk, 1:ncols_blk)) ! DEALLOCATE(mat_blk, STAT=stat) - ! CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + ! CPPostcondition(stat==0, cp_failure_level, routineP,failure) END DO ! iatom_in_halo DEALLOCATE(mat_blk, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! clean up DEALLOCATE(atomic_H, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_H_blk_row_start, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_S, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_S_blk_row_start, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_filter_mat, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -1088,22 +1033,19 @@ END SUBROUTINE fb_fltrmat_add_blkcol_2 !> \param para_env : cp2k parallel environment !> \param atom_pairs_send : list of blocks to be sent !> \param atom_pairs_recv : list of blocks to be received -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_fltrmat_generate_com_pairs(filter_mat, & atomic_halo, & para_env, & atom_pairs_send, & - atom_pairs_recv, & - error) + atom_pairs_recv) TYPE(cp_dbcsr_type), POINTER :: filter_mat TYPE(fb_atomic_halo_obj), INTENT(IN) :: atomic_halo TYPE(cp_para_env_type), POINTER :: para_env TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs_send, & atom_pairs_recv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_fltrmat_generate_com_pairs', & @@ -1128,14 +1070,14 @@ SUBROUTINE fb_fltrmat_generate_com_pairs(filter_mat, & ! initialise atom_pairs_send and atom_pairs_recv IF (fb_com_atom_pairs_has_data(atom_pairs_send)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_send, error) + CALL fb_com_atom_pairs_init(atom_pairs_send) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_send, error) + CALL fb_com_atom_pairs_create(atom_pairs_send) END IF IF (fb_com_atom_pairs_has_data(atom_pairs_recv)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_recv, error) + CALL fb_com_atom_pairs_init(atom_pairs_recv) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_recv, error) + CALL fb_com_atom_pairs_create(atom_pairs_recv) END IF ! source is always the local processor @@ -1157,13 +1099,12 @@ SUBROUTINE fb_fltrmat_generate_com_pairs(filter_mat, & CALL fb_atomic_halo_get(atomic_halo=atomic_halo, & owner_atom=jatom_global, & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) ntasks_send = natoms_in_halo ! allocate send tasks ALLOCATE(tasks_send(TASK_N_RECORDS,ntasks_send), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! Get the total number of atoms, this can be obtained from the ! total number of block rows in the DBCSR filter matrix. We @@ -1199,19 +1140,18 @@ SUBROUTINE fb_fltrmat_generate_com_pairs(filter_mat, & itask = itask + 1 END DO ! iatom_in_halo - CALL fb_com_tasks_create(com_tasks_recv, error) - CALL fb_com_tasks_create(com_tasks_send, error) + CALL fb_com_tasks_create(com_tasks_recv) + CALL fb_com_tasks_create(com_tasks_send) CALL fb_com_tasks_set(com_tasks=com_tasks_send, & task_dim=TASK_N_RECORDS, & ntasks=ntasks_send, & nencode=nblkrows_total, & - tasks=tasks_send, & - error=error) + tasks=tasks_send) ! generate the recv task list (tasks_recv) from the send task list CALL fb_com_tasks_transpose_dest_src(com_tasks_recv, "<", com_tasks_send, & - para_env, error) + para_env) ! task lists are now complete, now construct the atom_pairs_send ! and atom_pairs_recv from the tasks lists @@ -1219,18 +1159,16 @@ SUBROUTINE fb_fltrmat_generate_com_pairs(filter_mat, & atom_pairs=atom_pairs_send, & natoms_encode=nblkrows_total, & send_or_recv="send", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) CALL fb_com_tasks_build_atom_pairs(com_tasks=com_tasks_recv, & atom_pairs=atom_pairs_recv, & natoms_encode=nblkrows_total, & send_or_recv="recv", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) ! cleanup - CALL fb_com_tasks_release(com_tasks_recv, error) - CALL fb_com_tasks_release(com_tasks_send, error) + CALL fb_com_tasks_release(com_tasks_recv) + CALL fb_com_tasks_release(com_tasks_send) CALL timestop(handle) @@ -1248,15 +1186,13 @@ END SUBROUTINE fb_fltrmat_generate_com_pairs !> \param para_env : cp2k parallel environment !> \param atom_pairs_send : list of blocks to be sent !> \param atom_pairs_recv : list of blocks to be received -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_fltrmat_generate_com_pairs_2(filter_mat, & atomic_halos, & para_env, & atom_pairs_send, & - atom_pairs_recv, & - error) + atom_pairs_recv) TYPE(cp_dbcsr_type), POINTER :: filter_mat TYPE(fb_atomic_halo_list_obj), & INTENT(IN) :: atomic_halos @@ -1264,7 +1200,6 @@ SUBROUTINE fb_fltrmat_generate_com_pairs_2(filter_mat, & TYPE(fb_com_atom_pairs_obj), & INTENT(INOUT) :: atom_pairs_send, & atom_pairs_recv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_fltrmat_generate_com_pairs_2', & @@ -1291,14 +1226,14 @@ SUBROUTINE fb_fltrmat_generate_com_pairs_2(filter_mat, & ! initialise atom_pairs_send and atom_pairs_recv IF (fb_com_atom_pairs_has_data(atom_pairs_send)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_send, error) + CALL fb_com_atom_pairs_init(atom_pairs_send) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_send, error) + CALL fb_com_atom_pairs_create(atom_pairs_send) END IF IF (fb_com_atom_pairs_has_data(atom_pairs_recv)) THEN - CALL fb_com_atom_pairs_init(atom_pairs_recv, error) + CALL fb_com_atom_pairs_init(atom_pairs_recv) ELSE - CALL fb_com_atom_pairs_create(atom_pairs_recv, error) + CALL fb_com_atom_pairs_create(atom_pairs_recv) END IF ! source is always the local processor @@ -1312,21 +1247,19 @@ SUBROUTINE fb_fltrmat_generate_com_pairs_2(filter_mat, & CALL fb_atomic_halo_list_get(atomic_halos=atomic_halos, & nhalos=nhalos, & - halos=halos, & - error=error) + halos=halos) ! estimate the maximum number of blocks (i.e. atom paris) to send ntasks_send = 0 DO ihalo = 1, nhalos CALL fb_atomic_halo_get(atomic_halo=halos(ihalo), & - natoms=natoms_in_halo, & - error=error) + natoms=natoms_in_halo) ntasks_send = ntasks_send + natoms_in_halo END DO ! ihalo ! allocate send tasks ALLOCATE(tasks_send(TASK_N_RECORDS,ntasks_send), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! Get the total number of atoms. This can be obtained from the ! total number of block rows in the DBCSR filter matrix. We @@ -1344,8 +1277,7 @@ SUBROUTINE fb_fltrmat_generate_com_pairs_2(filter_mat, & CALL fb_atomic_halo_get(atomic_halo=halos(ihalo), & owner_atom=jatom_global, & natoms=natoms_in_halo, & - halo_atoms=halo_atoms, & - error=error) + halo_atoms=halo_atoms) DO iatom_in_halo = 1, natoms_in_halo iatom_global = halo_atoms(iatom_in_halo) iatom_stored = iatom_global @@ -1369,18 +1301,17 @@ SUBROUTINE fb_fltrmat_generate_com_pairs_2(filter_mat, & END DO ! iatom_in_halo END DO ! ihalo - CALL fb_com_tasks_create(com_tasks_send, error) + CALL fb_com_tasks_create(com_tasks_send) CALL fb_com_tasks_set(com_tasks=com_tasks_send, & task_dim=TASK_N_RECORDS, & ntasks=ntasks_send, & nencode=nblkrows_total, & - tasks=tasks_send, & - error=error) + tasks=tasks_send) ! generate the recv task list (tasks_recv) from the send task list - CALL fb_com_tasks_create(com_tasks_recv, error) + CALL fb_com_tasks_create(com_tasks_recv) CALL fb_com_tasks_transpose_dest_src(com_tasks_recv, "<", com_tasks_send, & - para_env, error) + para_env) ! task lists are now complete, now construct the atom_pairs_send ! and atom_pairs_recv from the tasks lists @@ -1388,18 +1319,16 @@ SUBROUTINE fb_fltrmat_generate_com_pairs_2(filter_mat, & atom_pairs=atom_pairs_send, & natoms_encode=nblkrows_total, & send_or_recv="send", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) CALL fb_com_tasks_build_atom_pairs(com_tasks=com_tasks_recv, & atom_pairs=atom_pairs_recv, & natoms_encode=nblkrows_total, & send_or_recv="recv", & - symmetric=.FALSE., & - error=error) + symmetric=.FALSE.) ! cleanup - CALL fb_com_tasks_release(com_tasks_recv, error) - CALL fb_com_tasks_release(com_tasks_send, error) + CALL fb_com_tasks_release(com_tasks_recv) + CALL fb_com_tasks_release(com_tasks_send) CALL timestop(handle) @@ -1415,21 +1344,18 @@ END SUBROUTINE fb_fltrmat_generate_com_pairs_2 !> \param filter_temp : temperature used to construct the Fermi-Dirac !> filter function !> \param atomic_filter_mat : the atomic filter matrix -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & atomic_S, & fermi_level, & filter_temp, & - atomic_filter_mat, & - error) + atomic_filter_mat) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: atomic_H, atomic_S REAL(KIND=dp), INTENT(IN) :: fermi_level, filter_temp REAL(KIND=dp), DIMENSION(:, :), & INTENT(OUT) :: atomic_filter_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'fb_fltrmat_build_atomic_fltrmat', & @@ -1455,7 +1381,7 @@ SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & check_ok = SIZE(atomic_filter_mat, 1) > 0 .AND. & SIZE(atomic_filter_mat, 2) > 0 - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! initialise atomic_filter_mat = 0.0_dp @@ -1463,16 +1389,16 @@ SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & ! diagonalise using LAPACK ALLOCATE(eigenvalues(mat_dim), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! get optimal work array size ALLOCATE(work(1), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! dsygv will overwrite part of atomic_H and atomic_S, thus need to copy them ALLOCATE(atomic_S_copy(SIZE(atomic_S,1),SIZE(atomic_S,2)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) atomic_S_copy(:,:) = atomic_S(:,:) ALLOCATE(eigenvectors(SIZE(atomic_H,1),SIZE(atomic_H,2)), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) eigenvectors(:,:) = atomic_H(:,:) CALL timeset("fb_atomic_filter_dsygv", handle_dsygv) @@ -1493,9 +1419,9 @@ SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & work_array_size = NINT(work(1)) ! now allocate work array DEALLOCATE(work, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(work(work_array_size), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) work = 0.0_dp ! do calculation atomic_S_copy(:,:) = atomic_S(:,:) @@ -1516,32 +1442,32 @@ SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & ! check if diagonalisation is successful IF (info .NE. 0) THEN WRITE (*,*) "DSYGV ERROR MESSAGE: ", info - CPErrorMessage(cp_failure_level, routineP, "DSYGV failed", error) - CPPrecondition(.FALSE., cp_failure_level, routineP, error, failure) + CPErrorMessage(cp_failure_level, routineP, "DSYGV failed") + CPPrecondition(.FALSE., cp_failure_level, routineP,failure) END IF CALL timestop(handle_dsygv) DEALLOCATE(work, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(atomic_S_copy, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! first get the filter function ALLOCATE(filter_function(mat_dim), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) filter_function = 0.0_dp CALL fb_fltrmat_fermi_dirac_mu(filter_function, & eigenvalues, & filter_temp, & fermi_level) DEALLOCATE(eigenvalues, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! atomic_H has the eigenvectors, construct the version of it ! filtered through the filter function ALLOCATE(filtered_eigenvectors(mat_dim,mat_dim), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO jj = 1, mat_dim DO ii = 1, mat_dim filtered_eigenvectors(ii,jj) = & @@ -1550,7 +1476,7 @@ SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & END DO ! jj DEALLOCATE(filter_function, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL timeset("fb_atomic_filter_dgemm", handle_dgemm) @@ -1571,7 +1497,7 @@ SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & CALL timestop(handle_dgemm) - ! remove small negative terms due to numerical error, the filter + ! remove small negative terms due to numerical the filter ! matrix must not be negative definite DO jj = 1, SIZE(atomic_filter_mat,2) DO ii = 1, SIZE(atomic_filter_mat,1) @@ -1582,9 +1508,9 @@ SUBROUTINE fb_fltrmat_build_atomic_fltrmat(atomic_H, & END DO DEALLOCATE(filtered_eigenvectors, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DEALLOCATE(eigenvectors, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL timestop(handle) diff --git a/src/qs_fb_hash_table_types.F b/src/qs_fb_hash_table_types.F index b08ef6b149..24bda787c5 100644 --- a/src/qs_fb_hash_table_types.F +++ b/src/qs_fb_hash_table_types.F @@ -100,14 +100,12 @@ MODULE qs_fb_hash_table_types !> \param hash_table : the fb_hash_table object !> \param key : key of the element !> \param val : value of the element -!> \param error : CP2K error handler container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - RECURSIVE SUBROUTINE fb_hash_table_add(hash_table, key, val, error) + RECURSIVE SUBROUTINE fb_hash_table_add(hash_table, key, val) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table INTEGER(KIND=int_8), INTENT(IN) :: key INTEGER, INTENT(IN) :: val - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_add', & routineP = moduleN//':'//routineN @@ -117,17 +115,16 @@ RECURSIVE SUBROUTINE fb_hash_table_add(hash_table, key, val, error) failure = .FALSE. check_ok = fb_hash_table_has_data(hash_table) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! check hash table size, if too small rehash in a larger table IF (hash_table%obj%nelements*ENLARGE_RATIO .GE. & hash_table%obj%nmax) THEN CALL fb_hash_table_rehash(hash_table=hash_table, & - nmax=hash_table%obj%nmax*EXPAND_FACTOR, & - error=error) + nmax=hash_table%obj%nmax*EXPAND_FACTOR) END IF ! find the right slot for the given key islot = fb_hash_table_linear_probe(hash_table, key) - CPPostcondition(islot>0, cp_failure_level, routineP, error, failure) + CPPostcondition(islot>0, cp_failure_level, routineP,failure) ! we are adding a new entry only if islot points to an empty slot, ! otherwise just change the val of the existing entry IF (hash_table%obj%table(islot)%key == EMPTY_KEY) THEN @@ -156,13 +153,11 @@ END SUBROUTINE fb_hash_table_associate !> and cannot be UNDEFINED !> \param nmax : total size of the table, optional. If absent default !> size is 1. -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_create(hash_table, nmax, error) + SUBROUTINE fb_hash_table_create(hash_table, nmax) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table INTEGER, INTENT(IN), OPTIONAL :: nmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_create', & routineP = moduleN//':'//routineN @@ -172,9 +167,9 @@ SUBROUTINE fb_hash_table_create(hash_table, nmax, error) failure = .FALSE. check_ok = .NOT. fb_hash_table_has_data(hash_table) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ALLOCATE(hash_table%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(hash_table%obj%table) hash_table%obj%nmax = 0 hash_table%obj%nelements = 0 @@ -182,8 +177,7 @@ SUBROUTINE fb_hash_table_create(hash_table, nmax, error) my_nmax = 1 IF (PRESENT(nmax)) my_nmax = nmax CALL fb_hash_table_init(hash_table=hash_table, & - nmax=my_nmax, & - error=error) + nmax=my_nmax) ! book keeping stuff hash_table%obj%ref_count = 1 hash_table%obj%id_nr = last_fb_hash_table_id + 1 @@ -196,15 +190,13 @@ END SUBROUTINE fb_hash_table_create !> \param key : input key !> \param val : output value, equals to 0 if key not found !> \param found : .TRUE. if key is found, .FALSE. otherwise -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_get(hash_table, key, val, found, error) + SUBROUTINE fb_hash_table_get(hash_table, key, val, found) TYPE(fb_hash_table_obj), INTENT(IN) :: hash_table INTEGER(KIND=int_8), INTENT(IN) :: key INTEGER, INTENT(OUT) :: val LOGICAL, INTENT(OUT) :: found - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_get', & routineP = moduleN//':'//routineN @@ -214,7 +206,7 @@ SUBROUTINE fb_hash_table_get(hash_table, key, val, found, error) failure = .FALSE. check_ok = fb_hash_table_has_data(hash_table) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) found = .FALSE. val = 0 islot = fb_hash_table_linear_probe(hash_table, key) @@ -245,13 +237,11 @@ END FUNCTION fb_hash_table_has_data !> and cannot be UNDEFINED !> \param nmax : new size of the table, optional. If absent use the !> old size -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_init(hash_table, nmax, error) + SUBROUTINE fb_hash_table_init(hash_table, nmax) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table INTEGER, INTENT(IN), OPTIONAL :: nmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_init', & routineP = moduleN//':'//routineN @@ -261,7 +251,7 @@ SUBROUTINE fb_hash_table_init(hash_table, nmax, error) failure = .FALSE. check_ok = fb_hash_table_has_data(hash_table) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) my_nmax = hash_table%obj%nmax IF (PRESENT(nmax)) my_nmax = nmax ! table length should always be power of 2. Find the least @@ -274,13 +264,13 @@ SUBROUTINE fb_hash_table_init(hash_table, nmax, error) IF (ASSOCIATED(hash_table%obj%table)) THEN IF (SIZE(hash_table%obj%table) .NE. my_nmax) THEN DEALLOCATE(hash_table%obj%table, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(hash_table%obj%table(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE ALLOCATE(hash_table%obj%table(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF hash_table%obj%nmax = my_nmax hash_table%obj%prime = fb_hash_table_matching_prime(my_nmax) @@ -308,13 +298,11 @@ END SUBROUTINE fb_hash_table_nullify !> to MAX(nmax, number_of_non_empty_elements). !> \param hash_table : the fb_hash_table object !> \param nmax [OPTIONAL] : maximum size of the rehashed table -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_rehash(hash_table, nmax, error) + SUBROUTINE fb_hash_table_rehash(hash_table, nmax) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table INTEGER, INTENT(IN), OPTIONAL :: nmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_rehash', & routineP = moduleN//':'//routineN @@ -326,7 +314,7 @@ SUBROUTINE fb_hash_table_rehash(hash_table, nmax, error) failure = .FALSE. IF (.NOT. fb_hash_table_has_data(hash_table)) THEN - CALL fb_hash_table_create(hash_table, nmax, error) + CALL fb_hash_table_create(hash_table, nmax) RETURN END IF IF (PRESENT(nmax)) THEN @@ -335,33 +323,29 @@ SUBROUTINE fb_hash_table_rehash(hash_table, nmax, error) my_nmax = hash_table%obj%nmax END IF ALLOCATE(tmp_table(hash_table%obj%nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) tmp_table(:) = hash_table%obj%table(:) - CALL fb_hash_table_release(hash_table, error) + CALL fb_hash_table_release(hash_table) CALL fb_hash_table_create(hash_table=hash_table, & - nmax=my_nmax, & - error=error) + nmax=my_nmax) DO ii = 1, SIZE(tmp_table) IF (tmp_table(ii)%key .NE. EMPTY_KEY) THEN CALL fb_hash_table_add(hash_table=hash_table, & key=tmp_table(ii)%key, & - val=tmp_table(ii)%val, & - error=error) + val=tmp_table(ii)%val) END IF END DO DEALLOCATE(tmp_table, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END SUBROUTINE fb_hash_table_rehash ! ***************************************************************************** !> \brief releases given object !> \param hash_table : the fb_hash_table object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_release(hash_table, error) + SUBROUTINE fb_hash_table_release(hash_table) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_release', & routineP = moduleN//':'//routineN @@ -372,17 +356,17 @@ SUBROUTINE fb_hash_table_release(hash_table, error) failure = .FALSE. IF (ASSOCIATED(hash_table%obj)) THEN check_ok = hash_table%obj%ref_count > 0 - CPPreconditionNoFail(check_ok, cp_failure_level, routineP, error) + CPPreconditionNoFail(check_ok, cp_failure_level, routineP) hash_table%obj%ref_count = hash_table%obj%ref_count - 1 IF (hash_table%obj%ref_count == 0) THEN hash_table%obj%ref_count = 1 IF (ASSOCIATED(hash_table%obj%table)) THEN DEALLOCATE(hash_table%obj%table, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF hash_table%obj%ref_count = 0 DEALLOCATE(hash_table%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(hash_table%obj) @@ -393,13 +377,11 @@ END SUBROUTINE fb_hash_table_release !> \brief Remove element from a table, automatic resize if necessary !> \param hash_table : the fb_hash_table object !> \param key : key of the element to be removed -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_remove(hash_table, key, error) + SUBROUTINE fb_hash_table_remove(hash_table, key) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table INTEGER(KIND=int_8), INTENT(IN) :: key - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_remove', & routineP = moduleN//':'//routineN @@ -409,7 +391,7 @@ SUBROUTINE fb_hash_table_remove(hash_table, key, error) failure = .FALSE. check_ok = fb_hash_table_has_data(hash_table) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) islot = fb_hash_table_linear_probe(hash_table, key) ! we are only removing an entry if the key is found IF (islot > 0) THEN @@ -421,11 +403,9 @@ SUBROUTINE fb_hash_table_remove(hash_table, key, error) IF (hash_table%obj%nelements*REDUCE_RATIO .LT. & hash_table%obj%nmax) THEN CALL fb_hash_table_rehash(hash_table=hash_table, & - nmax=hash_table%obj%nmax/SHRINK_FACTOR, & - error=error) + nmax=hash_table%obj%nmax/SHRINK_FACTOR) ELSE - CALL fb_hash_table_rehash(hash_table=hash_table, & - error=error) + CALL fb_hash_table_rehash(hash_table=hash_table) END IF END IF END IF @@ -434,12 +414,10 @@ END SUBROUTINE fb_hash_table_remove ! ***************************************************************************** !> \brief retains given object !> \param hash_table : the fb_hash_table object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_retain(hash_table, error) + SUBROUTINE fb_hash_table_retain(hash_table) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_retain', & routineP = moduleN//':'//routineN @@ -448,9 +426,9 @@ SUBROUTINE fb_hash_table_retain(hash_table, error) failure = .FALSE. check_ok = ASSOCIATED(hash_table%obj) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = hash_table%obj%ref_count > 0 - CPPreconditionNoFail(check_ok, cp_failure_level, routineP, error) + CPPreconditionNoFail(check_ok, cp_failure_level, routineP) hash_table%obj%ref_count = hash_table%obj%ref_count + 1 END SUBROUTINE fb_hash_table_retain @@ -460,13 +438,11 @@ END SUBROUTINE fb_hash_table_retain !> \param nelements : number of non-empty slots in the table !> \param nmax : maximum number of slots in the table !> \param prime : the prime used in the hash function -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_hash_table_status(hash_table, nelements, nmax, prime, error) + SUBROUTINE fb_hash_table_status(hash_table, nelements, nmax, prime) TYPE(fb_hash_table_obj), INTENT(INOUT) :: hash_table INTEGER, INTENT(OUT), OPTIONAL :: nelements, nmax, prime - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_hash_table_status', & routineP = moduleN//':'//routineN @@ -475,7 +451,7 @@ SUBROUTINE fb_hash_table_status(hash_table, nelements, nmax, prime, error) failure = .FALSE. check_ok = fb_hash_table_has_data(hash_table) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) IF (PRESENT(nelements)) nelements = hash_table%obj%nelements IF (PRESENT(nmax)) nmax = hash_table%obj%nmax IF (PRESENT(prime)) prime = hash_table%obj%prime diff --git a/src/qs_fb_matrix_data_types.F b/src/qs_fb_matrix_data_types.F index 800781ea26..b0fd357afe 100644 --- a/src/qs_fb_matrix_data_types.F +++ b/src/qs_fb_matrix_data_types.F @@ -88,15 +88,13 @@ MODULE qs_fb_matrix_data_types !> \param row : block row index of the matrix block !> \param col : block col index of the matrix block !> \param blk : the matrix block to add -!> \param error : CP2K error handler container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_add(matrix_data, row, col, blk, error) + SUBROUTINE fb_matrix_data_add(matrix_data, row, col, blk) TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_data INTEGER, INTENT(IN) :: row, col REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: blk - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_add', & routineP = moduleN//':'//routineN @@ -108,37 +106,36 @@ SUBROUTINE fb_matrix_data_add(matrix_data, row, col, blk, error) failure = .FALSE. check_ok = fb_matrix_data_has_data(matrix_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ! check if we need to resize the blks array IF (matrix_data%obj%nblks*ENLARGE_RATIO .GE. & matrix_data%obj%nmax) THEN CALL fb_matrix_data_resize(matrix_data, & - matrix_data%obj%nmax*EXPAND_FACTOR, & - error) + matrix_data%obj%nmax*EXPAND_FACTOR) END IF ! assign block, copy blk data instead of associate nrows = SIZE(blk, 1) ncols = SIZE(blk, 2) ! first check if the block already exists in matrix_data pair_ind = fb_matrix_data_encode_pair(row, col, matrix_data%obj%nencode) - CALL fb_hash_table_get(matrix_data%obj%ind, pair_ind, existing_ii, found, error) + CALL fb_hash_table_get(matrix_data%obj%ind, pair_ind, existing_ii, found) IF (found) THEN ! matrix block aready stored, need to to reassign IF (ASSOCIATED(matrix_data%obj%blks(existing_ii)%p)) THEN DEALLOCATE(matrix_data%obj%blks(existing_ii)%p, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ALLOCATE(matrix_data%obj%blks(existing_ii)%p(nrows,ncols), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) matrix_data%obj%blks(existing_ii)%p(:,:) = blk(:,:) ELSE matrix_data%obj%nblks = matrix_data%obj%nblks + 1 ii = matrix_data%obj%nblks ALLOCATE(matrix_data%obj%blks(ii)%p(nrows,ncols), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) matrix_data%obj%blks(ii)%p(:,:) = blk(:,:) ! record blk index in the index table - CALL fb_hash_table_add(matrix_data%obj%ind, pair_ind, ii, error) + CALL fb_hash_table_add(matrix_data%obj%ind, pair_ind, ii) END IF END SUBROUTINE fb_matrix_data_add @@ -161,13 +158,11 @@ END SUBROUTINE fb_matrix_data_associate !> and cannot be UNDEFINED !> \param nmax : max number of matrix blks can be stored !> \param nencode ... -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_create(matrix_data, nmax, nencode, error) + SUBROUTINE fb_matrix_data_create(matrix_data, nmax, nencode) TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_data INTEGER, INTENT(IN) :: nmax, nencode - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_create', & routineP = moduleN//':'//routineN @@ -177,9 +172,9 @@ SUBROUTINE fb_matrix_data_create(matrix_data, nmax, nencode, error) failure = .FALSE. check_ok = .NOT. fb_matrix_data_has_data(matrix_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) ALLOCATE(matrix_data%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) CALL fb_hash_table_nullify(matrix_data%obj%ind) NULLIFY(matrix_data%obj%blks) matrix_data%obj%nmax = 0 @@ -187,8 +182,7 @@ SUBROUTINE fb_matrix_data_create(matrix_data, nmax, nencode, error) matrix_data%obj%nencode = nencode CALL fb_matrix_data_init(matrix_data=matrix_data, & nmax=nmax, & - nencode=nencode, & - error=error) + nencode=nencode) ! book keeping stuff matrix_data%obj%ref_count = 1 matrix_data%obj%id_nr = last_fb_matrix_data_id + 1 @@ -203,15 +197,13 @@ END SUBROUTINE fb_matrix_data_create !> \param blk_p : pointer to the block in the fb_matrix_data object !> \param found : if the requested block exists in the fb_matrix_data !> object -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_get(matrix_data, row, col, blk_p, found, error) + SUBROUTINE fb_matrix_data_get(matrix_data, row, col, blk_p, found) TYPE(fb_matrix_data_obj), INTENT(IN) :: matrix_data INTEGER, INTENT(IN) :: row, col REAL(KIND=dp), DIMENSION(:, :), POINTER :: blk_p LOGICAL, INTENT(OUT) :: found - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_get', & routineP = moduleN//':'//routineN @@ -222,9 +214,9 @@ SUBROUTINE fb_matrix_data_get(matrix_data, row, col, blk_p, found, error) failure = .FALSE. check_ok = fb_matrix_data_has_data(matrix_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) pair_ind = fb_matrix_data_encode_pair(row, col, matrix_data%obj%nencode) - CALL fb_hash_table_get(matrix_data%obj%ind, pair_ind, ind_in_blk, found, error) + CALL fb_hash_table_get(matrix_data%obj%ind, pair_ind, ind_in_blk, found) IF (found) THEN blk_p => matrix_data%obj%blks(ind_in_blk)%p ELSE @@ -253,13 +245,11 @@ END FUNCTION fb_matrix_data_has_data !> to use the existing number of blocks in matrix_data !> \param nencode : integer used to incode (row, col) to a single combined !> index -!> \param error : CP2K data container for error logging !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_init(matrix_data, nmax, nencode, error) + SUBROUTINE fb_matrix_data_init(matrix_data, nmax, nencode) TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_data INTEGER, INTENT(IN), OPTIONAL :: nmax, nencode - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_init', & routineP = moduleN//':'//routineN @@ -269,26 +259,26 @@ SUBROUTINE fb_matrix_data_init(matrix_data, nmax, nencode, error) failure = .FALSE. check_ok = fb_matrix_data_has_data(matrix_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) my_nmax = matrix_data%obj%nmax IF (PRESENT(nmax)) my_nmax = nmax my_nmax = MAX(my_nmax, 1) IF (fb_hash_table_has_data(matrix_data%obj%ind)) THEN - CALL fb_hash_table_release(matrix_data%obj%ind, error) + CALL fb_hash_table_release(matrix_data%obj%ind) END IF - CALL fb_hash_table_create(matrix_data%obj%ind, my_nmax, error) + CALL fb_hash_table_create(matrix_data%obj%ind, my_nmax) IF (ASSOCIATED(matrix_data%obj%blks)) THEN DO ii = 1, SIZE(matrix_data%obj%blks) IF (ASSOCIATED(matrix_data%obj%blks(ii)%p)) THEN DEALLOCATE(matrix_data%obj%blks(ii)%p, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF END DO DEALLOCATE(matrix_data%obj%blks, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ALLOCATE(matrix_data%obj%blks(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) matrix_data%obj%nmax = my_nmax ! nullify matrix blocks DO ii = 1, SIZE(matrix_data%obj%blks) @@ -312,12 +302,10 @@ END SUBROUTINE fb_matrix_data_nullify ! ***************************************************************************** !> \brief releases given object !> \param matrix_data : the fb_matrix_data object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_release(matrix_data, error) + SUBROUTINE fb_matrix_data_release(matrix_data) TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_data - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_release', & routineP = moduleN//':'//routineN @@ -328,26 +316,26 @@ SUBROUTINE fb_matrix_data_release(matrix_data, error) failure = .FALSE. IF (ASSOCIATED(matrix_data%obj)) THEN check_ok = matrix_data%obj%ref_count > 0 - CPPreconditionNoFail(check_ok, cp_failure_level, routineP, error) + CPPreconditionNoFail(check_ok, cp_failure_level, routineP) matrix_data%obj%ref_count = matrix_data%obj%ref_count - 1 IF (matrix_data%obj%ref_count == 0) THEN matrix_data%obj%ref_count = 1 IF (fb_hash_table_has_data(matrix_data%obj%ind)) THEN - CALL fb_hash_table_release(matrix_data%obj%ind, error) + CALL fb_hash_table_release(matrix_data%obj%ind) END IF IF (ASSOCIATED(matrix_data%obj%blks)) THEN DO ii = 1, SIZE(matrix_data%obj%blks) IF (ASSOCIATED(matrix_data%obj%blks(ii)%p)) THEN DEALLOCATE(matrix_data%obj%blks(ii)%p, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF END DO DEALLOCATE(matrix_data%obj%blks, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF matrix_data%obj%ref_count = 0 DEALLOCATE(matrix_data%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(matrix_data%obj) @@ -357,12 +345,10 @@ END SUBROUTINE fb_matrix_data_release ! ***************************************************************************** !> \brief retains given object !> \param matrix_data : the fb_matrix_data object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_retain(matrix_data, error) + SUBROUTINE fb_matrix_data_retain(matrix_data) TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_data - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_retain', & routineP = moduleN//':'//routineN @@ -371,9 +357,9 @@ SUBROUTINE fb_matrix_data_retain(matrix_data, error) failure = .FALSE. check_ok = ASSOCIATED(matrix_data%obj) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) check_ok = matrix_data%obj%ref_count > 0 - CPPreconditionNoFail(check_ok, cp_failure_level, routineP, error) + CPPreconditionNoFail(check_ok, cp_failure_level, routineP) matrix_data%obj%ref_count = matrix_data%obj%ref_count + 1 END SUBROUTINE fb_matrix_data_retain @@ -381,13 +367,11 @@ END SUBROUTINE fb_matrix_data_retain !> \brief Resize a fb_matrix_data object !> \param matrix_data : the fb_matrix_data object !> \param nmax : new maximun size of matrix_data%obj%blks -!> \param error : CP2K error handler container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_resize(matrix_data, nmax, error) + SUBROUTINE fb_matrix_data_resize(matrix_data, nmax) TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_data INTEGER, INTENT(IN) :: nmax - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_resize', & routineP = moduleN//':'//routineN @@ -399,14 +383,14 @@ SUBROUTINE fb_matrix_data_resize(matrix_data, nmax, error) failure = .FALSE. check_ok = fb_matrix_data_has_data(matrix_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) my_nmax = MAX(nmax, matrix_data%obj%nblks) ! resize the blks array, no need to reindex, as blks in the blks ! are always added to the array sequencially, and so their address ! do not change upon resizing. IF (ASSOCIATED(matrix_data%obj%blks)) THEN ALLOCATE(tmp_blks(matrix_data%obj%nblks), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ii = 1, SIZE(tmp_blks) NULLIFY(tmp_blks(ii)%p) END DO @@ -414,9 +398,9 @@ SUBROUTINE fb_matrix_data_resize(matrix_data, nmax, error) tmp_blks(ii)%p => matrix_data%obj%blks(ii)%p END DO DEALLOCATE(matrix_data%obj%blks, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ALLOCATE(matrix_data%obj%blks(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ii = 1, SIZE(matrix_data%obj%blks) NULLIFY(matrix_data%obj%blks(ii)%p) END DO @@ -424,10 +408,10 @@ SUBROUTINE fb_matrix_data_resize(matrix_data, nmax, error) matrix_data%obj%blks(ii)%p => tmp_blks(ii)%p END DO DEALLOCATE(tmp_blks, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ELSE ALLOCATE(matrix_data%obj%blks(my_nmax), STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) DO ii = 1, SIZE(matrix_data%obj%blks) NULLIFY(matrix_data%obj%blks(ii)%p) END DO @@ -443,15 +427,13 @@ END SUBROUTINE fb_matrix_data_resize !> \param nencode : outputs fb_matrix_data%obj%nencode !> \param blk_sizes : blk_sizes(ii,jj) gives size of jj-th dim of the !> ii-th block stored -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_matrix_data_status(matrix_data, nmax, nblks, nencode, blk_sizes, error) + SUBROUTINE fb_matrix_data_status(matrix_data, nmax, nblks, nencode, blk_sizes) TYPE(fb_matrix_data_obj), INTENT(INOUT) :: matrix_data INTEGER, INTENT(OUT), OPTIONAL :: nmax, nblks, nencode INTEGER, DIMENSION(:, :), INTENT(OUT), & OPTIONAL :: blk_sizes - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_status', & routineP = moduleN//':'//routineN @@ -461,14 +443,14 @@ SUBROUTINE fb_matrix_data_status(matrix_data, nmax, nblks, nencode, blk_sizes, e failure = .FALSE. check_ok = fb_matrix_data_has_data(matrix_data) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) IF (PRESENT(nmax)) nmax = matrix_data%obj%nmax IF (PRESENT(nblks)) nblks = matrix_data%obj%nblks IF (PRESENT(nencode)) nencode = matrix_data%obj%nencode IF (PRESENT(blk_sizes)) THEN check_ok = (SIZE(blk_sizes, 1) .GE. matrix_data%obj%nblks .AND. & SIZE(blk_sizes, 2) .GE. 2) - CPPostcondition(check_ok, cp_failure_level, routineP, error, failure) + CPPostcondition(check_ok, cp_failure_level, routineP,failure) blk_sizes(:,:) = 0 DO ii = 1, matrix_data%obj%nblks blk_sizes(ii,1) = SIZE(matrix_data%obj%blks(ii)%p, 1) diff --git a/src/qs_fb_trial_fns_types.F b/src/qs_fb_trial_fns_types.F index 3dcd636413..9d2b004e37 100644 --- a/src/qs_fb_trial_fns_types.F +++ b/src/qs_fb_trial_fns_types.F @@ -63,14 +63,12 @@ MODULE qs_fb_trial_fns_types !> \brief retains given object !> \brief ... !> \param trial_fns : the fb_trial_fns object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_trial_fns_retain(trial_fns, error) + SUBROUTINE fb_trial_fns_retain(trial_fns) ! note INTENT(IN) is okay because the obj pointer contained in the ! obj type will not be changed TYPE(fb_trial_fns_obj), INTENT(IN) :: trial_fns - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_trial_fns_retain', & routineP = moduleN//':'//routineN @@ -78,8 +76,8 @@ SUBROUTINE fb_trial_fns_retain(trial_fns, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP, error, failure) - CPPreconditionNoFail(trial_fns%obj%ref_count>0, cp_failure_level, routineP, error) + CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP,failure) + CPPreconditionNoFail(trial_fns%obj%ref_count>0, cp_failure_level, routineP) trial_fns%obj%ref_count = trial_fns%obj%ref_count + 1 END SUBROUTINE fb_trial_fns_retain @@ -88,12 +86,10 @@ END SUBROUTINE fb_trial_fns_retain !> \brief releases given object !> \brief ... !> \param trial_fns : the fb_trial_fns object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_trial_fns_release(trial_fns, error) + SUBROUTINE fb_trial_fns_release(trial_fns) TYPE(fb_trial_fns_obj), INTENT(INOUT) :: trial_fns - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_trial_fns_release', & routineP = moduleN//':'//routineN @@ -103,21 +99,21 @@ SUBROUTINE fb_trial_fns_release(trial_fns, error) failure = .FALSE. IF (ASSOCIATED(trial_fns%obj)) THEN - CPPreconditionNoFail(trial_fns%obj%ref_count>0, cp_failure_level, routineP, error) + CPPreconditionNoFail(trial_fns%obj%ref_count>0, cp_failure_level, routineP) trial_fns%obj%ref_count = trial_fns%obj%ref_count - 1 IF (trial_fns%obj%ref_count == 0) THEN trial_fns%obj%ref_count = 1 IF (ASSOCIATED(trial_fns%obj%nfunctions)) THEN DEALLOCATE(trial_fns%obj%nfunctions, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF (ASSOCIATED(trial_fns%obj%functions)) THEN DEALLOCATE(trial_fns%obj%functions, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF trial_fns%obj%ref_count = 0 DEALLOCATE(trial_fns%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF ELSE NULLIFY(trial_fns%obj) @@ -178,12 +174,10 @@ END FUNCTION fb_trial_fns_has_data ! ***************************************************************************** !> \brief creates an fb_trial_fns object and initialises it !> \param trial_fns : the fb_trial_fns object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_trial_fns_create(trial_fns, error) + SUBROUTINE fb_trial_fns_create(trial_fns) TYPE(fb_trial_fns_obj), INTENT(INOUT) :: trial_fns - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_trial_fns_create', & routineP = moduleN//':'//routineN @@ -192,9 +186,9 @@ SUBROUTINE fb_trial_fns_create(trial_fns, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(trial_fns%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(.NOT.ASSOCIATED(trial_fns%obj), cp_failure_level, routineP,failure) ALLOCATE(trial_fns%obj, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(trial_fns%obj%nfunctions) NULLIFY(trial_fns%obj%functions) trial_fns%obj%ref_count = 1 @@ -206,12 +200,10 @@ END SUBROUTINE fb_trial_fns_create ! ***************************************************************************** !> \brief initialises an fb_trial_fns object !> \param trial_fns : the fb_trial_fns object in question -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** - SUBROUTINE fb_trial_fns_init(trial_fns, error) + SUBROUTINE fb_trial_fns_init(trial_fns) TYPE(fb_trial_fns_obj), INTENT(INOUT) :: trial_fns - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_trial_fns_init', & routineP = moduleN//':'//routineN @@ -220,16 +212,16 @@ SUBROUTINE fb_trial_fns_init(trial_fns, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP,failure) ! if halo_atoms are associated, then deallocate and de-associate IF (ASSOCIATED(trial_fns%obj%nfunctions)) THEN DEALLOCATE(trial_fns%obj%nfunctions, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(trial_fns%obj%nfunctions) END IF IF (ASSOCIATED(trial_fns%obj%functions)) THEN DEALLOCATE(trial_fns%obj%functions, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) NULLIFY(trial_fns%obj%functions) END IF END SUBROUTINE fb_trial_fns_init @@ -240,18 +232,15 @@ END SUBROUTINE fb_trial_fns_init !> \param trial_fns : the fb_trial_fns object in question !> \param nfunctions : outputs pointer to trial_fns%obj%nfunctions !> \param functions : outputs pointer to trial_fns%obj%functions -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_trial_fns_get(trial_fns, & nfunctions, & - functions, & - error) + functions) TYPE(fb_trial_fns_obj), INTENT(IN) :: trial_fns INTEGER, DIMENSION(:), OPTIONAL, POINTER :: nfunctions INTEGER, DIMENSION(:, :), OPTIONAL, & POINTER :: functions - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_trial_fns_get', & routineP = moduleN//':'//routineN @@ -259,7 +248,7 @@ SUBROUTINE fb_trial_fns_get(trial_fns, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP,failure) IF (PRESENT(nfunctions)) nfunctions => trial_fns%obj%nfunctions IF (PRESENT(functions)) functions => trial_fns%obj%functions END SUBROUTINE fb_trial_fns_get @@ -270,18 +259,15 @@ END SUBROUTINE fb_trial_fns_get !> \param trial_fns : the fb_trial_fns object in question !> \param nfunctions : associates trial_fns%obj%nfunctions to this pointer !> \param functions : associates trial_fns%obj%nfunctions to this pointer -!> \param error : cp2k error container !> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk ! ***************************************************************************** SUBROUTINE fb_trial_fns_set(trial_fns, & nfunctions, & - functions, & - error) + functions) TYPE(fb_trial_fns_obj), INTENT(INOUT) :: trial_fns INTEGER, DIMENSION(:), OPTIONAL, POINTER :: nfunctions INTEGER, DIMENSION(:, :), OPTIONAL, & POINTER :: functions - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fb_trial_fns_set', & routineP = moduleN//':'//routineN @@ -290,18 +276,18 @@ SUBROUTINE fb_trial_fns_set(trial_fns, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(trial_fns%obj), cp_failure_level, routineP,failure) IF (PRESENT(nfunctions)) THEN IF (ASSOCIATED(trial_fns%obj%nfunctions)) THEN DEALLOCATE(trial_fns%obj%nfunctions, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF trial_fns%obj%nfunctions => nfunctions END IF IF (PRESENT(functions)) THEN IF (ASSOCIATED(trial_fns%obj%functions)) THEN DEALLOCATE(trial_fns%obj%functions, STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF trial_fns%obj%functions => functions END IF diff --git a/src/qs_fermi_contact.F b/src/qs_fermi_contact.F index fad73fd0aa..abddcd4145 100644 --- a/src/qs_fermi_contact.F +++ b/src/qs_fermi_contact.F @@ -67,19 +67,17 @@ MODULE qs_fermi_contact !> \param qs_env ... !> \param matrix_fc ... !> \param rc ... -!> \param error ... !> \date 27.02.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** - SUBROUTINE build_fermi_contact_matrix(qs_env,matrix_fc,rc,error) + SUBROUTINE build_fermi_contact_matrix(qs_env,matrix_fc,rc) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_fc REAL(dp), DIMENSION(3), INTENT(IN) :: rc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_fermi_contact_matrix', & routineP = moduleN//':'//routineN @@ -122,15 +120,14 @@ SUBROUTINE build_fermi_contact_matrix(qs_env,matrix_fc,rc,error) NULLIFY(cell,sab_orb,qs_kind_set,particle_set,para_env) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& particle_set=particle_set,& para_env=para_env,& sab_orb=sab_orb,& - cell=cell,& - error=error) + cell=cell) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -140,7 +137,7 @@ SUBROUTINE build_fermi_contact_matrix(qs_env,matrix_fc,rc,error) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxco,& maxlgto=maxlgto,& - maxsgf=maxsgf, error=error) + maxsgf=maxsgf) ldai = ncoset(maxlgto) CALL init_orbital_pointers(ldai) @@ -166,7 +163,7 @@ SUBROUTINE build_fermi_contact_matrix(qs_env,matrix_fc,rc,error) "basis_set_list",nkind) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -307,14 +304,14 @@ SUBROUTINE build_fermi_contact_matrix(qs_env,matrix_fc,rc,error) ! *** Print the Fermi contact matrix, if requested *** IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/FERMI_CONTACT",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/FERMI_CONTACT"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/FERMI_CONTACT",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL cp_dbcsr_write_sparse_matrix(matrix_fc(1)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) + CALL cp_dbcsr_write_sparse_matrix(matrix_fc(1)%matrix,4,after,qs_env,para_env,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/FERMI_CONTACT", error=error) + "DFT%PRINT%AO_MATRICES/FERMI_CONTACT") END IF CALL timestop(handle) diff --git a/src/qs_force.F b/src/qs_force.F index dc921d9f4b..0a93337b20 100644 --- a/src/qs_force.F +++ b/src/qs_force.F @@ -100,40 +100,36 @@ MODULE qs_force !> \param calc_force ... !> \param consistent_energies ... !> \param linres ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_calc_energy_force(qs_env,calc_force,consistent_energies,linres,error) + SUBROUTINE qs_calc_energy_force(qs_env,calc_force,consistent_energies,linres) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL :: calc_force, & consistent_energies, linres - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_calc_energy_force', & routineP = moduleN//':'//routineN qs_env%linres_run = linres - CALL set_qs_env(qs_env,error=error) + CALL set_qs_env(qs_env) IF (calc_force) THEN - CALL qs_forces(qs_env, error=error) + CALL qs_forces(qs_env) ELSE CALL qs_energies(qs_env, calc_forces=.FALSE.,& - consistent_energies=consistent_energies, error=error) + consistent_energies=consistent_energies) END IF - CALL get_qs_env(qs_env,error=error) + CALL get_qs_env(qs_env) END SUBROUTINE qs_calc_energy_force ! ***************************************************************************** !> \brief Calculate the Quickstep forces. !> \param qs_env ... -!> \param error ... !> \date 29.10.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE qs_forces(qs_env,error) + SUBROUTINE qs_forces(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_forces', & routineP = moduleN//':'//routineN @@ -174,13 +170,13 @@ SUBROUTINE qs_forces(qs_env,error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! rebuild plane wave environment - CALL qs_env_rebuild_pw_env(qs_env,error) + CALL qs_env_rebuild_pw_env(qs_env) ! zero out the forces in particle set - CALL get_qs_env(qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env,particle_set=particle_set) natom = SIZE(particle_set) DO iatom=1,natom particle_set(iatom)%f=0.0_dp @@ -188,9 +184,9 @@ SUBROUTINE qs_forces(qs_env,error) ! get atom mapping NULLIFY (atomic_kind_set) - CALL get_qs_env(qs_env,atomic_kind_set=atomic_kind_set,error=error) + CALL get_qs_env(qs_env,atomic_kind_set=atomic_kind_set) ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind,& kind_of=kind_of) @@ -198,30 +194,28 @@ SUBROUTINE qs_forces(qs_env,error) NULLIFY (force,subsys) CALL get_qs_env(qs_env,& force=force,& - subsys=subsys,& - error=error) + subsys=subsys) IF (.NOT.ASSOCIATED(force)) THEN ! *** Allocate the force data structure *** nkind = SIZE(atomic_kind_set) ALLOCATE (natom_of_kind(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& natom_of_kind=natom_of_kind) - CALL allocate_qs_force(force,natom_of_kind,error) + CALL allocate_qs_force(force,natom_of_kind) DEALLOCATE (natom_of_kind,STAT=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) - CALL qs_subsys_set(subsys,force=force,error=error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) + CALL qs_subsys_set(subsys,force=force) END IF - CALL zero_qs_force(force,error) + CALL zero_qs_force(force) ! recalculate energy with forces - CALL qs_energies(qs_env,calc_forces=.TRUE.,error=error) + CALL qs_energies(qs_env,calc_forces=.TRUE.) NULLIFY (dft_control,para_env) CALL get_qs_env(qs_env,& dft_control=dft_control,& - para_env=para_env,& - error=error) + para_env=para_env) ! Now we handle some special cases ! Maybe some of these would be better dealt with in qs_energies? @@ -230,20 +224,19 @@ SUBROUTINE qs_forces(qs_env,error) CALL get_qs_env(qs_env,& ks_env=ks_env,& matrix_w=matrix_w,& - matrix_s=matrix_s,& - error=error) - CALL cp_dbcsr_allocate_matrix_set(matrix_w,dft_control%nspins,error=error) + matrix_s=matrix_s) + CALL cp_dbcsr_allocate_matrix_set(matrix_w,dft_control%nspins) DO ispin=1,dft_control%nspins ALLOCATE(matrix_w(ispin)%matrix) - CALL cp_dbcsr_init(matrix_w(ispin)%matrix,error=error) + CALL cp_dbcsr_init(matrix_w(ispin)%matrix) CALL cp_dbcsr_copy(matrix_w(ispin)%matrix,matrix_s(1)%matrix,& - name="W MATRIX",error=error) - CALL cp_dbcsr_set(matrix_w(ispin)%matrix,0.0_dp,error=error) + name="W MATRIX") + CALL cp_dbcsr_set(matrix_w(ispin)%matrix,0.0_dp) END DO - CALL set_ks_env(ks_env,matrix_w=matrix_w,error=error) + CALL set_ks_env(ks_env,matrix_w=matrix_w) - CALL calc_c_mat_force(qs_env,error) - IF(dft_control%do_admm) CALL rt_admm_force(qs_env,error) + CALL calc_c_mat_force(qs_env) + IF(dft_control%do_admm) CALL rt_admm_force(qs_env) END IF ! from an eventual Mulliken restraint IF (dft_control%qs_control%mulliken_restraint) THEN @@ -251,40 +244,39 @@ SUBROUTINE qs_forces(qs_env,error) CALL get_qs_env(qs_env,& matrix_w=matrix_w,& matrix_s=matrix_s,& - rho=rho,& - error=error) + rho=rho) NULLIFY (rho_ao) - CALL qs_rho_get(rho,rho_ao=rho_ao,error=error) + CALL qs_rho_get(rho,rho_ao=rho_ao) CALL mulliken_restraint(dft_control%qs_control%mulliken_restraint_control, & - para_env,matrix_s(1)%matrix,rho_ao,w_matrix=matrix_w,error=error) + para_env,matrix_s(1)%matrix,rho_ao,w_matrix=matrix_w) END IF ! Add non-Pulay contribution of DFT+U to W matrix, since it has also to be ! digested with overlap matrix derivatives IF (dft_control%dft_plus_u) THEN NULLIFY(matrix_w) - CALL get_qs_env(qs_env,matrix_w=matrix_w,error=error) - CALL plus_u(qs_env=qs_env,matrix_w=matrix_w,error=error) + CALL get_qs_env(qs_env,matrix_w=matrix_w) + CALL plus_u(qs_env=qs_env,matrix_w=matrix_w) END IF ! Write W Matrix to output (if requested) - CALL get_qs_env(qs_env,has_unit_metric=has_unit_metric,error=error) + CALL get_qs_env(qs_env,has_unit_metric=has_unit_metric) IF (.NOT.has_unit_metric) THEN NULLIFY(matrix_w_kp) - CALL get_qs_env(qs_env,matrix_w_kp=matrix_w_kp,error=error) + CALL get_qs_env(qs_env,matrix_w_kp=matrix_w_kp) nspin = SIZE(matrix_w_kp,1) DO ispin=1,nspin IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/W_MATRIX",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) DO ic=1,SIZE(matrix_w_kp,2) CALL cp_dbcsr_write_sparse_matrix(matrix_w_kp(ispin,ic)%matrix,4,after,qs_env,& - para_env,output_unit=iw,error=error) + para_env,output_unit=iw) END DO CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/W_MATRIX", error=error) + "DFT%PRINT%AO_MATRICES/W_MATRIX") END IF END DO ENDIF @@ -292,32 +284,31 @@ SUBROUTINE qs_forces(qs_env,error) ! Compute core forces (also overwrites matrix_w) IF (dft_control%qs_control%semi_empirical) THEN CALL build_se_core_matrix(qs_env=qs_env,para_env=para_env,& - calculate_forces=.TRUE.,error=error) - CALL se_core_core_interaction(qs_env,para_env,calculate_forces=.TRUE.,& - error=error) + calculate_forces=.TRUE.) + CALL se_core_core_interaction(qs_env,para_env,calculate_forces=.TRUE.) ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_matrices(qs_env=qs_env,para_env=para_env,& - calculate_forces=.TRUE.,error=error) + calculate_forces=.TRUE.) CALL calculate_dftb_dispersion(qs_env=qs_env,para_env=para_env,& - calculate_forces=.TRUE.,error=error) + calculate_forces=.TRUE.) ELSEIF (dft_control%qs_control%scptb) THEN - CALL build_scptb_core_matrix(qs_env=qs_env,calculate_forces=.TRUE.,error=error) - CALL scptb_core_interaction(qs_env,calculate_forces=.TRUE.,error=error) + CALL build_scptb_core_matrix(qs_env=qs_env,calculate_forces=.TRUE.) + CALL scptb_core_interaction(qs_env,calculate_forces=.TRUE.) ELSE - CALL build_core_hamiltonian_matrix(qs_env=qs_env,calculate_forces=.TRUE.,error=error) - CALL calculate_ecore_self(qs_env,error=error) - CALL calculate_ecore_overlap(qs_env,para_env,calculate_forces=.TRUE.,error=error) - CALL calculate_ecore_efield(qs_env,calculate_forces=.TRUE.,error=error) + CALL build_core_hamiltonian_matrix(qs_env=qs_env,calculate_forces=.TRUE.) + CALL calculate_ecore_self(qs_env) + CALL calculate_ecore_overlap(qs_env,para_env,calculate_forces=.TRUE.) + CALL calculate_ecore_efield(qs_env,calculate_forces=.TRUE.) !swap external_e_potential before external_c_potential, to ensure !that external potential on grid is loaded before calculating energy of cores - CALL external_e_potential(qs_env,error) + CALL external_e_potential(qs_env) IF (.NOT. dft_control%qs_control%gapw ) THEN - CALL external_c_potential(qs_env,calculate_forces=.TRUE.,error=error) + CALL external_c_potential(qs_env,calculate_forces=.TRUE.) END IF END IF ! Compute grid-based forces - CALL qs_ks_update_qs_env(qs_env,calculate_forces=.TRUE.,error=error) + CALL qs_ks_update_qs_env(qs_env,calculate_forces=.TRUE.) ! MP2 Code IF(ASSOCIATED(qs_env%mp2_env)) THEN @@ -327,29 +318,27 @@ SUBROUTINE qs_forces(qs_env,error) matrix_w_mp2=matrix_w_mp2,& ks_env=ks_env,& rho=rho,& - energy=energy,& - error=error) + energy=energy) NULLIFY (rho_ao) - CALL qs_rho_get(rho,rho_ao=rho_ao,error=error) + CALL qs_rho_get(rho,rho_ao=rho_ao) ! with MP2 we have to recalculate the SCF energy with the ! correct density DO ispin=1,dft_control%nspins - CALL cp_dbcsr_add(rho_ao(ispin)%matrix,matrix_p_mp2(ispin)%matrix,1.0_dp,-1.0_dp,error) + CALL cp_dbcsr_add(rho_ao(ispin)%matrix,matrix_p_mp2(ispin)%matrix,1.0_dp,-1.0_dp) END DO - CALL qs_rho_update_rho(rho,qs_env=qs_env,error=error) - CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.,error=error) - CALL qs_ks_update_qs_env(qs_env,just_energy=.TRUE.,error=error) + CALL qs_rho_update_rho(rho,qs_env=qs_env) + CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.) + CALL qs_ks_update_qs_env(qs_env,just_energy=.TRUE.) energy%total = energy%total + energy%mp2 ! deallocate mp2_W - CALL cp_dbcsr_deallocate_matrix_set(matrix_w_mp2,error=error) - CALL set_ks_env(ks_env,matrix_w_mp2=Null(),error=error) + CALL cp_dbcsr_deallocate_matrix_set(matrix_w_mp2) + CALL set_ks_env(ks_env,matrix_w_mp2=Null()) END IF ! Add forces resulting from wavefunction fitting IF (dft_control%do_admm_dm) THEN CALL cp_unimplemented_error(fromWhere=routineP, & - message="Forces with ADMM DM methods not implemented", & - error=error) + message="Forces with ADMM DM methods not implemented") END IF IF (dft_control%do_admm_mo.AND..NOT.qs_env%run_rtp ) THEN NULLIFY(matrix_s_aux_fit,matrix_s_aux_fit_vs_orb,matrix_ks_aux_fit,& @@ -360,8 +349,7 @@ SUBROUTINE qs_forces(qs_env,error) matrix_ks_aux_fit=matrix_ks_aux_fit,& mos_aux_fit=mos_aux_fit,& mos=mos,& - admm_env=admm_env,& - error=error) + admm_env=admm_env) DO ispin=1,dft_control%nspins mo_set => mos(ispin)%mo_set CALL get_mo_set(mo_set=mo_set,mo_coeff=mo_coeff) @@ -369,10 +357,10 @@ SUBROUTINE qs_forces(qs_env,error) IF (admm_env%purification_method==do_admm_purify_none) THEN CALL get_mo_set(mo_set=mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) CALL calc_aux_mo_derivs_none(ispin, qs_env%admm_env, mo_set, & - mo_coeff_aux_fit, matrix_ks_aux_fit, error=error) + mo_coeff_aux_fit, matrix_ks_aux_fit) END IF END DO - CALL calc_mixed_overlap_force(qs_env, error) + CALL calc_mixed_overlap_force(qs_env) END IF ! *** replicate forces *** @@ -436,7 +424,7 @@ SUBROUTINE qs_forces(qs_env,error) END DO NULLIFY(virial,energy) - CALL get_qs_env(qs_env=qs_env,virial=virial,energy=energy,error=error) + CALL get_qs_env(qs_env=qs_env,virial=virial,energy=energy) ! *** distribute virial *** IF (virial%pv_availability) THEN CALL mp_sum(virial%pv_virial,para_env%group) @@ -459,37 +447,37 @@ SUBROUTINE qs_forces(qs_env,error) END IF output_unit = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%DERIVATIVES",& - extension=".Log",error=error) - print_section => section_vals_get_subs_vals(qs_env%input,"DFT%PRINT%DERIVATIVES",error=error) + extension=".Log") + print_section => section_vals_get_subs_vals(qs_env%input,"DFT%PRINT%DERIVATIVES") IF (dft_control%qs_control%semi_empirical) THEN CALL write_forces(force,atomic_kind_set,2,output_unit=output_unit,& - print_section=print_section,error=error) + print_section=print_section) ELSE IF (dft_control%qs_control%dftb) THEN CALL write_forces(force,atomic_kind_set,4,output_unit=output_unit,& - print_section=print_section,error=error) + print_section=print_section) ELSE IF (dft_control%qs_control%gapw) THEN CALL write_forces(force,atomic_kind_set,1,output_unit=output_unit,& - print_section=print_section,error=error) + print_section=print_section) ELSE IF (dft_control%qs_control%scptb) THEN CALL write_forces(force,atomic_kind_set,5,output_unit=output_unit,& - print_section=print_section,error=error) + print_section=print_section) ELSE CALL write_forces(force,atomic_kind_set,0,output_unit=output_unit,& - print_section=print_section,error=error) + print_section=print_section) END IF CALL cp_print_key_finished_output(output_unit,logger,qs_env%input,& - "DFT%PRINT%DERIVATIVES",error=error) + "DFT%PRINT%DERIVATIVES") ! deallocate W Matrix: NULLIFY(ks_env,matrix_w_kp) CALL get_qs_env(qs_env=qs_env,& matrix_w_kp=matrix_w_kp,& - ks_env=ks_env,error=error) - CALL cp_dbcsr_deallocate_matrix_set(matrix_w_kp,error=error) - CALL set_ks_env(ks_env,matrix_w=Null(),matrix_w_kp=Null(),error=error) + ks_env=ks_env) + CALL cp_dbcsr_deallocate_matrix_set(matrix_w_kp) + CALL set_ks_env(ks_env,matrix_w=Null(),matrix_w_kp=Null()) DEALLOCATE (atom_of_kind,kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -502,13 +490,12 @@ END SUBROUTINE qs_forces !> \param ftype ... !> \param output_unit ... !> \param print_section ... -!> \param error ... !> \date 05.06.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** SUBROUTINE write_forces(qs_force,atomic_kind_set,ftype,output_unit,& - print_section, error) + print_section) TYPE(qs_force_type), DIMENSION(:), & POINTER :: qs_force @@ -516,7 +503,6 @@ SUBROUTINE write_forces(qs_force,atomic_kind_set,ftype,output_unit,& POINTER :: atomic_kind_set INTEGER, INTENT(IN) :: ftype, output_unit TYPE(section_vals_type), POINTER :: print_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_forces', & routineP = moduleN//':'//routineN @@ -553,7 +539,7 @@ SUBROUTINE write_forces(qs_force,atomic_kind_set,ftype,output_unit,& ! Variable precision output of the forces CALL section_vals_val_get(print_section,"NDIGITS",& - i_val=ndigits,error=error) + i_val=ndigits) fmtstr1 = "(/,/,T2,A,/,/,T3,A,T11,A,T23,A,T40,A1,2( X,A1))" WRITE (UNIT=fmtstr1(41:42),FMT="(I2)") ndigits + 5 diff --git a/src/qs_force_types.F b/src/qs_force_types.F index fc6758ae0b..f637f14327 100644 --- a/src/qs_force_types.F +++ b/src/qs_force_types.F @@ -60,17 +60,15 @@ MODULE qs_force_types !> \brief Allocate a Quickstep force data structure. !> \param qs_force ... !> \param natom_of_kind ... -!> \param error ... !> \date 05.06.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_qs_force(qs_force,natom_of_kind,error) + SUBROUTINE allocate_qs_force(qs_force,natom_of_kind) TYPE(qs_force_type), DIMENSION(:), & POINTER :: qs_force INTEGER, DIMENSION(:), INTENT(IN) :: natom_of_kind - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_qs_force', & routineP = moduleN//':'//routineN @@ -79,65 +77,65 @@ SUBROUTINE allocate_qs_force(qs_force,natom_of_kind,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(qs_force)) CALL deallocate_qs_force(qs_force,error) + IF (ASSOCIATED(qs_force)) CALL deallocate_qs_force(qs_force) nkind = SIZE(natom_of_kind) ALLOCATE (qs_force(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind n = natom_of_kind(ikind) ALLOCATE (qs_force(ikind)%all_potential(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%core_overlap(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%gth_ppl(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%gth_nlcc(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%gth_ppnl(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%kinetic(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%overlap(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%overlap_admm(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%rho_core(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%rho_elec(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%rho_lri_elec(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%vhxc_atom(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%g0s_Vh_elec(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%repulsive(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%dispersion(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%other(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%ch_pulay(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%ehrenfest(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%efield(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%eev(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Always initialize ch_pulay to zero.. qs_force(ikind)%ch_pulay = 0.0_dp ALLOCATE (qs_force(ikind)%fock_4c(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%mp2_sep(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%mp2_non_sep(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (qs_force(ikind)%total(3,n),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO END SUBROUTINE allocate_qs_force @@ -145,16 +143,14 @@ END SUBROUTINE allocate_qs_force ! ***************************************************************************** !> \brief Deallocate a Quickstep force data structure. !> \param qs_force ... -!> \param error ... !> \date 05.06.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_qs_force(qs_force,error) + SUBROUTINE deallocate_qs_force(qs_force) TYPE(qs_force_type), DIMENSION(:), & POINTER :: qs_force - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_qs_force', & routineP = moduleN//':'//routineN @@ -163,7 +159,7 @@ SUBROUTINE deallocate_qs_force(qs_force,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_force),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_force),cp_failure_level,routineP,failure) nkind = SIZE(qs_force) @@ -171,142 +167,140 @@ SUBROUTINE deallocate_qs_force(qs_force,error) IF (ASSOCIATED(qs_force(ikind)%all_potential)) THEN DEALLOCATE (qs_force(ikind)%all_potential,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%core_overlap)) THEN DEALLOCATE (qs_force(ikind)%core_overlap,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%gth_ppl)) THEN DEALLOCATE (qs_force(ikind)%gth_ppl,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%gth_nlcc)) THEN DEALLOCATE (qs_force(ikind)%gth_nlcc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%gth_ppnl)) THEN DEALLOCATE (qs_force(ikind)%gth_ppnl,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%kinetic)) THEN DEALLOCATE (qs_force(ikind)%kinetic,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%overlap)) THEN DEALLOCATE (qs_force(ikind)%overlap,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%overlap_admm)) THEN DEALLOCATE (qs_force(ikind)%overlap_admm,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%rho_core)) THEN DEALLOCATE (qs_force(ikind)%rho_core,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%rho_elec)) THEN DEALLOCATE (qs_force(ikind)%rho_elec,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%rho_lri_elec)) THEN DEALLOCATE (qs_force(ikind)%rho_lri_elec,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%vhxc_atom)) THEN DEALLOCATE (qs_force(ikind)%vhxc_atom,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%g0s_Vh_elec)) THEN DEALLOCATE (qs_force(ikind)%g0s_Vh_elec,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%repulsive)) THEN DEALLOCATE (qs_force(ikind)%repulsive,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%dispersion)) THEN DEALLOCATE (qs_force(ikind)%dispersion,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%other)) THEN DEALLOCATE (qs_force(ikind)%other,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%total)) THEN DEALLOCATE (qs_force(ikind)%total,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%ch_pulay)) THEN DEALLOCATE (qs_force(ikind)%ch_pulay,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%fock_4c)) THEN DEALLOCATE (qs_force(ikind)%fock_4c,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%mp2_sep)) THEN DEALLOCATE (qs_force(ikind)%mp2_sep,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%mp2_non_sep)) THEN DEALLOCATE (qs_force(ikind)%mp2_non_sep,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%ehrenfest)) THEN DEALLOCATE (qs_force(ikind)%ehrenfest,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%efield)) THEN DEALLOCATE (qs_force(ikind)%efield,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_force(ikind)%eev)) THEN DEALLOCATE (qs_force(ikind)%eev,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (qs_force,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_qs_force ! ***************************************************************************** !> \brief Initialize a Quickstep force data structure. !> \param qs_force ... -!> \param error ... !> \date 15.07.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE zero_qs_force(qs_force,error) + SUBROUTINE zero_qs_force(qs_force) TYPE(qs_force_type), DIMENSION(:), & POINTER :: qs_force - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'zero_qs_force', & routineP = moduleN//':'//routineN @@ -315,7 +309,7 @@ SUBROUTINE zero_qs_force(qs_force,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_force),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_force),cp_failure_level,routineP,failure) DO ikind=1,SIZE(qs_force) qs_force(ikind)%all_potential(:,:) = 0.0_dp @@ -351,12 +345,11 @@ END SUBROUTINE zero_qs_force !> \param qs_force The force type variable to be used !> \param forcetype ... !> \param atomic_kind_set ... -!> \param error ... !> \par History !> 07.2014 JGH !> \author JGH ! ***************************************************************************** - SUBROUTINE add_qs_force(force, qs_force, forcetype, atomic_kind_set, error) + SUBROUTINE add_qs_force(force, qs_force, forcetype, atomic_kind_set) REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN) :: force @@ -365,7 +358,6 @@ SUBROUTINE add_qs_force(force, qs_force, forcetype, atomic_kind_set, error) CHARACTER(LEN=*), INTENT(IN) :: forcetype TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_qs_force', & routineP = moduleN//':'//routineN @@ -377,7 +369,7 @@ SUBROUTINE add_qs_force(force, qs_force, forcetype, atomic_kind_set, error) ! ------------------------------------------------------------------------ failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_force),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_force),cp_failure_level,routineP,failure) SELECT CASE (forcetype) CASE ("overlap_admm") @@ -390,7 +382,7 @@ SUBROUTINE add_qs_force(force, qs_force, forcetype, atomic_kind_set, error) END DO END DO CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE add_qs_force diff --git a/src/qs_gapw_densities.F b/src/qs_gapw_densities.F index 7ef5d6063b..fe35476747 100644 --- a/src/qs_gapw_densities.F +++ b/src/qs_gapw_densities.F @@ -45,14 +45,12 @@ MODULE qs_gapw_densities !> \param qs_env ... !> \param local_rho_set ... !> \param do_rho0 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0,error) + SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0) TYPE(qs_environment_type), POINTER :: qs_env TYPE(local_rho_type), OPTIONAL, POINTER :: local_rho_set LOGICAL, INTENT(IN), OPTIONAL :: do_rho0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'prepare_gapw_den', & routineP = moduleN//':'//routineN @@ -101,7 +99,7 @@ SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0,error) my_do_rho0 = .TRUE. IF (PRESENT(do_rho0)) my_do_rho0 = do_rho0 - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,& @@ -111,7 +109,7 @@ SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0,error) atomic_kind_set=atomic_kind_set,& rho0_mpole=rho0_mpole,& rho_atom_set=rho_atom_set,& - rho0_atom_set=rho0_atom_set,error=error) + rho0_atom_set=rho0_atom_set) gapw_control => dft_control%qs_control%gapw_control @@ -127,7 +125,7 @@ SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0,error) rho0_h_tot = 0.0_dp ALLOCATE(rho1_h_tot(1:nspins), rho1_s_tot(1:nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rho1_h_tot = 0.0_dp rho1_s_tot = 0.0_dp @@ -135,18 +133,18 @@ SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0,error) NULLIFY(grid_atom,harmonics) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list,natom=natom) CALL get_qs_kind(qs_kind_set(ikind), grid_atom=grid_atom,& - paw_atom=paw_atom, harmonics=harmonics, error=error) + paw_atom=paw_atom, harmonics=harmonics) ! Calculate rho1_h and rho1_s on the radial grids centered on the atomic position IF(paw_atom) & CALL calculate_rho_atom(para_env,rho_atom_set,qs_kind_set(ikind),& - atom_list,grid_atom,natom,nspins,rho1_h_tot,rho1_s_tot,error=error) + atom_list,grid_atom,natom,nspins,rho1_h_tot,rho1_s_tot) ! Calculate rho0_h and rho0_s on the radial grids centered on the atomic position IF (my_do_rho0) & CALL calculate_rho0_atom(gapw_control,rho_atom_set,rho0_atom_set,rho0_mpole,& atom_list,grid_atom, paw_atom,natom,ikind,qs_kind_set(ikind),& - harmonics,rho0_h_tot, error=error) + harmonics,rho0_h_tot) ENDDO @@ -160,7 +158,7 @@ SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0,error) IF (my_do_rho0) THEN rho0_mpole%total_rho0_h = -rho0_h_tot ! Put the rho0_soft on the global grid - CALL put_rho0_on_grid(qs_env,rho0_mpole,tot_rs_int,error) + CALL put_rho0_on_grid(qs_env,rho0_mpole,tot_rs_int) IF(ABS(rho0_h_tot) .GE. 1.0E-5_dp)THEN IF(ABS(1.0_dp-ABS(tot_rs_int/rho0_h_tot)).GT.1.0E-3_dp) THEN IF (output_unit>0) THEN @@ -181,7 +179,7 @@ SUBROUTINE prepare_gapw_den(qs_env,local_rho_set,do_rho0,error) END IF DEALLOCATE(rho1_h_tot,rho1_s_tot,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/qs_grid_atom.F b/src/qs_grid_atom.F index 18cbda9633..a96f871668 100644 --- a/src/qs_grid_atom.F +++ b/src/qs_grid_atom.F @@ -47,16 +47,14 @@ MODULE qs_grid_atom ! ***************************************************************************** !> \brief Deallocate a Gaussian-type orbital (GTO) basis set data set. !> \param grid_atom ... -!> \param error ... !> \date 03.11.2000 !> \author MK !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_grid_atom(grid_atom,error) + SUBROUTINE allocate_grid_atom(grid_atom) TYPE(grid_atom_type), POINTER :: grid_atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_grid_atom', & routineP = moduleN//':'//routineN @@ -66,10 +64,10 @@ SUBROUTINE allocate_grid_atom(grid_atom,error) failure = .FALSE. - IF (ASSOCIATED(grid_atom)) CALL deallocate_grid_atom(grid_atom,error) + IF (ASSOCIATED(grid_atom)) CALL deallocate_grid_atom(grid_atom) ALLOCATE (grid_atom,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (grid_atom%rad) NULLIFY (grid_atom%rad2) @@ -92,14 +90,12 @@ END SUBROUTINE allocate_grid_atom ! ***************************************************************************** !> \brief Deallocate a Gaussian-type orbital (GTO) basis set data set. !> \param grid_atom ... -!> \param error ... !> \date 03.11.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_grid_atom(grid_atom,error) + SUBROUTINE deallocate_grid_atom(grid_atom) TYPE(grid_atom_type), POINTER :: grid_atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_grid_atom', & routineP = moduleN//':'//routineN @@ -112,81 +108,81 @@ SUBROUTINE deallocate_grid_atom(grid_atom,error) IF (ASSOCIATED(grid_atom%rad)) THEN DEALLOCATE (grid_atom%rad,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%rad2)) THEN DEALLOCATE (grid_atom%rad2,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%wr)) THEN DEALLOCATE (grid_atom%wr,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%wa)) THEN DEALLOCATE (grid_atom%wa,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%weight)) THEN DEALLOCATE (grid_atom%weight,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%azi)) THEN DEALLOCATE (grid_atom%azi,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%cos_azi)) THEN DEALLOCATE (grid_atom%cos_azi,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%sin_azi)) THEN DEALLOCATE (grid_atom%sin_azi,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%cotan_azi)) THEN DEALLOCATE (grid_atom%cotan_azi,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%pol)) THEN DEALLOCATE (grid_atom%pol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%cos_pol)) THEN DEALLOCATE (grid_atom%cos_pol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%sin_pol)) THEN DEALLOCATE (grid_atom%sin_pol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%usin_pol)) THEN DEALLOCATE (grid_atom%usin_pol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%rad2l)) THEN DEALLOCATE (grid_atom%rad2l,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(grid_atom%oorad2l)) THEN DEALLOCATE (grid_atom%oorad2l,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (grid_atom,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer grid_atom is not associated and "//& diff --git a/src/qs_gspace_mixing.F b/src/qs_gspace_mixing.F index 6329b9eb89..6552d493d1 100644 --- a/src/qs_gspace_mixing.F +++ b/src/qs_gspace_mixing.F @@ -72,16 +72,14 @@ MODULE qs_gspace_mixing !> \param para_env ... !> \param p_out ... !> \param delta ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE self_consistency_check(rho_ao,p_delta,para_env,p_out,delta,error) + SUBROUTINE self_consistency_check(rho_ao,p_delta,para_env,p_out,delta) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: rho_ao, p_delta TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: p_out REAL(KIND=dp), INTENT(INOUT) :: delta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'self_consistency_check', & routineP = moduleN//':'//routineN @@ -98,7 +96,7 @@ SUBROUTINE self_consistency_check(rho_ao,p_delta,para_env,p_out,delta,error) NULLIFY(matrix_q, p_in) failure = .FALSE. - CPPrecondition(ASSOCIATED(p_out),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_out),cp_failure_level,routineP,failure) NULLIFY(matrix_q, p_in) p_in => rho_ao matrix_q => p_delta @@ -109,10 +107,10 @@ SUBROUTINE self_consistency_check(rho_ao,p_delta,para_env,p_out,delta,error) delta = 0.0_dp DO ispin=1, nspins DO ic=1, nimg - CALL cp_dbcsr_set(matrix_q(ispin,ic)%matrix, 0.0_dp, error=error) + CALL cp_dbcsr_set(matrix_q(ispin,ic)%matrix, 0.0_dp) CALL cp_sm_mix(m1=p_out(ispin,ic)%matrix,m2=p_in(ispin,ic)%matrix,& p_mix=1.0_dp,delta=tmp, para_env=para_env,& - m3=matrix_q(ispin,ic)%matrix,error=error) + m3=matrix_q(ispin,ic)%matrix) delta = MAX(tmp,delta) END DO END DO @@ -129,21 +127,19 @@ END SUBROUTINE self_consistency_check !> \param rho ... !> \param para_env ... !> \param iter_count ... -!> \param error ... !> \par History !> 05.2009 !> 02.2015 changed input to make g-space mixing available in linear scaling !> SCF [Patrick Seewald] !> \author MI ! ***************************************************************************** - SUBROUTINE gspace_mixing(qs_env, mixing_method, mixing_store, rho, para_env, iter_count, error) + SUBROUTINE gspace_mixing(qs_env, mixing_method, mixing_store, rho, para_env, iter_count) TYPE(qs_environment_type), POINTER :: qs_env INTEGER :: mixing_method TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: iter_count - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gspace_mixing', & routineP = moduleN//':'//routineN @@ -164,30 +160,30 @@ SUBROUTINE gspace_mixing(qs_env, mixing_method, mixing_store, rho, para_env, ite CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(mixing_store),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store),cp_failure_level,routineP,failure) NULLIFY(auxbas_pw_pool, dft_control, pw_env, rho_atom, rho_g, rho_r, tot_rho_r) - CALL get_qs_env(qs_env, dft_control=dft_control, pw_env=pw_env,error=error) - CALL qs_rho_get(rho, rho_g=rho_g, rho_r=rho_r, tot_rho_r= tot_rho_r, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control, pw_env=pw_env) + CALL qs_rho_get(rho, rho_g=rho_g, rho_r=rho_r, tot_rho_r= tot_rho_r) nspin = SIZE(rho_g,1) ng = SIZE(rho_g(1)%pw%pw_grid%gsq) - CPPrecondition((ng == SIZE(mixing_store%rhoin(1)%cc)),cp_failure_level,routineP,error,failure) + CPPrecondition((ng == SIZE(mixing_store%rhoin(1)%cc)),cp_failure_level,routineP,failure) alpha = mixing_store%alpha gapw = dft_control%qs_control%gapw IF(nspin==2) THEN - CALL pw_env_get(pw_env=pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env=pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,& rho_tmp%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) - CALL pw_zero(rho_tmp%pw, error=error) - CALL pw_copy(rho_g(1)%pw, rho_tmp%pw , error=error) - CALL pw_axpy(rho_g(2)%pw,rho_g(1)%pw, 1.0_dp, error=error) - CALL pw_axpy(rho_tmp%pw,rho_g(2)%pw, -1.0_dp, error=error) - CALL pw_scale(rho_g(2)%pw, -1.0_dp, error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero(rho_tmp%pw) + CALL pw_copy(rho_g(1)%pw, rho_tmp%pw) + CALL pw_axpy(rho_g(2)%pw,rho_g(1)%pw, 1.0_dp) + CALL pw_axpy(rho_tmp%pw,rho_g(2)%pw, -1.0_dp) + CALL pw_scale(rho_g(2)%pw, -1.0_dp) END IF IF(iter_count+1 <= mixing_store%nskip_mixing) THEN @@ -200,7 +196,7 @@ SUBROUTINE gspace_mixing(qs_env, mixing_method, mixing_store, rho, para_env, ite END DO IF(gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho_atom_set=rho_atom,error=error) + rho_atom_set=rho_atom) natom = SIZE(rho_atom) DO ispin = 1, nspin DO iatom = 1,natom @@ -213,54 +209,54 @@ SUBROUTINE gspace_mixing(qs_env, mixing_method, mixing_store, rho, para_env, ite END IF mixing_store%iter_method= "NoMix" IF(nspin==2) THEN - CALL pw_axpy(rho_g(2)%pw,rho_g(1)%pw, 1.0_dp, error=error) - CALL pw_scale(rho_g(1)%pw, 0.5_dp, error=error) - CALL pw_axpy(rho_g(1)%pw,rho_g(2)%pw, -1.0_dp, error=error) - CALL pw_scale(rho_g(2)%pw,-1.0_dp, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tmp%pw,error=error) + CALL pw_axpy(rho_g(2)%pw,rho_g(1)%pw, 1.0_dp) + CALL pw_scale(rho_g(1)%pw, 0.5_dp) + CALL pw_axpy(rho_g(1)%pw,rho_g(2)%pw, -1.0_dp) + CALL pw_scale(rho_g(2)%pw,-1.0_dp) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tmp%pw) END IF CALL timestop(handle) RETURN END IF IF((iter_count+1 - mixing_store%nskip_mixing) <= mixing_store%n_simple_mix) THEN - CALL gmix_potential_only(qs_env,mixing_store, rho, error) + CALL gmix_potential_only(qs_env,mixing_store, rho) mixing_store%iter_method= "Kerker" ELSE IF(mixing_method==gspace_mixing_nr) THEN - CALL gmix_potential_only(qs_env,mixing_store, rho, error) + CALL gmix_potential_only(qs_env,mixing_store, rho) mixing_store%iter_method= "Kerker" ELSEIF(mixing_method==pulay_mixing_nr) THEN - CPPrecondition(.NOT. gapw,cp_failure_level,routineP,error,failure) - CALL pulay_mixing(mixing_store, rho, para_env, error) + CPPrecondition(.NOT. gapw,cp_failure_level,routineP,failure) + CALL pulay_mixing(mixing_store, rho, para_env) mixing_store%iter_method= "Pulay" ELSEIF(mixing_method==broyden_mixing_nr) THEN - CALL broyden_mixing(qs_env,mixing_store, rho, para_env, error) + CALL broyden_mixing(qs_env,mixing_store, rho, para_env) mixing_store%iter_method= "Broy." ELSEIF(mixing_method==broyden_mixing_new_nr) THEN - CPPrecondition(.NOT. gapw,cp_failure_level,routineP,error,failure) - CALL broyden_mixing_new(mixing_store, rho, para_env, error) + CPPrecondition(.NOT. gapw,cp_failure_level,routineP,failure) + CALL broyden_mixing_new(mixing_store, rho, para_env) mixing_store%iter_method= "Broy." ELSEIF(mixing_method==multisecant_mixing_nr) THEN - CPPrecondition(.NOT. gapw,cp_failure_level,routineP,error,failure) - CALL multisecant_mixing(mixing_store, rho, para_env, error) + CPPrecondition(.NOT. gapw,cp_failure_level,routineP,failure) + CALL multisecant_mixing(mixing_store, rho, para_env) mixing_store%iter_method= "MSec." END IF END IF IF(nspin==2) THEN - CALL pw_axpy(rho_g(2)%pw,rho_g(1)%pw, 1.0_dp, error=error) - CALL pw_scale(rho_g(1)%pw, 0.5_dp, error=error) - CALL pw_axpy(rho_g(1)%pw,rho_g(2)%pw, -1.0_dp, error=error) - CALL pw_scale(rho_g(2)%pw,-1.0_dp, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tmp%pw,error=error) + CALL pw_axpy(rho_g(2)%pw,rho_g(1)%pw, 1.0_dp) + CALL pw_scale(rho_g(1)%pw, 0.5_dp) + CALL pw_axpy(rho_g(1)%pw,rho_g(2)%pw, -1.0_dp) + CALL pw_scale(rho_g(2)%pw,-1.0_dp) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tmp%pw) END IF DO ispin=1,nspin - CALL pw_transfer(rho_g(ispin)%pw,rho_r(ispin)%pw, error=error) - tot_rho_r(ispin) = pw_integrate_function(rho_r(ispin)%pw,isign=-1,error=error) + CALL pw_transfer(rho_g(ispin)%pw,rho_r(ispin)%pw) + tot_rho_r(ispin) = pw_integrate_function(rho_r(ispin)%pw,isign=-1) !dbg ! write(*,*) 'rho int 4', ispin , tot_rho_r(ispin) !dbg @@ -277,18 +273,16 @@ END SUBROUTINE gspace_mixing !> \param qs_env ... !> \param mixing_store ... !> \param rho ... -!> \param error ... !> \par History !> 02.2009 !> \author MI ! ***************************************************************************** - SUBROUTINE gmix_potential_only (qs_env,mixing_store, rho, error) + SUBROUTINE gmix_potential_only (qs_env,mixing_store, rho) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(qs_rho_type), POINTER :: rho - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gmix_potential_only', & routineP = moduleN//':'//routineN @@ -304,14 +298,14 @@ SUBROUTINE gmix_potential_only (qs_env,mixing_store, rho, error) POINTER :: rho_atom failure = .FALSE. - CPPrecondition(ASSOCIATED(mixing_store%rhoin),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mixing_store%kerker_factor),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store%rhoin),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mixing_store%kerker_factor),cp_failure_level,routineP,failure) CALL timeset(routineN,handle) NULLIFY(cc_new, dft_control, rho_g) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) + CALL qs_rho_get(rho, rho_g=rho_g) nspin = SIZE(rho_g,1) ng = SIZE(rho_g(1)%pw%pw_grid%gsq) @@ -335,7 +329,7 @@ SUBROUTINE gmix_potential_only (qs_env,mixing_store, rho, error) IF(gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho_atom_set=rho_atom,error=error) + rho_atom_set=rho_atom) natom = SIZE(rho_atom) DO ispin = 1, nspin DO iatom = 1,natom @@ -363,18 +357,16 @@ END SUBROUTINE gmix_potential_only !> \param mixing_store ... !> \param rho ... !> \param para_env ... -!> \param error ... !> \par History !> 03.2009 !> \author MI ! ***************************************************************************** - SUBROUTINE pulay_mixing(mixing_store, rho, para_env, error) + SUBROUTINE pulay_mixing(mixing_store, rho, para_env) TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pulay_mixing', & routineP = moduleN//':'//routineN @@ -392,12 +384,12 @@ SUBROUTINE pulay_mixing(mixing_store, rho, para_env, error) TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_g failure = .FALSE. - CPPrecondition(ASSOCIATED(mixing_store%res_buffer),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mixing_store%rhoin_buffer),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store%res_buffer),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mixing_store%rhoin_buffer),cp_failure_level,routineP,failure) NULLIFY(rho_g) CALL timeset(routineN,handle) - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL qs_rho_get(rho, rho_g=rho_g) nspin = SIZE(rho_g,1) ng = SIZE(mixing_store%res_buffer(1,1)%cc) vol = rho_g(1)%pw%pw_grid%vol @@ -414,26 +406,26 @@ SUBROUTINE pulay_mixing(mixing_store, rho, para_env, error) nb1 = nb + 1 ALLOCATE(a(nb1,nb1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) a=0.0_dp ALLOCATE(b(nb1,nb1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) b=0.0_dp ALLOCATE(c(nb,nb), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) c=0.0_dp ALLOCATE(c_inv(nb,nb), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) c_inv=0.0_dp ALLOCATE(alpha_c(nb), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) alpha_c=0.0_dp norm_c_inv = 0.0_dp ALLOCATE(ev(nb1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ev=0.0_dp ALLOCATE(cc_mix(ng), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspin mixing_store%res_buffer(ib,ispin)%cc(:) = CMPLX(0._dp,0._dp,KIND=dp) @@ -479,8 +471,8 @@ SUBROUTINE pulay_mixing(mixing_store, rho, para_env, error) b(1:nb,nb1) = 1.0_dp b(nb1,nb1) = 0.0_dp - CALL diamat_all(b(1:nb1,1:nb1),ev(1:nb1),error=error) - CALL invert_matrix(c,c_inv,inv_err,error=error) + CALL diamat_all(b(1:nb1,1:nb1),ev(1:nb1)) + CALL invert_matrix(c,c_inv,inv_err) alpha_c = 0.0_dp DO i = 1,nb DO jb=1,nb @@ -527,15 +519,15 @@ SUBROUTINE pulay_mixing(mixing_store, rho, para_env, error) END DO ! ispin DEALLOCATE(a, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(b, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(ev, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cc_mix, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(c,c_inv,alpha_c, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -548,19 +540,17 @@ END SUBROUTINE pulay_mixing !> \param mixing_store ... !> \param rho ... !> \param para_env ... -!> \param error ... !> \par History !> 03.2009 !> \author MI ! ***************************************************************************** - SUBROUTINE broyden_mixing(qs_env,mixing_store, rho, para_env, error) + SUBROUTINE broyden_mixing(qs_env,mixing_store, rho, para_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'broyden_mixing', & routineP = moduleN//':'//routineN @@ -584,15 +574,15 @@ SUBROUTINE broyden_mixing(qs_env,mixing_store, rho, para_env, error) POINTER :: rho_atom failure = .FALSE. - CPPrecondition(ASSOCIATED(mixing_store%res_buffer),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mixing_store%rhoin),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mixing_store%rhoin_old),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mixing_store%drho_buffer),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store%res_buffer),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mixing_store%rhoin),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mixing_store%rhoin_old),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mixing_store%drho_buffer),cp_failure_level,routineP,failure) NULLIFY(dft_control, rho_g) CALL timeset(routineN,handle) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) + CALL qs_rho_get(rho, rho_g=rho_g) nspin = SIZE(rho_g,1) ng = SIZE(mixing_store%res_buffer(1,1)%cc) @@ -615,23 +605,23 @@ SUBROUTINE broyden_mixing(qs_env,mixing_store, rho, para_env, error) !dbg ALLOCATE(a(ib-1,ib-1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) a=0.0_dp ALLOCATE(b(ib-1,ib-1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) b=0.0_dp ALLOCATE(c(ib-1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) c=0.0_dp ALLOCATE(g(ib-1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) g=0.0_dp ALLOCATE(res_rho(ng), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF(gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho_atom_set=rho_atom,error=error) + rho_atom_set=rho_atom) natom = SIZE(rho_atom) ELSE natom = 0 @@ -771,7 +761,7 @@ SUBROUTINE broyden_mixing(qs_env,mixing_store, rho, para_env, error) END DO END DO CALL mp_sum(c,para_env%group) - CALL invert_matrix(a,b,inv_err,error=error) + CALL invert_matrix(a,b,inv_err) CALL dgemv('T',IB-1,IB-1,1.0_dp,B,IB-1,C,1,0.0_dp,G,1) @@ -829,7 +819,7 @@ SUBROUTINE broyden_mixing(qs_env,mixing_store, rho, para_env, error) END DO DEALLOCATE(a,b,c,g,res_rho, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -840,14 +830,12 @@ END SUBROUTINE broyden_mixing !> \param mixing_store ... !> \param rho ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE broyden_mixing_new(mixing_store, rho, para_env, error) + SUBROUTINE broyden_mixing_new(mixing_store, rho, para_env) TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'broyden_mixing_new', & routineP = moduleN//':'//routineN @@ -874,13 +862,13 @@ SUBROUTINE broyden_mixing_new(mixing_store, rho, para_env, error) TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_g failure = .FALSE. - CPPrecondition(ASSOCIATED(mixing_store%rhoin_buffer),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store%rhoin_buffer),cp_failure_level,routineP,failure) CALL timeset(routineN,handle) NULLIFY(delta_res, u_vec, z_vec) NULLIFY(fmat, rho_g) - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL qs_rho_get(rho, rho_g=rho_g) nspin = SIZE(rho_g,1) ng = SIZE(mixing_store%rhoin_buffer(1,1)%cc) @@ -902,32 +890,32 @@ SUBROUTINE broyden_mixing_new(mixing_store, rho, para_env, error) ibb = MIN(mixing_store%ncall+1,nbuffer) ALLOCATE(res_rho(ng), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(res_rho_p(ng), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF(ib>1) THEN ALLOCATE(a(ib-1,ib-1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) a=0.0_dp ALLOCATE(b(ib-1,ib-1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) b=0.0_dp ALLOCATE(bq(ib-1,ib-1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) bq=0.0_dp ALLOCATE(tmp(ng), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(delta_res_p(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF p_metric => mixing_store%p_metric weight => mixing_store%weight - CPPrecondition(ASSOCIATED(mixing_store%delta_res),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store%delta_res),cp_failure_level,routineP,failure) delta_res => mixing_store%delta_res - CPPrecondition(ASSOCIATED(mixing_store%u_vec),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store%u_vec),cp_failure_level,routineP,failure) u_vec => mixing_store%u_vec - CPPrecondition(ASSOCIATED(mixing_store%z_vec),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store%z_vec),cp_failure_level,routineP,failure) z_vec => mixing_store%z_vec delta_rhog = 0.0_dp @@ -1084,7 +1072,7 @@ SUBROUTINE broyden_mixing_new(mixing_store, rho, para_env, error) IF(.TRUE.) THEN b=0.0_dp - CALL invert_matrix(a,b,inv_err,error=error) + CALL invert_matrix(a,b,inv_err) !dbg IF(para_env%ionode) THEN WRITE(*,*) 'invert version 1' @@ -1116,7 +1104,7 @@ SUBROUTINE broyden_mixing_new(mixing_store, rho, para_env, error) CALL DGEMM('T','T',ib-1,ib-1,ib-1,1.0_dp,av,ib-1,au,ib-1,0.0_dp,b,ib-1) DEALLOCATE(iwork,aval,au,av,work_dgesdd, work) -! CALL diamat_all(work(1:ib-1,1:ib-1),aval(1:ib-1),error=error) +! CALL diamat_all(work(1:ib-1,1:ib-1),aval(1:ib-1)) ! ! avec(1:ib-1,1:ib-1) = work(1:ib-1,1:ib-1) ! DO jb = 1,ib-1 @@ -1241,12 +1229,12 @@ SUBROUTINE broyden_mixing_new(mixing_store, rho, para_env, error) END DO ! ispin IF(ib>1) THEN DEALLOCATE(a,b,bq, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(delta_res_p,tmp, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(res_rho,res_rho_p, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1261,17 +1249,15 @@ END SUBROUTINE broyden_mixing_new !> \param mixing_store ... !> \param rho ... !> \param para_env ... -!> \param error ... !> \par History !> 05.2009 !> \author MI ! ***************************************************************************** - SUBROUTINE multisecant_mixing(mixing_store,rho,para_env,error) + SUBROUTINE multisecant_mixing(mixing_store,rho,para_env) TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'multisecant_mixing', & routineP = moduleN//':'//routineN @@ -1303,7 +1289,7 @@ SUBROUTINE multisecant_mixing(mixing_store,rho,para_env,error) TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_g failure = .FALSE. - CPPrecondition(ASSOCIATED(mixing_store),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store),cp_failure_level,routineP,failure) CALL timeset(routineN,handle) @@ -1314,11 +1300,11 @@ SUBROUTINE multisecant_mixing(mixing_store,rho,para_env,error) ! use_zgemm_rev = .FALSE. ! prepare the parameters - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL qs_rho_get(rho, rho_g=rho_g) nspin = SIZE(rho_g,1) ! not implemented for large grids. - CPPrecondition(rho_g(1)%pw%pw_grid%ngpts \param p_delta ... !> \param nspins ... !> \param mixing_store ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2009 created [MI] !> 08.2014 kpoints [JGH] @@ -1674,14 +1658,13 @@ END SUBROUTINE multisecant_mixing !> SCF [Patrick Seewald] !> \author fawzi ! ***************************************************************************** - SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mixing_store, error) + SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mixing_store) TYPE(qs_environment_type), POINTER :: qs_env INTEGER :: mixing_method TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & OPTIONAL, POINTER :: p_mix_new, p_delta INTEGER, INTENT(IN) :: nspins TYPE(mixing_storage_type), POINTER :: mixing_store - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mixing_allocate', & routineP = moduleN//':'//routineN @@ -1706,8 +1689,7 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi CALL get_qs_env(qs_env,& sab_orb=sab_orb, & matrix_s_kp=matrix_s, & - dft_control=dft_control,& - error=error) + dft_control=dft_control) refmatrix => matrix_s(1,1)%matrix nimg = dft_control%nimages @@ -1715,19 +1697,19 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi ! *** allocate p_mix_new *** IF (PRESENT(p_mix_new)) THEN IF (.NOT.ASSOCIATED(p_mix_new)) THEN - CALL cp_dbcsr_allocate_matrix_set(p_mix_new,nspins,nimg,error=error) + CALL cp_dbcsr_allocate_matrix_set(p_mix_new,nspins,nimg) DO i=1,nspins DO ic=1,nimg ALLOCATE(p_mix_new(i,ic)%matrix) - CALL cp_dbcsr_init(p_mix_new(i,ic)%matrix, error=error) + CALL cp_dbcsr_init(p_mix_new(i,ic)%matrix) CALL cp_dbcsr_create(matrix=p_mix_new(i,ic)%matrix, & name="SCF DENSITY", & dist=cp_dbcsr_distribution(refmatrix), matrix_type=dbcsr_type_symmetric,& row_blk_size=cp_dbcsr_row_block_sizes(refmatrix), & col_blk_size=cp_dbcsr_col_block_sizes(refmatrix), & - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(p_mix_new(i,ic)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(p_mix_new(i,ic)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(p_mix_new(i,ic)%matrix,sab_orb) + CALL cp_dbcsr_set(p_mix_new(i,ic)%matrix,0.0_dp) ENDDO ENDDO END IF @@ -1737,23 +1719,23 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi IF (PRESENT(p_delta)) THEN IF (mixing_method>=gspace_mixing_nr) THEN IF(.NOT.ASSOCIATED(p_delta)) THEN - CALL cp_dbcsr_allocate_matrix_set(p_delta,nspins,nimg,error=error) + CALL cp_dbcsr_allocate_matrix_set(p_delta,nspins,nimg) DO i=1,nspins DO ic=1,nimg ALLOCATE(p_delta(i,ic)%matrix) - CALL cp_dbcsr_init(p_delta(i,ic)%matrix, error=error) + CALL cp_dbcsr_init(p_delta(i,ic)%matrix) CALL cp_dbcsr_create(matrix=p_delta(i,ic)%matrix, & name="SCF DENSITY", & dist=cp_dbcsr_distribution(refmatrix), matrix_type=dbcsr_type_symmetric,& row_blk_size=cp_dbcsr_row_block_sizes(refmatrix), & col_blk_size=cp_dbcsr_col_block_sizes(refmatrix), & - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(p_delta(i,ic)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(p_delta(i,ic)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(p_delta(i,ic)%matrix,sab_orb) + CALL cp_dbcsr_set(p_delta(i,ic)%matrix,0.0_dp) ENDDO ENDDO END IF - CPPrecondition(ASSOCIATED(mixing_store),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mixing_store),cp_failure_level,routineP,failure) END IF END IF @@ -1769,16 +1751,16 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi END IF IF(dft_control%qs_control%gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho_atom_set=rho_atom,error=error) + rho_atom_set=rho_atom) natom = SIZE(rho_atom) IF(.NOT. ASSOCIATED(mixing_store%paw)) THEN ALLOCATE(mixing_store%paw(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mixing_store%paw = .FALSE. ALLOCATE(mixing_store%cpc_h_in(natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%cpc_s_in(natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO iat = 1,natom NULLIFY(mixing_store%cpc_h_in(iat,ispin)%r_coef) @@ -1794,7 +1776,7 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi .OR. mixing_method==multisecant_mixing_nr ) THEN IF(.NOT. ASSOCIATED(mixing_store%rhoin_buffer)) THEN ALLOCATE(mixing_store%rhoin_buffer(nbuffer,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO i = 1,nbuffer NULLIFY(mixing_store%rhoin_buffer(i,ispin)%cc) @@ -1807,7 +1789,7 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi IF (mixing_method>=pulay_mixing_nr) THEN IF(.NOT. ASSOCIATED(mixing_store%res_buffer)) THEN ALLOCATE(mixing_store%res_buffer(nbuffer,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO i = 1,nbuffer NULLIFY(mixing_store%res_buffer(i,ispin)%cc) @@ -1820,7 +1802,7 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi IF (mixing_method==pulay_mixing_nr) THEN IF(.NOT. ASSOCIATED(mixing_store%pulay_matrix)) THEN ALLOCATE(mixing_store%pulay_matrix(nbuffer,nbuffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -1834,9 +1816,9 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi END IF IF(.NOT. ASSOCIATED(mixing_store%drho_buffer)) THEN ALLOCATE(mixing_store%drho_buffer(nbuffer,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%last_res(nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO i = 1,nbuffer NULLIFY(mixing_store%drho_buffer(i,ispin)%cc) @@ -1847,9 +1829,9 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi IF(dft_control%qs_control%gapw) THEN IF(.NOT. ASSOCIATED(mixing_store%cpc_h_old)) THEN ALLOCATE(mixing_store%cpc_h_old(natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%cpc_s_old(natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO iat = 1,natom NULLIFY(mixing_store%cpc_h_old(iat,ispin)%r_coef) @@ -1859,13 +1841,13 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi END IF IF(.NOT. ASSOCIATED(mixing_store%dcpc_h_in)) THEN ALLOCATE(mixing_store%dcpc_h_in(nbuffer,natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%dcpc_s_in(nbuffer,natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%cpc_h_lastres(natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%cpc_s_lastres(natom,nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO iat = 1,natom DO i = 1,nbuffer @@ -1883,17 +1865,17 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi IF (mixing_method==broyden_mixing_new_nr) THEN IF(.NOT. ASSOCIATED(mixing_store%u_vec)) THEN ALLOCATE(mixing_store%last_res(nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%delta_res(nbuffer-1,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%u_vec(nbuffer-1,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%z_vec(nbuffer-1,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%weight(nbuffer,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%fmat(nbuffer-1,nbuffer-1,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO i = 1,nbuffer-1 NULLIFY(mixing_store%delta_res(i,ispin)%cc) @@ -1909,7 +1891,7 @@ SUBROUTINE mixing_allocate(qs_env, mixing_method, p_mix_new, p_delta, nspins, mi IF (mixing_method==multisecant_mixing_nr) THEN IF(.NOT. ASSOCIATED(mixing_store%norm_res_buffer)) THEN ALLOCATE(mixing_store%norm_res_buffer(nbuffer,nspins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -1924,20 +1906,17 @@ END SUBROUTINE mixing_allocate !> \param mixing_store ... !> \param para_env ... !> \param rho_atom ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2009 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) + SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom) INTEGER, INTENT(IN) :: mixing_method TYPE(qs_rho_type), POINTER :: rho TYPE(mixing_storage_type), POINTER :: mixing_store TYPE(cp_para_env_type), POINTER :: para_env TYPE(rho_atom_type), DIMENSION(:), & OPTIONAL, POINTER :: rho_atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mixing_init', & routineP = moduleN//':'//routineN @@ -1957,7 +1936,7 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) NULLIFY(g2,g_vec,rho_g) failure = .FALSE. - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL qs_rho_get(rho, rho_g=rho_g) nspin = SIZE(rho_g) ng = SIZE(rho_g(1)%pw%pw_grid%gsq,1) @@ -1976,11 +1955,11 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(.NOT. ASSOCIATED(mixing_store%kerker_factor)) THEN ALLOCATE(mixing_store%kerker_factor(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF IF(.NOT. ASSOCIATED(mixing_store%special_metric)) THEN ALLOCATE(mixing_store%special_metric(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF beta = mixing_store%beta kmin = 0.1_dp @@ -2007,7 +1986,7 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(.NOT. ASSOCIATED(mixing_store%rhoin_buffer(1,ispin)%cc)) THEN DO ib = 1,nbuffer ALLOCATE(mixing_store%rhoin_buffer(ib,ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END IF mixing_store%rhoin_buffer(1,ispin)%cc(1:ng) = & @@ -2017,7 +1996,7 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(.NOT. ASSOCIATED(mixing_store%res_buffer(1,ispin)%cc)) THEN DO ib = 1,nbuffer ALLOCATE(mixing_store%res_buffer(ib,ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END IF END IF @@ -2044,9 +2023,9 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(ASSOCIATED(mixing_store%cpc_s_in)) THEN IF(.NOT. ASSOCIATED(mixing_store%cpc_s_in(iat,ispin)%r_coef)) THEN ALLOCATE(mixing_store%cpc_s_in(iat,ispin)%r_coef(n1,n2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%cpc_h_in(iat,ispin)%r_coef(n1,n2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF mixing_store%cpc_h_in(iat,ispin)%r_coef = rho_atom(iat)%cpc_h(ispin)%r_coef mixing_store%cpc_s_in(iat,ispin)%r_coef = rho_atom(iat)%cpc_s(ispin)%r_coef @@ -2066,10 +2045,10 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(.NOT. ASSOCIATED(mixing_store%drho_buffer(1,ispin)%cc)) THEN DO ib = 1,nbuffer ALLOCATE(mixing_store%drho_buffer(ib,ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO ALLOCATE(mixing_store%last_res(ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF DO ib = 1,nbuffer mixing_store%drho_buffer(ib,ispin)%cc = CMPLX(0.0_dp,0.0_dp,kind=dp) @@ -2092,14 +2071,14 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(.NOT. ASSOCIATED(mixing_store%dcpc_s_in(1,iat,ispin)%r_coef)) THEN DO ib = 1,nbuffer ALLOCATE(mixing_store%dcpc_h_in(ib,iat,ispin)%r_coef(n1,n2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%dcpc_s_in(ib,iat,ispin)%r_coef(n1,n2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO ALLOCATE(mixing_store%cpc_h_lastres(iat,ispin)%r_coef(n1,n2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%cpc_s_lastres(iat,ispin)%r_coef(n1,n2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF DO ib = 1,nbuffer mixing_store%dcpc_h_in(ib,iat,ispin)%r_coef = 0.0_dp @@ -2114,7 +2093,7 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(.NOT. ASSOCIATED(mixing_store%p_metric)) THEN ALLOCATE(mixing_store%p_metric(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) bconst = mixing_store%bconst g2min = 1.E30_dp DO ig = 1,ng @@ -2141,19 +2120,19 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) IF(.NOT. ASSOCIATED(mixing_store%u_vec(1,ispin)%cc)) THEN DO ib = 1,nbuffer-1 ALLOCATE(mixing_store%delta_res(ib,ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%u_vec(ib,ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(mixing_store%z_vec(ib,ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO ALLOCATE(mixing_store%last_res(ispin)%cc(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF END DO IF(.NOT. ASSOCIATED(mixing_store%p_metric)) THEN ALLOCATE(mixing_store%p_metric(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) bconst = mixing_store%bconst g2min = 1.E30_dp DO ig = 1,ng @@ -2172,7 +2151,7 @@ SUBROUTINE mixing_init(mixing_method,rho,mixing_store,para_env,rho_atom,error) ELSEIF(mixing_method==multisecant_mixing_nr) THEN IF(.NOT. ASSOCIATED(mixing_store%ig_global_index)) THEN ALLOCATE(mixing_store%ig_global_index(ng),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF mixing_store%ig_global_index = 0 ig_count = 0 diff --git a/src/qs_harmonics_atom.F b/src/qs_harmonics_atom.F index 161a0b6724..e5fc6db2a6 100644 --- a/src/qs_harmonics_atom.F +++ b/src/qs_harmonics_atom.F @@ -61,13 +61,11 @@ MODULE qs_harmonics_atom ! ***************************************************************************** !> \brief Allocate a spherical harmonics set for the atom grid. !> \param harmonics ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_harmonics_atom(harmonics,error) + SUBROUTINE allocate_harmonics_atom(harmonics) TYPE(harmonics_atom_type), POINTER :: harmonics - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_harmonics_atom', & routineP = moduleN//':'//routineN @@ -76,10 +74,10 @@ SUBROUTINE allocate_harmonics_atom(harmonics,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(harmonics)) CALL deallocate_harmonics_atom(harmonics,error) + IF (ASSOCIATED(harmonics)) CALL deallocate_harmonics_atom(harmonics) ALLOCATE (harmonics,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) harmonics%max_s_harm=0 harmonics%llmax=0 @@ -104,13 +102,11 @@ END SUBROUTINE allocate_harmonics_atom ! ***************************************************************************** !> \brief Deallocate the spherical harmonics set for the atom grid. !> \param harmonics ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_harmonics_atom(harmonics,error) + SUBROUTINE deallocate_harmonics_atom(harmonics) TYPE(harmonics_atom_type), POINTER :: harmonics - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_harmonics_atom', & routineP = moduleN//':'//routineN @@ -123,56 +119,56 @@ SUBROUTINE deallocate_harmonics_atom(harmonics,error) IF(ASSOCIATED(harmonics%slm)) THEN DEALLOCATE (harmonics%slm,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%dmslm)) THEN DEALLOCATE (harmonics%dmslm,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%dslm)) THEN DEALLOCATE (harmonics%dslm,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%dslm_dxyz)) THEN DEALLOCATE (harmonics%dslm_dxyz,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%slm_int)) THEN DEALLOCATE (harmonics%slm_int,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%my_CG)) THEN DEALLOCATE (harmonics%my_CG,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%my_dCG)) THEN DEALLOCATE (harmonics%my_dCG,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%my_CG_dxyz)) THEN DEALLOCATE (harmonics%my_CG_dxyz,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%my_CG_dxyz_asym)) THEN DEALLOCATE (harmonics%my_CG_dxyz_asym,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(harmonics%a)) THEN DEALLOCATE (harmonics%a,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE (harmonics,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer harmonics is not associated and "//& @@ -194,17 +190,15 @@ END SUBROUTINE deallocate_harmonics_atom !> \param pol ... !> \param cos_pol ... !> \param cotan_azi ... -!> \param error ... ! ***************************************************************************** SUBROUTINE create_harmonics_atom(harmonics,my_CG,na,& - llmax,maxs,max_s_harm,ll,wa,pol,cos_pol,cotan_azi,error) + llmax,maxs,max_s_harm,ll,wa,pol,cos_pol,cotan_azi) TYPE(harmonics_atom_type), POINTER :: harmonics REAL(dp), DIMENSION(:, :, :), POINTER :: my_CG INTEGER, INTENT(IN) :: na, llmax, maxs, max_s_harm, & ll REAL(dp), DIMENSION(:), INTENT(IN) :: wa, pol, cos_pol, cotan_azi - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_harmonics_atom', & routineP = moduleN//':'//routineN @@ -226,7 +220,7 @@ SUBROUTINE create_harmonics_atom(harmonics,my_CG,na,& NULLIFY (y,dy,slm,dslm_dxyz,dc) - CPPrecondition(ASSOCIATED(harmonics),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(harmonics),cp_failure_level,routineP,failure) harmonics%max_s_harm = max_s_harm harmonics%llmax = llmax @@ -525,14 +519,12 @@ END SUBROUTINE create_harmonics_atom !> \param orb_basis ... !> \param llmax ... !> \param max_s_harm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_maxl_CG(harmonics,orb_basis,llmax,max_s_harm,error) + SUBROUTINE get_maxl_CG(harmonics,orb_basis,llmax,max_s_harm) TYPE(harmonics_atom_type), POINTER :: harmonics TYPE(gto_basis_set_type), POINTER :: orb_basis INTEGER, INTENT(IN) :: llmax, max_s_harm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_maxl_CG', & routineP = moduleN//':'//routineN @@ -546,7 +538,7 @@ SUBROUTINE get_maxl_CG(harmonics,orb_basis,llmax,max_s_harm,error) failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(harmonics),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(harmonics),cp_failure_level,routineP,failure) CALL get_gto_basis_set(gto_basis_set=orb_basis,lmax=lmax,lmin=lmin,nset=nset) @@ -558,15 +550,15 @@ SUBROUTINE get_maxl_CG(harmonics,orb_basis,llmax,max_s_harm,error) DO is2 = 1,nset CALL get_none0_cg_list(harmonics%my_CG,& lmin(is1),lmax(is1),lmin(is2),lmax(is2),& - max_s_harm,llmax,max_iso_not0=itmp,error=error) + max_s_harm,llmax,max_iso_not0=itmp) max_iso_not0 = MAX(max_iso_not0,itmp) CALL get_none0_cg_list(harmonics%my_dCG,& lmin(is1),lmax(is1),lmin(is2),lmax(is2),& - max_s_harm,llmax,max_iso_not0=itmp,error=error) + max_s_harm,llmax,max_iso_not0=itmp) dmax_iso_not0 = MAX(dmax_iso_not0,itmp) CALL get_none0_cg_list(harmonics%my_CG_dxyz_asym,& lmin(is1),lmax(is1),lmin(is2),lmax(is2),& - max_s_harm,llmax,max_iso_not0=itmp,error=error) + max_s_harm,llmax,max_iso_not0=itmp) damax_iso_not0 = MAX(damax_iso_not0,itmp) END DO ! is2 END DO ! is1 @@ -590,10 +582,9 @@ END SUBROUTINE get_maxl_CG !> \param list ... !> \param n_list ... !> \param max_iso_not0 ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_none0_cg_list4(cgc,lmin1,lmax1,lmin2,lmax2,max_s_harm,llmax,& - list,n_list,max_iso_not0,error) + list,n_list,max_iso_not0) REAL(dp), DIMENSION(:, :, :, :), & INTENT(IN) :: cgc @@ -604,7 +595,6 @@ SUBROUTINE get_none0_cg_list4(cgc,lmin1,lmax1,lmin2,lmax2,max_s_harm,llmax,& INTEGER, DIMENSION(:), INTENT(OUT), & OPTIONAL :: n_list INTEGER, INTENT(OUT) :: max_iso_not0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_none0_cg_list4', & routineP = moduleN//':'//routineN @@ -612,11 +602,11 @@ SUBROUTINE get_none0_cg_list4(cgc,lmin1,lmax1,lmin2,lmax2,max_s_harm,llmax,& INTEGER :: iso, iso1, iso2, l1, l2, nlist LOGICAL :: failure - CPPrecondition(nsoset(lmax1).LE.SIZE(cgc,2),cp_failure_level,routineP,error,failure) - CPPrecondition(nsoset(lmax2).LE.SIZE(cgc,3),cp_failure_level,routineP,error,failure) - CPPrecondition(max_s_harm.LE.SIZE(cgc,4),cp_failure_level,routineP,error,failure) + CPPrecondition(nsoset(lmax1).LE.SIZE(cgc,2),cp_failure_level,routineP,failure) + CPPrecondition(nsoset(lmax2).LE.SIZE(cgc,3),cp_failure_level,routineP,failure) + CPPrecondition(max_s_harm.LE.SIZE(cgc,4),cp_failure_level,routineP,failure) IF(PRESENT(n_list).AND.PRESENT(list)) THEN - CPPrecondition(max_s_harm.LE.SIZE(list,3),cp_failure_level,routineP,error,failure) + CPPrecondition(max_s_harm.LE.SIZE(list,3),cp_failure_level,routineP,failure) ENDIF max_iso_not0 = 0 IF(PRESENT(n_list).AND.PRESENT(list)) n_list = 0 @@ -657,10 +647,9 @@ END SUBROUTINE get_none0_cg_list4 !> \param list ... !> \param n_list ... !> \param max_iso_not0 ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_none0_cg_list3(cgc,lmin1,lmax1,lmin2,lmax2,max_s_harm,llmax,& - list,n_list,max_iso_not0,error) + list,n_list,max_iso_not0) REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: cgc INTEGER, INTENT(IN) :: lmin1, lmax1, lmin2, lmax2, & @@ -670,7 +659,6 @@ SUBROUTINE get_none0_cg_list3(cgc,lmin1,lmax1,lmin2,lmax2,max_s_harm,llmax,& INTEGER, DIMENSION(:), INTENT(OUT), & OPTIONAL :: n_list INTEGER, INTENT(OUT) :: max_iso_not0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_none0_cg_list3', & routineP = moduleN//':'//routineN @@ -678,11 +666,11 @@ SUBROUTINE get_none0_cg_list3(cgc,lmin1,lmax1,lmin2,lmax2,max_s_harm,llmax,& INTEGER :: iso, iso1, iso2, l1, l2, nlist LOGICAL :: failure - CPPrecondition(nsoset(lmax1).LE.SIZE(cgc,1),cp_failure_level,routineP,error,failure) - CPPrecondition(nsoset(lmax2).LE.SIZE(cgc,2),cp_failure_level,routineP,error,failure) - CPPrecondition(max_s_harm.LE.SIZE(cgc,3),cp_failure_level,routineP,error,failure) + CPPrecondition(nsoset(lmax1).LE.SIZE(cgc,1),cp_failure_level,routineP,failure) + CPPrecondition(nsoset(lmax2).LE.SIZE(cgc,2),cp_failure_level,routineP,failure) + CPPrecondition(max_s_harm.LE.SIZE(cgc,3),cp_failure_level,routineP,failure) IF(PRESENT(n_list).AND.PRESENT(list)) THEN - CPPrecondition(max_s_harm.LE.SIZE(list,3),cp_failure_level,routineP,error,failure) + CPPrecondition(max_s_harm.LE.SIZE(list,3),cp_failure_level,routineP,failure) ENDIF max_iso_not0 = 0 IF(PRESENT(n_list).AND.PRESENT(list)) n_list = 0 diff --git a/src/qs_initial_guess.F b/src/qs_initial_guess.F index d549e917ff..52842d883d 100644 --- a/src/qs_initial_guess.F +++ b/src/qs_initial_guess.F @@ -105,7 +105,6 @@ MODULE qs_initial_guess !> density matrix and optionally an initial wavefunction !> \param scf_env SCF environment information !> \param qs_env QS environment -!> \param error CP2K error handling !> \par History !> 03.2006 moved here from qs_scf [Joost VandeVondele] !> 06.2007 allow to skip the initial guess [jgh] @@ -114,11 +113,10 @@ MODULE qs_initial_guess !> badly needs to be split in subroutines each doing one of the possible !> schemes ! ***************************************************************************** - SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) + SUBROUTINE calculate_first_density_matrix(scf_env,qs_env) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'calculate_first_density_matrix', & @@ -175,7 +173,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) TYPE(section_vals_type), POINTER :: dft_section, input, & subsys_section - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. NULLIFY(atomic_kind, qs_kind, mo_coeff, sv, orb_basis_set, atomic_kind_set,& qs_kind_set, particle_set, ortho, work2, work1, mo_array, s_sparse, & @@ -205,15 +203,14 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) do_kpoints=do_kpoints,& kpoints=kpoints,& rho=rho,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) ! just initialize the first image, the other density are set to zero DO ispin=1, dft_control%nspins DO ic=1,SIZE(rho_ao_kp,2) - CALL cp_dbcsr_set(rho_ao_kp(ispin,ic)%matrix, 0.0_dp,error=error) + CALL cp_dbcsr_set(rho_ao_kp(ispin,ic)%matrix, 0.0_dp) END DO END DO s_sparse => matrix_s_kp(:,1) @@ -225,7 +222,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) work2 => scf_env%scf_work2 ortho => scf_env%ortho - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") nspin = dft_control%nspins ofgpw = dft_control%qs_control%ofgpw @@ -264,7 +261,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) ! not on compute nodes, everything goes crazy even though only I/O ! node actually reads the file IF (para_env%ionode) & - CALL wfn_restart_file_name(file_name,exist,dft_section,logger,error=error) + CALL wfn_restart_file_name(file_name,exist,dft_section,logger) CALL mp_bcast(exist, para_env%source, para_env%group) CALL mp_bcast(file_name, para_env%source, para_env%group) IF (.NOT.exist) THEN @@ -279,7 +276,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) END IF ELSE IF (density_guess == history_guess) THEN IF (para_env%ionode) & - CALL wfn_restart_file_name(file_name,exist,dft_section,logger,error=error) + CALL wfn_restart_file_name(file_name,exist,dft_section,logger) CALL mp_bcast(exist, para_env%source, para_env%group) CALL mp_bcast(file_name, para_env%source, para_env%group) nvec = qs_env%wf_history%memory_depth @@ -325,7 +322,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set) CALL read_mo_set(mo_array,atomic_kind_set,qs_kind_set,particle_set,para_env,& id_nr=id_nr,multiplicity=dft_control%multiplicity,dft_section=dft_section,& - natom_mismatch=natom_mismatch, kpoints=kpoints, error=error) + natom_mismatch=natom_mismatch, kpoints=kpoints) IF (natom_mismatch) THEN density_guess = safe_density_guess @@ -334,7 +331,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) IF (scf_control%level_shift /= 0.0_dp) THEN CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff=mo_coeff) - CALL cp_fm_to_fm(mo_coeff,ortho,error=error) + CALL cp_fm_to_fm(mo_coeff,ortho) END IF ! make all nmo vectors present orthonormal @@ -342,29 +339,29 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) mo_coeff=mo_coeff, nmo=nmo, homo=homo) IF(has_unit_metric) THEN - CALL make_basis_simple(mo_coeff,nmo,error=error) + CALL make_basis_simple(mo_coeff,nmo) ELSEIF(dft_control%smear)THEN CALL make_basis_lowdin(vmatrix=mo_coeff,ncol=nmo,& - matrix_s=s_sparse(1)%matrix,error=error) + matrix_s=s_sparse(1)%matrix) ELSE ! ortho so that one can restart for different positions (basis sets?) - CALL make_basis_sm(mo_coeff,homo,s_sparse(1)%matrix,error=error) + CALL make_basis_sm(mo_coeff,homo,s_sparse(1)%matrix) ENDIF ! only alpha spin is kept for restricted IF (dft_control%restricted) EXIT ENDDO - IF (dft_control%restricted) CALL mo_set_restrict(mo_array,error=error) + IF (dft_control%restricted) CALL mo_set_restrict(mo_array) - CALL set_mo_occupation(mo_array,smear=qs_env%scf_control%smear,error=error) + CALL set_mo_occupation(mo_array,smear=qs_env%scf_control%smear) DO ispin=1,nspin IF(scf_control%use_ot .OR. scf_env%method==ot_diag_method_nr) THEN!fm->dbcsr - CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,mo_array(ispin)%mo_set%mo_coeff_b,error=error)!fm->dbcsr + CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,mo_array(ispin)%mo_set%mo_coeff_b)!fm->dbcsr ENDIF!fm->dbcsr CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,error=error) + p_rmpv(ispin)%matrix) ENDDO ENDIF ! natom_mismatch @@ -376,45 +373,44 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) j = last_read -i CALL read_mo_set(mo_array,atomic_kind_set,qs_kind_set,particle_set,para_env,& id_nr=j,multiplicity=dft_control%multiplicity,& - dft_section=dft_section, kpoints=kpoints, error=error) + dft_section=dft_section, kpoints=kpoints) DO ispin=1,nspin IF (scf_control%level_shift /= 0.0_dp) THEN CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff=mo_coeff) - CALL cp_fm_to_fm(mo_coeff,ortho,error=error) + CALL cp_fm_to_fm(mo_coeff,ortho) END IF ! make all nmo vectors present orthonormal CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,mo_coeff=mo_coeff, nmo=nmo, homo=homo) IF(has_unit_metric) THEN - CALL make_basis_simple(mo_coeff,nmo,error=error) + CALL make_basis_simple(mo_coeff,nmo) ELSE ! ortho so that one can restart for different positions (basis sets?) - CALL make_basis_sm(mo_coeff,homo,s_sparse(1)%matrix,error=error) + CALL make_basis_sm(mo_coeff,homo,s_sparse(1)%matrix) ENDIF ! only alpha spin is kept for restricted IF (dft_control%restricted) EXIT END DO - IF (dft_control%restricted) CALL mo_set_restrict(mo_array,error=error) + IF (dft_control%restricted) CALL mo_set_restrict(mo_array) DO ispin=1,nspin CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=qs_env%scf_control%smear,& - error=error) + smear=qs_env%scf_control%smear) ENDDO DO ispin=1,nspin IF(scf_control%use_ot .OR. scf_env%method==ot_diag_method_nr) THEN!fm->dbcsr -CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,mo_array(ispin)%mo_set%mo_coeff_b,error=error)!fm->dbcsr +CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,mo_array(ispin)%mo_set%mo_coeff_b)!fm->dbcsr ENDIF!fm->dbcsr CALL calculate_density_matrix(mo_array(ispin)%mo_set, & - p_rmpv(ispin)%matrix,error=error) + p_rmpv(ispin)%matrix) ENDDO ! Write to extrapolation pipeline - CALL wfi_update(wf_history=qs_env%wf_history, qs_env=qs_env, dt=1.0_dp, error=error) + CALL wfi_update(wf_history=qs_env%wf_history, qs_env=qs_env, dt=1.0_dp) END DO END IF @@ -425,32 +421,31 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) DO ispin=1,nspin CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff=mo_coeff, nmo=nmo) - CALL cp_fm_init_random(mo_coeff,nmo,error=error) + CALL cp_fm_init_random(mo_coeff,nmo) IF(has_unit_metric) THEN - CALL make_basis_simple(mo_coeff,nmo,error=error) + CALL make_basis_simple(mo_coeff,nmo) ELSE - CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix,error=error) + CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix) ENDIF ! only alpha spin is kept for restricted IF (dft_control%restricted) EXIT ENDDO - IF (dft_control%restricted) CALL mo_set_restrict(mo_array,error=error) + IF (dft_control%restricted) CALL mo_set_restrict(mo_array) DO ispin=1,nspin CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=qs_env%scf_control%smear,& - error=error) + smear=qs_env%scf_control%smear) ENDDO DO ispin=1,nspin IF(scf_control%use_ot .OR. scf_env%method==ot_diag_method_nr) THEN!fm->dbcsr CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,& - mo_array(ispin)%mo_set%mo_coeff_b,error=error)!fm->dbcsr + mo_array(ispin)%mo_set%mo_coeff_b)!fm->dbcsr ENDIF!fm->dbcsr CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,error=error) + p_rmpv(ispin)%matrix) ENDDO did_guess = .TRUE. @@ -461,7 +456,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) ! Load core Hamiltonian into work matrix - CALL copy_dbcsr_to_fm(h_core_sparse(1)%matrix,work1(ispin)%matrix,error=error) + CALL copy_dbcsr_to_fm(h_core_sparse(1)%matrix,work1(ispin)%matrix) ! Diagonalize the core Hamiltonian matrix and retrieve a first set of ! molecular orbitals (MOs) @@ -472,16 +467,14 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) work=work2,& do_level_shift=.FALSE.,& level_shift=0.0_dp,& - use_jacobi=.FALSE.,jacobi_threshold=0._dp,& - error=error) + use_jacobi=.FALSE.,jacobi_threshold=0._dp) ELSE CALL eigensolver(matrix_ks_fm=work1(ispin)%matrix,& mo_set=mo_array(ispin)%mo_set,& ortho=ortho,& work=work2,& cholesky_method=scf_env%cholesky_method,& - use_jacobi=.FALSE.,& - error=error) + use_jacobi=.FALSE.) END IF ! Open shell case: copy alpha MOs to beta MOs @@ -497,20 +490,17 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) DO ispin=1,nspin CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,& - error=error) + p_rmpv(ispin)%matrix) END DO did_guess = .TRUE. END IF IF (density_guess == atomic_guess) THEN - subsys_section => section_vals_get_subs_vals(input,"SUBSYS",error=error) - output_unit = cp_print_key_unit_nr(logger,subsys_section,"PRINT%KINDS",extension=".Log",& - error=error) + subsys_section => section_vals_get_subs_vals(input,"SUBSYS") + output_unit = cp_print_key_unit_nr(logger,subsys_section,"PRINT%KINDS",extension=".Log") IF (output_unit > 0) THEN WRITE (UNIT=output_unit,FMT="(/,(T2,A))")& "Atomic guess: The first density matrix is obtained in terms of atomic orbitals",& @@ -523,7 +513,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) CALL calculate_atomic_block_dm(p_rmpv(ispin)%matrix,s_sparse(1)%matrix, & particle_set, atomic_kind_set, qs_kind_set, & - ispin, nspin, nelectron, output_unit, error) + ispin, nspin, nelectron, output_unit) ! The orbital transformation method (OT) requires not only an ! initial density matrix, but also an initial wavefunction (MO set) @@ -535,44 +525,42 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) (scf_env%method==block_krylov_diag_method_nr .AND. .NOT. do_std_diag) & .OR. dft_control%do_admm .OR. scf_env%method==block_davidson_diag_method_nr) THEN IF (dft_control%restricted.AND.(ispin == 2)) THEN - CALL mo_set_restrict(mo_array,error=error) + CALL mo_set_restrict(mo_array) ELSE CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff=mo_coeff,& nmo=nmo, nao=nao, homo=homo) - CALL cp_fm_set_all(mo_coeff,0.0_dp,error=error) - CALL cp_fm_init_random(mo_coeff,nmo,error=error) + CALL cp_fm_set_all(mo_coeff,0.0_dp) + CALL cp_fm_init_random(mo_coeff,nmo) - CALL cp_fm_create(sv,mo_coeff%matrix_struct,"SV",error=error) + CALL cp_fm_create(sv,mo_coeff%matrix_struct,"SV") ! multiply times PS IF (has_unit_metric) THEN - CALL cp_fm_to_fm(mo_coeff,sv,error=error) + CALL cp_fm_to_fm(mo_coeff,sv) ELSE ! PS*C(:,1:nomo)+C(:,nomo+1:nmo) (nomo=NINT(nelectron/maxocc)) - CALL cp_dbcsr_sm_fm_multiply(s_sparse(1)%matrix,mo_coeff,sv,nmo,error=error) + CALL cp_dbcsr_sm_fm_multiply(s_sparse(1)%matrix,mo_coeff,sv,nmo) END IF - CALL cp_dbcsr_sm_fm_multiply(p_rmpv(ispin)%matrix,sv,mo_coeff,homo,error=error) + CALL cp_dbcsr_sm_fm_multiply(p_rmpv(ispin)%matrix,sv,mo_coeff,homo) - CALL cp_fm_release(sv,error=error) + CALL cp_fm_release(sv) ! and ortho the result IF (has_unit_metric) THEN - CALL make_basis_simple(mo_coeff,nmo,error=error) + CALL make_basis_simple(mo_coeff,nmo) ELSE - CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix,error=error) + CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix) END IF END IF CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=qs_env%scf_control%smear,& - error=error) + smear=qs_env%scf_control%smear) CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,& - mo_array(ispin)%mo_set%mo_coeff_b,error=error)!fm->dbcsr + mo_array(ispin)%mo_set%mo_coeff_b)!fm->dbcsr CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,& - error=error) + p_rmpv(ispin)%matrix) END IF END IF @@ -580,21 +568,21 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) IF (ofgpw .AND. (scf_control%use_ot .OR. scf_env%method==ot_diag_method_nr)) THEN ! We fit a function to the square root of the density - CALL qs_rho_update_rho(rho,qs_env,error=error) - CPPostcondition(1==0,cp_failure_level,routineP,error,failure) -! CALL cp_fm_create(sv,mo_coeff%matrix_struct,"SV",error=error) + CALL qs_rho_update_rho(rho,qs_env) + CPPostcondition(1==0,cp_failure_level,routineP,failure) +! CALL cp_fm_create(sv,mo_coeff%matrix_struct,"SV") ! DO ispin=1,nspin -! CALL integrate_ppl_rspace(qs%rho%rho_r(ispin),qs_env,error=error) -! CALL cp_cfm_solve(overlap,mos,error) +! CALL integrate_ppl_rspace(qs%rho%rho_r(ispin),qs_env) +! CALL cp_cfm_solve(overlap,mos) ! CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& ! mo_coeff=mo_coeff, nmo=nmo, nao=nao) -! CALL cp_fm_init_random(mo_coeff,nmo,error=error) +! CALL cp_fm_init_random(mo_coeff,nmo) ! END DO -! CALL cp_fm_release(sv,error=error) +! CALL cp_fm_release(sv) END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%KINDS",error=error) + "PRINT%KINDS") did_guess = .TRUE. @@ -612,24 +600,24 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) group = para_env%group natoms = SIZE(particle_set) ALLOCATE (kind_of(natoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (first_sgf(natoms),last_sgf(natoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - checksum = cp_dbcsr_checksum(s_sparse(1)%matrix, error=error) + checksum = cp_dbcsr_checksum(s_sparse(1)%matrix) i = cp_dbcsr_get_num_blocks (s_sparse(1)%matrix); CALL mp_sum(i,group) IF(output_unit>0)WRITE(output_unit,*) 'S nblks',i,' checksum',checksum - CALL cp_dbcsr_filter(s_sparse(1)%matrix, eps, error=error) - checksum = cp_dbcsr_checksum(s_sparse(1)%matrix, error=error) + CALL cp_dbcsr_filter(s_sparse(1)%matrix, eps) + checksum = cp_dbcsr_checksum(s_sparse(1)%matrix) i = cp_dbcsr_get_num_blocks (s_sparse(1)%matrix); CALL mp_sum(i,group) IF(output_unit>0)WRITE(output_unit,*) 'S nblks',i,' checksum',checksum CALL get_particle_set(particle_set,qs_kind_set,first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,kind_of=kind_of) ALLOCATE (pmat(SIZE(atomic_kind_set)),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin=1,nspin scale = 1._dp @@ -638,7 +626,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) atomic_kind => atomic_kind_set(ikind) qs_kind => qs_kind_set(ikind) NULLIFY(pmat(ikind)%mat) - CALL calculate_atomic_orbitals(atomic_kind,qs_kind, pmat=pmat(ikind)%mat,ispin=ispin,error=error) + CALL calculate_atomic_orbitals(atomic_kind,qs_kind, pmat=pmat(ikind)%mat,ispin=ispin) NULLIFY(atomic_kind) END DO CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& @@ -653,42 +641,42 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) ENDDO CALL cp_dbcsr_iterator_stop(iter) - !CALL cp_dbcsr_verify_matrix(p_rmpv(ispin)%matrix, error=error) - checksum = cp_dbcsr_checksum(p_rmpv(ispin)%matrix, error=error) + !CALL cp_dbcsr_verify_matrix(p_rmpv(ispin)%matrix) + checksum = cp_dbcsr_checksum(p_rmpv(ispin)%matrix) occ = cp_dbcsr_get_occupation(p_rmpv(ispin)%matrix) IF(output_unit>0)WRITE(output_unit,*) 'P_init occ',occ,' checksum',checksum ! so far p needs to have the same sparsity as S - !CALL cp_dbcsr_filter(p_rmpv(ispin)%matrix, eps, error=error) - !CALL cp_dbcsr_verify_matrix(p_rmpv(ispin)%matrix, error=error) - checksum = cp_dbcsr_checksum(p_rmpv(ispin)%matrix, error=error) + !CALL cp_dbcsr_filter(p_rmpv(ispin)%matrix, eps) + !CALL cp_dbcsr_verify_matrix(p_rmpv(ispin)%matrix) + checksum = cp_dbcsr_checksum(p_rmpv(ispin)%matrix) occ = cp_dbcsr_get_occupation(p_rmpv(ispin)%matrix) IF(output_unit>0)WRITE(output_unit,*) 'P_init occ',occ,' checksum',checksum - CALL cp_dbcsr_trace(p_rmpv(ispin)%matrix, s_sparse(1)%matrix, trps1, error=error) + CALL cp_dbcsr_trace(p_rmpv(ispin)%matrix, s_sparse(1)%matrix, trps1) scale=REAL(nelectron,dp)/trps1 - CALL cp_dbcsr_scale(p_rmpv(ispin)%matrix, scale, error=error) + CALL cp_dbcsr_scale(p_rmpv(ispin)%matrix, scale) - !CALL cp_dbcsr_verify_matrix(p_rmpv(ispin)%matrix, error=error) - checksum = cp_dbcsr_checksum(p_rmpv(ispin)%matrix, error=error) + !CALL cp_dbcsr_verify_matrix(p_rmpv(ispin)%matrix) + checksum = cp_dbcsr_checksum(p_rmpv(ispin)%matrix) occ = cp_dbcsr_get_occupation(p_rmpv(ispin)%matrix) IF(output_unit>0)WRITE(output_unit,*) 'P occ',occ,' checksum',checksum ! ! The orbital transformation method (OT) requires not only an ! initial density matrix, but also an initial wavefunction (MO set) IF (dft_control%restricted.AND.(ispin == 2)) THEN - CALL mo_set_restrict(mo_array,error=error) + CALL mo_set_restrict(mo_array) ELSE CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff=mo_coeff,& nmo=nmo, nao=nao, homo=homo) - CALL cp_fm_set_all(mo_coeff,0.0_dp,error=error) + CALL cp_fm_set_all(mo_coeff,0.0_dp) n = MAXVAL(last_sgf-first_sgf)+1 size_atomic_kind_set = SIZE(atomic_kind_set) ALLOCATE(buff(n,n),sort_kind(size_atomic_kind_set),& nelec_kind(size_atomic_kind_set),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! sort kind vs nbr electron DO ikind = 1,size_atomic_kind_set @@ -699,7 +687,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) atom_list=atom_list,& z=z) CALL get_qs_kind(qs_kind, nsgf=nsgf,elec_conf=elec_conf,& - basis_set=orb_basis_set, zeff=zeff, error=error) + basis_set=orb_basis_set, zeff=zeff) nelec_kind(ikind) = SUM(elec_conf) ENDDO CALL sort(nelec_kind,size_atomic_kind_set,sort_kind) @@ -733,7 +721,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) CALL dlarnv(1,iseed,n_rows,buff(1,j)) ENDDO CALL cp_fm_set_submatrix(mo_coeff,buff,istart_row,istart_col,& - n_rows,n_cols,error=error) + n_rows,n_cols) istart_col = istart_col + n_cols ENDDO ENDDO @@ -743,19 +731,19 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) END IF DEALLOCATE(buff,nelec_kind,sort_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(.FALSE.) THEN ALLOCATE(buff(nao,1),buff2(nao,1)) DO i = 1,nmo - CALL cp_fm_get_submatrix(mo_coeff,buff,1,i,nao,1,error=error) + CALL cp_fm_get_submatrix(mo_coeff,buff,1,i,nao,1) IF(SUM(buff**2).LT.1E-10_dp) THEN WRITE(*,*) 'wrong',i,SUM(buff**2) ENDIF length = SQRT(DOT_PRODUCT(buff(:,1), buff(:,1))) buff(:,:) = buff(:,:)/length DO j = i+1,nmo - CALL cp_fm_get_submatrix(mo_coeff,buff2,1,j,nao,1,error=error) + CALL cp_fm_get_submatrix(mo_coeff,buff2,1,j,nao,1) length = SQRT(DOT_PRODUCT(buff2(:,1), buff2(:,1))) buff2(:,:) = buff2(:,:)/length IF(ABS(DOT_PRODUCT(buff(:,1),buff2(:,1))-1.0_dp).LT.1E-10_dp) THEN @@ -776,17 +764,17 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) ENDIF ! - CALL cp_dbcsr_init(mo_dbcsr, error=error) - CALL cp_fm_to_dbcsr_row_template(mo_dbcsr,mo_coeff,s_sparse(1)%matrix,error) - !CALL cp_dbcsr_verify_matrix(mo_dbcsr, error=error) - checksum = cp_dbcsr_checksum(mo_dbcsr, error=error) + CALL cp_dbcsr_init(mo_dbcsr) + CALL cp_fm_to_dbcsr_row_template(mo_dbcsr,mo_coeff,s_sparse(1)%matrix) + !CALL cp_dbcsr_verify_matrix(mo_dbcsr) + checksum = cp_dbcsr_checksum(mo_dbcsr) occ = cp_dbcsr_get_occupation(mo_dbcsr) IF(output_unit>0)WRITE(output_unit,*) 'C occ',occ,' checksum',checksum - CALL cp_dbcsr_filter(mo_dbcsr, eps, error=error) - !CALL cp_dbcsr_verify_matrix(mo_dbcsr, error=error) + CALL cp_dbcsr_filter(mo_dbcsr, eps) + !CALL cp_dbcsr_verify_matrix(mo_dbcsr) occ = cp_dbcsr_get_occupation(mo_dbcsr) - checksum = cp_dbcsr_checksum(mo_dbcsr, error=error) + checksum = cp_dbcsr_checksum(mo_dbcsr) IF(output_unit>0)WRITE(output_unit,*) 'C occ',occ,' checksum',checksum ! ! multiply times PS @@ -796,18 +784,18 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) END IF ! ! S*C - CALL cp_dbcsr_init(mo_tmp_dbcsr, error) - CALL cp_dbcsr_copy(mo_tmp_dbcsr, mo_dbcsr, name="mo_tmp", error=error) + CALL cp_dbcsr_init(mo_tmp_dbcsr) + CALL cp_dbcsr_copy(mo_tmp_dbcsr, mo_dbcsr, name="mo_tmp") CALL cp_dbcsr_multiply("N", "N", 1.0_dp, s_sparse(1)%matrix, mo_dbcsr,& 0.0_dp, mo_tmp_dbcsr,& - retain_sparsity=.TRUE., error=error) - !CALL cp_dbcsr_verify_matrix(mo_tmp_dbcsr, error=error) - checksum = cp_dbcsr_checksum(mo_tmp_dbcsr, error=error) + retain_sparsity=.TRUE.) + !CALL cp_dbcsr_verify_matrix(mo_tmp_dbcsr) + checksum = cp_dbcsr_checksum(mo_tmp_dbcsr) occ = cp_dbcsr_get_occupation(mo_tmp_dbcsr) IF(output_unit>0)WRITE(output_unit,*) 'S*C occ',occ,' checksum',checksum - CALL cp_dbcsr_filter(mo_tmp_dbcsr, eps, error=error) - !CALL cp_dbcsr_verify_matrix(mo_tmp_dbcsr, error=error) - checksum = cp_dbcsr_checksum(mo_tmp_dbcsr, error=error) + CALL cp_dbcsr_filter(mo_tmp_dbcsr, eps) + !CALL cp_dbcsr_verify_matrix(mo_tmp_dbcsr) + checksum = cp_dbcsr_checksum(mo_tmp_dbcsr) occ = cp_dbcsr_get_occupation(mo_tmp_dbcsr) IF(output_unit>0)WRITE(output_unit,*) 'S*C occ',occ,' checksum',checksum ! @@ -815,52 +803,50 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) ! the destroy is needed for the moment to avoid memory leaks ! ! This one is not needed because _destroy takes care of zeroing. CALL cp_dbcsr_multiply("N", "N", 1.0_dp, p_rmpv(ispin)%matrix,& - mo_tmp_dbcsr, 0.0_dp, mo_dbcsr, error=error) - IF(.FALSE.)CALL cp_dbcsr_verify_matrix(mo_dbcsr, error=error) - checksum = cp_dbcsr_checksum(mo_dbcsr, error=error) + mo_tmp_dbcsr, 0.0_dp, mo_dbcsr) + IF(.FALSE.)CALL cp_dbcsr_verify_matrix(mo_dbcsr) + checksum = cp_dbcsr_checksum(mo_dbcsr) occ = cp_dbcsr_get_occupation(mo_dbcsr) IF(output_unit>0)WRITE(output_unit,*) 'P*SC occ',occ,' checksum',checksum - CALL cp_dbcsr_filter(mo_dbcsr, eps, error=error) - !CALL cp_dbcsr_verify_matrix(mo_dbcsr, error=error) - checksum = cp_dbcsr_checksum(mo_dbcsr, error=error) + CALL cp_dbcsr_filter(mo_dbcsr, eps) + !CALL cp_dbcsr_verify_matrix(mo_dbcsr) + checksum = cp_dbcsr_checksum(mo_dbcsr) occ = cp_dbcsr_get_occupation(mo_dbcsr) IF(output_unit>0)WRITE(output_unit,*) 'P*SC occ',occ,' checksum',checksum ! - CALL copy_dbcsr_to_fm(mo_dbcsr, mo_coeff,error=error) + CALL copy_dbcsr_to_fm(mo_dbcsr, mo_coeff) - CALL cp_dbcsr_release(mo_dbcsr, error=error) - CALL cp_dbcsr_release(mo_tmp_dbcsr, error=error) + CALL cp_dbcsr_release(mo_dbcsr) + CALL cp_dbcsr_release(mo_tmp_dbcsr) ! and ortho the result - CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix,error=error) + CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix) END IF CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=qs_env%scf_control%smear,& - error=error) + smear=qs_env%scf_control%smear) CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,& - mo_array(ispin)%mo_set%mo_coeff_b,error=error)!fm->dbcsr + mo_array(ispin)%mo_set%mo_coeff_b)!fm->dbcsr CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,& - error=error) + p_rmpv(ispin)%matrix) DO ikind=1,SIZE(atomic_kind_set) IF(ASSOCIATED(pmat(ikind)%mat)) THEN DEALLOCATE (pmat(ikind)%mat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END DO END DO DEALLOCATE (pmat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (first_sgf,last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) did_guess = .TRUE. END IF @@ -871,7 +857,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) CALL get_mo_set(mo_set=mo_array(ispin)%mo_set, nelectron=nelectron) CALL calculate_mopac_dm(p_rmpv(ispin)%matrix,s_sparse(1)%matrix, has_unit_metric, dft_control,& - particle_set, atomic_kind_set, qs_kind_set, nspin, nelectron, para_env, error) + particle_set, atomic_kind_set, qs_kind_set, nspin, nelectron, para_env) ! The orbital transformation method (OT) requires not only an ! initial density matrix, but also an initial wavefunction (MO set) @@ -879,39 +865,37 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) IF (scf_control%use_ot .OR. scf_env%method==ot_diag_method_nr .OR. & (scf_env%method==block_krylov_diag_method_nr .AND. .NOT.do_std_diag)) THEN IF (dft_control%restricted.AND.(ispin == 2)) THEN - CALL mo_set_restrict(mo_array,error=error) + CALL mo_set_restrict(mo_array) ELSE CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff=mo_coeff,& nmo=nmo, homo=homo) - CALL cp_fm_init_random(mo_coeff,nmo,error=error) - CALL cp_fm_create(sv,mo_coeff%matrix_struct,"SV",error=error) + CALL cp_fm_init_random(mo_coeff,nmo) + CALL cp_fm_create(sv,mo_coeff%matrix_struct,"SV") ! multiply times PS IF (has_unit_metric) THEN - CALL cp_fm_to_fm(mo_coeff,sv,error=error) + CALL cp_fm_to_fm(mo_coeff,sv) ELSE - CALL cp_dbcsr_sm_fm_multiply(s_sparse(1)%matrix,mo_coeff,sv,nmo,error=error) + CALL cp_dbcsr_sm_fm_multiply(s_sparse(1)%matrix,mo_coeff,sv,nmo) END IF ! here we could easily multiply with the diag that we actually have replicated already - CALL cp_dbcsr_sm_fm_multiply(p_rmpv(ispin)%matrix,sv,mo_coeff,homo,error=error) - CALL cp_fm_release(sv,error=error) + CALL cp_dbcsr_sm_fm_multiply(p_rmpv(ispin)%matrix,sv,mo_coeff,homo) + CALL cp_fm_release(sv) ! and ortho the result IF (has_unit_metric) THEN - CALL make_basis_simple(mo_coeff,nmo,error=error) + CALL make_basis_simple(mo_coeff,nmo) ELSE - CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix,error=error) + CALL make_basis_sm(mo_coeff,nmo,s_sparse(1)%matrix) END IF END IF CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=qs_env%scf_control%smear,& - error=error) + smear=qs_env%scf_control%smear) CALL copy_fm_to_dbcsr(mo_array(ispin)%mo_set%mo_coeff,& - mo_array(ispin)%mo_set%mo_coeff_b,error=error) + mo_array(ispin)%mo_set%mo_coeff_b) CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,& - error=error) + p_rmpv(ispin)%matrix) END IF END DO @@ -920,7 +904,7 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) IF (density_guess == densities_guess) THEN ! Collocation of the density into the PW-grid - CALL collocate_atomic_charge_density(total_rho=total_rho, qs_env=qs_env, error=error) + CALL collocate_atomic_charge_density(total_rho=total_rho, qs_env=qs_env) ! do some assertions here on these matrices having the same structure, ! as is currently required @@ -928,16 +912,15 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) qs_env%scf_env%iter_count = 1 - CALL qs_ks_did_change(ks_env=qs_env%ks_env, rho_changed=.TRUE., error=error) + CALL qs_ks_did_change(ks_env=qs_env%ks_env, rho_changed=.TRUE.) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.TRUE.,& - just_energy=.FALSE., error=error) + just_energy=.FALSE.) ! diagonalization DO ispin=1, dft_control%nspins CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,& - qs_env%scf_env%scf_work1(ispin)%matrix,& - error=error) + qs_env%scf_env%scf_work1(ispin)%matrix) END DO qs_env%scf_env%iter_method = "Mixing/Diag" @@ -949,14 +932,11 @@ SUBROUTINE calculate_first_density_matrix(scf_env,qs_env,error) ortho=qs_env%scf_env%ortho, & work=qs_env%scf_env%scf_work2,& cholesky_method=scf_env%cholesky_method,& - use_jacobi=.FALSE.,& - error=error) + use_jacobi=.FALSE.) CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) CALL calculate_density_matrix(mo_array(ispin)%mo_set,& - p_rmpv(ispin)%matrix,& - error=error) + p_rmpv(ispin)%matrix) END DO did_guess = .TRUE. @@ -986,10 +966,9 @@ END SUBROUTINE calculate_first_density_matrix !> \param nspin ... !> \param nelectron_spin ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_atomic_block_dm(matrix_p,matrix_s, particle_set, atomic_kind_set, & - qs_kind_set, ispin, nspin, nelectron_spin, output_unit, error) + qs_kind_set, ispin, nspin, nelectron_spin, output_unit) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p, matrix_s TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set @@ -999,7 +978,6 @@ SUBROUTINE calculate_atomic_block_dm(matrix_p,matrix_s, particle_set, atomic_kin POINTER :: qs_kind_set INTEGER, INTENT(IN) :: ispin, nspin, nelectron_spin, & output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_atomic_block_dm', & routineP = moduleN//':'//routineN @@ -1024,17 +1002,17 @@ SUBROUTINE calculate_atomic_block_dm(matrix_p,matrix_s, particle_set, atomic_kin WRITE (UNIT=output_unit,FMT="(/,T2,A,I0)") "Spin ", ispin END IF - CALL cp_dbcsr_set(matrix_p,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_p,0.0_dp) natom = SIZE(particle_set) ALLOCATE (kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,kind_of=kind_of) ALLOCATE (pmat(SIZE(atomic_kind_set)),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! precompute the atomic blocks corresponding to spherical atoms DO ikind=1,SIZE(atomic_kind_set) @@ -1046,7 +1024,7 @@ SUBROUTINE calculate_atomic_block_dm(matrix_p,matrix_s, particle_set, atomic_kin "Guess for atomic kind: "//TRIM(atomic_kind%name) END IF CALL calculate_atomic_orbitals(atomic_kind,qs_kind,iunit=output_unit,pmat=pmat(ikind)%mat,& - ispin=ispin,error=error) + ispin=ispin) END DO scale = 1.0_dp @@ -1060,11 +1038,11 @@ SUBROUTINE calculate_atomic_block_dm(matrix_p,matrix_s, particle_set, atomic_kin ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_trace(matrix_p, matrix_s, trps1, error=error) + CALL cp_dbcsr_trace(matrix_p, matrix_s, trps1) scale = 0.0_dp IF(nelectron_spin>0)& ! could be a ghost-atoms-only simulation scale = REAL(nelectron_spin,dp)/trps1 - CALL cp_dbcsr_scale(matrix_p, scale, error=error) + CALL cp_dbcsr_scale(matrix_p, scale) IF (output_unit > 0) THEN IF (nspin > 1) THEN @@ -1081,15 +1059,15 @@ SUBROUTINE calculate_atomic_block_dm(matrix_p,matrix_s, particle_set, atomic_kin DO ikind=1,SIZE(atomic_kind_set) IF(ASSOCIATED(pmat(ikind)%mat)) THEN DEALLOCATE (pmat(ikind)%mat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (pmat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1107,11 +1085,10 @@ END SUBROUTINE calculate_atomic_block_dm !> \param nspin ... !> \param nelectron_spin ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & dft_control, particle_set, atomic_kind_set, qs_kind_set, & - nspin, nelectron_spin, para_env, error) + nspin, nelectron_spin, para_env) TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p, matrix_s LOGICAL :: has_unit_metric TYPE(dft_control_type), POINTER :: dft_control @@ -1123,7 +1100,6 @@ SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & POINTER :: qs_kind_set INTEGER, INTENT(IN) :: nspin, nelectron_spin TYPE(cp_para_env_type) :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_mopac_dm', & routineP = moduleN//':'//routineN @@ -1154,26 +1130,26 @@ SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & ENDIF ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL get_particle_set(particle_set,qs_kind_set,first_sgf=first_sgf,error=error) - CALL get_qs_kind_set(qs_kind_set, maxlgto=maxl, error=error) + CALL get_particle_set(particle_set,qs_kind_set,first_sgf=first_sgf) + CALL get_qs_kind_set(qs_kind_set, maxlgto=maxl) ALLOCATE (econf(0:maxl),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (pdiag(nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) pdiag(:) = 0.0_dp ALLOCATE (sdiag(nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) sdiag(:) = 0.0_dp IF (has_unit_metric) THEN sdiag(:) = 1.0_dp ELSE - CALL cp_dbcsr_get_diag(matrix_s, sdiag, error=error) + CALL cp_dbcsr_get_diag(matrix_s, sdiag) CALL mp_sum(sdiag,group) END IF @@ -1188,7 +1164,7 @@ SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom, atom_list=atom_list) CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set,& all_potential=all_potential,& - gth_potential=gth_potential, error=error) + gth_potential=gth_potential) IF ( dft_control%qs_control%dftb ) THEN CALL get_dftb_atom_param(qs_kind_set(ikind)%dftb_parameter,& @@ -1197,13 +1173,13 @@ SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & econf(0:maxl)=edftb(0:maxl) ELSEIF (ASSOCIATED(all_potential)) THEN CALL get_atomic_kind(atomic_kind_set(ikind), z=z) - CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff) maxll = MIN(SIZE(elec_conf) - 1,maxl) econf(:) = 0.0_dp econf(0:maxll) = 0.5_dp*maxocc*REAL(elec_conf(0:maxll),dp) ELSE IF (ASSOCIATED(gth_potential)) THEN CALL get_atomic_kind(atomic_kind_set(ikind), z=z) - CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), nsgf=nsgf, elec_conf=elec_conf, zeff=zeff) maxll = MIN(SIZE(elec_conf) - 1,maxl) econf(:) = 0.0_dp econf(0:maxll) = 0.5_dp*maxocc*REAL(elec_conf(0:maxll),dp) @@ -1239,7 +1215,7 @@ SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & pdiag(isgfa+14) = econf(3)/7._dp pdiag(isgfa+15) = econf(3)/7._dp CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO END DO @@ -1296,7 +1272,7 @@ SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & END IF END IF CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO ELSE @@ -1350,19 +1326,19 @@ SUBROUTINE calculate_mopac_dm(matrix_p,matrix_s, has_unit_metric, & END IF END IF - CALL cp_dbcsr_set_diag(matrix_p, pdiag, error=error) + CALL cp_dbcsr_set_diag(matrix_p, pdiag) DEALLOCATE (econf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (pdiag,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (sdiag,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/qs_integral_utils.F b/src/qs_integral_utils.F index 55d9f15867..ad7c18ee1c 100644 --- a/src/qs_integral_utils.F +++ b/src/qs_integral_utils.F @@ -44,15 +44,13 @@ MODULE qs_integral_utils !> \brief Return the maximum memory usage in integral calculations !> \param qs_kind_set The info for all atomic kinds !> \param basis_type_a Type of basis -!> \param error ... !> \retval ldmem Result ! ***************************************************************************** - FUNCTION get_memory_usage_a(qs_kind_set,basis_type_a,error) RESULT(ldmem) + FUNCTION get_memory_usage_a(qs_kind_set,basis_type_a) RESULT(ldmem) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set CHARACTER(LEN=*), INTENT(IN) :: basis_type_a - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ldmem CHARACTER(len=*), PARAMETER :: routineN = 'get_memory_usage_a', & @@ -62,7 +60,7 @@ FUNCTION get_memory_usage_a(qs_kind_set,basis_type_a,error) RESULT(ldmem) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxc, maxlgto=maxl, maxsgf=maxs,& - basis_type=basis_type_a,error=error) + basis_type=basis_type_a) ldmem = MAX(maxc,maxs) CALL init_orbital_pointers(maxl+2) @@ -74,15 +72,13 @@ END FUNCTION get_memory_usage_a !> \param qs_kind_set The info for all atomic kinds !> \param basis_type_a Type of basis !> \param basis_type_b Type of basis -!> \param error ... !> \retval ldmem Result ! ***************************************************************************** - FUNCTION get_memory_usage_ab(qs_kind_set,basis_type_a,basis_type_b,error) RESULT(ldmem) + FUNCTION get_memory_usage_ab(qs_kind_set,basis_type_a,basis_type_b) RESULT(ldmem) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set CHARACTER(LEN=*), INTENT(IN) :: basis_type_a, basis_type_b - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ldmem CHARACTER(len=*), PARAMETER :: routineN = 'get_memory_usage_ab', & @@ -90,8 +86,8 @@ FUNCTION get_memory_usage_ab(qs_kind_set,basis_type_a,basis_type_b,error) RESULT INTEGER :: lda, ldb - lda = get_memory_usage_a(qs_kind_set,basis_type_a,error) - ldb = get_memory_usage_a(qs_kind_set,basis_type_b,error) + lda = get_memory_usage_a(qs_kind_set,basis_type_a) + ldb = get_memory_usage_a(qs_kind_set,basis_type_b) ldmem = MAX(lda,ldb) END FUNCTION get_memory_usage_ab @@ -102,17 +98,15 @@ END FUNCTION get_memory_usage_ab !> \param basis_type_a Type of basis !> \param basis_type_b Type of basis !> \param basis_type_c Type of basis -!> \param error ... !> \retval ldmem Result ! ***************************************************************************** FUNCTION get_memory_usage_abc(qs_kind_set,basis_type_a,& - basis_type_b,basis_type_c,error) RESULT(ldmem) + basis_type_b,basis_type_c) RESULT(ldmem) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set CHARACTER(LEN=*), INTENT(IN) :: basis_type_a, basis_type_b, & basis_type_c - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ldmem CHARACTER(len=*), PARAMETER :: routineN = 'get_memory_usage_abc', & @@ -120,9 +114,9 @@ FUNCTION get_memory_usage_abc(qs_kind_set,basis_type_a,& INTEGER :: lda, ldb, ldc - lda = get_memory_usage_a(qs_kind_set,basis_type_a,error) - ldb = get_memory_usage_a(qs_kind_set,basis_type_b,error) - ldc = get_memory_usage_a(qs_kind_set,basis_type_c,error) + lda = get_memory_usage_a(qs_kind_set,basis_type_a) + ldb = get_memory_usage_a(qs_kind_set,basis_type_b) + ldc = get_memory_usage_a(qs_kind_set,basis_type_c) ldmem = MAX(lda,ldb,ldc) END FUNCTION get_memory_usage_abc @@ -134,17 +128,15 @@ END FUNCTION get_memory_usage_abc !> \param basis_type_b Type of basis !> \param basis_type_c Type of basis !> \param basis_type_d Type of basis -!> \param error ... !> \retval ldmem Result ! ***************************************************************************** FUNCTION get_memory_usage_abcd(qs_kind_set,basis_type_a,& - basis_type_b,basis_type_c,basis_type_d,error) RESULT(ldmem) + basis_type_b,basis_type_c,basis_type_d) RESULT(ldmem) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set CHARACTER(LEN=*), INTENT(IN) :: basis_type_a, basis_type_b, & basis_type_c, basis_type_d - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ldmem CHARACTER(len=*), PARAMETER :: routineN = 'get_memory_usage_abcd', & @@ -152,10 +144,10 @@ FUNCTION get_memory_usage_abcd(qs_kind_set,basis_type_a,& INTEGER :: lda, ldb, ldc, ldd - lda = get_memory_usage_a(qs_kind_set,basis_type_a,error) - ldb = get_memory_usage_a(qs_kind_set,basis_type_b,error) - ldc = get_memory_usage_a(qs_kind_set,basis_type_c,error) - ldd = get_memory_usage_a(qs_kind_set,basis_type_d,error) + lda = get_memory_usage_a(qs_kind_set,basis_type_a) + ldb = get_memory_usage_a(qs_kind_set,basis_type_b) + ldc = get_memory_usage_a(qs_kind_set,basis_type_c) + ldd = get_memory_usage_a(qs_kind_set,basis_type_d) ldmem = MAX(lda,ldb,ldc,ldd) END FUNCTION get_memory_usage_abcd @@ -167,16 +159,14 @@ END FUNCTION get_memory_usage_abcd !> \param basis_set_list The basis set list !> \param basis_type ... !> \param qs_kind_set Kind information, the basis is used -!> \param error ... ! ***************************************************************************** - SUBROUTINE basis_set_list_setup(basis_set_list,basis_type,qs_kind_set,error) + SUBROUTINE basis_set_list_setup(basis_set_list,basis_type,qs_kind_set) TYPE(gto_basis_set_p_type), & DIMENSION(:), POINTER :: basis_set_list CHARACTER(len=*), INTENT(IN) :: basis_type TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'basis_set_list_setup', & routineP = moduleN//':'//routineN @@ -190,7 +180,7 @@ SUBROUTINE basis_set_list_setup(basis_set_list,basis_type,qs_kind_set,error) DO ikind=1,SIZE(qs_kind_set) qs_kind => qs_kind_set(ikind) CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set,& - basis_type=basis_type,error=error) + basis_type=basis_type) NULLIFY(basis_set_list(ikind)%gto_basis_set) IF (ASSOCIATED(basis_set)) basis_set_list(ikind)%gto_basis_set => basis_set END DO diff --git a/src/qs_integrate_potential_low.F b/src/qs_integrate_potential_low.F index 9e0a4bbb2e..da96b72c21 100644 --- a/src/qs_integrate_potential_low.F +++ b/src/qs_integrate_potential_low.F @@ -69,7 +69,6 @@ MODULE qs_integrate_potential_low !> \param a_hdab ... !> \param use_subpatch ... !> \param subpatch_pattern ... -!> \param error ... ! ***************************************************************************** SUBROUTINE integrate_pgf_product_rspace(la_max,zeta,la_min,& lb_max,zetb,lb_min,& @@ -79,7 +78,7 @@ SUBROUTINE integrate_pgf_product_rspace(la_max,zeta,la_min,& calculate_forces,hdab,hadb,force_a,force_b,& compute_tau,map_consistent,& collocate_rho0,rpgf0_s,use_virial,my_virial_a,& - my_virial_b,a_hdab,use_subpatch,subpatch_pattern,error) + my_virial_b,a_hdab,use_subpatch,subpatch_pattern) INTEGER, INTENT(IN) :: la_max REAL(KIND=dp), INTENT(IN) :: zeta @@ -107,7 +106,6 @@ SUBROUTINE integrate_pgf_product_rspace(la_max,zeta,la_min,& LOGICAL, INTENT(IN), OPTIONAL :: use_virial REAL(KIND=dp), DIMENSION(3,3), OPTIONAL :: my_virial_a, my_virial_b REAL(KIND=dp), DIMENSION(:,:,:,:), OPTIONAL, POINTER :: a_hdab - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, OPTIONAL :: use_subpatch INTEGER(KIND=int_8), INTENT(IN), OPTIONAL :: subpatch_pattern @@ -153,7 +151,7 @@ SUBROUTINE integrate_pgf_product_rspace(la_max,zeta,la_min,& IF(PRESENT(use_subpatch)) THEN IF(use_subpatch)THEN subpatch_integrate = .TRUE. - CPPrecondition(PRESENT(subpatch_pattern),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(subpatch_pattern),cp_failure_level,routineP,failure) ENDIF ENDIF @@ -393,7 +391,7 @@ SUBROUTINE integrate_ortho() offset=MODULO(cubecenter(i)+lb_cube(i)+rsgrid%desc%lb(i)-rsgrid%lb_local(i),ng(i))+1-lb_cube(i) ! check for out of bounds IF (ub_cube(i)+offset>UBOUND(grid,i).OR.lb_cube(i)+offset \param basis_type ... !> \param pw_env_external ... !> \param task_list_external ... -!> \param error ... !> \par History !> IAB (29-Apr-2010): Added OpenMP parallelisation to task loop !> (c) The Numerical Algorithms Group (NAG) Ltd, 2010 on behalf of the HECToR project @@ -132,7 +131,7 @@ MODULE qs_integrate_potential_product ! ***************************************************************************** SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & qs_env, calculate_forces, force_adm, ispin, & - compute_tau, gapw, basis_type, pw_env_external, task_list_external, error) + compute_tau, gapw, basis_type, pw_env_external, task_list_external) TYPE(pw_p_type) :: v_rspace TYPE(cp_dbcsr_p_type), INTENT(INOUT), & @@ -151,7 +150,6 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & CHARACTER(len=*), INTENT(IN), OPTIONAL :: basis_type TYPE(pw_env_type), OPTIONAL, POINTER :: pw_env_external TYPE(task_list_type), OPTIONAL, POINTER :: task_list_external - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'integrate_v_rspace', & routineP = moduleN//':'//routineN @@ -221,13 +219,13 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & CALL timeset(routineN,handle) ! we test here if the provided operator matrices are consistent - CPPrecondition(PRESENT(hmat) .OR. PRESENT(hmat_kp),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(hmat) .OR. PRESENT(hmat_kp),cp_failure_level,routineP,failure) do_kp = .FALSE. IF(PRESENT(hmat_kp)) do_kp = .TRUE. IF(PRESENT(pmat)) THEN - CPPrecondition(PRESENT(hmat),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(hmat),cp_failure_level,routineP,failure) ELSE IF(PRESENT(pmat_kp)) THEN - CPPrecondition(PRESENT(hmat_kp),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(hmat_kp),cp_failure_level,routineP,failure) END IF failure=.FALSE. @@ -264,22 +262,20 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & CASE ("ORB") CALL get_qs_env(qs_env=qs_env,& task_list=task_list,& - task_list_soft=task_list_soft,& - error=error) + task_list_soft=task_list_soft) CASE ("AUX_FIT") CALL get_qs_env(qs_env=qs_env,& task_list_aux_fit=task_list,& - task_list_soft=task_list_soft,& - error=error) + task_list_soft=task_list_soft) END SELECT IF (my_gapw) task_list=>task_list_soft IF (PRESENT(task_list_external)) task_list=>task_list_external - CPPrecondition(ASSOCIATED(task_list),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(task_list),cp_failure_level,routineP,failure) ! the information on the grids is provided through pw_env ! pw_env has to be the parent env for the potential grid (input) ! there is an option to provide an external grid - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) IF (PRESENT(pw_env_external)) pw_env=>pw_env_external ! get all the general information on the system we are working on @@ -290,11 +286,11 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & dft_control=dft_control,& particle_set=particle_set,& force=force,& - virial=virial,error=error) + virial=virial) admm_scal_fac = 1.0_dp IF(my_force_adm) THEN - CALL get_qs_env(qs_env=qs_env,admm_env=admm_env,error=error) + CALL get_qs_env(qs_env=qs_env,admm_env=admm_env) ! Calculate bare scaling of force according to Merlot, 1. IF: ADMMP, 2. IF: ADMMS, IF( ( .NOT. admm_env%charge_constrain) .AND. & (admm_env%scaling_model == do_admm_exch_scaling_merlot ) ) THEN @@ -311,10 +307,10 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & atom_pair_send=>task_list%atom_pair_send atom_pair_recv=>task_list%atom_pair_recv - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_v, error=error) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_v) DO i=1,SIZE(rs_v) - CALL rs_grid_retain(rs_v(i)%rs_grid,error=error) + CALL rs_grid_retain(rs_v(i)%rs_grid) END DO ! assign from pw_env @@ -322,11 +318,11 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & cube_info=>pw_env%cube_info ! transform the potential on the rs_multigrids - CALL potential_pw2rs(rs_v,v_rspace,pw_env,error) + CALL potential_pw2rs(rs_v,v_rspace,pw_env) nimages = dft_control%nimages IF(nimages > 1) THEN - CPPrecondition(do_kp,cp_failure_level,routineP,error,failure) + CPPrecondition(do_kp,cp_failure_level,routineP,failure) END IF nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -334,7 +330,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & IF (calculate_forces) THEN ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, atom_of_kind=atom_of_kind) END IF @@ -352,7 +348,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxco,& maxsgf_set=maxsgf_set,& - basis_type=my_basis_type,error=error) + basis_type=my_basis_type) distributed_grids = .FALSE. DO igrid_level = 1, gridlevel_info%ngrid_levels @@ -364,7 +360,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & ! initialize the working hmat structures h_duplicated = .FALSE. ALLOCATE(dhmat(nimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(do_kp) THEN DO img=1,nimages dhmat(img)%matrix => hmat_kp(img)%matrix @@ -378,13 +374,12 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & DO img=1,nimages NULLIFY(dhmat(img)%matrix) ALLOCATE(dhmat(img)%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(dhmat(img)%matrix, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(dhmat(img)%matrix) CALL cp_dbcsr_create(dhmat(img)%matrix, 'LocalH', & cp_dbcsr_distribution (href),& cp_dbcsr_get_matrix_type (href), cp_dbcsr_row_block_sizes(href),& - cp_dbcsr_col_block_sizes(href), cp_dbcsr_get_data_size(href),& - error=error) + cp_dbcsr_col_block_sizes(href), cp_dbcsr_get_data_size(href)) END DO END IF @@ -392,7 +387,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & IF ( pab_required ) THEN ! initialize the working pmat structures ALLOCATE(deltap(nimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(do_kp) THEN DO img=1,nimages deltap(img)%matrix => pmat_kp(img)%matrix @@ -405,15 +400,15 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & DO img=1,nimages NULLIFY(deltap(img)%matrix) ALLOCATE(deltap(img)%matrix,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(deltap(img)%matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(deltap(img)%matrix) END DO IF(do_kp) THEN DO img=1,nimages - CALL cp_dbcsr_copy(deltap(img)%matrix,pmat_kp(img)%matrix,name="LocalP",error=error) + CALL cp_dbcsr_copy(deltap(img)%matrix,pmat_kp(img)%matrix,name="LocalP") END DO ELSE - CALL cp_dbcsr_copy(deltap(1)%matrix,pmat%matrix,name="LocalP",error=error) + CALL cp_dbcsr_copy(deltap(1)%matrix,pmat%matrix,name="LocalP") END IF END IF END IF @@ -428,7 +423,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & IF (pab_required) THEN CALL reallocate(pabt,1,maxco,1,maxco,0,nthread) ELSE - CPPrecondition(.NOT.calculate_forces,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.calculate_forces,cp_failure_level,routineP,failure) END IF NULLIFY(hdabt,hadbt,hdab,hadb) @@ -440,7 +435,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & DO ikind=1,nkind CALL get_qs_kind(qs_kind_set(ikind),& softb = my_gapw, & - basis_set=orb_basis_set,basis_type=my_basis_type,error=error) + basis_set=orb_basis_set,basis_type=my_basis_type) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE @@ -453,12 +448,12 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & IF (distributed_grids .AND. pab_required) THEN CALL rs_distribute_matrix (rs_descs, deltap, atom_pair_send, atom_pair_recv, & - natom, nimages, scatter=.TRUE., error=error) + natom, nimages, scatter=.TRUE.) ENDIF IF (debug_this_module) THEN ALLOCATE(block_touched(natom,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !$omp parallel default(none), & @@ -472,7 +467,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & !$omp private(ikind_old,jkind_old,iatom,jatom,iset,jset,ikind,jkind,ilevel,ipgf,jpgf), & !$omp private(img,brow,bcol,orb_basis_set,first_sgfa,la_max,la_min,npgfa,nseta,nsgfa), & !$omp private(rpgfa,set_radius_a,sphi_a,zeta,first_sgfb,lb_max,lb_min,npgfb), & -!$omp private(nsetb,nsgfb,rpgfb,set_radius_b,sphi_b,zetb,found,error,atom_a,atom_b), & +!$omp private(nsetb,nsgfb,rpgfb,set_radius_b,sphi_b,zetb,found,atom_a,atom_b), & !$omp private(force_a,force_b,my_virial_a,my_virial_b,atom_pair_changed,h_block), & !$omp private(p_block,ncoa,sgfa,ncob,sgfb,rab,rab2,ra,rb,zetp,dab,igrid_level), & !$omp private(na1,na2,nb1,nb2,use_subpatch,rab_inv,new_set_pair_coming,atom_pair_done), & @@ -498,10 +493,10 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & loop_gridlevels: DO igrid_level = 1, gridlevel_info%ngrid_levels DO img=1,nimages - CALL cp_dbcsr_work_create(dhmat(img)%matrix,work_mutable=.TRUE.,n=nthread,error=error) + CALL cp_dbcsr_work_create(dhmat(img)%matrix,work_mutable=.TRUE.,n=nthread) !$ CALL cp_assert (dbcsr_distribution_has_threads(cp_dbcsr_distribution(dhmat(img)%matrix)),& -!$ cp_fatal_level,cp_internal_error,routineN,"No thread distribution defined.",& -!$ error=error) +!$ cp_fatal_level,cp_internal_error,routineN,"No thread distribution defined.") +!$ END DO !$omp barrier @@ -518,7 +513,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & CALL int2pair(tasks(3,itask),ilevel,img,iatom,jatom,iset,jset,ipgf,jpgf,& nimages,natom,maxset,maxpgf) - CPPrecondition((img==1 .OR. do_kp),cp_failure_level,routineP,error,failure) + CPPrecondition((img==1 .OR. do_kp),cp_failure_level,routineP,failure) ! At the start of a block of tasks, get atom data (and kind data, if needed) IF (itask .EQ. task_list%taskstart(ipair,igrid_level) ) THEN @@ -539,7 +534,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & IF (ikind .NE. ikind_old ) THEN CALL get_qs_kind(qs_kind_set(ikind),& softb = my_gapw, & - basis_set=orb_basis_set,basis_type=my_basis_type,error=error) + basis_set=orb_basis_set,basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfa,& @@ -557,7 +552,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & IF (jkind .NE. jkind_old ) THEN CALL get_qs_kind(qs_kind_set(jkind),& softb = my_gapw, & - basis_set=orb_basis_set,basis_type=my_basis_type,error=error) + basis_set=orb_basis_set,basis_type=my_basis_type) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfb,& lmax=lb_max,& @@ -585,13 +580,13 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & NULLIFY(h_block) CALL cp_dbcsr_get_block_p(dhmat(img)%matrix,brow,bcol,h_block,found) IF (.NOT.ASSOCIATED(h_block)) THEN - CALL cp_dbcsr_add_block_node ( dhmat(img)%matrix, brow, bcol, h_block ,error=error) + CALL cp_dbcsr_add_block_node ( dhmat(img)%matrix, brow, bcol, h_block) END IF IF (pab_required) THEN CALL cp_dbcsr_get_block_p(matrix=deltap(img)%matrix,& row=brow,col=bcol,BLOCK=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END IF IF (calculate_forces) THEN @@ -695,7 +690,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & force_a=force_a,force_b=force_b,& compute_tau=my_compute_tau,map_consistent=map_consistent,& use_virial=use_virial,my_virial_a=my_virial_a,& - my_virial_b=my_virial_b,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask),error=error) + my_virial_b=my_virial_b,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask)) ELSE rab_inv=-rab CALL integrate_pgf_product_rspace(& @@ -709,7 +704,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & force_a=force_b,force_b=force_a,& compute_tau=my_compute_tau,map_consistent=map_consistent,& use_virial=use_virial,my_virial_a=my_virial_b,& - my_virial_b=my_virial_a,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask),error=error) + my_virial_b=my_virial_a,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask)) END IF ELSE IF (iatom <= jatom) THEN @@ -723,7 +718,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & calculate_forces=calculate_forces,& force_a=force_a,force_b=force_b,& compute_tau=my_compute_tau,& - map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask),error=error) + map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask)) ELSE rab_inv=-rab CALL integrate_pgf_product_rspace(& @@ -736,7 +731,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & calculate_forces=calculate_forces,& force_a=force_b,force_b=force_a, & compute_tau=my_compute_tau,& - map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask),error=error) + map_consistent=map_consistent,use_subpatch=use_subpatch,subpatch_pattern=tasks(6,itask)) END IF END IF @@ -803,7 +798,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & !$omp end do DO img=1,nimages - CALL cp_dbcsr_finalize(dhmat(img)%matrix, error=error) + CALL cp_dbcsr_finalize(dhmat(img)%matrix) END DO END DO loop_gridlevels @@ -812,7 +807,7 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & IF (debug_this_module) THEN DEALLOCATE(block_touched,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF ( h_duplicated ) THEN @@ -821,59 +816,59 @@ SUBROUTINE integrate_v_rspace(v_rspace, hmat, hmat_kp, pmat, pmat_kp, & scatter = .FALSE. IF(do_kp) THEN CALL rs_distribute_matrix (rs_descs, dhmat, atom_pair_recv, atom_pair_send,& - natom, nimages, scatter, hmats=hmat_kp, error=error) + natom, nimages, scatter, hmats=hmat_kp) ELSE ALLOCATE(htemp(1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) htemp(1)%matrix => hmat%matrix CALL rs_distribute_matrix (rs_descs, dhmat, atom_pair_recv, atom_pair_send,& - natom, nimages, scatter, hmats=htemp, error=error) + natom, nimages, scatter, hmats=htemp) NULLIFY(htemp(1)%matrix) DEALLOCATE(htemp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL cp_dbcsr_deallocate_matrix_set ( dhmat ,error=error) + CALL cp_dbcsr_deallocate_matrix_set ( dhmat) ELSE DO img=1,nimages NULLIFY ( dhmat(img)%matrix ) END DO DEALLOCATE(dhmat,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF ( pab_required ) THEN IF ( p_duplicated ) THEN - CALL cp_dbcsr_deallocate_matrix_set ( deltap ,error=error) + CALL cp_dbcsr_deallocate_matrix_set ( deltap) ELSE DO img=1,nimages NULLIFY ( deltap(img)%matrix ) END DO DEALLOCATE(deltap,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF ! *** Release work storage *** DEALLOCATE (habt,workt,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF ( pab_required ) THEN DEALLOCATE (pabt,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(rs_v)) THEN DO i=1,SIZE(rs_v) - CALL rs_grid_release(rs_v(i)%rs_grid, error=error) + CALL rs_grid_release(rs_v(i)%rs_grid) END DO END IF IF (calculate_forces) THEN DEALLOCATE (atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) diff --git a/src/qs_integrate_potential_single.F b/src/qs_integrate_potential_single.F index df5c11fd4b..25a500f1c2 100644 --- a/src/qs_integrate_potential_single.F +++ b/src/qs_integrate_potential_single.F @@ -105,15 +105,13 @@ MODULE qs_integrate_potential_single !> \param qs_env ... !> \param scpv ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE integrate_scp_rspace(scp_pot,qs_env,scpv,calculate_forces,error) + SUBROUTINE integrate_scp_rspace(scp_pot,qs_env,scpv,calculate_forces) TYPE(pw_p_type), INTENT(INOUT) :: scp_pot TYPE(qs_environment_type), POINTER :: qs_env TYPE(scp_vector_type), POINTER :: scpv LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'integrate_scp_rspace', & routineP = moduleN//':'//routineN @@ -149,11 +147,11 @@ SUBROUTINE integrate_scp_rspace(scp_pot,qs_env,scpv,calculate_forces,error) failure=.FALSE. NULLIFY(pw_env,cores) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v,error=error) - CALL rs_grid_retain(rs_v,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v) + CALL rs_grid_retain(rs_v) - CALL rs_pw_transfer(rs_v,scp_pot%pw,pw2rs,error=error) + CALL rs_pw_transfer(rs_v,scp_pot%pw,pw2rs) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& @@ -162,7 +160,7 @@ SUBROUTINE integrate_scp_rspace(scp_pot,qs_env,scpv,calculate_forces,error) dft_control=dft_control,& particle_set=particle_set,& pw_env=pw_env,& - force=force,virial=virial,error=error) + force=force,virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer).AND.calculate_forces @@ -172,18 +170,18 @@ SUBROUTINE integrate_scp_rspace(scp_pot,qs_env,scpv,calculate_forces,error) DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom_of_kind, atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,defined=defined,lmaxscp=lmaxscp,ag=alpha) IF (.NOT.defined) CYCLE ni = ncoset(lmaxscp) ALLOCATE(hab(ni,1),pab(ni,1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) pab = 0._dp hab = 0._dp ALLOCATE(cores(natom_of_kind),STAT=ierr) - CPPrecondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPrecondition(ierr==0,cp_failure_level,routineP,failure) cores = 0 npme = 0 @@ -236,7 +234,7 @@ SUBROUTINE integrate_scp_rspace(scp_pot,qs_env,scpv,calculate_forces,error) eps_gvg_rspace=eps_rho_rspace,& calculate_forces=calculate_forces,force_a=force_a,& force_b=force_b,use_virial=use_virial,my_virial_a=my_virial_a,& - my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8) DO l=0,lmaxscp pp = (2._dp*l+3._dp)/2._dp @@ -261,11 +259,11 @@ SUBROUTINE integrate_scp_rspace(scp_pot,qs_env,scpv,calculate_forces,error) END DO DEALLOCATE(cores,hab,pab,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) CALL timestop(handle) @@ -274,12 +272,10 @@ END SUBROUTINE integrate_scp_rspace !> \brief computes the forces/virial due to the local pseudopotential !> \param rho_rspace ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) + SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: rho_rspace TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'integrate_ppl_rspace', & routineP = moduleN//':'//routineN @@ -314,11 +310,11 @@ SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) failure=.FALSE. NULLIFY(pw_env,cores) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v,error=error) - CALL rs_grid_retain(rs_v,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v) + CALL rs_grid_retain(rs_v) - CALL rs_pw_transfer(rs_v,rho_rspace%pw,pw2rs,error=error) + CALL rs_pw_transfer(rs_v,rho_rspace%pw,pw2rs) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& @@ -327,7 +323,7 @@ SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) dft_control=dft_control,& particle_set=particle_set,& pw_env=pw_env,& - force=force,virial=virial,error=error) + force=force,virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -336,7 +332,7 @@ SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind),natom=natom_of_kind,atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind),gth_potential=gth_potential,error=error) + CALL get_qs_kind(qs_kind_set(ikind),gth_potential=gth_potential) IF (.NOT.ASSOCIATED(gth_potential)) CYCLE CALL get_potential(potential=gth_potential,alpha_ppl=alpha,nexp_ppl=lppl,cexp_ppl=cexp_ppl) @@ -345,7 +341,7 @@ SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) ni = ncoset(2*lppl-2) ALLOCATE(hab(ni,1),pab(ni,1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) pab = 0._dp CALL reallocate ( cores, 1, natom_of_kind ) @@ -399,7 +395,7 @@ SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) n = coset(2,2,2) pab(n,1) = 6._dp*cexp_ppl(4) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO @@ -438,7 +434,7 @@ SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) eps_gvg_rspace=eps_rho_rspace,& calculate_forces=.TRUE.,force_a=force_a,& force_b=force_b,use_virial=use_virial,my_virial_a=my_virial_a,& - my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8) force(ikind)%gth_ppl(:,iatom) =& force(ikind)%gth_ppl(:,iatom) + force_a(:)*rho_rspace%pw%pw_grid%dvol @@ -447,19 +443,19 @@ SUBROUTINE integrate_ppl_rspace(rho_rspace,qs_env,error) virial%pv_virial = virial%pv_virial + my_virial_a*rho_rspace%pw%pw_grid%dvol CALL cp_unimplemented_error(fromWhere=routineP, & message="Virial not debuged for CORE_PPL", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO DEALLOCATE(hab,pab,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) DEALLOCATE(cores,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -469,12 +465,10 @@ END SUBROUTINE integrate_ppl_rspace !> \brief computes the forces/virial due to the nlcc pseudopotential !> \param rho_rspace ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) + SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: rho_rspace TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'integrate_rho_nlcc', & routineP = moduleN//':'//routineN @@ -510,11 +504,11 @@ SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) failure=.FALSE. NULLIFY(pw_env,cores) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v,error=error) - CALL rs_grid_retain(rs_v,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v) + CALL rs_grid_retain(rs_v) - CALL rs_pw_transfer(rs_v,rho_rspace%pw,pw2rs,error=error) + CALL rs_pw_transfer(rs_v,rho_rspace%pw,pw2rs) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& @@ -523,7 +517,7 @@ SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) dft_control=dft_control,& particle_set=particle_set,& pw_env=pw_env,& - force=force,virial=virial,error=error) + force=force,virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -532,7 +526,7 @@ SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) DO ikind=1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind),natom=natom,atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind),gth_potential=gth_potential,error=error) + CALL get_qs_kind(qs_kind_set(ikind),gth_potential=gth_potential) IF (.NOT.ASSOCIATED(gth_potential)) CYCLE CALL get_potential(potential=gth_potential,nlcc_present=nlcc,nexp_nlcc=nexp_nlcc,& @@ -551,7 +545,7 @@ SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) ithread=0 ALLOCATE(hab(ni,1),pab(ni,1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) pab = 0._dp CALL reallocate ( cores, 1, natom ) @@ -605,7 +599,7 @@ SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) n = coset(2,2,2) pab(n,1) = 6._dp*cval_nlcc(4,iexp_nlcc)/alpha**6 CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO IF(dft_control%nspins==2)pab=pab*0.5_dp @@ -645,7 +639,7 @@ SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) eps_gvg_rspace=eps_rho_rspace,& calculate_forces=.TRUE.,force_a=force_a,& force_b=force_b,use_virial=use_virial,my_virial_a=my_virial_a,& - my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8) force(ikind)%gth_nlcc(:,iatom) =& force(ikind)%gth_nlcc(:,iatom) + force_a(:)*rho_rspace%pw%pw_grid%dvol @@ -656,16 +650,16 @@ SUBROUTINE integrate_rho_nlcc(rho_rspace,qs_env,error) END DO DEALLOCATE(hab,pab,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO END DO - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) DEALLOCATE(cores,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -676,12 +670,10 @@ END SUBROUTINE integrate_rho_nlcc !> grid !> \param v_rspace ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env,error) + SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env) TYPE(pw_p_type), INTENT(INOUT) :: v_rspace TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'integrate_v_core_rspace', & routineP = moduleN//':'//routineN @@ -715,7 +707,7 @@ SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env,error) CALL timeset(routineN,handle) NULLIFY(virial, atprop, dft_control) - CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env=qs_env, dft_control=dft_control) !If gapw, check for gpw kinds skip_fcore = .FALSE. @@ -727,17 +719,17 @@ SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env,error) IF(.NOT. skip_fcore) THEN NULLIFY(pw_env) ALLOCATE (cores(1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (hab(1,1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (pab(1,1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v,error=error) - CALL rs_grid_retain(rs_v,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env=pw_env,auxbas_rs_grid=rs_v) + CALL rs_grid_retain(rs_v) - CALL rs_pw_transfer(rs_v,v_rspace%pw,pw2rs,error=error) + CALL rs_pw_transfer(rs_v,v_rspace%pw,pw2rs) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& @@ -748,13 +740,12 @@ SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env,error) pw_env=pw_env,& force=force,& virial=virial,& - atprop=atprop,& - error=error) + atprop=atprop) ! atomic energy contributions IF(ASSOCIATED(atprop)) THEN natom = SIZE(particle_set) - CALL atprop_array_init(atprop%ateb,natom,error) + CALL atprop_array_init(atprop%ateb,natom) END IF use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -766,7 +757,7 @@ SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env,error) CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom_of_kind, atom_list=atom_list) CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom,& alpha_core_charge=alpha_core_charge,& - ccore_charge=ccore_charge,error=error) + ccore_charge=ccore_charge) IF(paw_atom) THEN force(ikind)%rho_core(:,:) = 0.0_dp @@ -818,7 +809,7 @@ SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env,error) eps_gvg_rspace=eps_rho_rspace,& calculate_forces=.TRUE.,force_a=force_a,& force_b=force_b,use_virial=use_virial,my_virial_a=my_virial_a,& - my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + my_virial_b=my_virial_b,use_subpatch=.TRUE.,subpatch_pattern=0_int_8) IF (ASSOCIATED(force)) THEN force(ikind)%rho_core(:,iatom) =& @@ -836,10 +827,10 @@ SUBROUTINE integrate_v_core_rspace(v_rspace,qs_env,error) END DO - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) DEALLOCATE (hab,pab,cores,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -854,17 +845,15 @@ END SUBROUTINE integrate_v_core_rspace !> \param qs_env ... !> \param int_res ... !> \param calculate_forces ... -!> \param error ... !> \author Dorothea Golze ! ***************************************************************************** SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& - calculate_forces,error) + calculate_forces) TYPE(pw_p_type), INTENT(IN) :: v_rspace TYPE(qs_environment_type), POINTER :: qs_env TYPE(lri_kind_type), DIMENSION(:), & POINTER :: int_res LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'integrate_v_rspace_one_center', & @@ -912,17 +901,17 @@ SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& failure = .FALSE. - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) - CALL pw_env_get(pw_env, rs_grids=rs_v, error=error) + CALL pw_env_get(pw_env, rs_grids=rs_v) DO i=1,SIZE(rs_v) - CALL rs_grid_retain(rs_v(i)%rs_grid,error=error) + CALL rs_grid_retain(rs_v(i)%rs_grid) CALL rs_grid_zero(rs_v(i)%rs_grid) END DO gridlevel_info=>pw_env%gridlevel_info - CALL potential_pw2rs(rs_v,v_rspace,pw_env,error) + CALL potential_pw2rs(rs_v,v_rspace,pw_env) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& @@ -932,7 +921,7 @@ SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& nkind=nkind,& particle_set=particle_set,& para_env=para_env,pw_env=pw_env,& - virial=virial,error=error) + virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -951,7 +940,7 @@ SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom_of_kind, atom_list=atom_list) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=lri_basis_set,basis_type="LRI",error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=lri_basis_set,basis_type="LRI") CALL get_gto_basis_set(gto_basis_set=lri_basis_set,& first_sgf=first_sgfa,& lmax=la_max,& @@ -1040,8 +1029,7 @@ SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& cube_info=pw_env%cube_info(igrid_level),& hab=hab,o1=na1,o2=0, eps_gvg_rspace=eps_rho_rspace,& calculate_forces=calculate_forces,& - map_consistent=map_consistent,& - error=error) + map_consistent=map_consistent) ELSE CALL integrate_pgf_product_rspace(la_max=la_max(iset),& zeta=zeta(ipgf,iset),la_min=la_min(iset),& @@ -1054,8 +1042,7 @@ SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& force_a=force_a,force_b=force_b,& use_virial=use_virial,& my_virial_a=my_virial_a,my_virial_b=my_virial_b,& - map_consistent=map_consistent,& - error=error) + map_consistent=map_consistent) ENDIF ENDIF ENDDO @@ -1077,10 +1064,10 @@ SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& ENDIF DEALLOCATE (work_i, STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE (work_f, STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF END DO @@ -1088,11 +1075,11 @@ SUBROUTINE integrate_v_rspace_one_center(v_rspace,qs_env,int_res,& CALL mp_sum(int_res(ikind)%v_int,para_env%group) DEALLOCATE (hab,pab,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO DO i=1,SIZE(rs_v) - CALL rs_grid_release(rs_v(i)%rs_grid, error=error) + CALL rs_grid_release(rs_v(i)%rs_grid) END DO CALL timestop(handle) diff --git a/src/qs_interactions.F b/src/qs_interactions.F index 4b58e60ca5..2d50f25df3 100644 --- a/src/qs_interactions.F +++ b/src/qs_interactions.F @@ -67,19 +67,17 @@ MODULE qs_interactions !> \param qs_control ... !> \param atomic_kind_set ... !> \param qs_kind_set ... -!> \param error ... !> \date 24.09.2002 !> \author GT !> \version 1.0 ! ***************************************************************************** - SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set,error) + SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set) TYPE(qs_control_type), INTENT(IN) :: qs_control TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_interaction_radii', & routineP = moduleN//':'//routineN @@ -123,22 +121,22 @@ SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set,error) p_lri = .FALSE. nkind = SIZE(atomic_kind_set) - CALL get_qs_kind_set(qs_kind_set, maxnset=maxnset, error=error) + CALL get_qs_kind_set(qs_kind_set, maxnset=maxnset) nexp_ppl = 0 DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,basis_type="ORB",error=error) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_basis_set,basis_type="AUX",error=error) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_fit_basis_set,basis_type="AUX_FIT",error=error) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=lri_basis,basis_type="LRI",error=error) - CALL get_qs_kind(qs_kind_set(ikind),soft_basis_set=soft_basis,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,basis_type="ORB") + CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_basis_set,basis_type="AUX") + CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_fit_basis_set,basis_type="AUX_FIT") + CALL get_qs_kind(qs_kind_set(ikind),basis_set=lri_basis,basis_type="LRI") + CALL get_qs_kind(qs_kind_set(ikind),soft_basis_set=soft_basis) CALL get_qs_kind(qs_kind_set(ikind),& paw_proj_set=paw_proj_set,& paw_atom=paw_atom,& all_potential=all_potential,& - gth_potential=gth_potential, error=error) + gth_potential=gth_potential) ! Calculate the orbital basis function radii *** ! For ALL electron this has to come before the calculation of the @@ -148,7 +146,7 @@ SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set,error) p_orb = .TRUE. CALL init_interaction_radii_orb_basis(orb_basis_set,qs_control%eps_pgf_orb,& - qs_control%eps_kg_orb,error=error) + qs_control%eps_kg_orb) END IF @@ -263,7 +261,7 @@ SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set,error) p_orb = .TRUE. CALL init_interaction_radii_orb_basis(aux_fit_basis_set,qs_control%eps_pgf_orb,& - qs_control%eps_kg_orb,error=error) + qs_control%eps_kg_orb) END IF @@ -271,7 +269,7 @@ SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set,error) IF (ASSOCIATED(aux_basis_set)) THEN - CALL init_interaction_radii_orb_basis(aux_basis_set,qs_control%eps_pgf_orb,error=error) + CALL init_interaction_radii_orb_basis(aux_basis_set,qs_control%eps_pgf_orb) END IF @@ -281,7 +279,7 @@ SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set,error) IF(paw_atom) THEN p_soft = .TRUE. - CALL init_interaction_radii_orb_basis(soft_basis,qs_control%eps_pgf_orb,error=error) + CALL init_interaction_radii_orb_basis(soft_basis,qs_control%eps_pgf_orb) END IF END IF @@ -289,7 +287,7 @@ SUBROUTINE init_interaction_radii(qs_control,atomic_kind_set,qs_kind_set,error) ! Calculate the lri basis function radii IF (ASSOCIATED(lri_basis)) THEN p_lri = .TRUE. - CALL init_interaction_radii_orb_basis(lri_basis,qs_control%eps_pgf_orb,error=error) + CALL init_interaction_radii_orb_basis(lri_basis,qs_control%eps_pgf_orb) END IF ! Calculate the paw projector basis function radii @@ -329,14 +327,12 @@ END SUBROUTINE init_interaction_radii !> \param orb_basis_set ... !> \param eps_pgf_orb ... !> \param eps_pgf_short ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_interaction_radii_orb_basis(orb_basis_set,eps_pgf_orb,eps_pgf_short,error) + SUBROUTINE init_interaction_radii_orb_basis(orb_basis_set,eps_pgf_orb,eps_pgf_short) TYPE(gto_basis_set_type), POINTER :: orb_basis_set REAL(KIND=dp), INTENT(IN) :: eps_pgf_orb REAL(KIND=dp), INTENT(IN), OPTIONAL :: eps_pgf_short - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'init_interaction_radii_orb_basis', & @@ -411,10 +407,9 @@ END SUBROUTINE init_interaction_radii_orb_basis !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** SUBROUTINE init_se_nlradius(se_control,atomic_kind_set,qs_kind_set,& - subsys_section,error) + subsys_section) TYPE(semi_empirical_control_type), & POINTER :: se_control @@ -423,7 +418,6 @@ SUBROUTINE init_se_nlradius(se_control,atomic_kind_set,qs_kind_set,& TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_se_nlradius', & routineP = moduleN//':'//routineN @@ -441,7 +435,7 @@ SUBROUTINE init_se_nlradius(se_control,atomic_kind_set,qs_kind_set,& qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind, basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind=qs_kind, basis_set=orb_basis_set) IF (ASSOCIATED(orb_basis_set)) THEN @@ -457,7 +451,7 @@ SUBROUTINE init_se_nlradius(se_control,atomic_kind_set,qs_kind_set,& END DO - CALL write_kind_radii(atomic_kind_set, qs_kind_set,subsys_section,error) + CALL write_kind_radii(atomic_kind_set, qs_kind_set,subsys_section) END SUBROUTINE init_se_nlradius @@ -466,16 +460,14 @@ END SUBROUTINE init_se_nlradius !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_kind_radii(atomic_kind_set, qs_kind_set,subsys_section,error) + SUBROUTINE write_kind_radii(atomic_kind_set, qs_kind_set,subsys_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=10) :: bas CHARACTER(LEN=default_string_length) :: name, unit_str @@ -485,23 +477,23 @@ SUBROUTINE write_kind_radii(atomic_kind_set, qs_kind_set,subsys_section,error) TYPE(gto_basis_set_type), POINTER :: orb_basis_set NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(orb_basis_set) bas="ORBITAL " nkind = SIZE(atomic_kind_set) ! *** Print the kind radii *** output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/KIND_RADII",extension=".Log",error=error) - CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + "PRINT%RADII/KIND_RADII",extension=".Log") + CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A,T56,A,T63,A,T75,A)")& "RADII: "//TRIM(bas)//" BASIS in "//TRIM(unit_str),& "Kind","Label","Radius" DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) IF(ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& kind_radius=kind_radius) @@ -514,7 +506,7 @@ SUBROUTINE write_kind_radii(atomic_kind_set, qs_kind_set,subsys_section,error) END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/KIND_RADII",error=error) + "PRINT%RADII/KIND_RADII") END SUBROUTINE write_kind_radii @@ -524,18 +516,16 @@ END SUBROUTINE write_kind_radii !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... !> \date 15.09.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_core_charge_radii(atomic_kind_set,qs_kind_set,subsys_section,error) + SUBROUTINE write_core_charge_radii(atomic_kind_set,qs_kind_set,subsys_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_string_length) :: name, unit_str INTEGER :: ikind, nkind, output_unit @@ -545,11 +535,11 @@ SUBROUTINE write_core_charge_radii(atomic_kind_set,qs_kind_set,subsys_section,er TYPE(gth_potential_type), POINTER :: gth_potential NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/CORE_CHARGE_RADII",extension=".Log",error=error) - CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + "PRINT%RADII/CORE_CHARGE_RADII",extension=".Log") + CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (output_unit>0) THEN nkind = SIZE(atomic_kind_set) WRITE (UNIT=output_unit,FMT="(/,T2,A,T56,A,T63,A,T75,A)")& @@ -558,7 +548,7 @@ SUBROUTINE write_core_charge_radii(atomic_kind_set,qs_kind_set,subsys_section,er DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) CALL get_qs_kind(qs_kind_set(ikind),& - all_potential=all_potential, gth_potential=gth_potential, error=error) + all_potential=all_potential, gth_potential=gth_potential) IF (ASSOCIATED(all_potential)) THEN CALL get_potential(potential=all_potential,& @@ -574,7 +564,7 @@ SUBROUTINE write_core_charge_radii(atomic_kind_set,qs_kind_set,subsys_section,er END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/CORE_CHARGE_RADII",error=error) + "PRINT%RADII/CORE_CHARGE_RADII") END SUBROUTINE write_core_charge_radii ! ***************************************************************************** @@ -583,12 +573,11 @@ END SUBROUTINE write_core_charge_radii !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... !> \date 05.06.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section,error) + SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section) CHARACTER(len=*) :: basis TYPE(atomic_kind_type), DIMENSION(:), & @@ -596,7 +585,6 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_pgf_orb_radii', & routineP = moduleN//':'//routineN @@ -615,7 +603,7 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, orb_basis_set NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(aux_basis_set,orb_basis_set,lri_basis_set) bas=" " bas(1:3) = basis(1:3) @@ -635,9 +623,9 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, ! *** Print the kind radii *** output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/KIND_RADII",extension=".Log",error=error) - CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + "PRINT%RADII/KIND_RADII",extension=".Log") + CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A,T46,A,T53,A,T63,A,T71,A)")& "RADII: "//TRIM(bas)//" BASIS in "//TRIM(unit_str),& @@ -645,20 +633,20 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) IF ( bas(1:3) == "ORB" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) IF(ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& kind_radius=kind_radius,& short_kind_radius=short_kind_radius) END IF ELSE IF ( bas(1:3) == "AUX" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX") IF(ASSOCIATED(aux_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=aux_basis_set,& kind_radius=kind_radius) END IF ELSE IF ( bas(1:3) == "LOC" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI") IF(ASSOCIATED(lri_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=lri_basis_set,& kind_radius=kind_radius) @@ -677,11 +665,11 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/KIND_RADII",error=error) + "PRINT%RADII/KIND_RADII") ! *** Print the shell set radii *** output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/SET_RADII",extension=".Log",error=error) + "PRINT%RADII/SET_RADII",extension=".Log") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A,T51,A,T57,A,T65,A,T75,A)")& "RADII: SHELL SETS OF "//TRIM(bas)//" BASIS in "//& @@ -689,21 +677,21 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) IF ( bas(1:3) == "ORB" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) IF(ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& set_radius=set_radius) END IF ELSE IF ( bas(1:3) == "AUX" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX") IF(ASSOCIATED(aux_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=aux_basis_set,& nset=nset,& set_radius=set_radius) END IF ELSE IF ( bas(1:3) == "LOC" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI") IF(ASSOCIATED(lri_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=lri_basis_set,& nset=nset,& @@ -723,10 +711,10 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/SET_RADII",error=error) + "PRINT%RADII/SET_RADII") ! *** Print the primitive Gaussian function radii *** output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/PGF_RADII",extension=".Log",error=error) + "PRINT%RADII/PGF_RADII",extension=".Log") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A,T51,A,T57,A,T65,A,T75,A)")& "RADII: PRIMITIVE GAUSSIANS OF "//TRIM(bas)//" BASIS in "//& @@ -734,7 +722,7 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) IF ( bas(1:3) == "ORB" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) IF(ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& @@ -742,7 +730,7 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, pgf_radius=pgf_radius) END IF ELSE IF ( bas(1:3) == "AUX" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=aux_basis_set, basis_type="AUX") IF(ASSOCIATED(aux_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=aux_basis_set,& nset=nset,& @@ -750,7 +738,7 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, pgf_radius=pgf_radius) END IF ELSE IF ( bas(1:3) == "LOC" ) THEN - CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI", error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=lri_basis_set, basis_type="LRI") IF(ASSOCIATED(lri_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=lri_basis_set,& nset=nset,& @@ -775,7 +763,7 @@ SUBROUTINE write_pgf_orb_radii(basis,atomic_kind_set,qs_kind_set,subsys_section, END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/PGF_RADII",error=error) + "PRINT%RADII/PGF_RADII") END SUBROUTINE write_pgf_orb_radii ! ***************************************************************************** @@ -785,19 +773,17 @@ END SUBROUTINE write_pgf_orb_radii !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... !> \date 06.10.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_ppl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) + SUBROUTINE write_ppl_radii(atomic_kind_set,qs_kind_set,subsys_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_string_length) :: name, unit_str INTEGER :: ikind, nkind, output_unit @@ -806,11 +792,11 @@ SUBROUTINE write_ppl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) TYPE(gth_potential_type), POINTER :: gth_potential NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/GTH_PPL_RADII",extension=".Log",error=error) - CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + "PRINT%RADII/GTH_PPL_RADII",extension=".Log") + CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (output_unit>0) THEN nkind = SIZE(atomic_kind_set) WRITE (UNIT=output_unit,FMT="(/,T2,A,T56,A,T63,A,T75,A)")& @@ -818,7 +804,7 @@ SUBROUTINE write_ppl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) TRIM(unit_str),"Kind","Label","Radius" DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) - CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential, error=error) + CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential) IF (ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential,& ppl_radius=ppl_radius) @@ -828,7 +814,7 @@ SUBROUTINE write_ppl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/GTH_PPL_RADII",error=error) + "PRINT%RADII/GTH_PPL_RADII") END SUBROUTINE write_ppl_radii ! ***************************************************************************** @@ -838,19 +824,17 @@ END SUBROUTINE write_ppl_radii !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... !> \date 06.10.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_ppnl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) + SUBROUTINE write_ppnl_radii(atomic_kind_set,qs_kind_set,subsys_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_string_length) :: name, unit_str INTEGER :: ikind, nkind, output_unit @@ -859,11 +843,11 @@ SUBROUTINE write_ppnl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) TYPE(gth_potential_type), POINTER :: gth_potential NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/GTH_PPNL_RADII",extension=".Log",error=error) - CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + "PRINT%RADII/GTH_PPNL_RADII",extension=".Log") + CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (output_unit>0) THEN nkind = SIZE(atomic_kind_set) WRITE (UNIT=output_unit,FMT="(/,T2,A,T56,A,T63,A,T75,A)")& @@ -871,7 +855,7 @@ SUBROUTINE write_ppnl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) TRIM(unit_str),"Kind","Label","Radius" DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) - CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential, error=error) + CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential) IF (ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential,& ppnl_radius=ppnl_radius) @@ -881,7 +865,7 @@ SUBROUTINE write_ppnl_radii(atomic_kind_set,qs_kind_set,subsys_section,error) END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/GTH_PPNL_RADII",error=error) + "PRINT%RADII/GTH_PPNL_RADII") END SUBROUTINE write_ppnl_radii ! ***************************************************************************** @@ -889,16 +873,14 @@ END SUBROUTINE write_ppnl_radii !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_paw_radii(atomic_kind_set,qs_kind_set,subsys_section,error) + SUBROUTINE write_paw_radii(atomic_kind_set,qs_kind_set,subsys_section) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_string_length) :: name, unit_str INTEGER :: ikind, nkind, output_unit @@ -908,11 +890,11 @@ SUBROUTINE write_paw_radii(atomic_kind_set,qs_kind_set,subsys_section,error) TYPE(paw_proj_set_type), POINTER :: paw_proj_set NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%RADII/GAPW_PRJ_RADII",extension=".Log",error=error) - CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str,error=error) - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + "PRINT%RADII/GAPW_PRJ_RADII",extension=".Log") + CALL section_vals_val_get(subsys_section,"PRINT%RADII%UNIT",c_val=unit_str) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) IF (output_unit>0) THEN nkind = SIZE(qs_kind_set) WRITE (UNIT=output_unit,FMT="(/,T2,A,T56,A,T63,A,T75,A)")& @@ -921,7 +903,7 @@ SUBROUTINE write_paw_radii(atomic_kind_set,qs_kind_set,subsys_section,error) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=name) CALL get_qs_kind(qs_kind_set(ikind),& - paw_atom=paw_atom, paw_proj_set=paw_proj_set, error=error) + paw_atom=paw_atom, paw_proj_set=paw_proj_set) IF (paw_atom .AND. ASSOCIATED(paw_proj_set)) THEN CALL get_paw_proj_set(paw_proj_set=paw_proj_set,& rcprj=rcprj) @@ -931,7 +913,7 @@ SUBROUTINE write_paw_radii(atomic_kind_set,qs_kind_set,subsys_section,error) END DO END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%RADII/GAPW_PRJ_RADII",error=error) + "PRINT%RADII/GAPW_PRJ_RADII") END SUBROUTINE write_paw_radii END MODULE qs_interactions diff --git a/src/qs_kind_types.F b/src/qs_kind_types.F index 47161467ca..3307b4fe38 100644 --- a/src/qs_kind_types.F +++ b/src/qs_kind_types.F @@ -187,16 +187,14 @@ MODULE qs_kind_types ! ***************************************************************************** !> \brief Destructor routine for a set of qs kinds !> \param qs_kind_set ... -!> \param error ... !> \date 02.01.2002 !> \author Matthias Krack (MK) !> \version 2.0 ! ***************************************************************************** - SUBROUTINE deallocate_qs_kind_set(qs_kind_set,error) + SUBROUTINE deallocate_qs_kind_set(qs_kind_set) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_qs_kind_set', & routineP = moduleN//':'//routineN @@ -211,79 +209,79 @@ SUBROUTINE deallocate_qs_kind_set(qs_kind_set,error) DO ikind=1,nkind IF (ASSOCIATED(qs_kind_set(ikind)%all_potential)) THEN - CALL deallocate_potential(qs_kind_set(ikind)%all_potential,error) + CALL deallocate_potential(qs_kind_set(ikind)%all_potential) END IF IF (ASSOCIATED(qs_kind_set(ikind)%tnadd_potential)) THEN - CALL deallocate_potential(qs_kind_set(ikind)%tnadd_potential,error) + CALL deallocate_potential(qs_kind_set(ikind)%tnadd_potential) END IF IF (ASSOCIATED(qs_kind_set(ikind)%gth_potential)) THEN - CALL deallocate_potential(qs_kind_set(ikind)%gth_potential,error) + CALL deallocate_potential(qs_kind_set(ikind)%gth_potential) ENDIF IF (ASSOCIATED(qs_kind_set(ikind)%se_parameter)) THEN - CALL semi_empirical_release(qs_kind_set(ikind)%se_parameter,error) + CALL semi_empirical_release(qs_kind_set(ikind)%se_parameter) END IF IF (ASSOCIATED(qs_kind_set(ikind)%dftb_parameter)) THEN - CALL deallocate_dftb_atom_param(qs_kind_set(ikind)%dftb_parameter,error) + CALL deallocate_dftb_atom_param(qs_kind_set(ikind)%dftb_parameter) END IF IF (ASSOCIATED(qs_kind_set(ikind)%scptb_parameter)) THEN - CALL deallocate_scptb_parameter(qs_kind_set(ikind)%scptb_parameter,error) + CALL deallocate_scptb_parameter(qs_kind_set(ikind)%scptb_parameter) END IF IF (ASSOCIATED(qs_kind_set(ikind)%soft_basis_set).AND.& qs_kind_set(ikind)%paw_atom) THEN - CALL deallocate_gto_basis_set(qs_kind_set(ikind)%soft_basis_set,error) + CALL deallocate_gto_basis_set(qs_kind_set(ikind)%soft_basis_set) ELSEIF(ASSOCIATED(qs_kind_set(ikind)%soft_basis_set).AND.& (.NOT.qs_kind_set(ikind)%paw_atom)) THEN NULLIFY (qs_kind_set(ikind)%soft_basis_set) END IF IF (ASSOCIATED(qs_kind_set(ikind)%paw_proj_set)) THEN - CALL deallocate_paw_proj_set(qs_kind_set(ikind)%paw_proj_set,error) + CALL deallocate_paw_proj_set(qs_kind_set(ikind)%paw_proj_set) END IF IF (ASSOCIATED(qs_kind_set(ikind)%harmonics)) THEN - CALL deallocate_harmonics_atom(qs_kind_set(ikind)%harmonics,error) + CALL deallocate_harmonics_atom(qs_kind_set(ikind)%harmonics) END IF IF (ASSOCIATED(qs_kind_set(ikind)%grid_atom)) THEN - CALL deallocate_grid_atom(qs_kind_set(ikind)%grid_atom,error) + CALL deallocate_grid_atom(qs_kind_set(ikind)%grid_atom) END IF IF (ASSOCIATED(qs_kind_set(ikind)%elec_conf)) THEN DEALLOCATE (qs_kind_set(ikind)%elec_conf,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF IF (ASSOCIATED(qs_kind_set(ikind)%dft_plus_u)) THEN IF (ASSOCIATED(qs_kind_set(ikind)%dft_plus_u%orbitals)) THEN DEALLOCATE (qs_kind_set(ikind)%dft_plus_u%orbitals,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (qs_kind_set(ikind)%dft_plus_u,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_kind_set(ikind)%dispersion)) THEN DEALLOCATE (qs_kind_set(ikind)%dispersion,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_kind_set(ikind)%addel)) THEN DEALLOCATE (qs_kind_set(ikind)%addel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_kind_set(ikind)%naddel)) THEN DEALLOCATE (qs_kind_set(ikind)%naddel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_kind_set(ikind)%laddel)) THEN DEALLOCATE (qs_kind_set(ikind)%laddel,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(qs_kind_set(ikind)%reltmat)) THEN DEALLOCATE (qs_kind_set(ikind)%reltmat,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL remove_basis_set_container(qs_kind_set(ikind)%basis_sets,error) + CALL remove_basis_set_container(qs_kind_set(ikind)%basis_sets) END DO DEALLOCATE (qs_kind_set,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer qs_kind_set is not associated and "//& @@ -350,7 +348,6 @@ END SUBROUTINE deallocate_qs_kind_set !> \param ghost ... !> \param name ... !> \param element_symbol ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_qs_kind(qs_kind, & basis_set, basis_type, ncgf, nsgf, & @@ -365,8 +362,7 @@ SUBROUTINE get_qs_kind(qs_kind, & dft_plus_u_atom, l_of_dft_plus_u, u_minus_j, dispersion, & bs_occupation, no_optimize, addel, laddel, naddel, orbitals, & max_scf, eps_scf, smear, u_ramping, u_minus_j_target, eps_u_ramping, & - init_u_ramping_each_scf, reltmat, ghost, name, element_symbol, & - error) + init_u_ramping_each_scf, reltmat, ghost, name, element_symbol) TYPE(qs_kind_type) :: qs_kind TYPE(gto_basis_set_type), OPTIONAL, & @@ -427,7 +423,6 @@ SUBROUTINE get_qs_kind(qs_kind, & CHARACTER(LEN=default_string_length), & INTENT(OUT), OPTIONAL :: name CHARACTER(LEN=2), INTENT(OUT), OPTIONAL :: element_symbol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_qs_kind', & routineP = moduleN//':'//routineN @@ -453,13 +448,13 @@ SUBROUTINE get_qs_kind(qs_kind, & basis_set => qs_kind%soft_basis_set ELSE CALL get_basis_from_container(qs_kind%basis_sets,basis_set=basis_set,& - basis_type=my_basis_type,error=error) + basis_type=my_basis_type) END IF END IF IF (PRESENT(ncgf)) THEN CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis_set,& - basis_type=my_basis_type,error=error) + basis_type=my_basis_type) IF(ASSOCIATED(tmp_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=tmp_basis_set,ncgf=ncgf) ELSE IF(ASSOCIATED(qs_kind%dftb_parameter)) THEN @@ -472,7 +467,7 @@ SUBROUTINE get_qs_kind(qs_kind, & IF (PRESENT(nsgf)) THEN CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis_set,& - basis_type=my_basis_type,error=error) + basis_type=my_basis_type) IF(ASSOCIATED(tmp_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=tmp_basis_set,nsgf=nsgf) ELSE IF(ASSOCIATED(qs_kind%dftb_parameter)) THEN @@ -696,7 +691,6 @@ END SUBROUTINE get_qs_kind !> \param maxg_iso_not0 ... !> \param lmax_rho0 ... !> \param basis_type ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_qs_kind_set(qs_kind_set,& all_potential_present, tnadd_potential_present, gth_potential_present,& @@ -704,7 +698,7 @@ SUBROUTINE get_qs_kind_set(qs_kind_set,& maxcgf, maxsgf, maxco, maxco_proj, maxgtops, maxlgto, maxlprj, maxnset, maxsgf_set,& ncgf, npgf, nset, nsgf, nshell, maxpol, maxlppl, maxlppnl, maxppnl,& nelectron, maxder, max_ngrid_rad, max_sph_harm, maxg_iso_not0, lmax_rho0,& - basis_type, error) + basis_type) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set @@ -718,7 +712,6 @@ SUBROUTINE get_qs_kind_set(qs_kind_set,& INTEGER, INTENT(OUT), OPTIONAL :: max_ngrid_rad, max_sph_harm, & maxg_iso_not0, lmax_rho0 CHARACTER(len=*), OPTIONAL :: basis_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_qs_kind_set', & routineP = moduleN//':'//routineN @@ -787,8 +780,7 @@ SUBROUTINE get_qs_kind_set(qs_kind_set,& max_iso_not0=max_iso_not0,& paw_atom=paw_atom,& dft_plus_u_atom=dft_plus_u_atom,& - lmax_rho0=lmax_rho0_kind,& - error=error) + lmax_rho0=lmax_rho0_kind) IF (PRESENT(maxlppl).AND.ASSOCIATED(gth_potential)) THEN CALL get_potential(potential=gth_potential,nexp_ppl=n) @@ -821,7 +813,7 @@ SUBROUTINE get_qs_kind_set(qs_kind_set,& END IF CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis_set,& - basis_type=my_basis_type,error=error) + basis_type=my_basis_type) IF (PRESENT(maxcgf)) THEN IF(ASSOCIATED(tmp_basis_set)) THEN @@ -1004,13 +996,11 @@ END SUBROUTINE get_qs_kind_set ! ***************************************************************************** !> \brief Initialise an atomic kind data set. !> \param qs_kind ... -!> \param error ... !> \author Creation (11.01.2002,MK) !> 20.09.2002 adapted for pol/kg use, gtb ! ***************************************************************************** - SUBROUTINE init_qs_kind(qs_kind,error) + SUBROUTINE init_qs_kind(qs_kind) TYPE(qs_kind_type), POINTER :: qs_kind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_qs_kind', & routineP = moduleN//':'//routineN @@ -1022,23 +1012,23 @@ SUBROUTINE init_qs_kind(qs_kind,error) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(qs_kind),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_kind),cp_failure_level,routineP,failure) IF (ASSOCIATED(qs_kind%gth_potential)) THEN - CALL init_potential(qs_kind%gth_potential,error) + CALL init_potential(qs_kind%gth_potential) END IF DO i=1,SIZE(qs_kind%basis_sets,1) NULLIFY(tmp_basis_set) CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis_set,& - inumbas=i,basis_type=basis_type,error=error) + inumbas=i,basis_type=basis_type) IF(basis_type=="") CYCLE IF(basis_type=="AUX") THEN IF(tmp_basis_set%norm_type < 0) tmp_basis_set%norm_type = 1 - CALL init_aux_basis_set(tmp_basis_set,error) + CALL init_aux_basis_set(tmp_basis_set) ELSE IF(tmp_basis_set%norm_type < 0) tmp_basis_set%norm_type = 2 - CALL init_orb_basis_set(tmp_basis_set,error) + CALL init_orb_basis_set(tmp_basis_set) END IF END DO @@ -1049,15 +1039,13 @@ END SUBROUTINE init_qs_kind ! ***************************************************************************** !> \brief Initialise an atomic kind set data set. !> \param qs_kind_set ... -!> \param error ... !> \author - Creation (17.01.2002,MK) !> - 20.09.2002 para_env passed (gt) ! ***************************************************************************** - SUBROUTINE init_qs_kind_set(qs_kind_set,error) + SUBROUTINE init_qs_kind_set(qs_kind_set) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_qs_kind_set', & routineP = moduleN//':'//routineN @@ -1072,7 +1060,7 @@ SUBROUTINE init_qs_kind_set(qs_kind_set,error) DO ikind=1, SIZE(qs_kind_set) qs_kind => qs_kind_set(ikind) - CALL init_qs_kind(qs_kind, error) + CALL init_qs_kind(qs_kind) END DO CALL timestop(handle) @@ -1084,16 +1072,13 @@ END SUBROUTINE init_qs_kind_set !> \param qs_kind_set ... !> \param qs_control ... !> \param force_env_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_gapw_basis_set(qs_kind_set,qs_control,force_env_section,& - error) + SUBROUTINE init_gapw_basis_set(qs_kind_set,qs_control,force_env_section) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(qs_control_type), POINTER :: qs_control TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_gapw_basis_set', & routineP = moduleN//':'//routineN @@ -1114,35 +1099,35 @@ SUBROUTINE init_gapw_basis_set(qs_kind_set,qs_control,force_env_section,& qs_kind => qs_kind_set(ikind) - CALL allocate_gto_basis_set(qs_kind%soft_basis_set,error) + CALL allocate_gto_basis_set(qs_kind%soft_basis_set) ! The hard_basis points to the orb_basis - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis) qs_kind%hard_basis_set => orb_basis CALL get_qs_kind(qs_kind=qs_kind,hard_radius=rc,& - max_rad_local=max_rad_local_type,gpw_type_forced=gpw,error=error) + max_rad_local=max_rad_local_type,gpw_type_forced=gpw) CALL create_soft_basis(orb_basis,qs_kind%soft_basis_set,& qs_control%gapw_control%eps_fit,rc,paw_atom,& - qs_control%gapw_control%force_paw,gpw,error) + qs_control%gapw_control%force_paw,gpw) - CALL set_qs_kind(qs_kind=qs_kind,paw_atom=paw_atom,error=error) + CALL set_qs_kind(qs_kind=qs_kind,paw_atom=paw_atom) IF (paw_atom) THEN - CALL allocate_paw_proj_set(qs_kind%paw_proj_set,error) - CALL get_qs_kind(qs_kind=qs_kind,paw_proj_set=paw_proj,error=error) + CALL allocate_paw_proj_set(qs_kind%paw_proj_set) + CALL get_qs_kind(qs_kind=qs_kind,paw_proj_set=paw_proj) CALL projectors(paw_proj,orb_basis,rc,qs_control,max_rad_local_type,& - force_env_section,error) + force_env_section) ELSE qs_control%gapw_control%non_paw_atoms = .TRUE. END IF ! grid_atom and harmonics are allocated even if NOT PAW_ATOM NULLIFY(qs_kind%grid_atom,qs_kind%harmonics) - CALL allocate_grid_atom(qs_kind%grid_atom,error) - CALL allocate_harmonics_atom(qs_kind%harmonics,error) + CALL allocate_grid_atom(qs_kind%grid_atom) + CALL allocate_harmonics_atom(qs_kind%harmonics) END DO IF(qs_control%gapw_control%non_paw_atoms) THEN @@ -1165,14 +1150,13 @@ END SUBROUTINE init_gapw_basis_set !> \param force_env_section ... !> \param no_fail ... !> \param method_id ... -!> \param error ... !> \par History !> - Creation (09.02.2002,MK) !> - 20.09.2002,gt: adapted for POL/KG use (elp_potential) !> - 05.03.2010: split elp_potential into fist_potential and kg_potential ! ***************************************************************************** SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& - no_fail, method_id, error) + no_fail, method_id) TYPE(qs_kind_type), INTENT(INOUT) :: qs_kind TYPE(section_vals_type), POINTER :: kind_section @@ -1180,7 +1164,6 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& TYPE(section_vals_type), POINTER :: force_env_section LOGICAL, INTENT(IN) :: no_fail INTEGER, INTENT(IN) :: method_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_qs_kind', & routineP = moduleN//':'//routineN @@ -1225,15 +1208,15 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& kgpot_type = "" z = -1 zeff_correction = 0.0_dp - dft_section => section_vals_get_subs_vals(force_env_section,"DFT",error=error) - CALL section_vals_get(kind_section,n_repetition=n_rep,error=error) + dft_section => section_vals_get_subs_vals(force_env_section,"DFT") + CALL section_vals_get(kind_section,n_repetition=n_rep) k_rep=-1 akind_name=qs_kind%name CALL uppercase(akind_name) ! First we use the atom_name to find out the proper KIND section DO i_rep=1,n_rep CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",& - c_val=keyword,i_rep_section=i_rep,error=error) + c_val=keyword,i_rep_section=i_rep) CALL uppercase(keyword) IF (keyword==akind_name) THEN k_rep=i_rep @@ -1250,7 +1233,7 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& CALL uppercase(akind_name) DO i_rep=1,n_rep CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",& - c_val=keyword,i_rep_section=i_rep,error=error) + c_val=keyword,i_rep_section=i_rep) CALL uppercase(keyword) IF (keyword==akind_name) THEN k_rep=i_rep @@ -1267,7 +1250,7 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& CALL uppercase(element_symbol) DO i_rep=1,n_rep CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",& - c_val=keyword,i_rep_section=i_rep,error=error) + c_val=keyword,i_rep_section=i_rep) CALL uppercase(keyword) IF (keyword==element_symbol) THEN k_rep=i_rep @@ -1280,7 +1263,7 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& IF (k_rep<1) THEN DO i_rep=1,n_rep CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",& - c_val=keyword,i_rep_section=i_rep,error=error) + c_val=keyword,i_rep_section=i_rep) CALL uppercase(keyword) IF (keyword=="DEFAULT") THEN k_rep=i_rep @@ -1304,12 +1287,12 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& keyword_name="BASIS_SET",& explicit=explicit,& - n_rep_val=nb_rep,error=error) + n_rep_val=nb_rep) IF(.NOT.explicit) nb_rep = 0 - CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,error,failure) + CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,failure) DO i=1,nb_rep CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="BASIS_SET",i_rep_val=i,c_vals=tmpstringlist,error=error) + keyword_name="BASIS_SET",i_rep_val=i,c_vals=tmpstringlist) IF(SIZE(tmpstringlist)==1) THEN ! default is orbital type basis_set_type(i) = "ORB" @@ -1318,7 +1301,7 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& basis_set_type(i) = tmpstringlist(1) basis_set_name(i) = tmpstringlist(2) ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO @@ -1330,55 +1313,55 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& END IF END DO CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="AUX_FIT_BASIS_SET", c_val=aux_fit_basis_set_name,error=error) + keyword_name="AUX_FIT_BASIS_SET", c_val=aux_fit_basis_set_name) IF(aux_fit_basis_set_name /= "") THEN nb_rep = nb_rep + 1 - CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,error,failure) + CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,failure) basis_set_type(nb_rep) = "AUX_FIT" basis_set_name(nb_rep) = aux_fit_basis_set_name END IF CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="AUX_BASIS_SET", c_val=aux_basis_set_name,error=error) + keyword_name="AUX_BASIS_SET", c_val=aux_basis_set_name) IF(aux_basis_set_name /= "") THEN nb_rep = nb_rep + 1 - CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,error,failure) + CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,failure) basis_set_type(nb_rep) = "AUX" basis_set_name(nb_rep) = aux_basis_set_name END IF CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="LRI_BASIS_SET", c_val=lri_basis_set_name,error=error) + keyword_name="LRI_BASIS_SET", c_val=lri_basis_set_name) IF(lri_basis_set_name /= "") THEN nb_rep = nb_rep + 1 - CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,error,failure) + CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,failure) basis_set_type(nb_rep) = "LRI" basis_set_name(nb_rep) = lri_basis_set_name END IF CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="RI_AUX_BASIS_SET", c_val=ri_aux_basis_set_name,error=error) + keyword_name="RI_AUX_BASIS_SET", c_val=ri_aux_basis_set_name) IF(ri_aux_basis_set_name /= "") THEN nb_rep = nb_rep + 1 - CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,error,failure) + CPPostcondition(nb_rep<=maxbas,cp_failure_level,routineP,failure) basis_set_type(nb_rep) = "RI_AUX" basis_set_name(nb_rep) = ri_aux_basis_set_name END IF ! end of deprecated input CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="ELEC_CONF",n_rep_val=i,error=error) + keyword_name="ELEC_CONF",n_rep_val=i) IF (i>0) THEN CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="ELEC_CONF",i_vals=elec_conf,error=error) - CALL set_qs_kind(qs_kind,elec_conf=elec_conf,error=error) + keyword_name="ELEC_CONF",i_vals=elec_conf) + CALL set_qs_kind(qs_kind,elec_conf=elec_conf) ENDIF CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="CORE_CORRECTION",r_val=zeff_correction,error=error) + keyword_name="CORE_CORRECTION",r_val=zeff_correction) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="POTENTIAL",c_val=potential_name,error=error) + keyword_name="POTENTIAL",c_val=potential_name) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="KG_POTENTIAL",c_val=kgpot_name,error=error) + keyword_name="KG_POTENTIAL",c_val=kgpot_name) ! assign atom dependent defaults, only H special case CALL section_vals_val_get(kind_section,i_rep_section=k_rep,n_rep_val=i,& - keyword_name="HARD_EXP_RADIUS",error=error) + keyword_name="HARD_EXP_RADIUS") IF (i==0) THEN IF (z==1) THEN qs_kind%hard_radius=1.2_dp @@ -1387,77 +1370,75 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& ENDIF ELSE CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="HARD_EXP_RADIUS",r_val=qs_kind%hard_radius,error=error) + keyword_name="HARD_EXP_RADIUS",r_val=qs_kind%hard_radius) ENDIF ! assign atom dependent defaults, only H special case CALL section_vals_val_get(kind_section,i_rep_section=k_rep,n_rep_val=i,& - keyword_name="RHO0_EXP_RADIUS",error=error) + keyword_name="RHO0_EXP_RADIUS") IF (i==0) THEN qs_kind%hard0_radius=qs_kind%hard_radius ELSE CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="RHO0_EXP_RADIUS",r_val=qs_kind%hard0_radius,error=error) + keyword_name="RHO0_EXP_RADIUS",r_val=qs_kind%hard0_radius) ENDIF CALL cp_assert(qs_kind%hard_radius>=qs_kind%hard0_radius,& cp_failure_level,cp_assertion_failed,routineP,& - "rc0 should be <= rc",error,failure) + "rc0 should be <= rc",failure) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="MAX_RAD_LOCAL",r_val=qs_kind%max_rad_local,error=error) + keyword_name="MAX_RAD_LOCAL",r_val=qs_kind%max_rad_local) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="LEBEDEV_GRID",i_val=qs_kind%ngrid_ang,error=error) + keyword_name="LEBEDEV_GRID",i_val=qs_kind%ngrid_ang) CALL cp_assert(qs_kind%ngrid_ang > 0,& cp_failure_level,cp_assertion_failed,routineP,& - "# point lebedev grid < 0",error,failure) + "# point lebedev grid < 0",failure) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="RADIAL_GRID",i_val=qs_kind%ngrid_rad,error=error) + keyword_name="RADIAL_GRID",i_val=qs_kind%ngrid_rad) CALL cp_assert(qs_kind%ngrid_rad > 0,& cp_failure_level,cp_assertion_failed,routineP,& - "# point radial grid < 0",error,failure) + "# point radial grid < 0",failure) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="GPW_TYPE",l_val=qs_kind%gpw_type_forced,error=error) + keyword_name="GPW_TYPE",l_val=qs_kind%gpw_type_forced) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="GHOST",l_val=qs_kind%ghost,error=error) + keyword_name="GHOST",l_val=qs_kind%ghost) CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="NO_OPTIMIZE",l_val=qs_kind%no_optimize,error=error) + keyword_name="NO_OPTIMIZE",l_val=qs_kind%no_optimize) ! DFTB3 param CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="DFTB3_PARAM",r_val=qs_kind%dudq_dftb3,error=error) + keyword_name="DFTB3_PARAM",r_val=qs_kind%dudq_dftb3) ! MAOS CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="MAO",i_val=qs_kind%mao,error=error) + keyword_name="MAO",i_val=qs_kind%mao) ! Read the BS subsection of the current atomic kind, if enabled NULLIFY(bs_section) bs_section => section_vals_get_subs_vals(kind_section,"BS",& - i_rep_section=k_rep,& - error=error) + i_rep_section=k_rep) section_enabled = .FALSE. CALL section_vals_val_get(bs_section,"_SECTION_PARAMETERS_",& - l_val=section_enabled,& - error=error) + l_val=section_enabled) IF (section_enabled) THEN qs_kind%bs_occupation = .TRUE. !Alpha spin NULLIFY(spin_section) - spin_section => section_vals_get_subs_vals(bs_section,"ALPHA",error=error) - CALL section_vals_get(spin_section, explicit=explicit, error=error) + spin_section => section_vals_get_subs_vals(bs_section,"ALPHA") + CALL section_vals_get(spin_section, explicit=explicit) IF(explicit) THEN NULLIFY(add_el) CALL section_vals_val_get(spin_section,& - keyword_name="NEL",i_vals=add_el,error=error) - CPPrecondition(ASSOCIATED(add_el),cp_failure_level,routineP,error,failure) + keyword_name="NEL",i_vals=add_el) + CPPrecondition(ASSOCIATED(add_el),cp_failure_level,routineP,failure) ALLOCATE(qs_kind%addel(SIZE(add_el),2),STAT=stat) qs_kind%addel =0 qs_kind%addel(1:SIZE(add_el),1) = add_el(1:SIZE(add_el)) NULLIFY(add_el) CALL section_vals_val_get(spin_section,& - keyword_name="L",i_vals=add_el,error=error) - CPPrecondition(ASSOCIATED(add_el),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(add_el)==SIZE( qs_kind%addel,1),cp_failure_level,routineP,error,failure) + keyword_name="L",i_vals=add_el) + CPPrecondition(ASSOCIATED(add_el),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(add_el)==SIZE( qs_kind%addel,1),cp_failure_level,routineP,failure) ALLOCATE(qs_kind%laddel(SIZE(add_el),2),STAT=stat) qs_kind%laddel =0 qs_kind%laddel(1:SIZE(add_el),1) = add_el(1:SIZE(add_el)) @@ -1465,10 +1446,10 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& qs_kind%naddel =0 NULLIFY(add_el) CALL section_vals_val_get(spin_section,& - keyword_name="N",n_rep_val=i,error=error) + keyword_name="N",n_rep_val=i) IF(i>0) THEN CALL section_vals_val_get(spin_section,& - keyword_name="N",i_vals=add_el,error=error) + keyword_name="N",i_vals=add_el) IF(SIZE(add_el)==SIZE( qs_kind%addel,1)) THEN qs_kind%naddel(1:SIZE(add_el),1) = add_el(1:SIZE(add_el)) END IF @@ -1476,28 +1457,28 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& END IF !Beta spin NULLIFY(spin_section) - spin_section => section_vals_get_subs_vals(bs_section,"BETA",error=error) - CALL section_vals_get(spin_section, explicit=explicit, error=error) + spin_section => section_vals_get_subs_vals(bs_section,"BETA") + CALL section_vals_get(spin_section, explicit=explicit) IF(explicit) THEN NULLIFY(add_el) CALL section_vals_val_get(spin_section,& - keyword_name="NEL",i_vals=add_el,error=error) - CPPrecondition(SIZE(add_el)==SIZE( qs_kind%addel,1),cp_failure_level,routineP,error,failure) + keyword_name="NEL",i_vals=add_el) + CPPrecondition(SIZE(add_el)==SIZE( qs_kind%addel,1),cp_failure_level,routineP,failure) qs_kind%addel(1:SIZE(add_el),2) = add_el(1:SIZE(add_el)) qs_kind%addel(:,:) = qs_kind%addel(:,:) NULLIFY(add_el) CALL section_vals_val_get(spin_section,& - keyword_name="L",i_vals=add_el,error=error) - CPPrecondition(SIZE(add_el)==SIZE( qs_kind%addel,1),cp_failure_level,routineP,error,failure) + keyword_name="L",i_vals=add_el) + CPPrecondition(SIZE(add_el)==SIZE( qs_kind%addel,1),cp_failure_level,routineP,failure) qs_kind%laddel(1:SIZE(add_el),2) = add_el(1:SIZE(add_el)) CALL section_vals_val_get(spin_section,& - keyword_name="N",n_rep_val=i,error=error) + keyword_name="N",n_rep_val=i) IF(i>0) THEN NULLIFY(add_el) CALL section_vals_val_get(spin_section,& - keyword_name="N",i_vals=add_el,error=error) + keyword_name="N",i_vals=add_el) IF(SIZE(add_el)==SIZE( qs_kind%addel,1)) THEN qs_kind%naddel(1:SIZE(add_el),2) = add_el(1:SIZE(add_el)) END IF @@ -1510,38 +1491,32 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& NULLIFY (dft_plus_u_section) dft_plus_u_section => section_vals_get_subs_vals(kind_section,& subsection_name="DFT_PLUS_U",& - i_rep_section=k_rep,& - error=error) + i_rep_section=k_rep) section_enabled = .FALSE. CALL section_vals_val_get(dft_plus_u_section,& keyword_name="_SECTION_PARAMETERS_",& - l_val=section_enabled,& - error=error) + l_val=section_enabled) IF (section_enabled) THEN ALLOCATE (qs_kind%dft_plus_u,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (qs_kind%dft_plus_u%orbitals) CALL section_vals_val_get(dft_plus_u_section,& keyword_name="L",& - i_val=l,& - error=error) + i_val=l) qs_kind%dft_plus_u%l = l CALL cp_assert((l >= 0),cp_failure_level,& cp_assertion_failed,routineP,& "DFT+U| Invalid orbital angular momentum quantum number specified: l < 0",& - error,failure) + failure) CALL section_vals_val_get(dft_plus_u_section,& keyword_name="U_MINUS_J",& - r_val=qs_kind%dft_plus_u%u_minus_j_target,& - error=error) + r_val=qs_kind%dft_plus_u%u_minus_j_target) CALL section_vals_val_get(dft_plus_u_section,& keyword_name="U_RAMPING",& - r_val=qs_kind%dft_plus_u%u_ramping,& - error=error) + r_val=qs_kind%dft_plus_u%u_ramping) CALL section_vals_val_get(dft_plus_u_section,& keyword_name="INIT_U_RAMPING_EACH_SCF",& - l_val=qs_kind%dft_plus_u%init_u_ramping_each_scf,& - error=error) + l_val=qs_kind%dft_plus_u%init_u_ramping_each_scf) IF (qs_kind%dft_plus_u%u_ramping > 0.0_dp) THEN qs_kind%dft_plus_u%u_minus_j = 0.0_dp ELSE @@ -1549,63 +1524,56 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& END IF CALL section_vals_val_get(dft_plus_u_section,& keyword_name="EPS_U_RAMPING",& - r_val=qs_kind%dft_plus_u%eps_u_ramping,& - error=error) + r_val=qs_kind%dft_plus_u%eps_u_ramping) NULLIFY (enforce_occupation_section) enforce_occupation_section => section_vals_get_subs_vals(dft_plus_u_section,& - subsection_name="ENFORCE_OCCUPATION",& - error=error) + subsection_name="ENFORCE_OCCUPATION") subsection_enabled = .FALSE. CALL section_vals_val_get(enforce_occupation_section,& keyword_name="_SECTION_PARAMETERS_",& - l_val=subsection_enabled,& - error=error) + l_val=subsection_enabled) IF (subsection_enabled) THEN NULLIFY (orbitals) CALL section_vals_val_get(enforce_occupation_section,& keyword_name="ORBITALS",& - i_vals=orbitals,& - error=error) + i_vals=orbitals) norbitals = SIZE(orbitals) CALL cp_assert(((norbitals > 0).AND.(norbitals <= 2*l+1)),cp_failure_level,cp_assertion_failed,routineP,& "DFT+U| Invalid number of ORBITALS specified: 1 to 2*L+1 integer numbers are expected",& - error,failure) + failure) ALLOCATE (qs_kind%dft_plus_u%orbitals(norbitals),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qs_kind%dft_plus_u%orbitals(:) = orbitals(:) NULLIFY (orbitals) DO m=1,norbitals CALL cp_assert((qs_kind%dft_plus_u%orbitals(m) <= l),cp_failure_level,& cp_assertion_failed,routineP,& "DFT+U| Invalid orbital magnetic quantum number specified: m > l",& - error,failure) + failure) CALL cp_assert((qs_kind%dft_plus_u%orbitals(m) >= -l),cp_failure_level,& cp_assertion_failed,routineP,& "DFT+U| Invalid orbital magnetic quantum number specified: m < -l",& - error,failure) + failure) DO j=1,norbitals IF (j /= m) THEN CALL cp_assert((qs_kind%dft_plus_u%orbitals(j) /= qs_kind%dft_plus_u%orbitals(m)),& cp_failure_level,cp_assertion_failed,routineP,& "DFT+U| An orbital magnetic quantum number was specified twice",& - error,failure) + failure) END IF END DO END DO CALL section_vals_val_get(enforce_occupation_section,& keyword_name="EPS_SCF",& - r_val=qs_kind%dft_plus_u%eps_scf,& - error=error) + r_val=qs_kind%dft_plus_u%eps_scf) CALL section_vals_val_get(enforce_occupation_section,& keyword_name="MAX_SCF",& - i_val=i,& - error=error) + i_val=i) qs_kind%dft_plus_u%max_scf = MAX(-1,i) CALL section_vals_val_get(enforce_occupation_section,& keyword_name="SMEAR",& - l_val=qs_kind%dft_plus_u%smear,& - error=error) + l_val=qs_kind%dft_plus_u%smear) END IF ! subsection enabled END IF ! section enabled @@ -1619,22 +1587,22 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& explicit_basis = .FALSE. IF (k_rep>0) THEN basis_section => section_vals_get_subs_vals(kind_section,"BASIS",i_rep_section=k_rep,& - can_return_null=.TRUE.,error=error) - CALL section_vals_get(basis_section,explicit=explicit_basis,error=error) + can_return_null=.TRUE.) + CALL section_vals_get(basis_section,explicit=explicit_basis) END IF explicit_potential = .FALSE. IF (k_rep>0) THEN potential_section => section_vals_get_subs_vals(kind_section,"POTENTIAL",& - i_rep_section=k_rep,can_return_null=.TRUE.,error=error) - CALL section_vals_get(potential_section, explicit=explicit_potential,error=error) + i_rep_section=k_rep,can_return_null=.TRUE.) + CALL section_vals_get(potential_section, explicit=explicit_potential) END IF explicit_kgpot = .FALSE. IF (k_rep>0) THEN kgpot_section => section_vals_get_subs_vals(kind_section,"KG_POTENTIAL",& - i_rep_section=k_rep,can_return_null=.TRUE.,error=error) - CALL section_vals_get(kgpot_section, explicit=explicit_kgpot,error=error) + i_rep_section=k_rep,can_return_null=.TRUE.) + CALL section_vals_get(kgpot_section, explicit=explicit_kgpot) END IF SELECT CASE(method_id) @@ -1642,15 +1610,15 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& do_method_pdg, do_method_pm3, do_method_pm6, do_method_mndod,& do_method_pnnl ) ! Allocate all_potential - CALL allocate_potential(qs_kind%all_potential,error) - CALL set_default_all_potential(qs_kind%all_potential,z,zeff_correction,error) - CALL get_qs_kind(qs_kind,elec_conf=elec_conf,error=error) + CALL allocate_potential(qs_kind%all_potential) + CALL set_default_all_potential(qs_kind%all_potential,z,zeff_correction) + CALL get_qs_kind(qs_kind,elec_conf=elec_conf) IF (.NOT.ASSOCIATED(elec_conf)) THEN CALL get_potential(potential=qs_kind%all_potential,elec_conf=elec_conf) - CALL set_qs_kind(qs_kind,elec_conf=elec_conf,error=error) + CALL set_qs_kind(qs_kind,elec_conf=elec_conf) END IF IF (qs_kind%ghost) THEN - CALL get_qs_kind(qs_kind=qs_kind,elec_conf=elec_conf,error=error) + CALL get_qs_kind(qs_kind=qs_kind,elec_conf=elec_conf) elec_conf(:) = 0 CALL get_potential(potential=qs_kind%all_potential,& elec_conf=elec_conf) @@ -1666,33 +1634,32 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& do_method_pm3, do_method_pm6, do_method_mndod, do_method_pnnl ) ! Setup proper semiempirical parameters check = .NOT.ASSOCIATED(qs_kind%se_parameter) - CPPostcondition(check, cp_failure_level, routineP, error, failure) - CALL semi_empirical_create(qs_kind%se_parameter,error) + CPPostcondition(check, cp_failure_level, routineP,failure) + CALL semi_empirical_create(qs_kind%se_parameter) ! Check if we allow p-orbitals on H SELECT CASE(z) CASE (1) IF (k_rep>0) THEN CALL section_vals_val_get(kind_section,i_rep_section=k_rep,& - keyword_name="SE_P_ORBITALS_ON_H",l_val=qs_kind%se_parameter%p_orbitals_on_h,& - error=error) + keyword_name="SE_P_ORBITALS_ON_H",l_val=qs_kind%se_parameter%p_orbitals_on_h) END IF CASE DEFAULT ! No special cases for other elements.. END SELECT ! Set default parameters - CALL section_vals_val_get(dft_section,"QS%SE%STO_NG",i_val=ngauss,error=error) - CALL se_param_set_default(qs_kind%se_parameter,z,method_id,error) + CALL section_vals_val_get(dft_section,"QS%SE%STO_NG",i_val=ngauss) + CALL se_param_set_default(qs_kind%se_parameter,z,method_id) NULLIFY(tmp_basis_set) - CALL init_se_param(qs_kind%se_parameter,tmp_basis_set,ngauss,error=error) - CALL add_basis_set_to_container(qs_kind%basis_sets,tmp_basis_set,"ORB",error=error) + CALL init_se_param(qs_kind%se_parameter,tmp_basis_set,ngauss) + CALL add_basis_set_to_container(qs_kind%basis_sets,tmp_basis_set,"ORB") CALL init_potential ( qs_kind%all_potential, itype="BARE", & - zeff=qs_kind%se_parameter%zeff,zeff_correction=zeff_correction,error=error) + zeff=qs_kind%se_parameter%zeff,zeff_correction=zeff_correction) qs_kind%se_parameter%zeff=qs_kind%se_parameter%zeff-zeff_correction CASE (do_method_dftb,do_method_scptb) ! Do nothing at this stage.. The initialization of the parameters will be done ! later CASE DEFAULT - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END SELECT check = ((potential_name /= '').OR.explicit_potential) @@ -1715,40 +1682,40 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& ! first external basis sets DO i=1,nb_rep NULLIFY(tmp_basis_set) - CALL allocate_gto_basis_set(tmp_basis_set,error) + CALL allocate_gto_basis_set(tmp_basis_set) CALL read_gto_basis_set(qs_kind%element_symbol,basis_set_name(i),& - tmp_basis_set,para_env,dft_section,error=error) + tmp_basis_set,para_env,dft_section) tmp=basis_set_type(i) CALL uppercase(tmp) - CALL add_basis_set_to_container(qs_kind%basis_sets,tmp_basis_set,tmp,error) + CALL add_basis_set_to_container(qs_kind%basis_sets,tmp_basis_set,tmp) END DO ! now explicit basis sets IF(explicit_basis) THEN - CALL section_vals_get(basis_section,n_repetition=nexp,error=error) + CALL section_vals_get(basis_section,n_repetition=nexp) DO i=1,nexp NULLIFY(tmp_basis_set) - CALL allocate_gto_basis_set(tmp_basis_set,error) + CALL allocate_gto_basis_set(tmp_basis_set) CALL read_gto_basis_set(qs_kind%element_symbol,basis_type,& - tmp_basis_set,basis_section,i,error=error) + tmp_basis_set,basis_section,i) tmp=basis_type CALL uppercase(tmp) - CALL add_basis_set_to_container(qs_kind%basis_sets,tmp_basis_set,tmp,error) + CALL add_basis_set_to_container(qs_kind%basis_sets,tmp_basis_set,tmp) END DO END IF ! combine multiple basis sets DO i=1,SIZE(qs_kind%basis_sets) NULLIFY(tmp_basis_set) CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis_set,& - inumbas=i,basis_type=basis_type,error=error) + inumbas=i,basis_type=basis_type) IF(basis_type=="") CYCLE DO j=i+1,SIZE(qs_kind%basis_sets) NULLIFY(sup_basis_set) CALL get_basis_from_container(qs_kind%basis_sets,basis_set=sup_basis_set,& - inumbas=j,basis_type=tmp,error=error) + inumbas=j,basis_type=tmp) IF(basis_type==tmp) THEN ! we found a match, combine the basis sets and delete the second - CALL combine_basis_sets(tmp_basis_set,sup_basis_set,error=error) - CALL remove_basis_from_container(qs_kind%basis_sets,j,error=error) + CALL combine_basis_sets(tmp_basis_set,sup_basis_set) + CALL remove_basis_from_container(qs_kind%basis_sets,j) END IF END DO NULLIFY(sup_basis_set) @@ -1760,7 +1727,7 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& DO i=1,SIZE(qs_kind%basis_sets) NULLIFY(tmp_basis_set) CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis_set,& - inumbas=i,basis_type=basis_type,error=error) + inumbas=i,basis_type=basis_type) IF(basis_type == "ORB") nobasis = .FALSE. END DO IF (nobasis) THEN @@ -1785,26 +1752,26 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& SELECT CASE (TRIM(potential_type)) CASE ("ALL") - CALL allocate_potential(qs_kind%all_potential,error) + CALL allocate_potential(qs_kind%all_potential) CALL read_potential(qs_kind%element_symbol,potential_name,& qs_kind%all_potential,zeff_correction,para_env,& - dft_section,potential_section,error) + dft_section,potential_section) CALL set_potential(qs_kind%all_potential,z=z) - CALL get_qs_kind(qs_kind,elec_conf=elec_conf,error=error) + CALL get_qs_kind(qs_kind,elec_conf=elec_conf) IF (.NOT.ASSOCIATED(elec_conf)) THEN CALL get_potential(potential=qs_kind%all_potential,elec_conf=elec_conf) - CALL set_qs_kind(qs_kind,elec_conf=elec_conf,error=error) + CALL set_qs_kind(qs_kind,elec_conf=elec_conf) END IF CASE ("GTH") - CALL allocate_potential(qs_kind%gth_potential,error) + CALL allocate_potential(qs_kind%gth_potential) CALL read_potential(qs_kind%element_symbol,potential_name,& qs_kind%gth_potential,zeff_correction,para_env,& - dft_section,potential_section,error) + dft_section,potential_section) CALL set_potential(qs_kind%gth_potential,z=z) - CALL get_qs_kind(qs_kind,elec_conf=elec_conf,error=error) + CALL get_qs_kind(qs_kind,elec_conf=elec_conf) IF (.NOT.ASSOCIATED(elec_conf)) THEN CALL get_potential(potential=qs_kind%gth_potential,elec_conf=elec_conf) - CALL set_qs_kind(qs_kind,elec_conf=elec_conf,error=error) + CALL set_qs_kind(qs_kind,elec_conf=elec_conf) END IF CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,& @@ -1830,10 +1797,10 @@ SUBROUTINE read_qs_kind(qs_kind,kind_section,para_env,force_env_section,& SELECT CASE (TRIM(kgpot_type)) CASE ("TNADD") - CALL allocate_potential(qs_kind%tnadd_potential,error) + CALL allocate_potential(qs_kind%tnadd_potential) CALL read_potential(qs_kind%element_symbol,kgpot_name,& qs_kind%tnadd_potential,para_env,& - dft_section,kgpot_section,error) + dft_section,kgpot_section) CASE ("NONE") NULLIFY(qs_kind%tnadd_potential) CASE DEFAULT @@ -1858,9 +1825,8 @@ END SUBROUTINE read_qs_kind !> \param kind_section ... !> \param para_env ... !> \param force_env_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_qs_kind_set(qs_kind_set, atomic_kind_set,kind_section,para_env,force_env_section,error) + SUBROUTINE create_qs_kind_set(qs_kind_set, atomic_kind_set,kind_section,para_env,force_env_section) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set @@ -1869,7 +1835,6 @@ SUBROUTINE create_qs_kind_set(qs_kind_set, atomic_kind_set,kind_section,para_env TYPE(section_vals_type), POINTER :: kind_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_qs_kind_set', & routineP = moduleN//':'//routineN @@ -1886,9 +1851,9 @@ SUBROUTINE create_qs_kind_set(qs_kind_set, atomic_kind_set,kind_section,para_env no_fail = .FALSE. ! Between all methods only SE and DFTB may not need a KIND section. - CALL section_vals_val_get(force_env_section,"METHOD",i_val=method,error=error) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=method) IF (method==do_qs) THEN - CALL section_vals_val_get(force_env_section,"DFT%QS%METHOD",i_val=qs_method,error=error) + CALL section_vals_val_get(force_env_section,"DFT%QS%METHOD",i_val=qs_method) SELECT CASE (qs_method) CASE (do_method_mndo, do_method_am1, do_method_pm3, do_method_pm6,& do_method_pdg, do_method_rm1, do_method_mndod, do_method_pnnl ) @@ -1907,7 +1872,7 @@ SUBROUTINE create_qs_kind_set(qs_kind_set, atomic_kind_set,kind_section,para_env qs_kind_set(ikind)%name = atomic_kind_set(ikind)%name qs_kind_set(ikind)%element_symbol = atomic_kind_set(ikind)%element_symbol qs_kind_set(ikind)%natom = atomic_kind_set(ikind)%natom - CALL read_qs_kind(qs_kind_set(ikind), kind_section, para_env, force_env_section, no_fail, qs_method, error) + CALL read_qs_kind(qs_kind_set(ikind), kind_section, para_env, force_env_section, no_fail, qs_method) END DO CALL timestop(handle) @@ -1920,14 +1885,12 @@ END SUBROUTINE create_qs_kind_set !> \param qs_kind ... !> \param dft_control ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE check_qs_kind(qs_kind,dft_control,subsys_section,error) + SUBROUTINE check_qs_kind(qs_kind,dft_control,subsys_section) TYPE(qs_kind_type), POINTER :: qs_kind TYPE(dft_control_type), INTENT(IN) :: dft_control TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_qs_kind', & routineP = moduleN//':'//routineN @@ -1938,23 +1901,23 @@ SUBROUTINE check_qs_kind(qs_kind,dft_control,subsys_section,error) TYPE(semi_empirical_type), POINTER :: se_parameter IF (dft_control%qs_control%semi_empirical) THEN - CALL get_qs_kind(qs_kind,se_parameter=se_parameter,error=error) - CPPostcondition(ASSOCIATED(se_parameter),cp_failure_level,routineP,error,failure) + CALL get_qs_kind(qs_kind,se_parameter=se_parameter) + CPPostcondition(ASSOCIATED(se_parameter),cp_failure_level,routineP,failure) CALL get_se_param(se_parameter,defined=defined) - CPPostcondition(defined,cp_failure_level,routineP,error,failure) - CALL write_se_param(se_parameter,subsys_section,error) + CPPostcondition(defined,cp_failure_level,routineP,failure) + CALL write_se_param(se_parameter,subsys_section) ELSE IF (dft_control%qs_control%dftb) THEN - CALL get_qs_kind(qs_kind,dftb_parameter=dftb_parameter,error=error) - CPPostcondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,error,failure) - CALL get_dftb_atom_param(dftb_parameter,defined=defined,error=error) - CPPostcondition(defined,cp_failure_level,routineP,error,failure) - CALL write_dftb_atom_param(dftb_parameter,subsys_section,error) + CALL get_qs_kind(qs_kind,dftb_parameter=dftb_parameter) + CPPostcondition(ASSOCIATED(dftb_parameter),cp_failure_level,routineP,failure) + CALL get_dftb_atom_param(dftb_parameter,defined=defined) + CPPostcondition(defined,cp_failure_level,routineP,failure) + CALL write_dftb_atom_param(dftb_parameter,subsys_section) ELSE IF (dft_control%qs_control%scptb) THEN - CALL get_qs_kind(qs_kind,scptb_parameter=scptb_parameter,error=error) - CPPostcondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,error,failure) - CALL get_scptb_parameter(scptb_parameter,defined=defined,error=error) - CPPostcondition(defined,cp_failure_level,routineP,error,failure) - CALL write_scptb_parameter(scptb_parameter,subsys_section,error) + CALL get_qs_kind(qs_kind,scptb_parameter=scptb_parameter) + CPPostcondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,failure) + CALL get_scptb_parameter(scptb_parameter,defined=defined) + CPPostcondition(defined,cp_failure_level,routineP,failure) + CALL write_scptb_parameter(scptb_parameter,subsys_section) END IF END SUBROUTINE check_qs_kind @@ -1965,16 +1928,14 @@ END SUBROUTINE check_qs_kind !> \param dft_control ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE check_qs_kind_set(qs_kind_set,dft_control,para_env,subsys_section,error) + SUBROUTINE check_qs_kind_set(qs_kind_set,dft_control,para_env,subsys_section) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(dft_control_type), INTENT(IN) :: dft_control TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'check_qs_kind_set', & routineP = moduleN//':'//routineN @@ -1987,7 +1948,7 @@ SUBROUTINE check_qs_kind_set(qs_kind_set,dft_control,para_env,subsys_section,err nkind = SIZE(qs_kind_set) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL check_qs_kind(qs_kind,dft_control,subsys_section,error) + CALL check_qs_kind(qs_kind,dft_control,subsys_section) END DO ELSE CALL stop_program(routineN,moduleN,__LINE__,& @@ -2015,13 +1976,12 @@ END SUBROUTINE check_qs_kind_set !> \param dftb_parameter ... !> \param scptb_parameter ... !> \param elec_conf ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_qs_kind(qs_kind,paw_atom,ghost,hard_radius,hard0_radius,& soft_basis_set,hard_basis_set,lmax_rho0,zeff,& no_optimize,dispersion,u_minus_j,reltmat,& dftb_parameter, scptb_parameter,& - elec_conf,error) + elec_conf) TYPE(qs_kind_type), INTENT(INOUT) :: qs_kind LOGICAL, INTENT(IN), OPTIONAL :: paw_atom, ghost @@ -2042,7 +2002,6 @@ SUBROUTINE set_qs_kind(qs_kind,paw_atom,ghost,hard_radius,hard0_radius,& POINTER :: scptb_parameter INTEGER, DIMENSION(:), INTENT(IN), & OPTIONAL :: elec_conf - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_qs_kind', & routineP = moduleN//':'//routineN @@ -2090,15 +2049,13 @@ END SUBROUTINE set_qs_kind !> \param qs_kind ... !> \param kind_number ... !> \param output_unit ... -!> \param error ... !> \par History !> Creation (09.02.2002,MK) ! ***************************************************************************** - SUBROUTINE write_qs_kind(qs_kind,kind_number,output_unit,error) + SUBROUTINE write_qs_kind(qs_kind,kind_number,output_unit) TYPE(qs_kind_type), POINTER :: qs_kind INTEGER, INTENT(in) :: kind_number, output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_qs_kind', & routineP = moduleN//':'//routineN @@ -2121,7 +2078,7 @@ SUBROUTINE write_qs_kind(qs_kind,kind_number,output_unit,error) DO ibas=1,SIZE(qs_kind%basis_sets,1) NULLIFY(tmp_basis) CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis,& - inumbas=ibas,basis_type=basis_type,error=error) + inumbas=ibas,basis_type=basis_type) IF(basis_type=="") CYCLE SELECT CASE (basis_type) CASE DEFAULT @@ -2138,7 +2095,7 @@ SUBROUTINE write_qs_kind(qs_kind,kind_number,output_unit,error) bstring = "LRI Basis Set" END SELECT - CALL write_orb_basis_set(tmp_basis,output_unit,bstring,error=error) + CALL write_orb_basis_set(tmp_basis,output_unit,bstring) END DO @@ -2155,12 +2112,12 @@ SUBROUTINE write_qs_kind(qs_kind,kind_number,output_unit,error) "Maximum GTO radius used for PAW projector construction:",& qs_kind%max_rad_local CALL write_orb_basis_set(qs_kind%soft_basis_set,output_unit,& - "GAPW Soft Basis Set",error=error) + "GAPW Soft Basis Set") END IF ! Potentials - CALL write_potential(qs_kind%all_potential,output_unit,error) - CALL write_potential(qs_kind%gth_potential,output_unit,error) - CALL write_potential(qs_kind%tnadd_potential,output_unit,error) + CALL write_potential(qs_kind%all_potential,output_unit) + CALL write_potential(qs_kind%gth_potential,output_unit) + CALL write_potential(qs_kind%tnadd_potential,output_unit) IF (ASSOCIATED(qs_kind%dft_plus_u)) THEN WRITE (UNIT=output_unit,FMT="(/,T6,A,/,T8,A,T76,I5,/,T8,A,T73,F8.3)")& "A DFT+U correction is applied to atoms of this atomic kind:",& @@ -2195,7 +2152,7 @@ SUBROUTINE write_qs_kind(qs_kind,kind_number,output_unit,error) END IF END IF ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF @@ -2206,15 +2163,13 @@ END SUBROUTINE write_qs_kind !> \brief Write an atomic kind set data set to the output unit. !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... !> \par History !> Creation (09.02.2002,MK) ! ***************************************************************************** - SUBROUTINE write_qs_kind_set(qs_kind_set,subsys_section,error) + SUBROUTINE write_qs_kind_set(qs_kind_set,subsys_section) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_qs_kind_set', & routineP = moduleN//':'//routineN @@ -2229,25 +2184,24 @@ SUBROUTINE write_qs_kind_set(qs_kind_set,subsys_section,error) failure = .FALSE. NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%KINDS",extension=".Log",& - error=error) + "PRINT%KINDS",extension=".Log") IF (output_unit > 0) THEN IF (ASSOCIATED(qs_kind_set)) THEN WRITE (UNIT=output_unit,FMT="(/,/,T2,A)") "ATOMIC KIND INFORMATION" nkind = SIZE(qs_kind_set) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL write_qs_kind(qs_kind,ikind,output_unit,error) + CALL write_qs_kind(qs_kind,ikind,output_unit) END DO ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%KINDS",error=error) + "PRINT%KINDS") CALL timestop(handle) @@ -2259,16 +2213,14 @@ END SUBROUTINE write_qs_kind_set !> database). !> \param qs_kind_set ... !> \param subsys_section ... -!> \param error ... !> \par History !> Creation (17.01.2002,MK) ! ***************************************************************************** - SUBROUTINE write_gto_basis_sets(qs_kind_set,subsys_section,error) + SUBROUTINE write_gto_basis_sets(qs_kind_set,subsys_section) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_gto_basis_sets', & routineP = moduleN//':'//routineN @@ -2285,10 +2237,10 @@ SUBROUTINE write_gto_basis_sets(qs_kind_set,subsys_section,error) failure = .FALSE. NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,subsys_section,& "PRINT%KINDS/BASIS_SET",& - extension=".Log",error=error) + extension=".Log") IF (output_unit > 0) THEN IF (ASSOCIATED(qs_kind_set)) THEN WRITE (UNIT=output_unit,FMT="(/,/,T2,A)")& @@ -2302,7 +2254,7 @@ SUBROUTINE write_gto_basis_sets(qs_kind_set,subsys_section,error) DO ibas=1,SIZE(qs_kind%basis_sets,1) NULLIFY(tmp_basis) CALL get_basis_from_container(qs_kind%basis_sets,basis_set=tmp_basis,& - inumbas=ibas,basis_type=basis_type,error=error) + inumbas=ibas,basis_type=basis_type) IF(basis_type=="") CYCLE SELECT CASE (basis_type) CASE DEFAULT @@ -2319,21 +2271,21 @@ SUBROUTINE write_gto_basis_sets(qs_kind_set,subsys_section,error) bstring = "LRI Basis Set" END SELECT - CALL write_gto_basis_set(tmp_basis,output_unit,bstring,error) + CALL write_gto_basis_set(tmp_basis,output_unit,bstring) END DO CALL write_gto_basis_set(qs_kind%soft_basis_set,& - output_unit,"GAPW Soft Basis Set",error) + output_unit,"GAPW Soft Basis Set") END DO ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%KINDS/BASIS_SET",error=error) + "PRINT%KINDS/BASIS_SET") CALL timestop(handle) @@ -2349,15 +2301,13 @@ END SUBROUTINE write_gto_basis_sets !> \param ncalc ... !> \param ncore ... !> \param nelem ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_atom_electronic_state (atomic_kind,qs_kind,ispin,ncalc,ncore,nelem,error) + SUBROUTINE init_atom_electronic_state (atomic_kind,qs_kind,ispin,ncalc,ncore,nelem) TYPE(atomic_kind_type), INTENT(IN) :: atomic_kind TYPE(qs_kind_type), INTENT(IN) :: qs_kind INTEGER, INTENT(IN) :: ispin INTEGER, DIMENSION(0:3, 10), INTENT(OUT) :: ncalc, ncore, nelem - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_atom_electronic_state', & routineP = moduleN//':'//routineN @@ -2374,7 +2324,7 @@ SUBROUTINE init_atom_electronic_state (atomic_kind,qs_kind,ispin,ncalc,ncore,nel CALL get_qs_kind(qs_kind,& gth_potential=gth_potential,& bs_occupation=bs_occupation,& - addel=addel,laddel=laddel,naddel=naddel,error=error) + addel=addel,laddel=laddel,naddel=naddel) ! electronic state nelem = 0 diff --git a/src/qs_kinetic.F b/src/qs_kinetic.F index e985b668d8..6a24721f24 100644 --- a/src/qs_kinetic.F +++ b/src/qs_kinetic.F @@ -78,7 +78,6 @@ MODULE qs_kinetic !> \param matrix_p density matrix for force calculation (optional) !> \param matrixkp_p density matrix for force calculation with kpoints (optional) !> \param eps_filter Filter final matrix (optional) -!> \param error for error handling !> \date 11.10.2010 !> \par History !> Ported from qs_overlap, replaces code in build_core_hamiltonian @@ -90,7 +89,7 @@ MODULE qs_kinetic ! ***************************************************************************** SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& basis_type,sab_nl,calculate_forces,matrix_p,matrixkp_p,& - eps_filter,error) + eps_filter) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -106,7 +105,6 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & OPTIONAL, POINTER :: matrixkp_p REAL(KIND=dp), INTENT(IN), OPTIONAL :: eps_filter - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_kinetic_matrix', & routineP = moduleN//':'//routineN @@ -160,11 +158,11 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& use_cell_mapping = .FALSE. ELSEIF (PRESENT(matrixkp_t)) THEN dokp = .TRUE. - CALL get_ks_env(ks_env=ks_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_ks_env(ks_env=ks_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) use_cell_mapping = (SIZE(cell_to_index) > 1) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF NULLIFY (atomic_kind_set, qs_kind_set, p_block,dft_control) @@ -173,57 +171,56 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& atomic_kind_set=atomic_kind_set,& natom=natom,& qs_kind_set=qs_kind_set,& - dbcsr_dist=dbcsr_dist,& - error=error) + dbcsr_dist=dbcsr_dist) nimg = dft_control%nimages nkind = SIZE(atomic_kind_set) ALLOCATE (atom_of_kind(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) do_forces = .FALSE. IF (PRESENT(calculate_forces)) do_forces = calculate_forces ! check for symmetry - CPPrecondition(SIZE(sab_nl) > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(sab_nl) > 0,cp_failure_level,routineP,failure) CALL get_neighbor_list_set_p(neighbor_list_sets=sab_nl,symmetric=do_symmetric) ! prepare basis set ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL basis_set_list_setup(basis_set_list,basis_type,qs_kind_set,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL basis_set_list_setup(basis_set_list,basis_type,qs_kind_set) IF(dokp) THEN - CALL cp_dbcsr_allocate_matrix_set(matrixkp_t,1,nimg,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrixkp_t,1,nimg) CALL create_sab_matrix(ks_env, matrixkp_t, matrix_name, basis_set_list, basis_set_list, & - sab_nl, do_symmetric, error) + sab_nl, do_symmetric) ELSE - CALL cp_dbcsr_allocate_matrix_set(matrix_t,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_t,1) CALL create_sab_matrix(ks_env, matrix_t, matrix_name, basis_set_list, basis_set_list, & - sab_nl, do_symmetric, error) + sab_nl, do_symmetric) END IF IF (do_forces) THEN ! if forces -> maybe virial too - CALL get_ks_env(ks_env=ks_env,force=force,virial=virial,error=error) + CALL get_ks_env(ks_env=ks_env,force=force,virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ! we need density matrix for forces IF(dokp) THEN - CPPrecondition(PRESENT(matrixkp_p),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrixkp_p),cp_failure_level,routineP,failure) ELSE - CPPrecondition(PRESENT(matrix_p),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrix_p),cp_failure_level,routineP,failure) END IF END IF ! *** Allocate work storage *** - ldsab = get_memory_usage(qs_kind_set,basis_type,error=error) + ldsab = get_memory_usage(qs_kind_set,basis_type) ALLOCATE (kab(ldsab,ldsab),qab(ldsab,ldsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (do_forces) THEN ALLOCATE(dab(ldsab,ldsab,3),pab(ldsab,ldsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! Iterate of neighbor list @@ -262,7 +259,7 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& IF(use_cell_mapping) THEN ic = cell_to_index(cell(1),cell(2),cell(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) ELSE ic = 1 END IF @@ -288,11 +285,11 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& IF(dokp) THEN CALL cp_dbcsr_get_block_p(matrix=matrixkp_t(1,ic)%matrix,& row=irow,col=icol,BLOCK=k_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ELSE CALL cp_dbcsr_get_block_p(matrix=matrix_t(1)%matrix,& row=irow,col=icol,BLOCK=k_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END IF IF (do_forces) THEN @@ -300,11 +297,11 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& IF(dokp) THEN CALL cp_dbcsr_get_block_p(matrix=matrixkp_p(1,ic)%matrix,& row=irow,col=icol,block=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ELSE CALL cp_dbcsr_get_block_p(matrix=matrix_p,row=irow,col=icol,& block=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END IF END IF @@ -327,30 +324,30 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& IF (do_forces .AND. ASSOCIATED(p_block) .AND. ((iatom/=jatom) .OR. use_virial)) THEN ! Decontract P matrix block kab = 0.0_dp - CALL block_add("OUT",kab,nsgfa(iset),nsgfb(jset),p_block,sgfa,sgfb,trans=trans,error=error) + CALL block_add("OUT",kab,nsgfa(iset),nsgfb(jset),p_block,sgfa,sgfb,trans=trans) CALL decontraction(kab,pab,scon_a(:,sgfa:),ncoa,nsgfa(iset),scon_b(:,sgfb:),ncob,nsgfb(jset),& - trans=trans,error=error) + trans=trans) ! calculate integrals and derivatives CALL kinetic(la_max(iset),la_min(iset),npgfa(iset),rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),rpgfb(:,jset),zetb(:,jset),& - rab,kab,dab,error=error) - CALL force_trace(force_a,dab,pab,ncoa,ncob,3,error=error) + rab,kab,dab) + CALL force_trace(force_a,dab,pab,ncoa,ncob,3) force(ikind)%kinetic(:,atom_a)=force(ikind)%kinetic(:,atom_a) + ff*force_a(:) force(jkind)%kinetic(:,atom_b)=force(jkind)%kinetic(:,atom_b) - ff*force_a(:) IF( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, f0, force_a, rab, error) + CALL virial_pair_force ( virial%pv_virial, f0, force_a, rab) END IF ELSE ! calclulate integrals CALL kinetic(la_max(iset),la_min(iset),npgfa(iset),rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),rpgfb(:,jset),zetb(:,jset),& - rab,kab,error=error) + rab,kab) END IF ! Contraction step CALL contraction(kab,qab,ca=scon_a(:,sgfa:),na=ncoa,ma=nsgfa(iset),& cb=scon_b(:,sgfb:),nb=ncob,mb=nsgfb(jset),& - trans=trans,error=error) - CALL block_add("IN",qab,nsgfa(iset),nsgfb(jset),k_block,sgfa,sgfb,trans=trans,error=error) + trans=trans) + CALL block_add("IN",qab,nsgfa(iset),nsgfb(jset),k_block,sgfa,sgfb,trans=trans) END DO END DO @@ -360,29 +357,29 @@ SUBROUTINE build_kinetic_matrix(ks_env,matrix_t,matrixkp_t,matrix_name,& IF(dokp) THEN DO ic=1,nimg - CALL cp_dbcsr_finalize(matrixkp_t(1,ic)%matrix, error=error) + CALL cp_dbcsr_finalize(matrixkp_t(1,ic)%matrix) IF (PRESENT(eps_filter)) THEN - CALL cp_dbcsr_filter(matrixkp_t(1,ic)%matrix, eps_filter, error=error) + CALL cp_dbcsr_filter(matrixkp_t(1,ic)%matrix, eps_filter) END IF END DO ELSE - CALL cp_dbcsr_finalize(matrix_t(1)%matrix, error=error) + CALL cp_dbcsr_finalize(matrix_t(1)%matrix) IF (PRESENT(eps_filter)) THEN - CALL cp_dbcsr_filter(matrix_t(1)%matrix, eps_filter, error=error) + CALL cp_dbcsr_filter(matrix_t(1)%matrix, eps_filter) END IF END IF ! Release work storage DEALLOCATE (atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (kab,qab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(do_forces) THEN DEALLOCATE (pab,dab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/qs_kpp1_env_methods.F b/src/qs_kpp1_env_methods.F index 89c62a3a56..165366f990 100644 --- a/src/qs_kpp1_env_methods.F +++ b/src/qs_kpp1_env_methods.F @@ -103,15 +103,12 @@ MODULE qs_kpp1_env_methods ! ***************************************************************************** !> \brief allocates and initializes a kpp1_env !> \param kpp1_env the environement to initialize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE kpp1_create(kpp1_env, error) + SUBROUTINE kpp1_create(kpp1_env) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_create', & routineP = moduleN//':'//routineN @@ -122,7 +119,7 @@ SUBROUTINE kpp1_create(kpp1_env, error) failure=.FALSE. ALLOCATE(kpp1_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(kpp1_env%v_rspace, kpp1_env%v_ao, kpp1_env%drho_r,& kpp1_env%rho_set, & kpp1_env%deriv_set, kpp1_env%spin_pot, kpp1_env%grad_pot,& @@ -145,10 +142,8 @@ END SUBROUTINE kpp1_create !> \param rho1 the density that represent the first direction along which !> you should evaluate the derivatives !> \param rho1_xc ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, error) + SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env TYPE(qs_p_env_type), POINTER :: p_env @@ -157,7 +152,6 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, POINTER :: k_p_p1 TYPE(qs_rho_type), POINTER :: rho, rho1 TYPE(qs_rho_type), OPTIONAL, POINTER :: rho1_xc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_calc_k_p_p1', & routineP = moduleN//':'//routineN @@ -198,108 +192,105 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, NULLIFY(auxbas_pw_pool, pw_pools, pw_env, v_rspace_new, & rho1_r, rho1_g_pw, tau_pw, v_xc, rho1_set,& poisson_env, input, scf_section, rho1_g, rho_ao) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ionode = logger%para_env%mepos==logger%para_env%source - CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(k_p_p1),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho1),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(k_p_p1),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho1),cp_failure_level,routineP,failure) - CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL kpp1_check_i_alloc(kpp1_env,qs_env=qs_env,error=error) + CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,failure) + CALL kpp1_check_i_alloc(kpp1_env,qs_env=qs_env) CALL get_qs_env(qs_env=qs_env,& pw_env=pw_env,& - input=input,& - error=error) + input=input) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) - CALL qs_rho_get(rho1, rho_g=rho1_g, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) + CALL qs_rho_get(rho1, rho_g=rho1_g) - gapw=(section_get_ival(input,"DFT%QS%METHOD",error=error)==do_method_gapw) - gapw_xc=(section_get_ival(input,"DFT%QS%METHOD",error=error)==do_method_gapw_xc) + gapw=(section_get_ival(input,"DFT%QS%METHOD")==do_method_gapw) + gapw_xc=(section_get_ival(input,"DFT%QS%METHOD")==do_method_gapw_xc) IF(gapw_xc) THEN - CPPrecondition(ASSOCIATED(rho1_xc),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho1_xc),cp_failure_level,routineP,failure) END IF nspins = SIZE(k_p_p1) lsd = (nspins==2) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) - scf_section => section_vals_get_subs_vals(input,"DFT%SCF",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") + scf_section => section_vals_get_subs_vals(input,"DFT%SCF") CALL section_vals_val_get(input,"DFT%EXCITATIONS",& - i_val=excitations,error=error) + i_val=excitations) IF (excitations==tddfpt_excitations) THEN - xc_section => section_vals_get_subs_vals(input,"DFT%TDDFPT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%TDDFPT%XC") !FM this check should already had happened and section made explicit, give an error? - CALL section_vals_get(xc_section,explicit=explicit,error=error) + CALL section_vals_get(xc_section,explicit=explicit) IF (.NOT.explicit) THEN - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") END IF END IF CALL section_vals_val_get(input,"DFT%TDDFPT%LSD_SINGLETS",& - l_val=lsd_singlets,error=error) + l_val=lsd_singlets) CALL section_vals_val_get(input,"DFT%TDDFPT%RES_ETYPE",& - i_val=res_etype,error=error) + i_val=res_etype) kpp1_env%iter=kpp1_env%iter+1 ! gets the tmp grids - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools, poisson_env=poisson_env,error=error) + pw_pools=pw_pools, poisson_env=poisson_env) ALLOCATE(v_rspace_new(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_gspace%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_rspace%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) IF (gapw .OR. gapw_xc) & - CALL prepare_gapw_den(qs_env,p_env%local_rho_set, do_rho0=(.NOT.gapw_xc), error=error) + CALL prepare_gapw_den(qs_env,p_env%local_rho_set, do_rho0=(.NOT.gapw_xc)) ! *** calculate the hartree potential on the total density *** CALL pw_pool_create_pw(auxbas_pw_pool, rho1_tot_gspace%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) - CALL pw_copy(rho1_g(1)%pw,rho1_tot_gspace%pw,error=error) + CALL pw_copy(rho1_g(1)%pw,rho1_tot_gspace%pw) DO ispin=2,nspins - CALL pw_axpy(rho1_g(ispin)%pw, rho1_tot_gspace%pw, error=error) + CALL pw_axpy(rho1_g(ispin)%pw, rho1_tot_gspace%pw) END DO IF (gapw) & - CALL pw_axpy(p_env%local_rho_set%rho0_mpole%rho0_s_gs%pw, rho1_tot_gspace%pw,& - error=error) + CALL pw_axpy(p_env%local_rho_set%rho0_mpole%rho0_s_gs%pw, rho1_tot_gspace%pw) - IF (cp_print_key_should_output(logger%iter_info,scf_section,"PRINT%TOTAL_DENSITIES",& - error=error)/=0) THEN + IF (cp_print_key_should_output(logger%iter_info,scf_section,"PRINT%TOTAL_DENSITIES")& + /=0) THEN output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%TOTAL_DENSITIES",& - extension=".scfLog",error=error) - CALL print_densities(rho1, rho1_tot_gspace, output_unit, error=error) + extension=".scfLog") + CALL print_densities(rho1, rho1_tot_gspace, output_unit) CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%TOTAL_DENSITIES", error=error) + "PRINT%TOTAL_DENSITIES") END IF IF (.NOT.(nspins==1 .AND. excitations==tddfpt_excitations .AND. & res_etype /= tddfpt_singlet )) THEN CALL pw_poisson_solve(poisson_env,rho1_tot_gspace%pw, & energy_hartree, & - v_hartree_gspace%pw,error=error) - CALL pw_transfer(v_hartree_gspace%pw,v_hartree_rspace%pw,error=error) + v_hartree_gspace%pw) + CALL pw_transfer(v_hartree_gspace%pw,v_hartree_rspace%pw) END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool, rho1_tot_gspace%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, rho1_tot_gspace%pw) ! *** calculate the xc potential *** IF(gapw_xc) THEN - CALL qs_rho_get(rho1_xc, rho_r=rho1_r, error=error) + CALL qs_rho_get(rho1_xc, rho_r=rho1_r) ELSE - CALL qs_rho_get(rho1, rho_r=rho1_r, error=error) + CALL qs_rho_get(rho1, rho_r=rho1_r) END IF IF (nspins == 1 .AND. excitations==tddfpt_excitations .AND. & @@ -310,8 +301,8 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, DO ispin=1, 2 NULLIFY(rho1_r_pw(ispin)%pw) CALL pw_create(rho1_r_pw(ispin)%pw, rho1_r(1)%pw%pw_grid, & - rho1_r(1)%pw%in_use, rho1_r(1)%pw%in_space,error=error) - CALL pw_transfer(rho1_r(1)%pw, rho1_r_pw(ispin)%pw,error=error) + rho1_r(1)%pw%in_use, rho1_r(1)%pw%in_space) + CALL pw_transfer(rho1_r(1)%pw, rho1_r_pw(ispin)%pw) END DO ELSE @@ -319,7 +310,7 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, ALLOCATE(rho1_r_pw(nspins)) DO ispin=1, nspins rho1_r_pw(ispin)%pw => rho1_r(ispin)%pw - CALL pw_retain(rho1_r_pw(ispin)%pw,error=error) + CALL pw_retain(rho1_r_pw(ispin)%pw) END DO END IF @@ -332,29 +323,27 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, bo = rho1_r(1)%pw%pw_grid%bounds_local ! create the place where to store the argument for the functionals CALL xc_rho_set_create(rho1_set, bo, & - rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF",error=error), & - drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF",error=error), & - tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF",error=error), & - error=error) + rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF"), & + drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF"), & + tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF")) - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",& - error=error) - needs=xc_functionals_get_needs(xc_fun_section,lsd,.TRUE.,error) + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") + needs=xc_functionals_get_needs(xc_fun_section,lsd,.TRUE.) ! calculate the arguments needed by the functionals CALL xc_rho_set_update(rho1_set, rho1_r_pw, rho1_g_pw, tau_pw, needs,& - section_get_ival(xc_section,"XC_GRID%XC_DERIV",error=error),& - section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO",error=error),& - auxbas_pw_pool, error) + section_get_ival(xc_section,"XC_GRID%XC_DERIV"),& + section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO"),& + auxbas_pw_pool) ALLOCATE(v_xc(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1, nspins NULLIFY(v_xc(ispin)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,v_xc(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(v_xc(ispin)%pw,error=error) + in_space = REALSPACE) + CALL pw_zero(v_xc(ispin)%pw) END DO fac=0._dp @@ -365,23 +354,23 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, CALL xc_calc_2nd_deriv(v_xc, kpp1_env%deriv_set, kpp1_env%rho_set, & rho1_set, auxbas_pw_pool,xc_section=xc_section,& - tddfpt_fac=fac, error=error) + tddfpt_fac=fac) DO ispin=1,nspins v_rspace_new(ispin)%pw => v_xc(ispin)%pw END DO DEALLOCATE(v_xc,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - IF (gapw) CALL calculate_xc_2nd_deriv_atom(p_env, qs_env, xc_section, error=error) + IF (gapw) CALL calculate_xc_2nd_deriv_atom(p_env, qs_env, xc_section) - CALL xc_rho_set_release(rho1_set,error=error) + CALL xc_rho_set_release(rho1_set) DO ispin=1,SIZE(rho1_r_pw) - CALL pw_release(rho1_r_pw(ispin)%pw,error=error) + CALL pw_release(rho1_r_pw(ispin)%pw) END DO DEALLOCATE(rho1_r_pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !-------------------------------! ! Add both hartree and xc terms ! @@ -403,12 +392,12 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, END IF ! remove kpp1_env%v_ao and work directly on k_p_p1 ? - CALL cp_dbcsr_set(kpp1_env%v_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(kpp1_env%v_ao(ispin)%matrix,0.0_dp) CALL integrate_v_rspace(v_rspace=v_rspace_new(ispin),& pmat=rho_ao(ispin),& hmat=kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw_xc,error=error) + calculate_forces=.FALSE.,gapw=gapw_xc) ! add hartree only for SINGLETS IF (res_etype == tddfpt_singlet) THEN @@ -420,16 +409,16 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, pmat=rho_ao(ispin),& hmat=kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw,error=error) + calculate_forces=.FALSE.,gapw=gapw) END IF ELSE ! remove kpp1_env%v_ao and work directly on k_p_p1 ? - CALL cp_dbcsr_set(kpp1_env%v_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(kpp1_env%v_ao(ispin)%matrix,0.0_dp) CALL integrate_v_rspace(v_rspace=v_rspace_new(ispin),& pmat=rho_ao(ispin),& hmat=kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw_xc,error=error) + calculate_forces=.FALSE.,gapw=gapw_xc) IF (ispin == 1) THEN v_hartree_rspace%pw%cr3d = v_hartree_rspace%pw%cr3d * & @@ -440,7 +429,7 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, pmat=rho_ao(ispin),& hmat=kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw,error=error) + calculate_forces=.FALSE.,gapw=gapw) END IF ELSE @@ -473,24 +462,24 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, END IF ! remove kpp1_env%v_ao and work directly on k_p_p1 ? - CALL cp_dbcsr_set(kpp1_env%v_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(kpp1_env%v_ao(ispin)%matrix,0.0_dp) CALL integrate_v_rspace(v_rspace=v_rspace_new(ispin),& pmat=rho_ao(ispin),& hmat=kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw,error=error) + calculate_forces=.FALSE.,gapw=gapw) END IF - CALL cp_dbcsr_copy(k_p_p1(ispin)%matrix,kpp1_env%v_ao(ispin)%matrix,error=error) + CALL cp_dbcsr_copy(k_p_p1(ispin)%matrix,kpp1_env%v_ao(ispin)%matrix) END DO IF (gapw) THEN IF (.NOT. (excitations==tddfpt_excitations .AND. (nspins == 1 .AND. & res_etype == tddfpt_triplet))) THEN - CALL Vh_1c_gg_integrals(qs_env,energy_hartree_1c, .TRUE., p_env=p_env,error=error) + CALL Vh_1c_gg_integrals(qs_env,energy_hartree_1c, .TRUE., p_env=p_env) CALL integrate_vhg0_rspace(qs_env, v_hartree_rspace, & - .FALSE., .TRUE., p_env=p_env, error=error) + .FALSE., .TRUE., p_env=p_env) END IF ! *** Add single atom contributions to the KS matrix *** ! remap pointer @@ -498,19 +487,16 @@ SUBROUTINE kpp1_calc_k_p_p1(kpp1_env, p_env, qs_env, k_p_p1, rho, rho1, rho1_xc, ksmat(1:ns,1:1) => k_p_p1(1:ns) ns = SIZE(rho_ao) psmat(1:ns,1:1) => rho_ao(1:ns) - CALL update_ks_atom(qs_env,ksmat,psmat,.FALSE.,.TRUE.,p_env,error) + CALL update_ks_atom(qs_env,ksmat,psmat,.FALSE.,.TRUE.,p_env) END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw,& - error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_rspace%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_rspace%pw) DO ispin=1,nspins - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw) END DO DEALLOCATE(v_rspace_new, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE kpp1_calc_k_p_p1 @@ -525,8 +511,6 @@ END SUBROUTINE kpp1_calc_k_p_p1 !> \param rho1 the density that represent the first direction along which !> you should evaluate the derivatives !> \param diff the amount of the finite difference step -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2003 created [fawzi] !> \author Fawzi Mohamed @@ -535,13 +519,12 @@ END SUBROUTINE kpp1_calc_k_p_p1 !> rescale my_diff depending on the norm of rho1? ! ***************************************************************************** SUBROUTINE kpp1_calc_k_p_p1_fdiff(qs_env,k_p_p1,rho,rho1,& - diff, error) + diff) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: k_p_p1 TYPE(qs_rho_type), POINTER :: rho, rho1 REAL(KIND=dp), INTENT(in), OPTIONAL :: diff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_calc_k_p_p1_fdiff', & routineP = moduleN//':'//routineN @@ -560,15 +543,15 @@ SUBROUTINE kpp1_calc_k_p_p1_fdiff(qs_env,k_p_p1,rho,rho1,& IF (PRESENT(diff)) my_diff=diff CALL allocate_qs_energy(qs_energy) - CALL qs_rho_get(rho, rho_ao=rho_ao, rho_r=rho_r, rho_g=rho_g, error=error) - CALL qs_rho_get(rho1, rho_ao=rho1_ao, rho_r=rho1_r, rho_g=rho1_g, error=error) - CALL get_qs_env(qs_env, matrix_s=matrix_s,error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao, rho_r=rho_r, rho_g=rho_g) + CALL qs_rho_get(rho1, rho_ao=rho1_ao, rho_r=rho1_r, rho_g=rho1_g) + CALL get_qs_env(qs_env, matrix_s=matrix_s) ! rho = rho0+h/2*rho1 my_diff=my_diff/2.0_dp DO ispin=1,SIZE(k_p_p1) CALL cp_dbcsr_add(rho_ao(ispin)%matrix,rho1_ao(ispin)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=my_diff,error=error) + alpha_scalar=1.0_dp,beta_scalar=my_diff) rho_r(ispin)%pw%cr3d = rho_r(ispin)%pw%cr3d + my_diff*rho1_r(ispin)%pw%cr3d rho_g(ispin)%pw%cc = rho_g(ispin)%pw%cc + my_diff*rho1_g(ispin)%pw%cc END DO @@ -576,22 +559,21 @@ SUBROUTINE kpp1_calc_k_p_p1_fdiff(qs_env,k_p_p1,rho,rho1,& CALL qs_ks_build_kohn_sham_matrix(qs_env,& ext_ks_matrix=k_p_p1,& calculate_forces=.FALSE.,& - just_energy=.FALSE.,& - error=error) + just_energy=.FALSE.) - CALL cp_dbcsr_allocate_matrix_set(ks_2,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(ks_2,nspins) DO ispin=1,nspins ALLOCATE(ks_2(ispin)%matrix) - CALL cp_dbcsr_init(ks_2(ispin)%matrix,error=error) + CALL cp_dbcsr_init(ks_2(ispin)%matrix) CALL cp_dbcsr_copy(ks_2(ispin)%matrix,matrix_s(1)%matrix,& - name="tmp_ks2-"//ADJUSTL(cp_to_string(ispin)),error=error) + name="tmp_ks2-"//ADJUSTL(cp_to_string(ispin))) END DO ! rho = rho0-h/2*rho1 my_diff=-2.0_dp*my_diff DO ispin=1,nspins CALL cp_dbcsr_add(rho_ao(ispin)%matrix,rho1_ao(ispin)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=my_diff,error=error) + alpha_scalar=1.0_dp,beta_scalar=my_diff) rho_r(ispin)%pw%cr3d = rho_r(ispin)%pw%cr3d + my_diff*rho1_r(ispin)%pw%cr3d rho_g(ispin)%pw%cc = rho_g(ispin)%pw%cc + my_diff*rho1_g(ispin)%pw%cc END DO @@ -599,14 +581,13 @@ SUBROUTINE kpp1_calc_k_p_p1_fdiff(qs_env,k_p_p1,rho,rho1,& CALL qs_ks_build_kohn_sham_matrix(qs_env,& ext_ks_matrix=ks_2,& calculate_forces=.FALSE.,& - just_energy=.FALSE.,& - error=error) + just_energy=.FALSE.) ! rho = rho0 my_diff=-0.5_dp*my_diff DO ispin=1,nspins CALL cp_dbcsr_add(rho_ao(ispin)%matrix,rho1_ao(ispin)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=my_diff,error=error) + alpha_scalar=1.0_dp,beta_scalar=my_diff) rho_r(ispin)%pw%cr3d = rho_r(ispin)%pw%cr3d + my_diff*rho1_r(ispin)%pw%cr3d rho_g(ispin)%pw%cc = rho_g(ispin)%pw%cc + my_diff*rho1_g(ispin)%pw%cc END DO @@ -614,11 +595,11 @@ SUBROUTINE kpp1_calc_k_p_p1_fdiff(qs_env,k_p_p1,rho,rho1,& ! k_p_p1=(H(rho0+h/2 rho1)-H(rho0-h/2 rho1))/h DO ispin=1,nspins CALL cp_dbcsr_add(k_p_p1(ispin)%matrix,ks_2(ispin)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) - CALL cp_dbcsr_scale(k_p_p1(ispin)%matrix,alpha_scalar=0.5_dp/my_diff,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) + CALL cp_dbcsr_scale(k_p_p1(ispin)%matrix,alpha_scalar=0.5_dp/my_diff) END DO - CALL cp_dbcsr_deallocate_matrix_set(ks_2,error=error) + CALL cp_dbcsr_deallocate_matrix_set(ks_2) CALL deallocate_qs_energy(qs_energy) END SUBROUTINE kpp1_calc_k_p_p1_fdiff @@ -626,17 +607,14 @@ END SUBROUTINE kpp1_calc_k_p_p1_fdiff !> \brief checks that the intenal storage is allocated, and allocs it if needed !> \param kpp1_env the environment to check !> \param qs_env the qs environment this kpp1_env lives in -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed !> \note !> private routine ! ***************************************************************************** - SUBROUTINE kpp1_check_i_alloc(kpp1_env, qs_env, error) + SUBROUTINE kpp1_check_i_alloc(kpp1_env, qs_env) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_check_i_alloc', & routineP = moduleN//':'//routineN @@ -658,86 +636,85 @@ SUBROUTINE kpp1_check_i_alloc(kpp1_env, qs_env, error) failure=.FALSE. NULLIFY(pw_env,auxbas_pw_pool,matrix_s,rho,rho_r,input) - CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,error,failure) - CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,failure) + CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env, pw_env=pw_env,& - matrix_s=matrix_s, input=input, error=error, rho=rho) + matrix_s=matrix_s, input=input,rho=rho) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) nspins=SIZE(rho_r) - CALL pw_env_get(pw_env, auxbas_pw_pool = auxbas_pw_pool, error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool = auxbas_pw_pool) IF (.NOT.ASSOCIATED(kpp1_env%v_rspace)) THEN ALLOCATE(kpp1_env%v_rspace(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins CALL pw_pool_create_pw(auxbas_pw_pool, & kpp1_env%v_rspace(ispin)%pw,& - use_data=REALDATA3D, in_space=REALSPACE,error=error) + use_data=REALDATA3D, in_space=REALSPACE) END DO END IF IF (.NOT.ASSOCIATED(kpp1_env%v_ao)) THEN - CALL cp_dbcsr_allocate_matrix_set(kpp1_env%v_ao,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(kpp1_env%v_ao,nspins) DO ispin=1,nspins ALLOCATE(kpp1_env%v_ao(ispin)%matrix) - CALL cp_dbcsr_init(kpp1_env%v_ao(ispin)%matrix,error=error) + CALL cp_dbcsr_init(kpp1_env%v_ao(ispin)%matrix) CALL cp_dbcsr_copy(kpp1_env%v_ao(ispin)%matrix,matrix_s(1)%matrix,& - name="kpp1%v_ao-"//ADJUSTL(cp_to_string(ispin)),error=error) + name="kpp1%v_ao-"//ADJUSTL(cp_to_string(ispin))) END DO END IF IF (.not.ASSOCIATED(kpp1_env%deriv_set)) THEN CALL section_vals_val_get(input,"DFT%EXCITATIONS",& - i_val=excitations,error=error) + i_val=excitations) CALL section_vals_val_get(input,"DFT%TDDFPT%LSD_SINGLETS",& - l_val=lsd_singlets,error=error) + l_val=lsd_singlets) CALL section_vals_val_get(input,"DFT%TDDFPT%RES_ETYPE",& - i_val=res_etype,error=error) + i_val=res_etype) IF (nspins==1.AND.(excitations==tddfpt_excitations.and.& (lsd_singlets .OR. res_etype == tddfpt_triplet))) THEN ALLOCATE(my_rho_r(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,2 CALL pw_pool_create_pw(auxbas_pw_pool,my_rho_r(ispin)%pw, & - use_data=rho_r(1)%pw%in_use, in_space=rho_r(1)%pw%in_space,& - error=error) + use_data=rho_r(1)%pw%in_use, in_space=rho_r(1)%pw%in_space) my_rho_r(ispin)%pw%cr3d = 0.5_dp * rho_r(1)%pw%cr3d END DO ELSE ALLOCATE(my_rho_r(SIZE(rho_r)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,SIZE(rho_r) my_rho_r(ispin)%pw => rho_r(ispin)%pw - CALL pw_retain(my_rho_r(ispin)%pw,error=error) + CALL pw_retain(my_rho_r(ispin)%pw) END DO END IF - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") CALL section_vals_val_get(input,"DFT%EXCITATIONS",& - i_val=excitations,error=error) + i_val=excitations) IF (excitations==tddfpt_excitations) THEN - xc_section => section_vals_get_subs_vals(input,"DFT%TDDFPT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%TDDFPT%XC") !FM this check should already had happened and section made explicit, give an error? - CALL section_vals_get(xc_section,explicit=explicit,error=error) + CALL section_vals_get(xc_section,explicit=explicit) IF (.NOT.explicit) THEN - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") END IF END IF CALL xc_prep_2nd_deriv(kpp1_env%deriv_set, kpp1_env%rho_set, & my_rho_r, auxbas_pw_pool, & - xc_section=xc_section, error=error) + xc_section=xc_section) DO ispin=1,SIZE(my_rho_r) - CALL pw_release(my_rho_r(ispin)%pw,error=error) + CALL pw_release(my_rho_r(ispin)%pw) END DO DEALLOCATE(my_rho_r,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE kpp1_check_i_alloc @@ -749,18 +726,15 @@ END SUBROUTINE kpp1_check_i_alloc !> \param s_struct_changed true if the structure of the s matrix has changed !> \param grid_changed true if the grids have changed and have to be rebuilt !> \param psi0_changed true if the value of psi0 (qs_env%rho) has changed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE kpp1_did_change(kpp1_env, s_struct_changed, grid_changed,& - psi0_changed, error) + psi0_changed) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env LOGICAL, INTENT(in), OPTIONAL :: s_struct_changed, & grid_changed, psi0_changed - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_did_change', & routineP = moduleN//':'//routineN @@ -776,44 +750,44 @@ SUBROUTINE kpp1_did_change(kpp1_env, s_struct_changed, grid_changed,& IF (PRESENT(s_struct_changed)) my_s_struct_changed=s_struct_changed IF (PRESENT(psi0_changed)) my_psi0_changed=psi0_changed - CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,error,failure) - CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,failure) + CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,failure) IF (my_s_struct_changed) THEN IF (ASSOCIATED(kpp1_env%v_ao)) THEN - CALL cp_dbcsr_deallocate_matrix_set(kpp1_env%v_ao,error=error) + CALL cp_dbcsr_deallocate_matrix_set(kpp1_env%v_ao) END IF END IF IF (my_s_struct_changed.or.my_psi0_changed) THEN IF (ASSOCIATED(kpp1_env%drho_r)) THEN DEALLOCATE(kpp1_env%drho_r, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%deriv_set)) THEN - CALL xc_dset_release(kpp1_env%deriv_set, error=error) + CALL xc_dset_release(kpp1_env%deriv_set) NULLIFY(kpp1_env%deriv_set) END IF IF (ASSOCIATED(kpp1_env%spin_pot)) THEN DEALLOCATE(kpp1_env%spin_pot, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%grad_pot)) THEN DEALLOCATE(kpp1_env%grad_pot, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%ndiag_term)) THEN DEALLOCATE(kpp1_env%ndiag_term, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF - CALL xc_rho_set_release(kpp1_env%rho_set,error=error) ! it would be better to pass a pw pool + CALL xc_rho_set_release(kpp1_env%rho_set) ! it would be better to pass a pw pool END IF IF (PRESENT(grid_changed)) THEN IF (grid_changed) THEN IF (ASSOCIATED(kpp1_env%v_rspace)) THEN DO i=1,SIZE(kpp1_env%v_rspace) - CALL pw_release(kpp1_env%v_rspace(i)%pw,error=error) + CALL pw_release(kpp1_env%v_rspace(i)%pw) END DO DEALLOCATE(kpp1_env%v_rspace,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END IF @@ -824,14 +798,12 @@ END SUBROUTINE kpp1_did_change !> \param rho1 ... !> \param rho1_tot_gspace ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE print_densities(rho1, rho1_tot_gspace, output_unit, error) + SUBROUTINE print_densities(rho1, rho1_tot_gspace, output_unit) TYPE(qs_rho_type), POINTER :: rho1 TYPE(pw_p_type), INTENT(IN) :: rho1_tot_gspace INTEGER :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_densities', & routineP = moduleN//':'//routineN @@ -841,9 +813,9 @@ SUBROUTINE print_densities(rho1, rho1_tot_gspace, output_unit, error) NULLIFY(tot_rho1_r) - total_rho_gspace = pw_integrate_function(rho1_tot_gspace%pw,isign=-1,error=error) + total_rho_gspace = pw_integrate_function(rho1_tot_gspace%pw,isign=-1) IF (output_unit>0) THEN - CALL qs_rho_get(rho1, tot_rho_r=tot_rho1_r, error=error) + CALL qs_rho_get(rho1, tot_rho_r=tot_rho1_r) WRITE (UNIT=output_unit,FMT="(T3,A,T60,F20.10)")& "KPP1 total charge density (r-space):",& accurate_sum(tot_rho1_r),& diff --git a/src/qs_kpp1_env_types.F b/src/qs_kpp1_env_types.F index 39d1f52be3..6bfaa067d1 100644 --- a/src/qs_kpp1_env_types.F +++ b/src/qs_kpp1_env_types.F @@ -91,15 +91,12 @@ MODULE qs_kpp1_env_types ! ***************************************************************************** !> \brief releases a kpp1_env (see doc/ReferenceCounting.html) !> \param kpp1_env the environement to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE kpp1_release(kpp1_env,error) + SUBROUTINE kpp1_release(kpp1_env) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_release', & routineP = moduleN//':'//routineN @@ -110,51 +107,51 @@ SUBROUTINE kpp1_release(kpp1_env,error) failure=.FALSE. IF (ASSOCIATED(kpp1_env)) THEN - CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,failure) kpp1_env%ref_count=kpp1_env%ref_count-1 IF (kpp1_env%ref_count<1) THEN IF (ASSOCIATED(kpp1_env%v_rspace)) THEN DO ispin=1,SIZE(kpp1_env%v_rspace) - CALL pw_release(kpp1_env%v_rspace(ispin)%pw,error=error) + CALL pw_release(kpp1_env%v_rspace(ispin)%pw) END DO DEALLOCATE(kpp1_env%v_rspace,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%v_ao)) THEN DO ispin=1,SIZE(kpp1_env%v_ao) IF (ASSOCIATED(kpp1_env%v_ao(ispin)%matrix)) THEN - CALL cp_dbcsr_deallocate_matrix(kpp1_env%v_ao(ispin)%matrix,error=error) + CALL cp_dbcsr_deallocate_matrix(kpp1_env%v_ao(ispin)%matrix) END IF END DO DEALLOCATE(kpp1_env%v_ao, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%drho_r)) THEN DEALLOCATE(kpp1_env%drho_r, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%deriv_set)) THEN - CALL xc_dset_release(kpp1_env%deriv_set, error=error) + CALL xc_dset_release(kpp1_env%deriv_set) NULLIFY(kpp1_env%deriv_set) END IF IF (ASSOCIATED(kpp1_env%rho_set)) THEN - CALL xc_rho_set_release(kpp1_env%rho_set, error=error) + CALL xc_rho_set_release(kpp1_env%rho_set) NULLIFY(kpp1_env%rho_set) END IF IF (ASSOCIATED(kpp1_env%spin_pot)) THEN DEALLOCATE(kpp1_env%spin_pot, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%grad_pot)) THEN DEALLOCATE(kpp1_env%grad_pot, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(kpp1_env%ndiag_term)) THEN DEALLOCATE(kpp1_env%ndiag_term, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(kpp1_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(kpp1_env) @@ -163,15 +160,12 @@ END SUBROUTINE kpp1_release ! ***************************************************************************** !> \brief retains a kpp1_env (see doc/ReferenceCounting.html) !> \param kpp1_env the environement to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE kpp1_retain(kpp1_env,error) + SUBROUTINE kpp1_retain(kpp1_env) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_retain', & routineP = moduleN//':'//routineN @@ -180,8 +174,8 @@ SUBROUTINE kpp1_retain(kpp1_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,error,failure) - CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,failure) + CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,failure) kpp1_env%ref_count=kpp1_env%ref_count+1 END SUBROUTINE kpp1_retain @@ -194,19 +188,15 @@ END SUBROUTINE kpp1_retain !> (defaults to false) !> \param local if the unit is a local unit or a global unit !> (defaults to false, i.e. global) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& - error) + SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env TYPE(particle_list_type), POINTER :: particles INTEGER, INTENT(in) :: unit_nr LOGICAL, INTENT(in), OPTIONAL :: long_description, local - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_write', & routineP = moduleN//':'//routineN @@ -223,7 +213,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& IF (PRESENT(local)) my_local=local IF (PRESENT(long_description)) my_long_description=long_description - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() para_env=>logger%para_env should_w=my_local .OR. para_env%mepos==para_env%source my_unit_nr=unit_nr @@ -262,7 +252,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& CALL cp_pw_to_cube ( kpp1_env%v_rspace(ispin)%pw,& unit_nr=file_unit,& particles=particles,& - title="v_rspace",error=error) + title="v_rspace") CALL close_file(file_unit) END DO WRITE (unit=my_unit_nr,fmt="(a,a,a)") " v_rspace=*written to ",& @@ -283,7 +273,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& !FM fromWhere=routineP,iter=kpp1_env%print_count,& !FM matrix=kpp1_env%v_ao(ispin)%matrix,& !FM para_env=logger%para_env,& -!FM error=error) +!FM !FM END DO !FM WRITE (unit=my_unit_nr,fmt="(a,a,a)") " v_ao=*written to ",& !FM filename,"*" @@ -311,7 +301,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& CALL cp_pw_to_cube ( kpp1_env%v_rspace(ispin)%pw,& unit_nr=file_unit,& particles=particles,& - title="drho_r",error=error) + title="drho_r") CALL close_file(file_unit) END DO END DO @@ -330,7 +320,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& !FM outputName=base_filename//"%deriv_set%data", & !FM fromWhere=routineP, iter=kpp1_env%print_count,& !FM array=kpp1_env%deriv_set%data,& -!FM local=my_local, error=error) +!FM local=my_local) !FM ELSE WRITE (unit=my_unit_nr,fmt="(a)") " deriv_xc=*associated*," !FM END IF @@ -342,7 +332,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& IF (my_long_description) THEN WRITE (unit=my_unit_nr,fmt="(a)") " spin_pot=(" CALL cp_2d_i_write(array=kpp1_env%spin_pot,& - unit_nr=my_unit_nr, error=error) + unit_nr=my_unit_nr) WRITE (unit=my_unit_nr,fmt="(a)") " )," ELSE WRITE (unit=my_unit_nr,fmt="(a)") " spin_pot=*associated*," @@ -355,7 +345,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& IF (my_long_description) THEN WRITE (unit=my_unit_nr,fmt="(a)") " grad_pot=(" CALL cp_2d_logical_write(array=kpp1_env%grad_pot,& - unit_nr=my_unit_nr, error=error) + unit_nr=my_unit_nr) WRITE (unit=my_unit_nr,fmt="(a)") " )," ELSE WRITE (unit=my_unit_nr,fmt="(a)") " grad_pot=*associated*," @@ -369,7 +359,7 @@ SUBROUTINE kpp1_write(kpp1_env, particles, unit_nr, long_description, local,& IF (my_long_description) THEN WRITE (unit=my_unit_nr,fmt="(a)") " ndiag_term=(" CALL cp_1d_logical_write(array=kpp1_env%ndiag_term,& - unit_nr=my_unit_nr, error=error) + unit_nr=my_unit_nr) WRITE (unit=my_unit_nr,fmt="(a)") " )," ELSE WRITE (unit=my_unit_nr,fmt="(a)") " ndiag_term=*associated*" diff --git a/src/qs_ks_apply_restraints.F b/src/qs_ks_apply_restraints.F index bed9671e8d..1051bedd53 100644 --- a/src/qs_ks_apply_restraints.F +++ b/src/qs_ks_apply_restraints.F @@ -56,16 +56,14 @@ MODULE qs_ks_apply_restraints !> \param calculate_forces ... !> \param matrix_s ... !> \param becke ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ks_becke_restraint(qs_env,auxbas_pw_pool,calculate_forces,matrix_s,becke,error) + SUBROUTINE qs_ks_becke_restraint(qs_env,auxbas_pw_pool,calculate_forces,matrix_s,becke) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_pool_type), POINTER :: auxbas_pw_pool LOGICAL, INTENT(in) :: calculate_forces TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: matrix_s TYPE(becke_restraint_type), POINTER :: becke - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_becke_restraint', & routineP = moduleN//':'//routineN @@ -77,26 +75,26 @@ SUBROUTINE qs_ks_becke_restraint(qs_env,auxbas_pw_pool,calculate_forces,matrix_s failure = .FALSE. NULLIFY(dft_control) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) IF(dft_control%qs_control%becke_restraint)THEN ! Test no k-points - CPPrecondition(SIZE(matrix_s,2)==1,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(matrix_s,2)==1,cp_failure_level,routineP,failure) !***** Check if becke potential is needed to constrain charges ***** becke => dft_control%qs_control%becke_control IF(becke%need_pot.OR.calculate_forces)THEN CALL pw_pool_create_pw(auxbas_pw_pool,becke%becke_pot%pw,use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL becke_restraint(qs_env,becke_const=becke%becke_pot,calc_pot=.TRUE.,& - calculate_forces=calculate_forces,error=error) - CALL pw_scale(becke%becke_pot%pw,becke%becke_pot%pw%pw_grid%dvol,error=error) + calculate_forces=calculate_forces) + CALL pw_scale(becke%becke_pot%pw,becke%becke_pot%pw%pw_grid%dvol) becke%need_pot=.FALSE. ELSE inv_vol=1.0_dp/becke%becke_pot%pw%pw_grid%dvol - CALL pw_scale(becke%becke_pot%pw,inv_vol,error=error) + CALL pw_scale(becke%becke_pot%pw,inv_vol) CALL becke_restraint(qs_env,becke%becke_pot,calc_pot=.FALSE.,& - calculate_forces=calculate_forces,error=error) - CALL pw_scale(becke%becke_pot%pw,becke%becke_pot%pw%pw_grid%dvol,error=error) + calculate_forces=calculate_forces) + CALL pw_scale(becke%becke_pot%pw,becke%becke_pot%pw%pw_grid%dvol) ENDIF IF(dft_control%qs_control%et_coupling_calc)THEN @@ -104,26 +102,26 @@ SUBROUTINE qs_ks_becke_restraint(qs_env,auxbas_pw_pool,calculate_forces,matrix_s IF(qs_env%et_coupling%first_run)THEN NULLIFY(qs_env%et_coupling%rest_mat(1)%matrix) ALLOCATE(qs_env%et_coupling%rest_mat(1)%matrix) - CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(1)%matrix, error=error) + CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(1)%matrix) CALL cp_dbcsr_copy(qs_env%et_coupling%rest_mat(1)%matrix, matrix_s(1,1)%matrix, & - name="ET_RESTRAINT_MATRIX_A", error=error) - CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(1)%matrix,0.0_dp,error=error) + name="ET_RESTRAINT_MATRIX_A") + CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(1)%matrix,0.0_dp) CALL integrate_v_rspace(becke%becke_pot,& hmat=qs_env%et_coupling%rest_mat(1),& - qs_env=qs_env,calculate_forces=.FALSE.,error=error) + qs_env=qs_env,calculate_forces=.FALSE.) qs_env%et_coupling%order_p=dft_control%qs_control%becke_control%becke_order_p qs_env%et_coupling%e1=dft_control%qs_control%becke_control%strength qs_env%et_coupling%keep_matrix=.FALSE. ELSE NULLIFY(qs_env%et_coupling%rest_mat(2)%matrix) ALLOCATE(qs_env%et_coupling%rest_mat(2)%matrix) - CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(2)%matrix, error=error) + CALL cp_dbcsr_init(qs_env%et_coupling%rest_mat(2)%matrix) CALL cp_dbcsr_copy(qs_env%et_coupling%rest_mat(2)%matrix, matrix_s(1,1)%matrix, & - name="ET_RESTRAINT_MATRIX_B", error=error) - CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(2)%matrix,0.0_dp,error=error) + name="ET_RESTRAINT_MATRIX_B") + CALL cp_dbcsr_set(qs_env%et_coupling%rest_mat(2)%matrix,0.0_dp) CALL integrate_v_rspace(becke%becke_pot,& hmat=qs_env%et_coupling%rest_mat(2),& - qs_env=qs_env,calculate_forces=.FALSE.,error=error) + qs_env=qs_env,calculate_forces=.FALSE.) END IF END IF @@ -142,10 +140,9 @@ END SUBROUTINE qs_ks_becke_restraint !> \param matrix_s ... !> \param rho ... !> \param mulliken_order_p ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_ks_mulliken_restraint(energy,dft_control,just_energy,para_env,& - ks_matrix,matrix_s,rho,mulliken_order_p,error) + ks_matrix,matrix_s,rho,mulliken_order_p) TYPE(qs_energy_type), POINTER :: energy TYPE(dft_control_type), POINTER :: dft_control @@ -155,7 +152,6 @@ SUBROUTINE qs_ks_mulliken_restraint(energy,dft_control,just_energy,para_env,& POINTER :: ks_matrix, matrix_s TYPE(qs_rho_type), POINTER :: rho REAL(KIND=dp) :: mulliken_order_p - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_mulliken_restraint', & routineP = moduleN//':'//routineN @@ -171,19 +167,19 @@ SUBROUTINE qs_ks_mulliken_restraint(energy,dft_control,just_energy,para_env,& IF (dft_control%qs_control%mulliken_restraint) THEN ! Test no k-points - CPPrecondition(SIZE(matrix_s,2)==1,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(matrix_s,2)==1,cp_failure_level,routineP,failure) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) IF (just_energy) THEN CALL mulliken_restraint(dft_control%qs_control%mulliken_restraint_control, & para_env,matrix_s(1,1)%matrix,rho_ao,energy=energy%mulliken, & - order_p=mulliken_order_p,error=error) + order_p=mulliken_order_p) ELSE ksmat => ks_matrix(:,1) CALL mulliken_restraint(dft_control%qs_control%mulliken_restraint_control,& para_env,matrix_s(1,1)%matrix,rho_ao,energy=energy%mulliken, & - ks_matrix=ksmat,order_p=mulliken_order_p,error=error) + ks_matrix=ksmat,order_p=mulliken_order_p) ENDIF ENDIF @@ -198,10 +194,9 @@ END SUBROUTINE qs_ks_mulliken_restraint !> \param energy ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_ks_s2_restraint(dft_control,qs_env,matrix_s,& - energy,calculate_forces, just_energy,error) + energy,calculate_forces, just_energy) TYPE(dft_control_type), POINTER :: dft_control TYPE(qs_environment_type), POINTER :: qs_env @@ -209,7 +204,6 @@ SUBROUTINE qs_ks_s2_restraint(dft_control,qs_env,matrix_s,& POINTER :: matrix_s TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_s2_restraint', & routineP = moduleN//':'//routineN @@ -228,27 +222,27 @@ SUBROUTINE qs_ks_s2_restraint(dft_control,qs_env,matrix_s,& IF (dft_control%qs_control%s2_restraint) THEN ! Test no k-points - CPPrecondition(SIZE(matrix_s,2)==1,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(matrix_s,2)==1,cp_failure_level,routineP,failure) ! adds s2_restraint energy and orbital derivatives - CPPrecondition(dft_control%nspins == 2,cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%requires_mo_derivs,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%nspins == 2,cp_failure_level,routineP,failure) + CPPrecondition(qs_env%requires_mo_derivs,cp_failure_level,routineP,failure) ! forces are not implemented (not difficult, but ... ) - CPPrecondition(.NOT. calculate_forces, cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array,error=error) + CPPrecondition(.NOT. calculate_forces, cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array) ALLOCATE(fm_mo_derivs(SIZE(mo_derivs,1)))!fm->dbcsr DO i=1,SIZE(mo_derivs,1)!fm->dbcsr CALL get_mo_set(mo_set=mo_array(i)%mo_set,mo_coeff=mo_coeff)!fm->dbcsr - CALL cp_fm_create(fm_mo_derivs(i)%matrix,mo_coeff%matrix_struct,error=error)!fm->dbcsr - CALL copy_dbcsr_to_fm(mo_derivs(i)%matrix,fm_mo_derivs(i)%matrix,error=error)!fm->dbcsr + CALL cp_fm_create(fm_mo_derivs(i)%matrix,mo_coeff%matrix_struct)!fm->dbcsr + CALL copy_dbcsr_to_fm(mo_derivs(i)%matrix,fm_mo_derivs(i)%matrix)!fm->dbcsr ENDDO!fm->dbcsr smat => matrix_s(:,1) CALL s2_restraint(mo_array, smat, fm_mo_derivs, energy%s2_restraint, & - dft_control%qs_control%s2_restraint_control, just_energy, error) + dft_control%qs_control%s2_restraint_control, just_energy) DO i=1,SIZE(mo_derivs,1)!fm->dbcsr - CALL copy_fm_to_dbcsr(fm_mo_derivs(i)%matrix,mo_derivs(i)%matrix,error=error)!fm->dbcsr + CALL copy_fm_to_dbcsr(fm_mo_derivs(i)%matrix,mo_derivs(i)%matrix)!fm->dbcsr ENDDO!fm->dbcsr DEALLOCATE(fm_mo_derivs)!fm->dbcsr diff --git a/src/qs_ks_atom.F b/src/qs_ks_atom.F index 937a07a952..8d023a3b0f 100644 --- a/src/qs_ks_atom.F +++ b/src/qs_ks_atom.F @@ -76,13 +76,12 @@ MODULE qs_ks_atom !> \param forces switch for the calculation of the forces on atoms !> \param tddft switch for TDDFT linear response !> \param p_env perturbation theory environment -!> \param error cp_error_type !> \par History !> created [MI] !> the loop over the spins is done internally [03-05,MI] !> Rewrite using new OCE matrices [08.02.09, jhu] ! ***************************************************************************** - SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) + SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -90,7 +89,6 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) LOGICAL, INTENT(IN) :: forces LOGICAL, INTENT(IN), OPTIONAL :: tddft TYPE(qs_p_env_type), OPTIONAL, POINTER :: p_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_ks_atom', & routineP = moduleN//':'//routineN @@ -160,8 +158,7 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) rho_atom_set=rho_atom,& virial=virial,& sab_orb=sab_orb,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) nspins = dft_control%nspins nimages = dft_control%nimages @@ -171,14 +168,14 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) factor = 1.0_dp IF (my_tddft) THEN IF (nspins == 1) factor = 2.0_dp - CPPostcondition(nimages==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nimages==1,cp_failure_level,routineP,failure) END IF ! kpoint images NULLIFY(cell_to_index) IF (nimages>1) THEN - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF IF (my_tddft) THEN @@ -188,32 +185,32 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) eps_cpc = dft_control%qs_control%gapw_control%eps_cpc CALL get_atomic_kind_set(atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set,maxsgf=max_nsgf,maxgtops=max_gau,error=error) + CALL get_qs_kind_set(qs_kind_set,maxsgf=max_nsgf,maxgtops=max_gau) ALLOCATE (C_int_h(max_gau*max_nsgf),C_int_s(max_gau*max_nsgf),coc(max_gau*max_gau),& a_matrix(max_gau,max_gau),p_matrix(max_nsgf,max_nsgf),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) lC_int = max_gau ALLOCATE(mat_h(nspins),mat_p(nspins), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins NULLIFY(mat_h(ispin)%array,mat_p(ispin)%array) END DO IF(forces) THEN ALLOCATE (atom_of_kind(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, atom_of_kind=atom_of_kind) ALLOCATE(dCPC_h(max_gau,max_gau),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dCPC_s(max_gau,max_gau),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ldCPC = max_gau ALLOCATE(PC_h(max_nsgf,max_gau,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(PC_s(max_nsgf,max_gau,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) lPC = max_nsgf use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) END IF @@ -225,7 +222,7 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) DO ikind = 1,nkind NULLIFY(atom_list) CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=atom_list, natom=nat) - CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom, error=error) + CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom) IF(paw_atom) THEN ! gather the atomic block integrals in a more compressed format bo = get_limit( nat, num_pe, mepos ) @@ -233,9 +230,9 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) iatom = atom_list(iat) DO ispin = 1,nspins CALL prj_gather(rho_atom(iatom)%ga_Vlocal_gb_h(ispin)%r_coef,& - rho_atom(iatom)%cpc_h(ispin)%r_coef,qs_kind_set(ikind),error) + rho_atom(iatom)%cpc_h(ispin)%r_coef,qs_kind_set(ikind)) CALL prj_gather(rho_atom(iatom)%ga_Vlocal_gb_s(ispin)%r_coef,& - rho_atom(iatom)%cpc_s(ispin)%r_coef,qs_kind_set(ikind),error) + rho_atom(iatom)%cpc_s(ispin)%r_coef,qs_kind_set(ikind)) END DO END DO ! broadcast the CPC arrays to all processors (replicated data) @@ -253,9 +250,9 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) END DO ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -274,7 +271,7 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) IF(nimages>1) THEN img = cell_to_index(cell_b(1),cell_b(2),cell_b(3)) - CPPostcondition(img > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(img > 0,cp_failure_level,routineP,failure) ELSE img = 1 END IF @@ -301,7 +298,7 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) END DO DO kkind=1,nkind - CALL get_qs_kind(qs_kind_set(kkind), basis_set=orb_basis, paw_atom=paw_atom, error=error) + CALL get_qs_kind(qs_kind_set(kkind), basis_set=orb_basis, paw_atom=paw_atom) IF(.NOT. paw_atom) CYCLE @@ -312,8 +309,8 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) IF (.NOT.ASSOCIATED(oce%intac(iac)%alist)) CYCLE IF (.NOT.ASSOCIATED(oce%intac(ibc)%alist)) CYCLE - CALL get_alist(oce%intac(iac), alist_ac, iatom, error) - CALL get_alist(oce%intac(ibc), alist_bc, jatom, error) + CALL get_alist(oce%intac(iac), alist_ac, iatom) + CALL get_alist(oce%intac(ibc), alist_bc, jatom) IF (.NOT.ASSOCIATED(alist_ac)) CYCLE IF (.NOT.ASSOCIATED(alist_bc)) CYCLE @@ -354,7 +351,7 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) CALL add_vhxca_to_ks(mat_h,C_coeff_hh_a,C_coeff_hh_b,C_coeff_ss_a,C_coeff_ss_b,& rho_at,nspins,iatom,jatom,nsoctot,factor,& - list_a,n_cont_a,list_b,n_cont_b,C_int_h,C_int_s,a_matrix,dista,distb,coc,error) + list_a,n_cont_a,list_b,n_cont_b,C_int_h,C_int_s,a_matrix,dista,distb,coc) IF(forces)THEN ia_kind = atom_of_kind(iatom) @@ -365,7 +362,7 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) IF(iatom <= jatom) THEN CALL add_vhxca_forces(mat_p,C_coeff_hh_a,C_coeff_hh_b,C_coeff_ss_a,C_coeff_ss_b,& rho_at,force_tmp,nspins,iatom,jatom,nsoctot,& - list_a,n_cont_a,list_b,n_cont_b,dCPC_h,dCPC_s,ldCPC,PC_h,PC_s,p_matrix,error) + list_a,n_cont_a,list_b,n_cont_b,dCPC_h,dCPC_s,ldCPC,PC_h,PC_s,p_matrix) force(kkind)%vhxc_atom(1:3,ka_kind) = & force(kkind)%vhxc_atom(1:3,ka_kind) + & @@ -379,13 +376,13 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) IF (use_virial) THEN rac = alist_ac%clist(kac)%rac rbc = alist_bc%clist(kbc)%rac - CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,1),rac,error) - CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,2),rbc,error) + CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,1),rac) + CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,2),rbc) END IF ELSE CALL add_vhxca_forces(mat_p,C_coeff_hh_b,C_coeff_hh_a,C_coeff_ss_b,C_coeff_ss_a,& rho_at,force_tmp,nspins,jatom,iatom,nsoctot,& - list_b,n_cont_b,list_a,n_cont_a,dCPC_h,dCPC_s,ldCPC,PC_h,PC_s,p_matrix,error) + list_b,n_cont_b,list_a,n_cont_a,dCPC_h,dCPC_s,ldCPC,PC_h,PC_s,p_matrix) force(kkind)%vhxc_atom(1:3,ka_kind) = & force(kkind)%vhxc_atom(1:3,ka_kind) + & @@ -399,8 +396,8 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) IF (use_virial) THEN rac = alist_ac%clist(kac)%rac rbc = alist_bc%clist(kbc)%rac - CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,2),rac,error) - CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,1),rbc,error) + CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,2),rac) + CALL virial_pair_force(virial%pv_virial,1._dp,force_tmp(1:3,1),rbc) END IF END IF END IF @@ -418,15 +415,15 @@ SUBROUTINE update_ks_atom(qs_env,ksmat,pmat,forces,tddft,p_env,error) END DO DEALLOCATE(basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mat_h,mat_p,C_int_h,C_int_s,a_matrix,p_matrix,coc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(forces) THEN DEALLOCATE (atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(DCPC_h,dCPC_s,PC_h,PC_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -456,11 +453,10 @@ END SUBROUTINE update_ks_atom !> \param dista ... !> \param distb ... !> \param coc ... -!> \param error ... ! ***************************************************************************** SUBROUTINE add_vhxca_to_ks(mat_h,C_hh_a,C_hh_b,C_ss_a,C_ss_b,& rho_atom,nspins,ia,ja,nsp,factor,lista,nconta,listb,ncontb,& - C_int_h,C_int_s,a_matrix,dista,distb,coc,error) + C_int_h,C_int_s,a_matrix,dista,distb,coc) TYPE(cp_2d_r_p_type), DIMENSION(:), & POINTER :: mat_h @@ -476,7 +472,6 @@ SUBROUTINE add_vhxca_to_ks(mat_h,C_hh_a,C_hh_b,C_ss_a,C_ss_b,& REAL(dp), DIMENSION(:, :) :: a_matrix LOGICAL, INTENT(IN) :: dista, distb REAL(dp), DIMENSION(:) :: coc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_vhxca_to_ks', & routineP = moduleN//':'//routineN @@ -610,11 +605,10 @@ END SUBROUTINE add_vhxca_to_ks !> \param PC_h ... !> \param PC_s ... !> \param p_matrix ... -!> \param error ... ! ***************************************************************************** SUBROUTINE add_vhxca_forces(mat_p,C_hh_a,C_hh_b,C_ss_a,C_ss_b,& rho_atom,force,nspins,ia,ja,nsp,lista,nconta,listb,ncontb,& - dCPC_h,dCPC_s,ldCPC,PC_h,PC_s,p_matrix,error) + dCPC_h,dCPC_s,ldCPC,PC_h,PC_s,p_matrix) TYPE(cp_2d_r_p_type), DIMENSION(:), & POINTER :: mat_p @@ -630,7 +624,6 @@ SUBROUTINE add_vhxca_forces(mat_p,C_hh_a,C_hh_b,C_ss_a,C_ss_b,& INTEGER, INTENT(IN) :: ldCPC REAL(KIND=dp), DIMENSION(:, :, :) :: PC_h, PC_s REAL(KIND=dp), DIMENSION(:, :) :: p_matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'add_vhxca_forces', & routineP = moduleN//':'//routineN diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index b23ec4811a..e9d7aee1b4 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -189,8 +189,6 @@ MODULE qs_ks_methods !> ks matrix. Defaults to false !> \param print_active ... !> \param ext_ks_matrix ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2002 moved from qs_scf to qs_ks_methods, use of ks_env !> new did_change scheme [fawzi] @@ -206,13 +204,12 @@ MODULE qs_ks_methods !> to qs_env components? ! ***************************************************************************** SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& - print_active,ext_ks_matrix, error) + print_active,ext_ks_matrix) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in) :: calculate_forces, just_energy LOGICAL, INTENT(IN), OPTIONAL :: print_active TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: ext_ks_matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_build_kohn_sham_matrix', & routineP = moduleN//':'//routineN @@ -269,9 +266,9 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& matrix_vxc, vee, rho_nlcc, ks_env, & ks_matrix, rho, energy, rho_xc, rho_r, rho_ao, rho_core) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_print = .TRUE. IF(PRESENT(print_active)) my_print = print_active @@ -293,10 +290,9 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& rho=rho,& rho_core=rho_core,& rho_xc=rho_xc,& - energy=energy,& - error=error) + energy=energy) - CALL qs_rho_get(rho, rho_r=rho_r, rho_ao_kp=rho_ao, error=error) + CALL qs_rho_get(rho, rho_r=rho_r, rho_ao_kp=rho_ao) IF(PRESENT(ext_ks_matrix)) THEN ! remap pointer to allow for non-kpoint external ks matrix @@ -307,14 +303,14 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,error=error) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx) IF( do_hfx ) THEN CALL section_vals_val_get(hfx_sections, "TREAT_LSD_IN_CORE", l_val=hfx_treat_lsd_in_core,& - i_rep_section=1,error=error) + i_rep_section=1) END IF - adiabatic_rescaling_section => section_vals_get_subs_vals(input,"DFT%XC%ADIABATIC_RESCALING",error=error) - CALL section_vals_get(adiabatic_rescaling_section,explicit=do_adiabatic_rescaling,error=error) + adiabatic_rescaling_section => section_vals_get_subs_vals(input,"DFT%XC%ADIABATIC_RESCALING") + CALL section_vals_get(adiabatic_rescaling_section,explicit=do_adiabatic_rescaling) just_energy_xc=just_energy IF(do_adiabatic_rescaling) THEN !! If we perform adiabatic rescaling, the xc potential has to be scaled by the xc- and @@ -324,11 +320,11 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& nimages = dft_control%nimages nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(matrix_h),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix,1)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_h),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix,1)>0,cp_failure_level,routineP,failure) ! Setup the possible usage of DDAPC charges do_ddapc = dft_control%qs_control%ddapc_restraint.OR.& @@ -340,30 +336,30 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& gapw = dft_control%qs_control%gapw gapw_xc = dft_control%qs_control%gapw_xc IF(gapw_xc .AND. gapw) CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& - " GAPW and GAPW_XC are not compatible",error,failure) + " GAPW and GAPW_XC are not compatible",failure) do_ppl = dft_control%qs_control%do_ppl_method == do_ppl_grid IF ( do_ppl ) THEN - CPPrecondition(.NOT.gapw,cp_failure_level,routineP,error,failure) - CALL get_qs_env ( qs_env=qs_env, vppl=vppl_rspace, error=error ) + CPPrecondition(.NOT.gapw,cp_failure_level,routineP,failure) + CALL get_qs_env ( qs_env=qs_env, vppl=vppl_rspace) END IF IF(gapw_xc) THEN - CPPrecondition(ASSOCIATED(rho_xc),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_xc),cp_failure_level,routineP,failure) END IF ! gets the tmp grids CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools, poisson_env=poisson_env,error=error) + pw_pools=pw_pools, poisson_env=poisson_env) IF (gapw .AND. (poisson_env%parameters%solver .EQ. pw_poisson_implicit)) THEN CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP,& - "The implicit Poisson solver cannot be used in conjunction with GAPW.", error, failure) + "The implicit Poisson solver cannot be used in conjunction with GAPW.",failure) END IF ! *** Prepare densities for gapw *** IF(gapw .OR. gapw_xc) THEN - CALL prepare_gapw_den(qs_env,do_rho0=(.NOT.gapw_xc),error=error) + CALL prepare_gapw_den(qs_env,do_rho0=(.NOT.gapw_xc)) ENDIF IF (.NOT. failure) THEN @@ -372,32 +368,30 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& CALL pw_pool_create_pw(auxbas_pw_pool,& v_hartree_gspace%pw, & use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& rho_tot_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) - scf_section => section_vals_get_subs_vals(input,"DFT%SCF",error=error) + scf_section => section_vals_get_subs_vals(input,"DFT%SCF") IF (BTEST(cp_print_key_should_output(logger%iter_info,scf_section,& - "PRINT%DETAILED_ENERGY",error=error),& + "PRINT%DETAILED_ENERGY"),& cp_p_file).AND.& (.NOT.gapw).AND.(.NOT.gapw_xc)) THEN - CALL pw_zero(rho_tot_gspace%pw, error=error) - CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, skip_nuclear_density=.TRUE.,error=error) + CALL pw_zero(rho_tot_gspace%pw) + CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, skip_nuclear_density=.TRUE.) CALL pw_poisson_solve(poisson_env,rho_tot_gspace%pw,energy%e_hartree,& - v_hartree_gspace%pw,error=error) - CALL pw_zero(rho_tot_gspace%pw, error=error) - CALL pw_zero(v_hartree_gspace%pw, error=error) + v_hartree_gspace%pw) + CALL pw_zero(rho_tot_gspace%pw) + CALL pw_zero(v_hartree_gspace%pw) END IF ! Get the total density in g-space [ions + electrons] - CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, error=error) + CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho) IF (my_print) THEN - CALL print_densities(qs_env, rho, error=error) + CALL print_densities(qs_env, rho) END IF IF (dft_control%do_sccs) THEN @@ -405,22 +399,20 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& CALL pw_pool_create_pw(auxbas_pw_pool,& v_sccs_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) IF (poisson_env%parameters%solver .EQ. pw_poisson_implicit) THEN CALL cp_assert(.FALSE., cp_failure_level, cp_assertion_failed, routineP,& "The implicit Poisson solver cannot be used together with SCCS.",& - error, failure) + failure) END IF IF (use_virial.AND.calculate_forces) THEN CALL sccs(qs_env,rho_tot_gspace%pw,v_hartree_gspace%pw,v_sccs_rspace%pw,& - h_stress=h_stress,error=error) + h_stress=h_stress) virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe,dp) ELSE - CALL sccs(qs_env,rho_tot_gspace%pw,v_hartree_gspace%pw,v_sccs_rspace%pw,& - error=error) + CALL sccs(qs_env,rho_tot_gspace%pw,v_hartree_gspace%pw,v_sccs_rspace%pw) END IF ELSE ! Getting the Hartree energy and Hartree potential. Also getting the stress tensor @@ -429,11 +421,11 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& h_stress(:,:) = 0.0_dp CALL pw_poisson_solve(poisson_env,rho_tot_gspace%pw,energy%hartree,& v_hartree_gspace%pw,h_stress=h_stress, & - rho_core=rho_core, error=error) + rho_core=rho_core) virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe,dp) ELSE CALL pw_poisson_solve(poisson_env, rho_tot_gspace%pw,energy%hartree, & - v_hartree_gspace%pw, rho_core=rho_core, error=error) + v_hartree_gspace%pw, rho_core=rho_core) END IF END IF @@ -441,56 +433,53 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& IF (do_ddapc) THEN CALL qs_ks_ddapc(qs_env, auxbas_pw_pool, rho_tot_gspace, v_hartree_gspace,& v_spin_ddapc_rest_r, energy, calculate_forces, ks_matrix, & - just_energy, error) + just_energy) ELSE dft_control%qs_control%ddapc_explicit_potential = .FALSE. dft_control%qs_control%ddapc_restraint_is_spin = .FALSE. IF (.NOT.just_energy) THEN - CALL pw_transfer(v_hartree_gspace%pw, v_hartree_rspace%pw, error=error) - CALL pw_scale(v_hartree_rspace%pw, v_hartree_rspace%pw%pw_grid%dvol,& - error=error) + CALL pw_transfer(v_hartree_gspace%pw, v_hartree_rspace%pw) + CALL pw_scale(v_hartree_rspace%pw, v_hartree_rspace%pw%pw_grid%dvol) END IF END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw) IF (dft_control%apply_efield_field) THEN CALL pw_pool_create_pw(auxbas_pw_pool,& v_efield_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL efield_potential(qs_env,v_efield_rspace,error) - CALL pw_scale(v_efield_rspace%pw,v_efield_rspace%pw%pw_grid%dvol,error=error) + in_space=REALSPACE) + CALL efield_potential(qs_env,v_efield_rspace) + CALL pw_scale(v_efield_rspace%pw,v_efield_rspace%pw%pw_grid%dvol) END IF IF(dft_control%correct_surf_dip) THEN - CALL calc_dipsurf_potential(qs_env,energy,error=error) + CALL calc_dipsurf_potential(qs_env,energy) energy%hartree = energy%hartree + energy%surf_dipole END IF ! SIC CALL calc_v_sic_rspace(v_sic_rspace,energy,qs_env,dft_control,rho,poisson_env,& - just_energy,calculate_forces,auxbas_pw_pool,error=error) + just_energy,calculate_forces,auxbas_pw_pool) - IF (gapw) CALL Vh_1c_gg_integrals(qs_env,energy%hartree_1c,error=error) + IF (gapw) CALL Vh_1c_gg_integrals(qs_env,energy%hartree_1c) ! Check if becke potential is needed to constrain charges - CALL qs_ks_becke_restraint(qs_env,auxbas_pw_pool,calculate_forces,matrix_s,becke,error) + CALL qs_ks_becke_restraint(qs_env,auxbas_pw_pool,calculate_forces,matrix_s,becke) ! Adds the External Potential if requested IF(dft_control%apply_external_potential) THEN ! Compute the energy due to the external potential ee_ener=0.0_dp DO ispin=1,nspins - ee_ener = ee_ener + pw_integral_ab (rho_r(ispin)%pw, vee%pw, error=error) + ee_ener = ee_ener + pw_integral_ab (rho_r(ispin)%pw, vee%pw) END DO IF (.NOT.just_energy) THEN IF (gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho0_s_rs=rho0_s_rs,& - error=error) - CPPrecondition(ASSOCIATED(rho0_s_rs),cp_failure_level,routineP,error,failure) - ee_ener = ee_ener + pw_integral_ab (rho0_s_rs%pw, vee%pw, error=error) + rho0_s_rs=rho0_s_rs) + CPPrecondition(ASSOCIATED(rho0_s_rs),cp_failure_level,routineP,failure) + ee_ener = ee_ener + pw_integral_ab (rho0_s_rs%pw, vee%pw) END IF END IF ! the sign accounts for the charge of the electrons @@ -502,46 +491,44 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& CALL qmmm_calculate_energy (qs_env=qs_env,& rho=rho_r,& v_qmmm=qs_env%ks_qmmm_env%v_qmmm_rspace,& - qmmm_energy=energy%qmmm_el,& - error=error) + qmmm_energy=energy%qmmm_el) IF (qs_env%qmmm_env_qm%image_charge) THEN CALL calculate_image_pot(v_hartree_rspace=v_hartree_rspace,& rho_hartree_gspace=rho_tot_gspace,& energy=energy,& qmmm_env=qs_env%qmmm_env_qm,& - qs_env=qs_env,error=error) + qs_env=qs_env) IF (.NOT.just_energy) THEN CALL add_image_pot_to_hartree_pot(v_hartree=v_hartree_rspace,& v_metal=qs_env%ks_qmmm_env%v_metal_rspace,& - qs_env=qs_env,error=error) + qs_env=qs_env) IF(calculate_forces) THEN CALL integrate_potential_devga_rspace(& potential=v_hartree_rspace,coeff=qs_env%image_coeff,& forces=qs_env%qmmm_env_qm%image_charge_pot%image_forcesMM,& - qmmm_env=qs_env%qmmm_env_qm,qs_env=qs_env,error=error) + qmmm_env=qs_env%qmmm_env_qm,qs_env=qs_env) ENDIF ENDIF - CALL pw_release(qs_env%ks_qmmm_env%v_metal_rspace%pw,error=error) + CALL pw_release(qs_env%ks_qmmm_env%v_metal_rspace%pw) END IF IF (.NOT.just_energy) THEN CALL qmmm_modify_hartree_pot(v_hartree=v_hartree_rspace,& - v_qmmm=qs_env%ks_qmmm_env%v_qmmm_rspace,scale=1.0_dp,& - error=error) + v_qmmm=qs_env%ks_qmmm_env%v_qmmm_rspace,scale=1.0_dp) END IF END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw) ! calculate the density matrix for the fitted mo_coeffs IF(dft_control%do_admm) THEN - CALL hfx_admm_init(qs_env, error) + CALL hfx_admm_init(qs_env) IF(dft_control%do_admm_mo) THEN IF(qs_env%run_rtp)THEN - CALL rtp_admm_calc_rho_aux(qs_env, error) + CALL rtp_admm_calc_rho_aux(qs_env) ELSE - CALL admm_mo_calc_rho_aux(qs_env, error) + CALL admm_mo_calc_rho_aux(qs_env) END IF ELSEIF(dft_control%do_admm_dm) THEN - CALL admm_dm_calc_rho_aux(ks_env, error) + CALL admm_dm_calc_rho_aux(ks_env) ENDIF ENDIF @@ -552,18 +539,18 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& ! *** associates v_rspace_new if the xc potential needs to be computed. ! If we do wavefunction fitting, we need the vxc_potential in the auxiliary basis set IF( dft_control%do_admm ) THEN - CALL get_qs_env(qs_env, admm_env=admm_env,error=error) + CALL get_qs_env(qs_env, admm_env=admm_env) xc_section => admm_env%xc_section_aux IF (gapw_xc) THEN - CALL get_qs_env(qs_env=qs_env, rho_xc=rho_struct, error=error) + CALL get_qs_env(qs_env=qs_env, rho_xc=rho_struct) ELSE - CALL get_qs_env(qs_env=qs_env, rho_aux_fit=rho_struct, error=error) + CALL get_qs_env(qs_env=qs_env, rho_aux_fit=rho_struct) END IF ! here we ignore a possible vdW section in admm_env%xc_section_aux CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_struct, xc_section=xc_section, & vxc_rho=v_rspace_new_aux_fit, vxc_tau=v_tau_rspace_aux_fit, exc=energy%exc_aux_fit, & - just_energy=just_energy_xc, error=error) + just_energy=just_energy_xc) NULLIFY(rho_struct) @@ -573,31 +560,31 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& END IF xc_section => admm_env%xc_section_primary ELSE - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") END IF IF (gapw_xc) THEN - CALL get_qs_env(qs_env=qs_env, rho_xc=rho_struct, error=error) + CALL get_qs_env(qs_env=qs_env, rho_xc=rho_struct) ELSE - CALL get_qs_env(qs_env=qs_env, rho=rho_struct, error=error) + CALL get_qs_env(qs_env=qs_env, rho=rho_struct) END IF ! zmp IF (dft_control%apply_external_density .OR. dft_control%apply_external_vxc) THEN energy%exc = 0. - CALL calculate_zmp_potential(qs_env, v_rspace_new, rho, exc=energy%exc,error=error) + CALL calculate_zmp_potential(qs_env, v_rspace_new, rho, exc=energy%exc) ELSE CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_struct, xc_section=xc_section, & vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=energy%exc, & edisp=edisp, dispersion_env=qs_env%dispersion_env, & - just_energy=just_energy_xc, error=error) + just_energy=just_energy_xc) IF(edisp /= 0.0_dp) energy%dispersion = edisp IF (qs_env%requires_matrix_vxc) THEN - CALL compute_matrix_vxc(qs_env=qs_env,v_rspace=v_rspace_new, matrix_vxc=matrix_vxc, error=error) + CALL compute_matrix_vxc(qs_env=qs_env,v_rspace=v_rspace_new, matrix_vxc=matrix_vxc) ENDIF IF (gapw .OR. gapw_xc) THEN - CALL calculate_vxc_atom(qs_env,just_energy_xc,error) + CALL calculate_vxc_atom(qs_env,just_energy_xc) ENDIF ENDIF @@ -609,32 +596,32 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& ! *** Add Hartree-Fock contribution if required *** IF ( do_hfx ) THEN CALL hfx_ks_matrix(qs_env,ks_matrix,rho,energy,calculate_forces,& - just_energy,v_rspace_new,v_tau_rspace,error=error) + just_energy,v_rspace_new,v_tau_rspace) !! Adiabatic rescaling only if do_hfx; right????? END IF !do_hfx IF(do_ppl .AND. calculate_forces)THEN - CPPrecondition(.NOT.gapw,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.gapw,cp_failure_level,routineP,failure) DO ispin=1,nspins - CALL integrate_ppl_rspace(rho_r(ispin),qs_env,error=error) + CALL integrate_ppl_rspace(rho_r(ispin),qs_env) END DO END IF IF(ASSOCIATED(rho_nlcc) .AND. calculate_forces)THEN - CPPrecondition(.NOT.(gapw .OR. gapw_xc),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.(gapw .OR. gapw_xc),cp_failure_level,routineP,failure) DO ispin=1,nspins - CALL integrate_rho_nlcc(v_rspace_new(ispin),qs_env,error=error) - IF(dft_control%do_admm)CALL integrate_rho_nlcc(v_rspace_new_aux_fit(ispin),qs_env,error=error) + CALL integrate_rho_nlcc(v_rspace_new(ispin),qs_env) + IF(dft_control%do_admm)CALL integrate_rho_nlcc(v_rspace_new_aux_fit(ispin),qs_env) END DO ENDIF ! calculate KG correction IF (dft_control%qs_control%do_kg.AND.just_energy) THEN - CPPrecondition(nimages==1,cp_failure_level,routineP,error,failure) + CPPrecondition(nimages==1,cp_failure_level,routineP,failure) ksmat => ks_matrix(:,1) CALL kg_ekin_subset(qs_env, ksmat, gapw, gapw_xc, ekin_mol, & - calculate_forces, error) + calculate_forces) ! substract kg corr from the total energy energy%exc = energy%exc - ekin_mol @@ -647,13 +634,13 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& ! Getting nuclear force contribution from the core charge density IF ((poisson_env%parameters%solver .EQ. pw_poisson_implicit) .AND. & (poisson_env%parameters%dielectric_params%dielec_core_correction)) THEN - CALL pw_pool_create_pw(auxbas_pw_pool, v_minus_veps%pw, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_copy(v_hartree_rspace%pw, v_minus_veps%pw, error=error) - CALL pw_axpy(poisson_env%implicit_env%v_eps, v_minus_veps%pw, - v_hartree_rspace%pw%pw_grid%dvol, error=error) - CALL integrate_v_core_rspace(v_minus_veps, qs_env, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool, v_minus_veps%pw, error=error) + CALL pw_pool_create_pw(auxbas_pw_pool, v_minus_veps%pw, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy(v_hartree_rspace%pw, v_minus_veps%pw) + CALL pw_axpy(poisson_env%implicit_env%v_eps, v_minus_veps%pw, - v_hartree_rspace%pw%pw_grid%dvol) + CALL integrate_v_core_rspace(v_minus_veps, qs_env) + CALL pw_pool_give_back_pw(auxbas_pw_pool, v_minus_veps%pw) ELSE - CALL integrate_v_core_rspace(v_hartree_rspace,qs_env,error=error) + CALL integrate_v_core_rspace(v_hartree_rspace,qs_env) END IF END IF @@ -663,7 +650,7 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& DO ispin=1,nspins DO img=1,nimages CALL cp_dbcsr_copy(ks_matrix(ispin,img)%matrix,matrix_h(1,img)%matrix,& - name=cp_dbcsr_name(ks_matrix(ispin,img)%matrix),error=error) + name=cp_dbcsr_name(ks_matrix(ispin,img)%matrix)) END DO END DO END IF @@ -674,13 +661,13 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& CALL sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,vppl_rspace,& v_rspace_new,v_rspace_new_aux_fit,v_tau_rspace,v_tau_rspace_aux_fit,& v_efield_rspace,v_sic_rspace,v_spin_ddapc_rest_r,v_sccs_rspace,becke,& - calculate_forces,error=error) + calculate_forces) IF (dft_control%qs_control%do_kg) THEN - CPPrecondition(nimages==1,cp_failure_level,routineP,error,failure) + CPPrecondition(nimages==1,cp_failure_level,routineP,failure) ksmat => ks_matrix(:,1) CALL kg_ekin_subset(qs_env, ksmat, gapw, gapw_xc, ekin_mol, & - calculate_forces, error) + calculate_forces) ! substract kg corr from the total energy energy%exc = energy%exc - ekin_mol END IF @@ -688,48 +675,47 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& END IF ! .NOT. just energy IF (dft_control%qs_control%ddapc_explicit_potential) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_spin_ddapc_rest_r%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_spin_ddapc_rest_r%pw) END IF IF (dft_control%apply_efield_field) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_efield_rspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_efield_rspace%pw) END IF IF (calculate_forces.AND.dft_control%qs_control%becke_restraint) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,becke%becke_pot%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,becke%becke_pot%pw) END IF IF (dft_control%do_sccs) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_sccs_rspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_sccs_rspace%pw) END IF IF (gapw) THEN IF (dft_control%apply_external_potential) THEN ! Integrals of the Hartree potential with g0_soft CALL qmmm_modify_hartree_pot(v_hartree=v_hartree_rspace,& - v_qmmm=vee,scale=-1.0_dp,& - error=error) + v_qmmm=vee,scale=-1.0_dp) ENDIF - CALL integrate_vhg0_rspace(qs_env,v_hartree_rspace,calculate_forces,error=error) + CALL integrate_vhg0_rspace(qs_env,v_hartree_rspace,calculate_forces) END IF IF (gapw.OR.gapw_xc) THEN ! Single atom contributions in the KS matrix *** - CALL update_ks_atom(qs_env,ks_matrix,rho_ao,calculate_forces,error=error) + CALL update_ks_atom(qs_env,ks_matrix,rho_ao,calculate_forces) END IF !Calculation of Mulliken restraint, if requested CALL qs_ks_mulliken_restraint(energy,dft_control,just_energy,para_env,& - ks_matrix,matrix_s,rho,mulliken_order_p,error) + ks_matrix,matrix_s,rho,mulliken_order_p) ! Add DFT+U contribution, if requested IF (dft_control%dft_plus_u) THEN - CPPrecondition(nimages==1,cp_failure_level,routineP,error,failure) + CPPrecondition(nimages==1,cp_failure_level,routineP,failure) IF (just_energy) THEN - CALL plus_u(qs_env=qs_env,error=error) + CALL plus_u(qs_env=qs_env) ELSE ksmat => ks_matrix(:,1) - CALL plus_u(qs_env=qs_env,matrix_h=ksmat,error=error) + CALL plus_u(qs_env=qs_env,matrix_h=ksmat) END IF ELSE energy%dft_plus_u = 0.0_dp @@ -739,49 +725,49 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& DO ispin=1,nspins DO img=1,nimages CALL cp_dbcsr_filter(ks_matrix(ispin,img)%matrix,& - dft_control%qs_control%eps_filter_matrix,error=error) + dft_control%qs_control%eps_filter_matrix) END DO ENDDO !** merge the auxiliary KS matrix and the primary one IF(dft_control%do_admm_mo) THEN IF(qs_env%run_rtp) THEN - CALL rtp_admm_merge_ks_matrix(qs_env, error) + CALL rtp_admm_merge_ks_matrix(qs_env) ELSE - CALL admm_mo_merge_ks_matrix(qs_env, error) + CALL admm_mo_merge_ks_matrix(qs_env) ENDIF ELSEIF(dft_control%do_admm_dm) THEN - CALL admm_dm_merge_ks_matrix(ks_env, error) + CALL admm_dm_merge_ks_matrix(ks_env) ENDIF ! External field (nonperiodic case) - CALL qs_efield_local_operator(qs_env,just_energy,calculate_forces,error) + CALL qs_efield_local_operator(qs_env,just_energy,calculate_forces) ! Right now we can compute the orbital derivative here, as it depends currently only on the available ! Kohn-Sham matrix. This might change in the future, in which case more pieces might need to be assembled ! from this routine, notice that this part of the calculation in not linear scaling ! right now this operation is only non-trivial because of occupation numbers and the restricted keyword IF (qs_env%requires_mo_derivs .AND. .NOT. just_energy.AND..NOT.qs_env%run_rtp) THEN - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,error=error) - CPPrecondition(nimages==1,cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs) + CPPrecondition(nimages==1,cp_failure_level,routineP,failure) ksmat => ks_matrix(:,1) - CALL calc_mo_derivatives(qs_env,ksmat,mo_derivs,error) + CALL calc_mo_derivatives(qs_env,ksmat,mo_derivs) ENDIF ! deal with low spin roks CALL low_spin_roks(energy,qs_env,dft_control,just_energy,& - calculate_forces,auxbas_pw_pool,error) + calculate_forces,auxbas_pw_pool) ! deal with sic on explicit orbitals CALL sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_energy,& - calculate_forces,auxbas_pw_pool,error) + calculate_forces,auxbas_pw_pool) ! Periodic external field - CALL qs_efield_berry_phase(qs_env,just_energy,calculate_forces,error) + CALL qs_efield_berry_phase(qs_env,just_energy,calculate_forces) ! adds s2_restraint energy and orbital derivatives CALL qs_ks_s2_restraint(dft_control,qs_env,matrix_s,& - energy,calculate_forces,just_energy,error) + energy,calculate_forces,just_energy) IF ( do_ppl ) THEN ! update core energy for grid based local pseudopotential @@ -806,7 +792,7 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env,calculate_forces,just_energy,& ! Print detailed energy IF (my_print) THEN - CALL print_detailed_energy(qs_env,dft_control,input,energy,mulliken_order_p,error=error) + CALL print_detailed_energy(qs_env,dft_control,input,energy,mulliken_order_p) END IF END IF ! failure @@ -822,18 +808,15 @@ END SUBROUTINE qs_ks_build_kohn_sham_matrix !> \param just_energy if true updates the energies but not the !> ks matrix. Defaults to false !> \param print_active ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2014 created !> \author Dorothea Golze !> \note might be integrate in qs_ks_build_kohn_sham_matrix later ! ***************************************************************************** - SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active,error) + SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in) :: calculate_forces, just_energy LOGICAL, INTENT(in), OPTIONAL :: print_active - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lri_build_ks_matrix', & routineP = moduleN//':'//routineN @@ -876,7 +859,7 @@ SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active, matrix_p, poisson_env, pw_pools, v_rspace_new, v_tau_rspace, & atomic_kind_set, lri_env, lri_density, lri_v_int, v_hartree_rspace%pw,& virial) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) my_print = .TRUE. IF(PRESENT(print_active)) my_print = print_active @@ -895,18 +878,17 @@ SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active, v_hartree_rspace=v_hartree_rspace%pw,& matrix_ks=ks_matrix,& rho=rho,& - energy=energy,& - error=error) + energy=energy) nspins=dft_control%nspins - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ! gets the tmp grids CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools, poisson_env=poisson_env,error=error) + pw_pools=pw_pools, poisson_env=poisson_env) IF (.NOT. failure) THEN @@ -914,19 +896,17 @@ SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active, CALL pw_pool_create_pw(auxbas_pw_pool,& v_hartree_gspace%pw, & use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& rho_tot_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) ! get the total density in g-space [ions + electrons] - CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, error=error) + CALL calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho) IF(my_print) THEN - CALL print_densities(qs_env, rho, error=error) + CALL print_densities(qs_env, rho) END IF ! solve Poisson equation to get Hartree energy and potential and the stress @@ -934,39 +914,38 @@ SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active, IF (use_virial.AND.calculate_forces) THEN h_stress(:,:) = 0.0_dp CALL pw_poisson_solve(poisson_env,rho_tot_gspace%pw,energy%hartree,& - v_hartree_gspace%pw,h_stress=h_stress,error=error) + v_hartree_gspace%pw,h_stress=h_stress) virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe,dp) ELSE CALL pw_poisson_solve(poisson_env,rho_tot_gspace%pw,energy%hartree,& - v_hartree_gspace%pw,error=error) + v_hartree_gspace%pw) ENDIF IF (.NOT. just_energy) THEN - CALL pw_transfer(v_hartree_gspace%pw, v_hartree_rspace%pw, error=error) - CALL pw_scale(v_hartree_rspace%pw, v_hartree_rspace%pw%pw_grid%dvol,& - error=error) + CALL pw_transfer(v_hartree_gspace%pw, v_hartree_rspace%pw) + CALL pw_scale(v_hartree_rspace%pw, v_hartree_rspace%pw%pw_grid%dvol) END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw) ! *** core contribution IF (.NOT. just_energy) THEN ! Initialize the Kohn-Sham matrix with the core Hamiltonian matrix DO ispin=1,nspins CALL cp_dbcsr_copy(ks_matrix(ispin)%matrix,matrix_h(1)%matrix,& - name=cp_dbcsr_name(ks_matrix(ispin)%matrix),error=error) + name=cp_dbcsr_name(ks_matrix(ispin)%matrix)) END DO END IF ! *** exchange-correlation IF (use_virial .AND. calculate_forces) virial%pv_calculate = .TRUE. - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") just_energy_xc=just_energy CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho, xc_section=xc_section, & vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=energy%exc, & edisp=edisp, dispersion_env=qs_env%dispersion_env, & - just_energy=just_energy_xc, error=error) + just_energy=just_energy_xc) IF(edisp /= 0.0_dp) energy%dispersion = edisp IF (use_virial .AND. calculate_forces) THEN @@ -990,29 +969,28 @@ SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active, lri_v_int => lri_density%lri_coefs(ispin)%lri_kinds IF(.NOT.ASSOCIATED(v_rspace_new)) THEN CALL integrate_v_rspace_one_center(v_hartree_rspace,qs_env,& - lri_v_int,calculate_forces,error) + lri_v_int,calculate_forces) ELSE CALL integrate_v_rspace_one_center(v_rspace_new(ispin),qs_env,& - lri_v_int,calculate_forces,error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw,& - error=error) + lri_v_int,calculate_forces) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw) ENDIF CALL calculate_lri_ks_matrix(lri_env, lri_v_int, ks_matrix(ispin)%matrix,& - atomic_kind_set, error) + atomic_kind_set) ENDDO IF(ASSOCIATED(v_rspace_new)) THEN DEALLOCATE(v_rspace_new,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF ! *** LRIGPW forces IF (calculate_forces ) THEN ! Getting nuclear force contribution from the core charge density - CALL integrate_v_core_rspace(v_hartree_rspace, qs_env,error=error) + CALL integrate_v_core_rspace(v_hartree_rspace, qs_env) ! Getting electronic force contribution from fitted LRI charge density - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao=matrix_p) CALL calculate_lri_forces(lri_env,lri_density,qs_env,matrix_p,atomic_kind_set,& - use_virial,error) + use_virial) END IF ENDIF @@ -1020,8 +998,7 @@ SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active, ! At this point the ks matrix should be up to date, filter it if requested DO ispin=1,nspins CALL cp_dbcsr_filter(ks_matrix(ispin)%matrix,& - dft_control%qs_control%eps_filter_matrix,& - error=error) + dft_control%qs_control%eps_filter_matrix) ENDDO ! Right now we can compute the orbital derivative here, as it depends currently only on the available @@ -1029,8 +1006,8 @@ SUBROUTINE lri_build_ks_matrix(qs_env,calculate_forces,just_energy,print_active, ! from this routine, notice that this part of the calculation in not linear scaling ! right now this operation is only non-trivial because of occupation numbers and the restricted keyword IF (qs_env%requires_mo_derivs .AND. .NOT. just_energy.AND..NOT.qs_env%run_rtp) THEN - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,error=error) - CALL calc_mo_derivatives(qs_env,ks_matrix,mo_derivs,error) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs) + CALL calc_mo_derivatives(qs_env,ks_matrix,mo_derivs) ENDIF energy%total = energy%core_overlap + energy%core_self + & @@ -1057,14 +1034,12 @@ END SUBROUTINE lri_build_ks_matrix !> \param qs_env ... !> \param rho ... !> \param skip_nuclear_density ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, skip_nuclear_density, error) + SUBROUTINE calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, skip_nuclear_density) TYPE(pw_p_type), INTENT(INOUT) :: rho_tot_gspace TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_rho_type), POINTER :: rho LOGICAL, INTENT(IN), OPTIONAL :: skip_nuclear_density - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'calc_rho_tot_gspace', & routineP = moduleN//':'//routineN @@ -1083,35 +1058,34 @@ SUBROUTINE calc_rho_tot_gspace(rho_tot_gspace, qs_env, rho, skip_nuclear_density rho_core=rho_core,& rho0_s_gs=rho0_s_gs,& qs_charges=qs_charges,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL qs_rho_get(rho, rho_g=rho_g) IF (.NOT.my_skip) THEN IF(dft_control%qs_control%gapw) THEN IF(dft_control%qs_control%gapw_control%nopaw_as_gpw) THEN - CPPrecondition(ASSOCIATED(rho0_s_gs),cp_failure_level,routineP,error,failure) - CALL pw_copy(rho0_s_gs%pw,rho_tot_gspace%pw, error=error) - CALL pw_axpy(rho_core%pw,rho_tot_gspace%pw, error=error) - CALL pw_axpy(rho_g(1)%pw,rho_tot_gspace%pw, error=error) + CPPrecondition(ASSOCIATED(rho0_s_gs),cp_failure_level,routineP,failure) + CALL pw_copy(rho0_s_gs%pw,rho_tot_gspace%pw) + CALL pw_axpy(rho_core%pw,rho_tot_gspace%pw) + CALL pw_axpy(rho_g(1)%pw,rho_tot_gspace%pw) ELSE - CPPrecondition(ASSOCIATED(rho0_s_gs),cp_failure_level,routineP,error,failure) - CALL pw_copy(rho0_s_gs%pw,rho_tot_gspace%pw, error=error) - CALL pw_axpy(rho_g(1)%pw,rho_tot_gspace%pw, error=error) + CPPrecondition(ASSOCIATED(rho0_s_gs),cp_failure_level,routineP,failure) + CALL pw_copy(rho0_s_gs%pw,rho_tot_gspace%pw) + CALL pw_axpy(rho_g(1)%pw,rho_tot_gspace%pw) END IF ELSE - CALL pw_copy(rho_core%pw,rho_tot_gspace%pw, error=error) - CALL pw_axpy(rho_g(1)%pw,rho_tot_gspace%pw, error=error) + CALL pw_copy(rho_core%pw,rho_tot_gspace%pw) + CALL pw_axpy(rho_g(1)%pw,rho_tot_gspace%pw) END IF ELSE - CALL pw_axpy(rho_g(1)%pw, rho_tot_gspace%pw, error=error) + CALL pw_axpy(rho_g(1)%pw, rho_tot_gspace%pw) END IF DO ispin=2, dft_control%nspins - CALL pw_axpy(rho_g(ispin)%pw, rho_tot_gspace%pw, error=error) + CALL pw_axpy(rho_g(ispin)%pw, rho_tot_gspace%pw) END DO IF (.NOT.my_skip) & - qs_charges%total_rho_gspace = pw_integrate_function(rho_tot_gspace%pw,isign=-1, error=error) + qs_charges%total_rho_gspace = pw_integrate_function(rho_tot_gspace%pw,isign=-1) END SUBROUTINE calc_rho_tot_gspace @@ -1120,17 +1094,15 @@ END SUBROUTINE calc_rho_tot_gspace !> \param qs_env the qs_env to update !> \param ks_matrix ... !> \param mo_derivs ... -!> \param error ... !> \par History !> 01.2014 created, transferred from qs_ks_build_kohn_sham_matrix in !> separate subroutine !> \author Dorothea Golze ! ***************************************************************************** - SUBROUTINE calc_mo_derivatives(qs_env,ks_matrix,mo_derivs,error) + SUBROUTINE calc_mo_derivatives(qs_env,ks_matrix,mo_derivs) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix, mo_derivs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_mo_derivatives', & routineP = moduleN//':'//routineN @@ -1157,8 +1129,7 @@ SUBROUTINE calc_mo_derivatives(qs_env,ks_matrix,mo_derivs,error) CALL get_qs_env(qs_env,& dft_control=dft_control,& - mos=mo_array,& - error=error) + mos=mo_array) IF(dft_control%do_admm_mo) THEN !fm->dbcsr NULLIFY(mo_derivs_tmp)!fm->dbcsr @@ -1166,7 +1137,7 @@ SUBROUTINE calc_mo_derivatives(qs_env,ks_matrix,mo_derivs,error) DO ispin=1,SIZE(mo_derivs)!fm->dbcsr CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,mo_coeff=mo_coeff)!fm->dbcsr NULLIFY(mo_derivs_tmp(ispin)%matrix) - CALL cp_fm_create(mo_derivs_tmp(ispin)%matrix,mo_coeff%matrix_struct,error=error)!fm->dbcsr + CALL cp_fm_create(mo_derivs_tmp(ispin)%matrix,mo_coeff%matrix_struct)!fm->dbcsr ENDDO!fm->dbcsr ENDIF!fm->dbcsr @@ -1176,48 +1147,47 @@ SUBROUTINE calc_mo_derivatives(qs_env,ks_matrix,mo_derivs,error) CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,mo_coeff=mo_coeff,& mo_coeff_b=mo_coeff_b, occupation_numbers=occupation_numbers ) CALL cp_dbcsr_multiply('n','n',1.0_dp,ks_matrix(ispin)%matrix,mo_coeff_b,& - 0.0_dp,mo_derivs(ispin)%matrix, error=error) + 0.0_dp,mo_derivs(ispin)%matrix) IF(dft_control%do_admm_mo) THEN CALL get_qs_env(qs_env,& mos_aux_fit=mos_aux_fit,& mo_derivs_aux_fit=mo_derivs_aux_fit,& - matrix_ks_aux_fit=matrix_ks_aux_fit,& - error=error) + matrix_ks_aux_fit=matrix_ks_aux_fit) CALL get_mo_set(mo_set=mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) CALL copy_dbcsr_to_fm(mo_derivs(ispin)%matrix,& - mo_derivs_tmp(ispin)%matrix,error=error)!fm->dbcsr + mo_derivs_tmp(ispin)%matrix)!fm->dbcsr CALL admm_mo_merge_derivs(ispin, qs_env%admm_env, mo_array(ispin)%mo_set, & mo_coeff, mo_coeff_aux_fit, mo_derivs_tmp, mo_derivs_aux_fit, & - matrix_ks_aux_fit, error=error) - CALL copy_fm_to_dbcsr(mo_derivs_tmp(ispin)%matrix,mo_derivs(ispin)%matrix,error=error)!fm->dbcsr + matrix_ks_aux_fit) + CALL copy_fm_to_dbcsr(mo_derivs_tmp(ispin)%matrix,mo_derivs(ispin)%matrix)!fm->dbcsr END IF IF (dft_control%restricted) THEN ! only the first mo_set are actual variables, but we still need both - CPPrecondition(ispin==1, cp_failure_level, routineP, error, failure) - CPPrecondition(SIZE(mo_array)==2, cp_failure_level, routineP, error, failure) + CPPrecondition(ispin==1, cp_failure_level, routineP,failure) + CPPrecondition(SIZE(mo_array)==2, cp_failure_level, routineP,failure) ! use a temporary array with the same size as the first spin for the second spin ! uniform_occupation is needed for this case, otherwise we can no ! reconstruct things in ot, since we irreversibly sum CALL get_mo_set(mo_set=mo_array(1)%mo_set, uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation, cp_failure_level, routineP, error, failure) + CPPrecondition(uniform_occupation, cp_failure_level, routineP,failure) CALL get_mo_set(mo_set=mo_array(2)%mo_set,& uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation, cp_failure_level, routineP, error, failure) + CPPrecondition(uniform_occupation, cp_failure_level, routineP,failure) CALL get_mo_set(mo_set=mo_array(2)%mo_set,mo_coeff_b=mo_coeff_b) CALL cp_dbcsr_multiply('n','n',1.0_dp,ks_matrix(2)%matrix,mo_coeff_b,& - 1.0_dp, mo_derivs(1)%matrix, match_matrix_sizes=.TRUE., error=error) + 1.0_dp, mo_derivs(1)%matrix, match_matrix_sizes=.TRUE.) ENDIF ENDDO IF(dft_control%do_admm_mo) THEN !fm->dbcsr DO ispin=1,SIZE(mo_derivs)!fm->dbcsr - CALL cp_fm_release(mo_derivs_tmp(ispin)%matrix,error=error)!fm->dbcsr + CALL cp_fm_release(mo_derivs_tmp(ispin)%matrix)!fm->dbcsr ENDDO!fm->dbcsr DEALLOCATE(mo_derivs_tmp)!fm->dbcsr ENDIF!fm->dbcsr @@ -1233,8 +1203,6 @@ END SUBROUTINE calc_mo_derivatives !> \param just_energy if true updates the energies but not the !> ks matrix. Defaults to false !> \param print_active ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> 8.2014 kpoints [JGH] @@ -1242,11 +1210,10 @@ END SUBROUTINE calc_mo_derivatives !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE qs_ks_update_qs_env(qs_env,calculate_forces,just_energy,& - print_active,error) + print_active) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN), OPTIONAL :: calculate_forces, & just_energy, print_active - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_update_qs_env', & routineP = moduleN//':'//routineN @@ -1259,7 +1226,7 @@ SUBROUTINE qs_ks_update_qs_env(qs_env,calculate_forces,just_energy,& failure=.FALSE. NULLIFY(logger,ks_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() c_forces = .FALSE. energy_only = .FALSE. @@ -1272,15 +1239,14 @@ SUBROUTINE qs_ks_update_qs_env(qs_env,calculate_forces,just_energy,& CALL timeset(routineN,handle) ENDIF - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& ks_env=ks_env,& rho_changed=rho_changed,& s_mstruct_changed=s_mstruct_changed,& potential_changed=potential_changed,& - forces_up_to_date=forces_up_to_date,& - error=error) + forces_up_to_date=forces_up_to_date) do_rebuild = .FALSE. do_rebuild = do_rebuild .OR. rho_changed @@ -1290,24 +1256,22 @@ SUBROUTINE qs_ks_update_qs_env(qs_env,calculate_forces,just_energy,& IF (do_rebuild) THEN - CALL evaluate_core_matrix_traces(qs_env,error) + CALL evaluate_core_matrix_traces(qs_env) ! the ks matrix will be rebuilt so this is fine now - CALL set_ks_env(ks_env, potential_changed=.FALSE., error=error) + CALL set_ks_env(ks_env, potential_changed=.FALSE.) CALL rebuild_ks_matrix(qs_env,& calculate_forces=c_forces,& just_energy=energy_only,& - print_active=print_active,& - error=error) + print_active=print_active) IF(.NOT.energy_only) THEN CALL set_ks_env(ks_env,& rho_changed=.FALSE.,& s_mstruct_changed=.FALSE.,& - forces_up_to_date=forces_up_to_date.or.c_forces,& - error=error) + forces_up_to_date=forces_up_to_date.or.c_forces) END IF END IF @@ -1327,12 +1291,10 @@ END SUBROUTINE qs_ks_update_qs_env ! ***************************************************************************** !> \brief Calculates the traces of the core matrices and the density matrix. !> \param qs_env ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE evaluate_core_matrix_traces(qs_env,error) + SUBROUTINE evaluate_core_matrix_traces(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'evaluate_core_matrix_traces', & routineP = moduleN//':'//routineN @@ -1353,16 +1315,15 @@ SUBROUTINE evaluate_core_matrix_traces(qs_env,error) energy=energy,& dft_control=dft_control,& kinetic_kp=matrixkp_t,& - matrix_h_kp=matrixkp_h,& - error=error) + matrix_h_kp=matrixkp_h) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) - CALL calculate_ptrace(matrixkp_h, rho_ao_kp, energy%core, dft_control%nspins, error) + CALL calculate_ptrace(matrixkp_h, rho_ao_kp, energy%core, dft_control%nspins) ! kinetic energy IF(ASSOCIATED(matrixkp_t)) & - CALL calculate_ptrace(matrixkp_t, rho_ao_kp, energy%kinetic, dft_control%nspins, error) + CALL calculate_ptrace(matrixkp_t, rho_ao_kp, energy%kinetic, dft_control%nspins) CALL timestop(handle) END SUBROUTINE evaluate_core_matrix_traces @@ -1374,14 +1335,12 @@ END SUBROUTINE evaluate_core_matrix_traces !> \param calculate_forces ... !> \param just_energy ... !> \param print_active ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE rebuild_ks_matrix(qs_env,calculate_forces,just_energy,print_active,error) + SUBROUTINE rebuild_ks_matrix(qs_env,calculate_forces,just_energy,print_active) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calculate_forces, just_energy LOGICAL, INTENT(IN), OPTIONAL :: print_active - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rebuild_ks_matrix', & routineP = moduleN//':'//routineN @@ -1392,38 +1351,33 @@ SUBROUTINE rebuild_ks_matrix(qs_env,calculate_forces,just_energy,print_active,er CALL timeset(routineN,handle) NULLIFY(dft_control) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN CALL build_se_fock_matrix(qs_env,& calculate_forces=calculate_forces,& - just_energy=just_energy,& - error=error) + just_energy=just_energy) ELSEIF (dft_control%qs_control%dftb) THEN CALL build_dftb_ks_matrix(qs_env,& calculate_forces=calculate_forces,& - just_energy=just_energy,& - error=error) + just_energy=just_energy) ELSEIF (dft_control%qs_control%scptb) THEN CALL build_scptb_ks_matrix(qs_env,& calculate_forces=calculate_forces,& - just_energy=just_energy,& - error=error) + just_energy=just_energy) ELSEIF (dft_control%qs_control%lrigpw) THEN CALL lri_build_ks_matrix(qs_env,& calculate_forces=calculate_forces,& just_energy=just_energy,& - print_active=print_active,& - error=error) + print_active=print_active) ELSE CALL qs_ks_build_kohn_sham_matrix(qs_env,& calculate_forces=calculate_forces,& just_energy=just_energy,& - print_active=print_active,& - error=error) + print_active=print_active) END IF CALL timestop(handle) @@ -1436,18 +1390,16 @@ END SUBROUTINE rebuild_ks_matrix !> \param mo_set type containing the full matrix of the MO and the eigenvalues !> \param w_matrix sparse matrix !> error -!> \param error ... !> \par History !> Creation (03.03.03,MK) !> Modification that computes it as a full block, several times (e.g. 20) !> faster at the cost of some additional memory !> \author MK ! ***************************************************************************** - SUBROUTINE calculate_w_matrix_1(mo_set,w_matrix,error) + SUBROUTINE calculate_w_matrix_1(mo_set,w_matrix) TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_dbcsr_type), POINTER :: w_matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_w_matrix_1', & routineP = moduleN//':'//routineN @@ -1461,13 +1413,13 @@ SUBROUTINE calculate_w_matrix_1(mo_set,w_matrix,error) failure=.FALSE. NULLIFY(weighted_vectors) - CALL cp_dbcsr_set(w_matrix,0.0_dp,error=error) - CALL cp_fm_create(weighted_vectors,mo_set%mo_coeff%matrix_struct,"weighted_vectors",error=error) - CALL cp_fm_to_fm(mo_set%mo_coeff,weighted_vectors,error=error) + CALL cp_dbcsr_set(w_matrix,0.0_dp) + CALL cp_fm_create(weighted_vectors,mo_set%mo_coeff%matrix_struct,"weighted_vectors") + CALL cp_fm_to_fm(mo_set%mo_coeff,weighted_vectors) ! scale every column with the occupation ALLOCATE(eigocc(mo_set%homo),stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO imo=1,mo_set%homo eigocc(imo) = mo_set%eigenvalues(imo)*mo_set%occupation_numbers(imo) @@ -1478,9 +1430,9 @@ SUBROUTINE calculate_w_matrix_1(mo_set,w_matrix,error) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=w_matrix,& matrix_v=mo_set%mo_coeff,& matrix_g=weighted_vectors,& - ncol=mo_set%homo,error=error) + ncol=mo_set%homo) - CALL cp_fm_release(weighted_vectors,error=error) + CALL cp_fm_release(weighted_vectors) CALL timestop(handle) @@ -1495,16 +1447,14 @@ END SUBROUTINE calculate_w_matrix_1 !> \param w_matrix sparse matrix !> \param s_matrix sparse matrix for the overlap !> error -!> \param error ... !> \par History !> Creation (JV) !> \author MK ! ***************************************************************************** - SUBROUTINE calculate_w_matrix_ot(mo_set,mo_deriv,w_matrix,s_matrix,error) + SUBROUTINE calculate_w_matrix_ot(mo_set,mo_deriv,w_matrix,s_matrix) TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_dbcsr_type), POINTER :: mo_deriv, w_matrix, s_matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_w_matrix_ot', & routineP = moduleN//':'//routineN @@ -1529,67 +1479,67 @@ SUBROUTINE calculate_w_matrix_ot(mo_set,mo_deriv,w_matrix,s_matrix,error) ncol_global=ncol_global,& nrow_global=nrow_global,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) + ncol_block=ncol_block) - CALL cp_fm_create(weighted_vectors,mo_set%mo_coeff%matrix_struct,"weighted_vectors",error=error) + CALL cp_fm_create(weighted_vectors,mo_set%mo_coeff%matrix_struct,"weighted_vectors") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol_global, ncol_global=ncol_global, & para_env=mo_set%mo_coeff%matrix_struct%para_env, & - context=mo_set%mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create(h_block,fm_struct_tmp, name="h block",error=error) - IF (do_symm) CALL cp_fm_create(h_block_t,fm_struct_tmp, name="h block t",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=mo_set%mo_coeff%matrix_struct%context) + CALL cp_fm_create(h_block,fm_struct_tmp, name="h block") + IF (do_symm) CALL cp_fm_create(h_block_t,fm_struct_tmp, name="h block t") + CALL cp_fm_struct_release(fm_struct_tmp) CALL get_mo_set(mo_set=mo_set, occupation_numbers=occupation_numbers ) ALLOCATE(scaling_factor(SIZE(occupation_numbers)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) scaling_factor=2.0_dp*occupation_numbers - CALL copy_dbcsr_to_fm(mo_deriv,weighted_vectors,error=error) + CALL copy_dbcsr_to_fm(mo_deriv,weighted_vectors) CALL cp_fm_column_scale(weighted_vectors,scaling_factor) DEALLOCATE(scaling_factor,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! the convention seems to require the half here, the factor of two is presumably taken care of ! internally in qs_core_hamiltonian CALL cp_gemm('T','N',ncol_global,ncol_global,nrow_global,0.5_dp, & - mo_set%mo_coeff,weighted_vectors,0.0_dp,h_block,error=error) + mo_set%mo_coeff,weighted_vectors,0.0_dp,h_block) IF (do_symm) THEN ! at the minimum things are anyway symmetric, but numerically it might not be the case ! needs some investigation to find out if using this is better - CALL cp_fm_transpose(h_block,h_block_t,error=error) - CALL cp_fm_scale_and_add(0.5_dp,h_block,0.5_dp,h_block_t,error=error) + CALL cp_fm_transpose(h_block,h_block_t) + CALL cp_fm_scale_and_add(0.5_dp,h_block,0.5_dp,h_block_t) ENDIF ! this could overwrite the mo_derivs to save the weighted_vectors CALL cp_gemm('N','N',nrow_global,ncol_global,ncol_global,1.0_dp, & - mo_set%mo_coeff,h_block,0.0_dp,weighted_vectors,error=error) + mo_set%mo_coeff,h_block,0.0_dp,weighted_vectors) - CALL cp_dbcsr_set(w_matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(w_matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=w_matrix,& matrix_v=mo_set%mo_coeff,& matrix_g=weighted_vectors,& - ncol=mo_set%homo,error=error) + ncol=mo_set%homo) IF (check_gradient) THEN - CALL cp_fm_create(gradient,mo_set%mo_coeff%matrix_struct,"gradient",error=error) + CALL cp_fm_create(gradient,mo_set%mo_coeff%matrix_struct,"gradient") CALL cp_dbcsr_sm_fm_multiply(s_matrix,weighted_vectors,& - gradient, ncol_global,error=error) + gradient, ncol_global) ALLOCATE(scaling_factor(SIZE(occupation_numbers)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) scaling_factor=2.0_dp*occupation_numbers - CALL copy_dbcsr_to_fm(mo_deriv,weighted_vectors,error=error) + CALL copy_dbcsr_to_fm(mo_deriv,weighted_vectors) CALL cp_fm_column_scale(weighted_vectors,scaling_factor) DEALLOCATE(scaling_factor,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) WRITE(*,*) " maxabs difference ", MAXVAL(ABS(weighted_vectors%local_data-2.0_dp*gradient%local_data)) - CALL cp_fm_release(gradient,error=error) + CALL cp_fm_release(gradient) ENDIF - IF (do_symm) CALL cp_fm_release(h_block_t,error=error) - CALL cp_fm_release(weighted_vectors,error=error) - CALL cp_fm_release(h_block,error=error) + IF (do_symm) CALL cp_fm_release(h_block_t) + CALL cp_fm_release(weighted_vectors) + CALL cp_fm_release(h_block) CALL timestop(handle) @@ -1602,13 +1552,11 @@ END SUBROUTINE calculate_w_matrix_ot !> \param matrix_ks ... !> \param matrix_p ... !> \param matrix_w ... -!> \param error ... !> \author 04.05.06,MK ! ***************************************************************************** - SUBROUTINE calculate_w_matrix_roks(mo_set,matrix_ks,matrix_p,matrix_w,error) + SUBROUTINE calculate_w_matrix_roks(mo_set,matrix_ks,matrix_p,matrix_w) TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_dbcsr_type), POINTER :: matrix_ks, matrix_p, matrix_w - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_w_matrix_roks', & routineP = moduleN//':'//routineN @@ -1630,25 +1578,24 @@ SUBROUTINE calculate_w_matrix_roks(mo_set,matrix_ks,matrix_p,matrix_w,error) NULLIFY (work) CALL get_mo_set(mo_set=mo_set,mo_coeff=c) - CALL cp_fm_get_info(c,context=context,nrow_global=nao,para_env=para_env,& - error=error) + CALL cp_fm_get_info(c,context=context,nrow_global=nao,para_env=para_env) CALL cp_fm_struct_create(fm_struct,context=context,nrow_global=nao,& - ncol_global=nao,para_env=para_env,error=error) - CALL cp_fm_create(ks,fm_struct,name="Kohn-Sham matrix",error=error) - CALL cp_fm_create(p,fm_struct,name="Density matrix",error=error) - CALL cp_fm_create(work,fm_struct,name="Work matrix",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) - CALL copy_dbcsr_to_fm(matrix_ks,ks,error=error) - CALL copy_dbcsr_to_fm(matrix_p,p,error=error) - CALL cp_fm_upper_to_full(p,work,error) - CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ks,p,0.0_dp,work,error=error) - CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,p,work,0.0_dp,ks,error=error) - CALL cp_dbcsr_set(matrix_w,0.0_dp,error=error) - CALL copy_fm_to_dbcsr(ks,matrix_w,keep_sparsity=.TRUE., error=error) - - CALL cp_fm_release(work,error=error) - CALL cp_fm_release(p,error=error) - CALL cp_fm_release(ks,error=error) + ncol_global=nao,para_env=para_env) + CALL cp_fm_create(ks,fm_struct,name="Kohn-Sham matrix") + CALL cp_fm_create(p,fm_struct,name="Density matrix") + CALL cp_fm_create(work,fm_struct,name="Work matrix") + CALL cp_fm_struct_release(fm_struct) + CALL copy_dbcsr_to_fm(matrix_ks,ks) + CALL copy_dbcsr_to_fm(matrix_p,p) + CALL cp_fm_upper_to_full(p,work) + CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ks,p,0.0_dp,work) + CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,p,work,0.0_dp,ks) + CALL cp_dbcsr_set(matrix_w,0.0_dp) + CALL copy_fm_to_dbcsr(ks,matrix_w,keep_sparsity=.TRUE.) + + CALL cp_fm_release(work) + CALL cp_fm_release(p) + CALL cp_fm_release(ks) CALL timestop(handle) @@ -1657,15 +1604,13 @@ END SUBROUTINE calculate_w_matrix_roks ! ***************************************************************************** !> \brief Allocate ks_matrix and ks_env if necessary !> \param qs_env ... -!> \param error ... !> \par History !> refactoring 04.03.2011 [MI] !> \author ! ***************************************************************************** - SUBROUTINE qs_ks_allocate_basics(qs_env,error) + SUBROUTINE qs_ks_allocate_basics(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_allocate_basics', & routineP = moduleN//':'//routineN @@ -1693,12 +1638,11 @@ SUBROUTINE qs_ks_allocate_basics(qs_env,error) ks_env=ks_env,& sab_orb=sab_orb,& sab_aux_fit=sab_aux_fit,& - matrix_ks_kp=matrixkp_ks,& - error=error) + matrix_ks_kp=matrixkp_ks) IF (.NOT.ASSOCIATED(matrixkp_ks)) THEN nimg = dft_control%nimages - CALL cp_dbcsr_allocate_matrix_set(matrixkp_ks, dft_control%nspins, nimg, error) + CALL cp_dbcsr_allocate_matrix_set(matrixkp_ks, dft_control%nspins, nimg) refmatrix => matrix_s_kp(1,1)%matrix DO ispin=1,dft_control%nspins DO ic=1,nimg @@ -1712,18 +1656,18 @@ SUBROUTINE qs_ks_allocate_basics(qs_env,error) headline="KOHN-SHAM MATRIX" END IF ALLOCATE(matrixkp_ks(ispin,ic)%matrix) - CALL cp_dbcsr_init(matrixkp_ks(ispin,ic)%matrix,error=error) + CALL cp_dbcsr_init(matrixkp_ks(ispin,ic)%matrix) CALL cp_dbcsr_create(matrix=matrixkp_ks(ispin,ic)%matrix,& name=TRIM(headline),& dist=cp_dbcsr_distribution(refmatrix), matrix_type=dbcsr_type_symmetric,& row_blk_size=cp_dbcsr_row_block_sizes(refmatrix),& col_blk_size=cp_dbcsr_col_block_sizes(refmatrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrixkp_ks(ispin,ic)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(matrixkp_ks(ispin,ic)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrixkp_ks(ispin,ic)%matrix,sab_orb) + CALL cp_dbcsr_set(matrixkp_ks(ispin,ic)%matrix,0.0_dp) ENDDO ENDDO - CALL set_ks_env(ks_env, matrix_ks_kp=matrixkp_ks, error=error) + CALL set_ks_env(ks_env, matrix_ks_kp=matrixkp_ks) END IF @@ -1735,63 +1679,59 @@ SUBROUTINE qs_ks_allocate_basics(qs_env,error) matrix_ks_aux_fit=matrix_ks_aux_fit,& matrix_ks_aux_fit_dft=matrix_ks_aux_fit_dft,& matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx,& - matrix_s_aux_fit=matrix_s_aux_fit,& - error=error) + matrix_s_aux_fit=matrix_s_aux_fit) IF (.NOT.ASSOCIATED(matrix_ks_aux_fit)) THEN refmatrix => matrix_s_aux_fit(1)%matrix - CALL cp_dbcsr_allocate_matrix_set(matrix_ks_aux_fit, dft_control%nspins, error) + CALL cp_dbcsr_allocate_matrix_set(matrix_ks_aux_fit, dft_control%nspins) DO ispin=1,dft_control%nspins ALLOCATE(matrix_ks_aux_fit(ispin)%matrix) - CALL cp_dbcsr_init(matrix_ks_aux_fit(ispin)%matrix,error=error) + CALL cp_dbcsr_init(matrix_ks_aux_fit(ispin)%matrix) CALL cp_dbcsr_create(matrix=matrix_ks_aux_fit(ispin)%matrix, & name="KOHN-SHAM_MATRIX for ADMM", & dist=cp_dbcsr_distribution(refmatrix), matrix_type=dbcsr_type_symmetric, & row_blk_size=cp_dbcsr_row_block_sizes(refmatrix),& col_blk_size=cp_dbcsr_col_block_sizes(refmatrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks_aux_fit(ispin)%matrix,sab_aux_fit,& - error=error) - CALL cp_dbcsr_set(matrix_ks_aux_fit(ispin)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks_aux_fit(ispin)%matrix,sab_aux_fit) + CALL cp_dbcsr_set(matrix_ks_aux_fit(ispin)%matrix,0.0_dp) ENDDO - CALL set_ks_env(ks_env,matrix_ks_aux_fit=matrix_ks_aux_fit,error=error) + CALL set_ks_env(ks_env,matrix_ks_aux_fit=matrix_ks_aux_fit) END IF ! same allocation procedure for matrix_ks_aux_fit_dft IF (.NOT.ASSOCIATED(matrix_ks_aux_fit_dft)) THEN refmatrix => matrix_s_aux_fit(1)%matrix - CALL cp_dbcsr_allocate_matrix_set(matrix_ks_aux_fit_dft, dft_control%nspins, error) + CALL cp_dbcsr_allocate_matrix_set(matrix_ks_aux_fit_dft, dft_control%nspins) DO ispin=1,dft_control%nspins ALLOCATE(matrix_ks_aux_fit_dft(ispin)%matrix) - CALL cp_dbcsr_init(matrix_ks_aux_fit_dft(ispin)%matrix,error=error) + CALL cp_dbcsr_init(matrix_ks_aux_fit_dft(ispin)%matrix) CALL cp_dbcsr_create(matrix=matrix_ks_aux_fit_dft(ispin)%matrix, & name="AUX. KOHN-SHAM MATRIX FOR ADMM ONLY DFT EXCHANGE", & dist=cp_dbcsr_distribution(refmatrix), matrix_type=dbcsr_type_symmetric, & row_blk_size=cp_dbcsr_row_block_sizes(refmatrix),& col_blk_size=cp_dbcsr_col_block_sizes(refmatrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks_aux_fit_dft(ispin)%matrix,sab_aux_fit,& - error=error) - CALL cp_dbcsr_set(matrix_ks_aux_fit_dft(ispin)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks_aux_fit_dft(ispin)%matrix,sab_aux_fit) + CALL cp_dbcsr_set(matrix_ks_aux_fit_dft(ispin)%matrix,0.0_dp) ENDDO - CALL set_ks_env(ks_env,matrix_ks_aux_fit_dft=matrix_ks_aux_fit_dft,error=error) + CALL set_ks_env(ks_env,matrix_ks_aux_fit_dft=matrix_ks_aux_fit_dft) END IF ! same allocation procedure for matrix_ks_aux_fit_hfx IF (.NOT.ASSOCIATED(matrix_ks_aux_fit_hfx)) THEN refmatrix => matrix_s_aux_fit(1)%matrix - CALL cp_dbcsr_allocate_matrix_set(matrix_ks_aux_fit_hfx, dft_control%nspins, error) + CALL cp_dbcsr_allocate_matrix_set(matrix_ks_aux_fit_hfx, dft_control%nspins) DO ispin=1,dft_control%nspins ALLOCATE(matrix_ks_aux_fit_hfx(ispin)%matrix) - CALL cp_dbcsr_init(matrix_ks_aux_fit_hfx(ispin)%matrix,error=error) + CALL cp_dbcsr_init(matrix_ks_aux_fit_hfx(ispin)%matrix) CALL cp_dbcsr_create(matrix=matrix_ks_aux_fit_hfx(ispin)%matrix, & name="AUX. KOHN-SHAM MATRIX FOR ADMM ONLY HF EXCHANGE", & dist=cp_dbcsr_distribution(refmatrix), matrix_type=dbcsr_type_symmetric, & row_blk_size=cp_dbcsr_row_block_sizes(refmatrix),& col_blk_size=cp_dbcsr_col_block_sizes(refmatrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks_aux_fit_hfx(ispin)%matrix,sab_aux_fit,& - error=error) - CALL cp_dbcsr_set(matrix_ks_aux_fit_hfx(ispin)%matrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_ks_aux_fit_hfx(ispin)%matrix,sab_aux_fit) + CALL cp_dbcsr_set(matrix_ks_aux_fit_hfx(ispin)%matrix,0.0_dp) ENDDO - CALL set_ks_env(ks_env,matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx,error=error) + CALL set_ks_env(ks_env,matrix_ks_aux_fit_hfx=matrix_ks_aux_fit_hfx) END IF diff --git a/src/qs_ks_qmmm_methods.F b/src/qs_ks_qmmm_methods.F index d813353fb3..9fe67da667 100644 --- a/src/qs_ks_qmmm_methods.F +++ b/src/qs_ks_qmmm_methods.F @@ -52,30 +52,27 @@ MODULE qs_ks_qmmm_methods !> \brief Initialize the ks_qmmm_env !> \param qs_env ... !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE ks_qmmm_env_rebuild(qs_env,qmmm_env,error) + SUBROUTINE ks_qmmm_env_rebuild(qs_env,qmmm_env) TYPE(qs_environment_type), OPTIONAL, & POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error TYPE(qs_ks_qmmm_env_type), POINTER :: ks_qmmm_env NULLIFY(ks_qmmm_env) CALL get_qs_env(qs_env=qs_env,& - ks_qmmm_env=ks_qmmm_env,error=error) + ks_qmmm_env=ks_qmmm_env) ! *** allocate the ks_qmmm env if not allocated yet!** IF (.NOT.ASSOCIATED(ks_qmmm_env)) THEN CALL qs_ks_qmmm_create(ks_qmmm_env=ks_qmmm_env,qs_env=qs_env,& - qmmm_env=qmmm_env,error=error) - CALL set_qs_env(qs_env=qs_env, ks_qmmm_env=ks_qmmm_env,error=error) - CALL qs_ks_qmmm_release(ks_qmmm_env=ks_qmmm_env, error=error) + qmmm_env=qmmm_env) + CALL set_qs_env(qs_env=qs_env, ks_qmmm_env=ks_qmmm_env) + CALL qs_ks_qmmm_release(ks_qmmm_env=ks_qmmm_env) END IF END SUBROUTINE ks_qmmm_env_rebuild @@ -84,17 +81,14 @@ END SUBROUTINE ks_qmmm_env_rebuild !> \param ks_qmmm_env the ks_qmmm env to be initialized !> \param qs_env the qs environment !> \param qmmm_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qs_ks_qmmm_create(ks_qmmm_env, qs_env, qmmm_env, error) + SUBROUTINE qs_ks_qmmm_create(ks_qmmm_env, qs_env, qmmm_env) TYPE(qs_ks_qmmm_env_type), POINTER :: ks_qmmm_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(qmmm_env_qm_type), POINTER :: qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ks_qmmm_create', & routineP = moduleN//':'//routineN @@ -110,17 +104,17 @@ SUBROUTINE qs_ks_qmmm_create(ks_qmmm_env, qs_env, qmmm_env, error) CALL timeset(routineN,handle) failure=.FALSE. - CPPreconditionNoFail(.NOT.ASSOCIATED(ks_qmmm_env),cp_failure_level,routineP,error) + CPPreconditionNoFail(.NOT.ASSOCIATED(ks_qmmm_env),cp_failure_level,routineP) ALLOCATE(ks_qmmm_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY( ks_qmmm_env%pw_env,& ks_qmmm_env%cube_info) NULLIFY( auxbas_pw_pool) CALL get_qs_env(qs_env=qs_env,& - pw_env=ks_qmmm_env%pw_env,error=error) - CALL pw_env_get(ks_qmmm_env%pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) - CALL pw_env_retain(ks_qmmm_env%pw_env,error=error) + pw_env=ks_qmmm_env%pw_env) + CALL pw_env_get(ks_qmmm_env%pw_env,auxbas_pw_pool=auxbas_pw_pool) + CALL pw_env_retain(ks_qmmm_env%pw_env) ks_qmmm_env%pc_ener=0.0_dp ks_qmmm_env%n_evals=0 @@ -129,13 +123,13 @@ SUBROUTINE qs_ks_qmmm_create(ks_qmmm_env, qs_env, qmmm_env, error) ks_qmmm_env%id_nr=last_ks_qmmm_nr CALL pw_pool_create_pw(auxbas_pw_pool,ks_qmmm_env%v_qmmm_rspace%pw,& - use_data=REALDATA3D, in_space=REALSPACE,error=error) + use_data=REALDATA3D, in_space=REALSPACE) IF ((qmmm_env%qmmm_coupl_type==do_qmmm_gauss).OR.(qmmm_env%qmmm_coupl_type==do_qmmm_swave)) THEN CALL init_d3_poly_module() ! a fairly arbitrary but sufficient spot to do this - CALL pw_env_get(ks_qmmm_env%pw_env,pw_pools=pools,error=error) + CALL pw_env_get(ks_qmmm_env%pw_env,pw_pools=pools) ALLOCATE(cube_info(SIZE(pools)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO igrid=1,SIZE(pools) CALL init_cube_info(cube_info(igrid),& pools(igrid)%pool%pw_grid%dr(:),& @@ -160,17 +154,15 @@ END SUBROUTINE qs_ks_qmmm_create !> \param rho ... !> \param v_qmmm ... !> \param qmmm_energy ... -!> \param error ... !> \par History !> 05.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_calculate_energy(qs_env, rho, v_qmmm, qmmm_energy, error) + SUBROUTINE qmmm_calculate_energy(qs_env, rho, v_qmmm, qmmm_energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type), DIMENSION(:), POINTER :: rho TYPE(pw_p_type), INTENT(IN) :: v_qmmm REAL(KIND=dp), INTENT(INOUT) :: qmmm_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_calculate_energy', & routineP = moduleN//':'//routineN @@ -184,35 +176,33 @@ SUBROUTINE qmmm_calculate_energy(qs_env, rho, v_qmmm, qmmm_energy, error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) NULLIFY(dft_control,input,logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,& dft_control=dft_control,& - input=input,& - error=error) + input=input) output_unit=cp_print_key_unit_nr(logger,input,"QMMM%PRINT%PROGRAM_RUN_INFO",& - extension=".qmmmLog",error=error) + extension=".qmmmLog") IF (output_unit>0) WRITE (UNIT=output_unit,FMT="(T3,A)")& "Adding QM/MM electrostatic potential to the Kohn-Sham potential." qmmm_energy = 0.0_dp DO ispin=1, dft_control%nspins - qmmm_energy = qmmm_energy + pw_integral_ab ( rho(ispin)%pw, v_qmmm%pw, error=error) + qmmm_energy = qmmm_energy + pw_integral_ab ( rho(ispin)%pw, v_qmmm%pw) END DO IF(dft_control%qs_control%gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho0_s_rs=rho0_s_rs,& - error=error) - CPPrecondition(ASSOCIATED(rho0_s_rs),cp_failure_level,routineP,error,failure) - qmmm_energy = qmmm_energy + pw_integral_ab (rho0_s_rs%pw, v_qmmm%pw, error=error) + rho0_s_rs=rho0_s_rs) + CPPrecondition(ASSOCIATED(rho0_s_rs),cp_failure_level,routineP,failure) + qmmm_energy = qmmm_energy + pw_integral_ab (rho0_s_rs%pw, v_qmmm%pw) END IF CALL cp_print_key_finished_output(output_unit,logger,input,& - "QMMM%PRINT%PROGRAM_RUN_INFO", error=error) + "QMMM%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE qmmm_calculate_energy @@ -222,16 +212,14 @@ END SUBROUTINE qmmm_calculate_energy !> \param v_hartree ... !> \param v_qmmm ... !> \param scale ... -!> \param error ... !> \par History !> 05.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qmmm_modify_hartree_pot(v_hartree,v_qmmm,scale,error) + SUBROUTINE qmmm_modify_hartree_pot(v_hartree,v_qmmm,scale) TYPE(pw_p_type), INTENT(INOUT) :: v_hartree TYPE(pw_p_type), INTENT(IN) :: v_qmmm REAL(KIND=dp), INTENT(IN) :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qmmm_modify_hartree_pot', & routineP = moduleN//':'//routineN diff --git a/src/qs_ks_qmmm_types.F b/src/qs_ks_qmmm_types.F index 7374baac78..84c6860cad 100644 --- a/src/qs_ks_qmmm_types.F +++ b/src/qs_ks_qmmm_types.F @@ -70,15 +70,12 @@ MODULE qs_ks_qmmm_types ! ***************************************************************************** !> \brief releases the ks_qmmm_env (see doc/ReferenceCounting.html) !> \param ks_qmmm_env the ks_qmmm_env to be released -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE qs_ks_qmmm_release(ks_qmmm_env,error) + SUBROUTINE qs_ks_qmmm_release(ks_qmmm_env) TYPE(qs_ks_qmmm_env_type), POINTER :: ks_qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ks_qmmm_release', & routineP = moduleN//':'//routineN @@ -90,25 +87,25 @@ SUBROUTINE qs_ks_qmmm_release(ks_qmmm_env,error) failure=.FALSE. IF (ASSOCIATED(ks_qmmm_env)) THEN - CPPrecondition(ks_qmmm_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ks_qmmm_env%ref_count>0,cp_failure_level,routineP,failure) ks_qmmm_env%ref_count=ks_qmmm_env%ref_count-1 IF (ks_qmmm_env%ref_count<1) THEN - CALL pw_env_get(ks_qmmm_env%pw_env,auxbas_pw_pool=pool,error=error) - CALL pw_pool_give_back_pw(pool,ks_qmmm_env%v_qmmm_rspace%pw,error=error) - CALL pw_env_release(ks_qmmm_env%pw_env,error=error) + CALL pw_env_get(ks_qmmm_env%pw_env,auxbas_pw_pool=pool) + CALL pw_pool_give_back_pw(pool,ks_qmmm_env%v_qmmm_rspace%pw) + CALL pw_env_release(ks_qmmm_env%pw_env) IF (ASSOCIATED(ks_qmmm_env%cube_info))THEN DO i=1,SIZE(ks_qmmm_env%cube_info) CALL destroy_cube_info(ks_qmmm_env%cube_info(i)) END DO DEALLOCATE(ks_qmmm_env%cube_info, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(ks_qmmm_env%matrix_h)) THEN - CALL cp_dbcsr_deallocate_matrix_set(ks_qmmm_env%matrix_h,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_qmmm_env%matrix_h) END IF DEALLOCATE(ks_qmmm_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(ks_qmmm_env) @@ -117,15 +114,12 @@ END SUBROUTINE qs_ks_qmmm_release ! ***************************************************************************** !> \brief retains the given ks_environment !> \param ks_qmmm_env the KohnSham QM/MM environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2004 created [tlaino] !> \author Teodoro Laino ! ***************************************************************************** -SUBROUTINE qs_ks_qmmm_retain(ks_qmmm_env, error) +SUBROUTINE qs_ks_qmmm_retain(ks_qmmm_env) TYPE(qs_ks_qmmm_env_type), POINTER :: ks_qmmm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ks_qmmm_retain', & routineP = moduleN//':'//routineN @@ -134,8 +128,8 @@ SUBROUTINE qs_ks_qmmm_retain(ks_qmmm_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(ks_qmmm_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ks_qmmm_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ks_qmmm_env),cp_failure_level,routineP,failure) + CPPrecondition(ks_qmmm_env%ref_count>0,cp_failure_level,routineP,failure) ks_qmmm_env%ref_count=ks_qmmm_env%ref_count+1 END SUBROUTINE qs_ks_qmmm_retain diff --git a/src/qs_ks_types.F b/src/qs_ks_types.F index e05a3f006b..1dfae2bb5a 100644 --- a/src/qs_ks_types.F +++ b/src/qs_ks_types.F @@ -233,24 +233,22 @@ MODULE qs_ks_types ! ***************************************************************************** !> \brief Allocates a new instance of ks_env. !> \param ks_env ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** -SUBROUTINE qs_ks_env_create(ks_env, error) +SUBROUTINE qs_ks_env_create(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_env_create', & routineP = moduleN//':'//routineN IF(ASSOCIATED(ks_env)) STOP routineP//"ks_env already associated" ALLOCATE(ks_env) - CALL qs_rho_create(ks_env%rho, error) - CALL qs_rho_create(ks_env%rho_aux_fit, error) - CALL qs_rho_create(ks_env%rho_aux_fit_buffer, error) - CALL qs_rho_create(ks_env%rho_xc, error) - CALL qs_rho_create(ks_env%rho_buffer, error) - CALL kpoint_create(ks_env%kpoints,error) + CALL qs_rho_create(ks_env%rho) + CALL qs_rho_create(ks_env%rho_aux_fit) + CALL qs_rho_create(ks_env%rho_aux_fit_buffer) + CALL qs_rho_create(ks_env%rho_xc) + CALL qs_rho_create(ks_env%rho_buffer) + CALL kpoint_create(ks_env%kpoints) END SUBROUTINE qs_ks_env_create @@ -345,7 +343,6 @@ END SUBROUTINE qs_ks_env_create !> \param nelectron_total ... !> \param nelectron_spin ... !> \param admm_dm ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_ks_env(ks_env,v_hartree_rspace,& s_mstruct_changed,rho_changed,& @@ -368,8 +365,7 @@ SUBROUTINE get_ks_env(ks_env,v_hartree_rspace,& particle_set,energy,force,local_particles,local_molecules,& molecule_kind_set,molecule_set,subsys,cp_subsys,virial,results,atprop,& nkind, natom, dft_control,dbcsr_dist,distribution_2d,pw_env,& - para_env,blacs_env, nelectron_total, nelectron_spin,admm_dm,& - error) + para_env,blacs_env, nelectron_total, nelectron_spin,admm_dm) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(pw_type), OPTIONAL, POINTER :: v_hartree_rspace @@ -438,7 +434,6 @@ SUBROUTINE get_ks_env(ks_env,v_hartree_rspace,& INTEGER, OPTIONAL :: nelectron_total INTEGER, DIMENSION(2), OPTIONAL :: nelectron_spin TYPE(admm_dm_type), OPTIONAL, POINTER :: admm_dm - TYPE(cp_error_type), INTENT(INOUT) :: error IF(.NOT. ASSOCIATED(ks_env)) STOP "get_ks_env: not associated" IF(ks_env%ref_count<1) STOP "get_ks_env: ks_env%ref_count<1" @@ -541,8 +536,7 @@ SUBROUTINE get_ks_env(ks_env,v_hartree_rspace,& natom=natom,& nkind=nkind,& nelectron_total=nelectron_total,& - nelectron_spin=nelectron_spin,& - error=error) + nelectron_spin=nelectron_spin) END SUBROUTINE get_ks_env @@ -610,7 +604,6 @@ END SUBROUTINE get_ks_env !> \param para_env ... !> \param blacs_env ... !> \param admm_dm ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_ks_env(ks_env,v_hartree_rspace,& s_mstruct_changed,rho_changed,& @@ -626,8 +619,7 @@ SUBROUTINE set_ks_env(ks_env,v_hartree_rspace,& sab_se,sab_tbe,sab_core,sab_vdw,sab_scp,sab_almo,sab_kp,& task_list,task_list_aux_fit,task_list_soft,& subsys,dft_control,dbcsr_dist,distribution_2d,pw_env,& - para_env,blacs_env,admm_dm,& - error) + para_env,blacs_env,admm_dm) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(pw_type), OPTIONAL, POINTER :: v_hartree_rspace @@ -666,7 +658,6 @@ SUBROUTINE set_ks_env(ks_env,v_hartree_rspace,& TYPE(cp_blacs_env_type), OPTIONAL, & POINTER :: blacs_env TYPE(admm_dm_type), OPTIONAL, POINTER :: admm_dm - TYPE(cp_error_type), INTENT(INOUT) :: error IF(.NOT. ASSOCIATED(ks_env)) STOP "set_ks_env: not associated" IF(ks_env%ref_count<1) STOP "set_ks_env: ks_env%ref_count<1" @@ -738,13 +729,13 @@ SUBROUTINE set_ks_env(ks_env,v_hartree_rspace,& IF (PRESENT(task_list_soft)) ks_env%task_list_soft=>task_list_soft IF (PRESENT(subsys)) THEN - CALL qs_subsys_release(ks_env%subsys,error) - CALL qs_subsys_retain(subsys, error=error) + CALL qs_subsys_release(ks_env%subsys) + CALL qs_subsys_retain(subsys) ks_env%subsys => subsys END IF IF (PRESENT(dft_control)) THEN - CALL dft_control_retain(dft_control, error=error) - CALL dft_control_release(ks_env%dft_control, error=error) + CALL dft_control_retain(dft_control) + CALL dft_control_release(ks_env%dft_control) ks_env%dft_control => dft_control END IF IF (PRESENT(dbcsr_dist)) THEN @@ -755,23 +746,23 @@ SUBROUTINE set_ks_env(ks_env,v_hartree_rspace,& ks_env%dbcsr_dist => dbcsr_dist ENDIF IF (PRESENT(distribution_2d)) THEN - CALL distribution_2d_retain(distribution_2d,error=error) - CALL distribution_2d_release(ks_env%distribution_2d,error=error) + CALL distribution_2d_retain(distribution_2d) + CALL distribution_2d_release(ks_env%distribution_2d) ks_env%distribution_2d => distribution_2d ENDIF IF (PRESENT(pw_env)) THEN - CALL pw_env_retain(pw_env,error=error) - CALL pw_env_release(ks_env%pw_env,error=error) + CALL pw_env_retain(pw_env) + CALL pw_env_release(ks_env%pw_env) ks_env%pw_env => pw_env END IF IF (PRESENT(para_env)) THEN - CALL cp_para_env_retain(para_env,error=error) - CALL cp_para_env_release(ks_env%para_env,error=error) + CALL cp_para_env_retain(para_env) + CALL cp_para_env_release(ks_env%para_env) ks_env%para_env => para_env ENDIF IF (PRESENT(blacs_env)) THEN - CALL cp_blacs_env_retain(blacs_env,error=error) - CALL cp_blacs_env_release(ks_env%blacs_env,error=error) + CALL cp_blacs_env_retain(blacs_env) + CALL cp_blacs_env_release(ks_env%blacs_env) ks_env%blacs_env => blacs_env ENDIF END SUBROUTINE set_ks_env @@ -779,15 +770,12 @@ END SUBROUTINE set_ks_env ! ***************************************************************************** !> \brief releases the ks_env (see doc/ReferenceCounting.html) !> \param ks_env the ks_env to be released -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qs_ks_release(ks_env,error) + SUBROUTINE qs_ks_release(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ks_release', & routineP = moduleN//':'//routineN @@ -797,77 +785,77 @@ SUBROUTINE qs_ks_release(ks_env,error) failure=.FALSE. IF (ASSOCIATED(ks_env)) THEN - CPPrecondition(ks_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ks_env%ref_count>0,cp_failure_level,routineP,failure) ks_env%ref_count=ks_env%ref_count-1 IF (ks_env%ref_count<1) THEN IF (ASSOCIATED(ks_env%v_hartree_rspace)) & - CALL pw_release(ks_env%v_hartree_rspace,error=error) + CALL pw_release(ks_env%v_hartree_rspace) IF (ASSOCIATED(ks_env%matrix_ks_im)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_im,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_im) - CALL kpoint_transitional_release(ks_env%matrix_ks, error) - CALL kpoint_transitional_release(ks_env%matrix_h, error) - CALL kpoint_transitional_release(ks_env%matrix_vxc, error) - CALL kpoint_transitional_release(ks_env%matrix_s, error) - CALL kpoint_transitional_release(ks_env%matrix_w, error) - CALL kpoint_transitional_release(ks_env%kinetic, error) + CALL kpoint_transitional_release(ks_env%matrix_ks) + CALL kpoint_transitional_release(ks_env%matrix_h) + CALL kpoint_transitional_release(ks_env%matrix_vxc) + CALL kpoint_transitional_release(ks_env%matrix_s) + CALL kpoint_transitional_release(ks_env%matrix_w) + CALL kpoint_transitional_release(ks_env%kinetic) IF (ASSOCIATED(ks_env%matrix_ks_aux_fit)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit) IF (ASSOCIATED(ks_env%matrix_ks_aux_fit_im)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_im,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_im) IF (ASSOCIATED(ks_env%matrix_ks_aux_fit_dft)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_dft,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_dft) IF (ASSOCIATED(ks_env%matrix_ks_aux_fit_hfx)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_hfx,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_hfx) IF (ASSOCIATED(ks_env%matrix_s_aux_fit)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_s_aux_fit,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_s_aux_fit) IF (ASSOCIATED(ks_env%matrix_s_aux_fit_vs_orb)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_s_aux_fit_vs_orb,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_s_aux_fit_vs_orb) IF (ASSOCIATED(ks_env%matrix_w_mp2)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_w_mp2,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_w_mp2) IF (ASSOCIATED(ks_env%matrix_p_mp2)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_p_mp2) IF (ASSOCIATED(ks_env%gamma_matrix)) & - CALL cp_dbcsr_deallocate_matrix_set(ks_env%gamma_matrix,error) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%gamma_matrix) IF(ASSOCIATED(ks_env%rho))& - CALL qs_rho_release(ks_env%rho, error=error) + CALL qs_rho_release(ks_env%rho) IF(ASSOCIATED(ks_env%rho_buffer))& - CALL qs_rho_release(ks_env%rho_buffer,error=error) + CALL qs_rho_release(ks_env%rho_buffer) IF(ASSOCIATED(ks_env%rho_xc))& - CALL qs_rho_release(ks_env%rho_xc, error=error) + CALL qs_rho_release(ks_env%rho_xc) IF(ASSOCIATED(ks_env%rho_aux_fit))& - CALL qs_rho_release(ks_env%rho_aux_fit, error=error) + CALL qs_rho_release(ks_env%rho_aux_fit) IF(ASSOCIATED(ks_env%rho_aux_fit_buffer))& - CALL qs_rho_release(ks_env%rho_aux_fit_buffer, error=error) + CALL qs_rho_release(ks_env%rho_aux_fit_buffer) IF (ASSOCIATED(ks_env%distribution_2d)) & - CALL distribution_2d_release(ks_env%distribution_2d,error=error) + CALL distribution_2d_release(ks_env%distribution_2d) IF(ASSOCIATED(ks_env%task_list)) & - CALL deallocate_task_list(ks_env%task_list,error) + CALL deallocate_task_list(ks_env%task_list) IF(ASSOCIATED(ks_env%task_list_aux_fit)) & - CALL deallocate_task_list(ks_env%task_list_aux_fit,error) + CALL deallocate_task_list(ks_env%task_list_aux_fit) IF(ASSOCIATED(ks_env%task_list_soft)) & - CALL deallocate_task_list(ks_env%task_list_soft,error) + CALL deallocate_task_list(ks_env%task_list_soft) IF (ASSOCIATED(ks_env%rho_nlcc_g)) THEN - CALL pw_release(ks_env%rho_nlcc_g%pw,error=error) + CALL pw_release(ks_env%rho_nlcc_g%pw) DEALLOCATE(ks_env%rho_nlcc_g) ENDIF IF (ASSOCIATED(ks_env%rho_nlcc)) THEN - CALL pw_release(ks_env%rho_nlcc%pw,error=error) + CALL pw_release(ks_env%rho_nlcc%pw) DEALLOCATE(ks_env%rho_nlcc) ENDIF IF (ASSOCIATED(ks_env%rho_core)) THEN - CALL pw_release(ks_env%rho_core%pw,error=error) + CALL pw_release(ks_env%rho_core%pw) DEALLOCATE(ks_env%rho_core) ENDIF IF (ASSOCIATED(ks_env%vppl)) THEN - CALL pw_release(ks_env%vppl%pw,error=error) + CALL pw_release(ks_env%vppl%pw) DEALLOCATE(ks_env%vppl) ENDIF IF (ASSOCIATED(ks_env%vee)) THEN - CALL pw_release(ks_env%vee%pw,error=error) + CALL pw_release(ks_env%vee%pw) DEALLOCATE(ks_env%vee) ENDIF IF(ASSOCIATED(ks_env%dbcsr_dist)) THEN @@ -892,13 +880,13 @@ SUBROUTINE qs_ks_release(ks_env,error) CALL release_sab(ks_env%sab_lrc) CALL release_sab(ks_env%sab_almo) CALL release_sab(ks_env%sab_kp) - CALL dft_control_release(ks_env%dft_control, error=error) - CALL kpoint_release(ks_env%kpoints,error=error) - CALL qs_subsys_release(ks_env%subsys,error=error) - CALL pw_env_release(ks_env%pw_env, error=error) - CALL cp_para_env_release(ks_env%para_env,error=error) - CALL cp_blacs_env_release(ks_env%blacs_env, error=error) - CALL admm_dm_release(ks_env%admm_dm, error=error) + CALL dft_control_release(ks_env%dft_control) + CALL kpoint_release(ks_env%kpoints) + CALL qs_subsys_release(ks_env%subsys) + CALL pw_env_release(ks_env%pw_env) + CALL cp_para_env_release(ks_env%para_env) + CALL cp_blacs_env_release(ks_env%blacs_env) + CALL admm_dm_release(ks_env%admm_dm) DEALLOCATE(ks_env) END IF @@ -930,15 +918,12 @@ END SUBROUTINE release_sab ! ***************************************************************************** !> \brief retains the given ks_environment !> \param ks_env the KohnSham environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE qs_ks_retain(ks_env, error) +SUBROUTINE qs_ks_retain(ks_env) TYPE(qs_ks_env_type), POINTER :: ks_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ks_retain', & routineP = moduleN//':'//routineN @@ -947,8 +932,8 @@ SUBROUTINE qs_ks_retain(ks_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(ks_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ks_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ks_env),cp_failure_level,routineP,failure) + CPPrecondition(ks_env%ref_count>0,cp_failure_level,routineP,failure) ks_env%ref_count=ks_env%ref_count+1 END SUBROUTINE qs_ks_retain @@ -963,20 +948,17 @@ END SUBROUTINE qs_ks_retain !> \param rho_changed if true it means that the density has changed !> \param potential_changed ... !> \param full_reset if true everything has changed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 4.2002 created [fawzi] !> 12.2014 moved from qs_ks_methods, added deallocation of KS-matrices [Ole Schuett] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE qs_ks_did_change(ks_env,s_mstruct_changed,rho_changed,& - potential_changed,full_reset,error) + potential_changed,full_reset) TYPE(qs_ks_env_type), POINTER :: ks_env LOGICAL, INTENT(in), OPTIONAL :: s_mstruct_changed, & rho_changed, & potential_changed, full_reset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ks_did_change', & routineP = moduleN//':'//routineN @@ -988,7 +970,7 @@ SUBROUTINE qs_ks_did_change(ks_env,s_mstruct_changed,rho_changed,& failure = .FALSE. my_mstruct_chg = .FALSE. - CPPrecondition(ASSOCIATED(ks_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ks_env),cp_failure_level,routineP,failure) IF (PRESENT(rho_changed)) THEN IF (rho_changed) ks_env%rho_changed = .TRUE. @@ -1012,11 +994,11 @@ SUBROUTINE qs_ks_did_change(ks_env,s_mstruct_changed,rho_changed,& IF(my_mstruct_chg) THEN ks_env%s_mstruct_changed = .TRUE. ! *** deallocate matrices that will have the wrong structure *** - CALL kpoint_transitional_release(ks_env%matrix_ks, error) - CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit,error) + CALL kpoint_transitional_release(ks_env%matrix_ks) + CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit) !TODO: deallocate imaginary parts as well - !CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_im,error) - !CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_im,error) + !CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_im) + !CALL cp_dbcsr_deallocate_matrix_set(ks_env%matrix_ks_aux_fit_im) ENDIF CALL timestop(handle) diff --git a/src/qs_ks_utils.F b/src/qs_ks_utils.F index b13ef1d771..42975be8b2 100644 --- a/src/qs_ks_utils.F +++ b/src/qs_ks_utils.F @@ -124,17 +124,15 @@ MODULE qs_ks_utils !> \param just_energy ... !> \param calculate_forces ... !> \param auxbas_pw_pool ... -!> \param error ... ! ***************************************************************************** SUBROUTINE low_spin_roks(energy,qs_env,dft_control,just_energy,& - calculate_forces,auxbas_pw_pool,error) + calculate_forces,auxbas_pw_pool) TYPE(qs_energy_type), POINTER :: energy TYPE(qs_environment_type), POINTER :: qs_env TYPE(dft_control_type), POINTER :: dft_control LOGICAL, INTENT(IN) :: just_energy, calculate_forces TYPE(pw_pool_type), POINTER :: auxbas_pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'low_spin_roks', & routineP = moduleN//':'//routineN @@ -182,28 +180,27 @@ SUBROUTINE low_spin_roks(energy,qs_env,dft_control,just_energy,& pw_env=pw_env,& input=input,& cell=cell,& - virial=virial,& - error=error) + virial=virial) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) compute_virial=virial%pv_calculate.AND.(.NOT.virial%pv_numer) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") ! some assumptions need to be checked ! we have two spins - CPPrecondition(SIZE(mo_array,1)==2,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(mo_array,1)==2,cp_failure_level,routineP,failure) Nspin=2 ! we want uniform occupations CALL get_mo_set(mo_set=mo_array(1)%mo_set, uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation, cp_failure_level, routineP, error, failure) + CPPrecondition(uniform_occupation, cp_failure_level, routineP,failure) CALL get_mo_set(mo_set=mo_array(2)%mo_set,mo_coeff_b=mo_coeff, uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation, cp_failure_level, routineP, error, failure) + CPPrecondition(uniform_occupation, cp_failure_level, routineP,failure) NULLIFY(dbcsr_deriv) - CALL cp_dbcsr_init_p(dbcsr_deriv,error) - CALL cp_dbcsr_copy(dbcsr_deriv,mo_derivs(1)%matrix,error=error) - CALL cp_dbcsr_set(dbcsr_deriv,0.0_dp,error) + CALL cp_dbcsr_init_p(dbcsr_deriv) + CALL cp_dbcsr_copy(dbcsr_deriv,mo_derivs(1)%matrix) + CALL cp_dbcsr_set(dbcsr_deriv,0.0_dp) ! basic info CALL get_mo_set(mo_set=mo_array(1)%mo_set,mo_coeff_b=mo_coeff) @@ -212,25 +209,25 @@ SUBROUTINE low_spin_roks(energy,qs_env,dft_control,just_energy,& CALL cp_dbcsr_get_info(mo_coeff,nfullcols_total=k_beta) ! read the input - low_spin_roks_section => section_vals_get_subs_vals(input,"DFT%LOW_SPIN_ROKS", error=error) + low_spin_roks_section => section_vals_get_subs_vals(input,"DFT%LOW_SPIN_ROKS") - CALL section_vals_val_get(low_spin_roks_section,"ENERGY_SCALING",r_vals=rvec,error=error) + CALL section_vals_val_get(low_spin_roks_section,"ENERGY_SCALING",r_vals=rvec) Nterms=SIZE(rvec) ALLOCATE(energy_scaling(Nterms)) energy_scaling=rvec !? just wondering, should this add up to 1, in which case we should cpp? - CALL section_vals_val_get(low_spin_roks_section,"SPIN_CONFIGURATION",n_rep_val=n_rep,error=error) - CPPostcondition(n_rep==Nterms, cp_failure_level, routineP, error, failure) - CALL section_vals_val_get(low_spin_roks_section,"SPIN_CONFIGURATION",i_rep_val=1,i_vals=ivec,error=error) + CALL section_vals_val_get(low_spin_roks_section,"SPIN_CONFIGURATION",n_rep_val=n_rep) + CPPostcondition(n_rep==Nterms, cp_failure_level, routineP,failure) + CALL section_vals_val_get(low_spin_roks_section,"SPIN_CONFIGURATION",i_rep_val=1,i_vals=ivec) Nelectron=SIZE(ivec) - CPPostcondition(Nelectron==k_alpha-k_beta, cp_failure_level, routineP, error, failure) + CPPostcondition(Nelectron==k_alpha-k_beta, cp_failure_level, routineP,failure) ALLOCATE(occupations(2,Nelectron,Nterms)) occupations=0 DO iterm=1,Nterms - CALL section_vals_val_get(low_spin_roks_section,"SPIN_CONFIGURATION",i_rep_val=iterm,i_vals=ivec,error=error) - CPPostcondition(Nelectron==SIZE(ivec), cp_failure_level, routineP, error, failure) + CALL section_vals_val_get(low_spin_roks_section,"SPIN_CONFIGURATION",i_rep_val=iterm,i_vals=ivec) + CPPostcondition(Nelectron==SIZE(ivec), cp_failure_level, routineP,failure) in_range=ALL(ivec>=1) .AND. ALL(ivec<=2) - CPPostcondition(in_range, cp_failure_level, routineP, error, failure) + CPPostcondition(in_range, cp_failure_level, routineP,failure) DO k=1,Nelectron occupations(ivec(k),k,iterm)=1 ENDDO @@ -240,86 +237,86 @@ SUBROUTINE low_spin_roks(energy,qs_env,dft_control,just_energy,& ! density matrices, kohn-sham matrices NULLIFY(matrix_p) - CALL cp_dbcsr_allocate_matrix_set(matrix_p,Nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_p,Nspin) DO ispin=1,Nspin ALLOCATE(matrix_p(ispin)%matrix) - CALL cp_dbcsr_init(matrix_p(ispin)%matrix, error=error) + CALL cp_dbcsr_init(matrix_p(ispin)%matrix) CALL cp_dbcsr_copy(matrix_p(ispin)%matrix,rho_ao(1)%matrix,& - name="density matrix low spin roks",error=error) - CALL cp_dbcsr_set(matrix_p(ispin)%matrix,0.0_dp,error=error) + name="density matrix low spin roks") + CALL cp_dbcsr_set(matrix_p(ispin)%matrix,0.0_dp) ENDDO NULLIFY(matrix_h) - CALL cp_dbcsr_allocate_matrix_set(matrix_h,Nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_h,Nspin) DO ispin=1,Nspin ALLOCATE(matrix_h(ispin)%matrix) - CALL cp_dbcsr_init(matrix_h(ispin)%matrix, error=error) + CALL cp_dbcsr_init(matrix_h(ispin)%matrix) CALL cp_dbcsr_copy(matrix_h(ispin)%matrix,rho_ao(1)%matrix,& - name="KS matrix low spin roks",error=error) - CALL cp_dbcsr_set(matrix_h(ispin)%matrix,0.0_dp,error=error) + name="KS matrix low spin roks") + CALL cp_dbcsr_set(matrix_h(ispin)%matrix,0.0_dp) ENDDO ! grids in real and g space for rho and vxc ! tau functionals are not supported NULLIFY(tau,vxc_tau,vxc) - CALL pw_env_get(pw_env,xc_pw_pool=xc_pw_pool, error=error) + CALL pw_env_get(pw_env,xc_pw_pool=xc_pw_pool) ALLOCATE(rho_r(Nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rho_g(Nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,Nspin CALL pw_pool_create_pw(auxbas_pw_pool,rho_r(ispin)%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,rho_g(ispin)%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) ENDDO CALL pw_pool_create_pw(auxbas_pw_pool,work_v_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) ! get mo matrices needed to construct the density matrices ! we will base all on the alpha spin matrix, obviously possible in ROKS CALL get_mo_set(mo_set=mo_array(1)%mo_set,mo_coeff_b=mo_coeff) NULLIFY(fm_scaled, fm_deriv) - CALL cp_dbcsr_init_p(fm_scaled,error=error) - CALL cp_dbcsr_init_p(fm_deriv,error=error) - CALL cp_dbcsr_copy(fm_scaled,mo_coeff,error=error) - CALL cp_dbcsr_copy(fm_deriv,mo_coeff,error=error) + CALL cp_dbcsr_init_p(fm_scaled) + CALL cp_dbcsr_init_p(fm_deriv) + CALL cp_dbcsr_copy(fm_scaled,mo_coeff) + CALL cp_dbcsr_copy(fm_deriv,mo_coeff) ALLOCATE(scaling(k_alpha),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! for each term, add it with the given scaling factor to the energy, and compute the required derivatives DO iterm=1,Nterms DO ispin=1,Nspin ! compute the proper density matrices with the required occupations - CALL cp_dbcsr_set(matrix_p(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_p(ispin)%matrix,0.0_dp) scaling=1.0_dp scaling(k_alpha-Nelectron+1:k_alpha)=occupations(ispin,:,iterm) - CALL cp_dbcsr_copy(fm_scaled,mo_coeff,error=error) - CALL cp_dbcsr_scale_by_vector(fm_scaled,scaling,side='right',error=error) + CALL cp_dbcsr_copy(fm_scaled,mo_coeff) + CALL cp_dbcsr_scale_by_vector(fm_scaled,scaling,side='right') CALL cp_dbcsr_multiply('n','t',1.0_dp,mo_coeff,fm_scaled,& - 0.0_dp,matrix_p(ispin)%matrix, retain_sparsity=.TRUE.,error=error) + 0.0_dp,matrix_p(ispin)%matrix, retain_sparsity=.TRUE.) ! compute the densities on the grid CALL calculate_rho_elec(matrix_p=matrix_p(ispin)%matrix,& rho=rho_r(ispin),rho_gspace=rho_g(ispin), total_rho=total_rho,& - ks_env=ks_env, error=error) + ks_env=ks_env) ENDDO ! compute the exchange energies / potential if needed IF (just_energy) THEN exc=xc_exc_calc(rho_r=rho_r, rho_g=rho_g, tau=tau, xc_section=xc_section,& - pw_pool=xc_pw_pool, error=error) + pw_pool=xc_pw_pool) ELSE - CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,failure) CALL xc_vxc_pw_create1(vxc_rho=vxc, rho_r=rho_r,& rho_g=rho_g, tau=tau, vxc_tau=vxc_tau, exc=exc, xc_section=xc_section, & - pw_pool=xc_pw_pool, compute_virial=.FALSE., virial_xc=virial_xc_tmp, error=error) + pw_pool=xc_pw_pool, compute_virial=.FALSE., virial_xc=virial_xc_tmp) END IF energy%exc = energy%exc + energy_scaling(iterm) * exc @@ -332,22 +329,22 @@ SUBROUTINE low_spin_roks(energy,qs_env,dft_control,just_energy,& work_v_rspace%pw%cr3d = (energy_scaling(iterm) * vxc(ispin)%pw %pw_grid%dvol)* & vxc(ispin)%pw%cr3d ! zero first ?! - CALL cp_dbcsr_set(matrix_h(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(matrix_h(ispin)%matrix,0.0_dp) CALL integrate_v_rspace(v_rspace=work_v_rspace,pmat=matrix_p(ispin),hmat=matrix_h(ispin),& - qs_env=qs_env,calculate_forces=calculate_forces,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,vxc(ispin)%pw,error=error) + qs_env=qs_env,calculate_forces=calculate_forces) + CALL pw_pool_give_back_pw(auxbas_pw_pool,vxc(ispin)%pw) ENDDO DEALLOCATE(vxc) ! add this to the mo_derivs, again based on the alpha mo_coeff DO ispin=1,Nspin CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_h(ispin)%matrix,mo_coeff,& - 0.0_dp,dbcsr_deriv,last_column=k_alpha, error=error) + 0.0_dp,dbcsr_deriv,last_column=k_alpha) scaling=1.0_dp scaling(k_alpha-Nelectron+1:k_alpha)=occupations(ispin,:,iterm) - CALL cp_dbcsr_scale_by_vector(dbcsr_deriv,scaling,side='right',error=error) - CALL cp_dbcsr_add(mo_derivs(1)%matrix, dbcsr_deriv,1.0_dp,1.0_dp,error=error) + CALL cp_dbcsr_scale_by_vector(dbcsr_deriv,scaling,side='right') + CALL cp_dbcsr_add(mo_derivs(1)%matrix, dbcsr_deriv,1.0_dp,1.0_dp) ENDDO ENDIF @@ -356,23 +353,23 @@ SUBROUTINE low_spin_roks(energy,qs_env,dft_control,just_energy,& ! release allocated memory DO ispin=1,Nspin - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r(ispin)%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g(ispin)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_r(ispin)%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_g(ispin)%pw) ENDDO DEALLOCATE(rho_r,rho_g) - CALL cp_dbcsr_deallocate_matrix_set(matrix_p,error=error) - CALL cp_dbcsr_deallocate_matrix_set(matrix_h,error=error) + CALL cp_dbcsr_deallocate_matrix_set(matrix_p) + CALL cp_dbcsr_deallocate_matrix_set(matrix_h) - CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v_rspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v_rspace%pw) - CALL cp_dbcsr_release_p(fm_deriv,error=error) - CALL cp_dbcsr_release_p(fm_scaled,error=error) + CALL cp_dbcsr_release_p(fm_deriv) + CALL cp_dbcsr_release_p(fm_scaled) DEALLOCATE(occupations) DEALLOCATE(energy_scaling) DEALLOCATE(scaling) - CALL cp_dbcsr_release_p(dbcsr_deriv,error=error) + CALL cp_dbcsr_release_p(dbcsr_deriv) CALL timestop(handle) @@ -386,10 +383,9 @@ END SUBROUTINE low_spin_roks !> \param just_energy ... !> \param calculate_forces ... !> \param auxbas_pw_pool ... -!> \param error ... ! ***************************************************************************** SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_energy,& - calculate_forces,auxbas_pw_pool,error) + calculate_forces,auxbas_pw_pool) TYPE(qs_energy_type), POINTER :: energy TYPE(qs_environment_type), POINTER :: qs_env @@ -397,7 +393,6 @@ SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_ener TYPE(pw_poisson_type), POINTER :: poisson_env LOGICAL, INTENT(IN) :: just_energy, calculate_forces TYPE(pw_pool_type), POINTER :: auxbas_pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'sic_explicit_orbitals', & routineP = moduleN//':'//routineN @@ -449,39 +444,38 @@ SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_ener pw_env=pw_env, & input=input,& cell=cell,& - virial=virial,& - error=error) + virial=virial) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) compute_virial=virial%pv_calculate.AND.(.NOT.virial%pv_numer) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") DO i=1,SIZE(mo_array)!fm->dbcsr IF(mo_array(i)%mo_set%use_mo_coeff_b) THEN!fm->dbcsr CALL copy_dbcsr_to_fm(mo_array(i)%mo_set%mo_coeff_b,& - mo_array(i)%mo_set%mo_coeff,error=error)!fm->dbcsr + mo_array(i)%mo_set%mo_coeff)!fm->dbcsr ENDIF!fm->dbcsr ENDDO!fm->dbcsr - CALL pw_env_get(pw_env,xc_pw_pool=xc_pw_pool, error=error) + CALL pw_env_get(pw_env,xc_pw_pool=xc_pw_pool) ! we have two spins - CPPrecondition(SIZE(mo_array,1)==2,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(mo_array,1)==2,cp_failure_level,routineP,failure) ! we want uniform occupations CALL get_mo_set(mo_set=mo_array(1)%mo_set, uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation, cp_failure_level, routineP, error, failure) + CPPrecondition(uniform_occupation, cp_failure_level, routineP,failure) CALL get_mo_set(mo_set=mo_array(2)%mo_set,mo_coeff=mo_coeff, uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation, cp_failure_level, routineP, error, failure) + CPPrecondition(uniform_occupation, cp_failure_level, routineP,failure) NULLIFY (tmp_dbcsr) - CALL cp_dbcsr_allocate_matrix_set(tmp_dbcsr,SIZE(mo_derivs,1),error=error) + CALL cp_dbcsr_allocate_matrix_set(tmp_dbcsr,SIZE(mo_derivs,1)) DO i=1,SIZE(mo_derivs,1)!fm->dbcsr ! NULLIFY(tmp_dbcsr(i)%matrix) - CALL cp_dbcsr_init_p(tmp_dbcsr(i)%matrix,error) - CALL cp_dbcsr_copy(tmp_dbcsr(i)%matrix,mo_derivs(i)%matrix,error=error) - CALL cp_dbcsr_set(tmp_dbcsr(i)%matrix,0.0_dp,error) + CALL cp_dbcsr_init_p(tmp_dbcsr(i)%matrix) + CALL cp_dbcsr_copy(tmp_dbcsr(i)%matrix,mo_derivs(i)%matrix) + CALL cp_dbcsr_set(tmp_dbcsr(i)%matrix,0.0_dp) ENDDO!fm->dbcsr @@ -490,16 +484,16 @@ SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_ener CASE(sic_list_all) CALL get_mo_set(mo_set=mo_array(1)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=k_alpha,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=k_alpha) IF (SIZE(mo_array,1)>1) THEN CALL get_mo_set(mo_set=mo_array(2)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=k_beta,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=k_beta) ENDIF Norb=k_alpha + k_beta ALLOCATE(sic_orbital_list(3,Norb),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iorb=0 DO i=1,k_alpha @@ -521,20 +515,20 @@ SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_ener CASE(sic_list_unpaired) ! we have two spins - CPPrecondition(SIZE(mo_array,1)==2,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(mo_array,1)==2,cp_failure_level,routineP,failure) ! we have them restricted - CPPrecondition(SIZE(mo_derivs,1)==1,cp_failure_level,routineP,error,failure) - CPPrecondition(dft_control%restricted,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(mo_derivs,1)==1,cp_failure_level,routineP,failure) + CPPrecondition(dft_control%restricted,cp_failure_level,routineP,failure) CALL get_mo_set(mo_set=mo_array(1)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=k_alpha,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=k_alpha) CALL get_mo_set(mo_set=mo_array(2)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=k_beta,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=k_beta) Norb=k_alpha-k_beta ALLOCATE(sic_orbital_list(3,Norb),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iorb=0 DO i=k_beta+1,k_alpha @@ -546,79 +540,79 @@ SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_ener ENDDO CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! data needed for each of the orbs CALL pw_pool_create_pw(auxbas_pw_pool,orb_rho_r%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,tmp_r%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,orb_rho_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,tmp_g%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,work_v_gspace%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,work_v_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) ALLOCATE(orb_density_matrix) - CALL cp_dbcsr_init(orb_density_matrix, error=error) + CALL cp_dbcsr_init(orb_density_matrix) CALL cp_dbcsr_copy(orb_density_matrix,rho_ao(1)%matrix,& - name="orb_density_matrix",error=error) - CALL cp_dbcsr_set(orb_density_matrix,0.0_dp,error=error) + name="orb_density_matrix") + CALL cp_dbcsr_set(orb_density_matrix,0.0_dp) orb_density_matrix_p%matrix=>orb_density_matrix ALLOCATE(orb_h) - CALL cp_dbcsr_init(orb_h, error=error) + CALL cp_dbcsr_init(orb_h) CALL cp_dbcsr_copy(orb_h,rho_ao(1)%matrix,& - name="orb_density_matrix",error=error) - CALL cp_dbcsr_set(orb_h,0.0_dp,error=error) + name="orb_density_matrix") + CALL cp_dbcsr_set(orb_h,0.0_dp) orb_h_p%matrix=>orb_h CALL get_mo_set(mo_set=mo_array(1)%mo_set,mo_coeff=mo_coeff) CALL cp_fm_struct_create(fm_struct_tmp, ncol_global=1, & - template_fmstruct=mo_coeff%matrix_struct, error=error) - CALL cp_fm_create(matrix_v,fm_struct_tmp, name="matrix_v",error=error) - CALL cp_fm_create(matrix_hv,fm_struct_tmp, name="matrix_hv",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + template_fmstruct=mo_coeff%matrix_struct) + CALL cp_fm_create(matrix_v,fm_struct_tmp, name="matrix_v") + CALL cp_fm_create(matrix_hv,fm_struct_tmp, name="matrix_hv") + CALL cp_fm_struct_release(fm_struct_tmp) ALLOCATE(mo_derivs_local(SIZE(mo_array,1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,SIZE(mo_array,1) CALL get_mo_set(mo_set=mo_array(i)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_create(mo_derivs_local(I)%matrix,mo_coeff%matrix_struct,error=error) + CALL cp_fm_create(mo_derivs_local(I)%matrix,mo_coeff%matrix_struct) ENDDO ALLOCATE(rho_r(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rho_r(1)%pw=>orb_rho_r%pw rho_r(2)%pw=>tmp_r%pw - CALL pw_zero(tmp_r%pw, error=error) + CALL pw_zero(tmp_r%pw) ALLOCATE(rho_g(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rho_g(1)%pw=>orb_rho_g%pw rho_g(2)%pw=>tmp_g%pw - CALL pw_zero(tmp_g%pw, error=error) + CALL pw_zero(tmp_g%pw) NULLIFY(vxc) ! ALLOCATE(vxc(2),stat=stat) - ! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + ! CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! CALL pw_pool_create_pw(xc_pw_pool,vxc(1)%pw,& - ! in_space=REALSPACE, use_data=REALDATA3D,error=error) + ! in_space=REALSPACE, use_data=REALDATA3D) ! CALL pw_pool_create_pw(xc_pw_pool,vxc(2)%pw,& - ! in_space=REALSPACE, use_data=REALDATA3D,error=error) + ! in_space=REALSPACE, use_data=REALDATA3D) ! now apply to SIC correction to each selected orbital DO iorb=1,Norb @@ -627,36 +621,35 @@ SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_ener CALL cp_fm_to_fm(mo_coeff,matrix_v,1,sic_orbital_list(2,iorb),1) ! construct the density matrix and the corresponding density - CALL cp_dbcsr_set(orb_density_matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(orb_density_matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(orb_density_matrix,matrix_v=matrix_v,ncol=1,& - alpha=1.0_dp,error=error) + alpha=1.0_dp) CALL calculate_rho_elec(matrix_p=orb_density_matrix,& rho=orb_rho_r,rho_gspace=orb_rho_g, total_rho=total_rho,& - ks_env=ks_env, error=error) + ks_env=ks_env) ! write(*,*) 'Orbital ',sic_orbital_list(1,iorb),sic_orbital_list(2,iorb) ! write(*,*) 'Total orbital rho= ',total_rho ! compute the energy functional for this orbital and its derivative - CALL pw_poisson_solve(poisson_env,orb_rho_g%pw, ener, work_v_gspace%pw,error=error) + CALL pw_poisson_solve(poisson_env,orb_rho_g%pw, ener, work_v_gspace%pw) energy%hartree=energy%hartree - dft_control%sic_scaling_a * ener IF (.NOT. just_energy) THEN - CALL pw_transfer(work_v_gspace%pw, work_v_rspace%pw, error=error) - CALL pw_scale(work_v_rspace%pw, - dft_control%sic_scaling_a * work_v_rspace%pw%pw_grid%dvol,& - error=error) - CALL cp_dbcsr_set(orb_h,0.0_dp,error=error) + CALL pw_transfer(work_v_gspace%pw, work_v_rspace%pw) + CALL pw_scale(work_v_rspace%pw, - dft_control%sic_scaling_a * work_v_rspace%pw%pw_grid%dvol) + CALL cp_dbcsr_set(orb_h,0.0_dp) ENDIF IF (just_energy) THEN exc=xc_exc_calc(rho_r=rho_r, rho_g=rho_g, tau=tau, xc_section=xc_section,& - pw_pool=xc_pw_pool, error=error) + pw_pool=xc_pw_pool) ELSE - CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,failure) CALL xc_vxc_pw_create1(vxc_rho=vxc, rho_r=rho_r,& rho_g=rho_g, tau=tau, vxc_tau=vxc_tau, exc=exc, xc_section=xc_section, & - pw_pool=xc_pw_pool, compute_virial=compute_virial, virial_xc=virial_xc_tmp, error=error) + pw_pool=xc_pw_pool, compute_virial=compute_virial, virial_xc=virial_xc_tmp) ! add to the existing work_v_rspace work_v_rspace%pw%cr3d = work_v_rspace%pw%cr3d - & dft_control%sic_scaling_b * vxc(1)%pw %pw_grid%dvol * vxc(1)%pw%cr3d @@ -666,46 +659,46 @@ SUBROUTINE sic_explicit_orbitals(energy,qs_env,dft_control,poisson_env,just_ener IF (.NOT. just_energy) THEN ! note, orb_h (which is being pointed to with orb_h_p) is zeroed above CALL integrate_v_rspace(v_rspace=work_v_rspace,pmat=orb_density_matrix_p,hmat=orb_h_p,& - qs_env=qs_env,calculate_forces=calculate_forces,error=error) + qs_env=qs_env,calculate_forces=calculate_forces) ! add this to the mo_derivs - CALL cp_dbcsr_sm_fm_multiply(orb_h,matrix_v,matrix_hv, 1, error=error) + CALL cp_dbcsr_sm_fm_multiply(orb_h,matrix_v,matrix_hv, 1) ! silly trick, copy to an array of the right size and add to mo_derivs - CALL cp_fm_set_all(mo_derivs_local(sic_orbital_list(3,iorb))%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(mo_derivs_local(sic_orbital_list(3,iorb))%matrix,0.0_dp) CALL cp_fm_to_fm(matrix_hv,mo_derivs_local(sic_orbital_list(3,iorb))%matrix,1,1,sic_orbital_list(2,iorb)) CALL copy_fm_to_dbcsr(mo_derivs_local(sic_orbital_list(3,iorb))%matrix,& - tmp_dbcsr(sic_orbital_list(3,iorb))%matrix,error=error) + tmp_dbcsr(sic_orbital_list(3,iorb))%matrix) CALL cp_dbcsr_add(mo_derivs(sic_orbital_list(3,iorb))%matrix, & - tmp_dbcsr(sic_orbital_list(3,iorb))%matrix,1.0_dp,1.0_dp,error=error) + tmp_dbcsr(sic_orbital_list(3,iorb))%matrix,1.0_dp,1.0_dp) ! ! need to deallocate vxc - CALL pw_pool_give_back_pw(xc_pw_pool,vxc(1)%pw,error=error) - CALL pw_pool_give_back_pw(xc_pw_pool,vxc(2)%pw,error=error) + CALL pw_pool_give_back_pw(xc_pw_pool,vxc(1)%pw) + CALL pw_pool_give_back_pw(xc_pw_pool,vxc(2)%pw) DEALLOCATE(vxc) ENDIF ENDDO - CALL pw_pool_give_back_pw(auxbas_pw_pool,orb_rho_r%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_r%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,orb_rho_g%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v_gspace%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v_rspace%pw,error=error) - - CALL cp_dbcsr_deallocate_matrix(orb_density_matrix,error=error) - CALL cp_dbcsr_deallocate_matrix(orb_h,error=error) - CALL cp_fm_release(matrix_v,error) - CALL cp_fm_release(matrix_hv,error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,orb_rho_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,orb_rho_g%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v_gspace%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v_rspace%pw) + + CALL cp_dbcsr_deallocate_matrix(orb_density_matrix) + CALL cp_dbcsr_deallocate_matrix(orb_h) + CALL cp_fm_release(matrix_v) + CALL cp_fm_release(matrix_hv) DO I=1,SIZE(mo_derivs_local,1) - CALL cp_fm_release(mo_derivs_local(I)%matrix,error=error) + CALL cp_fm_release(mo_derivs_local(I)%matrix) ENDDO DEALLOCATE(mo_derivs_local) DEALLOCATE(rho_r) DEALLOCATE(rho_g) - CALL cp_dbcsr_deallocate_matrix_set(tmp_dbcsr,error=error)!fm->dbcsr + CALL cp_dbcsr_deallocate_matrix_set(tmp_dbcsr)!fm->dbcsr CALL timestop(handle) @@ -722,11 +715,10 @@ END SUBROUTINE sic_explicit_orbitals !> \param just_energy ... !> \param calculate_forces ... !> \param auxbas_pw_pool ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_v_sic_rspace(v_sic_rspace,energy,& qs_env,dft_control,rho,poisson_env,just_energy,& - calculate_forces,auxbas_pw_pool,error) + calculate_forces,auxbas_pw_pool) TYPE(pw_p_type), INTENT(INOUT) :: v_sic_rspace TYPE(qs_energy_type), POINTER :: energy @@ -736,7 +728,6 @@ SUBROUTINE calc_v_sic_rspace(v_sic_rspace,energy,& TYPE(pw_poisson_type), POINTER :: poisson_env LOGICAL, INTENT(IN) :: just_energy, calculate_forces TYPE(pw_pool_type), POINTER :: auxbas_pw_pool - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'calc_v_sic_rspace', & routineP = moduleN//':'//routineN @@ -761,46 +752,46 @@ SUBROUTINE calc_v_sic_rspace(v_sic_rspace,energy,& IF (dft_control%sic_method_id == sic_eo) RETURN CALL cp_assert(.NOT. dft_control%qs_control%gapw, cp_failure_level,cp_assertion_failed,routineP,& - "sic and GAPW not yet compatible",error,failure) + "sic and GAPW not yet compatible",failure) ! OK, right now we like two spins to do sic, could be relaxed for AD - CPPrecondition(dft_control%nspins == 2,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%nspins == 2,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(auxbas_pw_pool, work_rho%pw, & use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool, work_v%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL qs_rho_get(rho, rho_g=rho_g) ! Hartree sic corrections SELECT CASE ( dft_control%sic_method_id ) CASE ( sic_mauri_us, sic_mauri_spz ) - CALL pw_copy(rho_g(1)%pw,work_rho%pw, error=error) - CALL pw_axpy(rho_g(2)%pw,work_rho%pw,alpha=-1._dp, error=error) - CALL pw_poisson_solve(poisson_env,work_rho%pw, ener, work_v%pw,error=error) + CALL pw_copy(rho_g(1)%pw,work_rho%pw) + CALL pw_axpy(rho_g(2)%pw,work_rho%pw,alpha=-1._dp) + CALL pw_poisson_solve(poisson_env,work_rho%pw, ener, work_v%pw) CASE ( sic_ad ) ! find out how many elecs we have - CALL get_qs_env(qs_env,mos=mo_array,error=error) + CALL get_qs_env(qs_env,mos=mo_array) CALL get_mo_set(mo_set=mo_array(1)%mo_set,nelectron=nelec_a) CALL get_mo_set(mo_set=mo_array(2)%mo_set,nelectron=nelec_b) nelec = nelec_a + nelec_b - CALL pw_copy(rho_g(1)%pw,work_rho%pw, error=error) - CALL pw_axpy(rho_g(2)%pw,work_rho%pw, error=error) + CALL pw_copy(rho_g(1)%pw,work_rho%pw) + CALL pw_axpy(rho_g(2)%pw,work_rho%pw) scaling = 1.0_dp / REAL(nelec,KIND=dp) - CALL pw_scale(work_rho%pw,scaling, error=error) - CALL pw_poisson_solve(poisson_env,work_rho%pw, ener, work_v%pw,error=error) + CALL pw_scale(work_rho%pw,scaling) + CALL pw_poisson_solve(poisson_env,work_rho%pw, ener, work_v%pw) CASE DEFAULT CALL cp_assert( .FALSE., cp_failure_level,cp_assertion_failed,routineP,& - "Unknown sic method id",error,failure) + "Unknown sic method id",failure) END SELECT ! Correct for DDAP charges (if any) ! storing whatever force might be there from previous decoupling IF (calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,force=force) nforce=0 DO i=1,SIZE(force) nforce=nforce+SIZE(force(i)%ch_pulay,2) @@ -819,8 +810,7 @@ SUBROUTINE calc_v_sic_rspace(v_sic_rspace,energy,& ener,& v_hartree_gspace=work_v,& calculate_forces=calculate_forces,& - Itype_of_density="SPIN",& - error=error) + Itype_of_density="SPIN") SELECT CASE ( dft_control%sic_method_id ) CASE ( sic_mauri_us, sic_mauri_spz ) @@ -829,7 +819,7 @@ SUBROUTINE calc_v_sic_rspace(v_sic_rspace,energy,& full_scaling= - dft_control%sic_scaling_a * nelec CASE DEFAULT CALL cp_assert( .FALSE., cp_failure_level,cp_assertion_failed,routineP,& - "Unknown sic method id",error,failure) + "Unknown sic method id",failure) END SELECT energy%hartree=energy%hartree + full_scaling * ener @@ -844,15 +834,15 @@ SUBROUTINE calc_v_sic_rspace(v_sic_rspace,energy,& IF (.NOT. just_energy) THEN CALL pw_pool_create_pw(auxbas_pw_pool,v_sic_rspace%pw,& - use_data=REALDATA3D, in_space=REALSPACE,error=error) - CALL pw_transfer(work_v%pw, v_sic_rspace%pw, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_transfer(work_v%pw, v_sic_rspace%pw) ! also take into account the scaling (in addition to the volume element) CALL pw_scale(v_sic_rspace%pw, & - dft_control%sic_scaling_a * v_sic_rspace%pw%pw_grid%dvol, error=error ) + dft_control%sic_scaling_a * v_sic_rspace%pw%pw_grid%dvol) ENDIF - CALL pw_pool_give_back_pw(auxbas_pw_pool,work_rho%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,work_rho%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,work_v%pw) END SUBROUTINE calc_v_sic_rspace @@ -860,12 +850,10 @@ END SUBROUTINE calc_v_sic_rspace !> \brief ... !> \param qs_env ... !> \param rho ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE print_densities(qs_env, rho, error) + SUBROUTINE print_densities(qs_env, rho) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_rho_type), POINTER :: rho - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: img, ispin, n_electrons, & output_unit @@ -885,31 +873,30 @@ SUBROUTINE print_densities(qs_env, rho, error) NULLIFY(qs_charges, qs_kind_set, cell, input, logger, scf_section, matrix_s,& dft_control,tot_rho_r_arr, rho_ao) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env,& qs_kind_set=qs_kind_set, & cell=cell,qs_charges=qs_charges,& input=input,& matrix_s_kp=matrix_s,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CALL get_qs_kind_set(qs_kind_set, nelectron=n_electrons, error=error) + CALL get_qs_kind_set(qs_kind_set, nelectron=n_electrons) - scf_section => section_vals_get_subs_vals(input,"DFT%SCF",error=error) + scf_section => section_vals_get_subs_vals(input,"DFT%SCF") output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%TOTAL_DENSITIES",& - extension=".scfLog",error=error) + extension=".scfLog") - CALL qs_rho_get(rho, tot_rho_r=tot_rho_r_arr, rho_ao_kp=rho_ao, error=error) + CALL qs_rho_get(rho, tot_rho_r=tot_rho_r_arr, rho_ao_kp=rho_ao) n_electrons = n_electrons - dft_control%charge tot_rho_r = accurate_sum(tot_rho_r_arr) trace=0 - IF(BTEST(cp_print_key_should_output(logger%iter_info,scf_section,"PRINT%TOTAL_DENSITIES",error=error),cp_p_file)) THEN + IF(BTEST(cp_print_key_should_output(logger%iter_info,scf_section,"PRINT%TOTAL_DENSITIES"),cp_p_file)) THEN DO ispin=1,dft_control%nspins DO img=1,dft_control%nimages - CALL cp_dbcsr_trace(rho_ao(ispin,img)%matrix,matrix_s(1,img)%matrix,trace_tmp,error=error) + CALL cp_dbcsr_trace(rho_ao(ispin,img)%matrix,matrix_s(1,img)%matrix,trace_tmp) trace=trace+trace_tmp END DO END DO @@ -981,7 +968,7 @@ SUBROUTINE print_densities(qs_env, rho, error) qs_charges%background=qs_charges%background/cell%deth CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%TOTAL_DENSITIES", error=error) + "PRINT%TOTAL_DENSITIES") END SUBROUTINE print_densities @@ -993,19 +980,17 @@ END SUBROUTINE print_densities !> \param input ... !> \param energy ... !> \param mulliken_order_p ... -!> \param error ... !> \par History !> refactoring 04.03.2011 [MI] !> \author ! ***************************************************************************** - SUBROUTINE print_detailed_energy(qs_env,dft_control,input,energy,mulliken_order_p,error) + SUBROUTINE print_detailed_energy(qs_env,dft_control,input,energy,mulliken_order_p) TYPE(qs_environment_type), POINTER :: qs_env TYPE(dft_control_type), POINTER :: dft_control TYPE(section_vals_type), POINTER :: input TYPE(qs_energy_type), POINTER :: energy REAL(KIND=dp), INTENT(IN) :: mulliken_order_p - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_detailed_energy', & routineP = moduleN//':'//routineN @@ -1014,10 +999,10 @@ SUBROUTINE print_detailed_energy(qs_env,dft_control,input,energy,mulliken_order_ REAL(KIND=dp) :: ddapc_order_p, s2_order_p TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,input,"DFT%SCF%PRINT%DETAILED_ENERGY",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit>0) THEN IF (dft_control%do_admm) THEN WRITE (UNIT=output_unit,FMT="((T3,A,T60,F20.10))")& @@ -1103,7 +1088,7 @@ SUBROUTINE print_detailed_energy(qs_env,dft_control,input,energy,mulliken_order_ END IF ! output_unit CALL cp_print_key_finished_output(output_unit,logger,input,& - "DFT%SCF%PRINT%DETAILED_ENERGY", error=error) + "DFT%SCF%PRINT%DETAILED_ENERGY") END SUBROUTINE print_detailed_energy @@ -1114,17 +1099,15 @@ END SUBROUTINE print_detailed_energy !> \param qs_env ... !> \param v_rspace ... !> \param matrix_vxc ... -!> \param error ... !> \par History !> created 23.10.2012 [Joost VandeVondele] !> \author ! ***************************************************************************** - SUBROUTINE compute_matrix_vxc(qs_env,v_rspace, matrix_vxc, error) + SUBROUTINE compute_matrix_vxc(qs_env,v_rspace, matrix_vxc) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type), DIMENSION(:), POINTER :: v_rspace TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_vxc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_matrix_vxc', & routineP = moduleN//':'//routineN @@ -1139,29 +1122,29 @@ SUBROUTINE compute_matrix_vxc(qs_env,v_rspace, matrix_vxc, error) ! create the matrix using matrix_ks as a template IF (ASSOCIATED(matrix_vxc)) THEN - CALL cp_dbcsr_deallocate_matrix_set(matrix_vxc,error) + CALL cp_dbcsr_deallocate_matrix_set(matrix_vxc) ENDIF - CALL get_qs_env(qs_env,matrix_ks=matrix_ks,error=error) + CALL get_qs_env(qs_env,matrix_ks=matrix_ks) ALLOCATE(matrix_vxc(SIZE(matrix_ks))) DO ispin=1,SIZE(matrix_ks) NULLIFY(matrix_vxc(ispin)%matrix) - CALL cp_dbcsr_init_p(matrix_vxc(ispin)%matrix,error=error) + CALL cp_dbcsr_init_p(matrix_vxc(ispin)%matrix) CALL cp_dbcsr_copy(matrix_vxc(ispin)%matrix,matrix_ks(ispin)%matrix,& - name="Matrix VXC of spin "//cp_to_string(ispin),error=error) - CALL cp_dbcsr_set(matrix_vxc(ispin)%matrix,0.0_dp,error=error) + name="Matrix VXC of spin "//cp_to_string(ispin)) + CALL cp_dbcsr_set(matrix_vxc(ispin)%matrix,0.0_dp) ENDDO ! and integrate - CALL get_qs_env(qs_env,dft_control=dft_control,error=error) + CALL get_qs_env(qs_env,dft_control=dft_control) gapw=dft_control%qs_control%gapw .OR. dft_control%qs_control%gapw_xc DO ispin=1,SIZE(matrix_ks) CALL integrate_v_rspace(v_rspace=v_rspace(ispin),& hmat=matrix_vxc(ispin), & qs_env=qs_env, & calculate_forces=.FALSE.,& - gapw=gapw,error=error) + gapw=gapw) ! scale by the volume element... should really become part of integrate_v_rspace - CALL cp_dbcsr_scale(matrix_vxc(ispin)%matrix,v_rspace(ispin)%pw%pw_grid%dvol,error=error) + CALL cp_dbcsr_scale(matrix_vxc(ispin)%matrix,v_rspace(ispin)%pw%pw_grid%dvol) ENDDO CALL timestop(handle) @@ -1186,7 +1169,6 @@ END SUBROUTINE compute_matrix_vxc !> \param v_sccs_rspace ... !> \param becke ... !> \param calculate_forces ... -!> \param error ... !> \par History !> - refactoring 04.03.2011 [MI] !> - SCCS implementation (16.10.2013,MK) @@ -1197,7 +1179,7 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& v_rspace_new_aux_fit,v_tau_rspace,& v_tau_rspace_aux_fit,v_efield_rspace,& v_sic_rspace,v_spin_ddapc_rest_r,& - v_sccs_rspace,becke,calculate_forces,error) + v_sccs_rspace,becke,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -1216,7 +1198,6 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& v_sccs_rspace TYPE(becke_restraint_type), POINTER :: becke LOGICAL, INTENT(in) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sum_up_and_integrate', & routineP = moduleN//':'//routineN @@ -1252,12 +1233,11 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& matrix_ks_aux_fit_dft=matrix_ks_aux_fit_dft,& v_hartree_rspace=v_rspace%pw,& rho_aux_fit=rho_aux_fit,& - vee=vee,& - error=error) + vee=vee) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) - CALL qs_rho_get(rho_aux_fit, rho_ao=rho_ao_aux, error=error) - CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) + CALL qs_rho_get(rho_aux_fit, rho_ao=rho_ao_aux) + CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool) gapw=dft_control%qs_control%gapw gapw_xc=dft_control%qs_control%gapw_xc do_ppl = dft_control%qs_control%do_ppl_method == do_ppl_grid @@ -1269,7 +1249,7 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& DO ispin=1,nspins IF (gapw_xc) THEN ! SIC not implemented (or at least not tested) - CPPrecondition(dft_control%sic_method_id==sic_none,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%sic_method_id==sic_none,cp_failure_level,routineP,failure) !Only the xc potential, because it has to be integrated with the soft basis v_rspace_new(ispin)%pw%cr3d =& v_rspace_new(ispin)%pw%pw_grid%dvol * & @@ -1282,7 +1262,7 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& pmat_kp=rho_ao,hmat_kp=ksmat,& qs_env=qs_env, & calculate_forces=calculate_forces,& - gapw=gapw_xc,error=error) + gapw=gapw_xc) ! Now the Hartree potential to be integrated with the full basis v_rspace_new(ispin)%pw%cr3d = v_rspace%pw%cr3d @@ -1331,11 +1311,10 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& ! External electrostatic potential IF (dft_control%apply_external_potential) THEN CALL qmmm_modify_hartree_pot(v_hartree=v_rspace_new(ispin),& - v_qmmm=vee,scale=-1.0_dp,& - error=error) + v_qmmm=vee,scale=-1.0_dp) END IF IF (do_ppl) THEN - CPPrecondition(.NOT.gapw,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.gapw,cp_failure_level,routineP,failure) v_rspace_new(ispin)%pw%cr3d = v_rspace_new(ispin)%pw%cr3d + & vppl_rspace%pw%cr3d*vppl_rspace%pw%pw_grid%dvol END IF @@ -1362,22 +1341,22 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& pmat_kp=rho_ao,hmat_kp=ksmat,& qs_env=qs_env, & calculate_forces=calculate_forces,& - gapw=gapw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw,error=error) + gapw=gapw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw) END DO ! ispin SELECT CASE (dft_control%sic_method_id) CASE (sic_none) CASE (sic_mauri_us,sic_mauri_spz, sic_ad ) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_sic_rspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_sic_rspace%pw) END SELECT DEALLOCATE(v_rspace_new,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE ! not implemented (or at least not tested) - CPPrecondition(dft_control%sic_method_id==sic_none,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.dft_control%qs_control%ddapc_restraint_is_spin,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%sic_method_id==sic_none,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.dft_control%qs_control%ddapc_restraint_is_spin,cp_failure_level,routineP,failure) DO ispin=1,nspins ! the efield contribution IF (dft_control%apply_efield_field) THEN @@ -1399,8 +1378,7 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& hmat_kp=ksmat,& qs_env=qs_env,& calculate_forces=calculate_forces,& - gapw=gapw,& - error=error) + gapw=gapw) END DO END IF ! ASSOCIATED(v_rspace_new) @@ -1416,13 +1394,11 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& pmat_kp=rho_ao,hmat_kp=ksmat,& qs_env=qs_env,& calculate_forces=calculate_forces,compute_tau=.TRUE., & - gapw=gapw,& - error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_tau_rspace(ispin)%pw,& - error=error) + gapw=gapw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_tau_rspace(ispin)%pw) END DO DEALLOCATE(v_tau_rspace, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ! Add contributions from ADMM if requested @@ -1436,7 +1412,7 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& ! set matrix_ks_aux_fit_dft = matrix_ks_aux_fit(k_HF) CALL cp_dbcsr_copy(matrix_ks_aux_fit_dft(ispin)%matrix, matrix_ks_aux_fit(ispin)%matrix, & - name="DFT exch. part of matrix_ks_aux_fit", error=error) + name="DFT exch. part of matrix_ks_aux_fit") ! Add potential to ks_matrix aux_fit @@ -1449,27 +1425,24 @@ SUBROUTINE sum_up_and_integrate(qs_env,ks_matrix,rho,my_rho,& force_adm=.TRUE.,& ispin=ispin, & gapw=gapw_xc,& - basis_type="AUX_FIT",& - error=error) + basis_type="AUX_FIT") ! matrix_ks_aux_fit_dft(x_DFT)=matrix_ks_aux_fit_dft(old,k_HF)-matrix_ks_aux_fit(k_HF-x_DFT) CALL cp_dbcsr_add(matrix_ks_aux_fit_dft(ispin)%matrix, & - matrix_ks_aux_fit(ispin)%matrix, 1.0_dp,-1.0_dp, error) + matrix_ks_aux_fit(ispin)%matrix, 1.0_dp,-1.0_dp) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new_aux_fit(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new_aux_fit(ispin)%pw) END DO DEALLOCATE(v_rspace_new_aux_fit,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ! Clean up v_tau_rspace_aux_fit, which is actually not needed IF( ASSOCIATED(v_tau_rspace_aux_fit)) THEN DO ispin=1,nspins - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_tau_rspace_aux_fit(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_tau_rspace_aux_fit(ispin)%pw) END DO DEALLOCATE(v_tau_rspace_aux_fit, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -1488,16 +1461,14 @@ END SUBROUTINE sum_up_and_integrate !> \param v_rspace_new ... !> \param rho ... !> \param exc ... -!> \param error ... !> \author D. Varsano [daniele.varsano@nano.cnr.it] ! ***************************************************************************** - SUBROUTINE calculate_zmp_potential(qs_env, v_rspace_new, rho, exc, error) + SUBROUTINE calculate_zmp_potential(qs_env, v_rspace_new, rho, exc) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type), DIMENSION(:), POINTER :: v_rspace_new TYPE(qs_rho_type), POINTER :: rho REAL(KIND=dp) :: exc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(*), PARAMETER :: routineN = 'calculate_zmp_potential', & routineP = moduleN//':'//routineN @@ -1535,25 +1506,24 @@ SUBROUTINE calculate_zmp_potential(qs_env, v_rspace_new, rho, exc, error) rho=rho,& input=input,& nelectron_spin=nelectron_spin,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) CALL pw_env_get(pw_env=pw_env,& auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env,error=error) - CALL qs_rho_get(rho, rho_r=rho_r, rho_g=rho_g, error=error) + poisson_env=poisson_env) + CALL qs_rho_get(rho, rho_r=rho_r, rho_g=rho_g) nspins = 1 ALLOCATE(v_rspace_new(nspins),stat=stat) CALL pw_pool_create_pw(pool=auxbas_pw_pool,pw=v_rspace_new(1)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + use_data=REALDATA3D,in_space=REALSPACE) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(pool=auxbas_pw_pool,pw=v_xc_rspace%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + use_data=REALDATA3D,in_space=REALSPACE) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL pw_zero(v_rspace_new(1)%pw, error=error) + CALL pw_zero(v_rspace_new(1)%pw) do_zmp_read=dft_control%apply_external_vxc IF (do_zmp_read) THEN - CALL pw_copy(qs_env%external_vxc%pw,v_rspace_new(1)%pw, error=error) + CALL pw_copy(qs_env%external_vxc%pw,v_rspace_new(1)%pw) exc = 0.0_dp exc = accurate_sum(v_rspace_new(1)%pw%cr3d*rho_r(1)%pw%cr3d)*& v_rspace_new(1)%pw%pw_grid%dvol @@ -1561,40 +1531,36 @@ SUBROUTINE calculate_zmp_potential(qs_env, v_rspace_new, rho, exc, error) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=rho_eff_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=v_xc_gspace%pw, & use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(rho_eff_gspace%pw, error=error) - CALL pw_zero(v_xc_gspace%pw, error=error) - CALL pw_zero(v_xc_rspace%pw,error=error) - factor=pw_integrate_function(rho_g(1)%pw,error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero(rho_eff_gspace%pw) + CALL pw_zero(v_xc_gspace%pw) + CALL pw_zero(v_xc_rspace%pw) + factor=pw_integrate_function(rho_g(1)%pw) CALL qs_rho_get(qs_env%rho_external,& rho_g=rho_ext_g,& - tot_rho_r=tot_rho_ext_r,& - error=error) + tot_rho_r=tot_rho_ext_r) factor=tot_rho_ext_r(1)/factor - CALL pw_axpy(rho_g(1)%pw,rho_eff_gspace%pw,alpha=factor,error=error) - CALL pw_axpy(rho_ext_g(1)%pw,rho_eff_gspace%pw,alpha=-1.0_dp,error=error) - total_rho = pw_integrate_function(rho_eff_gspace%pw,isign=1,error=error) - ext_den_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_DENSITY",error=error) - CALL section_vals_val_get(ext_den_section,"LAMBDA",r_val=lambda, error=error) - CALL section_vals_val_get(ext_den_section,"ZMP_CONSTRAINT",i_val=my_val,error=error) - CALL section_vals_val_get(ext_den_section,"FERMI_AMALDI",l_val=fermi_amaldi,error=error) + CALL pw_axpy(rho_g(1)%pw,rho_eff_gspace%pw,alpha=factor) + CALL pw_axpy(rho_ext_g(1)%pw,rho_eff_gspace%pw,alpha=-1.0_dp) + total_rho = pw_integrate_function(rho_eff_gspace%pw,isign=1) + ext_den_section => section_vals_get_subs_vals(input,"DFT%EXTERNAL_DENSITY") + CALL section_vals_val_get(ext_den_section,"LAMBDA",r_val=lambda) + CALL section_vals_val_get(ext_den_section,"ZMP_CONSTRAINT",i_val=my_val) + CALL section_vals_val_get(ext_den_section,"FERMI_AMALDI",l_val=fermi_amaldi) - CALL pw_scale( rho_eff_gspace%pw, a=lambda , error=error) + CALL pw_scale( rho_eff_gspace%pw, a=lambda) nelectron=nelectron_spin(1) factor = -1.0_dp/nelectron - CALL pw_axpy(rho_g(1)%pw,rho_eff_gspace%pw, alpha=factor,error=error) + CALL pw_axpy(rho_g(1)%pw,rho_eff_gspace%pw, alpha=factor) - CALL pw_poisson_solve(poisson_env,rho_eff_gspace%pw,vhartree=v_xc_gspace%pw,& - error=error) - CALL pw_transfer(v_xc_gspace%pw, v_rspace_new(1)%pw, error=error) - CALL pw_copy(v_rspace_new(1)%pw,v_xc_rspace%pw, error=error) + CALL pw_poisson_solve(poisson_env,rho_eff_gspace%pw,vhartree=v_xc_gspace%pw) + CALL pw_transfer(v_xc_gspace%pw, v_rspace_new(1)%pw) + CALL pw_copy(v_rspace_new(1)%pw,v_xc_rspace%pw) exc = 0.0_dp exc = accurate_sum(v_rspace_new(1)%pw%cr3d*rho_r(1)%pw%cr3d)*& @@ -1609,15 +1575,12 @@ SUBROUTINE calculate_zmp_potential(qs_env, v_rspace_new, rho, exc, error) !Vxc---> v_rspace_new !Exc---> energy%exc CALL pw_pool_give_back_pw(auxbas_pw_pool,& - rho_eff_gspace%pw,& - error=error) + rho_eff_gspace%pw) CALL pw_pool_give_back_pw(auxbas_pw_pool,& - v_xc_gspace%pw, & - error=error) + v_xc_gspace%pw) ENDIF - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_xc_rspace%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_xc_rspace%pw) CALL timestop(handle) diff --git a/src/qs_linres_atom_current.F b/src/qs_linres_atom_current.F index ed6aa262f6..14674f803f 100644 --- a/src/qs_linres_atom_current.F +++ b/src/qs_linres_atom_current.F @@ -92,14 +92,13 @@ MODULE qs_linres_atom_current !> \param mat_jp_riii ... !> \param iB ... !> \param idir ... -!> \param error ... !> \par History !> 07.2006 created [MI] !> 02.2009 using new setup of projector-basis overlap [jgh] !> \author MI ! ***************************************************************************** SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii,& - mat_jp_riii,iB,idir,error) + mat_jp_riii,iB,idir) ! TYPE(qs_environment_type), POINTER :: qs_env TYPE(current_env_type) :: current_env @@ -107,7 +106,6 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii POINTER :: mat_d0, mat_jp, mat_jp_rii, & mat_jp_riii INTEGER, INTENT(IN) :: iB, idir - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_jrho_atom_coeff', & routineP = moduleN//':'//routineN @@ -167,21 +165,19 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii dft_control=dft_control,& oce=oce,& sab_all=sab_all,& - para_env=para_env,& - error=error) + para_env=para_env) ! - CPPrecondition(ASSOCIATED(oce),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(oce),cp_failure_level,routineP,failure) ! CALL get_current_env(current_env=current_env,& - jrho1_atom_set=jrho1_atom_set,& - error=error) + jrho1_atom_set=jrho1_atom_set) ! - CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,failure) ! CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxsgf=max_nsgf,& - maxgtops=max_gau, error=error) + maxgtops=max_gau) eps_cpc = dft_control%qs_control%gapw_control%eps_cpc @@ -209,7 +205,7 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii a_block(nspins),b_block(nspins),c_block(nspins),d_block(nspins),& jp_RARnu(nspins),jp2_RARnu(nspins),PC1(max_nsgf*max_gau),& CPC(max_gau*max_gau),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! ! Reset CJC coefficients and local density arrays DO ikind = 1 ,nkind @@ -217,7 +213,7 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii CALL get_atomic_kind(atomic_kind_set(ikind),& atom_list=atom_list,& natom=nat) - CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom, error=error) + CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom) ! ! Quick cycle if needed. IF(.NOT. paw_atom) CYCLE @@ -242,9 +238,9 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii ! ! Three centers ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -265,7 +261,7 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii NULLIFY(jp_RARnu(ispin)%r_coef,jp2_RARnu(ispin)%r_coef) ALLOCATE(jp_RARnu(ispin)%r_coef(nsgfa,nsgfb),& jp2_RARnu(ispin)%r_coef(nsgfa,nsgfb),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDDO ! Take the block \mu\nu of jpab, jpab_ii and jpab_iii @@ -300,7 +296,7 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii basis_set=orb_basis_set,& hard_radius=hard_radius_c,& paw_proj_set=paw_proj,& - paw_atom=paw_atom, error=error) + paw_atom=paw_atom) ! ! Quick cycle if needed. IF(.NOT.paw_atom) CYCLE @@ -313,8 +309,8 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii IF (.NOT.ASSOCIATED(oce%intac(iac)%alist)) CYCLE IF (.NOT.ASSOCIATED(oce%intac(ibc)%alist)) CYCLE - CALL get_alist(oce%intac(iac), alist_ac, iatom, error) - CALL get_alist(oce%intac(ibc), alist_bc, jatom, error) + CALL get_alist(oce%intac(iac), alist_ac, iatom) + CALL get_alist(oce%intac(ibc), alist_bc, jatom) IF (.NOT.ASSOCIATED(alist_ac)) CYCLE IF (.NOT.ASSOCIATED(alist_bc)) CYCLE @@ -342,7 +338,7 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii katom = alist_ac%clist(kac)%catom IF(.NOT.ASSOCIATED(jrho1_atom_set(katom)%cjc0_h(1)%r_coef)) THEN - CALL allocate_jrho_coeff(jrho1_atom_set,katom,nsoctot,error) + CALL allocate_jrho_coeff(jrho1_atom_set,katom,nsoctot) ENDIF ! ! Compute the modified Qai matrix as @@ -440,13 +436,13 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii ENDDO ! kkind DO ispin = 1,nspins DEALLOCATE(jp_RARnu(ispin)%r_coef,jp2_RARnu(ispin)%r_coef,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDDO END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(basis_set_list,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! ! parallel sum up nbr_dbl = 0.0_dp @@ -457,7 +453,7 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii CALL get_qs_kind(qs_kind_set(ikind),& basis_set=orb_basis_set,& paw_proj_set=paw_proj,& - paw_atom=paw_atom, error=error) + paw_atom=paw_atom) IF(.NOT. paw_atom) CYCLE @@ -469,13 +465,13 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii bo = get_limit(nat,num_pe,mepos) ! ALLOCATE(zero_coeff(nsoctot,nsoctot),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO iat = 1,nat iatom = atom_list(iat) is_not_associated = .NOT.ASSOCIATED(jrho1_atom_set(iatom)%cjc0_h(1)%r_coef) ! IF(iat.GE.bo(1).AND.iat.LE.bo(2).AND.is_not_associated) THEN - CALL allocate_jrho_coeff(jrho1_atom_set,iatom,nsoctot,error) + CALL allocate_jrho_coeff(jrho1_atom_set,iatom,nsoctot) ENDIF ! DO ispin = 1, nspins @@ -533,12 +529,12 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii ENDDO ! iat ! DEALLOCATE(zero_coeff,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! ENDDO ! ikind ! ! - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) IF(output_unit>0) THEN WRITE(output_unit,'(A,E8.2)') 'calculate_jrho_atom_coeff: nbr_dbl=',nbr_dbl @@ -547,7 +543,7 @@ SUBROUTINE calculate_jrho_atom_coeff(qs_env,current_env,mat_d0,mat_jp,mat_jp_rii ! clean up DEALLOCATE(a_matrix,b_matrix,c_matrix,d_matrix,PC1,CPC,a_block,b_block,c_block,d_block,& jp_RARnu,jp2_RARnu,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! CALL timestop(handle) ! @@ -558,14 +554,12 @@ END SUBROUTINE calculate_jrho_atom_coeff !> \param qs_env ... !> \param current_env ... !> \param idir ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) + SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir) ! TYPE(qs_environment_type), POINTER :: qs_env TYPE(current_env_type) :: current_env INTEGER, INTENT(IN) :: idir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_jrho_atom_rad', & routineP = moduleN//':'//routineN @@ -624,15 +618,13 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& dft_control=dft_control,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL get_qs_kind_set(qs_kind_set=qs_kind_set,maxlgto=maxlgto,error=error) + CALL get_qs_kind_set(qs_kind_set=qs_kind_set,maxlgto=maxlgto) ! CALL get_current_env(current_env=current_env,& - jrho1_atom_set=jrho1_atom_set,& - error=error) + jrho1_atom_set=jrho1_atom_set) ! nkind = SIZE(qs_kind_set) @@ -640,7 +632,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) ! natom_tot = SIZE(jrho1_atom_set,1) ALLOCATE(is_set_to_0(natom_tot,nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) is_set_to_0(:,:) = .FALSE. ! @@ -657,7 +649,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) paw_atom=paw_atom,& harmonics=harmonics,& hard_radius=hard_radius,& - basis_set=orb_basis_set,error=error) + basis_set=orb_basis_set) ! ! Quick cycle if needed. IF(.NOT.paw_atom) CYCLE @@ -696,7 +688,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),& dacg_list(2,nsoset(maxl)**2,max_s_harm),dacg_n_list(max_s_harm),& gauge_h(nr),gauge_s(nr),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! ! Compute the gauge SELECT CASE(current_env%gauge) @@ -729,11 +721,11 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) m2s = 0 DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local,error) - CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local) + CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,failure) CALL get_none0_cg_list(my_CG_dxyz_asym,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,dacg_list,dacg_n_list,damax_iso_not0_local,error) - CPPrecondition(damax_iso_not0_local.LE.damax_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,lmax_expansion,dacg_list,dacg_n_list,damax_iso_not0_local) + CPPrecondition(damax_iso_not0_local.LE.damax_iso_not0,cp_failure_level,routineP,failure) n1s = nsoset(lmax(iset1)) DO ipgf1 = 1,npgf(iset1) @@ -743,7 +735,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) iso1_first = o2nindex(iso1_first) iso1_last = o2nindex(iso1_last) i1 = iso1_last - iso1_first + 1 - CPPrecondition(size1==i1,cp_failure_level,routineP,error,failure) + CPPrecondition(size1==i1,cp_failure_level,routineP,failure) i1 = nsoset(lmin(iset1)-1)+1 ! g1(1:nr) = EXP(-zet(ipgf1,iset1)*grid_atom%rad2(1:nr)) @@ -756,7 +748,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) iso2_first = o2nindex(iso2_first) iso2_last = o2nindex(iso2_last) i2 = iso2_last - iso2_first + 1 - CPPrecondition(size2==i2,cp_failure_level,routineP,error,failure) + CPPrecondition(size2==i2,cp_failure_level,routineP,failure) i2 = nsoset(lmin(iset2)-1)+1 ! g2(1:nr) = EXP(-zet(ipgf2,iset2)*grid_atom%rad2(1:nr)) @@ -861,11 +853,11 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) jrho1_atom => jrho1_atom_set(iatom) IF(.NOT.ASSOCIATED(jrho1_atom%jrho_a_h(ispin)%r_coef)) THEN CALL allocate_jrho_atom_rad(jrho1_atom,ispin,nr,na,& - max_max_iso_not0,error=error) + max_max_iso_not0) is_set_to_0(iatom,ispin) = .TRUE. ELSE IF(.NOT.is_set_to_0(iatom,ispin)) THEN - CALL set2zero_jrho_atom_rad(jrho1_atom,ispin,error=error) + CALL set2zero_jrho_atom_rad(jrho1_atom,ispin) is_set_to_0(iatom,ispin) = .TRUE. ENDIF ENDIF @@ -906,7 +898,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) WRITE(*,*) 'iso1=',iso1,' iso2=',iso2,' iso=',iso,' icg=',icg WRITE(*,*) '.... will stop!' ENDIF - CPPrecondition(iso2>0.AND.iso1>0,cp_failure_level,routineP,error,failure) + CPPrecondition(iso2>0.AND.iso1>0,cp_failure_level,routineP,failure) ! l = indso(1,iso1) + indso(1,iso2) IF(l.GT.lmax_expansion.OR.l.LT..0) THEN @@ -914,7 +906,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) WRITE(*,*) 'calculate_jrho_atom_rad: 1 lmax_expansion',lmax_expansion WRITE(*,*) '.... will stop!' ENDIF - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) !------------------------------------------------------------------ ! P0 ! @@ -1020,7 +1012,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) WRITE(*,*) 'iso1=',iso1,' iso2=',iso2,' iso=',iso,' icg=',icg WRITE(*,*) '.... will stop!' ENDIF - CPPrecondition(iso2>0.AND.iso1>0,cp_failure_level,routineP,error,failure) + CPPrecondition(iso2>0.AND.iso1>0,cp_failure_level,routineP,failure) ! l = indso(1,iso1) + indso(1,iso2) IF(l.GT.lmax_expansion) THEN @@ -1028,7 +1020,7 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) WRITE(*,*) 'calculate_jrho_atom_rad: 1 lmax_expansion',lmax_expansion WRITE(*,*) '.... will stop!' ENDIF - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) !------------------------------------------------------------------ ! Daij ! @@ -1113,12 +1105,12 @@ SUBROUTINE calculate_jrho_atom_rad(qs_env,current_env,idir,error) DEALLOCATE(cjc0_h_block,cjc0_s_block,cjc_h_block,cjc_s_block,cjc_ii_h_block,cjc_ii_s_block,& cjc_iii_h_block,cjc_iii_s_block,g1,g2,gg,gg_lm1,dgg_1,gauge_h,gauge_s,& cg_list,cg_n_list,dacg_list,dacg_n_list,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDDO ! ikind ! ! DEALLOCATE(is_set_to_0,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! CALL timestop(handle) ! @@ -1138,11 +1130,10 @@ END SUBROUTINE calculate_jrho_atom_rad !> \param iB ... !> \param idir ... !> \param ispin ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_jrho_atom_ang(jrho1_atom,jrho_h,jrho_s,grid_atom,& harmonics,do_igaim,ratom,natm_gauge,& - iB,idir,ispin,error) + iB,idir,ispin) ! TYPE(jrho_atom_type), POINTER :: jrho1_atom REAL(dp), DIMENSION(:, :), POINTER :: jrho_h, jrho_s @@ -1150,7 +1141,6 @@ SUBROUTINE calculate_jrho_atom_ang(jrho1_atom,jrho_h,jrho_s,grid_atom,& TYPE(harmonics_atom_type), POINTER :: harmonics LOGICAL, INTENT(IN) :: do_igaim INTEGER, INTENT(IN) :: iB, idir, ispin, natm_gauge - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(dp), INTENT(IN) :: ratom(:,:) CHARACTER(len=*), PARAMETER :: routineN = 'calculate_jrho_atom_ang', & @@ -1172,41 +1162,41 @@ SUBROUTINE calculate_jrho_atom_ang(jrho1_atom,jrho_h,jrho_s,grid_atom,& Fr_b_h,Fr_b_s,Fr_b_h_ii,Fr_b_s_ii,Fr_b_h_iii,Fr_b_s_iii,& a,slm) ! - CPPrecondition(ASSOCIATED(jrho_h),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho_h),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,failure) ! just to be sure... - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_ii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_ii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_ii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_ii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_ii(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_ii(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_ii(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_ii(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_iii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_iii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_iii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_iii),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_iii(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_iii(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_iii(ispin)%r_coef),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_iii(ispin)%r_coef),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_ii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_ii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_ii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_ii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_ii(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_ii(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_ii(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_ii(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_iii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_iii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_iii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_iii),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_h_iii(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_a_s_iii(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_h_iii(ispin)%r_coef),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(jrho1_atom%jrho_b_s_iii(ispin)%r_coef),cp_failure_level,routineP,failure) ! ! nr = grid_atom%nr na = grid_atom%ng_sphere max_max_iso_not0 = MAX(harmonics%max_iso_not0,harmonics%damax_iso_not0) ALLOCATE(g(3,nr,na),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) !------------------------------------------------------------------ ! Fr_h => jrho1_atom%jrho_h(ispin)%r_coef @@ -1300,7 +1290,7 @@ SUBROUTINE calculate_jrho_atom_ang(jrho1_atom,jrho_h,jrho_s,grid_atom,& ENDDO ! ir ! DEALLOCATE(g,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! CONTAINS ! @@ -1360,14 +1350,11 @@ END SUBROUTINE calculate_jrho_atom_ang !> \param qs_env ... !> \param iB ... !> \param idir ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_jrho_atom(current_env,qs_env,iB,idir,error) + SUBROUTINE calculate_jrho_atom(current_env,qs_env,iB,idir) TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB, idir - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_jrho_atom', & routineP = moduleN//':'//routineN @@ -1407,11 +1394,10 @@ SUBROUTINE calculate_jrho_atom(current_env,qs_env,iB,idir,error) qs_kind_set=qs_kind_set,& particle_set=particle_set,& cell=cell,& - para_env=para_env,error=error) + para_env=para_env) CALL get_current_env(current_env=current_env,& - jrho1_atom_set=jrho1_atom_set,& - error=error) + jrho1_atom_set=jrho1_atom_set) do_igaim = .FALSE. IF(current_env%gauge.EQ.current_gauge_atom) do_igaim = .TRUE. @@ -1422,7 +1408,7 @@ SUBROUTINE calculate_jrho_atom(current_env,qs_env,iB,idir,error) natm_tot = SIZE(particle_set) ALLOCATE(ratom(3,natm_tot),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF (gapw) THEN DO ikind = 1,nkind @@ -1432,7 +1418,7 @@ SUBROUTINE calculate_jrho_atom(current_env,qs_env,iB,idir,error) grid_atom=grid_atom,& harmonics=harmonics,& hard_radius=hard_radius,& - paw_atom=paw_atom, error=error) + paw_atom=paw_atom) IF (.NOT.paw_atom) CYCLE @@ -1462,14 +1448,14 @@ SUBROUTINE calculate_jrho_atom(current_env,qs_env,iB,idir,error) jrho1_atom%jrho_vec_rad_s(idir,ispin)%r_coef,& grid_atom,harmonics,& do_igaim,& - ratom,natm_gauge,iB,idir,ispin,error=error) + ratom,natm_gauge,iB,idir,ispin) END DO !ispin END DO !iat END DO !ikind END IF DEALLOCATE(ratom,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE calculate_jrho_atom diff --git a/src/qs_linres_current.F b/src/qs_linres_current.F index de16317187..9b57a7e7ec 100644 --- a/src/qs_linres_current.F +++ b/src/qs_linres_current.F @@ -164,7 +164,6 @@ MODULE qs_linres_current !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... !> \author MI !> \note !> The susceptibility is needed to compute the G=0 term of the shift @@ -175,12 +174,11 @@ MODULE qs_linres_current !> This cannot be done on directly on the full J(r) because it is not localized !> Therefore it is done state by state (see linres_nmr_shift) ! ***************************************************************************** - SUBROUTINE current_build_current(current_env,qs_env,iB,error) + SUBROUTINE current_build_current(current_env,qs_env,iB) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'current_build_current', & routineP = moduleN//':'//routineN @@ -241,7 +239,7 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) para_env,center_list,mo_coeff,psi_a_iB,jrho1_r, jrho1_g,& psi1,p_psi1,psi1_p,psi1_D,psi1_rxp,psi0_order,sab_all, qs_kind_set) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) ! ! @@ -252,8 +250,7 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) psi1_p=psi1_p,& psi0_order=psi0_order,& nstates=nstates,& - nao=nao,& - error=error) + nao=nao) ! ! CALL get_qs_env(qs_env=qs_env,& @@ -267,10 +264,9 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) sab_all=sab_all,& particle_set=particle_set,& qs_kind_set=qs_kind_set,& - dbcsr_dist=dbcsr_dist,& - error=error) + dbcsr_dist=dbcsr_dist) - CALL qs_subsys_get(subsys,particles=particles,error=error) + CALL qs_subsys_get(subsys,particles=particles) gapw = dft_control%qs_control%gapw nspins = dft_control%nspins @@ -278,73 +274,72 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) ! ! allocate temporary arrays ALLOCATE(psi1(nspins),p_psi1(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins - CALL cp_fm_create( psi1(ispin)%matrix,psi0_order(ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_create(p_psi1(ispin)%matrix,psi0_order(ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_set_all( psi1(ispin)%matrix,0.0_dp,error=error) - CALL cp_fm_set_all(p_psi1(ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_create( psi1(ispin)%matrix,psi0_order(ispin)%matrix%matrix_struct) + CALL cp_fm_create(p_psi1(ispin)%matrix,psi0_order(ispin)%matrix%matrix_struct) + CALL cp_fm_set_all( psi1(ispin)%matrix,0.0_dp) + CALL cp_fm_set_all(p_psi1(ispin)%matrix,0.0_dp) ENDDO ! ! - CALL cp_dbcsr_allocate_matrix_set(density_matrix0,nspins,error=error) - CALL cp_dbcsr_allocate_matrix_set(density_matrix_a,nspins,error=error) - CALL cp_dbcsr_allocate_matrix_set(density_matrix_ii,nspins,error=error) - CALL cp_dbcsr_allocate_matrix_set(density_matrix_iii,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(density_matrix0,nspins) + CALL cp_dbcsr_allocate_matrix_set(density_matrix_a,nspins) + CALL cp_dbcsr_allocate_matrix_set(density_matrix_ii,nspins) + CALL cp_dbcsr_allocate_matrix_set(density_matrix_iii,nspins) ! ! prepare for allocation ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! DO ispin = 1,nspins ! !density_matrix0 ALLOCATE(density_matrix0(ispin)%matrix) - CALL cp_dbcsr_init(density_matrix0(ispin)%matrix,error=error) + CALL cp_dbcsr_init(density_matrix0(ispin)%matrix) CALL cp_dbcsr_create(matrix=density_matrix0(ispin)%matrix, & name="density_matrix0", & dist=dbcsr_dist, matrix_type=dbcsr_type_no_symmetry,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(density_matrix0(ispin)%matrix,sab_all,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(density_matrix0(ispin)%matrix,sab_all) ! !density_matrix_a ALLOCATE(density_matrix_a(ispin)%matrix) - CALL cp_dbcsr_init(density_matrix_a(ispin)%matrix,error=error) + CALL cp_dbcsr_init(density_matrix_a(ispin)%matrix) CALL cp_dbcsr_copy(density_matrix_a(ispin)%matrix,density_matrix0(ispin)%matrix,& - name="density_matrix_a",error=error) + name="density_matrix_a") ! !density_matrix_ii ALLOCATE(density_matrix_ii(ispin)%matrix) - CALL cp_dbcsr_init(density_matrix_ii(ispin)%matrix,error=error) + CALL cp_dbcsr_init(density_matrix_ii(ispin)%matrix) CALL cp_dbcsr_copy(density_matrix_ii(ispin)%matrix,density_matrix0(ispin)%matrix,& - name="density_matrix_ii",error=error) + name="density_matrix_ii") ! !density_matrix_iii ALLOCATE(density_matrix_iii(ispin)%matrix) - CALL cp_dbcsr_init(density_matrix_iii(ispin)%matrix,error=error) + CALL cp_dbcsr_init(density_matrix_iii(ispin)%matrix) CALL cp_dbcsr_copy(density_matrix_iii(ispin)%matrix,density_matrix0(ispin)%matrix,& - name="density_matrix_iii",error=error) + name="density_matrix_iii") ENDDO ! DEALLOCATE(row_blk_sizes) ! ! - current_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES%CURRENT",error=error) + current_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES%CURRENT") ! IF(.NOT. failure) THEN ! @@ -363,22 +358,22 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) ! ! ! Build the first density matrix - CALL cp_dbcsr_set(density_matrix0(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(density_matrix0(ispin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix0(ispin)%matrix ,& matrix_v=mo_coeff,matrix_g=mo_coeff,& - ncol=nmo,alpha=maxocc,error=error) + ncol=nmo,alpha=maxocc) ! ! Allocate buffer vectors ALLOCATE(ddk(3,nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! Construct the 3 density matrices for the field in direction iB ! ! First the full matrix psi_a_iB psi_a_iB => psi1(ispin)%matrix psi_buf => p_psi1(ispin)%matrix - CALL cp_fm_set_all(psi_a_iB,0.0_dp,error=error) - CALL cp_fm_set_all(psi_buf,0.0_dp,error=error) + CALL cp_fm_set_all(psi_a_iB,0.0_dp) + CALL cp_fm_set_all(psi_buf,0.0_dp) ! psi_a_iB = - (R_\nu-dk)_ii psi1_piiiB + (R_\nu-dk)_iii psi1_piiB ! ! contributions from the response psi1_p_ii and psi1_p_iii @@ -394,66 +389,66 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) ddk(:,jstate) = dk(1:3) ENDDO ENDDO ! istate - CALL fm_scale_by_pbc_AC(psi_a_iB,current_env%basisfun_center,ddk,cell,iiiB,error) - CALL fm_scale_by_pbc_AC(psi_buf,current_env%basisfun_center,ddk,cell,iiB,error) - CALL cp_fm_scale_and_add(-1.0_dp,psi_a_iB,1.0_dp,psi_buf,error=error) + CALL fm_scale_by_pbc_AC(psi_a_iB,current_env%basisfun_center,ddk,cell,iiiB) + CALL fm_scale_by_pbc_AC(psi_buf,current_env%basisfun_center,ddk,cell,iiB) + CALL cp_fm_scale_and_add(-1.0_dp,psi_a_iB,1.0_dp,psi_buf) ! !psi_a_iB = psi_a_iB + psi1_rxp ! ! contribution from the response psi1_rxp - CALL cp_fm_scale_and_add(-1.0_dp,psi_a_iB,1.0_dp,psi1_rxp(ispin,iB)%matrix,error=error) + CALL cp_fm_scale_and_add(-1.0_dp,psi_a_iB,1.0_dp,psi1_rxp(ispin,iB)%matrix) ! !psi_a_iB = psi_a_iB - psi1_D IF(current_env%full) THEN ! ! contribution from the response psi1_D - CALL cp_fm_scale_and_add(1.0_dp,psi_a_iB,-1.0_dp,psi1_D(ispin,iB)%matrix,error=error) + CALL cp_fm_scale_and_add(1.0_dp,psi_a_iB,-1.0_dp,psi1_D(ispin,iB)%matrix) ENDIF ! ! Multiply by the occupation number for the density matrix ! ! Build the first density matrix - CALL cp_dbcsr_set(density_matrix_a(ispin)%matrix ,0.0_dp,error=error) + CALL cp_dbcsr_set(density_matrix_a(ispin)%matrix ,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix_a(ispin)%matrix ,& matrix_v=mo_coeff,matrix_g=psi_a_iB,& - ncol=nmo,alpha=maxocc,error=error) + ncol=nmo,alpha=maxocc) ! ! Build the second density matrix - CALL cp_dbcsr_set(density_matrix_iii(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(density_matrix_iii(ispin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix_iii(ispin)%matrix ,& matrix_v=mo_coeff,matrix_g=psi1_p(ispin,iiiB)%matrix,& - ncol=nmo,alpha=maxocc,error=error) + ncol=nmo,alpha=maxocc) ! ! Build the third density matrix - CALL cp_dbcsr_set(density_matrix_ii(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(density_matrix_ii(ispin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix_ii(ispin)%matrix ,& matrix_v=mo_coeff,matrix_g=psi1_p(ispin,iiB)%matrix,& - ncol=nmo,alpha=maxocc,error=error) + ncol=nmo,alpha=maxocc) DO idir = 1,3 ! ! Calculate the current density on the pw grid (only soft if GAPW) ! idir is the cartesian component of the response current density ! generated by the magnetic field pointing in cartesian direction iB ! Use the qs_rho_type already used for rho during the scf - CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_r=jrho1_r, error=error) - CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_g=jrho1_g, error=error) + CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_r=jrho1_r) + CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_g=jrho1_g) jrho_rspace => jrho1_r(ispin) jrho_gspace => jrho1_g(ispin) - CALL pw_zero(jrho_rspace%pw,error=error) - CALL pw_zero(jrho_gspace%pw,error=error) + CALL pw_zero(jrho_rspace%pw) + CALL pw_zero(jrho_gspace%pw) CALL calculate_jrho_resp(density_matrix0(ispin)%matrix, & density_matrix_a(ispin)%matrix, & density_matrix_ii(ispin)%matrix, & density_matrix_iii(ispin)%matrix, & iB,idir,jrho_rspace,jrho_gspace,qs_env, & - current_env,gapw,error=error) + current_env,gapw) scale_fac = cell%deth / twopi - CALL pw_scale(jrho_rspace%pw,scale_fac,error=error) - CALL pw_scale(jrho_gspace%pw,scale_fac,error=error) + CALL pw_scale(jrho_rspace%pw,scale_fac) + CALL pw_scale(jrho_gspace%pw,scale_fac) - jrho_tot_G(idir,iB) = pw_integrate_function(jrho_gspace%pw,isign=-1,error=error) - jrho_tot_R(idir,iB) = pw_integrate_function(jrho_rspace%pw,isign=-1,error=error) + jrho_tot_G(idir,iB) = pw_integrate_function(jrho_gspace%pw,isign=-1) + jrho_tot_R(idir,iB) = pw_integrate_function(jrho_rspace%pw,isign=-1) IF(output_unit>0) THEN WRITE(output_unit,'(T2,2(A,E24.16))') 'Integrated j_'& @@ -465,7 +460,7 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) ! ! Deallocate buffer vectors DEALLOCATE(ddk,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ENDDO ! ispin @@ -480,40 +475,39 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) density_matrix_a, & density_matrix_ii, & density_matrix_iii, & - iB,idir,error=error) + iB,idir) ! ! Then the radial parts are computed on the local radial grid, atom by atom ! 8 functions are computed for each atom, per grid point ! and per LM angular momentum. The multiplication by the Clebsh-Gordon ! coefficients or they correspondent for the derivatives, is also done here - CALL calculate_jrho_atom_rad(qs_env,current_env,idir,error=error) + CALL calculate_jrho_atom_rad(qs_env,current_env,idir) ! ! The current on the atomic grids - CALL calculate_jrho_atom(current_env,qs_env,iB,idir,error=error) + CALL calculate_jrho_atom(current_env,qs_env,iB,idir) ENDDO ! idir ENDIF ! ! Cube files IF(BTEST(cp_print_key_should_output(logger%iter_info,current_section,& - & "PRINT%CURRENT_CUBES",error=error),cp_p_file)) THEN - append_cube = section_get_lval(current_section,"PRINT%CURRENT_CUBES%APPEND",error=error) + & "PRINT%CURRENT_CUBES"),cp_p_file)) THEN + append_cube = section_get_lval(current_section,"PRINT%CURRENT_CUBES%APPEND") my_pos = "REWIND" IF(append_cube) THEN my_pos = "APPEND" END IF ! CALL pw_env_get(pw_env, auxbas_rs_desc=auxbas_rs_desc,& - auxbas_pw_pool=auxbas_pw_pool,& - error=error) + auxbas_pw_pool=auxbas_pw_pool) ! CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) ! DO idir = 1,3 - CALL pw_zero(wf_r%pw,error=error) - CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_r=jrho1_r, error=error) + CALL pw_zero(wf_r%pw) + CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_r=jrho1_r) DO ispin =1 ,nspins - CALL pw_axpy(jrho1_r(ispin)%pw,wf_r%pw,1.0_dp, error=error) + CALL pw_axpy(jrho1_r(ispin)%pw,wf_r%pw,1.0_dp) ENDDO ! IF(gapw) THEN @@ -527,18 +521,16 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) WRITE(ext,'(a2,a1,a2,a1,a5)') "iB",ACHAR(iB+119),"_d",ACHAR(idir+119),".cube" unit_nr=cp_print_key_unit_nr(logger,current_section,"PRINT%CURRENT_CUBES",& extension=TRIM(ext),middle_name=TRIM(filename),& - log_filename=.FALSE.,file_position=my_pos,& - error=error) + log_filename=.FALSE.,file_position=my_pos) CALL cp_pw_to_cube(wf_r%pw,unit_nr,"RESPONSE CURRENT DENSITY ",& particles=particles,& - stride=section_get_ivals(current_section,"PRINT%CURRENT_CUBES%STRIDE",& - error=error),error=error) + stride=section_get_ivals(current_section,"PRINT%CURRENT_CUBES%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,current_section,& - & "PRINT%CURRENT_CUBES",error=error) + & "PRINT%CURRENT_CUBES") ENDDO ! - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) ENDIF ! current cube ! ! Integrated current response checksum @@ -550,16 +542,16 @@ SUBROUTINE current_build_current(current_env,qs_env,iB,error) ! ! Dellocate grids for the calculation of jrho and the shift DO ispin = 1,nspins - CALL cp_fm_release( psi1(ispin)%matrix,error) - CALL cp_fm_release(p_psi1(ispin)%matrix,error) + CALL cp_fm_release( psi1(ispin)%matrix) + CALL cp_fm_release(p_psi1(ispin)%matrix) ENDDO DEALLOCATE(psi1,p_psi1,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_deallocate_matrix_set(density_matrix0,error=error) - CALL cp_dbcsr_deallocate_matrix_set(density_matrix_a,error=error) - CALL cp_dbcsr_deallocate_matrix_set(density_matrix_ii,error=error) - CALL cp_dbcsr_deallocate_matrix_set(density_matrix_iii,error=error) + CALL cp_dbcsr_deallocate_matrix_set(density_matrix0) + CALL cp_dbcsr_deallocate_matrix_set(density_matrix_a) + CALL cp_dbcsr_deallocate_matrix_set(density_matrix_ii) + CALL cp_dbcsr_deallocate_matrix_set(density_matrix_iii) ! ENDIF ! failure @@ -585,7 +577,6 @@ END SUBROUTINE current_build_current !> \param current_env ... !> \param soft_valid ... !> \param rtp If this subroutine is called form the rtp region -!> \param error ... !> \note !> The collocate is done in three parts, one for each density matrix !> In all cases the density matrices and therefore the collocation @@ -610,7 +601,7 @@ END SUBROUTINE current_build_current !> All the terms sum up to the same grid ! ***************************************************************************** SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& - current_rs, current_gs, qs_env, current_env, soft_valid, rtp,error) + current_rs, current_gs, qs_env, current_env, soft_valid, rtp) TYPE(cp_dbcsr_type), POINTER :: mat_d0, mat_jp, mat_jp_rii, & mat_jp_riii @@ -619,7 +610,6 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& TYPE(qs_environment_type), POINTER :: qs_env TYPE(current_env_type) :: current_env LOGICAL, INTENT(IN), OPTIONAL :: soft_valid, rtp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_jrho_resp', & routineP = moduleN//':'//routineN @@ -721,9 +711,9 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& particle_set=particle_set,& sab_all=sab_orb,& para_env=para_env,& - pw_env=pw_env,error=error) + pw_env=pw_env) - IF(do_igaim) CALL get_current_env(current_env=current_env,rs_gauge=rs_gauge,error=error) + IF(do_igaim) CALL get_current_env(current_env=current_env,rs_gauge=rs_gauge) ! Component of appearing in the vector product rxp, iiB and iiiB CALL set_vecp(iB,iiB,iiiB) @@ -741,10 +731,10 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& cube_info=>pw_env%cube_info ! Check that the neighbor list with all the pairs is associated - CPPrecondition(ASSOCIATED(sab_orb),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sab_orb),cp_failure_level,routineP,failure) ! *** set up the pw multi-grids - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_rho, error=error) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_rho) distributed_rs_grids=.FALSE. DO igrid_level=1,gridlevel_info%ngrid_levels @@ -760,7 +750,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxco,& maxsgf=maxsgf,& - maxsgf_set=maxsgf_set, error=error) + maxsgf_set=maxsgf_set) Lxo2 = SQRT ( SUM ( cell % hmat ( :, 1 ) ** 2 ) )/2.0_dp Lyo2 = SQRT ( SUM ( cell % hmat ( :, 2 ) ** 2 ) )/2.0_dp @@ -790,14 +780,14 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& ! hard code matrix index (no kpoints) nimages = dft_control%nimages - CPPostcondition(nimages==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nimages==1,cp_failure_level,routineP,failure) cindex = 1 DO ikind=1,nkind qs_kind => qs_kind_set(ikind) CALL get_qs_kind(qs_kind=qs_kind,& - basis_set=orb_basis_set, error=error) + basis_set=orb_basis_set) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE @@ -815,29 +805,29 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& ALLOCATE(deltajp_a(1),deltajp_b(1),deltajp_c(1),deltajp_d(1)) IF (distributed_rs_grids) THEN ALLOCATE(deltajp_a(1)%matrix,deltajp_b(1)%matrix,deltajp_c(1)%matrix) - CALL cp_dbcsr_init(deltajp_a(1)%matrix, error=error) - CALL cp_dbcsr_init(deltajp_b(1)%matrix, error=error) - CALL cp_dbcsr_init(deltajp_c(1)%matrix, error=error) + CALL cp_dbcsr_init(deltajp_a(1)%matrix) + CALL cp_dbcsr_init(deltajp_b(1)%matrix) + CALL cp_dbcsr_init(deltajp_c(1)%matrix) IF(do_igaim) THEN ALLOCATE(deltajp_d(1)%matrix) - CALL cp_dbcsr_init(deltajp_d(1)%matrix, error=error) + CALL cp_dbcsr_init(deltajp_d(1)%matrix) ENDIF CALL cp_dbcsr_create(deltajp_a(1)%matrix, ' deltajp_a ', cp_dbcsr_distribution (mat_a), cp_dbcsr_get_matrix_type (mat_a),& cp_dbcsr_row_block_sizes(mat_a),cp_dbcsr_col_block_sizes(mat_a), & - cp_dbcsr_get_data_size(mat_a),error=error) + cp_dbcsr_get_data_size(mat_a)) CALL cp_dbcsr_create(deltajp_b(1)%matrix, ' deltajp_b ', cp_dbcsr_distribution (mat_a), cp_dbcsr_get_matrix_type (mat_a),& cp_dbcsr_row_block_sizes(mat_a),cp_dbcsr_col_block_sizes(mat_a), & - cp_dbcsr_get_data_size(mat_a),error=error) + cp_dbcsr_get_data_size(mat_a)) CALL cp_dbcsr_create(deltajp_c(1)%matrix, ' deltajp_c ', cp_dbcsr_distribution (mat_a), cp_dbcsr_get_matrix_type (mat_a),& cp_dbcsr_row_block_sizes(mat_a),cp_dbcsr_col_block_sizes(mat_a), & - cp_dbcsr_get_data_size(mat_a),error=error) + cp_dbcsr_get_data_size(mat_a)) IF(do_igaim) CALL cp_dbcsr_create(deltajp_d(1)%matrix, ' deltajp_d ', cp_dbcsr_distribution (mat_a),& cp_dbcsr_get_matrix_type (mat_a),cp_dbcsr_row_block_sizes(mat_a),cp_dbcsr_col_block_sizes(mat_a),& - cp_dbcsr_get_data_size(mat_a),error=error) + cp_dbcsr_get_data_size(mat_a)) ELSE deltajp_a(1)%matrix => mat_a !mat_jp deltajp_b(1)%matrix => mat_b !mat_jp_rii @@ -846,10 +836,10 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& ENDIF ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,softb=my_soft,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,softb=my_soft,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -909,14 +899,14 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& IF (distributed_rs_grids) THEN NULLIFY (jpblock_a,jpblock_b,jpblock_c,jpblock_d) - CALL cp_dbcsr_add_block_node ( deltajp_a(1)%matrix, brow, bcol, jpblock_a ,error=error) + CALL cp_dbcsr_add_block_node ( deltajp_a(1)%matrix, brow, bcol, jpblock_a) jpblock_a = jp_block_a - CALL cp_dbcsr_add_block_node ( deltajp_b(1)%matrix, brow, bcol, jpblock_b ,error=error) + CALL cp_dbcsr_add_block_node ( deltajp_b(1)%matrix, brow, bcol, jpblock_b) jpblock_b = jp_block_b - CALL cp_dbcsr_add_block_node ( deltajp_c(1)%matrix, brow, bcol, jpblock_c ,error=error) + CALL cp_dbcsr_add_block_node ( deltajp_c(1)%matrix, brow, bcol, jpblock_c) jpblock_c = jp_block_c IF(do_igaim) THEN - CALL cp_dbcsr_add_block_node ( deltajp_d(1)%matrix, brow, bcol, jpblock_d ,error=error) + CALL cp_dbcsr_add_block_node ( deltajp_d(1)%matrix, brow, bcol, jpblock_d) jpblock_d = jp_block_d END IF ELSE @@ -937,42 +927,42 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& CALL task_list_inner_loop(tasks, dist_ab, ntasks, curr_tasks, rs_descs,& dft_control,cube_info,gridlevel_info,cindex,& iatom,jatom,rpgfa,rpgfb,zeta,zetb,kind_radius_b,set_radius_a,set_radius_b,ra,rab,& - la_max,la_min,lb_max,lb_min,npgfa,npgfb,maxpgf,maxset,natom,nimages,nseta,nsetb,error) + la_max,la_min,lb_max,lb_min,npgfa,npgfb,maxpgf,maxset,natom,nimages,nseta,nsetb) END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (distributed_rs_grids) THEN - CALL cp_dbcsr_finalize(deltajp_a(1)%matrix, error=error) - CALL cp_dbcsr_finalize(deltajp_b(1)%matrix, error=error) - CALL cp_dbcsr_finalize(deltajp_c(1)%matrix, error=error) - IF(do_igaim) CALL cp_dbcsr_finalize(deltajp_d(1)%matrix, error=error) + CALL cp_dbcsr_finalize(deltajp_a(1)%matrix) + CALL cp_dbcsr_finalize(deltajp_b(1)%matrix) + CALL cp_dbcsr_finalize(deltajp_c(1)%matrix) + IF(do_igaim) CALL cp_dbcsr_finalize(deltajp_d(1)%matrix) ENDIF ! sorts / redistributes the task list CALL distribute_tasks ( rs_descs, ntasks, natom, maxset, maxpgf, nimages,& tasks, dist_ab, atom_pair_send, atom_pair_recv,& symmetric=.FALSE., reorder_rs_grid_ranks=.TRUE., & - skip_load_balance_distributed=.FALSE., error=error) + skip_load_balance_distributed=.FALSE.) ALLOCATE(rs_current(gridlevel_info%ngrid_levels)) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO igrid_level=1,gridlevel_info%ngrid_levels ! Here we need to reallocate the distributed rs_grids, which may have been reordered ! by distribute_tasks IF (rs_descs(igrid_level)%rs_desc%distributed.AND..NOT.my_rtp) THEN - CALL rs_grid_release(rs_rho(igrid_level)%rs_grid, error=error) + CALL rs_grid_release(rs_rho(igrid_level)%rs_grid) NULLIFY (rs_rho(igrid_level)%rs_grid) - CALL rs_grid_create(rs_rho(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc, error=error) + CALL rs_grid_create(rs_rho(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc) ELSE - IF(.NOT.my_rtp) CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid, error=error) + IF(.NOT.my_rtp) CALL rs_grid_retain(rs_rho(igrid_level)%rs_grid) ENDIF CALL rs_grid_zero(rs_rho(igrid_level)%rs_grid) - CALL rs_grid_create(rs_current(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc, error=error) + CALL rs_grid_create(rs_current(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc) CALL rs_grid_zero(rs_current(igrid_level)%rs_grid) ENDDO @@ -988,7 +978,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& ! ! we need to build the gauge here IF(.NOT.current_env%gauge_init.AND.do_igaim) THEN - CALL current_set_gauge(current_env, qs_env, error=error) + CALL current_set_gauge(current_env, qs_env) current_env%gauge_init = .TRUE. ENDIF ! @@ -1034,13 +1024,13 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& IF (distributed_rs_grids) THEN CALL rs_distribute_matrix (rs_descs, deltajp_a, atom_pair_send, atom_pair_recv, & - natom, nimages, scatter=.TRUE., error=error) + natom, nimages, scatter=.TRUE.) CALL rs_distribute_matrix (rs_descs, deltajp_b, atom_pair_send, atom_pair_recv, & - natom, nimages, scatter=.TRUE., error=error) + natom, nimages, scatter=.TRUE.) CALL rs_distribute_matrix (rs_descs, deltajp_c, atom_pair_send, atom_pair_recv, & - natom, nimages, scatter=.TRUE., error=error) + natom, nimages, scatter=.TRUE.) IF(do_igaim) CALL rs_distribute_matrix (rs_descs, deltajp_d, atom_pair_send, atom_pair_recv, & - natom, nimages, scatter=.TRUE., error=error) + natom, nimages, scatter=.TRUE.) ENDIF ithread = 0 @@ -1059,7 +1049,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& nimages,natom,maxset,maxpgf) ! apparently generalised collocation not implemented correctly yet - CPPostcondition(tasks(4,itask).NE.2,cp_failure_level,routineP,error,failure) + CPPostcondition(tasks(4,itask).NE.2,cp_failure_level,routineP,failure) IF (iatom .NE. iatom_old .OR. jatom .NE. jatom_old) THEN @@ -1074,7 +1064,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& IF (ikind .NE. ikind_old ) THEN CALL get_qs_kind(qs_kind_set(ikind),& softb = my_soft, & - basis_set=orb_basis_set, error=error) + basis_set=orb_basis_set) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfa,& @@ -1093,7 +1083,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& CALL get_qs_kind(qs_kind_set(jkind),& softb = my_soft, & - basis_set=orb_basis_set, error=error) + basis_set=orb_basis_set) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& first_sgf=first_sgfb,& @@ -1211,7 +1201,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& eps_rho_rspace,& ga_gb_function=FUNC_ADBmDAB,& idir=idir,& - map_consistent=map_consistent,error=error) + map_consistent=map_consistent) IF(do_igaim) THEN ! here the decontracted mat_jb_{ab} is multiplied by ! f_{ab} = g_{a} * g_{b} ! THIS GOES OUTSIDE THE LOOP ! @@ -1222,7 +1212,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& rs_rho(igrid_level)%rs_grid,cell,cube_info(igrid_level),& eps_rho_rspace,& ga_gb_function=FUNC_AB,& - map_consistent=map_consistent,error=error) + map_consistent=map_consistent) ENDIF!rm ! here the decontracted mat_jp_rii{ab} is multiplied by ! f_{ab} = g_{a} (d(r) - R_{b})_{iiB} (dg_{b}/dr)_{idir} - @@ -1237,7 +1227,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& idir=idir,ir=iiiB,& rsgauge=rs_gauge(iiiB)%rs(igrid_level)%rs_grid,& rsbuf=current_env%rs_buf(igrid_level)%rs_grid,& - map_consistent=map_consistent,error=error) + map_consistent=map_consistent) ! here the decontracted mat_jp_riii{ab} is multiplied by ! f_{ab} = -g_{a} (d(r) - R_{b})_{iiB} (dg_{b}/dr)_{idir} + ! (dg_{a}/dr)_{idir} (d(r) - R_{b})_{iiB} g_{b} @@ -1251,7 +1241,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& idir=idir,ir=iiB,& rsgauge=rs_gauge(iiB)%rs(igrid_level)%rs_grid,& rsbuf=current_env%rs_buf(igrid_level)%rs_grid,& - map_consistent=map_consistent,error=error) + map_consistent=map_consistent) ELSE ! here the decontracted mat_jp_rii{ab} is multiplied by ! f_{ab} = g_{a} (r - R_{b})_{iiB} (dg_{b}/dr)_{idir} - @@ -1264,7 +1254,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& eps_rho_rspace,& ga_gb_function=FUNC_ARDBmDARB,& idir=idir,ir=iiiB,& - map_consistent=map_consistent,error=error) + map_consistent=map_consistent) ! here the decontracted mat_jp_riii{ab} is multiplied by ! f_{ab} = -g_{a} (r - R_{b})_{iiB} (dg_{b}/dr)_{idir} + ! (dg_{a}/dr)_{idir} (r - R_{b})_{iiB} g_{b} @@ -1276,7 +1266,7 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& eps_rho_rspace,& ga_gb_function=FUNC_ARDBmDARB,& idir=idir,ir=iiB,& - map_consistent=map_consistent,error=error) + map_consistent=map_consistent) ENDIF END DO loop_tasks @@ -1291,37 +1281,37 @@ SUBROUTINE calculate_jrho_resp(mat_d0,mat_jp,mat_jp_rii,mat_jp_riii,iB,idir,& ! *** Release work storage *** IF (distributed_rs_grids) THEN - CALL cp_dbcsr_deallocate_matrix ( deltajp_a(1)%matrix ,error=error) - CALL cp_dbcsr_deallocate_matrix ( deltajp_b(1)%matrix ,error=error) - CALL cp_dbcsr_deallocate_matrix ( deltajp_c(1)%matrix ,error=error) - IF(do_igaim) CALL cp_dbcsr_deallocate_matrix ( deltajp_d(1)%matrix ,error=error) + CALL cp_dbcsr_deallocate_matrix ( deltajp_a(1)%matrix) + CALL cp_dbcsr_deallocate_matrix ( deltajp_b(1)%matrix) + CALL cp_dbcsr_deallocate_matrix ( deltajp_c(1)%matrix) + IF(do_igaim) CALL cp_dbcsr_deallocate_matrix ( deltajp_d(1)%matrix) END IF DEALLOCATE(deltajp_a,deltajp_b,deltajp_c,deltajp_d) IF ( nthread > 1 ) THEN DEALLOCATE (lgrid%r,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (jpabt_a,jpabt_b,jpabt_c,jpabt_d,workt,tasks,dist_ab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (distributed_rs_grids) THEN DEALLOCATE(atom_pair_send,atom_pair_recv,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF - CALL density_rs2pw(pw_env,rs_current,current_rs,current_gs,error=error) + CALL density_rs2pw(pw_env,rs_current,current_rs,current_gs) IF (ASSOCIATED(rs_rho).AND..NOT.my_rtp) THEN !In emd/rtp we must not deallocate rs_rho DO i=1, SIZE(rs_rho) - CALL rs_grid_release(rs_rho(i)%rs_grid, error=error) + CALL rs_grid_release(rs_rho(i)%rs_grid) END DO END IF ! Free the array of grids (grids themselves are released in density_rs2pw) DEALLOCATE (rs_current,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1332,13 +1322,11 @@ END SUBROUTINE calculate_jrho_resp !> \brief ... !> \param current_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_set_gauge(current_env,qs_env,error) + SUBROUTINE current_set_gauge(current_env,qs_env) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'current_set_gauge', & routineP = moduleN//':'//routineN @@ -1362,57 +1350,53 @@ SUBROUTINE current_set_gauge(current_env,qs_env,error) CALL get_current_env(current_env=current_env,& use_old_gauge_atom=use_old_gauge_atom,& rs_gauge=rs_gauge,& - gauge=gauge,& - error=error) + gauge=gauge) IF(gauge.EQ.current_gauge_atom) THEN CALL get_qs_env(qs_env=qs_env,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) CALL pw_env_get(pw_env=pw_env,& - rs_descs=rs_descs,& - error=error) + rs_descs=rs_descs) ! ! box the atoms IF(use_old_gauge_atom) THEN - CALL box_atoms(qs_env,error) + CALL box_atoms(qs_env) ELSE - CALL box_atoms_new(current_env,qs_env,box,error) + CALL box_atoms_new(current_env,qs_env,box) ENDIF ! ! allocate and build the gauge ALLOCATE (rs_gauge(1)%rs(pw_env%gridlevel_info%ngrid_levels),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (rs_gauge(2)%rs(pw_env%gridlevel_info%ngrid_levels),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (rs_gauge(3)%rs(pw_env%gridlevel_info%ngrid_levels),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO igrid_level = pw_env%gridlevel_info%ngrid_levels,1,-1 - CALL rs_grid_create(rs_gauge(1)%rs(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc, error=error) - CALL rs_grid_create(rs_gauge(2)%rs(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc, error=error) - CALL rs_grid_create(rs_gauge(3)%rs(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc, error=error) + CALL rs_grid_create(rs_gauge(1)%rs(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc) + CALL rs_grid_create(rs_gauge(2)%rs(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc) + CALL rs_grid_create(rs_gauge(3)%rs(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc) IF(use_old_gauge_atom) THEN CALL collocate_gauge(current_env,qs_env,& rs_gauge(1)%rs(igrid_level)%rs_grid,& rs_gauge(2)%rs(igrid_level)%rs_grid,& - rs_gauge(3)%rs(igrid_level)%rs_grid,& - error) + rs_gauge(3)%rs(igrid_level)%rs_grid) ELSE CALL collocate_gauge_new(current_env,qs_env,& rs_gauge(1)%rs(igrid_level)%rs_grid,& rs_gauge(2)%rs(igrid_level)%rs_grid,& rs_gauge(3)%rs(igrid_level)%rs_grid,& - box,error) + box) ENDIF ENDDO ! ! allocate the buf ALLOCATE (current_env%rs_buf(pw_env%gridlevel_info%ngrid_levels),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO igrid_level = 1,pw_env%gridlevel_info%ngrid_levels - CALL rs_grid_create(current_env%rs_buf(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc, error=error) + CALL rs_grid_create(current_env%rs_buf(igrid_level)%rs_grid, rs_descs(igrid_level)%rs_desc) END DO ! DEALLOCATE(box_ptr,box_data) @@ -1426,11 +1410,9 @@ SUBROUTINE current_set_gauge(current_env,qs_env,error) ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE box_atoms(qs_env,error) + SUBROUTINE box_atoms(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(kind=dp), PARAMETER :: box_size_guess = 5.0_dp @@ -1447,8 +1429,7 @@ SUBROUTINE box_atoms(qs_env,error) CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& cell=cell,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) natms = SIZE(particle_set,1) ALLOCATE(ratom(3,natms)) @@ -1518,15 +1499,13 @@ END SUBROUTINE box_atoms !> \param rs_grid_x ... !> \param rs_grid_y ... !> \param rs_grid_z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE collocate_gauge(current_env,qs_env,rs_grid_x,rs_grid_y,rs_grid_z,error) + SUBROUTINE collocate_gauge(current_env,qs_env,rs_grid_x,rs_grid_y,rs_grid_z) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(realspace_grid_type), POINTER :: rs_grid_x, rs_grid_y, & rs_grid_z - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: i, iatom, ibeg, ibox, iend, imax, imin, j, jatom, jbox, jmax, & jmin, k, kbox, kmax, kmin, lb(3), lb_local(3), natms, natms_local, ng(3) @@ -1546,14 +1525,12 @@ SUBROUTINE collocate_gauge(current_env,qs_env,rs_grid_x,rs_grid_y,rs_grid_z,erro ! CALL get_current_env(current_env=current_env,& - gauge_atom_radius=gauge_atom_radius,& - error=error) + gauge_atom_radius=gauge_atom_radius) ! CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& cell=cell,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) ! natms = SIZE(particle_set,1) dr(1) = rs_grid_x%desc%dh(1,1) @@ -1685,14 +1662,12 @@ END SUBROUTINE collocate_gauge !> \param current_env ... !> \param qs_env ... !> \param box ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE box_atoms_new(current_env,qs_env,box,error) + SUBROUTINE box_atoms_new(current_env,qs_env,box) TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(box_type), DIMENSION(:, :, :), & POINTER :: box - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'box_atoms_new', & routineP = moduleN//':'//routineN @@ -1717,12 +1692,10 @@ SUBROUTINE box_atoms_new(current_env,qs_env,box,error) CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& cell=cell,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) CALL get_current_env(current_env=current_env,& - gauge_atom_radius=gauge_atom_radius,& - error=error) + gauge_atom_radius=gauge_atom_radius) scale = 2.0_dp @@ -1927,9 +1900,8 @@ END SUBROUTINE box_atoms_new !> \param rs_grid_y ... !> \param rs_grid_z ... !> \param box ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE collocate_gauge_new(current_env,qs_env,rs_grid_x,rs_grid_y,rs_grid_z,box,error) + SUBROUTINE collocate_gauge_new(current_env,qs_env,rs_grid_x,rs_grid_y,rs_grid_z,box) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env @@ -1937,7 +1909,6 @@ SUBROUTINE collocate_gauge_new(current_env,qs_env,rs_grid_x,rs_grid_y,rs_grid_z, rs_grid_z TYPE(box_type), DIMENSION(:, :, :), & POINTER :: box - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'collocate_gauge_new', & routineP = moduleN//':'//routineN @@ -1964,14 +1935,12 @@ SUBROUTINE collocate_gauge_new(current_env,qs_env,rs_grid_x,rs_grid_y,rs_grid_z, ! CALL get_current_env(current_env=current_env,& - gauge_atom_radius=gauge_atom_radius,& - error=error) + gauge_atom_radius=gauge_atom_radius) ! CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& cell=cell,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) ! natms = SIZE(particle_set,1) dr(1) = rs_grid_x%desc%dh(1,1) @@ -2189,19 +2158,17 @@ END SUBROUTINE current_set_gauge !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_build_chi(current_env,qs_env,iB,error) + SUBROUTINE current_build_chi(current_env,qs_env,iB) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT) :: error IF(current_env%full) THEN - CALL current_build_chi_many_centers(current_env,qs_env,iB,error) + CALL current_build_chi_many_centers(current_env,qs_env,iB) ELSE - CALL current_build_chi_one_center(current_env,qs_env,iB,error) + CALL current_build_chi_one_center(current_env,qs_env,iB) ENDIF END SUBROUTINE current_build_chi @@ -2212,14 +2179,12 @@ END SUBROUTINE current_build_chi !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) + SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'current_build_chi_many_centers', & @@ -2274,7 +2239,7 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) op_p_ao,psi1_p,psi1_rxp,psi1_D,p_rxp,r_p1,r_p2,rr_rxp,rr_p1,rr_p2,& cell,psi0_order,particle_set,qs_kind_set) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) CALL get_qs_env(qs_env=qs_env,& @@ -2286,8 +2251,7 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) particle_set=particle_set,& qs_kind_set=qs_kind_set,& sab_all=sab_all,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) nspins = dft_control%nspins gapw = dft_control%qs_control%gapw @@ -2302,8 +2266,7 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) psi1_rxp=psi1_rxp,& psi1_D=psi1_D,& nstates=nstates,& - psi0_order=psi0_order,& - error=error) + psi0_order=psi0_order) ! ! get max nbr of states per center max_states = 0 @@ -2316,73 +2279,71 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ! ! Allocate sparse matrices for dipole, quadrupole and their derivatives => 9x3 ! Remember the derivatives are antisymmetric - CALL cp_dbcsr_allocate_matrix_set(op_mom_ao,9,error=error) - CALL cp_dbcsr_allocate_matrix_set(op_mom_der_ao,9,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(op_mom_ao,9) + CALL cp_dbcsr_allocate_matrix_set(op_mom_der_ao,9,3) ! ! prepare for allocation natom = SIZE(particle_set,1) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! ALLOCATE(op_mom_ao(1)%matrix) - CALL cp_dbcsr_init(op_mom_ao(1)%matrix,error=error) + CALL cp_dbcsr_init(op_mom_ao(1)%matrix) CALL cp_dbcsr_create(matrix=op_mom_ao(1)%matrix, & name="op_mom", & dist=dbcsr_dist, matrix_type=dbcsr_type_no_symmetry,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(op_mom_ao(1)%matrix,sab_all,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(op_mom_ao(1)%matrix,sab_all) DO idir2=1,3 ALLOCATE(op_mom_der_ao(1,idir2)%matrix) - CALL cp_dbcsr_init(op_mom_der_ao(1,idir2)%matrix, error=error) + CALL cp_dbcsr_init(op_mom_der_ao(1,idir2)%matrix) CALL cp_dbcsr_copy(op_mom_der_ao(1,idir2)%matrix,op_mom_ao(1)%matrix,& - "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir2))),error) + "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir2)))) ENDDO DO idir = 2,SIZE(op_mom_ao,1) ALLOCATE(op_mom_ao(idir)%matrix) - CALL cp_dbcsr_init(op_mom_ao(idir)%matrix, error=error) + CALL cp_dbcsr_init(op_mom_ao(idir)%matrix) CALL cp_dbcsr_copy(op_mom_ao(idir)%matrix,op_mom_ao(1)%matrix,& - "op_mom_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir))),error) + "op_mom_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir)))) DO idir2=1,3 ALLOCATE(op_mom_der_ao(idir,idir2)%matrix) - CALL cp_dbcsr_init(op_mom_der_ao(idir,idir2)%matrix, error=error) + CALL cp_dbcsr_init(op_mom_der_ao(idir,idir2)%matrix) CALL cp_dbcsr_copy(op_mom_der_ao(idir,idir2)%matrix,op_mom_ao(1)%matrix,& - "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir*idir2))),error) + "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir*idir2)))) ENDDO ENDDO ! - CALL cp_dbcsr_allocate_matrix_set(op_p_ao,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(op_p_ao,3) ALLOCATE(op_p_ao(1)%matrix) - CALL cp_dbcsr_init(op_p_ao(1)%matrix,error=error) + CALL cp_dbcsr_init(op_p_ao(1)%matrix) CALL cp_dbcsr_create(matrix=op_p_ao(1)%matrix, & name="op_p_ao", & dist=dbcsr_dist, matrix_type=dbcsr_type_antisymmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(op_p_ao(1)%matrix, sab_orb, error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(op_p_ao(1)%matrix, sab_orb) DO idir=2,3 ALLOCATE(op_p_ao(idir)%matrix) - CALL cp_dbcsr_init(op_p_ao(idir)%matrix, error=error) + CALL cp_dbcsr_init(op_p_ao(idir)%matrix) CALL cp_dbcsr_copy(op_p_ao(idir)%matrix,op_p_ao(1)%matrix,& - "op_p_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir))),error) + "op_p_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir)))) ENDDO ! ! @@ -2394,38 +2355,36 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=max_states,para_env=para_env,& - context=mo_coeff%matrix_struct%context,& - error=error) - CALL cp_fm_create(psi0,tmp_fm_struct,error=error) - CALL cp_fm_create(psi_D,tmp_fm_struct,error=error) - CALL cp_fm_create(psi_rxp,tmp_fm_struct,error=error) - CALL cp_fm_create(psi_p1,tmp_fm_struct,error=error) - CALL cp_fm_create(psi_p2,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(psi0,tmp_fm_struct) + CALL cp_fm_create(psi_D,tmp_fm_struct) + CALL cp_fm_create(psi_rxp,tmp_fm_struct) + CALL cp_fm_create(psi_p1,tmp_fm_struct) + CALL cp_fm_create(psi_p2,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ! ALLOCATE(p_rxp(3),r_p1(3),r_p2(3),rr_rxp(9,3),rr_p1(9,3),rr_p2(9,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=max_states,para_env=para_env,& - context=mo_coeff%matrix_struct%context,& - error=error) + context=mo_coeff%matrix_struct%context) DO idir = 1,3 - CALL cp_fm_create(p_rxp(idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(r_p1(idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(r_p2(idir)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(p_rxp(idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(r_p1(idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(r_p2(idir)%matrix,tmp_fm_struct) DO idir2 = 1,9 - CALL cp_fm_create(rr_rxp(idir2,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(rr_p1(idir2,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(rr_p2(idir2,idir)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(rr_rxp(idir2,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(rr_p1(idir2,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(rr_p2(idir2,idir)%matrix,tmp_fm_struct) ENDDO ENDDO - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_fm_struct_release(tmp_fm_struct) ! ! ! ! recompute the linear momentum matrices - CALL build_lin_mom_matrix(qs_env,op_p_ao,error) - !CALL p_xyz_ao(op_p_ao,qs_env,minimum_image=.FALSE.,error=error) + CALL build_lin_mom_matrix(qs_env,op_p_ao) + !CALL p_xyz_ao(op_p_ao,qs_env,minimum_image=.FALSE.) ! ! ! get iiB and iiiB @@ -2450,20 +2409,20 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ! Compute the multipole integrals for the state istate, ! using as reference center the corresponding Wannier center DO idir = 1,9 - CALL cp_dbcsr_set(op_mom_ao(idir)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(op_mom_ao(idir)%matrix,0.0_dp) DO idir2 = 1,3 - CALL cp_dbcsr_set(op_mom_der_ao(idir,idir2)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(op_mom_der_ao(idir,idir2)%matrix,0.0_dp) ENDDO ENDDO CALL rRc_xyz_der_ao(op_mom_ao,op_mom_der_ao,qs_env,dk,order=2,& - minimum_image=.FALSE.,soft=gapw,error=error) + minimum_image=.FALSE.,soft=gapw) ! ! collecte the states that belong to a given center - CALL cp_fm_set_all(psi0,0.0_dp,error=error) - CALL cp_fm_set_all(psi_rxp,0.0_dp,error=error) - CALL cp_fm_set_all(psi_D,0.0_dp,error=error) - CALL cp_fm_set_all(psi_p1,0.0_dp,error=error) - CALL cp_fm_set_all(psi_p2,0.0_dp,error=error) + CALL cp_fm_set_all(psi0,0.0_dp) + CALL cp_fm_set_all(psi_rxp,0.0_dp) + CALL cp_fm_set_all(psi_D,0.0_dp) + CALL cp_fm_set_all(psi_p1,0.0_dp) + CALL cp_fm_set_all(psi_p2,0.0_dp) nstate_loc = center_list(ispin)%array(1,icenter+1)-center_list(ispin)%array(1,icenter) jstate = 1 DO j = center_list(ispin)%array(1,icenter),center_list(ispin)%array(1,icenter+1)-1 @@ -2483,40 +2442,34 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ENDDO ! istate ! ! scale the ordered mos - IF(current_env%full) CALL cp_fm_scale_and_add(1.0_dp,psi_rxp,-1.0_dp,psi_D,error=error) + IF(current_env%full) CALL cp_fm_scale_and_add(1.0_dp,psi_rxp,-1.0_dp,psi_D) ! DO idir = 1,3 CALL set_vecp(idir,ii,iii) CALL cp_dbcsr_sm_fm_multiply(op_p_ao(idir)%matrix,psi_rxp,& - p_rxp(idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp,& - error=error) + p_rxp(idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp) IF(iiiB.EQ.iii.OR.iiiB.EQ.ii) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_ao(idir)%matrix,psi_p1,& - r_p1(idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp,& - error=error) + r_p1(idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp) ENDIF IF(iiB.EQ.iii.OR.iiB.EQ.ii) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_ao(idir)%matrix,psi_p2,& - r_p2(idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp,& - error=error) + r_p2(idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp) ENDIF DO idir2 = 1,9 IF(idir2.EQ.ii.OR.idir2.EQ.iii) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(idir2,idir)%matrix,psi_rxp,& - rr_rxp(idir2,idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp,& - error=error) + rr_rxp(idir2,idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp) ENDIF ! IF(idir2.EQ.ind_m2(ii,iiiB).OR.idir2.EQ.ind_m2(iii,iiiB).OR.idir2.EQ.iiiB) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(idir2,idir)%matrix,psi_p1,& - rr_p1(idir2,idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp,& - error=error) + rr_p1(idir2,idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp) ENDIF ! IF(idir2.EQ.ind_m2(ii,iiB).OR.idir2.EQ.ind_m2(iii,iiB).OR.idir2.EQ.iiB) THEN CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(idir2,idir)%matrix,psi_p2,& - rr_p2(idir2,idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp,& - error=error) + rr_p2(idir2,idir)%matrix,ncol=nstate_loc,alpha=1.e0_dp) ENDIF ENDDO ENDDO @@ -2537,22 +2490,22 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ! term: 2[C0| (r-dk)_ii |d_iii(C1(rxp-D))]-2[C0| (r-dk)_iii |d_ii(C1(rxp-D))] ! the factor 2 should be already included in the matrix elements contrib = 0.0_dp - CALL cp_fm_trace(psi0,rr_rxp(ii,iii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_rxp(ii,iii)%matrix,contrib) chi_tmp = chi_tmp + 2.0_dp * contrib ! contrib = 0.0_dp - CALL cp_fm_trace(psi0,rr_rxp(iii,ii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_rxp(iii,ii)%matrix,contrib) chi_tmp = chi_tmp - 2.0_dp * contrib ! ! correction: dk_ii*2[C0| d_iii(C1(rxp-D))] - dk_iii*2[C0| d_ii(C1(rxp-D))] ! factor 2 not included in the matrix elements contrib = 0.0_dp - CALL cp_fm_trace(psi0,p_rxp(iii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,p_rxp(iii)%matrix,contrib) IF(.NOT.chi_pbc) chi_tmp = chi_tmp + 2.0_dp * dk(ii) * contrib int_current_tmp = int_current_tmp + 2.0_dp * contrib ! contrib2 = 0.0_dp - CALL cp_fm_trace(psi0,p_rxp(ii)%matrix,contrib2,error=error) + CALL cp_fm_trace(psi0,p_rxp(ii)%matrix,contrib2) IF(.NOT.chi_pbc) chi_tmp = chi_tmp - 2.0_dp * dk(iii) * contrib2 ! ! term: -2[C0| (r-dk)_ii (r-dk)_iiB | d_iii(C1(piiiB))] \ @@ -2560,21 +2513,21 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ! the factor 2 should be already included in the matrix elements contrib = 0.0_dp idir2 = ind_m2(ii,iiB) - CALL cp_fm_trace(psi0,rr_p2(idir2,iii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_p2(idir2,iii)%matrix,contrib) chi_tmp = chi_tmp - 2.0_dp * contrib contrib2 = 0.0_dp IF(iiB==iii) THEN - CALL cp_fm_trace(psi0,r_p2(ii)%matrix,contrib2,error=error) + CALL cp_fm_trace(psi0,r_p2(ii)%matrix,contrib2) chi_tmp = chi_tmp - contrib2 ENDIF ! contrib = 0.0_dp idir2 = ind_m2(iii,iiB) - CALL cp_fm_trace(psi0,rr_p2(idir2,ii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_p2(idir2,ii)%matrix,contrib) chi_tmp = chi_tmp + 2.0_dp * contrib contrib2 = 0.0_dp IF(iiB==ii) THEN - CALL cp_fm_trace(psi0,r_p2(iii)%matrix,contrib2,error=error) + CALL cp_fm_trace(psi0,r_p2(iii)%matrix,contrib2) chi_tmp = chi_tmp + contrib2 ENDIF ! @@ -2583,12 +2536,12 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ! the factor 2 should be already included in the matrix elements ! no additional correction terms because of the orthogonality between C0 and C1 contrib = 0.0_dp - CALL cp_fm_trace(psi0,rr_p2(iiB,iii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_p2(iiB,iii)%matrix,contrib) IF(.NOT.chi_pbc) chi_tmp = chi_tmp - 2.0_dp * dk(ii) * contrib int_current_tmp = int_current_tmp - 2.0_dp * contrib ! contrib2 = 0.0_dp - CALL cp_fm_trace(psi0,rr_p2(iiB,ii)%matrix,contrib2,error=error) + CALL cp_fm_trace(psi0,rr_p2(iiB,ii)%matrix,contrib2) IF(.NOT.chi_pbc) chi_tmp = chi_tmp + 2.0_dp * dk(iii) * contrib2 ! ! term: +2[C0| (r-dk)_ii (r-dk)_iiiB | d_iii(C1(piiB))] \ @@ -2596,21 +2549,21 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ! the factor 2 should be already included in the matrix elements contrib = 0.0_dp idir2 = ind_m2(ii,iiiB) - CALL cp_fm_trace(psi0,rr_p1(idir2,iii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_p1(idir2,iii)%matrix,contrib) chi_tmp = chi_tmp + 2.0_dp * contrib contrib2 = 0.0_dp IF(iiiB==iii) THEN - CALL cp_fm_trace(psi0,r_p1(ii)%matrix,contrib2,error=error) + CALL cp_fm_trace(psi0,r_p1(ii)%matrix,contrib2) chi_tmp = chi_tmp + contrib2 ENDIF ! contrib = 0.0_dp idir2 = ind_m2(iii,iiiB) - CALL cp_fm_trace(psi0,rr_p1(idir2,ii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_p1(idir2,ii)%matrix,contrib) chi_tmp = chi_tmp - 2.0_dp * contrib contrib2 = 0.0_dp IF(iiiB==ii) THEN - CALL cp_fm_trace(psi0,r_p1(iii)%matrix,contrib2,error=error) + CALL cp_fm_trace(psi0,r_p1(iii)%matrix,contrib2) chi_tmp = chi_tmp - contrib2 ENDIF ! @@ -2618,12 +2571,12 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ! -dk_iii * 2[C0|(r-dk)_iiiB | d_ii(C1(piiB))] ! the factor 2 should be already included in the matrix elements contrib = 0.0_dp - CALL cp_fm_trace(psi0,rr_p1(iiiB,iii)%matrix,contrib,error=error) + CALL cp_fm_trace(psi0,rr_p1(iiiB,iii)%matrix,contrib) IF(.NOT.chi_pbc) chi_tmp = chi_tmp + 2.0_dp * dk(ii) * contrib int_current_tmp = int_current_tmp + 2.0_dp * contrib ! contrib2 = 0.0_dp - CALL cp_fm_trace(psi0,rr_p1(iiiB,ii)%matrix,contrib2,error=error) + CALL cp_fm_trace(psi0,rr_p1(iiiB,ii)%matrix,contrib2) IF(.NOT.chi_pbc) chi_tmp = chi_tmp - 2.0_dp * dk(iii) * contrib2 ! ! accumulate @@ -2647,27 +2600,27 @@ SUBROUTINE current_build_chi_many_centers(current_env,qs_env,iB,error) ENDDO ! ispin ! ! deallocate the sparse matrices - CALL cp_dbcsr_deallocate_matrix_set(op_mom_ao,error=error) - CALL cp_dbcsr_deallocate_matrix_set(op_mom_der_ao,error=error) - CALL cp_dbcsr_deallocate_matrix_set(op_p_ao,error=error) - - CALL cp_fm_release(psi0,error=error) - CALL cp_fm_release(psi_rxp,error=error) - CALL cp_fm_release(psi_D,error=error) - CALL cp_fm_release(psi_p1,error=error) - CALL cp_fm_release(psi_p2,error=error) + CALL cp_dbcsr_deallocate_matrix_set(op_mom_ao) + CALL cp_dbcsr_deallocate_matrix_set(op_mom_der_ao) + CALL cp_dbcsr_deallocate_matrix_set(op_p_ao) + + CALL cp_fm_release(psi0) + CALL cp_fm_release(psi_rxp) + CALL cp_fm_release(psi_D) + CALL cp_fm_release(psi_p1) + CALL cp_fm_release(psi_p2) DO idir = 1,3 - CALL cp_fm_release(p_rxp(idir)%matrix,error=error) - CALL cp_fm_release(r_p1(idir)%matrix,error=error) - CALL cp_fm_release(r_p2(idir)%matrix,error=error) + CALL cp_fm_release(p_rxp(idir)%matrix) + CALL cp_fm_release(r_p1(idir)%matrix) + CALL cp_fm_release(r_p2(idir)%matrix) DO idir2 = 1,9 - CALL cp_fm_release(rr_rxp(idir2,idir)%matrix,error=error) - CALL cp_fm_release(rr_p1(idir2,idir)%matrix,error=error) - CALL cp_fm_release(rr_p2(idir2,idir)%matrix,error=error) + CALL cp_fm_release(rr_rxp(idir2,idir)%matrix) + CALL cp_fm_release(rr_p1(idir2,idir)%matrix) + CALL cp_fm_release(rr_p2(idir2,idir)%matrix) ENDDO ENDDO DEALLOCATE(p_rxp,r_p1,r_p2,rr_rxp,rr_p1,rr_p2,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -2679,14 +2632,12 @@ END SUBROUTINE current_build_chi_many_centers !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) + SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'current_build_chi_one_center', & routineP = moduleN//':'//routineN @@ -2735,7 +2686,7 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) op_mom_der_ao,center_list,centers_set,& op_p_ao,psi1_p,psi1_rxp,psi1_D,buf,cell,psi0_order) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) CALL get_qs_env(qs_env=qs_env,& @@ -2747,8 +2698,7 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) qs_kind_set=qs_kind_set,& sab_all=sab_all,& sab_orb=sab_orb,& - dbcsr_dist=dbcsr_dist,& - error=error) + dbcsr_dist=dbcsr_dist) nspins = dft_control%nspins gapw = dft_control%qs_control%gapw @@ -2763,80 +2713,77 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) psi1_rxp=psi1_rxp,& psi1_D=psi1_D,& nstates=nstates,& - psi0_order=psi0_order,& - error=error) + psi0_order=psi0_order) ! max_states = MAXVAL(nstates(1:nspins)) ! ! Allocate sparse matrices for dipole, quadrupole and their derivatives => 9x3 ! Remember the derivatives are antisymmetric - CALL cp_dbcsr_allocate_matrix_set(op_mom_ao,9,error=error) - CALL cp_dbcsr_allocate_matrix_set(op_mom_der_ao,9,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(op_mom_ao,9) + CALL cp_dbcsr_allocate_matrix_set(op_mom_der_ao,9,3) ! ! prepare for allocation natom = SIZE(particle_set,1) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! ALLOCATE(op_mom_ao(1)%matrix) - CALL cp_dbcsr_init(op_mom_ao(1)%matrix,error=error) + CALL cp_dbcsr_init(op_mom_ao(1)%matrix) CALL cp_dbcsr_create(matrix=op_mom_ao(1)%matrix, & name="op_mom", & dist=dbcsr_dist, matrix_type=dbcsr_type_no_symmetry,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(op_mom_ao(1)%matrix,sab_all,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(op_mom_ao(1)%matrix,sab_all) DO idir2=1,3 ALLOCATE(op_mom_der_ao(1,idir2)%matrix) - CALL cp_dbcsr_init(op_mom_der_ao(1,idir2)%matrix, error=error) + CALL cp_dbcsr_init(op_mom_der_ao(1,idir2)%matrix) CALL cp_dbcsr_copy(op_mom_der_ao(1,idir2)%matrix,op_mom_ao(1)%matrix,& - "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir2))),error) + "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir2)))) ENDDO DO idir = 2,SIZE(op_mom_ao,1) ALLOCATE(op_mom_ao(idir)%matrix) - CALL cp_dbcsr_init(op_mom_ao(idir)%matrix, error=error) + CALL cp_dbcsr_init(op_mom_ao(idir)%matrix) CALL cp_dbcsr_copy(op_mom_ao(idir)%matrix,op_mom_ao(1)%matrix,& - "op_mom_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir))),error) + "op_mom_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir)))) DO idir2=1,3 ALLOCATE(op_mom_der_ao(idir,idir2)%matrix) - CALL cp_dbcsr_init(op_mom_der_ao(idir,idir2)%matrix, error=error) + CALL cp_dbcsr_init(op_mom_der_ao(idir,idir2)%matrix) CALL cp_dbcsr_copy(op_mom_der_ao(idir,idir2)%matrix,op_mom_ao(1)%matrix,& - "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir*idir2))),error) + "op_mom_der_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir*idir2)))) ENDDO ENDDO ! - CALL cp_dbcsr_allocate_matrix_set(op_p_ao,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(op_p_ao,3) ALLOCATE(op_p_ao(1)%matrix) - CALL cp_dbcsr_init(op_p_ao(1)%matrix,error=error) + CALL cp_dbcsr_init(op_p_ao(1)%matrix) CALL cp_dbcsr_create(matrix=op_p_ao(1)%matrix, & name="op_p_ao", & dist=dbcsr_dist, matrix_type=dbcsr_type_antisymmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(op_p_ao(1)%matrix, sab_orb, error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(op_p_ao(1)%matrix, sab_orb) DO idir=2,3 ALLOCATE(op_p_ao(idir)%matrix) - CALL cp_dbcsr_init(op_p_ao(idir)%matrix, error=error) + CALL cp_dbcsr_init(op_p_ao(idir)%matrix) CALL cp_dbcsr_copy(op_p_ao(idir)%matrix,op_p_ao(1)%matrix,& - "op_p_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir))),error) + "op_p_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir)))) ENDDO ! ! @@ -2848,23 +2795,22 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=max_states,para_env=para_env,& - context=mo_coeff%matrix_struct%context,& - error=error) - CALL cp_fm_create(buf,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(buf,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ! ! ! ! recompute the linear momentum matrices - CALL build_lin_mom_matrix(qs_env,op_p_ao,error) - !CALL p_xyz_ao(op_p_ao,qs_env,minimum_image=.FALSE.,error=error) + CALL build_lin_mom_matrix(qs_env,op_p_ao) + !CALL p_xyz_ao(op_p_ao,qs_env,minimum_image=.FALSE.) ! ! ! get iiB and iiiB CALL set_vecp(iB,iiB,iiiB) DO ispin = 1,nspins ! - CPPostcondition(nbr_center(ispin)==1,cp_failure_level,routineP,error,failure) + CPPostcondition(nbr_center(ispin)==1,cp_failure_level,routineP,failure) ! ! get ground state MOS nmo = nstates(ispin) @@ -2882,13 +2828,13 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) ! Compute the multipole integrals for the state istate, ! using as reference center the corresponding Wannier center DO idir = 1,9 - CALL cp_dbcsr_set(op_mom_ao(idir)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(op_mom_ao(idir)%matrix,0.0_dp) DO idir2 = 1,3 - CALL cp_dbcsr_set(op_mom_der_ao(idir,idir2)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(op_mom_der_ao(idir,idir2)%matrix,0.0_dp) ENDDO ENDDO CALL rRc_xyz_der_ao(op_mom_ao,op_mom_der_ao,qs_env,dk,order=2,& - minimum_image=.FALSE.,soft=gapw,error=error) + minimum_image=.FALSE.,soft=gapw) ! ! ! Multuply left and right by the appropriate coefficients and sum into the @@ -2904,11 +2850,11 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) ! term: dk_ii*2[C0| d_iii(C1(rxp-D))] - dk_iii*2[C0| d_ii(C1(rxp-D))] IF(.NOT.chi_pbc) THEN CALL cp_dbcsr_sm_fm_multiply(op_p_ao(idir)%matrix,mo_coeff,& - buf,ncol=nmo,alpha=1.e0_dp,error=error) + buf,ncol=nmo,alpha=1.e0_dp) DO jdir = 1,3 DO kdir = 1,3 IF(Levi_Civita(kdir,jdir,idir).EQ.0.0_dp) CYCLE - CALL cp_fm_trace(buf,psi1_rxp(ispin,iB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_rxp(ispin,iB)%matrix,contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir,jdir,idir) * 2.0_dp * dk(jdir) * contrib ENDDO ENDDO @@ -2925,10 +2871,10 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) ! -dk_iii * 2[C0|(r-dk)_iiiB | d_ii(C1(piiB))] DO jdir = 1,3 CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(jdir,idir)%matrix,mo_coeff,& - buf,ncol=nmo,alpha=1.e0_dp,error=error) + buf,ncol=nmo,alpha=1.e0_dp) DO kdir = 1,3 IF(Levi_Civita(kdir,jdir,idir).EQ.0.0_dp) CYCLE - CALL cp_fm_trace(buf,psi1_rxp(ispin,iB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_rxp(ispin,iB)%matrix,contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir,jdir,idir) * 2.0_dp * contrib ENDDO ! @@ -2937,7 +2883,7 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) DO jjdir = 1,3 DO kdir = 1,3 IF(Levi_Civita(kdir,jjdir,idir).EQ.0.0_dp) CYCLE - CALL cp_fm_trace(buf,psi1_p(ispin,iiiB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_p(ispin,iiiB)%matrix,contrib) chi(kdir) = chi(kdir) + Levi_Civita(kdir,jjdir,idir) * 2.0_dp * dk(jjdir) * contrib ENDDO ENDDO @@ -2947,7 +2893,7 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) DO jjdir = 1,3 DO kdir = 1,3 IF(Levi_Civita(kdir,jjdir,idir).EQ.0.0_dp) CYCLE - CALL cp_fm_trace(buf,psi1_p(ispin,iiB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_p(ispin,iiB)%matrix,contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir,jjdir,idir) * 2.0_dp * dk(jjdir) * contrib ENDDO ENDDO @@ -2965,18 +2911,18 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) ! HERE THERE IS ONE EXTRA MULTIPLY DO jdir = 1,3 CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(ind_m2(jdir,iiB),idir)%matrix,mo_coeff,& - buf,ncol=nmo,alpha=1.e0_dp,error=error) + buf,ncol=nmo,alpha=1.e0_dp) DO kdir = 1,3 IF(Levi_Civita(kdir,jdir,idir).EQ.0.0_dp) CYCLE - CALL cp_fm_trace(buf,psi1_p(ispin,iiiB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_p(ispin,iiiB)%matrix,contrib) chi(kdir) = chi(kdir) + Levi_Civita(kdir,jdir,idir) * 2.0_dp * contrib ENDDO ! CALL cp_dbcsr_sm_fm_multiply(op_mom_der_ao(ind_m2(jdir,iiiB),idir)%matrix,mo_coeff,& - buf,ncol=nmo,alpha=1.e0_dp,error=error) + buf,ncol=nmo,alpha=1.e0_dp) DO kdir = 1,3 IF(Levi_Civita(kdir,jdir,idir).EQ.0.0_dp) CYCLE - CALL cp_fm_trace(buf,psi1_p(ispin,iiB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_p(ispin,iiB)%matrix,contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir,jdir,idir) * 2.0_dp * contrib ENDDO ENDDO @@ -2989,12 +2935,12 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) ! term2: +2[C0| (r-dk)_ii (r-dk)_iiiB | d_iii(C1(piiB))] + ! -2[C0| (r-dk)_iii (r-dk)_iiiB | d_ii(C1(piiB))] CALL cp_dbcsr_sm_fm_multiply(op_mom_ao(idir)%matrix,mo_coeff,& - buf,ncol=nmo,alpha=1.e0_dp,error=error) + buf,ncol=nmo,alpha=1.e0_dp) DO jdir = 1,3 DO kdir = 1,3 IF(Levi_Civita(kdir,idir,jdir).EQ.0.0_dp) CYCLE IF(iiB==jdir) THEN - CALL cp_fm_trace(buf,psi1_p(ispin,iiiB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_p(ispin,iiiB)%matrix,contrib) chi(kdir) = chi(kdir) + Levi_Civita(kdir,idir,jdir) * contrib ENDIF ENDDO @@ -3004,7 +2950,7 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) DO kdir = 1,3 IF(Levi_Civita(kdir,idir,jdir).EQ.0.0_dp) CYCLE IF(iiiB==jdir) THEN - CALL cp_fm_trace(buf,psi1_p(ispin,iiB)%matrix,contrib,error=error) + CALL cp_fm_trace(buf,psi1_p(ispin,iiB)%matrix,contrib) chi(kdir) = chi(kdir) - Levi_Civita(kdir,idir,jdir) * contrib ENDIF ! @@ -3028,10 +2974,10 @@ SUBROUTINE current_build_chi_one_center(current_env,qs_env,iB,error) ENDDO ! ispin ! ! deallocate the sparse matrices - CALL cp_dbcsr_deallocate_matrix_set(op_mom_ao,error=error) - CALL cp_dbcsr_deallocate_matrix_set(op_mom_der_ao,error=error) - CALL cp_dbcsr_deallocate_matrix_set(op_p_ao,error=error) - CALL cp_fm_release(buf,error=error) + CALL cp_dbcsr_deallocate_matrix_set(op_mom_ao) + CALL cp_dbcsr_deallocate_matrix_set(op_mom_der_ao) + CALL cp_dbcsr_deallocate_matrix_set(op_p_ao) + CALL cp_fm_release(buf) CALL timestop(handle) diff --git a/src/qs_linres_current_utils.F b/src/qs_linres_current_utils.F index d51c9220fc..a92326b29c 100644 --- a/src/qs_linres_current_utils.F +++ b/src/qs_linres_current_utils.F @@ -125,14 +125,12 @@ MODULE qs_linres_current_utils !> \param current_env ... !> \param p_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_response(current_env,p_env,qs_env,error) + SUBROUTINE current_response(current_env,p_env,qs_env) ! TYPE(current_env_type) :: current_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'current_response', & routineP = moduleN//':'//routineN @@ -190,14 +188,14 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) list_cubes, statetrueindex, centers_set, center_list, psi1_p, psi1_rxp, psi1_D, & p_psi0, rxp_psi0, psi0_order, op_p_ao, sab_orb, particle_set) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ionode = logger%para_env%mepos==logger%para_env%source - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") current_section => section_vals_get_subs_vals(qs_env%input, & - "PROPERTIES%LINRES%CURRENT",error=error) + "PROPERTIES%LINRES%CURRENT") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(T10,A,/)")& "*** Self consistent optimization of the response wavefunctions ***" @@ -211,7 +209,7 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) particle_set=particle_set,& qs_kind_set=qs_kind_set,& dbcsr_dist=dbcsr_dist,& - para_env=para_env,error=error) + para_env=para_env) nspins = dft_control%nspins @@ -228,68 +226,64 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) psi1_D=psi1_D,& p_psi0=p_psi0, & rxp_psi0=rxp_psi0, & - psi0_order=psi0_order,& - error=error) + psi0_order=psi0_order) ! ! allocate the vectors IF(current_env%full) THEN ALLOCATE(psi1(nspins),h1_psi0(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins mo_coeff => psi0_order(ispin)%matrix NULLIFY(tmp_fm_struct,psi1(ispin)%matrix,h1_psi0(ispin)%matrix) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=nstates(ispin),& - context=mo_coeff%matrix_struct%context,& - error=error) - CALL cp_fm_create(psi1(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(h1_psi0(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(psi1(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create(h1_psi0(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ENDDO ! ! prepare for allocation natom = SIZE(particle_set,1) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) DEALLOCATE (first_sgf,last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! rebuild the linear momentum matrices - CALL cp_dbcsr_allocate_matrix_set(op_p_ao,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(op_p_ao,3) ALLOCATE(op_p_ao(1)%matrix) - CALL cp_dbcsr_init(op_p_ao(1)%matrix,error=error) + CALL cp_dbcsr_init(op_p_ao(1)%matrix) CALL cp_dbcsr_create(matrix=op_p_ao(1)%matrix, & name="OP_P", & dist=dbcsr_dist, matrix_type=dbcsr_type_antisymmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(op_p_ao(1)%matrix,sab_orb,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(op_p_ao(1)%matrix,sab_orb) ! ! DEALLOCATE(row_blk_sizes) ! ! - CALL cp_dbcsr_set(op_p_ao(1)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(op_p_ao(1)%matrix,0.0_dp) DO idir = 2,3 ALLOCATE(op_p_ao(idir)%matrix) - CALL cp_dbcsr_init(op_p_ao(idir)%matrix,error=error) + CALL cp_dbcsr_init(op_p_ao(idir)%matrix) CALL cp_dbcsr_copy(op_p_ao(idir)%matrix,op_p_ao(1)%matrix,& - "current_env%op_p_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir))),& - error=error) - CALL cp_dbcsr_set(op_p_ao(idir)%matrix,0.0_dp,error=error) + "current_env%op_p_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir)))) + CALL cp_dbcsr_set(op_p_ao(idir)%matrix,0.0_dp) ENDDO ! - !CALL p_xyz_ao(op_p_ao,qs_env,minimum_image=.FALSE.,error=error) - CALL build_lin_mom_matrix(qs_env,op_p_ao,error) + !CALL p_xyz_ao(op_p_ao,qs_env,minimum_image=.FALSE.) + CALL build_lin_mom_matrix(qs_env,op_p_ao) ! ENDIF ! @@ -297,9 +291,9 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ! DO idir = 1,3 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1_p(ispin,idir)%matrix ,0.0_dp,error=error) - CALL cp_fm_set_all(psi1_rxp(ispin,idir)%matrix,0.0_dp,error=error) - IF(current_env%full) CALL cp_fm_set_all(psi1_D(ispin,idir)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1_p(ispin,idir)%matrix ,0.0_dp) + CALL cp_fm_set_all(psi1_rxp(ispin,idir)%matrix,0.0_dp) + IF(current_env%full) CALL cp_fm_set_all(psi1_D(ispin,idir)%matrix,0.0_dp) ENDDO ENDDO ! @@ -312,10 +306,10 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) DO idir = 1,3 ! operator p psi1_ptr => psi1_p(:,idir) - CALL linres_read_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_p",error=error) + CALL linres_read_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_p") ! operator rxp psi1_ptr => psi1_rxp(:,idir) - CALL linres_read_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_rxp",error=error) + CALL linres_read_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_rxp") ENDDO ENDIF ! @@ -337,15 +331,15 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ! ! linres_control%converged = .FALSE. - CALL linres_solver(p_env,qs_env,psi1_ptr,hpsi0_ptr,psi0_order,should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1_ptr,hpsi0_ptr,psi0_order,should_stop) ! ! ! print response functions IF(BTEST(cp_print_key_should_output(logger%iter_info,current_section,& - & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN ncubes = SIZE(list_cubes,1) - print_key => section_vals_get_subs_vals(current_section,"PRINT%RESPONSE_FUNCTION_CUBES",error=error) - append_cube = section_get_lval(current_section,"PRINT%RESPONSE_FUNCTION_CUBES%APPEND",error=error) + print_key => section_vals_get_subs_vals(current_section,"PRINT%RESPONSE_FUNCTION_CUBES") + append_cube = section_get_lval(current_section,"PRINT%RESPONSE_FUNCTION_CUBES%APPEND") my_pos = "REWIND" IF(append_cube) THEN my_pos = "APPEND" @@ -355,12 +349,12 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) DO ispin = 1,nspins CALL qs_print_cubes(qs_env,psi1_ptr(ispin)%matrix,ncubes,list_cubes,& centers_set(ispin)%array,print_key,'psi1_p',& - idir=idir,ispin=ispin,file_position=my_pos,error=error) + idir=idir,ispin=ispin,file_position=my_pos) ENDDO ! ispin ENDIF ! print response functions ! ! write restart file - CALL linres_write_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_p",error=error) + CALL linres_write_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_p") ENDDO ! idir ! ! operator rxp @@ -376,23 +370,23 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ! ! linres_control%converged = .FALSE. - CALL linres_solver(p_env,qs_env,psi1_ptr,hpsi0_ptr,psi0_order,should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1_ptr,hpsi0_ptr,psi0_order,should_stop) ! ! print response functions IF(BTEST(cp_print_key_should_output(logger%iter_info,current_section,& - & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN ncubes = SIZE(list_cubes,1) - print_key => section_vals_get_subs_vals(current_section,"PRINT%RESPONSE_FUNCTION_CUBES",error=error) + print_key => section_vals_get_subs_vals(current_section,"PRINT%RESPONSE_FUNCTION_CUBES") DO ispin = 1,nspins CALL qs_print_cubes(qs_env,psi1_ptr(ispin)%matrix,ncubes,list_cubes,& centers_set(ispin)%array,print_key,'psi1_rxp',& - idir=idir,ispin=ispin,file_position=my_pos, error=error) + idir=idir,ispin=ispin,file_position=my_pos) ENDDO ! ispin ENDIF ! print response functions ! ! write restart file - CALL linres_write_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_rxp",error=error) + CALL linres_write_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_rxp") ENDDO ! idir IF(.NOT. should_stop) current_env%all_pert_op_done =.TRUE. ! @@ -402,7 +396,7 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ! ! DO ispin = 1,nspins - CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp) ENDDO ! ! The correction is state depedent a loop over the states is necessary @@ -411,7 +405,7 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ! ALLOCATE(vecbuf_dklxp0(1,nao),fm_work_ii(nspins),fm_work_iii(nspins),& dkl_vec_ii(max_states),dkl_vec_iii(max_states),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vecbuf_dklxp0(1,nao) = 0.0_dp ! DO ispin = 1,nspins @@ -420,25 +414,24 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) NULLIFY(tmp_fm_struct,fm_work_ii(ispin)%matrix,fm_work_iii(ispin)%matrix) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=nmo,para_env=para_env,& - context=mo_coeff%matrix_struct%context,& - error=error) + context=mo_coeff%matrix_struct%context) - CALL cp_fm_create(fm_work_ii(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_set_all(fm_work_ii(ispin)%matrix,0.0_dp,error=error) - CALL cp_fm_create(fm_work_iii(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_set_all(fm_work_iii(ispin)%matrix,0.0_dp,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_fm_create(fm_work_ii(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_set_all(fm_work_ii(ispin)%matrix,0.0_dp) + CALL cp_fm_create(fm_work_iii(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_set_all(fm_work_iii(ispin)%matrix,0.0_dp) + CALL cp_fm_struct_release(tmp_fm_struct) ENDDO ! ispin ! DO idir = 1,3 IF(should_stop) EXIT DO ispin = 1,nspins - CALL cp_fm_set_all(psi1_D(ispin,idir)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1_D(ispin,idir)%matrix,0.0_dp) END DO first_center = 0 IF(linres_control%linres_restart) THEN psi1_ptr => psi1_D(:,idir) - CALL linres_read_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_dxp-",ind=first_center,error=error) + CALL linres_read_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_dxp-",ind=first_center) END IF IF(first_center>0) THEN IF(output_unit>0) THEN @@ -468,8 +461,8 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) IF(icenter.GT.nbr_center(ispin)) THEN ! ! set h1_psi0 and psi1 to zero to avoid problems in linres_scf - CALL cp_fm_set_all(h1_psi0(ispin)%matrix,0.0_dp,error=error) - CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(h1_psi0(ispin)%matrix,0.0_dp) + CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp) CYCLE ENDIF ! @@ -494,40 +487,37 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ! ! First term ! Rescale the ground state orbitals by (dk-dl)_ii - CALL cp_fm_to_fm(mo_coeff,fm_work_ii(ispin)%matrix,error=error) + CALL cp_fm_to_fm(mo_coeff,fm_work_ii(ispin)%matrix) CALL cp_fm_column_scale(fm_work_ii(ispin)%matrix,dkl_vec_ii(1:nmo)) ! ! Apply the p_iii operator ! fm_work_iii = -p_iii * (dk-dl)_ii * C0 CALL cp_dbcsr_sm_fm_multiply(op_p_ao(iii)%matrix,fm_work_ii(ispin)%matrix,& - fm_work_iii(ispin)%matrix,ncol=nmo,alpha=-1.0_dp,& - error=error) + fm_work_iii(ispin)%matrix,ncol=nmo,alpha=-1.0_dp) ! ! Copy in h1_psi0 ! h1_psi0_i = fm_work_iii - CALL cp_fm_to_fm(fm_work_iii(ispin)%matrix,h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_to_fm(fm_work_iii(ispin)%matrix,h1_psi0(ispin)%matrix) ! ! Second term ! Rescale the ground state orbitals by (dk-dl)_iii - CALL cp_fm_to_fm(mo_coeff,fm_work_iii(ispin)%matrix,error=error) + CALL cp_fm_to_fm(mo_coeff,fm_work_iii(ispin)%matrix) CALL cp_fm_column_scale(fm_work_iii(ispin)%matrix,dkl_vec_iii(1:nmo)) ! ! Apply the p_ii operator ! fm_work_ii = -p_ii * (dk-dl)_iii * C0 CALL cp_dbcsr_sm_fm_multiply(op_p_ao(ii)%matrix,fm_work_iii(ispin)%matrix,& - fm_work_ii(ispin)%matrix,ncol=nmo,alpha=-1.0_dp,& - error=error) + fm_work_ii(ispin)%matrix,ncol=nmo,alpha=-1.0_dp) ! ! Copy in h1_psi0 ! h1_psi0_i = fm_work_iii - fm_work_ii CALL cp_fm_scale_and_add(1.0_dp,h1_psi0(ispin)%matrix,& - & -1.0_dp,fm_work_ii(ispin)%matrix,& - error=error) + & -1.0_dp,fm_work_ii(ispin)%matrix) ENDDO ! ! Optimize the response wavefunctions - CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop) ! IF(output_unit>0) THEN WRITE(output_unit,"(T10,A,/)")& @@ -556,19 +546,19 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ENDDO ! ispin END IF psi1_ptr => psi1_D(:,idir) - CALL linres_write_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_dxp-",ind=icenter,error=error) + CALL linres_write_restart(qs_env,lr_section,psi1_ptr,idir,"nmr_dxp-",ind=icenter) ENDDO ! center ! ! print response functions IF(BTEST(cp_print_key_should_output(logger%iter_info,current_section,& - & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN ncubes = SIZE(list_cubes,1) - print_key => section_vals_get_subs_vals(current_section,"PRINT%RESPONSE_FUNCTION_CUBES",error=error) + print_key => section_vals_get_subs_vals(current_section,"PRINT%RESPONSE_FUNCTION_CUBES") DO ispin = 1,nspins CALL qs_print_cubes(qs_env,psi1_D(ispin,idir)%matrix,& ncubes,list_cubes,centers_set(ispin)%array,print_key,'psi1_D',& - idir=idir,ispin=ispin, file_position=my_pos,error=error) + idir=idir,ispin=ispin, file_position=my_pos) ENDDO ENDIF ! print response functions ! @@ -577,27 +567,27 @@ SUBROUTINE current_response(current_env,p_env,qs_env,error) ! ! clean up DO ispin = 1,nspins - CALL cp_fm_release(fm_work_ii(ispin)%matrix,error=error) - CALL cp_fm_release(fm_work_iii(ispin)%matrix,error=error) + CALL cp_fm_release(fm_work_ii(ispin)%matrix) + CALL cp_fm_release(fm_work_iii(ispin)%matrix) ENDDO DEALLOCATE(fm_work_ii,fm_work_iii,dkl_vec_ii,dkl_vec_iii,vecbuf_dklxp0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! ! clean up IF(current_env%full) THEN - CALL cp_dbcsr_deallocate_matrix_set(op_p_ao,error=error) + CALL cp_dbcsr_deallocate_matrix_set(op_p_ao) DO ispin = 1,nspins - CALL cp_fm_release(psi1(ispin)%matrix,error=error) - CALL cp_fm_release(h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_release(psi1(ispin)%matrix) + CALL cp_fm_release(h1_psi0(ispin)%matrix) ENDDO DEALLOCATE(psi1,h1_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - & "PRINT%PROGRAM_RUN_INFO",error=error) + & "PRINT%PROGRAM_RUN_INFO") ! CALL timestop(handle) ! @@ -609,13 +599,11 @@ END SUBROUTINE current_response !> \brief ... !> \param current_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_env_init(current_env,qs_env,error) + SUBROUTINE current_env_init(current_env,qs_env) ! TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'current_env_init', & routineP = moduleN//':'//routineN @@ -684,8 +672,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) particle_set=particle_set,& pw_env=pw_env,& scf_control=scf_control, & - para_env=para_env,& - error=error) + para_env=para_env) ! gapw = dft_control%qs_control%gapw nspins = dft_control%nspins @@ -719,19 +706,19 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ENDDO ! ! - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(output_unit>0) THEN WRITE(output_unit,"(/,T20,A,/)") "*** Start current Calculation ***" WRITE(output_unit,"(T10,A,/)") "Inizialization of the current environment" ENDIF - IF(current_env%ref_count /= 0) CALL current_env_cleanup(current_env,qs_env,error=error) + IF(current_env%ref_count /= 0) CALL current_env_cleanup(current_env,qs_env) - CALL current_env_create(current_env,error=error) + CALL current_env_create(current_env) ! ! current_env%chi_tensor(:,:,:) = 0.0_dp @@ -741,10 +728,10 @@ SUBROUTINE current_env_init(current_env,qs_env,error) current_env%do_selected_states = .FALSE. ! ! If current_density or full_nmr different allocations are required - current_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES%CURRENT",error=error) + current_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES%CURRENT") ! ! Select the gauge - CALL section_vals_val_get(current_section,"GAUGE",i_val=current_env%gauge,error=error) + CALL section_vals_val_get(current_section,"GAUGE",i_val=current_env%gauge) SELECT CASE(current_env%gauge) CASE(current_gauge_r) current_env%gauge_name="R" @@ -758,22 +745,22 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ! ! maximal radius to build the atom gauge CALL section_vals_val_get(current_section,"GAUGE_ATOM_RADIUS",& - r_val=current_env%gauge_atom_radius,error=error) + r_val=current_env%gauge_atom_radius) ! use old gauge atom CALL section_vals_val_get(current_section,"USE_OLD_GAUGE_ATOM",& - l_val=current_env%use_old_gauge_atom,error=error) + l_val=current_env%use_old_gauge_atom) ! chi for pbc - CALL section_vals_val_get(current_section,"CHI_PBC",l_val=current_env%chi_pbc,error=error) + CALL section_vals_val_get(current_section,"CHI_PBC",l_val=current_env%chi_pbc) ! ! use old gauge atom CALL section_vals_val_get(current_section,"USE_OLD_GAUGE_ATOM",& - l_val=current_env%use_old_gauge_atom,error=error) + l_val=current_env%use_old_gauge_atom) ! ! chi for pbc - CALL section_vals_val_get(current_section,"CHI_PBC",l_val=current_env%chi_pbc,error=error) + CALL section_vals_val_get(current_section,"CHI_PBC",l_val=current_env%chi_pbc) ! ! which center for the orbitals shall we use - CALL section_vals_val_get(current_section,"ORBITAL_CENTER",i_val=current_env%orb_center,error=error) + CALL section_vals_val_get(current_section,"ORBITAL_CENTER",i_val=current_env%orb_center) SELECT CASE(current_env%orb_center) CASE(current_orb_center_wannier) ! @@ -784,7 +771,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) current_env%full = .FALSE. ! ! Is there a user specified common_center? - CALL section_vals_val_get(current_section,"COMMON_CENTER",r_vals=common_center,error=error) + CALL section_vals_val_get(current_section,"COMMON_CENTER",r_vals=common_center) CASE(current_orb_center_atom) ! current_env%orb_center_name = "ATOM" @@ -793,7 +780,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) current_env%orb_center_name = "BOX" ! ! Is there a user specified nbox? - CALL section_vals_val_get(current_section,"NBOX",i_vals=nbox,error=error) + CALL section_vals_val_get(current_section,"NBOX",i_vals=nbox) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"Unknown orbital center, try again...") END SELECT @@ -804,7 +791,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) !ENDIF ! ! check that the psi0 are localized and you have all the centers - CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,error,failure) + CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,failure) IF(failure) THEN IF(output_unit>0) THEN WRITE(output_unit,'(A)') & @@ -812,12 +799,12 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ENDIF ENDIF qs_loc_env => linres_control%qs_loc_env - CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control,error=error) + CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control) ! ! ALLOCATE(current_env%centers_set(nspins),current_env%center_list(nspins),& state_list(max_states,nspins),STAT=istat) - CPPrecondition(istat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat==0,cp_warning_level,routineP,failure) state_list(:,:) = HUGE(0) nstate_list(:) = HUGE(0) ! @@ -850,8 +837,8 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ! if the user has requested to compute the response for a subset of the states ! we collect them here. it requies the states to be localized! CALL section_vals_val_get(current_section,"SELECTED_STATES_ATOM_RADIUS",& - r_val=current_env%selected_states_atom_radius,error=error) - CALL section_vals_val_get(current_section,"SELECTED_STATES_ON_ATOM_LIST",n_rep_val=n_rep,error=error) + r_val=current_env%selected_states_atom_radius) + CALL section_vals_val_get(current_section,"SELECTED_STATES_ON_ATOM_LIST",n_rep_val=n_rep) ! current_env%do_selected_states = n_rep.GT.0 ! @@ -866,7 +853,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) DO ir = 1,n_rep NULLIFY(list) CALL section_vals_val_get(current_section,"SELECTED_STATES_ON_ATOM_LIST",& - i_rep_val=ir,i_vals=list,error=error) + i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(current_env%selected_states_on_atom_list,1,n+SIZE(list)) DO ini = 1,SIZE(list) @@ -918,7 +905,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ! ALLOCATE(current_env%center_list(ispin)%array(2,nstate+1),& current_env%centers_set(ispin)%array(3,nstate),STAT=istat) - CPPrecondition(istat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat==0,cp_warning_level,routineP,failure) current_env%center_list(ispin)%array(:,:) = HUGE(0) current_env%centers_set(ispin)%array(:,:) = HUGE(0.0_dp) ! @@ -954,7 +941,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ! ! use the atom as -center- ALLOCATE(buff(nstate_list(ispin)),STAT=istat) - CPPrecondition(istat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat==0,cp_warning_level,routineP,failure) buff(:) = 0 ! DO is = 1,nstate @@ -1000,13 +987,13 @@ SUBROUTINE current_env_init(current_env,qs_env,error) current_env%nbr_center(ispin) = ii-1 ! DEALLOCATE(buff,STAT=istat) - CPPrecondition(istat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat==0,cp_warning_level,routineP,failure) CASE(current_orb_center_box) ! ! use boxes as -center- nbr_box = nbox(1)*nbox(2)*nbox(3) ALLOCATE(rbuff(3,nbr_box),buff(nstate),STAT=istat) - CPPrecondition(istat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat==0,cp_warning_level,routineP,failure) rbuff(:,:) = HUGE(0.0_dp) buff(:) = 0 ! @@ -1063,7 +1050,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) current_env%nbr_center(ispin) = ii-1 ! DEALLOCATE(buff,rbuff,STAT=istat) - CPPrecondition(istat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat==0,cp_warning_level,routineP,failure) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,& "Unknown orbital center, try again...") @@ -1074,17 +1061,16 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ! ! block the states for each center ALLOCATE(current_env%psi0_order(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=nstate_list(ispin),para_env=para_env,& - context=mo_coeff%matrix_struct%context,& - error=error) - CALL cp_fm_create(current_env%psi0_order(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) - CALL cp_fm_set_all(current_env%psi0_order(ispin)%matrix,0.0_dp,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(current_env%psi0_order(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) + CALL cp_fm_set_all(current_env%psi0_order(ispin)%matrix,0.0_dp) ENDDO ! ! @@ -1159,11 +1145,11 @@ SUBROUTINE current_env_init(current_env,qs_env,error) max_nbr_center = MAXVAL(current_env%nbr_center(1:nspins)) current_env%nao = nao ALLOCATE(current_env%statetrueindex(3,max_nbr_center,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) current_env%statetrueindex(:,:,:) = 0 IF(.TRUE.) THEN ALLOCATE(state_done(3,max_nbr_center),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins state_done(:,:) = .FALSE. current_env%statetrueindex(1,1,ispin) = 1 @@ -1208,7 +1194,7 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ENDDO ! idir ENDDO DEALLOCATE(state_done,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE DO ispin = 1,nspins DO icenter = 1,current_env%nbr_center(ispin) @@ -1247,29 +1233,29 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ENDIF IF(BTEST(cp_print_key_should_output(logger%iter_info,current_section,& - & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN NULLIFY(bounds,list) ncubes = 0 CALL section_vals_val_get(current_section,& & "PRINT%RESPONSE_FUNCTION_CUBES%CUBES_LU_BOUNDS",& - i_vals=bounds,error=error) + i_vals=bounds) ncubes = bounds(2) - bounds(1) + 1 IF(ncubes > 0 ) THEN ALLOCATE( current_env%list_cubes(ncubes),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ir = 1,ncubes current_env%list_cubes(ir) = bounds(1) + (ir-1) ENDDO ENDIF IF(.NOT. ASSOCIATED(current_env%list_cubes)) THEN CALL section_vals_val_get(current_section,"PRINT%RESPONSE_FUNCTION_CUBES%CUBES_LIST",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) ncubes = 0 DO ir = 1,n_rep NULLIFY(list) CALL section_vals_val_get(current_section,"PRINT%RESPONSE_FUNCTION_CUBES%CUBES_LIST",& - i_rep_val=ir,i_vals=list,error=error) + i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(current_env%list_cubes,1,ncubes+ SIZE(list)) DO ini = 1, SIZE(list) @@ -1281,14 +1267,14 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ENDIF IF(.NOT. ASSOCIATED(current_env%list_cubes)) THEN ALLOCATE(current_env%list_cubes(max_states),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ir = 1,max_states current_env%list_cubes(ir) = ir ENDDO ENDIF ENDIF IF (BTEST(cp_print_key_should_output(logger%iter_info,current_section,& - & "PRINT%CURRENT_CUBES",error=error),cp_p_file)) THEN + & "PRINT%CURRENT_CUBES"),cp_p_file)) THEN ENDIF ! for the chemical shift we need 6 psi1, i.e. 6 optimization procedures @@ -1306,70 +1292,67 @@ SUBROUTINE current_env_init(current_env,qs_env,error) ! We also need a temporary sparse matrix where to store the integrals during the calculation ALLOCATE(current_env%p_psi0(nspins,3),current_env%rxp_psi0(nspins,3),& current_env%psi1_p(nspins,3),current_env%psi1_rxp(nspins,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(current_env%full) THEN ALLOCATE(current_env%psi1_D(nspins,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF DO ispin = 1,nspins mo_coeff => current_env%psi0_order(ispin)%matrix NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=current_env%nstates(ispin),& - context=mo_coeff%matrix_struct%context,& - error=error) + context=mo_coeff%matrix_struct%context) DO idir = 1,3 NULLIFY(current_env%psi1_p(ispin,idir)%matrix,current_env%psi1_rxp(ispin,idir)%matrix) NULLIFY(current_env%p_psi0(ispin,idir)%matrix,current_env%rxp_psi0(ispin,idir)%matrix) - CALL cp_fm_create(current_env%psi1_p(ispin,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(current_env%psi1_rxp(ispin,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(current_env%p_psi0(ispin,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(current_env%rxp_psi0(ispin,idir)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(current_env%psi1_p(ispin,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(current_env%psi1_rxp(ispin,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(current_env%p_psi0(ispin,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(current_env%rxp_psi0(ispin,idir)%matrix,tmp_fm_struct) IF(current_env%full) THEN NULLIFY(current_env%psi1_D(ispin,idir)%matrix) - CALL cp_fm_create(current_env%psi1_D(ispin,idir)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(current_env%psi1_D(ispin,idir)%matrix,tmp_fm_struct) ENDIF ENDDO - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_fm_struct_release(tmp_fm_struct) ENDDO ! ! If the current density on the grid needs to be stored - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) ALLOCATE(current_env%jrho1_set(3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO idir = 1,3 NULLIFY(rho_r, rho_g) ALLOCATE(rho_r(nspins), rho_g(nspins)) DO ispin=1,nspins CALL pw_pool_create_pw(auxbas_pw_pool, rho_r(ispin)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_zero(rho_r(ispin)%pw, error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(rho_r(ispin)%pw) CALL pw_pool_create_pw(auxbas_pw_pool, rho_g(ispin)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(rho_g(ispin)%pw, error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL pw_zero(rho_g(ispin)%pw) ENDDO NULLIFY(current_env%jrho1_set(idir)%rho) - CALL qs_rho_create(current_env%jrho1_set(idir)%rho, error) + CALL qs_rho_create(current_env%jrho1_set(idir)%rho) CALL qs_rho_set(current_env%jrho1_set(idir)%rho,& - rho_r=rho_r, rho_g=rho_g, error=error) - CALL qs_rho_retain(current_env%jrho1_set(idir)%rho,error=error) + rho_r=rho_r, rho_g=rho_g) + CALL qs_rho_retain(current_env%jrho1_set(idir)%rho) ENDDO ! ! Initialize local current density if GAPW calculation IF(gapw) THEN - CALL init_jrho_atom_set(jrho1_atom_set,atomic_kind_set,nspins,error=error) - CALL set_current_env(current_env=current_env,jrho1_atom_set=jrho1_atom_set,& - error=error) + CALL init_jrho_atom_set(jrho1_atom_set,atomic_kind_set,nspins) + CALL set_current_env(current_env=current_env,jrho1_atom_set=jrho1_atom_set) ENDIF ! ALLOCATE(current_env%basisfun_center(3,current_env%nao),& first_sgf(natom),last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) current_env%basisfun_center = 0.0_dp CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) !Build 3 arrays where for each contracted basis function !the x y and z coordinates of the center are given DO iatom = 1,natom @@ -1381,20 +1364,20 @@ SUBROUTINE current_env_init(current_env,qs_env,error) END DO DEALLOCATE(first_sgf,last_sgf,state_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) current_env%simple_done(1:6) = .FALSE. ALLOCATE(current_env%full_done(3*nspins,max_nbr_center),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) current_env%full_done = .FALSE. ! ! allocate pointer for the gauge ALLOCATE(current_env%rs_gauge(3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(current_env%rs_gauge(1)%rs,current_env%rs_gauge(2)%rs,current_env%rs_gauge(3)%rs) - CALL cp_print_key_finished_output(output_unit,logger,lr_section,"PRINT%PROGRAM_RUN_INFO",error=error) + CALL cp_print_key_finished_output(output_unit,logger,lr_section,"PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE current_env_init @@ -1404,13 +1387,11 @@ END SUBROUTINE current_env_init !> \brief ... !> \param current_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_env_cleanup(current_env,qs_env,error) + SUBROUTINE current_env_cleanup(current_env,qs_env) TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'current_env_cleanup', & routineP = moduleN//':'//routineN @@ -1432,90 +1413,90 @@ SUBROUTINE current_env_cleanup(current_env,qs_env,error) !psi0_order IF(ASSOCIATED(current_env%psi0_order)) THEN DO ispin = 1,SIZE(current_env%psi0_order,1) - CALL cp_fm_release(current_env%psi0_order(ispin)%matrix,error=error) + CALL cp_fm_release(current_env%psi0_order(ispin)%matrix) ENDDO DEALLOCATE(current_env%psi0_order,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !psi1_p IF(ASSOCIATED(current_env%psi1_p)) THEN DO idir = 1,SIZE(current_env%psi1_p,2) DO ispin = 1,SIZE(current_env%psi1_p,1) - CALL cp_fm_release(current_env%psi1_p(ispin,idir)%matrix,error=error) + CALL cp_fm_release(current_env%psi1_p(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(current_env%psi1_p,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !psi1_rxp IF(ASSOCIATED(current_env%psi1_rxp)) THEN DO idir = 1,SIZE(current_env%psi1_rxp,2) DO ispin = 1,SIZE(current_env%psi1_rxp,1) - CALL cp_fm_release(current_env%psi1_rxp(ispin,idir)%matrix,error=error) + CALL cp_fm_release(current_env%psi1_rxp(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(current_env%psi1_rxp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !psi1_D IF(ASSOCIATED(current_env%psi1_D)) THEN DO idir = 1,SIZE(current_env%psi1_D,2) DO ispin = 1,SIZE(current_env%psi1_D,1) - CALL cp_fm_release(current_env%psi1_D(ispin,idir)%matrix,error=error) + CALL cp_fm_release(current_env%psi1_D(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(current_env%psi1_D,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! !p_psi0 IF(ASSOCIATED(current_env%p_psi0)) THEN DO idir = 1,SIZE(current_env%p_psi0,2) DO ispin = 1,SIZE(current_env%p_psi0,1) - CALL cp_fm_release(current_env%p_psi0(ispin,idir)%matrix,error=error) + CALL cp_fm_release(current_env%p_psi0(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(current_env%p_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !rxp_psi0 IF(ASSOCIATED(current_env%rxp_psi0)) THEN DO idir = 1,SIZE(current_env%rxp_psi0,2) DO ispin = 1,SIZE(current_env%rxp_psi0,1) - CALL cp_fm_release(current_env%rxp_psi0(ispin,idir)%matrix,error=error) + CALL cp_fm_release(current_env%rxp_psi0(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(current_env%rxp_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! ! DO ispin = 1,SIZE(current_env%centers_set,1) DEALLOCATE(current_env%centers_set(ispin)%array,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(current_env%centers_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,SIZE(current_env%center_list,1) DEALLOCATE(current_env%center_list(ispin)%array,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(current_env%center_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(ASSOCIATED(current_env%list_cubes)) THEN DEALLOCATE(current_env%list_cubes,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! Current density on the grid IF(ASSOCIATED(current_env%jrho1_set)) THEN DO idir = 1,3 - CALL qs_rho_clear(current_env%jrho1_set(idir)%rho, error) + CALL qs_rho_clear(current_env%jrho1_set(idir)%rho) DEALLOCATE(current_env%jrho1_set(idir)%rho) END DO DEALLOCATE(current_env%jrho1_set) @@ -1523,49 +1504,49 @@ SUBROUTINE current_env_cleanup(current_env,qs_env,error) ! ! Local current density, atom by atom (only gapw) IF(ASSOCIATED(current_env%jrho1_atom_set)) THEN - CALL deallocate_jrho_atom_set(current_env%jrho1_atom_set,error=error) + CALL deallocate_jrho_atom_set(current_env%jrho1_atom_set) END IF !fullnmr_done IF(ASSOCIATED(current_env%full_done)) THEN DEALLOCATE(current_env%full_done,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(current_env%basisfun_center)) THEN DEALLOCATE(current_env%basisfun_center,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(current_env%statetrueindex)) THEN DEALLOCATE(current_env%statetrueindex,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(current_env%selected_states_on_atom_list)) THEN DEALLOCATE(current_env%selected_states_on_atom_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! give back the gauge - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env,rs_descs=rs_descs,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env,rs_descs=rs_descs) DO idir=1,3 IF(ASSOCIATED(current_env%rs_gauge(idir)%rs)) THEN DO i=1,SIZE(current_env%rs_gauge(idir)%rs) - CALL rs_grid_release(current_env%rs_gauge(idir)%rs(i)%rs_grid, error=error) + CALL rs_grid_release(current_env%rs_gauge(idir)%rs(i)%rs_grid) END DO DEALLOCATE(current_env%rs_gauge(idir)%rs,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ENDDO ! DEALLOCATE(current_env%rs_gauge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! give back the buf IF(ASSOCIATED(current_env%rs_buf)) THEN DO i=1,SIZE(current_env%rs_buf) - CALL rs_grid_release(current_env%rs_buf(i)%rs_grid, error=error) + CALL rs_grid_release(current_env%rs_buf(i)%rs_grid) END DO DEALLOCATE(current_env%rs_buf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF END IF ! ref count diff --git a/src/qs_linres_epr_nablavks.F b/src/qs_linres_epr_nablavks.F index fc183aebef..3e39dfd244 100644 --- a/src/qs_linres_epr_nablavks.F +++ b/src/qs_linres_epr_nablavks.F @@ -99,17 +99,14 @@ MODULE qs_linres_epr_nablavks !> \brief Evaluates Nabla V_KS on the grids !> \param epr_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 06.2006 created [RD] !> \author RD ! ***************************************************************************** - SUBROUTINE epr_nablavks(epr_env,qs_env,error) + SUBROUTINE epr_nablavks(epr_env,qs_env) TYPE(epr_env_type) :: epr_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_nablavks', & routineP = moduleN//':'//routineN @@ -217,12 +214,12 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) NULLIFY(ks_env) NULLIFY(rho_r, rho_ao, rho1_r, rho2_r) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") ionode = logger%para_env%mepos==logger%para_env%source output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") failure = .FALSE. @@ -231,9 +228,9 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) ! ------------------------------------- g_section => section_vals_get_subs_vals(lr_section,& - "EPR%PRINT%G_TENSOR",error=error) + "EPR%PRINT%G_TENSOR") - CALL section_vals_val_get(g_section,"gapw_max_alpha",r_val=gapw_max_alpha, error=error) + CALL section_vals_val_get(g_section,"gapw_max_alpha",r_val=gapw_max_alpha) gth_gspace = .TRUE. @@ -242,21 +239,21 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) ! ------------------------------------- CALL get_epr_env(epr_env,nablavks_set=nablavks_set,& ! R0 - nablavks_atom_set=nablavks_atom_set,& ! R0 - error=error) ! R0 + nablavks_atom_set=nablavks_atom_set) ! R0 + ! R0 DO ispin = 1,SIZE(nablavks_set,2) DO idir = 1,SIZE(nablavks_set,1) - CALL qs_rho_get(nablavks_set(idir,ispin)%rho, rho_r=rho_r, error=error) - CALL pw_zero(rho_r(1)%pw, error=error) + CALL qs_rho_get(nablavks_set(idir,ispin)%rho, rho_r=rho_r) + CALL pw_zero(rho_r(1)%pw) END DO END DO - CALL qs_rho_get(nablavks_set(1, 1)%rho, rho_r=rho_r, error=error) + CALL qs_rho_get(nablavks_set(1, 1)%rho, rho_r=rho_r) pwx => rho_r(1)%pw - CALL qs_rho_get(nablavks_set(2, 1)%rho, rho_r=rho_r, error=error) + CALL qs_rho_get(nablavks_set(2, 1)%rho, rho_r=rho_r) pwy => rho_r(1)%pw - CALL qs_rho_get(nablavks_set(3, 1)%rho, rho_r=rho_r, error=error) + CALL qs_rho_get(nablavks_set(3, 1)%rho, rho_r=rho_r) pwz => rho_r(1)%pw roffset = -REAL(MODULO(pwx%pw_grid%npts,2),dp)*pwx%pw_grid%dr/2.0_dp @@ -280,14 +277,12 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) rho0_atom_set=rho0_atom_set,& rhoz_set=rhoz_set,& subsys=subsys,& - ks_env=ks_env,& - error=error) + ks_env=ks_env) CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env,& - error=error) + poisson_env=poisson_env) - CALL qs_subsys_get(subsys,particles=particles,error=error) + CALL qs_subsys_get(subsys,particles=particles) gapw = dft_control%qs_control%gapw gapw_xc = dft_control%qs_control%gapw_xc @@ -312,32 +307,28 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) "rho_tot_gspace",0) CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_gspace%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_gtemp%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_rtemp%pw,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,rho_tot_gspace%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) IF (gapw) THEN ! need to rebuild the coeff ! - CALL qs_rho_get(rho, rho_ao_kp=rho_ao, error=error) - CALL calculate_rho_atom_coeff(qs_env,rho_ao,error=error) - CALL prepare_gapw_den(qs_env,do_rho0=.TRUE.,error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao) + CALL calculate_rho_atom_coeff(qs_env,rho_ao) + CALL prepare_gapw_den(qs_env,do_rho0=.TRUE.) END IF - CALL pw_zero(rho_tot_gspace%pw, error=error) + CALL pw_zero(rho_tot_gspace%pw) CALL calc_rho_tot_gspace(rho_tot_gspace,qs_env,rho,& - skip_nuclear_density=.NOT. gapw,error=error) + skip_nuclear_density=.NOT. gapw) CALL pw_poisson_solve(poisson_env,rho_tot_gspace%pw,ehartree,& - v_hartree_gspace%pw,error=error) + v_hartree_gspace%pw) ! ------------------------------------- ! Atomic grids part @@ -361,13 +352,13 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) hard_radius=hard_radius,& paw_atom=paw_atom,& zeff=charge,& - alpha_core_charge=alpha_core, error=error) + alpha_core_charge=alpha_core) IF (paw_atom) THEN ALLOCATE(vh1_rad_h(grid_atom%nr,harmonics%max_iso_not0),STAT=istat) ALLOCATE(vh1_rad_s(grid_atom%nr,harmonics%max_iso_not0),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! DO iat = 1, natom ! natom = # atoms for ikind ! @@ -466,7 +457,7 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) DEALLOCATE(vh1_rad_h,STAT=istat) DEALLOCATE(vh1_rad_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! paw_atom @@ -474,25 +465,25 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) END IF ! gapw - CALL pw_copy(v_hartree_gspace%pw, v_hartree_gtemp%pw, error=error) - CALL pw_derive(v_hartree_gtemp%pw, (/1,0,0/) , error=error) - CALL pw_transfer(v_hartree_gtemp%pw, v_hartree_rtemp%pw, error=error) - CALL pw_copy(v_hartree_rtemp%pw, pwx, error=error) + CALL pw_copy(v_hartree_gspace%pw, v_hartree_gtemp%pw) + CALL pw_derive(v_hartree_gtemp%pw, (/1,0,0/)) + CALL pw_transfer(v_hartree_gtemp%pw, v_hartree_rtemp%pw) + CALL pw_copy(v_hartree_rtemp%pw, pwx) - CALL pw_copy(v_hartree_gspace%pw, v_hartree_gtemp%pw, error=error) - CALL pw_derive(v_hartree_gtemp%pw, (/0,1,0/) , error=error) - CALL pw_transfer(v_hartree_gtemp%pw, v_hartree_rtemp%pw, error=error) - CALL pw_copy(v_hartree_rtemp%pw, pwy, error=error) + CALL pw_copy(v_hartree_gspace%pw, v_hartree_gtemp%pw) + CALL pw_derive(v_hartree_gtemp%pw, (/0,1,0/)) + CALL pw_transfer(v_hartree_gtemp%pw, v_hartree_rtemp%pw) + CALL pw_copy(v_hartree_rtemp%pw, pwy) - CALL pw_copy(v_hartree_gspace%pw, v_hartree_gtemp%pw, error=error) - CALL pw_derive(v_hartree_gtemp%pw, (/0,0,1/) , error=error) - CALL pw_transfer(v_hartree_gtemp%pw, v_hartree_rtemp%pw, error=error) - CALL pw_copy(v_hartree_rtemp%pw, pwz, error=error) + CALL pw_copy(v_hartree_gspace%pw, v_hartree_gtemp%pw) + CALL pw_derive(v_hartree_gtemp%pw, (/0,0,1/)) + CALL pw_transfer(v_hartree_gtemp%pw, v_hartree_rtemp%pw) + CALL pw_copy(v_hartree_rtemp%pw, pwz) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gtemp%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_rtemp%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gtemp%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_rtemp%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_tot_gspace%pw) DEALLOCATE(v_hartree_gspace,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -524,7 +515,7 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) hard_radius=hard_radius,& gth_potential=gth_potential,& all_potential=all_potential,& - paw_atom=paw_atom, error=error) + paw_atom=paw_atom) IF (ASSOCIATED(gth_potential)) THEN @@ -561,16 +552,13 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) "v_coulomb_rtemp",0) CALL pw_pool_create_pw(auxbas_pw_pool,v_coulomb_gspace%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,v_coulomb_gtemp%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,v_coulomb_rtemp%pw,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) - CALL pw_zero(v_coulomb_gspace%pw, error=error) + CALL pw_zero(v_coulomb_gspace%pw) DO iat = 1, natom ! natom = # atoms for ikind @@ -649,24 +637,24 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) END DO - CALL pw_copy(v_coulomb_gspace%pw, v_coulomb_gtemp%pw,error=error) - CALL pw_derive(v_coulomb_gtemp%pw, (/1,0,0/),error=error ) - CALL pw_transfer(v_coulomb_gtemp%pw, v_coulomb_rtemp%pw,error=error) - CALL pw_axpy(v_coulomb_rtemp%pw, pwx,error=error) + CALL pw_copy(v_coulomb_gspace%pw, v_coulomb_gtemp%pw) + CALL pw_derive(v_coulomb_gtemp%pw, (/1,0,0/)) + CALL pw_transfer(v_coulomb_gtemp%pw, v_coulomb_rtemp%pw) + CALL pw_axpy(v_coulomb_rtemp%pw, pwx) - CALL pw_copy(v_coulomb_gspace%pw, v_coulomb_gtemp%pw,error=error) - CALL pw_derive(v_coulomb_gtemp%pw, (/0,1,0/),error=error ) - CALL pw_transfer(v_coulomb_gtemp%pw, v_coulomb_rtemp%pw,error=error) - CALL pw_axpy(v_coulomb_rtemp%pw, pwy,error=error) + CALL pw_copy(v_coulomb_gspace%pw, v_coulomb_gtemp%pw) + CALL pw_derive(v_coulomb_gtemp%pw, (/0,1,0/)) + CALL pw_transfer(v_coulomb_gtemp%pw, v_coulomb_rtemp%pw) + CALL pw_axpy(v_coulomb_rtemp%pw, pwy) - CALL pw_copy(v_coulomb_gspace%pw, v_coulomb_gtemp%pw,error=error) - CALL pw_derive(v_coulomb_gtemp%pw, (/0,0,1/),error=error ) - CALL pw_transfer(v_coulomb_gtemp%pw, v_coulomb_rtemp%pw,error=error) - CALL pw_axpy(v_coulomb_rtemp%pw, pwz,error=error) + CALL pw_copy(v_coulomb_gspace%pw, v_coulomb_gtemp%pw) + CALL pw_derive(v_coulomb_gtemp%pw, (/0,0,1/)) + CALL pw_transfer(v_coulomb_gtemp%pw, v_coulomb_rtemp%pw) + CALL pw_axpy(v_coulomb_rtemp%pw, pwz) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_coulomb_gspace%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_coulomb_gtemp%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_coulomb_rtemp%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_coulomb_gspace%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_coulomb_gtemp%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_coulomb_rtemp%pw) DEALLOCATE(v_coulomb_gspace,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -906,9 +894,9 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) END DO DO idir = 1,3 - CALL qs_rho_get(nablavks_set(idir,1)%rho, rho_r=rho1_r, error=error) - CALL qs_rho_get(nablavks_set(idir,2)%rho, rho_r=rho2_r, error=error) - CALL pw_copy(rho1_r(1)%pw,rho2_r(1)%pw,error=error) + CALL qs_rho_get(nablavks_set(idir,1)%rho, rho_r=rho1_r) + CALL qs_rho_get(nablavks_set(idir,2)%rho, rho_r=rho2_r) + CALL pw_copy(rho1_r(1)%pw,rho2_r(1)%pw) END DO ! ------------------------------------- @@ -923,49 +911,44 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) "v_xc_rtemp",0) CALL pw_pool_create_pw(auxbas_pw_pool,v_xc_gtemp%pw, & - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,v_xc_rtemp%pw,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) - xc_section => section_vals_get_subs_vals(input, "PROPERTIES%LINRES%EPR%PRINT%G_TENSOR%XC", error=error) + xc_section => section_vals_get_subs_vals(input, "PROPERTIES%LINRES%EPR%PRINT%G_TENSOR%XC") ! a possible vdW section in xc_section will be ignored IF (gapw_xc) THEN CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_xc, xc_section=xc_section,& - vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=exc, just_energy=.FALSE., & - error=error) + vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=exc, just_energy=.FALSE.) ELSE CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho, xc_section=xc_section,& - vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=exc, just_energy=.FALSE., & - error=error) + vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=exc, just_energy=.FALSE.) END IF IF (ASSOCIATED(v_rspace_new)) THEN DO ispin = 1,nspins - CALL pw_transfer(v_rspace_new(ispin)%pw, v_xc_gtemp%pw, error=error) - CALL pw_derive(v_xc_gtemp%pw, (/1,0,0/) , error=error) - CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw, error=error) - CALL qs_rho_get(nablavks_set(1,ispin)%rho, rho_r=rho_r, error=error) - CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw, error=error) + CALL pw_transfer(v_rspace_new(ispin)%pw, v_xc_gtemp%pw) + CALL pw_derive(v_xc_gtemp%pw, (/1,0,0/)) + CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw) + CALL qs_rho_get(nablavks_set(1,ispin)%rho, rho_r=rho_r) + CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw) - CALL pw_transfer(v_rspace_new(ispin)%pw, v_xc_gtemp%pw, error=error) - CALL pw_derive(v_xc_gtemp%pw, (/0,1,0/) , error=error) - CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw, error=error) - CALL qs_rho_get(nablavks_set(2,ispin)%rho, rho_r=rho_r, error=error) - CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw, error=error) + CALL pw_transfer(v_rspace_new(ispin)%pw, v_xc_gtemp%pw) + CALL pw_derive(v_xc_gtemp%pw, (/0,1,0/)) + CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw) + CALL qs_rho_get(nablavks_set(2,ispin)%rho, rho_r=rho_r) + CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw) - CALL pw_transfer(v_rspace_new(ispin)%pw, v_xc_gtemp%pw, error=error) - CALL pw_derive(v_xc_gtemp%pw, (/0,0,1/) , error=error) - CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw, error=error) - CALL qs_rho_get(nablavks_set(3,ispin)%rho, rho_r=rho_r, error=error) - CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw, error=error) + CALL pw_transfer(v_rspace_new(ispin)%pw, v_xc_gtemp%pw) + CALL pw_derive(v_xc_gtemp%pw, (/0,0,1/)) + CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw) + CALL qs_rho_get(nablavks_set(3,ispin)%rho, rho_r=rho_r) + CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw) END DO @@ -978,26 +961,25 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) DO ispin = 1,nspins - CALL pw_transfer(v_tau_rspace(ispin)%pw, v_xc_gtemp%pw, error=error) - CALL pw_derive(v_xc_gtemp%pw, (/1,0,0/) , error=error) - CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw, error=error) - CALL qs_rho_get(nablavks_set(1,ispin)%rho, rho_r=rho_r, error=error) - CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw, error=error) + CALL pw_transfer(v_tau_rspace(ispin)%pw, v_xc_gtemp%pw) + CALL pw_derive(v_xc_gtemp%pw, (/1,0,0/)) + CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw) + CALL qs_rho_get(nablavks_set(1,ispin)%rho, rho_r=rho_r) + CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw) - CALL pw_transfer(v_tau_rspace(ispin)%pw, v_xc_gtemp%pw, error=error) - CALL pw_derive(v_xc_gtemp%pw, (/0,1,0/) , error=error) - CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw, error=error) - CALL qs_rho_get(nablavks_set(2,ispin)%rho, rho_r=rho_r, error=error) - CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw, error=error) + CALL pw_transfer(v_tau_rspace(ispin)%pw, v_xc_gtemp%pw) + CALL pw_derive(v_xc_gtemp%pw, (/0,1,0/)) + CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw) + CALL qs_rho_get(nablavks_set(2,ispin)%rho, rho_r=rho_r) + CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw) - CALL pw_transfer(v_tau_rspace(ispin)%pw, v_xc_gtemp%pw, error=error) - CALL pw_derive(v_xc_gtemp%pw, (/0,0,1/) , error=error) - CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw, error=error) - CALL qs_rho_get(nablavks_set(3,ispin)%rho, rho_r=rho_r, error=error) - CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw, error=error) + CALL pw_transfer(v_tau_rspace(ispin)%pw, v_xc_gtemp%pw) + CALL pw_derive(v_xc_gtemp%pw, (/0,0,1/)) + CALL pw_transfer(v_xc_gtemp%pw, v_xc_rtemp%pw) + CALL qs_rho_get(nablavks_set(3,ispin)%rho, rho_r=rho_r) + CALL pw_axpy(v_xc_rtemp%pw, rho_r(1)%pw) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_tau_rspace(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_tau_rspace(ispin)%pw) END DO @@ -1006,8 +988,8 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) "v_tau_rspace") END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_xc_gtemp%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_xc_rtemp%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_xc_gtemp%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_xc_rtemp%pw) DEALLOCATE(v_xc_gtemp,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -1018,8 +1000,7 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) IF (gapw .OR. gapw_xc) THEN CALL calculate_vxc_atom(qs_env=qs_env,energy_only=.FALSE.,& - gradient_atom_set=nablavks_atom_set,& - error=error) + gradient_atom_set=nablavks_atom_set) END IF ! ------------------------------------- @@ -1027,38 +1008,37 @@ SUBROUTINE epr_nablavks(epr_env,qs_env,error) ! ------------------------------------- IF (BTEST(cp_print_key_should_output(logger%iter_info,lr_section,& - "EPR%PRINT%NABLAVKS_CUBES",error=error),cp_p_file)) THEN + "EPR%PRINT%NABLAVKS_CUBES"),cp_p_file)) THEN ALLOCATE(wf_r,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "wf_r",0) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) DO idir = 1,3 - CALL pw_zero(wf_r%pw, error=error) - CALL qs_rho_get(nablavks_set(idir,1)%rho, rho_r=rho_r, error=error) - CALL pw_copy(rho_r(1)%pw,wf_r%pw, error=error) ! RA + CALL pw_zero(wf_r%pw) + CALL qs_rho_get(nablavks_set(idir,1)%rho, rho_r=rho_r) + CALL pw_copy(rho_r(1)%pw,wf_r%pw) ! RA filename="nablavks" WRITE(ext,'(a2,I1,a5)') "_d",idir,".cube" unit_nr=cp_print_key_unit_nr(logger,lr_section,"EPR%PRINT%NABLAVKS_CUBES",& extension=TRIM(ext),middle_name=TRIM(filename),& - log_filename=.FALSE.,file_position="REWIND",error=error) + log_filename=.FALSE.,file_position="REWIND") CALL cp_pw_to_cube(wf_r%pw,unit_nr,"NABLA V_KS ",& particles=particles,& stride=section_get_ivals(lr_section,& - "EPR%PRINT%NABLAVKS_CUBES%STRIDE",error=error),& - error=error) + "EPR%PRINT%NABLAVKS_CUBES%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,lr_section,& - "EPR%PRINT%NABLAVKS_CUBES",error=error) + "EPR%PRINT%NABLAVKS_CUBES") END DO - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) DEALLOCATE(wf_r,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "wf_r") END IF CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE epr_nablavks diff --git a/src/qs_linres_epr_ownutils.F b/src/qs_linres_epr_ownutils.F index 16e75bb94b..664a568373 100644 --- a/src/qs_linres_epr_ownutils.F +++ b/src/qs_linres_epr_ownutils.F @@ -93,17 +93,14 @@ MODULE qs_linres_epr_ownutils !> \brief Prints the g tensor !> \param epr_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 06.2006 created [RD] !> \author RD ! ***************************************************************************** - SUBROUTINE epr_g_print(epr_env,qs_env,error) + SUBROUTINE epr_g_print(epr_env,qs_env) TYPE(epr_env_type) :: epr_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_g_print', & routineP = moduleN//':'//routineN @@ -117,11 +114,11 @@ SUBROUTINE epr_g_print(epr_env,qs_env,error) NULLIFY(logger, lr_section) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") gsum = 0.0_dp @@ -137,14 +134,14 @@ SUBROUTINE epr_g_print(epr_env,qs_env,error) END IF CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") IF (BTEST(cp_print_key_should_output(logger%iter_info,lr_section,& - "EPR%PRINT%G_TENSOR",error=error),cp_p_file)) THEN + "EPR%PRINT%G_TENSOR"),cp_p_file)) THEN unit_nr=cp_print_key_unit_nr(logger,lr_section,"EPR%PRINT%G_TENSOR",& extension=".data",middle_name="GTENSOR",& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) IF(unit_nr > 0) THEN @@ -198,7 +195,7 @@ SUBROUTINE epr_g_print(epr_env,qs_env,error) WRITE(unit_nr,"(3(A,f15.10))")" ZX=",g_sym(3,1),& " ZY=",g_sym(3,2)," ZZ=",g_sym(3,3)+epr_env%g_free_factor - CALL diamat_all(g_sym,eigenv_g,error=error) + CALL diamat_all(g_sym,eigenv_g) eigenv_g(:) = eigenv_g(:)*1.0e6_dp WRITE(unit_nr,"(T2,A)") "delta_g principal values in ppm" @@ -212,7 +209,7 @@ SUBROUTINE epr_g_print(epr_env,qs_env,error) END IF CALL cp_print_key_finished_output(unit_nr,logger,lr_section,& - & "EPR%PRINT%G_TENSOR",error=error) + & "EPR%PRINT%G_TENSOR") ENDIF @@ -222,17 +219,14 @@ END SUBROUTINE epr_g_print !> \brief Calculate zke part of the g tensor !> \param epr_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 06.2006 created [RD] !> \author RD ! ***************************************************************************** - SUBROUTINE epr_g_zke(epr_env,qs_env,error) + SUBROUTINE epr_g_zke(epr_env,qs_env) TYPE(epr_env_type) :: epr_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_g_zke', & routineP = moduleN//':'//routineN @@ -249,20 +243,20 @@ SUBROUTINE epr_g_zke(epr_env,qs_env,error) NULLIFY(dft_control, logger, lr_section, rho, kinetic, para_env, rho_ao) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,& - kinetic=kinetic,rho=rho,para_env=para_env,error=error) + kinetic=kinetic,rho=rho,para_env=para_env) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,dft_control%nspins CALL calculate_ptrace(kinetic(1)%matrix,rho_ao(ispin)%matrix,& - ecore=epr_g_zke_temp(ispin),error=error) + ecore=epr_g_zke_temp(ispin)) END DO epr_env%g_zke = epr_env%g_zke_factor * ( epr_g_zke_temp(1) - epr_g_zke_temp(2) ) @@ -276,7 +270,7 @@ SUBROUTINE epr_g_zke(epr_env,qs_env,error) END IF CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE epr_g_zke @@ -286,19 +280,16 @@ END SUBROUTINE epr_g_zke !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... !> \par History !> 06.2006 created [RD] !> \author RD ! ***************************************************************************** - SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) + SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB) TYPE(epr_env_type) :: epr_env TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_g_so', & routineP = moduleN//':'//routineN @@ -350,11 +341,11 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) jrho1_set, logger, lr_section, nablavks_atom, nablavks_atom_set,& nablavks_set, para_env, particle_set, jrho2_r, jrho3_r, nrho1_r, nrho2_r, nrho3_r) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") failure = .FALSE. @@ -362,8 +353,7 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& para_env=para_env,pw_env=pw_env,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) CALL get_epr_env(epr_env=epr_env,& nablavks_set=nablavks_set,& @@ -371,8 +361,7 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) g_total=g_total,g_so=g_so) CALL get_current_env(current_env=current_env,& - jrho1_set=jrho1_set,jrho1_atom_set=jrho1_atom_set,& - error=error) + jrho1_set=jrho1_set,jrho1_atom_set=jrho1_atom_set) gapw = dft_control%qs_control%gapw nkind = SIZE(qs_kind_set,1) @@ -383,13 +372,13 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) ! j_pw x nabla_vks_pw temp_so_soft = 0.0_dp DO ispin=1,nspins - CALL qs_rho_get(jrho1_set(idir2)%rho, rho_r=jrho2_r, error=error) - CALL qs_rho_get(jrho1_set(idir3)%rho, rho_r=jrho3_r, error=error) - CALL qs_rho_get(nablavks_set(idir2,ispin)%rho, rho_r=nrho2_r, error=error) - CALL qs_rho_get(nablavks_set(idir3,ispin)%rho, rho_r=nrho3_r, error=error) + CALL qs_rho_get(jrho1_set(idir2)%rho, rho_r=jrho2_r) + CALL qs_rho_get(jrho1_set(idir3)%rho, rho_r=jrho3_r) + CALL qs_rho_get(nablavks_set(idir2,ispin)%rho, rho_r=nrho2_r) + CALL qs_rho_get(nablavks_set(idir3,ispin)%rho, rho_r=nrho3_r) temp_so_soft = temp_so_soft + (-1.0_dp)**(1 + ispin) * ( & - pw_integral_ab(jrho2_r(ispin)%pw, nrho3_r(1)%pw, error=error) - & - pw_integral_ab(jrho3_r(ispin)%pw, nrho2_r(1)%pw, error=error) ) + pw_integral_ab(jrho2_r(ispin)%pw, nrho3_r(1)%pw) - & + pw_integral_ab(jrho3_r(ispin)%pw, nrho2_r(1)%pw) ) END DO temp_so_soft = -1.0_dp * epr_env%g_so_factor * temp_so_soft IF (output_unit>0) THEN @@ -401,39 +390,37 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) IF (gapw) THEN - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) ALLOCATE(vks_pw_spline(3,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) interp_section => section_vals_get_subs_vals(lr_section,& - "EPR%INTERPOLATOR",error=error) + "EPR%INTERPOLATOR") CALL section_vals_val_get(interp_section,"aint_precond", & - i_val=aint_precond, error=error) - CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind,error=error) - CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter,error=error) - CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r,error=error) - CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x,error=error) + i_val=aint_precond) + CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind) + CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter) + CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r) + CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x) DO ispin = 1,nspins DO idir1 = 1,3 CALL pw_pool_create_pw(auxbas_pw_pool,& vks_pw_spline(idir1,ispin)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) ! calculate spline coefficients CALL pw_spline_precond_create(precond,precond_kind=aint_precond,& - pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.,error=error) - CALL qs_rho_get(nablavks_set(idir1,ispin)%rho, rho_r=nrho1_r, error=error) + pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.) + CALL qs_rho_get(nablavks_set(idir1,ispin)%rho, rho_r=nrho1_r) CALL pw_spline_do_precond(precond, nrho1_r(1)%pw,& - vks_pw_spline(idir1,ispin)%pw,error=error) - CALL pw_spline_precond_set_kind(precond,precond_kind,error=error) + vks_pw_spline(idir1,ispin)%pw) + CALL pw_spline_precond_set_kind(precond,precond_kind) success=find_coeffs(values=nrho1_r(1)%pw,& coeffs=vks_pw_spline(idir1,ispin)%pw,linOp=spl3_pbc,& preconditioner=precond,pool=auxbas_pw_pool,& - eps_r=eps_r,eps_x=eps_x,max_iter=max_iter,& - error=error) - CPPostconditionNoFail(success,cp_warning_level,routineP,error) - CALL pw_spline_precond_release(precond,error=error) + eps_r=eps_r,eps_x=eps_x,max_iter=max_iter) + CPPostconditionNoFail(success,cp_warning_level,routineP) + CALL pw_spline_precond_release(precond) END DO ! idir1 END DO ! ispin @@ -446,7 +433,7 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) hard_radius=hard_radius,& grid_atom=grid_atom,& harmonics=harmonics,& - paw_atom=paw_atom, error=error) + paw_atom=paw_atom) IF (.NOT.paw_atom) CYCLE @@ -472,9 +459,9 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) ra = particle_set(iatom)%r ra(:) = ra(:) + grid_atom%rad(ir)*harmonics%a(:,ia) vks_ra_idir2 = Eval_Interp_Spl3_pbc(ra,& - vks_pw_spline(idir2,ispin)%pw,error) + vks_pw_spline(idir2,ispin)%pw) vks_ra_idir3 = Eval_Interp_Spl3_pbc(ra,& - vks_pw_spline(idir3,ispin)%pw,error) + vks_pw_spline(idir3,ispin)%pw) IF(iat.LT.bo(1).OR.iat.GT.bo(2))CYCLE!quick and dirty: ! !here take care of the partition @@ -553,20 +540,19 @@ SUBROUTINE epr_g_so(epr_env,current_env,qs_env,iB,error) DO ispin = 1,nspins DO idir1 = 1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,vks_pw_spline(idir1,ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,vks_pw_spline(idir1,ispin)%pw) END DO END DO DEALLOCATE(vks_pw_spline,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! gapw g_total(iB,:) = g_total(iB,:) + g_so(iB,:) CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE epr_g_so @@ -576,19 +562,16 @@ END SUBROUTINE epr_g_so !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... !> \par History !> 06.2006 created [RD] !> \author RD ! ***************************************************************************** - SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB,error) + SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB) TYPE(epr_env_type) :: epr_env TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_g_soo', & routineP = moduleN//':'//routineN @@ -639,30 +622,29 @@ SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB,error) logger, lr_section, para_env, particle_set, rho, rho_atom, & rho_atom_set, rho_r, brho1_r) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") g_section => section_vals_get_subs_vals(lr_section,& - "EPR%PRINT%G_TENSOR",error=error) + "EPR%PRINT%G_TENSOR") - CALL section_vals_val_get(g_section,"soo_rho_hard",l_val=soo_rho_hard,error=error) + CALL section_vals_val_get(g_section,"soo_rho_hard",l_val=soo_rho_hard) failure = .FALSE. CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& dft_control=dft_control,para_env=para_env,particle_set=particle_set,& - pw_env=pw_env,rho=rho,rho_atom_set=rho_atom_set,error=error) + pw_env=pw_env,rho=rho,rho_atom_set=rho_atom_set) CALL get_epr_env(epr_env=epr_env,bind_set=bind_set,& g_soo=g_soo,g_total=g_total) CALL get_current_env(current_env=current_env,& - chi_tensor=chi_tensor,& - error=error) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + chi_tensor=chi_tensor) + CALL qs_rho_get(rho, rho_r=rho_r) gapw = dft_control%qs_control%gapw nkind = SIZE(qs_kind_set,1) @@ -671,9 +653,9 @@ SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB,error) DO idir1=1,3 temp_soo_soft = 0.0_dp DO ispin=1,nspins - CALL qs_rho_get(bind_set(idir1,iB)%rho, rho_r=brho1_r, error=error) + CALL qs_rho_get(bind_set(idir1,iB)%rho, rho_r=brho1_r) temp_soo_soft = temp_soo_soft + (-1.0_dp)**(1 +ispin) * & - pw_integral_ab(brho1_r(1)%pw, rho_r(ispin)%pw ,error=error) + pw_integral_ab(brho1_r(1)%pw, rho_r(ispin)%pw) END DO temp_soo_soft = 1.0_dp * epr_env%g_soo_factor * temp_soo_soft IF (output_unit>0) THEN @@ -695,38 +677,36 @@ SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB,error) IF (gapw .AND. soo_rho_hard) THEN - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) ALLOCATE(bind_pw_spline(3,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) interp_section => section_vals_get_subs_vals(lr_section,& - "EPR%INTERPOLATOR",error=error) + "EPR%INTERPOLATOR") CALL section_vals_val_get(interp_section,"aint_precond", & - i_val=aint_precond, error=error) - CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind,error=error) - CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter,error=error) - CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r,error=error) - CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x,error=error) + i_val=aint_precond) + CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind) + CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter) + CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r) + CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x) DO idir1 = 1,3 CALL pw_pool_create_pw(auxbas_pw_pool,& bind_pw_spline(idir1,iB)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) ! calculate spline coefficients CALL pw_spline_precond_create(precond,precond_kind=aint_precond,& - pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.,error=error) - CALL qs_rho_get(bind_set(idir1,iB)%rho, rho_r=brho1_r, error=error) + pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.) + CALL qs_rho_get(bind_set(idir1,iB)%rho, rho_r=brho1_r) CALL pw_spline_do_precond(precond, brho1_r(1)%pw,& - bind_pw_spline(idir1,iB)%pw,error=error) - CALL pw_spline_precond_set_kind(precond,precond_kind,error=error) + bind_pw_spline(idir1,iB)%pw) + CALL pw_spline_precond_set_kind(precond,precond_kind) success=find_coeffs(values=brho1_r(1)%pw,& coeffs=bind_pw_spline(idir1,iB)%pw,linOp=spl3_pbc,& preconditioner=precond,pool=auxbas_pw_pool,& - eps_r=eps_r,eps_x=eps_x,max_iter=max_iter,& - error=error) - CPPostconditionNoFail(success,cp_warning_level,routineP,error) - CALL pw_spline_precond_release(precond,error=error) + eps_r=eps_r,eps_x=eps_x,max_iter=max_iter) + CPPostconditionNoFail(success,cp_warning_level,routineP) + CALL pw_spline_precond_release(precond) END DO ! idir1 temp_soo_gapw = 0.0_dp @@ -738,7 +718,7 @@ SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB,error) hard_radius=hard_radius,& grid_atom=grid_atom,& harmonics=harmonics,& - paw_atom=paw_atom, error=error) + paw_atom=paw_atom) IF (.NOT.paw_atom) CYCLE @@ -764,7 +744,7 @@ SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB,error) ra = particle_set(iatom)%r ra(:) = ra(:) + grid_atom%rad(ir)*harmonics%a(:,ia) bind_ra_idir1 = Eval_Interp_Spl3_pbc(ra,& - bind_pw_spline(idir1,iB)%pw,error) + bind_pw_spline(idir1,iB)%pw) IF(iat.LT.bo(1).OR.iat.GT.bo(2))CYCLE!quick and dirty: ! !here take care of the partition @@ -803,19 +783,18 @@ SUBROUTINE epr_g_soo(epr_env,current_env,qs_env,iB,error) g_soo(iB,:) = g_soo(iB,:) + temp_soo_gapw(iB,:) DO idir1 = 1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,bind_pw_spline(idir1,iB)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,bind_pw_spline(idir1,iB)%pw) END DO DEALLOCATE(bind_pw_spline,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! gapw g_total(iB,:) = g_total(iB,:) + g_soo(iB,:) CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE epr_g_soo @@ -825,15 +804,13 @@ END SUBROUTINE epr_g_soo !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE epr_ind_magnetic_field(epr_env,current_env,qs_env,iB,error) + SUBROUTINE epr_ind_magnetic_field(epr_env,current_env,qs_env,iB) TYPE(epr_env_type) :: epr_env TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_ind_magnetic_field', & routineP = moduleN//':'//routineN @@ -866,43 +843,41 @@ SUBROUTINE epr_ind_magnetic_field(epr_env,current_env,qs_env,iB,error) rho_gspace, pw_pools, particle_set, jrho1_g, epr_rho_r) CALL get_qs_env(qs_env=qs_env,cell=cell,dft_control=dft_control,& - particle_set=particle_set,error=error) + particle_set=particle_set) gapw = dft_control%qs_control%gapw natom = SIZE(particle_set,1) nspins = dft_control%nspins - CALL get_epr_env(epr_env=epr_env,& - error=error) + CALL get_epr_env(epr_env=epr_env) - CALL get_current_env(current_env=current_env,error=error) + CALL get_current_env(current_env=current_env) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_desc=auxbas_rs_desc,& - auxbas_pw_pool=auxbas_pw_pool,pw_pools=pw_pools,& - error=error) + auxbas_pw_pool=auxbas_pw_pool,pw_pools=pw_pools) ! ! Initialize ! Allocate grids for the calculation of jrho and the shift ALLOCATE(shift_pw_gspace(3,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO idir = 1,3 CALL pw_pool_create_pw(auxbas_pw_pool,shift_pw_gspace(idir,ispin)%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) - CALL pw_zero(shift_pw_gspace(idir,ispin)%pw,error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero(shift_pw_gspace(idir,ispin)%pw) ENDDO ENDDO CALL pw_pool_create_pw(auxbas_pw_pool,shift_pw_rspace%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_zero(shift_pw_rspace%pw,error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(shift_pw_rspace%pw) CALL pw_pool_create_pw(auxbas_pw_pool,pw_gspace_work%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,error=error) + in_space=RECIPROCALSPACE) - CALL pw_zero(pw_gspace_work%pw,error=error) + CALL pw_zero(pw_gspace_work%pw) ! CALL set_vecp(iB,iiB,iiiB) ! @@ -910,10 +885,10 @@ SUBROUTINE epr_ind_magnetic_field(epr_env,current_env,qs_env,iB,error) ! DO idir3=1,3 ! set to zero for the calculation of the shift - CALL pw_zero(shift_pw_gspace(idir3,ispin)%pw,error=error) + CALL pw_zero(shift_pw_gspace(idir3,ispin)%pw) ENDDO DO idir = 1,3 - CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_g=jrho1_g, error=error) + CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_g=jrho1_g) rho_gspace => jrho1_g(ispin) ! Field gradient ! loop over the Gvec components: x,y,z @@ -921,13 +896,13 @@ SUBROUTINE epr_ind_magnetic_field(epr_env,current_env,qs_env,iB,error) IF(idir /= idir2) THEN ! in reciprocal space multiply (G_idir2(i)/G(i)^2)J_(idir)(G(i)) CALL mult_G_ov_G2_grid(cell,auxbas_pw_pool,rho_gspace,& - pw_gspace_work,idir2,0.0_dp,error=error) + pw_gspace_work,idir2,0.0_dp) ! ! scale and add to the correct component of the shift column CALL set_vecp_rev(idir,idir2,idir3) scale_fac=fac_vecp(idir3,idir2,idir) - CALL pw_scale(pw_gspace_work%pw,scale_fac,error=error) - CALL pw_axpy(pw_gspace_work%pw,shift_pw_gspace(idir3,ispin)%pw,error=error) + CALL pw_scale(pw_gspace_work%pw,scale_fac) + CALL pw_axpy(pw_gspace_work%pw,shift_pw_gspace(idir3,ispin)%pw) ENDIF ENDDO ! @@ -937,22 +912,21 @@ SUBROUTINE epr_ind_magnetic_field(epr_env,current_env,qs_env,iB,error) ! Store the total soft induced magnetic field (corrected for sic) IF (dft_control%nspins == 2) THEN DO idir = 1,3 - CALL qs_rho_get(epr_env%bind_set(idir,iB)%rho, rho_r=epr_rho_r, error=error) - CALL pw_transfer(shift_pw_gspace(idir,2)%pw,epr_rho_r(1)%pw,& - error=error) + CALL qs_rho_get(epr_env%bind_set(idir,iB)%rho, rho_r=epr_rho_r) + CALL pw_transfer(shift_pw_gspace(idir,2)%pw,epr_rho_r(1)%pw) ENDDO END IF ! ! Dellocate grids for the calculation of jrho and the shift - CALL pw_pool_give_back_pw(auxbas_pw_pool,pw_gspace_work%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,pw_gspace_work%pw) DO ispin = 1,dft_control%nspins DO idir = 1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_gspace(idir,ispin)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_gspace(idir,ispin)%pw) ENDDO ENDDO DEALLOCATE(shift_pw_gspace,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_rspace%pw,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_rspace%pw) ! ! Finalize CALL timestop(handle) diff --git a/src/qs_linres_epr_utils.F b/src/qs_linres_epr_utils.F index c7350340b5..02062fc183 100644 --- a/src/qs_linres_epr_utils.F +++ b/src/qs_linres_epr_utils.F @@ -75,16 +75,14 @@ MODULE qs_linres_epr_utils !> \brief Initialize the epr environment !> \param epr_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 07.2006 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE epr_env_init(epr_env,qs_env,error) + SUBROUTINE epr_env_init(epr_env,qs_env) ! TYPE(epr_env_type) :: epr_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_env_init', & routineP = moduleN//':'//routineN @@ -127,15 +125,15 @@ SUBROUTINE epr_env_init(epr_env,qs_env,error) nao = 0 nmoloc = 0 - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() !ionode = logger%para_env%mepos==logger%para_env%source - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(epr_env%ref_count /= 0) THEN - CALL epr_env_cleanup(epr_env,error=error) + CALL epr_env_cleanup(epr_env) END IF IF(output_unit>0) THEN @@ -143,7 +141,7 @@ SUBROUTINE epr_env_init(epr_env,qs_env,error) WRITE(output_unit,"(T10,A,/)") "Initialization of the EPR environment" ENDIF - CALL epr_env_create(epr_env,error=error) + CALL epr_env_create(epr_env) CALL get_qs_env(qs_env=qs_env,& @@ -156,7 +154,7 @@ SUBROUTINE epr_env_init(epr_env,qs_env,error) mpools=mpools,& particle_set=particle_set,& pw_env=pw_env,& - scf_control=scf_control,error=error) + scf_control=scf_control) ! ! Check if restat also psi0 should be restarted !IF(epr_env%restart_epr .AND. scf_control%density_guess/=restart_guess)THEN @@ -164,7 +162,7 @@ SUBROUTINE epr_env_init(epr_env,qs_env,error) !ENDIF ! ! check that the psi0 are localized and you have all the centers - CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,error,failure) + CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,failure) IF(failure .AND. (output_unit>0)) THEN WRITE(output_unit,'(A)') & ' To get EPR parameters within PBC you need localized zero order orbitals ' @@ -185,63 +183,62 @@ SUBROUTINE epr_env_init(epr_env,qs_env,error) epr_env%g_soo_chicorr_factor = 2.0 / 3.0_dp * fourpi * ( a_fine )**2 / cell%deth ! ! If the current density on the grid needs to be stored - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) ! ! Initialize local current density if GAPW calculation IF(gapw) THEN - CALL init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set,nspins,error=error) + CALL init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set,nspins) CALL set_epr_env(epr_env=epr_env,& - nablavks_atom_set=nablavks_atom_set,& - error=error) + nablavks_atom_set=nablavks_atom_set) ENDIF ! ! Bind ALLOCATE(epr_env%bind_set(3,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i_B = 1,3 DO idir = 1,3 NULLIFY(epr_env%bind_set(idir,i_B)%rho, rho_r, rho_g) - CALL qs_rho_create(epr_env%bind_set(idir,i_B)%rho, error) + CALL qs_rho_create(epr_env%bind_set(idir,i_B)%rho) ALLOCATE(rho_r(1), rho_g(1)) CALL pw_pool_create_pw(auxbas_pw_pool, rho_r(1)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool, rho_g(1)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) - CALL qs_rho_set(epr_env%bind_set(idir,i_B)%rho, rho_r=rho_r, rho_g=rho_g, error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL qs_rho_set(epr_env%bind_set(idir,i_B)%rho, rho_r=rho_r, rho_g=rho_g) END DO END DO ! Nabla_V_ks ALLOCATE(epr_env%nablavks_set(3,dft_control%nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO idir = 1,3 DO ispin = 1,nspins NULLIFY(epr_env%nablavks_set(idir,ispin)%rho, rho_r, rho_g) - CALL qs_rho_create(epr_env%nablavks_set(idir,ispin)%rho, error) + CALL qs_rho_create(epr_env%nablavks_set(idir,ispin)%rho) ALLOCATE(rho_r(1), rho_g(1)) CALL pw_pool_create_pw(auxbas_pw_pool, rho_r(1)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool, rho_g(1)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) CALL qs_rho_set(epr_env%nablavks_set(idir,ispin)%rho, & - rho_r=rho_r, rho_g=rho_g, error=error) + rho_r=rho_r, rho_g=rho_g) END DO END DO ! Initialize the g tensor components ALLOCATE(epr_env%g_total(3,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(epr_env%g_so(3,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(epr_env%g_soo(3,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) epr_env%g_total = 0.0_dp epr_env%g_zke = 0.0_dp epr_env%g_so = 0.0_dp epr_env%g_soo = 0.0_dp CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - & "PRINT%PROGRAM_RUN_INFO",error=error) + & "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -250,15 +247,13 @@ END SUBROUTINE epr_env_init ! ***************************************************************************** !> \brief Deallocate the epr environment !> \param epr_env ... -!> \param error ... !> \par History !> 07.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE epr_env_cleanup(epr_env,error) + SUBROUTINE epr_env_cleanup(epr_env) TYPE(epr_env_type) :: epr_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'epr_env_cleanup', & routineP = moduleN//':'//routineN @@ -274,16 +269,16 @@ SUBROUTINE epr_env_cleanup(epr_env,error) IF(ASSOCIATED(epr_env%nablavks_set)) THEN DO ispin = 1,SIZE(epr_env%nablavks_set,2) DO idir = 1,SIZE(epr_env%nablavks_set,1) - CALL qs_rho_clear(epr_env%nablavks_set(idir,ispin)%rho, error) + CALL qs_rho_clear(epr_env%nablavks_set(idir,ispin)%rho) DEALLOCATE(epr_env%nablavks_set(idir,ispin)%rho) ENDDO ENDDO DEALLOCATE(epr_env%nablavks_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! nablavks_atom_set IF(ASSOCIATED(epr_env%nablavks_atom_set)) THEN - CALL deallocate_nablavks_atom_set(epr_env%nablavks_atom_set,error=error) + CALL deallocate_nablavks_atom_set(epr_env%nablavks_atom_set) END IF ! vks_atom_set IF(ASSOCIATED(epr_env%vks_atom_set)) THEN @@ -293,32 +288,32 @@ SUBROUTINE epr_env_cleanup(epr_env,error) IF(ASSOCIATED(epr_env%bind_set)) THEN DO i_B = 1,SIZE(epr_env%bind_set,2) DO idir = 1,SIZE(epr_env%bind_set,1) - CALL qs_rho_clear(epr_env%bind_set(idir,i_B)%rho, error) + CALL qs_rho_clear(epr_env%bind_set(idir,i_B)%rho) DEALLOCATE(epr_env%bind_set(idir,i_B)%rho) ENDDO ENDDO DEALLOCATE(epr_env%bind_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! bind_atom_set IF(ASSOCIATED(epr_env%bind_atom_set)) THEN DEALLOCATE(epr_env%bind_atom_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! g_total IF(ASSOCIATED(epr_env%g_total)) THEN DEALLOCATE(epr_env%g_total,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! g_so IF(ASSOCIATED(epr_env%g_so)) THEN DEALLOCATE(epr_env%g_so,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! g_soo IF(ASSOCIATED(epr_env%g_soo)) THEN DEALLOCATE(epr_env%g_soo,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF ! ref count END IF ! failure diff --git a/src/qs_linres_issc_utils.F b/src/qs_linres_issc_utils.F index c0c4c9f142..d4f17a0625 100644 --- a/src/qs_linres_issc_utils.F +++ b/src/qs_linres_issc_utils.F @@ -91,14 +91,12 @@ MODULE qs_linres_issc_utils !> \param issc_env ... !> \param p_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE issc_response(issc_env,p_env,qs_env,error) + SUBROUTINE issc_response(issc_env,p_env,qs_env) ! TYPE(issc_env_type) :: issc_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_response', & routineP = moduleN//':'//routineN @@ -133,13 +131,13 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) NULLIFY(logger, mpools, psi1,h1_psi0, mo_coeff,para_env) NULLIFY(tmp_fm_struct, psi1_fc, psi1_efg, psi1_pso, pso_psi0, fc_psi0, efg_psi0, psi0_order) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") issc_section => section_vals_get_subs_vals(qs_env%input, & - "PROPERTIES%LINRES%SPINSPIN",error=error) + "PROPERTIES%LINRES%SPINSPIN") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(T10,A,/)")& "*** Self consistent optimization of the response wavefunctions ***" @@ -150,8 +148,7 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) mpools=mpools,& linres_control=linres_control,& mos=mos,& - para_env=para_env,& - error=error) + para_env=para_env) nspins = dft_control%nspins @@ -168,25 +165,23 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) do_fc=do_fc, & do_sd=do_sd, & do_pso=do_pso, & - do_dso=do_dso, & - error=error) + do_dso=do_dso) ! ! allocate the vectors ALLOCATE(psi0_order(nspins)) ALLOCATE(psi1(nspins),h1_psi0(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) psi0_order(ispin)%matrix => mo_coeff - CALL cp_fm_get_info(mo_coeff,ncol_global=nmo,nrow_global=nao,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=nmo,nrow_global=nao) NULLIFY(tmp_fm_struct,psi1(ispin)%matrix,h1_psi0(ispin)%matrix) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=nmo,& - context=mo_coeff%matrix_struct%context,& - error=error) - CALL cp_fm_create(psi1(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(h1_psi0(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(psi1(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create(h1_psi0(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ENDDO chk = 0.0_dp should_stop =.FALSE. @@ -198,7 +193,7 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) DO jdir = idir,3 ijdir = ijdir+1 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1_efg(ispin,ijdir)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1_efg(ispin,ijdir)%matrix,0.0_dp) ENDDO IF(output_unit>0) THEN WRITE(output_unit,"(T10,A)") "Response to the perturbation operator efg_"//ACHAR(idir+119)//ACHAR(jdir+119) @@ -206,39 +201,39 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) ! !Initial guess for psi1 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp,error=error) - !CALL cp_fm_to_fm(p_psi0(ispin,ijdir)%matrix, psi1(ispin)%matrix,error=error) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix,error=error) + CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp) + !CALL cp_fm_to_fm(p_psi0(ispin,ijdir)%matrix, psi1(ispin)%matrix) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix) ENDDO ! !DO scf cycle to optimize psi1 DO ispin = 1,nspins - CALL cp_fm_to_fm(efg_psi0(ispin,ijdir)%matrix,h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_to_fm(efg_psi0(ispin,ijdir)%matrix,h1_psi0(ispin)%matrix) ENDDO ! ! linres_control%lr_triplet = .FALSE. linres_control%do_kernel = .FALSE. linres_control%converged = .FALSE. - CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop) ! ! ! copy the response DO ispin=1,nspins - CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_efg(ispin,ijdir)%matrix,error=error) - CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro,error=error) + CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_efg(ispin,ijdir)%matrix) + CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro) chk = chk + fro ENDDO ! ! print response functions !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES",error=error) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") ! DO ispin = 1,nspins ! CALL qs_print_cubes(qs_env,psi1(ispin)%matrix,ncubes,list_cubes,& ! centers_set(ispin)%array,print_key,'psi1_efg',& - ! idir=ijdir,ispin=ispin,error=error) + ! idir=ijdir,ispin=ispin) ! ENDDO ! ispin !ENDIF ! print response functions ! @@ -256,7 +251,7 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) IF(do_pso) THEN DO idir = 1,3 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1_pso(ispin,idir)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1_pso(ispin,idir)%matrix,0.0_dp) ENDDO IF(output_unit>0) THEN WRITE(output_unit,"(T10,A)") "Response to the perturbation operator pso_"//ACHAR(idir+119) @@ -264,39 +259,39 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) ! !Initial guess for psi1 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp,error=error) - !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)%matrix,error=error) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix,error=error) + CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp) + !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)%matrix) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix) ENDDO ! !DO scf cycle to optimize psi1 DO ispin = 1,nspins - CALL cp_fm_to_fm(pso_psi0(ispin,idir)%matrix,h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_to_fm(pso_psi0(ispin,idir)%matrix,h1_psi0(ispin)%matrix) ENDDO ! ! linres_control%lr_triplet = .FALSE. ! we do singlet response linres_control%do_kernel = .FALSE. ! we do uncoupled response linres_control%converged = .FALSE. - CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop) ! ! ! copy the response DO ispin=1,nspins - CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_pso(ispin,idir)%matrix,error=error) - CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro,error=error) + CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_pso(ispin,idir)%matrix) + CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro) chk = chk + fro ENDDO ! ! print response functions !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES",error=error) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") ! DO ispin = 1,nspins ! CALL qs_print_cubes(qs_env,psi1(ispin)%matrix,ncubes,list_cubes,& ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin,error=error) + ! idir=idir,ispin=ispin) ! ENDDO ! ispin !ENDIF ! print response functions ! @@ -312,7 +307,7 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) ! operator fc IF(do_fc) THEN DO ispin = 1,nspins - CALL cp_fm_set_all(psi1_fc(ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1_fc(ispin)%matrix,0.0_dp) ENDDO IF(output_unit>0) THEN WRITE(output_unit,"(T10,A)") "Response to the perturbation operator fc" @@ -320,39 +315,39 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) ! !Initial guess for psi1 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp,error=error) - !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)%matrix,error=error) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix,error=error) + CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp) + !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)%matrix) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix) ENDDO ! !DO scf cycle to optimize psi1 DO ispin = 1,nspins - CALL cp_fm_to_fm(fc_psi0(ispin)%matrix,h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_to_fm(fc_psi0(ispin)%matrix,h1_psi0(ispin)%matrix) ENDDO ! ! linres_control%lr_triplet = .TRUE. ! we do triplet response linres_control%do_kernel = .TRUE. ! we do coupled response linres_control%converged = .FALSE. - CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop) ! ! ! copy the response DO ispin=1,nspins - CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_fc(ispin)%matrix,error=error) - CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro,error=error) + CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_fc(ispin)%matrix) + CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro) chk = chk + fro ENDDO ! ! print response functions !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES",error=error) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") ! DO ispin = 1,nspins ! CALL qs_print_cubes(qs_env,psi1(ispin)%matrix,ncubes,list_cubes,& ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin,error=error) + ! idir=idir,ispin=ispin) ! ENDDO ! ispin !ENDIF ! print response functions ! @@ -370,7 +365,7 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) IF(do_dso) THEN DO idir = 1,3 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1_dso(ispin,idir)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1_dso(ispin,idir)%matrix,0.0_dp) ENDDO IF(output_unit>0) THEN WRITE(output_unit,"(T10,A)") "Response to the perturbation operator r_"//ACHAR(idir+119) @@ -378,39 +373,39 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) ! !Initial guess for psi1 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp,error=error) - !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)%matrix,error=error) - !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix,error=error) + CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp) + !CALL cp_fm_to_fm(rxp_psi0(ispin,idir)%matrix, psi1(ispin)%matrix) + !CALL cp_fm_scale(-1.0_dp,psi1(ispin)%matrix) ENDDO ! !DO scf cycle to optimize psi1 DO ispin = 1,nspins - CALL cp_fm_to_fm(dso_psi0(ispin,idir)%matrix,h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_to_fm(dso_psi0(ispin,idir)%matrix,h1_psi0(ispin)%matrix) ENDDO ! ! linres_control%lr_triplet = .FALSE. ! we do singlet response linres_control%do_kernel = .TRUE. ! we do uncoupled response linres_control%converged = .FALSE. - CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order,should_stop) ! ! ! copy the response DO ispin=1,nspins - CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_dso(ispin,idir)%matrix,error=error) - CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro,error=error) + CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_dso(ispin,idir)%matrix) + CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro) chk = chk + fro ENDDO ! ! print response functions !IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - ! & "PRINT%RESPONSE_FUNCTION_CUBES",error=error),cp_p_file)) THEN + ! & "PRINT%RESPONSE_FUNCTION_CUBES"),cp_p_file)) THEN ! ncubes = SIZE(list_cubes,1) - ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES",error=error) + ! print_key => section_vals_get_subs_vals(issc_section,"PRINT%RESPONSE_FUNCTION_CUBES") ! DO ispin = 1,nspins ! CALL qs_print_cubes(qs_env,psi1(ispin)%matrix,ncubes,list_cubes,& ! centers_set(ispin)%array,print_key,'psi1_pso',& - ! idir=idir,ispin=ispin,error=error) + ! idir=idir,ispin=ispin) ! ENDDO ! ispin !ENDIF ! print response functions ! @@ -434,14 +429,14 @@ SUBROUTINE issc_response(issc_env,p_env,qs_env,error) ! ! clean up DO ispin = 1,nspins - CALL cp_fm_release(psi1(ispin)%matrix,error=error) - CALL cp_fm_release(h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_release(psi1(ispin)%matrix) + CALL cp_fm_release(h1_psi0(ispin)%matrix) ENDDO DEALLOCATE(psi1,h1_psi0,psi0_order,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - & "PRINT%PROGRAM_RUN_INFO",error=error) + & "PRINT%PROGRAM_RUN_INFO") ! CALL timestop(handle) ! @@ -453,14 +448,12 @@ END SUBROUTINE issc_response !> \param issc_env ... !> \param qs_env ... !> \param iatom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) + SUBROUTINE issc_issc(issc_env,qs_env,iatom) TYPE(issc_env_type) :: issc_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iatom - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_issc', & routineP = moduleN//':'//routineN @@ -501,8 +494,7 @@ SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) cell=cell,& dft_control=dft_control,& particle_set=particle_set,& - mos=mos,& - error=error) + mos=mos) gapw = dft_control%qs_control%gapw natom = SIZE(particle_set,1) @@ -522,8 +514,7 @@ SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) do_fc=do_fc, & do_sd=do_sd, & do_pso=do_pso, & - do_dso=do_dso, & - error=error) + do_dso=do_dso) g = e_mass / ( 2.0_dp * p_mass ) facfc = hertz * g**2 * a_fine**4 @@ -534,12 +525,12 @@ SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) ! ! issc_section => section_vals_get_subs_vals(qs_env%input, & - & "PROPERTIES%LINRES%SPINSPIN",error=error) + & "PROPERTIES%LINRES%SPINSPIN") ! ! Initialize DO ispin = 1,nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff,maxocc=maxocc) - CALL cp_fm_get_info(mo_coeff,ncol_global=nmo,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=nmo) DO jatom = 1,natom r_i = particle_set(iatom)%r @@ -556,16 +547,16 @@ SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) IF(do_fc.AND.iatom.NE.jatom) THEN ! ! build the integral for the jatom - CALL cp_dbcsr_set(matrix_fc(1)%matrix,0.0_dp,error=error) - CALL build_fermi_contact_matrix(qs_env,matrix_fc,r_j,error) + CALL cp_dbcsr_set(matrix_fc(1)%matrix,0.0_dp) + CALL build_fermi_contact_matrix(qs_env,matrix_fc,r_j) CALL cp_dbcsr_sm_fm_multiply(matrix_fc(1)%matrix,mo_coeff,& fc_psi0(ispin)%matrix,ncol=nmo,& ! fc_psi0 a buffer - & alpha=1.0_dp,error=error) + & alpha=1.0_dp) - CALL cp_fm_trace(fc_psi0(ispin)%matrix,mo_coeff,buf,error=error) + CALL cp_fm_trace(fc_psi0(ispin)%matrix,mo_coeff,buf) WRITE(*,*) ' jatom',jatom,'tr(P*fc)=',buf - CALL cp_fm_trace(fc_psi0(ispin)%matrix,psi1_fc(ispin)%matrix,buf,error=error) + CALL cp_fm_trace(fc_psi0(ispin)%matrix,psi1_fc(ispin)%matrix,buf) issc_fc = 2.0_dp * 2.0_dp * maxocc * facfc * buf issc(1,1,iatom,jatom,1) = issc(1,1,iatom,jatom,1) + issc_fc issc(2,2,iatom,jatom,1) = issc(2,2,iatom,jatom,1) + issc_fc @@ -577,21 +568,21 @@ SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) IF(do_sd.AND.iatom.NE.jatom) THEN ! ! build the integral for the jatom - CALL cp_dbcsr_set(matrix_efg(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(3)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(4)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(5)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(6)%matrix,0.0_dp,error=error) - CALL build_efg_matrix(qs_env,matrix_efg,r_j,error) + CALL cp_dbcsr_set(matrix_efg(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(3)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(4)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(5)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(6)%matrix,0.0_dp) + CALL build_efg_matrix(qs_env,matrix_efg,r_j) DO ixyz = 1,6 CALL cp_dbcsr_sm_fm_multiply(matrix_efg(ixyz)%matrix,mo_coeff,& fc_psi0(ispin)%matrix,ncol=nmo,& ! fc_psi0 a buffer - & alpha=1.0_dp,beta=0.0_dp,error=error) - CALL cp_fm_trace(fc_psi0(ispin)%matrix,mo_coeff,buf,error=error) + & alpha=1.0_dp,beta=0.0_dp) + CALL cp_fm_trace(fc_psi0(ispin)%matrix,mo_coeff,buf) WRITE(*,*) ' jatom',jatom,ixyz,'tr(P*efg)=',buf DO jxyz = 1,6 - CALL cp_fm_trace(fc_psi0(ispin)%matrix,psi1_efg(ispin,jxyz)%matrix,buf,error=error) + CALL cp_fm_trace(fc_psi0(ispin)%matrix,psi1_efg(ispin,jxyz)%matrix,buf) issc_sd = 2.0_dp * maxocc * facsd * buf !issc(ixyz,jxyz,iatom,jatom) = issc_sd !write(*,*) 'pso_',ixyz,jxyz,' iatom',iatom,'jatom',jatom,issc_pso @@ -604,16 +595,16 @@ SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) IF(do_pso.AND.iatom.NE.jatom) THEN ! ! build the integral for the jatom - CALL cp_dbcsr_set(matrix_pso(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_pso(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_pso(3)%matrix,0.0_dp,error=error) - CALL build_pso_matrix(qs_env,matrix_pso,r_j,error) + CALL cp_dbcsr_set(matrix_pso(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_pso(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_pso(3)%matrix,0.0_dp) + CALL build_pso_matrix(qs_env,matrix_pso,r_j) DO ixyz = 1,3 CALL cp_dbcsr_sm_fm_multiply(matrix_pso(ixyz)%matrix,mo_coeff,& fc_psi0(ispin)%matrix,ncol=nmo,& ! fc_psi0 a buffer - & alpha=1.0_dp,beta=0.0_dp,error=error) + & alpha=1.0_dp,beta=0.0_dp) DO jxyz = 1,3 - CALL cp_fm_trace(fc_psi0(ispin)%matrix,psi1_pso(ispin,jxyz)%matrix,buf,error=error) + CALL cp_fm_trace(fc_psi0(ispin)%matrix,psi1_pso(ispin,jxyz)%matrix,buf) issc_pso = -2.0_dp * maxocc * facpso * buf issc(ixyz,jxyz,iatom,jatom,3) = issc(ixyz,jxyz,iatom,jatom,3) + issc_pso ENDDO @@ -626,31 +617,31 @@ SUBROUTINE issc_issc(issc_env,qs_env,iatom,error) IF(do_dso.AND.iatom.EQ.natom.AND.jatom.EQ.natom) THEN ! ! build the integral for the jatom - !CALL cp_dbcsr_set(matrix_dso(1)%matrix,0.0_dp,error=error) - !CALL cp_dbcsr_set(matrix_dso(2)%matrix,0.0_dp,error=error) - !CALL cp_dbcsr_set(matrix_dso(3)%matrix,0.0_dp,error=error) - !CALL cp_dbcsr_set(matrix_dso(4)%matrix,0.0_dp,error=error) - !CALL cp_dbcsr_set(matrix_dso(5)%matrix,0.0_dp,error=error) - !CALL cp_dbcsr_set(matrix_dso(6)%matrix,0.0_dp,error=error) - !CALL build_dso_matrix(qs_env,matrix_dso,r_i,r_j,error) + !CALL cp_dbcsr_set(matrix_dso(1)%matrix,0.0_dp) + !CALL cp_dbcsr_set(matrix_dso(2)%matrix,0.0_dp) + !CALL cp_dbcsr_set(matrix_dso(3)%matrix,0.0_dp) + !CALL cp_dbcsr_set(matrix_dso(4)%matrix,0.0_dp) + !CALL cp_dbcsr_set(matrix_dso(5)%matrix,0.0_dp) + !CALL cp_dbcsr_set(matrix_dso(6)%matrix,0.0_dp) + !CALL build_dso_matrix(qs_env,matrix_dso,r_i,r_j) !DO ixyz = 1,6 ! CALL cp_sm_fm_multiply(matrix_dso(ixyz)%matrix,mo_coeff,& ! & fc_psi0(ispin)%matrix,ncol=nmo,& ! fc_psi0 a buffer - ! & alpha=1.0_dp,beta=0.0_dp,error=error) - ! CALL cp_fm_trace(fc_psi0(ispin)%matrix,mo_coeff,buf,error=error) + ! & alpha=1.0_dp,beta=0.0_dp) + ! CALL cp_fm_trace(fc_psi0(ispin)%matrix,mo_coeff,buf) ! issc_dso = 2.0_dp * maxocc * facdso * buf ! issc(ixyz,jxyz,iatom,jatom,4) = issc_dso !ENDDO - !CALL cp_dbcsr_set(matrix_dso(1)%matrix,0.0_dp,error=error) - !CALL cp_dbcsr_set(matrix_dso(2)%matrix,0.0_dp,error=error) - !CALL cp_dbcsr_set(matrix_dso(3)%matrix,0.0_dp,error=error) - !CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1,error=error) + !CALL cp_dbcsr_set(matrix_dso(1)%matrix,0.0_dp) + !CALL cp_dbcsr_set(matrix_dso(2)%matrix,0.0_dp) + !CALL cp_dbcsr_set(matrix_dso(3)%matrix,0.0_dp) + !CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1) DO ixyz = 1,3 CALL cp_dbcsr_sm_fm_multiply(matrix_dso(ixyz)%matrix,mo_coeff,& fc_psi0(ispin)%matrix,ncol=nmo,& ! fc_psi0 a buffer - & alpha=1.0_dp,beta=0.0_dp,error=error) + & alpha=1.0_dp,beta=0.0_dp) DO jxyz = 1,3 - CALL cp_fm_trace(psi1_dso(ispin,jxyz)%matrix,fc_psi0(ispin)%matrix,buf,error=error) + CALL cp_fm_trace(psi1_dso(ispin,jxyz)%matrix,fc_psi0(ispin)%matrix,buf) ! we save the polarizability for a checksum later on ! issc_dso = 2.0_dp * maxocc * buf !WRITE(*,*) ixyz,jxyz,'tr(P_r*r)=',2.0_dp * maxocc * buf @@ -673,12 +664,10 @@ END SUBROUTINE issc_issc !> \brief ... !> \param issc_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE issc_print(issc_env,qs_env,error) + SUBROUTINE issc_print(issc_env,qs_env) TYPE(issc_env_type) :: issc_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'issc_print', & routineP = moduleN//':'//routineN @@ -706,24 +695,22 @@ SUBROUTINE issc_print(issc_env,qs_env,error) NULLIFY(logger,particle_set,atom_kind_i,atom_kind_j,dft_control) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) issc_section => section_vals_get_subs_vals(qs_env%input, & - "PROPERTIES%LINRES%SPINSPIN",error=error) + "PROPERTIES%LINRES%SPINSPIN") CALL get_issc_env(issc_env=issc_env, & issc=issc, & do_fc=do_fc, & do_sd=do_sd, & do_pso=do_pso, & - do_dso=do_dso, & - error=error) + do_dso=do_dso) ! CALL get_qs_env(qs_env=qs_env, & dft_control=dft_control, & - particle_set=particle_set, & - error=error) + particle_set=particle_set) natom = SIZE(particle_set,1) gapw = dft_control%qs_control%gapw @@ -735,11 +722,10 @@ SUBROUTINE issc_print(issc_env,qs_env,error) ENDIF ! IF(BTEST(cp_print_key_should_output(logger%iter_info,issc_section,& - "PRINT%K_MATRIX",error=error),cp_p_file)) THEN + "PRINT%K_MATRIX"),cp_p_file)) THEN unit_atoms=cp_print_key_unit_nr(logger,issc_section,"PRINT%K_MATRIX",& - extension=".data",middle_name="K",log_filename=.FALSE.,& - error=error) + extension=".data",middle_name="K",log_filename=.FALSE.) IF(unit_atoms > 0) THEN WRITE(unit_atoms,*) @@ -759,25 +745,25 @@ SUBROUTINE issc_print(issc_env,qs_env,error) ! FC issc_tmp(:,:) = issc(:,:,iatom,jatom,1) issc_tmp(:,:) = 0.5_dp * ( issc_tmp(:,:) + TRANSPOSE( issc_tmp(:,:) ) ) - CALL diamat_all(issc_tmp,eig,error=error) + CALL diamat_all(issc_tmp,eig) issc_iso_fc = (eig(1)+ eig(2)+eig(3))/3.0_dp ! ! SD issc_tmp(:,:) = issc(:,:,iatom,jatom,2) issc_tmp(:,:) = 0.5_dp * ( issc_tmp(:,:) + TRANSPOSE( issc_tmp(:,:) ) ) - CALL diamat_all(issc_tmp,eig,error=error) + CALL diamat_all(issc_tmp,eig) issc_iso_sd = (eig(1)+ eig(2)+eig(3))/3.0_dp ! ! PSO issc_tmp(:,:) = issc(:,:,iatom,jatom,3) issc_tmp(:,:) = 0.5_dp * ( issc_tmp(:,:) + TRANSPOSE( issc_tmp(:,:) ) ) - CALL diamat_all(issc_tmp,eig,error=error) + CALL diamat_all(issc_tmp,eig) issc_iso_pso = (eig(1)+ eig(2)+eig(3))/3.0_dp ! ! DSO issc_tmp(:,:) = issc(:,:,iatom,jatom,4) issc_tmp(:,:) = 0.5_dp * ( issc_tmp(:,:) + TRANSPOSE( issc_tmp(:,:) ) ) - CALL diamat_all(issc_tmp,eig,error=error) + CALL diamat_all(issc_tmp,eig) issc_iso_dso = (eig(1)+ eig(2)+eig(3))/3.0_dp ! ! TOT @@ -799,7 +785,7 @@ SUBROUTINE issc_print(issc_env,qs_env,error) ENDDO ENDIF CALL cp_print_key_finished_output(unit_atoms,logger,issc_section,& - & "PRINT%K_MATRIX",error=error) + & "PRINT%K_MATRIX") ENDIF ! ! @@ -810,13 +796,11 @@ END SUBROUTINE issc_print !> \brief Initialize the issc environment !> \param issc_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE issc_env_init(issc_env,qs_env,error) + SUBROUTINE issc_env_init(issc_env,qs_env) ! TYPE(issc_env_type) :: issc_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_env_init', & routineP = moduleN//':'//routineN @@ -856,14 +840,14 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) NULLIFY(particle_set, qs_kind_set) NULLIFY(sab_orb) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(issc_env%ref_count /= 0) THEN - CALL issc_env_cleanup(issc_env,error=error) + CALL issc_env_cleanup(issc_env) ENDIF IF(output_unit>0) THEN @@ -871,12 +855,12 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) WRITE(output_unit,"(T10,A,/)") "Inizialization of the ISSC environment" ENDIF - CALL issc_env_create(issc_env,error=error) + CALL issc_env_create(issc_env) ! issc_section => section_vals_get_subs_vals(qs_env%input, & - & "PROPERTIES%LINRES%SPINSPIN",error=error) - !CALL section_vals_val_get(nmr_section,"INTERPOLATE_SHIFT",l_val=nmr_env%interpolate_shift,error=error) - !CALL section_vals_val_get(nmr_section,"SHIFT_GAPW_RADIUS",r_val=nmr_env%shift_gapw_radius,error=error) + & "PROPERTIES%LINRES%SPINSPIN") + !CALL section_vals_val_get(nmr_section,"INTERPOLATE_SHIFT",l_val=nmr_env%interpolate_shift) + !CALL section_vals_val_get(nmr_section,"SHIFT_GAPW_RADIUS",r_val=nmr_env%shift_gapw_radius) CALL get_qs_env(qs_env=qs_env,& dft_control=dft_control,& @@ -885,8 +869,7 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) sab_orb=sab_orb,& particle_set=particle_set,& qs_kind_set=qs_kind_set,& - dbcsr_dist=dbcsr_dist,& - error=error) + dbcsr_dist=dbcsr_dist) ! ! gapw = dft_control%qs_control%gapw @@ -894,7 +877,7 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) natom = SIZE(particle_set,1) ! ! check that the psi0 are localized and you have all the centers - CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,error,failure) + CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,failure) IF(failure.AND.(output_unit>0)) THEN WRITE(output_unit,'(A)') & ' To get indirect spin-spin coupling parameters within PBC you need to localize zero order orbitals ' @@ -903,24 +886,24 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) ! ! read terms need to be calculated ! FC - CALL section_vals_val_get(issc_section,"DO_FC",l_val=issc_env%do_fc,error=error) + CALL section_vals_val_get(issc_section,"DO_FC",l_val=issc_env%do_fc) ! SD - CALL section_vals_val_get(issc_section,"DO_SD",l_val=issc_env%do_sd,error=error) + CALL section_vals_val_get(issc_section,"DO_SD",l_val=issc_env%do_sd) ! PSO - CALL section_vals_val_get(issc_section,"DO_PSO",l_val=issc_env%do_pso,error=error) + CALL section_vals_val_get(issc_section,"DO_PSO",l_val=issc_env%do_pso) ! DSO - CALL section_vals_val_get(issc_section,"DO_DSO",l_val=issc_env%do_dso,error=error) + CALL section_vals_val_get(issc_section,"DO_DSO",l_val=issc_env%do_dso) ! ! ! read the list of atoms on which the issc need to be calculated - CALL section_vals_val_get(issc_section,"ISSC_ON_ATOM_LIST",n_rep_val=n_rep,error=error) + CALL section_vals_val_get(issc_section,"ISSC_ON_ATOM_LIST",n_rep_val=n_rep) ! ! NULLIFY(issc_env%issc_on_atom_list) n = 0 DO ir = 1,n_rep NULLIFY(list) - CALL section_vals_val_get(issc_section,"ISSC_ON_ATOM_LIST",i_rep_val=ir,i_vals=list,error=error) + CALL section_vals_val_get(issc_section,"ISSC_ON_ATOM_LIST",i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(issc_env%issc_on_atom_list,1,n+SIZE(list)) DO ini = 1,SIZE(list) @@ -932,7 +915,7 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) ! IF(.NOT.ASSOCIATED(issc_env%issc_on_atom_list)) THEN ALLOCATE(issc_env%issc_on_atom_list(natom),STAT=istat) - CPPrecondition(istat.EQ.0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat.EQ.0,cp_warning_level,routineP,failure) DO iatom = 1,natom issc_env%issc_on_atom_list(iatom) = iatom ENDDO @@ -944,7 +927,7 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) ALLOCATE(issc_env%issc(3,3,issc_env%issc_natms,issc_env%issc_natms,4),& issc_env%issc_loc(3,3,issc_env%issc_natms,issc_env%issc_natms,4),& STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) issc_env%issc(:,:,:,:,:) = 0.0_dp issc_env%issc_loc(:,:,:,:,:) = 0.0_dp ! @@ -953,137 +936,134 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) issc_env%psi1_efg(nspins,6),issc_env%psi1_pso(nspins,3),issc_env%psi1_fc(nspins),& issc_env%dso_psi0(nspins,3),issc_env%psi1_dso(nspins,3),& STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins !mo_coeff => current_env%psi0_order(ispin)%matrix CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=m,nrow_global=nao,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=m,nrow_global=nao) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=m,& - context=mo_coeff%matrix_struct%context,& - error=error) + context=mo_coeff%matrix_struct%context) DO idir = 1,6 NULLIFY(issc_env%psi1_efg(ispin,idir)%matrix,issc_env%efg_psi0(ispin,idir)%matrix) - CALL cp_fm_create(issc_env%psi1_efg(ispin,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(issc_env%efg_psi0(ispin,idir)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(issc_env%psi1_efg(ispin,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(issc_env%efg_psi0(ispin,idir)%matrix,tmp_fm_struct) ENDDO DO idir = 1,3 NULLIFY(issc_env%psi1_pso(ispin,idir)%matrix,issc_env%pso_psi0(ispin,idir)%matrix,& issc_env%dso_psi0(ispin,idir)%matrix) - CALL cp_fm_create(issc_env%psi1_pso(ispin,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(issc_env%pso_psi0(ispin,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(issc_env%psi1_dso(ispin,idir)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(issc_env%dso_psi0(ispin,idir)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(issc_env%psi1_pso(ispin,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(issc_env%pso_psi0(ispin,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(issc_env%psi1_dso(ispin,idir)%matrix,tmp_fm_struct) + CALL cp_fm_create(issc_env%dso_psi0(ispin,idir)%matrix,tmp_fm_struct) ENDDO NULLIFY(issc_env%psi1_fc(ispin)%matrix,issc_env%fc_psi0(ispin)%matrix) - CALL cp_fm_create(issc_env%psi1_fc(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(issc_env%fc_psi0(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_fm_create(issc_env%psi1_fc(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create(issc_env%fc_psi0(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ENDDO ! ! prepare for allocation ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! efg, pso and fc operators - CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_efg,6,error=error) + CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_efg,6) ALLOCATE(issc_env%matrix_efg(1)%matrix) - CALL cp_dbcsr_init(issc_env%matrix_efg(1)%matrix,error=error) + CALL cp_dbcsr_init(issc_env%matrix_efg(1)%matrix) CALL cp_dbcsr_create(matrix=issc_env%matrix_efg(1)%matrix, & name="efg (3xx-rr)/3", & dist=dbcsr_dist, matrix_type=dbcsr_type_symmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(issc_env%matrix_efg(1)%matrix,sab_orb,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(issc_env%matrix_efg(1)%matrix,sab_orb) ALLOCATE(issc_env%matrix_efg(2)%matrix,& issc_env%matrix_efg(3)%matrix,issc_env%matrix_efg(4)%matrix,& issc_env%matrix_efg(5)%matrix,issc_env%matrix_efg(6)%matrix) - CALL cp_dbcsr_init (issc_env%matrix_efg(2)%matrix,error=error) - CALL cp_dbcsr_init (issc_env%matrix_efg(3)%matrix,error=error) - CALL cp_dbcsr_init (issc_env%matrix_efg(4)%matrix,error=error) - CALL cp_dbcsr_init (issc_env%matrix_efg(5)%matrix,error=error) - CALL cp_dbcsr_init (issc_env%matrix_efg(6)%matrix,error=error) + CALL cp_dbcsr_init (issc_env%matrix_efg(2)%matrix) + CALL cp_dbcsr_init (issc_env%matrix_efg(3)%matrix) + CALL cp_dbcsr_init (issc_env%matrix_efg(4)%matrix) + CALL cp_dbcsr_init (issc_env%matrix_efg(5)%matrix) + CALL cp_dbcsr_init (issc_env%matrix_efg(6)%matrix) CALL cp_dbcsr_copy(issc_env%matrix_efg(2)%matrix,issc_env%matrix_efg(1)%matrix,& - 'efg xy',error=error) + 'efg xy') CALL cp_dbcsr_copy(issc_env%matrix_efg(3)%matrix,issc_env%matrix_efg(1)%matrix,& - 'efg xz',error=error) + 'efg xz') CALL cp_dbcsr_copy(issc_env%matrix_efg(4)%matrix,issc_env%matrix_efg(1)%matrix,& - 'efg (3yy-rr)/3',error=error) + 'efg (3yy-rr)/3') CALL cp_dbcsr_copy(issc_env%matrix_efg(5)%matrix,issc_env%matrix_efg(1)%matrix,& - 'efg yz',error=error) + 'efg yz') CALL cp_dbcsr_copy(issc_env%matrix_efg(6)%matrix,issc_env%matrix_efg(1)%matrix,& - 'efg (3zz-rr)/3',error=error) - - CALL cp_dbcsr_set(issc_env%matrix_efg(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_efg(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_efg(3)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_efg(4)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_efg(5)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_efg(6)%matrix,0.0_dp,error=error) + 'efg (3zz-rr)/3') + + CALL cp_dbcsr_set(issc_env%matrix_efg(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_efg(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_efg(3)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_efg(4)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_efg(5)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_efg(6)%matrix,0.0_dp) ! ! PSO - CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_pso,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_pso,3) ALLOCATE(issc_env%matrix_pso(1)%matrix) - CALL cp_dbcsr_init(issc_env%matrix_pso(1)%matrix,error=error) + CALL cp_dbcsr_init(issc_env%matrix_pso(1)%matrix) CALL cp_dbcsr_create(matrix=issc_env%matrix_pso(1)%matrix, & name="pso x", & dist=dbcsr_dist, matrix_type=dbcsr_type_antisymmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(issc_env%matrix_pso(1)%matrix,sab_orb,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(issc_env%matrix_pso(1)%matrix,sab_orb) ALLOCATE(issc_env%matrix_pso(2)%matrix,issc_env%matrix_pso(3)%matrix) - CALL cp_dbcsr_init (issc_env%matrix_pso(2)%matrix,error=error) - CALL cp_dbcsr_init (issc_env%matrix_pso(3)%matrix,error=error) + CALL cp_dbcsr_init (issc_env%matrix_pso(2)%matrix) + CALL cp_dbcsr_init (issc_env%matrix_pso(3)%matrix) CALL cp_dbcsr_copy(issc_env%matrix_pso(2)%matrix,issc_env%matrix_pso(1)%matrix,& - 'pso y',error=error) + 'pso y') CALL cp_dbcsr_copy(issc_env%matrix_pso(3)%matrix,issc_env%matrix_pso(1)%matrix,& - 'pso z',error=error) - CALL cp_dbcsr_set(issc_env%matrix_pso(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_pso(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_pso(3)%matrix,0.0_dp,error=error) + 'pso z') + CALL cp_dbcsr_set(issc_env%matrix_pso(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_pso(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_pso(3)%matrix,0.0_dp) ! ! DSO - CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_dso,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_dso,3) ALLOCATE(issc_env%matrix_dso(1)%matrix,issc_env%matrix_dso(2)%matrix,issc_env%matrix_dso(3)%matrix) - CALL cp_dbcsr_init(issc_env%matrix_dso(1)%matrix,error=error) - CALL cp_dbcsr_init(issc_env%matrix_dso(2)%matrix,error=error) - CALL cp_dbcsr_init(issc_env%matrix_dso(3)%matrix,error=error) + CALL cp_dbcsr_init(issc_env%matrix_dso(1)%matrix) + CALL cp_dbcsr_init(issc_env%matrix_dso(2)%matrix) + CALL cp_dbcsr_init(issc_env%matrix_dso(3)%matrix) CALL cp_dbcsr_copy(issc_env%matrix_dso(1)%matrix,issc_env%matrix_efg(1)%matrix,& - 'dso x',error=error) + 'dso x') CALL cp_dbcsr_copy(issc_env%matrix_dso(2)%matrix,issc_env%matrix_efg(1)%matrix,& - 'dso y',error=error) + 'dso y') CALL cp_dbcsr_copy(issc_env%matrix_dso(3)%matrix,issc_env%matrix_efg(1)%matrix,& - 'dso z',error=error) - CALL cp_dbcsr_set(issc_env%matrix_dso(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_dso(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(issc_env%matrix_dso(3)%matrix,0.0_dp,error=error) + 'dso z') + CALL cp_dbcsr_set(issc_env%matrix_dso(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_dso(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(issc_env%matrix_dso(3)%matrix,0.0_dp) ! ! FC - CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_fc,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(issc_env%matrix_fc,1) ALLOCATE(issc_env%matrix_fc(1)%matrix) - CALL cp_dbcsr_init(issc_env%matrix_fc(1)%matrix,error=error) + CALL cp_dbcsr_init(issc_env%matrix_fc(1)%matrix) CALL cp_dbcsr_copy(issc_env%matrix_fc(1)%matrix,issc_env%matrix_efg(1)%matrix,& - 'fc',error=error) - CALL cp_dbcsr_set(issc_env%matrix_fc(1)%matrix,0.0_dp,error=error) + 'fc') + CALL cp_dbcsr_set(issc_env%matrix_fc(1)%matrix,0.0_dp) DEALLOCATE(row_blk_sizes) ! @@ -1094,7 +1074,7 @@ SUBROUTINE issc_env_init(issc_env,qs_env,error) ENDIF CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - & "PRINT%PROGRAM_RUN_INFO",error=error) + & "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -1103,13 +1083,11 @@ END SUBROUTINE issc_env_init ! ***************************************************************************** !> \brief Deallocate the issc environment !> \param issc_env ... -!> \param error ... !> \par History ! ***************************************************************************** - SUBROUTINE issc_env_cleanup(issc_env,error) + SUBROUTINE issc_env_cleanup(issc_env) TYPE(issc_env_type) :: issc_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_env_cleanup', & routineP = moduleN//':'//routineN @@ -1123,125 +1101,125 @@ SUBROUTINE issc_env_cleanup(issc_env,error) IF(issc_env%ref_count == 0 ) THEN IF(ASSOCIATED(issc_env%issc_on_atom_list)) THEN DEALLOCATE(issc_env%issc_on_atom_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(issc_env%issc)) THEN DEALLOCATE(issc_env%issc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(issc_env%issc_loc)) THEN DEALLOCATE(issc_env%issc_loc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !efg_psi0 IF(ASSOCIATED(issc_env%efg_psi0)) THEN DO idir = 1,SIZE(issc_env%efg_psi0,2) DO ispin = 1,SIZE(issc_env%efg_psi0,1) - CALL cp_fm_release(issc_env%efg_psi0(ispin,idir)%matrix,error=error) + CALL cp_fm_release(issc_env%efg_psi0(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(issc_env%efg_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !pso_psi0 IF(ASSOCIATED(issc_env%pso_psi0)) THEN DO idir = 1,SIZE(issc_env%pso_psi0,2) DO ispin = 1,SIZE(issc_env%pso_psi0,1) - CALL cp_fm_release(issc_env%pso_psi0(ispin,idir)%matrix,error=error) + CALL cp_fm_release(issc_env%pso_psi0(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(issc_env%pso_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !dso_psi0 IF(ASSOCIATED(issc_env%dso_psi0)) THEN DO idir = 1,SIZE(issc_env%dso_psi0,2) DO ispin = 1,SIZE(issc_env%dso_psi0,1) - CALL cp_fm_release(issc_env%dso_psi0(ispin,idir)%matrix,error=error) + CALL cp_fm_release(issc_env%dso_psi0(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(issc_env%dso_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !fc_psi0 IF(ASSOCIATED(issc_env%fc_psi0)) THEN DO ispin = 1,SIZE(issc_env%fc_psi0,1) - CALL cp_fm_release(issc_env%fc_psi0(ispin)%matrix,error=error) + CALL cp_fm_release(issc_env%fc_psi0(ispin)%matrix) ENDDO DEALLOCATE(issc_env%fc_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !psi1_efg IF(ASSOCIATED(issc_env%psi1_efg)) THEN DO idir = 1,SIZE(issc_env%psi1_efg,2) DO ispin = 1,SIZE(issc_env%psi1_efg,1) - CALL cp_fm_release(issc_env%psi1_efg(ispin,idir)%matrix,error=error) + CALL cp_fm_release(issc_env%psi1_efg(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(issc_env%psi1_efg,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !psi1_pso IF(ASSOCIATED(issc_env%psi1_pso)) THEN DO idir = 1,SIZE(issc_env%psi1_pso,2) DO ispin = 1,SIZE(issc_env%psi1_pso,1) - CALL cp_fm_release(issc_env%psi1_pso(ispin,idir)%matrix,error=error) + CALL cp_fm_release(issc_env%psi1_pso(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(issc_env%psi1_pso,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !psi1_dso IF(ASSOCIATED(issc_env%psi1_dso)) THEN DO idir = 1,SIZE(issc_env%psi1_dso,2) DO ispin = 1,SIZE(issc_env%psi1_dso,1) - CALL cp_fm_release(issc_env%psi1_dso(ispin,idir)%matrix,error=error) + CALL cp_fm_release(issc_env%psi1_dso(ispin,idir)%matrix) ENDDO ENDDO DEALLOCATE(issc_env%psi1_dso,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !psi1_fc IF(ASSOCIATED(issc_env%psi1_fc)) THEN DO ispin = 1,SIZE(issc_env%psi1_fc,1) - CALL cp_fm_release(issc_env%psi1_fc(ispin)%matrix,error=error) + CALL cp_fm_release(issc_env%psi1_fc(ispin)%matrix) ENDDO DEALLOCATE(issc_env%psi1_fc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! ! cubes !IF(ASSOCIATED(issc_env%list_cubes)) THEN ! DEALLOCATE(issc_env%list_cubes,STAT=istat) - ! CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + ! CPPostcondition(istat==0,cp_failure_level,routineP,failure) !ENDIF ! !matrix_efg IF(ASSOCIATED(issc_env%matrix_efg)) THEN - CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_efg,error=error) + CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_efg) ENDIF ! !matrix_pso IF(ASSOCIATED(issc_env%matrix_pso)) THEN - CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_pso,error=error) + CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_pso) ENDIF ! !matrix_dso IF(ASSOCIATED(issc_env%matrix_dso)) THEN - CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_dso,error=error) + CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_dso) ENDIF ! !matrix_fc IF(ASSOCIATED(issc_env%matrix_fc)) THEN - CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_fc,error=error) + CALL cp_dbcsr_deallocate_matrix_set(issc_env%matrix_fc) ENDIF ENDIF ! ref count diff --git a/src/qs_linres_methods.F b/src/qs_linres_methods.F index 034e058eed..cd81c6df80 100644 --- a/src/qs_linres_methods.F +++ b/src/qs_linres_methods.F @@ -143,18 +143,16 @@ MODULE qs_linres_methods !> \param linres_control ... !> \param nspins ... !> \param centers_only ... -!> \param error ... !> \par History !> 07.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE linres_localize(qs_env,linres_control,nspins,centers_only,error) + SUBROUTINE linres_localize(qs_env,linres_control,nspins,centers_only) TYPE(qs_environment_type), POINTER :: qs_env TYPE(linres_control_type), POINTER :: linres_control INTEGER, INTENT(IN) :: nspins LOGICAL, INTENT(IN), OPTIONAL :: centers_only - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_localize', & routineP = moduleN//':'//routineN @@ -176,31 +174,31 @@ SUBROUTINE linres_localize(qs_env,linres_control,nspins,centers_only,error) failure = .FALSE. NULLIFY(logger, lr_section, loc_section, loc_print_section,localized_wfn_control) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) - loc_section => section_vals_get_subs_vals(lr_section,"LOCALIZE",error=error) - loc_print_section => section_vals_get_subs_vals(lr_section,"LOCALIZE%PRINT",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") + loc_section => section_vals_get_subs_vals(lr_section,"LOCALIZE") + loc_print_section => section_vals_get_subs_vals(lr_section,"LOCALIZE%PRINT") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") my_centers_only = .FALSE. IF(PRESENT(centers_only)) my_centers_only = centers_only NULLIFY(mos,mo_coeff,qs_loc_env,mos_localized) - CALL get_qs_env(qs_env=qs_env,mos=mos,error=error) - CALL qs_loc_env_create(qs_loc_env,error=error) - CALL qs_loc_env_retain(qs_loc_env, error=error) + CALL get_qs_env(qs_env=qs_env,mos=mos) + CALL qs_loc_env_create(qs_loc_env) + CALL qs_loc_env_retain(qs_loc_env) linres_control% qs_loc_env=> qs_loc_env - CALL qs_loc_env_release(qs_loc_env,error=error) + CALL qs_loc_env_release(qs_loc_env) qs_loc_env => linres_control% qs_loc_env - CALL qs_loc_control_init(qs_loc_env,loc_section,do_homo=.TRUE.,error=error) - CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control,error=error) + CALL qs_loc_control_init(qs_loc_env,loc_section,do_homo=.TRUE.) + CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control) ALLOCATE(mos_localized(nspins),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_create(mos_localized(ispin)%matrix,mo_coeff%matrix_struct,error=error) - CALL cp_fm_to_fm(mo_coeff,mos_localized(ispin)%matrix,error=error) + CALL cp_fm_create(mos_localized(ispin)%matrix,mo_coeff%matrix_struct) + CALL cp_fm_to_fm(mo_coeff,mos_localized(ispin)%matrix) END DO @@ -212,19 +210,19 @@ SUBROUTINE linres_localize(qs_env,linres_control,nspins,centers_only,error) ENDIF CALL qs_loc_init(qs_env, qs_loc_env,loc_section,mos_localized=mos_localized,& - do_homo=.TRUE.,error=error) + do_homo=.TRUE.) ! The orbital centers are stored in linres_control%localized_wfn_control DO ispin = 1,nspins CALL qs_loc_driver(qs_env,qs_loc_env,loc_print_section, myspin = ispin,& - ext_mo_coeff=mos_localized(ispin)%matrix,error=error) + ext_mo_coeff=mos_localized(ispin)%matrix) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_to_fm(mos_localized(ispin)%matrix,mo_coeff,error=error) + CALL cp_fm_to_fm(mos_localized(ispin)%matrix,mo_coeff) END DO CALL loc_write_restart(qs_loc_env,loc_print_section,mos,& - mos_localized, do_homo=.TRUE., error=error) - CALL cp_fm_vect_dealloc(mos_localized,error) + mos_localized, do_homo=.TRUE.) + CALL cp_fm_vect_dealloc(mos_localized) ! Write Centers and Spreads on std out @@ -257,19 +255,17 @@ END SUBROUTINE linres_localize !> \param h1_psi0 ... !> \param psi0_order ... !> \param should_stop ... -!> \param error ... !> \par History !> 07.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, error) + SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop) ! TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: psi1, h1_psi0, psi0_order LOGICAL, INTENT(OUT) :: should_stop - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_solver', & routineP = moduleN//':'//routineN @@ -306,7 +302,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, NULLIFY(Ap,r,p,z,lr_section,logger,buf,mos,tmp_fm_struct,mo_coeff) NULLIFY(Sc,chc) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() t1 = m_walltime() CALL get_qs_env(qs_env=qs_env,& @@ -316,8 +312,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, dft_control=dft_control,& linres_control=linres_control,& para_env=para_env,& - mos=mos,& - error=error) + mos=mos) ! nspins = dft_control%nspins @@ -327,21 +322,21 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, DO ispin = 1,nspins CALL get_mo_set(mos(ispin)%mo_set,nmo=ncol) maxnmo = MAX(maxnmo,ncol) - CALL cp_fm_get_info(psi0_order(ispin)%matrix,ncol_global=ncol,error=error) + CALL cp_fm_get_info(psi0_order(ispin)%matrix,ncol_global=ncol) maxnmo_o = MAX(maxnmo_o,ncol) ENDDO ! - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") ! - CALL check_p_env_init(p_env,linres_control,nspins,error=error) + CALL check_p_env_init(p_env,linres_control,nspins) ! ! allocate the vectors ALLOCATE(alpha(nspins),beta(nspins),tr_pAp(nspins),tr_rz0(nspins),tr_rz00(nspins),tr_rz1(nspins),& r(nspins),p(nspins),z(nspins),Ap(nspins),mo_coeff_array(nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff) mo_coeff_array(ispin)%matrix => mo_coeff @@ -349,49 +344,47 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! DO ispin = 1,nspins NULLIFY(r(ispin)%matrix,p(ispin)%matrix,z(ispin)%matrix,Ap(ispin)%matrix) - CALL cp_fm_create(r(ispin)%matrix,psi1(ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_create(p(ispin)%matrix,psi1(ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_create(z(ispin)%matrix,psi1(ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_create(Ap(ispin)%matrix,psi1(ispin)%matrix%matrix_struct,error=error) + CALL cp_fm_create(r(ispin)%matrix,psi1(ispin)%matrix%matrix_struct) + CALL cp_fm_create(p(ispin)%matrix,psi1(ispin)%matrix%matrix_struct) + CALL cp_fm_create(z(ispin)%matrix,psi1(ispin)%matrix%matrix_struct) + CALL cp_fm_create(Ap(ispin)%matrix,psi1(ispin)%matrix%matrix_struct) ENDDO ! NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=maxnmo,para_env=para_env,& - context=psi1(1)%matrix%matrix_struct%context,& - error=error) - CALL cp_fm_create(buf,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=psi1(1)%matrix%matrix_struct%context) + CALL cp_fm_create(buf,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ! ! ! ! compute S*C0, C0_order'*H*C0_order (this should be done once for all) ALLOCATE(chc(nspins),Sc(nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff,nmo=nmo) - CALL cp_fm_create(Sc(ispin)%matrix,mo_coeff%matrix_struct,error=error) + CALL cp_fm_create(Sc(ispin)%matrix,mo_coeff%matrix_struct) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmo,& ncol_global=nmo,para_env=para_env,& - context=mo_coeff%matrix_struct%context,& - error=error) - CALL cp_fm_create(chc(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(chc(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ENDDO ! DO ispin = 1,nspins ! ! C0_order' * H * C0_order mo_coeff => psi0_order(ispin)%matrix - CALL cp_fm_get_info(mo_coeff,ncol_global=ncol,error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_ks(ispin)%matrix,mo_coeff,buf,ncol,error=error) - CALL cp_gemm('T','N',ncol,ncol,nao,-1.0_dp,mo_coeff,buf,0.0_dp,chc(ispin)%matrix,error) + CALL cp_fm_get_info(mo_coeff,ncol_global=ncol) + CALL cp_dbcsr_sm_fm_multiply(matrix_ks(ispin)%matrix,mo_coeff,buf,ncol) + CALL cp_gemm('T','N',ncol,ncol,nao,-1.0_dp,mo_coeff,buf,0.0_dp,chc(ispin)%matrix) ! ! S * C0 CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=ncol,error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,mo_coeff,Sc(ispin)%matrix,ncol,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=ncol) + CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,mo_coeff,Sc(ispin)%matrix,ncol) ENDDO ! ! @@ -404,7 +397,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ENDIF ! ! orthogonalize x with respect to the psi0 - CALL preortho(psi1,mo_coeff_array,Sc,buf,error) + CALL preortho(psi1,mo_coeff_array,Sc,buf) ! ! build the preconditioner IF(linres_control%preconditioner_type /= ot_precond_none) THEN @@ -414,7 +407,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, CALL make_preconditioner(p_env%preconditioner(ispin),& linres_control%preconditioner_type,ot_precond_solver_default,& matrix_ks(ispin)%matrix,matrix_s(1)%matrix,matrix_t(1)%matrix,& - mos(ispin)%mo_set,linres_control%energy_gap,error=error) + mos(ispin)%mo_set,linres_control%energy_gap) ENDDO p_env%new_preconditioner = .FALSE. ENDIF @@ -423,17 +416,17 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! initalization of the linear solver ! ! A * x0 - CALL apply_op(qs_env,p_env,psi0_order,psi1,Ap,chc,buf,error) + CALL apply_op(qs_env,p_env,psi0_order,psi1,Ap,chc,buf) ! ! ! r_0 = b - Ax0 DO ispin = 1,nspins - CALL cp_fm_to_fm(h1_psi0(ispin)%matrix,r(ispin)%matrix,error=error) - CALL cp_fm_scale_and_add(-1.0_dp,r(ispin)%matrix,-1.0_dp,Ap(ispin)%matrix,error=error) + CALL cp_fm_to_fm(h1_psi0(ispin)%matrix,r(ispin)%matrix) + CALL cp_fm_scale_and_add(-1.0_dp,r(ispin)%matrix,-1.0_dp,Ap(ispin)%matrix) ENDDO ! ! proj r - CALL postortho(r,mo_coeff_array,Sc,buf,error) + CALL postortho(r,mo_coeff_array,Sc,buf) ! ! preconditioner linres_control%flag="" @@ -441,7 +434,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! ! z_0 = r_0 DO ispin = 1,nspins - CALL cp_fm_to_fm(r(ispin)%matrix,z(ispin)%matrix,error=error) + CALL cp_fm_to_fm(r(ispin)%matrix,z(ispin)%matrix) ENDDO linres_control%flag="CG" ELSE @@ -449,7 +442,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! z_0 = M * r_0 DO ispin = 1,nspins CALL apply_preconditioner(p_env%preconditioner(ispin),r(ispin)%matrix,& - z(ispin)%matrix,error) + z(ispin)%matrix) ENDDO linres_control%flag="PCG" ENDIF @@ -458,10 +451,10 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, DO ispin = 1,nspins ! ! p_0 = z_0 - CALL cp_fm_to_fm(z(ispin)%matrix,p(ispin)%matrix,error=error) + CALL cp_fm_to_fm(z(ispin)%matrix,p(ispin)%matrix) ! ! trace(r_0 * z_0) - CALL cp_fm_trace(r(ispin)%matrix,z(ispin)%matrix,tr_rz0(ispin),error) + CALL cp_fm_trace(r(ispin)%matrix,z(ispin)%matrix,tr_rz0(ispin)) IF(tr_rz0(ispin).LT.0.0_dp) CALL stop_program(routineN,moduleN,__LINE__,& "tr(r_j*z_j) < 0") norm_res = MAX(norm_res,ABS(tr_rz0(ispin))/SQRT(REAL(nao*maxnmo_o,dp))) @@ -515,35 +508,35 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! ! ! Apply the operators that do not depend on the perturbation - CALL apply_op(qs_env,p_env,psi0_order,p,Ap,chc,buf,error) + CALL apply_op(qs_env,p_env,psi0_order,p,Ap,chc,buf) ! ! ! ! proj Ap onto the virtual subspace - CALL postortho(Ap,mo_coeff_array,Sc,buf,error) + CALL postortho(Ap,mo_coeff_array,Sc,buf) ! ! DO ispin = 1,nspins ! ! tr(Ap_j*p_j) - CALL cp_fm_trace(Ap(ispin)%matrix,p(ispin)%matrix,tr_pAp(ispin),error) + CALL cp_fm_trace(Ap(ispin)%matrix,p(ispin)%matrix,tr_pAp(ispin)) IF (tr_pAp(ispin).LT.0.0_dp) THEN ! try to fix it by getting rid of the preconditioner IF(iter>1) THEN - CALL cp_fm_scale_and_add(beta(ispin),p(ispin)%matrix,-1.0_dp,z(ispin)%matrix,error=error) - CALL cp_fm_trace(r(ispin)%matrix,r(ispin)%matrix,tr_rz1(ispin),error) + CALL cp_fm_scale_and_add(beta(ispin),p(ispin)%matrix,-1.0_dp,z(ispin)%matrix) + CALL cp_fm_trace(r(ispin)%matrix,r(ispin)%matrix,tr_rz1(ispin)) beta(ispin) = tr_rz1(ispin)/tr_rz00(ispin) - CALL cp_fm_scale_and_add(beta(ispin),p(ispin)%matrix,1.0_dp,r(ispin)%matrix,error=error) + CALL cp_fm_scale_and_add(beta(ispin),p(ispin)%matrix,1.0_dp,r(ispin)%matrix) tr_rz0(ispin) = tr_rz1(ispin) ELSE - CALL cp_fm_to_fm(r(ispin)%matrix,p(ispin)%matrix,error=error) - CALL cp_fm_trace(r(ispin)%matrix,r(ispin)%matrix,tr_rz0(ispin),error) + CALL cp_fm_to_fm(r(ispin)%matrix,p(ispin)%matrix) + CALL cp_fm_trace(r(ispin)%matrix,r(ispin)%matrix,tr_rz0(ispin)) END IF linres_control%flag="CG" - CALL apply_op(qs_env,p_env,psi0_order,p,Ap,chc,buf,error) - CALL postortho(Ap,mo_coeff_array,Sc,buf,error) - CALL cp_fm_trace(Ap(ispin)%matrix,p(ispin)%matrix,tr_pAp(ispin),error) + CALL apply_op(qs_env,p_env,psi0_order,p,Ap,chc,buf) + CALL postortho(Ap,mo_coeff_array,Sc,buf) + CALL cp_fm_trace(Ap(ispin)%matrix,p(ispin)%matrix,tr_pAp(ispin)) CALL stop_program(routineN,moduleN,__LINE__,& "tr(Ap_j*p_j) < 0") END IF @@ -556,7 +549,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ENDIF ! ! x_j+1 = x_j + alpha * p_j - CALL cp_fm_scale_and_add(1.0_dp,psi1(ispin)%matrix,alpha(ispin),p(ispin)%matrix,error=error) + CALL cp_fm_scale_and_add(1.0_dp,psi1(ispin)%matrix,alpha(ispin),p(ispin)%matrix) ENDDO ! ! need to recompute the residue @@ -565,24 +558,24 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! ! ! r_j+1 = b - A * x_j+1 - CALL apply_op(qs_env,p_env,psi0_order,psi1,Ap,chc,buf,error) + CALL apply_op(qs_env,p_env,psi0_order,psi1,Ap,chc,buf) ! ! DO ispin = 1,nspins CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_to_fm(h1_psi0(ispin)%matrix,r(ispin)%matrix,error=error) - CALL cp_fm_scale_and_add(-1.0_dp,r(ispin)%matrix,-1.0_dp,Ap(ispin)%matrix,error=error) + CALL cp_fm_to_fm(h1_psi0(ispin)%matrix,r(ispin)%matrix) + CALL cp_fm_scale_and_add(-1.0_dp,r(ispin)%matrix,-1.0_dp,Ap(ispin)%matrix) ENDDO - CALL postortho(r,mo_coeff_array,Sc,buf,error) + CALL postortho(r,mo_coeff_array,Sc,buf) ! restart = .TRUE. ELSE ! ! proj Ap onto the virtual subspace - CALL postortho(Ap,mo_coeff_array,Sc,buf,error) + CALL postortho(Ap,mo_coeff_array,Sc,buf) ! ! r_j+1 = r_j - alpha * Ap_j DO ispin = 1,nspins - CALL cp_fm_scale_and_add(1.0_dp,r(ispin)%matrix,-alpha(ispin),Ap(ispin)%matrix,error=error) + CALL cp_fm_scale_and_add(1.0_dp,r(ispin)%matrix,-alpha(ispin),Ap(ispin)%matrix) ENDDO restart = .FALSE. ENDIF @@ -593,7 +586,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! ! z_j+1 = r_j+1 DO ispin = 1,nspins - CALL cp_fm_to_fm(r(ispin)%matrix,z(ispin)%matrix,error=error) + CALL cp_fm_to_fm(r(ispin)%matrix,z(ispin)%matrix) ENDDO linres_control%flag="CG" ELSE @@ -601,7 +594,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ! z_j+1 = M * r_j+1 DO ispin = 1,nspins CALL apply_preconditioner(p_env%preconditioner(ispin),r(ispin)%matrix,& - z(ispin)%matrix,error) + z(ispin)%matrix) ENDDO linres_control%flag="PCG" ENDIF @@ -610,7 +603,7 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, DO ispin = 1,nspins ! ! tr(r_j+1*z_j+1) - CALL cp_fm_trace(r(ispin)%matrix,z(ispin)%matrix,tr_rz1(ispin),error) + CALL cp_fm_trace(r(ispin)%matrix,z(ispin)%matrix,tr_rz1(ispin)) IF(tr_rz1(ispin).LT.0.0_dp) CALL stop_program(routineN,moduleN,__LINE__,& "tr(r_j+1*z_j+1) < 0") norm_res = MAX(norm_res,tr_rz1(ispin)/SQRT(REAL(nao*maxnmo_o,dp))) @@ -623,36 +616,36 @@ SUBROUTINE linres_solver(p_env, qs_env, psi1, h1_psi0, psi0_order, should_stop, ENDIF ! ! p_j+1 = z_j+1 + beta * p_j - CALL cp_fm_scale_and_add(beta(ispin),p(ispin)%matrix,1.0_dp,z(ispin)%matrix,error=error) + CALL cp_fm_scale_and_add(beta(ispin),p(ispin)%matrix,1.0_dp,z(ispin)%matrix) tr_rz00(ispin) = tr_rz0(ispin) tr_rz0(ispin) = tr_rz1(ispin) ENDDO ! ** can we exit the SCF loop ? CALL external_control(should_stop,"LINRES",target_time=qs_env%target_time, & - start_time=qs_env%start_time,error=error) + start_time=qs_env%start_time) ENDDO iteration ! ! proj psi1 - CALL preortho(psi1,mo_coeff_array,Sc,buf,error) + CALL preortho(psi1,mo_coeff_array,Sc,buf) ! ! clean up DO ispin = 1,nspins - CALL cp_fm_release(r(ispin)%matrix,error=error) - CALL cp_fm_release(p(ispin)%matrix,error=error) - CALL cp_fm_release(z(ispin)%matrix,error=error) - CALL cp_fm_release(Ap(ispin)%matrix,error=error) + CALL cp_fm_release(r(ispin)%matrix) + CALL cp_fm_release(p(ispin)%matrix) + CALL cp_fm_release(z(ispin)%matrix) + CALL cp_fm_release(Ap(ispin)%matrix) ! - CALL cp_fm_release(Sc(ispin)%matrix,error=error) - CALL cp_fm_release(chc(ispin)%matrix,error=error) + CALL cp_fm_release(Sc(ispin)%matrix) + CALL cp_fm_release(chc(ispin)%matrix) ENDDO - CALL cp_fm_release(buf,error=error) + CALL cp_fm_release(buf) DEALLOCATE(alpha,beta,tr_pAp,tr_rz0,tr_rz00,tr_rz1,r,p,z,Ap,Sc,chc,mo_coeff_array,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! - CALL cp_print_key_finished_output(output_unit,logger,lr_section,"PRINT%PROGRAM_RUN_INFO",error=error) + CALL cp_print_key_finished_output(output_unit,logger,lr_section,"PRINT%PROGRAM_RUN_INFO") ! CALL timestop(handle) ! @@ -668,16 +661,14 @@ END SUBROUTINE linres_solver !> \param Av ... !> \param chc ... !> \param buf ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_op(qs_env,p_env,c0,v,Av,chc,buf,error) + SUBROUTINE apply_op(qs_env,p_env,c0,v,Av,chc,buf) ! TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: c0, v, Av, chc TYPE(cp_fm_type), POINTER :: buf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_op', & routineP = moduleN//':'//routineN @@ -699,17 +690,16 @@ SUBROUTINE apply_op(qs_env,p_env,c0,v,Av,chc,buf,error) ! CALL timeset(routineN,handle) ! - CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(Av),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(chc),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(Av),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(chc),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,failure) ! CALL get_qs_env(qs_env=qs_env,& matrix_ks=matrix_ks,& matrix_s=matrix_s,& dft_control=dft_control,& - linres_control=linres_control,& - error=error) + linres_control=linres_control) ! nspins = dft_control%nspins @@ -718,52 +708,51 @@ SUBROUTINE apply_op(qs_env,p_env,c0,v,Av,chc,buf,error) ! apply the uncoupled operator DO ispin = 1,nspins CALL apply_op_1(v(ispin)%matrix,Av(ispin)%matrix,matrix_ks(ispin)%matrix,& - matrix_s(1)%matrix,chc(ispin)%matrix,buf,error) + matrix_s(1)%matrix,chc(ispin)%matrix,buf) ENDDO IF(linres_control%do_kernel) THEN!.AND.chksum.GT.1.0E-10_dp) THEN ! ! build DM - CALL build_dm_response(c0,v,p_env%p1,error) + CALL build_dm_response(c0,v,p_env%p1) chksum = 0.0_dp DO ispin = 1,nspins - chksum = chksum + cp_dbcsr_checksum(p_env%p1(ispin)%matrix,error=error) + chksum = chksum + cp_dbcsr_checksum(p_env%p1(ispin)%matrix) ENDDO ! ! skip the kernel if the DM is very small IF(chksum.GT.1.0E-14_dp) THEN - CALL p_env_check_i_alloc(p_env,qs_env,error) + CALL p_env_check_i_alloc(p_env,qs_env) - CALL qs_rho_get(p_env%rho1, rho_ao=rho1_ao, error=error) + CALL qs_rho_get(p_env%rho1, rho_ao=rho1_ao) DO ispin = 1,nspins - CALL cp_dbcsr_copy(rho1_ao(ispin)%matrix,p_env%p1(ispin)%matrix,error=error) + CALL cp_dbcsr_copy(rho1_ao(ispin)%matrix,p_env%p1(ispin)%matrix) ENDDO CALL qs_rho_update_rho(rho_struct=p_env%rho1,local_rho_set=p_env%local_rho_set,& - qs_env=qs_env,error=error) + qs_env=qs_env) !if(first_time) then - CALL get_qs_env(qs_env,rho=rho,error=error) ! that could be called before - CALL qs_rho_update_rho(rho,qs_env=qs_env,error=error) ! that could be called before + CALL get_qs_env(qs_env,rho=rho) ! that could be called before + CALL qs_rho_update_rho(rho,qs_env=qs_env) ! that could be called before ! first_time = .false. !endif - CALL apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) + CALL apply_op_2(qs_env,p_env,c0,v,Av,chc,buf) - !CALL kpp1_calc_k_p_p1(p_env%kpp1_env, p_env, qs_env, p_env%kpp1, qs_env%rho, p_env%rho1, p_env%rho1_xc, error) + !CALL kpp1_calc_k_p_p1(p_env%kpp1_env, p_env, qs_env, p_env%kpp1, qs_env%rho, p_env%rho1, p_env%rho1_xc) !DO ispin = 1,nspins - ! CALL cp_fm_get_info(c0(ispin)%matrix,ncol_global=ncol,error=error) + ! CALL cp_fm_get_info(c0(ispin)%matrix,ncol_global=ncol) ! CALL cp_sm_fm_multiply(sparse_matrix=p_env%kpp1(ispin)%matrix,& ! v_in=c0(ispin)%matrix,& ! v_out=Av(ispin)%matrix,& - ! ncol=ncol,alpha=1.0_dp,beta=1.0_dp,& - ! error=error) + ! ncol=ncol,alpha=1.0_dp,beta=1.0_dp) !ENDDO ENDIF @@ -780,15 +769,13 @@ END SUBROUTINE apply_op !> \param c0 ... !> \param c1 ... !> \param dm ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_dm_response(c0,c1,dm,error) + SUBROUTINE build_dm_response(c0,c1,dm) ! TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: c0, c1 TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: dm - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_dm_response', & routineP = moduleN//':'//routineN @@ -801,23 +788,23 @@ SUBROUTINE build_dm_response(c0,c1,dm,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(c0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(c1),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(dm),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(c0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(c1),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(dm),cp_failure_level,routineP,failure) nspins = SIZE(dm,1) DO ispin = 1,nspins - CALL cp_dbcsr_set(dm(ispin)%matrix,0.0_dp,error=error) - CALL cp_fm_get_info(c0(ispin)%matrix,ncol_global=ncol,error=error) + CALL cp_dbcsr_set(dm(ispin)%matrix,0.0_dp) + CALL cp_fm_get_info(c0(ispin)%matrix,ncol_global=ncol) CALL cp_dbcsr_plus_fm_fm_t(dm(ispin)%matrix,& matrix_v=c0(ispin)%matrix,& matrix_g=c1(ispin)%matrix,& - ncol=ncol,alpha=1.0_dp,error=error) + ncol=ncol,alpha=1.0_dp) CALL cp_dbcsr_plus_fm_fm_t(dm(ispin)%matrix,& matrix_v=c1(ispin)%matrix,& matrix_g=c0(ispin)%matrix,& - ncol=ncol,alpha=1.0_dp,error=error) + ncol=ncol,alpha=1.0_dp) ENDDO END SUBROUTINE build_dm_response @@ -831,14 +818,12 @@ END SUBROUTINE build_dm_response !> \param matrix_s ... !> \param chc ... !> \param buf ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_op_1(v,Av,matrix_ks,matrix_s,chc,buf,error) + SUBROUTINE apply_op_1(v,Av,matrix_ks,matrix_s,chc,buf) ! TYPE(cp_fm_type), POINTER :: v, Av TYPE(cp_dbcsr_type), POINTER :: matrix_ks, matrix_s TYPE(cp_fm_type), POINTER :: chc, buf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_op_1', & routineP = moduleN//':'//routineN @@ -852,20 +837,20 @@ SUBROUTINE apply_op_1(v,Av,matrix_ks,matrix_s,chc,buf,error) ! CALL timeset(routineN,handle) ! - CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(Av),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_ks),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(chc),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(Av),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_ks),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(chc),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,failure) ! - CALL cp_fm_get_info(v,ncol_global=ncol,nrow_global=nrow,error=error) + CALL cp_fm_get_info(v,ncol_global=ncol,nrow_global=nrow) ! H * v - CALL cp_dbcsr_sm_fm_multiply(matrix_ks,v,Av,ncol,error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_ks,v,Av,ncol) ! v * e (chc already multiplied by -1) - CALL cp_gemm('N','N',nrow,ncol,ncol,1.0_dp,v,chc,0.0_dp,buf,error) + CALL cp_gemm('N','N',nrow,ncol,ncol,1.0_dp,v,chc,0.0_dp,buf) ! S * ve - CALL cp_dbcsr_sm_fm_multiply(matrix_s,buf,Av,ncol,alpha=1.0_dp,beta=1.0_dp,error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_s,buf,Av,ncol,alpha=1.0_dp,beta=1.0_dp) !Results is H*C1 - S**C1 ! CALL timestop(handle) @@ -882,16 +867,14 @@ END SUBROUTINE apply_op_1 !> \param Av ... !> \param chc ... !> \param buf ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) + SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf) ! TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: c0, v, Av, chc TYPE(cp_fm_type), POINTER :: buf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_op_2', & routineP = moduleN//':'//routineN @@ -933,110 +916,107 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) NULLIFY(auxbas_pw_pool, pw_pools, pw_env, v_rspace_new, & rho1_r, rho1_g_pw, tau_pw, v_xc, rho1_set, rho1_ao, rho_ao, & poisson_env, input, scf_section,rho,dft_control,logger, rho1_g) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() energy_hartree=0.0_dp energy_hartree_1c=0.0_dp - CPPrecondition(ASSOCIATED(c0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(Av),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(chc),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(c0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(Av),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(chc),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,failure) - CPPrecondition(ASSOCIATED(p_env%kpp1_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(p_env%kpp1),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env%kpp1_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(p_env%kpp1),cp_failure_level,routineP,failure) rho1 => p_env%rho1 rho1_xc => p_env%rho1_xc - CPPrecondition(ASSOCIATED(rho1),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho1),cp_failure_level,routineP,failure) - CPPrecondition(p_env%kpp1_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(p_env%kpp1_env%ref_count>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env,& pw_env=pw_env,& input=input,& rho=rho,& linres_control=linres_control,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) lr_triplet = linres_control%lr_triplet - CALL kpp1_check_i_alloc(p_env%kpp1_env,qs_env,lr_triplet,error=error) - !gapw=(section_get_ival(input,"DFT%QS%METHOD",error=error)==do_method_gapw) - !gapw_xc=(section_get_ival(input,"DFT%QS%METHOD",error=error)==do_method_gapw_xc) + CALL kpp1_check_i_alloc(p_env%kpp1_env,qs_env,lr_triplet) + !gapw=(section_get_ival(input,"DFT%QS%METHOD")==do_method_gapw) + !gapw_xc=(section_get_ival(input,"DFT%QS%METHOD")==do_method_gapw_xc) gapw = dft_control%qs_control%gapw gapw_xc = dft_control%qs_control%gapw_xc IF(gapw_xc) THEN - CPPrecondition(ASSOCIATED(rho1_xc),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho1_xc),cp_failure_level,routineP,failure) END IF nspins = SIZE(p_env%kpp1) lsd = (nspins==2) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) - scf_section => section_vals_get_subs_vals(input,"DFT%SCF",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") + scf_section => section_vals_get_subs_vals(input,"DFT%SCF") p_env%kpp1_env%iter=p_env%kpp1_env%iter+1 ! gets the tmp grids - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools, poisson_env=poisson_env,error=error) + pw_pools=pw_pools, poisson_env=poisson_env) ALLOCATE(v_rspace_new(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_gspace%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,v_hartree_rspace%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) IF (gapw .OR. gapw_xc) & - CALL prepare_gapw_den(qs_env,p_env%local_rho_set, do_rho0=(.NOT.gapw_xc), error=error) + CALL prepare_gapw_den(qs_env,p_env%local_rho_set, do_rho0=(.NOT.gapw_xc)) ! *** calculate the hartree potential on the total density *** IF (.NOT. failure) THEN CALL pw_pool_create_pw(auxbas_pw_pool, rho1_tot_gspace%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) - CALL qs_rho_get(rho1, rho_g=rho1_g, error=error) - CALL pw_copy(rho1_g(1)%pw,rho1_tot_gspace%pw, error=error) + CALL qs_rho_get(rho1, rho_g=rho1_g) + CALL pw_copy(rho1_g(1)%pw,rho1_tot_gspace%pw) DO ispin=2,nspins - CALL pw_axpy(rho1_g(ispin)%pw, rho1_tot_gspace%pw, error=error) + CALL pw_axpy(rho1_g(ispin)%pw, rho1_tot_gspace%pw) END DO IF (gapw) & - CALL pw_axpy(p_env%local_rho_set%rho0_mpole%rho0_s_gs%pw, rho1_tot_gspace%pw,& - error=error) + CALL pw_axpy(p_env%local_rho_set%rho0_mpole%rho0_s_gs%pw, rho1_tot_gspace%pw) !IF (cp_print_key_should_output(logger%iter_info,scf_section,"PRINT%TOTAL_DENSITIES",& - ! error=error)/=0) THEN + ! /=0) THEN ! output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%TOTAL_DENSITIES",& - ! extension=".scfLog",error=error) - ! CALL print_densities(kpp1_env, rho1, rho1_tot_gspace, output_unit, error=error) + ! extension=".scfLog") + ! CALL print_densities(kpp1_env, rho1, rho1_tot_gspace, output_unit) ! CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - ! "PRINT%TOTAL_DENSITIES", error=error) + ! "PRINT%TOTAL_DENSITIES") !END IF IF (.NOT.(nspins==1 .AND. lr_triplet )) THEN CALL pw_poisson_solve(poisson_env,rho1_tot_gspace%pw, & energy_hartree, & - v_hartree_gspace%pw,error=error) - CALL pw_transfer(v_hartree_gspace%pw,v_hartree_rspace%pw, error=error) + v_hartree_gspace%pw) + CALL pw_transfer(v_hartree_gspace%pw,v_hartree_rspace%pw) ENDIF - CALL pw_pool_give_back_pw(auxbas_pw_pool, rho1_tot_gspace%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, rho1_tot_gspace%pw) ! *** calculate the xc potential *** IF(gapw_xc) THEN - CALL qs_rho_get(rho1_xc, rho_r=rho1_r, error=error) + CALL qs_rho_get(rho1_xc, rho_r=rho1_r) ELSE - CALL qs_rho_get(rho1, rho_r=rho1_r, error=error) + CALL qs_rho_get(rho1, rho_r=rho1_r) END IF IF (nspins == 1 .AND. (lr_triplet)) THEN @@ -1046,8 +1026,8 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) DO ispin=1, 2 NULLIFY(rho1_r_pw(ispin)%pw) CALL pw_create(rho1_r_pw(ispin)%pw, rho1_r(1)%pw%pw_grid, & - rho1_r(1)%pw%in_use, rho1_r(1)%pw%in_space,error=error) - CALL pw_transfer(rho1_r(1)%pw, rho1_r_pw(ispin)%pw, error=error) + rho1_r(1)%pw%in_use, rho1_r(1)%pw%in_space) + CALL pw_transfer(rho1_r(1)%pw, rho1_r_pw(ispin)%pw) END DO ELSE @@ -1055,7 +1035,7 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) ALLOCATE(rho1_r_pw(nspins)) DO ispin=1, nspins rho1_r_pw(ispin)%pw => rho1_r(ispin)%pw - CALL pw_retain(rho1_r_pw(ispin)%pw,error=error) + CALL pw_retain(rho1_r_pw(ispin)%pw) END DO END IF @@ -1068,29 +1048,27 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) bo = rho1_r(1)%pw%pw_grid%bounds_local ! create the place where to store the argument for the functionals CALL xc_rho_set_create(rho1_set, bo, & - rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF",error=error), & - drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF",error=error), & - tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF",error=error), & - error=error) + rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF"), & + drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF"), & + tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF")) - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",& - error=error) - needs=xc_functionals_get_needs(xc_fun_section,lsd,.TRUE.,error) + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") + needs=xc_functionals_get_needs(xc_fun_section,lsd,.TRUE.) ! calculate the arguments needed by the functionals CALL xc_rho_set_update(rho1_set, rho1_r_pw, rho1_g_pw, tau_pw, needs,& - section_get_ival(xc_section,"XC_GRID%XC_DERIV",error=error),& - section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO",error=error),& - auxbas_pw_pool, error) + section_get_ival(xc_section,"XC_GRID%XC_DERIV"),& + section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO"),& + auxbas_pw_pool) ALLOCATE(v_xc(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1, nspins NULLIFY(v_xc(ispin)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,v_xc(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(v_xc(ispin)%pw, error=error) + in_space = REALSPACE) + CALL pw_zero(v_xc(ispin)%pw) END DO fac=0._dp @@ -1100,24 +1078,24 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) CALL xc_calc_2nd_deriv(v_xc, p_env%kpp1_env%deriv_set, p_env%kpp1_env%rho_set, & rho1_set, auxbas_pw_pool,xc_section=xc_section,& - tddfpt_fac=fac, error=error) + tddfpt_fac=fac) DO ispin=1,nspins v_rspace_new(ispin)%pw => v_xc(ispin)%pw END DO DEALLOCATE(v_xc,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(gapw) CALL calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft=.FALSE.,& - do_triplet=lr_triplet,error=error) + do_triplet=lr_triplet) - CALL xc_rho_set_release(rho1_set,error=error) + CALL xc_rho_set_release(rho1_set) DO ispin=1,SIZE(rho1_r_pw) - CALL pw_release(rho1_r_pw(ispin)%pw,error=error) + CALL pw_release(rho1_r_pw(ispin)%pw) END DO DEALLOCATE(rho1_r_pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !-------------------------------! ! Add both hartree and xc terms ! @@ -1137,14 +1115,14 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) v_rspace_new(1)%pw%cr3d = 2.0_dp * v_rspace_new(1)%pw%cr3d END IF - CALL qs_rho_get(rho1, rho_ao=rho1_ao, error=error) + CALL qs_rho_get(rho1, rho_ao=rho1_ao) ! remove kpp1_env%v_ao and work directly on k_p_p1 ? - CALL cp_dbcsr_set(p_env%kpp1_env%v_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(p_env%kpp1_env%v_ao(ispin)%matrix,0.0_dp) CALL integrate_v_rspace(v_rspace=v_rspace_new(ispin),& pmat=rho1_ao(ispin),& hmat=p_env%kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw_xc,error=error) + calculate_forces=.FALSE.,gapw=gapw_xc) ! add hartree only for SINGLETS IF (.NOT.lr_triplet) THEN @@ -1156,16 +1134,16 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) pmat=rho_ao(ispin),& hmat=p_env%kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw,error=error) + calculate_forces=.FALSE.,gapw=gapw) END IF ELSE ! remove kpp1_env%v_ao and work directly on k_p_p1 ? - CALL cp_dbcsr_set(p_env%kpp1_env%v_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(p_env%kpp1_env%v_ao(ispin)%matrix,0.0_dp) CALL integrate_v_rspace(v_rspace=v_rspace_new(ispin),& pmat=rho_ao(ispin),& hmat=p_env%kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw_xc,error=error) + calculate_forces=.FALSE.,gapw=gapw_xc) IF (ispin == 1) THEN v_hartree_rspace%pw%cr3d = v_hartree_rspace%pw%cr3d * & @@ -1176,7 +1154,7 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) pmat=rho_ao(ispin),& hmat=p_env%kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw,error=error) + calculate_forces=.FALSE.,gapw=gapw) END IF ELSE @@ -1209,29 +1187,28 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) END IF ! remove kpp1_env%v_ao and work directly on k_p_p1 ? - CALL cp_dbcsr_set(p_env%kpp1_env%v_ao(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(p_env%kpp1_env%v_ao(ispin)%matrix,0.0_dp) CALL integrate_v_rspace(v_rspace=v_rspace_new(ispin),& pmat=rho_ao(ispin),& hmat=p_env%kpp1_env%v_ao(ispin),& qs_env=qs_env,& - calculate_forces=.FALSE.,gapw=gapw,error=error) + calculate_forces=.FALSE.,gapw=gapw) END IF - CALL cp_dbcsr_copy(p_env%kpp1(ispin)%matrix,p_env%kpp1_env%v_ao(ispin)%matrix,& - error=error) + CALL cp_dbcsr_copy(p_env%kpp1(ispin)%matrix,p_env%kpp1_env%v_ao(ispin)%matrix) END DO IF (gapw) THEN IF (.NOT. ( (nspins == 1 .AND. lr_triplet))) THEN CALL Vh_1c_gg_integrals(qs_env,energy_hartree_1c, tddft=.TRUE., do_triplet=lr_triplet, & - p_env=p_env,error=error) + p_env=p_env) CALL integrate_vhg0_rspace(qs_env, v_hartree_rspace, & .FALSE., tddft=.TRUE., do_triplet=lr_triplet, & - p_env=p_env, error=error) + p_env=p_env) END IF ! *** Add single atom contributions to the KS matrix *** @@ -1242,30 +1219,26 @@ SUBROUTINE apply_op_2(qs_env,p_env,c0,v,Av,chc,buf,error) ns = SIZE(rho_ao) psmat(1:ns,1:1) => rho_ao(1:ns) - CALL update_ks_atom(qs_env,ksmat,psmat,.FALSE.,.TRUE.,p_env,error) + CALL update_ks_atom(qs_env,ksmat,psmat,.FALSE.,.TRUE.,p_env) END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw,& - error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_rspace%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_gspace%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_hartree_rspace%pw) DO ispin=1,nspins - CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,v_rspace_new(ispin)%pw) END DO DEALLOCATE(v_rspace_new, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DO ispin = 1,nspins - CALL cp_fm_get_info(c0(ispin)%matrix,ncol_global=ncol,error=error) + CALL cp_fm_get_info(c0(ispin)%matrix,ncol_global=ncol) CALL cp_dbcsr_sm_fm_multiply(p_env%kpp1(ispin)%matrix,& c0(ispin)%matrix,& Av(ispin)%matrix,& - ncol=ncol,alpha=1.0_dp,beta=1.0_dp,& - error=error) + ncol=ncol,alpha=1.0_dp,beta=1.0_dp) ENDDO ! CALL timestop(handle) @@ -1277,12 +1250,10 @@ END SUBROUTINE apply_op_2 !> \brief ... !> \param p_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE p_env_check_i_alloc(p_env, qs_env, error) + SUBROUTINE p_env_check_i_alloc(p_env, qs_env) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_env_check_i_alloc', & routineP = moduleN//':'//routineN @@ -1299,35 +1270,35 @@ SUBROUTINE p_env_check_i_alloc(p_env, qs_env, error) failure=.FALSE. NULLIFY(dft_control,matrix_s) - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env, dft_control=dft_control,error=error) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env, dft_control=dft_control) gapw_xc = dft_control%qs_control%gapw_xc IF (.NOT.ASSOCIATED(p_env%kpp1)) THEN - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) nspins=dft_control%nspins - CALL cp_dbcsr_allocate_matrix_set(p_env%kpp1,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(p_env%kpp1,nspins) name="p_env"//cp_to_string(p_env%id_nr)//"%kpp1-" !CALL compress(name,full=.TRUE.) DO ispin=1,nspins ALLOCATE(p_env%kpp1(ispin)%matrix) - CALL cp_dbcsr_init(p_env%kpp1(ispin)%matrix,error=error) + CALL cp_dbcsr_init(p_env%kpp1(ispin)%matrix) CALL cp_dbcsr_copy(p_env%kpp1(ispin)%matrix,matrix_s(1)%matrix,& - name=TRIM(name)//ADJUSTL(cp_to_string(ispin)),error=error) - CALL cp_dbcsr_set(p_env%kpp1(ispin)%matrix,0.0_dp,error=error) + name=TRIM(name)//ADJUSTL(cp_to_string(ispin))) + CALL cp_dbcsr_set(p_env%kpp1(ispin)%matrix,0.0_dp) END DO - CALL qs_rho_rebuild(p_env%rho1, qs_env=qs_env, error=error) + CALL qs_rho_rebuild(p_env%rho1, qs_env=qs_env) IF(gapw_xc) THEN - CALL qs_rho_rebuild(p_env%rho1_xc,qs_env=qs_env,error=error) + CALL qs_rho_rebuild(p_env%rho1_xc,qs_env=qs_env) END IF END IF IF (.NOT.ASSOCIATED(p_env%rho1)) THEN - CALL qs_rho_rebuild(p_env%rho1, qs_env=qs_env, error=error) + CALL qs_rho_rebuild(p_env%rho1, qs_env=qs_env) IF(gapw_xc) THEN - CALL qs_rho_rebuild(p_env%rho1_xc,qs_env=qs_env,error=error) + CALL qs_rho_rebuild(p_env%rho1_xc,qs_env=qs_env) END IF END IF CALL timestop(handle) @@ -1339,14 +1310,12 @@ END SUBROUTINE p_env_check_i_alloc !> \param kpp1_env ... !> \param qs_env ... !> \param lr_triplet ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kpp1_check_i_alloc(kpp1_env, qs_env, lr_triplet,error) + SUBROUTINE kpp1_check_i_alloc(kpp1_env, qs_env, lr_triplet) TYPE(qs_kpp1_env_type), POINTER :: kpp1_env TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: lr_triplet - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'kpp1_check_i_alloc', & routineP = moduleN//':'//routineN @@ -1366,34 +1335,34 @@ SUBROUTINE kpp1_check_i_alloc(kpp1_env, qs_env, lr_triplet,error) failure=.FALSE. NULLIFY(pw_env,auxbas_pw_pool,matrix_s,rho,rho_r,input) - CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,error,failure) - CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(kpp1_env),cp_failure_level,routineP,failure) + CPPrecondition(kpp1_env%ref_count>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env, pw_env=pw_env,& - matrix_s=matrix_s, input=input, error=error, rho=rho) + matrix_s=matrix_s, input=input,rho=rho) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) nspins=SIZE(rho_r) - CALL pw_env_get(pw_env, auxbas_pw_pool = auxbas_pw_pool, error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool = auxbas_pw_pool) IF (.NOT.ASSOCIATED(kpp1_env%v_rspace)) THEN ALLOCATE(kpp1_env%v_rspace(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins CALL pw_pool_create_pw(auxbas_pw_pool, & kpp1_env%v_rspace(ispin)%pw,& - use_data=REALDATA3D, in_space=REALSPACE,error=error) + use_data=REALDATA3D, in_space=REALSPACE) END DO END IF IF (.NOT.ASSOCIATED(kpp1_env%v_ao)) THEN - CALL cp_dbcsr_allocate_matrix_set(kpp1_env%v_ao,nspins,error) + CALL cp_dbcsr_allocate_matrix_set(kpp1_env%v_ao,nspins) DO ispin=1,nspins ALLOCATE(kpp1_env%v_ao(ispin)%matrix) - CALL cp_dbcsr_init(kpp1_env%v_ao(ispin)%matrix,error=error) + CALL cp_dbcsr_init(kpp1_env%v_ao(ispin)%matrix) CALL cp_dbcsr_copy(kpp1_env%v_ao(ispin)%matrix,matrix_s(1)%matrix,& - name="kpp1%v_ao-"//ADJUSTL(cp_to_string(ispin)),error=error) + name="kpp1%v_ao-"//ADJUSTL(cp_to_string(ispin))) END DO END IF @@ -1401,40 +1370,39 @@ SUBROUTINE kpp1_check_i_alloc(kpp1_env, qs_env, lr_triplet,error) IF (nspins==1.AND.lr_triplet) THEN ALLOCATE(my_rho_r(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,2 CALL pw_pool_create_pw(auxbas_pw_pool,my_rho_r(ispin)%pw, & - use_data=rho_r(1)%pw%in_use, in_space=rho_r(1)%pw%in_space,& - error=error) + use_data=rho_r(1)%pw%in_use, in_space=rho_r(1)%pw%in_space) my_rho_r(ispin)%pw%cr3d = 0.5_dp * rho_r(1)%pw%cr3d END DO ELSE ALLOCATE(my_rho_r(SIZE(rho_r)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,SIZE(rho_r) my_rho_r(ispin)%pw => rho_r(ispin)%pw - CALL pw_retain(my_rho_r(ispin)%pw,error=error) + CALL pw_retain(my_rho_r(ispin)%pw) END DO END IF !ALLOCATE(my_rho_r(SIZE(rho_r)),stat=stat) - !CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + !CPPostcondition(stat==0,cp_failure_level,routineP,failure) !DO ispin=1,SIZE(rho_r) ! my_rho_r(ispin)%pw => rho_r(ispin)%pw - ! CALL pw_retain(my_rho_r(ispin)%pw,error=error) + ! CALL pw_retain(my_rho_r(ispin)%pw) !END DO - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") CALL xc_prep_2nd_deriv(kpp1_env%deriv_set, kpp1_env%rho_set, & my_rho_r, auxbas_pw_pool, & - xc_section=xc_section, error=error) + xc_section=xc_section) DO ispin=1,SIZE(my_rho_r) - CALL pw_release(my_rho_r(ispin)%pw,error=error) + CALL pw_release(my_rho_r(ispin)%pw) ENDDO DEALLOCATE(my_rho_r,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF END SUBROUTINE kpp1_check_i_alloc @@ -1446,15 +1414,13 @@ END SUBROUTINE kpp1_check_i_alloc !> \param psi0 ... !> \param S_psi0 ... !> \param buf ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE preortho(v,psi0,S_psi0,buf,error) + SUBROUTINE preortho(v,psi0,S_psi0,buf) !v = (I-PS)v ! TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: v, psi0, S_psi0 TYPE(cp_fm_type), POINTER :: buf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'preortho', & routineP = moduleN//':'//routineN @@ -1469,27 +1435,27 @@ SUBROUTINE preortho(v,psi0,S_psi0,buf,error) ! CALL timeset(routineN,handle) ! - CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(S_psi0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(psi0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(S_psi0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(psi0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,failure) ! nspins = SIZE(v,1) ! DO ispin = 1,nspins ! - CALL cp_fm_get_info(v(ispin)%matrix,ncol_global=mv,nrow_global=nv,error=error) - CALL cp_fm_get_info(psi0(ispin)%matrix,ncol_global=mp,nrow_global=np,error=error) - CALL cp_fm_get_info(buf,ncol_global=mt,nrow_global=nt,error=error) - CPPrecondition(nv==np,cp_failure_level,routineP,error,failure) - CPPrecondition(mt>=mv,cp_failure_level,routineP,error,failure) - CPPrecondition(mt>=mp,cp_failure_level,routineP,error,failure) - CPPrecondition(nt==nv,cp_failure_level,routineP,error,failure) + CALL cp_fm_get_info(v(ispin)%matrix,ncol_global=mv,nrow_global=nv) + CALL cp_fm_get_info(psi0(ispin)%matrix,ncol_global=mp,nrow_global=np) + CALL cp_fm_get_info(buf,ncol_global=mt,nrow_global=nt) + CPPrecondition(nv==np,cp_failure_level,routineP,failure) + CPPrecondition(mt>=mv,cp_failure_level,routineP,failure) + CPPrecondition(mt>=mp,cp_failure_level,routineP,failure) + CPPrecondition(nt==nv,cp_failure_level,routineP,failure) ! ! buf = v' * S_psi0 - CALL cp_gemm('T','N',mv,mp,nv,1.0_dp,v(ispin)%matrix,S_psi0(ispin)%matrix,0.0_dp,buf,error) + CALL cp_gemm('T','N',mv,mp,nv,1.0_dp,v(ispin)%matrix,S_psi0(ispin)%matrix,0.0_dp,buf) ! v = v - psi0 * buf' - CALL cp_gemm('N','T',nv,mv,mp,-1.0_dp,psi0(ispin)%matrix,buf,1.0_dp,v(ispin)%matrix,error) + CALL cp_gemm('N','T',nv,mv,mp,-1.0_dp,psi0(ispin)%matrix,buf,1.0_dp,v(ispin)%matrix) ! ENDDO ! @@ -1504,15 +1470,13 @@ END SUBROUTINE preortho !> \param psi0 ... !> \param S_psi0 ... !> \param buf ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE postortho(v,psi0,S_psi0,buf,error) + SUBROUTINE postortho(v,psi0,S_psi0,buf) !v = (I-SP)v ! TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: v, psi0, S_psi0 TYPE(cp_fm_type), POINTER :: buf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'postortho', & routineP = moduleN//':'//routineN @@ -1525,27 +1489,27 @@ SUBROUTINE postortho(v,psi0,S_psi0,buf,error) ! CALL timeset(routineN,handle) ! - CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(S_psi0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(psi0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(v),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(S_psi0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(psi0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(buf),cp_failure_level,routineP,failure) ! nspins = SIZE(v,1) ! DO ispin = 1,nspins ! - CALL cp_fm_get_info(v(ispin)%matrix,ncol_global=mv,nrow_global=nv,error=error) - CALL cp_fm_get_info(psi0(ispin)%matrix,ncol_global=mp,nrow_global=np,error=error) - CALL cp_fm_get_info(buf,ncol_global=mt,nrow_global=nt,error=error) - CPPrecondition(nv==np,cp_failure_level,routineP,error,failure) - CPPrecondition(mt>=mv,cp_failure_level,routineP,error,failure) - CPPrecondition(mt>=mp,cp_failure_level,routineP,error,failure) - CPPrecondition(nt==nv,cp_failure_level,routineP,error,failure) + CALL cp_fm_get_info(v(ispin)%matrix,ncol_global=mv,nrow_global=nv) + CALL cp_fm_get_info(psi0(ispin)%matrix,ncol_global=mp,nrow_global=np) + CALL cp_fm_get_info(buf,ncol_global=mt,nrow_global=nt) + CPPrecondition(nv==np,cp_failure_level,routineP,failure) + CPPrecondition(mt>=mv,cp_failure_level,routineP,failure) + CPPrecondition(mt>=mp,cp_failure_level,routineP,failure) + CPPrecondition(nt==nv,cp_failure_level,routineP,failure) ! ! buf = v' * psi0 - CALL cp_gemm('T','N',mv,mp,nv,1.0_dp,v(ispin)%matrix,psi0(ispin)%matrix,0.0_dp,buf,error) + CALL cp_gemm('T','N',mv,mp,nv,1.0_dp,v(ispin)%matrix,psi0(ispin)%matrix,0.0_dp,buf) ! v = v - S_psi0 * buf' - CALL cp_gemm('N','T',nv,mv,mp,-1.0_dp,S_psi0(ispin)%matrix,buf,1.0_dp,v(ispin)%matrix,error) + CALL cp_gemm('N','T',nv,mv,mp,-1.0_dp,S_psi0(ispin)%matrix,buf,1.0_dp,v(ispin)%matrix) ! ENDDO ! @@ -1561,9 +1525,8 @@ END SUBROUTINE postortho !> \param ivec ... !> \param tag ... !> \param ind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind,error) + SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: linres_section TYPE(cp_fm_p_type), DIMENSION(:), & @@ -1571,7 +1534,6 @@ SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind,error) INTEGER, INTENT(IN) :: ivec CHARACTER(LEN=*) :: tag INTEGER, INTENT(IN), OPTIONAL :: ind - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_write_restart', & routineP = moduleN//':'//routineN @@ -1597,19 +1559,18 @@ SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF(BTEST(cp_print_key_should_output(logger%iter_info,linres_section,"PRINT%RESTART",& - used_print_key=print_key,error=error),& + used_print_key=print_key),& cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,linres_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".Log",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".Log") CALL get_qs_env(qs_env=qs_env, & mos=mos, & - para_env=para_env, & - error=error) + para_env=para_env) nspins = SIZE(mos) @@ -1627,12 +1588,11 @@ SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind,error) END IF rst_unit = cp_print_key_unit_nr(logger,linres_section,"PRINT%RESTART",& extension=".lr",middle_name=TRIM(my_middle),file_status=TRIM(my_status),& - file_position=TRIM(my_pos),file_action="WRITE",file_form="UNFORMATTED",& - error=error) + file_position=TRIM(my_pos),file_action="WRITE",file_form="UNFORMATTED") filename = cp_print_key_generate_filename(logger,print_key,& - extension=".lr",middle_name=TRIM(my_middle), my_local=.FALSE.,error=error) + extension=".lr",middle_name=TRIM(my_middle), my_local=.FALSE.) IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T10,A,A,/)")& @@ -1644,9 +1604,9 @@ SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind,error) ! write data to file ! use the scalapack block size as a default for buffering columns CALL get_mo_set(mos(1)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,nrow_global=nao,ncol_block=max_block,error=error) + CALL cp_fm_get_info(mo_coeff,nrow_global=nao,ncol_block=max_block) ALLOCATE(vecbuffer(nao,max_block),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(PRESENT(ind)) THEN IF(rst_unit>0) WRITE(rst_unit) ind,ivec,nspins,nao @@ -1655,13 +1615,13 @@ SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind,error) END IF DO ispin=1,nspins - CALL cp_fm_get_info(vec(ispin)%matrix,ncol_global=nmo,error=error) + CALL cp_fm_get_info(vec(ispin)%matrix,ncol_global=nmo) IF(rst_unit>0) WRITE(rst_unit) nmo DO i=1,nmo,MAX(max_block,1) i_block=MIN(max_block,nmo-i+1) - CALL cp_fm_get_submatrix(vec(ispin)%matrix,vecbuffer,1,i,nao,i_block,error=error) + CALL cp_fm_get_submatrix(vec(ispin)%matrix,vecbuffer,1,i,nao,i_block) ! doing this in one write would increase efficiency, but breaks RESTART compatibility. ! to old ones, and in cases where max_block is different between runs, as might happen during ! restarts with a different number of CPUs @@ -1672,10 +1632,10 @@ SUBROUTINE linres_write_restart(qs_env,linres_section,vec,ivec,tag,ind,error) ENDDO DEALLOCATE (vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL cp_print_key_finished_output(rst_unit,logger,linres_section,& - "PRINT%RESTART",error=error) + "PRINT%RESTART") ENDIF CALL timestop(handle) @@ -1685,11 +1645,9 @@ END SUBROUTINE linres_write_restart ! ***************************************************************************** !> \brief ... !> \param linres_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE linres_init_write_restart(linres_section,error) + SUBROUTINE linres_init_write_restart(linres_section) TYPE(section_vals_type), POINTER :: linres_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_init_write_restart', & routineP = moduleN//':'//routineN @@ -1703,23 +1661,22 @@ SUBROUTINE linres_init_write_restart(linres_section,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - IF(BTEST(cp_print_key_should_output(logger%iter_info,linres_section,"PRINT%RESTART",error=error),& + IF(BTEST(cp_print_key_should_output(logger%iter_info,linres_section,"PRINT%RESTART"),& cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,linres_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".Log",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".Log") rst_unit = cp_print_key_unit_nr(logger,linres_section,"PRINT%RESTART",& extension=".lr",middle_name="RESTART",file_status="REPLACE",& - file_action="WRITE",file_position="APPEND",file_form="UNFORMATTED",& - error=error) + file_action="WRITE",file_position="APPEND",file_form="UNFORMATTED") ! may write some infos here about the response... CALL cp_print_key_finished_output(rst_unit,logger,linres_section,& - "PRINT%RESTART",error=error) + "PRINT%RESTART") ENDIF CALL timestop(handle) @@ -1735,9 +1692,8 @@ END SUBROUTINE linres_init_write_restart !> \param ivec ... !> \param tag ... !> \param ind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) + SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: linres_section TYPE(cp_fm_p_type), DIMENSION(:), & @@ -1745,7 +1701,6 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) INTEGER, INTENT(IN) :: ivec CHARACTER(LEN=*) :: tag INTEGER, INTENT(INOUT), OPTIONAL :: ind - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_read_restart', & routineP = moduleN//':'//routineN @@ -1770,15 +1725,14 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) CALL timeset(routineN,handle) NULLIFY(mos,para_env,logger,print_key,vecbuffer) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,linres_section,& - "PRINT%PROGRAM_RUN_INFO", extension=".Log",error=error) + "PRINT%PROGRAM_RUN_INFO", extension=".Log") CALL get_qs_env(qs_env=qs_env, & para_env=para_env,& - mos=mos,& - error=error) + mos=mos) nspins = SIZE(mos) group = para_env%group @@ -1787,7 +1741,7 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) rst_unit = -1 IF(para_env%ionode) THEN CALL section_vals_val_get(linres_section,"WFN_RESTART_FILE_NAME",& - n_rep_val=n_rep_val,error=error) + n_rep_val=n_rep_val) CALL XSTRING(tag,ia,ie) IF(PRESENT(ind)) THEN @@ -1797,14 +1751,14 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) END IF IF(n_rep_val>0) THEN - CALL section_vals_val_get(linres_section,"WFN_RESTART_FILE_NAME",c_val=filename,error=error) + CALL section_vals_val_get(linres_section,"WFN_RESTART_FILE_NAME",c_val=filename) CALL xstring (filename, ia, ie ) filename = filename(ia:ie)//TRIM(my_middle)//".lr" ELSE ! try to read from the filename that is generated automatically from the printkey - print_key => section_vals_get_subs_vals(linres_section,"PRINT%RESTART",error=error) + print_key => section_vals_get_subs_vals(linres_section,"PRINT%RESTART") filename = cp_print_key_generate_filename(logger,print_key, & - extension=".lr",middle_name=TRIM(my_middle),my_local=.FALSE., error=error) + extension=".lr",middle_name=TRIM(my_middle),my_local=.FALSE.) ENDIF INQUIRE(FILE=filename,exist=file_exists) ! @@ -1830,10 +1784,10 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) IF(file_exists) THEN CALL get_mo_set(mos(1)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,nrow_global=nao,ncol_block=max_block,error=error) + CALL cp_fm_get_info(mo_coeff,nrow_global=nao,ncol_block=max_block) ALLOCATE(vecbuffer(nao,max_block),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! read headers IF(PRESENT(ind)) THEN @@ -1864,7 +1818,7 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) ! DO ispin = 1,nspins CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=nmo,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=nmo) ! IF(rst_unit>0) READ(rst_unit) nmo_tmp CALL mp_bcast(nmo_tmp,source,group) @@ -1879,7 +1833,7 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) ENDDO IF(iv.EQ.ivec_tmp) THEN CALL mp_bcast(vecbuffer,source,group) - CALL cp_fm_set_submatrix(vec(ispin)%matrix,vecbuffer,1,i,nao,i_block,error=error) + CALL cp_fm_set_submatrix(vec(ispin)%matrix,vecbuffer,1,i,nao,i_block) ENDIF ENDDO ENDDO @@ -1892,7 +1846,7 @@ SUBROUTINE linres_read_restart(qs_env,linres_section,vec,ivec,tag,ind,error) ENDIF DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF @@ -1911,14 +1865,12 @@ END SUBROUTINE linres_read_restart !> \param p_env ... !> \param linres_control ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE check_p_env_init(p_env,linres_control, nspins, error) + SUBROUTINE check_p_env_init(p_env,linres_control, nspins) ! TYPE(qs_p_env_type), POINTER :: p_env TYPE(linres_control_type), POINTER :: linres_control INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_p_env_init', & routineP = moduleN//':'//routineN @@ -1938,11 +1890,11 @@ SUBROUTINE check_p_env_init(p_env,linres_control, nspins, error) p_env%gnorm_old = 1.0_dp IF(linres_control%preconditioner_type /= ot_precond_none) THEN - CPPrecondition(ASSOCIATED(p_env%preconditioner),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env%preconditioner),cp_failure_level,routineP,failure) DO ispin = 1,nspins - CALL cp_fm_get_info(p_env%PS_psi0(ispin)%matrix,nrow_global=nrow,ncol_global=ncol,error=error) - CPPrecondition(nrow==p_env%n_ao(ispin),cp_failure_level,routineP,error,failure) - CPPrecondition(ncol==p_env%n_mo(ispin),cp_failure_level,routineP,error,failure) + CALL cp_fm_get_info(p_env%PS_psi0(ispin)%matrix,nrow_global=nrow,ncol_global=ncol) + CPPrecondition(nrow==p_env%n_ao(ispin),cp_failure_level,routineP,failure) + CPPrecondition(ncol==p_env%n_mo(ispin),cp_failure_level,routineP,failure) ENDDO ENDIF diff --git a/src/qs_linres_module.F b/src/qs_linres_module.F index a2bdaa9685..f0e73b5b15 100644 --- a/src/qs_linres_module.F +++ b/src/qs_linres_module.F @@ -104,15 +104,13 @@ MODULE qs_linres_module ! ***************************************************************************** !> \brief Driver for the linear response calculatios !> \param force_env ... -!> \param error ... !> \par History !> 06.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE linres_calculation(force_env, error) + SUBROUTINE linres_calculation(force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_calculation', & routineP = moduleN//':'//routineN @@ -125,12 +123,12 @@ SUBROUTINE linres_calculation(force_env, error) NULLIFY(qs_env) - CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,error,failure) - CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(force_env),cp_failure_level,routineP,failure) + CPPrecondition(force_env%ref_count>0,cp_failure_level,routineP,failure) SELECT CASE(force_env%in_use) CASE(use_qs_force) - CALL force_env_get(force_env,qs_env=qs_env,error=error) + CALL force_env_get(force_env,qs_env=qs_env) CASE(use_qmmm) qs_env => force_env%qmmm_env%qs_env CASE DEFAULT @@ -139,7 +137,7 @@ SUBROUTINE linres_calculation(force_env, error) qs_env%linres_run = .TRUE. - CALL linres_calculation_low(qs_env, error=error) + CALL linres_calculation_low(qs_env) CALL timestop(handle) @@ -151,16 +149,14 @@ END SUBROUTINE linres_calculation !> Define which properties is to be calculated !> Start up the optimization of the response density and wfn !> \param qs_env ... -!> \param error ... !> \par History !> 06.2005 created [MI] !> 02.2013 added polarizability section [SL] !> \author MI ! ***************************************************************************** - SUBROUTINE linres_calculation_low(qs_env, error) + SUBROUTINE linres_calculation_low(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_calculation_low', & routineP = moduleN//':'//routineN @@ -184,52 +180,52 @@ SUBROUTINE linres_calculation_low(qs_env, error) polar_present = .FALSE. NULLIFY(dft_control,p_env,linres_control,logger,prop_section,lr_section) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) - CALL section_vals_get(lr_section,explicit=lr_calculation,error=error) + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") + CALL section_vals_get(lr_section,explicit=lr_calculation) IF(lr_calculation) THEN - CALL linres_init(lr_section,p_env,qs_env,error=error) + CALL linres_init(lr_section,p_env,qs_env) output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, & - linres_control=linres_control,error=error) + linres_control=linres_control) !The type of perturbation has not been defined yet linres_control%property = lr_none ! ! We do NMR or EPR, then compute the current response - prop_section => section_vals_get_subs_vals(lr_section,"NMR",error=error) - CALL section_vals_get(prop_section,explicit=nmr_present,error=error) - prop_section => section_vals_get_subs_vals(lr_section,"EPR",error=error) - CALL section_vals_get(prop_section,explicit=epr_present,error=error) + prop_section => section_vals_get_subs_vals(lr_section,"NMR") + CALL section_vals_get(prop_section,explicit=nmr_present) + prop_section => section_vals_get_subs_vals(lr_section,"EPR") + CALL section_vals_get(prop_section,explicit=epr_present) IF(nmr_present.OR.epr_present) THEN CALL nmr_epr_linres(linres_control,qs_env,p_env,dft_control, & - nmr_present,epr_present,output_unit, error=error) + nmr_present,epr_present,output_unit) ENDIF ! ! We do the indirect spin-spin coupling calculation - prop_section => section_vals_get_subs_vals(lr_section,"SPINSPIN",error=error) - CALL section_vals_get(prop_section,explicit=issc_present,error=error) + prop_section => section_vals_get_subs_vals(lr_section,"SPINSPIN") + CALL section_vals_get(prop_section,explicit=issc_present) IF(issc_present) THEN - CALL issc_linres(linres_control,qs_env, p_env, dft_control, error=error) + CALL issc_linres(linres_control,qs_env, p_env, dft_control) ENDIF ! ! We do the polarizability calculation - prop_section => section_vals_get_subs_vals(lr_section,"POLAR",error=error) - CALL section_vals_get(prop_section,explicit=polar_present,error=error) + prop_section => section_vals_get_subs_vals(lr_section,"POLAR") + CALL section_vals_get(prop_section,explicit=polar_present) IF(polar_present) THEN - CALL polar_linres(qs_env,p_env,error=error) + CALL polar_linres(qs_env,p_env) END IF ! Other possible LR calculations can be introduced here - CALL p_env_release(p_env,error=error) + CALL p_env_release(p_env) IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T3,A,/,T25,A,/,T3,A,/)")& @@ -238,7 +234,7 @@ SUBROUTINE linres_calculation_low(qs_env, error) REPEAT("=",77) END IF CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") !! ELSE ! output_unit = cp_logger_get_default_io_unit(logger) ! IF(output_unit>0) THEN @@ -261,19 +257,17 @@ END SUBROUTINE linres_calculation_low !> \param lr_section ... !> \param p_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 06.2005 created [MI] !> \author MI !> \note !> - The localization should probably be always for all the occupied states ! ***************************************************************************** - SUBROUTINE linres_init(lr_section,p_env,qs_env,error) + SUBROUTINE linres_init(lr_section,p_env,qs_env) TYPE(section_vals_type), POINTER :: lr_section TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'linres_init', & routineP = moduleN//':'//routineN @@ -293,24 +287,24 @@ SUBROUTINE linres_init(lr_section,p_env,qs_env,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") NULLIFY(dft_control, linres_control, loc_section, rho, mos, matrix_ks, rho_ao) - CPPrecondition(.NOT.ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(p_env),cp_failure_level,routineP,failure) - CALL linres_control_create(linres_control,error=error) - CALL set_qs_env(qs_env=qs_env, linres_control=linres_control,error=error) - CALL linres_control_release(linres_control,error=error) + CALL linres_control_create(linres_control) + CALL set_qs_env(qs_env=qs_env, linres_control=linres_control) + CALL linres_control_release(linres_control) CALL get_qs_env(qs_env=qs_env, linres_control=linres_control,& - dft_control=dft_control,matrix_ks=matrix_ks,mos=mos,rho=rho,error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + dft_control=dft_control,matrix_ks=matrix_ks,mos=mos,rho=rho) + CALL qs_rho_get(rho, rho_ao=rho_ao) ! Localized Psi0 are required when the position operator has to be defined (nmr) - loc_section =>section_vals_get_subs_vals(lr_section,"LOCALIZE",error=error) + loc_section =>section_vals_get_subs_vals(lr_section,"LOCALIZE") CALL section_vals_val_get(loc_section,"_SECTION_PARAMETERS_",& - l_val=linres_control%localized_psi0,error=error) + l_val=linres_control%localized_psi0) IF(linres_control%localized_psi0) THEN IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T3,A,A)")& @@ -318,21 +312,21 @@ SUBROUTINE linres_init(lr_section,p_env,qs_env,error) " before starting the linear response calculation" END IF - CALL linres_localize(qs_env, linres_control,dft_control%nspins,error=error) + CALL linres_localize(qs_env, linres_control,dft_control%nspins) DO ispin=1,dft_control%nspins - CALL calculate_density_matrix(mos(ispin)%mo_set,rho_ao(ispin)%matrix,error=error) + CALL calculate_density_matrix(mos(ispin)%mo_set,rho_ao(ispin)%matrix) ENDDO ! ** update qs_env%rho - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) END IF - CALL section_vals_val_get(lr_section,"RESTART",l_val=linres_control%linres_restart,error=error) - CALL section_vals_val_get(lr_section,"MAX_ITER",i_val=linres_control%max_iter,error=error) - CALL section_vals_val_get(lr_section,"EPS",r_val=linres_control%eps,error=error) - CALL section_vals_val_get(lr_section,"RESTART_EVERY",i_val=linres_control%restart_every,error=error) - CALL section_vals_val_get(lr_section,"PRECONDITIONER",i_val=linres_control%preconditioner_type,error=error) - CALL section_vals_val_get(lr_section,"ENERGY_GAP",r_val=linres_control%energy_gap,error=error) + CALL section_vals_val_get(lr_section,"RESTART",l_val=linres_control%linres_restart) + CALL section_vals_val_get(lr_section,"MAX_ITER",i_val=linres_control%max_iter) + CALL section_vals_val_get(lr_section,"EPS",r_val=linres_control%eps) + CALL section_vals_val_get(lr_section,"RESTART_EVERY",i_val=linres_control%restart_every) + CALL section_vals_val_get(lr_section,"PRECONDITIONER",i_val=linres_control%preconditioner_type) + CALL section_vals_val_get(lr_section,"ENERGY_GAP",r_val=linres_control%energy_gap) IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T3,A,/,T25,A,/,T3,A,/)")& @@ -343,7 +337,7 @@ SUBROUTINE linres_init(lr_section,p_env,qs_env,error) WRITE (UNIT=output_unit,FMT="(/,T10,A,/)")& "Properties to be Calulated:" CALL section_vals_val_get(lr_section,"NMR%_SECTION_PARAMETERS_",& - l_val=do_it,error=error) + l_val=do_it) IF(do_it) WRITE (UNIT=output_unit,FMT="(T45,A)") & "NMR Chemical Shift" @@ -385,16 +379,16 @@ SUBROUTINE linres_init(lr_section,p_env,qs_env,error) !------------------! ! create the p_env ! !------------------! - CALL p_env_create(p_env, qs_env, orthogonal_orbitals=.TRUE.,linres_control=linres_control,error=error) + CALL p_env_create(p_env, qs_env, orthogonal_orbitals=.TRUE.,linres_control=linres_control) ! update the m_epsilon matrix - CALL p_env_psi0_changed(p_env,qs_env,error=error) + CALL p_env_psi0_changed(p_env,qs_env) ! calculate eigenvectros and eigenvalues of K p_env%os_valid = .FALSE. p_env%new_preconditioner = .TRUE. CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END SUBROUTINE linres_init @@ -407,9 +401,8 @@ END SUBROUTINE linres_init !> \param nmr_present ... !> \param epr_present ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE nmr_epr_linres(linres_control,qs_env,p_env,dft_control,nmr_present,epr_present,output_unit, error) + SUBROUTINE nmr_epr_linres(linres_control,qs_env,p_env,dft_control,nmr_present,epr_present,output_unit) TYPE(linres_control_type), POINTER :: linres_control TYPE(qs_environment_type), POINTER :: qs_env @@ -417,7 +410,6 @@ SUBROUTINE nmr_epr_linres(linres_control,qs_env,p_env,dft_control,nmr_present,ep TYPE(dft_control_type), POINTER :: dft_control LOGICAL :: nmr_present, epr_present INTEGER :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nmr_epr_linres', & routineP = moduleN//':'//routineN @@ -437,7 +429,7 @@ SUBROUTINE nmr_epr_linres(linres_control,qs_env,p_env,dft_control,nmr_present,ep "Are you sure that you want to calculate the chemical "//& "shift without localized psi0?") CALL linres_localize(qs_env, linres_control,& - dft_control%nspins,centers_only=.TRUE.,error=error) + dft_control%nspins,centers_only=.TRUE.) ENDIF IF(dft_control%nspins/=2.AND.epr_present) THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -450,58 +442,58 @@ SUBROUTINE nmr_epr_linres(linres_control,qs_env,p_env,dft_control,nmr_present,ep IF(qs_env%qmmm) do_qmmm = .TRUE. current_env%do_qmmm = do_qmmm !current_env%prop='nmr' - CALL current_env_init(current_env,qs_env,error=error) - CALL current_operators(current_env,qs_env,error=error) - CALL current_response(current_env,p_env,qs_env,error) + CALL current_env_init(current_env,qs_env) + CALL current_operators(current_env,qs_env) + CALL current_response(current_env,p_env,qs_env) ! IF(current_env%all_pert_op_done) THEN !Initialize the nmr environment IF(nmr_present) THEN nmr_env%ref_count=0 - CALL nmr_env_init(nmr_env,qs_env,error=error) + CALL nmr_env_init(nmr_env,qs_env) ENDIF ! !Initialize the epr environment IF(epr_present) THEN epr_env%ref_count=0 - CALL epr_env_init(epr_env,qs_env,error=error) - CALL epr_g_zke(epr_env,qs_env,error=error) - CALL epr_nablavks(epr_env,qs_env,error=error) + CALL epr_env_init(epr_env,qs_env) + CALL epr_g_zke(epr_env,qs_env) + CALL epr_nablavks(epr_env,qs_env) ENDIF ! ! Build the rs_gauge if needed - !CALL current_set_gauge(current_env,qs_env,error=error) + !CALL current_set_gauge(current_env,qs_env) ! ! Loop over field direction DO iB = 1,3 ! ! Build current response and succeptibility - CALL current_build_current(current_env,qs_env,iB,error=error) - CALL current_build_chi(current_env,qs_env,iB,error=error) + CALL current_build_current(current_env,qs_env,iB) + CALL current_build_chi(current_env,qs_env,iB) ! ! Compute NMR shift IF(nmr_present) THEN - CALL nmr_shift(nmr_env,current_env,qs_env,iB,error=error) + CALL nmr_shift(nmr_env,current_env,qs_env,iB) ENDIF ! ! Compute EPR IF(epr_present) THEN - CALL epr_ind_magnetic_field(epr_env,current_env,qs_env,iB,error=error) - CALL epr_g_so(epr_env,current_env,qs_env,iB,error=error) - CALL epr_g_soo(epr_env,current_env,qs_env,iB,error=error) + CALL epr_ind_magnetic_field(epr_env,current_env,qs_env,iB) + CALL epr_g_so(epr_env,current_env,qs_env,iB) + CALL epr_g_soo(epr_env,current_env,qs_env,iB) ENDIF ENDDO ! ! Finalized the nmr environment IF(nmr_present) THEN - CALL nmr_shift_print(nmr_env,current_env,qs_env,error=error) - CALL nmr_env_cleanup(nmr_env,error=error) + CALL nmr_shift_print(nmr_env,current_env,qs_env) + CALL nmr_env_cleanup(nmr_env) ENDIF ! ! Finalized the epr environment IF(epr_present) THEN - CALL epr_g_print(epr_env,qs_env,error=error) - CALL epr_env_cleanup(epr_env,error=error) + CALL epr_g_print(epr_env,qs_env) + CALL epr_env_cleanup(epr_env) ENDIF ! ELSE @@ -512,7 +504,7 @@ SUBROUTINE nmr_epr_linres(linres_control,qs_env,p_env,dft_control,nmr_present,ep END IF END IF ! Finalized the current environment - CALL current_env_cleanup(current_env,qs_env,error=error) + CALL current_env_cleanup(current_env,qs_env) END SUBROUTINE nmr_epr_linres @@ -523,15 +515,13 @@ END SUBROUTINE nmr_epr_linres !> \param qs_env ... !> \param p_env ... !> \param dft_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE issc_linres(linres_control,qs_env, p_env, dft_control, error) + SUBROUTINE issc_linres(linres_control,qs_env, p_env, dft_control) TYPE(linres_control_type), POINTER :: linres_control TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_linres', & routineP = moduleN//':'//routineN @@ -547,7 +537,7 @@ SUBROUTINE issc_linres(linres_control,qs_env, p_env, dft_control, error) "Are you sure that you want to calculate the chemical "//& "shift without localized psi0?") CALL linres_localize(qs_env,linres_control,& - dft_control%nspins,centers_only=.TRUE.,error=error) + dft_control%nspins,centers_only=.TRUE.) ENDIF ! !Initialize the current environment @@ -556,23 +546,23 @@ SUBROUTINE issc_linres(linres_control,qs_env, p_env, dft_control, error) IF(qs_env%qmmm) do_qmmm = .TRUE. current_env%do_qmmm = do_qmmm !current_env%prop='issc' - !CALL current_env_init(current_env,qs_env,error=error) - !CALL current_response(current_env,p_env,qs_env,error) + !CALL current_env_init(current_env,qs_env) + !CALL current_response(current_env,p_env,qs_env) ! !Initialize the issc environment issc_env%ref_count=0 - CALL issc_env_init(issc_env,qs_env,error=error) + CALL issc_env_init(issc_env,qs_env) ! ! Loop over atoms DO iatom = 1,issc_env%issc_natms - CALL issc_operators(issc_env,qs_env,iatom,error) - CALL issc_response(issc_env,p_env,qs_env,error) - CALL issc_issc(issc_env,qs_env,iatom,error=error) + CALL issc_operators(issc_env,qs_env,iatom) + CALL issc_response(issc_env,p_env,qs_env) + CALL issc_issc(issc_env,qs_env,iatom) ENDDO ! ! Finalized the issc environment - CALL issc_print(issc_env,qs_env,error) - CALL issc_env_cleanup(issc_env,error) + CALL issc_print(issc_env,qs_env) + CALL issc_env_cleanup(issc_env) END SUBROUTINE issc_linres @@ -581,13 +571,11 @@ END SUBROUTINE issc_linres !> \brief ... !> \param qs_env ... !> \param p_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE polar_linres(qs_env,p_env,error) + SUBROUTINE polar_linres(qs_env,p_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_p_env_type), POINTER :: p_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'polar_linres', & routineP = moduleN//':'//routineN @@ -595,13 +583,13 @@ SUBROUTINE polar_linres(qs_env,p_env,error) TYPE(polar_env_type) :: polar_env polar_env%ref_count=0 - CALL polar_env_init(polar_env,qs_env,error=error) - CALL polar_operators(polar_env,qs_env,error=error) - CALL polar_response(polar_env,p_env,qs_env,error=error) - CALL polar_polar(polar_env,qs_env,error=error) + CALL polar_env_init(polar_env,qs_env) + CALL polar_operators(polar_env,qs_env) + CALL polar_response(polar_env,p_env,qs_env) + CALL polar_polar(polar_env,qs_env) ! - CALL polar_print(polar_env,qs_env,error) - CALL polar_env_cleanup(polar_env,error) + CALL polar_print(polar_env,qs_env) + CALL polar_env_cleanup(polar_env) END SUBROUTINE polar_linres diff --git a/src/qs_linres_nmr_epr_common_utils.F b/src/qs_linres_nmr_epr_common_utils.F index 6c55f5f54a..7622cd684e 100644 --- a/src/qs_linres_nmr_epr_common_utils.F +++ b/src/qs_linres_nmr_epr_common_utils.F @@ -52,7 +52,6 @@ MODULE qs_linres_nmr_epr_common_utils !> \param funcG_times_rho ... !> \param idir ... !> \param my_chi ... -!> \param error ... !> \author MI !> \note !> The G=0 component is not comnputed here, but can be evaluated @@ -61,7 +60,7 @@ MODULE qs_linres_nmr_epr_common_utils !> This method would not work for a non periodic system !> It should be generalized like the calculation of Hartree ! ***************************************************************************** - SUBROUTINE mult_G_ov_G2_grid(cell,pw_pool,rho_gspace,funcG_times_rho,idir,my_chi,error) + SUBROUTINE mult_G_ov_G2_grid(cell,pw_pool,rho_gspace,funcG_times_rho,idir,my_chi) TYPE(cell_type), POINTER :: cell TYPE(pw_pool_type), POINTER :: pw_pool @@ -69,7 +68,6 @@ SUBROUTINE mult_G_ov_G2_grid(cell,pw_pool,rho_gspace,funcG_times_rho,idir,my_ch TYPE(pw_p_type) :: funcG_times_rho INTEGER, INTENT(IN) :: idir REAL(dp), INTENT(IN) :: my_chi - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: handle, ig, ng LOGICAL :: failure @@ -83,10 +81,10 @@ SUBROUTINE mult_G_ov_G2_grid(cell,pw_pool,rho_gspace,funcG_times_rho,idir,my_ch failure = .FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) CALL pw_pool_create_pw ( pw_pool, influence_fn,& - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE ,error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) grid => influence_fn % pw_grid DO ig = grid % first_gne0, grid % ngpts_cut_local @@ -96,14 +94,14 @@ SUBROUTINE mult_G_ov_G2_grid(cell,pw_pool,rho_gspace,funcG_times_rho,idir,my_ch IF ( grid % have_g0 ) influence_fn%cc ( 1 ) = 0.0_dp frho => funcG_times_rho%pw - CALL pw_transfer (rho_gspace%pw,frho,error=error) + CALL pw_transfer (rho_gspace%pw,frho) ng = SIZE(grid % gsq) frho%cc(1:ng) = frho%cc(1:ng)*influence_fn % cc ( 1 : ng ) IF ( grid % have_g0 ) frho%cc(1) = my_chi CALL pw_pool_give_back_pw(pw_pool,influence_fn,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL timestop(handle) diff --git a/src/qs_linres_nmr_shift.F b/src/qs_linres_nmr_shift.F index ed9440638a..0da3dcd629 100644 --- a/src/qs_linres_nmr_shift.F +++ b/src/qs_linres_nmr_shift.F @@ -97,15 +97,13 @@ MODULE qs_linres_nmr_shift !> \param current_env ... !> \param qs_env ... !> \param iB ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE nmr_shift(nmr_env,current_env,qs_env,iB,error) + SUBROUTINE nmr_shift(nmr_env,current_env,qs_env,iB) TYPE(nmr_env_type) :: nmr_env TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iB - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nmr_shift', & routineP = moduleN//':'//routineN @@ -145,7 +143,7 @@ SUBROUTINE nmr_shift(nmr_env,current_env,qs_env,iB,error) pw_pools,particle_set,jrho1_g) CALL get_qs_env(qs_env=qs_env,cell=cell,dft_control=dft_control,& - particle_set=particle_set,error=error) + particle_set=particle_set) gapw = dft_control%qs_control%gapw natom = SIZE(particle_set,1) @@ -155,28 +153,25 @@ SUBROUTINE nmr_shift(nmr_env,current_env,qs_env,iB,error) chemical_shift_loc=chemical_shift_loc,& chemical_shift_nics=chemical_shift_nics,& chemical_shift_nics_loc=chemical_shift_nics_loc,& - interpolate_shift=interpolate_shift,& - error=error) + interpolate_shift=interpolate_shift) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) CALL pw_env_get(pw_env,auxbas_rs_desc=auxbas_rs_desc,& - auxbas_pw_pool=auxbas_pw_pool,pw_pools=pw_pools,& - error=error) + auxbas_pw_pool=auxbas_pw_pool,pw_pools=pw_pools) ! ! nmr_section => section_vals_get_subs_vals(qs_env%input, & - & "PROPERTIES%LINRES%NMR",error=error) + & "PROPERTIES%LINRES%NMR") ! ! Initialize ! Allocate grids for the calculation of jrho and the shift ALLOCATE(shift_pw_gspace(3,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO idir = 1,3 CALL pw_pool_create_pw(auxbas_pw_pool,shift_pw_gspace(idir,ispin)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(shift_pw_gspace(idir,ispin)%pw,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL pw_zero(shift_pw_gspace(idir,ispin)%pw) ENDDO ENDDO ! @@ -184,13 +179,12 @@ SUBROUTINE nmr_shift(nmr_env,current_env,qs_env,iB,error) CALL set_vecp(iB,iiB,iiiB) ! CALL pw_pool_create_pw(auxbas_pw_pool,pw_gspace_work%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(pw_gspace_work%pw,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL pw_zero(pw_gspace_work%pw) DO ispin = 1,nspins ! DO idir = 1,3 - CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_g=jrho1_g, error=error) + CALL qs_rho_get(current_env%jrho1_set(idir)%rho, rho_g=jrho1_g) jrho_gspace => jrho1_g(ispin) ! Field gradient ! loop over the Gvec components: x,y,z @@ -198,42 +192,41 @@ SUBROUTINE nmr_shift(nmr_env,current_env,qs_env,iB,error) IF(idir /= idir2) THEN ! in reciprocal space multiply (G_idir2(i)/G(i)^2)J_(idir)(G(i)) CALL mult_G_ov_G2_grid(cell,auxbas_pw_pool,jrho_gspace,& - pw_gspace_work,idir2,0.0_dp,error=error) + pw_gspace_work,idir2,0.0_dp) ! ! scale and add to the correct component of the shift column CALL set_vecp_rev(idir,idir2,idir3) scale_fac=fac_vecp(idir3,idir2,idir) - CALL pw_axpy(pw_gspace_work%pw,shift_pw_gspace(idir3,ispin)%pw,scale_fac,error=error) + CALL pw_axpy(pw_gspace_work%pw,shift_pw_gspace(idir3,ispin)%pw,scale_fac) ENDIF ENDDO ! ENDDO ! idir ENDDO ! ispin ! - CALL pw_pool_give_back_pw(auxbas_pw_pool,pw_gspace_work%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,pw_gspace_work%pw) ! ! compute shildings IF(interpolate_shift) THEN CALL pw_pool_create_pw(auxbas_pw_pool,shift_pw_rspace%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) DO ispin = 1,nspins DO idir = 1,3 ! Here first G->R and then interpolation to get the shifts. ! The interpolation doesnt work in parallel yet. ! The choice between both methods should be left to the user. - CALL pw_transfer(shift_pw_gspace(idir,ispin)%pw,shift_pw_rspace%pw,error=error) + CALL pw_transfer(shift_pw_gspace(idir,ispin)%pw,shift_pw_rspace%pw) CALL interpolate_shift_pwgrid(nmr_env,pw_env,particle_set,cell,shift_pw_rspace,& - iB,idir,nmr_section,error=error) + iB,idir,nmr_section) ENDDO ENDDO - CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_rspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_rspace%pw) ELSE DO ispin = 1,nspins DO idir = 1,3 ! Here the shifts are computed from summation of the coeff on the G-grip . CALL gsum_shift_pwgrid(nmr_env,particle_set,cell,& - shift_pw_gspace(idir,ispin),iB,idir,& - error=error) + shift_pw_gspace(idir,ispin),iB,idir) ENDDO ENDDO ENDIF @@ -243,18 +236,18 @@ SUBROUTINE nmr_shift(nmr_env,current_env,qs_env,iB,error) ! Finally the radial functions are multiplied by the YLM and properly summed ! The resulting array is J on the local grid. One array per atom. ! Local contributions by numerical integration over the spherical grids - CALL nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error=error) + CALL nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir) ENDDO ! idir ENDIF ! ! Dellocate grids for the calculation of jrho and the shift DO ispin = 1,nspins DO idir = 1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_gspace(idir,ispin)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,shift_pw_gspace(idir,ispin)%pw) ENDDO ENDDO DEALLOCATE(shift_pw_gspace,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! Finalize CALL timestop(handle) @@ -269,15 +262,13 @@ END SUBROUTINE nmr_shift !> \param qs_env ... !> \param iB ... !> \param idir ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) + SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir) TYPE(nmr_env_type) :: nmr_env TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: IB, idir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nmr_shift_gapw', & routineP = moduleN//':'//routineN @@ -322,7 +313,7 @@ SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) jrho1_atom,r_nics,jrho_h_grid,jrho_s_grid,& atom_list,grid_atom,harmonics,logger) ! - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) ! CALL get_qs_env(qs_env=qs_env,& @@ -331,8 +322,7 @@ SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) cell=cell,& dft_control=dft_control,& para_env=para_env,& - particle_set=particle_set,& - error=error) + particle_set=particle_set) CALL get_nmr_env(nmr_env=nmr_env,& chemical_shift_loc=chemical_shift_loc,& @@ -340,12 +330,10 @@ SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) shift_gapw_radius=shift_gapw_radius,& n_nics=n_nics,& r_nics=r_nics,& - do_nics=do_nics,& - error=error) + do_nics=do_nics) CALL get_current_env(current_env=current_env,& - jrho1_atom_set=jrho1_atom_set,& - error=error) + jrho1_atom_set=jrho1_atom_set) ! nkind = SIZE(atomic_kind_set,1) natom_tot = SIZE(particle_set,1) @@ -358,12 +346,12 @@ SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) ! ALLOCATE(cs_loc_tmp(3,natom_tot),list_j(natom_tot),& dist_ij(3,natom_tot),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) cs_loc_tmp = 0.0_dp IF(do_nics) THEN ALLOCATE(cs_nics_loc_tmp(3,n_nics),list_nics_j(n_nics),& dist_nics_ij(3,n_nics),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) cs_nics_loc_tmp = 0.0_dp ENDIF ! @@ -379,7 +367,7 @@ SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) CALL get_qs_kind(qs_kind_set(ikind),& paw_atom=paw_atom,& harmonics=harmonics,& - grid_atom=grid_atom, error=error) + grid_atom=grid_atom) ! na = grid_atom%ng_sphere nr = grid_atom%nr @@ -509,7 +497,7 @@ SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) & - nmr_env%shift_factor_gapw * cs_loc_tmp(:,:) / 2.0_dp ! DEALLOCATE(cs_loc_tmp,list_j,dist_ij,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! IF(do_nics) THEN CALL mp_sum(cs_nics_loc_tmp,para_env%group) @@ -517,7 +505,7 @@ SUBROUTINE nmr_shift_gapw(nmr_env,current_env,qs_env,iB,idir,error) & - nmr_env%shift_factor_gapw * cs_nics_loc_tmp(:,:) / 2.0_dp ! DEALLOCATE(cs_nics_loc_tmp,list_nics_j,dist_nics_ij,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! CALL timestop(handle) @@ -535,11 +523,10 @@ END SUBROUTINE nmr_shift_gapw !> \param i_B component of the magnetic field for which the shift is calculated (row) !> \param idir component of the vector \int_{r}[ ((r-r') x j(r))/|r-r'|^3 ] = Bind(r') !> \param nmr_section ... -!> \param error ... !> \author MI ! ***************************************************************************** SUBROUTINE interpolate_shift_pwgrid(nmr_env,pw_env,particle_set,cell,shift_pw_rspace,& - i_B,idir,nmr_section,error) + i_B,idir,nmr_section) TYPE(nmr_env_type) :: nmr_env TYPE(pw_env_type), POINTER :: pw_env @@ -549,7 +536,6 @@ SUBROUTINE interpolate_shift_pwgrid(nmr_env,pw_env,particle_set,cell,shift_pw_rs TYPE(pw_p_type) :: shift_pw_rspace INTEGER, INTENT(IN) :: i_B, idir TYPE(section_vals_type), POINTER :: nmr_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'interpolate_shift_pwgrid', & routineP = moduleN//':'//routineN @@ -577,39 +563,37 @@ SUBROUTINE interpolate_shift_pwgrid(nmr_env,pw_env,particle_set,cell,shift_pw_rs NULLIFY (auxbas_pw_pool,precond) NULLIFY (cs_atom_list,chemical_shift,chemical_shift_nics,r_nics) - CPPrecondition(ASSOCIATED(shift_pw_rspace%pw),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(shift_pw_rspace%pw),cp_failure_level,routineP,failure) interp_section => section_vals_get_subs_vals(nmr_section,& - "INTERPOLATOR",error=error) + "INTERPOLATOR") CALL section_vals_val_get(interp_section,"aint_precond", & - i_val=aint_precond, error=error) - CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind, error=error) - CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter, error=error) - CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r, error=error) - CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x, error=error) + i_val=aint_precond) + CALL section_vals_val_get(interp_section,"precond",i_val=precond_kind) + CALL section_vals_val_get(interp_section,"max_iter",i_val=max_iter) + CALL section_vals_val_get(interp_section,"eps_r",r_val=eps_r) + CALL section_vals_val_get(interp_section,"eps_x",r_val=eps_x) ! calculate spline coefficients - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,shiftspl%pw, & - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) CALL pw_spline_precond_create(precond,precond_kind=aint_precond,& - pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.,error=error) - CALL pw_spline_do_precond(precond,shift_pw_rspace%pw,shiftspl%pw,error=error) - CALL pw_spline_precond_set_kind(precond,precond_kind,error=error) + pool=auxbas_pw_pool,pbc=.TRUE.,transpose=.FALSE.) + CALL pw_spline_do_precond(precond,shift_pw_rspace%pw,shiftspl%pw) + CALL pw_spline_precond_set_kind(precond,precond_kind) success=find_coeffs(values=shift_pw_rspace%pw,coeffs=shiftspl%pw,& linOp=spl3_pbc,preconditioner=precond,pool=auxbas_pw_pool, & - eps_r=eps_r,eps_x=eps_x,max_iter=max_iter, & - error=error) - CPPostconditionNoFail(success,cp_warning_level,routineP,error) - CALL pw_spline_precond_release(precond,error=error) + eps_r=eps_r,eps_x=eps_x,max_iter=max_iter) + CPPostconditionNoFail(success,cp_warning_level,routineP) + CALL pw_spline_precond_release(precond) CALL get_nmr_env(nmr_env=nmr_env, cs_atom_list=cs_atom_list,& chemical_shift=chemical_shift,& chemical_shift_nics=chemical_shift_nics,& n_nics=n_nics,r_nics=r_nics,& - do_nics=do_nics,error=error) + do_nics=do_nics) IF(ASSOCIATED(cs_atom_list)) THEN natom = SIZE(cs_atom_list,1) @@ -620,7 +604,7 @@ SUBROUTINE interpolate_shift_pwgrid(nmr_env,pw_env,particle_set,cell,shift_pw_rs DO iat = 1,natom iatom = cs_atom_list(iat) R_iatom = pbc(particle_set(iatom)%r,cell) - shift_val = Eval_Interp_Spl3_pbc(R_iatom,shiftspl%pw,error=error) + shift_val = Eval_Interp_Spl3_pbc(R_iatom,shiftspl%pw) chemical_shift(idir,i_B,iatom)= chemical_shift(idir,i_B,iatom)+& nmr_env%shift_factor * twopi**2 * shift_val END DO @@ -629,13 +613,13 @@ SUBROUTINE interpolate_shift_pwgrid(nmr_env,pw_env,particle_set,cell,shift_pw_rs DO iatom = 1,n_nics ra(:) = r_nics(:,iatom) R_iatom = pbc(ra,cell) - shift_val = Eval_Interp_Spl3_pbc(R_iatom,shiftspl%pw,error) + shift_val = Eval_Interp_Spl3_pbc(R_iatom,shiftspl%pw) chemical_shift_nics(idir,i_B,iatom)= chemical_shift_nics(idir,i_B,iatom)+& nmr_env%shift_factor * twopi**2 * shift_val END DO END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,shiftspl%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,shiftspl%pw) ! CALL timestop(handle) @@ -650,17 +634,15 @@ END SUBROUTINE interpolate_shift_pwgrid !> \param shift_pw_gspace ... !> \param i_B ... !> \param idir ... -!> \param error ... ! ***************************************************************************** SUBROUTINE gsum_shift_pwgrid(nmr_env,particle_set,cell,shift_pw_gspace,& - i_B,idir,error) + i_B,idir) TYPE(nmr_env_type) :: nmr_env TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(cell_type), POINTER :: cell TYPE(pw_p_type) :: shift_pw_gspace INTEGER, INTENT(IN) :: i_B, idir - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gsum_shift_pwgrid', & routineP = moduleN//':'//routineN @@ -682,13 +664,12 @@ SUBROUTINE gsum_shift_pwgrid(nmr_env,particle_set,cell,shift_pw_gspace,& CALL timeset(routineN,handle) ! NULLIFY(cs_atom_list,chemical_shift,chemical_shift_nics,r_nics) - CPPrecondition(ASSOCIATED(shift_pw_gspace%pw),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(shift_pw_gspace%pw),cp_failure_level,routineP,failure) ! CALL get_nmr_env(nmr_env=nmr_env, cs_atom_list=cs_atom_list,& chemical_shift=chemical_shift,& chemical_shift_nics=chemical_shift_nics,& - n_nics=n_nics,r_nics=r_nics,do_nics=do_nics,& - error=error) + n_nics=n_nics,r_nics=r_nics,do_nics=do_nics) ! IF(ASSOCIATED(cs_atom_list)) THEN natom = SIZE(cs_atom_list,1) @@ -752,14 +733,12 @@ END SUBROUTINE gsumr !> \param nmr_env ... !> \param current_env ... !> \param qs_env ... -!> \param error ... !> \author MI ! ***************************************************************************** - SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) + SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env) TYPE(nmr_env_type) :: nmr_env TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nmr_shift_print', & routineP = moduleN//':'//routineN @@ -792,11 +771,11 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) NULLIFY(cs,cs_nics,r_nics,cs_loc,cs_nics_loc,logger,particle_set,atom_kind,dft_control) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) nmr_section => section_vals_get_subs_vals(qs_env%input, & - "PROPERTIES%LINRES%NMR",error=error) + "PROPERTIES%LINRES%NMR") CALL get_nmr_env(nmr_env=nmr_env, & chemical_shift=cs, & @@ -806,13 +785,11 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) cs_atom_list=cs_atom_list, & n_nics=n_nics, & r_nics=r_nics, & - do_nics=do_nics, & - error=error) + do_nics=do_nics) ! CALL get_current_env(current_env=current_env,& chi_tensor=chi_tensor,& - chi_tensor_loc=chi_tensor_loc,& - error=error) + chi_tensor_loc=chi_tensor_loc) ! ! multiply by the appropriate factor chi_tensor_tmp(:,:) = 0.0_dp @@ -822,18 +799,17 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) ! CALL get_qs_env(qs_env=qs_env, & dft_control=dft_control, & - particle_set=particle_set, & - error=error) + particle_set=particle_set) natom = SIZE(particle_set,1) gapw = dft_control%qs_control%gapw nat_print=SIZE(cs_atom_list,1) ALLOCATE(cs_tot(3,3,nat_print),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(do_nics) THEN ALLOCATE(cs_nics_tot(3,3,n_nics),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! Finalize Chi calculation ! Symmetrize @@ -843,7 +819,7 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) & + ( chi_tensor_loc_tmp(:,:) + TRANSPOSE(chi_tensor_loc_tmp(:,:)) ) / 2.0_dp ENDIF chi_tmp(:,:) = chi_sym_tot(:,:) - CALL diamat_all(chi_tmp,eig,error=error) + CALL diamat_all(chi_tmp,eig) chi_iso = (eig(1)+ eig(2)+eig(3))/3.0_dp chi_aniso = eig(3)-(eig(2)+eig(1))/2.0_dp ! @@ -853,11 +829,10 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) ENDIF ! IF (BTEST(cp_print_key_should_output(logger%iter_info,nmr_section,& - "PRINT%CHI_TENSOR",error=error),cp_p_file)) THEN + "PRINT%CHI_TENSOR"),cp_p_file)) THEN unit_atoms=cp_print_key_unit_nr(logger,nmr_section,"PRINT%CHI_TENSOR",& - extension=".data",middle_name="CHI",log_filename=.FALSE.,& - error=error) + extension=".data",middle_name="CHI",log_filename=.FALSE.) WRITE(title,'(A)') "Magnetic Susceptibility Tensor " IF(unit_atoms > 0) THEN @@ -915,7 +890,7 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) ENDIF CALL cp_print_key_finished_output(unit_atoms, logger,nmr_section,& - & "PRINT%CHI_TENSOR", error=error) + & "PRINT%CHI_TENSOR") ENDIF ! print chi ! ! Add the chi part to the shifts @@ -935,11 +910,11 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) ! ! print shifts IF (BTEST(cp_print_key_should_output(logger%iter_info,nmr_section,& - "PRINT%SHIELDING_TENSOR",error=error),cp_p_file)) THEN + "PRINT%SHIELDING_TENSOR"),cp_p_file)) THEN unit_atoms=cp_print_key_unit_nr(logger,nmr_section,"PRINT%SHIELDING_TENSOR",& extension=".data",middle_name="SHIFT",& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) nat_print = SIZE(cs_atom_list,1) IF(unit_atoms > 0) THEN @@ -951,7 +926,7 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) atom_kind => particle_set(iatom)%atomic_kind CALL get_atomic_kind(atom_kind,name=name,element_symbol=element_symbol) shift_sym_tot(:,:) = 0.5_dp * (cs_tot(:,:,ir) + TRANSPOSE(cs_tot(:,:,ir))) - CALL diamat_all(shift_sym_tot,eig,error=error) + CALL diamat_all(shift_sym_tot,eig) shift_iso = (eig(1) + eig(2) + eig(3)) / 3.0_dp shift_aniso = eig(3) - (eig(2) + eig(1)) / 2.0_dp ! @@ -994,7 +969,7 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) ENDDO ! ir ENDIF CALL cp_print_key_finished_output(unit_atoms,logger,nmr_section,& - & "PRINT%SHIELDING_TENSOR",error=error) + & "PRINT%SHIELDING_TENSOR") IF(do_nics) THEN ! @@ -1011,13 +986,13 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) ! unit_nics=cp_print_key_unit_nr(logger,nmr_section,"PRINT%SHIELDING_TENSOR",& extension=".data",middle_name="NICS",& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) IF(unit_nics > 0) THEN WRITE(title,'(A,1X,I5)') "Shielding at nics positions. # tensors printed ", n_nics WRITE(unit_nics,'(T2,A)') title DO ir = 1,n_nics shift_sym_tot(:,:) = 0.5_dp * (cs_nics_tot(:,:,ir) + TRANSPOSE(cs_nics_tot(:,:,ir))) - CALL diamat_all(shift_sym_tot,eig,error=error) + CALL diamat_all(shift_sym_tot,eig) shift_iso = (eig(1) + eig(2) + eig(3)) / 3.0_dp shift_aniso = eig(3) - (eig(2) + eig(1)) / 2.0_dp ! @@ -1060,16 +1035,16 @@ SUBROUTINE nmr_shift_print(nmr_env,current_env,qs_env,error) ENDDO ENDIF CALL cp_print_key_finished_output(unit_nics,logger,nmr_section,& - & "PRINT%SHIELDING_TENSOR",error=error) + & "PRINT%SHIELDING_TENSOR") ENDIF ENDIF ! print shift ! ! clean up DEALLOCATE(cs_tot,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(do_nics) THEN DEALLOCATE(cs_nics_tot,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! !100 FORMAT(A,1X,I5) diff --git a/src/qs_linres_nmr_utils.F b/src/qs_linres_nmr_utils.F index e2454fb107..70cbfeac78 100644 --- a/src/qs_linres_nmr_utils.F +++ b/src/qs_linres_nmr_utils.F @@ -66,16 +66,14 @@ MODULE qs_linres_nmr_utils !> \brief Initialize the nmr environment !> \param nmr_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 07.2006 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE nmr_env_init(nmr_env,qs_env,error) + SUBROUTINE nmr_env_init(nmr_env,qs_env) ! TYPE(nmr_env_type) :: nmr_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nmr_env_init', & routineP = moduleN//':'//routineN @@ -116,14 +114,14 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) nao = 0 nmoloc = 0 - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(nmr_env%ref_count /= 0) THEN - CALL nmr_env_cleanup(nmr_env,error=error) + CALL nmr_env_cleanup(nmr_env) END IF IF(output_unit>0) THEN @@ -131,35 +129,35 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) WRITE(output_unit,"(T10,A,/)") "Inizialization of the NMR environment" ENDIF - CALL nmr_env_create(nmr_env,error=error) + CALL nmr_env_create(nmr_env) ! ! If current_density or full_nmr different allocations are required nmr_section => section_vals_get_subs_vals(qs_env%input, & - & "PROPERTIES%LINRES%NMR",error=error) - CALL section_vals_val_get(nmr_section,"INTERPOLATE_SHIFT",l_val=nmr_env%interpolate_shift,error=error) - CALL section_vals_val_get(nmr_section,"SHIFT_GAPW_RADIUS",r_val=nmr_env%shift_gapw_radius,error=error) - CALL section_vals_val_get(nmr_section,"NICS",l_val=nmr_env%do_nics,error=error) + & "PROPERTIES%LINRES%NMR") + CALL section_vals_val_get(nmr_section,"INTERPOLATE_SHIFT",l_val=nmr_env%interpolate_shift) + CALL section_vals_val_get(nmr_section,"SHIFT_GAPW_RADIUS",r_val=nmr_env%shift_gapw_radius) + CALL section_vals_val_get(nmr_section,"NICS",l_val=nmr_env%do_nics) IF(nmr_env%do_nics) THEN CALL section_vals_val_get(nmr_section,"NICS_FILE_NAME",& - c_val=nics_file_name,error=error) - CALL parser_create(parser,nics_file_name,error=error) - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,nmr_env%n_nics,error=error) + c_val=nics_file_name) + CALL parser_create(parser,nics_file_name) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,nmr_env%n_nics) ALLOCATE(nmr_env%r_nics(3,nmr_env%n_nics),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) - CALL parser_get_next_line(parser,2,error=error) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) + CALL parser_get_next_line(parser,2) DO j = 1,nmr_env%n_nics - CALL parser_get_object(parser,label,error=error) - CALL parser_get_object(parser,nmr_env%r_nics(1,j),error=error) - CALL parser_get_object(parser,nmr_env%r_nics(2,j),error=error) - CALL parser_get_object(parser,nmr_env%r_nics(3,j),error=error) - nmr_env%r_nics(1,j) = cp_unit_to_cp2k(nmr_env%r_nics(1,j),"angstrom",error=error) - nmr_env%r_nics(2,j) = cp_unit_to_cp2k(nmr_env%r_nics(2,j),"angstrom",error=error) - nmr_env%r_nics(3,j) = cp_unit_to_cp2k(nmr_env%r_nics(3,j),"angstrom",error=error) - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_object(parser,label) + CALL parser_get_object(parser,nmr_env%r_nics(1,j)) + CALL parser_get_object(parser,nmr_env%r_nics(2,j)) + CALL parser_get_object(parser,nmr_env%r_nics(3,j)) + nmr_env%r_nics(1,j) = cp_unit_to_cp2k(nmr_env%r_nics(1,j),"angstrom") + nmr_env%r_nics(2,j) = cp_unit_to_cp2k(nmr_env%r_nics(2,j),"angstrom") + nmr_env%r_nics(3,j) = cp_unit_to_cp2k(nmr_env%r_nics(3,j),"angstrom") + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT ENDDO - CALL parser_release(parser,error=error) + CALL parser_release(parser) ENDIF CALL get_qs_env(qs_env=qs_env,& @@ -170,7 +168,7 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) mpools=mpools,& particle_set=particle_set,& pw_env=pw_env,& - scf_control=scf_control,error=error) + scf_control=scf_control) ! ! Check if restat also psi0 should be restarted !IF(nmr_env%restart_nmr .AND. scf_control%density_guess/=restart_guess)THEN @@ -178,7 +176,7 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) !ENDIF ! ! check that the psi0 are localized and you have all the centers - CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,error,failure) + CPPrecondition(linres_control%localized_psi0,cp_warning_level,routineP,failure) IF(failure .AND. (output_unit>0)) THEN WRITE(output_unit,'(A)') & ' To get NMR parameters within PBC you need localized zero order orbitals ' @@ -200,7 +198,7 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) nmr_env%chi_SI2ppmcgs = 6.022045_dp/1.0E+2_dp ! Chi to Shift: 10^-30 * 2/3 mu_0 / Omega * 1/ppm nmr_env%chi_SI2shiftppm = 1.0E-30_dp * 8.37758041E-7_dp/ & - (cp_unit_from_cp2k(cell%deth,"angstrom^3",error=error)*1.0E-30_dp) * 1.0E+6_dp + (cp_unit_from_cp2k(cell%deth,"angstrom^3")*1.0E-30_dp) * 1.0E+6_dp IF(output_unit>0) THEN WRITE(output_unit,"(T2,A,T65,ES15.6)") "NMR| Shift gapw radius (a.u.) ",nmr_env%shift_gapw_radius @@ -218,21 +216,21 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) ENDIF ALLOCATE (nmr_env%do_calc_cs_atom(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nmr_env%do_calc_cs_atom = 0 IF (BTEST(cp_print_key_should_output(logger%iter_info,nmr_section,& - & "PRINT%SHIELDING_TENSOR",error=error),cp_p_file)) THEN + & "PRINT%SHIELDING_TENSOR"),cp_p_file)) THEN NULLIFY(bounds,list) nat_print = 0 CALL section_vals_val_get(nmr_section,& & "PRINT%SHIELDING_TENSOR%ATOMS_LU_BOUNDS",& - i_vals=bounds,error=error) + i_vals=bounds) nat_print = bounds(2) - bounds(1) + 1 IF(nat_print > 0) THEN ALLOCATE(nmr_env%cs_atom_list(nat_print),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ir = 1,nat_print nmr_env%cs_atom_list(ir) = bounds(1) + (ir-1) nmr_env%do_calc_cs_atom(bounds(1) + (ir-1)) = 1 @@ -241,12 +239,12 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) IF(.NOT. ASSOCIATED(nmr_env%cs_atom_list)) THEN CALL section_vals_val_get(nmr_section,"PRINT%SHIELDING_TENSOR%ATOMS_LIST",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) nat_print = 0 DO ir = 1,n_rep NULLIFY(list) CALL section_vals_val_get(nmr_section,"PRINT%SHIELDING_TENSOR%ATOMS_LIST",& - i_rep_val=ir,i_vals=list,error=error) + i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(nmr_env%cs_atom_list,1,nat_print + SIZE(list)) DO ini = 1, SIZE(list) @@ -260,7 +258,7 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) IF(.NOT. ASSOCIATED(nmr_env%cs_atom_list)) THEN ALLOCATE(nmr_env%cs_atom_list(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ir = 1,natom nmr_env%cs_atom_list(ir) = ir ENDDO @@ -268,7 +266,7 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) ENDIF ! ! check the list - CPPostcondition(ASSOCIATED(nmr_env%cs_atom_list),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(nmr_env%cs_atom_list),cp_failure_level,routineP,failure) DO ir = 1,SIZE(nmr_env%cs_atom_list,1) IF(nmr_env%cs_atom_list(ir).LT.1.OR.nmr_env%cs_atom_list(ir).GT.natom) THEN CALL stop_program(routineN,moduleN,__LINE__,"Unknown atom(s)") @@ -297,19 +295,19 @@ SUBROUTINE nmr_env_init(nmr_env,qs_env,error) ! Initialize the chemical shift tensor ALLOCATE(nmr_env%chemical_shift(3,3,natom),& nmr_env%chemical_shift_loc(3,3,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nmr_env%chemical_shift = 0.0_dp nmr_env%chemical_shift_loc = 0.0_dp IF(nmr_env%do_nics) THEN ALLOCATE(nmr_env%chemical_shift_nics_loc(3,3,nmr_env%n_nics),& nmr_env%chemical_shift_nics(3,3,nmr_env%n_nics),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nmr_env%chemical_shift_nics_loc = 0.0_dp nmr_env%chemical_shift_nics = 0.0_dp ENDIF CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - & "PRINT%PROGRAM_RUN_INFO",error=error) + & "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -318,15 +316,13 @@ END SUBROUTINE nmr_env_init ! ***************************************************************************** !> \brief Deallocate the nmr environment !> \param nmr_env ... -!> \param error ... !> \par History !> 07.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE nmr_env_cleanup(nmr_env,error) + SUBROUTINE nmr_env_cleanup(nmr_env) TYPE(nmr_env_type) :: nmr_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nmr_env_cleanup', & routineP = moduleN//':'//routineN @@ -347,24 +343,24 @@ SUBROUTINE nmr_env_cleanup(nmr_env,error) !chemical_shift IF(ASSOCIATED(nmr_env%chemical_shift)) THEN DEALLOCATE(nmr_env%chemical_shift,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(nmr_env%chemical_shift_loc)) THEN DEALLOCATE(nmr_env%chemical_shift_loc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! nics IF(ASSOCIATED(nmr_env%r_nics)) THEN DEALLOCATE(nmr_env%r_nics,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(nmr_env%chemical_shift_nics)) THEN DEALLOCATE(nmr_env%chemical_shift_nics,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(nmr_env%chemical_shift_nics_loc)) THEN DEALLOCATE(nmr_env%chemical_shift_nics_loc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF ! ref count diff --git a/src/qs_linres_op.F b/src/qs_linres_op.F index b2f3dca123..649161184e 100644 --- a/src/qs_linres_op.F +++ b/src/qs_linres_op.F @@ -96,7 +96,6 @@ MODULE qs_linres_op !> linear response orbitals. !> \param current_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 07.2005 created [MI] !> \author MI @@ -107,11 +106,10 @@ MODULE qs_linres_op !> The centers of the orbitals result form the orbital localization procedure !> that typicaly uses the berry phase operator to define the Wannier centers. ! ***************************************************************************** - SUBROUTINE current_operators(current_env,qs_env,error) + SUBROUTINE current_operators(current_env,qs_env) TYPE(current_env_type) :: current_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'current_operators', & routineP = moduleN//':'//routineN @@ -161,12 +159,12 @@ SUBROUTINE current_operators(current_env,qs_env,error) rxp_psi0,vecbuf_c0,psi0_order,& mo_coeff,op_ao,sab_all) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() lr_section => section_vals_get_subs_vals(qs_env%input,& - "PROPERTIES%LINRES",error=error) + "PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(output_unit>0) THEN WRITE(output_unit,FMT="(T2,A,/)")& "CURRENT| Calculation of the p and (r-d)xp operators applied to psi0" @@ -181,8 +179,7 @@ SUBROUTINE current_operators(current_env,qs_env,error) particle_set=particle_set, & sab_all=sab_all,& sab_orb=sab_orb,& - dbcsr_dist=dbcsr_dist,& - error=error) + dbcsr_dist=dbcsr_dist) nspins = dft_control%nspins @@ -190,27 +187,27 @@ SUBROUTINE current_operators(current_env,qs_env,error) center_list=center_list,basisfun_center=basisfun_center, & nbr_center=nbr_center,p_psi0=p_psi0, rxp_psi0=rxp_psi0,& psi0_order=psi0_order,& - nstates=nstates,error=error) + nstates=nstates) ALLOCATE(vecbuf_c0(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO idir = 1,3 NULLIFY(vecbuf_Rmdc0(idir)%array) ALLOCATE(vecbuf_Rmdc0(idir)%array(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDDO - CALL get_qs_kind_set(qs_kind_set=qs_kind_set,nsgf=nsgf,error=error) + CALL get_qs_kind_set(qs_kind_set=qs_kind_set,nsgf=nsgf) natom = SIZE(particle_set,1) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ! Calculate the (r - dk)xp operator applied to psi0k @@ -222,7 +219,7 @@ SUBROUTINE current_operators(current_env,qs_env,error) ! notice: (r-c) and p are operators, whereas (c-d) is a multiplicative factor ! !First term: operator matrix elements - ! CALL rmc_x_p_xyz_ao(op_rmd_ao,qs_env,minimum_image=.FALSE.,error=error) + ! CALL rmc_x_p_xyz_ao(op_rmd_ao,qs_env,minimum_image=.FALSE.) !************************************************************ ! ! Since many psi0 vector can have the same center, depending on how the center is selected, @@ -234,29 +231,28 @@ SUBROUTINE current_operators(current_env,qs_env,error) ! ! prepare for allocation ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) ! ! - CALL cp_dbcsr_allocate_matrix_set(op_ao,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(op_ao,3) ALLOCATE(op_ao(1)%matrix,op_ao(2)%matrix,op_ao(3)%matrix) - CALL cp_dbcsr_init (op_ao(1)%matrix, error=error) - CALL cp_dbcsr_init (op_ao(2)%matrix, error=error) - CALL cp_dbcsr_init (op_ao(3)%matrix, error=error) + CALL cp_dbcsr_init (op_ao(1)%matrix) + CALL cp_dbcsr_init (op_ao(2)%matrix) + CALL cp_dbcsr_init (op_ao(3)%matrix) CALL cp_dbcsr_create(matrix=op_ao(1)%matrix, & name="op_ao", & dist=dbcsr_dist, matrix_type=dbcsr_type_no_symmetry,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(op_ao(1)%matrix,sab_all,error=error) - CALL cp_dbcsr_set(op_ao(1)%matrix,0.0_dp,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(op_ao(1)%matrix,sab_all) + CALL cp_dbcsr_set(op_ao(1)%matrix,0.0_dp) DO idir=2,3 CALL cp_dbcsr_copy(op_ao(idir)%matrix,op_ao(1)%matrix,& - "op_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir))),error=error) - CALL cp_dbcsr_set(op_ao(idir)%matrix,0.0_dp,error=error) + "op_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir)))) + CALL cp_dbcsr_set(op_ao(idir)%matrix,0.0_dp) ENDDO @@ -264,27 +260,27 @@ SUBROUTINE current_operators(current_env,qs_env,error) DO ispin = 1,nspins mo_coeff => psi0_order(ispin)%matrix nmo = nstates(ispin) - CALL cp_fm_set_all(p_psi0(ispin,1)%matrix,0.0_dp,error=error) - CALL cp_fm_set_all(p_psi0(ispin,2)%matrix,0.0_dp,error=error) - CALL cp_fm_set_all(p_psi0(ispin,3)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(p_psi0(ispin,1)%matrix,0.0_dp) + CALL cp_fm_set_all(p_psi0(ispin,2)%matrix,0.0_dp) + CALL cp_fm_set_all(p_psi0(ispin,3)%matrix,0.0_dp) DO icenter = 1,nbr_center(ispin) - CALL cp_dbcsr_set(op_ao(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(op_ao(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(op_ao(3)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(op_ao(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(op_ao(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(op_ao(3)%matrix,0.0_dp) !CALL rmc_x_p_xyz_ao(op_ao,qs_env,minimum_image=.FALSE.,& - ! & wancen=centers_set(ispin)%array(1:3,icenter),& - ! & error=error) - CALL build_ang_mom_matrix(qs_env,op_ao,centers_set(ispin)%array(1:3,icenter),error) + ! & wancen=centers_set(ispin)%array(1:3,icenter)) + ! & + CALL build_ang_mom_matrix(qs_env,op_ao,centers_set(ispin)%array(1:3,icenter)) ! ! accumulate checksums - chk(1) = chk(1)+cp_dbcsr_checksum(op_ao(1)%matrix,error=error) - chk(2) = chk(2)+cp_dbcsr_checksum(op_ao(2)%matrix,error=error) - chk(3) = chk(3)+cp_dbcsr_checksum(op_ao(3)%matrix,error=error) + chk(1) = chk(1)+cp_dbcsr_checksum(op_ao(1)%matrix) + chk(2) = chk(2)+cp_dbcsr_checksum(op_ao(2)%matrix) + chk(3) = chk(3)+cp_dbcsr_checksum(op_ao(3)%matrix) DO idir = 1,3 - CALL cp_fm_set_all(rxp_psi0(ispin,idir)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(rxp_psi0(ispin,idir)%matrix,0.0_dp) CALL cp_dbcsr_sm_fm_multiply(op_ao(idir)%matrix,mo_coeff,& rxp_psi0(ispin,idir)%matrix,ncol=nmo,& - alpha=-1.0_dp,error=error) + alpha=-1.0_dp) DO j = center_list(ispin)%array(1,icenter),center_list(ispin)%array(1,icenter+1)-1 istate = center_list(ispin)%array(2,j) ! the p_psi0 fm is used as temporary matrix to store the results for the psi0 centered in dk @@ -293,12 +289,12 @@ SUBROUTINE current_operators(current_env,qs_env,error) ENDDO END DO ENDDO - CALL cp_fm_to_fm(p_psi0(ispin,1)%matrix,rxp_psi0(ispin,1)%matrix,error) - CALL cp_fm_to_fm(p_psi0(ispin,2)%matrix,rxp_psi0(ispin,2)%matrix,error) - CALL cp_fm_to_fm(p_psi0(ispin,3)%matrix,rxp_psi0(ispin,3)%matrix,error) + CALL cp_fm_to_fm(p_psi0(ispin,1)%matrix,rxp_psi0(ispin,1)%matrix) + CALL cp_fm_to_fm(p_psi0(ispin,2)%matrix,rxp_psi0(ispin,2)%matrix) + CALL cp_fm_to_fm(p_psi0(ispin,3)%matrix,rxp_psi0(ispin,3)%matrix) ENDDO ! - CALL cp_dbcsr_deallocate_matrix_set(op_ao,error=error) + CALL cp_dbcsr_deallocate_matrix_set(op_ao) ! ! print checksums IF(output_unit>0) THEN @@ -308,34 +304,33 @@ SUBROUTINE current_operators(current_env,qs_env,error) ENDIF ! ! Calculate the px py pz operators - CALL cp_dbcsr_allocate_matrix_set(op_ao,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(op_ao,3) ALLOCATE(op_ao(1)%matrix,op_ao(2)%matrix,op_ao(3)%matrix) - CALL cp_dbcsr_init (op_ao(1)%matrix, error=error) - CALL cp_dbcsr_init (op_ao(2)%matrix, error=error) - CALL cp_dbcsr_init (op_ao(3)%matrix, error=error) + CALL cp_dbcsr_init (op_ao(1)%matrix) + CALL cp_dbcsr_init (op_ao(2)%matrix) + CALL cp_dbcsr_init (op_ao(3)%matrix) CALL cp_dbcsr_create(matrix=op_ao(1)%matrix, & name="op_ao", & dist=dbcsr_dist, matrix_type=dbcsr_type_antisymmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(op_ao(1)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(op_ao(1)%matrix,0.0_dp,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(op_ao(1)%matrix,sab_orb) + CALL cp_dbcsr_set(op_ao(1)%matrix,0.0_dp) DO idir=2,3 CALL cp_dbcsr_copy(op_ao(idir)%matrix,op_ao(1)%matrix,& - "op_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir))),error=error) - CALL cp_dbcsr_set(op_ao(idir)%matrix,0.0_dp,error=error) + "op_ao"//"-"//TRIM(ADJUSTL(cp_to_string(idir)))) + CALL cp_dbcsr_set(op_ao(idir)%matrix,0.0_dp) ENDDO ! - CALL build_lin_mom_matrix(qs_env,op_ao,error) - !CALL p_xyz_ao(op_ao,qs_env,minimum_image=.FALSE.,error=error) + CALL build_lin_mom_matrix(qs_env,op_ao) + !CALL p_xyz_ao(op_ao,qs_env,minimum_image=.FALSE.) ! ! print checksums - chk(1) = cp_dbcsr_checksum(op_ao(1)%matrix,error=error) - chk(2) = cp_dbcsr_checksum(op_ao(2)%matrix,error=error) - chk(3) = cp_dbcsr_checksum(op_ao(3)%matrix,error=error) + chk(1) = cp_dbcsr_checksum(op_ao(1)%matrix) + chk(2) = cp_dbcsr_checksum(op_ao(2)%matrix) + chk(3) = cp_dbcsr_checksum(op_ao(3)%matrix) IF(output_unit>0) THEN WRITE(output_unit,'(T2,A,E23.16)') 'CURRENT| current_operators: CheckSum P_x =',chk(1) WRITE(output_unit,'(T2,A,E23.16)') 'CURRENT| current_operators: CheckSum P_y =',chk(2) @@ -346,17 +341,17 @@ SUBROUTINE current_operators(current_env,qs_env,error) DO ispin = 1,nspins mo_coeff => psi0_order(ispin)%matrix nmo = nstates(ispin) - CALL cp_fm_set_all(p_psi0(ispin,idir)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(p_psi0(ispin,idir)%matrix,0.0_dp) CALL cp_dbcsr_sm_fm_multiply(op_ao(idir)%matrix,mo_coeff,& p_psi0(ispin,idir)%matrix,ncol=nmo,& - alpha=-1.0_dp,error=error) + alpha=-1.0_dp) END DO END DO ! - CALL cp_dbcsr_deallocate_matrix_set(op_ao,error=error) + CALL cp_dbcsr_deallocate_matrix_set(op_ao) ! CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This part is not necessary with the present implementation @@ -369,9 +364,9 @@ SUBROUTINE current_operators(current_env,qs_env,error) !DO ispin = 1,nspins ! CALL get_mo_set(mos(ispin)%mo_set, mo_coeff=mo_coeff, nmo=nmo, homo=homo) ! DO idir = 1,3 - ! CALL cp_fm_set_all(rxp_psi0(ispin,idir)%matrix,0.0_dp,error=error) + ! CALL cp_fm_set_all(rxp_psi0(ispin,idir)%matrix,0.0_dp) ! CALL cp_sm_fm_multiply(op_rmd_ao(idir)%matrix,mo_coeff,& - ! rxp_psi0(ispin,idir)%matrix,ncol=nmo,alpha=-1.0_dp,error=error) + ! rxp_psi0(ispin,idir)%matrix,ncol=nmo,alpha=-1.0_dp) ! END DO !END DO @@ -388,18 +383,18 @@ SUBROUTINE current_operators(current_env,qs_env,error) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=nmo,para_env=para_env,& - context=mo_coeff%matrix_struct%context,error=error) + context=mo_coeff%matrix_struct%context) DO idir = 1,3 NULLIFY(fm_Rmd_mos(idir)%matrix) - CALL cp_fm_create(fm_Rmd_mos(idir)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(fm_Rmd_mos(idir)%matrix,tmp_fm_struct) END DO - CALL cp_fm_create (fm_work1,tmp_fm_struct,error=error) - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + CALL cp_fm_create (fm_work1,tmp_fm_struct) + CALL cp_fm_struct_release ( tmp_fm_struct) ! This part should be done better, using the full matrix distribution DO istate = 1,nmo CALL cp_fm_get_submatrix(psi0_order(ispin)%matrix,vecbuf_c0,1,istate,nao,1,& - transpose=.TRUE.,error=error) + transpose=.TRUE.) !center of the localized psi0 state istate dk(1:3) = centers_set(ispin)%array(1:3,istate) DO idir = 1,3 @@ -410,7 +405,7 @@ SUBROUTINE current_operators(current_env,qs_env,error) vecbuf_Rmdc0(idir)%array(1,iao) = vecbuf_c0(1,iao)*ckdk(idir) END DO ! iao CALL cp_fm_set_submatrix(fm_Rmd_mos(idir)%matrix,vecbuf_Rmdc0(idir)%array,& - 1,istate,nao,1,transpose=.TRUE.,error=error) + 1,istate,nao,1,transpose=.TRUE.) END DO ! idir END DO ! istate @@ -418,24 +413,24 @@ SUBROUTINE current_operators(current_env,qs_env,error) CALL set_vecp(idir,ii,iii) !Add the second term to the idir component - CALL cp_fm_set_all(fm_work1,0.0_dp,error=error) + CALL cp_fm_set_all(fm_work1,0.0_dp) CALL cp_dbcsr_sm_fm_multiply(op_ao(iii)%matrix,fm_Rmd_mos(ii)%matrix,& - fm_work1,ncol=nmo,alpha=-1.0_dp,error=error) + fm_work1,ncol=nmo,alpha=-1.0_dp) CALL cp_fm_scale_and_add(1.0_dp,rxp_psi0(ispin,idir)%matrix,& - 1.0_dp, fm_work1,error=error) + 1.0_dp, fm_work1) - CALL cp_fm_set_all(fm_work1,0.0_dp,error=error) + CALL cp_fm_set_all(fm_work1,0.0_dp) CALL cp_dbcsr_sm_fm_multiply(op_ao(ii)%matrix,fm_Rmd_mos(iii)%matrix,& - fm_work1,ncol=nmo,alpha=-1.0_dp,error=error) + fm_work1,ncol=nmo,alpha=-1.0_dp) CALL cp_fm_scale_and_add(1.0_dp,rxp_psi0(ispin,idir)%matrix,& - -1.0_dp,fm_work1,error=error) + -1.0_dp,fm_work1) END DO ! idir DO idir = 1,3 - CALL cp_fm_release (fm_Rmd_mos(idir)%matrix,error=error) + CALL cp_fm_release (fm_Rmd_mos(idir)%matrix) END DO - CALL cp_fm_release (fm_work1,error=error) + CALL cp_fm_release (fm_work1) END DO ! ispin ENDIF @@ -443,13 +438,13 @@ SUBROUTINE current_operators(current_env,qs_env,error) DEALLOCATE(row_blk_sizes) DEALLOCATE (first_sgf,last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(vecbuf_c0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO idir = 1,3 DEALLOCATE(vecbuf_Rmdc0(idir)%array,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO CALL timestop(handle) @@ -461,14 +456,12 @@ END SUBROUTINE current_operators !> \param issc_env ... !> \param qs_env ... !> \param iatom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) + SUBROUTINE issc_operators(issc_env,qs_env,iatom) TYPE(issc_env_type) :: issc_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: iatom - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'issc_operators', & routineP = moduleN//':'//routineN @@ -506,12 +499,12 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) NULLIFY(matrix_fc,matrix_pso,matrix_efg) NULLIFY(efg_psi0,pso_psi0,fc_psi0) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() lr_section => section_vals_get_subs_vals(qs_env%input,& - "PROPERTIES%LINRES",error=error) + "PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") CALL get_qs_env(qs_env=qs_env, & qs_kind_set=qs_kind_set, & @@ -520,8 +513,7 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) linres_control=linres_control, & para_env=para_env, & mos=mos,& - particle_set=particle_set, & - error=error) + particle_set=particle_set) nspins = dft_control%nspins @@ -537,8 +529,7 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) do_fc=do_fc,& do_sd=do_sd,& do_pso=do_pso,& - do_dso=do_dso,& - error=error) + do_dso=do_dso) ! ! r_i = particle_set(iatom)%r !pbc(particle_set(iatom)%r,cell) @@ -550,10 +541,10 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) ! Fermi contact integral !IF(do_fc) THEN IF(.TRUE.) THEN ! for the moment we build it (regs) - CALL cp_dbcsr_set(matrix_fc(1)%matrix,0.0_dp,error=error) - CALL build_fermi_contact_matrix(qs_env,matrix_fc,r_i,error) + CALL cp_dbcsr_set(matrix_fc(1)%matrix,0.0_dp) + CALL build_fermi_contact_matrix(qs_env,matrix_fc,r_i) - chk(1) = cp_dbcsr_checksum(matrix_fc(1)%matrix,error=error) + chk(1) = cp_dbcsr_checksum(matrix_fc(1)%matrix) IF(output_unit>0) THEN WRITE(output_unit,'(T2,A,E23.16)') 'ISSC| fermi_contact: CheckSum =',chk(1) @@ -563,14 +554,14 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) ! spin-orbit integral !IF(do_pso) THEN IF(.TRUE.) THEN ! for the moment we build it (regs) - CALL cp_dbcsr_set(matrix_pso(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_pso(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_pso(3)%matrix,0.0_dp,error=error) - CALL build_pso_matrix(qs_env,matrix_pso,r_i,error) + CALL cp_dbcsr_set(matrix_pso(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_pso(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_pso(3)%matrix,0.0_dp) + CALL build_pso_matrix(qs_env,matrix_pso,r_i) - chk(2) = cp_dbcsr_checksum(matrix_pso(1)%matrix,error=error) - chk(3) = cp_dbcsr_checksum(matrix_pso(2)%matrix,error=error) - chk(4) = cp_dbcsr_checksum(matrix_pso(3)%matrix,error=error) + chk(2) = cp_dbcsr_checksum(matrix_pso(1)%matrix) + chk(3) = cp_dbcsr_checksum(matrix_pso(2)%matrix) + chk(4) = cp_dbcsr_checksum(matrix_pso(3)%matrix) IF(output_unit>0) THEN WRITE(output_unit,'(T2,A,E23.16)') 'ISSC| pso_x: CheckSum =',chk(2) @@ -582,20 +573,20 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) ! electric field integral !IF(do_sd) THEN IF(.TRUE.) THEN ! for the moment we build it (regs) - CALL cp_dbcsr_set(matrix_efg(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(3)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(4)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(5)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_efg(6)%matrix,0.0_dp,error=error) - CALL build_efg_matrix(qs_env,matrix_efg,r_i,error) - - chk(5) = cp_dbcsr_checksum(matrix_efg(1)%matrix,error=error) - chk(6) = cp_dbcsr_checksum(matrix_efg(2)%matrix,error=error) - chk(7) = cp_dbcsr_checksum(matrix_efg(3)%matrix,error=error) - chk(8) = cp_dbcsr_checksum(matrix_efg(4)%matrix,error=error) - chk(9) = cp_dbcsr_checksum(matrix_efg(5)%matrix,error=error) - chk(10)= cp_dbcsr_checksum(matrix_efg(6)%matrix,error=error) + CALL cp_dbcsr_set(matrix_efg(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(3)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(4)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(5)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_efg(6)%matrix,0.0_dp) + CALL build_efg_matrix(qs_env,matrix_efg,r_i) + + chk(5) = cp_dbcsr_checksum(matrix_efg(1)%matrix) + chk(6) = cp_dbcsr_checksum(matrix_efg(2)%matrix) + chk(7) = cp_dbcsr_checksum(matrix_efg(3)%matrix) + chk(8) = cp_dbcsr_checksum(matrix_efg(4)%matrix) + chk(9) = cp_dbcsr_checksum(matrix_efg(5)%matrix) + chk(10)= cp_dbcsr_checksum(matrix_efg(6)%matrix) IF(output_unit>0) THEN WRITE(output_unit,'(T2,A,E23.16)') 'ISSC| efg (3xx-rr)/3: CheckSum =',chk(5) @@ -614,24 +605,24 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) ! !>>> debugging only here we build the dipole matrix... debugging the kernel... IF(do_dso) THEN - CALL cp_dbcsr_set(matrix_dso(1)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_dso(2)%matrix,0.0_dp,error=error) - CALL cp_dbcsr_set(matrix_dso(3)%matrix,0.0_dp,error=error) - CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1,error=error) + CALL cp_dbcsr_set(matrix_dso(1)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_dso(2)%matrix,0.0_dp) + CALL cp_dbcsr_set(matrix_dso(3)%matrix,0.0_dp) + CALL rRc_xyz_ao(matrix_dso,qs_env,(/0.0_dp,0.0_dp,0.0_dp/),1) ENDIF ! ! multiply by the mos DO ispin = 1,nspins ! CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,ncol_global=nmo,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=nmo) ! ! EFG IF(do_sd) THEN DO idir = 1,6 CALL cp_dbcsr_sm_fm_multiply(matrix_efg(idir)%matrix,mo_coeff,& efg_psi0(ispin,idir)%matrix,ncol=nmo,& - alpha=1.0_dp,error=error) + alpha=1.0_dp) ENDDO ENDIF ! @@ -640,7 +631,7 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) DO idir = 1,3 CALL cp_dbcsr_sm_fm_multiply(matrix_pso(idir)%matrix,mo_coeff,& pso_psi0(ispin,idir)%matrix,ncol=nmo,& - alpha=-1.0_dp,error=error) + alpha=-1.0_dp) ENDDO ENDIF ! @@ -648,7 +639,7 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) IF(do_fc) THEN CALL cp_dbcsr_sm_fm_multiply(matrix_fc(1)%matrix,mo_coeff,& fc_psi0(ispin)%matrix,ncol=nmo,& - alpha=1.0_dp,error=error) + alpha=1.0_dp) ENDIF ! !>>> for debugging only @@ -656,14 +647,14 @@ SUBROUTINE issc_operators(issc_env,qs_env,iatom,error) DO idir = 1,3 CALL cp_dbcsr_sm_fm_multiply(matrix_dso(idir)%matrix,mo_coeff,& dso_psi0(ispin,idir)%matrix,ncol=nmo,& - alpha=-1.0_dp,error=error) + alpha=-1.0_dp) ENDDO ENDIF !<<< for debugging only ENDDO CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -678,17 +669,15 @@ END SUBROUTINE issc_operators !> !> \param polar_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 01.2013 created [SL] !> \author SL ! ***************************************************************************** - SUBROUTINE polar_operators(polar_env,qs_env,error) + SUBROUTINE polar_operators(polar_env,qs_env) TYPE(polar_env_type) :: polar_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'polar_operators', & routineP = moduleN//':'//routineN @@ -729,20 +718,19 @@ SUBROUTINE polar_operators(polar_env,qs_env,error) NULLIFY(dBerry_psi0,inv_work,mo_derivs,& op_fm_set,opvec,sinmat,cosmat) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() lr_section => section_vals_get_subs_vals(qs_env%input,& - "PROPERTIES%LINRES",error=error) + "PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") NULLIFY ( cell, dft_control, mos, matrix_s) CALL get_qs_env(qs_env=qs_env, & cell=cell, & dft_control=dft_control, & para_env=para_env, & mos=mos,& - matrix_s=matrix_s, & - error=error) + matrix_s=matrix_s) nspins = dft_control%nspins @@ -750,15 +738,14 @@ SUBROUTINE polar_operators(polar_env,qs_env,error) CALL get_polar_env(polar_env=polar_env, & do_raman=do_raman, & dBerry_psi0=dBerry_psi0, & - mo_derivs=mo_derivs, & - error=error) + mo_derivs=mo_derivs) !SL calculate dipole berry phase IF(do_raman) THEN DO i= 1,3 DO ispin = 1,nspins - CALL cp_fm_set_all(dBerry_psi0(i,ispin)%matrix,0.0_dp,error=error) - CALL cp_fm_set_all(mo_derivs(i,ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(dBerry_psi0(i,ispin)%matrix,0.0_dp) + CALL cp_fm_set_all(mo_derivs(i,ispin)%matrix,0.0_dp) ENDDO END DO @@ -767,38 +754,33 @@ SUBROUTINE polar_operators(polar_env,qs_env,error) ! initialize all work matrices needed ALLOCATE ( opvec(2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( op_fm_set( 2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( eigrmat( dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( inv_mat(3, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( inv_work(2,3, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! A bit to allocate for the wavefunction DO ispin = 1, dft_control%nspins NULLIFY(tmp_fm_struct,mo_coeff) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff,nao=nao,nmo=nmo) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmo,& - ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context,& - error=error) + ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context) DO i = 1, SIZE ( op_fm_set, 1 ) - CALL cp_fm_create (opvec(i,ispin)%matrix , mo_coeff%matrix_struct ,error=error) + CALL cp_fm_create (opvec(i,ispin)%matrix , mo_coeff%matrix_struct) NULLIFY(op_fm_set(i,ispin)%matrix) - CALL cp_fm_create (op_fm_set(i,ispin)%matrix , tmp_fm_struct ,error=error) + CALL cp_fm_create (op_fm_set(i,ispin)%matrix , tmp_fm_struct) END DO - CALL cp_cfm_create ( eigrmat(ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ,& - error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_cfm_create ( eigrmat(ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ) + CALL cp_fm_struct_release(tmp_fm_struct) DO i=1,3 - CALL cp_cfm_create ( inv_mat(i,ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ,& - error=error) - CALL cp_fm_create ( inv_work(2,i,ispin)%matrix, op_fm_set(2,ispin)%matrix%matrix_struct ,& - error=error) - CALL cp_fm_create ( inv_work(1,i,ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ,& - error=error) + CALL cp_cfm_create ( inv_mat(i,ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ) + CALL cp_fm_create ( inv_work(2,i,ispin)%matrix, op_fm_set(2,ispin)%matrix%matrix_struct ) + CALL cp_fm_create ( inv_work(1,i,ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ) END DO END DO @@ -806,62 +788,62 @@ SUBROUTINE polar_operators(polar_env,qs_env,error) ! NULLIFY (cosmat, sinmat) ALLOCATE(cosmat, sinmat) - CALL cp_dbcsr_init(cosmat, error=error) - CALL cp_dbcsr_init(sinmat, error=error) - CALL cp_dbcsr_copy(cosmat,matrix_s(1)%matrix,'COS MOM',error=error) - CALL cp_dbcsr_copy(sinmat,matrix_s(1)%matrix,'SIN MOM',error=error) - CALL cp_dbcsr_set(cosmat,0.0_dp,error=error) - CALL cp_dbcsr_set(sinmat,0.0_dp,error=error) + CALL cp_dbcsr_init(cosmat) + CALL cp_dbcsr_init(sinmat) + CALL cp_dbcsr_copy(cosmat,matrix_s(1)%matrix,'COS MOM') + CALL cp_dbcsr_copy(sinmat,matrix_s(1)%matrix,'SIN MOM') + CALL cp_dbcsr_set(cosmat,0.0_dp) + CALL cp_dbcsr_set(sinmat,0.0_dp) DO i=1,3 kvec(:) = twopi*cell%h_inv(i,:) - CALL cp_dbcsr_set(cosmat,0.0_dp,error=error) - CALL cp_dbcsr_set(sinmat,0.0_dp,error=error) - CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) + CALL cp_dbcsr_set(cosmat,0.0_dp) + CALL cp_dbcsr_set(sinmat,0.0_dp) + CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec) DO ispin=1, dft_control%nspins ! spin CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,mo_coeff=mo_coeff,nmo=nmo) - CALL cp_dbcsr_sm_fm_multiply(cosmat, mo_coeff, opvec(1,ispin)%matrix, ncol=nmo, error=error) + CALL cp_dbcsr_sm_fm_multiply(cosmat, mo_coeff, opvec(1,ispin)%matrix, ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff,opvec(1,ispin)%matrix,0.0_dp,& - op_fm_set(1,ispin)%matrix,error=error) - CALL cp_dbcsr_sm_fm_multiply(sinmat, mo_coeff, opvec(2,ispin)%matrix, ncol=nmo, error=error) + op_fm_set(1,ispin)%matrix) + CALL cp_dbcsr_sm_fm_multiply(sinmat, mo_coeff, opvec(2,ispin)%matrix, ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff,opvec(2,ispin)%matrix,0.0_dp,& - op_fm_set(2,ispin)%matrix,error=error) + op_fm_set(2,ispin)%matrix) ENDDO !second step invert C^T S_berry C zdet=one DO ispin = 1, dft_control%nspins - CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim,error=error) + CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim) DO idim=1,tmp_dim eigrmat(ispin)%matrix%local_data(:,idim) = & CMPLX (op_fm_set(1,ispin)%matrix%local_data(:,idim), & -op_fm_set(2,ispin)%matrix%local_data(:,idim),dp) END DO - CALL cp_cfm_set_all (inv_mat(i,ispin)%matrix,zero,one,error) - CALL cp_cfm_solve ( eigrmat(ispin)%matrix,inv_mat(i,ispin)%matrix, zdeta,error ) + CALL cp_cfm_set_all (inv_mat(i,ispin)%matrix,zero,one) + CALL cp_cfm_solve ( eigrmat(ispin)%matrix,inv_mat(i,ispin)%matrix, zdeta) END DO ! ! !compute the derivative and add the result to mo_derivatives DO ispin=1,dft_control%nspins - CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim,error=error) + CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim) CALL get_mo_set(mo_set=mos(ispin)%mo_set,nao=nao,nmo=nmo,maxocc=maxocc) DO z=1,tmp_dim inv_work(1,i,ispin)%matrix%local_data(:,z)=REAL(inv_mat(i,ispin)%matrix%local_data(:,z),dp) inv_work(2,i,ispin)%matrix%local_data(:,z)=AIMAG(inv_mat(i,ispin)%matrix%local_data(:,z)) END DO CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,opvec(1,ispin)%matrix,inv_work(2,i,ispin)%matrix,& - 0.0_dp,mo_derivs(i,ispin)%matrix,error) + 0.0_dp,mo_derivs(i,ispin)%matrix) CALL cp_gemm("N","N",nao,nmo,nmo,-1.0_dp,opvec(2,ispin)%matrix,inv_work(1,i,ispin)%matrix,& - 1.0_dp,mo_derivs(i,ispin)%matrix,error) + 1.0_dp,mo_derivs(i,ispin)%matrix) CALL cp_gemm("N","N",nao,nmo,nmo,-1.0_dp,opvec(1,ispin)%matrix,inv_work(2,i,ispin)%matrix,& - 0.0_dp,dBerry_psi0(i,ispin)%matrix,error) + 0.0_dp,dBerry_psi0(i,ispin)%matrix) CALL cp_gemm("N","N",nao,nmo,nmo,1.0_dp,opvec(2,ispin)%matrix,inv_work(1,i,ispin)%matrix,& - 1.0_dp,dBerry_psi0(i,ispin)%matrix,error) + 1.0_dp,dBerry_psi0(i,ispin)%matrix) END DO @@ -869,40 +851,40 @@ SUBROUTINE polar_operators(polar_env,qs_env,error) !SL we omit here the multiplication with hmat (this scaling back done at the end of the response calc) DO ispin=1,dft_control%nspins - CALL cp_cfm_release(eigrmat(ispin)%matrix,error=error) + CALL cp_cfm_release(eigrmat(ispin)%matrix) DO i=1,3 - CALL cp_cfm_release(inv_mat(i,ispin)%matrix,error=error) - CALL cp_fm_release(inv_work(1,i,ispin)%matrix,error=error) - CALL cp_fm_release(inv_work(2,i,ispin)%matrix,error=error) + CALL cp_cfm_release(inv_mat(i,ispin)%matrix) + CALL cp_fm_release(inv_work(1,i,ispin)%matrix) + CALL cp_fm_release(inv_work(2,i,ispin)%matrix) END DO - CALL cp_fm_release(opvec(1,ispin)%matrix,error=error) - CALL cp_fm_release(opvec(2,ispin)%matrix,error=error) - CALL cp_fm_release(op_fm_set(2,ispin)%matrix,error=error) - CALL cp_fm_release(op_fm_set(1,ispin)%matrix,error=error) + CALL cp_fm_release(opvec(1,ispin)%matrix) + CALL cp_fm_release(opvec(2,ispin)%matrix) + CALL cp_fm_release(op_fm_set(2,ispin)%matrix) + CALL cp_fm_release(op_fm_set(1,ispin)%matrix) END DO - CALL cp_dbcsr_deallocate_matrix ( cosmat, error=error ) - CALL cp_dbcsr_deallocate_matrix ( sinmat, error=error ) + CALL cp_dbcsr_deallocate_matrix ( cosmat) + CALL cp_dbcsr_deallocate_matrix ( sinmat) DEALLOCATE ( inv_work, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE ( opvec, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE ( op_fm_set, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE ( eigrmat, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE ( inv_mat, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! raman CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -1017,16 +999,14 @@ END SUBROUTINE set_vecp_rev !> \param rc ... !> \param cell ... !> \param ixyz ... -!> \param error ... !> \author vw ! ***************************************************************************** - SUBROUTINE fm_scale_by_pbc_AC(matrix,ra,rc,cell,ixyz,error) + SUBROUTINE fm_scale_by_pbc_AC(matrix,ra,rc,cell,ixyz) TYPE(cp_fm_type), POINTER :: matrix REAL(KIND=dp), DIMENSION(:, :), & INTENT(in) :: ra, rc TYPE(cell_type), POINTER :: cell INTEGER, INTENT(IN) :: ixyz - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_scale_by_pbc_AC', & routineP = moduleN//':'//routineN diff --git a/src/qs_linres_polar_utils.F b/src/qs_linres_polar_utils.F index ba6660f59c..0c3e65d8b2 100644 --- a/src/qs_linres_polar_utils.F +++ b/src/qs_linres_polar_utils.F @@ -74,14 +74,12 @@ MODULE qs_linres_polar_utils !> \param polar_env ... !> \param p_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE polar_response(polar_env,p_env,qs_env,error) + SUBROUTINE polar_response(polar_env,p_env,qs_env) TYPE(polar_env_type) :: polar_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'polar_response', & routineP = moduleN//':'//routineN @@ -112,13 +110,13 @@ SUBROUTINE polar_response(polar_env,p_env,qs_env,error) NULLIFY(logger, mpools, psi1, h1_psi0, mo_coeff, para_env) NULLIFY(tmp_fm_struct, psi1_dBerry,dBerry_psi0) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") polar_section => section_vals_get_subs_vals(qs_env%input, & - "PROPERTIES%LINRES%POLAR",error=error) + "PROPERTIES%LINRES%POLAR") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(T10,A,/)")& "*** Self consistent optimization of the response wavefunctions ***" @@ -129,69 +127,65 @@ SUBROUTINE polar_response(polar_env,p_env,qs_env,error) mpools=mpools,& linres_control=linres_control,& mos=mos,& - para_env=para_env,& - error=error) + para_env=para_env) nspins = dft_control%nspins CALL get_polar_env(polar_env=polar_env, & - do_raman=do_raman, & - error=error) + do_raman=do_raman) ! ! allocate the vectors ALLOCATE(psi0_order(nspins)) ALLOCATE(psi1(nspins),h1_psi0(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) psi0_order(ispin)%matrix => mo_coeff - CALL cp_fm_get_info(mo_coeff,ncol_global=nmo,nrow_global=nao,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=nmo,nrow_global=nao) NULLIFY(tmp_fm_struct,psi1(ispin)%matrix,h1_psi0(ispin)%matrix) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=nmo,& - context=mo_coeff%matrix_struct%context,& - error=error) - CALL cp_fm_create(psi1(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(h1_psi0(ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(psi1(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create(h1_psi0(ispin)%matrix,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) ENDDO chk = 0.0_dp ! IF(do_raman) THEN CALL get_polar_env(polar_env=polar_env, & psi1_dBerry=psi1_dBerry, & - dBerry_psi0=dBerry_psi0, & - error=error) + dBerry_psi0=dBerry_psi0) DO idir = 1,3 IF(output_unit>0) THEN WRITE(output_unit,"(T10,A)") & "Response to the perturbation operator Berry phase_"//ACHAR(idir+119) ENDIF DO ispin = 1,nspins - CALL cp_fm_set_all(psi1_dBerry(idir,ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1_dBerry(idir,ispin)%matrix,0.0_dp) ENDDO ! !Initial guess for psi1 DO ispin = 1,nspins - CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_set_all(psi1(ispin)%matrix,0.0_dp) ENDDO ! !DO scf cycle to optimize psi1 DO ispin = 1,nspins - CALL cp_fm_to_fm(dBerry_psi0(idir,ispin)%matrix,h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_to_fm(dBerry_psi0(idir,ispin)%matrix,h1_psi0(ispin)%matrix) ENDDO ! ! linres_control%lr_triplet = .FALSE. ! we do singlet response linres_control%do_kernel = .TRUE. ! we do coupled response linres_control%converged = .FALSE. - CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order, should_stop,error=error) + CALL linres_solver(p_env,qs_env,psi1,h1_psi0,psi0_order, should_stop) ! ! ! copy the response DO ispin=1,nspins - CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_dBerry(idir,ispin)%matrix,error=error) - CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro,error=error) + CALL cp_fm_to_fm(psi1(ispin)%matrix,psi1_dBerry(idir,ispin)%matrix) + CALL cp_fm_frobenius_norm(psi1(ispin)%matrix,fro) chk = chk + fro ENDDO ! @@ -212,14 +206,14 @@ SUBROUTINE polar_response(polar_env,p_env,qs_env,error) ! ! clean up DO ispin = 1,nspins - CALL cp_fm_release(psi1(ispin)%matrix,error=error) - CALL cp_fm_release(h1_psi0(ispin)%matrix,error=error) + CALL cp_fm_release(psi1(ispin)%matrix) + CALL cp_fm_release(h1_psi0(ispin)%matrix) ENDDO DEALLOCATE(psi1,h1_psi0,psi0_order,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") ! CALL timestop(handle) ! @@ -230,13 +224,11 @@ END SUBROUTINE polar_response !> \brief ... !> \param polar_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE polar_polar(polar_env,qs_env,error) + SUBROUTINE polar_polar(polar_env,qs_env) TYPE(polar_env_type) :: polar_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'polar_polar', & routineP = moduleN//':'//routineN @@ -259,20 +251,18 @@ SUBROUTINE polar_polar(polar_env,qs_env,error) NULLIFY(cell,dft_control,polar,psi1_dBerry,logger) NULLIFY(mos, dBerry_psi0, mo_derivs) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) CALL get_qs_env(qs_env=qs_env,& cell=cell,& dft_control=dft_control,& - mos=mos,& - error=error) + mos=mos) nspins = dft_control%nspins CALL get_polar_env(polar_env=polar_env,& - do_raman=do_raman, & - error=error) + do_raman=do_raman) ! IF(do_raman) THEN @@ -282,23 +272,22 @@ SUBROUTINE polar_polar(polar_env,qs_env,error) psi1_dBerry=psi1_dBerry, & dBerry_psi0=dBerry_psi0, & polar=polar, & - mo_derivs=mo_derivs, & - error=error) + mo_derivs=mo_derivs) ! ! ! polar_section => section_vals_get_subs_vals(qs_env%input, & -! & "PROPERTIES%LINRES%POLAR",error=error) +! & "PROPERTIES%LINRES%POLAR") ! ! Initialize ALLOCATE ( polar_tmp( 3, 3), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) polar_tmp(:,:)=0.0_dp DO i = 1,3 ! directions of electric field DO z=1,3 !dipole directions DO ispin=1,dft_control%nspins !SL compute trace - CALL cp_fm_trace(psi1_dBerry(i,ispin)%matrix,mo_derivs(z,ispin)%matrix,polar_tmp(i,z),error=error) + CALL cp_fm_trace(psi1_dBerry(i,ispin)%matrix,mo_derivs(z,ispin)%matrix,polar_tmp(i,z)) polar_tmp(i,z)=polar_tmp(i,z) + polar_tmp(i,z) END DO polar_tmp(i,z) = polar_tmp(i,z)/(twopi * twopi) @@ -314,7 +303,7 @@ SUBROUTINE polar_polar(polar_env,qs_env,error) ! IF(ASSOCIATED(polar_tmp)) THEN DEALLOCATE(polar_tmp, STAT = istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ENDIF !raman @@ -328,12 +317,10 @@ END SUBROUTINE polar_polar !> \brief ... !> \param polar_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE polar_print(polar_env,qs_env,error) + SUBROUTINE polar_print(polar_env,qs_env) TYPE(polar_env_type) :: polar_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'polar_print', & routineP = moduleN//':'//routineN @@ -352,27 +339,26 @@ SUBROUTINE polar_print(polar_env,qs_env,error) NULLIFY(logger,dft_control,para_env,results) CALL get_qs_env(qs_env=qs_env, results=results, dft_control=dft_control,& - para_env=para_env, error=error) + para_env=para_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) polar_section => section_vals_get_subs_vals(qs_env%input, & - "PROPERTIES%LINRES%POLAR",error=error) + "PROPERTIES%LINRES%POLAR") - CALL get_polar_env(polar_env=polar_env, polar=polar, do_raman=do_raman, error=error) + CALL get_polar_env(polar_env=polar_env, polar=polar, do_raman=do_raman) description = "[POLAR]" - CALL cp_results_erase(results,description=description,error=error) - CALL put_results(results,description=description,values=polar(:,:),error=error) + CALL cp_results_erase(results,description=description) + CALL put_results(results,description=description,values=polar(:,:)) IF(do_raman) THEN IF(BTEST(cp_print_key_should_output(logger%iter_info,polar_section,& - "PRINT%POLAR_MATRIX",error=error),cp_p_file)) THEN + "PRINT%POLAR_MATRIX"),cp_p_file)) THEN unit_p=cp_print_key_unit_nr(logger,polar_section,"PRINT%POLAR_MATRIX",& - extension=".data",middle_name="raman",log_filename=.FALSE.,& - error=error) + extension=".data",middle_name="raman",log_filename=.FALSE.) IF(unit_p>0) THEN IF(unit_p/=output_unit) THEN WRITE(unit_p,*) @@ -388,7 +374,7 @@ SUBROUTINE polar_print(polar_env,qs_env,error) WRITE (unit_p,'(T10,A,3F15.5)')"yx,zx,zy",polar(2,1)*angstrom**3,& polar(3,1)*angstrom**3,polar(3,2)*angstrom**3 CALL cp_print_key_finished_output(unit_p,logger,polar_section, & - "PRINT%POLAR_MATRIX",error=error) + "PRINT%POLAR_MATRIX") ENDIF ENDIF ENDIF @@ -416,13 +402,11 @@ END SUBROUTINE polar_print !> \brief Initialize the polar environment !> \param polar_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE polar_env_init(polar_env,qs_env,error) + SUBROUTINE polar_env_init(polar_env,qs_env) ! TYPE(polar_env_type) :: polar_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'polar_env_init', & routineP = moduleN//':'//routineN @@ -451,15 +435,15 @@ SUBROUTINE polar_env_init(polar_env,qs_env,error) NULLIFY(linres_control) NULLIFY(logger,polar_section) - logger => cp_error_get_logger(error) - lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES",error=error) + logger => cp_get_default_logger() + lr_section => section_vals_get_subs_vals(qs_env%input,"PROPERTIES%LINRES") output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF(polar_env%ref_count /= 0) THEN - CALL polar_env_cleanup(polar_env,error=error) + CALL polar_env_cleanup(polar_env) ENDIF IF(output_unit>0) THEN @@ -467,56 +451,54 @@ SUBROUTINE polar_env_init(polar_env,qs_env,error) WRITE(output_unit,"(T10,A,/)") "Initialization of the polar environment" ENDIF - CALL polar_env_create(polar_env,error=error) + CALL polar_env_create(polar_env) ! polar_section => section_vals_get_subs_vals(qs_env%input, & - "PROPERTIES%LINRES%POLAR",error=error) + "PROPERTIES%LINRES%POLAR") CALL get_qs_env(qs_env=qs_env,& dft_control=dft_control,& matrix_s=matrix_s, & linres_control=linres_control,& - mos=mos,& - error=error) + mos=mos) ! ! nspins = dft_control%nspins ! - CALL section_vals_val_get(polar_section,"DO_RAMAN",l_val=polar_env%do_raman,error=error) + CALL section_vals_val_get(polar_section,"DO_RAMAN",l_val=polar_env%do_raman) ! ! ! ALLOCATE(polar_env%polar(3,3), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) polar_env%polar(:,:) = 0.0_dp ! ! allocation ALLOCATE(polar_env%dBerry_psi0(3,nspins), & polar_env%psi1_dBerry(3,nspins), polar_env%mo_derivs(3,nspins), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff,nao=nao,nmo=nmo) - CALL cp_fm_get_info(mo_coeff,ncol_global=m,nrow_global=nao,error=error) + CALL cp_fm_get_info(mo_coeff,ncol_global=m,nrow_global=nao) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=m,& - context=mo_coeff%matrix_struct%context,& - error=error) + context=mo_coeff%matrix_struct%context) DO idir = 1,3 NULLIFY(polar_env%psi1_dBerry(idir,ispin)%matrix,polar_env%dBerry_psi0(idir,ispin)%matrix,& polar_env%mo_derivs(idir,ispin)%matrix) - CALL cp_fm_create(polar_env%psi1_dBerry(idir,ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(polar_env%dBerry_psi0(idir,ispin)%matrix,tmp_fm_struct,error=error) - CALL cp_fm_create(polar_env%mo_derivs(idir,ispin)%matrix,tmp_fm_struct,error=error) + CALL cp_fm_create(polar_env%psi1_dBerry(idir,ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create(polar_env%dBerry_psi0(idir,ispin)%matrix,tmp_fm_struct) + CALL cp_fm_create(polar_env%mo_derivs(idir,ispin)%matrix,tmp_fm_struct) ENDDO - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_fm_struct_release(tmp_fm_struct) ! END DO CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -525,13 +507,11 @@ END SUBROUTINE polar_env_init ! ***************************************************************************** !> \brief Deallocate the polar environment !> \param polar_env ... -!> \param error ... !> \par History ! ***************************************************************************** - SUBROUTINE polar_env_cleanup(polar_env,error) + SUBROUTINE polar_env_cleanup(polar_env) TYPE(polar_env_type) :: polar_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'polar_env_cleanup', & routineP = moduleN//':'//routineN @@ -545,34 +525,34 @@ SUBROUTINE polar_env_cleanup(polar_env,error) IF(polar_env%ref_count == 0 ) THEN IF(ASSOCIATED(polar_env%polar)) THEN DEALLOCATE(polar_env%polar,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(polar_env%dBerry_psi0)) THEN DO idir = 1,SIZE(polar_env%dBerry_psi0,1) DO ispin = 1,SIZE(polar_env%dBerry_psi0,2) - CALL cp_fm_release(polar_env%dBerry_psi0(idir,ispin)%matrix,error=error) + CALL cp_fm_release(polar_env%dBerry_psi0(idir,ispin)%matrix) ENDDO ENDDO DEALLOCATE(polar_env%dBerry_psi0,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(polar_env%mo_derivs)) THEN DO idir = 1,SIZE(polar_env%mo_derivs,1) DO ispin = 1,SIZE(polar_env%mo_derivs,2) - CALL cp_fm_release(polar_env%mo_derivs(idir,ispin)%matrix,error=error) + CALL cp_fm_release(polar_env%mo_derivs(idir,ispin)%matrix) ENDDO ENDDO DEALLOCATE(polar_env%mo_derivs,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(polar_env%psi1_dBerry)) THEN DO idir = 1,SIZE(polar_env%psi1_dBerry,1) DO ispin = 1,SIZE(polar_env%psi1_dBerry,2) - CALL cp_fm_release(polar_env%psi1_dBerry(idir,ispin)%matrix,error=error) + CALL cp_fm_release(polar_env%psi1_dBerry(idir,ispin)%matrix) ENDDO ENDDO DEALLOCATE(polar_env%psi1_dBerry,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ! diff --git a/src/qs_linres_types.F b/src/qs_linres_types.F index 19ecaed716..77ffa22cd2 100644 --- a/src/qs_linres_types.F +++ b/src/qs_linres_types.F @@ -237,12 +237,10 @@ MODULE qs_linres_types ! ***************************************************************************** !> \brief ... !> \param linres_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE linres_control_create(linres_control,error) + SUBROUTINE linres_control_create(linres_control) TYPE(linres_control_type), POINTER :: linres_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'linres_control_create', & routineP = moduleN//':'//routineN @@ -252,9 +250,9 @@ SUBROUTINE linres_control_create(linres_control,error) failure =.FALSE. - CPPrecondition(.NOT.ASSOCIATED(linres_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(linres_control),cp_failure_level,routineP,failure) ALLOCATE (linres_control,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) linres_control%ref_count=1 NULLIFY(linres_control%qs_loc_env) linres_control%property = HUGE(0)!is that used? @@ -275,12 +273,10 @@ END SUBROUTINE linres_control_create ! ***************************************************************************** !> \brief ... !> \param linres_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE linres_control_release(linres_control,error) + SUBROUTINE linres_control_release(linres_control) TYPE(linres_control_type), POINTER :: linres_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'linres_control_release', & routineP = moduleN//':'//routineN @@ -291,14 +287,14 @@ SUBROUTINE linres_control_release(linres_control,error) failure =.FALSE. IF (ASSOCIATED(linres_control)) THEN - CPPostcondition(linres_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPostcondition(linres_control%ref_count>0,cp_failure_level,routineP,failure) linres_control%ref_count=linres_control%ref_count-1 IF(linres_control%ref_count<1)THEN IF(ASSOCIATED(linres_control%qs_loc_env)) THEN - CALL qs_loc_env_release(linres_control%qs_loc_env, error=error) + CALL qs_loc_env_release(linres_control%qs_loc_env) END IF DEALLOCATE(linres_control,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF NULLIFY(linres_control) @@ -307,12 +303,10 @@ END SUBROUTINE linres_control_release ! ***************************************************************************** !> \brief ... !> \param linres_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE linres_control_retain(linres_control,error) + SUBROUTINE linres_control_retain(linres_control) TYPE(linres_control_type), POINTER :: linres_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'linres_control_retain', & routineP = moduleN//':'//routineN @@ -321,8 +315,8 @@ SUBROUTINE linres_control_retain(linres_control,error) failure =.FALSE. - CPPrecondition(ASSOCIATED(linres_control),cp_failure_level,routineP,error,failure) - CPPostcondition(linres_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(linres_control),cp_failure_level,routineP,failure) + CPPostcondition(linres_control%ref_count>0,cp_failure_level,routineP,failure) linres_control%ref_count=linres_control%ref_count+1 END SUBROUTINE linres_control_retain @@ -330,12 +324,10 @@ END SUBROUTINE linres_control_retain ! ***************************************************************************** !> \brief ... !> \param current_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE current_env_create(current_env,error) + SUBROUTINE current_env_create(current_env) TYPE(current_env_type) :: current_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'current_env_create', & routineP = moduleN//':'//routineN @@ -344,7 +336,7 @@ SUBROUTINE current_env_create(current_env,error) failure =.FALSE. - CPPrecondition(current_env%ref_count==0, cp_failure_level,routineP,error,failure) + CPPrecondition(current_env%ref_count==0, cp_failure_level,routineP,failure) current_env%ref_count = 1 current_env%nao = HUGE(1) current_env%gauge = HUGE(1) @@ -377,12 +369,10 @@ END SUBROUTINE current_env_create ! ***************************************************************************** !> \brief ... !> \param nmr_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE nmr_env_create(nmr_env,error) + SUBROUTINE nmr_env_create(nmr_env) TYPE(nmr_env_type) :: nmr_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nmr_env_create', & routineP = moduleN//':'//routineN @@ -391,7 +381,7 @@ SUBROUTINE nmr_env_create(nmr_env,error) failure =.FALSE. - CPPrecondition(nmr_env%ref_count==0, cp_failure_level,routineP,error,failure) + CPPrecondition(nmr_env%ref_count==0, cp_failure_level,routineP,failure) nmr_env%ref_count = 1 NULLIFY(nmr_env%chemical_shift) NULLIFY(nmr_env%chemical_shift_loc) @@ -406,12 +396,10 @@ END SUBROUTINE nmr_env_create ! ***************************************************************************** !> \brief ... !> \param issc_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE issc_env_create(issc_env,error) + SUBROUTINE issc_env_create(issc_env) TYPE(issc_env_type) :: issc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'issc_env_create', & routineP = moduleN//':'//routineN @@ -420,7 +408,7 @@ SUBROUTINE issc_env_create(issc_env,error) failure =.FALSE. - CPPrecondition(issc_env%ref_count==0, cp_failure_level,routineP,error,failure) + CPPrecondition(issc_env%ref_count==0, cp_failure_level,routineP,failure) issc_env%ref_count = 1 NULLIFY(issc_env%issc) NULLIFY(issc_env%issc_loc) @@ -442,13 +430,10 @@ END SUBROUTINE issc_env_create ! ***************************************************************************** !> \brief ... !> \param epr_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE epr_env_create(epr_env,error) + SUBROUTINE epr_env_create(epr_env) TYPE(epr_env_type) :: epr_env - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'epr_env_create', & routineP = moduleN//':'//routineN @@ -457,7 +442,7 @@ SUBROUTINE epr_env_create(epr_env,error) failure =.FALSE. - CPPrecondition(epr_env%ref_count==0, cp_failure_level,routineP,error,failure) + CPPrecondition(epr_env%ref_count==0, cp_failure_level,routineP,failure) epr_env%ref_count = 1 NULLIFY(epr_env%nablavks_set) NULLIFY(epr_env%nablavks_atom_set) @@ -501,14 +486,13 @@ END SUBROUTINE epr_env_create !> \param use_old_gauge_atom ... !> \param chi_pbc ... !> \param psi0_order ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_current_env(current_env,simple_done,simple_converged,full_done,ref_count,nao,& nstates,gauge,list_cubes,statetrueindex,gauge_name,basisfun_center,& nbr_center,center_list,centers_set,psi1_p,psi1_rxp,psi1_D,p_psi0,& rxp_psi0,jrho1_atom_set,jrho1_set,chi_tensor,& chi_tensor_loc,gauge_atom_radius,rs_gauge,use_old_gauge_atom,& - chi_pbc,psi0_order,error) + chi_pbc,psi0_order) TYPE(current_env_type), OPTIONAL :: current_env LOGICAL, OPTIONAL :: simple_done(6), & @@ -543,7 +527,6 @@ SUBROUTINE get_current_env(current_env,simple_done,simple_converged,full_done,re LOGICAL, OPTIONAL :: use_old_gauge_atom, chi_pbc TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: psi0_order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_current_env', & routineP = moduleN//':'//routineN @@ -555,7 +538,7 @@ SUBROUTINE get_current_env(current_env,simple_done,simple_converged,full_done,re failure =.FALSE. - CPPrecondition(current_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(current_env%ref_count>0, cp_failure_level,routineP,failure) IF(PRESENT(simple_done )) simple_done(1:6) = current_env%simple_done(1:6) IF(PRESENT(simple_converged)) simple_converged(1:6) = current_env%simple_converged(1:6) @@ -602,12 +585,11 @@ END SUBROUTINE get_current_env !> \param shift_gapw_radius ... !> \param do_nics ... !> \param interpolate_shift ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_nmr_env(nmr_env, n_nics, cs_atom_list, do_calc_cs_atom, & r_nics, chemical_shift,chemical_shift_loc, & chemical_shift_nics_loc, chemical_shift_nics, & - shift_gapw_radius,do_nics,interpolate_shift,error) + shift_gapw_radius,do_nics,interpolate_shift) TYPE(nmr_env_type) :: nmr_env INTEGER, INTENT(OUT), OPTIONAL :: n_nics @@ -621,7 +603,6 @@ SUBROUTINE get_nmr_env(nmr_env, n_nics, cs_atom_list, do_calc_cs_atom, & chemical_shift_nics REAL(dp), INTENT(OUT), OPTIONAL :: shift_gapw_radius LOGICAL, INTENT(OUT), OPTIONAL :: do_nics, interpolate_shift - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_nmr_env', & routineP = moduleN//':'//routineN @@ -630,7 +611,7 @@ SUBROUTINE get_nmr_env(nmr_env, n_nics, cs_atom_list, do_calc_cs_atom, & failure =.FALSE. - CPPrecondition(nmr_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(nmr_env%ref_count>0, cp_failure_level,routineP,failure) IF(PRESENT(n_nics )) n_nics = nmr_env%n_nics IF(PRESENT(cs_atom_list )) cs_atom_list => nmr_env%cs_atom_list @@ -670,12 +651,11 @@ END SUBROUTINE get_nmr_env !> \param matrix_pso ... !> \param matrix_dso ... !> \param matrix_fc ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_issc_env(issc_env,issc_on_atom_list,issc_gapw_radius,issc_loc,& do_fc,do_sd,do_pso,do_dso,& issc,interpolate_issc,psi1_efg,psi1_pso,psi1_dso,psi1_fc,efg_psi0,pso_psi0,dso_psi0,fc_psi0,& - matrix_efg,matrix_pso,matrix_dso,matrix_fc,error) + matrix_efg,matrix_pso,matrix_dso,matrix_fc) TYPE(issc_env_type) :: issc_env INTEGER, DIMENSION(:), OPTIONAL, POINTER :: issc_on_atom_list @@ -697,7 +677,6 @@ SUBROUTINE get_issc_env(issc_env,issc_on_atom_list,issc_gapw_radius,issc_loc,& TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: matrix_efg, matrix_pso, & matrix_dso, matrix_fc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_issc_env', & routineP = moduleN//':'//routineN @@ -706,7 +685,7 @@ SUBROUTINE get_issc_env(issc_env,issc_on_atom_list,issc_gapw_radius,issc_loc,& failure =.FALSE. - CPPrecondition(issc_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(issc_env%ref_count>0,cp_failure_level,routineP,failure) IF(PRESENT(issc_on_atom_list)) issc_on_atom_list => issc_env%issc_on_atom_list IF(PRESENT(issc_gapw_radius )) issc_gapw_radius = issc_env%issc_gapw_radius @@ -737,16 +716,14 @@ END SUBROUTINE get_issc_env !> \param current_env ... !> \param jrho1_atom_set ... !> \param jrho1_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_current_env(current_env,jrho1_atom_set,jrho1_set,error) + SUBROUTINE set_current_env(current_env,jrho1_atom_set,jrho1_set) TYPE(current_env_type) :: current_env TYPE(jrho_atom_type), DIMENSION(:), & OPTIONAL, POINTER :: jrho1_atom_set TYPE(qs_rho_p_type), DIMENSION(:), & OPTIONAL, POINTER :: jrho1_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_current_env', & routineP = moduleN//':'//routineN @@ -756,12 +733,12 @@ SUBROUTINE set_current_env(current_env,jrho1_atom_set,jrho1_set,error) failure =.FALSE. - CPPrecondition(current_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(current_env%ref_count>0, cp_failure_level,routineP,failure) IF(PRESENT(jrho1_atom_set)) THEN IF(ASSOCIATED(current_env%jrho1_atom_set)) THEN - CALL deallocate_jrho_atom_set(current_env%jrho1_atom_set,error=error) + CALL deallocate_jrho_atom_set(current_env%jrho1_atom_set) ENDIF current_env%jrho1_atom_set => jrho1_atom_set END IF @@ -769,7 +746,7 @@ SUBROUTINE set_current_env(current_env,jrho1_atom_set,jrho1_set,error) IF(PRESENT(jrho1_set)) THEN IF(ASSOCIATED(current_env%jrho1_set)) THEN DO idir = 1,3 - CALL qs_rho_release(current_env%jrho1_set(idir)%rho,error=error) + CALL qs_rho_release(current_env%jrho1_set(idir)%rho) END DO END IF current_env%jrho1_set => jrho1_set @@ -783,15 +760,12 @@ END SUBROUTINE set_current_env !> \param chi_factor ... !> \param chi_SI2shiftppm ... !> \param chi_SI2ppmcgs ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_nmr_env(nmr_env,shift_factor,chi_factor,chi_SI2shiftppm,chi_SI2ppmcgs,& - error) + SUBROUTINE set_nmr_env(nmr_env,shift_factor,chi_factor,chi_SI2shiftppm,chi_SI2ppmcgs) TYPE(nmr_env_type) :: nmr_env REAL(dp), INTENT(IN), OPTIONAL :: shift_factor, chi_factor, & chi_SI2shiftppm, chi_SI2ppmcgs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_nmr_env', & routineP = moduleN//':'//routineN @@ -800,7 +774,7 @@ SUBROUTINE set_nmr_env(nmr_env,shift_factor,chi_factor,chi_SI2shiftppm,chi_SI2pp failure =.FALSE. - CPPrecondition(nmr_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(nmr_env%ref_count>0, cp_failure_level,routineP,failure) IF(PRESENT(shift_factor )) nmr_env%chi_factor = chi_factor IF(PRESENT(shift_factor )) nmr_env%chi_factor = chi_factor @@ -811,12 +785,10 @@ END SUBROUTINE set_nmr_env ! ***************************************************************************** !> \brief ... !> \param issc_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_issc_env(issc_env,error) + SUBROUTINE set_issc_env(issc_env) TYPE(issc_env_type) :: issc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_issc_env', & routineP = moduleN//':'//routineN @@ -825,7 +797,7 @@ SUBROUTINE set_issc_env(issc_env,error) failure =.FALSE. - CPPrecondition(issc_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(issc_env%ref_count>0, cp_failure_level,routineP,failure) END SUBROUTINE set_issc_env @@ -839,10 +811,9 @@ END SUBROUTINE set_issc_env !> \param nablavks_atom_set ... !> \param bind_set ... !> \param bind_atom_set ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_epr_env(epr_env, g_total, g_so, g_soo, nablavks_set, nablavks_atom_set, & - bind_set, bind_atom_set, error) + bind_set, bind_atom_set) TYPE(epr_env_type) :: epr_env REAL(dp), DIMENSION(:, :), OPTIONAL, & @@ -855,8 +826,6 @@ SUBROUTINE get_epr_env(epr_env, g_total, g_so, g_soo, nablavks_set, nablavks_ato OPTIONAL, POINTER :: bind_set TYPE(rho_atom_coeff), DIMENSION(:, :), & OPTIONAL, POINTER :: bind_atom_set - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_epr_env', & routineP = moduleN//':'//routineN @@ -865,7 +834,7 @@ SUBROUTINE get_epr_env(epr_env, g_total, g_so, g_soo, nablavks_set, nablavks_ato failure =.FALSE. - CPPrecondition(epr_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(epr_env%ref_count>0, cp_failure_level,routineP,failure) IF(PRESENT(g_total)) g_total => epr_env%g_total IF(PRESENT(g_so)) g_so => epr_env%g_so @@ -888,12 +857,10 @@ END SUBROUTINE get_epr_env !> \param g_zke_factor ... !> \param nablavks_set ... !> \param nablavks_atom_set ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_epr_env(epr_env,g_free_factor,g_soo_chicorr_factor,& g_soo_factor,g_so_factor,g_so_factor_gapw,& - g_zke_factor,nablavks_set,nablavks_atom_set,& - error) + g_zke_factor,nablavks_set,nablavks_atom_set) TYPE(epr_env_type) :: epr_env REAL(dp), INTENT(IN), OPTIONAL :: g_free_factor, g_soo_chicorr_factor, & @@ -902,8 +869,6 @@ SUBROUTINE set_epr_env(epr_env,g_free_factor,g_soo_chicorr_factor,& OPTIONAL, POINTER :: nablavks_set TYPE(nablavks_atom_type), DIMENSION(:), & OPTIONAL, POINTER :: nablavks_atom_set - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_epr_env', & routineP = moduleN//':'//routineN @@ -913,7 +878,7 @@ SUBROUTINE set_epr_env(epr_env,g_free_factor,g_soo_chicorr_factor,& failure =.FALSE. - CPPrecondition(epr_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(epr_env%ref_count>0, cp_failure_level,routineP,failure) IF(PRESENT(g_free_factor)) epr_env%g_free_factor=g_free_factor IF(PRESENT(g_zke_factor)) epr_env%g_zke_factor=g_zke_factor @@ -926,7 +891,7 @@ SUBROUTINE set_epr_env(epr_env,g_free_factor,g_soo_chicorr_factor,& IF(ASSOCIATED(epr_env%nablavks_set)) THEN DO ispin = 1,2 DO idir = 1,3 - CALL qs_rho_release(epr_env%nablavks_set(idir,ispin)%rho,error=error) + CALL qs_rho_release(epr_env%nablavks_set(idir,ispin)%rho) END DO END DO END IF @@ -935,7 +900,7 @@ SUBROUTINE set_epr_env(epr_env,g_free_factor,g_soo_chicorr_factor,& IF(PRESENT(nablavks_atom_set)) THEN IF(ASSOCIATED(epr_env%nablavks_atom_set)) THEN - CALL deallocate_nablavks_atom_set(epr_env%nablavks_atom_set,error=error) + CALL deallocate_nablavks_atom_set(epr_env%nablavks_atom_set) ENDIF epr_env%nablavks_atom_set => nablavks_atom_set ENDIF @@ -946,15 +911,12 @@ END SUBROUTINE set_epr_env !> \brief ... !> \param nablavks_atom_set ... !> \param natom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_nablavks_atom_set(nablavks_atom_set,natom,error) + SUBROUTINE allocate_nablavks_atom_set(nablavks_atom_set,natom) TYPE(nablavks_atom_type), DIMENSION(:), & POINTER :: nablavks_atom_set INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_nablavks_atom_set', & routineP = moduleN//':'//routineN @@ -965,7 +927,7 @@ SUBROUTINE allocate_nablavks_atom_set(nablavks_atom_set,natom,error) failure = .FALSE. ALLOCATE(nablavks_atom_set(natom), STAT=istat) - CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0, cp_failure_level,routineP,failure) DO iat = 1,natom NULLIFY(nablavks_atom_set(iat)%nablavks_vec_rad_h) @@ -976,14 +938,11 @@ END SUBROUTINE allocate_nablavks_atom_set ! ***************************************************************************** !> \brief ... !> \param nablavks_atom_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_nablavks_atom_set(nablavks_atom_set,error) + SUBROUTINE deallocate_nablavks_atom_set(nablavks_atom_set) TYPE(nablavks_atom_type), DIMENSION(:), & POINTER :: nablavks_atom_set - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_nablavks_atom_set', & routineP = moduleN//':'//routineN @@ -993,7 +952,7 @@ SUBROUTINE deallocate_nablavks_atom_set(nablavks_atom_set,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(nablavks_atom_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(nablavks_atom_set),cp_failure_level,routineP,failure) natom = SIZE(nablavks_atom_set) DO iat = 1,natom @@ -1003,34 +962,32 @@ SUBROUTINE deallocate_nablavks_atom_set(nablavks_atom_set,error) DO i=1,n DO idir = 1,3 DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_h(idir,i)%r_coef,STAT=istat) - CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0, cp_failure_level,routineP,failure) DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_s(idir,i)%r_coef,STAT=istat) - CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0, cp_failure_level,routineP,failure) ENDDO ENDDO ENDIF DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_h,STAT=istat) - CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0, cp_failure_level,routineP,failure) DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_s,STAT=istat) - CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0, cp_failure_level,routineP,failure) ENDIF ENDDO DEALLOCATE(nablavks_atom_set, STAT=istat) - CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0, cp_failure_level,routineP,failure) END SUBROUTINE deallocate_nablavks_atom_set ! ***************************************************************************** !> \brief ... !> \param jrho_atom_set ... !> \param natom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_jrho_atom_set(jrho_atom_set,natom,error) + SUBROUTINE allocate_jrho_atom_set(jrho_atom_set,natom) TYPE(jrho_atom_type), DIMENSION(:), & POINTER :: jrho_atom_set INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_atom_set', & routineP = moduleN//':'//routineN @@ -1041,7 +998,7 @@ SUBROUTINE allocate_jrho_atom_set(jrho_atom_set,natom,error) failure = .FALSE. ALLOCATE(jrho_atom_set(natom), STAT=istat) - CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0, cp_failure_level,routineP,failure) DO iat = 1,natom NULLIFY(jrho_atom_set(iat)%cjc0_h) @@ -1074,13 +1031,11 @@ END SUBROUTINE allocate_jrho_atom_set ! ***************************************************************************** !> \brief ... !> \param jrho_atom_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) + SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set) TYPE(jrho_atom_type), DIMENSION(:), & POINTER :: jrho_atom_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_jrho_atom_set', & routineP = moduleN//':'//routineN @@ -1090,7 +1045,7 @@ SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(jrho_atom_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho_atom_set),cp_failure_level,routineP,failure) natom = SIZE(jrho_atom_set) DO iat = 1,natom @@ -1109,7 +1064,7 @@ SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) jrho_atom_set(iat)%cjc_iii_h(i)%r_coef,& jrho_atom_set(iat)%cjc_iii_s(i)%r_coef,& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END IF DEALLOCATE(jrho_atom_set(iat)%cjc0_h,& @@ -1121,7 +1076,7 @@ SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) jrho_atom_set(iat)%cjc_iii_h,& jrho_atom_set(iat)%cjc_iii_s,& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(jrho_atom_set(iat)%jrho_a_h)) THEN @@ -1145,7 +1100,7 @@ SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) jrho_atom_set(iat)%jrho_b_h_iii(i)%r_coef,& jrho_atom_set(iat)%jrho_b_s_iii(i)%r_coef,& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END IF DEALLOCATE(jrho_atom_set(iat)%jrho_h,& @@ -1163,7 +1118,7 @@ SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) jrho_atom_set(iat)%jrho_b_h_iii,& jrho_atom_set(iat)%jrho_b_s_iii,& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(jrho_atom_set(iat)%jrho_vec_rad_h)) THEN @@ -1176,18 +1131,18 @@ SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) DEALLOCATE(jrho_atom_set(iat)%jrho_vec_rad_h(idir,i)%r_coef,& jrho_atom_set(iat)%jrho_vec_rad_s(idir,i)%r_coef,& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END DO ENDIF DEALLOCATE(jrho_atom_set(iat)%jrho_vec_rad_h,& jrho_atom_set(iat)%jrho_vec_rad_s,& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE(jrho_atom_set,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_jrho_atom_set @@ -1198,13 +1153,11 @@ END SUBROUTINE deallocate_jrho_atom_set !> \param nr ... !> \param na ... !> \param max_iso_not0 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_jrho_atom_rad(jrho1_atom,ispin,nr,na,max_iso_not0,error) + SUBROUTINE allocate_jrho_atom_rad(jrho1_atom,ispin,nr,na,max_iso_not0) TYPE(jrho_atom_type), POINTER :: jrho1_atom INTEGER, INTENT(IN) :: ispin, nr, na, max_iso_not0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_atom_rad', & routineP = moduleN//':'//routineN @@ -1216,14 +1169,14 @@ SUBROUTINE allocate_jrho_atom_rad(jrho1_atom,ispin,nr,na,max_iso_not0,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,failure) DO idir = 1,3 ALLOCATE(jrho1_atom%jrho_vec_rad_h(idir,ispin)%r_coef(nr,na),& jrho1_atom%jrho_vec_rad_s(idir,ispin)%r_coef(nr,na),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) jrho1_atom%jrho_vec_rad_h(idir,ispin)%r_coef = 0.0_dp jrho1_atom%jrho_vec_rad_s(idir,ispin)%r_coef = 0.0_dp ENDDO @@ -1243,7 +1196,7 @@ SUBROUTINE allocate_jrho_atom_rad(jrho1_atom,ispin,nr,na,max_iso_not0,error) jrho1_atom%jrho_b_h_iii(ispin)%r_coef(nr,max_iso_not0),& jrho1_atom%jrho_b_s_iii(ispin)%r_coef(nr,max_iso_not0),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! jrho1_atom%jrho_h(ispin)%r_coef = 0.0_dp jrho1_atom%jrho_s(ispin)%r_coef = 0.0_dp @@ -1267,13 +1220,11 @@ END SUBROUTINE allocate_jrho_atom_rad !> \brief ... !> \param jrho1_atom ... !> \param ispin ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set2zero_jrho_atom_rad(jrho1_atom,ispin,error) + SUBROUTINE set2zero_jrho_atom_rad(jrho1_atom,ispin) ! TYPE(jrho_atom_type), POINTER :: jrho1_atom INTEGER, INTENT(IN) :: ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set2zero_jrho_atom_rad', & routineP = moduleN//':'//routineN @@ -1282,7 +1233,7 @@ SUBROUTINE set2zero_jrho_atom_rad(jrho1_atom,ispin,error) failure = .FALSE. ! - CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,failure) ! jrho1_atom%jrho_h(ispin)%r_coef = 0.0_dp jrho1_atom%jrho_s(ispin)%r_coef = 0.0_dp @@ -1311,14 +1262,12 @@ END SUBROUTINE set2zero_jrho_atom_rad !> \param jrho1_atom_set ... !> \param iatom ... !> \param nsotot ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_jrho_coeff(jrho1_atom_set,iatom,nsotot,error) + SUBROUTINE allocate_jrho_coeff(jrho1_atom_set,iatom,nsotot) TYPE(jrho_atom_type), DIMENSION(:), & POINTER :: jrho1_atom_set INTEGER, INTENT(IN) :: iatom, nsotot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_coeff', & routineP = moduleN//':'//routineN @@ -1328,7 +1277,7 @@ SUBROUTINE allocate_jrho_coeff(jrho1_atom_set,iatom,nsotot,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,failure) DO i = 1,SIZE(jrho1_atom_set(iatom)%cjc0_h,1) ALLOCATE(jrho1_atom_set(iatom)%cjc0_h(i)%r_coef(nsotot,nsotot),& jrho1_atom_set(iatom)%cjc0_s(i)%r_coef(nsotot,nsotot),& @@ -1339,7 +1288,7 @@ SUBROUTINE allocate_jrho_coeff(jrho1_atom_set,iatom,nsotot,error) jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef(nsotot,nsotot),& jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef(nsotot,nsotot),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) jrho1_atom_set(iatom)%cjc0_h(i)%r_coef = 0.0_dp jrho1_atom_set(iatom)%cjc0_s(i)%r_coef = 0.0_dp jrho1_atom_set(iatom)%cjc_h(i)%r_coef = 0.0_dp @@ -1358,14 +1307,12 @@ END SUBROUTINE allocate_jrho_coeff !> \brief ... !> \param jrho1_atom_set ... !> \param iatom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_jrho_coeff(jrho1_atom_set,iatom,error) + SUBROUTINE deallocate_jrho_coeff(jrho1_atom_set,iatom) TYPE(jrho_atom_type), DIMENSION(:), & POINTER :: jrho1_atom_set INTEGER, INTENT(IN) :: iatom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_jrho_coeff', & routineP = moduleN//':'//routineN @@ -1375,7 +1322,7 @@ SUBROUTINE deallocate_jrho_coeff(jrho1_atom_set,iatom,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,failure) DO i = 1,SIZE(jrho1_atom_set(iatom)%cjc0_h,1) DEALLOCATE(jrho1_atom_set(iatom)%cjc0_h(i)%r_coef,& jrho1_atom_set(iatom)%cjc0_s(i)%r_coef,& @@ -1386,7 +1333,7 @@ SUBROUTINE deallocate_jrho_coeff(jrho1_atom_set,iatom,error) jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef,& jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef,& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDDO CALL timestop(handle) END SUBROUTINE deallocate_jrho_coeff @@ -1405,10 +1352,9 @@ END SUBROUTINE deallocate_jrho_coeff !> \param cjc_iii_s ... !> \param jrho_vec_rad_h ... !> \param jrho_vec_rad_s ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_jrho_atom(jrho1_atom_set,iatom,cjc_h,cjc_s,cjc_ii_h,cjc_ii_s,& - cjc_iii_h,cjc_iii_s,jrho_vec_rad_h,jrho_vec_rad_s,error) + cjc_iii_h,cjc_iii_s,jrho_vec_rad_h,jrho_vec_rad_s) TYPE(jrho_atom_type), DIMENSION(:), & POINTER :: jrho1_atom_set @@ -1418,7 +1364,6 @@ SUBROUTINE get_jrho_atom(jrho1_atom_set,iatom,cjc_h,cjc_s,cjc_ii_h,cjc_ii_s,& cjc_ii_s, cjc_iii_h, cjc_iii_s TYPE(rho_atom_coeff), DIMENSION(:, :), & OPTIONAL, POINTER :: jrho_vec_rad_h, jrho_vec_rad_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_jrho_atom', & routineP = moduleN//':'//routineN @@ -1427,7 +1372,7 @@ SUBROUTINE get_jrho_atom(jrho1_atom_set,iatom,cjc_h,cjc_s,cjc_ii_h,cjc_ii_s,& failure = .FALSE. - CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,failure) IF(PRESENT(cjc_h )) cjc_h => jrho1_atom_set(iatom)%cjc_h IF(PRESENT(cjc_s )) cjc_s => jrho1_atom_set(iatom)%cjc_s @@ -1445,15 +1390,13 @@ END SUBROUTINE get_jrho_atom !> \param jrho1_atom_set ... !> \param atomic_kind_set ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_jrho_atom_set(jrho1_atom_set,atomic_kind_set,nspins,error) + SUBROUTINE init_jrho_atom_set(jrho1_atom_set,atomic_kind_set,nspins) TYPE(jrho_atom_type), DIMENSION(:), & POINTER :: jrho1_atom_set TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_jrho_atom_set', & routineP = moduleN//':'//routineN @@ -1468,15 +1411,15 @@ SUBROUTINE init_jrho_atom_set(jrho1_atom_set,atomic_kind_set,nspins,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,failure) IF(ASSOCIATED(jrho1_atom_set)) THEN - CALL deallocate_jrho_atom_set(jrho1_atom_set,error=error) + CALL deallocate_jrho_atom_set(jrho1_atom_set) END IF CALL get_atomic_kind_set(atomic_kind_set, natom = natom) - CALL allocate_jrho_atom_set(jrho1_atom_set,natom,error=error) + CALL allocate_jrho_atom_set(jrho1_atom_set,natom) nkind = SIZE(atomic_kind_set) @@ -1513,7 +1456,7 @@ SUBROUTINE init_jrho_atom_set(jrho1_atom_set,atomic_kind_set,nspins,error) jrho1_atom_set(iatom)%cjc_iii_h(nspins),& jrho1_atom_set(iatom)%cjc_iii_s(nspins),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO idir = 1,3 @@ -1559,9 +1502,8 @@ END SUBROUTINE init_jrho_atom_set !> \param atomic_kind_set ... !> \param qs_kind_set ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set,nspins,error) + SUBROUTINE init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set,nspins) TYPE(nablavks_atom_type), DIMENSION(:), & POINTER :: nablavks_atom_set @@ -1570,8 +1512,6 @@ SUBROUTINE init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set, TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_nablavks_atom_set', & routineP = moduleN//':'//routineN @@ -1588,15 +1528,15 @@ SUBROUTINE init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set, failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_kind_set),cp_failure_level,routineP,failure) IF(ASSOCIATED(nablavks_atom_set)) THEN - CALL deallocate_nablavks_atom_set(nablavks_atom_set,error=error) + CALL deallocate_nablavks_atom_set(nablavks_atom_set) END IF CALL get_atomic_kind_set(atomic_kind_set, natom=natom) - CALL allocate_nablavks_atom_set(nablavks_atom_set,natom,error=error) + CALL allocate_nablavks_atom_set(nablavks_atom_set,natom) nkind = SIZE(atomic_kind_set) @@ -1605,7 +1545,7 @@ SUBROUTINE init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set, CALL get_qs_kind(qs_kind_set(ikind),& basis_set=orb_basis_set, & harmonics=harmonics,& - grid_atom=grid_atom, error=error) + grid_atom=grid_atom) na = grid_atom%ng_sphere nr = grid_atom%nr @@ -1619,17 +1559,17 @@ SUBROUTINE init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,qs_kind_set, !*** allocate the radial density for each LM,for each atom *** ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_h(3,nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_s(3,nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins DO idir = 1,3 NULLIFY(nablavks_atom_set(iatom)%nablavks_vec_rad_h(idir,ispin)%r_coef) NULLIFY(nablavks_atom_set(iatom)%nablavks_vec_rad_s(idir,ispin)%r_coef) ALLOCATE(nablavks_atom_set(iatom)%nablavks_vec_rad_h(idir,ispin)%r_coef(nr,na),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(nablavks_atom_set(iatom)%nablavks_vec_rad_s(idir,ispin)%r_coef(nr,na),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END DO ! ispin END DO ! iat @@ -1642,12 +1582,10 @@ END SUBROUTINE init_nablavks_atom_set ! ***************************************************************************** !> \brief ... !> \param polar_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE polar_env_create(polar_env,error) + SUBROUTINE polar_env_create(polar_env) TYPE(polar_env_type) :: polar_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'polar_env_create', & routineP = moduleN//':'//routineN @@ -1656,7 +1594,7 @@ SUBROUTINE polar_env_create(polar_env,error) failure =.FALSE. - CPPrecondition(polar_env%ref_count==0, cp_failure_level,routineP,error,failure) + CPPrecondition(polar_env%ref_count==0, cp_failure_level,routineP,failure) polar_env%ref_count = 1 ! polar_env%do_raman=.FALSE. NULLIFY(polar_env%polar) @@ -1674,10 +1612,9 @@ END SUBROUTINE polar_env_create !> \param polar ... !> \param psi1_dBerry ... !> \param mo_derivs ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_polar_env(polar_env,do_raman,dBerry_psi0, polar, & - psi1_dBerry,mo_derivs,error) + psi1_dBerry,mo_derivs) TYPE(polar_env_type) :: polar_env LOGICAL, OPTIONAL :: do_raman @@ -1687,7 +1624,6 @@ SUBROUTINE get_polar_env(polar_env,do_raman,dBerry_psi0, polar, & POINTER :: polar TYPE(cp_fm_p_type), DIMENSION(:, :), & OPTIONAL, POINTER :: psi1_dBerry, mo_derivs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_polar_env', & routineP = moduleN//':'//routineN @@ -1696,7 +1632,7 @@ SUBROUTINE get_polar_env(polar_env,do_raman,dBerry_psi0, polar, & failure =.FALSE. - CPPrecondition(polar_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(polar_env%ref_count>0,cp_failure_level,routineP,failure) IF(PRESENT(polar)) polar => polar_env%polar IF(PRESENT(psi1_dBerry )) psi1_dBerry => polar_env%psi1_dBerry @@ -1710,12 +1646,10 @@ END SUBROUTINE get_polar_env ! ***************************************************************************** !> \brief ... !> \param polar_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_polar_env(polar_env,error) + SUBROUTINE set_polar_env(polar_env) TYPE(polar_env_type) :: polar_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_polar_env', & routineP = moduleN//':'//routineN @@ -1724,7 +1658,7 @@ SUBROUTINE set_polar_env(polar_env,error) failure =.FALSE. - CPPrecondition(polar_env%ref_count>0, cp_failure_level,routineP,error,failure) + CPPrecondition(polar_env%ref_count>0, cp_failure_level,routineP,failure) END SUBROUTINE set_polar_env ! ***************************************************************************** diff --git a/src/qs_loc_methods.F b/src/qs_loc_methods.F index 250ecbfbc4..21d8557527 100644 --- a/src/qs_loc_methods.F +++ b/src/qs_loc_methods.F @@ -133,8 +133,6 @@ MODULE qs_loc_methods !> \param weights ... !> \param ispin ... !> \param print_loc_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2005 created [MI] !> \author MI @@ -144,8 +142,7 @@ MODULE qs_loc_methods !> The file for the centers and the spreads have a xyz format ! ***************************************************************************** SUBROUTINE optimize_loc_berry( method, qs_loc_env, vectors, op_sm_set, & - zij_fm_set, para_env, cell, weights, ispin, print_loc_section,& - error) + zij_fm_set, para_env, cell, weights, ispin, print_loc_section) INTEGER, INTENT(IN) :: method TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env @@ -159,7 +156,6 @@ SUBROUTINE optimize_loc_berry( method, qs_loc_env, vectors, op_sm_set, & REAL(dp), DIMENSION(:) :: weights INTEGER, INTENT(IN) :: ispin TYPE(section_vals_type), POINTER :: print_loc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'optimize_loc_berry', & routineP = moduleN//':'//routineN @@ -176,23 +172,23 @@ SUBROUTINE optimize_loc_berry( method, qs_loc_env, vectors, op_sm_set, & TYPE(cp_logger_type), POINTER :: logger CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,print_loc_section,"PROGRAM_RUN_INFO",& - extension=".locInfo",error=error) + extension=".locInfo") NULLIFY(opvec) ! get rows and cols of the input - CALL cp_fm_get_info(vectors,nrow_global=nao,ncol_global=nmoloc,error=error) + CALL cp_fm_get_info(vectors,nrow_global=nao,ncol_global=nmoloc) ! replicate the input kind of matrix - CALL cp_fm_create(opvec,vectors%matrix_struct,error=error) + CALL cp_fm_create(opvec,vectors%matrix_struct) ! Compute zij here DO i=1,SIZE ( zij_fm_set, 2 ) DO j=1,SIZE ( zij_fm_set, 1 ) - CALL cp_fm_set_all(zij_fm_set(j,i)%matrix, 0.0_dp, error=error) - CALL cp_dbcsr_sm_fm_multiply(op_sm_set(j,i)%matrix, vectors,opvec,ncol=nmoloc ,error=error) + CALL cp_fm_set_all(zij_fm_set(j,i)%matrix, 0.0_dp) + CALL cp_dbcsr_sm_fm_multiply(op_sm_set(j,i)%matrix, vectors,opvec,ncol=nmoloc) CALL cp_gemm("T","N",nmoloc,nmoloc,nao,1.0_dp,vectors,opvec,0.0_dp,& - zij_fm_set(j,i)%matrix,error=error) + zij_fm_set(j,i)%matrix) ENDDO ENDDO @@ -205,17 +201,16 @@ SUBROUTINE optimize_loc_berry( method, qs_loc_env, vectors, op_sm_set, & target_time = qs_loc_env%target_time start_time = qs_loc_env%start_time CALL centers_spreads_berry( qs_loc_env, zij_fm_set, nmoloc, cell, weights,& - ispin, print_loc_section, only_initial_out=.TRUE., error=error ) + ispin, print_loc_section, only_initial_out=.TRUE.) SELECT CASE ( method ) CASE ( do_loc_jacobi ) CALL jacobi_rotations ( weights, zij_fm_set, vectors, para_env, max_iter=max_iter,& eps_localization=eps_localization, sweeps=sweeps, & - out_each=out_each, target_time=target_time, start_time=start_time, error=error ) + out_each=out_each, target_time=target_time, start_time=start_time) CASE ( do_loc_crazy ) CALL crazy_rotations( weights, zij_fm_set, vectors, max_iter=max_iter, max_crazy_angle = max_crazy_angle, & crazy_scale=crazy_scale, crazy_use_diag=crazy_use_diag, & - eps_localization=eps_localization, iterations= sweeps ,converged=converged,& - error=error) + eps_localization=eps_localization, iterations= sweeps ,converged=converged) ! Possibly fallback to jacobi if the crazy rotation fails IF ( .NOT.converged ) THEN IF (qs_loc_env%localized_wfn_control%jacobi_fallback) THEN @@ -224,7 +219,7 @@ SUBROUTINE optimize_loc_berry( method, qs_loc_env, vectors, op_sm_set, & " iterations, switching to jacobi rotations" CALL jacobi_rotations ( weights, zij_fm_set, vectors, para_env, max_iter=max_iter,& eps_localization=eps_localization, sweeps=sweeps, & - out_each=out_each, target_time=target_time, start_time=start_time, error=error ) + out_each=out_each, target_time=target_time, start_time=start_time) ELSE IF (output_unit>0) WRITE (output_unit,"(A,I6,A)")& " Crazy Wannier localization not converged after ",sweeps,& @@ -233,20 +228,20 @@ SUBROUTINE optimize_loc_berry( method, qs_loc_env, vectors, op_sm_set, & END IF CASE ( do_loc_direct ) CALL direct_mini( weights, zij_fm_set, vectors, max_iter=max_iter,& - eps_localization=eps_localization, iterations=sweeps, error=error ) + eps_localization=eps_localization, iterations=sweeps) CASE( do_loc_l1_norm_sd ) IF(.NOT. cell%orthorhombic ) THEN CALL stop_program(routineN,moduleN,__LINE__,& "Non-orthorhombic cell with the selected method NYI") ELSE - CALL approx_l1_norm_sd(vectors,max_iter,eps_localization,converged,sweeps,error=error) + CALL approx_l1_norm_sd(vectors,max_iter,eps_localization,converged,sweeps) ! here we need to set zij for the computation of the centers and spreads DO i=1,SIZE ( zij_fm_set, 2 ) DO j=1,SIZE ( zij_fm_set, 1 ) - CALL cp_fm_set_all(zij_fm_set(j,i)%matrix, 0.0_dp, error=error) - CALL cp_dbcsr_sm_fm_multiply(op_sm_set(j,i)%matrix, vectors,opvec,ncol=nmoloc ,error=error) + CALL cp_fm_set_all(zij_fm_set(j,i)%matrix, 0.0_dp) + CALL cp_dbcsr_sm_fm_multiply(op_sm_set(j,i)%matrix, vectors,opvec,ncol=nmoloc) CALL cp_gemm("T","N",nmoloc,nmoloc,nao,1.0_dp,vectors,opvec,0.0_dp,& - zij_fm_set(j,i)%matrix,error=error) + zij_fm_set(j,i)%matrix) ENDDO ENDDO END IF @@ -263,9 +258,9 @@ SUBROUTINE optimize_loc_berry( method, qs_loc_env, vectors, op_sm_set, & ENDIF CALL centers_spreads_berry( qs_loc_env, zij_fm_set, nmoloc, cell, weights,& - ispin, print_loc_section, error=error ) - CALL cp_fm_release(opvec,error=error) - CALL cp_print_key_finished_output(output_unit,logger,print_loc_section,"PROGRAM_RUN_INFO",error=error) + ispin, print_loc_section) + CALL cp_fm_release(opvec) + CALL cp_print_key_finished_output(output_unit,logger,print_loc_section,"PROGRAM_RUN_INFO") CALL timestop(handle) @@ -280,13 +275,12 @@ END SUBROUTINE optimize_loc_berry !> \param zij_fm_set ... !> \param ispin ... !> \param print_loc_section ... -!> \param error ... !> \par History !> 04.2005 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE optimize_loc_pipek(qs_env, method, qs_loc_env, vectors, zij_fm_set,& - ispin, print_loc_section, error) + ispin, print_loc_section) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: method TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env @@ -295,7 +289,6 @@ SUBROUTINE optimize_loc_pipek(qs_env, method, qs_loc_env, vectors, zij_fm_set,& POINTER :: zij_fm_set INTEGER, INTENT(IN) :: ispin TYPE(section_vals_type), POINTER :: print_loc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'optimize_loc_pipek', & routineP = moduleN//':'//routineN @@ -318,73 +311,73 @@ SUBROUTINE optimize_loc_pipek(qs_env, method, qs_loc_env, vectors, zij_fm_set,& CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,print_loc_section,"PROGRAM_RUN_INFO",& - extension=".locInfo",error=error) + extension=".locInfo") NULLIFY(particle_set) ! get rows and cols of the input - CALL cp_fm_get_info(vectors,nrow_global=nao,ncol_global=nmoloc,error=error) + CALL cp_fm_get_info(vectors,nrow_global=nao,ncol_global=nmoloc) ! replicate the input kind of matrix - CALL cp_fm_create(opvec,vectors%matrix_struct,error=error) - CALL cp_fm_set_all(opvec, 0.0_dp, error=error) + CALL cp_fm_create(opvec,vectors%matrix_struct) + CALL cp_fm_set_all(opvec, 0.0_dp) CALL get_qs_env(qs_env=qs_env, matrix_s=matrix_s, & - particle_set=particle_set,qs_kind_set=qs_kind_set,error=error) + particle_set=particle_set,qs_kind_set=qs_kind_set) natom = SIZE(particle_set,1) ALLOCATE (first_sgf(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (nsgf(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! construction of CALL get_particle_set(particle_set, qs_kind_set,& - first_sgf=first_sgf,last_sgf=last_sgf,nsgf=nsgf,error=error) + first_sgf=first_sgf,last_sgf=last_sgf,nsgf=nsgf) ! Copy the overlap sparse matrix in a full matrix - CALL mpools_get(qs_env%mpools,ao_ao_fm_pools=ao_ao_fm_pools,error=error) - CALL fm_pool_create_fm(ao_ao_fm_pools(1)%pool, ov_fm, name=" ", error=error) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,ov_fm,error=error) + CALL mpools_get(qs_env%mpools,ao_ao_fm_pools=ao_ao_fm_pools) + CALL fm_pool_create_fm(ao_ao_fm_pools(1)%pool, ov_fm, name=" ") + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,ov_fm) ! Compute zij here DO iatom = 1, natom - CALL cp_fm_set_all(zij_fm_set(iatom,1)%matrix, 0.0_dp, error=error) - CALL cp_fm_get_info(zij_fm_set(iatom,1)%matrix,ncol_global=ldz,error=error) + CALL cp_fm_set_all(zij_fm_set(iatom,1)%matrix, 0.0_dp) + CALL cp_fm_get_info(zij_fm_set(iatom,1)%matrix,ncol_global=ldz) isgf = first_sgf(iatom) ncol = nsgf(iatom) ! multiply fmxfm, using only part of the ao : Ct x S CALL cp_gemm('N','N',nao,nmoloc,nao,1.0_dp,ov_fm,vectors,0.0_dp,opvec,& - b_first_col=1,a_first_row=1,b_first_row=1,error=error) + b_first_col=1,a_first_row=1,b_first_row=1) CALL cp_gemm('T','N',nmoloc,nmoloc,ncol,0.5_dp,vectors,opvec,& 0.0_dp,zij_fm_set(iatom,1)%matrix,& - b_first_col=1,a_first_row=isgf,b_first_row=isgf,error=error) + b_first_col=1,a_first_row=isgf,b_first_row=isgf) CALL cp_gemm('N','N',nao,nmoloc,ncol,1.0_dp,ov_fm,vectors,0.0_dp,opvec,& - b_first_col=1,a_first_row=isgf,b_first_row=isgf,error=error) + b_first_col=1,a_first_row=isgf,b_first_row=isgf) CALL cp_gemm('T','N',nmoloc,nmoloc,nao,0.5_dp,vectors,opvec,& 1.0_dp,zij_fm_set(iatom,1)%matrix,& - b_first_col=1,a_first_row=1,b_first_row=1,error=error) + b_first_col=1,a_first_row=1,b_first_row=1) END DO ! iatom ! And now perform the optimization and rotate the orbitals SELECT CASE ( method ) CASE ( do_loc_jacobi ) - CALL jacobi_rotation_pipek(zij_fm_set, vectors, sweeps ,error=error) + CALL jacobi_rotation_pipek(zij_fm_set, vectors, sweeps) CASE ( do_loc_crazy ) CALL cp_unimplemented_error(fromWhere=routineP, & message="Crazy and Pipek not implemented.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE( do_loc_l1_norm_sd ) CALL cp_unimplemented_error(fromWhere=routineP, & message="L1 norm and Pipek not implemented.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE ( do_loc_direct ) CALL cp_unimplemented_error(fromWhere=routineP, & message="Direct and Pipek not implemented.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE ( do_loc_none ) IF (output_unit>0) WRITE(output_unit,'(A,I6,A)') " No MOS localization applied " CASE DEFAULT @@ -395,13 +388,13 @@ SUBROUTINE optimize_loc_pipek(qs_env, method, qs_loc_env, vectors, zij_fm_set,& " converged in ",sweeps," iterations" CALL centers_spreads_pipek( qs_loc_env, zij_fm_set, particle_set, ispin,& - print_loc_section, error=error ) + print_loc_section) DEALLOCATE (first_sgf, last_sgf, nsgf, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_fm_release(opvec,error=error) - CALL cp_print_key_finished_output(output_unit,logger,print_loc_section,"PROGRAM_RUN_INFO",error=error) + CALL cp_fm_release(opvec) + CALL cp_print_key_finished_output(output_unit,logger,print_loc_section,"PROGRAM_RUN_INFO") CALL timestop(handle) @@ -417,13 +410,12 @@ END SUBROUTINE optimize_loc_pipek !> \param ispin ... !> \param print_loc_section ... !> \param only_initial_out ... -!> \param error ... !> \par History !> 04.2005 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE centers_spreads_berry( qs_loc_env, zij, nmoloc, cell, weights, ispin,& - print_loc_section, only_initial_out, error) + print_loc_section, only_initial_out) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(cp_fm_p_type), INTENT(INOUT) :: zij( :, : ) INTEGER, INTENT(IN) :: nmoloc @@ -432,7 +424,6 @@ SUBROUTINE centers_spreads_berry( qs_loc_env, zij, nmoloc, cell, weights, ispin, INTEGER, INTENT(IN) :: ispin TYPE(section_vals_type), POINTER :: print_loc_section LOGICAL, INTENT(IN), OPTIONAL :: only_initial_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'centers_spreads_berry', & routineP = moduleN//':'//routineN @@ -452,24 +443,24 @@ SUBROUTINE centers_spreads_berry( qs_loc_env, zij, nmoloc, cell, weights, ispin, NULLIFY(centers, logger, print_key) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() my_only_init=.FALSE. IF(PRESENT(only_initial_out)) my_only_init=only_initial_out file_tmp = TRIM(qs_loc_env%tag_mo)//"_spreads_s"//TRIM(ADJUSTL(cp_to_string(ispin))) output_unit = cp_print_key_unit_nr(logger,print_loc_section,"PROGRAM_RUN_INFO",& - extension=".locInfo",error=error) + extension=".locInfo") unit_out_s = cp_print_key_unit_nr(logger,print_loc_section,"WANNIER_SPREADS",& - middle_name=file_tmp,extension=".data",error=error) - iter = cp_iter_string(logger%iter_info,error=error) + middle_name=file_tmp,extension=".data") + iter = cp_iter_string(logger%iter_info) IF(unit_out_s>0 .AND. .NOT. my_only_init) WRITE(unit_out_s,'(i6,/,A)') nmoloc, TRIM(iter) - CALL cp_fm_get_info ( zij ( 1, 1 ) % matrix, nrow_global = nstates ,error=error) - CPPrecondition(nstates>=nmoloc,cp_failure_level,routineP,error,failure) + CALL cp_fm_get_info ( zij ( 1, 1 ) % matrix, nrow_global = nstates) + CPPrecondition(nstates>=nmoloc,cp_failure_level,routineP,failure) centers => qs_loc_env%localized_wfn_control%centers_set(ispin)%array - CPPrecondition(ASSOCIATED(centers),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(centers,2)==nmoloc,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(centers),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(centers,2)==nmoloc,cp_failure_level,routineP,failure) sum_spread_i = 0.0_dp sum_spread_ii = 0.0_dp DO istate=1,nmoloc @@ -502,8 +493,8 @@ SUBROUTINE centers_spreads_berry( qs_loc_env, zij, nmoloc, cell, weights, ispin, ENDDO ! Print of wannier centers - print_key => section_vals_get_subs_vals(print_loc_section,"WANNIER_CENTERS",error=error) - IF (.NOT. my_only_init) CALL print_wannier_centers(qs_loc_env, print_key, centers, logger, ispin, error) + print_key => section_vals_get_subs_vals(print_loc_section,"WANNIER_CENTERS") + IF (.NOT. my_only_init) CALL print_wannier_centers(qs_loc_env, print_key, centers, logger, ispin) IF (output_unit>0) THEN WRITE(output_unit,'(T10, A, 2x, A26, A26)') " Spread Functional ","sum_in -w_i ln(|z_in|^2)",& @@ -517,8 +508,8 @@ SUBROUTINE centers_spreads_berry( qs_loc_env, zij, nmoloc, cell, weights, ispin, IF (unit_out_s>0 .AND. .NOT. my_only_init) WRITE (unit_out_s,'(A,2F16.10)') " Total ", sum_spread_i, sum_spread_ii - CALL cp_print_key_finished_output(unit_out_s,logger,print_loc_section,"WANNIER_SPREADS",error=error) - CALL cp_print_key_finished_output(output_unit,logger,print_loc_section,"PROGRAM_RUN_INFO",error=error) + CALL cp_print_key_finished_output(unit_out_s,logger,print_loc_section,"WANNIER_SPREADS") + CALL cp_print_key_finished_output(output_unit,logger,print_loc_section,"PROGRAM_RUN_INFO") END SUBROUTINE centers_spreads_berry @@ -530,12 +521,11 @@ END SUBROUTINE centers_spreads_berry !> \param particle_set ... !> \param ispin spin 1 or 2 !> \param print_loc_section ... -!> \param error ... !> \par History !> 05.2005 created [MI] ! ***************************************************************************** SUBROUTINE centers_spreads_pipek(qs_loc_env,zij_fm_set,particle_set,ispin,& - print_loc_section,error) + print_loc_section) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(cp_fm_p_type), DIMENSION(:, :), & @@ -544,7 +534,6 @@ SUBROUTINE centers_spreads_pipek(qs_loc_env,zij_fm_set,particle_set,ispin,& POINTER :: particle_set INTEGER, INTENT(IN) :: ispin TYPE(section_vals_type), POINTER :: print_loc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'centers_spreads_pipek', & routineP = moduleN//':'//routineN @@ -563,27 +552,27 @@ SUBROUTINE centers_spreads_pipek(qs_loc_env,zij_fm_set,particle_set,ispin,& NULLIFY(centers,logger, print_key) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL cp_fm_get_info ( zij_fm_set(1,1)%matrix, nrow_global = nstate,error=error) + CALL cp_fm_get_info ( zij_fm_set(1,1)%matrix, nrow_global = nstate) natom = SIZE(zij_fm_set,1) centers => qs_loc_env%localized_wfn_control%centers_set(ispin)%array - CPPrecondition(ASSOCIATED(centers),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(centers,2)==nstate,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(centers),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(centers,2)==nstate,cp_failure_level,routineP,failure) file_tmp = TRIM(qs_loc_env%tag_mo)//"_spreads_s"//TRIM(ADJUSTL(cp_to_string(ispin))) unit_out_s = cp_print_key_unit_nr(logger,print_loc_section,"WANNIER_SPREADS",& - middle_name=file_tmp,extension=".data",log_filename=.FALSE.,error=error) - iter = cp_iter_string(logger%iter_info,error=error) + middle_name=file_tmp,extension=".data",log_filename=.FALSE.) + iter = cp_iter_string(logger%iter_info) IF(unit_out_s>0) WRITE(unit_out_s,'(i6,/,A)') TRIM(iter) ALLOCATE (atom_of_state(nstate),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) atom_of_state = 0 ALLOCATE(diag(nstate,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) diag = 0.0_dp DO iatom = 1,natom @@ -593,7 +582,7 @@ SUBROUTINE centers_spreads_pipek(qs_loc_env,zij_fm_set,particle_set,ispin,& END DO ALLOCATE (Qii(nstate),ziimax(nstate),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ziimax = 0.0_dp Qii = 0.0_dp @@ -616,13 +605,13 @@ SUBROUTINE centers_spreads_pipek(qs_loc_env,zij_fm_set,particle_set,ispin,& END DO ! Print the wannier centers - print_key => section_vals_get_subs_vals(print_loc_section,"WANNIER_CENTERS",error=error) - CALL print_wannier_centers(qs_loc_env, print_key, centers, logger, ispin, error) + print_key => section_vals_get_subs_vals(print_loc_section,"WANNIER_CENTERS") + CALL print_wannier_centers(qs_loc_env, print_key, centers, logger, ispin) - CALL cp_print_key_finished_output(unit_out_s,logger,print_loc_section,"WANNIER_SPREADS",error=error) + CALL cp_print_key_finished_output(unit_out_s,logger,print_loc_section,"WANNIER_SPREADS") DEALLOCATE(Qii,ziimax,atom_of_state,diag,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE centers_spreads_pipek @@ -633,20 +622,18 @@ END SUBROUTINE centers_spreads_pipek !> \param print_loc_section ... !> \param myspin ... !> \param ext_mo_coeff ... -!> \param error ... !> \par History !> 04.2005 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& - ext_mo_coeff,error) + ext_mo_coeff) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(section_vals_type), POINTER :: print_loc_section INTEGER, INTENT(IN), OPTIONAL :: myspin TYPE(cp_fm_type), OPTIONAL, POINTER :: ext_mo_coeff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_driver', & routineP = moduleN//':'//routineN @@ -689,10 +676,10 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& CALL get_qs_loc_env(qs_loc_env=qs_loc_env, & localized_wfn_control=localized_wfn_control,& moloc_coeff=moloc_coeff,op_sm_set=op_sm_set, op_fm_set=op_fm_set,cell=cell,& - weights=weights, dim_op=dim_op, error=error) + weights=weights, dim_op=dim_op) CALL get_qs_env(qs_env=qs_env, dft_control=dft_control,& - para_env=para_env, mos=mos, error=error) + para_env=para_env, mos=mos) s_spin = 1 l_spin = dft_control%nspins @@ -711,51 +698,48 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& nmosub = localized_wfn_control%nloc_states(ispin) IF (PRESENT(ext_mo_coeff)) THEN CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmosub,& - ncol_global=nmosub,para_env=para_env,context=ext_mo_coeff%matrix_struct%context,& - error=error) + ncol_global=nmosub,para_env=para_env,context=ext_mo_coeff%matrix_struct%context) ELSE CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmosub,& - ncol_global=nmosub,para_env=para_env,context=mo_coeff%matrix_struct%context,& - error=error) + ncol_global=nmosub,para_env=para_env,context=mo_coeff%matrix_struct%context) END IF ! ALLOCATE ( op_fm_set( 2, dim_op), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i = 1, dim_op DO j = 1, SIZE ( op_fm_set, 1 ) NULLIFY(op_fm_set(j,i)%matrix) - CALL cp_fm_create (op_fm_set(j,i)%matrix , tmp_fm_struct ,error=error) - CALL cp_fm_get_info(op_fm_set(j,i)%matrix, nrow_global=nmosub, & - error=error) - CPPostcondition(nmo>=nmosub,cp_failure_level,routineP,error,failure) - CALL cp_fm_set_all(op_fm_set(j,i)%matrix,0.0_dp,error=error) + CALL cp_fm_create (op_fm_set(j,i)%matrix , tmp_fm_struct) + CALL cp_fm_get_info(op_fm_set(j,i)%matrix, nrow_global=nmosub) + CPPostcondition(nmo>=nmosub,cp_failure_level,routineP,failure) + CALL cp_fm_set_all(op_fm_set(j,i)%matrix,0.0_dp) END DO END DO - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_fm_struct_release(tmp_fm_struct) CALL optimize_loc_berry(loc_method, qs_loc_env, moloc_coeff(ispin)%matrix, op_sm_set,& - op_fm_set, para_env, cell, weights, ispin, print_loc_section, error=error) + op_fm_set, para_env, cell, weights, ispin, print_loc_section) ! Here we dealloctate op_fm_set IF(ASSOCIATED(op_fm_set)) THEN DO i=1,dim_op DO j=1,SIZE ( op_fm_set,1) - CALL cp_fm_release(op_fm_set(j,i)%matrix,error=error) + CALL cp_fm_release(op_fm_set(j,i)%matrix) END DO END DO DEALLOCATE(op_fm_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CASE(op_loc_boys) CALL cp_unimplemented_error(fromWhere=routineP, & message="Boys localization not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE(op_loc_pipek) CALL optimize_loc_pipek(qs_env, loc_method, qs_loc_env, moloc_coeff(ispin)%matrix,& - op_fm_set, ispin, print_loc_section, error=error) + op_fm_set, ispin, print_loc_section) END SELECT @@ -769,7 +753,7 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& IF(localized_wfn_control%set_of_states == state_loc_list) THEN ALLOCATE(vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nmosub = SIZE(localized_wfn_control%loc_states,1) imoloc = 0 DO i = lb,ub @@ -779,17 +763,17 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& imo = localized_wfn_control%loc_states(i,ispin) CALL cp_fm_get_submatrix(moloc_coeff(ispin)%matrix,vecbuffer,1,imoloc,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) IF (PRESENT(ext_mo_coeff)) THEN CALL cp_fm_set_submatrix(ext_mo_coeff,vecbuffer,1,imo,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) ELSE CALL cp_fm_set_submatrix(mo_coeff,vecbuffer,1,imo,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) END IF END DO DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE nmosub = localized_wfn_control%nloc_states(ispin) @@ -807,12 +791,12 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& ! Provides boundaries of MOs CALL section_vals_val_get(print_loc_section,"WANNIER_CUBES%CUBES_LU_BOUNDS",& - i_vals=bounds,error=error) + i_vals=bounds) ncubes = bounds(2) - bounds(1) + 1 IF(ncubes > 0) THEN list_cubes_setup =.TRUE. ALLOCATE( list_cubes(ncubes),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ir = 1,ncubes list_cubes(ir) = bounds(1) + (ir-1) END DO @@ -820,12 +804,12 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& ! Provides the list of MOs CALL section_vals_val_get(print_loc_section,"WANNIER_CUBES%CUBES_LIST",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) IF (.NOT.list_cubes_setup) THEN ncubes = 0 DO ir = 1,n_rep CALL section_vals_val_get(print_loc_section,"WANNIER_CUBES%CUBES_LIST",& - i_rep_val=ir,i_vals=list,error=error) + i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(list_cubes,1,ncubes+ SIZE(list)) DO i = 1, SIZE(list) @@ -843,7 +827,7 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& ncubes = localized_wfn_control%nloc_states(1) IF(ncubes>0) THEN ALLOCATE(list_cubes(ncubes),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DO i = 1, ncubes list_cubes(i) = i @@ -853,7 +837,7 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& ncubes = SIZE(list_cubes) ncubes = MIN(ncubes,nmo) ALLOCATE(centers(6,ncubes),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i = 1, ncubes istate = list_cubes(i) DO j = 1,localized_wfn_control%nloc_states(ispin) @@ -866,8 +850,8 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& END DO ! ncubes ! Real call for dumping the cube files - print_key => section_vals_get_subs_vals(print_loc_section,"WANNIER_CUBES",error=error) - append_cube= section_get_lval(print_loc_section,"WANNIER_CUBES%APPEND",error=error) + print_key => section_vals_get_subs_vals(print_loc_section,"WANNIER_CUBES") + append_cube= section_get_lval(print_loc_section,"WANNIER_CUBES%APPEND") my_pos = "REWIND" IF (append_cube) THEN my_pos = "APPEND" @@ -875,12 +859,12 @@ SUBROUTINE qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin,& CALL qs_print_cubes(qs_env,moloc_coeff(ispin)%matrix,ncubes,list_cubes,centers,& print_key,"loc"//TRIM(ADJUSTL(qs_loc_env%tag_mo)),& - ispin=ispin,file_position=my_pos,error=error) + ispin=ispin,file_position=my_pos) DEALLOCATE(centers,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(list_cubes,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END DO ! ispin first_time = .FALSE. @@ -900,7 +884,6 @@ END SUBROUTINE qs_loc_driver !> \param idir ... !> \param state0 ... !> \param file_position ... -!> \param error ... !> \par History !> 08.2005 created [MI] !> \author MI @@ -908,7 +891,7 @@ END SUBROUTINE qs_loc_driver !> This routine shoul not be in this module ! ***************************************************************************** SUBROUTINE qs_print_cubes(qs_env,mo_coeff,nstates,state_list,centers,& - print_key,root,ispin,idir,state0,file_position,error) + print_key,root,ispin,idir,state0,file_position) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_fm_type), POINTER :: mo_coeff @@ -921,7 +904,6 @@ SUBROUTINE qs_print_cubes(qs_env,mo_coeff,nstates,state_list,centers,& INTEGER, OPTIONAL :: state0 CHARACTER(LEN=default_string_length), & OPTIONAL :: file_position - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_print_cubes', & routineP = moduleN//':'//routineN @@ -952,21 +934,21 @@ SUBROUTINE qs_print_cubes(qs_env,mo_coeff,nstates,state_list,centers,& failure = .FALSE. CALL timeset(routineN,handle) NULLIFY(auxbas_pw_pool, pw_env, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,subsys=subsys,error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,subsys=subsys) + CALL qs_subsys_get(subsys,particles=particles) - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,wf_g%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) my_state0 = 0 IF(PRESENT(state0)) my_state0 = state0 @@ -991,10 +973,10 @@ SUBROUTINE qs_print_cubes(qs_env,mo_coeff,nstates,state_list,centers,& DO istate = 1, nstates ivector = state_list(istate) - my_state0 CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,cell=cell,& - dft_control=dft_control,particle_set=particle_set,pw_env=pw_env,error=error) + dft_control=dft_control,particle_set=particle_set,pw_env=pw_env) CALL calculate_wavefunction(mo_coeff, ivector, wf_r, wf_g, atomic_kind_set, & - qs_kind_set, cell, dft_control, particle_set, pw_env, error=error) + qs_kind_set, cell, dft_control, particle_set, pw_env) ! Formatting the middle part of the name ivector = state_list(istate) @@ -1012,7 +994,7 @@ SUBROUTINE qs_print_cubes(qs_env,mo_coeff,nstates,state_list,centers,& ! Using the print_key tools to open the file with the proper name unit_out_c = cp_print_key_unit_nr(logger,print_key,"",middle_name=filename,& - extension=".cube",file_position=my_pos,log_filename=.FALSE.,error=error) + extension=".cube",file_position=my_pos,log_filename=.FALSE.) IF(SIZE(centers,1)==6) THEN WRITE(title,'(A7,I5.5,A1,I1.1,A1,6F10.4)') "WFN ",ivector,"_s",my_ispin," ",& centers(1:3,istate)*angstrom, centers(4:6,istate)*angstrom @@ -1022,12 +1004,12 @@ SUBROUTINE qs_print_cubes(qs_env,mo_coeff,nstates,state_list,centers,& END IF CALL cp_pw_to_cube(wf_r%pw,unit_out_c,title,& particles=particles,& - stride=section_get_ivals(print_key,"STRIDE",error=error),error=error) - CALL cp_print_key_finished_output(unit_out_c,logger,print_key,"",error=error) + stride=section_get_ivals(print_key,"STRIDE")) + CALL cp_print_key_finished_output(unit_out_c,logger,print_key,"") END DO - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw) CALL timestop(handle) END SUBROUTINE qs_print_cubes @@ -1038,16 +1020,13 @@ END SUBROUTINE qs_print_cubes !> \param center ... !> \param logger ... !> \param ispin ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_wannier_centers(qs_loc_env, print_key, center, logger, ispin, error) + SUBROUTINE print_wannier_centers(qs_loc_env, print_key, center, logger, ispin) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(section_vals_type), POINTER :: print_key REAL(KIND=dp), INTENT(IN) :: center( :, : ) TYPE(cp_logger_type), POINTER :: logger INTEGER, INTENT(IN) :: ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_wannier_centers', & routineP = moduleN//':'//routineN @@ -1061,35 +1040,35 @@ SUBROUTINE print_wannier_centers(qs_loc_env, print_key, center, logger, ispin, e nstates = SIZE(center,2) my_form = "formatted" my_ext = ".data" - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,first_time=first_time,& - error=error),cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,first_time=first_time)& + ,cp_p_file)) THEN ! Find out if we want to print IONS+CENTERS or ONLY CENTERS.. - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,"/IONS+CENTERS",& - error=error),cp_p_file)) THEN - CALL get_output_format(print_key,my_form=my_form,my_ext=my_ext,error=error) + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,"/IONS+CENTERS")& + ,cp_p_file)) THEN + CALL get_output_format(print_key,my_form=my_form,my_ext=my_ext) END IF IF (first_time.OR.(.NOT.qs_loc_env%first_time)) THEN iunit=cp_print_key_unit_nr(logger,print_key,"",extension=my_ext,file_form=my_form,& middle_name=TRIM(qs_loc_env%tag_mo)//"_centers_s"//TRIM(ADJUSTL(cp_to_string(ispin))),& - log_filename=.FALSE.,on_file=.TRUE.,is_new_file=init_traj,error=error) + log_filename=.FALSE.,on_file=.TRUE.,is_new_file=init_traj) IF (iunit>0) THEN ! Gather units of measure for output (if available) - CALL section_vals_val_get(print_key,"UNIT",c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(print_key,"UNIT",c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,"/IONS+CENTERS",error=error),cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,"/IONS+CENTERS"),cp_p_file)) THEN ! Different possible formats - CALL print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, unit_conv, error) + CALL print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, unit_conv) ELSE ! Default print format - iter=cp_iter_string(logger%iter_info,error=error) + iter=cp_iter_string(logger%iter_info) WRITE(iunit,'(i6,/,a)') nstates,TRIM(iter) DO l=1,nstates WRITE(iunit,'(A,4F16.8)') "X", unit_conv*center(1:4,l) END DO END IF END IF - CALL cp_print_key_finished_output(iunit,logger,print_key,on_file=.TRUE.,error=error) + CALL cp_print_key_finished_output(iunit,logger,print_key,on_file=.TRUE.) END IF END IF END SUBROUTINE print_wannier_centers @@ -1102,17 +1081,14 @@ END SUBROUTINE print_wannier_centers !> \param iunit ... !> \param init_traj ... !> \param unit_conv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, unit_conv, error) + SUBROUTINE print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, unit_conv) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(section_vals_type), POINTER :: print_key REAL(KIND=dp), INTENT(IN) :: center( :, : ) INTEGER, INTENT(IN) :: iunit LOGICAL, INTENT(IN) :: init_traj REAL(KIND=dp), INTENT(IN) :: unit_conv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_wannier_traj', & routineP = moduleN//':'//routineN @@ -1128,10 +1104,10 @@ SUBROUTINE print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, u POINTER :: particle_set NULLIFY(particle_set, atomic_kind_set, atomic_kind, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() natom = SIZE(qs_loc_env%particle_set) ntot = natom + SIZE(center,2) - CALL allocate_particle_set(particle_set, ntot,error) + CALL allocate_particle_set(particle_set, ntot) ALLOCATE(atomic_kind_set(1)) atomic_kind => atomic_kind_set(1) CALL set_atomic_kind(atomic_kind=atomic_kind,kind_number=0,& @@ -1147,7 +1123,7 @@ SUBROUTINE print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, u particle_set(i)%r = pbc(center(1:3,i-natom),qs_loc_env%cell) END DO ! Dump the structure - CALL section_vals_val_get(print_key,"FORMAT",i_val=outformat,error=error) + CALL section_vals_val_get(print_key,"FORMAT",i_val=outformat) ! Header file SELECT CASE (outformat) @@ -1160,7 +1136,7 @@ SUBROUTINE print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, u ! levels.. this cannot be exactly reproduce with DCD. ! Just as a compromise let's pick-up the value of the MD iteration ! level. In any case this is not any sensible information for the standard.. - iskip = section_get_ival(print_key,"EACH%MD",error=error) + iskip = section_get_ival(print_key,"EACH%MD") WRITE(iunit) "CORD",0,-1,iskip,& 0,0,0,0,0,0,REAL(0,KIND=sp),1,0,0,0,0,0,0,0,0,24 remark1= "REMARK FILETYPE CORD DCD GENERATED BY CP2K" @@ -1170,16 +1146,16 @@ SUBROUTINE print_wannier_traj(qs_loc_env, print_key, center, iunit, init_traj, u CALL m_flush(iunit) END IF CASE (dump_xmol) - iter = cp_iter_string(logger%iter_info,error=error) + iter = cp_iter_string(logger%iter_info) WRITE (UNIT=title,FMT="(A)")" Particles+Wannier centers. Iteration:"//TRIM(iter) CASE DEFAULT title = "" END SELECT CALL write_particle_coordinates(particle_set,iunit,outformat,"POS",title,qs_loc_env%cell,& - unit_conv=unit_conv, error=error) + unit_conv=unit_conv) CALL m_flush(iunit) - CALL deallocate_particle_set(particle_set,error) - CALL deallocate_atomic_kind_set(atomic_kind_set,error) + CALL deallocate_particle_set(particle_set) + CALL deallocate_atomic_kind_set(atomic_kind_set) END SUBROUTINE print_wannier_traj END MODULE qs_loc_methods diff --git a/src/qs_loc_molecules.F b/src/qs_loc_molecules.F index 6962dde434..598c5cad0a 100644 --- a/src/qs_loc_molecules.F +++ b/src/qs_loc_molecules.F @@ -58,18 +58,15 @@ MODULE qs_loc_molecules !> \param center ... !> \param molecule_set ... !> \param nspins ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & - molecule_set, nspins, error) + molecule_set, nspins) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_loc_env_new_type), INTENT(IN) :: qs_loc_env TYPE(section_vals_type), POINTER :: loc_print_key REAL(KIND=dp), INTENT(IN) :: center( :, : ) TYPE(molecule_type), POINTER :: molecule_set( : ) INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfc_to_molecule', & routineP = moduleN//':'//routineN @@ -101,29 +98,29 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & POINTER :: qs_kind_set failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ! Molecular Dipoles availables only for nspin == 1 IF( BTEST(cp_print_key_should_output(logger%iter_info,loc_print_key,& - "MOLECULAR_DIPOLES",error=error),cp_p_file))THEN + "MOLECULAR_DIPOLES"),cp_p_file))THEN IF (nspins>1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Molecular Dipoles not implemented for SPIN multiplicity "//& - "larger than 1!", error=error, error_level=cp_failure_level) + "larger than 1!",error_level=cp_failure_level) END IF ! Setup reference point and some warning.. - reference = section_get_ival(loc_print_key,keyword_name="MOLECULAR_DIPOLES%REFERENCE",error=error) - CALL section_vals_val_get(loc_print_key,"MOLECULAR_DIPOLES%REF_POINT",r_vals=ref_point,error=error) - CALL section_vals_val_get(loc_print_key,"MOLECULAR_DIPOLES%PERIODIC",l_val=do_berry,error=error) + reference = section_get_ival(loc_print_key,keyword_name="MOLECULAR_DIPOLES%REFERENCE") + CALL section_vals_val_get(loc_print_key,"MOLECULAR_DIPOLES%REF_POINT",r_vals=ref_point) + CALL section_vals_val_get(loc_print_key,"MOLECULAR_DIPOLES%PERIODIC",l_val=do_berry) END IF - CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set, error=error) + CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set) particle_set => qs_loc_env%particle_set para_env => qs_loc_env%para_env local_molecules => qs_loc_env%local_molecules nstate = SIZE ( center, 2 ) ALLOCATE(wfc_to_atom_map(nstate),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !--------------------------------------------------------------------------- !--------------------------------------------------------------------------- nkind = SIZE (local_molecules%n_el) @@ -138,13 +135,13 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & natom_max = natom_max + natom IF (.NOT.ASSOCIATED(molecule_set(i)%lmi)) THEN ALLOCATE(molecule_set(i)%lmi,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(molecule_set(i)%lmi%states) ENDIF molecule_set(i)%lmi%nstates=0 IF(ASSOCIATED(molecule_set(i)%lmi%states)) THEN DEALLOCATE(molecule_set(i)%lmi%states,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO END DO @@ -154,10 +151,10 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & CALL mp_max(natom_max,para_env%group) ALLOCATE(r(3,natom_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(distance(natom_max),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !Zero all the stuff r(:,:) = 0.0_dp @@ -240,7 +237,7 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & ! Figure out dipole of the molecule. !--------------------------------------------------------------------------- IF( BTEST(cp_print_key_should_output(logger%iter_info,loc_print_key,& - "MOLECULAR_DIPOLES",error=error),cp_p_file))THEN + "MOLECULAR_DIPOLES"),cp_p_file))THEN particle_set => qs_loc_env%particle_set para_env => qs_loc_env%para_env @@ -265,7 +262,7 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & ! Get reference point for this molecule CALL get_reference_point(rcc,qs_env=qs_env,reference=reference,& ref_point=ref_point,ifirst=first_atom,& - ilast=first_atom+natom-1,error=error) + ilast=first_atom+natom-1) dipole=0.0_dp IF (do_berry) THEN @@ -275,9 +272,9 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & i=first_atom+iatom-1 atomic_kind=>particle_set(i)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=akind) - CALL get_qs_kind(qs_kind_set(akind), ghost=ghost,error=error) + CALL get_qs_kind(qs_kind_set(akind), ghost=ghost) IF (.NOT.ghost) THEN - CALL get_qs_kind(qs_kind_set(akind), core_charge=zeff,error=error) + CALL get_qs_kind(qs_kind_set(akind), core_charge=zeff) charge_set(imol_now)=charge_set(imol_now)+zeff END IF END DO @@ -296,9 +293,9 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & i=first_atom+iatom-1 atomic_kind=>particle_set(i)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=akind) - CALL get_qs_kind(qs_kind_set(akind), ghost=ghost,error=error) + CALL get_qs_kind(qs_kind_set(akind), ghost=ghost) IF (.NOT.ghost) THEN - CALL get_qs_kind(qs_kind_set(akind), core_charge=zeff,error=error) + CALL get_qs_kind(qs_kind_set(akind), core_charge=zeff) ria = pbc(particle_set(i)%r,cell) DO j = 1, 3 gvec = twopi*cell%h_inv(j,:) @@ -330,9 +327,9 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & i=first_atom+iatom-1 atomic_kind=>particle_set(i)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=akind) - CALL get_qs_kind(qs_kind_set(akind), ghost=ghost,error=error) + CALL get_qs_kind(qs_kind_set(akind), ghost=ghost) IF (.NOT.ghost) THEN - CALL get_qs_kind(qs_kind_set(akind), core_charge=zeff,error=error) + CALL get_qs_kind(qs_kind_set(akind), core_charge=zeff) ria = pbc(particle_set(i)%r,cell) - rcc dipole=dipole + zeff*(ria-rcc) charge_set(imol_now)=charge_set(imol_now)+zeff @@ -353,7 +350,7 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & CALL mp_sum(charge_set,para_env%group) output_unit=cp_print_key_unit_nr(logger,loc_print_key,"MOLECULAR_DIPOLES",& - extension=".MolDip",middle_name="MOLECULAR_DIPOLES",error=error) + extension=".MolDip",middle_name="MOLECULAR_DIPOLES") IF (output_unit>0) THEN WRITE(UNIT=output_unit,FMT='(A80)') "# molecule nr, charge, dipole vector, dipole (Debye) " dipole_set(:,:) = dipole_set(:,:)*debye ! Debye @@ -363,7 +360,7 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & ENDDO ENDIF CALL cp_print_key_finished_output(output_unit,logger,loc_print_key,& - "MOLECULAR_DIPOLES",error=error) + "MOLECULAR_DIPOLES") DEALLOCATE(dipole_set,charge_set) END IF !--------------------------------------------------------------------------- @@ -371,12 +368,12 @@ SUBROUTINE wfc_to_molecule(qs_env, qs_loc_env, loc_print_key, center, & !--------------------------------------------------------------------------- DEALLOCATE(distance,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wfc_to_atom_map,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE wfc_to_molecule !------------------------------------------------------------------------------ diff --git a/src/qs_loc_types.F b/src/qs_loc_types.F index 2d08dd804b..6577a002ea 100644 --- a/src/qs_loc_types.F +++ b/src/qs_loc_types.F @@ -162,15 +162,13 @@ MODULE qs_loc_types ! ***************************************************************************** !> \brief ... !> \param qs_loc_env ... -!> \param error ... !> \par History !> 04-05 created !> \author MI ! ***************************************************************************** - SUBROUTINE qs_loc_env_create(qs_loc_env,error) + SUBROUTINE qs_loc_env_create(qs_loc_env) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_env_create', & routineP = moduleN//':'//routineN @@ -180,10 +178,10 @@ SUBROUTINE qs_loc_env_create(qs_loc_env,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(qs_loc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(qs_loc_env),cp_failure_level,routineP,failure) ALLOCATE(qs_loc_env,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qs_loc_env%ref_count = 1 qs_loc_env%tag_mo="" @@ -204,15 +202,13 @@ END SUBROUTINE qs_loc_env_create ! ***************************************************************************** !> \brief ... !> \param qs_loc_env ... -!> \param error ... !> \par History !> 04-05 created !> \author MI ! ***************************************************************************** - SUBROUTINE qs_loc_env_destroy(qs_loc_env,error) + SUBROUTINE qs_loc_env_destroy(qs_loc_env) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_env_destroy', & routineP = moduleN//':'//routineN @@ -221,48 +217,47 @@ SUBROUTINE qs_loc_env_destroy(qs_loc_env,error) LOGICAL :: failure failure =.FALSE. - CPPrecondition(ASSOCIATED(qs_loc_env),cp_warning_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_loc_env),cp_warning_level,routineP,failure) - IF(ASSOCIATED(qs_loc_env%cell)) CALL cell_release(qs_loc_env%cell,error=error) + IF(ASSOCIATED(qs_loc_env%cell)) CALL cell_release(qs_loc_env%cell) IF(ASSOCIATED(qs_loc_env%local_molecules)) & - CALL distribution_1d_release(qs_loc_env%local_molecules,error=error) + CALL distribution_1d_release(qs_loc_env%local_molecules) IF (ASSOCIATED(qs_loc_env%localized_wfn_control)) THEN - CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control,& - error=error) + CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control) END IF - IF(ASSOCIATED(qs_loc_env%para_env)) CALL cp_para_env_release(qs_loc_env%para_env,error) + IF(ASSOCIATED(qs_loc_env%para_env)) CALL cp_para_env_release(qs_loc_env%para_env) IF(ASSOCIATED(qs_loc_env%particle_set)) NULLIFY(qs_loc_env%particle_set) IF(ASSOCIATED(qs_loc_env%moloc_coeff)) THEN DO i=1,SIZE ( qs_loc_env % moloc_coeff,1) - CALL cp_fm_release(qs_loc_env%moloc_coeff(i)%matrix,error=error) + CALL cp_fm_release(qs_loc_env%moloc_coeff(i)%matrix) END DO DEALLOCATE(qs_loc_env%moloc_coeff,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(qs_loc_env%op_fm_set)) THEN DO i=1,SIZE ( qs_loc_env % op_fm_set,2) DO j=1,SIZE ( qs_loc_env % op_fm_set,1) - CALL cp_fm_release(qs_loc_env%op_fm_set(j,i)%matrix,error=error) + CALL cp_fm_release(qs_loc_env%op_fm_set(j,i)%matrix) END DO END DO DEALLOCATE(qs_loc_env%op_fm_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(qs_loc_env%op_sm_set)) THEN DO i=1,SIZE ( qs_loc_env % op_sm_set, 2 ) DO j=1,SIZE ( qs_loc_env % op_sm_set, 1 ) - CALL cp_dbcsr_deallocate_matrix(qs_loc_env%op_sm_set(j,i)%matrix,error=error) + CALL cp_dbcsr_deallocate_matrix(qs_loc_env%op_sm_set(j,i)%matrix) ENDDO END DO DEALLOCATE(qs_loc_env%op_sm_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(qs_loc_env,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE qs_loc_env_destroy @@ -271,15 +266,13 @@ END SUBROUTINE qs_loc_env_destroy ! ***************************************************************************** !> \brief ... !> \param qs_loc_env ... -!> \param error ... !> \par History !> 04-05 created !> \author MI ! ***************************************************************************** - SUBROUTINE qs_loc_env_release(qs_loc_env,error) + SUBROUTINE qs_loc_env_release(qs_loc_env) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_env_release', & routineP = moduleN//':'//routineN @@ -289,10 +282,10 @@ SUBROUTINE qs_loc_env_release(qs_loc_env,error) failure=.FALSE. IF (ASSOCIATED(qs_loc_env)) THEN - CPPreconditionNoFail(qs_loc_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(qs_loc_env%ref_count>0,cp_failure_level,routineP) qs_loc_env%ref_count = qs_loc_env%ref_count -1 IF (qs_loc_env%ref_count==0) THEN - CALL qs_loc_env_destroy(qs_loc_env,error) + CALL qs_loc_env_destroy(qs_loc_env) END IF END IF END SUBROUTINE qs_loc_env_release @@ -302,15 +295,13 @@ END SUBROUTINE qs_loc_env_release ! ***************************************************************************** !> \brief ... !> \param qs_loc_env ... -!> \param error ... !> \par History !> 04-05 created !> \author MI ! ***************************************************************************** - SUBROUTINE qs_loc_env_retain(qs_loc_env,error) + SUBROUTINE qs_loc_env_retain(qs_loc_env) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_env_retain', & routineP = moduleN//':'//routineN @@ -319,8 +310,8 @@ SUBROUTINE qs_loc_env_retain(qs_loc_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(qs_loc_env),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(qs_loc_env%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(qs_loc_env),cp_failure_level,routineP,failure) + CPPreconditionNoFail(qs_loc_env%ref_count>0,cp_failure_level,routineP) qs_loc_env%ref_count = qs_loc_env%ref_count +1 END SUBROUTINE qs_loc_env_retain @@ -329,14 +320,12 @@ END SUBROUTINE qs_loc_env_retain ! ***************************************************************************** !> \brief create the localized_wfn_control_type !> \param localized_wfn_control ... -!> \param error ... !> \par History !> 04.2005 created [MI] ! ***************************************************************************** - SUBROUTINE localized_wfn_control_create(localized_wfn_control,error) + SUBROUTINE localized_wfn_control_create(localized_wfn_control) TYPE(localized_wfn_control_type), & POINTER :: localized_wfn_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'localized_wfn_control_create', & routineP = moduleN//':'//routineN @@ -346,9 +335,9 @@ SUBROUTINE localized_wfn_control_create(localized_wfn_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(localized_wfn_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(localized_wfn_control),cp_failure_level,routineP,failure) ALLOCATE(localized_wfn_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) localized_wfn_control%ref_count= 1 localized_wfn_control%nloc_states=0 @@ -367,15 +356,13 @@ END SUBROUTINE localized_wfn_control_create ! ***************************************************************************** !> \brief release the localized_wfn_control_type !> \param localized_wfn_control ... -!> \param error ... !> \par History !> 04.2005 created [MI] ! ***************************************************************************** - SUBROUTINE localized_wfn_control_release(localized_wfn_control,error) + SUBROUTINE localized_wfn_control_release(localized_wfn_control) TYPE(localized_wfn_control_type), & POINTER :: localized_wfn_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'localized_wfn_control_release', & @@ -386,24 +373,24 @@ SUBROUTINE localized_wfn_control_release(localized_wfn_control,error) failure=.FALSE. IF(ASSOCIATED(localized_wfn_control)) THEN - CPPrecondition(localized_wfn_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(localized_wfn_control%ref_count>0,cp_failure_level,routineP,failure) localized_wfn_control%ref_count=localized_wfn_control%ref_count-1 IF (localized_wfn_control%ref_count==0) THEN IF (ASSOCIATED(localized_wfn_control%loc_states)) THEN DEALLOCATE(localized_wfn_control%loc_states,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(localized_wfn_control%centers_set(1)%array)) THEN DEALLOCATE(localized_wfn_control%centers_set(1)%array,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(localized_wfn_control%centers_set(2)%array)) THEN DEALLOCATE(localized_wfn_control%centers_set(2)%array,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF localized_wfn_control%ref_count=0 DEALLOCATE(localized_wfn_control,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF END IF END SUBROUTINE localized_wfn_control_release @@ -411,14 +398,12 @@ END SUBROUTINE localized_wfn_control_release ! ***************************************************************************** !> \brief retain the localized_wfn_control_type !> \param localized_wfn_control ... -!> \param error ... !> \par History !> 04.2005 created [MI] ! ***************************************************************************** - SUBROUTINE localized_wfn_control_retain(localized_wfn_control,error) + SUBROUTINE localized_wfn_control_retain(localized_wfn_control) TYPE(localized_wfn_control_type), & POINTER :: localized_wfn_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'localized_wfn_control_retain', & routineP = moduleN//':'//routineN @@ -426,7 +411,7 @@ SUBROUTINE localized_wfn_control_retain(localized_wfn_control,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(localized_wfn_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(localized_wfn_control),cp_failure_level,routineP,failure) localized_wfn_control%ref_count=localized_wfn_control%ref_count+1 END SUBROUTINE localized_wfn_control_retain @@ -448,13 +433,12 @@ END SUBROUTINE localized_wfn_control_retain !> \param particle_set ... !> \param weights ... !> \param dim_op ... -!> \param error ... !> \par History !> 04-05 created !> \author MI ! ***************************************************************************** SUBROUTINE get_qs_loc_env(qs_loc_env,cell,local_molecules,localized_wfn_control,& - moloc_coeff,op_sm_set,op_fm_set,para_env,particle_set,weights,dim_op,error) + moloc_coeff,op_sm_set,op_fm_set,para_env,particle_set,weights,dim_op) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(cell_type), OPTIONAL, POINTER :: cell @@ -474,7 +458,6 @@ SUBROUTINE get_qs_loc_env(qs_loc_env,cell,local_molecules,localized_wfn_control, OPTIONAL, POINTER :: particle_set REAL(dp), DIMENSION(6), OPTIONAL :: weights INTEGER, OPTIONAL :: dim_op - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_qs_loc_env', & routineP = moduleN//':'//routineN @@ -482,7 +465,7 @@ SUBROUTINE get_qs_loc_env(qs_loc_env,cell,local_molecules,localized_wfn_control, LOGICAL :: failure failure =.FALSE. - CPPrecondition(ASSOCIATED(qs_loc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_loc_env),cp_failure_level,routineP,failure) IF (PRESENT(cell)) cell => qs_loc_env%cell IF (PRESENT(moloc_coeff)) moloc_coeff => qs_loc_env%moloc_coeff @@ -513,13 +496,12 @@ END SUBROUTINE get_qs_loc_env !> \param particle_set ... !> \param weights ... !> \param dim_op ... -!> \param error ... !> \par History !> 04-05 created !> \author MI ! ***************************************************************************** SUBROUTINE set_qs_loc_env(qs_loc_env,cell,local_molecules,localized_wfn_control,& - moloc_coeff,op_sm_set,op_fm_set,para_env,particle_set,weights,dim_op,error) + moloc_coeff,op_sm_set,op_fm_set,para_env,particle_set,weights,dim_op) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(cell_type), OPTIONAL, POINTER :: cell @@ -539,7 +521,6 @@ SUBROUTINE set_qs_loc_env(qs_loc_env,cell,local_molecules,localized_wfn_control, OPTIONAL, POINTER :: particle_set REAL(dp), DIMENSION(6), OPTIONAL :: weights INTEGER, OPTIONAL :: dim_op - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_qs_loc_env', & routineP = moduleN//':'//routineN @@ -548,38 +529,38 @@ SUBROUTINE set_qs_loc_env(qs_loc_env,cell,local_molecules,localized_wfn_control, LOGICAL :: failure failure =.FALSE. - CPPrecondition(ASSOCIATED(qs_loc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_loc_env),cp_failure_level,routineP,failure) IF (PRESENT(cell)) THEN - CALL cell_retain(cell, error=error) - CALL cell_release(qs_loc_env%cell,error=error) + CALL cell_retain(cell) + CALL cell_release(qs_loc_env%cell) qs_loc_env%cell => cell END IF IF (PRESENT(local_molecules)) THEN - CALL distribution_1d_retain(local_molecules,error=error) + CALL distribution_1d_retain(local_molecules) IF(ASSOCIATED(qs_loc_env%local_molecules)) & - CALL distribution_1d_release(qs_loc_env%local_molecules,error=error) + CALL distribution_1d_release(qs_loc_env%local_molecules) qs_loc_env%local_molecules => local_molecules END IF IF(PRESENT(localized_wfn_control)) THEN - CALL localized_wfn_control_retain(localized_wfn_control,error=error) - CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control,error=error) + CALL localized_wfn_control_retain(localized_wfn_control) + CALL localized_wfn_control_release(qs_loc_env%localized_wfn_control) qs_loc_env % localized_wfn_control => localized_wfn_control END IF IF(PRESENT(para_env)) THEN - CALL cp_para_env_retain(para_env,error=error) - CALL cp_para_env_release(qs_loc_env%para_env,error=error) + CALL cp_para_env_retain(para_env) + CALL cp_para_env_release(qs_loc_env%para_env) qs_loc_env%para_env => para_env END IF IF (PRESENT(particle_set)) qs_loc_env%particle_set => particle_set IF(PRESENT(moloc_coeff)) THEN IF(ASSOCIATED(qs_loc_env%moloc_coeff )) THEN DO i=1,SIZE ( qs_loc_env % moloc_coeff,1) - CALL cp_fm_release(qs_loc_env%moloc_coeff(i)%matrix,error=error) + CALL cp_fm_release(qs_loc_env%moloc_coeff(i)%matrix) END DO DEALLOCATE(qs_loc_env%moloc_coeff,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(qs_loc_env%moloc_coeff) END IF qs_loc_env%moloc_coeff => moloc_coeff diff --git a/src/qs_loc_utils.F b/src/qs_loc_utils.F index 8e709b157b..f18d15580b 100644 --- a/src/qs_loc_utils.F +++ b/src/qs_loc_utils.F @@ -109,13 +109,11 @@ MODULE qs_loc_utils !> \brief copy old mos to new ones, allocating as necessary !> \param mo_loc_history ... !> \param mo_loc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE retain_history(mo_loc_history, mo_loc, error) + SUBROUTINE retain_history(mo_loc_history, mo_loc) TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mo_loc_history, mo_loc - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_history', & routineP = moduleN//':'//routineN @@ -129,15 +127,15 @@ SUBROUTINE retain_history(mo_loc_history, mo_loc, error) IF (.NOT. ASSOCIATED(mo_loc_history)) THEN ALLOCATE(mo_loc_history(SIZE(mo_loc))) DO i=1,SIZE(mo_loc_history) - CALL cp_fm_create(mo_loc_history(i)%matrix, mo_loc(i)%matrix%matrix_struct,error=error) + CALL cp_fm_create(mo_loc_history(i)%matrix, mo_loc(i)%matrix%matrix_struct) ENDDO ENDIF DO i=1,SIZE(mo_loc_history) - CALL cp_fm_get_info(mo_loc_history(i)%matrix, ncol_global=ncol_hist, error=error) - CALL cp_fm_get_info(mo_loc(i)%matrix, ncol_global=ncol_loc, error=error) - CPPrecondition(ncol_hist==ncol_loc,cp_failure_level,routineP,error,failure) - CALL cp_fm_to_fm(mo_loc(i)%matrix, mo_loc_history(i)%matrix, error=error) + CALL cp_fm_get_info(mo_loc_history(i)%matrix, ncol_global=ncol_hist) + CALL cp_fm_get_info(mo_loc(i)%matrix, ncol_global=ncol_loc) + CPPrecondition(ncol_hist==ncol_loc,cp_failure_level,routineP,failure) + CALL cp_fm_to_fm(mo_loc(i)%matrix, mo_loc_history(i)%matrix) ENDDO CALL timestop(handle) @@ -150,13 +148,11 @@ END SUBROUTINE retain_history !> \param mo_new ... !> \param mo_ref ... !> \param matrix_S ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rotate_state_to_ref(mo_new, mo_ref, matrix_S, error) + SUBROUTINE rotate_state_to_ref(mo_new, mo_ref, matrix_S) TYPE(cp_fm_type), POINTER :: mo_new, mo_ref TYPE(cp_dbcsr_type), POINTER :: matrix_S - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotate_state_to_ref', & routineP = moduleN//':'//routineN @@ -170,55 +166,55 @@ SUBROUTINE rotate_state_to_ref(mo_new, mo_ref, matrix_S, error) CALL timeset(routineN,handle) failure=.FALSE. - CALL cp_fm_get_info(mo_new, nrow_global=nrow, ncol_global=ncol, error=error) - CALL cp_fm_get_info(mo_ref, ncol_global=ncol_ref, error=error) - CPPrecondition(ncol==ncol_ref,cp_failure_level,routineP,error,failure) + CALL cp_fm_get_info(mo_new, nrow_global=nrow, ncol_global=ncol) + CALL cp_fm_get_info(mo_ref, ncol_global=ncol_ref) + CPPrecondition(ncol==ncol_ref,cp_failure_level,routineP,failure) NULLIFY(fm_struct_tmp,o1,o2,o3,o4,smo) - CALL cp_fm_create(smo,mo_ref%matrix_struct,error=error) + CALL cp_fm_create(smo,mo_ref%matrix_struct) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, & ncol_global=ncol, para_env=mo_new%matrix_struct%para_env, & - context=mo_new%matrix_struct%context,error=error) - CALL cp_fm_create(o1,fm_struct_tmp,error=error) - CALL cp_fm_create(o2,fm_struct_tmp,error=error) - CALL cp_fm_create(o3,fm_struct_tmp,error=error) - CALL cp_fm_create(o4,fm_struct_tmp,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=mo_new%matrix_struct%context) + CALL cp_fm_create(o1,fm_struct_tmp) + CALL cp_fm_create(o2,fm_struct_tmp) + CALL cp_fm_create(o3,fm_struct_tmp) + CALL cp_fm_create(o4,fm_struct_tmp) + CALL cp_fm_struct_release(fm_struct_tmp) ! o1 = (mo_new)^T matrix_S mo_ref - CALL cp_dbcsr_sm_fm_multiply(matrix_S,mo_ref,smo,ncol,error=error) - CALL cp_gemm('T','N',ncol,ncol,nrow,1.0_dp, mo_new,smo,0.0_dp,o1,error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_S,mo_ref,smo,ncol) + CALL cp_gemm('T','N',ncol,ncol,nrow,1.0_dp, mo_new,smo,0.0_dp,o1) ! o2 = (o1^T o1) - CALL cp_gemm('T','N',ncol,ncol,ncol,1.0_dp, o1,o1,0.0_dp,o2,error=error) + CALL cp_gemm('T','N',ncol,ncol,ncol,1.0_dp, o1,o1,0.0_dp,o2) ! o2 = (o1^T o1)^-1/2 ALLOCATE(eigenvalues(ncol)) - CALL choose_eigv_solver(o2,o3,eigenvalues,error=error) - CALL cp_fm_to_fm(o3,o4,error=error) + CALL choose_eigv_solver(o2,o3,eigenvalues) + CALL cp_fm_to_fm(o3,o4) eigenvalues(:) = 1.0_dp/SQRT(eigenvalues(:)) CALL cp_fm_column_scale(o4,eigenvalues) - CALL cp_gemm('N','T',ncol,ncol,ncol,1.0_dp,o3,o4,0.0_dp,o2,error=error) + CALL cp_gemm('N','T',ncol,ncol,ncol,1.0_dp,o3,o4,0.0_dp,o2) ! o3 = o1 (o1^T o1)^-1/2 - CALL cp_gemm('N','N',ncol,ncol,ncol,1.0_dp,o1,o2,0.0_dp,o3,error=error) + CALL cp_gemm('N','N',ncol,ncol,ncol,1.0_dp,o1,o2,0.0_dp,o3) ! mo_new o1 (o1^T o1)^-1/2 - CALL cp_gemm('N','N',nrow,ncol,ncol,1.0_dp,mo_new,o3,0.0_dp,smo,error=error) - CALL cp_fm_to_fm(smo,mo_new,error=error) + CALL cp_gemm('N','N',nrow,ncol,ncol,1.0_dp,mo_new,o3,0.0_dp,smo) + CALL cp_fm_to_fm(smo,mo_new) ! XXXXXXX testing - ! CALL cp_gemm('N','T',ncol,ncol,ncol,1.0_dp,o3,o3,0.0_dp,o1,error=error) + ! CALL cp_gemm('N','T',ncol,ncol,ncol,1.0_dp,o3,o3,0.0_dp,o1) ! WRITE(*,*) o1%local_data - ! CALL cp_gemm('T','N',ncol,ncol,ncol,1.0_dp,o3,o3,0.0_dp,o1,error=error) + ! CALL cp_gemm('T','N',ncol,ncol,ncol,1.0_dp,o3,o3,0.0_dp,o1) ! WRITE(*,*) o1%local_data - CALL cp_fm_release(o1,error=error) - CALL cp_fm_release(o2,error=error) - CALL cp_fm_release(o3,error=error) - CALL cp_fm_release(o4,error=error) - CALL cp_fm_release(smo,error=error) + CALL cp_fm_release(o1) + CALL cp_fm_release(o2) + CALL cp_fm_release(o3) + CALL cp_fm_release(o4) + CALL cp_fm_release(smo) CALL timestop(handle) @@ -231,18 +227,16 @@ END SUBROUTINE rotate_state_to_ref !> \param zij_fm_set ... !> \param vectors ... !> \param sweeps ... -!> \param error ... !> \par History !> 05-2005 created !> \author MI ! ***************************************************************************** - SUBROUTINE jacobi_rotation_pipek(zij_fm_set, vectors, sweeps, error) + SUBROUTINE jacobi_rotation_pipek(zij_fm_set, vectors, sweeps) TYPE(cp_fm_p_type), DIMENSION(:, :), & POINTER :: zij_fm_set TYPE(cp_fm_type), POINTER :: vectors INTEGER :: sweeps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'jacobi_rotation_pipek', & routineP = moduleN//':'//routineN @@ -258,10 +252,10 @@ SUBROUTINE jacobi_rotation_pipek(zij_fm_set, vectors, sweeps, error) NULLIFY(rmat) - CALL cp_fm_create(rmat,zij_fm_set(1,1)%matrix%matrix_struct,error=error) - CALL cp_fm_set_all(rmat, 0.0_dp, 1.0_dp, error=error) + CALL cp_fm_create(rmat,zij_fm_set(1,1)%matrix%matrix_struct) + CALL cp_fm_set_all(rmat, 0.0_dp, 1.0_dp) - CALL cp_fm_get_info ( rmat , nrow_global = nstate, error = error ) + CALL cp_fm_get_info ( rmat , nrow_global = nstate) tolerance = 1.0e10_dp sweeps = 0 natom = SIZE(zij_fm_set,1) @@ -297,15 +291,15 @@ SUBROUTINE jacobi_rotation_pipek(zij_fm_set, vectors, sweeps, error) ct = COS(theta) st = SIN(theta) - CALL rotate_rmat_real(istate,jstate,st,ct,rmat,error=error) - CALL rotate_zij_real(istate,jstate,st,ct,zij_fm_set,error=error) + CALL rotate_rmat_real(istate,jstate,st,ct,rmat) + CALL rotate_zij_real(istate,jstate,st,ct,zij_fm_set) END DO END DO - CALL check_tolerance_real(zij_fm_set,tolerance,error=error) + CALL check_tolerance_real(zij_fm_set,tolerance) END DO CALL rotate_orbitals ( rmat, vectors ) - CALL cp_fm_release ( rmat ,error=error) + CALL cp_fm_release ( rmat) END SUBROUTINE jacobi_rotation_pipek @@ -316,17 +310,15 @@ END SUBROUTINE jacobi_rotation_pipek !> \param st ... !> \param ct ... !> \param rmat ... -!> \param error ... !> \par History !> 04.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE rotate_rmat_real(istate,jstate,st,ct,rmat,error) + SUBROUTINE rotate_rmat_real(istate,jstate,st,ct,rmat) INTEGER, INTENT(IN) :: istate, jstate REAL(dp), INTENT(IN) :: st, ct TYPE(cp_fm_type), POINTER :: rmat - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: nstate #if defined(__SCALAPACK) @@ -335,7 +327,7 @@ SUBROUTINE rotate_rmat_real(istate,jstate,st,ct,rmat,error) LOGICAL :: failure failure = .FALSE. - CALL cp_fm_get_info(rmat, nrow_global=nstate, error=error) + CALL cp_fm_get_info(rmat, nrow_global=nstate) #if defined(__SCALAPACK) desc(:) = rmat%matrix_struct%descriptor(:) CALL pzrot(nstate,rmat%local_data(1,1),1,istate,desc,1,& @@ -354,18 +346,16 @@ END SUBROUTINE rotate_rmat_real !> \param st ... !> \param ct ... !> \param zij ... -!> \param error ... !> \par History !> 04.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE rotate_zij_real(istate,jstate,st,ct,zij,error) + SUBROUTINE rotate_zij_real(istate,jstate,st,ct,zij) INTEGER, INTENT(IN) :: istate, jstate REAL(dp), INTENT(IN) :: st, ct TYPE(cp_fm_p_type), DIMENSION(:, :), & POINTER :: zij - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iatom, natom, nstate #if defined(__SCALAPACK) @@ -376,7 +366,7 @@ SUBROUTINE rotate_zij_real(istate,jstate,st,ct,zij,error) LOGICAL :: failure failure = .FALSE. - CALL cp_fm_get_info(zij(1,1)%matrix,nrow_global = nstate, error=error) + CALL cp_fm_get_info(zij(1,1)%matrix,nrow_global = nstate) natom = SIZE(zij, 1) DO iatom = 1, natom @@ -403,16 +393,14 @@ END SUBROUTINE rotate_zij_real !> \brief ... !> \param zij_fm_set ... !> \param tolerance ... -!> \param error ... !> \par History !> 04.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE check_tolerance_real(zij_fm_set,tolerance,error) + SUBROUTINE check_tolerance_real(zij_fm_set,tolerance) TYPE(cp_fm_p_type), DIMENSION(:, :) :: zij_fm_set REAL(dp), INTENT(OUT) :: tolerance - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: iatom, istat, istate, jstate, & natom, ncol_local, & @@ -429,12 +417,12 @@ SUBROUTINE check_tolerance_real(zij_fm_set,tolerance,error) natom = SIZE(zij_fm_set,1) CALL cp_fm_get_info ( zij_fm_set(1,1)%matrix, nrow_local = nrow_local, & ncol_local = ncol_local, nrow_global = nrow_global, & - row_indices = row_indices, col_indices = col_indices, error = error ) + row_indices = row_indices, col_indices = col_indices) ALLOCATE(diag(nrow_global,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,"check_tolerance_real",error,failure) + CPPostcondition(istat==0,cp_failure_level,"check_tolerance_real",failure) - CALL cp_fm_create(force , zij_fm_set(1,1)%matrix%matrix_struct,error=error) - CALL cp_fm_set_all (force, 0._dp, error= error) + CALL cp_fm_create(force , zij_fm_set(1,1)%matrix%matrix_struct) + CALL cp_fm_set_all (force, 0._dp) DO iatom = 1,natom DO istate = 1,nrow_global @@ -456,11 +444,11 @@ SUBROUTINE check_tolerance_real(zij_fm_set,tolerance,error) END DO DEALLOCATE(diag,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,"check_tolerance_real",error,failure) + CPPostcondition(istat==0,cp_failure_level,"check_tolerance_real",failure) - CALL cp_fm_maxabsval ( force, tolerance, error = error ) + CALL cp_fm_maxabsval ( force, tolerance) - CALL cp_fm_release ( force ,error=error) + CALL cp_fm_release ( force) END SUBROUTINE check_tolerance_real @@ -473,8 +461,6 @@ END SUBROUTINE check_tolerance_real !> \param do_localize ... !> \param loc_coeff ... !> \param mo_loc_history ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2005 created [MI] !> \author MI @@ -482,7 +468,7 @@ END SUBROUTINE check_tolerance_real !> similar to the old one, but not quite ! ***************************************************************************** SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_localize,& - loc_coeff, mo_loc_history, error) + loc_coeff, mo_loc_history) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(localized_wfn_control_type), & @@ -492,7 +478,6 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc LOGICAL, INTENT(IN), OPTIONAL :: do_localize TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: loc_coeff, mo_loc_history - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_env_init', & routineP = moduleN//':'//routineN @@ -527,7 +512,7 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc IF (qs_loc_env%do_localize) THEN CALL get_qs_env(qs_env=qs_env, matrix_s=matrix_s, cell=cell, & local_molecules=local_molecules,particle_set=particle_set, & - para_env=para_env,mos=mos, error=error) + para_env=para_env,mos=mos) nspins = SIZE(mos,1) s_spin = 1 l_spin = nspins @@ -538,25 +523,25 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc my_nspins = 1 END IF ALLOCATE (moloc_coeff(my_nspins), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = s_spin,l_spin NULLIFY(tmp_fm_struct,mo_coeff) CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff,nao=nao,nmo=nmo) nmosub = localized_wfn_control%nloc_states(ispin) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& - ncol_global=nmosub,para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create (moloc_coeff(ispin)%matrix , tmp_fm_struct ,error=error) + ncol_global=nmosub,para_env=para_env,context=mo_coeff%matrix_struct%context) + CALL cp_fm_create (moloc_coeff(ispin)%matrix , tmp_fm_struct) CALL cp_fm_get_info(moloc_coeff(ispin)%matrix, nrow_global=naosub, & - ncol_global=nmosub,error=error) - CPPostcondition(nao==naosub,cp_failure_level,routineP,error,failure) + ncol_global=nmosub) + CPPostcondition(nao==naosub,cp_failure_level,routineP,failure) IF(localized_wfn_control%do_homo)THEN - CPPostcondition(nmo>=nmosub,cp_failure_level,routineP,error,failure) + CPPostcondition(nmo>=nmosub,cp_failure_level,routineP,failure) ELSE - CPPostcondition(nao-nmo>=nmosub,cp_failure_level,routineP,error,failure) + CPPostcondition(nao-nmo>=nmosub,cp_failure_level,routineP,failure) END IF - CALL cp_fm_set_all(moloc_coeff(ispin)%matrix,0.0_dp,error=error) - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + CALL cp_fm_set_all(moloc_coeff(ispin)%matrix,0.0_dp) + CALL cp_fm_struct_release ( tmp_fm_struct) END DO ! ispin ! Copy the submatrix @@ -573,12 +558,12 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc END IF IF(localized_wfn_control%set_of_states == state_loc_list) THEN ALLOCATE(vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(localized_wfn_control%do_homo)THEN my_occ = occupations(localized_wfn_control%loc_states(1, ispin)) END IF nmosub = SIZE(localized_wfn_control%loc_states,1) - CPPostcondition(nmosub>0,cp_failure_level,routineP,error,failure) + CPPostcondition(nmosub>0,cp_failure_level,routineP,failure) imoloc = 0 DO i = lb,ub ! Get the index in the subset @@ -596,12 +581,12 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc END IF ! Take the imo vector from the full set and copy in the imoloc vector of the subset CALL cp_fm_get_submatrix(mat_ptr,vecbuffer,1,imo,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) CALL cp_fm_set_submatrix(moloc_coeff(ispin)%matrix,vecbuffer,1,imoloc,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) END DO DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE my_occ = occupations( lb ) occ_imo = occupations( ub ) @@ -620,8 +605,7 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc IF (PRESENT(mo_loc_history)) THEN IF (localized_wfn_control%use_history .AND. ASSOCIATED(mo_loc_history)) THEN CALL rotate_state_to_ref(moloc_coeff(ispin)%matrix, & - mo_loc_history(ispin)%matrix, matrix_s(1)%matrix, & - error=error) + mo_loc_history(ispin)%matrix, matrix_s(1)%matrix) ENDIF ENDIF @@ -629,14 +613,14 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc CALL set_qs_loc_env(qs_loc_env=qs_loc_env, cell=cell, local_molecules=local_molecules,& moloc_coeff=moloc_coeff, particle_set=particle_set,para_env=para_env,& - localized_wfn_control=localized_wfn_control,error=error) + localized_wfn_control=localized_wfn_control) ! Prepare the operators NULLIFY(tmp_fm_struct,mo_coeff) nmosub = MAXVAL(localized_wfn_control%nloc_states) CALL get_mo_set(mos(1)%mo_set, mo_coeff=mo_coeff) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmosub,& - ncol_global=nmosub,para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) + ncol_global=nmosub,para_env=para_env,context=mo_coeff%matrix_struct%context) IF ( localized_wfn_control%operator_type==op_loc_berry ) THEN IF(qs_loc_env%cell%orthorhombic) THEN @@ -644,50 +628,48 @@ SUBROUTINE qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env,myspin,do_loc ELSE dim_op = 6 END IF - CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=dim_op, error=error) + CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=dim_op) ALLOCATE ( qs_loc_env % op_sm_set ( 2, dim_op ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1, dim_op DO j=1, SIZE ( qs_loc_env % op_sm_set, 1 ) NULLIFY(qs_loc_env%op_sm_set(j,i)%matrix) ALLOCATE(qs_loc_env%op_sm_set(j,i)%matrix) - CALL cp_dbcsr_init(qs_loc_env%op_sm_set(j,i)%matrix, error=error) + CALL cp_dbcsr_init(qs_loc_env%op_sm_set(j,i)%matrix) CALL cp_dbcsr_copy(qs_loc_env%op_sm_set(j,i)%matrix, matrix_s(1)%matrix,& - name="qs_loc_env%op_sm_"//TRIM(ADJUSTL(cp_to_string(j)))//"-"//TRIM(ADJUSTL(cp_to_string(i))),& - error=error) - CALL cp_dbcsr_set(qs_loc_env%op_sm_set(j,i)%matrix,0.0_dp,error=error) + name="qs_loc_env%op_sm_"//TRIM(ADJUSTL(cp_to_string(j)))//"-"//TRIM(ADJUSTL(cp_to_string(i)))) + CALL cp_dbcsr_set(qs_loc_env%op_sm_set(j,i)%matrix,0.0_dp) ENDDO END DO ELSEIF ( localized_wfn_control%operator_type== op_loc_pipek) THEN natoms = SIZE ( qs_loc_env % particle_set, 1 ) ALLOCATE ( qs_loc_env % op_fm_set ( natoms , 1 ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=natoms, error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL set_qs_loc_env(qs_loc_env=qs_loc_env, dim_op=natoms) DO ispin = 1, SIZE(qs_loc_env % op_fm_set ,2) CALL get_mo_set(mos(ispin)%mo_set,nmo=nmo) DO iatom = 1,natoms NULLIFY(qs_loc_env %op_fm_set(iatom,ispin)%matrix) - CALL cp_fm_create (qs_loc_env % op_fm_set(iatom,ispin)%matrix , tmp_fm_struct ,error=error) + CALL cp_fm_create (qs_loc_env % op_fm_set(iatom,ispin)%matrix , tmp_fm_struct) - CALL cp_fm_get_info(qs_loc_env %op_fm_set(iatom,ispin)%matrix, nrow_global=nmosub, & - error=error) - CPPostcondition(nmo>=nmosub,cp_failure_level,routineP,error,failure) - CALL cp_fm_set_all(qs_loc_env %op_fm_set(iatom,ispin)%matrix,0.0_dp,error=error) + CALL cp_fm_get_info(qs_loc_env %op_fm_set(iatom,ispin)%matrix, nrow_global=nmosub) + CPPostcondition(nmo>=nmosub,cp_failure_level,routineP,failure) + CALL cp_fm_set_all(qs_loc_env %op_fm_set(iatom,ispin)%matrix,0.0_dp) END DO ! iatom END DO ! ispin ELSE CALL stop_program(routineN,moduleN,__LINE__,& "Type of operator not implemented") ENDIF - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + CALL cp_fm_struct_release ( tmp_fm_struct) IF ( localized_wfn_control%operator_type==op_loc_berry ) THEN CALL initialize_weights ( qs_loc_env % cell, qs_loc_env % weights ) - CALL get_berry_operator ( qs_loc_env, qs_env , error=error) + CALL get_berry_operator ( qs_loc_env, qs_env) ELSEIF ( localized_wfn_control%operator_type== op_loc_pipek) THEN @@ -713,8 +695,6 @@ END SUBROUTINE qs_loc_env_init !> the pair lists are exploited and sparse matrixes are constructed !> \param qs_loc_env new environment for the localization calculations !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2005 created [MI] !> \author MI @@ -722,10 +702,9 @@ END SUBROUTINE qs_loc_env_init !> The intgrals are computed analytically using the primitives GTO !> The contraction is performed block-wise ! ***************************************************************************** - SUBROUTINE get_berry_operator ( qs_loc_env, qs_env, error ) + SUBROUTINE get_berry_operator ( qs_loc_env, qs_env) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_berry_operator', & routineP = moduleN//':'//routineN @@ -775,13 +754,12 @@ SUBROUTINE get_berry_operator ( qs_loc_env, qs_env, error ) NULLIFY (set_radius_a,set_radius_b,rpgfa, rpgfb, sphi_a,sphi_b,zeta, zetb ) CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set,& - particle_set=particle_set, sab_orb=sab_orb,& - error=error) + particle_set=particle_set, sab_orb=sab_orb) nkind = SIZE(qs_kind_set) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& - maxco=ldwork, maxlgto=maxl,error=error ) + maxco=ldwork, maxlgto=maxl) ldab = ldwork ALLOCATE(cosab(ldab,ldab)) cosab = 0.0_dp @@ -791,12 +769,12 @@ SUBROUTINE get_berry_operator ( qs_loc_env, qs_env, error ) work = 0.0_dp CALL get_qs_loc_env(qs_loc_env=qs_loc_env, op_sm_set=op_sm_set, & - cell=cell, dim_op=dim_op, error=error) + cell=cell, dim_op=dim_op) ALLOCATE (op_cos(dim_op),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (op_sin(dim_op),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i = 1, dim_op NULLIFY (op_cos(i)%block) NULLIFY (op_sin(i)%block) @@ -818,10 +796,10 @@ SUBROUTINE get_berry_operator ( qs_loc_env, qs_env, error ) cell%perd(1:3) = 1 ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -944,10 +922,10 @@ SUBROUTINE get_berry_operator ( qs_loc_env, qs_env, error ) NULLIFY(op_sin(i)%block) END DO DEALLOCATE(op_cos,op_sin, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cosab,sinab,work,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE get_berry_operator @@ -960,10 +938,9 @@ END SUBROUTINE get_berry_operator !> \param coeff_localized ... !> \param do_homo ... !> \param evals ... -!> \param error ... ! ***************************************************************************** SUBROUTINE loc_write_restart(qs_loc_env,section,mo_array, coeff_localized,& - do_homo, evals, error) + do_homo, evals) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(section_vals_type), POINTER :: section TYPE(mo_set_p_type), DIMENSION(:), & @@ -973,7 +950,6 @@ SUBROUTINE loc_write_restart(qs_loc_env,section,mo_array, coeff_localized,& LOGICAL, INTENT(IN) :: do_homo TYPE(cp_1d_r_p_type), DIMENSION(:), & OPTIONAL, POINTER :: evals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'loc_write_restart', & routineP = moduleN//':'//routineN @@ -991,14 +967,14 @@ SUBROUTINE loc_write_restart(qs_loc_env,section,mo_array, coeff_localized,& CALL timeset(routineN,handle) failure = .FALSE. NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) IF (qs_loc_env%do_localize) THEN - print_key => section_vals_get_subs_vals(section,"LOC_RESTART",error=error) + print_key => section_vals_get_subs_vals(section,"LOC_RESTART") IF (BTEST(cp_print_key_should_output(logger%iter_info,& - section,"LOC_RESTART",error=error),& + section,"LOC_RESTART"),& cp_p_file)) THEN ! Open file @@ -1012,11 +988,11 @@ SUBROUTINE loc_write_restart(qs_loc_env,section,mo_array, coeff_localized,& rst_unit = cp_print_key_unit_nr(logger,section,"LOC_RESTART",& extension=".wfn", file_status="REPLACE", file_action="WRITE",& - file_form="UNFORMATTED",middle_name=TRIM(my_middle), error=error) + file_form="UNFORMATTED",middle_name=TRIM(my_middle)) IF(rst_unit>0) filename = cp_print_key_generate_filename(logger,print_key,& middle_name=TRIM(my_middle),extension=".wfn",& - my_local=.FALSE.,error=error) + my_local=.FALSE.) IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A, A/)")& @@ -1032,7 +1008,7 @@ SUBROUTINE loc_write_restart(qs_loc_env,section,mo_array, coeff_localized,& DO ispin = 1,SIZE(coeff_localized) mo_coeff => coeff_localized(ispin)%matrix - CALL cp_fm_get_info(mo_coeff, nrow_global=nao,ncol_global=nmo,ncol_block=max_block,error=error) + CALL cp_fm_get_info(mo_coeff, nrow_global=nao,ncol_global=nmo,ncol_block=max_block) nloc=qs_loc_env%localized_wfn_control%nloc_states(ispin) IF(rst_unit>0) THEN WRITE(rst_unit) qs_loc_env%localized_wfn_control%loc_states(1:nloc,ispin) @@ -1049,12 +1025,12 @@ SUBROUTINE loc_write_restart(qs_loc_env,section,mo_array, coeff_localized,& END IF END IF - CALL cp_fm_write_unformatted(mo_coeff,rst_unit,error) + CALL cp_fm_write_unformatted(mo_coeff,rst_unit) END DO CALL cp_print_key_finished_output(rst_unit,logger,section,& - "LOC_RESTART", error=error) + "LOC_RESTART") END IF END IF @@ -1075,10 +1051,9 @@ END SUBROUTINE loc_write_restart !> \param do_homo ... !> \param restart_found ... !> \param evals ... -!> \param error ... ! ***************************************************************************** SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para_env,& - do_homo,restart_found, evals,error) + do_homo,restart_found, evals) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(mo_set_p_type), DIMENSION(:), & @@ -1091,7 +1066,6 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para LOGICAL, INTENT(INOUT) :: restart_found TYPE(cp_1d_r_p_type), DIMENSION(:), & OPTIONAL, POINTER :: evals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'loc_read_restart', & routineP = moduleN//':'//routineN @@ -1110,7 +1084,7 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. nspin = SIZE(mos_localized) @@ -1120,7 +1094,7 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para group = para_env%group source = para_env%source output_unit = cp_print_key_unit_nr(logger,section2,& - "PROGRAM_RUN_INFO", extension=".Log",error=error) + "PROGRAM_RUN_INFO", extension=".Log") IF(do_homo) THEN fname_key="LOCHOMO_RESTART_FILE_NAME" @@ -1133,12 +1107,12 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para END IF file_exists = .FALSE. - CALL section_vals_val_get(section,fname_key,n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(section,fname_key,n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CALL section_vals_val_get(section,fname_key,c_val=filename,error=error) + CALL section_vals_val_get(section,fname_key,c_val=filename) ELSE - print_key => section_vals_get_subs_vals(section2,"LOC_RESTART",error=error) + print_key => section_vals_get_subs_vals(section2,"LOC_RESTART") IF(do_homo) THEN my_middle="LOC_HOMO" ELSE @@ -1146,7 +1120,7 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para END IF filename = cp_print_key_generate_filename(logger,print_key,& middle_name=TRIM(my_middle),extension=".wfn",& - my_local=.FALSE.,error=error) + my_local=.FALSE.) END IF IF (para_env%ionode) INQUIRE(FILE=filename,exist=file_exists) @@ -1180,12 +1154,12 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para max_nloc = MAXVAL(qs_loc_env%localized_wfn_control%nloc_states(:)) ALLOCATE (vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(ASSOCIATED(qs_loc_env%localized_wfn_control%loc_states)) THEN DEALLOCATE(qs_loc_env%localized_wfn_control%loc_states,STAT=istat) END IF ALLOCATE(qs_loc_env%localized_wfn_control%loc_states(max_nloc,2),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qs_loc_env%localized_wfn_control%loc_states = 0 DO ispin=1,nspin @@ -1200,14 +1174,14 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para IF(do_homo) THEN READ (rst_unit) nmo_read, homo_read, lfomo_read, nelectron_read ALLOCATE(eig_read(nmo_read), occ_read(nmo_read), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) eig_read = 0.0_dp occ_read = 0.0_dp READ (rst_unit) eig_read(1:nmo_read), occ_read(1:nmo_read) ELSE READ (rst_unit) nmo_read ALLOCATE(eig_read(nmo_read), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) eig_read = 0.0_dp READ (rst_unit) eig_read(1:nmo_read) END IF @@ -1227,11 +1201,11 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para mos(ispin)%mo_set%eigenvalues(1:nmo) = eig_read(1:nmo) mos(ispin)%mo_set%occupation_numbers(1:nmo) = occ_read(1:nmo) DEALLOCATE(eig_read, occ_read, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE evals(ispin)%array(1:nmo) = eig_read(1:nmo) DEALLOCATE(eig_read, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -1250,14 +1224,14 @@ SUBROUTINE loc_read_restart(qs_loc_env,mos,mos_localized,section, section2,para END IF CALL mp_bcast(vecbuffer,source,group) CALL cp_fm_set_submatrix(mos_localized(ispin)%matrix,& - vecbuffer,1,i,nao,1,transpose=.TRUE.,error=error) + vecbuffer,1,i,nao,1,transpose=.TRUE.) END DO END DO CALL mp_bcast(qs_loc_env%localized_wfn_control%loc_states,source,group) DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF @@ -1277,18 +1251,16 @@ END SUBROUTINE loc_read_restart !> \param do_homo ... !> \param do_xas ... !> \param nloc_xas ... -!> \param error ... !> \par History !> 2009 created ! ***************************************************************************** - SUBROUTINE qs_loc_control_init(qs_loc_env,loc_section,do_homo,do_xas,nloc_xas,error) + SUBROUTINE qs_loc_control_init(qs_loc_env,loc_section,do_homo,do_xas,nloc_xas) TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(section_vals_type), POINTER :: loc_section LOGICAL, INTENT(IN) :: do_homo LOGICAL, INTENT(IN), OPTIONAL :: do_xas INTEGER, INTENT(IN), OPTIONAL :: nloc_xas - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_control_init', & routineP = moduleN//':'//routineN @@ -1298,13 +1270,13 @@ SUBROUTINE qs_loc_control_init(qs_loc_env,loc_section,do_homo,do_xas,nloc_xas,er NULLIFY(localized_wfn_control) - CALL localized_wfn_control_create(localized_wfn_control,error=error) - CALL set_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control,error=error) - CALL localized_wfn_control_release(localized_wfn_control,error=error) - CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control,error=error) + CALL localized_wfn_control_create(localized_wfn_control) + CALL set_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control) + CALL localized_wfn_control_release(localized_wfn_control) + CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control) localized_wfn_control%do_homo=do_homo CALL read_loc_section(localized_wfn_control,loc_section,& - qs_loc_env%do_localize,do_xas,nloc_xas,error=error) + qs_loc_env%do_localize,do_xas,nloc_xas) END SUBROUTINE qs_loc_control_init @@ -1318,10 +1290,9 @@ END SUBROUTINE qs_loc_control_init !> \param do_mo_cubes ... !> \param mo_loc_history ... !> \param evals ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_loc_init(qs_env,qs_loc_env,localize_section,mos_localized, & - do_homo,do_mo_cubes,mo_loc_history,evals,error) + do_homo,do_mo_cubes,mo_loc_history,evals) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(section_vals_type), POINTER :: localize_section @@ -1332,7 +1303,6 @@ SUBROUTINE qs_loc_init(qs_env,qs_loc_env,localize_section,mos_localized, & OPTIONAL, POINTER :: mo_loc_history TYPE(cp_1d_r_p_type), DIMENSION(:), & OPTIONAL, POINTER :: evals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_loc_init', & routineP = moduleN//':'//routineN @@ -1362,12 +1332,11 @@ SUBROUTINE qs_loc_init(qs_env,qs_loc_env,localize_section,mos_localized, & matrix_ks=ks_rmpv,& mo_derivs=mo_derivs,& scf_control=scf_control,& - para_env=para_env,& - error=error) + para_env=para_env) - loc_print_section => section_vals_get_subs_vals(localize_section,"PRINT",error=error) + loc_print_section => section_vals_get_subs_vals(localize_section,"PRINT") - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) nspin = SIZE(mos) @@ -1384,10 +1353,10 @@ SUBROUTINE qs_loc_init(qs_env,qs_loc_env,localize_section,mos_localized, & restart_found = .FALSE. IF (qs_loc_env%do_localize) THEN ! Some setup for MOs to be localized - CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control,error=error) + CALL get_qs_loc_env(qs_loc_env,localized_wfn_control=localized_wfn_control) IF(localized_wfn_control%loc_restart) THEN CALL loc_read_restart(qs_loc_env,mos,mos_localized,localize_section,& - loc_print_section,para_env,my_do_homo,restart_found,evals=evals,error=error) + loc_print_section,para_env,my_do_homo,restart_found,evals=evals) IF (output_unit>0) WRITE(output_unit,"(/,T2,A,A)") "LOCALIZATION| ",& " The orbitals to be localized are read from localization restart file." nmoloc = localized_wfn_control%nloc_states @@ -1399,9 +1368,9 @@ SUBROUTINE qs_loc_init(qs_env,qs_loc_env,localize_section,mos_localized, & mo_coeff=mo_coeff, eigenvalues=mo_eigenvalues, occupation_numbers=occupation) ! Get eigenstates (only needed if not already calculated before) IF ((.NOT.my_do_mo_cubes)& -! .OR. section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO",error=error)==0)& +! .OR. section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO")==0)& .AND.my_do_homo .AND. qs_env%scf_env%method==ot_method_nr) THEN - CALL make_mo_eig(mos,nspin,ks_rmpv,scf_control,mo_derivs,error=error) + CALL make_mo_eig(mos,nspin,ks_rmpv,scf_control,mo_derivs) END IF IF(localized_wfn_control%set_of_states == state_loc_all.AND.my_do_homo) THEN nmoloc(ispin) = NINT(nelectron/occupation(1)) @@ -1478,12 +1447,12 @@ SUBROUTINE qs_loc_init(qs_env,qs_loc_env,localize_section,mos_localized, & ENDDO ! ispin n_mos(:)=nao-n_mo(:) IF(my_do_homo)n_mos=n_mo - CALL set_loc_wfn_lists(localized_wfn_control,nmoloc,n_mos,nspin,error=error) + CALL set_loc_wfn_lists(localized_wfn_control,nmoloc,n_mos,nspin) END IF - CALL set_loc_centers(localized_wfn_control,nmoloc,nspin,error=error) + CALL set_loc_centers(localized_wfn_control,nmoloc,nspin) IF(my_do_homo)THEN CALL qs_loc_env_init(qs_loc_env,localized_wfn_control,qs_env, & - loc_coeff=mos_localized,mo_loc_history=mo_loc_history,error=error) + loc_coeff=mos_localized,mo_loc_history=mo_loc_history) END IF ELSE ! Let's inform in case the section is not present in the input @@ -1506,12 +1475,11 @@ END SUBROUTINE qs_loc_init !> \param localize ... !> \param do_xas ... !> \param nloc_xas ... -!> \param error ... !> \par History !> 05.2005 created [MI] ! ***************************************************************************** SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& - localize,do_xas,nloc_xas,error) + localize,do_xas,nloc_xas) TYPE(localized_wfn_control_type), & POINTER :: localized_wfn_control @@ -1519,7 +1487,6 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& LOGICAL, INTENT(OUT) :: localize LOGICAL, INTENT(IN), OPTIONAL :: do_xas INTEGER, INTENT(IN), OPTIONAL :: nloc_xas - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_loc_section', & routineP = moduleN//':'//routineN @@ -1537,16 +1504,16 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& my_do_xas=.FALSE. IF(PRESENT(do_xas)) THEN my_do_xas=do_xas - CPPrecondition(PRESENT(nloc_xas),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(nloc_xas),cp_failure_level,routineP,failure) END IF - CPPrecondition(ASSOCIATED(loc_section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(loc_section),cp_failure_level,routineP,failure) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF(.NOT. failure) THEN - CALL section_vals_val_get(loc_section,"_SECTION_PARAMETERS_",l_val=localize,error=error) + CALL section_vals_val_get(loc_section,"_SECTION_PARAMETERS_",l_val=localize) IF(localize) THEN - loc_print_section => section_vals_get_subs_vals(loc_section,"PRINT",error=error) + loc_print_section => section_vals_get_subs_vals(loc_section,"PRINT") NULLIFY (list) NULLIFY (loc_list) localized_wfn_control%lu_bound_states = 0 @@ -1556,40 +1523,40 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& n_state = 0 CALL section_vals_val_get(loc_section,"MAX_ITER",& - i_val=localized_wfn_control%max_iter,error=error) + i_val=localized_wfn_control%max_iter) CALL section_vals_val_get(loc_section,"MAX_CRAZY_ANGLE",& - r_val=localized_wfn_control%max_crazy_angle,error=error) + r_val=localized_wfn_control%max_crazy_angle) CALL section_vals_val_get(loc_section,"CRAZY_SCALE",& - r_val=localized_wfn_control%crazy_scale,error=error) + r_val=localized_wfn_control%crazy_scale) CALL section_vals_val_get(loc_section,"EPS_OCCUPATION",& - r_val=localized_wfn_control%eps_occ,error=error) + r_val=localized_wfn_control%eps_occ) CALL section_vals_val_get(loc_section,"CRAZY_USE_DIAG",& - l_val=localized_wfn_control%crazy_use_diag,error=error) + l_val=localized_wfn_control%crazy_use_diag) CALL section_vals_val_get(loc_section,"OUT_ITER_EACH",& - i_val=localized_wfn_control%out_each,error=error) + i_val=localized_wfn_control%out_each) CALL section_vals_val_get(loc_section,"EPS_LOCALIZATION",& - r_val=localized_wfn_control%eps_localization,error=error) + r_val=localized_wfn_control%eps_localization) CALL section_vals_val_get(loc_section,"MIN_OR_MAX",& - i_val=localized_wfn_control%min_or_max,error=error) + i_val=localized_wfn_control%min_or_max) CALL section_vals_val_get(loc_section,"JACOBI_FALLBACK",& - l_val=localized_wfn_control%jacobi_fallback,error=error) + l_val=localized_wfn_control%jacobi_fallback) CALL section_vals_val_get(loc_section,"METHOD",& - i_val=localized_wfn_control%localization_method,error=error) + i_val=localized_wfn_control%localization_method) CALL section_vals_val_get(loc_section,"OPERATOR",& - i_val=localized_wfn_control%operator_type,error=error) + i_val=localized_wfn_control%operator_type) CALL section_vals_val_get(loc_section,"RESTART",& - l_val=localized_wfn_control%loc_restart,error=error) + l_val=localized_wfn_control%loc_restart) CALL section_vals_val_get(loc_section,"USE_HISTORY",& - l_val=localized_wfn_control%use_history,error=error) + l_val=localized_wfn_control%use_history) IF(localized_wfn_control%do_homo)THEN ! List of States HOMO - CALL section_vals_val_get(loc_section,"LIST", n_rep_val=n_rep,error=error) + CALL section_vals_val_get(loc_section,"LIST", n_rep_val=n_rep) IF(n_rep>0) THEN n_list = 0 DO ir = 1,n_rep NULLIFY(list) - CALL section_vals_val_get(loc_section,"LIST",i_rep_val=ir,i_vals=list,error=error) + CALL section_vals_val_get(loc_section,"LIST",i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(loc_list,1,n_list+SIZE(list)) DO i = 1, SIZE(list) @@ -1601,7 +1568,7 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& IF(n_list/=0) THEN localized_wfn_control%set_of_states=state_loc_list ALLOCATE(localized_wfn_control%loc_states(n_list,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) localized_wfn_control%loc_states = 0 localized_wfn_control%loc_states(:,1) = loc_list(:) localized_wfn_control%loc_states(:,2) = loc_list(:) @@ -1611,18 +1578,18 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& localized_wfn_control%loc_states(:,2) = 0 END IF DEALLOCATE(loc_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF ELSE ! List of States LUMO - CALL section_vals_val_get(loc_section,"LIST_UNOCCUPIED", n_rep_val=n_rep,error=error) + CALL section_vals_val_get(loc_section,"LIST_UNOCCUPIED", n_rep_val=n_rep) IF(n_rep>0) THEN n_list = 0 DO ir = 1,n_rep NULLIFY(list) - CALL section_vals_val_get(loc_section,"LIST_UNOCCUPIED",i_rep_val=ir,i_vals=list,error=error) + CALL section_vals_val_get(loc_section,"LIST_UNOCCUPIED",i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(loc_list,1,n_list+SIZE(list)) DO i = 1, SIZE(list) @@ -1634,19 +1601,19 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& IF(n_list/=0) THEN localized_wfn_control%set_of_states=state_loc_list ALLOCATE(localized_wfn_control%loc_states(n_list,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) localized_wfn_control%loc_states = 0 localized_wfn_control%loc_states(:,1) = loc_list(:) localized_wfn_control%loc_states(:,2) = loc_list(:) localized_wfn_control%nloc_states(1) = n_list DEALLOCATE(loc_list, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END IF IF(localized_wfn_control%set_of_states == 0) THEN - CALL section_vals_val_get(loc_section,"ENERGY_RANGE",r_vals=ene,error=error) + CALL section_vals_val_get(loc_section,"ENERGY_RANGE",r_vals=ene) IF(ene(1)/=ene(2)) THEN localized_wfn_control%set_of_states = energy_loc_range localized_wfn_control%lu_ene_bound(1) = ene(1) @@ -1671,16 +1638,16 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& localized_wfn_control%print_centers = & BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "WANNIER_CENTERS",error=error),cp_p_file) + "WANNIER_CENTERS"),cp_p_file) localized_wfn_control%print_spreads = & BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "WANNIER_SPREADS",error=error),cp_p_file) + "WANNIER_SPREADS"),cp_p_file) localized_wfn_control%print_cubes = & BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "WANNIER_CUBES",error=error),cp_p_file) + "WANNIER_CUBES"),cp_p_file) output_unit = cp_print_key_unit_nr(logger,loc_print_section,"PROGRAM_RUN_INFO",& - extension=".Log",error=error) + extension=".Log") IF (output_unit > 0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A)")& @@ -1761,7 +1728,7 @@ SUBROUTINE read_loc_section(localized_wfn_control,loc_section,& END IF ! process has output_unit - CALL cp_print_key_finished_output(output_unit,logger,loc_print_section,"PROGRAM_RUN_INFO",error=error) + CALL cp_print_key_finished_output(output_unit,logger,loc_print_section,"PROGRAM_RUN_INFO") ELSE localized_wfn_control%localization_method = do_loc_none @@ -1779,16 +1746,14 @@ END SUBROUTINE read_loc_section !> \param localized_wfn_control ... !> \param nmoloc ... !> \param nspins ... -!> \param error ... !> \par History !> 04.2005 created [MI] ! ***************************************************************************** - SUBROUTINE set_loc_centers(localized_wfn_control,nmoloc,nspins,error) + SUBROUTINE set_loc_centers(localized_wfn_control,nmoloc,nspins) TYPE(localized_wfn_control_type) :: localized_wfn_control INTEGER, DIMENSION(2), INTENT(IN) :: nmoloc INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_loc_centers', & routineP = moduleN//':'//routineN @@ -1800,7 +1765,7 @@ SUBROUTINE set_loc_centers(localized_wfn_control,nmoloc,nspins,error) DO ispin = 1,nspins ALLOCATE(localized_wfn_control%centers_set(ispin)%array(6,nmoloc(ispin)), STAT = istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) localized_wfn_control%centers_set(ispin)%array = 0.0_dp END DO @@ -1812,16 +1777,14 @@ END SUBROUTINE set_loc_centers !> \param nmoloc ... !> \param nmo ... !> \param nspins ... -!> \param error ... !> \par History !> 04.2005 created [MI] ! ***************************************************************************** - SUBROUTINE set_loc_wfn_lists(localized_wfn_control,nmoloc,nmo,nspins,error) + SUBROUTINE set_loc_wfn_lists(localized_wfn_control,nmoloc,nmo,nspins) TYPE(localized_wfn_control_type) :: localized_wfn_control INTEGER, DIMENSION(2), INTENT(IN) :: nmoloc, nmo INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_loc_wfn_lists', & routineP = moduleN//':'//routineN @@ -1840,7 +1803,7 @@ SUBROUTINE set_loc_wfn_lists(localized_wfn_control,nmoloc,nmo,nspins,error) SELECT CASE(localized_wfn_control%set_of_states ) CASE(state_loc_list) ! List - CPPrecondition(ASSOCIATED(localized_wfn_control%loc_states),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(localized_wfn_control%loc_states),cp_failure_level,routineP,failure) DO ispin = 1,nspins localized_wfn_control%lu_bound_states(1,ispin) = 1 localized_wfn_control%lu_bound_states(2,ispin) = nmoloc(ispin) @@ -1852,7 +1815,7 @@ SUBROUTINE set_loc_wfn_lists(localized_wfn_control,nmoloc,nmo,nspins,error) CASE(state_loc_range) ! Range ALLOCATE(localized_wfn_control%loc_states(max_nmoloc,2),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) localized_wfn_control%loc_states = 0 DO ispin = 1,nspins localized_wfn_control%lu_bound_states(1,ispin) = & @@ -1863,12 +1826,12 @@ SUBROUTINE set_loc_wfn_lists(localized_wfn_control,nmoloc,nmo,nspins,error) DO i = 1,nmoloc(ispin) localized_wfn_control%loc_states(i,ispin) = localized_wfn_control%lu_bound_states(1,ispin) + i -1 END DO - CPPostcondition(max_iloc<=nmo(ispin),cp_failure_level,routineP,error,failure) + CPPostcondition(max_iloc<=nmo(ispin),cp_failure_level,routineP,failure) END DO CASE(energy_loc_range) ! Energy ALLOCATE(localized_wfn_control%loc_states(max_nmoloc,2),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) localized_wfn_control%loc_states = 0 DO ispin = 1,nspins DO i = 1,nmoloc(ispin) @@ -1878,7 +1841,7 @@ SUBROUTINE set_loc_wfn_lists(localized_wfn_control,nmoloc,nmo,nspins,error) CASE(state_loc_all) ! All ALLOCATE(localized_wfn_control%loc_states(max_nmoloc,2),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) localized_wfn_control%loc_states = 0 DO ispin = 1,nspins diff --git a/src/qs_local_rho_types.F b/src/qs_local_rho_types.F index a6ff85ae8c..27131d3b45 100644 --- a/src/qs_local_rho_types.F +++ b/src/qs_local_rho_types.F @@ -213,12 +213,10 @@ END SUBROUTINE get_local_rho ! ***************************************************************************** !> \brief ... !> \param local_rho_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE local_rho_set_create(local_rho_set, error) + SUBROUTINE local_rho_set_create(local_rho_set) TYPE(local_rho_type), POINTER :: local_rho_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'local_rho_set_create', & routineP = moduleN//':'//routineN @@ -229,7 +227,7 @@ SUBROUTINE local_rho_set_create(local_rho_set, error) failure=.FALSE. ALLOCATE(local_rho_set, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (local_rho_set%rho_atom_set) NULLIFY (local_rho_set%rho0_atom_set) @@ -241,12 +239,10 @@ END SUBROUTINE local_rho_set_create ! ***************************************************************************** !> \brief ... !> \param local_rho_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE local_rho_set_release(local_rho_set,error) + SUBROUTINE local_rho_set_release(local_rho_set) TYPE(local_rho_type), POINTER :: local_rho_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'local_rho_set_release', & routineP = moduleN//':'//routineN @@ -263,7 +259,7 @@ SUBROUTINE local_rho_set_release(local_rho_set,error) END IF IF (ASSOCIATED(local_rho_set%rho0_mpole)) THEN - CALL deallocate_rho0_mpole(local_rho_set%rho0_mpole,error=error) + CALL deallocate_rho0_mpole(local_rho_set%rho0_mpole) END IF IF(ASSOCIATED(local_rho_set%rhoz_set)) THEN @@ -271,7 +267,7 @@ SUBROUTINE local_rho_set_release(local_rho_set,error) ENDIF DEALLOCATE(local_rho_set,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE local_rho_set_release @@ -283,10 +279,9 @@ END SUBROUTINE local_rho_set_release !> \param rho0_atom_set ... !> \param rho0_mpole ... !> \param rhoz_set ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_local_rho(local_rho_set,rho_atom_set,rho0_atom_set,rho0_mpole,& - rhoz_set, error) + rhoz_set) TYPE(local_rho_type), POINTER :: local_rho_set TYPE(rho_atom_type), DIMENSION(:), & @@ -296,7 +291,6 @@ SUBROUTINE set_local_rho(local_rho_set,rho_atom_set,rho0_atom_set,rho0_mpole,& TYPE(rho0_mpole_type), OPTIONAL, POINTER :: rho0_mpole TYPE(rhoz_type), DIMENSION(:), & OPTIONAL, POINTER :: rhoz_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_local_rho', & routineP = moduleN//':'//routineN @@ -317,7 +311,7 @@ SUBROUTINE set_local_rho(local_rho_set,rho_atom_set,rho0_atom_set,rho0_mpole,& IF (PRESENT(rho0_mpole)) THEN IF(ASSOCIATED(local_rho_set%rho0_mpole)) THEN - CALL deallocate_rho0_mpole(local_rho_set%rho0_mpole,error=error) + CALL deallocate_rho0_mpole(local_rho_set%rho0_mpole) ENDIF local_rho_set%rho0_mpole => rho0_mpole END IF diff --git a/src/qs_localization_methods.F b/src/qs_localization_methods.F index 8488353454..38b4eb0873 100644 --- a/src/qs_localization_methods.F +++ b/src/qs_localization_methods.F @@ -85,15 +85,13 @@ MODULE qs_localization_methods !> \param eps ... !> \param converged ... !> \param sweeps ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE approx_l1_norm_sd( C, iterations, eps, converged, sweeps, error) + SUBROUTINE approx_l1_norm_sd( C, iterations, eps, converged, sweeps) TYPE(cp_fm_type), POINTER :: C INTEGER, INTENT(IN) :: iterations REAL(KIND=dp), INTENT(IN) :: eps LOGICAL, INTENT(INOUT) :: converged INTEGER, INTENT(INOUT) :: sweeps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'approx_l1_norm_sd', & routineP = moduleN//':'//routineN @@ -116,19 +114,19 @@ SUBROUTINE approx_l1_norm_sd( C, iterations, eps, converged, sweeps, error) NULLIFY(logger,CTmp,U,G,Gp1,Gp2,context,para_env,fm_struct_k_k) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) CALL cp_fm_struct_get(C%matrix_struct, nrow_global=n, ncol_global=k, & nrow_local = nrow_local, ncol_local = ncol_local, & - para_env=para_env, context=context,error=error) + para_env=para_env, context=context) CALL cp_fm_struct_create(fm_struct_k_k, para_env=para_env, context=context, & - nrow_global=k, ncol_global=k, error=error) - CALL cp_fm_create(CTmp, C%matrix_struct, error=error) - CALL cp_fm_create(U , fm_struct_k_k, error=error) - CALL cp_fm_create(G , fm_struct_k_k, error=error) - CALL cp_fm_create(Gp1 , fm_struct_k_k, error=error) - CALL cp_fm_create(Gp2 , fm_struct_k_k, error=error) + nrow_global=k, ncol_global=k) + CALL cp_fm_create(CTmp, C%matrix_struct) + CALL cp_fm_create(U , fm_struct_k_k) + CALL cp_fm_create(G , fm_struct_k_k) + CALL cp_fm_create(Gp1 , fm_struct_k_k) + CALL cp_fm_create(Gp2 , fm_struct_k_k) ! ! printing IF(output_unit>0) THEN @@ -167,46 +165,46 @@ SUBROUTINE approx_l1_norm_sd( C, iterations, eps, converged, sweeps, error) CTmp%local_data(i,p) = C%local_data(i,p) / SQRT( C%local_data(i,p)**2 + f2_eps ) ENDDO ENDDO - CALL cp_gemm('T','N',k,k,n,1.0_dp,CTmp,C,0.0_dp,G,error=error) + CALL cp_gemm('T','N',k,k,n,1.0_dp,CTmp,C,0.0_dp,G) ! antisymmetrize - CALL cp_fm_transpose(G,U,error=error) - CALL cp_fm_scale_and_add(-0.5_dp,G,0.5_dp,U,error=error) + CALL cp_fm_transpose(G,U) + CALL cp_fm_scale_and_add(-0.5_dp,G,0.5_dp,U) ! !------------------------------------------------------------------- ! - CALL cp_fm_frobenius_norm(G,gnorm,error=error) + CALL cp_fm_frobenius_norm(G,gnorm) !write(*,*) 'qs_localize: norm(G)=',gnorm ! ! rescale for steepest descent - CALL cp_fm_scale(-alpha, G, error=error) + CALL cp_fm_scale(-alpha, G) ! ! compute unitary transform ! zeroth order - CALL cp_fm_set_all(U,0.0_dp,1.0_dp,error=error) + CALL cp_fm_set_all(U,0.0_dp,1.0_dp) ! first order expfactor = 1.0_dp - CALL cp_fm_scale_and_add(1.0_dp,U,expfactor,G,error=error) - CALL cp_fm_frobenius_norm(G,tnorm,error=error) + CALL cp_fm_scale_and_add(1.0_dp,U,expfactor,G) + CALL cp_fm_frobenius_norm(G,tnorm) !write(*,*) 'Taylor expansion i=',1,' norm(X^i)/i!=',tnorm IF(tnorm.GT.1.0E-10_dp) THEN ! other orders - CALL cp_fm_to_fm(G,Gp1,error=error) + CALL cp_fm_to_fm(G,Gp1) DO i = 2,taylor_order ! new power of G - CALL cp_gemm('N','N',k,k,k,1.0_dp,G,Gp1,0.0_dp,Gp2,error=error) - CALL cp_fm_to_fm(Gp2,Gp1,error=error) + CALL cp_gemm('N','N',k,k,k,1.0_dp,G,Gp1,0.0_dp,Gp2) + CALL cp_fm_to_fm(Gp2,Gp1) ! add to the taylor expansion so far expfactor = expfactor / REAL(i,KIND=dp) - CALL cp_fm_scale_and_add(1.0_dp,U,expfactor,Gp1,error=error) - CALL cp_fm_frobenius_norm(Gp1,tnorm,error=error) + CALL cp_fm_scale_and_add(1.0_dp,U,expfactor,Gp1) + CALL cp_fm_frobenius_norm(Gp1,tnorm) !write(*,*) 'Taylor expansion i=',i,' norm(X^i)/i!=',tnorm*expfactor IF(tnorm*expfactor.LT.1.0E-10_dp) EXIT ENDDO ENDIF ! ! incrementaly rotate the MOs - CALL cp_gemm('N','N',n,k,k,1.0_dp,C,U,0.0_dp,CTmp,error=error) - CALL cp_fm_to_fm(CTmp,C,error=error) + CALL cp_gemm('N','N',n,k,k,1.0_dp,C,U,0.0_dp,CTmp) + CALL cp_fm_to_fm(CTmp,C) ! ! printing IF(output_unit.GT.0) THEN @@ -245,12 +243,12 @@ SUBROUTINE approx_l1_norm_sd( C, iterations, eps, converged, sweeps, error) !ENDDO ! ! deallocate - CALL cp_fm_struct_release(fm_struct_k_k,error=error) - CALL cp_fm_release(CTmp,error=error) - CALL cp_fm_release(U ,error=error) - CALL cp_fm_release(G ,error=error) - CALL cp_fm_release(Gp1 ,error=error) - CALL cp_fm_release(Gp2 ,error=error) + CALL cp_fm_struct_release(fm_struct_k_k) + CALL cp_fm_release(CTmp) + CALL cp_fm_release(U) + CALL cp_fm_release(G) + CALL cp_fm_release(Gp1) + CALL cp_fm_release(Gp2) CALL timestop(handle) @@ -291,12 +289,11 @@ END SUBROUTINE initialize_weights !> \param out_each ... !> \param target_time ... !> \param start_time ... -!> \param error ... !> \par History !> \author Joost VandeVondele (02.2010) ! ***************************************************************************** SUBROUTINE jacobi_rotations(weights, zij, vectors, para_env, max_iter, eps_localization, & - sweeps, out_each, target_time, start_time, error) + sweeps, out_each, target_time, start_time) REAL(KIND=dp), INTENT(IN) :: weights( : ) TYPE(cp_fm_p_type), INTENT(INOUT) :: ZIJ( :, : ) @@ -307,13 +304,12 @@ SUBROUTINE jacobi_rotations(weights, zij, vectors, para_env, max_iter, eps_local INTEGER :: sweeps INTEGER, INTENT(IN) :: out_each REAL(dp) :: target_time, start_time - TYPE(cp_error_type), INTENT(inout) :: error IF (para_env%num_pe==1) THEN - CALL jacobi_rotations_serial ( weights, zij, vectors, max_iter, eps_localization, sweeps, out_each, error) + CALL jacobi_rotations_serial ( weights, zij, vectors, max_iter, eps_localization, sweeps, out_each) ELSE CALL jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_localization, & - sweeps, out_each, target_time, start_time, error) + sweeps, out_each, target_time, start_time) ENDIF END SUBROUTINE jacobi_rotations @@ -328,9 +324,8 @@ END SUBROUTINE jacobi_rotations !> \param eps_localization ... !> \param sweeps ... !> \param out_each ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE jacobi_rotations_serial ( weights, zij, vectors, max_iter, eps_localization, sweeps, out_each, error) + SUBROUTINE jacobi_rotations_serial ( weights, zij, vectors, max_iter, eps_localization, sweeps, out_each) REAL(KIND=dp), INTENT(IN) :: weights( : ) TYPE(cp_fm_p_type), INTENT(INOUT) :: ZIJ( :, : ) TYPE(cp_fm_type), POINTER :: vectors @@ -338,7 +333,6 @@ SUBROUTINE jacobi_rotations_serial ( weights, zij, vectors, max_iter, eps_locali REAL(KIND=dp), INTENT(IN) :: eps_localization INTEGER :: sweeps INTEGER, INTENT(IN) :: out_each - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'jacobi_rotations_serial', & routineP = moduleN//':'//routineN @@ -362,24 +356,24 @@ SUBROUTINE jacobi_rotations_serial ( weights, zij, vectors, max_iter, eps_locali dim2 = SIZE(zij,2) NULLIFY(rmat,c_rmat,c_zij) ALLOCATE(c_zij(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(mii,mij,mjj) ALLOCATE(mii(dim2),mij(dim2),mjj(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_fm_create ( rmat, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_set_all ( rmat, 0._dp, 1._dp, error ) + CALL cp_fm_create ( rmat, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_set_all ( rmat, 0._dp, 1._dp) - CALL cp_cfm_create ( c_rmat, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_cfm_set_all ( c_rmat, (0._dp,0._dp) , (1._dp,0._dp) ,error=error) + CALL cp_cfm_create ( c_rmat, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_set_all ( c_rmat, (0._dp,0._dp) , (1._dp,0._dp)) DO idim=1,dim2 NULLIFY(c_zij(idim)%matrix) - CALL cp_cfm_create ( c_zij(idim)%matrix, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) + CALL cp_cfm_create ( c_zij(idim)%matrix, zij ( 1, 1 ) % matrix % matrix_struct) c_zij(idim)%matrix% local_data = CMPLX (zij(1,idim) % matrix % local_data, & zij(2,idim) % matrix % local_data, dp ) ENDDO - CALL cp_fm_get_info ( rmat , nrow_global = nstate, error = error ) + CALL cp_fm_get_info ( rmat , nrow_global = nstate) tolerance = 1.0e10_dp sweeps = 0 unit_nr = -1 @@ -417,16 +411,16 @@ SUBROUTINE jacobi_rotations_serial ( weights, zij, vectors, max_iter, eps_locali DO idim=1,dim2 zij(1,idim) % matrix % local_data = REAL ( c_zij(idim)%matrix% local_data , dp ) zij(2,idim) % matrix % local_data = AIMAG ( c_zij(idim)%matrix% local_data ) - CALL cp_cfm_release( c_zij(idim)%matrix ,error=error) + CALL cp_cfm_release( c_zij(idim)%matrix) ENDDO DEALLOCATE(c_zij,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mii,mij,mjj, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rmat % local_data = REAL ( c_rmat%local_data, dp ) - CALL cp_cfm_release( c_rmat ,error=error) + CALL cp_cfm_release( c_rmat) CALL rotate_orbitals ( rmat, vectors ) - CALL cp_fm_release ( rmat ,error=error) + CALL cp_fm_release ( rmat) CALL timestop(handle) @@ -445,7 +439,6 @@ SUBROUTINE rotate_zij ( istate, jstate, st, ct, zij ) TYPE ( cp_cfm_p_type ) :: zij ( : ) REAL ( KIND = dp ), INTENT ( IN ) :: st, ct ! Locals - TYPE ( cp_error_type ) :: error INTEGER :: idim, nstate COMPLEX ( KIND = dp ) :: st_cmplx #if defined(__SCALAPACK) @@ -455,7 +448,7 @@ SUBROUTINE rotate_zij ( istate, jstate, st, ct, zij ) #endif st_cmplx = CMPLX ( st, 0.0_dp, dp ) - CALL cp_cfm_get_info ( zij ( 1 ) % matrix, nrow_global = nstate, error = error ) + CALL cp_cfm_get_info ( zij ( 1 ) % matrix, nrow_global = nstate) DO idim = 1, SIZE(zij,1) #if defined(__SCALAPACK) desc(:) = zij(idim) % matrix %matrix_struct%descriptor(:) @@ -486,7 +479,6 @@ SUBROUTINE rotate_rmat ( istate, jstate, st, ct, rmat ) TYPE ( cp_cfm_type ), POINTER :: rmat REAL ( KIND = dp ), INTENT ( IN ) :: ct, st ! Locals - TYPE ( cp_error_type ) :: error INTEGER :: nstate COMPLEX ( KIND = dp ) :: st_cmplx #if defined(__SCALAPACK) @@ -494,7 +486,7 @@ SUBROUTINE rotate_rmat ( istate, jstate, st, ct, rmat ) #endif st_cmplx = CMPLX ( st, 0.0_dp, dp ) - CALL cp_cfm_get_info ( rmat, nrow_global = nstate, error = error ) + CALL cp_cfm_get_info ( rmat, nrow_global = nstate) #if defined(__SCALAPACK) desc ( : ) = rmat % matrix_struct % descriptor(:) CALL pzrot( nstate , rmat % local_data (1,1) , 1 , istate, desc, 1, & @@ -565,7 +557,6 @@ SUBROUTINE check_tolerance ( zij, weights, tolerance ) routineP = moduleN//':'//routineN INTEGER :: handle - TYPE(cp_error_type) :: error TYPE(cp_fm_type), POINTER :: force CALL timeset(routineN,handle) @@ -573,11 +564,11 @@ SUBROUTINE check_tolerance ( zij, weights, tolerance ) ! compute gradient at t=0 NULLIFY ( force ) - CALL cp_fm_create ( force, zij( 1 ) % matrix % matrix_struct, error = error ) - CALL cp_fm_set_all ( force, 0._dp, error=error ) + CALL cp_fm_create ( force, zij( 1 ) % matrix % matrix_struct) + CALL cp_fm_set_all ( force, 0._dp) CALL grad_at_0 ( zij, weights, force ) - CALL cp_fm_maxabsval ( force, tolerance, error = error ) - CALL cp_fm_release ( force ,error=error) + CALL cp_fm_maxabsval ( force, tolerance) + CALL cp_fm_release ( force) CALL timestop(handle) @@ -591,15 +582,14 @@ SUBROUTINE rotate_orbitals ( rmat, vectors ) TYPE(cp_fm_type), POINTER :: rmat, vectors INTEGER :: k, n - TYPE(cp_error_type) :: error TYPE(cp_fm_type), POINTER :: wf NULLIFY ( wf ) - CALL cp_fm_create ( wf, vectors % matrix_struct, error = error ) - CALL cp_fm_get_info ( vectors, nrow_global = n, ncol_global=k ,error=error) - CALL cp_gemm("N", "N", n, k, k, 1.0_dp, vectors, rmat, 0.0_dp, wf ,error=error) - CALL cp_fm_to_fm ( wf, vectors ,error=error) - CALL cp_fm_release ( wf ,error=error) + CALL cp_fm_create ( wf, vectors % matrix_struct) + CALL cp_fm_get_info ( vectors, nrow_global = n, ncol_global=k) + CALL cp_gemm("N", "N", n, k, k, 1.0_dp, vectors, rmat, 0.0_dp, wf) + CALL cp_fm_to_fm ( wf, vectors) + CALL cp_fm_release ( wf) END SUBROUTINE rotate_orbitals ! ***************************************************************************** !> \brief ... @@ -621,11 +611,10 @@ SUBROUTINE gradsq_at_0 ( diag, weights, matrix,ndim ) nrow_local INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices REAL(KIND=dp) :: gradsq_ij - TYPE(cp_error_type) :: error CALL cp_fm_get_info ( matrix, nrow_local = nrow_local, & ncol_local = ncol_local, nrow_global = nrow_global, & - row_indices = row_indices, col_indices = col_indices, error = error ) + row_indices = row_indices, col_indices = col_indices) DO istate = 1, nrow_local DO jstate = 1, ncol_local @@ -660,12 +649,11 @@ SUBROUTINE grad_at_0 ( matrix_p, weights, matrix ) nrow_local INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices REAL(KIND=dp) :: grad_ij - TYPE(cp_error_type) :: error NULLIFY(diag) CALL cp_fm_get_info ( matrix, nrow_local = nrow_local, & ncol_local = ncol_local, nrow_global = nrow_global, & - row_indices = row_indices, col_indices = col_indices, error = error ) + row_indices = row_indices, col_indices = col_indices) dim_m = SIZE(matrix_p,1) ALLOCATE(diag(nrow_global,dim_m)) @@ -699,13 +687,11 @@ END SUBROUTINE grad_at_0 !> \param zij ... !> \param tolerance ... !> \param value ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE check_tolerance_new( weights, zij, tolerance, value, error) + SUBROUTINE check_tolerance_new( weights, zij, tolerance, value) REAL(KIND=dp), INTENT(IN) :: weights( : ) TYPE(cp_fm_p_type), INTENT(INOUT) :: ZIJ( :, : ) REAL(KIND=dp) :: tolerance, value - TYPE(cp_error_type), INTENT(inout) :: error COMPLEX(KIND=dp) :: kii, kij, kjj COMPLEX(KIND=dp), DIMENSION(:, :), & @@ -719,7 +705,7 @@ SUBROUTINE check_tolerance_new( weights, zij, tolerance, value, error) NULLIFY(diag) CALL cp_fm_get_info ( zij(1,1)%matrix, nrow_local = nrow_local, & ncol_local = ncol_local, nrow_global = nrow_global, & - row_indices = row_indices, col_indices = col_indices,error=error) + row_indices = row_indices, col_indices = col_indices) ALLOCATE(diag(nrow_global,SIZE(zij,2))) value=0.0_dp DO idim = 1,SIZE(zij,2) @@ -766,10 +752,9 @@ END SUBROUTINE check_tolerance_new !> \param eps_localization ... !> \param iterations ... !> \param converged ... -!> \param error ... ! ***************************************************************************** SUBROUTINE crazy_rotations( weights, zij, vectors,max_iter, max_crazy_angle, crazy_scale, crazy_use_diag, & - eps_localization, iterations, converged, error ) + eps_localization, iterations, converged) REAL(KIND=dp), INTENT(IN) :: weights( : ) TYPE(cp_fm_p_type), INTENT(INOUT) :: ZIJ( :, : ) TYPE(cp_fm_type), POINTER :: vectors @@ -780,7 +765,6 @@ SUBROUTINE crazy_rotations( weights, zij, vectors,max_iter, max_crazy_angle, cra REAL(KIND=dp), INTENT(IN) :: eps_localization INTEGER :: iterations LOGICAL, INTENT(out), OPTIONAL :: converged - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'crazy_rotations', & routineP = moduleN//':'//routineN @@ -811,49 +795,49 @@ SUBROUTINE crazy_rotations( weights, zij, vectors,max_iter, max_crazy_angle, cra CALL cp_fm_get_info(zij(1,1)%matrix,nrow_global=nrow_global, & ncol_global=ncol_global, & row_indices=row_indices, col_indices=col_indices, & - nrow_local=nrow_local, ncol_local=ncol_local,error=error) + nrow_local=nrow_local, ncol_local=ncol_local) limit_crazy_angle=max_crazy_angle NULLIFY(diag_z,evals,evals_exp,mii,mij,mjj) dim2 = SIZE(zij,2) ALLOCATE(diag_z(nrow_global,dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(evals(nrow_global),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(evals_exp(nrow_global),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_cfm_create ( cmat_A, zij ( 1, 1 ) % matrix % matrix_struct,error=error) - CALL cp_cfm_create ( cmat_R, zij ( 1, 1 ) % matrix % matrix_struct,error=error) - CALL cp_cfm_create ( cmat_t1, zij ( 1, 1 ) % matrix % matrix_struct,error=error) + CALL cp_cfm_create ( cmat_A, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_R, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_t1, zij ( 1, 1 ) % matrix % matrix_struct) - CALL cp_fm_create ( mat_U, zij ( 1, 1 ) % matrix % matrix_struct,error=error) - CALL cp_fm_create ( mat_t, zij ( 1, 1 ) % matrix % matrix_struct,error=error) - CALL cp_fm_create ( mat_R, zij ( 1, 1 ) % matrix % matrix_struct,error=error) + CALL cp_fm_create ( mat_U, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( mat_t, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( mat_R, zij ( 1, 1 ) % matrix % matrix_struct) NULLIFY(mat_theta) - CALL cp_fm_create ( mat_theta, zij ( 1, 1 ) % matrix % matrix_struct,error=error) + CALL cp_fm_create ( mat_theta, zij ( 1, 1 ) % matrix % matrix_struct) - CALL cp_fm_set_all( mat_R,0.0_dp,1.0_dp ,error=error) - CALL cp_fm_set_all( mat_t, 0.0_dp,error=error) + CALL cp_fm_set_all( mat_R,0.0_dp,1.0_dp) + CALL cp_fm_set_all( mat_t, 0.0_dp) ALLOCATE(mii(dim2),mij(dim2),mjj(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim=1,dim2 - CALL cp_fm_scale_and_add(1.0_dp,mat_t,weights(idim),zij(1,idim) % matrix,error=error) - CALL cp_fm_scale_and_add(1.0_dp,mat_t,weights(idim),zij(2,idim) % matrix,error=error) + CALL cp_fm_scale_and_add(1.0_dp,mat_t,weights(idim),zij(1,idim) % matrix) + CALL cp_fm_scale_and_add(1.0_dp,mat_t,weights(idim),zij(2,idim) % matrix) ENDDO - CALL cp_fm_syevd(mat_t,mat_U,evals,error=error) + CALL cp_fm_syevd(mat_t,mat_U,evals) DO idim=1,dim2 ! rotate z's - CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(1,idim)%matrix,mat_U,0.0_dp,mat_t,error=error) - CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(1,idim)%matrix,error=error) - CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(2,idim)%matrix,mat_U,0.0_dp,mat_t,error=error) - CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(2,idim)%matrix,error=error) + CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(1,idim)%matrix,mat_U,0.0_dp,mat_t) + CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(1,idim)%matrix) + CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(2,idim)%matrix,mat_U,0.0_dp,mat_t) + CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(2,idim)%matrix) ENDDO ! collect rotation matrix - CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_R,mat_U,0.0_dp,mat_t,error=error) - CALL cp_fm_to_fm(mat_t,mat_R,error=error) + CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_R,mat_U,0.0_dp,mat_t) + CALL cp_fm_to_fm(mat_t,mat_R) unit_nr=-1 IF (cmat_A%matrix_struct%para_env%mepos .EQ. cmat_A%matrix_struct%para_env%source ) THEN @@ -906,36 +890,36 @@ SUBROUTINE crazy_rotations( weights, zij, vectors,max_iter, max_crazy_angle, cra ! construct rotation matrix U based on A using diagonalization ! alternatively, exp based on repeated squaring could be faster IF (crazy_use_diag) THEN - CALL cp_cfm_heevd(cmat_A,cmat_R,evals,error=error) + CALL cp_cfm_heevd(cmat_A,cmat_R,evals) maxeval=MAXVAL(ABS(evals)) evals_exp(:)=EXP( (0.0_dp,-1.0_dp) * evals(:) ) - CALL cp_cfm_to_cfm(cmat_R,cmat_t1,error=error) + CALL cp_cfm_to_cfm(cmat_R,cmat_t1) CALL cp_cfm_column_scale(cmat_t1,evals_exp) CALL cp_cfm_gemm('N','C',nrow_global,nrow_global,nrow_global,cone,& - cmat_t1,cmat_R,czero,cmat_A,error=error) + cmat_t1,cmat_R,czero,cmat_A) mat_U%local_data=REAL(cmat_A%local_data,KIND=dp) ! U is a real matrix ELSE do_emd=.FALSE. method=2 eps_exp=1.0_dp*EPSILON(eps_exp) - CALL cp_fm_maxabsrownorm(mat_theta,norm,error) + CALL cp_fm_maxabsrownorm(mat_theta,norm) maxeval=norm ! an upper bound - CALL get_nsquare_norder(norm,nsquare,norder,eps_exp,method,do_emd,error) - CALL exp_pade_real(mat_U,mat_theta,nsquare,norder,error) + CALL get_nsquare_norder(norm,nsquare,norder,eps_exp,method,do_emd) + CALL exp_pade_real(mat_U,mat_theta,nsquare,norder) ENDIF DO idim=1,dim2 ! rotate z's - CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(1,idim)%matrix,mat_U,0.0_dp,mat_t,error=error) - CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(1,idim)%matrix,error=error) - CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(2,idim)%matrix,mat_U,0.0_dp,mat_t,error=error) - CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(2,idim)%matrix,error=error) + CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(1,idim)%matrix,mat_U,0.0_dp,mat_t) + CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(1,idim)%matrix) + CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,zij(2,idim)%matrix,mat_U,0.0_dp,mat_t) + CALL cp_gemm('T','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_U,mat_t,0.0_dp,zij(2,idim)%matrix) ENDDO ! collect rotation matrix - CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_R,mat_U,0.0_dp,mat_t,error=error) - CALL cp_fm_to_fm(mat_t,mat_R,error=error) + CALL cp_gemm('N','N',nrow_global,nrow_global,nrow_global,1.0_dp,mat_R,mat_U,0.0_dp,mat_t) + CALL cp_fm_to_fm(mat_t,mat_R) - CALL check_tolerance_new ( weights, zij, tolerance, value ,error=error) + CALL check_tolerance_new ( weights, zij, tolerance, value) IF (unit_nr>0) THEN WRITE(unit_nr,'(T2,A7,I6,1X,G20.15,E12.4,E12.4,E12.4)') & @@ -947,20 +931,20 @@ SUBROUTINE crazy_rotations( weights, zij, vectors,max_iter, max_crazy_angle, cra IF (PRESENT(converged)) converged=(tolerance .LT. eps_localization) - CALL cp_cfm_release(cmat_A,error=error) - CALL cp_cfm_release(cmat_R,error=error) - CALL cp_cfm_release(cmat_T1,error=error) + CALL cp_cfm_release(cmat_A) + CALL cp_cfm_release(cmat_R) + CALL cp_cfm_release(cmat_T1) - CALL cp_fm_release(mat_U,error=error) - CALL cp_fm_release(mat_T,error=error) - CALL cp_fm_release(mat_theta,error=error) + CALL cp_fm_release(mat_U) + CALL cp_fm_release(mat_T) + CALL cp_fm_release(mat_theta) CALL rotate_orbitals(mat_R,vectors) - CALL cp_fm_release(mat_R,error=error) + CALL cp_fm_release(mat_R) DEALLOCATE(evals_exp,evals,diag_z,STAT=istat) DEALLOCATE(mii,mij,mjj,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -979,16 +963,14 @@ END SUBROUTINE crazy_rotations !> \param max_iter ... !> \param eps_localization ... !> \param iterations ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, iterations , error) + SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, iterations) REAL(KIND=dp), INTENT(IN) :: weights( : ) TYPE(cp_fm_p_type), INTENT(INOUT) :: ZIJ( :, : ) TYPE(cp_fm_type), POINTER :: vectors INTEGER, INTENT(IN) :: max_iter REAL(KIND=dp), INTENT(IN) :: eps_localization INTEGER :: iterations - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'direct_mini', & routineP = moduleN//':'//routineN @@ -1025,7 +1007,7 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera NULLIFY(cmat_A,cmat_U,cmat_R,cmat_t1,cmat_t2,cmat_B,cmat_M) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) n = zij(1,1)%matrix%matrix_struct%nrow_global @@ -1040,41 +1022,41 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera ALLOCATE(evals(n),evals_exp(n),diag_z(n,ndim),fval(n),fvald(n)) ALLOCATE(c_zij(ndim), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! create the three complex matrices Z DO idim=1,ndim NULLIFY(c_zij(idim)%matrix) - CALL cp_cfm_create ( c_zij(idim)%matrix, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) + CALL cp_cfm_create ( c_zij(idim)%matrix, zij ( 1, 1 ) % matrix % matrix_struct) c_zij(idim)%matrix% local_data = CMPLX (zij(1,idim) % matrix % local_data, & zij(2,idim) % matrix % local_data, dp ) ENDDO - CALL cp_fm_create ( matrix_A, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_create ( matrix_G, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_create ( matrix_T, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_create ( matrix_H, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_create ( matrix_G_search, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_create ( matrix_G_old, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_create ( matrix_R, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_set_all(matrix_R,0.0_dp,1.0_dp,error=error) + CALL cp_fm_create ( matrix_A, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( matrix_G, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( matrix_T, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( matrix_H, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( matrix_G_search, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( matrix_G_old, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_create ( matrix_R, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_set_all(matrix_R,0.0_dp,1.0_dp) - CALL cp_fm_set_all(matrix_A,0.0_dp,error=error) + CALL cp_fm_set_all(matrix_A,0.0_dp) ! CALL cp_fm_init_random ( matrix_A ) - CALL cp_cfm_create ( cmat_A, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_cfm_create ( cmat_U, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_cfm_create ( cmat_R, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_cfm_create ( cmat_t1, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_cfm_create ( cmat_t2, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_cfm_create ( cmat_B, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_cfm_create ( cmat_M, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) + CALL cp_cfm_create ( cmat_A, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_U, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_R, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_t1, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_t2, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_B, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_cfm_create ( cmat_M, zij ( 1, 1 ) % matrix % matrix_struct) CALL cp_cfm_get_info ( cmat_B, nrow_local=nrow_local, ncol_local=ncol_local, & - row_indices=row_indices, col_indices=col_indices ,error=error) + row_indices=row_indices, col_indices=col_indices) - CALL cp_fm_set_all(matrix_G_old,0.0_dp,error=error) - CALL cp_fm_set_all(matrix_G_search,0.0_dp,error=error) + CALL cp_fm_set_all(matrix_G_old,0.0_dp) + CALL cp_fm_set_all(matrix_G_search,0.0_dp) normg_old=1.0E30_dp ds_min=1.0_dp new_direction=.TRUE. @@ -1085,40 +1067,40 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera iterations = iterations + 1 ! compute U,R,evals given A cmat_A % local_data = CMPLX ( 0.0_dp , matrix_A % local_data, dp ) ! cmat_A is hermitian, evals are reals - CALL cp_cfm_heevd(cmat_A,cmat_R,evals,error=error) + CALL cp_cfm_heevd(cmat_A,cmat_R,evals) evals_exp(:)=EXP( (0.0_dp,-1.0_dp) * evals(:) ) - CALL cp_cfm_to_cfm(cmat_R,cmat_t1,error=error) + CALL cp_cfm_to_cfm(cmat_R,cmat_t1) CALL cp_cfm_column_scale(cmat_t1,evals_exp) - CALL cp_cfm_gemm('N','C',n,n,n,cone,cmat_t1,cmat_R,czero,cmat_U,error=error) + CALL cp_cfm_gemm('N','C',n,n,n,cone,cmat_t1,cmat_R,czero,cmat_U) cmat_U%local_data=REAL(cmat_U%local_data,KIND=dp) ! enforce numerics, U is a real matrix IF ( new_direction .AND. MOD(line_searches,20).EQ.5 ) THEN ! reset with A .eq. 0 DO idim=1,ndim - CALL cp_cfm_gemm('N','N',n,n,n,cone,c_zij(idim)%matrix,cmat_U,czero,cmat_t1,error=error) - CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_U,cmat_t1,czero,c_zij(idim)%matrix,error=error) + CALL cp_cfm_gemm('N','N',n,n,n,cone,c_zij(idim)%matrix,cmat_U,czero,cmat_t1) + CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_U,cmat_t1,czero,c_zij(idim)%matrix) ENDDO ! collect rotation matrix matrix_H%local_data=REAL(cmat_U%local_data,KIND=dp) - CALL cp_gemm('N','N',n,n,n,1.0_dp,matrix_R,matrix_H,0.0_dp,matrix_T,error=error) - CALL cp_fm_to_fm(matrix_T,matrix_R,error=error) + CALL cp_gemm('N','N',n,n,n,1.0_dp,matrix_R,matrix_H,0.0_dp,matrix_T) + CALL cp_fm_to_fm(matrix_T,matrix_R) - CALL cp_cfm_set_all(cmat_U,czero,cone,error=error) - CALL cp_cfm_set_all(cmat_R,czero,cone,error=error) - CALL cp_cfm_set_all(cmat_A,czero,error=error) - CALL cp_fm_set_all(matrix_A,0.0_dp,error=error) + CALL cp_cfm_set_all(cmat_U,czero,cone) + CALL cp_cfm_set_all(cmat_R,czero,cone) + CALL cp_cfm_set_all(cmat_A,czero) + CALL cp_fm_set_all(matrix_A,0.0_dp) evals(:)=0.0_dp evals_exp(:)=EXP( (0.0_dp,-1.0_dp) * evals(:) ) - CALL cp_fm_set_all(matrix_G_old,0.0_dp,error=error) - CALL cp_fm_set_all(matrix_G_search,0.0_dp,error=error) + CALL cp_fm_set_all(matrix_G_old,0.0_dp) + CALL cp_fm_set_all(matrix_G_search,0.0_dp) normg_old=1.0E30_dp ENDIF ! compute Omega and M - CALL cp_cfm_set_all(cmat_M,czero,error=error) + CALL cp_cfm_set_all(cmat_M,czero) omega = 0.0_dp DO idim=1,ndim - CALL cp_cfm_gemm('N','N',n,n,n,cone,c_zij(idim)%matrix,cmat_U,czero,cmat_t1,error=error) ! t1=ZU - CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_U,cmat_t1,czero,cmat_t2,error=error) ! t2=(U^T)ZU + CALL cp_cfm_gemm('N','N',n,n,n,cone,c_zij(idim)%matrix,cmat_U,czero,cmat_t1) ! t1=ZU + CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_U,cmat_t1,czero,cmat_t2) ! t2=(U^T)ZU DO i=1,n CALL cp_cfm_get_element(cmat_t2,i,i,diag_z(i,idim)) SELECT CASE (2) ! allows for selection of different spread functionals @@ -1144,7 +1126,7 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera IF (.TRUE.) THEN CALL gradsq_at_0(diag_z,weights,matrix_H,ndim) ELSE - CALL cp_fm_set_all(matrix_H,1.0_dp,error=error) + CALL cp_fm_set_all(matrix_H,1.0_dp) ENDIF ! compute B @@ -1167,15 +1149,15 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera ENDDO ! compute gradient matrix_G - CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_M,cmat_R,czero,cmat_t1,error=error) ! t1=(M^T)(R^T) - CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_R,cmat_t1,czero,cmat_t2,error=error) ! t2=(R)t1 - CALL cp_cfm_schur_product(cmat_t2,cmat_B,cmat_t1,error=error) - CALL cp_cfm_gemm('N','C',n,n,n,cone,cmat_t1,cmat_R,czero,cmat_t2,error=error) - CALL cp_cfm_gemm('N','N',n,n,n,cone,cmat_R,cmat_t2,czero,cmat_t1,error=error) + CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_M,cmat_R,czero,cmat_t1) ! t1=(M^T)(R^T) + CALL cp_cfm_gemm('C','N',n,n,n,cone,cmat_R,cmat_t1,czero,cmat_t2) ! t2=(R)t1 + CALL cp_cfm_schur_product(cmat_t2,cmat_B,cmat_t1) + CALL cp_cfm_gemm('N','C',n,n,n,cone,cmat_t1,cmat_R,czero,cmat_t2) + CALL cp_cfm_gemm('N','N',n,n,n,cone,cmat_R,cmat_t2,czero,cmat_t1) matrix_G%local_data=REAL(cmat_t1%local_data,KIND=dp) - CALL cp_fm_transpose(matrix_G,matrix_T,error=error) - CALL cp_fm_scale_and_add( -1.0_dp,matrix_G, 1.0_dp,matrix_T,error=error) - CALL cp_fm_maxabsval(matrix_G,tol,error=error) + CALL cp_fm_transpose(matrix_G,matrix_T) + CALL cp_fm_scale_and_add( -1.0_dp,matrix_G, 1.0_dp,matrix_T) + CALL cp_fm_maxabsval(matrix_G,tol) ! from here on, minimizing technology IF ( new_direction ) THEN @@ -1196,7 +1178,7 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera IF (tolmax_iter) EXIT IF (.TRUE.) THEN ! do conjugate gradient CG - CALL cp_fm_trace(matrix_G,matrix_G_old,normg_cross,error=error) + CALL cp_fm_trace(matrix_G,matrix_G_old,normg_cross) normg_cross=normg_cross*0.5_dp ! takes into account the fact that A is antisymmetric ! apply the preconditioner DO icol=1,ncol_local @@ -1204,23 +1186,23 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera matrix_G_old%local_data(irow,icol)=matrix_G%local_data(irow,icol)/matrix_H%local_data(irow,icol) ENDDO ENDDO - CALL cp_fm_trace(matrix_G,matrix_G_old,normg,error=error) + CALL cp_fm_trace(matrix_G,matrix_G_old,normg) normg=normg*0.5_dp beta_pr=(normg-normg_cross)/normg_old normg_old=normg beta_pr=MAX(beta_pr,0.0_dp) - CALL cp_fm_scale_and_add(beta_pr,matrix_G_search,-1.0_dp,matrix_G_old,error=error) - CALL cp_fm_trace(matrix_G_search,matrix_G_old,normg_cross,error=error) + CALL cp_fm_scale_and_add(beta_pr,matrix_G_search,-1.0_dp,matrix_G_old) + CALL cp_fm_trace(matrix_G_search,matrix_G_old,normg_cross) IF (normg_cross .GE. 0) THEN ! back to SD IF (matrix_A%matrix_struct%para_env%mepos .EQ. & matrix_A%matrix_struct%para_env%source) THEN WRITE(cp_logger_get_default_unit_nr(),*) "!" ENDIF beta_pr=0.0_dp - CALL cp_fm_scale_and_add(beta_pr,matrix_G_search,-1.0_dp,matrix_G_old,error=error) + CALL cp_fm_scale_and_add(beta_pr,matrix_G_search,-1.0_dp,matrix_G_old) ENDIF ELSE ! SD - CALL cp_fm_scale_and_add(0.0_dp,matrix_G_search,-1.0_dp,matrix_G,error=error) + CALL cp_fm_scale_and_add(0.0_dp,matrix_G_search,-1.0_dp,matrix_G) ENDIF ! ds_min=1.0E-4_dp line_search_count=0 @@ -1235,7 +1217,7 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera CASE (1) pos(1)=0.0_dp pos(2)=ds_min - CALL cp_fm_trace(matrix_G,matrix_G_search,grad(1),error=error) + CALL cp_fm_trace(matrix_G,matrix_G_search,grad(1)) grad(1)=grad(1)/2.0_dp new_direction=.FALSE. CASE (2) @@ -1344,36 +1326,36 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera ! now go to the suggested point ds_min=pos(line_search_count+1) ds=pos(line_search_count+1)-pos(line_search_count) - CALL cp_fm_scale_and_add(1.0_dp,matrix_A,ds,matrix_G_search,error=error) + CALL cp_fm_scale_and_add(1.0_dp,matrix_A,ds,matrix_G_search) ENDDO ! collect rotation matrix matrix_H%local_data=REAL(cmat_U%local_data,KIND=dp) - CALL cp_gemm('N','N',n,n,n,1.0_dp,matrix_R,matrix_H,0.0_dp,matrix_T,error=error) - CALL cp_fm_to_fm(matrix_T,matrix_R,error=error) + CALL cp_gemm('N','N',n,n,n,1.0_dp,matrix_R,matrix_H,0.0_dp,matrix_T) + CALL cp_fm_to_fm(matrix_T,matrix_R) CALL rotate_orbitals(matrix_R,vectors) - CALL cp_fm_release ( matrix_R,error=error) - - CALL cp_fm_release ( matrix_A,error=error) - CALL cp_fm_release ( matrix_G,error=error) - CALL cp_fm_release ( matrix_H,error=error) - CALL cp_fm_release ( matrix_T,error=error) - CALL cp_fm_release ( matrix_G_search,error=error) - CALL cp_fm_release ( matrix_G_old,error=error) - CALL cp_cfm_release ( cmat_A,error=error) - CALL cp_cfm_release ( cmat_U,error=error) - CALL cp_cfm_release ( cmat_R,error=error) - CALL cp_cfm_release ( cmat_t1,error=error) - CALL cp_cfm_release ( cmat_t2,error=error) - CALL cp_cfm_release ( cmat_B,error=error) - CALL cp_cfm_release ( cmat_M,error=error) + CALL cp_fm_release ( matrix_R) + + CALL cp_fm_release ( matrix_A) + CALL cp_fm_release ( matrix_G) + CALL cp_fm_release ( matrix_H) + CALL cp_fm_release ( matrix_T) + CALL cp_fm_release ( matrix_G_search) + CALL cp_fm_release ( matrix_G_old) + CALL cp_cfm_release ( cmat_A) + CALL cp_cfm_release ( cmat_U) + CALL cp_cfm_release ( cmat_R) + CALL cp_cfm_release ( cmat_t1) + CALL cp_cfm_release ( cmat_t2) + CALL cp_cfm_release ( cmat_B) + CALL cp_cfm_release ( cmat_M) DEALLOCATE(evals,evals_exp,fval,fvald) DO idim=1,SIZE(c_zij) zij(1,idim) % matrix % local_data = REAL ( c_zij(idim)%matrix% local_data , dp ) zij(2,idim) % matrix % local_data = AIMAG ( c_zij(idim)%matrix% local_data ) - CALL cp_cfm_release( c_zij(idim)%matrix ,error=error) + CALL cp_cfm_release( c_zij(idim)%matrix) ENDDO DEALLOCATE(c_zij) DEALLOCATE(diag_z) @@ -1394,13 +1376,12 @@ SUBROUTINE direct_mini( weights, zij, vectors, max_iter ,eps_localization, itera !> \param out_each ... !> \param target_time ... !> \param start_time ... -!> \param error ... !> \par History !> use allgather for improved performance !> \author MI (11.2009) ! ***************************************************************************** SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_localization, & - sweeps, out_each, target_time, start_time, error) + sweeps, out_each, target_time, start_time) REAL(KIND=dp), INTENT(IN) :: weights( : ) TYPE(cp_fm_p_type), INTENT(INOUT) :: ZIJ( :, : ) @@ -1411,7 +1392,6 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali INTEGER :: sweeps INTEGER, INTENT(IN) :: out_each REAL(dp) :: target_time, start_time - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'jacobi_rot_para', & routineP = moduleN//':'//routineN @@ -1447,7 +1427,7 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali failure=.FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) NULLIFY(rmat, cz_ij_loc, zdiag_all, zdiag_me) @@ -1456,12 +1436,12 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali dim2 = SIZE(zij,2) ALLOCATE(mii(dim2),mij(dim2),mjj(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_fm_create ( rmat, zij ( 1, 1 ) % matrix % matrix_struct, error=error ) - CALL cp_fm_set_all ( rmat, 0._dp, 1._dp, error ) + CALL cp_fm_create ( rmat, zij ( 1, 1 ) % matrix % matrix_struct) + CALL cp_fm_set_all ( rmat, 0._dp, 1._dp) - CALL cp_fm_get_info ( rmat , nrow_global = nstate, error = error ) + CALL cp_fm_get_info ( rmat , nrow_global = nstate) ALLOCATE(rcount(para_env%num_pe),STAT=istat) ALLOCATE(rdispl(para_env%num_pe),STAT=istat) @@ -1473,13 +1453,13 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali npair = (para_env%num_pe+1)/2 nperm = para_env%num_pe - MOD( para_env%num_pe +1,2) ALLOCATE(list_pair(2,npair),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! Distribution of the states (XXXXX safe against more pe than states ??? XXXXX) xstate = REAL(nstate,dp)/REAL(para_env%num_pe,dp) nblock_max = 0 ALLOCATE(ns_bound(0:para_env%num_pe-1,2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) Xlow=0.0D0 Xup=0.0D0 DO ip=1,para_env%num_pe @@ -1501,20 +1481,20 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali ! otbtain local part of the matrix (could be made faster, but is likely irrelevant). ALLOCATE(z_ij_loc_re(nstate,nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(z_ij_loc_im(nstate,nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(cz_ij_loc(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim = 1,dim2 DO ip=0,para_env%num_pe-1 nblock=ns_bound(ip,2)-ns_bound(ip,1)+1 - CALL cp_fm_get_submatrix(zij(1,idim)%matrix,z_ij_loc_re,1,ns_bound(ip,1),nstate,nblock,error=error) - CALL cp_fm_get_submatrix(zij(2,idim)%matrix,z_ij_loc_im,1,ns_bound(ip,1),nstate,nblock,error=error) + CALL cp_fm_get_submatrix(zij(1,idim)%matrix,z_ij_loc_re,1,ns_bound(ip,1),nstate,nblock) + CALL cp_fm_get_submatrix(zij(2,idim)%matrix,z_ij_loc_im,1,ns_bound(ip,1),nstate,nblock) IF(para_env%mepos==ip) THEN ns_me = nblock ALLOCATE (cz_ij_loc(idim)%c_array(nstate,ns_me),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO i=1,ns_me DO j = 1,nstate cz_ij_loc(idim)%c_array(j,i) = CMPLX(z_ij_loc_re(j,i),z_ij_loc_im(j,i),dp) @@ -1524,14 +1504,14 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali END DO ! ip END DO DEALLOCATE(z_ij_loc_re,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(z_ij_loc_im,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! initialize rotation matrix ALLOCATE(rotmat(nstate,2*nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rotmat=0.0_dp DO i =ns_bound(para_env%mepos,1),ns_bound(para_env%mepos,2) ii = i - ns_bound(para_env%mepos,1) + 1 @@ -1539,42 +1519,42 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali END DO ALLOCATE(xyz_mix(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(xyz_mix_ns(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(zdiag_me(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(zdiag_all(dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ns_me = ns_bound(para_env%mepos,2) - ns_bound(para_env%mepos,1) +1 IF(ns_me/=0) THEN ALLOCATE(c_array_me(nstate,ns_me,dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim = 1,dim2 ALLOCATE(xyz_mix_ns(idim)%c_array(nstate,ns_me),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO ALLOCATE(gmat(nstate,ns_me),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF DO idim = 1,dim2 ALLOCATE(zdiag_me(idim)%c_array(nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) zdiag_me(idim)%c_array = CMPLX(0.0_dp, 0.0_dp, dp) ALLOCATE(zdiag_all(idim)%c_array(para_env%num_pe*nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) zdiag_all(idim)%c_array = CMPLX(0.0_dp, 0.0_dp, dp) END DO ALLOCATE(rmat_recv(nblock_max*2,nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(rmat_send(nblock_max*2,nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! buffer for message passing ALLOCATE(rmat_recv_all(nblock_max*2,nblock_max,0:para_env%num_pe-1),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF(output_unit>0) THEN WRITE(output_unit,'(T10,A )') "Localization by iterative distributed Jacobi rotation" @@ -1594,7 +1574,7 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali DO iperm = 1,nperm ! fix partners for this permutation, and get the number of states - CALL eberlein(iperm,para_env,list_pair,error) + CALL eberlein(iperm,para_env,list_pair) ip_partner = -1 ns_partner = 0 DO ipair = 1,npair @@ -1616,18 +1596,18 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali IF(ns_partner*ns_me /= 0) THEN ALLOCATE(rmat_loc(ns_me+ns_partner,ns_me+ns_partner),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rmat_loc = 0.0_dp DO i = 1, ns_me+ns_partner rmat_loc(i,i) = 1.0_dp END DO ALLOCATE(c_array_partner(nstate,ns_partner,dim2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim = 1,dim2 ALLOCATE(xyz_mix(idim)%c_array(ns_me+ns_partner,ns_me+ns_partner),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO i = 1,ns_me c_array_me(1:nstate,i,idim) = cz_ij_loc(idim)%c_array(1:nstate,i) END DO @@ -1739,7 +1719,7 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali END DO ! idim DEALLOCATE(c_array_partner,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ELSE ! save my data DO idim = 1,dim2 @@ -1855,10 +1835,10 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali IF(ns_partner*ns_me /= 0) THEN DEALLOCATE(rmat_loc, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim = 1,dim2 DEALLOCATE(xyz_mix(idim)%c_array,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO END IF @@ -1924,7 +1904,7 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali CALL m_flush(output_unit) END IF IF(tolerance < eps_localization) EXIT - CALL external_control(should_stop,"LOC",target_time=target_time, start_time=start_time,error=error) + CALL external_control(should_stop,"LOC",target_time=target_time, start_time=start_time) IF(should_stop) EXIT @@ -1932,53 +1912,53 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali ! buffer for message passing DEALLOCATE(rmat_recv_all,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(rmat_recv, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(rmat_send, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF (ns_me>0) THEN DEALLOCATE(c_array_me,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDIF DO idim = 1,dim2 DEALLOCATE(zdiag_me(idim)%c_array, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(zdiag_all(idim)%c_array, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(zdiag_me, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(zdiag_all, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(xyz_mix,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim = 1,dim2 IF(ns_me/=0) THEN DEALLOCATE(xyz_mix_ns(idim)%c_array,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDIF END DO DEALLOCATE(xyz_mix_ns,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF(ns_me/=0) THEN DEALLOCATE(gmat,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(mii,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mij,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mjj,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ilow1=ns_bound(para_env%mepos,1) ns_me=ns_bound(para_env%mepos,2)-ns_bound(para_env%mepos,1)+1 ALLOCATE(z_ij_loc_re(nstate,nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(z_ij_loc_im(nstate,nblock_max),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim = 1,dim2 DO ip = 0,para_env%num_pe-1 z_ij_loc_re = 0.0_dp @@ -1996,8 +1976,8 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali END IF CALL mp_bcast(z_ij_loc_re,ip,para_env%group) CALL mp_bcast(z_ij_loc_im,ip,para_env%group) - CALL cp_fm_set_submatrix(zij(1,idim)%matrix,z_ij_loc_re,1,ns_bound(ip,1),nstate,nblock,error=error) - CALL cp_fm_set_submatrix(zij(2,idim)%matrix,z_ij_loc_im,1,ns_bound(ip,1),nstate,nblock,error=error) + CALL cp_fm_set_submatrix(zij(1,idim)%matrix,z_ij_loc_re,1,ns_bound(ip,1),nstate,nblock) + CALL cp_fm_set_submatrix(zij(2,idim)%matrix,z_ij_loc_im,1,ns_bound(ip,1),nstate,nblock) END DO ! ip END DO @@ -2014,26 +1994,26 @@ SUBROUTINE jacobi_rot_para(weights, zij, vectors, para_env, max_iter, eps_locali END DO END IF CALL mp_bcast(z_ij_loc_re,ip,para_env%group) - CALL cp_fm_set_submatrix(rmat,z_ij_loc_re,1,ns_bound(ip,1),nstate,nblock,error=error) + CALL cp_fm_set_submatrix(rmat,z_ij_loc_re,1,ns_bound(ip,1),nstate,nblock) END DO DEALLOCATE(z_ij_loc_re,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(z_ij_loc_im,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO idim = 1,dim2 DEALLOCATE(cz_ij_loc(idim)%c_array,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(cz_ij_loc,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL mp_sync(para_env%group) CALL rotate_orbitals ( rmat, vectors ) - CALL cp_fm_release ( rmat ,error=error) + CALL cp_fm_release ( rmat) DEALLOCATE(rotmat,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(ns_bound, list_pair) CALL timestop(handle) @@ -2045,13 +2025,11 @@ END SUBROUTINE jacobi_rot_para !> \param iperm ... !> \param para_env ... !> \param list_pair ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE eberlein(iperm,para_env,list_pair,error) + SUBROUTINE eberlein(iperm,para_env,list_pair) INTEGER, INTENT(IN) :: iperm TYPE(cp_para_env_type), POINTER :: para_env INTEGER, DIMENSION(:, :) :: list_pair - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eberlein', & routineP = moduleN//':'//routineN diff --git a/src/qs_main.F b/src/qs_main.F index 041c075001..e1f5e674d9 100644 --- a/src/qs_main.F +++ b/src/qs_main.F @@ -60,14 +60,13 @@ MODULE qs_main !> \param force_env_section ... !> \param subsys_section ... !> \param use_motion_section ... -!> \param error ... !> \par History !> Creation (23.01.2002,MK) !> Modified for RESPA (07.2006) ! ***************************************************************************** SUBROUTINE quickstep_create_force_env(force_env,root_section,para_env,globenv,& subsys,cell,cell_ref,qmmm,qmmm_env_qm,force_env_section,& - subsys_section,use_motion_section,error) + subsys_section,use_motion_section) TYPE(force_env_type), POINTER :: force_env TYPE(section_vals_type), POINTER :: root_section @@ -81,7 +80,6 @@ SUBROUTINE quickstep_create_force_env(force_env,root_section,para_env,globenv,& TYPE(section_vals_type), POINTER :: force_env_section, & subsys_section LOGICAL, INTENT(IN) :: use_motion_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'quickstep_create_force_env', & routineP = moduleN//':'//routineN @@ -96,13 +94,13 @@ SUBROUTINE quickstep_create_force_env(force_env,root_section,para_env,globenv,& failure = .FALSE. NULLIFY(qs_env, sub_force_env) !Reference qs_env - CALL qs_env_create(qs_env,globenv,error=error) + CALL qs_env_create(qs_env,globenv) CALL qs_init(qs_env, para_env, globenv, root_section, cp_subsys=subsys, cell=cell, cell_ref=cell_ref,& qmmm=qmmm, qmmm_env_qm=qmmm_env_qm, force_env_section=force_env_section,& - subsys_section=subsys_section, use_motion_section=use_motion_section, error=error) + subsys_section=subsys_section, use_motion_section=use_motion_section) CALL force_env_create(force_env,root_section, qs_env=qs_env, para_env=para_env, globenv=globenv,& - sub_force_env=sub_force_env, force_env_section=force_env_section,error=error) - CALL qs_env_release(qs_env,error=error) + sub_force_env=sub_force_env, force_env_section=force_env_section) + CALL qs_env_release(qs_env) CALL timestop(handle) END SUBROUTINE quickstep_create_force_env diff --git a/src/qs_matrix_pools.F b/src/qs_matrix_pools.F index 72806f2950..51f86d1c52 100644 --- a/src/qs_matrix_pools.F +++ b/src/qs_matrix_pools.F @@ -81,15 +81,12 @@ MODULE qs_matrix_pools ! ***************************************************************************** !> \brief retains the given qs_matrix_pools_type !> \param mpools the matrix pools type to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE mpools_retain(mpools, error) +SUBROUTINE mpools_retain(mpools) TYPE(qs_matrix_pools_type), POINTER :: mpools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mpools_retain', & routineP = moduleN//':'//routineN @@ -98,23 +95,20 @@ SUBROUTINE mpools_retain(mpools, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(mpools),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(mpools%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(mpools),cp_failure_level,routineP,failure) + CPPreconditionNoFail(mpools%ref_count>0,cp_failure_level,routineP) mpools%ref_count=mpools%ref_count+1 END SUBROUTINE mpools_retain ! ***************************************************************************** !> \brief releases the given mpools !> \param mpools the matrix pools type to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE mpools_release(mpools,error) +SUBROUTINE mpools_release(mpools) TYPE(qs_matrix_pools_type), POINTER :: mpools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mpools_release', & routineP = moduleN//':'//routineN @@ -125,20 +119,20 @@ SUBROUTINE mpools_release(mpools,error) failure=.FALSE. IF (ASSOCIATED(mpools)) THEN - CPPreconditionNoFail(mpools%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(mpools%ref_count>0,cp_failure_level,routineP) mpools%ref_count=mpools%ref_count-1 IF (mpools%ref_count==0) THEN - CALL fm_pools_dealloc(mpools%ao_mo_fm_pools, error=error) - CALL fm_pools_dealloc(mpools%ao_ao_fm_pools, error=error) - CALL fm_pools_dealloc(mpools%mo_mo_fm_pools, error=error) + CALL fm_pools_dealloc(mpools%ao_mo_fm_pools) + CALL fm_pools_dealloc(mpools%ao_ao_fm_pools) + CALL fm_pools_dealloc(mpools%mo_mo_fm_pools) IF (ASSOCIATED(mpools%ao_mosub_fm_pools)) THEN - CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools) END IF IF (ASSOCIATED(mpools%mosub_mosub_fm_pools)) THEN - CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools) END IF DEALLOCATE(mpools, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(mpools) @@ -152,20 +146,16 @@ END SUBROUTINE mpools_release !> \param mo_mo_fm_pools ... !> \param ao_mosub_fm_pools ... !> \param mosub_mosub_fm_pools ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** SUBROUTINE mpools_set(mpools,ao_mo_fm_pools,ao_ao_fm_pools,& - mo_mo_fm_pools,ao_mosub_fm_pools,mosub_mosub_fm_pools,& - error) + mo_mo_fm_pools,ao_mosub_fm_pools,mosub_mosub_fm_pools) TYPE(qs_matrix_pools_type), POINTER :: mpools TYPE(cp_fm_pool_p_type), DIMENSION(:), OPTIONAL, POINTER :: & ao_mo_fm_pools, ao_ao_fm_pools, mo_mo_fm_pools, ao_mosub_fm_pools, & mosub_mosub_fm_pools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mpools_set', & routineP = moduleN//':'//routineN @@ -177,41 +167,41 @@ SUBROUTINE mpools_set(mpools,ao_mo_fm_pools,ao_ao_fm_pools,& failure=.FALSE. NULLIFY(new_fm_pools ) - CPPrecondition(ASSOCIATED(mpools),cp_failure_level,routineP,error,failure) - CPPrecondition(mpools%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mpools),cp_failure_level,routineP,failure) + CPPrecondition(mpools%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(ao_mo_fm_pools)) THEN IF (ASSOCIATED(ao_mo_fm_pools)) THEN - CALL fm_pools_copy(ao_mo_fm_pools,new_fm_pools,error=error) + CALL fm_pools_copy(ao_mo_fm_pools,new_fm_pools) END IF - CALL fm_pools_dealloc(mpools%ao_mo_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%ao_mo_fm_pools) mpools%ao_mo_fm_pools => new_fm_pools END IF IF (PRESENT(ao_ao_fm_pools)) THEN IF (ASSOCIATED(ao_ao_fm_pools)) THEN - CALL fm_pools_copy(ao_ao_fm_pools,new_fm_pools,error=error) + CALL fm_pools_copy(ao_ao_fm_pools,new_fm_pools) END IF - CALL fm_pools_dealloc(mpools%ao_ao_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%ao_ao_fm_pools) mpools%ao_ao_fm_pools => new_fm_pools END IF IF (PRESENT(mo_mo_fm_pools)) THEN IF (ASSOCIATED(mo_mo_fm_pools)) THEN - CALL fm_pools_copy(mo_mo_fm_pools,new_fm_pools,error=error) + CALL fm_pools_copy(mo_mo_fm_pools,new_fm_pools) END IF - CALL fm_pools_dealloc(mpools%mo_mo_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%mo_mo_fm_pools) mpools%mo_mo_fm_pools => new_fm_pools END IF IF (PRESENT(ao_mosub_fm_pools)) THEN IF (ASSOCIATED(ao_mosub_fm_pools)) THEN - CALL fm_pools_copy(ao_mosub_fm_pools,new_fm_pools,error=error) + CALL fm_pools_copy(ao_mosub_fm_pools,new_fm_pools) END IF - CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools) mpools%ao_mosub_fm_pools => new_fm_pools END IF IF (PRESENT(mosub_mosub_fm_pools)) THEN IF (ASSOCIATED(mosub_mosub_fm_pools)) THEN - CALL fm_pools_copy(mosub_mosub_fm_pools,new_fm_pools,error=error) + CALL fm_pools_copy(mosub_mosub_fm_pools,new_fm_pools) END IF - CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools) mpools%mosub_mosub_fm_pools => new_fm_pools END IF @@ -229,17 +219,13 @@ END SUBROUTINE mpools_set !> \param maxao_maxmo_fm_pool ... !> \param maxao_maxao_fm_pool ... !> \param maxmo_maxmo_fm_pool ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> see qs_matrix_pools_type attributes !> \par History !> 04.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** SUBROUTINE mpools_get(mpools,ao_mo_fm_pools,ao_ao_fm_pools,& mo_mo_fm_pools, ao_mosub_fm_pools, mosub_mosub_fm_pools,& - maxao_maxmo_fm_pool, maxao_maxao_fm_pool, maxmo_maxmo_fm_pool,& - error) + maxao_maxmo_fm_pool, maxao_maxao_fm_pool, maxmo_maxmo_fm_pool) TYPE(qs_matrix_pools_type), POINTER :: mpools TYPE(cp_fm_pool_p_type), DIMENSION(:), OPTIONAL, POINTER :: & ao_mo_fm_pools, ao_ao_fm_pools, mo_mo_fm_pools, ao_mosub_fm_pools, & @@ -247,7 +233,6 @@ SUBROUTINE mpools_get(mpools,ao_mo_fm_pools,ao_ao_fm_pools,& TYPE(cp_fm_pool_type), OPTIONAL, POINTER :: maxao_maxmo_fm_pool, & maxao_maxao_fm_pool, & maxmo_maxmo_fm_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mpools_get', & routineP = moduleN//':'//routineN @@ -287,15 +272,12 @@ END SUBROUTINE mpools_get ! ***************************************************************************** !> \brief creates a mpools !> \param mpools the mpools to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE mpools_create(mpools,error) +SUBROUTINE mpools_create(mpools) TYPE(qs_matrix_pools_type), POINTER :: mpools - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mpools_create', & routineP = moduleN//':'//routineN @@ -306,7 +288,7 @@ SUBROUTINE mpools_create(mpools,error) failure=.FALSE. ALLOCATE(mpools, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(mpools%ao_ao_fm_pools, mpools%ao_mo_fm_pools, & mpools%mo_mo_fm_pools, mpools%ao_mosub_fm_pools, & mpools%mosub_mosub_fm_pools) @@ -324,15 +306,13 @@ END SUBROUTINE mpools_create !> \param para_env the parallel environment of the matrixes !> \param nmosub number of the orbitals for the creation !> of the pools containing only a subset of mos (OPTIONAL) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> 04.2005 added pools for a subset of mos [MI] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& - nmosub,error) + nmosub) TYPE(qs_matrix_pools_type), POINTER :: mpools TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos @@ -340,7 +320,6 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& TYPE(cp_para_env_type), POINTER :: para_env INTEGER, DIMENSION(2), INTENT(IN), & OPTIONAL :: nmosub - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mpools_rebuild_fm_pools', & routineP = moduleN//':'//routineN @@ -366,21 +345,21 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& IF(nmosub(1) > 0) prepare_subset = .TRUE. END IF - CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(mpools)) THEN - CALL mpools_create(mpools,error=error) + CALL mpools_create(mpools) END IF IF (.NOT.failure) THEN nspins=SIZE(mos) IF (ASSOCIATED(mpools%ao_mo_fm_pools)) THEN IF (nspins/=SIZE(mpools%ao_mo_fm_pools)) THEN - CALL fm_pools_dealloc(mpools%ao_mo_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%ao_mo_fm_pools) END IF END IF IF (.NOT.ASSOCIATED(mpools%ao_mo_fm_pools)) THEN ALLOCATE(mpools%ao_mo_fm_pools(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(mpools%ao_mo_fm_pools(ispin)%pool) END DO @@ -388,12 +367,12 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& IF (ASSOCIATED(mpools%ao_ao_fm_pools)) THEN IF (nspins/=SIZE(mpools%ao_ao_fm_pools)) THEN - CALL fm_pools_dealloc(mpools%ao_ao_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%ao_ao_fm_pools) END IF END IF IF (.NOT.ASSOCIATED(mpools%ao_ao_fm_pools)) THEN ALLOCATE(mpools%ao_ao_fm_pools(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(mpools%ao_ao_fm_pools(ispin)%pool) END DO @@ -401,12 +380,12 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& IF (ASSOCIATED(mpools%mo_mo_fm_pools)) THEN IF (nspins/=SIZE(mpools%mo_mo_fm_pools)) THEN - CALL fm_pools_dealloc(mpools%mo_mo_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%mo_mo_fm_pools) END IF END IF IF (.NOT.ASSOCIATED(mpools%mo_mo_fm_pools)) THEN ALLOCATE(mpools%mo_mo_fm_pools(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(mpools%mo_mo_fm_pools(ispin)%pool) END DO @@ -416,12 +395,12 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& IF (ASSOCIATED(mpools%ao_mosub_fm_pools)) THEN IF (nspins/=SIZE(mpools%ao_mosub_fm_pools)) THEN - CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools) END IF END IF IF (.NOT.ASSOCIATED(mpools%ao_mosub_fm_pools)) THEN ALLOCATE(mpools%ao_mosub_fm_pools(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(mpools%ao_mosub_fm_pools(ispin)%pool) END DO @@ -429,12 +408,12 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& IF (ASSOCIATED(mpools%mosub_mosub_fm_pools)) THEN IF (nspins/=SIZE(mpools%mosub_mosub_fm_pools)) THEN - CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools,error=error) + CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools) END IF END IF IF (.NOT.ASSOCIATED(mpools%mosub_mosub_fm_pools)) THEN ALLOCATE(mpools%mosub_mosub_fm_pools(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(mpools%mosub_mosub_fm_pools(ispin)%pool) END DO @@ -454,7 +433,6 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& routineP,& "the mo with the most orbitals must be the first "//& CPSourceFileRef,& - error=error,& failure=failure) END IF min_nmo=MIN(min_nmo,nmo) @@ -467,29 +445,28 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& p_att => mpools%ao_ao_fm_pools(ispin)%pool should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) IF (.NOT.should_rebuild) THEN - fmstruct => fm_pool_get_el_struct(mpools%ao_ao_fm_pools(ispin)%pool,& - error=error) + fmstruct => fm_pool_get_el_struct(mpools%ao_ao_fm_pools(ispin)%pool) CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& - ncol_global=ncg,error=error) + ncol_global=ncg) CALL get_mo_set(mos(1)%mo_set,nao=nao,nmo=nmo) should_rebuild = nao/=nrg.OR.nao/=ncg END IF END DO IF (should_rebuild) THEN DO ispin=1,nspins - CALL fm_pool_release(mpools%ao_ao_fm_pools(ispin)%pool,error=error) + CALL fm_pool_release(mpools%ao_ao_fm_pools(ispin)%pool) END DO CALL cp_fm_struct_create(fmstruct, nrow_global=nao,& ncol_global=nao, para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) - CALL fm_pool_create(mpools%ao_ao_fm_pools(1)%pool,fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + ncol_block=ncol_block) + CALL fm_pool_create(mpools%ao_ao_fm_pools(1)%pool,fmstruct) + CALL cp_fm_struct_release(fmstruct) DO ispin=2,SIZE(mos) mpools%ao_ao_fm_pools(ispin)%pool => mpools%ao_ao_fm_pools(1)%pool - CALL fm_pool_retain(mpools%ao_ao_fm_pools(1)%pool,error=error) + CALL fm_pool_retain(mpools%ao_ao_fm_pools(1)%pool) END DO END IF @@ -500,16 +477,16 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) IF (.NOT.should_rebuild) THEN fmstruct => fm_pool_get_el_struct(mpools%ao_mo_fm_pools(ispin)& - %pool,error=error) + %pool) CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& - ncol_global=ncg,error=error) + ncol_global=ncg) CALL get_mo_set(mos(1)%mo_set,nao=nao,nmo=nmo) should_rebuild = nao/=nrg.OR.nmo/=ncg END IF END DO IF (should_rebuild) THEN DO ispin=1,nspins - CALL fm_pool_release(mpools%ao_mo_fm_pools(ispin)%pool,error=error) + CALL fm_pool_release(mpools%ao_mo_fm_pools(ispin)%pool) END DO IF (max_nmo==min_nmo) THEN @@ -517,12 +494,12 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=max_nmo, para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) - CALL fm_pool_create(mpools%ao_mo_fm_pools(1)%pool,fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + ncol_block=ncol_block) + CALL fm_pool_create(mpools%ao_mo_fm_pools(1)%pool,fmstruct) + CALL cp_fm_struct_release(fmstruct) DO ispin=2,SIZE(mos) mpools%ao_mo_fm_pools(ispin)%pool => mpools%ao_mo_fm_pools(1)%pool - CALL fm_pool_retain(mpools%ao_mo_fm_pools(1)%pool,error=error) + CALL fm_pool_retain(mpools%ao_mo_fm_pools(1)%pool) END DO ELSE DO ispin=1,SIZE(mos) @@ -531,10 +508,10 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=nmo, para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) + ncol_block=ncol_block) CALL fm_pool_create(mpools%ao_mo_fm_pools(ispin)%pool,& - fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + fmstruct) + CALL cp_fm_struct_release(fmstruct) END DO END IF END IF @@ -545,16 +522,16 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& p_att => mpools%mo_mo_fm_pools(ispin)%pool should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) IF (.NOT.should_rebuild) THEN - fmstruct => fm_pool_get_el_struct(p_att,error=error) + fmstruct => fm_pool_get_el_struct(p_att) CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& - ncol_global=ncg,error=error) + ncol_global=ncg) CALL get_mo_set(mos(1)%mo_set,nao=nao,nmo=nmo) should_rebuild = nmo/=nrg.OR.nmo/=ncg END IF END DO IF (should_rebuild) THEN DO ispin=1,nspins - CALL fm_pool_release(mpools%mo_mo_fm_pools(ispin)%pool,error=error) + CALL fm_pool_release(mpools%mo_mo_fm_pools(ispin)%pool) END DO IF (max_nmo==min_nmo) THEN @@ -562,13 +539,13 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=max_nmo, para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) + ncol_block=ncol_block) CALL fm_pool_create(mpools%mo_mo_fm_pools(1)%pool,& - fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + fmstruct) + CALL cp_fm_struct_release(fmstruct) DO ispin=2,SIZE(mos) mpools%mo_mo_fm_pools(ispin)%pool => mpools%mo_mo_fm_pools(1)%pool - CALL fm_pool_retain(mpools%mo_mo_fm_pools(1)%pool,error=error) + CALL fm_pool_retain(mpools%mo_mo_fm_pools(1)%pool) END DO ELSE DO ispin=1,SIZE(mos) @@ -578,10 +555,10 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=nmo, para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) + ncol_block=ncol_block) CALL fm_pool_create(mpools%mo_mo_fm_pools(ispin)%pool,& - fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + fmstruct) + CALL cp_fm_struct_release(fmstruct) END DO END IF END IF @@ -594,16 +571,16 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) IF (.NOT.should_rebuild) THEN fmstruct => fm_pool_get_el_struct(mpools%ao_mosub_fm_pools(ispin)& - %pool,error=error) + %pool) CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& - ncol_global=ncg,error=error) + ncol_global=ncg) CALL get_mo_set(mos(1)%mo_set,nao=nao) should_rebuild = nao/=nrg .OR. nmosub(ispin)/=ncg END IF END DO IF (should_rebuild) THEN DO ispin=1,nspins - CALL fm_pool_release(mpools%ao_mosub_fm_pools(ispin)%pool,error=error) + CALL fm_pool_release(mpools%ao_mosub_fm_pools(ispin)%pool) END DO IF (nspins==1 .OR. nmosub(1)==nmosub(2)) THEN @@ -611,12 +588,12 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=nmosub(1), para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) - CALL fm_pool_create(mpools%ao_mosub_fm_pools(1)%pool,fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + ncol_block=ncol_block) + CALL fm_pool_create(mpools%ao_mosub_fm_pools(1)%pool,fmstruct) + CALL cp_fm_struct_release(fmstruct) DO ispin=2,SIZE(mos) mpools%ao_mosub_fm_pools(ispin)%pool => mpools%ao_mosub_fm_pools(1)%pool - CALL fm_pool_retain(mpools%ao_mosub_fm_pools(1)%pool,error=error) + CALL fm_pool_retain(mpools%ao_mosub_fm_pools(1)%pool) END DO ELSE DO ispin=1,SIZE(mos) @@ -625,10 +602,10 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=nmosub(1), para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) + ncol_block=ncol_block) CALL fm_pool_create(mpools%ao_mosub_fm_pools(ispin)%pool,& - fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + fmstruct) + CALL cp_fm_struct_release(fmstruct) END DO END IF END IF ! should_rebuild @@ -639,15 +616,15 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& p_att => mpools%mosub_mosub_fm_pools(ispin)%pool should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) IF (.NOT.should_rebuild) THEN - fmstruct => fm_pool_get_el_struct(p_att,error=error) + fmstruct => fm_pool_get_el_struct(p_att) CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& - ncol_global=ncg,error=error) + ncol_global=ncg) should_rebuild = nmosub(ispin)/=nrg .OR. nmosub(ispin)/=ncg END IF END DO IF (should_rebuild) THEN DO ispin=1,nspins - CALL fm_pool_release(mpools%mosub_mosub_fm_pools(ispin)%pool,error=error) + CALL fm_pool_release(mpools%mosub_mosub_fm_pools(ispin)%pool) END DO IF ( nspins ==1 .OR. nmosub(1)==nmosub(2)) THEN @@ -655,13 +632,13 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=nmosub(1), para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) + ncol_block=ncol_block) CALL fm_pool_create(mpools%mosub_mosub_fm_pools(1)%pool,& - fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + fmstruct) + CALL cp_fm_struct_release(fmstruct) DO ispin=2,SIZE(mos) mpools%mosub_mosub_fm_pools(ispin)%pool => mpools%mosub_mosub_fm_pools(1)%pool - CALL fm_pool_retain(mpools%mosub_mosub_fm_pools(1)%pool,error=error) + CALL fm_pool_retain(mpools%mosub_mosub_fm_pools(1)%pool) END DO ELSE DO ispin=1,SIZE(mos) @@ -670,10 +647,10 @@ SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& ncol_global=nmosub(ispin), para_env=para_env,& context=blacs_env,& nrow_block=nrow_block,& - ncol_block=ncol_block,error=error) + ncol_block=ncol_block) CALL fm_pool_create(mpools%mosub_mosub_fm_pools(ispin)%pool,& - fmstruct,error=error) - CALL cp_fm_struct_release(fmstruct,error=error) + fmstruct) + CALL cp_fm_struct_release(fmstruct) END DO END IF END IF ! should_rebuild diff --git a/src/qs_mo_io.F b/src/qs_mo_io.F index cd9df90941..54e529a84d 100644 --- a/src/qs_mo_io.F +++ b/src/qs_mo_io.F @@ -107,10 +107,9 @@ MODULE qs_mo_io !> \param kpoints ... !> \param atomic_kind_set ... !> \param qs_kind_set ... -!> \param error ... ! ***************************************************************************** SUBROUTINE write_mo_set_to_restart(mo_array,particle_set,dft_section,& - kpoints,atomic_kind_set,qs_kind_set,error) + kpoints,atomic_kind_set,qs_kind_set) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array @@ -122,7 +121,6 @@ SUBROUTINE write_mo_set_to_restart(mo_array,particle_set,dft_section,& POINTER :: atomic_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_mo_set_to_restart', & routineP = moduleN//':'//routineN @@ -135,12 +133,12 @@ SUBROUTINE write_mo_set_to_restart(mo_array,particle_set,dft_section,& CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,keys(1),error=error),cp_p_file) .OR. & + dft_section,keys(1)),cp_p_file) .OR. & BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,keys(2),error=error),cp_p_file) ) THEN + dft_section,keys(2)),cp_p_file) ) THEN IF(PRESENT(kpoints)) THEN write_kp = (kpoints%nkp > 0) @@ -153,28 +151,28 @@ SUBROUTINE write_mo_set_to_restart(mo_array,particle_set,dft_section,& ! we copy it to the fm for anycase DO ispin=1,SIZE(mo_array) IF(.not.ASSOCIATED(mo_array(ispin)%mo_set%mo_coeff_b)) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL copy_dbcsr_to_fm(mo_array(ispin)%mo_set%mo_coeff_b,& - mo_array(ispin)%mo_set%mo_coeff,error=error)!fm->dbcsr + mo_array(ispin)%mo_set%mo_coeff)!fm->dbcsr ENDDO ENDIF DO ikey=1,SIZE(keys) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,keys(ikey),error=error),cp_p_file)) THEN + dft_section,keys(ikey)),cp_p_file)) THEN ires = cp_print_key_unit_nr(logger,dft_section,keys(ikey),& extension=".wfn", file_status="REPLACE", file_action="WRITE",& - do_backup=.TRUE., file_form="UNFORMATTED", error=error) + do_backup=.TRUE., file_form="UNFORMATTED") CALL write_mo_set_low(mo_array, particle_set=particle_set, & - qs_kind_set=qs_kind_set,ires=ires, error=error) + qs_kind_set=qs_kind_set,ires=ires) - IF(write_kp) CALL write_mos_kp(kpoints, ires=ires, error=error) + IF(write_kp) CALL write_mos_kp(kpoints, ires=ires) - CALL cp_print_key_finished_output(ires,logger,dft_section,TRIM(keys(ikey)), error=error) + CALL cp_print_key_finished_output(ires,logger,dft_section,TRIM(keys(ikey))) END IF END DO END IF @@ -187,13 +185,11 @@ END SUBROUTINE write_mo_set_to_restart !> \brief ... !> \param kpoints ... !> \param ires ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_mos_kp(kpoints,ires,error) + SUBROUTINE write_mos_kp(kpoints,ires) TYPE(kpoint_type), OPTIONAL, POINTER :: kpoints INTEGER, INTENT(IN) :: ires - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_mos_kp', & routineP = moduleN//':'//routineN @@ -250,7 +246,7 @@ SUBROUTINE write_mos_kp(kpoints,ires,error) DO ic=1,SIZE(mos,1) IF (ires > 0) WRITE (ires) ic,is mo_set => mos(ic,is)%mo_set - CALL write_mo_set_basic(mo_set, ires, error) + CALL write_mo_set_basic(mo_set, ires) END DO END DO ! this is for synchronization @@ -273,7 +269,7 @@ SUBROUTINE write_mos_kp(kpoints,ires,error) NULLIFY(mop) mos => kpoints%kp_env(1)%kpoint_env%mos mo_set => mos(1,1)%mo_set - CALL duplicate_mo_set(mop,mo_set,error) + CALL duplicate_mo_set(mop,mo_set) moalloc = .TRUE. END IF mosource = 0 @@ -285,7 +281,7 @@ SUBROUTINE write_mos_kp(kpoints,ires,error) CALL mp_irecv(mop%mo_coeff%local_data,mosource,para_env_inter_kp%group,request,tag) CALL mp_wait(request) IF (ires > 0) WRITE (ires) ic,is - CALL write_mo_set_basic(mop, ires, error) + CALL write_mo_set_basic(mop, ires) END DO END DO ELSE @@ -296,7 +292,7 @@ SUBROUTINE write_mos_kp(kpoints,ires,error) END DO IF(moalloc) THEN - CALL deallocate_mo_set(mop,error) + CALL deallocate_mo_set(mop) moalloc = .FALSE. END IF @@ -311,10 +307,9 @@ END SUBROUTINE write_mos_kp !> \param particle_set ... !> \param dft_section ... !> \param qs_kind_set ... -!> \param error ... ! ***************************************************************************** SUBROUTINE write_rt_mos_to_restart(mo_array,rt_mos,particle_set,dft_section,& - qs_kind_set,error) + qs_kind_set) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array @@ -325,7 +320,6 @@ SUBROUTINE write_rt_mos_to_restart(mo_array,rt_mos,particle_set,dft_section,& TYPE(section_vals_type), POINTER :: dft_section TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_rt_mos_to_restart', & routineP = moduleN//':'//routineN @@ -339,25 +333,25 @@ SUBROUTINE write_rt_mos_to_restart(mo_array,rt_mos,particle_set,dft_section,& CALL timeset(routineN,handle) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,keys(1),error=error),cp_p_file) .OR. & + dft_section,keys(1)),cp_p_file) .OR. & BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,keys(2),error=error),cp_p_file) ) THEN + dft_section,keys(2)),cp_p_file) ) THEN DO ikey=1,SIZE(keys) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,keys(ikey),error=error),cp_p_file)) THEN + dft_section,keys(ikey)),cp_p_file)) THEN ires = cp_print_key_unit_nr(logger,dft_section,keys(ikey),& extension=".rtpwfn", file_status="REPLACE", file_action="WRITE",& - do_backup=.TRUE., file_form="UNFORMATTED", error=error) + do_backup=.TRUE., file_form="UNFORMATTED") CALL write_mo_set_low(mo_array, rt_mos=rt_mos, qs_kind_set=qs_kind_set,& - particle_set=particle_set, ires=ires, error=error) - CALL cp_print_key_finished_output(ires,logger,dft_section,TRIM(keys(ikey)), error=error) + particle_set=particle_set, ires=ires) + CALL cp_print_key_finished_output(ires,logger,dft_section,TRIM(keys(ikey))) END IF END DO END IF @@ -373,9 +367,8 @@ END SUBROUTINE write_rt_mos_to_restart !> \param particle_set ... !> \param ires ... !> \param rt_mos ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_mo_set_low(mo_array, qs_kind_set, particle_set, ires, rt_mos, error) + SUBROUTINE write_mo_set_low(mo_array, qs_kind_set, particle_set, ires, rt_mos) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array @@ -386,7 +379,6 @@ SUBROUTINE write_mo_set_low(mo_array, qs_kind_set, particle_set, ires, rt_mos, e INTEGER :: ires TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: rt_mos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_mo_set_low', & routineP = moduleN//':'//routineN @@ -414,7 +406,7 @@ SUBROUTINE write_mo_set_low(mo_array, qs_kind_set, particle_set, ires, rt_mos, e NULLIFY(orb_basis_set,dftb_parameter) CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind),& - basis_set=orb_basis_set,dftb_parameter=dftb_parameter,error=error) + basis_set=orb_basis_set,dftb_parameter=dftb_parameter) IF (ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& @@ -437,22 +429,22 @@ SUBROUTINE write_mo_set_low(mo_array, qs_kind_set, particle_set, ires, rt_mos, e END DO ALLOCATE (nso_info(nshell_max,nset_max,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nso_info(:,:,:) = 0 ALLOCATE (nshell_info(nset_max,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nshell_info(:,:) = 0 ALLOCATE (nset_info(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nset_info(:) = 0 DO iatom=1,natom NULLIFY(orb_basis_set,dftb_parameter) CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind),& - basis_set=orb_basis_set,dftb_parameter=dftb_parameter,error=error) + basis_set=orb_basis_set,dftb_parameter=dftb_parameter) IF (ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& @@ -488,17 +480,17 @@ SUBROUTINE write_mo_set_low(mo_array, qs_kind_set, particle_set, ires, rt_mos, e WRITE (ires) nso_info DEALLOCATE (nset_info,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (nshell_info,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (nso_info,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! use the scalapack block size as a default for buffering columns - CALL cp_fm_get_info(mo_array(1)%mo_set%mo_coeff,ncol_block=max_block,error=error) + CALL cp_fm_get_info(mo_array(1)%mo_set%mo_coeff,ncol_block=max_block) DO ispin=1,nspin nmo=mo_array(ispin)%mo_set%nmo @@ -512,10 +504,10 @@ SUBROUTINE write_mo_set_low(mo_array, qs_kind_set, particle_set, ires, rt_mos, e END IF IF(PRESENT(rt_mos))THEN DO imat=2*ispin-1,2*ispin - CALL cp_fm_write_unformatted(rt_mos(imat)%matrix,ires,error) + CALL cp_fm_write_unformatted(rt_mos(imat)%matrix,ires) END DO ELSE - CALL cp_fm_write_unformatted(mo_array(ispin)%mo_set%mo_coeff,ires,error) + CALL cp_fm_write_unformatted(mo_array(ispin)%mo_set%mo_coeff,ires) END IF END DO @@ -528,13 +520,11 @@ END SUBROUTINE write_mo_set_low !> \brief ... !> \param mo_set ... !> \param ires ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_mo_set_basic(mo_set, ires, error) + SUBROUTINE write_mo_set_basic(mo_set, ires) TYPE(mo_set_type), POINTER :: mo_set INTEGER :: ires - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_mo_set_basic', & routineP = moduleN//':'//routineN @@ -550,7 +540,7 @@ SUBROUTINE write_mo_set_basic(mo_set, ires, error) WRITE (ires) nao,nmo,mo_set%homo,mo_set%lfomo,mo_set%nelectron WRITE (ires) mo_set%eigenvalues(1:nmo),mo_set%occupation_numbers(1:nmo) END IF - CALL cp_fm_write_unformatted(mo_set%mo_coeff,ires,error) + CALL cp_fm_write_unformatted(mo_set%mo_coeff,ires) CALL timestop(handle) @@ -564,16 +554,14 @@ END SUBROUTINE write_mo_set_basic !> \param logger ... !> \param xas ... !> \param rtp ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE wfn_restart_file_name(filename,exist,section,logger,xas,rtp,error) + SUBROUTINE wfn_restart_file_name(filename,exist,section,logger,xas,rtp) CHARACTER(LEN=default_path_length), & INTENT(OUT) :: filename LOGICAL, INTENT(OUT) :: exist TYPE(section_vals_type), POINTER :: section TYPE(cp_logger_type), POINTER :: logger LOGICAL, INTENT(IN), OPTIONAL :: xas, rtp - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: n_rep_val LOGICAL :: my_rtp, my_xas @@ -585,25 +573,25 @@ SUBROUTINE wfn_restart_file_name(filename,exist,section,logger,xas,rtp,error) IF(PRESENT(rtp)) my_rtp = rtp exist = .FALSE. - CALL section_vals_val_get(section,"WFN_RESTART_FILE_NAME",n_rep_val=n_rep_val,error=error) + CALL section_vals_val_get(section,"WFN_RESTART_FILE_NAME",n_rep_val=n_rep_val) IF (n_rep_val>0) THEN - CALL section_vals_val_get(section,"WFN_RESTART_FILE_NAME",c_val=filename,error=error) + CALL section_vals_val_get(section,"WFN_RESTART_FILE_NAME",c_val=filename) ELSE IF(my_xas) THEN ! try to read from the filename that is generated automatically from the printkey - print_key => section_vals_get_subs_vals(section,"PRINT%RESTART",error=error) + print_key => section_vals_get_subs_vals(section,"PRINT%RESTART") filename = cp_print_key_generate_filename(logger,print_key, & - extension="",my_local=.FALSE., error=error) + extension="",my_local=.FALSE.) ELSE IF (my_rtp)THEN ! try to read from the filename that is generated automatically from the printkey - print_key => section_vals_get_subs_vals(section,"REAL_TIME_PROPAGATION%PRINT%RESTART",error=error) + print_key => section_vals_get_subs_vals(section,"REAL_TIME_PROPAGATION%PRINT%RESTART") filename = cp_print_key_generate_filename(logger,print_key, & - extension=".rtpwfn",my_local=.FALSE., error=error) + extension=".rtpwfn",my_local=.FALSE.) ELSE ! try to read from the filename that is generated automatically from the printkey - print_key => section_vals_get_subs_vals(section,"SCF%PRINT%RESTART",error=error) + print_key => section_vals_get_subs_vals(section,"SCF%PRINT%RESTART") filename = cp_print_key_generate_filename(logger,print_key, & - extension=".wfn", my_local=.FALSE., error=error) + extension=".wfn", my_local=.FALSE.) END IF ENDIF IF(.NOT.my_xas) THEN @@ -624,10 +612,9 @@ END SUBROUTINE wfn_restart_file_name !> \param dft_section ... !> \param natom_mismatch ... !> \param kpoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE read_mo_set_from_restart(mo_array,atomic_kind_set,qs_kind_set,particle_set,& - para_env,id_nr,multiplicity,dft_section,natom_mismatch,kpoints,error) + para_env,id_nr,multiplicity,dft_section,natom_mismatch,kpoints) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array @@ -642,7 +629,6 @@ SUBROUTINE read_mo_set_from_restart(mo_array,atomic_kind_set,qs_kind_set,particl TYPE(section_vals_type), POINTER :: dft_section LOGICAL, INTENT(OUT), OPTIONAL :: natom_mismatch TYPE(kpoint_type), OPTIONAL, POINTER :: kpoints - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_mo_set_from_restart', & routineP = moduleN//':'//routineN @@ -654,7 +640,7 @@ SUBROUTINE read_mo_set_from_restart(mo_array,atomic_kind_set,qs_kind_set,particl TYPE(cp_logger_type), POINTER :: logger CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. nspin = SIZE(mo_array) @@ -666,7 +652,7 @@ SUBROUTINE read_mo_set_from_restart(mo_array,atomic_kind_set,qs_kind_set,particl IF (para_env%ionode) THEN natom = SIZE(particle_set,1) - CALL wfn_restart_file_name(file_name,exist,dft_section,logger,error=error) + CALL wfn_restart_file_name(file_name,exist,dft_section,logger) IF (id_nr/=0) THEN ! Is it one of the backup files? file_name = TRIM(file_name)//".bak-"//ADJUSTL(cp_to_string(id_nr)) @@ -682,8 +668,7 @@ SUBROUTINE read_mo_set_from_restart(mo_array,atomic_kind_set,qs_kind_set,particl CALL read_mos_restart_low (mo_array,para_env=para_env, qs_kind_set=qs_kind_set,& particle_set=particle_set, natom=natom,& - rst_unit=restart_unit, multiplicity=multiplicity, natom_mismatch=natom_mismatch, & - error=error) + rst_unit=restart_unit, multiplicity=multiplicity, natom_mismatch=natom_mismatch) IF (PRESENT(natom_mismatch)) THEN ! read_mos_restart_low only the io_node returns natom_mismatch, must broadcast it CALL mp_bcast(natom_mismatch,source,group) @@ -696,7 +681,7 @@ SUBROUTINE read_mo_set_from_restart(mo_array,atomic_kind_set,qs_kind_set,particl IF(PRESENT(kpoints)) THEN IF(kpoints%nkp > 0) THEN - CALL read_mos_kp(kpoints,restart_unit,error) + CALL read_mos_kp(kpoints,restart_unit) END IF END IF @@ -705,7 +690,7 @@ SUBROUTINE read_mo_set_from_restart(mo_array,atomic_kind_set,qs_kind_set,particl DO ispin = 1,nspin CALL write_mo_set(mo_array(ispin)%mo_set,atomic_kind_set,qs_kind_set,& - particle_set,4,dft_section,error=error) + particle_set,4,dft_section) END DO CALL timestop(handle) @@ -722,10 +707,9 @@ END SUBROUTINE read_mo_set_from_restart !> \param id_nr ... !> \param multiplicity ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** SUBROUTINE read_rt_mos_from_restart(mo_array,rt_mos,atomic_kind_set,qs_kind_set, & - particle_set,para_env,id_nr,multiplicity,dft_section,error) + particle_set,para_env,id_nr,multiplicity,dft_section) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array @@ -740,7 +724,6 @@ SUBROUTINE read_rt_mos_from_restart(mo_array,rt_mos,atomic_kind_set,qs_kind_set, TYPE(cp_para_env_type), POINTER :: para_env INTEGER, INTENT(IN) :: id_nr, multiplicity TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_rt_mos_from_restart', & routineP = moduleN//':'//routineN @@ -752,7 +735,7 @@ SUBROUTINE read_rt_mos_from_restart(mo_array,rt_mos,atomic_kind_set,qs_kind_set, TYPE(cp_logger_type), POINTER :: logger CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. nspin = SIZE(mo_array) @@ -764,7 +747,7 @@ SUBROUTINE read_rt_mos_from_restart(mo_array,rt_mos,atomic_kind_set,qs_kind_set, IF (para_env%ionode) THEN natom = SIZE(particle_set,1) - CALL wfn_restart_file_name(file_name,exist,dft_section,logger,rtp=.TRUE.,error=error) + CALL wfn_restart_file_name(file_name,exist,dft_section,logger,rtp=.TRUE.) IF (id_nr/=0) THEN ! Is it one of the backup files? file_name = TRIM(file_name)//".bak-"//ADJUSTL(cp_to_string(id_nr)) @@ -780,14 +763,14 @@ SUBROUTINE read_rt_mos_from_restart(mo_array,rt_mos,atomic_kind_set,qs_kind_set, CALL read_mos_restart_low (mo_array, rt_mos=rt_mos,para_env= para_env,& particle_set=particle_set, qs_kind_set=qs_kind_set, natom=natom,& - rst_unit=restart_unit, multiplicity=multiplicity, error=error) + rst_unit=restart_unit, multiplicity=multiplicity) ! Close restart file IF (para_env%ionode) CALL close_file(unit_number=restart_unit) DO ispin = 1,nspin CALL write_mo_set(mo_array(ispin)%mo_set,atomic_kind_set,qs_kind_set, & - particle_set,4,dft_section,error=error) + particle_set,4,dft_section) END DO CALL timestop(handle) @@ -797,13 +780,11 @@ END SUBROUTINE read_rt_mos_from_restart !> \brief ... !> \param kpoints ... !> \param ires ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_mos_kp(kpoints,ires,error) + SUBROUTINE read_mos_kp(kpoints,ires) TYPE(kpoint_type), OPTIONAL, POINTER :: kpoints INTEGER, INTENT(IN) :: ires - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_mos_kp', & routineP = moduleN//':'//routineN @@ -824,12 +805,12 @@ SUBROUTINE read_mos_kp(kpoints,ires,error) READ (ires) READ (ires) nkp CALL cp_assert(nkp==kpoints%nkp,cp_fatal_level,cp_assertion_failed,routineP,& - "Different number of kpoints",error,failure) + "Different number of kpoints",failure) DO ik=1,kpoints%nkp READ (ires) wkp,xkp(1:3) dd = ABS(wkp-kpoints%wkp(ik)) + SUM(ABS(xkp(1:3)-kpoints%xkp(1:3,ik))) CALL cp_assert(dd > 1.0e-12_dp,cp_fatal_level,cp_assertion_failed,routineP,& - "Different order/position of kpoints",error,failure) + "Different order/position of kpoints",failure) END DO END IF @@ -846,7 +827,7 @@ SUBROUTINE read_mos_kp(kpoints,ires,error) dd = ABS(ik-jk) dd = dd + ABS(wkp-kpoints%wkp(ik)) + SUM(ABS(xkp(1:3)-kpoints%xkp(1:3,ik))) CALL cp_assert(dd > 1.0e-12_dp,cp_fatal_level,cp_assertion_failed,routineP,& - "Different order/position of kpoints",error,failure) + "Different order/position of kpoints",failure) END IF is_source = .FALSE. IF (ik >= kpoints%kp_range(1) .AND. ik <= kpoints%kp_range(2)) THEN @@ -862,30 +843,30 @@ SUBROUTINE read_mos_kp(kpoints,ires,error) IF (ires > 0) THEN READ (ires) jc,js CALL cp_assert((ic==jc .AND. is==js),cp_fatal_level,cp_assertion_failed,routineP,& - "Different order/position/type of kpoints",error,failure) + "Different order/position/type of kpoints",failure) END IF mo_set => mos(ic,is)%mo_set - CALL read_mo_set_basic(mo_set, ires, error) + CALL read_mo_set_basic(mo_set, ires) END DO END DO ELSE IF(is_source) THEN ! not yet implemented - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ELSE IF(kpoints%iogrp) THEN IF(.NOT.moalloc) THEN NULLIFY(mop) mos => kpoints%kp_env(1)%kpoint_env%mos mo_set => mos(1,1)%mo_set - CALL duplicate_mo_set(mop,mo_set,error) + CALL duplicate_mo_set(mop,mo_set) moalloc = .TRUE. END IF ! not yet implemented - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO IF(moalloc) THEN - CALL deallocate_mo_set(mop,error) + CALL deallocate_mo_set(mop) moalloc = .FALSE. END IF @@ -904,13 +885,12 @@ END SUBROUTINE read_mos_kp !> \param multiplicity ... !> \param rt_mos ... !> \param natom_mismatch ... -!> \param error ... !> \par History !> 12.2007 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, natom, rst_unit, & - multiplicity, rt_mos, natom_mismatch, error) + multiplicity, rt_mos, natom_mismatch) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos @@ -924,7 +904,6 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: rt_mos LOGICAL, INTENT(OUT), OPTIONAL :: natom_mismatch - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_mos_restart_low', & routineP = moduleN//':'//routineN @@ -945,7 +924,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato TYPE(gto_basis_set_type), POINTER :: orb_basis_set TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() nspin = SIZE(mos) nao = mos(1)%mo_set%nao @@ -984,13 +963,13 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato ! Let's make it possible to change the basis set ALLOCATE (nso_info(nshell_max,nset_max,natom_read),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (nshell_info(nset_max,natom_read),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (nset_info(natom_read),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (offset_info(nshell_max,nset_max,natom_read),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (nao_read /= nao) THEN WRITE(cp_logger_get_default_unit_nr(logger),*) & @@ -1017,7 +996,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato END DO ALLOCATE(vecbuffer_read(1,nao_read),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! natom_match END IF ! ionode @@ -1042,7 +1021,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato CALL mp_bcast(nspin_read,source,group) ALLOCATE (vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin=1,nspin @@ -1050,12 +1029,12 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato homo=mos(ispin)%mo_set%homo mos(ispin)%mo_set%eigenvalues(:) = 0.0_dp mos(ispin)%mo_set%occupation_numbers(:) = 0.0_dp - CALL cp_fm_set_all(mos(ispin)%mo_set%mo_coeff,0.0_dp,error=error) + CALL cp_fm_set_all(mos(ispin)%mo_set%mo_coeff,0.0_dp) IF (para_env%ionode.AND.(nmo > 0)) THEN READ (rst_unit) nmo_read, homo_read, lfomo_read, nelectron_read ALLOCATE(eig_read(nmo_read), occ_read(nmo_read), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) eig_read = 0.0_dp occ_read = 0.0_dp @@ -1075,7 +1054,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato mos(ispin)%mo_set%eigenvalues(1:nmo) = eig_read(1:nmo) mos(ispin)%mo_set%occupation_numbers(1:nmo) = occ_read(1:nmo) DEALLOCATE(eig_read, occ_read, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mos(ispin)%mo_set%homo = homo_read mos(ispin)%mo_set%lfomo = lfomo_read @@ -1086,7 +1065,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato "the allocated MOs. The read MO set will be truncated and the occupation numbers recalculated!"//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,error=error) + CALL set_mo_occupation(mo_set=mos(ispin)%mo_set) ELSE ! can not make this a warning i.e. homo must be smaller than nmo ! otherwise e.g. set_mo_occupation will go out of bounds @@ -1114,7 +1093,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato END IF CALL mp_bcast(vecbuffer,source,group) CALL cp_fm_set_submatrix(rt_mos(imat)%matrix,& - vecbuffer,1,i,nao,1,transpose=.TRUE.,error=error) + vecbuffer,1,i,nao,1,transpose=.TRUE.) END DO END DO ELSE @@ -1128,7 +1107,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato NULLIFY(orb_basis_set,dftb_parameter,l,nshell) CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind),& - basis_set=orb_basis_set,dftb_parameter=dftb_parameter,error=error) + basis_set=orb_basis_set,dftb_parameter=dftb_parameter) IF (ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& @@ -1199,7 +1178,7 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato CALL mp_bcast(vecbuffer,source,group) CALL cp_fm_set_submatrix(mos(ispin)%mo_set%mo_coeff,& - vecbuffer,1,i,nao,1,transpose=.TRUE.,error=error) + vecbuffer,1,i,nao,1,transpose=.TRUE.) END DO END IF ! Skip extra MOs if there any @@ -1233,26 +1212,26 @@ SUBROUTINE read_mos_restart_low (mos, para_env, qs_kind_set, particle_set, nato mos(ispin+1)%mo_set%eigenvalues = mos(ispin)%mo_set%eigenvalues mos(ispin)%mo_set%occupation_numbers = mos(ispin)%mo_set%occupation_numbers/2.0_dp mos(ispin+1)%mo_set%occupation_numbers = mos(ispin)%mo_set%occupation_numbers - CALL cp_fm_to_fm(mos(ispin)%mo_set%mo_coeff,mos(ispin+1)%mo_set%mo_coeff,error=error) + CALL cp_fm_to_fm(mos(ispin)%mo_set%mo_coeff,mos(ispin+1)%mo_set%mo_coeff) EXIT END IF END IF END DO ! ispin DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (para_env%ionode) THEN DEALLOCATE(vecbuffer_read,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(offset_info,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(nso_info,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(nshell_info,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(nset_info,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE read_mos_restart_low @@ -1261,13 +1240,11 @@ END SUBROUTINE read_mos_restart_low !> \brief ... !> \param mo_set ... !> \param ires ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_mo_set_basic (mo_set, ires, error) + SUBROUTINE read_mo_set_basic (mo_set, ires) TYPE(mo_set_type), POINTER :: mo_set INTEGER, INTENT(in) :: ires - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_mo_set_basic', & routineP = moduleN//':'//routineN @@ -1281,12 +1258,12 @@ SUBROUTINE read_mo_set_basic (mo_set, ires, error) IF ((ires>0).AND.(nmo > 0)) THEN READ (ires) nao,nmo,mo_set%homo,mo_set%lfomo,mo_set%nelectron CALL cp_assert(mao==nao,cp_fatal_level,cp_assertion_failed,routineP,& - "Different size of basis set",error,failure) + "Different size of basis set",failure) CALL cp_assert(mmo==nmo,cp_fatal_level,cp_assertion_failed,routineP,& - "Different number of MOs",error,failure) + "Different number of MOs",failure) READ (ires) mo_set%eigenvalues(1:nmo),mo_set%occupation_numbers(1:nmo) END IF - CALL cp_fm_read_unformatted(mo_set%mo_coeff,ires,error) + CALL cp_fm_read_unformatted(mo_set%mo_coeff,ires) END SUBROUTINE read_mo_set_basic @@ -1301,7 +1278,6 @@ END SUBROUTINE read_mo_set_basic !> \param dft_section ... !> \param spin ... !> \param last ... -!> \param error ... !> \date 15.05.2001 !> \par History: !> - Optionally print Cartesian MOs (20.04.2005,MK) @@ -1312,7 +1288,7 @@ END SUBROUTINE read_mo_set_basic !> \version 1.0 ! ***************************************************************************** SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,particle_set,& - before,dft_section,spin,last,error) + before,dft_section,spin,last) TYPE(mo_set_type), POINTER :: mo_set TYPE(atomic_kind_type), DIMENSION(:), & @@ -1325,7 +1301,6 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic TYPE(section_vals_type), POINTER :: dft_section CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: spin LOGICAL, INTENT(IN), OPTIONAL :: last - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_mo_set_to_output_unit', & routineP = moduleN//':'//routineN @@ -1361,18 +1336,18 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic NULLIFY (mo_index_range) NULLIFY (nshell) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ionode = logger%para_env%mepos==logger%para_env%source failure = .FALSE. - CALL section_vals_val_get(dft_section,"PRINT%MO%EIGENVALUES",l_val=p_eval,error=error) - CALL section_vals_val_get(dft_section,"PRINT%MO%EIGENVECTORS",l_val=p_evec,error=error) - CALL section_vals_val_get(dft_section,"PRINT%MO%OCCUPATION_NUMBERS",l_val=p_occ,error=error) - CALL section_vals_val_get(dft_section,"PRINT%MO%CARTESIAN",l_val=p_cart,error=error) - CALL section_vals_val_get(dft_section,"PRINT%MO%MO_INDEX_RANGE",i_vals=mo_index_range,error=error) - CALL section_vals_val_get(dft_section,"PRINT%MO%NDIGITS",i_val=after,error=error) + CALL section_vals_val_get(dft_section,"PRINT%MO%EIGENVALUES",l_val=p_eval) + CALL section_vals_val_get(dft_section,"PRINT%MO%EIGENVECTORS",l_val=p_evec) + CALL section_vals_val_get(dft_section,"PRINT%MO%OCCUPATION_NUMBERS",l_val=p_occ) + CALL section_vals_val_get(dft_section,"PRINT%MO%CARTESIAN",l_val=p_cart) + CALL section_vals_val_get(dft_section,"PRINT%MO%MO_INDEX_RANGE",i_vals=mo_index_range) + CALL section_vals_val_get(dft_section,"PRINT%MO%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) should_output = BTEST(cp_print_key_should_output(logger%iter_info,dft_section,& - "PRINT%MO",error=error),cp_p_file) + "PRINT%MO"),cp_p_file) IF ((.NOT.should_output).OR.(.NOT.(p_eval.OR.p_evec.OR.p_occ))) RETURN @@ -1387,24 +1362,24 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic IF (p_evec) THEN CALL cp_fm_get_info(mo_set%mo_coeff,& nrow_global=nrow_global,& - ncol_global=ncol_global,error=error) + ncol_global=ncol_global) ALLOCATE(smatrix(nrow_global,ncol_global),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_fm_get_submatrix(mo_set%mo_coeff,smatrix,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_fm_get_submatrix(mo_set%mo_coeff,smatrix) IF (.NOT.ionode) THEN DEALLOCATE(smatrix,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%MO",& ignore_should_output=should_output,& - extension=".MOLog",error=error) + extension=".MOLog") IF (iw > 0) THEN CALL get_atomic_kind_set(atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set, ncgf=ncgf, nsgf=nsgf,error=error) + CALL get_qs_kind_set(qs_kind_set, ncgf=ncgf, nsgf=nsgf) ! Definition of the variable formats @@ -1444,7 +1419,7 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic END IF ALLOCATE(cmatrix(ncgf,ncgf),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) cmatrix = 0.0_dp @@ -1457,7 +1432,7 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind),& basis_set=orb_basis_set,& - dftb_parameter=dftb_parameter,error=error) + dftb_parameter=dftb_parameter) IF (ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& @@ -1566,7 +1541,7 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic element_symbol=element_symbol, kind_number=ikind) CALL get_qs_kind(qs_kind_set(ikind),& basis_set=orb_basis_set,& - dftb_parameter=dftb_parameter,error=error) + dftb_parameter=dftb_parameter) IF (p_cart) THEN @@ -1666,10 +1641,10 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic ! Release work storage DEALLOCATE (smatrix,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (p_cart) THEN DEALLOCATE (cmatrix,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ELSE IF (p_occ.OR.p_eval) THEN @@ -1707,8 +1682,7 @@ SUBROUTINE write_mo_set_to_output_unit(mo_set,atomic_kind_set,qs_kind_set,partic END IF ! iw CALL cp_print_key_finished_output(iw,logger,dft_section,"PRINT%MO",& - ignore_should_output=should_output,& - error=error) + ignore_should_output=should_output) END SUBROUTINE write_mo_set_to_output_unit diff --git a/src/qs_mo_methods.F b/src/qs_mo_methods.F index df04caf2ba..daa676e25f 100644 --- a/src/qs_mo_methods.F +++ b/src/qs_mo_methods.F @@ -85,15 +85,13 @@ MODULE qs_mo_methods !> \param vmatrix ... !> \param ncol ... !> \param matrix_s ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE make_basis_sm(vmatrix,ncol,matrix_s,error) + SUBROUTINE make_basis_sm(vmatrix,ncol,matrix_s) TYPE(cp_fm_type), POINTER :: vmatrix INTEGER, INTENT(IN) :: ncol TYPE(cp_dbcsr_type), POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'make_basis_sm', & routineP = moduleN//':'//routineN @@ -107,25 +105,25 @@ SUBROUTINE make_basis_sm(vmatrix,ncol,matrix_s,error) CALL timeset(routineN,handle) - CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global,error=error) + CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global) IF (ncol.gt.ncol_global) CALL stop_program(routineN,moduleN,__LINE__,"Wrong ncol value") - CALL cp_fm_create(svmatrix,vmatrix%matrix_struct,"SV",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s,vmatrix,svmatrix,ncol,error=error) + CALL cp_fm_create(svmatrix,vmatrix%matrix_struct,"SV") + CALL cp_dbcsr_sm_fm_multiply(matrix_s,vmatrix,svmatrix,ncol) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol,& para_env=vmatrix%matrix_struct%para_env, & - context=vmatrix%matrix_struct%context,error=error) - CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=vmatrix%matrix_struct%context) + CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,svmatrix,rzero, overlap_vv,error=error) - CALL cp_fm_cholesky_decompose(overlap_vv,error=error) - CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.,error=error) + CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,svmatrix,rzero, overlap_vv) + CALL cp_fm_cholesky_decompose(overlap_vv) + CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.) - CALL cp_fm_release(overlap_vv,error=error) - CALL cp_fm_release(svmatrix,error=error) + CALL cp_fm_release(overlap_vv) + CALL cp_fm_release(svmatrix) CALL timestop(handle) @@ -136,16 +134,14 @@ END SUBROUTINE make_basis_sm !> \param vmatrix ... !> \param ncol ... !> \param svmatrix ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE make_basis_sv_fm(vmatrix,ncol,svmatrix,error) + SUBROUTINE make_basis_sv_fm(vmatrix,ncol,svmatrix) TYPE(cp_fm_type), POINTER :: vmatrix INTEGER, INTENT(IN) :: ncol TYPE(cp_fm_type), POINTER :: svmatrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'make_basis_sv_fm', & routineP = moduleN//':'//routineN @@ -160,21 +156,21 @@ SUBROUTINE make_basis_sv_fm(vmatrix,ncol,svmatrix,error) CALL timeset(routineN,handle) NULLIFY(fm_struct_tmp) - CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global,error=error) + CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global) IF (ncol.gt.ncol_global) CALL stop_program(routineN,moduleN,__LINE__,"Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol,& para_env=vmatrix%matrix_struct%para_env, & - context=vmatrix%matrix_struct%context,error=error) - CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=vmatrix%matrix_struct%context) + CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,svmatrix,rzero, overlap_vv,error=error) - CALL cp_fm_cholesky_decompose(overlap_vv,error=error) - CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.,error=error) - CALL cp_fm_triangular_multiply(overlap_vv,svmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.,error=error) + CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,svmatrix,rzero, overlap_vv) + CALL cp_fm_cholesky_decompose(overlap_vv) + CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.) + CALL cp_fm_triangular_multiply(overlap_vv,svmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.) - CALL cp_fm_release(overlap_vv,error=error) + CALL cp_fm_release(overlap_vv) CALL timestop(handle) @@ -187,16 +183,14 @@ END SUBROUTINE make_basis_sv_fm !> \param svmatrix ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE make_basis_sv_dbcsr(vmatrix,ncol,svmatrix,para_env,blacs_env,error) + SUBROUTINE make_basis_sv_dbcsr(vmatrix,ncol,svmatrix,para_env,blacs_env) TYPE(cp_dbcsr_type) :: vmatrix INTEGER, INTENT(IN) :: ncol TYPE(cp_dbcsr_type) :: svmatrix TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'make_basis_sv_dbcsr', & routineP = moduleN//':'//routineN @@ -211,36 +205,36 @@ SUBROUTINE make_basis_sv_dbcsr(vmatrix,ncol,svmatrix,para_env,blacs_env,error) CALL timeset(routineN,handle) - !CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global,error=error) + !CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global) CALL cp_dbcsr_get_info(vmatrix,nfullrows_total=n,nfullcols_total=ncol_global) IF (ncol.gt.ncol_global) CALL stop_program(routineN,moduleN,__LINE__,"Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp,context=blacs_env,nrow_global=ncol,& - ncol_global=ncol,para_env=para_env,error=error) - CALL cp_fm_create(overlap_vv,fm_struct_tmp,name="fm_overlap_vv",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + ncol_global=ncol,para_env=para_env) + CALL cp_fm_create(overlap_vv,fm_struct_tmp,name="fm_overlap_vv") + CALL cp_fm_struct_release(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp,context=blacs_env,nrow_global=n,& - ncol_global=ncol_global,para_env=para_env,error=error) - CALL cp_fm_create(fm_vmatrix,fm_struct_tmp,name="fm_vmatrix",error=error) - CALL cp_fm_create(fm_svmatrix,fm_struct_tmp,name="fm_svmatrix",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + ncol_global=ncol_global,para_env=para_env) + CALL cp_fm_create(fm_vmatrix,fm_struct_tmp,name="fm_vmatrix") + CALL cp_fm_create(fm_svmatrix,fm_struct_tmp,name="fm_svmatrix") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL copy_dbcsr_to_fm(vmatrix,fm_vmatrix,error=error) - CALL copy_dbcsr_to_fm(svmatrix,fm_svmatrix,error=error) + CALL copy_dbcsr_to_fm(vmatrix,fm_vmatrix) + CALL copy_dbcsr_to_fm(svmatrix,fm_svmatrix) - CALL cp_gemm('T','N',ncol,ncol,n,rone,fm_vmatrix,fm_svmatrix,rzero, overlap_vv,error=error) - CALL cp_fm_cholesky_decompose(overlap_vv,error=error) - CALL cp_fm_triangular_multiply(overlap_vv,fm_vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.,error=error) - CALL cp_fm_triangular_multiply(overlap_vv,fm_svmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.,error=error) + CALL cp_gemm('T','N',ncol,ncol,n,rone,fm_vmatrix,fm_svmatrix,rzero, overlap_vv) + CALL cp_fm_cholesky_decompose(overlap_vv) + CALL cp_fm_triangular_multiply(overlap_vv,fm_vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.) + CALL cp_fm_triangular_multiply(overlap_vv,fm_svmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.) - CALL copy_fm_to_dbcsr(fm_vmatrix,vmatrix, error=error) - CALL copy_fm_to_dbcsr(fm_svmatrix,svmatrix, error=error) + CALL copy_fm_to_dbcsr(fm_vmatrix,vmatrix) + CALL copy_fm_to_dbcsr(fm_svmatrix,svmatrix) - CALL cp_fm_release(overlap_vv,error=error) - CALL cp_fm_release(fm_vmatrix,error=error) - CALL cp_fm_release(fm_svmatrix,error=error) + CALL cp_fm_release(overlap_vv) + CALL cp_fm_release(fm_vmatrix) + CALL cp_fm_release(fm_svmatrix) CALL timestop(handle) @@ -252,7 +246,6 @@ END SUBROUTINE make_basis_sv_dbcsr !> \param vmatrix ... !> \param ncol ... !> \param ortho cholesky decomposed S matrix -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] !> \note @@ -260,12 +253,11 @@ END SUBROUTINE make_basis_sv_dbcsr !> use make_basis_sm since this is much faster than computing the !> cholesky decomposition of S ! ***************************************************************************** - SUBROUTINE make_basis_cholesky(vmatrix,ncol,ortho,error) + SUBROUTINE make_basis_cholesky(vmatrix,ncol,ortho) TYPE(cp_fm_type), POINTER :: vmatrix INTEGER, INTENT(IN) :: ncol TYPE(cp_fm_type), POINTER :: ortho - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'make_basis_cholesky', & routineP = moduleN//':'//routineN @@ -280,22 +272,22 @@ SUBROUTINE make_basis_cholesky(vmatrix,ncol,ortho,error) CALL timeset(routineN,handle) NULLIFY(fm_struct_tmp) - CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global,error=error) + CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global) IF (ncol.gt.ncol_global) CALL stop_program(routineN,moduleN,__LINE__,"Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol,& para_env=vmatrix%matrix_struct%para_env, & - context=vmatrix%matrix_struct%context,error=error) - CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=vmatrix%matrix_struct%context) + CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL cp_fm_triangular_multiply(ortho,vmatrix,n_cols=ncol,error=error) - CALL cp_fm_syrk('U','T',n,rone,vmatrix,1,1,rzero,overlap_vv,error=error) - CALL cp_fm_cholesky_decompose(overlap_vv,error=error) - CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.,error=error) - CALL cp_fm_triangular_multiply(ortho,vmatrix,n_cols=ncol,invert_tr=.TRUE.,error=error) + CALL cp_fm_triangular_multiply(ortho,vmatrix,n_cols=ncol) + CALL cp_fm_syrk('U','T',n,rone,vmatrix,1,1,rzero,overlap_vv) + CALL cp_fm_cholesky_decompose(overlap_vv) + CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.) + CALL cp_fm_triangular_multiply(ortho,vmatrix,n_cols=ncol,invert_tr=.TRUE.) - CALL cp_fm_release(overlap_vv,error=error) + CALL cp_fm_release(overlap_vv) CALL timestop(handle) @@ -308,18 +300,16 @@ END SUBROUTINE make_basis_cholesky !> \param vmatrix ... !> \param ncol ... !> \param matrix_s ... -!> \param error ... !> \param !> \par History !> 05.2009 created [MI] !> \note ! ***************************************************************************** - SUBROUTINE make_basis_lowdin(vmatrix,ncol,matrix_s,error) + SUBROUTINE make_basis_lowdin(vmatrix,ncol,matrix_s) TYPE(cp_fm_type), POINTER :: vmatrix INTEGER, INTENT(IN) :: ncol TYPE(cp_dbcsr_type), POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'make_basis_lowdin', & routineP = moduleN//':'//routineN @@ -335,28 +325,28 @@ SUBROUTINE make_basis_lowdin(vmatrix,ncol,matrix_s,error) CALL timeset(routineN,handle) NULLIFY(fm_struct_tmp) threshold = 1.0E-7_dp - CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global,error=error) + CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global) IF (ncol.gt.ncol_global) CALL stop_program(routineN,moduleN,__LINE__,"Wrong ncol value") - CALL cp_fm_create(sc,vmatrix%matrix_struct,"SC",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s,vmatrix,sc,ncol,error=error) + CALL cp_fm_create(sc,vmatrix%matrix_struct,"SC") + CALL cp_dbcsr_sm_fm_multiply(matrix_s,vmatrix,sc,ncol) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol,& para_env=vmatrix%matrix_struct%para_env, & - context=vmatrix%matrix_struct%context,error=error) - CALL cp_fm_create(csc,fm_struct_tmp,"csc",error=error) - CALL cp_fm_create(work,fm_struct_tmp,"work",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - - CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,sc,rzero, csc,error=error) - CALL cp_fm_power(csc,work,-0.5_dp, threshold,ndep,error=error) - CALL cp_gemm('N','N',n,ncol,ncol,rone,vmatrix,csc,rzero,sc,error=error) + context=vmatrix%matrix_struct%context) + CALL cp_fm_create(csc,fm_struct_tmp,"csc") + CALL cp_fm_create(work,fm_struct_tmp,"work") + CALL cp_fm_struct_release(fm_struct_tmp) + + CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,sc,rzero, csc) + CALL cp_fm_power(csc,work,-0.5_dp, threshold,ndep) + CALL cp_gemm('N','N',n,ncol,ncol,rone,vmatrix,csc,rzero,sc) CALL cp_fm_to_fm(sc, vmatrix, ncol, 1,1) - CALL cp_fm_release(csc,error=error) - CALL cp_fm_release(sc,error=error) - CALL cp_fm_release(work,error=error) + CALL cp_fm_release(csc) + CALL cp_fm_release(sc) + CALL cp_fm_release(work) CALL timestop(handle) @@ -367,15 +357,13 @@ END SUBROUTINE make_basis_lowdin !> spanning the same space (notice, only for cases where S==1) !> \param vmatrix ... !> \param ncol ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE make_basis_simple(vmatrix,ncol,error) + SUBROUTINE make_basis_simple(vmatrix,ncol) TYPE(cp_fm_type), POINTER :: vmatrix INTEGER, INTENT(IN) :: ncol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'make_basis_simple', & routineP = moduleN//':'//routineN @@ -391,20 +379,20 @@ SUBROUTINE make_basis_simple(vmatrix,ncol,error) NULLIFY(fm_struct_tmp) - CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global,error=error) + CALL cp_fm_get_info(matrix=vmatrix,nrow_global=n,ncol_global=ncol_global) IF (ncol.gt.ncol_global) CALL stop_program(routineN,moduleN,__LINE__,"Wrong ncol value") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol,& para_env=vmatrix%matrix_struct%para_env, & - context=vmatrix%matrix_struct%context,error=error) - CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=vmatrix%matrix_struct%context) + CALL cp_fm_create(overlap_vv,fm_struct_tmp,"overlap_vv") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,vmatrix,rzero, overlap_vv,error=error) - CALL cp_fm_cholesky_decompose(overlap_vv,error=error) - CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.,error=error) + CALL cp_gemm('T','N',ncol,ncol,n,rone,vmatrix,vmatrix,rzero, overlap_vv) + CALL cp_fm_cholesky_decompose(overlap_vv) + CALL cp_fm_triangular_multiply(overlap_vv,vmatrix,n_cols=ncol,side='R',invert_tr=.TRUE.) - CALL cp_fm_release(overlap_vv,error=error) + CALL cp_fm_release(overlap_vv) CALL timestop(handle) @@ -415,19 +403,17 @@ END SUBROUTINE make_basis_simple !> \param mo_set ... !> \param density_matrix ... !> \param use_dbcsr ... -!> \param error ... !> \date 06.2002 !> \par History !> - Fractional occupied orbitals (MK) !> \author Joost VandeVondele !> \version 1.0 ! ***************************************************************************** - SUBROUTINE calculate_dm_sparse(mo_set,density_matrix,use_dbcsr,error) + SUBROUTINE calculate_dm_sparse(mo_set,density_matrix,use_dbcsr) TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_dbcsr_type), POINTER :: density_matrix LOGICAL, INTENT(IN), OPTIONAL :: use_dbcsr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_dm_sparse', & routineP = moduleN//':'//routineN @@ -448,43 +434,43 @@ SUBROUTINE calculate_dm_sparse(mo_set,density_matrix,use_dbcsr,error) END IF END IF - CALL cp_dbcsr_set(density_matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(density_matrix,0.0_dp) IF ( .NOT. mo_set%uniform_occupation ) THEN ! not all orbitals 1..homo are equally occupied IF(my_use_dbcsr) THEN - CALL cp_dbcsr_init(dbcsr_tmp,error=error) - CALL cp_dbcsr_copy(dbcsr_tmp,mo_set%mo_coeff_b,error=error) + CALL cp_dbcsr_init(dbcsr_tmp) + CALL cp_dbcsr_copy(dbcsr_tmp,mo_set%mo_coeff_b) CALL cp_dbcsr_scale_by_vector(dbcsr_tmp,mo_set%occupation_numbers(1:mo_set%homo),& - side='right',error=error) + side='right') CALL cp_dbcsr_multiply("N", "T", 1.0_dp, mo_set%mo_coeff_b, dbcsr_tmp,& 1.0_dp, density_matrix, retain_sparsity=.TRUE.,& - last_k = mo_set%homo, error=error) - CALL cp_dbcsr_release(dbcsr_tmp, error=error) + last_k = mo_set%homo) + CALL cp_dbcsr_release(dbcsr_tmp) ELSE NULLIFY(fm_tmp) - CALL cp_fm_create(fm_tmp,mo_set%mo_coeff%matrix_struct,error=error) - CALL cp_fm_to_fm(mo_set%mo_coeff,fm_tmp,error=error) + CALL cp_fm_create(fm_tmp,mo_set%mo_coeff%matrix_struct) + CALL cp_fm_to_fm(mo_set%mo_coeff,fm_tmp) CALL cp_fm_column_scale(fm_tmp,mo_set%occupation_numbers(1:mo_set%homo)) alpha=1.0_dp CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix,& matrix_v=mo_set%mo_coeff,& matrix_g=fm_tmp,& ncol=mo_set%homo,& - alpha=alpha,error=error) - CALL cp_fm_release(fm_tmp,error=error) + alpha=alpha) + CALL cp_fm_release(fm_tmp) ENDIF ELSE IF(my_use_dbcsr) THEN CALL cp_dbcsr_multiply("N", "T", mo_set%maxocc, mo_set%mo_coeff_b, mo_set%mo_coeff_b,& 1.0_dp, density_matrix, retain_sparsity=.TRUE.,& - last_k = mo_set%homo, error=error) + last_k = mo_set%homo) ELSE alpha=mo_set%maxocc CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix,& matrix_v=mo_set%mo_coeff,& ncol=mo_set%homo,& - alpha=alpha,error=error) + alpha=alpha) ENDIF ENDIF @@ -505,13 +491,12 @@ END SUBROUTINE calculate_dm_sparse !> note that rotating the orbitals is slower !> \param co_rotate an optional set of orbitals rotated by the same rotation matrix !> \param co_rotate_dbcsr ... -!> \param error ... !> \par History !> 08.2004 documented and added do_rotation [Joost VandeVondele] !> 09.2008 only compute eigenvalues if rotation is not needed ! ***************************************************************************** SUBROUTINE subspace_eigenvalues_ks_fm(orbitals,ks_matrix,evals_arg,ionode,scr,& - do_rotation,co_rotate,co_rotate_dbcsr,error) + do_rotation,co_rotate,co_rotate_dbcsr) TYPE(cp_fm_type), POINTER :: orbitals TYPE(cp_dbcsr_type), POINTER :: ks_matrix @@ -522,7 +507,6 @@ SUBROUTINE subspace_eigenvalues_ks_fm(orbitals,ks_matrix,evals_arg,ionode,scr,& LOGICAL, INTENT(IN), OPTIONAL :: do_rotation TYPE(cp_fm_type), OPTIONAL, POINTER :: co_rotate TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: co_rotate_dbcsr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'subspace_eigenvalues_ks_fm', & routineP = moduleN//':'//routineN @@ -545,7 +529,7 @@ SUBROUTINE subspace_eigenvalues_ks_fm(orbitals,ks_matrix,evals_arg,ionode,scr,& NULLIFY(weighted_vectors,weighted_vectors2,h_block,e_vectors,fm_struct_tmp) CALL cp_fm_get_info(matrix=orbitals, & ncol_global=ncol_global, & - nrow_global=nrow_global,error=error) + nrow_global=nrow_global) IF (do_rotation_local) THEN compute_evecs=.TRUE. @@ -560,49 +544,49 @@ SUBROUTINE subspace_eigenvalues_ks_fm(orbitals,ks_matrix,evals_arg,ionode,scr,& ALLOCATE(evals(ncol_global)) - CALL cp_fm_create(weighted_vectors,orbitals%matrix_struct,"weighted_vectors",error=error) + CALL cp_fm_create(weighted_vectors,orbitals%matrix_struct,"weighted_vectors") CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol_global, ncol_global=ncol_global, & para_env=orbitals%matrix_struct%para_env, & - context=orbitals%matrix_struct%context,error=error) - CALL cp_fm_create(h_block,fm_struct_tmp, name="h block",error=error) + context=orbitals%matrix_struct%context) + CALL cp_fm_create(h_block,fm_struct_tmp, name="h block") IF (compute_evecs) THEN - CALL cp_fm_create(e_vectors,fm_struct_tmp, name="e vectors",error=error) + CALL cp_fm_create(e_vectors,fm_struct_tmp, name="e vectors") ENDIF - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_tmp) ! h subblock and diag - CALL cp_dbcsr_sm_fm_multiply(ks_matrix,orbitals,weighted_vectors, ncol_global,error=error) + CALL cp_dbcsr_sm_fm_multiply(ks_matrix,orbitals,weighted_vectors, ncol_global) CALL cp_gemm('T','N',ncol_global,ncol_global,nrow_global,1.0_dp, & - orbitals,weighted_vectors,0.0_dp,h_block,error=error) + orbitals,weighted_vectors,0.0_dp,h_block) ! if eigenvectors are required, go for syevd, otherwise only compute eigenvalues IF (compute_evecs) THEN - CALL choose_eigv_solver(h_block,e_vectors,evals,error=error) + CALL choose_eigv_solver(h_block,e_vectors,evals) ELSE - CALL cp_fm_syevx(h_block,eigenvalues=evals,error=error) + CALL cp_fm_syevx(h_block,eigenvalues=evals) ENDIF ! rotate the orbitals IF (do_rotation_local) THEN CALL cp_gemm('N','N',nrow_global,ncol_global,ncol_global,1.0_dp, & - orbitals,e_vectors,0.0_dp,weighted_vectors,error=error) - CALL cp_fm_to_fm(weighted_vectors,orbitals,error=error) + orbitals,e_vectors,0.0_dp,weighted_vectors) + CALL cp_fm_to_fm(weighted_vectors,orbitals) IF (PRESENT(co_rotate)) THEN IF (ASSOCIATED(co_rotate)) THEN CALL cp_gemm('N','N',nrow_global,ncol_global,ncol_global,1.0_dp, & - co_rotate,e_vectors,0.0_dp,weighted_vectors,error=error) - CALL cp_fm_to_fm(weighted_vectors,co_rotate,error=error) + co_rotate,e_vectors,0.0_dp,weighted_vectors) + CALL cp_fm_to_fm(weighted_vectors,co_rotate) ENDIF ENDIF IF(PRESENT(co_rotate_dbcsr)) THEN IF(ASSOCIATED(co_rotate_dbcsr)) THEN - CALL cp_fm_create(weighted_vectors2,orbitals%matrix_struct,"weighted_vectors",error=error) - CALL copy_dbcsr_to_fm(co_rotate_dbcsr,weighted_vectors2,error) + CALL cp_fm_create(weighted_vectors2,orbitals%matrix_struct,"weighted_vectors") + CALL copy_dbcsr_to_fm(co_rotate_dbcsr,weighted_vectors2) CALL cp_gemm('N','N',nrow_global,ncol_global,ncol_global,1.0_dp, & - weighted_vectors2,e_vectors,0.0_dp,weighted_vectors,error=error) - CALL copy_fm_to_dbcsr(weighted_vectors,co_rotate_dbcsr,error=error) - CALL cp_fm_release(weighted_vectors2,error=error) + weighted_vectors2,e_vectors,0.0_dp,weighted_vectors) + CALL copy_fm_to_dbcsr(weighted_vectors,co_rotate_dbcsr) + CALL cp_fm_release(weighted_vectors2) ENDIF ENDIF ENDIF @@ -632,10 +616,10 @@ SUBROUTINE subspace_eigenvalues_ks_fm(orbitals,ks_matrix,evals_arg,ionode,scr,& ENDIF ENDIF - CALL cp_fm_release(weighted_vectors,error=error) - CALL cp_fm_release(h_block,error=error) + CALL cp_fm_release(weighted_vectors) + CALL cp_fm_release(h_block) IF (compute_evecs) THEN - CALL cp_fm_release(e_vectors,error=error) + CALL cp_fm_release(e_vectors) ENDIF DEALLOCATE(evals) @@ -658,10 +642,9 @@ END SUBROUTINE subspace_eigenvalues_ks_fm !> \param co_rotate ... !> \param para_env ... !> \param blacs_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE subspace_eigenvalues_ks_dbcsr(orbitals,ks_matrix,evals_arg,ionode,scr,& - do_rotation,co_rotate,para_env,blacs_env,error) + do_rotation,co_rotate,para_env,blacs_env) TYPE(cp_dbcsr_type), POINTER :: orbitals, ks_matrix REAL(KIND=dp), DIMENSION(:), OPTIONAL, & @@ -672,7 +655,6 @@ SUBROUTINE subspace_eigenvalues_ks_dbcsr(orbitals,ks_matrix,evals_arg,ionode,scr TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: co_rotate TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_blacs_env_type), POINTER :: blacs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'subspace_eigenvalues_ks_dbcsr', & @@ -710,58 +692,57 @@ SUBROUTINE subspace_eigenvalues_ks_dbcsr(orbitals,ks_matrix,evals_arg,ionode,scr ALLOCATE(evals(ncol_global)) - CALL cp_dbcsr_init_p(weighted_vectors,error=error) - CALL cp_dbcsr_copy(weighted_vectors,orbitals,name="weighted_vectors",error=error) + CALL cp_dbcsr_init_p(weighted_vectors) + CALL cp_dbcsr_copy(weighted_vectors,orbitals,name="weighted_vectors") - CALL cp_dbcsr_init_p(h_block,error=error) + CALL cp_dbcsr_init_p(h_block) CALL cp_dbcsr_m_by_n_from_template(h_block,template=orbitals,m=ncol_global,n=ncol_global,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) !!!!!!!!!!!!!!XXXXXXXXXXXXXXXXXXX!!!!!!!!!!!!! - !CALL cp_fm_create(h_block,fm_struct_tmp, name="h block",error=error) + !CALL cp_fm_create(h_block,fm_struct_tmp, name="h block") IF (compute_evecs) THEN - CALL cp_dbcsr_init_p(e_vectors,error=error) + CALL cp_dbcsr_init_p(e_vectors) CALL cp_dbcsr_m_by_n_from_template(e_vectors,template=orbitals,m=ncol_global,n=ncol_global,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ! CALL cp_dbcsr_create(e_vectors, "e_vectors", dist, dbcsr_type_no_symmetry,& -! row_blk_size, col_blk_size, 0, 0, dbcsr_type_real_default,& -! error=error) - !CALL cp_fm_create(e_vectors,fm_struct_tmp, name="e vectors",error=error) +! row_blk_size, col_blk_size, 0, 0, dbcsr_type_real_default) + !CALL cp_fm_create(e_vectors,fm_struct_tmp, name="e vectors") ENDIF ! CALL cp_dbcsr_distribution_release (dist) ! CALL array_release (row_blk_size);CALL array_release (col_blk_size) - !CALL cp_fm_struct_release(fm_struct_tmp,error=error) + !CALL cp_fm_struct_release(fm_struct_tmp) ! h subblock and diag CALL cp_dbcsr_multiply('N','N',1.0_dp,ks_matrix,orbitals,& - 0.0_dp,weighted_vectors,error=error) - !CALL cp_dbcsr_sm_fm_multiply(ks_matrix,orbitals,weighted_vectors, ncol_global,error=error) + 0.0_dp,weighted_vectors) + !CALL cp_dbcsr_sm_fm_multiply(ks_matrix,orbitals,weighted_vectors, ncol_global) - CALL cp_dbcsr_multiply('T','N',1.0_dp,orbitals,weighted_vectors,0.0_dp,h_block,error=error) + CALL cp_dbcsr_multiply('T','N',1.0_dp,orbitals,weighted_vectors,0.0_dp,h_block) !CALL cp_gemm('T','N',ncol_global,ncol_global,nrow_global,1.0_dp, & - ! orbitals,weighted_vectors,0.0_dp,h_block,error=error) + ! orbitals,weighted_vectors,0.0_dp,h_block) ! if eigenvectors are required, go for syevd, otherwise only compute eigenvalues IF (compute_evecs) THEN - CALL cp_dbcsr_syevd(h_block,e_vectors,evals,para_env=para_env,blacs_env=blacs_env,error=error) + CALL cp_dbcsr_syevd(h_block,e_vectors,evals,para_env=para_env,blacs_env=blacs_env) ELSE - CALL cp_dbcsr_syevx(h_block,eigenvalues=evals,para_env=para_env,blacs_env=blacs_env,error=error) + CALL cp_dbcsr_syevx(h_block,eigenvalues=evals,para_env=para_env,blacs_env=blacs_env) ENDIF ! rotate the orbitals IF (do_rotation_local) THEN - CALL cp_dbcsr_multiply('N','N',1.0_dp,orbitals,e_vectors,0.0_dp,weighted_vectors,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,orbitals,e_vectors,0.0_dp,weighted_vectors) !CALL cp_gemm('N','N',nrow_global,ncol_global,ncol_global,1.0_dp, & - ! orbitals,e_vectors,0.0_dp,weighted_vectors,error=error) - CALL cp_dbcsr_copy(orbitals,weighted_vectors,error=error) - !CALL cp_fm_to_fm(weighted_vectors,orbitals,error=error) + ! orbitals,e_vectors,0.0_dp,weighted_vectors) + CALL cp_dbcsr_copy(orbitals,weighted_vectors) + !CALL cp_fm_to_fm(weighted_vectors,orbitals) IF (PRESENT(co_rotate)) THEN IF (ASSOCIATED(co_rotate)) THEN - CALL cp_dbcsr_multiply('N','N',1.0_dp,co_rotate,e_vectors,0.0_dp,weighted_vectors,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,co_rotate,e_vectors,0.0_dp,weighted_vectors) !CALL cp_gemm('N','N',nrow_global,ncol_global,ncol_global,1.0_dp, & - ! co_rotate,e_vectors,0.0_dp,weighted_vectors,error=error) - CALL cp_dbcsr_copy(co_rotate,weighted_vectors,error=error) - !CALL cp_fm_to_fm(weighted_vectors,co_rotate,error=error) + ! co_rotate,e_vectors,0.0_dp,weighted_vectors) + CALL cp_dbcsr_copy(co_rotate,weighted_vectors) + !CALL cp_fm_to_fm(weighted_vectors,co_rotate) ENDIF ENDIF ENDIF @@ -791,13 +772,13 @@ SUBROUTINE subspace_eigenvalues_ks_dbcsr(orbitals,ks_matrix,evals_arg,ionode,scr ENDIF ENDIF - CALL cp_dbcsr_release_p(weighted_vectors,error=error) - CALL cp_dbcsr_release_p(h_block,error=error) - !CALL cp_fm_release(weighted_vectors,error=error) - !CALL cp_fm_release(h_block,error=error) + CALL cp_dbcsr_release_p(weighted_vectors) + CALL cp_dbcsr_release_p(h_block) + !CALL cp_fm_release(weighted_vectors) + !CALL cp_fm_release(h_block) IF (compute_evecs) THEN - CALL cp_dbcsr_release_p(e_vectors,error=error) - !CALL cp_fm_release(e_vectors,error=error) + CALL cp_dbcsr_release_p(e_vectors) + !CALL cp_fm_release(e_vectors) ENDIF DEALLOCATE(evals) @@ -816,14 +797,12 @@ END SUBROUTINE subspace_eigenvalues_ks_dbcsr !> \param orthonormality ... !> \param mo_array ... !> \param matrix_s ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_orthonormality(orthonormality,mo_array,matrix_s,error) + SUBROUTINE calculate_orthonormality(orthonormality,mo_array,matrix_s) REAL(KIND=dp) :: orthonormality TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_orthonormality', & routineP = moduleN//':'//routineN @@ -845,34 +824,34 @@ SUBROUTINE calculate_orthonormality(orthonormality,mo_array,matrix_s,error) DO ispin=1,nspin IF (PRESENT(matrix_s)) THEN ! get S*C - CALL cp_fm_create(svec,mo_array(ispin)%mo_set%mo_coeff%matrix_struct,error=error) + CALL cp_fm_create(svec,mo_array(ispin)%mo_set%mo_coeff%matrix_struct) CALL cp_fm_get_info(mo_array(ispin)%mo_set%mo_coeff,& - nrow_global=n,ncol_global=k,error=error) + nrow_global=n,ncol_global=k) CALL cp_dbcsr_sm_fm_multiply(matrix_s,mo_array(ispin)%mo_set%mo_coeff,& - svec,k,error=error) + svec,k) ! get C^T (S*C) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=k,ncol_global=k, & para_env=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%para_env, & - context=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create(overlap,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%context) + CALL cp_fm_create(overlap,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) CALL cp_gemm('T','N',k,k,n,1.0_dp, mo_array(ispin)%mo_set%mo_coeff,& - svec,0.0_dp,overlap,error=error) - CALL cp_fm_release(svec,error=error) + svec,0.0_dp,overlap) + CALL cp_fm_release(svec) ELSE ! orthogonal basis C^T C CALL cp_fm_get_info(mo_array(ispin)%mo_set%mo_coeff,& - nrow_global=n,ncol_global=k,error=error) + nrow_global=n,ncol_global=k) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=k,ncol_global=k, & para_env=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%para_env, & - context=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create(overlap,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%context) + CALL cp_fm_create(overlap,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) CALL cp_gemm('T','N',k,k,n,1.0_dp, mo_array(ispin)%mo_set%mo_coeff,& - mo_array(ispin)%mo_set%mo_coeff,0.0_dp,overlap,error=error) + mo_array(ispin)%mo_set%mo_coeff,0.0_dp,overlap) ENDIF CALL cp_fm_get_info(overlap,nrow_local=nrow_local,ncol_local=ncol_local, & - row_indices=row_indices,col_indices=col_indices,error=error) + row_indices=row_indices,col_indices=col_indices) DO i=1,nrow_local DO j=1,ncol_local alpha=overlap%local_data(i,j) @@ -880,7 +859,7 @@ SUBROUTINE calculate_orthonormality(orthonormality,mo_array,matrix_s,error) max_alpha=MAX(max_alpha,ABS(alpha)) ENDDO ENDDO - CALL cp_fm_release(overlap,error=error) + CALL cp_fm_release(overlap) ENDDO CALL mp_max(max_alpha,mo_array(1)%mo_set%mo_coeff%matrix_struct%para_env%group) orthonormality=max_alpha @@ -899,13 +878,11 @@ END SUBROUTINE calculate_orthonormality !> \param mo_array ... !> \param mo_mag_min ... !> \param mo_mag_max ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_magnitude(mo_array,mo_mag_min,mo_mag_max,error) + SUBROUTINE calculate_magnitude(mo_array,mo_mag_min,mo_mag_max) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array REAL(KIND=dp) :: mo_mag_min, mo_mag_max - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_magnitude', & routineP = moduleN//':'//routineN @@ -924,21 +901,21 @@ SUBROUTINE calculate_magnitude(mo_array,mo_mag_min,mo_mag_max,error) mo_mag_max=-HUGE(0.0_dp) DO ispin=1,nspin CALL cp_fm_get_info(mo_array(ispin)%mo_set%mo_coeff,& - nrow_global=n,ncol_global=k,error=error) + nrow_global=n,ncol_global=k) ALLOCATE(evals(k)) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=k,ncol_global=k, & para_env=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%para_env, & - context=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create(overlap,tmp_fm_struct,error=error) - CALL cp_fm_create(evecs,tmp_fm_struct,error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + context=mo_array(ispin)%mo_set%mo_coeff%matrix_struct%context) + CALL cp_fm_create(overlap,tmp_fm_struct) + CALL cp_fm_create(evecs,tmp_fm_struct) + CALL cp_fm_struct_release(tmp_fm_struct) CALL cp_gemm('T','N',k,k,n,1.0_dp, mo_array(ispin)%mo_set%mo_coeff,& - mo_array(ispin)%mo_set%mo_coeff,0.0_dp,overlap,error=error) - CALL choose_eigv_solver(overlap,evecs,evals,error=error) + mo_array(ispin)%mo_set%mo_coeff,0.0_dp,overlap) + CALL choose_eigv_solver(overlap,evecs,evals) mo_mag_min=MIN(MINVAL(evals),mo_mag_min) mo_mag_max=MAX(MAXVAL(evals),mo_mag_max) - CALL cp_fm_release(overlap,error=error) - CALL cp_fm_release(evecs,error=error) + CALL cp_fm_release(overlap) + CALL cp_fm_release(evecs) DEALLOCATE(evals) ENDDO CALL timestop(handle) @@ -953,12 +930,11 @@ END SUBROUTINE calculate_magnitude !> \param scf_control ... !> \param mo_derivs ... !> \param admm_env ... -!> \param error ... !> \par History !> 02.2013 moved from qs_scf_post_gpw !> ! ***************************************************************************** - SUBROUTINE make_mo_eig(mos,nspins,ks_rmpv,scf_control,mo_derivs,admm_env,error) + SUBROUTINE make_mo_eig(mos,nspins,ks_rmpv,scf_control,mo_derivs,admm_env) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos @@ -969,7 +945,6 @@ SUBROUTINE make_mo_eig(mos,nspins,ks_rmpv,scf_control,mo_derivs,admm_env,error) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: mo_derivs TYPE(admm_type), OPTIONAL, POINTER :: admm_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_mo_eig', & routineP = moduleN//':'//routineN @@ -985,7 +960,7 @@ SUBROUTINE make_mo_eig(mos,nspins,ks_rmpv,scf_control,mo_derivs,admm_env,error) NULLIFY(mo_coeff_deriv,mo_coeff,mo_eigenvalues) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) DO ispin=1,nspins @@ -1008,23 +983,21 @@ SUBROUTINE make_mo_eig(mos,nspins,ks_rmpv,scf_control,mo_derivs,admm_env,error) ! ** If we do ADMM, we add have to modify the kohn-sham matrix IF( PRESENT(admm_env) ) THEN - CALL admm_correct_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix, & - error) + CALL admm_correct_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix) END IF CALL calculate_subspace_eigenvalues(mo_coeff,ks_rmpv(ispin)%matrix,mo_eigenvalues, & scr=output_unit, ionode=output_unit>0, do_rotation=.TRUE.,& - co_rotate_dbcsr=mo_coeff_deriv,error=error) + co_rotate_dbcsr=mo_coeff_deriv) ! ** If we do ADMM, we restore the original kohn-sham matrix IF( PRESENT(admm_env) ) THEN - CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix, & - error) + CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix) END IF ELSE IF (output_unit>0) WRITE(output_unit,'(4(1X,1F16.8))') mo_eigenvalues(1:homo) END IF - CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,smear=scf_control%smear,error=error) + CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,smear=scf_control%smear) IF (output_unit>0) WRITE(output_unit,'(T2,A,F12.6)') & "Fermi Energy [eV] :",mos(ispin)%mo_set%mu*evolt ENDDO diff --git a/src/qs_mo_occupation.F b/src/qs_mo_occupation.F index 3508369296..71bfb94620 100644 --- a/src/qs_mo_occupation.F +++ b/src/qs_mo_occupation.F @@ -52,17 +52,15 @@ MODULE qs_mo_occupation !> !> \param mo_array ... !> \param smear ... -!> \param error ... !> \date 10.03.2011 (MI) !> \author MI !> \version 1.0 ! ***************************************************************************** - SUBROUTINE set_mo_occupation_3(mo_array,smear,error) + SUBROUTINE set_mo_occupation_3(mo_array,smear) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array TYPE(smear_type), POINTER :: smear - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_mo_occupation_3', & routineP = moduleN//':'//routineN @@ -79,8 +77,8 @@ SUBROUTINE set_mo_occupation_3(mo_array,smear,error) occ_b failure = .FALSE. - CPPrecondition(ASSOCIATED(mo_array),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(mo_array) == 2),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mo_array),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(mo_array) == 2),cp_failure_level,routineP,failure) CALL timeset(routineN,handle) NULLIFY(eigval_a,eigval_b,occ_a,occ_b) @@ -90,9 +88,9 @@ SUBROUTINE set_mo_occupation_3(mo_array,smear,error) occupation_numbers=occ_b) all_nmo = nmo_a+nmo_b ALLOCATE(all_eigval(all_nmo), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(all_occ(all_nmo), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(all_index(all_nmo), STAT=stat) all_eigval(1:nmo_a) = eigval_a(1:nmo_a) @@ -125,19 +123,19 @@ SUBROUTINE set_mo_occupation_3(mo_array,smear,error) ! this is not a real problem, but the temperature might be a bit large CALL cp_assert(.NOT.is_large,cp_warning_level,cp_assertion_failed,routineP,& "Fermi-Dirac smearing includes the first MO",& - error,failure) + failure) is_large=ABS(MINVAL(all_occ))> smear%eps_fermi_dirac CALL cp_assert(.NOT.is_large,cp_warning_level,cp_assertion_failed,routineP,& "Fermi-Dirac smearing includes the last MO => "//& - "Add more MOs for proper smearing.",error,failure) + "Add more MOs for proper smearing.",failure) ! check that the total electron count is accurate is_large=(ABS(all_nelec - accurate_sum(all_occ(:))) > smear%eps_fermi_dirac*all_nelec) CALL cp_assert(.NOT.is_large,& cp_warning_level,cp_assertion_failed,routineP,& "Total number of electrons is not accurate",& - error,failure) + failure) DO i = 1,all_nmo IF(all_index(i)<=nmo_a) THEN @@ -180,9 +178,9 @@ SUBROUTINE set_mo_occupation_3(mo_array,smear,error) END DO CALL set_mo_set(mo_set=mo_array(1)%mo_set,kTS=kTS/2.0_dp,mu=mu,n_el_f=nelec_a,& - lfomo=lfomo_a,homo=homo_a,uniform_occupation=.FALSE.,error=error) + lfomo=lfomo_a,homo=homo_a,uniform_occupation=.FALSE.) CALL set_mo_set(mo_set=mo_array(2)%mo_set,kTS=kTS/2.0_dp,mu=mu,n_el_f=nelec_b,& - lfomo=lfomo_b,homo=homo_b,uniform_occupation=.FALSE.,error=error) + lfomo=lfomo_b,homo=homo_b,uniform_occupation=.FALSE.) CALL timestop(handle) @@ -194,19 +192,17 @@ END SUBROUTINE set_mo_occupation_3 !> \param mo_array ... !> \param smear ... !> \param eval_deriv ... -!> \param error ... !> \date 25.01.2010 (MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) + SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array TYPE(smear_type), POINTER :: smear REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: eval_deriv - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_mo_occupation_2', & routineP = moduleN//':'//routineN @@ -222,27 +218,27 @@ SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(mo_array),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mo_array),cp_failure_level,routineP,failure) mo_set_a => mo_array(1)%mo_set - CPPrecondition(ASSOCIATED(mo_set_a),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mo_set_a),cp_failure_level,routineP,failure) ! Fall back for the case that we have only one MO set IF (SIZE(mo_array) == 1) THEN IF (PRESENT(eval_deriv)) THEN - CALL set_mo_occupation_1(mo_set_a,smear=smear,eval_deriv=eval_deriv,error=error) + CALL set_mo_occupation_1(mo_set_a,smear=smear,eval_deriv=eval_deriv) ELSE - CALL set_mo_occupation_1(mo_set_a,smear=smear,error=error) + CALL set_mo_occupation_1(mo_set_a,smear=smear) END IF CALL timestop(handle) RETURN END IF - CPPrecondition((SIZE(mo_array) == 2),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(mo_array) == 2),cp_failure_level,routineP,failure) mo_set_b => mo_array(2)%mo_set IF (smear%do_smear) THEN IF (smear%fixed_mag_mom < 0.0_dp) THEN IF (smear%fixed_mag_mom /= -1.0_dp) THEN - CPPrecondition(.NOT.(PRESENT(eval_deriv)),cp_failure_level,routineP,error,failure) - CALL set_mo_occupation_3(mo_array,smear=smear,error=error) + CPPrecondition(.NOT.(PRESENT(eval_deriv)),cp_failure_level,routineP,failure) + CALL set_mo_occupation_3(mo_array,smear=smear) CALL timestop(handle) RETURN END IF @@ -252,20 +248,20 @@ SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) mo_set_a%n_el_f = nelec_f/2.0_dp + smear%fixed_mag_mom/2.0_dp mo_set_b%n_el_f = nelec_f/2.0_dp - smear%fixed_mag_mom/2.0_dp END IF - CPPrecondition(.NOT.(PRESENT(eval_deriv)),cp_failure_level,routineP,error,failure) - CALL set_mo_occupation_1(mo_set_a,smear=smear,error=error) - CALL set_mo_occupation_1(mo_set_b,smear=smear,error=error) + CPPrecondition(.NOT.(PRESENT(eval_deriv)),cp_failure_level,routineP,failure) + CALL set_mo_occupation_1(mo_set_a,smear=smear) + CALL set_mo_occupation_1(mo_set_b,smear=smear) END IF END IF IF (.NOT.((mo_set_a%flexible_electron_count > 0.0_dp).AND.& (mo_set_b%flexible_electron_count > 0.0_dp))) THEN IF (PRESENT(eval_deriv)) THEN - CALL set_mo_occupation_1(mo_set_a,smear=smear,eval_deriv=eval_deriv,error=error) - CALL set_mo_occupation_1(mo_set_b,smear=smear,eval_deriv=eval_deriv,error=error) + CALL set_mo_occupation_1(mo_set_a,smear=smear,eval_deriv=eval_deriv) + CALL set_mo_occupation_1(mo_set_b,smear=smear,eval_deriv=eval_deriv) ELSE - CALL set_mo_occupation_1(mo_set_a,smear=smear,error=error) - CALL set_mo_occupation_1(mo_set_b,smear=smear,error=error) + CALL set_mo_occupation_1(mo_set_a,smear=smear) + CALL set_mo_occupation_1(mo_set_b,smear=smear) END IF CALL timestop(handle) RETURN @@ -278,14 +274,12 @@ SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) CALL cp_assert((mo_set_a%nelectron < mo_set_a%nmo),& cp_warning_level,cp_assertion_failed,routineP,& "All alpha MOs are occupied. Add more alpha MOs to "//& - "allow for a higher multiplicity",only_ionode=.TRUE.,& - error=error) + "allow for a higher multiplicity",only_ionode=.TRUE.) CALL cp_assert(((mo_set_b%nelectron < mo_set_b%nmo).OR.& (mo_set_b%nelectron == mo_set_a%nelectron)),& cp_warning_level,cp_assertion_failed,routineP,& "All beta MOs are occupied. Add more beta MOs to "//& - "allow for a lower multiplicity",only_ionode=.TRUE.,& - error=error) + "allow for a lower multiplicity",only_ionode=.TRUE.) eigval_a => mo_set_a%eigenvalues eigval_b => mo_set_b%eigenvalues @@ -307,8 +301,7 @@ SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) CALL cp_assert((i == nelec),& cp_warning_level,cp_assertion_failed,routineP,& "All alpha MOs are occupied. Add more alpha MOs to "//& - "allow for a higher multiplicity",only_ionode=.TRUE.,& - error=error) + "allow for a higher multiplicity",only_ionode=.TRUE.) IF (i < nelec) THEN lumo_a = lumo_a - 1 lumo_b = lumo_b + 1 @@ -318,8 +311,7 @@ SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) CALL cp_assert((lumo_b >= lumo_a),& cp_warning_level,cp_assertion_failed,routineP,& "All beta MOs are occupied. Add more beta MOs to "//& - "allow for a lower multiplicity",only_ionode=.TRUE.,& - error=error) + "allow for a lower multiplicity",only_ionode=.TRUE.) IF (i < nelec) THEN lumo_a = lumo_a + 1 lumo_b = lumo_b - 1 @@ -337,7 +329,7 @@ SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) ") than alpha ("//& TRIM(ADJUSTL(cp_to_string(mo_set_a%homo)))//& ") MOs are occupied. Resorting to low spin state",& - only_ionode=.TRUE.,error=error) + only_ionode=.TRUE.) mo_set_a%homo = nelec/2 + MODULO(nelec,2) mo_set_b%homo = nelec/2 END IF @@ -351,14 +343,14 @@ SUBROUTINE set_mo_occupation_2(mo_array,smear,eval_deriv,error) "Multiplicity changed from "//& TRIM(ADJUSTL(cp_to_string(multiplicity_old)))//" to "//& TRIM(ADJUSTL(cp_to_string(multiplicity_new))),& - only_ionode=.TRUE.,error=error,failure=failure) + only_ionode=.TRUE.,failure=failure) IF (PRESENT(eval_deriv)) THEN - CALL set_mo_occupation_1(mo_set_a,smear=smear,eval_deriv=eval_deriv,error=error) - CALL set_mo_occupation_1(mo_set_b,smear=smear,eval_deriv=eval_deriv,error=error) + CALL set_mo_occupation_1(mo_set_a,smear=smear,eval_deriv=eval_deriv) + CALL set_mo_occupation_1(mo_set_b,smear=smear,eval_deriv=eval_deriv) ELSE - CALL set_mo_occupation_1(mo_set_a,smear=smear,error=error) - CALL set_mo_occupation_1(mo_set_b,smear=smear,error=error) + CALL set_mo_occupation_1(mo_set_a,smear=smear) + CALL set_mo_occupation_1(mo_set_b,smear=smear) END IF CALL timestop(handle) @@ -372,12 +364,11 @@ END SUBROUTINE set_mo_occupation_2 !> \param eval_deriv on entry the derivative of the KS energy wrt to the occupation number !> on exit the derivative of the full free energy (i.e. KS and entropy) wrt to the eigenvalue !> \param xas_env ... -!> \param error ... !> \date 17.04.2002 (v1.0), 26.08.2008 (v1.1) !> \author Matthias Krack !> \version 1.1 ! ***************************************************************************** - SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) + SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env) TYPE(mo_set_type), POINTER :: mo_set TYPE(smear_type), OPTIONAL, POINTER :: smear @@ -385,7 +376,6 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) POINTER :: eval_deriv TYPE(xas_environment_type), OPTIONAL, & POINTER :: xas_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_mo_occupation_1', & routineP = moduleN//':'//routineN @@ -403,9 +393,9 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(mo_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mo_set%eigenvalues),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mo_set%occupation_numbers),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mo_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mo_set%eigenvalues),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mo_set%occupation_numbers),cp_failure_level,routineP,failure) mo_set%occupation_numbers(:) = 0.0_dp ! Quick return, if no electrons are available @@ -417,7 +407,7 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) xas_estate = -1 occ_estate = 0.0_dp IF(PRESENT(xas_env)) THEN - CALL get_xas_env(xas_env=xas_env, xas_nelectron=xas_nelectron, occ_estate=occ_estate,xas_estate=xas_estate,error=error) + CALL get_xas_env(xas_env=xas_env, xas_nelectron=xas_nelectron, occ_estate=occ_estate,xas_estate=xas_estate) nomo = INT(xas_nelectron + 1 - occ_estate) IF(MOD(xas_nelectron + 1 - occ_estate,1.0_dp)>EPSILON(0.0_dp)) nomo = nomo+1 @@ -427,7 +417,7 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) IF(el_count>xas_nelectron) mo_set%occupation_numbers(nomo) = mo_set%occupation_numbers(nomo) - (el_count-xas_nelectron) el_count = SUM( mo_set%occupation_numbers(1:nomo)) is_large=ABS(el_count-xas_nelectron)>xas_nelectron*EPSILON(el_count) - CPPrecondition(.NOT.is_large,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.is_large,cp_failure_level,routineP,failure) ELSE IF (MODULO(mo_set%nelectron,INT(mo_set%maxocc)) == 0) THEN nomo = NINT(mo_set%nelectron/mo_set%maxocc) @@ -442,8 +432,8 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) END IF nmo = SIZE(mo_set%eigenvalues) - CPPrecondition((nmo >= nomo),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(mo_set%occupation_numbers) == nmo),cp_failure_level,routineP,error,failure) + CPPrecondition((nmo >= nomo),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(mo_set%occupation_numbers) == nmo),cp_failure_level,routineP,failure) mo_set%homo = nomo mo_set%lfomo = nomo + 1 @@ -452,7 +442,7 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) ! Check consistency of the array lengths IF (PRESENT(eval_deriv)) THEN equal_size = (SIZE(mo_set%occupation_numbers,1) == SIZE(eval_deriv,1)) - CPPrecondition(equal_size,cp_failure_level,routineP,error,failure) + CPPrecondition(equal_size,cp_failure_level,routineP,failure) END IF ! Quick return, if no smearing information is supplied (TO BE FIXED, smear should become non-optional...) @@ -497,7 +487,7 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) ! could be a relatively large matrix, but one could get rid of it by never storing it ! we only need dE/df * df/de, one could equally parallelize over entries, this could become expensive ALLOCATE(dfde(nmo,nmo),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! lengthscale could become a parameter, but this is pretty good lengthscale=10*smear%electronic_temperature @@ -510,7 +500,7 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) eval_deriv=MATMUL(TRANSPOSE(dfde),eval_deriv) DEALLOCATE(dfde,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Find the lowest fractional occupied MO (LFOMO) @@ -524,7 +514,7 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) ! this is not a real problem, but the temperature might be a bit large CALL cp_assert(.NOT.is_large,cp_warning_level,cp_assertion_failed,routineP,& "Fermi-Dirac smearing includes the first MO",& - error,failure) + failure) ! Find the highest (fractional) occupied MO which will be now the HOMO DO imo=nmo,mo_set%lfomo,-1 @@ -536,29 +526,29 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) is_large=ABS(MINVAL(mo_set%occupation_numbers))> smear%eps_fermi_dirac CALL cp_assert(.NOT.is_large,cp_warning_level,cp_assertion_failed,routineP,& "Fermi-Dirac smearing includes the last MO => "//& - "Add more MOs for proper smearing.",error,failure) + "Add more MOs for proper smearing.",failure) ! check that the total electron count is accurate is_large=(ABS(nelec - accurate_sum(mo_set%occupation_numbers(:))) > smear%eps_fermi_dirac*nelec) CALL cp_assert(.NOT.is_large,& cp_warning_level,cp_assertion_failed,routineP,& "Total number of electrons is not accurate",& - error,failure) + failure) CASE (smear_energy_window) ! not implemented - CPPrecondition(.NOT.PRESENT(eval_deriv),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(eval_deriv),cp_failure_level,routineP,failure) ! Define the energy window for the eigenvalues e1 = mo_set%eigenvalues(mo_set%homo) - 0.5_dp*smear%window_size CALL cp_assert((e1 > mo_set%eigenvalues(1)),cp_warning_level,cp_assertion_failed,routineP,& "Energy window for smearing includes the first MO",& - error,failure) + failure) e2 = mo_set%eigenvalues(mo_set%homo) + 0.5_dp*smear%window_size CALL cp_assert((e2 < mo_set%eigenvalues(nmo)),cp_warning_level,cp_assertion_failed,routineP,& "Energy window for smearing includes the last MO => "//& - "Add more MOs for proper smearing.",error,failure) + "Add more MOs for proper smearing.",failure) ! Find the lowest fractional occupied MO (LFOMO) DO imo=i_first,nomo @@ -595,7 +585,7 @@ SUBROUTINE set_mo_occupation_1(mo_set,smear,eval_deriv,xas_env, error) CASE (smear_list) equal_size = SIZE(mo_set%occupation_numbers,1)==SIZE(smear%list,1) - CPPrecondition(equal_size,cp_failure_level,routineP,error,failure) + CPPrecondition(equal_size,cp_failure_level,routineP,failure) mo_set%occupation_numbers = smear%list ! there is no dependence of the energy on the eigenvalues IF (PRESENT(eval_deriv)) THEN diff --git a/src/qs_mo_types.F b/src/qs_mo_types.F index 02d7cc74b9..0faf0fbf80 100644 --- a/src/qs_mo_types.F +++ b/src/qs_mo_types.F @@ -95,14 +95,12 @@ MODULE qs_mo_types !> \brief allocate a new mo_set, and copy the old data !> \param mo_set_new ... !> \param mo_set_old ... -!> \param error ... !> \date 2009-7-19 !> \par History !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE duplicate_mo_set(mo_set_new,mo_set_old,error) + SUBROUTINE duplicate_mo_set(mo_set_new,mo_set_old) TYPE(mo_set_type), POINTER :: mo_set_new, mo_set_old - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'duplicate_mo_set', & routineP = moduleN//':'//routineN @@ -113,7 +111,7 @@ SUBROUTINE duplicate_mo_set(mo_set_new,mo_set_old,error) failure = .FALSE. ALLOCATE (mo_set_new,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mo_set_new%maxocc = mo_set_old%maxocc mo_set_new%nelectron = mo_set_old%nelectron @@ -130,22 +128,22 @@ SUBROUTINE duplicate_mo_set(mo_set_new,mo_set_old,error) nmo = mo_set_new%nmo NULLIFY(mo_set_new%mo_coeff) - CALL cp_fm_create(mo_set_new%mo_coeff,mo_set_old%mo_coeff%matrix_struct,error=error) - CALL cp_fm_to_fm(mo_set_old%mo_coeff,mo_set_new%mo_coeff,error=error) + CALL cp_fm_create(mo_set_new%mo_coeff,mo_set_old%mo_coeff%matrix_struct) + CALL cp_fm_to_fm(mo_set_old%mo_coeff,mo_set_new%mo_coeff) NULLIFY(mo_set_new%mo_coeff_b) IF(ASSOCIATED(mo_set_old%mo_coeff_b)) THEN - CALL cp_dbcsr_init_p(mo_set_new%mo_coeff_b,error=error) - CALL cp_dbcsr_copy(mo_set_new%mo_coeff_b,mo_set_old%mo_coeff_b,error=error) + CALL cp_dbcsr_init_p(mo_set_new%mo_coeff_b) + CALL cp_dbcsr_copy(mo_set_new%mo_coeff_b,mo_set_old%mo_coeff_b) ENDIF mo_set_new%use_mo_coeff_b = mo_set_old%use_mo_coeff_b ALLOCATE (mo_set_new%eigenvalues(nmo),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) mo_set_new%eigenvalues = mo_set_old%eigenvalues ALLOCATE (mo_set_new%occupation_numbers(nmo),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) mo_set_new%occupation_numbers = mo_set_old%occupation_numbers END SUBROUTINE duplicate_mo_set @@ -161,21 +159,18 @@ END SUBROUTINE duplicate_mo_set !> \param n_el_f ... !> \param maxocc maximum occupation of an orbital (LDA: 2, LSD:1) !> \param flexible_electron_count the number of electrons can be changed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \date 15.05.2001 !> \par History !> 11.2002 splitted initialization in two phases [fawzi] !> \author Matthias Krack ! ***************************************************************************** SUBROUTINE allocate_mo_set(mo_set,nao,nmo,nelectron,n_el_f,maxocc,& - flexible_electron_count,error) + flexible_electron_count) TYPE(mo_set_type), POINTER :: mo_set INTEGER, INTENT(IN) :: nao, nmo, nelectron REAL(KIND=dp), INTENT(IN) :: n_el_f, maxocc, & flexible_electron_count - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_mo_set', & routineP = moduleN//':'//routineN @@ -185,10 +180,10 @@ SUBROUTINE allocate_mo_set(mo_set,nao,nmo,nelectron,n_el_f,maxocc,& failure = .FALSE. - IF (ASSOCIATED(mo_set)) CALL deallocate_mo_set(mo_set,error) + IF (ASSOCIATED(mo_set)) CALL deallocate_mo_set(mo_set) ALLOCATE (mo_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mo_set%maxocc = maxocc mo_set%nelectron = nelectron @@ -217,18 +212,15 @@ END SUBROUTINE allocate_mo_set !> \param mo_set the mo_set to initialize !> \param fm_pool a pool out which you initialize the mo_set !> \param name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 rewamped [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE init_mo_set(mo_set,fm_pool,name,error) + SUBROUTINE init_mo_set(mo_set,fm_pool,name) TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_fm_pool_type), POINTER :: fm_pool CHARACTER(LEN=*), INTENT(in) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_mo_set', & routineP = moduleN//':'//routineN @@ -238,23 +230,23 @@ SUBROUTINE init_mo_set(mo_set,fm_pool,name,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(mo_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(fm_pool),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(mo_set%eigenvalues),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(mo_set%occupation_numbers),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(mo_set%mo_coeff),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mo_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(fm_pool),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(mo_set%eigenvalues),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(mo_set%occupation_numbers),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(mo_set%mo_coeff),cp_failure_level,routineP,failure) - CALL fm_pool_create_fm(fm_pool,mo_set%mo_coeff,name=name,error=error) - CALL cp_fm_get_info(mo_set%mo_coeff,nrow_global=nao,ncol_global=nmo,error=error) - CPPostcondition((nao >= mo_set%nao),cp_failure_level,routineP,error,failure) - CPPostcondition((nmo >= mo_set%nmo),cp_failure_level,routineP,error,failure) + CALL fm_pool_create_fm(fm_pool,mo_set%mo_coeff,name=name) + CALL cp_fm_get_info(mo_set%mo_coeff,nrow_global=nao,ncol_global=nmo) + CPPostcondition((nao >= mo_set%nao),cp_failure_level,routineP,failure) + CPPostcondition((nmo >= mo_set%nmo),cp_failure_level,routineP,failure) ALLOCATE (mo_set%eigenvalues(nmo),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) mo_set%eigenvalues(:) = 0.0_dp ALLOCATE (mo_set%occupation_numbers(nmo),STAT=istat) - CPPostcondition((istat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((istat == 0),cp_failure_level,routineP,failure) ! Initialize MO occupations mo_set%occupation_numbers(:) = 0.0_dp ! Quick return, if no electrons are available @@ -272,8 +264,8 @@ SUBROUTINE init_mo_set(mo_set,fm_pool,name,error) mo_set%occupation_numbers(nomo) = mo_set%nelectron -(nomo-1)* mo_set%maxocc END IF - CPPrecondition((nmo >= nomo),cp_failure_level,routineP,error,failure) - CPPrecondition((SIZE(mo_set%occupation_numbers) == nmo),cp_failure_level,routineP,error,failure) + CPPrecondition((nmo >= nomo),cp_failure_level,routineP,failure) + CPPrecondition((SIZE(mo_set%occupation_numbers) == nmo),cp_failure_level,routineP,failure) mo_set%homo = nomo mo_set%lfomo = nomo + 1 @@ -286,15 +278,13 @@ END SUBROUTINE init_mo_set !> effectively copying the orbital data !> \param mo_array ... !> \param convert_dbcsr ... -!> \param error ... !> \par History !> 10.2004 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE mo_set_restrict(mo_array,convert_dbcsr,error) + SUBROUTINE mo_set_restrict(mo_array,convert_dbcsr) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array LOGICAL, INTENT(in), OPTIONAL :: convert_dbcsr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'mo_set_restrict', & routineP = moduleN//':'//routineN @@ -309,16 +299,16 @@ SUBROUTINE mo_set_restrict(mo_array,convert_dbcsr,error) my_convert_dbcsr = .FALSE. IF(PRESENT(convert_dbcsr)) my_convert_dbcsr = convert_dbcsr - CPPrecondition(ASSOCIATED(mo_array),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(mo_array).EQ.2,cp_failure_level,routineP,error,failure) - CPPrecondition(mo_array(1)%mo_set%nmo>=mo_array(2)%mo_set%nmo,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mo_array),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(mo_array).EQ.2,cp_failure_level,routineP,failure) + CPPrecondition(mo_array(1)%mo_set%nmo>=mo_array(2)%mo_set%nmo,cp_failure_level,routineP,failure) ! first nmo_beta orbitals are copied from alpha to beta IF(my_convert_dbcsr) THEN!fm->dbcsr CALL cp_dbcsr_copy_columns_hack(mo_array(2)%mo_set%mo_coeff_b,mo_array(1)%mo_set%mo_coeff_b,&!fm->dbcsr mo_array(2)%mo_set%nmo,1,1,&!fm->dbcsr para_env=mo_array(1)%mo_set%mo_coeff%matrix_struct%para_env,&!fm->dbcsr - blacs_env=mo_array(1)%mo_set%mo_coeff%matrix_struct%context,error=error)!fm->dbcsr + blacs_env=mo_array(1)%mo_set%mo_coeff%matrix_struct%context)!fm->dbcsr ELSE!fm->dbcsr CALL cp_fm_to_fm(mo_array(1)%mo_set%mo_coeff,mo_array(2)%mo_set%mo_coeff,mo_array(2)%mo_set%nmo) ENDIF @@ -356,15 +346,13 @@ END SUBROUTINE correct_mo_eigenvalues ! ***************************************************************************** !> \brief Deallocate a wavefunction data structure. !> \param mo_set ... -!> \param error ... !> \date 15.05.2001 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_mo_set(mo_set,error) + SUBROUTINE deallocate_mo_set(mo_set) TYPE(mo_set_type), POINTER :: mo_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_mo_set', & routineP = moduleN//':'//routineN @@ -377,16 +365,16 @@ SUBROUTINE deallocate_mo_set(mo_set,error) IF (ASSOCIATED(mo_set)) THEN IF (ASSOCIATED(mo_set%eigenvalues)) THEN DEALLOCATE (mo_set%eigenvalues,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(mo_set%occupation_numbers)) THEN DEALLOCATE (mo_set%occupation_numbers,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF - CALL cp_fm_release(mo_set%mo_coeff,error=error) - IF(ASSOCIATED(mo_set%mo_coeff_b)) CALL cp_dbcsr_release_p(mo_set%mo_coeff_b, error=error) + CALL cp_fm_release(mo_set%mo_coeff) + IF(ASSOCIATED(mo_set%mo_coeff_b)) CALL cp_dbcsr_release_p(mo_set%mo_coeff_b) DEALLOCATE (mo_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_mo_set @@ -467,14 +455,13 @@ END SUBROUTINE get_mo_set !> \param kTS ... !> \param mu ... !> \param flexible_electron_count ... -!> \param error ... !> \date 22.04.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** SUBROUTINE set_mo_set(mo_set,maxocc,homo,lfomo,nao,nelectron,n_el_f,nmo,& eigenvalues,occupation_numbers,uniform_occupation,& - kTS,mu,flexible_electron_count,error) + kTS,mu,flexible_electron_count) TYPE(mo_set_type), POINTER :: mo_set REAL(KIND=dp), INTENT(IN), OPTIONAL :: maxocc @@ -487,7 +474,6 @@ SUBROUTINE set_mo_set(mo_set,maxocc,homo,lfomo,nao,nelectron,n_el_f,nmo,& LOGICAL, INTENT(IN), OPTIONAL :: uniform_occupation REAL(KIND=dp), INTENT(IN), OPTIONAL :: kTS, mu, & flexible_electron_count - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_mo_set', & routineP = moduleN//':'//routineN @@ -505,14 +491,14 @@ SUBROUTINE set_mo_set(mo_set,maxocc,homo,lfomo,nao,nelectron,n_el_f,nmo,& IF (PRESENT(eigenvalues)) THEN IF (ASSOCIATED(mo_set%eigenvalues)) THEN DEALLOCATE(mo_set%eigenvalues,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF mo_set%eigenvalues => eigenvalues END IF IF (PRESENT(occupation_numbers)) THEN IF (ASSOCIATED(mo_set%occupation_numbers)) THEN DEALLOCATE(mo_set%occupation_numbers,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF mo_set%occupation_numbers => occupation_numbers END IF diff --git a/src/qs_moments.F b/src/qs_moments.F index de8fb68fa4..0b266d12dd 100644 --- a/src/qs_moments.F +++ b/src/qs_moments.F @@ -102,9 +102,8 @@ MODULE qs_moments !> \param nmoments ... !> \param ref_point ... !> \param ref_points ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_local_moment_matrix(qs_env,moments,nmoments,ref_point,ref_points,error) + SUBROUTINE build_local_moment_matrix(qs_env,moments,nmoments,ref_point,ref_points) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -114,7 +113,6 @@ SUBROUTINE build_local_moment_matrix(qs_env,moments,nmoments,ref_point,ref_point INTENT(IN), OPTIONAL :: ref_point REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN), OPTIONAL :: ref_points - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_local_moment_matrix', & routineP = moduleN//':'//routineN @@ -161,13 +159,13 @@ SUBROUTINE build_local_moment_matrix(qs_env,moments,nmoments,ref_point,ref_point nm = (6 + 11*nmoments + 6*nmoments**2 + nmoments**3)/6 - 1 - CPPostcondition(SIZE(moments)>=nm,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(moments)>=nm,cp_failure_level,routineP,failure) NULLIFY (qs_kind_set,particle_set,sab_orb,cell) CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& particle_set=particle_set,cell=cell,& - sab_orb=sab_orb,error=error) + sab_orb=sab_orb) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -175,27 +173,27 @@ SUBROUTINE build_local_moment_matrix(qs_env,moments,nmoments,ref_point,ref_point ! *** Allocate work storage *** CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& - maxco=maxco, maxsgf=maxsgf, error=error) + maxco=maxco, maxsgf=maxsgf) ALLOCATE (mab(maxco,maxco,nm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mab(:,:,:) = 0.0_dp ALLOCATE (work(maxco,maxsgf),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) work(:,:) = 0.0_dp ALLOCATE (mint(nm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,nm NULLIFY (mint(i)%block) END DO ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -333,14 +331,14 @@ SUBROUTINE build_local_moment_matrix(qs_env,moments,nmoments,ref_point,ref_point ! *** Release work storage *** DEALLOCATE (mab,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,nm NULLIFY (mint(i)%block) END DO DEALLOCATE (mint,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -353,9 +351,8 @@ END SUBROUTINE build_local_moment_matrix !> \param nmoments ... !> \param ref_point ... !> \param ref_points ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_local_magmom_matrix(qs_env,magmom,nmoments,ref_point,ref_points,error) + SUBROUTINE build_local_magmom_matrix(qs_env,magmom,nmoments,ref_point,ref_points) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -365,7 +362,6 @@ SUBROUTINE build_local_magmom_matrix(qs_env,magmom,nmoments,ref_point,ref_points INTENT(IN), OPTIONAL :: ref_point REAL(KIND=dp), DIMENSION(:, :), & INTENT(IN), OPTIONAL :: ref_points - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_local_magmom_matrix', & routineP = moduleN//':'//routineN @@ -413,24 +409,24 @@ SUBROUTINE build_local_magmom_matrix(qs_env,magmom,nmoments,ref_point,ref_points NULLIFY (qs_kind_set,cell,particle_set,sab_orb) NULLIFY (matrix_s) - CALL get_qs_env(qs_env=qs_env, matrix_s=matrix_s,error=error) + CALL get_qs_env(qs_env=qs_env, matrix_s=matrix_s) ! magnetic dipoles/angular moments only nm = 3 - CALL cp_dbcsr_allocate_matrix_set ( magmom, nm ,error=error) + CALL cp_dbcsr_allocate_matrix_set ( magmom, nm) DO i=1,nm ALLOCATE(magmom(i)%matrix) - CALL cp_dbcsr_init (magmom(i)%matrix, error=error) - CALL cp_dbcsr_copy(magmom(i)%matrix, matrix_s(1)%matrix, "Moments", error) - CALL cp_dbcsr_set(magmom(i)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_init (magmom(i)%matrix) + CALL cp_dbcsr_copy(magmom(i)%matrix, matrix_s(1)%matrix, "Moments") + CALL cp_dbcsr_set(magmom(i)%matrix,0.0_dp) END DO NULLIFY (qs_kind_set,particle_set,sab_orb,cell) CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& particle_set=particle_set,cell=cell,& - sab_orb=sab_orb,error=error) + sab_orb=sab_orb) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -438,27 +434,27 @@ SUBROUTINE build_local_magmom_matrix(qs_env,magmom,nmoments,ref_point,ref_points ! *** Allocate work storage *** CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& - maxco=maxco, maxsgf=maxsgf, error=error) + maxco=maxco, maxsgf=maxsgf) ALLOCATE (mab(maxco,maxco,nm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mab(:,:,:) = 0.0_dp ALLOCATE (work(maxco,maxsgf),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) work(:,:) = 0.0_dp ALLOCATE (mint(nm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,nm NULLIFY (mint(i)%block) END DO ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -596,14 +592,14 @@ SUBROUTINE build_local_magmom_matrix(qs_env,magmom,nmoments,ref_point,ref_points ! *** Release work storage *** DEALLOCATE (mab,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,nm NULLIFY (mint(i)%block) END DO DEALLOCATE (mint,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -615,14 +611,12 @@ END SUBROUTINE build_local_magmom_matrix !> \param cosmat ... !> \param sinmat ... !> \param kvec ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) + SUBROUTINE build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_type), POINTER :: cosmat, sinmat REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: kvec - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_berry_moment_matrix', & routineP = moduleN//':'//routineN @@ -664,28 +658,28 @@ SUBROUTINE build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& particle_set=particle_set,cell=cell,& - sab_orb=sab_orb,error=error) + sab_orb=sab_orb) - CALL cp_dbcsr_set(sinmat,0.0_dp,error=error) - CALL cp_dbcsr_set(cosmat,0.0_dp,error=error) + CALL cp_dbcsr_set(sinmat,0.0_dp) + CALL cp_dbcsr_set(cosmat,0.0_dp) - CALL get_qs_kind_set(qs_kind_set=qs_kind_set, maxco=ldwork, error=error) + CALL get_qs_kind_set(qs_kind_set=qs_kind_set, maxco=ldwork) ldab = ldwork ALLOCATE(cosab(ldab,ldab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(sinab(ldab,ldab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(work(ldwork,ldwork),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -742,7 +736,7 @@ SUBROUTINE build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) row=irow,col=icol,BLOCK=sblock,found=found) IF(ASSOCIATED(cblock).AND..NOT.ASSOCIATED(sblock).OR.& .NOT.ASSOCIATED(cblock).AND.ASSOCIATED(sblock)) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(cblock).AND.ASSOCIATED(sblock)) THEN @@ -781,13 +775,13 @@ SUBROUTINE build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(cosab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(sinab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -801,16 +795,14 @@ END SUBROUTINE build_berry_moment_matrix !> \param reference ... !> \param ref_point ... !> \param unit_number ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,unit_number,error) + SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,unit_number) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: magnetic INTEGER, INTENT(IN) :: nmoments, reference REAL(dp), DIMENSION(:), POINTER :: ref_point INTEGER, INTENT(IN) :: unit_number - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_moment_berry_phase', & routineP = moduleN//':'//routineN @@ -858,7 +850,7 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u TYPE(rt_prop_type), POINTER :: rtp failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) IF(ASSOCIATED(qs_env%ls_scf_env)) THEN IF(unit_number > 0) WRITE(unit_number,*) "Periodic moment calculation not implemented in linear scaling code" @@ -876,15 +868,15 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! rmom(:,2)=nuclear ! rmom(:,1)=total ALLOCATE (rmom(nm+1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (rlab(nm+1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rmom = 0.0_dp rlab = "" IF(magnetic) THEN nm=3 ALLOCATE (mmom(nm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mmom = 0._dp END IF @@ -901,42 +893,39 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u para_env=para_env,& local_particles=local_particles,& matrix_s=matrix_s,& - mos=mos,& - error=error) + mos=mos) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) NULLIFY ( cosmat, sinmat ) ALLOCATE(cosmat, sinmat) - CALL cp_dbcsr_init(cosmat, error=error) - CALL cp_dbcsr_init(sinmat, error=error) - CALL cp_dbcsr_copy(cosmat,matrix_s(1)%matrix,'COS MOM',error=error) - CALL cp_dbcsr_copy(sinmat,matrix_s(1)%matrix,'SIN MOM',error=error) - CALL cp_dbcsr_set(cosmat,0.0_dp,error=error) - CALL cp_dbcsr_set(sinmat,0.0_dp,error=error) + CALL cp_dbcsr_init(cosmat) + CALL cp_dbcsr_init(sinmat) + CALL cp_dbcsr_copy(cosmat,matrix_s(1)%matrix,'COS MOM') + CALL cp_dbcsr_copy(sinmat,matrix_s(1)%matrix,'SIN MOM') + CALL cp_dbcsr_set(cosmat,0.0_dp) + CALL cp_dbcsr_set(sinmat,0.0_dp) ALLOCATE ( op_fm_set( 2, dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( opvec( dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE ( eigrmat( dft_control%nspins ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nmotot = 0 DO ispin = 1, dft_control%nspins NULLIFY(tmp_fm_struct,mo_coeff) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff,nao=nao,nmo=nmo) nmotot = nmotot + nmo - CALL cp_fm_create (opvec(ispin)%matrix , mo_coeff%matrix_struct ,error=error) + CALL cp_fm_create (opvec(ispin)%matrix , mo_coeff%matrix_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nmo,& - ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context,& - error=error) + ncol_global=nmo,para_env=para_env,context=mo_coeff%matrix_struct%context) DO i = 1, SIZE ( op_fm_set, 1 ) NULLIFY(op_fm_set(i,ispin)%matrix) - CALL cp_fm_create (op_fm_set(i,ispin)%matrix , tmp_fm_struct ,error=error) + CALL cp_fm_create (op_fm_set(i,ispin)%matrix , tmp_fm_struct) END DO - CALL cp_cfm_create ( eigrmat(ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ,& - error=error) - CALL cp_fm_struct_release(tmp_fm_struct,error=error) + CALL cp_cfm_create ( eigrmat(ispin)%matrix, op_fm_set(1,ispin)%matrix%matrix_struct ) + CALL cp_fm_struct_release(tmp_fm_struct) END DO ! occupation @@ -945,12 +934,12 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u IF (.NOT.uniform) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments for non uniform MOs' occupation numbers not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO ! reference point - CALL get_reference_point(rcc,qs_env=qs_env,reference=reference,ref_point=ref_point,error=error) + CALL get_reference_point(rcc,qs_env=qs_env,reference=reference,ref_point=ref_point) rcc = pbc(rcc,cell) ! label @@ -965,7 +954,7 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u DO ia = 1,SIZE(particle_set) atomic_kind => particle_set(ia)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), core_charge=charge, ghost=ghost, error=error) + CALL get_qs_kind(qs_kind_set(ikind), core_charge=charge, ghost=ghost) IF (.NOT. ghost) THEN rmom(1,2) = rmom(1,2) - charge ENDIF @@ -986,7 +975,7 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u DO ia = 1,SIZE(particle_set) atomic_kind => particle_set(ia)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), core_charge=charge, ghost=ghost, error=error) + CALL get_qs_kind(qs_kind_set(ikind), core_charge=charge, ghost=ghost) IF (.NOT. ghost) THEN ria = particle_set(ia)%r ria = pbc(ria,cell) @@ -1006,12 +995,12 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! Quadrupole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) zij(:,:) = CMPLX ( 1._dp, 0._dp, dp ) DO ia = 1,SIZE(particle_set) atomic_kind => particle_set(ia)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), core_charge=charge, error=error) + CALL get_qs_kind(qs_kind_set(ikind), core_charge=charge) ria = particle_set(ia)%r ria = pbc(ria,cell) DO i = 1, 3 @@ -1049,16 +1038,16 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! Octapole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE (4) ! Hexadecapole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 4 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END DO @@ -1070,7 +1059,7 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! charge trace = 0.0_dp DO ispin=1,dft_control%nspins - CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,matrix_s(1)%matrix,trace,error=error) + CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,matrix_s(1)%matrix,trace) rmom(1,1) = rmom(1,1) + trace END DO @@ -1085,23 +1074,23 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! Dipole DO i = 1, 3 kvec(:) = twopi*cell%h_inv(i,:) - CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) + CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec) IF(qs_env%run_rtp)THEN - CALL get_qs_env(qs_env,rtp=rtp,error=error) - CALL get_rtp(rtp,mos_new=mos_new,error=error) - CALL op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new,error) + CALL get_qs_env(qs_env,rtp=rtp) + CALL get_rtp(rtp,mos_new=mos_new) + CALL op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new) ELSE - CALL op_orbbas (cosmat,sinmat,mos,op_fm_set,opvec,error) + CALL op_orbbas (cosmat,sinmat,mos,op_fm_set,opvec) END IF zdet = CMPLX ( 1._dp, 0._dp, dp ) DO ispin = 1, dft_control%nspins - CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim,error=error) + CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim) DO idim=1,tmp_dim eigrmat(ispin)%matrix%local_data(:,idim) = & CMPLX (op_fm_set(1,ispin)%matrix%local_data(:,idim), & -op_fm_set(2,ispin)%matrix%local_data(:,idim),dp) END DO - CALL cp_cfm_lu_decompose ( eigrmat(ispin)%matrix, zdeta ,error) + CALL cp_cfm_lu_decompose ( eigrmat(ispin)%matrix, zdeta) zdet = zdet * zdeta IF (dft_control%nspins==1) THEN zdet = zdet * zdeta @@ -1114,27 +1103,27 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! Quadrupole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) DO i = 1, 3 DO j = i, 3 kvec(:) = twopi*(cell%h_inv(i,:)+cell%h_inv(j,:)) - CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec,error) + CALL build_berry_moment_matrix(qs_env,cosmat,sinmat,kvec) IF(qs_env%run_rtp)THEN - CALL get_qs_env(qs_env,rtp=rtp,error=error) - CALL get_rtp(rtp,mos_new=mos_new,error=error) - CALL op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new,error) + CALL get_qs_env(qs_env,rtp=rtp) + CALL get_rtp(rtp,mos_new=mos_new) + CALL op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new) ELSE - CALL op_orbbas (cosmat,sinmat,mos,op_fm_set,opvec,error) + CALL op_orbbas (cosmat,sinmat,mos,op_fm_set,opvec) END IF zdet = CMPLX ( 1._dp, 0._dp, dp ) DO ispin = 1, dft_control%nspins - CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim,error=error) + CALL cp_cfm_get_info(eigrmat(ispin)%matrix,ncol_local=tmp_dim) DO idim=1,tmp_dim eigrmat(ispin)%matrix%local_data(:,idim) = & CMPLX (op_fm_set(1,ispin)%matrix%local_data(:,idim), & -op_fm_set(2,ispin)%matrix%local_data(:,idim),dp) END DO - CALL cp_cfm_lu_decompose ( eigrmat(ispin)%matrix, zdeta ,error) + CALL cp_cfm_lu_decompose ( eigrmat(ispin)%matrix, zdeta) zdet = zdet * zdeta IF (dft_control%nspins==1) THEN zdet = zdet * zdeta @@ -1148,16 +1137,16 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! Octapole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE (4) ! Hexadecapole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 4 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END DO DO l = 1, nmom @@ -1174,7 +1163,7 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! Quadrupole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) DO i=1,3 DO j=1,3 zz = zij(i,j)/zi(i)/zi(j) @@ -1199,24 +1188,24 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u ! Octapole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE (4) ! Hexadecapole CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Berry phase moments bigger than 4 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END DO rmom(:,3) = rmom(:,1) + rmom(:,2) description="[DIPOLE]" - CALL cp_results_erase(results=results,description=description,error=error) + CALL cp_results_erase(results=results,description=description) CALL put_results(results=results,description=description,& - values=rmom(2:4,3),error=error) + values=rmom(2:4,3)) IF(magnetic) THEN CALL print_moments(unit_number,nmom,rmom,rlab,rcc,cell,periodic=.TRUE.,mmom=mmom) ELSE @@ -1224,30 +1213,30 @@ SUBROUTINE qs_moment_berry_phase (qs_env,magnetic,nmoments,reference,ref_point,u END IF DEALLOCATE (rmom,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (rlab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(magnetic) THEN DEALLOCATE ( mmom, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF - CALL cp_dbcsr_deallocate_matrix ( cosmat, error ) - CALL cp_dbcsr_deallocate_matrix ( sinmat, error ) + CALL cp_dbcsr_deallocate_matrix ( cosmat) + CALL cp_dbcsr_deallocate_matrix ( sinmat) DO ispin = 1, dft_control%nspins - CALL cp_fm_release(opvec(ispin)%matrix,error=error) - CALL cp_cfm_release(eigrmat(ispin)%matrix,error=error) + CALL cp_fm_release(opvec(ispin)%matrix) + CALL cp_cfm_release(eigrmat(ispin)%matrix) DO i = 1, SIZE ( op_fm_set, 1 ) - CALL cp_fm_release(op_fm_set(i,ispin)%matrix,error=error) + CALL cp_fm_release(op_fm_set(i,ispin)%matrix) END DO END DO DEALLOCATE ( op_fm_set, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE ( opvec, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE ( eigrmat, STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1261,9 +1250,8 @@ END SUBROUTINE qs_moment_berry_phase !> \param mos ... !> \param op_fm_set ... !> \param opvec ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE op_orbbas (cosmat,sinmat,mos,op_fm_set,opvec,error) + SUBROUTINE op_orbbas (cosmat,sinmat,mos,op_fm_set,opvec) TYPE(cp_dbcsr_type), POINTER :: cosmat, sinmat TYPE(mo_set_p_type), DIMENSION(:), & @@ -1272,19 +1260,18 @@ SUBROUTINE op_orbbas (cosmat,sinmat,mos,op_fm_set,opvec,error) POINTER :: op_fm_set TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: opvec - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: i, nao, nmo TYPE(cp_fm_type), POINTER :: mo_coeff DO i=1,SIZE ( op_fm_set, 2 ) ! spin CALL get_mo_set(mo_set=mos(i)%mo_set,nao=nao,mo_coeff=mo_coeff,nmo=nmo) - CALL cp_dbcsr_sm_fm_multiply(cosmat, mo_coeff, opvec(i)%matrix, ncol=nmo, error=error) + CALL cp_dbcsr_sm_fm_multiply(cosmat, mo_coeff, opvec(i)%matrix, ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff,opvec(i)%matrix,0.0_dp,& - op_fm_set(1,i)%matrix,error=error) - CALL cp_dbcsr_sm_fm_multiply(sinmat, mo_coeff, opvec(i)%matrix, ncol=nmo, error=error) + op_fm_set(1,i)%matrix) + CALL cp_dbcsr_sm_fm_multiply(sinmat, mo_coeff, opvec(i)%matrix, ncol=nmo) CALL cp_gemm("T","N",nmo,nmo,nao,1.0_dp,mo_coeff,opvec(i)%matrix,0.0_dp,& - op_fm_set(2,i)%matrix,error=error) + op_fm_set(2,i)%matrix) ENDDO END SUBROUTINE op_orbbas @@ -1296,9 +1283,8 @@ END SUBROUTINE op_orbbas !> \param mos ... !> \param op_fm_set ... !> \param mos_new ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new,error) + SUBROUTINE op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new) TYPE(cp_dbcsr_type), POINTER :: cosmat, sinmat TYPE(mo_set_p_type), DIMENSION(:), & @@ -1307,7 +1293,6 @@ SUBROUTINE op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new,error) POINTER :: op_fm_set TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mos_new - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: i, icol, lcol, nao, newdim, & nmo @@ -1317,49 +1302,47 @@ SUBROUTINE op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new,error) DO i=1,SIZE ( op_fm_set, 2 ) ! spin CALL get_mo_set(mo_set=mos(i)%mo_set,nao=nao,mo_coeff=mo_coeff,nmo=nmo) - CALL cp_fm_get_info(mos_new(2*i)%matrix,ncol_local=lcol,ncol_global=nmo,error=error) + CALL cp_fm_get_info(mos_new(2*i)%matrix,ncol_local=lcol,ncol_global=nmo) double_col=.TRUE. double_row=.FALSE. CALL cp_fm_struct_double(newstruct,& mos_new(2*i)%matrix%matrix_struct,& mos_new(2*i)%matrix%matrix_struct%context,& double_col,& - double_row,& - error) + double_row) - CALL cp_fm_create(work,matrix_struct=newstruct,error=error) - CALL cp_fm_create(work1,matrix_struct=newstruct,error=error) - CALL cp_fm_create(work2,matrix_struct=newstruct,error=error) - CALL cp_fm_get_info(work,ncol_global=newdim,error=error) + CALL cp_fm_create(work,matrix_struct=newstruct) + CALL cp_fm_create(work1,matrix_struct=newstruct) + CALL cp_fm_create(work2,matrix_struct=newstruct) + CALL cp_fm_get_info(work,ncol_global=newdim) - CALL cp_fm_set_all(work,0.0_dp,0.0_dp,error) + CALL cp_fm_set_all(work,0.0_dp,0.0_dp) DO icol=1,lcol work%local_data(:,icol)=mos_new(2*i-1)%matrix%local_data(:,icol) work%local_data(:,icol+lcol)=mos_new(2*i)%matrix%local_data(:,icol) END DO - CALL cp_dbcsr_sm_fm_multiply(cosmat, work, work1, ncol=newdim, error=error) - CALL cp_dbcsr_sm_fm_multiply(sinmat, work, work2, ncol=newdim, error=error) + CALL cp_dbcsr_sm_fm_multiply(cosmat, work, work1, ncol=newdim) + CALL cp_dbcsr_sm_fm_multiply(sinmat, work, work2, ncol=newdim) DO icol=1,lcol work%local_data(:,icol)=work1%local_data(:,icol)-work2%local_data(:,icol+lcol) work%local_data(:,icol+lcol)=work1%local_data(:,icol+lcol)+work2%local_data(:,icol) END DO - CALL cp_fm_release(work1,error) - CALL cp_fm_release(work2,error) + CALL cp_fm_release(work1) + CALL cp_fm_release(work2) CALL cp_fm_struct_double(newstruct1,& op_fm_set(1,i)%matrix%matrix_struct,& op_fm_set(1,i)%matrix%matrix_struct%context,& double_col,& - double_row,& - error) + double_row) - CALL cp_fm_create(work1,matrix_struct=newstruct1,error=error) + CALL cp_fm_create(work1,matrix_struct=newstruct1) CALL cp_gemm("T","N",nmo,newdim,nao,1.0_dp,mos_new(2*i-1)%matrix,& - work,0.0_dp,work1,error=error) + work,0.0_dp,work1) DO icol=1,lcol op_fm_set(1,i)%matrix%local_data(:,icol)=work1%local_data(:,icol) @@ -1368,7 +1351,7 @@ SUBROUTINE op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new,error) CALL cp_gemm("T","N",nmo,newdim,nao,1.0_dp,mos_new(2*i)%matrix,& - work,0.0_dp,work1,error=error) + work,0.0_dp,work1) DO icol=1,lcol op_fm_set(1,i)%matrix%local_data(:,icol)=& @@ -1377,10 +1360,10 @@ SUBROUTINE op_orbbas_rtp (cosmat,sinmat,mos,op_fm_set,mos_new,error) op_fm_set(2,i)%matrix%local_data(:,icol)-work1%local_data(:,icol) END DO - CALL cp_fm_release(work,error) - CALL cp_fm_release(work1,error) - CALL cp_fm_struct_release(newstruct,error=error) - CALL cp_fm_struct_release(newstruct1,error=error) + CALL cp_fm_release(work) + CALL cp_fm_release(work1) + CALL cp_fm_struct_release(newstruct) + CALL cp_fm_struct_release(newstruct1) ENDDO @@ -1394,16 +1377,14 @@ END SUBROUTINE op_orbbas_rtp !> \param reference ... !> \param ref_point ... !> \param unit_number ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_moment_locop (qs_env,magnetic,nmoments,reference,ref_point,unit_number,error) + SUBROUTINE qs_moment_locop (qs_env,magnetic,nmoments,reference,ref_point,unit_number) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: magnetic INTEGER, INTENT(IN) :: nmoments, reference REAL(dp), DIMENSION(:), POINTER :: ref_point INTEGER, INTENT(IN) :: unit_number - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_moment_locop', & routineP = moduleN//':'//routineN @@ -1435,30 +1416,30 @@ SUBROUTINE qs_moment_locop (qs_env,magnetic,nmoments,reference,ref_point,unit_nu TYPE(qs_rho_type), POINTER :: rho failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL timeset(routineN,handle) ! reference point - CALL get_reference_point(rcc,qs_env=qs_env,reference=reference,ref_point=ref_point,error=error) + CALL get_reference_point(rcc,qs_env=qs_env,reference=reference,ref_point=ref_point) ! only allow for moments up to maxl set by basis nmom = MIN (nmoments,current_maxl) ! electronic contribution NULLIFY ( moments,matrix_s ) - CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s,error=error) + CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s) nm = (6 + 11*nmom + 6*nmom**2 + nmom**3)/6 - 1 - CALL cp_dbcsr_allocate_matrix_set(moments,nm,error=error) + CALL cp_dbcsr_allocate_matrix_set(moments,nm) DO i=1,nm ALLOCATE(moments(i)%matrix,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(moments(i)%matrix,error=error) - CALL cp_dbcsr_copy(moments(i)%matrix,matrix_s(1)%matrix,"Moments",error=error) - CALL cp_dbcsr_set(moments(i)%matrix,0.0_dp,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(moments(i)%matrix) + CALL cp_dbcsr_copy(moments(i)%matrix,matrix_s(1)%matrix,"Moments") + CALL cp_dbcsr_set(moments(i)%matrix,0.0_dp) END DO - CALL build_local_moment_matrix(qs_env,moments,nmom,ref_point=rcc,error=error) + CALL build_local_moment_matrix(qs_env,moments,nmom,ref_point=rcc) NULLIFY (dft_control,rho,cell,particle_set,qs_kind_set,results,para_env,matrix_s,rho_ao) CALL get_qs_env(qs_env,& @@ -1469,57 +1450,56 @@ SUBROUTINE qs_moment_locop (qs_env,magnetic,nmoments,reference,ref_point,unit_nu particle_set=particle_set,& qs_kind_set=qs_kind_set,& para_env=para_env,& - matrix_s=matrix_s,& - error=error) + matrix_s=matrix_s) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) nm = SIZE(moments) ALLOCATE (rmom(nm+1,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (rlab(nm+1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rmom=0.0_dp rlab = "" trace = 0.0_dp DO ispin=1,dft_control%nspins - CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,matrix_s(1)%matrix,trace,error=error) + CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,matrix_s(1)%matrix,trace) rmom(1,1) = rmom(1,1) + trace END DO DO i = 1, SIZE(moments) strace = 0._dp DO ispin=1,dft_control%nspins - CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,moments(i)%matrix,trace,error=error) + CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,moments(i)%matrix,trace) strace = strace + trace END DO rmom(i+1,1) = strace END DO - CALL cp_dbcsr_deallocate_matrix_set ( moments, error ) + CALL cp_dbcsr_deallocate_matrix_set ( moments) ! magnetic moments IF (magnetic) THEN NULLIFY ( magmom ) - CALL build_local_magmom_matrix(qs_env,magmom,nmom,ref_point=rcc,error=error) + CALL build_local_magmom_matrix(qs_env,magmom,nmom,ref_point=rcc) nm = SIZE(magmom) ALLOCATE (mmom(nm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i = 1, SIZE(magmom) strace = 0._dp DO ispin=1,dft_control%nspins - CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,magmom(i)%matrix,trace,error=error) + CALL cp_dbcsr_trace(rho_ao(ispin)%matrix,magmom(i)%matrix,trace) strace = strace + trace END DO mmom(i) = strace END DO - CALL cp_dbcsr_deallocate_matrix_set(magmom,error=error) + CALL cp_dbcsr_deallocate_matrix_set(magmom) END IF ! nuclear contribution CALL get_qs_env(qs_env=qs_env,& - local_particles=local_particles,error=error) + local_particles=local_particles) DO ikind = 1,SIZE(local_particles%n_el) DO ia = 1,local_particles%n_el(ikind) iatom = local_particles%list(ikind)%array(ia) @@ -1528,7 +1508,7 @@ SUBROUTINE qs_moment_locop (qs_env,magnetic,nmoments,reference,ref_point,unit_nu ria = ria - rcc atomic_kind => particle_set(iatom)%atomic_kind CALL get_atomic_kind(atomic_kind, kind_number=akind) - CALL get_qs_kind(qs_kind_set(akind), core_charge=charge, error=error) + CALL get_qs_kind(qs_kind_set(akind), core_charge=charge) rmom(1,2) = rmom(1,2) - charge DO l = 1, nm ix = indco(1,l+1) @@ -1548,9 +1528,9 @@ SUBROUTINE qs_moment_locop (qs_env,magnetic,nmoments,reference,ref_point,unit_nu rmom(:,3) = rmom(:,1) + rmom(:,2) description="[DIPOLE]" - CALL cp_results_erase(results=results,description=description,error=error) + CALL cp_results_erase(results=results,description=description) CALL put_results(results=results,description=description,& - values=rmom(2:4,3),error=error) + values=rmom(2:4,3)) IF(magnetic) THEN CALL print_moments(unit_number,nmom,rmom,rlab,rcc,cell,periodic=.FALSE.,mmom=mmom) ELSE @@ -1558,12 +1538,12 @@ SUBROUTINE qs_moment_locop (qs_env,magnetic,nmoments,reference,ref_point,unit_nu END IF DEALLOCATE (rmom,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (rlab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (magnetic) THEN DEALLOCATE (mmom,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) diff --git a/src/qs_neighbor_lists.F b/src/qs_neighbor_lists.F index 2cd88d4e65..51b0b48691 100644 --- a/src/qs_neighbor_lists.F +++ b/src/qs_neighbor_lists.F @@ -122,12 +122,10 @@ MODULE qs_neighbor_lists ! ***************************************************************************** !> \brief free the internals of atom2d !> \param atom2d ... -!> \param error ... !> \param ! ***************************************************************************** - SUBROUTINE atom2d_cleanup(atom2d,error) + SUBROUTINE atom2d_cleanup(atom2d) TYPE(local_atoms_type), DIMENSION(:) :: atom2d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom2d_cleanup', & routineP = moduleN//':'//routineN @@ -141,23 +139,23 @@ SUBROUTINE atom2d_cleanup(atom2d,error) NULLIFY (atom2d(ikind)%list) IF (ASSOCIATED(atom2d(ikind)%list_local_a_index)) THEN DEALLOCATE (atom2d(ikind)%list_local_a_index,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom2d(ikind)%list_local_b_index)) THEN DEALLOCATE (atom2d(ikind)%list_local_b_index,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom2d(ikind)%list_a_mol)) THEN DEALLOCATE (atom2d(ikind)%list_a_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom2d(ikind)%list_b_mol)) THEN DEALLOCATE (atom2d(ikind)%list_b_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom2d(ikind)%list_1d)) THEN DEALLOCATE (atom2d(ikind)%list_1d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO CALL timestop(handle) @@ -178,11 +176,10 @@ END SUBROUTINE atom2d_cleanup !> \param kg ... !> \param dftb ... !> \param particle_set ... -!> \param error ... !> \author JH ! ***************************************************************************** SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distribution_2d,& - atomic_kind_set,qs_kind_set,molecule_set,molecule_only,kg,dftb,particle_set,error) + atomic_kind_set,qs_kind_set,molecule_set,molecule_only,kg,dftb,particle_set) TYPE(local_atoms_type), DIMENSION(:) :: atom2d REAL(dp), DIMENSION(:) :: orb_radius LOGICAL, DIMENSION(:) :: orb_present @@ -199,7 +196,6 @@ SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distributi LOGICAL :: dftb TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atom2d_build', & routineP = moduleN//':'//routineN @@ -223,7 +219,7 @@ SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distributi nkind=SIZE(atomic_kind_set) natom=SIZE(particle_set) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind) @@ -245,7 +241,7 @@ SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distributi NULLIFY (atom2d(ikind)%list_b_mol) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom2d(ikind)%list) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) natom_a = SIZE(atom2d(ikind)%list) @@ -256,7 +252,7 @@ SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distributi nel = distribution_1d%n_el(ikind) ALLOCATE (atom2d(ikind)%list_1d(nel),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iat=1,nel ia = distribution_1d%list(ikind)%array(iat) atom2d(ikind)%list_1d(iat) = atom_of_kind(ia) @@ -272,25 +268,25 @@ SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distributi ELSE IF (dftb) THEN ! Set the interaction radius for the neighbor lists (DFTB case) ! This includes all interactions (orbitals and short range pair potential) except vdW - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom,error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom) CALL get_dftb_atom_param(dftb_parameter=dftb_atom,& cutoff=orb_radius(ikind),& - defined=orb_present(ikind),error=error) + defined=orb_present(ikind)) ELSE orb_present(ikind) = .FALSE. END IF IF ( orb_present(ikind) ) THEN ALLOCATE (listsort(natom_a),listindex(natom_a),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) listsort(1:natom_a) = atom2d(ikind)%list(1:natom_a) CALL sort(listsort,natom_a,listindex) ! Block rows IF (natom_local_a > 0) THEN ALLOCATE (atom2d(ikind)%list_local_a_index(natom_local_a),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom2d(ikind)%list_a_mol(natom_local_a),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) atom2d(ikind)%list_a_mol(:) = 0 @@ -308,9 +304,9 @@ SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distributi IF (natom_local_b > 0) THEN ALLOCATE (atom2d(ikind)%list_local_b_index(natom_local_b),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom2d(ikind)%list_b_mol(natom_local_b),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) atom2d(ikind)%list_b_mol(:) = 0 ! Build index vector for mapping @@ -324,14 +320,14 @@ SUBROUTINE atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distributi END IF DEALLOCATE (listsort,listindex,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ENDDO DEALLOCATE (atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -343,19 +339,17 @@ END SUBROUTINE atom2d_build !> \param para_env ... !> \param molecular ... !> \param force_env_section ... -!> \param error ... !> \date 28.08.2000 !> \par History !> - Major refactoring (25.07.2010,jhu) !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,error) + SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, OPTIONAL :: molecular TYPE(section_vals_type), POINTER :: force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_qs_neighbor_lists', & routineP = moduleN//':'//routineN @@ -412,7 +406,7 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY (atomic_kind_set, qs_kind_set, cell, neighbor_list_section,& distribution_1d, distribution_2d, gth_potential, orb_basis_set,& @@ -447,10 +441,9 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e local_particles=distribution_1d,& particle_set=particle_set,& molecule_set=molecule_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - neighbor_list_section => section_vals_get_subs_vals(force_env_section,"DFT%PRINT%NEIGHBOR_LISTS",error=error) + neighbor_list_section => section_vals_get_subs_vals(force_env_section,"DFT%PRINT%NEIGHBOR_LISTS") molecule_only = .FALSE. IF (PRESENT(molecular)) molecule_only = molecular @@ -459,7 +452,7 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e ! new version implies new sparsity of the matrices last_qs_neighbor_list_id_nr=last_qs_neighbor_list_id_nr+1 - CALL set_ks_env(ks_env=ks_env,neighbor_list_id=last_qs_neighbor_list_id_nr,error=error) + CALL set_ks_env(ks_env=ks_env,neighbor_list_id=last_qs_neighbor_list_id_nr) CALL get_ks_env(ks_env=ks_env,& sab_orb=sab_orb,& @@ -478,8 +471,7 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e sab_scp=sab_scp, & sab_all=sab_all, & sab_almo=sab_almo, & - sab_kp=sab_kp, & - error=error) + sab_kp=sab_kp) dokp = (kpoints%nkp > 0) nddo = dft_control%qs_control%semi_empirical @@ -489,15 +481,15 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e lrigpw = (dft_control%qs_control%method_id == do_method_lrigpw) lri_optbas = dft_control%qs_control%lri_optbas - hfx_sections => section_vals_get_subs_vals(qs_env%input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,error=error) + hfx_sections => section_vals_get_subs_vals(qs_env%input,"DFT%XC%HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx) CALL get_atomic_kind_set(atomic_kind_set, maxatom=maxatom) CALL get_qs_kind_set(qs_kind_set, paw_atom_present=paw_atom_present,& gth_potential_present=gth_potential_present,& - all_potential_present=all_potential_present,error=error) + all_potential_present=all_potential_present) - CALL section_vals_val_get(qs_env%input,"DFT%SUBCELLS",r_val=subcells,error=error) + CALL section_vals_val_get(qs_env%input,"DFT%SUBCELLS",r_val=subcells) ! Allocate work storage @@ -505,11 +497,11 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e ALLOCATE (orb_present(nkind),aux_fit_present(nkind),aux_present(nkind),& default_present(nkind),core_present(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (orb_radius(nkind),aux_fit_radius(nkind),c_radius(nkind),& core_radius(nkind),calpha(nkind),zeff(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) orb_radius(:) = 0.0_dp aux_fit_radius(:) = 0.0_dp c_radius(:) = 0.0_dp @@ -518,50 +510,50 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e zeff(:) = 0.0_dp ALLOCATE (pair_radius(nkind,nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (gth_potential_present) THEN ALLOCATE (ppl_present(nkind),ppl_radius(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ppl_radius = 0.0_dp ALLOCATE (ppnl_present(nkind),ppnl_radius(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ppnl_radius = 0.0_dp END IF IF (paw_atom_present) THEN ALLOCATE (oce_present(nkind),oce_radius(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) oce_radius = 0.0_dp END IF IF (all_potential_present) THEN ALLOCATE (all_present(nkind),all_pot_rad(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) all_pot_rad = 0.0_dp END IF ! Initialize the local data structures ALLOCATE (atom2d(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL atom2d_build(atom2d,orb_radius,orb_present,distribution_1d,distribution_2d,& atomic_kind_set,qs_kind_set,molecule_set,molecule_only,& - dftb=dftb,particle_set=particle_set,error=error) + dftb=dftb,particle_set=particle_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom2d(ikind)%list) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,basis_type="ORB",error=error) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_basis_set,basis_type="AUX",error=error) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_fit_basis_set,basis_type="AUX_FIT",error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,basis_type="ORB") + CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_basis_set,basis_type="AUX") + CALL get_qs_kind(qs_kind_set(ikind),basis_set=aux_fit_basis_set,basis_type="AUX_FIT") CALL get_qs_kind(qs_kind_set(ikind),& paw_proj_set=paw_proj,& paw_atom=paw_atom,& all_potential=all_potential,& - gth_potential=gth_potential,error=error) + gth_potential=gth_potential) ! SCP IF (ASSOCIATED(aux_basis_set)) THEN @@ -581,7 +573,7 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e CALL get_qs_kind(qs_kind_set(ikind),& alpha_core_charge=calpha(ikind),& core_charge_radius=core_radius(ikind),& - zeff=zeff(ikind),error=error) + zeff=zeff(ikind)) IF(zeff(ikind) /= 0._dp .AND. calpha(ikind) /= 0._dp) THEN core_present(ikind) = .TRUE. ELSE @@ -638,12 +630,12 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e END IF ! Build the orbital-orbital overlap neighbor lists - CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius) CALL build_neighbor_lists(sab_orb,particle_set,atom2d,cell,pair_radius,& - mic=mic,subcells=subcells,molecular=molecule_only,name="sab_orb",error=error) - CALL set_ks_env(ks_env=ks_env,sab_orb=sab_orb,error=error) + mic=mic,subcells=subcells,molecular=molecule_only,name="sab_orb") + CALL set_ks_env(ks_env=ks_env,sab_orb=sab_orb) CALL write_neighbor_lists(sab_orb,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_ORB","sab_orb","ORBITAL ORBITAL",error) + "/SAB_ORB","sab_orb","ORBITAL ORBITAL") ! Build orbital-orbital list containing all the pairs, to be used with ! non-symmetric operators. Beware: the cutoff of the orbital-orbital overlap @@ -651,40 +643,40 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e ! right now only used for linear response (e.g. nmr). Should be computed more sparingly IF (.NOT. (nddo .OR. dftb .OR. scptb)) THEN CALL build_neighbor_lists(sab_all,particle_set,atom2d,cell,pair_radius,& - mic=mic,symmetric=.FALSE.,subcells=subcells,molecular=molecule_only,name="sab_all",error=error) - CALL set_ks_env(ks_env=ks_env,sab_all=sab_all,error=error) + mic=mic,symmetric=.FALSE.,subcells=subcells,molecular=molecule_only,name="sab_all") + CALL set_ks_env(ks_env=ks_env,sab_all=sab_all) ENDIF ! Build the core-core overlap neighbor lists IF (.NOT. (nddo .OR. dftb .OR. scptb)) THEN - CALL pair_radius_setup(core_present,core_present,core_radius,core_radius,pair_radius,error) + CALL pair_radius_setup(core_present,core_present,core_radius,core_radius,pair_radius) CALL build_neighbor_lists(sab_core,particle_set,atom2d,cell,pair_radius,mic=mic,subcells=subcells,& - operator_type="PP",name="sab_core",error=error) - CALL set_ks_env(ks_env=ks_env,sab_core=sab_core,error=error) + operator_type="PP",name="sab_core") + CALL set_ks_env(ks_env=ks_env,sab_core=sab_core) CALL write_neighbor_lists(sab_core,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_CORE","sab_core","CORE CORE",error) + "/SAB_CORE","sab_core","CORE CORE") ENDIF IF(dft_control%do_admm) THEN - CALL pair_radius_setup(aux_fit_present,aux_fit_present,aux_fit_radius,aux_fit_radius,pair_radius,error) + CALL pair_radius_setup(aux_fit_present,aux_fit_present,aux_fit_radius,aux_fit_radius,pair_radius) CALL build_neighbor_lists(sab_aux_fit,particle_set,atom2d,cell,pair_radius,& - mic=mic,molecular=molecule_only,subcells=subcells,name="sab_aux_fit",error=error) + mic=mic,molecular=molecule_only,subcells=subcells,name="sab_aux_fit") CALL build_neighbor_lists(sab_aux_fit_asymm,particle_set,atom2d,cell,pair_radius,& mic=mic,symmetric=.FALSE.,molecular=molecule_only,subcells=subcells,& - name="sab_aux_fit_asymm",error=error) - CALL pair_radius_setup(aux_fit_present,orb_present,aux_fit_radius,orb_radius,pair_radius,error) + name="sab_aux_fit_asymm") + CALL pair_radius_setup(aux_fit_present,orb_present,aux_fit_radius,orb_radius,pair_radius) CALL build_neighbor_lists(sab_aux_fit_vs_orb,particle_set,atom2d,cell,pair_radius,& mic=mic,symmetric=.FALSE.,molecular=molecule_only,subcells=subcells,& - name="sab_aux_fit_vs_orb",error=error) + name="sab_aux_fit_vs_orb") - CALL set_ks_env(ks_env=ks_env,sab_aux_fit=sab_aux_fit,error=error) - CALL set_ks_env(ks_env=ks_env,sab_aux_fit_vs_orb=sab_aux_fit_vs_orb,error=error) - CALL set_ks_env(ks_env=ks_env,sab_aux_fit_asymm=sab_aux_fit_asymm,error=error) + CALL set_ks_env(ks_env=ks_env,sab_aux_fit=sab_aux_fit) + CALL set_ks_env(ks_env=ks_env,sab_aux_fit_vs_orb=sab_aux_fit_vs_orb) + CALL set_ks_env(ks_env=ks_env,sab_aux_fit_asymm=sab_aux_fit_asymm) CALL write_neighbor_lists(sab_aux_fit,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_AUX_FIT","sab_aux_fit","AUX_FIT_ORBITAL AUX_FIT_ORBITAL",error) + "/SAB_AUX_FIT","sab_aux_fit","AUX_FIT_ORBITAL AUX_FIT_ORBITAL") CALL write_neighbor_lists(sab_aux_fit_vs_orb,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_AUX_FIT_VS_ORB","sab_aux_fit_vs_orb","ORBITAL AUX_FIT_ORBITAL",error) + "/SAB_AUX_FIT_VS_ORB","sab_aux_fit_vs_orb","ORBITAL AUX_FIT_ORBITAL") END IF IF(dokp) THEN @@ -695,13 +687,13 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e IF(do_hfx) THEN roperator = 0.0_dp CALL section_vals_val_get(hfx_sections,"INTERACTION_POTENTIAL%CUTOFF_RADIUS",& - explicit=explicit,error=error) + explicit=explicit) IF(explicit) THEN CALL section_vals_val_get(hfx_sections,"INTERACTION_POTENTIAL%CUTOFF_RADIUS",& - r_val=roperator,error=error) + r_val=roperator) ELSE CALL section_vals_val_get(hfx_sections,"PERIODIC%NUMBER_OF_SHELLS",& - i_val=numshells,error=error) + i_val=numshells) numshells = MAX(1,numshells) roperator = MAX( plane_distance(1,0,0,cell), & plane_distance(0,1,0,cell), & @@ -709,60 +701,60 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e END IF IF(dft_control%do_admm) THEN CALL pair_radius_setup(aux_fit_present,aux_fit_present,aux_fit_radius,aux_fit_radius,& - pair_radius,error) + pair_radius) ELSE - CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius) END IF pair_radius = pair_radius + roperator ELSE - CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius) END IF CALL build_neighbor_lists(sab_kp,particle_set,atom2d,cell,pair_radius,& - mic=mic,subcells=subcells,molecular=molecule_only,name="sab_kp",error=error) - CALL set_ks_env(ks_env=ks_env,sab_kp=sab_kp,error=error) + mic=mic,subcells=subcells,molecular=molecule_only,name="sab_kp") + CALL set_ks_env(ks_env=ks_env,sab_kp=sab_kp) END IF ! Build orbital GTH-PPL operator overlap list IF (gth_potential_present) THEN IF (ANY(ppl_present)) THEN - CALL pair_radius_setup(orb_present,ppl_present,orb_radius,ppl_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,ppl_present,orb_radius,ppl_radius,pair_radius) CALL build_neighbor_lists(sac_ppl,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="ABC",name="sac_ppl",error=error) - CALL set_ks_env(ks_env=ks_env,sac_ppl=sac_ppl,error=error) + subcells=subcells,operator_type="ABC",name="sac_ppl") + CALL set_ks_env(ks_env=ks_env,sac_ppl=sac_ppl) CALL write_neighbor_lists(sac_ppl,particle_set,cell,para_env,neighbor_list_section,& - "/SAC_PPL","sac_ppl","ORBITAL GTH-PPL",error) + "/SAC_PPL","sac_ppl","ORBITAL GTH-PPL") END IF IF (ANY(ppnl_present)) THEN - CALL pair_radius_setup(orb_present,ppnl_present,orb_radius,ppnl_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,ppnl_present,orb_radius,ppnl_radius,pair_radius) CALL build_neighbor_lists(sap_ppnl,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="ABBA",name="sap_ppnl",error=error) - CALL set_ks_env(ks_env=ks_env,sap_ppnl=sap_ppnl,error=error) + subcells=subcells,operator_type="ABBA",name="sap_ppnl") + CALL set_ks_env(ks_env=ks_env,sap_ppnl=sap_ppnl) CALL write_neighbor_lists(sap_ppnl,particle_set,cell,para_env,neighbor_list_section,& - "/SAP_PPNL","sap_ppnl","ORBITAL GTH-PPNL",error) + "/SAP_PPNL","sap_ppnl","ORBITAL GTH-PPNL") END IF END IF IF (paw_atom_present) THEN ! Build orbital-GAPW projector overlap list IF (ANY(oce_present)) THEN - CALL pair_radius_setup(orb_present,oce_present,orb_radius,oce_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,oce_present,orb_radius,oce_radius,pair_radius) CALL build_neighbor_lists(sap_oce,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="ABBA",name="sap_oce",error=error) - CALL set_ks_env(ks_env=ks_env,sap_oce=sap_oce,error=error) + subcells=subcells,operator_type="ABBA",name="sap_oce") + CALL set_ks_env(ks_env=ks_env,sap_oce=sap_oce) CALL write_neighbor_lists(sap_oce,particle_set,cell,para_env,neighbor_list_section,& - "/SAP_OCE","sap_oce","ORBITAL(A) PAW-PRJ",error) + "/SAP_OCE","sap_oce","ORBITAL(A) PAW-PRJ") END IF END IF ! Build orbital-ERFC potential list IF (all_potential_present .AND. .NOT. (nddo .OR. dftb .OR. scptb)) THEN - CALL pair_radius_setup(orb_present,all_present,orb_radius,all_pot_rad,pair_radius,error) + CALL pair_radius_setup(orb_present,all_present,orb_radius,all_pot_rad,pair_radius) CALL build_neighbor_lists(sac_ae,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="ABC",name="sac_ae",error=error) - CALL set_ks_env(ks_env=ks_env,sac_ae=sac_ae,error=error) + subcells=subcells,operator_type="ABC",name="sac_ae") + CALL set_ks_env(ks_env=ks_env,sac_ae=sac_ae) CALL write_neighbor_lists(sac_ae,particle_set,cell,para_env,neighbor_list_section,& - "/SAC_AE","sac_ae","ORBITAL ERFC POTENTIAL",error) + "/SAC_AE","sac_ae","ORBITAL ERFC POTENTIAL") END IF IF (nddo) THEN @@ -770,71 +762,71 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e default_present = .TRUE. c_radius = dft_control%qs_control%se_control%cutoff_cou ! Build the neighbor lists for the Hartree terms - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) IF (dft_control%qs_control%se_control%do_ewald_gks) THEN ! Use MIC for the periodic code of GKS CALL build_neighbor_lists(sab_se,particle_set,atom2d,cell,pair_radius,mic=mic,& - subcells=subcells,name="sab_se",error=error) + subcells=subcells,name="sab_se") ELSE CALL build_neighbor_lists(sab_se,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,name="sab_se",error=error) + subcells=subcells,name="sab_se") END IF - CALL set_ks_env(ks_env=ks_env,sab_se=sab_se,error=error) + CALL set_ks_env(ks_env=ks_env,sab_se=sab_se) CALL write_neighbor_lists(sab_se,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_SE","sab_se","HARTREE INTERACTIONS",error) + "/SAB_SE","sab_se","HARTREE INTERACTIONS") ! If requested build the SE long-range correction neighbor list IF ((dft_control%qs_control%se_control%do_ewald).AND.& (dft_control%qs_control%se_control%integral_screening/=do_se_IS_slater)) THEN c_radius = dft_control%qs_control%se_control%cutoff_lrc - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_lrc,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,name="sab_lrc",error=error) - CALL set_ks_env(ks_env=ks_env,sab_lrc=sab_lrc,error=error) + subcells=subcells,name="sab_lrc") + CALL set_ks_env(ks_env=ks_env,sab_lrc=sab_lrc) CALL write_neighbor_lists(sab_lrc,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_LRC","sab_lrc","SE LONG-RANGE CORRECTION",error) + "/SAB_LRC","sab_lrc","SE LONG-RANGE CORRECTION") END IF END IF IF (dftb) THEN ! Build the neighbor lists for the DFTB Ewald methods IF (dft_control%qs_control%dftb_control%do_ewald) THEN - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,error=error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env) CALL ewald_env_get ( ewald_env, alpha=alpha ) c_radius = 0.5_dp*SQRT(-LOG(3.5_dp*alpha**3*1.e-12_dp))/alpha - CALL pair_radius_setup(orb_present,orb_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,orb_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_tbe,particle_set,atom2d,cell,pair_radius,mic=mic,& - subcells=subcells,name="sab_tbe",error=error) - CALL set_ks_env(ks_env=ks_env,sab_tbe=sab_tbe,error=error) + subcells=subcells,name="sab_tbe") + CALL set_ks_env(ks_env=ks_env,sab_tbe=sab_tbe) END IF ! Build the neighbor lists for the DFTB vdW pair potential IF (dft_control%qs_control%dftb_control%dispersion) THEN IF (dft_control%qs_control%dftb_control%dispersion_type == dispersion_uff) THEN DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom,error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_atom) CALL get_dftb_atom_param(dftb_parameter=dftb_atom,& - rcdisp=c_radius(ikind),error=error) + rcdisp=c_radius(ikind)) END DO default_present=.TRUE. - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_vdw,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,name="sab_vdw",error=error) - CALL set_ks_env(ks_env=ks_env,sab_vdw=sab_vdw,error=error) + subcells=subcells,name="sab_vdw") + CALL set_ks_env(ks_env=ks_env,sab_vdw=sab_vdw) END IF END IF END IF ! Build the neighbor lists for the vdW pair potential - CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env,error=error) + CALL get_qs_env(qs_env=qs_env,dispersion_env=dispersion_env) sab_vdw => dispersion_env%sab_vdw sab_cn => dispersion_env%sab_cn IF ( dispersion_env%type == xc_vdw_fun_pairpot ) THEN c_radius(:) = dispersion_env%rc_disp default_present=.TRUE. !include all atoms in vdW (even without basis) - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_vdw,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="PP",name="sab_vdw",error=error) + subcells=subcells,operator_type="PP",name="sab_vdw") dispersion_env%sab_vdw => sab_vdw IF ( dispersion_env%pp_type == vdw_pairpot_dftd3 .OR. & @@ -844,9 +836,9 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e CALL get_atomic_kind(atomic_kind_set(ikind), z=zat) c_radius(ikind) = 4._dp*ptable(zat)%covalent_radius*bohr END DO - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_cn,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="PP",name="sab_cn",error=error) + subcells=subcells,operator_type="PP",name="sab_cn") dispersion_env%sab_cn => sab_cn END IF END IF @@ -855,47 +847,47 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e ! Build the neighbor lists for the Core term default_present = .FALSE. DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,rcpair=c_radius(ikind),defined=default_present(ikind)) END DO - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_core,particle_set,atom2d,cell,pair_radius,mic=mic,& - subcells=subcells,name="sab_core",error=error) - CALL set_ks_env(ks_env=ks_env,sab_core=sab_core,error=error) + subcells=subcells,name="sab_core") + CALL set_ks_env(ks_env=ks_env,sab_core=sab_core) CALL write_neighbor_lists(sab_core,particle_set,cell,para_env,neighbor_list_section,& - "/SAB_CORE","sab_core","CORE INTERACTIONS",error) + "/SAB_CORE","sab_core","CORE INTERACTIONS") ! Build the neighbor lists for the SCPTB Ewald methods IF (dft_control%qs_control%scptb_control%do_ewald) THEN ! Ewald with alpha - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,error=error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env) CALL ewald_env_get ( ewald_env, alpha=alpha ) c_radius = 0.5_dp*SQRT(-LOG(3.5_dp*alpha**3*1.e-12_dp))/alpha - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_tbe,particle_set,atom2d,cell,pair_radius,mic=mic,& - subcells=subcells,name="sab_tbe",error=error) - CALL set_ks_env(ks_env=ks_env,sab_tbe=sab_tbe,error=error) + subcells=subcells,name="sab_tbe") + CALL set_ks_env(ks_env=ks_env,sab_tbe=sab_tbe) ! Correction term for Gaussians DO ikind = 1, nkind - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,ag=alpha) alpha = SQRT(alpha) c_radius(ikind) = 0.5_dp*SQRT(-LOG(3.5_dp*alpha**3*1.e-12_dp))/alpha END DO - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_scp,particle_set,atom2d,cell,pair_radius,mic=mic,& - subcells=subcells,name="sab_scp",error=error) - CALL set_ks_env(ks_env=ks_env,sab_scp=sab_scp,error=error) + subcells=subcells,name="sab_scp") + CALL set_ks_env(ks_env=ks_env,sab_scp=sab_scp) END IF END IF IF(lrigpw .OR. lri_optbas) THEN ! set neighborlists in lri_env environment - CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius,error) + CALL pair_radius_setup(orb_present,orb_present,orb_radius,orb_radius,pair_radius) soo_list => qs_env%lri_env%soo_list CALL build_neighbor_lists(soo_list,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,name="soo_list",error=error) + subcells=subcells,name="soo_list") qs_env%lri_env%soo_list => soo_list CALL write_neighbor_lists(soo_list,particle_set,cell,para_env,neighbor_list_section,& - "/SOO_LIST","soo_list","ORBITAL ORBITAL (RI)",error) + "/SOO_LIST","soo_list","ORBITAL ORBITAL (RI)") END IF ! Build the neighbor lists for the ALMO delocalization @@ -907,56 +899,54 @@ SUBROUTINE build_qs_neighbor_lists(qs_env,para_env,molecular,force_env_section,e almo_max_cutoff_multiplier END DO default_present=.TRUE. !include all atoms (even without basis) - CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius,error) + CALL pair_radius_setup(default_present,default_present,c_radius,c_radius,pair_radius) CALL build_neighbor_lists(sab_almo,particle_set,atom2d,cell,pair_radius,& - subcells=subcells,operator_type="PP",name="sab_almo",error=error) - CALL set_ks_env(ks_env=ks_env,sab_almo=sab_almo,error=error) + subcells=subcells,operator_type="PP",name="sab_almo") + CALL set_ks_env(ks_env=ks_env,sab_almo=sab_almo) ENDIF ! Print particle distribution print_key_path = "PRINT%DISTRIBUTION" IF (BTEST(cp_print_key_should_output(logger%iter_info,force_env_section,& - print_key_path,error=error),& + print_key_path),& cp_p_file)) THEN iw = cp_print_key_unit_nr(logger=logger,& basis_section=force_env_section,& print_key_path=print_key_path,& - extension=".out",& - error=error) - CALL write_neighbor_distribution(sab_orb,qs_kind_set,iw,para_env,error) + extension=".out") + CALL write_neighbor_distribution(sab_orb,qs_kind_set,iw,para_env) CALL cp_print_key_finished_output(unit_nr=iw,& logger=logger,& basis_section=force_env_section,& - print_key_path=print_key_path,& - error=error) + print_key_path=print_key_path) END IF ! Release work storage - CALL atom2d_cleanup(atom2d,error) + CALL atom2d_cleanup(atom2d) DEALLOCATE (atom2d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (orb_present,default_present,core_present,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (orb_radius,aux_fit_radius,c_radius,core_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (calpha,zeff,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (pair_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (gth_potential_present) THEN DEALLOCATE (ppl_present,ppl_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (ppnl_present,ppnl_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (paw_atom_present) THEN DEALLOCATE (oce_present,oce_radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (all_potential_present) THEN DEALLOCATE (all_present,all_pot_rad,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -978,7 +968,6 @@ END SUBROUTINE build_qs_neighbor_lists !> \param current_subset ... !> \param operator_type ... !> \param name ... -!> \param error ... !> \date 20.03.2002 !> \par History !> - Major refactoring (25.07.2010,jhu) @@ -987,7 +976,7 @@ END SUBROUTINE build_qs_neighbor_lists ! ***************************************************************************** SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subcells,& mic,symmetric,molecular,subset_of_mol,current_subset,& - operator_type,name,error) + operator_type,name) TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: ab_list @@ -1003,7 +992,6 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce INTEGER, OPTIONAL :: current_subset CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: operator_type CHARACTER(LEN=*), INTENT(IN) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_neighbor_lists', & routineP = moduleN//':'//routineN @@ -1050,7 +1038,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce otype = 1 ! simple overlap CASE ("ABC") otype = 2 ! for three center operators - CPAssert(.NOT.my_molecular,cp_failure_level,routineP,error,failure) + CPAssert(.NOT.my_molecular,cp_failure_level,routineP,failure) my_symmetric = .FALSE. CASE ("ABBA") otype = 3 ! for separable nonlocal operators @@ -1058,7 +1046,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce CASE ("PP") otype = 4 ! simple atomic pair potential list CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSE ! default is a simple AB neighbor list @@ -1071,19 +1059,19 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce CALL deallocate_neighbor_list_set(ab_list(iab)%neighbor_list_set) END DO DEALLOCATE (ab_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF nkind = SIZE(atom) ! Allocate and initialize the new neighbor list structure ALLOCATE (ab_list(nkind*nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iab=1,SIZE(ab_list) NULLIFY (ab_list(iab)%neighbor_list_set) END DO ! Allocate and initialize the kind availability ALLOCATE (pres_a(nkind),pres_b(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind pres_a(ikind) = ANY(pair_radius(ikind,:) > 0._dp) pres_b(ikind) = ANY(pair_radius(:,ikind) > 0._dp) @@ -1092,7 +1080,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce ! create a copy of the pbc'ed coordinates natom=SIZE(particle_set) ALLOCATE(r_pbc(3,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,natom r_pbc(1:3,i)=pbc(particle_set(i)%r(1:3),cell) ENDDO @@ -1103,12 +1091,12 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce maxat=MAX(maxat,SIZE(atom(ikind)%list)) END DO ALLOCATE (index_list(maxat),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,maxat index_list(i) = i END DO ALLOCATE (lista(nkind),listb(nkind),nlista(nkind),nlistb(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nlista = 0 nlistb = 0 DO ikind=1,nkind @@ -1131,7 +1119,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce nlistb(ikind) = SIZE(atom(ikind)%list) listb(ikind)%list => index_list CASE (3) - CALL combine_lists(lista(ikind)%list,nlista(ikind),ikind,atom,error) + CALL combine_lists(lista(ikind)%list,nlista(ikind),ikind,atom) nlistb(ikind) = SIZE(atom(ikind)%list) listb(ikind)%list => index_list CASE (4) @@ -1140,7 +1128,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce nlistb(ikind) = SIZE(atom(ikind)%list) listb(ikind)%list => index_list CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO @@ -1150,7 +1138,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce maxat=MAX(maxat,nlista(ikind),nlistb(ikind)) END DO ALLOCATE (kind_a(2*maxat),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Load informations about the simulation cell CALL get_cell(cell=cell,periodic=periodic,deth=deth) @@ -1205,7 +1193,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce neighbor_list=kind_a(iatom_local)%neighbor_list) END DO - CALL allocate_subcell(subcell,nsubcell,error=error) + CALL allocate_subcell(subcell,nsubcell) DO iatom_local=1,nlista(ikind) iatom = lista(ikind)%list(iatom_local) atom_a = atom(ikind)%list(iatom) @@ -1218,7 +1206,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce DO i = 1,nsubcell(1) maxat = subcell(i,j,k)%natom + subcell(i,j,k)%natom/10 ALLOCATE(subcell(i,j,k)%atom_list(maxat),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) subcell(i,j,k)%natom = 0 END DO END DO @@ -1352,7 +1340,7 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce END DO - CALL deallocate_subcell(subcell,error=error) + CALL deallocate_subcell(subcell) END DO END DO @@ -1362,17 +1350,17 @@ SUBROUTINE build_neighbor_lists(ab_list,particle_set,atom,cell,pair_radius,subce CASE (3) DO ikind=1,nkind DEALLOCATE(lista(ikind)%list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT DEALLOCATE (kind_a,pres_a,pres_b,lista,listb,nlista,nlistb,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (index_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_pbc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1386,15 +1374,13 @@ END SUBROUTINE build_neighbor_lists !> \param n ... !> \param ikind ... !> \param atom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE combine_lists(list,n,ikind,atom,error) + SUBROUTINE combine_lists(list,n,ikind,atom) INTEGER, DIMENSION(:), POINTER :: list INTEGER, INTENT(OUT) :: n INTEGER, INTENT(IN) :: ikind TYPE(local_atoms_type), DIMENSION(:), & INTENT(IN) :: atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'combine_lists', & routineP = moduleN//':'//routineN @@ -1405,7 +1391,7 @@ SUBROUTINE combine_lists(list,n,ikind,atom,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(list),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(list),cp_failure_level,routineP,failure) lista => atom(ikind)%list_local_a_index listb => atom(ikind)%list_local_b_index @@ -1423,7 +1409,7 @@ SUBROUTINE combine_lists(list,n,ikind,atom,error) END IF ALLOCATE(list(na+nb),STAT=ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) n = na IF(na.GT.0) list(1:na) = lista(1:na) @@ -1447,13 +1433,11 @@ END SUBROUTINE combine_lists !> \param radius_a ... !> \param radius_b ... !> \param pair_radius ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pair_radius_setup(present_a,present_b,radius_a,radius_b,pair_radius,error) + SUBROUTINE pair_radius_setup(present_a,present_b,radius_a,radius_b,pair_radius) LOGICAL, DIMENSION(:), INTENT(IN) :: present_a, present_b REAL(dp), DIMENSION(:), INTENT(IN) :: radius_a, radius_b REAL(dp), DIMENSION(:, :), INTENT(OUT) :: pair_radius - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pair_radius_setup', & routineP = moduleN//':'//routineN @@ -1480,19 +1464,17 @@ END SUBROUTINE pair_radius_setup !> \param qs_kind_set ... !> \param output_unit ... !> \param para_env ... -!> \param error ... !> \date 19.06.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_neighbor_distribution(ab,qs_kind_set,output_unit,para_env,error) + SUBROUTINE write_neighbor_distribution(ab,qs_kind_set,output_unit,para_env) TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: ab TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set INTEGER, INTENT(in) :: output_unit TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_neighbor_distribution', & routineP = moduleN//':'//routineN @@ -1518,15 +1500,15 @@ SUBROUTINE write_neighbor_distribution(ab,qs_kind_set,output_unit,para_env,error ! Allocate work storage ALLOCATE (nblock(npe),nelement(npe),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nblock(:) = 0 nelement(:) = 0 nkind = SIZE(qs_kind_set) ALLOCATE (nnsgf(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nnsgf = 1 DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set) IF (ASSOCIATED(orb_basis_set)) THEN CALL get_gto_basis_set(gto_basis_set=orb_basis_set,nsgf=nnsgf(ikind)) END IF @@ -1587,7 +1569,7 @@ SUBROUTINE write_neighbor_distribution(ab,qs_kind_set,output_unit,para_env,error ! Release work storage DEALLOCATE (nblock,nelement,nnsgf,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1603,7 +1585,6 @@ END SUBROUTINE write_neighbor_distribution !> \param nl_type ... !> \param middle_name ... !> \param name ... -!> \param error ... !> \date 04.03.2002 !> \par History !> - Adapted to the new parallelized neighbor list version @@ -1612,7 +1593,7 @@ END SUBROUTINE write_neighbor_distribution !> \version 1.0 ! ***************************************************************************** SUBROUTINE write_neighbor_lists(ab,particle_set,cell,para_env,neighbor_list_section,& - nl_type,middle_name,name,error) + nl_type,middle_name,name) TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: ab @@ -1622,7 +1603,6 @@ SUBROUTINE write_neighbor_lists(ab,particle_set,cell,para_env,neighbor_list_sect TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: neighbor_list_section CHARACTER(LEN=*), INTENT(IN) :: nl_type, middle_name, name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_string_length) :: string, unit_str INTEGER :: iatom, inode, iw, jatom, & @@ -1637,9 +1617,9 @@ SUBROUTINE write_neighbor_lists(ab,particle_set,cell,para_env,neighbor_list_sect failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info,neighbor_list_section,& - TRIM(nl_type),error=error),& + TRIM(nl_type)),& cp_p_file)) THEN iw = cp_print_key_unit_nr(logger=logger,& basis_section=neighbor_list_section,& @@ -1648,11 +1628,10 @@ SUBROUTINE write_neighbor_lists(ab,particle_set,cell,para_env,neighbor_list_sect middle_name=TRIM(middle_name),& local=.TRUE.,& log_filename=.FALSE.,& - file_position="REWIND",& - error=error) + file_position="REWIND") mype = para_env%mepos - CALL section_vals_val_get(neighbor_list_section,"UNIT",c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + CALL section_vals_val_get(neighbor_list_section,"UNIT",c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) ! Print headline string = "" @@ -1692,8 +1671,7 @@ SUBROUTINE write_neighbor_lists(ab,particle_set,cell,para_env,neighbor_list_sect logger=logger,& basis_section=neighbor_list_section,& print_key_path=TRIM(nl_type),& - local=.TRUE.,& - error=error) + local=.TRUE.) END IF END SUBROUTINE write_neighbor_lists diff --git a/src/qs_oce_methods.F b/src/qs_oce_methods.F index 38a8412770..eebcf99962 100644 --- a/src/qs_oce_methods.F +++ b/src/qs_oce_methods.F @@ -71,10 +71,9 @@ MODULE qs_oce_methods !> \param nsgf_cnt ... !> \param sgf_soft_only ... !> \param eps_fit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE build_oce_block(oces,atom_ka,atom_kb,rab,nder,sgf_list,nsgf_cnt,sgf_soft_only,& - eps_fit,error) + eps_fit) TYPE(block_p_type), DIMENSION(:), & @@ -86,7 +85,6 @@ SUBROUTINE build_oce_block(oces,atom_ka,atom_kb,rab,nder,sgf_list,nsgf_cnt,sgf_s INTEGER, INTENT(OUT) :: nsgf_cnt LOGICAL, INTENT(OUT) :: sgf_soft_only REAL(dp), INTENT(IN) :: eps_fit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_oce_block', & routineP = moduleN//':'//routineN @@ -117,12 +115,12 @@ SUBROUTINE build_oce_block(oces,atom_ka,atom_kb,rab,nder,sgf_list,nsgf_cnt,sgf_s NULLIFY(orb_basis_a,paw_proj_a) CALL get_qs_kind(qs_kind=atom_ka,basis_set=orb_basis_a,& paw_proj_set=paw_proj_a,paw_atom=paw_atom_a,& - hard_radius=hard_radius_a,error=error) + hard_radius=hard_radius_a) NULLIFY(orb_basis_b,paw_proj_b) CALL get_qs_kind(qs_kind=atom_kb,basis_set=orb_basis_b,& paw_proj_set=paw_proj_b,paw_atom=paw_atom_b,& - hard_radius=hard_radius_b,error=error) + hard_radius=hard_radius_b) IF(.NOT. paw_atom_a) RETURN @@ -158,15 +156,15 @@ SUBROUTINE build_oce_block(oces,atom_ka,atom_kb,rab,nder,sgf_list,nsgf_cnt,sgf_s msab = MAX(maxnprja*ncoset(maxlprj),maxcob) ALLOCATE(c2s(lds,lds),STAT= istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(s(lds,lds,ncoset(nder+1)),STAT= istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(spa_sb(np_car,ntotsgfb), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(spa_tmp(msab,msab*maxder),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(ovs(np_sph,maxcob*nsetb*maxder),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) m1 = 0 nsgf_cnt = 0 @@ -271,7 +269,7 @@ SUBROUTINE build_oce_block(oces,atom_ka,atom_kb,rab,nder,sgf_list,nsgf_cnt,sgf_s IF(sgf_hard_only.EQ.0) sgf_soft_only = .TRUE. DEALLOCATE(c2s,s,spa_sb,spa_tmp,ovs,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE build_oce_block @@ -282,16 +280,14 @@ END SUBROUTINE build_oce_block !> \param atom_ka ... !> \param sgf_list ... !> \param nsgf_cnt ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_oce_block_local(oceh,oces,atom_ka,sgf_list,nsgf_cnt,error) + SUBROUTINE build_oce_block_local(oceh,oces,atom_ka,sgf_list,nsgf_cnt) TYPE(block_p_type), DIMENSION(:), & POINTER :: oceh, oces TYPE(qs_kind_type), POINTER :: atom_ka INTEGER, DIMENSION(:), INTENT(OUT) :: sgf_list INTEGER, INTENT(OUT) :: nsgf_cnt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_oce_block_local', & routineP = moduleN//':'//routineN @@ -310,7 +306,7 @@ SUBROUTINE build_oce_block_local(oceh,oces,atom_ka,sgf_list,nsgf_cnt,error) failure = .FALSE. NULLIFY(orb_basis_a,paw_proj_a) CALL get_qs_kind(qs_kind=atom_ka,basis_set=orb_basis_a,& - paw_proj_set=paw_proj_a,paw_atom=paw_atom_a,error=error) + paw_proj_set=paw_proj_a,paw_atom=paw_atom_a) IF(.NOT. paw_atom_a) RETURN @@ -326,7 +322,7 @@ SUBROUTINE build_oce_block_local(oceh,oces,atom_ka,sgf_list,nsgf_cnt,error) local_oce_sphi_s=local_oce_s) ALLOCATE(prjloc_h(nseta*maxsoa,nsgfa),prjloc_s(nseta*maxsoa,nsgfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) prjloc_h = 0._dp prjloc_s = 0._dp @@ -353,7 +349,7 @@ SUBROUTINE build_oce_block_local(oceh,oces,atom_ka,sgf_list,nsgf_cnt,error) END DO DEALLOCATE(prjloc_h,prjloc_s,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE build_oce_block_local @@ -368,13 +364,12 @@ END SUBROUTINE build_oce_block_local !> \param particle_set ... !> \param sap_oce ... !> \param eps_fit ... -!> \param error ... !> \par History !> 02.2009 created !> \author jgh ! ***************************************************************************** SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& - qs_kind_set, particle_set, sap_oce, eps_fit, error) + qs_kind_set, particle_set, sap_oce, eps_fit) TYPE(sap_int_type), DIMENSION(:), & POINTER :: intac @@ -387,7 +382,6 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sap_oce REAL(dp), INTENT(IN) :: eps_fit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_oce_matrices', & routineP = moduleN//':'//routineN @@ -441,7 +435,7 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& maxlgto=maxlgto,& maxlprj=maxlprj,& maxco_proj=maxprj,& - maxsgf=maxsgf,error=error) + maxsgf=maxsgf) maxl = MAX(maxlgto,maxlprj) CALL init_orbital_pointers(maxl+nder+1) @@ -449,14 +443,14 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& ldsab = MAX(maxco,ncoset(maxlprj),maxsgf,maxprj) ldai = ncoset(maxl+nder+1) ALLOCATE(sab(ldsab,ldsab*maxder),work(ldsab,ldsab*maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sab=0.0_dp ALLOCATE (ai_work(ldai,ldai,ncoset(nder+1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ai_work=0.0_dp ALLOCATE(oceh(maxder),oces(maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nkind*nkind NULLIFY(intac(i)%alist,intac(i)%asort,intac(i)%aindex) @@ -473,7 +467,7 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& dab = SQRT(SUM(rab*rab)) qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis_set,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis_set) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& @@ -494,10 +488,10 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& qs_kind => qs_kind_set(jkind) NULLIFY(paw_proj_b) - CALL get_qs_kind(qs_kind=qs_kind,paw_proj_set=paw_proj_b,paw_atom=paw_atom_b,error=error) + CALL get_qs_kind(qs_kind=qs_kind,paw_proj_set=paw_proj_b,paw_atom=paw_atom_b) IF (.NOT.paw_atom_b) CYCLE - CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis_paw,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=orb_basis_paw) IF (.NOT.ASSOCIATED(orb_basis_paw)) CYCLE CALL get_gto_basis_set(gto_basis_set=orb_basis_paw,maxso=maxsob,nset=nsetb) @@ -518,7 +512,7 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& intac(iac)%p_kind = jkind intac(iac)%nalist = nlist ALLOCATE(intac(iac)%alist(nlist),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nlist NULLIFY(intac(iac)%alist(i)%clist) intac(iac)%alist(i)%aatom = 0 @@ -529,7 +523,7 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& intac(iac)%alist(ilist)%aatom = atom_a intac(iac)%alist(ilist)%nclist = nneighbor ALLOCATE(intac(iac)%alist(ilist)%clist(nneighbor),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF clist => intac(iac)%alist(ilist)%clist(jneighbor) @@ -542,7 +536,7 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& NULLIFY(clist%acint,clist%achint,clist%sgf_list) ALLOCATE(sgf_list(nsgfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) at_a => qs_kind_set(jkind) at_b => qs_kind_set(ikind) @@ -552,22 +546,22 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& IF( local ) THEN DO i=1,maxder ALLOCATE(oceh(i)%block(nsobtot,nsgfa),oces(i)%block(nsobtot,nsgfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) oceh(i)%block=0._dp oces(i)%block=0._dp END DO - CALL build_oce_block_local(oceh,oces,at_a,sgf_list,nsgf_cnt,error) + CALL build_oce_block_local(oceh,oces,at_a,sgf_list,nsgf_cnt) clist%nsgf_cnt = nsgf_cnt clist%sgf_soft_only = .FALSE. IF(nsgf_cnt > 0) THEN ALLOCATE(clist%acint(nsgf_cnt,nsobtot,maxder),clist%sgf_list(nsgf_cnt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) clist%acint(:,:,:)=0._dp clist%sgf_list(:)=HUGE(0) - CPPostcondition(nsgf_cnt == nsgfa,cp_failure_level,routineP,error,failure) + CPPostcondition(nsgf_cnt == nsgfa,cp_failure_level,routineP,failure) ! *** Special case: A=B ALLOCATE(clist%achint(nsgfa,nsobtot,maxder),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) clist%achint=0._dp clist%acint(1:nsgfa,1:nsobtot,1) = TRANSPOSE(oces(1)%block(1:nsobtot,1:nsgfa)) clist%achint(1:nsgfa,1:nsobtot,1) = TRANSPOSE(oceh(1)%block(1:nsobtot,1:nsgfa)) @@ -577,20 +571,20 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& ENDIF DO i=1,maxder DEALLOCATE(oceh(i)%block,oces(i)%block,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO ELSE DO i=1,maxder ALLOCATE(oces(i)%block(nsobtot,nsgfa),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) oces(i)%block=0._dp END DO - CALL build_oce_block(oces,at_a,at_b,rab,nder,sgf_list,nsgf_cnt,sgf_soft_only,eps_fit,error) + CALL build_oce_block(oces,at_a,at_b,rab,nder,sgf_list,nsgf_cnt,sgf_soft_only,eps_fit) clist%nsgf_cnt = nsgf_cnt clist%sgf_soft_only = sgf_soft_only IF(nsgf_cnt > 0) THEN ALLOCATE(clist%acint(nsgf_cnt,nsobtot,maxder),clist%sgf_list(nsgf_cnt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) clist%acint(:,:,:)=0._dp clist%sgf_list(:)=HUGE(0) DO i=1,maxder @@ -602,23 +596,23 @@ SUBROUTINE build_oce_matrices(intac, calculate_forces, nder,& ENDIF DO i=1,maxder DEALLOCATE(oces(i)%block,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO END IF DEALLOCATE(sgf_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(sab,work,ai_work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(oceh,oces,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! set up sort index - CALL sap_sort(intac,error) + CALL sap_sort(intac) END IF @@ -702,14 +696,12 @@ END SUBROUTINE proj_blk !> \param ain matrix in old indexing !> \param aout matrix in new compressed indexing !> \param atom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE prj_gather(ain,aout,atom,error) + SUBROUTINE prj_gather(ain,aout,atom) REAL(dp), DIMENSION(:, :), INTENT(IN) :: ain REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: aout TYPE(qs_kind_type), INTENT(IN) :: atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'prj_gather', & routineP = moduleN//':'//routineN @@ -720,7 +712,7 @@ SUBROUTINE prj_gather(ain,aout,atom,error) TYPE(paw_proj_set_type), POINTER :: paw_proj NULLIFY(paw_proj) - CALL get_qs_kind(qs_kind=atom,paw_proj_set=paw_proj,paw_atom=paw_atom,error=error) + CALL get_qs_kind(qs_kind=atom,paw_proj_set=paw_proj,paw_atom=paw_atom) NULLIFY(n2oindex) CALL get_paw_proj_set(paw_proj_set=paw_proj,nsatbas=nbas,n2oindex=n2oindex) @@ -739,14 +731,12 @@ END SUBROUTINE prj_gather !> \param ain matrix in new compressed indexing !> \param aout matrix in old indexing (addup) !> \param atom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE prj_scatter(ain,aout,atom,error) + SUBROUTINE prj_scatter(ain,aout,atom) REAL(dp), DIMENSION(:, :), INTENT(IN) :: ain REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: aout TYPE(qs_kind_type), INTENT(IN) :: atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'prj_scatter', & routineP = moduleN//':'//routineN @@ -757,7 +747,7 @@ SUBROUTINE prj_scatter(ain,aout,atom,error) TYPE(paw_proj_set_type), POINTER :: paw_proj NULLIFY(paw_proj) - CALL get_qs_kind(qs_kind=atom,paw_proj_set=paw_proj,paw_atom=paw_atom,error=error) + CALL get_qs_kind(qs_kind=atom,paw_proj_set=paw_proj,paw_atom=paw_atom) NULLIFY(n2oindex) CALL get_paw_proj_set(paw_proj_set=paw_proj,nsatbas=nbas,n2oindex=n2oindex) diff --git a/src/qs_oce_types.F b/src/qs_oce_types.F index dad9fc2f47..ed8fdada80 100644 --- a/src/qs_oce_types.F +++ b/src/qs_oce_types.F @@ -52,13 +52,11 @@ MODULE qs_oce_types !> \brief Allocate and initialize the matrix set of oce coefficients. !> \param oce_set ... !> \param nkind ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_oce_set(oce_set,nkind,error) + SUBROUTINE allocate_oce_set(oce_set,nkind) TYPE(oce_matrix_type), POINTER :: oce_set INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_oce_set', & routineP = moduleN//':'//routineN @@ -69,7 +67,7 @@ SUBROUTINE allocate_oce_set(oce_set,nkind,error) failure = .FALSE. ALLOCATE(oce_set%intac(nkind*nkind),STAT=istat) - CPPrecondition(istat==0,cp_warning_level,routineP,error,failure) + CPPrecondition(istat==0,cp_warning_level,routineP,failure) DO i=1,nkind*nkind NULLIFY(oce_set%intac(i)%alist) NULLIFY(oce_set%intac(i)%asort) @@ -81,19 +79,17 @@ END SUBROUTINE allocate_oce_set ! ***************************************************************************** !> \brief ... !> \param oce_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_oce_set(oce_set,error) + SUBROUTINE create_oce_set(oce_set) TYPE(oce_matrix_type), POINTER :: oce_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_oce_set', & routineP = moduleN//':'//routineN INTEGER :: istat - IF(ASSOCIATED(oce_set)) CALL deallocate_oce_set(oce_set,error=error) + IF(ASSOCIATED(oce_set)) CALL deallocate_oce_set(oce_set) ALLOCATE (oce_set,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,"oce_set",0) @@ -105,14 +101,12 @@ END SUBROUTINE create_oce_set ! ***************************************************************************** !> \brief Deallocate the matrix set of oce coefficients !> \param oce_set ... -!> \param error ... !> \date !> \author !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_oce_set(oce_set,error) + SUBROUTINE deallocate_oce_set(oce_set) TYPE(oce_matrix_type), POINTER :: oce_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_oce_set', & routineP = moduleN//':'//routineN @@ -121,7 +115,7 @@ SUBROUTINE deallocate_oce_set(oce_set,error) IF (.NOT.ASSOCIATED(oce_set)) RETURN - IF(ASSOCIATED(oce_set%intac)) CALL release_sap_int(oce_set%intac,error=error) + IF(ASSOCIATED(oce_set%intac)) CALL release_sap_int(oce_set%intac) DEALLOCATE (oce_set,STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& diff --git a/src/qs_operators_ao.F b/src/qs_operators_ao.F index d3a3713cea..c04b10db98 100644 --- a/src/qs_operators_ao.F +++ b/src/qs_operators_ao.F @@ -62,17 +62,15 @@ MODULE qs_operators_ao !> Cartesian Gaussian functions. !> \param qs_env ... !> \param matrix ... -!> \param error ... !> \date 27.02.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** - SUBROUTINE build_lin_mom_matrix(qs_env,matrix,error) + SUBROUTINE build_lin_mom_matrix(qs_env,matrix) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_lin_mom_matrix', & routineP = moduleN//':'//routineN @@ -119,7 +117,7 @@ SUBROUTINE build_lin_mom_matrix(qs_env,matrix,error) NULLIFY(cell,sab_orb,qs_kind_set,particle_set,para_env) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& @@ -127,8 +125,7 @@ SUBROUTINE build_lin_mom_matrix(qs_env,matrix,error) neighbor_list_id=neighbor_list_id,& para_env=para_env,& sab_orb=sab_orb,& - cell=cell,& - error=error) + cell=cell) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -138,22 +135,22 @@ SUBROUTINE build_lin_mom_matrix(qs_env,matrix,error) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxco,& maxlgto=maxlgto,& - maxsgf=maxsgf, error=error) + maxsgf=maxsgf) ldai = ncoset(maxlgto+1) CALL init_orbital_pointers(ldai) ALLOCATE(rr_work(ldai,ldai,3),intab(maxco,maxco,3),work(maxco,maxsgf),integral(3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rr_work(:,:,:) = 0.0_dp intab(:,:,:) = 0.0_dp work(:,:) = 0.0_dp ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -212,7 +209,7 @@ SUBROUTINE build_lin_mom_matrix(qs_env,matrix,error) NULLIFY(integral(i)%block) CALL cp_dbcsr_get_block_p(matrix=matrix(i)%matrix,& row=irow,col=icol,BLOCK=integral(i)%block,found=found) - CPPostcondition(ASSOCIATED(INTEGRAL(i)%block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(INTEGRAL(i)%block),cp_failure_level,routineP,failure) ENDDO END IF @@ -237,7 +234,7 @@ SUBROUTINE build_lin_mom_matrix(qs_env,matrix,error) rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),& rpgfb(:,jset),zetb(:,jset),& - rab,intab,SIZE(rr_work,1),rr_work,error) + rab,intab,SIZE(rr_work,1),rr_work) ! *** Contraction step *** @@ -278,19 +275,19 @@ SUBROUTINE build_lin_mom_matrix(qs_env,matrix,error) ! *** Release work storage *** DEALLOCATE(intab,work,integral,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! *** Print the spin orbit matrix, if requested *** !IF (BTEST(cp_print_key_should_output(logger%iter_info,& - ! qs_env%input,"DFT%PRINT%AO_MATRICES/LINEAR_MOMENTUM",error=error),cp_p_file)) THEN + ! qs_env%input,"DFT%PRINT%AO_MATRICES/LINEAR_MOMENTUM"),cp_p_file)) THEN ! iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/LINEA_MOMENTUM",& - ! extension=".Log",error=error) - ! CALL cp_dbcsr_write_sparse_matrix(matrix(1)%matrix,4,6,qs_env,para_env,output_unit=iw,error=error) - ! CALL cp_dbcsr_write_sparse_matrix(matrix(2)%matrix,4,6,qs_env,para_env,output_unit=iw,error=error) - ! CALL cp_dbcsr_write_sparse_matrix(matrix(3)%matrix,4,6,qs_env,para_env,output_unit=iw,error=error) + ! extension=".Log") + ! CALL cp_dbcsr_write_sparse_matrix(matrix(1)%matrix,4,6,qs_env,para_env,output_unit=iw) + ! CALL cp_dbcsr_write_sparse_matrix(matrix(2)%matrix,4,6,qs_env,para_env,output_unit=iw) + ! CALL cp_dbcsr_write_sparse_matrix(matrix(3)%matrix,4,6,qs_env,para_env,output_unit=iw) ! CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - ! "DFT%PRINT%AO_MATRICES/LINEAR_MOMENTUM", error=error) + ! "DFT%PRINT%AO_MATRICES/LINEAR_MOMENTUM") !END IF CALL timestop(handle) @@ -315,13 +312,12 @@ END SUBROUTINE build_lin_mom_matrix !> \param intab ... !> \param ldrr ... !> \param rr ... -!> \param error ... !> \date 02.03.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** SUBROUTINE lin_mom(la_max,la_min,npgfa,rpgfa,zeta,lb_max,lb_min,npgfb,rpgfb,zetb,& - rab,intab,ldrr,rr,error) + rab,intab,ldrr,rr) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max, lb_min, npgfb @@ -333,7 +329,6 @@ SUBROUTINE lin_mom(la_max,la_min,npgfa,rpgfa,zeta,lb_max,lb_min,npgfb,rpgfb,zetb REAL(dp), & DIMENSION(0:ldrr-1, 0:ldrr-1, 3), & INTENT(INOUT) :: rr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lin_mom', & routineP = moduleN//':'//routineN @@ -440,19 +435,17 @@ END SUBROUTINE lin_mom !> \param qs_env ... !> \param matrix ... !> \param rc ... -!> \param error ... !> \date 27.02.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** - SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc,error) + SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix REAL(dp), DIMENSION(:), INTENT(IN) :: rc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_ang_mom_matrix', & routineP = moduleN//':'//routineN @@ -499,7 +492,7 @@ SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc,error) NULLIFY(cell,sab_all,qs_kind_set,particle_set,para_env) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& @@ -507,8 +500,7 @@ SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc,error) neighbor_list_id=neighbor_list_id,& para_env=para_env,& sab_all=sab_all,& - cell=cell,& - error=error) + cell=cell) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -518,22 +510,22 @@ SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc,error) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxco,& maxlgto=maxlgto,& - maxsgf=maxsgf, error=error) + maxsgf=maxsgf) ldai = ncoset(maxlgto+1) CALL init_orbital_pointers(ldai) ALLOCATE(rr_work(ldai,ldai,3),intab(maxco,maxco,3),work(maxco,maxsgf),integral(3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rr_work(:,:,:) = 0.0_dp intab(:,:,:) = 0.0_dp work(:,:) = 0.0_dp ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -594,7 +586,7 @@ SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc,error) NULLIFY(INTEGRAL(i)%block) CALL cp_dbcsr_get_block_p(matrix=matrix(i)%matrix,& row=irow,col=icol,BLOCK=INTEGRAL(i)%block,found=found) - CPPostcondition(ASSOCIATED(INTEGRAL(i)%block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(INTEGRAL(i)%block),cp_failure_level,routineP,failure) ENDDO END IF @@ -629,7 +621,7 @@ SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc,error) rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),& rpgfb(:,jset),zetb(:,jset),& - rab,rac,intab,SIZE(rr_work,1),rr_work,error) + rab,rac,intab,SIZE(rr_work,1),rr_work) ! *** Contraction step *** @@ -671,19 +663,19 @@ SUBROUTINE build_ang_mom_matrix(qs_env,matrix,rc,error) ! *** Release work storage *** DEALLOCATE(intab,work,integral,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! *** Print the spin orbit matrix, if requested *** !IF (BTEST(cp_print_key_should_output(logger%iter_info,& - ! qs_env%input,"DFT%PRINT%AO_MATRICES/ANGULAR_MOMENTUM",error=error),cp_p_file)) THEN + ! qs_env%input,"DFT%PRINT%AO_MATRICES/ANGULAR_MOMENTUM"),cp_p_file)) THEN ! iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/ANGULAR_MOMENTUM",& - ! extension=".Log",error=error) - ! CALL cp_dbcsr_write_sparse_matrix(matrix(1)%matrix,4,6,qs_env,para_env,output_unit=iw,error=error) - ! CALL cp_dbcsr_write_sparse_matrix(matrix(2)%matrix,4,6,qs_env,para_env,output_unit=iw,error=error) - ! CALL cp_dbcsr_write_sparse_matrix(matrix(3)%matrix,4,6,qs_env,para_env,output_unit=iw,error=error) + ! extension=".Log") + ! CALL cp_dbcsr_write_sparse_matrix(matrix(1)%matrix,4,6,qs_env,para_env,output_unit=iw) + ! CALL cp_dbcsr_write_sparse_matrix(matrix(2)%matrix,4,6,qs_env,para_env,output_unit=iw) + ! CALL cp_dbcsr_write_sparse_matrix(matrix(3)%matrix,4,6,qs_env,para_env,output_unit=iw) ! CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - ! "DFT%PRINT%AO_MATRICES/ANGULAR_MOMENTUM", error=error) + ! "DFT%PRINT%AO_MATRICES/ANGULAR_MOMENTUM") !END IF CALL timestop(handle) @@ -708,13 +700,12 @@ END SUBROUTINE build_ang_mom_matrix !> \param intab ... !> \param ldrr ... !> \param rr ... -!> \param error ... !> \date 02.03.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** SUBROUTINE ang_mom(la_max,la_min,npgfa,rpgfa,zeta,lb_max,lb_min,npgfb,rpgfb,zetb,& - rab,rac,intab,ldrr,rr,error) + rab,rac,intab,ldrr,rr) INTEGER, INTENT(IN) :: la_max, la_min, npgfa REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rpgfa, zeta INTEGER, INTENT(IN) :: lb_max, lb_min, npgfb @@ -726,7 +717,6 @@ SUBROUTINE ang_mom(la_max,la_min,npgfa,rpgfa,zeta,lb_max,lb_min,npgfb,rpgfb,zetb REAL(dp), & DIMENSION(0:ldrr-1, 0:ldrr-1, 3), & INTENT(INOUT) :: rr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ang_mom', & routineP = moduleN//':'//routineN @@ -843,20 +833,17 @@ END SUBROUTINE ang_mom !> calculated in terms of the contracted basis functions !> \param qs_env enviroment for the lists and the basis sets !> \param minimum_image take into account only the first neighbors in the lists -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE p_xyz_ao(op,qs_env,minimum_image,error) + SUBROUTINE p_xyz_ao(op,qs_env,minimum_image) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: op TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN), OPTIONAL :: minimum_image - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_xyz_ao', & routineP = moduleN//':'//routineN @@ -906,12 +893,12 @@ SUBROUTINE p_xyz_ao(op,qs_env,minimum_image,error) CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set,& cell=cell,particle_set=particle_set,& - sab_orb=sab_orb,error=error) + sab_orb=sab_orb) nkind = SIZE(qs_kind_set) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& - maxco=ldwork, maxlgto=maxl, error=error ) + maxco=ldwork, maxlgto=maxl) my_minimum_image = .FALSE. IF(PRESENT(minimum_image)) THEN @@ -924,23 +911,23 @@ SUBROUTINE p_xyz_ao(op,qs_env,minimum_image,error) ldab = ldwork ALLOCATE(difab(ldab,ldab,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) difab(1:ldab,1:ldab,1:3) = 0.0_dp ALLOCATE(work(ldwork,ldwork),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) work(1:ldwork,1:ldwork) = 0.0_dp ALLOCATE (op_dip(3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i = 1, 3 NULLIFY (op_dip(i)%block) END DO ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -1016,7 +1003,7 @@ SUBROUTINE p_xyz_ao(op,qs_env,minimum_image,error) NULLIFY(op_dip(i)%block) CALL cp_dbcsr_get_block_p(matrix=op(i)%matrix,& row=irow,col=icol,block=op_dip(i)%block,found=found) - CPPostcondition(ASSOCIATED(op_dip(i)%block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(op_dip(i)%block),cp_failure_level,routineP,failure) END DO END IF ! new_atom_b rab2 = rab(1)*rab(1) + rab(2)*rab(2) + rab(3)*rab(3) @@ -1107,10 +1094,10 @@ SUBROUTINE p_xyz_ao(op,qs_env,minimum_image,error) NULLIFY(op_dip(i)%block) END DO DEALLOCATE(op_dip, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(difab,work,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1130,14 +1117,12 @@ END SUBROUTINE p_xyz_ao !> \param order maximum order of the momentum, for the doipole order = 1 !> \param minimum_image take into account only the first neighbors in the lists !> \param soft ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE rRc_xyz_ao(op,qs_env,rc,order,minimum_image,soft,error) + SUBROUTINE rRc_xyz_ao(op,qs_env,rc,order,minimum_image,soft) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: op @@ -1145,7 +1130,6 @@ SUBROUTINE rRc_xyz_ao(op,qs_env,rc,order,minimum_image,soft,error) REAL(dp) :: Rc(3) INTEGER, INTENT(IN) :: order LOGICAL, INTENT(IN), OPTIONAL :: minimum_image, soft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rRc_xyz_ao', & routineP = moduleN//':'//routineN @@ -1193,13 +1177,12 @@ SUBROUTINE rRc_xyz_ao(op,qs_env,rc,order,minimum_image,soft,error) NULLIFY (set_radius_a,set_radius_b,rpgfa, rpgfb, sphi_a,sphi_b,zeta, zetb ) CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set,& - cell=cell,particle_set=particle_set,sab_orb=sab_orb,& - error=error) + cell=cell,particle_set=particle_set,sab_orb=sab_orb) nkind = SIZE(qs_kind_set) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& - maxco=ldwork, maxlgto=maxl, error=error ) + maxco=ldwork, maxlgto=maxl) my_minimum_image = .FALSE. IF(PRESENT(minimum_image)) THEN @@ -1216,26 +1199,26 @@ SUBROUTINE rRc_xyz_ao(op,qs_env,rc,order,minimum_image,soft,error) ldab = ldwork M_dim = ncoset(order)-1 - CPPostcondition(M_dim<=SIZE(op,1),cp_failure_level,routineP,error,failure) + CPPostcondition(M_dim<=SIZE(op,1),cp_failure_level,routineP,failure) ALLOCATE(mab(ldab,ldab,M_dim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mab(1:ldab,1:ldab,1:M_dim) = 0.0_dp ALLOCATE(work(ldwork,ldwork),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) work(1:ldwork,1:ldwork) = 0.0_dp ALLOCATE (op_dip(M_dim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO imom = 1, M_dim NULLIFY (op_dip(imom)%block) END DO ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,softb=my_soft,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,softb=my_soft,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -1303,7 +1286,7 @@ SUBROUTINE rRc_xyz_ao(op,qs_env,rc,order,minimum_image,soft,error) NULLIFY(op_dip(imom)%block) CALL cp_dbcsr_get_block_p(matrix=op(imom)%matrix,& row=irow,col=icol,block=op_dip(imom)%block,found=found) - CPPostcondition(ASSOCIATED(op_dip(imom)%block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(op_dip(imom)%block),cp_failure_level,routineP,failure) END DO ! imom END IF ! new_atom_b @@ -1367,10 +1350,10 @@ SUBROUTINE rRc_xyz_ao(op,qs_env,rc,order,minimum_image,soft,error) NULLIFY(op_dip(i)%block) END DO DEALLOCATE(op_dip, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mab,work,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1407,8 +1390,6 @@ END SUBROUTINE rRc_xyz_ao !> \param order maximum order of the momentum, for the dipole order = 1 !> \param minimum_image take into account only the first neighbors in the lists !> \param soft ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 created [MI] !> \author MI @@ -1418,7 +1399,7 @@ END SUBROUTINE rRc_xyz_ao !> The elements of the sparse matrices are the integrals in the !> basis functions ! ***************************************************************************** - SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) + SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: op @@ -1428,7 +1409,6 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) REAL(dp) :: Rc(3) INTEGER, INTENT(IN) :: order LOGICAL, INTENT(IN), OPTIONAL :: minimum_image, soft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rRc_xyz_der_ao', & routineP = moduleN//':'//routineN @@ -1475,11 +1455,11 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPostcondition(ASSOCIATED(op),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(op_der),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(op),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(op_der),cp_failure_level,routineP,failure) !IF(.NOT.op_sm_der(1,1)%matrix%symmetry=="none") THEN IF(.NOT.cp_dbcsr_get_matrix_type(op_der(1,1)%matrix).EQ.dbcsr_type_no_symmetry) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF NULLIFY (qs_kind, qs_kind_set) @@ -1492,12 +1472,12 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set,& cell=cell,particle_set=particle_set,& - sab_all=sab_all,error=error) + sab_all=sab_all) nkind = SIZE(qs_kind_set) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& - maxco=ldwork, maxlgto=maxl, error=error ) + maxco=ldwork, maxlgto=maxl) my_minimum_image = .FALSE. IF(PRESENT(minimum_image)) THEN @@ -1514,22 +1494,22 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) ldab = ldwork M_dim = ncoset(order)-1 - CPPostcondition(M_dim<=SIZE(op,1),cp_failure_level,routineP,error,failure) + CPPostcondition(M_dim<=SIZE(op,1),cp_failure_level,routineP,failure) ALLOCATE(mab(ldab,ldab,M_dim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mab(1:ldab,1:ldab,1:M_dim) = 0.0_dp ALLOCATE(difmab(ldab,ldab,M_dim,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) difmab(1:ldab,1:ldab,1:M_dim,1:3) = 0.0_dp ALLOCATE(work(ldwork,ldwork),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) work(1:ldwork,1:ldwork) = 0.0_dp ALLOCATE (op_dip(M_dim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (op_dip_der(M_dim,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO imom = 1, M_dim NULLIFY (op_dip(imom)%block) @@ -1539,10 +1519,10 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) END DO ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,softb=my_soft,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,softb=my_soft,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -1611,14 +1591,14 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) row=irow, col=icol,& block=op_dip(imom)%block,& found=op_found) -CPPostcondition(op_found.and.ASSOCIATED(op_dip(imom)%block),cp_failure_level,routineP,error,failure) +CPPostcondition(op_found.and.ASSOCIATED(op_dip(imom)%block),cp_failure_level,routineP,failure) DO idir = 1,3 NULLIFY(op_dip_der(imom,idir)%block) CALL cp_dbcsr_get_block_p (matrix=op_der(imom,idir)%matrix,& row=irow, col=icol,& block=op_dip_der(imom,idir)%block,& found=op_der_found) -CPPostcondition(op_der_found.and.ASSOCIATED(op_dip_der(imom,idir)%block),cp_failure_level,routineP,error,failure) +CPPostcondition(op_der_found.and.ASSOCIATED(op_dip_der(imom,idir)%block),cp_failure_level,routineP,failure) END DO ! idir END DO ! imom END IF ! new_atom_b @@ -1645,7 +1625,7 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) ALLOCATE(mab_tmp(npgfa(iset)*ncoset(la_max(iset)+1),& npgfb(jset)*ncoset(lb_max(jset)+1),ncoset(order)-1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) lda_min = MAX ( 0, la_min(iset)-1) ldb_min = MAX ( 0, lb_min(jset)-1) @@ -1708,7 +1688,7 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) END DO ! imom DEALLOCATE(mab_tmp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! >= dab END DO ! jset @@ -1722,10 +1702,10 @@ SUBROUTINE rRc_xyz_der_ao(op,op_der,qs_env,rc,order,minimum_image,soft,error) NULLIFY(op_dip(i)%block) END DO DEALLOCATE(op_dip,op_dip_der, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(mab,difmab,work,basis_set_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/qs_ot.F b/src/qs_ot.F index 1fb0594fa9..c14aeb44e7 100644 --- a/src/qs_ot.F +++ b/src/qs_ot.F @@ -70,12 +70,10 @@ MODULE qs_ot !> \brief ... !> \param qs_ot_env ... !> \param preconditioner ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_new_preconditioner(qs_ot_env,preconditioner,error) + SUBROUTINE qs_ot_new_preconditioner(qs_ot_env,preconditioner) TYPE(qs_ot_type) :: qs_ot_env TYPE(preconditioner_type), POINTER :: preconditioner - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_new_preconditioner', & routineP = moduleN//':'//routineN @@ -88,24 +86,24 @@ SUBROUTINE qs_ot_new_preconditioner(qs_ot_env,preconditioner,error) qs_ot_env%preconditioner => preconditioner qs_ot_env%os_valid = .FALSE. IF (.NOT. ASSOCIATED(qs_ot_env%matrix_psc0)) THEN - CALL cp_dbcsr_init_p(qs_ot_env%matrix_psc0, error=error) - CALL cp_dbcsr_copy(qs_ot_env%matrix_psc0,qs_ot_env%matrix_sc0,'matrix_psc0',error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_psc0) + CALL cp_dbcsr_copy(qs_ot_env%matrix_psc0,qs_ot_env%matrix_sc0,'matrix_psc0') ENDIF mixed_precision = qs_ot_env%settings%mixed_precision IF (.NOT. qs_ot_env%use_dx) THEN qs_ot_env%use_dx=.TRUE. - CALL cp_dbcsr_init_p(qs_ot_env%matrix_dx, error=error) - CALL cp_dbcsr_copy(qs_ot_env%matrix_dx,qs_ot_env%matrix_gx,'matrix_dx',error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_dx) + CALL cp_dbcsr_copy(qs_ot_env%matrix_dx,qs_ot_env%matrix_gx,'matrix_dx') IF (qs_ot_env%settings%do_rotation) THEN - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_dx, error=error) - CALL cp_dbcsr_copy(qs_ot_env%rot_mat_dx,qs_ot_env%rot_mat_gx,'rot_mat_dx',error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_dx) + CALL cp_dbcsr_copy(qs_ot_env%rot_mat_dx,qs_ot_env%rot_mat_gx,'rot_mat_dx') ENDIF IF (qs_ot_env%settings%do_ener) THEN ncoef = SIZE ( qs_ot_env % ener_gx) ALLOCATE ( qs_ot_env%ener_dx ( ncoef ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qs_ot_env%ener_dx = 0.0_dp ENDIF ENDIF @@ -119,13 +117,11 @@ END SUBROUTINE qs_ot_new_preconditioner !> \param SC ... !> \param G_OLD ... !> \param D ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_on_the_fly_localize(qs_ot_env, C_NEW, SC, G_OLD, D, error) + SUBROUTINE qs_ot_on_the_fly_localize(qs_ot_env, C_NEW, SC, G_OLD, D) ! TYPE(qs_ot_type) :: qs_ot_env TYPE(cp_dbcsr_type), POINTER :: C_NEW, SC, G_OLD, D - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_on_the_fly_localize', & routineP = moduleN//':'//routineN @@ -159,7 +155,7 @@ SUBROUTINE qs_ot_on_the_fly_localize(qs_ot_env, C_NEW, SC, G_OLD, D, error) !------------------------------------------------------------------- ! (x^2+eps)^1/2 f2 = 0.0_dp - CALL cp_dbcsr_copy(C,C_NEW,error=error) + CALL cp_dbcsr_copy(C,C_NEW) CALL cp_dbcsr_iterator_start(iter, C) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) CALL cp_dbcsr_iterator_next_block(iter, row, col, DATA, blk,& @@ -174,19 +170,18 @@ SUBROUTINE qs_ot_on_the_fly_localize(qs_ot_env, C_NEW, SC, G_OLD, D, error) ENDDO CALL cp_dbcsr_iterator_stop(iter) CALL mp_sum(f2,dbcsr_mp_group(dbcsr_distribution_mp(cp_dbcsr_distribution(C)))) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) IF(output_unit>0) WRITE(output_unit,*) routineN//' f2 =',f2 ! ! - CALL cp_dbcsr_multiply('T','N',1.0_dp,C,C_NEW,0.0_dp,GU,error=error) + CALL cp_dbcsr_multiply('T','N',1.0_dp,C,C_NEW,0.0_dp,GU) ! ! antisymetrize CALL cp_dbcsr_transposed (U, GU, shallow_data_copy=.FALSE., & use_distribution=cp_dbcsr_distribution(GU), & - transpose_distribution=.FALSE., & - error=error) - CALL cp_dbcsr_add(GU,U,alpha_scalar=-0.5_dp,beta_scalar=0.5_dp,error=error) + transpose_distribution=.FALSE.) + CALL cp_dbcsr_add(GU,U,alpha_scalar=-0.5_dp,beta_scalar=0.5_dp) !------------------------------------------------------------------- ! norm_fro = cp_dbcsr_frobenius_norm(GU) @@ -198,44 +193,44 @@ SUBROUTINE qs_ot_on_the_fly_localize(qs_ot_env, C_NEW, SC, G_OLD, D, error) !write(*,*) 'qs_ot_localize: scale=',scale,' kscale=',kscale ! ! rescale for steepest descent - CALL cp_dbcsr_scale(GU, -alpha, error=error) + CALL cp_dbcsr_scale(GU, -alpha) ! ! compute unitary transform ! zeroth and first order expfactor = 1.0_dp - CALL cp_dbcsr_copy(U,GU,error=error) - CALL cp_dbcsr_scale(U,expfactor,error=error) - CALL cp_dbcsr_add_on_diag(U,1.0_dp,error=error) + CALL cp_dbcsr_copy(U,GU) + CALL cp_dbcsr_scale(U,expfactor) + CALL cp_dbcsr_add_on_diag(U,1.0_dp) ! other orders - CALL cp_dbcsr_copy(Gp1,GU,error=error) + CALL cp_dbcsr_copy(Gp1,GU) DO i = 2,taylor_order ! new power of G - CALL cp_dbcsr_multiply('N','N',1.0_dp,GU,Gp1,0.0_dp,Gp2,error=error) - CALL cp_dbcsr_copy(Gp1,Gp2,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,GU,Gp1,0.0_dp,Gp2) + CALL cp_dbcsr_copy(Gp1,Gp2) ! add to the taylor expansion so far expfactor = expfactor / REAL(i,KIND=dp) - CALL cp_dbcsr_add(U,Gp1,alpha_scalar=1.0_dp,beta_scalar=expfactor,error=error) + CALL cp_dbcsr_add(U,Gp1,alpha_scalar=1.0_dp,beta_scalar=expfactor) norm_fro = cp_dbcsr_frobenius_norm(Gp1) !write(*,*) 'Taylor expansion i=',i,' norm(X^i)/i!=',norm_fro*expfactor IF(norm_fro*expfactor.LT.1.0E-10_dp) EXIT ENDDO ! ! rotate MOs - CALL cp_dbcsr_multiply('N','N',1.0_dp,C_NEW,U,0.0_dp,C,error=error) - CALL cp_dbcsr_copy(C_NEW,C,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,C_NEW,U,0.0_dp,C) + CALL cp_dbcsr_copy(C_NEW,C) ! ! rotate SC - CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,U,0.0_dp,C,error=error) - CALL cp_dbcsr_copy(SC,C,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,U,0.0_dp,C) + CALL cp_dbcsr_copy(SC,C) ! ! rotate D_i - CALL cp_dbcsr_multiply('N','N',1.0_dp,D,U,0.0_dp,C,error=error) - CALL cp_dbcsr_copy(D,C,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,D,U,0.0_dp,C) + CALL cp_dbcsr_copy(D,C) ! ! rotate G_i-1 IF(ASSOCIATED(G_OLD)) THEN - CALL cp_dbcsr_multiply('N','N',1.0_dp,G_OLD,U,0.0_dp,C,error=error) - CALL cp_dbcsr_copy(G_OLD,C,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,G_OLD,U,0.0_dp,C) + CALL cp_dbcsr_copy(G_OLD,C) ENDIF ! CALL timestop(handle) @@ -250,14 +245,12 @@ END SUBROUTINE qs_ot_on_the_fly_localize !> \param P ... !> \param SC ... !> \param update ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_ref_chol(qs_ot_env, C_OLD, C_TMP, C_NEW, P, SC, update, error) + SUBROUTINE qs_ot_ref_chol(qs_ot_env, C_OLD, C_TMP, C_NEW, P, SC, update) ! TYPE(qs_ot_type) :: qs_ot_env TYPE(cp_dbcsr_type) :: C_OLD, C_TMP, C_NEW, P, SC LOGICAL, INTENT(IN) :: update - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_ref_chol', & routineP = moduleN//':'//routineN @@ -269,18 +262,17 @@ SUBROUTINE qs_ot_ref_chol(qs_ot_env, C_OLD, C_TMP, C_NEW, P, SC, update, error) CALL cp_dbcsr_get_info(C_NEW,nfullrows_total=n,nfullcols_total=k) ! ! P = U'*U - CALL cp_dbcsr_cholesky_decompose(P,k,qs_ot_env%para_env,qs_ot_env%blacs_env,error=error) + CALL cp_dbcsr_cholesky_decompose(P,k,qs_ot_env%para_env,qs_ot_env%blacs_env) ! ! C_NEW = C_OLD*inv(U) CALL cp_dbcsr_cholesky_restore(C_OLD,k,P,C_NEW,op="SOLVE",pos="RIGHT",& - transa="N",para_env=qs_ot_env%para_env,blacs_env=qs_ot_env%blacs_env,& - error=error) + transa="N",para_env=qs_ot_env%para_env,blacs_env=qs_ot_env%blacs_env) ! ! Update SC if needed IF(update) THEN CALL cp_dbcsr_cholesky_restore(SC,k,P,C_TMP,op="SOLVE",pos="RIGHT",& - transa="N",para_env=qs_ot_env%para_env,blacs_env=qs_ot_env%blacs_env,error=error) - CALL cp_dbcsr_copy(SC,C_TMP,error=error) + transa="N",para_env=qs_ot_env%para_env,blacs_env=qs_ot_env%blacs_env) + CALL cp_dbcsr_copy(SC,C_TMP) ENDIF ! CALL timestop(handle) @@ -295,14 +287,12 @@ END SUBROUTINE qs_ot_ref_chol !> \param P ... !> \param SC ... !> \param update ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_ref_lwdn(qs_ot_env, C_OLD, C_TMP, C_NEW, P, SC, update, error) + SUBROUTINE qs_ot_ref_lwdn(qs_ot_env, C_OLD, C_TMP, C_NEW, P, SC, update) ! TYPE(qs_ot_type) :: qs_ot_env TYPE(cp_dbcsr_type) :: C_OLD, C_TMP, C_NEW, P, SC LOGICAL, INTENT(IN) :: update - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_ref_lwdn', & routineP = moduleN//':'//routineN @@ -321,9 +311,9 @@ SUBROUTINE qs_ot_ref_lwdn(qs_ot_env, C_OLD, C_TMP, C_NEW, P, SC, update, error) V => qs_ot_env%buf1_k_k_nosym ! a buffer W => qs_ot_env%buf2_k_k_nosym ! a buffer ALLOCATE(eig(k), fun(k), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! - CALL cp_dbcsr_syevd(P,V,eig,qs_ot_env%para_env,qs_ot_env%blacs_env,error=error) + CALL cp_dbcsr_syevd(P,V,eig,qs_ot_env%para_env,qs_ot_env%blacs_env) ! ! compute the P^(-1/2) DO i = 1,k @@ -335,21 +325,21 @@ SUBROUTINE qs_ot_ref_lwdn(qs_ot_env, C_OLD, C_TMP, C_NEW, P, SC, update, error) fun(i)=1.0_dp/SQRT(eig(i)) ENDIF ENDDO - CALL cp_dbcsr_copy(W,V,error=error) - CALL cp_dbcsr_scale_by_vector(V,alpha=fun,side='right',error=error) - CALL cp_dbcsr_multiply('N','T',1.0_dp,W,V,0.0_dp,P,error=error) + CALL cp_dbcsr_copy(W,V) + CALL cp_dbcsr_scale_by_vector(V,alpha=fun,side='right') + CALL cp_dbcsr_multiply('N','T',1.0_dp,W,V,0.0_dp,P) ! ! Update C - CALL cp_dbcsr_multiply('N','N',1.0_dp,C_OLD,P,0.0_dp,C_NEW,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,C_OLD,P,0.0_dp,C_NEW) ! ! Update SC if needed IF(update) THEN - CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,P,0.0_dp,C_TMP,error=error) - CALL cp_dbcsr_copy(SC,C_TMP,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,P,0.0_dp,C_TMP) + CALL cp_dbcsr_copy(SC,C_TMP) ENDIF ! DEALLOCATE(eig, fun, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! CALL timestop(handle) END SUBROUTINE qs_ot_ref_lwdn @@ -365,9 +355,8 @@ END SUBROUTINE qs_ot_ref_lwdn !> \param norm_in ... !> \param update ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm_in,update,output_unit,error) + SUBROUTINE qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm_in,update,output_unit) ! TYPE(qs_ot_type) :: qs_ot_env TYPE(cp_dbcsr_type), POINTER :: C_OLD, C_TMP, C_NEW, P @@ -375,7 +364,6 @@ SUBROUTINE qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm_in,update,output REAL(dp), INTENT(IN) :: norm_in LOGICAL, INTENT(IN) :: update INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_ref_poly', & routineP = moduleN//':'//routineN @@ -411,27 +399,27 @@ SUBROUTINE qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm_in,update,output IF(norm.GT.1.0_dp) THEN IF(output_unit>0) WRITE(output_unit,'(A,I3,A)') & routineN,irefine,': we rescale (C+a*D)' - CALL cp_dbcsr_scale(P,1.0_dp/norm,error=error) + CALL cp_dbcsr_scale(P,1.0_dp/norm) rescale = rescale/SQRT(norm) ENDIF ! ! get the refinement polynomial CALL qs_ot_refine(P, FY, BUF1, BUF2, qs_ot_env%settings%irac_degree, & - qs_ot_env%settings%eps_irac_filter_matrix, output_unit, error) + qs_ot_env%settings%eps_irac_filter_matrix, output_unit) ! ! collect the transformation IF(irefine.EQ.1) THEN - CALL cp_dbcsr_copy(FT, FY, name='FT', error=error) + CALL cp_dbcsr_copy(FT, FY, name='FT') ELSE - CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, FT, FY, 0.0_dp, BUF1, error=error) + CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, FT, FY, 0.0_dp, BUF1) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(buf1) - CALL cp_dbcsr_filter(buf1,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(buf1,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(buf1) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(BUF1): occ_in',occ_in,' occ_out',occ_out ENDIF - CALL cp_dbcsr_copy(FT, BUF1, name='FT', error=error) + CALL cp_dbcsr_copy(FT, BUF1, name='FT') ENDIF ! ! quick exit if possible @@ -442,28 +430,28 @@ SUBROUTINE qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm_in,update,output ENDIF ! ! P = FY^T * P * FY - CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, P, FY, 0.0_dp, BUF_NOSYM, error=error) + CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, P, FY, 0.0_dp, BUF_NOSYM) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(buf_nosym) - CALL cp_dbcsr_filter(buf_nosym,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(buf_nosym,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(buf_nosym) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(BUF_NOSYM): occ_in',occ_in,' occ_out',occ_out ENDIF - CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, FY, BUF_NOSYM, 0.0_dp, P, error=error) + CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, FY, BUF_NOSYM, 0.0_dp, P) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(p) - CALL cp_dbcsr_filter(p,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(p,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(p) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(P): occ_in',occ_in,' occ_out',occ_out ENDIF ! ! check ||P-1||_gct - CALL cp_dbcsr_add_on_diag(P, -1.0_dp, error=error) + CALL cp_dbcsr_add_on_diag(P, -1.0_dp) norm_fro = cp_dbcsr_frobenius_norm(P) norm_gct = cp_dbcsr_gershgorin_norm(P) - CALL cp_dbcsr_add_on_diag(P, 1.0_dp, error=error) + CALL cp_dbcsr_add_on_diag(P, 1.0_dp) norm = MIN(norm_gct,norm_fro) ! ! printing @@ -487,10 +475,10 @@ SUBROUTINE qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm_in,update,output ENDDO ! ! C_NEW = C_NEW * FT * rescale - CALL cp_dbcsr_multiply('N', 'N', rescale, C_OLD, FT, 0.0_dp, C_NEW, error=error) + CALL cp_dbcsr_multiply('N', 'N', rescale, C_OLD, FT, 0.0_dp, C_NEW) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(c_new) - CALL cp_dbcsr_filter(c_new,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(c_new,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(c_new) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(C_NEW): occ_in',occ_in,' occ_out',occ_out @@ -498,15 +486,15 @@ SUBROUTINE qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm_in,update,output ! ! update SC = SC * FY * rescale IF(update) THEN - CALL cp_dbcsr_multiply('N', 'N', rescale, SC, FT, 0.0_dp, C_TMP, error=error) + CALL cp_dbcsr_multiply('N', 'N', rescale, SC, FT, 0.0_dp, C_TMP) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(c_tmp) - CALL cp_dbcsr_filter(c_tmp,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(c_tmp,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(c_tmp) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(C_TMP): occ_in',occ_in,' occ_out',occ_out ENDIF - CALL cp_dbcsr_copy(SC, C_TMP, error=error) + CALL cp_dbcsr_copy(SC, C_TMP) ENDIF ! CALL timestop(handle) @@ -568,18 +556,16 @@ END SUBROUTINE qs_ot_ref_decide !> \param qs_ot_env ... !> \param qs_ot_env1 ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_ot_get_orbitals_ref(matrix_c, matrix_s, matrix_x, matrix_sx, & matrix_gx_old, matrix_dx, qs_ot_env, & - qs_ot_env1, output_unit, error) + qs_ot_env1, output_unit) ! TYPE(cp_dbcsr_type), POINTER :: matrix_c, matrix_s, matrix_x, & matrix_sx, matrix_gx_old, & matrix_dx TYPE(qs_ot_type) :: qs_ot_env, qs_ot_env1 INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_get_orbitals_ref', & routineP = moduleN//':'//routineN @@ -621,33 +607,33 @@ SUBROUTINE qs_ot_get_orbitals_ref(matrix_c, matrix_s, matrix_x, matrix_sx, & ! ! compute SC = S*C IF(ASSOCIATED(S)) THEN - CALL cp_dbcsr_multiply('N','N',1.0_dp,S,C_OLD,0.0_dp,SC,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,S,C_OLD,0.0_dp,SC) IF (qs_ot_env1%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(sc) - CALL cp_dbcsr_filter(sc,qs_ot_env1%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(sc,qs_ot_env1%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(sc) IF(output_unit>0.AND.qs_ot_env1%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(SC): occ_in',occ_in,' occ_out',occ_out ENDIF ELSE - CALL cp_dbcsr_copy(SC,C_OLD,error=error) + CALL cp_dbcsr_copy(SC,C_OLD) ENDIF ! ! compute P = C'*SC - CALL cp_dbcsr_multiply('T','N',1.0_dp,C_OLD,SC,0.0_dp,P,error=error) + CALL cp_dbcsr_multiply('T','N',1.0_dp,C_OLD,SC,0.0_dp,P) IF (qs_ot_env1%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(p) - CALL cp_dbcsr_filter(p,qs_ot_env1%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(p,qs_ot_env1%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(p) IF(output_unit>0.AND.qs_ot_env1%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(P): occ_in',occ_in,' occ_out',occ_out ENDIF ! ! check ||P-1||_f and ||P-1||_gct - CALL cp_dbcsr_add_on_diag(P, -1.0_dp, error=error) + CALL cp_dbcsr_add_on_diag(P, -1.0_dp) norm_fro = cp_dbcsr_frobenius_norm(P) norm_gct = cp_dbcsr_gershgorin_norm(P) - CALL cp_dbcsr_add_on_diag(P, 1.0_dp, error=error) + CALL cp_dbcsr_add_on_diag(P, 1.0_dp) norm = MIN(norm_gct,norm_fro) CALL qs_ot_ref_decide(qs_ot_env1,norm,ortho_irac) IF(output_unit>0) WRITE(output_unit,'(A,I3,A,E12.5,A)') & @@ -657,11 +643,11 @@ SUBROUTINE qs_ot_get_orbitals_ref(matrix_c, matrix_s, matrix_x, matrix_sx, & ! select the orthogonality method SELECT CASE(ortho_irac) CASE("CHOL") - CALL qs_ot_ref_chol(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,update,error) + CALL qs_ot_ref_chol(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,update) CASE("LWDN") - CALL qs_ot_ref_lwdn(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,update,error) + CALL qs_ot_ref_lwdn(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,update) CASE("POLY") - CALL qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm,update,output_unit,error) + CALL qs_ot_ref_poly(qs_ot_env,C_OLD,C_TMP,C_NEW,P,SC,norm,update,output_unit) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"Wrong argument") END SELECT @@ -671,9 +657,9 @@ SUBROUTINE qs_ot_get_orbitals_ref(matrix_c, matrix_s, matrix_x, matrix_sx, & IF(on_the_fly_loc) THEN IF(output_unit>0) WRITE(output_unit,'(A)') & routineN//' we localize C' - CALL qs_ot_on_the_fly_localize(qs_ot_env,C_NEW,SC,G_OLD,D,error) + CALL qs_ot_on_the_fly_localize(qs_ot_env,C_NEW,SC,G_OLD,D) ENDIF - CALL cp_dbcsr_copy(C_OLD,C_NEW,error=error) + CALL cp_dbcsr_copy(C_OLD,C_NEW) ENDIF ! CALL timestop(handle) @@ -688,9 +674,8 @@ END SUBROUTINE qs_ot_get_orbitals_ref !> \param irac_degree ... !> \param eps_irac_filter_matrix ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_refine(P,FY,P2,T,irac_degree,eps_irac_filter_matrix,output_unit,error) + SUBROUTINE qs_ot_refine(P,FY,P2,T,irac_degree,eps_irac_filter_matrix,output_unit) !---------------------------------------------------------------------- ! refinement polynomial of degree 2,3 and 4 (PRB 70, 193102 (2004)) !---------------------------------------------------------------------- @@ -699,7 +684,6 @@ SUBROUTINE qs_ot_refine(P,FY,P2,T,irac_degree,eps_irac_filter_matrix,output_unit INTEGER, INTENT(in) :: irac_degree REAL(dp), INTENT(in) :: eps_irac_filter_matrix INTEGER, INTENT(in) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_refine', & routineP = moduleN//':'//routineN @@ -714,72 +698,72 @@ SUBROUTINE qs_ot_refine(P,FY,P2,T,irac_degree,eps_irac_filter_matrix,output_unit CASE(2) ! C_out = C_in * ( 15/8 * I - 10/8 * P + 3/8 * P^2) r = 3.0_dp/8.0_dp - CALL cp_dbcsr_multiply('N', 'N', r, P, P, 0.0_dp, FY, error=error) + CALL cp_dbcsr_multiply('N', 'N', r, P, P, 0.0_dp, FY) IF (eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(fy) - CALL cp_dbcsr_filter(fy,eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(fy,eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(fy) IF(output_unit>0.AND.eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(FY): occ_in',occ_in,' occ_out',occ_out ENDIF r = -10.0_dp/8.0_dp - CALL cp_dbcsr_add(FY, P, alpha_scalar=1.0_dp, beta_scalar=r, error=error) + CALL cp_dbcsr_add(FY, P, alpha_scalar=1.0_dp, beta_scalar=r) r = 15.0_dp/8.0_dp - CALL cp_dbcsr_add_on_diag(FY, alpha_scalar=r, error=error) + CALL cp_dbcsr_add_on_diag(FY, alpha_scalar=r) CASE(3) ! C_out = C_in * ( 35/16 * I - 35/16 * P + 21/16 * P^2 - 5/16 P^3) - CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, P, P, 0.0_dp, P2, error=error) + CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, P, P, 0.0_dp, P2) IF (eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(p2) - CALL cp_dbcsr_filter(p2,eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(p2,eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(p2) IF(output_unit>0.AND.eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(P2): occ_in',occ_in,' occ_out',occ_out ENDIF r = -5.0_dp/16.0_dp - CALL cp_dbcsr_multiply('N', 'N', r, P2, P, 0.0_dp, FY, error=error) + CALL cp_dbcsr_multiply('N', 'N', r, P2, P, 0.0_dp, FY) IF (eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(fy) - CALL cp_dbcsr_filter(fy,eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(fy,eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(fy) IF(output_unit>0.AND.eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(FY): occ_in',occ_in,' occ_out',occ_out ENDIF r = 21.0_dp/16.0_dp - CALL cp_dbcsr_add(FY, P2, alpha_scalar=1.0_dp, beta_scalar=r, error=error) + CALL cp_dbcsr_add(FY, P2, alpha_scalar=1.0_dp, beta_scalar=r) r = -35.0_dp/16.0_dp - CALL cp_dbcsr_add(FY, P, alpha_scalar=1.0_dp, beta_scalar=r, error=error) + CALL cp_dbcsr_add(FY, P, alpha_scalar=1.0_dp, beta_scalar=r) r = 35.0_dp/16.0_dp - CALL cp_dbcsr_add_on_diag(FY, alpha_scalar=r, error=error) + CALL cp_dbcsr_add_on_diag(FY, alpha_scalar=r) CASE(4) ! C_out = C_in * ( 315/128 * I - 420/128 * P + 378/128 * P^2 - 180/128 P^3 + 35/128 P^4 ) ! = C_in * ( 315/128 * I - 420/128 * P + 378/128 * P^2 + ( - 180/128 * P + 35/128 * P^2 ) * P^2 ) - CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, P, P, 0.0_dp, P2, error=error) ! P^2 + CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, P, P, 0.0_dp, P2) ! P^2 IF (eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(p2) - CALL cp_dbcsr_filter(p2,eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(p2,eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(p2) IF(output_unit>0.AND.eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(P2): occ_in',occ_in,' occ_out',occ_out ENDIF r = -180.0_dp/128.0_dp - CALL cp_dbcsr_add(T, P, alpha_scalar=0.0_dp, beta_scalar=r, error=error) ! T=-180/128*P + CALL cp_dbcsr_add(T, P, alpha_scalar=0.0_dp, beta_scalar=r) ! T=-180/128*P r = 35.0_dp/128.0_dp - CALL cp_dbcsr_add(T, P2, alpha_scalar=1.0_dp, beta_scalar=r, error=error) ! T=T+35/128*P^2 - CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, T, P2, 0.0_dp, FY, error=error) ! Y=T*P^2 + CALL cp_dbcsr_add(T, P2, alpha_scalar=1.0_dp, beta_scalar=r) ! T=T+35/128*P^2 + CALL cp_dbcsr_multiply('N', 'N', 1.0_dp, T, P2, 0.0_dp, FY) ! Y=T*P^2 IF (eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(fy) - CALL cp_dbcsr_filter(fy,eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(fy,eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(fy) IF(output_unit>0.AND.eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(FY): occ_in',occ_in,' occ_out',occ_out ENDIF r = 378.0_dp/128.0_dp - CALL cp_dbcsr_add(FY, P2, alpha_scalar=1.0_dp, beta_scalar=r, error=error)! Y=Y+378/128*P^2 + CALL cp_dbcsr_add(FY, P2, alpha_scalar=1.0_dp, beta_scalar=r)! Y=Y+378/128*P^2 r = -420.0_dp/128.0_dp - CALL cp_dbcsr_add(FY, P, alpha_scalar=1.0_dp, beta_scalar=r, error=error) ! Y=Y-420/128*P + CALL cp_dbcsr_add(FY, P, alpha_scalar=1.0_dp, beta_scalar=r) ! Y=Y-420/128*P r = 315.0_dp/128.0_dp - CALL cp_dbcsr_add_on_diag(FY, alpha_scalar=r, error=error) ! Y=Y+315/128*I + CALL cp_dbcsr_add_on_diag(FY, alpha_scalar=r) ! Y=Y+315/128*I CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"This irac_order NYI") END SELECT @@ -795,15 +779,13 @@ END SUBROUTINE qs_ot_refine !> \param matrix_gx ... !> \param qs_ot_env ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_ot_get_derivative_ref(matrix_hc,matrix_x,matrix_sx,matrix_gx, & - qs_ot_env,output_unit,error) + qs_ot_env,output_unit) TYPE(cp_dbcsr_type), POINTER :: matrix_hc, matrix_x, & matrix_sx, matrix_gx TYPE(qs_ot_type) :: qs_ot_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_get_derivative_ref', & routineP = moduleN//':'//routineN @@ -827,47 +809,47 @@ SUBROUTINE qs_ot_get_derivative_ref(matrix_hc,matrix_x,matrix_sx,matrix_gx, & IF(mixed_precision) THEN ! C'*(H*C) - CALL cp_dbcsr_multiply('T','N',1.0_dp,C,HC,0.0_dp,CHC,error=error) + CALL cp_dbcsr_multiply('T','N',1.0_dp,C,HC,0.0_dp,CHC) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(chc) - CALL cp_dbcsr_filter(chc,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(chc,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(chc) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(CHC): occ_in',occ_in,' occ_out',occ_out ENDIF ! (S*C)*(C'*H*C) - CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,CHC,0.0_dp,G_dp,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,CHC,0.0_dp,G_dp) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(g_dp) - CALL cp_dbcsr_filter(g_dp,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(g_dp,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(g_dp) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(G_dp): occ_in',occ_in,' occ_out',occ_out ENDIF ! G = 2*(1-S*C*C')*H*C - CALL cp_dbcsr_add(G_dp,HC,alpha_scalar=-1.0_dp,beta_scalar=1.0_dp,error=error) - CALL cp_dbcsr_copy(G,G_dp,error=error) + CALL cp_dbcsr_add(G_dp,HC,alpha_scalar=-1.0_dp,beta_scalar=1.0_dp) + CALL cp_dbcsr_copy(G,G_dp) ELSE ! C'*(H*C) - CALL cp_dbcsr_multiply('T','N',1.0_dp,C,HC,0.0_dp,CHC,error=error) + CALL cp_dbcsr_multiply('T','N',1.0_dp,C,HC,0.0_dp,CHC) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(chc) - CALL cp_dbcsr_filter(chc,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(chc,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(chc) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(CHC): occ_in',occ_in,' occ_out',occ_out ENDIF ! (S*C)*(C'*H*C) - CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,CHC,0.0_dp,G,error=error) + CALL cp_dbcsr_multiply('N','N',1.0_dp,SC,CHC,0.0_dp,G) IF (qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) THEN occ_in = cp_dbcsr_get_occupation(g) - CALL cp_dbcsr_filter(g,qs_ot_env%settings%eps_irac_filter_matrix,error=error) + CALL cp_dbcsr_filter(g,qs_ot_env%settings%eps_irac_filter_matrix) occ_out = cp_dbcsr_get_occupation(g) IF(output_unit>0.AND.qs_ot_env%settings%eps_irac_filter_matrix.GT.0.0_dp) & WRITE(output_unit,'(2(A,F8.5))') routinen//' filter(G): occ_in',occ_in,' occ_out',occ_out ENDIF ! G = 2*(1-S*C*C')*H*C - CALL cp_dbcsr_add(G,HC,alpha_scalar=-1.0_dp,beta_scalar=1.0_dp,error=error) + CALL cp_dbcsr_add(G,HC,alpha_scalar=-1.0_dp,beta_scalar=1.0_dp) ENDIF ! CALL timestop(handle) @@ -879,13 +861,11 @@ END SUBROUTINE qs_ot_get_derivative_ref !> \param matrix_x ... !> \param matrix_sx ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_get_p(matrix_x,matrix_sx,qs_ot_env,error) + SUBROUTINE qs_ot_get_p(matrix_x,matrix_sx,qs_ot_env) TYPE(cp_dbcsr_type), POINTER :: matrix_x, matrix_sx TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_get_p', & routineP = moduleN//':'//routineN @@ -901,24 +881,24 @@ SUBROUTINE qs_ot_get_p(matrix_x,matrix_sx,qs_ot_env,error) ! get the overlap CALL cp_dbcsr_multiply('T','N',rone,matrix_x,matrix_sx,rzero,& - qs_ot_env%matrix_p,error=error) + qs_ot_env%matrix_p) ! get an upper bound for the largest eigenvalue ! try using lancos first and fall back to gershgorin norm if it fails max_iter=30; threshold=1.0E-03_dp - CALL cp_dbcsr_arnoldi_extremal(qs_ot_env%matrix_p, max_ev, min_ev, converged, threshold, max_iter, error=error) + CALL cp_dbcsr_arnoldi_extremal(qs_ot_env%matrix_p, max_ev, min_ev, converged, threshold, max_iter) qs_ot_env % largest_eval_upper_bound=MAX(max_ev,ABS(min_ev)) IF(.NOT.converged)qs_ot_env % largest_eval_upper_bound = cp_dbcsr_gershgorin_norm(qs_ot_env%matrix_p) CALL decide_strategy(qs_ot_env) IF (qs_ot_env % do_taylor) THEN - CALL qs_ot_p2m_taylor(qs_ot_env,error=error) + CALL qs_ot_p2m_taylor(qs_ot_env) ELSE - CALL qs_ot_p2m_diag(qs_ot_env,error=error) + CALL qs_ot_p2m_diag(qs_ot_env) ENDIF IF (qs_ot_env % settings % do_rotation) THEN - CALL qs_ot_generate_rotation(qs_ot_env,error=error) + CALL qs_ot_generate_rotation(qs_ot_env) ENDIF CALL timestop(handle) @@ -929,14 +909,12 @@ END SUBROUTINE qs_ot_get_p !> \brief computes the rotation matrix rot_mat_u that is associated to a given !> rot_mat_x using rot_mat_u=exp(rot_mat_x) !> \param qs_ot_env a valid qs_ot_env -!> \param error ... !> \par History !> 08.2004 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE qs_ot_generate_rotation(qs_ot_env,error) + SUBROUTINE qs_ot_generate_rotation(qs_ot_env) TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_generate_rotation', & routineP = moduleN//':'//routineN @@ -957,16 +935,16 @@ SUBROUTINE qs_ot_generate_rotation(qs_ot_env,error) CALL cp_dbcsr_get_info(qs_ot_env%rot_mat_x,nfullrows_total=k) IF (k/=0) THEN - CALL cp_dbcsr_init(cmat_x, error=error) - CALL cp_dbcsr_init(cmat_u, error=error) - CALL cp_dbcsr_copy(cmat_x,qs_ot_env%rot_mat_evec,name='cmat_x',error=error) - CALL cp_dbcsr_copy(cmat_u,qs_ot_env%rot_mat_evec,name='cmat_u',error=error) + CALL cp_dbcsr_init(cmat_x) + CALL cp_dbcsr_init(cmat_u) + CALL cp_dbcsr_copy(cmat_x,qs_ot_env%rot_mat_evec,name='cmat_x') + CALL cp_dbcsr_copy(cmat_u,qs_ot_env%rot_mat_evec,name='cmat_u') ALLOCATE(evals_exp(k)) ! rot_mat_u = exp(rot_mat_x) ! i rot_mat_x is hermitian, so go over the complex variables for diag - !vwCALL cp_cfm_get_info(cmat_x,local_data=local_data_c,error=error) - !vwCALL cp_fm_get_info(qs_ot_env%rot_mat_x,local_data=local_data_r,error=error) + !vwCALL cp_cfm_get_info(cmat_x,local_data=local_data_c) + !vwCALL cp_fm_get_info(qs_ot_env%rot_mat_x,local_data=local_data_r) !vwlocal_data_c=CMPLX(0.0_dp,local_data_r,KIND=dp) CALL cp_dbcsr_iterator_start(iter, cmat_x) DO WHILE (cp_dbcsr_iterator_blocks_left(iter)) @@ -983,14 +961,14 @@ SUBROUTINE qs_ot_generate_rotation(qs_ot_env,error) CALL cp_dbcsr_heevd(cmat_x,qs_ot_env%rot_mat_evec,qs_ot_env%rot_mat_evals,& - qs_ot_env%para_env, qs_ot_env%blacs_env, error=error) + qs_ot_env%para_env, qs_ot_env%blacs_env) evals_exp(:)=EXP( (0.0_dp,-1.0_dp) * qs_ot_env%rot_mat_evals(:) ) - CALL cp_dbcsr_copy(cmat_x,qs_ot_env%rot_mat_evec,error=error) - CALL cp_dbcsr_scale_by_vector(cmat_x,alpha=evals_exp,side='right',error=error) - CALL cp_dbcsr_multiply('N','C',cone,cmat_x,qs_ot_env%rot_mat_evec,czero,cmat_u,error=error) - CALL cp_dbcsr_copy(qs_ot_env%rot_mat_u, cmat_u, keep_imaginary=.FALSE., error=error) - CALL cp_dbcsr_release(cmat_x, error=error) - CALL cp_dbcsr_release(cmat_u, error=error) + CALL cp_dbcsr_copy(cmat_x,qs_ot_env%rot_mat_evec) + CALL cp_dbcsr_scale_by_vector(cmat_x,alpha=evals_exp,side='right') + CALL cp_dbcsr_multiply('N','C',cone,cmat_x,qs_ot_env%rot_mat_evec,czero,cmat_u) + CALL cp_dbcsr_copy(qs_ot_env%rot_mat_u, cmat_u, keep_imaginary=.FALSE.) + CALL cp_dbcsr_release(cmat_x) + CALL cp_dbcsr_release(cmat_u) DEALLOCATE(evals_exp) END IF @@ -1002,13 +980,11 @@ END SUBROUTINE qs_ot_generate_rotation !> \brief computes the derivative fields with respect to rot_mat_x !> \param qs_ot_env valid qs_ot_env. In particular qs_ot_generate_rotation has to be called before !> and the rot_mat_dedu matrix has to be up to date -!> \param error ... !> \par History !> 08.2004 created [ Joost VandeVondele ] ! ***************************************************************************** - SUBROUTINE qs_ot_rot_mat_derivative(qs_ot_env,error) + SUBROUTINE qs_ot_rot_mat_derivative(qs_ot_env) TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_rot_mat_derivative', & routineP = moduleN//':'//routineN @@ -1029,18 +1005,18 @@ SUBROUTINE qs_ot_rot_mat_derivative(qs_ot_env,error) CALL cp_dbcsr_get_info(qs_ot_env%rot_mat_u,nfullrows_total=k) IF (k/=0) THEN - CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%rot_mat_dedu,error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%rot_mat_dedu) ! now we get to the derivative wrt the antisymmetric matrix rot_mat_x - CALL cp_dbcsr_init(cmat_buf1, error=error) - CALL cp_dbcsr_init(cmat_buf2, error=error) - CALL cp_dbcsr_copy(cmat_buf1,qs_ot_env%rot_mat_evec,"cmat_buf1",error=error) - CALL cp_dbcsr_copy(cmat_buf2,qs_ot_env%rot_mat_evec,"cmat_buf2",error=error) + CALL cp_dbcsr_init(cmat_buf1) + CALL cp_dbcsr_init(cmat_buf2) + CALL cp_dbcsr_copy(cmat_buf1,qs_ot_env%rot_mat_evec,"cmat_buf1") + CALL cp_dbcsr_copy(cmat_buf2,qs_ot_env%rot_mat_evec,"cmat_buf2") ! init cmat_buf1 - !CALL cp_fm_get_info(qs_ot_env%matrix_buf1,matrix_struct=fm_struct, local_data=local_data_r,error=error) + !CALL cp_fm_get_info(qs_ot_env%matrix_buf1,matrix_struct=fm_struct, local_data=local_data_r) !CALL cp_cfm_get_info(cmat_buf1, nrow_local=nrow_local, ncol_local=ncol_local, & ! row_indices=row_indices, col_indices=col_indices, & - ! local_data=local_data_c,error=error) + ! local_data=local_data_c) !local_data_c=local_data_r CALL cp_dbcsr_iterator_start(iter, cmat_buf1) @@ -1052,9 +1028,9 @@ SUBROUTINE qs_ot_rot_mat_derivative(qs_ot_env,error) CALL cp_dbcsr_iterator_stop(iter) CALL cp_dbcsr_multiply('T','N',cone,cmat_buf1,qs_ot_env%rot_mat_evec,& - czero,cmat_buf2,error=error) + czero,cmat_buf2) CALL cp_dbcsr_multiply('C','N',cone,qs_ot_env%rot_mat_evec,cmat_buf2,& - czero,cmat_buf1,error=error) + czero,cmat_buf1) CALL cp_dbcsr_iterator_start(iter, cmat_buf1) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) @@ -1072,20 +1048,20 @@ SUBROUTINE qs_ot_rot_mat_derivative(qs_ot_env,error) CALL cp_dbcsr_iterator_stop(iter) CALL cp_dbcsr_multiply('N','N',cone,qs_ot_env%rot_mat_evec,cmat_buf1,& - czero,cmat_buf2,error=error) + czero,cmat_buf2) CALL cp_dbcsr_multiply('N','C',cone,cmat_buf2,qs_ot_env%rot_mat_evec,& - czero,cmat_buf1,error=error) + czero,cmat_buf1) - CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,cmat_buf1,error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,cmat_buf1) CALL cp_dbcsr_transposed(qs_ot_env%matrix_buf2,qs_ot_env%matrix_buf1,& shallow_data_copy=.FALSE., use_distribution=cp_dbcsr_distribution(qs_ot_env%matrix_buf3), & - transpose_distribution=.FALSE.,error=error) + transpose_distribution=.FALSE.) CALL cp_dbcsr_add(qs_ot_env%matrix_buf1,qs_ot_env%matrix_buf2,& - alpha_scalar=-1.0_dp,beta_scalar=+1.0_dp,error=error) - CALL cp_dbcsr_copy(qs_ot_env%rot_mat_gx,qs_ot_env%matrix_buf1,error=error) - CALL cp_dbcsr_release(cmat_buf1, error=error) - CALL cp_dbcsr_release(cmat_buf2, error=error) + alpha_scalar=-1.0_dp,beta_scalar=+1.0_dp) + CALL cp_dbcsr_copy(qs_ot_env%rot_mat_gx,qs_ot_env%matrix_buf1) + CALL cp_dbcsr_release(cmat_buf1) + CALL cp_dbcsr_release(cmat_buf2) END IF CALL timestop(handle) CONTAINS @@ -1158,13 +1134,11 @@ END SUBROUTINE decide_strategy !> \param matrix_c ... !> \param matrix_x ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_get_orbitals(matrix_c, matrix_x, qs_ot_env, error) + SUBROUTINE qs_ot_get_orbitals(matrix_c, matrix_x, qs_ot_env) TYPE(cp_dbcsr_type), POINTER :: matrix_c, matrix_x TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_get_orbitals', & routineP = moduleN//':'//routineN @@ -1182,23 +1156,23 @@ SUBROUTINE qs_ot_get_orbitals(matrix_c, matrix_x, qs_ot_env, error) IF (qs_ot_env%settings%do_rotation) THEN matrix_kk => qs_ot_env%matrix_buf1 CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_cosp, & - qs_ot_env%rot_mat_u,rzero,matrix_kk,error=error) + qs_ot_env%rot_mat_u,rzero,matrix_kk) ELSE matrix_kk => qs_ot_env%matrix_cosp ENDIF CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_c0,matrix_kk, & - rzero,matrix_c,error=error) + rzero,matrix_c) IF (qs_ot_env%settings%do_rotation) THEN matrix_kk => qs_ot_env%matrix_buf1 CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_sinp, & - qs_ot_env%rot_mat_u,rzero,matrix_kk,error=error) + qs_ot_env%rot_mat_u,rzero,matrix_kk) ELSE matrix_kk => qs_ot_env%matrix_sinp ENDIF CALL cp_dbcsr_multiply('N','N',rone,matrix_x,matrix_kk, & - rone ,matrix_c,error=error) + rone ,matrix_c) CALL timestop(handle) @@ -1216,14 +1190,12 @@ END SUBROUTINE qs_ot_get_orbitals !> \param matrix_sx ... !> \param matrix_gx ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_ot_get_derivative(matrix_hc,matrix_x,matrix_sx,matrix_gx, & - qs_ot_env,error) + qs_ot_env) TYPE(cp_dbcsr_type), POINTER :: matrix_hc, matrix_x, & matrix_sx, matrix_gx TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_get_derivative', & routineP = moduleN//':'//routineN @@ -1242,19 +1214,19 @@ SUBROUTINE qs_ot_get_derivative(matrix_hc,matrix_x,matrix_sx,matrix_gx, & ! create a local rotated version of matrix_hc leaving matrix_hc untouched (needed ! for lagrangian multipliers) IF (qs_ot_env % settings % do_rotation) THEN - CALL cp_dbcsr_copy(matrix_gx,matrix_hc,error=error) ! use gx as temporary - CALL cp_dbcsr_init_p(matrix_hc_local, error=error) - CALL cp_dbcsr_copy(matrix_hc_local,matrix_hc,name='matrix_hc_local',error=error) - CALL cp_dbcsr_set(matrix_hc_local,0.0_dp,error=error) - CALL cp_dbcsr_multiply('N','T',rone,matrix_gx,qs_ot_env%rot_mat_u,rzero,matrix_hc_local,error=error) + CALL cp_dbcsr_copy(matrix_gx,matrix_hc) ! use gx as temporary + CALL cp_dbcsr_init_p(matrix_hc_local) + CALL cp_dbcsr_copy(matrix_hc_local,matrix_hc,name='matrix_hc_local') + CALL cp_dbcsr_set(matrix_hc_local,0.0_dp) + CALL cp_dbcsr_multiply('N','T',rone,matrix_gx,qs_ot_env%rot_mat_u,rzero,matrix_hc_local) ELSE matrix_hc_local=>matrix_hc ENDIF IF (qs_ot_env % do_taylor) THEN - CALL qs_ot_get_derivative_taylor(matrix_hc_local,matrix_x,matrix_sx,matrix_gx,qs_ot_env,error=error) + CALL qs_ot_get_derivative_taylor(matrix_hc_local,matrix_x,matrix_sx,matrix_gx,qs_ot_env) ELSE - CALL qs_ot_get_derivative_diag(matrix_hc_local,matrix_x,matrix_sx,matrix_gx,qs_ot_env,error=error) + CALL qs_ot_get_derivative_diag(matrix_hc_local,matrix_x,matrix_sx,matrix_gx,qs_ot_env) ENDIF ! and make it orthogonal @@ -1272,32 +1244,31 @@ SUBROUTINE qs_ot_get_derivative(matrix_hc,matrix_x,matrix_sx,matrix_gx, & IF (ASSOCIATED(qs_ot_env%preconditioner)) THEN CALL apply_preconditioner(qs_ot_env%preconditioner, qs_ot_env%matrix_sc0, & - qs_ot_env%matrix_psc0 ,error=error) + qs_ot_env%matrix_psc0) ENDIF CALL cp_dbcsr_multiply('T','N',rone,& qs_ot_env%matrix_sc0,matrix_target, & - rzero,qs_ot_env%matrix_os,& - error=error) + rzero,qs_ot_env%matrix_os) CALL cp_dbcsr_cholesky_decompose(qs_ot_env%matrix_os,& - para_env=qs_ot_env%para_env,blacs_env=qs_ot_env%blacs_env,error=error) + para_env=qs_ot_env%para_env,blacs_env=qs_ot_env%blacs_env) CALL cp_dbcsr_cholesky_invert(qs_ot_env%matrix_os,& para_env=qs_ot_env%para_env,blacs_env=qs_ot_env%blacs_env,& - upper_to_full=.TRUE.,error=error) + upper_to_full=.TRUE.) qs_ot_env%os_valid=.TRUE. ENDIF CALL cp_dbcsr_multiply('T','N',rone,matrix_target,matrix_gx, & - rzero,qs_ot_env%matrix_buf1_ortho, error=error) + rzero,qs_ot_env%matrix_buf1_ortho) CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_os,& - qs_ot_env%matrix_buf1_ortho, rzero,qs_ot_env%matrix_buf2_ortho,error=error) + qs_ot_env%matrix_buf1_ortho, rzero,qs_ot_env%matrix_buf2_ortho) CALL cp_dbcsr_multiply('N','N',-rone,qs_ot_env%matrix_sc0, & - qs_ot_env%matrix_buf2_ortho, rone,matrix_gx,error=error) + qs_ot_env%matrix_buf2_ortho, rone,matrix_gx) ! also treat the rot_mat gradient here IF (qs_ot_env%settings%do_rotation) THEN - CALL qs_ot_rot_mat_derivative(qs_ot_env,error=error) + CALL qs_ot_rot_mat_derivative(qs_ot_env) ENDIF IF (qs_ot_env % settings % do_rotation) THEN - CALL cp_dbcsr_release_p(matrix_hc_local, error=error) + CALL cp_dbcsr_release_p(matrix_hc_local) ENDIF CALL timestop(handle) @@ -1311,15 +1282,13 @@ END SUBROUTINE qs_ot_get_derivative !> \param matrix_sx ... !> \param matrix_gx ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_ot_get_derivative_diag(matrix_hc,matrix_x,matrix_sx,matrix_gx, & - qs_ot_env,error) + qs_ot_env) TYPE(cp_dbcsr_type), POINTER :: matrix_hc, matrix_x, & matrix_sx, matrix_gx TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_get_derivative_diag', & routineP = moduleN//':'//routineN @@ -1333,51 +1302,49 @@ SUBROUTINE qs_ot_get_derivative_diag(matrix_hc,matrix_x,matrix_sx,matrix_gx, & ! go for the derivative now ! this de/dc*(dX/dx)*sinp - CALL cp_dbcsr_multiply('N','N',rone,matrix_hc,qs_ot_env%matrix_sinp,rzero,matrix_gx,& - error=error) + CALL cp_dbcsr_multiply('N','N',rone,matrix_hc,qs_ot_env%matrix_sinp,rzero,matrix_gx) ! overlap hc*x - CALL cp_dbcsr_multiply('T','N',rone,matrix_hc,matrix_x,rzero,qs_ot_env%matrix_buf2,& - error=error) + CALL cp_dbcsr_multiply('T','N',rone,matrix_hc,matrix_x,rzero,qs_ot_env%matrix_buf2) ! get it in the basis of the eigenvectors CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_buf2,qs_ot_env%matrix_r,& - rzero,qs_ot_env%matrix_buf1,error=error) + rzero,qs_ot_env%matrix_buf1) CALL cp_dbcsr_multiply('T','N',rone,qs_ot_env%matrix_r,qs_ot_env%matrix_buf1, & - rzero,qs_ot_env%matrix_buf2,error=error) + rzero,qs_ot_env%matrix_buf2) ! get the schur product of O_uv*B_uv CALL cp_dbcsr_hadamard_product(qs_ot_env%matrix_buf2,qs_ot_env%matrix_sinp_b, & - qs_ot_env%matrix_buf3,error=error) + qs_ot_env%matrix_buf3) ! overlap hc*c0 CALL cp_dbcsr_multiply('T','N',rone,matrix_hc,qs_ot_env%matrix_c0,rzero, & - qs_ot_env%matrix_buf2,error=error) + qs_ot_env%matrix_buf2) ! get it in the basis of the eigenvectors CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_buf2,qs_ot_env%matrix_r, & - rzero,qs_ot_env%matrix_buf1,error=error) + rzero,qs_ot_env%matrix_buf1) CALL cp_dbcsr_multiply('T','N',rone,qs_ot_env%matrix_r, qs_ot_env%matrix_buf1, & - rzero,qs_ot_env%matrix_buf2,error=error) + rzero,qs_ot_env%matrix_buf2) CALL cp_dbcsr_hadamard_product(qs_ot_env%matrix_buf2,qs_ot_env%matrix_cosp_b, & - qs_ot_env%matrix_buf4,error=error) + qs_ot_env%matrix_buf4) ! add the two bs and compute b+b^T CALL cp_dbcsr_add(qs_ot_env%matrix_buf3,qs_ot_env%matrix_buf4,& - alpha_scalar=rone,beta_scalar=rone,error=error) + alpha_scalar=rone,beta_scalar=rone) ! get the b in the eigenvector basis CALL cp_dbcsr_multiply('N','T',rone,qs_ot_env%matrix_buf3,qs_ot_env%matrix_r, & - rzero,qs_ot_env%matrix_buf1,error=error) + rzero,qs_ot_env%matrix_buf1) CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_r,qs_ot_env%matrix_buf1, & - rzero,qs_ot_env%matrix_buf3,error=error) + rzero,qs_ot_env%matrix_buf3) CALL cp_dbcsr_transposed(qs_ot_env%matrix_buf1,qs_ot_env%matrix_buf3,& shallow_data_copy=.FALSE., use_distribution=cp_dbcsr_distribution(qs_ot_env%matrix_buf3), & - transpose_distribution=.FALSE.,error=error) + transpose_distribution=.FALSE.) CALL cp_dbcsr_add(qs_ot_env%matrix_buf3,qs_ot_env%matrix_buf1,& - alpha_scalar=rone,beta_scalar=rone,error=error) + alpha_scalar=rone,beta_scalar=rone) ! and add to the derivative CALL cp_dbcsr_multiply('N','N',rone,matrix_sx,qs_ot_env%matrix_buf3, & - rone,matrix_gx,error=error) + rone,matrix_gx) CALL timestop(handle) END SUBROUTINE qs_ot_get_derivative_diag @@ -1390,15 +1357,13 @@ END SUBROUTINE qs_ot_get_derivative_diag !> \param matrix_sx ... !> \param matrix_gx ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_ot_get_derivative_taylor(matrix_hc,matrix_x,matrix_sx,matrix_gx, & - qs_ot_env, error) + qs_ot_env) TYPE(cp_dbcsr_type), POINTER :: matrix_hc, matrix_x, & matrix_sx, matrix_gx TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_get_derivative_taylor', & routineP = moduleN//':'//routineN @@ -1414,8 +1379,7 @@ SUBROUTINE qs_ot_get_derivative_taylor(matrix_hc,matrix_x,matrix_sx,matrix_gx, & ! go for the derivative now ! this de/dc*(dX/dx)*sinp i.e. zeroth order - CALL cp_dbcsr_multiply('N','N',rone,matrix_hc,qs_ot_env%matrix_sinp,rzero,matrix_gx,& - error=error) + CALL cp_dbcsr_multiply('N','N',rone,matrix_hc,qs_ot_env%matrix_sinp,rzero,matrix_gx) IF (qs_ot_env % taylor_order .LE. 0) THEN CALL timestop(handle) @@ -1423,26 +1387,25 @@ SUBROUTINE qs_ot_get_derivative_taylor(matrix_hc,matrix_x,matrix_sx,matrix_gx, & ENDIF ! we store the matrix that will multiply sx in matrix_r - CALL cp_dbcsr_set(qs_ot_env%matrix_r,rzero,error=error) + CALL cp_dbcsr_set(qs_ot_env%matrix_r,rzero) ! just better names for matrix_cosp_b and matrix_sinp_b (they are buffer space here) matrix_left => qs_ot_env%matrix_cosp_b matrix_right => qs_ot_env%matrix_sinp_b ! overlap hc*x and add its transpose to matrix_left - CALL cp_dbcsr_multiply('T','N',rone,matrix_hc,matrix_x,rzero,matrix_left,& - error=error) + CALL cp_dbcsr_multiply('T','N',rone,matrix_hc,matrix_x,rzero,matrix_left) CALL cp_dbcsr_transposed(qs_ot_env%matrix_buf1,matrix_left,& shallow_data_copy=.FALSE., use_distribution=cp_dbcsr_distribution(matrix_left), & - transpose_distribution=.FALSE., error=error) + transpose_distribution=.FALSE.) CALL cp_dbcsr_add(matrix_left,qs_ot_env%matrix_buf1,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) - CALL cp_dbcsr_copy(matrix_right,matrix_left,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) + CALL cp_dbcsr_copy(matrix_right,matrix_left) ! first order sinfactor=-1.0_dp/(2.0_dp*3.0_dp) CALL cp_dbcsr_add(qs_ot_env%matrix_r,matrix_left,& - alpha_scalar=1.0_dp,beta_scalar=sinfactor,error=error) + alpha_scalar=1.0_dp,beta_scalar=sinfactor) ! M ! OM+MO @@ -1450,27 +1413,27 @@ SUBROUTINE qs_ot_get_derivative_taylor(matrix_hc,matrix_x,matrix_sx,matrix_gx, & ! ... DO i=2, qs_ot_env % taylor_order sinfactor=sinfactor * (-1.0_dp)/REAL(2*i * (2*i+1),KIND=dp) - CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_p,matrix_left,rzero,qs_ot_env%matrix_buf1,error=error) - CALL cp_dbcsr_multiply('N','N',rone,matrix_right,qs_ot_env%matrix_p,rzero,matrix_left,error=error) - CALL cp_dbcsr_copy(matrix_right,matrix_left,error=error) + CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_p,matrix_left,rzero,qs_ot_env%matrix_buf1) + CALL cp_dbcsr_multiply('N','N',rone,matrix_right,qs_ot_env%matrix_p,rzero,matrix_left) + CALL cp_dbcsr_copy(matrix_right,matrix_left) CALL cp_dbcsr_add(matrix_left,qs_ot_env%matrix_buf1,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) CALL cp_dbcsr_add(qs_ot_env%matrix_r,matrix_left,& - alpha_scalar=1.0_dp,beta_scalar=sinfactor,error=error) + alpha_scalar=1.0_dp,beta_scalar=sinfactor) ENDDO ! overlap hc*c0 and add its transpose to matrix_left - CALL cp_dbcsr_multiply('T','N',rone,matrix_hc,qs_ot_env%matrix_c0,rzero,matrix_left,error=error) + CALL cp_dbcsr_multiply('T','N',rone,matrix_hc,qs_ot_env%matrix_c0,rzero,matrix_left) CALL cp_dbcsr_transposed(qs_ot_env%matrix_buf1,matrix_left,& shallow_data_copy=.FALSE., use_distribution=cp_dbcsr_distribution(matrix_left),& - transpose_distribution=.FALSE., error=error) - CALL cp_dbcsr_add(matrix_left,qs_ot_env%matrix_buf1,1.0_dp,1.0_dp,error=error) - CALL cp_dbcsr_copy(matrix_right,matrix_left,error=error) + transpose_distribution=.FALSE.) + CALL cp_dbcsr_add(matrix_left,qs_ot_env%matrix_buf1,1.0_dp,1.0_dp) + CALL cp_dbcsr_copy(matrix_right,matrix_left) ! first order cosfactor=-1.0_dp/(1.0_dp*2.0_dp) CALL cp_dbcsr_add(qs_ot_env%matrix_r,matrix_left,& - alpha_scalar=1.0_dp,beta_scalar=cosfactor,error=error) + alpha_scalar=1.0_dp,beta_scalar=cosfactor) ! M ! OM+MO @@ -1478,16 +1441,16 @@ SUBROUTINE qs_ot_get_derivative_taylor(matrix_hc,matrix_x,matrix_sx,matrix_gx, & ! ... DO i=2, qs_ot_env % taylor_order cosfactor=cosfactor * (-1.0_dp)/REAL(2*i * (2*i-1),KIND=dp) - CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_p,matrix_left,rzero,qs_ot_env%matrix_buf1,error=error) - CALL cp_dbcsr_multiply('N','N',rone,matrix_right,qs_ot_env%matrix_p,rzero,matrix_left,error=error) - CALL cp_dbcsr_copy(matrix_right,matrix_left,error=error) - CALL cp_dbcsr_add(matrix_left,qs_ot_env%matrix_buf1,1.0_dp,1.0_dp,error=error) + CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_p,matrix_left,rzero,qs_ot_env%matrix_buf1) + CALL cp_dbcsr_multiply('N','N',rone,matrix_right,qs_ot_env%matrix_p,rzero,matrix_left) + CALL cp_dbcsr_copy(matrix_right,matrix_left) + CALL cp_dbcsr_add(matrix_left,qs_ot_env%matrix_buf1,1.0_dp,1.0_dp) CALL cp_dbcsr_add(qs_ot_env%matrix_r,matrix_left,& - alpha_scalar=1.0_dp,beta_scalar=cosfactor,error=error) + alpha_scalar=1.0_dp,beta_scalar=cosfactor) ENDDO ! and add to the derivative - CALL cp_dbcsr_multiply('N','N',rone,matrix_sx,qs_ot_env%matrix_r,rone,matrix_gx,error=error) + CALL cp_dbcsr_multiply('N','N',rone,matrix_sx,qs_ot_env%matrix_r,rone,matrix_gx) CALL timestop(handle) @@ -1497,11 +1460,9 @@ END SUBROUTINE qs_ot_get_derivative_taylor ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_p2m_taylor(qs_ot_env,error) + SUBROUTINE qs_ot_p2m_taylor(qs_ot_env) TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_p2m_taylor', & routineP = moduleN//':'//routineN @@ -1513,10 +1474,10 @@ SUBROUTINE qs_ot_p2m_taylor(qs_ot_env,error) CALL timeset(routineN,handle) ! zeroth order - CALL cp_dbcsr_set(qs_ot_env%matrix_cosp,rzero,error=error) - CALL cp_dbcsr_set(qs_ot_env%matrix_sinp,rzero,error=error) - CALL cp_dbcsr_add_on_diag(qs_ot_env%matrix_cosp,rone,error=error) - CALL cp_dbcsr_add_on_diag(qs_ot_env%matrix_sinp,rone,error=error) + CALL cp_dbcsr_set(qs_ot_env%matrix_cosp,rzero) + CALL cp_dbcsr_set(qs_ot_env%matrix_sinp,rzero) + CALL cp_dbcsr_add_on_diag(qs_ot_env%matrix_cosp,rone) + CALL cp_dbcsr_add_on_diag(qs_ot_env%matrix_sinp,rone) IF (qs_ot_env% taylor_order .LE. 0) THEN CALL timestop(handle) @@ -1526,8 +1487,8 @@ SUBROUTINE qs_ot_p2m_taylor(qs_ot_env,error) ! first order cosfactor=-1.0_dp/(1.0_dp*2.0_dp) sinfactor=-1.0_dp/(2.0_dp*3.0_dp) - CALL cp_dbcsr_add(qs_ot_env%matrix_cosp,qs_ot_env%matrix_p,alpha_scalar=1.0_dp,beta_scalar=cosfactor,error=error) - CALL cp_dbcsr_add(qs_ot_env%matrix_sinp,qs_ot_env%matrix_p,alpha_scalar=1.0_dp,beta_scalar=sinfactor,error=error) + CALL cp_dbcsr_add(qs_ot_env%matrix_cosp,qs_ot_env%matrix_p,alpha_scalar=1.0_dp,beta_scalar=cosfactor) + CALL cp_dbcsr_add(qs_ot_env%matrix_sinp,qs_ot_env%matrix_p,alpha_scalar=1.0_dp,beta_scalar=sinfactor) IF (qs_ot_env% taylor_order .LE. 1) THEN CALL timestop(handle) RETURN @@ -1535,20 +1496,20 @@ SUBROUTINE qs_ot_p2m_taylor(qs_ot_env,error) ! other orders CALL cp_dbcsr_get_info(qs_ot_env%matrix_p,nfullrows_total=k) - CALL cp_dbcsr_copy(qs_ot_env%matrix_r,qs_ot_env%matrix_p,error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_r,qs_ot_env%matrix_p) DO i=2, qs_ot_env%taylor_order ! new power of p CALL cp_dbcsr_multiply('N','N',rone,qs_ot_env%matrix_p,qs_ot_env%matrix_r,& - rzero,qs_ot_env%matrix_buf1,error=error) - CALL cp_dbcsr_copy(qs_ot_env%matrix_r,qs_ot_env%matrix_buf1,error=error) + rzero,qs_ot_env%matrix_buf1) + CALL cp_dbcsr_copy(qs_ot_env%matrix_r,qs_ot_env%matrix_buf1) ! add to the taylor expansion so far cosfactor=cosfactor * (-1.0_dp)/REAL(2*i * (2*i-1),KIND=dp) sinfactor=sinfactor * (-1.0_dp)/REAL(2*i * (2*i+1),KIND=dp) CALL cp_dbcsr_add(qs_ot_env%matrix_cosp,qs_ot_env%matrix_r,& - alpha_scalar=1.0_dp,beta_scalar=cosfactor,error=error) + alpha_scalar=1.0_dp,beta_scalar=cosfactor) CALL cp_dbcsr_add(qs_ot_env%matrix_sinp,qs_ot_env%matrix_r,& - alpha_scalar=1.0_dp,beta_scalar=sinfactor,error=error) + alpha_scalar=1.0_dp,beta_scalar=sinfactor) ENDDO CALL timestop(handle) @@ -1563,12 +1524,10 @@ END SUBROUTINE qs_ot_p2m_taylor ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_p2m_diag(qs_ot_env,error) + SUBROUTINE qs_ot_p2m_diag(qs_ot_env) TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_p2m_diag', & routineP = moduleN//':'//routineN @@ -1584,9 +1543,9 @@ SUBROUTINE qs_ot_p2m_diag(qs_ot_env,error) CALL timeset(routineN,handle) CALL cp_dbcsr_get_info(qs_ot_env%matrix_p,nfullrows_total=k) - CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%matrix_p,error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%matrix_p) CALL cp_dbcsr_syevd(qs_ot_env%matrix_buf1,qs_ot_env%matrix_r,qs_ot_env%evals,& - qs_ot_env%para_env,qs_ot_env%blacs_env,error=error) + qs_ot_env%para_env,qs_ot_env%blacs_env) DO i=1,k qs_ot_env%evals(i)=MAX(0.0_dp,qs_ot_env%evals(i)) ENDDO @@ -1595,21 +1554,21 @@ SUBROUTINE qs_ot_p2m_diag(qs_ot_env,error) DO i=1,k qs_ot_env%dum(i)=COS(SQRT(qs_ot_env%evals(i))) ENDDO - CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%matrix_r,error=error) - CALL cp_dbcsr_scale_by_vector(qs_ot_env%matrix_buf1,alpha=qs_ot_env%dum,side='right',error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%matrix_r) + CALL cp_dbcsr_scale_by_vector(qs_ot_env%matrix_buf1,alpha=qs_ot_env%dum,side='right') CALL cp_dbcsr_multiply('N','T',rone,qs_ot_env%matrix_r,qs_ot_env%matrix_buf1, & - rzero,qs_ot_env%matrix_cosp,error=error) + rzero,qs_ot_env%matrix_cosp) !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(k,qs_ot_env) DO i=1,k qs_ot_env%dum(i)=qs_ot_sinc(SQRT(qs_ot_env%evals(i))) ENDDO - CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%matrix_r,error=error) - CALL cp_dbcsr_scale_by_vector(qs_ot_env%matrix_buf1,alpha=qs_ot_env%dum,side='right',error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_buf1,qs_ot_env%matrix_r) + CALL cp_dbcsr_scale_by_vector(qs_ot_env%matrix_buf1,alpha=qs_ot_env%dum,side='right') CALL cp_dbcsr_multiply('N','T',rone,qs_ot_env%matrix_r,qs_ot_env%matrix_buf1, & - rzero,qs_ot_env%matrix_sinp,error=error) + rzero,qs_ot_env%matrix_sinp) - CALL cp_dbcsr_copy(qs_ot_env%matrix_cosp_b,qs_ot_env%matrix_cosp,error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_cosp_b,qs_ot_env%matrix_cosp) CALL cp_dbcsr_iterator_start(iter, qs_ot_env%matrix_cosp_b) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) CALL cp_dbcsr_iterator_next_block(iter, row, col, DATA,& @@ -1627,7 +1586,7 @@ SUBROUTINE qs_ot_p2m_diag(qs_ot_env,error) ENDDO CALL cp_dbcsr_iterator_stop(iter) - CALL cp_dbcsr_copy(qs_ot_env%matrix_sinp_b,qs_ot_env%matrix_sinp,error=error) + CALL cp_dbcsr_copy(qs_ot_env%matrix_sinp_b,qs_ot_env%matrix_sinp) CALL cp_dbcsr_iterator_start(iter, qs_ot_env%matrix_sinp_b) DO WHILE (cp_dbcsr_iterator_blocks_left (iter)) CALL cp_dbcsr_iterator_next_block(iter, row, col, DATA,& diff --git a/src/qs_ot_eigensolver.F b/src/qs_ot_eigensolver.F index a216263ed8..9941a1b267 100644 --- a/src/qs_ot_eigensolver.F +++ b/src/qs_ot_eigensolver.F @@ -66,11 +66,10 @@ MODULE qs_ot_eigensolver !> \param size_ortho_space ... !> \param silent ... !> \param ot_settings ... -!> \param error ... ! ***************************************************************************** SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & matrix_c_fm,preconditioner,eps_gradient, & - iter_max,size_ortho_space,silent,ot_settings,error) + iter_max,size_ortho_space,silent,ot_settings) TYPE(cp_dbcsr_type), POINTER :: matrix_h, matrix_s TYPE(cp_fm_type), OPTIONAL, POINTER :: matrix_orthogonal_space_fm @@ -83,7 +82,6 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & LOGICAL, INTENT(IN), OPTIONAL :: silent TYPE(qs_ot_settings_type), INTENT(IN), & OPTIONAL :: ot_settings - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_eigensolver', & routineP = moduleN//':'//routineN @@ -104,7 +102,7 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) IF ( PRESENT(silent) ) THEN @@ -117,9 +115,9 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & NULLIFY(matrix_c)! fm->dbcsr !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx - CALL cp_fm_get_info(matrix_c_fm, nrow_global=n, ncol_global=k,error=error)! fm->dbcsr + CALL cp_fm_get_info(matrix_c_fm, nrow_global=n, ncol_global=k)! fm->dbcsr ALLOCATE(matrix_c) - CALL cp_fm_to_dbcsr_row_template(matrix_c,fm_in=matrix_c_fm,template=matrix_h,error=error) + CALL cp_fm_to_dbcsr_row_template(matrix_c,fm_in=matrix_c_fm,template=matrix_h) iter_total=0 @@ -136,8 +134,8 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & ALLOCATE(qs_ot_env(1)) ALLOCATE(matrix_hc(1)) NULLIFY(matrix_hc(1)%matrix) - CALL cp_dbcsr_init_p(matrix_hc(1)%matrix, error=error) - CALL cp_dbcsr_copy(matrix_hc(1)%matrix,matrix_c,'matrix_hc',error=error) + CALL cp_dbcsr_init_p(matrix_hc(1)%matrix) + CALL cp_dbcsr_copy(matrix_hc(1)%matrix,matrix_c,'matrix_hc') ortho=.FALSE. IF (PRESENT(matrix_orthogonal_space_fm)) ortho=.TRUE. @@ -153,8 +151,8 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & IF (ortho) THEN ALLOCATE(matrix_orthogonal_space) - CALL cp_fm_to_dbcsr_row_template(matrix_orthogonal_space,fm_in=matrix_orthogonal_space_fm,template=matrix_h,error=error) - CALL cp_fm_get_info(matrix_orthogonal_space_fm,ncol_global=ortho_space_k,error=error) + CALL cp_fm_to_dbcsr_row_template(matrix_orthogonal_space,fm_in=matrix_orthogonal_space_fm,template=matrix_h) + CALL cp_fm_get_info(matrix_orthogonal_space_fm,ncol_global=ortho_space_k) IF (PRESENT(size_ortho_space)) ortho_space_k=size_ortho_space ortho_k=ortho_space_k+k @@ -163,96 +161,94 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & ENDIF ! allocate - CALL qs_ot_allocate(qs_ot_env(1),matrix_s,matrix_c_fm%matrix_struct,ortho_k=ortho_k,error=error) + CALL qs_ot_allocate(qs_ot_env(1),matrix_s,matrix_c_fm%matrix_struct,ortho_k=ortho_k) IF (ortho) THEN ! construct an initial guess that is orthogonal to matrix_orthogonal_space - CALL cp_dbcsr_init_p(matrix_s_ortho, error=error) - CALL cp_dbcsr_copy(matrix_s_ortho,matrix_orthogonal_space,name="matrix_s_ortho",error=error) + CALL cp_dbcsr_init_p(matrix_s_ortho) + CALL cp_dbcsr_copy(matrix_s_ortho,matrix_orthogonal_space,name="matrix_s_ortho") - CALL cp_dbcsr_init_p(matrix_os_ortho, error=error) + CALL cp_dbcsr_init_p(matrix_os_ortho) CALL cp_dbcsr_m_by_n_from_template(matrix_os_ortho,template=matrix_h,m=ortho_space_k,n=ortho_space_k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(matrix_buf1_ortho, error=error) + CALL cp_dbcsr_init_p(matrix_buf1_ortho) CALL cp_dbcsr_m_by_n_from_template(matrix_buf1_ortho,template=matrix_h,m=ortho_space_k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(matrix_buf2_ortho, error=error) + CALL cp_dbcsr_init_p(matrix_buf2_ortho) CALL cp_dbcsr_m_by_n_from_template(matrix_buf2_ortho,template=matrix_h,m=ortho_space_k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_s,matrix_orthogonal_space, & - 0.0_dp,matrix_s_ortho,error=error) + 0.0_dp,matrix_s_ortho) CALL cp_dbcsr_multiply('T','N',rone,matrix_s_ortho, matrix_s_ortho, & - rzero,matrix_os_ortho,error=error) + rzero,matrix_os_ortho) CALL cp_dbcsr_cholesky_decompose(matrix_os_ortho,& - para_env=qs_ot_env(1)%para_env,blacs_env=qs_ot_env(1)%blacs_env,error=error) + para_env=qs_ot_env(1)%para_env,blacs_env=qs_ot_env(1)%blacs_env) CALL cp_dbcsr_cholesky_invert(matrix_os_ortho,& para_env=qs_ot_env(1)%para_env,blacs_env=qs_ot_env(1)%blacs_env,& - upper_to_full=.TRUE.,error=error) + upper_to_full=.TRUE.) CALL cp_dbcsr_multiply('T','N',rone,matrix_s_ortho,matrix_c, & - rzero,matrix_buf1_ortho, error=error) + rzero,matrix_buf1_ortho) CALL cp_dbcsr_multiply('N','N',rone,matrix_os_ortho,matrix_buf1_ortho, & - rzero,matrix_buf2_ortho,error=error) + rzero,matrix_buf2_ortho) CALL cp_dbcsr_multiply('N','N',-rone,matrix_s_ortho, matrix_buf2_ortho, & - rone,matrix_c, error=error) + rone,matrix_c) ! make matrix_c0 an orthogonal basis, matrix_c contains sc0 - CALL cp_dbcsr_copy(qs_ot_env(1)%matrix_c0,matrix_c,error=error) + CALL cp_dbcsr_copy(qs_ot_env(1)%matrix_c0,matrix_c) CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_s,qs_ot_env(1)%matrix_c0, & - 0.0_dp,matrix_c,error=error) + 0.0_dp,matrix_c) CALL make_basis_sv(qs_ot_env(1)%matrix_c0,k, matrix_c, & - qs_ot_env(1)%para_env, qs_ot_env(1)%blacs_env, & - error=error) + qs_ot_env(1)%para_env, qs_ot_env(1)%blacs_env) ! copy sc0 and matrix_s_ortho in qs_ot_env(1)%matrix_sc0 - !CALL cp_dbcsr_copy_columns(qs_ot_env(1)%matrix_sc0,matrix_s_ortho,ortho_space_k,1,1,error=error) + !CALL cp_dbcsr_copy_columns(qs_ot_env(1)%matrix_sc0,matrix_s_ortho,ortho_space_k,1,1) CALL cp_dbcsr_copy_columns_hack(qs_ot_env(1)%matrix_sc0,matrix_s_ortho,ortho_space_k,1,1,& - para_env=qs_ot_env(1)%para_env,blacs_env=qs_ot_env(1)%blacs_env,error=error) - !CALL cp_dbcsr_copy_columns(qs_ot_env(1)%matrix_sc0,matrix_c,k,1,ortho_space_k+1,error=error) + para_env=qs_ot_env(1)%para_env,blacs_env=qs_ot_env(1)%blacs_env) + !CALL cp_dbcsr_copy_columns(qs_ot_env(1)%matrix_sc0,matrix_c,k,1,ortho_space_k+1) CALL cp_dbcsr_copy_columns_hack(qs_ot_env(1)%matrix_sc0,matrix_c,k,1,ortho_space_k+1,& - para_env=qs_ot_env(1)%para_env,blacs_env=qs_ot_env(1)%blacs_env,error=error) + para_env=qs_ot_env(1)%para_env,blacs_env=qs_ot_env(1)%blacs_env) - CALL cp_dbcsr_release_p(matrix_buf1_ortho, error=error) - CALL cp_dbcsr_release_p(matrix_buf2_ortho, error=error) - CALL cp_dbcsr_release_p(matrix_os_ortho, error=error) - CALL cp_dbcsr_release_p(matrix_s_ortho, error=error) + CALL cp_dbcsr_release_p(matrix_buf1_ortho) + CALL cp_dbcsr_release_p(matrix_buf2_ortho) + CALL cp_dbcsr_release_p(matrix_os_ortho) + CALL cp_dbcsr_release_p(matrix_s_ortho) ELSE ! set c0,sc0 - CALL cp_dbcsr_copy(qs_ot_env(1)%matrix_c0,matrix_c,error=error) + CALL cp_dbcsr_copy(qs_ot_env(1)%matrix_c0,matrix_c) CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_s,qs_ot_env(1)%matrix_c0, & - 0.0_dp,qs_ot_env(1)%matrix_sc0,error=error) + 0.0_dp,qs_ot_env(1)%matrix_sc0) CALL make_basis_sv(qs_ot_env(1)%matrix_c0,k, qs_ot_env(1)%matrix_sc0, & - qs_ot_env(1)%para_env, qs_ot_env(1)%blacs_env, & - error=error) + qs_ot_env(1)%para_env, qs_ot_env(1)%blacs_env) ENDIF ! init - CALL qs_ot_init(qs_ot_env(1),error=error) + CALL qs_ot_init(qs_ot_env(1)) energy_only=qs_ot_env(1)%energy_only ! set x - CALL cp_dbcsr_set(qs_ot_env(1)%matrix_x,0.0_dp,error=error) - CALL cp_dbcsr_set(qs_ot_env(1)%matrix_sx,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(1)%matrix_x,0.0_dp) + CALL cp_dbcsr_set(qs_ot_env(1)%matrix_sx,0.0_dp) ! get c - CALL qs_ot_get_p(qs_ot_env(1)%matrix_x,qs_ot_env(1)%matrix_sx,qs_ot_env(1),error=error) - CALL qs_ot_get_orbitals(matrix_c,qs_ot_env(1)%matrix_x,qs_ot_env(1),error=error) + CALL qs_ot_get_p(qs_ot_env(1)%matrix_x,qs_ot_env(1)%matrix_sx,qs_ot_env(1)) + CALL qs_ot_get_orbitals(matrix_c,qs_ot_env(1)%matrix_x,qs_ot_env(1)) ! if present preconditioner, use it IF (PRESENT(preconditioner) ) THEN IF (ASSOCIATED(preconditioner)) THEN IF (preconditioner_in_use(preconditioner)) THEN - CALL qs_ot_new_preconditioner(qs_ot_env(1),preconditioner,error=error) + CALL qs_ot_new_preconditioner(qs_ot_env(1),preconditioner) ELSE ! we should presumably make one END IF @@ -268,22 +264,22 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & ! the energy is cHc, the gradient is 2*H*c CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_h,matrix_c, & - 0.0_dp,matrix_hc(1)%matrix,error=error) - CALL cp_dbcsr_trace(matrix_c,matrix_hc(1)%matrix,energy,error=error) + 0.0_dp,matrix_hc(1)%matrix) + CALL cp_dbcsr_trace(matrix_c,matrix_hc(1)%matrix,energy) IF (.NOT. energy_only) THEN - CALL cp_dbcsr_scale(matrix_hc(1)%matrix,2.0_dp,error=error) + CALL cp_dbcsr_scale(matrix_hc(1)%matrix,2.0_dp) ENDIF qs_ot_env(1)%etotal=energy - CALL ot_mini(qs_ot_env,matrix_hc,output_unit=0,error=error) + CALL ot_mini(qs_ot_env,matrix_hc,output_unit=0) delta =qs_ot_env(1)%delta energy_only =qs_ot_env(1)%energy_only CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_s,qs_ot_env(1)%matrix_x, & - 0.0_dp, qs_ot_env(1)%matrix_sx, error=error) + 0.0_dp, qs_ot_env(1)%matrix_sx) - CALL qs_ot_get_p(qs_ot_env(1)%matrix_x,qs_ot_env(1)%matrix_sx,qs_ot_env(1),error=error) - CALL qs_ot_get_orbitals(matrix_c,qs_ot_env(1)%matrix_x,qs_ot_env(1),error=error) + CALL qs_ot_get_p(qs_ot_env(1)%matrix_x,qs_ot_env(1)%matrix_sx,qs_ot_env(1)) + CALL qs_ot_get_orbitals(matrix_c,qs_ot_env(1)%matrix_x,qs_ot_env(1)) ! exit on convergence or if maximum of inner loop cycles is reached IF ( delta < eps_gradient .OR. ieigensolver >= max_iter_inner_loop ) EXIT eigensolver_loop @@ -292,11 +288,11 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & END DO eigensolver_loop - CALL qs_ot_destroy(qs_ot_env(1),error=error) + CALL qs_ot_destroy(qs_ot_env(1)) DEALLOCATE(qs_ot_env) - CALL cp_dbcsr_release_p(matrix_hc(1)%matrix, error=error) + CALL cp_dbcsr_release_p(matrix_hc(1)%matrix) DEALLOCATE(matrix_hc) - CALL cp_dbcsr_release_p(matrix_orthogonal_space, error=error) + CALL cp_dbcsr_release_p(matrix_orthogonal_space) IF (delta < eps_gradient) THEN IF ((output_unit>0) .AND. .NOT.my_silent) THEN @@ -320,8 +316,8 @@ SUBROUTINE ot_eigensolver(matrix_h,matrix_s,matrix_orthogonal_space_fm, & ENDDO outer_scf - CALL copy_dbcsr_to_fm(matrix_c,matrix_c_fm,error=error)! fm->dbcsr - CALL cp_dbcsr_release_p(matrix_c, error=error)! fm->dbcsr + CALL copy_dbcsr_to_fm(matrix_c,matrix_c_fm)! fm->dbcsr + CALL cp_dbcsr_release_p(matrix_c)! fm->dbcsr CALL timestop(handle) diff --git a/src/qs_ot_minimizer.F b/src/qs_ot_minimizer.F index 588a38b5fa..e8edcd5fd9 100644 --- a/src/qs_ot_minimizer.F +++ b/src/qs_ot_minimizer.F @@ -53,14 +53,12 @@ MODULE qs_ot_minimizer !> \param qs_ot_env ... !> \param matrix_hc ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE ot_mini(qs_ot_env,matrix_hc,output_unit,error) +SUBROUTINE ot_mini(qs_ot_env,matrix_hc,output_unit) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_hc INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_mini', & routineP = moduleN//':'//routineN @@ -87,11 +85,11 @@ SUBROUTINE ot_mini(qs_ot_env,matrix_hc,output_unit,error) CASE("TOD") CALL qs_ot_get_derivative(matrix_hc(ispin)%matrix,qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_sx, & - qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin),error=error) + qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)) CASE("REF") CALL qs_ot_get_derivative_ref(matrix_hc(ispin)%matrix,& qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_sx, & - qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin),output_unit,error=error) + qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin),output_unit) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"ALGORITHM NYI") END SELECT @@ -99,10 +97,10 @@ SUBROUTINE ot_mini(qs_ot_env,matrix_hc,output_unit,error) ! and also the gradient along the direction IF (qs_ot_env(1)%use_dx) THEN IF ( do_ks ) THEN - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_dx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_dx,tmp) qs_ot_env(1)%gradient=qs_ot_env(1)%gradient+tmp IF (qs_ot_env(1)%settings%do_rotation) THEN - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_dx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_dx,tmp) qs_ot_env(1)%gradient=qs_ot_env(1)%gradient+0.5_dp*tmp ENDIF END IF @@ -112,10 +110,10 @@ SUBROUTINE ot_mini(qs_ot_env,matrix_hc,output_unit,error) ENDIF ELSE IF ( do_ks ) THEN - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp) qs_ot_env(1)%gradient=qs_ot_env(1)%gradient-tmp IF (qs_ot_env(1)%settings%do_rotation) THEN - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp) qs_ot_env(1)%gradient=qs_ot_env(1)%gradient-0.5_dp*tmp ENDIF ENDIF @@ -131,27 +129,27 @@ SUBROUTINE ot_mini(qs_ot_env,matrix_hc,output_unit,error) CASE ("CG") IF (current_point_is_fine(qs_ot_env)) THEN qs_ot_env(1)%OT_METHOD_FULL="OT CG" - CALL ot_new_cg_direction(qs_ot_env,error=error) + CALL ot_new_cg_direction(qs_ot_env) qs_ot_env(1)%line_search_count=0 ELSE qs_ot_env(1)%OT_METHOD_FULL="OT LS" ENDIF - CALL do_line_search(qs_ot_env,error=error) + CALL do_line_search(qs_ot_env) CASE ("SD") IF (current_point_is_fine(qs_ot_env)) THEN qs_ot_env(1)%OT_METHOD_FULL="OT SD" - CALL ot_new_sd_direction(qs_ot_env,error=error) + CALL ot_new_sd_direction(qs_ot_env) qs_ot_env(1)%line_search_count=0 ELSE qs_ot_env(1)%OT_METHOD_FULL="OT LS" ENDIF - CALL do_line_search(qs_ot_env,error=error) + CALL do_line_search(qs_ot_env) CASE ("DIIS") qs_ot_env(1)%OT_METHOD_FULL="OT DIIS" - CALL ot_diis_step(qs_ot_env,error=error) + CALL ot_diis_step(qs_ot_env) CASE ("BROY") qs_ot_env(1)%OT_METHOD_FULL="OT BROY" - CALL ot_broyden_step(qs_ot_env,error=error) + CALL ot_broyden_step(qs_ot_env) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"OT_METHOD NYI") END SELECT @@ -200,24 +198,22 @@ END FUNCTION current_point_is_fine ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE do_line_search(qs_ot_env,error) +SUBROUTINE do_line_search(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_line_search', & routineP = moduleN//':'//routineN SELECT CASE(qs_ot_env(1)%settings%line_search_method) CASE("GOLD") - CALL do_line_search_gold(qs_ot_env,error=error) + CALL do_line_search_gold(qs_ot_env) CASE("3PNT") - CALL do_line_search_3pnt(qs_ot_env,error=error) + CALL do_line_search_3pnt(qs_ot_env) CASE("2PNT") - CALL do_line_search_2pnt(qs_ot_env,error=error) + CALL do_line_search_2pnt(qs_ot_env) CASE("NONE") - CALL do_line_search_none(qs_ot_env,error=error) + CALL do_line_search_none(qs_ot_env) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"NYI") END SELECT @@ -227,14 +223,12 @@ END SUBROUTINE do_line_search !> \brief moves x adding the right amount (ds) of the gradient or search direction !> \param ds ... !> \param qs_ot_env ... -!> \param error ... !> \par History !> 08.2004 created [ Joost VandeVondele ] copied here from a larger number of subroutines ! ***************************************************************************** -SUBROUTINE take_step(ds,qs_ot_env,error) +SUBROUTINE take_step(ds,qs_ot_env) REAL(KIND=dp) :: ds TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'take_step', & routineP = moduleN//':'//routineN @@ -255,10 +249,10 @@ SUBROUTINE take_step(ds,qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_dx,& - alpha_scalar=1.0_dp,beta_scalar=ds,error=error) + alpha_scalar=1.0_dp,beta_scalar=ds) IF (qs_ot_env(ispin)%settings%do_rotation) THEN CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_x,qs_ot_env(ispin)%rot_mat_dx,& - alpha_scalar=1.0_dp,beta_scalar=ds,error=error) + alpha_scalar=1.0_dp,beta_scalar=ds) ENDIF ENDDO END IF @@ -271,10 +265,10 @@ SUBROUTINE take_step(ds,qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_gx,& - alpha_scalar=1.0_dp,beta_scalar=-ds,error=error) + alpha_scalar=1.0_dp,beta_scalar=-ds) IF (qs_ot_env(ispin)%settings%do_rotation) THEN CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_x,qs_ot_env(ispin)%rot_mat_gx,& - alpha_scalar=1.0_dp,beta_scalar=-ds,error=error) + alpha_scalar=1.0_dp,beta_scalar=-ds) ENDIF ENDDO ENDIF @@ -291,12 +285,10 @@ END SUBROUTINE take_step ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE do_line_search_gold(qs_ot_env,error) +SUBROUTINE do_line_search_gold(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_line_search_gold', & routineP = moduleN//':'//routineN @@ -388,7 +380,7 @@ SUBROUTINE do_line_search_gold(qs_ot_env,error) ds=qs_ot_env(1)%OT_pos(count+1)-qs_ot_env(1)%OT_pos(count) qs_ot_env(1)%ds_min=qs_ot_env(1)%OT_pos(count+1) - CALL take_step(ds,qs_ot_env,error=error) + CALL take_step(ds,qs_ot_env) CALL timestop(handle) @@ -397,12 +389,10 @@ END SUBROUTINE do_line_search_gold ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE do_line_search_3pnt(qs_ot_env,error) +SUBROUTINE do_line_search_3pnt(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_line_search_3pnt', & routineP = moduleN//':'//routineN @@ -462,7 +452,7 @@ SUBROUTINE do_line_search_3pnt(qs_ot_env,error) ds=qs_ot_env(1)%OT_pos(count+1)-qs_ot_env(1)%OT_pos(count) qs_ot_env(1)%ds_min=qs_ot_env(1)%OT_pos(count+1) - CALL take_step(ds,qs_ot_env,error=error) + CALL take_step(ds,qs_ot_env) CALL timestop(handle) @@ -471,12 +461,10 @@ END SUBROUTINE do_line_search_3pnt ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE do_line_search_2pnt(qs_ot_env,error) +SUBROUTINE do_line_search_2pnt(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_line_search_2pnt', & routineP = moduleN//':'//routineN @@ -523,7 +511,7 @@ SUBROUTINE do_line_search_2pnt(qs_ot_env,error) ds=qs_ot_env(1)%OT_pos(count+1)-qs_ot_env(1)%OT_pos(count) qs_ot_env(1)%ds_min=qs_ot_env(1)%OT_pos(count+1) - CALL take_step(ds,qs_ot_env,error=error) + CALL take_step(ds,qs_ot_env) CALL timestop(handle) @@ -532,13 +520,11 @@ END SUBROUTINE do_line_search_2pnt ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE do_line_search_none(qs_ot_env,error) +SUBROUTINE do_line_search_none(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error - CALL take_step(qs_ot_env(1)%ds_min,qs_ot_env,error=error) + CALL take_step(qs_ot_env(1)%ds_min,qs_ot_env) END SUBROUTINE do_line_search_none @@ -550,11 +536,9 @@ END SUBROUTINE do_line_search_none ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE ot_new_sd_direction(qs_ot_env,error) +SUBROUTINE ot_new_sd_direction(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_new_sd_direction', & routineP = moduleN//':'//routineN @@ -570,7 +554,7 @@ SUBROUTINE ot_new_sd_direction(qs_ot_env,error) !***SCP nspin=SIZE(qs_ot_env) - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() do_ks = qs_ot_env ( 1 ) % settings % ks do_ener = qs_ot_env ( 1 ) % settings % do_ener @@ -580,27 +564,27 @@ SUBROUTINE ot_new_sd_direction(qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin CALL apply_preconditioner(qs_ot_env(ispin)%preconditioner, & - qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_dx,error=error) - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_dx,tmp,error=error) + qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_dx) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_dx,tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp ENDDO IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() WRITE(cp_logger_get_default_unit_nr(logger),*) "WARNING Preconditioner not positive definite !" ENDIF DO ispin=1,nspin - CALL cp_dbcsr_scale(qs_ot_env(ispin)%matrix_dx,-1.0_dp,error=error) + CALL cp_dbcsr_scale(qs_ot_env(ispin)%matrix_dx,-1.0_dp) ENDDO IF (qs_ot_env(1)%settings%do_rotation) THEN DO ispin=1,nspin ! right now no preconditioner yet - CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_dx,qs_ot_env(ispin)%rot_mat_gx,error=error) - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_dx,tmp,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_dx,qs_ot_env(ispin)%rot_mat_gx) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_dx,tmp) ! added 0.5, because we have (antisymmetry) only half the number of variables qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+0.5_dp*tmp ENDDO DO ispin=1,nspin - CALL cp_dbcsr_scale(qs_ot_env(ispin)%rot_mat_dx,-1.0_dp,error=error) + CALL cp_dbcsr_scale(qs_ot_env(ispin)%rot_mat_dx,-1.0_dp) ENDDO ENDIF ENDIF @@ -616,12 +600,12 @@ SUBROUTINE ot_new_sd_direction(qs_ot_env,error) qs_ot_env(1)%gnorm=0.0_dp IF ( do_ks ) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp ENDDO IF (qs_ot_env(1)%settings%do_rotation) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp) ! added 0.5, because we have (antisymmetry) only half the number of variables qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+0.5_dp*tmp ENDDO @@ -671,11 +655,9 @@ END SUBROUTINE ot_new_sd_direction ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE ot_new_cg_direction(qs_ot_env,error) +SUBROUTINE ot_new_cg_direction(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_new_cg_direction', & routineP = moduleN//':'//routineN @@ -690,7 +672,7 @@ SUBROUTINE ot_new_cg_direction(qs_ot_env,error) CALL timeset(routineN,handle) nspin=SIZE(qs_ot_env) - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() do_ks = qs_ot_env ( 1 ) % settings % ks do_ener = qs_ot_env ( 1 ) % settings % do_ener @@ -698,12 +680,12 @@ SUBROUTINE ot_new_cg_direction(qs_ot_env,error) gnorm_cross=0.0_dp IF ( do_ks ) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx_old,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx_old,tmp) gnorm_cross=gnorm_cross+tmp ENDDO IF (qs_ot_env(1)%settings%do_rotation) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx_old,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx_old,tmp) ! added 0.5, because we have (antisymmetry) only half the number of variables gnorm_cross=gnorm_cross+0.5_dp*tmp ENDDO @@ -720,30 +702,30 @@ SUBROUTINE ot_new_cg_direction(qs_ot_env,error) DO ispin=1,nspin CALL apply_preconditioner(qs_ot_env(ispin)%preconditioner, & - qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_gx_old,error=error) + qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_gx_old) ENDDO qs_ot_env(1)%gnorm=0.0_dp IF ( do_ks ) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx_old,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx_old,tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp ENDDO IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN WRITE(cp_logger_get_default_unit_nr(logger),*) "WARNING Preconditioner not positive definite !" ENDIF DO ispin=1,nspin - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx_old,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx_old) ENDDO IF (qs_ot_env(1)%settings%do_rotation) THEN DO ispin=1,nspin ! right now no preconditioner yet - CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_gx_old,qs_ot_env(ispin)%rot_mat_gx,error=error) - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx_old,tmp,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_gx_old,qs_ot_env(ispin)%rot_mat_gx) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx_old,tmp) ! added 0.5, because we have (antisymmetry) only half the number of variables qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+0.5_dp*tmp ENDDO DO ispin=1,nspin - CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx_old,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx_old) ENDDO ENDIF END IF @@ -759,16 +741,16 @@ SUBROUTINE ot_new_cg_direction(qs_ot_env,error) IF ( do_ks ) THEN qs_ot_env(1)%gnorm=0.0_dp DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_gx_old,qs_ot_env(ispin)%matrix_gx,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_gx_old,qs_ot_env(ispin)%matrix_gx) ENDDO IF (qs_ot_env(1)%settings%do_rotation) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp) ! added 0.5, because we have (antisymmetry) only half the number of variables qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+0.5_dp*tmp - CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_gx_old,qs_ot_env(ispin)%rot_mat_gx,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_gx_old,qs_ot_env(ispin)%rot_mat_gx) ENDDO ENDIF ENDIF @@ -810,13 +792,13 @@ SUBROUTINE ot_new_cg_direction(qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_dx,qs_ot_env(ispin)%matrix_gx,& - alpha_scalar=beta_pr,beta_scalar=-1.0_dp,error=error) - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_dx,tmp,error=error) + alpha_scalar=beta_pr,beta_scalar=-1.0_dp) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_dx,tmp) test_down=test_down+tmp IF (qs_ot_env(1)%settings%do_rotation) THEN CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_dx,qs_ot_env(ispin)%rot_mat_gx,& - alpha_scalar=beta_pr,beta_scalar=-1.0_dp,error=error) - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_dx,tmp,error=error) + alpha_scalar=beta_pr,beta_scalar=-1.0_dp) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_dx,tmp) test_down=test_down+0.5_dp*tmp ENDIF ENDDO @@ -834,10 +816,10 @@ SUBROUTINE ot_new_cg_direction(qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_dx,qs_ot_env(ispin)%matrix_gx,& - alpha_scalar=beta_pr,beta_scalar=-1.0_dp,error=error) + alpha_scalar=beta_pr,beta_scalar=-1.0_dp) IF (qs_ot_env(1)%settings%do_rotation) THEN CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_dx, & - qs_ot_env(ispin)%rot_mat_gx,alpha_scalar=beta_pr,beta_scalar=-1.0_dp,error=error) + qs_ot_env(ispin)%rot_mat_gx,alpha_scalar=beta_pr,beta_scalar=-1.0_dp) ENDIF ENDDO END IF @@ -858,11 +840,9 @@ END SUBROUTINE ot_new_cg_direction ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE ot_diis_step(qs_ot_env,error) +SUBROUTINE ot_diis_step(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_diis_step', & routineP = moduleN//':'//routineN @@ -877,7 +857,7 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() do_ks = qs_ot_env ( 1 ) % settings % ks do_ener = qs_ot_env ( 1 ) % settings % do_ener @@ -897,9 +877,9 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_h_x(j)%matrix,qs_ot_env(ispin)%matrix_x,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_h_x(j)%matrix,qs_ot_env(ispin)%matrix_x) IF (qs_ot_env(ispin)%settings%do_rotation) THEN - CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_h_x(j)%matrix,qs_ot_env(ispin)%rot_mat_x,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_h_x(j)%matrix,qs_ot_env(ispin)%rot_mat_x) ENDIF ENDDO END IF @@ -913,26 +893,26 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin CALL apply_preconditioner(qs_ot_env(ispin)%preconditioner, & - qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_h_e(j)%matrix,error=error) + qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_h_e(j)%matrix) CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_h_e(j)%matrix, & - tmp,error=error) + tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp ENDDO IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN WRITE(cp_logger_get_default_unit_nr(logger),*) "WARNING Preconditioner not positive definite !" ENDIF DO ispin=1,nspin - CALL cp_dbcsr_scale(qs_ot_env(ispin)%matrix_h_e(j)%matrix,-qs_ot_env(1)%ds_min,error=error) + CALL cp_dbcsr_scale(qs_ot_env(ispin)%matrix_h_e(j)%matrix,-qs_ot_env(1)%ds_min) ENDDO IF (qs_ot_env(1)%settings%do_rotation) THEN DO ispin=1,nspin - CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_h_e(j)%matrix,qs_ot_env(ispin)%rot_mat_gx,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%rot_mat_h_e(j)%matrix,qs_ot_env(ispin)%rot_mat_gx) CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_h_e(j)%matrix, & - tmp,error=error) + tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+0.5_dp*tmp ENDDO DO ispin=1,nspin - CALL cp_dbcsr_scale(qs_ot_env(ispin)%rot_mat_h_e(j)%matrix,-qs_ot_env(1)%ds_min,error=error) + CALL cp_dbcsr_scale(qs_ot_env(ispin)%rot_mat_h_e(j)%matrix,-qs_ot_env(1)%ds_min) ENDDO ENDIF END IF @@ -948,17 +928,17 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) qs_ot_env(1)%gnorm=0.0_dp IF ( do_ks ) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_h_e(j)%matrix, & - qs_ot_env(ispin)%matrix_gx,alpha_scalar=0.0_dp,beta_scalar=-qs_ot_env(1)%ds_min,error=error) + qs_ot_env(ispin)%matrix_gx,alpha_scalar=0.0_dp,beta_scalar=-qs_ot_env(1)%ds_min) ENDDO IF (qs_ot_env(1)%settings%do_rotation) THEN DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx,qs_ot_env(ispin)%rot_mat_gx,tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+0.5_dp*tmp CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_h_e(j)%matrix, & - qs_ot_env(ispin)%rot_mat_gx,alpha_scalar=0.0_dp,beta_scalar=-qs_ot_env(1)%ds_min,error=error) + qs_ot_env(ispin)%rot_mat_gx,alpha_scalar=0.0_dp,beta_scalar=-qs_ot_env(1)%ds_min) ENDDO ENDIF END IF @@ -1006,12 +986,12 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) DO ispin=1,nspin CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_h_e(j)%matrix, & qs_ot_env(ispin)%matrix_h_e(i)%matrix, & - tmp,error=error) + tmp) qs_ot_env(1)%ls_diis(i,j)=qs_ot_env(1)%ls_diis(i,j)+tmp IF (qs_ot_env(ispin)%settings%do_rotation) THEN CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_h_e(j)%matrix, & qs_ot_env(ispin)%rot_mat_h_e(i)%matrix, & - tmp,error=error) + tmp) qs_ot_env(1)%ls_diis(i,j)=qs_ot_env(1)%ls_diis(i,j)+0.5_dp*tmp ENDIF ENDDO @@ -1028,12 +1008,12 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) DO ispin=1,nspin CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx, & qs_ot_env(ispin)%matrix_h_e(i)%matrix, & - tmp,error=error) + tmp) qs_ot_env(1)%ls_diis(i,j)=qs_ot_env(1)%ls_diis(i,j)-qs_ot_env(1)%ds_min * tmp IF (qs_ot_env(ispin)%settings%do_rotation) THEN CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_gx, & qs_ot_env(ispin)%rot_mat_h_e(i)%matrix, & - tmp,error=error) + tmp) qs_ot_env(1)%ls_diis(i,j)=qs_ot_env(1)%ls_diis(i,j)-qs_ot_env(1)%ds_min * 0.5_dp * tmp ENDIF ENDDO @@ -1066,28 +1046,28 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin ! OK, add the vectors now - CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp) DO i=1, diis_bound CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_e(i)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i),error=error) + alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i)) ENDDO DO i=1, diis_bound CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_x(i)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i),error=error) + alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i)) ENDDO IF (qs_ot_env(ispin)%settings%do_rotation) THEN - CALL cp_dbcsr_set(qs_ot_env(ispin)%rot_mat_x,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%rot_mat_x,0.0_dp) DO i=1, diis_bound CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_x, & qs_ot_env(ispin)%rot_mat_h_e(i)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i),error=error) + alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i)) ENDDO DO i=1, diis_bound CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_x, & qs_ot_env(ispin)%rot_mat_h_x(i)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i),error=error) + alpha_scalar=1.0_dp,beta_scalar=qs_ot_env(1)%c_diis(i)) ENDDO ENDIF ENDDO @@ -1115,17 +1095,17 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) IF ( do_ks ) THEN DO ispin=1,nspin CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_h_x(j)%matrix, & - qs_ot_env(ispin)%matrix_gx, tmp,error=error) + qs_ot_env(ispin)%matrix_gx, tmp) tr_xold_gx=tr_xold_gx+tmp CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_x, & - qs_ot_env(ispin)%matrix_gx, tmp,error=error) + qs_ot_env(ispin)%matrix_gx, tmp) tr_xnew_gx=tr_xnew_gx+tmp IF (qs_ot_env(ispin)%settings%do_rotation) THEN CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_h_x(j)%matrix, & - qs_ot_env(ispin)%rot_mat_gx, tmp,error=error) + qs_ot_env(ispin)%rot_mat_gx, tmp) tr_xold_gx=tr_xold_gx+0.5_dp*tmp CALL cp_dbcsr_trace(qs_ot_env(ispin)%rot_mat_x, & - qs_ot_env(ispin)%rot_mat_gx, tmp,error=error) + qs_ot_env(ispin)%rot_mat_gx, tmp) tr_xnew_gx=tr_xnew_gx+0.5_dp*tmp ENDIF ENDDO @@ -1150,21 +1130,21 @@ SUBROUTINE ot_diis_step(qs_ot_env,error) qs_ot_env(1)%OT_METHOD_FULL="OT SD" IF ( do_ks ) THEN DO ispin=1,nspin - CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp) CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_e(j)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_x(j)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) IF (qs_ot_env(ispin)%settings%do_rotation) THEN - CALL cp_dbcsr_set(qs_ot_env(ispin)%rot_mat_x,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%rot_mat_x,0.0_dp) CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_x, & qs_ot_env(ispin)%rot_mat_h_e(j)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) CALL cp_dbcsr_add(qs_ot_env(ispin)%rot_mat_x, & qs_ot_env(ispin)%rot_mat_h_x(j)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) ENDIF ENDDO END IF @@ -1184,12 +1164,10 @@ END SUBROUTINE ot_diis_step ! ***************************************************************************** !> \brief Energy minimizer by Broyden's method !> \param qs_ot_env variable to control minimizer behaviour -!> \param error variable to control error logging, stopping,... !> \author Kurt Baarman (09.2010) ! ***************************************************************************** -SUBROUTINE ot_broyden_step(qs_ot_env,error) +SUBROUTINE ot_broyden_step(qs_ot_env) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_broyden_step', & routineP = moduleN//':'//routineN @@ -1264,31 +1242,31 @@ SUBROUTINE ot_broyden_step(qs_ot_env,error) j = MOD(qs_ot_env(1)%diis_iter,diis_m)+1 ! index in the circular array DO ispin=1,nspin - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_h_x(j)%matrix,qs_ot_env(ispin)%matrix_x,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_h_x(j)%matrix,qs_ot_env(ispin)%matrix_x) ENDDO IF (ASSOCIATED(qs_ot_env(1)%preconditioner)) THEN qs_ot_env(1)%gnorm=0.0_dp DO ispin=1,nspin CALL apply_preconditioner(qs_ot_env(ispin)%preconditioner, & - qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_h_e(j)%matrix,error=error) + qs_ot_env(ispin)%matrix_gx, qs_ot_env(ispin)%matrix_h_e(j)%matrix) CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_h_e(j)%matrix, & - tmp,error=error) + tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp ENDDO IF (qs_ot_env(1)%gnorm .LT. 0.0_dp) THEN WRITE(cp_logger_get_default_unit_nr(logger),*) "WARNING Preconditioner not positive definite !" ENDIF DO ispin=1,nspin - CALL cp_dbcsr_scale(qs_ot_env(ispin)%matrix_h_e(j)%matrix,-1.0_dp,error=error) + CALL cp_dbcsr_scale(qs_ot_env(ispin)%matrix_h_e(j)%matrix,-1.0_dp) ENDDO ELSE qs_ot_env(1)%gnorm=0.0_dp DO ispin=1,nspin - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx,qs_ot_env(ispin)%matrix_gx,tmp) qs_ot_env(1)%gnorm=qs_ot_env(1)%gnorm+tmp CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_h_e(j)%matrix, & - qs_ot_env(ispin)%matrix_gx,alpha_scalar=0.0_dp,beta_scalar=-1.0_dp,error=error) + qs_ot_env(ispin)%matrix_gx,alpha_scalar=0.0_dp,beta_scalar=-1.0_dp) ENDDO ENDIF @@ -1325,45 +1303,45 @@ SUBROUTINE ot_broyden_step(qs_ot_env,error) DO i=1,diis_bound CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix, & - qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix,tmp,error=error) + qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix,tmp) S(i,i) = S(i,i) + tmp CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix, & - qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix,tmp,error=error) + qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix,tmp) S(i+diis_bound,i+diis_bound) = S(i+diis_bound,i+diis_bound) +tmp CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix, & - qs_ot_env(ispin)%matrix_x,tmp,error=error) + qs_ot_env(ispin)%matrix_x,tmp) S(i,2*diis_bound+1) = S(i,2*diis_bound+1) + tmp S(i,2*diis_bound+1) = S(2*diis_bound+1,i) CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix, & - qs_ot_env(ispin)%matrix_x,tmp,error=error) + qs_ot_env(ispin)%matrix_x,tmp) S(i+diis_bound,2*diis_bound+1) = S(i+diis_bound,2*diis_bound+1) + tmp S(i+diis_bound,2*diis_bound+1) = S(2*diis_bound+1,diis_bound+i) DO k=(i+1),diis_bound CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix, & qs_ot_env(ispin)%matrix_h_x(circ_index(k))%matrix, & - tmp,error=error) + tmp) S(i,k) = S(i,k) + tmp S(k,i) = S(i,k) CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix, & qs_ot_env(ispin)%matrix_h_e(circ_index(k))%matrix, & - tmp,error=error) + tmp) S(diis_bound+i,diis_bound+k) = S(diis_bound+i,diis_bound+k) + tmp S(diis_bound+k,diis_bound+i) = S(diis_bound+i,diis_bound+k) ENDDO DO k=1,diis_bound CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix, & - qs_ot_env(ispin)%matrix_h_e(circ_index(k))%matrix,tmp,error=error) + qs_ot_env(ispin)%matrix_h_e(circ_index(k))%matrix,tmp) S(i,k+diis_bound) = S(i,k+diis_bound) + tmp S(k+diis_bound,i) = S(i,k+diis_bound) ENDDO ENDDO - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_x, qs_ot_env(ispin)%matrix_x,tmp,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_x, qs_ot_env(ispin)%matrix_x,tmp) S(2*diis_bound+1,2*diis_bound+1) = S(2*diis_bound+1,2*diis_bound+1) + tmp ENDDO @@ -1382,22 +1360,22 @@ SUBROUTINE ot_broyden_step(qs_ot_env,error) CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix, & qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix, & - tmp,error=error) + tmp) tmp2 = tmp2+tmp CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i-1))%matrix, & qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix, & - tmp,error=error) + tmp) tmp2 = tmp2-tmp CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix, & qs_ot_env(ispin)%matrix_h_e(circ_index(i-1))%matrix, & - tmp,error=error) + tmp) tmp2 = tmp2-tmp CALL cp_dbcsr_trace( & qs_ot_env(ispin)%matrix_h_x(circ_index(i-1))%matrix, & qs_ot_env(ispin)%matrix_h_e(circ_index(i-1))%matrix, & - tmp,error=error) + tmp) tmp2 = tmp2+tmp ENDDO qs_ot_env(1)%c_broy(i-1) = tmp2 @@ -1412,13 +1390,13 @@ SUBROUTINE ot_broyden_step(qs_ot_env,error) sigma = sigma_dec * sigma qs_ot_env(1)%OT_METHOD_FULL="OT BTRK" DO ispin=1,nspin - CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp) CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_x(i)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=(1.0_dp-gamma),error=error) + alpha_scalar=1.0_dp,beta_scalar=(1.0_dp-gamma)) CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_x(circ_index(diis_bound))%matrix,& - alpha_scalar=1.0_dp,beta_scalar=gamma,error=error) + alpha_scalar=1.0_dp,beta_scalar=gamma) ENDDO ELSE ! Construct G @@ -1456,16 +1434,16 @@ SUBROUTINE ot_broyden_step(qs_ot_env,error) ! OK, add the vectors now, this sums up to the proposed step DO ispin=1,nspin - CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp) DO i=1, diis_bound CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_e(circ_index(i))%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-x(i+diis_bound),error=error) + alpha_scalar=1.0_dp,beta_scalar=-x(i+diis_bound)) ENDDO DO i=1, diis_bound CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_x(circ_index(i))%matrix,& - alpha_scalar=1.0_dp,beta_scalar=x(i),error=error) + alpha_scalar=1.0_dp,beta_scalar=x(i)) ENDDO ENDDO @@ -1481,7 +1459,7 @@ SUBROUTINE ot_broyden_step(qs_ot_env,error) DO ispin=1,nspin CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_gx, & qs_ot_env(ispin)%matrix_x, & - tmp2,error=error) + tmp2) tmp = tmp+tmp2 ENDDO @@ -1496,11 +1474,11 @@ SUBROUTINE ot_broyden_step(qs_ot_env,error) sigma = sigma*sigma_dec CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_x(circ_index(diis_bound))%matrix,& - alpha_scalar=-1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=-1.0_dp,beta_scalar=1.0_dp) ELSE CALL cp_dbcsr_add(qs_ot_env(ispin)%matrix_x, & qs_ot_env(ispin)%matrix_h_x(circ_index(diis_bound))%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) ENDIF ENDDO ENDIF @@ -1537,12 +1515,11 @@ FUNCTION new_sigma(G, S, n) RESULT(sigma) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: eigv REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: H - TYPE(cp_error_type) :: error ALLOCATE(H(n,n)) CALL hess_G(G, S, H, n) ALLOCATE(eigv(n)) - CALL diamat_all(H(1:n,1:n), eigv, error=error) + CALL diamat_all(H(1:n,1:n), eigv) SELECT CASE(1) CASE(1) diff --git a/src/qs_ot_scf.F b/src/qs_ot_scf.F index feddf2da43..b170ead863 100644 --- a/src/qs_ot_scf.F +++ b/src/qs_ot_scf.F @@ -63,12 +63,10 @@ MODULE qs_ot_scf !> \brief ... !> \param qs_ot_env ... !> \param scf_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ot_scf_read_input(qs_ot_env,scf_section,error) + SUBROUTINE ot_scf_read_input(qs_ot_env,scf_section) TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_scf_read_input', & routineP = moduleN//':'//routineN @@ -83,21 +81,21 @@ SUBROUTINE ot_scf_read_input(qs_ot_env,scf_section,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") ! decide default settings CALL qs_ot_settings_init(qs_ot_env(1)%settings) ! use ot input new style - ot_section=>section_vals_get_subs_vals(scf_section,"OT",error=error) - CALL section_vals_get(ot_section,explicit=explicit,error=error) + ot_section=>section_vals_get_subs_vals(scf_section,"OT") + CALL section_vals_get(ot_section,explicit=explicit) - CALL ot_readwrite_input(qs_ot_env(1)%settings,ot_section,output_unit,error) + CALL ot_readwrite_input(qs_ot_env(1)%settings,ot_section,output_unit) CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") ! copy the ot settings type so it is identical nspin=SIZE(qs_ot_env) @@ -127,10 +125,9 @@ END SUBROUTINE ot_scf_read_input !> \param delta ... !> \param qs_ot_env ... !> \param input ... -!> \param error ... ! ***************************************************************************** SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & - energy_only, delta, qs_ot_env, input,error) + energy_only, delta, qs_ot_env, input) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array @@ -143,7 +140,6 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & REAL(KIND=dp) :: delta TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env TYPE(section_vals_type), POINTER :: input - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_scf_mini', & routineP = moduleN//':'//routineN @@ -165,38 +161,38 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & failure=.FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() nspin=SIZE(mo_array) ALLOCATE(occupation_numbers(nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(scaling_factor(nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (qs_ot_env(1)%settings%do_ener) THEN ALLOCATE(expectation_values(nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DO ispin=1,nspin CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,occupation_numbers=occupation_numbers(ispin)%array) ALLOCATE(scaling_factor(ispin)%array(SIZE(occupation_numbers(ispin)%array)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) scaling_factor(ispin)%array=2.0_dp*occupation_numbers(ispin)%array IF (qs_ot_env(1)%settings%do_ener) THEN ALLOCATE(expectation_values(ispin)%array(SIZE(occupation_numbers(ispin)%array)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDDO ! optimizing orbital energies somehow implies non-equivalent orbitals IF (qs_ot_env(1)%settings%do_ener) THEN - CPPrecondition(qs_ot_env(1)%settings%do_rotation,cp_failure_level,routineP,error,failure) + CPPrecondition(qs_ot_env(1)%settings%do_rotation,cp_failure_level,routineP,failure) ENDIF ! add_nondiag_energy requires do_ener IF (qs_ot_env(1)%settings%add_nondiag_energy) THEN - CPPrecondition(qs_ot_env(1)%settings%do_ener,cp_failure_level,routineP,error,failure) + CPPrecondition(qs_ot_env(1)%settings%do_ener,cp_failure_level,routineP,failure) ENDIF ! get a rotational force @@ -206,13 +202,13 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,mo_coeff_b=mo_coeff) CALL cp_dbcsr_get_info(mo_coeff,nfullrows_total=n,nfullcols_total=k) CALL cp_dbcsr_multiply('T','N',1.0_dp,mo_coeff,matrix_dedc(ispin)%matrix, & - 0.0_dp,qs_ot_env(ispin)%rot_mat_chc,error=error) - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_buf1,qs_ot_env(ispin)%rot_mat_chc,error=error) + 0.0_dp,qs_ot_env(ispin)%rot_mat_chc) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_buf1,qs_ot_env(ispin)%rot_mat_chc) - CALL cp_dbcsr_scale_by_vector(qs_ot_env(ispin)%matrix_buf1,alpha=scaling_factor(ispin)%array,side='right',error=error) + CALL cp_dbcsr_scale_by_vector(qs_ot_env(ispin)%matrix_buf1,alpha=scaling_factor(ispin)%array,side='right') ! create the derivative of the energy wrt to rot_mat_u CALL cp_dbcsr_multiply('N','N',1.0_dp,qs_ot_env(ispin)%rot_mat_u,qs_ot_env(ispin)%matrix_buf1, & - 0.0_dp,qs_ot_env(ispin)%rot_mat_dedu,error=error) + 0.0_dp,qs_ot_env(ispin)%rot_mat_dedu) ENDDO ! here we construct the derivative of the free energy with respect to the evals @@ -220,10 +216,10 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & ! the mo occupations should in principle remain unaltered IF (qs_ot_env(1)%settings%do_ener) THEN DO ispin=1,SIZE(mo_array) - CALL cp_dbcsr_get_diag(qs_ot_env(ispin)%rot_mat_chc,expectation_values(ispin)%array,error=error) + CALL cp_dbcsr_get_diag(qs_ot_env(ispin)%rot_mat_chc,expectation_values(ispin)%array) qs_ot_env(ispin)%ener_gx=expectation_values(ispin)%array CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=smear, eval_deriv=qs_ot_env(ispin)%ener_gx, error=error) + smear=smear, eval_deriv=qs_ot_env(ispin)%ener_gx) ENDDO ENDIF @@ -234,9 +230,9 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & DO ispin=1,SIZE(qs_ot_env) CALL cp_dbcsr_get_info(qs_ot_env(ispin)%rot_mat_u,nfullcols_total=k) CALL cp_dbcsr_multiply('N','N',1.0_dp,qs_ot_env(ispin)%rot_mat_u,qs_ot_env(ispin)%rot_mat_chc, & - 0.0_dp,qs_ot_env(ispin)%matrix_buf1,error=error) + 0.0_dp,qs_ot_env(ispin)%matrix_buf1) CALL cp_dbcsr_multiply('N','T',1.0_dp,qs_ot_env(ispin)%matrix_buf1,qs_ot_env(ispin)%rot_mat_u, & - 0.0_dp,qs_ot_env(ispin)%rot_mat_chc,error=error) + 0.0_dp,qs_ot_env(ispin)%rot_mat_chc) ENDDO ENDIF ENDIF @@ -249,17 +245,17 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & ! transform \tilde H to the current basis of C (assuming non-selfconsistent H) CALL cp_dbcsr_get_info(qs_ot_env(ispin)%rot_mat_u,nfullcols_total=k) CALL cp_dbcsr_multiply('T','N',1.0_dp,qs_ot_env(ispin)%rot_mat_u,qs_ot_env(ispin)%rot_mat_chc, & - 0.0_dp,qs_ot_env(ispin)%matrix_buf1,error=error) + 0.0_dp,qs_ot_env(ispin)%matrix_buf1) CALL cp_dbcsr_multiply('N','N',1.0_dp,qs_ot_env(ispin)%matrix_buf1,qs_ot_env(ispin)%rot_mat_u, & - 0.0_dp,qs_ot_env(ispin)%matrix_buf2,error=error) + 0.0_dp,qs_ot_env(ispin)%matrix_buf2) ! subtract the current ener_x from the diagonal - CALL cp_dbcsr_get_diag(qs_ot_env(ispin)%matrix_buf2,expectation_values(ispin)%array,error=error) + CALL cp_dbcsr_get_diag(qs_ot_env(ispin)%matrix_buf2,expectation_values(ispin)%array) expectation_values(ispin)%array=expectation_values(ispin)%array-qs_ot_env(ispin)%ener_x - CALL cp_dbcsr_set_diag(qs_ot_env(ispin)%matrix_buf2,expectation_values(ispin)%array,error=error) + CALL cp_dbcsr_set_diag(qs_ot_env(ispin)%matrix_buf2,expectation_values(ispin)%array) ! get nondiag energy trace (D^T D) - CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_buf2,qs_ot_env(ispin)%matrix_buf2,trace,error=error) + CALL cp_dbcsr_trace(qs_ot_env(ispin)%matrix_buf2,qs_ot_env(ispin)%matrix_buf2,trace) ener_nondiag=ener_nondiag+0.5_dp*qs_ot_env(1)%settings%nondiag_energy_strength*trace ! get gradient (again ignoring dependencies of H) @@ -270,10 +266,10 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & ! next for the rot_mat_u derivative (2 * k * \tilde H U D) CALL cp_dbcsr_multiply('N','N',1.0_dp,qs_ot_env(ispin)%rot_mat_chc,qs_ot_env(ispin)%rot_mat_u,& - 0.0_dp,qs_ot_env(ispin)%matrix_buf1,error=error) + 0.0_dp,qs_ot_env(ispin)%matrix_buf1) CALL cp_dbcsr_multiply('N','N',2.0_dp * qs_ot_env(1)%settings%nondiag_energy_strength, & qs_ot_env(ispin)%matrix_buf1,qs_ot_env(ispin)%matrix_buf2,& - 1.0_dp,qs_ot_env(ispin)%rot_mat_dedu,error=error) + 1.0_dp,qs_ot_env(ispin)%rot_mat_dedu) ENDIF ENDDO ENDIF @@ -282,26 +278,26 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & ! use it in the following, eventually, as occupations numbers get more integrated, it should become possible ! to remove this. ALLOCATE(matrix_dedc_scaled(SIZE(matrix_dedc)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,SIZE(matrix_dedc) ALLOCATE(matrix_dedc_scaled(ispin)%matrix) - CALL cp_dbcsr_init(matrix_dedc_scaled(ispin)%matrix, error=error) - CALL cp_dbcsr_copy(matrix_dedc_scaled(ispin)%matrix,matrix_dedc(ispin)%matrix,error=error) + CALL cp_dbcsr_init(matrix_dedc_scaled(ispin)%matrix) + CALL cp_dbcsr_copy(matrix_dedc_scaled(ispin)%matrix,matrix_dedc(ispin)%matrix) ! as a preconditioner, one might want to scale only with a constant, not with f(i) ! for the convergence criterium, maybe take it back out IF (qs_ot_env(1)%settings%occupation_preconditioner) THEN scaling_factor(ispin)%array=2.0_dp ENDIF - CALL cp_dbcsr_scale_by_vector(matrix_dedc_scaled(ispin)%matrix,alpha=scaling_factor(ispin)%array,side='right',error=error) + CALL cp_dbcsr_scale_by_vector(matrix_dedc_scaled(ispin)%matrix,alpha=scaling_factor(ispin)%array,side='right') ENDDO ! notice we use qs_ot_env(1) for driving all output and the minimization in case of LSD qs_ot_env(1)%etotal=energy+ener_nondiag output_unit = cp_print_key_unit_nr(logger,input,"DFT%SCF%PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) - CALL ot_mini(qs_ot_env,matrix_dedc_scaled,output_unit,error=error) + extension=".scfLog") + CALL ot_mini(qs_ot_env,matrix_dedc_scaled,output_unit) delta =qs_ot_env(1)%delta energy_only =qs_ot_env(1)%energy_only @@ -314,24 +310,24 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & CASE("TOD") IF (ASSOCIATED(matrix_s)) THEN CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_s,qs_ot_env(ispin)%matrix_x, & - 0.0_dp,qs_ot_env(ispin)%matrix_sx, error=error) + 0.0_dp,qs_ot_env(ispin)%matrix_sx) ELSE - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin)%matrix_x,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin)%matrix_x) ENDIF - CALL qs_ot_get_p(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin),error=error) - CALL qs_ot_get_orbitals(mo_coeff,qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin),error=error) + CALL qs_ot_get_p(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin)) + CALL qs_ot_get_orbitals(mo_coeff,qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)) CASE("REF") CALL qs_ot_get_orbitals_ref(mo_coeff,matrix_s,qs_ot_env(ispin)%matrix_x,& qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin)%matrix_gx_old,& qs_ot_env(ispin)%matrix_dx,qs_ot_env(ispin),qs_ot_env(1),& - output_unit,error=error) + output_unit) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"Algorithm not yet implemented") END SELECT ENDDO IF (qs_ot_env(1)%restricted) THEN - CALL mo_set_restrict(mo_array,convert_dbcsr=.TRUE.,error=error) + CALL mo_set_restrict(mo_array,convert_dbcsr=.TRUE.) ENDIF ! ! obtain the new set of OT eigenvalues and set the occupations accordingly @@ -340,35 +336,35 @@ SUBROUTINE ot_scf_mini(mo_array,matrix_dedc,smear,matrix_s,energy, & DO ispin=1,SIZE(mo_array) mo_array(ispin)%mo_set%eigenvalues=qs_ot_env(ispin)%ener_x CALL set_mo_occupation(mo_set=mo_array(ispin)%mo_set,& - smear=smear, error=error) + smear=smear) ENDDO ENDIF ! cleanup CALL cp_print_key_finished_output(output_unit,logger,input,& - "DFT%SCF%PRINT%PROGRAM_RUN_INFO", error=error) + "DFT%SCF%PRINT%PROGRAM_RUN_INFO") DO ispin=1,SIZE(scaling_factor) DEALLOCATE(scaling_factor(ispin)%array,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(scaling_factor,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (qs_ot_env(1)%settings%do_ener) THEN DO ispin=1,SIZE(expectation_values) DEALLOCATE(expectation_values(ispin)%array,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(expectation_values,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(occupation_numbers,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,SIZE(matrix_dedc_scaled) - CALL cp_dbcsr_release(matrix_dedc_scaled(ispin)%matrix, error=error) + CALL cp_dbcsr_release(matrix_dedc_scaled(ispin)%matrix) DEALLOCATE(matrix_dedc_scaled(ispin)%matrix) ENDDO DEALLOCATE(matrix_dedc_scaled,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -384,9 +380,8 @@ END SUBROUTINE ot_scf_mini !> \param qs_ot_env ... !> \param matrix_ks ... !> \param broyden_adaptive_sigma ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ot_scf_init ( mo_array, matrix_s, qs_ot_env, matrix_ks, broyden_adaptive_sigma, error ) + SUBROUTINE ot_scf_init ( mo_array, matrix_s, qs_ot_env, matrix_ks, broyden_adaptive_sigma) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mo_array @@ -394,7 +389,6 @@ SUBROUTINE ot_scf_init ( mo_array, matrix_s, qs_ot_env, matrix_ks, broyden_adapt TYPE(qs_ot_type), DIMENSION(:), POINTER :: qs_ot_env TYPE(cp_dbcsr_type), POINTER :: matrix_ks REAL(KIND=dp) :: broyden_adaptive_sigma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_scf_init', & routineP = moduleN//':'//routineN @@ -412,10 +406,10 @@ SUBROUTINE ot_scf_init ( mo_array, matrix_s, qs_ot_env, matrix_ks, broyden_adapt CALL stop_program(routineN,moduleN,__LINE__,"Shouldn't get there") ! we do ot then copy fm to dbcsr ! allocate that somewhere else ! fm -> dbcsr - CALL cp_dbcsr_init_p(mo_array(ispin)%mo_set%mo_coeff_b, error=error) + CALL cp_dbcsr_init_p(mo_array(ispin)%mo_set%mo_coeff_b) CALL cp_dbcsr_m_by_n_from_row_template(mo_array(ispin)%mo_set%mo_coeff_b,template=matrix_ks,& n=mo_array(ispin)%mo_set%nmo,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) ENDIF ENDDO @@ -432,46 +426,46 @@ SUBROUTINE ot_scf_init ( mo_array, matrix_s, qs_ot_env, matrix_ks, broyden_adapt DO ispin=1,nspin CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,mo_coeff_b=mo_coeff,mo_coeff=mo_coeff_fm) - CALL copy_fm_to_dbcsr(mo_coeff_fm,mo_coeff, error=error)!fm -> dbcsr + CALL copy_fm_to_dbcsr(mo_coeff_fm,mo_coeff)!fm -> dbcsr CALL cp_dbcsr_get_info(mo_coeff, nfullrows_total=n, nfullcols_total=k) ! allocate - CALL qs_ot_allocate(qs_ot_env(ispin),matrix_ks,mo_coeff_fm%matrix_struct,error=error) + CALL qs_ot_allocate(qs_ot_env(ispin),matrix_ks,mo_coeff_fm%matrix_struct) ! set c0,sc0 - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_c0,mo_coeff,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_c0,mo_coeff) IF (ASSOCIATED(matrix_s)) THEN CALL cp_dbcsr_multiply('N','N',1.0_dp,matrix_s,qs_ot_env(ispin)%matrix_c0, & - 0.0_dp,qs_ot_env(ispin)%matrix_sc0,error=error) + 0.0_dp,qs_ot_env(ispin)%matrix_sc0) ELSE - CALL cp_dbcsr_copy(qs_ot_env ( ispin ) % matrix_sc0, qs_ot_env ( ispin ) % matrix_c0, error = error ) + CALL cp_dbcsr_copy(qs_ot_env ( ispin ) % matrix_sc0, qs_ot_env ( ispin ) % matrix_c0) ENDIF ! init - CALL qs_ot_init(qs_ot_env(ispin),error=error) + CALL qs_ot_init(qs_ot_env(ispin)) ! set x - CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp,error=error) - CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_sx,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_x,0.0_dp) + CALL cp_dbcsr_set(qs_ot_env(ispin)%matrix_sx,0.0_dp) IF (qs_ot_env(ispin)%settings%do_rotation) THEN - CALL cp_dbcsr_set(qs_ot_env(ispin)%rot_mat_x,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env(ispin)%rot_mat_x,0.0_dp) ENDIF IF (qs_ot_env(ispin)%settings%do_ener) THEN is_equal=SIZE(qs_ot_env ( ispin ) % ener_x)==SIZE(mo_array(ispin)%mo_set%eigenvalues) - CPPostcondition(is_equal,cp_failure_level,routineP,error,failure) + CPPostcondition(is_equal,cp_failure_level,routineP,failure) qs_ot_env ( ispin ) % ener_x = mo_array(ispin)%mo_set%eigenvalues ENDIF SELECT CASE(qs_ot_env(1)%settings%ot_algorithm) CASE("TOD") ! get c - CALL qs_ot_get_p(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin),error=error) + CALL qs_ot_get_p(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin)) CASE("REF") - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_c0,error=error) - CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin)%matrix_sc0,error=error) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_x,qs_ot_env(ispin)%matrix_c0) + CALL cp_dbcsr_copy(qs_ot_env(ispin)%matrix_sx,qs_ot_env(ispin)%matrix_sc0) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"Algorithm not yet implemented") END SELECT @@ -483,14 +477,12 @@ END SUBROUTINE ot_scf_init ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ot_scf_destroy(qs_ot_env,error) + SUBROUTINE ot_scf_destroy(qs_ot_env) TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error - CALL qs_ot_destroy(qs_ot_env,error=error) + CALL qs_ot_destroy(qs_ot_env) END SUBROUTINE ot_scf_destroy diff --git a/src/qs_ot_types.F b/src/qs_ot_types.F index 0799ae6f7c..992b21d8e3 100644 --- a/src/qs_ot_types.F +++ b/src/qs_ot_types.F @@ -248,11 +248,9 @@ END SUBROUTINE qs_ot_settings_init ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_init(qs_ot_env,error) + SUBROUTINE qs_ot_init(qs_ot_env) TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error qs_ot_env%OT_energy(:)=0.0_dp qs_ot_env%OT_pos(:)=0.0_dp @@ -265,20 +263,20 @@ SUBROUTINE qs_ot_init(qs_ot_env,error) qs_ot_env%ds_min=qs_ot_env%settings%ds_min qs_ot_env%os_valid=.FALSE. - CALL cp_dbcsr_set(qs_ot_env%matrix_gx,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env%matrix_gx,0.0_dp) IF (qs_ot_env%use_dx) & - CALL cp_dbcsr_set(qs_ot_env%matrix_dx,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env%matrix_dx,0.0_dp) IF (qs_ot_env%use_gx_old) & - CALL cp_dbcsr_set(qs_ot_env%matrix_gx_old,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env%matrix_gx_old,0.0_dp) IF (qs_ot_env%settings%do_rotation) THEN - CALL cp_dbcsr_set(qs_ot_env%rot_mat_gx,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env%rot_mat_gx,0.0_dp) IF (qs_ot_env%use_dx) & - CALL cp_dbcsr_set(qs_ot_env%rot_mat_dx,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env%rot_mat_dx,0.0_dp) IF (qs_ot_env%use_gx_old) & - CALL cp_dbcsr_set(qs_ot_env%rot_mat_gx_old,0.0_dp,error=error) + CALL cp_dbcsr_set(qs_ot_env%rot_mat_gx_old,0.0_dp) ENDIF IF (qs_ot_env%settings%do_ener) THEN qs_ot_env % ener_gx ( : ) = 0.0_dp @@ -299,14 +297,12 @@ END SUBROUTINE qs_ot_init !> \param matrix_s ... !> \param fm_struct_ref ... !> \param ortho_k ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_allocate(qs_ot_env, matrix_s, fm_struct_ref, ortho_k, error) + SUBROUTINE qs_ot_allocate(qs_ot_env, matrix_s, fm_struct_ref, ortho_k) TYPE(qs_ot_type) :: qs_ot_env TYPE(cp_dbcsr_type), POINTER :: matrix_s TYPE(cp_fm_struct_type), POINTER :: fm_struct_ref INTEGER, OPTIONAL :: ortho_k - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_allocate', & routineP = moduleN//':'//routineN @@ -328,12 +324,12 @@ SUBROUTINE qs_ot_allocate(qs_ot_env, matrix_s, fm_struct_ref, ortho_k, error) NULLIFY(qs_ot_env%blacs_env) CALL cp_fm_struct_get(fm_struct_ref, nrow_global=n, ncol_global=k, & - para_env=para_env, context=context,error=error) + para_env=para_env, context=context) qs_ot_env%para_env => para_env qs_ot_env%blacs_env => context - CALL cp_para_env_retain(para_env, error) - CALL cp_blacs_env_retain(context, error) + CALL cp_para_env_retain(para_env) + CALL cp_blacs_env_retain(context) IF (PRESENT(ortho_k)) THEN my_ortho_k = ortho_k @@ -410,138 +406,138 @@ SUBROUTINE qs_ot_allocate(qs_ot_env, matrix_s, fm_struct_ref, ortho_k, error) NULLIFY(qs_ot_env%p_k_k_sym) ! COMMON MATRICES - CALL cp_dbcsr_init_p(qs_ot_env%matrix_c0, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_c0) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_c0,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_sc0, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_sc0) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_sc0,template=matrix_s,n=my_ortho_k,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_x, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_x) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_x,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_sx, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_sx) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_sx,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_gx, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_gx) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_gx,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, data_type=special_data_type,error=error) + sym=dbcsr_type_no_symmetry, data_type=special_data_type) IF (qs_ot_env%use_dx) THEN - CALL cp_dbcsr_init_p(qs_ot_env%matrix_dx, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_dx) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_dx,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, data_type=special_data_type,error=error) + sym=dbcsr_type_no_symmetry, data_type=special_data_type) ENDIF IF (qs_ot_env%use_gx_old) THEN - CALL cp_dbcsr_init_p(qs_ot_env%matrix_gx_old, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_gx_old) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_gx_old,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, data_type=special_data_type,error=error) + sym=dbcsr_type_no_symmetry, data_type=special_data_type) ENDIF SELECT CASE(qs_ot_env%settings%ot_algorithm) CASE("TOD") - CALL cp_dbcsr_init_p(qs_ot_env%matrix_p, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_p) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_p,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_r, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_r) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_r,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_sinp, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_sinp) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_sinp,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_cosp, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_cosp) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_cosp,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_sinp_b, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_sinp_b) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_sinp_b,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_cosp_b, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_cosp_b) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_cosp_b,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf1, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf1) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_buf1,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf2, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf2) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_buf2,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf3, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf3) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_buf3,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf4, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf4) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_buf4,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_os, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_os) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_os,template=matrix_s,m=my_ortho_k,n=my_ortho_k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf1_ortho, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf1_ortho) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_buf1_ortho,template=matrix_s,m=my_ortho_k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf2_ortho, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_buf2_ortho) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%matrix_buf2_ortho,template=matrix_s,m=my_ortho_k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) CASE("REF") - CALL cp_dbcsr_init_p(qs_ot_env%buf1_k_k_nosym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf1_k_k_nosym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf1_k_k_nosym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%buf2_k_k_nosym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf2_k_k_nosym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf2_k_k_nosym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%buf3_k_k_nosym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf3_k_k_nosym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf3_k_k_nosym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%buf4_k_k_nosym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf4_k_k_nosym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf4_k_k_nosym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ! It claims to be symmetric but to avoid dbcsr conusion nonsymmetric is kept - CALL cp_dbcsr_init_p(qs_ot_env%buf1_k_k_sym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf1_k_k_sym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf1_k_k_sym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%buf2_k_k_sym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf2_k_k_sym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf2_k_k_sym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%buf3_k_k_sym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf3_k_k_sym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf3_k_k_sym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ! - CALL cp_dbcsr_init_p(qs_ot_env%buf4_k_k_sym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf4_k_k_sym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%buf4_k_k_sym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ! - CALL cp_dbcsr_init_p(qs_ot_env%p_k_k_sym, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%p_k_k_sym) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%p_k_k_sym,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ! - CALL cp_dbcsr_init_p(qs_ot_env%buf1_n_k, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf1_n_k) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%buf1_n_k,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) ! IF(mixed_precision) THEN - CALL cp_dbcsr_init_p(qs_ot_env%buf1_n_k_dp, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%buf1_n_k_dp) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%buf1_n_k_dp,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) ENDIF ! @@ -551,16 +547,16 @@ SUBROUTINE qs_ot_allocate(qs_ot_env, matrix_s, fm_struct_ref, ortho_k, error) qs_ot_env%settings%ot_method.eq."BROY" ) THEN NULLIFY(qs_ot_env%matrix_h_e) NULLIFY(qs_ot_env%matrix_h_x) - CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%matrix_h_e,m_diis,error=error) - CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%matrix_h_x,m_diis,error=error) + CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%matrix_h_e,m_diis) + CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%matrix_h_x,m_diis) DO i=1,m_diis - CALL cp_dbcsr_init_p(qs_ot_env%matrix_h_x(i)%matrix, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_h_x(i)%matrix) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_h_x(i)%matrix,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, data_type=special_data_type, error=error) + sym=dbcsr_type_no_symmetry, data_type=special_data_type) - CALL cp_dbcsr_init_p(qs_ot_env%matrix_h_e(i)%matrix, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%matrix_h_e(i)%matrix) CALL cp_dbcsr_m_by_n_from_row_template(qs_ot_env%matrix_h_e(i)%matrix,template=matrix_s,n=k,& - sym=dbcsr_type_no_symmetry, data_type=special_data_type, error=error) + sym=dbcsr_type_no_symmetry, data_type=special_data_type) ENDDO ENDIF @@ -569,56 +565,56 @@ SUBROUTINE qs_ot_allocate(qs_ot_env, matrix_s, fm_struct_ref, ortho_k, error) qs_ot_env%rot_mat_evals, qs_ot_env%rot_mat_evec, qs_ot_env%rot_mat_dedu, qs_ot_env%rot_mat_chc) IF (qs_ot_env%settings%do_rotation) THEN - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_u, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_u) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_u,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_x, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_x) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_x,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_dedu, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_dedu) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_dedu,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_chc, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_chc) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_chc,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) IF (qs_ot_env%settings%ot_method.EQ."DIIS") THEN - CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%rot_mat_h_e,m_diis,error=error) - CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%rot_mat_h_x,m_diis,error=error) + CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%rot_mat_h_e,m_diis) + CALL cp_dbcsr_allocate_matrix_set(qs_ot_env%rot_mat_h_x,m_diis) DO i=1,m_diis - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_h_e(i)%matrix, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_h_e(i)%matrix) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_h_e(i)%matrix,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_h_x(i)%matrix, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_h_x(i)%matrix) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_h_x(i)%matrix,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ENDDO ENDIF ALLOCATE(qs_ot_env%rot_mat_evals(k)) - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_evec, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_evec) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_evec,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,data_type=dbcsr_type_complex_default,error=error) + sym=dbcsr_type_no_symmetry,data_type=dbcsr_type_complex_default) - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_gx, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_gx) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_gx,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) IF (qs_ot_env%use_gx_old) THEN - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_gx_old, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_gx_old) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_gx_old,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ENDIF IF (qs_ot_env%use_dx) THEN - CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_dx, error=error) + CALL cp_dbcsr_init_p(qs_ot_env%rot_mat_dx) CALL cp_dbcsr_m_by_n_from_template(qs_ot_env%rot_mat_dx,template=matrix_s,m=k,n=k,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) ENDIF ENDIF @@ -626,26 +622,26 @@ SUBROUTINE qs_ot_allocate(qs_ot_env, matrix_s, fm_struct_ref, ortho_k, error) IF ( qs_ot_env % settings % do_ener ) THEN ncoef = k ALLOCATE ( qs_ot_env % ener_x ( ncoef ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (qs_ot_env%settings%ot_method.EQ."DIIS") THEN ALLOCATE(qs_ot_env%ener_h_e( m_diis, ncoef ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(qs_ot_env%ener_h_x( m_diis, ncoef ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF ALLOCATE ( qs_ot_env%ener_gx ( ncoef ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (qs_ot_env%use_gx_old) THEN ALLOCATE ( qs_ot_env%ener_gx_old ( ncoef ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF (qs_ot_env%use_dx) THEN ALLOCATE ( qs_ot_env%ener_dx ( ncoef ), STAT = istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qs_ot_env%ener_dx = 0.0_dp ENDIF ENDIF @@ -656,11 +652,9 @@ END SUBROUTINE qs_ot_allocate ! ***************************************************************************** !> \brief ... !> \param qs_ot_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_ot_destroy(qs_ot_env,error) + SUBROUTINE qs_ot_destroy(qs_ot_env) TYPE(qs_ot_type) :: qs_ot_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_ot_destroy', & routineP = moduleN//':'//routineN @@ -670,49 +664,49 @@ SUBROUTINE qs_ot_destroy(qs_ot_env,error) failure = .FALSE. - CALL cp_para_env_release( qs_ot_env%para_env, error) - CALL cp_blacs_env_release( qs_ot_env%blacs_env, error) + CALL cp_para_env_release( qs_ot_env%para_env) + CALL cp_blacs_env_release( qs_ot_env%blacs_env) DEALLOCATE(qs_ot_env%evals) DEALLOCATE(qs_ot_env%dum) - IF(ASSOCIATED(qs_ot_env%matrix_os)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_os, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_p)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_p, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_cosp)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_cosp, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_sinp)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sinp, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_r)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_r, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_cosp_b)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_cosp_b, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_sinp_b)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sinp_b, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_buf1)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf1, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_buf2)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf2, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_buf3)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf3, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_buf4)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf4, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_buf1_ortho)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf1_ortho, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_buf2_ortho)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf2_ortho, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_c0)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_c0, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_sc0)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sc0, error=error) - IF (ASSOCIATED(qs_ot_env%matrix_psc0)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_psc0, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_x)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_x, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_sx)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sx, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_gx)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_gx, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_dx)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_dx, error=error) - IF(ASSOCIATED(qs_ot_env%matrix_gx_old)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_gx_old, error=error) - IF(ASSOCIATED(qs_ot_env%buf1_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_k_k_nosym, error=error) - IF(ASSOCIATED(qs_ot_env%buf2_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf2_k_k_nosym, error=error) - IF(ASSOCIATED(qs_ot_env%buf3_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf3_k_k_nosym, error=error) - IF(ASSOCIATED(qs_ot_env%buf4_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf4_k_k_nosym, error=error) - IF(ASSOCIATED(qs_ot_env%p_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%p_k_k_sym, error=error) - IF(ASSOCIATED(qs_ot_env%buf1_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_k_k_sym, error=error) - IF(ASSOCIATED(qs_ot_env%buf2_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf2_k_k_sym, error=error) - IF(ASSOCIATED(qs_ot_env%buf3_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf3_k_k_sym, error=error) - IF(ASSOCIATED(qs_ot_env%buf4_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf4_k_k_sym, error=error) - IF(ASSOCIATED(qs_ot_env%buf1_n_k)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_n_k, error=error) - IF(ASSOCIATED(qs_ot_env%buf1_n_k_dp)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_n_k_dp, error=error) + IF(ASSOCIATED(qs_ot_env%matrix_os)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_os) + IF(ASSOCIATED(qs_ot_env%matrix_p)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_p) + IF(ASSOCIATED(qs_ot_env%matrix_cosp)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_cosp) + IF(ASSOCIATED(qs_ot_env%matrix_sinp)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sinp) + IF(ASSOCIATED(qs_ot_env%matrix_r)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_r) + IF(ASSOCIATED(qs_ot_env%matrix_cosp_b)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_cosp_b) + IF(ASSOCIATED(qs_ot_env%matrix_sinp_b)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sinp_b) + IF(ASSOCIATED(qs_ot_env%matrix_buf1)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf1) + IF(ASSOCIATED(qs_ot_env%matrix_buf2)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf2) + IF(ASSOCIATED(qs_ot_env%matrix_buf3)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf3) + IF(ASSOCIATED(qs_ot_env%matrix_buf4)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf4) + IF(ASSOCIATED(qs_ot_env%matrix_buf1_ortho)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf1_ortho) + IF(ASSOCIATED(qs_ot_env%matrix_buf2_ortho)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_buf2_ortho) + IF(ASSOCIATED(qs_ot_env%matrix_c0)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_c0) + IF(ASSOCIATED(qs_ot_env%matrix_sc0)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sc0) + IF (ASSOCIATED(qs_ot_env%matrix_psc0)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_psc0) + IF(ASSOCIATED(qs_ot_env%matrix_x)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_x) + IF(ASSOCIATED(qs_ot_env%matrix_sx)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_sx) + IF(ASSOCIATED(qs_ot_env%matrix_gx)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_gx) + IF(ASSOCIATED(qs_ot_env%matrix_dx)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_dx) + IF(ASSOCIATED(qs_ot_env%matrix_gx_old)) CALL cp_dbcsr_release_p(qs_ot_env%matrix_gx_old) + IF(ASSOCIATED(qs_ot_env%buf1_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_k_k_nosym) + IF(ASSOCIATED(qs_ot_env%buf2_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf2_k_k_nosym) + IF(ASSOCIATED(qs_ot_env%buf3_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf3_k_k_nosym) + IF(ASSOCIATED(qs_ot_env%buf4_k_k_nosym)) CALL cp_dbcsr_release_p(qs_ot_env%buf4_k_k_nosym) + IF(ASSOCIATED(qs_ot_env%p_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%p_k_k_sym) + IF(ASSOCIATED(qs_ot_env%buf1_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_k_k_sym) + IF(ASSOCIATED(qs_ot_env%buf2_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf2_k_k_sym) + IF(ASSOCIATED(qs_ot_env%buf3_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf3_k_k_sym) + IF(ASSOCIATED(qs_ot_env%buf4_k_k_sym)) CALL cp_dbcsr_release_p(qs_ot_env%buf4_k_k_sym) + IF(ASSOCIATED(qs_ot_env%buf1_n_k)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_n_k) + IF(ASSOCIATED(qs_ot_env%buf1_n_k_dp)) CALL cp_dbcsr_release_p(qs_ot_env%buf1_n_k_dp) IF (qs_ot_env%settings%ot_method.eq."DIIS" .OR. & qs_ot_env%settings%ot_method.eq."BROY") THEN - CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%matrix_h_x,error=error) - CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%matrix_h_e,error=error) + CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%matrix_h_x) + CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%matrix_h_e) DEALLOCATE(qs_ot_env%ls_diis) DEALLOCATE(qs_ot_env%lss_diis) DEALLOCATE(qs_ot_env%c_diis) @@ -723,42 +717,42 @@ SUBROUTINE qs_ot_destroy(qs_ot_env,error) IF (qs_ot_env%settings%do_rotation) THEN - IF(ASSOCIATED(qs_ot_env%rot_mat_u)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_u, error=error) - IF(ASSOCIATED(qs_ot_env%rot_mat_x)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_x, error=error) - IF(ASSOCIATED(qs_ot_env%rot_mat_dedu)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_dedu, error=error) - IF(ASSOCIATED(qs_ot_env%rot_mat_chc)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_chc, error=error) + IF(ASSOCIATED(qs_ot_env%rot_mat_u)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_u) + IF(ASSOCIATED(qs_ot_env%rot_mat_x)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_x) + IF(ASSOCIATED(qs_ot_env%rot_mat_dedu)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_dedu) + IF(ASSOCIATED(qs_ot_env%rot_mat_chc)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_chc) IF (qs_ot_env%settings%ot_method.EQ."DIIS") THEN - CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%rot_mat_h_x,error=error) - CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%rot_mat_h_e,error=error) + CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%rot_mat_h_x) + CALL cp_dbcsr_deallocate_matrix_set(qs_ot_env%rot_mat_h_e) ENDIF DEALLOCATE(qs_ot_env%rot_mat_evals) - IF(ASSOCIATED(qs_ot_env%rot_mat_evec)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_evec, error=error) - IF(ASSOCIATED(qs_ot_env%rot_mat_gx)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_gx, error=error) - IF(ASSOCIATED(qs_ot_env%rot_mat_gx_old)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_gx_old, error=error) - IF(ASSOCIATED(qs_ot_env%rot_mat_dx)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_dx, error=error) + IF(ASSOCIATED(qs_ot_env%rot_mat_evec)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_evec) + IF(ASSOCIATED(qs_ot_env%rot_mat_gx)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_gx) + IF(ASSOCIATED(qs_ot_env%rot_mat_gx_old)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_gx_old) + IF(ASSOCIATED(qs_ot_env%rot_mat_dx)) CALL cp_dbcsr_release_p(qs_ot_env%rot_mat_dx) ENDIF IF (qs_ot_env%settings%do_ener) THEN DEALLOCATE ( qs_ot_env % ener_x, STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE ( qs_ot_env % ener_gx, STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (qs_ot_env%settings%ot_method.EQ."DIIS") THEN DEALLOCATE (qs_ot_env % ener_h_x, STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (qs_ot_env % ener_h_e, STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF (qs_ot_env%use_dx) THEN DEALLOCATE ( qs_ot_env % ener_dx, STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF IF (qs_ot_env%use_gx_old) THEN DEALLOCATE ( qs_ot_env % ener_gx_old, STAT=istat ) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF END IF @@ -769,13 +763,11 @@ END SUBROUTINE qs_ot_destroy !> \param settings ... !> \param ot_section ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) + SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit) TYPE(qs_ot_settings_type) :: settings TYPE(section_vals_type), POINTER :: ot_section INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_readwrite_input', & routineP = moduleN//':'//routineN @@ -790,7 +782,7 @@ SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) CALL timeset(routineN,handle) ! choose algorithm - CALL section_vals_val_get(ot_section,"ALGORITHM",i_val=ot_algorithm,error=error) + CALL section_vals_val_get(ot_section,"ALGORITHM",i_val=ot_algorithm) SELECT CASE(ot_algorithm) CASE (ot_algo_taylor_or_diag) settings%ot_algorithm="TOD" @@ -802,36 +794,35 @@ SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) END SELECT ! irac input - CALL section_vals_val_get(ot_section,"IRAC_DEGREE",i_val=settings%irac_degree,error=error) + CALL section_vals_val_get(ot_section,"IRAC_DEGREE",i_val=settings%irac_degree) IF ( settings%irac_degree < 2 .OR. settings%irac_degree > 4 ) THEN CALL stop_program(routineN,moduleN,__LINE__,"READ OT IRAC_DEGREE: Value unknown") ENDIF - CALL section_vals_val_get(ot_section,"MAX_IRAC",i_val=settings%max_irac,error=error) + CALL section_vals_val_get(ot_section,"MAX_IRAC",i_val=settings%max_irac) IF(settings%max_irac < 1) THEN CALL stop_program(routineN,moduleN,__LINE__,"READ OT MAX_IRAC: VALUE MUST BE GREATER THAN ZERO") ENDIF - CALL section_vals_val_get(ot_section,"EPS_IRAC_FILTER_MATRIX",r_val=settings%eps_irac_filter_matrix,& -error=error) - CALL section_vals_val_get(ot_section,"EPS_IRAC",r_val=settings%eps_irac,error=error) + CALL section_vals_val_get(ot_section,"EPS_IRAC_FILTER_MATRIX",r_val=settings%eps_irac_filter_matrix) + CALL section_vals_val_get(ot_section,"EPS_IRAC",r_val=settings%eps_irac) IF(settings%eps_irac < 0.0_dp) THEN CALL stop_program(routineN,moduleN,__LINE__,"READ OT EPS_IRAC: VALUE MUST BE GREATER THAN ZERO") ENDIF - CALL section_vals_val_get(ot_section,"EPS_IRAC_QUICK_EXIT",r_val=settings%eps_irac_quick_exit,error=error) + CALL section_vals_val_get(ot_section,"EPS_IRAC_QUICK_EXIT",r_val=settings%eps_irac_quick_exit) IF(settings%eps_irac_quick_exit < 0.0_dp) THEN CALL stop_program(routineN,moduleN,__LINE__,"READ OT EPS_IRAC_QUICK_EXIT: VALUE MUST BE GREATER THAN ZERO") ENDIF - CALL section_vals_val_get(ot_section,"EPS_IRAC_SWITCH",r_val=settings%eps_irac_switch,error=error) + CALL section_vals_val_get(ot_section,"EPS_IRAC_SWITCH",r_val=settings%eps_irac_switch) IF(settings%eps_irac_switch < 0.0_dp) THEN CALL stop_program(routineN,moduleN,__LINE__,"READ OT EPS_IRAC_SWITCH: VALUE MUST BE GREATER THAN ZERO") ENDIF - CALL section_vals_val_get(ot_section,"MIXED_PRECISION",l_val=settings%mixed_precision,error=error) + CALL section_vals_val_get(ot_section,"MIXED_PRECISION",l_val=settings%mixed_precision) IF(settings%mixed_precision.AND.ot_algorithm.NE.ot_algo_irac) THEN CALL stop_program(routineN,moduleN,__LINE__,"MIXED_PRECISION implemented only for IRAC so far") ENDIF - CALL section_vals_val_get(ot_section,"ORTHO_IRAC",i_val=ot_ortho_irac,error=error) + CALL section_vals_val_get(ot_section,"ORTHO_IRAC",i_val=ot_ortho_irac) SELECT CASE(ot_ortho_irac) CASE(ot_chol_irac) settings%ortho_irac="CHOL" @@ -843,9 +834,9 @@ SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) CALL stop_program(routineN,moduleN,__LINE__,"READ OT ORTHO_IRAC: Value unknown") END SELECT - CALL section_vals_val_get(ot_section,"ON_THE_FLY_LOC",l_val=settings%on_the_fly_loc,error=error) + CALL section_vals_val_get(ot_section,"ON_THE_FLY_LOC",l_val=settings%on_the_fly_loc) - CALL section_vals_val_get(ot_section,"MINIMIZER",i_val=ot_method,error=error) + CALL section_vals_val_get(ot_section,"MINIMIZER",i_val=ot_method) ! compatibility SELECT CASE(ot_method) CASE (ot_mini_sd) @@ -854,25 +845,25 @@ SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) settings%ot_method="CG" CASE (ot_mini_diis) settings%ot_method="DIIS" - CALL section_vals_val_get(ot_section,"N_HISTORY_VEC",i_val=settings%diis_m,error=error) + CALL section_vals_val_get(ot_section,"N_HISTORY_VEC",i_val=settings%diis_m) CASE (ot_mini_broyden) - CALL section_vals_val_get(ot_section,"N_HISTORY_VEC",i_val=settings%diis_m,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_BETA", r_val=settings%broyden_beta,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_GAMMA",r_val=settings%broyden_gamma,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_SIGMA",r_val=settings%broyden_sigma,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_ETA", r_val=settings%broyden_eta,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_OMEGA", r_val=settings%broyden_omega,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_SIGMA_DECREASE", r_val=settings%broyden_sigma_decrease,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_SIGMA_MIN", r_val=settings%broyden_sigma_min,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_FORGET_HISTORY", l_val=settings%broyden_forget_history,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_ADAPTIVE_SIGMA", l_val=settings%broyden_adaptive_sigma,error=error) - CALL section_vals_val_get(ot_section,"BROYDEN_ENABLE_FLIP", l_val=settings%broyden_enable_flip,error=error) + CALL section_vals_val_get(ot_section,"N_HISTORY_VEC",i_val=settings%diis_m) + CALL section_vals_val_get(ot_section,"BROYDEN_BETA", r_val=settings%broyden_beta) + CALL section_vals_val_get(ot_section,"BROYDEN_GAMMA",r_val=settings%broyden_gamma) + CALL section_vals_val_get(ot_section,"BROYDEN_SIGMA",r_val=settings%broyden_sigma) + CALL section_vals_val_get(ot_section,"BROYDEN_ETA", r_val=settings%broyden_eta) + CALL section_vals_val_get(ot_section,"BROYDEN_OMEGA", r_val=settings%broyden_omega) + CALL section_vals_val_get(ot_section,"BROYDEN_SIGMA_DECREASE", r_val=settings%broyden_sigma_decrease) + CALL section_vals_val_get(ot_section,"BROYDEN_SIGMA_MIN", r_val=settings%broyden_sigma_min) + CALL section_vals_val_get(ot_section,"BROYDEN_FORGET_HISTORY", l_val=settings%broyden_forget_history) + CALL section_vals_val_get(ot_section,"BROYDEN_ADAPTIVE_SIGMA", l_val=settings%broyden_adaptive_sigma) + CALL section_vals_val_get(ot_section,"BROYDEN_ENABLE_FLIP", l_val=settings%broyden_enable_flip) settings%ot_method="BROY" CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"READ OTSCF MINIMIZER: Value unknown") END SELECT - CALL section_vals_val_get(ot_section,"SAFER_DIIS",l_val=settings%safer_diis,error=error) - CALL section_vals_val_get(ot_section,"LINESEARCH",i_val=ls_method,error=error) + CALL section_vals_val_get(ot_section,"SAFER_DIIS",l_val=settings%safer_diis) + CALL section_vals_val_get(ot_section,"LINESEARCH",i_val=ls_method) SELECT CASE(ls_method) CASE (ls_none) settings%line_search_method="NONE" @@ -882,12 +873,12 @@ SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) settings%line_search_method="3PNT" CASE (ls_gold) settings%line_search_method="GOLD" - CALL section_vals_val_get(ot_section,"GOLD_TARGET",r_val=settings%gold_target,error=error) + CALL section_vals_val_get(ot_section,"GOLD_TARGET",r_val=settings%gold_target) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"READ OTSCF LS: Value unknown") END SELECT - CALL section_vals_val_get(ot_section,"PRECOND_SOLVER",i_val=settings%precond_solver_type,error=error) + CALL section_vals_val_get(ot_section,"PRECOND_SOLVER",i_val=settings%precond_solver_type) SELECT CASE(settings%precond_solver_type) CASE(ot_precond_solver_default) settings%precond_solver_name="DEFAULT" @@ -902,10 +893,10 @@ SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) END SELECT !If these values are negative we will set them "optimal" for a given precondtioner below - CALL section_vals_val_get(ot_section,"STEPSIZE",r_val=settings%ds_min,error=error) - CALL section_vals_val_get(ot_section,"ENERGY_GAP",r_val=settings%energy_gap,error=error) + CALL section_vals_val_get(ot_section,"STEPSIZE",r_val=settings%ds_min) + CALL section_vals_val_get(ot_section,"ENERGY_GAP",r_val=settings%energy_gap) - CALL section_vals_val_get(ot_section,"PRECONDITIONER",i_val=settings%preconditioner_type,error=error) + CALL section_vals_val_get(ot_section,"PRECONDITIONER",i_val=settings%preconditioner_type) SELECT CASE(settings%preconditioner_type) CASE(ot_precond_none) settings%preconditioner_name="NONE" @@ -934,17 +925,17 @@ SUBROUTINE ot_readwrite_input(settings,ot_section,output_unit,error) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"READ OTSCF PRECONDITIONER: Value unknown") END SELECT - CALL section_vals_val_get(ot_section,"EPS_TAYLOR",r_val=settings%eps_taylor,error=error) - CALL section_vals_val_get(ot_section,"MAX_TAYLOR",i_val=settings%max_taylor,error=error) - CALL section_vals_val_get(ot_section,"ROTATION",l_val=settings%do_rotation,error=error) - CALL section_vals_val_get(ot_section,"ENERGIES",l_val=settings%do_ener,error=error) + CALL section_vals_val_get(ot_section,"EPS_TAYLOR",r_val=settings%eps_taylor) + CALL section_vals_val_get(ot_section,"MAX_TAYLOR",i_val=settings%max_taylor) + CALL section_vals_val_get(ot_section,"ROTATION",l_val=settings%do_rotation) + CALL section_vals_val_get(ot_section,"ENERGIES",l_val=settings%do_ener) CALL section_vals_val_get(ot_section,"OCCUPATION_PRECONDITIONER", & - l_val=settings%occupation_preconditioner,error=error) - CALL section_vals_val_get(ot_section,"NONDIAG_ENERGY",l_val=settings%add_nondiag_energy,error=error) + l_val=settings%occupation_preconditioner) + CALL section_vals_val_get(ot_section,"NONDIAG_ENERGY",l_val=settings%add_nondiag_energy) CALL section_vals_val_get(ot_section,"NONDIAG_ENERGY_STRENGTH",& - r_val=settings%nondiag_energy_strength,error=error) + r_val=settings%nondiag_energy_strength) ! not yet fully implemented - CPPostcondition(.NOT.settings%do_ener,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.settings%do_ener,cp_failure_level,routineP,failure) ! write OT output diff --git a/src/qs_outer_scf.F b/src/qs_outer_scf.F index 7200ea3570..60886af612 100644 --- a/src/qs_outer_scf.F +++ b/src/qs_outer_scf.F @@ -50,14 +50,12 @@ MODULE qs_outer_scf ! ***************************************************************************** !> \brief returns the number of variables that is employed in the outer loop !> \param scf_control ... -!> \param error ... !> \retval res ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - FUNCTION outer_loop_variables_count(scf_control,error) RESULT(res) + FUNCTION outer_loop_variables_count(scf_control) RESULT(res) TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res SELECT CASE(scf_control%outer_scf%type) @@ -79,14 +77,12 @@ END FUNCTION outer_loop_variables_count !> \brief computes the gradient wrt to the outer loop variables !> \param qs_env ... !> \param scf_env ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE outer_loop_gradient(qs_env, scf_env, error) + SUBROUTINE outer_loop_gradient(qs_env, scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'outer_loop_gradient', & routineP = moduleN//':'//routineN @@ -104,11 +100,11 @@ SUBROUTINE outer_loop_gradient(qs_env, scf_env, error) failure = .FALSE. CALL get_qs_env(qs_env=qs_env,scf_control=scf_control, & - dft_control=dft_control,energy=energy,error=error) - CPPrecondition(scf_control%outer_scf%have_scf,cp_failure_level,routineP,error,failure) + dft_control=dft_control,energy=energy) + CPPrecondition(scf_control%outer_scf%have_scf,cp_failure_level,routineP,failure) ihistory=scf_env%outer_scf%iter_count - CPPrecondition(ihistory<=SIZE(scf_env%outer_scf%energy,1),cp_failure_level,routineP,error,failure) + CPPrecondition(ihistory<=SIZE(scf_env%outer_scf%energy,1),cp_failure_level,routineP,failure) scf_env%outer_scf%energy(ihistory)=energy%total @@ -118,35 +114,35 @@ SUBROUTINE outer_loop_gradient(qs_env, scf_env, error) scf_env%outer_scf%variables(1,ihistory)=scf_env%iter_delta scf_env%outer_scf%gradient(1,ihistory)=scf_env%iter_delta CASE (outer_scf_ddapc_constraint) - CPPrecondition(dft_control%qs_control%ddapc_restraint,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%qs_control%ddapc_restraint,cp_failure_level,routineP,failure) DO n=1,SIZE(dft_control%qs_control%ddapc_restraint_control) NULLIFY(ddapc_restraint_control) ddapc_restraint_control=>dft_control%qs_control%ddapc_restraint_control(n)%ddapc_restraint_control is_constraint=(ddapc_restraint_control%functional_form==do_ddapc_constraint) IF(is_constraint)EXIT END DO - CPPrecondition(is_constraint,cp_failure_level,routineP,error,failure) + CPPrecondition(is_constraint,cp_failure_level,routineP,failure) scf_env%outer_scf%variables(:,ihistory)=ddapc_restraint_control%strength scf_env%outer_scf%gradient(:,ihistory) =ddapc_restraint_control%ddapc_order_p- & ddapc_restraint_control%target CASE (outer_scf_s2_constraint) - CPPrecondition(dft_control%qs_control%s2_restraint,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%qs_control%s2_restraint,cp_failure_level,routineP,failure) s2_restraint_control=>dft_control%qs_control%s2_restraint_control is_constraint=(s2_restraint_control%functional_form==do_s2_constraint) - CPPrecondition(is_constraint,cp_failure_level,routineP,error,failure) + CPPrecondition(is_constraint,cp_failure_level,routineP,failure) scf_env%outer_scf%variables(:,ihistory)=s2_restraint_control%strength scf_env%outer_scf%gradient(:,ihistory) =s2_restraint_control%s2_order_p- & s2_restraint_control%target CASE (outer_scf_becke_constraint) - CPPrecondition(dft_control%qs_control%becke_restraint,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%qs_control%becke_restraint,cp_failure_level,routineP,failure) becke_control=>dft_control%qs_control%becke_control scf_env%outer_scf%variables(:,ihistory)=becke_control%strength scf_env%outer_scf%gradient(:,ihistory) =becke_control%becke_order_p- & becke_control%target CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) @@ -157,16 +153,14 @@ END SUBROUTINE outer_loop_gradient !> \brief optimizes the parameters of the outer_scf !> \param scf_env ... !> \param scf_control ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] !> \note !> ought to be general, and independent of the actual kind of variables ! ***************************************************************************** - SUBROUTINE outer_loop_optimize(scf_env, scf_control, error) + SUBROUTINE outer_loop_optimize(scf_env, scf_control) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'outer_loop_optimize', & routineP = moduleN//':'//routineN @@ -191,7 +185,7 @@ SUBROUTINE outer_loop_optimize(scf_env, scf_control, error) SELECT CASE(optimizer_type) CASE(outer_scf_optimizer_bisect) ! bisection on the gradient, needs to be 1D - CPPrecondition(SIZE(scf_env%outer_scf%gradient(:,1))==1,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(scf_env%outer_scf%gradient(:,1))==1,cp_failure_level,routineP,failure) ! find the pair of points that bracket a zero of the gradient, with the smallest interval possible ilow=-1 ihigh=-1 @@ -231,7 +225,7 @@ SUBROUTINE outer_loop_optimize(scf_env, scf_control, error) scf_env%outer_scf%variables(:,ihistory+1)=scf_env%outer_scf%variables(:,ihistory) - & scf_control%outer_scf%step_size*scf_env%outer_scf%gradient(:,ihistory) CASE(outer_scf_optimizer_diis) - CPPrecondition(scf_control%outer_scf%diis_buffer_length>0,cp_failure_level,routineP,error,failure) + CPPrecondition(scf_control%outer_scf%diis_buffer_length>0,cp_failure_level,routineP,failure) ! set up DIIS matrix nb=MIN(ihistory,scf_control%outer_scf%diis_buffer_length) IF (nb<2) THEN @@ -252,7 +246,7 @@ SUBROUTINE outer_loop_optimize(scf_env, scf_control, error) b(:,nb+1)=-1.0_dp b(nb+1,nb+1)=0.0_dp - CALL diamat_all(b,ev,error=error) + CALL diamat_all(b,ev) a(:,:)=b DO I=1,nb+1 IF (ABS(ev(I)).LT.1.0E-12_dp) THEN @@ -272,7 +266,7 @@ SUBROUTINE outer_loop_optimize(scf_env, scf_control, error) DEALLOCATE(b,ev) ENDIF CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT EXIT ENDDO @@ -286,14 +280,12 @@ END SUBROUTINE outer_loop_optimize !> qs_env !> \param qs_env ... !> \param scf_env ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE outer_loop_update_qs_env(qs_env, scf_env, error) + SUBROUTINE outer_loop_update_qs_env(qs_env, scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'outer_loop_update_qs_env', & routineP = moduleN//':'//routineN @@ -310,7 +302,7 @@ SUBROUTINE outer_loop_update_qs_env(qs_env, scf_env, error) CALL timeset(routineN,handle) - CALL get_qs_env(qs_env=qs_env,scf_control=scf_control, dft_control=dft_control,error=error) + CALL get_qs_env(qs_env=qs_env,scf_control=scf_control, dft_control=dft_control) ihistory=scf_env%outer_scf%iter_count SELECT CASE(scf_control%outer_scf%type) @@ -331,7 +323,7 @@ SUBROUTINE outer_loop_update_qs_env(qs_env, scf_env, error) becke_control=>dft_control%qs_control%becke_control becke_control%strength=scf_env%outer_scf%variables(1,ihistory+1) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) @@ -342,16 +334,14 @@ END SUBROUTINE outer_loop_update_qs_env !> \brief uses the outer_scf_history to extrapolate new values for the variables !> and updates their value in qs_env accordingly !> \param qs_env ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] !> \note !> it assumes that the current value of qs_env still needs to be added to the history !> simple multilinear extrapolation is employed ! ***************************************************************************** - SUBROUTINE outer_loop_extrapolate(qs_env, error) + SUBROUTINE outer_loop_extrapolate(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'outer_loop_extrapolate', & routineP = moduleN//':'//routineN @@ -373,13 +363,13 @@ SUBROUTINE outer_loop_extrapolate(qs_env, error) CALL get_qs_env(qs_env,outer_scf_history=outer_scf_history, & outer_scf_ihistory=outer_scf_ihistory, & - scf_control=scf_control, dft_control=dft_control,error=error) + scf_control=scf_control, dft_control=dft_control) nvariables=SIZE(outer_scf_history,1) nhistory=SIZE(outer_scf_history,2) ALLOCATE(extrapolation(nvariables),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) - CPPrecondition(nhistory>0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) + CPPrecondition(nhistory>0,cp_failure_level,routineP,failure) ! add the current version of qs_env to the history outer_scf_ihistory=outer_scf_ihistory+1 @@ -403,9 +393,9 @@ SUBROUTINE outer_loop_extrapolate(qs_env, error) outer_scf_history(1,ivec)= & dft_control%qs_control%becke_control%strength CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL set_qs_env(qs_env,outer_scf_ihistory=outer_scf_ihistory,error=error) + CALL set_qs_env(qs_env,outer_scf_ihistory=outer_scf_ihistory) ! multilinear extrapolation nvec=MIN(nhistory,outer_scf_ihistory) @@ -429,11 +419,11 @@ SUBROUTINE outer_loop_extrapolate(qs_env, error) CASE (outer_scf_becke_constraint) dft_control%qs_control%becke_control%strength=extrapolation(1) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT DEALLOCATE(extrapolation,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/qs_overlap.F b/src/qs_overlap.F index 49bb582458..50c21c298b 100644 --- a/src/qs_overlap.F +++ b/src/qs_overlap.F @@ -98,7 +98,6 @@ MODULE qs_overlap !> \param calculate_forces (optional) !> \param matrix_p density matrix for force calculation (optional) !> \param matrixkp_p density matrix for force calculation with k_points (optional) -!> \param error CP2K error reporting !> \date 11.03.2002 !> \par History !> Enlarged functionality of this routine. Now overlap matrices based @@ -113,7 +112,7 @@ MODULE qs_overlap ! ***************************************************************************** SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& nderivative, basis_type_a, basis_type_b, sab_nl, calculate_forces,& - matrix_p, matrixkp_p, error) + matrix_p, matrixkp_p) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -129,7 +128,6 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: matrix_p TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & OPTIONAL, POINTER :: matrixkp_p - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_overlap_matrix', & routineP = moduleN//':'//routineN @@ -186,11 +184,11 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& use_cell_mapping = .FALSE. ELSEIF (PRESENT(matrixkp_s)) THEN dokp = .TRUE. - CALL get_ks_env(ks_env=ks_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_ks_env(ks_env=ks_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) use_cell_mapping = (SIZE(cell_to_index) > 1) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF NULLIFY (atomic_kind_set) @@ -199,14 +197,13 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& natom=natom,& qs_kind_set=qs_kind_set,& dbcsr_dist=dbcsr_dist,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) nimg = dft_control%nimages nkind = SIZE(qs_kind_set) ALLOCATE (atom_of_kind(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,atom_of_kind=atom_of_kind) IF (PRESENT(calculate_forces)) THEN @@ -223,52 +220,52 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& maxder = ncoset(nder) ! check for symmetry - CPPrecondition(SIZE(sab_nl) > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(sab_nl) > 0,cp_failure_level,routineP,failure) CALL get_neighbor_list_set_p(neighbor_list_sets=sab_nl,symmetric=do_symmetric) IF (do_symmetric) THEN - CPPrecondition(basis_type_a == basis_type_b,cp_failure_level,routineP,error,failure) + CPPrecondition(basis_type_a == basis_type_b,cp_failure_level,routineP,failure) END IF ! set up basis set lists ALLOCATE (basis_set_list_a(nkind),basis_set_list_b(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL basis_set_list_setup(basis_set_list_a,basis_type_a,qs_kind_set,error=error) - CALL basis_set_list_setup(basis_set_list_b,basis_type_b,qs_kind_set,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL basis_set_list_setup(basis_set_list_a,basis_type_a,qs_kind_set) + CALL basis_set_list_setup(basis_set_list_b,basis_type_b,qs_kind_set) IF(dokp) THEN - CALL cp_dbcsr_allocate_matrix_set(matrixkp_s,maxder,nimg,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrixkp_s,maxder,nimg) CALL create_sab_matrix(ks_env, matrixkp_s, matrix_name, basis_set_list_a, basis_set_list_b, & - sab_nl, do_symmetric, error) + sab_nl, do_symmetric) ELSE - CALL cp_dbcsr_allocate_matrix_set(matrix_s,maxder,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_s,maxder) CALL create_sab_matrix(ks_env, matrix_s, matrix_name, basis_set_list_a, basis_set_list_b, & - sab_nl, do_symmetric, error) + sab_nl, do_symmetric) END IF maxs = maxder IF (do_forces) THEN - CALL get_ks_env(ks_env=ks_env,force=force,virial=virial,error=error) + CALL get_ks_env(ks_env=ks_env,force=force,virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) END IF - ldsab = get_memory_usage(qs_kind_set,basis_type_a,basis_type_b,error=error) + ldsab = get_memory_usage(qs_kind_set,basis_type_a,basis_type_b) IF (do_forces) THEN ! we need density matrix for forces IF(dokp) THEN - CPPrecondition(PRESENT(matrixkp_p),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrixkp_p),cp_failure_level,routineP,failure) ELSE - CPPrecondition(PRESENT(matrix_p),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(matrix_p),cp_failure_level,routineP,failure) END IF nder = MAX(nder,1) ALLOCATE (pmat(ldsab,ldsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF maxder = ncoset(nder) ALLOCATE (oint(ldsab,ldsab,maxder),owork(ldsab,ldsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (sint(maxs),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,maxs NULLIFY (sint(i)%block) END DO @@ -308,7 +305,7 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& IF(use_cell_mapping) THEN ic = cell_to_index(cell(1),cell(2),cell(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) ELSE ic = 1 END IF @@ -335,11 +332,11 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& IF(dokp) THEN CALL cp_dbcsr_get_block_p(matrix=matrixkp_s(i,ic)%matrix,& row=irow,col=icol,BLOCK=sint(i)%block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ELSE CALL cp_dbcsr_get_block_p(matrix=matrix_s(i)%matrix,& row=irow,col=icol,BLOCK=sint(i)%block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END IF END DO IF (do_forces) THEN @@ -347,11 +344,11 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& IF(dokp) THEN CALL cp_dbcsr_get_block_p(matrix=matrixkp_p(1,ic)%matrix,& row=irow,col=icol,block=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ELSE CALL cp_dbcsr_get_block_p(matrix=matrix_p,row=irow,col=icol,& block=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) END IF END IF trans = do_symmetric .AND. (iatom > jatom) @@ -378,29 +375,29 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& CASE (0) CALL overlap_ab(la_max(iset),la_min(iset),npgfa(iset),rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),rpgfb(:,jset),zetb(:,jset),& - rab,sab=oint(:,:,1),error=error) + rab,sab=oint(:,:,1)) CASE (1) CALL overlap_ab(la_max(iset),la_min(iset),npgfa(iset),rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),rpgfb(:,jset),zetb(:,jset),& - rab,sab=oint(:,:,1),dab=oint(:,:,2:4),error=error) + rab,sab=oint(:,:,1),dab=oint(:,:,2:4)) CASE (2) CALL overlap_ab(la_max(iset),la_min(iset),npgfa(iset),rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),rpgfb(:,jset),zetb(:,jset),& - rab,sab=oint(:,:,1),dab=oint(:,:,2:4),ddab=oint(:,:,5:10),error=error) + rab,sab=oint(:,:,1),dab=oint(:,:,2:4),ddab=oint(:,:,5:10)) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (do_forces .AND. ASSOCIATED(p_block) .AND. ((iatom/=jatom) .OR. use_virial)) THEN ! Decontract P matrix block owork = 0.0_dp - CALL block_add("OUT",owork,nsgfa(iset),nsgfb(jset),p_block,sgfa,sgfb,trans=trans,error=error) + CALL block_add("OUT",owork,nsgfa(iset),nsgfb(jset),p_block,sgfa,sgfb,trans=trans) CALL decontraction(owork,pmat,scon_a(:,sgfa:),n1,nsgfa(iset),scon_b(:,sgfb:),n2,nsgfb(jset),& - trans=trans,error=error) - CALL force_trace(force_a,oint(:,:,2:4),pmat,n1,n2,3,error=error) + trans=trans) + CALL force_trace(force_a,oint(:,:,2:4),pmat,n1,n2,3) force(ikind)%overlap(:,atom_a)=force(ikind)%overlap(:,atom_a) - ff*force_a(:) force(jkind)%overlap(:,atom_b)=force(jkind)%overlap(:,atom_b) + ff*force_a(:) IF( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -f0, force_a, rab, error) + CALL virial_pair_force ( virial%pv_virial, -f0, force_a, rab) END IF END IF ! Contraction @@ -408,9 +405,9 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& f = 1.0_dp IF (ndod(i) == 1 .AND. trans) f = -1.0_dp CALL contraction(oint(:,:,i),owork,ca=scon_a(:,sgfa:),na=n1,ma=nsgfa(iset),& - cb=scon_b(:,sgfb:),nb=n2,mb=nsgfb(jset),fscale=f,trans=trans,error=error) + cb=scon_b(:,sgfb:),nb=n2,mb=nsgfb(jset),fscale=f,trans=trans) CALL block_add("IN",owork,nsgfa(iset),nsgfb(jset),sint(i)%block,& - sgfa,sgfb,trans=trans,error=error) + sgfa,sgfb,trans=trans) END DO END DO @@ -422,34 +419,34 @@ SUBROUTINE build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name,& IF(dokp) THEN DO i = 1,maxs DO ic=1,nimg - CALL cp_dbcsr_finalize(matrixkp_s(i,ic)%matrix, error=error) + CALL cp_dbcsr_finalize(matrixkp_s(i,ic)%matrix) CALL cp_dbcsr_filter(matrixkp_s(i,ic)%matrix, & - dft_control%qs_control%eps_filter_matrix, error=error) + dft_control%qs_control%eps_filter_matrix) ENDDO ENDDO ELSE DO i = 1,maxs - CALL cp_dbcsr_finalize(matrix_s(i)%matrix, error=error) + CALL cp_dbcsr_finalize(matrix_s(i)%matrix) CALL cp_dbcsr_filter(matrix_s(i)%matrix, & - dft_control%qs_control%eps_filter_matrix, error=error) + dft_control%qs_control%eps_filter_matrix) ENDDO END IF ! *** Release work storage *** DEALLOCATE (atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i=1,maxs NULLIFY (sint(i)%block) END DO DEALLOCATE (sint,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (basis_set_list_a,basis_set_list_b,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (oint,owork,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(do_forces) THEN DEALLOCATE (pmat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -466,7 +463,6 @@ END SUBROUTINE build_overlap_matrix !> \param basis_type_b basis set to be used for ket in !> \param sab_nl pair list (must be consistent with basis sets!) !> \param matrix_p density matrix for force calculation -!> \param error for error handling !> \date 11.03.2002 !> \par History !> Enlarged functionality of this routine. Now overlap matrices based @@ -480,7 +476,7 @@ END SUBROUTINE build_overlap_matrix !> \version 1.0 ! ***************************************************************************** SUBROUTINE build_overlap_force(ks_env, force, basis_type_a, basis_type_b, & - sab_nl, matrix_p, error) + sab_nl, matrix_p) TYPE(qs_ks_env_type), POINTER :: ks_env REAL(KIND=dp), DIMENSION(:, :), & @@ -489,7 +485,6 @@ SUBROUTINE build_overlap_force(ks_env, force, basis_type_a, basis_type_b, & TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl TYPE(cp_dbcsr_type), POINTER :: matrix_p - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_overlap_force', & routineP = moduleN//':'//routineN @@ -527,30 +522,30 @@ SUBROUTINE build_overlap_force(ks_env, force, basis_type_a, basis_type_b, & CALL timeset(routineN,handle) NULLIFY (qs_kind_set) - CALL get_ks_env(ks_env=ks_env,qs_kind_set=qs_kind_set,error=error) + CALL get_ks_env(ks_env=ks_env,qs_kind_set=qs_kind_set) nkind = SIZE(qs_kind_set) nder = 1 ! check for symmetry - CPPrecondition(SIZE(sab_nl) > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(sab_nl) > 0,cp_failure_level,routineP,failure) CALL get_neighbor_list_set_p(neighbor_list_sets=sab_nl,symmetric=do_symmetric) - CALL get_ks_env(ks_env=ks_env,virial=virial,error=error) + CALL get_ks_env(ks_env=ks_env,virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ! *** Allocate work storage *** - ldsab = get_memory_usage(qs_kind_set,basis_type_a,basis_type_b,error=error) + ldsab = get_memory_usage(qs_kind_set,basis_type_a,basis_type_b) ALLOCATE (sab(ldsab,ldsab),pab(ldsab,ldsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (drab(ldsab,ldsab,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! set up basis sets ALLOCATE (basis_set_list_a(nkind),basis_set_list_b(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL basis_set_list_setup(basis_set_list_a,basis_type_a,qs_kind_set,error=error) - CALL basis_set_list_setup(basis_set_list_b,basis_type_b,qs_kind_set,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL basis_set_list_setup(basis_set_list_a,basis_type_a,qs_kind_set) + CALL basis_set_list_setup(basis_set_list_b,basis_type_b,qs_kind_set) ! Loop over neighbor list CALL neighbor_list_iterator_create(nl_iterator,sab_nl) @@ -637,18 +632,18 @@ SUBROUTINE build_overlap_force(ks_env, force, basis_type_a, basis_type_b, & IF (ASSOCIATED(p_block) .AND. ((iatom/=jatom) .OR. use_virial)) THEN ! Decontract P matrix block sab = 0.0_dp - CALL block_add("OUT",sab,nsgfa(iset),nsgfb(jset),p_block,sgfa,sgfb,trans=trans,error=error) + CALL block_add("OUT",sab,nsgfa(iset),nsgfb(jset),p_block,sgfa,sgfb,trans=trans) CALL decontraction(sab,pab,scon_a(:,sgfa:),n1,nsgfa(iset),scon_b(:,sgfb:),n2,nsgfb(jset),& - trans=trans,error=error) + trans=trans) ! calculate integrals and derivatives CALL overlap_ab(la_max(iset),la_min(iset),npgfa(iset),rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),rpgfb(:,jset),zetb(:,jset),& - rab,dab=drab,error=error) - CALL force_trace(force_a,drab,pab,n1,n2,3,error=error) + rab,dab=drab) + CALL force_trace(force_a,drab,pab,n1,n2,3) force(1:3,iatom) = force(1:3,iatom) - ff*force_a(1:3) force(1:3,jatom) = force(1:3,jatom) + ff*force_a(1:3) IF( use_virial ) THEN - CALL virial_pair_force ( virial%pv_virial, -f0, force_a, rab, error) + CALL virial_pair_force ( virial%pv_virial, -f0, force_a, rab) END IF END IF @@ -660,9 +655,9 @@ SUBROUTINE build_overlap_force(ks_env, force, basis_type_a, basis_type_b, & ! *** Release work storage *** DEALLOCATE (sab,pab,drab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (basis_set_list_a,basis_set_list_b,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -678,10 +673,9 @@ END SUBROUTINE build_overlap_force !> \param basis_set_list_b Basis set used for |b> !> \param sab_nl Overlap neighbor list !> \param symmetric Is symmetry used in the neighbor list? -!> \param error CP2K error reporting ! ***************************************************************************** SUBROUTINE create_sab_matrix_1d(ks_env, matrix_s, matrix_name,& - basis_set_list_a, basis_set_list_b, sab_nl, symmetric, error) + basis_set_list_a, basis_set_list_b, sab_nl, symmetric) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -693,7 +687,6 @@ SUBROUTINE create_sab_matrix_1d(ks_env, matrix_s, matrix_name,& TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl LOGICAL, INTENT(IN) :: symmetric - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_sab_matrix_1d', & routineP = moduleN//':'//routineN @@ -713,7 +706,7 @@ SUBROUTINE create_sab_matrix_1d(ks_env, matrix_s, matrix_name,& failure = .FALSE. CALL get_ks_env(ks_env=ks_env,particle_set=particle_set,& - qs_kind_set=qs_kind_set, dbcsr_dist=dbcsr_dist,error=error) + qs_kind_set=qs_kind_set, dbcsr_dist=dbcsr_dist) natom = SIZE(particle_set) @@ -726,12 +719,12 @@ SUBROUTINE create_sab_matrix_1d(ks_env, matrix_s, matrix_name,& maxs = SIZE(matrix_s) ALLOCATE (row_blk_sizes(natom),col_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes,& - basis=basis_set_list_a,error=error) + basis=basis_set_list_a) CALL get_particle_set(particle_set, qs_kind_set, nsgf=col_blk_sizes,& - basis=basis_set_list_b,error=error) + basis=basis_set_list_b) ! prepare for allocation IF (symmetric) THEN @@ -761,14 +754,14 @@ SUBROUTINE create_sab_matrix_1d(ks_env, matrix_s, matrix_name,& CALL compress(name) CALL uppercase(name) ALLOCATE(matrix_s(i)%matrix, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_s(i)%matrix,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_s(i)%matrix) CALL cp_dbcsr_create(matrix=matrix_s(i)%matrix, & name=TRIM(name), & dist=dbcsr_dist, matrix_type=symmetry_string,& row_blk_size=row_blk_sizes, col_blk_size=col_blk_sizes, & - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_s(i)%matrix,sab_nl,error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_s(i)%matrix,sab_nl) END DO DEALLOCATE(row_blk_sizes,col_blk_sizes) @@ -785,10 +778,9 @@ END SUBROUTINE create_sab_matrix_1d !> \param basis_set_list_b Basis set used for |b> !> \param sab_nl Overlap neighbor list !> \param symmetric Is symmetry used in the neighbor list? -!> \param error CP2K error reporting ! ***************************************************************************** SUBROUTINE create_sab_matrix_2d(ks_env, matrix_s, matrix_name,& - basis_set_list_a, basis_set_list_b, sab_nl, symmetric, error) + basis_set_list_a, basis_set_list_b, sab_nl, symmetric) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -800,7 +792,6 @@ SUBROUTINE create_sab_matrix_2d(ks_env, matrix_s, matrix_name,& TYPE(neighbor_list_set_p_type), & DIMENSION(:), POINTER :: sab_nl LOGICAL, INTENT(IN) :: symmetric - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_sab_matrix_2d', & routineP = moduleN//':'//routineN @@ -821,7 +812,7 @@ SUBROUTINE create_sab_matrix_2d(ks_env, matrix_s, matrix_name,& failure = .FALSE. CALL get_ks_env(ks_env=ks_env,particle_set=particle_set,& - qs_kind_set=qs_kind_set, dbcsr_dist=dbcsr_dist,error=error) + qs_kind_set=qs_kind_set, dbcsr_dist=dbcsr_dist) natom = SIZE(particle_set) @@ -835,12 +826,12 @@ SUBROUTINE create_sab_matrix_2d(ks_env, matrix_s, matrix_name,& maxs2 = SIZE(matrix_s,2) ALLOCATE (row_blk_sizes(natom),col_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set, nsgf=row_blk_sizes,& - basis=basis_set_list_a,error=error) + basis=basis_set_list_a) CALL get_particle_set(particle_set, qs_kind_set, nsgf=col_blk_sizes,& - basis=basis_set_list_b,error=error) + basis=basis_set_list_b) ! prepare for allocation IF (symmetric) THEN @@ -871,14 +862,14 @@ SUBROUTINE create_sab_matrix_2d(ks_env, matrix_s, matrix_name,& CALL compress(name) CALL uppercase(name) ALLOCATE(matrix_s(i1,i2)%matrix, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_s(i1,i2)%matrix,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_s(i1,i2)%matrix) CALL cp_dbcsr_create(matrix=matrix_s(i1,i2)%matrix, & name=TRIM(name), & dist=dbcsr_dist, matrix_type=symmetry_string,& row_blk_size=row_blk_sizes, col_blk_size=col_blk_sizes, & - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_s(i1,i2)%matrix,sab_nl,error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_s(i1,i2)%matrix,sab_nl) END DO END DO diff --git a/src/qs_p_env_methods.F b/src/qs_p_env_methods.F index 86649985e6..4b850ac950 100644 --- a/src/qs_p_env_methods.F +++ b/src/qs_p_env_methods.F @@ -112,14 +112,12 @@ MODULE qs_p_env_methods !> \param psi0d ... !> \param orthogonal_orbitals if the orbitals are orthogonal !> \param linres_control ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE p_env_create(p_env, qs_env, kpp1_env, p1_option, & - psi0d, orthogonal_orbitals,linres_control, error) + psi0d, orthogonal_orbitals,linres_control) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env @@ -132,7 +130,6 @@ SUBROUTINE p_env_create(p_env, qs_env, kpp1_env, p1_option, & LOGICAL, INTENT(in), OPTIONAL :: orthogonal_orbitals TYPE(linres_control_type), OPTIONAL, & POINTER :: linres_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_env_create', & routineP = moduleN//':'//routineN @@ -158,13 +155,12 @@ SUBROUTINE p_env_create(p_env, qs_env, kpp1_env, p1_option, & matrix_s=matrix_s,& dft_control=dft_control,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) n_spins = dft_control%nspins ALLOCATE(p_env,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(p_env%kpp1, & p_env%p1, & p_env%m_epsilon, & @@ -195,44 +191,43 @@ SUBROUTINE p_env_create(p_env, qs_env, kpp1_env, p1_option, & p_env%etotal=0.0_dp p_env%gradient=0.0_dp - CALL qs_rho_create(p_env%rho1, error) - CALL qs_rho_create(p_env%rho1_xc, error) + CALL qs_rho_create(p_env%rho1) + CALL qs_rho_create(p_env%rho1_xc) IF (PRESENT(kpp1_env)) THEN p_env%kpp1_env => kpp1_env ELSE - CALL kpp1_create(p_env%kpp1_env, error=error) + CALL kpp1_create(p_env%kpp1_env) END IF IF (PRESENT(p1_option)) THEN p_env%p1 => p1_option ELSE - CALL cp_dbcsr_allocate_matrix_set(p_env%p1,n_spins,error) + CALL cp_dbcsr_allocate_matrix_set(p_env%p1,n_spins) DO spin=1, n_spins ALLOCATE(p_env%p1(spin)%matrix) - CALL cp_dbcsr_init(p_env%p1(spin)%matrix,error=error) + CALL cp_dbcsr_init(p_env%p1(spin)%matrix) CALL cp_dbcsr_copy(p_env%p1(spin)%matrix,matrix_s(1)%matrix,& name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//& - "%p1-"//TRIM(ADJUSTL(cp_to_string(spin))),error=error) - CALL cp_dbcsr_set(p_env%p1(spin)%matrix,0.0_dp,error=error) + "%p1-"//TRIM(ADJUSTL(cp_to_string(spin)))) + CALL cp_dbcsr_set(p_env%p1(spin)%matrix,0.0_dp) END DO END IF CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools,& - mo_mo_fm_pools=mo_mo_fm_pools,& - error=error) + mo_mo_fm_pools=mo_mo_fm_pools) p_env%n_mo=0 p_env%n_ao=0 DO spin=1, n_spins IF (PRESENT(psi0d)) THEN CALL cp_fm_get_info(psi0d(spin)%matrix, & - ncol_global=n_mo, nrow_global=n_ao,error=error) + ncol_global=n_mo, nrow_global=n_ao) ELSE CALL get_mo_set(qs_env%mos(spin)%mo_set, mo_coeff=qs_env_c) CALL cp_fm_get_info(qs_env_c, & - ncol_global=n_mo, nrow_global=n_ao,error=error) + ncol_global=n_mo, nrow_global=n_ao) END IF p_env%n_mo(spin) = n_mo p_env%n_ao(spin) = n_ao @@ -243,46 +238,42 @@ SUBROUTINE p_env_create(p_env, qs_env, kpp1_env, p1_option, & p_env%orthogonal_orbitals=orthogonal_orbitals CALL fm_pools_create_fm_vect(ao_mo_fm_pools,elements=p_env%S_psi0,& - name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//"%S_psi0",& - error=error) + name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//"%S_psi0") ! alloc m_epsilon CALL fm_pools_create_fm_vect(mo_mo_fm_pools,elements=p_env%m_epsilon,& name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//& - "%m_epsilon",& - error=error) + "%m_epsilon") ! alloc Smo_inv IF (.NOT. p_env%orthogonal_orbitals) THEN CALL fm_pools_create_fm_vect(mo_mo_fm_pools,elements=p_env%Smo_inv,& name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//& - "%Smo_inv",& - error=error) + "%Smo_inv") END IF IF (PRESENT(psi0d)) THEN IF (ASSOCIATED(psi0d)) THEN - CALL cp_fm_vect_copy(psi0d,p_env%psi0d,error=error) + CALL cp_fm_vect_copy(psi0d,p_env%psi0d) END IF ELSE IF (.NOT.p_env%orthogonal_orbitals) THEN CALL fm_pools_create_fm_vect(ao_mo_fm_pools,& elements=p_env%psi0d,& name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//& - "%psi0d", & - error=error) + "%psi0d") END IF !----------------------! ! GAPW initializations ! !----------------------! IF (dft_control%qs_control%gapw) THEN - CALL local_rho_set_create(p_env%local_rho_set,error=error) - CALL allocate_rho_atom_internals(qs_env, p_env%local_rho_set%rho_atom_set,error=error) + CALL local_rho_set_create(p_env%local_rho_set) + CALL allocate_rho_atom_internals(qs_env, p_env%local_rho_set%rho_atom_set) CALL init_rho0(qs_env, dft_control%qs_control%gapw_control, & - .TRUE., p_env%local_rho_set, error) - CALL hartree_local_create(p_env%hartree_local,error=error) - CALL get_qs_env(qs_env=qs_env,natom=natom,error=error) - CALL init_coulomb_local(p_env%hartree_local,natom,error=error) + .TRUE., p_env%local_rho_set) + CALL hartree_local_create(p_env%hartree_local) + CALL get_qs_env(qs_env=qs_env,natom=natom) + CALL init_coulomb_local(p_env%hartree_local,natom) END IF !------------------------! @@ -295,22 +286,20 @@ SUBROUTINE p_env_create(p_env, qs_env, kpp1_env, p1_option, & IF (.NOT.ASSOCIATED(p_env%preconditioner)) THEN ALLOCATE(p_env%preconditioner(n_spins), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO spin =1,n_spins CALL init_preconditioner(p_env%preconditioner(spin),& - para_env=para_env,blacs_env=blacs_env,error=error) + para_env=para_env,blacs_env=blacs_env) END DO p_env%os_valid = .FALSE. CALL fm_pools_create_fm_vect(ao_mo_fm_pools,elements=p_env%PS_psi0,& - name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//"%PS_psi0",& - error=error) + name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//"%PS_psi0") ALLOCATE(p_env%ev_h0(n_spins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! CALL fm_pools_create_fm_vect(ao_mo_fm_pools,elements=p_env%ev_h0,& -! name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//"%ev_h0",& -! error=error) +! name="p_env"//TRIM(ADJUSTL(cp_to_string(p_env%id_nr)))//"%ev_h0") END IF END IF @@ -325,18 +314,15 @@ END SUBROUTINE p_env_create !> \brief checks that the intenal storage is allocated, and allocs it if needed !> \param p_env the environment to check !> \param qs_env the qs environment this p_env lives in -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> private routine ! ***************************************************************************** - SUBROUTINE p_env_check_i_alloc(p_env, qs_env, error) + SUBROUTINE p_env_check_i_alloc(p_env, qs_env) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_env_check_i_alloc', & routineP = moduleN//':'//routineN @@ -353,27 +339,27 @@ SUBROUTINE p_env_check_i_alloc(p_env, qs_env, error) failure=.FALSE. NULLIFY(dft_control,matrix_s) - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env, dft_control=dft_control,error=error) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env, dft_control=dft_control) gapw_xc = dft_control%qs_control%gapw_xc IF (.NOT.ASSOCIATED(p_env%kpp1)) THEN - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) nspins=dft_control%nspins - CALL cp_dbcsr_allocate_matrix_set(p_env%kpp1,nspins,error) + CALL cp_dbcsr_allocate_matrix_set(p_env%kpp1,nspins) name="p_env"//cp_to_string(p_env%id_nr)//"%kpp1-" CALL compress(name,full=.TRUE.) DO ispin=1,nspins ALLOCATE(p_env%kpp1(ispin)%matrix) - CALL cp_dbcsr_init(p_env%kpp1(ispin)%matrix,error=error) + CALL cp_dbcsr_init(p_env%kpp1(ispin)%matrix) CALL cp_dbcsr_copy(p_env%kpp1(ispin)%matrix,matrix_s(1)%matrix,& - name=TRIM(name)//ADJUSTL(cp_to_string(ispin)),error=error) + name=TRIM(name)//ADJUSTL(cp_to_string(ispin))) END DO - CALL qs_rho_rebuild(p_env%rho1, qs_env=qs_env, error=error) + CALL qs_rho_rebuild(p_env%rho1, qs_env=qs_env) IF(gapw_xc) THEN - CALL qs_rho_rebuild(p_env%rho1_xc,qs_env=qs_env,error=error) + CALL qs_rho_rebuild(p_env%rho1_xc,qs_env=qs_env) END IF END IF @@ -386,16 +372,13 @@ END SUBROUTINE p_env_check_i_alloc !> \param p_env the p_env to inform of the changes !> \param s_struct_changed true if the structure of the s matrix has changed !> \param grid_changed true if the grids have changed and have to be rebuilt -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE p_env_did_change(p_env, s_struct_changed, grid_changed,error) +SUBROUTINE p_env_did_change(p_env, s_struct_changed, grid_changed) TYPE(qs_p_env_type), POINTER :: p_env LOGICAL, INTENT(in), OPTIONAL :: s_struct_changed, grid_changed - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_env_did_change', & routineP = moduleN//':'//routineN @@ -404,12 +387,12 @@ SUBROUTINE p_env_did_change(p_env, s_struct_changed, grid_changed,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(s_struct_changed)) THEN IF (s_struct_changed) THEN IF (ASSOCIATED(p_env%kpp1)) THEN - CALL cp_dbcsr_deallocate_matrix_set(p_env%kpp1,error=error) + CALL cp_dbcsr_deallocate_matrix_set(p_env%kpp1) END IF END IF END IF @@ -417,15 +400,15 @@ SUBROUTINE p_env_did_change(p_env, s_struct_changed, grid_changed,error) IF (PRESENT(grid_changed)) THEN IF (grid_changed) THEN IF(ASSOCIATED(p_env%rho1_xc)) THEN - CALL qs_rho_release(p_env%rho1_xc,error=error) + CALL qs_rho_release(p_env%rho1_xc) END IF - CALL qs_rho_release(p_env%rho1,error=error) + CALL qs_rho_release(p_env%rho1) END IF END IF - CPPrecondition(ASSOCIATED(p_env%kpp1_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env%kpp1_env),cp_failure_level,routineP,failure) CALL kpp1_did_change(p_env%kpp1_env,s_struct_changed=s_struct_changed,& - grid_changed=grid_changed,error=error) + grid_changed=grid_changed) END SUBROUTINE p_env_did_change ! ***************************************************************************** @@ -436,13 +419,11 @@ END SUBROUTINE p_env_did_change !> \param psi0 the value of psi0, if not given defaults to the qs_env mos !> \param Hrho_psi0d is given, then the partial result Hrho_psi0d is stored in !> that vector -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d, error) + SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env @@ -450,7 +431,6 @@ SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d, error) OPTIONAL, POINTER :: psi0 TYPE(cp_fm_p_type), DIMENSION(:), & INTENT(inout), OPTIONAL :: Hrho_psi0d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_env_psi0_changed', & routineP = moduleN//':'//routineN @@ -480,10 +460,10 @@ SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d, error) failure=.FALSE. NULLIFY(ao_mo_fm_pools,mos,my_psi0,matrix_s,mos, para_env,ks_env, rho, & logger, input,lr_section, energy, matrix_ks, dft_control, rho_ao) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& ks_env=ks_env,& @@ -494,35 +474,34 @@ SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d, error) rho=rho,& input=input,& energy=energy,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) n_spins = dft_control%nspins p_env%iter=p_env%iter+1 CALL mpools_get(qs_env%mpools,& - ao_mo_fm_pools=ao_mo_fm_pools, error=error) + ao_mo_fm_pools=ao_mo_fm_pools) ! def my_psi0 IF (PRESENT(psi0)) THEN - CALL cp_fm_vect_copy(psi0,my_psi0,error=error) + CALL cp_fm_vect_copy(psi0,my_psi0) ELSE ALLOCATE(my_psi0(n_spins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO spin=1,n_spins NULLIFY(my_psi0(spin)%matrix) CALL get_mo_set(mos(spin)%mo_set,& mo_coeff=my_psi0(spin)%matrix) - CALL cp_fm_retain(my_psi0(spin)%matrix,error=error) + CALL cp_fm_retain(my_psi0(spin)%matrix) END DO END IF - lr_section => section_vals_get_subs_vals(input,"PROPERTIES%LINRES",error=error) + lr_section => section_vals_get_subs_vals(input,"PROPERTIES%LINRES") ! def psi0d IF (p_env%orthogonal_orbitals) THEN IF (ASSOCIATED(p_env%psi0d)) THEN - CALL cp_fm_vect_dealloc(p_env%psi0d,error=error) + CALL cp_fm_vect_dealloc(p_env%psi0d) END IF p_env%psi0d => my_psi0 ELSE @@ -533,86 +512,83 @@ SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d, error) CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,& my_psi0(spin)%matrix,& p_env%S_psi0(spin)%matrix,& - ncol=p_env%n_mo(spin), alpha=1.0_dp,error=error) + ncol=p_env%n_mo(spin), alpha=1.0_dp) CALL cp_gemm(transa='T',transb='N',n=p_env%n_mo(spin),& m=p_env%n_mo(spin),k=p_env%n_ao(spin),alpha=1.0_dp,& matrix_a=my_psi0(spin)%matrix, & matrix_b=p_env%S_psi0(spin)%matrix,& - beta=0.0_dp,matrix_c=p_env%m_epsilon(spin)%matrix,& - error=error) + beta=0.0_dp,matrix_c=p_env%m_epsilon(spin)%matrix) CALL cp_fm_cholesky_decompose(p_env%m_epsilon(spin)%matrix,& - n=p_env%n_mo(spin),error=error) + n=p_env%n_mo(spin)) ! Smo_inv= (my_psi0^T S my_psi0)^-1 - CALL cp_fm_set_all(p_env%Smo_inv(spin)%matrix,0.0_dp,1.0_dp,error=error) + CALL cp_fm_set_all(p_env%Smo_inv(spin)%matrix,0.0_dp,1.0_dp) ! faster using cp_fm_cholesky_invert ? CALL cp_fm_triangular_multiply(& triangular_matrix=p_env%m_epsilon(spin)%matrix,& matrix_b=p_env%Smo_inv(spin)%matrix,side='R',& invert_tr=.TRUE., n_rows=p_env%n_mo(spin),& - n_cols=p_env%n_mo(spin),error=error) + n_cols=p_env%n_mo(spin)) CALL cp_fm_triangular_multiply(& triangular_matrix=p_env%m_epsilon(spin)%matrix,& matrix_b=p_env%Smo_inv(spin)%matrix,side='R',& transpose_tr=.TRUE.,& invert_tr=.TRUE., n_rows=p_env%n_mo(spin),& - n_cols=p_env%n_mo(spin),error=error) + n_cols=p_env%n_mo(spin)) ! psi0d=my_psi0 (my_psi0^T S my_psi0)^-1 ! faster using cp_fm_cholesky_invert ? CALL cp_fm_to_fm(my_psi0(spin)%matrix,& - p_env%psi0d(spin)%matrix, error=error) + p_env%psi0d(spin)%matrix) CALL cp_fm_triangular_multiply(& triangular_matrix=p_env%m_epsilon(spin)%matrix,& matrix_b=p_env%psi0d(spin)%matrix,side='R',& invert_tr=.TRUE., n_rows=p_env%n_ao(spin),& - n_cols=p_env%n_mo(spin),error=error) + n_cols=p_env%n_mo(spin)) CALL cp_fm_triangular_multiply(& triangular_matrix=p_env%m_epsilon(spin)%matrix,& matrix_b=p_env%psi0d(spin)%matrix,side='R',& transpose_tr=.TRUE.,& invert_tr=.TRUE., n_rows=p_env%n_ao(spin),& - n_cols=p_env%n_mo(spin),error=error) + n_cols=p_env%n_mo(spin)) ! updates P CALL get_mo_set(mos(spin)%mo_set,lfomo=lfomo,& nmo=nmo,maxocc=maxocc) IF (lfomo>nmo) THEN - CALL cp_dbcsr_set(rho_ao(spin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(rho_ao(spin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(rho_ao(spin)%matrix,& matrix_v=my_psi0(spin)%matrix,& matrix_g=p_env%psi0d(spin)%matrix,& - ncol=p_env%n_mo(spin),error=error) - CALL cp_dbcsr_scale(rho_ao(spin)%matrix,alpha_scalar=maxocc,& - error=error) + ncol=p_env%n_mo(spin)) + CALL cp_dbcsr_scale(rho_ao(spin)%matrix,alpha_scalar=maxocc) ELSE CALL cp_unimplemented_error(fromWhere=routineP,& - message="symmetrized onesided smearing to do",& - error=error) + message="symmetrized onesided smearing to do") END IF END DO ! updates rho - CALL qs_rho_update_rho(rho_struct=rho, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho_struct=rho, qs_env=qs_env) ! tells ks_env that p changed - CALL qs_ks_did_change(ks_env=ks_env, rho_changed=.TRUE., error=error) + CALL qs_ks_did_change(ks_env=ks_env, rho_changed=.TRUE.) END IF ! updates K (if necessary) - CALL qs_ks_update_qs_env(qs_env, error=error) + CALL qs_ks_update_qs_env(qs_env) output_unit = cp_print_key_unit_nr(logger,lr_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".linresLog",error=error) + extension=".linresLog") IF (output_unit>0) THEN - CALL section_vals_get(lr_section,explicit=was_present,error=error) + CALL section_vals_get(lr_section,explicit=was_present) IF(was_present) THEN WRITE(UNIT=output_unit,FMT="(/,(T3,A,T55,F25.14))") & "Total energy ground state: ", energy%total END IF END IF CALL cp_print_key_finished_output(output_unit,logger,lr_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") !-----------------------------------------------------------------------| ! calculates | ! m_epsilon = - psi0d^T times K times psi0d | @@ -622,17 +598,16 @@ SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d, error) ! S_psi0 = k times psi0d CALL cp_dbcsr_sm_fm_multiply(matrix_ks(spin)%matrix, & p_env%psi0d(spin)%matrix, & - p_env%S_psi0(spin)%matrix, p_env%n_mo(spin),error=error) + p_env%S_psi0(spin)%matrix, p_env%n_mo(spin)) IF (PRESENT(Hrho_psi0d)) THEN CALL cp_fm_scale_and_add(alpha=0.0_dp,matrix_a=Hrho_psi0d(spin)%matrix,& - beta=1.0_dp,matrix_b=p_env%S_psi0(spin)%matrix,& - error=error) + beta=1.0_dp,matrix_b=p_env%S_psi0(spin)%matrix) END IF ! m_epsilon = -1 times S_psi0^T times psi0d CALL cp_gemm('T', 'N', & p_env%n_mo(spin), p_env%n_mo(spin), p_env%n_ao(spin), & -1.0_dp, p_env%S_psi0(spin)%matrix, p_env%psi0d(spin)%matrix, & - 0.0_dp, p_env%m_epsilon(spin)%matrix,error=error) + 0.0_dp, p_env%m_epsilon(spin)%matrix) ! DO i =1,size(p_env%m_epsilon(spin)%matrix%local_data,1) ! write(*,'(I4,4f12.6)') i,(p_env%m_epsilon(spin)%matrix%local_data(i,j), j=1,4) ! end do @@ -645,23 +620,23 @@ SUBROUTINE p_env_psi0_changed(p_env, qs_env, psi0, Hrho_psi0d, error) ! calculating this reduces the mat mult without storing a full aoxao ! matrix (for P). If nspin>1 you might consider calculating it on the ! fly to spare some memory - CALL get_qs_env(qs_env, matrix_s=matrix_s,error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) DO spin=1,n_spins CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, & my_psi0(spin)%matrix, & p_env%S_psi0(spin)%matrix, & - p_env%n_mo(spin),error=error) + p_env%n_mo(spin)) END DO ! releases my_psi0 IF (p_env%orthogonal_orbitals) THEN NULLIFY(my_psi0) ELSE - CALL cp_fm_vect_dealloc(my_psi0,error=error) + CALL cp_fm_vect_dealloc(my_psi0) END IF ! tells kpp1_env about the change of psi0 - CALL kpp1_did_change(p_env%kpp1_env,psi0_changed=.TRUE.,error=error) + CALL kpp1_did_change(p_env%kpp1_env,psi0_changed=.TRUE.) CALL timestop(handle) @@ -674,12 +649,11 @@ END SUBROUTINE p_env_psi0_changed !> \param qs_env the qs_env that is perturbed by this p_env !> \param v the matrix to operate on !> \param res the result -!> \param error error handling object (optional) !> \par History !> 10.2002, TCH, extracted single spin calculation !> \author Thomas Chassaing ! ***************************************************************************** - SUBROUTINE p_op_l1(p_env, qs_env, v, res, error) + SUBROUTINE p_op_l1(p_env, qs_env, v, res) ! argument TYPE(qs_p_env_type), POINTER :: p_env @@ -688,7 +662,6 @@ SUBROUTINE p_op_l1(p_env, qs_env, v, res, error) INTENT(in) :: v TYPE(cp_fm_p_type), DIMENSION(:), & INTENT(inout) :: res - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_op_l1', & routineP = moduleN//':'//routineN @@ -701,15 +674,15 @@ SUBROUTINE p_op_l1(p_env, qs_env, v, res, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(dft_control) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) n_spins = dft_control%nspins DO spin=1, n_spins CALL p_op_l1_spin(p_env, qs_env, spin, v(spin)%matrix,& - res(spin)%matrix,error) + res(spin)%matrix) END DO END SUBROUTINE p_op_l1 @@ -722,21 +695,19 @@ END SUBROUTINE p_op_l1 !> \param spin the spin to calculate (1 or 2 normally) !> \param v the matrix to operate on !> \param res the result -!> \param error error handling object (optional) !> \par History !> 10.2002, TCH, created !> \author Thomas Chassaing !> \note !> Same as p_op_l1 but takes a spin as additional argument. ! ***************************************************************************** - SUBROUTINE p_op_l1_spin(p_env, qs_env, spin, v, res, error) + SUBROUTINE p_op_l1_spin(p_env, qs_env, spin, v, res) ! argument TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: spin TYPE(cp_fm_type), POINTER :: v, res - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_op_l1_spin', & routineP = moduleN//':'//routineN @@ -761,34 +732,32 @@ SUBROUTINE p_op_l1_spin(p_env, qs_env, spin, v, res, error) para_env=para_env,& matrix_s=matrix_s,& matrix_ks=matrix_ks,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(00,cp_failure_level,routineP,failure) + CPPrecondition(0 matrix_ks(spin)%matrix - CALL cp_fm_get_info(v, ncol_global=ncol,error=error) + CALL cp_fm_get_info(v, ncol_global=ncol) IF (p_env%orthogonal_orbitals) THEN - CALL cp_dbcsr_sm_fm_multiply(k_p, v, res, ncol ,error=error) + CALL cp_dbcsr_sm_fm_multiply(k_p, v, res, ncol) ELSE - CALL cp_dbcsr_sm_fm_multiply(k_p, v, tmp, ncol ,error=error) + CALL cp_dbcsr_sm_fm_multiply(k_p, v, tmp, ncol) CALL cp_fm_symm('R', 'U', p_env%n_ao(spin), p_env%n_mo(spin), 1.0_dp, & - p_env%Smo_inv(spin)%matrix, tmp, 0.0_dp, res,error=error) + p_env%Smo_inv(spin)%matrix, tmp, 0.0_dp, res) END IF CALL cp_fm_symm('R', 'U', p_env%n_ao(spin), p_env%n_mo(spin), 1.0_dp, & - p_env%m_epsilon(spin)%matrix, v, 0.0_dp, tmp,error=error) + p_env%m_epsilon(spin)%matrix, v, 0.0_dp, tmp) CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, tmp, & - res, p_env%n_mo(spin), alpha=1.0_dp,beta=1.0_dp,error=error) - CALL fm_pool_give_back_fm(maxao_maxmo_fm_pool,tmp,error=error); NULLIFY(tmp) + res, p_env%n_mo(spin), alpha=1.0_dp,beta=1.0_dp) + CALL fm_pool_give_back_fm(maxao_maxmo_fm_pool,tmp); NULLIFY(tmp) CALL timestop(handle) @@ -803,8 +772,6 @@ END SUBROUTINE p_op_l1_spin !> \param res place where to store the result !> \param alpha scale factor of the result (defaults to 1.0) !> \param beta scale factor of the old values (defaults to 0.0) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.09.2002 adapted for new qs_p_env_type (TC) !> 03.2003 extended for p1 not taken from v (TC) @@ -813,7 +780,7 @@ END SUBROUTINE p_op_l1_spin !> qs_env%rho must be up to date !> it would be better to pass rho1, not p1 ! ***************************************************************************** - SUBROUTINE p_op_l2(p_env, qs_env, p1, res, alpha, beta, error) + SUBROUTINE p_op_l2(p_env, qs_env, p1, res, alpha, beta) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env @@ -822,7 +789,6 @@ SUBROUTINE p_op_l2(p_env, qs_env, p1, res, alpha, beta, error) TYPE(cp_fm_p_type), DIMENSION(:), & INTENT(INOUT) :: res REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_op_l2', & routineP = moduleN//':'//routineN @@ -841,7 +807,7 @@ SUBROUTINE p_op_l2(p_env, qs_env, p1, res, alpha, beta, error) failure=.FALSE. NULLIFY(dft_control, rho, rho1_ao) - CALL get_qs_env(qs_env, dft_control=dft_control, rho=rho, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control, rho=rho) gapw=dft_control%qs_control%gapw gapw_xc=dft_control%qs_control%gapw_xc @@ -852,36 +818,34 @@ SUBROUTINE p_op_l2(p_env, qs_env, p1, res, alpha, beta, error) iter=iter+1 - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) - CALL p_env_check_i_alloc(p_env,qs_env=qs_env,error=error) + CALL p_env_check_i_alloc(p_env,qs_env=qs_env) n_spins = dft_control%nspins - CALL qs_rho_get(p_env%rho1, rho_ao=rho1_ao, error=error) + CALL qs_rho_get(p_env%rho1, rho_ao=rho1_ao) DO ispin=1, SIZE(p1) ! hack to avoid crashes in ep regs IF(.not.ASSOCIATED(rho1_ao(ispin)%matrix,p1(ispin)%matrix)) THEN - CALL cp_dbcsr_copy(rho1_ao(ispin)%matrix,p1(ispin)%matrix,error=error) + CALL cp_dbcsr_copy(rho1_ao(ispin)%matrix,p1(ispin)%matrix) ENDIF ENDDO - CALL qs_rho_update_rho(rho_struct=p_env%rho1, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho_struct=p_env%rho1, qs_env=qs_env) IF (fdiff) THEN CALL kpp1_calc_k_p_p1_fdiff(qs_env=qs_env,& - k_p_p1=p_env%kpp1, rho=rho ,rho1=p_env%rho1,& - error=error) + k_p_p1=p_env%kpp1, rho=rho ,rho1=p_env%rho1) ELSE CALL kpp1_calc_k_p_p1(kpp1_env=p_env%kpp1_env, p_env=p_env, qs_env=qs_env,& - k_p_p1=p_env%kpp1, rho=rho ,rho1=p_env%rho1, rho1_xc=p_env%rho1,& - error=error) + k_p_p1=p_env%kpp1, rho=rho ,rho1=p_env%rho1, rho1_xc=p_env%rho1) END IF DO ispin=1,n_spins CALL cp_dbcsr_sm_fm_multiply(p_env%kpp1(ispin)%matrix,& p_env%psi0d(ispin)%matrix, res(ispin)%matrix,& ncol=p_env%n_mo(ispin),& - alpha=my_alpha,beta=my_beta,error=error) + alpha=my_alpha,beta=my_beta) END DO CALL timestop(handle) @@ -895,13 +859,11 @@ END SUBROUTINE p_op_l2 !> \param qs_env the qs_env that is perturbed by this p_env !> \param v matrix to orthogonalize !> \param n_cols the number of columns of C to multiply (defaults to size(v,2)) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.09.2002 adapted for new qs_p_env_type (TC) !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE p_preortho(p_env, qs_env, v, n_cols, error) + SUBROUTINE p_preortho(p_env, qs_env, v, n_cols) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env @@ -909,7 +871,6 @@ SUBROUTINE p_preortho(p_env, qs_env, v, n_cols, error) INTENT(inout) :: v INTEGER, DIMENSION(:), INTENT(in), & OPTIONAL :: n_cols - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_preortho', & routineP = moduleN//':'//routineN @@ -933,67 +894,63 @@ SUBROUTINE p_preortho(p_env, qs_env, v, n_cols, error) NULLIFY(tmp_matrix,maxmo_maxmo_fm_pool, maxmo_maxmo_fmstruct,tmp_fmstruct,& dft_control) - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) - CALL mpools_get(qs_env%mpools,maxmo_maxmo_fm_pool=maxmo_maxmo_fm_pool,& - error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) + CALL mpools_get(qs_env%mpools,maxmo_maxmo_fm_pool=maxmo_maxmo_fm_pool) n_spins = dft_control%nspins - maxmo_maxmo_fmstruct => fm_pool_get_el_struct(maxmo_maxmo_fm_pool,error=error) - CALL cp_fm_struct_get(maxmo_maxmo_fmstruct, nrow_global=nmo2,ncol_global=maxnmo,error=error) - CPPrecondition(SIZE(v)>=n_spins,cp_failure_level,routineP,error,failure) + maxmo_maxmo_fmstruct => fm_pool_get_el_struct(maxmo_maxmo_fm_pool) + CALL cp_fm_struct_get(maxmo_maxmo_fmstruct, nrow_global=nmo2,ncol_global=maxnmo) + CPPrecondition(SIZE(v)>=n_spins,cp_failure_level,routineP,failure) ! alloc tmp storage IF (PRESENT(n_cols)) THEN max_cols=MAXVAL(n_cols(1:n_spins)) ELSE max_cols=0 DO spin=1, n_spins - CALL cp_fm_get_info(v(spin)%matrix, ncol_global=v_cols,error=error) + CALL cp_fm_get_info(v(spin)%matrix, ncol_global=v_cols) max_cols = MAX(max_cols, v_cols) END DO END IF IF (max_cols <= nmo2) THEN - CALL fm_pool_create_fm(maxmo_maxmo_fm_pool,tmp_matrix,error=error) + CALL fm_pool_create_fm(maxmo_maxmo_fm_pool,tmp_matrix) ELSE CALL cp_fm_struct_create(tmp_fmstruct,nrow_global=max_cols,& - ncol_global=maxnmo,template_fmstruct=maxmo_maxmo_fmstruct,& - error=error) - CALL cp_fm_create(tmp_matrix,matrix_struct=tmp_fmstruct,& - error=error) - CALL cp_fm_struct_release(tmp_fmstruct,error=error) + ncol_global=maxnmo,template_fmstruct=maxmo_maxmo_fmstruct) + CALL cp_fm_create(tmp_matrix,matrix_struct=tmp_fmstruct) + CALL cp_fm_struct_release(tmp_fmstruct) END IF DO spin=1, n_spins CALL cp_fm_get_info(v(spin)%matrix, & - nrow_global=v_rows, ncol_global=v_cols,error=error) - CPPrecondition(v_rows>=p_env%n_ao(spin),cp_failure_level,routineP,error,failure) + nrow_global=v_rows, ncol_global=v_cols) + CPPrecondition(v_rows>=p_env%n_ao(spin),cp_failure_level,routineP,failure) cols = v_cols IF (PRESENT(n_cols)) THEN - CPPrecondition(n_cols(spin)<=cols,cp_failure_level,routineP,error,failure) + CPPrecondition(n_cols(spin)<=cols,cp_failure_level,routineP,failure) cols=n_cols(spin) END IF - CPPrecondition(cols<=max_cols,cp_failure_level,routineP,error,failure) + CPPrecondition(cols<=max_cols,cp_failure_level,routineP,failure) ! tmp_matrix = v^T (S psi0) CALL cp_gemm(transa='T',transb='N',m=cols,n=p_env%n_mo(spin),& k=p_env%n_ao(spin),alpha=1.0_dp,matrix_a=v(spin)%matrix,& matrix_b=p_env%S_psi0(spin)%matrix,beta=0.0_dp,& - matrix_c=tmp_matrix,error=error) + matrix_c=tmp_matrix) ! v = v- psi0d tmp_matrix^T = v - psi0d psi0^T S v CALL cp_gemm(transa='N',transb='T',m=p_env%n_ao(spin),n=cols,& k=p_env%n_mo(spin),alpha=-1.0_dp,& matrix_a=p_env%psi0d(spin)%matrix,matrix_b=tmp_matrix,& - beta=1.0_dp,matrix_c=v(spin)%matrix,error=error) + beta=1.0_dp,matrix_c=v(spin)%matrix) END DO IF (max_cols <= nmo2) THEN - CALL fm_pool_give_back_fm(maxmo_maxmo_fm_pool,tmp_matrix,& - error=error) + CALL fm_pool_give_back_fm(maxmo_maxmo_fm_pool,tmp_matrix) ELSE - CALL cp_fm_release(tmp_matrix,error=error) + CALL cp_fm_release(tmp_matrix) END IF CALL timestop(handle) @@ -1007,13 +964,11 @@ END SUBROUTINE p_preortho !> \param qs_env the qs_env that is perturbed by this p_env !> \param v matrix to orthogonalize !> \param n_cols the number of columns of C to multiply (defaults to size(v,2)) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE p_postortho(p_env, qs_env, v, n_cols, error) + SUBROUTINE p_postortho(p_env, qs_env, v, n_cols) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env @@ -1021,7 +976,6 @@ SUBROUTINE p_postortho(p_env, qs_env, v, n_cols, error) INTENT(inout) :: v INTEGER, DIMENSION(:), INTENT(in), & OPTIONAL :: n_cols - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_postortho', & routineP = moduleN//':'//routineN @@ -1044,67 +998,63 @@ SUBROUTINE p_postortho(p_env, qs_env, v, n_cols, error) NULLIFY(tmp_matrix,maxmo_maxmo_fm_pool, maxmo_maxmo_fmstruct,tmp_fmstruct,& dft_control) - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) - CALL get_qs_env(qs_env, dft_control=dft_control,error=error) - CALL mpools_get(qs_env%mpools, maxmo_maxmo_fm_pool=maxmo_maxmo_fm_pool,& - error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) + CALL mpools_get(qs_env%mpools, maxmo_maxmo_fm_pool=maxmo_maxmo_fm_pool) n_spins = dft_control%nspins - maxmo_maxmo_fmstruct => fm_pool_get_el_struct(maxmo_maxmo_fm_pool,error=error) - CALL cp_fm_struct_get(maxmo_maxmo_fmstruct, nrow_global=nmo2,ncol_global=maxnmo,error=error) - CPPrecondition(SIZE(v)>=n_spins,cp_failure_level,routineP,error,failure) + maxmo_maxmo_fmstruct => fm_pool_get_el_struct(maxmo_maxmo_fm_pool) + CALL cp_fm_struct_get(maxmo_maxmo_fmstruct, nrow_global=nmo2,ncol_global=maxnmo) + CPPrecondition(SIZE(v)>=n_spins,cp_failure_level,routineP,failure) ! alloc tmp storage IF (PRESENT(n_cols)) THEN max_cols=MAXVAL(n_cols(1:n_spins)) ELSE max_cols=0 DO spin=1, n_spins - CALL cp_fm_get_info(v(spin)%matrix, ncol_global=v_cols,error=error) + CALL cp_fm_get_info(v(spin)%matrix, ncol_global=v_cols) max_cols = MAX(max_cols, v_cols) END DO END IF IF (max_cols <= nmo2) THEN - CALL fm_pool_create_fm(maxmo_maxmo_fm_pool,tmp_matrix,error=error) + CALL fm_pool_create_fm(maxmo_maxmo_fm_pool,tmp_matrix) ELSE CALL cp_fm_struct_create(tmp_fmstruct,nrow_global=max_cols,& - ncol_global=maxnmo,template_fmstruct=maxmo_maxmo_fmstruct,& - error=error) - CALL cp_fm_create(tmp_matrix,matrix_struct=tmp_fmstruct,& - error=error) - CALL cp_fm_struct_release(tmp_fmstruct,error=error) + ncol_global=maxnmo,template_fmstruct=maxmo_maxmo_fmstruct) + CALL cp_fm_create(tmp_matrix,matrix_struct=tmp_fmstruct) + CALL cp_fm_struct_release(tmp_fmstruct) END IF DO spin=1, n_spins CALL cp_fm_get_info(v(spin)%matrix, & - nrow_global=v_rows, ncol_global=v_cols,error=error) - CPPrecondition(v_rows>=p_env%n_ao(spin),cp_failure_level,routineP,error,failure) + nrow_global=v_rows, ncol_global=v_cols) + CPPrecondition(v_rows>=p_env%n_ao(spin),cp_failure_level,routineP,failure) cols = v_cols IF (PRESENT(n_cols)) THEN - CPPrecondition(n_cols(spin)<=cols,cp_failure_level,routineP,error,failure) + CPPrecondition(n_cols(spin)<=cols,cp_failure_level,routineP,failure) cols=n_cols(spin) END IF - CPPrecondition(cols<=max_cols,cp_failure_level,routineP,error,failure) + CPPrecondition(cols<=max_cols,cp_failure_level,routineP,failure) ! tmp_matrix = v^T psi0d CALL cp_gemm(transa='T',transb='N',m=cols,n=p_env%n_mo(spin),& k=p_env%n_ao(spin),alpha=1.0_dp,matrix_a=v(spin)%matrix,& matrix_b=p_env%psi0d(spin)%matrix,beta=0.0_dp,& - matrix_c=tmp_matrix,error=error) + matrix_c=tmp_matrix) ! v = v- (S psi0) tmp_matrix^T = v - S psi0 psi0d^T v CALL cp_gemm(transa='N',transb='T',m=p_env%n_ao(spin),n=cols,& k=p_env%n_mo(spin),alpha=-1.0_dp,& matrix_a=p_env%S_psi0(spin)%matrix,matrix_b=tmp_matrix,& - beta=1.0_dp,matrix_c=v(spin)%matrix,error=error) + beta=1.0_dp,matrix_c=v(spin)%matrix) END DO IF (max_cols <= nmo2) THEN - CALL fm_pool_give_back_fm(maxmo_maxmo_fm_pool,tmp_matrix,& - error=error) + CALL fm_pool_give_back_fm(maxmo_maxmo_fm_pool,tmp_matrix) ELSE - CALL cp_fm_release(tmp_matrix,error=error) + CALL cp_fm_release(tmp_matrix) END IF CALL timestop(handle) diff --git a/src/qs_p_env_types.F b/src/qs_p_env_types.F index d0c5ffb1c4..1e42011356 100644 --- a/src/qs_p_env_types.F +++ b/src/qs_p_env_types.F @@ -105,15 +105,12 @@ MODULE qs_p_env_types ! ***************************************************************************** !> \brief retains the given p_env (see doc/ReferenceCounting.html) !> \param p_env the p_env to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE p_env_retain(p_env,error) +SUBROUTINE p_env_retain(p_env) TYPE(qs_p_env_type), POINTER :: p_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_env_retain', & routineP = moduleN//':'//routineN @@ -122,24 +119,21 @@ SUBROUTINE p_env_retain(p_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,error,failure) - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_env),cp_failure_level,routineP,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) p_env%ref_count=p_env%ref_count+1 END SUBROUTINE p_env_retain ! ***************************************************************************** !> \brief relases the given p_env (see doc/ReferenceCounting.html) !> \param p_env the environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE p_env_release(p_env, error) + SUBROUTINE p_env_release(p_env) TYPE(qs_p_env_type), POINTER :: p_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_env_release', & routineP = moduleN//':'//routineN @@ -150,46 +144,46 @@ SUBROUTINE p_env_release(p_env, error) failure=.FALSE. IF (ASSOCIATED(p_env)) THEN - CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(p_env%ref_count>0,cp_failure_level,routineP,failure) p_env%ref_count=p_env%ref_count-1 IF (p_env%ref_count<1) THEN - CALL kpp1_release(p_env%kpp1_env, error) - CALL cp_fm_vect_dealloc(p_env%S_psi0, error=error) - CALL cp_fm_vect_dealloc(p_env%m_epsilon, error=error) - CALL cp_fm_vect_dealloc(p_env%psi0d, error=error) - CALL cp_fm_vect_dealloc(p_env%Smo_inv, error=error) + CALL kpp1_release(p_env%kpp1_env) + CALL cp_fm_vect_dealloc(p_env%S_psi0) + CALL cp_fm_vect_dealloc(p_env%m_epsilon) + CALL cp_fm_vect_dealloc(p_env%psi0d) + CALL cp_fm_vect_dealloc(p_env%Smo_inv) IF(ASSOCIATED(p_env%rho1_xc)) THEN - CALL qs_rho_release(p_env%rho1_xc,error=error) + CALL qs_rho_release(p_env%rho1_xc) ENDIF - CALL qs_rho_release(p_env%rho1,error=error) - IF (ASSOCIATED(p_env%kpp1)) CALL cp_dbcsr_deallocate_matrix_set(p_env%kpp1,error) - IF (ASSOCIATED(p_env%p1)) CALL cp_dbcsr_deallocate_matrix_set(p_env%p1,error) + CALL qs_rho_release(p_env%rho1) + IF (ASSOCIATED(p_env%kpp1)) CALL cp_dbcsr_deallocate_matrix_set(p_env%kpp1) + IF (ASSOCIATED(p_env%p1)) CALL cp_dbcsr_deallocate_matrix_set(p_env%p1) IF (ASSOCIATED(p_env%local_rho_set)) THEN - CALL local_rho_set_release(p_env%local_rho_set,error=error) + CALL local_rho_set_release(p_env%local_rho_set) END IF IF (ASSOCIATED(p_env%hartree_local)) THEN - CALL hartree_local_release(p_env%hartree_local,error=error) + CALL hartree_local_release(p_env%hartree_local) END IF IF(ASSOCIATED(p_env%PS_psi0)) THEN - CALL cp_fm_vect_dealloc(p_env%PS_psi0, error=error) + CALL cp_fm_vect_dealloc(p_env%PS_psi0) END IF IF(ASSOCIATED(p_env%ev_h0)) THEN DO ip = 1,SIZE(p_env%ev_h0,1) NULLIFY(p_env%ev_h0(ip)%matrix) END DO DEALLOCATE(p_env%ev_h0, STAT=stat) - CPPostcondition((stat==0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat==0),cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(p_env%preconditioner)) THEN DO ip=1,SIZE(p_env%preconditioner,1) - CALL destroy_preconditioner(p_env%preconditioner(ip),error=error) + CALL destroy_preconditioner(p_env%preconditioner(ip)) END DO DEALLOCATE(p_env%preconditioner,STAT=stat) - CPPostcondition((stat==0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat==0),cp_failure_level,routineP,failure) END IF END IF DEALLOCATE(p_env,stat=stat) - CPPostcondition((stat==0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat==0),cp_failure_level,routineP,failure) END IF NULLIFY(p_env) END SUBROUTINE p_env_release diff --git a/src/qs_p_sparse_psi.F b/src/qs_p_sparse_psi.F index 9c62884448..1cd75884d2 100644 --- a/src/qs_p_sparse_psi.F +++ b/src/qs_p_sparse_psi.F @@ -68,20 +68,17 @@ MODULE qs_p_sparse_psi !> \param particle_set the particle set from where to extract the indexes !> of the ao !> \param qs_kind_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE p_proj_create(p_proj, atoms, particle_set, qs_kind_set, error) +SUBROUTINE p_proj_create(p_proj, atoms, particle_set, qs_kind_set) TYPE(qs_p_projection_type), POINTER :: p_proj INTEGER, DIMENSION(:), INTENT(in) :: atoms TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_proj_create', & routineP = moduleN//':'//routineN @@ -100,7 +97,7 @@ SUBROUTINE p_proj_create(p_proj, atoms, particle_set, qs_kind_set, error) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) size_proj = 0 DO i=1,SIZE(p_proj%atoms) size_proj = size_proj + last_sgf(p_proj%atoms(i)) -& @@ -127,15 +124,12 @@ END SUBROUTINE p_proj_create !> \brief augments the retain count by one, to be called to hold a shared copy !> of this object !> \param p_proj the projection to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE p_proj_retain(p_proj, error) +SUBROUTINE p_proj_retain(p_proj) TYPE(qs_p_projection_type), POINTER :: p_proj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_proj_retain', & routineP = moduleN//':'//routineN @@ -144,8 +138,8 @@ SUBROUTINE p_proj_retain(p_proj, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(p_proj),cp_failure_level,routineP,error,failure) - CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_proj),cp_failure_level,routineP,failure) + CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,failure) p_proj%ref_count=p_proj%ref_count+1 END SUBROUTINE p_proj_retain @@ -153,15 +147,12 @@ END SUBROUTINE p_proj_retain !> \brief decreases the retain count by one, deleting the objecs when it hits 0. !> To be called when you no longer need a shared copy you retained !> \param p_proj the projection to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE p_proj_release(p_proj, error) +SUBROUTINE p_proj_release(p_proj) TYPE(qs_p_projection_type), POINTER :: p_proj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_proj_release', & routineP = moduleN//':'//routineN @@ -172,16 +163,16 @@ SUBROUTINE p_proj_release(p_proj, error) failure=.FALSE. IF (ASSOCIATED(p_proj)) THEN - CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,failure) p_proj%ref_count=p_proj%ref_count-1 IF (p_proj%ref_count<1) THEN DEALLOCATE(p_proj%atoms,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DEALLOCATE(p_proj%proj_indexes,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) p_proj%ref_count=0 DEALLOCATE(p_proj, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF END SUBROUTINE p_proj_release @@ -199,19 +190,16 @@ END SUBROUTINE p_proj_release !> \param start_col_min ... !> \param ncol number of columns to set (defaults to all the columns of !> min_m -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE p_proj_transfer_blacs_to_f(p_proj, min_m, full_m,& - start_col_full, start_col_min, ncol, error) + start_col_full, start_col_min, ncol) TYPE(qs_p_projection_type), POINTER :: p_proj TYPE(cp_fm_type), POINTER :: min_m, full_m INTEGER, INTENT(in), OPTIONAL :: start_col_full, & start_col_min, ncol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_proj_transfer_blacs_to_f', & routineP = moduleN//':'//routineN @@ -226,12 +214,10 @@ SUBROUTINE p_proj_transfer_blacs_to_f(p_proj, min_m, full_m,& CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(ASSOCIATED(p_proj),cp_failure_level,routineP,error,failure) - CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,error,failure) - CALL cp_fm_get_info(min_m, nrow_global=nrow_min, ncol_global=ncol_min,& - error=error) - CALL cp_fm_get_info(full_m, nrow_global=nrow_full, ncol_global=ncol_full,& - error=error) + CPPrecondition(ASSOCIATED(p_proj),cp_failure_level,routineP,failure) + CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,failure) + CALL cp_fm_get_info(min_m, nrow_global=nrow_min, ncol_global=ncol_min) + CALL cp_fm_get_info(full_m, nrow_global=nrow_full, ncol_global=ncol_full) my_start_col_full=1 IF (PRESENT(start_col_full)) my_start_col_full=start_col_full @@ -241,21 +227,20 @@ SUBROUTINE p_proj_transfer_blacs_to_f(p_proj, min_m, full_m,& IF (PRESENT(ncol)) my_ncol=ncol blocksize=MIN(my_ncol,max_blocksize) - CPPrecondition(my_ncol>=0,cp_failure_level,routineP,error,failure) - CPPrecondition(my_start_col_min+my_ncol=SIZE(p_proj%proj_indexes),cp_failure_level,routineP,error,failure) + CPPrecondition(my_ncol>=0,cp_failure_level,routineP,failure) + CPPrecondition(my_start_col_min+my_ncol=SIZE(p_proj%proj_indexes),cp_failure_level,routineP,failure) ALLOCATE(tmp_min(blocksize,nrow_min), tmp_full(blocksize,nrow_full),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO icol=0,my_ncol-1,blocksize IF (icol+blocksize>my_ncol) blocksize=my_ncol-icol CALL cp_fm_get_submatrix(min_m, target_m=tmp_min, & start_col=icol+my_start_col_min, n_cols=blocksize, & - transpose=.TRUE.,& - error=error) + transpose=.TRUE.) CALL dcopy(SIZE(tmp_full,1)*SIZE(tmp_full,2),0.0_dp,0,tmp_full(1,1),1) DO i=1,SIZE(p_proj%proj_indexes) @@ -264,12 +249,11 @@ SUBROUTINE p_proj_transfer_blacs_to_f(p_proj, min_m, full_m,& CALL cp_fm_set_submatrix(full_m, new_values=tmp_full, & start_col=icol+my_start_col_full, n_cols=blocksize, & - transpose=.TRUE.,& - error=error) + transpose=.TRUE.) END DO DEALLOCATE(tmp_min, tmp_full, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE p_proj_transfer_blacs_to_f @@ -282,19 +266,16 @@ END SUBROUTINE p_proj_transfer_blacs_to_f !> \param full_m the matrix in the full basis to be restrained !> \param start_col the first column to restrain (defaults to 1) !> \param ncol number of columns to restrain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2003 created [fawzi] !> \author fawzi !> \note !> keep_row could easily reduced to (min(proj_indexes):max(proj_indexes)) ! ***************************************************************************** -SUBROUTINE p_proj_restrain_f(p_proj, full_m,start_col, ncol, error) +SUBROUTINE p_proj_restrain_f(p_proj, full_m,start_col, ncol) TYPE(qs_p_projection_type), POINTER :: p_proj TYPE(cp_fm_type), POINTER :: full_m INTEGER, INTENT(in), OPTIONAL :: start_col, ncol - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p_proj_restrain_f', & routineP = moduleN//':'//routineN @@ -312,19 +293,19 @@ SUBROUTINE p_proj_restrain_f(p_proj, full_m,start_col, ncol, error) failure=.FALSE. NULLIFY(row_indices,col_indices) - CPPrecondition(ASSOCIATED(p_proj),cp_failure_level,routineP,error,failure) - CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(full_m),cp_failure_level,routineP,error,failure) - CPPrecondition(full_m%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_proj),cp_failure_level,routineP,failure) + CPPrecondition(p_proj%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(full_m),cp_failure_level,routineP,failure) + CPPrecondition(full_m%ref_count>0,cp_failure_level,routineP,failure) min_index=MINVAL(p_proj%proj_indexes) max_index=MAXVAL(p_proj%proj_indexes) ALLOCATE(keep_row(min_index:max_index),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) my_start_col=1 IF (PRESENT(start_col)) my_start_col=start_col CALL cp_fm_get_info(full_m,ncol_global=my_end_col, & - row_indices=row_indices, col_indices=col_indices,error=error) + row_indices=row_indices, col_indices=col_indices) IF (PRESENT(ncol)) my_end_col=start_col+ncol keep_row=.FALSE. @@ -347,7 +328,7 @@ SUBROUTINE p_proj_restrain_f(p_proj, full_m,start_col, ncol, error) END DO DEALLOCATE(keep_row,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE p_proj_restrain_f diff --git a/src/qs_pdos.F b/src/qs_pdos.F index 54de444528..f806bf3cf2 100644 --- a/src/qs_pdos.F +++ b/src/qs_pdos.F @@ -126,7 +126,6 @@ MODULE qs_pdos !> \param qs_env ... !> \param dft_section ... !> \param ispin ... -!> \param error ... !> \date 26.02.2008 !> \par History: !> - @@ -137,7 +136,7 @@ MODULE qs_pdos !> \version 1.0 ! ***************************************************************************** SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_set,qs_env,& - dft_section,ispin,error) + dft_section,ispin) TYPE(mo_set_type), POINTER :: mo_set TYPE(atomic_kind_type), DIMENSION(:), & @@ -149,7 +148,6 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: dft_section INTEGER, INTENT(IN), OPTIONAL :: ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_projected_dos', & routineP = moduleN//':'//routineN @@ -204,11 +202,11 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s TYPE(section_vals_type), POINTER :: ldos_section NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ionode = logger%para_env%mepos==logger%para_env%source failure = .FALSE. should_output = BTEST(cp_print_key_should_output(logger%iter_info,dft_section,& - "PRINT%PDOS",error=error),cp_p_file) + "PRINT%PDOS"),cp_p_file) output_unit= cp_logger_get_default_io_unit(logger) spin(1)="ALPHA" @@ -226,10 +224,10 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s IF (output_unit > 0) WRITE(UNIT=output_unit,FMT='(/,(T3,A,T61,I10))')& " Calculate PDOS at iteration step ", iterstep CALL get_qs_env(qs_env=qs_env,& - matrix_s=s_matrix,error=error) + matrix_s=s_matrix) CALL get_atomic_kind_set(atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set, nsgf=nsgf, maxlgto=maxlgto, error=error) + CALL get_qs_kind_set(qs_kind_set, nsgf=nsgf, maxlgto=maxlgto) nkind = SIZE(atomic_kind_set) CALL get_mo_set(mo_set=mo_set, mo_coeff=mo_coeff, homo=homo, nao=nao, nmo=nmo,& @@ -237,11 +235,11 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s CALL cp_fm_get_info(mo_coeff,& context=context, para_env=para_env,& nrow_global=nrow_global,& - ncol_global=ncol_global,error=error) + ncol_global=ncol_global) - CALL section_vals_val_get(dft_section,"PRINT%PDOS%OUT_EACH_MO",i_val=out_each,error=error) + CALL section_vals_val_get(dft_section,"PRINT%PDOS%OUT_EACH_MO",i_val=out_each) IF(out_each==-1) out_each=nao+1 - CALL section_vals_val_get(dft_section,"PRINT%PDOS%NLUMO",i_val=nlumo,error=error) + CALL section_vals_val_get(dft_section,"PRINT%PDOS%NLUMO",i_val=nlumo) IF (nlumo == -1) nlumo = nao - homo do_virt = (nlumo>(nmo-homo)) nvirt = nlumo - (nmo-homo) @@ -253,7 +251,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s my_spin = 1 END IF - CALL generate_virtual_mo(qs_env,mo_set, evals_virt, mo_virt, nvirt, ispin=my_spin, error=error ) + CALL generate_virtual_mo(qs_env,mo_set, evals_virt, mo_virt, nvirt, ispin=my_spin) ELSE NULLIFY (evals_virt,mo_virt) nvirt = 0 @@ -261,62 +259,61 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s ! Create S^1/2 : from sparse to full matrix CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=context, & - nrow_global=nrow_global,ncol_global=nrow_global,error=error) - CALL cp_fm_create(matrix_shalf, fm_struct_tmp,name="matrix_shalf",error=error) - CALL cp_fm_create(matrix_work, fm_struct_tmp,name="matrix_work",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL copy_dbcsr_to_fm(s_matrix(1)%matrix,matrix_shalf,error=error) - CALL cp_fm_power(matrix_shalf,matrix_work,0.5_dp,EPSILON(0.0_dp),n_dependent,error=error) - CALL cp_fm_release(matrix_work,error=error) + nrow_global=nrow_global,ncol_global=nrow_global) + CALL cp_fm_create(matrix_shalf, fm_struct_tmp,name="matrix_shalf") + CALL cp_fm_create(matrix_work, fm_struct_tmp,name="matrix_work") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL copy_dbcsr_to_fm(s_matrix(1)%matrix,matrix_shalf) + CALL cp_fm_power(matrix_shalf,matrix_work,0.5_dp,EPSILON(0.0_dp),n_dependent) + CALL cp_fm_release(matrix_work) ! Multiply S^(1/2) time the mOS coefficients to get orthonormalized MOS CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=context, & - nrow_global=nrow_global,ncol_global=ncol_global,error=error) - CALL cp_fm_create(matrix_shalfc,fm_struct_tmp,name="matrix_shalfc",error=error) + nrow_global=nrow_global,ncol_global=ncol_global) + CALL cp_fm_create(matrix_shalfc,fm_struct_tmp,name="matrix_shalfc") CALL cp_gemm("N","N",nrow_global,ncol_global,nrow_global, & - 1.0_dp,matrix_shalf,mo_coeff,0.0_dp,matrix_shalfc,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + 1.0_dp,matrix_shalf,mo_coeff,0.0_dp,matrix_shalfc) + CALL cp_fm_struct_release(fm_struct_tmp) IF (do_virt) THEN IF (output_unit > 0) WRITE(UNIT=output_unit,FMT='(/,(T3,A,T14,I10,T27,A))')& " Compute ", nvirt, " additional unoccupied KS orbitals" CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=context, & - nrow_global=nrow_global,ncol_global=nvirt,error=error) - CALL cp_fm_create(matrix_work,fm_struct_tmp,name="matrix_shalfc",error=error) + nrow_global=nrow_global,ncol_global=nvirt) + CALL cp_fm_create(matrix_work,fm_struct_tmp,name="matrix_shalfc") CALL cp_gemm("N","N",nrow_global,nvirt,nrow_global, & - 1.0_dp,matrix_shalf,mo_virt,0.0_dp,matrix_work,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + 1.0_dp,matrix_shalf,mo_virt,0.0_dp,matrix_work) + CALL cp_fm_struct_release(fm_struct_tmp) END IF - CALL cp_fm_release(matrix_shalf,error=error) + CALL cp_fm_release(matrix_shalf) ! Array to store the PDOS per kind and angular momentum do_ldos = .FALSE. - ldos_section => section_vals_get_subs_vals(dft_section,"PRINT%PDOS%LDOS",error=error) + ldos_section => section_vals_get_subs_vals(dft_section,"PRINT%PDOS%LDOS") - CALL section_vals_get(ldos_section,n_repetition=nldos,error=error) + CALL section_vals_get(ldos_section,n_repetition=nldos) IF(nldos>0) THEN IF (output_unit > 0) WRITE(UNIT=output_unit,FMT='(/,(T3,A,T61,I10))')& " Prepare the list of atoms for LDOS. Number of lists: ", nldos do_ldos = .TRUE. ALLOCATE(ldos_p(nldos),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ldos_index(nldos),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ildos=1,nldos WRITE(ldos_index(ildos),'(I0)') ildos ALLOCATE(ldos_p(ildos)%ldos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(ldos_p(ildos)%ldos%pdos_array) NULLIFY(ldos_p(ildos)%ldos%list_index) - CALL section_vals_val_get(ldos_section,"LIST",i_rep_section=ildos, n_rep_val=n_rep,& - error=error) + CALL section_vals_val_get(ldos_section,"LIST",i_rep_section=ildos, n_rep_val=n_rep) IF(n_rep>0) THEN ldos_p(ildos)%ldos%nlist = 0 DO ir = 1,n_rep NULLIFY (list) CALL section_vals_val_get(ldos_section,"LIST",i_rep_section=ildos,i_rep_val=ir,& - i_vals=list, error=error) + i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(ldos_p(ildos)%ldos%list_index,1,ldos_p(ildos)%ldos%nlist+SIZE(list)) DO i = 1,SIZE(list) @@ -332,13 +329,13 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s IF (output_unit > 0) WRITE(UNIT=output_unit,FMT='((T10,A,T18,I6,T25,A,T36,I10,A))')& " List ",ildos , " contains ", ldos_p(ildos)%ldos%nlist , " atoms" CALL section_vals_val_get(ldos_section,"COMPONENTS",i_rep_section=ildos,& - l_val=ldos_p(ildos)%ldos%separate_components,error=error) + l_val=ldos_p(ildos)%ldos%separate_components) IF(ldos_p(ildos)%ldos%separate_components) THEN ALLOCATE(ldos_p(ildos)%ldos%pdos_array(nsoset(maxlgto),nmo+nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(ldos_p(ildos)%ldos%pdos_array(0:maxlgto,nmo+nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ldos_p(ildos)%ldos%pdos_array=0.0_dp ldos_p(ildos)%ldos%maxl = -1 @@ -347,45 +344,44 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s END IF do_r_ldos = .FALSE. - ldos_section => section_vals_get_subs_vals(dft_section,"PRINT%PDOS%R_LDOS",error=error) - CALL section_vals_get(ldos_section,n_repetition=n_r_ldos,error=error) + ldos_section => section_vals_get_subs_vals(dft_section,"PRINT%PDOS%R_LDOS") + CALL section_vals_get(ldos_section,n_repetition=n_r_ldos) IF(n_r_ldos>0) THEN do_r_ldos = .TRUE. IF (output_unit > 0) WRITE(UNIT=output_unit,FMT='(/,(T3,A,T61,I10))')& " Prepare the list of points for R_LDOS. Number of lists: ", n_r_ldos ALLOCATE(r_ldos_p(n_r_ldos),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(r_ldos_index(n_r_ldos),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env,& cell=cell,& dft_control=dft_control,& - pw_env=pw_env,error=error) + pw_env=pw_env) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,wf_g%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) ALLOCATE(read_r(4,n_r_ldos),STAT=stat) DO ildos=1,n_r_ldos WRITE(r_ldos_index(ildos),'(I0)') ildos ALLOCATE(r_ldos_p(ildos)%ldos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(r_ldos_p(ildos)%ldos%pdos_array) NULLIFY(r_ldos_p(ildos)%ldos%list_index) - CALL section_vals_val_get(ldos_section,"LIST",i_rep_section=ildos, n_rep_val=n_rep,& - error=error) + CALL section_vals_val_get(ldos_section,"LIST",i_rep_section=ildos, n_rep_val=n_rep) IF(n_rep>0) THEN r_ldos_p(ildos)%ldos%nlist = 0 DO ir = 1,n_rep NULLIFY (list) CALL section_vals_val_get(ldos_section,"LIST",i_rep_section=ildos,i_rep_val=ir,& - i_vals=list, error=error) + i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(r_ldos_p(ildos)%ldos%list_index,1,r_ldos_p(ildos)%ldos%nlist+SIZE(list)) DO i = 1,SIZE(list) @@ -399,38 +395,38 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s END IF ALLOCATE(r_ldos_p(ildos)%ldos%pdos_array(nmo+nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r_ldos_p(ildos)%ldos%pdos_array=0.0_dp read_r(1:3, ildos) = .FALSE. - CALL section_vals_val_get(ldos_section,"XRANGE",i_rep_section=ildos,explicit=read_r(1,ildos),error=error) + CALL section_vals_val_get(ldos_section,"XRANGE",i_rep_section=ildos,explicit=read_r(1,ildos)) IF (read_r(1,ildos)) THEN CALL section_vals_val_get(ldos_section,"XRANGE",i_rep_section=ildos,r_vals=& - r_ldos_p(ildos)%ldos%x_range, error=error) + r_ldos_p(ildos)%ldos%x_range) ELSE ALLOCATE(r_ldos_p(ildos)%ldos%x_range(2)) r_ldos_p(ildos)%ldos%x_range=0.0_dp END IF - CALL section_vals_val_get(ldos_section,"YRANGE",i_rep_section=ildos,explicit=read_r(2,ildos),error=error) + CALL section_vals_val_get(ldos_section,"YRANGE",i_rep_section=ildos,explicit=read_r(2,ildos)) IF (read_r(2,ildos)) THEN CALL section_vals_val_get(ldos_section,"YRANGE",i_rep_section=ildos,r_vals=& - r_ldos_p(ildos)%ldos%y_range, error=error) + r_ldos_p(ildos)%ldos%y_range) ELSE ALLOCATE(r_ldos_p(ildos)%ldos%y_range(2)) r_ldos_p(ildos)%ldos%y_range=0.0_dp END IF - CALL section_vals_val_get(ldos_section,"ZRANGE",i_rep_section=ildos,explicit=read_r(3,ildos),error=error) + CALL section_vals_val_get(ldos_section,"ZRANGE",i_rep_section=ildos,explicit=read_r(3,ildos)) IF (read_r(3,ildos)) THEN CALL section_vals_val_get(ldos_section,"ZRANGE",i_rep_section=ildos,r_vals=& - r_ldos_p(ildos)%ldos%z_range, error=error) + r_ldos_p(ildos)%ldos%z_range) ELSE ALLOCATE(r_ldos_p(ildos)%ldos%z_range(2)) r_ldos_p(ildos)%ldos%z_range=0.0_dp END IF - CALL section_vals_val_get(ldos_section,"ERANGE",i_rep_section=ildos,explicit=read_r(4,ildos),error=error) + CALL section_vals_val_get(ldos_section,"ERANGE",i_rep_section=ildos,explicit=read_r(4,ildos)) IF (read_r(4,ildos)) THEN CALL section_vals_val_get(ldos_section,"ERANGE",i_rep_section=ildos,& - r_vals=r_ldos_p(ildos)%ldos%eval_range, error=error) + r_vals=r_ldos_p(ildos)%ldos%eval_range) ELSE ALLOCATE(r_ldos_p(ildos)%ldos%eval_range(2)) r_ldos_p(ildos)%ldos%eval_range(1)=-HUGE(0.0_dp) @@ -442,7 +438,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s dvol = wf_r%pw%pw_grid%dvol np_tot = wf_r%pw%pw_grid%npts(1)*wf_r%pw%pw_grid%npts(2)*wf_r%pw%pw_grid%npts(3) ALLOCATE(r_ldos_p(ildos)%ldos%index_grid_local(3,np_tot), STAT =stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r_ldos_p(ildos)%ldos%npoints = 0 DO jz=bo(1,3),bo(2,3) @@ -513,22 +509,21 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s END IF - CALL section_vals_val_get(dft_section,"PRINT%PDOS%COMPONENTS",l_val=separate_components,& - error=error) + CALL section_vals_val_get(dft_section,"PRINT%PDOS%COMPONENTS",l_val=separate_components) IF (separate_components) THEN ALLOCATE(pdos_array(nsoset(maxlgto),nkind,nmo+nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ALLOCATE(pdos_array(0:maxlgto,nkind,nmo+nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(do_virt) THEN ALLOCATE(eigenvalues(nmo+nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) eigenvalues(1:nmo) = mo_set%eigenvalues(1:nmo) eigenvalues(nmo+1:nmo+nvirt) = evals_virt(1:nvirt) ALLOCATE(occupation_numbers(nmo+nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) occupation_numbers(:) = 0.0_dp occupation_numbers(1:nmo) = mo_set%occupation_numbers(1:nmo) ELSE @@ -539,10 +534,10 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s pdos_array = 0.0_dp nao = mo_set%nao ALLOCATE(vecbuffer(1,nao),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vecbuffer = 0.0_dp ALLOCATE(firstrow(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) firstrow=0 !Adjust energy range for r_ldos @@ -563,10 +558,10 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s ! Extract the eigenvector from the distributed full matrix IF(imo>nmo) THEN CALL cp_fm_get_submatrix(matrix_work,vecbuffer,1,imo-nmo,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) ELSE CALL cp_fm_get_submatrix(matrix_shalfc,vecbuffer,1,imo,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) END IF ! Calculate the pdos for all the kinds @@ -575,7 +570,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s firstrow(iatom)=irow NULLIFY(orb_basis_set) CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& nshell=nshell,& @@ -618,7 +613,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s irow=firstrow(iatom) NULLIFY(orb_basis_set) CALL get_atomic_kind(particle_set(iatom)%atomic_kind, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,& nset=nset,& @@ -665,11 +660,11 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s IF(imo>nmo) THEN CALL calculate_wavefunction(mo_virt,imo-nmo,& wf_r, wf_g, atomic_kind_set, qs_kind_set,cell,dft_control,particle_set, & - pw_env, error = error ) + pw_env) ELSE CALL calculate_wavefunction(mo_coeff,imo,& wf_r, wf_g, atomic_kind_set,qs_kind_set,cell,dft_control,particle_set, & - pw_env, error = error ) + pw_env) END IF r_ldos_p(ildos)%ldos%pdos_array(imo) = 0.0_dp DO il = 1,r_ldos_p(ildos)%ldos%npoints @@ -685,12 +680,12 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s END DO END DO ! imo - CALL cp_fm_release(matrix_shalfc,error=error) + CALL cp_fm_release(matrix_shalfc) DEALLOCATE(vecbuffer,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL section_vals_val_get(dft_section,"PRINT%PDOS%APPEND",l_val=append,error=error) + CALL section_vals_val_get(dft_section,"PRINT%PDOS%APPEND",l_val=append) IF(append .AND. iterstep > 1 ) THEN my_pos = "APPEND" ELSE @@ -701,7 +696,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s NULLIFY(orb_basis_set) CALL get_atomic_kind(atomic_kind_set(ikind), name=kind_name) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(gto_basis_set=orb_basis_set, maxl=maxl) ! basis none has no associated maxl, and no pdos @@ -717,8 +712,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%PDOS",& extension=".pdos", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(my_mittle), & - error=error) + file_form="FORMATTED", middle_name=TRIM(my_mittle)) IF(iw>0) THEN fmtstr1 = "(I8,2X,2F16.6, (2X,F16.8))" @@ -736,7 +730,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s iterstep,", E(Fermi) = ",e_fermi," a.u." IF (separate_components) THEN ALLOCATE(tmp_str(0:0,0:maxl,-maxl:maxl),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_str = "" DO j = 0, maxl DO i = -j,j @@ -752,7 +746,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s (pdos_array(lshell,ikind,imo),lshell=1,nsoset(maxl)) END DO DEALLOCATE(tmp_str,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE WRITE (UNIT=iw,FMT=fmtstr2)& "# MO Eigenvalue [a.u.] Occupation",& @@ -764,7 +758,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s END IF END IF CALL cp_print_key_finished_output(iw,logger,dft_section,& - "PRINT%PDOS", error=error) + "PRINT%PDOS") END DO ! ikind @@ -785,8 +779,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%PDOS",& extension=".pdos", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(my_mittle), & - error=error) + file_form="FORMATTED", middle_name=TRIM(my_mittle)) IF(iw>0) THEN fmtstr1 = "(I8,2X,2F16.6, (2X,F16.8))" @@ -804,7 +797,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s ", E(Fermi) = ",e_fermi," a.u." IF(ldos_p(ildos)%ldos%separate_components) THEN ALLOCATE(tmp_str(0:0,0:ldos_p(ildos)%ldos%maxl,-ldos_p(ildos)%ldos%maxl:ldos_p(ildos)%ldos%maxl),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_str = "" DO j = 0, ldos_p(ildos)%ldos%maxl DO i = -j,j @@ -820,7 +813,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s (ldos_p(ildos)%ldos%pdos_array(lshell,imo),lshell=1,nsoset(ldos_p(ildos)%ldos%maxl)) END DO DEALLOCATE(tmp_str,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE WRITE (UNIT=iw,FMT=fmtstr2)& "# MO Eigenvalue [a.u.] Occupation",& @@ -832,7 +825,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s END IF END IF CALL cp_print_key_finished_output(iw,logger,dft_section,& - "PRINT%PDOS", error=error) + "PRINT%PDOS") END IF ! maxl>0 END DO ! ildos @@ -854,8 +847,7 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%PDOS",& extension=".pdos", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(my_mittle), & - error=error) + file_form="FORMATTED", middle_name=TRIM(my_mittle)) IF(iw>0) THEN fmtstr1 = "(I8,2X,2F16.6, (2X,F16.8))" fmtstr2 = "(A42, (10X,A8))" @@ -876,37 +868,37 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s END IF CALL cp_print_key_finished_output(iw,logger,dft_section,& - "PRINT%PDOS", error=error) + "PRINT%PDOS") END DO ! deallocate local variables DEALLOCATE(pdos_array, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(firstrow, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(do_ldos) THEN DO ildos = 1,nldos DEALLOCATE(ldos_p(ildos)%ldos%pdos_array, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ldos_p(ildos)%ldos%list_index, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ldos_p(ildos)%ldos, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(ldos_p, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ldos_index, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(do_r_ldos) THEN DO ildos = 1,n_r_ldos DEALLOCATE(r_ldos_p(ildos)%ldos%index_grid_local,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_ldos_p(ildos)%ldos%pdos_array,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r_ldos_p(ildos)%ldos%list_index,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(.NOT. read_r(1,ildos)) THEN DEALLOCATE(r_ldos_p(ildos)%ldos%x_range) END IF @@ -920,25 +912,25 @@ SUBROUTINE calculate_projected_dos(mo_set,atomic_kind_set,qs_kind_set,particle_s DEALLOCATE(r_ldos_p(ildos)%ldos%eval_range) END IF DEALLOCATE(r_ldos_p(ildos)%ldos,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(read_r,STAT=stat) DEALLOCATE(r_ldos_p, STAT=stat) DEALLOCATE(r_ldos_index, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw) END IF IF(do_virt) THEN DEALLOCATE(evals_virt,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_fm_release(mo_virt,error=error) - CALL cp_fm_release(matrix_work,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_fm_release(mo_virt) + CALL cp_fm_release(matrix_work) DEALLOCATE(eigenvalues,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(occupation_numbers,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -953,7 +945,6 @@ END SUBROUTINE calculate_projected_dos !> \param mo_virt ... !> \param nvirt ... !> \param ispin ... -!> \param error ... !> \date 08.03.2008 !> \par History: !> - @@ -965,14 +956,13 @@ END SUBROUTINE calculate_projected_dos ! ***************************************************************************** SUBROUTINE generate_virtual_mo (qs_env, mo_set, evals_virt, mo_virt, & - nvirt, ispin, error ) + nvirt, ispin) TYPE(qs_environment_type), POINTER :: qs_env TYPE(mo_set_type), POINTER :: mo_set REAL(KIND=dp), DIMENSION(:), POINTER :: evals_virt TYPE(cp_fm_type), POINTER :: mo_virt INTEGER, INTENT(IN) :: nvirt, ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_virtual_mo', & routineP = moduleN//':'//routineN @@ -991,19 +981,19 @@ SUBROUTINE generate_virtual_mo (qs_env, mo_set, evals_virt, mo_virt, & failure = .FALSE. NULLIFY(evals_virt,mo_virt) ALLOCATE(evals_virt(nvirt),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,matrix_ks=ks_matrix, matrix_s=s_matrix, & - scf_control=scf_control, error=error) + scf_control=scf_control) CALL get_mo_set(mo_set=mo_set, mo_coeff=mo_coeff, nmo=nmo ) CALL cp_fm_get_info(mo_coeff, context=context, para_env=para_env,& - nrow_global=nrow_global, error=error) + nrow_global=nrow_global) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=context, & - nrow_global=nrow_global,ncol_global=nvirt,error=error) - CALL cp_fm_create(mo_virt, fm_struct_tmp,name="virtual",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_init_random(mo_virt,nvirt,error=error) + nrow_global=nrow_global,ncol_global=nvirt) + CALL cp_fm_create(mo_virt, fm_struct_tmp,name="virtual") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_init_random(mo_virt,nvirt) NULLIFY (local_preconditioner) @@ -1012,10 +1002,10 @@ SUBROUTINE generate_virtual_mo (qs_env, mo_set, evals_virt, mo_virt, & eps_gradient=scf_control%eps_lumos, & preconditioner=local_preconditioner, & iter_max=scf_control%max_iter_lumos,& - size_ortho_space=nmo,error=error) + size_ortho_space=nmo) CALL calculate_subspace_eigenvalues(mo_virt,ks_matrix(ispin)%matrix,& - evals_virt, error=error) + evals_virt) END SUBROUTINE generate_virtual_mo diff --git a/src/qs_period_efield_types.F b/src/qs_period_efield_types.F index edb397ec02..5fceddfb7a 100644 --- a/src/qs_period_efield_types.F +++ b/src/qs_period_efield_types.F @@ -41,11 +41,9 @@ MODULE qs_period_efield_types ! ***************************************************************************** !> \brief ... !> \param efield ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_efield_matrices(efield,error) + SUBROUTINE init_efield_matrices(efield) TYPE(efield_berry_type), POINTER :: efield - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_efield_matrices', & routineP = moduleN//':'//routineN @@ -61,14 +59,14 @@ SUBROUTINE init_efield_matrices(efield,error) IF(ASSOCIATED(efield)) THEN field_energy = efield%field_energy polarisation = efield%polarisation - CALL efield_berry_release(efield,error) + CALL efield_berry_release(efield) ELSE field_energy = 0.0_dp polarisation = 0.0_dp END IF ALLOCATE(efield,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(efield%cosmat) NULLIFY(efield%sinmat) NULLIFY(efield%dipmat) @@ -103,11 +101,9 @@ END SUBROUTINE set_efield_matrices ! ***************************************************************************** !> \brief ... !> \param efield ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE efield_berry_release(efield,error) + SUBROUTINE efield_berry_release(efield) TYPE(efield_berry_type), POINTER :: efield - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'efield_berry_release', & routineP = moduleN//':'//routineN @@ -118,14 +114,14 @@ SUBROUTINE efield_berry_release(efield,error) failure =.FALSE. IF(ASSOCIATED(efield))THEN IF(ASSOCIATED(efield%sinmat).AND.ASSOCIATED(efield%cosmat))THEN - CALL cp_dbcsr_deallocate_matrix_set ( efield%cosmat, error ) - CALL cp_dbcsr_deallocate_matrix_set ( efield%sinmat, error ) + CALL cp_dbcsr_deallocate_matrix_set ( efield%cosmat) + CALL cp_dbcsr_deallocate_matrix_set ( efield%sinmat) END IF IF(ASSOCIATED(efield%dipmat))THEN - CALL cp_dbcsr_deallocate_matrix_set ( efield%dipmat, error ) + CALL cp_dbcsr_deallocate_matrix_set ( efield%dipmat) END IF DEALLOCATE(efield,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE efield_berry_release diff --git a/src/qs_resp.F b/src/qs_resp.F index f2e33dcb4a..f5a18e8737 100644 --- a/src/qs_resp.F +++ b/src/qs_resp.F @@ -123,12 +123,9 @@ MODULE qs_resp ! ***************************************************************************** !> \brief performs resp fit and generates RESP charges !> \param qs_env the qs environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE resp_fit(qs_env,error) + SUBROUTINE resp_fit(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'resp_fit', & routineP = moduleN//':'//routineN @@ -157,39 +154,38 @@ SUBROUTINE resp_fit(qs_env,error) resp_section,cons_section,rest_section,poisson_section,resp_env,rep_sys) failure=.FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, input=input,& - subsys=subsys,particle_set=particle_set, cell=cell, error=error) - resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP",& - error=error) - CALL section_vals_get(resp_section, explicit=has_resp, error=error) + subsys=subsys,particle_set=particle_set, cell=cell) + resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP") + CALL section_vals_get(resp_section, explicit=has_resp) IF (.NOT. failure .AND. has_resp) THEN - logger => cp_error_get_logger(error) - poisson_section => section_vals_get_subs_vals(input,"DFT%POISSON",error=error) - CALL section_vals_val_get(poisson_section,"PERIODIC",i_val=my_per,error=error) - CALL create_resp_type(resp_env, rep_sys, error) + logger => cp_get_default_logger() + poisson_section => section_vals_get_subs_vals(input,"DFT%POISSON") + CALL section_vals_val_get(poisson_section,"PERIODIC",i_val=my_per) + CALL create_resp_type(resp_env, rep_sys) !initialize the RESP fitting, get all the keywords CALL init_resp(resp_env,rep_sys,subsys,atomic_kind_set,& - cell,resp_section,cons_section,rest_section,error) + cell,resp_section,cons_section,rest_section) !print info - CALL print_resp_parameter_info(qs_env,resp_env,rep_sys,my_per,error) + CALL print_resp_parameter_info(qs_env,resp_env,rep_sys,my_per) - CALL qs_subsys_get(subsys,particles=particles,error=error) + CALL qs_subsys_get(subsys,particles=particles) natom=particles%n_els nvar=natom+resp_env%ncons ALLOCATE(ipiv(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) IF(.NOT.ASSOCIATED(resp_env%matrix)) THEN ALLOCATE(resp_env%matrix(nvar,nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ENDIF IF(.NOT.ASSOCIATED(resp_env%rhs)) THEN ALLOCATE(resp_env%rhs(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ENDIF ipiv =0 resp_env%matrix = 0.0_dp @@ -199,19 +195,19 @@ SUBROUTINE resp_fit(qs_env,error) SELECT CASE (my_per) CASE(use_perd_none) CALL calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set, particles,cell,& - resp_env%matrix,resp_env%rhs,natom,error) + resp_env%matrix,resp_env%rhs,natom) CASE(use_perd_xyz) CALL cite_reference(Golze2015) - CALL calc_resp_matrix_periodic(qs_env,resp_env,rep_sys,particles,cell,natom, error) + CALL calc_resp_matrix_periodic(qs_env,resp_env,rep_sys,particles,cell,natom) CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="RESP charges only implemented for nonperiodic systems"//& " or XYZ periodicity!", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT output_unit=cp_print_key_unit_nr(logger,resp_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".resp",error=error) + extension=".resp") IF (output_unit>0) THEN WRITE(output_unit,'(T3,A,T69,I12)') "Number of potential fitting "//& "points found: ",resp_env%npoints @@ -220,23 +216,23 @@ SUBROUTINE resp_fit(qs_env,error) !adding restraints and constraints CALL add_restraints_and_constraints(qs_env,resp_env,rest_section,& - subsys,natom,cons_section,particle_set,error) + subsys,natom,cons_section,particle_set) !solve system for the values of the charges and the lagrangian multipliers CALL DGETRF(nvar,nvar,resp_env%matrix,nvar,ipiv,info) - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) CALL DGETRS('N',nvar,1,resp_env%matrix,nvar,ipiv,resp_env%rhs,nvar,info) - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) - CALL print_resp_charges(qs_env,resp_env,output_unit,natom,error) - CALL print_pot_from_resp_charges(qs_env,resp_env,particles,natom,output_unit,error) + CALL print_resp_charges(qs_env,resp_env,output_unit,natom) + CALL print_pot_from_resp_charges(qs_env,resp_env,particles,natom,output_unit) DEALLOCATE(ipiv, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) - CALL resp_dealloc(resp_env,rep_sys,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) + CALL resp_dealloc(resp_env,rep_sys) CALL cp_print_key_finished_output(output_unit,logger,resp_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") END IF @@ -248,13 +244,10 @@ END SUBROUTINE resp_fit !> \brief creates the resp_type structure !> \param resp_env the resp environment !> \param rep_sys structure for repeating input sections defining fit points -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE create_resp_type(resp_env, rep_sys, error) + SUBROUTINE create_resp_type(resp_env, rep_sys) TYPE(resp_type), POINTER :: resp_env TYPE(resp_p_type), DIMENSION(:), POINTER :: rep_sys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_resp_type', & routineP = moduleN//':'//routineN @@ -263,9 +256,9 @@ SUBROUTINE create_resp_type(resp_env, rep_sys, error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(resp_env)) CALL resp_dealloc(resp_env,rep_sys,error) + IF (ASSOCIATED(resp_env)) CALL resp_dealloc(resp_env,rep_sys) ALLOCATE(resp_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) NULLIFY(resp_env%matrix,& resp_env%fitpoints,& @@ -295,13 +288,10 @@ END SUBROUTINE create_resp_type !> \brief deallocates the resp_type structure !> \param resp_env the resp environment !> \param rep_sys structure for repeating input sections defining fit points -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE resp_dealloc(resp_env,rep_sys, error) + SUBROUTINE resp_dealloc(resp_env,rep_sys) TYPE(resp_type), POINTER :: resp_env TYPE(resp_p_type), DIMENSION(:), POINTER :: rep_sys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'resp_dealloc', & routineP = moduleN//':'//routineN @@ -311,36 +301,36 @@ SUBROUTINE resp_dealloc(resp_env,rep_sys, error) IF (ASSOCIATED(resp_env)) THEN IF (ASSOCIATED(resp_env%matrix)) THEN DEALLOCATE(resp_env%matrix, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF IF (ASSOCIATED(resp_env%rhs)) THEN DEALLOCATE(resp_env%rhs, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF IF (ASSOCIATED(resp_env%fitpoints)) THEN DEALLOCATE(resp_env%fitpoints, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF IF (ASSOCIATED(resp_env%rmin_kind))THEN DEALLOCATE(resp_env%rmin_kind, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF IF (ASSOCIATED(resp_env%rmax_kind))THEN DEALLOCATE(resp_env%rmax_kind, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF DEALLOCATE(resp_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF IF (ASSOCIATED(rep_sys)) THEN DO i=1, SIZE(rep_sys) DEALLOCATE(rep_sys(i)%p_resp%atom_surf_list, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) DEALLOCATE(rep_sys(i)%p_resp, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDDO DEALLOCATE(rep_sys, stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDIF END SUBROUTINE resp_dealloc @@ -355,11 +345,9 @@ END SUBROUTINE resp_dealloc !> \param resp_section resp section !> \param cons_section constraints section, part of resp section !> \param rest_section restraints section, part of resp section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE init_resp(resp_env,rep_sys,subsys,& - atomic_kind_set,cell,resp_section,cons_section,rest_section,error) + atomic_kind_set,cell,resp_section,cons_section,rest_section) TYPE(resp_type), POINTER :: resp_env TYPE(resp_p_type), DIMENSION(:), POINTER :: rep_sys @@ -369,7 +357,6 @@ SUBROUTINE init_resp(resp_env,rep_sys,subsys,& TYPE(cell_type), POINTER :: cell TYPE(section_vals_type), POINTER :: resp_section, cons_section, & rest_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_resp', & routineP = moduleN//':'//routineN @@ -385,34 +372,30 @@ SUBROUTINE init_resp(resp_env,rep_sys,subsys,& failure=.FALSE. ! get the subsections - sphere_section=>section_vals_get_subs_vals(resp_section,"SPHERE_SAMPLING",& - error=error) - slab_section=>section_vals_get_subs_vals(resp_section,"SLAB_SAMPLING",& - error=error) - cons_section=>section_vals_get_subs_vals(resp_section,"CONSTRAINT",& - error=error) - rest_section=>section_vals_get_subs_vals(resp_section,"RESTRAINT",& - error=error) + sphere_section=>section_vals_get_subs_vals(resp_section,"SPHERE_SAMPLING") + slab_section=>section_vals_get_subs_vals(resp_section,"SLAB_SAMPLING") + cons_section=>section_vals_get_subs_vals(resp_section,"CONSTRAINT") + rest_section=>section_vals_get_subs_vals(resp_section,"RESTRAINT") ! get and set the parameters for molecular (non-surface) systems CALL get_parameter_molecular_sys(resp_env, sphere_section, cell, & - atomic_kind_set, error) + atomic_kind_set) ! get the parameter for periodic/surface systems - CALL section_vals_get(slab_section, explicit=explicit, n_repetition=nrep, error=error) + CALL section_vals_get(slab_section, explicit=explicit, n_repetition=nrep) IF(explicit) THEN ALLOCATE(rep_sys(nrep), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) DO i=1, nrep ALLOCATE(rep_sys(i)%p_resp, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) NULLIFY(rep_sys(i)%p_resp%range_surf, rep_sys(i)%p_resp%atom_surf_list) CALL section_vals_val_get(slab_section,"RANGE",r_vals=rep_sys(i)%p_resp%range_surf,& - i_rep_section=i, error=error) + i_rep_section=i) CALL section_vals_val_get(slab_section,"LENGTH", r_val=rep_sys(i)%p_resp%length,& - i_rep_section=i, error=error) + i_rep_section=i) CALL section_vals_val_get(slab_section,"SURF_DIRECTION",& - i_rep_section=i, i_val=rep_sys(i)%p_resp%my_fit,error=error) + i_rep_section=i, i_val=rep_sys(i)%p_resp%my_fit) IF(ANY(rep_sys(i)%p_resp%range_surf<0.0_dp)) THEN CALL stop_program(routineN,moduleN,__LINE__,& "Numbers in RANGE in SLAB_SAMPLING cannot be negative.") @@ -422,45 +405,45 @@ SUBROUTINE init_resp(resp_env,rep_sys,subsys,& "Parameter LENGTH in SLAB_SAMPLING has to be larger than zero.") ENDIF !list of atoms specifing the surface - CALL build_atom_list(slab_section,subsys,rep_sys(i)%p_resp%atom_surf_list,rep=i,error=error) + CALL build_atom_list(slab_section,subsys,rep_sys(i)%p_resp%atom_surf_list,rep=i) ENDDO ENDIF ! get the parameters for the constraint and restraint sections - CALL section_vals_get(cons_section, explicit=explicit, error=error) + CALL section_vals_get(cons_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_get(cons_section,n_repetition=resp_env%ncons_sec,error=error) + CALL section_vals_get(cons_section,n_repetition=resp_env%ncons_sec) DO i=1,resp_env%ncons_sec CALL section_vals_val_get(cons_section,"EQUAL_CHARGES",l_val=resp_env%equal_charges,& - explicit=explicit,error=error) + explicit=explicit) IF(.NOT.explicit) CYCLE - CALL build_atom_list(cons_section,subsys,atom_list_cons,i,error=error) + CALL build_atom_list(cons_section,subsys,atom_list_cons,i) !instead of using EQUAL_CHARGES the constraint sections could be repeated resp_env%ncons=resp_env%ncons+SIZE(atom_list_cons)-2 DEALLOCATE(atom_list_cons,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDDO ENDIF - CALL section_vals_get(rest_section, explicit=explicit, error=error) + CALL section_vals_get(rest_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_get(rest_section,n_repetition=resp_env%nrest_sec,error=error) + CALL section_vals_get(rest_section,n_repetition=resp_env%nrest_sec) ENDIF resp_env%ncons=resp_env%ncons+resp_env%ncons_sec resp_env%nres=resp_env%nres+resp_env%nrest_sec ! get the general keywords CALL section_vals_val_get(resp_section,"INTEGER_TOTAL_CHARGE",& - l_val=resp_env%itc,error=error) + l_val=resp_env%itc) IF (resp_env%itc) resp_env%ncons=resp_env%ncons+1 CALL section_vals_val_get(resp_section,"RESTRAIN_HEAVIES_TO_ZERO",& - l_val=resp_env%rheavies,error=error) + l_val=resp_env%rheavies) IF (resp_env%rheavies) THEN CALL section_vals_val_get(resp_section,"RESTRAIN_HEAVIES_STRENGTH",& - r_val=resp_env%rheavies_strength,error=error) + r_val=resp_env%rheavies_strength) ENDIF - CALL section_vals_val_get(resp_section,"STRIDE",i_vals=my_stride,error=error) + CALL section_vals_val_get(resp_section,"STRIDE",i_vals=my_stride) CALL cp_assert(SIZE(my_stride)==1.OR.SIZE(my_stride)==3,cp_fatal_level,cp_assertion_failed,routineP,& "STRIDE keyword can accept only 1 (the same for X,Y,Z) or 3 values. Correct your input file."//& CPSourceFileRef,& @@ -472,7 +455,7 @@ SUBROUTINE init_resp(resp_env,rep_sys,subsys,& ELSE resp_env%stride = my_stride(1:3) END IF - CALL section_vals_val_get(resp_section,"WIDTH", r_val=resp_env%eta, error=error) + CALL section_vals_val_get(resp_section,"WIDTH", r_val=resp_env%eta) CALL timestop(handle) @@ -485,18 +468,15 @@ END SUBROUTINE init_resp !> fitting in spheres around the atom !> \param cell parameters related to the simulation cell !> \param atomic_kind_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE get_parameter_molecular_sys(resp_env,sphere_section,cell,& - atomic_kind_set,error) + atomic_kind_set) TYPE(resp_type), POINTER :: resp_env TYPE(section_vals_type), POINTER :: sphere_section TYPE(cell_type), POINTER :: cell TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_parameter_molecular_sys', & routineP = moduleN//':'//routineN @@ -515,68 +495,66 @@ SUBROUTINE get_parameter_molecular_sys(resp_env,sphere_section,cell,& nrep_rmax=0 nkind=SIZE(atomic_kind_set) - CALL section_vals_get(sphere_section, explicit=explicit, error=error) + CALL section_vals_get(sphere_section, explicit=explicit) IF(explicit) THEN resp_env%molecular_sys=.TRUE. - CALL section_vals_val_get(sphere_section,"RMIN",r_val=rmin,& - error=error) - CALL section_vals_val_get(sphere_section,"RMAX",r_val=rmax,& - error=error) - CALL section_vals_val_get(sphere_section,"RMIN_KIND", n_rep_val=nrep_rmin, error=error) - CALL section_vals_val_get(sphere_section,"RMAX_KIND", n_rep_val=nrep_rmax, error=error) + CALL section_vals_val_get(sphere_section,"RMIN",r_val=rmin) + CALL section_vals_val_get(sphere_section,"RMAX",r_val=rmax) + CALL section_vals_val_get(sphere_section,"RMIN_KIND", n_rep_val=nrep_rmin) + CALL section_vals_val_get(sphere_section,"RMAX_KIND", n_rep_val=nrep_rmax) ALLOCATE(resp_env%rmin_kind(nkind),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(resp_env%rmax_kind(nkind),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) resp_env%rmin_kind(:)=rmin resp_env%rmax_kind(:)=rmax DO j=1, nrep_rmin CALL section_vals_val_get(sphere_section,"RMIN_KIND", i_rep_val=j,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) DO ikind=1,nkind atomic_kind => atomic_kind_set(ikind) CALL get_atomic_kind(atomic_kind,element_symbol=symbol,kind_number=kind_number) IF(TRIM(tmpstringlist(2))==TRIM(symbol)) THEN READ(tmpstringlist(1),*) resp_env%rmin_kind(kind_number) resp_env%rmin_kind(kind_number)=cp_unit_to_cp2k(resp_env%rmin_kind(kind_number),& - "angstrom",error=error) + "angstrom") ENDIF ENDDO ENDDO DO j=1, nrep_rmax CALL section_vals_val_get(sphere_section,"RMAX_KIND", i_rep_val=j,& - c_vals=tmpstringlist, error=error) + c_vals=tmpstringlist) DO ikind=1,nkind atomic_kind => atomic_kind_set(ikind) CALL get_atomic_kind(atomic_kind,element_symbol=symbol,kind_number=kind_number) IF(TRIM(tmpstringlist(2))==TRIM(symbol)) THEN READ(tmpstringlist(1),*) resp_env%rmax_kind(kind_number) resp_env%rmax_kind(kind_number)=cp_unit_to_cp2k(resp_env%rmax_kind(kind_number),& - "angstrom",error=error) + "angstrom") ENDIF ENDDO ENDDO resp_env%box_hi=(/cell%hmat(1,1),cell%hmat(2,2),cell%hmat(3,3)/) resp_env%box_low=0.0_dp - CALL section_vals_val_get(sphere_section,"X_HI",explicit=explicit,error=error) + CALL section_vals_val_get(sphere_section,"X_HI",explicit=explicit) IF (explicit) CALL section_vals_val_get(sphere_section,"X_HI",& - r_val=resp_env%box_hi(1),error=error) - CALL section_vals_val_get(sphere_section,"X_LOW",explicit=explicit,error=error) + r_val=resp_env%box_hi(1)) + CALL section_vals_val_get(sphere_section,"X_LOW",explicit=explicit) IF (explicit) CALL section_vals_val_get(sphere_section,"X_LOW",& - r_val=resp_env%box_low(1),error=error) - CALL section_vals_val_get(sphere_section,"Y_HI",explicit=explicit,error=error) + r_val=resp_env%box_low(1)) + CALL section_vals_val_get(sphere_section,"Y_HI",explicit=explicit) IF (explicit) CALL section_vals_val_get(sphere_section,"Y_HI",& - r_val=resp_env%box_hi(2),error=error) - CALL section_vals_val_get(sphere_section,"Y_LOW",explicit=explicit,error=error) + r_val=resp_env%box_hi(2)) + CALL section_vals_val_get(sphere_section,"Y_LOW",explicit=explicit) IF (explicit) CALL section_vals_val_get(sphere_section,"Y_LOW",& - r_val=resp_env%box_low(2),error=error) - CALL section_vals_val_get(sphere_section,"Z_HI",explicit=explicit,error=error) + r_val=resp_env%box_low(2)) + CALL section_vals_val_get(sphere_section,"Z_HI",explicit=explicit) IF (explicit) CALL section_vals_val_get(sphere_section,"Z_HI",& - r_val=resp_env%box_hi(3),error=error) - CALL section_vals_val_get(sphere_section,"Z_LOW",explicit=explicit,error=error) + r_val=resp_env%box_hi(3)) + CALL section_vals_val_get(sphere_section,"Z_LOW",explicit=explicit) IF (explicit) CALL section_vals_val_get(sphere_section,"Z_LOW",& - r_val=resp_env%box_low(3),error=error) + r_val=resp_env%box_low(3)) ENDIF END SUBROUTINE get_parameter_molecular_sys @@ -589,16 +567,13 @@ END SUBROUTINE get_parameter_molecular_sys !> sampling for slab-like systems !> \param rep input section can be repeated, this param defines for which !> repetition of the input section the atom_list is built -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE build_atom_list(section,subsys,atom_list,rep,error) + SUBROUTINE build_atom_list(section,subsys,atom_list,rep) TYPE(section_vals_type), POINTER :: section TYPE(qs_subsys_type), POINTER :: subsys INTEGER, DIMENSION(:), POINTER :: atom_list INTEGER, INTENT(IN), OPTIONAL :: rep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_atom_list', & routineP = moduleN//':'//routineN @@ -617,30 +592,30 @@ SUBROUTINE build_atom_list(section,subsys,atom_list,rep,error) IF(PRESENT(rep)) irep=rep CALL section_vals_val_get(section,"ATOM_LIST",i_rep_section=irep,& - n_rep_val=n_var,error=error) + n_rep_val=n_var) num_atom=0 DO i=1,n_var CALL section_vals_val_get(section,"ATOM_LIST",i_rep_section=irep,& - i_rep_val=i,i_vals=indexes,error=error) + i_rep_val=i,i_vals=indexes) num_atom=num_atom + SIZE(indexes) ENDDO ALLOCATE(atom_list(num_atom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) atom_list=0 num_atom=1 DO i=1,n_var CALL section_vals_val_get(section,"ATOM_LIST",i_rep_section=irep,& - i_rep_val=i,i_vals=indexes,error=error) + i_rep_val=i,i_vals=indexes) atom_list(num_atom:num_atom+SIZE(indexes)-1)=indexes(:) num_atom = num_atom + SIZE(indexes) ENDDO !check atom list num_atom=num_atom-1 - CALL qs_subsys_get(subsys, nparticle=max_index, error=error) - CPPrecondition(SIZE(atom_list) /= 0,cp_failure_level,routineP,error,failure) + CALL qs_subsys_get(subsys, nparticle=max_index) + CPPrecondition(SIZE(atom_list) /= 0,cp_failure_level,routineP,failure) index_in_range=(MAXVAL(atom_list)<= max_index)& .AND.(MINVAL(atom_list) > 0) - CPPostcondition(index_in_range,cp_failure_level,routineP,error,failure) + CPPostcondition(index_in_range,cp_failure_level,routineP,failure) DO i=1,num_atom DO j=i+1,num_atom atom_a=atom_list(i) @@ -665,11 +640,9 @@ END SUBROUTINE build_atom_list !> \param matrix coefficient matrix of the linear system of equations !> \param rhs vector of the linear system of equations !> \param natom number of atoms -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set,particles,& - cell,matrix,rhs,natom,error) + cell,matrix,rhs,natom) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env @@ -680,7 +653,6 @@ SUBROUTINE calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set,particles,& REAL(KIND=dp), DIMENSION(:, :), POINTER :: matrix REAL(KIND=dp), DIMENSION(:), POINTER :: rhs INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_resp_matrix_nonper', & routineP = moduleN//':'//routineN @@ -711,7 +683,7 @@ SUBROUTINE calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set,particles,& CALL cp_unimplemented_error(fromWhere=routineP, & message="Nonperiodic solution for RESP charges only"//& " implemented for orthorhombic cells!", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF(.NOT.resp_env%molecular_sys) THEN CALL stop_program(routineN,moduleN,__LINE__,& @@ -721,13 +693,11 @@ SUBROUTINE calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set,particles,& CALL get_qs_env(qs_env,& input=input,& particle_set=particle_set,& - v_hartree_rspace=v_hartree_pw,& - error=error) - resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP",& - error=error) + v_hartree_rspace=v_hartree_pw) + resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP") print_key => section_vals_get_subs_vals(resp_section,& - "PRINT%V_RESP_CUBE",error=error) - logger => cp_error_get_logger(error) + "PRINT%V_RESP_CUBE") + logger => cp_get_default_logger() bo=v_hartree_pw%pw_grid%bounds_local gbo=v_hartree_pw%pw_grid%bounds @@ -737,17 +707,17 @@ SUBROUTINE calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set,particles,& nkind=SIZE(atomic_kind_set) ALLOCATE(dist(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(not_in_range(natom,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) !only store fitting points when printing RESP potential IF (BTEST(cp_print_key_should_output(logger%iter_info,resp_section,& - "PRINT%V_RESP_CUBE",error=error),cp_p_file)) THEN + "PRINT%V_RESP_CUBE"),cp_p_file)) THEN IF(.NOT.ASSOCIATED(resp_env%fitpoints)) THEN now = 1000 ALLOCATE(resp_env%fitpoints(3,now),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ELSE now = SIZE(resp_env%fitpoints,2) END IF @@ -794,7 +764,7 @@ SUBROUTINE calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set,particles,& IF(ANY(not_in_range(:,1)).OR.ALL(not_in_range(:,2))) CYCLE resp_env%npoints = resp_env%npoints + 1 IF (BTEST(cp_print_key_should_output(logger%iter_info,resp_section,& - "PRINT%V_RESP_CUBE",error=error),cp_p_file)) THEN + "PRINT%V_RESP_CUBE"),cp_p_file)) THEN IF(resp_env%npoints > now) THEN now = 2*now CALL reallocate(resp_env%fitpoints,1,3,1,now) @@ -831,9 +801,9 @@ SUBROUTINE calc_resp_matrix_nonper(qs_env,resp_env,atomic_kind_set,particles,& rhs=rhs/resp_env%npoints DEALLOCATE(dist,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) DEALLOCATE(not_in_range,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) CALL timestop(handle) @@ -847,11 +817,9 @@ END SUBROUTINE calc_resp_matrix_nonper !> \param particles ... !> \param cell parameters related to the simulation cell !> \param natom number of atoms -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE calc_resp_matrix_periodic(qs_env,resp_env,rep_sys,particles,cell,& - natom,error) + natom) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env @@ -859,7 +827,6 @@ SUBROUTINE calc_resp_matrix_periodic(qs_env,resp_env,rep_sys,particles,cell,& TYPE(particle_list_type), POINTER :: particles TYPE(cell_type), POINTER :: cell INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_resp_matrix_periodic', & routineP = moduleN//':'//routineN @@ -887,44 +854,40 @@ SUBROUTINE calc_resp_matrix_periodic(qs_env,resp_env,rep_sys,particles,cell,& " can only be obtained with a cell that has XYZ periodicity") ENDIF - CALL get_qs_env(qs_env, pw_env=pw_env,para_env=para_env,& - error=error) + CALL get_qs_env(qs_env, pw_env=pw_env,para_env=para_env) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env, error=error) + poisson_env=poisson_env) CALL pw_pool_create_pw(auxbas_pw_pool,& rho_ga%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& va_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& va_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) !get fitting points and store them in resp_env%fitpoints CALL get_fitting_points(qs_env,resp_env,rep_sys,particles=particles,& - cell=cell,error=error) + cell=cell) ALLOCATE(vpot(resp_env%npoints,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) normalize_factor=SQRT((resp_env%eta/pi)**3) DO i=1,natom !collocate gaussian for each atom - CALL pw_zero(rho_ga%pw, error=error) - CALL calculate_rho_resp_single(rho_ga,qs_env,resp_env%eta,i,error) + CALL pw_zero(rho_ga%pw) + CALL calculate_rho_resp_single(rho_ga,qs_env,resp_env%eta,i) !calculate potential va and store the part needed for fitting in vpot - CALL pw_zero(va_gspace%pw, error=error) - CALL pw_poisson_solve(poisson_env,rho_ga%pw,vhartree=va_gspace%pw,error=error) - CALL pw_zero(va_rspace%pw, error=error) - CALL pw_transfer(va_gspace%pw,va_rspace%pw,error=error) - CALL pw_scale(va_rspace%pw,normalize_factor,error=error) + CALL pw_zero(va_gspace%pw) + CALL pw_poisson_solve(poisson_env,rho_ga%pw,vhartree=va_gspace%pw) + CALL pw_zero(va_rspace%pw) + CALL pw_transfer(va_gspace%pw,va_rspace%pw) + CALL pw_scale(va_rspace%pw,normalize_factor) DO ip=1,resp_env%npoints jx = resp_env%fitpoints(1,ip) jy = resp_env%fitpoints(2,ip) @@ -933,9 +896,9 @@ SUBROUTINE calc_resp_matrix_periodic(qs_env,resp_env,rep_sys,particles,cell,& END DO ENDDO - CALL pw_release(va_gspace%pw,error=error) - CALL pw_release(va_rspace%pw,error=error) - CALL pw_release(rho_ga%pw,error=error) + CALL pw_release(va_gspace%pw) + CALL pw_release(va_rspace%pw) + CALL pw_release(rho_ga%pw) DO i=1,natom DO j=1,natom @@ -943,11 +906,11 @@ SUBROUTINE calc_resp_matrix_periodic(qs_env,resp_env,rep_sys,particles,cell,& resp_env%matrix(i,j)=resp_env%matrix(i,j) + 2.0_dp*SUM(vpot(:,i)*vpot(:,j)) ENDDO ! calculate vector resp_env%rhs - CALL calculate_rhs(qs_env,resp_env,resp_env%rhs(i),vpot(:,i),error=error) + CALL calculate_rhs(qs_env,resp_env,resp_env%rhs(i),vpot(:,i)) ENDDO DEALLOCATE(vpot,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) resp_env%npoints_proc=resp_env%npoints CALL mp_sum(resp_env%npoints,para_env%group) @@ -968,17 +931,14 @@ END SUBROUTINE calc_resp_matrix_periodic !> \param rep_sys structure for repeating input sections defining fit points !> \param particles ... !> \param cell parameters related to the simulation cell -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE get_fitting_points(qs_env,resp_env,rep_sys,particles,cell,error) + SUBROUTINE get_fitting_points(qs_env,resp_env,rep_sys,particles,cell) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env TYPE(resp_p_type), DIMENSION(:), POINTER :: rep_sys TYPE(particle_list_type), POINTER :: particles TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_fitting_points', & routineP = moduleN//':'//routineN @@ -1012,19 +972,16 @@ SUBROUTINE get_fitting_points(qs_env,resp_env,rep_sys,particles,cell,error) particle_set=particle_set,& atomic_kind_set=atomic_kind_set,& para_env=para_env,& - v_hartree_rspace=v_hartree_pw,& - error=error) + v_hartree_rspace=v_hartree_pw) - resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP",& - error=error) - logger => cp_error_get_logger(error) + resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP") + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,resp_section,& "PRINT%COORD_FIT_POINTS",& extension=".xyz",& file_status="REPLACE",& file_action="WRITE",& - file_form="FORMATTED",& - error=error) + file_form="FORMATTED") bo=v_hartree_pw%pw_grid%bounds_local gbo=v_hartree_pw%pw_grid%bounds @@ -1035,15 +992,15 @@ SUBROUTINE get_fitting_points(qs_env,resp_env,rep_sys,particles,cell,error) IF(.NOT.ASSOCIATED(resp_env%fitpoints)) THEN now = 1000 ALLOCATE(resp_env%fitpoints(3,now),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ELSE now = SIZE(resp_env%fitpoints,2) END IF ALLOCATE(dist(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(not_in_range(natom,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) !every proc gets another bo, grid is distributed DO jz=bo(1,3),bo(2,3) @@ -1128,17 +1085,17 @@ SUBROUTINE get_fitting_points(qs_env,resp_env,rep_sys,particles,cell,error) !print fitting points to file if requested IF (BTEST(cp_print_key_should_output(logger%iter_info,& - resp_section,"PRINT%COORD_FIT_POINTS",error=error),& + resp_section,"PRINT%COORD_FIT_POINTS"),& cp_p_file))THEN - CALL print_fitting_points(qs_env,resp_env,dh,output_unit,gbo,error) + CALL print_fitting_points(qs_env,resp_env,dh,output_unit,gbo) ENDIF CALL cp_print_key_finished_output(output_unit,logger,resp_section,& - "PRINT%COORD_FIT_POINTS", error=error) + "PRINT%COORD_FIT_POINTS") DEALLOCATE(dist,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) DEALLOCATE(not_in_range,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) CALL timestop(handle) @@ -1150,16 +1107,13 @@ END SUBROUTINE get_fitting_points !> \param resp_env the resp environment !> \param rhs vector !> \param vpot single gaussian potential -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE calculate_rhs(qs_env,resp_env,rhs,vpot,error) + SUBROUTINE calculate_rhs(qs_env,resp_env,rhs,vpot) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env REAL(KIND=dp), INTENT(INOUT) :: rhs REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vpot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rhs', & routineP = moduleN//':'//routineN @@ -1174,7 +1128,7 @@ SUBROUTINE calculate_rhs(qs_env,resp_env,rhs,vpot,error) failure=.FALSE. NULLIFY(v_hartree_pw) - CALL get_qs_env(qs_env, v_hartree_rspace=v_hartree_pw, error=error) + CALL get_qs_env(qs_env, v_hartree_rspace=v_hartree_pw) dvol=v_hartree_pw%pw_grid%dvol !multiply v_hartree and va_rspace and calculate the vector rhs !taking into account that v_hartree has opposite site; remove v_qmmm @@ -1202,16 +1156,13 @@ END SUBROUTINE calculate_rhs !> \param dh incremental cell matrix !> \param output_unit ... !> \param gbo lower and upper bounds for the grid points -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_fitting_points(qs_env,resp_env,dh,output_unit,gbo,error) + SUBROUTINE print_fitting_points(qs_env,resp_env,dh,output_unit,gbo) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env REAL(KIND=dp), INTENT(IN) :: dh(3,3) INTEGER, INTENT(IN) :: output_unit, gbo(2,3) - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_fitting_points', & routineP = moduleN//':'//routineN @@ -1238,20 +1189,18 @@ SUBROUTINE print_fitting_points(qs_env,resp_env,dh,output_unit,gbo,error) tmp_points,tmp_npoints) CALL get_qs_env(qs_env, input=input, para_env=para_env,& - particle_set=particle_set,error=error) + particle_set=particle_set) - resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP",& - error=error) + resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP") print_key => section_vals_get_subs_vals(resp_section,& - "PRINT%COORD_FIT_POINTS",& - error=error) - logger => cp_error_get_logger(error) - conv=cp_unit_from_cp2k(1.0_dp,"angstrom",error=error) + "PRINT%COORD_FIT_POINTS") + logger => cp_get_default_logger() + conv=cp_unit_from_cp2k(1.0_dp,"angstrom") IF(output_unit>0) THEN filename=cp_print_key_generate_filename(logger,& print_key, extension=".xyz",& - my_local=.FALSE.,error=error) + my_local=.FALSE.) WRITE(unit=output_unit,FMT="(I12,A,/)") SIZE(particle_set),' + nr fit points' DO iatom=1,SIZE(particle_set) CALL get_atomic_kind(atomic_kind=particle_set(iatom)%atomic_kind,& @@ -1276,9 +1225,9 @@ SUBROUTINE print_fitting_points(qs_env,resp_env,dh,output_unit,gbo,error) ENDIF ALLOCATE(tmp_size(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) ALLOCATE(tmp_npoints(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) !sending data of all other prosc to proc which makes the output (proc 0) IF(output_unit>0) THEN @@ -1289,7 +1238,7 @@ SUBROUTINE print_fitting_points(qs_env,resp_env,dh,output_unit,gbo,error) request=req(1)) CALL mp_wait(req(1)) ALLOCATE(tmp_points(3,tmp_size(1)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,Failure) + CPPostcondition(stat==0,cp_failure_level,routineP,Failure) CALL mp_irecv(msgout=tmp_points,source=i-1,comm=para_env%group,& request=req(3)) CALL mp_wait(req(3)) @@ -1310,7 +1259,7 @@ SUBROUTINE print_fitting_points(qs_env,resp_env,dh,output_unit,gbo,error) WRITE(UNIT=output_unit,FMT="(A,2X,3F10.5)") "X", r(1), r(2),r(3) ENDDO DEALLOCATE(tmp_points,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDDO ELSE tmp_size(1)=SIZE(resp_env%fitpoints,2) @@ -1328,9 +1277,9 @@ SUBROUTINE print_fitting_points(qs_env,resp_env,dh,output_unit,gbo,error) ENDIF DEALLOCATE(tmp_size,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) DEALLOCATE(tmp_npoints,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) CALL timestop(handle) @@ -1345,11 +1294,9 @@ END SUBROUTINE print_fitting_points !> \param natom number of atoms !> \param cons_section input section for constraints !> \param particle_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE add_restraints_and_constraints(qs_env,resp_env,rest_section,& - subsys,natom,cons_section,particle_set,error) + subsys,natom,cons_section,particle_set) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env @@ -1359,7 +1306,6 @@ SUBROUTINE add_restraints_and_constraints(qs_env,resp_env,rest_section,& TYPE(section_vals_type), POINTER :: cons_section TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'add_restraints_and_constraints', & @@ -1379,19 +1325,17 @@ SUBROUTINE add_restraints_and_constraints(qs_env,resp_env,rest_section,& NULLIFY(atom_coef,atom_list_res,atom_list_cons,dft_control) failure=.FALSE. - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) ! add the restraints DO i=1,resp_env%nrest_sec - CALL section_vals_val_get(rest_section,"TARGET",i_rep_section=i,r_val=TARGET,error=error) - CALL section_vals_val_get(rest_section,"STRENGTH",i_rep_section=i,r_val=strength,error=error) - CALL build_atom_list(rest_section,subsys,atom_list_res,i,error) - CALL section_vals_val_get(rest_section,"ATOM_COEF",i_rep_section=i,explicit=explicit_coeff,& - error=error) + CALL section_vals_val_get(rest_section,"TARGET",i_rep_section=i,r_val=TARGET) + CALL section_vals_val_get(rest_section,"STRENGTH",i_rep_section=i,r_val=strength) + CALL build_atom_list(rest_section,subsys,atom_list_res,i) + CALL section_vals_val_get(rest_section,"ATOM_COEF",i_rep_section=i,explicit=explicit_coeff) IF (explicit_coeff) THEN - CALL section_vals_val_get(rest_section,"ATOM_COEF",i_rep_section=i,r_vals=atom_coef,& - error=error) - CPPrecondition(SIZE(atom_list_res)==SIZE(atom_coef),cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(rest_section,"ATOM_COEF",i_rep_section=i,r_vals=atom_coef) + CPPrecondition(SIZE(atom_list_res)==SIZE(atom_coef),cp_failure_level,routineP,failure) ENDIF DO m=1,SIZE(atom_list_res) IF (explicit_coeff) THEN @@ -1411,7 +1355,7 @@ SUBROUTINE add_restraints_and_constraints(qs_env,resp_env,rest_section,& ENDIF ENDDO DEALLOCATE(atom_list_res,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDDO ! if heavies are restrained to zero, add these as well @@ -1435,12 +1379,12 @@ SUBROUTINE add_restraints_and_constraints(qs_env,resp_env,rest_section,& ENDIF DO i=1,resp_env%ncons_sec - CALL build_atom_list(cons_section,subsys,atom_list_cons,i,error) + CALL build_atom_list(cons_section,subsys,atom_list_cons,i) IF(.NOT.resp_env%equal_charges) THEN ncons_v=ncons_v+1 - CALL section_vals_val_get(cons_section,"ATOM_COEF",i_rep_section=i,r_vals=atom_coef,error=error) - CALL section_vals_val_get(cons_section,"TARGET",i_rep_section=i,r_val=TARGET,error=error) - CPPrecondition(SIZE(atom_list_cons)==SIZE(atom_coef),cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(cons_section,"ATOM_COEF",i_rep_section=i,r_vals=atom_coef) + CALL section_vals_val_get(cons_section,"TARGET",i_rep_section=i,r_val=TARGET) + CPPrecondition(SIZE(atom_list_cons)==SIZE(atom_coef),cp_failure_level,routineP,failure) DO m=1,SIZE(atom_list_cons) resp_env%matrix(atom_list_cons(m),ncons_v)=atom_coef(m) resp_env%matrix(ncons_v,atom_list_cons(m))=atom_coef(m) @@ -1459,7 +1403,7 @@ SUBROUTINE add_restraints_and_constraints(qs_env,resp_env,rest_section,& ENDDO ENDIF DEALLOCATE(atom_list_cons,stat=stat) - CPPostconditionNoFail(stat==0,cp_failure_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_failure_level,routineP) ENDDO CALL timestop(handle) @@ -1471,16 +1415,13 @@ END SUBROUTINE add_restraints_and_constraints !> \param resp_env the resp environment !> \param rep_sys structure for repeating input sections defining fit points !> \param my_per ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_resp_parameter_info(qs_env,resp_env,rep_sys,my_per,error) + SUBROUTINE print_resp_parameter_info(qs_env,resp_env,rep_sys,my_per) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env TYPE(resp_p_type), DIMENSION(:), POINTER :: rep_sys INTEGER, INTENT(IN) :: my_per - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_resp_parameter_info', & routineP = moduleN//':'//routineN @@ -1493,16 +1434,15 @@ SUBROUTINE print_resp_parameter_info(qs_env,resp_env,rep_sys,my_per,error) CALL timeset(routineN,handle) NULLIFY(logger,input,resp_section) - CALL get_qs_env(qs_env, input=input, error=error) - resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP",& - error=error) - logger => cp_error_get_logger(error) + CALL get_qs_env(qs_env, input=input) + resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP") + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,resp_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".resp",error=error) + extension=".resp") - conv=cp_unit_from_cp2k(1.0_dp,"angstrom",error=error) + conv=cp_unit_from_cp2k(1.0_dp,"angstrom") IF(.NOT.my_per==use_perd_none) THEN - eta_conv=cp_unit_from_cp2k(resp_env%eta,"angstrom",power=-2,error=error) + eta_conv=cp_unit_from_cp2k(resp_env%eta,"angstrom",power=-2) ENDIF IF (output_unit>0) THEN @@ -1556,7 +1496,7 @@ SUBROUTINE print_resp_parameter_info(qs_env,resp_env,rep_sys,my_per,error) CALL m_flush(output_unit) ENDIF CALL cp_print_key_finished_output(output_unit,logger,resp_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -1568,15 +1508,12 @@ END SUBROUTINE print_resp_parameter_info !> \param resp_env the resp environment !> \param output_runinfo ... !> \param natom number of atoms -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_resp_charges(qs_env,resp_env,output_runinfo,natom,error) + SUBROUTINE print_resp_charges(qs_env,resp_env,output_runinfo,natom) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env INTEGER, INTENT(IN) :: output_runinfo, natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_resp_charges', & routineP = moduleN//':'//routineN @@ -1597,39 +1534,36 @@ SUBROUTINE print_resp_charges(qs_env,resp_env,output_runinfo,natom,error) NULLIFY(particle_set,qs_kind_set,input,logger,resp_section,print_key) CALL get_qs_env(qs_env,input=input,particle_set=particle_set,& - qs_kind_set=qs_kind_set, error=error) + qs_kind_set=qs_kind_set) - resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP",& - error=error) + resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP") print_key => section_vals_get_subs_vals(resp_section,& - "PRINT%RESP_CHARGES_TO_FILE",& - error=error) - logger => cp_error_get_logger(error) + "PRINT%RESP_CHARGES_TO_FILE") + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info,& - resp_section,"PRINT%RESP_CHARGES_TO_FILE",error=error),& + resp_section,"PRINT%RESP_CHARGES_TO_FILE"),& cp_p_file)) THEN output_file=cp_print_key_unit_nr(logger,resp_section,& "PRINT%RESP_CHARGES_TO_FILE",& extension=".resp",& file_status="REPLACE",& file_action="WRITE",& - file_form="FORMATTED",& - error=error) + file_form="FORMATTED") IF(output_file>0) THEN filename = cp_print_key_generate_filename(logger,& print_key, extension=".resp", & - my_local=.FALSE.,error=error) + my_local=.FALSE.) CALL print_atomic_charges(particle_set,qs_kind_set,output_file,title="RESP charges:",& - atomic_charges=resp_env%rhs(1:natom),error=error) + atomic_charges=resp_env%rhs(1:natom)) IF(output_runinfo>0) WRITE(output_runinfo,'(2X,A,/)') "PRINTED RESP CHARGES TO FILE" ENDIF CALL cp_print_key_finished_output(output_file,logger,resp_section,& - "PRINT%RESP_CHARGES_TO_FILE", error=error) + "PRINT%RESP_CHARGES_TO_FILE") ELSE CALL print_atomic_charges(particle_set,qs_kind_set,output_runinfo,title="RESP charges:",& - atomic_charges=resp_env%rhs(1:natom),error=error) + atomic_charges=resp_env%rhs(1:natom)) ENDIF CALL timestop(handle) @@ -1643,16 +1577,13 @@ END SUBROUTINE print_resp_charges !> \param particles ... !> \param natom number of atoms !> \param output_runinfo ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE print_pot_from_resp_charges(qs_env,resp_env,particles,natom,output_runinfo,error) + SUBROUTINE print_pot_from_resp_charges(qs_env,resp_env,particles,natom,output_runinfo) TYPE(qs_environment_type), POINTER :: qs_env TYPE(resp_type), POINTER :: resp_env TYPE(particle_list_type), POINTER :: particles INTEGER, INTENT(IN) :: natom, output_runinfo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_pot_from_resp_charges', & routineP = moduleN//':'//routineN @@ -1683,54 +1614,47 @@ SUBROUTINE print_pot_from_resp_charges(qs_env,resp_env,particles,natom,output_ru input=input,& para_env=para_env,& pw_env=pw_env,& - v_hartree_rspace=v_hartree_rspace,& - error=error) - resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP",& - error=error) + v_hartree_rspace=v_hartree_rspace) + resp_section => section_vals_get_subs_vals(input,"PROPERTIES%RESP") print_key => section_vals_get_subs_vals(resp_section,& - "PRINT%V_RESP_CUBE",error=error) - logger => cp_error_get_logger(error) + "PRINT%V_RESP_CUBE") + logger => cp_get_default_logger() IF (BTEST(cp_print_key_should_output(logger%iter_info,resp_section,& - "PRINT%V_RESP_CUBE",error=error),cp_p_file)) THEN + "PRINT%V_RESP_CUBE"),cp_p_file)) THEN ! calculate potential generated from RESP charges CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,& - poisson_env=poisson_env,error=error) + poisson_env=poisson_env) CALL pw_pool_create_pw(auxbas_pw_pool,& rho_resp%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& v_resp_gspace%pw, & use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,& v_resp_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) - CALL pw_zero(rho_resp%pw,error=error) + CALL pw_zero(rho_resp%pw) CALL calculate_rho_resp_all(rho_resp,resp_env%rhs,natom,& - resp_env%eta,qs_env,error) - CALL pw_zero(v_resp_gspace%pw, error=error) + resp_env%eta,qs_env) + CALL pw_zero(v_resp_gspace%pw) CALL pw_poisson_solve(poisson_env,rho_resp%pw,& - vhartree=v_resp_gspace%pw,error=error) - CALL pw_zero(v_resp_rspace%pw, error=error) - CALL pw_transfer(v_resp_gspace%pw,v_resp_rspace%pw,error=error) - CALL pw_scale(v_resp_rspace%pw,v_resp_rspace%pw%pw_grid%dvol,& - error=error) - CALL pw_scale(v_resp_rspace%pw,-normalize_factor,& - error=error) - CALL pw_release(v_resp_gspace%pw,error=error) - CALL pw_release(rho_resp%pw,error=error) + vhartree=v_resp_gspace%pw) + CALL pw_zero(v_resp_rspace%pw) + CALL pw_transfer(v_resp_gspace%pw,v_resp_rspace%pw) + CALL pw_scale(v_resp_rspace%pw,v_resp_rspace%pw%pw_grid%dvol) + CALL pw_scale(v_resp_rspace%pw,-normalize_factor) + CALL pw_release(v_resp_gspace%pw) + CALL pw_release(rho_resp%pw) !now print the v_resp_rspace%pw to a cube file CALL pw_pool_create_pw(auxbas_pw_pool,aux_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - append_cube=section_get_lval(resp_section,"PRINT%V_RESP_CUBE%APPEND",error=error) + in_space = REALSPACE) + append_cube=section_get_lval(resp_section,"PRINT%V_RESP_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" @@ -1738,17 +1662,16 @@ SUBROUTINE print_pot_from_resp_charges(qs_env,resp_env,particles,natom,output_ru unit_nr=cp_print_key_unit_nr(logger,resp_section,& "PRINT%V_RESP_CUBE",& extension=".cube",& - file_position=my_pos_cube,error=error) + file_position=my_pos_cube) udvol = 1.0_dp/v_resp_rspace%pw%pw_grid%dvol - CALL pw_copy(v_resp_rspace%pw,aux_r%pw, error=error) - CALL pw_scale(aux_r%pw,udvol,error=error) + CALL pw_copy(v_resp_rspace%pw,aux_r%pw) + CALL pw_scale(aux_r%pw,udvol) CALL cp_pw_to_cube(aux_r%pw,unit_nr,"RESP POTENTIAL",particles=particles,& stride=section_get_ivals(resp_section,& - "PRINT%V_RESP_CUBE%STRIDE",error=error),& - error=error) + "PRINT%V_RESP_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,resp_section,& - "PRINT%V_RESP_CUBE",error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw, error=error) + "PRINT%V_RESP_CUBE") + CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw) !RMS and RRMS sum_diff=0.0_dp @@ -1773,7 +1696,7 @@ SUBROUTINE print_pot_from_resp_charges(qs_env,resp_env,particles,natom,output_ru WRITE(output_runinfo,'(2X,A,T69,ES12.5,/)') "Relative root-mean-square "//& "(RRMS) error of RESP fit:",rrms ENDIF - CALL pw_release(v_resp_rspace%pw,error=error) + CALL pw_release(v_resp_rspace%pw) ENDIF CALL timestop(handle) diff --git a/src/qs_rho0_ggrid.F b/src/qs_rho0_ggrid.F index 65b57f325e..3a12847b4b 100644 --- a/src/qs_rho0_ggrid.F +++ b/src/qs_rho0_ggrid.F @@ -91,14 +91,12 @@ MODULE qs_rho0_ggrid !> \param qs_env ... !> \param rho0 ... !> \param tot_rs_int ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int, error) + SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int) TYPE(qs_environment_type), POINTER :: qs_env TYPE(rho0_mpole_type), POINTER :: rho0 REAL(dp), INTENT(OUT) :: tot_rs_int - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'put_rho0_on_grid', & routineP = moduleN//':'//routineN @@ -147,11 +145,11 @@ SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int, error) atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& para_env=para_env,& - pw_env=pw_env,cell=cell,error=error) + pw_env=pw_env,cell=cell) eps_rho_rspace = dft_control%qs_control%eps_rho_rspace NULLIFY(descs,pw_pools) - CALL pw_env_get(pw_env=pw_env,rs_descs=descs,rs_grids=grids,pw_pools=pw_pools,error=error) + CALL pw_env_get(pw_env=pw_env,rs_descs=descs,rs_grids=grids,pw_pools=pw_pools) cube_info => pw_env%cube_info auxbas_grid=pw_env%auxbas_grid @@ -167,8 +165,8 @@ SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int, error) rs_grid => grids(igrid)%rs_grid pw_pool => pw_pools(igrid)%pool - CPPrecondition(ASSOCIATED(desc),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(desc),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) IF (igrid /= auxbas_grid) THEN ALLOCATE (coeff_rspace,STAT=istat) @@ -179,12 +177,12 @@ SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int, error) "coeff_gspace",0) CALL pw_pool_create_pw(pw_pool,coeff_rspace%pw,use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) CALL pw_pool_create_pw(pw_pool,coeff_gspace%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) END IF - CALL rs_grid_retain(rs_grid,error=error) + CALL rs_grid_retain(rs_grid) CALL rs_grid_zero(rs_grid) nch_max = ncoset(lmax0) @@ -195,7 +193,7 @@ SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int, error) DO ikind = 1,SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=atom_list,natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom,error=error) + CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom) IF(.NOT. paw_atom .AND. dft_control%qs_control%gapw_control%nopaw_as_gpw) CYCLE @@ -242,7 +240,7 @@ SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int, error) ra, (/0.0_dp,0.0_dp,0.0_dp/), 0.0_dp, 1.0_dp, pab,0,0,& rs_grid,cell, cube_info(igrid),eps_rho_rspace,ga_gb_function=401,& ithread=ithread,collocate_rho0=.TRUE.,rpgf0_s=rpgf0,& - use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + use_subpatch=.TRUE.,subpatch_pattern=0_int_8) END DO ! j @@ -250,42 +248,42 @@ SUBROUTINE put_rho0_on_grid(qs_env, rho0, tot_rs_int, error) IF (ASSOCIATED(cores)) THEN DEALLOCATE (cores,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(pab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(igrid /= auxbas_grid) THEN - CALL rs_pw_transfer(rs_grid,coeff_rspace%pw,rs2pw,error=error) - CALL rs_grid_release(rs_grid, error=error) - CALL pw_zero(rho0_s_gs%pw,error=error) - CALL pw_transfer(coeff_rspace%pw,coeff_gspace%pw,error=error) - CALL pw_axpy(coeff_gspace%pw,rho0_s_gs%pw,error=error) + CALL rs_pw_transfer(rs_grid,coeff_rspace%pw,rs2pw) + CALL rs_grid_release(rs_grid) + CALL pw_zero(rho0_s_gs%pw) + CALL pw_transfer(coeff_rspace%pw,coeff_gspace%pw) + CALL pw_axpy(coeff_gspace%pw,rho0_s_gs%pw) - tot_rs_int = pw_integrate_function(coeff_rspace%pw,isign=-1,error=error) + tot_rs_int = pw_integrate_function(coeff_rspace%pw,isign=-1) - CALL pw_pool_give_back_pw(pw_pool,coeff_rspace%pw,error=error) - CALL pw_pool_give_back_pw(pw_pool,coeff_gspace%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,coeff_rspace%pw) + CALL pw_pool_give_back_pw(pw_pool,coeff_gspace%pw) DEALLOCATE(coeff_rspace,coeff_gspace,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE CALL pw_pool_create_pw(pw_pool, rho0_r_tmp%pw, & - use_data=REALDATA3D,in_space=REALSPACE, error=error) + use_data=REALDATA3D,in_space=REALSPACE) - CALL rs_pw_transfer(rs_grid,rho0_r_tmp%pw,rs2pw,error=error) - CALL rs_grid_release(rs_grid, error=error) + CALL rs_pw_transfer(rs_grid,rho0_r_tmp%pw,rs2pw) + CALL rs_grid_release(rs_grid) - tot_rs_int = pw_integrate_function(rho0_r_tmp%pw,isign=-1,error=error) + tot_rs_int = pw_integrate_function(rho0_r_tmp%pw,isign=-1) - CALL pw_transfer(rho0_r_tmp%pw,rho0_s_rs%pw,error=error) - CALL pw_pool_give_back_pw(pw_pool, rho0_r_tmp%pw, error=error) + CALL pw_transfer(rho0_r_tmp%pw,rho0_s_rs%pw) + CALL pw_pool_give_back_pw(pw_pool, rho0_r_tmp%pw) - CALL pw_zero(rho0_s_gs%pw,error=error) - CALL pw_transfer(rho0_s_rs%pw,rho0_s_gs%pw,error=error) + CALL pw_zero(rho0_s_gs%pw) + CALL pw_transfer(rho0_s_rs%pw,rho0_s_gs%pw) END IF CALL timestop(handle) @@ -296,14 +294,12 @@ END SUBROUTINE put_rho0_on_grid !> \param qs_env ... !> \param rho0_mpole ... !> \param tddft ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rho0_s_grid_create(qs_env, rho0_mpole, tddft, error) + SUBROUTINE rho0_s_grid_create(qs_env, rho0_mpole, tddft) TYPE(qs_environment_type), POINTER :: qs_env TYPE(rho0_mpole_type), POINTER :: rho0_mpole LOGICAL, INTENT(IN), OPTIONAL :: tddft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rho0_s_grid_create', & routineP = moduleN//':'//routineN @@ -319,41 +315,41 @@ SUBROUTINE rho0_s_grid_create(qs_env, rho0_mpole, tddft, error) IF(PRESENT(tddft)) my_tddft = tddft NULLIFY(new_pw_env) - CALL get_qs_env(qs_env, pw_env=new_pw_env,error=error) - CPPrecondition(ASSOCIATED(new_pw_env),cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env, pw_env=new_pw_env) + CPPrecondition(ASSOCIATED(new_pw_env),cp_failure_level,routineP,failure) NULLIFY(auxbas_pw_pool) - CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) - CPPrecondition(ASSOCIATED(auxbas_pw_pool),cp_failure_level,routineP,error,failure) + CALL pw_env_get(new_pw_env, auxbas_pw_pool=auxbas_pw_pool) + CPPrecondition(ASSOCIATED(auxbas_pw_pool),cp_failure_level,routineP,failure) ! reallocate rho0 on the global grid in real and reciprocal space NULLIFY(rho_rs,rho_gs) - CPPrecondition(ASSOCIATED(rho0_mpole),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho0_mpole),cp_failure_level,routineP,failure) rho_rs => rho0_mpole%rho0_s_rs rho_gs => rho0_mpole%rho0_s_gs ! rho0 density in real space IF (ASSOCIATED(rho_rs)) THEN - CALL pw_release(rho_rs%pw,error=error) + CALL pw_release(rho_rs%pw) DEALLOCATE(rho_rs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ALLOCATE(rho_rs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(auxbas_pw_pool, rho_rs%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) rho0_mpole%rho0_s_rs => rho_rs ! rho0 density in reciprocal space IF (ASSOCIATED(rho_gs)) THEN - CALL pw_release(rho_gs%pw,error=error) + CALL pw_release(rho_gs%pw) DEALLOCATE(rho_gs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ALLOCATE(rho_gs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(auxbas_pw_pool, rho_gs%pw, & - use_data=COMPLEXDATA1D, error=error) + use_data=COMPLEXDATA1D) rho_gs%pw%in_space=RECIPROCALSPACE rho0_mpole%rho0_s_gs => rho_gs @@ -371,17 +367,15 @@ END SUBROUTINE rho0_s_grid_create !> \param tddft ... !> \param do_triplet ... !> \param p_env ... -!> \param error ... ! ***************************************************************************** SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & - tddft, do_triplet, p_env, error) + tddft, do_triplet, p_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type) :: v_rspace LOGICAL, INTENT(IN) :: calculate_forces LOGICAL, INTENT(IN), OPTIONAL :: tddft, do_triplet TYPE(qs_p_env_type), OPTIONAL, POINTER :: p_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'integrate_vhg0_rspace', & routineP = moduleN//':'//routineN @@ -458,7 +452,7 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & rho0_mpole=rho0_mpole,& rho_atom_set=rho_atom_set,& particle_set=particle_set,& - virial=virial,error=error) + virial=virial) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -484,8 +478,8 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & ! *** set up of the potential on the multigrids NULLIFY(rs_descs, pw_pools) - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CALL pw_env_get(pw_env, rs_descs=rs_descs, pw_pools=pw_pools, error=error) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CALL pw_env_get(pw_env, rs_descs=rs_descs, pw_pools=pw_pools) ! *** assign from pw_env auxbas_grid=pw_env%auxbas_grid @@ -497,59 +491,59 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & pw_pool => pw_pools(igrid)%pool ALLOCATE(coeff_gspace, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(coeff_rspace, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(pw_pool,coeff_gspace%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(pw_pool,coeff_rspace%pw,use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) IF (igrid /= auxbas_grid) THEN pw_aux => pw_pools(auxbas_grid)%pool ALLOCATE(coeff_gaux,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(pw_aux, coeff_gaux%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) - CALL pw_transfer(v_rspace%pw,coeff_gaux%pw,error=error) - CALL pw_copy(coeff_gaux%pw,coeff_gspace%pw,error=error) - CALL pw_transfer(coeff_gspace%pw,coeff_rspace%pw,error=error) - CALL pw_pool_give_back_pw(pw_aux,coeff_gaux%pw,error=error) + in_space = RECIPROCALSPACE) + CALL pw_transfer(v_rspace%pw,coeff_gaux%pw) + CALL pw_copy(coeff_gaux%pw,coeff_gspace%pw) + CALL pw_transfer(coeff_gspace%pw,coeff_rspace%pw) + CALL pw_pool_give_back_pw(pw_aux,coeff_gaux%pw) DEALLOCATE(coeff_gaux, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(coeff_raux,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL pw_pool_create_pw(pw_aux, coeff_raux%pw,use_data=REALDATA3D,& - in_space=REALSPACE,error=error) + in_space=REALSPACE) scale = coeff_rspace%pw%pw_grid%dvol/coeff_raux%pw%pw_grid%dvol coeff_rspace%pw%cr3d = scale*coeff_rspace%pw%cr3d - CALL pw_pool_give_back_pw(pw_aux,coeff_raux%pw,error=error) + CALL pw_pool_give_back_pw(pw_aux,coeff_raux%pw) DEALLOCATE(coeff_raux, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE IF(coeff_gspace%pw%pw_grid%spherical) THEN - CALL pw_transfer(v_rspace%pw,coeff_gspace%pw,error=error) - CALL pw_transfer(coeff_gspace%pw,coeff_rspace%pw,error=error) + CALL pw_transfer(v_rspace%pw,coeff_gspace%pw) + CALL pw_transfer(coeff_gspace%pw,coeff_rspace%pw) ELSE - CALL pw_copy(v_rspace%pw,coeff_rspace%pw,error=error) + CALL pw_copy(v_rspace%pw,coeff_rspace%pw) END IF END IF - CALL pw_pool_give_back_pw(pw_pool,coeff_gspace%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,coeff_gspace%pw) DEALLOCATE(coeff_gspace, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! *** set up the rs grid at level igrid - CALL rs_grid_create(rs_v, rs_desc, error=error) + CALL rs_grid_create(rs_v, rs_desc) CALL rs_grid_zero(rs_v) - CALL rs_pw_transfer(rs_v,coeff_rspace%pw,pw2rs,error=error) + CALL rs_pw_transfer(rs_v,coeff_rspace%pw,pw2rs) - CALL pw_pool_give_back_pw(pw_pool,coeff_rspace%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,coeff_rspace%pw) DEALLOCATE(coeff_rspace, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! *** Now the potential is on the right grid => integration @@ -578,7 +572,7 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & CALL get_qs_kind(qs_kind_set(ikind),& basis_set=orb_basis_set,& paw_atom=paw_atom,& - harmonics=harmonics,error=error) + harmonics=harmonics) IF(.NOT. paw_atom) CYCLE @@ -594,7 +588,7 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & nsotot = maxso*nset ALLOCATE(intloc(nsotot,nsotot),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Initialize the local KS integrals @@ -604,7 +598,7 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & llmax = harmonics%llmax ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) num_pe = para_env%num_pe mepos = para_env%mepos @@ -637,7 +631,7 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & hdab=hdab,hadb=hadb,& collocate_rho0=.TRUE.,rpgf0_s=rpgf0,& use_virial=use_virial, my_virial_a=my_virial_a, my_virial_b=my_virial_b,& - a_hdab=a_hdab,use_subpatch=.TRUE.,subpatch_pattern=0_int_8,error=error) + a_hdab=a_hdab,use_subpatch=.TRUE.,subpatch_pattern=0_int_8) ! Convert from cartesian to spherical DO lshell = 0,l0_ikind @@ -688,7 +682,7 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & m2 = 0 DO iset2 = 1,nset CALL get_none0_cg_list(harmonics%my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local,error) + max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local) n1 = nsoset(lmax(iset1)) DO ipgf1 = 1,npgf(iset1) n2 = nsoset(lmax(iset2)) @@ -752,16 +746,16 @@ SUBROUTINE integrate_vhg0_rspace(qs_env, v_rspace, calculate_forces, & END DO DEALLOCATE(intloc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cg_list,cg_n_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO ! ikind - CALL rs_grid_release(rs_v, error=error) + CALL rs_grid_release(rs_v) DEALLOCATE (hab,hdab,hadb,hab_sph,hdab_sph,pab,a_hdab,a_hdab_sph,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/qs_rho0_methods.F b/src/qs_rho0_methods.F index b1ca599d28..8afc54de8b 100644 --- a/src/qs_rho0_methods.F +++ b/src/qs_rho0_methods.F @@ -81,15 +81,13 @@ MODULE qs_rho0_methods !> \param harmonics ... !> \param nchannels ... !> \param nsotot ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_mpole_gau(mp_gau,orb_basis,harmonics,nchannels,nsotot,error) + SUBROUTINE calculate_mpole_gau(mp_gau,orb_basis,harmonics,nchannels,nsotot) TYPE(mpole_gau_overlap) :: mp_gau TYPE(gto_basis_set_type), POINTER :: orb_basis TYPE(harmonics_atom_type), POINTER :: harmonics INTEGER, INTENT(IN) :: nchannels, nsotot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_mpole_gau', & routineP = moduleN//':'//routineN @@ -121,7 +119,7 @@ SUBROUTINE calculate_mpole_gau(mp_gau,orb_basis,harmonics,nchannels,nsotot,erro llmax = harmonics%llmax ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) my_CG => harmonics%my_CG @@ -131,7 +129,7 @@ SUBROUTINE calculate_mpole_gau(mp_gau,orb_basis,harmonics,nchannels,nsotot,erro DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local,error) + max_s_harm,llmax,cg_list,cg_n_list,max_iso_not0_local) n1 = nsoset(lmax(iset1)) DO ipgf1 = 1,npgf(iset1) @@ -165,7 +163,7 @@ SUBROUTINE calculate_mpole_gau(mp_gau,orb_basis,harmonics,nchannels,nsotot,erro END DO ! iset1 DEALLOCATE(cg_list,cg_n_list,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE calculate_mpole_gau @@ -184,13 +182,11 @@ END SUBROUTINE calculate_mpole_gau !> \param qs_kind ... !> \param harmonics ... !> \param rho0_h_tot ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_rho0_atom(gapw_control,rho_atom_set, rho0_atom_set, & rho0_mp,a_list,g_atom,& paw_atom,natom,ikind,qs_kind,harmonics,& - rho0_h_tot,& - error) + rho0_h_tot) TYPE(gapw_control_type), POINTER :: gapw_control TYPE(rho_atom_type), DIMENSION(:), & @@ -205,7 +201,6 @@ SUBROUTINE calculate_rho0_atom(gapw_control,rho_atom_set, rho0_atom_set, & TYPE(qs_kind_type), INTENT(IN) :: qs_kind TYPE(harmonics_atom_type), POINTER :: harmonics REAL(dp), INTENT(INOUT) :: rho0_h_tot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho0_atom', & routineP = moduleN//':'//routineN @@ -263,14 +258,14 @@ SUBROUTINE calculate_rho0_atom(gapw_control,rho_atom_set, rho0_atom_set, & nspins = SIZE(cpc_h) nsotot = SIZE(mpole_gau%Qlm_gg,1) ALLOCATE(cpc_ah(nsotot,nsotot,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) cpc_ah=0._dp ALLOCATE(cpc_as(nsotot,nsotot,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) cpc_as=0._dp DO ispin = 1,nspins - CALL prj_scatter(cpc_h(ispin)%r_coef,cpc_ah(:,:,ispin),qs_kind,error) - CALL prj_scatter(cpc_s(ispin)%r_coef,cpc_as(:,:,ispin),qs_kind,error) + CALL prj_scatter(cpc_h(ispin)%r_coef,cpc_ah(:,:,ispin),qs_kind) + CALL prj_scatter(cpc_s(ispin)%r_coef,cpc_as(:,:,ispin),qs_kind) END DO END IF @@ -317,7 +312,7 @@ SUBROUTINE calculate_rho0_atom(gapw_control,rho_atom_set, rho0_atom_set, & END DO ! iso IF(paw_atom) THEN DEALLOCATE(cpc_ah,cpc_as,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END DO ! iat END IF @@ -373,16 +368,14 @@ END SUBROUTINE calculate_rho0_atom !> \param gapw_control ... !> \param tddft ... !> \param tddft_local_rho_set ... -!> \param error ... ! ***************************************************************************** SUBROUTINE init_rho0(qs_env, gapw_control, & - tddft, tddft_local_rho_set, error) + tddft, tddft_local_rho_set) TYPE(qs_environment_type), POINTER :: qs_env TYPE(gapw_control_type), POINTER :: gapw_control LOGICAL, INTENT(IN), OPTIONAL :: tddft TYPE(local_rho_type), OPTIONAL, POINTER :: tddft_local_rho_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_rho0', & routineP = moduleN//':'//routineN @@ -416,7 +409,7 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(qs_kind_set) NULLIFY(atomic_kind_set) @@ -432,7 +425,7 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set, & atomic_kind_set=atomic_kind_set,& - dft_control=dft_control,error=error) + dft_control=dft_control) nkind = SIZE(atomic_kind_set) eps_Vrho0 = gapw_control%eps_Vrho0 @@ -444,7 +437,7 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & CALL get_atomic_kind_set(atomic_kind_set, natom=natom) ! Initialize the multipole and the compensation charge type - CALL allocate_rho0_mpole(rho0_mpole,error=error) + CALL allocate_rho0_mpole(rho0_mpole) CALL allocate_rho0_atom(rho0_atom_set,natom) ! Allocate the multipole set @@ -472,7 +465,7 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & paw_atom=paw_atom,& hard0_radius=rc_orb,& zeff=zeff,& - alpha_core_charge=alpha_core,error=error) + alpha_core_charge=alpha_core) CALL get_gto_basis_set(gto_basis_set=orb_basis,& maxl=maxl,& @@ -487,7 +480,7 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & rho0_mpole%lmax0_kind(ikind) = 0 END IF - CALL set_qs_kind(qs_kind_set(ikind), lmax_rho0 = rho0_mpole%lmax0_kind(ikind),error=error) + CALL set_qs_kind(qs_kind_set(ikind), lmax_rho0 = rho0_mpole%lmax0_kind(ikind)) IF(gapw_control%lrho1_eq_lrho0) harmonics%max_iso_not0 = & nsoset(rho0_mpole%lmax0_kind(ikind)) @@ -511,7 +504,7 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & IF(paw_atom) THEN ! Calculate multipoles given by the product of 2 primitives Qlm_gg CALL calculate_mpole_gau(rho0_mpole%mp_gau(ikind),& - orb_basis,harmonics,nchan_s,nsotot,error) + orb_basis,harmonics,nchan_s,nsotot) END IF ! Calculate the core density rhoz @@ -548,7 +541,7 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & ! and calculate the interaction radii max_rpgf0_s = 0.0_dp DO ikind = 1,nkind - CALL get_qs_kind(qs_kind_set(ikind),grid_atom=grid_atom,error=error) + CALL get_qs_kind(qs_kind_set(ikind),grid_atom=grid_atom) CALL calculate_g0(rho0_mpole,grid_atom,ikind) CALL interaction_radii_g0(rho0_mpole,ikind,eps_Vrho0,max_rpgf0_s) END DO @@ -558,25 +551,24 @@ SUBROUTINE init_rho0(qs_env, gapw_control, & CALL set_qs_env(qs_env=qs_env, rho0_mpole = rho0_mpole, & rho0_atom_set=rho0_atom_set,& rhoz_set = rhoz_set,& - rhoz_tot=total_rho_core_rspace,error=error) + rhoz_tot=total_rho_core_rspace) ELSE tddft_local_rho_set%rho0_mpole => rho0_mpole tddft_local_rho_set%rho0_atom_set => rho0_atom_set tddft_local_rho_set%rhoz_set => rhoz_set tddft_local_rho_set%rhoz_tot = total_rho_core_rspace - CALL rho0_s_grid_create(qs_env, rho0_mpole, .TRUE., error) + CALL rho0_s_grid_create(qs_env, rho0_mpole, .TRUE.) END IF - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") output_unit = cp_print_key_unit_nr(logger,dft_section,"PRINT%GAPW%RHO0_INFORMATION",& - extension=".Log",error=error) - CALL section_vals_val_get(dft_section,"PRINT%GAPW%RHO0_INFORMATION%UNIT",c_val=unit_str,& - error=error) + extension=".Log") + CALL section_vals_val_get(dft_section,"PRINT%GAPW%RHO0_INFORMATION%UNIT",c_val=unit_str) IF (output_unit>0) THEN - CALL write_rho0_info(rho0_mpole,unit_str,output_unit,error) + CALL write_rho0_info(rho0_mpole,unit_str,output_unit) END IF CALL cp_print_key_finished_output(output_unit,logger,dft_section,& - "PRINT%GAPW%RHO0_INFORMATION",error=error) + "PRINT%GAPW%RHO0_INFORMATION") CALL timestop(handle) diff --git a/src/qs_rho0_types.F b/src/qs_rho0_types.F index f935cd5fda..7d61f35f32 100644 --- a/src/qs_rho0_types.F +++ b/src/qs_rho0_types.F @@ -213,12 +213,10 @@ END SUBROUTINE allocate_rho0_atom_rad ! ***************************************************************************** !> \brief ... !> \param rho0 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_rho0_mpole(rho0,error) + SUBROUTINE allocate_rho0_mpole(rho0) TYPE(rho0_mpole_type), POINTER :: rho0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_rho0_mpole', & routineP = moduleN//':'//routineN @@ -226,7 +224,7 @@ SUBROUTINE allocate_rho0_mpole(rho0,error) INTEGER :: istat IF(ASSOCIATED(rho0)) THEN - CALL deallocate_rho0_mpole(rho0,error=error) + CALL deallocate_rho0_mpole(rho0) END IF ALLOCATE (rho0,STAT=istat) @@ -437,12 +435,10 @@ END SUBROUTINE deallocate_rho0_atom ! ***************************************************************************** !> \brief ... !> \param rho0 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_rho0_mpole(rho0,error) + SUBROUTINE deallocate_rho0_mpole(rho0) TYPE(rho0_mpole_type), POINTER :: rho0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_rho0_mpole', & routineP = moduleN//':'//routineN @@ -468,14 +464,14 @@ SUBROUTINE deallocate_rho0_mpole(rho0,error) END IF IF (ASSOCIATED(rho0%rho0_s_rs)) THEN - CALL pw_release(rho0%rho0_s_rs%pw,error=error) + CALL pw_release(rho0%rho0_s_rs%pw) DEALLOCATE(rho0%rho0_s_rs, STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "rho0%rho0_s_rs") ENDIF IF (ASSOCIATED(rho0%rho0_s_gs)) THEN - CALL pw_release(rho0%rho0_s_gs%pw,error=error) + CALL pw_release(rho0%rho0_s_gs%pw) DEALLOCATE(rho0%rho0_s_gs, STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "rho0%rho0_s_gs") @@ -622,14 +618,12 @@ END SUBROUTINE initialize_mpole_rho !> \param rho0_mpole ... !> \param unit_str ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_rho0_info(rho0_mpole,unit_str,output_unit,error) + SUBROUTINE write_rho0_info(rho0_mpole,unit_str,output_unit) TYPE(rho0_mpole_type), POINTER :: rho0_mpole CHARACTER(LEN=*), INTENT(IN) :: unit_str INTEGER, INTENT(in) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_rho0_info', & routineP = moduleN//':'//routineN @@ -638,7 +632,7 @@ SUBROUTINE write_rho0_info(rho0_mpole,unit_str,output_unit,error) REAL(dp) :: conv IF (ASSOCIATED(rho0_mpole)) THEN - conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) WRITE (UNIT=output_unit,FMT="(/,T5,A,/)") & "*** Compensation density charges data set ***" diff --git a/src/qs_rho_atom_methods.F b/src/qs_rho_atom_methods.F index 12e9676220..71df3636f0 100644 --- a/src/qs_rho_atom_methods.F +++ b/src/qs_rho_atom_methods.F @@ -95,10 +95,9 @@ MODULE qs_rho_atom_methods !> \param nspins ... !> \param tot_rho1_h ... !> \param tot_rho1_s ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& - grid_atom, natom, nspins, tot_rho1_h, tot_rho1_s, error) + grid_atom, natom, nspins, tot_rho1_h, tot_rho1_s) TYPE(cp_para_env_type), POINTER :: para_env TYPE(rho_atom_type), DIMENSION(:), & @@ -108,7 +107,6 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& TYPE(grid_atom_type), INTENT(IN) :: grid_atom INTEGER, INTENT(IN) :: natom, nspins REAL(dp), DIMENSION(:), INTENT(INOUT) :: tot_rho1_h, tot_rho1_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_atom', & routineP = moduleN//':'//routineN @@ -149,7 +147,7 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& NULLIFY(lmin,lmax,npgf,zet,my_CG,my_dCG,my_CG_dxyz,coeff) CALL get_qs_kind(qs_kind,basis_set=orb_basis,& - paw_proj_set=paw_proj,harmonics=harmonics,error=error) + paw_proj_set=paw_proj,harmonics=harmonics) CALL get_gto_basis_set(gto_basis_set=orb_basis,lmax=lmax,lmin=lmin,& maxl=maxl,npgf=npgf,nset=nset,zet=zet,& @@ -173,31 +171,31 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& my_CG_dxyz => harmonics%my_CG_dxyz ALLOCATE(CPCH_sphere(nsoset(maxl),nsoset(maxl)),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(CPCS_sphere(nsoset(maxl),nsoset(maxl)),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(g1(nr),g2(nr),gg0(nr),gg(nr,0:2*maxl),dgg(nr,0:2*maxl),& gg_lm1(nr,0:2*maxl),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(erf_zet12(nr),vgg(nr,0:2*maxl,0:indso(1,max_iso_not0)),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(done_vgg(0:2*maxl,0:indso(1,max_iso_not0)),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dd(nr),int1(nr),int2(nr),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),& dacg_list(2,nsoset(maxl)**2,max_s_harm),dacg_n_list(max_s_harm),& dbcg_list(2,nsoset(maxl)**2,max_s_harm),dbcg_n_list(max_s_harm),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO iat = bo(1),bo(2) iatom = atom_list(iat) DO i=1,nspins IF(.NOT. ASSOCIATED(rho_atom_set(iatom)%rho_rad_h(i)%r_coef)) THEN - CALL allocate_rho_atom_rad(rho_atom_set,iatom,i,nr,max_iso_not0,error=error) + CALL allocate_rho_atom_rad(rho_atom_set,iatom,i,nr,max_iso_not0) ELSE - CALL set2zero_rho_atom_rad(rho_atom_set,iatom,i,error=error) + CALL set2zero_rho_atom_rad(rho_atom_set,iatom,i) ENDIF END DO END DO @@ -208,12 +206,12 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local,error) - CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local) + CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,failure) CALL get_none0_cg_list(my_CG_dxyz,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,dacg_list,dacg_n_list,damax_iso_not0_local,error) + max_s_harm,lmax_expansion,dacg_list,dacg_n_list,damax_iso_not0_local) CALL get_none0_cg_list(my_dCG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,dbcg_list,dbcg_n_list,dbmax_iso_not0_local,error) + max_s_harm,lmax_expansion,dbcg_list,dbcg_n_list,dbmax_iso_not0_local) n1s = nsoset(lmax(iset1)) DO ipgf1 = 1,npgf(iset1) @@ -223,7 +221,7 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& iso1_first = o2nindex(iso1_first) iso1_last = o2nindex(iso1_last) i1 = iso1_last - iso1_first + 1 - CPPrecondition(size1==i1,cp_failure_level,routineP,error,failure) + CPPrecondition(size1==i1,cp_failure_level,routineP,failure) i1 = nsoset(lmin(iset1)-1)+1 g1(1:nr) = EXP(-zet(ipgf1,iset1)*grid_atom%rad2(1:nr)) @@ -236,7 +234,7 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& iso2_first = o2nindex(iso2_first) iso2_last = o2nindex(iso2_last) i2 = iso2_last - iso2_first + 1 - CPPrecondition(size2==i2,cp_failure_level,routineP,error,failure) + CPPrecondition(size2==i2,cp_failure_level,routineP,failure) i2 = nsoset(lmin(iset2)-1)+1 g2(1:nr) = EXP(-zet(ipgf2,iset2)*grid_atom%rad2(1:nr)) @@ -290,7 +288,7 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& iso2 = cg_list(2,icg,iso) l = indso(1,iso1) + indso(1,iso2) - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) IF(.NOT. failure) THEN IF(done_vgg(l,l_iso)) CYCLE @@ -344,7 +342,7 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& - 2._dp*REAL(l2,dp)*zet(ipgf1,iset1) & + 4._dp*zet(ipgf1,iset1)*zet(ipgf2,iset2)*grid_atom%rad2(1:nr) l = indso(1,iso1) + indso(1,iso2) - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) IF(.NOT. failure) THEN rho_atom_set(iatom)%rho_rad_h(i)%r_coef(1:nr,iso) =& rho_atom_set(iatom)%rho_rad_h(i)%r_coef(1:nr,iso) +& @@ -400,7 +398,7 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& iso1 = dacg_list(1,icg,iso) iso2 = dacg_list(2,icg,iso) l = indso(1,iso1) + indso(1,iso2) - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) IF(.NOT. failure) THEN DO j = 1,3 rho_atom_set(iatom)%rho_rad_h_d(j,i)%r_coef(1:nr,iso) =& @@ -426,7 +424,7 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& iso2 = dbcg_list(2,icg,iso) l = indso(1,iso1) + indso(1,iso2) - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) IF(.NOT.failure) THEN rho_atom_set(iatom)%trho_rad_h(2,i)%r_coef(1:nr,iso) =& rho_atom_set(iatom)%trho_rad_h(2,i)%r_coef(1:nr,iso) +& @@ -472,11 +470,11 @@ SUBROUTINE calculate_rho_atom(para_env,rho_atom_set,qs_kind,atom_list,& END DO ! iat DEALLOCATE(CPCH_sphere,CPCS_sphere,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(g1,g2,gg0,gg,gg_lm1,dgg,vgg,done_vgg,erf_zet12,int1,int2,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cg_list,cg_n_list,dacg_list,dacg_n_list,dbcg_list,dbcg_n_list,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -489,16 +487,14 @@ END SUBROUTINE calculate_rho_atom !> \param qs_env ... !> \param rho_ao ... !> \param rho_atom_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) + SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: rho_ao TYPE(rho_atom_type), DIMENSION(:), & OPTIONAL, POINTER :: rho_atom_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rho_atom_coeff', & routineP = moduleN//':'//routineN @@ -560,8 +556,7 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) qs_kind_set=qs_kind_set,& para_env=para_env,& oce=oce,sab_orb=sab_orb,& - rho_atom_set=rho_atom,& - error=error) + rho_atom_set=rho_atom) eps_cpc = dft_control%qs_control%gapw_control%eps_cpc @@ -572,28 +567,28 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) NULLIFY(cell_to_index) IF (nimages > 1) THEN - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF ALLOCATE(p_block_spin(nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins NULLIFY(p_block_spin(ispin)%r_coef) END DO CALL get_atomic_kind_set(atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set, maxsgf=max_nsgf, maxgtops=max_gau,error=error) + CALL get_qs_kind_set(qs_kind_set, maxsgf=max_nsgf, maxgtops=max_gau) ALLOCATE (PC1(max_nsgf*max_gau),CPC(max_gau*max_gau),p_matrix(max_nsgf,max_nsgf),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) nkind = SIZE(atomic_kind_set) ! Inizialize to 0 the CPC coefficients and the local density arrays DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=a_list,natom=nat_kind) - CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom,error=error) + CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom) IF(.NOT. paw_atom) CYCLE DO i = 1,nat_kind @@ -617,9 +612,9 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) END DO ! ikind ALLOCATE (basis_set_list(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -648,7 +643,7 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) IF(nimages > 1) THEN img = cell_to_index(cell_b(1),cell_b(2),cell_b(3)) - CPPostcondition(img > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(img > 0,cp_failure_level,routineP,failure) ELSE img = 1 END IF @@ -664,7 +659,7 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) DO kkind = 1 ,nkind CALL get_qs_kind(qs_kind_set(kkind),& basis_set=orb_basis_set,& - paw_proj_set=paw_proj,paw_atom=paw_atom,error=error) + paw_proj_set=paw_proj,paw_atom=paw_atom) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,nset =nsetc,maxso=maxsoc) @@ -678,8 +673,8 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) IF (.NOT.ASSOCIATED(oce%intac(iac)%alist)) CYCLE IF (.NOT.ASSOCIATED(oce%intac(ibc)%alist)) CYCLE - CALL get_alist(oce%intac(iac), alist_ac, iatom, error) - CALL get_alist(oce%intac(ibc), alist_bc, jatom, error) + CALL get_alist(oce%intac(iac), alist_ac, iatom) + CALL get_alist(oce%intac(ibc), alist_bc, jatom) IF (.NOT.ASSOCIATED(alist_ac)) CYCLE IF (.NOT.ASSOCIATED(alist_bc)) CYCLE @@ -758,7 +753,7 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) CALL neighbor_list_iterator_release(nl_iterator) ALLOCATE (kind_of(natom),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,kind_of=kind_of) DO iatom = 1,natom @@ -778,7 +773,7 @@ SUBROUTINE calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set,error) END DO DEALLOCATE(PC1,CPC,p_block_spin,p_matrix,kind_of,basis_set_list,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -788,13 +783,11 @@ END SUBROUTINE calculate_rho_atom_coeff !> \brief ... !> \param qs_env ... !> \param gapw_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_rho_atom(qs_env,gapw_control,error) + SUBROUTINE init_rho_atom(qs_env,gapw_control) TYPE(qs_environment_type), POINTER :: qs_env TYPE(gapw_control_type), POINTER :: gapw_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_rho_atom', & routineP = moduleN//':'//routineN @@ -828,9 +821,9 @@ SUBROUTINE init_rho_atom(qs_env,gapw_control,error) NULLIFY(my_CG, grid_atom, harmonics,atom_list) CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set, atomic_kind_set=atomic_kind_set,& - dft_control=dft_control,error=error) + dft_control=dft_control) CALL get_atomic_kind_set(atomic_kind_set, natom=natom) - CALL get_qs_kind_set(qs_kind_set,maxlgto=maxlgto,error=error) + CALL get_qs_kind_set(qs_kind_set,maxlgto=maxlgto) nspins = dft_control%nspins @@ -847,7 +840,7 @@ SUBROUTINE init_rho_atom(qs_env,gapw_control,error) CALL reallocate(my_CG,1,max_s_set,1,max_s_set,1,max_s_harm) ALLOCATE(rga(lcleb,2),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO lc1 = 0,maxlgto DO iso1=nsoset(lc1-1)+1,nsoset(lc1) l1 = indso(1,iso1) @@ -895,7 +888,7 @@ SUBROUTINE init_rho_atom(qs_env,gapw_control,error) ENDDO ! iso1 ENDDO ! lc1 DEALLOCATE(rga,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL clebsch_gordon_deallocate() ! *** initialize the Lebedev grids *** @@ -908,7 +901,7 @@ SUBROUTINE init_rho_atom(qs_env,gapw_control,error) paw_atom=paw_atom,& grid_atom=grid_atom,& harmonics=harmonics,& - ngrid_rad=nr,ngrid_ang=na,error=error) + ngrid_rad=nr,ngrid_ang=na) ! *** determine the Lebedev grid for this kind *** @@ -932,23 +925,23 @@ SUBROUTINE init_rho_atom(qs_env,gapw_control,error) ! *** calculate the spherical harmonics on the grid *** - CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=orb_basis_set) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,maxl=maxl) maxs=nsoset(maxl) CALL create_harmonics_atom(harmonics,& my_CG,na,llmax,maxs,max_s_harm,ll,grid_atom%wa,& grid_atom%pol,grid_atom%cos_pol,& - grid_atom%cotan_azi,error) - CALL get_maxl_CG(harmonics,orb_basis_set,llmax,max_s_harm,error) + grid_atom%cotan_azi) + CALL get_maxl_CG(harmonics,orb_basis_set,llmax,max_s_harm) END DO CALL deallocate_lebedev_grids() DEALLOCATE(my_CG) - CALL allocate_rho_atom_internals(qs_env, rho_atom_set,error=error) + CALL allocate_rho_atom_internals(qs_env, rho_atom_set) - CALL set_qs_env(qs_env=qs_env, rho_atom_set=rho_atom_set,error=error) + CALL set_qs_env(qs_env=qs_env, rho_atom_set=rho_atom_set) CALL timestop(handle) @@ -958,14 +951,12 @@ END SUBROUTINE init_rho_atom !> \brief ... !> \param qs_env ... !> \param rho_atom_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set,error) + SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set) TYPE(qs_environment_type), POINTER :: qs_env TYPE(rho_atom_type), DIMENSION(:), & POINTER :: rho_atom_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_rho_atom_internals', & routineP = moduleN//':'//routineN @@ -992,8 +983,7 @@ SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set,error) qs_kind_set=qs_kind_set, & atomic_kind_set=atomic_kind_set,& para_env=para_env,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) CALL get_atomic_kind_set(atomic_kind_set, natom=natom) @@ -1009,7 +999,7 @@ SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set,error) paw_proj_set=paw_proj,& paw_atom=paw_atom,& harmonics=harmonics,& - ngrid_rad=nr,error=error) + ngrid_rad=nr) IF (paw_atom) THEN CALL get_paw_proj_set(paw_proj_set=paw_proj,nsatbas=nsatbas,nsotot=nsotot) @@ -1021,13 +1011,13 @@ SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set,error) ! *** allocate the radial density for each LM,for each atom *** ALLOCATE (rho_atom_set(iatom)%rho_rad_h(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (rho_atom_set(iatom)%rho_rad_s(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (rho_atom_set(iatom)%vrho_rad_h(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (rho_atom_set(iatom)%vrho_rad_s(nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) istat = 0 DO ispin = 1,nspins @@ -1047,7 +1037,7 @@ SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set,error) rho_atom_set(iatom)%rho_rad_h_d(3,nspins), & rho_atom_set(iatom)%rho_rad_s_d(3,nspins), & STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (paw_atom) THEN DO ispin = 1,nspins @@ -1062,7 +1052,7 @@ SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set,error) ALLOCATE(rho_atom_set(iatom)%cpc_h(ispin)%r_coef(1:nsatbas,1:nsatbas), & rho_atom_set(iatom)%cpc_s(ispin)%r_coef(1:nsatbas,1:nsatbas),& STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) rho_atom_set(iatom)%cpc_h(ispin)%r_coef = 0.0_dp rho_atom_set(iatom)%cpc_s(ispin)%r_coef = 0.0_dp @@ -1094,7 +1084,7 @@ SUBROUTINE allocate_rho_atom_internals(qs_env,rho_atom_set,error) ALLOCATE (rho_atom_set(iatom)%ga_Vlocal_gb_h(nspins), & rho_atom_set(iatom)%ga_Vlocal_gb_s(nspins), & STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (paw_atom) THEN DO ispin = 1,nspins NULLIFY(rho_atom_set(iatom)%ga_Vlocal_gb_h(ispin)%r_coef) @@ -1130,14 +1120,12 @@ END SUBROUTINE allocate_rho_atom_internals !> \param ispin ... !> \param nr ... !> \param max_iso_not0 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_rho_atom_rad(rho_atom_set,iatom,ispin,nr,max_iso_not0,error) + SUBROUTINE allocate_rho_atom_rad(rho_atom_set,iatom,ispin,nr,max_iso_not0) TYPE(rho_atom_type), DIMENSION(:), & POINTER :: rho_atom_set INTEGER, INTENT(IN) :: iatom, ispin, nr, max_iso_not0 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_rho_atom_rad', & routineP = moduleN//':'//routineN @@ -1153,7 +1141,7 @@ SUBROUTINE allocate_rho_atom_rad(rho_atom_set,iatom,ispin,nr,max_iso_not0,error) rho_atom_set(iatom)%vrho_rad_h(ispin)%r_coef(1:nr,1:max_iso_not0), & rho_atom_set(iatom)%vrho_rad_s(ispin)%r_coef(1:nr,1:max_iso_not0), & STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rho_atom_set(iatom)%rho_rad_h(ispin)%r_coef=0.0_dp rho_atom_set(iatom)%rho_rad_s(ispin)%r_coef=0.0_dp @@ -1163,7 +1151,7 @@ SUBROUTINE allocate_rho_atom_rad(rho_atom_set,iatom,ispin,nr,max_iso_not0,error) ALLOCATE(rho_atom_set(iatom)%drho_rad_h(ispin)%r_coef(nr,max_iso_not0),& rho_atom_set(iatom)%drho_rad_s(ispin)%r_coef(nr,max_iso_not0),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rho_atom_set(iatom)%drho_rad_h(ispin)%r_coef = 0.0_dp rho_atom_set(iatom)%drho_rad_s(ispin)%r_coef = 0.0_dp @@ -1171,7 +1159,7 @@ SUBROUTINE allocate_rho_atom_rad(rho_atom_set,iatom,ispin,nr,max_iso_not0,error) ALLOCATE(rho_atom_set(iatom)%trho_rad_h(j,ispin)%r_coef(nr,max_iso_not0),& rho_atom_set(iatom)%trho_rad_s(j,ispin)%r_coef(nr,max_iso_not0),& STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rho_atom_set(iatom)%trho_rad_h(j,ispin)%r_coef = 0.0_dp rho_atom_set(iatom)%trho_rad_s(j,ispin)%r_coef = 0.0_dp END DO @@ -1182,7 +1170,7 @@ SUBROUTINE allocate_rho_atom_rad(rho_atom_set,iatom,ispin,nr,max_iso_not0,error) ALLOCATE(rho_atom_set(iatom)%rho_rad_h_d(j,ispin)%r_coef(nr,max_iso_not0), & rho_atom_set(iatom)%rho_rad_s_d(j,ispin)%r_coef(nr,max_iso_not0), & STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) rho_atom_set(iatom)%rho_rad_h_d(j,ispin)%r_coef = 0.0_dp rho_atom_set(iatom)%rho_rad_s_d(j,ispin)%r_coef = 0.0_dp END DO @@ -1196,15 +1184,13 @@ END SUBROUTINE allocate_rho_atom_rad !> \param rho_atom_set ... !> \param iatom ... !> \param ispin ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set2zero_rho_atom_rad(rho_atom_set,iatom,ispin,error) + SUBROUTINE set2zero_rho_atom_rad(rho_atom_set,iatom,ispin) ! TYPE(rho_atom_type), POINTER :: rho_atom TYPE(rho_atom_type), DIMENSION(:), & POINTER :: rho_atom_set INTEGER, INTENT(IN) :: iatom, ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set2zero_rho_atom_rad', & routineP = moduleN//':'//routineN diff --git a/src/qs_rho_methods.F b/src/qs_rho_methods.F index 3984ceb2ae..ee56bb02d2 100644 --- a/src/qs_rho_methods.F +++ b/src/qs_rho_methods.F @@ -74,8 +74,6 @@ MODULE qs_rho_methods !> \param rebuild_grids if it in necessary to rebuild rho_r and rho_g. !> Defaults to false. !> \param admm (use aux_fit basis) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2002 created replacing qs_rho_create and qs_env_rebuild_rho[fawzi] !> \author Fawzi Mohamed @@ -86,12 +84,11 @@ MODULE qs_rho_methods !> Change so that it does not allocate a subcomponent if it is not !> associated and not requested? ! ***************************************************************************** - SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) + SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm) TYPE(qs_rho_type), POINTER :: rho TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in), OPTIONAL :: rebuild_ao, rebuild_grids, & admm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_rho_rebuild', & routineP = moduleN//':'//routineN @@ -136,21 +133,20 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) kpoints=kpoints,& do_kpoints=do_kpoints,& pw_env=pw_env,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) nimg = dft_control%nimages IF (my_admm) THEN - CPPostcondition(.NOT.do_kpoints, cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env, matrix_s_aux_fit=matrix_s, sab_aux_fit=sab_orb, error=error) + CPPostcondition(.NOT.do_kpoints, cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env, matrix_s_aux_fit=matrix_s, sab_aux_fit=sab_orb) refmatrix => matrix_s(1)%matrix ELSE - CALL get_qs_env(qs_env, matrix_s_kp=matrix_s_kp, sab_orb=sab_orb, error=error) + CALL get_qs_env(qs_env, matrix_s_kp=matrix_s_kp, sab_orb=sab_orb) refmatrix => matrix_s_kp(1,1)%matrix END IF - CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool) nspins=dft_control%nspins IF (.NOT.ASSOCIATED(rho)) STOP routineP//" rho not associated" @@ -163,22 +159,21 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) drho_g=drho_g,& tau_r=tau_r,& tau_g=tau_g,& - rho_r_sccs=rho_r_sccs,& - error=error) + rho_r_sccs=rho_r_sccs) IF (.NOT.ASSOCIATED(tot_rho_r)) THEN ALLOCATE(tot_rho_r(nspins)) tot_rho_r=0.0_dp - CALL qs_rho_set(rho, tot_rho_r=tot_rho_r, error=error) + CALL qs_rho_set(rho, tot_rho_r=tot_rho_r) END IF ! rho_ao IF (my_rebuild_ao.OR.(.NOT.ASSOCIATED(rho_ao_kp))) THEN IF (ASSOCIATED(rho_ao_kp)) & - CALL cp_dbcsr_deallocate_matrix_set(rho_ao_kp,error=error) + CALL cp_dbcsr_deallocate_matrix_set(rho_ao_kp) ! Create a new density matrix set - CALL cp_dbcsr_allocate_matrix_set(rho_ao_kp,nspins,nimg,error=error) - CALL qs_rho_set(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL cp_dbcsr_allocate_matrix_set(rho_ao_kp,nspins,nimg) + CALL qs_rho_set(rho, rho_ao_kp=rho_ao_kp) DO i=1,nspins DO ic=1,nimg IF (nspins > 1) THEN @@ -192,14 +187,14 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) END IF ALLOCATE(rho_ao_kp(i,ic)%matrix) tmatrix => rho_ao_kp(i,ic)%matrix - CALL cp_dbcsr_init(tmatrix, error=error) + CALL cp_dbcsr_init(tmatrix) CALL cp_dbcsr_create(matrix=tmatrix, name=TRIM(headline),& dist=cp_dbcsr_distribution(refmatrix), matrix_type=dbcsr_type_symmetric,& row_blk_size=cp_dbcsr_row_block_sizes(refmatrix),& col_blk_size=cp_dbcsr_col_block_sizes(refmatrix),& - nze=0, error=error) - CALL cp_dbcsr_alloc_block_from_nbl(tmatrix,sab_orb,error=error) - CALL cp_dbcsr_set(tmatrix,0.0_dp,error=error) + nze=0) + CALL cp_dbcsr_alloc_block_from_nbl(tmatrix,sab_orb) + CALL cp_dbcsr_set(tmatrix,0.0_dp) END DO END DO END IF @@ -208,15 +203,15 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) IF (my_rebuild_grids.OR..NOT.ASSOCIATED(rho_r)) THEN IF (ASSOCIATED(rho_r)) THEN DO i=1,SIZE(rho_r) - CALL pw_release(rho_r(i)%pw,error=error) + CALL pw_release(rho_r(i)%pw) END DO DEALLOCATE(rho_r) END IF ALLOCATE(rho_r(nspins)) - CALL qs_rho_set(rho, rho_r=rho_r, error=error) + CALL qs_rho_set(rho, rho_r=rho_r) DO i=1,nspins CALL pw_pool_create_pw(auxbas_pw_pool,rho_r(i)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) END DO END IF @@ -224,15 +219,15 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) IF (my_rebuild_grids.OR..NOT.ASSOCIATED(rho_g)) THEN IF (ASSOCIATED(rho_g)) THEN DO i=1,SIZE(rho_g) - CALL pw_release(rho_g(i)%pw,error=error) + CALL pw_release(rho_g(i)%pw) END DO DEALLOCATE(rho_g) END IF ALLOCATE(rho_g(nspins)) - CALL qs_rho_set(rho, rho_g=rho_g, error=error) + CALL qs_rho_set(rho, rho_g=rho_g) DO i=1,nspins CALL pw_pool_create_pw(auxbas_pw_pool,rho_g(i)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) END DO END IF @@ -240,16 +235,15 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) IF (dft_control%do_sccs) THEN IF (my_rebuild_grids.OR.(.NOT.ASSOCIATED(rho_r_sccs))) THEN IF (ASSOCIATED(rho_r_sccs)) THEN - CALL pw_release(rho_r_sccs%pw,error=error) + CALL pw_release(rho_r_sccs%pw) DEALLOCATE (rho_r_sccs) END IF ALLOCATE (rho_r_sccs) - CALL qs_rho_set(rho,rho_r_sccs=rho_r_sccs,error=error) + CALL qs_rho_set(rho,rho_r_sccs=rho_r_sccs) CALL pw_pool_create_pw(auxbas_pw_pool,rho_r_sccs%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_zero(rho_r_sccs%pw,error=error) + in_space=REALSPACE) + CALL pw_zero(rho_r_sccs%pw) END IF END IF @@ -259,30 +253,30 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) IF (my_rebuild_grids.OR..NOT.ASSOCIATED(drho_r)) THEN IF (ASSOCIATED(drho_r)) THEN DO i=1,SIZE(drho_r) - CALL pw_release(drho_r(i)%pw,error=error) + CALL pw_release(drho_r(i)%pw) END DO DEALLOCATE(drho_r) END IF ALLOCATE(drho_r(3*nspins)) - CALL qs_rho_set(rho, drho_r=drho_r, error=error) + CALL qs_rho_set(rho, drho_r=drho_r) DO i=1,3*nspins CALL pw_pool_create_pw(auxbas_pw_pool,drho_r(i)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) END DO END IF ! drho_g IF (my_rebuild_grids.OR..NOT.ASSOCIATED(drho_g)) THEN IF (ASSOCIATED(drho_g)) THEN DO i=1,SIZE(drho_g) - CALL pw_release(drho_g(i)%pw,error=error) + CALL pw_release(drho_g(i)%pw) END DO DEALLOCATE(drho_g) END IF ALLOCATE(drho_g(3*nspins)) - CALL qs_rho_set(rho, drho_g=drho_g, error=error) + CALL qs_rho_set(rho, drho_g=drho_g) DO i=1,3*nspins CALL pw_pool_create_pw(auxbas_pw_pool,drho_g(i)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) END DO END IF END IF @@ -293,15 +287,15 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) IF (my_rebuild_grids.OR..NOT.ASSOCIATED(tau_r)) THEN IF (ASSOCIATED(tau_r)) THEN DO i=1,SIZE(tau_r) - CALL pw_release(tau_r(i)%pw,error=error) + CALL pw_release(tau_r(i)%pw) END DO DEALLOCATE(tau_r) END IF ALLOCATE(tau_r(nspins)) - CALL qs_rho_set(rho, tau_r=tau_r, error=error) + CALL qs_rho_set(rho, tau_r=tau_r) DO i=1,nspins CALL pw_pool_create_pw(auxbas_pw_pool,tau_r(i)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) END DO END IF @@ -309,15 +303,15 @@ SUBROUTINE qs_rho_rebuild(rho, qs_env, rebuild_ao, rebuild_grids, admm, error) IF (my_rebuild_grids.OR..NOT.ASSOCIATED(tau_g)) THEN IF (ASSOCIATED(tau_g)) THEN DO i=1,SIZE(tau_g) - CALL pw_release(tau_g(i)%pw,error=error) + CALL pw_release(tau_g(i)%pw) END DO DEALLOCATE(tau_g) END IF ALLOCATE(tau_g(nspins)) - CALL qs_rho_set(rho, tau_g=tau_g, error=error) + CALL qs_rho_set(rho, tau_g=tau_g) DO i=1,nspins CALL pw_pool_create_pw(auxbas_pw_pool,tau_g(i)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) END DO END IF END IF ! use_kinetic_energy_density @@ -334,18 +328,15 @@ END SUBROUTINE qs_rho_rebuild !> the integrated charge in r space !> \param local_rho_set ... !> \param task_list_external ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_external, error) +SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_external) TYPE(qs_rho_type), POINTER :: rho_struct TYPE(qs_environment_type), POINTER :: qs_env TYPE(local_rho_type), OPTIONAL, POINTER :: local_rho_set TYPE(task_list_type), OPTIONAL, POINTER :: task_list_external - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_update_rho', & routineP = moduleN//':'//routineN @@ -382,7 +373,7 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern NULLIFY(rho_xc_ao,rho_xc_g,rho_xc_r,drho_xc_g, tau_xc_r, tau_xc_g, tot_rho_r, tot_rho_r_xc) NULLIFY(lri_env, lri_density, para_env, atomic_kind_set) - CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& ks_env=ks_env,& @@ -391,8 +382,7 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern lri_density=lri_density,& lri_env=lri_env,& atomic_kind_set=atomic_kind_set,& - para_env=para_env,& - error=error) + para_env=para_env) CALL qs_rho_get(rho_struct,& rho_r=rho_r,& @@ -402,8 +392,7 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern drho_g=drho_g,& tau_r=tau_r,& tau_g=tau_g,& - rho_r_sccs=rho_r_sccs,& - error=error) + rho_r_sccs=rho_r_sccs) IF (PRESENT(task_list_external)) task_list => task_list_external @@ -414,22 +403,22 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern IF(dft_control%qs_control%semi_empirical) THEN ! - CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE., error=error) + CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE.) ELSEIF(dft_control%qs_control%dftb) THEN ! - CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE., error=error) + CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE.) ELSEIF(dft_control%qs_control%scptb) THEN ! - CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE., error=error) + CALL qs_rho_set(rho_struct, rho_r_valid=.FALSE., rho_g_valid=.FALSE.) ELSEIF(dft_control%qs_control%lrigpw) THEN - CALL qs_rho_get(rho_struct, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho_struct, rho_ao=rho_ao) CALL calculate_lri_densities(lri_env,lri_density,qs_env,rho_ao,& lri_rho_struct=rho_struct,& atomic_kind_set=atomic_kind_set,& - para_env=para_env,error=error) - CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + para_env=para_env) + CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) ELSE - CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) DO ispin=1,nspins rho_ao => rho_ao_kp(ispin,:) CALL calculate_rho_elec(matrix_p_kp=rho_ao,& @@ -437,23 +426,23 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern rho_gspace=rho_g(ispin),& total_rho=tot_rho_r(ispin),& ks_env=ks_env,soft_valid=gapw,& - task_list_external=task_list, error=error) + task_list_external=task_list) END DO - CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_struct, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) END IF ! if needed compute also the gradient of the density IF (dft_control%drho_by_collocation) THEN - CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) DO ispin=1,nspins - CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,failure) rho_ao => rho_ao_kp(ispin,:) CALL calculate_drho_elec(matrix_p_kp=rho_ao,& drho=drho_r(3*(ispin-1)+1:3*ispin),& drho_gspace=drho_g(3*(ispin-1)+1:3*ispin),& - qs_env=qs_env,soft_valid=gapw,error=error) + qs_env=qs_env,soft_valid=gapw) END DO - CALL qs_rho_set(rho_struct, drho_r_valid=.TRUE., drho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_struct, drho_r_valid=.TRUE., drho_g_valid=.TRUE.) ENDIF ! if needed compute also the kinetic energy density @@ -462,34 +451,33 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern CALL stop_program(routineN,moduleN,__LINE__,& "LRIGPW not implemented for meta-GGAs") ENDIF - CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) DO ispin=1,nspins - CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,failure) rho_ao => rho_ao_kp(ispin,:) CALL calculate_rho_elec(matrix_p_kp=rho_ao,& rho=tau_r(ispin),& rho_gspace=tau_g(ispin),& total_rho=dum, & ! presumably not meaningful ks_env=ks_env, soft_valid=gapw, & - compute_tau=.TRUE.,& - error=error) + compute_tau=.TRUE.) END DO - CALL qs_rho_set(rho_struct, tau_r_valid=.TRUE., tau_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_struct, tau_r_valid=.TRUE., tau_g_valid=.TRUE.) ENDIF ! GAPW o GAPW_XC require the calculation of hard and soft local densities IF(gapw ) THEN - CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,error,failure) - CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp, error=error) + CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,failure) + CALL qs_rho_get(rho_struct, rho_ao_kp=rho_ao_kp) IF(PRESENT(local_rho_set)) THEN - CALL calculate_rho_atom_coeff(qs_env,rho_ao_kp,local_rho_set%rho_atom_set,error=error) + CALL calculate_rho_atom_coeff(qs_env,rho_ao_kp,local_rho_set%rho_atom_set) ELSE - CALL calculate_rho_atom_coeff(qs_env,rho_ao_kp,error=error) + CALL calculate_rho_atom_coeff(qs_env,rho_ao_kp) ENDIF ENDIF IF(gapw_xc) THEN - CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env=qs_env,rho_xc=rho_xc,error=error) + CPPrecondition(.NOT.PRESENT(task_list_external),cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env=qs_env,rho_xc=rho_xc) CALL qs_rho_get(rho_xc,& rho_ao_kp=rho_xc_ao,& rho_r=rho_xc_r,& @@ -497,13 +485,12 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern tot_rho_r=tot_rho_r_xc,& drho_g=drho_xc_g,& tau_r=tau_xc_r,& - tau_g=tau_xc_g,& - error=error) - CALL calculate_rho_atom_coeff(qs_env,rho_ao_kp,error=error) + tau_g=tau_xc_g) + CALL calculate_rho_atom_coeff(qs_env,rho_ao_kp) ! copy rho_ao into rho_xc_ao DO ispin=1,nspins DO img=1,nimg - CALL cp_dbcsr_copy(rho_xc_ao(ispin,img)%matrix,rho_ao_kp(ispin,img)%matrix, error=error) + CALL cp_dbcsr_copy(rho_xc_ao(ispin,img)%matrix,rho_ao_kp(ispin,img)%matrix) END DO END DO DO ispin=1,nspins @@ -512,9 +499,9 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern rho=rho_xc_r(ispin),& rho_gspace=rho_xc_g(ispin),& total_rho=tot_rho_r_xc(ispin),& - ks_env=ks_env,soft_valid=gapw_xc,error=error) + ks_env=ks_env,soft_valid=gapw_xc) END DO - CALL qs_rho_set(rho_xc, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_xc, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) ! if needed compute also the gradient of the density IF (dft_control%drho_by_collocation) THEN DO ispin=1,nspins @@ -522,9 +509,9 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern CALL calculate_drho_elec(matrix_p_kp=rho_ao,& drho=rho_xc_r(3*(ispin-1)+1:3*ispin),& drho_gspace=drho_xc_g(3*(ispin-1)+1:3*ispin),& - qs_env=qs_env,soft_valid=gapw_xc,error=error) + qs_env=qs_env,soft_valid=gapw_xc) END DO - CALL qs_rho_set(rho_xc, drho_r_valid=.TRUE., drho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_xc, drho_r_valid=.TRUE., drho_g_valid=.TRUE.) ENDIF ! if needed compute also the kinetic energy density IF (dft_control%use_kinetic_energy_density) THEN @@ -535,9 +522,9 @@ SUBROUTINE qs_rho_update_rho(rho_struct, qs_env, local_rho_set, task_list_extern rho_gspace=tau_xc_g(ispin),& total_rho=dum, & ! presumably not meaningful ks_env=ks_env, soft_valid=gapw_xc, & - compute_tau=.TRUE., error=error) + compute_tau=.TRUE.) END DO - CALL qs_rho_set(rho_xc, tau_r_valid=.TRUE., tau_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho_xc, tau_r_valid=.TRUE., tau_g_valid=.TRUE.) ENDIF ENDIF @@ -551,19 +538,16 @@ END SUBROUTINE qs_rho_update_rho !> \param rho_output The duplicate rho structure !> \param qs_env The QS environment from which the auxiliary PW basis-set !> pool is taken -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2005 initial create [tdk] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) !> \note !> Associated pointers are deallocated, nullified pointers are NOT accepted! ! ***************************************************************************** - SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) + SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env) TYPE(qs_rho_type), POINTER :: rho_input, rho_output TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'duplicate_rho_type', & routineP = moduleN//':'//routineN @@ -594,17 +578,16 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) NULLIFY(tot_rho_r_in, tot_rho_r_out, tot_rho_g_in, tot_rho_g_out) NULLIFY(rho_r_sccs_in, rho_r_sccs_out) - CPPrecondition(ASSOCIATED(rho_input), cp_failure_level, routineP, error, failure) - CPPrecondition(ASSOCIATED(rho_output), cp_failure_level, routineP, error, failure) - CPPrecondition(ASSOCIATED(qs_env), cp_failure_level, routineP, error, failure) - CPPrecondition(qs_env%ref_count>0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(rho_input), cp_failure_level, routineP,failure) + CPPrecondition(ASSOCIATED(rho_output), cp_failure_level, routineP,failure) + CPPrecondition(ASSOCIATED(qs_env), cp_failure_level, routineP,failure) + CPPrecondition(qs_env%ref_count>0, cp_failure_level, routineP,failure) - CALL get_qs_env(qs_env=qs_env, pw_env=pw_env, dft_control=dft_control, & - error=error) - CALL pw_env_get(pw_env=pw_env, auxbas_pw_pool=auxbas_pw_pool, error=error) + CALL get_qs_env(qs_env=qs_env, pw_env=pw_env, dft_control=dft_control) + CALL pw_env_get(pw_env=pw_env, auxbas_pw_pool=auxbas_pw_pool) nspins = dft_control%nspins - CALL qs_rho_clear(rho_output, error=error) + CALL qs_rho_clear(rho_output) CALL qs_rho_get(rho_input,& rho_ao = rho_ao_in,& @@ -624,31 +607,28 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) tau_g_valid = tau_g_valid_in,& rho_r_sccs = rho_r_sccs_in,& soft_valid = soft_valid_in,& - rebuild_each = rebuild_each_in,& - error=error) + rebuild_each = rebuild_each_in) ! rho_ao IF (ASSOCIATED(rho_ao_in)) THEN - CALL cp_dbcsr_allocate_matrix_set(rho_ao_out, nspins,error=error) - CALL qs_rho_set(rho_output, rho_ao=rho_ao_out, error=error) + CALL cp_dbcsr_allocate_matrix_set(rho_ao_out, nspins) + CALL qs_rho_set(rho_output, rho_ao=rho_ao_out) DO i = 1, nspins ALLOCATE(rho_ao_out(i)%matrix) - CALL cp_dbcsr_init(rho_ao_out(i)%matrix, error=error) + CALL cp_dbcsr_init(rho_ao_out(i)%matrix) CALL cp_dbcsr_copy(rho_ao_out(i)%matrix,rho_ao_in(i)%matrix, & - name="myDensityMatrix_for_Spin_"//TRIM(ADJUSTL(cp_to_string(i))), & - error=error) - CALL cp_dbcsr_set(rho_ao_out(i)%matrix,0.0_dp,error=error) + name="myDensityMatrix_for_Spin_"//TRIM(ADJUSTL(cp_to_string(i)))) + CALL cp_dbcsr_set(rho_ao_out(i)%matrix,0.0_dp) END DO END IF ! rho_r IF (ASSOCIATED(rho_r_in)) THEN ALLOCATE(rho_r_out(nspins)) - CALL qs_rho_set(rho_output, rho_r=rho_r_out, error=error) + CALL qs_rho_set(rho_output, rho_r=rho_r_out) DO i = 1, nspins CALL pw_pool_create_pw(auxbas_pw_pool, rho_r_out(i)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) rho_r_out(i)%pw%cr3d(:,:,:) = rho_r_in(i)%pw%cr3d(:,:,:) END DO END IF @@ -656,22 +636,21 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) ! rho_g IF (ASSOCIATED(rho_g_in)) THEN ALLOCATE(rho_g_out(nspins)) - CALL qs_rho_set(rho_output, rho_g=rho_g_out, error=error) + CALL qs_rho_set(rho_output, rho_g=rho_g_out) DO i = 1, nspins CALL pw_pool_create_pw(auxbas_pw_pool, rho_g_out(i)%pw, & use_data=COMPLEXDATA1D, & - in_space=RECIPROCALSPACE, error=error) + in_space=RECIPROCALSPACE) rho_g_out(i)%pw%cc(:) = rho_g_in(i)%pw%cc(:) END DO END IF ! SCCS IF (ASSOCIATED(rho_r_sccs_in)) THEN - CALL qs_rho_set(rho_output,rho_r_sccs=rho_r_sccs_out,error=error) + CALL qs_rho_set(rho_output,rho_r_sccs=rho_r_sccs_out) CALL pw_pool_create_pw(auxbas_pw_pool,rho_r_sccs_out%pw,& in_space=REALSPACE,& - use_data=REALDATA3D,& - error=error) + use_data=REALDATA3D) rho_r_sccs_out%pw%cr3d(:,:,:) = rho_r_sccs_in%pw%cr3d(:,:,:) END IF @@ -680,11 +659,10 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) ! drho_r IF (ASSOCIATED(drho_r_in)) THEN ALLOCATE(drho_r_out(3*nspins)) - CALL qs_rho_set(rho_output, drho_r=drho_r_out, error=error) + CALL qs_rho_set(rho_output, drho_r=drho_r_out) DO i = 1, 3*nspins CALL pw_pool_create_pw(auxbas_pw_pool, drho_r_out(i)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) drho_r_out(i)%pw%cr3d(:,:,:) = drho_r_in(i)%pw%cr3d(:,:,:) END DO END IF @@ -692,11 +670,11 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) ! drho_g IF (ASSOCIATED(drho_g_in)) THEN ALLOCATE(drho_g_out(3*nspins)) - CALL qs_rho_set(rho_output, drho_g=drho_g_out, error=error) + CALL qs_rho_set(rho_output, drho_g=drho_g_out) DO i = 1, 3*nspins CALL pw_pool_create_pw(auxbas_pw_pool, drho_g_out(i)%pw, & use_data=COMPLEXDATA1D, & - in_space=RECIPROCALSPACE, error=error) + in_space=RECIPROCALSPACE) drho_g_out(i)%pw%cc(:) = drho_g_in(i)%pw%cc(:) END DO END IF @@ -709,11 +687,10 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) ! tau_r IF (ASSOCIATED(tau_r_in)) THEN ALLOCATE(tau_r_out(nspins)) - CALL qs_rho_set(rho_output, tau_r=tau_r_out, error=error) + CALL qs_rho_set(rho_output, tau_r=tau_r_out) DO i = 1, nspins CALL pw_pool_create_pw(auxbas_pw_pool, tau_r_out(i)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) tau_r_out(i)%pw%cr3d(:,:,:) = tau_r_in(i)%pw%cr3d(:,:,:) END DO END IF @@ -721,11 +698,11 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) ! tau_g IF (ASSOCIATED(tau_g_in)) THEN ALLOCATE(tau_g_out(nspins)) - CALL qs_rho_set(rho_output, tau_g=tau_g_out, error=error) + CALL qs_rho_set(rho_output, tau_g=tau_g_out) DO i = 1, nspins CALL pw_pool_create_pw(auxbas_pw_pool, tau_g_out(i)%pw, & use_data=COMPLEXDATA1D, & - in_space=RECIPROCALSPACE, error=error) + in_space=RECIPROCALSPACE) tau_g_out(i)%pw%cc(:) = tau_g_in(i)%pw%cc(:) END DO END IF @@ -739,13 +716,12 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) tau_r_valid = tau_r_valid_in,& tau_g_valid = tau_g_valid_in,& soft_valid = soft_valid_in,& - rebuild_each = rebuild_each_in,& - error=error) + rebuild_each = rebuild_each_in) ! tot_rho_r IF (ASSOCIATED(tot_rho_r_in)) THEN ALLOCATE(tot_rho_r_out(nspins)) - CALL qs_rho_set(rho_output, tot_rho_r=tot_rho_r_out, error=error) + CALL qs_rho_set(rho_output, tot_rho_r=tot_rho_r_out) DO i = 1, nspins tot_rho_r_out(i) = tot_rho_r_in(i) END DO @@ -754,7 +730,7 @@ SUBROUTINE duplicate_rho_type(rho_input, rho_output, qs_env, error) ! tot_rho_g IF (ASSOCIATED(tot_rho_g_in)) THEN ALLOCATE(tot_rho_g_out(nspins)) - CALL qs_rho_set(rho_output, tot_rho_g=tot_rho_g_out, error=error) + CALL qs_rho_set(rho_output, tot_rho_g=tot_rho_g_out) DO i = 1, nspins tot_rho_g_out(i) = tot_rho_g_in(i) END DO diff --git a/src/qs_rho_types.F b/src/qs_rho_types.F index 0ae33ce8b3..0e20487ace 100644 --- a/src/qs_rho_types.F +++ b/src/qs_rho_types.F @@ -102,12 +102,10 @@ MODULE qs_rho_types ! ***************************************************************************** !> \brief Allocates a new instance of rho. !> \param rho ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qs_rho_create(rho, error) + SUBROUTINE qs_rho_create(rho) TYPE(qs_rho_type), POINTER :: rho - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_rho_create', & routineP = moduleN//':'//routineN @@ -125,15 +123,12 @@ END SUBROUTINE qs_rho_create !> \brief retains a rho_struct by increasing the reference count by one !> (to be called when you want to keep a shared copy) !> \param rho_struct the structure to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qs_rho_retain(rho_struct,error) + SUBROUTINE qs_rho_retain(rho_struct) TYPE(qs_rho_type), POINTER :: rho_struct - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_retain', & routineP = moduleN//':'//routineN @@ -142,8 +137,8 @@ SUBROUTINE qs_rho_retain(rho_struct,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,failure) + CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,failure) rho_struct%ref_count=rho_struct%ref_count+1 END SUBROUTINE qs_rho_retain @@ -152,15 +147,12 @@ END SUBROUTINE qs_rho_retain !> and deallocating if it reaches 0 (to be called when you don't want !> anymore a shared copy) !> \param rho_struct the structure to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE qs_rho_release(rho_struct,error) + SUBROUTINE qs_rho_release(rho_struct) TYPE(qs_rho_type), POINTER :: rho_struct - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_release', & routineP = moduleN//':'//routineN @@ -170,10 +162,10 @@ SUBROUTINE qs_rho_release(rho_struct,error) failure=.FALSE. IF (ASSOCIATED(rho_struct)) THEN - CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,failure) rho_struct%ref_count=rho_struct%ref_count-1 IF (rho_struct%ref_count<1) THEN - CALL qs_rho_clear(rho_struct, error) + CALL qs_rho_clear(rho_struct) DEALLOCATE(rho_struct) END IF END IF @@ -186,12 +178,10 @@ END SUBROUTINE qs_rho_release ! ***************************************************************************** !> \brief Deallocates all components, whithout deallocating rho_struct itself. !> \param rho_struct ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qs_rho_clear(rho_struct, error) + SUBROUTINE qs_rho_clear(rho_struct) TYPE(qs_rho_type), POINTER :: rho_struct - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_clear', & routineP = moduleN//':'//routineN @@ -200,49 +190,49 @@ SUBROUTINE qs_rho_clear(rho_struct, error) IF (ASSOCIATED(rho_struct%rho_r)) THEN DO i=1,SIZE(rho_struct%rho_r) - CALL pw_release(rho_struct%rho_r(i)%pw,error=error) + CALL pw_release(rho_struct%rho_r(i)%pw) END DO DEALLOCATE(rho_struct%rho_r) END IF IF (ASSOCIATED(rho_struct%drho_r)) THEN DO i=1,SIZE(rho_struct%drho_r) - CALL pw_release(rho_struct%drho_r(i)%pw,error=error) + CALL pw_release(rho_struct%drho_r(i)%pw) END DO DEALLOCATE(rho_struct%drho_r) END IF IF (ASSOCIATED(rho_struct%drho_g)) THEN DO i=1,SIZE(rho_struct%drho_g) - CALL pw_release(rho_struct%drho_g(i)%pw,error=error) + CALL pw_release(rho_struct%drho_g(i)%pw) END DO DEALLOCATE(rho_struct%drho_g) END IF IF (ASSOCIATED(rho_struct%tau_r)) THEN DO i=1,SIZE(rho_struct%tau_r) - CALL pw_release(rho_struct%tau_r(i)%pw,error=error) + CALL pw_release(rho_struct%tau_r(i)%pw) END DO DEALLOCATE(rho_struct%tau_r) END IF IF (ASSOCIATED(rho_struct%rho_g)) THEN DO i=1,SIZE(rho_struct%rho_g) - CALL pw_release(rho_struct%rho_g(i)%pw,error=error) + CALL pw_release(rho_struct%rho_g(i)%pw) END DO DEALLOCATE(rho_struct%rho_g) END IF IF (ASSOCIATED(rho_struct%tau_g)) THEN DO i=1,SIZE(rho_struct%tau_g) - CALL pw_release(rho_struct%tau_g(i)%pw,error=error) + CALL pw_release(rho_struct%tau_g(i)%pw) END DO DEALLOCATE(rho_struct%tau_g) END IF IF (ASSOCIATED(rho_struct%rho_r_sccs)) THEN - CALL pw_release(rho_struct%rho_r_sccs%pw,error=error) + CALL pw_release(rho_struct%rho_r_sccs%pw) DEALLOCATE(rho_struct%rho_r_sccs) END IF - CALL kpoint_transitional_release(rho_struct%rho_ao, error) + CALL kpoint_transitional_release(rho_struct%rho_ao) IF (ASSOCIATED(rho_struct%rho_ao_im))& - CALL cp_dbcsr_deallocate_matrix_set(rho_struct%rho_ao_im,error=error) + CALL cp_dbcsr_deallocate_matrix_set(rho_struct%rho_ao_im) IF (ASSOCIATED(rho_struct%tot_rho_r))& DEALLOCATE(rho_struct%tot_rho_r) IF (ASSOCIATED(rho_struct%tot_rho_g))& @@ -274,9 +264,6 @@ END SUBROUTINE qs_rho_clear !> \param tot_rho_g ... !> \param rho_r_sccs ... !> \param soft_valid ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> For the other inputs the qs_rho_type attributes !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed @@ -284,7 +271,7 @@ END SUBROUTINE qs_rho_clear SUBROUTINE qs_rho_get(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_r, drho_r, & rho_g, drho_g, tau_r, tau_g, rho_r_valid, drho_r_valid, rho_g_valid, & drho_g_valid, tau_r_valid, tau_g_valid, rebuild_each, tot_rho_r, tot_rho_g,& - rho_r_sccs, soft_valid, error) + rho_r_sccs, soft_valid) TYPE(qs_rho_type), POINTER :: rho_struct TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: rho_ao, rho_ao_im @@ -301,7 +288,6 @@ SUBROUTINE qs_rho_get(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_r, drho_r, & POINTER :: tot_rho_r, tot_rho_g TYPE(pw_p_type), OPTIONAL, POINTER :: rho_r_sccs LOGICAL, INTENT(out), OPTIONAL :: soft_valid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_get', & routineP = moduleN//':'//routineN @@ -310,8 +296,8 @@ SUBROUTINE qs_rho_get(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_r, drho_r, & failure=.FALSE. - CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,failure) + CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(rho_ao)) rho_ao => get_1d_pointer(rho_struct%rho_ao) IF (PRESENT(rho_ao_kp)) rho_ao_kp => get_2d_pointer(rho_struct%rho_ao) @@ -360,13 +346,12 @@ END SUBROUTINE qs_rho_get !> \param tot_rho_g ... !> \param rho_r_sccs ... !> \param soft_valid ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** SUBROUTINE qs_rho_set(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_r, drho_r, & rho_g, drho_g, tau_r, tau_g, rho_r_valid, drho_r_valid, rho_g_valid, & drho_g_valid, tau_r_valid, tau_g_valid, rebuild_each, tot_rho_r, tot_rho_g,& - rho_r_sccs, soft_valid, error) + rho_r_sccs, soft_valid) TYPE(qs_rho_type), POINTER :: rho_struct TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: rho_ao, rho_ao_im @@ -383,7 +368,6 @@ SUBROUTINE qs_rho_set(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_r, drho_r, & POINTER :: tot_rho_r, tot_rho_g TYPE(pw_p_type), OPTIONAL, POINTER :: rho_r_sccs LOGICAL, INTENT(in), OPTIONAL :: soft_valid - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_set', & routineP = moduleN//':'//routineN @@ -392,8 +376,8 @@ SUBROUTINE qs_rho_set(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_r, drho_r, & failure=.FALSE. - CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,failure) + CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(rho_ao)) CALL set_1d_pointer(rho_struct%rho_ao, rho_ao) IF (PRESENT(rho_ao_kp)) CALL set_2d_pointer(rho_struct%rho_ao, rho_ao_kp) diff --git a/src/qs_sccs.F b/src/qs_sccs.F index 0664e27d4d..308f4642f0 100644 --- a/src/qs_sccs.F +++ b/src/qs_sccs.F @@ -116,21 +116,19 @@ MODULE qs_sccs !> \param v_hartree_gspace ... !> \param v_sccs ... !> \param h_stress ... -!> \param error ... !> \par History: !> - Creation (10.10.2013,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) + SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_type), POINTER :: rho_tot_gspace, & v_hartree_gspace, v_sccs REAL(KIND=dp), DIMENSION(3, 3), & INTENT(OUT), OPTIONAL :: h_stress - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sccs', & routineP = moduleN//':'//routineN @@ -216,16 +214,15 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) para_env=para_env,& pw_env=pw_env,& rho=rho,& - scf_env=scf_env,& - error=error) - CALL cp_subsys_get(cp_subsys,particles=particles,error=error) + scf_env=scf_env) + CALL cp_subsys_get(cp_subsys,particles=particles) sccs_control => dft_control%sccs_control - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho_tot_gspace),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(v_hartree_gspace),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(v_sccs),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho_tot_gspace),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(v_hartree_gspace),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(v_sccs),cp_failure_level,routineP,failure) IF (PRESENT(h_stress)) THEN calculate_stress_tensor = .TRUE. @@ -240,10 +237,9 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) CALL pw_env_get(pw_env,& auxbas_pw_pool=auxbas_pw_pool,& pw_pools=pw_pools,& - poisson_env=poisson_env,& - error=error) + poisson_env=poisson_env) - CALL pw_zero(v_sccs,error=error) + CALL pw_zero(v_sccs) ! Calculate no SCCS contribution, if the requested SCF convergence threshold is not reached yet IF (.NOT.sccs_control%sccs_activated) THEN @@ -254,8 +250,7 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) CALL pw_poisson_solve(poisson_env=poisson_env,& density=rho_tot_gspace,& ehartree=energy%hartree,& - vhartree=v_hartree_gspace,& - error=error) + vhartree=v_hartree_gspace) energy%sccs_pol = 0.0_dp energy%sccs_cav = 0.0_dp energy%sccs_dis = 0.0_dp @@ -270,16 +265,15 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) nspin = dft_control%nspins ! Manage print output control - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() print_level = logger%iter_info%print_level print_path = "DFT%PRINT%SCCS" should_output = (BTEST(cp_print_key_should_output(logger%iter_info,input,& - TRIM(print_path),error=error),cp_p_file)) + TRIM(print_path)),cp_p_file)) output_unit = cp_print_key_unit_nr(logger,input,TRIM(print_path),& extension=".sccs",& ignore_should_output=should_output,& - log_filename=.FALSE.,& - error=error) + log_filename=.FALSE.) ! Get work storage for the 3d grids in r-space DO i=1,SIZE(work_r3d) @@ -287,8 +281,7 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) CALL pw_pool_create_pw(auxbas_pw_pool,& work_r3d(i)%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) END DO ! Assign total electronic density in r-space @@ -305,17 +298,16 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) ! Get rho CALL qs_rho_get(rho_struct=rho,& rho_r=rho_r,& - rho_r_sccs=rho_r_sccs,& - error=error) + rho_r_sccs=rho_r_sccs) ! Retrieve the last rho_iter from the previous SCCS cycle if available - CPPrecondition(ASSOCIATED(rho_r_sccs),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_r_sccs),cp_failure_level,routineP,failure) rho_iter_old => rho_r_sccs%pw ! Retrieve the total electronic density in r-space - CALL pw_copy(rho_r(1)%pw,rho_elec,error=error) + CALL pw_copy(rho_r(1)%pw,rho_elec) DO ispin=2,nspin - CALL pw_axpy(rho_r(ispin)%pw,rho_elec,error=error) + CALL pw_axpy(rho_r(ispin)%pw,rho_elec) END DO tot_rho_elec = accurate_sum(rho_elec%cr3d)*dvol CALL mp_sum(tot_rho_elec,para_env%group) @@ -340,24 +332,22 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) ! Optional output of the dielectric function in cube file format filename = "DIELECTRIC_FUNCTION" cube_path = TRIM(print_path)//"%"//TRIM(filename) - IF (BTEST(cp_print_key_should_output(logger%iter_info,input,TRIM(cube_path),error=error),& + IF (BTEST(cp_print_key_should_output(logger%iter_info,input,TRIM(cube_path)),& cp_p_file)) THEN - append_cube = section_get_lval(input,TRIM(cube_path)//"%APPEND",error=error) + append_cube = section_get_lval(input,TRIM(cube_path)//"%APPEND") my_pos_cube="REWIND" IF (append_cube) my_pos_cube="APPEND" cube_unit = cp_print_key_unit_nr(logger,input,TRIM(cube_path),& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,& - error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit > 0) THEN INQUIRE (UNIT=cube_unit,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& "The dielectric function is written in cube file format to the file:",TRIM(filename) END IF CALL cp_pw_to_cube(eps_elec,cube_unit,TRIM(filename),particles=particles,& - stride=section_get_ivals(input,TRIM(cube_path)//"%STRIDE",error=error),& - error=error) - CALL cp_print_key_finished_output(cube_unit,logger,input,TRIM(cube_path),error=error) + stride=section_get_ivals(input,TRIM(cube_path)//"%STRIDE")) + CALL cp_print_key_finished_output(cube_unit,logger,input,TRIM(cube_path)) END IF ! Calculate the (quantum) volume and surface of the solute cavity @@ -368,7 +358,7 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) ! Initialise the switching function theta theta => work_r3d(4)%pw - CALL pw_zero(theta,error=error) + CALL pw_zero(theta) ! Calculate the (quantum) volume of the solute cavity f = 1.0_dp/(eps0 - 1.0_dp) @@ -393,10 +383,9 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) CALL pw_pool_create_pw(auxbas_pw_pool,& drho_elec(i)%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) END DO - CALL derive(rho_elec,drho_elec,sccs_derivative_fft,pw_env,input,para_env,error) + CALL derive(rho_elec,drho_elec,sccs_derivative_fft,pw_env,input,para_env) ! Calculate the norm of the gradient of the electronic density in r-space norm_drho_elec => work_r3d(5)%pw @@ -420,24 +409,22 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) ! Optional output of the norm of the density gradient in cube file format filename = "DENSITY_GRADIENT" cube_path = TRIM(print_path)//"%"//TRIM(filename) - IF (BTEST(cp_print_key_should_output(logger%iter_info,input,TRIM(cube_path),error=error),& + IF (BTEST(cp_print_key_should_output(logger%iter_info,input,TRIM(cube_path)),& cp_p_file)) THEN - append_cube = section_get_lval(input,TRIM(cube_path)//"%APPEND",error=error) + append_cube = section_get_lval(input,TRIM(cube_path)//"%APPEND") my_pos_cube="REWIND" IF (append_cube) my_pos_cube="APPEND" cube_unit = cp_print_key_unit_nr(logger,input,TRIM(cube_path),& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,& - error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit > 0) THEN INQUIRE (UNIT=cube_unit,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& "The norm of the density gradient is written in cube file format to the file:",TRIM(filename) END IF CALL cp_pw_to_cube(norm_drho_elec,cube_unit,TRIM(filename),particles=particles,& - stride=section_get_ivals(input,TRIM(cube_path)//"%STRIDE",error=error),& - error=error) - CALL cp_print_key_finished_output(cube_unit,logger,input,TRIM(cube_path),error=error) + stride=section_get_ivals(input,TRIM(cube_path)//"%STRIDE")) + CALL cp_print_key_finished_output(cube_unit,logger,input,TRIM(cube_path)) END IF ! Calculate the (quantum) surface of the solute cavity @@ -472,11 +459,10 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) CALL pw_pool_create_pw(auxbas_pw_pool,& d2rho_elec(dj,di)%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) END DO CALL derive(drho_elec(di)%pw,d2rho_elec(:,di),sccs_derivative_fft,pw_env,& - input,para_env,error) + input,para_env) END DO ! Calculate the contribution of the cavitation energy to the Kohn-Sham potential @@ -501,22 +487,22 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) END DO END DO !$omp end parallel do - CALL pw_scale(v_sccs,dvol,error=error) + CALL pw_scale(v_sccs,dvol) END IF ! Release storage NULLIFY (theta) DO i=1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_elec(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_elec(i)%pw) END DO END IF ! Retrieve the total charge density (core + elec) of the solute in r-space rho_solute => work_r3d(4)%pw - CALL pw_zero(rho_solute,error=error) - CALL pw_transfer(rho_tot_gspace,rho_solute,error=error) + CALL pw_zero(rho_solute) + CALL pw_transfer(rho_tot_gspace,rho_solute) tot_rho_solute = accurate_sum(rho_solute%cr3d)*dvol CALL mp_sum(tot_rho_solute,para_env%group) @@ -556,11 +542,10 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) CALL pw_pool_create_pw(auxbas_pw_pool,& dln_eps_elec(i)%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_zero(dln_eps_elec(i)%pw,error=error) + in_space=REALSPACE) + CALL pw_zero(dln_eps_elec(i)%pw) END DO - CALL derive(ln_eps_elec,dln_eps_elec,sccs_control%derivative_method,pw_env,input,para_env,error) + CALL derive(ln_eps_elec,dln_eps_elec,sccs_control%derivative_method,pw_env,input,para_env) ! Print header for the SCCS cycle IF (should_output.AND.(output_unit > 0)) THEN @@ -571,13 +556,13 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) WRITE (UNIT=output_unit,FMT="(T3,A,T56,F25.3)")& "SCCS| Surface of the solute cavity [bohr^2]",cavity_surface,& "SCCS| [angstrom^2]",& - cp_unit_from_cp2k(cavity_surface,"angstrom^2",error=error),& + cp_unit_from_cp2k(cavity_surface,"angstrom^2"),& "SCCS| Volume of the solute cavity [bohr^3]",cavity_volume,& "SCCS| [angstrom^3]",& - cp_unit_from_cp2k(cavity_volume,"angstrom^3",error=error),& + cp_unit_from_cp2k(cavity_volume,"angstrom^3"),& "SCCS| Volume of the cell [bohr^3]",cell_volume,& "SCCS| [angstrom^3]",& - cp_unit_from_cp2k(cell_volume,"angstrom^3",error=error) + cp_unit_from_cp2k(cell_volume,"angstrom^3") WRITE (UNIT=output_unit,FMT="(T3,A)")& "SCCS|",& "SCCS| Step Average residual Maximum residual" @@ -590,8 +575,7 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) CALL pw_pool_create_pw(auxbas_pw_pool,& dphi_tot(i)%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) + in_space=REALSPACE) END DO ! Reassign work storage to rho_tot, because ln_eps_elec is no longer needed @@ -599,8 +583,8 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) NULLIFY (ln_eps_elec) ! Initialise the total electronic density in r-space rho_tot with rho_tot_zero + rho_iter_zero - CALL pw_copy(rho_tot_zero,rho_tot,error=error) - CALL pw_axpy(rho_iter_old,rho_tot,error=error) + CALL pw_copy(rho_tot_zero,rho_tot) + CALL pw_axpy(rho_iter_old,rho_tot) ! Main SCCS iteration loop iter = 0 @@ -623,8 +607,7 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) ! Calculate derivative of the current total potential in r-space CALL pw_poisson_solve(poisson_env=poisson_env,& density=rho_tot,& - dvhartree=dphi_tot,& - error=error) + dvhartree=dphi_tot) ! Update total charge density (solute plus polarisation) in r-space ! based on the iterated polarisation charge density @@ -685,70 +668,65 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) ! Calculate the total Hartree energy, potential, and its derivatives of ! the solute and the implicit solvent - CALL pw_transfer(rho_tot,rho_tot_gspace,error=error) + CALL pw_transfer(rho_tot,rho_tot_gspace) IF (calculate_stress_tensor) THEN CALL pw_poisson_solve(poisson_env=poisson_env,& density=rho_tot_gspace,& ehartree=energy%sccs_hartree,& vhartree=v_hartree_gspace,& dvhartree=dphi_tot,& - h_stress=h_stress,& - error=error) + h_stress=h_stress) ELSE CALL pw_poisson_solve(poisson_env=poisson_env,& density=rho_tot_gspace,& ehartree=energy%sccs_hartree,& vhartree=v_hartree_gspace,& - dvhartree=dphi_tot,& - error=error) + dvhartree=dphi_tot) END IF phi_pol => work_r3d(5)%pw - CALL pw_transfer(v_hartree_gspace,phi_pol,error=error) + CALL pw_transfer(v_hartree_gspace,phi_pol) ! Calculate the Hartree energy and potential of the solute only phi_solute => rho_tot_zero - CALL pw_zero(phi_solute,error=error) + CALL pw_zero(phi_solute) NULLIFY (rho_tot_zero) CALL pw_poisson_solve(poisson_env=poisson_env,& density=rho_solute,& ehartree=energy%hartree,& - vhartree=phi_solute,& - error=error) + vhartree=phi_solute) ! Calculate the polarisation potential ! phi_pol = phi_tot - phi_solute - CALL pw_axpy(phi_solute,phi_pol,alpha=-1.0_dp,error=error) + CALL pw_axpy(phi_solute,phi_pol,alpha=-1.0_dp) ! Calculate the polarisation charge ! rho_pol = rho_tot - rho_solute - CALL pw_axpy(rho_solute,rho_tot,alpha=-1.0_dp,error=error) + CALL pw_axpy(rho_solute,rho_tot,alpha=-1.0_dp) polarisation_charge = accurate_sum(rho_tot%cr3d)*dvol CALL mp_sum(polarisation_charge,para_env%group) filename = "POLARISATION_POTENTIAL" cube_path = TRIM(print_path)//"%"//TRIM(filename) - IF (BTEST(cp_print_key_should_output(logger%iter_info,input,TRIM(cube_path),error=error),& + IF (BTEST(cp_print_key_should_output(logger%iter_info,input,TRIM(cube_path)),& cp_p_file)) THEN - append_cube = section_get_lval(input,TRIM(cube_path)//"%APPEND",error=error) + append_cube = section_get_lval(input,TRIM(cube_path)//"%APPEND") my_pos_cube="REWIND" IF (append_cube) my_pos_cube="APPEND" cube_unit = cp_print_key_unit_nr(logger,input,TRIM(cube_path),& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,& - error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit > 0) THEN INQUIRE (UNIT=cube_unit,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& "The SCCS polarisation potential is written in cube file format to the file:",TRIM(filename) END IF CALL cp_pw_to_cube(phi_pol,cube_unit,TRIM(filename),particles=particles,& - stride=section_get_ivals(input,TRIM(cube_path)//"%STRIDE",error=error),& - error=error) - CALL cp_print_key_finished_output(cube_unit,logger,input,TRIM(cube_path),error=error) + stride=section_get_ivals(input,TRIM(cube_path)//"%STRIDE")) + CALL cp_print_key_finished_output(cube_unit,logger,input,TRIM(cube_path)) END IF ! Calculate SCCS polarisation energy - energy%sccs_pol = 0.5_dp*pw_integral_ab(rho_solute,phi_pol,error=error) + energy%sccs_pol = 0.5_dp*pw_integral_ab(rho_solute,phi_pol) ! Calculate the Makov-Payne energy correction for charged systems with PBC ! Madelung energy of a simple cubic lattice of point charges immersed in neutralising jellium @@ -770,19 +748,19 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) WRITE (UNIT=output_unit,FMT="(T3,A,T56,F25.12,/,T3,A,T61,F20.3)")& "SCCS| Polarisation energy [Hartree]",energy%sccs_pol,& "SCCS| [kcal/mol]",& - cp_unit_from_cp2k(energy%sccs_pol,"kcalmol",error=error),& + cp_unit_from_cp2k(energy%sccs_pol,"kcalmol"),& "SCCS| Makov-Payne correction [Hartree]",energy%sccs_mpc,& "SCCS| [kcal/mol]",& - cp_unit_from_cp2k(energy%sccs_mpc,"kcalmol",error=error),& + cp_unit_from_cp2k(energy%sccs_mpc,"kcalmol"),& "SCCS| Cavitation energy [Hartree]",energy%sccs_cav,& "SCCS| [kcal/mol]",& - cp_unit_from_cp2k(energy%sccs_cav,"kcalmol",error=error),& + cp_unit_from_cp2k(energy%sccs_cav,"kcalmol"),& "SCCS| Dispersion free energy [Hartree]",energy%sccs_dis,& "SCCS| [kcal/mol]",& - cp_unit_from_cp2k(energy%sccs_dis,"kcalmol",error=error),& + cp_unit_from_cp2k(energy%sccs_dis,"kcalmol"),& "SCCS| Repulsion free energy [Hartree]",energy%sccs_rep,& "SCCS| [kcal/mol]",& - cp_unit_from_cp2k(energy%sccs_rep,"kcalmol",error=error) + cp_unit_from_cp2k(energy%sccs_rep,"kcalmol") END IF ! Calculate SCCS contribution to the Kohn-Sham potential @@ -809,17 +787,16 @@ SUBROUTINE sccs(qs_env,rho_tot_gspace,v_hartree_gspace,v_sccs,h_stress,error) NULLIFY (deps_elec) NULLIFY (rho_solute) DO i=1,SIZE(work_r3d) - CALL pw_pool_give_back_pw(auxbas_pw_pool,work_r3d(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,work_r3d(i)%pw) END DO DO i=1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,dln_eps_elec(i)%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,dphi_tot(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dln_eps_elec(i)%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,dphi_tot(i)%pw) END DO ! Release the SCCS printout environment CALL cp_print_key_finished_output(output_unit,logger,input,TRIM(print_path),& - ignore_should_output=should_output,& - error=error) + ignore_should_output=should_output) CALL timestop(handle) @@ -981,13 +958,12 @@ END SUBROUTINE fattebert_gygi !> \param pw_env ... !> \param input ... !> \param para_env ... -!> \param error ... !> \par History: !> - Creation (15.11.2013,MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE derive(f,df,method,pw_env,input,para_env,error) + SUBROUTINE derive(f,df,method,pw_env,input,para_env) TYPE(pw_type), POINTER :: f TYPE(pw_p_type), DIMENSION(3), & @@ -996,7 +972,6 @@ SUBROUTINE derive(f,df,method,pw_env,input,para_env,error) TYPE(pw_env_type), POINTER :: pw_env TYPE(section_vals_type), POINTER :: input TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'derive', & routineP = moduleN//':'//routineN @@ -1015,16 +990,16 @@ SUBROUTINE derive(f,df,method,pw_env,input,para_env,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(f),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) ! Perform method specific setup SELECT CASE (method) CASE (sccs_derivative_cd3,sccs_derivative_cd5,sccs_derivative_cd7) NULLIFY (rs_desc) NULLIFY (rs_grid) - rs_grid_section => section_vals_get_subs_vals(input,"DFT%MGRID%RS_GRID",error=error) + rs_grid_section => section_vals_get_subs_vals(input,"DFT%MGRID%RS_GRID") SELECT CASE (method) CASE (sccs_derivative_cd3) border_points = 1 @@ -1034,44 +1009,43 @@ SUBROUTINE derive(f,df,method,pw_env,input,para_env,error) border_points = 3 END SELECT CALL init_input_type(input_settings,2*border_points+1,rs_grid_section,& - 1,(/-1,-1,-1/),error) + 1,(/-1,-1,-1/)) CALL rs_grid_create_descriptor(rs_desc,f%pw_grid,input_settings,& - border_points=border_points,error=error) - CALL rs_grid_create(rs_grid,rs_desc,error=error) -!MK CALL rs_grid_print(rs_grid,6,error=error) + border_points=border_points) + CALL rs_grid_create(rs_grid,rs_desc) +!MK CALL rs_grid_print(rs_grid,6) CASE (sccs_derivative_fft) lb(1:3) = f%pw_grid%bounds_local(1,1:3) ub(1:3) = f%pw_grid%bounds_local(2,1:3) NULLIFY (auxbas_pw_pool) - CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool) ! Get work storage for the 1d grids in g-space (derivative calculation) DO i=1,SIZE(work_g1d) NULLIFY (work_g1d(i)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,& work_g1d(i)%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) END DO END SELECT ! Calculate the derivatives SELECT CASE (method) CASE (sccs_derivative_cd3) - CALL derive_fdm_cd3(f,df,rs_grid,error) + CALL derive_fdm_cd3(f,df,rs_grid) CASE (sccs_derivative_cd5) - CALL derive_fdm_cd5(f,df,rs_grid,error) + CALL derive_fdm_cd5(f,df,rs_grid) CASE (sccs_derivative_cd7) - CALL derive_fdm_cd7(f,df,rs_grid,error) + CALL derive_fdm_cd7(f,df,rs_grid) CASE (sccs_derivative_fft) ! FFT - CALL pw_transfer(f,work_g1d(1)%pw,error=error) + CALL pw_transfer(f,work_g1d(1)%pw) DO i=1,3 n(:) = 0 n(i) = 1 - CALL pw_copy(work_g1d(1)%pw,work_g1d(2)%pw,error=error) - CALL pw_derive(work_g1d(2)%pw,n(:),error=error) - CALL pw_transfer(work_g1d(2)%pw,df(i)%pw,error=error) + CALL pw_copy(work_g1d(1)%pw,work_g1d(2)%pw) + CALL pw_derive(work_g1d(2)%pw,n(:)) + CALL pw_transfer(work_g1d(2)%pw,df(i)%pw) END DO CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,& @@ -1082,11 +1056,11 @@ SUBROUTINE derive(f,df,method,pw_env,input,para_env,error) ! Perform method specific cleanup SELECT CASE (method) CASE (sccs_derivative_cd3,sccs_derivative_cd5,sccs_derivative_cd7) - CALL rs_grid_release(rs_grid,error=error) - CALL rs_grid_release_descriptor(rs_desc,error=error) + CALL rs_grid_release(rs_grid) + CALL rs_grid_release_descriptor(rs_desc) CASE (sccs_derivative_fft) DO i=1,SIZE(work_g1d) - CALL pw_pool_give_back_pw(auxbas_pw_pool,work_g1d(i)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,work_g1d(i)%pw) END DO END SELECT diff --git a/src/qs_scf.F b/src/qs_scf.F index dc4b0155e3..9622ed9fc4 100644 --- a/src/qs_scf.F +++ b/src/qs_scf.F @@ -149,16 +149,13 @@ MODULE qs_scf ! ***************************************************************************** !> \brief perform an scf procedure in the given qs_env !> \param qs_env the qs_environment where to perform the scf procedure -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 introduced scf_env, moved real work to scf_env_do_scf [fawzi] !> \author fawzi !> \note ! ***************************************************************************** - SUBROUTINE scf(qs_env,error) + SUBROUTINE scf(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf', & routineP = moduleN//':'//routineN @@ -176,23 +173,23 @@ SUBROUTINE scf(qs_env,error) NULLIFY(scf_env) failure=.FALSE. - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env,scf_env=scf_env,error=error,input=input, & + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env,scf_env=scf_env,input=input, & dft_control=dft_control,scf_control=scf_control) IF(scf_control%max_scf > 0) THEN - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) - scf_section => section_vals_get_subs_vals(dft_section,"SCF",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") + scf_section => section_vals_get_subs_vals(dft_section,"SCF") IF(.NOT. ASSOCIATED(scf_env)) THEN - CALL qs_scf_env_initialize(qs_env,scf_env,error=error) + CALL qs_scf_env_initialize(qs_env,scf_env) ! Moved here from qs_scf_env_initialize to be able to have more scf_env - CALL set_qs_env(qs_env,scf_env=scf_env,error=error) - CALL scf_env_release(scf_env,error=error) - CALL get_qs_env(qs_env=qs_env,scf_env=scf_env,error=error) + CALL set_qs_env(qs_env,scf_env=scf_env) + CALL scf_env_release(scf_env) + CALL get_qs_env(qs_env=qs_env,scf_env=scf_env) ELSE - CALL qs_scf_env_initialize(qs_env,scf_env,error=error) + CALL qs_scf_env_initialize(qs_env,scf_env) ENDIF IF ((scf_control%density_guess .EQ. history_guess) .AND. (first_step_flag)) THEN @@ -203,13 +200,13 @@ SUBROUTINE scf(qs_env,error) END IF CALL scf_env_do_scf(scf_env=scf_env, scf_control=scf_control, qs_env=qs_env, & - converged=converged, should_stop=should_stop, error=error) + converged=converged, should_stop=should_stop) ! *** add the converged wavefunction to the wavefunction history IF ((ASSOCIATED(qs_env%wf_history)) .AND. & ((scf_control%density_guess .NE. history_guess) .OR. & (.NOT. first_step_flag))) THEN - CALL wfi_update(qs_env%wf_history,qs_env=qs_env,dt=1.0_dp, error=error) + CALL wfi_update(qs_env%wf_history,qs_env=qs_env,dt=1.0_dp) ELSE IF ((scf_control%density_guess .EQ. history_guess) .AND. & (first_step_flag)) THEN scf_control%max_scf = max_scf_tmp @@ -218,10 +215,10 @@ SUBROUTINE scf(qs_env,error) END IF ! *** compute properties that depend on the converged wavefunction - IF (.NOT.(should_stop)) CALL qs_scf_compute_properties(qs_env,dft_section,error) + IF (.NOT.(should_stop)) CALL qs_scf_compute_properties(qs_env,dft_section) ! *** cleanup - CALL scf_env_cleanup(scf_env,error=error) + CALL scf_env_cleanup(scf_env) END IF @@ -234,8 +231,6 @@ END SUBROUTINE scf !> \param qs_env the qs_env, the scf_env lives in !> \param converged will be true / false if converged is reached !> \param should_stop ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> long history, see cvs and qs_scf module history !> 02.2003 introduced scf_env [fawzi] @@ -244,13 +239,12 @@ END SUBROUTINE scf !> \author Matthias Krack !> \note ! ***************************************************************************** - SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error) + SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(OUT) :: converged, should_stop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scf_env_do_scf', & routineP = moduleN//':'//routineN @@ -296,12 +290,12 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error particle_set,dft_section,input,& scf_section, para_env, results, kpoints, pw_env, rho_ao_kp) - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() t1 = m_walltime() CALL get_qs_env(qs_env=qs_env,& @@ -319,16 +313,15 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error kpoints=kpoints,& results=results,& pw_env=pw_env,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) - scf_section => section_vals_get_subs_vals(dft_section,"SCF",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") + scf_section => section_vals_get_subs_vals(dft_section,"SCF") output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit>0) WRITE (UNIT=output_unit,FMT="(/,/,T2,A)") & "SCF WAVEFUNCTION OPTIMIZATION" @@ -339,20 +332,20 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error "Step","Update method","Time","Convergence","Total energy","Change",& REPEAT("-",78) END IF - CALL cp_add_iter_level(logger%iter_info,"QS_SCF",error=error) + CALL cp_add_iter_level(logger%iter_info,"QS_SCF") ! check for external communicator and if the inermediate energy should be sended res_val_3(:) = -1.0_dp description = "[EXT_SCF_ENER_COMM]" - IF(test_for_result(results,description=description, error=error)) THEN + IF(test_for_result(results,description=description)) THEN CALL get_results(results, description=description,& - values=res_val_3, n_entries=i_tmp, error=error) - CPPostcondition(i_tmp.EQ.3,cp_failure_level,routineP,error,failure) + values=res_val_3, n_entries=i_tmp) + CPPostcondition(i_tmp.EQ.3,cp_failure_level,routineP,failure) CALL cp_assert(ANY(res_val_3(:).GT.0.0),cp_failure_level,& cp_assertion_failed,routineP,& " Trying to access result ("//TRIM(description)//& ") which is not correctly stored. ",& - error, only_ionode=.TRUE.) + only_ionode=.TRUE.) END IF external_comm = NINT(res_val_3(1)) ext_master_id = NINT(res_val_3(2)) @@ -368,10 +361,10 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error scf_outer_loop: DO CALL init_scf_loop(scf_env=scf_env, qs_env=qs_env, & - scf_section=scf_section, error=error) + scf_section=scf_section) CALL qs_scf_set_loop_flags(scf_env,diis_step,& - energy_only,just_energy,exit_inner_loop,error=error) + energy_only,just_energy,exit_inner_loop) scf_loop: DO @@ -379,7 +372,7 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error scf_env%iter_count = scf_env%iter_count + 1 iter_count = iter_count + 1 - CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_count,error=error) + CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_count) IF (output_unit > 0) CALL m_flush(output_unit) @@ -387,23 +380,23 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error just_energy = energy_only CALL qs_ks_update_qs_env(qs_env, just_energy=just_energy,& - calculate_forces=.FALSE., error=error) + calculate_forces=.FALSE.) ! print 'heavy weight' or relatively expensive quantities - CALL qs_scf_loop_print(qs_env,scf_env,para_env,error=error) + CALL qs_scf_loop_print(qs_env,scf_env,para_env) IF(do_kpoints) THEN ! kpoints - CALL qs_scf_new_mos_kp(qs_env,scf_env,scf_control,diis_step,error=error) + CALL qs_scf_new_mos_kp(qs_env,scf_env,scf_control,diis_step) ELSE ! Gamma points only - CALL qs_scf_new_mos(qs_env,scf_env,scf_control,scf_section,diis_step,energy_only,error=error) + CALL qs_scf_new_mos(qs_env,scf_env,scf_control,scf_section,diis_step,energy_only) END IF ! another heavy weight print object, print controlled by dft_section - CALL qs_scf_write_mos(mos,atomic_kind_set,qs_kind_set,particle_set,dft_section,error=error) + CALL qs_scf_write_mos(mos,atomic_kind_set,qs_kind_set,particle_set,dft_section) - CALL qs_scf_density_mixing(scf_env,rho,para_env,diis_step,do_kpoints,error=error) + CALL qs_scf_density_mixing(scf_env,rho,para_env,diis_step,do_kpoints) t2 = m_walltime() @@ -417,26 +410,26 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error END IF CALL qs_scf_check_inner_exit(qs_env,scf_env,scf_control,should_stop,exit_inner_loop,& - inner_loop_converged,output_unit,error) + inner_loop_converged,output_unit) ! In case we decide to exit we perform few more check to see if this one ! is really the last SCF step IF (exit_inner_loop) THEN - CALL qs_scf_inner_finalize(scf_env,qs_env,diis_step,output_unit,error) + CALL qs_scf_inner_finalize(scf_env,qs_env,diis_step,output_unit) CALL qs_scf_check_outer_exit(qs_env,scf_env,scf_control,should_stop,& - outer_loop_converged,exit_outer_loop,error) + outer_loop_converged,exit_outer_loop) ! Let's tag the last SCF cycle so we can print informations only of the last step - IF (exit_outer_loop) CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=iter_count,error=error) + IF (exit_outer_loop) CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=iter_count) END IF ! Write WaveFunction restart file CALL write_mo_set(mos,particle_set,dft_section=dft_section,& atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& - kpoints=kpoints,error=error) + kpoints=kpoints) ! Exit if we have finished with the SCF inner loop IF (exit_inner_loop) THEN @@ -445,7 +438,7 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error END IF IF (.NOT.BTEST(cp_print_key_should_output(logger%iter_info,& - scf_section,"PRINT%ITERATION_INFO/TIME_CUMUL",error=error),cp_p_file)) & + scf_section,"PRINT%ITERATION_INFO/TIME_CUMUL"),cp_p_file)) & t1 = m_walltime() ! mixing methods have the new density matrix in p_mix_new @@ -453,13 +446,13 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error DO ic=1,SIZE(rho_ao_kp,2) DO ispin=1,dft_control%nspins CALL cp_dbcsr_copy(rho_ao_kp(ispin,ic)%matrix,scf_env%p_mix_new(ispin,ic)%matrix,& - name=TRIM(cp_dbcsr_name(rho_ao_kp(ispin,ic)%matrix)),error=error) + name=TRIM(cp_dbcsr_name(rho_ao_kp(ispin,ic)%matrix))) END DO END DO END IF CALL qs_scf_rho_update(rho,qs_env,scf_env,ks_env,& - mix_rho=scf_env%mixing_method>=gspace_mixing_nr,error=error) + mix_rho=scf_env%mixing_method>=gspace_mixing_nr) CALL timestop(handle2) @@ -473,9 +466,9 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error IF (exit_outer_loop) EXIT scf_outer_loop - CALL outer_loop_optimize(scf_env,scf_control,error) - CALL outer_loop_update_qs_env(qs_env,scf_env,error) - CALL qs_ks_did_change(ks_env,potential_changed=.TRUE.,error=error) + CALL outer_loop_optimize(scf_env,scf_control) + CALL outer_loop_update_qs_env(qs_env,scf_env) + CALL qs_ks_did_change(ks_env,potential_changed=.TRUE.) END DO scf_outer_loop @@ -487,18 +480,18 @@ SUBROUTINE scf_env_do_scf(scf_env,scf_control,qs_env,converged,should_stop,error IF (.NOT.ASSOCIATED(mos(ispin)%mo_set%mo_coeff_b)) &!fm->dbcsr CALL stop_program(routineN,moduleN,__LINE__,"mo_coeff_b is not allocated")!fm->dbcsr CALL copy_dbcsr_to_fm(mos(ispin)%mo_set%mo_coeff_b, &!fm->dbcsr - mos(ispin)%mo_set%mo_coeff,error=error)!fm -> dbcsr + mos(ispin)%mo_set%mo_coeff)!fm -> dbcsr ENDIF!fm->dbcsr ENDDO!fm -> dbcsr IF(dft_control%qs_control%becke_restraint)THEN - CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_give_back_pw(auxbas_pw_pool,& - dft_control%qs_control%becke_control%becke_pot%pw,error=error) + dft_control%qs_control%becke_control%becke_pot%pw) dft_control%qs_control%becke_control%need_pot=.TRUE. END IF - CALL cp_rm_iter_level(logger%iter_info,level_name="QS_SCF",error=error) + CALL cp_rm_iter_level(logger%iter_info,level_name="QS_SCF") CALL timestop(handle) END SUBROUTINE scf_env_do_scf @@ -510,16 +503,14 @@ END SUBROUTINE scf_env_do_scf !> \param scf_env ... !> \param qs_env ... !> \param scf_section ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) + SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_scf_loop', & routineP = moduleN//':'//routineN @@ -543,27 +534,27 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env,& scf_control=scf_control,& dft_control=dft_control,& - mos=mos,error=error) + mos=mos) ! if using mo_coeff_b then copy to fm DO ispin=1,SIZE(mos)!fm->dbcsr IF(mos(1)%mo_set%use_mo_coeff_b)THEN!fm->dbcsr - CALL copy_dbcsr_to_fm(mos(ispin)%mo_set%mo_coeff_b,mos(ispin)%mo_set%mo_coeff,error=error)!fm->dbcsr + CALL copy_dbcsr_to_fm(mos(ispin)%mo_set%mo_coeff_b,mos(ispin)%mo_set%mo_coeff)!fm->dbcsr ENDIF!fm->dbcsr ENDDO!fm->dbcsr ! this just guarantees that all mo_occupations match the eigenvalues, if smear DO ispin=1,dft_control%nspins CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,& - smear=scf_control%smear, error=error) + smear=scf_control%smear) ENDDO SELECT CASE (scf_env%method) @@ -571,51 +562,51 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown scf method method:"//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) CASE (filter_matrix_diag_method_nr) IF(.NOT.scf_env%skip_diis) THEN IF (.NOT.ASSOCIATED(scf_env%scf_diis_buffer)) THEN - CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis,error=error) + CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis) END IF - CALL qs_diis_b_clear(scf_env%scf_diis_buffer,error=error) + CALL qs_diis_b_clear(scf_env%scf_diis_buffer) END IF CASE (general_diag_method_nr,special_diag_method_nr,block_krylov_diag_method_nr) IF(.NOT.scf_env%skip_diis) THEN IF (.NOT.ASSOCIATED(scf_env%scf_diis_buffer)) THEN - CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis,error=error) + CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis) END IF - CALL qs_diis_b_clear(scf_env%scf_diis_buffer,error=error) + CALL qs_diis_b_clear(scf_env%scf_diis_buffer) END IF CASE (ot_diag_method_nr) - CALL get_qs_env(qs_env, matrix_ks=matrix_ks, matrix_s=matrix_s, error=error) + CALL get_qs_env(qs_env, matrix_ks=matrix_ks, matrix_s=matrix_s) IF(.NOT.scf_env%skip_diis) THEN IF (.NOT.ASSOCIATED(scf_env%scf_diis_buffer)) THEN - CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis,error=error) + CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis) END IF - CALL qs_diis_b_clear(scf_env%scf_diis_buffer,error=error) + CALL qs_diis_b_clear(scf_env%scf_diis_buffer) END IF ! disable DFTB and SE for now IF (dft_control%qs_control%dftb .OR. dft_control%qs_control%semi_empirical) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"DFTB and SE not available with OT/DIAG",error,failure) + routineP,"DFTB and SE not available with OT/DIAG",failure) END IF ! if an old preconditioner is still around (i.e. outer SCF is active), ! remove it if this could be worthwhile CALL restart_preconditioner(qs_env,scf_env%ot_preconditioner,& scf_control%diagonalization%ot_settings%preconditioner_type,& - dft_control%nspins,error=error) + dft_control%nspins) CALL prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,scf_env%ot_preconditioner,& scf_control%diagonalization%ot_settings%preconditioner_type,& scf_control%diagonalization%ot_settings%precond_solver_type,& - scf_control%diagonalization%ot_settings%energy_gap,dft_control%nspins,error=error) + scf_control%diagonalization%ot_settings%energy_gap,dft_control%nspins) CASE (block_davidson_diag_method_nr) ! Preconditioner initialized within the loop, when required @@ -623,8 +614,7 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) CALL get_qs_env(qs_env,& has_unit_metric=has_unit_metric,& matrix_s=matrix_s,& - matrix_ks=matrix_ks,& - error=error) + matrix_ks=matrix_ks) ! reortho the wavefunctions if we are having an outer scf and ! this is not the first iteration @@ -636,9 +626,9 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) DO ispin=1,dft_control%nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set, mo_coeff=mo_coeff, nmo=nmo) IF (has_unit_metric) THEN - CALL make_basis_simple(mo_coeff,nmo,error=error) + CALL make_basis_simple(mo_coeff,nmo) ELSE - CALL make_basis_sm(mo_coeff,nmo,matrix_s(1)%matrix,error=error) + CALL make_basis_sm(mo_coeff,nmo,matrix_s(1)%matrix) ENDIF ENDDO ENDIF @@ -654,10 +644,10 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) IF (dft_control%restricted) number_of_OT_envs=1 ALLOCATE(scf_env%qs_ot_env(number_of_OT_envs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! XXX Joost XXX should disentangle reading input from this part - CALL ot_scf_read_input(scf_env%qs_ot_env,scf_section,error) + CALL ot_scf_read_input(scf_env%qs_ot_env,scf_section) ! keep a note that we are restricted IF (dft_control%restricted) THEN @@ -674,13 +664,13 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) ! might need the KS matrix to init properly CALL qs_ks_update_qs_env(qs_env, just_energy=.FALSE.,& - calculate_forces=.FALSE., error=error) + calculate_forces=.FALSE.) ! if an old preconditioner is still around (i.e. outer SCF is active), ! remove it if this could be worthwhile CALL restart_preconditioner(qs_env,scf_env%ot_preconditioner,& scf_env%qs_ot_env(1)%settings%preconditioner_type,& - dft_control%nspins,error=error) + dft_control%nspins) ! ! preconditioning still needs to be done correctly with has_unit_metric @@ -700,12 +690,11 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) scf_env%qs_ot_env(1)%settings%precond_solver_type,& scf_env%qs_ot_env(1)%settings%energy_gap,dft_control%nspins,& has_unit_metric=has_unit_metric,& - mixed_precision=scf_env%qs_ot_env(1)%settings%mixed_precision,error=error) + mixed_precision=scf_env%qs_ot_env(1)%settings%mixed_precision) CALL ot_scf_init(mo_array = mos, matrix_s = orthogonality_metric, & broyden_adaptive_sigma=qs_env%broyden_adaptive_sigma,& - qs_ot_env = scf_env%qs_ot_env,matrix_ks=matrix_ks(1)%matrix,& - error=error) + qs_ot_env = scf_env%qs_ot_env,matrix_ks=matrix_ks(1)%matrix) SELECT CASE(scf_env%qs_ot_env(1)%settings%preconditioner_type) CASE(ot_precond_none) @@ -715,20 +704,20 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) do_rotation=scf_env%qs_ot_env(1)%settings%do_rotation ! only full all needs rotation is_full_all=scf_env%qs_ot_env(1)%settings%preconditioner_type==ot_precond_full_all - CPPrecondition(.NOT.(do_rotation.AND.is_full_all),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.(do_rotation.AND.is_full_all),cp_failure_level,routineP,failure) DO ispin=1,SIZE(scf_env%qs_ot_env) CALL qs_ot_new_preconditioner(scf_env%qs_ot_env(ispin),& - scf_env%ot_preconditioner(ispin)%preconditioner,error=error) + scf_env%ot_preconditioner(ispin)%preconditioner) ENDDO CASE(ot_precond_s_inverse,ot_precond_full_single) DO ispin=1,SIZE(scf_env%qs_ot_env) CALL qs_ot_new_preconditioner(scf_env%qs_ot_env(ispin),& - scf_env%ot_preconditioner(1)%preconditioner,error=error) + scf_env%ot_preconditioner(1)%preconditioner) ENDDO CASE DEFAULT DO ispin=1,SIZE(scf_env%qs_ot_env) CALL qs_ot_new_preconditioner(scf_env%qs_ot_env(ispin),& - scf_env%ot_preconditioner(1)%preconditioner,error=error) + scf_env%ot_preconditioner(1)%preconditioner) ENDDO END SELECT ENDIF @@ -737,16 +726,16 @@ SUBROUTINE init_scf_loop(scf_env,qs_env,scf_section,error) do_rotation=scf_env%qs_ot_env(1)%settings%do_rotation DO ispin=1,SIZE(mos) IF (.NOT. mos(ispin)%mo_set%uniform_occupation) THEN - CPPrecondition(do_rotation,cp_failure_level,routineP,error,failure) + CPPrecondition(do_rotation,cp_failure_level,routineP,failure) ENDIF ENDDO END SELECT ! another safety check IF (dft_control%low_spin_roks) THEN - CPPrecondition(scf_env%method==ot_method_nr,cp_failure_level,routineP,error,failure) + CPPrecondition(scf_env%method==ot_method_nr,cp_failure_level,routineP,failure) do_rotation=scf_env%qs_ot_env(1)%settings%do_rotation - CPPrecondition(do_rotation,cp_failure_level,routineP,error,failure) + CPPrecondition(do_rotation,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle) @@ -758,15 +747,12 @@ END SUBROUTINE init_scf_loop !> \brief perform cleanup operations (like releasing temporary storage) !> at the end of the scf !> \param scf_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE scf_env_cleanup(scf_env,error) + SUBROUTINE scf_env_cleanup(scf_env) TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_env_cleanup', & routineP = moduleN//':'//routineN @@ -778,37 +764,37 @@ SUBROUTINE scf_env_cleanup(scf_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) ! *** Release SCF work storage *** IF (ASSOCIATED(scf_env%scf_work1)) THEN DO ispin=1,SIZE(scf_env%scf_work1) - CALL cp_fm_release(scf_env%scf_work1(ispin)%matrix,error=error) + CALL cp_fm_release(scf_env%scf_work1(ispin)%matrix) ENDDO DEALLOCATE(scf_env%scf_work1) ENDIF - IF (ASSOCIATED(scf_env%scf_work2)) CALL cp_fm_release(scf_env%scf_work2,error) - IF (ASSOCIATED(scf_env%ortho)) CALL cp_fm_release(scf_env%ortho,error=error) - IF (ASSOCIATED(scf_env%ortho_m1)) CALL cp_fm_release(scf_env%ortho_m1,error=error) + IF (ASSOCIATED(scf_env%scf_work2)) CALL cp_fm_release(scf_env%scf_work2) + IF (ASSOCIATED(scf_env%ortho)) CALL cp_fm_release(scf_env%ortho) + IF (ASSOCIATED(scf_env%ortho_m1)) CALL cp_fm_release(scf_env%ortho_m1) IF (ASSOCIATED(scf_env%ortho_dbcsr)) THEN - CALL cp_dbcsr_deallocate_matrix(scf_env%ortho_dbcsr,error=error) + CALL cp_dbcsr_deallocate_matrix(scf_env%ortho_dbcsr) END IF IF (ASSOCIATED(scf_env%buf1_dbcsr)) THEN - CALL cp_dbcsr_deallocate_matrix(scf_env%buf1_dbcsr,error=error) + CALL cp_dbcsr_deallocate_matrix(scf_env%buf1_dbcsr) END IF IF (ASSOCIATED(scf_env%buf2_dbcsr)) THEN - CALL cp_dbcsr_deallocate_matrix(scf_env%buf2_dbcsr,error=error) + CALL cp_dbcsr_deallocate_matrix(scf_env%buf2_dbcsr) END IF IF (ASSOCIATED(scf_env%p_mix_new)) THEN - CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_mix_new,error=error) + CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_mix_new) END IF IF (ASSOCIATED(scf_env%p_delta)) THEN - CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_delta,error=error) + CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_delta) END IF ! *** method dependent cleanup @@ -823,30 +809,30 @@ SUBROUTINE scf_env_cleanup(scf_env,error) ! CASE(block_krylov_diag_method_nr) CASE(block_davidson_diag_method_nr) - CALL block_davidson_deallocate(scf_env%block_davidson_env,error=error) + CALL block_davidson_deallocate(scf_env%block_davidson_env) CASE(filter_matrix_diag_method_nr) ! CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown scf method method:"//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) END SELECT IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN DEALLOCATE(scf_env%outer_scf%variables,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(scf_env%outer_scf%count)) THEN DEALLOCATE(scf_env%outer_scf%count,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN DEALLOCATE(scf_env%outer_scf%gradient,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN DEALLOCATE(scf_env%outer_scf%energy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ENDIF CALL timestop(handle) diff --git a/src/qs_scf_block_davidson.F b/src/qs_scf_block_davidson.F index 338c5c660b..e65970274b 100644 --- a/src/qs_scf_block_davidson.F +++ b/src/qs_scf_block_davidson.F @@ -73,14 +73,12 @@ MODULE qs_scf_block_davidson !> \param mo_coeff ... !> \param matrix_hc ... !> \param ritz_coeff ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ritz_coefficients(bdav_env,mo_coeff,matrix_hc,ritz_coeff,error) + SUBROUTINE ritz_coefficients(bdav_env,mo_coeff,matrix_hc,ritz_coeff) TYPE(davidson_type) :: bdav_env TYPE(cp_fm_type), POINTER :: mo_coeff, matrix_hc REAL(dp), DIMENSION(:) :: ritz_coeff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ritz_coefficients', & routineP = moduleN//':'//routineN @@ -96,43 +94,43 @@ SUBROUTINE ritz_coefficients(bdav_env,mo_coeff,matrix_hc,ritz_coeff,error) CALL timeset(routineN,handle) NULLIFY(block_mat,fm_struct_tmp,matrix_tmp) - CALL cp_fm_get_info(mo_coeff,nrow_global=nao,ncol_global=nmo,error=error) + CALL cp_fm_get_info(mo_coeff,nrow_global=nao,ncol_global=nmo) ALLOCATE(csc_diag(nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(chc_diag(nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! storage matrix of size mos x mos, only the diagonal elements are used CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nmo,ncol_global=nmo, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(matrix_tmp,fm_struct_tmp,name="matrix_tmp",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(matrix_tmp,fm_struct_tmp,name="matrix_tmp") + CALL cp_fm_struct_release(fm_struct_tmp) ! since we only use diagonal elements this is a bit of a waste ! compute CSC -! CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,mo_coeff,matrix_sc,0.0_dp,matrix_tmp,error=error) -! CALL cp_fm_get_diag(matrix_tmp,csc_diag,error=error) +! CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,mo_coeff,matrix_sc,0.0_dp,matrix_tmp) +! CALL cp_fm_get_diag(matrix_tmp,csc_diag) ! set the top left part of S[C,Z] block matrix CSC block_mat => bdav_env%S_block_mat - CALL cp_fm_set_all(block_mat,0.0_dp, 1.0_dp,error=error) -! CALL cp_fm_to_fm_submat(matrix_tmp,block_mat,nmo,nmo,1,1,1,1,error=error) + CALL cp_fm_set_all(block_mat,0.0_dp, 1.0_dp) +! CALL cp_fm_to_fm_submat(matrix_tmp,block_mat,nmo,nmo,1,1,1,1) ! compute CHC - CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,mo_coeff,matrix_hc,0.0_dp,matrix_tmp,error=error) - CALL cp_fm_get_diag(matrix_tmp,chc_diag,error=error) + CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,mo_coeff,matrix_hc,0.0_dp,matrix_tmp) + CALL cp_fm_get_diag(matrix_tmp,chc_diag) ! set the top left part of H[C,Z] block matrix CHC block_mat => bdav_env%H_block_mat - CALL cp_fm_to_fm_submat(matrix_tmp,block_mat,nmo,nmo,1,1,1,1,error=error) + CALL cp_fm_to_fm_submat(matrix_tmp,block_mat,nmo,nmo,1,1,1,1) DO i=1,nmo ! IF(ABS(csc_diag(i))>EPSILON(0.0_dp)) THEN ritz_coeff(i) = chc_diag(i)!/csc_diag(i) ! END IF END DO - CALL cp_fm_release(matrix_tmp,error=error) + CALL cp_fm_release(matrix_tmp) CALL timestop(handle) @@ -147,10 +145,9 @@ END SUBROUTINE ritz_coefficients !> \param matrix_s ... !> \param output_unit ... !> \param preconditioner ... -!> \param error ... ! ***************************************************************************** SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit,& - preconditioner,error) + preconditioner) TYPE(davidson_type) :: bdav_env TYPE(mo_set_type), POINTER :: mo_set @@ -158,7 +155,6 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit INTEGER, INTENT(IN) :: output_unit TYPE(preconditioner_type), OPTIONAL, & POINTER :: preconditioner - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_extended_space', & routineP = moduleN//':'//routineN @@ -208,42 +204,42 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit END IF ALLOCATE(iconv(nmo), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(inotconv(nmo), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(ritz_coeff(nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(vnorm(nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) converged=.FALSE. DO iter = 1, max_iter ! compute Ritz values ritz_coeff=0.0_dp - CALL cp_fm_create(m_hc,mo_coeff%matrix_struct,name="hc",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_h,mo_coeff,m_hc,nmo,error=error) - CALL cp_fm_create(m_sc,mo_coeff%matrix_struct,name="sc",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s,mo_coeff,m_sc,nmo,error=error) + CALL cp_fm_create(m_hc,mo_coeff%matrix_struct,name="hc") + CALL cp_dbcsr_sm_fm_multiply(matrix_h,mo_coeff,m_hc,nmo) + CALL cp_fm_create(m_sc,mo_coeff%matrix_struct,name="sc") + CALL cp_dbcsr_sm_fm_multiply(matrix_s,mo_coeff,m_sc,nmo) CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nmo,ncol_global=nmo, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(m_tmp,fm_struct_tmp,name="matrix_tmp",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(m_tmp,fm_struct_tmp,name="matrix_tmp") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,mo_coeff,m_hc,0.0_dp,m_tmp,error=error) - CALL cp_fm_get_diag(m_tmp,ritz_coeff,error=error) - CALL cp_fm_release(m_tmp,error=error) + CALL cp_gemm('T','N',nmo,nmo,nao,1.0_dp,mo_coeff,m_hc,0.0_dp,m_tmp) + CALL cp_fm_get_diag(m_tmp,ritz_coeff) + CALL cp_fm_release(m_tmp) ! Check for converged eigenvectors -! CALL cp_fm_create(c_z,mo_coeff%matrix_struct,name="tmp",error=error) +! CALL cp_fm_create(c_z,mo_coeff%matrix_struct,name="tmp") c_z => bdav_env%matrix_z c_pz => bdav_env%matrix_pz - CALL cp_fm_to_fm(m_sc,c_z,error=error) + CALL cp_fm_to_fm(m_sc,c_z) CALL cp_fm_column_scale(c_z,ritz_coeff) - CALL cp_fm_scale_and_add(-1.0_dp,c_z,1.0_dp,m_hc,error=error) - CALL cp_fm_vectorsnorm(c_z,vnorm,error=error) + CALL cp_fm_scale_and_add(-1.0_dp,c_z,1.0_dp,m_hc) + CALL cp_fm_vectorsnorm(c_z,vnorm) nmo_converged = 0 nmo_not_converged = 0 @@ -267,9 +263,9 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit IF(nmo_converged>0) THEN ALLOCATE(iconv_set(nmo_converged,2), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(inotconv_set(nmo_not_converged,2), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) i_last = iconv(1) nset = 0 DO j = 1,nmo_converged @@ -303,8 +299,8 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit END IF END DO nset_not_conv = nset - CALL cp_fm_release(m_sc,error=error) - CALL cp_fm_release(m_hc,error=error) + CALL cp_fm_release(m_sc) + CALL cp_fm_release(m_hc) NULLIFY(c_z, c_pz) END IF @@ -328,49 +324,49 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit IF(nmo_converged>0) THEN CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nao,ncol_global=nao, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) + para_env=mo_coeff%matrix_struct%para_env) !allocate h_fm - CALL cp_fm_create(h_fm,fm_struct_tmp,name="matrix_tmp",error=error) + CALL cp_fm_create(h_fm,fm_struct_tmp,name="matrix_tmp") !allocate s_fm - CALL cp_fm_create(s_fm,fm_struct_tmp,name="matrix_tmp",error=error) + CALL cp_fm_create(s_fm,fm_struct_tmp,name="matrix_tmp") !copy matrix_h in h_fm - CALL copy_dbcsr_to_fm(matrix_h,h_fm,error=error) - CALL cp_fm_upper_to_full(h_fm,s_fm,error=error) + CALL copy_dbcsr_to_fm(matrix_h,h_fm) + CALL cp_fm_upper_to_full(h_fm,s_fm) !copy matrix_s in s_fm -! CALL cp_fm_set_all(s_fm,0.0_dp,error=error) - CALL copy_dbcsr_to_fm(matrix_s,s_fm,error=error) +! CALL cp_fm_set_all(s_fm,0.0_dp) + CALL copy_dbcsr_to_fm(matrix_s,s_fm) !allocate c_out - CALL cp_fm_create(c_out,fm_struct_tmp,name="matrix_tmp",error=error) + CALL cp_fm_create(c_out,fm_struct_tmp,name="matrix_tmp") ! set c_out to zero - CALL cp_fm_set_all(c_out,0.0_dp,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_set_all(c_out,0.0_dp) + CALL cp_fm_struct_release(fm_struct_tmp) !allocate c_conv CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nao,ncol_global=nmo_converged, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(c_conv,fm_struct_tmp,name="c_conv",error=error) - CALL cp_fm_set_all(c_conv,0.0_dp,error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(c_conv,fm_struct_tmp,name="c_conv") + CALL cp_fm_set_all(c_conv,0.0_dp) !allocate m_tmp - CALL cp_fm_create(m_tmp,fm_struct_tmp,name="m_tmp_nxmc",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(m_tmp,fm_struct_tmp,name="m_tmp_nxmc") + CALL cp_fm_struct_release(fm_struct_tmp) END IF !allocate c_notconv CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nao,ncol_global=nmo_not_converged, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(c_notconv,fm_struct_tmp,name="c_notconv",error=error) - CALL cp_fm_set_all(c_notconv,0.0_dp,error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(c_notconv,fm_struct_tmp,name="c_notconv") + CALL cp_fm_set_all(c_notconv,0.0_dp) IF(nmo_converged>0) THEN - CALL cp_fm_create(m_hc,fm_struct_tmp,name="m_hc",error=error) - CALL cp_fm_create(m_sc,fm_struct_tmp,name="m_sc",error=error) + CALL cp_fm_create(m_hc,fm_struct_tmp,name="m_hc") + CALL cp_fm_create(m_sc,fm_struct_tmp,name="m_sc") !allocate c_z - CALL cp_fm_create(c_z,fm_struct_tmp,name="c_z",error=error) - CALL cp_fm_create(c_pz,fm_struct_tmp,name="c_pz",error=error) - CALL cp_fm_set_all(c_z,0.0_dp,error=error) + CALL cp_fm_create(c_z,fm_struct_tmp,name="c_z") + CALL cp_fm_create(c_pz,fm_struct_tmp,name="c_pz") + CALL cp_fm_set_all(c_z,0.0_dp) ! sum contributions to c_out jj=1 @@ -378,23 +374,23 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit i_first=iconv_set(j,1) i_last=iconv_set(j,2) n=i_last-i_first+1 - CALL cp_fm_to_fm_submat(mo_coeff,c_conv,nao,n,1,i_first,1,jj,error=error) + CALL cp_fm_to_fm_submat(mo_coeff,c_conv,nao,n,1,i_first,1,jj) jj=jj+n END DO - CALL cp_fm_symm('L','U',nao,nmo_converged,1.0_dp,s_fm,c_conv,0.0_dp,m_tmp,error=error) - CALL cp_gemm('N','T',nao,nao,nmo_converged,1.0_dp,m_tmp,m_tmp,0.0_dp,c_out,error=error) + CALL cp_fm_symm('L','U',nao,nmo_converged,1.0_dp,s_fm,c_conv,0.0_dp,m_tmp) + CALL cp_gemm('N','T',nao,nao,nmo_converged,1.0_dp,m_tmp,m_tmp,0.0_dp,c_out) ! project c_out out of H lambda = 100.0_dp*ABS(eigenvalues(homo)) - CALL cp_fm_scale_and_add(lambda,c_out,1.0_dp,h_fm,error=error) - CALL cp_fm_release(m_tmp,error=error) - CALL cp_fm_release(h_fm,error=error) + CALL cp_fm_scale_and_add(lambda,c_out,1.0_dp,h_fm) + CALL cp_fm_release(m_tmp) + CALL cp_fm_release(h_fm) END IF !allocate m_tmp - CALL cp_fm_create(m_tmp,fm_struct_tmp,name="m_tmp_nxm",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(m_tmp,fm_struct_tmp,name="m_tmp_nxm") + CALL cp_fm_struct_release(fm_struct_tmp) IF(nmo_converged>0) THEN ALLOCATE(eig_not_conv(nmo_not_converged)) jj=1 @@ -402,138 +398,138 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit i_first=inotconv_set(j,1) i_last=inotconv_set(j,2) n=i_last-i_first+1 - CALL cp_fm_to_fm_submat(mo_coeff,c_notconv,nao,n,1,i_first,1,jj,error=error) + CALL cp_fm_to_fm_submat(mo_coeff,c_notconv,nao,n,1,i_first,1,jj) eig_not_conv(jj:jj+n-1) = ritz_coeff(i_first:i_last) jj=jj+n END DO - CALL cp_gemm('N','N',nao,nmo_not_converged,nao,1.0_dp,c_out,c_notconv,0.0_dp,m_hc,error=error) - CALL cp_fm_symm('L','U',nao,nmo_not_converged,1.0_dp,s_fm,c_notconv,0.0_dp,m_sc,error=error) + CALL cp_gemm('N','N',nao,nmo_not_converged,nao,1.0_dp,c_out,c_notconv,0.0_dp,m_hc) + CALL cp_fm_symm('L','U',nao,nmo_not_converged,1.0_dp,s_fm,c_notconv,0.0_dp,m_sc) ! extend suspace using only the not converged vectors - CALL cp_fm_to_fm(m_sc,m_tmp,error=error) + CALL cp_fm_to_fm(m_sc,m_tmp) CALL cp_fm_column_scale(m_tmp,eig_not_conv) - CALL cp_fm_scale_and_add(-1.0_dp,m_tmp,1.0_dp,m_hc,error=error) + CALL cp_fm_scale_and_add(-1.0_dp,m_tmp,1.0_dp,m_hc) DEALLOCATE(eig_not_conv) - CALL cp_fm_to_fm(m_tmp,c_z,error=error) + CALL cp_fm_to_fm(m_tmp,c_z) ELSE - CALL cp_fm_to_fm(mo_coeff,c_notconv,error=error) + CALL cp_fm_to_fm(mo_coeff,c_notconv) END IF !preconditioner IF(do_apply_preconditioner) THEN IF (preconditioner%in_use/=0) THEN - CALL apply_preconditioner(preconditioner,c_z,c_pz,error=error) + CALL apply_preconditioner(preconditioner,c_z,c_pz) ELSE - CALL cp_fm_to_fm(c_z,c_pz,error=error) + CALL cp_fm_to_fm(c_z,c_pz) ENDIF ELSE - CALL cp_fm_to_fm(c_z,c_pz,error=error) + CALL cp_fm_to_fm(c_z,c_pz) END IF - CALL cp_fm_release(m_tmp,error=error) + CALL cp_fm_release(m_tmp) CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nmo_not_converged,ncol_global=nmo_not_converged, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) + para_env=mo_coeff%matrix_struct%para_env) - CALL cp_fm_create(m_tmp,fm_struct_tmp,name="m_tmp_mxm",error=error) - CALL cp_fm_create(mt_tmp,fm_struct_tmp,name="mt_tmp_mxm",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(m_tmp,fm_struct_tmp,name="m_tmp_mxm") + CALL cp_fm_create(mt_tmp,fm_struct_tmp,name="mt_tmp_mxm") + CALL cp_fm_struct_release(fm_struct_tmp) nmat = nmo_not_converged nmat2 = 2* nmo_not_converged CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nmat2,ncol_global=nmat2, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) + para_env=mo_coeff%matrix_struct%para_env) - CALL cp_fm_create(s_block,fm_struct_tmp,name="sb",error=error) - CALL cp_fm_create(h_block,fm_struct_tmp,name="hb",error=error) - CALL cp_fm_create(v_block,fm_struct_tmp,name="vb",error=error) - CALL cp_fm_create(w_block,fm_struct_tmp,name="wb",error=error) + CALL cp_fm_create(s_block,fm_struct_tmp,name="sb") + CALL cp_fm_create(h_block,fm_struct_tmp,name="hb") + CALL cp_fm_create(v_block,fm_struct_tmp,name="vb") + CALL cp_fm_create(w_block,fm_struct_tmp,name="wb") ALLOCATE(evals(nmat2)) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_tmp) ! compute CSC - CALL cp_fm_set_all(s_block,0.0_dp, 1.0_dp,error=error) + CALL cp_fm_set_all(s_block,0.0_dp, 1.0_dp) ! compute CHC - CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_notconv,m_hc,0.0_dp,m_tmp,error=error) - CALL cp_fm_to_fm_submat(m_tmp,h_block,nmat,nmat,1,1,1,1,error=error) + CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_notconv,m_hc,0.0_dp,m_tmp) + CALL cp_fm_to_fm_submat(m_tmp,h_block,nmat,nmat,1,1,1,1) ! compute ZSC - CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_sc,0.0_dp,m_tmp,error=error) - CALL cp_fm_to_fm_submat(m_tmp,s_block,nmat,nmat,1,1,1+nmat,1,error=error) - CALL cp_fm_transpose(m_tmp,mt_tmp,error=error) - CALL cp_fm_to_fm_submat(mt_tmp,s_block,nmat,nmat,1,1,1,1+nmat,error=error) + CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_sc,0.0_dp,m_tmp) + CALL cp_fm_to_fm_submat(m_tmp,s_block,nmat,nmat,1,1,1+nmat,1) + CALL cp_fm_transpose(m_tmp,mt_tmp) + CALL cp_fm_to_fm_submat(mt_tmp,s_block,nmat,nmat,1,1,1,1+nmat) ! compute ZHC - CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_hc,0.0_dp,m_tmp,error=error) - CALL cp_fm_to_fm_submat(m_tmp,h_block,nmat,nmat,1,1,1+nmat,1,error=error) - CALL cp_fm_transpose(m_tmp,mt_tmp,error=error) - CALL cp_fm_to_fm_submat(mt_tmp,h_block,nmat,nmat,1,1,1,1+nmat,error=error) + CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_hc,0.0_dp,m_tmp) + CALL cp_fm_to_fm_submat(m_tmp,h_block,nmat,nmat,1,1,1+nmat,1) + CALL cp_fm_transpose(m_tmp,mt_tmp) + CALL cp_fm_to_fm_submat(mt_tmp,h_block,nmat,nmat,1,1,1,1+nmat) - CALL cp_fm_release(mt_tmp,error=error) + CALL cp_fm_release(mt_tmp) ! reuse m_sc and m_hc to computr HZ and SZ IF(nmo_converged>0) THEN - CALL cp_gemm('N','N',nao,nmat,nao,1.0_dp,c_out,c_pz,0.0_dp,m_hc,error=error) - CALL cp_fm_symm('L','U',nao,nmo_not_converged,1.0_dp,s_fm,c_pz,0.0_dp,m_sc,error=error) + CALL cp_gemm('N','N',nao,nmat,nao,1.0_dp,c_out,c_pz,0.0_dp,m_hc) + CALL cp_fm_symm('L','U',nao,nmo_not_converged,1.0_dp,s_fm,c_pz,0.0_dp,m_sc) - CALL cp_fm_release(c_out,error=error) - CALL cp_fm_release(c_conv,error=error) - CALL cp_fm_release(s_fm,error=error) + CALL cp_fm_release(c_out) + CALL cp_fm_release(c_conv) + CALL cp_fm_release(s_fm) ELSE - CALL cp_dbcsr_sm_fm_multiply(matrix_h,c_pz,m_hc,nmo,error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s,c_pz,m_sc,nmo,error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_h,c_pz,m_hc,nmo) + CALL cp_dbcsr_sm_fm_multiply(matrix_s,c_pz,m_sc,nmo) END IF ! compute ZSZ - CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_sc,0.0_dp,m_tmp,error=error) - CALL cp_fm_to_fm_submat(m_tmp,s_block,nmat,nmat,1,1,1+nmat,1+nmat,error=error) + CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_sc,0.0_dp,m_tmp) + CALL cp_fm_to_fm_submat(m_tmp,s_block,nmat,nmat,1,1,1+nmat,1+nmat) ! compute ZHZ - CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_hc,0.0_dp,m_tmp,error=error) - CALL cp_fm_to_fm_submat(m_tmp,h_block,nmat,nmat,1,1,1+nmat,1+nmat,error=error) + CALL cp_gemm('T','N',nmat,nmat,nao,1.0_dp,c_pz,m_hc,0.0_dp,m_tmp) + CALL cp_fm_to_fm_submat(m_tmp,h_block,nmat,nmat,1,1,1+nmat,1+nmat) - CALL cp_fm_release(m_sc,error=error) + CALL cp_fm_release(m_sc) ! solution of the reduced eigenvalues problem - CALL reduce_extended_space(s_block,h_block,v_block,w_block, evals, nmat2, error=error) + CALL reduce_extended_space(s_block,h_block,v_block,w_block, evals, nmat2) ! extract egenvectors - CALL cp_fm_to_fm_submat(v_block,m_tmp, nmat,nmat,1,1,1,1,error=error) - CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,c_notconv,m_tmp,0.0_dp,m_hc,error=error) - CALL cp_fm_to_fm_submat(v_block,m_tmp, nmat,nmat,1+nmat,1,1,1,error=error) - CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,c_pz,m_tmp,1.0_dp,m_hc,error=error) + CALL cp_fm_to_fm_submat(v_block,m_tmp, nmat,nmat,1,1,1,1) + CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,c_notconv,m_tmp,0.0_dp,m_hc) + CALL cp_fm_to_fm_submat(v_block,m_tmp, nmat,nmat,1+nmat,1,1,1) + CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,c_pz,m_tmp,1.0_dp,m_hc) - CALL cp_fm_release(m_tmp,error=error) + CALL cp_fm_release(m_tmp) - CALL cp_fm_release(c_notconv,error=error) - CALL cp_fm_release(s_block,error=error) - CALL cp_fm_release(h_block,error=error) - CALL cp_fm_release(w_block,error=error) - CALL cp_fm_release(v_block,error=error) + CALL cp_fm_release(c_notconv) + CALL cp_fm_release(s_block) + CALL cp_fm_release(h_block) + CALL cp_fm_release(w_block) + CALL cp_fm_release(v_block) IF(nmo_converged>0) THEN - CALL cp_fm_release(c_z,error=error) - CALL cp_fm_release(c_pz,error=error) + CALL cp_fm_release(c_z) + CALL cp_fm_release(c_pz) jj=1 DO j=1,nset_not_conv i_first=inotconv_set(j,1) i_last=inotconv_set(j,2) n=i_last-i_first+1 - CALL cp_fm_to_fm_submat(m_hc,mo_coeff,nao,n,1,jj,1,i_first,error=error) + CALL cp_fm_to_fm_submat(m_hc,mo_coeff,nao,n,1,jj,1,i_first) eigenvalues(i_first:i_last) = evals(jj:jj+n-1) jj=jj+n END DO DEALLOCATE(iconv_set,STAT=istat) DEALLOCATE (inotconv_set,STAT=istat) ELSE - CALL cp_fm_to_fm(m_hc,mo_coeff,error=error) + CALL cp_fm_to_fm(m_hc,mo_coeff) eigenvalues(1:nmo) = evals(1:nmo) END IF DEALLOCATE(evals,STAT=istat) - CALL cp_fm_release(m_hc,error=error) + CALL cp_fm_release(m_hc) - CALL copy_fm_to_dbcsr(mo_coeff,mo_coeff_b,error=error)!fm->dbcsr + CALL copy_fm_to_dbcsr(mo_coeff,mo_coeff_b)!fm->dbcsr t2 = m_walltime() IF (output_unit > 0) THEN @@ -545,13 +541,13 @@ SUBROUTINE generate_extended_space(bdav_env,mo_set,matrix_h,matrix_s,output_unit END DO ! iter DEALLOCATE(iconv,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(inotconv,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(ritz_coeff,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(vnorm,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE generate_extended_space @@ -564,10 +560,9 @@ END SUBROUTINE generate_extended_space !> \param matrix_s ... !> \param output_unit ... !> \param preconditioner ... -!> \param error ... ! ***************************************************************************** SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,output_unit,& - preconditioner,error) + preconditioner) TYPE(davidson_type) :: bdav_env TYPE(mo_set_type), POINTER :: mo_set @@ -575,7 +570,6 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp INTEGER, INTENT(IN) :: output_unit TYPE(preconditioner_type), OPTIONAL, & POINTER :: preconditioner - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'generate_extended_space_sparse', & @@ -629,58 +623,58 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp ! Allocate array for Ritz values ALLOCATE(ritz_coeff(nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(iconv(nmo), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(inotconv(nmo), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(vnorm(nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) converged=.FALSE. DO iter = 1, max_iter NULLIFY(c_out, mo_conv, mo_notconv_fm, mo_notconv) ! Prepare HC and SC, using mo_coeff_b (sparse), these are still sparse - CALL cp_dbcsr_init_p(matrix_hc,error=error) + CALL cp_dbcsr_init_p(matrix_hc) CALL cp_dbcsr_create(matrix_hc,"matrix_hc",cp_dbcsr_distribution(mo_coeff_b),& dbcsr_type_no_symmetry,cp_dbcsr_row_block_sizes(mo_coeff_b),& - cp_dbcsr_col_block_sizes(mo_coeff_b),nze=0,data_type=dbcsr_type_real_default,error=error) - CALL cp_dbcsr_init_p(matrix_sc,error=error) + cp_dbcsr_col_block_sizes(mo_coeff_b),nze=0,data_type=dbcsr_type_real_default) + CALL cp_dbcsr_init_p(matrix_sc) CALL cp_dbcsr_create(matrix_sc,"matrix_sc",cp_dbcsr_distribution(mo_coeff_b),& dbcsr_type_no_symmetry,cp_dbcsr_row_block_sizes(mo_coeff_b),& - cp_dbcsr_col_block_sizes(mo_coeff_b),nze=0,data_type=dbcsr_type_real_default,error=error) + cp_dbcsr_col_block_sizes(mo_coeff_b),nze=0,data_type=dbcsr_type_real_default) CALL cp_dbcsr_get_info(mo_coeff_b,nfullrows_total=n,nfullcols_total=k) - CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_h,mo_coeff_b,0.0_dp,matrix_hc,last_column=k,error=error) - CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_s,mo_coeff_b,0.0_dp,matrix_sc,last_column=k,error=error) + CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_h,mo_coeff_b,0.0_dp,matrix_hc,last_column=k) + CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_s,mo_coeff_b,0.0_dp,matrix_sc,last_column=k) ! compute Ritz values ritz_coeff=0.0_dp ! Allocate Sparse matrices: nmoxnmo ! matrix_mm - CALL cp_dbcsr_init_p(matrix_mm,error=error) + CALL cp_dbcsr_init_p(matrix_mm) CALL cp_dbcsr_m_by_n_from_template(matrix_mm,template=matrix_s,m=nmo,n=nmo,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_multiply('t','n',1.0_dp,mo_coeff_b,matrix_hc,0.0_dp,matrix_mm, last_column=k, error=error) - CALL cp_dbcsr_get_diag(matrix_mm,ritz_coeff,error=error) + CALL cp_dbcsr_multiply('t','n',1.0_dp,mo_coeff_b,matrix_hc,0.0_dp,matrix_mm, last_column=k) + CALL cp_dbcsr_get_diag(matrix_mm,ritz_coeff) CALL mp_sum(ritz_coeff,mo_coeff%matrix_struct%para_env%group) ! extended subspace P Z = P [H - theta S]C this ia another matrix of type and size as mo_coeff_b - CALL cp_dbcsr_init_p(matrix_z,error=error) + CALL cp_dbcsr_init_p(matrix_z) CALL cp_dbcsr_create(matrix_z,"matrix_z",cp_dbcsr_distribution(mo_coeff_b),& dbcsr_type_no_symmetry,cp_dbcsr_row_block_sizes(mo_coeff_b),& - cp_dbcsr_col_block_sizes(mo_coeff_b),nze=0,data_type=dbcsr_type_real_default,error=error) - CALL cp_dbcsr_copy(matrix_z,matrix_sc,error=error) - CALL cp_dbcsr_scale_by_vector(matrix_z,ritz_coeff,side='right',error=error) - CALL cp_dbcsr_add(matrix_z,matrix_hc,-1.0_dp,1.0_dp,error=error) + cp_dbcsr_col_block_sizes(mo_coeff_b),nze=0,data_type=dbcsr_type_real_default) + CALL cp_dbcsr_copy(matrix_z,matrix_sc) + CALL cp_dbcsr_scale_by_vector(matrix_z,ritz_coeff,side='right') + CALL cp_dbcsr_add(matrix_z,matrix_hc,-1.0_dp,1.0_dp) ! Check for converged eigenvectors vnorm =0.0_dp - CALL cp_dbcsr_norm(matrix_z,which_norm=dbcsr_norm_column,norm_vector=vnorm,error=error) + CALL cp_dbcsr_norm(matrix_z,which_norm=dbcsr_norm_column,norm_vector=vnorm) nmo_converged = 0 nmo_not_converged = 0 max_norm = 0.0_dp @@ -705,9 +699,9 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp IF(nmo_converged>0) THEN ALLOCATE(iconv_set(nmo_converged,2), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(inotconv_set(nmo_not_converged,2), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) i_last = iconv(1) nset = 0 DO j = 1,nmo_converged @@ -742,18 +736,18 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp END DO nset_not_conv = nset - CALL cp_dbcsr_release_p(matrix_hc, error=error) - CALL cp_dbcsr_release_p(matrix_sc, error=error) - CALL cp_dbcsr_release_p(matrix_z, error=error) - CALL cp_dbcsr_release_p(matrix_mm, error=error) + CALL cp_dbcsr_release_p(matrix_hc) + CALL cp_dbcsr_release_p(matrix_sc) + CALL cp_dbcsr_release_p(matrix_z) + CALL cp_dbcsr_release_p(matrix_mm) END IF IF(REAL(nmo_converged,dp)/REAL(nmo,dp)>bdav_env%conv_percent) THEN DEALLOCATE(iconv_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (inotconv_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) converged=.TRUE. t2 = m_walltime() @@ -773,10 +767,10 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp !allocate mo_conv_fm CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nao,ncol_global=nmo_converged, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(mo_conv_fm,fm_struct_tmp,name="mo_conv_fm",error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(mo_conv_fm,fm_struct_tmp,name="mo_conv_fm") - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_tmp) ! extract mo_conv from mo_coeff full matrix jj=1 @@ -784,98 +778,98 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp i_first=iconv_set(j,1) i_last=iconv_set(j,2) n=i_last-i_first+1 - CALL cp_fm_to_fm_submat(mo_coeff,mo_conv_fm,nao,n,1,i_first,1,jj,error=error) + CALL cp_fm_to_fm_submat(mo_coeff,mo_conv_fm,nao,n,1,i_first,1,jj) jj=jj+n END DO ! allocate c_out sparse matrix, to project out the converged MOS - CALL cp_dbcsr_init_p(c_out,error=error) + CALL cp_dbcsr_init_p(c_out) CALL cp_dbcsr_create(c_out,"c_out",cp_dbcsr_distribution(matrix_s),& dbcsr_type_symmetric,cp_dbcsr_row_block_sizes(matrix_s),& - cp_dbcsr_col_block_sizes(matrix_s),nze=0,data_type=dbcsr_type_real_default,error=error) + cp_dbcsr_col_block_sizes(matrix_s),nze=0,data_type=dbcsr_type_real_default) ! allocate mo_conv sparse - CALL cp_dbcsr_init_p(mo_conv,error=error) + CALL cp_dbcsr_init_p(mo_conv) CALL cp_dbcsr_m_by_n_from_row_template(mo_conv,template=matrix_s,n=nmo_converged,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(smo_conv,error=error) + CALL cp_dbcsr_init_p(smo_conv) CALL cp_dbcsr_m_by_n_from_row_template(smo_conv,template=matrix_s,n=nmo_converged,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL copy_fm_to_dbcsr(mo_conv_fm,mo_conv,error=error)!fm->dbcsr + CALL copy_fm_to_dbcsr(mo_conv_fm,mo_conv)!fm->dbcsr - CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_s,mo_conv,0.0_dp,smo_conv,last_column=nmo_converged,error=error) - CALL cp_dbcsr_multiply('n','t',1.0_dp,smo_conv,smo_conv,0.0_dp,c_out,last_column=nao,error=error) + CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_s,mo_conv,0.0_dp,smo_conv,last_column=nmo_converged) + CALL cp_dbcsr_multiply('n','t',1.0_dp,smo_conv,smo_conv,0.0_dp,c_out,last_column=nao) ! project c_out out of H lambda = 100.0_dp*ABS(eigenvalues(homo)) - CALL cp_dbcsr_add(c_out,matrix_h,lambda,1.0_dp,error=error) + CALL cp_dbcsr_add(c_out,matrix_h,lambda,1.0_dp) - CALL cp_dbcsr_release_p(mo_conv, error=error) - CALL cp_dbcsr_release_p(smo_conv, error=error) - CALL cp_fm_release(mo_conv_fm, error=error) + CALL cp_dbcsr_release_p(mo_conv) + CALL cp_dbcsr_release_p(smo_conv) + CALL cp_fm_release(mo_conv_fm) !allocate c_notconv_fm CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nao,ncol_global=nmo_not_converged, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(mo_notconv_fm,fm_struct_tmp,name="mo_notconv_fm",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(mo_notconv_fm,fm_struct_tmp,name="mo_notconv_fm") + CALL cp_fm_struct_release(fm_struct_tmp) ! extract mo_notconv from mo_coeff full matrix ALLOCATE(eig_not_conv(nmo_not_converged),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) jj=1 DO j=1,nset_not_conv i_first=inotconv_set(j,1) i_last=inotconv_set(j,2) n=i_last-i_first+1 - CALL cp_fm_to_fm_submat(mo_coeff,mo_notconv_fm,nao,n,1,i_first,1,jj,error=error) + CALL cp_fm_to_fm_submat(mo_coeff,mo_notconv_fm,nao,n,1,i_first,1,jj) eig_not_conv(jj:jj+n-1) = ritz_coeff(i_first:i_last) jj=jj+n END DO ! allocate mo_conv sparse - CALL cp_dbcsr_init_p(mo_notconv,error=error) + CALL cp_dbcsr_init_p(mo_notconv) CALL cp_dbcsr_m_by_n_from_row_template(mo_notconv,template=matrix_s,n=nmo_not_converged,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(matrix_hc,error=error) + CALL cp_dbcsr_init_p(matrix_hc) CALL cp_dbcsr_m_by_n_from_row_template(matrix_hc,template=matrix_s,n=nmo_not_converged,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(matrix_sc,error=error) + CALL cp_dbcsr_init_p(matrix_sc) CALL cp_dbcsr_m_by_n_from_row_template(matrix_sc,template=matrix_s,n=nmo_not_converged,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL cp_dbcsr_init_p(matrix_z,error=error) + CALL cp_dbcsr_init_p(matrix_z) CALL cp_dbcsr_m_by_n_from_row_template(matrix_z,template=matrix_s,n=nmo_not_converged,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) - CALL copy_fm_to_dbcsr(mo_notconv_fm,mo_notconv,error=error)!fm->dbcsr + CALL copy_fm_to_dbcsr(mo_notconv_fm,mo_notconv)!fm->dbcsr CALL cp_dbcsr_multiply('n','n',1.0_dp,c_out,mo_notconv,0.0_dp,matrix_hc,& - last_column=nmo_not_converged,error=error) + last_column=nmo_not_converged) CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_s,mo_notconv,0.0_dp,matrix_sc,& - last_column=nmo_not_converged,error=error) + last_column=nmo_not_converged) - CALL cp_dbcsr_copy(matrix_z,matrix_sc,error=error) - CALL cp_dbcsr_scale_by_vector(matrix_z,eig_not_conv,side='right',error=error) - CALL cp_dbcsr_add(matrix_z,matrix_hc,-1.0_dp,1.0_dp,error=error) + CALL cp_dbcsr_copy(matrix_z,matrix_sc) + CALL cp_dbcsr_scale_by_vector(matrix_z,eig_not_conv,side='right') + CALL cp_dbcsr_add(matrix_z,matrix_hc,-1.0_dp,1.0_dp) DEALLOCATE(eig_not_conv,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! matrix_mm - CALL cp_dbcsr_init_p(matrix_mm,error=error) + CALL cp_dbcsr_init_p(matrix_mm) CALL cp_dbcsr_m_by_n_from_template (matrix_mm,template=matrix_s,m=nmo_not_converged,n=nmo_not_converged,& - sym=dbcsr_type_no_symmetry,error=error) + sym=dbcsr_type_no_symmetry) CALL cp_dbcsr_multiply('t','n',1.0_dp,mo_notconv,matrix_hc,0.0_dp,matrix_mm,& - last_column=nmo_not_converged, error=error) + last_column=nmo_not_converged) ELSE mo_notconv=>mo_coeff_b @@ -884,114 +878,114 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp END IF ! allocate matrix_pz using as template matrix_z - CALL cp_dbcsr_init_p(matrix_pz,error=error) + CALL cp_dbcsr_init_p(matrix_pz) CALL cp_dbcsr_create(matrix_pz,"matrix_pz",cp_dbcsr_distribution(matrix_z),& dbcsr_type_no_symmetry,cp_dbcsr_row_block_sizes(matrix_z),& - cp_dbcsr_col_block_sizes(matrix_z),nze=0,data_type=dbcsr_type_real_default,error=error) + cp_dbcsr_col_block_sizes(matrix_z),nze=0,data_type=dbcsr_type_real_default) IF(do_apply_preconditioner) THEN IF(preconditioner%in_use/=0) THEN - CALL apply_preconditioner(preconditioner,matrix_z,matrix_pz,error=error) + CALL apply_preconditioner(preconditioner,matrix_z,matrix_pz) ELSE - CALL cp_dbcsr_copy(matrix_pz,matrix_z,error=error) + CALL cp_dbcsr_copy(matrix_pz,matrix_z) END IF ELSE - CALL cp_dbcsr_copy(matrix_pz,matrix_z,error=error) + CALL cp_dbcsr_copy(matrix_pz,matrix_z) END IF !allocate NMOxNMO full matrices nmat = nmo_not_converged CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nmat,ncol_global=nmat, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(matrix_mm_fm,fm_struct_tmp,name="m_tmp_mxm",error=error) - CALL cp_fm_create(matrix_mmt_fm,fm_struct_tmp,name="mt_tmp_mxm",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(matrix_mm_fm,fm_struct_tmp,name="m_tmp_mxm") + CALL cp_fm_create(matrix_mmt_fm,fm_struct_tmp,name="mt_tmp_mxm") + CALL cp_fm_struct_release(fm_struct_tmp) !allocate 2NMOx2NMO full matrices nmat2 = 2* nmo_not_converged CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nmat2,ncol_global=nmat2, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) + para_env=mo_coeff%matrix_struct%para_env) - CALL cp_fm_create(s_block,fm_struct_tmp,name="sb",error=error) - CALL cp_fm_create(h_block,fm_struct_tmp,name="hb",error=error) - CALL cp_fm_create(v_block,fm_struct_tmp,name="vb",error=error) - CALL cp_fm_create(w_block,fm_struct_tmp,name="wb",error=error) + CALL cp_fm_create(s_block,fm_struct_tmp,name="sb") + CALL cp_fm_create(h_block,fm_struct_tmp,name="hb") + CALL cp_fm_create(v_block,fm_struct_tmp,name="vb") + CALL cp_fm_create(w_block,fm_struct_tmp,name="wb") ALLOCATE(evals(nmat2)) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_tmp) ! compute CSC - CALL cp_fm_set_all(s_block,0.0_dp, 1.0_dp,error=error) + CALL cp_fm_set_all(s_block,0.0_dp, 1.0_dp) ! compute CHC - CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm,error=error) - CALL cp_fm_to_fm_submat(matrix_mm_fm,h_block,nmat,nmat,1,1,1,1,error=error) + CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm) + CALL cp_fm_to_fm_submat(matrix_mm_fm,h_block,nmat,nmat,1,1,1,1) ! compute the bottom left ZSC (top right is transpose) - CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_sc,0.0_dp,matrix_mm,last_column=nmat,error=error) + CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_sc,0.0_dp,matrix_mm,last_column=nmat) ! set the bottom left part of S[C,Z] block matrix ZSC !copy sparse to full - CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm,error=error) - CALL cp_fm_to_fm_submat(matrix_mm_fm,s_block,nmat,nmat,1,1,1+nmat,1,error=error) - CALL cp_fm_transpose(matrix_mm_fm,matrix_mmt_fm,error=error) - CALL cp_fm_to_fm_submat(matrix_mmt_fm,s_block,nmat,nmat,1,1,1,1+nmat,error=error) + CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm) + CALL cp_fm_to_fm_submat(matrix_mm_fm,s_block,nmat,nmat,1,1,1+nmat,1) + CALL cp_fm_transpose(matrix_mm_fm,matrix_mmt_fm) + CALL cp_fm_to_fm_submat(matrix_mmt_fm,s_block,nmat,nmat,1,1,1,1+nmat) ! compute the bottom left ZHC (top right is transpose) - CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_hc,0.0_dp,matrix_mm,last_column=nmat,error=error) + CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_hc,0.0_dp,matrix_mm,last_column=nmat) ! set the bottom left part of S[C,Z] block matrix ZHC - CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm,error=error) - CALL cp_fm_to_fm_submat(matrix_mm_fm,h_block,nmat,nmat,1,1,1+nmat,1,error=error) - CALL cp_fm_transpose(matrix_mm_fm,matrix_mmt_fm,error=error) - CALL cp_fm_to_fm_submat(matrix_mmt_fm,h_block,nmat,nmat,1,1,1,1+nmat,error=error) + CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm) + CALL cp_fm_to_fm_submat(matrix_mm_fm,h_block,nmat,nmat,1,1,1+nmat,1) + CALL cp_fm_transpose(matrix_mm_fm,matrix_mmt_fm) + CALL cp_fm_to_fm_submat(matrix_mmt_fm,h_block,nmat,nmat,1,1,1,1+nmat) - CALL cp_fm_release(matrix_mmt_fm,error=error) + CALL cp_fm_release(matrix_mmt_fm) ! (reuse matrix_sc and matrix_hc to computr HZ and SZ) CALL cp_dbcsr_get_info(matrix_pz,nfullrows_total=n,nfullcols_total=k) - CALL cp_dbcsr_multiply('n','n',1.0_dp,c_out,matrix_pz,0.0_dp,matrix_hc,last_column=k,error=error) - CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_s,matrix_pz,0.0_dp,matrix_sc,last_column=k,error=error) + CALL cp_dbcsr_multiply('n','n',1.0_dp,c_out,matrix_pz,0.0_dp,matrix_hc,last_column=k) + CALL cp_dbcsr_multiply('n','n',1.0_dp,matrix_s,matrix_pz,0.0_dp,matrix_sc,last_column=k) ! compute the bottom right ZSZ - CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_sc,0.0_dp,matrix_mm,last_column=k,error=error) + CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_sc,0.0_dp,matrix_mm,last_column=k) ! set the bottom right part of S[C,Z] block matrix ZSZ - CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm,error=error) - CALL cp_fm_to_fm_submat(matrix_mm_fm,s_block,nmat,nmat,1,1,1+nmat,1+nmat,error=error) + CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm) + CALL cp_fm_to_fm_submat(matrix_mm_fm,s_block,nmat,nmat,1,1,1+nmat,1+nmat) ! compute the bottom right ZHZ - CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_hc,0.0_dp,matrix_mm,last_column=k,error=error) + CALL cp_dbcsr_multiply('t','n',1.0_dp,matrix_pz,matrix_hc,0.0_dp,matrix_mm,last_column=k) ! set the bottom right part of H[C,Z] block matrix ZHZ - CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm,error=error) - CALL cp_fm_to_fm_submat(matrix_mm_fm,h_block,nmat,nmat,1,1,1+nmat,1+nmat,error=error) + CALL copy_dbcsr_to_fm(matrix_mm,matrix_mm_fm) + CALL cp_fm_to_fm_submat(matrix_mm_fm,h_block,nmat,nmat,1,1,1+nmat,1+nmat) - CALL cp_dbcsr_release_p(matrix_mm, error=error) - CALL cp_dbcsr_release_p(matrix_sc, error=error) - CALL cp_dbcsr_release_p(matrix_hc, error=error) + CALL cp_dbcsr_release_p(matrix_mm) + CALL cp_dbcsr_release_p(matrix_sc) + CALL cp_dbcsr_release_p(matrix_hc) - CALL reduce_extended_space(s_block,h_block,v_block,w_block, evals, nmat2, error=error) + CALL reduce_extended_space(s_block,h_block,v_block,w_block, evals, nmat2) ! allocate two (nao x nmat) full matrix CALL cp_fm_struct_create(fm_struct_tmp,nrow_global=nao,ncol_global=nmat, & context=mo_coeff%matrix_struct%context, & - para_env=mo_coeff%matrix_struct%para_env,error=error) - CALL cp_fm_create(matrix_nm_fm,fm_struct_tmp,name="m_nxm",error=error) - CALL cp_fm_create(matrix_z_fm,fm_struct_tmp,name="m_nxm",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + para_env=mo_coeff%matrix_struct%para_env) + CALL cp_fm_create(matrix_nm_fm,fm_struct_tmp,name="m_nxm") + CALL cp_fm_create(matrix_z_fm,fm_struct_tmp,name="m_nxm") + CALL cp_fm_struct_release(fm_struct_tmp) - CALL copy_dbcsr_to_fm(matrix_pz,matrix_z_fm,error=error) + CALL copy_dbcsr_to_fm(matrix_pz,matrix_z_fm) ! extract egenvectors - CALL cp_fm_to_fm_submat(v_block,matrix_mm_fm, nmat,nmat,1,1,1,1,error=error) - CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,mo_notconv_fm,matrix_mm_fm,0.0_dp,matrix_nm_fm,error=error) - CALL cp_fm_to_fm_submat(v_block,matrix_mm_fm, nmat,nmat,1+nmat,1,1,1,error=error) - CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,matrix_z_fm,matrix_mm_fm,1.0_dp,matrix_nm_fm,error=error) + CALL cp_fm_to_fm_submat(v_block,matrix_mm_fm, nmat,nmat,1,1,1,1) + CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,mo_notconv_fm,matrix_mm_fm,0.0_dp,matrix_nm_fm) + CALL cp_fm_to_fm_submat(v_block,matrix_mm_fm, nmat,nmat,1+nmat,1,1,1) + CALL cp_gemm('N','N',nao,nmat,nmat,1.0_dp,matrix_z_fm,matrix_mm_fm,1.0_dp,matrix_nm_fm) - CALL cp_dbcsr_release_p(matrix_z, error=error) - CALL cp_dbcsr_release_p(matrix_pz, error=error) - CALL cp_fm_release(matrix_z_fm,error=error) - CALL cp_fm_release(s_block,error=error) - CALL cp_fm_release(h_block,error=error) - CALL cp_fm_release(w_block,error=error) - CALL cp_fm_release(v_block,error=error) - CALL cp_fm_release(matrix_mm_fm,error=error) + CALL cp_dbcsr_release_p(matrix_z) + CALL cp_dbcsr_release_p(matrix_pz) + CALL cp_fm_release(matrix_z_fm) + CALL cp_fm_release(s_block) + CALL cp_fm_release(h_block) + CALL cp_fm_release(w_block) + CALL cp_fm_release(v_block) + CALL cp_fm_release(matrix_mm_fm) ! in case some vector are already converged only a subset of vectors are copied in the MOS @@ -1001,27 +995,27 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp i_first=inotconv_set(j,1) i_last=inotconv_set(j,2) n=i_last-i_first+1 - CALL cp_fm_to_fm_submat(matrix_nm_fm,mo_coeff,nao,n,1,jj,1,i_first,error=error) + CALL cp_fm_to_fm_submat(matrix_nm_fm,mo_coeff,nao,n,1,jj,1,i_first) eigenvalues(i_first:i_last) = evals(jj:jj+n-1) jj=jj+n END DO DEALLOCATE(iconv_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (inotconv_set,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_release_p(mo_notconv, error=error) - CALL cp_dbcsr_release_p(c_out, error=error) - CALL cp_fm_release(mo_notconv_fm,error=error) + CALL cp_dbcsr_release_p(mo_notconv) + CALL cp_dbcsr_release_p(c_out) + CALL cp_fm_release(mo_notconv_fm) ELSE - CALL cp_fm_to_fm(matrix_nm_fm,mo_coeff,error=error) + CALL cp_fm_to_fm(matrix_nm_fm,mo_coeff) eigenvalues(1:nmo) = evals(1:nmo) END IF DEALLOCATE(evals,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_fm_release(matrix_nm_fm,error=error) - CALL copy_fm_to_dbcsr(mo_coeff,mo_coeff_b,error=error)!fm->dbcsr + CALL cp_fm_release(matrix_nm_fm) + CALL copy_fm_to_dbcsr(mo_coeff,mo_coeff_b)!fm->dbcsr t2 = m_walltime() IF (output_unit > 0) THEN @@ -1035,13 +1029,13 @@ SUBROUTINE generate_extended_space_sparse(bdav_env,mo_set,matrix_h,matrix_s,outp DEALLOCATE(ritz_coeff,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(iconv,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(inotconv,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(vnorm,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1057,15 +1051,13 @@ END SUBROUTINE generate_extended_space_sparse !> \param w_block ... !> \param evals ... !> \param ndim ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE reduce_extended_space(s_block,h_block,v_block,w_block, evals, ndim, error) + SUBROUTINE reduce_extended_space(s_block,h_block,v_block,w_block, evals, ndim) TYPE(cp_fm_type), POINTER :: s_block, h_block, v_block, & w_block REAL(dp), DIMENSION(:) :: evals INTEGER :: ndim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reduce_extended_space', & routineP = moduleN//':'//routineN @@ -1077,22 +1069,22 @@ SUBROUTINE reduce_extended_space(s_block,h_block,v_block,w_block, evals, ndim, CALL timeset(routineN,handle) - CALL cp_fm_to_fm(s_block,w_block,error=error) - CALL cp_fm_cholesky_decompose(s_block,info_out=info,error=error) + CALL cp_fm_to_fm(s_block,w_block) + CALL cp_fm_cholesky_decompose(s_block,info_out=info) IF(info==0) THEN - CALL cp_fm_triangular_invert(s_block,error=error) - CALL cp_fm_cholesky_restore(H_block,ndim,S_block,w_block,"MULTIPLY",pos="RIGHT",error=error) - CALL cp_fm_cholesky_restore(w_block,ndim,S_block,H_block,"MULTIPLY",pos="LEFT",transa="T",error=error) - CALL choose_eigv_solver(H_block,w_block,evals,error=error) - CALL cp_fm_cholesky_restore(w_block,ndim,S_block,v_block,"MULTIPLY",error=error) + CALL cp_fm_triangular_invert(s_block) + CALL cp_fm_cholesky_restore(H_block,ndim,S_block,w_block,"MULTIPLY",pos="RIGHT") + CALL cp_fm_cholesky_restore(w_block,ndim,S_block,H_block,"MULTIPLY",pos="LEFT",transa="T") + CALL choose_eigv_solver(H_block,w_block,evals) + CALL cp_fm_cholesky_restore(w_block,ndim,S_block,v_block,"MULTIPLY") ELSE ! S^(-1/2) - CALL cp_fm_power(w_block,s_block,-0.5_dp,1.0E-5_dp,info,error=error) - CALL cp_fm_to_fm(w_block,s_block,error=error) - CALL cp_gemm('N','N',ndim,ndim,ndim,1.0_dp,H_block,s_block,0.0_dp,w_block,error=error) - CALL cp_gemm('N','N',ndim,ndim,ndim,1.0_dp,s_block,w_block,0.0_dp,H_block,error=error) - CALL choose_eigv_solver(H_block,w_block,evals,error=error) - CALL cp_gemm('N','N',ndim,ndim,ndim,1.0_dp,s_block,w_block,0.0_dp,v_block,error=error) + CALL cp_fm_power(w_block,s_block,-0.5_dp,1.0E-5_dp,info) + CALL cp_fm_to_fm(w_block,s_block) + CALL cp_gemm('N','N',ndim,ndim,ndim,1.0_dp,H_block,s_block,0.0_dp,w_block) + CALL cp_gemm('N','N',ndim,ndim,ndim,1.0_dp,s_block,w_block,0.0_dp,H_block) + CALL choose_eigv_solver(H_block,w_block,evals) + CALL cp_gemm('N','N',ndim,ndim,ndim,1.0_dp,s_block,w_block,0.0_dp,v_block) END IF CALL timestop(handle) diff --git a/src/qs_scf_diagonalization.F b/src/qs_scf_diagonalization.F index c85f65d01a..e8aa2bb7fd 100644 --- a/src/qs_scf_diagonalization.F +++ b/src/qs_scf_diagonalization.F @@ -137,14 +137,13 @@ MODULE qs_scf_diagonalization !> \param scf_control ... !> \param scf_section ... !> \param diis_step ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE general_eigenproblem(scf_env,mos,matrix_ks,& matrix_s,scf_control,scf_section,& - diis_step,error) + diis_step) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(mo_set_p_type), DIMENSION(:), & @@ -154,7 +153,6 @@ SUBROUTINE general_eigenproblem(scf_env,mos,matrix_ks,& TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(INOUT) :: diis_step - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'general_eigenproblem', & routineP = moduleN//':'//routineN @@ -170,8 +168,7 @@ SUBROUTINE general_eigenproblem(scf_env,mos,matrix_ks,& DO ispin=1,nspin CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,& - scf_env%scf_work1(ispin)%matrix,& - error=error) + scf_env%scf_work1(ispin)%matrix) END DO eps_diis = scf_control%eps_diis @@ -181,7 +178,7 @@ SUBROUTINE general_eigenproblem(scf_env,mos,matrix_ks,& scf_env%scf_work2,scf_env%iter_delta,diis_error,diis_step,& eps_diis,scf_control%nmixing,& s_matrix=matrix_s,& - scf_section=scf_section,error=error) + scf_section=scf_section) ELSE diis_step = .FALSE. END IF @@ -231,7 +228,7 @@ SUBROUTINE general_eigenproblem(scf_env,mos,matrix_ks,& mo_set=mos(ispin)%mo_set,& ortho_dbcsr=ortho_dbcsr,& ksbuf1=scf_env%buf1_dbcsr,ksbuf2=scf_env%buf2_dbcsr,& - work=scf_env%scf_work2, error=error) + work=scf_env%scf_work2) END DO ELSE IF (scf_env%cholesky_method>cholesky_off) THEN @@ -246,8 +243,7 @@ SUBROUTINE general_eigenproblem(scf_env,mos,matrix_ks,& ortho=ortho,& work=scf_env%scf_work2,& cholesky_method=scf_env%cholesky_method,& - use_jacobi=use_jacobi,& - error=error) + use_jacobi=use_jacobi) END DO ELSE ortho => scf_env%ortho @@ -259,8 +255,7 @@ SUBROUTINE general_eigenproblem(scf_env,mos,matrix_ks,& do_level_shift=do_level_shift,& level_shift=scf_control%level_shift,& use_jacobi=use_jacobi,& - jacobi_threshold=scf_control%diagonalization%jacobi_threshold,& - error=error) + jacobi_threshold=scf_control%diagonalization%jacobi_threshold) END DO END IF @@ -275,11 +270,10 @@ END SUBROUTINE general_eigenproblem !> \param scf_control ... !> \param scf_section ... !> \param diis_step ... -!> \param error ... ! ***************************************************************************** SUBROUTINE do_general_diag( scf_env,mos,matrix_ks,& matrix_s,scf_control,scf_section,& - diis_step,error) + diis_step) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(mo_set_p_type), DIMENSION(:), & @@ -289,7 +283,6 @@ SUBROUTINE do_general_diag( scf_env,mos,matrix_ks,& TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(INOUT) :: diis_step - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_general_diag', & routineP = moduleN//':'//routineN @@ -299,17 +292,15 @@ SUBROUTINE do_general_diag( scf_env,mos,matrix_ks,& nspin = SIZE(matrix_ks) CALL general_eigenproblem(scf_env,mos,matrix_ks,& - matrix_s,scf_control,scf_section, diis_step,error=error) + matrix_s,scf_control,scf_section, diis_step) CALL set_mo_occupation(mo_array=mos,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) DO ispin=1,nspin ! does not yet handle k-points CALL calculate_density_matrix(mos(ispin)%mo_set,& - scf_env%p_mix_new(ispin,1)%matrix,& - error=error) + scf_env%p_mix_new(ispin,1)%matrix) END DO END SUBROUTINE do_general_diag @@ -326,13 +317,12 @@ END SUBROUTINE do_general_diag !> \param kpoints Kpoint environment !> \param scf_control SCF control variables !> \param diis_step Have we done a DIIS step -!> \param error CP2K error handling !> \par History !> 08.2014 created [JGH] ! ***************************************************************************** SUBROUTINE do_general_diag_kp(scf_env,matrix_ks,matrix_s,kpoints,& - scf_control,diis_step,error) + scf_control,diis_step) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -340,7 +330,6 @@ SUBROUTINE do_general_diag_kp(scf_env,matrix_ks,matrix_s,kpoints,& TYPE(kpoint_type), POINTER :: kpoints TYPE(scf_control_type), POINTER :: scf_control LOGICAL, INTENT(INOUT) :: diis_step - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'do_general_diag_kp', & routineP = moduleN//':'//routineN @@ -392,49 +381,49 @@ SUBROUTINE do_general_diag_kp(scf_env,matrix_ks,matrix_s,kpoints,& END IF ! We always do Cholesky - CPAssert(scf_env%cholesky_method>cholesky_off,cp_failure_level,routineP,error,failure) + CPAssert(scf_env%cholesky_method>cholesky_off,cp_failure_level,routineP,failure) NULLIFY(sab_nl) CALL get_kpoint_info(kpoints,nkp=nkp,xkp=xkp,use_real_wfn=use_real_wfn,kp_range=kp_range,& nkp_groups=nkp_groups,kp_dist=kp_dist,sab_nl=sab_nl,& - cell_to_index=cell_to_index,error=error) - CPAssert(ASSOCIATED(sab_nl),cp_failure_level,routineP,error,failure) + cell_to_index=cell_to_index) + CPAssert(ASSOCIATED(sab_nl),cp_failure_level,routineP,failure) kplocal = kp_range(2) - kp_range(1) + 1 ! allocate some work matrices ALLOCATE(rmatrix,cmatrix,tmpmat,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(rmatrix,error=error) - CALL cp_dbcsr_init(cmatrix,error=error) - CALL cp_dbcsr_init(tmpmat,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(rmatrix) + CALL cp_dbcsr_init(cmatrix) + CALL cp_dbcsr_init(tmpmat) CALL cp_dbcsr_create(rmatrix,template=matrix_ks(1,1)%matrix,& - matrix_type=dbcsr_type_symmetric,error=error) + matrix_type=dbcsr_type_symmetric) CALL cp_dbcsr_create(cmatrix,template=matrix_ks(1,1)%matrix,& - matrix_type=dbcsr_type_antisymmetric,error=error) + matrix_type=dbcsr_type_antisymmetric) CALL cp_dbcsr_create(tmpmat,template=matrix_ks(1,1)%matrix,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_alloc_block_from_nbl(rmatrix,sab_nl,error) - CALL cp_dbcsr_alloc_block_from_nbl(cmatrix,sab_nl,error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_alloc_block_from_nbl(rmatrix,sab_nl) + CALL cp_dbcsr_alloc_block_from_nbl(cmatrix,sab_nl) fmwork => scf_env%scf_work1 ! fm pools to be used within a kpoint group - CALL get_kpoint_info(kpoints,mpools=mpools,error=error) - CALL mpools_get(mpools,ao_ao_fm_pools=ao_ao_fm_pools,error=error) + CALL get_kpoint_info(kpoints,mpools=mpools) + CALL mpools_get(mpools,ao_ao_fm_pools=ao_ao_fm_pools) - CALL fm_pool_create_fm(ao_ao_fm_pools(1)%pool,fmlocal,error=error) - CALL cp_fm_get_info(fmlocal,matrix_struct=matrix_struct,error=error) + CALL fm_pool_create_fm(ao_ao_fm_pools(1)%pool,fmlocal) + CALL cp_fm_get_info(fmlocal,matrix_struct=matrix_struct) IF(use_real_wfn) THEN - CALL cp_fm_create(rksmat,matrix_struct,error=error) - CALL cp_fm_create(rsmat,matrix_struct,error=error) + CALL cp_fm_create(rksmat,matrix_struct) + CALL cp_fm_create(rsmat,matrix_struct) ELSE - CALL cp_cfm_create(cksmat,matrix_struct,error=error) - CALL cp_cfm_create(csmat,matrix_struct,error=error) - CALL cp_cfm_create(cwork,matrix_struct,error=error) + CALL cp_cfm_create(cksmat,matrix_struct) + CALL cp_cfm_create(csmat,matrix_struct) + CALL cp_cfm_create(cwork,matrix_struct) kp => kpoints%kp_env(1)%kpoint_env CALL get_mo_set(kp%mos(1,1)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_get_info(mo_coeff,matrix_struct=mo_struct,error=error) - CALL cp_cfm_create(cmos,mo_struct,error=error) + CALL cp_fm_get_info(mo_coeff,matrix_struct=mo_struct) + CALL cp_cfm_create(cmos,mo_struct) END IF ! global blacs context (=groupid) @@ -449,27 +438,27 @@ SUBROUTINE do_general_diag_kp(scf_env,matrix_ks,matrix_s,kpoints,& IF(use_real_wfn) THEN ! FT of matrices KS and S, then transfer to FM type CALL rskp_transform(rmatrix=rmatrix,rsmat=matrix_ks,ispin=ispin,& - xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl,error=error) - CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat,error=error) - CALL copy_dbcsr_to_fm(tmpmat,fmwork(1)%matrix,error=error) + xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl) + CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat) + CALL copy_dbcsr_to_fm(tmpmat,fmwork(1)%matrix) CALL rskp_transform(rmatrix=rmatrix,rsmat=matrix_s,ispin=ispin,& - xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl,error=error) - CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat,error=error) - CALL copy_dbcsr_to_fm(tmpmat,fmwork(3)%matrix,error=error) + xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl) + CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat) + CALL copy_dbcsr_to_fm(tmpmat,fmwork(3)%matrix) ELSE ! FT of matrices KS and S, then transfer to FM type CALL rskp_transform(rmatrix=rmatrix,cmatrix=cmatrix,rsmat=matrix_ks,ispin=ispin,& - xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl,error=error) - CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat,error=error) - CALL copy_dbcsr_to_fm(tmpmat,fmwork(1)%matrix,error=error) - CALL cp_dbcsr_desymmetrize(cmatrix,tmpmat,error=error) - CALL copy_dbcsr_to_fm(tmpmat,fmwork(2)%matrix,error=error) + xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl) + CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat) + CALL copy_dbcsr_to_fm(tmpmat,fmwork(1)%matrix) + CALL cp_dbcsr_desymmetrize(cmatrix,tmpmat) + CALL copy_dbcsr_to_fm(tmpmat,fmwork(2)%matrix) CALL rskp_transform(rmatrix=rmatrix,cmatrix=cmatrix,rsmat=matrix_s,ispin=ispin,& - xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl,error=error) - CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat,error=error) - CALL copy_dbcsr_to_fm(tmpmat,fmwork(3)%matrix,error=error) - CALL cp_dbcsr_desymmetrize(cmatrix,tmpmat,error=error) - CALL copy_dbcsr_to_fm(tmpmat,fmwork(4)%matrix,error=error) + xkp=xkp(1:3,ik),cell_to_index=cell_to_index,sab_nl=sab_nl) + CALL cp_dbcsr_desymmetrize(rmatrix,tmpmat) + CALL copy_dbcsr_to_fm(tmpmat,fmwork(3)%matrix) + CALL cp_dbcsr_desymmetrize(cmatrix,tmpmat) + CALL copy_dbcsr_to_fm(tmpmat,fmwork(4)%matrix) END IF ! transfer to kpoint group ! redistribution of matrices, new blacs environment @@ -477,27 +466,27 @@ SUBROUTINE do_general_diag_kp(scf_env,matrix_ks,matrix_s,kpoints,& ! fmwork -> fmlocal -> rsmat/csmat IF(use_real_wfn) THEN IF(my_kpgrp) THEN - CALL cp_fm_copy_general(fmwork(1)%matrix,rksmat,bcntxt,error) - CALL cp_fm_copy_general(fmwork(3)%matrix,rsmat,bcntxt,error) + CALL cp_fm_copy_general(fmwork(1)%matrix,rksmat,bcntxt) + CALL cp_fm_copy_general(fmwork(3)%matrix,rsmat,bcntxt) ELSE - CALL cp_fm_copy_general(fmwork(1)%matrix,fmdummy,bcntxt,error) - CALL cp_fm_copy_general(fmwork(3)%matrix,fmdummy,bcntxt,error) + CALL cp_fm_copy_general(fmwork(1)%matrix,fmdummy,bcntxt) + CALL cp_fm_copy_general(fmwork(3)%matrix,fmdummy,bcntxt) END IF ELSE IF(my_kpgrp) THEN - CALL cp_fm_copy_general(fmwork(1)%matrix,fmlocal,bcntxt,error) - CALL cp_cfm_add_fm(czero,cksmat,cone,fmlocal,error) - CALL cp_fm_copy_general(fmwork(2)%matrix,fmlocal,bcntxt,error) - CALL cp_cfm_add_fm(cone,cksmat,ione,fmlocal,error) - CALL cp_fm_copy_general(fmwork(3)%matrix,fmlocal,bcntxt,error) - CALL cp_cfm_add_fm(czero,csmat,cone,fmlocal,error) - CALL cp_fm_copy_general(fmwork(4)%matrix,fmlocal,bcntxt,error) - CALL cp_cfm_add_fm(cone,csmat,ione,fmlocal,error) + CALL cp_fm_copy_general(fmwork(1)%matrix,fmlocal,bcntxt) + CALL cp_cfm_add_fm(czero,cksmat,cone,fmlocal) + CALL cp_fm_copy_general(fmwork(2)%matrix,fmlocal,bcntxt) + CALL cp_cfm_add_fm(cone,cksmat,ione,fmlocal) + CALL cp_fm_copy_general(fmwork(3)%matrix,fmlocal,bcntxt) + CALL cp_cfm_add_fm(czero,csmat,cone,fmlocal) + CALL cp_fm_copy_general(fmwork(4)%matrix,fmlocal,bcntxt) + CALL cp_cfm_add_fm(cone,csmat,ione,fmlocal) ELSE - CALL cp_fm_copy_general(fmwork(1)%matrix,fmdummy,bcntxt,error) - CALL cp_fm_copy_general(fmwork(2)%matrix,fmdummy,bcntxt,error) - CALL cp_fm_copy_general(fmwork(3)%matrix,fmdummy,bcntxt,error) - CALL cp_fm_copy_general(fmwork(4)%matrix,fmdummy,bcntxt,error) + CALL cp_fm_copy_general(fmwork(1)%matrix,fmdummy,bcntxt) + CALL cp_fm_copy_general(fmwork(2)%matrix,fmdummy,bcntxt) + CALL cp_fm_copy_general(fmwork(3)%matrix,fmdummy,bcntxt) + CALL cp_fm_copy_general(fmwork(4)%matrix,fmdummy,bcntxt) END IF END IF END DO @@ -506,41 +495,41 @@ SUBROUTINE do_general_diag_kp(scf_env,matrix_ks,matrix_s,kpoints,& kp => kpoints%kp_env(ikpgr)%kpoint_env IF(use_real_wfn) THEN CALL get_mo_set(kp%mos(1,ispin)%mo_set,mo_coeff=mo_coeff,eigenvalues=eigenvalues) - CALL cp_fm_geeig(rksmat,rsmat,mo_coeff,eigenvalues,fmlocal,error) + CALL cp_fm_geeig(rksmat,rsmat,mo_coeff,eigenvalues,fmlocal) ELSE CALL get_mo_set(kp%mos(1,ispin)%mo_set,mo_coeff=rmos,eigenvalues=eigenvalues) CALL get_mo_set(kp%mos(2,ispin)%mo_set,mo_coeff=imos) - CALL cp_cfm_geeig(cksmat,csmat,cmos,eigenvalues,cwork,error) + CALL cp_cfm_geeig(cksmat,csmat,cmos,eigenvalues,cwork) ! copy eigenvalues to imag set (keep them in sync) kp%mos(2,ispin)%mo_set%eigenvalues=eigenvalues ! split real and imaginary part of mos - CALL cp_cfm_to_fm(cmos,rmos,imos,error) + CALL cp_cfm_to_fm(cmos,rmos,imos) END IF END DO END DO ! MO occupations - CALL kpoint_set_mo_occupation(kpoints,scf_control%smear,error) + CALL kpoint_set_mo_occupation(kpoints,scf_control%smear) ! density matrices - CALL kpoint_density_matrices(kpoints,error=error) + CALL kpoint_density_matrices(kpoints) ! density matrices in real space CALL kpoint_density_transform(kpoints,scf_env%p_mix_new,.FALSE.,& - matrix_s(1,1)%matrix,sab_nl,fmwork,error) + matrix_s(1,1)%matrix,sab_nl,fmwork) - CALL cp_dbcsr_deallocate_matrix(rmatrix,error=error) - CALL cp_dbcsr_deallocate_matrix(cmatrix,error=error) - CALL cp_dbcsr_deallocate_matrix(tmpmat,error=error) + CALL cp_dbcsr_deallocate_matrix(rmatrix) + CALL cp_dbcsr_deallocate_matrix(cmatrix) + CALL cp_dbcsr_deallocate_matrix(tmpmat) IF(use_real_wfn) THEN - CALL cp_fm_release(rksmat,error=error) - CALL cp_fm_release(rsmat,error=error) + CALL cp_fm_release(rksmat) + CALL cp_fm_release(rsmat) ELSE - CALL cp_cfm_release(cksmat,error=error) - CALL cp_cfm_release(csmat,error=error) - CALL cp_cfm_release(cwork,error=error) - CALL cp_cfm_release(cmos,error=error) + CALL cp_cfm_release(cksmat) + CALL cp_cfm_release(csmat) + CALL cp_cfm_release(cwork) + CALL cp_cfm_release(cmos) END IF - CALL fm_pool_give_back_fm(ao_ao_fm_pools(1)%pool, fmlocal, error=error) + CALL fm_pool_give_back_fm(ao_ao_fm_pools(1)%pool, fmlocal) END SUBROUTINE do_general_diag_kp @@ -555,13 +544,12 @@ END SUBROUTINE do_general_diag_kp !> \param ks_env ... !> \param scf_section ... !> \param scf_control ... -!> \param error ... !> \par History !> 09.2009 created [MI] !> \note it is assumed that when diagonalization is used, also some mixing procedure is active ! ***************************************************************************** SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& - ks_env,scf_section,scf_control,error) + ks_env,scf_section,scf_control) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env @@ -572,7 +560,6 @@ SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(section_vals_type), POINTER :: scf_section TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_scf_diag_subspace', & routineP = moduleN//':'//routineN @@ -605,37 +592,37 @@ SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& NULLIFY(c0, chc, energy, evec, matrix_ks, mo_coeff, mo_eigenvalues, & mo_occupations, work, dft_control, rho_ao, rho_ao_kp) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%DIAG_SUB_SCF",& - extension=".scfLog",error=error) + extension=".scfLog") !Extra loop keeping mos unchanged and refining the subspace occupation work => scf_env%scf_work2 nspin = SIZE(mos) - CALL qs_rho_get(rho, rho_ao=rho_ao, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao, rho_ao_kp=rho_ao_kp) ALLOCATE( eval_first(nspin), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE( occ_first(nspin),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin=1,nspin CALL get_mo_set(mo_set=mos(ispin)%mo_set,& nmo=nmo,& eigenvalues=mo_eigenvalues,& occupation_numbers=mo_occupations) ALLOCATE( eval_first(ispin)%array(nmo),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE( occ_first(ispin)%array(nmo),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) eval_first(ispin)%array(1:nmo) = mo_eigenvalues(1:nmo) occ_first(ispin)%array(1:nmo) = mo_occupations(1:nmo) END DO DO ispin=1,nspin ! does not yet handle k-points - CALL cp_dbcsr_copy(subspace_env%p_matrix_store(ispin)%matrix, rho_ao(ispin)%matrix,error=error ) - CALL cp_dbcsr_copy(rho_ao(ispin)%matrix, scf_env%p_mix_new(ispin, 1)%matrix,error=error ) + CALL cp_dbcsr_copy(subspace_env%p_matrix_store(ispin)%matrix, rho_ao(ispin)%matrix) + CALL cp_dbcsr_copy(rho_ao(ispin)%matrix, scf_env%p_mix_new(ispin, 1)%matrix) END DO subspace_env%p_matrix_mix => scf_env%p_mix_new @@ -646,21 +633,20 @@ SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& energy=energy, & matrix_s=matrix_s,& para_env=para_env,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! mixing storage allocation IF (subspace_env%mixing_method>=gspace_mixing_nr) THEN CALL mixing_allocate(qs_env,subspace_env%mixing_method,scf_env%p_mix_new, & - scf_env%p_delta,nspin,subspace_env%mixing_store,error) + scf_env%p_delta,nspin,subspace_env%mixing_store) IF(dft_control%qs_control%gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho_atom_set=rho_atom,error=error) + rho_atom_set=rho_atom) CALL mixing_init(subspace_env%mixing_method,rho,subspace_env%mixing_store,& - para_env,rho_atom=rho_atom,error=error) + para_env,rho_atom=rho_atom) ELSE CALL mixing_init(subspace_env%mixing_method,rho,subspace_env%mixing_store,& - para_env,error=error) + para_env) END IF END IF @@ -675,16 +661,16 @@ SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& ! recalculate density matrix here ! update of density - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) DO iloop = 1,subspace_env%max_iter t1 = m_walltime() converged=.FALSE. ene_old = energy%total - CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.,error=error) + CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.) CALL qs_ks_update_qs_env(qs_env,calculate_forces=.FALSE.,& - just_energy=.FALSE.,print_active=.FALSE.,error=error) + just_energy=.FALSE.,print_active=.FALSE.) max_val = 0.0_dp sum_val = 0.0_dp @@ -701,23 +687,21 @@ SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& chc => subspace_env%chc_mat(ispin)%matrix evec => subspace_env%c_vec(ispin)%matrix c0 => subspace_env%c0(ispin)%matrix - CALL cp_fm_to_fm(mo_coeff,c0,error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_ks(ispin)%matrix,c0,work,nmo,error=error) - CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,work,rzero,chc,error=error) + CALL cp_fm_to_fm(mo_coeff,c0) + CALL cp_dbcsr_sm_fm_multiply(matrix_ks(ispin)%matrix,c0,work,nmo) + CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,work,rzero,chc) !diagonalize C'HC - CALL choose_eigv_solver(chc,evec,mo_eigenvalues,error=error) + CALL choose_eigv_solver(chc,evec,mo_eigenvalues) !rotate the mos by the eigenvectors of C'HC - CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,mo_coeff,error=error) + CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,mo_coeff) CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) ! does not yet handle k-points CALL calculate_density_matrix(mos(ispin)%mo_set,& - subspace_env%p_matrix_mix(ispin, 1)%matrix,& - error=error) + subspace_env%p_matrix_mix(ispin, 1)%matrix) DO i = 1, nmo sum_band = sum_band + mo_eigenvalues(i)*mo_occupations(i) @@ -728,23 +712,22 @@ SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& IF(subspace_env%mixing_method==direct_mixing_nr) THEN CALL scf_env_density_mixing(subspace_env%p_matrix_mix, & - scf_env%mixing_store, rho_ao_kp, para_env, iter_delta, iloop, & - error=error) + scf_env%mixing_store, rho_ao_kp, para_env, iter_delta, iloop) ELSE CALL self_consistency_check(rho_ao_kp,scf_env%p_delta,para_env,& - subspace_env%p_matrix_mix,delta=iter_delta,error=error) + subspace_env%p_matrix_mix,delta=iter_delta) END IF DO ispin=1,nspin ! does not yet handle k-points - CALL cp_dbcsr_copy(rho_ao(ispin)%matrix,subspace_env%p_matrix_mix(ispin,1)%matrix ,error=error ) + CALL cp_dbcsr_copy(rho_ao(ispin)%matrix,subspace_env%p_matrix_mix(ispin,1)%matrix) END DO ! update of density - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) ! Mixing in reciprocal space IF(subspace_env%mixing_method>=gspace_mixing_nr) THEN CALL gspace_mixing(qs_env, scf_env%mixing_method, subspace_env%mixing_store, & - rho, para_env, scf_env%iter_count, error=error) + rho, para_env, scf_env%iter_count) END IF ene_diff = energy%total-ene_old @@ -767,8 +750,8 @@ SUBROUTINE do_scf_diag_subspace(qs_env,scf_env,subspace_env,mos,rho,& NULLIFY (subspace_env%p_matrix_mix) DO ispin=1,nspin ! does not yet handle k-points - CALL cp_dbcsr_copy(scf_env%p_mix_new(ispin,1)%matrix,rho_ao(ispin)%matrix,error=error ) - CALL cp_dbcsr_copy(rho_ao(ispin)%matrix, subspace_env%p_matrix_store(ispin)%matrix ,error=error ) + CALL cp_dbcsr_copy(scf_env%p_mix_new(ispin,1)%matrix,rho_ao(ispin)%matrix) + CALL cp_dbcsr_copy(rho_ao(ispin)%matrix, subspace_env%p_matrix_store(ispin)%matrix) DEALLOCATE(eval_first(ispin)%array,occ_first(ispin)%array) END DO @@ -784,15 +767,13 @@ END SUBROUTINE do_scf_diag_subspace !> \param subspace_env ... !> \param qs_env ... !> \param mos ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE diag_subspace_allocate(subspace_env,qs_env,mos,error) +SUBROUTINE diag_subspace_allocate(subspace_env,qs_env,mos) TYPE(subspace_env_type), POINTER :: subspace_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'diag_subspace_allocate', & routineP = moduleN//':'//routineN @@ -813,47 +794,46 @@ SUBROUTINE diag_subspace_allocate(subspace_env,qs_env,mos,error) NULLIFY(sab_orb, matrix_s) CALL get_qs_env(qs_env=qs_env, sab_orb=sab_orb, & - matrix_s=matrix_s, & - error=error) + matrix_s=matrix_s) nspin = SIZE(mos) ! *** allocate p_atrix_store *** IF (.NOT.ASSOCIATED(subspace_env%p_matrix_store)) THEN - CALL cp_dbcsr_allocate_matrix_set(subspace_env%p_matrix_store,nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(subspace_env%p_matrix_store,nspin) DO i=1,nspin ALLOCATE(subspace_env%p_matrix_store(i)%matrix) - CALL cp_dbcsr_init(subspace_env%p_matrix_store(i)%matrix,error=error) + CALL cp_dbcsr_init(subspace_env%p_matrix_store(i)%matrix) CALL cp_dbcsr_create(matrix=subspace_env%p_matrix_store(i)%matrix, & name="DENSITY_STORE", & dist=cp_dbcsr_distribution(matrix_s(1)%matrix), matrix_type=dbcsr_type_symmetric,& row_blk_size=cp_dbcsr_row_block_sizes(matrix_s(1)%matrix), & col_blk_size=cp_dbcsr_col_block_sizes(matrix_s(1)%matrix), & - nze=0, error=error) + nze=0) CALL cp_dbcsr_alloc_block_from_nbl(subspace_env%p_matrix_store(i)%matrix,& - sab_orb, error=error) - CALL cp_dbcsr_set(subspace_env%p_matrix_store(i)%matrix,0.0_dp,error=error) + sab_orb) + CALL cp_dbcsr_set(subspace_env%p_matrix_store(i)%matrix,0.0_dp) ENDDO END IF ALLOCATE(subspace_env%chc_mat(nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(subspace_env%c_vec(nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(subspace_env%c0(nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspin CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff, nmo=nmo) - CALL cp_fm_create(subspace_env%c0(ispin)%matrix,mo_coeff%matrix_struct,error=error) + CALL cp_fm_create(subspace_env%c0(ispin)%matrix,mo_coeff%matrix_struct) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nmo, ncol_global=nmo,& para_env=mo_coeff%matrix_struct%para_env, & - context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create(subspace_env%chc_mat(ispin)%matrix,fm_struct_tmp,"chc",error=error) - CALL cp_fm_create(subspace_env%c_vec(ispin)%matrix,fm_struct_tmp,"vec",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(subspace_env%chc_mat(ispin)%matrix,fm_struct_tmp,"chc") + CALL cp_fm_create(subspace_env%c_vec(ispin)%matrix,fm_struct_tmp,"vec") + CALL cp_fm_struct_release(fm_struct_tmp) END DO CALL timestop(handle) @@ -869,12 +849,11 @@ END SUBROUTINE diag_subspace_allocate !> \param scf_control ... !> \param scf_section ... !> \param diis_step ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE do_special_diag(scf_env,mos,matrix_ks,scf_control,& - scf_section,diis_step,error) + scf_section,diis_step) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(mo_set_p_type), DIMENSION(:), & @@ -884,7 +863,6 @@ SUBROUTINE do_special_diag(scf_env,mos,matrix_ks,scf_control,& TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(INOUT) :: diis_step - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ispin, nspin LOGICAL :: do_level_shift, use_jacobi @@ -893,14 +871,13 @@ SUBROUTINE do_special_diag(scf_env,mos,matrix_ks,scf_control,& nspin = SIZE(matrix_ks) DO ispin=1,nspin - CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,scf_env%scf_work1(ispin)%matrix,error=error) + CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,scf_env%scf_work1(ispin)%matrix) END DO IF (scf_env%iter_count > 1 .AND. .NOT. scf_env%skip_diis) THEN CALL qs_diis_b_step(scf_env%scf_diis_buffer,mos,scf_env%scf_work1,& scf_env%scf_work2,scf_env%iter_delta,diis_error,diis_step,& scf_control%eps_diis,scf_control%nmixing,& - scf_section=scf_section,& - error=error) + scf_section=scf_section) ELSE diis_step = .FALSE. END IF @@ -946,19 +923,16 @@ SUBROUTINE do_special_diag(scf_env,mos,matrix_ks,scf_control,& do_level_shift=do_level_shift,& level_shift=scf_control%level_shift,& use_jacobi=use_jacobi,& - jacobi_threshold=scf_control%diagonalization%jacobi_threshold,& - error=error) + jacobi_threshold=scf_control%diagonalization%jacobi_threshold) END DO CALL set_mo_occupation(mo_array=mos,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) DO ispin=1,nspin ! does not yet handle k-points CALL calculate_density_matrix(mos(ispin)%mo_set,& - scf_env%p_mix_new(ispin, 1)%matrix,& - error=error) + scf_env%p_mix_new(ispin, 1)%matrix) END DO END SUBROUTINE do_special_diag @@ -973,12 +947,11 @@ END SUBROUTINE do_special_diag !> \param scf_control ... !> \param scf_section ... !> \param diis_step ... -!> \param error ... !> \par History !> 10.2008 created [JGH] ! ***************************************************************************** SUBROUTINE do_ot_diag(scf_env,mos,matrix_ks,matrix_s,& - scf_control,scf_section,diis_step,error) + scf_control,scf_section,diis_step) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(mo_set_p_type), DIMENSION(:), & @@ -988,7 +961,6 @@ SUBROUTINE do_ot_diag(scf_env,mos,matrix_ks,matrix_s,& TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(INOUT) :: diis_step - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_ot_diag', & routineP = moduleN//':'//routineN @@ -1005,8 +977,7 @@ SUBROUTINE do_ot_diag(scf_env,mos,matrix_ks,matrix_s,& DO ispin=1,nspin CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,& - scf_env%scf_work1(ispin)%matrix,& - error=error) + scf_env%scf_work1(ispin)%matrix) END DO IF ((scf_env%iter_count > 1).AND.(.NOT.scf_env%skip_diis)) THEN @@ -1014,7 +985,7 @@ SUBROUTINE do_ot_diag(scf_env,mos,matrix_ks,matrix_s,& scf_env%scf_work2,scf_env%iter_delta,diis_error,diis_step,& scf_control%eps_diis,scf_control%nmixing,& s_matrix=matrix_s,& - scf_section=scf_section,error=error) + scf_section=scf_section) ELSE diis_step = .FALSE. END IF @@ -1029,8 +1000,7 @@ SUBROUTINE do_ot_diag(scf_env,mos,matrix_ks,matrix_s,& scf_env%iter_method = "DIIS/OTdiag" DO ispin=1,nspin CALL copy_fm_to_dbcsr(scf_env%scf_work1(ispin)%matrix,& - matrix_ks(ispin)%matrix,keep_sparsity=.TRUE.,& - error=error) + matrix_ks(ispin)%matrix,keep_sparsity=.TRUE.) END DO eps_iter = MAX(eps_iter,scf_control%diagonalization%eps_adapt*diis_error) ELSE @@ -1058,27 +1028,23 @@ SUBROUTINE do_ot_diag(scf_env,mos,matrix_ks,matrix_s,& eps_gradient=eps_iter,& iter_max=scf_control%diagonalization%max_iter,& silent=.TRUE.,& - ot_settings=scf_control%diagonalization%ot_settings,& - error=error) + ot_settings=scf_control%diagonalization%ot_settings) CALL calculate_subspace_eigenvalues(mo_coeff,matrix_ks(ispin)%matrix,& evals_arg=eigenvalues,& - do_rotation=.TRUE.,& - error=error) + do_rotation=.TRUE.) !MK WRITE(*,*) routinen//' copy_dbcsr_to_fm' CALL copy_fm_to_dbcsr(mos(ispin)%mo_set%mo_coeff,& - mos(ispin)%mo_set%mo_coeff_b,& - error=error)!fm->dbcsr + mos(ispin)%mo_set%mo_coeff_b) + !fm->dbcsr END DO CALL set_mo_occupation(mo_array=mos,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) DO ispin=1,nspin ! does not yet handle k-points CALL calculate_density_matrix(mos(ispin)%mo_set,& - scf_env%p_mix_new(ispin, 1)%matrix,& - error=error) + scf_env%p_mix_new(ispin, 1)%matrix) END DO END SUBROUTINE do_ot_diag @@ -1094,7 +1060,6 @@ END SUBROUTINE do_ot_diag !> \param scf_section ... !> \param diis_step ... !> \param orthogonal_basis ... -!> \param error ... !> \par History !> 04.2006 created [MK] !> Revised (01.05.06,MK) @@ -1103,7 +1068,7 @@ END SUBROUTINE do_ot_diag ! ***************************************************************************** SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& scf_control,scf_section,diis_step,& - orthogonal_basis,error) + orthogonal_basis) ! Literature: - C. C. J. Roothaan, Rev. Mod. Phys. 32, 179 (1960) ! - M. F. Guest and V. R. Saunders, Mol. Phys. 28(3), 819 (1974) @@ -1118,7 +1083,6 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(INOUT) :: diis_step LOGICAL, INTENT(IN) :: orthogonal_basis - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_roks_diag', & routineP = moduleN//':'//routineN @@ -1144,8 +1108,8 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& ksa => scf_env%scf_work1(1)%matrix ksb => scf_env%scf_work1(2)%matrix - CALL copy_dbcsr_to_fm(matrix_ks(1)%matrix,ksa,error=error) - CALL copy_dbcsr_to_fm(matrix_ks(2)%matrix,ksb,error=error) + CALL copy_dbcsr_to_fm(matrix_ks(1)%matrix,ksa) + CALL copy_dbcsr_to_fm(matrix_ks(2)%matrix,ksb) ! Get MO information @@ -1183,21 +1147,20 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& ! Transform the spin unrestricted alpha and beta Kohn-Sham matrices ! from AO basis to MO basis: K(MO) = C(T)*K(AO)*C - CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksa,moa,0.0_dp,work,error=error) - CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,moa,work,0.0_dp,ksa,error=error) + CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksa,moa,0.0_dp,work) + CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,moa,work,0.0_dp,ksa) - CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksb,moa,0.0_dp,work,error=error) - CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,moa,work,0.0_dp,ksb,error=error) + CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksb,moa,0.0_dp,work) + CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,moa,work,0.0_dp,ksb) ! Combine the spin unrestricted alpha and beta Kohn-Sham matrices ! in the MO basis IF (scf_control%roks_scheme == general_roks) THEN CALL combine_ks_matrices(ksa,ksb,occa,occb,scf_control%roks_f,& - nalpha,nbeta,error=error) + nalpha,nbeta) ELSE IF (scf_control%roks_scheme == high_spin_roks) THEN - CALL combine_ks_matrices(ksa,ksb,occa,occb,scf_control%roks_parameter,& - error=error) + CALL combine_ks_matrices(ksa,ksb,occa,occb,scf_control%roks_parameter) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "Unknown ROKS scheme requested") @@ -1214,13 +1177,13 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& mo2ao => mob !MK CALL copy_sm_to_fm(matrix_s(1)%matrix,work) !MK CALL cp_fm_symm("L","U",nao,nao,1.0_dp,work,moa,0.0_dp,mo2ao) - CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,moa,mo2ao,nao,error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,moa,mo2ao,nao) END IF ! K(AO) = Q*K(MO)*Q(T) - CALL cp_gemm("N","T",nao,nao,nao,1.0_dp,ksa,mo2ao,0.0_dp,work,error=error) - CALL cp_gemm("N","N",nao,nao,nao,1.0_dp,mo2ao,work,0.0_dp,ksa,error=error) + CALL cp_gemm("N","T",nao,nao,nao,1.0_dp,ksa,mo2ao,0.0_dp,work) + CALL cp_gemm("N","N",nao,nao,nao,1.0_dp,mo2ao,work,0.0_dp,ksa) ELSE @@ -1228,7 +1191,7 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& ! i.e. the beta Kohn-Sham matrix in AO basis, is taken. ! There might be better choices, anyhow. - CALL cp_fm_to_fm(ksb,ksa,error=error) + CALL cp_fm_to_fm(ksb,ksa) END IF @@ -1245,8 +1208,7 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& diis_step=diis_step,& eps_diis=scf_control%eps_diis,& scf_section=scf_section,& - roks=.TRUE.,& - error=error) + roks=.TRUE.) ELSE CALL qs_diis_b_step(diis_buffer=scf_env%scf_diis_buffer,& mo_array=mos,& @@ -1258,8 +1220,7 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& eps_diis=scf_control%eps_diis,& scf_section=scf_section,& s_matrix=matrix_s,& - roks=.TRUE.,& - error=error) + roks=.TRUE.) END IF END IF @@ -1283,16 +1244,16 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& ! Transform the current Kohn-Sham matrix from AO to MO basis ! for level-shifting using the current MO set - CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksa,moa,0.0_dp,work,error=error) - CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,moa,work,0.0_dp,ksa,error=error) + CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksa,moa,0.0_dp,work) + CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,moa,work,0.0_dp,ksa) ! Apply level-shifting using 50:50 split of the shift (could be relaxed) DO imo=homob+1,homoa - CALL cp_fm_add_to_element(ksa,imo,imo,0.5_dp*level_shift_loc,error) + CALL cp_fm_add_to_element(ksa,imo,imo,0.5_dp*level_shift_loc) END DO DO imo=homoa+1,nmo - CALL cp_fm_add_to_element(ksa,imo,imo,level_shift_loc,error) + CALL cp_fm_add_to_element(ksa,imo,imo,level_shift_loc) END DO ELSE IF (.NOT.orthogonal_basis) THEN @@ -1300,47 +1261,47 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& ! Transform the current Kohn-Sham matrix to an orthogonal basis SELECT CASE(scf_env%cholesky_method) CASE(cholesky_reduce) - CALL cp_fm_cholesky_reduce(ksa,ortho,error=error) + CALL cp_fm_cholesky_reduce(ksa,ortho) CASE(cholesky_restore) - CALL cp_fm_upper_to_full(ksa,work,error=error) + CALL cp_fm_upper_to_full(ksa,work) CALL cp_fm_cholesky_restore(ksa,nao,ortho,work,& - "SOLVE",pos="RIGHT",error=error) + "SOLVE",pos="RIGHT") CALL cp_fm_cholesky_restore(work,nao,ortho,ksa,& - "SOLVE",pos="LEFT",transa="T",error=error) + "SOLVE",pos="LEFT",transa="T") CASE(cholesky_inverse) - CALL cp_fm_upper_to_full(ksa,work,error=error) + CALL cp_fm_upper_to_full(ksa,work) CALL cp_fm_cholesky_restore(ksa,nao,ortho,work,& - "MULTIPLY",pos="RIGHT",error=error) + "MULTIPLY",pos="RIGHT") CALL cp_fm_cholesky_restore(work,nao,ortho,ksa,& - "MULTIPLY",pos="LEFT",transa="T",error=error) + "MULTIPLY",pos="LEFT",transa="T") CASE(cholesky_off) - CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksa,ortho,0.0_dp,work,error=error) - CALL cp_gemm("N","N",nao,nao,nao,1.0_dp,ortho,work,0.0_dp,ksa,error=error) + CALL cp_fm_symm("L","U",nao,nao,1.0_dp,ksa,ortho,0.0_dp,work) + CALL cp_gemm("N","N",nao,nao,nao,1.0_dp,ortho,work,0.0_dp,ksa) END SELECT END IF ! Diagonalization of the ROKS operator matrix - CALL choose_eigv_solver(ksa,work,eiga,error=error) + CALL choose_eigv_solver(ksa,work,eiga) ! Back-transformation of the orthonormal eigenvectors if needed IF (level_shift_loc /= 0.0_dp) THEN ! Use old MO set for back-transformation if level-shifting was applied - CALL cp_fm_to_fm(moa,ortho,error=error) - CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,ortho,work,0.0_dp,moa,error=error) + CALL cp_fm_to_fm(moa,ortho) + CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,ortho,work,0.0_dp,moa) ELSE IF (orthogonal_basis) THEN - CALL cp_fm_to_fm(work,moa,error=error) + CALL cp_fm_to_fm(work,moa) ELSE SELECT CASE(scf_env%cholesky_method) CASE(cholesky_reduce,cholesky_restore) - CALL cp_fm_cholesky_restore(work,nmo,ortho,moa,"SOLVE",error=error) + CALL cp_fm_cholesky_restore(work,nmo,ortho,moa,"SOLVE") CASE(cholesky_inverse) - CALL cp_fm_cholesky_restore(work,nmo,ortho,moa,"MULTIPLY",error=error) + CALL cp_fm_cholesky_restore(work,nmo,ortho,moa,"MULTIPLY") CASE(cholesky_off) - CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,ortho,work,0.0_dp,moa,error=error) + CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,ortho,work,0.0_dp,moa) END SELECT END IF END IF @@ -1359,15 +1320,13 @@ SUBROUTINE do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& ! Update also the beta MO set eigb(:) = eiga(:) - CALL cp_fm_to_fm(moa,mob,error=error) + CALL cp_fm_to_fm(moa,mob) ! Calculate the new alpha and beta density matrix ! does not yet handle k-points - CALL calculate_density_matrix(mos(1)%mo_set,scf_env%p_mix_new(1, 1)%matrix,& - error=error) - CALL calculate_density_matrix(mos(2)%mo_set,scf_env%p_mix_new(2, 1)%matrix,& - error=error) + CALL calculate_density_matrix(mos(1)%mo_set,scf_env%p_mix_new(1, 1)%matrix) + CALL calculate_density_matrix(mos(2)%mo_set,scf_env%p_mix_new(2, 1)%matrix) CALL timestop(handle) @@ -1381,14 +1340,13 @@ END SUBROUTINE do_roks_diag !> \param scf_control ... !> \param scf_section ... !> \param check_moconv_only ... -!> \param error ... !> \param !> \par History !> 05.2009 created [MI] ! ***************************************************************************** SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& - scf_control, scf_section, check_moconv_only, error) + scf_control, scf_section, check_moconv_only) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(mo_set_p_type), DIMENSION(:), & @@ -1398,7 +1356,6 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(IN), OPTIONAL :: check_moconv_only - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_block_krylov_diag', & routineP = moduleN//':'//routineN @@ -1415,11 +1372,11 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& TYPE(cp_logger_type), POINTER :: logger failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%LANCZOS",& - extension=".scfLog",error=error) + extension=".scfLog") my_check_moconv_only = .FALSE. @@ -1438,8 +1395,7 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& DO ispin=1,SIZE(matrix_ks) CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,& - scf_env%scf_work1(ispin)%matrix,& - error=error) + scf_env%scf_work1(ispin)%matrix) END DO IF(scf_env%mixing_method ==1) THEN @@ -1453,7 +1409,7 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& DO ispin=1,SIZE(matrix_ks) ks => scf_env%scf_work1(ispin)%matrix - CALL cp_fm_upper_to_full(ks,work,error=error) + CALL cp_fm_upper_to_full(ks,work) CALL get_mo_set(mo_set=mos(ispin)%mo_set,& nao=nao,& @@ -1467,21 +1423,21 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& c1 => scf_env%krylov_space%mo_refine(ispin)%matrix SELECT CASE(scf_env%cholesky_method) CASE(cholesky_reduce) - CALL cp_fm_cholesky_reduce(ks,ortho,error=error) - CALL cp_fm_upper_to_full(ks,work,error=error) - CALL cp_fm_cholesky_restore(mo_coeff,nmo,ortho,c0,"MULTIPLY",error=error) + CALL cp_fm_cholesky_reduce(ks,ortho) + CALL cp_fm_upper_to_full(ks,work) + CALL cp_fm_cholesky_restore(mo_coeff,nmo,ortho,c0,"MULTIPLY") CASE(cholesky_restore) CALL cp_fm_cholesky_restore(ks,nao,ortho,work,& - "SOLVE",pos="RIGHT",error=error) + "SOLVE",pos="RIGHT") CALL cp_fm_cholesky_restore(work,nao,ortho,ks,& - "SOLVE",pos="LEFT",transa="T",error=error) - CALL cp_fm_cholesky_restore(mo_coeff,nmo,ortho,c0,"MULTIPLY",error=error) + "SOLVE",pos="LEFT",transa="T") + CALL cp_fm_cholesky_restore(mo_coeff,nmo,ortho,c0,"MULTIPLY") CASE(cholesky_inverse) CALL cp_fm_cholesky_restore(ks,nao,ortho,work,& - "MULTIPLY",pos="RIGHT",error=error) + "MULTIPLY",pos="RIGHT") CALL cp_fm_cholesky_restore(work,nao,ortho,ks,& - "MULTIPLY",pos="LEFT",transa="T",error=error) - CALL cp_fm_cholesky_restore(mo_coeff,nmo,ortho,c0,"SOLVE",error=error) + "MULTIPLY",pos="LEFT",transa="T") + CALL cp_fm_cholesky_restore(mo_coeff,nmo,ortho,c0,"SOLVE") END SELECT scf_env%krylov_space%nmo_nc = nmo @@ -1501,7 +1457,7 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& IF(my_check_moconv_only) THEN CALL lanczos_refinement(scf_env%krylov_space, ks, c0, c1, mo_eigenvalues,& - nao, eps_iter, ispin, check_moconv_only=my_check_moconv_only, error=error) + nao, eps_iter, ispin, check_moconv_only=my_check_moconv_only) t2 = m_walltime() IF(output_unit > 0)& WRITE(output_unit,'(T8,I3,T16,I5,T24,I6,T33,E12.4,2x,E12.4,T60,F8.3)') & @@ -1513,7 +1469,7 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& !Block Lanczos refinement DO iter = 1,scf_env%krylov_space%max_iter CALL lanczos_refinement_2v(scf_env%krylov_space, ks, c0, c1, mo_eigenvalues,& - nao, eps_iter, ispin, error=error) + nao, eps_iter, ispin) t2 = m_walltime() IF (output_unit > 0) THEN WRITE(output_unit,'(T8,I3,T16,I5,T24,I6,T33,E12.4,2x,E12.4,T60,F8.3)')& @@ -1545,29 +1501,27 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& NULLIFY( chc, evec) chc => scf_env%krylov_space%chc_mat(ispin)%matrix evec => scf_env%krylov_space%c_vec(ispin)%matrix - CALL cp_gemm('N','N',nao,nmo,nao,rone,ks,c0,rzero,work,error=error) - CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,work,rzero,chc,error=error) + CALL cp_gemm('N','N',nao,nmo,nao,rone,ks,c0,rzero,work) + CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,work,rzero,chc) !Diagonalize (C^t)HC - CALL choose_eigv_solver(chc,evec,mo_eigenvalues,error=error) + CALL choose_eigv_solver(chc,evec,mo_eigenvalues) !Rotate the C vectors - CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,c1,error=error) + CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,c1) c0 => scf_env%krylov_space%mo_refine(ispin)%matrix END IF IF(scf_env%cholesky_method==cholesky_inverse) THEN - CALL cp_fm_cholesky_restore(c0,nmo,ortho,mo_coeff,"MULTIPLY",error=error) + CALL cp_fm_cholesky_restore(c0,nmo,ortho,mo_coeff,"MULTIPLY") ELSE - CALL cp_fm_cholesky_restore(c0,nmo,ortho,mo_coeff,"SOLVE",error=error) + CALL cp_fm_cholesky_restore(c0,nmo,ortho,mo_coeff,"SOLVE") END IF CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) ! does not yet handle k-points CALL calculate_density_matrix(mos(ispin)%mo_set,& - scf_env%p_mix_new(ispin,1)%matrix,& - error=error) + scf_env%p_mix_new(ispin,1)%matrix) END IF END DO ! ispin @@ -1576,7 +1530,7 @@ SUBROUTINE do_block_krylov_diag(scf_env,mos,matrix_ks,& END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%LANCZOS", error=error) + "PRINT%LANCZOS") CALL timestop(handle) @@ -1592,14 +1546,13 @@ END SUBROUTINE do_block_krylov_diag !> \param scf_control ... !> \param scf_section ... !> \param check_moconv_only ... -!> \param error ... !> \param !> \par History !> 05.2011 created [MI] ! ***************************************************************************** SUBROUTINE do_block_davidson_diag (qs_env,scf_env,mos,matrix_ks,matrix_s,& - scf_control,scf_section, check_moconv_only, error) + scf_control,scf_section, check_moconv_only) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env @@ -1610,7 +1563,6 @@ SUBROUTINE do_block_davidson_diag (qs_env,scf_env,mos,matrix_ks,matrix_s,& TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section LOGICAL, INTENT(IN), OPTIONAL :: check_moconv_only - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_block_davidson_diag', & routineP = moduleN//':'//routineN @@ -1622,11 +1574,11 @@ SUBROUTINE do_block_davidson_diag (qs_env,scf_env,mos,matrix_ks,matrix_s,& TYPE(cp_logger_type), POINTER :: logger failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%DAVIDSON",& - extension=".scfLog",error=error) + extension=".scfLog") IF(output_unit > 0) & WRITE(output_unit ,"(/T15,A)") '<<<<<<<<< DAVIDSON ITERATIONS <<<<<<<<<<' @@ -1653,48 +1605,44 @@ SUBROUTINE do_block_davidson_diag (qs_env,scf_env,mos,matrix_ks,matrix_s,& IF( do_prec .AND. (scf_env%iter_count==scf_env%block_davidson_env(1)%first_prec .OR. & MODULO(scf_env%iter_count,scf_env%block_davidson_env(1)%niter_new_prec)==0)) THEN CALL restart_preconditioner(qs_env,scf_env%ot_preconditioner,& - prec_type=scf_env%block_davidson_env(1)%prec_type,nspins=nspins,error=error) + prec_type=scf_env%block_davidson_env(1)%prec_type,nspins=nspins) CALL prepare_preconditioner(qs_env,mos,matrix_ks,matrix_s,scf_env%ot_preconditioner,& scf_env%block_davidson_env(1)%prec_type, & scf_env%block_davidson_env(1)%solver_type,& scf_env%block_davidson_env(1)%energy_gap,nspins,& - convert_to_dbcsr=scf_env%block_davidson_env(1)%use_sparse_mos,error=error) + convert_to_dbcsr=scf_env%block_davidson_env(1)%use_sparse_mos) END IF DO ispin = 1,nspins IF(scf_env%block_davidson_env(ispin)%use_sparse_mos) THEN IF(.NOT. do_prec) THEN CALL generate_extended_space_sparse(scf_env%block_davidson_env(ispin),mos(ispin)%mo_set,& - matrix_ks(ispin)%matrix,matrix_s(1)%matrix, output_unit,& - error=error) + matrix_ks(ispin)%matrix,matrix_s(1)%matrix, output_unit) ELSE CALL generate_extended_space_sparse(scf_env%block_davidson_env(ispin),mos(ispin)%mo_set,& matrix_ks(ispin)%matrix,matrix_s(1)%matrix,output_unit,& - scf_env%ot_preconditioner(ispin)%preconditioner,error=error) + scf_env%ot_preconditioner(ispin)%preconditioner) END IF ELSE IF(.NOT. do_prec) THEN CALL generate_extended_space(scf_env%block_davidson_env(ispin),mos(ispin)%mo_set,& - matrix_ks(ispin)%matrix,matrix_s(1)%matrix, output_unit,& - error=error) + matrix_ks(ispin)%matrix,matrix_s(1)%matrix, output_unit) ELSE CALL generate_extended_space(scf_env%block_davidson_env(ispin),mos(ispin)%mo_set,& matrix_ks(ispin)%matrix,matrix_s(1)%matrix,output_unit,& - scf_env%ot_preconditioner(ispin)%preconditioner,error=error) + scf_env%ot_preconditioner(ispin)%preconditioner) END IF END IF END DO !ispin CALL set_mo_occupation(mo_array=mos,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) DO ispin=1,nspins ! does not yet handle k-points CALL calculate_density_matrix(mos(ispin)%mo_set,& - scf_env%p_mix_new(ispin, 1)%matrix,& - error=error) + scf_env%p_mix_new(ispin, 1)%matrix) END DO @@ -1703,7 +1651,7 @@ SUBROUTINE do_block_davidson_diag (qs_env,scf_env,mos,matrix_ks,matrix_s,& END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%DAVIDSON", error=error) + "PRINT%DAVIDSON") CALL timestop(handle) diff --git a/src/qs_scf_initialization.F b/src/qs_scf_initialization.F index d5d92b9cbd..d8e0719cc2 100644 --- a/src/qs_scf_initialization.F +++ b/src/qs_scf_initialization.F @@ -128,17 +128,14 @@ MODULE qs_scf_initialization !> \param scf_env ... !> \param scf_control ... !> \param scf_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section,error) + SUBROUTINE qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), OPTIONAL, & POINTER :: scf_control TYPE(section_vals_type), OPTIONAL, & POINTER :: scf_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_env_initialize', & routineP = moduleN//':'//routineN @@ -149,41 +146,41 @@ SUBROUTINE qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section,error) TYPE(section_vals_type), POINTER :: dft_section, input, & my_scf_section - CALL get_qs_env(qs_env,error=error,input=input, rho=rho,& + CALL get_qs_env(qs_env,input=input, rho=rho,& dft_control=dft_control) IF(PRESENT(scf_control)) THEN my_scf_control => scf_control ELSE - CALL get_qs_env(qs_env,error=error,scf_control=my_scf_control) + CALL get_qs_env(qs_env,scf_control=my_scf_control) ENDIF - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") IF(PRESENT(scf_section)) THEN my_scf_section => scf_section ELSE - my_scf_section => section_vals_get_subs_vals(dft_section,"SCF",error=error) + my_scf_section => section_vals_get_subs_vals(dft_section,"SCF") END IF - CALL qs_scf_ensure_scf_env(qs_env,scf_env,error) + CALL qs_scf_ensure_scf_env(qs_env,scf_env) - CALL section_vals_val_get(my_scf_section,"CHOLESKY",i_val=scf_env%cholesky_method,error=error) + CALL section_vals_val_get(my_scf_section,"CHOLESKY",i_val=scf_env%cholesky_method) - CALL qs_scf_ensure_mos(qs_env,scf_env,error=error) + CALL qs_scf_ensure_mos(qs_env,scf_env) ! set flags for diagonalization CALL qs_scf_ensure_diagonalization(scf_env,my_scf_section,qs_env,& - my_scf_control, qs_env%has_unit_metric, error=error) + my_scf_control, qs_env%has_unit_metric) ! set parameters for mixing/DIIS during scf - CALL qs_scf_ensure_mixing(my_scf_control,my_scf_section,scf_env,dft_control,error=error) + CALL qs_scf_ensure_mixing(my_scf_control,my_scf_section,scf_env,dft_control) - CALL qs_scf_ensure_work_matrices(qs_env,scf_env,error=error) + CALL qs_scf_ensure_work_matrices(qs_env,scf_env) - CALL qs_scf_ensure_mixing_store(qs_env,scf_env,error=error) + CALL qs_scf_ensure_mixing_store(qs_env,scf_env) - CALL qs_scf_ensure_outer_loop_vars(scf_env,my_scf_control,error=error) + CALL qs_scf_ensure_outer_loop_vars(scf_env,my_scf_control) - CALL init_scf_run(scf_env, qs_env, my_scf_section, my_scf_control, error=error) + CALL init_scf_run(scf_env, qs_env, my_scf_section, my_scf_control) END SUBROUTINE qs_scf_env_initialize @@ -192,12 +189,10 @@ END SUBROUTINE qs_scf_env_initialize !> in case it is present the g-space mixing storage is reset !> \param qs_env ... !> \param scf_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_ensure_scf_env(qs_env,scf_env,error) + SUBROUTINE qs_scf_ensure_scf_env(qs_env,scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_ensure_scf_env', & routineP = moduleN//':'//routineN @@ -208,10 +203,10 @@ SUBROUTINE qs_scf_ensure_scf_env(qs_env,scf_env,error) NULLIFY(rho_g) IF (.NOT.ASSOCIATED(scf_env)) THEN ! i.e. for MD this is associated on the second step (it so seems) - CALL scf_env_create(scf_env, error=error) -! CALL set_qs_env(qs_env,scf_env=scf_env,error=error) -! CALL scf_env_release(scf_env,error=error) -! CALL get_qs_env(qs_env=qs_env,scf_env=scf_env,error=error) + CALL scf_env_create(scf_env) +! CALL set_qs_env(qs_env,scf_env=scf_env) +! CALL scf_env_release(scf_env) +! CALL get_qs_env(qs_env=qs_env,scf_env=scf_env) ELSE ! Reallocate mixing store, if the g space grid (cell) has changed SELECT CASE (scf_env%mixing_method) @@ -220,10 +215,10 @@ SUBROUTINE qs_scf_ensure_scf_env(qs_env,scf_env,error) ! The current mixing_store data structure does not allow for an unique ! grid comparison, but the probability that the 1d lengths of the old and ! the new grid are accidentily equal is rather low - CALL get_qs_env(qs_env,error=error, rho=rho) - CALL qs_rho_get(rho, rho_g=rho_g, error=error) + CALL get_qs_env(qs_env,rho=rho) + CALL qs_rho_get(rho, rho_g=rho_g) IF (SIZE(rho_g(1)%pw%pw_grid%gsq) /= SIZE(scf_env%mixing_store%rhoin(1)%cc)) & - CALL mixing_storage_release(scf_env%mixing_store,error=error) + CALL mixing_storage_release(scf_env%mixing_store) END IF END SELECT END IF @@ -235,12 +230,10 @@ END SUBROUTINE qs_scf_ensure_scf_env !> \brief performs allocation of outer SCF variables !> \param scf_env ... !> \param scf_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_ensure_outer_loop_vars(scf_env,scf_control,error) + SUBROUTINE qs_scf_ensure_outer_loop_vars(scf_env,scf_control) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'qs_scf_ensure_outer_loop_vars', & @@ -251,16 +244,16 @@ SUBROUTINE qs_scf_ensure_outer_loop_vars(scf_env,scf_control,error) IF (scf_control%outer_scf%have_scf) THEN nhistory = scf_control%outer_scf%max_scf + 1 - nvariables = outer_loop_variables_count(scf_control,error) + nvariables = outer_loop_variables_count(scf_control) ALLOCATE(scf_env%outer_scf%variables(nvariables,nhistory),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(scf_env%outer_scf%count(nhistory),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) scf_env%outer_scf%count=0 ALLOCATE(scf_env%outer_scf%gradient(nvariables,nhistory),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(scf_env%outer_scf%energy(nhistory),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF END SUBROUTINE qs_scf_ensure_outer_loop_vars @@ -270,12 +263,10 @@ END SUBROUTINE qs_scf_ensure_outer_loop_vars !> \brief performs allocation of the mixing storage !> \param qs_env ... !> \param scf_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_ensure_mixing_store(qs_env,scf_env,error) + SUBROUTINE qs_scf_ensure_mixing_store(qs_env,scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_ensure_mixing_store', & routineP = moduleN//':'//routineN @@ -283,13 +274,12 @@ SUBROUTINE qs_scf_ensure_mixing_store(qs_env,scf_env,error) TYPE(dft_control_type), POINTER :: dft_control NULLIFY(dft_control) - CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,& - error=error) + CALL get_qs_env(qs_env=qs_env,dft_control=dft_control) IF (scf_env%mixing_method>0) THEN CALL mixing_allocate(qs_env,scf_env%mixing_method,scf_env%p_mix_new, & scf_env%p_delta, dft_control%nspins,& - scf_env%mixing_store, error) + scf_env%mixing_store) ELSE NULLIFY(scf_env%p_mix_new) END IF @@ -303,13 +293,11 @@ END SUBROUTINE qs_scf_ensure_mixing_store !> maybe we have to initialize some matrices in the fm_pool in kpoints !> \param qs_env ... !> \param scf_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_ensure_work_matrices(qs_env,scf_env,error) + SUBROUTINE qs_scf_ensure_work_matrices(qs_env,scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_ensure_work_matrices', & routineP = moduleN//':'//routineN @@ -335,21 +323,19 @@ SUBROUTINE qs_scf_ensure_work_matrices(qs_env,scf_env,error) dft_control=dft_control,& matrix_s_kp=matrix_s,& mos=mos,& - do_kpoints=do_kpoints,& - error=error) - CALL mpools_get(qs_env%mpools,ao_mo_fm_pools=ao_mo_fm_pools,error=error) + do_kpoints=do_kpoints) + CALL mpools_get(qs_env%mpools,ao_mo_fm_pools=ao_mo_fm_pools) ! create an ao_ao parallel matrix structure - ao_mo_fmstruct => fm_pool_get_el_struct(ao_mo_fm_pools(1)%pool,error=error) - CALL cp_fm_struct_get(ao_mo_fmstruct, nrow_block=nrow_block,error=error) + ao_mo_fmstruct => fm_pool_get_el_struct(ao_mo_fm_pools(1)%pool) + CALL cp_fm_struct_get(ao_mo_fmstruct, nrow_block=nrow_block) CALL get_mo_set(mos(1)%mo_set,nao=nao) CALL cp_fm_struct_create(fmstruct=ao_ao_fmstruct,& nrow_block=nrow_block,& ncol_block=nrow_block,& nrow_global=nao,& ncol_global=nao,& - template_fmstruct=ao_mo_fmstruct,& - error=error) + template_fmstruct=ao_mo_fmstruct) IF ((scf_env%method /= ot_method_nr) .AND. & (scf_env%method /= block_davidson_diag_method_nr) ) THEN @@ -357,14 +343,13 @@ SUBROUTINE qs_scf_ensure_work_matrices(qs_env,scf_env,error) nw = dft_control%nspins IF (do_kpoints) nw = 4 ALLOCATE(scf_env%scf_work1(nw), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO is=1,SIZE(scf_env%scf_work1) NULLIFY(scf_env%scf_work1(is)%matrix) CALL cp_fm_create(scf_env%scf_work1(is)%matrix,& matrix_struct=ao_ao_fmstruct,& name="SCF"//TRIM(ADJUSTL(cp_to_string(scf_env%id_nr)))//& - "WORK_MATRIX-1-"//TRIM(ADJUSTL(cp_to_string(is))),& - error=error) + "WORK_MATRIX-1-"//TRIM(ADJUSTL(cp_to_string(is)))) END DO END IF IF ((.NOT.ASSOCIATED(scf_env%ortho)).AND.& @@ -374,34 +359,31 @@ SUBROUTINE qs_scf_ensure_work_matrices(qs_env,scf_env,error) CALL cp_fm_create(scf_env%ortho,& matrix_struct=ao_ao_fmstruct,& name="SCF"//TRIM(ADJUSTL(cp_to_string(scf_env%id_nr)))//& - "ORTHO_MATRIX",& - error=error) + "ORTHO_MATRIX") ! Initialize dbcsr matrix to store the Cholesky decomposition IF (scf_env%cholesky_method == cholesky_dbcsr) THEN ref_matrix => matrix_s(1,1)%matrix - CALL cp_dbcsr_init_p(scf_env%ortho_dbcsr,error=error) + CALL cp_dbcsr_init_p(scf_env%ortho_dbcsr) CALL cp_dbcsr_create(scf_env%ortho_dbcsr,template=ref_matrix,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init_p(scf_env%buf1_dbcsr,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init_p(scf_env%buf1_dbcsr) CALL cp_dbcsr_create(scf_env%buf1_dbcsr,template=ref_matrix,& - matrix_type=dbcsr_type_no_symmetry,error=error) - CALL cp_dbcsr_init_p(scf_env%buf2_dbcsr,error=error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_init_p(scf_env%buf2_dbcsr) CALL cp_dbcsr_create(scf_env%buf2_dbcsr,template=ref_matrix,& - matrix_type=dbcsr_type_no_symmetry,error=error) + matrix_type=dbcsr_type_no_symmetry) ELSE IF (scf_env%cholesky_method == cholesky_inverse) THEN CALL cp_fm_create(scf_env%ortho_m1,& matrix_struct=ao_ao_fmstruct,& name="SCF"//TRIM(ADJUSTL(cp_to_string(scf_env%id_nr)))//& - "ORTHO_MATRIX-1",& - error=error) + "ORTHO_MATRIX-1") END IF END IF IF (.NOT.ASSOCIATED(scf_env%scf_work2)) THEN CALL cp_fm_create(scf_env%scf_work2,& matrix_struct=ao_ao_fmstruct,& name="SCF"//TRIM(ADJUSTL(cp_to_string(scf_env%id_nr)))//& - "WORK_MATRIX-2",& - error=error) + "WORK_MATRIX-2") END IF END IF @@ -411,14 +393,12 @@ SUBROUTINE qs_scf_ensure_work_matrices(qs_env,scf_env,error) CALL cp_fm_create(scf_env%scf_work2,& matrix_struct=ao_ao_fmstruct,& name="SCF"//TRIM(ADJUSTL(cp_to_string(scf_env%id_nr)))//& - "WORK_MATRIX-2",& - error=error) + "WORK_MATRIX-2") END IF IF (.NOT.ASSOCIATED(scf_env%s_half)) THEN CALL cp_fm_create(scf_env%s_half,& matrix_struct=ao_ao_fmstruct,& - name="S**(1/2) MATRIX",& - error=error) + name="S**(1/2) MATRIX") END IF END IF END IF @@ -427,19 +407,18 @@ SUBROUTINE qs_scf_ensure_work_matrices(qs_env,scf_env,error) IF (.NOT.ASSOCIATED(scf_env%scf_work1)) THEN nw = 4 ALLOCATE(scf_env%scf_work1(nw), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO is=1,SIZE(scf_env%scf_work1) NULLIFY(scf_env%scf_work1(is)%matrix) CALL cp_fm_create(scf_env%scf_work1(is)%matrix,& matrix_struct=ao_ao_fmstruct,& name="SCF"//TRIM(ADJUSTL(cp_to_string(scf_env%id_nr)))//& - "WORK_MATRIX-1-"//TRIM(ADJUSTL(cp_to_string(is))),& - error=error) + "WORK_MATRIX-1-"//TRIM(ADJUSTL(cp_to_string(is)))) END DO END IF END IF - CALL cp_fm_struct_release(ao_ao_fmstruct,error=error) + CALL cp_fm_struct_release(ao_ao_fmstruct) CALL timestop(handle) @@ -450,12 +429,10 @@ END SUBROUTINE qs_scf_ensure_work_matrices !> \brief performs allocation of the MO matrices !> \param qs_env ... !> \param scf_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_ensure_mos(qs_env,scf_env,error) + SUBROUTINE qs_scf_ensure_mos(qs_env,scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_ensure_mos', & routineP = moduleN//':'//routineN @@ -489,55 +466,53 @@ SUBROUTINE qs_scf_ensure_mos(qs_env,scf_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env,& dft_control=dft_control,& mos=mos,& matrix_s_kp=matrix_s,& mos_aux_fit=mos_aux_fit,& - xas_env=xas_env,error=error) - CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools,& - error=error) + xas_env=xas_env) + CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools) nmo_mat=dft_control%nspins IF(dft_control%restricted)nmo_mat=1 ! right now, there might be more mos than needed derivs ! *** finish initialization of the MOs *** - CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,failure) DO ispin=1,SIZE(mos) CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff,mo_coeff_b=mo_coeff_b) IF (.NOT.ASSOCIATED(mo_coeff)) THEN CALL init_mo_set(mos(ispin)%mo_set,& ao_mo_fm_pools(ispin)%pool,& name="qs_env"//TRIM(ADJUSTL(cp_to_string(qs_env%id_nr)))//& - "%mo"//TRIM(ADJUSTL(cp_to_string(ispin))),& - error=error) + "%mo"//TRIM(ADJUSTL(cp_to_string(ispin)))) END IF IF(.not.ASSOCIATED(mo_coeff_b)) THEN - CALL cp_fm_get_info(mos(ispin)%mo_set%mo_coeff,ncol_global=nmo,error=error) - CALL cp_dbcsr_init_p(mos(ispin)%mo_set%mo_coeff_b,error=error) + CALL cp_fm_get_info(mos(ispin)%mo_set%mo_coeff,ncol_global=nmo) + CALL cp_dbcsr_init_p(mos(ispin)%mo_set%mo_coeff_b) CALL cp_dbcsr_m_by_n_from_row_template(mos(ispin)%mo_set%mo_coeff_b,template=matrix_s(1,1)%matrix,n=nmo,& - sym=dbcsr_type_no_symmetry, error=error) + sym=dbcsr_type_no_symmetry) ENDIF END DO ! *** get the mo_derivs OK if needed *** IF (qs_env%requires_mo_derivs) THEN - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,error=error) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs) IF (.NOT.ASSOCIATED(mo_derivs)) THEN ALLOCATE(mo_derivs(nmo_mat)) DO ispin=1,nmo_mat CALL get_mo_set(mos(ispin)%mo_set,mo_coeff_b=mo_coeff_b) NULLIFY(mo_derivs(ispin)%matrix) - CALL cp_dbcsr_init_p(mo_derivs(ispin)%matrix,error=error) + CALL cp_dbcsr_init_p(mo_derivs(ispin)%matrix) CALL cp_dbcsr_create(mo_derivs(ispin)%matrix, "mo_derivs",& cp_dbcsr_distribution(mo_coeff_b), dbcsr_type_no_symmetry,& cp_dbcsr_row_block_sizes(mo_coeff_b), cp_dbcsr_col_block_sizes(mo_coeff_b),& - nze=0, data_type=dbcsr_type_real_default, error=error) + nze=0, data_type=dbcsr_type_real_default) ENDDO - CALL set_qs_env(qs_env,mo_derivs=mo_derivs,error=error) + CALL set_qs_env(qs_env,mo_derivs=mo_derivs) ENDIF ELSE @@ -546,28 +521,26 @@ SUBROUTINE qs_scf_ensure_mos(qs_env,scf_env,error) ! *** finish initialization of the MOs for ADMM and derivs if needed *** IF(dft_control%do_admm) THEN - CPPrecondition(ASSOCIATED(mos_aux_fit),cp_failure_level,routineP,error,failure) - CALL mpools_get(qs_env%mpools_aux_fit, ao_mo_fm_pools=ao_mo_fm_pools_aux_fit,& - error=error) + CPPrecondition(ASSOCIATED(mos_aux_fit),cp_failure_level,routineP,failure) + CALL mpools_get(qs_env%mpools_aux_fit, ao_mo_fm_pools=ao_mo_fm_pools_aux_fit) DO ispin=1,SIZE(mos_aux_fit) CALL get_mo_set(mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) IF (.NOT.ASSOCIATED(mo_coeff_aux_fit)) THEN CALL init_mo_set(mos_aux_fit(ispin)%mo_set,& ao_mo_fm_pools_aux_fit(ispin)%pool,& name="qs_env"//TRIM(ADJUSTL(cp_to_string(qs_env%id_nr)))//& - "%mo_aux_fit"//TRIM(ADJUSTL(cp_to_string(ispin))),& - error=error) + "%mo_aux_fit"//TRIM(ADJUSTL(cp_to_string(ispin)))) END IF END DO IF (qs_env%requires_mo_derivs) THEN - CALL get_qs_env(qs_env,mo_derivs_aux_fit=mo_derivs_aux_fit,error=error) + CALL get_qs_env(qs_env,mo_derivs_aux_fit=mo_derivs_aux_fit) IF (.NOT.ASSOCIATED(mo_derivs_aux_fit)) THEN ALLOCATE(mo_derivs_aux_fit(nmo_mat)) DO ispin=1,nmo_mat CALL get_mo_set(mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit) - CALL cp_fm_create(mo_derivs_aux_fit(ispin)%matrix,mo_coeff_aux_fit%matrix_struct,error=error) + CALL cp_fm_create(mo_derivs_aux_fit(ispin)%matrix,mo_coeff_aux_fit%matrix_struct) ENDDO - CALL set_qs_env(qs_env,mo_derivs_aux_fit=mo_derivs_aux_fit,error=error) + CALL set_qs_env(qs_env,mo_derivs_aux_fit=mo_derivs_aux_fit) ENDIF ELSE ! nothing should be done @@ -575,30 +548,30 @@ SUBROUTINE qs_scf_ensure_mos(qs_env,scf_env,error) END IF ! kpoints: we have to initialize all the k-point MOs - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) IF(kpoints%nkp /= 0) THEN ! check for some incompatible options CALL cp_assert(.NOT.(qs_env%requires_mo_derivs),cp_failure_level,cp_assertion_failed,& - routineP,"No MO derivative methods allowed with kpoints",error,failure) + routineP,"No MO derivative methods allowed with kpoints",failure) CALL cp_assert(.NOT.(dft_control%do_admm),cp_failure_level,cp_assertion_failed,& - routineP,"No ADMM implemented with kpoints",error,failure) + routineP,"No ADMM implemented with kpoints",failure) CALL cp_assert(.NOT.(dft_control%do_xas_calculation),cp_failure_level,cp_assertion_failed,& - routineP,"No XAS implemented with kpoints",error,failure) + routineP,"No XAS implemented with kpoints",failure) DO ik=1,SIZE(kpoints%kp_env) - CALL mpools_get(kpoints%mpools, ao_mo_fm_pools=ao_mo_fm_pools,error=error) + CALL mpools_get(kpoints%mpools, ao_mo_fm_pools=ao_mo_fm_pools) mos_k => kpoints%kp_env(ik)%kpoint_env%mos ikk = kpoints%kp_range(1) + ik - 1 - CPPrecondition(ASSOCIATED(mos_k),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mos_k),cp_failure_level,routineP,failure) DO ispin=1,SIZE(mos_k,2) DO ic=1,SIZE(mos_k,1) CALL get_mo_set(mos_k(ic,ispin)%mo_set,mo_coeff=mo_coeff,mo_coeff_b=mo_coeff_b) IF (.NOT.ASSOCIATED(mo_coeff)) THEN CALL init_mo_set(mos_k(ic,ispin)%mo_set,ao_mo_fm_pools(ispin)%pool,& name="kpoints_"//TRIM(ADJUSTL(cp_to_string(ikk)))//& - "%mo"//TRIM(ADJUSTL(cp_to_string(ispin))),error=error) + "%mo"//TRIM(ADJUSTL(cp_to_string(ispin)))) END IF ! no sparse matrix representation of kpoint MO vectors - CPPrecondition(.NOT.ASSOCIATED(mo_coeff_b),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(mo_coeff_b),cp_failure_level,routineP,failure) END DO END DO END DO @@ -615,14 +588,12 @@ END SUBROUTINE qs_scf_ensure_mos !> \param scf_section ... !> \param scf_env ... !> \param dft_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_ensure_mixing(scf_control,scf_section,scf_env,dft_control,error) + SUBROUTINE qs_scf_ensure_mixing(scf_control,scf_section,scf_env,dft_control) TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_ensure_mixing', & routineP = moduleN//':'//routineN @@ -636,13 +607,13 @@ SUBROUTINE qs_scf_ensure_mixing(scf_control,scf_section,scf_env,dft_control,erro scf_env%p_mix_alpha = 1.0_dp CASE(direct_p_mix,kerker_mix,pulay_mix,broy_mix,broy_mix_new,multisec_mix) scf_env%mixing_method = scf_control%mixing_method - mixing_section => section_vals_get_subs_vals(scf_section,"MIXING",error=error) + mixing_section => section_vals_get_subs_vals(scf_section,"MIXING") IF(.NOT.ASSOCIATED(scf_env%mixing_store))& CALL mixing_storage_create(scf_env%mixing_store, mixing_section, scf_env%mixing_method, & - dft_control%qs_control%cutoff, error=error) + dft_control%qs_control%cutoff) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"Unknown mixing method",error,failure) + routineP,"Unknown mixing method",failure) END SELECT ! Disable DIIS for OT and g-space density mixing methods @@ -655,7 +626,7 @@ SUBROUTINE qs_scf_ensure_mixing(scf_control,scf_section,scf_env,dft_control,erro IF (scf_control%use_diag .AND. scf_env%mixing_method==no_mixing_nr) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"Diagonalization procedures without mixing are not recommendable",error,failure) + routineP,"Diagonalization procedures without mixing are not recommendable",failure) END IF IF(scf_env%mixing_method>direct_mixing_nr) THEN @@ -663,7 +634,7 @@ SUBROUTINE qs_scf_ensure_mixing(scf_control,scf_section,scf_env,dft_control,erro scf_env%p_mix_alpha = scf_env%mixing_store%alpha IF(scf_env%mixing_store%beta==0.0_dp) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"Mixing employing the Kerker damping factor needs BETA /= 0.0",error,failure) + routineP,"Mixing employing the Kerker damping factor needs BETA /= 0.0",failure) END IF END IF @@ -673,7 +644,7 @@ SUBROUTINE qs_scf_ensure_mixing(scf_control,scf_section,scf_env,dft_control,erro scf_env%skip_diis = .TRUE. CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "the DIIS scheme is disabled, since EPS_DIIS < EPS_SCF",& - error,failure) + failure) END IF END IF @@ -688,16 +659,14 @@ END SUBROUTINE qs_scf_ensure_mixing !> \param qs_env ... !> \param scf_control ... !> \param has_unit_metric ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_scf_ensure_diagonalization(scf_env,scf_section,qs_env,& - scf_control,has_unit_metric,error) + scf_control,has_unit_metric) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(section_vals_type), POINTER :: scf_section TYPE(qs_environment_type), POINTER :: qs_env TYPE(scf_control_type), POINTER :: scf_control LOGICAL :: has_unit_metric - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'qs_scf_ensure_diagonalization', & @@ -711,7 +680,7 @@ SUBROUTINE qs_scf_ensure_diagonalization(scf_env,scf_section,qs_env,& TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos - CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints,dft_control=dft_control,mos=mos,error=error) + CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints,dft_control=dft_control,mos=mos) not_se_or_dftb=.NOT.(dft_control%qs_control%dftb .OR. dft_control%qs_control%semi_empirical) need_coeff_b=.FALSE. scf_env%needs_ortho=.FALSE. @@ -719,11 +688,11 @@ SUBROUTINE qs_scf_ensure_diagonalization(scf_env,scf_section,qs_env,& IF (scf_control%use_diag) THEN ! sanity check whether combinations are allowed CALL cp_assert(.NOT.dft_control%restricted,cp_failure_level,cp_assertion_failed,& - routineP,"OT only for restricted (ROKS)",error,failure) + routineP,"OT only for restricted (ROKS)",failure) SELECT CASE (scf_control%diagonalization%method) CASE(diag_ot,diag_block_krylov,diag_block_davidson) CALL cp_assert(not_se_or_dftb,cp_failure_level,cp_assertion_failed,& - routineP,"DFTB and SE not possible with OT diagonalization",error,failure) + routineP,"DFTB and SE not possible with OT diagonalization",failure) END SELECT SELECT CASE (scf_control%diagonalization%method) ! Diagonalization: additional check whether we are in an orthonormal basis @@ -736,34 +705,34 @@ SUBROUTINE qs_scf_ensure_diagonalization(scf_env,scf_section,qs_env,& ! OT Diagonalization: not possible with ROKS CASE (diag_ot) CALL cp_assert(.NOT.(dft_control%roks),cp_failure_level,cp_assertion_failed,& - routineP,"ROKS with OT diagonalization not possible",error,failure) + routineP,"ROKS with OT diagonalization not possible",failure) CALL cp_assert(.NOT.do_kpoints,cp_failure_level,cp_assertion_failed,& - routineP,"OT diagonalization not possible with kpoint calculations",error,failure) + routineP,"OT diagonalization not possible with kpoint calculations",failure) scf_env%method=ot_diag_method_nr need_coeff_b=.TRUE. ! Block Krylov diagonlization: not possible with ROKS, ! allocation of additional matrices is needed CASE (diag_block_krylov) CALL cp_assert(.NOT.(dft_control%roks),cp_failure_level,cp_assertion_failed,& - routineP,"ROKS with block PF diagonalization not possible",error,failure) + routineP,"ROKS with block PF diagonalization not possible",failure) CALL cp_assert(.NOT.do_kpoints,cp_failure_level,cp_assertion_failed,& - routineP,"Block Krylov diagonalization not possible with kpoint calculations",error,failure) + routineP,"Block Krylov diagonalization not possible with kpoint calculations",failure) scf_env%method=block_krylov_diag_method_nr scf_env%needs_ortho=.TRUE. IF(.NOT.ASSOCIATED(scf_env%krylov_space))& - CALL krylov_space_create(scf_env%krylov_space, scf_section,error=error) - CALL krylov_space_allocate(scf_env%krylov_space, scf_control, mos, error=error) + CALL krylov_space_create(scf_env%krylov_space, scf_section) + CALL krylov_space_allocate(scf_env%krylov_space, scf_control, mos) ! Block davidson diagonlization: allocation of additional matrices is needed CASE (diag_block_davidson) CALL cp_assert(.NOT.do_kpoints,cp_failure_level,cp_assertion_failed,& - routineP,"Block Davidson diagonalization not possible with kpoint calculations",error,failure) + routineP,"Block Davidson diagonalization not possible with kpoint calculations",failure) scf_env%method=block_davidson_diag_method_nr IF(.NOT.ASSOCIATED(scf_env%block_davidson_env))& CALL block_davidson_env_create(scf_env%block_davidson_env,dft_control%nspins,& - scf_section,error=error) + scf_section) DO ispin=1,dft_control%nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set, mo_coeff=mo_coeff,nao=nao,nmo=nmo) - CALL block_davidson_allocate(scf_env%block_davidson_env(ispin),mo_coeff, nao, nmo, error=error) + CALL block_davidson_allocate(scf_env%block_davidson_env(ispin),mo_coeff, nao, nmo) END DO need_coeff_b=.TRUE. ! Filter matrix diagonalisation method @@ -771,26 +740,26 @@ SUBROUTINE qs_scf_ensure_diagonalization(scf_env,scf_section,qs_env,& scf_env%method=filter_matrix_diag_method_nr scf_env%cholesky_method = cholesky_inverse IF (.NOT. fb_env_has_data(scf_env%filter_matrix_env)) THEN - CALL fb_env_create(scf_env%filter_matrix_env, error=error) + CALL fb_env_create(scf_env%filter_matrix_env) END IF - CALL fb_env_read_input(scf_env%filter_matrix_env, scf_section, error=error) - CALL fb_env_build_rcut_auto(scf_env%filter_matrix_env, qs_env, error=error) - CALL fb_env_write_info(scf_env%filter_matrix_env, qs_env, scf_section, error=error) - CALL fb_distribution_build(scf_env%filter_matrix_env, qs_env, scf_section, error=error) - CALL fb_env_build_atomic_halos(scf_env%filter_matrix_env, qs_env, scf_section, error=error) + CALL fb_env_read_input(scf_env%filter_matrix_env, scf_section) + CALL fb_env_build_rcut_auto(scf_env%filter_matrix_env, qs_env) + CALL fb_env_write_info(scf_env%filter_matrix_env, qs_env, scf_section) + CALL fb_distribution_build(scf_env%filter_matrix_env, qs_env, scf_section) + CALL fb_env_build_atomic_halos(scf_env%filter_matrix_env, qs_env, scf_section) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"Unknown diagonalization method",error,failure) + routineP,"Unknown diagonalization method",failure) END SELECT ! Check if subspace diagonlization is requested: allocation of additional matrices is needed IF(scf_control%do_diag_sub) THEN scf_env%needs_ortho=.TRUE. IF(.NOT.ASSOCIATED(scf_env%subspace_env))& CALL diag_subspace_env_create(scf_env%subspace_env,scf_section,& - dft_control%qs_control%cutoff,error=error) - CALL diag_subspace_allocate(scf_env%subspace_env, qs_env, mos, error=error) + dft_control%qs_control%cutoff) + CALL diag_subspace_allocate(scf_env%subspace_env, qs_env, mos) CALL cp_assert(.NOT.do_kpoints,cp_failure_level,cp_assertion_failed,& - routineP,"No subspace diagonlization with kpoint calculation",error,failure) + routineP,"No subspace diagonlization with kpoint calculation",failure) END IF ! OT: check if OT is used instead of diagonlization. Not possible with added MOS at the moment ELSEIF (scf_control%use_ot) THEN @@ -798,15 +767,15 @@ SUBROUTINE qs_scf_ensure_diagonalization(scf_env,scf_section,qs_env,& need_coeff_b=.TRUE. IF(scf_control%added_mos(1)+scf_control%added_mos(2) > 0) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"OT with ADDED_MOS/=0 not implemented", error,failure) + routineP,"OT with ADDED_MOS/=0 not implemented",failure) IF(dft_control%restricted)& CALL cp_assert(dft_control%nspins.EQ.2,cp_failure_level,cp_assertion_failed,& - routineP,"nspin must be 2 for restricted (ROKS)", error,failure) + routineP,"nspin must be 2 for restricted (ROKS)",failure) CALL cp_assert(.NOT.do_kpoints,cp_failure_level,cp_assertion_failed,& - routineP,"OT not possible with kpoint calculations",error,failure) + routineP,"OT not possible with kpoint calculations",failure) ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"OT or DIAGONALIZATION have to be set",error,failure) + routineP,"OT or DIAGONALIZATION have to be set",failure) END IF DO ispin=1,dft_control%nspins mos(ispin)%mo_set%use_mo_coeff_b=need_coeff_b @@ -819,12 +788,10 @@ END SUBROUTINE qs_scf_ensure_diagonalization !> \brief computes properties for a given hamilonian using the current wfn !> \param qs_env ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_compute_properties(qs_env,dft_section,error) + SUBROUTINE qs_scf_compute_properties(qs_env,dft_section) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_compute_properties', & routineP = moduleN//':'//routineN @@ -832,26 +799,26 @@ SUBROUTINE qs_scf_compute_properties(qs_env,dft_section,error) TYPE(dft_control_type), POINTER :: dft_control TYPE(qs_scf_env_type), POINTER :: scf_env - CALL get_qs_env(qs_env, scf_env=scf_env, dft_control=dft_control, error=error ) + CALL get_qs_env(qs_env, scf_env=scf_env, dft_control=dft_control) IF (dft_control%qs_control%semi_empirical) THEN - CALL scf_post_calculation_se (qs_env, error) + CALL scf_post_calculation_se (qs_env) ELSEIF (dft_control%qs_control%dftb) THEN - CALL scf_post_calculation_dftb (dft_section, scf_env, qs_env, error) + CALL scf_post_calculation_dftb (dft_section, scf_env, qs_env) ELSEIF (dft_control%qs_control%scptb) THEN - CALL scf_post_calculation_scptb (qs_env, error) + CALL scf_post_calculation_scptb (qs_env) ELSEIF (dft_control%qs_control%do_kg) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="No properties from PRINT section available for KG methods", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSEIF (dft_control%qs_control%ofgpw) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="No properties from PRINT section available for OFGPW methods", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSEIF (dft_control%qs_control%lri_optbas.AND.dft_control%qs_control%gpw) THEN - CALL optimize_lri_basis(qs_env,error) + CALL optimize_lri_basis(qs_env) ELSE - CALL scf_post_calculation_gpw (dft_section, scf_env, qs_env, error) + CALL scf_post_calculation_gpw (dft_section, scf_env, qs_env) END IF END SUBROUTINE qs_scf_compute_properties @@ -865,17 +832,15 @@ END SUBROUTINE qs_scf_compute_properties !> \param qs_env ... !> \param scf_section ... !> \param scf_control ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control, error) + SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: scf_section TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_scf_run', & routineP = moduleN//':'//routineN @@ -903,12 +868,12 @@ SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control, error) NULLIFY( qs_kind_set, matrix_s, dft_control, mos, qs_kind, rho,xas_env) failure=.FALSE. ! - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) NULLIFY(para_env) s_minus_half_available = .FALSE. @@ -920,46 +885,45 @@ SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control, error) nelectron_total=scf_env%nelectron,& do_kpoints=do_kpoints,& para_env=para_env,& - xas_env=xas_env,& - error=error) + xas_env=xas_env) output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") CALL qs_scf_initial_info(output_unit,mos,dft_control) CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") ! calc ortho matrix ndep = 0 IF (scf_env%needs_ortho)THEN - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,scf_env%ortho,error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,scf_env%ortho) IF (scf_env%cholesky_method>cholesky_off) THEN - CALL cp_fm_cholesky_decompose(scf_env%ortho,error=error) + CALL cp_fm_cholesky_decompose(scf_env%ortho) IF(scf_env%cholesky_method == cholesky_dbcsr) THEN - CALL cp_fm_triangular_invert(scf_env%ortho,error=error) - CALL cp_fm_set_all(scf_env%scf_work2,0.0_dp,error=error) - CALL cp_fm_to_fm_triangular(scf_env%ortho,scf_env%scf_work2,"U",error=error) - CALL copy_fm_to_dbcsr(scf_env%scf_work2, scf_env%ortho_dbcsr, error=error) + CALL cp_fm_triangular_invert(scf_env%ortho) + CALL cp_fm_set_all(scf_env%scf_work2,0.0_dp) + CALL cp_fm_to_fm_triangular(scf_env%ortho,scf_env%scf_work2,"U") + CALL copy_fm_to_dbcsr(scf_env%scf_work2, scf_env%ortho_dbcsr) ELSE IF(scf_env%cholesky_method==cholesky_inverse) THEN - CALL cp_fm_to_fm(scf_env%ortho,scf_env%ortho_m1,error=error) - CALL cp_fm_triangular_invert(scf_env%ortho_m1,error=error) + CALL cp_fm_to_fm(scf_env%ortho,scf_env%ortho_m1) + CALL cp_fm_triangular_invert(scf_env%ortho_m1) END IF ELSE CALL cp_fm_power(scf_env%ortho,scf_env%scf_work2,-0.5_dp,& - scf_control%eps_eigval,ndep,error=error) + scf_control%eps_eigval,ndep) s_minus_half_available = .TRUE. END IF IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/ORTHO",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/ORTHO"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/ORTHO",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL write_fm_with_basis_info(scf_env%ortho,4,after,qs_env,para_env,output_unit=iw,error=error) + CALL write_fm_with_basis_info(scf_env%ortho,4,after,qs_env,para_env,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/ORTHO", error=error) + "DFT%PRINT%AO_MATRICES/ORTHO") END IF END IF @@ -967,15 +931,15 @@ SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control, error) ! DFT+U methods based on Lowdin charges need S^(1/2) IF (dft_control%dft_plus_u) THEN - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s) IF (dft_control%plus_u_method_id == plus_u_lowdin) THEN IF (s_minus_half_available) THEN CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,scf_env%ortho,scf_env%s_half,& - nao,error=error) + nao) ELSE - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,scf_env%s_half,error=error) + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,scf_env%s_half) CALL cp_fm_power(scf_env%s_half,scf_env%scf_work2,0.5_dp,& - scf_control%eps_eigval,ndep,error=error) + scf_control%eps_eigval,ndep) END IF END IF DO ikind=1,SIZE(qs_kind_set) @@ -983,27 +947,27 @@ SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control, error) CALL get_qs_kind(qs_kind=qs_kind,& dft_plus_u_atom=dft_plus_u_atom,& u_ramping=u_ramping,& - init_u_ramping_each_scf=init_u_ramping_each_scf,error=error) + init_u_ramping_each_scf=init_u_ramping_each_scf) IF (dft_plus_u_atom.AND.(u_ramping /= 0.0_dp)) THEN IF (init_u_ramping_each_scf) THEN - CALL set_qs_kind(qs_kind=qs_kind,u_minus_j=0.0_dp,error=error) + CALL set_qs_kind(qs_kind=qs_kind,u_minus_j=0.0_dp) END IF END IF END DO END IF output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit > 0) THEN WRITE (UNIT=output_unit,FMT="(T2,A,T71,I10)")& "Number of independent orbital functions:",nao - ndep END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") ! extrapolate outer loop variables IF (scf_control%outer_scf%have_scf) THEN - CALL outer_loop_extrapolate(qs_env,error) + CALL outer_loop_extrapolate(qs_env) ENDIF ! initializes rho and the mos @@ -1012,22 +976,21 @@ SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control, error) ! changes come from a perturbation, e.g., the occupation numbers ! it could be generalized for other cases, at the moment used only for core level spectroscopy ! initialize the density with the localized mos - CALL xas_initialize_rho(qs_env,scf_env,scf_control,error=error) + CALL xas_initialize_rho(qs_env,scf_env,scf_control) ELSE CALL scf_env_initial_rho_setup(scf_env,qs_env=qs_env,& - scf_section=scf_section, scf_control=scf_control, error=error) + scf_section=scf_section, scf_control=scf_control) END IF ! Frozen density approximation IF (ASSOCIATED(qs_env%wf_history)) THEN IF (qs_env%wf_history%interpolation_method_nr==wfi_frozen_method_nr) THEN IF (.NOT. ASSOCIATED(qs_env%wf_history%past_states(1)%snapshot)) THEN - CALL wfi_update(qs_env%wf_history, qs_env=qs_env, dt=1.0_dp, & - error=error) - CALL qs_rho_create(qs_env%wf_history%past_states(1)%snapshot%rho_frozen, error) + CALL wfi_update(qs_env%wf_history, qs_env=qs_env, dt=1.0_dp) + CALL qs_rho_create(qs_env%wf_history%past_states(1)%snapshot%rho_frozen) CALL duplicate_rho_type(rho_input=rho, & rho_output=qs_env%wf_history%past_states(1)%snapshot%rho_frozen, & - qs_env=qs_env, error=error) + qs_env=qs_env) END IF END IF END IF @@ -1036,7 +999,7 @@ SUBROUTINE init_scf_run(scf_env, qs_env, scf_section,scf_control, error) IF(qs_env%qmmm) THEN IF(qs_env%qmmm.AND.qs_env%qmmm_env_qm%image_charge) THEN CALL conditional_calc_image_matrix(qs_env=qs_env,& - qmmm_env=qs_env%qmmm_env_qm,error=error) + qmmm_env=qs_env%qmmm_env_qm) ENDIF ENDIF @@ -1051,18 +1014,15 @@ END SUBROUTINE init_scf_run !> \param qs_env the qs env the scf_env lives in !> \param scf_section ... !> \param scf_control ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE scf_env_initial_rho_setup(scf_env, qs_env, scf_section, scf_control, error) + SUBROUTINE scf_env_initial_rho_setup(scf_env, qs_env, scf_section, scf_control) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: scf_section TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_env_initial_rho_setup', & routineP = moduleN//':'//routineN @@ -1084,24 +1044,23 @@ SUBROUTINE scf_env_initial_rho_setup(scf_env, qs_env, scf_section, scf_control, CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(mo_coeff, rho, dft_control, para_env, mos) - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& rho=rho,& mos=mos,& dft_control=dft_control,& - para_env=para_env,& - error=error) + para_env=para_env) extrapolation_method_nr=wfi_use_guess_method_nr IF (ASSOCIATED(qs_env%wf_history)) THEN CALL wfi_extrapolate(qs_env%wf_history, & qs_env=qs_env, dt=1.0_dp, & extrapolation_method_nr=extrapolation_method_nr,& - orthogonal_wf=orthogonal_wf, error=error) + orthogonal_wf=orthogonal_wf) ! wfi_use_guess_method_nr the wavefunctions are not yet initialized IF ((.NOT.orthogonal_wf).AND.& (scf_env%method == ot_method_nr).AND.& @@ -1110,29 +1069,27 @@ SUBROUTINE scf_env_initial_rho_setup(scf_env, qs_env, scf_section, scf_control, CALL get_mo_set(mos(ispin)%mo_set, & mo_coeff=mo_coeff, nmo=nmo) CALL reorthogonalize_vectors(qs_env, & - v_matrix=mo_coeff, n_col=nmo,& - error=error) + v_matrix=mo_coeff, n_col=nmo) CALL set_mo_occupation(mo_set=mos(ispin)%mo_set, & - smear=scf_control%smear, error=error) + smear=scf_control%smear) END DO END IF END IF output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A)")& "Extrapolation method: "//& - TRIM(wfi_get_method_label(extrapolation_method_nr,error=error)) + TRIM(wfi_get_method_label(extrapolation_method_nr)) END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") IF (extrapolation_method_nr==wfi_use_guess_method_nr) THEN - CALL calculate_first_density_matrix(scf_env=scf_env,qs_env=qs_env,error=error) + CALL calculate_first_density_matrix(scf_env=scf_env,qs_env=qs_env) IF (.NOT.(scf_control%density_guess==densities_guess)) THEN - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.,& - error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) END IF END IF @@ -1140,19 +1097,19 @@ SUBROUTINE scf_env_initial_rho_setup(scf_env, qs_env, scf_section, scf_control, IF(scf_env%mixing_method>1) THEN IF(dft_control % qs_control%gapw) THEN CALL get_qs_env(qs_env=qs_env,& - rho_atom_set=rho_atom,error=error) + rho_atom_set=rho_atom) CALL mixing_init(scf_env%mixing_method,rho,scf_env%mixing_store,& - para_env,rho_atom=rho_atom,error=error) + para_env,rho_atom=rho_atom) ELSE CALL mixing_init(scf_env%mixing_method,rho,scf_env%mixing_store,& - para_env,error=error) + para_env) END IF END IF DO ispin=1,SIZE(mos)!fm->dbcsr IF(mos(ispin)%mo_set%use_mo_coeff_b) THEN CALL copy_fm_to_dbcsr(mos(ispin)%mo_set%mo_coeff,& - mos(ispin)%mo_set%mo_coeff_b,error=error)!fm->dbcsr + mos(ispin)%mo_set%mo_coeff_b)!fm->dbcsr ENDIF ENDDO!fm->dbcsr diff --git a/src/qs_scf_lanczos.F b/src/qs_scf_lanczos.F index 89390780cb..64dee5233f 100644 --- a/src/qs_scf_lanczos.F +++ b/src/qs_scf_lanczos.F @@ -53,19 +53,17 @@ MODULE qs_scf_lanczos !> \param krylov_space ... !> \param scf_control ... !> \param mos ... -!> \param error ... !> \param !> \par History !> 05.2009 created [MI] ! ***************************************************************************** - SUBROUTINE krylov_space_allocate(krylov_space, scf_control, mos, error) + SUBROUTINE krylov_space_allocate(krylov_space, scf_control, mos) TYPE(krylov_space_type), POINTER :: krylov_space TYPE(scf_control_type), POINTER :: scf_control TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'krylov_space_allocate', & routineP = moduleN//':'//routineN @@ -81,7 +79,7 @@ SUBROUTINE krylov_space_allocate(krylov_space, scf_control, mos, error) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(krylov_space),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(krylov_space),cp_failure_level,routineP,failure) IF(.NOT. ASSOCIATED(krylov_space%mo_conv)) THEN NULLIFY(fm_struct_tmp, mo_coeff) @@ -94,74 +92,74 @@ SUBROUTINE krylov_space_allocate(krylov_space, scf_control, mos, error) nspin = SIZE(mos,1) ALLOCATE(krylov_space%mo_conv(nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(krylov_space%mo_refine(nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(krylov_space%chc_mat(nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(krylov_space%c_vec(nspin),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) max_nmo = 0 DO ispin = 1,nspin CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff, nao=nao, nmo=nmo) - CALL cp_fm_create(krylov_space%mo_conv(ispin)%matrix,mo_coeff%matrix_struct,error=error) - CALL cp_fm_create(krylov_space%mo_refine(ispin)%matrix,mo_coeff%matrix_struct,error=error) + CALL cp_fm_create(krylov_space%mo_conv(ispin)%matrix,mo_coeff%matrix_struct) + CALL cp_fm_create(krylov_space%mo_refine(ispin)%matrix,mo_coeff%matrix_struct) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nmo, ncol_global=nmo,& para_env=mo_coeff%matrix_struct%para_env, & - context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create(krylov_space%chc_mat(ispin)%matrix,fm_struct_tmp,"chc",error=error) - CALL cp_fm_create(krylov_space%c_vec(ispin)%matrix,fm_struct_tmp,"vec",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create(krylov_space%chc_mat(ispin)%matrix,fm_struct_tmp,"chc") + CALL cp_fm_create(krylov_space%c_vec(ispin)%matrix,fm_struct_tmp,"vec") + CALL cp_fm_struct_release(fm_struct_tmp) max_nmo = MAX(max_nmo,nmo) END DO !the use of max_nmo might not be ok, in this case allocate nspin matrices ALLOCATE(krylov_space%c_eval(max_nmo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(krylov_space%v_mat(nk),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=nblock,& para_env=mo_coeff%matrix_struct%para_env, & - context=mo_coeff%matrix_struct%context,error=error) + context=mo_coeff%matrix_struct%context) DO ik = 1,nk CALL cp_fm_create(krylov_space%v_mat(ik)%matrix,matrix_struct=fm_struct_tmp,& - name="v_mat_"//TRIM(ADJUSTL(cp_to_string(ik))),error=error) + name="v_mat_"//TRIM(ADJUSTL(cp_to_string(ik)))) END DO CALL cp_fm_create(krylov_space%tmp_mat,matrix_struct=fm_struct_tmp,& - name="tmp_mat",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="tmp_mat") + CALL cp_fm_struct_release(fm_struct_tmp) ! NOTE: the following matrices are small and could be defined ! as standard array rather than istributed fm NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nblock, ncol_global=nblock,& para_env=mo_coeff%matrix_struct%para_env, & - context=mo_coeff%matrix_struct%context,error=error) + context=mo_coeff%matrix_struct%context) CALL cp_fm_create(krylov_space%block1_mat,matrix_struct=fm_struct_tmp,& - name="a_mat_"//TRIM(ADJUSTL(cp_to_string(ik))),error=error) + name="a_mat_"//TRIM(ADJUSTL(cp_to_string(ik)))) CALL cp_fm_create(krylov_space%block2_mat,matrix_struct=fm_struct_tmp,& - name="b_mat_"//TRIM(ADJUSTL(cp_to_string(ik))),error=error) + name="b_mat_"//TRIM(ADJUSTL(cp_to_string(ik)))) CALL cp_fm_create(krylov_space%block3_mat,matrix_struct=fm_struct_tmp,& - name="b2_mat_"//TRIM(ADJUSTL(cp_to_string(ik))),error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="b2_mat_"//TRIM(ADJUSTL(cp_to_string(ik)))) + CALL cp_fm_struct_release(fm_struct_tmp) ndim = nblock*nk NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ndim, ncol_global=ndim,& para_env=mo_coeff%matrix_struct%para_env, & - context=mo_coeff%matrix_struct%context,error=error) + context=mo_coeff%matrix_struct%context) CALL cp_fm_create(krylov_space%block4_mat,matrix_struct=fm_struct_tmp,& - name="t_mat",error=error) + name="t_mat") CALL cp_fm_create(krylov_space%block5_mat,matrix_struct=fm_struct_tmp,& - name="t_vec",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="t_vec") + CALL cp_fm_struct_release(fm_struct_tmp) ALLOCATE(krylov_space%t_eval(ndim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE !Nothing should be done @@ -183,14 +181,13 @@ END SUBROUTINE krylov_space_allocate !> \param eps_iter ... !> \param ispin ... !> \param check_moconv_only ... -!> \param error ... !> \param !> \par History !> 05.2009 created [MI] ! ***************************************************************************** SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & - eps_iter, ispin, check_moconv_only, error) + eps_iter, ispin, check_moconv_only) TYPE(krylov_space_type), POINTER :: krylov_space TYPE(cp_fm_type), POINTER :: ks, c0, c1 @@ -199,7 +196,6 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & REAL(dp), INTENT(IN) :: eps_iter INTEGER, INTENT(IN) :: ispin LOGICAL, INTENT(IN), OPTIONAL :: check_moconv_only - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lanczos_refinement', & routineP = moduleN//':'//routineN @@ -242,37 +238,37 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & NULLIFY(fm_struct_tmp, c_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=nmo,& para_env=c0%matrix_struct%para_env, & - context=c0%matrix_struct%context,error=error) + context=c0%matrix_struct%context) CALL cp_fm_create(c_tmp,matrix_struct=fm_struct_tmp,& - name="c_tmp",error=error) + name="c_tmp") CALL cp_fm_create(hc,matrix_struct=fm_struct_tmp,& - name="hc",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="hc") + CALL cp_fm_struct_release(fm_struct_tmp) !Compute (C^t)HC - CALL cp_gemm('N','N',nao,nmo,nao,rone,ks,c0,rzero,hc,error=error) - CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,hc,rzero,chc,error=error) + CALL cp_gemm('N','N',nao,nmo,nao,rone,ks,c0,rzero,hc) + CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,hc,rzero,chc) !Diagonalize (C^t)HC CALL timeset(routineN//"diag_chc",hand1) - CALL choose_eigv_solver(chc,evec,eval,error=error) + CALL choose_eigv_solver(chc,evec,eval) CALL timestop(hand1) !Rotate the C vectors - CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,c1,error=error) + CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,c1) !Check for converged states - CALL cp_gemm('N','N',nao,nmo,nmo,rone,hc,evec,rzero,c_tmp,error=error) + CALL cp_gemm('N','N',nao,nmo,nmo,rone,hc,evec,rzero,c_tmp) CALL cp_fm_to_fm(c1,c0,nmo,1,1) CALL cp_fm_column_scale(c1,eval) - CALL cp_fm_scale_and_add(1.0_dp,c_tmp,rmone,c1,error=error) - CALL cp_fm_vectorsnorm(c_tmp,c_res,error=error) + CALL cp_fm_scale_and_add(1.0_dp,c_tmp,rmone,c1) + CALL cp_fm_vectorsnorm(c_tmp,c_res) nmo_converged = 0 nmo_nc = 0 max_norm = 0.0_dp min_norm = 1.e10_dp - CALL cp_fm_set_all(c1,rzero,error=error) + CALL cp_fm_set_all(c1,rzero) DO imo = 1,nmo max_norm = MAX(max_norm,c_res(imo)) min_norm = MIN(min_norm,c_res(imo)) @@ -295,8 +291,8 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & krylov_space%min_res_norm = min_norm IF(my_check_moconv_only) THEN - CALL cp_fm_release(c_tmp,error) - CALL cp_fm_release(hc,error) + CALL cp_fm_release(c_tmp) + CALL cp_fm_release(hc) CALL timestop(handle) RETURN ELSE IF(krylov_space%nmo_nc>0) THEN @@ -320,17 +316,17 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=ndim,& para_env=c0%matrix_struct%para_env, & - context=c0%matrix_struct%context,error=error) + context=c0%matrix_struct%context) CALL cp_fm_create(c2_tmp,matrix_struct=fm_struct_tmp,& - name="c2_tmp",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="c2_tmp") + CALL cp_fm_struct_release(fm_struct_tmp) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nmob, ncol_global=ndim,& para_env=c0%matrix_struct%para_env, & - context=c0%matrix_struct%context,error=error) + context=c0%matrix_struct%context) CALL cp_fm_create(c3_tmp,matrix_struct=fm_struct_tmp,& - name="c3_tmp",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="c3_tmp") + CALL cp_fm_struct_release(fm_struct_tmp) ! Create local matrix of right size IF(nmob/=nblock) THEN @@ -338,33 +334,33 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nmob, ncol_global=nmob,& para_env=chc%matrix_struct%para_env, & - context=chc%matrix_struct%context,error=error) + context=chc%matrix_struct%context) CALL cp_fm_create(a_mat,matrix_struct=fm_struct_tmp,& - name="a_mat",error=error) + name="a_mat") CALL cp_fm_create(b_mat,matrix_struct=fm_struct_tmp,& - name="b_mat",error=error) + name="b_mat") CALL cp_fm_create(b2_mat,matrix_struct=fm_struct_tmp,& - name="b2_mat",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="b2_mat") + CALL cp_fm_struct_release(fm_struct_tmp) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ndim, ncol_global=ndim,& para_env=chc%matrix_struct%para_env, & - context=chc%matrix_struct%context,error=error) + context=chc%matrix_struct%context) CALL cp_fm_create(t_mat,matrix_struct=fm_struct_tmp,& - name="t_mat",error=error) + name="t_mat") CALL cp_fm_create(t_vec,matrix_struct=fm_struct_tmp,& - name="t_vec",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="t_vec") + CALL cp_fm_struct_release(fm_struct_tmp) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=nmob,& para_env=c0%matrix_struct%para_env, & - context=c0%matrix_struct%context,error=error) + context=c0%matrix_struct%context) ALLOCATE(v_mat(krylov_space%nkrylov)) DO ik=1,krylov_space%nkrylov CALL cp_fm_create(v_mat(ik)%matrix,matrix_struct=fm_struct_tmp,& - name="v_mat",error=error) + name="v_mat") END DO - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_tmp) ELSE a_mat => krylov_space%block1_mat b_mat => krylov_space%block2_mat @@ -378,58 +374,58 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & ALLOCATE(tvblock(nmob,ndim),STAT=istat) CALL timeset(routineN//"_kry_loop",hand2) - CALL cp_fm_set_all(b_mat,rzero,error=error) - CALL cp_fm_set_all(t_mat,rzero,error=error) + CALL cp_fm_set_all(b_mat,rzero) + CALL cp_fm_set_all(t_mat,rzero) CALL cp_fm_to_fm(c1,v_mat(1)%matrix,nmob,imo_low,1) !Compute A =(V^t)HV - CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(1)%matrix,rzero,hc,error=error) + CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(1)%matrix,rzero,hc) CALL cp_gemm('T','N',nmob,nmob,nao,rone,v_mat(1)%matrix,hc,& - rzero,a_mat,error=error) + rzero,a_mat) !Compute the residual matrix R for next !factorisation CALL cp_gemm('N','N',nao,nmob,nmob,rone,v_mat(1)%matrix,a_mat,& - rzero,c_tmp,error=error) - CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc,error=error) + rzero,c_tmp) + CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc) ! Build the block tridiagonal matrix - CALL cp_fm_get_submatrix(a_mat,tblock,1,1,nmob,nmob,error=error) - CALL cp_fm_set_submatrix(t_mat,tblock,1,1,nmob,nmob,error=error) + CALL cp_fm_get_submatrix(a_mat,tblock,1,1,nmob,nmob) + CALL cp_fm_set_submatrix(t_mat,tblock,1,1,nmob,nmob) DO ik = 2,krylov_space%nkrylov ! Call lapack for QR factorization - CALL cp_fm_set_all(b_mat,rzero,error=error) + CALL cp_fm_set_all(b_mat,rzero) CALL cp_fm_to_fm(c_tmp,v_mat(ik)%matrix,nmob,1,1) - CALL cp_fm_qr_factorization(c_tmp, b_mat, nao, nmob, 1,1,error=error) + CALL cp_fm_qr_factorization(c_tmp, b_mat, nao, nmob, 1,1) CALL cp_fm_triangular_multiply(b_mat, v_mat(ik)%matrix, side="R", invert_tr=.TRUE.,& - n_rows=nao,n_cols=nmob,error=error) + n_rows=nao,n_cols=nmob) !Compute A =(V^t)HV - CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(ik)%matrix,rzero,hc,error=error) - CALL cp_gemm('T','N',nmob,nmob,nao,rone,v_mat(ik)%matrix,hc,rzero, a_mat,error=error) + CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(ik)%matrix,rzero,hc) + CALL cp_gemm('T','N',nmob,nmob,nao,rone,v_mat(ik)%matrix,hc,rzero, a_mat) !Compute the !residual matrix R !for next !factorisation CALL cp_gemm('N','N',nao,nmob,nmob,rone,v_mat(ik)%matrix,a_mat,& - rzero,c_tmp,error=error) - CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc,error=error) + rzero,c_tmp) + CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc) CALL cp_fm_to_fm(v_mat(ik-1)%matrix,hc,nmob,1,1) CALL cp_fm_triangular_multiply(b_mat,hc,side='R',transpose_tr=.TRUE.,& - n_rows=nao,n_cols=nmob,alpha=rmone,error=error) - CALL cp_fm_scale_and_add(rone,c_tmp,rone,hc,error=error) + n_rows=nao,n_cols=nmob,alpha=rmone) + CALL cp_fm_scale_and_add(rone,c_tmp,rone,hc) ! Build the block tridiagonal matrix it = (ik-2)*nmob + 1 jt = (ik-1)*nmob + 1 - CALL cp_fm_get_submatrix(a_mat,tblock,1,1,nmob,nmob,error=error) - CALL cp_fm_set_submatrix(t_mat,tblock,jt,jt,nmob,nmob,error=error) - CALL cp_fm_transpose(b_mat,a_mat,error=error) - CALL cp_fm_get_submatrix(a_mat,tblock,1,1,nmob,nmob,error=error) - CALL cp_fm_set_submatrix(t_mat,tblock,it,jt,nmob,nmob,error=error) + CALL cp_fm_get_submatrix(a_mat,tblock,1,1,nmob,nmob) + CALL cp_fm_set_submatrix(t_mat,tblock,jt,jt,nmob,nmob) + CALL cp_fm_transpose(b_mat,a_mat) + CALL cp_fm_get_submatrix(a_mat,tblock,1,1,nmob,nmob) + CALL cp_fm_set_submatrix(t_mat,tblock,it,jt,nmob,nmob) END DO ! ik CALL timestop(hand2) @@ -438,27 +434,27 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & CALL timeset(routineN//"_diag_tri",hand3) - CALL choose_eigv_solver(t_mat,t_vec,t_eval,error=error) + CALL choose_eigv_solver(t_mat,t_vec,t_eval) ! Diagonalize the block-tridiagonal matrix CALL timestop(hand3) CALL timeset(routineN//"_build_cnew",hand4) ! !Compute the refined vectors - CALL cp_fm_set_all(c2_tmp,rzero,error=error) + CALL cp_fm_set_all(c2_tmp,rzero) DO ik = 1,krylov_space%nkrylov jt = (ik-1)*nmob CALL cp_gemm('N','N',nao,ndim,nmob,rone,v_mat(ik)%matrix,t_vec,rone,c2_tmp,& - b_first_row=(jt+1),error=error) + b_first_row=(jt+1)) END DO DEALLOCATE(tvblock,STAT=istat) - CALL cp_fm_set_all(c3_tmp,rzero,error=error) - CALL cp_gemm('T','N',nmob,ndim,nao,rone,v_mat(1)%matrix,c2_tmp,rzero,c3_tmp,error=error) + CALL cp_fm_set_all(c3_tmp,rzero) + CALL cp_gemm('T','N',nmob,ndim,nao,rone,v_mat(1)%matrix,c2_tmp,rzero,c3_tmp) !Try to avoid linear dependencies ALLOCATE(q_mat(nmob,ndim),STAT=istat) !get max - CALL cp_fm_get_submatrix(c3_tmp,q_mat,1,1,nmob,ndim,error=error) + CALL cp_fm_get_submatrix(c3_tmp,q_mat,1,1,nmob,ndim) ALLOCATE(itaken(ndim),STAT=istat) itaken = 0 @@ -483,33 +479,33 @@ SUBROUTINE lanczos_refinement(krylov_space, ks, c0, c1, eval, nao, & CALL timestop(hand4) IF(nmob \param eps_iter ... !> \param ispin ... !> \param check_moconv_only ... -!> \param error ... ! ***************************************************************************** SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & - eps_iter, ispin, check_moconv_only, error) + eps_iter, ispin, check_moconv_only) TYPE(krylov_space_type), POINTER :: krylov_space TYPE(cp_fm_type), POINTER :: ks, c0, c1 @@ -543,7 +538,6 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & REAL(dp), INTENT(IN) :: eps_iter INTEGER, INTENT(IN) :: ispin LOGICAL, INTENT(IN), OPTIONAL :: check_moconv_only - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'lanczos_refinement_2v', & routineP = moduleN//':'//routineN @@ -591,39 +585,39 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & NULLIFY(fm_struct_tmp, c_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=nmo,& para_env=c0%matrix_struct%para_env, & - context=c0%matrix_struct%context,error=error) + context=c0%matrix_struct%context) CALL cp_fm_create(c_tmp,matrix_struct=fm_struct_tmp,& - name="c_tmp",error=error) + name="c_tmp") CALL cp_fm_create(hc,matrix_struct=fm_struct_tmp,& - name="hc",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="hc") + CALL cp_fm_struct_release(fm_struct_tmp) !Compute (C^t)HC - CALL cp_gemm('N','N',nao,nmo,nao,rone,ks,c0,rzero,hc,error=error) - CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,hc,rzero,chc,error=error) + CALL cp_gemm('N','N',nao,nmo,nao,rone,ks,c0,rzero,hc) + CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,hc,rzero,chc) !Diagonalize (C^t)HC CALL timeset(routineN//"diag_chc",hand1) - CALL choose_eigv_solver(chc,evec,eval,error=error) + CALL choose_eigv_solver(chc,evec,eval) CALL timestop(hand1) CALL timeset(routineN//"check_conv",hand6) !Rotate the C vectors - CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,c1,error=error) + CALL cp_gemm('N','N',nao,nmo,nmo,rone,c0,evec,rzero,c1) !Check for converged states - CALL cp_gemm('N','N',nao,nmo,nmo,rone,hc,evec,rzero,c_tmp,error=error) + CALL cp_gemm('N','N',nao,nmo,nmo,rone,hc,evec,rzero,c_tmp) CALL cp_fm_to_fm(c1,c0,nmo,1,1) CALL cp_fm_column_scale(c1,eval) - CALL cp_fm_scale_and_add(1.0_dp,c_tmp,rmone,c1,error=error) - CALL cp_fm_vectorsnorm(c_tmp,c_res,error=error) + CALL cp_fm_scale_and_add(1.0_dp,c_tmp,rmone,c1) + CALL cp_fm_vectorsnorm(c_tmp,c_res) nmo_converged = 0 nmo_nc = 0 max_norm = 0.0_dp min_norm = 1.e10_dp - CALL cp_fm_set_all(c1,rzero,error=error) + CALL cp_fm_set_all(c1,rzero) DO imo = 1,nmo max_norm = MAX(max_norm,c_res(imo)) min_norm = MIN(min_norm,c_res(imo)) @@ -638,8 +632,8 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & END DO CALL timestop(hand6) - CALL cp_fm_release(c_tmp,error) - CALL cp_fm_release(hc,error) + CALL cp_fm_release(c_tmp) + CALL cp_fm_release(hc) krylov_space%nmo_nc = nmo_nc krylov_space%nmo_conv = nmo_converged @@ -669,11 +663,11 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & ! Allocation CALL timeset(routineN//"alloc",hand6) ALLOCATE(a_block(nmob,nmob),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(b_block(nmob,nmob),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(t_mat(ndim,ndim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(fm_struct_tmp) ! by forcing ncol_block=nmo, the needed part of the matrix is distributed on a subset of processes @@ -686,56 +680,56 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & ncol_block=nmob,& para_env=c0%matrix_struct%para_env, & context=c0%matrix_struct%context,& - force_block=.TRUE.,error=error) + force_block=.TRUE.) CALL cp_fm_create(c_tmp,matrix_struct=fm_struct_tmp,& - name="c_tmp",error=error) - CALL cp_fm_set_all(c_tmp,rzero,error=error) + name="c_tmp") + CALL cp_fm_set_all(c_tmp,rzero) CALL cp_fm_create(v_tmp,matrix_struct=fm_struct_tmp,& - name="v_tmp",error=error) - CALL cp_fm_set_all(v_tmp,rzero,error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="v_tmp") + CALL cp_fm_set_all(v_tmp,rzero) + CALL cp_fm_struct_release(fm_struct_tmp) NULLIFY(fm_struct_tmp) ALLOCATE(v_mat(krylov_space%nkrylov),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=nmob,& ncol_block=nmob,& para_env=c0%matrix_struct%para_env, & context=c0%matrix_struct%context, & - force_block=.TRUE.,error=error) + force_block=.TRUE.) DO ik=1,krylov_space%nkrylov CALL cp_fm_create(v_mat(ik)%matrix,matrix_struct=fm_struct_tmp,& - name="v_mat",error=error) + name="v_mat") END DO CALL cp_fm_create(hc,matrix_struct=fm_struct_tmp,& - name="hc",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="hc") + CALL cp_fm_struct_release(fm_struct_tmp) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nao, ncol_global=ndim,& ncol_block=ndim,& para_env=c0%matrix_struct%para_env, & context=c0%matrix_struct%context,& - force_block=.TRUE., error=error) + force_block=.TRUE.) CALL cp_fm_create(c2_tmp,matrix_struct=fm_struct_tmp,& - name="c2_tmp",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="c2_tmp") + CALL cp_fm_struct_release(fm_struct_tmp) NULLIFY(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nmob, ncol_global=nmob,& para_env=c0%matrix_struct%para_env, & - context=c0%matrix_struct%context,error=error) + context=c0%matrix_struct%context) CALL cp_fm_create(b_mat,matrix_struct=fm_struct_tmp,& - name="b_mat",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + name="b_mat") + CALL cp_fm_struct_release(fm_struct_tmp) CALL timestop(hand6) !End allocation - CALL cp_fm_set_all(b_mat,rzero,error=error) + CALL cp_fm_set_all(b_mat,rzero) CALL cp_fm_to_fm(c1,v_mat(1)%matrix,nmob,imo_low,1) ! Here starts the construction of krylov space CALL timeset(routineN//"_kry_loop",hand2) !Compute A =(V^t)HV - CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(1)%matrix,rzero,hc,error=error) + CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(1)%matrix,rzero,hc) a_block = 0.0_dp a_loc => v_mat(1)%matrix%local_data @@ -758,7 +752,7 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & SIZE(c_tmp%local_data,1),a_block(1,1),nmob,0.0_dp,& b_loc(1,1), SIZE(c_tmp%local_data,1)) END IF - CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc,error=error) + CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc) ! Build the block tridiagonal matrix t_mat = 0.0_dp @@ -768,17 +762,17 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & DO ik = 2,krylov_space%nkrylov ! Call lapack for QR factorization - CALL cp_fm_set_all(b_mat,rzero,error=error) + CALL cp_fm_set_all(b_mat,rzero) CALL cp_fm_to_fm(c_tmp,v_mat(ik)%matrix,nmob,1,1) - CALL cp_fm_qr_factorization(c_tmp, b_mat, nao, nmob, 1,1,error=error) + CALL cp_fm_qr_factorization(c_tmp, b_mat, nao, nmob, 1,1) CALL cp_fm_triangular_multiply(b_mat, v_mat(ik)%matrix, side="R", invert_tr=.TRUE.,& - n_rows=nao,n_cols=nmob,error=error) + n_rows=nao,n_cols=nmob) - CALL cp_fm_get_submatrix(b_mat,b_block,1,1,nmob,nmob,error=error) + CALL cp_fm_get_submatrix(b_mat,b_block,1,1,nmob,nmob) !Compute A =(V^t)HV - CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(ik)%matrix,rzero,hc,error=error) + CALL cp_gemm('N','N',nao,nmob,nao,rone,ks,v_mat(ik)%matrix,rzero,hc) a_block = 0.0_dp IF(SIZE(hc%local_data,2)==nmob) THEN @@ -799,7 +793,7 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & SIZE(c_tmp%local_data,1),a_block(1,1),nmob,0.0_dp,& b_loc(1,1), SIZE(c_tmp%local_data,1)) END IF - CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc,error=error) + CALL cp_fm_scale_and_add(rmone,c_tmp,rone,hc) IF(SIZE(c_tmp%local_data,2)==nmob) THEN a_loc => v_mat(ik-1)%matrix%local_data @@ -829,17 +823,17 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & lwork = 1 + 6*ndim + 2*ndim**2 + 5000 liwork = 5*ndim + 3 ALLOCATE(work(lwork),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(liwork),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! Diagonalize the block-tridiagonal matrix CALL dsyevd('V', 'U', ndim, t_mat(1,1),ndim,t_eval(1), & work(1), lwork, iwork(1), liwork, info) DEALLOCATE(work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(iwork,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(hand3) CALL timeset(routineN//"_build_cnew",hand4) @@ -847,7 +841,7 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & c2_tmp%local_data=0.0_dp ALLOCATE(q_mat(nmob,ndim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) q_mat = 0.0_dp b_loc => c2_tmp%local_data DO ik = 1,krylov_space%nkrylov @@ -875,7 +869,7 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & CALL mp_sum(q_mat, hc%matrix_struct%para_env%group) ALLOCATE(itaken(ndim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) itaken = 0 DO it = 1,nmob vmax = 0.0_dp @@ -891,40 +885,40 @@ SUBROUTINE lanczos_refinement_2v(krylov_space, ks, c0, c1, eval, nao, & CALL cp_fm_to_fm(c2_tmp,v_mat(1)%matrix,1,ik,it) END DO DEALLOCATE(itaken,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(q_mat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) !Copy in the converged set to enlarge the converged subspace CALL cp_fm_to_fm(v_mat(1)%matrix,c0,nmob,1,(nmo_converged+imo_low)) CALL timestop(hand4) - CALL cp_fm_release(c2_tmp,error) - CALL cp_fm_release(c_tmp,error) - CALL cp_fm_release(hc,error) - CALL cp_fm_release(v_tmp,error) - CALL cp_fm_release(b_mat,error) + CALL cp_fm_release(c2_tmp) + CALL cp_fm_release(c_tmp) + CALL cp_fm_release(hc) + CALL cp_fm_release(v_tmp) + CALL cp_fm_release(b_mat) DEALLOCATE(t_mat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(a_block,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(b_block,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ik=1,krylov_space%nkrylov - CALL cp_fm_release(v_mat(ik)%matrix,error) + CALL cp_fm_release(v_mat(ik)%matrix) END DO DEALLOCATE(v_mat,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO ! ib CALL timeset(routineN//"_ortho",hand5) - CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,c0,rzero,chc,error=error) + CALL cp_gemm('T','N',nmo,nmo,nao,rone,c0,c0,rzero,chc) - CALL cp_fm_cholesky_decompose(chc,nmo,error=error) - CALL cp_fm_triangular_multiply(chc,c0,'R',invert_tr=.TRUE.,error=error) + CALL cp_fm_cholesky_decompose(chc,nmo) + CALL cp_fm_triangular_multiply(chc,c0,'R',invert_tr=.TRUE.) CALL timestop(hand5) ELSE ! Do nothing diff --git a/src/qs_scf_loop_utils.F b/src/qs_scf_loop_utils.F index f4da3f6680..5cea2fbfc7 100644 --- a/src/qs_scf_loop_utils.F +++ b/src/qs_scf_loop_utils.F @@ -85,15 +85,13 @@ MODULE qs_scf_loop_utils !> \param energy_only ... !> \param just_energy ... !> \param exit_inner_loop ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_scf_set_loop_flags(scf_env,diis_step,& - energy_only,just_energy,exit_inner_loop,error) + energy_only,just_energy,exit_inner_loop) TYPE(qs_scf_env_type), POINTER :: scf_env LOGICAL :: diis_step, energy_only, & just_energy, exit_inner_loop - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_set_loop_flags', & routineP = moduleN//':'//routineN @@ -122,16 +120,14 @@ END SUBROUTINE qs_scf_set_loop_flags !> \param scf_section ... !> \param diis_step ... !> \param energy_only ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_scf_new_mos(qs_env,scf_env,scf_control,scf_section,diis_step,& - energy_only,error) + energy_only) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: scf_section LOGICAL :: diis_step, energy_only - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_new_mos', & routineP = moduleN//':'//routineN @@ -156,8 +152,7 @@ SUBROUTINE qs_scf_new_mos(qs_env,scf_env,scf_control,scf_section,diis_step,& ks_env=ks_env, & matrix_ks=matrix_ks,rho=rho,mos=mos, & dft_control=dft_control, & - has_unit_metric=has_unit_metric,& - error=error) + has_unit_metric=has_unit_metric) scf_env%iter_param = 0.0_dp @@ -165,7 +160,7 @@ SUBROUTINE qs_scf_new_mos(qs_env,scf_env,scf_control,scf_section,diis_step,& CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown scf method: "//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) ! ************************************************************************* ! Filter matrix diagonalisation: ugly implementation at this point of time @@ -173,24 +168,24 @@ SUBROUTINE qs_scf_new_mos(qs_env,scf_env,scf_control,scf_section,diis_step,& CASE(filter_matrix_diag_method_nr) CALL fb_env_do_diag(scf_env%filter_matrix_env, qs_env, & - matrix_ks, matrix_s, scf_section, diis_step, error) + matrix_ks, matrix_s, scf_section, diis_step) ! Diagonlization in non orthonormal case CASE(general_diag_method_nr) IF (dft_control%roks) THEN CALL do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& scf_control,scf_section,diis_step,& - has_unit_metric,error) + has_unit_metric) ELSE CALL do_general_diag(scf_env,mos,matrix_ks,& matrix_s,scf_control,scf_section, & - diis_step,error=error) + diis_step) IF(scf_control%do_diag_sub) THEN skip_diag_sub = (scf_env%subspace_env%eps_diag_sub > 0.0_dp) .AND. & (scf_env%iter_count==1 .OR. scf_env%iter_delta>scf_env%subspace_env%eps_diag_sub ) IF( .NOT. skip_diag_sub) THEN CALL do_scf_diag_subspace(qs_env,scf_env,scf_env%subspace_env,mos,rho,& - ks_env,scf_section,scf_control,error=error) + ks_env,scf_section,scf_control) END IF END IF END IF @@ -199,52 +194,52 @@ SUBROUTINE qs_scf_new_mos(qs_env,scf_env,scf_control,scf_section,diis_step,& IF (dft_control%roks) THEN CALL do_roks_diag(scf_env,mos,matrix_ks,matrix_s,& scf_control,scf_section,diis_step,& - has_unit_metric,error) + has_unit_metric) ELSE CALL do_special_diag(scf_env,mos,matrix_ks,& scf_control,scf_section, & - diis_step,error) + diis_step) END IF ! OT diagonlization CASE(ot_diag_method_nr) CALL do_ot_diag(scf_env,mos,matrix_ks,matrix_s,& - scf_control,scf_section,diis_step,error) + scf_control,scf_section,diis_step) ! Block Krylov diagonlization CASE(block_krylov_diag_method_nr) IF((scf_env%krylov_space%eps_std_diag > 0.0_dp) .AND.& (scf_env%iter_count==1 .OR. scf_env%iter_delta>scf_env%krylov_space%eps_std_diag)) THEN IF(scf_env%krylov_space%always_check_conv) THEN CALL do_block_krylov_diag(scf_env,mos,matrix_ks,& - scf_control, scf_section, check_moconv_only=.TRUE., error=error) + scf_control, scf_section, check_moconv_only=.TRUE.) END IF CALL do_general_diag(scf_env,mos,matrix_ks,& - matrix_s,scf_control,scf_section, diis_step,error=error) + matrix_s,scf_control,scf_section, diis_step) ELSE CALL do_block_krylov_diag(scf_env,mos,matrix_ks, & - scf_control, scf_section, error=error) + scf_control, scf_section) END IF IF(scf_control%do_diag_sub) THEN skip_diag_sub = (scf_env%subspace_env%eps_diag_sub > 0.0_dp) .AND. & (scf_env%iter_count==1 .OR. scf_env%iter_delta>scf_env%subspace_env%eps_diag_sub ) IF( .NOT. skip_diag_sub) THEN CALL do_scf_diag_subspace(qs_env,scf_env,scf_env%subspace_env,mos,rho,& - ks_env,scf_section, scf_control,error=error) + ks_env,scf_section, scf_control) END IF END IF ! Block Davidson diagonlization CASE(block_davidson_diag_method_nr) CALL do_block_davidson_diag(qs_env,scf_env,mos,matrix_ks,matrix_s,scf_control,& - scf_section,.FALSE.,error=error) + scf_section,.FALSE.) ! OT without diagonlization. Needs special treatment for SCP runs CASE(ot_method_nr) CALL qs_scf_loop_do_ot(qs_env,scf_env,scf_control%smear,mos,rho,& qs_env%mo_derivs,energy%total, & - matrix_s, energy_only=energy_only,has_unit_metric=has_unit_metric,error=error) + matrix_s, energy_only=energy_only,has_unit_metric=has_unit_metric) END SELECT energy%kTS = 0.0_dp energy%efermi = 0.0_dp - CALL get_qs_env(qs_env,mos=mos,error=error) + CALL get_qs_env(qs_env,mos=mos) DO ispin=1,SIZE(mos) energy%kTS = energy%kTS + mos(ispin)%mo_set%kTS energy%efermi = energy%efermi + mos(ispin)%mo_set%mu @@ -262,14 +257,12 @@ END SUBROUTINE qs_scf_new_mos !> \param scf_env ... !> \param scf_control ... !> \param diis_step ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_new_mos_kp(qs_env,scf_env,scf_control,diis_step,error) + SUBROUTINE qs_scf_new_mos_kp(qs_env,scf_env,scf_control,diis_step) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control LOGICAL :: diis_step - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_new_mos_kp', & routineP = moduleN//':'//routineN @@ -285,38 +278,38 @@ SUBROUTINE qs_scf_new_mos_kp(qs_env,scf_env,scf_control,diis_step,error) NULLIFY(dft_control, kpoints, matrix_ks, matrix_s) CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,& - kpoints=kpoints,error=error) + kpoints=kpoints) scf_env%iter_param = 0.0_dp CALL cp_assert(.NOT.dft_control%roks,cp_failure_level,cp_assertion_failed,& - routineP,"KP code: ROKS method not available: ",error,failure) + routineP,"KP code: ROKS method not available: ",failure) SELECT CASE (scf_env%method) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"KP code: Unknown scf method: "//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) CASE(general_diag_method_nr) ! Diagonlization in non orthonormal case - CALL get_qs_env(qs_env,matrix_ks_kp=matrix_ks,matrix_s_kp=matrix_s,error=error) + CALL get_qs_env(qs_env,matrix_ks_kp=matrix_ks,matrix_s_kp=matrix_s) CALL do_general_diag_kp(scf_env,matrix_ks,matrix_s,kpoints,& - scf_control,diis_step,error=error) + scf_control,diis_step) CASE(special_diag_method_nr) - CALL get_qs_env(qs_env=qs_env,has_unit_metric=has_unit_metric,error=error) - CPPrecondition(has_unit_metric,cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env=qs_env,has_unit_metric=has_unit_metric) + CPPrecondition(has_unit_metric,cp_failure_level,routineP,failure) ! Diagonlization in orthonormal case ! CALL do_special_diag(scf_env,mos,matrix_ks,& -! scf_control,scf_section,diis_step,error) +! scf_control,scf_section,diis_step) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"KP code: Scf method not available: "//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) CASE(ot_diag_method_nr,& block_krylov_diag_method_nr,& block_davidson_diag_method_nr,& ot_method_nr) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"KP code: Scf method not available: "//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) END SELECT END SUBROUTINE qs_scf_new_mos_kp @@ -335,13 +328,12 @@ END SUBROUTINE qs_scf_new_mos_kp !> \param matrix_s ... !> \param energy_only ... !> \param has_unit_metric ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] !> 2013 moved from qs_scf [Florian Schiffmann] ! ***************************************************************************** SUBROUTINE qs_scf_loop_do_ot(qs_env,scf_env,smear,mos,rho,mo_derivs,total_energy,& - matrix_s,energy_only,has_unit_metric,error) + matrix_s,energy_only,has_unit_metric) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env @@ -356,7 +348,6 @@ SUBROUTINE qs_scf_loop_do_ot(qs_env,scf_env,smear,mos,rho,mo_derivs,total_energy POINTER :: matrix_s LOGICAL, INTENT(INOUT) :: energy_only LOGICAL, INTENT(IN) :: has_unit_metric - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_loop_do_ot', & routineP = moduleN//':'//routineN @@ -371,7 +362,7 @@ SUBROUTINE qs_scf_loop_do_ot(qs_env,scf_env,smear,mos,rho,mo_derivs,total_energy NULLIFY(rho_ao) failure = .FALSE. - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) IF (has_unit_metric) THEN NULLIFY(orthogonality_metric) @@ -384,20 +375,18 @@ SUBROUTINE qs_scf_loop_do_ot(qs_env,scf_env,smear,mos,rho,mo_derivs,total_energy CALL ot_scf_mini(mos,mo_derivs,smear,orthogonality_metric, & total_energy,energy_only,scf_env%iter_delta, & - scf_env%qs_ot_env,qs_env%input,error=error) + scf_env%qs_ot_env,qs_env%input) DO ispin=1,SIZE(mos) CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,& - smear=smear,& - error=error) + smear=smear) ENDDO DO ispin=1,SIZE(mos) CALL calculate_density_matrix(mos(ispin)%mo_set,& rho_ao(ispin)%matrix,& - use_dbcsr=.TRUE.,& - error=error) + use_dbcsr=.TRUE.) END DO scf_env%iter_method=scf_env%qs_ot_env(1)%OT_METHOD_FULL @@ -416,15 +405,13 @@ END SUBROUTINE qs_scf_loop_do_ot !> \param para_env Parallel environment !> \param diis_step Did we do a DIIS step? !> \param do_kpoints Is this a kpoint run? -!> \param error CP2K error handling variable ! ***************************************************************************** - SUBROUTINE qs_scf_density_mixing(scf_env,rho,para_env,diis_step,do_kpoints,error) + SUBROUTINE qs_scf_density_mixing(scf_env,rho,para_env,diis_step,do_kpoints) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env LOGICAL :: diis_step LOGICAL, INTENT(IN) :: do_kpoints - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_density_mixing', & routineP = moduleN//':'//routineN @@ -436,23 +423,23 @@ SUBROUTINE qs_scf_density_mixing(scf_env,rho,para_env,diis_step,do_kpoints,error failure=.FALSE. NULLIFY(rho_ao_kp) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) SELECT CASE(scf_env%mixing_method) CASE(direct_mixing_nr) CALL scf_env_density_mixing(scf_env%p_mix_new,& scf_env%mixing_store, rho_ao_kp, para_env, scf_env%iter_delta, scf_env%iter_count, & - diis=diis_step, error=error) + diis=diis_step) CASE(gspace_mixing_nr,pulay_mixing_nr,broyden_mixing_nr,& broyden_mixing_new_nr,multisecant_mixing_nr) ! Compute the difference p_out-p_in CALL self_consistency_check(rho_ao_kp,scf_env%p_delta,para_env,scf_env%p_mix_new,& - delta=scf_env%iter_delta, error=error) + delta=scf_env%iter_delta) CASE(no_mixing_nr) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown scf mixing method: "//& - cp_to_string(scf_env%mixing_method),error,failure) + cp_to_string(scf_env%mixing_method),failure) END SELECT END SUBROUTINE qs_scf_density_mixing @@ -466,17 +453,15 @@ END SUBROUTINE qs_scf_density_mixing !> \param should_stop ... !> \param outer_loop_converged ... !> \param exit_outer_loop ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_scf_check_outer_exit(qs_env,scf_env,scf_control,should_stop,& - outer_loop_converged,exit_outer_loop,error) + outer_loop_converged,exit_outer_loop) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control LOGICAL :: should_stop, & outer_loop_converged, & exit_outer_loop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_check_outer_exit', & routineP = moduleN//':'//routineN @@ -489,7 +474,7 @@ SUBROUTINE qs_scf_check_outer_exit(qs_env,scf_env,scf_control,should_stop,& scf_env%outer_scf%iter_count=scf_env%outer_scf%iter_count+1 outer_loop_converged=.FALSE. - CALL outer_loop_gradient(qs_env,scf_env,error) + CALL outer_loop_gradient(qs_env,scf_env) outer_loop_eps=SQRT(SUM(scf_env%outer_scf%gradient(:,scf_env%outer_scf%iter_count)**2))/ & SIZE(scf_env%outer_scf%gradient,1) IF (outer_loop_eps \param exit_inner_loop ... !> \param inner_loop_converged ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_scf_check_inner_exit(qs_env,scf_env,scf_control,should_stop,& - exit_inner_loop,inner_loop_converged,output_unit,error) + exit_inner_loop,inner_loop_converged,output_unit) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control LOGICAL :: should_stop, exit_inner_loop, & inner_loop_converged INTEGER :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_check_inner_exit', & routineP = moduleN//':'//routineN @@ -529,7 +512,7 @@ SUBROUTINE qs_scf_check_inner_exit(qs_env,scf_env,scf_control,should_stop,& exit_inner_loop = .FALSE. CALL external_control(should_stop,"SCF",target_time=qs_env%target_time, & - start_time=qs_env%start_time,error=error) + start_time=qs_env%start_time) IF (scf_env%iter_delta < scf_control%eps_scf) THEN IF (output_unit>0) THEN WRITE(UNIT=output_unit,FMT="(/,T3,A,I5,A/)")& @@ -556,15 +539,13 @@ END SUBROUTINE qs_scf_check_inner_exit !> \param dft_control ... !> \param para_env ... !> \param diis_step ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_undo_mixing(scf_env,rho,dft_control,para_env,diis_step,error) + SUBROUTINE qs_scf_undo_mixing(scf_env,rho,dft_control,para_env,diis_step) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_rho_type), POINTER :: rho TYPE(dft_control_type), POINTER :: dft_control TYPE(cp_para_env_type), POINTER :: para_env LOGICAL :: diis_step - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_undo_mixing', & routineP = moduleN//':'//routineN @@ -578,18 +559,18 @@ SUBROUTINE qs_scf_undo_mixing(scf_env,rho,dft_control,para_env,diis_step,error) NULLIFY(rho_ao_kp) IF (scf_env%mixing_method>0) THEN - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) nc = SIZE(scf_env%p_mix_new,2) SELECT CASE(scf_env%mixing_method) CASE(direct_mixing_nr) CALL scf_env_density_mixing(scf_env%p_mix_new,scf_env%mixing_store,& rho_ao_kp,para_env,scf_env%iter_delta,& scf_env%iter_count,diis=diis_step,& - invert=.TRUE.,error=error) + invert=.TRUE.) DO ic=1,nc DO ispin=1,dft_control%nspins CALL cp_dbcsr_copy(rho_ao_kp(ispin,ic)%matrix,scf_env%p_mix_new(ispin,ic)%matrix,& - name=TRIM(cp_dbcsr_name(rho_ao_kp(ispin,ic)%matrix)),error=error) + name=TRIM(cp_dbcsr_name(rho_ao_kp(ispin,ic)%matrix))) END DO END DO CASE(gspace_mixing_nr,pulay_mixing_nr,broyden_mixing_nr,& @@ -597,7 +578,7 @@ SUBROUTINE qs_scf_undo_mixing(scf_env,rho,dft_control,para_env,diis_step,error) DO ic=1,nc DO ispin=1,dft_control%nspins CALL cp_dbcsr_copy(rho_ao_kp(ispin,ic)%matrix,scf_env%p_mix_new(ispin,ic)%matrix,& - name=TRIM(cp_dbcsr_name(rho_ao_kp(ispin,ic)%matrix)),error=error) + name=TRIM(cp_dbcsr_name(rho_ao_kp(ispin,ic)%matrix))) END DO END DO END SELECT @@ -612,15 +593,13 @@ END SUBROUTINE qs_scf_undo_mixing !> \param scf_env ... !> \param ks_env ... !> \param mix_rho ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_rho_update(rho,qs_env,scf_env,ks_env,mix_rho,error) + SUBROUTINE qs_scf_rho_update(rho,qs_env,scf_env,ks_env,mix_rho) TYPE(qs_rho_type), POINTER :: rho TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_ks_env_type), POINTER :: ks_env LOGICAL, INTENT(IN) :: mix_rho - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_rho_update', & routineP = moduleN//':'//routineN @@ -628,16 +607,16 @@ SUBROUTINE qs_scf_rho_update(rho,qs_env,scf_env,ks_env,mix_rho,error) TYPE(cp_para_env_type), POINTER :: para_env NULLIFY(para_env) - CALL get_qs_env(qs_env, para_env=para_env, error=error) + CALL get_qs_env(qs_env, para_env=para_env) ! ** update qs_env%rho - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) ! ** Density mixing through density matrix or on the reciprocal space grid (exclusive) IF(mix_rho) THEN CALL gspace_mixing(qs_env, scf_env%mixing_method, scf_env%mixing_store, rho, & - para_env, scf_env%iter_count, error=error) + para_env, scf_env%iter_count) END IF - CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.,error=error) + CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.) END SUBROUTINE qs_scf_rho_update @@ -648,14 +627,12 @@ END SUBROUTINE qs_scf_rho_update !> \param qs_env ... !> \param diis_step ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_inner_finalize(scf_env,qs_env,diis_step,output_unit,error) + SUBROUTINE qs_scf_inner_finalize(scf_env,qs_env,diis_step,output_unit) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_environment_type), POINTER :: qs_env LOGICAL :: diis_step INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_inner_finalize', & routineP = moduleN//':'//routineN @@ -672,20 +649,20 @@ SUBROUTINE qs_scf_inner_finalize(scf_env,qs_env,diis_step,output_unit,error) CALL get_qs_env(qs_env=qs_env, energy=energy,ks_env=ks_env,& rho=rho, dft_control=dft_control,para_env=para_env,& - do_kpoints=do_kpoints, error=error) + do_kpoints=do_kpoints) - CALL cleanup_scf_loop(scf_env,error) + CALL cleanup_scf_loop(scf_env) ! now, print out energies and charges corresponding to the obtained wfn ! (this actually is not 100% consistent at this point)! - CALL qs_scf_print_summary(output_unit,qs_env,error) + CALL qs_scf_print_summary(output_unit,qs_env) - CALL qs_scf_undo_mixing (scf_env,rho,dft_control,para_env,diis_step,error) + CALL qs_scf_undo_mixing (scf_env,rho,dft_control,para_env,diis_step) ! *** update rspace rho since the mo changed ! *** this might not always be needed (i.e. no post calculation / no forces ) ! *** but guarantees that rho and wfn are consistent at this point - CALL qs_scf_rho_update(rho,qs_env,scf_env,ks_env,mix_rho=.FALSE.,error=error) + CALL qs_scf_rho_update(rho,qs_env,scf_env,ks_env,mix_rho=.FALSE.) END SUBROUTINE qs_scf_inner_finalize @@ -693,13 +670,11 @@ END SUBROUTINE qs_scf_inner_finalize ! ***************************************************************************** !> \brief perform cleanup operations at the end of an scf loop !> \param scf_env ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE cleanup_scf_loop(scf_env,error) + SUBROUTINE cleanup_scf_loop(scf_env) TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cleanup_scf_loop', & routineP = moduleN//':'//routineN @@ -711,16 +686,16 @@ SUBROUTINE cleanup_scf_loop(scf_env,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) ! *** method dependent cleanup SELECT CASE(scf_env%method) CASE(ot_method_nr) DO ispin=1,SIZE(scf_env%qs_ot_env) - CALL ot_scf_destroy(scf_env%qs_ot_env(ispin),error=error) + CALL ot_scf_destroy(scf_env%qs_ot_env(ispin)) ENDDO DEALLOCATE(scf_env%qs_ot_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CASE(ot_diag_method_nr) ! CASE(general_diag_method_nr) @@ -734,7 +709,7 @@ SUBROUTINE cleanup_scf_loop(scf_env,error) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown scf method method:"//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) END SELECT diff --git a/src/qs_scf_methods.F b/src/qs_scf_methods.F index c7d19edb20..857e6abef1 100644 --- a/src/qs_scf_methods.F +++ b/src/qs_scf_methods.F @@ -84,15 +84,13 @@ MODULE qs_scf_methods !> \param iter_count ... !> \param diis ... !> \param invert Invert mixing -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> 08.2014 adapted for kpoints [JGH] !> \author fawzi ! ***************************************************************************** SUBROUTINE scf_env_density_mixing(p_mix_new,mixing_store,rho_ao,para_env,& - iter_delta,iter_count,diis,invert,error) + iter_delta,iter_count,diis,invert) TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & POINTER :: p_mix_new TYPE(mixing_storage_type), POINTER :: mixing_store @@ -102,7 +100,6 @@ SUBROUTINE scf_env_density_mixing(p_mix_new,mixing_store,rho_ao,para_env,& REAL(KIND=dp), INTENT(INOUT) :: iter_delta INTEGER, INTENT(IN) :: iter_count LOGICAL, INTENT(in), OPTIONAL :: diis, invert - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_env_density_mixing', & routineP = moduleN//':'//routineN @@ -124,25 +121,23 @@ SUBROUTINE scf_env_density_mixing(p_mix_new,mixing_store,rho_ao,para_env,& END IF iter_delta = 0.0_dp - CPPrecondition(ASSOCIATED(p_mix_new),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(p_mix_new),cp_failure_level,routineP,failure) DO ic=1,SIZE(p_mix_new,2) DO ispin=1,SIZE(p_mix_new,1) IF (my_invert) THEN - CPPrecondition(my_p_mix/=0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(my_p_mix/=0.0_dp,cp_failure_level,routineP,failure) IF (my_p_mix/=1.0_dp) THEN CALL cp_dbcsr_add(matrix_a=p_mix_new(ispin,ic)%matrix,& alpha_scalar=1.0_dp/my_p_mix,& matrix_b=rho_ao(ispin,ic)%matrix,& - beta_scalar=(my_p_mix-1.0_dp)/my_p_mix,& - error=error) + beta_scalar=(my_p_mix-1.0_dp)/my_p_mix) END IF ELSE CALL cp_sm_mix(m1=p_mix_new(ispin,ic)%matrix,& m2=rho_ao(ispin,ic)%matrix,& p_mix=my_p_mix,& delta=tmp,& - para_env=para_env,& - error=error) + para_env=para_env) iter_delta=MAX(iter_delta,tmp) END IF END DO @@ -161,20 +156,17 @@ END SUBROUTINE scf_env_density_mixing !> \param work ... !> \param cholesky_method ... !> \param use_jacobi ... -!> \param error ... !> \date 01.05.2001 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** SUBROUTINE eigensolver(matrix_ks_fm,mo_set,ortho,work,& - cholesky_method,use_jacobi,& - error) + cholesky_method,use_jacobi) TYPE(cp_fm_type), POINTER :: matrix_ks_fm TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_fm_type), POINTER :: ortho, work INTEGER, INTENT(INout) :: cholesky_method LOGICAL, INTENT(IN) :: use_jacobi - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eigensolver', & routineP = moduleN//':'//routineN @@ -200,33 +192,33 @@ SUBROUTINE eigensolver(matrix_ks_fm,mo_set,ortho,work,& SELECT CASE(cholesky_method) CASE(cholesky_reduce) - CALL cp_fm_cholesky_reduce(matrix_ks_fm,ortho,error=error) - CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues,error=error) - CALL cp_fm_cholesky_restore(work,nmo,ortho,mo_coeff,"SOLVE",error=error) + CALL cp_fm_cholesky_reduce(matrix_ks_fm,ortho) + CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues) + CALL cp_fm_cholesky_restore(work,nmo,ortho,mo_coeff,"SOLVE") CASE(cholesky_restore) - CALL cp_fm_upper_to_full(matrix_ks_fm,work,error=error) + CALL cp_fm_upper_to_full(matrix_ks_fm,work) CALL cp_fm_cholesky_restore(matrix_ks_fm,nao,ortho,work,& - "SOLVE",pos="RIGHT",error=error) + "SOLVE",pos="RIGHT") CALL cp_fm_cholesky_restore(work,nao,ortho,matrix_ks_fm,& - "SOLVE",pos="LEFT",transa="T",error=error) - CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues,error=error) - CALL cp_fm_cholesky_restore(work,nmo,ortho,mo_coeff,"SOLVE",error=error) + "SOLVE",pos="LEFT",transa="T") + CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues) + CALL cp_fm_cholesky_restore(work,nmo,ortho,mo_coeff,"SOLVE") CASE(cholesky_inverse) - CALL cp_fm_upper_to_full(matrix_ks_fm,work,error=error) + CALL cp_fm_upper_to_full(matrix_ks_fm,work) CALL cp_fm_triangular_multiply(ortho,matrix_ks_fm ,side="R",transpose_tr=.FALSE.,& - invert_tr=.FALSE., uplo_tr="U",n_rows=nao,n_cols=nao,alpha=1.0_dp,error=error) + invert_tr=.FALSE., uplo_tr="U",n_rows=nao,n_cols=nao,alpha=1.0_dp) CALL cp_fm_triangular_multiply(ortho, matrix_ks_fm,side="L",transpose_tr=.TRUE.,& - invert_tr=.FALSE., uplo_tr="U",n_rows=nao,n_cols=nao,alpha=1.0_dp,error=error) - CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues,error=error) + invert_tr=.FALSE., uplo_tr="U",n_rows=nao,n_cols=nao,alpha=1.0_dp) + CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues) CALL cp_fm_triangular_multiply(ortho,work,side="L",transpose_tr=.FALSE.,& - invert_tr=.FALSE., uplo_tr="U",n_rows=nao,n_cols=nmo,alpha=1.0_dp,error=error) + invert_tr=.FALSE., uplo_tr="U",n_rows=nao,n_cols=nmo,alpha=1.0_dp) CALL cp_fm_to_fm(work,mo_coeff,nmo,1,1) END SELECT IF (use_jacobi) THEN - CALL cp_fm_to_fm(mo_coeff,ortho,error=error) + CALL cp_fm_to_fm(mo_coeff,ortho) cholesky_method = cholesky_off END IF @@ -243,16 +235,13 @@ END SUBROUTINE eigensolver !> \param ksbuf1 ... !> \param ksbuf2 ... !> \param work ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE eigensolver_dbcsr(matrix_ks,matrix_ks_fm,mo_set,ortho_dbcsr,ksbuf1,ksbuf2,work,& - error) + SUBROUTINE eigensolver_dbcsr(matrix_ks,matrix_ks_fm,mo_set,ortho_dbcsr,ksbuf1,ksbuf2,work) TYPE(cp_dbcsr_type), POINTER :: matrix_ks TYPE(cp_fm_type), POINTER :: matrix_ks_fm TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_dbcsr_type), POINTER :: ortho_dbcsr, ksbuf1, ksbuf2 TYPE(cp_fm_type), POINTER :: work - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eigensolver_dbcsr', & routineP = moduleN//':'//routineN @@ -273,16 +262,16 @@ SUBROUTINE eigensolver_dbcsr(matrix_ks,matrix_ks_fm,mo_set,ortho_dbcsr,ksbuf1,ks mo_coeff=mo_coeff) ! Reduce KS matrix - CALL cp_dbcsr_desymmetrize(matrix_ks,ksbuf2,error=error) - CALL cp_dbcsr_multiply('N','N',1.0_dp,ksbuf2,ortho_dbcsr,0.0_dp,ksbuf1,error=error) - CALL cp_dbcsr_multiply('T','N',1.0_dp,ortho_dbcsr,ksbuf1,0.0_dp,ksbuf2,error=error) + CALL cp_dbcsr_desymmetrize(matrix_ks,ksbuf2) + CALL cp_dbcsr_multiply('N','N',1.0_dp,ksbuf2,ortho_dbcsr,0.0_dp,ksbuf1) + CALL cp_dbcsr_multiply('T','N',1.0_dp,ortho_dbcsr,ksbuf1,0.0_dp,ksbuf2) ! Solve the eigenvalue problem - CALL copy_dbcsr_to_fm(ksbuf2, matrix_ks_fm, error=error) - CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues,error=error) + CALL copy_dbcsr_to_fm(ksbuf2, matrix_ks_fm) + CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues) ! Restore the eigenvector of the general eig. problem - CALL cp_dbcsr_sm_fm_multiply(ortho_dbcsr,work,mo_coeff,nmo, error=error) + CALL cp_dbcsr_sm_fm_multiply(ortho_dbcsr,work,mo_coeff,nmo) @@ -301,11 +290,10 @@ END SUBROUTINE eigensolver_dbcsr !> \param level_shift ... !> \param use_jacobi ... !> \param jacobi_threshold ... -!> \param error ... ! ***************************************************************************** SUBROUTINE eigensolver_symm(matrix_ks_fm,mo_set,ortho,work,do_level_shift,& level_shift,use_jacobi,& - jacobi_threshold,error) + jacobi_threshold) TYPE(cp_fm_type), POINTER :: matrix_ks_fm TYPE(mo_set_type), POINTER :: mo_set TYPE(cp_fm_type), POINTER :: ortho, work @@ -313,7 +301,6 @@ SUBROUTINE eigensolver_symm(matrix_ks_fm,mo_set,ortho,work,do_level_shift,& REAL(KIND=dp), INTENT(IN) :: level_shift LOGICAL, INTENT(IN) :: use_jacobi REAL(KIND=dp), INTENT(IN) :: jacobi_threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eigensolver_symm', & routineP = moduleN//':'//routineN @@ -342,9 +329,9 @@ SUBROUTINE eigensolver_symm(matrix_ks_fm,mo_set,ortho,work,do_level_shift,& IF (use_jacobi) THEN - CALL cp_fm_symm("L","U",nao,homo,1.0_dp,matrix_ks_fm,mo_coeff,0.0_dp,work,error=error) + CALL cp_fm_symm("L","U",nao,homo,1.0_dp,matrix_ks_fm,mo_coeff,0.0_dp,work) CALL cp_gemm("T","N",homo,nao-homo,nao,1.0_dp,work,mo_coeff,& - 0.0_dp,matrix_ks_fm,b_first_col=homo+1,c_first_col=homo+1,error=error) + 0.0_dp,matrix_ks_fm,b_first_col=homo+1,c_first_col=homo+1) ! Block Jacobi (pseudo-diagonalization, only one sweep) CALL cp_fm_block_jacobi(matrix_ks_fm,mo_coeff,mo_eigenvalues,& @@ -352,22 +339,22 @@ SUBROUTINE eigensolver_symm(matrix_ks_fm,mo_set,ortho,work,do_level_shift,& ELSE ! full S^(-1/2) has been computed - CALL cp_fm_symm("L","U",nao,nao,1.0_dp,matrix_ks_fm,ortho,0.0_dp,work,error=error) - CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,ortho,work,0.0_dp,matrix_ks_fm,error=error) + CALL cp_fm_symm("L","U",nao,nao,1.0_dp,matrix_ks_fm,ortho,0.0_dp,work) + CALL cp_gemm("T","N",nao,nao,nao,1.0_dp,ortho,work,0.0_dp,matrix_ks_fm) IF (do_level_shift) THEN DO imo=homo+1,nmo ! now unnecessary broadcast of element CALL cp_fm_get_element(matrix_ks_fm,imo,imo,alpha) alpha=alpha+level_shift - CALL cp_fm_set_element(matrix_ks_fm,imo,imo,alpha,error=error) + CALL cp_fm_set_element(matrix_ks_fm,imo,imo,alpha) END DO END IF - CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues,error=error) + CALL choose_eigv_solver(matrix_ks_fm,work,mo_eigenvalues) CALL cp_gemm("N","N",nao,nmo,nao,1.0_dp,ortho,work,0.0_dp,& - mo_coeff,error=error) + mo_coeff) IF (do_level_shift) THEN CALL correct_mo_eigenvalues(mo_set,level_shift) @@ -393,10 +380,9 @@ END SUBROUTINE eigensolver_symm !> \param level_shift ... !> \param use_jacobi ... !> \param jacobi_threshold ... -!> \param error ... ! ***************************************************************************** SUBROUTINE eigensolver_simple(matrix_ks,mo_set,work,do_level_shift,& - level_shift,use_jacobi,jacobi_threshold,error) + level_shift,use_jacobi,jacobi_threshold) TYPE(cp_fm_type), POINTER :: matrix_ks TYPE(mo_set_type), POINTER :: mo_set @@ -405,7 +391,6 @@ SUBROUTINE eigensolver_simple(matrix_ks,mo_set,work,do_level_shift,& REAL(KIND=dp), INTENT(IN) :: level_shift LOGICAL, INTENT(IN) :: use_jacobi REAL(KIND=dp), INTENT(IN) :: jacobi_threshold - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eigensolver_simple', & routineP = moduleN//':'//routineN @@ -435,19 +420,19 @@ SUBROUTINE eigensolver_simple(matrix_ks,mo_set,work,do_level_shift,& ! now unnecessary broadcast of element CALL cp_fm_get_element(matrix_ks,imo,imo,alpha) alpha=alpha+level_shift - CALL cp_fm_set_element(matrix_ks,imo,imo,alpha,error=error) + CALL cp_fm_set_element(matrix_ks,imo,imo,alpha) END DO END IF IF ( use_jacobi ) THEN - CALL cp_fm_symm("L","U",nao,homo,1.0_dp,matrix_ks,mo_coeff,0.0_dp,work,error=error) + CALL cp_fm_symm("L","U",nao,homo,1.0_dp,matrix_ks,mo_coeff,0.0_dp,work) CALL cp_gemm("T","N",homo,nao-homo,nao,1.0_dp,work,mo_coeff,& - 0.0_dp,matrix_ks,b_first_col=homo+1,c_first_col=homo+1,error=error) + 0.0_dp,matrix_ks,b_first_col=homo+1,c_first_col=homo+1) ! Block Jacobi (pseudo-diagonalization, only one sweep) CALL cp_fm_block_jacobi(matrix_ks,mo_coeff,mo_eigenvalues,jacobi_threshold,homo+1) ELSE - CALL choose_eigv_solver(matrix_ks,work,mo_eigenvalues,error=error) + CALL choose_eigv_solver(matrix_ks,work,mo_eigenvalues) CALL cp_fm_to_fm(work,mo_coeff,nmo,1,1) @@ -470,8 +455,6 @@ END SUBROUTINE eigensolver_simple !> \param delta maximum norm of m1-m2 !> \param para_env ... !> \param m3 ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 rewamped [fawzi] !> \author fawzi @@ -480,14 +463,13 @@ END SUBROUTINE eigensolver_simple !> (1-pmix) as pmix !> para_env should be removed (embedded in matrix) ! ***************************************************************************** - SUBROUTINE cp_sm_mix(m1,m2,p_mix,delta,para_env,m3,error) + SUBROUTINE cp_sm_mix(m1,m2,p_mix,delta,para_env,m3) TYPE(cp_dbcsr_type), POINTER :: m1, m2 REAL(KIND=dp), INTENT(IN) :: p_mix REAL(KIND=dp), INTENT(OUT) :: delta TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_dbcsr_type), OPTIONAL, POINTER :: m3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sm_mix', & routineP = moduleN//':'//routineN @@ -508,11 +490,11 @@ SUBROUTINE cp_sm_mix(m1,m2,p_mix,delta,para_env,m3,error) CALL cp_dbcsr_iterator_next_block(iter, iblock_row, iblock_col, p_new_block, blk) CALL cp_dbcsr_get_block_p(matrix=m2,row=iblock_row,col=iblock_col,& BLOCK=p_old_block,found=found) - CPPostcondition(ASSOCIATED(p_old_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_old_block),cp_failure_level,routineP,failure) IF(PRESENT(m3)) THEN CALL cp_dbcsr_get_block_p(matrix=m3,row=iblock_row,col=iblock_col,& BLOCK=p_delta_block,found=found) - CPPostcondition(ASSOCIATED(p_delta_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_delta_block),cp_failure_level,routineP,failure) DO j=1,SIZE(p_new_block,2) DO i=1,SIZE(p_new_block,1) @@ -545,9 +527,8 @@ END SUBROUTINE cp_sm_mix !> \param occa ... !> \param occb ... !> \param roks_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE combine_ks_matrices_1(ksa,ksb,occa,occb,roks_parameter,error) + SUBROUTINE combine_ks_matrices_1(ksa,ksb,occa,occb,roks_parameter) ! Combine the alpha and beta Kohn-Sham matrices during a restricted open ! Kohn-Sham (ROKS) calculation @@ -562,7 +543,6 @@ SUBROUTINE combine_ks_matrices_1(ksa,ksb,occa,occb,roks_parameter,error) REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: occa, occb REAL(KIND=dp), & DIMENSION(0:2, 0:2, 1:2), INTENT(IN) :: roks_parameter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'combine_ks_matrices_1', & routineP = moduleN//':'//routineN @@ -582,8 +562,8 @@ SUBROUTINE combine_ks_matrices_1(ksa,ksb,occa,occb,roks_parameter,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(ksa),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ksb),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ksa),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ksb),cp_failure_level,routineP,failure) CALL cp_fm_get_info(matrix=ksa,& matrix_struct=ksa_struct,& @@ -591,16 +571,14 @@ SUBROUTINE combine_ks_matrices_1(ksa,ksb,occa,occb,roks_parameter,error) ncol_local=ncol_local,& row_indices=row_indices,& col_indices=col_indices,& - local_data=fa,& - error=error) + local_data=fa) CALL cp_fm_get_info(matrix=ksb,& matrix_struct=ksb_struct,& - local_data=fb,& - error=error) + local_data=fb) - compatible_matrices = cp_fm_struct_equivalent(ksa_struct,ksb_struct,error=error) - CPPrecondition(compatible_matrices,cp_failure_level,routineP,error,failure) + compatible_matrices = cp_fm_struct_equivalent(ksa_struct,ksb_struct) + CPPrecondition(compatible_matrices,cp_failure_level,routineP,failure) IF (SUM(occb) == 0.0_dp) fb = 0.0_dp @@ -629,9 +607,8 @@ END SUBROUTINE combine_ks_matrices_1 !> \param f ... !> \param nalpha ... !> \param nbeta ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE combine_ks_matrices_2(ksa,ksb,occa,occb,f,nalpha,nbeta,error) + SUBROUTINE combine_ks_matrices_2(ksa,ksb,occa,occb,f,nalpha,nbeta) ! Combine the alpha and beta Kohn-Sham matrices during a restricted open ! Kohn-Sham (ROKS) calculation @@ -646,7 +623,6 @@ SUBROUTINE combine_ks_matrices_2(ksa,ksb,occa,occb,f,nalpha,nbeta,error) REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: occa, occb REAL(KIND=dp), INTENT(IN) :: f INTEGER, INTENT(IN) :: nalpha, nbeta - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'combine_ks_matrices_2', & routineP = moduleN//':'//routineN @@ -667,8 +643,8 @@ SUBROUTINE combine_ks_matrices_2(ksa,ksb,occa,occb,f,nalpha,nbeta,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(ksa),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ksb),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ksa),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ksb),cp_failure_level,routineP,failure) CALL cp_fm_get_info(matrix=ksa,& matrix_struct=ksa_struct,& @@ -676,16 +652,14 @@ SUBROUTINE combine_ks_matrices_2(ksa,ksb,occa,occb,f,nalpha,nbeta,error) ncol_local=ncol_local,& row_indices=row_indices,& col_indices=col_indices,& - local_data=fa,& - error=error) + local_data=fa) CALL cp_fm_get_info(matrix=ksb,& matrix_struct=ksb_struct,& - local_data=fb,& - error=error) + local_data=fb) - compatible_matrices = cp_fm_struct_equivalent(ksa_struct,ksb_struct,error=error) - CPPrecondition(compatible_matrices,cp_failure_level,routineP,error,failure) + compatible_matrices = cp_fm_struct_equivalent(ksa_struct,ksb_struct) + CPPrecondition(compatible_matrices,cp_failure_level,routineP,failure) beta = 1.0_dp/(1.0_dp - f) diff --git a/src/qs_scf_output.F b/src/qs_scf_output.F index 8bda5e778f..7b62ca81fb 100644 --- a/src/qs_scf_output.F +++ b/src/qs_scf_output.F @@ -62,12 +62,10 @@ MODULE qs_scf_output !> \brief writes a summary of information after scf !> \param output_unit ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_print_summary(output_unit,qs_env,error) + SUBROUTINE qs_scf_print_summary(output_unit,qs_env) INTEGER, INTENT(IN) :: output_unit TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_print_summary', & routineP = moduleN//':'//routineN @@ -82,7 +80,7 @@ SUBROUTINE qs_scf_print_summary(output_unit,qs_env,error) NULLIFY(rho,energy,dft_control,scf_env,qs_charges) CALL get_qs_env(qs_env=qs_env,rho=rho,energy=energy,dft_control=dft_control,& - scf_env=scf_env,qs_charges=qs_charges,error=error) + scf_env=scf_env,qs_charges=qs_charges) gapw = dft_control%qs_control%gapw gapw_xc = dft_control%qs_control%gapw_xc @@ -90,7 +88,7 @@ SUBROUTINE qs_scf_print_summary(output_unit,qs_env,error) nelectron_total=scf_env%nelectron CALL qs_scf_print_scf_summary(output_unit,rho,qs_charges,energy,nelectron_total,& - dft_control,qmmm,qs_env,gapw,gapw_xc,error) + dft_control,qmmm,qs_env,gapw,gapw_xc) END SUBROUTINE qs_scf_print_summary @@ -142,9 +140,8 @@ END SUBROUTINE qs_scf_initial_info !> \param qs_kind_set ... !> \param particle_set ... !> \param dft_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_scf_write_mos(mos,atomic_kind_set,qs_kind_set,particle_set,dft_section,error) + SUBROUTINE qs_scf_write_mos(mos,atomic_kind_set,qs_kind_set,particle_set,dft_section) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos TYPE(atomic_kind_type), DIMENSION(:), & @@ -154,19 +151,18 @@ SUBROUTINE qs_scf_write_mos(mos,atomic_kind_set,qs_kind_set,particle_set,dft_sec TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_write_mos', & routineP = moduleN//':'//routineN IF (SIZE(mos) > 1) THEN CALL write_mo_set(mos(1)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,spin="ALPHA",last=.FALSE.,error=error) + dft_section,spin="ALPHA",last=.FALSE.) CALL write_mo_set(mos(2)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,spin="BETA",last=.FALSE.,error=error) + dft_section,spin="BETA",last=.FALSE.) ELSE CALL write_mo_set(mos(1)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,last=.FALSE.,error=error) + dft_section,last=.FALSE.) END IF END SUBROUTINE qs_scf_write_mos @@ -275,12 +271,11 @@ END SUBROUTINE qs_scf_loop_info !> \param qs_env ... !> \param gapw ... !> \param gapw_xc ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE qs_scf_print_scf_summary(output_unit,rho,qs_charges,energy,nelectron_total,& - dft_control,qmmm,qs_env,gapw,gapw_xc,error) + dft_control,qmmm,qs_env,gapw,gapw_xc) INTEGER, INTENT(IN) :: output_unit TYPE(qs_rho_type), POINTER :: rho TYPE(qs_charges_type), POINTER :: qs_charges @@ -290,7 +285,6 @@ SUBROUTINE qs_scf_print_scf_summary(output_unit,rho,qs_charges,energy,nelectron_ LOGICAL, INTENT(IN) :: qmmm TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: gapw, gapw_xc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_print_scf_summary', & routineP = moduleN//':'//routineN @@ -303,7 +297,7 @@ SUBROUTINE qs_scf_print_scf_summary(output_unit,rho,qs_charges,energy,nelectron_ CALL timeset(routineN,handle) IF (output_unit>0) THEN - CALL qs_rho_get(rho, tot_rho_r=tot_rho_r, error=error) + CALL qs_rho_get(rho, tot_rho_r=tot_rho_r) IF(.NOT.(dft_control%qs_control%semi_empirical .OR. dft_control%qs_control%dftb .OR.& dft_control%qs_control%scptb)) THEN WRITE (UNIT=output_unit,FMT="(/,(T3,A,T41,2F20.10))")& @@ -418,7 +412,7 @@ SUBROUTINE qs_scf_print_scf_summary(output_unit,rho,qs_charges,energy,nelectron_ WRITE (UNIT=output_unit,FMT="(T3,A,T56,F25.14,/,T3,A,T61,F20.3)")& "SCCS| Polarisation energy [Hartree]",energy%sccs_pol,& "SCCS| [kcal/mol]",& - cp_unit_from_cp2k(energy%sccs_pol,"kcalmol",error=error) + cp_unit_from_cp2k(energy%sccs_pol,"kcalmol") END IF IF (qmmm) THEN WRITE (UNIT=output_unit,FMT="(T3,A,T56,F25.14)")& @@ -445,7 +439,7 @@ SUBROUTINE qs_scf_print_scf_summary(output_unit,rho,qs_charges,energy,nelectron_ END IF IF (qmmm) THEN IF(qs_env%qmmm_env_qm%image_charge) THEN - CALL print_image_coefficients(qs_env%image_coeff,qs_env,error) + CALL print_image_coefficients(qs_env%image_coeff,qs_env) ENDIF ENDIF CALL m_flush(output_unit) @@ -460,15 +454,13 @@ END SUBROUTINE qs_scf_print_scf_summary !> \param qs_env ... !> \param scf_env ... !> \param para_env ... -!> \param error ... !> \par History !> 03.2006 created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE qs_scf_loop_print(qs_env,scf_env,para_env,error) + SUBROUTINE qs_scf_loop_print(qs_env,scf_env,para_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_loop_print', & routineP = moduleN//':'//routineN @@ -487,109 +479,108 @@ SUBROUTINE qs_scf_loop_print(qs_env,scf_env,para_env,error) TYPE(section_vals_type), POINTER :: dft_section, input, & scf_section - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) CALL get_qs_env(qs_env=qs_env,input=input,dft_control=dft_control, & - do_kpoints=do_kpoints,error=error) + do_kpoints=do_kpoints) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) - scf_section => section_vals_get_subs_vals(dft_section,"SCF",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") + scf_section => section_vals_get_subs_vals(dft_section,"SCF") DO ispin=1,dft_control%nspins IF (BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,"PRINT%AO_MATRICES/DENSITY",error=error),cp_p_file)) THEN - CALL get_qs_env(qs_env, rho=rho, error=error) - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + dft_section,"PRINT%AO_MATRICES/DENSITY"),cp_p_file)) THEN + CALL get_qs_env(qs_env, rho=rho) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%AO_MATRICES/DENSITY",& - extension=".Log",error=error) - CALL section_vals_val_get(dft_section,"PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(dft_section,"PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) DO ic=1,SIZE(matrix_p,2) CALL cp_dbcsr_write_sparse_matrix(matrix_p(ispin,ic)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END DO CALL cp_print_key_finished_output(iw,logger,dft_section,& - "PRINT%AO_MATRICES/DENSITY", error=error) + "PRINT%AO_MATRICES/DENSITY") END IF IF (BTEST(cp_print_key_should_output(logger%iter_info,& - dft_section,"PRINT%AO_MATRICES/KOHN_SHAM_MATRIX",error=error),cp_p_file)) THEN + dft_section,"PRINT%AO_MATRICES/KOHN_SHAM_MATRIX"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%AO_MATRICES/KOHN_SHAM_MATRIX",& - extension=".Log",error=error) - CALL section_vals_val_get(dft_section,"PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(dft_section,"PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL get_qs_env(qs_env=qs_env,matrix_ks_kp=matrix_ks,error=error) + CALL get_qs_env(qs_env=qs_env,matrix_ks_kp=matrix_ks) DO ic=1,SIZE(matrix_ks,2) IF (dft_control%qs_control%semi_empirical) THEN CALL cp_dbcsr_write_sparse_matrix(matrix_ks(ispin,ic)%matrix,4,after,qs_env,para_env,& - scale=evolt,output_unit=iw,error=error) + scale=evolt,output_unit=iw) ELSE CALL cp_dbcsr_write_sparse_matrix(matrix_ks(ispin,ic)%matrix,4,after,qs_env,para_env,& - output_unit=iw,error=error) + output_unit=iw) END IF END DO CALL cp_print_key_finished_output(iw,logger,dft_section,& - "PRINT%AO_MATRICES/KOHN_SHAM_MATRIX", error=error) + "PRINT%AO_MATRICES/KOHN_SHAM_MATRIX") END IF ENDDO IF (BTEST(cp_print_key_should_output(logger%iter_info,& - scf_section,"PRINT%MO_ORTHONORMALITY",error=error),cp_p_file)) THEN + scf_section,"PRINT%MO_ORTHONORMALITY"),cp_p_file)) THEN IF(do_kpoints) THEN iw=cp_print_key_unit_nr(logger,scf_section,"PRINT%MO_ORTHONORMALITY",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE(iw,'(T8,A)') & " K-points: Maximum deviation from MO S-orthonormality not determined" ENDIF CALL cp_print_key_finished_output(iw,logger,scf_section,& - "PRINT%MO_ORTHONORMALITY", error=error) + "PRINT%MO_ORTHONORMALITY") ELSE - CALL get_qs_env(qs_env, mos=mos, error=error) + CALL get_qs_env(qs_env, mos=mos) IF(scf_env%method==special_diag_method_nr) THEN - CALL calculate_orthonormality(orthonormality,mos,error=error) + CALL calculate_orthonormality(orthonormality,mos) ELSE - CALL get_qs_env(qs_env=qs_env,matrix_s_kp=matrix_s,error=error) - CALL calculate_orthonormality(orthonormality,mos,matrix_s(1,1)%matrix,& - error=error) + CALL get_qs_env(qs_env=qs_env,matrix_s_kp=matrix_s) + CALL calculate_orthonormality(orthonormality,mos,matrix_s(1,1)%matrix) END IF iw=cp_print_key_unit_nr(logger,scf_section,"PRINT%MO_ORTHONORMALITY",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE(iw,'(T8,A,T61,E20.4)') & " Maximum deviation from MO S-orthonormality",orthonormality ENDIF CALL cp_print_key_finished_output(iw,logger,scf_section,& - "PRINT%MO_ORTHONORMALITY", error=error) + "PRINT%MO_ORTHONORMALITY") END IF ENDIF IF (BTEST(cp_print_key_should_output(logger%iter_info,& - scf_section,"PRINT%MO_MAGNITUDE",error=error),cp_p_file)) THEN + scf_section,"PRINT%MO_MAGNITUDE"),cp_p_file)) THEN IF(do_kpoints) THEN iw=cp_print_key_unit_nr(logger,scf_section,"PRINT%MO_MAGNITUDE",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE(iw,'(T8,A)') & " K-points: Minimum/Maximum MO magnitude not determined" ENDIF CALL cp_print_key_finished_output(iw,logger,scf_section,& - "PRINT%MO_MAGNITUDE", error=error) + "PRINT%MO_MAGNITUDE") ELSE - CALL get_qs_env(qs_env, mos=mos, error=error) - CALL calculate_magnitude(mos,mo_mag_min,mo_mag_max,error=error) + CALL get_qs_env(qs_env, mos=mos) + CALL calculate_magnitude(mos,mo_mag_min,mo_mag_max) iw=cp_print_key_unit_nr(logger,scf_section,"PRINT%MO_MAGNITUDE",& - extension=".scfLog",error=error) + extension=".scfLog") IF (iw>0) THEN WRITE(iw,'(T8,A,T41,2E20.4)') & " Minimum/Maximum MO magnitude ",mo_mag_min,mo_mag_max ENDIF CALL cp_print_key_finished_output(iw,logger,scf_section,& - "PRINT%MO_MAGNITUDE", error=error) + "PRINT%MO_MAGNITUDE") END IF ENDIF diff --git a/src/qs_scf_post_dftb.F b/src/qs_scf_post_dftb.F index 692ace123b..17b774e70e 100644 --- a/src/qs_scf_post_dftb.F +++ b/src/qs_scf_post_dftb.F @@ -77,18 +77,16 @@ MODULE qs_scf_post_dftb !> \param dft_section ... !> \param scf_env ... !> \param qs_env ... -!> \param error ... !> \par History !> 03.2013 copy of scf_post_gpw !> \author JHU !> \note ! ***************************************************************************** - SUBROUTINE scf_post_calculation_dftb(dft_section, scf_env, qs_env, error) + SUBROUTINE scf_post_calculation_dftb(dft_section, scf_env, qs_env) TYPE(section_vals_type), POINTER :: dft_section TYPE(qs_scf_env_type), OPTIONAL, POINTER :: scf_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_post_calculation_dftb', & routineP = moduleN//':'//routineN @@ -120,25 +118,25 @@ SUBROUTINE scf_post_calculation_dftb(dft_section, scf_env, qs_env, error) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) NULLIFY(dft_control,rho,para_env,matrix_s,matrix_p) CALL get_qs_env(qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& dft_control=dft_control,rho=rho,natom=natom,para_env=para_env,& - matrix_s_kp=matrix_s,error=error) + matrix_s_kp=matrix_s) nspins = dft_control%nspins - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) ! Mulliken charges ALLOCATE(charges(natom,nspins),mcharge(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! - CALL mulliken_charges(matrix_p,matrix_s,para_env,charges,error=error) + CALL mulliken_charges(matrix_p,matrix_s,para_env,charges) ! nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,zeff=zeff) DO iatom=1,nat iat = atomic_kind_set(ikind)%atom_list(iatom) @@ -146,13 +144,13 @@ SUBROUTINE scf_post_calculation_dftb(dft_section, scf_env, qs_env, error) END DO END DO - print_section => section_vals_get_subs_vals(dft_section,"PRINT",error=error) + print_section => section_vals_get_subs_vals(dft_section,"PRINT") ! Mulliken - print_key => section_vals_get_subs_vals(print_section,"MULLIKEN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"MULLIKEN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN unit_nr=cp_print_key_unit_nr(logger,print_section,"MULLIKEN",extension=".mulliken",& - middle_name="",log_filename=.FALSE.,error=error) + middle_name="",log_filename=.FALSE.) IF (unit_nr > 0) THEN WRITE (UNIT=unit_nr,FMT="(/,/,T2,A)") "MULLIKEN POPULATION ANALYSIS" IF (nspins == 1) THEN @@ -160,7 +158,7 @@ SUBROUTINE scf_post_calculation_dftb(dft_section, scf_env, qs_env, error) " # Atom Element Kind Atomic population"," Net charge" DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,name=aname) ana = ADJUSTR(TRIM(ADJUSTL(aname))) DO iatom=1,nat @@ -178,7 +176,7 @@ SUBROUTINE scf_post_calculation_dftb(dft_section, scf_env, qs_env, error) "# Atom Element Kind Atomic population (alpha,beta) Net charge Spin moment" DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),dftb_parameter=dftb_kind) CALL get_dftb_atom_param(dftb_kind,name=aname) ana = ADJUSTR(TRIM(ADJUSTL(aname))) DO iatom=1,nat @@ -194,161 +192,161 @@ SUBROUTINE scf_post_calculation_dftb(dft_section, scf_env, qs_env, error) END IF CALL m_flush(unit_nr) END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF ! Lowdin - print_key => section_vals_get_subs_vals(print_section,"LOWDIN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"LOWDIN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Lowdin population analysis not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Hirshfeld - print_key => section_vals_get_subs_vals(print_section,"HIRSHFELD", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"HIRSHFELD") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Hirshfeld charges not available for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Dipole Moments - print_key => section_vals_get_subs_vals(print_section,"MOMENTS", error=error) - IF(BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file))THEN + print_key => section_vals_get_subs_vals(print_section,"MOMENTS") + IF(BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file))THEN unit_nr=cp_print_key_unit_nr(logger,print_section,"MOMENTS",& - extension=".data",middle_name="dftb_dipole",log_filename=.FALSE.,error=error) - moments_section => section_vals_get_subs_vals(print_section,"MOMENTS",error=error) - CALL dftb_dipole(qs_env, moments_section, unit_nr, mcharge, error) - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + extension=".data",middle_name="dftb_dipole",log_filename=.FALSE.) + moments_section => section_vals_get_subs_vals(print_section,"MOMENTS") + CALL dftb_dipole(qs_env, moments_section, unit_nr, mcharge) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF DEALLOCATE(charges,mcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! EPR Hyperfine Coupling - print_key => section_vals_get_subs_vals(print_section,"HYPERFINE_COUPLING_TENSOR",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"HYPERFINE_COUPLING_TENSOR") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Hyperfine Coupling not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! EFIELD CUBE FILE - print_key => section_vals_get_subs_vals(print_section,"EFIELD_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"EFIELD_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Efield cube file not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! DENSITY CUBE FILE - print_key => section_vals_get_subs_vals(print_section,"E_DENSITY_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"E_DENSITY_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Electronic density cube file not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! TOTAL DENSITY CUBE FILE - print_key => section_vals_get_subs_vals(print_section,"TOT_DENSITY_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"TOT_DENSITY_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Total density cube file not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! V_Hartree CUBE FILE - print_key => section_vals_get_subs_vals(print_section,"V_HARTREE_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"V_HARTREE_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Hartree potential cube file not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! V_XC CUBE FILE - print_key => section_vals_get_subs_vals(print_section,"V_XC_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"V_XC_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="XC potential cube file not available for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! ELF - print_key => section_vals_get_subs_vals(print_section,"ELF_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"ELF_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="ELF not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! KINETIC ENERGY - print_key => section_vals_get_subs_vals(print_section,"KINETIC_ENERGY",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"KINETIC_ENERGY") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Kinetic energy not available for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Xray diffraction spectrum - print_key => section_vals_get_subs_vals(print_section,"XRAY_DIFFRACTION_SPECTRUM",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"XRAY_DIFFRACTION_SPECTRUM") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Xray diffraction spectrum not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Electric field gradients - print_key => section_vals_get_subs_vals(print_section,"ELECTRIC_FIELD_GRADIENT",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"ELECTRIC_FIELD_GRADIENT") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Electric field gradient not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! STM - print_key => section_vals_get_subs_vals(print_section,"STM",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"STM") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="STM not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! MO - print_key => section_vals_get_subs_vals(print_section,"MO",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"MO") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of MO properties not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! MO CUBES - print_key => section_vals_get_subs_vals(print_section,"MO_CUBES",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"MO_CUBES") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of MO cube files not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Wavefunction mixing - wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX",error=error) - CALL section_vals_get(wfn_mix_section,explicit=explicit,error=error) - IF(explicit.AND..NOT.qs_env%run_rtp) CALL wfn_mix_dftb(qs_env,dft_section,scf_env,error) + wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX") + CALL section_vals_get(wfn_mix_section,explicit=explicit) + IF(explicit.AND..NOT.qs_env%run_rtp) CALL wfn_mix_dftb(qs_env,dft_section,scf_env) ! PLUS_U - print_key => section_vals_get_subs_vals(print_section,"PLUS_U",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"PLUS_U") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="DFT+U method not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! PDOS - print_key => section_vals_get_subs_vals(print_section,"PDOS",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"PDOS") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Projected DOS not implemented for DFTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF CALL timestop(handle) @@ -361,15 +359,13 @@ END SUBROUTINE scf_post_calculation_dftb !> \param input ... !> \param unit_nr ... !> \param charges ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dftb_dipole(qs_env, input, unit_nr, charges, error) + SUBROUTINE dftb_dipole(qs_env, input, unit_nr, charges) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: input INTEGER, INTENT(in) :: unit_nr REAL(KIND=dp), DIMENSION(:), INTENT(in) :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dftb_dipole', & routineP = moduleN//':'//routineN @@ -393,16 +389,16 @@ SUBROUTINE dftb_dipole(qs_env, input, unit_nr, charges, error) NULLIFY(atomic_kind_set,cell) CALL get_qs_env(qs_env,atomic_kind_set=atomic_kind_set,& - particle_set=particle_set,cell=cell,error=error) + particle_set=particle_set,cell=cell) ! Reference point - reference = section_get_ival(input,keyword_name="REFERENCE",error=error) + reference = section_get_ival(input,keyword_name="REFERENCE") NULLIFY(ref_point) description='[DIPOLE]' - CALL section_vals_val_get(input,"REF_POINT",r_vals=ref_point,error=error) - CALL section_vals_val_get(input,"PERIODIC",l_val=do_berry,error=error) + CALL section_vals_val_get(input,"REF_POINT",r_vals=ref_point) + CALL section_vals_val_get(input,"PERIODIC",l_val=do_berry) - CALL get_reference_point(rcc,drcc,qs_env=qs_env,reference=reference,ref_point=ref_point,error=error) + CALL get_reference_point(rcc,drcc,qs_env=qs_env,reference=reference,ref_point=ref_point) ! Dipole deriv will be the derivative of the Dipole(dM/dt=\sum e_j v_j) dipole_deriv = 0.0_dp @@ -472,17 +468,15 @@ END SUBROUTINE dftb_dipole !> \param qs_env ... !> \param dft_section ... !> \param scf_env ... -!> \param error ... !> \author Florian Schiffmann !> \note ! ***************************************************************************** - SUBROUTINE wfn_mix_dftb(qs_env,dft_section,scf_env,error) + SUBROUTINE wfn_mix_dftb(qs_env,dft_section,scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: dft_section TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfn_mix_dftb', & routineP = moduleN//':'//routineN @@ -507,55 +501,55 @@ SUBROUTINE wfn_mix_dftb(qs_env,dft_section,scf_env,error) POINTER :: qs_kind_set TYPE(section_vals_type), POINTER :: wfn_mix_section - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,matrix_s=matrix_s,matrix_ks=matrix_ks,& particle_set=particle_set,atomic_kind_set=atomic_kind_set,& - qs_kind_set=qs_kind_set, mos=mos,error=error) + qs_kind_set=qs_kind_set, mos=mos) - wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX",error=error) + wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX") CALL get_mo_set(mos(1)%mo_set,mo_coeff=mo_coeff,nao=nao) CALL cp_fm_struct_create(fmstruct=ao_ao_fmstruct, nrow_global=nao, ncol_global=nao,& - template_fmstruct=mo_coeff%matrix_struct, error=error) - CALL cp_fm_create(S_tmp,matrix_struct=ao_ao_fmstruct,error=error) - CALL cp_fm_create(KS_tmp,matrix_struct=ao_ao_fmstruct,error=error) - CALL cp_fm_create(MO_tmp,matrix_struct=ao_ao_fmstruct,error=error) - CALL cp_fm_create(work,matrix_struct=ao_ao_fmstruct,error=error) + template_fmstruct=mo_coeff%matrix_struct) + CALL cp_fm_create(S_tmp,matrix_struct=ao_ao_fmstruct) + CALL cp_fm_create(KS_tmp,matrix_struct=ao_ao_fmstruct) + CALL cp_fm_create(MO_tmp,matrix_struct=ao_ao_fmstruct) + CALL cp_fm_create(work,matrix_struct=ao_ao_fmstruct) ALLOCATE(lumos(SIZE(mos))) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,S_tmp,error=error) - CALL cp_fm_cholesky_decompose(S_tmp,error=error) + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,S_tmp) + CALL cp_fm_cholesky_decompose(S_tmp) DO ispin=1,SIZE(mos) CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff,eigenvalues=mo_eigenvalues,nmo=nmo) CALL cp_fm_struct_create(fmstruct=ao_lumo_struct, nrow_global=nao, ncol_global=nao-nmo,& - template_fmstruct=mo_coeff%matrix_struct, error=error) + template_fmstruct=mo_coeff%matrix_struct) - CALL cp_fm_create(lumos(ispin)%matrix,matrix_struct=ao_lumo_struct,error=error) - CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,KS_tmp,error=error) - CALL cp_fm_cholesky_reduce(KS_tmp,S_tmp,error=error) - CALL choose_eigv_solver(KS_tmp,work,mo_eigenvalues,error=error) - CALL cp_fm_cholesky_restore(work,nao,S_tmp,MO_tmp,"SOLVE",error=error) - CALL cp_fm_to_fm_submat(MO_tmp, mo_coeff, nao, nmo, 1, 1, 1, 1, error) - CALL cp_fm_to_fm_submat(MO_tmp, lumos(ispin)%matrix, nao, nao-nmo, 1, nmo+1, 1, 1, error) + CALL cp_fm_create(lumos(ispin)%matrix,matrix_struct=ao_lumo_struct) + CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix,KS_tmp) + CALL cp_fm_cholesky_reduce(KS_tmp,S_tmp) + CALL choose_eigv_solver(KS_tmp,work,mo_eigenvalues) + CALL cp_fm_cholesky_restore(work,nao,S_tmp,MO_tmp,"SOLVE") + CALL cp_fm_to_fm_submat(MO_tmp, mo_coeff, nao, nmo, 1, 1, 1, 1) + CALL cp_fm_to_fm_submat(MO_tmp, lumos(ispin)%matrix, nao, nao-nmo, 1, nmo+1, 1, 1) - CALL cp_fm_struct_release(ao_lumo_struct,error) + CALL cp_fm_struct_release(ao_lumo_struct) END DO output_unit= cp_logger_get_default_io_unit(logger) CALL wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, & - lumos, scf_env, matrix_s, output_unit, error=error) + lumos, scf_env, matrix_s, output_unit) DO ispin=1,SIZE(mos) - CALL cp_fm_release(lumos(ispin)%matrix,error) + CALL cp_fm_release(lumos(ispin)%matrix) END DO DEALLOCATE(lumos) - CALL cp_fm_release(S_tmp,error) - CALL cp_fm_release(MO_tmp,error) - CALL cp_fm_release(KS_tmp,error) - CALL cp_fm_release(work,error) - CALL cp_fm_struct_release(ao_ao_fmstruct,error) + CALL cp_fm_release(S_tmp) + CALL cp_fm_release(MO_tmp) + CALL cp_fm_release(KS_tmp) + CALL cp_fm_release(work) + CALL cp_fm_struct_release(ao_ao_fmstruct) END SUBROUTINE wfn_mix_dftb diff --git a/src/qs_scf_post_gpw.F b/src/qs_scf_post_gpw.F index 575576b87e..addc069b6b 100644 --- a/src/qs_scf_post_gpw.F +++ b/src/qs_scf_post_gpw.F @@ -197,8 +197,6 @@ MODULE qs_scf_post_gpw !> \param dft_section ... !> \param scf_env the scf_env whose info should be written out !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> 10.2004 moved here from qs_scf [Joost VandeVondele] @@ -211,12 +209,11 @@ MODULE qs_scf_post_gpw !> change afterwards slightly the forces (hence small numerical differences between MD !> with and without the debug print level). Ideally this should not happen... ! ***************************************************************************** - SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) + SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env) TYPE(section_vals_type), POINTER :: dft_section TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_post_calculation_gpw', & routineP = moduleN//':'//routineN @@ -272,7 +269,7 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) CALL timeset(routineN,handle) ! Writes the data that is already available in qs_env - CALL write_available_results(qs_env,scf_env,error) + CALL write_available_results(qs_env,scf_env) failure=.FALSE. my_localized_wfn = .FALSE. @@ -288,12 +285,12 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) p_loc_homo = .FALSE. p_loc_lumo= .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) ! Here we start with data that needs a postprocessing... CALL get_qs_env(qs_env,& dft_control=dft_control,& @@ -306,63 +303,62 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) pw_env=pw_env,& particle_set=particle_set, & atomic_kind_set=atomic_kind_set, & - qs_kind_set=qs_kind_set, & - error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + qs_kind_set=qs_kind_set) + CALL qs_subsys_get(subsys,particles=particles) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao) ! **** the kinetic energy IF (cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%KINETIC_ENERGY",error=error)/=0) THEN - CALL get_qs_env(qs_env,kinetic_kp=kinetic_m,error=error) - CPPrecondition(ASSOCIATED(kinetic_m),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(kinetic_m(1,1)%matrix),cp_failure_level,routineP,error,failure) - CALL calculate_ptrace(kinetic_m,rho_ao,e_kin,dft_control%nspins,error) + "DFT%PRINT%KINETIC_ENERGY")/=0) THEN + CALL get_qs_env(qs_env,kinetic_kp=kinetic_m) + CPPrecondition(ASSOCIATED(kinetic_m),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(kinetic_m(1,1)%matrix),cp_failure_level,routineP,failure) + CALL calculate_ptrace(kinetic_m,rho_ao,e_kin,dft_control%nspins) unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%KINETIC_ENERGY",& - extension=".Log",error=error) + extension=".Log") IF (unit_nr>0) THEN WRITE (unit_nr,'(T3,A,T55,F25.14)') "Electronic kinetic energy:",e_kin ENDIF CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%KINETIC_ENERGY", error=error) + "DFT%PRINT%KINETIC_ENERGY") END IF ! Atomic Charges that require further computation - CALL qs_scf_post_charges(input, logger, qs_env, error=error) + CALL qs_scf_post_charges(input, logger, qs_env) ! Moments of charge distribution - CALL qs_scf_post_moments(input, logger, qs_env, output_unit, error=error) + CALL qs_scf_post_moments(input, logger, qs_env, output_unit) ! Determine if we need to computer properties using the localized centers - localize_section => section_vals_get_subs_vals(dft_section,"LOCALIZE",error=error) - loc_print_section => section_vals_get_subs_vals(localize_section,"PRINT",error=error) - CALL section_vals_get(localize_section, explicit=loc_explicit, error=error) - CALL section_vals_get(loc_print_section, explicit=loc_print_explicit, error=error) + localize_section => section_vals_get_subs_vals(dft_section,"LOCALIZE") + loc_print_section => section_vals_get_subs_vals(localize_section,"PRINT") + CALL section_vals_get(localize_section, explicit=loc_explicit) + CALL section_vals_get(loc_print_section, explicit=loc_print_explicit) ! Print_keys controlled by localization IF(loc_print_explicit) THEN - print_key => section_vals_get_subs_vals(loc_print_section,"MOLECULAR_DIPOLES",error=error) - p_loc=BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file) - print_key => section_vals_get_subs_vals(loc_print_section,"TOTAL_DIPOLE",error=error) - p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file) - print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_CENTERS",error=error) - p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file) - print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_SPREADS",error=error) - p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file) - print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_CUBES",error=error) - p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file) - print_key => section_vals_get_subs_vals(loc_print_section,"MOLECULAR_STATES",error=error) - p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file) + print_key => section_vals_get_subs_vals(loc_print_section,"MOLECULAR_DIPOLES") + p_loc=BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file) + print_key => section_vals_get_subs_vals(loc_print_section,"TOTAL_DIPOLE") + p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file) + print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_CENTERS") + p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file) + print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_SPREADS") + p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file) + print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_CUBES") + p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file) + print_key => section_vals_get_subs_vals(loc_print_section,"MOLECULAR_STATES") + p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file) ELSE p_loc=.FALSE. END IF IF(loc_explicit) THEN - p_loc_homo=(section_get_ival(localize_section,"STATES",error=error)==do_loc_homo.OR.& - section_get_ival(localize_section,"STATES",error=error)==do_loc_both).AND.p_loc - p_loc_lumo=(section_get_ival(localize_section,"STATES",error=error)==do_loc_lumo.OR.& - section_get_ival(localize_section,"STATES",error=error)==do_loc_both).AND.p_loc - CALL section_vals_val_get(localize_section,"LIST_UNOCCUPIED", n_rep_val=n_rep,error=error) + p_loc_homo=(section_get_ival(localize_section,"STATES")==do_loc_homo.OR.& + section_get_ival(localize_section,"STATES")==do_loc_both).AND.p_loc + p_loc_lumo=(section_get_ival(localize_section,"STATES")==do_loc_lumo.OR.& + section_get_ival(localize_section,"STATES")==do_loc_both).AND.p_loc + CALL section_vals_val_get(localize_section,"LIST_UNOCCUPIED", n_rep_val=n_rep) ELSE p_loc_homo=.FALSE. p_loc_lumo=.FALSE. @@ -376,42 +372,42 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) only_ionode=.TRUE.) p_loc_lumo=.FALSE. END IF - print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_STATES",error=error) - p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file) + print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_STATES") + p_loc=p_loc.OR.BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file) ! Control for STM - stm_section => section_vals_get_subs_vals(input,"DFT%PRINT%STM", error=error) - CALL section_vals_get(stm_section,explicit=do_stm,error=error) + stm_section => section_vals_get_subs_vals(input,"DFT%PRINT%STM") + CALL section_vals_get(stm_section,explicit=do_stm) nlumo_stm = 0 - IF(do_stm) nlumo_stm = section_get_ival(stm_section,"NLUMO",error=error) + IF(do_stm) nlumo_stm = section_get_ival(stm_section,"NLUMO") ! check for CUBES (MOs and WANNIERS) - do_mo_cubes=BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%MO_CUBES",& - error=error),cp_p_file) + do_mo_cubes=BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%MO_CUBES")& + ,cp_p_file) IF(loc_print_explicit) THEN do_wannier_cubes=BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "WANNIER_CUBES",error=error),cp_p_file) + "WANNIER_CUBES"),cp_p_file) ELSE do_wannier_cubes=.FALSE. END IF - nlumo=section_get_ival(dft_section,"PRINT%MO_CUBES%NLUMO",error=error) - nhomo=section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO",error=error) + nlumo=section_get_ival(dft_section,"PRINT%MO_CUBES%NLUMO") + nhomo=section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO") nlumo_tddft = 0 IF(dft_control%do_tddfpt_calculation) THEN - nlumo_tddft=section_get_ival(dft_section,"TDDFPT%NLUMO",error=error) + nlumo_tddft=section_get_ival(dft_section,"TDDFPT%NLUMO") END IF ! Setup the grids needed to compute a wavefunction given a vector.. IF ( ( ( do_mo_cubes .OR. do_wannier_cubes ).AND. (nlumo /= 0 .OR. nhomo /= 0 )) .OR. p_loc ) THEN CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,wf_g%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) END IF ! Makes the MOs eigenstates, computes eigenvalues, write cubes @@ -419,25 +415,23 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF (do_mo_cubes) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Print MO Cubes not implemented for k-point calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ELSE CALL get_qs_env(qs_env,& mos=mos,& - matrix_ks=ks_rmpv,& - error=error) + matrix_ks=ks_rmpv) IF ((do_mo_cubes .AND. nhomo /= 0) .OR. do_stm .OR. dft_control%do_tddfpt_calculation ) THEN IF (dft_control%restricted) THEN IF (output_unit>0) WRITE(output_unit,*) & " Unclear how we define MOs in the restricted case ... skipping" ELSE - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,error=error) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs) IF(dft_control%do_admm) THEN - CALL get_qs_env(qs_env,admm_env=admm_env, error=error) - CALL make_mo_eig(mos,dft_control%nspins,ks_rmpv,scf_control,mo_derivs,admm_env=admm_env,& - error=error) + CALL get_qs_env(qs_env,admm_env=admm_env) + CALL make_mo_eig(mos,dft_control%nspins,ks_rmpv,scf_control,mo_derivs,admm_env=admm_env) ELSE - CALL make_mo_eig(mos,dft_control%nspins,ks_rmpv,scf_control,mo_derivs,error=error) + CALL make_mo_eig(mos,dft_control%nspins,ks_rmpv,scf_control,mo_derivs) END IF END IF DO ispin=1,dft_control%nspins @@ -452,7 +446,7 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff, & eigenvalues=mo_eigenvalues,homo=homo,nmo=nmo) CALL qs_scf_post_occ_cubes(input, dft_section, dft_control, logger, qs_env,& - mo_coeff, wf_g, wf_r, particles, homo, ispin, error=error) + mo_coeff, wf_g, wf_r, particles, homo, ispin) END DO ENDIF ENDIF @@ -465,53 +459,53 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF (do_kpoints) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Localization not implemented for k-point calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSEIF (dft_control%restricted) THEN IF (output_unit>0) WRITE(output_unit,*) & " Unclear how we define MOs / localization in the restricted case ... skipping" ELSE ALLOCATE(occupied_orbs(dft_control%nspins),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(occupied_evals(dft_control%nspins),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(homo_localized(dft_control%nspins),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff, & eigenvalues=mo_eigenvalues) occupied_orbs(ispin)%matrix=>mo_coeff occupied_evals(ispin)%array=>mo_eigenvalues - CALL cp_fm_create(homo_localized(ispin)%matrix,occupied_orbs(ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_to_fm(occupied_orbs(ispin)%matrix,homo_localized(ispin)%matrix,error=error) + CALL cp_fm_create(homo_localized(ispin)%matrix,occupied_orbs(ispin)%matrix%matrix_struct) + CALL cp_fm_to_fm(occupied_orbs(ispin)%matrix,homo_localized(ispin)%matrix) END DO - CALL get_qs_env(qs_env,mo_loc_history=mo_loc_history,error=error) + CALL get_qs_env(qs_env,mo_loc_history=mo_loc_history) do_homo=.TRUE. - CALL qs_loc_env_create(qs_loc_env_homo,error=error) - CALL qs_loc_control_init(qs_loc_env_homo,localize_section,do_homo=do_homo,error=error) + CALL qs_loc_env_create(qs_loc_env_homo) + CALL qs_loc_control_init(qs_loc_env_homo,localize_section,do_homo=do_homo) CALL qs_loc_init(qs_env,qs_loc_env_homo,localize_section,homo_localized,do_homo,& - do_mo_cubes,mo_loc_history=mo_loc_history,error=error) + do_mo_cubes,mo_loc_history=mo_loc_history) CALL get_localization_info(qs_env,qs_loc_env_homo,localize_section,homo_localized,& - wf_r, wf_g,particles,occupied_orbs,occupied_evals,marked_states,error=error) + wf_r, wf_g,particles,occupied_orbs,occupied_evals,marked_states) !retain the homo_localized for future use IF (qs_loc_env_homo%localized_wfn_control%use_history) THEN - CALL retain_history(mo_loc_history,homo_localized,error) - CALL set_qs_env(qs_env,mo_loc_history=mo_loc_history,error=error) + CALL retain_history(mo_loc_history,homo_localized) + CALL set_qs_env(qs_env,mo_loc_history=mo_loc_history) ENDIF !write restart for localization of occupied orbitals CALL loc_write_restart(qs_loc_env_homo,loc_print_section,mos,& - homo_localized, do_homo, error=error) - CALL cp_fm_vect_dealloc(homo_localized,error) + homo_localized, do_homo) + CALL cp_fm_vect_dealloc(homo_localized) DEALLOCATE(occupied_orbs,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(occupied_evals,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! Print Total Dipole if the localization has been performed IF (qs_loc_env_homo%do_localize) THEN - CALL qs_scf_post_loc_dip(input, dft_control, qs_loc_env_homo, logger, qs_env, error) + CALL qs_scf_post_loc_dip(input, dft_control, qs_loc_env_homo, logger, qs_env) END IF END IF ENDIF @@ -521,7 +515,7 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) ! nothing at the moment, not implemented CALL cp_unimplemented_error(fromWhere=routineP, & message="Localization and MO related output not implemented for k-point calculations!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSE IF(nlumo .GT. -1) THEN nlumo = MAX(nlumo, nlumo_tddft) @@ -536,7 +530,7 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF(do_mo_cubes .AND. .NOT. compute_lumos) THEN - nlumo=section_get_ival(dft_section,"PRINT%MO_CUBES%NLUMO",error=error) + nlumo=section_get_ival(dft_section,"PRINT%MO_CUBES%NLUMO") DO ispin = 1,dft_control%nspins CALL get_mo_set(mo_set=mos(ispin)%mo_set, homo=homo, nmo=nmo, eigenvalues=mo_eigenvalues) @@ -554,7 +548,7 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) ! Prints the cube files of UNOCCUPIED ORBITALS CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) CALL qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_env,& - mo_coeff, wf_g, wf_r, particles, nlumo, homo, ispin, lumo=homo+1, error=error) + mo_coeff, wf_g, wf_r, particles, nlumo, homo, ispin, lumo=homo+1) END IF END DO @@ -566,16 +560,16 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF(nlumo==0)check_write=.FALSE. IF(p_loc_lumo)THEN do_homo=.FALSE. - CALL qs_loc_env_create(qs_loc_env_lumo,error=error) - CALL qs_loc_control_init(qs_loc_env_lumo,localize_section,do_homo=do_homo,error=error) + CALL qs_loc_env_create(qs_loc_env_lumo) + CALL qs_loc_control_init(qs_loc_env_lumo,localize_section,do_homo=do_homo) min_lumos=MAX(MAXVAL(qs_loc_env_lumo%localized_wfn_control%loc_states(:,:)),nlumo) END IF ALLOCATE(unoccupied_orbs(dft_control%nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(unoccupied_evals(dft_control%nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) - CALL make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,min_lumos,nlumos,error) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) + CALL make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,min_lumos,nlumos) lumo_ptr=>unoccupied_orbs DO ispin=1,dft_control%nspins has_lumo=.TRUE. @@ -585,7 +579,7 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF(p_loc_lumo.AND.nlumo.NE.-1)nlumos=MIN(nlumo,nlumos) ! Prints the cube files of UNOCCUPIED ORBITALS CALL qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_env,& - unoccupied_orbs(ispin)%matrix, wf_g, wf_r, particles, nlumos, homo, ispin, error=error) + unoccupied_orbs(ispin)%matrix, wf_g, wf_r, particles, nlumos, homo, ispin) END IF END DO @@ -601,20 +595,20 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF(p_loc_lumo)THEN ALLOCATE(lumo_localized(dft_control%nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins - CALL cp_fm_create(lumo_localized(ispin)%matrix,unoccupied_orbs(ispin)%matrix%matrix_struct,error=error) - CALL cp_fm_to_fm(unoccupied_orbs(ispin)%matrix,lumo_localized(ispin)%matrix,error=error) + CALL cp_fm_create(lumo_localized(ispin)%matrix,unoccupied_orbs(ispin)%matrix%matrix_struct) + CALL cp_fm_to_fm(unoccupied_orbs(ispin)%matrix,lumo_localized(ispin)%matrix) END DO CALL qs_loc_init(qs_env,qs_loc_env_lumo,localize_section,lumo_localized,do_homo,do_mo_cubes,& - evals=unoccupied_evals, error=error) + evals=unoccupied_evals) CALL qs_loc_env_init(qs_loc_env_lumo,qs_loc_env_lumo%localized_wfn_control,qs_env,& - loc_coeff=unoccupied_orbs,error=error) + loc_coeff=unoccupied_orbs) CALL get_localization_info(qs_env,qs_loc_env_lumo,localize_section, & lumo_localized, wf_r, wf_g,particles,& - unoccupied_orbs,unoccupied_evals,marked_states,error=error) + unoccupied_orbs,unoccupied_evals,marked_states) CALL loc_write_restart(qs_loc_env_lumo,loc_print_section,mos,homo_localized, do_homo,& - evals=unoccupied_evals, error=error) + evals=unoccupied_evals) lumo_ptr=>lumo_localized END IF ENDIF @@ -633,28 +627,28 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) ! Deallocate grids needed to compute wavefunctions IF ( ( ( do_mo_cubes .OR. do_wannier_cubes ).AND. (nlumo /= 0 .OR. nhomo /= 0 )) .OR. p_loc ) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw) END IF ! Destroy the localization environment IF (.NOT.do_kpoints) THEN - IF (p_loc_homo) CALL qs_loc_env_destroy(qs_loc_env_homo, error=error) - IF (p_loc_lumo) CALL qs_loc_env_destroy(qs_loc_env_lumo, error=error) + IF (p_loc_homo) CALL qs_loc_env_destroy(qs_loc_env_homo) + IF (p_loc_lumo) CALL qs_loc_env_destroy(qs_loc_env_lumo) END IF ! generate a mix of wfns, and write to a restart IF (do_kpoints) THEN ! nothing at the moment, not implemented ELSE - CALL get_qs_env(qs_env,matrix_s=matrix_s,error=error) + CALL get_qs_env(qs_env,matrix_s=matrix_s) CALL wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, & - lumo_ptr, scf_env, matrix_s, output_unit, marked_states,error) - IF(p_loc_lumo)CALL cp_fm_vect_dealloc(lumo_localized,error) + lumo_ptr, scf_env, matrix_s, output_unit, marked_states) + IF(p_loc_lumo)CALL cp_fm_vect_dealloc(lumo_localized) END IF IF(ASSOCIATED(marked_states))THEN DEALLOCATE(marked_states,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF ! This is just a deallocation for printing MO_CUBES or TDDFPT @@ -662,15 +656,15 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF(compute_lumos) THEN DO ispin=1,dft_control%nspins DEALLOCATE(unoccupied_evals(ispin)%array,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF (.NOT.dft_control%do_tddfpt_calculation) & - CALL cp_fm_release(unoccupied_orbs(ispin)%matrix,error=error) + CALL cp_fm_release(unoccupied_orbs(ispin)%matrix) ENDDO DEALLOCATE(unoccupied_evals,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) IF (.NOT.dft_control%do_tddfpt_calculation) THEN DEALLOCATE(unoccupied_orbs,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF ENDIF ENDIF @@ -680,48 +674,48 @@ SUBROUTINE scf_post_calculation_gpw(dft_section, scf_env,qs_env, error) IF(do_kpoints) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="STM not implemented for k-point calculations!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSE ALLOCATE(unoccupied_orbs_stm(dft_control%nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(unoccupied_evals_stm(dft_control%nspins),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL make_lumo(qs_env,scf_env,unoccupied_orbs_stm,unoccupied_evals_stm,& - nlumo_stm,nlumos,error=error) + nlumo_stm,nlumos) CALL th_stm_image(qs_env, stm_section, particles, unoccupied_orbs_stm, & - unoccupied_evals_stm, error=error) + unoccupied_evals_stm) DO ispin=1,dft_control%nspins DEALLOCATE(unoccupied_evals_stm(ispin)%array,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_fm_release(unoccupied_orbs_stm(ispin)%matrix,error=error) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_fm_release(unoccupied_orbs_stm(ispin)%matrix) ENDDO DEALLOCATE(unoccupied_evals_stm,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(unoccupied_orbs_stm,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END IF END IF ! Print coherent X-ray diffraction spectrum - CALL qs_scf_post_xray(input, dft_section, logger, qs_env, output_unit, error) + CALL qs_scf_post_xray(input, dft_section, logger, qs_env, output_unit) ! Calculation of Electric Field Gradients - CALL qs_scf_post_efg(input, logger, qs_env, error) + CALL qs_scf_post_efg(input, logger, qs_env) ! Calculation of ET - CALL qs_scf_post_et(input, qs_env, dft_control, error) + CALL qs_scf_post_et(input, qs_env, dft_control) ! Calculation of EPR Hyperfine Coupling Tensors - CALL qs_scf_post_epr(input, logger, qs_env, error) + CALL qs_scf_post_epr(input, logger, qs_env) ! Calculation of properties needed for BASIS_MOLOPT optimizations - CALL qs_scf_post_molopt(input, logger, qs_env, error) + CALL qs_scf_post_molopt(input, logger, qs_env) ! Calculate ELF - CALL qs_scf_post_elf(input, logger, qs_env, error) + CALL qs_scf_post_elf(input, logger, qs_env) CALL timestop(handle) @@ -740,10 +734,9 @@ END SUBROUTINE scf_post_calculation_gpw !> \param coeff ... !> \param evals ... !> \param marked_states ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_localization_info(qs_env,qs_loc_env,loc_section,mo_local,& - wf_r, wf_g,particles,coeff,evals,marked_states,error) + wf_r, wf_g,particles,coeff,evals,marked_states) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env @@ -757,7 +750,6 @@ SUBROUTINE get_localization_info(qs_env,qs_loc_env,loc_section,mo_local,& TYPE(cp_1d_r_p_type), DIMENSION(:), & POINTER :: evals INTEGER, DIMENSION(:, :, :), POINTER :: marked_states - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_localization_info', & routineP = moduleN//':'//routineN @@ -783,17 +775,17 @@ SUBROUTINE get_localization_info(qs_env,qs_loc_env,loc_section,mo_local,& NULLIFY(mos, ks_rmpv, dft_control, loc_print_section, marked_states_spin,& matrix_s, molecule_set, scenter,wc) CALL get_qs_env(qs_env,mos=mos,matrix_ks=ks_rmpv,molecule_set=molecule_set,& - dft_control=dft_control,matrix_s=matrix_s,error=error) - logger => cp_error_get_logger(error) + dft_control=dft_control,matrix_s=matrix_s) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - loc_print_section => section_vals_get_subs_vals(loc_section,"PRINT",error=error) + loc_print_section => section_vals_get_subs_vals(loc_section,"PRINT") do_homo=qs_loc_env%localized_wfn_control%do_homo IF (BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "WANNIER_STATES",error=error),cp_p_file)) THEN - CALL get_qs_env(qs_env=qs_env,WannierCentres=wc,error=error) + "WANNIER_STATES"),cp_p_file)) THEN + CALL get_qs_env(qs_env=qs_env,WannierCentres=wc) IF (.NOT. ASSOCIATED(wc)) THEN ALLOCATE(wc(dft_control%nspins),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDIF DO ispin=1,dft_control%nspins @@ -816,58 +808,58 @@ SUBROUTINE get_localization_info(qs_env,qs_loc_env,loc_section,mo_local,& scenter => qs_loc_env%localized_wfn_control%centers_set(ispin)%array CALL qs_loc_driver(qs_env,qs_loc_env,loc_print_section,& - myspin=ispin,ext_mo_coeff=mo_local(ispin)%matrix,error=error) + myspin=ispin,ext_mo_coeff=mo_local(ispin)%matrix) ! maps wfc to molecules, and compute the molecular dipoles if required IF (( BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "MOLECULAR_DIPOLES",error=error),cp_p_file) .OR. & + "MOLECULAR_DIPOLES"),cp_p_file) .OR. & BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "MOLECULAR_STATES",error=error),cp_p_file))) THEN + "MOLECULAR_STATES"),cp_p_file))) THEN CALL wfc_to_molecule(qs_env, qs_loc_env, loc_print_section, scenter,& - molecule_set, dft_control%nspins, error) + molecule_set, dft_control%nspins) END IF ! Compute the wannier states IF (BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "WANNIER_STATES",error=error),cp_p_file)) THEN + "WANNIER_STATES"),cp_p_file)) THEN ns=SIZE(qs_loc_env%localized_wfn_control%loc_states,1) IF (.NOT. ASSOCIATED(wc(ispin)%centres)) THEN ALLOCATE(wc(ispin)%WannierHamDiag(ns),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wc(ispin)%centres(3,ns),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF wc(ispin)%centres(:,:)=scenter(1+(ispin-1)*3:ispin*3,:) lstates => qs_loc_env%localized_wfn_control%loc_states(:,ispin) CALL construct_wannier_states(mo_local(ispin)%matrix,& ks_rmpv(ispin)%matrix, qs_env, loc_print_section=loc_print_section,& - WannierCentres=wc(ispin),ns=ns,states=lstates, error=error) + WannierCentres=wc(ispin),ns=ns,states=lstates) ENDIF ! Compute the molecular states IF ( BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "MOLECULAR_STATES",error=error),cp_p_file)) THEN + "MOLECULAR_STATES"),cp_p_file)) THEN CALL construct_molecular_states(molecule_set, mo_local(ispin)%matrix, coeff(ispin)%matrix,& evals(ispin)%array,ks_rmpv(ispin)%matrix, matrix_s(1)%matrix, qs_env, wf_r, wf_g, & loc_print_section=loc_print_section, particles=particles, tag=TRIM(qs_loc_env%tag_mo),& - marked_states=marked_states_spin,error=error) + marked_states=marked_states_spin) IF(ASSOCIATED(marked_states_spin))THEN IF(.NOT.ASSOCIATED(marked_states))THEN ALLOCATE(marked_states(SIZE(marked_states_spin),dft_control%nspins,2),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF mystate=1 IF(qs_loc_env%tag_mo=="LUMO")mystate=2 marked_states(:,ispin,mystate)=marked_states_spin(:) DEALLOCATE(marked_states_spin,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ENDIF END IF ENDDO IF (BTEST(cp_print_key_should_output(logger%iter_info,loc_print_section,& - "WANNIER_STATES",error=error),cp_p_file)) THEN - CALL set_qs_env(qs_env=qs_env,WannierCentres=wc,error=error) + "WANNIER_STATES"),cp_p_file)) THEN + CALL set_qs_env(qs_env=qs_env,WannierCentres=wc) ENDIF CALL timestop(handle) @@ -882,9 +874,8 @@ END SUBROUTINE get_localization_info !> \param unoccupied_evals ... !> \param nlumo ... !> \param nlumos ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,nlumo,nlumos,error) + SUBROUTINE make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,nlumo,nlumos) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env @@ -894,7 +885,6 @@ SUBROUTINE make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,nlumo,nlumo POINTER :: unoccupied_evals INTEGER :: nlumo INTEGER, INTENT(OUT) :: nlumos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'make_lumo', & routineP = moduleN//':'//routineN @@ -927,10 +917,9 @@ SUBROUTINE make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,nlumo,nlumo matrix_s=matrix_s,& admm_env=admm_env,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) DO ispin=1,dft_control%nspins @@ -941,16 +930,16 @@ SUBROUTINE make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,nlumo,nlumo IF (output_unit>0) WRITE(output_unit,*) " Lowest Eigenvalues of the unoccupied subspace spin ",ispin IF (output_unit>0) WRITE(output_unit,FMT='(1X,A)') "-----------------------------------------------------" CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff,homo=homo,nao=nao,nmo=nmo) - CALL cp_fm_get_info(mo_coeff, nrow_global=n,error=error) + CALL cp_fm_get_info(mo_coeff, nrow_global=n) nlumos=MAX(1,MIN(nlumo,nao-nmo)) IF (nlumo==-1) nlumos=nao-nmo ALLOCATE(unoccupied_evals(ispin)%array(nlumos),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=blacs_env, & - nrow_global=n,ncol_global=nlumos,error=error) - CALL cp_fm_create(unoccupied_orbs(ispin)%matrix, fm_struct_tmp,name="lumos",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) - CALL cp_fm_init_random(unoccupied_orbs(ispin)%matrix,nlumos,error=error) + nrow_global=n,ncol_global=nlumos) + CALL cp_fm_create(unoccupied_orbs(ispin)%matrix, fm_struct_tmp,name="lumos") + CALL cp_fm_struct_release(fm_struct_tmp) + CALL cp_fm_init_random(unoccupied_orbs(ispin)%matrix,nlumos) ! the full_all preconditioner makes not much sense for lumos search NULLIFY(local_preconditioner) @@ -964,8 +953,7 @@ SUBROUTINE make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,nlumo,nlumo ! ** If we do ADMM, we add have to modify the kohn-sham matrix IF( dft_control%do_admm ) THEN - CALL admm_correct_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix, & - error) + CALL admm_correct_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix) END IF CALL ot_eigensolver(matrix_h=ks_rmpv(ispin)%matrix,matrix_s=matrix_s(1)%matrix, & @@ -974,17 +962,16 @@ SUBROUTINE make_lumo(qs_env,scf_env,unoccupied_orbs,unoccupied_evals,nlumo,nlumo eps_gradient=scf_control%eps_lumos, & preconditioner=local_preconditioner, & iter_max=scf_control%max_iter_lumos,& - size_ortho_space=nmo,error=error) + size_ortho_space=nmo) CALL calculate_subspace_eigenvalues(unoccupied_orbs(ispin)%matrix,ks_rmpv(ispin)%matrix,& unoccupied_evals(ispin)%array, scr=output_unit, & - ionode=output_unit>0,error=error) + ionode=output_unit>0) ! ** If we do ADMM, we restore the original kohn-sham matrix IF( dft_control%do_admm ) THEN - CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix, & - error) + CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix) END IF END DO @@ -997,14 +984,11 @@ END SUBROUTINE make_lumo !> \param input ... !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_charges(input, logger, qs_env, error) + SUBROUTINE qs_scf_post_charges(input, logger, qs_env) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_charges', & routineP = moduleN//':'//routineN @@ -1015,41 +999,41 @@ SUBROUTINE qs_scf_post_charges(input, logger, qs_env, error) CALL timeset(routineN,handle) - CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints,error=error) + CALL get_qs_env(qs_env=qs_env,do_kpoints=do_kpoints) ! Mulliken charges require no further computation and are printed from write_mo_free_results ! Compute the Lowdin charges - print_key => section_vals_get_subs_vals(input,"DFT%PRINT%LOWDIN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%PRINT%LOWDIN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%LOWDIN",extension=".lowdin",& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) print_level = 1 - CALL section_vals_val_get(print_key,"PRINT_GOP",l_val=print_it,error=error) + CALL section_vals_val_get(print_key,"PRINT_GOP",l_val=print_it) IF (print_it) print_level = 2 - CALL section_vals_val_get(print_key,"PRINT_ALL",l_val=print_it,error=error) + CALL section_vals_val_get(print_key,"PRINT_ALL",l_val=print_it) IF (print_it) print_level = 3 IF(do_kpoints) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Lowdin charges not implemented for k-point calculations!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSE - CALL lowdin_population_analysis(qs_env,unit_nr,print_level,error) + CALL lowdin_population_analysis(qs_env,unit_nr,print_level) END IF - CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%LOWDIN", error=error) + CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%LOWDIN") END IF ! Compute the RESP charges - CALL resp_fit(qs_env,error) + CALL resp_fit(qs_env) ! Compute the Density Derived Atomic Point charges with the Bloechl scheme - print_key => section_vals_get_subs_vals(input,"PROPERTIES%FIT_CHARGE", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"PROPERTIES%FIT_CHARGE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN unit_nr=cp_print_key_unit_nr(logger,input,"PROPERTIES%FIT_CHARGE",extension=".Fitcharge",& - log_filename=.FALSE.,error=error) - density_fit_section => section_vals_get_subs_vals(input,"DFT%DENSITY_FITTING", error=error) - CALL get_ddapc(qs_env,.FALSE.,density_fit_section,iwc=unit_nr,error=error) - CALL cp_print_key_finished_output(unit_nr, logger,input,"PROPERTIES%FIT_CHARGE", error=error) + log_filename=.FALSE.) + density_fit_section => section_vals_get_subs_vals(input,"DFT%DENSITY_FITTING") + CALL get_ddapc(qs_env,.FALSE.,density_fit_section,iwc=unit_nr) + CALL cp_print_key_finished_output(unit_nr, logger,input,"PROPERTIES%FIT_CHARGE") END IF CALL timestop(handle) @@ -1063,16 +1047,13 @@ END SUBROUTINE qs_scf_post_charges !> \param qs_loc_env ... !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env, error) + SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env) TYPE(section_vals_type), POINTER :: input TYPE(dft_control_type), POINTER :: dft_control TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_loc_dip', & routineP = moduleN//':'//routineN @@ -1100,23 +1081,22 @@ SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env, e CALL timeset(routineN,handle) failure = .FALSE. - print_key => section_vals_get_subs_vals(input,"DFT%LOCALIZE%PRINT%TOTAL_DIPOLE", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,first_time=first_time,& - error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%LOCALIZE%PRINT%TOTAL_DIPOLE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,first_time=first_time)& + ,cp_p_file)) THEN NULLIFY(cell, particle_set, qs_kind_set, ref_point, results) CALL get_qs_env(qs_env=qs_env,& cell=cell,& particle_set=particle_set,& qs_kind_set=qs_kind_set,& - results=results,& - error=error) + results=results) - reference = section_get_ival(print_key,keyword_name="REFERENCE",error=error) - CALL section_vals_val_get(print_key,"REF_POINT",r_vals=ref_point,error=error) - CALL section_vals_val_get(print_key,"PERIODIC",l_val=do_berry,error=error) + reference = section_get_ival(print_key,keyword_name="REFERENCE") + CALL section_vals_val_get(print_key,"REF_POINT",r_vals=ref_point) + CALL section_vals_val_get(print_key,"PERIODIC",l_val=do_berry) description='[DIPOLE]' descriptionThisDip='[TOTAL_DIPOLE]' - CALL get_reference_point(rcc,qs_env=qs_env,reference=reference,ref_point=ref_point,error=error) + CALL get_reference_point(rcc,qs_env=qs_env,reference=reference,ref_point=ref_point) dipole=0.0_dp IF (do_berry) THEN @@ -1129,9 +1109,9 @@ SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env, e ! Nuclear charges DO i=1,SIZE(particle_set) CALL get_atomic_kind(particle_set(i)%atomic_kind,kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), ghost=ghost, error=error) + CALL get_qs_kind(qs_kind_set(ikind), ghost=ghost) IF (.NOT.ghost) THEN - CALL get_qs_kind(qs_kind_set(ikind), core_charge=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), core_charge=zeff) ria = pbc(particle_set(i)%r, cell) DO j = 1, 3 gvec = twopi*cell%h_inv(j,:) @@ -1164,9 +1144,9 @@ SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env, e ! Charges of the atoms involved DO i=1,SIZE(particle_set) CALL get_atomic_kind(particle_set(i)%atomic_kind, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), ghost=ghost, error=error) + CALL get_qs_kind(qs_kind_set(ikind), ghost=ghost) IF (.NOT.ghost) THEN - CALL get_qs_kind(qs_kind_set(ikind), core_charge=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind), core_charge=zeff) ria = pbc(particle_set(i)%r, cell) dipole=dipole + zeff*(ria-rcc) END IF @@ -1186,7 +1166,7 @@ SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env, e ! Print and possibly store results unit_nr=cp_print_key_unit_nr(logger,print_key,extension=".Dipole",& - middle_name="TOTAL_DIPOLE",error=error) + middle_name="TOTAL_DIPOLE") IF (unit_nr>0) THEN IF (first_time) THEN WRITE(unit=unit_nr,fmt="(A,T31,A,T88,A,T136,A)")& @@ -1194,12 +1174,12 @@ SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env, e "dipole(x,y,z)[debye]",& "delta_dipole(x,y,z)[atomic units]" END IF - iter=cp_iter_string(logger%iter_info,error=error) - CALL get_results(results,descriptionThisDip,n_rep=n_rep,error=error) + iter=cp_iter_string(logger%iter_info) + CALL get_results(results,descriptionThisDip,n_rep=n_rep) IF(n_rep==0)THEN dipole_old=0._dp ELSE - CALL get_results(results,descriptionThisDip,dipole_old,nval=n_rep,error=error) + CALL get_results(results,descriptionThisDip,dipole_old,nval=n_rep) END IF IF (do_berry) THEN WRITE(unit=unit_nr,fmt="(a,9(es18.8))")& @@ -1209,11 +1189,11 @@ SUBROUTINE qs_scf_post_loc_dip(input, dft_control, qs_loc_env, logger, qs_env, e iter(1:15), dipole, dipole*debye, (dipole-dipole_old) END IF END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) - CALL cp_results_erase(results,description,error=error) - CALL put_results(results,description,dipole,error) - CALL cp_results_erase(results,descriptionThisDip,error=error) - CALL put_results(results,descriptionThisDip,dipole,error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + CALL cp_results_erase(results,description) + CALL put_results(results,description,dipole) + CALL cp_results_erase(results,descriptionThisDip) + CALL put_results(results,descriptionThisDip,dipole) END IF CALL timestop(handle) @@ -1233,11 +1213,9 @@ END SUBROUTINE qs_scf_post_loc_dip !> \param particles ... !> \param homo ... !> \param ispin ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE qs_scf_post_occ_cubes(input, dft_section, dft_control, logger, qs_env,& - mo_coeff, wf_g, wf_r, particles, homo, ispin, error) + mo_coeff, wf_g, wf_r, particles, homo, ispin) TYPE(section_vals_type), POINTER :: input, dft_section TYPE(dft_control_type), POINTER :: dft_control TYPE(cp_logger_type), POINTER :: logger @@ -1246,7 +1224,6 @@ SUBROUTINE qs_scf_post_occ_cubes(input, dft_section, dft_control, logger, qs_env TYPE(pw_p_type) :: wf_g, wf_r TYPE(particle_list_type), POINTER :: particles INTEGER, INTENT(IN) :: homo, ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_occ_cubes', & routineP = moduleN//':'//routineN @@ -1266,10 +1243,10 @@ SUBROUTINE qs_scf_post_occ_cubes(input, dft_section, dft_control, logger, qs_env CALL timeset(routineN,handle) - IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%MO_CUBES",& - error=error),cp_p_file) .AND. section_get_lval(dft_section,"PRINT%MO_CUBES%WRITE_CUBE",error=error)) THEN - nhomo=section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO",error=error) - append_cube = section_get_lval(dft_section,"PRINT%MO_CUBES%APPEND",error=error) + IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%MO_CUBES")& + ,cp_p_file) .AND. section_get_lval(dft_section,"PRINT%MO_CUBES%WRITE_CUBE")) THEN + nhomo=section_get_ival(dft_section,"PRINT%MO_CUBES%NHOMO") + append_cube = section_get_lval(dft_section,"PRINT%MO_CUBES%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" @@ -1281,18 +1258,16 @@ SUBROUTINE qs_scf_post_occ_cubes(input, dft_section, dft_control, logger, qs_env qs_kind_set=qs_kind_set,& cell=cell,& particle_set=particle_set,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) CALL calculate_wavefunction(mo_coeff,ivector,wf_r,wf_g,atomic_kind_set,qs_kind_set,& - cell,dft_control,particle_set,pw_env,error=error) + cell,dft_control,particle_set,pw_env) WRITE(filename,'(a4,I5.5,a1,I1.1)')"WFN_",ivector,"_",ispin unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%MO_CUBES",extension=".cube",& - middle_name=TRIM(filename),file_position=my_pos_cube,log_filename=.FALSE.,error=error) + middle_name=TRIM(filename),file_position=my_pos_cube,log_filename=.FALSE.) WRITE(title,*) "WAVEFUNCTION ",ivector," spin ",ispin," i.e. HOMO - ",ivector-homo CALL cp_pw_to_cube(wf_r%pw,unit_nr,title,particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%MO_CUBES%STRIDE",error=error),& - error=error) - CALL cp_print_key_finished_output(unit_nr,logger,input,"DFT%PRINT%MO_CUBES",error=error) + stride=section_get_ivals(dft_section,"PRINT%MO_CUBES%STRIDE")) + CALL cp_print_key_finished_output(unit_nr,logger,input,"DFT%PRINT%MO_CUBES") ENDDO END IF @@ -1315,11 +1290,9 @@ END SUBROUTINE qs_scf_post_occ_cubes !> \param homo ... !> \param ispin ... !> \param lumo ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_env,& - unoccupied_orbs, wf_g, wf_r, particles, nlumos, homo, ispin, lumo, error) + unoccupied_orbs, wf_g, wf_r, particles, nlumos, homo, ispin, lumo) TYPE(section_vals_type), POINTER :: input, dft_section TYPE(dft_control_type), POINTER :: dft_control TYPE(cp_logger_type), POINTER :: logger @@ -1329,7 +1302,6 @@ SUBROUTINE qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_e TYPE(particle_list_type), POINTER :: particles INTEGER, INTENT(IN) :: nlumos, homo, ispin INTEGER, INTENT(IN), OPTIONAL :: lumo - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_unocc_cubes', & routineP = moduleN//':'//routineN @@ -1349,10 +1321,10 @@ SUBROUTINE qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_e CALL timeset(routineN,handle) - IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%MO_CUBES",error=error),cp_p_file)& - .AND. section_get_lval(dft_section,"PRINT%MO_CUBES%WRITE_CUBE",error=error) ) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%MO_CUBES"),cp_p_file)& + .AND. section_get_lval(dft_section,"PRINT%MO_CUBES%WRITE_CUBE") ) THEN NULLIFY(qs_kind_set, particle_set, pw_env, cell) - append_cube = section_get_lval(dft_section,"PRINT%MO_CUBES%APPEND",error=error) + append_cube = section_get_lval(dft_section,"PRINT%MO_CUBES%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" @@ -1365,10 +1337,9 @@ SUBROUTINE qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_e qs_kind_set=qs_kind_set,& cell=cell,& particle_set=particle_set,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) CALL calculate_wavefunction(unoccupied_orbs, ivector, wf_r, wf_g, atomic_kind_set, & - qs_kind_set, cell, dft_control, particle_set, pw_env, error=error) + qs_kind_set, cell, dft_control, particle_set, pw_env) IF(ifirst==1) THEN index_mo = homo+ivector @@ -1378,12 +1349,11 @@ SUBROUTINE qs_scf_post_unocc_cubes(input, dft_section, dft_control, logger, qs_e WRITE(filename,'(a4,I5.5,a1,I1.1)')"WFN_",index_mo,"_",ispin unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%MO_CUBES",extension=".cube",& - middle_name=TRIM(filename),file_position=my_pos_cube,log_filename=.FALSE.,error=error) + middle_name=TRIM(filename),file_position=my_pos_cube,log_filename=.FALSE.) WRITE(title,*) "WAVEFUNCTION ",index_mo," spin ",ispin," i.e. LUMO + ",ifirst+ivector-2 CALL cp_pw_to_cube(wf_r%pw, unit_nr, title, particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%MO_CUBES%STRIDE",error=error),& - error=error) - CALL cp_print_key_finished_output(unit_nr,logger,input,"DFT%PRINT%MO_CUBES",error=error) + stride=section_get_ivals(dft_section,"PRINT%MO_CUBES%STRIDE")) + CALL cp_print_key_finished_output(unit_nr,logger,input,"DFT%PRINT%MO_CUBES") ENDDO ENDIF @@ -1397,15 +1367,12 @@ END SUBROUTINE qs_scf_post_unocc_cubes !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives !> \param output_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_moments(input, logger, qs_env, output_unit, error) + SUBROUTINE qs_scf_post_moments(input, logger, qs_env, output_unit) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_moments', & routineP = moduleN//':'//routineN @@ -1420,23 +1387,23 @@ SUBROUTINE qs_scf_post_moments(input, logger, qs_env, output_unit, error) CALL timeset(routineN,handle) print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%MOMENTS",error=error) + subsection_name="DFT%PRINT%MOMENTS") - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN maxmom = section_get_ival(section_vals=input,& - keyword_name="DFT%PRINT%MOMENTS%MAX_MOMENT",error=error) + keyword_name="DFT%PRINT%MOMENTS%MAX_MOMENT") periodic = section_get_lval(section_vals=input,& - keyword_name="DFT%PRINT%MOMENTS%PERIODIC",error=error) + keyword_name="DFT%PRINT%MOMENTS%PERIODIC") reference = section_get_ival(section_vals=input,& - keyword_name="DFT%PRINT%MOMENTS%REFERENCE",error=error) + keyword_name="DFT%PRINT%MOMENTS%REFERENCE") magnetic = section_get_lval(section_vals=input,& - keyword_name="DFT%PRINT%MOMENTS%MAGNETIC",error=error) + keyword_name="DFT%PRINT%MOMENTS%MAGNETIC") NULLIFY ( ref_point ) - CALL section_vals_val_get(input,"DFT%PRINT%MOMENTS%REF_POINT",r_vals=ref_point,error=error) + CALL section_vals_val_get(input,"DFT%PRINT%MOMENTS%REF_POINT",r_vals=ref_point) unit_nr = cp_print_key_unit_nr(logger=logger,basis_section=input,& print_key_path="DFT%PRINT%MOMENTS",extension=".dat",& - middle_name="moments",log_filename=.FALSE.,error=error) + middle_name="moments",log_filename=.FALSE.) IF (output_unit>0) THEN IF(unit_nr /= output_unit) THEN @@ -1449,23 +1416,22 @@ SUBROUTINE qs_scf_post_moments(input, logger, qs_env, output_unit, error) END IF END IF - CALL get_qs_env(qs_env,do_kpoints=do_kpoints,error=error) + CALL get_qs_env(qs_env,do_kpoints=do_kpoints) IF (do_kpoints) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Moments not implemented for k-point calculations!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ELSE IF (periodic) THEN - CALL qs_moment_berry_phase(qs_env,magnetic,maxmom,reference,ref_point,unit_nr,error) + CALL qs_moment_berry_phase(qs_env,magnetic,maxmom,reference,ref_point,unit_nr) ELSE - CALL qs_moment_locop(qs_env,magnetic,maxmom,reference,ref_point,unit_nr,error) + CALL qs_moment_locop(qs_env,magnetic,maxmom,reference,ref_point,unit_nr) END IF END IF CALL cp_print_key_finished_output(unit_nr=unit_nr,logger=logger,& - basis_section=input,print_key_path="DFT%PRINT%MOMENTS",& - error=error) + basis_section=input,print_key_path="DFT%PRINT%MOMENTS") END IF CALL timestop(handle) @@ -1479,16 +1445,13 @@ END SUBROUTINE qs_scf_post_moments !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives !> \param output_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_xray(input,dft_section,logger,qs_env,output_unit,error) + SUBROUTINE qs_scf_post_xray(input,dft_section,logger,qs_env,output_unit) TYPE(section_vals_type), POINTER :: input, dft_section TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_scf_post_xray', & routineP = moduleN//':'//routineN @@ -1501,20 +1464,17 @@ SUBROUTINE qs_scf_post_xray(input,dft_section,logger,qs_env,output_unit,error) CALL timeset(routineN,handle) print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%XRAY_DIFFRACTION_SPECTRUM",& - error=error) + subsection_name="DFT%PRINT%XRAY_DIFFRACTION_SPECTRUM") - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN q_max = section_get_rval(section_vals=dft_section,& - keyword_name="PRINT%XRAY_DIFFRACTION_SPECTRUM%Q_MAX",& - error=error) + keyword_name="PRINT%XRAY_DIFFRACTION_SPECTRUM%Q_MAX") unit_nr = cp_print_key_unit_nr(logger=logger,& basis_section=input,& print_key_path="DFT%PRINT%XRAY_DIFFRACTION_SPECTRUM",& extension=".dat",& middle_name="xrd",& - log_filename=.FALSE.,& - error=error) + log_filename=.FALSE.) IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,/,T2,A)")& @@ -1527,13 +1487,11 @@ SUBROUTINE qs_scf_post_xray(input,dft_section,logger,qs_env,output_unit,error) END IF CALL xray_diffraction_spectrum(qs_env=qs_env,& unit_number=unit_nr,& - q_max=q_max,& - error=error) + q_max=q_max) CALL cp_print_key_finished_output(unit_nr=unit_nr,& logger=logger,& basis_section=input,& - print_key_path="DFT%PRINT%XRAY_DIFFRACTION_SPECTRUM",& - error=error) + print_key_path="DFT%PRINT%XRAY_DIFFRACTION_SPECTRUM") END IF CALL timestop(handle) @@ -1545,14 +1503,11 @@ END SUBROUTINE qs_scf_post_xray !> \param input ... !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_efg(input, logger, qs_env, error) + SUBROUTINE qs_scf_post_efg(input, logger, qs_env) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_efg', & routineP = moduleN//':'//routineN @@ -1563,11 +1518,10 @@ SUBROUTINE qs_scf_post_efg(input, logger, qs_env, error) CALL timeset(routineN,handle) print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%ELECTRIC_FIELD_GRADIENT",& - error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),& + subsection_name="DFT%PRINT%ELECTRIC_FIELD_GRADIENT") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),& cp_p_file)) THEN - CALL qs_efg_calc(qs_env=qs_env,error=error) + CALL qs_efg_calc(qs_env=qs_env) END IF CALL timestop(handle) @@ -1579,14 +1533,11 @@ END SUBROUTINE qs_scf_post_efg !> \param input ... !> \param qs_env the qs_env in which the qs_env lives !> \param dft_control ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_et(input, qs_env, dft_control, error) + SUBROUTINE qs_scf_post_et(input, qs_env, dft_control) TYPE(section_vals_type), POINTER :: input TYPE(qs_environment_type), POINTER :: qs_env TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_et', & routineP = moduleN//':'//routineN @@ -1601,26 +1552,24 @@ SUBROUTINE qs_scf_post_et(input, qs_env, dft_control, error) failure=.FALSE. do_et=.FALSE. - et_section => section_vals_get_subs_vals(input,"PROPERTIES%ET_COUPLING",& - error=error) - CALL section_vals_get(et_section,explicit=do_et,error=error) + et_section => section_vals_get_subs_vals(input,"PROPERTIES%ET_COUPLING") + CALL section_vals_get(et_section,explicit=do_et) IF(do_et)THEN IF(qs_env%et_coupling%first_run)THEN NULLIFY(my_mos) ALLOCATE(my_mos(dft_control%nspins),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(qs_env%et_coupling%et_mo_coeff(dft_control%nspins),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO ispin =1,dft_control%nspins NULLIFY(my_mos(ispin)%matrix) CALL cp_fm_create(matrix=my_mos(ispin)%matrix,& matrix_struct=qs_env%mos(ispin)%mo_set%mo_coeff%matrix_struct,& - name="FIRST_RUN_COEFF"//TRIM(ADJUSTL(cp_to_string(ispin)))//"MATRIX",& - error=error) + name="FIRST_RUN_COEFF"//TRIM(ADJUSTL(cp_to_string(ispin)))//"MATRIX") CALL cp_fm_to_fm(qs_env%mos(ispin)%mo_set%mo_coeff,& - my_mos(ispin)%matrix,error=error) + my_mos(ispin)%matrix) END DO - CALL set_et_coupling_type(qs_env%et_coupling,et_mo_coeff=my_mos,error=error) + CALL set_et_coupling_type(qs_env%et_coupling,et_mo_coeff=my_mos) DEALLOCATE(my_mos) END IF END IF @@ -1635,15 +1584,13 @@ END SUBROUTINE qs_scf_post_et !> \param input ... !> \param logger ... !> \param qs_env ... -!> \param error ... !> \par History !> 2012-07 Created [MI] ! ***************************************************************************** - SUBROUTINE qs_scf_post_elf(input, logger, qs_env, error) + SUBROUTINE qs_scf_post_elf(input, logger, qs_env) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_elf', & routineP = moduleN//':'//routineN @@ -1669,36 +1616,36 @@ SUBROUTINE qs_scf_post_elf(input, logger, qs_env, error) output_unit= cp_logger_get_default_io_unit(logger) do_elf=.FALSE. - elf_section => section_vals_get_subs_vals(input,"DFT%PRINT%ELF_CUBE",error=error) - CALL section_vals_get(elf_section,explicit=do_elf,error=error) + elf_section => section_vals_get_subs_vals(input,"DFT%PRINT%ELF_CUBE") + CALL section_vals_get(elf_section,explicit=do_elf) IF(do_elf)THEN NULLIFY(dft_control, pw_env, auxbas_pw_pool, pw_pools, particles, subsys, elf_r) - CALL get_qs_env(qs_env,dft_control=dft_control, pw_env=pw_env, subsys=subsys, error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + CALL get_qs_env(qs_env,dft_control=dft_control, pw_env=pw_env, subsys=subsys) + CALL qs_subsys_get(subsys,particles=particles) gapw=dft_control%qs_control%gapw IF(.NOT. gapw) THEN ! allocate ALLOCATE(elf_r(dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) DO ispin = 1,dft_control%nspins CALL pw_pool_create_pw(auxbas_pw_pool,elf_r(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(elf_r(ispin)%pw, error=error) + in_space = REALSPACE) + CALL pw_zero(elf_r(ispin)%pw) END DO IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T15,A,/)")& " ----- ELF is computed on the real space grid -----" END IF - rho_cutoff=section_get_rval(elf_section,"density_cutoff",error=error) - CALL qs_elf_calc(qs_env, elf_r, rho_cutoff, error=error) + rho_cutoff=section_get_rval(elf_section,"density_cutoff") + CALL qs_elf_calc(qs_env, elf_r, rho_cutoff) ! write ELF into cube file - append_cube = section_get_lval(elf_section,"APPEND",error=error) + append_cube = section_get_lval(elf_section,"APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" @@ -1708,7 +1655,7 @@ SUBROUTINE qs_scf_post_elf(input, logger, qs_env, error) WRITE(filename,'(a5,I1.1)')"ELF_S",ispin WRITE(title,*) "ELF spin ", ispin unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%ELF_CUBE",extension=".cube",& - middle_name=TRIM(filename),file_position=my_pos_cube,log_filename=.FALSE.,error=error) + middle_name=TRIM(filename),file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& @@ -1717,22 +1664,21 @@ SUBROUTINE qs_scf_post_elf(input, logger, qs_env, error) END IF CALL cp_pw_to_cube(elf_r(ispin)%pw,unit_nr,title,particles=particles,& - stride=section_get_ivals(elf_section,"STRIDE",error=error),& - error=error) - CALL cp_print_key_finished_output(unit_nr,logger,input,"DFT%PRINT%ELF_CUBE",error=error) + stride=section_get_ivals(elf_section,"STRIDE")) + CALL cp_print_key_finished_output(unit_nr,logger,input,"DFT%PRINT%ELF_CUBE") - CALL pw_pool_give_back_pw(auxbas_pw_pool,elf_r(ispin)%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,elf_r(ispin)%pw) END DO ! deallocate DEALLOCATE(elf_r,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE ! not implemented CALL cp_unimplemented_error(fromWhere=routineP, & message="ELF not implemented for GAPW calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF @@ -1747,14 +1693,12 @@ END SUBROUTINE qs_scf_post_elf !> \param qs_env ... !> \param elf_r ... !> \param rho_cutoff ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE qs_elf_calc(qs_env, elf_r, rho_cutoff, error) + SUBROUTINE qs_elf_calc(qs_env, elf_r, rho_cutoff) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_p_type), DIMENSION(:), POINTER :: elf_r REAL(kind=dp), INTENT(IN) :: rho_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_elf_calc', & routineP = moduleN//':'//routineN @@ -1793,7 +1737,7 @@ SUBROUTINE qs_elf_calc(qs_env, elf_r, rho_cutoff, error) NULLIFY(rho_struct,rho_r, drho_g, drho_r, tau_r, tau_g, pw_env, auxbas_pw_pool, pw_pools,tmp_g, ks_env ) NULLIFY(rho_struct_ao,rho_struct_r,tau_struct_r,drho_struct_r) - CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=pw_env, rho=rho_struct, error=error) + CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=pw_env, rho=rho_struct) CALL qs_rho_get(rho_struct,& rho_ao_kp=rho_struct_ao,& @@ -1801,25 +1745,24 @@ SUBROUTINE qs_elf_calc(qs_env, elf_r, rho_cutoff, error) tau_r=tau_struct_r,& drho_r=drho_struct_r,& tau_r_valid=tau_r_valid,& - drho_r_valid=drho_r_valid,& - error=error) + drho_r_valid=drho_r_valid) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) nspin = SIZE(rho_struct_r) bo = rho_struct_r(1)%pw%pw_grid%bounds_local cfermi = (3.0_dp/10.0_dp)*(pi*pi*3.0_dp)**f23 ALLOCATE(rho_r(nspin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tau_r(nspin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tau_g(nspin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(drho_r(3*nspin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(drho_g(3*nspin),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspin rho_r(ispin)%pw => rho_struct_r(ispin)%pw @@ -1827,16 +1770,16 @@ SUBROUTINE qs_elf_calc(qs_env, elf_r, rho_cutoff, error) tau_r(ispin)%pw => tau_struct_r(ispin)%pw ELSE CALL pw_pool_create_pw(auxbas_pw_pool,tau_r(ispin)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,tau_g(ispin)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) rho_ao => rho_struct_ao(ispin,:) CALL calculate_rho_elec(matrix_p_kp=rho_ao,& rho=tau_r(ispin),& rho_gspace=tau_g(ispin),& total_rho=dum, & ks_env=ks_env, soft_valid=.FALSE., & - compute_tau=.TRUE., error=error) + compute_tau=.TRUE.) END IF IF(drho_r_valid) THEN @@ -1849,31 +1792,31 @@ SUBROUTINE qs_elf_calc(qs_env, elf_r, rho_cutoff, error) IF(deriv_pw) THEN nd = RESHAPE ((/1,0,0,0,1,0,0,0,1/),(/3,3/)) CALL pw_pool_create_pw(auxbas_pw_pool,tmp_g,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) udvol = 1.0_dp/rho_struct_r(ispin)%pw%pw_grid%dvol DO idir = 1,3 CALL pw_pool_create_pw(auxbas_pw_pool,drho_r(3*(ispin-1)+idir)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_transfer ( rho_struct_r(ispin)%pw, tmp_g , error=error) - CALL pw_derive ( tmp_g, nd(:,idir) , error=error) - CALL pw_transfer (tmp_g, drho_r(3*(ispin-1)+idir)%pw , error=error) -! CALL pw_scale(drho_r(3*(ispin-1)+idir)%pw,udvol,error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_transfer ( rho_struct_r(ispin)%pw, tmp_g) + CALL pw_derive ( tmp_g, nd(:,idir)) + CALL pw_transfer (tmp_g, drho_r(3*(ispin-1)+idir)%pw) +! CALL pw_scale(drho_r(3*(ispin-1)+idir)%pw,udvol) END DO ELSE DO idir = 1,3 CALL pw_pool_create_pw(auxbas_pw_pool,drho_r(3*(ispin-1)+idir)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) + use_data=REALDATA3D,in_space=REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,drho_g(3*(ispin-1)+idir)%pw,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) rho_ao => rho_struct_ao(ispin,:) CALL calculate_rho_elec(matrix_p_kp=rho_ao,& rho=drho_r(3*(ispin-1)+idir),& rho_gspace=drho_g(3*(ispin-1)+idir),& total_rho=dum, & ks_env=ks_env, soft_valid=.FALSE., & - compute_tau=.FALSE., compute_grad=.TRUE., idir =idir, error=error) + compute_tau=.FALSE., compute_grad=.TRUE., idir =idir) END DO END IF @@ -1899,34 +1842,34 @@ SUBROUTINE qs_elf_calc(qs_env, elf_r, rho_cutoff, error) END DO IF (.NOT. tau_r_valid) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,tau_r(ispin)%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,tau_g(ispin)%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,tau_r(ispin)%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,tau_g(ispin)%pw) END IF IF (.NOT. drho_r_valid) THEN IF(deriv_pw) THEN - CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g) DO idir = 1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_r(3*(ispin-1)+idir)%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_r(3*(ispin-1)+idir)%pw) END DO ELSE DO idir = 1,3 - CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_r(3*(ispin-1)+idir)%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_g(3*(ispin-1)+idir)%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_r(3*(ispin-1)+idir)%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,drho_g(3*(ispin-1)+idir)%pw) END DO END IF END IF END DO !ispin DEALLOCATE(rho_r,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tau_r,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tau_g,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(drho_r,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(drho_g,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1939,16 +1882,13 @@ END SUBROUTINE qs_elf_calc !> \param input ... !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 2007-07 Created [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE qs_scf_post_molopt(input, logger, qs_env, error) + SUBROUTINE qs_scf_post_molopt(input, logger, qs_env) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_molopt', & routineP = moduleN//':'//routineN @@ -1968,35 +1908,34 @@ SUBROUTINE qs_scf_post_molopt(input, logger, qs_env, error) CALL timeset(routineN,handle) print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%BASIS_MOLOPT_QUANTITIES",& - error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),& + subsection_name="DFT%PRINT%BASIS_MOLOPT_QUANTITIES") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),& cp_p_file)) THEN - CALL get_qs_env(qs_env,energy=energy,matrix_s=matrix_s,mos=mos,error=error) + CALL get_qs_env(qs_env,energy=energy,matrix_s=matrix_s,mos=mos) ! set up the two needed full matrices, using mo_coeff as a template CALL get_mo_set(mo_set=mos(1)%mo_set,mo_coeff=mo_coeff,nao=nao) CALL cp_fm_struct_create(fmstruct=ao_ao_fmstruct,& nrow_global=nao, ncol_global=nao,& - template_fmstruct=mo_coeff%matrix_struct, error=error) + template_fmstruct=mo_coeff%matrix_struct) CALL cp_fm_create(fm_s, matrix_struct=ao_ao_fmstruct,& - name="fm_s", error=error) + name="fm_s") CALL cp_fm_create(fm_work, matrix_struct=ao_ao_fmstruct,& - name="fm_work", error=error) - CALL cp_fm_struct_release(ao_ao_fmstruct,error=error) + name="fm_work") + CALL cp_fm_struct_release(ao_ao_fmstruct) ALLOCATE(eigenvalues(nao)) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,fm_s,error=error) - CALL choose_eigv_solver(fm_s,fm_work,eigenvalues,error=error) + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix,fm_s) + CALL choose_eigv_solver(fm_s,fm_work,eigenvalues) - CALL cp_fm_release(fm_s,error=error) - CALL cp_fm_release(fm_work,error=error) + CALL cp_fm_release(fm_s) + CALL cp_fm_release(fm_work) S_cond_number=MAXVAL(ABS(eigenvalues))/MAX(MINVAL(ABS(eigenvalues)),EPSILON(0.0_dp)) unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%BASIS_MOLOPT_QUANTITIES",& - extension=".molopt",error=error) + extension=".molopt") IF (unit_nr>0) THEN ! please keep this format fixed, needs to be grepable for molopt @@ -2006,7 +1945,7 @@ SUBROUTINE qs_scf_post_molopt(input, logger, qs_env, error) ENDIF CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%BASIS_MOLOPT_QUANTITIES",error=error) + "DFT%PRINT%BASIS_MOLOPT_QUANTITIES") END IF @@ -2019,14 +1958,11 @@ END SUBROUTINE qs_scf_post_molopt !> \param input ... !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_epr(input, logger, qs_env, error) + SUBROUTINE qs_scf_post_epr(input, logger, qs_env) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_epr', & routineP = moduleN//':'//routineN @@ -2037,11 +1973,10 @@ SUBROUTINE qs_scf_post_epr(input, logger, qs_env, error) CALL timeset(routineN,handle) print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%HYPERFINE_COUPLING_TENSOR",& - error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),& + subsection_name="DFT%PRINT%HYPERFINE_COUPLING_TENSOR") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),& cp_p_file)) THEN - CALL qs_epr_hyp_calc(qs_env=qs_env,error=error) + CALL qs_epr_hyp_calc(qs_env=qs_env) END IF CALL timestop(handle) @@ -2054,13 +1989,10 @@ END SUBROUTINE qs_scf_post_epr !> the linear scaling code) !> \param qs_env the qs_env in which the qs_env lives !> \param scf_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE write_available_results(qs_env,scf_env,error) + SUBROUTINE write_available_results(qs_env,scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), OPTIONAL, POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_available_results', & routineP = moduleN//':'//routineN @@ -2070,10 +2002,10 @@ SUBROUTINE write_available_results(qs_env,scf_env,error) CALL timeset(routineN,handle) ! those properties that require MOs (not suitable density matrix based methods) - CALL write_mo_dependent_results(qs_env,scf_env,error) + CALL write_mo_dependent_results(qs_env,scf_env) ! those that depend only on the density matrix, they should be linear scaling in their implementation - CALL write_mo_free_results(qs_env,error) + CALL write_mo_free_results(qs_env) CALL timestop(handle) @@ -2085,13 +2017,10 @@ END SUBROUTINE write_available_results !> provide MO's !> \param qs_env the qs_env in which the qs_env lives !> \param scf_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE write_mo_dependent_results(qs_env,scf_env,error) + SUBROUTINE write_mo_dependent_results(qs_env,scf_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), OPTIONAL, POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_mo_dependent_results', & routineP = moduleN//':'//routineN @@ -2141,10 +2070,10 @@ SUBROUTINE write_mo_dependent_results(qs_env,scf_env,error) particle_set, rho, ks_rmpv, matrix_s, scf_control, dft_section, & molecule_set, input, particles, subsys, rho_r) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& dft_control=dft_control,& molecule_set=molecule_set, & @@ -2155,49 +2084,46 @@ SUBROUTINE write_mo_dependent_results(qs_env,scf_env,error) scf_control=scf_control,& input=input,& cell=cell,& - subsys=subsys,& - error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) - CALL get_qs_env(qs_env,rho=rho,error=error) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + subsys=subsys) + CALL qs_subsys_get(subsys,particles=particles) + CALL get_qs_env(qs_env,rho=rho) + CALL qs_rho_get(rho, rho_r=rho_r) ! kpoints - CALL get_qs_env(qs_env,do_kpoints=do_kpoints,error=error) + CALL get_qs_env(qs_env,do_kpoints=do_kpoints) ! *** if the dft_section tells you to do so, write last wavefunction to screen - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") IF(.NOT.qs_env%run_rtp)THEN IF(.NOT.do_kpoints) THEN - CALL get_qs_env(qs_env,mos=mos,error=error) + CALL get_qs_env(qs_env,mos=mos) IF (dft_control%nspins == 2) THEN CALL write_mo_set(mos(1)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,spin="ALPHA",last=.TRUE.,error=error) + dft_section,spin="ALPHA",last=.TRUE.) CALL write_mo_set(mos(2)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,spin="BETA",last=.TRUE.,error=error) + dft_section,spin="BETA",last=.TRUE.) ELSE CALL write_mo_set(mos(1)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,last=.TRUE.,error=error) + dft_section,last=.TRUE.) END IF END IF ! *** at the end of scf print out the projected dos per kind - IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%PDOS",& - error=error),cp_p_file) ) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%PDOS")& + ,cp_p_file) ) THEN IF(do_kpoints) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Projected density of states not implemented for k-points.", & - error=error,error_level=cp_warning_level) + error_level=cp_warning_level) ELSE CALL get_qs_env(qs_env,& mos=mos,& - matrix_ks=ks_rmpv,& - error=error) + matrix_ks=ks_rmpv) DO ispin = 1,dft_control%nspins ! ** If we do ADMM, we add have to modify the kohn-sham matrix IF( dft_control%do_admm ) THEN - CALL admm_correct_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix, & - error) + CALL admm_correct_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix) END IF IF(PRESENT(scf_env))THEN IF (scf_env%method == ot_method_nr) THEN @@ -2211,23 +2137,22 @@ SUBROUTINE write_mo_dependent_results(qs_env,scf_env,error) CALL calculate_subspace_eigenvalues(mo_coeff,ks_rmpv(ispin)%matrix,mo_eigenvalues, & do_rotation=.TRUE.,& - co_rotate_dbcsr=mo_coeff_deriv,error=error) - CALL set_mo_occupation(mo_set=mos(ispin)%mo_set,error=error) + co_rotate_dbcsr=mo_coeff_deriv) + CALL set_mo_occupation(mo_set=mos(ispin)%mo_set) END IF END IF IF(dft_control%nspins==2) THEN CALL calculate_projected_dos(mos(ispin)%mo_set,atomic_kind_set,& - qs_kind_set,particle_set,qs_env, dft_section,ispin=ispin,error=error) + qs_kind_set,particle_set,qs_env, dft_section,ispin=ispin) ELSE CALL calculate_projected_dos(mos(ispin)%mo_set,atomic_kind_set,& - qs_kind_set,particle_set,qs_env,dft_section,error=error) + qs_kind_set,particle_set,qs_env,dft_section) END IF ! ** If we do ADMM, we add have to modify the kohn-sham matrix IF( dft_control%do_admm ) THEN - CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix, & - error) + CALL admm_uncorrect_for_eigenvalues(ispin, admm_env, ks_rmpv(ispin)%matrix) END IF END DO @@ -2237,19 +2162,19 @@ SUBROUTINE write_mo_dependent_results(qs_env,scf_env,error) ! *** Integrated absolute spin density and spin contamination *** IF (dft_control%nspins.eq.2) THEN - CALL get_qs_env(qs_env,mos=mos,error=error) - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) + CALL get_qs_env(qs_env,mos=mos) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_copy(rho_r(1)%pw,wf_r%pw, error=error) - CALL pw_axpy(rho_r(2)%pw,wf_r%pw,alpha=-1._dp, error=error) - total_abs_spin_dens=pw_integrate_function(wf_r%pw,oprt="ABS", error=error) + in_space = REALSPACE) + CALL pw_copy(rho_r(1)%pw,wf_r%pw) + CALL pw_axpy(rho_r(2)%pw,wf_r%pw,alpha=-1._dp) + total_abs_spin_dens=pw_integrate_function(wf_r%pw,oprt="ABS") IF (output_unit > 0) WRITE(UNIT=output_unit,FMT='(/,(T3,A,T61,F20.10))')& "Integrated absolute spin density : ",total_abs_spin_dens - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) ! ! XXX Fix Me XXX ! should be extended to the case where added MOs are present @@ -2258,7 +2183,7 @@ SUBROUTINE write_mo_dependent_results(qs_env,scf_env,error) IF(do_kpoints) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Spin contamination estimate not implemented for k-points.", & - error=error,error_level=cp_warning_level) + error_level=cp_warning_level) ELSE all_equal = .TRUE. DO ispin=1,dft_control%nspins @@ -2279,9 +2204,9 @@ SUBROUTINE write_mo_dependent_results(qs_env,scf_env,error) ELSE CALL get_qs_env(qs_env=qs_env,& matrix_s=matrix_s,& - energy=energy,error=error) + energy=energy) CALL compute_s_square(mos=mos, matrix_s=matrix_s, s_square=s_square,& - s_square_ideal=s_square_ideal,error=error) + s_square_ideal=s_square_ideal) IF (output_unit > 0) WRITE (UNIT=output_unit,FMT='(T3,A,T51,2F15.6)')& "Ideal and single determinant S**2 : ",s_square_ideal,s_square energy%s_square=s_square @@ -2298,12 +2223,9 @@ END SUBROUTINE write_mo_dependent_results !> \brief Write QS results always available (if switched on through the print_keys) !> Can be called from ls_scf !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE write_mo_free_results(qs_env,error) + SUBROUTINE write_mo_free_results(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_mo_free_results', & routineP = moduleN//':'//routineN @@ -2372,10 +2294,10 @@ SUBROUTINE write_mo_free_results(qs_env,error) atomic_kind_set, qs_kind_set, particle_set, rho, ks_rmpv, rho_ao, rho_r,& dft_section, xc_section, input, particles, subsys, matrix_vxc,v_hartree_rspace, vee) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) IF (.NOT. failure) THEN CALL get_qs_env(qs_env,& atomic_kind_set=atomic_kind_set,& @@ -2386,69 +2308,66 @@ SUBROUTINE write_mo_free_results(qs_env,error) dft_control=dft_control, & input=input,& do_kpoints=do_kpoints, & - subsys=subsys,& - error=error) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + subsys=subsys) + dft_section => section_vals_get_subs_vals(input,"DFT") + CALL qs_subsys_get(subsys,particles=particles) ! Print the total density (electronic + core charge) - CALL get_qs_env(qs_env,rho=rho,error=error) - CALL qs_rho_get(rho,rho_r=rho_r,error=error) + CALL get_qs_env(qs_env,rho=rho) + CALL qs_rho_get(rho,rho_r=rho_r) IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%TOT_DENSITY_CUBE", error=error),cp_p_file)) THEN + "DFT%PRINT%TOT_DENSITY_CUBE"),cp_p_file)) THEN NULLIFY(rho_core,rho0_s_gs) - append_cube = section_get_lval(input,"DFT%PRINT%TOT_DENSITY_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%TOT_DENSITY_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,rho_core=rho_core,& - rho0_s_gs=rho0_s_gs,error=error) + rho0_s_gs=rho0_s_gs) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) IF (dft_control%qs_control%gapw) THEN - CALL pw_transfer(rho0_s_gs%pw,wf_r%pw,error=error) + CALL pw_transfer(rho0_s_gs%pw,wf_r%pw) IF(dft_control%qs_control%gapw_control%nopaw_as_gpw) THEN - CALL pw_axpy(rho_core%pw,wf_r%pw, error=error) + CALL pw_axpy(rho_core%pw,wf_r%pw) END IF ELSE - CALL pw_transfer(rho_core%pw,wf_r%pw,error=error) + CALL pw_transfer(rho_core%pw,wf_r%pw) END IF DO ispin=1,dft_control%nspins - CALL pw_axpy(rho_r(ispin)%pw,wf_r%pw, error=error) + CALL pw_axpy(rho_r(ispin)%pw,wf_r%pw) END DO filename = "TOTAL_DENSITY" unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%TOT_DENSITY_CUBE",& extension=".cube",middle_name=TRIM(filename),file_position=my_pos_cube,& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) CALL cp_pw_to_cube(wf_r%pw,unit_nr,"TOTAL DENSITY",& particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%TOT_DENSITY_CUBE%STRIDE",error=error),& - error=error) + stride=section_get_ivals(dft_section,"PRINT%TOT_DENSITY_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%TOT_DENSITY_CUBE",error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw, error=error) + "DFT%PRINT%TOT_DENSITY_CUBE") + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) END IF ! Write cube file with electron density IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%E_DENSITY_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%E_DENSITY_CUBE"),cp_p_file)) THEN CALL section_vals_val_get(dft_section,& keyword_name="PRINT%E_DENSITY_CUBE%TOTAL_DENSITY",& - l_val=print_total_density,& - error=error) - append_cube = section_get_lval(input,"DFT%PRINT%E_DENSITY_CUBE%APPEND",error=error) + l_val=print_total_density) + append_cube = section_get_lval(input,"DFT%PRINT%E_DENSITY_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF ! Write the info on core densities for the interface between cp2k and the XRD code ! together with the valence density they are used to compute the form factor (Fourier transform) - xrd_interface = section_get_lval(input,"DFT%PRINT%E_DENSITY_CUBE%XRD_INTERFACE",error=error) + xrd_interface = section_get_lval(input,"DFT%PRINT%E_DENSITY_CUBE%XRD_INTERFACE") IF(xrd_interface) THEN !cube file only contains soft density (GAPW) IF(dft_control%qs_control%gapw) print_total_density = .FALSE. @@ -2456,8 +2375,8 @@ SUBROUTINE write_mo_free_results(qs_env,error) filename = "ELECTRON_DENSITY" unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%E_DENSITY_CUBE",& extension=".xrd",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,error=error) - ngto = section_get_ival(input,"DFT%PRINT%E_DENSITY_CUBE%NGAUSS",error=error) + file_position=my_pos_cube,log_filename=.FALSE.) + ngto = section_get_ival(input,"DFT%PRINT%E_DENSITY_CUBE%NGAUSS") IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& @@ -2465,7 +2384,7 @@ SUBROUTINE write_mo_free_results(qs_env,error) TRIM(filename) END IF - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") nkind = SIZE(atomic_kind_set) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Atomic (core) densities" @@ -2478,19 +2397,19 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF ! calculate atomic density and core density ALLOCATE(ppdens(ngto,2,nkind),aedens(ngto,2,nkind),ccdens(ngto,2,nkind),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind atomic_kind => atomic_kind_set(ikind) qs_kind => qs_kind_set(ikind) CALL get_atomic_kind(atomic_kind,name=name,element_symbol=element_symbol) CALL calculate_atomic_density(ppdens(:,:,ikind),atomic_kind,qs_kind, ngto,& - iunit=output_unit, confine=.TRUE.,error=error) + iunit=output_unit, confine=.TRUE.) CALL calculate_atomic_density(aedens(:,:,ikind),atomic_kind,qs_kind, ngto,& - iunit=output_unit,allelectron=.TRUE.,confine=.TRUE.,error=error) + iunit=output_unit,allelectron=.TRUE.,confine=.TRUE.) ccdens(:,1,ikind) = aedens(:,1,ikind) ccdens(:,2,ikind) = 0._dp CALL project_function_a(ccdens(1:ngto,2,ikind),ccdens(1:ngto,1,ikind),& - ppdens(1:ngto,2,ikind),ppdens(1:ngto,1,ikind),0,error) + ppdens(1:ngto,2,ikind),ppdens(1:ngto,1,ikind),0) ccdens(:,2,ikind) = aedens(:,2,ikind) - ccdens(:,2,ikind) IF (unit_nr>0) THEN WRITE(unit_nr,FMT="(I6,A10,A20)") ikind,TRIM(element_symbol),TRIM(name) @@ -2504,7 +2423,7 @@ SUBROUTINE write_mo_free_results(qs_env,error) END DO IF (dft_control%qs_control%gapw) THEN - CALL get_qs_env(qs_env=qs_env,rho_atom_set=rho_atom_set,error=error) + CALL get_qs_env(qs_env=qs_env,rho_atom_set=rho_atom_set) IF (unit_nr>0) THEN WRITE(unit_nr,*) "Coordinates and GAPW density" @@ -2512,7 +2431,7 @@ SUBROUTINE write_mo_free_results(qs_env,error) np = particles%n_els DO iat=1,np CALL get_atomic_kind(particles%els(iat)%atomic_kind,kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), grid_atom=grid_atom, error=error) + CALL get_qs_kind(qs_kind_set(ikind), grid_atom=grid_atom) rho_atom => rho_atom_set(iat) IF(ASSOCIATED(rho_atom%rho_rad_h(1)%r_coef)) THEN nr = SIZE(rho_atom%rho_rad_h(1)%r_coef,1) @@ -2525,7 +2444,7 @@ SUBROUTINE write_mo_free_results(qs_env,error) CALL mp_sum(niso,para_env%group) ALLOCATE(bfun(nr,niso),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) bfun = 0._dp DO ispin = 1,dft_control%nspins IF(ASSOCIATED(rho_atom%rho_rad_h(1)%r_coef)) THEN @@ -2540,14 +2459,14 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF DO iso=1,niso l = indso(1,iso) - CALL project_function_b(ccdens(:,2,ikind),ccdens(:,1,ikind),bfun(:,iso),grid_atom,l,error) + CALL project_function_b(ccdens(:,2,ikind),ccdens(:,1,ikind),bfun(:,iso),grid_atom,l) IF (unit_nr>0) THEN WRITE(unit_nr,FMT="(3I6)") iso,l,ngto WRITE(unit_nr,FMT="(2G24.12)") (ccdens(i,1,ikind),ccdens(i,2,ikind),i=1,ngto) END IF END DO DEALLOCATE(bfun,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO ELSE IF (unit_nr>0) THEN @@ -2561,58 +2480,50 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF DEALLOCATE(ppdens,aedens,ccdens,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%E_DENSITY_CUBE",& - error=error) + "DFT%PRINT%E_DENSITY_CUBE") END IF IF (dft_control%qs_control%gapw.AND.print_total_density) THEN ! total density in g-space not implemented for k-points - CPPrecondition(.NOT.do_kpoints,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.do_kpoints,cp_failure_level,routineP,failure) ! Print total electronic density CALL get_qs_env(qs_env=qs_env,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) CALL pw_env_get(pw_env=pw_env,& auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,& - error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=rho_elec_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_zero(rho_elec_rspace%pw,error=error) + in_space=REALSPACE) + CALL pw_zero(rho_elec_rspace%pw) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=rho_elec_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(rho_elec_gspace%pw,error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero(rho_elec_gspace%pw) CALL get_pw_grid_info(pw_grid=rho_elec_gspace%pw%pw_grid,& dr=dr,& - vol=volume,& - error=error) + vol=volume) q_max = SQRT(SUM((pi/dr(:))**2)) CALL calculate_rhotot_elec_gspace(qs_env=qs_env,& auxbas_pw_pool=auxbas_pw_pool,& rhotot_elec_gspace=rho_elec_gspace,& q_max=q_max,& rho_hard=rho_hard,& - rho_soft=rho_soft,& - error=error) + rho_soft=rho_soft) rho_total = rho_hard + rho_soft CALL get_pw_grid_info(pw_grid=rho_elec_gspace%pw%pw_grid,& - vol=volume,& - error=error) - CALL pw_transfer(rho_elec_gspace%pw,rho_elec_rspace%pw,debug=.FALSE.,error=error) - rho_total_rspace = pw_integrate_function(rho_elec_rspace%pw,isign=-1,error=error)/volume + vol=volume) + CALL pw_transfer(rho_elec_gspace%pw,rho_elec_rspace%pw,debug=.FALSE.) + rho_total_rspace = pw_integrate_function(rho_elec_rspace%pw,isign=-1)/volume filename = "TOTAL_ELECTRON_DENSITY" unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%E_DENSITY_CUBE",& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& @@ -2627,30 +2538,27 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF CALL cp_pw_to_cube(rho_elec_rspace%pw,unit_nr,"TOTAL ELECTRON DENSITY",& particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE",error=error),& - error=error) + stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%E_DENSITY_CUBE",& - error=error) + "DFT%PRINT%E_DENSITY_CUBE") ! Print total spin density for spin-polarized systems IF (dft_control%nspins > 1) THEN - CALL pw_zero(rho_elec_gspace%pw,error=error) - CALL pw_zero(rho_elec_rspace%pw,error=error) + CALL pw_zero(rho_elec_gspace%pw) + CALL pw_zero(rho_elec_rspace%pw) CALL calculate_rhotot_elec_gspace(qs_env=qs_env,& auxbas_pw_pool=auxbas_pw_pool,& rhotot_elec_gspace=rho_elec_gspace,& q_max=q_max,& rho_hard=rho_hard,& rho_soft=rho_soft,& - fsign=-1.0_dp,& - error=error) + fsign=-1.0_dp) rho_total = rho_hard + rho_soft - CALL pw_transfer(rho_elec_gspace%pw,rho_elec_rspace%pw,debug=.FALSE.,error=error) - rho_total_rspace = pw_integrate_function(rho_elec_rspace%pw,isign=-1,error=error)/volume + CALL pw_transfer(rho_elec_gspace%pw,rho_elec_rspace%pw,debug=.FALSE.) + rho_total_rspace = pw_integrate_function(rho_elec_rspace%pw,isign=-1)/volume filename = "TOTAL_SPIN_DENSITY" unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%E_DENSITY_CUBE",& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& @@ -2665,31 +2573,27 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF CALL cp_pw_to_cube(rho_elec_rspace%pw,unit_nr,"TOTAL SPIN DENSITY",& particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE",error=error),& - error=error) + stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE")) END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_elec_gspace%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_elec_rspace%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_elec_gspace%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_elec_rspace%pw) ELSE IF (dft_control%nspins > 1) THEN CALL get_qs_env(qs_env=qs_env,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) CALL pw_env_get(pw_env=pw_env,& auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,& - error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=rho_elec_rspace%pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_copy(rho_r(1)%pw,rho_elec_rspace%pw, error=error) - CALL pw_axpy(rho_r(2)%pw,rho_elec_rspace%pw, error=error) + in_space=REALSPACE) + CALL pw_copy(rho_r(1)%pw,rho_elec_rspace%pw) + CALL pw_axpy(rho_r(2)%pw,rho_elec_rspace%pw) filename = "ELECTRON_DENSITY" unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%E_DENSITY_CUBE",& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& @@ -2697,16 +2601,15 @@ SUBROUTINE write_mo_free_results(qs_env,error) TRIM(filename) END IF CALL cp_pw_to_cube(rho_elec_rspace%pw,unit_nr,"SUM OF ALPHA AND BETA DENSITY",& - particles=particles,stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE",& - error=error),error=error) + particles=particles,stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%E_DENSITY_CUBE",error=error) - CALL pw_copy(rho_r(1)%pw,rho_elec_rspace%pw, error=error) - CALL pw_axpy(rho_r(2)%pw,rho_elec_rspace%pw,alpha=-1.0_dp, error=error) + "DFT%PRINT%E_DENSITY_CUBE") + CALL pw_copy(rho_r(1)%pw,rho_elec_rspace%pw) + CALL pw_axpy(rho_r(2)%pw,rho_elec_rspace%pw,alpha=-1.0_dp) filename = "SPIN_DENSITY" unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%E_DENSITY_CUBE",& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& @@ -2715,17 +2618,15 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF CALL cp_pw_to_cube(rho_elec_rspace%pw,unit_nr,"SPIN DENSITY",& particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE",error=error),& - error=error) + stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%E_DENSITY_CUBE",& - error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_elec_rspace%pw,error=error) + "DFT%PRINT%E_DENSITY_CUBE") + CALL pw_pool_give_back_pw(auxbas_pw_pool,rho_elec_rspace%pw) ELSE filename = "ELECTRON_DENSITY" unit_nr = cp_print_key_unit_nr(logger,input,"DFT%PRINT%E_DENSITY_CUBE",& extension=".cube",middle_name=TRIM(filename),& - file_position=my_pos_cube,log_filename=.FALSE.,error=error) + file_position=my_pos_cube,log_filename=.FALSE.) IF (output_unit>0) THEN INQUIRE (UNIT=unit_nr,NAME=filename) WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T2,A)")& @@ -2734,11 +2635,9 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF CALL cp_pw_to_cube(rho_r(1)%pw,unit_nr,"ELECTRON DENSITY",& particles=particles,& - stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE",error=error),& - error=error) + stride=section_get_ivals(dft_section,"PRINT%E_DENSITY_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%E_DENSITY_CUBE",& - error=error) + "DFT%PRINT%E_DENSITY_CUBE") END IF ! nspins END IF ! total density for GAPW END IF ! print key @@ -2746,180 +2645,176 @@ SUBROUTINE write_mo_free_results(qs_env,error) ! Print the hartree potential IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%V_HARTREE_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%V_HARTREE_CUBE"),cp_p_file)) THEN CALL get_qs_env(qs_env=qs_env,& pw_env=pw_env,& - v_hartree_rspace=v_hartree_rspace,& - error=error) - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, error=error) + v_hartree_rspace=v_hartree_rspace) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,aux_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) - append_cube = section_get_lval(input,"DFT%PRINT%V_HARTREE_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%V_HARTREE_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env, error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env) unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%V_HARTREE_CUBE",& - extension=".cube",middle_name="v_hartree",file_position=my_pos_cube,error=error) + extension=".cube",middle_name="v_hartree",file_position=my_pos_cube) udvol = 1.0_dp/v_hartree_rspace%pw_grid%dvol - CALL pw_copy(v_hartree_rspace,aux_r%pw, error=error) - CALL pw_scale(aux_r%pw,udvol,error=error) + CALL pw_copy(v_hartree_rspace,aux_r%pw) + CALL pw_scale(aux_r%pw,udvol) CALL cp_pw_to_cube(aux_r%pw,unit_nr,"HARTREE POTENTIAL",particles=particles,& stride=section_get_ivals(dft_section,& - "PRINT%V_HARTREE_CUBE%STRIDE",error=error),& - error=error) + "PRINT%V_HARTREE_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%V_HARTREE_CUBE",error=error) + "DFT%PRINT%V_HARTREE_CUBE") - CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw) ENDIF ! Print the external potential IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%EXTERNAL_POTENTIAL_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%EXTERNAL_POTENTIAL_CUBE"),cp_p_file)) THEN IF(dft_control%apply_external_potential)THEN - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,vee=vee,error=error) - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,vee=vee) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,aux_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) - append_cube = section_get_lval(input,"DFT%PRINT%EXTERNAL_POTENTIAL_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%EXTERNAL_POTENTIAL_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF - CALL pw_env_get(pw_env, error=error) + CALL pw_env_get(pw_env) unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%EXTERNAL_POTENTIAL_CUBE",& - extension=".cube",middle_name="ext_pot",file_position=my_pos_cube,error=error) + extension=".cube",middle_name="ext_pot",file_position=my_pos_cube) - CALL pw_copy(vee%pw,aux_r%pw, error=error) + CALL pw_copy(vee%pw,aux_r%pw) CALL cp_pw_to_cube(aux_r%pw,unit_nr,"EXTERNAL POTENTIAL",particles=particles,& stride=section_get_ivals(dft_section,& - "PRINT%EXTERNAL_POTENTIAL_CUBE%STRIDE",error=error),& - error=error) + "PRINT%EXTERNAL_POTENTIAL_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%EXTERNAL_POTENTIAL_CUBE",error=error) + "DFT%PRINT%EXTERNAL_POTENTIAL_CUBE") - CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw) ENDIF ENDIF ! Print the Electrical Field Components IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%EFIELD_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%EFIELD_CUBE"),cp_p_file)) THEN - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) CALL pw_pool_create_pw(auxbas_pw_pool,aux_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,aux_g%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) - append_cube = section_get_lval(input,"DFT%PRINT%EFIELD_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%EFIELD_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,error=error) - CALL pw_env_get(pw_env, error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env) + CALL pw_env_get(pw_env) udvol = 1.0_dp/v_hartree_rspace%pw_grid%dvol DO id=1,3 unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%EFIELD_CUBE",& - extension=".cube",middle_name="efield_"//cdir(id),file_position=my_pos_cube,error=error) + extension=".cube",middle_name="efield_"//cdir(id),file_position=my_pos_cube) - CALL pw_transfer(v_hartree_rspace,aux_g%pw, error=error) + CALL pw_transfer(v_hartree_rspace,aux_g%pw) nd=0 nd(id)=1 - CALL pw_derive(aux_g%pw,nd,error=error) - CALL pw_transfer(aux_g%pw,aux_r%pw, error=error) - CALL pw_scale(aux_r%pw,udvol,error=error) + CALL pw_derive(aux_g%pw,nd) + CALL pw_transfer(aux_g%pw,aux_r%pw) + CALL pw_scale(aux_r%pw,udvol) CALL cp_pw_to_cube(aux_r%pw,& unit_nr,"ELECTRIC FIELD",particles=particles,& stride=section_get_ivals(dft_section,& - "PRINT%EFIELD_CUBE%STRIDE",error=error),& - error=error) + "PRINT%EFIELD_CUBE%STRIDE")) CALL cp_print_key_finished_output(unit_nr,logger,input,& - "DFT%PRINT%EFIELD_CUBE",error=error) + "DFT%PRINT%EFIELD_CUBE") END DO - CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_g%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,aux_g%pw) END IF ! Write the dielectric constant into a cube file do_dielectric_cube = BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%DIELECTRIC_CUBE",error=error),cp_p_file) + "DFT%PRINT%DIELECTRIC_CUBE"),cp_p_file) has_implicit_ps = .FALSE. - CALL get_qs_env(qs_env=qs_env, pw_env=pw_env, error=error) + CALL get_qs_env(qs_env=qs_env, pw_env=pw_env) IF (pw_env%poisson_env%parameters%solver .EQ. pw_poisson_implicit) has_implicit_ps = .TRUE. IF (has_implicit_ps .AND. do_dielectric_cube) THEN - append_cube = section_get_lval(input,"DFT%PRINT%DIELECTRIC_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%DIELECTRIC_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%DIELECTRIC_CUBE",& - extension=".cube", middle_name="DIELCTRIC_CONSTANT", file_position=my_pos_cube, error=error) - CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool, error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, aux_r%pw, use_data=REALDATA3D, in_space=REALSPACE, error=error) + extension=".cube", middle_name="DIELCTRIC_CONSTANT", file_position=my_pos_cube) + CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, aux_r%pw, use_data=REALDATA3D, in_space=REALSPACE) - CALL pw_copy(poisson_env%implicit_env%dielectric%eps, aux_r%pw, error=error) + CALL pw_copy(poisson_env%implicit_env%dielectric%eps, aux_r%pw) CALL cp_pw_to_cube(aux_r%pw, unit_nr, "DIELECTRIC CONSTANT", particles=particles,& - stride=section_get_ivals(dft_section, "PRINT%DIELECTRIC_CUBE%STRIDE", error=error), error=error) - CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIELECTRIC_CUBE", error=error) + stride=section_get_ivals(dft_section, "PRINT%DIELECTRIC_CUBE%STRIDE")) + CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIELECTRIC_CUBE") - CALL pw_pool_give_back_pw(auxbas_pw_pool, aux_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, aux_r%pw) ENDIF ! Write Dirichlet constraint charges into a cube file do_cstr_charge_cube = BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%DIRICHLET_CSTR_CHARGE_CUBE",error=error),cp_p_file) + "DFT%PRINT%DIRICHLET_CSTR_CHARGE_CUBE"),cp_p_file) has_implicit_ps = .FALSE. - CALL get_qs_env(qs_env=qs_env, pw_env=pw_env, error=error) + CALL get_qs_env(qs_env=qs_env, pw_env=pw_env) IF (pw_env%poisson_env%parameters%solver .EQ. pw_poisson_implicit) has_implicit_ps = .TRUE. IF (has_implicit_ps .AND. do_cstr_charge_cube) THEN - append_cube = section_get_lval(input,"DFT%PRINT%DIRICHLET_CSTR_CHARGE_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%DIRICHLET_CSTR_CHARGE_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%DIRICHLET_CSTR_CHARGE_CUBE",& - extension=".cube", middle_name="dirichlet_cstr_charge", file_position=my_pos_cube, error=error) - CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool, error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, aux_r%pw, use_data=REALDATA3D, in_space=REALSPACE, error=error) + extension=".cube", middle_name="dirichlet_cstr_charge", file_position=my_pos_cube) + CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, aux_r%pw, use_data=REALDATA3D, in_space=REALSPACE) - CALL pw_copy(poisson_env%implicit_env%cstr_charge, aux_r%pw, error=error) + CALL pw_copy(poisson_env%implicit_env%cstr_charge, aux_r%pw) CALL cp_pw_to_cube(aux_r%pw, unit_nr, "DIRICHLET CONSTRAINT CHARGE", particles=particles,& - stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_CSTR_CHARGE_CUBE%STRIDE", error=error), error=error) - CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_CSTR_CHARGE_CUBE", error=error) + stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_CSTR_CHARGE_CUBE%STRIDE")) + CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_CSTR_CHARGE_CUBE") - CALL pw_pool_give_back_pw(auxbas_pw_pool, aux_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, aux_r%pw) ENDIF ! Write Dirichlet type constranits into cube files has_implicit_ps = .FALSE. - CALL get_qs_env(qs_env=qs_env, pw_env=pw_env, error=error) + CALL get_qs_env(qs_env=qs_env, pw_env=pw_env) IF (pw_env%poisson_env%parameters%solver .EQ. pw_poisson_implicit) has_implicit_ps = .TRUE. do_dirichlet_bc_cube = BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%DIRICHLET_BC_CUBE",error=error),cp_p_file) + "DFT%PRINT%DIRICHLET_BC_CUBE"),cp_p_file) has_dirichlet_bc = .FALSE. IF (has_implicit_ps) THEN IF ((pw_env%poisson_env%implicit_env%params%boundary_condition .EQ. MIXED_PERIODIC_BC) .OR. & @@ -2929,26 +2824,26 @@ SUBROUTINE write_mo_free_results(qs_env,error) END IF IF (has_implicit_ps .AND. has_dirichlet_bc .AND. do_dirichlet_bc_cube) THEN - append_cube = section_get_lval(input,"DFT%PRINT%DIRICHLET_BC_CUBE%APPEND",error=error) + append_cube = section_get_lval(input,"DFT%PRINT%DIRICHLET_BC_CUBE%APPEND") my_pos_cube="REWIND" IF(append_cube) THEN my_pos_cube="APPEND" END IF - tile_cubes = section_get_lval(input,"DFT%PRINT%DIRICHLET_BC_CUBE%TILE_CUBES",error=error) + tile_cubes = section_get_lval(input,"DFT%PRINT%DIRICHLET_BC_CUBE%TILE_CUBES") - CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool, error=error) - CALL pw_pool_create_pw(auxbas_pw_pool, aux_r%pw, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_zero(aux_r%pw, error=error) + CALL pw_env_get(pw_env, poisson_env=poisson_env, auxbas_pw_pool=auxbas_pw_pool) + CALL pw_pool_create_pw(auxbas_pw_pool, aux_r%pw, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(aux_r%pw) IF (.NOT. tile_cubes) THEN - CALL setup_grid_axes(auxbas_pw_pool%pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, error) + CALL setup_grid_axes(auxbas_pw_pool%pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) NULLIFY(dirichlet_tile) - CALL pw_pool_create_pw(auxbas_pw_pool, dirichlet_tile, use_data=REALDATA3D, in_space=REALSPACE, error=error) - CALL pw_zero(dirichlet_tile, error=error) + CALL pw_pool_create_pw(auxbas_pw_pool, dirichlet_tile, use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(dirichlet_tile) unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%DIRICHLET_BC_CUBE", & - extension=".cube", middle_name="DIRICHLET_CSTR", file_position=my_pos_cube, error=error) + extension=".cube", middle_name="DIRICHLET_CSTR", file_position=my_pos_cube) n_cstr = SIZE(poisson_env%implicit_env%gates) DO j = 1 , n_cstr @@ -2959,28 +2854,27 @@ SUBROUTINE write_mo_free_results(qs_env,error) DO i = 1, n_tiles CALL pw_mollifier(auxbas_pw_pool, zeta, x_glbl, y_glbl, z_glbl, & poisson_env%implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw,& - dirichlet_tile, error) - CALL pw_axpy(dirichlet_tile, aux_r%pw, error=error) + dirichlet_tile) + CALL pw_axpy(dirichlet_tile, aux_r%pw) END DO ELSE DO i = 1, n_tiles tile_npts = poisson_env%implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%npts CALL pw_copy(poisson_env%implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw, & - dirichlet_tile, error=error) - CALL pw_axpy(dirichlet_tile, aux_r%pw, REAL(tile_npts,kind=dp), error=error) + dirichlet_tile) + CALL pw_axpy(dirichlet_tile, aux_r%pw, REAL(tile_npts,kind=dp)) END DO END IF END DO CALL cp_pw_to_cube(aux_r%pw, unit_nr, "DIRICHLET TYPE CONSTRAINT", particles=particles, & - stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_BC_CUBE%STRIDE", error=error), & - error=error) - CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_BC_CUBE", error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool, dirichlet_tile, error=error) + stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_BC_CUBE%STRIDE")) + CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_BC_CUBE") + CALL pw_pool_give_back_pw(auxbas_pw_pool, dirichlet_tile) ELSE - CALL setup_grid_axes(auxbas_pw_pool%pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl, error) + CALL setup_grid_axes(auxbas_pw_pool%pw_grid, x_glbl, y_glbl, z_glbl, x_locl, y_locl, z_locl) n_cstr = SIZE(poisson_env%implicit_env%gates) DO j = 1 , n_cstr @@ -2992,137 +2886,132 @@ SUBROUTINE write_mo_free_results(qs_env,error) filename = "dirichlet_cstr_"//TRIM(ADJUSTL(cp_to_string(j)))//& "_tile_"//TRIM(ADJUSTL(cp_to_string(i))) unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%DIRICHLET_BC_CUBE", & - extension=".cube", middle_name=filename, file_position=my_pos_cube, error=error) + extension=".cube", middle_name=filename, file_position=my_pos_cube) CALL pw_mollifier(auxbas_pw_pool, zeta, x_glbl, y_glbl, z_glbl, & - poisson_env%implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw, aux_r%pw, error) + poisson_env%implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw, aux_r%pw) CALL cp_pw_to_cube(aux_r%pw, unit_nr, "DIRICHLET TYPE CONSTRAINT", particles=particles, & - stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_BC_CUBE%STRIDE", error=error), & - error=error) - CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_BC_CUBE", error=error) + stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_BC_CUBE%STRIDE")) + CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_BC_CUBE") END DO ELSE DO i = 1, n_tiles filename = "dirichlet_cstr_"//TRIM(ADJUSTL(cp_to_string(j)))//& "_tile_"//TRIM(ADJUSTL(cp_to_string(i))) unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%DIRICHLET_BC_CUBE", & - extension=".cube", middle_name=filename, file_position=my_pos_cube, error=error) + extension=".cube", middle_name=filename, file_position=my_pos_cube) tile_npts = poisson_env%implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%npts CALL pw_copy(poisson_env%implicit_env%gates(j)%dirichlet_bc%tiles(i)%tile%tile_pw, & - aux_r%pw, error=error) - CALL pw_scale(aux_r%pw, REAL(tile_npts,kind=dp), error=error) + aux_r%pw) + CALL pw_scale(aux_r%pw, REAL(tile_npts,kind=dp)) CALL cp_pw_to_cube(aux_r%pw, unit_nr, "DIRICHLET TYPE CONSTRAINT", particles=particles, & - stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_BC_CUBE%STRIDE", error=error), & - error=error) - CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_BC_CUBE", error=error) + stride=section_get_ivals(dft_section, "PRINT%DIRICHLET_BC_CUBE%STRIDE")) + CALL cp_print_key_finished_output(unit_nr, logger, input, "DFT%PRINT%DIRICHLET_BC_CUBE") END DO END IF END DO END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool, aux_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, aux_r%pw) ENDIF ! Write the density matrices IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%AO_MATRICES/DENSITY",error=error),cp_p_file)) THEN + "DFT%PRINT%AO_MATRICES/DENSITY"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,input,"DFT%PRINT%AO_MATRICES/DENSITY",& - extension=".Log",error=error) - CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao, error=error) + extension=".Log") + CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao) after = MIN(MAX(after,1),16) DO ispin=1,dft_control%nspins DO img=1,dft_control%nimages CALL cp_dbcsr_write_sparse_matrix(rho_ao(ispin,img)%matrix,4,after,qs_env,& - para_env,output_unit=iw,error=error) + para_env,output_unit=iw) END DO END DO CALL cp_print_key_finished_output(iw,logger,input,& - "DFT%PRINT%AO_MATRICES/DENSITY",& - error=error) + "DFT%PRINT%AO_MATRICES/DENSITY") END IF ! Write the Kohn-Sham matrices write_ks = BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX",error=error),cp_p_file) + "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX"),cp_p_file) write_xc = BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%AO_MATRICES/MATRIX_VXC",error=error),cp_p_file) + "DFT%PRINT%AO_MATRICES/MATRIX_VXC"),cp_p_file) ! we need to update stuff before writing, potentially computing the matrix_vxc IF (write_ks.OR.write_xc) THEN IF (write_xc) qs_env%requires_matrix_vxc = .TRUE. - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.,error=error) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE.,& - just_energy=.FALSE., error=error) + just_energy=.FALSE.) IF (write_xc) qs_env%requires_matrix_vxc = .FALSE. END IF ! Write the Kohn-Sham matrices IF (write_ks) THEN iw = cp_print_key_unit_nr(logger,input,"DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX",& - extension=".Log",error=error) - CALL get_qs_env(qs_env=qs_env, matrix_ks_kp=ks_rmpv, error=error) - CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL get_qs_env(qs_env=qs_env, matrix_ks_kp=ks_rmpv) + CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) DO ispin=1,dft_control%nspins DO img=1,dft_control%nimages CALL cp_dbcsr_write_sparse_matrix(ks_rmpv(ispin,img)%matrix,4,after,qs_env,& - para_env,output_unit=iw,error=error) + para_env,output_unit=iw) END DO END DO CALL cp_print_key_finished_output(iw,logger,input,& - "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX",& - error=error) + "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX") END IF ! Write the xc matrix IF (write_xc) THEN - CALL get_qs_env(qs_env=qs_env, matrix_vxc_kp=matrix_vxc, error=error) - CPPrecondition(ASSOCIATED(matrix_vxc),cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env=qs_env, matrix_vxc_kp=matrix_vxc) + CPPrecondition(ASSOCIATED(matrix_vxc),cp_failure_level,routineP,failure) iw = cp_print_key_unit_nr(logger,input,"DFT%PRINT%AO_MATRICES/MATRIX_VXC",& - extension=".Log",error=error) - CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) DO ispin=1,dft_control%nspins DO img=1,dft_control%nimages CALL cp_dbcsr_write_sparse_matrix(matrix_vxc(ispin,img)%matrix,4,after,qs_env,& - para_env,output_unit=iw,error=error) + para_env,output_unit=iw) END DO END DO CALL cp_print_key_finished_output(iw,logger,input,& - "DFT%PRINT%AO_MATRICES/MATRIX_VXC",& - error=error) + "DFT%PRINT%AO_MATRICES/MATRIX_VXC") END IF ! Compute the Mulliken charges - print_key => section_vals_get_subs_vals(input,"DFT%PRINT%MULLIKEN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%PRINT%MULLIKEN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%MULLIKEN",extension=".mulliken",& - middle_name="",log_filename=.FALSE.,error=error) + middle_name="",log_filename=.FALSE.) print_level = 1 - CALL section_vals_val_get(print_key,"PRINT_GOP",l_val=print_it,error=error) + CALL section_vals_val_get(print_key,"PRINT_GOP",l_val=print_it) IF (print_it) print_level = 2 - CALL section_vals_val_get(print_key,"PRINT_ALL",l_val=print_it,error=error) + CALL section_vals_val_get(print_key,"PRINT_ALL",l_val=print_it) IF (print_it) print_level = 3 - CALL mulliken_population_analysis(qs_env,unit_nr,print_level,error) - CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%MULLIKEN",error=error) + CALL mulliken_population_analysis(qs_env,unit_nr,print_level) + CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%MULLIKEN") END IF ! Compute the Hirshfeld charges - print_key => section_vals_get_subs_vals(input,"DFT%PRINT%HIRSHFELD", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%PRINT%HIRSHFELD") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN ! we check if real space density is available NULLIFY(rho) - CALL get_qs_env(qs_env=qs_env,rho=rho,error=error) - CALL qs_rho_get(rho,rho_r_valid=rho_r_valid,error=error) + CALL get_qs_env(qs_env=qs_env,rho=rho) + CALL qs_rho_get(rho,rho_r_valid=rho_r_valid) IF(rho_r_valid) THEN unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%HIRSHFELD",extension=".hirshfeld",& - middle_name="",log_filename=.FALSE.,error=error) - CALL hirshfeld_charges(qs_env,print_key,unit_nr,error) - CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%HIRSHFELD",error=error) + middle_name="",log_filename=.FALSE.) + CALL hirshfeld_charges(qs_env,print_key,unit_nr) + CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%HIRSHFELD") END IF END IF @@ -3137,13 +3026,11 @@ END SUBROUTINE write_mo_free_results !> \param qs_env ... !> \param input_section ... !> \param unit_nr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE hirshfeld_charges(qs_env,input_section,unit_nr,error) + SUBROUTINE hirshfeld_charges(qs_env,input_section,unit_nr) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: input_section INTEGER, INTENT(IN) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hirshfeld_charges', & routineP = moduleN//':'//routineN @@ -3174,30 +3061,30 @@ SUBROUTINE hirshfeld_charges(qs_env,input_section,unit_nr,error) failure = .FALSE. NULLIFY(hirshfeld_env) - CALL create_hirshfeld_type(hirshfeld_env,error) + CALL create_hirshfeld_type(hirshfeld_env) ! - CALL get_qs_env(qs_env,nkind=nkind,natom=natom,error=error) + CALL get_qs_env(qs_env,nkind=nkind,natom=natom) ALLOCATE(hirshfeld_env%charges(natom),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ! input options - CALL section_vals_val_get(input_section,"SELF_CONSISTENT",l_val=do_sc,error=error) - CALL section_vals_val_get(input_section,"SHAPE_FUNCTION",i_val=shapef,error=error) - CALL section_vals_val_get(input_section,"REFERENCE_CHARGE",i_val=refc,error=error) + CALL section_vals_val_get(input_section,"SELF_CONSISTENT",l_val=do_sc) + CALL section_vals_val_get(input_section,"SHAPE_FUNCTION",i_val=shapef) + CALL section_vals_val_get(input_section,"REFERENCE_CHARGE",i_val=refc) CALL set_hirshfeld_info(hirshfeld_env,shape_function_type=shapef,& - iterative=do_sc,ref_charge=refc,error=error) + iterative=do_sc,ref_charge=refc) ! shape function - CALL get_qs_env(qs_env,qs_kind_set=qs_kind_set,atomic_kind_set=atomic_kind_set,error=error) - CALL create_shape_function(hirshfeld_env,qs_kind_set,atomic_kind_set,error) + CALL get_qs_env(qs_env,qs_kind_set=qs_kind_set,atomic_kind_set=atomic_kind_set) + CALL create_shape_function(hirshfeld_env,qs_kind_set,atomic_kind_set) ! reference charges - CALL get_qs_env(qs_env,rho=rho,error=error) - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL get_qs_env(qs_env,rho=rho) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) nspin=SIZE(matrix_p,1) ALLOCATE(charges(natom,nspin),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) SELECT CASE (refc) CASE (ref_charge_atomic) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),zeff=zeff, error=error) + CALL get_qs_kind(qs_kind_set(ikind),zeff=zeff) atomic_kind => atomic_kind_set(ikind) CALL get_atomic_kind(atomic_kind,atom_list=atom_list) DO iat=1,SIZE(atom_list) @@ -3206,34 +3093,34 @@ SUBROUTINE hirshfeld_charges(qs_env,input_section,unit_nr,error) END DO END DO CASE (ref_charge_mulliken) - CALL get_qs_env(qs_env,matrix_s_kp=matrix_s,para_env=para_env,error=error) - CALL mulliken_charges(matrix_p,matrix_s,para_env,charges,error) + CALL get_qs_env(qs_env,matrix_s_kp=matrix_s,para_env=para_env) + CALL mulliken_charges(matrix_p,matrix_s,para_env,charges) DO iat=1,natom hirshfeld_env%charges(iat) = SUM(charges(iat,:)) END DO CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Unknown type of reference charge for Hirshfeld partitioning.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT ! charges = 0.0_dp IF(hirshfeld_env%iterative) THEN ! Hirshfeld-I charges - CALL comp_hirshfeld_i_charges(qs_env,hirshfeld_env,charges,unit_nr,error) + CALL comp_hirshfeld_i_charges(qs_env,hirshfeld_env,charges,unit_nr) ELSE ! Hirshfeld charges - CALL comp_hirshfeld_charges(qs_env,hirshfeld_env,charges,error) + CALL comp_hirshfeld_charges(qs_env,hirshfeld_env,charges) END IF - CALL get_qs_env(qs_env,particle_set=particle_set,dft_control=dft_control,error=error) + CALL get_qs_env(qs_env,particle_set=particle_set,dft_control=dft_control) IF(dft_control%qs_control%gapw) THEN ! GAPW: add core charges (rho_hard - rho_soft) - CALL get_qs_env(qs_env,rho0_mpole=rho0_mpole,error=error) + CALL get_qs_env(qs_env,rho0_mpole=rho0_mpole) CALL get_rho0_mpole(rho0_mpole,mp_rho=mp_rho) DO iat=1,natom atomic_kind => particle_set(iat)%atomic_kind CALL get_atomic_kind(atomic_kind,kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom, error=error) + CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom) IF(paw_atom) THEN charges(iat,1:nspin) = charges(iat,1:nspin) + mp_rho(iat)%q0(1:nspin) END IF @@ -3242,12 +3129,12 @@ SUBROUTINE hirshfeld_charges(qs_env,input_section,unit_nr,error) ! IF(unit_nr > 0) THEN CALL write_hirshfeld_charges(charges,hirshfeld_env,particle_set,& - qs_kind_set,unit_nr,error) + qs_kind_set,unit_nr) END IF ! - CALL release_hirshfeld_type(hirshfeld_env,error) + CALL release_hirshfeld_type(hirshfeld_env) DEALLOCATE(charges,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE hirshfeld_charges @@ -3258,14 +3145,12 @@ END SUBROUTINE hirshfeld_charges !> \param cb ... !> \param b ... !> \param l ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE project_function_a(ca,a,cb,b,l,error) + SUBROUTINE project_function_a(ca,a,cb,b,l) ! project function cb on ca REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: ca REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: a, cb, b INTEGER, INTENT(IN) :: l - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'project_function_a', & routineP = moduleN//':'//routineN @@ -3280,17 +3165,17 @@ SUBROUTINE project_function_a(ca,a,cb,b,l,error) n = SIZE(ca) ALLOCATE(smat(n,n),tmat(n,n),v(n,1),ipiv(n),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL sg_overlap ( smat, l, a, a ) CALL sg_overlap ( tmat, l, a, b ) v(:,1) = MATMUL(tmat,cb) CALL lapack_sgesv ( n, 1, smat, n, ipiv, v, n, info ) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) ca(:) = v(:,1) DEALLOCATE(smat,tmat,v,ipiv,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE project_function_a @@ -3301,15 +3186,13 @@ END SUBROUTINE project_function_a !> \param bfun ... !> \param grid_atom ... !> \param l ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE project_function_b(ca,a,bfun,grid_atom,l,error) + SUBROUTINE project_function_b(ca,a,bfun,grid_atom,l) ! project function f on ca REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: ca REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: a, bfun TYPE(grid_atom_type), POINTER :: grid_atom INTEGER, INTENT(IN) :: l - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'project_function_b', & routineP = moduleN//':'//routineN @@ -3326,7 +3209,7 @@ SUBROUTINE project_function_b(ca,a,bfun,grid_atom,l,error) n = SIZE(ca) nr = grid_atom%nr ALLOCATE(smat(n,n),v(n,1),ipiv(n),afun(nr),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL sg_overlap ( smat, l, a, a ) DO i=1,n @@ -3334,11 +3217,11 @@ SUBROUTINE project_function_b(ca,a,bfun,grid_atom,l,error) v(i,1) = SUM(afun(:)*bfun(:)*grid_atom%wr(:)) END DO CALL lapack_sgesv ( n, 1, smat, n, ipiv, v, n, info ) - CPPostcondition(info==0,cp_failure_level,routineP,error,failure) + CPPostcondition(info==0,cp_failure_level,routineP,failure) ca(:) = v(:,1) DEALLOCATE(smat,v,ipiv,afun,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE project_function_b diff --git a/src/qs_scf_post_scptb.F b/src/qs_scf_post_scptb.F index 0ecaf825e9..36c4baaa7f 100644 --- a/src/qs_scf_post_scptb.F +++ b/src/qs_scf_post_scptb.F @@ -49,17 +49,14 @@ MODULE qs_scf_post_scptb ! ***************************************************************************** !> \brief collects possible post - scf calculations and prints info / computes properties. !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2013 Adapted from qs_scf_post_gpw.F !> \author Ralph Koitz !> \note ! ***************************************************************************** - SUBROUTINE scf_post_calculation_scptb(qs_env,error) + SUBROUTINE scf_post_calculation_scptb(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_post_calculation_scptb', & routineP = moduleN//':'//routineN @@ -68,7 +65,7 @@ SUBROUTINE scf_post_calculation_scptb(qs_env,error) CALL timeset(routineN,handle) - CALL write_scptb_mo_free_results(qs_env,error) + CALL write_scptb_mo_free_results(qs_env) CALL timestop(handle) END SUBROUTINE scf_post_calculation_scptb @@ -76,13 +73,10 @@ END SUBROUTINE scf_post_calculation_scptb ! ***************************************************************************** !> \brief Write QS results always available in SCPTB calculation !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History 09.2013 adapted from qs_scf_post_gpw.F. [RK] ! ***************************************************************************** - SUBROUTINE write_scptb_mo_free_results(qs_env,error) + SUBROUTINE write_scptb_mo_free_results(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_scptb_mo_free_results', & routineP = moduleN//':'//routineN @@ -111,10 +105,10 @@ SUBROUTINE write_scptb_mo_free_results(qs_env,error) CALL timeset(routineN,handle) failure=.FALSE. NULLIFY(dft_control, rho, input, para_env, rho_ao) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) IF (.NOT. failure) THEN CALL get_qs_env(qs_env,& dft_control=dft_control, & @@ -124,199 +118,198 @@ SUBROUTINE write_scptb_mo_free_results(qs_env,error) input=input,& cell=cell,& subsys=subsys,& - para_env=para_env,& - error=error) + para_env=para_env) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) - print_section => section_vals_get_subs_vals(dft_section,"PRINT",error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") + print_section => section_vals_get_subs_vals(dft_section,"PRINT") + CALL qs_subsys_get(subsys,particles=particles) ! Dipole Moments - print_key => section_vals_get_subs_vals(print_section,"MOMENTS", error=error) - IF(BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file))THEN + print_key => section_vals_get_subs_vals(print_section,"MOMENTS") + IF(BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file))THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Multipole moments from SCPTB calculation currently " //& - "not supported", error=error, error_level=cp_warning_level) + "not supported",error_level=cp_warning_level) END IF ! Print the total density (electronic + core charge) ! Not implemented so far. IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,& - "TOT_DENSITY_CUBE", error=error),cp_p_file)) THEN + "TOT_DENSITY_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of cube files from SCPTB calculation currently " //& - "not supported", error=error, error_level=cp_warning_level) + "not supported",error_level=cp_warning_level) END IF ! Write cube file with electron density ! Not implemented so far. IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,& - "E_DENSITY_CUBE",error=error),cp_p_file)) THEN + "E_DENSITY_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of cube files from SCPTB calculation currently " //& - "not supported", error=error, error_level=cp_warning_level) + "not supported",error_level=cp_warning_level) END IF ! print key ! Print the hartree potential ! Not implemented so far. IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,& - "V_HARTREE_CUBE",error=error),cp_p_file)) THEN + "V_HARTREE_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of cube files from SCPTB calculation currently " //& - "not supported", error=error, error_level=cp_warning_level) + "not supported",error_level=cp_warning_level) ENDIF ! Print the Electrical Field Components ! Not implemented so far. IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,& - "EFIELD_CUBE",error=error),cp_p_file)) THEN + "EFIELD_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of cube files from SCPTB calculation currently " //& - "not supported", error=error, error_level=cp_warning_level) + "not supported",error_level=cp_warning_level) END IF ! Write the density matrices IF (BTEST(cp_print_key_should_output(logger%iter_info,print_section,& - "AO_MATRICES/DENSITY",error=error),cp_p_file)) THEN + "AO_MATRICES/DENSITY"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,input,"AO_MATRICES/DENSITY",& - extension=".Log",error=error) - CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,dft_control%nspins CALL cp_dbcsr_write_sparse_matrix(rho_ao(ispin)%matrix,4,after,qs_env,& - para_env,output_unit=iw,error=error) + para_env,output_unit=iw) END DO - CALL cp_print_key_finished_output(iw,logger,input,"AO_MATRICES/DENSITY",error=error) + CALL cp_print_key_finished_output(iw,logger,input,"AO_MATRICES/DENSITY") END IF ! Compute the Mulliken charges - print_key => section_vals_get_subs_vals(print_section,"MULLIKEN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"MULLIKEN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN unit_nr=cp_print_key_unit_nr(logger,print_section,"MULLIKEN",extension=".mulliken",& - middle_name="",log_filename=.FALSE.,error=error) + middle_name="",log_filename=.FALSE.) print_level = 1 - CALL section_vals_val_get(print_key,"PRINT_GOP",l_val=print_it,error=error) + CALL section_vals_val_get(print_key,"PRINT_GOP",l_val=print_it) IF (print_it) print_level = 2 - CALL section_vals_val_get(print_key,"PRINT_ALL",l_val=print_it,error=error) + CALL section_vals_val_get(print_key,"PRINT_ALL",l_val=print_it) IF (print_it) print_level = 3 - CALL mulliken_population_analysis(qs_env,unit_nr,print_level,error) - CALL cp_print_key_finished_output(unit_nr, logger,print_section,"MULLIKEN",error=error) + CALL mulliken_population_analysis(qs_env,unit_nr,print_level) + CALL cp_print_key_finished_output(unit_nr, logger,print_section,"MULLIKEN") END IF ! Hirshfeld charges - print_key => section_vals_get_subs_vals(print_section,"HIRSHFELD",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"HIRSHFELD") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Hirshfeld charges not available for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! KINETIC ENERGY - print_key => section_vals_get_subs_vals(print_section,"KINETIC_ENERGY",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"KINETIC_ENERGY") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Kinetic energy not available for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Xray diffraction spectrum - print_key => section_vals_get_subs_vals(print_section,"XRAY_DIFFRACTION_SPECTRUM",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"XRAY_DIFFRACTION_SPECTRUM") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Xray diffraction spectrum not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Electric field gradients - print_key => section_vals_get_subs_vals(print_section,"ELECTRIC_FIELD_GRADIENT",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"ELECTRIC_FIELD_GRADIENT") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Electric field gradient not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! STM - print_key => section_vals_get_subs_vals(print_section,"STM",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"STM") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="STM not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! MO - print_key => section_vals_get_subs_vals(print_section,"MO",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"MO") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of MO properties not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! MO CUBES - print_key => section_vals_get_subs_vals(print_section,"MO_CUBES",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"MO_CUBES") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of MO cube files not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Wavefunction mixing - wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX",error=error) - CALL section_vals_get(wfn_mix_section,explicit=explicit,error=error) + wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX") + CALL section_vals_get(wfn_mix_section,explicit=explicit) IF(explicit.AND..NOT.qs_env%run_rtp) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Wavefunction mixing not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! PLUS_U - print_key => section_vals_get_subs_vals(print_section,"PLUS_U",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"PLUS_U") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="DFT+U method not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! PDOS - print_key => section_vals_get_subs_vals(print_section,"PDOS",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"PDOS") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Projected DOS not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! V_XC CUBE FILE - print_key => section_vals_get_subs_vals(print_section,"V_XC_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"V_XC_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="XC potential cube file not available for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! ELF - print_key => section_vals_get_subs_vals(print_section,"ELF_CUBE",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"ELF_CUBE") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="ELF not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! EPR Hyperfine Coupling - print_key => section_vals_get_subs_vals(print_section,"HYPERFINE_COUPLING_TENSOR",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"HYPERFINE_COUPLING_TENSOR") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Hyperfine Coupling not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Lowdin - print_key => section_vals_get_subs_vals(print_section,"LOWDIN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(print_section,"LOWDIN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Lowdin population analysis not implemented for SCPTB method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF END IF diff --git a/src/qs_scf_post_se.F b/src/qs_scf_post_se.F index 906389b06a..4e46acb0cb 100644 --- a/src/qs_scf_post_se.F +++ b/src/qs_scf_post_se.F @@ -73,8 +73,6 @@ MODULE qs_scf_post_se !> \brief collects possible post - scf calculations and prints info / computes properties. !> specific for Semi-empirical calculations !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2008 created [tlaino] - Splitted from qs_scf_post (general) !> \author tlaino @@ -85,10 +83,9 @@ MODULE qs_scf_post_se !> change afterwards slightly the forces (hence small numerical differences between MD !> with and without the debug print level). Ideally this should not happen... ! ***************************************************************************** - SUBROUTINE scf_post_calculation_se(qs_env,error) + SUBROUTINE scf_post_calculation_se(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_post_calculation_se', & routineP = moduleN//':'//routineN @@ -110,17 +107,17 @@ SUBROUTINE scf_post_calculation_se(qs_env,error) CALL timeset(routineN,handle) ! Writes the data that is already available in qs_env - CALL write_available_results(qs_env,error) + CALL write_available_results(qs_env) failure=.FALSE. my_localized_wfn = .FALSE. NULLIFY(dft_control, mos, rho, & subsys, particles, input, print_key, para_env) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) ! Here we start with data that needs a postprocessing... CALL get_qs_env(qs_env,& dft_control=dft_control,& @@ -128,87 +125,86 @@ SUBROUTINE scf_post_calculation_se(qs_env,error) rho=rho,& input=input,& subsys=subsys,& - para_env=para_env,& - error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + para_env=para_env) + CALL qs_subsys_get(subsys,particles=particles) ! Compute Atomic Charges - CALL qs_scf_post_charges(input, logger, qs_env, rho, para_env, error) + CALL qs_scf_post_charges(input, logger, qs_env, rho, para_env) ! Moments of charge distribution - CALL qs_scf_post_moments(input, logger, qs_env, error) + CALL qs_scf_post_moments(input, logger, qs_env) ! MO_CUBES print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%MO_CUBES",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + subsection_name="DFT%PRINT%MO_CUBES") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Printing of MO cube files not implemented for Semi-Empirical method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! STM print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%STM",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + subsection_name="DFT%PRINT%STM") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="STM not implemented for Semi-Empirical method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! DFT+U print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%PLUS_U",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + subsection_name="DFT%PRINT%PLUS_U") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="DFT+U not available for Semi-Empirical method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Kinetic Energy print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%KINETIC_ENERGY",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + subsection_name="DFT%PRINT%KINETIC_ENERGY") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Kinetic energy not available for Semi-Empirical method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Wavefunction mixing - wfn_mix_section => section_vals_get_subs_vals(input,"DFT%PRINT%WFN_MIX",error=error) - CALL section_vals_get(wfn_mix_section,explicit=explicit,error=error) + wfn_mix_section => section_vals_get_subs_vals(input,"DFT%PRINT%WFN_MIX") + CALL section_vals_get(wfn_mix_section,explicit=explicit) IF(explicit.AND..NOT.qs_env%run_rtp) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Wavefunction mixing not implemented for Semi-Empirical method.", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Print coherent X-ray diffraction spectrum print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%XRAY_DIFFRACTION_SPECTRUM",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + subsection_name="DFT%PRINT%XRAY_DIFFRACTION_SPECTRUM") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="XRAY_DIFFRACTION_SPECTRUM not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Calculation of Electric Field Gradients print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%ELECTRIC_FIELD_GRADIENT",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + subsection_name="DFT%PRINT%ELECTRIC_FIELD_GRADIENT") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="ELECTRIC_FIELD_GRADIENT not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Calculation of EPR Hyperfine Coupling Tensors print_key => section_vals_get_subs_vals(section_vals=input,& - subsection_name="DFT%PRINT%HYPERFINE_COUPLING_TENSOR",error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),& + subsection_name="DFT%PRINT%HYPERFINE_COUPLING_TENSOR") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),& cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="HYPERFINE_COUPLING_TENSOR not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF @@ -225,14 +221,11 @@ END SUBROUTINE scf_post_calculation_se !> \param input ... !> \param logger ... !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE qs_scf_post_moments(input, logger, qs_env, error) + SUBROUTINE qs_scf_post_moments(input, logger, qs_env) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_moments', & routineP = moduleN//':'//routineN @@ -269,20 +262,20 @@ SUBROUTINE qs_scf_post_moments(input, logger, qs_env, error) TYPE(section_vals_type), POINTER :: print_key TYPE(semi_empirical_type), POINTER :: se_kind - print_key => section_vals_get_subs_vals(input,"DFT%PRINT%MOMENTS", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%PRINT%MOMENTS") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN ! Dipole Moments unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%MOMENTS",& - extension=".data",middle_name="se_dipole",log_filename=.FALSE.,error=error) + extension=".data",middle_name="se_dipole",log_filename=.FALSE.) ! Reference point - reference = section_get_ival(print_key,keyword_name="REFERENCE",error=error) + reference = section_get_ival(print_key,keyword_name="REFERENCE") NULLIFY(ref_point) description='[DIPOLE]' - CALL section_vals_val_get(print_key,"REF_POINT",r_vals=ref_point,error=error) - CALL section_vals_val_get(print_key,"PERIODIC",l_val=do_berry,error=error) + CALL section_vals_val_get(print_key,"REF_POINT",r_vals=ref_point) + CALL section_vals_val_get(print_key,"PERIODIC",l_val=do_berry) CALL get_reference_point(rcc,drcc,qs_env=qs_env,reference=reference,& - ref_point=ref_point,error=error) + ref_point=ref_point) ! NULLIFY(particle_set) CALL get_qs_env(qs_env=qs_env,& @@ -292,20 +285,19 @@ SUBROUTINE qs_scf_post_moments(input, logger, qs_env, error) natom=natom,& qs_kind_set=qs_kind_set,& particle_set=particle_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao=matrix_p) nspin = SIZE(matrix_p) nkind = SIZE(atomic_kind_set) ! net charges ALLOCATE (ncharge(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ncharge = 0.0_dp DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind) CALL get_se_param(se_kind,zeff=zeff,natorb=natorb) DO iatom=1,nat iat = atomic_kind_set(ikind)%atom_list(iatom) @@ -383,20 +375,20 @@ SUBROUTINE qs_scf_post_moments(input, logger, qs_env, error) ! No contribution to dipole derivatives DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set,error=error) - CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),basis_set=basis_set) + CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind) CALL get_se_param(se_kind,natorb=natorb) ALLOCATE (mom(natorb,natorb,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) mom = 0.0_dp - CALL atomic_moments(mom,basis_set,error) + CALL atomic_moments(mom,basis_set) DO iatom=1,nat iat = atomic_kind_set(ikind)%atom_list(iatom) DO i=1,nspin CALL cp_dbcsr_get_block_p(matrix=matrix_p(i)%matrix,row=iat,col=iat,& block=pblock,found=found) IF(found) THEN - CPPostcondition(natorb==SIZE(pblock,1),cp_failure_level,routineP,error,failure) + CPPostcondition(natorb==SIZE(pblock,1),cp_failure_level,routineP,failure) ix=coset(1,0,0) - 1 dipole(1)=dipole(1) + SUM(pblock*mom(:,:,ix)) ix=coset(0,1,0) - 1 @@ -407,14 +399,14 @@ SUBROUTINE qs_scf_post_moments(input, logger, qs_env, error) END DO END DO DEALLOCATE (mom,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO IF(unit_nr>0)THEN WRITE(unit_nr,'(1X,A,T48,3F11.6)')"DIPOLE "//TRIM(dipole_type)//"(A.U.)|",dipole WRITE(unit_nr,'(1X,A,T48,3F11.6)')"DIPOLE "//TRIM(dipole_type)//"(Debye)|",dipole*debye WRITE(unit_nr,'(1X,A,T48,3F11.6)')"DIPOLE "//TRIM(dipole_type)//" DERIVATIVE(A.U.)|",dipole_deriv END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) END IF END SUBROUTINE qs_scf_post_moments @@ -423,13 +415,10 @@ END SUBROUTINE qs_scf_post_moments !> \brief Computes the dipole integrals for an atom (a|x|b), a,b on atom A !> \param mom ... !> \param basis_set ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE atomic_moments(mom,basis_set,error) + SUBROUTINE atomic_moments(mom,basis_set) REAL(KIND=dp), DIMENSION(:, :, :) :: mom TYPE(gto_basis_set_type), POINTER :: basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atomic_moments', & routineP = moduleN//':'//routineN @@ -465,7 +454,7 @@ SUBROUTINE atomic_moments(mom,basis_set,error) nm = MAX(nm,ncoa) END DO ALLOCATE (mab(nm,nm,4),work(nm,nm),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO iset=1,nset ncoa = npgf(iset)*ncoset(la_max(iset)) @@ -486,7 +475,7 @@ SUBROUTINE atomic_moments(mom,basis_set,error) END DO END DO DEALLOCATE (mab,work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE atomic_moments ! ***************************************************************************** @@ -496,17 +485,14 @@ END SUBROUTINE atomic_moments !> \param qs_env the qs_env in which the qs_env lives !> \param rho ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE qs_scf_post_charges(input, logger, qs_env, rho, & - para_env, error) + para_env) TYPE(section_vals_type), POINTER :: input TYPE(cp_logger_type), POINTER :: logger TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_rho_type), POINTER :: rho TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_scf_post_charges', & routineP = moduleN//':'//routineN @@ -540,25 +526,24 @@ SUBROUTINE qs_scf_post_charges(input, logger, qs_env, rho, & natom=natom,& qs_kind_set=qs_kind_set,& particle_set=particle_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) ! Compute the mulliken charges - print_key => section_vals_get_subs_vals(input,"DFT%PRINT%MULLIKEN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%PRINT%MULLIKEN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN unit_nr=cp_print_key_unit_nr(logger,input,"DFT%PRINT%MULLIKEN",extension=".mulliken",& - middle_name="",log_filename=.FALSE.,error=error) - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + middle_name="",log_filename=.FALSE.) + CALL qs_rho_get(rho, rho_ao=matrix_p) nspin = SIZE(matrix_p) ALLOCATE (charges(natom,nspin),mcharge(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) charges = 0.0_dp mcharge = 0.0_dp ! calculate atomic charges nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind) CALL get_se_param(se_kind,zeff=zeff,natorb=natorb) DO iatom=1,nat iat = atomic_kind_set(ikind)%atom_list(iatom) @@ -585,7 +570,7 @@ SUBROUTINE qs_scf_post_charges(input, logger, qs_env, rho, & " # Atom Element Kind Atomic population"," Net charge" DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind) CALL get_se_param(se_kind,name=aname) ana = ADJUSTR(TRIM(ADJUSTL(aname))) DO iatom=1,nat @@ -603,7 +588,7 @@ SUBROUTINE qs_scf_post_charges(input, logger, qs_env, rho, & "# Atom Element Kind Atomic population (alpha,beta) Net charge Spin moment" DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind,error=error) + CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind) CALL get_se_param(se_kind,name=aname) ana = ADJUSTR(TRIM(ADJUSTL(aname))) DO iatom=1,nat @@ -619,26 +604,26 @@ SUBROUTINE qs_scf_post_charges(input, logger, qs_env, rho, & END IF END IF - CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%MULLIKEN",error=error) + CALL cp_print_key_finished_output(unit_nr, logger,input,"DFT%PRINT%MULLIKEN") DEALLOCATE (charges,mcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! Compute the Lowdin charges - print_key => section_vals_get_subs_vals(input,"DFT%PRINT%LOWDIN", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%PRINT%LOWDIN") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP,& message="Lowdin charges not available for semi-empirical calculations!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Hirshfeld charges - print_key => section_vals_get_subs_vals(input,"DFT%PRINT%HIRSHFELD", error=error) - IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key,error=error),cp_p_file)) THEN + print_key => section_vals_get_subs_vals(input,"DFT%PRINT%HIRSHFELD") + IF (BTEST(cp_print_key_should_output(logger%iter_info,print_key),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Hirshfeld charges not available for semi-empirical calculations!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF END SUBROUTINE qs_scf_post_charges @@ -646,12 +631,9 @@ END SUBROUTINE qs_scf_post_charges ! ***************************************************************************** !> \brief Write QS results always available (if switched on through the print_keys) !> \param qs_env the qs_env in which the qs_env lives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE write_available_results(qs_env,error) + SUBROUTINE write_available_results(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_available_results', & routineP = moduleN//':'//routineN @@ -683,10 +665,10 @@ SUBROUTINE write_available_results(qs_env,error) NULLIFY(cell, dft_control, mos, atomic_kind_set, particle_set, rho, & ks_rmpv, dft_section, input, & particles, subsys, para_env, rho_ao) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) IF (.NOT. failure) THEN CALL get_qs_env(qs_env,& dft_control=dft_control,& @@ -699,106 +681,105 @@ SUBROUTINE write_available_results(qs_env,error) input=input,& cell=cell,& subsys=subsys,& - para_env=para_env,& - error=error) - CALL qs_subsys_get(subsys,particles=particles,error=error) + para_env=para_env) + CALL qs_subsys_get(subsys,particles=particles) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) ! *** if the dft_section tells you to do so, write last wavefunction to screen - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + dft_section => section_vals_get_subs_vals(input,"DFT") IF (dft_control%nspins == 2) THEN CALL write_mo_set(mos(1)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,spin="ALPHA",last=.TRUE.,error=error) + dft_section,spin="ALPHA",last=.TRUE.) CALL write_mo_set(mos(2)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,spin="BETA",last=.TRUE.,error=error) + dft_section,spin="BETA",last=.TRUE.) ELSE CALL write_mo_set(mos(1)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,last=.TRUE.,error=error) + dft_section,last=.TRUE.) END IF ! *** at the end of scf print out the projected dos per kind - IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%PDOS",& - error=error),cp_p_file) ) THEN + IF (BTEST(cp_print_key_should_output(logger%iter_info,dft_section,"PRINT%PDOS")& + ,cp_p_file) ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="PDOS not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ENDIF ! Print the total density (electronic + core charge) IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%TOT_DENSITY_CUBE", error=error),cp_p_file)) THEN + "DFT%PRINT%TOT_DENSITY_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="TOT_DENSITY_CUBE not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! Write cube file with electron density IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%E_DENSITY_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%E_DENSITY_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="E_DENSITY_CUBE not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! print key ! Write cube file with EFIELD IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%EFIELD_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%EFIELD_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="EFIELD_CUBE not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! print key ! Write cube file with ELF IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%ELF_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%ELF_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="ELF function not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) END IF ! print key ! Print the hartree potential IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%V_HARTREE_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%V_HARTREE_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="V_HARTREE_CUBE not implemented for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ENDIF ! Print the XC potential IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%V_XC_CUBE",error=error),cp_p_file)) THEN + "DFT%PRINT%V_XC_CUBE"),cp_p_file)) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="V_XC_CUBE not available for Semi-Empirical calculations!!", & - error=error, error_level=cp_warning_level) + error_level=cp_warning_level) ENDIF ! Write the density matrix IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%AO_MATRICES/DENSITY",error=error),cp_p_file)) THEN + "DFT%PRINT%AO_MATRICES/DENSITY"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,input,"DFT%PRINT%AO_MATRICES/DENSITY",& - extension=".Log",error=error) - CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) DO ispin=1,dft_control%nspins CALL cp_dbcsr_write_sparse_matrix(rho_ao(ispin)%matrix,4,after,qs_env,& - para_env,output_unit=iw,error=error) + para_env,output_unit=iw) END DO CALL cp_print_key_finished_output(iw,logger,input,& - "DFT%PRINT%AO_MATRICES/DENSITY", error=error) + "DFT%PRINT%AO_MATRICES/DENSITY") END IF ! The Kohn-Sham matrix itself IF (BTEST(cp_print_key_should_output(logger%iter_info,input,& - "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX",error=error),cp_p_file)) THEN - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.,error=error) + "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX"),cp_p_file)) THEN + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=.FALSE.) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) iw = cp_print_key_unit_nr(logger,input,"DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX",& - extension=".Log",error=error) - CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL cp_dbcsr_write_sparse_matrix(ks_rmpv(1)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) + CALL cp_dbcsr_write_sparse_matrix(ks_rmpv(1)%matrix,4,after,qs_env,para_env,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,input,& - "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX", error=error) + "DFT%PRINT%AO_MATRICES/KOHN_SHAM_MATRIX") END IF END IF diff --git a/src/qs_scf_types.F b/src/qs_scf_types.F index 03d2d21b86..1973906b63 100644 --- a/src/qs_scf_types.F +++ b/src/qs_scf_types.F @@ -134,15 +134,12 @@ MODULE qs_scf_types ! ***************************************************************************** !> \brief allocates and initialize an scf_env !> \param scf_env the scf env to initialize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE scf_env_create(scf_env, error) + SUBROUTINE scf_env_create(scf_env) TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_env_create', & routineP = moduleN//':'//routineN @@ -155,7 +152,7 @@ SUBROUTINE scf_env_create(scf_env, error) failure = .FALSE. ALLOCATE (scf_env,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) scf_env%ref_count = 1 scf_env%print_count = 0 last_scf_env_id = last_scf_env_id + 1 @@ -207,16 +204,13 @@ END SUBROUTINE scf_env_create ! ***************************************************************************** !> \brief retains an scf_env (see doc/ReferenceCounting.html) !> \param scf_env the environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE scf_env_retain(scf_env,error) + SUBROUTINE scf_env_retain(scf_env) TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_env_retain', & routineP = moduleN//':'//routineN @@ -228,8 +222,8 @@ SUBROUTINE scf_env_retain(scf_env,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) scf_env%ref_count = scf_env%ref_count + 1 CALL timestop(handle) @@ -239,15 +233,12 @@ END SUBROUTINE scf_env_retain ! ***************************************************************************** !> \brief function to be called to inform the scf_env about changes !> \param scf_env the scf env to inform -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE scf_env_did_change(scf_env,error) + SUBROUTINE scf_env_did_change(scf_env) TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_env_did_change', & routineP = moduleN//':'//routineN @@ -259,14 +250,14 @@ SUBROUTINE scf_env_did_change(scf_env,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) IF (ASSOCIATED(scf_env%p_mix_new)) THEN - CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_mix_new,error=error) + CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_mix_new) END IF IF (ASSOCIATED(scf_env%p_delta)) THEN - CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_delta,error=error) + CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_delta) END IF CALL timestop(handle) @@ -276,16 +267,13 @@ END SUBROUTINE scf_env_did_change ! ***************************************************************************** !> \brief releases an scf_env (see doc/ReferenceCounting.html) !> \param scf_env the environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE scf_env_release(scf_env,error) + SUBROUTINE scf_env_release(scf_env) TYPE(qs_scf_env_type), POINTER :: scf_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scf_env_release', & routineP = moduleN//':'//routineN @@ -298,93 +286,93 @@ SUBROUTINE scf_env_release(scf_env,error) failure = .FALSE. IF (ASSOCIATED(scf_env)) THEN - CPPreconditionNoFail(scf_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(scf_env%ref_count>0,cp_failure_level,routineP) scf_env%ref_count = scf_env%ref_count - 1 IF (scf_env%ref_count < 1) THEN - CALL cp_fm_vect_dealloc(scf_env%scf_work1,error=error) - CALL cp_fm_release(scf_env%scf_work2,error=error) - CALL cp_fm_release(scf_env%ortho,error=error) - CALL cp_fm_release(scf_env%ortho_m1,error=error) + CALL cp_fm_vect_dealloc(scf_env%scf_work1) + CALL cp_fm_release(scf_env%scf_work2) + CALL cp_fm_release(scf_env%ortho) + CALL cp_fm_release(scf_env%ortho_m1) IF (ASSOCIATED(scf_env%ortho_dbcsr)) THEN ! we should not end up here, and give back using the pools - CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP,error) - CALL cp_dbcsr_deallocate_matrix(scf_env%ortho_dbcsr,error=error) + CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP) + CALL cp_dbcsr_deallocate_matrix(scf_env%ortho_dbcsr) END IF IF (ASSOCIATED(scf_env%buf1_dbcsr)) THEN ! we should not end up here, and give back using the pools - CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP,error) - CALL cp_dbcsr_deallocate_matrix(scf_env%buf1_dbcsr,error=error) + CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP) + CALL cp_dbcsr_deallocate_matrix(scf_env%buf1_dbcsr) END IF IF (ASSOCIATED(scf_env%buf2_dbcsr)) THEN ! we should not end up here, and give back using the pools - CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP,error) - CALL cp_dbcsr_deallocate_matrix(scf_env%buf2_dbcsr,error=error) + CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP) + CALL cp_dbcsr_deallocate_matrix(scf_env%buf2_dbcsr) END IF - CALL cp_fm_release(scf_env%s_half,error=error) - CALL cp_fm_release(scf_env%s_minus_one,error=error) + CALL cp_fm_release(scf_env%s_half) + CALL cp_fm_release(scf_env%s_minus_one) IF (ASSOCIATED(scf_env%p_mix_new)) THEN ! we should not end up here, and give back using the pools - CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP,error) - CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_mix_new,error=error) + CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP) + CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_mix_new) END IF IF (ASSOCIATED(scf_env%p_delta)) THEN ! we should not end up here, and give back using the pools - CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP,error) - CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_delta,error=error) + CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP) + CALL cp_dbcsr_deallocate_matrix_set(scf_env%p_delta) END IF IF (ASSOCIATED(scf_env%ot_preconditioner)) THEN DO i=1,SIZE(scf_env%ot_preconditioner) - CALL destroy_preconditioner(scf_env%ot_preconditioner(i)%preconditioner,error=error) + CALL destroy_preconditioner(scf_env%ot_preconditioner(i)%preconditioner) DEALLOCATE (scf_env%ot_preconditioner(i)%preconditioner) END DO DEALLOCATE (scf_env%ot_preconditioner,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(scf_env%qs_ot_env)) THEN DO i=1,SIZE(scf_env%qs_ot_env) - CALL qs_ot_destroy(scf_env%qs_ot_env(i),error=error) + CALL qs_ot_destroy(scf_env%qs_ot_env(i)) END DO DEALLOCATE(scf_env%qs_ot_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF - CALL qs_diis_b_release(scf_env%scf_diis_buffer,error=error) + CALL qs_diis_b_release(scf_env%scf_diis_buffer) IF (ASSOCIATED(scf_env%outer_scf%variables)) THEN DEALLOCATE(scf_env%outer_scf%variables,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(scf_env%outer_scf%count)) THEN DEALLOCATE(scf_env%outer_scf%count,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(scf_env%outer_scf%gradient)) THEN DEALLOCATE(scf_env%outer_scf%gradient,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(scf_env%outer_scf%energy)) THEN DEALLOCATE(scf_env%outer_scf%energy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(scf_env%cc_buffer)) THEN DEALLOCATE(scf_env%cc_buffer,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(scf_env%mixing_store)) THEN - CALL mixing_storage_release(scf_env%mixing_store,error=error) + CALL mixing_storage_release(scf_env%mixing_store) END IF IF (ASSOCIATED(scf_env%krylov_space)) THEN - CALL krylov_space_release(scf_env%krylov_space,error=error) + CALL krylov_space_release(scf_env%krylov_space) END IF IF (ASSOCIATED(scf_env%subspace_env)) THEN - CALL diag_subspace_env_release(scf_env%subspace_env,error=error) + CALL diag_subspace_env_release(scf_env%subspace_env) END IF IF (ASSOCIATED(scf_env%block_davidson_env)) THEN - CALL block_davidson_release(scf_env%block_davidson_env,error=error) + CALL block_davidson_release(scf_env%block_davidson_env) END IF IF (fb_env_has_data(scf_env%filter_matrix_env)) THEN - CALL fb_env_release(scf_env%filter_matrix_env, error=error) + CALL fb_env_release(scf_env%filter_matrix_env) END IF DEALLOCATE(scf_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF @@ -398,16 +386,14 @@ END SUBROUTINE scf_env_release !> \brief creates krylov space !> \param krylov_space ... !> \param scf_section ... -!> \param error ... !> \par History !> 05.2009 created [MI] !> \author [MI] ! ***************************************************************************** - SUBROUTINE krylov_space_create(krylov_space,scf_section, error) + SUBROUTINE krylov_space_create(krylov_space,scf_section) TYPE(krylov_space_type), POINTER :: krylov_space TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'krylov_space_create', & routineP = moduleN//':'//routineN @@ -417,9 +403,9 @@ SUBROUTINE krylov_space_create(krylov_space,scf_section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(krylov_space),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(krylov_space),cp_failure_level,routineP,failure) ALLOCATE(krylov_space, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(krylov_space%c_eval,krylov_space%t_eval) @@ -431,33 +417,31 @@ SUBROUTINE krylov_space_create(krylov_space,scf_section, error) NULLIFY(krylov_space%block3_mat, krylov_space%block4_mat, krylov_space%block5_mat) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%MAX_ITER",& - i_val=krylov_space%max_iter,error=error) + i_val=krylov_space%max_iter) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%KRYLOV%NKRYLOV",& - i_val=krylov_space%nkrylov,error=error) + i_val=krylov_space%nkrylov) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%KRYLOV%NBLOCK",& - i_val=krylov_space%nblock,error=error) + i_val=krylov_space%nblock) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%KRYLOV%EPS_KRYLOV",& - r_val=krylov_space%eps_conv,error=error) + r_val=krylov_space%eps_conv) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%KRYLOV%EPS_STD_DIAG",& - r_val=krylov_space%eps_std_diag,error=error) + r_val=krylov_space%eps_std_diag) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%EPS_ADAPT",& - r_val=krylov_space%eps_adapt,error=error) + r_val=krylov_space%eps_adapt) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%KRYLOV%CHECK_MOS_CONV",& - l_val=krylov_space%always_check_conv,error=error) + l_val=krylov_space%always_check_conv) END SUBROUTINE krylov_space_create ! ***************************************************************************** !> \brief releases krylov space !> \param krylov_space ... -!> \param error ... !> \par History !> 05.2009 created [MI] !> \author [MI] ! ***************************************************************************** - SUBROUTINE krylov_space_release(krylov_space,error) + SUBROUTINE krylov_space_release(krylov_space) TYPE(krylov_space_type), POINTER :: krylov_space - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'krylov_space_release', & routineP = moduleN//':'//routineN @@ -470,45 +454,45 @@ SUBROUTINE krylov_space_release(krylov_space,error) IF(ASSOCIATED(krylov_space)) THEN DEALLOCATE(krylov_space%c_eval,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(krylov_space%t_eval,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO i = 1,SIZE(krylov_space%v_mat) - CALL cp_fm_release(krylov_space%v_mat(i)%matrix,error=error) + CALL cp_fm_release(krylov_space%v_mat(i)%matrix) END DO DEALLOCATE(krylov_space%v_mat,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO i = 1,SIZE(krylov_space%mo_conv) - CALL cp_fm_release(krylov_space%mo_conv(i)%matrix,error=error) + CALL cp_fm_release(krylov_space%mo_conv(i)%matrix) END DO DEALLOCATE(krylov_space%mo_conv,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO i = 1,SIZE(krylov_space%mo_refine) - CALL cp_fm_release(krylov_space%mo_refine(i)%matrix,error=error) + CALL cp_fm_release(krylov_space%mo_refine(i)%matrix) END DO DEALLOCATE(krylov_space%mo_refine,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO i = 1,SIZE(krylov_space%chc_mat) - CALL cp_fm_release(krylov_space%chc_mat(i)%matrix,error=error) + CALL cp_fm_release(krylov_space%chc_mat(i)%matrix) END DO DEALLOCATE(krylov_space%chc_mat,STAT=stat) DO i = 1,SIZE(krylov_space%c_vec) - CALL cp_fm_release(krylov_space%c_vec(i)%matrix,error=error) + CALL cp_fm_release(krylov_space%c_vec(i)%matrix) END DO DEALLOCATE(krylov_space%c_vec,STAT=stat) - CALL cp_fm_release(krylov_space%tmp_mat,error=error) - CALL cp_fm_release(krylov_space%block1_mat,error=error) - CALL cp_fm_release(krylov_space%block2_mat,error=error) - CALL cp_fm_release(krylov_space%block3_mat,error=error) - CALL cp_fm_release(krylov_space%block4_mat,error=error) - CALL cp_fm_release(krylov_space%block5_mat,error=error) + CALL cp_fm_release(krylov_space%tmp_mat) + CALL cp_fm_release(krylov_space%block1_mat) + CALL cp_fm_release(krylov_space%block2_mat) + CALL cp_fm_release(krylov_space%block3_mat) + CALL cp_fm_release(krylov_space%block4_mat) + CALL cp_fm_release(krylov_space%block5_mat) DEALLOCATE(krylov_space,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(krylov_space) END IF @@ -520,17 +504,15 @@ END SUBROUTINE krylov_space_release !> \param subspace_env ... !> \param scf_section ... !> \param ecut ... -!> \param error ... !> \par History !> 09.2009 created [MI] !> \author [MI] ! ***************************************************************************** - SUBROUTINE diag_subspace_env_create(subspace_env,scf_section,ecut,error) + SUBROUTINE diag_subspace_env_create(subspace_env,scf_section,ecut) TYPE(subspace_env_type), POINTER :: subspace_env TYPE(section_vals_type), POINTER :: scf_section REAL(dp), INTENT(IN) :: ecut - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'diag_subspace_env_create', & routineP = moduleN//':'//routineN @@ -541,9 +523,9 @@ SUBROUTINE diag_subspace_env_create(subspace_env,scf_section,ecut,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(subspace_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(subspace_env),cp_failure_level,routineP,failure) ALLOCATE(subspace_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY(subspace_env%p_matrix_store) @@ -555,26 +537,24 @@ SUBROUTINE diag_subspace_env_create(subspace_env,scf_section,ecut,error) NULLIFY(mixing_section) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DIAG_SUB_SCF%MAX_ITER",& - i_val=subspace_env%max_iter,error=error) + i_val=subspace_env%max_iter) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DIAG_SUB_SCF%EPS_ENE",& - r_val=subspace_env%eps_ene,error=error) + r_val=subspace_env%eps_ene) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DIAG_SUB_SCF%EPS_SKIP_SUB_DIAG",& - r_val=subspace_env%eps_diag_sub,error=error) + r_val=subspace_env%eps_diag_sub) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DIAG_SUB_SCF%EPS_ADAPT_SCF",& - r_val=subspace_env%eps_adapt,error=error) + r_val=subspace_env%eps_adapt) subspace_env%mixing_method = 0 do_mixing = .FALSE. - mixing_section => section_vals_get_subs_vals(scf_section,"DIAGONALIZATION%DIAG_SUB_SCF%MIXING",error=error) + mixing_section => section_vals_get_subs_vals(scf_section,"DIAGONALIZATION%DIAG_SUB_SCF%MIXING") CALL section_vals_val_get(mixing_section,"_SECTION_PARAMETERS_",& - l_val=do_mixing,& - error=error) + l_val=do_mixing) IF (do_mixing) THEN CALL section_vals_val_get(mixing_section,"METHOD",& - i_val=subspace_env%mixing_method,& - error=error) + i_val=subspace_env%mixing_method) IF(subspace_env%mixing_method>=direct_mixing_nr)& CALL mixing_storage_create(subspace_env%mixing_store, mixing_section, & - subspace_env%mixing_method, ecut=ecut, error=error) + subspace_env%mixing_method, ecut=ecut) END IF @@ -583,14 +563,12 @@ END SUBROUTINE diag_subspace_env_create ! ***************************************************************************** !> \brief releases subspace-rotation environment !> \param subspace_env ... -!> \param error ... !> \par History !> 09.2009 created [MI] !> \author [MI] ! ***************************************************************************** - SUBROUTINE diag_subspace_env_release(subspace_env,error) + SUBROUTINE diag_subspace_env_release(subspace_env) TYPE(subspace_env_type), POINTER :: subspace_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'diag_subspace_env_release', & routineP = moduleN//':'//routineN @@ -604,28 +582,28 @@ SUBROUTINE diag_subspace_env_release(subspace_env,error) IF (ASSOCIATED(subspace_env%p_matrix_store)) THEN - CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP,error) ! should be given back using the pools - CALL cp_dbcsr_deallocate_matrix_set(subspace_env%p_matrix_store,error=error) + CPPreconditionNoFail(.TRUE.,cp_failure_level,routineP) ! should be given back using the pools + CALL cp_dbcsr_deallocate_matrix_set(subspace_env%p_matrix_store) ENDIF DO i = 1,SIZE(subspace_env%chc_mat) - CALL cp_fm_release(subspace_env%chc_mat(i)%matrix,error=error) + CALL cp_fm_release(subspace_env%chc_mat(i)%matrix) END DO DEALLOCATE(subspace_env%chc_mat,STAT=stat) DO i = 1,SIZE(subspace_env%c_vec) - CALL cp_fm_release(subspace_env%c_vec(i)%matrix,error=error) + CALL cp_fm_release(subspace_env%c_vec(i)%matrix) END DO DEALLOCATE(subspace_env%c_vec,STAT=stat) DO i = 1,SIZE(subspace_env%c0) - CALL cp_fm_release(subspace_env%c0(i)%matrix,error=error) + CALL cp_fm_release(subspace_env%c0(i)%matrix) END DO DEALLOCATE(subspace_env%c0,STAT=stat) IF (ASSOCIATED(subspace_env%mixing_store)) THEN - CALL mixing_storage_release(subspace_env%mixing_store,error=error) + CALL mixing_storage_release(subspace_env%mixing_store) END IF DEALLOCATE(subspace_env, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END SUBROUTINE diag_subspace_env_release diff --git a/src/qs_scf_wfn_mix.F b/src/qs_scf_wfn_mix.F index 2a6122d75c..0772c05270 100644 --- a/src/qs_scf_wfn_mix.F +++ b/src/qs_scf_wfn_mix.F @@ -61,10 +61,9 @@ MODULE qs_scf_wfn_mix !> \param matrix_s ... !> \param output_unit ... !> \param marked_states ... -!> \param error ... ! ***************************************************************************** SUBROUTINE wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set,& - unoccupied_orbs, scf_env, matrix_s, output_unit, marked_states,error) + unoccupied_orbs, scf_env, matrix_s, output_unit, marked_states) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos @@ -83,7 +82,6 @@ SUBROUTINE wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, INTEGER :: output_unit INTEGER, DIMENSION(:, :, :), OPTIONAL, & POINTER :: marked_states - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfn_mix', & routineP = moduleN//':'//routineN @@ -103,8 +101,8 @@ SUBROUTINE wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, failure=.FALSE. CALL timeset(routineN,handle) - wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX",error=error) - CALL section_vals_get(wfn_mix_section,explicit=explicit, error=error) + wfn_mix_section => section_vals_get_subs_vals(dft_section,"PRINT%WFN_MIX") + CALL section_vals_get(wfn_mix_section,explicit=explicit) ! only perform action if explicitly required IF (explicit) THEN @@ -117,42 +115,42 @@ SUBROUTINE wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, ALLOCATE(mos_new(SIZE(mos))) DO ispin=1,SIZE(mos) - CALL duplicate_mo_set(mos_new(ispin)%mo_set,mos(ispin)%mo_set,error) + CALL duplicate_mo_set(mos_new(ispin)%mo_set,mos(ispin)%mo_set) ENDDO ! a single vector matrix structure NULLIFY(fm_struct_vector) CALL cp_fm_struct_create(fm_struct_vector,template_fmstruct=mos(1)%mo_set%mo_coeff%matrix_struct, & - ncol_global=1, error=error) - CALL cp_fm_create(matrix_x,fm_struct_vector,name="x",error=error) - CALL cp_fm_create(matrix_y,fm_struct_vector,name="y",error=error) - CALL cp_fm_struct_release(fm_struct_vector,error) - - update_section=>section_vals_get_subs_vals(wfn_mix_section,"UPDATE",error=error) - CALL section_vals_get(update_section,n_repetition=n_rep,error=error) - CALL section_vals_get(update_section,explicit=explicit, error=error) + ncol_global=1) + CALL cp_fm_create(matrix_x,fm_struct_vector,name="x") + CALL cp_fm_create(matrix_y,fm_struct_vector,name="y") + CALL cp_fm_struct_release(fm_struct_vector) + + update_section=>section_vals_get_subs_vals(wfn_mix_section,"UPDATE") + CALL section_vals_get(update_section,n_repetition=n_rep) + CALL section_vals_get(update_section,explicit=explicit) IF (.NOT. explicit) n_rep=0 DO i_rep=1,n_rep - CALL section_vals_val_get(update_section,"RESULT_MO_INDEX",i_rep_section=i_rep,i_val=result_mo_index,error=error) - CALL section_vals_val_get(update_section,"RESULT_MARKED_STATE",i_rep_section=i_rep,i_val=mark_number,error=error) - CALL section_vals_val_get(update_section,"RESULT_SPIN_INDEX",i_rep_section=i_rep,i_val=result_spin_index,error=error) - CALL section_vals_val_get(update_section,"RESULT_SCALE",i_rep_section=i_rep,r_val=result_scale,error=error) + CALL section_vals_val_get(update_section,"RESULT_MO_INDEX",i_rep_section=i_rep,i_val=result_mo_index) + CALL section_vals_val_get(update_section,"RESULT_MARKED_STATE",i_rep_section=i_rep,i_val=mark_number) + CALL section_vals_val_get(update_section,"RESULT_SPIN_INDEX",i_rep_section=i_rep,i_val=result_spin_index) + CALL section_vals_val_get(update_section,"RESULT_SCALE",i_rep_section=i_rep,r_val=result_scale) mark_ind=1 IF(mark_number.GT.0)result_mo_index=marked_states(mark_number,result_spin_index,mark_ind) - CALL section_vals_val_get(update_section,"ORIG_MO_INDEX",i_rep_section=i_rep,i_val=orig_mo_index,error=error) - CALL section_vals_val_get(update_section,"ORIG_MARKED_STATE",i_rep_section=i_rep,i_val=mark_number,error=error) - CALL section_vals_val_get(update_section,"ORIG_SPIN_INDEX",i_rep_section=i_rep,i_val=orig_spin_index,error=error) - CALL section_vals_val_get(update_section,"ORIG_SCALE",i_rep_section=i_rep,r_val=orig_scale,error=error) - CALL section_vals_val_get(update_section,"ORIG_IS_VIRTUAL",i_rep_section=i_rep,l_val=orig_is_virtual,error=error) + CALL section_vals_val_get(update_section,"ORIG_MO_INDEX",i_rep_section=i_rep,i_val=orig_mo_index) + CALL section_vals_val_get(update_section,"ORIG_MARKED_STATE",i_rep_section=i_rep,i_val=mark_number) + CALL section_vals_val_get(update_section,"ORIG_SPIN_INDEX",i_rep_section=i_rep,i_val=orig_spin_index) + CALL section_vals_val_get(update_section,"ORIG_SCALE",i_rep_section=i_rep,r_val=orig_scale) + CALL section_vals_val_get(update_section,"ORIG_IS_VIRTUAL",i_rep_section=i_rep,l_val=orig_is_virtual) IF(orig_is_virtual)mark_ind=2 IF(mark_number.GT.0)orig_mo_index=marked_states(mark_number,orig_spin_index,mark_ind) - CALL section_vals_val_get(wfn_mix_section,"OVERWRITE_MOS",l_val=overwrite_mos,error=error) + CALL section_vals_val_get(wfn_mix_section,"OVERWRITE_MOS",l_val=overwrite_mos) ! first get a copy of the proper orig IF (.NOT. ORIG_IS_VIRTUAL) THEN @@ -166,7 +164,7 @@ SUBROUTINE wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, 1,mos_new(result_spin_index)%mo_set%nmo-result_mo_index+1,1) ! properly mix - CALL cp_fm_scale_and_add(result_scale,matrix_y,orig_scale,matrix_x,error) + CALL cp_fm_scale_and_add(result_scale,matrix_y,orig_scale,matrix_x) ! and copy back in the result mos CALL cp_fm_to_fm(matrix_y,mos_new(result_spin_index)%mo_set%mo_coeff, & @@ -174,13 +172,13 @@ SUBROUTINE wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, ENDDO - CALL cp_fm_release(matrix_x,error) - CALL cp_fm_release(matrix_y,error) + CALL cp_fm_release(matrix_x) + CALL cp_fm_release(matrix_y) IF(scf_env%method==special_diag_method_nr) THEN - CALL calculate_orthonormality(orthonormality,mos,error=error) + CALL calculate_orthonormality(orthonormality,mos) ELSE - CALL calculate_orthonormality(orthonormality,mos,matrix_s(1)%matrix,error=error) + CALL calculate_orthonormality(orthonormality,mos,matrix_s(1)%matrix) END IF IF (output_unit>0) THEN @@ -194,20 +192,18 @@ SUBROUTINE wfn_mix(mos, particle_set, dft_section, atomic_kind_set, qs_kind_set, DO ispin=1,SIZE(mos_new) IF(overwrite_mos)THEN - CALL cp_fm_to_fm(mos_new(ispin)%mo_set%mo_coeff,mos(ispin)%mo_set%mo_coeff,error) + CALL cp_fm_to_fm(mos_new(ispin)%mo_set%mo_coeff,mos(ispin)%mo_set%mo_coeff) IF(mos_new(1)%mo_set%use_mo_coeff_b)& - CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_set%mo_coeff,mos_new(ispin)%mo_set%mo_coeff_b,& - error=error) + CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_set%mo_coeff,mos_new(ispin)%mo_set%mo_coeff_b) END IF IF(mos(1)%mo_set%use_mo_coeff_b)& - CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_set%mo_coeff,mos(ispin)%mo_set%mo_coeff_b,& - error=error) + CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_set%mo_coeff,mos(ispin)%mo_set%mo_coeff_b) END DO CALL write_mo_set(mos_new,particle_set,dft_section=dft_section, & - atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set,error=error) + atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set) DO ispin=1,SIZE(mos_new) - CALL deallocate_mo_set(mos_new(ispin)%mo_set,error) + CALL deallocate_mo_set(mos_new(ispin)%mo_set) ENDDO DEALLOCATE(mos_new) diff --git a/src/qs_spin_orbit.F b/src/qs_spin_orbit.F index 1759ba68e8..380ae7e80a 100644 --- a/src/qs_spin_orbit.F +++ b/src/qs_spin_orbit.F @@ -66,19 +66,17 @@ MODULE qs_spin_orbit !> \param qs_env ... !> \param matrix_so ... !> \param rc ... -!> \param error ... !> \date 27.02.2009 !> \author VW !> \version 1.0 ! ***************************************************************************** - SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc,error) + SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_so REAL(dp), DIMENSION(3), INTENT(IN) :: rc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_pso_matrix', & routineP = moduleN//':'//routineN @@ -124,7 +122,7 @@ SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc,error) NULLIFY(cell,sab_orb,qs_kind_set,particle_set,para_env) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env,& qs_kind_set=qs_kind_set,& @@ -132,8 +130,7 @@ SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc,error) neighbor_list_id=neighbor_list_id,& para_env=para_env,& sab_orb=sab_orb,& - cell=cell,& - error=error) + cell=cell) nkind = SIZE(qs_kind_set) natom = SIZE(particle_set) @@ -144,7 +141,7 @@ SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc,error) CALL get_qs_kind_set(qs_kind_set=qs_kind_set,& maxco=maxco,& maxlgto=maxlgto,& - maxsgf=maxsgf, error=error) + maxsgf=maxsgf) ldai = ncoset(maxlgto+1) CALL init_orbital_pointers(ldai) @@ -174,7 +171,7 @@ SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc,error) "basis_set_list",nkind) DO ikind=1,nkind qs_kind => qs_kind_set(ikind) - CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a,error=error) + CALL get_qs_kind(qs_kind=qs_kind,basis_set=basis_set_a) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -262,7 +259,7 @@ SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc,error) rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),& rpgfb(:,jset),zetb(:,jset),& - rac,rbc,rab,soab,SIZE(rr_work,1),SIZE(rr_work,2),rr_work,error) + rac,rbc,rab,soab,SIZE(rr_work,1),SIZE(rr_work,2),rr_work) ! *** Contraction step *** @@ -320,16 +317,16 @@ SUBROUTINE build_pso_matrix(qs_env,matrix_so,rc,error) ! *** Print the spin orbit matrix, if requested *** IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/PSO",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/PSO"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/PSO",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) - CALL cp_dbcsr_write_sparse_matrix(matrix_so(1)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_so(2)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) - CALL cp_dbcsr_write_sparse_matrix(matrix_so(3)%matrix,4,after,qs_env,para_env,output_unit=iw,error=error) + CALL cp_dbcsr_write_sparse_matrix(matrix_so(1)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_write_sparse_matrix(matrix_so(2)%matrix,4,after,qs_env,para_env,output_unit=iw) + CALL cp_dbcsr_write_sparse_matrix(matrix_so(3)%matrix,4,after,qs_env,para_env,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/PSO", error=error) + "DFT%PRINT%AO_MATRICES/PSO") END IF CALL timestop(handle) diff --git a/src/qs_subsys_methods.F b/src/qs_subsys_methods.F index 23aa07bd01..94fda5cc0e 100644 --- a/src/qs_subsys_methods.F +++ b/src/qs_subsys_methods.F @@ -62,10 +62,9 @@ MODULE qs_subsys_methods !> \param cp_subsys ... !> \param cell ... !> \param cell_ref ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_subsys_create(subsys, para_env, root_section,force_env_section, subsys_section, & - use_motion_section, cp_subsys, cell, cell_ref, error) + use_motion_section, cp_subsys, cell, cell_ref) TYPE(qs_subsys_type), POINTER :: subsys TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: root_section, & @@ -74,7 +73,6 @@ SUBROUTINE qs_subsys_create(subsys, para_env, root_section,force_env_section, su LOGICAL, INTENT(IN) :: use_motion_section TYPE(cp_subsys_type), OPTIONAL, POINTER :: cp_subsys TYPE(cell_type), OPTIONAL, POINTER :: cell, cell_ref - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_subsys_create', & routineP = moduleN//':'//routineN @@ -99,8 +97,7 @@ SUBROUTINE qs_subsys_create(subsys, para_env, root_section,force_env_section, su CALL cp_subsys_create(my_cp_subsys, para_env, root_section=root_section,& force_env_section=force_env_section,& subsys_section=subsys_section,& - use_motion_section=use_motion_section,& - error=error) + use_motion_section=use_motion_section) END IF ! create cp_subsys%cell @@ -111,26 +108,26 @@ SUBROUTINE qs_subsys_create(subsys, para_env, root_section,force_env_section, su my_cell_ref => cell_ref use_ref_cell = .TRUE. ELSE - CALL cell_create(my_cell_ref, error=error) - CALL cell_clone(my_cell, my_cell_ref, error) + CALL cell_create(my_cell_ref) + CALL cell_clone(my_cell, my_cell_ref) use_ref_cell = .FALSE. END IF ELSE - cell_section => section_vals_get_subs_vals(subsys_section,"CELL",error=error) + cell_section => section_vals_get_subs_vals(subsys_section,"CELL") CALL read_cell(my_cell, my_cell_ref, use_ref_cell=use_ref_cell, & - cell_section=cell_section, para_env=para_env, error=error) + cell_section=cell_section, para_env=para_env) END IF - CALL cp_subsys_set(my_cp_subsys, cell=my_cell, error=error) - CALL write_cell(my_cell,subsys_section,cell_ref=my_cell_ref,error=error) + CALL cp_subsys_set(my_cp_subsys, cell=my_cell) + CALL write_cell(my_cell,subsys_section,cell_ref=my_cell_ref) ! setup qs_kinds - CALL cp_subsys_get(my_cp_subsys, atomic_kind_set=atomic_kind_set, error=error) - kind_section => section_vals_get_subs_vals(subsys_section,"KIND",error=error) + CALL cp_subsys_get(my_cp_subsys, atomic_kind_set=atomic_kind_set) + kind_section => section_vals_get_subs_vals(subsys_section,"KIND") CALL create_qs_kind_set(qs_kind_set, atomic_kind_set, kind_section, & - para_env, force_env_section, error) + para_env, force_env_section) CALL num_ao_el_per_molecule(my_cp_subsys%molecule_kinds_new%els, & - qs_kind_set, error=error) + qs_kind_set) ! finally create qs_subsys ALLOCATE(subsys) @@ -138,19 +135,17 @@ SUBROUTINE qs_subsys_create(subsys, para_env, root_section,force_env_section, su cp_subsys=my_cp_subsys,& cell_ref=my_cell_ref,& use_ref_cell=use_ref_cell,& - qs_kind_set=qs_kind_set,& - error=error) + qs_kind_set=qs_kind_set) - IF (.NOT.PRESENT(cell)) CALL cell_release(my_cell,error=error) - IF (.NOT.PRESENT(cell_ref)) CALL cell_release(my_cell_ref,error=error) - IF (.NOT.PRESENT(cp_subsys)) CALL cp_subsys_release(my_cp_subsys,error=error) + IF (.NOT.PRESENT(cell)) CALL cell_release(my_cell) + IF (.NOT.PRESENT(cell_ref)) CALL cell_release(my_cell_ref) + IF (.NOT.PRESENT(cp_subsys)) CALL cp_subsys_release(my_cp_subsys) END SUBROUTINE qs_subsys_create ! ***************************************************************************** !> \brief Read a molecule kind data set from the input file. !> \param molecule_kind_set ... !> \param qs_kind_set ... -!> \param error ... !> \date 22.11.2004 !> \par History !> Rustam Z. Khaliullin 10.2014 - charges and electrons of molecules @@ -158,13 +153,12 @@ END SUBROUTINE qs_subsys_create !> \author MI !> \version 1.0 ! ***************************************************************************** - SUBROUTINE num_ao_el_per_molecule(molecule_kind_set,qs_kind_set,error) + SUBROUTINE num_ao_el_per_molecule(molecule_kind_set,qs_kind_set) TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'num_ao_el_per_molecule', & routineP = moduleN//':'//routineN @@ -209,7 +203,7 @@ SUBROUTINE num_ao_el_per_molecule(molecule_kind_set,qs_kind_set,error) CALL get_qs_kind(qs_kind_set(ikind),& basis_set=orb_basis_set,& all_potential=all_potential,& - gth_potential=gth_potential, error=error) + gth_potential=gth_potential) ! Get the electronic state of the atom that is used ! to calculate the ATOMIC GUESS @@ -223,8 +217,7 @@ SUBROUTINE num_ao_el_per_molecule(molecule_kind_set,qs_kind_set,error) ispin=ispin, & ncalc=ne_explicit, & ncore=ne_core, & - nelem=ne_elem, & - error=error) + nelem=ne_elem) ! Get the number of electrons: explicit (i.e. with orbitals) and total ! Note that it is impossible to separate alpha and beta electrons @@ -266,7 +259,7 @@ SUBROUTINE num_ao_el_per_molecule(molecule_kind_set,qs_kind_set,error) ! assigned to the molecule ARBITRARY_SPIN=1 ! IF( n_occ_alpha_and_beta(1).ne.n_occ_alpha_and_beta(2) ) THEN -! CPErrorMessage(cp_failure_level,routineP,"SECOND SPIN CONFIG IS IGNORED WHEN MOLECULAR STATES ARE ASSIGNED!",error) +! CPErrorMessage(cp_failure_level,routineP,"SECOND SPIN CONFIG IS IGNORED WHEN MOLECULAR STATES ARE ASSIGNED!") ! END IF charge_molecule=REAL(z_molecule-n_occ_alpha_and_beta(ARBITRARY_SPIN),dp) CALL set_molecule_kind(molecule_kind=molecule_kind,& diff --git a/src/qs_subsys_types.F b/src/qs_subsys_types.F index 7c8b4fde2d..9a4a8376c7 100644 --- a/src/qs_subsys_types.F +++ b/src/qs_subsys_types.F @@ -72,13 +72,10 @@ MODULE qs_subsys_types ! ***************************************************************************** !> \brief retains a subsys (see doc/ReferenceCounting.html) !> \param subsys the subsys to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qs_subsys_retain(subsys, error) + SUBROUTINE qs_subsys_retain(subsys) TYPE(qs_subsys_type), POINTER :: subsys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_subsys_retain', & routineP = moduleN//':'//routineN @@ -87,37 +84,34 @@ SUBROUTINE qs_subsys_retain(subsys, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,failure) + CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP) subsys%ref_count=subsys%ref_count+1 END SUBROUTINE qs_subsys_retain ! ***************************************************************************** !> \brief releases a subsys (see doc/ReferenceCounting.html) !> \param subsys the subsys to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE qs_subsys_release(subsys, error) + SUBROUTINE qs_subsys_release(subsys) TYPE(qs_subsys_type), POINTER :: subsys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_subsys_release', & routineP = moduleN//':'//routineN IF (ASSOCIATED(subsys)) THEN - CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP) subsys%ref_count=subsys%ref_count-1 IF (subsys%ref_count==0) THEN - CALL cp_subsys_release(subsys%cp_subsys, error=error) - CALL cell_release(subsys%cell_ref,error=error) + CALL cp_subsys_release(subsys%cp_subsys) + CALL cell_release(subsys%cell_ref) IF (ASSOCIATED(subsys%qs_kind_set))& - CALL deallocate_qs_kind_set(subsys%qs_kind_set, error) + CALL deallocate_qs_kind_set(subsys%qs_kind_set) IF (ASSOCIATED(subsys%energy))& CALL deallocate_qs_energy(subsys%energy) IF (ASSOCIATED(subsys%force))& - CALL deallocate_qs_force(subsys%force,error) + CALL deallocate_qs_force(subsys%force) DEALLOCATE(subsys) END IF END IF @@ -159,7 +153,6 @@ END SUBROUTINE qs_subsys_release !> \param cp_subsys ... !> \param nelectron_total ... !> \param nelectron_spin ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_subsys_get(subsys, atomic_kinds, atomic_kind_set, particles,particle_set,& local_particles, molecules_new, molecule_set,& @@ -168,8 +161,7 @@ SUBROUTINE qs_subsys_get(subsys, atomic_kinds, atomic_kind_set, particles,partic shell_particles, core_particles, gci, multipoles,& natom, nparticle, ncore, nshell, nkind, atprop, virial, & results, cell, cell_ref, use_ref_cell, energy, force,& - qs_kind_set,cp_subsys,nelectron_total,nelectron_spin,& - error) + qs_kind_set,cp_subsys,nelectron_total,nelectron_spin) TYPE(qs_subsys_type), POINTER :: subsys TYPE(atomic_kind_list_type), OPTIONAL, & POINTER :: atomic_kinds @@ -216,7 +208,6 @@ SUBROUTINE qs_subsys_get(subsys, atomic_kinds, atomic_kind_set, particles,partic TYPE(cp_subsys_type), OPTIONAL, POINTER :: cp_subsys INTEGER, OPTIONAL :: nelectron_total INTEGER, DIMENSION(2), OPTIONAL :: nelectron_spin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_subsys_get', & routineP = moduleN//':'//routineN @@ -246,8 +237,7 @@ SUBROUTINE qs_subsys_get(subsys, atomic_kinds, atomic_kind_set, particles,partic atprop=atprop,& virial=virial,& results=results,& - cell=cell,& - error=error) + cell=cell) IF (PRESENT(cell_ref)) cell_ref => subsys%cell_ref IF (PRESENT(use_ref_cell)) use_ref_cell = subsys%use_ref_cell @@ -274,13 +264,11 @@ END SUBROUTINE qs_subsys_get !> \param qs_kind_set ... !> \param nelectron_total ... !> \param nelectron_spin ... -!> \param error ... ! ***************************************************************************** SUBROUTINE qs_subsys_set(subsys,cp_subsys,& local_particles,local_molecules_new,cell,& cell_ref, use_ref_cell, energy, force,& - qs_kind_set, nelectron_total, nelectron_spin,& - error) + qs_kind_set, nelectron_total, nelectron_spin) TYPE(qs_subsys_type), POINTER :: subsys TYPE(cp_subsys_type), OPTIONAL, POINTER :: cp_subsys TYPE(distribution_1d_type), OPTIONAL, & @@ -295,26 +283,24 @@ SUBROUTINE qs_subsys_set(subsys,cp_subsys,& OPTIONAL, POINTER :: qs_kind_set INTEGER, OPTIONAL :: nelectron_total INTEGER, DIMENSION(2), OPTIONAL :: nelectron_spin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_subsys_set', & routineP = moduleN//':'//routineN IF (PRESENT(cp_subsys)) THEN - CALL cp_subsys_retain(cp_subsys, error=error) - CALL cp_subsys_release(subsys%cp_subsys,error=error) + CALL cp_subsys_retain(cp_subsys) + CALL cp_subsys_release(subsys%cp_subsys) subsys%cp_subsys => cp_subsys END IF CALL cp_subsys_set(subsys%cp_subsys,& local_particles=local_particles,& local_molecules_new=local_molecules_new,& - cell=cell,& - error=error) + cell=cell) IF (PRESENT(cell_ref)) THEN - CALL cell_retain(cell_ref, error=error) - CALL cell_release(subsys%cell_ref,error=error) + CALL cell_retain(cell_ref) + CALL cell_release(subsys%cell_ref) subsys%cell_ref => cell_ref END IF diff --git a/src/qs_tddfpt_eigensolver.F b/src/qs_tddfpt_eigensolver.F index 4e99576933..5e38c46699 100644 --- a/src/qs_tddfpt_eigensolver.F +++ b/src/qs_tddfpt_eigensolver.F @@ -68,14 +68,12 @@ MODULE qs_tddfpt_eigensolver !> \param p_env ... !> \param qs_env ... !> \param t_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE eigensolver(p_env, qs_env, t_env, error) + SUBROUTINE eigensolver(p_env, qs_env, t_env) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(tddfpt_env_type), INTENT(INOUT) :: t_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eigensolver', & routineP = moduleN//':'//routineN @@ -92,15 +90,15 @@ SUBROUTINE eigensolver(p_env, qs_env, t_env, error) NULLIFY(logger, dft_control) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) n_ev = dft_control%tddfpt_control%n_ev nspins = dft_control%nspins ALLOCATE(ievals(n_ev), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !---------------! ! initial guess ! @@ -112,13 +110,13 @@ SUBROUTINE eigensolver(p_env, qs_env, t_env, error) WRITE (output_unit,*) END IF IF (ASSOCIATED(dft_control%tddfpt_control%lumos)) THEN - CALL co_initial_guess(t_env%evecs, ievals, n_ev, qs_env, error=error) + CALL co_initial_guess(t_env%evecs, ievals, n_ev, qs_env) ELSE IF (output_unit>0) WRITE (output_unit,*) "LUMOS are needed in TDDFPT!" - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF DO restarts=1, dft_control%tddfpt_control%n_restarts - IF (iterative_solver(ievals, t_env, p_env, qs_env, ievals, error=error)) EXIT + IF (iterative_solver(ievals, t_env, p_env, qs_env, ievals)) EXIT IF (output_unit>0) THEN WRITE (output_unit,*) " Restarting" WRITE (output_unit,*) @@ -135,7 +133,7 @@ SUBROUTINE eigensolver(p_env, qs_env, t_env, error) WRITE (output_unit,*) END IF DO restarts=1, dft_control%tddfpt_control%n_restarts - IF (iterative_solver(ievals, t_env, p_env, qs_env, t_env%evals, error=error)) EXIT + IF (iterative_solver(ievals, t_env, p_env, qs_env, t_env%evals)) EXIT IF (output_unit>0) THEN WRITE (output_unit,*) " Restarting" WRITE (output_unit,*) @@ -146,7 +144,7 @@ SUBROUTINE eigensolver(p_env, qs_env, t_env, error) ! cleanup ! !---------! DEALLOCATE(ievals, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -168,19 +166,17 @@ END SUBROUTINE eigensolver !> \param p_env ... !> \param qs_env ... !> \param out_evals ... -!> \param error ... !> \retval res ... ! ***************************************************************************** FUNCTION iterative_solver(in_evals, & t_env, p_env, qs_env, & - out_evals, error) RESULT(res) + out_evals) RESULT(res) REAL(KIND=dp), DIMENSION(:) :: in_evals TYPE(tddfpt_env_type), INTENT(INOUT) :: t_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env REAL(kind=dp), DIMENSION(:), OPTIONAL :: out_evals - TYPE(cp_error_type), INTENT(INOUT) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'iterative_solver', & @@ -227,11 +223,10 @@ FUNCTION iterative_solver(in_evals, & matrix_s=matrix_s,& dft_control=dft_control,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) tddfpt_control => dft_control%tddfpt_control - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) n_ev = tddfpt_control%n_ev nspins = dft_control%nspins @@ -254,37 +249,37 @@ FUNCTION iterative_solver(in_evals, & WRITE (output_unit,*) " Setting the maximum number of krylov vectors to ", max_kv, "!!" END IF END IF -! CPPostcondition(max_krylovspace_dim>=max_kv,cp_failure_level,routineP,error,failure) +! CPPostcondition(max_krylovspace_dim>=max_kv,cp_failure_level,routineP,failure) !----------------------! ! allocate the vectors ! !----------------------! - CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools,error=error) - CALL fm_pools_create_fm_vect(ao_mo_fm_pools, X, name=routineP//":X",error=error) - CALL fm_pools_create_fm_vect(ao_mo_fm_pools, R, name=routineP//":R",error=error) + CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools) + CALL fm_pools_create_fm_vect(ao_mo_fm_pools, X, name=routineP//":X") + CALL fm_pools_create_fm_vect(ao_mo_fm_pools, R, name=routineP//":R") ALLOCATE(evals_difference(n_ev), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(must_improve(n_ev), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(evals(max_kv, 0:max_kv), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(evals_tmp(max_kv), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(b(max_kv,nspins), Ab(max_kv,nspins), & Sb(max_kv,nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kv_fm_struct(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO spin=1, nspins NULLIFY (kv_fm_struct(spin)%struct) CALL cp_fm_struct_create(kv_fm_struct(spin)%struct, para_env, blacs_env, & - p_env%n_ao(spin), p_env%n_mo(spin),error=error) + p_env%n_ao(spin), p_env%n_mo(spin)) END DO DO spin=1, nspins DO i=1, max_kv @@ -304,9 +299,9 @@ FUNCTION iterative_solver(in_evals, & n_kv = n_ev iteration: DO - CALL allocate_krylov_vectors(b, "b-", k+1, n_kv, nspins, kv_fm_struct,error=error) - CALL allocate_krylov_vectors(Ab, "Ab-", k+1, n_kv, nspins, kv_fm_struct,error=error) - CALL allocate_krylov_vectors(Sb, "Sb-", k+1, n_kv, nspins, kv_fm_struct,error=error) + CALL allocate_krylov_vectors(b, "b-", k+1, n_kv, nspins, kv_fm_struct) + CALL allocate_krylov_vectors(Ab, "Ab-", k+1, n_kv, nspins, kv_fm_struct) + CALL allocate_krylov_vectors(Sb, "Sb-", k+1, n_kv, nspins, kv_fm_struct) DO i=1, n_kv k=k+1 @@ -315,7 +310,7 @@ FUNCTION iterative_solver(in_evals, & ! take the initial guess DO spin=1, nspins - CALL cp_fm_to_fm(t_env%evecs(k,spin)%matrix, b(k,spin)%matrix,error=error) + CALL cp_fm_to_fm(t_env%evecs(k,spin)%matrix, b(k,spin)%matrix) END DO ELSE @@ -327,9 +322,9 @@ FUNCTION iterative_solver(in_evals, & IF (tddfpt_control%invert_S) THEN CALL cp_fm_symm('L', 'U', p_env%n_ao(spin), p_env%n_mo(spin), & 1.0_dp, t_env%invS(spin)%matrix, Ab(k-1,spin)%matrix, & - 0.0_dp, b(k,spin)%matrix,error=error) + 0.0_dp, b(k,spin)%matrix) ELSE - CALL cp_fm_to_fm(Ab(k-1,spin)%matrix, b(k,spin)%matrix,error=error) + CALL cp_fm_to_fm(Ab(k-1,spin)%matrix, b(k,spin)%matrix) END IF END DO @@ -339,22 +334,22 @@ FUNCTION iterative_solver(in_evals, & ! create the new davidson vector DO spin=1, nspins - CALL cp_fm_set_all(R(spin)%matrix, 0.0_dp, error=error) + CALL cp_fm_set_all(R(spin)%matrix, 0.0_dp) DO j=1, k-i - CALL cp_fm_to_fm(Ab(j,spin)%matrix, X(spin)%matrix,error=error) + CALL cp_fm_to_fm(Ab(j,spin)%matrix, X(spin)%matrix) CALL cp_fm_scale_and_add(1.0_dp, X(spin)%matrix, & - -evals(iev,iter-1), Sb(j,spin)%matrix,error=error) + -evals(iev,iter-1), Sb(j,spin)%matrix) CALL cp_fm_get_element(Us%matrix, j, iev, tmp) CALL cp_fm_scale_and_add(1.0_dp, R(spin)%matrix, & - tmp, X(spin)%matrix,error=error) + tmp, X(spin)%matrix) END DO IF (tddfpt_control%invert_S) THEN CALL cp_fm_symm('L', 'U', p_env%n_ao(spin), p_env%n_mo(spin), & 1.0_dp, t_env%invS(spin)%matrix, R(spin)%matrix, & - 0.0_dp, X(spin)%matrix,error=error) + 0.0_dp, X(spin)%matrix) ELSE - CALL cp_fm_to_fm(R(spin)%matrix, X(spin)%matrix,error=error) + CALL cp_fm_to_fm(R(spin)%matrix, X(spin)%matrix) END IF !----------------! @@ -371,58 +366,58 @@ FUNCTION iterative_solver(in_evals, & tmp2=MAX(tmp2,100*EPSILON(1.0_dp)) DO row=1, p_env%n_ao(spin) CALL cp_fm_get_element(X(spin)%matrix, row, col, tmp) - CALL cp_fm_set_element(b(k,spin)%matrix, row, col, tmp/tmp2,error=error) + CALL cp_fm_set_element(b(k,spin)%matrix, row, col, tmp/tmp2) END DO END DO ELSE - CALL cp_fm_to_fm(X(spin)%matrix, b(k,spin)%matrix,error=error) + CALL cp_fm_to_fm(X(spin)%matrix, b(k,spin)%matrix) END IF END DO ELSE IF (output_unit>0) WRITE (output_unit,*) "unknown mode" - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF - CALL p_preortho(p_env, qs_env, b(k,:),error=error) + CALL p_preortho(p_env, qs_env, b(k,:)) DO j=1, tddfpt_control%n_reortho - CALL reorthogonalize(b(k,:), b, Sb, R, k-1,error=error) ! R is temp + CALL reorthogonalize(b(k,:), b, Sb, R, k-1) ! R is temp END DO - CALL normalize(b(k,:), R, matrix_s,error=error) ! R is temp + CALL normalize(b(k,:), R, matrix_s) ! R is temp DO spin=1, nspins - CALL cp_fm_to_fm(b(k,spin)%matrix, X(spin)%matrix,error=error) + CALL cp_fm_to_fm(b(k,spin)%matrix, X(spin)%matrix) END DO CALL apply_op(X, Ab(k,:), p_env, qs_env, & - dft_control%tddfpt_control%do_kernel,error=error) - CALL p_postortho(p_env, qs_env, Ab(k,:),error=error) + dft_control%tddfpt_control%do_kernel) + CALL p_postortho(p_env, qs_env, Ab(k,:)) DO spin=1, nspins CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, & b(k,spin)%matrix, & Sb(k,spin)%matrix, & - p_env%n_mo(spin),error=error) + p_env%n_mo(spin)) END DO END DO !--------------------------------------------! ! deallocate memory for the reduced matrices ! !--------------------------------------------! - IF (ASSOCIATED(Atilde%matrix)) CALL cp_fm_release(Atilde%matrix,error=error) - IF (ASSOCIATED(Us%matrix)) CALL cp_fm_release(Us%matrix,error=error) - IF (ASSOCIATED(tilde_fm_struct)) CALL cp_fm_struct_release(tilde_fm_struct,error=error) + IF (ASSOCIATED(Atilde%matrix)) CALL cp_fm_release(Atilde%matrix) + IF (ASSOCIATED(Us%matrix)) CALL cp_fm_release(Us%matrix) + IF (ASSOCIATED(tilde_fm_struct)) CALL cp_fm_struct_release(tilde_fm_struct) !------------------------------------------! ! allocate memory for the reduced matrices ! !------------------------------------------! - CALL cp_fm_struct_create(tilde_fm_struct, para_env, blacs_env, k, k,error=error) + CALL cp_fm_struct_create(tilde_fm_struct, para_env, blacs_env, k, k) CALL cp_fm_create(Atilde%matrix, & tilde_fm_struct, & - routineP//"Atilde",error=error) + routineP//"Atilde") CALL cp_fm_create(Us%matrix, & tilde_fm_struct, & - routineP//"Us",error=error) + routineP//"Us") !---------------------------------------! ! calc the matrix Atilde = transp(b)*Ab ! @@ -431,10 +426,10 @@ FUNCTION iterative_solver(in_evals, & DO j=1, k Atilde_ij= 0.0_dp DO spin=1, nspins - CALL cp_fm_trace(b(i,spin)%matrix, Ab(j,spin)%matrix, tmp,error=error) + CALL cp_fm_trace(b(i,spin)%matrix, Ab(j,spin)%matrix, tmp) Atilde_ij = Atilde_ij + tmp END DO - CALL cp_fm_set_element(Atilde%matrix, i, j, Atilde_ij,error=error) + CALL cp_fm_set_element(Atilde%matrix, i, j, Atilde_ij) END DO END DO @@ -442,7 +437,7 @@ FUNCTION iterative_solver(in_evals, & ! diagonalize Atilde ! !--------------------! evals_tmp(:) = evals(:,iter) - CALL cp_fm_syevd(Atilde%matrix, Us%matrix, evals_tmp(:),error=error) + CALL cp_fm_syevd(Atilde%matrix, Us%matrix, evals_tmp(:)) evals(:,iter) = evals_tmp(:) !-------------------! @@ -502,11 +497,11 @@ FUNCTION iterative_solver(in_evals, & DO spin=1, nspins DO j=1, n_ev - CALL cp_fm_set_all(t_env%evecs(j,spin)%matrix, 0.0_dp,error=error) + CALL cp_fm_set_all(t_env%evecs(j,spin)%matrix, 0.0_dp) DO i=1, k CALL cp_fm_get_element(Us%matrix, i, j, tmp) CALL cp_fm_scale_and_add(1.0_dp, t_env%evecs(j,spin)%matrix, & - tmp, b(i,spin)%matrix,error=error) + tmp, b(i,spin)%matrix) END DO END DO END DO @@ -514,35 +509,35 @@ FUNCTION iterative_solver(in_evals, & DO spin=1, nspins DO i=1, max_kv IF (ASSOCIATED(b(i,spin)%matrix)) & - CALL cp_fm_release(b(i,spin)%matrix,error=error) + CALL cp_fm_release(b(i,spin)%matrix) IF (ASSOCIATED(Ab(i,spin)%matrix)) & - CALL cp_fm_release(Ab(i,spin)%matrix,error=error) + CALL cp_fm_release(Ab(i,spin)%matrix) IF (ASSOCIATED(Sb(i,spin)%matrix)) & - CALL cp_fm_release(Sb(i,spin)%matrix,error=error) + CALL cp_fm_release(Sb(i,spin)%matrix) END DO END DO !----------! ! clean up ! !----------! - IF (ASSOCIATED(Atilde%matrix)) CALL cp_fm_release(Atilde%matrix,error=error) - IF (ASSOCIATED(Us%matrix)) CALL cp_fm_release(Us%matrix,error=error) - IF (ASSOCIATED(tilde_fm_struct)) CALL cp_fm_struct_release(tilde_fm_struct,error) - CALL fm_pools_give_back_fm_vect(ao_mo_fm_pools, X,error=error) - CALL fm_pools_give_back_fm_vect(ao_mo_fm_pools, R,error=error) + IF (ASSOCIATED(Atilde%matrix)) CALL cp_fm_release(Atilde%matrix) + IF (ASSOCIATED(Us%matrix)) CALL cp_fm_release(Us%matrix) + IF (ASSOCIATED(tilde_fm_struct)) CALL cp_fm_struct_release(tilde_fm_struct) + CALL fm_pools_give_back_fm_vect(ao_mo_fm_pools, X) + CALL fm_pools_give_back_fm_vect(ao_mo_fm_pools, R) DO spin=1, nspins - CALL cp_fm_struct_release(kv_fm_struct(spin)%struct,error=error) + CALL cp_fm_struct_release(kv_fm_struct(spin)%struct) DO i=1, max_kv IF (ASSOCIATED(b(i,spin)%matrix)) & - CALL cp_fm_release(b(i,spin)%matrix,error=error) + CALL cp_fm_release(b(i,spin)%matrix) IF (ASSOCIATED(Ab(i,spin)%matrix)) & - CALL cp_fm_release(Ab(i,spin)%matrix,error=error) + CALL cp_fm_release(Ab(i,spin)%matrix) IF (ASSOCIATED(Sb(i,spin)%matrix)) & - CALL cp_fm_release(Sb(i,spin)%matrix,error=error) + CALL cp_fm_release(Sb(i,spin)%matrix) END DO END DO DEALLOCATE(b, Ab, Sb, evals, evals_tmp, evals_difference, must_improve, kv_fm_struct, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(X, R, b, Ab, Sb, kv_fm_struct) CALL timestop(handle) @@ -563,15 +558,13 @@ END FUNCTION iterative_solver !> \param p_env ... !> \param qs_env ... !> \param do_kernel ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_op(X, R, p_env, qs_env, do_kernel, error) + SUBROUTINE apply_op(X, R, p_env, qs_env, do_kernel) TYPE(cp_fm_p_type), DIMENSION(:) :: X, R TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: do_kernel - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'apply_op', & routineP = moduleN//':'//routineN @@ -585,13 +578,13 @@ SUBROUTINE apply_op(X, R, p_env, qs_env, do_kernel, error) CALL timeset(routineN,handle) counter = counter + 1 - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) nspins = dft_control%nspins !------------! ! R = HX-SXL ! !------------! - CALL p_op_l1(p_env, qs_env, X, R,error=error) ! acts on both spins, result in R + CALL p_op_l1(p_env, qs_env, X, R) ! acts on both spins, result in R !-----------------! ! calc P1 and ! @@ -599,26 +592,26 @@ SUBROUTINE apply_op(X, R, p_env, qs_env, do_kernel, error) !-----------------! IF (do_kernel) THEN DO spin=1, nspins - CALL cp_dbcsr_set(p_env%p1(spin)%matrix, 0.0_dp, error=error) ! optimize? + CALL cp_dbcsr_set(p_env%p1(spin)%matrix, 0.0_dp) ! optimize? CALL cp_dbcsr_plus_fm_fm_t(p_env%p1(spin)%matrix,& matrix_v=p_env%psi0d(spin)%matrix,& matrix_g=X(spin)%matrix,& ncol=p_env%n_mo(spin), & - alpha=0.5_dp,error=error) + alpha=0.5_dp) CALL cp_dbcsr_plus_fm_fm_t(p_env%p1(spin)%matrix,& matrix_v=X(spin)%matrix,& matrix_g=p_env%psi0d(spin)%matrix,& ncol=p_env%n_mo(spin), & - alpha=0.5_dp,error=error) + alpha=0.5_dp) END DO DO spin=1, nspins - CALL cp_fm_set_all(X(spin)%matrix, 0.0_dp,error=error) + CALL cp_fm_set_all(X(spin)%matrix, 0.0_dp) END DO CALL p_op_l2(p_env, qs_env, p_env%p1, X, & - alpha=1.0_dp, beta=0.0_dp,error=error) ! X = beta*X + alpha*K(P1)*C + alpha=1.0_dp, beta=0.0_dp) ! X = beta*X + alpha*K(P1)*C DO spin=1, nspins CALL cp_fm_scale_and_add(1.0_dp, R(spin)%matrix, & - 1.0_dp, X(spin)%matrix,error=error) ! add X to R + 1.0_dp, X(spin)%matrix) ! add X to R END DO END IF @@ -634,10 +627,9 @@ END SUBROUTINE apply_op !> \param n_v ... !> \param nspins ... !> \param fm_struct ... -!> \param error ... ! ***************************************************************************** SUBROUTINE allocate_krylov_vectors(vectors, vectors_name, & - startv, n_v, nspins, fm_struct, error) + startv, n_v, nspins, fm_struct) TYPE(cp_fm_p_type), DIMENSION(:, :), & POINTER :: vectors @@ -645,7 +637,6 @@ SUBROUTINE allocate_krylov_vectors(vectors, vectors_name, & INTEGER, INTENT(IN) :: startv, n_v, nspins TYPE(cp_fm_struct_p_type), & DIMENSION(:), POINTER :: fm_struct - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_krylov_vectors', & routineP = moduleN//':'//routineN @@ -659,7 +650,7 @@ SUBROUTINE allocate_krylov_vectors(vectors, vectors_name, & mat_name = routineP//vectors_name//TRIM(cp_to_string(index))& //","//TRIM(cp_to_string(spin)) CALL cp_fm_create(vectors(index,spin)%matrix, & - fm_struct(spin)%struct, mat_name,error=error) + fm_struct(spin)%struct, mat_name) IF (.NOT.ASSOCIATED(vectors(index,spin)%matrix)) & CALL stop_program(routineN,moduleN,__LINE__,& "Could not allocate "//TRIM(mat_name)//".") diff --git a/src/qs_tddfpt_module.F b/src/qs_tddfpt_module.F index 7ad19775d5..dd5aa43fbb 100644 --- a/src/qs_tddfpt_module.F +++ b/src/qs_tddfpt_module.F @@ -60,12 +60,10 @@ MODULE qs_tddfpt_module ! ***************************************************************************** !> \brief Performs the perturbation calculation !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_calculation(qs_env, error) + SUBROUTINE tddfpt_calculation(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tddfpt_calculation', & routineP = moduleN//':'//routineN @@ -80,40 +78,40 @@ SUBROUTINE tddfpt_calculation(qs_env, error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(input,ks_env) - CALL get_qs_env(qs_env, ks_env=ks_env, input=input,error=error) - dft_section => section_vals_get_subs_vals(input,"DFT",error=error) + CALL get_qs_env(qs_env, ks_env=ks_env, input=input) + dft_section => section_vals_get_subs_vals(input,"DFT") - IF (section_get_ival(dft_section,"EXCITATIONS",error=error) /= tddfpt_excitations) RETURN + IF (section_get_ival(dft_section,"EXCITATIONS") /= tddfpt_excitations) RETURN CALL cite_reference(Iannuzzi2005) CALL timeset(routineN,handle) - IF (section_get_ival(dft_section,"TDDFPT%OE_CORR",error=error) /= oe_none) THEN - CALL orbital_eigenvalue_correction(qs_env, error) + IF (section_get_ival(dft_section,"TDDFPT%OE_CORR") /= oe_none) THEN + CALL orbital_eigenvalue_correction(qs_env) END IF NULLIFY(p_env) iw = cp_print_key_unit_nr(logger,dft_section,"PRINT%PROGRAM_BANNER",& - extension=".Log",error=error) + extension=".Log") CALL tddfpt_header(iw) CALL cp_print_key_finished_output(iw,logger,dft_section,& - "PRINT%PROGRAM_BANNER",error=error) + "PRINT%PROGRAM_BANNER") !---------------------------------------! ! we don't want to update the KS matrix ! !---------------------------------------! - CALL set_ks_env(ks_env, rho_changed=.FALSE., error=error) + CALL set_ks_env(ks_env, rho_changed=.FALSE.) - CALL tddfpt_init(p_env, t_env, qs_env,error=error) + CALL tddfpt_init(p_env, t_env, qs_env) - CALL eigensolver(p_env, qs_env, t_env, error) + CALL eigensolver(p_env, qs_env, t_env) - CALL find_contributions(qs_env, t_env, error) + CALL find_contributions(qs_env, t_env) - CALL tddfpt_cleanup(t_env, p_env,error=error) + CALL tddfpt_cleanup(t_env, p_env) CALL timestop(handle) @@ -123,12 +121,10 @@ END SUBROUTINE tddfpt_calculation !> \brief Apply a special potential to obtain better !> orbital eigenvalues. !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE orbital_eigenvalue_correction(qs_env, error) + SUBROUTINE orbital_eigenvalue_correction(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'orbital_eigenvalue_correction', & @@ -144,11 +140,11 @@ SUBROUTINE orbital_eigenvalue_correction(qs_env, error) TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(section_vals_type), POINTER :: input, xc_fun_orig, xc_fun_tmp - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) failure = .FALSE. NULLIFY(logger, scf_env, input, energy, matrix_ks, rho) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) IF (output_unit>0) THEN @@ -163,34 +159,30 @@ SUBROUTINE orbital_eigenvalue_correction(qs_env, error) scf_env=scf_env,& input=input,& matrix_ks=matrix_ks,& - rho=rho,& - error=error) + rho=rho) !----------------------! ! KS matrix without XC ! !----------------------! - xc_fun_orig => section_vals_get_subs_vals(input,"DFT%XC%XC_FUNCTIONAL",& - error=error) - CALL section_vals_retain(xc_fun_orig,error=error) + xc_fun_orig => section_vals_get_subs_vals(input,"DFT%XC%XC_FUNCTIONAL") + CALL section_vals_retain(xc_fun_orig) NULLIFY(xc_fun_tmp) - CALL section_vals_create(xc_fun_tmp,xc_fun_orig%section,error=error) - CALL section_vals_set_subs_vals(input,"DFT%XC%XC_FUNCTIONAL",xc_fun_tmp,& - error=error) - CALL section_vals_release(xc_fun_tmp,error=error) + CALL section_vals_create(xc_fun_tmp,xc_fun_orig%section) + CALL section_vals_set_subs_vals(input,"DFT%XC%XC_FUNCTIONAL",xc_fun_tmp) + CALL section_vals_release(xc_fun_tmp) - CALL get_qs_env(qs_env, energy=energy, error=error) + CALL get_qs_env(qs_env, energy=energy) CALL qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces=.FALSE.,& - just_energy=.FALSE., error=error) + just_energy=.FALSE.) - CALL section_vals_set_subs_vals(input,"DFT%XC%XC_FUNCTIONAL",xc_fun_orig,& - error=error) - CALL section_vals_release(xc_fun_orig,error=error) + CALL section_vals_set_subs_vals(input,"DFT%XC%XC_FUNCTIONAL",xc_fun_orig) + CALL section_vals_release(xc_fun_orig) - CALL section_vals_val_get(input,"DFT%TDDFPT%OE_CORR",i_val=oe_corr,error=error) + CALL section_vals_val_get(input,"DFT%TDDFPT%OE_CORR",i_val=oe_corr) IF (oe_corr == oe_saop .OR. & oe_corr == oe_lb .OR. & oe_corr == oe_gllb) THEN - CALL add_saop_pot(matrix_ks, qs_env, oe_corr, error) + CALL add_saop_pot(matrix_ks, qs_env, oe_corr) ELSE IF (oe_corr == oe_sic) THEN END IF diff --git a/src/qs_tddfpt_types.F b/src/qs_tddfpt_types.F index 8bffe81f6c..223fd335b5 100644 --- a/src/qs_tddfpt_types.F +++ b/src/qs_tddfpt_types.F @@ -55,14 +55,12 @@ MODULE qs_tddfpt_types !> \param t_env ... !> \param p_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_env_allocate(t_env, p_env, qs_env, error) + SUBROUTINE tddfpt_env_allocate(t_env, p_env, qs_env) TYPE(tddfpt_env_type), INTENT(inout) :: t_env TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tddfpt_env_allocate', & routineP = moduleN//':'//routineN @@ -78,12 +76,11 @@ SUBROUTINE tddfpt_env_allocate(t_env, p_env, qs_env, error) CALL get_qs_env(qs_env,& dft_control=dft_control,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) n_ev = dft_control%tddfpt_control%n_ev n_spins = dft_control%nspins - CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=t_env%ao_mo_fm_pools,error=error) + CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=t_env%ao_mo_fm_pools) ALLOCATE (t_env%evals(n_ev),STAT=stat) IF (stat /=0 ) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -95,7 +92,7 @@ SUBROUTINE tddfpt_env_allocate(t_env, p_env, qs_env, error) DO spin=1,n_spins DO i=1, n_ev CALL fm_pool_create_fm(t_env%ao_mo_fm_pools(spin)%pool, & - t_env%evecs(i,spin)%matrix,error=error) + t_env%evecs(i,spin)%matrix) END DO END DO @@ -108,9 +105,9 @@ SUBROUTINE tddfpt_env_allocate(t_env, p_env, qs_env, error) DO spin=1, n_spins NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct, para_env, blacs_env, & - p_env%n_ao(spin), p_env%n_ao(spin),error=error) - CALL cp_fm_create(t_env%invS(spin)%matrix, fm_struct, routineP//"invS",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + p_env%n_ao(spin), p_env%n_ao(spin)) + CALL cp_fm_create(t_env%invS(spin)%matrix, fm_struct, routineP//"invS") + CALL cp_fm_struct_release(fm_struct) END DO END SUBROUTINE tddfpt_env_allocate @@ -118,12 +115,10 @@ END SUBROUTINE tddfpt_env_allocate ! ***************************************************************************** !> \brief ... !> \param t_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_env_deallocate(t_env,error) + SUBROUTINE tddfpt_env_deallocate(t_env) TYPE(tddfpt_env_type), INTENT(inout) :: t_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tddfpt_env_deallocate', & routineP = moduleN//':'//routineN @@ -133,13 +128,13 @@ SUBROUTINE tddfpt_env_deallocate(t_env,error) DO spin=1, SIZE(t_env%evecs, 2) DO i=1, SIZE(t_env%evecs, 1) CALL fm_pool_give_back_fm(t_env%ao_mo_fm_pools(spin)%pool, & - t_env%evecs(i,spin)%matrix,error=error) + t_env%evecs(i,spin)%matrix) END DO END DO DO spin=1, SIZE(t_env%invS) IF (ASSOCIATED(t_env%invS(spin)%matrix)) & - CALL cp_fm_release(t_env%invS(spin)%matrix,error=error) + CALL cp_fm_release(t_env%invS(spin)%matrix) END DO DEALLOCATE (t_env%invS,t_env%evecs,t_env%evals,STAT=stat) IF (stat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& diff --git a/src/qs_tddfpt_utils.F b/src/qs_tddfpt_utils.F index 09e316c370..75be5bedae 100644 --- a/src/qs_tddfpt_utils.F +++ b/src/qs_tddfpt_utils.F @@ -74,14 +74,12 @@ MODULE qs_tddfpt_utils !> \param t_env tddfpt environment to be initialized !> \param qs_env Quickstep environment with the results of a !> ground state calcualtion -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_init(p_env, t_env, qs_env, error) + SUBROUTINE tddfpt_init(p_env, t_env, qs_env) TYPE(qs_p_env_type), POINTER :: p_env TYPE(tddfpt_env_type), INTENT(out) :: t_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tddfpt_init', & routineP = moduleN//':'//routineN @@ -90,14 +88,14 @@ SUBROUTINE tddfpt_init(p_env, t_env, qs_env, error) ! create the p_env ! !------------------! - CALL p_env_create(p_env, qs_env, orthogonal_orbitals=.TRUE.,error=error) - CALL p_env_psi0_changed(p_env, qs_env,error=error) ! update the m_epsilon matrix + CALL p_env_create(p_env, qs_env, orthogonal_orbitals=.TRUE.) + CALL p_env_psi0_changed(p_env, qs_env) ! update the m_epsilon matrix !------------------! ! create the t_env ! !------------------! - CALL tddfpt_env_allocate(t_env, p_env, qs_env,error=error) - CALL tddfpt_env_init(t_env, qs_env,error=error) + CALL tddfpt_env_allocate(t_env, p_env, qs_env) + CALL tddfpt_env_init(t_env, qs_env) END SUBROUTINE tddfpt_init @@ -105,13 +103,11 @@ END SUBROUTINE tddfpt_init !> \brief Initialize t_env with meaningfull values. !> \param t_env ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_env_init(t_env, qs_env,error) + SUBROUTINE tddfpt_env_init(t_env, qs_env) TYPE(tddfpt_env_type), INTENT(inout) :: t_env TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tddfpt_env_init', & routineP = moduleN//':'//routineN @@ -123,13 +119,13 @@ SUBROUTINE tddfpt_env_init(t_env, qs_env,error) NULLIFY(matrix_s, dft_control) - CALL get_qs_env(qs_env, matrix_s=matrix_s, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s, dft_control=dft_control) n_spins = dft_control%nspins IF (dft_control%tddfpt_control%invert_S) THEN DO spin=1, n_spins - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, t_env%invS(spin)%matrix,error=error) - CALL cp_fm_cholesky_decompose(t_env%invS(spin)%matrix,error=error) - CALL cp_fm_cholesky_invert(t_env%invS(spin)%matrix,error=error) + CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, t_env%invS(spin)%matrix) + CALL cp_fm_cholesky_decompose(t_env%invS(spin)%matrix) + CALL cp_fm_cholesky_invert(t_env%invS(spin)%matrix) END DO END IF @@ -139,19 +135,17 @@ END SUBROUTINE tddfpt_env_init !> \brief ... !> \param t_env ... !> \param p_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tddfpt_cleanup(t_env, p_env, error) + SUBROUTINE tddfpt_cleanup(t_env, p_env) TYPE(tddfpt_env_type), INTENT(inout) :: t_env TYPE(qs_p_env_type), POINTER :: p_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tddfpt_cleanup', & routineP = moduleN//':'//routineN - CALL tddfpt_env_deallocate(t_env,error=error) - CALL p_env_release(p_env,error=error) + CALL tddfpt_env_deallocate(t_env) + CALL p_env_release(p_env) END SUBROUTINE tddfpt_cleanup @@ -161,16 +155,14 @@ END SUBROUTINE tddfpt_cleanup !> \param energies ... !> \param n_v ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE co_initial_guess(matrices, energies, n_v, qs_env, error) + SUBROUTINE co_initial_guess(matrices, energies, n_v, qs_env) TYPE(cp_fm_p_type), DIMENSION(:, :), & POINTER :: matrices REAL(kind=DP), DIMENSION(:), INTENT(OUT) :: energies INTEGER, INTENT(IN) :: n_v TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'co_initial_guess', & routineP = moduleN//':'//routineN @@ -193,7 +185,7 @@ SUBROUTINE co_initial_guess(matrices, energies, n_v, qs_env, error) NULLIFY(dft_control) failure=.FALSE. - CALL get_qs_env(qs_env, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, dft_control=dft_control) tddfpt_control => dft_control%tddfpt_control n_spins = dft_control%nspins energies = 0.0_dp @@ -208,7 +200,7 @@ SUBROUTINE co_initial_guess(matrices, energies, n_v, qs_env, error) n_rows = matrices(1,spin)%matrix%matrix_struct%nrow_global DO i=1, n_v - CALL cp_fm_set_all(matrices(i,spin)%matrix, 0.0_dp,error=error) + CALL cp_fm_set_all(matrices(i,spin)%matrix, 0.0_dp) END DO CALL get_mo_set(qs_env%mos(spin)%mo_set, eigenvalues=orbital_eigenvalues) @@ -255,9 +247,9 @@ SUBROUTINE co_initial_guess(matrices, energies, n_v, qs_env, error) END DO ALLOCATE(lumos(n_rows, n_lumos), guess(n_rows, n_orbits), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL cp_fm_get_submatrix(tddfpt_control%lumos(spin)%matrix, lumos, & - start_col=1, n_cols=n_lumos,error=error) + start_col=1, n_cols=n_lumos) !-------------------! ! fill the matrices ! @@ -268,13 +260,13 @@ SUBROUTINE co_initial_guess(matrices, energies, n_v, qs_env, error) CALL dcopy(n_rows, lumos(:,sorter_iterator%lumo), 1, & guess(:,sorter_iterator%orbit),1) CALL cp_fm_set_submatrix(matrices(i,spin)%matrix, & - guess(:,1:n_orbits),error=error) + guess(:,1:n_orbits)) energies(i) = energies(i) + sorter_iterator%value/REAL(n_spins,dp) sorter_iterator=>sorter_iterator%next END DO IF (n_v > n_orbits*n_lumos) THEN DO i=n_orbits*n_lumos+1, n_v - CALL cp_fm_init_random(matrices(i,spin)%matrix, n_orbits,error=error) + CALL cp_fm_init_random(matrices(i,spin)%matrix, n_orbits) energies(i)=1.0E38_dp END DO END IF @@ -298,13 +290,11 @@ END SUBROUTINE co_initial_guess !> \brief ... !> \param qs_env ... !> \param t_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE find_contributions(qs_env, t_env, error) + SUBROUTINE find_contributions(qs_env, t_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(tddfpt_env_type), INTENT(IN) :: t_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'find_contributions', & routineP = moduleN//':'//routineN @@ -327,9 +317,9 @@ SUBROUTINE find_contributions(qs_env, t_env, error) NULLIFY(S_lumos, logger, matrix_s, dft_control) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CALL get_qs_env(qs_env, matrix_s=matrix_s, dft_control=dft_control, error=error) + CALL get_qs_env(qs_env, matrix_s=matrix_s, dft_control=dft_control) IF (output_unit>0) WRITE (output_unit,*) IF (output_unit>0) WRITE (output_unit,*) @@ -339,21 +329,21 @@ SUBROUTINE find_contributions(qs_env, t_env, error) n_spins = dft_control%nspins ALLOCATE(S_lumos(n_spins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO spin=1, n_spins nrows(spin) = t_control%lumos(spin)%matrix%matrix_struct%nrow_global nhomos(spin) = t_env%evecs(1,spin)%matrix%matrix_struct%ncol_global nlumos(spin) = t_control%lumos(spin)%matrix%matrix_struct%ncol_global CALL cp_fm_create(S_lumos(spin)%matrix, t_control%lumos(spin)%matrix%matrix_struct, & - "S times lumos", error=error) + "S times lumos") CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, t_control%lumos(spin)%matrix, & - S_lumos(spin)%matrix, nlumos(spin), 1.0_dp, 0.0_dp,error=error) + S_lumos(spin)%matrix, nlumos(spin), 1.0_dp, 0.0_dp) END DO ALLOCATE(homo_coeff_col(MAXVAL(nrows(1:n_spins)),1), & lumo_coeff_col(MAXVAL(nrows(1:n_spins)),1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1, n_ev IF (output_unit>0) THEN WRITE (output_unit,'(A,I3,5X,F15.6)') " excited state : ", i, t_env%evals(i)*evolt @@ -370,10 +360,10 @@ SUBROUTINE find_contributions(qs_env, t_env, error) END IF searchloop: DO occ=nhomos(spin), 1, -1 CALL cp_fm_get_submatrix(t_env%evecs(i,spin)%matrix, homo_coeff_col, & - 1, occ, nrows(spin), 1, error=error) + 1, occ, nrows(spin), 1) DO virt=1, nlumos(spin) CALL cp_fm_get_submatrix(S_lumos(spin)%matrix, lumo_coeff_col, & - 1, virt, nrows(spin), 1, error=error) + 1, virt, nrows(spin), 1) contribution = 0.0_dp DO j=1, nrows(spin) contribution = contribution + homo_coeff_col(j,1)*lumo_coeff_col(j,1) @@ -397,13 +387,13 @@ SUBROUTINE find_contributions(qs_env, t_env, error) ENDIF DO spin=1, n_spins - CALL cp_fm_release(S_lumos(spin)%matrix, error=error) + CALL cp_fm_release(S_lumos(spin)%matrix) END DO DEALLOCATE(homo_coeff_col, lumo_coeff_col, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(S_lumos, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE find_contributions @@ -412,14 +402,12 @@ END SUBROUTINE find_contributions !> \param X ... !> \param tmp_vec ... !> \param metric ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE normalize(X, tmp_vec, metric, error) + SUBROUTINE normalize(X, tmp_vec, metric) TYPE(cp_fm_p_type), DIMENSION(:) :: x, tmp_vec TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: metric - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: n_spins, spin REAL(KIND=dp) :: norm, tmp @@ -432,14 +420,14 @@ SUBROUTINE normalize(X, tmp_vec, metric, error) CALL cp_dbcsr_sm_fm_multiply(metric(1)%matrix, X(spin)%matrix, & tmp_vec(spin)%matrix, & X(spin)%matrix%matrix_struct%ncol_global, & - 1.0_dp, 0.0_dp,error=error) - CALL cp_fm_trace(X(spin)%matrix, tmp_vec(spin)%matrix, tmp,error=error) + 1.0_dp, 0.0_dp) + CALL cp_fm_trace(X(spin)%matrix, tmp_vec(spin)%matrix, tmp) norm = norm + tmp END DO norm = SQRT(norm) DO spin=1, n_spins - CALL cp_fm_scale((1.0_dp/norm), X(spin)%matrix,error=error) + CALL cp_fm_scale((1.0_dp/norm), X(spin)%matrix) END DO END SUBROUTINE normalize @@ -455,15 +443,13 @@ END SUBROUTINE normalize !> \param SV_set ... !> \param work ... !> \param n ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE reorthogonalize(X, V_set, SV_set, work, n, error) + SUBROUTINE reorthogonalize(X, V_set, SV_set, work, n) TYPE(cp_fm_p_type), DIMENSION(:) :: X TYPE(cp_fm_p_type), DIMENSION(:, :) :: V_set, SV_set TYPE(cp_fm_p_type), DIMENSION(:) :: work INTEGER, INTENT(IN) :: n - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'reorthogonalize', & routineP = moduleN//':'//routineN @@ -477,18 +463,18 @@ SUBROUTINE reorthogonalize(X, V_set, SV_set, work, n, error) n_spins = SIZE(X) DO spin=1, n_spins - CALL cp_fm_to_fm(X(spin)%matrix, work(spin)%matrix,error=error) + CALL cp_fm_to_fm(X(spin)%matrix, work(spin)%matrix) END DO DO i=1, n dot_product = 0.0_dp DO spin=1, n_spins - CALL cp_fm_trace(SV_set(i,spin)%matrix, work(spin)%matrix, tmp,error=error) + CALL cp_fm_trace(SV_set(i,spin)%matrix, work(spin)%matrix, tmp) dot_product = dot_product + tmp END DO DO spin=1, n_spins CALL cp_fm_scale_and_add(1.0_dp, X(spin)%matrix, & - -1.0_dp*dot_product, V_set(i,spin)%matrix,error=error) + -1.0_dp*dot_product, V_set(i,spin)%matrix) END DO END DO diff --git a/src/qs_vxc.F b/src/qs_vxc.F index 7658197a26..e4423efa2f 100644 --- a/src/qs_vxc.F +++ b/src/qs_vxc.F @@ -86,8 +86,6 @@ MODULE qs_vxc !> \param edisp ... !> \param dispersion_env ... !> \param adiabatic_rescale_factor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> - 05.2002 modified to use the mp_allgather function each pe !> computes only part of the grid and this is broadcasted to all @@ -99,7 +97,7 @@ MODULE qs_vxc !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc,& - just_energy, edisp, dispersion_env, adiabatic_rescale_factor, error) + just_energy, edisp, dispersion_env, adiabatic_rescale_factor) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(qs_rho_type), POINTER :: rho_struct @@ -111,7 +109,6 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, TYPE(qs_dispersion_type), OPTIONAL, & POINTER :: dispersion_env REAL(KIND=dp), INTENT(in), OPTIONAL :: adiabatic_rescale_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'qs_vxc_create', & routineP = moduleN//':'//routineN @@ -141,8 +138,8 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, CALL timeset( routineN ,handle) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(vxc_rho),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(vxc_tau),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(vxc_rho),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(vxc_tau),cp_failure_level,routineP,failure) NULLIFY(dft_control, pw_env, auxbas_pw_pool, xc_pw_pool, vdw_pw_pool, cell, my_vxc_rho, & tmp_pw, tmp_g, tmp_g2, my_vxc_tau, rho_g, rho_r, tau, rho_m_rspace, & rho_m_gspace, rho_nlcc, rho_nlcc_g,rho_struct_r,rho_struct_g,tau_struct_r) @@ -162,27 +159,25 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, cell=cell,& virial=virial,& rho_nlcc=rho_nlcc,& - rho_nlcc_g=rho_nlcc_g,& - error=error) + rho_nlcc_g=rho_nlcc_g) CALL qs_rho_get(rho_struct,& tau_r_valid=tau_r_valid,& rho_g_valid=rho_g_valid,& rho_r=rho_struct_r,& rho_g=rho_struct_g,& - tau_r=tau_struct_r,& - error=error) + tau_r=tau_struct_r) compute_virial=virial%pv_calculate.AND.(.NOT.virial%pv_numer) CALL section_vals_val_get(xc_section,"XC_FUNCTIONAL%_SECTION_PARAMETERS_",& - i_val=myfun,error=error) + i_val=myfun) CALL section_vals_val_get(xc_section,"VDW_POTENTIAL%POTENTIAL_TYPE",& - i_val=vdw,error=error) + i_val=vdw) vdW_nl = (vdw==xc_vdw_fun_nonloc) ! this combination has not been investigated - CPPrecondition(.NOT.(do_adiabatic_rescaling .AND. vdW_nl),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.(do_adiabatic_rescaling .AND. vdW_nl),cp_failure_level,routineP,failure) ! are the necessary inputs available IF(.NOT.(PRESENT(dispersion_env) .AND. PRESENT(edisp))) THEN vdW_nl = .FALSE. @@ -192,10 +187,10 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (myfun/=xc_none .OR. vdW_nl) THEN ! test if the real space density is available - CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,failure) CALL cp_assert( dft_control%nspins == 1 .OR. dft_control%nspins == 2,& cp_failure_level,cp_assertion_failed,routineP,& - "nspins must be 1 or 2",error,failure) + "nspins must be 1 or 2",failure) ! there are some options related to SIC here. ! Normal DFT computes E(rho_alpha,rho_beta) (or its variant E(2*rho_alpha) for non-LSD) ! SIC can E(rho_alpha,rho_beta)-b*(E(rho_alpha,rho_beta)-E(rho_beta,rho_beta)) @@ -208,16 +203,16 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ! all fine CASE ( sic_mauri_spz, sic_ad ) ! no idea yet what to do here in that case - CPPrecondition(.NOT.tau_r_valid ,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.tau_r_valid ,cp_failure_level,routineP,failure) CASE ( sic_mauri_us ) my_scaling=1.0_dp-dft_control%sic_scaling_b ! no idea yet what to do here in that case - CPPrecondition(.NOT.tau_r_valid ,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.tau_r_valid ,cp_failure_level,routineP,failure) CASE ( sic_eo ) ! NOTHING TO BE DONE CASE DEFAULT ! this case has not yet been treated here - CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,"NYI",error,failure) + CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,"NYI",failure) END SELECT IF (dft_control%sic_scaling_b .EQ. 0.0_dp) THEN @@ -226,12 +221,11 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, sic_scaling_b_zero = .FALSE. ENDIF - CALL pw_env_get(pw_env,xc_pw_pool=xc_pw_pool,auxbas_pw_pool=auxbas_pw_pool,& - error=error) + CALL pw_env_get(pw_env,xc_pw_pool=xc_pw_pool,auxbas_pw_pool=auxbas_pw_pool) uf_grid = .NOT. pw_grid_compare(auxbas_pw_pool%pw_grid,xc_pw_pool%pw_grid) ALLOCATE(rho_r(dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (.not.uf_grid) THEN DO ispin=1,dft_control%nspins rho_r(ispin)%pw => rho_struct_r(ispin)%pw @@ -239,7 +233,7 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (tau_r_valid) THEN ALLOCATE(tau(dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins tau(ispin)%pw => tau_struct_r(ispin)%pw END DO @@ -249,45 +243,45 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ! be useful so if we have it, we pass it in IF ( rho_g_valid ) THEN ALLOCATE(rho_g(dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins rho_g(ispin)%pw => rho_struct_g(ispin)%pw END DO END IF ELSE - CPPrecondition(rho_g_valid,cp_failure_level,routineP,error,failure) + CPPrecondition(rho_g_valid,cp_failure_level,routineP,failure) ALLOCATE(rho_g(dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins CALL pw_pool_create_pw(xc_pw_pool,rho_g(ispin)%pw,& - in_space=RECIPROCALSPACE, use_data=COMPLEXDATA1D,error=error) - CALL pw_transfer(rho_struct_g(ispin)%pw,rho_g(ispin)%pw, error=error) + in_space=RECIPROCALSPACE, use_data=COMPLEXDATA1D) + CALL pw_transfer(rho_struct_g(ispin)%pw,rho_g(ispin)%pw) END DO DO ispin=1,dft_control%nspins CALL pw_pool_create_pw(xc_pw_pool,rho_r(ispin)%pw,& - in_space=REALSPACE, use_data=REALDATA3D,error=error) - CALL pw_transfer(rho_g(ispin)%pw,rho_r(ispin)%pw, error=error) + in_space=REALSPACE, use_data=REALDATA3D) + CALL pw_transfer(rho_g(ispin)%pw,rho_r(ispin)%pw) END DO IF (tau_r_valid) THEN ! tau with finer grids is not implemented (at least not correctly), which this asserts CALL cp_unimplemented_error(fromWhere=routineP, & message="tau with finer grids", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ! ALLOCATE(tau(dft_control%nspins),stat=stat) -! CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) +! CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! DO ispin=1,dft_control%nspins ! CALL pw_pool_create_pw(xc_pw_pool,tau(ispin)%pw,& -! in_space=REALSPACE, use_data=REALDATA3D,error=error) +! in_space=REALSPACE, use_data=REALDATA3D) ! ! CALL pw_pool_create_pw(xc_pw_pool,tmp_g,& -! in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D,error=error) +! in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D) ! CALL pw_pool_create_pw(auxbas_pw_pool,tmp_g2,& -! in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D,error=error) -! CALL pw_transfer(tau(ispin)%pw,tmp_g, error=error) -! CALL pw_transfer(tmp_g,tmp_g2, error=error) -! CALL pw_transfer(tmp_g2,tmp_pw, error=error) -! CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g2,error=error) -! CALL pw_pool_give_back_pw(xc_pw_pool,tmp_g,error=error) +! in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D) +! CALL pw_transfer(tau(ispin)%pw,tmp_g) +! CALL pw_transfer(tmp_g,tmp_g2) +! CALL pw_transfer(tmp_g2,tmp_pw) +! CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g2) +! CALL pw_pool_give_back_pw(xc_pw_pool,tmp_g) ! END DO END IF END IF @@ -296,8 +290,8 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (ASSOCIATED(rho_nlcc)) THEN factor=1.0_dp DO ispin=1,dft_control%nspins - CALL pw_axpy(rho_nlcc%pw, rho_r(ispin)%pw, factor, error) - CALL pw_axpy(rho_nlcc_g%pw, rho_g(ispin)%pw, factor, error) + CALL pw_axpy(rho_nlcc%pw, rho_r(ispin)%pw, factor) + CALL pw_axpy(rho_nlcc_g%pw, rho_g(ispin)%pw, factor) ENDDO ENDIF @@ -308,8 +302,7 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (my_just_energy) THEN exc=xc_exc_calc(rho_r=rho_r,tau=tau,& rho_g=rho_g, xc_section=xc_section,& - pw_pool=xc_pw_pool,& - error=error) + pw_pool=xc_pw_pool) ELSE CALL xc_vxc_pw_create1(vxc_rho=my_vxc_rho,vxc_tau=my_vxc_tau, rho_r=rho_r,& @@ -317,16 +310,15 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, xc_section=xc_section,& pw_pool=xc_pw_pool,& compute_virial=compute_virial,& - virial_xc=virial%pv_xc,& - error=error) + virial_xc=virial%pv_xc) END IF ! remove the nlcc densities (keep stuff in original state) IF (ASSOCIATED(rho_nlcc)) THEN factor=-1.0_dp DO ispin=1,dft_control%nspins - CALL pw_axpy(rho_nlcc%pw, rho_r(ispin)%pw, factor, error) - CALL pw_axpy(rho_nlcc_g%pw, rho_g(ispin)%pw, factor, error) + CALL pw_axpy(rho_nlcc%pw, rho_r(ispin)%pw, factor) + CALL pw_axpy(rho_nlcc_g%pw, rho_g(ispin)%pw, factor) ENDDO ENDIF @@ -335,17 +327,17 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ! if yes, we use the dispersion_env from ks_env ! this is dangerous, as it assumes a special connection xc_section -> qs_env IF (vdW_nl) THEN - CALL get_ks_env(ks_env=ks_env, para_env=para_env, error=error) + CALL get_ks_env(ks_env=ks_env, para_env=para_env) ! no SIC functionals allowed - CPPrecondition(dft_control%sic_method_id==sic_none,cp_failure_level,routineP,error,failure) + CPPrecondition(dft_control%sic_method_id==sic_none,cp_failure_level,routineP,failure) ! - CALL pw_env_get(pw_env,vdw_pw_pool=vdw_pw_pool,error=error) + CALL pw_env_get(pw_env,vdw_pw_pool=vdw_pw_pool) IF(my_just_energy) THEN CALL calculate_dispersion_nonloc(my_vxc_rho,rho_r,rho_g,edisp,dispersion_env,& - my_just_energy,vdw_pw_pool,xc_pw_pool,para_env,error=error) + my_just_energy,vdw_pw_pool,xc_pw_pool,para_env) ELSE CALL calculate_dispersion_nonloc(my_vxc_rho,rho_r,rho_g,edisp,dispersion_env,& - my_just_energy,vdw_pw_pool,xc_pw_pool,para_env,virial=virial,error=error) + my_just_energy,vdw_pw_pool,xc_pw_pool,para_env,virial=virial) END IF END IF @@ -378,21 +370,21 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ! pw -> coeff IF (ASSOCIATED(my_vxc_rho)) THEN ALLOCATE(vxc_rho(dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins vxc_rho(ispin)%pw => my_vxc_rho(ispin)%pw END DO DEALLOCATE(my_vxc_rho,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(my_vxc_tau)) THEN ALLOCATE(vxc_tau(dft_control%nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,dft_control%nspins vxc_tau(ispin)%pw => my_vxc_tau(ispin)%pw END DO DEALLOCATE(my_vxc_tau,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! compute again the xc but now for Exc(m,o) and the opposite sign @@ -400,23 +392,23 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ALLOCATE(rho_m_rspace(2),rho_m_gspace(2)) CALL pw_pool_create_pw(xc_pw_pool, rho_m_gspace(1)%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(xc_pw_pool, rho_m_rspace(1)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_copy(rho_struct_r(1)%pw,rho_m_rspace(1)%pw, error=error) - CALL pw_axpy(rho_struct_r(2)%pw,rho_m_rspace(1)%pw,alpha=-1._dp, error=error) - CALL pw_copy(rho_struct_g(1)%pw,rho_m_gspace(1)%pw, error=error) - CALL pw_axpy(rho_struct_g(2)%pw,rho_m_gspace(1)%pw,alpha=-1._dp, error=error) + in_space = REALSPACE) + CALL pw_copy(rho_struct_r(1)%pw,rho_m_rspace(1)%pw) + CALL pw_axpy(rho_struct_r(2)%pw,rho_m_rspace(1)%pw,alpha=-1._dp) + CALL pw_copy(rho_struct_g(1)%pw,rho_m_gspace(1)%pw) + CALL pw_axpy(rho_struct_g(2)%pw,rho_m_gspace(1)%pw,alpha=-1._dp) ! bit sad, these will be just zero... CALL pw_pool_create_pw(xc_pw_pool, rho_m_gspace(2)%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(xc_pw_pool, rho_m_rspace(2)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(rho_m_rspace(2)%pw, error=error) - CALL pw_zero(rho_m_gspace(2)%pw, error=error) + in_space = REALSPACE) + CALL pw_zero(rho_m_rspace(2)%pw) + CALL pw_zero(rho_m_gspace(2)%pw) rho_g(1)%pw => rho_m_gspace(1)%pw rho_g(2)%pw => rho_m_gspace(2)%pw @@ -426,18 +418,16 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (my_just_energy) THEN exc_m=xc_exc_calc(rho_r=rho_r,tau=tau,& rho_g=rho_g, xc_section=xc_section,& - pw_pool=xc_pw_pool,& - error=error) + pw_pool=xc_pw_pool) ELSE ! virial untested - CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,failure) CALL xc_vxc_pw_create1(vxc_rho=my_vxc_rho,vxc_tau=my_vxc_tau, rho_r=rho_r,& rho_g=rho_g,tau=tau,exc=exc_m,& xc_section=xc_section,& pw_pool=xc_pw_pool,& compute_virial=.FALSE.,& - virial_xc=virial_xc_tmp,& - error=error) + virial_xc=virial_xc_tmp) END IF exc = exc - dft_control%sic_scaling_b * exc_m @@ -448,17 +438,15 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, my_vxc_rho(1)%pw%cr3d vxc_rho(2)%pw%cr3d=vxc_rho(2)%pw%cr3d+dft_control%sic_scaling_b *& my_vxc_rho(1)%pw%cr3d ! 1=m - CALL pw_release(my_vxc_rho(1)%pw,error=error) - CALL pw_release(my_vxc_rho(2)%pw,error=error) + CALL pw_release(my_vxc_rho(1)%pw) + CALL pw_release(my_vxc_rho(2)%pw) DEALLOCATE(my_vxc_rho,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DO ispin=1,2 - CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_rspace(ispin)%pw,& - error=error) - CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_gspace(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_rspace(ispin)%pw) + CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_gspace(ispin)%pw) ENDDO DEALLOCATE(rho_m_rspace) DEALLOCATE(rho_m_gspace) @@ -469,16 +457,16 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF ( dft_control%sic_method_id .EQ. sic_ad .AND. .NOT. sic_scaling_b_zero ) THEN ! find out how many elecs we have - CALL get_ks_env(ks_env,nelectron_spin=nelec_spin,error=error) + CALL get_ks_env(ks_env,nelectron_spin=nelec_spin) ALLOCATE(rho_m_rspace(2),rho_m_gspace(2)) DO ispin=1,2 CALL pw_pool_create_pw(xc_pw_pool, rho_m_gspace(ispin)%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) CALL pw_pool_create_pw(xc_pw_pool, rho_m_rspace(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) ENDDO rho_g(1)%pw => rho_m_gspace(1)%pw @@ -493,28 +481,26 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ! does it matter if there are no electrons with this spin (H) ? nelec_s_inv=0.0_dp ENDIF - CALL pw_copy(rho_struct_r(ispin)%pw,rho_m_rspace(1)%pw, error=error) - CALL pw_copy(rho_struct_g(ispin)%pw,rho_m_gspace(1)%pw, error=error) - CALL pw_scale(rho_m_rspace(1)%pw,nelec_s_inv, error=error) - CALL pw_scale(rho_m_gspace(1)%pw,nelec_s_inv, error=error) - CALL pw_zero(rho_m_rspace(2)%pw, error=error) - CALL pw_zero(rho_m_gspace(2)%pw, error=error) + CALL pw_copy(rho_struct_r(ispin)%pw,rho_m_rspace(1)%pw) + CALL pw_copy(rho_struct_g(ispin)%pw,rho_m_gspace(1)%pw) + CALL pw_scale(rho_m_rspace(1)%pw,nelec_s_inv) + CALL pw_scale(rho_m_gspace(1)%pw,nelec_s_inv) + CALL pw_zero(rho_m_rspace(2)%pw) + CALL pw_zero(rho_m_gspace(2)%pw) IF (my_just_energy) THEN exc_m=xc_exc_calc(rho_r=rho_r,tau=tau,& rho_g=rho_g, xc_section=xc_section,& - pw_pool=xc_pw_pool,& - error=error) + pw_pool=xc_pw_pool) ELSE ! virial untested - CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,failure) CALL xc_vxc_pw_create1(vxc_rho=my_vxc_rho,vxc_tau=my_vxc_tau, rho_r=rho_r,& rho_g=rho_g,tau=tau,exc=exc_m,& xc_section=xc_section,& pw_pool=xc_pw_pool,& compute_virial=.FALSE.,& - virial_xc=virial_xc_tmp,& - error=error) + virial_xc=virial_xc_tmp) END IF exc = exc - dft_control%sic_scaling_b * nelec_spin(ispin) * exc_m @@ -523,18 +509,16 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (.NOT. my_just_energy) THEN vxc_rho(ispin)%pw%cr3d=vxc_rho(ispin)%pw%cr3d-dft_control%sic_scaling_b *& my_vxc_rho(1)%pw%cr3d - CALL pw_release(my_vxc_rho(1)%pw,error=error) - CALL pw_release(my_vxc_rho(2)%pw,error=error) + CALL pw_release(my_vxc_rho(1)%pw) + CALL pw_release(my_vxc_rho(2)%pw) DEALLOCATE(my_vxc_rho,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDDO DO ispin=1,2 - CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_rspace(ispin)%pw,& - error=error) - CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_gspace(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_rspace(ispin)%pw) + CALL pw_pool_give_back_pw(xc_pw_pool,rho_m_gspace(ispin)%pw) ENDDO DEALLOCATE(rho_m_rspace) DEALLOCATE(rho_m_gspace) @@ -553,18 +537,16 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (my_just_energy) THEN exc_m=xc_exc_calc(rho_r=rho_r,tau=tau,& rho_g=rho_g, xc_section=xc_section,& - pw_pool=xc_pw_pool,& - error=error) + pw_pool=xc_pw_pool) ELSE ! virial untested - CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.compute_virial,cp_failure_level,routineP,failure) CALL xc_vxc_pw_create1(vxc_rho=my_vxc_rho,vxc_tau=my_vxc_tau, rho_r=rho_r,& rho_g=rho_g,tau=tau,exc=exc_m,& xc_section=xc_section,& pw_pool=xc_pw_pool,& compute_virial=.FALSE.,& - virial_xc=virial_xc_tmp,& - error=error) + virial_xc=virial_xc_tmp) END IF exc = exc + dft_control%sic_scaling_b * exc_m @@ -574,10 +556,10 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ! both go to minority spin vxc_rho(2)%pw%cr3d = vxc_rho(2)%pw%cr3d + & 2.0_dp * dft_control%sic_scaling_b * my_vxc_rho(1)%pw%cr3d - CALL pw_release(my_vxc_rho(1)%pw,error=error) - CALL pw_release(my_vxc_rho(2)%pw,error=error) + CALL pw_release(my_vxc_rho(1)%pw) + CALL pw_release(my_vxc_rho(2)%pw) DEALLOCATE(my_vxc_rho) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDIF @@ -587,26 +569,26 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, ! IF (uf_grid) THEN DO ispin=1,SIZE(rho_r) - CALL pw_pool_give_back_pw(xc_pw_pool,rho_r(ispin)%pw,error=error) + CALL pw_pool_give_back_pw(xc_pw_pool,rho_r(ispin)%pw) END DO IF (ASSOCIATED(vxc_rho)) THEN DO ispin=1,SIZE(vxc_rho) CALL pw_pool_create_pw(auxbas_pw_pool,tmp_pw,& - in_space=REALSPACE,use_data=REALDATA3D,error=error) + in_space=REALSPACE,use_data=REALDATA3D) CALL pw_pool_create_pw(xc_pw_pool,tmp_g,& - in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D,error=error) + in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D) CALL pw_pool_create_pw(auxbas_pw_pool,tmp_g2,& - in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D,error=error) - CALL pw_transfer(vxc_rho(ispin)%pw,tmp_g, error=error) - CALL pw_transfer(tmp_g,tmp_g2, error=error) - CALL pw_transfer(tmp_g2,tmp_pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g2,error=error) - CALL pw_pool_give_back_pw(xc_pw_pool,tmp_g,error=error) - !FM CALL pw_zero(tmp_pw,error=error) + in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D) + CALL pw_transfer(vxc_rho(ispin)%pw,tmp_g) + CALL pw_transfer(tmp_g,tmp_g2) + CALL pw_transfer(tmp_g2,tmp_pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g2) + CALL pw_pool_give_back_pw(xc_pw_pool,tmp_g) + !FM CALL pw_zero(tmp_pw) !FM CALL pw_restrict_s3(vxc_rho(ispin)%pw,tmp_pw,& - !FM auxbas_pw_pool,param_section=interp_section,error=error) - CALL pw_pool_give_back_pw(xc_pw_pool,vxc_rho(ispin)%pw,error=error) + !FM auxbas_pw_pool,param_section=interp_section) + CALL pw_pool_give_back_pw(xc_pw_pool,vxc_rho(ispin)%pw) vxc_rho(ispin)%pw => tmp_pw NULLIFY(tmp_pw) END DO @@ -614,21 +596,21 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, IF (ASSOCIATED(vxc_tau)) THEN DO ispin=1,SIZE(vxc_tau) CALL pw_pool_create_pw(auxbas_pw_pool,tmp_pw,& - in_space=REALSPACE,use_data=REALDATA3D,error=error) + in_space=REALSPACE,use_data=REALDATA3D) CALL pw_pool_create_pw(xc_pw_pool,tmp_g,& - in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D,error=error) + in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D) CALL pw_pool_create_pw(auxbas_pw_pool,tmp_g2,& - in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D,error=error) - CALL pw_transfer(vxc_tau(ispin)%pw,tmp_g, error=error) - CALL pw_transfer(tmp_g,tmp_g2, error=error) - CALL pw_transfer(tmp_g2,tmp_pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g2,error=error) - CALL pw_pool_give_back_pw(xc_pw_pool,tmp_g,error=error) - !FM CALL pw_zero(tmp_pw,error=error) + in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D) + CALL pw_transfer(vxc_tau(ispin)%pw,tmp_g) + CALL pw_transfer(tmp_g,tmp_g2) + CALL pw_transfer(tmp_g2,tmp_pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,tmp_g2) + CALL pw_pool_give_back_pw(xc_pw_pool,tmp_g) + !FM CALL pw_zero(tmp_pw) !FM CALL pw_restrict_s3(vxc_rho(ispin)%pw,tmp_pw,& - !FM auxbas_pw_pool,param_section=interp_section,error=error) - CALL pw_pool_give_back_pw(xc_pw_pool,vxc_tau(ispin)%pw,error=error) + !FM auxbas_pw_pool,param_section=interp_section) + CALL pw_pool_give_back_pw(xc_pw_pool,vxc_tau(ispin)%pw) vxc_tau(ispin)%pw => tmp_pw NULLIFY(tmp_pw) END DO @@ -636,24 +618,24 @@ SUBROUTINE qs_vxc_create( ks_env, rho_struct, xc_section, vxc_rho, vxc_tau, exc, END IF DEALLOCATE(rho_r,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) IF (ASSOCIATED(rho_g)) THEN IF (uf_grid) THEN DO ispin=1,SIZE(rho_g) - CALL pw_pool_give_back_pw(xc_pw_pool,rho_g(ispin)%pw,error=error) + CALL pw_pool_give_back_pw(xc_pw_pool,rho_g(ispin)%pw) END DO END IF DEALLOCATE(rho_g,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(tau)) THEN IF (uf_grid) THEN DO ispin=1,SIZE(tau) - CALL pw_pool_give_back_pw(xc_pw_pool,tau(ispin)%pw,error=error) + CALL pw_pool_give_back_pw(xc_pw_pool,tau(ispin)%pw) END DO END IF DEALLOCATE(tau,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF diff --git a/src/qs_vxc_atom.F b/src/qs_vxc_atom.F index 9f29bb5134..3753b797be 100644 --- a/src/qs_vxc_atom.F +++ b/src/qs_vxc_atom.F @@ -75,15 +75,13 @@ MODULE qs_vxc_atom !> \brief ... !> \param qs_env ... !> \param energy_only ... -!> \param error ... !> \param gradient_atom_set ... !> \param adiabatic_rescale_factor ... ! ***************************************************************************** - SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabatic_rescale_factor) + SUBROUTINE calculate_vxc_atom(qs_env,energy_only,gradient_atom_set,adiabatic_rescale_factor) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: energy_only - TYPE(cp_error_type), INTENT(inout) :: error TYPE(nablavks_atom_type), DIMENSION(:), & OPTIONAL, POINTER :: gradient_atom_set REAL(dp), INTENT(IN), OPTIONAL :: adiabatic_rescale_factor @@ -169,18 +167,17 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat atomic_kind_set=atomic_kind_set,& qs_kind_set=qs_kind_set,& input=input,& - rho_atom_set=rho_atom_set,error=error) + rho_atom_set=rho_atom_set) IF(epr_xc) THEN xc_section => section_vals_get_subs_vals(input,& - "PROPERTIES%LINRES%EPR%PRINT%G_TENSOR%XC",error=error) + "PROPERTIES%LINRES%EPR%PRINT%G_TENSOR%XC") ELSE - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") END IF - xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",& - error=error) + xc_fun_section => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",& - i_val=myfun,error=error) + i_val=myfun) IF(myfun == xc_none) THEN energy%exc1 = 0.0_dp @@ -188,18 +185,17 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat rho_atom_set(:)%exc_s = 0.0_dp ELSE CALL section_vals_val_get(xc_section,"DENSITY_CUTOFF",& - r_val=density_cut,error=error) + r_val=density_cut) CALL section_vals_val_get(xc_section,"GRADIENT_CUTOFF",& - r_val=gradient_cut,error=error) + r_val=gradient_cut) CALL section_vals_val_get(xc_section,"TAU_CUTOFF",& - r_val=tau_cut,error=error) + r_val=tau_cut) lsd = dft_control%lsd nspins = dft_control%nspins needs = xc_functionals_get_needs(xc_fun_section,& lsd=lsd,& - add_basic_components=.TRUE.,& - error=error) + add_basic_components=.TRUE.) ! whatever the xc, if epr_xc, drho_spin is needed IF(epr_xc) needs%drho_spin = .TRUE. @@ -221,7 +217,7 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat DO ikind = 1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=atom_list,natom=natom) CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom,& - harmonics=harmonics,grid_atom=grid_atom, error=error) + harmonics=harmonics,grid_atom=grid_atom) IF (.NOT.paw_atom) CYCLE @@ -238,14 +234,12 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat bounds(2,2) = nr ! create a place where to put the derivatives - CALL xc_dset_create(deriv_set, local_bounds=bounds, error=error) + CALL xc_dset_create(deriv_set, local_bounds=bounds) ! create the place where to store the argument for the functionals CALL xc_rho_set_create(rho_set_h,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,& - error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) CALL xc_rho_set_create(rho_set_s,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,& - error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) ! allocate the required 3d arrays where to store rho and drho CALL xc_rho_set_atom_update(rho_set_h,needs,nspins,bounds) @@ -304,31 +298,31 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat DO ir = 1,nr CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f,& ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, & - r_h_d, r_s_d, drho_h, drho_s, error=error) + r_h_d, r_s_d, drho_h, drho_s) IF (tau_f) THEN CALL calc_tau_angular(grid_atom, harmonics, nspins, ir, & - trho_h, trho_s, tau_h, tau_s, error=error) + trho_h, trho_s, tau_h, tau_s) END IF - CALL fill_rho_set(rho_set_h,lsd,nspins,needs,rho_h,drho_h,tau_h,na,ir,error=error) - CALL fill_rho_set(rho_set_s,lsd,nspins,needs,rho_s,drho_s,tau_s,na,ir,error=error) + CALL fill_rho_set(rho_set_h,lsd,nspins,needs,rho_h,drho_h,tau_h,na,ir) + CALL fill_rho_set(rho_set_s,lsd,nspins,needs,rho_s,drho_s,tau_s,na,ir) END DO !-------------------! ! hard atom density ! !-------------------! - CALL xc_dset_zero_all(deriv_set, error) + CALL xc_dset_zero_all(deriv_set) CALL vxc_of_r_new(xc_fun_section, rho_set_h, deriv_set, 1, needs, weight, & lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h, energy_only=energy_only, & - epr_xc=epr_xc, adiabatic_rescale_factor=my_adiabatic_rescale_factor, error=error) + epr_xc=epr_xc, adiabatic_rescale_factor=my_adiabatic_rescale_factor) rho_atom%exc_h = rho_atom%exc_h + exc_h !-------------------! ! soft atom density ! !-------------------! - CALL xc_dset_zero_all(deriv_set, error) + CALL xc_dset_zero_all(deriv_set) CALL vxc_of_r_new(xc_fun_section, rho_set_s, deriv_set, 1, needs, weight, & lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s, energy_only=energy_only, & - epr_xc=epr_xc, adiabatic_rescale_factor=my_adiabatic_rescale_factor, error=error) + epr_xc=epr_xc, adiabatic_rescale_factor=my_adiabatic_rescale_factor) rho_atom%exc_s = rho_atom%exc_s + exc_s IF (epr_xc) THEN @@ -360,21 +354,21 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat qs_kind => qs_kind_set(ikind) IF (gradient_f) THEN CALL gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,& - rho_atom,nspins,error=error) + rho_atom,nspins) ELSE - CALL gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins,error=error) + CALL gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins) END IF IF (tau_f) THEN - CALL dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins,error=error) + CALL dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins) END IF END IF ! energy_only NULLIFY (r_h,r_s,dr_h,dr_s) END DO ! iat ! Release the xc structure used to store the xc derivatives - CALL xc_dset_release(deriv_set, error=error) - CALL xc_rho_set_release(rho_set_h,error=error) - CALL xc_rho_set_release(rho_set_s,error=error) + CALL xc_dset_release(deriv_set) + CALL xc_rho_set_release(rho_set_h) + CALL xc_rho_set_release(rho_set_s) END DO ! ikind @@ -382,44 +376,44 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat IF (ASSOCIATED(rho_h)) THEN DEALLOCATE (rho_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(rho_s)) THEN DEALLOCATE (rho_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(vxc_h)) THEN DEALLOCATE (vxc_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(vxc_s)) THEN DEALLOCATE (vxc_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (gradient_f) THEN IF (ASSOCIATED(drho_h)) THEN DEALLOCATE (drho_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(drho_s)) THEN DEALLOCATE (drho_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(vxg_h)) THEN DEALLOCATE (vxg_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(vxg_s)) THEN DEALLOCATE (vxg_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -428,22 +422,22 @@ SUBROUTINE calculate_vxc_atom(qs_env,energy_only,error,gradient_atom_set,adiabat IF (ASSOCIATED(tau_h)) THEN DEALLOCATE (tau_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(tau_s)) THEN DEALLOCATE (tau_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(vtau_h)) THEN DEALLOCATE (vtau_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(vtau_s)) THEN DEALLOCATE (vtau_s,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -461,15 +455,13 @@ END SUBROUTINE calculate_vxc_atom !> \param xc_section ... !> \param do_tddft ... !> \param do_triplet ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_triplet,error) + SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_triplet) TYPE(qs_p_env_type), POINTER :: p_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: xc_section LOGICAL, INTENT(IN), OPTIONAL :: do_tddft, do_triplet - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_xc_2nd_deriv_atom', & routineP = moduleN//':'//routineN @@ -536,41 +528,40 @@ SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_tripl input=input,& qs_kind_set=qs_kind_set,& atomic_kind_set=atomic_kind_set,& - rho_atom_set=rho_atom_set,& - error=error) + rho_atom_set=rho_atom_set) rho1_atom_set => p_env%local_rho_set%rho_atom_set - CALL section_vals_val_get(input,"DFT%LSD",l_val=lsd,error=error) + CALL section_vals_val_get(input,"DFT%LSD",l_val=lsd) CALL section_vals_val_get(xc_section,"DENSITY_CUTOFF",& - r_val=density_cut,error=error) + r_val=density_cut) CALL section_vals_val_get(xc_section,"GRADIENT_CUTOFF",& - r_val=gradient_cut,error=error) + r_val=gradient_cut) CALL section_vals_val_get(xc_section,"TAU_CUTOFF",& - r_val=tau_cut,error=error) + r_val=tau_cut) IF(my_do_tddft) THEN CALL section_vals_val_get(input,"DFT%EXCITATIONS",& - i_val=excitations,error=error) + i_val=excitations) CALL section_vals_val_get(input,"DFT%TDDFPT%LSD_SINGLETS",& - l_val=lsd_singlets,error=error) + l_val=lsd_singlets) CALL section_vals_val_get(input,"DFT%TDDFPT%RES_ETYPE",& - i_val=res_etype,error=error) + i_val=res_etype) ENDIF xc_fun_section => section_vals_get_subs_vals(xc_section,& - "XC_FUNCTIONAL",error=error) + "XC_FUNCTIONAL") IF (lsd) THEN nspins=2 ELSE nspins=1 END IF needs=xc_functionals_get_needs(xc_fun_section,lsd=lsd,& - add_basic_components=.TRUE., error=error) + add_basic_components=.TRUE.) gradient_functional = needs%drho .OR. needs%drho_spin tau_f = (needs%tau.OR.needs%tau_spin) IF ( tau_f ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Tau functionals not implemented for GAPW 2nd derivatives", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF(my_do_tddft) THEN @@ -593,7 +584,7 @@ SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_tripl NULLIFY(atom_list, harmonics, grid_atom) CALL get_atomic_kind(atomic_kind_set(ikind),atom_list=atom_list,natom=natom) CALL get_qs_kind(qs_kind_set(ikind),paw_atom=paw_atom,& - harmonics=harmonics,grid_atom=grid_atom, error=error) + harmonics=harmonics,grid_atom=grid_atom) IF (.NOT.paw_atom) CYCLE nr = grid_atom%nr @@ -607,19 +598,15 @@ SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_tripl bounds(2,2) = nr NULLIFY(deriv_set, rho_set_h, rho_set_s, rho1_set_h, rho1_set_s) - CALL xc_dset_create(deriv_set, local_bounds=bounds, error=error) + CALL xc_dset_create(deriv_set, local_bounds=bounds) CALL xc_rho_set_create(rho_set_h,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,& - error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) CALL xc_rho_set_create(rho_set_s,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,& - error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) CALL xc_rho_set_create(rho1_set_h,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,& - error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) CALL xc_rho_set_create(rho1_set_s,bounds,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,tau_cutoff=tau_cut,& - error=error) + drho_cutoff=gradient_cut,tau_cutoff=tau_cut) ! allocate the required 3d arrays where to store rho and drho IF (nspins == 1 .AND. .NOT. lsd) THEN @@ -636,10 +623,10 @@ SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_tripl ALLOCATE (rho_h(1:na,1:nspins),rho1_h(1:na,1:nspins), & rho_s(1:na,1:nspins),rho1_s(1:na,1:nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (vxc_h(1:na,1:nr,1:nspins), vxc_s(1:na,1:nr,1:nspins),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vxc_h = 0.0_dp vxc_s = 0.0_dp @@ -648,10 +635,10 @@ SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_tripl IF (gradient_functional) THEN ALLOCATE(drho_h(1:4,1:na,1:nr,1:nspins), drho1_h(1:4,1:na,1:nr,1:nspins), & drho_s(1:4,1:na,1:nr,1:nspins), drho1_s(1:4,1:na,1:nr,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vxg_h(1:3,1:na,1:nr,1:nspins), vxg_s(1:3,1:na,1:nr,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vxg_h = 0.0_dp vxg_s = 0.0_dp END IF @@ -695,33 +682,33 @@ SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_tripl CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, & ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, r_h_d, r_s_d, & - drho_h, drho_s, error) + drho_h, drho_s) CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, & ir, r1_h, r1_s, rho1_h, rho1_s, dr1_h, dr1_s, r1_h_d, r1_s_d, & - drho1_h, drho1_s, error) + drho1_h, drho1_s) - CALL fill_rho_set(rho_set_h,lsd,nspins,needs,rho_h,drho_h,tau_h,na,ir,error) - CALL fill_rho_set(rho1_set_h,lsd,nspins,needs,rho1_h,drho1_h,tau1_h,na,ir,error) - CALL fill_rho_set(rho_set_s,lsd,nspins,needs,rho_s,drho_s,tau_s,na,ir,error) - CALL fill_rho_set(rho1_set_s,lsd,nspins,needs,rho1_s,drho1_s,tau1_s,na,ir,error) + CALL fill_rho_set(rho_set_h,lsd,nspins,needs,rho_h,drho_h,tau_h,na,ir) + CALL fill_rho_set(rho1_set_h,lsd,nspins,needs,rho1_h,drho1_h,tau1_h,na,ir) + CALL fill_rho_set(rho_set_s,lsd,nspins,needs,rho_s,drho_s,tau_s,na,ir) + CALL fill_rho_set(rho1_set_s,lsd,nspins,needs,rho1_s,drho1_s,tau1_s,na,ir) END DO CALL xc_2nd_deriv_of_r(xc_section=xc_section, & rho_set=rho_set_h, rho1_set=rho1_set_h, & deriv_set=deriv_set, & - w=weight, vxc=vxc_h, vxg=vxg_h, error=error) + w=weight, vxc=vxc_h, vxg=vxg_h) CALL xc_2nd_deriv_of_r(xc_section=xc_section, & rho_set=rho_set_s, rho1_set=rho1_set_s, & deriv_set=deriv_set, & - w=weight, vxc=vxc_s, vxg=vxg_s, error=error) + w=weight, vxc=vxc_s, vxg=vxg_s) IF(gradient_functional) THEN CALL gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind_set(ikind),& - rho1_atom, nspins,error=error) + rho1_atom, nspins) ELSE CALL gaVxcgb_noGC(vxc_h, vxc_s, qs_kind_set(ikind), & - rho1_atom, nspins,error=error) + rho1_atom, nspins) ENDIF NULLIFY(r_h,r_s,dr_h,dr_s) @@ -730,21 +717,21 @@ SUBROUTINE calculate_xc_2nd_deriv_atom(p_env,qs_env,xc_section,do_tddft,do_tripl ! some cleanup DEALLOCATE(rho_h, rho_s, rho1_h, rho1_s, vxc_h, vxc_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(rho_h, rho_s, weight) IF (gradient_functional) THEN DEALLOCATE(drho_h, drho_s, vxg_h, vxg_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(drho1_h, drho1_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(drho_h, drho_s, drho1_h, drho1_s, vxg_h, vxc_s) END IF - CALL xc_dset_release(deriv_set, error=error) - CALL xc_rho_set_release(rho_set_h,error=error) - CALL xc_rho_set_release(rho1_set_h,error=error) - CALL xc_rho_set_release(rho_set_s,error=error) - CALL xc_rho_set_release(rho1_set_s,error=error) + CALL xc_dset_release(deriv_set) + CALL xc_rho_set_release(rho_set_h) + CALL xc_rho_set_release(rho1_set_h) + CALL xc_rho_set_release(rho_set_s) + CALL xc_rho_set_release(rho1_set_s) END DO @@ -769,11 +756,10 @@ END SUBROUTINE calculate_xc_2nd_deriv_atom !> \param r_s_d ... !> \param drho_h ... !> \param drho_s ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_rho_angular(grid_atom, harmonics, nspins, grad_func, & ir, r_h, r_s, rho_h, rho_s, & - dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s, error) + dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s) TYPE(grid_atom_type), POINTER :: grid_atom TYPE(harmonics_atom_type), POINTER :: harmonics @@ -789,7 +775,6 @@ SUBROUTINE calc_rho_angular(grid_atom, harmonics, nspins, grad_func, & POINTER :: r_h_d, r_s_d REAL(KIND=dp), DIMENSION(:, :, :, :), & POINTER :: drho_h, drho_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_rho_angular', & routineP = moduleN//':'//routineN @@ -799,17 +784,17 @@ SUBROUTINE calc_rho_angular(grid_atom, harmonics, nspins, grad_func, & REAL(KIND=dp) :: rad, urad failure = .FALSE. - CPPostcondition(ASSOCIATED(r_h),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(r_s),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(rho_h),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(rho_s),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(r_h),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(r_s),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(rho_h),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(rho_s),cp_failure_level,routineP,failure) IF (grad_func) THEN - CPPostcondition(ASSOCIATED(dr_h),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(dr_s),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(r_h_d),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(r_s_d),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(drho_h),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(drho_s),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(dr_h),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(dr_s),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(r_h_d),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(r_s_d),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(drho_h),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(drho_s),cp_failure_level,routineP,failure) END IF IF (failure) RETURN @@ -900,10 +885,9 @@ END SUBROUTINE calc_rho_angular !> \param trho_s ... !> \param tau_h ... !> \param tau_s ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_tau_angular(grid_atom, harmonics, nspins, ir, & - trho_h, trho_s, tau_h, tau_s, error) + trho_h, trho_s, tau_h, tau_s) TYPE(grid_atom_type), POINTER :: grid_atom TYPE(harmonics_atom_type), POINTER :: harmonics @@ -911,7 +895,6 @@ SUBROUTINE calc_tau_angular(grid_atom, harmonics, nspins, ir, & TYPE(rho_atom_coeff), DIMENSION(:, :), & POINTER :: trho_h, trho_s REAL(KIND=dp), DIMENSION(:, :), POINTER :: tau_h, tau_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_tau_angular', & routineP = moduleN//':'//routineN @@ -920,10 +903,10 @@ SUBROUTINE calc_tau_angular(grid_atom, harmonics, nspins, ir, & LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(trho_h),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(trho_s),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tau_h),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tau_s),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(trho_h),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(trho_s),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tau_h),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tau_s),cp_failure_level,routineP,failure) IF (failure) RETURN @@ -963,15 +946,13 @@ END SUBROUTINE calc_tau_angular !> \param qs_kind ... !> \param rho_atom ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins,error) + SUBROUTINE gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins) REAL(dp), DIMENSION(:, :, :), POINTER :: vxc_h, vxc_s TYPE(qs_kind_type), INTENT(IN) :: qs_kind TYPE(rho_atom_type), POINTER :: rho_atom INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gaVxcgb_noGC', & routineP = moduleN//':'//routineN @@ -1004,7 +985,7 @@ SUBROUTINE gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins,error) NULLIFY (lmin,lmax,npgf,zet,my_CG,harmonics,grid_atom) CALL get_qs_kind(qs_kind,basis_set=orb_basis,& - harmonics=harmonics,grid_atom=grid_atom,error=error) + harmonics=harmonics,grid_atom=grid_atom) CALL get_gto_basis_set(gto_basis_set=orb_basis,lmax=lmax,lmin=lmin,& maxso=maxso,maxl=maxl,npgf=npgf,& @@ -1036,7 +1017,7 @@ SUBROUTINE gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins,error) "vx",na*nr*dp_size) ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) NULLIFY (int_hh,int_ss) @@ -1050,8 +1031,8 @@ SUBROUTINE gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins,error) m2 = 0 DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local,error) - CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local) + CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,failure) n2 = nsoset(lmax(iset2)) DO ipgf1 = 1,npgf(iset1) @@ -1105,7 +1086,7 @@ SUBROUTINE gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins,error) iso2 = cg_list(2,icg,iso) l = indso(1,iso1) + indso(1,iso2) - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) DO ia = 1,na matso_h(iso1,iso2) = matso_h(iso1,iso2) + & gVg_h(ia,l)*& @@ -1145,7 +1126,7 @@ SUBROUTINE gaVxcgb_noGC(vxc_h,vxc_s,qs_kind,rho_atom,nspins,error) "g1,g2,gg,matso_h,matso_s,gVg_s,gVg_h") DEALLOCATE(cg_list,cg_n_list,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1160,17 +1141,15 @@ END SUBROUTINE gaVxcgb_noGC !> \param qs_kind ... !> \param rho_atom ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** SUBROUTINE gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,rho_atom,& - nspins,error) + nspins) REAL(dp), DIMENSION(:, :, :), POINTER :: vxc_h, vxc_s REAL(dp), DIMENSION(:, :, :, :), POINTER :: vxg_h, vxg_s TYPE(qs_kind_type), INTENT(IN) :: qs_kind TYPE(rho_atom_type), POINTER :: rho_atom INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'gaVxcgb_GC', & routineP = moduleN//':'//routineN @@ -1208,7 +1187,7 @@ SUBROUTINE gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,rho_atom,& NULLIFY(lmin,lmax,npgf,zet,my_CG,my_CG_dxyz,harmonics,grid_atom) CALL get_qs_kind(qs_kind,basis_set=orb_basis,& - harmonics=harmonics,grid_atom=grid_atom,error=error) + harmonics=harmonics,grid_atom=grid_atom) CALL get_gto_basis_set(gto_basis_set=orb_basis,lmax=lmax,lmin=lmin,& maxso=maxso,maxl=maxl,npgf=npgf,& @@ -1235,7 +1214,7 @@ SUBROUTINE gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,rho_atom,& "gVXCg_h,gVXCg_s",12*na*maxl*dp_size) ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),& dcg_list(2,nsoset(maxl)**2,max_s_harm),dcg_n_list(max_s_harm),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(int_hh,int_ss) @@ -1256,11 +1235,11 @@ SUBROUTINE gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,rho_atom,& m2 = 0 DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local,error) - CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local) + CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,failure) CALL get_none0_cg_list(my_CG_dxyz,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,dcg_list,dcg_n_list,dmax_iso_not0_local,error) - !CPPrecondition(dmax_iso_not0_local.LE.dmax_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,lmax_expansion,dcg_list,dcg_n_list,dmax_iso_not0_local) + !CPPrecondition(dmax_iso_not0_local.LE.dmax_iso_not0,cp_failure_level,routineP,failure) n2 = nsoset(lmax(iset2)) DO ipgf1 = 1,npgf(iset1) @@ -1363,7 +1342,7 @@ SUBROUTINE gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,rho_atom,& l = indso(1,iso1) + indso(1,iso2) !test reduce expansion local densities - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) IF(.NOT. failure) THEN DO ia = 1,na @@ -1391,7 +1370,7 @@ SUBROUTINE gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,rho_atom,& l = indso(1,iso1) + indso(1,iso2) !test reduce expansion local densities - CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,error,failure) + CPPrecondition(l<=lmax_expansion,cp_failure_level,routineP,failure) IF(.NOT. failure) THEN DO ia = 1,na @@ -1439,7 +1418,7 @@ SUBROUTINE gaVxcgb_GC(vxc_h,vxc_s,vxg_h,vxg_s,qs_kind,rho_atom,& IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& "g1,g2,gg,matso_h,matso_s,gVXCg_s,gVXCg_h,gVXGg_h,gVXGg_s") DEALLOCATE(cg_list,cg_n_list,dcg_list,dcg_n_list,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1452,15 +1431,13 @@ END SUBROUTINE gaVxcgb_GC !> \param qs_kind ... !> \param rho_atom ... !> \param nspins ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins,error) + SUBROUTINE dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins) REAL(dp), DIMENSION(:, :, :), POINTER :: vtau_h, vtau_s TYPE(qs_kind_type), INTENT(IN) :: qs_kind TYPE(rho_atom_type), POINTER :: rho_atom INTEGER, INTENT(IN) :: nspins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dgaVtaudgb', & routineP = moduleN//':'//routineN @@ -1494,7 +1471,7 @@ SUBROUTINE dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins,error) NULLIFY(harmonics,grid_atom) CALL get_qs_kind(qs_kind,basis_set=orb_basis,& - harmonics=harmonics,grid_atom=grid_atom,error=error) + harmonics=harmonics,grid_atom=grid_atom) NULLIFY(lmin,lmax,npgf,zet) CALL get_gto_basis_set(gto_basis_set=orb_basis,lmax=lmax,lmin=lmin,& @@ -1510,17 +1487,17 @@ SUBROUTINE dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins,error) nr = grid_atom%nr na = grid_atom%ng_sphere ALLOCATE(g1(nr),g2(nr),gg(nr),dd(nr),gr(nr),ww(na),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(fgr(nr,0:maxl,0:maxl),dgr(nr,0:lmax_expansion),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(cg_list(2,nsoset(maxl)**2,max_s_harm),cg_n_list(max_s_harm),& dcg_list(2,nsoset(maxl)**2,max_s_harm),dcg_n_list(max_s_harm),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(matso_h(nsoset(maxl),nsoset(maxl)),& matso_s(nsoset(maxl),nsoset(maxl)),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(int_hh,int_ss) CALL get_rho_atom(rho_atom=rho_atom,ga_Vlocal_gb_h=int_hh,ga_Vlocal_gb_s=int_ss) @@ -1531,9 +1508,9 @@ SUBROUTINE dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins,error) DO ispin=1,nspins maxiso = SIZE(harmonics%slm,2) ALLOCATE(vth(nr,maxiso),vts(nr,maxiso),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dvth(nr,maxiso),dvts(nr,maxiso),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO iso=1,maxiso ww(1:na) = harmonics%slm(1:na,iso) vth(1:nr,iso) = MATMUL(ww(1:na),vtau_h(1:na,1:nr,ispin)) @@ -1548,10 +1525,10 @@ SUBROUTINE dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins,error) m2 = 0 DO iset2 = 1,nset CALL get_none0_cg_list(my_CG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local,error) - CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,error,failure) + max_s_harm,lmax_expansion,cg_list,cg_n_list,max_iso_not0_local) + CPPrecondition(max_iso_not0_local.LE.max_iso_not0,cp_failure_level,routineP,failure) CALL get_none0_cg_list(my_dCG,lmin(iset1),lmax(iset1),lmin(iset2),lmax(iset2),& - max_s_harm,lmax_expansion,dcg_list,dcg_n_list,dmax_iso_not0_local,error) + max_s_harm,lmax_expansion,dcg_list,dcg_n_list,dmax_iso_not0_local) n2 = nsoset(lmax(iset2)) DO ipgf1 = 1,npgf(iset1) @@ -1651,17 +1628,17 @@ SUBROUTINE dgaVtaudgb(vtau_h,vtau_s,qs_kind,rho_atom,nspins,error) m1 = m1 + maxso END DO ! iset1 DEALLOCATE(vth,vts,dvth,dvts,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END DO ! ispin DEALLOCATE(matso_h,matso_s,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(g1,g2,gg,dd,gr,ww,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(fgr,dgr,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(cg_list,cg_n_list,dcg_list,dcg_n_list,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) vtau_h = 2._dp*vtau_h vtau_s = 2._dp*vtau_s diff --git a/src/qs_wf_history_methods.F b/src/qs_wf_history_methods.F index 21a3e2d790..a227ee810d 100644 --- a/src/qs_wf_history_methods.F +++ b/src/qs_wf_history_methods.F @@ -107,16 +107,13 @@ MODULE qs_wf_history_methods ! ***************************************************************************** !> \brief allocates and initialize a wavefunction snapshot !> \param snapshot the snapshot to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> 02.2005 added wf_mol [MI] !> \author fawzi ! ***************************************************************************** -SUBROUTINE wfs_create(snapshot, error) +SUBROUTINE wfs_create(snapshot) TYPE(qs_wf_snapshot_type), POINTER :: snapshot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfs_create', & routineP = moduleN//':'//routineN @@ -127,7 +124,7 @@ SUBROUTINE wfs_create(snapshot, error) failure=.FALSE. ALLOCATE(snapshot, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_wfs_id=last_wfs_id+1 snapshot%id_nr=last_wfs_id NULLIFY(snapshot%wf, snapshot%rho_r, & @@ -143,19 +140,16 @@ END SUBROUTINE wfs_create !> \param wf_history the history !> \param qs_env the qs_env that should be snapshotted !> \param dt the time of the snapshot (wrt. to the previous snapshot) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> 02.2005 added kg_fm_mol_set for KG_GPW [MI] !> \author fawzi ! ***************************************************************************** -SUBROUTINE wfs_update(snapshot,wf_history,qs_env,dt,error) +SUBROUTINE wfs_update(snapshot,wf_history,qs_env,dt) TYPE(qs_wf_snapshot_type), POINTER :: snapshot TYPE(qs_wf_history_type), POINTER :: wf_history TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), INTENT(in), OPTIONAL :: dt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfs_update', & routineP = moduleN//':'//routineN @@ -184,136 +178,130 @@ SUBROUTINE wfs_update(snapshot,wf_history,qs_env,dt,error) NULLIFY(pw_env, auxbas_pw_pool, ao_mo_pools, dft_control, mos, mo_coeff,& rho, rho_r,rho_g,rho_ao, matrix_s) CALL get_qs_env(qs_env, pw_env=pw_env,& - dft_control=dft_control, rho=rho, error=error) - CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_pools, & - error=error) - CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, error=error) + dft_control=dft_control, rho=rho) + CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_pools) + CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool) - CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(dft_control),cp_failure_level,routineP,failure) IF (.not.ASSOCIATED(snapshot)) THEN - CALL wfs_create(snapshot,error=error) + CALL wfs_create(snapshot) END IF - CPPrecondition(wf_history%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(snapshot%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(wf_history%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(snapshot%ref_count>0,cp_failure_level,routineP,failure) nspins=dft_control%nspins snapshot%dt=1.0_dp IF (PRESENT(dt)) snapshot%dt=dt IF (wf_history%store_wf) THEN - CALL get_qs_env(qs_env,mos=mos,error=error) + CALL get_qs_env(qs_env,mos=mos) IF (.NOT.ASSOCIATED(snapshot%wf)) THEN CALL fm_pools_create_fm_vect(ao_mo_pools,snapshot%wf,& name="ws_snap"//TRIM(ADJUSTL(cp_to_string(snapshot%id_nr)))//& - "ws",error=error) - CPPostcondition(nspins==SIZE(snapshot%wf),cp_failure_level,routineP,error,failure) + "ws") + CPPostcondition(nspins==SIZE(snapshot%wf),cp_failure_level,routineP,failure) END IF DO ispin=1,nspins CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff) - CALL cp_fm_to_fm(mo_coeff,snapshot%wf(ispin)%matrix,error=error) + CALL cp_fm_to_fm(mo_coeff,snapshot%wf(ispin)%matrix) END DO ELSE IF (ASSOCIATED(snapshot%wf)) THEN - CALL fm_pools_give_back_fm_vect(ao_mo_pools,snapshot%wf,& - error=error) + CALL fm_pools_give_back_fm_vect(ao_mo_pools,snapshot%wf) END IF IF (wf_history%store_rho_r) THEN - CALL qs_rho_get(rho, rho_r=rho_r,error=error) - CPPrecondition(ASSOCIATED(rho_r),cp_failure_level,routineP,error,failure) + CALL qs_rho_get(rho, rho_r=rho_r) + CPPrecondition(ASSOCIATED(rho_r),cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(snapshot%rho_r)) THEN ALLOCATE(snapshot%rho_r(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(snapshot%rho_r(ispin)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,snapshot%rho_r(ispin)%pw,& - in_space=REALSPACE, use_data=REALDATA3D,error=error) + in_space=REALSPACE, use_data=REALDATA3D) END DO END IF DO ispin=1,nspins - CALL pw_copy(rho_r(ispin)%pw,snapshot%rho_r(ispin)%pw,error=error) + CALL pw_copy(rho_r(ispin)%pw,snapshot%rho_r(ispin)%pw) END DO ELSE IF (ASSOCIATED(snapshot%rho_r)) THEN DO ispin=1,SIZE(snapshot%rho_r) - CALL pw_pool_give_back_pw(auxbas_pw_pool,snapshot%rho_r(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,snapshot%rho_r(ispin)%pw) END DO DEALLOCATE(snapshot%rho_r,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (wf_history%store_rho_g) THEN - CALL qs_rho_get(rho, rho_g=rho_g,error=error) - CPPrecondition(ASSOCIATED(rho_g),cp_failure_level,routineP,error,failure) + CALL qs_rho_get(rho, rho_g=rho_g) + CPPrecondition(ASSOCIATED(rho_g),cp_failure_level,routineP,failure) IF (.NOT.ASSOCIATED(snapshot%rho_g)) THEN ALLOCATE(snapshot%rho_g(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(snapshot%rho_g(ispin)%pw) CALL pw_pool_create_pw(auxbas_pw_pool,snapshot%rho_g(ispin)%pw,& - in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D,& - error=error) + in_space=RECIPROCALSPACE,use_data=COMPLEXDATA1D) END DO END IF DO ispin=1,nspins - CALL pw_copy(rho_g(ispin)%pw,snapshot%rho_g(ispin)%pw,error=error) + CALL pw_copy(rho_g(ispin)%pw,snapshot%rho_g(ispin)%pw) END DO ELSE IF (ASSOCIATED(snapshot%rho_g)) THEN DO ispin=1,SIZE(snapshot%rho_g) - CALL pw_pool_give_back_pw(auxbas_pw_pool,snapshot%rho_g(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,snapshot%rho_g(ispin)%pw) END DO DEALLOCATE(snapshot%rho_g,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(snapshot%rho_ao)) THEN ! the sparsity might be different ! (future struct:check) - CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao,error=error) + CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao) END IF IF (wf_history%store_rho_ao) THEN - CALL qs_rho_get(rho,rho_ao=rho_ao,error=error) - CPPrecondition(ASSOCIATED(rho_ao),cp_failure_level,routineP,error,failure) + CALL qs_rho_get(rho,rho_ao=rho_ao) + CPPrecondition(ASSOCIATED(rho_ao),cp_failure_level,routineP,failure) - CALL cp_dbcsr_allocate_matrix_set(snapshot%rho_ao,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(snapshot%rho_ao,nspins) DO ispin=1,nspins ALLOCATE(snapshot%rho_ao(ispin)%matrix) - CALL cp_dbcsr_init(snapshot%rho_ao(ispin)%matrix,error=error) - CALL cp_dbcsr_copy(snapshot%rho_ao(ispin)%matrix,rho_ao(ispin)%matrix,& - error=error) + CALL cp_dbcsr_init(snapshot%rho_ao(ispin)%matrix) + CALL cp_dbcsr_copy(snapshot%rho_ao(ispin)%matrix,rho_ao(ispin)%matrix) END DO END IF IF (ASSOCIATED(snapshot%rho_ao_kp)) THEN ! the sparsity might be different ! (future struct:check) - CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao_kp,error=error) + CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao_kp) END IF IF (wf_history%store_rho_ao_kp) THEN - CALL qs_rho_get(rho,rho_ao_kp=rho_ao_kp,error=error) - CPPrecondition(ASSOCIATED(rho_ao_kp),cp_failure_level,routineP,error,failure) + CALL qs_rho_get(rho,rho_ao_kp=rho_ao_kp) + CPPrecondition(ASSOCIATED(rho_ao_kp),cp_failure_level,routineP,failure) nimg = dft_control%nimages - CALL cp_dbcsr_allocate_matrix_set(snapshot%rho_ao_kp,nspins,nimg,error=error) + CALL cp_dbcsr_allocate_matrix_set(snapshot%rho_ao_kp,nspins,nimg) DO ispin=1,nspins DO img=1,nimg ALLOCATE(snapshot%rho_ao_kp(ispin,img)%matrix) - CALL cp_dbcsr_init(snapshot%rho_ao_kp(ispin,img)%matrix,error=error) + CALL cp_dbcsr_init(snapshot%rho_ao_kp(ispin,img)%matrix) CALL cp_dbcsr_copy(snapshot%rho_ao_kp(ispin,img)%matrix,& - rho_ao_kp(ispin,img)%matrix,error=error) + rho_ao_kp(ispin,img)%matrix) END DO END DO END IF IF (ASSOCIATED(snapshot%overlap)) THEN ! the sparsity might be different ! (future struct:check) - CALL cp_dbcsr_deallocate_matrix(snapshot%overlap,error=error) + CALL cp_dbcsr_deallocate_matrix(snapshot%overlap) END IF IF (wf_history%store_overlap) THEN - CALL get_qs_env(qs_env, matrix_s=matrix_s, error=error) - CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_s(1)%matrix),cp_failure_level,routineP,error,failure) + CALL get_qs_env(qs_env, matrix_s=matrix_s) + CPPrecondition(ASSOCIATED(matrix_s),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_s(1)%matrix),cp_failure_level,routineP,failure) ALLOCATE(snapshot%overlap) - CALL cp_dbcsr_init(snapshot%overlap, error=error) - CALL cp_dbcsr_copy(snapshot%overlap, matrix_s(1)%matrix, error=error) + CALL cp_dbcsr_init(snapshot%overlap) + CALL cp_dbcsr_copy(snapshot%overlap, matrix_s(1)%matrix) END IF IF (wf_history%store_frozen_density) THEN @@ -333,19 +321,16 @@ END SUBROUTINE wfs_update !> (see qs_wf_history_types:wfi_*_method_nr) !> \param extrapolation_order ... !> \param has_unit_metric ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** SUBROUTINE wfi_create(wf_history, interpolation_method_nr, extrapolation_order, & - has_unit_metric, error) + has_unit_metric) TYPE(qs_wf_history_type), POINTER :: wf_history INTEGER, INTENT(in) :: interpolation_method_nr, & extrapolation_order LOGICAL, INTENT(IN) :: has_unit_metric - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfi_create', & routineP = moduleN//':'//routineN @@ -358,7 +343,7 @@ SUBROUTINE wfi_create(wf_history, interpolation_method_nr, extrapolation_order, failure=.FALSE. ALLOCATE(wf_history, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_wfi_id=last_wfi_id+1 wf_history%id_nr=last_wfi_id wf_history%ref_count=1 @@ -414,11 +399,11 @@ SUBROUTINE wfi_create(wf_history, interpolation_method_nr, extrapolation_order, routineP,"Unknown interpolation method: "//& TRIM(ADJUSTL(cp_to_string(interpolation_method_nr)))//" in "//& CPSourceFileRef,& - error, failure) + failure) wf_history%interpolation_method_nr=wfi_use_prev_rho_r_method_nr END SELECT ALLOCATE(wf_history%past_states(wf_history%memory_depth),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(wf_history%past_states) NULLIFY(wf_history%past_states(i)%snapshot) @@ -430,15 +415,12 @@ END SUBROUTINE wfi_create ! ***************************************************************************** !> \brief ... !> \param wf_history ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2015 created [jhu] !> \author fawzi ! ***************************************************************************** -SUBROUTINE wfi_create_for_kp(wf_history, error) +SUBROUTINE wfi_create_for_kp(wf_history) TYPE(qs_wf_history_type), POINTER :: wf_history - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfi_create_for_kp', & routineP = moduleN//':'//routineN @@ -446,7 +428,7 @@ SUBROUTINE wfi_create_for_kp(wf_history, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,failure) IF(wf_history%store_rho_ao) THEN wf_history%store_rho_ao_kp = .TRUE. wf_history%store_rho_ao = .FALSE. @@ -455,17 +437,17 @@ SUBROUTINE wfi_create_for_kp(wf_history, error) IF(wf_history%store_wf) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"WFN based interpolation method not possible for kpoints.",& - error, failure) + failure) END IF IF(wf_history%store_frozen_density) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Frozen density initialization method not possible for kpoints.",& - error, failure) + failure) END IF IF(wf_history%store_overlap) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Inconsistent interpolation method for kpoints.",& - error, failure) + failure) END IF END SUBROUTINE wfi_create_for_kp @@ -473,16 +455,13 @@ END SUBROUTINE wfi_create_for_kp ! ***************************************************************************** !> \brief returns a string describing the interpolation method !> \param method_nr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -FUNCTION wfi_get_method_label(method_nr,error) RESULT(res) +FUNCTION wfi_get_method_label(method_nr) RESULT(res) INTEGER, INTENT(in) :: method_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=30) :: res CHARACTER(len=*), PARAMETER :: routineN = 'wfi_get_method_label', & @@ -520,7 +499,7 @@ FUNCTION wfi_get_method_label(method_nr,error) RESULT(res) TRIM(ADJUSTL(cp_to_string(method_nr)))//& " in "//& CPSourceFileRef,& - error, failure) + failure) END SELECT END FUNCTION wfi_get_method_label @@ -533,21 +512,18 @@ END FUNCTION wfi_get_method_label !> \param dt the time at which to extrapolate (wrt. to the last snapshot) !> \param extrapolation_method_nr returns the extrapolation method used !> \param orthogonal_wf ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> 11.2003 Joost VandeVondele : Implemented Nth order PS extrapolation !> \author fawzi ! ***************************************************************************** SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & - orthogonal_wf, error) + orthogonal_wf) TYPE(qs_wf_history_type), POINTER :: wf_history TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), INTENT(IN) :: dt INTEGER, INTENT(OUT), OPTIONAL :: extrapolation_method_nr LOGICAL, INTENT(OUT), OPTIONAL :: orthogonal_wf - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfi_extrapolate', & routineP = moduleN//':'//routineN @@ -579,17 +555,17 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & use_overlap = wf_history%store_overlap CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() print_level = logger%iter_info%print_level output_unit = cp_print_key_unit_nr(logger,qs_env%input,"DFT%SCF%PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) - - CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,error,failure) - CPPrecondition(wf_history%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) - CALL get_qs_env(qs_env, mos=mos, rho=rho, do_kpoints=do_kpoints, error=error) - CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools, error=error) + extension=".scfLog") + + CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,failure) + CPPrecondition(wf_history%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) + CALL get_qs_env(qs_env, mos=mos, rho=rho, do_kpoints=do_kpoints) + CALL mpools_get(qs_env%mpools, ao_mo_fm_pools=ao_mo_fm_pools) ! chooses the method for this extrapolation IF (wf_history%snapshot_count<1) THEN actual_extrapolation_method_nr=wfi_use_guess_method_nr @@ -618,104 +594,99 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & SELECT CASE (actual_extrapolation_method_nr) CASE(wfi_frozen_method_nr) - CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,error,failure) - t0_state => wfi_get_snapshot(wf_history, index=1, error=error) - CPPrecondition(ASSOCIATED(t0_state%rho_frozen),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,failure) + t0_state => wfi_get_snapshot(wf_history, index=1) + CPPrecondition(ASSOCIATED(t0_state%rho_frozen),cp_failure_level,routineP,failure) nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec, error=error) + CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec) - CALL qs_rho_get(t0_state%rho_frozen, rho_ao=rho_frozen_ao, error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(t0_state%rho_frozen, rho_ao=rho_frozen_ao) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(rho_frozen_ao) CALL cp_dbcsr_copy(rho_ao(ispin)%matrix,& rho_frozen_ao(ispin)%matrix,& - keep_sparsity=.TRUE.,& - error=error) + keep_sparsity=.TRUE.) END DO !FM updating rho_ao directly with t0_state%rho_ao would have the !FM wrong matrix structure - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env, rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env, rho_changed=.TRUE.) my_orthogonal_wf=.FALSE. CASE(wfi_use_prev_rho_r_method_nr) - t0_state => wfi_get_snapshot(wf_history, index=1, error=error) + t0_state => wfi_get_snapshot(wf_history, index=1) nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec, error=error) + CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec) IF(do_kpoints) THEN - CPPrecondition(ASSOCIATED(t0_state%rho_ao_kp),cp_failure_level,routineP,error,failure) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CPPrecondition(ASSOCIATED(t0_state%rho_ao_kp),cp_failure_level,routineP,failure) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) DO ispin=1,SIZE(t0_state%rho_ao_kp,1) DO img=1,SIZE(t0_state%rho_ao_kp,2) CALL cp_dbcsr_copy(rho_ao_kp(ispin,img)%matrix,& t0_state%rho_ao_kp(ispin,img)%matrix,& - keep_sparsity=.TRUE.,& - error=error) + keep_sparsity=.TRUE.) END DO END DO ELSE - CPPrecondition(ASSOCIATED(t0_state%rho_ao),cp_failure_level,routineP,error,failure) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CPPrecondition(ASSOCIATED(t0_state%rho_ao),cp_failure_level,routineP,failure) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(t0_state%rho_ao) CALL cp_dbcsr_copy(rho_ao(ispin)%matrix,& t0_state%rho_ao(ispin)%matrix,& - keep_sparsity=.TRUE.,& - error=error) + keep_sparsity=.TRUE.) END DO END IF ! Why is rho_g valid at this point ? - CALL qs_rho_set(rho, rho_g_valid=.TRUE., error=error) + CALL qs_rho_set(rho, rho_g_valid=.TRUE.) ! does nothing CASE(wfi_use_prev_wf_method_nr) - CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,failure) my_orthogonal_wf=.TRUE. nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec, error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(mos) CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff,& nmo=nmo) CALL reorthogonalize_vectors(qs_env,& v_matrix=mo_coeff,& - n_col=nmo, error=error) + n_col=nmo) CALL calculate_density_matrix(mo_set=mos(ispin)%mo_set,& - density_matrix=rho_ao(ispin)%matrix,error=error) + density_matrix=rho_ao(ispin)%matrix) END DO - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CASE(wfi_use_prev_p_method_nr) - CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,error,failure) - t0_state => wfi_get_snapshot(wf_history, index=1, error=error) + CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,failure) + t0_state => wfi_get_snapshot(wf_history, index=1) nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec, error=error) + CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec) IF(do_kpoints) THEN - CPPrecondition(ASSOCIATED(t0_state%rho_ao_kp),cp_failure_level,routineP,error,failure) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CPPrecondition(ASSOCIATED(t0_state%rho_ao_kp),cp_failure_level,routineP,failure) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) DO ispin=1,SIZE(t0_state%rho_ao_kp,1) DO img=1,SIZE(t0_state%rho_ao_kp,2) CALL cp_dbcsr_copy(rho_ao_kp(ispin,img)%matrix,& t0_state%rho_ao_kp(ispin,img)%matrix,& - keep_sparsity=.TRUE.,& - error=error) + keep_sparsity=.TRUE.) END DO END DO ELSE - CPPrecondition(ASSOCIATED(t0_state%rho_ao),cp_failure_level,routineP,error,failure) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CPPrecondition(ASSOCIATED(t0_state%rho_ao),cp_failure_level,routineP,failure) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(t0_state%rho_ao) CALL cp_dbcsr_copy(rho_ao(ispin)%matrix,& t0_state%rho_ao(ispin)%matrix,& - keep_sparsity=.TRUE.,& - error=error) + keep_sparsity=.TRUE.) END DO END IF !FM updating rho_ao directly with t0_state%rho_ao would have the !FM wrong matrix structure - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env, rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env, rho_changed=.TRUE.) CASE(wfi_use_guess_method_nr) !FM more clean to do it here, but it @@ -724,98 +695,97 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & !FM (btw. it also needs the eigensolver, and unless you relocate it !FM gives circular dependencies) nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec, error=error) + CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec) CASE(wfi_linear_wf_method_nr) - CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,error,failure) - t0_state => wfi_get_snapshot(wf_history, index=2, error=error) - t1_state => wfi_get_snapshot(wf_history, index=1, error=error) - CPPrecondition(ASSOCIATED(t0_state),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t0_state%wf),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state%wf),cp_warning_level,routineP,error,failure) + CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,failure) + t0_state => wfi_get_snapshot(wf_history, index=2) + t1_state => wfi_get_snapshot(wf_history, index=1) + CPPrecondition(ASSOCIATED(t0_state),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t0_state%wf),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state%wf),cp_warning_level,routineP,failure) nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec, error=error) + CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec) my_orthogonal_wf=.TRUE. t0=0.0_dp t1=t1_state%dt t2=t1+dt - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(mos) CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff,& nmo=nmo) CALL cp_fm_scale_and_add(alpha=0.0_dp,& matrix_a=mo_coeff,& matrix_b=t1_state%wf(ispin)%matrix,& - beta=(t2-t0)/(t1-t0),& - error=error) ! this copy should be unnecessary + beta=(t2-t0)/(t1-t0)) + ! this copy should be unnecessary CALL cp_fm_scale_and_add(alpha=1.0_dp,& matrix_a=mo_coeff,& - beta=(t1-t2)/(t1-t0), matrix_b=t0_state%wf(ispin)%matrix,& - error=error) + beta=(t1-t2)/(t1-t0), matrix_b=t0_state%wf(ispin)%matrix) CALL reorthogonalize_vectors(qs_env,& v_matrix=mo_coeff,& - n_col=nmo, error=error) + n_col=nmo) CALL calculate_density_matrix(mo_set=mos(ispin)%mo_set,& - density_matrix=rho_ao(ispin)%matrix,error=error) + density_matrix=rho_ao(ispin)%matrix) END DO - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) CALL qs_ks_did_change(qs_env%ks_env,& - rho_changed=.TRUE., error=error) + rho_changed=.TRUE.) CASE(wfi_linear_p_method_nr) - t0_state => wfi_get_snapshot(wf_history, index=2, error=error) - t1_state => wfi_get_snapshot(wf_history, index=1, error=error) - CPPrecondition(ASSOCIATED(t0_state),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state),cp_warning_level,routineP,error,failure) + t0_state => wfi_get_snapshot(wf_history, index=2) + t1_state => wfi_get_snapshot(wf_history, index=1) + CPPrecondition(ASSOCIATED(t0_state),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state),cp_warning_level,routineP,failure) IF(do_kpoints) THEN - CPPrecondition(ASSOCIATED(t0_state%rho_ao_kp),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state%rho_ao_kp),cp_warning_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(t0_state%rho_ao_kp),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state%rho_ao_kp),cp_warning_level,routineP,failure) ELSE - CPPrecondition(ASSOCIATED(t0_state%rho_ao),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state%rho_ao),cp_warning_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(t0_state%rho_ao),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state%rho_ao),cp_warning_level,routineP,failure) END IF nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec, error=error) + CALL wfi_set_history_variables(qs_env=qs_env, nvec=nvec) t0=0.0_dp t1=t1_state%dt t2=t1+dt IF(do_kpoints) THEN - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) DO ispin=1,SIZE(rho_ao_kp,1) DO img=1,SIZE(rho_ao_kp,2) CALL cp_dbcsr_add(rho_ao_kp(ispin,img)%matrix,t1_state%rho_ao_kp(ispin,img)%matrix,& - alpha_scalar=0.0_dp,beta_scalar=(t2-t0)/(t1-t0),error=error) ! this copy should be unnecessary + alpha_scalar=0.0_dp,beta_scalar=(t2-t0)/(t1-t0)) ! this copy should be unnecessary CALL cp_dbcsr_add(rho_ao_kp(ispin,img)%matrix,t0_state%rho_ao_kp(ispin,img)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=(t1-t2)/(t1-t0),error=error) + alpha_scalar=1.0_dp,beta_scalar=(t1-t2)/(t1-t0)) END DO END DO ELSE - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(rho_ao) CALL cp_dbcsr_add(rho_ao(ispin)%matrix,t1_state%rho_ao(ispin)%matrix,& - alpha_scalar=0.0_dp,beta_scalar=(t2-t0)/(t1-t0),error=error) ! this copy should be unnecessary + alpha_scalar=0.0_dp,beta_scalar=(t2-t0)/(t1-t0)) ! this copy should be unnecessary CALL cp_dbcsr_add(rho_ao(ispin)%matrix,t0_state%rho_ao(ispin)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=(t1-t2)/(t1-t0),error=error) + alpha_scalar=1.0_dp,beta_scalar=(t1-t2)/(t1-t0)) END DO END IF - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env, rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env, rho_changed=.TRUE.) ! wf not calculated, extract with PSC renormalized? ! use wf_linear? CASE(wfi_linear_ps_method_nr) - CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,error,failure) - t0_state => wfi_get_snapshot(wf_history, index=2, error=error) - t1_state => wfi_get_snapshot(wf_history, index=1, error=error) - CPPrecondition(ASSOCIATED(t0_state),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t0_state%wf),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state%wf),cp_warning_level,routineP,error,failure) + CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,failure) + t0_state => wfi_get_snapshot(wf_history, index=2) + t1_state => wfi_get_snapshot(wf_history, index=1) + CPPrecondition(ASSOCIATED(t0_state),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t0_state%wf),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state%wf),cp_warning_level,routineP,failure) IF (wf_history%store_overlap) THEN - CPPrecondition(ASSOCIATED(t0_state%overlap),cp_warning_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(t1_state%overlap),cp_warning_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(t0_state%overlap),cp_warning_level,routineP,failure) + CPPrecondition(ASSOCIATED(t1_state%overlap),cp_warning_level,routineP,failure) END IF nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) IF (nvec >= wf_history%memory_depth) THEN @@ -834,41 +804,41 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & my_orthogonal_wf=.TRUE. ! use PS_2=2 PS_1-PS_0 ! C_2 comes from using PS_2 as a projector acting on C_1 - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(mos) NULLIFY(mo_coeff,matrix_struct,matrix_struct_new,csc) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) CALL cp_fm_get_info(mo_coeff,nrow_global=n,ncol_global=k, & - matrix_struct=matrix_struct,error=error) + matrix_struct=matrix_struct) CALL cp_fm_struct_create(matrix_struct_new,template_fmstruct=matrix_struct, & - nrow_global=k,ncol_global=k,error=error) - CALL cp_fm_create(csc,matrix_struct_new,error=error) - CALL cp_fm_struct_release(matrix_struct_new,error=error) + nrow_global=k,ncol_global=k) + CALL cp_fm_create(csc,matrix_struct_new) + CALL cp_fm_struct_release(matrix_struct_new) IF ( use_overlap ) THEN - CALL cp_dbcsr_sm_fm_multiply(t0_state%overlap,t1_state%wf(ispin)%matrix,mo_coeff, k,error=error) - CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,mo_coeff,0.0_dp,csc,error=error) + CALL cp_dbcsr_sm_fm_multiply(t0_state%overlap,t1_state%wf(ispin)%matrix,mo_coeff, k) + CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,mo_coeff,0.0_dp,csc) ELSE CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,& - t1_state%wf(ispin)%matrix,0.0_dp,csc,error=error) + t1_state%wf(ispin)%matrix,0.0_dp,csc) END IF - CALL cp_gemm('N','N',n,k,k,1.0_dp,t0_state%wf(ispin)%matrix,csc,0.0_dp,mo_coeff,error=error) - CALL cp_fm_release(csc,error=error) - CALL cp_fm_scale_and_add(-1.0_dp,mo_coeff,2.0_dp,t1_state%wf(ispin)%matrix,error=error) + CALL cp_gemm('N','N',n,k,k,1.0_dp,t0_state%wf(ispin)%matrix,csc,0.0_dp,mo_coeff) + CALL cp_fm_release(csc) + CALL cp_fm_scale_and_add(-1.0_dp,mo_coeff,2.0_dp,t1_state%wf(ispin)%matrix) CALL reorthogonalize_vectors(qs_env,& v_matrix=mo_coeff,& - n_col=k, error=error) + n_col=k) CALL calculate_density_matrix(mo_set=mos(ispin)%mo_set,& - density_matrix=rho_ao(ispin)%matrix,error=error) + density_matrix=rho_ao(ispin)%matrix) END DO - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CASE(wfi_ps_method_nr) - CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,failure) ! figure out the actual number of vectors to use in the extrapolation: nvec = MIN(wf_history%memory_depth, wf_history%snapshot_count) - CPPrecondition(nvec .GT. 0,cp_failure_level,routineP,error,failure) + CPPrecondition(nvec .GT. 0,cp_failure_level,routineP,failure) IF (nvec >= wf_history%memory_depth) THEN IF ((qs_env%scf_control%max_scf_hist .NE. 0) .AND. (qs_env%scf_control%eps_scf_hist .NE. 0)) THEN qs_env%scf_control%max_scf = qs_env%scf_control%max_scf_hist @@ -887,49 +857,49 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & NULLIFY(mo_coeff,matrix_struct,matrix_struct_new,csc,fm_tmp) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) CALL cp_fm_get_info(mo_coeff,nrow_global=n,ncol_global=k, & - matrix_struct=matrix_struct,error=error) - CALL cp_fm_create(fm_tmp,matrix_struct,error=error) + matrix_struct=matrix_struct) + CALL cp_fm_create(fm_tmp,matrix_struct) CALL cp_fm_struct_create(matrix_struct_new,template_fmstruct=matrix_struct, & - nrow_global=k,ncol_global=k,error=error) - CALL cp_fm_create(csc,matrix_struct_new,error=error) - CALL cp_fm_struct_release(matrix_struct_new,error=error) + nrow_global=k,ncol_global=k) + CALL cp_fm_create(csc,matrix_struct_new) + CALL cp_fm_struct_release(matrix_struct_new) ! first the most recent - t1_state => wfi_get_snapshot(wf_history, index=1, error=error) - CALL cp_fm_to_fm(t1_state%wf(ispin)%matrix,mo_coeff,error=error) + t1_state => wfi_get_snapshot(wf_history, index=1) + CALL cp_fm_to_fm(t1_state%wf(ispin)%matrix,mo_coeff) alpha = nvec - CALL cp_fm_scale(alpha,mo_coeff,error=error) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL cp_fm_scale(alpha,mo_coeff) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO i=2,nvec - t0_state => wfi_get_snapshot(wf_history, index=i, error=error) + t0_state => wfi_get_snapshot(wf_history, index=i) IF ( use_overlap ) THEN - CALL cp_dbcsr_sm_fm_multiply(t0_state%overlap,t1_state%wf(ispin)%matrix,fm_tmp, k,error=error) - CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,fm_tmp,0.0_dp,csc,error=error) + CALL cp_dbcsr_sm_fm_multiply(t0_state%overlap,t1_state%wf(ispin)%matrix,fm_tmp, k) + CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,fm_tmp,0.0_dp,csc) ELSE CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,& - t1_state%wf(ispin)%matrix,0.0_dp,csc,error=error) + t1_state%wf(ispin)%matrix,0.0_dp,csc) END IF - CALL cp_gemm('N','N',n,k,k,1.0_dp,t0_state%wf(ispin)%matrix,csc,0.0_dp,fm_tmp,error=error) + CALL cp_gemm('N','N',n,k,k,1.0_dp,t0_state%wf(ispin)%matrix,csc,0.0_dp,fm_tmp) alpha = -1.0_dp * alpha * REAL(nvec - i + 1 , dp ) / REAL(i , dp ) - CALL cp_fm_scale_and_add(1.0_dp,mo_coeff,alpha,fm_tmp,error=error) + CALL cp_fm_scale_and_add(1.0_dp,mo_coeff,alpha,fm_tmp) ENDDO - CALL cp_fm_release(csc,error=error) - CALL cp_fm_release(fm_tmp,error=error) + CALL cp_fm_release(csc) + CALL cp_fm_release(fm_tmp) CALL reorthogonalize_vectors(qs_env,& v_matrix=mo_coeff,& - n_col=k, error=error) + n_col=k) CALL calculate_density_matrix(mo_set=mos(ispin)%mo_set,& - density_matrix=rho_ao(ispin)%matrix,error=error) + density_matrix=rho_ao(ispin)%matrix) END DO - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE., error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CASE (wfi_aspc_nr) - CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT. do_kpoints,cp_failure_level,routineP,failure) CALL cite_reference(Kolafa2004) ! figure out the actual number of vectors to use in the extrapolation: nvec = MIN(wf_history%memory_depth,wf_history%snapshot_count) - CPPrecondition(nvec.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(nvec.GT.0,cp_failure_level,routineP,failure) IF (nvec >= wf_history%memory_depth) THEN IF ((qs_env%scf_control%max_scf_hist .NE. 0) .AND. & (qs_env%scf_control%eps_scf_hist .NE. 0)) THEN @@ -945,26 +915,25 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & END IF my_orthogonal_wf = .TRUE. - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(mos) NULLIFY (mo_coeff,matrix_struct,matrix_struct_new,csc,fm_tmp) CALL get_mo_set(mo_set=mos(ispin)%mo_set,mo_coeff=mo_coeff) CALL cp_fm_get_info(mo_coeff,& nrow_global=n,& ncol_global=k,& - matrix_struct=matrix_struct,error=error) - CALL cp_fm_create(fm_tmp,matrix_struct,error=error) + matrix_struct=matrix_struct) + CALL cp_fm_create(fm_tmp,matrix_struct) CALL cp_fm_struct_create(matrix_struct_new,& template_fmstruct=matrix_struct,& nrow_global=k,& - ncol_global=k,error=error) - CALL cp_fm_create(csc,matrix_struct_new,error=error) - CALL cp_fm_struct_release(matrix_struct_new,error=error) + ncol_global=k) + CALL cp_fm_create(csc,matrix_struct_new) + CALL cp_fm_struct_release(matrix_struct_new) ! first the most recent t1_state => wfi_get_snapshot(wf_history,& - index=1,& - error=error) - CALL cp_fm_to_fm(t1_state%wf(ispin)%matrix,mo_coeff,error=error) + index=1) + CALL cp_fm_to_fm(t1_state%wf(ispin)%matrix,mo_coeff) alpha = REAL(4*nvec - 2,KIND=dp)/REAL(nvec + 1,KIND=dp) IF ((output_unit > 0).AND.(print_level > low_print_level)) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A,/,/,T3,A,I0,/,/,T3,A2,I0,A4,F10.6)")& @@ -972,38 +941,36 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & "ASPC order: ",MAX(nvec - 2,0),& "B(",1,") = ",alpha END IF - CALL cp_fm_scale(alpha,mo_coeff,error=error) + CALL cp_fm_scale(alpha,mo_coeff) DO i=2,nvec - t0_state => wfi_get_snapshot(wf_history,index=i,error=error) + t0_state => wfi_get_snapshot(wf_history,index=i) IF ( use_overlap ) THEN - CALL cp_dbcsr_sm_fm_multiply(t0_state%overlap,t1_state%wf(ispin)%matrix,fm_tmp,k,error=error) - CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,fm_tmp,0.0_dp,csc,error=error) + CALL cp_dbcsr_sm_fm_multiply(t0_state%overlap,t1_state%wf(ispin)%matrix,fm_tmp,k) + CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,fm_tmp,0.0_dp,csc) ELSE CALL cp_gemm('T','N',k,k,n,1.0_dp,t0_state%wf(ispin)%matrix,& - t1_state%wf(ispin)%matrix,0.0_dp,csc,error=error) + t1_state%wf(ispin)%matrix,0.0_dp,csc) END IF - CALL cp_gemm('N','N',n,k,k,1.0_dp,t0_state%wf(ispin)%matrix,csc,0.0_dp,fm_tmp,error=error) + CALL cp_gemm('N','N',n,k,k,1.0_dp,t0_state%wf(ispin)%matrix,csc,0.0_dp,fm_tmp) alpha = (-1.0_dp)**(i + 1)*REAL(i,KIND=dp)*& binomial(2*nvec,nvec - i)/binomial(2*nvec - 2,nvec -1) IF ((output_unit > 0).AND.(print_level > low_print_level)) THEN WRITE (UNIT=output_unit,FMT="(T3,A2,I0,A4,F10.6)")& "B(",i,") = ",alpha END IF - CALL cp_fm_scale_and_add(1.0_dp,mo_coeff,alpha,fm_tmp,error=error) + CALL cp_fm_scale_and_add(1.0_dp,mo_coeff,alpha,fm_tmp) END DO - CALL cp_fm_release(csc,error=error) - CALL cp_fm_release(fm_tmp,error=error) + CALL cp_fm_release(csc) + CALL cp_fm_release(fm_tmp) CALL reorthogonalize_vectors(qs_env,& v_matrix=mo_coeff,& - n_col=k,& - error=error) + n_col=k) CALL calculate_density_matrix(mo_set=mos(ispin)%mo_set,& - density_matrix=rho_ao(ispin)%matrix,& - error=error) + density_matrix=rho_ao(ispin)%matrix) END DO - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.,error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& @@ -1011,11 +978,11 @@ SUBROUTINE wfi_extrapolate(wf_history, qs_env, dt, extrapolation_method_nr, & TRIM(ADJUSTL(cp_to_string(wf_history%interpolation_method_nr)))//& " in "//& CPSourceFileRef,& - error, failure) + failure) END SELECT IF (PRESENT(orthogonal_wf)) orthogonal_wf=my_orthogonal_wf CALL cp_print_key_finished_output(output_unit,logger,qs_env%input,& - "DFT%SCF%PRINT%PROGRAM_RUN_INFO",error=error) + "DFT%SCF%PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE wfi_extrapolate @@ -1024,16 +991,13 @@ END SUBROUTINE wfi_extrapolate !> to using a WF extrapolation. !> \param qs_env The QS environment !> \param nvec ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2006 created [TdK] !> \author Thomas D. Kuehne (tkuehne@phys.chem.ethz.ch) ! ***************************************************************************** - SUBROUTINE wfi_set_history_variables(qs_env, nvec, error) + SUBROUTINE wfi_set_history_variables(qs_env, nvec) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: nvec - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfi_set_history_variables', & routineP = moduleN//':'//routineN @@ -1044,8 +1008,8 @@ SUBROUTINE wfi_set_history_variables(qs_env, nvec, error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env), cp_failure_level, routineP, error, failure) - CPPrecondition(qs_env%ref_count>0, cp_failure_level, routineP, error, failure) + CPPrecondition(ASSOCIATED(qs_env), cp_failure_level, routineP,failure) + CPPrecondition(qs_env%ref_count>0, cp_failure_level, routineP,failure) IF (nvec >= qs_env%wf_history%memory_depth) THEN IF ((qs_env%scf_control%max_scf_hist .NE. 0) .AND. (qs_env%scf_control%eps_scf_hist .NE. 0)) THEN @@ -1070,17 +1034,14 @@ END SUBROUTINE wfi_set_history_variables !> \param wf_history the history buffer to update !> \param qs_env the qs_env we get the info from !> \param dt ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE wfi_update(wf_history, qs_env, dt, error) +SUBROUTINE wfi_update(wf_history, qs_env, dt) TYPE(qs_wf_history_type), POINTER :: wf_history TYPE(qs_environment_type), POINTER :: qs_env REAL(KIND=dp), INTENT(in) :: dt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfi_update', & routineP = moduleN//':'//routineN @@ -1089,10 +1050,10 @@ SUBROUTINE wfi_update(wf_history, qs_env, dt, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,error,failure) - CPPrecondition(wf_history%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,failure) + CPPrecondition(wf_history%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) wf_history%snapshot_count=wf_history%snapshot_count+1 IF (wf_history%memory_depth>0) THEN @@ -1100,7 +1061,7 @@ SUBROUTINE wfi_update(wf_history, qs_env, dt, error) wf_history%memory_depth)+1 CALL wfs_update(snapshot=wf_history%past_states & (wf_history%last_state_index)%snapshot,wf_history=wf_history,& - qs_env=qs_env,dt=dt,error=error) + qs_env=qs_env,dt=dt) END IF END SUBROUTINE wfi_update @@ -1109,17 +1070,14 @@ END SUBROUTINE wfi_update !> \param qs_env the qs_env in which to orthogonalize !> \param v_matrix the vectors to orthogonalize !> \param n_col number of column of v to orthogonalize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE reorthogonalize_vectors(qs_env, v_matrix, n_col,error) + SUBROUTINE reorthogonalize_vectors(qs_env, v_matrix, n_col) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_fm_type), POINTER :: v_matrix INTEGER, INTENT(in), OPTIONAL :: n_col - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reorthogonalize_vectors', & routineP = moduleN//':'//routineN @@ -1140,20 +1098,18 @@ SUBROUTINE reorthogonalize_vectors(qs_env, v_matrix, n_col,error) NULLIFY(scf_env, scf_control, maxao_maxmo_fm_pool, matrix_s, mpools, dft_control) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(v_matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(v_matrix),cp_failure_level,routineP,failure) - CALL cp_fm_get_info(v_matrix,ncol_global=my_n_col,error=error) + CALL cp_fm_get_info(v_matrix,ncol_global=my_n_col) IF (PRESENT(n_col)) my_n_col=n_col CALL get_qs_env(qs_env,mpools=mpools,& scf_env=scf_env,& scf_control=scf_control,& matrix_s=matrix_s,& - dft_control=dft_control,& - error=error) - CALL mpools_get(mpools,maxao_maxmo_fm_pool=maxao_maxmo_fm_pool,& - error=error) + dft_control=dft_control) + CALL mpools_get(mpools,maxao_maxmo_fm_pool=maxao_maxmo_fm_pool) IF (ASSOCIATED(scf_env)) THEN ortho_contains_cholesky=(scf_env%method /= ot_method_nr).AND.& (scf_env%cholesky_method>0 ).AND.& @@ -1162,7 +1118,7 @@ SUBROUTINE reorthogonalize_vectors(qs_env, v_matrix, n_col,error) ortho_contains_cholesky=.FALSE. END IF - CALL get_qs_env(qs_env,has_unit_metric=has_unit_metric,error=error) + CALL get_qs_env(qs_env,has_unit_metric=has_unit_metric) smearing_is_used = .FALSE. IF (dft_control%smear) THEN smearing_is_used = .TRUE. @@ -1170,15 +1126,15 @@ SUBROUTINE reorthogonalize_vectors(qs_env, v_matrix, n_col,error) IF (has_unit_metric) THEN - CALL make_basis_simple(v_matrix,my_n_col,error=error) + CALL make_basis_simple(v_matrix,my_n_col) ELSE IF (smearing_is_used) THEN CALL make_basis_lowdin(vmatrix=v_matrix,ncol=my_n_col,& - matrix_s=matrix_s(1)%matrix,error=error) + matrix_s=matrix_s(1)%matrix) ELSE IF (ortho_contains_cholesky) THEN CALL make_basis_cholesky(vmatrix=v_matrix,ncol=my_n_col,& - ortho=scf_env%ortho,error=error) + ortho=scf_env%ortho) ELSE - CALL make_basis_sm(v_matrix,my_n_col, matrix_s(1)%matrix ,error=error) + CALL make_basis_sm(v_matrix,my_n_col, matrix_s(1)%matrix) END IF CALL timestop(handle) END SUBROUTINE reorthogonalize_vectors diff --git a/src/qs_wf_history_types.F b/src/qs_wf_history_types.F index eaecb26cab..052b5422ea 100644 --- a/src/qs_wf_history_types.F +++ b/src/qs_wf_history_types.F @@ -118,16 +118,13 @@ MODULE qs_wf_history_types ! ***************************************************************************** !> \brief releases a snapshot of a wavefunction (see doc/ReferenceCounting.html) !> \param snapshot the snapshot to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> 02.2005 wf_mol added [MI] !> \author fawzi ! ***************************************************************************** -SUBROUTINE wfs_release(snapshot,error) +SUBROUTINE wfs_release(snapshot) TYPE(qs_wf_snapshot_type), POINTER :: snapshot - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfs_release', & routineP = moduleN//':'//routineN @@ -138,32 +135,32 @@ SUBROUTINE wfs_release(snapshot,error) failure=.FALSE. IF (ASSOCIATED(snapshot)) THEN - CPPreconditionNoFail(snapshot%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(snapshot%ref_count>0,cp_failure_level,routineP) snapshot%ref_count=snapshot%ref_count-1 IF (snapshot%ref_count==0) THEN IF (ASSOCIATED(snapshot%wf)) THEN DO i=1,SIZE(snapshot%wf) - CALL cp_fm_release(snapshot%wf(i)%matrix,error=error) + CALL cp_fm_release(snapshot%wf(i)%matrix) END DO DEALLOCATE(snapshot%wf,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF ! snapshot%rho_r & snapshot%rho_g is deallocated in wfs_update ! of qs_wf_history_methods, in case you wonder about it. IF (ASSOCIATED(snapshot%rho_ao)) THEN - CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao,error=error) + CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao) END IF IF (ASSOCIATED(snapshot%rho_ao_kp)) THEN - CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao_kp,error=error) + CALL cp_dbcsr_deallocate_matrix_set(snapshot%rho_ao_kp) END IF IF (ASSOCIATED(snapshot%overlap)) THEN - CALL cp_dbcsr_deallocate_matrix(snapshot%overlap,error=error) + CALL cp_dbcsr_deallocate_matrix(snapshot%overlap) END IF IF (ASSOCIATED(snapshot%rho_frozen)) THEN - CALL qs_rho_release(snapshot%rho_frozen,error=error) + CALL qs_rho_release(snapshot%rho_frozen) END IF DEALLOCATE(snapshot,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(snapshot) @@ -172,15 +169,12 @@ END SUBROUTINE wfs_release ! ***************************************************************************** !> \brief retains a wf history (see doc/ReferenceCounting.html) !> \param wf_history the wf_history to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE wfi_retain(wf_history,error) +SUBROUTINE wfi_retain(wf_history) TYPE(qs_wf_history_type), POINTER :: wf_history - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfi_retain', & routineP = moduleN//':'//routineN @@ -189,7 +183,7 @@ SUBROUTINE wfi_retain(wf_history,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,failure) wf_history%ref_count=wf_history%ref_count+1 END SUBROUTINE wfi_retain @@ -198,15 +192,12 @@ END SUBROUTINE wfi_retain !> \brief releases a wf_history of a wavefunction !> (see doc/ReferenceCounting.html) !> \param wf_history the wf_history to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE wfi_release(wf_history,error) +SUBROUTINE wfi_release(wf_history) TYPE(qs_wf_history_type), POINTER :: wf_history - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'wfi_release', & routineP = moduleN//':'//routineN @@ -217,19 +208,18 @@ SUBROUTINE wfi_release(wf_history,error) failure=.FALSE. IF (ASSOCIATED(wf_history)) THEN - CPPreconditionNoFail(wf_history%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(wf_history%ref_count>0,cp_failure_level,routineP) wf_history%ref_count=wf_history%ref_count-1 IF (wf_history%ref_count==0) THEN IF (ASSOCIATED(wf_history%past_states)) THEN DO i=1,SIZE(wf_history%past_states) - CALL wfs_release(wf_history%past_states(i)%snapshot,& - error=error) + CALL wfs_release(wf_history%past_states(i)%snapshot) END DO DEALLOCATE(wf_history%past_states,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(wf_history,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(wf_history) @@ -239,17 +229,14 @@ END SUBROUTINE wfi_release !> \brief returns a snapshot, the first being the latest snapshot !> \param wf_history the plage where to get the snapshot !> \param index the index of the snapshot you want -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 12.2002 created [fawzi] !> \author fawzi ! ***************************************************************************** -FUNCTION wfi_get_snapshot(wf_history, index, error) RESULT(res) +FUNCTION wfi_get_snapshot(wf_history, index) RESULT(res) TYPE(qs_wf_history_type), POINTER :: wf_history INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error TYPE(qs_wf_snapshot_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'wfi_get_snapshot', & @@ -260,10 +247,10 @@ FUNCTION wfi_get_snapshot(wf_history, index, error) RESULT(res) failure=.FALSE. NULLIFY(res) - CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(wf_history%past_states),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(wf_history),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(wf_history%past_states),cp_failure_level,routineP,failure) IF (index>wf_history%memory_depth.OR.index>wf_history%snapshot_count) THEN - CPPrecondition(.FALSE.,cp_warning_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_warning_level,routineP,failure) END IF res => wf_history%past_states(& MODULO(wf_history%snapshot_count+1-index,& diff --git a/src/rel_control_types.F b/src/rel_control_types.F index 2147ff4a44..c71f8163cb 100644 --- a/src/rel_control_types.F +++ b/src/rel_control_types.F @@ -67,17 +67,14 @@ MODULE rel_control_types ! ***************************************************************************** !> \brief allocates and initializes an rel control object with the default values !> \param rel_control the object to initialize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] for scf_control_type !> 10.2008 copied to rel_control_type [JT] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE rel_c_create(rel_control,error) + SUBROUTINE rel_c_create(rel_control) TYPE(rel_control_type), POINTER :: rel_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rel_c_create', & routineP = moduleN//':'//routineN @@ -88,7 +85,7 @@ SUBROUTINE rel_c_create(rel_control,error) failure = .FALSE. ALLOCATE (rel_control,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ! Load the default values @@ -107,17 +104,14 @@ END SUBROUTINE rel_c_create ! ***************************************************************************** !> \brief retains the given rel_control (see cp2k/doc/ReferenceCounting.html) !> \param rel_control the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] for scf_control_type !> 10.2008 copied to rel_control_type [JT] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE rel_c_retain(rel_control,error) + SUBROUTINE rel_c_retain(rel_control) TYPE(rel_control_type), POINTER :: rel_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rel_c_retain', & routineP = moduleN//':'//routineN @@ -126,9 +120,9 @@ SUBROUTINE rel_c_retain(rel_control,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rel_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rel_control),cp_failure_level,routineP,failure) - CPPrecondition(rel_control%ref_count > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(rel_control%ref_count > 0,cp_failure_level,routineP,failure) rel_control%ref_count = rel_control%ref_count + 1 END SUBROUTINE rel_c_retain @@ -136,8 +130,6 @@ END SUBROUTINE rel_c_retain ! ***************************************************************************** !> \brief releases the given rel_control (see cp2k/doc/ReferenceCounting.html) !> \param rel_control the object to free -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] for scf_control_type !> 10.2008 copied to rel_control_type [JT] @@ -145,10 +137,9 @@ END SUBROUTINE rel_c_retain !> \note !> at the moment does nothing ! ***************************************************************************** - SUBROUTINE rel_c_release(rel_control,error) + SUBROUTINE rel_c_release(rel_control) TYPE(rel_control_type), POINTER :: rel_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rel_c_release', & routineP = moduleN//':'//routineN @@ -159,11 +150,11 @@ SUBROUTINE rel_c_release(rel_control,error) failure = .FALSE. IF (ASSOCIATED(rel_control)) THEN - CPPrecondition(rel_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(rel_control%ref_count>0,cp_failure_level,routineP,failure) rel_control%ref_count = rel_control%ref_count - 1 IF (rel_control%ref_count < 1) THEN DEALLOCATE(rel_control,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF @@ -175,18 +166,16 @@ END SUBROUTINE rel_c_release !> \brief reads the parameters of the relativistic section into the given rel_control !> \param rel_control the object that wil contain the values read !> \param dft_section ... -!> \param error controls log and error handling !> \par History !> 05.2001 created [Matthias] for scf_control_type !> 09.2002 created separated scf_control type [fawzi] !> 10.2008 copied to rel_control_type [JT] !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE rel_c_read_parameters(rel_control,dft_section,error) + SUBROUTINE rel_c_read_parameters(rel_control,dft_section) TYPE(rel_control_type), POINTER :: rel_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rel_c_read_parameters', & routineP = moduleN//':'//routineN @@ -196,31 +185,24 @@ SUBROUTINE rel_c_read_parameters(rel_control,dft_section,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(rel_control),cp_failure_level,routineP,error,failure) - CPPrecondition((rel_control%ref_count > 0),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(dft_section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rel_control),cp_failure_level,routineP,failure) + CPPrecondition((rel_control%ref_count > 0),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(dft_section),cp_failure_level,routineP,failure) - rel_section => section_vals_get_subs_vals(dft_section,"RELATIVISTIC",& - error=error) + rel_section => section_vals_get_subs_vals(dft_section,"RELATIVISTIC") CALL section_vals_val_get(rel_section,"method",& - i_val=rel_control%rel_method,& - error=error) + i_val=rel_control%rel_method) CALL section_vals_val_get(rel_section,"DKH_order",& - i_val=rel_control%rel_DKH_order,& - error=error) + i_val=rel_control%rel_DKH_order) CALL section_vals_val_get(rel_section,"ZORA_TYPE",& - i_val=rel_control%rel_zora_type,& - error=error) + i_val=rel_control%rel_zora_type) CALL section_vals_val_get(rel_section,"transformation",& - i_val=rel_control%rel_transformation,& - error=error) + i_val=rel_control%rel_transformation) CALL section_vals_val_get(rel_section,"z_cutoff",& - i_val=rel_control%rel_z_cutoff,& - error=error) + i_val=rel_control%rel_z_cutoff) CALL section_vals_val_get(rel_section,"potential",& - i_val=rel_control%rel_potential,& - error=error) + i_val=rel_control%rel_potential) END SUBROUTINE rel_c_read_parameters diff --git a/src/replica_methods.F b/src/replica_methods.F index 8f452154a9..c8cfeafcc2 100644 --- a/src/replica_methods.F +++ b/src/replica_methods.F @@ -85,12 +85,10 @@ MODULE replica_methods !> basis (defaults to true for QS jobs) !> \param row_force to use the new mapping to the cart with rows !> working on force instead of columns. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, prep,& - sync_v,keep_wf_history,row_force,error) + sync_v,keep_wf_history,row_force) TYPE(replica_env_type), POINTER :: rep_env TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: input @@ -98,7 +96,6 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre INTEGER :: nrep, prep LOGICAL, INTENT(in), OPTIONAL :: sync_v, keep_wf_history, & row_force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_create', & routineP = moduleN//':'//routineN @@ -117,11 +114,11 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre para_env_inter_rep failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(rep_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(input_declaration),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(rep_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(input_declaration),cp_failure_level,routineP,failure) NULLIFY(cart,para_env_f,para_env_inter_rep) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() unit_nr=cp_logger_get_default_io_unit(logger) new_env_id=-1 forcedim = 1 @@ -137,20 +134,20 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre END IF CALL mp_cart_create ( comm_old=para_env%group, ndims=2, dims=dims, pos=pos, comm_cart=comm_cart) IF (comm_cart/=MPI_COMM_NULL) THEN - CALL cp_cart_create(cart,comm_cart,ndims=2,owns_group=.TRUE.,error=error) + CALL cp_cart_create(cart,comm_cart,ndims=2,owns_group=.TRUE.) NULLIFY(para_env_full) - CALL cp_para_env_create(para_env_full,comm_cart,owns_group=.FALSE.,error=error) + CALL cp_para_env_create(para_env_full,comm_cart,owns_group=.FALSE.) rdim(3-forcedim)=.FALSE. rdim(forcedim)=.TRUE. CALL mp_cart_sub( comm=comm_cart, rdim=rdim , sub_comm=comm_f) - CALL cp_para_env_create(para_env_f,comm_f,owns_group=.TRUE.,error=error) + CALL cp_para_env_create(para_env_f,comm_f,owns_group=.TRUE.) rdim(3-forcedim)=.TRUE. rdim(forcedim)=.FALSE. CALL mp_cart_sub( comm=comm_cart, rdim=rdim , sub_comm=comm_inter_rep) CALL cp_para_env_create(para_env_inter_rep,comm_inter_rep,& - owns_group=.TRUE.,error=error) + owns_group=.TRUE.) ALLOCATE(rep_env,stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) END IF ALLOCATE(gridinfo(2,0:para_env%num_pe-1)) gridinfo=0 @@ -194,7 +191,7 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre CALL section_vals_val_get(input,"GLOBAL%PROJECT_NAME",& - c_val=input_file_path,error=error) + c_val=input_file_path) rep_env%original_project_name = input_file_path ! By default replica_env handles files for each replica ! with the structure PROJECT_NAME-r-N where N is the @@ -205,11 +202,11 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre lp=LEN_TRIM(input_file_path) ! Setup new project name CALL section_vals_val_set(input,"GLOBAL%PROJECT_NAME",& - c_val=input_file_path,error=error) + c_val=input_file_path) ! Redirect the output of each replica on a same local file output_file_path=input_file_path(1:lp)//".out" CALL section_vals_val_set(input,"GLOBAL%OUTPUT_FILE_NAME",& - c_val=TRIM(output_file_path),error=error) + c_val=TRIM(output_file_path)) ! Dump an input file to warm-up new force_eval structures and ! delete them immediately afterwards.. @@ -218,12 +215,12 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre CALL open_file(file_name=TRIM(input_file_path),file_status="UNKNOWN",& file_form="FORMATTED",file_action="WRITE",& unit_number=unit_nr) - CALL section_vals_write(input,unit_nr,hide_root=.TRUE.,error=error) + CALL section_vals_write(input,unit_nr,hide_root=.TRUE.) CALL close_file(unit_nr) END IF CALL create_force_env(new_env_id,input_declaration,input_file_path,& output_file_path,para_env_f%group,ierr=ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) ! Delete input files.. IF (para_env_f%source==para_env_f%mepos) THEN @@ -234,11 +231,11 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre rep_env%f_env_id=new_env_id CALL get_nparticle(new_env_id,nparticle,ierr) - CPPostcondition(ierr==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_fatal_level,routineP,failure) rep_env%nparticle = nparticle rep_env%ndim = 3*nparticle ALLOCATE(rep_env%replica_owner(nrep),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) i0=nrep/para_env_inter_rep%num_pe ir=MODULO(nrep,para_env_inter_rep%num_pe) @@ -252,7 +249,7 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre IF (rep_env%my_rep_group cart rep_env%para_env => para_env_full @@ -271,24 +268,24 @@ SUBROUTINE rep_env_create(rep_env, para_env, input, input_declaration, nrep, pre ALLOCATE (rep_env%r(rep_env%ndim,nrep),rep_env%v(rep_env%ndim,nrep),& rep_env%f(rep_env%ndim+1,nrep), stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) rep_env%r=0._dp rep_env%f=0._dp rep_env%v=0._dp CALL set_vel(rep_env%f_env_id, rep_env%v(:,1), rep_env%ndim, ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) DO i=1,nrep IF (rep_env%rep_is_local(i)) THEN CALL get_pos(rep_env%f_env_id,rep_env%r(:,i),rep_env%ndim,ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF END DO END IF IF (.NOT.failure.AND.ASSOCIATED(rep_env)) THEN - CALL rep_envs_add_rep_env(rep_env,error=error) + CALL rep_envs_add_rep_env(rep_env) CALL rep_env_init_low(rep_env%id_nr,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE rep_env_create @@ -309,7 +306,6 @@ SUBROUTINE rep_env_init_low(rep_env_id, ierr) INTEGER :: i, in_use, stat LOGICAL :: do_kpoints, failure, & has_unit_metric - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys TYPE(dft_control_type), POINTER :: dft_control @@ -324,39 +320,35 @@ SUBROUTINE rep_env_init_low(rep_env_id, ierr) failure=failure) NULLIFY(qs_env,dft_control,subsys) CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=error, failure=failure) - logger => cp_error_get_logger(error) + failure=failure) + logger => cp_get_default_logger() logger%iter_info%iteration(1)=rep_env%my_rep_group CALL cp_add_iter_level(iteration_info=logger%iter_info,& - level_name="REPLICA_EVAL",error=error) + level_name="REPLICA_EVAL") !wf interp IF (rep_env%keep_wf_history) THEN - CALL force_env_get(f_env%force_env,in_use=in_use,error=error) + CALL force_env_get(f_env%force_env,in_use=in_use) IF (in_use==use_qs_force) THEN - CALL force_env_get(f_env%force_env,qs_env=qs_env,& - error=error) - CALL get_qs_env(qs_env,dft_control=dft_control,error=error) + CALL force_env_get(f_env%force_env,qs_env=qs_env) + CALL get_qs_env(qs_env,dft_control=dft_control) ALLOCATE(rep_env%wf_history(SIZE(rep_env%local_rep_indices)),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,SIZE(rep_env%wf_history) NULLIFY(rep_env%wf_history(i)%wf_history) IF (i==1) THEN CALL get_qs_env(qs_env,& - wf_history=rep_env%wf_history(i)%wf_history,& - error=error) - CALL wfi_retain(rep_env%wf_history(i)%wf_history,& - error=error) + wf_history=rep_env%wf_history(i)%wf_history) + CALL wfi_retain(rep_env%wf_history(i)%wf_history) ELSE CALL get_qs_env(qs_env,has_unit_metric=has_unit_metric,& - do_kpoints=do_kpoints,error=error) + do_kpoints=do_kpoints) CALL wfi_create(rep_env%wf_history(i)%wf_history,& interpolation_method_nr=& dft_control%qs_control%wf_interpolation_method_nr,& extrapolation_order = dft_control%qs_control%wf_extrapolation_order,& - has_unit_metric = has_unit_metric, & - error=error) + has_unit_metric = has_unit_metric) IF(do_kpoints) THEN - CALL wfi_create_for_kp(rep_env%wf_history(i)%wf_history,error=error) + CALL wfi_create_for_kp(rep_env%wf_history(i)%wf_history) END IF END IF END DO @@ -365,23 +357,23 @@ SUBROUTINE rep_env_init_low(rep_env_id, ierr) END IF END IF ALLOCATE(rep_env%results(rep_env%nrep),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1, rep_env%nrep NULLIFY(rep_env%results(i)%results) IF (i==1) THEN - CALL force_env_get(f_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, results=rep_env%results(i)%results, error=error) - CALL cp_result_retain(rep_env%results(i)%results,error) + CALL force_env_get(f_env%force_env, subsys=subsys) + CALL cp_subsys_get(subsys, results=rep_env%results(i)%results) + CALL cp_result_retain(rep_env%results(i)%results) ELSE - CALL cp_result_create(rep_env%results(i)%results,error) + CALL cp_result_create(rep_env%results(i)%results) END IF END DO - CALL rep_env_sync(rep_env,rep_env%r,error=error) - CALL rep_env_sync(rep_env,rep_env%v,error=error) - CALL rep_env_sync(rep_env,rep_env%f,error=error) + CALL rep_env_sync(rep_env,rep_env%r) + CALL rep_env_sync(rep_env,rep_env%v) + CALL rep_env_sync(rep_env,rep_env%f) - CALL f_env_rm_defaults(f_env,error,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL f_env_rm_defaults(f_env,ierr) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE rep_env_init_low @@ -391,16 +383,13 @@ END SUBROUTINE rep_env_init_low !> forces !> \param calc_f if true calculates also the forces, if false only the !> energy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> indirect through f77_int_low to work around fortran madness ! ***************************************************************************** - SUBROUTINE rep_env_calc_e_f(rep_env,calc_f,error) + SUBROUTINE rep_env_calc_e_f(rep_env,calc_f) TYPE(replica_env_type), POINTER :: rep_env LOGICAL, OPTIONAL :: calc_f - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_calc_e_f', & routineP = moduleN//':'//routineN @@ -411,14 +400,14 @@ SUBROUTINE rep_env_calc_e_f(rep_env,calc_f,error) failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,error,failure) - CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,failure) + CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,failure) my_calc_f=0 IF (PRESENT(calc_f)) THEN IF (calc_f) my_calc_f=1 END IF CALL rep_env_calc_e_f_low(rep_env%id_nr,my_calc_f,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE rep_env_calc_e_f @@ -443,7 +432,6 @@ RECURSIVE SUBROUTINE rep_env_calc_e_f_low(rep_env_id,calc_f,ierr) routineP = moduleN//':'//routineN LOGICAL :: failure - TYPE(cp_error_type) :: new_error TYPE(f_env_type), POINTER :: f_env TYPE(replica_env_type), POINTER :: rep_env @@ -451,9 +439,9 @@ RECURSIVE SUBROUTINE rep_env_calc_e_f_low(rep_env_id,calc_f,ierr) rep_env => rep_envs_get_rep_env(rep_env_id, ierr) IF (ASSOCIATED(rep_env)) THEN CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure) - CALL rep_env_calc_e_f_int(rep_env,calc_f/=0,new_error) - CALL f_env_rm_defaults(f_env,new_error,ierr) + failure=failure) + CALL rep_env_calc_e_f_int(rep_env,calc_f/=0) + CALL f_env_rm_defaults(f_env,ierr) ELSE ierr=111 END IF @@ -464,16 +452,13 @@ END SUBROUTINE rep_env_calc_e_f_low !> \brief calculates energy and force, internal private method !> \param rep_env the replica env to update !> \param calc_f if the force should be calculated as well (defaults to true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> this is the where the real work is done ! ***************************************************************************** - SUBROUTINE rep_env_calc_e_f_int(rep_env,calc_f,error) + SUBROUTINE rep_env_calc_e_f_int(rep_env,calc_f) TYPE(replica_env_type), POINTER :: rep_env LOGICAL, OPTIONAL :: calc_f - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_calc_e_f_int', & routineP = moduleN//':'//routineN @@ -481,7 +466,6 @@ SUBROUTINE rep_env_calc_e_f_int(rep_env,calc_f,error) INTEGER :: i, ierr, irep, md_iter, & my_calc_f, ndim LOGICAL :: failure - TYPE(cp_error_type) :: new_error TYPE(cp_logger_type), POINTER :: logger TYPE(cp_subsys_type), POINTER :: subsys TYPE(f_env_type), POINTER :: f_env @@ -489,26 +473,26 @@ SUBROUTINE rep_env_calc_e_f_int(rep_env,calc_f,error) failure=.FALSE. NULLIFY(f_env,qs_env,subsys) - CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,error,failure) - CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,failure) + CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,failure) my_calc_f=3*rep_env%nparticle IF (PRESENT(calc_f)) THEN IF (.NOT.calc_f) my_calc_f=0 END IF CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure) - logger => cp_error_get_logger(new_error) + failure=failure) + logger => cp_get_default_logger() ! md_iter=logger%iter_info%iteration(2)+1 md_iter=logger%iter_info%iteration(2) - CALL f_env_rm_defaults(f_env,new_error,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CALL f_env_rm_defaults(f_env,ierr) + CPAssert(ierr==0,cp_failure_level,routineP,failure) DO i=1,SIZE(rep_env%local_rep_indices) irep = rep_env%local_rep_indices(i) ndim = 3*rep_env%nparticle IF (rep_env%sync_v) THEN CALL set_vel(rep_env%f_env_id,rep_env%v(:,irep),ndim,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) IF (failure) EXIT END IF @@ -517,29 +501,28 @@ SUBROUTINE rep_env_calc_e_f_int(rep_env,calc_f,error) IF (rep_env%keep_wf_history) THEN CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure) - CALL force_env_get(f_env%force_env,qs_env=qs_env,error=error) + failure=failure) + CALL force_env_get(f_env%force_env,qs_env=qs_env) CALL set_qs_env(qs_env,& - wf_history=rep_env%wf_history(i)%wf_history,& - error=error) - CALL f_env_rm_defaults(f_env,new_error,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + wf_history=rep_env%wf_history(i)%wf_history) + CALL f_env_rm_defaults(f_env,ierr) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END IF CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=new_error, failure=failure) - CALL force_env_get(f_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_set(subsys, results=rep_env%results(irep)%results, error=error) - CALL f_env_rm_defaults(f_env,new_error,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + failure=failure) + CALL force_env_get(f_env%force_env, subsys=subsys) + CALL cp_subsys_set(subsys, results=rep_env%results(irep)%results) + CALL f_env_rm_defaults(f_env,ierr) + CPAssert(ierr==0,cp_failure_level,routineP,failure) CALL calc_force(rep_env%f_env_id,rep_env%r(:,irep),ndim,& rep_env%f(ndim+1,irep),rep_env%f(:ndim,irep),& my_calc_f,ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) IF (failure) EXIT END DO - CALL rep_env_sync(rep_env,rep_env%f,error=error) - CALL rep_env_sync_results(rep_env,rep_env%results,error) + CALL rep_env_sync(rep_env,rep_env%f) + CALL rep_env_sync_results(rep_env,rep_env%results) END SUBROUTINE rep_env_calc_e_f_int diff --git a/src/replica_types.F b/src/replica_types.F index 877b3a9479..0251309f37 100644 --- a/src/replica_types.F +++ b/src/replica_types.F @@ -129,16 +129,13 @@ MODULE replica_types ! ***************************************************************************** !> \brief releases the given replica environment !> \param rep_env the replica environment to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> here and not in replica_types to allow the use of replica_env_type !> in a force_env (call to destroy_force_env gives circular dep) ! ***************************************************************************** - SUBROUTINE rep_env_release(rep_env,error) + SUBROUTINE rep_env_release(rep_env) TYPE(replica_env_type), POINTER :: rep_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_release', & routineP = moduleN//':'//routineN @@ -149,57 +146,57 @@ SUBROUTINE rep_env_release(rep_env,error) failure=.FALSE. CALL timeset(routineN,handle) IF (ASSOCIATED(rep_env)) THEN - CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,failure) rep_env%ref_count=rep_env%ref_count-1 IF (rep_env%ref_count==0) THEN CALL rep_env_destroy_low(rep_env%id_nr,ierr) IF (rep_env%f_env_id>0) THEN CALL destroy_force_env(rep_env%f_env_id,ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(rep_env%r)) THEN DEALLOCATE(rep_env%r,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rep_env%v)) THEN DEALLOCATE(rep_env%v,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rep_env%f)) THEN DEALLOCATE(rep_env%f,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rep_env%wf_history)) THEN DO i=1,SIZE(rep_env%wf_history) - CALL wfi_release(rep_env%wf_history(i)%wf_history,error=error) + CALL wfi_release(rep_env%wf_history(i)%wf_history) END DO DEALLOCATE(rep_env%wf_history,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rep_env%results)) THEN DO i=1,SIZE(rep_env%results) - CALL cp_result_release(rep_env%results(i)%results,error=error) + CALL cp_result_release(rep_env%results(i)%results) END DO DEALLOCATE(rep_env%results,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(rep_env%local_rep_indices,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DEALLOCATE(rep_env%rep_is_local,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) IF (ASSOCIATED(rep_env%replica_owner)) THEN DEALLOCATE(rep_env%replica_owner,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF DEALLOCATE(rep_env%inter_rep_rank,rep_env%force_rank,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - CALL cp_cart_release(rep_env%cart,error=error) - CALL cp_para_env_release(rep_env%para_env,error=error) - CALL cp_para_env_release(rep_env%para_env_f,error=error) - CALL cp_para_env_release(rep_env%para_env_inter_rep,error=error) - CALL rep_envs_rm_rep_env(rep_env,error=error) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) + CALL cp_cart_release(rep_env%cart) + CALL cp_para_env_release(rep_env%para_env) + CALL cp_para_env_release(rep_env%para_env_f) + CALL cp_para_env_release(rep_env%para_env_inter_rep) + CALL rep_envs_rm_rep_env(rep_env) DEALLOCATE(rep_env,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(rep_env) @@ -221,7 +218,6 @@ SUBROUTINE rep_env_destroy_low(rep_env_id, ierr) INTEGER :: stat LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(cp_logger_type), POINTER :: logger TYPE(f_env_type), POINTER :: f_env TYPE(replica_env_type), POINTER :: rep_env @@ -232,24 +228,21 @@ SUBROUTINE rep_env_destroy_low(rep_env_id, ierr) routineP,"could not find rep_env with id_nr"//cp_to_string(rep_env_id),& failure=failure) CALL f_env_add_defaults(f_env_id=rep_env%f_env_id,f_env=f_env,& - new_error=error, failure=failure) - logger => cp_error_get_logger(error) + failure=failure) + logger => cp_get_default_logger() CALL cp_rm_iter_level(iteration_info=logger%iter_info,& - level_name="REPLICA_EVAL",error=error) - CALL f_env_rm_defaults(f_env,error,ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + level_name="REPLICA_EVAL") + CALL f_env_rm_defaults(f_env,ierr) + CPAssert(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE rep_env_destroy_low ! ***************************************************************************** !> \brief retains the given replica environment !> \param rep_env the replica environment to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE rep_env_retain(rep_env,error) + SUBROUTINE rep_env_retain(rep_env) TYPE(replica_env_type), POINTER :: rep_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_retain', & routineP = moduleN//':'//routineN @@ -259,8 +252,8 @@ SUBROUTINE rep_env_retain(rep_env,error) failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,error,failure) - CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,failure) + CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,failure) rep_env%ref_count=rep_env%ref_count+1 CALL timestop(handle) END SUBROUTINE rep_env_retain @@ -269,14 +262,11 @@ END SUBROUTINE rep_env_retain !> \brief writes out information about the rep_env !> \param rep_env the replica env to describe !> \param unit_nr the unit to write to -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE rep_env_write(rep_env, unit_nr, error) + SUBROUTINE rep_env_write(rep_env, unit_nr) TYPE(replica_env_type), POINTER :: rep_env INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_write', & routineP = moduleN//':'//routineN @@ -295,13 +285,13 @@ SUBROUTINE rep_env_write(rep_env, unit_nr, error) WRITE (unit_nr,"(' replica_owner=')", advance="no") WRITE (unit_nr,"(10i6)") rep_env%replica_owner WRITE (unit_nr,"(' cart=')", advance="no") - CALL cp_cart_write(rep_env%cart,unit_nr,error=error) + CALL cp_cart_write(rep_env%cart,unit_nr) WRITE (unit_nr,"(' para_env=')", advance="no") - CALL cp_para_env_write(rep_env%para_env,unit_nr,error=error) + CALL cp_para_env_write(rep_env%para_env,unit_nr) WRITE (unit_nr,"(' para_env_f=')", advance="no") - CALL cp_para_env_write(rep_env%para_env_f,unit_nr,error=error) + CALL cp_para_env_write(rep_env%para_env_f,unit_nr) WRITE (unit_nr,"(' para_env_inter_rep=')", advance="no") - CALL cp_para_env_write(rep_env%para_env_inter_rep,unit_nr,error=error) + CALL cp_para_env_write(rep_env%para_env_inter_rep,unit_nr) WRITE (unit_nr,"(' force_rank=(')", advance="no") WRITE (unit_nr,"(10i6)") rep_env%force_rank WRITE (unit_nr,"(')')") @@ -334,17 +324,14 @@ END SUBROUTINE rep_env_write !> on replica j/=i data from replica i overwrites val(:,i) !> \param rep_env replica environment !> \param vals the values to synchronize (second index runs over replicas) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> could be optimized: bcast in inter_rep, all2all or shift vs sum ! ***************************************************************************** - SUBROUTINE rep_env_sync(rep_env,vals,error) + SUBROUTINE rep_env_sync(rep_env,vals) TYPE(replica_env_type), POINTER :: rep_env REAL(kind=dp), DIMENSION(:, :), & INTENT(inout) :: vals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_sync', & routineP = moduleN//':'//routineN @@ -354,9 +341,9 @@ SUBROUTINE rep_env_sync(rep_env,vals,error) failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,error,failure) - CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(vals,2)==rep_env%nrep,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,failure) + CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(vals,2)==rep_env%nrep,cp_failure_level,routineP,failure) DO irep=1,rep_env%nrep IF (.NOT.rep_env%rep_is_local(irep)) THEN vals(:,irep)=0._dp @@ -371,15 +358,12 @@ END SUBROUTINE rep_env_sync !> in this case the result type is passed !> \param rep_env replica environment !> \param results is an array of result_types -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fschiff ! ***************************************************************************** - SUBROUTINE rep_env_sync_results(rep_env,results,error) + SUBROUTINE rep_env_sync_results(rep_env,results) TYPE(replica_env_type), POINTER :: rep_env TYPE(cp_result_p_type), DIMENSION(:), & POINTER :: results - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_sync_results', & routineP = moduleN//':'//routineN @@ -390,16 +374,16 @@ SUBROUTINE rep_env_sync_results(rep_env,results,error) failure=.FALSE. CALL timeset(routineN,handle) nrep=rep_env%nrep - CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,error,failure) - CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(results)==rep_env%nrep,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,failure) + CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(results)==rep_env%nrep,cp_failure_level,routineP,failure) DO irep=1, nrep ! source = 0 ! IF (rep_env%rep_is_local(irep)) source = rep_env%para_env_inter_rep%mepos ! CALL mp_sum(source, rep_env%para_env_inter_rep%group) ! above three lines should be the same as just: source = rep_env%inter_rep_rank(rep_env%replica_owner(irep)) - CALL cp_results_mp_bcast(results(irep)%results, source, rep_env%para_env_inter_rep, error) + CALL cp_results_mp_bcast(results(irep)%results, source, rep_env%para_env_inter_rep) END DO CALL timestop(handle) END SUBROUTINE rep_env_sync_results @@ -440,13 +424,10 @@ END FUNCTION rep_envs_get_rep_env ! ***************************************************************************** !> \brief adds the given rep_env to the list of controlled rep_envs. !> \param rep_env the rep_env to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE rep_envs_add_rep_env(rep_env,error) + SUBROUTINE rep_envs_add_rep_env(rep_env) TYPE(replica_env_type), POINTER :: rep_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_envs_add_rep_env', & routineP = moduleN//':'//routineN @@ -465,20 +446,20 @@ SUBROUTINE rep_envs_add_rep_env(rep_env,error) IF (module_initialized) THEN IF (.NOT.ASSOCIATED(rep_envs)) THEN ALLOCATE(rep_envs(1),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ELSE ALLOCATE(new_rep_envs(SIZE(rep_envs)+1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) DO i=1,SIZE(rep_envs) new_rep_envs(i)%rep_env => rep_envs(i)%rep_env END DO DEALLOCATE(rep_envs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) rep_envs => new_rep_envs END IF ELSE ALLOCATE(rep_envs(1),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF rep_envs(SIZE(rep_envs))%rep_env => rep_env module_initialized=.TRUE. @@ -489,13 +470,10 @@ END SUBROUTINE rep_envs_add_rep_env ! ***************************************************************************** !> \brief removes the given rep_env to the list of controlled rep_envs. !> \param rep_env the rep_env to remove -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE rep_envs_rm_rep_env(rep_env,error) + SUBROUTINE rep_envs_rm_rep_env(rep_env) TYPE(replica_env_type), POINTER :: rep_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rep_envs_rm_rep_env', & routineP = moduleN//':'//routineN @@ -508,9 +486,9 @@ SUBROUTINE rep_envs_rm_rep_env(rep_env,error) failure=.FALSE. IF (ASSOCIATED(rep_env)) THEN - CPPrecondition(module_initialized,cp_failure_level,routineP,error,failure) + CPPrecondition(module_initialized,cp_failure_level,routineP,failure) ALLOCATE(new_rep_envs(SIZE(rep_envs)-1),stat=stat) - CPPostcondition(stat==0,cp_fatal_level,routineP,error,failure) + CPPostcondition(stat==0,cp_fatal_level,routineP,failure) ii=0 DO i=1,SIZE(rep_envs) IF (rep_envs(i)%rep_env%id_nr/=rep_env%id_nr) THEN @@ -518,13 +496,13 @@ SUBROUTINE rep_envs_rm_rep_env(rep_env,error) new_rep_envs(ii)%rep_env => rep_envs(i)%rep_env END IF END DO - CPPostcondition(ii==SIZE(new_rep_envs),cp_failure_level,routineP,error,failure) + CPPostcondition(ii==SIZE(new_rep_envs),cp_failure_level,routineP,failure) DEALLOCATE(rep_envs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) rep_envs => new_rep_envs IF (SIZE(rep_envs)==0) THEN DEALLOCATE(rep_envs,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE rep_envs_rm_rep_env @@ -533,15 +511,12 @@ END SUBROUTINE rep_envs_rm_rep_env !> \brief returns the local index of the replica (-1 if it is not a local replica) !> \param rep_env the replica env !> \param global_index the global replica index -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author fawzi ! ***************************************************************************** - FUNCTION rep_env_local_index(rep_env,global_index,error) RESULT(res) + FUNCTION rep_env_local_index(rep_env,global_index) RESULT(res) TYPE(replica_env_type), POINTER :: rep_env INTEGER, INTENT(in) :: global_index - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'rep_env_local_index', & @@ -553,8 +528,8 @@ FUNCTION rep_env_local_index(rep_env,global_index,error) RESULT(res) failure=.FALSE. CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,error,failure) - CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rep_env),cp_failure_level,routineP,failure) + CPPrecondition(rep_env%ref_count>0,cp_failure_level,routineP,failure) res=-1 DO i=1,SIZE(rep_env%local_rep_indices) IF (rep_env%local_rep_indices(i)==global_index) THEN diff --git a/src/restraint.F b/src/restraint.F index 6830349956..05813919c8 100644 --- a/src/restraint.F +++ b/src/restraint.F @@ -62,13 +62,11 @@ MODULE restraint ! ***************************************************************************** !> \brief Computes restraints !> \param force_env ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE restraint_control( force_env, error ) + SUBROUTINE restraint_control( force_env) TYPE(force_env_type), POINTER :: force_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_control', & routineP = moduleN//':'//routineN @@ -104,7 +102,7 @@ SUBROUTINE restraint_control( force_env, error ) molecules, molecule_kind, molecule_kind_set, molecule, molecule_set, particles,& particle_set, gci, lfixd_list) CALL timeset(routineN,handle) - CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell,error=error) + CALL force_env_get(force_env=force_env, subsys=subsys, cell=cell) energy_4x6 = 0.0_dp energy_3x3 = 0.0_dp energy_colv = 0.0_dp @@ -112,7 +110,7 @@ SUBROUTINE restraint_control( force_env, error ) n_restraint=0 CALL cp_subsys_get(subsys=subsys,particles=particles, molecules_new=molecules,& local_particles=local_particles, local_molecules_new=local_molecules,& - gci=gci, molecule_kinds_new=molecule_kinds ,error=error) + gci=gci, molecule_kinds_new=molecule_kinds) nkind = molecule_kinds%n_els particle_set => particles%els @@ -121,12 +119,11 @@ SUBROUTINE restraint_control( force_env, error ) ! Intramolecular Restraints ALLOCATE(force(3,SIZE(particle_set)),stat=stat) - CPPrecondition(stat==0, cp_failure_level, routineP, error, failure) + CPPrecondition(stat==0, cp_failure_level, routineP,failure) force = 0.0_dp ! Create the list of locally fixed atoms - CALL create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, local_particles,& - error) + CALL create_local_fixd_list(lfixd_list, nkind, molecule_kind_set, local_particles) DO ifixd = 1, SIZE(lfixd_list) ikind = lfixd_list(ifixd)%ikind @@ -165,7 +162,7 @@ SUBROUTINE restraint_control( force_env, error ) force(:,iparticle) = force(:,iparticle) - 2.0_dp * k0 * rab END IF END DO - CALL release_local_fixd_list(lfixd_list, error) + CALL release_local_fixd_list(lfixd_list) ! Loop over other kind of Restraints MOL: DO ikind = 1, nkind @@ -183,18 +180,17 @@ SUBROUTINE restraint_control( force_env, error ) ! 3x3 IF ( n3x3con_restraint /= 0 ) THEN n_restraint=n_restraint+n3x3con_restraint - CALL restraint_3x3_int( molecule, particle_set, energy_3x3, force, error ) + CALL restraint_3x3_int( molecule, particle_set, energy_3x3, force) ENDIF ! 4x6 IF ( n4x6con_restraint /= 0 ) THEN n_restraint=n_restraint+n4x6con_restraint - CALL restraint_4x6_int( molecule, particle_set, energy_4x6, force, error ) + CALL restraint_4x6_int( molecule, particle_set, energy_4x6, force) ENDIF ! collective variables IF ( ncolv%nrestraint /= 0 ) THEN n_restraint=n_restraint+ncolv%nrestraint - CALL restraint_colv_int( molecule, particle_set, cell, energy_colv, force,& - error ) + CALL restraint_colv_int( molecule, particle_set, cell, energy_colv, force) ENDIF END DO END DO MOL @@ -204,8 +200,7 @@ SUBROUTINE restraint_control( force_env, error ) CALL mp_sum(energy_3x3,force_env%para_env%group) CALL mp_sum(energy_4x6,force_env%para_env%group) CALL mp_sum(energy_colv,force_env%para_env%group) - CALL update_particle_set(particle_set,force_env%para_env%group,for=force,add=.TRUE.,& - error=error) + CALL update_particle_set(particle_set,force_env%para_env%group,for=force,add=.TRUE.) force = 0.0_dp n_restraint = 0 ENDIF @@ -215,18 +210,17 @@ SUBROUTINE restraint_control( force_env, error ) ! 3x3 IF ( gci%ng3x3_restraint /= 0 ) THEN n_restraint=n_restraint+gci%ng3x3_restraint - CALL restraint_3x3_ext( gci, particle_set, energy_3x3, force, error ) + CALL restraint_3x3_ext( gci, particle_set, energy_3x3, force) ENDIF ! 4x6 IF ( gci%ng4x6_restraint /= 0 ) THEN n_restraint=n_restraint+gci%ng4x6_restraint - CALL restraint_4x6_ext( gci, particle_set, energy_4x6, force, error ) + CALL restraint_4x6_ext( gci, particle_set, energy_4x6, force) ENDIF ! collective variables IF ( gci%ncolv%nrestraint /= 0 ) THEN n_restraint=n_restraint+gci%ncolv%nrestraint - CALL restraint_colv_ext( gci, particle_set, cell, energy_colv, force,& - error ) + CALL restraint_colv_ext( gci, particle_set, cell, energy_colv, force) ENDIF DO iparticle = 1, SIZE(particle_set) particle_set(iparticle)%f = particle_set(iparticle)%f + force(:,iparticle) @@ -234,15 +228,15 @@ SUBROUTINE restraint_control( force_env, error ) END IF END IF DEALLOCATE(force,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Store restraint energies - CALL force_env_get(force_env=force_env, additional_potential=extended_energies, error=error) + CALL force_env_get(force_env=force_env, additional_potential=extended_energies) extended_energies=extended_energies+ energy_3x3 +& energy_fixd +& energy_4x6 +& energy_colv - CALL force_env_set(force_env=force_env, additional_potential=extended_energies, error=error) + CALL force_env_set(force_env=force_env, additional_potential=extended_energies) CALL timestop(handle) END SUBROUTINE restraint_control @@ -253,17 +247,15 @@ END SUBROUTINE restraint_control !> \param particle_set ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE restraint_3x3_int( molecule, particle_set, energy, force, error ) + SUBROUTINE restraint_3x3_int( molecule, particle_set, energy, force) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_3x3_int', & routineP = moduleN//':'//routineN @@ -279,7 +271,7 @@ SUBROUTINE restraint_3x3_int( molecule, particle_set, energy, force, error ) fixd_list = fixd_list) CALL get_molecule ( molecule, first_atom = first_atom ) CALL restraint_3x3_low( ng3x3, g3x3_list, fixd_list, first_atom, particle_set,& - energy, force, error ) + energy, force) END SUBROUTINE restraint_3x3_int @@ -289,17 +281,15 @@ END SUBROUTINE restraint_3x3_int !> \param particle_set ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE restraint_4x6_int( molecule, particle_set, energy, force, error ) + SUBROUTINE restraint_4x6_int( molecule, particle_set, energy, force) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_4x6_int', & routineP = moduleN//':'//routineN @@ -315,7 +305,7 @@ SUBROUTINE restraint_4x6_int( molecule, particle_set, energy, force, error ) fixd_list=fixd_list ) CALL get_molecule ( molecule, first_atom = first_atom ) CALL restraint_4x6_low( ng4x6, g4x6_list, fixd_list, first_atom, particle_set,& - energy, force, error ) + energy, force) END SUBROUTINE restraint_4x6_int @@ -326,10 +316,9 @@ END SUBROUTINE restraint_4x6_int !> \param cell ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE restraint_colv_int( molecule, particle_set, cell, energy, force, error ) + SUBROUTINE restraint_colv_int( molecule, particle_set, cell, energy, force) TYPE(molecule_type), POINTER :: molecule TYPE(particle_type), POINTER :: particle_set( : ) @@ -337,7 +326,6 @@ SUBROUTINE restraint_colv_int( molecule, particle_set, cell, energy, force, erro REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_colv_int', & routineP = moduleN//':'//routineN @@ -357,7 +345,7 @@ SUBROUTINE restraint_colv_int( molecule, particle_set, cell, energy, force, erro CALL get_molecule_kind ( molecule_kind, colv_list = colv_list, fixd_list=fixd_list ) CALL get_molecule ( molecule, lcolv=lcolv ) CALL restraint_colv_low( colv_list, fixd_list, lcolv, particle_set,& - cell, energy, force, error ) + cell, energy, force) END SUBROUTINE restraint_colv_int @@ -367,17 +355,15 @@ END SUBROUTINE restraint_colv_int !> \param particle_set ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE restraint_3x3_ext( gci, particle_set, energy, force, error ) + SUBROUTINE restraint_3x3_ext( gci, particle_set, energy, force) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_3x3_ext', & routineP = moduleN//':'//routineN @@ -392,7 +378,7 @@ SUBROUTINE restraint_3x3_ext( gci, particle_set, energy, force, error ) g3x3_list => gci%g3x3_list fixd_list => gci%fixd_list CALL restraint_3x3_low( ng3x3, g3x3_list, fixd_list, first_atom, particle_set,& - energy, force, error ) + energy, force) END SUBROUTINE restraint_3x3_ext @@ -402,17 +388,15 @@ END SUBROUTINE restraint_3x3_ext !> \param particle_set ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE restraint_4x6_ext( gci, particle_set, energy, force, error ) + SUBROUTINE restraint_4x6_ext( gci, particle_set, energy, force) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_4x6_ext', & routineP = moduleN//':'//routineN @@ -427,7 +411,7 @@ SUBROUTINE restraint_4x6_ext( gci, particle_set, energy, force, error ) g4x6_list => gci%g4x6_list fixd_list => gci%fixd_list CALL restraint_4x6_low( ng4x6, g4x6_list, fixd_list, first_atom, particle_set,& - energy, force, error ) + energy, force) END SUBROUTINE restraint_4x6_ext @@ -438,10 +422,9 @@ END SUBROUTINE restraint_4x6_ext !> \param cell ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** - SUBROUTINE restraint_colv_ext( gci, particle_set, cell, energy, force, error ) + SUBROUTINE restraint_colv_ext( gci, particle_set, cell, energy, force) TYPE(global_constraint_type), POINTER :: gci TYPE(particle_type), POINTER :: particle_set( : ) @@ -449,7 +432,6 @@ SUBROUTINE restraint_colv_ext( gci, particle_set, cell, energy, force, error ) REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_colv_ext', & routineP = moduleN//':'//routineN @@ -464,7 +446,7 @@ SUBROUTINE restraint_colv_ext( gci, particle_set, cell, energy, force, error ) fixd_list => gci%fixd_list lcolv => gci%lcolv CALL restraint_colv_low( colv_list, fixd_list, lcolv, particle_set,& - cell, energy, force, error ) + cell, energy, force) END SUBROUTINE restraint_colv_ext @@ -477,11 +459,10 @@ END SUBROUTINE restraint_colv_ext !> \param particle_set ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** SUBROUTINE restraint_3x3_low( ng3x3, g3x3_list, fixd_list, first_atom,& - particle_set, energy, force, error ) + particle_set, energy, force) INTEGER :: ng3x3 TYPE(g3x3_constraint_type), POINTER :: g3x3_list( : ) @@ -492,7 +473,6 @@ SUBROUTINE restraint_3x3_low( ng3x3, g3x3_list, fixd_list, first_atom,& REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_3x3_low', & routineP = moduleN//':'//routineN @@ -546,11 +526,10 @@ END SUBROUTINE restraint_3x3_low !> \param particle_set ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** SUBROUTINE restraint_4x6_low( ng4x6, g4x6_list, fixd_list, first_atom,& - particle_set, energy, force, error ) + particle_set, energy, force) INTEGER :: ng4x6 TYPE(g4x6_constraint_type), POINTER :: g4x6_list( : ) @@ -561,7 +540,6 @@ SUBROUTINE restraint_4x6_low( ng4x6, g4x6_list, fixd_list, first_atom,& REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_4x6_low', & routineP = moduleN//':'//routineN @@ -631,11 +609,10 @@ END SUBROUTINE restraint_4x6_low !> \param cell ... !> \param energy ... !> \param force ... -!> \param error ... !> \author Teodoro Laino 08.2006 [tlaino] ! ***************************************************************************** SUBROUTINE restraint_colv_low( colv_list, fixd_list, lcolv, & - particle_set, cell, energy, force, error ) + particle_set, cell, energy, force) TYPE(colvar_constraint_type), POINTER :: colv_list( : ) TYPE(fixd_constraint_type), & @@ -647,7 +624,6 @@ SUBROUTINE restraint_colv_low( colv_list, fixd_list, lcolv, & REAL(KIND=dp), INTENT(INOUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'restraint_colv_low', & routineP = moduleN//':'//routineN @@ -661,7 +637,7 @@ SUBROUTINE restraint_colv_low( colv_list, fixd_list, lcolv, & IF (.NOT.colv_list(iconst)%restraint%active) CYCLE ! Update colvar CALL colvar_eval_mol_f( lcolv ( iconst ) % colvar, cell, & - particles=particle_set, fixd_list=fixd_list, error=error) + particles=particle_set, fixd_list=fixd_list) k = colv_list ( iconst )%restraint%k0 targ = colv_list ( iconst )%expected_value diff --git a/src/rmsd.F b/src/rmsd.F index b17f7b95a7..39f58ae3b5 100644 --- a/src/rmsd.F +++ b/src/rmsd.F @@ -37,7 +37,6 @@ MODULE rmsd !> \param transl ... !> \param rot ... !> \param drmsd3 ... -!> \param error ... !> \author Teodoro Laino 08.2006 !> \note !> Optional arguments: @@ -49,7 +48,7 @@ MODULE rmsd !> drmsd3 -> derivatives of RMSD3 w.r.t. atomic positions ! ***************************************************************************** SUBROUTINE rmsd3( particle_set, r, r0, output_unit, weights, my_val,& - rotate, transl, rot, drmsd3, error) + rotate, transl, rot, drmsd3) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set REAL(KIND=dp), DIMENSION(:), & @@ -63,7 +62,6 @@ SUBROUTINE rmsd3( particle_set, r, r0, output_unit, weights, my_val,& INTENT(OUT), OPTIONAL :: transl REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL :: rot, drmsd3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rmsd3', & routineP = moduleN//':'//routineN @@ -77,12 +75,12 @@ SUBROUTINE rmsd3( particle_set, r, r0, output_unit, weights, my_val,& DIMENSION(:, :) :: r0p, rp failure = .FALSE. - CPPostcondition(SIZE(r)==SIZE(r0),cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==SIZE(r0),cp_failure_level,routineP,failure) natom = SIZE(particle_set) my_rotate = .FALSE. IF (PRESENT(rotate)) my_rotate=rotate ALLOCATE(w(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(weights)) THEN w(:) = weights ELSE @@ -95,9 +93,9 @@ SUBROUTINE rmsd3( particle_set, r, r0, output_unit, weights, my_val,& IF (mtot /= 0.0_dp) w(:) = w(:)/mtot END IF ALLOCATE(rp(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(r0p(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Molecule given by coordinates R ! Find COM and center molecule in COM xx=0.0_dp @@ -184,7 +182,7 @@ SUBROUTINE rmsd3( particle_set, r, r0, output_unit, weights, my_val,& M(4,3) = M(3,4) ! Solve the eigenvalue problem for M Z = M - CALL diamat_all(Z,lambda,error=error) + CALL diamat_all(Z,lambda) ! Pick the correct eigenvectors S = 1.0_dp IF (Z(1,1) .LT. 0.0_dp) S = -1.0_dp @@ -293,11 +291,11 @@ SUBROUTINE rmsd3( particle_set, r, r0, output_unit, weights, my_val,& END DO END IF DEALLOCATE(w,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(r0p,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE rmsd3 END MODULE rmsd diff --git a/src/rpa_communication.F b/src/rpa_communication.F index 04e8604aba..cc2da1c3e9 100644 --- a/src/rpa_communication.F +++ b/src/rpa_communication.F @@ -52,11 +52,10 @@ MODULE rpa_communication !> \param map_rec_size ... !> \param local_size_source ... !> \param para_env_RPA ... -!> \param error ... ! ***************************************************************************** SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buffer_send,& number_of_rec,number_of_send,& - map_send_size,map_rec_size,local_size_source,para_env_RPA,error) + map_send_size,map_rec_size,local_size_source,para_env_RPA) TYPE(cp_fm_type), POINTER :: fm_mat_source, fm_mat_dest INTEGER, ALLOCATABLE, DIMENSION(:) :: RPA_proc_map TYPE(integ_mat_buffer_type), & @@ -65,7 +64,6 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b INTEGER, ALLOCATABLE, DIMENSION(:) :: map_send_size, map_rec_size INTEGER, ALLOCATABLE, DIMENSION(:, :) :: local_size_source TYPE(cp_para_env_type), POINTER :: para_env_RPA - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'initialize_buffer', & routineP = moduleN//':'//routineN @@ -89,7 +87,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b ! create the RPA proc_map IF(.NOT.(ALLOCATED(RPA_proc_map))) THEN ALLOCATE(RPA_proc_map(-para_env_RPA%num_pe:2*para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RPA_proc_map=0 DO i=0,para_env_RPA%num_pe-1 RPA_proc_map(i)=i @@ -105,8 +103,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b row_indices=row_indices_s,& col_indices=col_indices_s,& nrow_block=nrow_block_s,& - ncol_block=ncol_block_s,& - error=error) + ncol_block=ncol_block_s) myprow_s=fm_mat_source%matrix_struct%context%mepos(1) mypcol_s=fm_mat_source%matrix_struct%context%mepos(2) nprow_s =fm_mat_source%matrix_struct%context%num_pe(1) @@ -119,8 +116,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b row_indices=row_indices_d,& col_indices=col_indices_d,& nrow_block=nrow_block_d,& - ncol_block=ncol_block_d,& - error=error) + ncol_block=ncol_block_d) myprow_d=fm_mat_dest%matrix_struct%context%mepos(1) mypcol_d=fm_mat_dest%matrix_struct%context%mepos(2) nprow_d =fm_mat_dest%matrix_struct%context%num_pe(1) @@ -128,7 +124,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b ! 0) create the map for the local sizes ALLOCATE(local_size_source(2,0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) local_size_source=0 local_size_source(1,para_env_RPA%mepos)=nrow_local_s local_size_source(2,para_env_RPA%mepos)=ncol_local_s @@ -136,7 +132,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b ! 1) loop over my local data and define a map for the proc to send data ALLOCATE(map_send_size(0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_send_size=0 DO jjB=1, ncol_local_s j_global=col_indices_s(jjB) @@ -153,7 +149,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b ! 2) loop over my local data of fm_mat_S and define a map for the proc from which rec data ALLOCATE(map_rec_size(0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_rec_size=0 DO jjB=1, ncol_local_d j_global=col_indices_d(jjB) @@ -178,12 +174,12 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b END DO ALLOCATE(buffer_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! 3.5) prepare the index map CALL timeset(routineN//"_bS",handle2) ALLOCATE(proc2counter(0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) proc2counter=0 ! allocate buffer for sending send_counter=0 @@ -195,7 +191,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b send_counter=send_counter+1 ! prepare the sending buffer ALLOCATE(buffer_send(send_counter)%indx(2,size_send_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_send(send_counter)%indx=0 proc2counter(proc_send)=send_counter @@ -203,7 +199,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b END DO ALLOCATE(index_counter(0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) index_counter=0 DO iiB=1, nrow_local_s i_global=row_indices_s(iiB) @@ -237,7 +233,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b END DO ALLOCATE(buffer_rec(number_of_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! 4.5) prepare the index map CALL timeset(routineN//"_bR",handle2) @@ -251,7 +247,7 @@ SUBROUTINE initialize_buffer(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,b rec_counter=rec_counter+1 ! allocate the auxilliary index structure ALLOCATE(buffer_rec(rec_counter)%indx(2,size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_rec(rec_counter)%indx=0 proc2counter(proc_receive)=rec_counter @@ -328,11 +324,10 @@ END SUBROUTINE initialize_buffer !> \param map_rec_size ... !> \param local_size_source ... !> \param para_env_RPA ... -!> \param error ... ! ***************************************************************************** SUBROUTINE fm_redistribute(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buffer_send,& number_of_send,& - map_send_size,map_rec_size,local_size_source,para_env_RPA,error) + map_send_size,map_rec_size,local_size_source,para_env_RPA) TYPE(cp_fm_type), POINTER :: fm_mat_source, fm_mat_dest INTEGER, ALLOCATABLE, DIMENSION(:) :: RPA_proc_map TYPE(integ_mat_buffer_type), & @@ -341,7 +336,6 @@ SUBROUTINE fm_redistribute(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buf INTEGER, ALLOCATABLE, DIMENSION(:) :: map_send_size, map_rec_size INTEGER, ALLOCATABLE, DIMENSION(:, :) :: local_size_source TYPE(cp_para_env_type), POINTER :: para_env_RPA - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_redistribute', & routineP = moduleN//':'//routineN @@ -368,8 +362,7 @@ SUBROUTINE fm_redistribute(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buf row_indices=row_indices_s,& col_indices=col_indices_s,& nrow_block=nrow_block_s,& - ncol_block=ncol_block_s,& - error=error) + ncol_block=ncol_block_s) myprow_s=fm_mat_source%matrix_struct%context%mepos(1) mypcol_s=fm_mat_source%matrix_struct%context%mepos(2) nprow_s =fm_mat_source%matrix_struct%context%num_pe(1) @@ -382,8 +375,7 @@ SUBROUTINE fm_redistribute(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buf row_indices=row_indices_d,& col_indices=col_indices_d,& nrow_block=nrow_block_d,& - ncol_block=ncol_block_d,& - error=error) + ncol_block=ncol_block_d) myprow_d=fm_mat_dest%matrix_struct%context%mepos(1) mypcol_d=fm_mat_dest%matrix_struct%context%mepos(2) nprow_d =fm_mat_dest%matrix_struct%context%num_pe(1) @@ -425,7 +417,7 @@ SUBROUTINE fm_redistribute(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buf rec_counter=rec_counter+1 ! prepare the buffer for receive ALLOCATE(buffer_rec(rec_counter)%msg(size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_rec(rec_counter)%msg=0.0_dp buffer_rec(rec_counter)%proc=proc_receive @@ -440,7 +432,7 @@ SUBROUTINE fm_redistribute(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buf CALL timeset(routineN//"_bS",handle2) ! allocate buffer for sending, fill the buffer, send the message ALLOCATE(req_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_counter=0 DO proc_shift=1, para_env_RPA%num_pe-1 proc_send=RPA_proc_map(para_env_RPA%mepos+proc_shift) @@ -450,7 +442,7 @@ SUBROUTINE fm_redistribute(fm_mat_source,fm_mat_dest,RPA_proc_map,buffer_rec,buf send_counter=send_counter+1 ! allocate ALLOCATE(buffer_send(send_counter)%msg(size_send_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_send(send_counter)%msg=0.0_dp buffer_send(send_counter)%proc=proc_send @@ -531,18 +523,16 @@ END SUBROUTINE fm_redistribute !> \param map_send_size ... !> \param map_rec_size ... !> \param local_size_source ... -!> \param error ... ! ***************************************************************************** SUBROUTINE release_buffer(RPA_proc_map,buffer_rec,buffer_send,& number_of_rec,number_of_send,& - map_send_size,map_rec_size,local_size_source,error) + map_send_size,map_rec_size,local_size_source) INTEGER, ALLOCATABLE, DIMENSION(:) :: RPA_proc_map TYPE(integ_mat_buffer_type), & ALLOCATABLE, DIMENSION(:) :: buffer_rec, buffer_send INTEGER :: number_of_rec, number_of_send INTEGER, ALLOCATABLE, DIMENSION(:) :: map_send_size, map_rec_size INTEGER, ALLOCATABLE, DIMENSION(:, :) :: local_size_source - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'release_buffer', & routineP = moduleN//':'//routineN diff --git a/src/rpa_ri_gpw.F b/src/rpa_ri_gpw.F index fc4d7e1971..a1c72e1059 100644 --- a/src/rpa_ri_gpw.F +++ b/src/rpa_ri_gpw.F @@ -96,7 +96,6 @@ MODULE rpa_ri_gpw !> \param gw_corr_lev_occ ... !> \param gw_corr_lev_virt ... !> \param unit_nr ... -!> \param error ... !> \param do_ri_sos_laplace_mp2 ... !> \param my_do_gw ... !> \param BIb_C_beta ... @@ -113,7 +112,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c ends_array,ends_B_virtual,ends_B_all,sizes_array,sizes_B_virtual,sizes_B_all,& starts_array,starts_B_virtual,starts_B_all,& Eigenval,nmo,homo,dimen_RI,gw_corr_lev_occ,gw_corr_lev_virt,& - unit_nr,error,do_ri_sos_laplace_mp2,my_do_gw,& + unit_nr,do_ri_sos_laplace_mp2,my_do_gw,& BIb_C_beta,homo_beta,Eigenval_beta,& ends_B_virtual_beta,sizes_B_virtual_beta, starts_B_virtual_beta,& BIb_C_gw_beta,gw_corr_lev_occ_beta,gw_corr_lev_virt_beta) @@ -130,7 +129,6 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c INTEGER :: nmo, homo, dimen_RI, & gw_corr_lev_occ, & gw_corr_lev_virt, unit_nr - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: do_ri_sos_laplace_mp2, & my_do_gw REAL(KIND=dp), ALLOCATABLE, & @@ -224,7 +222,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c IF(ierr==0) EXIT END DO END IF - CPPostcondition(num_integ_points>=1,cp_failure_level,routineP,error,failure) + CPPostcondition(num_integ_points>=1,cp_failure_level,routineP,failure) ELSE num_integ_points=mp2_env%ri_rpa%rpa_num_quad_points input_integ_group_size=mp2_env%ri_rpa%rpa_integ_group_size @@ -412,7 +410,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c sizes_ia,starts_ia,ends_ia,& sizes_B_virtual,starts_B_virtual,ends_B_virtual,& sub_proc_map,my_ia_size,my_ia_start,my_ia_end,my_group_L_size,& - my_B_size,my_B_virtual_start,error) + my_B_size,my_B_virtual_start) DEALLOCATE(BIb_C) DEALLOCATE(starts_B_virtual) DEALLOCATE(ends_B_virtual) @@ -425,7 +423,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c sizes_ia_beta,starts_ia_beta,ends_ia_beta,& sizes_B_virtual_beta,starts_B_virtual_beta,ends_B_virtual_beta,& sub_proc_map,my_ia_size_beta,my_ia_start_beta,my_ia_end_beta,my_group_L_size,& - my_B_size_beta,my_B_virtual_start_beta,error) + my_B_size_beta,my_B_virtual_start_beta) DEALLOCATE(BIb_C_beta) DEALLOCATE(starts_B_virtual_beta) @@ -441,7 +439,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c sizes_nm_gw,starts_nm_gw,ends_nm_gw,& sizes_B_all,starts_B_all,ends_B_all,& sub_proc_map,my_nm_gw_size,my_nm_gw_start,my_nm_gw_end,my_group_L_size,& - my_B_all_size,my_B_all_start,error) + my_B_all_size,my_B_all_start) ! The same for open shell IF(my_open_shell) THEN @@ -451,7 +449,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c sizes_nm_gw,starts_nm_gw,ends_nm_gw,& sizes_B_all,starts_B_all,ends_B_all,& sub_proc_map,my_nm_gw_size,my_nm_gw_start,my_nm_gw_end,my_group_L_size,& - my_B_all_size,my_B_all_start,error) + my_B_all_size,my_B_all_start) DEALLOCATE(BIb_C_gw_beta) END IF @@ -472,7 +470,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c mp2_env%block_size_row,mp2_env%block_size_col,unit_nr,& my_ia_size,my_ia_start,my_ia_end,& my_group_L_size,my_group_L_start,my_group_L_end,& - para_env_RPA,fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,error) + para_env_RPA,fm_mat_S,fm_mat_Q_gemm,fm_mat_Q) ! for GW, we need other matrix fm_mat_S IF(my_do_gw) THEN @@ -481,18 +479,18 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c ! mp2_env%block_size_row,mp2_env%block_size_col,unit_nr,& ! my_nm_gw_size,my_nm_gw_start,my_nm_gw_end,& ! my_group_L_size,my_group_L_start,my_group_L_end,& -! para_env_RPA,fm_mat_S_gw,fm_mat_R_gw_gemm,fm_mat_R_gw,error,& +! para_env_RPA,fm_mat_S_gw,fm_mat_R_gw_gemm,fm_mat_R_gw,& ! .TRUE.,fm_mat_Q%matrix_struct%context,fm_mat_S%matrix_struct%context) CALL create_integ_mat(BIb_C_2D_gw,para_env,para_env_sub,color_sub,ngroup,integ_group_size,& dimen_RI,dimen_nm_gw,dimen_ia,color_rpa_group,& mp2_env%block_size_row,mp2_env%block_size_col,unit_nr,& my_nm_gw_size,my_nm_gw_start,my_nm_gw_end,& my_group_L_size,my_group_L_start,my_group_L_end,& - para_env_RPA,fm_mat_S_gw,fm_mat_R_gw_gemm,fm_mat_R_gw,error,& + para_env_RPA,fm_mat_S_gw,fm_mat_R_gw_gemm,fm_mat_R_gw,& .TRUE.,fm_mat_Q%matrix_struct%context,fm_mat_Q%matrix_struct%context) ! for GW, we don't need fm_mat_R_gw_gemm (in contrast to RPA) - CALL cp_fm_release(fm_mat_R_gw_gemm,error=error) + CALL cp_fm_release(fm_mat_R_gw_gemm) IF(my_open_shell) THEN CALL create_integ_mat(BIb_C_2D_gw_beta,para_env,para_env_sub,color_sub,ngroup,integ_group_size,& @@ -500,7 +498,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c mp2_env%block_size_row,mp2_env%block_size_col,unit_nr,& my_nm_gw_size,my_nm_gw_start,my_nm_gw_end,& my_group_L_size,my_group_L_start,my_group_L_end,& - para_env_RPA,fm_mat_S_gw_beta,fm_mat_R_gw_gemm_beta,fm_mat_R_gw_beta,error,& + para_env_RPA,fm_mat_S_gw_beta,fm_mat_R_gw_gemm_beta,fm_mat_R_gw_beta,& .TRUE.,fm_mat_Q%matrix_struct%context,fm_mat_Q%matrix_struct%context,.TRUE.) END IF @@ -514,14 +512,14 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c mp2_env%block_size_row,mp2_env%block_size_col,unit_nr,& my_ia_size_beta,my_ia_start_beta,my_ia_end_beta,& my_group_L_size,my_group_L_start,my_group_L_end,& - para_env_RPA,fm_mat_S_beta,fm_mat_Q_gemm_beta,fm_mat_Q_beta,error,& + para_env_RPA,fm_mat_S_beta,fm_mat_Q_gemm_beta,fm_mat_Q_beta,& .TRUE.,fm_mat_Q%matrix_struct%context) IF(do_ri_sos_laplace_mp2) THEN ! go with laplace MINIMAX MP2 CALL laplace_minimax_approx(Erpa,para_env,para_env_RPA,unit_nr,homo,virtual,dimen_RI,dimen_ia,Eigenval,& num_integ_points,num_integ_group,color_rpa_group,& - fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,error,& + fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,& homo_beta,virtual_beta,dimen_ia_beta,Eigenval_beta,fm_mat_S_beta,& fm_mat_Q_gemm_beta,fm_mat_Q_beta) ELSE @@ -533,7 +531,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c my_do_gw,gw_corr_lev_occ,gw_corr_lev_virt,num_poles,ext_scaling,omega_max_fit,& stop_crit,check_fit,fermi_level_offset,crossing_search,& max_iter_fit,& - mp2_env%ri_rpa%mm_style,do_minimax_quad,error,& + mp2_env%ri_rpa%mm_style,do_minimax_quad,& homo_beta,virtual_beta,dimen_ia_beta,Eigenval_beta,fm_mat_S_beta,& fm_mat_Q_gemm_beta,fm_mat_Q_beta,fm_mat_S_gw_beta,& gw_corr_lev_occ_beta,gw_corr_lev_virt_beta) @@ -543,7 +541,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c ! go with laplace MINIMAX MP2 CALL laplace_minimax_approx(Erpa,para_env,para_env_RPA,unit_nr,homo,virtual,dimen_RI,dimen_ia,Eigenval,& num_integ_points,num_integ_group,color_rpa_group,& - fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,error) + fm_mat_S,fm_mat_Q_gemm,fm_mat_Q) ELSE ! go with clenshaw-curtius/minimax quadrature ! here, we also do the quasi-particle-energy correction for G0W0 @@ -554,7 +552,7 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c my_do_gw,gw_corr_lev_occ,gw_corr_lev_virt,num_poles,ext_scaling,omega_max_fit,& stop_crit,check_fit,fermi_level_offset,crossing_search,& max_iter_fit,& - mp2_env%ri_rpa%mm_style,do_minimax_quad,error) + mp2_env%ri_rpa%mm_style,do_minimax_quad) END IF END IF @@ -568,30 +566,30 @@ SUBROUTINE rpa_ri_compute_en(Erpa,mp2_env,BIb_C,BIb_C_gw,para_env,para_env_sub,c DEALLOCATE(starts_array) DEALLOCATE(ends_array) - CALL cp_para_env_release(para_env_RPA,error=error) + CALL cp_para_env_release(para_env_RPA) - CALL cp_fm_release(fm_mat_S,error=error) - !XXX CALL cp_fm_release(fm_mat_G,error=error) - CALL cp_fm_release(fm_mat_Q_gemm,error=error) - CALL cp_fm_release(fm_mat_Q,error=error) + CALL cp_fm_release(fm_mat_S) + !XXX CALL cp_fm_release(fm_mat_G) + CALL cp_fm_release(fm_mat_Q_gemm) + CALL cp_fm_release(fm_mat_Q) IF(my_open_shell) THEN DEALLOCATE(sizes_ia_beta) DEALLOCATE(starts_ia_beta) DEALLOCATE(ends_ia_beta) - CALL cp_fm_release(fm_mat_S_beta,error=error) - !XXX CALL cp_fm_release(fm_mat_G_beta,error=error) - CALL cp_fm_release(fm_mat_Q_gemm_beta,error=error) - CALL cp_fm_release(fm_mat_Q_beta,error=error) + CALL cp_fm_release(fm_mat_S_beta) + !XXX CALL cp_fm_release(fm_mat_G_beta) + CALL cp_fm_release(fm_mat_Q_gemm_beta) + CALL cp_fm_release(fm_mat_Q_beta) END IF IF(my_do_gw) THEN DEALLOCATE(sizes_nm_gw) DEALLOCATE(starts_nm_gw) DEALLOCATE(ends_nm_gw) - CALL cp_fm_release(fm_mat_S_gw,error=error) - CALL cp_fm_release(fm_mat_R_gw,error=error) + CALL cp_fm_release(fm_mat_S_gw) + CALL cp_fm_release(fm_mat_R_gw) IF(my_open_shell) THEN - CALL cp_fm_release(fm_mat_S_gw_beta,error=error) + CALL cp_fm_release(fm_mat_S_gw_beta) END IF END IF @@ -624,14 +622,13 @@ END SUBROUTINE rpa_ri_compute_en !> \param my_group_L_size ... !> \param my_B_size ... !> \param my_B_virtual_start ... -!> \param error ... !> \author Jan Wilhelm, 03/2015 ! ***************************************************************************** SUBROUTINE calculate_BIb_C_2D(BIb_C_2D,BIb_C,para_env_sub,dimen_ia,homo,virtual,& sizes_ia,starts_ia,ends_ia,& sizes_B_virtual,starts_B_virtual,ends_B_virtual,& sub_proc_map,my_ia_size,my_ia_start,my_ia_end,my_group_L_size,& - my_B_size,my_B_virtual_start,error) + my_B_size,my_B_virtual_start) REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: BIb_C_2D @@ -644,7 +641,6 @@ SUBROUTINE calculate_BIb_C_2D(BIb_C_2D,BIb_C,para_env_sub,dimen_ia,homo,virtual, INTEGER :: my_ia_size, my_ia_start, & my_ia_end, my_group_L_size, & my_B_size, my_B_virtual_start - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_BIb_C_2D', & routineP = moduleN//':'//routineN @@ -659,13 +655,13 @@ SUBROUTINE calculate_BIb_C_2D(BIb_C_2D,BIb_C,para_env_sub,dimen_ia,homo,virtual, dimen_ia=homo*virtual ALLOCATE(sizes_ia(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sizes_ia=0 ALLOCATE(starts_ia(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) starts_ia=0 ALLOCATE(ends_ia(0:para_env_sub%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ends_ia=0 DO iproc=0, para_env_sub%num_pe-1 @@ -681,7 +677,7 @@ SUBROUTINE calculate_BIb_C_2D(BIb_C_2D,BIb_C,para_env_sub,dimen_ia,homo,virtual, ! reorder data ALLOCATE(BIb_C_2D(my_ia_size,my_group_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(jjB,ia_global) & !$OMP SHARED(homo,my_B_size,virtual,my_B_virtual_start,my_ia_start,my_ia_end,BIb_C,BIb_C_2D,& @@ -707,7 +703,7 @@ SUBROUTINE calculate_BIb_C_2D(BIb_C_2D,BIb_C,para_env_sub,dimen_ia,homo,virtual, ! TODO: fix this more cleanly with a rewrite sending only needed data etc. ! TODO: occ_chunk should presumably be precomputed so that messages are limited to e.g. 100MiB. ALLOCATE(BIb_C_rec(my_group_L_size,rec_B_size,MIN(homo,occ_chunk)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO occ_low=1,homo,occ_chunk occ_high=MIN(homo,occ_low+occ_chunk-1) @@ -757,7 +753,6 @@ END SUBROUTINE calculate_BIb_C_2D !> \param fm_mat_S ... !> \param fm_mat_Q_gemm ... !> \param fm_mat_Q ... -!> \param error ... !> \param beta_case ... !> \param blacs_env_ext ... !> \param blacs_env_ext_S ... @@ -768,7 +763,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ext_row_block_size,ext_col_block_size,unit_nr,& my_ia_size,my_ia_start,my_ia_end,& my_group_L_size,my_group_L_start,my_group_L_end,& - para_env_RPA,fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,error,beta_case,& + para_env_RPA,fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,beta_case,& blacs_env_ext,blacs_env_ext_S,do_gw_open_shell) REAL(KIND=dp), ALLOCATABLE, & @@ -781,7 +776,6 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte TYPE(cp_para_env_type), POINTER :: para_env_RPA TYPE(cp_fm_type), POINTER :: fm_mat_S, fm_mat_Q_gemm, & fm_mat_Q - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, OPTIONAL :: beta_case TYPE(cp_blacs_env_type), OPTIONAL, & POINTER :: blacs_env_ext, blacs_env_ext_S @@ -843,7 +837,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte IF(.NOT.my_beta_case) THEN CALL mp_comm_split_direct(para_env%group,comm_rpa,color_rpa_group) NULLIFY(para_env_RPA) - CALL cp_para_env_create(para_env_RPA,comm_rpa,error=error) + CALL cp_para_env_create(para_env_RPA,comm_rpa) END IF ! create the RPA blacs env @@ -852,7 +846,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte blacs_env=>blacs_env_ext_S NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=dimen_ia,& - ncol_global=dimen_RI,para_env=para_env_RPA,error=error) + ncol_global=dimen_RI,para_env=para_env_RPA) ELSE NULLIFY(blacs_env) IF(para_env_RPA%num_pe>1) THEN @@ -877,14 +871,14 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ELSE grid_2D=1 END IF - CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_RPA, grid_2d=grid_2d, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_RPA, grid_2d=grid_2d) IF (unit_nr>0) THEN WRITE (UNIT=unit_nr,FMT="(T3,A,T75,i6)")& "MATRIX_INFO| Number row processes:", grid_2D(1) WRITE (UNIT=unit_nr,FMT="(T3,A,T75,i6)")& "MATRIX_INFO| Number column processes:", grid_2D(2) END IF - ! CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_RPA, error=error) + ! CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_RPA) ! define the block_size for the row IF(ext_row_block_size>0) THEN @@ -913,16 +907,16 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! and homo*virtual rows NULLIFY(fm_struct) ! CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=dimen_ia,& - ! ncol_global=dimen_RI,para_env=para_env_RPA,error=error) + ! ncol_global=dimen_RI,para_env=para_env_RPA) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=dimen_ia,& ncol_global=dimen_RI,para_env=para_env_RPA,& - nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.,error=error) + nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.) END IF NULLIFY(fm_mat_S) - CALL cp_fm_create(fm_mat_S,fm_struct,name="fm_mat_S",error=error) + CALL cp_fm_create(fm_mat_S,fm_struct,name="fm_mat_S") - CALL cp_fm_set_all(matrix=fm_mat_S,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_mat_S,alpha=0.0_dp) ! fill the matrix CALL cp_fm_get_info(matrix=fm_mat_S,& @@ -931,8 +925,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte row_indices=row_indices,& col_indices=col_indices,& nrow_block=nrow_block,& - ncol_block=ncol_block,& - error=error) + ncol_block=ncol_block) myprow=fm_mat_S%matrix_struct%context%mepos(1) mypcol=fm_mat_S%matrix_struct%context%mepos(2) nprow =fm_mat_S%matrix_struct%context%num_pe(1) @@ -940,7 +933,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! create the RPA proc_map ALLOCATE(RPA_proc_map(-para_env_RPA%num_pe:2*para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RPA_proc_map=0 DO i=0,para_env_RPA%num_pe-1 RPA_proc_map(i)=i @@ -950,13 +943,13 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! create the info array, first index: 1-> L info, 2-> ia info ALLOCATE(RPA_info_start(2,0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RPA_info_start=0 ALLOCATE(RPA_info_end(2,0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RPA_info_end=0 ALLOCATE(RPA_info_size(2,0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) RPA_info_size=0 RPA_info_start(1,para_env_RPA%mepos)=my_group_L_start @@ -978,10 +971,10 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! 0) create array with processes positions CALL timeset(routineN//"_info",handle3) ALLOCATE(grid_2_mepos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_2_mepos=0 ALLOCATE(mepos_2_grid(0:para_env_RPA%num_pe-1,2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mepos_2_grid=0 grid_2_mepos(myprow,mypcol)=para_env_RPA%mepos @@ -993,7 +986,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! 1) loop over my local data and define a map for the proc to send data ALLOCATE(map_send_size(0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_send_size=0 DO jjB=my_group_L_start, my_group_L_end send_pcol=cp_fm_indxg2p(jjB,ncol_block,dummy_proc,& @@ -1008,11 +1001,11 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! 2) loop over my local data of fm_mat_S and define a map for the proc from which rec data ALLOCATE(map_rec_size(0:para_env_RPA%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_rec_size=0 mepos_in_RPA_group=MOD(color_sub,integ_group_size) ALLOCATE(group_grid_2_mepos(0:para_env_sub%num_pe-1,0:integ_group_size-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) group_grid_2_mepos=0 group_grid_2_mepos(para_env_sub%mepos,mepos_in_RPA_group)=para_env_RPA%mepos CALL mp_sum(group_grid_2_mepos,para_env_RPA%group) @@ -1084,12 +1077,12 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte END DO ALLOCATE(buffer_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! this array given a pair (ref_send_prow,ref_send_pcol) returns ! the position in the buffer_send associated to that process ALLOCATE(grid_ref_2_send_pos(0:nprow-1,0:npcol-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) grid_ref_2_send_pos=0 send_counter=0 @@ -1101,7 +1094,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte send_counter=send_counter+1 ! prepare the sending buffer ALLOCATE(buffer_send(send_counter)%msg(size_send_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_send(send_counter)%msg=0.0_dp buffer_send(send_counter)%proc=proc_send @@ -1131,7 +1124,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! loop over the locally held data and fill the buffer_send ! for doing that we need an array index ALLOCATE(iii_vet(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iii_vet=0 DO iiB=my_ia_start, my_ia_end @@ -1166,7 +1159,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte END DO ALLOCATE(buffer_rec(number_of_rec),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rec_counter=0 DO proc_shift=1, para_env_RPA%num_pe-1 @@ -1177,7 +1170,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte rec_counter=rec_counter+1 ! prepare the buffer for receive ALLOCATE(buffer_rec(rec_counter)%msg(size_rec_buffer),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) buffer_rec(rec_counter)%msg=0.0_dp buffer_rec(rec_counter)%proc=proc_receive @@ -1188,7 +1181,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte ! 6) send data ALLOCATE(req_send(number_of_send),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) send_counter=0 DO proc_shift=1, para_env_RPA%num_pe-1 proc_send=RPA_proc_map(para_env_RPA%mepos+proc_shift) @@ -1211,7 +1204,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte my_num_row_blocks=my_num_row_blocks+1 END DO ALLOCATE(blocks_ranges_row(2,my_num_row_blocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blocks_ranges_row=0 blocks_ranges_row(1,1)=row_indices(1) iii=1 @@ -1230,7 +1223,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte my_num_col_blocks=my_num_col_blocks+1 END DO ALLOCATE(blocks_ranges_col(2,my_num_col_blocks),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blocks_ranges_col=0 blocks_ranges_col(1,1)=col_indices(1) iii=1 @@ -1263,7 +1256,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte END DO END DO ALLOCATE(index_col_rec(num_rec_cols),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) index_col_rec=0 iii=0 DO jjB=1, my_num_col_blocks @@ -1387,7 +1380,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte rec_ia_end=RPA_info_end(2,proc_receive) ALLOCATE(BIb_C_rec(rec_ia_size,rec_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_rec=0.0_dp CALL mp_sendrecv(BIb_C_2D,proc_send_static,& @@ -1408,7 +1401,7 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte DEALLOCATE(BIb_C_2D) ALLOCATE(BIb_C_2D(rec_ia_size,rec_L_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) BIb_C_2D(:,:)=BIb_C_rec DEALLOCATE(BIb_C_rec) @@ -1427,56 +1420,56 @@ SUBROUTINE create_integ_mat(BIb_C_2D,para_env,para_env_sub,color_sub,ngroup,inte sub_sub_color=para_env_RPA%mepos CALL mp_comm_split_direct(para_env%group,comm_exchange,sub_sub_color) NULLIFY(para_env_exchange) - CALL cp_para_env_create(para_env_exchange,comm_exchange,error=error) + CALL cp_para_env_create(para_env_exchange,comm_exchange) CALL timeset(routineN//"_sum",handle2) CALL mp_sum(fm_mat_S%local_data,para_env_exchange%group) CALL timestop(handle2) - CALL cp_para_env_release(para_env_exchange,error=error) + CALL cp_para_env_release(para_env_exchange) ! create the twin matrix for the mat-mat-mul (mat_Q) - !XXX CALL cp_fm_create(fm_mat_G,fm_struct,name="fm_mat_G",error=error) - !XXX CALL cp_fm_set_all(matrix=fm_mat_G,alpha=0.0_dp,error=error) + !XXX CALL cp_fm_create(fm_mat_G,fm_struct,name="fm_mat_G") + !XXX CALL cp_fm_set_all(matrix=fm_mat_G,alpha=0.0_dp) - CALL cp_fm_struct_release(fm_struct,error=error) + CALL cp_fm_struct_release(fm_struct) IF(.NOT. my_gw_open_shell) THEN ! create the Q matrix dimen_RIxdimen_RI where the result of the mat-mat-mult will be stored NULLIFY(fm_mat_Q_gemm) NULLIFY(fm_struct) !CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=dimen_RI,& - ! ncol_global=dimen_RI,para_env=para_env_RPA,error=error) + ! ncol_global=dimen_RI,para_env=para_env_RPA) CALL cp_fm_struct_create(fm_struct,context=blacs_env,nrow_global=dimen_RI,& ncol_global=dimen_RI,para_env=para_env_RPA,& - nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.,error=error) - CALL cp_fm_create(fm_mat_Q_gemm,fm_struct,name="fm_mat_Q_gemm",error=error) - CALL cp_fm_struct_release(fm_struct,error=error) + nrow_block=nrow_block_mat, ncol_block=ncol_block_mat, force_block=.TRUE.) + CALL cp_fm_create(fm_mat_Q_gemm,fm_struct,name="fm_mat_Q_gemm") + CALL cp_fm_struct_release(fm_struct) - CALL cp_fm_set_all(matrix=fm_mat_Q_gemm,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_mat_Q_gemm,alpha=0.0_dp) ! create the Q matrix with a different blacs env NULLIFY(blacs_env_Q) IF(my_blacs_ext) THEN blacs_env_Q=>blacs_env_ext ELSE - CALL cp_blacs_env_create(blacs_env=blacs_env_Q, para_env=para_env_RPA, error=error) + CALL cp_blacs_env_create(blacs_env=blacs_env_Q, para_env=para_env_RPA) END IF NULLIFY(fm_mat_Q) NULLIFY(fm_struct) CALL cp_fm_struct_create(fm_struct,context=blacs_env_Q,nrow_global=dimen_RI,& - ncol_global=dimen_RI,para_env=para_env_RPA,error=error) - CALL cp_fm_create(fm_mat_Q,fm_struct,name="fm_mat_Q",error=error) + ncol_global=dimen_RI,para_env=para_env_RPA) + CALL cp_fm_create(fm_mat_Q,fm_struct,name="fm_mat_Q") - CALL cp_fm_struct_release(fm_struct,error=error) + CALL cp_fm_struct_release(fm_struct) - CALL cp_fm_set_all(matrix=fm_mat_Q,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_mat_Q,alpha=0.0_dp) END IF ! release blacs_env - IF(.NOT.my_blacs_ext) CALL cp_blacs_env_release(blacs_env_Q,error=error) - IF(.NOT.my_blacs_S_ext) CALL cp_blacs_env_release(blacs_env,error=error) + IF(.NOT.my_blacs_ext) CALL cp_blacs_env_release(blacs_env_Q) + IF(.NOT.my_blacs_S_ext) CALL cp_blacs_env_release(blacs_env) CALL timestop(handle) @@ -1516,7 +1509,6 @@ END SUBROUTINE create_integ_mat !> \param max_iter_fit ... !> \param mm_style ... !> \param do_minimax_quad ... -!> \param error ... !> \param homo_beta ... !> \param virtual_beta ... !> \param dimen_ia_beta ... @@ -1534,7 +1526,7 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& fm_mat_S,fm_mat_Q_gemm,fm_mat_Q,fm_mat_S_gw,fm_mat_R_gw,& my_do_gw,gw_corr_lev_occ,gw_corr_lev_virt,num_poles,ext_scaling,omega_max_fit,& stop_crit,check_fit,fermi_level_offset,crossing_search,& - max_iter_fit,mm_style,do_minimax_quad,error,& + max_iter_fit,mm_style,do_minimax_quad,& homo_beta,virtual_beta,dimen_ia_beta,Eigenval_beta,fm_mat_S_beta,& fm_mat_Q_gemm_beta,fm_mat_Q_beta,fm_mat_S_gw_beta,& gw_corr_lev_occ_beta,gw_corr_lev_virt_beta) @@ -1561,7 +1553,6 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& INTEGER :: crossing_search, & max_iter_fit, mm_style LOGICAL :: do_minimax_quad - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, OPTIONAL :: homo_beta, virtual_beta, & dimen_ia_beta REAL(KIND=dp), DIMENSION(:), OPTIONAL :: Eigenval_beta @@ -1625,20 +1616,20 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& PRESENT(fm_mat_Q_beta)) my_open_shell=.TRUE. ALLOCATE(tj(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tj=0.0_dp ALLOCATE(wj(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wj=0.0_dp ALLOCATE(Q_log(dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(trace_Qomega(dimen_RI),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(do_minimax_quad) THEN ! MINIMAX quadrature ALLOCATE(x_tw(2*num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) x_tw=0.0_dp Emin=Eigenval(homo+1)-Eigenval(homo) @@ -1654,7 +1645,7 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& E_Range=Emax/Emin ierr=0 - CALL get_rpa_minimax_coeff(num_integ_points,E_Range,x_tw,ierr,error) + CALL get_rpa_minimax_coeff(num_integ_points,E_Range,x_tw,ierr) DO jquad=1, num_integ_points tj(jquad)=x_tw(jquad) @@ -1690,12 +1681,12 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& IF(my_open_shell) THEN CALL calc_scaling_factor(a_scaling,para_env,para_env_RPA,homo,virtual,Eigenval,& num_integ_points,num_integ_group,color_rpa_group,& - tj,wj,fm_mat_S,error,& + tj,wj,fm_mat_S,& homo_beta,virtual_beta,dimen_ia_beta,Eigenval_beta,fm_mat_S_beta) ELSE CALL calc_scaling_factor(a_scaling,para_env,para_env_RPA,homo,virtual,Eigenval,& num_integ_points,num_integ_group,color_rpa_group,& - tj,wj,fm_mat_S,error) + tj,wj,fm_mat_S) END IF ! for G0W0, we may set the scaling factor by hand @@ -1712,11 +1703,11 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! initialize buffer for matrix redistribution CALL initialize_buffer(fm_mat_Q_gemm,fm_mat_Q,RPA_proc_map,buffer_rec,buffer_send,& number_of_rec,number_of_send,& - map_send_size,map_rec_size,local_size_source,para_env_RPA,error) + map_send_size,map_rec_size,local_size_source,para_env_RPA) IF(my_open_shell) THEN CALL initialize_buffer(fm_mat_Q_gemm_beta,fm_mat_Q_beta,RPA_proc_map,buffer_rec_beta,buffer_send_beta,& number_of_rec_beta,number_of_send_beta,& - map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA,error) + map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA) END IF IF(my_open_shell) THEN @@ -1730,11 +1721,11 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& gw_corr_lev_tot=gw_corr_lev_occ+gw_corr_lev_virt ALLOCATE(Eigenval_scf(nmo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Eigenval_scf(:) = Eigenval(:) ALLOCATE(Eigenval_last(nmo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Eigenval_last(:) = Eigenval(:) ! in the case of HF_diag approach of X. Blase (PRB 83, 115103 (2011), Sec. IV), we subtract the @@ -1750,11 +1741,11 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! Eigenval for beta IF(my_open_shell) THEN ALLOCATE(Eigenval_scf_beta(nmo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Eigenval_scf_beta(:) = Eigenval_beta(:) ALLOCATE(Eigenval_last_beta(nmo),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Eigenval_last_beta(:) = Eigenval_beta(:) ! in the case of HF_diag approach of X. Blase (PRB 83, 115103 (2011), Sec. IV), we subtract the @@ -1770,22 +1761,22 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! create temporary matrix to store B*([1+Q(iw')]^-1-1), has the same size as B NULLIFY(fm_mat_S_gw_work) - CALL cp_fm_create(fm_mat_S_gw_work,fm_mat_S_gw%matrix_struct,error=error) - CALL cp_fm_set_all(matrix=fm_mat_S_gw_work,alpha=0.0_dp,error=error) + CALL cp_fm_create(fm_mat_S_gw_work,fm_mat_S_gw%matrix_struct) + CALL cp_fm_set_all(matrix=fm_mat_S_gw_work,alpha=0.0_dp) IF(my_open_shell) THEN NULLIFY(fm_mat_S_gw_work_beta) - CALL cp_fm_create(fm_mat_S_gw_work_beta,fm_mat_S_gw%matrix_struct,error=error) - CALL cp_fm_set_all(matrix=fm_mat_S_gw_work_beta,alpha=0.0_dp,error=error) + CALL cp_fm_create(fm_mat_S_gw_work_beta,fm_mat_S_gw%matrix_struct) + CALL cp_fm_set_all(matrix=fm_mat_S_gw_work_beta,alpha=0.0_dp) END IF ALLOCATE(vec_W_gw(dimen_nm_gw),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_W_gw=0.0_dp IF(my_open_shell) THEN ALLOCATE(vec_W_gw_beta(dimen_nm_gw),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_W_gw_beta=0.0_dp END IF @@ -1794,7 +1785,7 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! fill the omega_frequency vector ALLOCATE(vec_omega_gw(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_omega_gw=0.0_dp DO jquad=1,num_integ_points @@ -1817,18 +1808,18 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! create new arrays containing omega values at which we calculate vec_Sigma_c_gw ALLOCATE(vec_omega_fit_gw(num_fit_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vec_omega_fit_gw_sign(num_fit_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vec_Sigma_c_gw(gw_corr_lev_tot,num_fit_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_Sigma_c_gw=(0.0_dp,0.0_dp) IF(my_open_shell) THEN ALLOCATE(vec_Sigma_c_gw_beta(gw_corr_lev_tot,num_fit_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_Sigma_c_gw_beta=(0.0_dp,0.0_dp) END IF @@ -1846,45 +1837,45 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! arrays storing the complex fit parameters a_0, a_1, b_1, a_2, b_2, ... num_var=2*num_poles+1 ALLOCATE(Lambda(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda=(0.0_dp,0.0_dp) ALLOCATE(Lambda_without_offset(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda_without_offset=(0.0_dp,0.0_dp) ALLOCATE(Lambda_Re(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda_Re=0.0_dp ALLOCATE(Lambda_Im(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda_Im=0.0_dp ! arrays storing the correlation self-energy, stat. error and z-shot value ALLOCATE(vec_gw_energ(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_gw_energ=0.0_dp ALLOCATE(vec_gw_energ_error_fit(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_gw_energ_error_fit=0.0_dp ALLOCATE(z_value(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) z_value=0.0_dp ALLOCATE(m_value(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) m_value=0.0_dp ! the same for beta IF(my_open_shell) THEN ALLOCATE(vec_gw_energ_beta(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_gw_energ_beta=0.0_dp ALLOCATE(vec_gw_energ_error_fit_beta(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vec_gw_energ_error_fit_beta=0.0_dp ALLOCATE(z_value_beta(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) z_value_beta=0.0_dp ALLOCATE(m_value_beta(gw_corr_lev_tot),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) m_value_beta=0.0_dp END IF @@ -1934,15 +1925,15 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& END IF !XXX ! copy fm_mat_S into fm_mat_G - !XXX CALL cp_fm_to_fm(source=fm_mat_S,destination=fm_mat_G,error=error) + !XXX CALL cp_fm_to_fm(source=fm_mat_S,destination=fm_mat_G) !XXX ! get info of fm_mat_G !XXX CALL cp_fm_get_info(matrix=fm_mat_G,& !XXX nrow_local=nrow_local,& !XXX ncol_local=ncol_local,& !XXX row_indices=row_indices,& - !XXX col_indices=col_indices,& - !XXX error=error) + !XXX col_indices=col_indices) + !XXX @@ -1951,8 +1942,7 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ! remove eigenvalue part of S matrix from the last eigenvalue self-c. cycle @@ -2028,13 +2018,13 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! waste-fully computes the full symmetrix matrix, but maybe faster than cp_fm_syrk for optimized cp_fm_gemm CALL cp_gemm(transa="T",transb="N",m=dimen_RI,n=dimen_RI,k=dimen_ia,alpha=alpha,& matrix_a=fm_mat_S,matrix_b=fm_mat_S,beta=0.0_dp,& - matrix_c=fm_mat_Q_gemm,error=error) + matrix_c=fm_mat_Q_gemm) CASE(wfc_mm_style_syrk) ! will only compute the upper half of the matrix, which is fine, since we only use it for cholesky later CALL cp_fm_syrk(uplo='U',trans='T',k=dimen_ia,alpha=alpha,matrix_a=fm_mat_S,& - ia=1,ja=1,beta=0.0_dp,matrix_c=fm_mat_Q_gemm,error=error) + ia=1,ja=1,beta=0.0_dp,matrix_c=fm_mat_Q_gemm) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT t_end=m_walltime() @@ -2044,30 +2034,29 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& my_num_dgemm_call=my_num_dgemm_call+1 ! copy/redistribute fm_mat_Q_gemm to fm_mat_Q - CALL cp_fm_set_all(matrix=fm_mat_Q,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_mat_Q,alpha=0.0_dp) CALL fm_redistribute(fm_mat_Q_gemm,fm_mat_Q,RPA_proc_map,buffer_rec,buffer_send,& number_of_send,& - map_send_size,map_rec_size,local_size_source,para_env_RPA,error) + map_send_size,map_rec_size,local_size_source,para_env_RPA) IF(my_open_shell) THEN ! the same for the beta spin !XXX ! copy fm_mat_S into fm_mat_G - !XXX CALL cp_fm_to_fm(source=fm_mat_S_beta,destination=fm_mat_G_beta,error=error) + !XXX CALL cp_fm_to_fm(source=fm_mat_S_beta,destination=fm_mat_G_beta) !XXX ! get info of fm_mat_G_beta !XXX CALL cp_fm_get_info(matrix=fm_mat_G_beta,& !XXX nrow_local=nrow_local,& !XXX ncol_local=ncol_local,& !XXX row_indices=row_indices,& - !XXX col_indices=col_indices,& - !XXX error=error) + !XXX col_indices=col_indices) + !XXX ! get info of fm_mat_S_beta CALL cp_fm_get_info(matrix=fm_mat_S_beta,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ! update G matrix with the new value of omega IF(first_cycle) THEN @@ -2113,12 +2102,12 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& CASE(wfc_mm_style_gemm) CALL cp_gemm(transa="T",transb="N",m=dimen_RI,n=dimen_RI,k=dimen_ia_beta,alpha=alpha,& matrix_a=fm_mat_S_beta,matrix_b=fm_mat_S_beta,beta=0.0_dp,& - matrix_c=fm_mat_Q_gemm_beta,error=error) + matrix_c=fm_mat_Q_gemm_beta) CASE(wfc_mm_style_syrk) CALL cp_fm_syrk(uplo='U',trans='T',k=dimen_ia_beta,alpha=alpha,matrix_a=fm_mat_S_beta,& - ia=1,ja=1,beta=0.0_dp,matrix_c=fm_mat_Q_gemm_beta,error=error) + ia=1,ja=1,beta=0.0_dp,matrix_c=fm_mat_Q_gemm_beta) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT t_end=m_walltime() actual_flop_rate=2.0_dp*REAL(dimen_ia_beta,KIND=dp)*dimen_RI*REAL(dimen_RI,KIND=dp)/(MAX(0.01_dp,t_end-t_start)) @@ -2126,12 +2115,12 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& my_num_dgemm_call=my_num_dgemm_call+1 ! copy/redistribute fm_mat_Q_gemm to fm_mat_Q - CALL cp_fm_set_all(matrix=fm_mat_Q_beta,alpha=0.0_dp,error=error) + CALL cp_fm_set_all(matrix=fm_mat_Q_beta,alpha=0.0_dp) CALL fm_redistribute(fm_mat_Q_gemm_beta,fm_mat_Q_beta,RPA_proc_map,buffer_rec_beta,buffer_send_beta,& number_of_send_beta,& - map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA,error) + map_send_size_beta,map_rec_size_beta,local_size_source_beta,para_env_RPA) - CALL cp_fm_scale_and_add(alpha=1.0_dp,matrix_a=fm_mat_Q,beta=1.0_dp,matrix_b=fm_mat_Q_beta,error=error) + CALL cp_fm_scale_and_add(alpha=1.0_dp,matrix_a=fm_mat_Q,beta=1.0_dp,matrix_b=fm_mat_Q_beta) ! fm_mat_Q%local_data=fm_mat_Q%local_data+fm_mat_Q_beta%local_data END IF @@ -2141,8 +2130,7 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ! calcualte the trace of Q and add 1 on the diagonal trace_Qomega=0.0_dp @@ -2161,16 +2149,15 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& CALL mp_sum(trace_Qomega,para_env_RPA%group) ! calculate Trace(Log(Matrix)) as Log(DET(Matrix)) via cholesky decomposition - CALL cp_fm_cholesky_decompose(matrix=fm_mat_Q, n=dimen_RI, info_out=info_chol, error=error) - CPPostcondition(info_chol==0,cp_failure_level,routineP,error,failure) + CALL cp_fm_cholesky_decompose(matrix=fm_mat_Q, n=dimen_RI, info_out=info_chol) + CPPostcondition(info_chol==0,cp_failure_level,routineP,failure) ! get info of cholesky_decomposed(fm_mat_Q) CALL cp_fm_get_info(matrix=fm_mat_Q,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) Q_log=0.0_dp !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(jjB,iiB,i_global,j_global) & @@ -2206,9 +2193,9 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& CALL timeset(routineN//"_G0W0_matrix_operations",handle2) ! calculate [1+Q(iw')]^-1 - CALL cp_fm_cholesky_invert(fm_mat_Q,error=error) + CALL cp_fm_cholesky_invert(fm_mat_Q) ! symmetrize the result, fm_mat_R_gw is only temporary work matrix - CALL cp_fm_upper_to_full(fm_mat_Q,fm_mat_R_gw,error=error) + CALL cp_fm_upper_to_full(fm_mat_Q,fm_mat_R_gw) ! subtract 1 from the diagonal to get rid of exchange self-energy !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(jjB,iiB,i_global,j_global) & @@ -2224,23 +2211,23 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& END DO ! copy/redistribute fm_mat_Q to fm_mat_Q_gemm - ! CALL cp_fm_set_all(matrix=fm_mat_Q_gemm,alpha=0.0_dp,error=error) + ! CALL cp_fm_set_all(matrix=fm_mat_Q_gemm,alpha=0.0_dp) ! CALL fm_redistribute(fm_mat_Q,fm_mat_Q_gemm,RPA_proc_map,buffer_rec_gw,buffer_send_gw,& ! number_of_send_gw,& - ! map_send_size_gw,map_rec_size_gw,local_size_source_gw,para_env_RPA,error) + ! map_send_size_gw,map_rec_size_gw,local_size_source_gw,para_env_RPA) ! S_work_(nm)Q = B_(nm)P * ([1+Q]^-1-1)_PQ CALL timeset(routineN//"_mult_B_f(Pi)_gw",handle3) ! CALL cp_gemm(transa="N",transb="N",m=dimen_nm_gw,n=dimen_RI,k=dimen_RI,alpha=1.0_dp,& ! matrix_a=fm_mat_S_gw,matrix_b=fm_mat_Q_gemm,beta=0.0_dp,& - ! matrix_c=fm_mat_S_gw_work,error=error) + ! matrix_c=fm_mat_S_gw_work) CALL cp_gemm(transa="N",transb="N",m=dimen_nm_gw,n=dimen_RI,k=dimen_RI,alpha=1.0_dp,& matrix_a=fm_mat_S_gw,matrix_b=fm_mat_Q,beta=0.0_dp,& - matrix_c=fm_mat_S_gw_work,error=error) + matrix_c=fm_mat_S_gw_work) IF(my_open_shell) THEN CALL cp_gemm(transa="N",transb="N",m=dimen_nm_gw,n=dimen_RI,k=dimen_RI,alpha=1.0_dp,& matrix_a=fm_mat_S_gw_beta,matrix_b=fm_mat_Q,beta=0.0_dp,& - matrix_c=fm_mat_S_gw_work_beta,error=error) + matrix_c=fm_mat_S_gw_work_beta) END IF CALL timestop(handle3) @@ -2251,8 +2238,7 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) vec_W_gw = 0.0_dp IF(my_open_shell) THEN @@ -2376,14 +2362,14 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& CALL fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fit_gw,& z_value,m_value,vec_Sigma_c_gw,Eigenval,n_level_gw,gw_corr_lev_occ,num_poles,& num_fit_points,max_iter_fit,crossing_search,homo,unit_nr,check_fit,stop_crit,& - fermi_level_offset,error) + fermi_level_offset) IF(my_open_shell) THEN CALL fit_and_continuation(vec_gw_energ_beta,vec_gw_energ_error_fit_beta,vec_omega_fit_gw,& z_value_beta,m_value_beta,vec_Sigma_c_gw_beta,Eigenval_beta,n_level_gw,& gw_corr_lev_occ_beta,num_poles,& num_fit_points,max_iter_fit,crossing_search,homo_beta,unit_nr,check_fit,stop_crit,& - fermi_level_offset,error) + fermi_level_offset) END IF @@ -2410,21 +2396,20 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& z_value,m_value,mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:,1),Eigenval,& Eigenval_last,Eigenval_scf,gw_corr_lev_occ,gw_corr_lev_virt,gw_corr_lev_tot,& count_ev_sc_GW,crossing_search,homo,nmo,unit_nr,mp2_env%ri_g0w0%print_gw_details,& - error,do_alpha=.TRUE.) + do_alpha=.TRUE.) CALL print_and_update_for_ev_sc(vec_gw_energ_beta,vec_gw_energ_error_fit_beta,& z_value_beta,m_value_beta,mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:,2),Eigenval_beta,& Eigenval_last_beta,Eigenval_scf_beta,gw_corr_lev_occ_beta,gw_corr_lev_virt_beta,gw_corr_lev_tot,& count_ev_sc_GW,crossing_search,homo_beta,nmo,unit_nr,mp2_env%ri_g0w0%print_gw_details,& - error,do_beta=.TRUE.) + do_beta=.TRUE.) ELSE CALL print_and_update_for_ev_sc(vec_gw_energ,vec_gw_energ_error_fit,& z_value,m_value,mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:,1),Eigenval,& Eigenval_last,Eigenval_scf,gw_corr_lev_occ,gw_corr_lev_virt,gw_corr_lev_tot,& - count_ev_sc_GW,crossing_search,homo,nmo,unit_nr,mp2_env%ri_g0w0%print_gw_details,& - error) + count_ev_sc_GW,crossing_search,homo,nmo,unit_nr,mp2_env%ri_g0w0%print_gw_details) END IF @@ -2438,16 +2423,16 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& ! release buffer CALL release_buffer(RPA_proc_map,buffer_rec,buffer_send,& number_of_rec,number_of_send,& - map_send_size,map_rec_size,local_size_source,error) + map_send_size,map_rec_size,local_size_source) IF(my_open_shell) THEN CALL release_buffer(RPA_proc_map,buffer_rec_beta,buffer_send_beta,& number_of_rec_beta,number_of_send_beta,& - map_send_size_beta,map_rec_size_beta,local_size_source_beta,error) + map_send_size_beta,map_rec_size_beta,local_size_source_beta) END IF IF(my_do_gw) THEN - CALL cp_fm_release(fm_mat_S_gw_work,error=error) + CALL cp_fm_release(fm_mat_S_gw_work) DEALLOCATE(vec_Sigma_c_gw) DEALLOCATE(vec_omega_fit_gw) DEALLOCATE(vec_omega_fit_gw_sign) @@ -2463,7 +2448,7 @@ SUBROUTINE rpa_numerical_integ(Erpa,mp2_env,para_env,para_env_RPA,unit_nr,& DEALLOCATE(Eigenval_last) DEALLOCATE(Eigenval_scf) IF(my_open_shell) THEN - CALL cp_fm_release(fm_mat_S_gw_work_beta,error=error) + CALL cp_fm_release(fm_mat_S_gw_work_beta) DEALLOCATE(vec_W_gw_beta) DEALLOCATE(vec_Sigma_c_gw_beta) DEALLOCATE(z_value_beta) @@ -2498,7 +2483,6 @@ END SUBROUTINE rpa_numerical_integ !> \param tj_ext ... !> \param wj_ext ... !> \param fm_mat_S ... -!> \param error ... !> \param homo_beta ... !> \param virtual_beta ... !> \param dimen_ia_beta ... @@ -2507,7 +2491,7 @@ END SUBROUTINE rpa_numerical_integ ! ***************************************************************************** SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual,Eigenval,& num_integ_points,num_integ_group,color_rpa_group,& - tj_ext,wj_ext,fm_mat_S,error,& + tj_ext,wj_ext,fm_mat_S,& homo_beta,virtual_beta,dimen_ia_beta,Eigenval_beta,fm_mat_S_beta) REAL(KIND=dp) :: a_scaling_ext TYPE(cp_para_env_type), POINTER :: para_env, para_env_RPA @@ -2518,7 +2502,6 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual color_rpa_group REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: tj_ext, wj_ext TYPE(cp_fm_type), POINTER :: fm_mat_S - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, OPTIONAL :: homo_beta, virtual_beta, & dimen_ia_beta REAL(KIND=dp), DIMENSION(:), OPTIONAL :: Eigenval_beta @@ -2564,13 +2547,13 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual eps=1.0E-10_dp ALLOCATE(cottj(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tj(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wj(num_integ_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! calculate the cotangent of the abscissa tj DO jquad=1, num_integ_points @@ -2582,17 +2565,16 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual ! calculate the (ia|ia) RI integrals ! ---------------------------------- ! 1) get info fm_mat_S - !XXX CALL cp_fm_to_fm(source=fm_mat_S,destination=fm_mat_G,error=error) + !XXX CALL cp_fm_to_fm(source=fm_mat_S,destination=fm_mat_G) CALL cp_fm_get_info(matrix=fm_mat_S,& nrow_local=nrow_local,& ncol_local=ncol_local,& row_indices=row_indices,& - col_indices=col_indices,& - error=error) + col_indices=col_indices) ! allocate the local buffer of iaia_RI integrals (dp kind) ALLOCATE(iaia_RI_dp(nrow_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iaia_RI_dp=0.0_dp ! 2) perform the local multiplication SUM_K (ia|K)*(ia|K) @@ -2621,13 +2603,13 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual color_row=fm_mat_S%matrix_struct%context%mepos(1) CALL mp_comm_split_direct(para_env_RPA%group,comm_row,color_row) NULLIFY(para_env_row) - CALL cp_para_env_create(para_env_row,comm_row,error=error) + CALL cp_para_env_create(para_env_row,comm_row) CALL mp_sum(iaia_RI_dp,para_env_row%group) ! convert the iaia_RI_dp into double-double precision ALLOCATE(iaia_RI(nrow_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=1, nrow_local iaia_RI(iiB)=iaia_RI_dp(iiB) END DO @@ -2638,10 +2620,10 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual ! orbital energy differences, M_ia is the diagonal of the full RPA 'excitation' ! matrix ALLOCATE(D_ia(nrow_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(M_ia(nrow_local),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=1, nrow_local i_global=row_indices(iiB) @@ -2668,23 +2650,22 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual color_col=fm_mat_S%matrix_struct%context%mepos(2) CALL mp_comm_split_direct(para_env_RPA%group,comm_col,color_col) NULLIFY(para_env_col) - CALL cp_para_env_create(para_env_col,comm_col,error=error) + CALL cp_para_env_create(para_env_col,comm_col) ! allocate communication array for columns CALL mp_sum(right_term_ref,para_env_col%group) ! In the open shell case do point 1-2-3 for the beta spin IF(my_open_shell) THEN - !XXX CALL cp_fm_to_fm(source=fm_mat_S_beta,destination=fm_mat_G_beta,error=error) + !XXX CALL cp_fm_to_fm(source=fm_mat_S_beta,destination=fm_mat_G_beta) CALL cp_fm_get_info(matrix=fm_mat_S_beta,& nrow_local=nrow_local_beta,& ncol_local=ncol_local_beta,& row_indices=row_indices_beta,& - col_indices=col_indices_beta,& - error=error) + col_indices=col_indices_beta) ALLOCATE(iaia_RI_dp_beta(nrow_local_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iaia_RI_dp_beta=0.0_dp DO jjB=1, ncol_local_beta @@ -2696,22 +2677,22 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual color_row_beta=fm_mat_S_beta%matrix_struct%context%mepos(1) CALL mp_comm_split_direct(para_env_RPA%group,comm_row_beta,color_row_beta) NULLIFY(para_env_row_beta) - CALL cp_para_env_create(para_env_row_beta,comm_row_beta,error=error) + CALL cp_para_env_create(para_env_row_beta,comm_row_beta) CALL mp_sum(iaia_RI_dp_beta,para_env_row_beta%group) ALLOCATE(iaia_RI_beta(nrow_local_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=1, nrow_local_beta iaia_RI_beta(iiB)=iaia_RI_dp_beta(iiB) END DO DEALLOCATE(iaia_RI_dp_beta) ALLOCATE(D_ia_beta(nrow_local_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(M_ia_beta(nrow_local_beta),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iiB=1, nrow_local_beta i_global=row_indices_beta(iiB) @@ -2737,7 +2718,7 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual color_col_beta=fm_mat_S_beta%matrix_struct%context%mepos(2) CALL mp_comm_split_direct(para_env_RPA%group,comm_col_beta,color_col_beta) NULLIFY(para_env_col_beta) - CALL cp_para_env_create(para_env_col_beta,comm_col_beta,error=error) + CALL cp_para_env_create(para_env_col_beta,comm_col_beta) CALL mp_sum(right_term_ref_beta,para_env_col_beta%group) @@ -2814,15 +2795,15 @@ SUBROUTINE calc_scaling_factor(a_scaling_ext,para_env,para_env_RPA,homo,virtual DEALLOCATE(iaia_RI) DEALLOCATE(D_ia) DEALLOCATE(M_ia) - CALL cp_para_env_release(para_env_row,error=error) - CALL cp_para_env_release(para_env_col,error=error) + CALL cp_para_env_release(para_env_row) + CALL cp_para_env_release(para_env_col) IF(my_open_shell) THEN DEALLOCATE(iaia_RI_beta) DEALLOCATE(D_ia_beta) DEALLOCATE(M_ia_beta) - CALL cp_para_env_release(para_env_row_beta,error=error) - CALL cp_para_env_release(para_env_col_beta,error=error) + CALL cp_para_env_release(para_env_row_beta) + CALL cp_para_env_release(para_env_col_beta) END IF CALL timestop(handle) @@ -2936,10 +2917,9 @@ END SUBROUTINE calculate_objfunc !> \param num_fit_points ... !> \param n_level_gw ... !> \param h ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& - num_poles,num_fit_points,n_level_gw,h,error) + num_poles,num_fit_points,n_level_gw,h) REAL(KIND=dp) :: N_ij COMPLEX(KIND=dp), ALLOCATABLE, & DIMENSION(:) :: Lambda @@ -2949,7 +2929,6 @@ SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& INTEGER :: i, j, num_poles, & num_fit_points, n_level_gw REAL(KIND=dp) :: h - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_mat_N', & routineP = moduleN//':'//routineN @@ -2965,7 +2944,7 @@ SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& num_var=2*num_poles+1 ALLOCATE(Lambda_tmp(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda_tmp=(0.0_dp,0.0_dp) chi2_sum=0.0_dp re_unit=(1.0_dp,0.0_dp) @@ -2974,7 +2953,7 @@ SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& !test Lambda_tmp(:) = Lambda(:) CALL calc_chi2(chi2,Lambda_tmp,Sigma_c,vec_omega_fit_gw,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) ! Fitting parameters with offset h Lambda_tmp(:) = Lambda(:) @@ -2989,7 +2968,7 @@ SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& Lambda_tmp((j+1)/2)=Lambda_tmp((j+1)/2)+h*im_unit END IF CALL calc_chi2(chi2,Lambda_tmp,Sigma_c,vec_omega_fit_gw,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) chi2_sum=chi2_sum+chi2 IF(MODULO(i,2)==0) THEN @@ -2998,7 +2977,7 @@ SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& Lambda_tmp((i+1)/2)=Lambda_tmp((i+1)/2)-2.0_dp*h*im_unit END IF CALL calc_chi2(chi2,Lambda_tmp,Sigma_c,vec_omega_fit_gw,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) chi2_sum=chi2_sum-chi2 IF(MODULO(j,2)==0) THEN @@ -3007,7 +2986,7 @@ SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& Lambda_tmp((j+1)/2)=Lambda_tmp((j+1)/2)-2.0_dp*h*im_unit END IF CALL calc_chi2(chi2,Lambda_tmp,Sigma_c,vec_omega_fit_gw,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) chi2_sum=chi2_sum+chi2 IF(MODULO(i,2)==0) THEN @@ -3016,7 +2995,7 @@ SUBROUTINE calc_mat_N(N_ij,Lambda,Sigma_c,vec_omega_fit_gw,i,j,& Lambda_tmp((i+1)/2)=Lambda_tmp((i+1)/2)+2.0_dp*h*im_unit END IF CALL calc_chi2(chi2,Lambda_tmp,Sigma_c,vec_omega_fit_gw,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) chi2_sum=chi2_sum-chi2 ! Second derivative with symmetric difference quotient @@ -3037,10 +3016,9 @@ END SUBROUTINE calc_mat_N !> \param num_poles ... !> \param num_fit_points ... !> \param n_level_gw ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_chi2(chi2,Lambda,Sigma_c,vec_omega_fit_gw,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) REAL(KIND=dp) :: chi2 COMPLEX(KIND=dp), ALLOCATABLE, & DIMENSION(:) :: Lambda @@ -3049,7 +3027,6 @@ SUBROUTINE calc_chi2(chi2,Lambda,Sigma_c,vec_omega_fit_gw,num_poles,& REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: vec_omega_fit_gw INTEGER :: num_poles, num_fit_points, & n_level_gw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_chi2', & routineP = moduleN//':'//routineN @@ -3084,10 +3061,9 @@ END SUBROUTINE calc_chi2 !> \param num_poles ... !> \param num_fit_points ... !> \param n_level_gw ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calc_max_dev(max_dev,Lambda,Sigma_c,vec_omega_fit_gw,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) REAL(KIND=dp) :: max_dev COMPLEX(KIND=dp), ALLOCATABLE, & DIMENSION(:) :: Lambda @@ -3096,7 +3072,6 @@ SUBROUTINE calc_max_dev(max_dev,Lambda,Sigma_c,vec_omega_fit_gw,num_poles,& REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: vec_omega_fit_gw INTEGER :: num_poles, num_fit_points, & n_level_gw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_max_dev', & routineP = moduleN//':'//routineN @@ -3132,16 +3107,14 @@ END SUBROUTINE calc_max_dev !> \param omega real or complex energy !> \param e_fermi the Fermi level !> \param num_poles ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE evaluate_fit_function(func_val,Lambda,omega,e_fermi,num_poles,error) + SUBROUTINE evaluate_fit_function(func_val,Lambda,omega,e_fermi,num_poles) COMPLEX(KIND=dp) :: func_val COMPLEX(KIND=dp), ALLOCATABLE, & DIMENSION(:) :: Lambda COMPLEX(KIND=dp) :: omega REAL(KIND=dp) :: e_fermi INTEGER :: num_poles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'evaluate_fit_function', & routineP = moduleN//':'//routineN @@ -3182,12 +3155,11 @@ END SUBROUTINE evaluate_fit_function !> \param check_fit ... !> \param stop_crit ... !> \param fermi_level_offset ... -!> \param error ... ! ***************************************************************************** SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fit_gw,& z_value,m_value,vec_Sigma_c_gw,Eigenval,n_level_gw,gw_corr_lev_occ,num_poles,& num_fit_points,max_iter_fit,crossing_search,homo,unit_nr,check_fit,stop_crit,& - fermi_level_offset,error) + fermi_level_offset) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: vec_gw_energ, & vec_gw_energ_error_fit, & vec_omega_fit_gw, z_value, & @@ -3199,7 +3171,6 @@ SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fi max_iter_fit, crossing_search, homo, unit_nr LOGICAL :: check_fit REAL(KIND=dp) :: stop_crit, fermi_level_offset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fit_and_continuation', & routineP = moduleN//':'//routineN @@ -3232,20 +3203,20 @@ SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fi num_var=2*num_poles+1 ALLOCATE(Lambda(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda=(0.0_dp,0.0_dp) ALLOCATE(Lambda_without_offset(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda_without_offset=(0.0_dp,0.0_dp) ALLOCATE(Lambda_Re(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda_Re=0.0_dp ALLOCATE(Lambda_Im(num_var),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Lambda_Im=0.0_dp ALLOCATE(vec_omega_fit_gw_sign(num_fit_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(n_level_gw<=gw_corr_lev_occ) THEN sign_occ_virt = -1.0_dp @@ -3272,15 +3243,15 @@ SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fi END DO CALL calc_chi2(chi2_old,Lambda,vec_Sigma_c_gw,vec_omega_fit_gw_sign,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) ALLOCATE(mat_A_gw(num_poles+1,num_poles+1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vec_b_gw(num_poles+1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ipiv(num_poles+1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mat_A_gw=(0.0_dp,0.0_dp) vec_b_gw=0.0_dp @@ -3303,10 +3274,10 @@ SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fi ! Solve system of linear equations CALL ZGETRF(num_poles+1,num_poles+1,mat_A_gw,num_poles+1,ipiv,info) - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) CALL ZGETRS('N',num_poles+1,1,mat_A_gw,num_poles+1,ipiv,vec_b_gw,num_poles+1,info) - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) Lambda_Re(1)=REAL(vec_b_gw(1)) Lambda_Im(1)=AIMAG(vec_b_gw(1)) @@ -3321,19 +3292,19 @@ SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fi DEALLOCATE(ipiv) ALLOCATE(mat_A_gw(num_var*2,num_var*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mat_B_gw(num_fit_points,num_var*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dLambda(num_fit_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(dLambda_2(num_fit_points),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vec_b_gw(num_var*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vec_b_gw_copy(num_var*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ipiv(num_var*2),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ScalParam=0.01_dp Ldown=1.5_dp @@ -3406,10 +3377,10 @@ SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fi CALL timeset(routineN//"_fit_lin_eq_2",handle4) CALL ZGETRF(2*num_var,2*num_var,mat_A_gw,2*num_var,ipiv,info) - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) CALL ZGETRS('N',2*num_var,1,mat_A_gw,2*num_var,ipiv,vec_b_gw,2*num_var,info) - CPPrecondition(info==0,cp_failure_level,routineP,error,failure) + CPPrecondition(info==0,cp_failure_level,routineP,failure) CALL timestop(handle4) @@ -3419,7 +3390,7 @@ SUBROUTINE fit_and_continuation(vec_gw_energ,vec_gw_energ_error_fit,vec_omega_fi ! calculate chi2 CALL calc_chi2(chi2,Lambda,vec_Sigma_c_gw,vec_omega_fit_gw_sign,num_poles,& - num_fit_points,n_level_gw,error) + num_fit_points,n_level_gw) IF(chi2 \param nmo ... !> \param unit_nr ... !> \param print_gw_details ... -!> \param error ... !> \param do_alpha ... !> \param do_beta ... ! ***************************************************************************** SUBROUTINE print_and_update_for_ev_sc(vec_gw_energ,vec_gw_energ_error_fit,& z_value,m_value,vec_Sigma_x_minus_vxc_gw,Eigenval,& Eigenval_last,Eigenval_scf,gw_corr_lev_occ,gw_corr_lev_virt,gw_corr_lev_tot,& - count_ev_sc_GW,crossing_search,homo,nmo,unit_nr,print_gw_details,error,do_alpha,do_beta) + count_ev_sc_GW,crossing_search,homo,nmo,unit_nr,print_gw_details,do_alpha,do_beta) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: vec_gw_energ, & vec_gw_energ_error_fit, & @@ -3657,7 +3627,6 @@ SUBROUTINE print_and_update_for_ev_sc(vec_gw_energ,vec_gw_energ_error_fit,& INTEGER :: gw_corr_lev_occ, gw_corr_lev_virt, gw_corr_lev_tot, & count_ev_sc_GW, crossing_search, homo, nmo, unit_nr LOGICAL :: print_gw_details - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL, OPTIONAL :: do_alpha, do_beta CHARACTER(LEN=*), PARAMETER :: routineN = 'print_and_update_for_ev_sc', & diff --git a/src/rs_pw_interface.F b/src/rs_pw_interface.F index fb73be1274..102d728afb 100644 --- a/src/rs_pw_interface.F +++ b/src/rs_pw_interface.F @@ -62,18 +62,16 @@ MODULE rs_pw_interface !> \param rs_rho ... !> \param rho ... !> \param rho_gspace ... -!> \param error ... !> \note !> should contain all communication in the collocation of the density !> in the case of replicated grids ! ***************************************************************************** - SUBROUTINE density_rs2pw(pw_env,rs_rho,rho,rho_gspace,error) + SUBROUTINE density_rs2pw(pw_env,rs_rho,rho,rho_gspace) TYPE(pw_env_type), POINTER :: pw_env TYPE(realspace_grid_p_type), & DIMENSION(:), POINTER :: rs_rho TYPE(pw_p_type), INTENT(INOUT) :: rho, rho_gspace - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_rs2pw', & routineP = moduleN//':'//routineN @@ -91,63 +89,62 @@ SUBROUTINE density_rs2pw(pw_env,rs_rho,rho,rho_gspace,error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(gridlevel_info, mgrid_gspace, mgrid_rspace, rs_descs, pw_pools) - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CALL pw_env_get(pw_env, rs_descs=rs_descs, pw_pools=pw_pools, error=error) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CALL pw_env_get(pw_env, rs_descs=rs_descs, pw_pools=pw_pools) gridlevel_info=>pw_env%gridlevel_info - CALL section_vals_val_get(pw_env%interp_section,"KIND",i_val=interp_kind,error=error) + CALL section_vals_val_get(pw_env%interp_section,"KIND",i_val=interp_kind) CALL pw_pools_create_pws(pw_pools,mgrid_rspace,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pools_create_pws(pw_pools,mgrid_gspace,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) IF (gridlevel_info%ngrid_levels==1) THEN - CALL rs_pw_transfer(rs_rho(1)%rs_grid,rho%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho(1)%rs_grid, error=error) - CALL pw_transfer(rho%pw,rho_gspace%pw,error=error) + CALL rs_pw_transfer(rs_rho(1)%rs_grid,rho%pw,rs2pw) + CALL rs_grid_release(rs_rho(1)%rs_grid) + CALL pw_transfer(rho%pw,rho_gspace%pw) IF (rho%pw%pw_grid%spherical) THEN ! rho_gspace = rho - CALL pw_transfer(rho_gspace%pw,rho%pw,error=error) + CALL pw_transfer(rho_gspace%pw,rho%pw) ENDIF ELSE DO igrid_level=1,gridlevel_info%ngrid_levels CALL rs_pw_transfer(rs_rho(igrid_level)%rs_grid,& - mgrid_rspace(igrid_level)%pw,rs2pw,error=error) - CALL rs_grid_release(rs_rho(igrid_level)%rs_grid, error=error) + mgrid_rspace(igrid_level)%pw,rs2pw) + CALL rs_grid_release(rs_rho(igrid_level)%rs_grid) ENDDO ! we want both rho and rho_gspace, the latter for Hartree and co-workers. SELECT CASE(interp_kind) CASE(pw_interp) - CALL pw_zero(rho_gspace%pw,error=error) + CALL pw_zero(rho_gspace%pw) DO igrid_level=1,gridlevel_info%ngrid_levels CALL pw_transfer(mgrid_rspace(igrid_level)%pw,& - mgrid_gspace(igrid_level)%pw,error=error) - CALL pw_axpy(mgrid_gspace(igrid_level)%pw,rho_gspace%pw,& - error=error) + mgrid_gspace(igrid_level)%pw) + CALL pw_axpy(mgrid_gspace(igrid_level)%pw,rho_gspace%pw) END DO - CALL pw_transfer(rho_gspace%pw,rho%pw,error=error) + CALL pw_transfer(rho_gspace%pw,rho%pw) CASE(spline3_pbc_interp) DO igrid_level=gridlevel_info%ngrid_levels,2,-1 CALL pw_prolongate_s3(mgrid_rspace(igrid_level)%pw,& mgrid_rspace(igrid_level-1)%pw,pw_pools(igrid_level)%pool,& - pw_env%interp_section,error=error) + pw_env%interp_section) END DO - CALL pw_copy(mgrid_rspace(1)%pw,rho%pw,error=error) - CALL pw_transfer(rho%pw,rho_gspace%pw,error=error) + CALL pw_copy(mgrid_rspace(1)%pw,rho%pw) + CALL pw_transfer(rho%pw,rho_gspace%pw) CASE default CALL cp_unimplemented_error(routineN,"interpolator "//& - cp_to_string(interp_kind),error=error) + cp_to_string(interp_kind)) END SELECT END IF ! *** give back the pw multi-grids - CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace,error=error) - CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace,error=error) + CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace) + CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace) CALL timestop(handle) END SUBROUTINE density_rs2pw @@ -159,18 +156,16 @@ END SUBROUTINE density_rs2pw !> \param rs_rho ... !> \param rho ... !> \param rho_gspace ... -!> \param error ... !> \note !> should contain the all communication in the collocation of the density !> in the case of replicated grids ! ***************************************************************************** - SUBROUTINE density_rs2pw_basic(pw_env,rs_rho,rho,rho_gspace,error) + SUBROUTINE density_rs2pw_basic(pw_env,rs_rho,rho,rho_gspace) TYPE(pw_env_type), POINTER :: pw_env TYPE(realspace_grid_p_type), & DIMENSION(:), POINTER :: rs_rho TYPE(pw_p_type), INTENT(INOUT) :: rho, rho_gspace - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'density_rs2pw_basic', & routineP = moduleN//':'//routineN @@ -188,29 +183,29 @@ SUBROUTINE density_rs2pw_basic(pw_env,rs_rho,rho,rho_gspace,error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(gridlevel_info, mgrid_gspace, mgrid_rspace, rs_descs, pw_pools) - CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,error,failure) - CALL pw_env_get(pw_env, rs_descs=rs_descs, pw_pools=pw_pools, error=error) + CPPrecondition(ASSOCIATED(pw_env),cp_failure_level,routineP,failure) + CALL pw_env_get(pw_env, rs_descs=rs_descs, pw_pools=pw_pools) gridlevel_info=>pw_env%gridlevel_info - CALL section_vals_val_get(pw_env%interp_section,"KIND",i_val=interp_kind,error=error) + CALL section_vals_val_get(pw_env%interp_section,"KIND",i_val=interp_kind) CALL pw_pools_create_pws(pw_pools,mgrid_rspace,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pools_create_pws(pw_pools,mgrid_gspace,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) IF (gridlevel_info%ngrid_levels==1) THEN - CALL rs_pw_transfer(rs_rho(1)%rs_grid,rho%pw,rs2pw,error=error) - CALL pw_transfer(rho%pw,rho_gspace%pw,error=error) + CALL rs_pw_transfer(rs_rho(1)%rs_grid,rho%pw,rs2pw) + CALL pw_transfer(rho%pw,rho_gspace%pw) ELSE DO igrid_level=1,gridlevel_info%ngrid_levels CALL rs_pw_transfer(rs_rho(igrid_level)%rs_grid,& - mgrid_rspace(igrid_level)%pw,rs2pw,error=error) + mgrid_rspace(igrid_level)%pw,rs2pw) ENDDO ! we want both rho and rho_gspace, the latter for Hartree and co-workers. @@ -218,31 +213,30 @@ SUBROUTINE density_rs2pw_basic(pw_env,rs_rho,rho,rho_gspace,error) CASE(pw_interp) DO igrid_level=1,gridlevel_info%ngrid_levels CALL pw_transfer(mgrid_rspace(igrid_level)%pw,& - mgrid_gspace(igrid_level)%pw,error=error) + mgrid_gspace(igrid_level)%pw) IF (igrid_level/=1) THEN - CALL pw_axpy(mgrid_gspace(igrid_level)%pw,mgrid_gspace(1)%pw,& - error=error) + CALL pw_axpy(mgrid_gspace(igrid_level)%pw,mgrid_gspace(1)%pw) END IF END DO - CALL pw_transfer(mgrid_gspace(1)%pw,rho%pw,error=error) - CALL pw_transfer(mgrid_rspace(1)%pw,rho_gspace%pw,error=error) + CALL pw_transfer(mgrid_gspace(1)%pw,rho%pw) + CALL pw_transfer(mgrid_rspace(1)%pw,rho_gspace%pw) CASE(spline3_pbc_interp) DO igrid_level=gridlevel_info%ngrid_levels,2,-1 CALL pw_prolongate_s3(mgrid_rspace(igrid_level)%pw,& mgrid_rspace(igrid_level-1)%pw,pw_pools(igrid_level)%pool,& - pw_env%interp_section,error=error) + pw_env%interp_section) END DO - CALL pw_copy(mgrid_rspace(1)%pw,rho%pw,error=error) - CALL pw_transfer(rho%pw,rho_gspace%pw,error=error) + CALL pw_copy(mgrid_rspace(1)%pw,rho%pw) + CALL pw_transfer(rho%pw,rho_gspace%pw) CASE default CALL cp_unimplemented_error(routineN,"interpolator "//& - cp_to_string(interp_kind),error=error) + cp_to_string(interp_kind)) END SELECT END IF ! *** give back the pw multi-grids - CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace,error=error) - CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace,error=error) + CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace) + CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace) CALL timestop(handle) END SUBROUTINE density_rs2pw_basic @@ -254,7 +248,6 @@ END SUBROUTINE density_rs2pw_basic !> \param rs_v OUTPUT: the potential on the realspace multigrids !> \param v_rspace INPUT : the potential on a planewave grid in Rspace !> \param pw_env ... -!> \param error ... !> \par History !> 09.2006 created [Joost VandeVondele] !> \note @@ -262,13 +255,12 @@ END SUBROUTINE density_rs2pw_basic !> should contain all parallel communication of integrate_v_rspace in the !> case of replicated grids. ! ***************************************************************************** - SUBROUTINE potential_pw2rs(rs_v,v_rspace,pw_env,error) + SUBROUTINE potential_pw2rs(rs_v,v_rspace,pw_env) TYPE(realspace_grid_p_type), & DIMENSION(:), POINTER :: rs_v TYPE(pw_p_type), INTENT(IN) :: v_rspace TYPE(pw_env_type), POINTER :: pw_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'potential_pw2rs', & routineP = moduleN//':'//routineN @@ -285,32 +277,29 @@ SUBROUTINE potential_pw2rs(rs_v,v_rspace,pw_env,error) ! *** set up of the potential on the multigrids CALL pw_env_get(pw_env, pw_pools=pw_pools, gridlevel_info=gridlevel_info, & - auxbas_grid = auxbas_grid, error=error) + auxbas_grid = auxbas_grid) CALL pw_pools_create_pws(pw_pools,mgrid_rspace,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) ! use either realspace or fft techniques to get the potential on the rs multigrids - CALL section_vals_val_get(pw_env%interp_section,"KIND",i_val=interp_kind,error=error) + CALL section_vals_val_get(pw_env%interp_section,"KIND",i_val=interp_kind) SELECT CASE(interp_kind) CASE (pw_interp) CALL pw_pools_create_pws(pw_pools,mgrid_gspace,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) - CALL pw_transfer(v_rspace%pw,mgrid_gspace(auxbas_grid)%pw,error=error) + in_space = RECIPROCALSPACE) + CALL pw_transfer(v_rspace%pw,mgrid_gspace(auxbas_grid)%pw) DO igrid_level=1,gridlevel_info%ngrid_levels IF ( igrid_level /= auxbas_grid ) THEN - CALL pw_copy(mgrid_gspace(auxbas_grid)%pw,mgrid_gspace(igrid_level)%pw,& - error=error) - CALL pw_transfer(mgrid_gspace(igrid_level)%pw,mgrid_rspace(igrid_level)%pw,& - error=error) + CALL pw_copy(mgrid_gspace(auxbas_grid)%pw,mgrid_gspace(igrid_level)%pw) + CALL pw_transfer(mgrid_gspace(igrid_level)%pw,mgrid_rspace(igrid_level)%pw) ELSE IF (mgrid_gspace(auxbas_grid)%pw%pw_grid%spherical) THEN - CALL pw_transfer(mgrid_gspace(auxbas_grid)%pw,mgrid_rspace(auxbas_grid)%pw,& - error=error) + CALL pw_transfer(mgrid_gspace(auxbas_grid)%pw,mgrid_rspace(auxbas_grid)%pw) ELSE ! fft forward + backward should be identical - CALL pw_copy(v_rspace%pw,mgrid_rspace(auxbas_grid)%pw,error=error) + CALL pw_copy(v_rspace%pw,mgrid_rspace(auxbas_grid)%pw) ENDIF ENDIF ! *** Multiply by the grid volume element ratio *** @@ -321,29 +310,29 @@ SUBROUTINE potential_pw2rs(rs_v,v_rspace,pw_env,error) scale*mgrid_rspace(igrid_level)%pw%cr3d END IF END DO - CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace,error=error) + CALL pw_pools_give_back_pws(pw_pools,mgrid_gspace) CASE(spline3_pbc_interp) - CALL pw_copy(v_rspace%pw,mgrid_rspace(1)%pw,error=error) + CALL pw_copy(v_rspace%pw,mgrid_rspace(1)%pw) DO igrid_level=1,gridlevel_info%ngrid_levels-1 - CALL pw_zero(mgrid_rspace(igrid_level+1)%pw,error=error) + CALL pw_zero(mgrid_rspace(igrid_level+1)%pw) CALL pw_restrict_s3(mgrid_rspace(igrid_level)%pw,& mgrid_rspace(igrid_level+1)%pw,pw_pools(igrid_level+1)%pool,& - pw_env%interp_section,error=error) + pw_env%interp_section) ! *** Multiply by the grid volume element ratio mgrid_rspace(igrid_level+1) % pw % cr3d = & mgrid_rspace(igrid_level+1) % pw % cr3d * 8._dp END DO CASE default CALL cp_unimplemented_error(routineN,"interpolation not supported "//& - cp_to_string(interp_kind),error=error) + cp_to_string(interp_kind)) END SELECT DO igrid_level=1,gridlevel_info%ngrid_levels CALL rs_pw_transfer(rs_v(igrid_level)%rs_grid,& - mgrid_rspace(igrid_level)%pw,pw2rs,error=error) + mgrid_rspace(igrid_level)%pw,pw2rs) ENDDO ! *** give back the pw multi-grids - CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace,error=error) + CALL pw_pools_give_back_pws(pw_pools,mgrid_rspace) CALL timestop(handle) diff --git a/src/rt_propagation_forces.F b/src/rt_propagation_forces.F index 39572a6343..84724f645d 100644 --- a/src/rt_propagation_forces.F +++ b/src/rt_propagation_forces.F @@ -69,22 +69,20 @@ MODULE rt_propagation_forces !> P_imag*C , P_imag*B*S^-1*S_der , P*S^-1*H*S_der !> driver routine !> \param qs_env ... -!> \param error ... !> \par History !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE calc_c_mat_force(qs_env,error) + SUBROUTINE calc_c_mat_force(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_c_mat_force', & routineP = moduleN//':'//routineN IF(qs_env%rtp%linear_scaling)THEN - CALL calc_c_mat_force_ls(qs_env,error) + CALL calc_c_mat_force_ls(qs_env) ELSE - CALL calc_c_mat_force_fm(qs_env,error) + CALL calc_c_mat_force_fm(qs_env) END IF END SUBROUTINE calc_c_mat_force @@ -93,11 +91,9 @@ END SUBROUTINE calc_c_mat_force !> \brief standard treatment for fm MO based calculations !> P_imag*C , P_imag*B*S^-1*S_der , P*S^-1*H*S_der !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calc_c_mat_force_fm(qs_env,error) + SUBROUTINE calc_c_mat_force_fm(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_c_mat_force_fm', & routineP = moduleN//':'//routineN @@ -133,25 +129,25 @@ SUBROUTINE calc_c_mat_force_fm(qs_env,error) NULLIFY(rtp,particle_set,atomic_kind_set,mos) NULLIFY(tmp_dbcsr,rho_im_sparse) CALL get_qs_env(qs_env=qs_env,rtp=rtp,particle_set=particle_set,& - atomic_kind_set=atomic_kind_set,mos=mos,force=force,error=error) + atomic_kind_set=atomic_kind_set,mos=mos,force=force) CALL get_rtp(rtp=rtp,C_mat=C_mat,S_der=S_der,& - SinvH=SinvH,SinvB=SinvB,mos_new=mos_new,error=error) + SinvH=SinvH,SinvB=SinvB,mos_new=mos_new) ALLOCATE(tmp_dbcsr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rho_im_sparse,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp_dbcsr,error=error) - CALL cp_dbcsr_create(tmp_dbcsr,template=SinvH(1)%matrix, error=error) - CALL cp_dbcsr_init(rho_im_sparse,error=error) - CALL cp_dbcsr_create(rho_im_sparse,template=SinvH(1)%matrix, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp_dbcsr) + CALL cp_dbcsr_create(tmp_dbcsr,template=SinvH(1)%matrix) + CALL cp_dbcsr_init(rho_im_sparse) + CALL cp_dbcsr_create(rho_im_sparse,template=SinvH(1)%matrix) natom = SIZE(particle_set) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind,kind_of=kind_of) @@ -165,36 +161,36 @@ SUBROUTINE calc_c_mat_force_fm(qs_env,error) NULLIFY(col_blk_size) CALL dbcsr_create_dist_r_unrot (dist, cp_dbcsr_distribution(SinvB(ispin)%matrix), nmo, col_blk_size) - CALL cp_dbcsr_init(db_mos_re, error) + CALL cp_dbcsr_init(db_mos_re) CALL cp_dbcsr_create(db_mos_re, "D", dist, dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(SinvB(ispin)%matrix), col_blk_size,& - nze=0, error=error) - CALL cp_dbcsr_init(db_mos_im, error) - CALL cp_dbcsr_create(db_mos_im,template=db_mos_re, error=error) - CALL cp_dbcsr_init(db_mo_tmp1, error) - CALL cp_dbcsr_create(db_mo_tmp1,template=db_mos_re, error=error) - CALL cp_dbcsr_init(db_mo_tmp2, error) - CALL cp_dbcsr_create(db_mo_tmp2,template=db_mos_re, error=error) - - CALL copy_fm_to_dbcsr(mos_new(im)%matrix,db_mos_im,error=error) - CALL copy_fm_to_dbcsr(mos_new(re)%matrix,db_mos_re,error=error) - - CALL cp_dbcsr_multiply("N","N",alpha, SinvB(ispin)%matrix,db_mos_im,0.0_dp,db_mo_tmp1,error=error) - CALL cp_dbcsr_multiply("N","N",alpha, SinvH(ispin)%matrix,db_mos_re,1.0_dp,db_mo_tmp1,error=error) - CALL cp_dbcsr_multiply("N","N",-alpha,SinvB(ispin)%matrix,db_mos_re,0.0_dp,db_mo_tmp2,error=error) - CALL cp_dbcsr_multiply("N","N",alpha, SinvH(ispin)%matrix,db_mos_im,1.0_dp,db_mo_tmp2,error=error) - CALL cp_dbcsr_multiply("N","T",1.0_dp,db_mo_tmp1,db_mos_re,0.0_dp,tmp_dbcsr,error=error) - CALL cp_dbcsr_multiply("N","T",1.0_dp,db_mo_tmp2,db_mos_im,1.0_dp,tmp_dbcsr,error=error) + nze=0) + CALL cp_dbcsr_init(db_mos_im) + CALL cp_dbcsr_create(db_mos_im,template=db_mos_re) + CALL cp_dbcsr_init(db_mo_tmp1) + CALL cp_dbcsr_create(db_mo_tmp1,template=db_mos_re) + CALL cp_dbcsr_init(db_mo_tmp2) + CALL cp_dbcsr_create(db_mo_tmp2,template=db_mos_re) + + CALL copy_fm_to_dbcsr(mos_new(im)%matrix,db_mos_im) + CALL copy_fm_to_dbcsr(mos_new(re)%matrix,db_mos_re) + + CALL cp_dbcsr_multiply("N","N",alpha, SinvB(ispin)%matrix,db_mos_im,0.0_dp,db_mo_tmp1) + CALL cp_dbcsr_multiply("N","N",alpha, SinvH(ispin)%matrix,db_mos_re,1.0_dp,db_mo_tmp1) + CALL cp_dbcsr_multiply("N","N",-alpha,SinvB(ispin)%matrix,db_mos_re,0.0_dp,db_mo_tmp2) + CALL cp_dbcsr_multiply("N","N",alpha, SinvH(ispin)%matrix,db_mos_im,1.0_dp,db_mo_tmp2) + CALL cp_dbcsr_multiply("N","T",1.0_dp,db_mo_tmp1,db_mos_re,0.0_dp,tmp_dbcsr) + CALL cp_dbcsr_multiply("N","T",1.0_dp,db_mo_tmp2,db_mos_im,1.0_dp,tmp_dbcsr) - CALL cp_dbcsr_multiply("N","T",alpha,db_mos_re,db_mos_im,0.0_dp,rho_im_sparse,error=error) - CALL cp_dbcsr_multiply("N","T",-alpha,db_mos_im,db_mos_re,1.0_dp,rho_im_sparse,error=error) + CALL cp_dbcsr_multiply("N","T",alpha,db_mos_re,db_mos_im,0.0_dp,rho_im_sparse) + CALL cp_dbcsr_multiply("N","T",-alpha,db_mos_im,db_mos_re,1.0_dp,rho_im_sparse) - CALL compute_forces(force,tmp_dbcsr,S_der,rho_im_sparse,C_mat,kind_of,atom_of_kind,error) + CALL compute_forces(force,tmp_dbcsr,S_der,rho_im_sparse,C_mat,kind_of,atom_of_kind) - CALL cp_dbcsr_release(db_mos_re,error) - CALL cp_dbcsr_release(db_mos_im,error) - CALL cp_dbcsr_release(db_mo_tmp1,error) - CALL cp_dbcsr_release(db_mo_tmp2,error) + CALL cp_dbcsr_release(db_mos_re) + CALL cp_dbcsr_release(db_mos_im) + CALL cp_dbcsr_release(db_mo_tmp1) + CALL cp_dbcsr_release(db_mo_tmp2) DEALLOCATE(col_blk_size) CALL dbcsr_distribution_release(dist) @@ -205,16 +201,16 @@ SUBROUTINE calc_c_mat_force_fm(qs_env,error) force(i)%ehrenfest(:,:)=- force(i)%ehrenfest(:,:) END DO - CALL cp_dbcsr_release(tmp_dbcsr,error) - CALL cp_dbcsr_release(rho_im_sparse,error) + CALL cp_dbcsr_release(tmp_dbcsr) + CALL cp_dbcsr_release(rho_im_sparse) DEALLOCATE (atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (kind_of,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_dbcsr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rho_im_sparse,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -225,15 +221,13 @@ END SUBROUTINE calc_c_mat_force_fm !> \brief special treatment ofr linear scaling !> P_imag*C , P_imag*B*S^-1*S_der , P*S^-1*H*S_der !> \param qs_env ... -!> \param error ... !> \par History !> 02.2014 switched to dbcsr matrices [Samuel Andermatt] !> \author Florian Schiffmann (02.09) ! ***************************************************************************** - SUBROUTINE calc_c_mat_force_ls(qs_env,error) + SUBROUTINE calc_c_mat_force_ls(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_c_mat_force_ls', & routineP = moduleN//':'//routineN @@ -267,64 +261,63 @@ SUBROUTINE calc_c_mat_force_ls(qs_env,error) particle_set=particle_set,& atomic_kind_set=atomic_kind_set,& force=force,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) rtp_control=>dft_control%rtp_control CALL get_rtp(rtp=rtp,C_mat=C_mat,S_der=S_der,S_inv=S_inv,& - SinvH=SinvH,SinvB=SinvB,error=error) + SinvH=SinvH,SinvB=SinvB) natom = SIZE(particle_set) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (kind_of(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind,kind_of=kind_of) NULLIFY(tmp) ALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp,error=error) - CALL cp_dbcsr_create(tmp,template=SinvB(1)%matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp) + CALL cp_dbcsr_create(tmp,template=SinvB(1)%matrix) NULLIFY(tmp2) ALLOCATE(tmp2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp2,error=error) - CALL cp_dbcsr_create(tmp2,template=SinvB(1)%matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp2) + CALL cp_dbcsr_create(tmp2,template=SinvB(1)%matrix) NULLIFY(tmp3) ALLOCATE(tmp3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(tmp3,error=error) - CALL cp_dbcsr_create(tmp3,template=SinvB(1)%matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(tmp3) + CALL cp_dbcsr_create(tmp3,template=SinvB(1)%matrix) - CALL get_rtp(rtp=rtp,rho_new=rho_new,S_minus_half=S_minus_half,error=error) + CALL get_rtp(rtp=rtp,rho_new=rho_new,S_minus_half=S_minus_half) DO ispin=1,SIZE(SinvH) re=2*ispin-1 im=2*ispin IF(rtp_control%orthonormal) THEN CALL cp_dbcsr_multiply("N","N",one,S_minus_half,SinvH(ispin)%matrix,zero,tmp2,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,tmp2,rho_new(re)%matrix,zero,tmp3,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,tmp3,S_minus_half,zero,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,S_minus_half,SinvB(ispin)%matrix,zero,tmp2,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,tmp2,rho_new(im)%matrix,zero,tmp3,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",one,tmp3,S_minus_half,one,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ELSE CALL cp_dbcsr_multiply("N","N",one,SinvH(ispin)%matrix,rho_new(re)%matrix,zero,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) CALL cp_dbcsr_multiply("N","N",-one,SinvB(ispin)%matrix,rho_new(im)%matrix,one,tmp,& - filter_eps=rtp%filter_eps,error=error) + filter_eps=rtp%filter_eps) ENDIF - CALL compute_forces(force,tmp,S_der,rho_new(im)%matrix,C_mat,kind_of,atom_of_kind,error) + CALL compute_forces(force,tmp,S_der,rho_new(im)%matrix,C_mat,kind_of,atom_of_kind) END DO @@ -333,14 +326,14 @@ SUBROUTINE calc_c_mat_force_ls(qs_env,error) force(i)%ehrenfest(:,:)=- force(i)%ehrenfest(:,:) END DO - CALL cp_dbcsr_deallocate_matrix(tmp,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp2,error=error) - CALL cp_dbcsr_deallocate_matrix(tmp3,error=error) + CALL cp_dbcsr_deallocate_matrix(tmp) + CALL cp_dbcsr_deallocate_matrix(tmp2) + CALL cp_dbcsr_deallocate_matrix(tmp3) DEALLOCATE (atom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (kind_of,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -355,9 +348,8 @@ SUBROUTINE calc_c_mat_force_ls(qs_env,error) !> \param C_mat ... !> \param kind_of ... !> \param atom_of_kind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE compute_forces(force,tmp,S_der,rho_im,C_mat,kind_of,atom_of_kind,error) + SUBROUTINE compute_forces(force,tmp,S_der,rho_im,C_mat,kind_of,atom_of_kind) TYPE(qs_force_type), DIMENSION(:), & POINTER :: force TYPE(cp_dbcsr_type), POINTER :: tmp @@ -367,7 +359,6 @@ SUBROUTINE compute_forces(force,tmp,S_der,rho_im,C_mat,kind_of,atom_of_kind,erro TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: C_mat INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of, atom_of_kind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_forces', & routineP = moduleN//':'//routineN @@ -420,11 +411,9 @@ END SUBROUTINE compute_forces ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rt_admm_force(qs_env,error) + SUBROUTINE rt_admm_force(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_admm_force', & routineP = moduleN//':'//routineN @@ -444,14 +433,13 @@ SUBROUTINE rt_admm_force(qs_env,error) matrix_ks_aux_fit=KS_aux_re,& matrix_ks_aux_fit_im=KS_aux_im,& matrix_s_aux_fit=matrix_s_aux_fit,& - matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb,& - error=error) + matrix_s_aux_fit_vs_orb=matrix_s_aux_fit_vs_orb) - CALL get_rtp(rtp=rtp,mos_new=mos,admm_mos=mos_admm,error=error) + CALL get_rtp(rtp=rtp,mos_new=mos,admm_mos=mos_admm) ! currently only none option CALL rt_admm_forces_none(qs_env, admm_env, KS_aux_re, KS_aux_im, & - matrix_s_aux_fit, matrix_s_aux_fit_vs_orb , mos_admm,mos,error) + matrix_s_aux_fit, matrix_s_aux_fit_vs_orb , mos_admm,mos) END SUBROUTINE rt_admm_force @@ -465,9 +453,8 @@ END SUBROUTINE rt_admm_force !> \param matrix_s_aux_fit_vs_orb ... !> \param mos_admm ... !> \param mos ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rt_admm_forces_none(qs_env,admm_env,KS_aux_re,KS_aux_im,matrix_s_aux_fit, matrix_s_aux_fit_vs_orb,mos_admm,mos,error) + SUBROUTINE rt_admm_forces_none(qs_env,admm_env,KS_aux_re,KS_aux_im,matrix_s_aux_fit, matrix_s_aux_fit_vs_orb,mos_admm,mos) TYPE(qs_environment_type), POINTER :: qs_env TYPE(admm_type), POINTER :: admm_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -476,7 +463,6 @@ SUBROUTINE rt_admm_forces_none(qs_env,admm_env,KS_aux_re,KS_aux_im,matrix_s_aux_ matrix_s_aux_fit_vs_orb TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: mos_admm, mos - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_admm_forces_none', & routineP = moduleN//':'//routineN @@ -502,105 +488,101 @@ SUBROUTINE rt_admm_forces_none(qs_env,admm_env,KS_aux_re,KS_aux_im,matrix_s_aux_ NULLIFY(sab_aux_fit_asymm, sab_aux_fit_vs_orb, ks_env) failure = .FALSE. -! CALL cp_fm_create(tmp_aux_aux,admm_env%fm_struct_tmp,name="fm matrix",error=error) +! CALL cp_fm_create(tmp_aux_aux,admm_env%fm_struct_tmp,name="fm matrix") CALL get_qs_env(qs_env,& sab_aux_fit_asymm=sab_aux_fit_asymm,& sab_aux_fit_vs_orb=sab_aux_fit_vs_orb,& - ks_env=ks_env,& - error=error) + ks_env=ks_env) ALLOCATE(matrix_w_s) - CALL cp_dbcsr_init (matrix_w_s, error) + CALL cp_dbcsr_init (matrix_w_s) CALL cp_dbcsr_create(matrix_w_s, 'W MATRIX AUX S', & cp_dbcsr_distribution(matrix_s_aux_fit(1)%matrix), dbcsr_type_no_symmetry, & cp_dbcsr_row_block_sizes(matrix_s_aux_fit(1)%matrix),& cp_dbcsr_col_block_sizes(matrix_s_aux_fit(1)%matrix), & cp_dbcsr_get_data_size(matrix_s_aux_fit(1)%matrix),& - cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix), & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(matrix_w_s,sab_aux_fit_asymm,error=error) + cp_dbcsr_get_data_type(matrix_s_aux_fit(1)%matrix)) + CALL cp_dbcsr_alloc_block_from_nbl(matrix_w_s,sab_aux_fit_asymm) ALLOCATE(matrix_w_q) - CALL cp_dbcsr_init(matrix_w_q, error=error) + CALL cp_dbcsr_init(matrix_w_q) CALL cp_dbcsr_copy(matrix_w_q,matrix_s_aux_fit_vs_orb(1)%matrix,& - "W MATRIX AUX Q",error=error) + "W MATRIX AUX Q") DO ispin=1,SIZE(KS_aux_re) re=2*ispin-1; im=2*ispin naux=admm_env%nao_aux_fit; nmo=admm_env%nmo(ispin); nao=admm_env%nao_orb ALLOCATE(tmp_aux_aux(2),tmp_aux_nao(2),tmp_aux_mo(2),tmp_aux_mo1(2)) - CALL cp_fm_create(tmp_aux_aux(1)%matrix,admm_env%work_aux_aux%matrix_struct,name="taa",error=error) - CALL cp_fm_create(tmp_aux_aux(2)%matrix,admm_env%work_aux_aux%matrix_struct,name="taa",error=error) - CALL cp_fm_create(tmp_aux_nao(1)%matrix,admm_env%work_aux_orb%matrix_struct,name="tao",error=error) - CALL cp_fm_create(tmp_aux_nao(2)%matrix,admm_env%work_aux_orb%matrix_struct,name="tao",error=error) + CALL cp_fm_create(tmp_aux_aux(1)%matrix,admm_env%work_aux_aux%matrix_struct,name="taa") + CALL cp_fm_create(tmp_aux_aux(2)%matrix,admm_env%work_aux_aux%matrix_struct,name="taa") + CALL cp_fm_create(tmp_aux_nao(1)%matrix,admm_env%work_aux_orb%matrix_struct,name="tao") + CALL cp_fm_create(tmp_aux_nao(2)%matrix,admm_env%work_aux_orb%matrix_struct,name="tao") mstruct => admm_env%work_aux_nmo(ispin)%matrix%matrix_struct - CALL cp_fm_create(tmp_aux_mo(1)%matrix,mstruct,name="tam",error=error) - CALL cp_fm_create(tmp_aux_mo(2)%matrix,mstruct,name="tam",error=error) - CALL cp_fm_create(tmp_aux_mo1(1)%matrix,mstruct,name="tam",error=error) - CALL cp_fm_create(tmp_aux_mo1(2)%matrix,mstruct,name="tam",error=error) + CALL cp_fm_create(tmp_aux_mo(1)%matrix,mstruct,name="tam") + CALL cp_fm_create(tmp_aux_mo(2)%matrix,mstruct,name="tam") + CALL cp_fm_create(tmp_aux_mo1(1)%matrix,mstruct,name="tam") + CALL cp_fm_create(tmp_aux_mo1(2)%matrix,mstruct,name="tam") ! First calculate H=KS_aux*C~, real part ends on work_aux_aux2, imaginary part ends at work_aux_aux3 - CALL cp_dbcsr_sm_fm_multiply(KS_aux_re(ispin)%matrix,mos_admm(re)%matrix,tmp_aux_mo(re)%matrix,nmo,4.0_dp,0.0_dp,error) - CALL cp_dbcsr_sm_fm_multiply(KS_aux_re(ispin)%matrix,mos_admm(im)%matrix,tmp_aux_mo(im)%matrix,nmo,4.0_dp,0.0_dp,error) - CALL cp_dbcsr_sm_fm_multiply(KS_aux_im(ispin)%matrix,mos_admm(im)%matrix,tmp_aux_mo(re)%matrix,nmo,-4.0_dp,1.0_dp,error) - CALL cp_dbcsr_sm_fm_multiply(KS_aux_im(ispin)%matrix,mos_admm(re)%matrix,tmp_aux_mo(im)%matrix,nmo,4.0_dp,1.0_dp,error) + CALL cp_dbcsr_sm_fm_multiply(KS_aux_re(ispin)%matrix,mos_admm(re)%matrix,tmp_aux_mo(re)%matrix,nmo,4.0_dp,0.0_dp) + CALL cp_dbcsr_sm_fm_multiply(KS_aux_re(ispin)%matrix,mos_admm(im)%matrix,tmp_aux_mo(im)%matrix,nmo,4.0_dp,0.0_dp) + CALL cp_dbcsr_sm_fm_multiply(KS_aux_im(ispin)%matrix,mos_admm(im)%matrix,tmp_aux_mo(re)%matrix,nmo,-4.0_dp,1.0_dp) + CALL cp_dbcsr_sm_fm_multiply(KS_aux_im(ispin)%matrix,mos_admm(re)%matrix,tmp_aux_mo(im)%matrix,nmo,4.0_dp,1.0_dp) ! Next step compute S-1*H - CALL cp_gemm('N','N',naux,nmo,naux,1.0_dp,admm_env%S_inv,tmp_aux_mo(re)%matrix,0.0_dp,tmp_aux_mo1(re)%matrix,error) - CALL cp_gemm('N','N',naux,nmo,naux,1.0_dp,admm_env%S_inv,tmp_aux_mo(im)%matrix,0.0_dp,tmp_aux_mo1(im)%matrix,error) + CALL cp_gemm('N','N',naux,nmo,naux,1.0_dp,admm_env%S_inv,tmp_aux_mo(re)%matrix,0.0_dp,tmp_aux_mo1(re)%matrix) + CALL cp_gemm('N','N',naux,nmo,naux,1.0_dp,admm_env%S_inv,tmp_aux_mo(im)%matrix,0.0_dp,tmp_aux_mo1(im)%matrix) ! Here we go on with Ws=S-1*H * C^H (take care of sign of the imaginary part!!!) CALL cp_gemm("N","T",naux,nao,nmo,-1.0_dp,tmp_aux_mo1(re)%matrix, mos(re)%matrix, 0.0_dp,& - tmp_aux_nao(re)%matrix, error) + tmp_aux_nao(re)%matrix) CALL cp_gemm("N","T",naux,nao,nmo,-1.0_dp,tmp_aux_mo1(im)%matrix, mos(im)%matrix, 1.0_dp,& - tmp_aux_nao(re)%matrix, error) + tmp_aux_nao(re)%matrix) CALL cp_gemm("N","T",naux,nao,nmo,1.0_dp,tmp_aux_mo1(re)%matrix, mos(im)%matrix, 0.0_dp,& - tmp_aux_nao(im)%matrix, error) + tmp_aux_nao(im)%matrix) CALL cp_gemm("N","T",naux,nao,nmo,-1.0_dp,tmp_aux_mo1(im)%matrix, mos(re)%matrix, 1.0_dp,& - tmp_aux_nao(im)%matrix, error) + tmp_aux_nao(im)%matrix) ! Let's do the final bit Wq=S-1*H * C^H * A^T - CALL cp_gemm('N','T',naux,naux,nao,-1.0_dp,tmp_aux_nao(re)%matrix,admm_env%A,0.0_dp,tmp_aux_aux(re)%matrix,error) - CALL cp_gemm('N','T',naux,naux,nao,-1.0_dp,tmp_aux_nao(im)%matrix,admm_env%A,0.0_dp,tmp_aux_aux(im)%matrix,error) + CALL cp_gemm('N','T',naux,naux,nao,-1.0_dp,tmp_aux_nao(re)%matrix,admm_env%A,0.0_dp,tmp_aux_aux(re)%matrix) + CALL cp_gemm('N','T',naux,naux,nao,-1.0_dp,tmp_aux_nao(im)%matrix,admm_env%A,0.0_dp,tmp_aux_aux(im)%matrix) ! *** copy to sparse matrix - CALL copy_fm_to_dbcsr(tmp_aux_nao(re)%matrix, matrix_w_q,keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(tmp_aux_nao(re)%matrix, matrix_w_q,keep_sparsity=.TRUE.) ! *** copy to sparse matrix - CALL copy_fm_to_dbcsr(tmp_aux_aux(re)%matrix, matrix_w_s,keep_sparsity=.TRUE.,& - error=error) + CALL copy_fm_to_dbcsr(tmp_aux_aux(re)%matrix, matrix_w_s,keep_sparsity=.TRUE.) ! *** This can be done in one call w_total = w_alpha + w_beta ! allocate force vector - CALL get_qs_env(qs_env=qs_env,natom=natom,error=error) + CALL get_qs_env(qs_env=qs_env,natom=natom) ALLOCATE(admm_force(3,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) admm_force = 0.0_dp CALL build_overlap_force(ks_env, admm_force,& basis_type_a="AUX_FIT", basis_type_b="AUX_FIT", & - sab_nl=sab_aux_fit_asymm, matrix_p=matrix_w_s, error=error) + sab_nl=sab_aux_fit_asymm, matrix_p=matrix_w_s) CALL build_overlap_force(ks_env, admm_force,& basis_type_a="AUX_FIT", basis_type_b="ORB", & - sab_nl=sab_aux_fit_vs_orb, matrix_p=matrix_w_q, error=error) + sab_nl=sab_aux_fit_vs_orb, matrix_p=matrix_w_q) ! add forces CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,& - force=force,error=error) - CALL add_qs_force(admm_force, force, "overlap_admm", atomic_kind_set, error) + force=force) + CALL add_qs_force(admm_force, force, "overlap_admm", atomic_kind_set) DEALLOCATE(admm_force,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! *** Deallocated weighted density matrices - CALL cp_dbcsr_deallocate_matrix(matrix_w_s,error) - CALL cp_dbcsr_deallocate_matrix(matrix_w_q,error) - CALL cp_fm_vect_dealloc(tmp_aux_aux,error) - CALL cp_fm_vect_dealloc(tmp_aux_nao,error) - CALL cp_fm_vect_dealloc(tmp_aux_mo,error) - CALL cp_fm_vect_dealloc(tmp_aux_mo1,error) + CALL cp_dbcsr_deallocate_matrix(matrix_w_s) + CALL cp_dbcsr_deallocate_matrix(matrix_w_q) + CALL cp_fm_vect_dealloc(tmp_aux_aux) + CALL cp_fm_vect_dealloc(tmp_aux_nao) + CALL cp_fm_vect_dealloc(tmp_aux_mo) + CALL cp_fm_vect_dealloc(tmp_aux_mo1) END DO END SUBROUTINE rt_admm_forces_none diff --git a/src/rt_propagation_types.F b/src/rt_propagation_types.F index bbdbc458e5..b9b225f820 100644 --- a/src/rt_propagation_types.F +++ b/src/rt_propagation_types.F @@ -137,9 +137,8 @@ MODULE rt_propagation_types !> \param template ... !> \param linear_scaling ... !> \param mos_aux ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rt_prop_create(rtp,mos,mpools,dft_control,template,linear_scaling,mos_aux,error) + SUBROUTINE rt_prop_create(rtp,mos,mpools,dft_control,template,linear_scaling,mos_aux) TYPE(rt_prop_type), POINTER :: rtp TYPE(mo_set_p_type), DIMENSION(:), & @@ -150,7 +149,6 @@ SUBROUTINE rt_prop_create(rtp,mos,mpools,dft_control,template,linear_scaling,mos LOGICAL :: linear_scaling TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos_aux - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_prop_create', & routineP = moduleN//':'//routineN @@ -177,47 +175,44 @@ SUBROUTINE rt_prop_create(rtp,mos,mpools,dft_control,template,linear_scaling,mos IF(rtp%linear_scaling) THEN ALLOCATE(rtp%rho,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(rtp%rho%old) - CALL cp_dbcsr_allocate_matrix_set(rtp%rho%old,2*nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(rtp%rho%old,2*nspin) NULLIFY(rtp%rho%next) - CALL cp_dbcsr_allocate_matrix_set(rtp%rho%next,2*nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(rtp%rho%next,2*nspin) NULLIFY(rtp%rho%new) - CALL cp_dbcsr_allocate_matrix_set(rtp%rho%new,2*nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(rtp%rho%new,2*nspin) DO i=1,2*nspin - CALL cp_dbcsr_init_p(rtp%rho%old(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%rho%old(i)%matrix,template=template,matrix_type="N",error=error) - CALL cp_dbcsr_init_p(rtp%rho%next(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%rho%next(i)%matrix,template=template,matrix_type="N",error=error) - CALL cp_dbcsr_init_p(rtp%rho%new(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%rho%new(i)%matrix,template=template,matrix_type="N",error=error) + CALL cp_dbcsr_init_p(rtp%rho%old(i)%matrix) + CALL cp_dbcsr_create(rtp%rho%old(i)%matrix,template=template,matrix_type="N") + CALL cp_dbcsr_init_p(rtp%rho%next(i)%matrix) + CALL cp_dbcsr_create(rtp%rho%next(i)%matrix,template=template,matrix_type="N") + CALL cp_dbcsr_init_p(rtp%rho%new(i)%matrix) + CALL cp_dbcsr_create(rtp%rho%new(i)%matrix,template=template,matrix_type="N") END DO ELSE - CALL mpools_get(mpools, ao_mo_fm_pools=ao_mo_fm_pools,& - error=error) + CALL mpools_get(mpools, ao_mo_fm_pools=ao_mo_fm_pools) - ao_mo_fmstruct => fm_pool_get_el_struct(ao_mo_fm_pools(1)%pool,& - error=error) - CALL cp_fm_struct_get(ao_mo_fmstruct, nrow_block=nrow_block,& - error=error) + ao_mo_fmstruct => fm_pool_get_el_struct(ao_mo_fm_pools(1)%pool) + CALL cp_fm_struct_get(ao_mo_fmstruct, nrow_block=nrow_block) CALL get_mo_set(mos(1)%mo_set,nao=nao) CALL cp_fm_struct_create(fmstruct=rtp%ao_ao_fmstruct,& nrow_block=nrow_block,ncol_block=nrow_block,& nrow_global=nao, ncol_global=nao,& - template_fmstruct=ao_mo_fmstruct, error=error) + template_fmstruct=ao_mo_fmstruct) ALLOCATE(rtp%mos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rtp%mos%old(2*nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rtp%mos%new(2*nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rtp%mos%next(2*nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(rtp%mos%admm) IF(dft_control%do_admm)THEN ALLOCATE(rtp%mos%admm(2*nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DO i=1,nspin DO j=1,2 @@ -226,22 +221,18 @@ SUBROUTINE rt_prop_create(rtp,mos,mpools,dft_control,template,linear_scaling,mos NULLIFY(rtp%mos%next(2*(i-1)+j)%matrix) CALL cp_fm_create(rtp%mos%old(2*(i-1)+j)%matrix,& matrix_struct=mos(i)%mo_set%mo_coeff%matrix_struct,& - name="mos_old"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j))),& - error=error) + name="mos_old"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j)))) CALL cp_fm_create(rtp%mos%new(2*(i-1)+j)%matrix,& matrix_struct=mos(i)%mo_set%mo_coeff%matrix_struct,& - name="mos_new"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j))),& - error=error) + name="mos_new"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j)))) CALL cp_fm_create(rtp%mos%next(2*(i-1)+j)%matrix,& matrix_struct=mos(i)%mo_set%mo_coeff%matrix_struct,& - name="mos_next"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j))),& - error=error) + name="mos_next"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j)))) IF(dft_control%do_admm)THEN NULLIFY(rtp%mos%admm(2*(i-1)+j)%matrix) CALL cp_fm_create(rtp%mos%admm(2*(i-1)+j)%matrix,& matrix_struct=mos_aux(i)%mo_set%mo_coeff%matrix_struct,& - name="mos_admm"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j))),& - error=error) + name="mos_admm"//TRIM(ADJUSTL(cp_to_string(2*(i-1)+j)))) END IF END DO END DO @@ -252,35 +243,35 @@ SUBROUTINE rt_prop_create(rtp,mos,mpools,dft_control,template,linear_scaling,mos NULLIFY(rtp%exp_H_new) NULLIFY(rtp%H_last_iter) NULLIFY(rtp%propagator_matrix) - CALL cp_dbcsr_allocate_matrix_set(rtp%exp_H_old,2*nspin,error=error) - CALL cp_dbcsr_allocate_matrix_set(rtp%exp_H_new,2*nspin,error=error) - CALL cp_dbcsr_allocate_matrix_set(rtp%H_last_iter,2*nspin,error=error) - CALL cp_dbcsr_allocate_matrix_set(rtp%propagator_matrix,2*nspin,error=error) + CALL cp_dbcsr_allocate_matrix_set(rtp%exp_H_old,2*nspin) + CALL cp_dbcsr_allocate_matrix_set(rtp%exp_H_new,2*nspin) + CALL cp_dbcsr_allocate_matrix_set(rtp%H_last_iter,2*nspin) + CALL cp_dbcsr_allocate_matrix_set(rtp%propagator_matrix,2*nspin) DO i=1,2*nspin - CALL cp_dbcsr_init_p(rtp%exp_H_old(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%exp_H_old(i)%matrix,template=template,matrix_type="N",error=error) - CALL cp_dbcsr_init_p(rtp%exp_H_new(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%exp_H_new(i)%matrix,template=template,matrix_type="N",error=error) - CALL cp_dbcsr_init_p(rtp%H_last_iter(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%H_last_iter(i)%matrix,template=template,matrix_type="N",error=error) - CALL cp_dbcsr_init_p(rtp%propagator_matrix(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%propagator_matrix(i)%matrix,template=template,matrix_type="N",error=error) + CALL cp_dbcsr_init_p(rtp%exp_H_old(i)%matrix) + CALL cp_dbcsr_create(rtp%exp_H_old(i)%matrix,template=template,matrix_type="N") + CALL cp_dbcsr_init_p(rtp%exp_H_new(i)%matrix) + CALL cp_dbcsr_create(rtp%exp_H_new(i)%matrix,template=template,matrix_type="N") + CALL cp_dbcsr_init_p(rtp%H_last_iter(i)%matrix) + CALL cp_dbcsr_create(rtp%H_last_iter(i)%matrix,template=template,matrix_type="N") + CALL cp_dbcsr_init_p(rtp%propagator_matrix(i)%matrix) + CALL cp_dbcsr_create(rtp%propagator_matrix(i)%matrix,template=template,matrix_type="N") END DO NULLIFY(rtp%S_inv) ALLOCATE(rtp%S_inv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(rtp%S_inv,error=error) - CALL cp_dbcsr_create(rtp%S_inv,template=template,matrix_type="S",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(rtp%S_inv) + CALL cp_dbcsr_create(rtp%S_inv,template=template,matrix_type="S") NULLIFY(rtp%S_half) ALLOCATE(rtp%S_half,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(rtp%S_half,error=error) - CALL cp_dbcsr_create(rtp%S_half,template=template,matrix_type="S",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(rtp%S_half) + CALL cp_dbcsr_create(rtp%S_half,template=template,matrix_type="S") NULLIFY(rtp%S_minus_half) ALLOCATE(rtp%S_minus_half,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(rtp%S_minus_half,error=error) - CALL cp_dbcsr_create(rtp%S_minus_half,template=template,matrix_type="S",error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(rtp%S_minus_half) + CALL cp_dbcsr_create(rtp%S_minus_half,template=template,matrix_type="S") NULLIFY(rtp%B_mat) NULLIFY(rtp%C_mat) NULLIFY(rtp%S_der) @@ -288,30 +279,30 @@ SUBROUTINE rt_prop_create(rtp,mos,mpools,dft_control,template,linear_scaling,mos NULLIFY(rtp%SinvB) IF(.NOT.rtp_control%fixed_ions)THEN ALLOCATE(rtp%B_mat,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(rtp%B_mat,error=error) - CALL cp_dbcsr_create(rtp%B_mat,template=template,matrix_type="N",error=error) - CALL cp_dbcsr_allocate_matrix_set(rtp%C_mat,3,error=error) - CALL cp_dbcsr_allocate_matrix_set(rtp%S_der,9,error=error) - CALL cp_dbcsr_allocate_matrix_set(rtp%SinvH,nspin,error=error) - CALL cp_dbcsr_allocate_matrix_set(rtp%SinvB,nspin,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(rtp%B_mat) + CALL cp_dbcsr_create(rtp%B_mat,template=template,matrix_type="N") + CALL cp_dbcsr_allocate_matrix_set(rtp%C_mat,3) + CALL cp_dbcsr_allocate_matrix_set(rtp%S_der,9) + CALL cp_dbcsr_allocate_matrix_set(rtp%SinvH,nspin) + CALL cp_dbcsr_allocate_matrix_set(rtp%SinvB,nspin) DO i=1,nspin - CALL cp_dbcsr_init_p(rtp%SinvH(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%SinvH(i)%matrix,template=template,matrix_type="N",error=error) - CALL cp_dbcsr_init_p(rtp%SinvB(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%SinvB(i)%matrix,template=template,matrix_type="N",error=error) + CALL cp_dbcsr_init_p(rtp%SinvH(i)%matrix) + CALL cp_dbcsr_create(rtp%SinvH(i)%matrix,template=template,matrix_type="N") + CALL cp_dbcsr_init_p(rtp%SinvB(i)%matrix) + CALL cp_dbcsr_create(rtp%SinvB(i)%matrix,template=template,matrix_type="N") END DO DO i=1,3 - CALL cp_dbcsr_init_p(rtp%C_mat(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%C_mat(i)%matrix,template=template,matrix_type="N",error=error) + CALL cp_dbcsr_init_p(rtp%C_mat(i)%matrix) + CALL cp_dbcsr_create(rtp%C_mat(i)%matrix,template=template,matrix_type="N") END DO DO i=1,9 - CALL cp_dbcsr_init_p(rtp%S_der(i)%matrix,error=error) - CALL cp_dbcsr_create(rtp%S_der(i)%matrix,template=template,matrix_type="N",error=error) + CALL cp_dbcsr_init_p(rtp%S_der(i)%matrix) + CALL cp_dbcsr_create(rtp%S_der(i)%matrix,template=template,matrix_type="N") END DO END IF ALLOCATE(rtp%orders(2,nspin),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rtp_control%converged=.FALSE. rtp%matrix_update=.TRUE. rtp%narn_old=0 @@ -349,11 +340,10 @@ END SUBROUTINE rt_prop_create !> \param SinvH ... !> \param SinvB ... !> \param admm_mos ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_rtp(rtp,exp_H_old,exp_H_new,H_last_iter,rho_old,rho_next,rho_new,mos,mos_new,mos_old,mos_next,& S_inv,S_half,S_minus_half,B_mat,C_mat,propagator_matrix,mixing,mixing_factor,& - S_der,dt,nsteps,SinvH,SinvB,admm_mos,error) + S_der,dt,nsteps,SinvH,SinvB,admm_mos) TYPE(rt_prop_type), POINTER :: rtp TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -377,7 +367,6 @@ SUBROUTINE get_rtp(rtp,exp_H_old,exp_H_new,H_last_iter,rho_old,rho_next,rho_new, OPTIONAL, POINTER :: SinvH, SinvB TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: admm_mos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_rtp', & routineP = moduleN//':'//routineN @@ -386,7 +375,7 @@ SUBROUTINE get_rtp(rtp,exp_H_old,exp_H_new,H_last_iter,rho_old,rho_next,rho_new, failure=.FALSE. - CPPrecondition(ASSOCIATED(rtp),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rtp),cp_failure_level,routineP,failure) IF (PRESENT(exp_H_old))exp_H_old=>rtp%exp_H_old IF (PRESENT(exp_H_new))exp_H_new=>rtp%exp_H_new IF (PRESENT(H_last_iter))H_last_iter=>rtp%H_last_iter @@ -420,11 +409,9 @@ END SUBROUTINE get_rtp ! ***************************************************************************** !> \brief ... !> \param rtp ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rt_prop_release(rtp,error) + SUBROUTINE rt_prop_release(rtp) TYPE(rt_prop_type), INTENT(inout) :: rtp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rt_prop_release', & routineP = moduleN//':'//routineN @@ -435,62 +422,60 @@ SUBROUTINE rt_prop_release(rtp,error) failure=.FALSE. - CALL cp_dbcsr_deallocate_matrix_set(rtp%exp_H_old,error) - CALL cp_dbcsr_deallocate_matrix_set(rtp%exp_H_new,error) - CALL cp_dbcsr_deallocate_matrix_set(rtp%H_last_iter,error) - CALL cp_dbcsr_deallocate_matrix_set(rtp%propagator_matrix,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%exp_H_old) + CALL cp_dbcsr_deallocate_matrix_set(rtp%exp_H_new) + CALL cp_dbcsr_deallocate_matrix_set(rtp%H_last_iter) + CALL cp_dbcsr_deallocate_matrix_set(rtp%propagator_matrix) IF(ASSOCIATED(rtp%rho)) THEN IF(ASSOCIATED(rtp%rho%old))& - CALL cp_dbcsr_deallocate_matrix_set(rtp%rho%old,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%rho%old) IF(ASSOCIATED(rtp%rho%next))& - CALL cp_dbcsr_deallocate_matrix_set(rtp%rho%next,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%rho%next) IF(ASSOCIATED(rtp%rho%new))& - CALL cp_dbcsr_deallocate_matrix_set(rtp%rho%new,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%rho%new) DEALLOCATE(rtp%rho,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF(ASSOCIATED(rtp%mos)) THEN IF(ASSOCIATED(rtp%mos%old))& - CALL cp_fm_vect_dealloc(rtp%mos%old,error) + CALL cp_fm_vect_dealloc(rtp%mos%old) IF(ASSOCIATED(rtp%mos%new))& - CALL cp_fm_vect_dealloc(rtp%mos%new,error) + CALL cp_fm_vect_dealloc(rtp%mos%new) IF(ASSOCIATED(rtp%mos%next))& - CALL cp_fm_vect_dealloc(rtp%mos%next,error) + CALL cp_fm_vect_dealloc(rtp%mos%next) IF(ASSOCIATED(rtp%mos%admm))& - CALL cp_fm_vect_dealloc(rtp%mos%admm,error) + CALL cp_fm_vect_dealloc(rtp%mos%admm) DEALLOCATE(rtp%mos,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL cp_dbcsr_deallocate_matrix(rtp%S_inv,error) - CALL cp_dbcsr_deallocate_matrix(rtp%S_half,error) - CALL cp_dbcsr_deallocate_matrix(rtp%S_minus_half,error) + CALL cp_dbcsr_deallocate_matrix(rtp%S_inv) + CALL cp_dbcsr_deallocate_matrix(rtp%S_half) + CALL cp_dbcsr_deallocate_matrix(rtp%S_minus_half) IF(ASSOCIATED(rtp%B_mat))& - CALL cp_dbcsr_deallocate_matrix(rtp%B_mat,error) + CALL cp_dbcsr_deallocate_matrix(rtp%B_mat) IF(ASSOCIATED(rtp%C_mat))& - CALL cp_dbcsr_deallocate_matrix_set(rtp%C_mat,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%C_mat) IF(ASSOCIATED(rtp%S_der))& - CALL cp_dbcsr_deallocate_matrix_set(rtp%S_der,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%S_der) IF(ASSOCIATED(rtp%SinvH))& - CALL cp_dbcsr_deallocate_matrix_set(rtp%SinvH,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%SinvH) IF(ASSOCIATED(rtp%SinvB))& - CALL cp_dbcsr_deallocate_matrix_set(rtp%SinvB,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%SinvB) IF(ASSOCIATED(rtp%history))& - CALL rtp_history_release(rtp,error) + CALL rtp_history_release(rtp) DEALLOCATE(rtp%orders,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - IF(.NOT.rtp%linear_scaling) CALL cp_fm_struct_release(rtp%ao_ao_fmstruct,error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + IF(.NOT.rtp%linear_scaling) CALL cp_fm_struct_release(rtp%ao_ao_fmstruct) END SUBROUTINE rt_prop_release ! ***************************************************************************** !> \brief ... !> \param rtp ... !> \param aspc_order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rtp_history_create(rtp,aspc_order,error) + SUBROUTINE rtp_history_create(rtp,aspc_order) TYPE(rt_prop_type), INTENT(inout) :: rtp INTEGER, INTENT(in) :: aspc_order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rtp_history_create', & routineP = moduleN//':'//routineN @@ -503,37 +488,36 @@ SUBROUTINE rtp_history_create(rtp,aspc_order,error) NULLIFY(history) ALLOCATE(rtp%history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) history=> rtp%history NULLIFY(history%rho_history,history%mo_history,history%s_history) IF(aspc_order.GT.0)THEN IF(rtp%linear_scaling)THEN nmat=SIZE(rtp%rho%new) - CALL cp_dbcsr_allocate_matrix_set(history%rho_history,nmat,aspc_order,error=error) + CALL cp_dbcsr_allocate_matrix_set(history%rho_history,nmat,aspc_order) DO i=1,nmat DO j=1,aspc_order - CALL cp_dbcsr_init_p(history%rho_history(i,j)%matrix,error=error) + CALL cp_dbcsr_init_p(history%rho_history(i,j)%matrix) CALL cp_dbcsr_create(history%rho_history(i,j)%matrix,& name="rho_hist"//TRIM(ADJUSTL(cp_to_string(i))),& - template=rtp%rho%new(1)%matrix,error=error) + template=rtp%rho%new(1)%matrix) END DO END DO ELSE nmat=SIZE(rtp%mos%old) ALLOCATE(history%mo_history(nmat,aspc_order),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,nmat DO j=1,aspc_order NULLIFY(history%mo_history(i,j)%matrix) CALL cp_fm_create(history%mo_history(i,j)%matrix,& matrix_struct=rtp%mos%new(i)%matrix%matrix_struct,& - name="mo_hist"//TRIM(ADJUSTL(cp_to_string(i))),& - error=error) + name="mo_hist"//TRIM(ADJUSTL(cp_to_string(i)))) END DO END DO ALLOCATE(history%s_history(aspc_order),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,aspc_order NULLIFY(history%s_history(i)%matrix) END DO @@ -547,11 +531,9 @@ END SUBROUTINE rtp_history_create ! ***************************************************************************** !> \brief ... !> \param rtp ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rtp_history_release(rtp,error) + SUBROUTINE rtp_history_release(rtp) TYPE(rt_prop_type), INTENT(inout) :: rtp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rtp_history_release', & routineP = moduleN//':'//routineN @@ -562,28 +544,28 @@ SUBROUTINE rtp_history_release(rtp,error) failure=.FALSE. IF (ASSOCIATED(rtp%history%rho_history)) THEN - CALL cp_dbcsr_deallocate_matrix_set(rtp%history%rho_history,error) + CALL cp_dbcsr_deallocate_matrix_set(rtp%history%rho_history) END IF IF (ASSOCIATED(rtp%history%mo_history)) THEN DO i=1,SIZE(rtp%history%mo_history,1) DO j=1,SIZE(rtp%history%mo_history,2) - CALL cp_fm_release(rtp%history%mo_history(i,j)%matrix,error=error) + CALL cp_fm_release(rtp%history%mo_history(i,j)%matrix) END DO END DO DEALLOCATE(rtp%history%mo_history,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(rtp%history%s_history)) THEN DO i=1,SIZE(rtp%history%s_history) IF (ASSOCIATED(rtp%history%s_history(i)%matrix))& - CALL cp_dbcsr_deallocate_matrix(rtp%history%s_history(i)%matrix,error=error) + CALL cp_dbcsr_deallocate_matrix(rtp%history%s_history(i)%matrix) END DO DEALLOCATE(rtp%history%s_history,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF DEALLOCATE(rtp%history,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE rtp_history_release diff --git a/src/rtp_admm_methods.F b/src/rtp_admm_methods.F index 1971faafe0..67737b388e 100644 --- a/src/rtp_admm_methods.F +++ b/src/rtp_admm_methods.F @@ -75,13 +75,11 @@ MODULE rtp_admm_methods !> \brief Compute the ADMM density matrix in case of rtp (complex MO's) !> !> \param qs_env ... -!> \param error ... !> \par History ! ***************************************************************************** - SUBROUTINE rtp_admm_calc_rho_aux(qs_env,error) + SUBROUTINE rtp_admm_calc_rho_aux(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rtp_admm_calc_rho_aux', & routineP = moduleN//':'//routineN @@ -124,16 +122,15 @@ SUBROUTINE rtp_admm_calc_rho_aux(qs_env,error) rtp=rtp,& rho=rho,& rho_aux_fit=rho_aux_fit,& - s_mstruct_changed=s_mstruct_changed,& - error=error) + s_mstruct_changed=s_mstruct_changed) nspins = dft_control%nspins - CALL get_rtp(rtp=rtp,admm_mos=rtp_coeff_aux_fit,error=error) + CALL get_rtp(rtp=rtp,admm_mos=rtp_coeff_aux_fit) CALL rtp_admm_fit_mo_coeffs(qs_env, admm_env, dft_control%admm_control, para_env, & matrix_s_aux_fit, matrix_s_aux_fit_vs_orb,& mos, mos_aux_fit,rtp,rtp_coeff_aux_fit,& - s_mstruct_changed, error=error) + s_mstruct_changed) DO ispin=1,nspins CALL qs_rho_get(rho_aux_fit,& @@ -141,24 +138,22 @@ SUBROUTINE rtp_admm_calc_rho_aux(qs_env,error) rho_ao_im=matrix_p_aux_im,& rho_r=rho_r_aux,& rho_g=rho_g_aux,& - tot_rho_r=tot_rho_r_aux,& - error=error) + tot_rho_r=tot_rho_r_aux) CALL rtp_admm_calculate_dm(admm_env,rtp_coeff_aux_fit,& matrix_p_aux(ispin)%matrix,& matrix_p_aux_im(ispin)%matrix,& - ispin,error) + ispin) CALL calculate_rho_elec(matrix_p=matrix_p_aux(ispin)%matrix,& rho=rho_r_aux(ispin),& rho_gspace=rho_g_aux(ispin),& total_rho=tot_rho_r_aux(ispin),& ks_env=ks_env,soft_valid=.FALSE.,& - basis_type="AUX_FIT",& - error=error) + basis_type="AUX_FIT") END DO - CALL set_qs_env(qs_env,admm_env=admm_env,error=error) - CALL qs_rho_set(rho_aux_fit, rho_r_valid=.TRUE., rho_g_valid=.TRUE., error=error) + CALL set_qs_env(qs_env,admm_env=admm_env) + CALL qs_rho_set(rho_aux_fit, rho_r_valid=.TRUE., rho_g_valid=.TRUE.) CALL timestop(handle) @@ -171,17 +166,15 @@ END SUBROUTINE rtp_admm_calc_rho_aux !> \param density_matrix_aux ... !> \param density_matrix_aux_im ... !> \param ispin ... -!> \param error ... ! ***************************************************************************** SUBROUTINE rtp_admm_calculate_dm(admm_env,rtp_coeff_aux_fit, density_matrix_aux,& - density_matrix_aux_im, ispin,error) + density_matrix_aux_im, ispin) TYPE(admm_type), POINTER :: admm_env TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: rtp_coeff_aux_fit TYPE(cp_dbcsr_type), POINTER :: density_matrix_aux, & density_matrix_aux_im INTEGER, INTENT(in) :: ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rtp_admm_calculate_dm', & routineP = moduleN//':'//routineN @@ -196,7 +189,7 @@ SUBROUTINE rtp_admm_calculate_dm(admm_env,rtp_coeff_aux_fit, density_matrix_aux, SELECT CASE(admm_env%purification_method) CASE(do_admm_purify_none) CALL calculate_rtp_admm_density(density_matrix_aux,density_matrix_aux_im,& - rtp_coeff_aux_fit,ispin,error) + rtp_coeff_aux_fit,ispin) CASE DEFAULT CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "only purification NONE possible with RTP/EMD at the moment"//& @@ -221,10 +214,9 @@ END SUBROUTINE rtp_admm_calculate_dm !> \param rtp ... !> \param rtp_coeff_aux_fit ... !> \param geometry_did_change ... -!> \param error ... ! ***************************************************************************** SUBROUTINE rtp_admm_fit_mo_coeffs(qs_env, admm_env, admm_control, para_env, matrix_s_aux_fit, matrix_s_mixed, & - mos, mos_aux_fit,rtp,rtp_coeff_aux_fit, geometry_did_change, error) + mos, mos_aux_fit,rtp,rtp_coeff_aux_fit, geometry_did_change) TYPE(qs_environment_type), POINTER :: qs_env TYPE(admm_type), POINTER :: admm_env @@ -239,7 +231,6 @@ SUBROUTINE rtp_admm_fit_mo_coeffs(qs_env, admm_env, admm_control, para_env, matr TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: rtp_coeff_aux_fit LOGICAL, INTENT(IN) :: geometry_did_change - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rtp_admm_fit_mo_coeffs', & routineP = moduleN//':'//routineN @@ -256,13 +247,13 @@ SUBROUTINE rtp_admm_fit_mo_coeffs(qs_env, admm_env, admm_control, para_env, matr IF (.NOT.(ASSOCIATED(admm_env) )) THEN ! setup admm environment - CALL get_qs_env(qs_env, input=input, particle_set=particle_set, error=error) + CALL get_qs_env(qs_env, input=input, particle_set=particle_set) natoms = SIZE(particle_set,1) CALL admm_env_create(admm_env, admm_control, mos, mos_aux_fit, & - para_env, natoms, error) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + para_env, natoms) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") CALL create_admm_xc_section(qs_env=qs_env, xc_section=xc_section, & - admm_env=admm_env, error=error) + admm_env=admm_env) IF(admm_control%method /= do_admm_basis_projection) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& @@ -276,7 +267,7 @@ SUBROUTINE rtp_admm_fit_mo_coeffs(qs_env, admm_env, admm_control, para_env, matr SELECT CASE(admm_env%purification_method) CASE(do_admm_purify_none) CALL rtp_fit_mo_coeffs_none(qs_env, admm_env, para_env, matrix_s_aux_fit, matrix_s_mixed, & - mos, mos_aux_fit,rtp,rtp_coeff_aux_fit,recalc_S , error) + mos, mos_aux_fit,rtp,rtp_coeff_aux_fit,recalc_S) CASE DEFAULT CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "Purification method not implemented in combination with RTP"//& @@ -302,13 +293,12 @@ END SUBROUTINE rtp_admm_fit_mo_coeffs !> \param rtp ... !> \param rtp_coeff_aux_fit ... !> \param geometry_did_change flag to indicate if the geomtry changed -!> \param error ... !> \par History !> 05.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE rtp_fit_mo_coeffs_none(qs_env, admm_env, para_env, matrix_s_aux_fit, matrix_s_mixed, & - mos, mos_aux_fit,rtp,rtp_coeff_aux_fit, geometry_did_change, error) + mos, mos_aux_fit,rtp,rtp_coeff_aux_fit, geometry_did_change) TYPE(qs_environment_type), POINTER :: qs_env TYPE(admm_type), POINTER :: admm_env @@ -322,7 +312,6 @@ SUBROUTINE rtp_fit_mo_coeffs_none(qs_env, admm_env, para_env, matrix_s_aux_fit, TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: rtp_coeff_aux_fit LOGICAL, INTENT(IN) :: geometry_did_change - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rtp_fit_mo_coeffs_none', & routineP = moduleN//':'//routineN @@ -344,12 +333,12 @@ SUBROUTINE rtp_fit_mo_coeffs_none(qs_env, admm_env, para_env, matrix_s_aux_fit, NULLIFY(dft_control, particle_set) IF (.NOT.(ASSOCIATED(admm_env) )) THEN - CALL get_qs_env(qs_env,input=input,particle_set=particle_set,dft_control=dft_control,error=error) + CALL get_qs_env(qs_env,input=input,particle_set=particle_set,dft_control=dft_control) natoms = SIZE(particle_set,1) - CALL admm_env_create(admm_env, dft_control%admm_control, mos, mos_aux_fit, para_env, natoms, error) - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + CALL admm_env_create(admm_env, dft_control%admm_control, mos, mos_aux_fit, para_env, natoms) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") CALL create_admm_xc_section(qs_env=qs_env, xc_section=xc_section, & - admm_env=admm_env,error=error) + admm_env=admm_env) END IF nao_aux_fit = admm_env%nao_aux_fit @@ -360,21 +349,21 @@ SUBROUTINE rtp_fit_mo_coeffs_none(qs_env, admm_env, para_env, matrix_s_aux_fit, ! *** This part only depends on overlap matrices ==> needs only to be calculated if the geometry changed IF( geometry_did_change ) THEN - CALL copy_dbcsr_to_fm(matrix_s_aux_fit(1)%matrix,admm_env%S_inv,error) - CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux,error=error) - CALL cp_fm_to_fm(admm_env%S_inv, admm_env%S, error=error) + CALL copy_dbcsr_to_fm(matrix_s_aux_fit(1)%matrix,admm_env%S_inv) + CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux) + CALL cp_fm_to_fm(admm_env%S_inv, admm_env%S) - CALL copy_dbcsr_to_fm(matrix_s_mixed(1)%matrix,admm_env%Q,error) + CALL copy_dbcsr_to_fm(matrix_s_mixed(1)%matrix,admm_env%Q) !! Calculate S'_inverse - CALL cp_fm_cholesky_decompose(admm_env%S_inv,error=error) - CALL cp_fm_cholesky_invert(admm_env%S_inv,error=error) + CALL cp_fm_cholesky_decompose(admm_env%S_inv) + CALL cp_fm_cholesky_invert(admm_env%S_inv) !! Symmetrize the guy - CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux,error=error) + CALL cp_fm_upper_to_full(admm_env%S_inv,admm_env%work_aux_aux) !! Calculate A=S'^(-1)*P CALL cp_gemm('N','N',nao_aux_fit,nao_orb,nao_aux_fit,& 1.0_dp,admm_env%S_inv,admm_env%Q,0.0_dp,& - admm_env%A,error) + admm_env%A) END IF ! *** Calculate the mo_coeffs for the fitting basis @@ -382,19 +371,19 @@ SUBROUTINE rtp_fit_mo_coeffs_none(qs_env, admm_env, para_env, matrix_s_aux_fit, nmo = admm_env%nmo(ispin) IF( nmo == 0 ) CYCLE !! Lambda = C^(T)*B*C - CALL get_rtp (rtp=rtp,mos_new=mos_new,error=error) + CALL get_rtp (rtp=rtp,mos_new=mos_new) CALL get_mo_set(mos(ispin)%mo_set,mo_coeff=mo_coeff, occupation_numbers=occ_num,nmo=nmo_mos) CALL get_mo_set(mos_aux_fit(ispin)%mo_set,mo_coeff=mo_coeff_aux_fit,& occupation_numbers=occ_num_aux) CALL cp_gemm('N','N',nao_aux_fit,nmo,nao_orb,& 1.0_dp,admm_env%A,mos_new(2*ispin-1)%matrix,0.0_dp,& - rtp_coeff_aux_fit(2*ispin-1)%matrix,error) + rtp_coeff_aux_fit(2*ispin-1)%matrix) CALL cp_gemm('N','N',nao_aux_fit,nmo,nao_orb,& 1.0_dp,admm_env%A,mos_new(2*ispin)%matrix,0.0_dp,& - rtp_coeff_aux_fit(2*ispin)%matrix,error) + rtp_coeff_aux_fit(2*ispin)%matrix) - CALL cp_fm_to_fm(rtp_coeff_aux_fit(2*ispin-1)%matrix,mo_coeff_aux_fit,error) + CALL cp_fm_to_fm(rtp_coeff_aux_fit(2*ispin-1)%matrix,mo_coeff_aux_fit) END DO CALL timestop(handle) @@ -408,17 +397,15 @@ END SUBROUTINE rtp_fit_mo_coeffs_none !> \param density_matrix_aux_im ... !> \param rtp_coeff_aux_fit ... !> \param ispin ... -!> \param error ... ! ***************************************************************************** SUBROUTINE calculate_rtp_admm_density(density_matrix_aux,density_matrix_aux_im,& - rtp_coeff_aux_fit,ispin, error) + rtp_coeff_aux_fit,ispin) TYPE(cp_dbcsr_type), POINTER :: density_matrix_aux, & density_matrix_aux_im TYPE(cp_fm_p_type), DIMENSION(:), & POINTER :: rtp_coeff_aux_fit INTEGER, INTENT(in) :: ispin - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calculate_rtp_admm_density', & routineP = moduleN//':'//routineN @@ -431,34 +418,34 @@ SUBROUTINE calculate_rtp_admm_density(density_matrix_aux,density_matrix_aux_im,& re=2*ispin-1 ; im =2*ispin alpha=3*one-REAL(SIZE(rtp_coeff_aux_fit)/2,dp) - CALL cp_dbcsr_set(density_matrix_aux,zero,error=error) - CALL cp_fm_get_info(rtp_coeff_aux_fit(re)%matrix,ncol_global=ncol,error=error) + CALL cp_dbcsr_set(density_matrix_aux,zero) + CALL cp_fm_get_info(rtp_coeff_aux_fit(re)%matrix,ncol_global=ncol) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix_aux,& matrix_v=rtp_coeff_aux_fit(re)%matrix,& matrix_g=rtp_coeff_aux_fit(re)%matrix,& ncol=ncol,& - alpha=alpha,error=error) + alpha=alpha) ! It is actually complex conjugate but i*i=-1 therfore it must be added CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix_aux,& matrix_v=rtp_coeff_aux_fit(im)%matrix,& matrix_g=rtp_coeff_aux_fit(im)%matrix,& ncol=ncol,& - alpha=alpha,error=error) + alpha=alpha) ! compute the imaginary part of the dm - CALL cp_dbcsr_set(density_matrix_aux_im,zero,error=error) + CALL cp_dbcsr_set(density_matrix_aux_im,zero) CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix_aux_im,& matrix_v=rtp_coeff_aux_fit(im)%matrix,& matrix_g=rtp_coeff_aux_fit(re)%matrix,& ncol=ncol,& - alpha=alpha,error=error) + alpha=alpha) alpha=-alpha CALL cp_dbcsr_plus_fm_fm_t(sparse_matrix=density_matrix_aux_im,& matrix_v=rtp_coeff_aux_fit(re)%matrix,& matrix_g=rtp_coeff_aux_fit(im)%matrix,& ncol=ncol,& - alpha=alpha,error=error) + alpha=alpha) CALL timestop(handle) @@ -467,11 +454,9 @@ END SUBROUTINE calculate_rtp_admm_density ! ***************************************************************************** !> \brief ... !> \param qs_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rtp_admm_merge_ks_matrix(qs_env, error) + SUBROUTINE rtp_admm_merge_ks_matrix(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rtp_admm_merge_ks_matrix', & routineP = moduleN//':'//routineN @@ -496,17 +481,16 @@ SUBROUTINE rtp_admm_merge_ks_matrix(qs_env, error) matrix_ks=matrix_ks,& matrix_ks_im=matrix_ks_im,& matrix_ks_aux_fit=matrix_ks_aux_fit,& - matrix_ks_aux_fit_im=matrix_ks_aux_fit_im,& - error=error) + matrix_ks_aux_fit_im=matrix_ks_aux_fit_im) DO ispin=1, dft_control%nspins SELECT CASE(admm_env%purification_method) CASE(do_admm_purify_none) CALL rt_merge_ks_matrix_none(ispin, admm_env, & - matrix_ks, matrix_ks_aux_fit, error) + matrix_ks, matrix_ks_aux_fit) CALL rt_merge_ks_matrix_none(ispin, admm_env,& - matrix_ks_im, matrix_ks_aux_fit_im, error) + matrix_ks_im, matrix_ks_aux_fit_im) CASE DEFAULT CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "only purification NONE possible with RTP/EMD at the moment"//& @@ -525,15 +509,13 @@ END SUBROUTINE rtp_admm_merge_ks_matrix !> \param admm_env ... !> \param matrix_ks ... !> \param matrix_ks_aux_fit ... -!> \param error ... ! ***************************************************************************** SUBROUTINE rt_merge_ks_matrix_none(ispin, admm_env, & - matrix_ks, matrix_ks_aux_fit, error) + matrix_ks, matrix_ks_aux_fit) INTEGER, INTENT(IN) :: ispin TYPE(admm_type), POINTER :: admm_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_ks, matrix_ks_aux_fit - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rt_merge_ks_matrix_none', & routineP = moduleN//':'//routineN @@ -553,43 +535,42 @@ SUBROUTINE rt_merge_ks_matrix_none(ispin, admm_env, & nao_aux_fit = admm_env%nao_aux_fit nao_orb = admm_env%nao_orb nmo = admm_env%nmo(ispin) - CALL cp_dbcsr_init (matrix_ks_nosym, error) + CALL cp_dbcsr_init (matrix_ks_nosym) CALL cp_dbcsr_create (matrix_ks_nosym, template=matrix_ks_aux_fit(ispin)%matrix,& - matrix_type=dbcsr_type_no_symmetry, error=error) - CALL cp_dbcsr_set(matrix_ks_nosym,0.0_dp,error) - CALL cp_dbcsr_desymmetrize(matrix_ks_aux_fit(ispin)%matrix,matrix_ks_nosym,error) + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_set(matrix_ks_nosym,0.0_dp) + CALL cp_dbcsr_desymmetrize(matrix_ks_aux_fit(ispin)%matrix,matrix_ks_nosym) - CALL copy_dbcsr_to_fm(matrix_ks_nosym,admm_env%K(ispin)%matrix,error) + CALL copy_dbcsr_to_fm(matrix_ks_nosym,admm_env%K(ispin)%matrix) !! K*A CALL cp_gemm('N', 'N', nao_aux_fit, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%K(ispin)%matrix,admm_env%A,0.0_dp,& - admm_env%work_aux_orb,error) + admm_env%work_aux_orb) !! A^T*K*A CALL cp_gemm('T', 'N', nao_orb, nao_orb, nao_aux_fit,& 1.0_dp,admm_env%A,admm_env%work_aux_orb,0.0_dp,& - admm_env%work_orb_orb,error) + admm_env%work_orb_orb) NULLIFY(matrix_k_tilde) ALLOCATE(matrix_k_tilde) - CALL cp_dbcsr_init (matrix_k_tilde, error) + CALL cp_dbcsr_init (matrix_k_tilde) CALL cp_dbcsr_create(matrix_k_tilde, 'MATRIX K_tilde', & cp_dbcsr_distribution(matrix_ks(ispin)%matrix), cp_dbcsr_get_matrix_type(matrix_ks_aux_fit(ispin)%matrix),& cp_dbcsr_row_block_sizes(matrix_ks(ispin)%matrix),& cp_dbcsr_col_block_sizes(matrix_ks(ispin)%matrix), & cp_dbcsr_get_data_size(matrix_ks(ispin)%matrix),& - cp_dbcsr_get_data_type(matrix_ks(ispin)%matrix), error=error) + cp_dbcsr_get_data_type(matrix_ks(ispin)%matrix)) - CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp, error) - CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE.,& - error=error) + CALL cp_dbcsr_copy(matrix_k_tilde, matrix_ks(ispin)%matrix) + CALL cp_dbcsr_set(matrix_k_tilde, 0.0_dp) + CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, matrix_k_tilde, keep_sparsity=.TRUE.) - CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp, error) + CALL cp_dbcsr_add(matrix_ks(ispin)%matrix, matrix_k_tilde, 1.0_dp, 1.0_dp) - CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde,error) - CALL cp_dbcsr_release(matrix_ks_nosym,error) + CALL cp_dbcsr_deallocate_matrix(matrix_k_tilde) + CALL cp_dbcsr_release(matrix_ks_nosym) CALL timestop(handle) diff --git a/src/s_square_methods.F b/src/s_square_methods.F index aecc6599e4..fcfc3f9cd9 100644 --- a/src/s_square_methods.F +++ b/src/s_square_methods.F @@ -57,7 +57,6 @@ MODULE s_square_methods !> \param s_square_ideal ... !> \param mo_derivs inout if present, add the derivative of s_square wrt mos to mo_derivs !> \param strength ... -!> \param error ... !> \par History !> 07.2004 created [ Joost VandeVondele ] !> \note @@ -65,7 +64,7 @@ MODULE s_square_methods !> Szabo and Ostlund ! ***************************************************************************** SUBROUTINE compute_s_square(mos, matrix_s, s_square, s_square_ideal,& - mo_derivs,strength,error) + mo_derivs,strength) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -74,7 +73,6 @@ SUBROUTINE compute_s_square(mos, matrix_s, s_square, s_square_ideal,& TYPE(cp_fm_p_type), DIMENSION(:), & OPTIONAL, POINTER :: mo_derivs REAL(KIND=dp), OPTIONAL :: strength - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'compute_s_square', & routineP = moduleN//':'//routineN @@ -103,31 +101,31 @@ SUBROUTINE compute_s_square(mos, matrix_s, s_square, s_square_ideal,& s_square = 0.0_dp s_square_ideal = 0.0_dp ! let's not do this - CPPrecondition(PRESENT(mo_derivs),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(mo_derivs),cp_failure_level,routineP,failure) CASE (2) CALL get_mo_set(mo_set=mos(1)%mo_set,mo_coeff=c_alpha,homo=nalpha,uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation,cp_warning_level,routineP,error,failure) + CPPrecondition(uniform_occupation,cp_warning_level,routineP,failure) CALL get_mo_set(mo_set=mos(2)%mo_set,mo_coeff=c_beta,homo=nbeta,uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation,cp_warning_level,routineP,error,failure) - CALL cp_fm_get_info(c_alpha,ncol_global=na,error=error) - CALL cp_fm_get_info(c_beta,ncol_global=nb,error=error) + CPPrecondition(uniform_occupation,cp_warning_level,routineP,failure) + CALL cp_fm_get_info(c_alpha,ncol_global=na) + CALL cp_fm_get_info(c_beta,ncol_global=nb) s_square_ideal = REAL((nalpha - nbeta)*(nalpha - nbeta + 2),KIND=dp)/4.0_dp ! create overlap matrix - CALL cp_fm_get_info(c_alpha,para_env=para_env,context=context,error=error) + CALL cp_fm_get_info(c_alpha,para_env=para_env,context=context) CALL cp_fm_struct_create(fm_struct_tmp,para_env=para_env,context=context, & - nrow_global=na,ncol_global=nb,error=error) - CALL cp_fm_create(matrix_overlap, fm_struct_tmp,name="matrix_overlap",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + nrow_global=na,ncol_global=nb) + CALL cp_fm_create(matrix_overlap, fm_struct_tmp,name="matrix_overlap") + CALL cp_fm_struct_release(fm_struct_tmp) ! create S C_beta and compute overlap - CALL cp_fm_get_info(c_beta, matrix_struct=fm_struct_tmp,nrow_global=nrow,error=error) - CALL cp_fm_create(matrix_sc_b, fm_struct_tmp,name="matrix_sc_beta",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,c_beta,matrix_sc_b,nb,error=error) - CALL cp_gemm('T','N',na,nb,nrow,1.0_dp,c_alpha,matrix_sc_b,0.0_dp,matrix_overlap,error=error) + CALL cp_fm_get_info(c_beta, matrix_struct=fm_struct_tmp,nrow_global=nrow) + CALL cp_fm_create(matrix_sc_b, fm_struct_tmp,name="matrix_sc_beta") + CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,c_beta,matrix_sc_b,nb) + CALL cp_gemm('T','N',na,nb,nrow,1.0_dp,c_alpha,matrix_sc_b,0.0_dp,matrix_overlap) ! invoke formula 2.271 CALL cp_fm_get_info(matrix_overlap,& local_data=local_data,& nrow_local=nrow_local,& - ncol_local=ncol_local,error=error) + ncol_local=ncol_local) tmp=0.0_dp DO j=1,ncol_local DO i=1,nrow_local @@ -138,22 +136,22 @@ SUBROUTINE compute_s_square(mos, matrix_s, s_square, s_square_ideal,& s_square = s_square_ideal + nb - tmp IF (PRESENT(mo_derivs)) THEN ! this gets really wrong for fractional occupations - CPPrecondition(SIZE(mo_derivs,1)==2,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(mo_derivs,1)==2,cp_failure_level,routineP,failure) CALL get_mo_set(mo_set=mos(1)%mo_set,uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation,cp_failure_level,routineP,error,failure) + CPPrecondition(uniform_occupation,cp_failure_level,routineP,failure) CALL get_mo_set(mo_set=mos(2)%mo_set,uniform_occupation=uniform_occupation) - CPPrecondition(uniform_occupation,cp_failure_level,routineP,error,failure) - CALL cp_gemm('N','T',nrow,na,nb,-1.0_dp*strength,matrix_sc_b,matrix_overlap,1.0_dp,mo_derivs(1)%matrix,error=error) - CALL cp_fm_release(matrix_sc_b,error=error) - CALL cp_fm_get_info(c_alpha, matrix_struct=fm_struct_tmp,error=error) - CALL cp_fm_create(matrix_sc_a, fm_struct_tmp,name="matrix_sc_alpha",error=error) - CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,c_alpha,matrix_sc_a,na,error=error) - CALL cp_gemm('N','N',nrow,nb,na,-1.0_dp*strength,matrix_sc_a,matrix_overlap,1.0_dp,mo_derivs(2)%matrix,error=error) - CALL cp_fm_release(matrix_sc_a,error=error) - CALL cp_fm_release(matrix_overlap,error=error) + CPPrecondition(uniform_occupation,cp_failure_level,routineP,failure) + CALL cp_gemm('N','T',nrow,na,nb,-1.0_dp*strength,matrix_sc_b,matrix_overlap,1.0_dp,mo_derivs(1)%matrix) + CALL cp_fm_release(matrix_sc_b) + CALL cp_fm_get_info(c_alpha, matrix_struct=fm_struct_tmp) + CALL cp_fm_create(matrix_sc_a, fm_struct_tmp,name="matrix_sc_alpha") + CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,c_alpha,matrix_sc_a,na) + CALL cp_gemm('N','N',nrow,nb,na,-1.0_dp*strength,matrix_sc_a,matrix_overlap,1.0_dp,mo_derivs(2)%matrix) + CALL cp_fm_release(matrix_sc_a) + CALL cp_fm_release(matrix_overlap) ELSE - CALL cp_fm_release(matrix_sc_b,error=error) - CALL cp_fm_release(matrix_overlap,error=error) + CALL cp_fm_release(matrix_sc_b) + CALL cp_fm_release(matrix_overlap) ENDIF CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,"alpha, beta, what else ?") @@ -171,12 +169,11 @@ END SUBROUTINE compute_s_square !> \param energy ... !> \param s2_restraint_control ... !> \param just_energy ... -!> \param error ... !> \par History !> 07.2004 created [ Joost VandeVondele ] ! ***************************************************************************** SUBROUTINE s2_restraint(mos, matrix_s, mo_derivs, energy, & - s2_restraint_control, just_energy, error) + s2_restraint_control, just_energy) TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos @@ -187,7 +184,6 @@ SUBROUTINE s2_restraint(mos, matrix_s, mo_derivs, energy, & REAL(kind=dp) :: energy TYPE(s2_restraint_type), POINTER :: s2_restraint_control LOGICAL :: just_energy - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 's2_restraint', & routineP = moduleN//':'//routineN @@ -202,17 +198,17 @@ SUBROUTINE s2_restraint(mos, matrix_s, mo_derivs, energy, & SELECT CASE(s2_restraint_control%functional_form) CASE(do_s2_constraint) IF (just_energy) THEN - CALL compute_s_square(mos, matrix_s, s_square, s_square_ideal, error=error) + CALL compute_s_square(mos, matrix_s, s_square, s_square_ideal) ELSE CALL compute_s_square(mos, matrix_s, s_square, s_square_ideal, & - mo_derivs,s2_restraint_control%strength,error) + mo_derivs,s2_restraint_control%strength) ENDIF energy= s2_restraint_control%strength*(s_square-s2_restraint_control%target) s2_restraint_control%s2_order_p=s_square CASE(do_s2_restraint) ! not yet implemented - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL timestop(handle) diff --git a/src/sap_kind_types.F b/src/sap_kind_types.F index 0b1b475a44..89a78e28ec 100644 --- a/src/sap_kind_types.F +++ b/src/sap_kind_types.F @@ -55,13 +55,11 @@ MODULE sap_kind_types ! ***************************************************************************** !> \brief ... !> \param sap_int ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE release_sap_int(sap_int, error) + SUBROUTINE release_sap_int(sap_int) TYPE(sap_int_type), DIMENSION(:), & POINTER :: sap_int - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'release_sap_int', & routineP = moduleN//':'//routineN @@ -72,7 +70,7 @@ SUBROUTINE release_sap_int(sap_int, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(sap_int),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sap_int),cp_failure_level,routineP,failure) DO i=1,SIZE(sap_int) IF ( ASSOCIATED(sap_int(i)%alist) ) THEN @@ -82,36 +80,36 @@ SUBROUTINE release_sap_int(sap_int, error) clist => sap_int(i)%alist(j)%clist(k) IF ( ASSOCIATED(clist%acint) ) THEN DEALLOCATE (clist%acint,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(clist%sgf_list) ) THEN DEALLOCATE (clist%sgf_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(clist%achint) ) THEN DEALLOCATE (clist%achint,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (sap_int(i)%alist(j)%clist,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (sap_int(i)%alist,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sap_int(i)%asort) ) THEN DEALLOCATE (sap_int(i)%asort,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF ( ASSOCIATED(sap_int(i)%aindex) ) THEN DEALLOCATE (sap_int(i)%aindex,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO DEALLOCATE (sap_int,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_sap_int @@ -120,14 +118,12 @@ END SUBROUTINE release_sap_int !> \param sap_int ... !> \param alist ... !> \param atom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE get_alist(sap_int, alist, atom, error) + SUBROUTINE get_alist(sap_int, alist, atom) TYPE(sap_int_type) :: sap_int TYPE(alist_type), POINTER :: alist INTEGER, INTENT(IN) :: atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_alist', & routineP = moduleN//':'//routineN @@ -145,7 +141,7 @@ SUBROUTINE get_alist(sap_int, alist, atom, error) ELSE IF (i==0) THEN NULLIFY(alist) ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE get_alist @@ -237,12 +233,10 @@ END SUBROUTINE alist_post_align_blk ! ***************************************************************************** !> \brief ... !> \param sap_int ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE sap_sort(sap_int,error) + SUBROUTINE sap_sort(sap_int) TYPE(sap_int_type), DIMENSION(:), & POINTER :: sap_int - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sap_sort', & routineP = moduleN//':'//routineN @@ -258,7 +252,7 @@ SUBROUTINE sap_sort(sap_int,error) IF (.NOT.ASSOCIATED(sap_int(iac)%alist)) CYCLE na = SIZE(sap_int(iac)%alist) ALLOCATE(sap_int(iac)%asort(na),sap_int(iac)%aindex(na),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sap_int(iac)%asort(1:na)=sap_int(iac)%alist(1:na)%aatom CALL sort(sap_int(iac)%asort,na,sap_int(iac)%aindex) END DO diff --git a/src/scf_control_types.F b/src/scf_control_types.F index 897772381a..9cb403a6b2 100644 --- a/src/scf_control_types.F +++ b/src/scf_control_types.F @@ -145,17 +145,14 @@ MODULE scf_control_types ! ***************************************************************************** !> \brief allocates and initializes an scf control object with the default values !> \param scf_control the object to initialize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] !> - Default ROKS parameters added (05.04.06,MK) !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE scf_c_create(scf_control,error) + SUBROUTINE scf_c_create(scf_control) TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scf_c_create', & routineP = moduleN//':'//routineN @@ -168,7 +165,7 @@ SUBROUTINE scf_c_create(scf_control,error) failure = .FALSE. ALLOCATE (scf_control,STAT=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) ! Load the default values @@ -267,16 +264,13 @@ END SUBROUTINE scf_c_create ! ***************************************************************************** !> \brief retains the given scf_control (see cp2k/doc/ReferenceCounting.html) !> \param scf_control the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE scf_c_retain(scf_control,error) + SUBROUTINE scf_c_retain(scf_control) TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scf_c_retain', & routineP = moduleN//':'//routineN @@ -285,9 +279,9 @@ SUBROUTINE scf_c_retain(scf_control,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,failure) - CPPrecondition(scf_control%ref_count > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(scf_control%ref_count > 0,cp_failure_level,routineP,failure) scf_control%ref_count = scf_control%ref_count + 1 END SUBROUTINE scf_c_retain @@ -295,18 +289,15 @@ END SUBROUTINE scf_c_retain ! ***************************************************************************** !> \brief releases the given scf_control (see cp2k/doc/ReferenceCounting.html) !> \param scf_control the object to free -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> at the moment does nothing ! ***************************************************************************** - SUBROUTINE scf_c_release(scf_control,error) + SUBROUTINE scf_c_release(scf_control) TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scf_c_release', & routineP = moduleN//':'//routineN @@ -317,17 +308,17 @@ SUBROUTINE scf_c_release(scf_control,error) failure = .FALSE. IF (ASSOCIATED(scf_control)) THEN - CPPrecondition(scf_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(scf_control%ref_count>0,cp_failure_level,routineP,failure) scf_control%ref_count = scf_control%ref_count - 1 IF (scf_control%ref_count < 1) THEN IF (ASSOCIATED(scf_control%smear%list)) THEN DEALLOCATE(scf_control%smear%list,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ENDIF DEALLOCATE(scf_control%smear,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DEALLOCATE(scf_control,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END IF @@ -339,17 +330,15 @@ END SUBROUTINE scf_c_release !> \brief reads the parameters of the scf section into the given scf_control !> \param scf_control the object that wil contain the values read !> \param inp_section ... -!> \param error controls log and error handling !> \par History !> 05.2001 created [Matthias] !> 09.2002 creaded separated scf_control type [fawzi] !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE scf_c_read_parameters(scf_control,inp_section,error) + SUBROUTINE scf_c_read_parameters(scf_control,inp_section) TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: inp_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scf_c_read_parameters', & routineP = moduleN//':'//routineN @@ -365,75 +354,75 @@ SUBROUTINE scf_c_read_parameters(scf_control,inp_section,error) CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,error,failure) - CPPrecondition((scf_control%ref_count > 0),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,failure) + CPPrecondition((scf_control%ref_count > 0),cp_failure_level,routineP,failure) IF (.NOT.failure) THEN - scf_section => section_vals_get_subs_vals(inp_section,"SCF",error=error) + scf_section => section_vals_get_subs_vals(inp_section,"SCF") CALL section_vals_val_get(scf_section,"DIAGONALIZATION%_SECTION_PARAMETERS_",& - l_val=scf_control%use_diag,error=error) + l_val=scf_control%use_diag) IF(scf_control%use_diag) THEN CALL section_vals_val_get(scf_section,"DIAGONALIZATION%DIAG_SUB_SCF%_SECTION_PARAMETERS_",& - l_val=scf_control%do_diag_sub,error=error) + l_val=scf_control%do_diag_sub) END IF - CALL section_vals_val_get(scf_section,"OT%_SECTION_PARAMETERS_",l_val=scf_control%use_ot,error=error) + CALL section_vals_val_get(scf_section,"OT%_SECTION_PARAMETERS_",l_val=scf_control%use_ot) IF ( scf_control%use_diag .AND. scf_control%use_ot ) THEN ! don't allow both options to be true CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"Don't activate OT and Diagonaliztion together",error,failure) + routineP,"Don't activate OT and Diagonaliztion together",failure) ELSEIF ( .NOT. (scf_control%use_diag .OR. scf_control%use_ot) ) THEN ! set default to diagonalization scf_control%use_diag = .TRUE. END IF - CALL section_vals_val_get(scf_section,"OT%ALGORITHM",i_val=ialgo,error=error) + CALL section_vals_val_get(scf_section,"OT%ALGORITHM",i_val=ialgo) scf_control%do_outer_scf_reortho = ialgo.EQ.ot_algo_taylor_or_diag - CALL section_vals_val_get(scf_section,"SCF_GUESS",i_val=scf_control%density_guess,error=error) - CALL section_vals_val_get(scf_section,"EPS_DIIS",r_val=scf_control%eps_diis,error=error) - CALL section_vals_val_get(scf_section,"eps_eigval",r_val=scf_control%eps_eigval,error=error) - CALL section_vals_val_get(scf_section,"cholesky",i_val=cholesky_flag,error=error) + CALL section_vals_val_get(scf_section,"SCF_GUESS",i_val=scf_control%density_guess) + CALL section_vals_val_get(scf_section,"EPS_DIIS",r_val=scf_control%eps_diis) + CALL section_vals_val_get(scf_section,"eps_eigval",r_val=scf_control%eps_eigval) + CALL section_vals_val_get(scf_section,"cholesky",i_val=cholesky_flag) IF(cholesky_flag>0) THEN scf_control%use_cholesky = .TRUE. END IF - CALL section_vals_val_get(scf_section,"eps_scf",r_val=scf_control%eps_scf,error=error) - CALL section_vals_val_get(scf_section,"level_shift",r_val=scf_control%level_shift,error=error) - CALL section_vals_val_get(scf_section,"max_diis",i_val=scf_control%max_diis,error=error) - CALL section_vals_val_get(scf_section,"max_scf",i_val=scf_control%max_scf,error=error) + CALL section_vals_val_get(scf_section,"eps_scf",r_val=scf_control%eps_scf) + CALL section_vals_val_get(scf_section,"level_shift",r_val=scf_control%level_shift) + CALL section_vals_val_get(scf_section,"max_diis",i_val=scf_control%max_diis) + CALL section_vals_val_get(scf_section,"max_scf",i_val=scf_control%max_scf) ! Diagonaliztion section IF ( scf_control%use_diag ) THEN CALL section_vals_val_get(scf_section,"DIAGONALIZATION%ALGORITHM",& - i_val=scf_control%diagonalization%method,error=error) + i_val=scf_control%diagonalization%method) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%EPS_JACOBI",& - r_val=scf_control%diagonalization%eps_jacobi,error=error) + r_val=scf_control%diagonalization%eps_jacobi) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%JACOBI_THRESHOLD",& - r_val=scf_control%diagonalization%jacobi_threshold,error=error) + r_val=scf_control%diagonalization%jacobi_threshold) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%MAX_ITER",& - i_val=scf_control%diagonalization%max_iter,error=error) + i_val=scf_control%diagonalization%max_iter) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%EPS_ITER",& - r_val=scf_control%diagonalization%eps_iter,error=error) + r_val=scf_control%diagonalization%eps_iter) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%EPS_ADAPT",& - r_val=scf_control%diagonalization%eps_adapt,error=error) + r_val=scf_control%diagonalization%eps_adapt) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%KRYLOV%NKRYLOV",& - i_val=scf_control%diagonalization%nkrylov,error=error) + i_val=scf_control%diagonalization%nkrylov) CALL section_vals_val_get(scf_section,"DIAGONALIZATION%KRYLOV%NBLOCK",& - i_val=scf_control%diagonalization%nblock_krylov,error=error) + i_val=scf_control%diagonalization%nblock_krylov) IF ( scf_control%diagonalization%method == diag_ot ) THEN ! read OT section - CALL ot_diag_read_input(scf_control%diagonalization%ot_settings,scf_section,error) + CALL ot_diag_read_input(scf_control%diagonalization%ot_settings,scf_section) END IF END IF ! Read ROKS parameters - CALL section_vals_val_get(scf_section,"ROKS_SCHEME",i_val=scf_control%roks_scheme,error=error) + CALL section_vals_val_get(scf_section,"ROKS_SCHEME",i_val=scf_control%roks_scheme) SELECT CASE (scf_control%roks_scheme) CASE (general_roks) ! Read parameters for the general ROKS scheme - CALL section_vals_val_get(scf_section,"ROKS_F",r_val=scf_control%roks_f,error=error) + CALL section_vals_val_get(scf_section,"ROKS_F",r_val=scf_control%roks_f) CASE (high_spin_roks) ! Read high-spin ROKS parameters for the diagonal block ! 0 = v)irtual, 1 = o)pen shell, 2 = c)losed shell NULLIFY (roks_parameter) - CALL section_vals_val_get(scf_section,"ROKS_PARAMETERS",r_vals=roks_parameter,error=error) + CALL section_vals_val_get(scf_section,"ROKS_PARAMETERS",r_vals=roks_parameter) IF (ASSOCIATED(roks_parameter)) THEN scf_control%roks_parameter(2,2,1) = roks_parameter(1) ! acc scf_control%roks_parameter(2,2,2) = roks_parameter(2) ! bcc @@ -445,12 +434,12 @@ SUBROUTINE scf_c_read_parameters(scf_control,inp_section,error) END SELECT ! should be moved to printkey - CALL section_vals_val_get(scf_section,"eps_lumo",r_val=scf_control%eps_lumos,error=error) - CALL section_vals_val_get(scf_section,"max_iter_lumo",i_val=scf_control%max_iter_lumos,error=error) + CALL section_vals_val_get(scf_section,"eps_lumo",r_val=scf_control%eps_lumos) + CALL section_vals_val_get(scf_section,"max_iter_lumo",i_val=scf_control%max_iter_lumos) ! Extra MOs, e.g. for smearing - CALL section_vals_val_get(scf_section,"added_mos",i_vals=added_mos,error=error) - CPPrecondition(ASSOCIATED(added_mos),cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(scf_section,"added_mos",i_vals=added_mos) + CPPrecondition(ASSOCIATED(added_mos),cp_failure_level,routineP,failure) IF (SIZE(added_mos) > 0) THEN scf_control%added_mos(1) = added_mos(1) IF (SIZE(added_mos) > 1) THEN @@ -458,59 +447,48 @@ SUBROUTINE scf_c_read_parameters(scf_control,inp_section,error) END IF END IF - CALL section_vals_val_get(scf_section,"max_scf_history",i_val=scf_control%max_scf_hist,error=error) - CALL section_vals_val_get(scf_section,"eps_scf_history",r_val=scf_control%eps_scf_hist,error=error) + CALL section_vals_val_get(scf_section,"max_scf_history",i_val=scf_control%max_scf_hist) + CALL section_vals_val_get(scf_section,"eps_scf_history",r_val=scf_control%eps_scf_hist) IF (scf_control%level_shift /= 0.0_dp) scf_control%use_cholesky = .FALSE. IF (scf_control%use_ot.AND.(scf_control%density_guess == core_guess)) THEN CALL stop_program(routineN,moduleN,__LINE__,"Use GUESS {ATOMIC,RESTART,RANDOM} with OT") END IF - outer_scf_section => section_vals_get_subs_vals(scf_section,"OUTER_SCF",error=error) + outer_scf_section => section_vals_get_subs_vals(scf_section,"OUTER_SCF") CALL section_vals_val_get(outer_scf_section,"_SECTION_PARAMETERS_",& - l_val=scf_control%outer_scf%have_scf,error=error) + l_val=scf_control%outer_scf%have_scf) IF (scf_control%outer_scf%have_scf) THEN CALL section_vals_val_get(outer_scf_section,"EPS_SCF",& - r_val=scf_control%outer_scf%eps_scf,& - error=error) + r_val=scf_control%outer_scf%eps_scf) CALL section_vals_val_get(outer_scf_section,"STEP_SIZE",& - r_val=scf_control%outer_scf%step_size,& - error=error) + r_val=scf_control%outer_scf%step_size) CALL section_vals_val_get(outer_scf_section,"DIIS_BUFFER_LENGTH",& - i_val=scf_control%outer_scf%diis_buffer_length,& - error=error) + i_val=scf_control%outer_scf%diis_buffer_length) CALL section_vals_val_get(outer_scf_section,"BISECT_TRUST_COUNT",& - i_val=scf_control%outer_scf%bisect_trust_count,& - error=error) + i_val=scf_control%outer_scf%bisect_trust_count) CALL section_vals_val_get(outer_scf_section,"TYPE",& - i_val=scf_control%outer_scf%type,& - error=error) + i_val=scf_control%outer_scf%type) CALL section_vals_val_get(outer_scf_section,"OPTIMIZER",& - i_val=scf_control%outer_scf%optimizer,& - error=error) + i_val=scf_control%outer_scf%optimizer) CALL section_vals_val_get(outer_scf_section,"MAX_SCF",& - i_val=scf_control%outer_scf%max_scf,& - error=error) + i_val=scf_control%outer_scf%max_scf) CALL section_vals_val_get(outer_scf_section,"EXTRAPOLATION_ORDER",& - i_val=scf_control%outer_scf%extrapolation_order,& - error=error) + i_val=scf_control%outer_scf%extrapolation_order) END IF - smear_section => section_vals_get_subs_vals(scf_section,"SMEAR",error=error) - CALL init_smear(scf_control%smear,error) - CALL read_smear_section(scf_control%smear, smear_section, error) + smear_section => section_vals_get_subs_vals(scf_section,"SMEAR") + CALL init_smear(scf_control%smear) + CALL read_smear_section(scf_control%smear, smear_section) do_mixing = .FALSE. - mixing_section => section_vals_get_subs_vals(scf_section,"MIXING",error=error) + mixing_section => section_vals_get_subs_vals(scf_section,"MIXING") CALL section_vals_val_get(mixing_section,"_SECTION_PARAMETERS_",& - l_val=do_mixing,& - error=error) + l_val=do_mixing) IF (do_mixing) THEN CALL section_vals_val_get(mixing_section,"METHOD",& - i_val=scf_control%mixing_method,& - error=error) - CALL section_vals_val_get(mixing_section,"NMIXING",i_val=scf_control%nmixing,& - error=error) + i_val=scf_control%mixing_method) + CALL section_vals_val_get(mixing_section,"NMIXING",i_val=scf_control%nmixing) END IF ! do mixing END IF ! failure @@ -521,11 +499,9 @@ END SUBROUTINE scf_c_read_parameters ! ***************************************************************************** !> \brief ... !> \param smear ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_smear(smear,error) + SUBROUTINE init_smear(smear) TYPE(smear_type), POINTER :: smear - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_smear', & routineP = moduleN//':'//routineN @@ -534,9 +510,9 @@ SUBROUTINE init_smear(smear,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(smear),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(smear),cp_failure_level,routineP,failure) ALLOCATE(smear,stat=stat) - CPPostcondition((stat == 0),cp_failure_level,routineP,error,failure) + CPPostcondition((stat == 0),cp_failure_level,routineP,failure) smear%do_smear = .FALSE. smear%method = smear_energy_window smear%electronic_temperature = 0.0_dp @@ -550,12 +526,10 @@ END SUBROUTINE init_smear !> \brief ... !> \param smear ... !> \param smear_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_smear_section(smear,smear_section,error) + SUBROUTINE read_smear_section(smear,smear_section) TYPE(smear_type), POINTER :: smear TYPE(section_vals_type), POINTER :: smear_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_smear_section', & routineP = moduleN//':'//routineN @@ -569,33 +543,26 @@ SUBROUTINE read_smear_section(smear,smear_section,error) IF (.NOT.failure) THEN CALL section_vals_val_get(smear_section,"_SECTION_PARAMETERS_",& - l_val=smear%do_smear,& - error=error) + l_val=smear%do_smear) IF (smear%do_smear) THEN CALL section_vals_val_get(smear_section,"METHOD",& - i_val=smear%method,& - error=error) + i_val=smear%method) CALL section_vals_val_get(smear_section,"ELECTRONIC_TEMPERATURE",& - r_val=smear%electronic_temperature,& - error=error) + r_val=smear%electronic_temperature) CALL section_vals_val_get(smear_section,"EPS_FERMI_DIRAC",& - r_val=smear%eps_fermi_dirac,& - error=error) + r_val=smear%eps_fermi_dirac) CALL section_vals_val_get(smear_section,"WINDOW_SIZE",& - r_val=smear%window_size,& - error=error) + r_val=smear%window_size) IF (smear%method==smear_list) THEN CALL section_vals_val_get(smear_section,"LIST",& - r_vals=r_vals,& - error=error) - CPPrecondition(ASSOCIATED(r_vals),cp_failure_level,routineP,error,failure) + r_vals=r_vals) + CPPrecondition(ASSOCIATED(r_vals),cp_failure_level,routineP,failure) ALLOCATE(smear%list(SIZE(r_vals)),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) smear%list=r_vals END IF CALL section_vals_val_get(smear_section,"FIXED_MAGNETIC_MOMENT",& - r_val=smear%fixed_mag_mom,& - error=error) + r_val=smear%fixed_mag_mom) END IF ! do smear END IF END SUBROUTINE read_smear_section @@ -604,17 +571,15 @@ END SUBROUTINE read_smear_section !> \brief writes out the scf parameters !> \param scf_control the object you want to print !> \param dft_section ... -!> \param error controls log and error handling !> \par History !> 05.2001 created [Matthias] !> 09.2002 created separated scf_control type [fawzi] !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) + SUBROUTINE scf_c_write_parameters(scf_control,dft_section) TYPE(scf_control_type), POINTER :: scf_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scf_c_write_parameters', & routineP = moduleN//':'//routineN @@ -634,35 +599,35 @@ SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) failure = .FALSE. NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY (scf_section) NULLIFY (section) - CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scf_control),cp_failure_level,routineP,failure) + CPPrecondition(scf_control%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT.failure) THEN - scf_section => section_vals_get_subs_vals(dft_section,"SCF",error=error) + scf_section => section_vals_get_subs_vals(dft_section,"SCF") output_unit = cp_print_key_unit_nr(logger,scf_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit > 0) THEN IF (scf_control%max_scf > 0) THEN - CALL create_scf_section(section,error=error) + CALL create_scf_section(section) - keyword => section_get_keyword(section,"SCF_GUESS",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + keyword => section_get_keyword(section,"SCF_GUESS") + CALL keyword_get(keyword,enum=enum) WRITE (UNIT=output_unit,& FMT="(/,/,T2,A,T25,A,T51,A30,/,T25,56('-'),3(/,T25,A,T76,I5),/,"//& "T25,56('-'),4(/,T25,A,T72,ES9.2),/,T25,56('-'),"//& "1(/,T25,A,T76,F5.2))")& "SCF PARAMETERS",& - "Density guess: ",ADJUSTR(TRIM(enum_i2c(enum,scf_control%density_guess,error=error))),& + "Density guess: ",ADJUSTR(TRIM(enum_i2c(enum,scf_control%density_guess))),& "max_scf: ",scf_control%max_scf,& "max_scf_history: ",scf_control%max_scf_hist,& "max_diis: ",scf_control%max_diis,& @@ -677,25 +642,25 @@ SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) END IF IF (scf_control%mixing_method>0 .AND. .NOT. scf_control%use_ot) THEN - keyword => section_get_keyword(section,"MIXING%METHOD",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + keyword => section_get_keyword(section,"MIXING%METHOD") + CALL keyword_get(keyword,enum=enum) WRITE (UNIT=output_unit,FMT="(T25,A,/,T25,A,T51,A30)")& REPEAT("-",56),& - "Mixing method: ",ADJUSTR(TRIM(enum_i2c(enum,scf_control%mixing_method,error=error))) + "Mixing method: ",ADJUSTR(TRIM(enum_i2c(enum,scf_control%mixing_method))) IF(scf_control%mixing_method>1) THEN WRITE (UNIT=output_unit,FMT="(T47,A34)") "charge density mixing in g-space" END IF END IF IF (scf_control%smear%do_smear) THEN - keyword => section_get_keyword(section,"SMEAR%METHOD",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + keyword => section_get_keyword(section,"SMEAR%METHOD") + CALL keyword_get(keyword,enum=enum) WRITE (UNIT=output_unit,FMT="(T25,A,/,T25,A,T51,A30)")& REPEAT("-",56),& - "Smear method: ",ADJUSTR(TRIM(enum_i2c(enum,scf_control%smear%method,error=error))) + "Smear method: ",ADJUSTR(TRIM(enum_i2c(enum,scf_control%smear%method))) SELECT CASE (scf_control%smear%method) CASE (smear_fermi_dirac) elec_temp = cp_unit_from_cp2k(scf_control%smear%electronic_temperature,& - "K",error=error) + "K") WRITE (UNIT=output_unit,FMT="(T25,A,T61,F20.1)")& "Electronic temperature [K]:",elec_temp WRITE (UNIT=output_unit,FMT="(T25,A,T71,ES10.2)")& @@ -710,15 +675,15 @@ SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) END SELECT END IF - CALL section_vals_val_get(dft_section,"ROKS",l_val=roks,error=error) + CALL section_vals_val_get(dft_section,"ROKS",l_val=roks) IF (roks.AND.(.NOT.scf_control%use_ot)) THEN CALL section_vals_val_get(scf_section,"ROKS_SCHEME",& - i_val=roks_scheme,error=error) - keyword => section_get_keyword(section,"ROKS_SCHEME",error=error) - CALL keyword_get(keyword,enum=enum,error=error) + i_val=roks_scheme) + keyword => section_get_keyword(section,"ROKS_SCHEME") + CALL keyword_get(keyword,enum=enum) WRITE (UNIT=output_unit,FMT="(T25,A,/,T25,A,T51,A30)")& REPEAT("-",56),& - "ROKS scheme:",ADJUSTR(TRIM(enum_i2c(enum,roks_scheme,error=error))) + "ROKS scheme:",ADJUSTR(TRIM(enum_i2c(enum,roks_scheme))) SELECT CASE (roks_scheme) CASE (general_roks) WRITE (UNIT=output_unit,FMT="(T25,A,T71,F10.6)")& @@ -735,7 +700,7 @@ SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) "bvv",scf_control%roks_parameter(0,0,2) END SELECT END IF - CALL section_release(section,error=error) + CALL section_release(section) IF (scf_control%outer_scf%have_scf) THEN WRITE (output_unit,"(T25,56('-'),/,T25,A)") "Outer loop SCF in use " @@ -749,7 +714,7 @@ SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) CASE (outer_scf_becke_constraint) WRITE (output_unit,'(T25,A)') "Becke weight population constraint enforced" CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT WRITE (output_unit,'(T25,A,T72,ES9.2)') "eps_scf",scf_control%outer_scf%eps_scf WRITE (output_unit,'(T25,A,T72,I9)') "max_scf",scf_control%outer_scf%max_scf @@ -766,7 +731,7 @@ SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) WRITE (output_unit,'(T25,A,T72,I9)') "DIIS buffer length", & scf_control%outer_scf%diis_buffer_length CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT WRITE (output_unit,'(T25,A,T72,ES9.2)') "step_size",scf_control%outer_scf%step_size ELSE @@ -778,7 +743,7 @@ SUBROUTINE scf_c_write_parameters(scf_control,dft_section,error) END IF ! output_unit > 0 CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") END IF ! not failure @@ -792,12 +757,10 @@ END SUBROUTINE scf_c_write_parameters !> \brief ... !> \param settings ... !> \param scf_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ot_diag_read_input(settings,scf_section,error) + SUBROUTINE ot_diag_read_input(settings,scf_section) TYPE(qs_ot_settings_type) :: settings TYPE(section_vals_type), POINTER :: scf_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ot_diag_read_input', & routineP = moduleN//':'//routineN @@ -811,21 +774,21 @@ SUBROUTINE ot_diag_read_input(settings,scf_section,error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") ! decide default settings CALL qs_ot_settings_init(settings) ! use ot input new style - ot_section=>section_vals_get_subs_vals(scf_section,"DIAGONALIZATION%OT",error=error) - CALL section_vals_get(ot_section,explicit=explicit,error=error) + ot_section=>section_vals_get_subs_vals(scf_section,"DIAGONALIZATION%OT") + CALL section_vals_get(ot_section,explicit=explicit) - CALL ot_readwrite_input(settings,ot_section,output_unit,error) + CALL ot_readwrite_input(settings,ot_section,output_unit) CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) diff --git a/src/scptb_core_interactions.F b/src/scptb_core_interactions.F index 388f4e0389..fb324e0dc0 100644 --- a/src/scptb_core_interactions.F +++ b/src/scptb_core_interactions.F @@ -54,14 +54,12 @@ MODULE scptb_core_interactions !> \brief Evaluates the repulsive core interactions for SCPTB methods !> \param qs_env ... !> \param calculate_forces ... -!> \param error ... !> \date 12.2011 [jhu] !> \author Juerg Hutter [jhu] - University of Zurich ! ***************************************************************************** - SUBROUTINE scptb_core_interaction(qs_env, calculate_forces, error) + SUBROUTINE scptb_core_interaction(qs_env, calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scptb_core_interaction', & routineP = moduleN//':'//routineN @@ -102,9 +100,9 @@ SUBROUTINE scptb_core_interaction(qs_env, calculate_forces, error) NULLIFY(atprop) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env,para_env=para_env,dft_control=dft_control,& - cell=cell,virial=virial,energy=energy,atprop=atprop,error=error) + cell=cell,virial=virial,energy=energy,atprop=atprop) ! Parameters use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -112,28 +110,28 @@ SUBROUTINE scptb_core_interaction(qs_env, calculate_forces, error) ! atomic energy decomposition atener = atprop%energy IF (atener) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE (particle_set) - CALL atprop_array_init(atprop%atecc,natom,error) + CALL atprop_array_init(atprop%atecc,natom) END IF CALL get_qs_env(qs_env=qs_env,sab_core=sab_core, atomic_kind_set=atomic_kind_set,& - qs_kind_set=qs_kind_set,error=error) + qs_kind_set=qs_kind_set) nkind = SIZE(atomic_kind_set) ! Possibly compute forces IF(calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,force=force) natom = SIZE (particle_set) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set,atom_of_kind=atom_of_kind) END IF ALLOCATE (scptb_kind_param(nkind),scptb_defined(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind_a) scptb_kind_param(ikind)%scptb_param => scptb_kind_a CALL get_scptb_parameter(scptb_kind_a,defined=defined) scptb_defined(ikind)=defined @@ -150,7 +148,7 @@ SUBROUTINE scptb_core_interaction(qs_env, calculate_forces, error) IF ( dr1 > 0.00001_dp ) THEN ! Core-Core energy and derivatives IF(calculate_forces) THEN - CALL corecore (scptb_kind_a,scptb_kind_b,rij,enuc=enuc,denuc=force_ab,error=error) + CALL corecore (scptb_kind_a,scptb_kind_b,rij,enuc=enuc,denuc=force_ab) atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) @@ -166,11 +164,11 @@ SUBROUTINE scptb_core_interaction(qs_env, calculate_forces, error) force(jkind)%all_potential(3,atom_b) = force(jkind)%all_potential(3,atom_b) + force_ab(3) IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, force_ab, rij) END IF ELSE - CALL corecore (scptb_kind_a,scptb_kind_b,rij,enuc=enuc,error=error) + CALL corecore (scptb_kind_a,scptb_kind_b,rij,enuc=enuc) END IF enucij = enucij + enuc END IF @@ -183,11 +181,11 @@ SUBROUTINE scptb_core_interaction(qs_env, calculate_forces, error) CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (scptb_kind_param,scptb_defined,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE(atom_of_kind,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF CALL mp_sum(enuclear,para_env%group) @@ -204,15 +202,13 @@ END SUBROUTINE scptb_core_interaction !> \param rij ... !> \param enuc ... !> \param denuc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE corecore (sepi,sepj,rij,enuc,denuc,error) + SUBROUTINE corecore (sepi,sepj,rij,enuc,denuc) TYPE(scptb_parameter_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), INTENT(OUT) :: enuc REAL(dp), DIMENSION(3), INTENT(OUT), & OPTIONAL :: denuc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore', & routineP = moduleN//':'//routineN diff --git a/src/scptb_core_matrix.F b/src/scptb_core_matrix.F index 59e716c2d6..455a0639c4 100644 --- a/src/scptb_core_matrix.F +++ b/src/scptb_core_matrix.F @@ -69,13 +69,11 @@ MODULE scptb_core_matrix !> \brief Builds the SCPTB core Hamiltonian matrix and its derivatives !> \param qs_env The QS environment !> \param calculate_forces Flag to toggle force calculation -!> \param error CP2K error reporting ! ***************************************************************************** - SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) + SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_scptb_core_matrix', & routineP = moduleN//':'//routineN @@ -124,7 +122,7 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) CALL timeset(routineN,handle) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(rho,force,atomic_kind_set,qs_kind_set,sab_orb,matrix_p,ks_env,& dft_control, matrix_h, matrix_s, matrix_t, kpoints) @@ -141,10 +139,9 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) kpoints=kpoints,& matrix_s_kp=matrix_s,& kinetic_kp=matrix_t,& - matrix_h_kp=matrix_h,& - error=error) + matrix_h_kp=matrix_h) - CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index, error=error) + CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) use_cell_mapping = (SIZE(cell_to_index) > 1) nkind = SIZE(atomic_kind_set) @@ -160,24 +157,23 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) ! forces are not yet supported for k-points nder = 1 ALLOCATE (atom_of_kind(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) CALL get_qs_env(qs_env,& rho=rho,& force=force,& - matrix_w_kp=matrix_w,& - error=error) + matrix_w_kp=matrix_w) - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) IF (nspins == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix, matrix_p(2,ic)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_p(2,ic)%matrix, matrix_p(1,ic)%matrix, & - alpha_scalar=-2.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-2.0_dp, beta_scalar=1.0_dp) CALL cp_dbcsr_add(matrix_w(1,ic)%matrix, matrix_w(2,ic)%matrix, & - alpha_scalar= 1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar= 1.0_dp, beta_scalar=1.0_dp) END DO END IF @@ -188,19 +184,17 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) basis_type_a="ORB",& basis_type_b="ORB", & sab_nl=sab_orb,calculate_forces=.TRUE.,& - matrixkp_p=matrix_w,& - error=error) + matrixkp_p=matrix_w) ! T matrix CALL build_kinetic_matrix(ks_env,matrixkp_t=matrix_t,& matrix_name="KINETIC ENERGY MATRIX",& basis_type="ORB",& sab_nl=sab_orb,calculate_forces=.TRUE.,& matrixkp_p=matrix_p,& - eps_filter=eps_filter,& - error=error) + eps_filter=eps_filter) ELSE IF (cp_print_key_should_output(logger%iter_info,qs_env%input,& - "DFT%PRINT%AO_MATRICES/DERIVATIVES",error=error)/=0) THEN + "DFT%PRINT%AO_MATRICES/DERIVATIVES")/=0) THEN nder = 1 ELSE nder = 0 @@ -211,38 +205,36 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) matrix_name="OVERLAP MATRIX",& basis_type_a="ORB",& basis_type_b="ORB", & - sab_nl=sab_orb,& - error=error) + sab_nl=sab_orb) ! T matrix CALL build_kinetic_matrix(ks_env,matrixkp_t=matrix_t,& matrix_name="KINETIC ENERGY MATRIX",& basis_type="ORB",& sab_nl=sab_orb,& - eps_filter=eps_filter,& - error=error) + eps_filter=eps_filter) END IF - CALL set_ks_env(ks_env, matrix_s_kp=matrix_s, kinetic_kp=matrix_t, error=error) + CALL set_ks_env(ks_env, matrix_s_kp=matrix_s, kinetic_kp=matrix_t) ! initialize H matrix - CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,nimg,error) + CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,nimg) DO ic=1,nimg ALLOCATE(matrix_h(1,ic)%matrix) - CALL cp_dbcsr_init(matrix_h(1,ic)%matrix, error=error) + CALL cp_dbcsr_init(matrix_h(1,ic)%matrix) CALL cp_dbcsr_copy(matrix_h(1,ic)%matrix,matrix_t(1,ic)%matrix,& - name="CORE HAMILTONIAN MATRIX",error=error) + name="CORE HAMILTONIAN MATRIX") END DO !The band energy elements will be added to the kinetic energy. ALLOCATE (scptb_kind_param(nkind),scptb_defined(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (umt(100,nkind),hmt(100,nkind),kk(nkind,nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) umt = 0._dp hmt = 0._dp DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind_a) scptb_kind_param(ikind)%scptb_param => scptb_kind_a CALL get_scptb_parameter(scptb_kind_a,defined=defined) scptb_defined(ikind)=defined @@ -269,7 +261,7 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) IF(use_cell_mapping) THEN ic = cell_to_index(cell(1),cell(2),cell(3)) - CPPrecondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPrecondition(ic > 0,cp_failure_level,routineP,failure) ELSE ic = 1 END IF @@ -283,7 +275,7 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) icol = iatom END IF CALL cp_dbcsr_get_block_p(matrix_h(1,ic)%matrix,irow,icol,h_block,found) - CPPostcondition(ASSOCIATED(h_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(h_block),cp_failure_level,routineP,failure) dr = SUM(rij(:)**2) !actual core energy determination , eq. 2.17 in my notes ??? @@ -294,7 +286,7 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) ELSE NULLIFY(s_block) !s_block is overlap [sub]matrix ??? CALL cp_dbcsr_get_block_p(matrix_s(1,ic)%matrix,irow,icol,s_block,found) - CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) IF ( irow == iatom ) THEN DO i=1,SIZE(h_block,1) DO j=1,SIZE(h_block,2) @@ -314,11 +306,11 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) atom_a = atom_of_kind(iatom) atom_b = atom_of_kind(jatom) CALL cp_dbcsr_get_block_p(matrix_p(1,ic)%matrix,irow,icol,p_block,found) - CPPostcondition(ASSOCIATED(p_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_block),cp_failure_level,routineP,failure) DO icor=1,3 force_ab(icor) = 0._dp CALL cp_dbcsr_get_block_p(matrix_s(icor+1,ic)%matrix,irow,icol,ds_block,found) - CPPostcondition(ASSOCIATED(ds_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ds_block),cp_failure_level,routineP,failure) IF ( irow == iatom ) THEN DO i=1,SIZE(h_block,1) DO j=1,SIZE(h_block,2) @@ -341,7 +333,7 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) IF (use_virial) THEN f0 = -1.0_dp IF(iatom==jatom) f0=-0.5_dp - CALL virial_pair_force ( virial%pv_virial, f0, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, f0, force_ab, rij) END IF END IF @@ -351,28 +343,28 @@ SUBROUTINE build_scptb_core_matrix(qs_env,calculate_forces,error) CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (scptb_kind_param,scptb_defined,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (umt,hmt,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE (atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (nspins == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix, matrix_p(2,ic)%matrix, & - alpha_scalar= 0.5_dp, beta_scalar=0.5_dp,error=error) + alpha_scalar= 0.5_dp, beta_scalar=0.5_dp) CALL cp_dbcsr_add(matrix_p(2,ic)%matrix, matrix_p(1,ic)%matrix, & - alpha_scalar=-1.0_dp, beta_scalar=1.0_dp,error=error) + alpha_scalar=-1.0_dp, beta_scalar=1.0_dp) END DO END IF END IF ! *** Put the core Hamiltonian matrix in the QS environment *** - CALL set_ks_env(ks_env, matrix_h_kp=matrix_h, error=error) + CALL set_ks_env(ks_env, matrix_h_kp=matrix_h) ! Print matrices if requested - CALL dump_info_core_hamiltonian(qs_env, calculate_forces, error) + CALL dump_info_core_hamiltonian(qs_env, calculate_forces) CALL timestop(handle) END SUBROUTINE build_scptb_core_matrix diff --git a/src/scptb_ks_matrix.F b/src/scptb_ks_matrix.F index 83663dda99..b238f5bc3d 100644 --- a/src/scptb_ks_matrix.F +++ b/src/scptb_ks_matrix.F @@ -113,12 +113,10 @@ MODULE scptb_ks_matrix !> \param qs_env ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) + SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_scptb_ks_matrix', & routineP = moduleN//':'//routineN @@ -158,8 +156,8 @@ SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) failure=.FALSE. NULLIFY(dft_control, logger, scf_section) NULLIFY(particle_set, ks_env, ks_matrixkp, rho, energy) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - logger => cp_error_get_logger(error) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + logger => cp_get_default_logger() CALL get_qs_env(qs_env,& ks_env=ks_env,& @@ -170,22 +168,21 @@ SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) rho=rho,& energy=energy,& matrix_h_kp=matrixkp_h,& - matrix_ks_kp=ks_matrixkp,& - error=error) + matrix_ks_kp=ks_matrixkp) - CPPrecondition(SIZE(ks_matrixkp,1)>0,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrixkp,2)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(ks_matrixkp,1)>0,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrixkp,2)>0,cp_failure_level,routineP,failure) - scf_section => section_vals_get_subs_vals(qs_env%input,"DFT%SCF",error=error) + scf_section => section_vals_get_subs_vals(qs_env%input,"DFT%SCF") nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) do_es = .FALSE. do_scp = .FALSE. nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=natom_kind) - CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,lmaxscp=lmaxscp) IF(lmaxscp > 0) do_scp = .TRUE. IF(lmaxscp >= 0) do_es = .TRUE. @@ -197,10 +194,10 @@ SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) IF(do_scp) do_es = .TRUE. ! copy the core matrix into the fock matrix - CPPrecondition(ASSOCIATED(matrixkp_h),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrixkp_h),cp_failure_level,routineP,failure) DO ispin=1,nspins DO ic=1,SIZE(matrixkp_h,2) - CALL cp_dbcsr_copy(ks_matrixkp(ispin,ic)%matrix,matrixkp_h(1,ic)%matrix,error=error) + CALL cp_dbcsr_copy(ks_matrixkp(ispin,ic)%matrix,matrixkp_h(1,ic)%matrix) END DO END DO @@ -208,26 +205,25 @@ SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) ! Mulliken charges CALL get_qs_env(qs_env,& particle_set=particle_set,& - matrix_s_kp=matrixkp_s,& - error=error) - CALL qs_rho_get(rho,rho_ao_kp=matrixkp_p,error=error) + matrix_s_kp=matrixkp_s) + CALL qs_rho_get(rho,rho_ao_kp=matrixkp_p) natom=SIZE(particle_set) ALLOCATE(charges(natom,nspins),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(mcharge(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(dmcharge(natom,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(calculate_forces) THEN - CALL mulliken_charges(matrixkp_p,matrixkp_s,para_env,charges,dmcharge,error=error) + CALL mulliken_charges(matrixkp_p,matrixkp_s,para_env,charges,dmcharge) ELSE charges = 0._dp - CALL mulliken_charges(matrixkp_p,matrixkp_s,para_env,charges,error=error) + CALL mulliken_charges(matrixkp_p,matrixkp_s,para_env,charges) END IF nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=natom_kind) - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,zeff=zeff) DO iatom=1,natom_kind atom_a = atomic_kind_set(ikind)%atom_list(iatom) @@ -235,18 +231,18 @@ SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) END DO END DO DEALLOCATE(charges,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (do_scp) THEN - CALL scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,calculate_forces,just_energy,error) + CALL scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,calculate_forces,just_energy) ELSE - CALL tb_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,calculate_forces,just_energy,error) + CALL tb_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,calculate_forces,just_energy) END IF DEALLOCATE(mcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(dmcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ELSE energy%hartree = 0._dp END IF @@ -255,7 +251,7 @@ SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) energy%dispersion output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%DETAILED_ENERGY",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,(T9,A,T60,F20.10))")& "Repulsive pair potential energy: ",energy%repulsive,& @@ -269,18 +265,18 @@ SUBROUTINE build_scptb_ks_matrix(qs_env,calculate_forces,just_energy,error) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%DETAILED_ENERGY", error=error) + "PRINT%DETAILED_ENERGY") ! here we compute dE/dC if needed. Assumes dE/dC is H_{ks}C (plus occupation numbers) IF (qs_env%requires_mo_derivs .AND. .NOT. just_energy) THEN - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array,error=error) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array) DO ispin=1,SIZE(mo_derivs) CALL get_mo_set(mo_set=mo_array(ispin)%mo_set,& mo_coeff_b=mo_coeff, occupation_numbers=occupation_numbers ) IF(.NOT.mo_array(ispin)%mo_set%use_mo_coeff_b) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL cp_dbcsr_multiply('n','n',1.0_dp,ks_matrixkp(1,ispin)%matrix,mo_coeff,& - 0.0_dp,mo_derivs(ispin)%matrix, error=error) + 0.0_dp,mo_derivs(ispin)%matrix) ENDDO ENDIF @@ -298,9 +294,8 @@ END SUBROUTINE build_scptb_ks_matrix !> \param mcharge ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,just_energy,error) + SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -309,7 +304,6 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus REAL(KIND=dp), DIMENSION(:), & INTENT(inout) :: mcharge LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tb_coulomb', & routineP = moduleN//':'//routineN @@ -363,15 +357,15 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus NULLIFY(virial, atprop) CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,virial=virial,atprop=atprop,& - energy=energy,para_env=para_env,particle_set=particle_set,cell=cell,error=error) + energy=energy,para_env=para_env,particle_set=particle_set,cell=cell) CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& - local_particles=local_particles,natom=natom,error=error) + local_particles=local_particles,natom=natom) scptb_control => dft_control%qs_control%scptb_control use_virial=.FALSE. ndim = 1 IF (calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,force=force) ndim = 4 use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer).AND.scptb_control%do_ewald END IF @@ -380,8 +374,8 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus NULLIFY(cell_to_index) IF (nimg>1) THEN NULLIFY(kpoints) - CALL get_qs_env(qs_env=qs_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_qs_env(qs_env=qs_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) END IF energy%hartree = 0._dp @@ -391,29 +385,29 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus IF ( chabs > 1.e-8_dp ) THEN IF(scptb_control%do_ewald) THEN ALLOCATE(gmcharge(natom,ndim),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) gmcharge = 0._dp ! Ewald sum NULLIFY(ewald_env,ewald_pw) - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw,error=error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) CALL get_cell(cell=cell,periodic=periodic,deth=deth) - CALL ewald_env_get(ewald_env,alpha=alpha,ewald_type=ewald_type,error=error) - CALL get_qs_env(qs_env=qs_env,sab_tbe=n_list,error=error) + CALL ewald_env_get(ewald_env,alpha=alpha,ewald_type=ewald_type) + CALL get_qs_env(qs_env=qs_env,sab_tbe=n_list) CALL dftb_ewald_overlap(gmcharge,mcharge,alpha,n_list,& - virial,use_virial,atprop,error=error) + virial,use_virial,atprop) SELECT CASE(ewald_type) CASE DEFAULT - CALL cp_unimplemented_error(routineP,"Invalid Ewald type",error) + CALL cp_unimplemented_error(routineP,"Invalid Ewald type") CASE(do_ewald_none) - CPErrorMessage(cp_failure_level,routineP,"Not allowed with SCPTB",error) - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPErrorMessage(cp_failure_level,routineP,"Not allowed with SCPTB") + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE(do_ewald_ewald) - CALL cp_unimplemented_error(routineP,"Standard Ewald not implemented in SCPTB",error) + CALL cp_unimplemented_error(routineP,"Standard Ewald not implemented in SCPTB") CASE(do_ewald_pme) - CALL cp_unimplemented_error(routineP,"PME not implemented in SCPTB",error) + CALL cp_unimplemented_error(routineP,"PME not implemented in SCPTB") CASE(do_ewald_spme) CALL dftb_spme_evaluate(ewald_env,ewald_pw,particle_set,cell,& - gmcharge,mcharge,calculate_forces,virial,use_virial,atprop,error) + gmcharge,mcharge,calculate_forces,virial,use_virial,atprop) END SELECT ! add self charge interaction and background charge contribution @@ -425,7 +419,7 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus energy%hartree = energy%hartree + 0.5_dp*SUM(mcharge(:)*gmcharge(:,1)) IF ( calculate_forces ) THEN ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind) @@ -441,17 +435,17 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus END DO END IF IF ( .NOT. just_energy ) THEN - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) IF ( calculate_forces .AND. SIZE(matrix_p,1) == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END DO END IF nsize = SIZE(ks_matrix,1) NULLIFY(n_list) - CALL get_qs_env(qs_env=qs_env,sab_orb=n_list,error=error) + CALL get_qs_env(qs_env=qs_env,sab_orb=n_list) CALL neighbor_list_iterator_create(nl_iterator,n_list) DO WHILE (neighbor_list_iterate(nl_iterator)==0) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,& @@ -464,19 +458,19 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus ic = 1 ELSE ic = cell_to_index(cellind(1),cellind(2),cellind(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) END IF gmij = 0.5_dp*(gmcharge(iatom,1)+gmcharge(jatom,1)) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1,ic)%matrix,& row=irow,col=icol,block=sblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO is=1,nsize NULLIFY(ksblock) CALL cp_dbcsr_get_block_p(matrix=ks_matrix(is,ic)%matrix,& row=irow,col=icol,block=ksblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ksblock = ksblock - gmij*sblock END DO IF ( calculate_forces .AND. iatom /= jatom ) THEN @@ -487,22 +481,22 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1,ic)%matrix,& row=irow,col=icol,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO i=1,3 NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i,ic)%matrix,& row=irow,col=icol,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) fi = -gmij*SUM(pblock*dsblock)*2.0_dp force(ikind)%rho_elec(i,iat) = force(ikind)%rho_elec(i,iat) + fi force(jkind)%rho_elec(i,jat) = force(jkind)%rho_elec(i,jat) - fi fij(i) = fi END DO IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij, error) + CALL virial_pair_force ( virial%pv_virial, 1._dp, fij, rij) IF (atprop%stress) THEN - CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij, error) - CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij, error) + CALL virial_pair_force (atprop%atstress(:,:,iatom), 0.5_dp, fij, rij) + CALL virial_pair_force (atprop%atstress(:,:,jatom), 0.5_dp, fij, rij) END IF END IF END IF @@ -513,7 +507,7 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus IF ( calculate_forces .AND. SIZE(matrix_p,1) == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END DO END IF END IF @@ -522,16 +516,16 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus ehartree = 0._dp IF(.NOT.just_energy .OR. calculate_forces) THEN ALLOCATE(qcharge(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qcharge = 0._dp END IF IF (calculate_forces) THEN ALLOCATE(drcharge(3,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) drcharge = 0._dp END IF NULLIFY(n_list) - CALL get_qs_env(qs_env=qs_env,sab_scp=n_list,error=error) + CALL get_qs_env(qs_env=qs_env,sab_scp=n_list) CALL neighbor_list_iterator_create(nl_iterator,n_list) DO WHILE (neighbor_list_iterate(nl_iterator)==0) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,iatom=iatom,jatom=jatom,r=rij) @@ -539,11 +533,11 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus dr2 = SUM(rij(:)**2) dr = SQRT(dr2) IF (dr > 1.e-10) THEN - CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,lmaxscp=lmaxscp,ag=alpha) IF (lmaxscp < 0) CYCLE noa = (alpha/pi)**1.5_dp - CALL get_qs_kind(qs_kind_set(jkind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(jkind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,lmaxscp=lmaxscp,ag=beta) IF (lmaxscp < 0) CYCLE eta = alpha*beta/(alpha+beta) @@ -569,7 +563,7 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus IF (use_virial) THEN fij(:) = ff*rij(:)*mcharge(iatom)*mcharge(jatom) + & rij(:)/(dr*dr2)*mcharge(iatom)*mcharge(jatom) - CALL virial_pair_force ( virial%pv_virial, -1._dp, fij, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fij, rij) END IF END IF @@ -582,11 +576,11 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus IF(.NOT.just_energy.OR.calculate_forces) THEN IF ( calculate_forces ) THEN - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) IF (SIZE(matrix_p,1) == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END DO END IF END IF @@ -594,7 +588,7 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus CALL mp_sum(qcharge,para_env%group) NULLIFY(n_list) - CALL get_qs_env(qs_env=qs_env,sab_orb=n_list,error=error) + CALL get_qs_env(qs_env=qs_env,sab_orb=n_list) CALL neighbor_list_iterator_create(nl_iterator,n_list) DO WHILE (neighbor_list_iterate(nl_iterator)==0) CALL get_iterator_info(nl_iterator,ikind=ikind,jkind=jkind,& @@ -607,19 +601,19 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus ic = 1 ELSE ic = cell_to_index(cellind(1),cellind(2),cellind(3)) - CPPostcondition(ic > 0,cp_failure_level,routineP,error,failure) + CPPostcondition(ic > 0,cp_failure_level,routineP,failure) END IF dq = qcharge(iatom)+qcharge(jatom) IF(.NOT.just_energy) THEN CALL cp_dbcsr_get_block_p(matrix=matrix_s(1,ic)%matrix,& row=irow,col=icol,block=sblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO is=1,nsize NULLIFY(ksblock) CALL cp_dbcsr_get_block_p(matrix=ks_matrix(is,ic)%matrix,& row=irow,col=icol,block=ksblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ksblock = ksblock - 0.5_dp*dq*sblock END DO END IF @@ -631,18 +625,18 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1,ic)%matrix,& row=irow,col=icol,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO i=1,3 NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i,ic)%matrix,& row=irow,col=icol,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) fij(i) = dq*SUM(pblock*dsblock) force(ikind)%rho_elec(i,iat) = force(ikind)%rho_elec(i,iat) - fij(i) force(jkind)%rho_elec(i,jat) = force(jkind)%rho_elec(i,jat) + fij(i) END DO IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1._dp, fij, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1._dp, fij, rij) END IF END IF @@ -660,52 +654,52 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus IF (SIZE(matrix_p,1) == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END DO END IF END IF END IF DEALLOCATE(gmcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(.NOT.just_energy .OR. calculate_forces) THEN DEALLOCATE(qcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF ( calculate_forces ) THEN DEALLOCATE(drcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (atom_of_kind,kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ELSE ! direct sum IF (nimg > 1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="SCPTB direct sum electrostatic cannot be used with k-points.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF(.NOT.just_energy .OR. calculate_forces) THEN ALLOCATE(qcharge(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) qcharge = 0._dp END IF IF (calculate_forces) THEN ALLOCATE(drcharge(3,natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) drcharge = 0._dp END IF nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nai,atom_list=atomi_list) - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,defined=defined,lmaxscp=lmaxscp,ag=alpha) IF (.NOT.defined) CYCLE IF (lmaxscp < 0) CYCLE noa = (alpha/pi)**1.5_dp DO jkind=1,ikind CALL get_atomic_kind(atomic_kind_set(jkind),natom=naj,atom_list=atomj_list) - CALL get_qs_kind(qs_kind_set(jkind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(jkind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,defined=defined,lmaxscp=lmaxscp,ag=beta) eta = alpha*beta/(alpha+beta) f0 = 2.0_dp*SQRT(pi**5/(alpha+beta))/(alpha*beta) @@ -741,15 +735,15 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus IF(.NOT.just_energy.OR.calculate_forces) THEN CALL mp_sum(qcharge,para_env%group) ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, & kind_of=kind_of, atom_of_kind=atom_of_kind) IF ( calculate_forces ) THEN - CALL qs_rho_get(rho, rho_ao_kp=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao_kp=matrix_p) IF (SIZE(matrix_p,1) == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END DO END IF END IF @@ -765,7 +759,7 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus NULLIFY(ksblock) CALL cp_dbcsr_get_block_p(matrix=ks_matrix(is,1)%matrix,& row=iatom,col=jatom,block=ksblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ksblock = ksblock - 0.5_dp*dq*sblock END DO END IF @@ -777,12 +771,12 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1,1)%matrix,& row=iatom,col=jatom,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO i=1,3 NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i,1)%matrix,& row=iatom,col=jatom,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) fi = dq*SUM(pblock*dsblock) force(ikind)%rho_elec(i,iat) = force(ikind)%rho_elec(i,iat) - fi force(jkind)%rho_elec(i,jat) = force(jkind)%rho_elec(i,jat) + fi @@ -800,19 +794,19 @@ SUBROUTINE tb_coulomb(qs_env,ks_matrix,matrix_s,rho,mcharge,calculate_forces,jus force(ikind)%rho_elec(3,iat) = force(ikind)%rho_elec(3,iat) + drcharge(3,iatom) END DO DEALLOCATE(drcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF (SIZE(matrix_p,1) == 2) THEN DO ic=1,nimg CALL cp_dbcsr_add(matrix_p(1,ic)%matrix,matrix_p(2,ic)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END DO END IF END IF DEALLOCATE (atom_of_kind,kind_of,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(qcharge,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -829,10 +823,9 @@ END SUBROUTINE tb_coulomb !> \param mcharge ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... ! ***************************************************************************** SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& - calculate_forces,just_energy,error) + calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -841,7 +834,6 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& REAL(KIND=dp), DIMENSION(:), & INTENT(inout) :: mcharge LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_coulomb', & routineP = moduleN//':'//routineN @@ -884,12 +876,12 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,& do_kpoints=do_kpoints,& - energy=energy,force=force,para_env=para_env,error=error) + energy=energy,force=force,para_env=para_env) IF(do_kpoints) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="SCPTB not implemented with k-points.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF NULLIFY(ks_matrix,matrix_s) @@ -900,7 +892,7 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& natom = SIZE(mcharge,1) ALLOCATE(charges(natom),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) dqv = 1._dp/SQRT(4._dp*pi) charges(:) = mcharge*dqv scptb_control => dft_control%qs_control%scptb_control @@ -908,13 +900,13 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& NULLIFY(cvec,cpol,cself,cp,cw) ! Create scp vectors - CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,error=error) + CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set) nkind = SIZE(atomic_kind_set) ALLOCATE(nbasis(nkind),natoms(nkind),lscp(nkind),zeta(nkind),adef(nkind),stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=nat) - CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,defined=defined,lmaxscp=lmaxscp,ag=alpha) IF(defined) THEN norb = (lmaxscp+1)**2 @@ -928,18 +920,18 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& adef(ikind) = defined END DO NULLIFY(cvec,cself,cpol,cp,cw) - CALL scp_vector_create(cvec, nkind, natoms, nbasis, error) - CALL scp_vector_set(cvec, 0._dp, error) - CALL scp_vector_create(cself, nkind, natoms, nbasis, error) - CALL scp_vector_set(cself, 0._dp, error) - CALL scp_vector_create(cpol, nkind, natoms, nbasis, error) - CALL scp_vector_set(cpol, 0._dp, error) + CALL scp_vector_create(cvec, nkind, natoms, nbasis) + CALL scp_vector_set(cvec, 0._dp) + CALL scp_vector_create(cself, nkind, natoms, nbasis) + CALL scp_vector_set(cself, 0._dp) + CALL scp_vector_create(cpol, nkind, natoms, nbasis) + CALL scp_vector_set(cpol, 0._dp) ! set vector of multipoles CALL scp_set_charge(cvec,charges,adef,natoms,atomic_kind_set) DO ikind=1,nkind IF(adef(ikind)) THEN CALL get_atomic_kind(atomic_kind_set(ikind),natom=nat) - CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind),scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,pol=pol) alpha = zeta(ikind) DO iat=1,natoms(ikind) @@ -958,24 +950,24 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& ! Calclulate scp vector DO iat=1,ndiis NULLIFY(cval(iat)%vec,cres(iat)%vec) - CALL scp_vector_create(cval(iat)%vec, nkind, natoms, nbasis, error) - CALL scp_vector_create(cres(iat)%vec, nkind, natoms, nbasis, error) + CALL scp_vector_create(cval(iat)%vec, nkind, natoms, nbasis) + CALL scp_vector_create(cres(iat)%vec, nkind, natoms, nbasis) END DO - CALL scp_vector_create(cp, nkind, natoms, nbasis, error) - CALL scp_vector_create(cw, nkind, natoms, nbasis, error) + CALL scp_vector_create(cp, nkind, natoms, nbasis) + CALL scp_vector_create(cw, nkind, natoms, nbasis) kmax = MIN(SUM(nbasis),100) * 10 mdiis = 0 DO kint=1,kmax mdiis = MIN(mdiis + 1, ndiis) mpos = MOD(kint-1,ndiis) + 1 - CALL scp_vector_set(cw, 0._dp, error) + CALL scp_vector_set(cw, 0._dp) CALL apply_scp_vector(cvec,cw,cself,cpol,cp,qs_env,scptb_control%do_ewald,& - calculate_forces=.FALSE.,error=error) + calculate_forces=.FALSE.) rhom1 = scp_dot(cw,cw) IF ( SQRT(rhom1) < epsrel ) EXIT - CALL scp_vector_copy(cvec, cval(mpos)%vec, error) - CALL scp_vector_copy(cw, cres(mpos)%vec, error) + CALL scp_vector_copy(cvec, cval(mpos)%vec) + CALL scp_vector_copy(cw, cres(mpos)%vec) IF (mdiis > 100) THEN vdiis = 0._dp vdiis(mdiis+1,1) = 1._dp @@ -989,41 +981,41 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& END DO END DO CALL solve_system ( bdiis, mdiis+1, vdiis ) - CALL scp_vector_set(cvec, 0._dp, error) + CALL scp_vector_set(cvec, 0._dp) DO i=1,mdiis - CALL scp_vector_add(vdiis(i,1), cval(i)%vec, cvec, error) + CALL scp_vector_add(vdiis(i,1), cval(i)%vec, cvec) END DO ELSE - CALL scp_vector_add(-0.1_dp, cw, cvec, error) + CALL scp_vector_add(-0.1_dp, cw, cvec) END IF CALL scp_set_charge(cvec,charges,adef,natoms,atomic_kind_set) END DO DO iat=1,ndiis - CALL scp_vector_release(cval(iat)%vec, error) - CALL scp_vector_release(cres(iat)%vec, error) + CALL scp_vector_release(cval(iat)%vec) + CALL scp_vector_release(cres(iat)%vec) END DO ! SCP energy - CALL scp_vector_set(cw, 0._dp, error) + CALL scp_vector_set(cw, 0._dp) IF (calculate_forces) THEN CALL apply_scp_vector(cvec,cw,cself,cpol,cp,qs_env,scptb_control%do_ewald,& - calculate_forces=.TRUE.,error=error) + calculate_forces=.TRUE.) ELSE CALL apply_scp_vector(cvec,cw,cself,cpol,cp,qs_env,scptb_control%do_ewald,& - calculate_forces=.FALSE.,error=error) + calculate_forces=.FALSE.) END IF - CALL scp_vector_dot(ak, cw, cvec, error) + CALL scp_vector_dot(ak, cw, cvec) energy%hartree = 0.5_dp*ak IF (.NOT.just_energy) THEN ALLOCATE (atom_of_kind(natom),kind_of(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind) IF ( calculate_forces ) THEN - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao=matrix_p) IF (SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=1.0_dp) END IF END IF @@ -1047,7 +1039,7 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& NULLIFY(pblock) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1)%matrix,& row=iatom,col=jatom,block=pblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) dq = (cw%vector(ikind)%vmat(1,iat) + & cw%vector(ikind)%vmat(1,iat) * cself%vector(ikind)%vmat(1,iat) + & cw%vector(jkind)%vmat(1,jat) + & @@ -1056,7 +1048,7 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& NULLIFY(dsblock) CALL cp_dbcsr_get_block_p(matrix=matrix_s(1+i)%matrix,& row=iatom,col=jatom,block=dsblock,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) fi = dq*SUM(pblock*dsblock) !deb what about these forces? ! force(ikind)%rho_elec(i,iat) = force(ikind)%rho_elec(i,iat) + fi @@ -1069,19 +1061,19 @@ SUBROUTINE scp_coulomb(qs_env,ks_matrixkp,matrixkp_s,rho,mcharge,& IF (calculate_forces) THEN IF (SIZE(matrix_p) == 2) THEN CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,& - alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END IF END IF END IF - CALL scp_vector_release(cself, error) - CALL scp_vector_release(cvec, error) - CALL scp_vector_release(cpol, error) - CALL scp_vector_release(cw, error) - CALL scp_vector_release(cp, error) + CALL scp_vector_release(cself) + CALL scp_vector_release(cvec) + CALL scp_vector_release(cpol) + CALL scp_vector_release(cw) + CALL scp_vector_release(cp) DEALLOCATE(nbasis,natoms,lscp,zeta,adef,charges,stat=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE scp_coulomb @@ -1177,14 +1169,12 @@ END SUBROUTINE scp_print !> \param qs_env ... !> \param do_ewald ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_forces,error) + SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_forces) TYPE(scp_vector_type), POINTER :: cin, cout, cself, cpol, cdum TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in) :: do_ewald, calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'apply_scp_vector', & routineP = moduleN//':'//routineN @@ -1225,44 +1215,44 @@ SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_f TYPE(virial_type), POINTER :: virial failure = .FALSE. - CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,force=force,virial=virial,para_env=para_env,error=error) + CALL get_qs_env(qs_env=qs_env,pw_env=pw_env,force=force,virial=virial,para_env=para_env) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) IF (do_ewald) THEN CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,poisson_env=poisson_env,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool,scp_rho%pw,use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool,scp_pot%pw,use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) - CALL pw_pool_create_pw(auxbas_pw_pool,scp_rho_g%pw,use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,error=error) + pw_pools=pw_pools,poisson_env=poisson_env) + CALL pw_pool_create_pw(auxbas_pw_pool,scp_rho%pw,use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_pool_create_pw(auxbas_pw_pool,scp_pot%pw,use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL pw_pool_create_pw(auxbas_pw_pool,scp_rho_g%pw,use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) - CALL calculate_scp_charge(scp_rho,qs_env,cin,error) - CALL pw_transfer(scp_rho%pw, scp_rho_g%pw, error=error) + CALL calculate_scp_charge(scp_rho,qs_env,cin) + CALL pw_transfer(scp_rho%pw, scp_rho_g%pw) ! Getting the Hartree energy and Hartree potential. Also getting the stress tensor ! from the Hartree term if needed. IF (use_virial .AND. calculate_forces) THEN h_stress(:,:) = 0.0_dp - CALL pw_poisson_solve(poisson_env,scp_rho_g%pw,ehartree,scp_pot%pw,h_stress=h_stress,error=error) + CALL pw_poisson_solve(poisson_env,scp_rho_g%pw,ehartree,scp_pot%pw,h_stress=h_stress) virial%pv_virial = virial%pv_virial + h_stress/REAL(para_env%num_pe,dp) ELSE - CALL pw_poisson_solve(poisson_env,scp_rho_g%pw,ehartree,scp_pot%pw,error=error) + CALL pw_poisson_solve(poisson_env,scp_rho_g%pw,ehartree,scp_pot%pw) END IF - CALL pw_pool_give_back_pw(auxbas_pw_pool,scp_rho_g%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,scp_rho_g%pw) - CALL pw_transfer(scp_pot%pw,scp_rho%pw,error=error) - CALL integrate_scp_rspace(scp_rho,qs_env,cout,calculate_forces,error) + CALL pw_transfer(scp_pot%pw,scp_rho%pw) + CALL integrate_scp_rspace(scp_rho,qs_env,cout,calculate_forces) - CALL pw_pool_give_back_pw(auxbas_pw_pool,scp_rho%pw,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,scp_pot%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,scp_rho%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,scp_pot%pw) ELSE ! direct sum NULLIFY(atomic_kind_set,qs_kind_set,particle_set,cell) CALL get_qs_env(qs_env=qs_env,atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,& - particle_set=particle_set,cell=cell,error=error) + particle_set=particle_set,cell=cell) nkind = SIZE(atomic_kind_set) DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind),natom=nai,atom_list=atomi_list) - CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,defined=defined,lmaxscp=lmaxscp,ag=alpha) IF (.NOT.defined) CYCLE IF (lmaxscp < 0) CYCLE @@ -1273,7 +1263,7 @@ SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_f CALL calc_norm(normi,li,alpha) DO jkind=1,ikind CALL get_atomic_kind(atomic_kind_set(jkind), natom=naj,atom_list=atomj_list) - CALL get_qs_kind(qs_kind_set(jkind), scptb_parameter=scptb_kind, error=error) + CALL get_qs_kind(qs_kind_set(jkind), scptb_parameter=scptb_kind) CALL get_scptb_parameter(scptb_kind,defined=defined,lmaxscp=lmaxscp,ag=beta) IF (.NOT.defined) CYCLE IF (lmaxscp < 0) CYCLE @@ -1282,10 +1272,10 @@ SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_f coj => cout%vector(jkind)%vmat cij => cin%vector(jkind)%vmat ALLOCATE (aintegral(ni,nj),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(calculate_forces) THEN ALLOCATE (daintegral(ni,nj,3),paint(ni,nj),maint(ni,nj),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL calc_norm(normj,lj,beta) DO iatom=1,nai @@ -1295,7 +1285,7 @@ SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_f IF(ikind==jkind .AND. jatom > iatom) CYCLE rij = particle_set(ia)%r - particle_set(ja)%r rij = pbc(rij,cell) - CALL calc_int(aintegral,rij,alpha,li,beta,lj,error) + CALL calc_int(aintegral,rij,alpha,li,beta,lj) ! add normalization constants to integrals DO j=1,nj DO i=1,ni @@ -1310,9 +1300,9 @@ SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_f DO i=1,3 drij = rij drij(i) = drij(i) + dr - CALL calc_int(paint,drij,alpha,li,beta,lj,error) + CALL calc_int(paint,drij,alpha,li,beta,lj) drij(i) = drij(i) - 2.0_dp*dr - CALL calc_int(maint,drij,alpha,li,beta,lj,error) + CALL calc_int(maint,drij,alpha,li,beta,lj) daintegral(:,:,i) = (paint - maint)/(2.0_dp*dr) END DO DO j=1,nj @@ -1331,10 +1321,10 @@ SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_f END DO END DO DEALLOCATE (aintegral,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(calculate_forces) THEN DEALLOCATE (daintegral,paint,maint,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END DO END DO @@ -1342,13 +1332,13 @@ SUBROUTINE apply_scp_vector(cin,cout,cself,cpol,cdum,qs_env,do_ewald,calculate_f END IF ! remove self interaction - CALL scp_vector_copy(cself, cdum, error) - CALL scp_vector_mult(cin, cdum, error) - CALL scp_vector_add(-1._dp, cdum, cout, error) + CALL scp_vector_copy(cself, cdum) + CALL scp_vector_mult(cin, cdum) + CALL scp_vector_add(-1._dp, cdum, cout) ! add scp polarization - CALL scp_vector_copy(cpol, cdum, error) - CALL scp_vector_mult(cin, cdum, error) - CALL scp_vector_add(1._dp, cdum, cout, error) + CALL scp_vector_copy(cpol, cdum) + CALL scp_vector_mult(cin, cdum) + CALL scp_vector_add(1._dp, cdum, cout) END SUBROUTINE apply_scp_vector @@ -1360,9 +1350,8 @@ END SUBROUTINE apply_scp_vector !> \param li ... !> \param beta ... !> \param lj ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calc_int(aintegral,rij,alpha,li,beta,lj,error) + SUBROUTINE calc_int(aintegral,rij,alpha,li,beta,lj) REAL(KIND=dp), DIMENSION(:, :), & INTENT(inout) :: aintegral @@ -1371,7 +1360,6 @@ SUBROUTINE calc_int(aintegral,rij,alpha,li,beta,lj,error) INTEGER, INTENT(IN) :: li REAL(KIND=dp), INTENT(IN) :: beta INTEGER, INTENT(IN) :: lj - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_int', & routineP = moduleN//':'//routineN @@ -1394,7 +1382,7 @@ SUBROUTINE calc_int(aintegral,rij,alpha,li,beta,lj,error) ni = ncoset(li) nj = ncoset(lj) ALLOCATE (vij(ni,nj),v(ni,nj,nl),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! cartesian integrals CALL coulomb2_new(li,1,zi,0,lj,1,zj,0,rij,dr2,vij,v,f) @@ -1405,7 +1393,7 @@ SUBROUTINE calc_int(aintegral,rij,alpha,li,beta,lj,error) aintegral(1:mi,1:mj) = MATMUL(c2s_tramat(1:mi,1:ni),v(1:ni,1:mj,1)) DEALLOCATE (vij,v,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE calc_int diff --git a/src/scptb_parameters.F b/src/scptb_parameters.F index 1d7a3d892c..d762105103 100644 --- a/src/scptb_parameters.F +++ b/src/scptb_parameters.F @@ -41,12 +41,10 @@ MODULE scptb_parameters ! ***************************************************************************** !> \brief Default parameter sets for SCPTB method !> \param param ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_default_parameter ( param, error) + SUBROUTINE scptb_default_parameter ( param) TYPE(scptb_parameter_type), & INTENT(INOUT) :: param - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scptb_default_parameter', & routineP = moduleN//':'//routineN @@ -57,7 +55,7 @@ SUBROUTINE scptb_default_parameter ( param, error) param%parameterization = "UZH.00.00" SELECT CASE (TRIM(param%key)) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE ("XX") param%defined = .TRUE. CASE ("H") diff --git a/src/scptb_types.F b/src/scptb_types.F index 1c6db385d8..a6bfa2f282 100644 --- a/src/scptb_types.F +++ b/src/scptb_types.F @@ -100,12 +100,10 @@ MODULE scptb_types ! ***************************************************************************** !> \brief ... !> \param scptb_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_scptb_parameter(scptb_parameter,error) + SUBROUTINE allocate_scptb_parameter(scptb_parameter) TYPE(scptb_parameter_type), POINTER :: scptb_parameter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_scptb_parameter', & routineP = moduleN//':'//routineN @@ -114,10 +112,10 @@ SUBROUTINE allocate_scptb_parameter(scptb_parameter,error) LOGICAL :: failure IF (ASSOCIATED(scptb_parameter)) & - CALL deallocate_scptb_parameter(scptb_parameter,error) + CALL deallocate_scptb_parameter(scptb_parameter) ALLOCATE (scptb_parameter,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) scptb_parameter % key = "" scptb_parameter % parameterization = "" @@ -144,12 +142,10 @@ END SUBROUTINE allocate_scptb_parameter ! ***************************************************************************** !> \brief ... !> \param scptb_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_scptb_parameter(scptb_parameter,error) + SUBROUTINE deallocate_scptb_parameter(scptb_parameter) TYPE(scptb_parameter_type), POINTER :: scptb_parameter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_scptb_parameter', & routineP = moduleN//':'//routineN @@ -157,9 +153,9 @@ SUBROUTINE deallocate_scptb_parameter(scptb_parameter,error) INTEGER :: istat LOGICAL :: failure - CPPrecondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,failure) DEALLOCATE (scptb_parameter,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_scptb_parameter @@ -185,10 +181,9 @@ END SUBROUTINE deallocate_scptb_parameter !> \param pol ... !> \param ag ... !> \param rcpair ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_scptb_parameter(scptb_parameter,key,atomname,parameterization,defined,z,zeff,natorb,& - lmaxorb,lmaxscp,norb,nqm,zeta,hcore,occupation,energy,crep,pol,ag,rcpair,error) + lmaxorb,lmaxscp,norb,nqm,zeta,hcore,occupation,energy,crep,pol,ag,rcpair) TYPE(scptb_parameter_type), POINTER :: scptb_parameter CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: key, atomname, & @@ -205,15 +200,13 @@ SUBROUTINE get_scptb_parameter(scptb_parameter,key,atomname,parameterization,def REAL(KIND=dp), DIMENSION(3), OPTIONAL :: crep REAL(KIND=dp), DIMENSION(1:3), OPTIONAL :: pol REAL(KIND=dp), OPTIONAL :: ag, rcpair - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_scptb_parameter', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,failure) IF (PRESENT(key)) key = scptb_parameter%key IF (PRESENT(atomname)) atomname = scptb_parameter%atomname @@ -259,10 +252,9 @@ END SUBROUTINE get_scptb_parameter !> \param pol ... !> \param ag ... !> \param rcpair ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_scptb_parameter(scptb_parameter,key,atomname,parameterization,defined,z,zeff,natorb,& - lmaxorb,lmaxscp,norb,nqm,zeta,hcore,occupation,energy,crep,pol,ag,rcpair,error) + lmaxorb,lmaxscp,norb,nqm,zeta,hcore,occupation,energy,crep,pol,ag,rcpair) TYPE(scptb_parameter_type), POINTER :: scptb_parameter CHARACTER(LEN=*), OPTIONAL :: key, atomname, & @@ -279,15 +271,13 @@ SUBROUTINE set_scptb_parameter(scptb_parameter,key,atomname,parameterization,def REAL(KIND=dp), DIMENSION(3), OPTIONAL :: crep REAL(KIND=dp), DIMENSION(1:3), OPTIONAL :: pol REAL(KIND=dp), OPTIONAL :: ag, rcpair - TYPE(cp_error_type), INTENT(INOUT), & - OPTIONAL :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_scptb_parameter', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(scptb_parameter),cp_failure_level,routineP,failure) IF (PRESENT(key)) scptb_parameter%key = key IF (PRESENT(atomname)) scptb_parameter%atomname = atomname @@ -315,13 +305,11 @@ END SUBROUTINE set_scptb_parameter !> \brief ... !> \param scptb_parameter ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_scptb_parameter(scptb_parameter,section,error) + SUBROUTINE write_scptb_parameter(scptb_parameter,section) TYPE(scptb_parameter_type), POINTER :: scptb_parameter TYPE(section_vals_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_scptb_parameter', & routineP = moduleN//':'//routineN @@ -340,17 +328,17 @@ SUBROUTINE write_scptb_parameter(scptb_parameter,section,error) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(scptb_parameter).AND.& BTEST(cp_print_key_should_output(logger%iter_info,section,& - "PRINT%KINDS/POTENTIAL",error=error),cp_p_file)) THEN + "PRINT%KINDS/POTENTIAL"),cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,section,"PRINT%KINDS",& - extension=".Log",error=error) + extension=".Log") IF (output_unit >0) THEN CALL get_scptb_parameter(scptb_parameter,key=key,atomname=atomname,& - parameterization=parameterization,defined=defined,error=error) + parameterization=parameterization,defined=defined) WRITE (UNIT=output_unit,FMT="(/,T10,A,T67,A14)") " SCPTB parameters: ",TRIM(atomname) WRITE (UNIT=output_unit,FMT="(T67,A14)") TRIM(key) @@ -359,8 +347,7 @@ SUBROUTINE write_scptb_parameter(scptb_parameter,section,error) CALL get_scptb_parameter(scptb_parameter,& zeff=zeff,natorb=natorb,lmaxorb=lmaxorb,lmaxscp=lmaxscp,& norb=norb,nqm=nqm,zeta=zeta,hcore=hcore,& - energy=energy,crep=crep,pol=pol,ag=ag,rcpair=rcpair,& - error=error) + energy=energy,crep=crep,pol=pol,ag=ag,rcpair=rcpair) WRITE (UNIT=output_unit,FMT="(T16,A,T71,F10.2)") "Effective core charge:",zeff WRITE (UNIT=output_unit,FMT="(T16,A,T71,I10)") "Total number of orbitals:",natorb WRITE (UNIT=output_unit,FMT="(T16,A,T30,A,T71,A)") "l-QM n-QM i","Exponent","H core" @@ -381,7 +368,7 @@ SUBROUTINE write_scptb_parameter(scptb_parameter,section,error) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,section,& - "PRINT%KINDS",error=error) + "PRINT%KINDS") END IF END SUBROUTINE write_scptb_parameter @@ -392,13 +379,11 @@ END SUBROUTINE write_scptb_parameter !> \param nkind ... !> \param natoms ... !> \param nbasis ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_create(scp_vec, nkind, natoms, nbasis, error) + SUBROUTINE scp_vector_create(scp_vec, nkind, natoms, nbasis) TYPE(scp_vector_type), POINTER :: scp_vec INTEGER, INTENT(IN) :: nkind INTEGER, DIMENSION(:), INTENT(IN) :: natoms, nbasis - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_create', & routineP = moduleN//':'//routineN @@ -406,12 +391,12 @@ SUBROUTINE scp_vector_create(scp_vec, nkind, natoms, nbasis, error) INTEGER :: ikind, istat, tl LOGICAL :: failure - CALL scp_vector_release(scp_vec, error) + CALL scp_vector_release(scp_vec) ALLOCATE(scp_vec,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(scp_vec%vector(nkind),stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) tl=0 DO ikind=1,nkind @@ -419,7 +404,7 @@ SUBROUTINE scp_vector_create(scp_vec, nkind, natoms, nbasis, error) scp_vec%vector(ikind)%nbasis = nbasis(ikind) tl=tl+natoms(ikind)*nbasis(ikind) ALLOCATE(scp_vec%vector(ikind)%vmat(nbasis(ikind),natoms(ikind)),stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) scp_vec%vector(ikind)%vmat=0._dp END DO scp_vec%total_length = tl @@ -429,11 +414,9 @@ END SUBROUTINE scp_vector_create ! ***************************************************************************** !> \brief ... !> \param scp_vec ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_release(scp_vec, error) + SUBROUTINE scp_vector_release(scp_vec) TYPE(scp_vector_type), POINTER :: scp_vec - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_release', & routineP = moduleN//':'//routineN @@ -445,14 +428,14 @@ SUBROUTINE scp_vector_release(scp_vec, error) IF(ASSOCIATED(scp_vec%vector)) THEN DO ikind=1,SIZE(scp_vec%vector) DEALLOCATE(scp_vec%vector(ikind)%vmat,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(scp_vec%vector,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(scp_vec%vector) END IF DEALLOCATE(scp_vec,stat=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE scp_vector_release @@ -461,12 +444,10 @@ END SUBROUTINE scp_vector_release !> \brief ... !> \param scp_vec ... !> \param value ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_set(scp_vec, value, error) + SUBROUTINE scp_vector_set(scp_vec, value) TYPE(scp_vector_type) :: scp_vec REAL(KIND=dp), INTENT(IN) :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_set', & routineP = moduleN//':'//routineN @@ -484,12 +465,10 @@ END SUBROUTINE scp_vector_set !> \param alpha ... !> \param vecx ... !> \param vecy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_add(alpha, vecx, vecy, error) + SUBROUTINE scp_vector_add(alpha, vecx, vecy) REAL(KIND=dp), INTENT(IN) :: alpha TYPE(scp_vector_type) :: vecx, vecy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_add', & routineP = moduleN//':'//routineN @@ -506,11 +485,9 @@ END SUBROUTINE scp_vector_add !> \brief ... !> \param vec_in ... !> \param vec_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_copy(vec_in, vec_out, error) + SUBROUTINE scp_vector_copy(vec_in, vec_out) TYPE(scp_vector_type) :: vec_in, vec_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_copy', & routineP = moduleN//':'//routineN @@ -527,12 +504,10 @@ END SUBROUTINE scp_vector_copy !> \brief ... !> \param scale ... !> \param vec ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_scale(scale, vec, error) + SUBROUTINE scp_vector_scale(scale, vec) REAL(KIND=dp), INTENT(IN) :: scale TYPE(scp_vector_type) :: vec - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_scale', & routineP = moduleN//':'//routineN @@ -549,11 +524,9 @@ END SUBROUTINE scp_vector_scale !> \brief ... !> \param vecx ... !> \param vecy ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_mult(vecx, vecy, error) + SUBROUTINE scp_vector_mult(vecx, vecy) TYPE(scp_vector_type) :: vecx, vecy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_mult', & routineP = moduleN//':'//routineN @@ -571,12 +544,10 @@ END SUBROUTINE scp_vector_mult !> \param RESULT ... !> \param vec1 ... !> \param vec2 ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_dot(RESULT, vec1, vec2, error) + SUBROUTINE scp_vector_dot(RESULT, vec1, vec2) REAL(KIND=dp), INTENT(OUT) :: RESULT TYPE(scp_vector_type) :: vec1, vec2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_dot', & routineP = moduleN//':'//routineN @@ -594,12 +565,10 @@ END SUBROUTINE scp_vector_dot !> \brief ... !> \param RESULT ... !> \param vec ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_norm(RESULT, vec, error) + SUBROUTINE scp_vector_norm(RESULT, vec) REAL(KIND=dp), INTENT(OUT) :: RESULT TYPE(scp_vector_type) :: vec - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_norm', & routineP = moduleN//':'//routineN @@ -618,12 +587,10 @@ END SUBROUTINE scp_vector_norm !> \brief ... !> \param vec ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_sync(vec, para_env, error) + SUBROUTINE scp_vector_sync(vec, para_env) TYPE(scp_vector_type) :: vec TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_sync', & routineP = moduleN//':'//routineN @@ -639,11 +606,9 @@ END SUBROUTINE scp_vector_sync ! ***************************************************************************** !> \brief ... !> \param vec ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scp_vector_print(vec, error) + SUBROUTINE scp_vector_print(vec) TYPE(scp_vector_type) :: vec - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'scp_vector_print', & routineP = moduleN//':'//routineN diff --git a/src/scptb_utils.F b/src/scptb_utils.F index 5793ba42e9..307a18a4dd 100644 --- a/src/scptb_utils.F +++ b/src/scptb_utils.F @@ -64,9 +64,8 @@ MODULE scptb_utils !> \param scptb_control ... !> \param print_section ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_section,para_env,error) + SUBROUTINE scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_section,para_env) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -75,7 +74,6 @@ SUBROUTINE scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_ TYPE(scptb_control_type), INTENT(INOUT) :: scptb_control TYPE(section_vals_type), POINTER :: print_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scptb_parameter_init', & routineP = moduleN//':'//routineN @@ -97,45 +95,45 @@ SUBROUTINE scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_ failure = .FALSE. output_unit = -1 NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() print_info = (BTEST(cp_print_key_should_output(logger%iter_info,print_section,& - "KINDS/BASIS_SET",error=error),cp_p_file)) + "KINDS/BASIS_SET"),cp_p_file)) IF (print_info) THEN - output_unit = cp_print_key_unit_nr(logger,print_section,"KINDS",extension=".Log",error=error) + output_unit = cp_print_key_unit_nr(logger,print_section,"KINDS",extension=".Log") IF ( output_unit > 0 ) THEN WRITE(output_unit,"(/,A)") " SCPTB| A set of SCPTB "//& "parameters for material sciences." WRITE(output_unit,"(A)") " SCPTB| J. Hutter, Y. Misteli, R. Koitz" WRITE(output_unit,"(A)") " SCPTB| University of Zurich, 2012" END IF - CALL cp_print_key_finished_output(output_unit,logger,print_section,"KINDS",error=error) + CALL cp_print_key_finished_output(output_unit,logger,print_section,"KINDS") END IF ! read global parameters from xml file - IF(para_env%ionode) CALL scptb_global_parameter_from_file(scptb_control,error) - CALL scptb_global_parameter_broadcast(scptb_control,para_env,error) + IF(para_env%ionode) CALL scptb_global_parameter_from_file(scptb_control) + CALL scptb_global_parameter_broadcast(scptb_control,para_env) nkind = SIZE(atomic_kind_set) DO ikind = 1, nkind CALL get_atomic_kind(atomic_kind_set(ikind), name=iname) CALL uppercase(iname) NULLIFY(scptb_parameter) - CALL allocate_scptb_parameter(scptb_parameter,error) - CALL set_scptb_parameter(scptb_parameter,key=iname,defined=.FALSE., error=error) + CALL allocate_scptb_parameter(scptb_parameter) + CALL set_scptb_parameter(scptb_parameter,key=iname,defined=.FALSE.) ! only for ionode - IF(para_env%ionode) CALL scptb_parameter_from_file(scptb_parameter,scptb_control,error) - CALL scptb_parameter_broadcast(scptb_parameter,para_env,error) + IF(para_env%ionode) CALL scptb_parameter_from_file(scptb_parameter,scptb_control) + CALL scptb_parameter_broadcast(scptb_parameter,para_env) IF (scptb_parameter%defined .EQV. .FALSE.) THEN - output_unit = cp_print_key_unit_nr(logger,print_section,"KINDS",extension=".Log",error=error) + output_unit = cp_print_key_unit_nr(logger,print_section,"KINDS",extension=".Log") IF ( output_unit > 0 ) THEN WRITE(output_unit, "(A,I3,2X,A,A)") " SCPTB| Kind ", ikind, TRIM(iname), & ": No parameter xml given or element undefined. Using defaults." END IF !defaults, but undefined for most elements atm - CALL scptb_default_parameter(scptb_parameter,error) - CALL cp_print_key_finished_output(output_unit,logger,print_section,"KINDS",error=error) + CALL scptb_default_parameter(scptb_parameter) + CALL cp_print_key_finished_output(output_unit,logger,print_section,"KINDS") END IF !initialization @@ -145,15 +143,15 @@ SUBROUTINE scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_ zeff_correction=0.0_dp) ! basis set NULLIFY(sto_basis) - CALL allocate_sto_basis_set (sto_basis,error) + CALL allocate_sto_basis_set (sto_basis) nshell = SUM(scptb_parameter%norb) ALLOCATE (nq(nshell),lq(nshell),zet(nshell),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) nq=0 lq=0 zet=0._dp ALLOCATE (symbol(nshell),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) symbol="" is=0 !Aggregate all the electron shell parameters into arrays @@ -175,14 +173,14 @@ SUBROUTINE scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_ nshell=nshell,symbol=symbol,nq=nq,lq=lq,zet=zet) qs_kind => qs_kind_set(ikind) NULLIFY(gto_basis) - CALL create_gto_from_sto_basis(sto_basis,gto_basis,scptb_control%sto_ng,error=error) - CALL add_basis_set_to_container(qs_kind%basis_sets,gto_basis,"ORB",error) + CALL create_gto_from_sto_basis(sto_basis,gto_basis,scptb_control%sto_ng) + CALL add_basis_set_to_container(qs_kind%basis_sets,gto_basis,"ORB") END IF DEALLOCATE (nq,lq,zet,symbol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) - CALL deallocate_sto_basis_set (sto_basis,error) + CALL deallocate_sto_basis_set (sto_basis) !throw away the STO basis set, since from now on we use the GTO a = scptb_parameter%crep(1) @@ -212,7 +210,7 @@ SUBROUTINE scptb_parameter_init(atomic_kind_set,qs_kind_set,scptb_control,print_ END IF - CALL set_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_parameter, error=error) + CALL set_qs_kind(qs_kind_set(ikind), scptb_parameter=scptb_parameter) END DO @@ -221,12 +219,10 @@ END SUBROUTINE scptb_parameter_init ! ***************************************************************************** !> \brief ... !> \param scptb_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_global_parameter_from_file(scptb_control,error) + SUBROUTINE scptb_global_parameter_from_file(scptb_control) TYPE(scptb_control_type), INTENT(INOUT) :: scptb_control - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'scptb_global_parameter_from_file', & @@ -326,14 +322,12 @@ END SUBROUTINE scptb_global_parameter_from_file !> \brief ... !> \param scptb_parameter ... !> \param scptb_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_parameter_from_file(scptb_parameter,scptb_control,error) + SUBROUTINE scptb_parameter_from_file(scptb_parameter,scptb_control) TYPE(scptb_parameter_type), & INTENT(INOUT) :: scptb_parameter TYPE(scptb_control_type), INTENT(INOUT) :: scptb_control - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scptb_parameter_from_file', & routineP = moduleN//':'//routineN @@ -565,13 +559,11 @@ END SUBROUTINE scptb_parameter_from_file !> \brief ... !> \param scptb_control ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_global_parameter_broadcast(scptb_control,para_env,error) + SUBROUTINE scptb_global_parameter_broadcast(scptb_control,para_env) TYPE(scptb_control_type), INTENT(INOUT) :: scptb_control TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'scptb_global_parameter_broadcast', & @@ -586,9 +578,9 @@ SUBROUTINE scptb_global_parameter_broadcast(scptb_control,para_env,error) group = para_env%group IF(para_env%ionode) THEN - CPPostcondition(source==para_env%mepos,cp_failure_level,routineP,error,failure) + CPPostcondition(source==para_env%mepos,cp_failure_level,routineP,failure) ELSE - CPPostcondition(source/=para_env%mepos,cp_failure_level,routineP,error,failure) + CPPostcondition(source/=para_env%mepos,cp_failure_level,routineP,failure) END IF CALL mp_bcast(scptb_control%sd3,source,group) @@ -599,14 +591,12 @@ END SUBROUTINE scptb_global_parameter_broadcast !> \brief ... !> \param scptb_parameter ... !> \param para_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE scptb_parameter_broadcast(scptb_parameter,para_env,error) + SUBROUTINE scptb_parameter_broadcast(scptb_parameter,para_env) TYPE(scptb_parameter_type), & INTENT(INOUT) :: scptb_parameter TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'scptb_parameter_broadcast', & routineP = moduleN//':'//routineN @@ -620,9 +610,9 @@ SUBROUTINE scptb_parameter_broadcast(scptb_parameter,para_env,error) group = para_env%group IF(para_env%ionode) THEN - CPPostcondition(source==para_env%mepos,cp_failure_level,routineP,error,failure) + CPPostcondition(source==para_env%mepos,cp_failure_level,routineP,failure) ELSE - CPPostcondition(source/=para_env%mepos,cp_failure_level,routineP,error,failure) + CPPostcondition(source/=para_env%mepos,cp_failure_level,routineP,failure) END IF CALL mp_bcast(scptb_parameter%key,source,group) diff --git a/src/se_core_core.F b/src/se_core_core.F index 3fea50f4cd..f480701bce 100644 --- a/src/se_core_core.F +++ b/src/se_core_core.F @@ -78,15 +78,13 @@ MODULE se_core_core !> \param qs_env ... !> \param para_env ... !> \param calculate_forces ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) + SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(in) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_core_core_interaction', & routineP = moduleN//':'//routineN @@ -135,11 +133,11 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) virial, atprop) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, cell=cell, se_taper=se_taper,& - virial=virial,atprop=atprop, energy=energy, error=error) + virial=virial,atprop=atprop, energy=energy) - CALL initialize_se_taper(se_taper,coulomb=.TRUE.,error=error) + CALL initialize_se_taper(se_taper,coulomb=.TRUE.) ! Parameters se_control => dft_control%qs_control%se_control anag = se_control%analytical_gradients @@ -152,31 +150,31 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) ! atomic energy decomposition atener = atprop%energy IF (atener) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE (particle_set) - CALL atprop_array_init(atprop%atecc,natom,error) + CALL atprop_array_init(atprop%atecc,natom) END IF ! Retrieve some information if GKS ewald scheme is used IF(se_control%do_ewald_gks) THEN - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw,error=error) - CALL ewald_env_get (ewald_env, alpha=se_int_control%ewald_gks%alpha, error=error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) + CALL ewald_env_get (ewald_env, alpha=se_int_control%ewald_gks%alpha) CALL ewald_pw_get (ewald_pw, pw_big_pool=se_int_control%ewald_gks%pw_pool, & dg=se_int_control%ewald_gks%dg) ! Virial not implemented - CPPrecondition(.NOT.use_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.use_virial,cp_failure_level,routineP,failure) END IF CALL get_qs_env(qs_env=qs_env,sab_se=sab_se,atomic_kind_set=atomic_kind_set,& - qs_kind_set=qs_kind_set, error=error) + qs_kind_set=qs_kind_set) nkind = SIZE(atomic_kind_set) ! Possibly compute forces IF(calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,force=force) natom = SIZE (particle_set) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) delta = se_control%delta CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) END IF @@ -184,9 +182,9 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) itype = get_se_type(dft_control%qs_control%method_id) ALLOCATE (se_kind_param(nkind),se_defined(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) se_kind_param(ikind)%se_param => se_kind_a CALL get_se_param(se_kind_a,defined=defined) se_defined(ikind)=defined @@ -208,7 +206,7 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) ! Core-Core energy term CALL corecore (se_kind_a,se_kind_b,rij,enuc=enuc,itype=itype,anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) enucij = enucij + enuc ! Residual integral (1/R^3) correction IF (se_int_control%do_ewald_r3) THEN @@ -225,7 +223,7 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) atom_b = atom_of_kind(jatom) CALL dcorecore (se_kind_a,se_kind_b,rij,denuc=force_ab,itype=itype,delta=delta,& - anag=anag,se_int_control=se_int_control,se_taper=se_taper,error=error) + anag=anag,se_int_control=se_int_control,se_taper=se_taper) ! Residual integral (1/R^3) correction IF (se_int_control%do_ewald_r3) THEN @@ -234,7 +232,7 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) force_ab = force_ab + se_kind_a%expns3_int(jkind)%expns3%core_core*dr3inv END IF IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij) END IF ! Sum up force components @@ -248,13 +246,13 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) force(jkind)%all_potential(3,atom_b) = force(jkind)%all_potential(3,atom_b) + force_ab(3) END IF CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSE IF ( se_int_control%do_ewald_gks ) THEN ! Core-Core energy term (self term in periodic systems) CALL corecore (se_kind_a,se_kind_b,rij,enuc=enuc,itype=itype,anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) enucij = enucij + 0.5_dp*enuc END IF END IF @@ -267,18 +265,18 @@ SUBROUTINE se_core_core_interaction(qs_env, para_env, calculate_forces, error) CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (se_kind_param,se_defined,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE(atom_of_kind,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF CALL mp_sum(enuclear,para_env%group) energy%core_overlap = enuclear energy%core_overlap0 = enuclear - CALL finalize_se_taper(se_taper,error=error) + CALL finalize_se_taper(se_taper) CALL timestop(handle) END SUBROUTINE se_core_core_interaction diff --git a/src/se_core_matrix.F b/src/se_core_matrix.F index 274fae5be6..e2c7e97c49 100644 --- a/src/se_core_matrix.F +++ b/src/se_core_matrix.F @@ -79,14 +79,12 @@ MODULE se_core_matrix !> \param qs_env ... !> \param para_env ... !> \param calculate_forces ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) + SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_para_env_type), POINTER :: para_env LOGICAL, INTENT(IN) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'build_se_core_matrix', & routineP = moduleN//':'//routineN @@ -138,7 +136,7 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) CALL timeset(routineN,handle) NULLIFY(logger,energy) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY ( rho,force,atomic_kind_set,qs_kind_set,sab_orb,& diagmat_h,diagmat_p,particle_set, matrix_p, ks_env) @@ -155,8 +153,7 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) force=force,& virial=virial,& rho=rho,& - sab_orb=sab_orb,& - error=error) + sab_orb=sab_orb) ! calculate overlap matrix IF(calculate_forces) THEN @@ -164,55 +161,53 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) matrix_name="OVERLAP",& basis_type_a="ORB",& basis_type_b="ORB", & - sab_nl=sab_orb,& - error=error) - CALL set_ks_env(ks_env,matrix_s=matrix_s,error=error) + sab_nl=sab_orb) + CALL set_ks_env(ks_env,matrix_s=matrix_s) use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) ELSE CALL build_overlap_matrix(ks_env,matrix_s=matrix_s,& matrix_name="OVERLAP",& basis_type_a="ORB",& basis_type_b="ORB", & - sab_nl=sab_orb,& - error=error) - CALL set_ks_env(ks_env,matrix_s=matrix_s,error=error) + sab_nl=sab_orb) + CALL set_ks_env(ks_env,matrix_s=matrix_s) use_virial = .FALSE. END IF IF(calculate_forces) THEN - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + CALL qs_rho_get(rho, rho_ao=matrix_p) IF (SIZE(matrix_p) == 2) THEN - CALL cp_dbcsr_add(matrix_p(1)%matrix, matrix_p(2)%matrix, alpha_scalar=1.0_dp, beta_scalar=1.0_dp, error=error) + CALL cp_dbcsr_add(matrix_p(1)%matrix, matrix_p(2)%matrix, alpha_scalar=1.0_dp, beta_scalar=1.0_dp) END IF natom = SIZE (particle_set) ALLOCATE (atom_of_kind(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) delta = dft_control%qs_control%se_control%delta CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& atom_of_kind=atom_of_kind) ALLOCATE(diagmat_p,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init (diagmat_p, error=error) - CALL cp_dbcsr_get_block_diag(matrix_p(1)%matrix, diagmat_p, error=error) - CALL cp_dbcsr_replicate_all(diagmat_p,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init (diagmat_p) + CALL cp_dbcsr_get_block_diag(matrix_p(1)%matrix, diagmat_p) + CALL cp_dbcsr_replicate_all(diagmat_p) END IF ! Allocate the core Hamiltonian matrix - CALL cp_dbcsr_allocate_matrix_set(matrix_h,1,error=error) + CALL cp_dbcsr_allocate_matrix_set(matrix_h,1) ALLOCATE(matrix_h(1)%matrix,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(matrix_h(1)%matrix, error=error) - CALL cp_dbcsr_copy(matrix_h(1)%matrix,matrix_s(1)%matrix,"CORE HAMILTONIAN MATRIX",error=error) - CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(matrix_h(1)%matrix) + CALL cp_dbcsr_copy(matrix_h(1)%matrix,matrix_s(1)%matrix,"CORE HAMILTONIAN MATRIX") + CALL cp_dbcsr_set(matrix_h(1)%matrix,0.0_dp) ! Allocate a diagonal block matrix ALLOCATE(diagmat_h,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_init(diagmat_h, error=error) - CALL cp_dbcsr_get_block_diag(matrix_s(1)%matrix, diagmat_h, error=error) - CALL cp_dbcsr_set(diagmat_h, 0.0_dp, error=error) - CALL cp_dbcsr_replicate_all(diagmat_h,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_init(diagmat_h) + CALL cp_dbcsr_get_block_diag(matrix_s(1)%matrix, diagmat_h) + CALL cp_dbcsr_set(diagmat_h, 0.0_dp) + CALL cp_dbcsr_replicate_all(diagmat_h) ! kh might be set in qs_control itype = get_se_type(dft_control%qs_control%method_id) @@ -221,23 +216,23 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) nkind = SIZE(atomic_kind_set) ALLOCATE (se_defined(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (hmt(16,nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (umt(16,nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (ZSt(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (ZPt(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (nrt(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) econst = 0.0_dp DO ikind=1,nkind CALL get_atomic_kind(atomic_kind_set(ikind), natom=natom) - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a,& beta=beta_a,uss=uss,upp=upp,udd=udd,uff=uff,eisol=eisol,eheat=eheat,& nr=nr_a,sto_exponents=sto_exponents_a) @@ -281,10 +276,10 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) do_method_pm3,do_method_pm6,do_method_mndod, do_method_pnnl) NULLIFY(h_blocka) CALL cp_dbcsr_get_block_p(diagmat_h,iatom,iatom,h_blocka,found) - CPPostcondition(ASSOCIATED(h_blocka),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(h_blocka),cp_failure_level,routineP,failure) IF(calculate_forces) THEN CALL cp_dbcsr_get_block_p(diagmat_p,iatom,iatom,pamat,found) - CPPostcondition(ASSOCIATED(pamat),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pamat),cp_failure_level,routineP,failure) END IF END SELECT END IF @@ -293,7 +288,7 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) SELECT CASE (dft_control%qs_control%method_id) CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) CASE (do_method_am1,do_method_rm1,do_method_mndo,do_method_pdg,& do_method_pm3,do_method_pm6,do_method_mndod, do_method_pnnl) DO i=1,SIZE(h_blocka,1) @@ -312,13 +307,13 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) NULLIFY (h_block) CALL cp_dbcsr_get_block_p(matrix_h(1)%matrix,& irow,icol,h_block,found) - CPPostcondition(ASSOCIATED(h_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(h_block),cp_failure_level,routineP,failure) ! two-centre one-electron term NULLIFY(s_block) ! CALL cp_dbcsr_get_block_p(matrix_s(1)%matrix,& ! irow,icol,s_block,found) -! CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,error,failure) +! CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) ! ! if( irow == iatom )then ! R= -rij @@ -336,7 +331,7 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) CALL cp_dbcsr_get_block_p(matrix_s(1)%matrix,& irow,icol,s_block,found) - CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(s_block),cp_failure_level,routineP,failure) IF ( irow == iatom ) THEN DO i=1,SIZE(h_block,1) DO j=1,SIZE(h_block,2) @@ -363,12 +358,12 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) ! endif CALL cp_dbcsr_get_block_p(matrix_p(1)%matrix,irow,icol,pabmat,found) - CPPostcondition(ASSOCIATED(pabmat),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pabmat),cp_failure_level,routineP,failure) DO icor=1,3 force_ab(icor) = 0._dp ! CALL cp_dbcsr_get_block_p(matrix_s(icor+1)%matrix,irow,icol,dsmat,found) -! CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,error,failure) +! CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,failure) ! ! do i=1,4 ! do j=1,4 @@ -377,7 +372,7 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) ! enddo CALL cp_dbcsr_get_block_p(matrix_s(icor+1)%matrix,irow,icol,dsmat,found) - CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(dsmat),cp_failure_level,routineP,failure) dsmat=2._dp*kh*dsmat*pabmat IF ( irow == iatom ) THEN DO i=1,SIZE(h_block,1) @@ -404,7 +399,7 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) force(jkind)%all_potential(:,atom_b) =& force(jkind)%all_potential(:,atom_b) + force_ab(:) IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij) END IF END IF @@ -412,35 +407,35 @@ SUBROUTINE build_se_core_matrix(qs_env,para_env,calculate_forces,error) CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE (se_defined,hmt,umt,ZSt,ZPt,nrt,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_sum_replicated(diagmat_h, error=error) - CALL cp_dbcsr_distribute(diagmat_h,error=error) - CALL cp_dbcsr_add(matrix_h(1)%matrix, diagmat_h,1.0_dp,1.0_dp,error=error) - CALL set_ks_env(ks_env,matrix_h=matrix_h,error=error) + CALL cp_dbcsr_sum_replicated(diagmat_h) + CALL cp_dbcsr_distribute(diagmat_h) + CALL cp_dbcsr_add(matrix_h(1)%matrix, diagmat_h,1.0_dp,1.0_dp) + CALL set_ks_env(ks_env,matrix_h=matrix_h) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN",error=error),cp_p_file)) THEN + qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN"),cp_p_file)) THEN iw = cp_print_key_unit_nr(logger,qs_env%input,"DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN",& - extension=".Log",error=error) - CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after,error=error) + extension=".Log") + CALL section_vals_val_get(qs_env%input,"DFT%PRINT%AO_MATRICES%NDIGITS",i_val=after) after = MIN(MAX(after,1),16) CALL cp_dbcsr_write_sparse_matrix(matrix_h(1)%matrix,4,after,qs_env,para_env,& - scale=evolt,output_unit=iw,error=error) + scale=evolt,output_unit=iw) CALL cp_print_key_finished_output(iw,logger,qs_env%input,& - "DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN", error=error) + "DFT%PRINT%AO_MATRICES/CORE_HAMILTONIAN") END IF IF(calculate_forces) THEN IF (SIZE(matrix_p) == 2) THEN - CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,alpha_scalar=1.0_dp,beta_scalar=-1.0_dp,error=error) + CALL cp_dbcsr_add(matrix_p(1)%matrix,matrix_p(2)%matrix,alpha_scalar=1.0_dp,beta_scalar=-1.0_dp) END IF DEALLOCATE(atom_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_deallocate_matrix(diagmat_p,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_deallocate_matrix(diagmat_p) END IF - CALL cp_dbcsr_deallocate_matrix(diagmat_h,error=error) + CALL cp_dbcsr_deallocate_matrix(diagmat_h) CALL timestop(handle) diff --git a/src/se_fock_matrix.F b/src/se_fock_matrix.F index c6a4e6e07a..1c9421cafa 100644 --- a/src/se_fock_matrix.F +++ b/src/se_fock_matrix.F @@ -76,15 +76,13 @@ MODULE se_fock_matrix !> \param qs_env ... !> \param calculate_forces ... !> \param just_energy ... -!> \param error ... !> \par History !> - Teodoro Laino [tlaino] (05.2009) - Split and module reorganization !> \author JGH ! ***************************************************************************** - SUBROUTINE build_se_fock_matrix (qs_env,calculate_forces,just_energy,error) + SUBROUTINE build_se_fock_matrix (qs_env,calculate_forces,just_energy) TYPE(qs_environment_type), POINTER :: qs_env LOGICAL, INTENT(in) :: calculate_forces, just_energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_se_fock_matrix', & routineP = moduleN//':'//routineN @@ -122,8 +120,8 @@ SUBROUTINE build_se_fock_matrix (qs_env,calculate_forces,just_energy,error) NULLIFY(matrix_h, dft_control, logger, scf_section, store_int_env, se_control) NULLIFY(atomic_kind_set, atprop) NULLIFY(ks_env, ks_matrix, rho, energy) - logger => cp_error_get_logger(error) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + logger => cp_get_default_logger() + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& dft_control=dft_control,& @@ -136,71 +134,70 @@ SUBROUTINE build_se_fock_matrix (qs_env,calculate_forces,just_energy,error) ks_env=ks_env,& matrix_ks=ks_matrix,& rho=rho,& - energy=energy,& - error=error) + energy=energy) SELECT CASE (dft_control%qs_control%method_id) CASE DEFAULT ! Abort if the parameterization is an unknown one.. CALL cp_unimplemented_error(fromWhere=routineP, & message="Fock Matrix not available for the chosen parameterization! ", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE (do_method_am1,do_method_rm1,do_method_mndo,do_method_pdg,& do_method_pm3,do_method_pm6,do_method_mndod, do_method_pnnl) ! Check for properly allocation of Matrixes nspins=dft_control%nspins - CPPrecondition(((nspins>=1).AND.(nspins<=2)),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(matrix_h),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(((nspins>=1).AND.(nspins<=2)),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(matrix_h),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) se_control => dft_control%qs_control%se_control - scf_section => section_vals_get_subs_vals(qs_env%input,"DFT%SCF",error=error) - CALL qs_rho_get(rho, rho_ao=matrix_p, error=error) + scf_section => section_vals_get_subs_vals(qs_env%input,"DFT%SCF") + CALL qs_rho_get(rho, rho_ao=matrix_p) energy%qmmm_el = 0.0_dp energy%total = 0.0_dp DO ispin=1,nspins ! Copy the core matrix into the fock matrix - CALL cp_dbcsr_copy(ks_matrix(ispin)%matrix,matrix_h(1)%matrix,error=error) + CALL cp_dbcsr_copy(ks_matrix(ispin)%matrix,matrix_h(1)%matrix) END DO ! WRITE ( *, * ) 'KS_ENV%s_mstruct_changed', ks_env%s_mstruct_changed IF(atprop%energy) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set) natom = SIZE(particle_set) - CALL atprop_array_init(atprop%atecoul,natom,error) + CALL atprop_array_init(atprop%atecoul,natom) END IF ! Compute Exchange and Coulomb terms - CALL semi_empirical_si_initialize(store_int_env, s_mstruct_changed, error) + CALL semi_empirical_si_initialize(store_int_env, s_mstruct_changed) CALL build_fock_matrix_exchange(qs_env,ks_matrix,matrix_p,calculate_forces,& - store_int_env,error) + store_int_env) CALL build_fock_matrix_coulomb(qs_env,ks_matrix,matrix_p,energy,calculate_forces,& - store_int_env,error) + store_int_env) ! Debug statements for Long-Range IF (debug_energy_coulomb_lr.AND.se_control%do_ewald) THEN CALL dbg_energy_coulomb_lr(energy, ks_matrix, nspins, qs_env, matrix_p,& - calculate_forces, store_int_env, error) + calculate_forces, store_int_env) END IF ! Long Range Electrostatic IF (se_control%do_ewald) THEN ! Evaluate Coulomb Long-Range CALL build_fock_matrix_coulomb_lr(qs_env,ks_matrix,matrix_p,energy,calculate_forces,& - store_int_env, error) + store_int_env) ! Possibly handle the slowly convergent term 1/R^3 IF (se_control%do_ewald_r3) THEN CALL build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,& - calculate_forces,error) + calculate_forces) END IF END IF - CALL semi_empirical_si_finalize(store_int_env, s_mstruct_changed, error) + CALL semi_empirical_si_finalize(store_int_env, s_mstruct_changed) IF(atprop%energy) THEN atprop%atecoul = 0.5_dp*atprop%atecoul @@ -209,22 +206,22 @@ SUBROUTINE build_se_fock_matrix (qs_env,calculate_forces,just_energy,error) ! Compute the Hartree energy ! NOTE: If we are performing SCP-NDDO, ks_matrix contains coulomb piece from SCP. DO ispin=1,nspins - CALL cp_dbcsr_trace(ks_matrix(ispin)%matrix,matrix_p(ispin)%matrix,trace=ecoul,error=error) + CALL cp_dbcsr_trace(ks_matrix(ispin)%matrix,matrix_p(ispin)%matrix,trace=ecoul) energy%hartree = energy%hartree + ecoul END DO ! WRITE ( *, * ) 'AFTER Hartree', ecoul, energy%hartree -! CALL build_fock_matrix_ph(qs_env,ks_matrix,error) +! CALL build_fock_matrix_ph(qs_env,ks_matrix) ! QM/MM IF (qs_env%qmmm) THEN DO ispin = 1, nspins ! If QM/MM sumup the 1el Hamiltonian CALL cp_dbcsr_add(ks_matrix(ispin)%matrix,qs_env%ks_qmmm_env%matrix_h(1)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) ! Compute QM/MM Energy CALL cp_dbcsr_trace(qs_env%ks_qmmm_env%matrix_h(1)%matrix,& - matrix_p(ispin)%matrix,trace=qmmm_el,error=error) + matrix_p(ispin)%matrix,trace=qmmm_el) energy%qmmm_el = energy%qmmm_el + qmmm_el END DO END IF @@ -243,7 +240,7 @@ SUBROUTINE build_se_fock_matrix (qs_env,calculate_forces,just_energy,error) output_unit=cp_print_key_unit_nr(logger,scf_section,"PRINT%DETAILED_ENERGY",& - extension=".scfLog",error=error) + extension=".scfLog") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,(T3,A,T60,F20.10))")& @@ -256,20 +253,20 @@ SUBROUTINE build_se_fock_matrix (qs_env,calculate_forces,just_energy,error) END IF CALL cp_print_key_finished_output(output_unit,logger,scf_section,& - "PRINT%DETAILED_ENERGY", error=error) + "PRINT%DETAILED_ENERGY") ! Here we compute dE/dC if needed. Assumes dE/dC is H_{ks}C (plus occupation numbers) IF (qs_env%requires_mo_derivs .AND. .NOT. just_energy) THEN - CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array,error=error) + CALL get_qs_env(qs_env,mo_derivs=mo_derivs,mos=mo_array) DO ispin=1,SIZE(mo_derivs) CALL get_mo_set(mo_set=mo_array(ispin)%mo_set, & mo_coeff_b=mo_coeff, occupation_numbers=occupation_numbers ) IF(.NOT.mo_array(ispin)%mo_set%use_mo_coeff_b) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL cp_dbcsr_get_info(mo_coeff,nfullcols_total=ncol_global) CALL cp_dbcsr_multiply('n','n',1.0_dp,ks_matrix(ispin)%matrix,mo_coeff,& - 0.0_dp,mo_derivs(ispin)%matrix, error=error) + 0.0_dp,mo_derivs(ispin)%matrix) ENDDO ENDIF diff --git a/src/se_fock_matrix_coulomb.F b/src/se_fock_matrix_coulomb.F index 5e3fbbf80a..ea27ba2893 100644 --- a/src/se_fock_matrix_coulomb.F +++ b/src/se_fock_matrix_coulomb.F @@ -110,11 +110,10 @@ MODULE se_fock_matrix_coulomb !> \param energy ... !> \param calculate_forces ... !> \param store_int_env ... -!> \param error ... !> \author JGH ! ***************************************************************************** SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate_forces,& - store_int_env,error) + store_int_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -122,7 +121,6 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_fock_matrix_coulomb', & routineP = moduleN//':'//routineN @@ -180,10 +178,10 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, cell=cell, se_taper=se_taper,& para_env=para_env, sab_se=sab_se, atomic_kind_set=atomic_kind_set,atprop=atprop,& - qs_kind_set=qs_kind_set, particle_set=particle_set, virial=virial, error=error) + qs_kind_set=qs_kind_set, particle_set=particle_set, virial=virial) ! Parameters - CALL initialize_se_taper(se_taper,coulomb=.TRUE.,error=error) + CALL initialize_se_taper(se_taper,coulomb=.TRUE.) se_control => dft_control%qs_control%se_control anag = se_control%analytical_gradients use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) @@ -194,48 +192,48 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate shortrange=(se_control%do_ewald.OR.se_control%do_ewald_gks),& max_multipole=se_control%max_multipole,pc_coulomb_int=.FALSE.) IF(se_control%do_ewald_gks) THEN - CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw, error=error) - CALL ewald_env_get (ewald_env, alpha=se_int_control%ewald_gks%alpha, error=error) + CALL get_qs_env(qs_env=qs_env,ewald_env=ewald_env,ewald_pw=ewald_pw) + CALL ewald_env_get (ewald_env, alpha=se_int_control%ewald_gks%alpha) CALL ewald_pw_get (ewald_pw, pw_big_pool=se_int_control%ewald_gks%pw_pool, & dg=se_int_control%ewald_gks%dg) END IF nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) nkind = SIZE(atomic_kind_set) IF(calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env, force=force, error=error) + CALL get_qs_env(qs_env=qs_env, force=force) natom = SIZE (particle_set) delta = se_control%delta ! Allocate atom index for kind ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) END IF - CALL cp_dbcsr_allocate_matrix_set(diagmat_ks,nspins,error=error) - CALL cp_dbcsr_allocate_matrix_set(diagmat_p,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(diagmat_ks,nspins) + CALL cp_dbcsr_allocate_matrix_set(diagmat_p,nspins) DO ispin=1,nspins ! Allocate diagonal block matrices ALLOCATE(diagmat_p(ispin)%matrix,diagmat_ks(ispin)%matrix)!sm->dbcsr - CALL cp_dbcsr_init(diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_init(diagmat_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_get_block_diag(matrix_p(ispin)%matrix, diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_get_block_diag(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(diagmat_ks(ispin)%matrix, 0.0_dp, error=error) - CALL cp_dbcsr_replicate_all(diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_replicate_all(diagmat_ks(ispin)%matrix, error=error) + CALL cp_dbcsr_init(diagmat_p(ispin)%matrix) + CALL cp_dbcsr_init(diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_get_block_diag(matrix_p(ispin)%matrix, diagmat_p(ispin)%matrix) + CALL cp_dbcsr_get_block_diag(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_set(diagmat_ks(ispin)%matrix, 0.0_dp) + CALL cp_dbcsr_replicate_all(diagmat_p(ispin)%matrix) + CALL cp_dbcsr_replicate_all(diagmat_ks(ispin)%matrix) END DO ecore2 = 0.0_dp itype = get_se_type(dft_control%qs_control%method_id) ALLOCATE (se_defined(nkind),se_kind_list(nkind),se_natorb(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) se_kind_list(ikind)%se_param => se_kind_a CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a) se_defined(ikind) = (defined .AND. natorb_a >= 1) @@ -257,23 +255,23 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate IF (inode==1) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(1)%matrix,& row=iatom,col=iatom,BLOCK=pa_block_a,found=found) - CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,failure) check = (SIZE(pa_block_a,1)==natorb_a).AND.(SIZE(pa_block_a,2)==natorb_a) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(1)%matrix,& row=iatom,col=iatom,BLOCK=ksa_block_a,found=found) - CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,failure) p_block_tot_a(1:natorb_a,1:natorb_a) = 2.0_dp * pa_block_a pa_a(1:natorb_a2) = RESHAPE(pa_block_a,(/natorb_a2/)) IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(2)%matrix,& row=iatom,col=iatom,BLOCK=pa_block_b,found=found) - CPPostcondition(ASSOCIATED(pa_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pa_block_b),cp_failure_level,routineP,failure) check = (SIZE(pa_block_b,1)==natorb_a).AND.(SIZE(pa_block_b,2)==natorb_a) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(2)%matrix,& row=iatom,col=iatom,BLOCK=ksa_block_b,found=found) - CPPostcondition(ASSOCIATED(ksa_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksa_block_b),cp_failure_level,routineP,failure) p_block_tot_a(1:natorb_a,1:natorb_a) = pa_block_a + pa_block_b pa_b(1:natorb_a2) = RESHAPE(pa_block_b,(/natorb_a2/)) END IF @@ -291,26 +289,26 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate ! Retrieve blocks for KS and P CALL cp_dbcsr_get_block_p(matrix=diagmat_p(1)%matrix,& row=jatom,col=jatom,BLOCK=pb_block_a,found=found) - CPPostcondition(ASSOCIATED(pb_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pb_block_a),cp_failure_level,routineP,failure) check = (SIZE(pb_block_a,1)==natorb_b).AND.(SIZE(pb_block_a,2)==natorb_b) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(1)%matrix,& row=jatom,col=jatom,BLOCK=ksb_block_a,found=found) - CPPostcondition(ASSOCIATED(ksb_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksb_block_a),cp_failure_level,routineP,failure) p_block_tot_b(1:natorb_b,1:natorb_b) = 2.0_dp * pb_block_a pb_a(1:natorb_b2) = RESHAPE(pb_block_a,(/natorb_b2/)) ! Handle more than one configuration IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(2)%matrix,& row=jatom,col=jatom,BLOCK=pb_block_b,found=found) - CPPostcondition(ASSOCIATED(pb_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pb_block_b),cp_failure_level,routineP,failure) check = (SIZE(pb_block_b,1)==natorb_b).AND.(SIZE(pb_block_b,2)==natorb_b) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(2)%matrix,& row=jatom,col=jatom,BLOCK=ksb_block_b,found=found) - CPPostcondition(ASSOCIATED(ksb_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksb_block_b),cp_failure_level,routineP,failure) check = (SIZE(pb_block_a,1)==SIZE(pb_block_b,1)).AND.(SIZE(pb_block_a,2)==SIZE(pb_block_b,2)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) p_block_tot_b(1:natorb_b,1:natorb_b) = pb_block_a + pb_block_b pb_b(1:natorb_b2) = RESHAPE(pb_block_b,(/natorb_b2/)) END IF @@ -324,17 +322,16 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate ecab = 0._dp CALL fock2_1el (se_kind_a,se_kind_b,rij, ksa_block_a, ksb_block_a,& pa_a, pb_a, ecore=ecab, itype=itype, anag=anag, se_int_control=se_int_control,& - se_taper=se_taper, store_int_env=store_int_env, error=error) + se_taper=se_taper, store_int_env=store_int_env) ecore2 = ecore2 + ecab(1) + ecab(2) ELSE IF ( nspins == 2 ) THEN ecab = 0._dp CALL fock2_1el (se_kind_a,se_kind_b,rij, ksa_block_a, ksb_block_a,& pa_block_a, pb_block_a, ecore=ecab, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env) CALL fock2_1el (se_kind_a,se_kind_b,rij, ksa_block_b, ksb_block_b,& pa_b, pb_b, ecore=ecab, itype=itype, anag=anag, se_int_control=se_int_control,& - se_taper=se_taper, store_int_env=store_int_env, error=error) + se_taper=se_taper, store_int_env=store_int_env) ecore2 = ecore2 + ecab(1) + ecab(2) END IF IF (atener) THEN @@ -345,15 +342,15 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate IF ( nspins == 1 ) THEN CALL fock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, ksa_block_a, p_block_tot_b,& ksb_block_a, factor=0.5_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) ELSE IF ( nspins == 2 ) THEN CALL fock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, ksa_block_a, p_block_tot_b,& ksb_block_a, factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) CALL fock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, ksa_block_b, p_block_tot_b,& ksb_block_b, factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) END IF IF(calculate_forces) THEN @@ -365,17 +362,15 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate IF ( nspins == 1 ) THEN CALL dfock2_1el (se_kind_a,se_kind_b,rij, pa_a, pb_a, itype=itype, anag=anag,& se_int_control=se_int_control, se_taper=se_taper, force=force_ab,& - delta=delta, error=error) + delta=delta) ELSE IF ( nspins == 2 ) THEN CALL dfock2_1el (se_kind_a,se_kind_b,rij, pa_block_a, pb_block_a, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) CALL dfock2_1el (se_kind_a,se_kind_b,rij, pa_b, pb_b, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) END IF IF (use_virial) THEN - CALL virial_pair_force (virial%pv_virial, -1.0_dp, force_ab, rij, error) + CALL virial_pair_force (virial%pv_virial, -1.0_dp, force_ab, rij) END IF ! Sum up force components @@ -392,16 +387,13 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate force_ab = 0._dp IF ( nspins == 1 ) THEN CALL dfock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, p_block_tot_b, factor=0.25_dp,& - anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) ELSE IF ( nspins == 2 ) THEN CALL dfock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, p_block_tot_b, factor=0.50_dp,& - anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) CALL dfock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, p_block_tot_b, factor=0.50_dp,& - anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) END IF IF ( switch ) THEN force_ab(1) = -force_ab(1) @@ -409,7 +401,7 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate force_ab(3) = -force_ab(3) END IF IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij) END IF ! Sum up force components force(ikind)%rho_elec(1,atom_a) = force(ikind)%rho_elec(1,atom_a) - force_ab(1) @@ -422,24 +414,24 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate force(jkind)%rho_elec(3,atom_b) = force(jkind)%rho_elec(3,atom_b) + force_ab(3) END IF CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ELSE IF ( se_int_control%do_ewald_gks ) THEN - CPPostcondition(iatom==jatom,cp_failure_level,routineP,error,failure) + CPPostcondition(iatom==jatom,cp_failure_level,routineP,failure) ! Two-centers One-electron terms ecores=0._dp IF ( nspins == 1 ) THEN CALL fock2_1el_ew (se_kind_a,rij, ksa_block_a, pa_a, & ecore=ecores, itype=itype, anag=anag, se_int_control=se_int_control,& - se_taper=se_taper, store_int_env=store_int_env, error=error) + se_taper=se_taper, store_int_env=store_int_env) ELSE IF ( nspins == 2 ) THEN CALL fock2_1el_ew (se_kind_a,rij, ksa_block_a, pa_block_a,& ecore=ecores, itype=itype, anag=anag, se_int_control=se_int_control, & - se_taper=se_taper, store_int_env=store_int_env, error=error) + se_taper=se_taper, store_int_env=store_int_env) CALL fock2_1el_ew (se_kind_a,rij, ksa_block_b, pa_b,& ecore=ecores, itype=itype, anag=anag, se_int_control=se_int_control,& - se_taper=se_taper, store_int_env=store_int_env, error=error) + se_taper=se_taper, store_int_env=store_int_env) END IF ecore2=ecore2+ecores IF (atener) THEN @@ -449,14 +441,14 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate IF ( nspins == 1 ) THEN CALL fock2C_ew(se_kind_a, rij, p_block_tot_a, ksa_block_a,& factor=0.5_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) ELSE IF ( nspins == 2 ) THEN CALL fock2C_ew(se_kind_a, rij, p_block_tot_a, ksa_block_a,& factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) CALL fock2C_ew(se_kind_a, rij, p_block_tot_a, ksa_block_b,& factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) END IF END IF END IF @@ -464,20 +456,20 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(se_kind_list,se_defined,se_natorb,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1, nspins - CALL cp_dbcsr_sum_replicated( diagmat_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_distribute(diagmat_ks(ispin)%matrix, error=error) + CALL cp_dbcsr_sum_replicated( diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_distribute(diagmat_ks(ispin)%matrix) CALL cp_dbcsr_add(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) END DO - CALL cp_dbcsr_deallocate_matrix_set ( diagmat_p, error=error ) - CALL cp_dbcsr_deallocate_matrix_set ( diagmat_ks, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( diagmat_p) + CALL cp_dbcsr_deallocate_matrix_set ( diagmat_ks) IF (calculate_forces) THEN DEALLOCATE(atom_of_kind,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ! Two-centers one-electron terms @@ -485,7 +477,7 @@ SUBROUTINE build_fock_matrix_coulomb (qs_env,ks_matrix,matrix_p,energy,calculate energy%hartree = ecore2 - energy%core ! WRITE ( *, * ) 'IN SE_F_COUL', ecore2, energy%core - CALL finalize_se_taper(se_taper,error=error) + CALL finalize_se_taper(se_taper) CALL timestop(handle) END SUBROUTINE build_fock_matrix_coulomb @@ -498,12 +490,11 @@ END SUBROUTINE build_fock_matrix_coulomb !> \param energy ... !> \param calculate_forces ... !> \param store_int_env ... -!> \param error ... !> \date 08.2008 [created] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& - calculate_forces, store_int_env, error) + calculate_forces, store_int_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -511,7 +502,6 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_fock_matrix_coulomb_lr', & routineP = moduleN//':'//routineN @@ -565,51 +555,50 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& se_control, ewald_env, ewald_pw, se_nddo_mpole, se_nonbond_env, se_section, mpole,& logger, virial, atprop) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, cell=cell, para_env=para_env,& atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set, particle_set=particle_set,& ewald_env=ewald_env,& local_particles=local_particles, ewald_pw=ewald_pw, se_nddo_mpole=se_nddo_mpole,& - se_nonbond_env=se_nonbond_env, virial=virial, atprop=atprop,& - error=error) + se_nonbond_env=se_nonbond_env, virial=virial, atprop=atprop) nlocal_particles = SUM(local_particles%n_el(:)) natoms = SIZE(particle_set) - CALL ewald_env_get (ewald_env, ewald_type=ewald_type, error=error) + CALL ewald_env_get (ewald_env, ewald_type=ewald_type) SELECT CASE(ewald_type) CASE (do_ewald_ewald) forces_g_size= nlocal_particles CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Periodic SE implemented only for standard EWALD sums.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT ! Parameters - se_section => section_vals_get_subs_vals(qs_env%input,"DFT%QS%SE",error=error) + se_section => section_vals_get_subs_vals(qs_env%input,"DFT%QS%SE") se_control => dft_control%qs_control%se_control anag = se_control%analytical_gradients use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer).AND.calculate_forces atener = atprop%energy nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_allocate_matrix_set(diagmat_ks,nspins,error=error) - CALL cp_dbcsr_allocate_matrix_set(diagmat_p,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(diagmat_ks,nspins) + CALL cp_dbcsr_allocate_matrix_set(diagmat_p,nspins) nkind = SIZE(atomic_kind_set) DO ispin=1,nspins ! Allocate diagonal block matrices ALLOCATE(diagmat_p(ispin)%matrix,diagmat_ks(ispin)%matrix)!sm->dbcsr - CALL cp_dbcsr_init(diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_init(diagmat_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_get_block_diag(matrix_p(ispin)%matrix, diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_get_block_diag(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(diagmat_ks(ispin)%matrix, 0.0_dp, error=error) - CALL cp_dbcsr_replicate_all(diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_replicate_all(diagmat_ks(ispin)%matrix, error=error) + CALL cp_dbcsr_init(diagmat_p(ispin)%matrix) + CALL cp_dbcsr_init(diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_get_block_diag(matrix_p(ispin)%matrix, diagmat_p(ispin)%matrix) + CALL cp_dbcsr_get_block_diag(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_set(diagmat_ks(ispin)%matrix, 0.0_dp) + CALL cp_dbcsr_replicate_all(diagmat_p(ispin)%matrix) + CALL cp_dbcsr_replicate_all(diagmat_ks(ispin)%matrix) END DO ! Check for implemented SE methods @@ -618,7 +607,7 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& do_method_rm1, do_method_mndod, do_method_pnnl) itype = get_se_type(dft_control%qs_control%method_id) CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Zero arrays and possibly build neighbor lists @@ -638,12 +627,12 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& CASE(do_multipole_quadrupole) task = .TRUE. CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Build-up neighbor lists for real-space part of Ewald multipoles CALL list_control ( atomic_kind_set, particle_set, local_particles, & - cell, se_nonbond_env, para_env, se_section, error=error) + cell, se_nonbond_env, para_env, se_section) enuc = 0.0_dp energy%core_overlap = 0.0_dp @@ -654,7 +643,7 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& DO ispin = 1, nspins ! Compute the NDDO mpole expansion DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a) IF (.NOT.defined .OR. natorb_a < 1) CYCLE @@ -664,7 +653,7 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& iatom = local_particles%list(ikind)%array(ilist) CALL cp_dbcsr_get_block_p(matrix=diagmat_p(ispin)%matrix,& row=iatom,col=iatom,BLOCK=pa_block_a,found=found) - CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,failure) ! Nuclei IF (task(1).AND.ispin==1) se_nddo_mpole%charge(iatom) = se_kind_a%zeff ! Electrons @@ -691,7 +680,7 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& ! Quadrupole IF (mpole%task(3).AND.task(3)) THEN qsph = fac*mpole%qs * pa_block_a(indi,indj) - CALL quadrupole_sph_to_cart(qcart, qsph, error) + CALL quadrupole_sph_to_cart(qcart, qsph) se_nddo_mpole%quadrupole(:,:,iatom) = se_nddo_mpole%quadrupole(:,:,iatom) +& qcart END IF @@ -715,20 +704,20 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& END IF ! Ewald Multipoles Sum - iw = cp_print_key_unit_nr(logger,se_section,"PRINT%EWALD_INFO",extension=".seLog",error=error) + iw = cp_print_key_unit_nr(logger,se_section,"PRINT%EWALD_INFO",extension=".seLog") IF(calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env, force=force, error=error) + CALL get_qs_env(qs_env=qs_env, force=force) ! Allocate atom index for kind ALLOCATE (atom_of_kind(natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, atom_of_kind=atom_of_kind) ! Allocate and zeroing arrays ALLOCATE ( forces_g(3, forces_g_size), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( forces_r(3, natoms), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) forces_g = 0.0_dp forces_r = 0.0_dp CALL ewald_multipole_evaluate(ewald_env, ewald_pw, se_nonbond_env, cell,& @@ -737,7 +726,7 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& charges=se_nddo_mpole%charge, dipoles=se_nddo_mpole%dipole, quadrupoles=se_nddo_mpole%quadrupole,& forces_local=forces_g, forces_glob=forces_r, pv_glob=pv_glob, pv_local=pv_local,& efield0=se_nddo_mpole%efield0, efield1=se_nddo_mpole%efield1, efield2=se_nddo_mpole%efield2, iw=iw,& - do_debug=.TRUE.,error=error) + do_debug=.TRUE.) ! Only SR force have to be summed up.. the one in g-space are already fully local.. CALL mp_sum(forces_r, para_env%group) ELSE @@ -746,15 +735,15 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& do_correction_bonded=.FALSE., do_forces=.FALSE., do_stress=.FALSE., do_efield=.TRUE.,& charges=se_nddo_mpole%charge, dipoles=se_nddo_mpole%dipole, quadrupoles=se_nddo_mpole%quadrupole,& efield0=se_nddo_mpole%efield0, efield1=se_nddo_mpole%efield1, efield2=se_nddo_mpole%efield2,& - iw=iw, do_debug=.TRUE.,error=error) + iw=iw, do_debug=.TRUE.) END IF - CALL cp_print_key_finished_output(iw,logger,se_section,"PRINT%EWALD_INFO",error=error) + CALL cp_print_key_finished_output(iw,logger,se_section,"PRINT%EWALD_INFO") ! Apply correction only when the Integral Scheme is different from Slater IF ((se_control%integral_screening/=do_se_IS_slater).AND.(.NOT.debug_this_module)) THEN CALL build_fock_matrix_coul_lrc(qs_env, ks_matrix, matrix_p, energy, calculate_forces,& store_int_env, se_nddo_mpole, task, diagmat_p, diagmat_ks, virial,& - pv_glob, error) + pv_glob) END IF ! Virial for the long-range part and correction @@ -776,7 +765,7 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& ! Modify the KS matrix and possibly compute derivatives node = 0 DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a) IF (.NOT.defined .OR. natorb_a < 1) CYCLE @@ -788,7 +777,7 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& DO ispin = 1, nspins CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(ispin)%matrix,& row=iatom,col=iatom,BLOCK=ksa_block_a,found=found) - CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,failure) ! Modify Hamiltonian Matrix accordingly potential, field and electric field gradient size_1c_int = SIZE(se_kind_a%w_mpole) @@ -842,22 +831,22 @@ SUBROUTINE build_fock_matrix_coulomb_lr (qs_env, ks_matrix, matrix_p, energy,& END IF DO ispin = 1, nspins - CALL cp_dbcsr_sum_replicated( diagmat_ks(ispin)%matrix, error=error ) - CALL cp_dbcsr_distribute(diagmat_ks(ispin)%matrix, error=error) + CALL cp_dbcsr_sum_replicated( diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_distribute(diagmat_ks(ispin)%matrix) CALL cp_dbcsr_add(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) END DO - CALL cp_dbcsr_deallocate_matrix_set ( diagmat_p, error=error ) - CALL cp_dbcsr_deallocate_matrix_set ( diagmat_ks, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( diagmat_p) + CALL cp_dbcsr_deallocate_matrix_set ( diagmat_ks) ! Set the Fock matrix contribution to SCP IF (calculate_forces) THEN DEALLOCATE(atom_of_kind,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(forces_g,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(forces_r,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF @@ -880,12 +869,11 @@ END SUBROUTINE build_fock_matrix_coulomb_lr !> \param diagmat_ks ... !> \param virial ... !> \param pv_glob ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 05.2009 ! ***************************************************************************** SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& calculate_forces, store_int_env,se_nddo_mpole,task,diagmat_p,diagmat_ks,& - virial, pv_glob, error) + virial, pv_glob) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & @@ -900,7 +888,6 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& TYPE(virial_type), POINTER :: virial REAL(KIND=dp), DIMENSION(3, 3), & INTENT(INOUT) :: pv_glob - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_fock_matrix_coul_lrc', & routineP = moduleN//':'//routineN @@ -955,10 +942,10 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, cell=cell, se_taper=se_taper,& para_env=para_env, sab_lrc=sab_lrc, atomic_kind_set=atomic_kind_set, & - qs_kind_set=qs_kind_set, particle_set=particle_set, atprop=atprop, error=error) + qs_kind_set=qs_kind_set, particle_set=particle_set, atprop=atprop) ! Parameters - CALL initialize_se_taper(se_taper,lr_corr=.TRUE.,error=error) + CALL initialize_se_taper(se_taper,lr_corr=.TRUE.) se_control => dft_control%qs_control%se_control anag = se_control%analytical_gradients use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer).AND.calculate_forces @@ -970,36 +957,36 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& pc_coulomb_int=.TRUE.) nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(diagmat_p),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(diagmat_ks),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(diagmat_p),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(diagmat_ks),cp_failure_level,routineP,failure) nkind = SIZE(atomic_kind_set) IF(calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env, force=force, error=error) + CALL get_qs_env(qs_env=qs_env, force=force) natom = SIZE (particle_set) delta = se_control%delta ! Allocate atom index for kind ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) END IF ! Allocate arrays for storing partial information on potential, field, field gradient size1 = SIZE(se_nddo_mpole%efield0) ALLOCATE (efield0(size1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) efield0 = 0.0_dp size1 = SIZE(se_nddo_mpole%efield1,1) size2 = SIZE(se_nddo_mpole%efield1,2) ALLOCATE (efield1(size1,size2), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) efield1 = 0.0_dp size1 = SIZE(se_nddo_mpole%efield2,1) size2 = SIZE(se_nddo_mpole%efield2,2) ALLOCATE (efield2(size1,size2), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) efield2 = 0.0_dp ! Initialize if virial is requested @@ -1015,9 +1002,9 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& itype = get_se_type(dft_control%qs_control%method_id) ALLOCATE (se_defined(nkind),se_kind_list(nkind),se_natorb(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) se_kind_list(ikind)%se_param => se_kind_a CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a) se_defined(ikind) = (defined .AND. natorb_a >= 1) @@ -1039,23 +1026,23 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& IF (inode==1) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(1)%matrix,& row=iatom,col=iatom,BLOCK=pa_block_a,found=found) - CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,failure) check = (SIZE(pa_block_a,1)==natorb_a).AND.(SIZE(pa_block_a,2)==natorb_a) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(1)%matrix,& row=iatom,col=iatom,BLOCK=ksa_block_a,found=found) - CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,failure) p_block_tot_a(1:natorb_a,1:natorb_a) = 2.0_dp * pa_block_a pa_a(1:natorb_a2) = RESHAPE(pa_block_a,(/natorb_a2/)) IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(2)%matrix,& row=iatom,col=iatom,BLOCK=pa_block_b,found=found) - CPPostcondition(ASSOCIATED(pa_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pa_block_b),cp_failure_level,routineP,failure) check = (SIZE(pa_block_b,1)==natorb_a).AND.(SIZE(pa_block_b,2)==natorb_a) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(2)%matrix,& row=iatom,col=iatom,BLOCK=ksa_block_b,found=found) - CPPostcondition(ASSOCIATED(ksa_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksa_block_b),cp_failure_level,routineP,failure) p_block_tot_a(1:natorb_a,1:natorb_a) = pa_block_a + pa_block_b pa_b(1:natorb_a2) = RESHAPE(pa_block_b,(/natorb_a2/)) END IF @@ -1078,31 +1065,31 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& force_ab=force_ab0, efield0=efield0, efield1=efield1, efield2=efield2,& rab2=dr1, rab=rij, ptens11=ptens11, ptens12=ptens12, ptens13=ptens13,& ptens21=ptens21, ptens22=ptens22, ptens23=ptens23, ptens31=ptens31,& - ptens32=ptens32, ptens33=ptens33, error=error) + ptens32=ptens32, ptens33=ptens33) ! Retrieve blocks for KS and P CALL cp_dbcsr_get_block_p(matrix=diagmat_p(1)%matrix,& row=jatom,col=jatom,BLOCK=pb_block_a,found=found) - CPPostcondition(ASSOCIATED(pb_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pb_block_a),cp_failure_level,routineP,failure) check = (SIZE(pb_block_a,1)==natorb_b).AND.(SIZE(pb_block_a,2)==natorb_b) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(1)%matrix,& row=jatom,col=jatom,BLOCK=ksb_block_a,found=found) - CPPostcondition(ASSOCIATED(ksb_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksb_block_a),cp_failure_level,routineP,failure) p_block_tot_b(1:natorb_b,1:natorb_b) = 2.0_dp * pb_block_a pb_a(1:natorb_b2) = RESHAPE(pb_block_a,(/natorb_b2/)) ! Handle more than one configuration IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(2)%matrix,& row=jatom,col=jatom,BLOCK=pb_block_b,found=found) - CPPostcondition(ASSOCIATED(pb_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pb_block_b),cp_failure_level,routineP,failure) check = (SIZE(pb_block_b,1)==natorb_b).AND.(SIZE(pb_block_b,2)==natorb_b) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(2)%matrix,& row=jatom,col=jatom,BLOCK=ksb_block_b,found=found) - CPPostcondition(ASSOCIATED(ksb_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksb_block_b),cp_failure_level,routineP,failure) check = (SIZE(pb_block_a,1)==SIZE(pb_block_b,1)).AND.(SIZE(pb_block_a,2)==SIZE(pb_block_b,2)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) p_block_tot_b(1:natorb_b,1:natorb_b) = pb_block_a + pb_block_b pb_b(1:natorb_b2) = RESHAPE(pb_block_b,(/natorb_b2/)) END IF @@ -1112,7 +1099,7 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& do_method_rm1, do_method_mndod) ! Evaluate nuclear contribution.. CALL corecore_el (se_kind_a,se_kind_b,rij,enuc=enuc,itype=itype,anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) enuclear = enuclear + enuc ! Two-centers One-electron terms @@ -1120,17 +1107,16 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& ecab = 0._dp CALL fock2_1el (se_kind_a,se_kind_b,rij, ksa_block_a, ksb_block_a,& pa_a, pb_a, ecore=ecab, itype=itype, anag=anag, se_int_control=se_int_control,& - se_taper=se_taper, store_int_env=store_int_env, error=error) + se_taper=se_taper, store_int_env=store_int_env) ecore2 = ecore2 + ecab(1) + ecab(2) ELSE IF ( nspins == 2 ) THEN ecab = 0._dp CALL fock2_1el (se_kind_a,se_kind_b,rij, ksa_block_a, ksb_block_a,& pa_block_a, pb_block_a, ecore=ecab, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env) CALL fock2_1el (se_kind_a,se_kind_b,rij, ksa_block_b, ksb_block_b,& pa_b, pb_b, ecore=ecab, itype=itype, anag=anag, se_int_control=se_int_control,& - se_taper=se_taper, store_int_env=store_int_env, error=error) + se_taper=se_taper, store_int_env=store_int_env) ecore2 = ecore2 + ecab(1) + ecab(2) END IF IF (atener) THEN @@ -1141,15 +1127,15 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& IF ( nspins == 1 ) THEN CALL fock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, ksa_block_a, p_block_tot_b,& ksb_block_a, factor=0.5_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) ELSE IF ( nspins == 2 ) THEN CALL fock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, ksa_block_a, p_block_tot_b,& ksb_block_a, factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) CALL fock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, ksa_block_b, p_block_tot_b,& ksb_block_b, factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper,& - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) END IF IF(calculate_forces) THEN @@ -1158,23 +1144,21 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& ! Evaluate nuclear contribution.. CALL dcorecore_el (se_kind_a,se_kind_b,rij,denuc=force_ab,itype=itype,delta=delta,& - anag=anag,se_int_control=se_int_control,se_taper=se_taper,error=error) + anag=anag,se_int_control=se_int_control,se_taper=se_taper) ! Derivatives of the Two-centre One-electron terms IF ( nspins == 1 ) THEN CALL dfock2_1el (se_kind_a,se_kind_b,rij, pa_a, pb_a, itype=itype, anag=anag,& se_int_control=se_int_control, se_taper=se_taper, force=force_ab,& - delta=delta, error=error) + delta=delta) ELSE IF ( nspins == 2 ) THEN CALL dfock2_1el (se_kind_a,se_kind_b,rij, pa_block_a, pb_block_a, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) CALL dfock2_1el (se_kind_a,se_kind_b,rij, pa_b, pb_b, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) END IF IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij) END IF force_ab = force_ab + force_ab0 @@ -1192,16 +1176,13 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& force_ab = 0._dp IF ( nspins == 1 ) THEN CALL dfock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, p_block_tot_b, factor=0.25_dp,& - anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) ELSE IF ( nspins == 2 ) THEN CALL dfock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, p_block_tot_b, factor=0.50_dp,& - anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) CALL dfock2C(se_kind_a, se_kind_b, rij, switch, p_block_tot_a, p_block_tot_b, factor=0.50_dp,& - anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta,& - error=error) + anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab, delta=delta) END IF IF ( switch ) THEN force_ab(1) = -force_ab(1) @@ -1209,7 +1190,7 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& force_ab(3) = -force_ab(3) END IF IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij) END IF ! Sum up force components @@ -1223,14 +1204,14 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& force(jkind)%rho_elec(3,atom_b) = force(jkind)%rho_elec(3,atom_b) + force_ab(3) END IF CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(se_kind_list,se_defined,se_natorb,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Sum-up Virial constribution (long-range correction) IF (use_virial) THEN @@ -1247,7 +1228,7 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& IF (calculate_forces) THEN DEALLOCATE(atom_of_kind,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ! collect information on potential, field, field gradient @@ -1259,18 +1240,18 @@ SUBROUTINE build_fock_matrix_coul_lrc (qs_env,ks_matrix,matrix_p,energy,& se_nddo_mpole%efield2 = se_nddo_mpole%efield2 - efield2 ! deallocate working arrays DEALLOCATE (efield0, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (efield1, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (efield2, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Corrections for two-centers one-electron terms + nuclear terms CALL mp_sum(enuclear,para_env%group) CALL mp_sum(ecore2,para_env%group) energy%hartree = energy%hartree + ecore2 energy%core_overlap = enuclear - CALL finalize_se_taper(se_taper,error=error) + CALL finalize_se_taper(se_taper) CALL timestop(handle) END SUBROUTINE build_fock_matrix_coul_lrc @@ -1284,16 +1265,14 @@ END SUBROUTINE build_fock_matrix_coul_lrc !> \param matrix_p ... !> \param energy ... !> \param calculate_forces ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 12.2008 ! ***************************************************************************** - SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calculate_forces,error) + SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calculate_forces) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix, matrix_p TYPE(qs_energy_type), POINTER :: energy LOGICAL, INTENT(in) :: calculate_forces - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_fock_matrix_coul_lr_r3', & routineP = moduleN//':'//routineN @@ -1348,62 +1327,62 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula failure=.FALSE. CALL timeset(routineN,handle) - CALL get_qs_env(qs_env=qs_env, error=error)!sm->dbcsr + CALL get_qs_env(qs_env=qs_env)!sm->dbcsr NULLIFY(dft_control, cell, force, particle_set, diagmat_ks, & diagmat_p, local_particles, se_control, ewald_env, ewald_pw, & se_nddo_mpole, se_nonbond_env, se_section, sab_orb, logger, atprop) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_qs_env(qs_env=qs_env, dft_control=dft_control, cell=cell, para_env=para_env,& atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set, particle_set=particle_set,& ewald_env=ewald_env, atprop=atprop,& local_particles=local_particles, ewald_pw=ewald_pw, se_nddo_mpole=se_nddo_mpole,& - se_nonbond_env=se_nonbond_env, sab_orb=sab_orb, error=error) + se_nonbond_env=se_nonbond_env, sab_orb=sab_orb) nlocal_particles = SUM(local_particles%n_el(:)) natoms = SIZE(particle_set) - CALL ewald_env_get (ewald_env, ewald_type=ewald_type, error=error) + CALL ewald_env_get (ewald_env, ewald_type=ewald_type) SELECT CASE(ewald_type) CASE (do_ewald_ewald) ! Do Nothing CASE DEFAULT CALL cp_unimplemented_error(fromWhere=routineP, & message="Periodic SE implemented only for standard EWALD sums.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT ! Parameters - se_section => section_vals_get_subs_vals(qs_env%input,"DFT%QS%SE",error=error) + se_section => section_vals_get_subs_vals(qs_env%input,"DFT%QS%SE") se_control => dft_control%qs_control%se_control anag = se_control%analytical_gradients atener = atprop%energy nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_allocate_matrix_set(diagmat_ks,nspins,error=error) - CALL cp_dbcsr_allocate_matrix_set(diagmat_p,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(diagmat_ks,nspins) + CALL cp_dbcsr_allocate_matrix_set(diagmat_p,nspins) nkind = SIZE(atomic_kind_set) DO ispin=1,nspins ! Allocate diagonal block matrices ALLOCATE(diagmat_p(ispin)%matrix,diagmat_ks(ispin)%matrix)!sm->dbcsr - CALL cp_dbcsr_init(diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_init(diagmat_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_get_block_diag(matrix_p(ispin)%matrix, diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_get_block_diag(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix, error=error) - CALL cp_dbcsr_set(diagmat_ks(ispin)%matrix, 0.0_dp, error=error) - CALL cp_dbcsr_replicate_all(diagmat_p(ispin)%matrix, error=error) - CALL cp_dbcsr_replicate_all(diagmat_ks(ispin)%matrix, error=error) + CALL cp_dbcsr_init(diagmat_p(ispin)%matrix) + CALL cp_dbcsr_init(diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_get_block_diag(matrix_p(ispin)%matrix, diagmat_p(ispin)%matrix) + CALL cp_dbcsr_get_block_diag(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_set(diagmat_ks(ispin)%matrix, 0.0_dp) + CALL cp_dbcsr_replicate_all(diagmat_p(ispin)%matrix) + CALL cp_dbcsr_replicate_all(diagmat_ks(ispin)%matrix) END DO ! Possibly compute forces IF(calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,force=force) ALLOCATE (atom_of_kind(natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) END IF itype = get_se_type(dft_control%qs_control%method_id) @@ -1411,9 +1390,9 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula ecore2 = 0.0_dp ! Real space part of the 1/R^3 sum ALLOCATE (se_defined(nkind),se_kind_list(nkind),se_natorb(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) se_kind_list(ikind)%se_param => se_kind_a CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a) se_defined(ikind) = (defined .AND. natorb_a >= 1) @@ -1435,23 +1414,23 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula IF (inode==1) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(1)%matrix,& row=iatom,col=iatom,BLOCK=pa_block_a,found=found) - CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pa_block_a),cp_failure_level,routineP,failure) check = (SIZE(pa_block_a,1)==natorb_a).AND.(SIZE(pa_block_a,2)==natorb_a) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(1)%matrix,& row=iatom,col=iatom,BLOCK=ksa_block_a,found=found) - CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksa_block_a),cp_failure_level,routineP,failure) p_block_tot_a(1:natorb_a,1:natorb_a) = 2.0_dp * pa_block_a pa_a(1:natorb_a2) = RESHAPE(pa_block_a,(/natorb_a2/)) IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(2)%matrix,& row=iatom,col=iatom,BLOCK=pa_block_b,found=found) - CPPostcondition(ASSOCIATED(pa_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pa_block_b),cp_failure_level,routineP,failure) check = (SIZE(pa_block_b,1)==natorb_a).AND.(SIZE(pa_block_b,2)==natorb_a) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(2)%matrix,& row=iatom,col=iatom,BLOCK=ksa_block_b,found=found) - CPPostcondition(ASSOCIATED(ksa_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksa_block_b),cp_failure_level,routineP,failure) p_block_tot_a(1:natorb_a,1:natorb_a) = pa_block_a + pa_block_b pa_b(1:natorb_a2) = RESHAPE(pa_block_b,(/natorb_a2/)) END IF @@ -1468,26 +1447,26 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula ! Retrieve blocks for KS and P CALL cp_dbcsr_get_block_p(matrix=diagmat_p(1)%matrix,& row=jatom,col=jatom,BLOCK=pb_block_a,found=found) - CPPostcondition(ASSOCIATED(pb_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pb_block_a),cp_failure_level,routineP,failure) check = (SIZE(pb_block_a,1)==natorb_b).AND.(SIZE(pb_block_a,2)==natorb_b) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(1)%matrix,& row=jatom,col=jatom,BLOCK=ksb_block_a,found=found) - CPPostcondition(ASSOCIATED(ksb_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksb_block_a),cp_failure_level,routineP,failure) p_block_tot_b(1:natorb_b,1:natorb_b) = 2.0_dp * pb_block_a pb_a(1:natorb_b2) = RESHAPE(pb_block_a,(/natorb_b2/)) ! Handle more than one configuration IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=diagmat_p(2)%matrix,& row=jatom,col=jatom,BLOCK=pb_block_b,found=found) - CPPostcondition(ASSOCIATED(pb_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pb_block_b),cp_failure_level,routineP,failure) check = (SIZE(pb_block_b,1)==natorb_b).AND.(SIZE(pb_block_b,2)==natorb_b) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=diagmat_ks(2)%matrix,& row=jatom,col=jatom,BLOCK=ksb_block_b,found=found) - CPPostcondition(ASSOCIATED(ksb_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ksb_block_b),cp_failure_level,routineP,failure) check = (SIZE(pb_block_a,1)==SIZE(pb_block_b,1)).AND.(SIZE(pb_block_a,2)==SIZE(pb_block_b,2)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) p_block_tot_b(1:natorb_b,1:natorb_b) = pb_block_a + pb_block_b pb_b(1:natorb_b2) = RESHAPE(pb_block_b,(/natorb_b2/)) END IF @@ -1506,17 +1485,17 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula ecab = 0._dp CALL fock2_1el_r3(se_kind_a, se_kind_b, ksa_block_a, ksb_block_a, pa_a, pb_a,& ecore=ecab, e1b=se_kind_a%expns3_int(jkind)%expns3%e1b,& - e2a=se_kind_a%expns3_int(jkind)%expns3%e2a, rp=r3inv, error=error) + e2a=se_kind_a%expns3_int(jkind)%expns3%e2a, rp=r3inv) ecore2 = ecore2 + ecab(1) + ecab(2) ELSE IF ( nspins == 2 ) THEN ecab = 0._dp CALL fock2_1el_r3(se_kind_a, se_kind_b, ksa_block_a, ksb_block_a, pa_block_a,& pb_block_a, ecore=ecab, e1b=se_kind_a%expns3_int(jkind)%expns3%e1b,& - e2a=se_kind_a%expns3_int(jkind)%expns3%e2a, rp=r3inv, error=error) + e2a=se_kind_a%expns3_int(jkind)%expns3%e2a, rp=r3inv) CALL fock2_1el_r3(se_kind_a, se_kind_b, ksa_block_b, ksb_block_b, pa_b, pb_b,& ecore=ecab, e1b=se_kind_a%expns3_int(jkind)%expns3%e1b,& - e2a=se_kind_a%expns3_int(jkind)%expns3%e2a, rp=r3inv, error=error) + e2a=se_kind_a%expns3_int(jkind)%expns3%e2a, rp=r3inv) ecore2 = ecore2 + ecab(1) + ecab(2) END IF IF (atener) THEN @@ -1526,16 +1505,13 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula ! Coulomb Terms IF ( nspins == 1 ) THEN CALL fock2C_r3(se_kind_a, se_kind_b, switch, p_block_tot_a, ksa_block_a, p_block_tot_b,& - ksb_block_a, factor=0.5_dp, w=se_kind_a%expns3_int(jkind)%expns3%w, rp=r3inv,& - error=error) + ksb_block_a, factor=0.5_dp, w=se_kind_a%expns3_int(jkind)%expns3%w, rp=r3inv) ELSE IF ( nspins == 2 ) THEN CALL fock2C_r3(se_kind_a, se_kind_b, switch, p_block_tot_a, ksa_block_a, p_block_tot_b,& - ksb_block_a, factor=1.0_dp, w=se_kind_a%expns3_int(jkind)%expns3%w, rp=r3inv,& - error=error) + ksb_block_a, factor=1.0_dp, w=se_kind_a%expns3_int(jkind)%expns3%w, rp=r3inv) CALL fock2C_r3(se_kind_a, se_kind_b, switch, p_block_tot_a, ksa_block_b, p_block_tot_b,& - ksb_block_b, factor=1.0_dp, w=se_kind_a%expns3_int(jkind)%expns3%w, rp=r3inv,& - error=error) + ksb_block_b, factor=1.0_dp, w=se_kind_a%expns3_int(jkind)%expns3%w, rp=r3inv) END IF ! Compute forces if requested @@ -1548,16 +1524,13 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula ! Derivatives of the One-centre One-electron terms IF ( nspins == 1 ) THEN CALL dfock2_1el_r3(se_kind_a,se_kind_b, dr3inv, pa_a, pb_a, force_ab,& - se_kind_a%expns3_int(jkind)%expns3%e1b, se_kind_a%expns3_int(jkind)%expns3%e2a,& - error=error) + se_kind_a%expns3_int(jkind)%expns3%e1b, se_kind_a%expns3_int(jkind)%expns3%e2a) ELSE IF ( nspins == 2 ) THEN CALL dfock2_1el_r3(se_kind_a,se_kind_b, dr3inv, pa_block_a, pb_block_a, force_ab,& - se_kind_a%expns3_int(jkind)%expns3%e1b, se_kind_a%expns3_int(jkind)%expns3%e2a,& - error=error) + se_kind_a%expns3_int(jkind)%expns3%e1b, se_kind_a%expns3_int(jkind)%expns3%e2a) CALL dfock2_1el_r3(se_kind_a,se_kind_b, dr3inv, pa_b, pb_b, force_ab,& - se_kind_a%expns3_int(jkind)%expns3%e1b, se_kind_a%expns3_int(jkind)%expns3%e2a,& - error=error) + se_kind_a%expns3_int(jkind)%expns3%e1b, se_kind_a%expns3_int(jkind)%expns3%e2a) END IF ! Sum up force components @@ -1574,13 +1547,13 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula force_ab = 0.0_dp IF ( nspins == 1 ) THEN CALL dfock2C_r3(se_kind_a, se_kind_b, switch, p_block_tot_a, p_block_tot_b, factor=0.25_dp,& - w=se_kind_a%expns3_int(jkind)%expns3%w, drp=dr3inv, force=force_ab, error=error) + w=se_kind_a%expns3_int(jkind)%expns3%w, drp=dr3inv, force=force_ab) ELSE IF ( nspins == 2 ) THEN CALL dfock2C_r3(se_kind_a, se_kind_b, switch, p_block_tot_a, p_block_tot_b, factor=0.50_dp,& - w=se_kind_a%expns3_int(jkind)%expns3%w, drp=dr3inv, force=force_ab, error=error) + w=se_kind_a%expns3_int(jkind)%expns3%w, drp=dr3inv, force=force_ab) CALL dfock2C_r3(se_kind_a, se_kind_b, switch, p_block_tot_a, p_block_tot_b, factor=0.50_dp,& - w=se_kind_a%expns3_int(jkind)%expns3%w, drp=dr3inv, force=force_ab, error=error) + w=se_kind_a%expns3_int(jkind)%expns3%w, drp=dr3inv, force=force_ab) END IF ! Sum up force components @@ -1594,27 +1567,27 @@ SUBROUTINE build_fock_matrix_coul_lr_r3(qs_env,ks_matrix,matrix_p,energy,calcula force(jkind)%rho_elec(3,atom_b) = force(jkind)%rho_elec(3,atom_b) + force_ab(3) END IF CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(se_kind_list,se_defined,se_natorb,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO ispin = 1, nspins - CALL cp_dbcsr_sum_replicated( diagmat_ks(ispin)%matrix, error=error ) - CALL cp_dbcsr_distribute(diagmat_ks(ispin)%matrix, error=error) + CALL cp_dbcsr_sum_replicated( diagmat_ks(ispin)%matrix) + CALL cp_dbcsr_distribute(diagmat_ks(ispin)%matrix) CALL cp_dbcsr_add(ks_matrix(ispin)%matrix, diagmat_ks(ispin)%matrix,& - 1.0_dp,1.0_dp,error=error) + 1.0_dp,1.0_dp) END DO - CALL cp_dbcsr_deallocate_matrix_set ( diagmat_p, error=error ) - CALL cp_dbcsr_deallocate_matrix_set ( diagmat_ks, error=error ) + CALL cp_dbcsr_deallocate_matrix_set ( diagmat_p) + CALL cp_dbcsr_deallocate_matrix_set ( diagmat_ks) IF (calculate_forces) THEN DEALLOCATE(atom_of_kind,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ! Two-centers one-electron terms diff --git a/src/se_fock_matrix_dbg.F b/src/se_fock_matrix_dbg.F index f88a8a7f6a..538a4fe991 100644 --- a/src/se_fock_matrix_dbg.F +++ b/src/se_fock_matrix_dbg.F @@ -34,11 +34,10 @@ MODULE se_fock_matrix_dbg !> \param matrix_p ... !> \param calculate_forces ... !> \param store_int_env ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 04.2009 ! ***************************************************************************** SUBROUTINE dbg_energy_coulomb_lr(energy, ks_matrix, nspins, qs_env, matrix_p,& - calculate_forces, store_int_env, error) + calculate_forces, store_int_env) TYPE(qs_energy_type), POINTER :: energy TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix @@ -48,7 +47,6 @@ SUBROUTINE dbg_energy_coulomb_lr(energy, ks_matrix, nspins, qs_env, matrix_p,& POINTER :: matrix_p LOGICAL, INTENT(IN) :: calculate_forces TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ispin LOGICAL :: failure @@ -58,17 +56,16 @@ SUBROUTINE dbg_energy_coulomb_lr(energy, ks_matrix, nspins, qs_env, matrix_p,& ! Zero structures only for debugging purpose CALL init_qs_energy(energy) DO ispin = 1, nspins - CALL cp_dbcsr_set(ks_matrix(ispin)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(ks_matrix(ispin)%matrix,0.0_dp) END DO ! Evaluate Coulomb Long-Range CALL build_fock_matrix_coulomb_lr(qs_env,ks_matrix,matrix_p,energy,calculate_forces,& - store_int_env,error) + store_int_env) ! Compute the Hartree energy DO ispin=1,nspins - CALL cp_dbcsr_trace(ks_matrix(ispin)%matrix,matrix_p(ispin)%matrix,trace=ecoul,& - error=error) + CALL cp_dbcsr_trace(ks_matrix(ispin)%matrix,matrix_p(ispin)%matrix,trace=ecoul) energy%hartree = energy%hartree + ecoul WRITE(*,*)ispin,"ECOUL ",ecoul diff --git a/src/se_fock_matrix_exchange.F b/src/se_fock_matrix_exchange.F index ff32e2053e..6faf389533 100644 --- a/src/se_fock_matrix_exchange.F +++ b/src/se_fock_matrix_exchange.F @@ -73,18 +73,16 @@ MODULE se_fock_matrix_exchange !> \param matrix_p ... !> \param calculate_forces ... !> \param store_int_env ... -!> \param error ... !> \author JGH ! ***************************************************************************** SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_forces,& - store_int_env, error) + store_int_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix, matrix_p LOGICAL, INTENT(in) :: calculate_forces TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_fock_matrix_exchange', & routineP = moduleN//':'//routineN @@ -132,16 +130,16 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo NULLIFY(dft_control,cell,force,particle_set,se_control,se_taper) CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,cell=cell,se_taper=se_taper,& - para_env=para_env,virial=virial,error=error) + para_env=para_env,virial=virial) - CALL initialize_se_taper(se_taper,exchange=.TRUE.,error=error) + CALL initialize_se_taper(se_taper,exchange=.TRUE.) se_control => dft_control%qs_control%se_control anag = se_control%analytical_gradients use_virial = virial%pv_availability.AND.(.NOT.virial%pv_numer) nspins=dft_control%nspins - CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix_p),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) ! Identify proper integral screening (according user requests) integral_screening = se_control%integral_screening @@ -153,22 +151,22 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.) CALL get_qs_env(qs_env=qs_env,sab_orb=sab_orb,& - atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,error=error) + atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set) nkind = SIZE(atomic_kind_set) IF(calculate_forces) THEN - CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,force=force,error=error) + CALL get_qs_env(qs_env=qs_env,particle_set=particle_set,force=force) natom = SIZE (particle_set) ALLOCATE (atom_of_kind(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) delta = se_control%delta CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,atom_of_kind=atom_of_kind) END IF ALLOCATE (se_defined(nkind),se_kind_list(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind),se_parameter=se_kind_a) se_kind_list(ikind)%se_param => se_kind_a CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a) se_defined(ikind) = (defined .AND. natorb_a >= 1) @@ -194,10 +192,10 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo ! Retrieve blocks for KS and P CALL cp_dbcsr_get_block_p(matrix=ks_matrix(1)%matrix,& row=irow,col=icol,BLOCK=ks_block_a,found=found) - CPPostcondition(ASSOCIATED(ks_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ks_block_a),cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=matrix_p(1)%matrix,& row=irow,col=icol,BLOCK=p_block_a,found=found) - CPPostcondition(ASSOCIATED(p_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_block_a),cp_failure_level,routineP,failure) size_p_block_a(1) = SIZE(p_block_a,1) size_p_block_a(2) = SIZE(p_block_a,2) p_block_tot(1:size_p_block_a(1),1:size_p_block_a(2)) = 2.0_dp * p_block_a @@ -206,12 +204,12 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=ks_matrix(2)%matrix,& row=irow,col=icol,BLOCK=ks_block_b,found=found) - CPPostcondition(ASSOCIATED(ks_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ks_block_b),cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=matrix_p(2)%matrix,& row=irow,col=icol,BLOCK=p_block_b,found=found) - CPPostcondition(ASSOCIATED(p_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(p_block_b),cp_failure_level,routineP,failure) check = (size_p_block_a(1)==SIZE(p_block_b,1)).AND.(size_p_block_a(2)==SIZE(p_block_b,2)) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) p_block_tot(1:SIZE(p_block_a,1),1:SIZE(p_block_a,2)) = p_block_a + p_block_b END IF @@ -219,25 +217,25 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo IF ( iatom == jatom .AND. dr < rij_threshold ) THEN ! Once center - Two electron Terms IF ( nspins == 1 ) THEN - CALL fock1_2el(se_kind_a,p_block_tot,p_block_a,ks_block_a,factor=0.5_dp,error=error) + CALL fock1_2el(se_kind_a,p_block_tot,p_block_a,ks_block_a,factor=0.5_dp) ELSE IF ( nspins == 2 ) THEN - CALL fock1_2el(se_kind_a,p_block_tot,p_block_a,ks_block_a,factor=1.0_dp,error=error) - CALL fock1_2el(se_kind_a,p_block_tot,p_block_b,ks_block_b,factor=1.0_dp,error=error) + CALL fock1_2el(se_kind_a,p_block_tot,p_block_a,ks_block_a,factor=1.0_dp) + CALL fock1_2el(se_kind_a,p_block_tot,p_block_b,ks_block_b,factor=1.0_dp) END IF ELSE ! Exchange Terms IF ( nspins == 1 ) THEN CALL fock2E(se_kind_a, se_kind_b, rij, switch, size_p_block_a, p_block_a, ks_block_a,& factor=0.5_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper, & - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) ELSE IF ( nspins == 2 ) THEN CALL fock2E(se_kind_a, se_kind_b, rij, switch, size_p_block_a, p_block_a, ks_block_a,& factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper, & - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) CALL fock2E(se_kind_a, se_kind_b, rij, switch, size_p_block_a, p_block_b, ks_block_b,& factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper, & - store_int_env=store_int_env, error=error) + store_int_env=store_int_env) END IF IF(calculate_forces) THEN atom_a = atom_of_kind(iatom) @@ -246,15 +244,15 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo IF ( nspins == 1 ) THEN CALL dfock2E(se_kind_a, se_kind_b, rij, switch, size_p_block_a, p_block_a,& factor=0.5_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab,& - delta=delta, error=error) + delta=delta) ELSE IF ( nspins == 2 ) THEN CALL dfock2E(se_kind_a, se_kind_b, rij, switch, size_p_block_a, p_block_a,& factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab,& - delta=delta, error=error) + delta=delta) CALL dfock2E(se_kind_a, se_kind_b, rij, switch, size_p_block_a, p_block_b,& factor=1.0_dp, anag=anag, se_int_control=se_int_control, se_taper=se_taper, force=force_ab,& - delta=delta, error=error) + delta=delta) END IF IF (switch) THEN force_ab(1) = -force_ab(1) @@ -262,7 +260,7 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo force_ab(3) = -force_ab(3) END IF IF (use_virial) THEN - CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij, error) + CALL virial_pair_force ( virial%pv_virial, -1.0_dp, force_ab, rij) END IF force(ikind)%rho_elec(1,atom_a) = force(ikind)%rho_elec(1,atom_a) - force_ab(1) @@ -279,13 +277,13 @@ SUBROUTINE build_fock_matrix_exchange (qs_env, ks_matrix, matrix_p, calculate_fo CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(se_kind_list,se_defined,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (calculate_forces) THEN DEALLOCATE(atom_of_kind,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL finalize_se_taper(se_taper,error=error) + CALL finalize_se_taper(se_taper) CALL timestop(handle) @@ -295,14 +293,12 @@ END SUBROUTINE build_fock_matrix_exchange !> \brief ... !> \param qs_env ... !> \param ks_matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE build_fock_matrix_ph(qs_env, ks_matrix, error) + SUBROUTINE build_fock_matrix_ph(qs_env, ks_matrix) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'build_fock_matrix_ph', & routineP = moduleN//':'//routineN @@ -335,24 +331,24 @@ SUBROUTINE build_fock_matrix_ph(qs_env, ks_matrix, error) NULLIFY(dft_control, se_control) CALL get_qs_env(qs_env=qs_env,dft_control=dft_control,& - para_env=para_env,error=error) + para_env=para_env) se_control => dft_control%qs_control%se_control anag = se_control%analytical_gradients nspins=dft_control%nspins - CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(ks_matrix)>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env,sab_orb=sab_orb,& - atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set,error=error) + atomic_kind_set=atomic_kind_set,qs_kind_set=qs_kind_set) nkind = SIZE(atomic_kind_set) ALLOCATE (se_defined(nkind),se_kind_list(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind - CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a, error=error) + CALL get_qs_kind(qs_kind_set(ikind), se_parameter=se_kind_a) se_kind_list(ikind)%se_param => se_kind_a CALL get_se_param(se_kind_a,defined=defined,natorb=natorb_a) se_defined(ikind) = (defined .AND. natorb_a >= 1) @@ -378,7 +374,7 @@ SUBROUTINE build_fock_matrix_ph(qs_env, ks_matrix, error) ! Retrieve blocks for KS CALL cp_dbcsr_get_block_p(matrix=ks_matrix(1)%matrix,& row=irow,col=icol,BLOCK=ks_block_a,found=found) - CPPostcondition(ASSOCIATED(ks_block_a),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ks_block_a),cp_failure_level,routineP,failure) ifHi= (atomic_kind_set(ikind)%element_symbol=='H ') ifHj= (atomic_kind_set(jkind)%element_symbol=='H ') @@ -428,14 +424,14 @@ SUBROUTINE build_fock_matrix_ph(qs_env, ks_matrix, error) IF ( nspins == 2 ) THEN CALL cp_dbcsr_get_block_p(matrix=ks_matrix(2)%matrix,& row=irow,col=icol,BLOCK=ks_block_b,found=found) - CPPostcondition(ASSOCIATED(ks_block_b),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ks_block_b),cp_failure_level,routineP,failure) END IF END DO CALL neighbor_list_iterator_release(nl_iterator) DEALLOCATE(se_kind_list,se_defined,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/se_fock_matrix_integrals.F b/src/se_fock_matrix_integrals.F index ff19ea7b6c..77bac21360 100644 --- a/src/se_fock_matrix_integrals.F +++ b/src/se_fock_matrix_integrals.F @@ -54,12 +54,11 @@ MODULE se_fock_matrix_integrals !> \param se_int_control ... !> \param se_taper ... !> \param store_int_env ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE fock2_1el (sepi, sepj, rij, ksi_block, ksj_block, pi_block, pj_block,& - ecore, itype, anag, se_int_control, se_taper, store_int_env, error) + ecore, itype, anag, se_int_control, se_taper, store_int_env) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij REAL(KIND=dp), DIMENSION(:, :), POINTER :: ksi_block, ksj_block @@ -76,7 +75,6 @@ SUBROUTINE fock2_1el (sepi, sepj, rij, ksi_block, ksj_block, pi_block, pj_block, TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock2_1el', & routineP = moduleN//':'//routineN @@ -88,8 +86,7 @@ SUBROUTINE fock2_1el (sepi, sepj, rij, ksi_block, ksj_block, pi_block, pj_block, failure = .FALSE. ! Compute integrals CALL rotnuc (sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env) ! ! Add the electron-nuclear attraction term for atom sepi ! @@ -142,12 +139,11 @@ END SUBROUTINE fock2_1el !> \param se_taper ... !> \param force ... !> \param delta ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE dfock2_1el (sepi, sepj, rij, pi_block, pj_block, itype, anag,& - se_int_control, se_taper, force, delta, error) + se_int_control, se_taper, force, delta) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij REAL(KIND=dp), & @@ -163,7 +159,6 @@ SUBROUTINE dfock2_1el (sepi, sepj, rij, pi_block, pj_block, itype, anag,& REAL(KIND=dp), DIMENSION(3), & INTENT(INOUT) :: force REAL(KIND=dp), INTENT(IN) :: delta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dfock2_1el', & routineP = moduleN//':'//routineN @@ -176,7 +171,7 @@ SUBROUTINE dfock2_1el (sepi, sepj, rij, pi_block, pj_block, itype, anag,& failure = .FALSE. ! Compute integrals CALL drotnuc (sepi, sepj, rij, de1b=de1b, de2a=de2a, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, delta=delta, error=error) + se_int_control=se_int_control, se_taper=se_taper, delta=delta) ! ! Add the electron-nuclear attraction term for atom sepi ! @@ -227,11 +222,10 @@ END SUBROUTINE dfock2_1el !> \param p_mat ... !> \param f_mat DIMENSION(sep%natorb, sep%natorb) !> \param factor ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE fock1_2el(sep, p_tot, p_mat, f_mat, factor, error) + SUBROUTINE fock1_2el(sep, p_tot, p_mat, f_mat, factor) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), DIMENSION(45, 45), & INTENT(IN) :: p_tot @@ -240,7 +234,6 @@ SUBROUTINE fock1_2el(sep, p_tot, p_mat, f_mat, factor, error) INTENT(IN) :: p_mat REAL(KIND=dp), DIMENSION(:, :), POINTER :: f_mat REAL(KIND=dp), INTENT(IN) :: factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock1_2el', & routineP = moduleN//':'//routineN @@ -305,12 +298,11 @@ END SUBROUTINE fock1_2el !> \param se_int_control ... !> \param se_taper ... !> \param store_int_env ... -!> \param error ... !> \date 04.2009 [jgh] !> \author jgh - University of Zurich ! ***************************************************************************** SUBROUTINE fock2_1el_ew (sep, rij, ks_block, p_block, ecore, itype, anag, & - se_int_control, se_taper, store_int_env, error) + se_int_control, se_taper, store_int_env) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij REAL(KIND=dp), DIMENSION(:, :), POINTER :: ks_block @@ -323,7 +315,6 @@ SUBROUTINE fock2_1el_ew (sep, rij, ks_block, p_block, ecore, itype, anag, & TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock2_1el_ew', & routineP = moduleN//':'//routineN @@ -335,8 +326,7 @@ SUBROUTINE fock2_1el_ew (sep, rij, ks_block, p_block, ecore, itype, anag, & failure = .FALSE. ! Compute integrals CALL rotnuc (sep, sep, rij, e1b=e1b, e2a=e2a, itype=itype, anag=anag,& - se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env,& - error=error) + se_int_control=se_int_control, se_taper=se_taper, store_int_env=store_int_env) ! ! Add the electron-nuclear attraction term for atom sep ! e1b == e2a @@ -371,12 +361,11 @@ END SUBROUTINE fock2_1el_ew !> \param se_int_control ... !> \param se_taper ... !> \param store_int_env ... -!> \param error ... !> \date 04.2009 [jgh] !> \author jgh - University of Zurich ! ***************************************************************************** SUBROUTINE fock2C_ew(sep, rij, p_tot, f_mat, factor, anag, se_int_control, & - se_taper, store_int_env, error) + se_taper, store_int_env) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij REAL(KIND=dp), DIMENSION(45, 45), & @@ -387,7 +376,6 @@ SUBROUTINE fock2C_ew(sep, rij, p_tot, f_mat, factor, anag, se_int_control, & TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock2C_ew', & routineP = moduleN//':'//routineN @@ -401,7 +389,7 @@ SUBROUTINE fock2C_ew(sep, rij, p_tot, f_mat, factor, anag, se_int_control, & failure = .FALSE. ! Evaluate integrals CALL rotint (sep,sep,rij,w,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,store_int_env=store_int_env, error=error) + se_taper=se_taper,store_int_env=store_int_env) kr = 0 natorb = sep%natorb DO iL = 1, natorb @@ -449,12 +437,11 @@ END SUBROUTINE fock2C_ew !> \param se_int_control ... !> \param se_taper ... !> \param store_int_env ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE fock2C(sepi, sepj, rij, switch, pi_tot, fi_mat, pj_tot, fj_mat, & - factor, anag, se_int_control, se_taper, store_int_env, error) + factor, anag, se_int_control, se_taper, store_int_env) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij LOGICAL, INTENT(IN) :: switch @@ -469,7 +456,6 @@ SUBROUTINE fock2C(sepi, sepj, rij, switch, pi_tot, fi_mat, pj_tot, fj_mat, & TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock2C', & routineP = moduleN//':'//routineN @@ -484,11 +470,11 @@ SUBROUTINE fock2C(sepi, sepj, rij, switch, pi_tot, fi_mat, pj_tot, fj_mat, & ! Evaluate integrals IF (.NOT.switch) THEN CALL rotint (sepi,sepj, rij,w,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,store_int_env=store_int_env, error=error) + se_taper=se_taper,store_int_env=store_int_env) ELSE irij = -rij CALL rotint (sepj,sepi,irij,w,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,store_int_env=store_int_env, error=error) + se_taper=se_taper,store_int_env=store_int_env) END IF kr = 0 natorb(1) = sepi%natorb @@ -548,12 +534,11 @@ END SUBROUTINE fock2C !> \param se_taper ... !> \param force ... !> \param delta ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE dfock2C(sepi, sepj, rij, switch, pi_tot, pj_tot, factor, anag,& - se_int_control, se_taper, force, delta, error) + se_int_control, se_taper, force, delta) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij LOGICAL, INTENT(IN) :: switch @@ -566,7 +551,6 @@ SUBROUTINE dfock2C(sepi, sepj, rij, switch, pi_tot, pj_tot, factor, anag,& REAL(KIND=dp), DIMENSION(3), & INTENT(INOUT) :: force REAL(KIND=dp), INTENT(IN) :: delta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dfock2C', & routineP = moduleN//':'//routineN @@ -582,11 +566,11 @@ SUBROUTINE dfock2C(sepi, sepj, rij, switch, pi_tot, pj_tot, factor, anag,& ! Evaluate integrals' derivatives IF (.NOT.switch) THEN CALL drotint (sepi,sepj, rij,dw,delta,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,error=error) + se_taper=se_taper) ELSE irij = -rij CALL drotint (sepj,sepi,irij,dw,delta,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,error=error) + se_taper=se_taper) END IF kr = 0 @@ -645,12 +629,11 @@ END SUBROUTINE dfock2C !> \param se_int_control ... !> \param se_taper ... !> \param store_int_env ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE fock2E(sepi, sepj, rij, switch, isize, pi_mat, fi_mat, factor,& - anag, se_int_control, se_taper, store_int_env, error) + anag, se_int_control, se_taper, store_int_env) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij LOGICAL, INTENT(IN) :: switch @@ -664,7 +647,6 @@ SUBROUTINE fock2E(sepi, sepj, rij, switch, isize, pi_mat, fi_mat, factor,& TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock2E', & routineP = moduleN//':'//routineN @@ -679,11 +661,11 @@ SUBROUTINE fock2E(sepi, sepj, rij, switch, isize, pi_mat, fi_mat, factor,& ! Evaluate integrals IF (.NOT.switch) THEN CALL rotint (sepi,sepj, rij,w,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,store_int_env=store_int_env, error=error) + se_taper=se_taper,store_int_env=store_int_env) ELSE irij = -rij CALL rotint (sepj,sepi,irij,w,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,store_int_env=store_int_env, error=error) + se_taper=se_taper,store_int_env=store_int_env) END IF kr = 0 natorb(1) = sepi%natorb @@ -737,12 +719,11 @@ END SUBROUTINE fock2E !> \param se_taper ... !> \param force ... !> \param delta ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE dfock2E(sepi, sepj, rij, switch, isize, pi_mat, factor, anag,& - se_int_control, se_taper, force, delta, error) + se_int_control, se_taper, force, delta) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rij LOGICAL, INTENT(IN) :: switch @@ -757,7 +738,6 @@ SUBROUTINE dfock2E(sepi, sepj, rij, switch, isize, pi_mat, factor, anag,& REAL(KIND=dp), DIMENSION(3), & INTENT(INOUT) :: force REAL(KIND=dp), INTENT(IN) :: delta - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dfock2E', & routineP = moduleN//':'//routineN @@ -774,11 +754,11 @@ SUBROUTINE dfock2E(sepi, sepj, rij, switch, isize, pi_mat, factor, anag,& ! Evaluate integrals' derivatives IF (.NOT.switch) THEN CALL drotint (sepi,sepj, rij,dw,delta,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,error=error) + se_taper=se_taper) ELSE irij = -rij CALL drotint (sepj,sepi,irij,dw,delta,anag=anag,se_int_control=se_int_control,& - se_taper=se_taper,error=error) + se_taper=se_taper) END IF kr = 0 @@ -848,12 +828,11 @@ END SUBROUTINE dfock2E !> \param e2a ... !> \param ecore ... !> \param rp ... -!> \param error ... !> \date 12.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE fock2_1el_r3 (sepi, sepj, ksi_block, ksj_block, pi_block, pj_block,& - e1b, e2a, ecore, rp, error) + e1b, e2a, ecore, rp) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(:, :), POINTER :: ksi_block, ksj_block REAL(KIND=dp), & @@ -866,7 +845,6 @@ SUBROUTINE fock2_1el_r3 (sepi, sepj, ksi_block, ksj_block, pi_block, pj_block,& REAL(KIND=dp), DIMENSION(2), & INTENT(INOUT) :: ecore REAL(KIND=dp), INTENT(IN) :: rp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock2_1el_r3', & routineP = moduleN//':'//routineN @@ -909,12 +887,10 @@ END SUBROUTINE fock2_1el_r3 !> \param force ... !> \param e1b ... !> \param e2a ... -!> \param error ... !> \date 12.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE dfock2_1el_r3 (sepi, sepj, drp, pi_block, pj_block, force, e1b, e2a,& - error) + SUBROUTINE dfock2_1el_r3 (sepi, sepj, drp, pi_block, pj_block, force, e1b, e2a) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: drp REAL(KIND=dp), & @@ -926,7 +902,6 @@ SUBROUTINE dfock2_1el_r3 (sepi, sepj, drp, pi_block, pj_block, force, e1b, e2a,& REAL(KIND=dp), DIMENSION(3), & INTENT(INOUT) :: force REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: e1b, e2a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dfock2_1el_r3', & routineP = moduleN//':'//routineN @@ -976,12 +951,11 @@ END SUBROUTINE dfock2_1el_r3 !> \param factor ... !> \param w ... !> \param rp ... -!> \param error ... !> \date 12.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE fock2C_r3(sepi, sepj, switch, pi_tot, fi_mat, pj_tot, fj_mat, & - factor, w, rp, error) + factor, w, rp) TYPE(semi_empirical_type), POINTER :: sepi, sepj LOGICAL, INTENT(IN) :: switch REAL(KIND=dp), DIMENSION(45, 45), & @@ -993,7 +967,6 @@ SUBROUTINE fock2C_r3(sepi, sepj, switch, pi_tot, fi_mat, pj_tot, fj_mat, & REAL(KIND=dp), INTENT(IN) :: factor REAL(KIND=dp), DIMENSION(81), INTENT(IN) :: w REAL(KIND=dp), INTENT(IN) :: rp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'fock2C_r3', & routineP = moduleN//':'//routineN @@ -1055,12 +1028,11 @@ END SUBROUTINE fock2C_r3 !> \param w ... !> \param drp ... !> \param force ... -!> \param error ... !> \date 12.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE dfock2C_r3(sepi, sepj, switch, pi_tot, pj_tot, factor, w, drp,& - force, error) + force) TYPE(semi_empirical_type), POINTER :: sepi, sepj LOGICAL, INTENT(IN) :: switch REAL(KIND=dp), DIMENSION(45, 45), & @@ -1070,7 +1042,6 @@ SUBROUTINE dfock2C_r3(sepi, sepj, switch, pi_tot, pj_tot, factor, w, drp,& REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: drp REAL(KIND=dp), DIMENSION(3), & INTENT(INOUT) :: force - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dfock2C_r3', & routineP = moduleN//':'//routineN @@ -1151,14 +1122,13 @@ END SUBROUTINE dfock2C_r3 !> \param ptens31 ... !> \param ptens32 ... !> \param ptens33 ... -!> \param error ... !> \date 05.2009 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** SUBROUTINE se_coulomb_ij_interaction (atom_a, atom_b, my_task, do_forces, do_efield,& do_stress, charges, dipoles, quadrupoles, force_ab, efield0, efield1, efield2, & rab2, rab, integral_value, ptens11, ptens12, ptens13, ptens21, ptens22, ptens23,& - ptens31, ptens32, ptens33, error) + ptens31, ptens32, ptens33) INTEGER, INTENT(IN) :: atom_a, atom_b LOGICAL, DIMENSION(3) :: my_task LOGICAL, INTENT(IN) :: do_forces, do_efield, & @@ -1176,7 +1146,6 @@ SUBROUTINE se_coulomb_ij_interaction (atom_a, atom_b, my_task, do_forces, do_efi REAL(KIND=dp), INTENT(INOUT) :: ptens11, ptens12, ptens13, & ptens21, ptens22, ptens23, & ptens31, ptens32, ptens33 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_coulomb_ij_interaction', & routineP = moduleN//':'//routineN diff --git a/src/semi_empirical_expns3_methods.F b/src/semi_empirical_expns3_methods.F index 92dbb57d17..04932b35c4 100644 --- a/src/semi_empirical_expns3_methods.F +++ b/src/semi_empirical_expns3_methods.F @@ -37,17 +37,15 @@ MODULE semi_empirical_expns3_methods !> \param qs_kind_set ... !> \param se_control ... !> \param method_id ... -!> \param error ... !> \date 12.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE semi_empirical_expns3_setup(qs_kind_set, se_control, method_id, error) + SUBROUTINE semi_empirical_expns3_setup(qs_kind_set, se_control, method_id) TYPE(qs_kind_type), DIMENSION(:), & POINTER :: qs_kind_set TYPE(semi_empirical_control_type), & POINTER :: se_control INTEGER, INTENT(IN) :: method_id - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_expns3_setup', & routineP = moduleN//':'//routineN @@ -61,23 +59,23 @@ SUBROUTINE semi_empirical_expns3_setup(qs_kind_set, se_control, method_id, error NULLIFY(sepi, sepj) nkinds = SIZE(qs_kind_set) DO i = 1, nkinds - CALL get_qs_kind(qs_kind_set(i), se_parameter=sepi, error=error) + CALL get_qs_kind(qs_kind_set(i), se_parameter=sepi) check = .NOT.ASSOCIATED(sepi%expns3_int) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) ALLOCATE(sepi%expns3_int(nkinds),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, nkinds NULLIFY(sepi%expns3_int(j)%expns3) - CALL semi_empirical_expns3_create(sepi%expns3_int(j)%expns3,error=error) + CALL semi_empirical_expns3_create(sepi%expns3_int(j)%expns3) END DO END DO itype = get_se_type(method_id) DO i = 1, nkinds - CALL get_qs_kind(qs_kind_set(i), se_parameter=sepi, error=error) + CALL get_qs_kind(qs_kind_set(i), se_parameter=sepi) DO j = 1, nkinds - CALL get_qs_kind(qs_kind_set(j), se_parameter=sepj, error=error) - CALL setup_c3_coeff(sepi, sepj, i, j, itype, error) + CALL get_qs_kind(qs_kind_set(j), se_parameter=sepj) + CALL setup_c3_coeff(sepi, sepj, i, j, itype) END DO END DO END IF @@ -95,14 +93,12 @@ END SUBROUTINE semi_empirical_expns3_setup !> \param ikind ... !> \param jkind ... !> \param itype ... -!> \param error ... !> \date 12.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE setup_c3_coeff(sepi, sepj, ikind, jkind, itype, error) + SUBROUTINE setup_c3_coeff(sepi, sepj, ikind, jkind, itype) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ikind, jkind, itype - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_c3_coeff', & routineP = moduleN//':'//routineN @@ -120,69 +116,69 @@ SUBROUTINE setup_c3_coeff(sepi, sepj, ikind, jkind, itype, error) ij = indexa(1, 1) zi = -sepi%zeff zj = -sepj%zeff - core_core = ijkl_low_3(sepi, sepj, ij, ij, 0, 0, 0, 0, -1, itype, coeff_int_3, error) * zi * zj + core_core = ijkl_low_3(sepi, sepj, ij, ij, 0, 0, 0, 0, -1, itype, coeff_int_3) * zi * zj ! Electron(i)-Nuclei(j) contribution kl = indexa(1, 1) - e1b(1) = ijkl_low_3 (sepi, sepj, kl, ij, 0, 0, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(1) = ijkl_low_3 (sepi, sepj, kl, ij, 0, 0, 0, 0, 2, itype, coeff_int_3) * zj IF (sepi%natorb > 1) THEN kl = indexa(2, 2) - e1b(2) = ijkl_low_3 (sepi, sepj, kl, ij, 1, 1, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(2) = ijkl_low_3 (sepi, sepj, kl, ij, 1, 1, 0, 0, 2, itype, coeff_int_3) * zj kl = indexa(3, 3) - e1b(3) = ijkl_low_3 (sepi, sepj, kl, ij, 1, 1, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(3) = ijkl_low_3 (sepi, sepj, kl, ij, 1, 1, 0, 0, 2, itype, coeff_int_3) * zj kl = indexa(4, 4) - e1b(4) = ijkl_low_3 (sepi, sepj, kl, ij, 1, 1, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(4) = ijkl_low_3 (sepi, sepj, kl, ij, 1, 1, 0, 0, 2, itype, coeff_int_3) * zj ! Consistency check - CPPostcondition(e1b(2)==e1b(3),cp_failure_level,routineP,error,failure) - CPPostcondition(e1b(3)==e1b(4),cp_failure_level,routineP,error,failure) + CPPostcondition(e1b(2)==e1b(3),cp_failure_level,routineP,failure) + CPPostcondition(e1b(3)==e1b(4),cp_failure_level,routineP,failure) IF (sepi%dorb) THEN kl = indexa(5, 5) - e1b(5) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(5) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3) * zj kl = indexa(6, 6) - e1b(6) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(6) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3) * zj kl = indexa(7, 7) - e1b(7) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(7) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3) * zj kl = indexa(8, 8) - e1b(8) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(8) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3) * zj kl = indexa(9, 9) - e1b(9) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3, error) * zj + e1b(9) = ijkl_low_3 (sepi, sepj, kl, ij, 2, 2, 0, 0, 2, itype, coeff_int_3) * zj ! Consistency check - CPPostcondition(e1b(5)==e1b(6),cp_failure_level,routineP,error,failure) - CPPostcondition(e1b(6)==e1b(7),cp_failure_level,routineP,error,failure) - CPPostcondition(e1b(7)==e1b(8),cp_failure_level,routineP,error,failure) - CPPostcondition(e1b(8)==e1b(9),cp_failure_level,routineP,error,failure) + CPPostcondition(e1b(5)==e1b(6),cp_failure_level,routineP,failure) + CPPostcondition(e1b(6)==e1b(7),cp_failure_level,routineP,failure) + CPPostcondition(e1b(7)==e1b(8),cp_failure_level,routineP,failure) + CPPostcondition(e1b(8)==e1b(9),cp_failure_level,routineP,failure) END IF END IF ! Electron(j)-Nuclei(i) contribution kl = indexa(1, 1) - e2a(1) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 0, 0, 1, itype, coeff_int_3, error) * zi + e2a(1) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 0, 0, 1, itype, coeff_int_3) * zi IF (sepj%natorb > 1) THEN kl = indexa(2, 2) - e2a(2) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 1, 1, 1, itype, coeff_int_3, error) * zi + e2a(2) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 1, 1, 1, itype, coeff_int_3) * zi kl = indexa(3, 3) - e2a(3) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 1, 1, 1, itype, coeff_int_3, error) * zi + e2a(3) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 1, 1, 1, itype, coeff_int_3) * zi kl = indexa(4, 4) - e2a(4) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 1, 1, 1, itype, coeff_int_3, error) * zi + e2a(4) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 1, 1, 1, itype, coeff_int_3) * zi ! Consistency check - CPPostcondition(e2a(2)==e2a(3),cp_failure_level,routineP,error,failure) - CPPostcondition(e2a(3)==e2a(4),cp_failure_level,routineP,error,failure) + CPPostcondition(e2a(2)==e2a(3),cp_failure_level,routineP,failure) + CPPostcondition(e2a(3)==e2a(4),cp_failure_level,routineP,failure) IF (sepj%dorb) THEN kl = indexa(5, 5) - e2a(5) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3, error) * zi + e2a(5) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3) * zi kl = indexa(6, 6) - e2a(6) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3, error) * zi + e2a(6) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3) * zi kl = indexa(7, 7) - e2a(7) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3, error) * zi + e2a(7) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3) * zi kl = indexa(8, 8) - e2a(8) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3, error) * zi + e2a(8) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3) * zi kl = indexa(9, 9) - e2a(9) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3, error) * zi + e2a(9) = ijkl_low_3 (sepi, sepj, ij, kl, 0, 0, 2, 2, 1, itype, coeff_int_3) * zi ! Consistency check - CPPostcondition(e2a(5)==e2a(6),cp_failure_level,routineP,error,failure) - CPPostcondition(e2a(6)==e2a(7),cp_failure_level,routineP,error,failure) - CPPostcondition(e2a(7)==e2a(8),cp_failure_level,routineP,error,failure) - CPPostcondition(e2a(8)==e2a(9),cp_failure_level,routineP,error,failure) + CPPostcondition(e2a(5)==e2a(6),cp_failure_level,routineP,failure) + CPPostcondition(e2a(6)==e2a(7),cp_failure_level,routineP,failure) + CPPostcondition(e2a(7)==e2a(8),cp_failure_level,routineP,failure) + CPPostcondition(e2a(8)==e2a(9),cp_failure_level,routineP,failure) END IF END IF @@ -205,7 +201,7 @@ SUBROUTINE setup_c3_coeff(sepi, sepj, ikind, jkind, itype, error) kl = indexa(j,j) kr = kr + 1 sepi%expns3_int(jkind)%expns3%w(kr) = & - ijkl_low_3 (sepi, sepj, ij, kl, li, li, lk, lk, 0, do_method_undef, coeff_int_3, error) + ijkl_low_3 (sepi, sepj, ij, kl, li, li, lk, lk, 0, do_method_undef, coeff_int_3) END DO END DO @@ -219,7 +215,7 @@ SUBROUTINE setup_c3_coeff(sepi, sepj, ikind, jkind, itype, error) kl = indexa(j,j) kr = kr + 1 sepj%expns3_int(ikind)%expns3%w(kr) = & - ijkl_low_3 (sepj, sepi, ij, kl, li, li, lk, lk, 0, do_method_undef, coeff_int_3, error) + ijkl_low_3 (sepj, sepi, ij, kl, li, li, lk, lk, 0, do_method_undef, coeff_int_3) END DO END DO diff --git a/src/semi_empirical_expns3_types.F b/src/semi_empirical_expns3_types.F index f5910d9e38..0596a74d54 100644 --- a/src/semi_empirical_expns3_types.F +++ b/src/semi_empirical_expns3_types.F @@ -45,13 +45,11 @@ MODULE semi_empirical_expns3_types ! ***************************************************************************** !> \brief Allocate semi-empirical 1/R^3 expansion type !> \param expns3 ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 12.2008 ! ***************************************************************************** - SUBROUTINE semi_empirical_expns3_create(expns3, error) + SUBROUTINE semi_empirical_expns3_create(expns3) TYPE(semi_empirical_expns3_type), & POINTER :: expns3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_expns3_create', & routineP = moduleN//':'//routineN @@ -60,9 +58,9 @@ SUBROUTINE semi_empirical_expns3_create(expns3, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(expns3),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(expns3),cp_failure_level,routineP,failure) ALLOCATE (expns3,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) expns3%core_core = 0.0_dp expns3%e1b = 0.0_dp expns3%e2a = 0.0_dp @@ -72,13 +70,11 @@ END SUBROUTINE semi_empirical_expns3_create ! ***************************************************************************** !> \brief Deallocate the semi-empirical type !> \param expns3 ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 12.2008 ! ***************************************************************************** - SUBROUTINE semi_empirical_expns3_release(expns3, error) + SUBROUTINE semi_empirical_expns3_release(expns3) TYPE(semi_empirical_expns3_type), & POINTER :: expns3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'semi_empirical_expns3_release', & @@ -90,7 +86,7 @@ SUBROUTINE semi_empirical_expns3_release(expns3, error) failure = .FALSE. IF (ASSOCIATED(expns3)) THEN DEALLOCATE (expns3,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE semi_empirical_expns3_release diff --git a/src/semi_empirical_int3_utils.F b/src/semi_empirical_int3_utils.F index 762522bf07..88f57d39df 100644 --- a/src/semi_empirical_int3_utils.F +++ b/src/semi_empirical_int3_utils.F @@ -43,18 +43,15 @@ MODULE semi_empirical_int3_utils !> \param ic ... !> \param itype ... !> \param eval ... -!> \param error ... !> \retval res ... !> \date 11.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - FUNCTION ijkl_low_3(sepi, sepj, ij, kl, li, lj, lk, ll, ic, itype, eval, error) RESULT(res) + FUNCTION ijkl_low_3(sepi, sepj, ij, kl, li, lj, lk, ll, ic, itype, eval) RESULT(res) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ij, kl, li, lj, lk, ll, ic, & itype - REAL(KIND=dp) :: eval - TYPE(cp_error_type), INTENT(inout) :: error - REAL(KIND=dp) :: res + REAL(KIND=dp) :: eval, res CHARACTER(len=*), PARAMETER :: routineN = 'ijkl_low_3', & routineP = moduleN//':'//routineN @@ -104,7 +101,7 @@ FUNCTION ijkl_low_3(sepi, sepj, ij, kl, li, lj, lk, ll, ic, itype, eval, error) END IF ccc = clm_d(ij, l1, 0) * clm_d(kl, l2, 0) IF (ABS(ccc) > EPSILON(0.0_dp)) THEN - chrg = eval(l1, l2, add, error) + chrg = eval(l1, l2, add) sum = chrg END IF END IF @@ -123,16 +120,14 @@ END FUNCTION ijkl_low_3 !> \param l1 ... !> \param l2 ... !> \param add ... -!> \param error ... !> \retval charg ... !> \date 11.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - FUNCTION charg_int_3(r, l1, l2, add, error) RESULT(charg) + FUNCTION charg_int_3(r, l1, l2, add) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1, l2 REAL(KIND=dp), INTENT(in) :: add - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'charg_int_3', & @@ -149,7 +144,7 @@ FUNCTION charg_int_3(r, l1, l2, add, error) RESULT(charg) RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION charg_int_3 ! ***************************************************************************** @@ -162,15 +157,13 @@ END FUNCTION charg_int_3 !> \param l1 ... !> \param l2 ... !> \param add ... -!> \param error ... !> \retval coeff ... !> \date 11.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - FUNCTION coeff_int_3(l1, l2, add, error) RESULT(coeff) + FUNCTION coeff_int_3(l1, l2, add) RESULT(coeff) INTEGER, INTENT(in) :: l1, l2 REAL(KIND=dp), INTENT(in) :: add - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: coeff CHARACTER(len=*), PARAMETER :: routineN = 'coeff_int_3', & @@ -187,7 +180,7 @@ FUNCTION coeff_int_3(l1, l2, add, error) RESULT(coeff) RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION coeff_int_3 ! ***************************************************************************** @@ -202,16 +195,14 @@ END FUNCTION coeff_int_3 !> \param l1 ... !> \param l2 ... !> \param add ... -!> \param error ... !> \retval charg ... !> \date 11.2008 [tlaino] !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - FUNCTION dcharg_int_3(r, l1, l2, add, error) RESULT(charg) + FUNCTION dcharg_int_3(r, l1, l2, add) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1, l2 REAL(KIND=dp), INTENT(in) :: add - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'dcharg_int_3', & @@ -228,7 +219,7 @@ FUNCTION dcharg_int_3(r, l1, l2, add, error) RESULT(charg) RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION dcharg_int_3 END MODULE semi_empirical_int3_utils diff --git a/src/semi_empirical_int_ana.F b/src/semi_empirical_int_ana.F index c1ea2a8847..d519ae419d 100644 --- a/src/semi_empirical_int_ana.F +++ b/src/semi_empirical_int_ana.F @@ -75,7 +75,6 @@ MODULE semi_empirical_int_ana !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_taper ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver @@ -86,7 +85,7 @@ MODULE semi_empirical_int_ana !> Analytical version of the MOPAC rotnuc routine ! ***************************************************************************** RECURSIVE SUBROUTINE rotnuc_ana (sepi,sepj,rijv,itype,e1b,e2a,de1b,de2a,& - se_int_control,se_taper,error) + se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv INTEGER, INTENT(IN) :: itype @@ -96,7 +95,6 @@ RECURSIVE SUBROUTINE rotnuc_ana (sepi,sepj,rijv,itype,e1b,e2a,de1b,de2a,& INTENT(OUT), OPTIONAL :: de1b, de2a TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotnuc_ana', & routineP = moduleN//':'//routineN @@ -125,9 +123,8 @@ RECURSIVE SUBROUTINE rotnuc_ana (sepi,sepj,rijv,itype,e1b,e2a,de1b,de2a,& ! Compute Integrals in diatomic frame opportunely inverted rij = SQRT(rij) ! Create the rotation matrix - CALL rotmat_create(ij_matrix, error) - CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=lgrad, do_invert=invert,& - error=error) + CALL rotmat_create(ij_matrix) + CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=lgrad, do_invert=invert) IF (lgrad) THEN drij(1) = rijv(1)/rij @@ -142,7 +139,7 @@ RECURSIVE SUBROUTINE rotnuc_ana (sepi,sepj,rijv,itype,e1b,e2a,de1b,de2a,& END IF CALL dcore_nucint_ana(sepi,sepj,rij,core=core,dcore=dcore,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control,lgrad=lgrad,error=error) + se_int_control=se_int_control,lgrad=lgrad) ! Copy parameters over to arrays for do loop. last_orbital(1) = sepi%natorb @@ -200,8 +197,8 @@ RECURSIVE SUBROUTINE rotnuc_ana (sepi,sepj,rijv,itype,e1b,e2a,de1b,de2a,& END DO END IF END DO - IF (invert.AND.l_e1b) CALL invert_integral (sepi, sepi, int1el=e1b, error=error) - IF (invert.AND.l_e2a) CALL invert_integral (sepj, sepj, int1el=e2a, error=error) + IF (invert.AND.l_e1b) CALL invert_integral (sepi, sepi, int1el=e1b) + IF (invert.AND.l_e2a) CALL invert_integral (sepj, sepj, int1el=e2a) ! Possibly compute derivatives task (1) = l_de1b @@ -318,13 +315,13 @@ RECURSIVE SUBROUTINE rotnuc_ana (sepi,sepj,rijv,itype,e1b,e2a,de1b,de2a,& END DO END IF END DO - IF (invert.AND.l_de1b) CALL invert_derivative(sepi, sepi, dint1el=de1b, error=error) - IF (invert.AND.l_de2a) CALL invert_derivative(sepj, sepj, dint1el=de2a, error=error) - CALL rotmat_release(ij_matrix, error) + IF (invert.AND.l_de1b) CALL invert_derivative(sepi, sepi, dint1el=de1b) + IF (invert.AND.l_de2a) CALL invert_derivative(sepj, sepj, dint1el=de2a) + CALL rotmat_release(ij_matrix) ! Possibly debug the analytical values versus the numerical ones IF (debug_this_module) THEN - CALL check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, e1b, e2a, de1b, de2a, error) + CALL check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, e1b, e2a, de1b, de2a) END IF END IF END SUBROUTINE rotnuc_ana @@ -340,7 +337,6 @@ END SUBROUTINE rotnuc_ana !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_taper ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver @@ -351,7 +347,7 @@ END SUBROUTINE rotnuc_ana !> \note !> Analytical version of the MOPAC rotnuc routine ! ***************************************************************************** - RECURSIVE SUBROUTINE corecore_ana (sepi,sepj,rijv,itype,enuc,denuc,se_int_control,se_taper,error) + RECURSIVE SUBROUTINE corecore_ana (sepi,sepj,rijv,itype,enuc,denuc,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv INTEGER, INTENT(IN) :: itype @@ -360,7 +356,6 @@ RECURSIVE SUBROUTINE corecore_ana (sepi,sepj,rijv,itype,enuc,denuc,se_int_contro OPTIONAL :: denuc TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore_ana', & routineP = moduleN//':'//routineN @@ -388,11 +383,11 @@ RECURSIVE SUBROUTINE corecore_ana (sepi,sepj,rijv,itype,enuc,denuc,se_int_contro do_ewald_gks=.FALSE., integral_screening=se_int_control%integral_screening, & max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.) CALL dssss_nucint_ana(sepi,sepj,rij,ssss=ssss,dssss=dssss,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control_off,lgrad=l_denuc,error=error) + se_int_control=se_int_control_off,lgrad=l_denuc) ! In case let's compute the short-range part of the (ss|ss) integral IF (se_int_control%shortrange) THEN CALL dssss_nucint_ana(sepi,sepj,rij,ssss=ssss_sr,dssss=dssss_sr,itype=itype,& - se_taper=se_taper, se_int_control=se_int_control, lgrad=l_denuc, error=error) + se_taper=se_taper, se_int_control=se_int_control, lgrad=l_denuc) ELSE ssss_sr = ssss dssss_sr = dssss @@ -637,7 +632,7 @@ RECURSIVE SUBROUTINE corecore_ana (sepi,sepj,rijv,itype,enuc,denuc,se_int_contro END IF ! Debug statement IF (debug_this_module) THEN - CALL check_dcorecore_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, enuc, denuc, error) + CALL check_dcorecore_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, enuc, denuc) END IF ENDIF END SUBROUTINE corecore_ana @@ -655,7 +650,6 @@ END SUBROUTINE corecore_ana !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_taper ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver @@ -667,7 +661,7 @@ END SUBROUTINE corecore_ana !> Analytical version of the MOPAC rotnuc routine ! ***************************************************************************** RECURSIVE SUBROUTINE corecore_el_ana (sepi,sepj,rijv,itype,enuc,denuc,& - se_int_control,se_taper,error) + se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv INTEGER, INTENT(IN) :: itype @@ -676,7 +670,6 @@ RECURSIVE SUBROUTINE corecore_el_ana (sepi,sepj,rijv,itype,enuc,denuc,& OPTIONAL :: denuc TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore_el_ana', & routineP = moduleN//':'//routineN @@ -698,11 +691,11 @@ RECURSIVE SUBROUTINE corecore_el_ana (sepi,sepj,rijv,itype,enuc,denuc,& do_ewald_gks=.FALSE., integral_screening=se_int_control%integral_screening, & max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.) CALL dssss_nucint_ana(sepi,sepj,rij,ssss=ssss,dssss=dssss,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control_off,lgrad=l_denuc,error=error) + se_int_control=se_int_control_off,lgrad=l_denuc) ! In case let's compute the short-range part of the (ss|ss) integral IF (se_int_control%shortrange.OR.se_int_control%pc_coulomb_int) THEN CALL dssss_nucint_ana(sepi,sepj,rij,ssss=ssss_sr,dssss=dssss_sr,itype=itype,& - se_taper=se_taper, se_int_control=se_int_control, lgrad=l_denuc, error=error) + se_taper=se_taper, se_int_control=se_int_control, lgrad=l_denuc) ELSE ssss_sr = ssss dssss_sr = dssss @@ -726,17 +719,15 @@ END SUBROUTINE corecore_el_ana !> \param sepj ... !> \param int1el ... !> \param int2el ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> 05.2008 New driver for integral invertion (supports d-orbitals) !> \author Teodoro Laino - Zurich University ! ***************************************************************************** - SUBROUTINE invert_integral(sepi, sepj, int1el, int2el, error) + SUBROUTINE invert_integral(sepi, sepj, int1el, int2el) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(:), INTENT(INOUT), & OPTIONAL :: int1el, int2el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'invert_integral', & routineP = moduleN//':'//routineN @@ -844,16 +835,14 @@ END SUBROUTINE invert_integral !> \param sepj ... !> \param dint1el ... !> \param dint2el ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> \author Teodoro Laino - Zurich University ! ***************************************************************************** - SUBROUTINE invert_derivative(sepi, sepj, dint1el, dint2el, error) + SUBROUTINE invert_derivative(sepi, sepj, dint1el, dint2el) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL :: dint1el, dint2el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'invert_derivative', & routineP = moduleN//':'//routineN @@ -866,10 +855,10 @@ SUBROUTINE invert_derivative(sepi, sepj, dint1el, dint2el, error) ! Integral part DO i=1,3 IF (PRESENT(dint1el)) THEN - CALL invert_integral(sepi, sepj, int1el=dint1el(i,:), error=error) + CALL invert_integral(sepi, sepj, int1el=dint1el(i,:)) END IF IF (PRESENT(dint2el)) THEN - CALL invert_integral(sepi, sepj, int2el=dint2el(i,:), error=error) + CALL invert_integral(sepi, sepj, int2el=dint2el(i,:)) END IF END DO @@ -903,7 +892,6 @@ END SUBROUTINE invert_derivative !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param lgrad ... -!> \param error ... !> \par History !> 03.2007 created [tlaino] !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver @@ -915,7 +903,7 @@ END SUBROUTINE invert_derivative !> ! ***************************************************************************** SUBROUTINE dssss_nucint_ana(sepi, sepj, rij, ssss, dssss, itype, se_taper, se_int_control,& - lgrad, error) + lgrad) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), INTENT(OUT) :: ssss, dssss @@ -923,7 +911,6 @@ SUBROUTINE dssss_nucint_ana(sepi, sepj, rij, ssss, dssss, itype, se_taper, se_in TYPE(se_taper_type), POINTER :: se_taper TYPE(se_int_control_type), INTENT(IN) :: se_int_control LOGICAL, INTENT(IN) :: lgrad - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dssss_nucint_ana', & routineP = moduleN//':'//routineN @@ -938,27 +925,27 @@ SUBROUTINE dssss_nucint_ana(sepi, sepj, rij, ssss, dssss, itype, se_taper, se_in ft = 1.0_dp dft= 0.0_dp IF (itype/=do_method_pchg) THEN - ft = taper_eval(se_taper%taper, rij, error) - dft= dtaper_eval(se_taper%taper, rij, error) + ft = taper_eval(se_taper%taper, rij) + dft= dtaper_eval(se_taper%taper, rij) END IF ! Evaluate additional taper function for dumped integrals IF (se_int_control%integral_screening==do_se_IS_kdso_d) THEN se_int_screen%ft = 1.0_dp se_int_screen%dft = 0.0_dp IF (itype/=do_method_pchg) THEN - se_int_screen%ft = taper_eval(se_taper%taper_add, rij, error) - se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij, error) + se_int_screen%ft = taper_eval(se_taper%taper_add, rij) + se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) END IF END IF ! Value of the integrals for sp shell CALL nucint_sp_num(sepi, sepj, rij, ssss=ssss, itype=itype, se_int_control=se_int_control,& - se_int_screen=se_int_screen, error=error) + se_int_screen=se_int_screen) IF (lgrad) THEN ! Integrals derivatives for sp shell CALL dnucint_sp_ana(sepi, sepj, rij, dssss=dssss, itype=itype, se_int_control=se_int_control,& - se_int_screen=se_int_screen, error=error) + se_int_screen=se_int_screen) END IF ! Tapering the value of the integrals @@ -969,7 +956,7 @@ SUBROUTINE dssss_nucint_ana(sepi, sepj, rij, ssss, dssss, itype, se_taper, se_in ! Debug Procedure.. Check valifity of analytical gradients of nucint IF (debug_this_module.AND.lgrad) THEN - CALL check_dssss_nucint_ana(sepi,sepj,rij,dssss,itype,se_int_control,se_taper=se_taper,error=error) + CALL check_dssss_nucint_ana(sepi,sepj,rij,dssss,itype,se_int_control,se_taper=se_taper) END IF END SUBROUTINE dssss_nucint_ana @@ -991,7 +978,6 @@ END SUBROUTINE dssss_nucint_ana !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param lgrad ... -!> \param error ... !> \par History !> 03.2007 created [tlaino] !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver @@ -1003,7 +989,7 @@ END SUBROUTINE dssss_nucint_ana !> ! ***************************************************************************** SUBROUTINE dcore_nucint_ana ( sepi, sepj, rij, core, dcore, itype, se_taper, & - se_int_control, lgrad, error) + se_int_control, lgrad) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(10, 2), INTENT(OUT) :: core, dcore @@ -1011,7 +997,6 @@ SUBROUTINE dcore_nucint_ana ( sepi, sepj, rij, core, dcore, itype, se_taper, & TYPE(se_taper_type), POINTER :: se_taper TYPE(se_int_control_type), INTENT(IN) :: se_int_control LOGICAL, INTENT(IN) :: lgrad - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dcore_nucint_ana', & routineP = moduleN//':'//routineN @@ -1026,40 +1011,38 @@ SUBROUTINE dcore_nucint_ana ( sepi, sepj, rij, core, dcore, itype, se_taper, & ft = 1.0_dp dft= 0.0_dp IF (itype/=do_method_pchg) THEN - ft = taper_eval(se_taper%taper, rij, error) - dft= dtaper_eval(se_taper%taper, rij, error) + ft = taper_eval(se_taper%taper, rij) + dft= dtaper_eval(se_taper%taper, rij) END IF ! Evaluate additional taper function for dumped integrals IF (se_int_control%integral_screening==do_se_IS_kdso_d) THEN se_int_screen%ft = 1.0_dp se_int_screen%dft = 0.0_dp IF (itype/=do_method_pchg) THEN - se_int_screen%ft = taper_eval(se_taper%taper_add, rij, error) - se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij, error) + se_int_screen%ft = taper_eval(se_taper%taper_add, rij) + se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) END IF END IF ! Value of the integrals for sp shell CALL nucint_sp_num(sepi, sepj, rij, core=core, itype=itype,& - se_int_control=se_int_control, se_int_screen=se_int_screen, error=error) + se_int_control=se_int_control, se_int_screen=se_int_screen) IF (sepi%dorb.OR.sepj%dorb) THEN ! Compute the contribution from d-orbitals CALL nucint_d_num(sepi, sepj, rij, core, itype,& - se_int_control=se_int_control, se_int_screen=se_int_screen, error=error) + se_int_control=se_int_control, se_int_screen=se_int_screen) END IF IF (lgrad) THEN ! Integrals derivatives for sp shell CALL dnucint_sp_ana(sepi, sepj, rij, dcore=dcore, itype=itype,& - se_int_control=se_int_control, se_int_screen=se_int_screen,& - error=error) + se_int_control=se_int_control, se_int_screen=se_int_screen) IF (sepi%dorb.OR.sepj%dorb) THEN ! Integral derivatives involving d-orbitals CALL dnucint_d_ana(sepi, sepj, rij, dcore=dcore, itype=itype,& - se_int_control=se_int_control, se_int_screen=se_int_screen,& - error=error) + se_int_control=se_int_control, se_int_screen=se_int_screen) END IF END IF @@ -1081,7 +1064,7 @@ SUBROUTINE dcore_nucint_ana ( sepi, sepj, rij, core, dcore, itype, se_taper, & ! Debug Procedure.. Check valifity of analytical gradients of nucint IF (debug_this_module.AND.lgrad) THEN - CALL check_dcore_nucint_ana(sepi,sepj,rij,dcore,itype,se_int_control,se_taper=se_taper,error=error) + CALL check_dcore_nucint_ana(sepi,sepj,rij,dcore,itype,se_int_control,se_taper=se_taper) END IF END SUBROUTINE dcore_nucint_ana @@ -1103,7 +1086,6 @@ END SUBROUTINE dcore_nucint_ana !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_int_screen ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> Teodoro Laino (03.2008) [tlaino] - University of Zurich : new driver @@ -1117,7 +1099,7 @@ END SUBROUTINE dcore_nucint_ana !> vector version written by Ernest R. Davidson, Indiana University ! ***************************************************************************** SUBROUTINE dnucint_sp_ana ( sepi, sepj, rij, dssss, dcore, itype, se_int_control,& - se_int_screen, error) + se_int_screen) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), INTENT(INOUT), OPTIONAL :: dssss @@ -1126,7 +1108,6 @@ SUBROUTINE dnucint_sp_ana ( sepi, sepj, rij, dssss, dcore, itype, se_int_control INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dnucint_sp_ana', & routineP = moduleN//':'//routineN @@ -1200,12 +1181,11 @@ END SUBROUTINE dnucint_sp_ana !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_int_screen ... -!> \param error ... !> \author !> Teodoro Laino (05.2008) [tlaino] - University of Zurich: created ! ***************************************************************************** SUBROUTINE dnucint_d_ana( sepi, sepj, rij, dcore, itype, se_int_control,& - se_int_screen, error) + se_int_screen) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(10, 2), & @@ -1213,7 +1193,6 @@ SUBROUTINE dnucint_d_ana( sepi, sepj, rij, dcore, itype, se_int_control,& INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dnucint_d_ana', & routineP = moduleN//':'//routineN @@ -1277,7 +1256,6 @@ END SUBROUTINE dnucint_d_ana !> \param dw ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver @@ -1289,7 +1267,7 @@ END SUBROUTINE dnucint_d_ana !> routine adapted from mopac7 (repp) !> vector version written by Ernest R. Davidson, Indiana University ! ***************************************************************************** - RECURSIVE SUBROUTINE rotint_ana (sepi,sepj,rijv,w,dw,se_int_control,se_taper,error) + RECURSIVE SUBROUTINE rotint_ana (sepi,sepj,rijv,w,dw,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv REAL(dp), DIMENSION(2025), INTENT(OUT), & @@ -1298,7 +1276,6 @@ RECURSIVE SUBROUTINE rotint_ana (sepi,sepj,rijv,w,dw,se_int_control,se_taper,err INTENT(OUT), OPTIONAL :: dw TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotint_ana', & routineP = moduleN//':'//routineN @@ -1332,11 +1309,11 @@ RECURSIVE SUBROUTINE rotint_ana (sepi,sepj,rijv,w,dw,se_int_control,se_taper,err rij = SQRT(rij) ! Create the rotation matrix - CALL rotmat_create(ij_matrix, error) - CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=lgrad, do_invert=invert, error=error) + CALL rotmat_create(ij_matrix) + CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=lgrad, do_invert=invert) ! Compute integrals in diatomic frame as well their derivatives (if requested) - CALL dterep_ana(sepi,sepj,rij,rep,rep_d,se_taper,se_int_control,lgrad=lgrad,error=error) + CALL dterep_ana(sepi,sepj,rij,rep,rep_d,se_taper,se_int_control,lgrad=lgrad) IF (lgrad) THEN drij(1) = rijv(1)/rij @@ -1354,7 +1331,7 @@ RECURSIVE SUBROUTINE rotint_ana (sepi,sepj,rijv,w,dw,se_int_control,se_taper,err kk = sepj%natorb ! First step in rotation of integrals CALL rot_2el_2c_first(sepi, sepj, rijv, se_int_control, se_taper, invert, ii, kk, rep, logv, ij_matrix,& - v, lgrad, rep_d, v_d, logv_d, drij, error) + v, lgrad, rep_d, v_d, logv_d, drij) ! Integrals if requested IF (l_w) THEN @@ -1445,13 +1422,13 @@ RECURSIVE SUBROUTINE rotint_ana (sepi,sepj,rijv,w,dw,se_int_control,se_taper,err END DO END DO ! Store two electron integrals in the triangular format - CALL store_2el_2c_diag(limij, limkl, ww(1:istep), w, error=error) - IF (invert) CALL invert_integral(sepi, sepj, int2el=w, error=error) + CALL store_2el_2c_diag(limij, limkl, ww(1:istep), w) + IF (invert) CALL invert_integral(sepi, sepj, int2el=w) END IF IF (debug_this_module) THEN ! Check value of integrals - CALL check_rotint_ana(sepi,sepj,rijv,w,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL check_rotint_ana(sepi,sepj,rijv,w,se_int_control=se_int_control,se_taper=se_taper) END IF END IF @@ -1592,16 +1569,16 @@ RECURSIVE SUBROUTINE rotint_ana (sepi,sepj,rijv,w,dw,se_int_control,se_taper,err END DO ! Store two electron integrals in the triangular format CALL store_2el_2c_diag(limij, limkl, ww_dx=ww_d(1,1:istep), ww_dy=ww_d(2,1:istep), ww_dz=ww_d(3,1:istep),& - dw=dw, error=error) - IF (invert) CALL invert_derivative(sepi, sepj, dint2el=dw, error=error) + dw=dw) + IF (invert) CALL invert_derivative(sepi, sepj, dint2el=dw) END IF IF (debug_this_module) THEN ! Check derivatives - CALL check_rotint_ana(sepi,sepj,rijv,dw=dw,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL check_rotint_ana(sepi,sepj,rijv,dw=dw,se_int_control=se_int_control,se_taper=se_taper) END IF END IF - CALL rotmat_release(ij_matrix, error) + CALL rotmat_release(ij_matrix) ENDIF END SUBROUTINE rotint_ana @@ -1617,13 +1594,12 @@ END SUBROUTINE rotint_ana !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param lgrad ... -!> \param error ... !> \par History !> 03.2008 created [tlaino] !> \author Teodoro Laino [tlaino] - Zurich University ! ***************************************************************************** RECURSIVE SUBROUTINE dterep_ana (sepi, sepj, rij, rep, rep_d, se_taper, & - se_int_control, lgrad, error) + se_int_control, lgrad) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), INTENT(IN) :: rij REAL(KIND=dp), DIMENSION(491), & @@ -1631,7 +1607,6 @@ RECURSIVE SUBROUTINE dterep_ana (sepi, sepj, rij, rep, rep_d, se_taper, & TYPE(se_taper_type), POINTER :: se_taper TYPE(se_int_control_type), INTENT(IN) :: se_int_control LOGICAL, INTENT(IN) :: lgrad - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dterep_ana', & routineP = moduleN//':'//routineN @@ -1644,39 +1619,39 @@ RECURSIVE SUBROUTINE dterep_ana (sepi, sepj, rij, rep, rep_d, se_taper, & failure = .FALSE. ! Compute the tapering function and its derivatives - ft = taper_eval(se_taper%taper,rij,error) + ft = taper_eval(se_taper%taper,rij) dft = 0.0_dp ft1 = ft IF (lgrad) THEN ft1 = 1.0_dp - dft = dtaper_eval(se_taper%taper,rij,error) + dft = dtaper_eval(se_taper%taper,rij) END IF ! Evaluate additional taper function for dumped integrals IF (se_int_control%integral_screening==do_se_IS_kdso_d) THEN - se_int_screen%ft = taper_eval(se_taper%taper_add, rij, error) + se_int_screen%ft = taper_eval(se_taper%taper_add, rij) IF (lgrad) & - se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij, error) + se_int_screen%dft = dtaper_eval(se_taper%taper_add, rij) END IF ! Integral Values for sp shells only CALL terep_sp_num(sepi, sepj, rij, rep, se_int_control=se_int_control, & - se_int_screen=se_int_screen, ft=ft1, error=error) + se_int_screen=se_int_screen, ft=ft1) IF (sepi%dorb.OR.sepj%dorb) THEN ! Compute the contribution from d-orbitals CALL terep_d_num (sepi, sepj, rij, rep, se_int_control=se_int_control,& - se_int_screen=se_int_screen, ft=ft1, error=error) + se_int_screen=se_int_screen, ft=ft1) END IF IF (lgrad) THEN ! Integral Derivatives CALL dterep_sp_ana(sepi, sepj, rij, rep_d, rep, se_int_control,& - se_int_screen, ft, dft, error=error) + se_int_screen, ft, dft) IF (sepi%dorb.OR.sepj%dorb) THEN ! Compute the derivatives from d-orbitals CALL dterep_d_ana (sepi, sepj, rij, rep_d, rep, se_int_control,& - se_int_screen, ft, dft, error=error) + se_int_screen, ft, dft) END IF ! Tapering Integral values @@ -1703,7 +1678,7 @@ RECURSIVE SUBROUTINE dterep_ana (sepi, sepj, rij, rep, rep_d, se_taper, & ! Possibly debug 2el 2cent integrals and derivatives IF (debug_this_module) THEN CALL check_dterep_ana(sepi, sepj, rij, rep, rep_d, se_int_control, se_taper=se_taper,& - lgrad=lgrad, error=error) + lgrad=lgrad) END IF END SUBROUTINE dterep_ana @@ -1720,7 +1695,6 @@ END SUBROUTINE dterep_ana !> \param se_int_screen ... !> \param ft ... !> \param dft ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> Teodoro Laino (03.2008) [tlaino] - University of Zurich : new driver @@ -1734,7 +1708,7 @@ END SUBROUTINE dterep_ana !> vector version written by Ernest R. Davidson, Indiana University ! ***************************************************************************** SUBROUTINE dterep_sp_ana ( sepi, sepj, rij, drep, rep, se_int_control, & - se_int_screen, ft, dft, error) + se_int_screen, ft, dft) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(491), INTENT(OUT) :: drep @@ -1742,7 +1716,6 @@ SUBROUTINE dterep_sp_ana ( sepi, sepj, rij, drep, rep, se_int_control, & TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen REAL(dp), INTENT(IN) :: ft, dft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dterep_sp_ana', & routineP = moduleN//':'//routineN @@ -1776,7 +1749,7 @@ SUBROUTINE dterep_sp_ana ( sepi, sepj, rij, drep, rep, se_int_control, & drep(numb) = -drep(-nold) ELSE IF (nold == 0) THEN tmp = d_ijkl_sp (sepi, sepj, ij, kl, li, lj, lk, ll, 0, rij,& - se_int_control, se_int_screen, do_method_undef, error) + se_int_control, se_int_screen, do_method_undef) drep(numb) = dft*rep(numb)+ft*tmp END IF END IF @@ -1798,13 +1771,12 @@ END SUBROUTINE dterep_sp_ana !> \param se_int_screen ... !> \param ft ... !> \param dft ... -!> \param error ... !> \par History !> Teodoro Laino (05.2008) [tlaino] - University of Zurich : new driver !> for computing integral derivatives for d-orbitals ! ***************************************************************************** SUBROUTINE dterep_d_ana (sepi, sepj, rij, drep, rep, se_int_control, & - se_int_screen, ft, dft, error ) + se_int_screen, ft, dft) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(491), INTENT(INOUT) :: drep @@ -1812,7 +1784,6 @@ SUBROUTINE dterep_d_ana (sepi, sepj, rij, drep, rep, se_int_control, & TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen REAL(dp), INTENT(IN) :: ft, dft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dterep_d_ana', & routineP = moduleN//':'//routineN @@ -1847,7 +1818,7 @@ SUBROUTINE dterep_d_ana (sepi, sepj, rij, drep, rep, se_int_control, & drep(numb) = -drep(-nold) ELSE IF (nold == 0) THEN tmp = d_ijkl_d (sepi, sepj, ij, kl, li, lj, lk, ll, 0, rij,& - se_int_control, se_int_screen, do_method_undef, error) + se_int_control, se_int_screen, do_method_undef) drep(numb) = dft*rep(numb)+ft*tmp END IF END IF diff --git a/src/semi_empirical_int_args.h b/src/semi_empirical_int_args.h index 3d133d9103..09550ae878 100644 --- a/src/semi_empirical_int_args.h +++ b/src/semi_empirical_int_args.h @@ -1 +1 @@ -#define CPPint_args se_int_control, se_int_screen, itype, error +#define CPPint_args se_int_control, se_int_screen, itype diff --git a/src/semi_empirical_int_arrays.F b/src/semi_empirical_int_arrays.F index 88bb7d7781..aa06c4047e 100644 --- a/src/semi_empirical_int_arrays.F +++ b/src/semi_empirical_int_arrays.F @@ -135,32 +135,28 @@ MODULE semi_empirical_int_arrays ! ***************************************************************************** !> \brief Initialize all arrays used for the evaluation of the integrals !> -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE init_se_intd_array(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE init_se_intd_array() CHARACTER(len=*), PARAMETER :: routineN = 'init_se_intd_array', & routineP = moduleN//':'//routineN - CALL setup_index_array(error) - CALL setup_indrot_array(error) - CALL setup_clm_array(error) - CALL setup_ijkl_array(error) + CALL setup_index_array() + CALL setup_indrot_array() + CALL setup_clm_array() + CALL setup_ijkl_array() END SUBROUTINE init_se_intd_array ! ***************************************************************************** !> \brief Fills in array for the diagonal storage of the ij and kl multipoles term !> -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE setup_index_array(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE setup_index_array() CHARACTER(len=*), PARAMETER :: routineN = 'setup_index_array', & routineP = moduleN//':'//routineN @@ -204,12 +200,10 @@ END SUBROUTINE setup_index_array ! ***************************************************************************** !> \brief Fills in array for the rotation of the integrals !> -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE setup_indrot_array(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE setup_indrot_array() CHARACTER(len=*), PARAMETER :: routineN = 'setup_indrot_array', & routineP = moduleN//':'//routineN @@ -275,12 +269,10 @@ END SUBROUTINE setup_indrot_array ! ***************************************************************************** !> \brief Fills in Clm coefficients (see Table [2] of TCA) !> -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE setup_clm_array(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE setup_clm_array() CHARACTER(len=*), PARAMETER :: routineN = 'setup_clm_array', & routineP = moduleN//':'//routineN @@ -490,12 +482,10 @@ END SUBROUTINE setup_clm_array !> \brief Fills in the index number for the integral as well as the !> symmetry index !> -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE setup_ijkl_array(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE setup_ijkl_array() CHARACTER(len=*), PARAMETER :: routineN = 'setup_ijkl_array', & routineP = moduleN//':'//routineN diff --git a/src/semi_empirical_int_debug.F b/src/semi_empirical_int_debug.F index 9faf468910..13c3bfdcf9 100644 --- a/src/semi_empirical_int_debug.F +++ b/src/semi_empirical_int_debug.F @@ -11,11 +11,10 @@ !> \param rjiv ... !> \param ij_matrix ... !> \param do_invert ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** -SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert, error) +SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert) USE kinds, ONLY: dp USE semi_empirical_int_utils, ONLY: rotmat @@ -30,7 +29,6 @@ SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert, error) REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rjiv TYPE(rotmat_type), POINTER :: ij_matrix LOGICAL, INTENT(IN) :: do_invert - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN='semi_empirical_int_debug',& routineN = 'check_rotmat_der', routineP = moduleN//':'//routineN @@ -43,9 +41,9 @@ SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert, error) NULLIFY(matrix_m, matrix_p, matrix_n, matrix) failure = .FALSE. - CALL rotmat_create(matrix_p, error) - CALL rotmat_create(matrix_m, error) - CALL rotmat_create(matrix_n, error) + CALL rotmat_create(matrix_p) + CALL rotmat_create(matrix_m) + CALL rotmat_create(matrix_n) dx = 1.0E-6_dp imap(1) = 1 imap(2) = 2 @@ -65,8 +63,7 @@ SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert, error) IF (i==2) matrix => matrix_m r0 = rjiv + (-1.0_dp)**(i-1) * x r = SQRT(DOT_PRODUCT(r0,r0)) - CALL rotmat (sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=do_invert,& - error=error) + CALL rotmat (sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=do_invert) END DO ! SP matrix_n%sp_d(j, :, :) = (matrix_p%sp - matrix_m%sp)/(2.0_dp*dx) @@ -128,9 +125,9 @@ SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert, error) END DO END IF END DO - CALL rotmat_release(matrix_p, error) - CALL rotmat_release(matrix_m, error) - CALL rotmat_release(matrix_n, error) + CALL rotmat_release(matrix_p) + CALL rotmat_release(matrix_m) + CALL rotmat_release(matrix_n) END SUBROUTINE check_rotmat_der ! ***************************************************************************** @@ -144,14 +141,13 @@ END SUBROUTINE check_rotmat_der !> \param ii ... !> \param kk ... !> \param v_d ... -!> \param error ... !> \par History !> 04.2008 created [tlaino] !> \author Teodoro Laino - Zurich University !> \note !> Debug routine ! ***************************************************************************** -SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, invert, ii, kk, v_d, error) +SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, invert, ii, kk, v_d) USE kinds, ONLY: dp USE semi_empirical_int_utils, ONLY: rotmat @@ -174,7 +170,6 @@ SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, in INTEGER, INTENT(IN) :: ii, kk REAL(KIND=dp), DIMENSION(3, 45, 45), & INTENT(IN) :: v_d - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN='semi_empirical_int_debug',& routineN = 'rot_2el_2c_first', routineP = moduleN//':'//routineN @@ -209,22 +204,21 @@ SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, in r0 = rijv + (-1.0_dp)**(i-1) * x r = SQRT(DOT_PRODUCT(r0,r0)) - CALL rotmat_create(matrix, error) - CALL rotmat (sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=invert,& - error=error) + CALL rotmat_create(matrix) + CALL rotmat (sepi, sepj, r0, r, matrix, do_derivatives=.FALSE., debug_invert=invert) ! Compute integrals in diatomic frame - CALL terep_num(sepi,sepj,r,rep,se_taper=se_taper,se_int_control=se_int_control,error=error) + CALL terep_num(sepi,sepj,r,rep,se_taper=se_taper,se_int_control=se_int_control) IF (i==1) THEN CALL rot_2el_2c_first(sepi, sepj, r0, se_int_control, se_taper, invert, ii, kk, rep, logv, matrix,& - v_p, lgrad=.FALSE., error=error) + v_p, lgrad=.FALSE.) END IF IF (i==2) THEN CALL rot_2el_2c_first(sepi, sepj, r0, se_int_control, se_taper, invert, ii, kk, rep, logv, matrix,& - v_m, lgrad=.FALSE., error=error) + v_m, lgrad=.FALSE.) END IF - CALL rotmat_release(matrix, error) + CALL rotmat_release(matrix) END DO ! Check numerical VS analytical DO i = 1, 45 @@ -249,14 +243,13 @@ END SUBROUTINE rot_2el_2c_first_debug !> \param itype ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \par History !> 04.2008 created [tlaino] !> \author Teodoro Laino - Zurich University !> \note !> Debug routine ! ***************************************************************************** -SUBROUTINE check_dssss_nucint_ana (sepi,sepj,r,dssss,itype,se_int_control,se_taper,error) +SUBROUTINE check_dssss_nucint_ana (sepi,sepj,r,dssss,itype,se_int_control,se_taper) USE kinds, ONLY: dp USE semi_empirical_int_num, ONLY: ssss_nucint_num @@ -271,7 +264,6 @@ SUBROUTINE check_dssss_nucint_ana (sepi,sepj,r,dssss,itype,se_int_control,se_tap INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN='semi_empirical_int_debug',& routineN = 'check_dssss_nucint_ana', routineP = moduleN//':'//routineN @@ -282,9 +274,9 @@ SUBROUTINE check_dssss_nucint_ana (sepi,sepj,r,dssss,itype,se_int_control,se_tap delta = 1.0E-8_dp od = 0.5_dp/delta rn = r + delta - CALL ssss_nucint_num(sepi,sepj,rn,ssssp,itype,se_taper,se_int_control,error=error) + CALL ssss_nucint_num(sepi,sepj,rn,ssssp,itype,se_taper,se_int_control) rn = r - delta - CALL ssss_nucint_num(sepi,sepj,rn,ssssm,itype,se_taper,se_int_control,error=error) + CALL ssss_nucint_num(sepi,sepj,rn,ssssm,itype,se_taper,se_int_control) nssss = od * (ssssp - ssssm) ! check WRITE(*,*)"DEBUG::"//routineP @@ -303,14 +295,13 @@ END SUBROUTINE check_dssss_nucint_ana !> \param itype ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \par History !> 04.2008 created [tlaino] !> \author Teodoro Laino - Zurich University !> \note !> Debug routine ! ***************************************************************************** -SUBROUTINE check_dcore_nucint_ana (sepi,sepj,r,dcore,itype,se_int_control,se_taper,error) +SUBROUTINE check_dcore_nucint_ana (sepi,sepj,r,dcore,itype,se_int_control,se_taper) USE kinds, ONLY: dp USE semi_empirical_int_num, ONLY: core_nucint_num @@ -325,7 +316,6 @@ SUBROUTINE check_dcore_nucint_ana (sepi,sepj,r,dcore,itype,se_int_control,se_tap INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN='semi_empirical_int_debug',& routineN = 'check_dcore_nucint_ana', routineP = moduleN//':'//routineN @@ -338,9 +328,9 @@ SUBROUTINE check_dcore_nucint_ana (sepi,sepj,r,dcore,itype,se_int_control,se_tap delta = 1.0E-8_dp od = 0.5_dp/delta rn = r + delta - CALL core_nucint_num(sepi,sepj,rn,corep,itype,se_taper,se_int_control,error=error) + CALL core_nucint_num(sepi,sepj,rn,corep,itype,se_taper,se_int_control) rn = r - delta - CALL core_nucint_num(sepi,sepj,rn,corem,itype,se_taper,se_int_control,error=error) + CALL core_nucint_num(sepi,sepj,rn,corem,itype,se_taper,se_int_control) ncore = od * (corep - corem) ! check WRITE(*,*)"DEBUG::"//routineP @@ -405,14 +395,13 @@ END FUNCTION check_value !> \param e2a ... !> \param de1b ... !> \param de2a ... -!> \param error ... !> \par History !> 04.2008 created [tlaino] !> \author Teodoro Laino - Zurich University !> \note !> Debug routine ! ***************************************************************************** -SUBROUTINE check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, e1b, e2a, de1b, de2a, error) +SUBROUTINE check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, e1b, e2a, de1b, de2a) USE kinds, ONLY: dp USE semi_empirical_int_num, ONLY: rotnuc_num,& @@ -431,7 +420,6 @@ SUBROUTINE check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, OPTIONAL :: e1b, e2a REAL(dp), DIMENSION(3, 45), & INTENT(IN), OPTIONAL :: de1b, de2a - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN = 'semi_empirical_int_debug', & routineN = 'check_drotnuc_ana', routineP = moduleN//':'//routineN @@ -451,7 +439,7 @@ SUBROUTINE check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, delta = 1.0E-5_dp ! Check value of integrals WRITE(*,*)"DEBUG::"//routineP - CALL rotnuc_num(sepi,sepj,rijv,e1b2,e2a2,itype,se_int_control,se_taper=se_taper,error=error) + CALL rotnuc_num(sepi,sepj,rijv,e1b2,e2a2,itype,se_int_control,se_taper=se_taper) IF (l_e1b) THEN DO j = 1, 45 IF (.NOT.check_value(e1b2(j), e1b(j), delta, 0.1_dp)) THEN @@ -472,7 +460,7 @@ SUBROUTINE check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper, ! Check derivatives IF (lgrad) THEN CALL drotnuc_num(sepi,sepj,rijv,de1b2,de2a2,itype,delta=delta,& - se_int_control=se_int_control,se_taper=se_taper,error=error) + se_int_control=se_int_control,se_taper=se_taper) IF (l_de1b) THEN DO i = 1, 3 DO j = 1, 45 @@ -512,14 +500,13 @@ END SUBROUTINE check_drotnuc_ana !> \param se_taper ... !> \param enuc ... !> \param denuc ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> \author Teodoro Laino - Zurich University !> \note !> Debug routine ! ***************************************************************************** -SUBROUTINE check_dcorecore_ana(sepi, sepj, rijv, itype,se_int_control, se_taper, enuc, denuc, error) +SUBROUTINE check_dcorecore_ana(sepi, sepj, rijv, itype,se_int_control, se_taper, enuc, denuc) USE kinds, ONLY: dp USE semi_empirical_int_num, ONLY: corecore_num,& @@ -537,7 +524,6 @@ SUBROUTINE check_dcorecore_ana(sepi, sepj, rijv, itype,se_int_control, se_taper, OPTIONAL :: denuc TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN = 'semi_empirical_int_debug', & routineN = 'check_dcorecore_ana', routineP = moduleN//':'//routineN @@ -551,14 +537,14 @@ SUBROUTINE check_dcorecore_ana(sepi, sepj, rijv, itype,se_int_control, se_taper, delta = 1.0E-7_dp ! check IF (PRESENT(enuc)) THEN - CALL corecore_num(sepi,sepj,rijv, enuc_num,itype,se_int_control,se_taper,error) + CALL corecore_num(sepi,sepj,rijv, enuc_num,itype,se_int_control,se_taper) IF (.NOT.check_value(enuc, enuc_num, delta, 0.001_dp)) THEN WRITE(*,*)"ERROR for CORE-CORE energy value (numerical different from analytical)!!" STOP END IF END IF IF (PRESENT(denuc)) THEN - CALL dcorecore_num(sepi,sepj,rijv,denuc_num,itype,delta,se_int_control,se_taper,error) + CALL dcorecore_num(sepi,sepj,rijv,denuc_num,itype,delta,se_int_control,se_taper) DO j = 1, 3 IF (.NOT.check_value(denuc(j), denuc_num(j), delta, 0.001_dp)) THEN WRITE(*,*)"ERROR for CORE-CORE energy derivative value (numerical different from analytical). DENUC(j), j::", j @@ -578,14 +564,13 @@ END SUBROUTINE check_dcorecore_ana !> \param se_int_control ... !> \param se_taper ... !> \param lgrad ... -!> \param error ... !> \par History !> 04.2007 created [tlaino] !> \author Teodoro Laino - Zurich University !> \note !> Debug routine ! ***************************************************************************** -SUBROUTINE check_dterep_ana (sepi,sepj,r,ri,dri,se_int_control,se_taper,lgrad,error) +SUBROUTINE check_dterep_ana (sepi,sepj,r,ri,dri,se_int_control,se_taper,lgrad) USE kinds, ONLY: dp USE semi_empirical_int_num, ONLY: terep_num @@ -600,7 +585,6 @@ SUBROUTINE check_dterep_ana (sepi,sepj,r,ri,dri,se_int_control,se_taper,lgrad,er TYPE(se_int_control_type), INTENT(IN) :: se_int_control LOGICAL, INTENT(IN) :: lgrad TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN = 'semi_empirical_int_debug', & routineN = 'check_dterep_ana', routineP = moduleN//':'//routineN @@ -613,12 +597,12 @@ SUBROUTINE check_dterep_ana (sepi,sepj,r,ri,dri,se_int_control,se_taper,lgrad,er delta = 1.0E-8_dp od = 0.5_dp/delta rn = r - CALL terep_num(sepi,sepj,rn,ri0,se_taper,se_int_control,error=error) + CALL terep_num(sepi,sepj,rn,ri0,se_taper,se_int_control) IF (lgrad) THEN rn = r + delta - CALL terep_num(sepi,sepj,rn,rip,se_taper,se_int_control,error=error) + CALL terep_num(sepi,sepj,rn,rip,se_taper,se_int_control) rn = r - delta - CALL terep_num(sepi,sepj,rn,rim,se_taper,se_int_control,error=error) + CALL terep_num(sepi,sepj,rn,rim,se_taper,se_int_control) nri = od * (rip - rim) END IF ! check @@ -650,14 +634,13 @@ END SUBROUTINE check_dterep_ana !> \param dw ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \par History !> 04.2008 created [tlaino] !> \author Teodoro Laino - Zurich University !> \note !> Debug routine ! ***************************************************************************** -SUBROUTINE check_rotint_ana(sepi,sepj,rijv,w,dw,se_int_control,se_taper,error) +SUBROUTINE check_rotint_ana(sepi,sepj,rijv,w,dw,se_int_control,se_taper) USE kinds, ONLY: dp USE semi_empirical_int_num, ONLY: rotint_num,& @@ -675,7 +658,6 @@ SUBROUTINE check_rotint_ana(sepi,sepj,rijv,w,dw,se_int_control,se_taper,error) INTENT(IN), OPTIONAL :: dw TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: moduleN = 'semi_empirical_int_debug', & routineN = 'rotint_ana', routineP = moduleN//':'//routineN @@ -690,7 +672,7 @@ SUBROUTINE check_rotint_ana(sepi,sepj,rijv,w,dw,se_int_control,se_taper,error) WRITE(*,*)"DEBUG::"//routineP IF (PRESENT(w)) THEN w2=0.0_dp - CALL rotint_num(sepi,sepj,rijv,w2,se_int_control,se_taper=se_taper,error=error) + CALL rotint_num(sepi,sepj,rijv,w2,se_int_control,se_taper=se_taper) DO j = 1, 2025 IF (.NOT.check_value(w(j), w2(j), delta, 0.1_dp)) THEN WRITE(*,*)"ERROR for integral value W(j), j::",j @@ -703,8 +685,8 @@ SUBROUTINE check_rotint_ana(sepi,sepj,rijv,w,dw,se_int_control,se_taper,error) ! First of all let's decide if the value we get for delta is compatible ! with a reasonable value of the integral.. (compatible if the value of the ! integral is greater than 1.0E-6) - CALL drotint_num(sepi,sepj,rijv,dw2,delta=delta,se_int_control=se_int_control,se_taper=se_taper,error=error) - CALL rotint_num(sepi,sepj,rijv,w2,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL drotint_num(sepi,sepj,rijv,dw2,delta=delta,se_int_control=se_int_control,se_taper=se_taper) + CALL rotint_num(sepi,sepj,rijv,w2,se_int_control=se_int_control,se_taper=se_taper) DO i = 1, 3 DO j = 1, 2025 IF ((ABS(w2(j))>delta).AND.(ABS(dw2(i,j))>delta*10)) THEN diff --git a/src/semi_empirical_int_debug.h b/src/semi_empirical_int_debug.h index 578c4ffccd..96616f124a 100644 --- a/src/semi_empirical_int_debug.h +++ b/src/semi_empirical_int_debug.h @@ -10,7 +10,7 @@ !> \date 04.2008 [tlaino] ! ***************************************************************************** INTERFACE - SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert, error) + SUBROUTINE check_rotmat_der( sepi, sepj, rjiv, ij_matrix, do_invert) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: rotmat_type,& semi_empirical_type @@ -20,7 +20,6 @@ INTERFACE REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rjiv TYPE(rotmat_type), POINTER :: ij_matrix LOGICAL, INTENT(IN) :: do_invert - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE check_rotmat_der END INTERFACE @@ -34,7 +33,7 @@ END INTERFACE ! ***************************************************************************** INTERFACE SUBROUTINE check_dssss_nucint_ana (sepi,sepj,r,dssss,itype,se_int_control,& - se_taper,error) + se_taper) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: semi_empirical_type,& se_int_control_type,& @@ -47,7 +46,6 @@ INTERFACE INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE check_dssss_nucint_ana END INTERFACE @@ -61,7 +59,7 @@ END INTERFACE ! ***************************************************************************** INTERFACE SUBROUTINE check_dcore_nucint_ana (sepi,sepj,r,dcore,itype,se_int_control,& - se_taper,error) + se_taper) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: semi_empirical_type,& se_int_control_type,& @@ -74,7 +72,6 @@ INTERFACE INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE check_dcore_nucint_ana END INTERFACE @@ -88,7 +85,7 @@ END INTERFACE ! ***************************************************************************** INTERFACE SUBROUTINE check_drotnuc_ana(sepi, sepj, rijv, itype, se_int_control, se_taper,& - e1b, e2a, de1b, de2a, error) + e1b, e2a, de1b, de2a) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: semi_empirical_type,& se_int_control_type,& @@ -104,7 +101,6 @@ INTERFACE OPTIONAL :: e1b, e2a REAL(dp), DIMENSION(45, 3), & INTENT(IN), OPTIONAL :: de1b, de2a - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE check_drotnuc_ana END INTERFACE @@ -118,7 +114,7 @@ END INTERFACE ! ***************************************************************************** INTERFACE SUBROUTINE check_dcorecore_ana(sepi, sepj, rijv, itype,se_int_control,& - se_taper, enuc, denuc, error) + se_taper, enuc, denuc) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: semi_empirical_type,& se_int_control_type,& @@ -133,7 +129,6 @@ INTERFACE OPTIONAL :: denuc TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE check_dcorecore_ana END INTERFACE @@ -148,7 +143,7 @@ END INTERFACE ! ***************************************************************************** INTERFACE SUBROUTINE rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper,& - invert, ii, kk, v_d, error) + invert, ii, kk, v_d) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: semi_empirical_type,& se_int_control_type,& @@ -163,7 +158,6 @@ INTERFACE INTEGER, INTENT(IN) :: ii, kk REAL(KIND=dp), DIMENSION(45, 45, 3), & INTENT(IN) :: v_d - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE rot_2el_2c_first_debug END INTERFACE @@ -176,7 +170,7 @@ END INTERFACE !> \author Teodoro Laino - Zurich University ! ***************************************************************************** INTERFACE - SUBROUTINE check_dterep_ana (sepi,sepj,r,ri,dri,se_int_control,se_taper,lgrad,error) + SUBROUTINE check_dterep_ana (sepi,sepj,r,ri,dri,se_int_control,se_taper,lgrad) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: semi_empirical_type,& se_int_control_type,& @@ -189,7 +183,6 @@ INTERFACE TYPE(se_int_control_type), INTENT(IN) :: se_int_control LOGICAL, INTENT(IN) :: lgrad TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE check_dterep_ana END INTERFACE @@ -202,7 +195,7 @@ END INTERFACE !> \author Teodoro Laino - Zurich University ! ***************************************************************************** INTERFACE - SUBROUTINE check_rotint_ana(sepi,sepj,rijv,w,dw,se_int_control,se_taper,error) + SUBROUTINE check_rotint_ana(sepi,sepj,rijv,w,dw,se_int_control,se_taper) USE kinds, ONLY: dp USE semi_empirical_types, ONLY: semi_empirical_type,& se_int_control_type,& @@ -217,6 +210,5 @@ INTERFACE INTENT(IN), OPTIONAL :: dw TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error END SUBROUTINE check_rotint_ana END INTERFACE diff --git a/src/semi_empirical_int_gks.F b/src/semi_empirical_int_gks.F index 02a3af1951..d87c5d5a05 100644 --- a/src/semi_empirical_int_gks.F +++ b/src/semi_empirical_int_gks.F @@ -53,15 +53,13 @@ MODULE semi_empirical_int_gks !> \param e1b ... !> \param e2a ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rotnuc_gks (sepi,sepj,rij,e1b,e2a,se_int_control,error) + SUBROUTINE rotnuc_gks (sepi,sepj,rij,e1b,e2a,se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(45), INTENT(OUT), & OPTIONAL :: e1b, e2a TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotnuc_gks', & routineP = moduleN//':'//routineN @@ -74,12 +72,12 @@ SUBROUTINE rotnuc_gks (sepi,sepj,rij,e1b,e2a,se_int_control,error) IF(se_int_control%do_ewald_gks) THEN IF ( DOT_PRODUCT(rij,rij) > rij_threshold) THEN - CALL makeCoulE(rab,sepi,sepj,Coul,se_int_control,error) + CALL makeCoulE(rab,sepi,sepj,Coul,se_int_control) ELSE - CALL makeCoulE0(sepi,Coul,se_int_control,error) + CALL makeCoulE0(sepi,Coul,se_int_control) END IF ELSE - CALL makeCoul(rab,sepi,sepj,Coul,se_int_control,error) + CALL makeCoul(rab,sepi,sepj,Coul,se_int_control) END IF i = 0 @@ -107,15 +105,13 @@ END SUBROUTINE rotnuc_gks !> \param rij ... !> \param w ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rotint_gks (sepi,sepj,rij,w,se_int_control,error) + SUBROUTINE rotint_gks (sepi,sepj,rij,w,se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(2025), INTENT(OUT), & OPTIONAL :: w TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotint_gks', & routineP = moduleN//':'//routineN @@ -129,12 +125,12 @@ SUBROUTINE rotint_gks (sepi,sepj,rij,w,se_int_control,error) IF(se_int_control%do_ewald_gks) THEN IF ( DOT_PRODUCT(rij,rij) > rij_threshold) THEN - CALL makeCoulE(rab,sepi,sepj,Coul,se_int_control,error) + CALL makeCoulE(rab,sepi,sepj,Coul,se_int_control) ELSE - CALL makeCoulE0(sepi,Coul,se_int_control,error) + CALL makeCoulE0(sepi,Coul,se_int_control) END IF ELSE - CALL makeCoul(rab,sepi,sepj,Coul,se_int_control,error) + CALL makeCoul(rab,sepi,sepj,Coul,se_int_control) END IF i = 0 @@ -163,15 +159,13 @@ END SUBROUTINE rotint_gks !> \param de1b ... !> \param de2a ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE drotnuc_gks(sepi,sepj,rij,de1b,de2a,se_int_control,error) + SUBROUTINE drotnuc_gks(sepi,sepj,rij,de1b,de2a,se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(3, 45), & INTENT(OUT), OPTIONAL :: de1b, de2a TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'drotnuc_gks', & routineP = moduleN//':'//routineN @@ -183,9 +177,9 @@ SUBROUTINE drotnuc_gks(sepi,sepj,rij,de1b,de2a,se_int_control,error) rab= -rij IF(se_int_control%do_ewald_gks) THEN - CALL makedCoulE(rab,sepi,sepj,dCoul,se_int_control,error) + CALL makedCoulE(rab,sepi,sepj,dCoul,se_int_control) ELSE - CALL makedCoul(rab,sepi,sepj,dCoul,se_int_control,error) + CALL makedCoul(rab,sepi,sepj,dCoul,se_int_control) END IF i = 0 @@ -217,15 +211,13 @@ END SUBROUTINE drotnuc_gks !> \param rij ... !> \param dw ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE drotint_gks(sepi,sepj,rij,dw,se_int_control,error) + SUBROUTINE drotint_gks(sepi,sepj,rij,dw,se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(3, 2025), & INTENT(OUT) :: dw TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'drotint_gks', & routineP = moduleN//':'//routineN @@ -238,9 +230,9 @@ SUBROUTINE drotint_gks(sepi,sepj,rij,dw,se_int_control,error) rab= -rij IF(se_int_control%do_ewald_gks) THEN - CALL makedCoulE(rab,sepi,sepj,dCoul,se_int_control,error) + CALL makedCoulE(rab,sepi,sepj,dCoul,se_int_control) ELSE - CALL makedCoul(rab,sepi,sepj,dCoul,se_int_control,error) + CALL makedCoul(rab,sepi,sepj,dCoul,se_int_control) END IF i = 0 @@ -270,15 +262,13 @@ END SUBROUTINE drotint_gks !> \param sepj ... !> \param Coul ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE makeCoul(RAB,sepi,sepj,Coul,se_int_control,error) + SUBROUTINE makeCoul(RAB,sepi,sepj,Coul,se_int_control) REAL(kind=dp), DIMENSION(3) :: RAB TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(kind=dp), DIMENSION(45, 45), & INTENT(OUT) :: Coul TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'makeCoul', & routineP = moduleN//':'//routineN @@ -383,15 +373,13 @@ END SUBROUTINE makeCoul !> \param sepj ... !> \param dCoul ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE makedCoul(RAB,sepi,sepj,dCoul,se_int_control,error) + SUBROUTINE makedCoul(RAB,sepi,sepj,dCoul,se_int_control) REAL(kind=dp), DIMENSION(3) :: RAB TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(kind=dp), DIMENSION(3, 45, 45), & INTENT(OUT) :: dCoul TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'makedCoul', & routineP = moduleN//':'//routineN @@ -514,16 +502,14 @@ END SUBROUTINE makedCoul !> \param enuc ... !> \param denuc ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE corecore_gks (sepi,sepj,rijv,enuc,denuc,se_int_control,error) + SUBROUTINE corecore_gks (sepi,sepj,rijv,enuc,denuc,se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv REAL(dp), INTENT(OUT), OPTIONAL :: enuc REAL(dp), DIMENSION(3), INTENT(OUT), & OPTIONAL :: denuc TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore_gks', & routineP = moduleN//':'//routineN @@ -549,19 +535,19 @@ SUBROUTINE corecore_gks (sepi,sepj,rijv,enuc,denuc,se_int_control,error) CALL setup_se_int_control_type(se_int_control_off, shortrange=.FALSE., do_ewald_r3=.FALSE.,& do_ewald_gks=.FALSE., integral_screening=se_int_control%integral_screening,& max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.) - CALL makeCoul(rijv,sepi,sepj,Coul,se_int_control_off,error) - IF (l_denuc) CALL makedCoul(rijv,sepi,sepj,dCoul,se_int_control_off,error) + CALL makeCoul(rijv,sepi,sepj,Coul,se_int_control_off) + IF (l_denuc) CALL makedCoul(rijv,sepi,sepj,dCoul,se_int_control_off) IF (se_int_control%do_ewald_gks) THEN - CALL makeCoulE(rijv,sepi,sepj,CoulE,se_int_control,error) - IF (l_denuc) CALL makedCoulE(rijv,sepi,sepj,dCoulE,se_int_control,error) + CALL makeCoulE(rijv,sepi,sepj,CoulE,se_int_control) + IF (l_denuc) CALL makedCoulE(rijv,sepi,sepj,dCoulE,se_int_control) ELSE - CALL makeCoul(rijv,sepi,sepj,CoulE,se_int_control,error) - IF (l_denuc) CALL makedCoul(rijv,sepi,sepj,dCoulE,se_int_control,error) + CALL makeCoul(rijv,sepi,sepj,CoulE,se_int_control) + IF (l_denuc) CALL makedCoul(rijv,sepi,sepj,dCoulE,se_int_control) END IF ELSE - CALL makeCoul(rijv,sepi,sepj,Coul,se_int_control,error) + CALL makeCoul(rijv,sepi,sepj,Coul,se_int_control) CoulE = Coul - IF (l_denuc) CALL makedCoul(rijv,sepi,sepj,dCoul,se_int_control,error) + IF (l_denuc) CALL makedCoul(rijv,sepi,sepj,dCoul,se_int_control) IF (l_denuc) dCoulE = dCoul END IF @@ -585,7 +571,7 @@ SUBROUTINE corecore_gks (sepi,sepj,rijv,enuc,denuc,se_int_control,error) IF (se_int_control%do_ewald_gks) THEN zz = sepi%zeff*sepi%zeff - CALL makeCoulE0(sepi,CoulE,se_int_control,error) + CALL makeCoulE0(sepi,CoulE,se_int_control) IF (l_enuc) THEN enuc=zz*CoulE(1,1) END IF @@ -604,15 +590,13 @@ END SUBROUTINE corecore_gks !> \param sepj ... !> \param Coul ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE makeCoulE(RAB,sepi,sepj,Coul,se_int_control,error) + SUBROUTINE makeCoulE(RAB,sepi,sepj,Coul,se_int_control) REAL(KIND=dp), DIMENSION(3) :: RAB TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(45, 45), & INTENT(OUT) :: Coul TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'makeCoulE', & routineP = moduleN//':'//routineN @@ -830,15 +814,13 @@ END SUBROUTINE makeCoulE !> \param sepj ... !> \param dCoul ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE makedCoulE(RAB,sepi,sepj,dCoul,se_int_control,error) + SUBROUTINE makedCoulE(RAB,sepi,sepj,dCoul,se_int_control) REAL(KIND=dp), DIMENSION(3) :: RAB TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3, 45, 45), & INTENT(OUT) :: dCoul TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'makedCoulE', & routineP = moduleN//':'//routineN @@ -1212,14 +1194,12 @@ END SUBROUTINE build_d_tensor_gks !> \param sepi ... !> \param Coul ... !> \param se_int_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE makeCoulE0(sepi,Coul,se_int_control,error) + SUBROUTINE makeCoulE0(sepi,Coul,se_int_control) TYPE(semi_empirical_type), POINTER :: sepi REAL(KIND=dp), DIMENSION(45, 45), & INTENT(OUT) :: Coul TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'makeCoulE0', & routineP = moduleN//':'//routineN diff --git a/src/semi_empirical_int_num.F b/src/semi_empirical_int_num.F index 9389f373a4..577e7b3c05 100644 --- a/src/semi_empirical_int_num.F +++ b/src/semi_empirical_int_num.F @@ -69,18 +69,16 @@ MODULE semi_empirical_int_num !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_taper ... -!> \param error ... !> \note routine adapted from mopac7 (rotate) !> written by Ernest R. Davidson, Indiana University. !> Teodoro Laino [tlaino] - University of Zurich 04.2008 : major rewriting ! ***************************************************************************** - SUBROUTINE rotint_num (sepi,sepj,rijv,w,se_int_control,se_taper,error) + SUBROUTINE rotint_num (sepi,sepj,rijv,w,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv REAL(dp), DIMENSION(2025), INTENT(OUT) :: w TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotint_num', & routineP = moduleN//':'//routineN @@ -106,11 +104,11 @@ SUBROUTINE rotint_num (sepi,sepj,rijv,w,se_int_control,se_taper,error) rij = SQRT(rij) ! Create the rotation matrix - CALL rotmat_create(ij_matrix, error) - CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=.FALSE., error=error) + CALL rotmat_create(ij_matrix) + CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=.FALSE.) ! Compute Integrals in Diatomic Frame - CALL terep_num(sepi,sepj,rij,rep,se_taper=se_taper,se_int_control=se_int_control,error=error) + CALL terep_num(sepi,sepj,rij,rep,se_taper=se_taper,se_int_control=se_int_control) ! Rotate Integrals ii = sepi%natorb @@ -125,7 +123,7 @@ SUBROUTINE rotint_num (sepi,sepj,rijv,w,se_int_control,se_taper,error) ! First step in rotation of integrals CALL rot_2el_2c_first(sepi, sepj, rijv, se_int_control, se_taper, .FALSE., ii, kk, rep, & - logv, ij_matrix, v, lgrad=.FALSE.,error=error) + logv, ij_matrix, v, lgrad=.FALSE.) ! Second step in rotation of integrals DO i1 = 1, ii @@ -206,10 +204,10 @@ SUBROUTINE rotint_num (sepi,sepj,rijv,w,se_int_control,se_taper,error) END DO END DO END IF - CALL rotmat_release(ij_matrix, error) + CALL rotmat_release(ij_matrix) ! Store two electron integrals in the triangular format - CALL store_2el_2c_diag(limij, limkl, ww, w, error=error) + CALL store_2el_2c_diag(limij, limkl, ww, w) ENDIF END SUBROUTINE rotint_num @@ -223,18 +221,16 @@ END SUBROUTINE rotint_num !> \param se_taper ... !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) -!> \param error ... !> \par History !> 03.2008 created [tlaino] !> \author Teodoro Laino [tlaino] - Zurich University ! ***************************************************************************** - SUBROUTINE terep_num(sepi, sepj, rij, rep, se_taper, se_int_control, error) + SUBROUTINE terep_num(sepi, sepj, rij, rep, se_taper, se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(491), INTENT(OUT) :: rep TYPE(se_taper_type), POINTER :: se_taper TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'terep_num', & routineP = moduleN//':'//routineN @@ -244,20 +240,19 @@ SUBROUTINE terep_num(sepi, sepj, rij, rep, se_taper, se_int_control, error) TYPE(se_int_screen_type) :: se_int_screen failure = .FALSE. - ft = taper_eval(se_taper%taper, rij, error) + ft = taper_eval(se_taper%taper, rij) ! In case of dumped integrals compute an additional taper term IF (se_int_control%integral_screening==do_se_IS_kdso_d) THEN - se_int_screen%ft = taper_eval(se_taper%taper_add, rij, error) + se_int_screen%ft = taper_eval(se_taper%taper_add, rij) END IF ! Contribution from sp shells - CALL terep_sp_num(sepi, sepj, rij, rep, se_int_control, se_int_screen, ft,& - error) + CALL terep_sp_num(sepi, sepj, rij, rep, se_int_control, se_int_screen, ft) IF (sepi%dorb.OR.sepj%dorb) THEN ! Compute the contribution from d shells CALL terep_d_num (sepi, sepj, rij, rep, se_int_control, se_int_screen,& - ft, error) + ft) END IF END SUBROUTINE terep_num @@ -273,20 +268,18 @@ END SUBROUTINE terep_num !> \param se_int_screen contains information for computing the screened !> integrals KDSO-D !> \param ft ... -!> \param error ... !> \par History !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver !> for computing integrals ! ***************************************************************************** SUBROUTINE terep_sp_num (sepi, sepj, rij, rep, se_int_control, se_int_screen,& - ft, error ) + ft) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(491), INTENT(OUT) :: rep TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen REAL(dp), INTENT(IN) :: ft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'terep_sp_num', & routineP = moduleN//':'//routineN @@ -320,8 +313,8 @@ SUBROUTINE terep_sp_num (sepi, sepj, rij, rep, se_int_control, se_int_screen,& rep(numb) = -rep(-nold) ELSE IF (nold == 0) THEN tmp = ijkl_sp (sepi, sepj, ij, kl, li, lj, lk, ll, 0, rij,& - se_int_control, se_int_screen, do_method_undef,& - error) * ft + se_int_control, se_int_screen, do_method_undef)& + * ft rep(numb) = tmp END IF END IF @@ -342,20 +335,18 @@ END SUBROUTINE terep_sp_num !> \param se_int_screen contains information for computing the screened !> integrals KDSO-D !> \param ft ... -!> \param error ... !> \par History !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver !> for computing integrals ! ***************************************************************************** SUBROUTINE terep_d_num (sepi, sepj, rij, rep, se_int_control, se_int_screen,& - ft, error ) + ft) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(491), INTENT(INOUT) :: rep TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen REAL(dp), INTENT(IN) :: ft - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'terep_d_num', & routineP = moduleN//':'//routineN @@ -390,8 +381,8 @@ SUBROUTINE terep_d_num (sepi, sepj, rij, rep, se_int_control, se_int_screen,& rep(numb) = -rep(-nold) ELSE IF (nold == 0) THEN tmp = ijkl_d (sepi, sepj, ij, kl, li, lj, lk, ll, 0, rij,& - se_int_control, se_int_screen, do_method_undef,& - error) * ft + se_int_control, se_int_screen, do_method_undef)& + * ft rep(numb) = tmp END IF END IF @@ -414,13 +405,12 @@ END SUBROUTINE terep_d_num !> \param itype ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \note routine adapted from mopac7 (rotate) !> written by Ernest R. Davidson, Indiana University. !> Teodoro Laino [tlaino] - University of Zurich 04.2008 : major rewriting !> Teodoro Laino [tlaino] - University of Zurich 04.2008 : removed the core-core part ! ***************************************************************************** - SUBROUTINE rotnuc_num(sepi,sepj,rijv,e1b,e2a,itype,se_int_control,se_taper,error) + SUBROUTINE rotnuc_num(sepi,sepj,rijv,e1b,e2a,itype,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv REAL(dp), DIMENSION(45), INTENT(OUT), & @@ -428,7 +418,6 @@ SUBROUTINE rotnuc_num(sepi,sepj,rijv,e1b,e2a,itype,se_int_control,se_taper,error INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotnuc_num', & routineP = moduleN//':'//routineN @@ -449,12 +438,12 @@ SUBROUTINE rotnuc_num(sepi,sepj,rijv,e1b,e2a,itype,se_int_control,se_taper,error IF (rij > rij_threshold) THEN rij = SQRT(rij) ! Create the rotation matrix - CALL rotmat_create(ij_matrix, error) - CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=.FALSE., error=error) + CALL rotmat_create(ij_matrix) + CALL rotmat (sepi, sepj, rijv, rij, ij_matrix, do_derivatives=.FALSE.) ! Compute Integrals in Diatomic Frame CALL core_nucint_num(sepi,sepj,rij,core=core,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control,error=error) + se_int_control=se_int_control) ! Copy parameters over to arrays for do loop. last_orbital(1) = sepi%natorb @@ -512,7 +501,7 @@ SUBROUTINE rotnuc_num(sepi,sepj,rijv,e1b,e2a,itype,se_int_control,se_taper,error END DO END IF END DO - CALL rotmat_release(ij_matrix, error) + CALL rotmat_release(ij_matrix) END IF END SUBROUTINE rotnuc_num @@ -526,20 +515,18 @@ END SUBROUTINE rotnuc_num !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_taper ... -!> \param error ... !> \note routine adapted from mopac7 (rotate) !> written by Ernest R. Davidson, Indiana University. !> Teodoro Laino [tlaino] - University of Zurich 04.2008 : major rewriting !> Teodoro Laino [tlaino] - University of Zurich 04.2008 : splitted from rotnuc ! ***************************************************************************** - SUBROUTINE corecore_num(sepi,sepj,rijv,enuc,itype,se_int_control,se_taper,error) + SUBROUTINE corecore_num(sepi,sepj,rijv,enuc,itype,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv REAL(dp), INTENT(OUT) :: enuc INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore_num', & routineP = moduleN//':'//routineN @@ -559,11 +546,11 @@ SUBROUTINE corecore_num(sepi,sepj,rijv,enuc,itype,se_int_control,se_taper,error) do_ewald_gks=.FALSE., integral_screening=se_int_control%integral_screening,& max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.) CALL ssss_nucint_num(sepi,sepj,rij,ssss=ssss,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control_off,error=error) + se_int_control=se_int_control_off) ! In case let's compute the short-range part of the (ss|ss) integral IF (se_int_control%shortrange) THEN CALL ssss_nucint_num(sepi,sepj,rij,ssss=ssss_sr,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control,error=error) + se_int_control=se_int_control) ELSE ssss_sr = ssss END IF @@ -707,17 +694,15 @@ END SUBROUTINE corecore_num !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) !> \param se_taper ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 05.2009 ! ***************************************************************************** - SUBROUTINE corecore_el_num(sepi,sepj,rijv,enuc,itype,se_int_control,se_taper,error) + SUBROUTINE corecore_el_num(sepi,sepj,rijv,enuc,itype,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rijv REAL(dp), INTENT(OUT) :: enuc INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore_el_num', & routineP = moduleN//':'//routineN @@ -733,11 +718,11 @@ SUBROUTINE corecore_el_num(sepi,sepj,rijv,enuc,itype,se_int_control,se_taper,err do_ewald_gks=.FALSE., integral_screening=se_int_control%integral_screening,& max_multipole=do_multipole_none, pc_coulomb_int=.FALSE.) CALL ssss_nucint_num(sepi,sepj,rij,ssss=ssss,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control_off,error=error) + se_int_control=se_int_control_off) ! In case let's compute the short-range part of the (ss|ss) integral IF (se_int_control%shortrange.OR.se_int_control%pc_coulomb_int) THEN CALL ssss_nucint_num(sepi,sepj,rij,ssss=ssss_sr,itype=itype,se_taper=se_taper,& - se_int_control=se_int_control,error=error) + se_int_control=se_int_control) ELSE ssss_sr = ssss END IF @@ -759,19 +744,17 @@ END SUBROUTINE corecore_el_num !> \param se_taper ... !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) -!> \param error ... !> \par History !> 03.2008 created [tlaino] !> \author Teodoro Laino - Zurich University ! ***************************************************************************** - SUBROUTINE ssss_nucint_num(sepi, sepj, rij, ssss, itype, se_taper, se_int_control, error) + SUBROUTINE ssss_nucint_num(sepi, sepj, rij, ssss, itype, se_taper, se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), INTENT(OUT) :: ssss INTEGER, INTENT(IN) :: itype TYPE(se_taper_type), POINTER :: se_taper TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ssss_nucint_num', & routineP = moduleN//':'//routineN @@ -785,21 +768,20 @@ SUBROUTINE ssss_nucint_num(sepi, sepj, rij, ssss, itype, se_taper, se_int_contro ! Computing Tapering function ft = 1.0_dp IF (itype /=do_method_pchg) THEN - ft = taper_eval(se_taper%taper, rij, error) + ft = taper_eval(se_taper%taper, rij) END IF ! In case of dumped integrals compute an additional taper term IF (se_int_control%integral_screening==do_se_IS_kdso_d) THEN se_int_screen%ft = 1.0_dp IF (itype /=do_method_pchg) THEN - se_int_screen%ft = taper_eval(se_taper%taper_add, rij, error) + se_int_screen%ft = taper_eval(se_taper%taper_add, rij) END IF END IF ! Contribution from the sp shells CALL nucint_sp_num(sepi, sepj, rij, ssss=ssss, itype=itype,& - se_int_control=se_int_control,se_int_screen=se_int_screen,& - error=error) + se_int_control=se_int_control,se_int_screen=se_int_screen) ! Tapering the integrals ssss = ft*ssss @@ -818,19 +800,17 @@ END SUBROUTINE ssss_nucint_num !> \param se_taper ... !> \param se_int_control input parameters that control the calculation of SE !> integrals (shortrange, R3 residual, screening type) -!> \param error ... !> \par History !> 03.2008 created [tlaino] !> \author Teodoro Laino - Zurich University ! ***************************************************************************** - SUBROUTINE core_nucint_num(sepi, sepj, rij, core, itype, se_taper, se_int_control, error) + SUBROUTINE core_nucint_num(sepi, sepj, rij, core, itype, se_taper, se_int_control) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(10, 2), INTENT(OUT) :: core INTEGER, INTENT(IN) :: itype TYPE(se_taper_type), POINTER :: se_taper TYPE(se_int_control_type), INTENT(IN) :: se_int_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'core_nucint_num', & routineP = moduleN//':'//routineN @@ -844,25 +824,25 @@ SUBROUTINE core_nucint_num(sepi, sepj, rij, core, itype, se_taper, se_int_contro ! Computing the Tapering function ft = 1.0_dp IF (itype /=do_method_pchg) THEN - ft = taper_eval(se_taper%taper, rij, error) + ft = taper_eval(se_taper%taper, rij) END IF ! In case of dumped integrals compute an additional taper term IF (se_int_control%integral_screening==do_se_IS_kdso_d) THEN se_int_screen%ft = 1.0_dp IF (itype /=do_method_pchg) THEN - se_int_screen%ft = taper_eval(se_taper%taper_add, rij, error) + se_int_screen%ft = taper_eval(se_taper%taper_add, rij) END IF END IF ! Contribution from the sp shells CALL nucint_sp_num(sepi, sepj, rij, core=core, itype=itype,& - se_int_control=se_int_control,se_int_screen=se_int_screen, error=error) + se_int_control=se_int_control,se_int_screen=se_int_screen) IF (sepi%dorb.OR.sepj%dorb) THEN ! Compute the contribution from d shells CALL nucint_d_num(sepi, sepj, rij, core, itype, se_int_control,& - se_int_screen, error=error) + se_int_screen) END IF ! Tapering the integrals @@ -885,7 +865,6 @@ END SUBROUTINE core_nucint_num !> \param itype ... !> \param se_int_control ... !> \param se_int_screen ... -!> \param error ... !> \par History !> Teodoro Laino (04.2008) [tlaino] - University of Zurich : new driver !> for computing integrals @@ -894,7 +873,7 @@ END SUBROUTINE core_nucint_num ! ***************************************************************************** SUBROUTINE nucint_sp_num( sepi, sepj, rij, ssss, core, itype, se_int_control,& - se_int_screen, error) + se_int_screen) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), INTENT(INOUT), OPTIONAL :: ssss @@ -903,7 +882,6 @@ SUBROUTINE nucint_sp_num( sepi, sepj, rij, ssss, core, itype, se_int_control,& INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nucint_sp_num', & routineP = moduleN//':'//routineN @@ -977,12 +955,11 @@ END SUBROUTINE nucint_sp_num !> integrals (shortrange, R3 residual, screening type) !> \param se_int_screen contains information for computing the screened !> integrals KDSO-D -!> \param error ... !> \author !> Teodoro Laino (03.2008) [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE nucint_d_num( sepi, sepj, rij, core, itype, se_int_control, & - se_int_screen, error) + se_int_screen) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), INTENT(IN) :: rij REAL(dp), DIMENSION(10, 2), & @@ -990,7 +967,6 @@ SUBROUTINE nucint_d_num( sepi, sepj, rij, core, itype, se_int_control, & INTEGER, INTENT(IN) :: itype TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nucint_d_num', & routineP = moduleN//':'//routineN @@ -1055,9 +1031,8 @@ END SUBROUTINE nucint_d_num !> \param delta ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE drotint_num(sepi,sepj,r,dw,delta,se_int_control,se_taper, error) + SUBROUTINE drotint_num(sepi,sepj,r,dw,delta,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: r REAL(dp), DIMENSION(3, 2025), & @@ -1065,7 +1040,6 @@ SUBROUTINE drotint_num(sepi,sepj,r,dw,delta,se_int_control,se_taper, error) REAL(dp), INTENT(IN) :: delta TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'drotint_num', & routineP = moduleN//':'//routineN @@ -1080,9 +1054,9 @@ SUBROUTINE drotint_num(sepi,sepj,r,dw,delta,se_int_control,se_taper, error) DO i=1,3 rr=r rr(i)=rr(i)+delta - CALL rotint_num(sepi,sepj,rr,wp,se_int_control,se_taper=se_taper,error=error) + CALL rotint_num(sepi,sepj,rr,wp,se_int_control,se_taper=se_taper) rr(i)=rr(i)-2._dp*delta - CALL rotint_num(sepi,sepj,rr,wm,se_int_control,se_taper=se_taper,error=error) + CALL rotint_num(sepi,sepj,rr,wm,se_int_control,se_taper=se_taper) DO j = 1, nsize dw(i,j) = od * (wp(j) - wm(j)) END DO @@ -1101,9 +1075,8 @@ END SUBROUTINE drotint_num !> \param delta ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE drotnuc_num(sepi,sepj,r,de1b,de2a,itype,delta,se_int_control,se_taper,error) + SUBROUTINE drotnuc_num(sepi,sepj,r,de1b,de2a,itype,delta,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: r REAL(dp), DIMENSION(3, 45), & @@ -1112,7 +1085,6 @@ SUBROUTINE drotnuc_num(sepi,sepj,r,de1b,de2a,itype,delta,se_int_control,se_taper REAL(dp), INTENT(IN) :: delta TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'drotnuc_num', & routineP = moduleN//':'//routineN @@ -1130,9 +1102,9 @@ SUBROUTINE drotnuc_num(sepi,sepj,r,de1b,de2a,itype,delta,se_int_control,se_taper DO i=1,3 rr=r rr(i)=rr(i)+delta - CALL rotnuc_num(sepi,sepj,rr,e1p,e2p,itype,se_int_control,se_taper=se_taper,error=error) + CALL rotnuc_num(sepi,sepj,rr,e1p,e2p,itype,se_int_control,se_taper=se_taper) rr(i)=rr(i)-2._dp*delta - CALL rotnuc_num(sepi,sepj,rr,e1m,e2m,itype,se_int_control,se_taper=se_taper,error=error) + CALL rotnuc_num(sepi,sepj,rr,e1m,e2m,itype,se_int_control,se_taper=se_taper) IF (l_de1b) THEN DO j = 1, sepi%atm_int_size de1b(i,j) = od * (e1p(j) - e1m(j)) @@ -1156,9 +1128,8 @@ END SUBROUTINE drotnuc_num !> \param delta ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dcorecore_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_taper,error) + SUBROUTINE dcorecore_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: r REAL(dp), DIMENSION(3), INTENT(OUT) :: denuc @@ -1166,7 +1137,6 @@ SUBROUTINE dcorecore_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_taper,e REAL(dp), INTENT(IN) :: delta TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dcorecore_num', & routineP = moduleN//':'//routineN @@ -1179,9 +1149,9 @@ SUBROUTINE dcorecore_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_taper,e DO i=1,3 rr=r rr(i)=rr(i)+delta - CALL corecore_num(sepi,sepj,rr,enucp,itype,se_int_control,se_taper=se_taper,error=error) + CALL corecore_num(sepi,sepj,rr,enucp,itype,se_int_control,se_taper=se_taper) rr(i)=rr(i)-2._dp*delta - CALL corecore_num(sepi,sepj,rr,enucm,itype,se_int_control,se_taper=se_taper,error=error) + CALL corecore_num(sepi,sepj,rr,enucm,itype,se_int_control,se_taper=se_taper) denuc(i) = od * ( enucp - enucm ) END DO END SUBROUTINE dcorecore_num @@ -1196,9 +1166,8 @@ END SUBROUTINE dcorecore_num !> \param delta ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE dcorecore_el_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_taper,error) + SUBROUTINE dcorecore_el_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: r REAL(dp), DIMENSION(3), INTENT(OUT) :: denuc @@ -1206,7 +1175,6 @@ SUBROUTINE dcorecore_el_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_tape REAL(dp), INTENT(IN) :: delta TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dcorecore_el_num', & routineP = moduleN//':'//routineN @@ -1219,9 +1187,9 @@ SUBROUTINE dcorecore_el_num(sepi,sepj,r,denuc,itype,delta,se_int_control,se_tape DO i=1,3 rr=r rr(i)=rr(i)+delta - CALL corecore_el_num(sepi,sepj,rr,enucp,itype,se_int_control,se_taper=se_taper,error=error) + CALL corecore_el_num(sepi,sepj,rr,enucp,itype,se_int_control,se_taper=se_taper) rr(i)=rr(i)-2._dp*delta - CALL corecore_el_num(sepi,sepj,rr,enucm,itype,se_int_control,se_taper=se_taper,error=error) + CALL corecore_el_num(sepi,sepj,rr,enucm,itype,se_int_control,se_taper=se_taper) denuc(i) = od * ( enucp - enucm ) END DO END SUBROUTINE dcorecore_el_num diff --git a/src/semi_empirical_int_utils.F b/src/semi_empirical_int_utils.F index 14a11f57e0..bc9db07cff 100644 --- a/src/semi_empirical_int_utils.F +++ b/src/semi_empirical_int_utils.F @@ -58,20 +58,18 @@ MODULE semi_empirical_int_utils !> \param se_int_control ... !> \param se_int_screen ... !> \param itype ... -!> \param error ... !> \retval res ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** FUNCTION ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& - se_int_screen, itype, error) RESULT(res) + se_int_screen, itype) RESULT(res) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ij, kl, li, lj, lk, ll, ic REAL(KIND=dp), INTENT(IN) :: r TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen INTEGER, INTENT(IN) :: itype - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'ijkl_sp', & @@ -80,14 +78,14 @@ FUNCTION ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& res = ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, se_int_control%shortrange,& se_int_control%pc_coulomb_int, se_int_control%max_multipole,& - itype, charg_int_nri, error) + itype, charg_int_nri) ! If only the shortrange component is requested we can skip the rest IF ((.NOT.se_int_control%pc_coulomb_int).AND.(itype/=do_method_pchg)) THEN ! Handle the 1/r^3 term, this term is ALWAYS false for KDSO-D integrals IF (se_int_control%shortrange.AND.se_int_control%do_ewald_r3) THEN res = res - ijkl_low_3(sepi, sepj, ij, kl, li, lj, lk, ll, ic,& - itype, charg_int_3, error) + itype, charg_int_3) END IF END IF END FUNCTION ijkl_sp @@ -112,20 +110,18 @@ END FUNCTION ijkl_sp !> \param se_int_control ... !> \param se_int_screen ... !> \param itype ... -!> \param error ... !> \retval res ... !> \date 05.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** FUNCTION d_ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& - se_int_screen, itype, error) RESULT(res) + se_int_screen, itype) RESULT(res) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ij, kl, li, lj, lk, ll, ic REAL(KIND=dp), INTENT(IN) :: r TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen INTEGER, INTENT(IN) :: itype - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'd_ijkl_sp', & @@ -137,12 +133,12 @@ FUNCTION d_ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& res = ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, .FALSE.,& se_int_control%pc_coulomb_int, se_int_control%max_multipole,& - itype, dcharg_int_nri, error) + itype, dcharg_int_nri) IF (.NOT.se_int_control%pc_coulomb_int) THEN dfs = ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, .FALSE., .FALSE., & - se_int_control%max_multipole, itype, dcharg_int_nri_fs, error) + se_int_control%max_multipole, itype, dcharg_int_nri_fs) res = res + dfs*se_int_screen%dft ! In case we need the shortrange part we have to evaluate an additional derivative @@ -150,7 +146,7 @@ FUNCTION d_ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& IF (se_int_control%shortrange) THEN srd = ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, .FALSE., .TRUE., & - se_int_control%max_multipole, itype, dcharg_int_nri, error) + se_int_control%max_multipole, itype, dcharg_int_nri) res = res - srd END IF END IF @@ -158,7 +154,7 @@ FUNCTION d_ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& res = ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, se_int_control%shortrange,& se_int_control%pc_coulomb_int, se_int_control%max_multipole,& - itype, dcharg_int_nri, error) + itype, dcharg_int_nri) END IF ! If only the shortrange component is requested we can skip the rest @@ -166,7 +162,7 @@ FUNCTION d_ijkl_sp(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& ! Handle the 1/r^3 term, this term is ALWAYS false for KDSO-D integrals IF (se_int_control%shortrange.AND.se_int_control%do_ewald_r3) THEN res = res - ijkl_low_3(sepi, sepj, ij, kl, li, lj, lk, ll, ic,& - itype, dcharg_int_3, error) + itype, dcharg_int_3) END IF END IF @@ -197,13 +193,12 @@ END FUNCTION d_ijkl_sp !> \param max_multipole ... !> \param itype ... !> \param eval a function without explicit interface -!> \param error ... !> \retval res ... !> \date 05.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** FUNCTION ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& - iscreen, shortrange, pc_coulomb_int, max_multipole, itype, eval, error) RESULT(res) + iscreen, shortrange, pc_coulomb_int, max_multipole, itype, eval) RESULT(res) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ij, kl, li, lj, lk, ll, ic REAL(KIND=dp), INTENT(IN) :: r @@ -211,9 +206,7 @@ FUNCTION ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& INTEGER, INTENT(IN) :: iscreen LOGICAL, INTENT(IN) :: shortrange, pc_coulomb_int INTEGER, INTENT(IN) :: max_multipole, itype - REAL(KIND=dp) :: eval - TYPE(cp_error_type), INTENT(inout) :: error - REAL(KIND=dp) :: res + REAL(KIND=dp) :: eval, res CHARACTER(len=*), PARAMETER :: routineN = 'ijkl_sp_low', & routineP = moduleN//':'//routineN @@ -286,7 +279,7 @@ FUNCTION ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& DO m = -lmin, lmin ccc = clm_sp(ij, l1, m) * clm_sp(kl, l2, m) IF (ABS(ccc) > EPSILON(0.0_dp)) THEN - chrg = eval(r, l1, l2, clm_sp(ij, l1, m), clm_sp(kl, l2, m), dij, dkl, add, fact_screen, error) + chrg = eval(r, l1, l2, clm_sp(ij, l1, m), clm_sp(kl, l2, m), dij, dkl, add, fact_screen) s1 = s1 + chrg END IF END DO @@ -318,7 +311,7 @@ FUNCTION ijkl_sp_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& DO m = -lmin, lmin ccc = clm_sp(ij, l1, m) * clm_sp(kl, l2, m) IF (ABS(ccc) > EPSILON(0.0_dp)) THEN - chrg = eval(r, l1, l2, clm_sp(ij, l1, m), clm_sp(kl, l2, m), dij, dkl, add, fact_screen, error) + chrg = eval(r, l1, l2, clm_sp(ij, l1, m), clm_sp(kl, l2, m), dij, dkl, add, fact_screen) s1 = s1 + chrg END IF END DO @@ -349,16 +342,14 @@ END FUNCTION ijkl_sp_low !> \param db_i ... !> \param add0 ... !> \param fact_screen ... -!> \param error ... !> \retval charg ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION charg_int_nri(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen, error) RESULT(charg) + FUNCTION charg_int_nri(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1_i, l2_i, m1_i, m2_i REAL(KIND=dp), INTENT(in) :: da_i, db_i, add0, fact_screen - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'charg_int_nri', & @@ -534,7 +525,7 @@ FUNCTION charg_int_nri(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen, RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION charg_int_nri ! ***************************************************************************** @@ -558,16 +549,14 @@ END FUNCTION charg_int_nri !> \param db_i ... !> \param add0 ... !> \param fact_screen ... -!> \param error ... !> \retval charg ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION dcharg_int_nri(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen, error) RESULT(charg) + FUNCTION dcharg_int_nri(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1_i, l2_i, m1_i, m2_i REAL(KIND=dp), INTENT(in) :: da_i, db_i, add0, fact_screen - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'dcharg_int_nri', & @@ -743,7 +732,7 @@ FUNCTION dcharg_int_nri(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION dcharg_int_nri ! ***************************************************************************** @@ -768,16 +757,14 @@ END FUNCTION dcharg_int_nri !> \param db_i ... !> \param add0 ... !> \param fact_screen ... -!> \param error ... !> \retval charg ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION dcharg_int_nri_fs(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen, error) RESULT(charg) + FUNCTION dcharg_int_nri_fs(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_screen) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1_i, l2_i, m1_i, m2_i REAL(KIND=dp), INTENT(in) :: da_i, db_i, add0, fact_screen - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'dcharg_int_nri_fs', & @@ -955,7 +942,7 @@ FUNCTION dcharg_int_nri_fs(r, l1_i, l2_i, m1_i, m2_i, da_i, db_i, add0, fact_scr RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION dcharg_int_nri_fs ! ***************************************************************************** @@ -984,20 +971,18 @@ END FUNCTION dcharg_int_nri_fs !> \param se_int_control ... !> \param se_int_screen ... !> \param itype ... -!> \param error ... !> \retval res ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** FUNCTION ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control, & - se_int_screen, itype, error) RESULT(res) + se_int_screen, itype) RESULT(res) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ij, kl, li, lj, lk, ll, ic REAL(KIND=dp), INTENT(IN) :: r TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen INTEGER, INTENT(IN) :: itype - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'ijkl_d', & @@ -1006,14 +991,14 @@ FUNCTION ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control, & res = ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, se_int_control%shortrange,& se_int_control%pc_coulomb_int, se_int_control%max_multipole,& - itype, charg_int_ri, error) + itype, charg_int_ri) ! If only the shortrange component is requested we can skip the rest IF ((.NOT.se_int_control%pc_coulomb_int).AND.(itype/=do_method_pchg)) THEN ! Handle the 1/r^3 term, this term is ALWAYS false for KDSO-D integrals IF (se_int_control%shortrange.AND.se_int_control%do_ewald_r3) THEN res = res - ijkl_low_3(sepi, sepj, ij, kl, li, lj, lk, ll, ic,& - itype, charg_int_3, error) + itype, charg_int_3) END IF END IF END FUNCTION ijkl_d @@ -1044,20 +1029,18 @@ END FUNCTION ijkl_d !> \param se_int_control ... !> \param se_int_screen ... !> \param itype ... -!> \param error ... !> \retval res ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** FUNCTION d_ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& - se_int_screen, itype, error) RESULT(res) + se_int_screen, itype) RESULT(res) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ij, kl, li, lj, lk, ll, ic REAL(KIND=dp), INTENT(IN) :: r TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_int_screen_type), INTENT(IN) :: se_int_screen INTEGER, INTENT(IN) :: itype - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'd_ijkl_d', & @@ -1069,12 +1052,12 @@ FUNCTION d_ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& res = ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, .FALSE.,& se_int_control%pc_coulomb_int, se_int_control%max_multipole,& - itype, dcharg_int_ri, error) + itype, dcharg_int_ri) IF (.NOT.se_int_control%pc_coulomb_int) THEN dfs = ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, .FALSE., .FALSE.,& - se_int_control%max_multipole, itype, dcharg_int_ri_fs, error) + se_int_control%max_multipole, itype, dcharg_int_ri_fs) res = res + dfs*se_int_screen%dft ! In case we need the shortrange part we have to evaluate an additional derivative @@ -1082,7 +1065,7 @@ FUNCTION d_ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& IF (se_int_control%shortrange) THEN srd = ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, .FALSE., .TRUE.,& - se_int_control%max_multipole, itype, dcharg_int_ri, error) + se_int_control%max_multipole, itype, dcharg_int_ri) res = res - srd END IF END IF @@ -1090,7 +1073,7 @@ FUNCTION d_ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& res = ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& se_int_control%integral_screening, se_int_control%shortrange,& se_int_control%pc_coulomb_int, se_int_control%max_multipole,& - itype, dcharg_int_ri, error) + itype, dcharg_int_ri) END IF ! If only the shortrange component is requested we can skip the rest @@ -1098,7 +1081,7 @@ FUNCTION d_ijkl_d(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_control,& ! Handle the 1/r^3 term, this term is ALWAYS false for KDSO-D integrals IF (se_int_control%shortrange.AND.se_int_control%do_ewald_r3) THEN res = res - ijkl_low_3(sepi, sepj, ij, kl, li, lj, lk, ll, ic,& - itype, dcharg_int_3, error) + itype, dcharg_int_3) END IF END IF @@ -1134,13 +1117,12 @@ END FUNCTION d_ijkl_d !> \param max_multipole ... !> \param itype ... !> \param eval a function without explicit interface -!> \param error ... !> \retval res ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** FUNCTION ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& - iscreen, shortrange, pc_coulomb_int, max_multipole, itype, eval, error) RESULT(res) + iscreen, shortrange, pc_coulomb_int, max_multipole, itype, eval) RESULT(res) TYPE(semi_empirical_type), POINTER :: sepi, sepj INTEGER, INTENT(IN) :: ij, kl, li, lj, lk, ll, ic REAL(KIND=dp), INTENT(IN) :: r @@ -1148,9 +1130,7 @@ FUNCTION ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& INTEGER, INTENT(IN) :: iscreen LOGICAL, INTENT(IN) :: shortrange, pc_coulomb_int INTEGER, INTENT(IN) :: max_multipole, itype - REAL(KIND=dp) :: eval - TYPE(cp_error_type), INTENT(inout) :: error - REAL(KIND=dp) :: res + REAL(KIND=dp) :: eval, res CHARACTER(len=*), PARAMETER :: routineN = 'ijkl_d_low', & routineP = moduleN//':'//routineN @@ -1222,7 +1202,7 @@ FUNCTION ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& ccc = clm_d(ij, l1, m) * clm_d(kl, l2, m) IF (ABS(ccc) > EPSILON(0.0_dp)) THEN mm = ABS (m) - chrg = eval(r, l1, l2, mm, dij, dkl, add, fact_screen, error) + chrg = eval(r, l1, l2, mm, dij, dkl, add, fact_screen) s1 = s1 + chrg * ccc END IF END DO @@ -1255,7 +1235,7 @@ FUNCTION ijkl_d_low(sepi, sepj, ij, kl, li, lj, lk, ll, ic, r, se_int_screen,& ccc = clm_d(ij, l1, m) * clm_d(kl, l2, m) IF (ABS(ccc) > EPSILON(0.0_dp)) THEN mm = ABS (m) - chrg = eval(r, l1, l2, mm, dij, dkl, add, fact_screen, error) + chrg = eval(r, l1, l2, mm, dij, dkl, add, fact_screen) s1 = s1 + chrg * ccc END IF END DO @@ -1285,16 +1265,14 @@ END FUNCTION ijkl_d_low !> \param db_i ... !> \param add0 ... !> \param fact_screen ... -!> \param error ... !> \retval charg ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION charg_int_ri(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen, error) RESULT(charg) + FUNCTION charg_int_ri(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1_i, l2_i, m REAL(KIND=dp), INTENT(in) :: da_i, db_i, add0, fact_screen - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'charg_int_ri', & @@ -1404,7 +1382,7 @@ FUNCTION charg_int_ri(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen, error) RE RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION charg_int_ri ! ***************************************************************************** @@ -1426,16 +1404,14 @@ END FUNCTION charg_int_ri !> \param db_i ... !> \param add0 ... !> \param fact_screen ... -!> \param error ... !> \retval charg ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION dcharg_int_ri(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen, error) RESULT(charg) + FUNCTION dcharg_int_ri(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1_i, l2_i, m REAL(KIND=dp), INTENT(in) :: da_i, db_i, add0, fact_screen - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'dcharg_int_ri', & @@ -1546,7 +1522,7 @@ FUNCTION dcharg_int_ri(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen, error) R RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION dcharg_int_ri ! ***************************************************************************** @@ -1569,16 +1545,14 @@ END FUNCTION dcharg_int_ri !> \param db_i ... !> \param add0 ... !> \param fact_screen ... -!> \param error ... !> \retval charg ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION dcharg_int_ri_fs(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen, error) RESULT(charg) + FUNCTION dcharg_int_ri_fs(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen) RESULT(charg) REAL(KIND=dp), INTENT(in) :: r INTEGER, INTENT(in) :: l1_i, l2_i, m REAL(KIND=dp), INTENT(in) :: da_i, db_i, add0, fact_screen - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: charg CHARACTER(len=*), PARAMETER :: routineN = 'dcharg_int_ri_fs', & @@ -1692,7 +1666,7 @@ FUNCTION dcharg_int_ri_fs(r, l1_i, l2_i, m, da_i, db_i, add0, fact_screen, error RETURN END IF ! We should NEVER reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END FUNCTION dcharg_int_ri_fs ! ***************************************************************************** @@ -1707,12 +1681,11 @@ END FUNCTION dcharg_int_ri_fs !> \param do_derivatives ... !> \param do_invert ... !> \param debug_invert ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** RECURSIVE SUBROUTINE rotmat (sepi, sepj, rjiv, r, ij_matrix, do_derivatives,& - do_invert, debug_invert, error) + do_invert, debug_invert) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rjiv REAL(KIND=dp), INTENT(IN) :: r @@ -1720,7 +1693,6 @@ RECURSIVE SUBROUTINE rotmat (sepi, sepj, rjiv, r, ij_matrix, do_derivatives,& LOGICAL, INTENT(IN) :: do_derivatives LOGICAL, INTENT(OUT), OPTIONAL :: do_invert LOGICAL, INTENT(IN), OPTIONAL :: debug_invert - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotmat', & routineP = moduleN//':'//routineN @@ -1739,7 +1711,7 @@ RECURSIVE SUBROUTINE rotmat (sepi, sepj, rjiv, r, ij_matrix, do_derivatives,& REAL(KIND=dp), DIMENSION(5, 5) :: d failure = .FALSE. - CPPostcondition(ASSOCIATED(ij_matrix),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ij_matrix),cp_failure_level,routineP,failure) IF (PRESENT(do_invert)) do_invert = .FALSE. IF ((sepi%natorb>1).OR.(sepj%natorb>1)) THEN ! Compute Geomtric data and interatomic distance @@ -1782,7 +1754,7 @@ RECURSIVE SUBROUTINE rotmat (sepi, sepj, rjiv, r, ij_matrix, do_derivatives,& IF (dbg_inv) THEN ! When debugging the derivatives of the rotation matrix we must possibly force ! the inversion of the reference frame - CPPostcondition(.NOT.do_derivatives,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.do_derivatives,cp_failure_level,routineP,failure) imap(1) = 3 imap(2) = 2 imap(3) = 1 @@ -1937,7 +1909,7 @@ RECURSIVE SUBROUTINE rotmat (sepi, sepj, rjiv, r, ij_matrix, do_derivatives,& IF (do_derivatives) THEN ! This condition is necessary because derivatives uses the invertion of the ! axis for treating the divergence point along z-axis - CPPostcondition(eval,cp_failure_level,routineP,error,failure) + CPPostcondition(eval,cp_failure_level,routineP,failure) x11_d = 0.0_dp; x11_d(1) = 1.0_dp x22_d = 0.0_dp; x22_d(2) = 1.0_dp x33_d = 0.0_dp; x33_d(3) = 1.0_dp @@ -2098,7 +2070,7 @@ RECURSIVE SUBROUTINE rotmat (sepi, sepj, rjiv, r, ij_matrix, do_derivatives,& END DO END IF IF (debug_this_module) THEN - CALL check_rotmat_der(sepi, sepj, rjiv, ij_matrix, do_invert=do_invert, error=error) + CALL check_rotmat_der(sepi, sepj, rjiv, ij_matrix, do_invert=do_invert) END IF END IF END IF @@ -2125,13 +2097,11 @@ END SUBROUTINE rotmat !> \param v_d ... !> \param logv_d ... !> \param drij ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** RECURSIVE SUBROUTINE rot_2el_2c_first (sepi, sepj, rijv, se_int_control, se_taper,& - invert, ii, kk, rep, logv, ij_matrix, v, lgrad, rep_d, v_d, logv_d, drij,& - error) + invert, ii, kk, rep, logv, ij_matrix, v, lgrad, rep_d, v_d, logv_d, drij) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: rijv TYPE(se_int_control_type), INTENT(IN) :: se_int_control @@ -2153,7 +2123,6 @@ RECURSIVE SUBROUTINE rot_2el_2c_first (sepi, sepj, rijv, se_int_control, se_tape INTENT(OUT), OPTIONAL :: logv_d REAL(KIND=dp), DIMENSION(3), & INTENT(IN), OPTIONAL :: drij - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rot_2el_2c_first', & routineP = moduleN//':'//routineN @@ -2165,10 +2134,10 @@ RECURSIVE SUBROUTINE rot_2el_2c_first (sepi, sepj, rijv, se_int_control, se_tape failure = .FALSE. IF (lgrad) THEN - CPPostcondition(PRESENT( rep_d),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT( v_d),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(logv_d),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT( drij),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT( rep_d),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT( v_d),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(logv_d),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT( drij),cp_failure_level,routineP,failure) END IF limkl = indexb(kk, kk) DO k = 1, limkl @@ -2456,7 +2425,7 @@ RECURSIVE SUBROUTINE rot_2el_2c_first (sepi, sepj, rijv, se_int_control, se_tape END DO END DO IF (debug_this_module) THEN - CALL rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, invert, ii, kk, v_d, error) + CALL rot_2el_2c_first_debug(sepi, sepj, rijv, se_int_control, se_taper, invert, ii, kk, v_d) END IF END IF END SUBROUTINE rot_2el_2c_first @@ -2472,11 +2441,10 @@ END SUBROUTINE rot_2el_2c_first !> \param ww_dy ... !> \param ww_dz ... !> \param dw ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE store_2el_2c_diag (limij, limkl, ww, w, ww_dx, ww_dy, ww_dz, dw, error) + SUBROUTINE store_2el_2c_diag (limij, limkl, ww, w, ww_dx, ww_dy, ww_dz, dw) INTEGER, INTENT(IN) :: limij, limkl REAL(KIND=dp), DIMENSION(limkl, limij), & @@ -2487,7 +2455,6 @@ SUBROUTINE store_2el_2c_diag (limij, limkl, ww, w, ww_dx, ww_dy, ww_dz, dw, erro INTENT(IN), OPTIONAL :: ww_dx, ww_dy, ww_dz REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT), OPTIONAL :: dw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'store_2el_2c_diag', & routineP = moduleN//':'//routineN @@ -2514,7 +2481,7 @@ SUBROUTINE store_2el_2c_diag (limij, limkl, ww, w, ww_dx, ww_dy, ww_dz, dw, erro END DO END DO ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE store_2el_2c_diag diff --git a/src/semi_empirical_integrals.F b/src/semi_empirical_integrals.F index 0850dccde0..61a9dfdf5a 100644 --- a/src/semi_empirical_integrals.F +++ b/src/semi_empirical_integrals.F @@ -64,11 +64,10 @@ MODULE semi_empirical_integrals !> \param se_int_control ... !> \param se_taper ... !> \param store_int_env ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE rotint(sepi,sepj,rij,w,anag,se_int_control,se_taper,store_int_env,error) + SUBROUTINE rotint(sepi,sepj,rij,w,anag,se_int_control,se_taper,store_int_env) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(2025), INTENT(OUT) :: w @@ -76,7 +75,6 @@ SUBROUTINE rotint(sepi,sepj,rij,w,anag,se_int_control,se_taper,store_int_env,err TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotint', & routineP = moduleN//':'//routineN @@ -106,12 +104,12 @@ SUBROUTINE rotint(sepi,sepj,rij,w,anag,se_int_control,se_taper,store_int_env,err END IF ! Compute Integrals IF (se_int_control%integral_screening == do_se_IS_slater ) THEN - CALL rotint_gks (sepi,sepj,rij,w,se_int_control=se_int_control,error=error) + CALL rotint_gks (sepi,sepj,rij,w,se_int_control=se_int_control) ELSE IF (anag) THEN - CALL rotint_ana (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL rotint_ana (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper) ELSE - CALL rotint_num (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL rotint_num (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper) END IF END IF ! Store integrals if we did not go overflow @@ -135,14 +133,14 @@ SUBROUTINE rotint(sepi,sepj,rij,w,anag,se_int_control,se_taper,store_int_env,err store_int_env%integral_containers(nbits), & eps_storage, 1.0_dp,& store_int_env%memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) buffer_left = buffer_left - buffer_size buffer_start = buffer_start + buffer_size END DO ELSE ! Skip compression memory_usage = store_int_env%memory_parameter%actual_memory_usage - CPPrecondition((nints/1.2_dp)<=HUGE(0)-memory_usage,cp_failure_level,routineP,error,failure) + CPPrecondition((nints/1.2_dp)<=HUGE(0)-memory_usage,cp_failure_level,routineP,failure) IF (memory_usage+nints>SIZE(store_int_env%uncompressed_container)) THEN new_size = INT((memory_usage+nints)*1.2_dp) CALL reallocate(store_int_env%uncompressed_container, 1, new_size) @@ -186,24 +184,24 @@ SUBROUTINE rotint(sepi,sepj,rij,w,anag,se_int_control,se_taper,store_int_env,err END IF ELSE IF (se_int_control%integral_screening == do_se_IS_slater ) THEN - CALL rotint_gks (sepi,sepj,rij,w,se_int_control=se_int_control,error=error) + CALL rotint_gks (sepi,sepj,rij,w,se_int_control=se_int_control) ELSE IF (anag) THEN - CALL rotint_ana (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL rotint_ana (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper) ELSE - CALL rotint_num (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL rotint_num (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper) END IF END IF END IF END IF ELSE IF (se_int_control%integral_screening == do_se_IS_slater ) THEN - CALL rotint_gks (sepi,sepj,rij,w,se_int_control=se_int_control,error=error) + CALL rotint_gks (sepi,sepj,rij,w,se_int_control=se_int_control) ELSE IF (anag) THEN - CALL rotint_ana (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL rotint_ana (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper) ELSE - CALL rotint_num (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL rotint_num (sepi,sepj,rij,w,se_int_control=se_int_control,se_taper=se_taper) END IF END IF END IF @@ -221,11 +219,10 @@ END SUBROUTINE rotint !> \param se_int_control ... !> \param se_taper ... !> \param store_int_env ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,store_int_env,error) + SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,store_int_env) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(45), INTENT(OUT), & @@ -236,7 +233,6 @@ SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,stor TYPE(se_taper_type), POINTER :: se_taper TYPE(semi_empirical_si_type), OPTIONAL, & POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotnuc', & routineP = moduleN//':'//routineN @@ -260,7 +256,7 @@ SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,stor IF (PRESENT(e2a)) nints_2 = (sepj%natorb*(sepj%natorb+1)/2) nints = nints_1 + nints_2 ! This is the upper limit for an spd basis set - CPPrecondition(nints<=90,cp_failure_level,routineP,error,failure) + CPPrecondition(nints<=90,cp_failure_level,routineP,failure) cache_size = store_int_env%memory_parameter%cache_size eps_storage= store_int_env%memory_parameter%eps_storage_scaling IF (store_int_env%filling_containers) THEN @@ -275,14 +271,14 @@ SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,stor ! Compute Integrals IF (se_int_control%integral_screening == do_se_IS_slater ) THEN CALL rotnuc_gks (sepi,sepj,rij,e1b=e1b,e2a=e2a,& - se_int_control=se_int_control,error=error) + se_int_control=se_int_control) ELSE IF (anag) THEN CALL rotnuc_ana (sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) ELSE CALL rotnuc_num (sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) END IF END IF ! Store integrals if we did not go overflow @@ -309,14 +305,14 @@ SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,stor store_int_env%integral_containers(nbits), & eps_storage, 1.0_dp,& store_int_env%memory_parameter%actual_memory_usage, & - .FALSE., error) + .FALSE.) buffer_left = buffer_left - buffer_size buffer_start = buffer_start + buffer_size END DO ELSE ! Skip compression memory_usage = store_int_env%memory_parameter%actual_memory_usage - CPPrecondition((nints/1.2_dp)<=HUGE(0)-memory_usage,cp_failure_level,routineP,error,failure) + CPPrecondition((nints/1.2_dp)<=HUGE(0)-memory_usage,cp_failure_level,routineP,failure) IF (memory_usage+nints>SIZE(store_int_env%uncompressed_container)) THEN new_size = INT((memory_usage+nints)*1.2_dp) CALL reallocate(store_int_env%uncompressed_container, 1, new_size) @@ -363,14 +359,14 @@ SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,stor ELSE IF (se_int_control%integral_screening == do_se_IS_slater ) THEN CALL rotnuc_gks (sepi,sepj,rij,e1b=e1b,e2a=e2a,& - se_int_control=se_int_control, error=error) + se_int_control=se_int_control) ELSE IF (anag) THEN CALL rotnuc_ana (sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) ELSE CALL rotnuc_num (sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) END IF END IF END IF @@ -378,14 +374,14 @@ SUBROUTINE rotnuc (sepi,sepj,rij,e1b,e2a,itype,anag,se_int_control,se_taper,stor ELSE IF (se_int_control%integral_screening == do_se_IS_slater ) THEN CALL rotnuc_gks (sepi,sepj,rij,e1b=e1b,e2a=e2a,& - se_int_control=se_int_control, error=error) + se_int_control=se_int_control) ELSE IF (anag) THEN CALL rotnuc_ana (sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) ELSE CALL rotnuc_num (sepi, sepj, rij, e1b=e1b, e2a=e2a, itype=itype,& - se_int_control=se_int_control, se_taper=se_taper, error=error) + se_int_control=se_int_control, se_taper=se_taper) END IF END IF END IF @@ -405,11 +401,10 @@ END SUBROUTINE rotnuc !> \param anag ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \date 04.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE corecore (sepi,sepj,rij,enuc,itype,anag,se_int_control,se_taper,error) + SUBROUTINE corecore (sepi,sepj,rij,enuc,itype,anag,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), INTENT(OUT) :: enuc @@ -417,21 +412,20 @@ SUBROUTINE corecore (sepi,sepj,rij,enuc,itype,anag,se_int_control,se_taper,error LOGICAL, INTENT(IN) :: anag TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore', & routineP = moduleN//':'//routineN enuc = 0.0_dp IF (se_int_control%integral_screening == do_se_IS_slater ) THEN - CALL corecore_gks (sepi,sepj,rij,enuc=enuc,se_int_control=se_int_control,error=error) + CALL corecore_gks (sepi,sepj,rij,enuc=enuc,se_int_control=se_int_control) ELSE IF (anag) THEN CALL corecore_ana (sepi,sepj,rij,enuc=enuc,itype=itype,se_int_control=se_int_control,& - se_taper=se_taper, error=error) + se_taper=se_taper) ELSE CALL corecore_num (sepi,sepj,rij,enuc=enuc,itype=itype,se_int_control=se_int_control,& - se_taper=se_taper, error=error) + se_taper=se_taper) END IF END IF @@ -449,11 +443,10 @@ END SUBROUTINE corecore !> \param anag ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \date 05.2009 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE corecore_el (sepi,sepj,rij,enuc,itype,anag,se_int_control,se_taper,error) + SUBROUTINE corecore_el (sepi,sepj,rij,enuc,itype,anag,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), INTENT(OUT) :: enuc @@ -461,7 +454,6 @@ SUBROUTINE corecore_el (sepi,sepj,rij,enuc,itype,anag,se_int_control,se_taper,er LOGICAL, INTENT(IN) :: anag TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'corecore_el', & routineP = moduleN//':'//routineN @@ -469,10 +461,10 @@ SUBROUTINE corecore_el (sepi,sepj,rij,enuc,itype,anag,se_int_control,se_taper,er enuc = 0.0_dp IF (anag) THEN CALL corecore_el_ana (sepi,sepj,rij,enuc=enuc,itype=itype,se_int_control=se_int_control,& - se_taper=se_taper, error=error) + se_taper=se_taper) ELSE CALL corecore_el_num (sepi,sepj,rij,enuc=enuc,itype=itype,se_int_control=se_int_control,& - se_taper=se_taper, error=error) + se_taper=se_taper) END IF END SUBROUTINE corecore_el @@ -487,11 +479,10 @@ END SUBROUTINE corecore_el !> \param anag ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \date 04.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE drotint (sepi,sepj,rij,dw,delta,anag,se_int_control,se_taper, error) + SUBROUTINE drotint (sepi,sepj,rij,dw,delta,anag,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(3, 2025), & @@ -500,19 +491,18 @@ SUBROUTINE drotint (sepi,sepj,rij,dw,delta,anag,se_int_control,se_taper, error) LOGICAL, INTENT(IN) :: anag TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'drotint', & routineP = moduleN//':'//routineN dw(:,:) = 0.0_dp IF (se_int_control%integral_screening == do_se_IS_slater ) THEN - CALL drotint_gks(sepi,sepj,rij,dw=dw,se_int_control=se_int_control,error=error) + CALL drotint_gks(sepi,sepj,rij,dw=dw,se_int_control=se_int_control) ELSE IF (anag) THEN - CALL rotint_ana(sepi,sepj,rij,dw=dw, se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL rotint_ana(sepi,sepj,rij,dw=dw, se_int_control=se_int_control,se_taper=se_taper) ELSE - CALL drotint_num(sepi,sepj,rij,dw,delta,se_int_control=se_int_control,se_taper=se_taper,error=error) + CALL drotint_num(sepi,sepj,rij,dw,delta,se_int_control=se_int_control,se_taper=se_taper) END IF END IF @@ -530,11 +520,10 @@ END SUBROUTINE drotint !> \param anag ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \date 04.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE drotnuc (sepi,sepj,rij,de1b,de2a,itype,delta,anag,se_int_control,se_taper,error) + SUBROUTINE drotnuc (sepi,sepj,rij,de1b,de2a,itype,delta,anag,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(3, 45), & @@ -544,7 +533,6 @@ SUBROUTINE drotnuc (sepi,sepj,rij,de1b,de2a,itype,delta,anag,se_int_control,se_t LOGICAL, INTENT(IN) :: anag TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'drotnuc', & routineP = moduleN//':'//routineN @@ -553,14 +541,14 @@ SUBROUTINE drotnuc (sepi,sepj,rij,de1b,de2a,itype,delta,anag,se_int_control,se_t IF (PRESENT(de2a)) de2a(:,:) = 0.0_dp IF (se_int_control%integral_screening == do_se_IS_slater ) THEN CALL drotnuc_gks (sepi, sepj, rij, de1b=de1b, de2a=de2a,& - se_int_control=se_int_control,error=error) + se_int_control=se_int_control) ELSE IF (anag) THEN CALL rotnuc_ana (sepi, sepj, rij, de1b=de1b, de2a=de2a, itype=itype,& - se_int_control=se_int_control,se_taper=se_taper,error=error) + se_int_control=se_int_control,se_taper=se_taper) ELSE CALL drotnuc_num (sepi, sepj, rij, de1b=de1b, de2a=de2a, itype=itype,& - delta=delta,se_int_control=se_int_control,se_taper=se_taper,error=error) + delta=delta,se_int_control=se_int_control,se_taper=se_taper) END IF END IF @@ -577,11 +565,10 @@ END SUBROUTINE drotnuc !> \param anag ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \date 04.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE dcorecore (sepi,sepj,rij,denuc,itype,delta,anag,se_int_control,se_taper,error) + SUBROUTINE dcorecore (sepi,sepj,rij,denuc,itype,delta,anag,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(3), INTENT(OUT) :: denuc @@ -590,21 +577,20 @@ SUBROUTINE dcorecore (sepi,sepj,rij,denuc,itype,delta,anag,se_int_control,se_tap LOGICAL, INTENT(IN) :: anag TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dcorecore', & routineP = moduleN//':'//routineN denuc = 0.0_dp IF (se_int_control%integral_screening == do_se_IS_slater ) THEN - CALL corecore_gks (sepi,sepj,rij,denuc=denuc,se_int_control=se_int_control,error=error) + CALL corecore_gks (sepi,sepj,rij,denuc=denuc,se_int_control=se_int_control) ELSE IF (anag) THEN CALL corecore_ana (sepi,sepj,rij,denuc=denuc,itype=itype,se_int_control=se_int_control,& - se_taper=se_taper, error=error) + se_taper=se_taper) ELSE CALL dcorecore_num (sepi,sepj,rij,denuc=denuc,delta=delta,itype=itype,& - se_int_control=se_int_control,se_taper=se_taper, error=error) + se_int_control=se_int_control,se_taper=se_taper) END IF END IF @@ -623,11 +609,10 @@ END SUBROUTINE dcorecore !> \param anag ... !> \param se_int_control ... !> \param se_taper ... -!> \param error ... !> \date 05.2009 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE dcorecore_el (sepi,sepj,rij,denuc,itype,delta,anag,se_int_control,se_taper,error) + SUBROUTINE dcorecore_el (sepi,sepj,rij,denuc,itype,delta,anag,se_int_control,se_taper) TYPE(semi_empirical_type), POINTER :: sepi, sepj REAL(dp), DIMENSION(3), INTENT(IN) :: rij REAL(dp), DIMENSION(3), INTENT(OUT) :: denuc @@ -636,7 +621,6 @@ SUBROUTINE dcorecore_el (sepi,sepj,rij,denuc,itype,delta,anag,se_int_control,se_ LOGICAL, INTENT(IN) :: anag TYPE(se_int_control_type), INTENT(IN) :: se_int_control TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dcorecore_el', & routineP = moduleN//':'//routineN @@ -644,10 +628,10 @@ SUBROUTINE dcorecore_el (sepi,sepj,rij,denuc,itype,delta,anag,se_int_control,se_ denuc = 0.0_dp IF (anag) THEN CALL corecore_el_ana (sepi,sepj,rij,denuc=denuc,itype=itype,se_int_control=se_int_control,& - se_taper=se_taper, error=error) + se_taper=se_taper) ELSE CALL dcorecore_el_num (sepi,sepj,rij,denuc=denuc,delta=delta,itype=itype,& - se_int_control=se_int_control,se_taper=se_taper, error=error) + se_int_control=se_int_control,se_taper=se_taper) END IF END SUBROUTINE dcorecore_el diff --git a/src/semi_empirical_mpole_methods.F b/src/semi_empirical_mpole_methods.F index 52c2ae8394..e730c23e8a 100644 --- a/src/semi_empirical_mpole_methods.F +++ b/src/semi_empirical_mpole_methods.F @@ -49,16 +49,14 @@ MODULE semi_empirical_mpole_methods !> \param mpoles ... !> \param se_parameter ... !> \param method ... -!> \param error ... !> \date 09.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE semi_empirical_mpole_p_setup(mpoles, se_parameter, method, error) + SUBROUTINE semi_empirical_mpole_p_setup(mpoles, se_parameter, method) TYPE(semi_empirical_mpole_p_type), & DIMENSION(:), POINTER :: mpoles TYPE(semi_empirical_type), POINTER :: se_parameter INTEGER, INTENT(IN) :: method - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_mpole_p_setup', & routineP = moduleN//':'//routineN @@ -78,19 +76,19 @@ SUBROUTINE semi_empirical_mpole_p_setup(mpoles, se_parameter, method, error) TYPE(semi_empirical_mpole_type), POINTER :: mpole failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(mpoles),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(mpoles),cp_failure_level,routineP,failure) ! If there are atomic orbitals proceed with the expansion in multipoles natorb = se_parameter%natorb IF (natorb/=0) THEN ndim = natorb*(natorb+1)/2 - CALL semi_empirical_mpole_p_create(mpoles, ndim, error) + CALL semi_empirical_mpole_p_create(mpoles, ndim) ! Select method for multipolar expansion ! Fill in information on multipole expansion due to atomic orbitals charge ! distribution NULLIFY(mpole) - CALL amn_l(se_parameter, amn, error) + CALL amn_l(se_parameter, amn) DO i = 1, natorb DO j = 1, i ind1 = indexa(se_map_alm(i),se_map_alm(j)) @@ -140,7 +138,7 @@ SUBROUTINE semi_empirical_mpole_p_setup(mpoles, se_parameter, method, error) mpole%qs(5) = tmp * alm(ind1,2,-2) ! dxy ! Convert into cartesian components - CALL quadrupole_sph_to_cart(mpole%qc, mpole%qs, error) + CALL quadrupole_sph_to_cart(mpole%qc, mpole%qs) mpole%task(3)= .TRUE. END IF @@ -157,7 +155,7 @@ SUBROUTINE semi_empirical_mpole_p_setup(mpoles, se_parameter, method, error) IF (method == do_method_pnnl) THEN ! No d-function for Schenter type integrals - CPPostcondition(natorb<=4,cp_failure_level,routineP,error,failure) + CPPostcondition(natorb<=4,cp_failure_level,routineP,failure) M0 = 0.0_dp M1 = 0.0_dp @@ -237,15 +235,13 @@ END SUBROUTINE semi_empirical_mpole_p_setup !> \brief Transforms the quadrupole components from sphericals to cartesians !> \param qcart ... !> \param qsph ... -!> \param error ... !> \date 09.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE quadrupole_sph_to_cart(qcart, qsph, error) + SUBROUTINE quadrupole_sph_to_cart(qcart, qsph) REAL(KIND=dp), DIMENSION(3, 3), & INTENT(OUT) :: qcart REAL(KIND=dp), DIMENSION(5), INTENT(IN) :: qsph - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'quadrupole_sph_to_cart', & routineP = moduleN//':'//routineN @@ -277,14 +273,12 @@ END SUBROUTINE quadrupole_sph_to_cart !> \brief Setup NDDO multipole type !> \param nddo_mpole ... !> \param natom ... -!> \param error ... !> \date 09.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE nddo_mpole_setup(nddo_mpole, natom, error) + SUBROUTINE nddo_mpole_setup(nddo_mpole, natom) TYPE(nddo_mpole_type), POINTER :: nddo_mpole INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nddo_mpole_setup', & routineP = moduleN//':'//routineN @@ -296,23 +290,23 @@ SUBROUTINE nddo_mpole_setup(nddo_mpole, natom, error) failure = .FALSE. IF (ASSOCIATED(nddo_mpole)) THEN - CALL nddo_mpole_release(nddo_mpole, error=error) + CALL nddo_mpole_release(nddo_mpole) END IF - CALL nddo_mpole_create(nddo_mpole, error=error) + CALL nddo_mpole_create(nddo_mpole) ! Allocate Global Arrays ALLOCATE(nddo_mpole%charge(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nddo_mpole%dipole(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nddo_mpole%quadrupole(3,3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nddo_mpole%efield0( natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nddo_mpole%efield1(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(nddo_mpole%efield2(9,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) diff --git a/src/semi_empirical_mpole_types.F b/src/semi_empirical_mpole_types.F index 7676ba6b00..4e8ab05986 100644 --- a/src/semi_empirical_mpole_types.F +++ b/src/semi_empirical_mpole_types.F @@ -70,14 +70,12 @@ MODULE semi_empirical_mpole_types !> \brief Allocate semi-empirical mpole type !> \param mpole ... !> \param ndim ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 08.2008 Zurich University ! ***************************************************************************** - SUBROUTINE semi_empirical_mpole_p_create(mpole, ndim, error) + SUBROUTINE semi_empirical_mpole_p_create(mpole, ndim) TYPE(semi_empirical_mpole_p_type), & DIMENSION(:), POINTER :: mpole INTEGER, INTENT(IN) :: ndim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'semi_empirical_mpole_p_create', & @@ -87,12 +85,12 @@ SUBROUTINE semi_empirical_mpole_p_create(mpole, ndim, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(mpole),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(mpole),cp_failure_level,routineP,failure) ALLOCATE (mpole(ndim),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, ndim NULLIFY(mpole(i)%mpole) - CALL semi_empirical_mpole_create(mpole(i)%mpole, error=error) + CALL semi_empirical_mpole_create(mpole(i)%mpole) END DO END SUBROUTINE semi_empirical_mpole_p_create @@ -100,13 +98,11 @@ END SUBROUTINE semi_empirical_mpole_p_create ! ***************************************************************************** !> \brief Deallocate the semi-empirical mpole type !> \param mpole ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 08.2008 Zurich University ! ***************************************************************************** - SUBROUTINE semi_empirical_mpole_p_release(mpole, error) + SUBROUTINE semi_empirical_mpole_p_release(mpole) TYPE(semi_empirical_mpole_p_type), & DIMENSION(:), POINTER :: mpole - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'semi_empirical_mpole_p_release', & @@ -118,10 +114,10 @@ SUBROUTINE semi_empirical_mpole_p_release(mpole, error) failure = .FALSE. IF (ASSOCIATED(mpole)) THEN DO i = 1, SIZE(mpole) - CALL semi_empirical_mpole_release(mpole(i)%mpole,error=error) + CALL semi_empirical_mpole_release(mpole(i)%mpole) END DO DEALLOCATE (mpole, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE semi_empirical_mpole_p_release @@ -129,12 +125,10 @@ END SUBROUTINE semi_empirical_mpole_p_release ! ***************************************************************************** !> \brief Allocate semi-empirical mpole type !> \param mpole ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 08.2008 Zurich University ! ***************************************************************************** - SUBROUTINE semi_empirical_mpole_create(mpole, error) + SUBROUTINE semi_empirical_mpole_create(mpole) TYPE(semi_empirical_mpole_type), POINTER :: mpole - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_mpole_create', & routineP = moduleN//':'//routineN @@ -143,9 +137,9 @@ SUBROUTINE semi_empirical_mpole_create(mpole, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(mpole),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(mpole),cp_failure_level,routineP,failure) ALLOCATE (mpole,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) mpole%task = .FALSE. mpole%indi = 0 mpole%indj = 0 @@ -161,12 +155,10 @@ END SUBROUTINE semi_empirical_mpole_create ! ***************************************************************************** !> \brief Deallocate the semi-empirical mpole type !> \param mpole ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 08.2008 Zurich University ! ***************************************************************************** - SUBROUTINE semi_empirical_mpole_release(mpole, error) + SUBROUTINE semi_empirical_mpole_release(mpole) TYPE(semi_empirical_mpole_type), POINTER :: mpole - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_mpole_release', & routineP = moduleN//':'//routineN @@ -177,7 +169,7 @@ SUBROUTINE semi_empirical_mpole_release(mpole, error) failure = .FALSE. IF (ASSOCIATED(mpole)) THEN DEALLOCATE (mpole, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE semi_empirical_mpole_release @@ -185,12 +177,10 @@ END SUBROUTINE semi_empirical_mpole_release ! ***************************************************************************** !> \brief Allocate NDDO multipole type !> \param nddo_mpole ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 08.2008 Zurich University ! ***************************************************************************** - SUBROUTINE nddo_mpole_create(nddo_mpole, error) + SUBROUTINE nddo_mpole_create(nddo_mpole) TYPE(nddo_mpole_type), POINTER :: nddo_mpole - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nddo_mpole_create', & routineP = moduleN//':'//routineN @@ -199,9 +189,9 @@ SUBROUTINE nddo_mpole_create(nddo_mpole, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(nddo_mpole),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(nddo_mpole),cp_failure_level,routineP,failure) ALLOCATE (nddo_mpole,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(nddo_mpole%charge) NULLIFY(nddo_mpole%dipole) NULLIFY(nddo_mpole%quadrupole) @@ -213,12 +203,10 @@ END SUBROUTINE nddo_mpole_create ! ***************************************************************************** !> \brief Deallocate NDDO multipole type !> \param nddo_mpole ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 08.2008 Zurich University ! ***************************************************************************** - SUBROUTINE nddo_mpole_release(nddo_mpole, error) + SUBROUTINE nddo_mpole_release(nddo_mpole) TYPE(nddo_mpole_type), POINTER :: nddo_mpole - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'nddo_mpole_release', & routineP = moduleN//':'//routineN @@ -230,30 +218,30 @@ SUBROUTINE nddo_mpole_release(nddo_mpole, error) IF (ASSOCIATED(nddo_mpole)) THEN IF (ASSOCIATED(nddo_mpole%charge)) THEN DEALLOCATE(nddo_mpole%charge,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(nddo_mpole%dipole)) THEN DEALLOCATE(nddo_mpole%dipole,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(nddo_mpole%quadrupole)) THEN DEALLOCATE(nddo_mpole%quadrupole,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(nddo_mpole%efield0)) THEN DEALLOCATE(nddo_mpole%efield0,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(nddo_mpole%efield1)) THEN DEALLOCATE(nddo_mpole%efield1,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(nddo_mpole%efield2)) THEN DEALLOCATE(nddo_mpole%efield2,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (nddo_mpole, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE nddo_mpole_release diff --git a/src/semi_empirical_par_utils.F b/src/semi_empirical_par_utils.F index 6ea24da7cb..48ccc6a236 100644 --- a/src/semi_empirical_par_utils.F +++ b/src/semi_empirical_par_utils.F @@ -206,12 +206,10 @@ MODULE semi_empirical_par_utils !> number of atomic orbitals for that specific element !> \param sep ... !> \param extended_basis_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE valence_electrons(sep, extended_basis_set, error) + SUBROUTINE valence_electrons(sep, extended_basis_set) TYPE(semi_empirical_type), POINTER :: sep LOGICAL, INTENT(IN) :: extended_basis_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'valence_electrons', & routineP = moduleN//':'//routineN @@ -223,7 +221,7 @@ SUBROUTINE valence_electrons(sep, extended_basis_set, error) failure = .FALSE. use_p_orbitals = .TRUE. z = sep%z - CPPostcondition(z>=0, cp_failure_level, routineP, error, failure) + CPPostcondition(z>=0, cp_failure_level, routineP,failure) ! Special case for Hydrogen.. If requested allow p-orbitals on it.. SELECT CASE (z) CASE (0,2) @@ -237,11 +235,11 @@ SUBROUTINE valence_electrons(sep, extended_basis_set, error) natorb = 0 IF (nqs(z)>0) natorb = natorb+1 IF((nqp(z)>0).OR.use_p_orbitals) natorb = natorb+3 - IF (extended_basis_set.AND.element_has_d(sep,error)) natorb = natorb+5 - IF (extended_basis_set.AND.element_has_f(sep,error)) natorb = natorb+7 + IF (extended_basis_set.AND.element_has_d(sep)) natorb = natorb+5 + IF (extended_basis_set.AND.element_has_f(sep)) natorb = natorb+7 ! Check and assignemnt check = (natorb<=4).OR.(extended_basis_set) - CPPostcondition(check, cp_failure_level, routineP, error, failure) + CPPostcondition(check, cp_failure_level, routineP,failure) sep%natorb = natorb sep%extended_basis_set = extended_basis_set ! Determine the Z eff @@ -253,13 +251,11 @@ END SUBROUTINE valence_electrons !> \brief Gives back the number of basis function for each l !> \param sep ... !> \param l ... -!> \param error ... !> \retval n ... ! ***************************************************************************** - FUNCTION get_se_basis(sep,l,error) RESULT(n) + FUNCTION get_se_basis(sep,l) RESULT(n) TYPE(semi_empirical_type), POINTER :: sep INTEGER, INTENT(IN) :: l - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: n CHARACTER(len=*), PARAMETER :: routineN = 'get_se_basis', & @@ -296,13 +292,11 @@ END FUNCTION get_se_basis ! ***************************************************************************** !> \brief Converts parameter units to internal !> \param sep ... -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE convert_param_to_cp2k(sep,error) + SUBROUTINE convert_param_to_cp2k(sep) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'convert_param_to_cp2k', & routineP = moduleN//':'//routineN @@ -341,14 +335,12 @@ END SUBROUTINE convert_param_to_cp2k !> \brief Calculates missing parameters !> \param z ... !> \param sep ... -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE calpar(z,sep,error) + SUBROUTINE calpar(z,sep) INTEGER :: z TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calpar', & routineP = moduleN//':'//routineN @@ -405,7 +397,7 @@ SUBROUTINE calpar(z,sep,error) ! Principal quantum number qn = REAL(nqs(z),KIND=dp) - CPPostcondition(qn>0, cp_failure_level, routineP, error, failure) + CPPostcondition(qn>0, cp_failure_level, routineP,failure) ! Charge separation evaluation dd = (2.0_dp*qn + 1)*(4.0_dp*zs*zp)**(qn + 0.5_dp)/(zs+zp)**(2.0_dp*qn + 2)/SQRT(3.0_dp) @@ -456,7 +448,7 @@ SUBROUTINE calpar(z,sep,error) IF (ABS(sep%aq) < EPSILON(0.0_dp)) sep%aq = aq ! Proceed with d-orbitals and fill the Kolpman-Ohno and Charge Separation ! arrays - CALL calpar_d(sep,error) + CALL calpar_d(sep) END SUBROUTINE calpar ! ***************************************************************************** @@ -464,13 +456,11 @@ END SUBROUTINE calpar !> parameters for d-orbitals !> !> \param sep ... -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE calpar_d(sep,error) + SUBROUTINE calpar_d(sep) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calpar_d', & routineP = moduleN//':'//routineN @@ -481,11 +471,11 @@ SUBROUTINE calpar_d(sep,error) failure = .FALSE. ! Determine if this element owns d-orbitals (only if the parametrization ! supports the d-orbitals) - IF (sep%extended_basis_set) sep%dorb = element_has_d(sep,error) + IF (sep%extended_basis_set) sep%dorb = element_has_d(sep) IF (sep%dorb) THEN - CALL amn_l(sep, amn, error) - CALL eval_1c_2el_spd(sep, error) - CALL eval_cs_ko(sep, amn, error) + CALL amn_l(sep, amn) + CALL eval_1c_2el_spd(sep) + CALL eval_cs_ko(sep, amn) END IF IF (.NOT.sep%dorb) THEN ! Use the old integral module @@ -518,14 +508,12 @@ END SUBROUTINE calpar_d !> \brief Determines if the elements has d-orbitals !> !> \param sep ... -!> \param error ... !> \retval res ... !> \date 05.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION element_has_d(sep, error) RESULT(res) + FUNCTION element_has_d(sep) RESULT(res) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'element_has_d', & @@ -538,14 +526,12 @@ END FUNCTION element_has_d !> \brief Determines if the elements has f-orbitals !> !> \param sep ... -!> \param error ... !> \retval res ... !> \date 05.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION element_has_f(sep, error) RESULT(res) + FUNCTION element_has_f(sep) RESULT(res) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'element_has_f', & @@ -560,16 +546,14 @@ END FUNCTION element_has_f !> !> \param sep ... !> \param amn ... -!> \param error ... !> \date 03.2008 [tlaino] !> \par Notation Index: 1 (SS), 2 (SP), 3 (SD), 4 (PP), 5 (PD), 6 (DD) !> !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE amn_l1 (sep, amn, error) + SUBROUTINE amn_l1 (sep, amn) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), DIMENSION(6), INTENT(OUT) :: amn - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'amn_l1', & routineP = moduleN//':'//routineN @@ -614,17 +598,15 @@ END SUBROUTINE amn_l1 !> !> \param sep ... !> \param amn ... -!> \param error ... !> \date 09.2008 [tlaino] !> \par !> !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE amn_l2 (sep, amn, error) + SUBROUTINE amn_l2 (sep, amn) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), DIMENSION(6, 0:2), & INTENT(OUT) :: amn - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'amn_l2', & routineP = moduleN//':'//routineN @@ -637,17 +619,17 @@ SUBROUTINE amn_l2 (sep, amn, error) z1 = sep%sto_exponents(0) z2 = sep%sto_exponents(1) z3 = sep%sto_exponents(2) - CPPostcondition(z1>0.0_dp, cp_failure_level, routineP, error, failure) + CPPostcondition(z1>0.0_dp, cp_failure_level, routineP,failure) amn = 0.0_dp nsp = nqs(sep%z) amn(1,0) = amn_l_low(z1, z1, nsp, nsp, 0) IF (sep%natorb>=4) THEN - CPPostcondition(z2>0.0_dp, cp_failure_level, routineP, error, failure) + CPPostcondition(z2>0.0_dp, cp_failure_level, routineP,failure) amn(2,1) = amn_l_low(z1, z2, nsp, nsp, 1) amn(3,0) = amn_l_low(z2, z2, nsp, nsp, 0) amn(3,2) = amn_l_low(z2, z2, nsp, nsp, 2) IF (sep%dorb) THEN - CPPostcondition(z3>0.0_dp, cp_failure_level, routineP, error, failure) + CPPostcondition(z3>0.0_dp, cp_failure_level, routineP,failure) nd = nqd(sep%z) amn(4,2) = amn_l_low(z1, z3, nsp, nd, 2) amn(5,1) = amn_l_low(z2, z3, nsp, nd, 1) @@ -684,7 +666,6 @@ END FUNCTION amn_l_low !> the two-center two-electron integrals with d-orbitals !> \param sep ... !> \param amn ... -!> \param error ... !> \date 03.2008 [tlaino] !> \par Notation !> -) Charge separations [sep%cs(1:6)] [see equations (12)-(16) of TCA] @@ -694,10 +675,9 @@ END FUNCTION amn_l_low !> of the core-electron attractions and core-core repulsions !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE eval_cs_ko (sep,amn,error) + SUBROUTINE eval_cs_ko (sep,amn) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), DIMENSION(6), INTENT(IN) :: amn - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eval_cs_ko', & routineP = moduleN//':'//routineN @@ -708,39 +688,39 @@ SUBROUTINE eval_cs_ko (sep,amn,error) failure = .FALSE. ! SS term fg = sep%gss - sep%ko(1) = ko_ij (0, 1.0_dp, fg, error) + sep%ko(1) = ko_ij (0, 1.0_dp, fg) IF (sep%natorb>= 4) THEN ! Other terms for SP basis ! SP d = amn(2)/SQRT(3.0_dp) fg = sep%hsp sep%cs(2) = d - sep%ko(2) = ko_ij(1, d, fg, error) + sep%ko(2) = ko_ij(1, d, fg) ! PP sep%ko(7) = sep%ko(1) d = SQRT(amn(3)*2.0_dp/5.0_dp) fg = 0.5_dp*(sep%gpp-sep%gp2) sep%cs(3) = d - sep%ko(3) = ko_ij(2, d, fg, error) + sep%ko(3) = ko_ij(2, d, fg) ! Terms involving d-orbitals IF (sep%dorb) THEN ! SD d = SQRT(amn(4)*2.0_dp/SQRT(15.0_dp)) fg = sep%onec2el(19) sep%cs(4) = d - sep%ko(4) = ko_ij(2, d, fg, error) + sep%ko(4) = ko_ij(2, d, fg) ! PD d = amn(5)/SQRT(5.0_dp) fg = sep%onec2el(23) - 1.8_dp * sep%onec2el(35) sep%cs(5) = d - sep%ko(5) = ko_ij(1, d, fg, error) + sep%ko(5) = ko_ij(1, d, fg) ! DD fg = 0.2_dp * (sep%onec2el(29)+2.0_dp*sep%onec2el(30)+2.0_dp*sep%onec2el(31)) - sep%ko(8) = ko_ij (0, 1.0_dp, fg, error) + sep%ko(8) = ko_ij (0, 1.0_dp, fg) d = SQRT(amn(6)*2.0_dp/7.0_dp) fg = sep%onec2el(44) - (20.0_dp/35.0_dp) * sep%onec2el(52) sep%cs(6) = d - sep%ko(6) = ko_ij(2, d, fg, error) + sep%ko(6) = ko_ij(2, d, fg) END IF END IF END SUBROUTINE eval_cs_ko @@ -748,13 +728,11 @@ END SUBROUTINE eval_cs_ko ! ***************************************************************************** !> \brief Computes the 1 center two-electrons integrals for a SPD basis !> \param sep ... -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE eval_1c_2el_spd(sep,error) + SUBROUTINE eval_1c_2el_spd(sep) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eval_1c_2el_spd', & routineP = moduleN//':'//routineN @@ -772,7 +750,7 @@ SUBROUTINE eval_1c_2el_spd(sep,error) ! We evaluate now the Slater-Condon parameters (Rlij) CALL sc_param(sep, r066, r266, r466, r016, r244, r036, r236, r155, r355, r125,& - r234, r246, error) + r234, r246) IF (ABS(sep%f0sd) > EPSILON(0.0_dp)) THEN r016 = sep%f0sd @@ -780,7 +758,7 @@ SUBROUTINE eval_1c_2el_spd(sep,error) IF (ABS(sep%g2sd) > EPSILON(0.0_dp)) THEN r244 = sep%g2sd END IF - CALL eisol_corr(sep, r016, r066, r244, r266, r466, error) + CALL eisol_corr(sep, r016, r066, r244, r266, r466) sep%onec2el(1) = r016 sep%onec2el(2) = 2.0_dp/(3.0_dp*s5)*r125 sep%onec2el(3) = 1.0_dp/s15*r125 @@ -860,17 +838,15 @@ END SUBROUTINE eval_1c_2el_spd !> \param r125 ... !> \param r234 ... !> \param r246 ... -!> \param error ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** SUBROUTINE sc_param (sep, r066, r266, r466, r016, r244, r036, r236, r155, r355, & - r125, r234, r246, error) + r125, r234, r246) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), INTENT(out) :: r066, r266, r466, r016, r244, & r036, r236, r155, r355, r125, & r234, r246 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'sc_param', & routineP = moduleN//':'//routineN @@ -885,18 +861,18 @@ SUBROUTINE sc_param (sep, r066, r266, r466, r016, r244, r036, r236, r155, r355, es = sep%zn(0) ep = sep%zn(1) ed = sep%zn(2) - r016 = sc_param_low (0, ns, es, ns, es, nd, ed, nd, ed, error) - r036 = sc_param_low (0, ns, ep, ns, ep, nd, ed, nd, ed, error) - r066 = sc_param_low (0, nd, ed, nd, ed, nd, ed, nd, ed, error) - r155 = sc_param_low (1, ns, ep, nd, ed, ns, ep, nd, ed, error) - r125 = sc_param_low (1, ns, es, ns, ep, ns, ep, nd, ed, error) - r244 = sc_param_low (2, ns, es, nd, ed, ns, es, nd, ed, error) - r236 = sc_param_low (2, ns, ep, ns, ep, nd, ed, nd, ed, error) - r266 = sc_param_low (2, nd, ed, nd, ed, nd, ed, nd, ed, error) - r234 = sc_param_low (2, ns, ep, ns, ep, ns, es, nd, ed, error) - r246 = sc_param_low (2, ns, es, nd, ed, nd, ed, nd, ed, error) - r355 = sc_param_low (3, ns, ep, nd, ed, ns, ep, nd, ed, error) - r466 = sc_param_low (4, nd, ed, nd, ed, nd, ed, nd, ed, error) + r016 = sc_param_low (0, ns, es, ns, es, nd, ed, nd, ed) + r036 = sc_param_low (0, ns, ep, ns, ep, nd, ed, nd, ed) + r066 = sc_param_low (0, nd, ed, nd, ed, nd, ed, nd, ed) + r155 = sc_param_low (1, ns, ep, nd, ed, ns, ep, nd, ed) + r125 = sc_param_low (1, ns, es, ns, ep, ns, ep, nd, ed) + r244 = sc_param_low (2, ns, es, nd, ed, ns, es, nd, ed) + r236 = sc_param_low (2, ns, ep, ns, ep, nd, ed, nd, ed) + r266 = sc_param_low (2, nd, ed, nd, ed, nd, ed, nd, ed) + r234 = sc_param_low (2, ns, ep, ns, ep, ns, es, nd, ed) + r246 = sc_param_low (2, ns, es, nd, ed, nd, ed, nd, ed) + r355 = sc_param_low (3, ns, ep, nd, ed, ns, ep, nd, ed) + r466 = sc_param_low (4, nd, ed, nd, ed, nd, ed, nd, ed) END SUBROUTINE sc_param ! ***************************************************************************** @@ -910,7 +886,6 @@ END SUBROUTINE sc_param !> \param ec ... !> \param nd ... !> \param ed ... -!> \param error ... !> \retval res ... !> \date 03.2008 [tlaino] !> \par Notation @@ -921,7 +896,7 @@ END SUBROUTINE sc_param !> -) ec,ed: Exponents of AO,corresponding to electron 2 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION sc_param_low (k, na, ea, nb, eb, nc, ec, nd, ed, error) RESULT(res) + FUNCTION sc_param_low (k, na, ea, nb, eb, nc, ec, nd, ed) RESULT(res) INTEGER, INTENT(in) :: k, na REAL(KIND=dp), INTENT(in) :: ea INTEGER, INTENT(in) :: nb @@ -930,7 +905,6 @@ FUNCTION sc_param_low (k, na, ea, nb, eb, nc, ec, nd, ed, error) RESULT(res) REAL(KIND=dp), INTENT(in) :: ec INTEGER, INTENT(in) :: nd REAL(KIND=dp), INTENT(in) :: ed - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'sc_param_low', & @@ -943,10 +917,10 @@ FUNCTION sc_param_low (k, na, ea, nb, eb, nc, ec, nd, ed, error) RESULT(res) s0, s1, s2, s3, tmp failure = .FALSE. - CPPostcondition(ea>0.0_dp, cp_failure_level, routineP, error, failure) - CPPostcondition(eb>0.0_dp, cp_failure_level, routineP, error, failure) - CPPostcondition(ec>0.0_dp, cp_failure_level, routineP, error, failure) - CPPostcondition(ed>0.0_dp, cp_failure_level, routineP, error, failure) + CPPostcondition(ea>0.0_dp, cp_failure_level, routineP,failure) + CPPostcondition(eb>0.0_dp, cp_failure_level, routineP,failure) + CPPostcondition(ec>0.0_dp, cp_failure_level, routineP,failure) + CPPostcondition(ed>0.0_dp, cp_failure_level, routineP,failure) aea = LOG(ea) aeb = LOG(eb) aec = LOG(ec) @@ -991,7 +965,6 @@ END FUNCTION sc_param_low !> \param r244 ... !> \param r266 ... !> \param r466 ... -!> \param error ... !> \date 03.2008 [tlaino] !> \par Notation !> r016: @@ -1002,10 +975,9 @@ END FUNCTION sc_param_low !> !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE eisol_corr (sep, r016, r066, r244, r266, r466, error) + SUBROUTINE eisol_corr (sep, r016, r066, r244, r266, r466) TYPE(semi_empirical_type), POINTER :: sep REAL(KIND=dp), INTENT(in) :: r016, r066, r244, r266, r466 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'eisol_corr', & routineP = moduleN//':'//routineN @@ -1027,15 +999,13 @@ END SUBROUTINE eisol_corr !> \param l ... !> \param d ... !> \param fg ... -!> \param error ... !> \retval res ... !> \date 03.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - FUNCTION ko_ij(l, d, fg, error) RESULT(res) + FUNCTION ko_ij(l, d, fg) RESULT(res) INTEGER, INTENT(in) :: l REAL(KIND=dp), INTENT(in) :: d, fg - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(len=*), PARAMETER :: routineN = 'ko_ij', & @@ -1050,7 +1020,7 @@ FUNCTION ko_ij(l, d, fg, error) RESULT(res) f1, f2, y1, y2 failure = .FALSE. - CPPostcondition(fg/=0.0_dp, cp_failure_level, routineP, error, failure) + CPPostcondition(fg/=0.0_dp, cp_failure_level, routineP,failure) ! Term for SS IF (l == 0) THEN res = 0.5_dp * evolt/fg @@ -1092,13 +1062,11 @@ END FUNCTION ko_ij !> \brief Fills the 1 center 2 electron integrals for the construction of the !> one-electron fock matrix !> \param sep ... -!> \param error ... !> \date 04.2008 [tlaino] !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE setup_1c_2el_int(sep, error) + SUBROUTINE setup_1c_2el_int(sep) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_1c_2el_int', & routineP = moduleN//':'//routineN @@ -1112,11 +1080,11 @@ SUBROUTINE setup_1c_2el_int(sep, error) failure = .FALSE. CALL get_se_param(sep, defined=defined, natorb=natorb,& gss=gss, gsp=gsp, gpp=gpp, gp2=gp2, hsp=hsp) - CPPostcondition(defined, cp_failure_level, routineP, error, failure) + CPPostcondition(defined, cp_failure_level, routineP,failure) isize = natorb*(natorb+1)/2 ALLOCATE(sep%w(isize,isize),stat=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ! Initialize array sep%w = 0.0_dp ! Fill the array diff --git a/src/semi_empirical_parameters.F b/src/semi_empirical_parameters.F index 23c01a4429..cb540e57e4 100644 --- a/src/semi_empirical_parameters.F +++ b/src/semi_empirical_parameters.F @@ -83,12 +83,10 @@ MODULE semi_empirical_parameters !> \brief Default parameter sets for semi empirical models: POINT_CHARGE !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pcharge_default_parameter(sep, z, error) + SUBROUTINE pcharge_default_parameter(sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pcharge_default_parameter', & routineP = moduleN//':'//routineN @@ -98,7 +96,7 @@ SUBROUTINE pcharge_default_parameter(sep, z, error) sep%eheat = 0.0_dp sep%z = z sep%defined = .TRUE. - CALL valence_electrons (sep, extended_basis_set=.FALSE., error=error) + CALL valence_electrons (sep, extended_basis_set=.FALSE.) END SUBROUTINE pcharge_default_parameter @@ -107,12 +105,10 @@ END SUBROUTINE pcharge_default_parameter !> \param sep ... !> \param z ... !> \param itype ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mndo_default_parameter ( sep, z, itype, error) + SUBROUTINE mndo_default_parameter ( sep, z, itype) TYPE(semi_empirical_type), POINTER :: sep INTEGER, INTENT(IN) :: z, itype - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mndo_default_parameter', & routineP = moduleN//':'//routineN @@ -693,11 +689,11 @@ SUBROUTINE mndo_default_parameter ( sep, z, itype, error) CASE (84:nelem) END SELECT ! In case overwrite with MNDO-d parameters - IF (itype==do_method_mndod) CALL mndod_default_parameter(sep, z, error) + IF (itype==do_method_mndod) CALL mndod_default_parameter(sep, z) ! Finalize parameters for the element - CALL valence_electrons(sep, extended_basis_set=(itype==do_method_mndod),error=error) - CALL calpar(z,sep,error) - CALL convert_param_to_cp2k(sep,error) + CALL valence_electrons(sep, extended_basis_set=(itype==do_method_mndod)) + CALL calpar(z,sep) + CALL convert_param_to_cp2k(sep) END SUBROUTINE mndo_default_parameter @@ -706,12 +702,10 @@ END SUBROUTINE mndo_default_parameter !> \brief Default parameter sets for semi empirical models developed at PNNL !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pnnl_default_parameter ( sep, z, error) + SUBROUTINE pnnl_default_parameter ( sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER, INTENT(IN) :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pnnl_default_parameter', & routineP = moduleN//':'//routineN @@ -777,9 +771,9 @@ SUBROUTINE pnnl_default_parameter ( sep, z, error) sep%acoul = 16.22361790703965_dp /eV END SELECT ! Finalize parameters for the element - CALL valence_electrons(sep, extended_basis_set=.FALSE., error=error) - CALL calpar(z,sep,error) - CALL convert_param_to_cp2k(sep,error) + CALL valence_electrons(sep, extended_basis_set=.FALSE.) + CALL calpar(z,sep) + CALL convert_param_to_cp2k(sep) END SUBROUTINE pnnl_default_parameter @@ -787,12 +781,10 @@ END SUBROUTINE pnnl_default_parameter !> \brief Additional default parameter sets for semi empirical models: MNDO-d !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE mndod_default_parameter ( sep, z, error) + SUBROUTINE mndod_default_parameter ( sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mndod_default_parameter', & routineP = moduleN//':'//routineN @@ -1038,12 +1030,10 @@ END SUBROUTINE mndod_default_parameter !> \brief Default parameter sets for semi empirical models: AM1 !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE am1_default_parameter ( sep, z, error ) + SUBROUTINE am1_default_parameter ( sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'am1_default_parameter', & routineP = moduleN//':'//routineN @@ -1513,9 +1503,9 @@ SUBROUTINE am1_default_parameter ( sep, z, error ) CASE (83:nelem) END SELECT ! Finalize parameters for the element - CALL valence_electrons(sep, extended_basis_set=.FALSE., error=error) - CALL calpar(z,sep,error) - CALL convert_param_to_cp2k(sep,error) + CALL valence_electrons(sep, extended_basis_set=.FALSE.) + CALL calpar(z,sep) + CALL convert_param_to_cp2k(sep) END SUBROUTINE am1_default_parameter @@ -1523,12 +1513,10 @@ END SUBROUTINE am1_default_parameter !> \brief Default parameter sets for semi empirical models: RM1 !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rm1_default_parameter ( sep, z, error) + SUBROUTINE rm1_default_parameter ( sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rm1_default_parameter', & routineP = moduleN//':'//routineN @@ -1727,9 +1715,9 @@ SUBROUTINE rm1_default_parameter ( sep, z, error) CASE (80:nelem) END SELECT ! Finalize parameters for the element - CALL valence_electrons(sep, extended_basis_set=.FALSE., error=error) - CALL calpar(z,sep,error) - CALL convert_param_to_cp2k(sep,error) + CALL valence_electrons(sep, extended_basis_set=.FALSE.) + CALL calpar(z,sep) + CALL convert_param_to_cp2k(sep) END SUBROUTINE rm1_default_parameter @@ -1737,12 +1725,10 @@ END SUBROUTINE rm1_default_parameter !> \brief Default parameter sets for semi empirical models: PM3 !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pm3_default_parameter ( sep, z, error) + SUBROUTINE pm3_default_parameter ( sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pm3_default_parameter', & routineP = moduleN//':'//routineN @@ -2524,9 +2510,9 @@ SUBROUTINE pm3_default_parameter ( sep, z, error) CASE (92:nelem) END SELECT ! Finalize parameters for the element - CALL valence_electrons(sep, extended_basis_set=.FALSE., error=error) - CALL calpar(z,sep,error) - CALL convert_param_to_cp2k(sep,error) + CALL valence_electrons(sep, extended_basis_set=.FALSE.) + CALL calpar(z,sep) + CALL convert_param_to_cp2k(sep) END SUBROUTINE pm3_default_parameter @@ -2534,12 +2520,10 @@ END SUBROUTINE pm3_default_parameter !> \brief Default parameter sets for semi empirical models: PM6 !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pm6_default_parameter ( sep, z, error) + SUBROUTINE pm6_default_parameter ( sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pm6_default_parameter', & routineP = moduleN//':'//routineN @@ -3873,10 +3857,10 @@ SUBROUTINE pm6_default_parameter ( sep, z, error) CASE(84:nelem) END SELECT ! Finalize parameters for the element - CALL valence_electrons(sep, extended_basis_set=.TRUE., error=error) - CALL calpar(z,sep,error) - CALL convert_param_to_cp2k(sep, error) - CALL init_pm6_pair_params(error) + CALL valence_electrons(sep, extended_basis_set=.TRUE.) + CALL calpar(z,sep) + CALL convert_param_to_cp2k(sep) + CALL init_pm6_pair_params() sep%aab(0:nelem) = aab_pm6(z,0:nelem) sep%xab(0:nelem) = xab_pm6(z,0:nelem) @@ -3894,12 +3878,10 @@ END SUBROUTINE pm6_default_parameter !> \brief Default parameter sets for semi empirical models: PDDG !> \param sep ... !> \param z ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pdg_default_parameter ( sep, z, error) + SUBROUTINE pdg_default_parameter ( sep, z) TYPE(semi_empirical_type), POINTER :: sep INTEGER :: z - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pdg_default_parameter', & routineP = moduleN//':'//routineN @@ -4257,18 +4239,16 @@ SUBROUTINE pdg_default_parameter ( sep, z, error) CASE (54:nelem) END SELECT ! Finalize parameters for the element - CALL valence_electrons(sep, extended_basis_set=.FALSE., error=error) - CALL calpar(z,sep, error) - CALL convert_param_to_cp2k(sep, error) + CALL valence_electrons(sep, extended_basis_set=.FALSE.) + CALL calpar(z,sep) + CALL convert_param_to_cp2k(sep) END SUBROUTINE pdg_default_parameter ! ***************************************************************************** !> \brief Default pair parameter for: PM6 -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_pm6_pair_params(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE init_pm6_pair_params() CHARACTER(len=*), PARAMETER :: routineN = 'init_pm6_pair_params', & routineP = moduleN//':'//routineN diff --git a/src/semi_empirical_store_int_types.F b/src/semi_empirical_store_int_types.F index 727f7f10d6..0552337801 100644 --- a/src/semi_empirical_store_int_types.F +++ b/src/semi_empirical_store_int_types.F @@ -64,15 +64,13 @@ MODULE semi_empirical_store_int_types !> \param store_int_env ... !> \param se_section ... !> \param compression ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE semi_empirical_si_create(store_int_env, se_section, compression, error) + SUBROUTINE semi_empirical_si_create(store_int_env, se_section, compression) TYPE(semi_empirical_si_type), POINTER :: store_int_env TYPE(section_vals_type), POINTER :: se_section LOGICAL, INTENT(in), OPTIONAL :: compression - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_si_create', & routineP = moduleN//':'//routineN @@ -82,22 +80,22 @@ SUBROUTINE semi_empirical_si_create(store_int_env, se_section, compression, erro TYPE(section_vals_type), POINTER :: se_mem_section failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(store_int_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(store_int_env),cp_failure_level,routineP,failure) ALLOCATE (store_int_env,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) store_int_env%filling_containers = .TRUE. store_int_env%nbuffer = 0 NULLIFY(store_int_env%max_val_buffer, store_int_env%uncompressed_container) ! Memory section - se_mem_section => section_vals_get_subs_vals(se_section,"MEMORY",error=error) + se_mem_section => section_vals_get_subs_vals(se_section,"MEMORY") IF ( PRESENT(compression) ) THEN store_int_env%compress = compression ELSE - CALL section_vals_val_get(se_mem_section,"COMPRESS",l_val=store_int_env%compress,error=error) + CALL section_vals_val_get(se_mem_section,"COMPRESS",l_val=store_int_env%compress) END IF CALL parse_memory_section(store_int_env%memory_parameter, se_mem_section, skip_disk=.TRUE.,& - skip_in_core_forces =.TRUE., error=error) + skip_in_core_forces =.TRUE.) store_int_env%memory_parameter%ram_counter = 0 ! If we don't compress there's no cache IF (.NOT.store_int_env%compress) THEN @@ -113,15 +111,15 @@ SUBROUTINE semi_empirical_si_create(store_int_env, se_section, compression, erro ! Allocate containers/caches for integral storage if requested IF(.NOT.store_int_env%memory_parameter%do_all_on_the_fly.AND.store_int_env%compress) THEN ALLOCATE(store_int_env%integral_containers(64), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(store_int_env%integral_caches(64), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,64 store_int_env%integral_caches(i)%element_counter = 1 store_int_env%integral_caches(i)%data = 0 - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(store_int_env%integral_containers(i)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) store_int_env%integral_containers(i)%first%prev => NULL() store_int_env%integral_containers(i)%first%next => NULL() store_int_env%integral_containers(i)%current => store_int_env%integral_containers(i)%first @@ -134,13 +132,11 @@ END SUBROUTINE semi_empirical_si_create ! ***************************************************************************** !> \brief Deallocate the semi-empirical store integrals type !> \param store_int_env ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE semi_empirical_si_release(store_int_env, error) + SUBROUTINE semi_empirical_si_release(store_int_env) TYPE(semi_empirical_si_type), POINTER :: store_int_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_si_release', & routineP = moduleN//':'//routineN @@ -157,28 +153,28 @@ SUBROUTINE semi_empirical_si_release(store_int_env, error) DO i=1,64 CALL hfx_init_container(store_int_env%integral_containers(i),& store_int_env%memory_parameter%actual_memory_usage,& - .FALSE., error) + .FALSE.) DEALLOCATE(store_int_env%integral_containers(i)%first,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO IF (ASSOCIATED(store_int_env%max_val_buffer)) THEN DEALLOCATE(store_int_env%max_val_buffer,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(store_int_env%integral_containers,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(store_int_env%integral_caches,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF (ASSOCIATED(store_int_env%uncompressed_container)) THEN DEALLOCATE(store_int_env%uncompressed_container,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END IF ! Deallocate the full store_int_env DEALLOCATE (store_int_env,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE semi_empirical_si_release @@ -187,14 +183,12 @@ END SUBROUTINE semi_empirical_si_release !> \brief Deallocate the semi-empirical store integrals type !> \param store_int_env ... !> \param geometry_did_change ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE semi_empirical_si_initialize(store_int_env, geometry_did_change, error) + SUBROUTINE semi_empirical_si_initialize(store_int_env, geometry_did_change) TYPE(semi_empirical_si_type), POINTER :: store_int_env LOGICAL, INTENT(IN) :: geometry_did_change - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_si_initialize', & routineP = moduleN//':'//routineN @@ -216,7 +210,7 @@ SUBROUTINE semi_empirical_si_initialize(store_int_env, geometry_did_change, erro DO i=1,64 CALL hfx_init_container(store_int_env%integral_containers(i),& store_int_env%memory_parameter%actual_memory_usage,& - .FALSE., error) + .FALSE.) END DO ELSE ! Skip compression @@ -246,14 +240,12 @@ END SUBROUTINE semi_empirical_si_initialize !> \brief Deallocate the semi-empirical store integrals type !> \param store_int_env ... !> \param geometry_did_change ... -!> \param error ... !> \date 05.2008 !> \author Teodoro Laino [tlaino] - University of Zurich ! ***************************************************************************** - SUBROUTINE semi_empirical_si_finalize(store_int_env, geometry_did_change, error) + SUBROUTINE semi_empirical_si_finalize(store_int_env, geometry_did_change) TYPE(semi_empirical_si_type), POINTER :: store_int_env LOGICAL, INTENT(IN) :: geometry_did_change - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_si_finalize', & routineP = moduleN//':'//routineN @@ -270,7 +262,7 @@ SUBROUTINE semi_empirical_si_finalize(store_int_env, geometry_did_change, error) DO i=1,64 CALL hfx_flush_last_cache(i, store_int_env%integral_caches(i),& store_int_env%integral_containers(i),& - store_int_env%memory_parameter%actual_memory_usage, .FALSE., error) + store_int_env%memory_parameter%actual_memory_usage, .FALSE.) END DO ! Reallocate this array with the proper size CALL reallocate(store_int_env%max_val_buffer, 1, store_int_env%nbuffer) diff --git a/src/semi_empirical_types.F b/src/semi_empirical_types.F index aa44153179..4b54821ca4 100644 --- a/src/semi_empirical_types.F +++ b/src/semi_empirical_types.F @@ -180,11 +180,9 @@ MODULE semi_empirical_types ! ***************************************************************************** !> \brief Allocate semi-empirical type !> \param sep ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE semi_empirical_create(sep, error) + SUBROUTINE semi_empirical_create(sep) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_create', & routineP = moduleN//':'//routineN @@ -193,32 +191,30 @@ SUBROUTINE semi_empirical_create(sep, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(sep),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(sep),cp_failure_level,routineP,failure) ALLOCATE (sep,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (sep%beta(0:3),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (sep%sto_exponents(0:3),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (sep%zn(0:3),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(sep%basis) NULLIFY(sep%w) NULLIFY(sep%w_mpole) NULLIFY(sep%expns3_int) - CALL zero_se_param(sep,error) + CALL zero_se_param(sep) END SUBROUTINE semi_empirical_create ! ***************************************************************************** !> \brief Deallocate the semi-empirical type !> \param sep ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE semi_empirical_release(sep, error) + SUBROUTINE semi_empirical_release(sep) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'semi_empirical_release', & routineP = moduleN//':'//routineN @@ -228,33 +224,33 @@ SUBROUTINE semi_empirical_release(sep, error) failure = .FALSE. IF (ASSOCIATED(sep)) THEN - CALL deallocate_sto_basis_set(sep%basis, error) - CALL semi_empirical_mpole_p_release(sep%w_mpole, error) + CALL deallocate_sto_basis_set(sep%basis) + CALL semi_empirical_mpole_p_release(sep%w_mpole) IF (ASSOCIATED(sep%beta)) THEN DEALLOCATE (sep%beta,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(sep%sto_exponents)) THEN DEALLOCATE (sep%sto_exponents,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(sep%zn)) THEN DEALLOCATE (sep%zn,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(sep%w)) THEN DEALLOCATE (sep%w,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(sep%expns3_int)) THEN DO i = 1, SIZE(sep%expns3_int) - CALL semi_empirical_expns3_release(sep%expns3_int(i)%expns3,error) + CALL semi_empirical_expns3_release(sep%expns3_int(i)%expns3) END DO DEALLOCATE (sep%expns3_int,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (sep,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE semi_empirical_release @@ -262,11 +258,9 @@ END SUBROUTINE semi_empirical_release ! ***************************************************************************** !> \brief Zero the whole semi-empirical type !> \param sep ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE zero_se_param(sep, error) + SUBROUTINE zero_se_param(sep) TYPE(semi_empirical_type), POINTER :: sep - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'zero_se_param', & routineP = moduleN//':'//routineN @@ -274,7 +268,7 @@ SUBROUTINE zero_se_param(sep, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(sep),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sep),cp_failure_level,routineP,failure) sep%defined = .FALSE. sep%dorb = .FALSE. sep%extended_basis_set = .FALSE. @@ -560,11 +554,9 @@ END SUBROUTINE set_se_param ! ***************************************************************************** !> \brief Creates rotmat type !> \param rotmat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rotmat_create(rotmat, error) + SUBROUTINE rotmat_create(rotmat) TYPE(rotmat_type), POINTER :: rotmat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotmat_create', & routineP = moduleN//':'//routineN @@ -573,20 +565,18 @@ SUBROUTINE rotmat_create(rotmat, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(rotmat),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(rotmat),cp_failure_level,routineP,failure) ALLOCATE (rotmat,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE rotmat_create ! ***************************************************************************** !> \brief Releases rotmat type !> \param rotmat ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE rotmat_release(rotmat, error) + SUBROUTINE rotmat_release(rotmat) TYPE(rotmat_type), POINTER :: rotmat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rotmat_release', & routineP = moduleN//':'//routineN @@ -597,7 +587,7 @@ SUBROUTINE rotmat_release(rotmat, error) failure = .FALSE. IF (ASSOCIATED(rotmat)) THEN DEALLOCATE (rotmat,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE rotmat_release @@ -656,12 +646,11 @@ END SUBROUTINE setup_se_int_control_type !> \param range_scr ... !> \param taper_lrc ... !> \param range_lrc ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2009 ! ***************************************************************************** SUBROUTINE se_taper_create(se_taper, integral_screening, do_ewald, & taper_cou, range_cou, taper_exc, range_exc, taper_scr, range_scr,& - taper_lrc, range_lrc, error) + taper_lrc, range_lrc) TYPE(se_taper_type), POINTER :: se_taper INTEGER, INTENT(IN) :: integral_screening LOGICAL, INTENT(IN) :: do_ewald @@ -669,7 +658,6 @@ SUBROUTINE se_taper_create(se_taper, integral_screening, do_ewald, & taper_exc, range_exc, & taper_scr, range_scr, & taper_lrc, range_lrc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_taper_create', & routineP = moduleN//':'//routineN @@ -678,34 +666,32 @@ SUBROUTINE se_taper_create(se_taper, integral_screening, do_ewald, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(se_taper),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(se_taper),cp_failure_level,routineP,failure) ALLOCATE(se_taper, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(se_taper%taper) NULLIFY(se_taper%taper_cou) NULLIFY(se_taper%taper_exc) NULLIFY(se_taper%taper_lrc) NULLIFY(se_taper%taper_add) ! Create the sub-typo taper - CALL taper_create(se_taper%taper_cou, taper_cou, range_cou, error) - CALL taper_create(se_taper%taper_exc, taper_exc, range_exc, error) + CALL taper_create(se_taper%taper_cou, taper_cou, range_cou) + CALL taper_create(se_taper%taper_exc, taper_exc, range_exc) IF (integral_screening==do_se_IS_kdso_d) THEN - CALL taper_create(se_taper%taper_add, taper_scr, range_scr, error) + CALL taper_create(se_taper%taper_add, taper_scr, range_scr) END IF IF ((integral_screening/=do_se_IS_slater).AND.do_ewald) THEN - CALL taper_create(se_taper%taper_lrc, taper_lrc, range_lrc, error) + CALL taper_create(se_taper%taper_lrc, taper_lrc, range_lrc) END IF END SUBROUTINE se_taper_create ! ***************************************************************************** !> \brief Releases the taper type used in SE calculations !> \param se_taper ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2009 ! ***************************************************************************** - SUBROUTINE se_taper_release(se_taper, error) + SUBROUTINE se_taper_release(se_taper) TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_taper_release', & routineP = moduleN//':'//routineN @@ -715,13 +701,13 @@ SUBROUTINE se_taper_release(se_taper, error) failure = .FALSE. IF (ASSOCIATED(se_taper)) THEN - CALL taper_release(se_taper%taper_cou, error=error) - CALL taper_release(se_taper%taper_exc, error=error) - CALL taper_release(se_taper%taper_lrc, error=error) - CALL taper_release(se_taper%taper_add, error=error) + CALL taper_release(se_taper%taper_cou) + CALL taper_release(se_taper%taper_exc) + CALL taper_release(se_taper%taper_lrc) + CALL taper_release(se_taper%taper_add) DEALLOCATE(se_taper, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE se_taper_release @@ -729,16 +715,14 @@ END SUBROUTINE se_taper_release !> \brief Writes the semi-empirical type !> \param sep ... !> \param subsys_section ... -!> \param error ... !> \par History !> 04.2008 Teodoro Laino [tlaino] - University of Zurich: rewriting with !> support for the whole set of parameters ! ***************************************************************************** - SUBROUTINE write_se_param(sep, subsys_section, error) + SUBROUTINE write_se_param(sep, subsys_section) TYPE(semi_empirical_type), POINTER :: sep TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_se_param', & routineP = moduleN//':'//routineN @@ -767,12 +751,12 @@ SUBROUTINE write_se_param(sep, subsys_section, error) TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (ASSOCIATED(sep).AND.BTEST(cp_print_key_should_output(logger%iter_info,subsys_section,& - "PRINT%KINDS/SE_PARAMETERS",error=error),cp_p_file)) THEN + "PRINT%KINDS/SE_PARAMETERS"),cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,subsys_section,"PRINT%KINDS/SE_PARAMETERS",& - extension=".Log",error=error) + extension=".Log") IF (output_unit >0) THEN CALL get_se_param(sep,name=name,typ=typ,defined=defined,& @@ -1007,7 +991,7 @@ SUBROUTINE write_se_param(sep, subsys_section, error) END SELECT END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%KINDS/SE_PARAMETERS",error=error) + "PRINT%KINDS/SE_PARAMETERS") END IF END SUBROUTINE write_se_param diff --git a/src/semi_empirical_utils.F b/src/semi_empirical_utils.F index 4cb41a76a0..aa33644371 100644 --- a/src/semi_empirical_utils.F +++ b/src/semi_empirical_utils.F @@ -54,16 +54,14 @@ MODULE semi_empirical_utils !> \param se_section ... !> \param cell ... !> \param output_unit ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2009 ! ***************************************************************************** - SUBROUTINE se_cutoff_compatible(se_control, se_section, cell, output_unit, error) + SUBROUTINE se_cutoff_compatible(se_control, se_section, cell, output_unit) TYPE(semi_empirical_control_type), & POINTER :: se_control TYPE(section_vals_type), POINTER :: se_section TYPE(cell_type), POINTER :: cell INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_cutoff_compatible', & routineP = moduleN//':'//routineN @@ -73,8 +71,8 @@ SUBROUTINE se_cutoff_compatible(se_control, se_section, cell, output_unit, error failure = .FALSE. ! Coulomb Cutoff Taper - CALL section_vals_val_get(se_section,"COULOMB%CUTOFF",explicit=explicit1,error=error) - CALL section_vals_val_get(se_section,"COULOMB%RC_TAPER",explicit=explicit2,error=error) + CALL section_vals_val_get(se_section,"COULOMB%CUTOFF",explicit=explicit1) + CALL section_vals_val_get(se_section,"COULOMB%RC_TAPER",explicit=explicit2) IF ((.NOT.explicit1).AND.se_control%do_ewald_gks) THEN rc = MAX(0.5*plane_distance(1,0,0,cell),& 0.5*plane_distance(0,1,0,cell),& @@ -123,8 +121,8 @@ SUBROUTINE se_cutoff_compatible(se_control, se_section, cell, output_unit, error WRITE(output_unit,*) END IF ! Exchange Cutoff Taper - CALL section_vals_val_get(se_section,"EXCHANGE%CUTOFF",explicit=explicit1,error=error) - CALL section_vals_val_get(se_section,"EXCHANGE%RC_TAPER",explicit=explicit2,error=error) + CALL section_vals_val_get(se_section,"EXCHANGE%CUTOFF",explicit=explicit1) + CALL section_vals_val_get(se_section,"EXCHANGE%RC_TAPER",explicit=explicit2) rc = se_control%cutoff_exc IF (.NOT.explicit1) THEN rc = MIN(rc,MAX(0.25_dp*plane_distance(1,0,0,cell),& @@ -167,13 +165,11 @@ END SUBROUTINE se_cutoff_compatible !> \param coulomb ... !> \param exchange ... !> \param lr_corr ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2009 ! ***************************************************************************** - SUBROUTINE initialize_se_taper(se_taper, coulomb, exchange, lr_corr, error) + SUBROUTINE initialize_se_taper(se_taper, coulomb, exchange, lr_corr) TYPE(se_taper_type), POINTER :: se_taper LOGICAL, INTENT(IN), OPTIONAL :: coulomb, exchange, lr_corr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'initialize_se_taper', & routineP = moduleN//':'//routineN @@ -183,7 +179,7 @@ SUBROUTINE initialize_se_taper(se_taper, coulomb, exchange, lr_corr, error) failure = .FALSE. check = .NOT.ASSOCIATED(se_taper%taper) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) l_coulomb = .FALSE. l_exchange = .FALSE. l_lrc = .FALSE. @@ -192,17 +188,17 @@ SUBROUTINE initialize_se_taper(se_taper, coulomb, exchange, lr_corr, error) IF (PRESENT(lr_corr)) l_lrc = lr_corr IF (l_coulomb) THEN check = (.NOT.l_exchange).AND.(.NOT.l_lrc) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) se_taper%taper => se_taper%taper_cou END IF IF (l_exchange) THEN check = (.NOT.l_coulomb).AND.(.NOT.l_lrc) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) se_taper%taper => se_taper%taper_exc END IF IF (l_lrc) THEN check = (.NOT.l_coulomb).AND.(.NOT.l_exchange) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) se_taper%taper => se_taper%taper_lrc END IF END SUBROUTINE initialize_se_taper @@ -210,12 +206,10 @@ END SUBROUTINE initialize_se_taper ! ***************************************************************************** !> \brief Finalizes the semi-empirical taper for a chunk calculation !> \param se_taper ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 03.2009 ! ***************************************************************************** - SUBROUTINE finalize_se_taper(se_taper, error) + SUBROUTINE finalize_se_taper(se_taper) TYPE(se_taper_type), POINTER :: se_taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'finalize_se_taper', & routineP = moduleN//':'//routineN @@ -224,7 +218,7 @@ SUBROUTINE finalize_se_taper(se_taper, error) failure = .FALSE. check = ASSOCIATED(se_taper%taper) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) NULLIFY(se_taper%taper) END SUBROUTINE finalize_se_taper @@ -233,13 +227,11 @@ END SUBROUTINE finalize_se_taper !> \param sep ... !> \param orb_basis_set ... !> \param ngauss ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_se_param(sep,orb_basis_set,ngauss,error) + SUBROUTINE init_se_param(sep,orb_basis_set,ngauss) TYPE(semi_empirical_type), POINTER :: sep TYPE(gto_basis_set_type), POINTER :: orb_basis_set INTEGER, INTENT(IN) :: ngauss - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_se_param', & routineP = moduleN//':'//routineN @@ -252,23 +244,23 @@ SUBROUTINE init_se_param(sep,orb_basis_set,ngauss,error) failure = .FALSE. IF (ASSOCIATED(sep)) THEN - CALL allocate_sto_basis_set (sep%basis,error) + CALL allocate_sto_basis_set (sep%basis) nshell = 0 IF (sep%natorb == 1) nshell=1 IF (sep%natorb == 4) nshell=2 IF (sep%natorb == 9) nshell=3 ALLOCATE (nq(0:3),lq(0:3),zet(0:3),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (symbol(0:3),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) symbol="" nq=0 lq=0 zet=0._dp DO l=0,nshell-1 - nq(l)=get_se_basis(sep,l,error) + nq(l)=get_se_basis(sep,l) lq(l)=l zet(l)=sep%sto_exponents(l) IF(l==0) WRITE(symbol(0),'(I1,A1)') nq(l),"S" @@ -280,17 +272,17 @@ SUBROUTINE init_se_param(sep,orb_basis_set,ngauss,error) sep%ngauss = ngauss CALL set_sto_basis_set(sep%basis,name=sep%name,nshell=nshell,symbol=symbol,& nq=nq,lq=lq,zet=zet) - CALL create_gto_from_sto_basis(sep%basis,orb_basis_set,sep%ngauss,error=error) + CALL create_gto_from_sto_basis(sep%basis,orb_basis_set,sep%ngauss) END IF DEALLOCATE (nq,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (lq,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (zet,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (symbol,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer sep is not associated") @@ -303,13 +295,11 @@ END SUBROUTINE init_se_param !> \param sep ... !> \param z ... !> \param method ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE se_param_set_default(sep,z,method,error) + SUBROUTINE se_param_set_default(sep,z,method) TYPE(semi_empirical_type), POINTER :: sep INTEGER, INTENT(IN) :: z, method - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'se_param_set_default', & routineP = moduleN//':'//routineN @@ -324,23 +314,23 @@ SUBROUTINE se_param_set_default(sep,z,method,error) END IF SELECT CASE (method) CASE (do_method_am1) - CALL am1_default_parameter(sep,z,error) + CALL am1_default_parameter(sep,z) CASE (do_method_rm1) - CALL rm1_default_parameter(sep,z,error) + CALL rm1_default_parameter(sep,z) CASE (do_method_pm3) - CALL pm3_default_parameter(sep,z,error) + CALL pm3_default_parameter(sep,z) CASE (do_method_pm6) - CALL pm6_default_parameter(sep,z,error) + CALL pm6_default_parameter(sep,z) CASE (do_method_pdg) - CALL pdg_default_parameter(sep,z,error) + CALL pdg_default_parameter(sep,z) CASE (do_method_mndo) - CALL mndo_default_parameter(sep,z,do_method_mndo, error) + CALL mndo_default_parameter(sep,z,do_method_mndo) CASE (do_method_mndod) - CALL mndo_default_parameter(sep,z,do_method_mndod,error) + CALL mndo_default_parameter(sep,z,do_method_mndod) CASE (do_method_pnnl) - CALL pnnl_default_parameter(sep,z,error) + CALL pnnl_default_parameter(sep,z) CASE (do_method_pchg) - CALL pcharge_default_parameter(sep,z,error) + CALL pcharge_default_parameter(sep,z) CASE DEFAULT CALL stop_program(routineN,moduleN,__LINE__,& "Semiempirical method unknown") @@ -358,10 +348,10 @@ SUBROUTINE se_param_set_default(sep,z,method,error) only_ionode=.TRUE.) ! Fill 1 center - 2 electron integrals - CALL setup_1c_2el_int(sep, error) + CALL setup_1c_2el_int(sep) ! Fill multipolar expansion of atomic orbitals charge distributions - CALL semi_empirical_mpole_p_setup(sep%w_mpole, sep, method, error) + CALL semi_empirical_mpole_p_setup(sep%w_mpole, sep, method) ! Get the value of the size of CORE integral array sep%core_size = 0 diff --git a/src/simpar_types.F b/src/simpar_types.F index e9fddf5f36..ec767fddfa 100644 --- a/src/simpar_types.F +++ b/src/simpar_types.F @@ -94,13 +94,10 @@ MODULE simpar_types ! ***************************************************************************** !> \brief Creates the simulation parameters type !> \param simpar ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE create_simpar_type(simpar, error) + SUBROUTINE create_simpar_type(simpar) TYPE(simpar_type), POINTER :: simpar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_simpar_type', & routineP = moduleN//':'//routineN @@ -109,21 +106,18 @@ SUBROUTINE create_simpar_type(simpar, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(simpar),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(simpar),cp_failure_level,routineP,failure) ALLOCATE(simpar, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE create_simpar_type ! ***************************************************************************** !> \brief Releases the simulation parameters type !> \param simpar ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE release_simpar_type(simpar, error) + SUBROUTINE release_simpar_type(simpar) TYPE(simpar_type), POINTER :: simpar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_simpar_type', & routineP = moduleN//':'//routineN @@ -132,9 +126,9 @@ SUBROUTINE release_simpar_type(simpar, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(simpar),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(simpar),cp_failure_level,routineP,failure) DEALLOCATE(simpar, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE release_simpar_type END MODULE simpar_types diff --git a/src/splines_types.F b/src/splines_types.F index f10f8a7bf1..b8cac30880 100644 --- a/src/splines_types.F +++ b/src/splines_types.F @@ -84,12 +84,10 @@ MODULE splines_types ! ***************************************************************************** !> \brief releases spline_env !> \param spline_env ... -!> \param error ... !> \author unknown ! ***************************************************************************** - SUBROUTINE spline_env_release(spline_env,error) + SUBROUTINE spline_env_release(spline_env) TYPE(spline_environment_type), POINTER :: spline_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_env_release', & routineP = moduleN//':'//routineN @@ -102,21 +100,21 @@ SUBROUTINE spline_env_release(spline_env,error) failure=.FALSE. IF (ASSOCIATED(spline_env)) THEN - CPPrecondition(spline_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(spline_env%ref_count>0,cp_failure_level,routineP,failure) spline_env%ref_count=spline_env%ref_count-1 IF (spline_env%ref_count<1) THEN DEALLOCATE ( spline_env % spltab, stat = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DO i = 1, SIZE ( spline_env % spl_pp ) spl_p => spline_env % spl_pp ( i ) % spl_p - CALL spline_data_p_release ( spl_p, error ) + CALL spline_data_p_release ( spl_p) END DO DEALLOCATE ( spline_env % spl_pp, stat = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY ( spline_env % spltab ) NULLIFY ( spline_env % spl_pp ) DEALLOCATE ( spline_env , stat = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF @@ -125,12 +123,10 @@ END SUBROUTINE spline_env_release ! ***************************************************************************** !> \brief releases spline_data !> \param spline_data ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE spline_data_release (spline_data,error) + SUBROUTINE spline_data_release (spline_data) TYPE(spline_data_type), POINTER :: spline_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_data_release', & routineP = moduleN//':'//routineN @@ -141,21 +137,21 @@ SUBROUTINE spline_data_release (spline_data,error) failure=.FALSE. IF (ASSOCIATED(spline_data)) THEN - CPPrecondition(spline_data%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(spline_data%ref_count>0,cp_failure_level,routineP,failure) spline_data%ref_count=spline_data%ref_count-1 IF (spline_data%ref_count<1) THEN IF ( ASSOCIATED ( spline_data%y)) THEN DEALLOCATE (spline_data%y,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY (spline_data%y) END IF IF ( ASSOCIATED ( spline_data%y2)) THEN DEALLOCATE (spline_data%y2,STAT=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) NULLIFY (spline_data%y2) END IF DEALLOCATE ( spline_data, stat = stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF END SUBROUTINE spline_data_release @@ -163,13 +159,11 @@ END SUBROUTINE spline_data_release ! ***************************************************************************** !> \brief releases spline_data_p !> \param spl_p ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE spline_data_p_release (spl_p,error) + SUBROUTINE spline_data_p_release (spl_p) TYPE(spline_data_p_type), DIMENSION(:), & POINTER :: spl_p - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_data_p_release', & routineP = moduleN//':'//routineN @@ -182,12 +176,12 @@ SUBROUTINE spline_data_p_release (spl_p,error) IF (ASSOCIATED(spl_p)) THEN release_kind = .TRUE. DO i = 1, SIZE(spl_p) - CALL spline_data_release(spl_p(i)%spline_data,error) + CALL spline_data_release(spl_p(i)%spline_data) release_kind = release_kind .AND.(.NOT.ASSOCIATED(spl_p(i)%spline_data)) END DO IF (release_kind) THEN DEALLOCATE(spl_p, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -196,12 +190,10 @@ END SUBROUTINE spline_data_p_release ! ***************************************************************************** !> \brief retains spline_env !> \param spline_data ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE spline_data_retain(spline_data,error) + SUBROUTINE spline_data_retain(spline_data) TYPE(spline_data_type), POINTER :: spline_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_data_retain', & routineP = moduleN//':'//routineN @@ -209,21 +201,19 @@ SUBROUTINE spline_data_retain(spline_data,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(spline_data),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_data%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_data),cp_failure_level,routineP,failure) + CPPrecondition(spline_data%ref_count>0,cp_failure_level,routineP,failure) spline_data%ref_count=spline_data%ref_count+1 END SUBROUTINE spline_data_retain ! ***************************************************************************** !> \brief retains spline_data_p_type !> \param spl_p ... -!> \param error ... !> \author CJM ! ***************************************************************************** - SUBROUTINE spline_data_p_retain(spl_p,error) + SUBROUTINE spline_data_p_retain(spl_p) TYPE(spline_data_p_type), DIMENSION(:), & POINTER :: spl_p - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_data_p_retain', & routineP = moduleN//':'//routineN @@ -232,23 +222,21 @@ SUBROUTINE spline_data_p_retain(spl_p,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(spl_p),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spl_p),cp_failure_level,routineP,failure) DO i = 1, SIZE(spl_p) - CALL spline_data_retain(spl_p(i)%spline_data, error) + CALL spline_data_retain(spl_p(i)%spline_data) END DO END SUBROUTINE spline_data_p_retain ! ***************************************************************************** !> \brief retains spline_env !> \param spline_env ... -!> \param error ... !> \par History !> 2001-09-19-HAF added this doc entry and changed formatting !> \author unknown ! ***************************************************************************** - SUBROUTINE spline_env_retain(spline_env,error) + SUBROUTINE spline_env_retain(spline_env) TYPE(spline_environment_type), POINTER :: spline_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_env_retain', & routineP = moduleN//':'//routineN @@ -256,8 +244,8 @@ SUBROUTINE spline_env_retain(spline_env,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(spline_env),cp_failure_level,routineP,error,failure) - CPPrecondition(spline_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(spline_env),cp_failure_level,routineP,failure) + CPPrecondition(spline_env%ref_count>0,cp_failure_level,routineP,failure) spline_env%ref_count=spline_env%ref_count+1 END SUBROUTINE spline_env_retain @@ -267,16 +255,14 @@ END SUBROUTINE spline_env_retain !> \param spline_env ... !> \param ntype ... !> \param ntab_in ... -!> \param error ... !> \par History !> 2001-09-19-HAF added this doc entry and changed formatting !> \author unknown ! ***************************************************************************** - SUBROUTINE spline_env_create ( spline_env, ntype, ntab_in, error ) + SUBROUTINE spline_env_create ( spline_env, ntype, ntab_in) TYPE(spline_environment_type), POINTER :: spline_env INTEGER, INTENT(IN) :: ntype INTEGER, INTENT(IN), OPTIONAL :: ntab_in - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_env_create', & routineP = moduleN//':'//routineN @@ -290,7 +276,7 @@ SUBROUTINE spline_env_create ( spline_env, ntype, ntab_in, error ) failure=.FALSE. ALLOCATE(spline_env, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY ( spline_env % spl_pp ) NULLIFY ( spline_env % spltab ) spline_env%ref_count=1 @@ -303,18 +289,18 @@ SUBROUTINE spline_env_create ( spline_env, ntype, ntab_in, error ) ntab = ( ntype * ntype + ntype ) / 2 END IF ALLOCATE ( spline_env % spl_pp( ntab ), stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( spline_env % spltab ( ntype, ntype ), stat=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, ntab NULLIFY (spline_env%spl_pp( i )%spl_p) isize = 1 ALLOCATE(spline_env%spl_pp(i)%spl_p(isize), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, SIZE(spline_env%spl_pp(i)%spl_p) - CALL spline_data_create (spline_env%spl_pp(i)%spl_p(j)%spline_data,error=error) + CALL spline_data_create (spline_env%spl_pp(i)%spl_p(j)%spline_data) END DO END DO @@ -326,13 +312,11 @@ END SUBROUTINE spline_env_create !> \brief Copy Data-structure of spline_data_p_type !> \param spl_p_source ... !> \param spl_p_dest ... -!> \param error ... !> \author teo 06.2007 ! ***************************************************************************** - SUBROUTINE spline_data_p_copy ( spl_p_source, spl_p_dest, error ) + SUBROUTINE spline_data_p_copy ( spl_p_source, spl_p_dest) TYPE(spline_data_p_type), DIMENSION(:), & POINTER :: spl_p_source, spl_p_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_data_p_copy', & routineP = moduleN//':'//routineN @@ -341,23 +325,23 @@ SUBROUTINE spline_data_p_copy ( spl_p_source, spl_p_dest, error ) LOGICAL :: failure failure=.FALSE. - CPPostcondition(ASSOCIATED(spl_p_source),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(spl_p_source),cp_failure_level,routineP,failure) nsizes = SIZE(spl_p_source) IF (.NOT.ASSOCIATED(spl_p_dest)) THEN ALLOCATE(spl_p_dest(nsizes), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nsizes NULLIFY(spl_p_dest(i)%spline_data) END DO ELSE nsized = SIZE(spl_p_dest) - CPPostcondition(nsizes==nsized,cp_failure_level,routineP,error,failure) + CPPostcondition(nsizes==nsized,cp_failure_level,routineP,failure) DO i = 1, nsizes - CALL spline_data_release(spl_p_dest(i)%spline_data, error=error) + CALL spline_data_release(spl_p_dest(i)%spline_data) END DO END IF DO i = 1, nsizes - CALL spline_data_copy (spl_p_source(i)%spline_data, spl_p_dest(i)%spline_data, error ) + CALL spline_data_copy (spl_p_source(i)%spline_data, spl_p_dest(i)%spline_data) END DO END SUBROUTINE spline_data_p_copy @@ -365,13 +349,11 @@ END SUBROUTINE spline_data_p_copy !> \brief Copy Data-structure that constains spline table !> \param spline_data_source ... !> \param spline_data_dest ... -!> \param error ... !> \author teo 11.2005 ! ***************************************************************************** - SUBROUTINE spline_data_copy ( spline_data_source, spline_data_dest, error ) + SUBROUTINE spline_data_copy ( spline_data_source, spline_data_dest) TYPE(spline_data_type), POINTER :: spline_data_source, & spline_data_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_data_copy', & routineP = moduleN//':'//routineN @@ -380,8 +362,8 @@ SUBROUTINE spline_data_copy ( spline_data_source, spline_data_dest, error ) LOGICAL :: failure failure=.FALSE. - CPPostcondition(ASSOCIATED(spline_data_source),cp_failure_level,routineP,error,failure) - IF (.NOT.ASSOCIATED(spline_data_dest)) CALL spline_data_create(spline_data_dest,error) + CPPostcondition(ASSOCIATED(spline_data_source),cp_failure_level,routineP,failure) + IF (.NOT.ASSOCIATED(spline_data_dest)) CALL spline_data_create(spline_data_dest) spline_data_dest%ref_count = spline_data_source%ref_count spline_data_dest%id_nr = spline_data_source%id_nr @@ -393,12 +375,12 @@ SUBROUTINE spline_data_copy ( spline_data_source, spline_data_dest, error ) spline_data_dest%xn = spline_data_source%xn IF (ASSOCIATED(spline_data_source%y)) THEN ALLOCATE(spline_data_dest%y(SIZE(spline_data_source%y)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) spline_data_dest%y = spline_data_source%y END IF IF (ASSOCIATED(spline_data_source%y2)) THEN ALLOCATE(spline_data_dest%y2(SIZE(spline_data_source%y2)), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) spline_data_dest%y2 = spline_data_source%y2 END IF END SUBROUTINE spline_data_copy @@ -406,12 +388,10 @@ END SUBROUTINE spline_data_copy ! ***************************************************************************** !> \brief Data-structure that constains spline table !> \param spline_data ... -!> \param error ... !> \author unknown ! ***************************************************************************** - SUBROUTINE spline_data_create ( spline_data, error ) + SUBROUTINE spline_data_create ( spline_data) TYPE(spline_data_type), POINTER :: spline_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_data_create', & routineP = moduleN//':'//routineN @@ -422,7 +402,7 @@ SUBROUTINE spline_data_create ( spline_data, error ) failure=.FALSE. ALLOCATE(spline_data, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) spline_data%ref_count=1 last_spline_data_id_nr=last_spline_data_id_nr+1 spline_data%id_nr = last_spline_data_id_nr @@ -433,12 +413,10 @@ END SUBROUTINE spline_data_create ! ***************************************************************************** !> \brief releases spline_factor !> \param spline_factor ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE spline_factor_release (spline_factor,error) + SUBROUTINE spline_factor_release (spline_factor) TYPE(spline_factor_type), POINTER :: spline_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_factor_release', & routineP = moduleN//':'//routineN @@ -451,30 +429,28 @@ SUBROUTINE spline_factor_release (spline_factor,error) IF (ASSOCIATED(spline_factor)) THEN IF (ASSOCIATED(spline_factor%rscale)) THEN DEALLOCATE(spline_factor%rscale,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(spline_factor%fscale)) THEN DEALLOCATE(spline_factor%fscale,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(spline_factor%dscale)) THEN DEALLOCATE(spline_factor%dscale,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (spline_factor, stat=stat ) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE spline_factor_release ! ***************************************************************************** !> \brief releases spline_factor !> \param spline_factor ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE spline_factor_create (spline_factor, error) + SUBROUTINE spline_factor_create (spline_factor) TYPE(spline_factor_type), POINTER :: spline_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_factor_create', & routineP = moduleN//':'//routineN @@ -483,15 +459,15 @@ SUBROUTINE spline_factor_create (spline_factor, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(spline_factor),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(spline_factor),cp_failure_level,routineP,failure) ALLOCATE(spline_factor, stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(spline_factor%rscale(1),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(spline_factor%fscale(1),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(spline_factor%dscale(1),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) spline_factor%rscale = 1.0_dp spline_factor%fscale = 1.0_dp spline_factor%dscale = 1.0_dp @@ -503,13 +479,11 @@ END SUBROUTINE spline_factor_create !> \brief releases spline_factor !> \param spline_factor_source ... !> \param spline_factor_dest ... -!> \param error ... !> \author teo ! ***************************************************************************** - SUBROUTINE spline_factor_copy (spline_factor_source,spline_factor_dest, error) + SUBROUTINE spline_factor_copy (spline_factor_source,spline_factor_dest) TYPE(spline_factor_type), POINTER :: spline_factor_source, & spline_factor_dest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spline_factor_copy', & routineP = moduleN//':'//routineN @@ -519,14 +493,14 @@ SUBROUTINE spline_factor_copy (spline_factor_source,spline_factor_dest, error) failure=.FALSE. - IF (ASSOCIATED(spline_factor_dest)) CALL spline_factor_release(spline_factor_dest, error) + IF (ASSOCIATED(spline_factor_dest)) CALL spline_factor_release(spline_factor_dest) IF (ASSOCIATED(spline_factor_source)) THEN isize = SIZE(spline_factor_source%rscale) jsize = SIZE(spline_factor_source%fscale) ksize = SIZE(spline_factor_source%dscale) - CPPrecondition(isize==jsize,cp_failure_level,routineP,error,failure) - CPPrecondition(isize==ksize,cp_failure_level,routineP,error,failure) - CALL spline_factor_create(spline_factor_dest, error) + CPPrecondition(isize==jsize,cp_failure_level,routineP,failure) + CPPrecondition(isize==ksize,cp_failure_level,routineP,failure) + CALL spline_factor_create(spline_factor_dest) spline_factor_dest%rscale = spline_factor_source%rscale spline_factor_dest%fscale = spline_factor_source%fscale spline_factor_dest%dscale = spline_factor_source%dscale diff --git a/src/spme.F b/src/spme.F index d4da3203ea..14e572eda2 100644 --- a/src/spme.F +++ b/src/spme.F @@ -87,14 +87,13 @@ MODULE spme !> \param use_virial ... !> \param charges ... !> \param atprop ... -!> \param error ... !> \par History !> JGH (03-May-2001) : SPME with charge definition !> \author JGH (21-Mar-2001) ! ***************************************************************************** SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & fg_coulomb, vg_coulomb, pv_g, shell_particle_set, core_particle_set,& - fgshell_coulomb, fgcore_coulomb, use_virial, charges, atprop, error ) + fgshell_coulomb, fgcore_coulomb, use_virial, charges, atprop) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw @@ -116,7 +115,6 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: charges TYPE(atprop_type), POINTER :: atprop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spme_evaluate', & routineP = moduleN//':'//routineN @@ -151,38 +149,38 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & !-------------- INITIALISATION --------------------- CALL ewald_env_get ( ewald_env, alpha=alpha, o_spline = o_spline,& - group = group, error=error) + group = group) CALL ewald_pw_get ( ewald_pw, pw_big_pool=pw_pool, rs_desc=rs_desc,& poisson_env=poisson_env) - CALL pw_poisson_rebuild(poisson_env,error=error) + CALL pw_poisson_rebuild(poisson_env) green => poisson_env%green_fft grid_spme => pw_pool % pw_grid npart = SIZE ( particle_set ) - CALL get_pw_grid_info(grid_spme,npts=npts,dvol=dvols,error=error) + CALL get_pw_grid_info(grid_spme,npts=npts,dvol=dvols) n = o_spline ALLOCATE ( rhos(n,n,n), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL rs_grid_create (rden, rs_desc, error=error) - CALL rs_grid_set_box ( grid_spme, rs=rden, error=error ) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL rs_grid_create (rden, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=rden) CALL rs_grid_zero ( rden ) ALLOCATE ( center(3, npart), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( particle_set, box, center, npts, n ) IF(PRESENT(shell_particle_set).AND.(PRESENT(core_particle_set))) THEN - CPPostcondition(ASSOCIATED(shell_particle_set),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(core_particle_set),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(shell_particle_set),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(core_particle_set),cp_failure_level,routineP,failure) nshell=SIZE(shell_particle_set) ncore =SIZE(core_particle_set) - CPPostcondition(nshell==ncore,cp_failure_level,routineP,error,failure) + CPPostcondition(nshell==ncore,cp_failure_level,routineP,failure) ALLOCATE ( shell_center ( 3, nshell ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( shell_particle_set, box, shell_center, npts, n ) ALLOCATE ( core_center ( 3, nshell ), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( core_particle_set, box, core_center, npts, n ) END IF @@ -232,13 +230,13 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & !----------- END OF DENSITY CALCULATION ------------- CALL pw_pool_create_pw ( pw_pool, rhob_r, use_data = REALDATA3D, & - in_space = REALSPACE ,error=error) - CALL rs_pw_transfer ( rden, rhob_r, rs2pw, error=error) + in_space = REALSPACE) + CALL rs_pw_transfer ( rden, rhob_r, rs2pw) ! transform density to G space and add charge function CALL pw_pool_create_pw ( pw_pool, rhob_g, & use_data = COMPLEXDATA1D, & - in_space = RECIPROCALSPACE ,error=error) - CALL pw_transfer ( rhob_r, rhob_g, error=error) + in_space = RECIPROCALSPACE) + CALL pw_transfer ( rhob_r, rhob_g) ! update charge function rhob_g % cc = rhob_g % cc * green % p3m_charge % cr @@ -248,24 +246,22 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & NULLIFY(dphi_g(i)%pw) CALL pw_pool_create_pw ( pw_pool, dphi_g ( i )%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE,& - error=error) + in_space = RECIPROCALSPACE) END DO CALL pw_pool_create_pw ( pw_pool, phi_g, & use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE,& - error=error) + in_space = RECIPROCALSPACE) CALL pw_poisson_solve ( poisson_env, rhob_g, vg_coulomb, phi_g, dphi_g, & - h_stress ,error=error) + h_stress) !---------- END OF ELECTROSTATIC CALCULATION -------- ! Atomic Energy and Stress IF (atprop%energy .OR. atprop%stress) THEN - CALL rs_grid_create (rpot, rs_desc, error=error) - CALL rs_grid_set_box ( grid_spme, rs=rpot, error=error ) + CALL rs_grid_create (rpot, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=rpot) phi_g%cc = phi_g%cc * green%p3m_charge%cr - CALL pw_transfer ( phi_g, rhob_r, error=error) - CALL rs_pw_transfer (rpot, rhob_r, pw2rs, error=error) + CALL pw_transfer ( phi_g, rhob_r) + CALL rs_pw_transfer (rpot, rhob_r, pw2rs) ipart = 0 DO CALL set_list ( particle_set, npart, center, p1, rden, ipart ) @@ -325,11 +321,11 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & DO j = 1, i nd = 0 nd ( j ) = 1 - CALL pw_copy ( phi_g, rhob_g, error=error) - CALL pw_derive ( rhob_g, nd , error=error) + CALL pw_copy ( phi_g, rhob_g) + CALL pw_derive ( rhob_g, nd) rhob_g%cc = rhob_g%cc * green%p3m_charge%cr - CALL pw_transfer ( rhob_g, rhob_r, error=error) - CALL rs_pw_transfer ( rpot, rhob_r, pw2rs, error=error) + CALL pw_transfer ( rhob_g, rhob_r) + CALL rs_pw_transfer ( rpot, rhob_r, pw2rs) ipart = 0 DO @@ -347,17 +343,17 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & END DO END DO END IF - CALL rs_grid_release ( rpot, error=error) + CALL rs_grid_release ( rpot) END IF - CALL pw_pool_give_back_pw ( pw_pool, phi_g ,error=error) - CALL pw_pool_give_back_pw ( pw_pool, rhob_g ,error=error) + CALL pw_pool_give_back_pw ( pw_pool, phi_g) + CALL pw_pool_give_back_pw ( pw_pool, rhob_g) !------------- STRESS TENSOR CALCULATION ------------ IF (use_virial) THEN DO i = 1, 3 DO j = i, 3 - f_stress ( i, j ) = pw_integral_a2b ( dphi_g ( i ) % pw, dphi_g ( j ) % pw, error=error) + f_stress ( i, j ) = pw_integral_a2b ( dphi_g ( i ) % pw, dphi_g ( j ) % pw) f_stress ( j, i ) = f_stress ( i, j ) END DO END DO @@ -369,17 +365,17 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & ! move derivative of potential to real space grid and ! multiply by charge function in g-space ALLOCATE ( drpot(1:3), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, 3 - CALL rs_grid_create( drpot(i)%rs_grid, rs_desc, error=error ) - CALL rs_grid_set_box ( grid_spme, rs=drpot(i)%rs_grid, error=error ) + CALL rs_grid_create( drpot(i)%rs_grid, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=drpot(i)%rs_grid) dphi_g ( i ) % pw % cc = dphi_g ( i ) % pw % cc * green % p3m_charge % cr - CALL pw_transfer ( dphi_g ( i )%pw, rhob_r, error=error) - CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw ,error=error) - CALL rs_pw_transfer ( drpot ( i ) % rs_grid, rhob_r, pw2rs,error=error) + CALL pw_transfer ( dphi_g ( i )%pw, rhob_r) + CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw) + CALL rs_pw_transfer ( drpot ( i ) % rs_grid, rhob_r, pw2rs) END DO - CALL pw_pool_give_back_pw ( pw_pool, rhob_r ,error=error) + CALL pw_pool_give_back_pw ( pw_pool, rhob_r) !----------------- FORCE CALCULATION ---------------- ! initialize the forces fg_coulomb = 0.0_dp @@ -447,26 +443,26 @@ SUBROUTINE spme_evaluate ( ewald_env, ewald_pw, box, particle_set, & !--------------END OF FORCE CALCULATION ------------- !------------------CLEANING UP ---------------------- - CALL rs_grid_release (rden, error=error) + CALL rs_grid_release (rden) IF (ASSOCIATED(drpot)) THEN DO i = 1, 3 - CALL rs_grid_release ( drpot(i)%rs_grid, error=error) + CALL rs_grid_release ( drpot(i)%rs_grid) END DO DEALLOCATE ( drpot, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE ( rhos, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ALLOCATED(shell_center)) THEN DEALLOCATE ( shell_center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ALLOCATED(core_center)) THEN DEALLOCATE ( core_center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) @@ -482,13 +478,12 @@ END SUBROUTINE spme_evaluate !> \param charges_a ... !> \param particle_set_b ... !> \param potential ... -!> \param error ... !> \par History !> JGH (23-Oct-2014) : adapted from SPME evaluate !> \author JGH (23-Oct-2014) ! ***************************************************************************** SUBROUTINE spme_potential ( ewald_env, ewald_pw, box, particle_set_a, charges_a, & - particle_set_b, potential, error ) + particle_set_b, potential) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw @@ -500,7 +495,6 @@ SUBROUTINE spme_potential ( ewald_env, ewald_pw, box, particle_set_a, charges_a, INTENT(IN) :: particle_set_b REAL(KIND=dp), DIMENSION(:), & INTENT(INOUT) :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spme_potential', & routineP = moduleN//':'//routineN @@ -529,26 +523,26 @@ SUBROUTINE spme_potential ( ewald_env, ewald_pw, box, particle_set_a, charges_a, CALL cite_reference(Essmann1995) !-------------- INITIALISATION --------------------- - CALL ewald_env_get ( ewald_env, alpha=alpha, o_spline = o_spline, group = group, error=error) + CALL ewald_env_get ( ewald_env, alpha=alpha, o_spline = o_spline, group = group) CALL ewald_pw_get ( ewald_pw, pw_big_pool=pw_pool, rs_desc=rs_desc, poisson_env=poisson_env) - CALL pw_poisson_rebuild(poisson_env,error=error) + CALL pw_poisson_rebuild(poisson_env) green => poisson_env%green_fft grid_spme => pw_pool % pw_grid npart_a = SIZE ( particle_set_a ) npart_b = SIZE ( particle_set_b ) - CALL get_pw_grid_info(grid_spme,npts=npts,dvol=dvols,error=error) + CALL get_pw_grid_info(grid_spme,npts=npts,dvol=dvols) n = o_spline ALLOCATE ( rhos(n,n,n), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL rs_grid_create (rden, rs_desc, error=error) - CALL rs_grid_set_box ( grid_spme, rs=rden, error=error ) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL rs_grid_create (rden, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=rden) CALL rs_grid_zero ( rden ) ALLOCATE ( center(3, npart_a), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( particle_set_a, box, center, npts, n ) !-------------- DENSITY CALCULATION ---------------- @@ -565,17 +559,17 @@ SUBROUTINE spme_potential ( ewald_env, ewald_pw, box, particle_set_a, charges_a, CALL dg_sum_patch ( rden, rhos, center(:,p1) ) END DO DEALLOCATE ( center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !----------- END OF DENSITY CALCULATION ------------- CALL pw_pool_create_pw ( pw_pool, rhob_r, use_data = REALDATA3D, & - in_space = REALSPACE ,error=error) - CALL rs_pw_transfer ( rden, rhob_r, rs2pw, error=error) + in_space = REALSPACE) + CALL rs_pw_transfer ( rden, rhob_r, rs2pw) ! transform density to G space and add charge function CALL pw_pool_create_pw ( pw_pool, rhob_g, & use_data = COMPLEXDATA1D, & - in_space = RECIPROCALSPACE ,error=error) - CALL pw_transfer ( rhob_r, rhob_g, error=error) + in_space = RECIPROCALSPACE) + CALL pw_transfer ( rhob_r, rhob_g) ! update charge function rhob_g % cc = rhob_g % cc * green % p3m_charge % cr @@ -583,19 +577,18 @@ SUBROUTINE spme_potential ( ewald_env, ewald_pw, box, particle_set_a, charges_a, ! allocate intermediate arrays CALL pw_pool_create_pw ( pw_pool, phi_g, & use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE,& - error=error) - CALL pw_poisson_solve ( poisson_env, density=rhob_g, vhartree=phi_g, error=error) + in_space = RECIPROCALSPACE) + CALL pw_poisson_solve ( poisson_env, density=rhob_g, vhartree=phi_g) !---------- END OF ELECTROSTATIC CALCULATION -------- !-------------- POTENTAIL AT ATOMIC POSITIONS ------- ALLOCATE ( center(3, npart_b), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( particle_set_b, box, center, npts, n ) rpot => rden phi_g%cc = phi_g%cc * green%p3m_charge%cr - CALL pw_transfer ( phi_g, rhob_r, error=error) - CALL rs_pw_transfer (rpot, rhob_r, pw2rs, error=error) + CALL pw_transfer ( phi_g, rhob_r) + CALL rs_pw_transfer (rpot, rhob_r, pw2rs) ipart = 0 DO CALL set_list ( particle_set_b, npart_b, center, p1, rden, ipart ) @@ -609,15 +602,15 @@ SUBROUTINE spme_potential ( ewald_env, ewald_pw, box, particle_set_a, charges_a, END DO !------------------CLEANING UP ---------------------- - CALL pw_pool_give_back_pw ( pw_pool, phi_g ,error=error) - CALL pw_pool_give_back_pw ( pw_pool, rhob_g ,error=error) - CALL pw_pool_give_back_pw ( pw_pool, rhob_r ,error=error) - CALL rs_grid_release (rden, error=error) + CALL pw_pool_give_back_pw ( pw_pool, phi_g) + CALL pw_pool_give_back_pw ( pw_pool, rhob_g) + CALL pw_pool_give_back_pw ( pw_pool, rhob_r) + CALL rs_grid_release (rden) DEALLOCATE ( rhos, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE spme_potential @@ -633,13 +626,12 @@ END SUBROUTINE spme_potential !> \param particle_set_b ... !> \param charges_b ... !> \param forces_b ... -!> \param error ... !> \par History !> JGH (27-Oct-2014) : adapted from SPME evaluate !> \author JGH (23-Oct-2014) ! ***************************************************************************** SUBROUTINE spme_forces ( ewald_env, ewald_pw, box, particle_set_a, charges_a, & - particle_set_b, charges_b, forces_b, error ) + particle_set_b, charges_b, forces_b) TYPE(ewald_environment_type), POINTER :: ewald_env TYPE(ewald_pw_type), POINTER :: ewald_pw @@ -652,7 +644,6 @@ SUBROUTINE spme_forces ( ewald_env, ewald_pw, box, particle_set_a, charges_a, & REAL(KIND=dp), DIMENSION(:), POINTER :: charges_b REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: forces_b - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'spme_forces', & routineP = moduleN//':'//routineN @@ -685,26 +676,26 @@ SUBROUTINE spme_forces ( ewald_env, ewald_pw, box, particle_set_a, charges_a, & CALL cite_reference(Essmann1995) !-------------- INITIALISATION --------------------- - CALL ewald_env_get ( ewald_env, alpha=alpha, o_spline = o_spline, group = group, error=error) + CALL ewald_env_get ( ewald_env, alpha=alpha, o_spline = o_spline, group = group) CALL ewald_pw_get ( ewald_pw, pw_big_pool=pw_pool, rs_desc=rs_desc, poisson_env=poisson_env) - CALL pw_poisson_rebuild(poisson_env,error=error) + CALL pw_poisson_rebuild(poisson_env) green => poisson_env%green_fft grid_spme => pw_pool % pw_grid npart_a = SIZE ( particle_set_a ) npart_b = SIZE ( particle_set_b ) - CALL get_pw_grid_info(grid_spme,npts=npts,dvol=dvols,error=error) + CALL get_pw_grid_info(grid_spme,npts=npts,dvol=dvols) n = o_spline ALLOCATE ( rhos(n,n,n), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL rs_grid_create (rden, rs_desc, error=error) - CALL rs_grid_set_box ( grid_spme, rs=rden, error=error ) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL rs_grid_create (rden, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=rden) CALL rs_grid_zero ( rden ) ALLOCATE ( center(3, npart_a), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( particle_set_a, box, center, npts, n ) !-------------- DENSITY CALCULATION ---------------- @@ -721,17 +712,17 @@ SUBROUTINE spme_forces ( ewald_env, ewald_pw, box, particle_set_a, charges_a, & CALL dg_sum_patch ( rden, rhos, center(:,p1) ) END DO DEALLOCATE ( center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !----------- END OF DENSITY CALCULATION ------------- CALL pw_pool_create_pw ( pw_pool, rhob_r, use_data = REALDATA3D, & - in_space = REALSPACE ,error=error) - CALL rs_pw_transfer ( rden, rhob_r, rs2pw, error=error) + in_space = REALSPACE) + CALL rs_pw_transfer ( rden, rhob_r, rs2pw) ! transform density to G space and add charge function CALL pw_pool_create_pw ( pw_pool, rhob_g, & use_data = COMPLEXDATA1D, & - in_space = RECIPROCALSPACE ,error=error) - CALL pw_transfer ( rhob_r, rhob_g, error=error) + in_space = RECIPROCALSPACE) + CALL pw_transfer ( rhob_r, rhob_g) ! update charge function rhob_g % cc = rhob_g % cc * green % p3m_charge % cr @@ -741,31 +732,29 @@ SUBROUTINE spme_forces ( ewald_env, ewald_pw, box, particle_set_a, charges_a, & NULLIFY(dphi_g(i)%pw) CALL pw_pool_create_pw ( pw_pool, dphi_g ( i )%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE,& - error=error) + in_space = RECIPROCALSPACE) END DO CALL pw_pool_create_pw ( pw_pool, phi_g, & use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE,& - error=error) + in_space = RECIPROCALSPACE) CALL pw_poisson_solve ( poisson_env, density=rhob_g, vhartree=phi_g, & - dvhartree=dphi_g, error=error) + dvhartree=dphi_g) !---------- END OF ELECTROSTATIC CALCULATION -------- ! move derivative of potential to real space grid and ! multiply by charge function in g-space ALLOCATE ( drpot(1:3), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, 3 - CALL rs_grid_create( drpot(i)%rs_grid, rs_desc, error=error ) - CALL rs_grid_set_box ( grid_spme, rs=drpot(i)%rs_grid, error=error ) + CALL rs_grid_create( drpot(i)%rs_grid, rs_desc) + CALL rs_grid_set_box ( grid_spme, rs=drpot(i)%rs_grid) dphi_g ( i ) % pw % cc = dphi_g ( i ) % pw % cc * green % p3m_charge % cr - CALL pw_transfer ( dphi_g ( i )%pw, rhob_r, error=error) - CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw ,error=error) - CALL rs_pw_transfer ( drpot ( i ) % rs_grid, rhob_r, pw2rs,error=error) + CALL pw_transfer ( dphi_g ( i )%pw, rhob_r) + CALL pw_pool_give_back_pw ( pw_pool, dphi_g ( i )%pw) + CALL rs_pw_transfer ( drpot ( i ) % rs_grid, rhob_r, pw2rs) END DO !----------------- FORCE CALCULATION ---------------- ALLOCATE ( center(3, npart_b), STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL get_center ( particle_set_b, box, center, npts, n ) ipart = 0 DO @@ -783,20 +772,20 @@ SUBROUTINE spme_forces ( ewald_env, ewald_pw, box, particle_set_a, charges_a, & !------------------CLEANING UP ---------------------- IF (ASSOCIATED(drpot)) THEN DO i = 1, 3 - CALL rs_grid_release ( drpot(i)%rs_grid, error=error) + CALL rs_grid_release ( drpot(i)%rs_grid) END DO DEALLOCATE ( drpot, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF - CALL pw_pool_give_back_pw ( pw_pool, phi_g ,error=error) - CALL pw_pool_give_back_pw ( pw_pool, rhob_g ,error=error) - CALL pw_pool_give_back_pw ( pw_pool, rhob_r ,error=error) - CALL rs_grid_release (rden, error=error) + CALL pw_pool_give_back_pw ( pw_pool, phi_g) + CALL pw_pool_give_back_pw ( pw_pool, rhob_g) + CALL pw_pool_give_back_pw ( pw_pool, rhob_r) + CALL rs_grid_release (rden) DEALLOCATE ( rhos, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE ( center, STAT = stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE spme_forces diff --git a/src/start/c_int_low.F b/src/start/c_int_low.F index 1e584f6990..90cd11a9c7 100644 --- a/src/start/c_int_low.F +++ b/src/start/c_int_low.F @@ -49,13 +49,11 @@ SUBROUTINE cp_create_fenv(new_env_id,input_file_path,output_file_path,& USE f77_interface, ONLY: create_force_env USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type USE ISO_C_BINDING, ONLY: c_int, c_char, c_null_char USE kinds, ONLY: default_path_length IMPLICIT NONE - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration CHARACTER(len=1,kind=c_char) :: input_file_path(*), output_file_path(*) INTEGER(c_int) :: new_env_id, ierr @@ -75,9 +73,9 @@ SUBROUTINE cp_create_fenv(new_env_id,input_file_path,output_file_path,& END DO NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL create_force_env(new_env_id,input_declaration,ifp,ofp,ierr=ierr) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_create_fenv ! ***************************************************************************** @@ -93,13 +91,11 @@ SUBROUTINE cp_create_fenv_comm(new_env_id,input_file_path,output_file_path,& USE f77_interface, ONLY: create_force_env USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type USE ISO_C_BINDING, ONLY: c_int, c_char, c_null_char USE kinds, ONLY: default_path_length IMPLICIT NONE - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration CHARACTER(len=1,kind=c_char) :: input_file_path(*), output_file_path(*) INTEGER(c_int) :: new_env_id, mpi_comm, ierr @@ -119,9 +115,9 @@ SUBROUTINE cp_create_fenv_comm(new_env_id,input_file_path,output_file_path,& END DO NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL create_force_env(new_env_id,input_declaration,ifp,ofp,mpi_comm,ierr=ierr) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_create_fenv_comm ! ***************************************************************************** @@ -402,13 +398,11 @@ SUBROUTINE cp_run_input(input_file_path,output_file_path,ierr) BIND(C,name="cp_c USE cp2k_runs, ONLY: run_input USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type USE ISO_C_BINDING, ONLY: c_int, c_char, c_null_char USE kinds, ONLY: default_path_length IMPLICIT NONE - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration CHARACTER(len=1,kind=c_char) :: input_file_path(*), output_file_path(*) INTEGER(c_int) :: ierr @@ -428,9 +422,9 @@ SUBROUTINE cp_run_input(input_file_path,output_file_path,ierr) BIND(C,name="cp_c END DO NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL run_input(input_declaration,ifp,ofp,ierr=ierr) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_run_input ! ***************************************************************************** @@ -445,13 +439,11 @@ RECURSIVE SUBROUTINE cp_run_input_comm(input_file_path,output_file_path,& USE cp2k_runs, ONLY: run_input USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type USE ISO_C_BINDING, ONLY: c_int, c_char, c_null_char USE kinds, ONLY: default_path_length IMPLICIT NONE - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration CHARACTER(len=1,kind=c_char) :: input_file_path(*), output_file_path(*) INTEGER(c_int) :: mpi_comm, ierr @@ -471,9 +463,9 @@ RECURSIVE SUBROUTINE cp_run_input_comm(input_file_path,output_file_path,& END DO NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL run_input(input_declaration,ifp,ofp,ierr,mpi_comm) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_run_input_comm ! ***************************************************************************** @@ -508,7 +500,6 @@ END SUBROUTINE cp_do_shake SUBROUTINE cp_c_ext_method_set_ptr(f_env_id,func,ierr) BIND(C,name="cp_c_ext_method_set_ptr") USE ISO_C_BINDING, ONLY: c_int, c_funptr USE f77_interface, ONLY: f_env_add_defaults, f_env_rm_defaults, f_env_type - USE cp_error_handling, ONLY: cp_error_type USE force_env_types, ONLY: force_env_get, use_qs_force IMPLICIT NONE @@ -517,17 +508,16 @@ SUBROUTINE cp_c_ext_method_set_ptr(f_env_id,func,ierr) BIND(C,name="cp_c_ext_met INTEGER(c_int) :: ierr INTEGER(c_int) :: f_env_id LOGICAL :: failure - TYPE(cp_error_type) :: error TYPE(f_env_type), POINTER :: f_env INTEGER :: in_use failure = .FALSE. NULLIFY (f_env) - CALL f_env_add_defaults(f_env_id,f_env,error,failure) - CALL force_env_get(f_env%force_env,in_use=in_use,error=error) + CALL f_env_add_defaults(f_env_id,f_env,failure) + CALL force_env_get(f_env%force_env,in_use=in_use) IF (in_use .EQ. use_qs_force) THEN f_env%force_env%qs_env%transport_env%ext_c_method_ptr = func END IF - CALL f_env_rm_defaults(f_env,error,ierr) + CALL f_env_rm_defaults(f_env,ierr) END SUBROUTINE cp_c_ext_method_set_ptr diff --git a/src/start/cp2k.F b/src/start/cp2k.F index fce7a6be90..1b7932aa6f 100644 --- a/src/start/cp2k.F +++ b/src/start/cp2k.F @@ -73,7 +73,6 @@ PROGRAM cp2k LOGICAL :: check, manual, usage, echo_input, command_line_error LOGICAL :: run_it, force_run, has_input, xml, print_version, print_license TYPE(section_type), POINTER :: input_declaration - TYPE(cp_error_type) :: error NULLIFY(input_declaration) @@ -250,17 +249,17 @@ PROGRAM cp2k ! if a manual is needed IF (manual) THEN IF (default_para_env%mepos==default_para_env%source) THEN - CALL write_cp2k_html_manual(error=error) + CALL write_cp2k_html_manual() END IF ENDIF IF (xml) THEN IF (default_para_env%mepos == default_para_env%source) THEN - CALL write_xml_file(error=error) + CALL write_xml_file() END IF END IF - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) IF (check) THEN CALL check_input(input_declaration,input_file_name,output_file_name,& @@ -287,7 +286,7 @@ PROGRAM cp2k ENDIF END IF - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) ENDIF ELSE WRITE(UNIT=output_unit,FMT="(/,A)") "initial setup (MPI ?) error" diff --git a/src/start/cp2k_runs.F b/src/start/cp2k_runs.F index bd583cafa2..467121ca32 100644 --- a/src/start/cp2k_runs.F +++ b/src/start/cp2k_runs.F @@ -179,7 +179,6 @@ RECURSIVE FUNCTION cp2k_run(input_declaration,input_file_name,output_unit,mpi_co INTEGER(KIND=int_8) :: m_memory_max_mpi LOGICAL :: echo_input, failure, & I_was_ionode, was_present - TYPE(cp_error_type) :: error, suberror TYPE(cp_logger_type), POINTER :: logger, sublogger TYPE(cp_para_env_type), POINTER :: para_env TYPE(dft_control_type), POINTER :: dft_control @@ -194,7 +193,7 @@ RECURSIVE FUNCTION cp2k_run(input_declaration,input_file_name,output_unit,mpi_co was_present = .FALSE. NULLIFY(para_env, f_env, dft_control) CALL cp_para_env_create(para_env, group=mpi_comm,& - owns_group=.FALSE.,error=error) + owns_group=.FALSE.) IF(acc_get_ndevices() > 0) & CALL acc_set_active_device(MOD(para_env%mepos, acc_get_ndevices())) @@ -203,7 +202,7 @@ RECURSIVE FUNCTION cp2k_run(input_declaration,input_file_name,output_unit,mpi_co CALL pw_cuda_init() - CALL cp_dbcsr_init_lib (error=error) + CALL cp_dbcsr_init_lib () NULLIFY(globenv, force_env) @@ -211,65 +210,64 @@ RECURSIVE FUNCTION cp2k_run(input_declaration,input_file_name,output_unit,mpi_co ! parse the input input_file => read_input(input_declaration,input_file_name,initial_variables=empty_initial_variables, & - para_env=para_env,error=error) + para_env=para_env) CALL mp_sync(para_env%group) - glob_section => section_vals_get_subs_vals(input_file,"GLOBAL",error=error) - CALL section_vals_val_get(glob_section,"ECHO_INPUT",l_val=echo_input,& - error=error) - logger => cp_error_get_logger(error) + glob_section => section_vals_get_subs_vals(input_file,"GLOBAL") + CALL section_vals_val_get(glob_section,"ECHO_INPUT",l_val=echo_input) + logger => cp_get_default_logger() IF (echo_input) THEN CALL section_vals_write(input_file,& unit_nr=cp_logger_get_default_io_unit(logger),& - hide_root=.TRUE., hide_defaults=.FALSE., error=error) + hide_root=.TRUE., hide_defaults=.FALSE.) END IF - CALL check_cp2k_input(input_declaration,input_file,para_env=para_env,output_unit=output_unit,error=error) + CALL check_cp2k_input(input_declaration,input_file,para_env=para_env,output_unit=output_unit) root_section=>input_file CALL section_vals_val_get(input_file,"GLOBAL%PROGRAM_NAME",& - i_val=prog_name_id,error=error) + i_val=prog_name_id) CALL section_vals_val_get(input_file,"GLOBAL%RUN_TYPE",& - i_val=run_type_id,error=error) + i_val=run_type_id) IF (prog_name_id/=do_cp2k) THEN ! initial setup (cp2k does in in the creation of the force_env) - CALL globenv_create(globenv, error=error) + CALL globenv_create(globenv) ! XXXXXXXXX ! root_section => input_file ! XXXXXXXXX - CALL section_vals_retain(input_file,error=error) + CALL section_vals_retain(input_file) CALL cp2k_init(para_env, output_unit, globenv, input_file_name=input_file_name) - CALL cp2k_read(root_section,para_env,globenv,error=error) - CALL cp2k_setup(root_section,para_env, globenv,suberror) + CALL cp2k_read(root_section,para_env,globenv) + CALL cp2k_setup(root_section,para_env, globenv) END IF - CALL cp_dbcsr_config (root_section, error) + CALL cp_dbcsr_config (root_section) IF (output_unit > 0 .AND.& cp_logger_would_log(logger, cp_note_level)) THEN - CALL cp_dbcsr_print_config (unit_nr=output_unit, error=error) + CALL cp_dbcsr_print_config (unit_nr=output_unit) WRITE (UNIT=output_unit,FMT='()') ENDIF SELECT CASE (prog_name_id) CASE (do_atom) globenv%run_type_id = none_run - CALL atom_code(root_section,suberror) + CALL atom_code(root_section) CASE (do_optimize_input) - CALL run_optimize_input(input_declaration,root_section, para_env, suberror) + CALL run_optimize_input(input_declaration,root_section, para_env) CASE (do_swarm) - CALL run_swarm(input_declaration, root_section, para_env, globenv, input_file_name, suberror) + CALL run_swarm(input_declaration, root_section, para_env, globenv, input_file_name) CASE (do_farming) ! Hack: DBCSR should be uninitialized when entering farming. ! But, we don't want to change the public f77_interface. ! TODO: refactor cp2k's startup code - CALL cp_dbcsr_finalize_lib(group=mpi_comm, output_unit=0, error=error) + CALL cp_dbcsr_finalize_lib(group=mpi_comm, output_unit=0) CALL pw_cuda_finalize() - CALL farming_run(input_declaration, root_section, para_env, suberror ) - CALL cp_dbcsr_init_lib(error=error) + CALL farming_run(input_declaration, root_section, para_env) + CALL cp_dbcsr_init_lib() CALL pw_cuda_init() CASE (do_opt_basis) - CALL run_optimize_basis (input_declaration, root_section, para_env, suberror) + CALL run_optimize_basis (input_declaration, root_section, para_env) globenv%run_type_id = none_run CASE(do_cp2k) CALL create_force_env(new_env_id,& @@ -279,32 +277,32 @@ RECURSIVE FUNCTION cp2k_run(input_declaration,input_file_name,output_unit,mpi_co output_unit=output_unit,& owns_out_unit=.FALSE.,& input=input_file,ierr=ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) - CALL f_env_add_defaults(new_env_id,f_env,new_error=suberror,& + CPAssert(ierr==0,cp_failure_level,routineP,failure) + CALL f_env_add_defaults(new_env_id,f_env,& failure=failure,handle=f_env_handle) force_env => f_env%force_env - CALL force_env_get(force_env,globenv=globenv,error=suberror) - CALL globenv_retain(globenv,error=suberror) - CALL section_vals_val_get(force_env%force_env_section,"METHOD",i_val=method_name_id,error=error) + CALL force_env_get(force_env,globenv=globenv) + CALL globenv_retain(globenv) + CALL section_vals_val_get(force_env%force_env_section,"METHOD",i_val=method_name_id) CASE (do_test) - CALL lib_test(root_section,para_env,globenv,suberror) + CALL lib_test(root_section,para_env,globenv) CASE (do_tree_mc) ! TMC entry point - CALL do_tmc (input_declaration, root_section, para_env, globenv, error=suberror) + CALL do_tmc (input_declaration, root_section, para_env, globenv) CASE (do_tree_mc_ana) - CALL do_analyze_files(input_declaration, root_section, para_env, error=suberror ) + CALL do_analyze_files(input_declaration, root_section, para_env) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,suberror,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL section_vals_release(input_file,error=suberror) + CALL section_vals_release(input_file) SELECT CASE (globenv%run_type_id) CASE (pint_run) - CALL do_pint_run( para_env, root_section, input_declaration, globenv, error=suberror ) + CALL do_pint_run( para_env, root_section, input_declaration, globenv) CASE (none_run, tree_mc_run) ! do nothing CASE (driver_run) - CALL run_driver (force_env, globenv, error=suberror) + CALL run_driver (force_env, globenv) CASE (energy_run, energy_force_run) IF( method_name_id /= do_qs .AND.& method_name_id /= do_qmmm .AND.& @@ -313,102 +311,98 @@ RECURSIVE FUNCTION cp2k_run(input_declaration,input_file_name,output_unit,mpi_co CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Energy/Force run not available for all methods "//& CPSourceFileRef,& - suberror,failure) + failure) - sublogger => cp_error_get_logger(error) + sublogger => cp_get_default_logger() CALL cp_add_iter_level(sublogger%iter_info,"JUST_ENERGY",& - n_rlevel_new=iter_level,& - error=suberror) + n_rlevel_new=iter_level) ! loop over molecules to generate a molecular guess ! this procedure is initiated here to avoid passing globenv deep down ! the subroutine stack - IF (do_mol_loop(force_env=force_env,error=suberror)) & - CALL loop_over_molecules(globenv,force_env,error=suberror) + IF (do_mol_loop(force_env=force_env)) & + CALL loop_over_molecules(globenv,force_env) SELECT CASE(globenv%run_type_id) CASE (energy_run) - CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.,error=suberror) + CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.) CASE(energy_force_run) - CALL force_env_calc_energy_force(force_env,calc_force=.TRUE. ,error=suberror) + CALL force_env_calc_energy_force(force_env,calc_force=.TRUE.) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL cp_rm_iter_level(sublogger%iter_info,level_name="JUST_ENERGY",n_rlevel_att=iter_level,& - error=suberror) + CALL cp_rm_iter_level(sublogger%iter_info,level_name="JUST_ENERGY",n_rlevel_att=iter_level) CASE (mol_dyn_run) - CALL qs_mol_dyn ( force_env, globenv, error=suberror ) + CALL qs_mol_dyn ( force_env, globenv) CASE (geo_opt_run) - CALL cp_geo_opt(force_env,globenv,error=suberror) + CALL cp_geo_opt(force_env,globenv) CASE (cell_opt_run) - CALL cp_cell_opt(force_env,globenv,error=suberror) + CALL cp_cell_opt(force_env,globenv) CASE (mon_car_run) - CALL do_mon_car(force_env, globenv, input_declaration, input_file_name, error=suberror) + CALL do_mon_car(force_env, globenv, input_declaration, input_file_name) CASE (do_tamc) - CALL qs_tamc ( force_env, globenv, error=suberror ) + CALL qs_tamc ( force_env, globenv) CASE (electronic_spectra_run) IF(method_name_id /= do_qs) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Electron spectra available only with Quickstep. "//& CPSourceFileRef,& - suberror,failure) - CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.,& - error=suberror) - CALL tddfpt_calculation(force_env%qs_env, error=error) + failure) + CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.) + CALL tddfpt_calculation(force_env%qs_env) CASE (real_time_propagation) IF(method_name_id /= do_qs) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Real time propagation needs METHOD QS. "//& CPSourceFileRef,& - suberror,failure) - CALL get_qs_env(force_env%qs_env, dft_control=dft_control, error=error) + failure) + CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions=.TRUE. - CALL rt_prop_setup(force_env,error) + CALL rt_prop_setup(force_env) CASE (ehrenfest) IF(method_name_id /= do_qs) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Ehrenfest dynamics needs METHOD QS "//& CPSourceFileRef,& - suberror,failure) - CALL get_qs_env(force_env%qs_env, dft_control=dft_control, error=error) + failure) + CALL get_qs_env(force_env%qs_env, dft_control=dft_control) dft_control%rtp_control%fixed_ions=.FALSE. - CALL qs_mol_dyn ( force_env, globenv, error=suberror ) + CALL qs_mol_dyn ( force_env, globenv) CASE (bsse_run) - CALL do_bsse_calculation(force_env, globenv, error=suberror) + CALL do_bsse_calculation(force_env, globenv) CASE (linear_response_run) IF(method_name_id /= do_qs .AND. & method_name_id /= do_qmmm) & CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Property calculations by Linear Response only within the QS or QMMM program "//& CPSourceFileRef,& - suberror,failure) + failure) ! The Ground State is needed, it can be read from Restart - CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.,linres=.TRUE.,& - error=suberror) - CALL linres_calculation(force_env, error=suberror) + CALL force_env_calc_energy_force(force_env,calc_force=.FALSE.,linres=.TRUE.) + CALL linres_calculation(force_env) CASE (debug_run) SELECT CASE(method_name_id) CASE(do_qs, do_qmmm, do_fist) - CALL cp2k_debug_energy_and_forces(force_env, error=suberror) + CALL cp2k_debug_energy_and_forces(force_env) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "Debug run available only with QS, FIST, and QMMM program "//& CPSourceFileRef,& - suberror,failure) + failure) END SELECT CASE (vib_anal) - CALL vb_anal(root_section,input_declaration,para_env,globenv,error=suberror) + CALL vb_anal(root_section,input_declaration,para_env,globenv) CASE (do_band) - CALL neb(root_section,input_declaration,para_env,globenv,error=suberror) + CALL neb(root_section,input_declaration,para_env,globenv) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT !sample peak memory CALL m_memory() CALL pw_cuda_finalize() - CALL cp_dbcsr_finalize_lib(group=mpi_comm, output_unit=output_unit, error=error) + CALL cp_dbcsr_finalize_lib(group=mpi_comm, output_unit=output_unit) m_memory_max_mpi=m_memory_max CALL mp_max(m_memory_max_mpi,mpi_comm) @@ -420,24 +414,24 @@ RECURSIVE FUNCTION cp2k_run(input_declaration,input_file_name,output_unit,mpi_co IF (prog_name_id==do_cp2k) THEN f_env%force_env => force_env ! for mc - CALL globenv_retain(globenv,error=error)!mc - CALL globenv_release(force_env%globenv,error=error) !mc + CALL globenv_retain(globenv)!mc + CALL globenv_release(force_env%globenv) !mc force_env%globenv => globenv !mc - CALL f_env_rm_defaults(f_env,error=suberror,ierr=ierr,& + CALL f_env_rm_defaults(f_env,ierr=ierr,& handle=f_env_handle) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) + CPAssert(ierr==0,cp_failure_level,routineP,failure) CALL destroy_force_env(new_env_id,ierr=ierr) - CPAssert(ierr==0,cp_failure_level,routineP,error,failure) - CALL globenv_release(globenv,error=error) + CPAssert(ierr==0,cp_failure_level,routineP,failure) + CALL globenv_release(globenv) ELSE I_was_ionode=para_env%ionode - CALL cp2k_finalize(root_section,para_env,globenv,error=error) - CPPostconditionNoFail(globenv%ref_count==1,cp_failure_level,routineP,error) - CALL section_vals_release(root_section,error=error) - CALL globenv_release(globenv,error=error) + CALL cp2k_finalize(root_section,para_env,globenv) + CPPostconditionNoFail(globenv%ref_count==1,cp_failure_level,routineP) + CALL section_vals_release(root_section) + CALL globenv_release(globenv) END IF - CALL cp_para_env_release(para_env,error=error) + CALL cp_para_env_release(para_env) cp2k_run_OK = .NOT. failure END FUNCTION cp2k_run @@ -447,17 +441,15 @@ END FUNCTION cp2k_run !> \param input_declaration ... !> \param root_section ... !> \param para_env ... -!> \param error ... !> \author Joost VandeVondele !> \note !> needs to be part of this module as the cp2k_run -> farming_run -> cp2k_run !> calling style creates a hard circular dependency ! ***************************************************************************** - RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) + RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'farming_run', & routineP = moduleN//':'//routineN @@ -492,18 +484,18 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) CALL timeset(routineN,handle) NULLIFY(my_parser,g_section,g_data,default_units) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit=cp_print_key_unit_nr(logger,root_section,"FARMING%PROGRAM_RUN_INFO",& - extension=".log",error=error) + extension=".log") IF (output_unit>0) WRITE(output_unit,FMT="(T2,A)") "FARMING| Hi, welcome on this farm!" ALLOCATE(farming_env,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL init_farming_env(farming_env) ! remember where we started CALL m_getcwd(farming_env%cwd) - CALL farming_parse_input(farming_env,root_section,para_env,error) + CALL farming_parse_input(farming_env,root_section,para_env) ! the full mpi group is first split in a slave group and a master group, the latter being at most 1 process slave=.TRUE. @@ -514,7 +506,7 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) ALLOCATE(master_slave_partition(0:1)) master_slave_partition=(/1,para_env%num_pe-1/) ALLOCATE(group_distribution(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL mp_comm_split(para_env%group,slave_group,ngroups,group_distribution,& n_subgroups=2, group_partition=master_slave_partition) @@ -527,11 +519,11 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) master=.TRUE. ! on the master node, num_slaves corresponds to the size of the master group ! due to the mp_environ call. - CPPostcondition(num_slaves==1,cp_failure_level,routineP,error,failure) + CPPostcondition(num_slaves==1,cp_failure_level,routineP,failure) num_slaves=para_env%num_pe-1 slave_rank=-1 ENDIF - CPPostcondition(num_slaves==para_env%num_pe-1,cp_failure_level,routineP,error,failure) + CPPostcondition(num_slaves==para_env%num_pe-1,cp_failure_level,routineP,failure) ELSE ! all processes are slaves IF (output_unit>0) WRITE(output_unit,FMT="(T2,A)") "FARMING| using a slave-only setup" @@ -542,7 +534,7 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) ! keep track of which para_env rank is which slave/master ALLOCATE(slave_distribution(0:para_env%num_pe-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) slave_distribution=0 slave_distribution(para_env%mepos)=slave_rank CALL mp_sum(slave_distribution,para_env%group) @@ -555,7 +547,7 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) ! split the current communicator for the slaves ! in a new_group, new_size and new_rank according to the number of groups required according to the input ALLOCATE(group_distribution(0:num_slaves-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) group_distribution=-1 IF (slave) THEN IF (farming_env%group_size_wish_set) THEN @@ -567,7 +559,7 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) n_subgroups=farming_env%ngroup_wish,& group_partition=farming_env%group_partition) ELSE - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF CALL mp_environ(new_size,new_rank,new_group) ENDIF @@ -613,11 +605,11 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) ! and write the restart now, that's the point where the next job starts, even if this one is running iunit=cp_print_key_unit_nr(logger,root_section,"FARMING%RESTART",& - extension=".restart",error=error) + extension=".restart") IF (iunit>0) THEN WRITE(iunit,*) i_job_to_restart ENDIF - CALL cp_print_key_finished_output(iunit,logger,root_section,"FARMING%RESTART",error=error) + CALL cp_print_key_finished_output(iunit,logger,root_section,"FARMING%RESTART") ! this is the job range to be executed. @@ -671,7 +663,7 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) ENDDO ELSE ! master ALLOCATE(slave_status(0:ngroups-1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) slave_status=slave_status_wait ijob_current=ijob_start-1 @@ -718,14 +710,14 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) WRITE(output_unit,FMT=*) "" CALL m_flush(output_unit) ENDIF - CPPostcondition(todo.NE.do_deadlock,cp_failure_level,routineP,error,failure) + CPPostcondition(todo.NE.do_deadlock,cp_failure_level,routineP,failure) ENDIF ENDIF ENDDO DEALLOCATE(slave_status,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ELSE @@ -784,15 +776,15 @@ RECURSIVE SUBROUTINE farming_run(input_declaration,root_section,para_env, error) ! and message passing deallocate structures DEALLOCATE(group_distribution,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(slave_distribution,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! clean the farming env CALL deallocate_farming_env(farming_env) CALL cp_print_key_finished_output(output_unit,logger,root_section,& - "FARMING%PROGRAM_RUN_INFO", error=error) + "FARMING%PROGRAM_RUN_INFO") CALL timestop(handle) @@ -807,7 +799,7 @@ RECURSIVE SUBROUTINE execute_job(i) ! change to the new working directory CALL m_chdir(TRIM(farming_env%Job(i)%cwd),ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) ! generate a fresh call to cp2k_run IF (new_rank == 0) THEN @@ -815,26 +807,25 @@ RECURSIVE SUBROUTINE execute_job(i) IF (farming_env%Job(i)%output=="") THEN ! generate the output file WRITE(output_file,'(A12,I5.5)') "FARMING_OUT_",i - CALL parser_create(my_parser,file_name=TRIM(farming_env%Job(i)%input),error=error) + CALL parser_create(my_parser,file_name=TRIM(farming_env%Job(i)%input)) label="&GLOBAL" - CALL parser_search_string(my_parser,label,ignore_case=.TRUE.,found=found,error=error) + CALL parser_search_string(my_parser,label,ignore_case=.TRUE.,found=found) IF (found) THEN - CALL create_global_section(g_section,error=error) - CALL section_vals_create(g_data,g_section,error=error) - CALL cp_unit_set_create(default_units, "OUTPUT",error=error) - CALL section_vals_parse(g_data,my_parser,default_units,& - error=error) - CALL cp_unit_set_release(default_units,error=error) + CALL create_global_section(g_section) + CALL section_vals_create(g_data,g_section) + CALL cp_unit_set_create(default_units, "OUTPUT") + CALL section_vals_parse(g_data,my_parser,default_units) + CALL cp_unit_set_release(default_units) CALL section_vals_val_get(g_data,"PROJECT",& - c_val=str, error=error) + c_val=str) IF (str.NE."") output_file=TRIM(str)//".out" CALL section_vals_val_get(g_data,"OUTPUT_FILE_NAME",& - c_val=str,error=error) + c_val=str) IF (str.NE."") output_file=str - CALL section_vals_release(g_data,error=error) - CALL section_release(g_section,error=error) + CALL section_vals_release(g_data) + CALL section_release(g_section) END IF - CALL parser_release(my_parser,error=error) + CALL parser_release(my_parser) ELSE output_file=farming_env%Job(i)%output ENDIF @@ -857,19 +848,16 @@ RECURSIVE SUBROUTINE execute_job(i) ! change to the original working directory CALL m_chdir(TRIM(farming_env%cwd),ierr) - CPPostcondition(ierr==0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr==0,cp_failure_level,routineP,failure) END SUBROUTINE execute_job END SUBROUTINE farming_run ! ***************************************************************************** !> \brief writes a small html description of the cp2k input -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author joost [fawzi] ! ***************************************************************************** - SUBROUTINE write_cp2k_html_manual(error) - TYPE(cp_error_type), INTENT(inout) :: error + SUBROUTINE write_cp2k_html_manual() CHARACTER(len=*), PARAMETER :: routineN = 'write_cp2k_html_manual', & routineP = moduleN//':'//routineN @@ -881,11 +869,11 @@ SUBROUTINE write_cp2k_html_manual(error) failure=.FALSE. NULLIFY(root_section) - CALL create_cp2k_root_section(root_section,error=error) + CALL create_cp2k_root_section(root_section) ! remove the default keyword that ignores things outside the section - CALL keyword_release(root_section%keywords(0)%keyword,error=error) + CALL keyword_release(root_section%keywords(0)%keyword) - CALL section_describe_html(root_section,"InputReference",0,default_output_unit,error=error) + CALL section_describe_html(root_section,"InputReference",0,default_output_unit) CALL open_file(unit_number=unit_nr,file_name="index.html",& file_action="WRITE", file_status="REPLACE") @@ -984,13 +972,13 @@ SUBROUTINE write_cp2k_html_manual(error) WRITE(unit_nr,FMT='(A)') "A description of each section, and a list of keywords can be obtained clicking on the links. " WRITE(unit_nr,FMT='(A)') "
      " - CALL section_describe_index_html(root_section,"InputReference",unit_nr,error=error) + CALL section_describe_index_html(root_section,"InputReference",unit_nr) WRITE(unit_nr,FMT='(A)') '

    Back to the CP2K homepage' WRITE(unit_nr,FMT='(A)') "" CALL close_file(unit_nr) - CALL section_release(root_section,error=error) + CALL section_release(root_section) ! References CALL open_file(unit_number=unit_nr,file_name="references.html",& @@ -1016,11 +1004,9 @@ END SUBROUTINE write_cp2k_html_manual ! ***************************************************************************** !> \brief ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_xml_file(error) + SUBROUTINE write_xml_file() - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_xml_file', & routineP = moduleN//':'//routineN @@ -1031,8 +1017,8 @@ SUBROUTINE write_xml_file(error) failure = .FALSE. NULLIFY(root_section) - CALL create_cp2k_root_section(root_section,error=error) - CALL keyword_release(root_section%keywords(0)%keyword,error) + CALL create_cp2k_root_section(root_section) + CALL keyword_release(root_section%keywords(0)%keyword) CALL open_file(unit_number=unit_number,& file_name="cp2k_input.xml",& file_action="WRITE",& @@ -1050,9 +1036,9 @@ SUBROUTINE write_xml_file(error) " 0),cp_failure_level,routineP,error,failure) + CPPostcondition((is > 0),cp_failure_level,routineP,failure) ie = INDEX(html_entity_table(i),";") - 1 - CPPostcondition((ie >= is),cp_failure_level,routineP,error,failure) + CPPostcondition((ie >= is),cp_failure_level,routineP,failure) WRITE (UNIT=unit_number,FMT="(A)")& "" END DO @@ -1067,13 +1053,13 @@ SUBROUTINE write_xml_file(error) " "//TRIM(compile_date)//"",& " "//TRIM(compile_revision)//"" DO i=1,root_section%n_subsections - CALL write_section_xml(root_section%subsections(i)%section,1,unit_number,error) + CALL write_section_xml(root_section%subsections(i)%section,1,unit_number) END DO ! Append HTML entity and tag tables CALL write_html_tables(unit_number) WRITE (UNIT=unit_number,FMT="(A)") "" CALL close_file(unit_number=unit_number) - CALL section_release(root_section,error=error) + CALL section_release(root_section) ! References CALL open_file(unit_number=unit_number,file_name="references.html",& @@ -1122,16 +1108,15 @@ SUBROUTINE run_input(input_declaration,input_file_path,output_file_path,ierr,mpi INTEGER :: unit_nr LOGICAL :: failure, success - TYPE(cp_error_type) :: error TYPE(cp_para_env_type), POINTER :: para_env failure=.FALSE. IF (PRESENT(mpi_comm)) THEN NULLIFY(para_env) - CALL cp_para_env_create(para_env, group=mpi_comm, owns_group=.FALSE.,error=error) !XXXXXXXXXXXX uninitiliased error + CALL cp_para_env_create(para_env, group=mpi_comm, owns_group=.FALSE.) !XXXXXXXXXXXX uninitiliased error ELSE para_env => f77_default_para_env - CALL cp_para_env_retain(para_env,error=error) !XXXXXXXXXXXX uninitiliased error + CALL cp_para_env_retain(para_env) !XXXXXXXXXXXX uninitiliased error END IF IF (para_env%mepos==para_env%source) THEN IF (output_file_path=="__STD_OUT__") THEN @@ -1150,7 +1135,7 @@ SUBROUTINE run_input(input_declaration,input_file_path,output_file_path,ierr,mpi ELSE ierr=0 END IF - CALL cp_para_env_release(para_env,error=error) !XXXXXXXXXXXX uninitiliased error + CALL cp_para_env_release(para_env) !XXXXXXXXXXXX uninitiliased error END SUBROUTINE run_input END MODULE cp2k_runs diff --git a/src/start/cp2k_shell.F b/src/start/cp2k_shell.F index 0c8765ddb9..a16f7f7f65 100644 --- a/src/start/cp2k_shell.F +++ b/src/start/cp2k_shell.F @@ -67,7 +67,6 @@ PROGRAM cp2k_shell shift2,env_id,last_env_id,& n_atom,stat,n_atom2,pid,n_lines INTEGER :: sout, file_unit - TYPE(cp_error_type) :: error TYPE(cp_para_env_type), POINTER :: para_env TYPE(cp_logger_type), POINTER :: logger CHARACTER(LEN=default_path_length) :: cmdStr, inp_filename, out_filename @@ -147,7 +146,7 @@ PROGRAM cp2k_shell IF (ierr/=0) CALL mp_abort('init_cp2k failure') NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) pos_fact=1.0_dp e_fact=1.0_dp @@ -155,7 +154,7 @@ PROGRAM cp2k_shell harsh=.FALSE. failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() para_env => logger%para_env eof=.FALSE. @@ -559,7 +558,7 @@ PROGRAM cp2k_shell END IF END DO - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) CALL finalize_cp2k(finalize_mpi=.TRUE.,ierr=ierr) IF (ierr/=0) CALL mp_abort('finalize_cp2k failure') diff --git a/src/start/f77_int_low.F b/src/start/f77_int_low.F index eed75867ac..3c219f476d 100644 --- a/src/start/f77_int_low.F +++ b/src/start/f77_int_low.F @@ -53,17 +53,15 @@ SUBROUTINE cp_create_fenv(new_env_id,input_file_path,output_file_path,& USE f77_interface, ONLY: create_force_env USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type IMPLICIT NONE CHARACTER(len=*) :: input_file_path, output_file_path INTEGER :: new_env_id, ierr - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL create_force_env(new_env_id,input_declaration,input_file_path,output_file_path,ierr=ierr) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_create_fenv ! ***************************************************************************** @@ -79,17 +77,15 @@ SUBROUTINE cp_create_fenv_comm(new_env_id,input_file_path,output_file_path,& USE f77_interface, ONLY: create_force_env USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type IMPLICIT NONE CHARACTER(len=*) :: input_file_path, output_file_path INTEGER :: new_env_id, mpi_comm, ierr - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL create_force_env(new_env_id,input_declaration,input_file_path,output_file_path,mpi_comm,ierr=ierr) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_create_fenv_comm ! ***************************************************************************** @@ -307,17 +303,15 @@ SUBROUTINE cp_run_input(input_file_path,output_file_path,ierr) USE cp2k_runs, ONLY: run_input USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type IMPLICIT NONE CHARACTER(len=*) :: input_file_path, output_file_path INTEGER :: ierr - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL run_input(input_declaration,input_file_path,output_file_path,ierr=ierr) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_run_input ! ***************************************************************************** @@ -332,17 +326,15 @@ RECURSIVE SUBROUTINE cp_run_input_comm(input_file_path,output_file_path,& USE cp2k_runs, ONLY: run_input USE input_cp2k, ONLY: create_cp2k_root_section USE input_section_types, ONLY: section_type, section_release - USE cp_error_handling, ONLY: cp_error_type IMPLICIT NONE CHARACTER(len=*) :: input_file_path, output_file_path INTEGER :: mpi_comm, ierr - TYPE(cp_error_type) :: error TYPE(section_type), POINTER :: input_declaration NULLIFY(input_declaration) - CALL create_cp2k_root_section(input_declaration, error) + CALL create_cp2k_root_section(input_declaration) CALL run_input(input_declaration,input_file_path,output_file_path,ierr,mpi_comm) - CALL section_release(input_declaration,error=error) + CALL section_release(input_declaration) END SUBROUTINE cp_run_input_comm ! ***************************************************************************** diff --git a/src/start/input_cp2k.F b/src/start/input_cp2k.F index 46e532ab3e..d38c0c5474 100644 --- a/src/start/input_cp2k.F +++ b/src/start/input_cp2k.F @@ -70,13 +70,10 @@ MODULE input_cp2k ! ***************************************************************************** !> \brief creates the input structure of the file used by cp2k !> \param root_section the input structure to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_cp2k_root_section(root_section,error) + SUBROUTINE create_cp2k_root_section(root_section) TYPE(section_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_cp2k_root_section', & routineP = moduleN//':'//routineN @@ -88,63 +85,63 @@ SUBROUTINE create_cp2k_root_section(root_section,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(root_section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(root_section),cp_failure_level,routineP,failure) CALL section_create(root_section,name="__ROOT__",& description="input file of cp2k",n_keywords=0, n_subsections=10,& - repeats=.FALSE., error=error) + repeats=.FALSE.) NULLIFY(section) - CALL create_global_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_global_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_test_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_test_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_debug_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_debug_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_motion_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_motion_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_multi_force_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_multi_force_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_force_eval_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_force_eval_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_farming_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_farming_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_optimize_input_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_optimize_input_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_optimize_basis_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_optimize_basis_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_swarm_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_swarm_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_ext_restart_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_ext_restart_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_vib_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_vib_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) - CALL create_atom_section(section,error=error) - CALL section_add_subsection(root_section,section,error=error) - CALL section_release(section,error=error) + CALL create_atom_section(section) + CALL section_add_subsection(root_section,section) + CALL section_release(section) CALL timestop(handle) END SUBROUTINE create_cp2k_root_section @@ -153,13 +150,10 @@ END SUBROUTINE create_cp2k_root_section ! ***************************************************************************** !> \brief section with the tests of the libraries or external code that cp2k uses !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_test_section(section,error) + SUBROUTINE create_test_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_test_section', & routineP = moduleN//':'//routineN @@ -169,58 +163,58 @@ SUBROUTINE create_test_section(section,error) CALL section_create(section,name="TEST",& description="Tests to perform on the supported libraries.",& - n_keywords=7, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword, print_key) CALL keyword_create(keyword, name="MEMORY",& description="Set the maximum amount of memory allocated for a given test (in bytes)",& - usage="MEMORY ",default_r_val=256.e6_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MEMORY ",default_r_val=256.e6_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COPY",& description="Tests the performance to copy two vectors."//& "The results of these tests allow to determine the size of the cache "//& "of the CPU. This can be used to optimize the performance of the"//& "FFTSG library. Tests are repeated the given number of times.",& - usage="copy 10",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="copy 10",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MATMUL",& description="Tests the performance of different kinds of matrix matrix "//& "multiply kernels for the F95 INTRINSIC matmul. Matrices up to 2**N+1 will be tested. ",& - usage="matmul 10",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="matmul 10",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DGEMM",& description="Tests the performance of different kinds of matrix matrix "//& "multiply kernels for the BLAS INTRINSIC DGEMM. Matrices up to 2**N+1 will be tested. ",& - usage="DGEMM 10",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DGEMM 10",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FFT",& description="Tests the performance of all available FFT libraries for "//& "3D FFTs Tests are repeated the given number of times.",& - usage="fft 10",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="fft 10",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ERI",& description="Tests the performance and correctness of ERI libraries ",& - usage="eri 1",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="eri 1",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CLEBSCH_GORDON",variants=(/"CLEBSCH"/),& description="Tests the Clebsch-Gordon Coefficients. "//& "Tests are repeated the given number of times.",& - usage="clebsch_gordon 10",default_i_val=0,error=error) + usage="clebsch_gordon 10",default_i_val=0) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MPI",& description="Tests mpi, quickly adapted benchmark code,"//& @@ -228,52 +222,50 @@ SUBROUTINE create_test_section(section,error) "initialized communicator. This test will produce messages "//& "of the size 8*10**requested_size, where requested_size is the value "//& "given to this keyword",& - usage="mpi 6",default_i_val=0,error=error) + usage="mpi 6",default_i_val=0) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RANDOM_NUMBER_GENERATOR",variants=(/"rng"/),& description=" Tests the parallel random number generator (RNG)",& - usage="rng 1000000",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="rng 1000000",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"GRID_INFORMATION",& description="Controls the printing of information regarding the PW and RS grid structures"//& " (ONLY for TEST run).",& - print_level=medium_print_level,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="controls the printing of tests output",& - print_level=silent_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=silent_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) NULLIFY(subsection) - CALL create_rs_pw_transfer_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_rs_pw_transfer_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_eigensolver_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_eigensolver_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_pw_transfer_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_pw_transfer_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_cp_fm_gemm_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cp_fm_gemm_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_cp_dbcsr_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cp_dbcsr_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_test_section @@ -281,13 +273,10 @@ END SUBROUTINE create_test_section ! ***************************************************************************** !> \brief section to setup debugging parameter !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_debug_section(section,error) + SUBROUTINE create_debug_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_debug_section', & routineP = moduleN//':'//routineN @@ -297,52 +286,51 @@ SUBROUTINE create_debug_section(section,error) CALL section_create(section,name="DEBUG",& description="Section to setup parameters for debug runs.",& - n_keywords=7, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=7, n_subsections=0, repeats=.FALSE.) NULLIFY (keyword,print_key) CALL keyword_create(keyword, name="DEBUG_FORCES",& description="Activates the debugging of the atomic forces",& usage="DEBUG_FORCES {LOGICAL}",default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DEBUG_STRESS_TENSOR",& description="Activates the debugging of the stress tensor",& usage="DEBUG_STRESS_TENSOR {LOGICAL}",default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DX",& description="Increment for the calculation of the numerical derivatives",& - usage="DX {REAL}",default_r_val=0.001_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DX {REAL}",default_r_val=0.001_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EPS_NO_ERROR_CHECK",& description="The mismatch between the numerical and the "//& "analytical value is not checked for analytical "//& "values smaller than this threshold value",& - usage="EPS_NO_ERROR_CHECK {REAL}",default_r_val=1.0E-5_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EPS_NO_ERROR_CHECK {REAL}",default_r_val=1.0E-5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STOP_ON_MISMATCH",& description="Stop the debug run when a mismatch between the numerical and "//& "the analytical value is detected",& usage="STOP_ON_MISMATCH {LOGICAL}",default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of the DEBUG specific output",& - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_debug_section @@ -350,13 +338,10 @@ END SUBROUTINE create_debug_section ! ***************************************************************************** !> \brief creates the multiple force_eval section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_multi_force_section(section,error) + SUBROUTINE create_multi_force_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_multi_force_section', & routineP = moduleN//':'//routineN @@ -366,10 +351,10 @@ SUBROUTINE create_multi_force_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MULTIPLE_FORCE_EVALS",& description="Describes how to handle multiple force_evals.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="FORCE_EVAL_ORDER",& @@ -377,17 +362,17 @@ SUBROUTINE create_multi_force_section(section,error) " this does not need to be specified in this list, because it that takes into account only the real"//& " energy contributions",& usage="FORCE_EVAL_ORDER .. ", type_of_var=integer_t, n_var=-1,& - default_i_vals=(/1/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_vals=(/1/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MULTIPLE_SUBSYS",& description="Specify if force_eval have different subsys. In case they share the same subsys,"//& " it needs to be specified only in the MIXED force_eval (if using MIXED) or"//& " in the force_eval corresponding to first force_eval of the previous order (when not using MIXED).",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_multi_force_section @@ -395,13 +380,10 @@ END SUBROUTINE create_multi_force_section ! ***************************************************************************** !> \brief Creates the exteranal restart section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_ext_restart_section(section,error) + SUBROUTINE create_ext_restart_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ext_restart_section', & routineP = moduleN//':'//routineN @@ -411,217 +393,217 @@ SUBROUTINE create_ext_restart_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EXT_RESTART",& description="Section for external restart, specifies an external "//& "input file where to take positions,...",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="RESTART_FILE_NAME",variants=(/"EXTERNAL_FILE"/),& description="Specifies the name of restart file (or any other input file)"//& " to be read. Only fields relevant to a restart will be used"//& " (unless switched off with the keywords in this section)",& - default_lc_val=" ", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val=" ") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BINARY_RESTART_FILE_NAME",& variants=(/"BINARY_RESTART_FILE"/),& description="Specifies the name of an additional restart file "//& "from which selected input sections are read in binary format "//& "(see SPLIT_RESTART_FILE).",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_DEFAULT",& description="This keyword controls the default value for all possible "//& " restartable keywords, unless explicitly defined. For example setting"//& " this keyword to .FALSE. does not restart any quantity. If, at the "//& " same time, one keyword is set to .TRUE. only that quantity will be"//& - " restarted.", default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + " restarted.", default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_COUNTERS",& description="Restarts the counters in MD schemes",& - type_of_var=logical_t, lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t, lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_POS",& description="Takes the positions from the external file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_VEL",& description="Takes the velocities from the external file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_RANDOMG",& description="Restarts the random number generator from the external file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_SHELL_POS",& description="Takes the positions of the shells from the external file (only if shell-model)",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_CORE_POS",& description="Takes the positions of the cores from the external file (only if shell-model)",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_OPTIMIZE_INPUT_VARIABLES",& description="Restart with the optimize input variables",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_SHELL_VELOCITY",& description="Takes the velocities of the shells from the external file (only if shell-model)",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_CORE_VELOCITY",& description="Takes the velocities of the shells from the external file (only if shell-model)",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_BAROSTAT",& description="Restarts the barostat from the external file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_BAROSTAT_THERMOSTAT",& description="Restarts the barostat thermostat from the external file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_SHELL_THERMOSTAT",& description="Restarts the shell thermostat from the external file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_THERMOSTAT",& description="Restarts the nose thermostats of the particles "//& "from the EXTERNAL file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_CELL",& description="Restarts the cell (and cell_ref) "//& "from the EXTERNAL file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_METADYNAMICS",& description="Restarts hills from a previous metadynamics run "//& "from the EXTERNAL file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_WALKERS",& description="Restarts walkers informations from a previous metadynamics run "//& "from the EXTERNAL file",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_BAND",& description="Restarts positions and velocities of the Band.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_QMMM",& description="Restarts the following specific QMMM info: translation vectors.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_CONSTRAINT",& description="Restarts constraint section. It's necessary when doing restraint"//& " calculation to have a perfect energy conservation. For constraints only it's"//& " use is optional.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_BSSE",& description="Restarts information for BSSE calculations.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_DIMER",& description="Restarts information for DIMER geometry optimizations.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_AVERAGES",& description="Restarts information for AVERAGES.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_RTP",& description="Restarts information for REAL TIME PROPAGATION and EHRENFEST DYNAMICS.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CUSTOM_PATH",& description="Restarts the given path from the EXTERNAL file. Allows a major flexibility for restarts.",& - type_of_var=char_t,repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=char_t,repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! PIMD CALL keyword_create(keyword, name="RESTART_PINT_POS",& description="Restart bead positions from PINT%BEADS%COORD.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_PINT_VEL",& description="Restart bead velocities from PINT%BEADS%VELOCITY.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_PINT_NOSE",& description="Restart Nose thermostat for beads from PINT%NOSE.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_PINT_GLE",& description="Restart GLE thermostat for beads from PINT%GLE.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! PIMC CALL keyword_create(keyword, name="RESTART_HELIUM_POS",& description="Restart helium positions from PINT%HELIUM%COORD.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_HELIUM_PERMUTATION",& description="Restart helium permutation state from PINT%HELIUM%PERM.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_HELIUM_FORCE",& description="Restart helium forces exerted on the solute from PINT%HELIUM%FORCE.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_HELIUM_RNG",& description="Restarts helium random number generators from PINT%HELIUM%RNG_STATE.",& - type_of_var=logical_t,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=logical_t,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_HELIUM_DENSITIES",& description="Restarts helium density distributions from PINT%HELIUM%RHO.",& type_of_var=logical_t,lone_keyword_l_val=.TRUE.,& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ext_restart_section @@ -630,13 +612,10 @@ END SUBROUTINE create_ext_restart_section ! ***************************************************************************** !> \brief creates the farming section !> \param section the section to create -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_farming_section(section,error) + SUBROUTINE create_farming_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_farming_section', & routineP = moduleN//':'//routineN @@ -647,95 +626,93 @@ SUBROUTINE create_farming_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="farming",& description="Describes a farming job, in which multiple inputs are executed."//newline//& "The RUN_TYPE in the global section has to be set to NONE for FARMING."//newline//& "The different groups are executed in parallel. The jobs inside the same groups in series.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) NULLIFY(keyword, print_key) CALL keyword_create(keyword, name="MASTER_SLAVE",& description="If a master-slave setup should be employed, in which one process is used to distribute the tasks. "//& "This is most useful to load-balance if not all jobs have the same length, "//& "and a lot of CPUs/groups are availabe.",& - usage="MASTER_SLAVE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="MASTER_SLAVE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NGROUPS",variants=(/"NGROUP"/),& description="Gives the preferred number of working groups.",& - usage="ngroups 4", type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ngroups 4", type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GROUP_SIZE",& description="Gives the preferred size of a working group, "//& "groups will always be equal or larger than this size.",& - usage="group_size 2", default_i_val=8, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="group_size 2", default_i_val=8) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GROUP_PARTITION",& description="gives the exact number of processors for each group.",& - usage="group_partition 2 2 4 2 4 ", type_of_var=integer_t, n_var=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="group_partition 2 2 4 2 4 ", type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_JOBS_PER_GROUP",& variants=(/"MAX_JOBS"/),& description="maximum number of jobs executed per group",& - usage="max_step 4", default_i_val=HUGE(0)/32768, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="max_step 4", default_i_val=HUGE(0)/32768) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CYCLE",& description="If farming should process all jobs in a cyclic way, stopping only if MAX_JOBS_PER_GROUP is exceeded." ,& - usage="CYCLE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CYCLE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WAIT_TIME",& description="Time to wait [s] for a new task if no task is currently available, make this zero if no clock is available",& - usage="WAIT_TIME 0.1",default_r_val=0.5_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="WAIT_TIME 0.1",default_r_val=0.5_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(sub_section) CALL section_create(sub_section,name="JOB",& description="description of the jobs to be executed",& - repeats=.TRUE., error=error) + repeats=.TRUE.) CALL keyword_create(keyword,name="DIRECTORY",& description="the directory in which the job should be executed",& usage="DIRECTORY /my/path",& - default_lc_val=".",error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val=".") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="INPUT_FILE_NAME",& description="the filename of the input file",& usage="INPUT_FILE_NAME my_input.inp",& - default_lc_val="input.inp",error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="input.inp") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="OUTPUT_FILE_NAME",& description="the filename of the output file, if not specified will use the project name in the &GLOBAL section.",& usage="OUTPUT_FILE_NAME my_input.inp",& - default_lc_val="",error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="JOB_ID",& description="An ID used to indentify a job in DEPENDENCIES. "//& "JOB_IDs do not need to be unique, dependencies will be on all jobs with a given ID. "//& "If no JOB_ID is given, the index of the &JOB section in the input file will be used. ",& - usage="JOB_ID 13", type_of_var=integer_t, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="JOB_ID 13", type_of_var=integer_t) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="DEPENDENCIES",& description="specifies a list of JOB_IDs on which the current job depends. "//& @@ -749,53 +726,47 @@ SUBROUTINE create_farming_section(section,error) "Additionally, note that, on some file systems, "//& " output (restart) files might not be immediately available on all compute nodes,"//& "potentially resulting in unexpected failures.", & - usage="DEPENDENCIES 13 1 7",type_of_var=integer_t, n_var=-1, error=error) - CALL section_add_keyword(sub_section,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section, sub_section, error=error) - CALL section_release(sub_section,error=error) + usage="DEPENDENCIES 13 1 7",type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(sub_section,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section, sub_section) + CALL section_release(sub_section) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="controls the printing of FARMING specific output",& - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL keyword_create(keyword, name="DO_RESTART",& description="Restart a farming job (and should pick up where the previous left off)",& - usage="DO_RESTART",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DO_RESTART",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_FILE_NAME",& description="Name of the restart file to use for restarting a FARMING run. If not "//& "specified the name is determined from PROJECT name.",& - usage="RESTART_FILE_NAME ", type_of_var=lchar_t,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="RESTART_FILE_NAME ", type_of_var=lchar_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"RESTART",& description="controls the printing of the restart for FARMING.",& - print_level=low_print_level,add_last=add_last_numeric,filename="FARMING",& - error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="FARMING") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_farming_section ! ***************************************************************************** !> \brief creates the rs_pw_transfer section for use in the test section !> \param section ... -!> \param error ... !> \date 2008-03-09 !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_rs_pw_transfer_section(section,error) + SUBROUTINE create_rs_pw_transfer_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_rs_pw_transfer_section', & @@ -807,42 +778,41 @@ SUBROUTINE create_rs_pw_transfer_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="RS_PW_TRANSFER",& description="Describes how to benchmark the rs_pw_transfer routines.",& - n_keywords=1, n_subsections=0, repeats=.FALSE.,& - error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="GRID",& description="Specify the number of grid points (not all grid points are allowed)",& usage="GRID_DIMENSIONS 128 128 128", type_of_var=integer_t, n_var=3,& - default_i_vals=(/128,128,128/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_vals=(/128,128,128/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HALO_SIZE",& description="number of grid points of the halo",& - usage="HALO_SIZE 17",default_i_val=17,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="HALO_SIZE 17",default_i_val=17) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_LOOP",& description="Number of rs_pw_transfers being timed",& - usage="N_LOOP 100",default_i_val=10,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_LOOP 100",default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RS2PW",& description="should the direction be rs2pw (pw2rs otherwise)",& - usage="rs2pw TRUE",default_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="rs2pw TRUE",default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) - CALL create_rsgrid_section(subsection,error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_rsgrid_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_rs_pw_transfer_section @@ -850,13 +820,11 @@ END SUBROUTINE create_rs_pw_transfer_section ! ***************************************************************************** !> \brief creates the rs_pw_transfer section for use in the test section !> \param section ... -!> \param error ... !> \date 2008-03-09 !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_pw_transfer_section(section,error) + SUBROUTINE create_pw_transfer_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_pw_transfer_section', & routineP = moduleN//':'//routineN @@ -866,25 +834,24 @@ SUBROUTINE create_pw_transfer_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PW_TRANSFER",& description="Benchmark and test the pw_transfer routines.",& - n_keywords=1, n_subsections=0, repeats=.TRUE.,& - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="GRID",& description="Specify the number of grid points (not all grid points are allowed)",& usage="GRID_DIMENSIONS 128 128 128", type_of_var=integer_t, n_var=3,& - default_i_vals=(/128,128,128/), error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_vals=(/128,128,128/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_LOOP",& description="Number of pw_transfers (backward&forward) being timed",& - usage="N_LOOP 100",default_i_val=100,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_LOOP 100",default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_GRID",& description="What kind of PW_GRID should be employed",& @@ -892,31 +859,30 @@ SUBROUTINE create_pw_transfer_section(section,error) enum_c_vals=s2a("SPHERICAL","NS-FULLSPACE","NS-HALFSPACE"),& enum_desc=s2a("- not tested"," tested"," - not tested"),& enum_i_vals=(/ do_pwgrid_spherical, do_pwgrid_ns_fullspace,do_pwgrid_ns_halfspace/),& - default_i_val=do_pwgrid_ns_fullspace, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_pwgrid_ns_fullspace) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_GRID_LAYOUT_ALL",& description="loop overal all PW_GRID_LAYOUTs that are compatible with a given number of CPUs ",& - usage="PW_GRID_LAYOUT_ALL",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="PW_GRID_LAYOUT_ALL",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DEBUG",& description="Do the FFT in debug mode in all cases",& - usage="DEBUG",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="DEBUG",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_GRID_LAYOUT",& description="Expert use only, leave the default..."//& "Can be used to set the distribution for ray-distributed FFT.",& usage="PW_GRID_LAYOUT",& repeats=.FALSE.,n_var=2,& - default_i_vals=(/-1,-1/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_vals=(/-1,-1/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PW_GRID_BLOCKED",& description="Expert use only, leave the default..."//& @@ -925,9 +891,9 @@ SUBROUTINE create_pw_transfer_section(section,error) enum_c_vals=s2a("FREE","TRUE","FALSE"),& enum_desc=s2a("CP2K will select the optimal value","blocked","not blocked"),& enum_i_vals=(/do_pw_grid_blocked_free,do_pw_grid_blocked_true,do_pw_grid_blocked_false/),& - default_i_val=do_pw_grid_blocked_false, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_pw_grid_blocked_false) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_pw_transfer_section @@ -936,13 +902,11 @@ END SUBROUTINE create_pw_transfer_section ! ***************************************************************************** !> \brief creates the cp_fm_gemm section for use in the test section !> \param section ... -!> \param error ... !> \date 2009-06-15 !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_cp_fm_gemm_section(section,error) + SUBROUTINE create_cp_fm_gemm_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_cp_fm_gemm_section', & routineP = moduleN//':'//routineN @@ -952,78 +916,77 @@ SUBROUTINE create_cp_fm_gemm_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CP_FM_GEMM",& description="Benchmark and test the cp_fm_gemm routines by multiplying C=A*B ",& - n_keywords=1, n_subsections=0, repeats=.TRUE.,& - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="N_LOOP",& description="Number of cp_fm_gemm operations being timed (useful for small matrices).",& - usage="N_LOOP 10",default_i_val=10,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_LOOP 10",default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Dimension 1 of C",& - usage="A 1024",default_i_val=256,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="A 1024",default_i_val=256) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="M",& description="Inner dimension M ",& - usage="A 1024",default_i_val=256,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="A 1024",default_i_val=256) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N",& description="Dimension 2 of C",& - usage="A 1024",default_i_val=256,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="A 1024",default_i_val=256) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NROW_BLOCK",& description="block_size for rows",& - usage="nrow_block 64",default_i_val=32,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="nrow_block 64",default_i_val=32) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NCOL_BLOCK",& description="block_size for cols",& - usage="nrow_block 64",default_i_val=32,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="nrow_block 64",default_i_val=32) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ROW_MAJOR",& description="Use a row major blacs grid",& - usage="ROW_MAJOR .FALSE.",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ROW_MAJOR .FALSE.",default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FORCE_BLOCKSIZE",& description="Forces the blocksize, even if this implies that a few processes might have no data",& - usage="FORCE_BLOCKSIZE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FORCE_BLOCKSIZE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="GRID_2D",& description="Explicitly set the blacs 2D processor layout."//& " If the product differs from the number of MPI ranks,"//& " it is ignored and a default nearly square layout is used.", n_var=2,& - usage="GRID_2D 64 16 ",default_i_vals=(/1, 1/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="GRID_2D 64 16 ",default_i_vals=(/1, 1/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRANSA",& description="Transpose matrix A",& - usage="TRANSA",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TRANSA",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRANSB",& description="Transpose matrix B",& - usage="TRANSB",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TRANSB",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_cp_fm_gemm_section @@ -1031,13 +994,11 @@ END SUBROUTINE create_cp_fm_gemm_section ! ***************************************************************************** !> \brief creates the eigensolver section for use in the test section !> \param section ... -!> \param error ... !> \date 2010-03-10 !> \author Joost VandeVondele ! ***************************************************************************** - SUBROUTINE create_eigensolver_section(section,error) + SUBROUTINE create_eigensolver_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_eigensolver_section', & routineP = moduleN//':'//routineN @@ -1047,24 +1008,23 @@ SUBROUTINE create_eigensolver_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="EIGENSOLVER",& description="Benchmark and test the eigensolver routines.",& - n_keywords=1, n_subsections=0, repeats=.TRUE.,& - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="N",& description="Dimension of the square matrix",& - usage="N 1024",default_i_val=256,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N 1024",default_i_val=256) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N_LOOP",& description="Number of operations being timed (useful for small matrices).",& - usage="N_LOOP 10",default_i_val=10,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_LOOP 10",default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIAG_METHOD",& description="Diagonalization strategy",& @@ -1072,15 +1032,15 @@ SUBROUTINE create_eigensolver_section(section,error) enum_c_vals=s2a("syevd","syevx"),& enum_desc=s2a("(sca)lapacks syevd","(sca)lapacks syevx"),& enum_i_vals=(/ do_diag_syevd, do_diag_syevx/),& - default_i_val=do_diag_syevd, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_diag_syevd) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EIGENVALUES",& description="number of eigenvalues to be computed (all=<0) ",& - usage="EIGENVALUES 13",default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="EIGENVALUES 13",default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INIT_METHOD",& description="Initialization approach",& @@ -1088,9 +1048,9 @@ SUBROUTINE create_eigensolver_section(section,error) enum_c_vals=s2a("random","read"),& enum_desc=s2a("use a random initial matrix", "read a matrix from file MATRIX"),& enum_i_vals=(/ do_mat_random, do_mat_read/),& - default_i_val=do_mat_random, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_mat_random) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_eigensolver_section @@ -1098,13 +1058,11 @@ END SUBROUTINE create_eigensolver_section ! ***************************************************************************** !> \brief creates the cp_dbcsr section for use in the test section !> \param section ... -!> \param error ... !> \date 2010-02-08 !> \author Urban Borstnik ! ***************************************************************************** - SUBROUTINE create_cp_dbcsr_section(section,error) + SUBROUTINE create_cp_dbcsr_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_cp_dbcsr_section', & routineP = moduleN//':'//routineN @@ -1114,18 +1072,17 @@ SUBROUTINE create_cp_dbcsr_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="CP_DBCSR",& description="Benchmark and test the cp_dbcsr routines",& - n_keywords=1, n_subsections=0, repeats=.TRUE.,& - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="N_LOOP",& description="Number of operations being timed (useful for small matrices).",& - usage="N_LOOP 10",default_i_val=10,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="N_LOOP 10",default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DATA_TYPE",& description="Data type of the matrices",& @@ -1138,10 +1095,9 @@ SUBROUTINE create_cp_dbcsr_section(section,error) "Real (Single Precision)",& "Real (Double Precision)",& "Complex (Single Precision)",& - "Complex (Double Precision)"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Complex (Double Precision)")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEST_TYPE",& description="Which part of DBCSR is tested",& @@ -1152,127 +1108,126 @@ SUBROUTINE create_cp_dbcsr_section(section,error) enum_desc=s2a(& "Run matrix multiplications",& "Run the Arnoldi eigenvalue routines (acts as check for the matrix vector part as well)",& - "Run binary IO checks"),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "Run binary IO checks")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="M",& description="Dimension 1 of C",& - usage="A 1024",default_i_val=256,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="A 1024",default_i_val=256) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="N",& description="Dimension 2 of C",& - usage="A 1024",default_i_val=256,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="A 1024",default_i_val=256) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="K",& description="Inner dimension M ",& - usage="A 1024",default_i_val=256,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="A 1024",default_i_val=256) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRANSA",& description="Transpose matrix A",& - usage="TRANSA",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TRANSA",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRANSB",& description="Transpose matrix B",& - usage="TRANSB",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TRANSB",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BS_M",& description="Row block sizes of C", n_var=-1,& - usage="BS_M 1 13 2 5",default_i_vals=(/1, 13, 2, 15/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BS_M 1 13 2 5",default_i_vals=(/1, 13, 2, 15/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BS_N",& description="Column block sizes of C", n_var=-1,& - usage="BS_N 1 13 2 5",default_i_vals=(/1, 13, 2, 15/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BS_N 1 13 2 5",default_i_vals=(/1, 13, 2, 15/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BS_K",& description="Block sizes of inner dimension", n_var=-1,& - usage="BS_K 1 13 2 5",default_i_vals=(/1, 13, 2, 15/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BS_K 1 13 2 5",default_i_vals=(/1, 13, 2, 15/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATYPE",& description="Matrix A type",& - usage="ATYPE N",default_c_val='N',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ATYPE N",default_c_val='N') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BTYPE",& description="Matrix B type",& - usage="BTYPE N",default_c_val='N',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BTYPE N",default_c_val='N') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CTYPE",& description="Matrix C type",& - usage="CTYPE N",default_c_val='N',error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="CTYPE N",default_c_val='N') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NPROC",& description="Number of processors to test", n_var=-1,& - usage="NPROC 128 16 1",default_i_vals=(/0/),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="NPROC 128 16 1",default_i_vals=(/0/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KEEPSPARSE",& description="Keep product sparse",& - usage="KEEPSPARSE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="KEEPSPARSE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ASPARSITY",& description="Sparsity of A matrix",& - usage="ASPARSITY 70",default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ASPARSITY 70",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BSPARSITY",& description="Sparsity of B matrix",& - usage="ASPARSITY 80",default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ASPARSITY 80",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CSPARSITY",& description="Sparsity of C matrix",& - usage="ASPARSITY 90",default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ASPARSITY 90",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA",& description="Multiplication factor",& - usage="ALPHA 2.0",default_r_val=1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALPHA 2.0",default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BETA",& description="Product premultiplication factor",& - usage="BETA 1.0",default_r_val=0.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BETA 1.0",default_r_val=0.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FILTER_EPS",& description="Threshold for on-the-fly and final filtering.",& - usage="FILTER_EPS 1.0",default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="FILTER_EPS 1.0",default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALWAYS_CHECKSUM",& description="perform a checksum after each multiplication",& - usage="ALWAYS_CHECKSUM",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ALWAYS_CHECKSUM",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_cp_dbcsr_section diff --git a/src/start/input_cp2k_motion.F b/src/start/input_cp2k_motion.F index dbd7dac48b..09568833c6 100644 --- a/src/start/input_cp2k_motion.F +++ b/src/start/input_cp2k_motion.F @@ -64,13 +64,10 @@ MODULE input_cp2k_motion ! ***************************************************************************** !> \brief creates the motion section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - SUBROUTINE create_motion_section(section,error) + SUBROUTINE create_motion_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_motion_section', & routineP = moduleN//':'//routineN @@ -80,79 +77,76 @@ SUBROUTINE create_motion_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="motion",& description="This section defines a set of tool connected with the motion of the nuclei.",& - n_keywords=1, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(subsection) CALL create_geoopt_section(subsection,label="GEO_OPT",& description="This section sets the environment of the geometry optimizer.",& - just_optimizers=.FALSE.,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + just_optimizers=.FALSE.) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_cell_opt_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cell_opt_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_shellcore_opt_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_shellcore_opt_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_md_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_md_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_driver_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_driver_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_fe_section(subsection,error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_fe_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_constraint_section(subsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_constraint_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_fp_section(subsection,error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_fp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_mc_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_TMC_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_TMC_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_pint_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_pint_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_band_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_band_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_motion_print_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_motion_print_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_motion_section ! ***************************************************************************** !> \brief creates the Monte Carlo section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_mc_section(section,error) + SUBROUTINE create_mc_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mc_section', & routineP = moduleN//':'//routineN @@ -163,205 +157,205 @@ SUBROUTINE create_mc_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="mc",& description="This section sets parameters to set up a MonteCarlo calculation.",& - n_keywords=10, n_subsections=2, repeats=.FALSE., error=error) + n_keywords=10, n_subsections=2, repeats=.FALSE.) NULLIFY(keyword,subsection) CALL keyword_create(keyword, name="NSTEP",& description="Specifies the number of MC cycles.",& usage="NSTEP {integer}",& - default_i_val=100,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=100) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IPRINT",& description="Prints coordinate/cell/etc information every IPRINT steps.",& usage="IPRINT {integer}",& - default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NMOVES",& description="Specifies the number of classical moves between energy evaluations. ",& usage="NMOVES {integer}",& - default_i_val=4,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=4) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NSWAPMOVES",& description="How many insertions to try per swap move.",& usage="NSWAPMOVES {integer}",& - default_i_val=16,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=16) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LBIAS",& description="Dictates if we presample moves with a different potential.",& usage="LBIAS {logical}",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LSTOP",& description="Makes nstep in terms of steps, instead of cycles.",& usage="LSTOP {logical}",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LDISCRETE",& description="Changes the volume of the box in discrete steps, one side at a time.",& usage="LDISCRETE {logical}",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART",& description="Read initial configuration from restart file.",& usage="RESTART {logical}",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NVIRIAL",& description="Use this many random orientations to compute the second virial coefficient (ENSEMBLE=VIRIAL)",& usage="NVIRIAL {integer}",& - default_i_val=1000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENSEMBLE",& description="Specify the type of simulation",& usage="PROGRAM (TRADITIONAL|GEMC_NVT|GEMC_NPT|VIRIAL)",& enum_c_vals=s2a( "TRADITIONAL","GEMC_NVT","GEMC_NPT","VIRIAL"),& enum_i_vals=(/do_mc_traditional,do_mc_gemc_nvt,do_mc_gemc_npt,do_mc_virial/),& - default_i_val=do_mc_traditional,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=do_mc_traditional) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_FILE_NAME",& description="Name of the restart file for MC information.",& usage="RESTART_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOVES_FILE_NAME",& description="The file to print the move statistics to.",& usage="MOVES_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MOLECULES_FILE_NAME",& description="The file to print the number of molecules to.",& usage="MOLECULES_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="COORDINATE_FILE_NAME",& description="The file to print the current coordinates to.",& usage="COORDINATE_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY_FILE_NAME",& description="The file to print current energies to.",& usage="ENERGY_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DATA_FILE_NAME",& description="The file to print current configurational info to.",& usage="DATA_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CELL_FILE_NAME",& description="The file to print current cell length info to.",& usage="CELL_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_DISP_FILE_NAME",& description="The file to print current maximum displacement info to.",& usage="MAX_DISP_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BOX2_FILE_NAME",& description="For GEMC, the name of the input file for the other box.",& usage="BOX2_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRESSURE",& description="The pressure for NpT simulations, in bar.",& usage="PRESSURE {real}",& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE",& description="The temperature of the simulation, in Kelvin.",& usage="TEMPERATURE {real}",& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VIRIAL_TEMPS",& description="The temperatures you wish to compute the virial coefficient for. Only used if ensemble=VIRIAL.",& usage="VIRIAL_TEMPS {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DISCRETE_STEP",& description="The size of the discrete volume move step, in angstroms.",& usage="DISCRETE_STEP {real}",& - default_r_val=1.0E0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ETA",& description="The free energy bias (in Kelvin) for swapping a molecule of each type into this box.",& usage="ETA {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RANDOMTOSKIP",& description="Number of random numbers from the acceptance/rejection stream to skip",& usage="RANDOMTOSKIP {integer}",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_avbmc_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_avbmc_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_move_prob_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_move_prob_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_update_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_update_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_max_disp_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_max_disp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_mc_section @@ -369,13 +363,10 @@ END SUBROUTINE create_mc_section ! ***************************************************************************** !> \brief ... !> \param section will contain the AVBMC parameters for MC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_avbmc_section(section, error) + SUBROUTINE create_avbmc_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_avbmc_section', & routineP = moduleN//':'//routineN @@ -385,43 +376,43 @@ SUBROUTINE create_avbmc_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="avbmc",& description="Parameters for Aggregation Volume Bias Monte Carlo (AVBMC) "//& "which explores cluster formation and destruction. "//& "Chen and Siepmann, J. Phys. Chem. B 105, 11275-11282 (2001).",& - n_keywords=5, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword ) CALL keyword_create(keyword, name="PBIAS",& description="The probability of swapping to an inner region in an AVBMC swap move for each molecule type.",& usage="PBIAS {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVBMC_ATOM",& description="The target atom for an AVBMC swap move for each molecule type.",& usage="AVBMC_ATOM {integer} {integer} ... ",& - n_var=-1,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVBMC_RMIN",& description="The inner radius for an AVBMC swap move, in angstroms for every molecule type.",& usage="AVBMC_RMIN {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="AVBMC_RMAX",& description="The outer radius for an AVBMC swap move, in angstroms, for every molecule type.",& usage="AVBMC_RMAX {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_avbmc_section @@ -429,13 +420,10 @@ END SUBROUTINE create_avbmc_section !> \brief ... !> \param section will contain the probabilities for attempting each move !> type in Monte Carlo -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_move_prob_section(section, error) + SUBROUTINE create_move_prob_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_move_prob_section', & routineP = moduleN//':'//routineN @@ -446,63 +434,63 @@ SUBROUTINE create_move_prob_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="move_probabilities",& description="Parameters for fraction of moves performed for each move type.",& - n_keywords=5, n_subsections=2, repeats=.FALSE., error=error) + n_keywords=5, n_subsections=2, repeats=.FALSE.) NULLIFY(keyword,subsection ) CALL keyword_create(keyword, name="PMHMC",& description="The probability of attempting a hybrid MC move.",& usage="PMHMC {real}",& - type_of_var=real_t, default_r_val=0.0E0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, default_r_val=0.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMTRANS",& description="The probability of attempting a molecule translation.",& usage="PMTRANS {real}",& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMAVBMC",& description="The probability of attempting an AVBMC swap move.",& usage="PMAVBMC {real}",& - default_r_val=0.0E0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMTRAION",& description="The probability of attempting a conformational change.",& usage="PMTRAION {real}",& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMSWAP",& description="The probability of attempting a swap move.",& usage="PMSWAP {real}",& - type_of_var=real_t, default_r_val=0.0E0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, default_r_val=0.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMVOLUME",& description="The probability of attempting a volume move.",& usage="PMVOLUME {real}",& - type_of_var=real_t, default_r_val=0.0E0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, default_r_val=0.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_mol_prob_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mol_prob_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_box_prob_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_box_prob_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_move_prob_section @@ -510,13 +498,10 @@ END SUBROUTINE create_move_prob_section !> \brief ... !> \param section will contain the probabilities for attempting various moves !> on the various molecule types present in the system -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_mol_prob_section(section, error) + SUBROUTINE create_mol_prob_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mol_prob_section', & routineP = moduleN//':'//routineN @@ -526,49 +511,49 @@ SUBROUTINE create_mol_prob_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="mol_probabilities",& description="Probabilities of attempting various moves types on "//& "the various molecular types present in the simulation.",& - n_keywords=5, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword ) CALL keyword_create(keyword, name="PMAVBMC_MOL",& description="The probability of attempting an AVBMC swap move on each molecule type.",& usage="PMAVBMC_MOL {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMSWAP_MOL",& description="The probability of attempting a molecule swap of a given molecule type.",& usage="PMSWAP_MOL {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMROT_MOL",& description="The probability of attempting a molecule rotation of a given molecule type.",& usage="PMROT_MOL {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMTRAION_MOL",& description="The probability of attempting a conformational change of a given molecule type.",& usage="PMTRAION_MOL {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMTRANS_MOL",& description="The probability of attempting a molecule translation of a given molecule type.",& usage="PMTRANS_MOL {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mol_prob_section @@ -576,13 +561,10 @@ END SUBROUTINE create_mol_prob_section !> \brief ... !> \param section will contain the probabilities for attempting various moves !> on the box where the variable is present -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_box_prob_section(section, error) + SUBROUTINE create_box_prob_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_box_prob_section', & routineP = moduleN//':'//routineN @@ -592,28 +574,28 @@ SUBROUTINE create_box_prob_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BOX_PROBABILITIES",& description="Probabilities of attempting various moves types on "//& "the box.",& - n_keywords=2, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword ) CALL keyword_create(keyword, name="PMHMC_BOX",& description="The probability of attempting a HMC move on this box.",& usage="PMHMC_BOX {real}",& - type_of_var=real_t, default_r_val=1.0E0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, default_r_val=1.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PMVOL_BOX",& description="The probability of attempting a volume move on this box (GEMC_NpT).",& usage="PMVOL_BOX {real}",& - type_of_var=real_t, default_r_val=1.0E0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t, default_r_val=1.0E0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_box_prob_section @@ -622,13 +604,10 @@ END SUBROUTINE create_box_prob_section !> \brief ... !> \param section will contain the frequency for updating maximum !> displacements for various moves -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_update_section(section, error) + SUBROUTINE create_update_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_update_section', & routineP = moduleN//':'//routineN @@ -638,28 +617,28 @@ SUBROUTINE create_update_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MOVE_UPDATES",& description="Frequency for updating move maximum displacements.",& - n_keywords=2, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword ) CALL keyword_create(keyword, name="IUPVOLUME",& description="Every iupvolume steps update maximum volume displacement.",& usage="IUPVOLUME {integer}",& - default_i_val=10000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=10000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IUPTRANS",& description="Every iuptrans steps update maximum translation/rotation/" //& "configurational changes.",& usage="IUPTRANS {integer}",& - default_i_val=10000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=10000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_update_section @@ -667,13 +646,10 @@ END SUBROUTINE create_update_section ! ***************************************************************************** !> \brief ... !> \param section will contain the maximum displacements for various moves -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_max_disp_section(section, error) + SUBROUTINE create_max_disp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_max_disp_section', & routineP = moduleN//':'//routineN @@ -683,21 +659,21 @@ SUBROUTINE create_max_disp_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="max_displacements",& description="The maximum displacements for all attempted moves.",& - n_keywords=1, n_subsections=2, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=2, repeats=.FALSE.) NULLIFY(subsection) - CALL create_mol_disp_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_mol_disp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_box_disp_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_box_disp_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_max_disp_section @@ -705,13 +681,10 @@ END SUBROUTINE create_max_disp_section !> \brief ... !> \param section will contain the maximum displacements for all moves which !> require a value for each molecule type -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_mol_disp_section(section, error) + SUBROUTINE create_mol_disp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_mol_disp_section', & routineP = moduleN//':'//routineN @@ -721,49 +694,49 @@ SUBROUTINE create_mol_disp_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="mol_displacements",& description="Maximum displacements for every move type that requires "//& "a value for each molecular type in the simulation.",& - n_keywords=5, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=5, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword ) CALL keyword_create(keyword, name="RMBOND",& description="Maximum bond length displacement, in angstroms, for each molecule type.",& usage="RMBOND {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMANGLE",& description="Maximum bond angle displacement, in degrees, for each molecule type.",& usage="RMANGLE {real} {real} ...",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMDIHEDRAL",& description="Maximum dihedral angle distplacement, in degrees, for each molecule type.",& usage="RMDIHEDRAL {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMROT",& description="Maximum rotational displacement, in degrees, for each molecule type.",& usage="RMROT {real} {real} ... ",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMTRANS",& description="Maximum translational displacement, in angstroms, for each molecule type.",& usage="RMTRANS {real} {real} ...",& - n_var=-1,type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_mol_disp_section @@ -771,13 +744,10 @@ END SUBROUTINE create_mol_disp_section !> \brief ... !> \param section will contain the maximum displacements for any move that !> is done on each simulation box -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author matt ! ***************************************************************************** - SUBROUTINE create_box_disp_section(section, error) + SUBROUTINE create_box_disp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_box_disp_section', & routineP = moduleN//':'//routineN @@ -787,21 +757,21 @@ SUBROUTINE create_box_disp_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="BOX_DISPLACEMENTS",& description="Maximum displacements for any move that is performed on each" // & " simulation box.",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword ) CALL keyword_create(keyword, name="RMVOLUME",& description="Maximum volume displacement, in angstrom**3.",& usage="RMVOLUME {real}",& - type_of_var=real_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_box_disp_section @@ -812,15 +782,12 @@ END SUBROUTINE create_box_disp_section !> \param label ... !> \param description ... !> \param just_optimizers ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author teo ! ***************************************************************************** - RECURSIVE SUBROUTINE create_geoopt_section(section,label,description,just_optimizers,error) + RECURSIVE SUBROUTINE create_geoopt_section(section,label,description,just_optimizers) TYPE(section_type), POINTER :: section CHARACTER(LEN=*), INTENT(IN) :: label, description LOGICAL, INTENT(IN) :: just_optimizers - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_geoopt_section', & routineP = moduleN//':'//routineN @@ -831,9 +798,9 @@ RECURSIVE SUBROUTINE create_geoopt_section(section,label,description,just_optimi failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name=label, description=description,& - n_keywords=1, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword) IF (.NOT.just_optimizers) THEN @@ -844,9 +811,9 @@ RECURSIVE SUBROUTINE create_geoopt_section(section,label,description,just_optimi enum_desc=s2a("Performs a geometry minimization.",& "Performs a transition state optimization."),& enum_i_vals=(/default_minimization_method_id,default_ts_method_id/),& - default_i_val=default_minimization_method_id,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=default_minimization_method_id) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END IF CALL keyword_create(keyword, name="OPTIMIZER",& @@ -860,86 +827,85 @@ RECURSIVE SUBROUTINE create_geoopt_section(section,label,description,just_optimi "Limit memory variant of the above, can also be applied to large systems, not as well fine-tuned",& "conjugate gradients, robust minimizer (depending on the line search) also OK for large systems"),& enum_i_vals=(/default_bfgs_method_id,default_lbfgs_method_id,default_cg_method_id/),& - default_i_val=default_bfgs_method_id,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=default_bfgs_method_id) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER",& description="Specifies the maximum number of geometry optimization steps. "//& "One step might imply several force evaluations for the CG and LBFGS optimizers.",& usage="MAX_ITER {integer}",& - default_i_val=200,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=200) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_DR",& description="Convergence criterium for the maximum geometry change "//& "between the current and the last optimizer iteration.",& usage="MAX_DR {real}",& - default_r_val=0.0030_dp,unit_str="bohr",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0030_dp,unit_str="bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_FORCE",& description="Convergence criterium for the maximum force component of the current configuration.",& usage="MAX_FORCE {real}",& - default_r_val=0.00045_dp,unit_str="hartree/bohr",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.00045_dp,unit_str="hartree/bohr") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMS_DR",& description="Convergence criterium for the root mean square (RMS) geometry"//& " change between the current and the last optimizer iteration.",& usage="RMS_DR {real}",unit_str="bohr",& - default_r_val=0.0015_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.0015_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RMS_FORCE",& description="Convergence criterium for the root mean square (RMS) force of the current configuration.",& usage="RMS_FORCE {real}",unit_str="hartree/bohr",& - default_r_val=0.00030_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.00030_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,name="step_start_val",& description="The starting step value for the "//TRIM(label)//" module.",& - usage="step_start_val ",default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="step_start_val ",default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_lbfgs_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_lbfgs_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_cg_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_cg_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_bfgs_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_bfgs_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) IF (.NOT.just_optimizers) THEN ! Transition states section - CALL create_ts_section(subsection, error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_ts_section(subsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! Create the PRINT subsection NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="Controls the printing properties during a geometry optimization run",& - n_keywords=0, n_subsections=1, repeats=.TRUE., error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic information during the Geometry Optimization", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END IF END SUBROUTINE create_geoopt_section @@ -947,13 +913,10 @@ END SUBROUTINE create_geoopt_section ! ***************************************************************************** !> \brief creates the section for the shell-core optimization !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Caino ! ***************************************************************************** - SUBROUTINE create_shellcore_opt_section(section, error) + SUBROUTINE create_shellcore_opt_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_shellcore_opt_section', & routineP = moduleN//':'//routineN @@ -965,7 +928,7 @@ SUBROUTINE create_shellcore_opt_section(section, error) " that might turn to be necessary along a MD run using a shell-model potential. "//& " The optimization procedure is activated when at least one of the shell-core "//& "pairs becomes too elongated, i.e. when the assumption of point dipole is not longer valid.",& - just_optimizers=.TRUE.,error=error) + just_optimizers=.TRUE.) NULLIFY(print_key, subsection) @@ -974,29 +937,25 @@ SUBROUTINE create_shellcore_opt_section(section, error) NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="Controls the printing properties during a shell-core optimization procedure",& - n_keywords=0, n_subsections=1, repeats=.TRUE., error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic information during the Optimization", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_shellcore_opt_section ! ***************************************************************************** !> \brief creates the section for the cell optimization !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 03.2008 ! ***************************************************************************** - SUBROUTINE create_cell_opt_section(section, error) + SUBROUTINE create_cell_opt_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_cell_opt_section', & routineP = moduleN//':'//routineN @@ -1007,7 +966,7 @@ SUBROUTINE create_cell_opt_section(section, error) CALL create_geoopt_section(section, label="CELL_OPT",& description="This section sets the environment for the optimization of the simulation cell."//& " Two possible schemes are available: (1) Zero temperature optimization; "//& - " (2) Finite temperature optimization. ",just_optimizers=.TRUE.,error=error) + " (2) Finite temperature optimization. ",just_optimizers=.TRUE.) NULLIFY(keyword,print_key,subsection) CALL keyword_create(keyword, name="TYPE",& @@ -1022,76 +981,72 @@ SUBROUTINE create_cell_opt_section(section, error) "Performs a geometry and cell optimization at the same time."//& " The stress tensor is computed at every step"),& enum_i_vals=(/default_cell_geo_opt_id,default_cell_md_id,default_cell_direct_id/),& - default_i_val=default_cell_direct_id,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=default_cell_direct_id) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="EXTERNAL_PRESSURE",& description="Specifies the external pressure (1 value or the full 9 components of the pressure tensor) "//& "applied during the cell optimization.",& usage="EXTERNAL_PRESSURE {REAL} .. {REAL}",unit_str="bar",& - default_r_vals=(/cp_unit_to_cp2k(100.0_dp,"bar",error=error),0.0_dp,0.0_dp,& - 0.0_dp,cp_unit_to_cp2k(100.0_dp,"bar",error=error),0.0_dp,& - 0.0_dp,0.0_dp,cp_unit_to_cp2k(100.0_dp,"bar",error=error)/),n_var=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_vals=(/cp_unit_to_cp2k(100.0_dp,"bar"),0.0_dp,0.0_dp,& + 0.0_dp,cp_unit_to_cp2k(100.0_dp,"bar"),0.0_dp,& + 0.0_dp,0.0_dp,cp_unit_to_cp2k(100.0_dp,"bar")/),n_var=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KEEP_ANGLES",& description="Keep angles between the cell vectors constant, but allow the lenghts of the"//& " cell vectors to change independently."//& " Albeit general, this is most useful for triclinic cells, to enforce higher symmetry, see KEEP_SYMMETRY.",& - usage="KEEP_ANGLES TRUE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="KEEP_ANGLES TRUE",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="KEEP_SYMMETRY",& description="Keep the requested initial cell symmetry (e.g. during a cell optimisation). "//& "The initial symmetry must be specified in the &CELL section.",& - usage="KEEP_SYMMETRY yes",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="KEEP_SYMMETRY yes",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRESSURE_TOLERANCE",& description="Specifies the Pressure tolerance (compared to the external pressure) to achieve "//& "during the cell optimization.",& usage="PRESSURE_TOLERANCE {REAL}",unit_str="bar",& - default_r_val=cp_unit_to_cp2k(100.0_dp,"bar",error=error),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(100.0_dp,"bar")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Create the PRINT subsection NULLIFY(subsection) CALL section_create(subsection,name="PRINT",& description="Controls the printing properties during a geometry optimization run",& - n_keywords=0, n_subsections=1, repeats=.TRUE., error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"program_run_info",& description="Controls the printing of basic information during the Geometry Optimization", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"cell",& description="Controls the printing of the cell eveytime a calculation using a new cell is started.", & print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - unit_str="angstrom",error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + unit_str="angstrom") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_cell_opt_section ! ***************************************************************************** !> \brief creates the section for tuning transition states search !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 01.2008 ! ***************************************************************************** - SUBROUTINE create_ts_section(section, error) + SUBROUTINE create_ts_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_ts_section', & routineP = moduleN//':'//routineN @@ -1107,7 +1062,7 @@ SUBROUTINE create_ts_section(section, error) NULLIFY(section,keyword,subsection, subsection2) CALL section_create(section,name="TRANSITION_STATE",& description="Specifies parameters to perform a transition state search",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="METHOD",& description="Specify which kind of method to use for locating transition states",& @@ -1116,84 +1071,83 @@ SUBROUTINE create_ts_section(section, error) enum_c_vals=s2a("DIMER"),& enum_desc=s2a("Uses the dimer method to optimize transition states."),& enum_i_vals=(/default_dimer_method_id/),& - default_i_val=default_dimer_method_id,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=default_dimer_method_id) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="DIMER",& description="Specifies parameters for Dimer Method",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="DR",& description="This keyword sets the value for the DR parameter.",& usage="DR {real}",unit_str='angstrom',& - default_r_val=cp_unit_to_cp2k(0.01_dp,"angstrom",error=error),error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(0.01_dp,"angstrom")) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INTERPOLATE_GRADIENT",& description="This keyword controls the interpolation of the gradient whenever possible"//& " during the optimization of the Dimer. The use of this keywords saves 1 evaluation "//& " of energy/forces.", usage="INTERPOLATE_GRADIENT {logical}",default_l_val=.TRUE.,& - lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ANGLE_TOLERANCE",& description="This keyword sets the value of the tolerance angle for the line search "//& " performed to optimize the orientation of the dimer.",& usage="ANGLE_TOL {real}",unit_str='rad',& - default_r_val=cp_unit_to_cp2k(5.0_dp,"deg",error=error),error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(5.0_dp,"deg")) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL create_geoopt_section(subsection2, label="ROT_OPT",& description="This section sets the environment for the optimization of the rotation of the Dimer.",& - just_optimizers=.TRUE.,error=error) + just_optimizers=.TRUE.) NULLIFY(subsection3) CALL section_create(subsection3,name="PRINT",& description="Controls the printing properties during the dimer rotation optimization run",& - n_keywords=0, n_subsections=1, repeats=.TRUE., error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"PROGRAM_RUN_INFO",& description="Controls the printing of basic information during the Geometry Optimization", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(subsection3,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(subsection3,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"ROTATIONAL_INFO",& description="Controls the printing basic info during the cleaning of the "//& "rotational degrees of freedom.", print_level=low_print_level,& - add_last=add_last_numeric,filename="__STD_OUT__",error=error) + add_last=add_last_numeric,filename="__STD_OUT__") CALL keyword_create(keyword, name="COORDINATES",& description="Prints atomic coordinates after rotation",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection3,print_key,error=error) - CALL section_release(print_key,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection3,print_key) + CALL section_release(print_key) - CALL section_add_subsection(subsection2,subsection3,error=error) - CALL section_release(subsection3,error=error) - CALL section_add_subsection(subsection,subsection2,error=error) - CALL section_release(subsection2,error=error) + CALL section_add_subsection(subsection2,subsection3) + CALL section_release(subsection3) + CALL section_add_subsection(subsection,subsection2) + CALL section_release(subsection2) CALL section_create(subsection2,name="DIMER_VECTOR",& description="Specifies the initial dimer vector (used frequently to restart DIMER calculations)."//& " If not provided the starting orientation of the dimer is chosen randomly.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify on each line the components of the dimer vector.",repeats=.TRUE.,& - usage="{Real} {Real} {Real}", type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(subsection2,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,subsection2,error=error) - CALL section_release(subsection2,error=error) + usage="{Real} {Real} {Real}", type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection2,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,subsection2) + CALL section_release(subsection2) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_ts_section @@ -1201,13 +1155,10 @@ END SUBROUTINE create_ts_section ! ***************************************************************************** !> \brief creates the BFGS section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 01.2008 ! ***************************************************************************** - SUBROUTINE create_bfgs_section(section, error) + SUBROUTINE create_bfgs_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_bfgs_section', & routineP = moduleN//':'//routineN @@ -1221,65 +1172,62 @@ SUBROUTINE create_bfgs_section(section, error) NULLIFY(section,keyword,print_key) CALL section_create(section,name="BFGS",& description="Provides parameters to tune the BFGS optimization",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="TRUST_RADIUS",& description="Trust radius used in BFGS. Previously set to 0.1. "//& "Large values can lead to instabilities",& usage="TRUST_RADIUS {real}",unit_str='angstrom',& - default_r_val=cp_unit_to_cp2k(0.25_dp,"angstrom",error=error),error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(0.25_dp,"angstrom")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_MODEL_HESSIAN",& description="Uses a model Hessian as initial guess instead of a unit matrix."//& " Should lead in general to improved convergence might be switched off for exotic cases",& usage="USE_MODEL_HESSIAN",& - default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="USE_RAT_FUN_OPT",& description="Includes a rational function optimization to determine the step."//& " Previously default but did not improve convergence in many cases",& usage="USE_RAT_FUN_OPT",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_HESSIAN",& description="Controls the reading of the initial Hessian from file.",& usage="RESTART_HESSIAN",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_FILE_NAME",& description="Specifies the name of the file used to read the initial Hessian.",& usage="RESTART_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"RESTART",& description="Controls the printing of Hessian Restart file", & print_level=low_print_level,add_last=add_last_numeric,filename="BFGS",& - common_iter_levels=2, error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + common_iter_levels=2) + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_bfgs_section ! ***************************************************************************** !> \brief creates the CG section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 01.2008 ! ***************************************************************************** - SUBROUTINE create_cg_section(section, error) + SUBROUTINE create_cg_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_cg_section', & routineP = moduleN//':'//routineN @@ -1294,15 +1242,15 @@ SUBROUTINE create_cg_section(section, error) NULLIFY(section,subsection,subsubsection,keyword) CALL section_create(section,name="CG",& description="Provides parameters to tune the conjugate gradient optimization",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="MAX_STEEP_STEPS",& description="Maximum number of steepest descent steps before starting the"//& " conjugate gradients optimization.",& usage="MAX_STEEP_STEPS {integer}",& - default_i_val=0,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RESTART_LIMIT",& description="Cosine of the angle between two consecutive searching directions."//& @@ -1310,21 +1258,21 @@ SUBROUTINE create_cg_section(section, error) " to the RESTART_LIMIT the CG is reset and one step of steepest descent is "//& " performed.",& usage="RESTART_LIMIT {real}",& - default_r_val=0.9_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.9_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FLETCHER_REEVES",& description="Uses FLETCHER-REEVES instead of POLAK-RIBIERE when using Conjugate Gradients",& usage="FLETCHER-REEVES",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! Line Search section CALL section_create(subsection,name="LINE_SEARCH",& description="Provides parameters to tune the line search during the conjugate gradient optimization",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="TYPE",& description="1D line search algorithm to be used with the CG optimizer,"//& @@ -1338,86 +1286,82 @@ SUBROUTINE create_cg_section(section, error) "perform 1D golden section search of the minimum (very expensive)",& "perform 1D fit of a parabola on several evaluation of energy "//& "(very expensive and more robust vs numerical noise)"),& - enum_i_vals=(/ls_none,ls_2pnt,ls_3pnt,ls_gold,ls_fit/),& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/ls_none,ls_2pnt,ls_3pnt,ls_gold,ls_fit/)) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) ! 2PNT NULLIFY(subsubsection) CALL section_create(subsubsection,name="2PNT",& description="Provides parameters to tune the line search for the two point based line search.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="MAX_ALLOWED_STEP",& description="Max allowed value for the line search step.",& usage="MAX_ALLOWED_STEP {real}",unit_str="internal_cp2k",& - default_r_val=0.25_dp,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.25_dp) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LINMIN_GRAD_ONLY",& description="Use only the gradient, not the energy for line minimizations (e.g. in conjugate gradients).",& usage="LINMIN_GRAD_ONLY T",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) ! GOLD NULLIFY(subsubsection) CALL section_create(subsubsection,name="GOLD",& description="Provides parameters to tune the line search for the gold search.",& - n_keywords=0, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=1, repeats=.FALSE.) CALL keyword_create(keyword, name="INITIAL_STEP",& description="Initial step size used, e.g. for bracketing or minimizers. "//& "Might need to be reduced for systems with close contacts",& usage="INITIAL_STEP {real}",unit_str="internal_cp2k",& - default_r_val=0.2_dp,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.2_dp) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BRACK_LIMIT",& description="Limit in 1D bracketing during line search in Conjugate Gradients Optimization.",& usage="BRACK_LIMIT {real}",unit_str="internal_cp2k",& - default_r_val=100.0_dp,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=100.0_dp) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BRENT_TOL",& description="Tolerance requested during Brent line search in Conjugate Gradients Optimization.",& usage="BRENT_TOL {real}",unit_str="internal_cp2k",& - default_r_val=0.01_dp,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.01_dp) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BRENT_MAX_ITER",& description="Maximum number of iterations in brent algorithm "// & "(used for the line search in Conjugated Gradients Optimization)",& usage="BRENT_MAX_ITER {integer}",& - default_i_val=100,error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) - - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_i_val=100) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) + + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_cg_section ! ***************************************************************************** !> \brief creates the LBFGS section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] - University of Zurich - 01.2008 ! ***************************************************************************** - SUBROUTINE create_lbfgs_section(section, error) + SUBROUTINE create_lbfgs_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_lbfgs_section', & routineP = moduleN//':'//routineN @@ -1432,8 +1376,7 @@ SUBROUTINE create_lbfgs_section(section, error) CALL section_create(section,name="LBFGS",& description="Provides parameters to tune the limited memory BFGS (LBFGS) optimization",& n_keywords=0, n_subsections=1, repeats=.FALSE.,& - citations=(/Byrd1995/),& - error=error) + citations=(/Byrd1995/)) CALL keyword_create(keyword, name="MAX_H_RANK",& description="Maximum rank (and consequently size) of the "//& @@ -1441,55 +1384,52 @@ SUBROUTINE create_lbfgs_section(section, error) "Larger values (e.g. 30) will accelerate the convergence behaviour "//& "at the cost of a larger memory consumption.",& usage="MAX_H_RANK {integer}",& - default_i_val=5,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_F_PER_ITER",& description="Maximum number of force evaluations per iteration"// & "(used for the line search)",& usage="MAX_F_PER_ITER {integer}",& - default_i_val=20,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=20) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WANTED_PROJ_GRADIENT",& description="Convergence criterium (overrides the general ones):"//& "Requested norm threshold of the gradient multiplied "// & "by the approximate Hessian.",& usage="WANTED_PROJ_GRADIENT {real}",unit_str="internal_cp2k",& - default_r_val=1.0E-16_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-16_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WANTED_REL_F_ERROR",& description="Convergence criterium (overrides the general ones):"//& "Requested relative error on the objective function"//& "of the optimizer (the energy)",& usage="WANTED_REL_F_ERROR {real}",unit_str="internal_cp2k",& - default_r_val=1.0E-16_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0E-16_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TRUST_RADIUS",& description="Trust radius used in LBFGS. Not completly in dept tested. Negativ values means no trust radius is used.",& usage="TRUST_RADIUS {real}",unit_str='angstrom',& - default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_lbfgs_section ! ***************************************************************************** !> \brief creates the flexible_partitioning section !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost VandeVondele [04.2006] ! ***************************************************************************** - SUBROUTINE create_fp_section(section,error) + SUBROUTINE create_fp_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_fp_section', & routineP = moduleN//':'//routineN @@ -1500,86 +1440,86 @@ SUBROUTINE create_fp_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="FLEXIBLE_PARTITIONING",& description="This section sets up flexible_partitioning",& - n_keywords=1, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword,print_key) CALL keyword_create(keyword, name="CENTRAL_ATOM",& description="Specifies the central atom.",& usage="CENTRAL_ATOM {integer}",& - n_var=1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INNER_ATOMS",& description="Specifies the list of atoms that should remain close to the central atom.",& usage="INNER_ATOMS {integer} {integer} .. {integer}",& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OUTER_ATOMS",& description="Specifies the list of atoms that should remain far from the central atom.",& usage="OUTER_ATOMS {integer} {integer} .. {integer}",& - n_var=-1, type_of_var=integer_t, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INNER_RADIUS",& description="radius of the inner wall",& usage="INNER_RADIUS {real} ", type_of_var=real_t, & - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="OUTER_RADIUS",& description="radius of the outer wall",& usage="OUTER_RADIUS {real} ", type_of_var=real_t, & - n_var=1, unit_str="angstrom", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=1, unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="STRENGTH",& description="Sets the force constant of the repulsive harmonic potential",& - usage="STRENGTH 1.0", default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="STRENGTH 1.0", default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BIAS",& description="If a bias potential counter-acting the weight term should be applied (recommended).",& - usage="BIAS F", default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="BIAS F", default_l_val=.TRUE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE",& description="Sets the temperature parameter that is used in the baising potential."//& "It is recommended to use the actual simulation temperature",& - usage="TEMPERATURE 300", default_r_val=300.0_dp, unit_str='K', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="TEMPERATURE 300", default_r_val=300.0_dp, unit_str='K') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SMOOTH_WIDTH",& description="Sets the width of the smooth counting function.",& - usage="SMOOTH_WIDTH 0.2", default_r_val=0.02_dp, unit_str='angstrom', error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="SMOOTH_WIDTH 0.2", default_r_val=0.02_dp, unit_str='angstrom') + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(print_key,"WEIGHTS",& description="Controls the printing of FP info during flexible partitioning simulations.", & print_level=low_print_level,common_iter_levels=1,& - filename="FLEXIBLE_PARTIONING", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="FLEXIBLE_PARTIONING") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CONTROL",& description="Controls the printing of FP info at startup", & print_level=low_print_level,common_iter_levels=1, & - filename="__STD_OUT__", error=error) - CALL section_add_subsection(section,print_key,error=error) - CALL section_release(print_key,error=error) + filename="__STD_OUT__") + CALL section_add_subsection(section,print_key) + CALL section_release(print_key) END SUBROUTINE create_fp_section @@ -1588,13 +1528,10 @@ END SUBROUTINE create_fp_section ! ***************************************************************************** !> \brief ... !> \param section will contain the driver section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author mceriotti ! ***************************************************************************** - SUBROUTINE create_driver_section(section,error) + SUBROUTINE create_driver_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_driver_section', & routineP = moduleN//':'//routineN @@ -1604,33 +1541,33 @@ SUBROUTINE create_driver_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="DRIVER",& description="This section defines the parameters needed to run in i-PI driver mode.",& - n_keywords=3, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=3, n_subsections=0, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="unix",& description="Use a UNIX socket rather than an INET socket.",& usage="unix LOGICAL",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="port",& description="Port number for the i-PI server.",& usage="port ",& - default_i_val=12345, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=12345) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="host",& description="Host name for the i-PI server.",& usage="host ",& - default_c_val="localhost", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="localhost") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_driver_section @@ -1638,13 +1575,10 @@ END SUBROUTINE create_driver_section ! ***************************************************************************** !> \brief creates the section for a path integral run !> \param section will contain the pint section -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE create_pint_section(section,error) + SUBROUTINE create_pint_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_pint_section', & routineP = moduleN//':'//routineN @@ -1656,159 +1590,157 @@ SUBROUTINE create_pint_section(section,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="PINT",& description="The section that controls a path integral run",& - n_keywords=11, n_subsections=8, repeats=.FALSE., error=error) + n_keywords=11, n_subsections=8, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="p",& description="Specify number beads to use",repeats=.FALSE.,& - default_i_val=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="proc_per_replica",& description="Specify number of processors to use for each replica",& - repeats=.FALSE., default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="num_steps",& description="Number of steps (if MAX_STEP is not explicitly given"//& " the program will perform this number of steps)",repeats=.FALSE.,& - default_i_val=3, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=3) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_STEP",& description="Maximum step number (the program will stop if"//& " ITERATION >= MAX_STEP even if NUM_STEPS has not been reached)",& - repeats=.FALSE., default_i_val=10, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=10) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="iteration",& description="Specify the iteration number from which it should be "//& - "counted", default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + "counted", default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Temp",& description="The temperature you want to simulate",& - default_r_val=cp_unit_to_cp2k(300._dp,"K",error=error),& - unit_str="K", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(300._dp,"K"),& + unit_str="K") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="T_tol",variants=(/"temp_to"/),& description="threshold for the oscillations of the temperature "//& "excedeed which the temperature is rescaled. 0 means no rescaling.",& - default_r_val=0._dp,unit_str="K", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0._dp,unit_str="K") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="dt",& description="timestep (might be subdivised in nrespa subtimesteps",& repeats=.FALSE.,& - default_r_val=cp_unit_to_cp2k(1.0_dp,"fs",error=error),& - usage="dt 1.0",unit_str="fs",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(1.0_dp,"fs"),& + usage="dt 1.0",unit_str="fs") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="nrespa",& description="number of respa steps for the bead for each md step",& - repeats=.FALSE., default_i_val=5,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=5) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="transformation",& description="Specifies the coordinate transformation to use",& usage="TRANSFORMATION (NORMAL|STAGE)",& default_i_val=transformation_normal,& enum_c_vals=s2a("NORMAL","STAGE"),& - enum_i_vals=(/transformation_normal,transformation_stage/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/transformation_normal,transformation_stage/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FIX_CENTROID_POS",& description="Propagate all DOF but the centroid - "//& "useful for equilibration of the non-centroid modes "//& "(activated only if TRANSFORMATION==NORMAL)",& repeats=.FALSE., default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection,subsubsection) CALL section_create(subsection,name="NORMALMODE",& description="Controls the normal mode transformation",& - n_keywords=3, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=3, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="Q_CENTROID",& description="Value of the thermostat mass of centroid degree of freedom",& - repeats=.FALSE., default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_r_val=-1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Q_BEAD",& description="Value of the thermostat mass of non-centroid degrees of freedom",& - repeats=.FALSE., default_r_val=-1.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_r_val=-1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MODEFACTOR",& description="mass scale factor for non-centroid degrees of freedom",& - repeats=.FALSE., default_r_val=1.0_dp,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + repeats=.FALSE., default_r_val=1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="staging",& description="The section that controls the staging transformation",& - n_keywords=2, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="j",& description="Value of the j parameter for the staging transformation",& - repeats=.FALSE., default_i_val=2,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=2) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="Q_END",& description="Value of the nose-hoover mass for the endbead (Q_end)",& - repeats=.FALSE., default_i_val=2,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + repeats=.FALSE., default_i_val=2) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create( subsection, name="BEADS",& description="Sets positions and velocities of the beads",& n_keywords=0, n_subsections=2,& - repeats=.FALSE., error=error ) - CALL create_coord_section(subsubsection,"BEADS",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) - CALL create_velocity_section(subsubsection,"BEADS",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + repeats=.FALSE.) + CALL create_coord_section(subsubsection,"BEADS") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) + CALL create_velocity_section(subsubsection,"BEADS") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create( subsection, name="NOSE",& description="Controls the Nose-Hoover thermostats",& n_keywords=1, n_subsections=2,& - repeats=.FALSE., error=error ) + repeats=.FALSE.) CALL keyword_create(keyword, name="nnos",& description="length of nose-hoover chain. 0 means no thermostat",& - repeats=.FALSE., default_i_val=2,error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL create_coord_section(subsubsection,"NOSE",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) - CALL create_velocity_section(subsubsection,"NOSE",error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) - - CALL create_gle_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + repeats=.FALSE., default_i_val=2) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL create_coord_section(subsubsection,"NOSE") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) + CALL create_velocity_section(subsubsection,"NOSE") + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) + + CALL create_gle_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL section_create( subsection, name="INIT",& description="Controls the initialization if the beads are not present",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="LEVY_POS_SAMPLE",& description="Sample bead positions assuming free particle "//& @@ -1816,116 +1748,107 @@ SUBROUTINE create_pint_section(section,error) "the classical position of each atom at the physical "//& "temperature defined in PINT%TEMP)",& repeats=.FALSE., default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LEVY_CORRELATED",& description="Use the same Levy path for all atoms, though "//& "with mass-dependent variances (might help at very low T)",& repeats=.FALSE., default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="LEVY_TEMP_FACTOR",& description="Multiplicative correction factor for the "//& "temperature at which the Levy walk is performed "//& "(correction is due to the interactions that modify "//& "the spread of a free particle)",& - repeats=.FALSE., default_r_val=1.0_dp,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_r_val=1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword,name="LEVY_SEED",& description="Initial seed for the (pseudo)random number "//& "generator that controls Levy walk for bead positions.",& usage="LEVY_SEED ",default_i_val=1234,& - repeats=.FALSE., error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="RANDOMIZE_POS",& description="add gaussian noise to the positions of the beads",& - repeats=.FALSE., default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CENTROID_SPEED",& description="adds random velocity component to the centroid modes "//& "(useful to correct for the averaging out of the speed of various beads)",& - repeats=.FALSE., default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VELOCITY_QUENCH",& description="set the initial velocities to zero",& - repeats=.FALSE., default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="VELOCITY_SCALE",& description="scale initial velocities to the temperature given in MOTION%PINT%TEMP",& - repeats=.FALSE., default_l_val=.FALSE., lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) - CALL create_helium_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_helium_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PRINT",& description="Controls the path integral-specific output",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) NULLIFY(print_key) CALL cp_print_key_section_create(print_key,"ENERGY",& description="Controls the output of the path integral energies", & - print_level=low_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CENTROID_POS",& description="Controls the output of the centroid's position", & unit_str="angstrom",& - print_level=low_print_level,common_iter_levels=1,error=error) + print_level=low_print_level,common_iter_levels=1) CALL add_format_keyword(keyword, print_key, pos=.TRUE.,& - description="Output file format for the positions of centroid",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + description="Output file format for the positions of centroid") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CENTROID_VEL",& description="Controls the output of the centroid's velocity", & unit_str="bohr*au_t^-1",& - print_level=low_print_level,common_iter_levels=1,error=error) + print_level=low_print_level,common_iter_levels=1) CALL add_format_keyword(keyword, print_key, pos=.FALSE.,& - description="Output file format for the velocity of centroid",& - error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + description="Output file format for the velocity of centroid") + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"CENTROID_GYR",& description="Controls the output of the centroid's radii of gyration", & unit_str="angstrom",& - print_level=low_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"COM",& description="Controls the output of the center of mass",& - print_level=high_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) END SUBROUTINE create_pint_section @@ -1936,11 +1859,9 @@ END SUBROUTINE create_pint_section ! ***************************************************************************** !> \brief ... !> \param section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE create_helium_section(section,error) + SUBROUTINE create_helium_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_helium_section', & routineP = moduleN//':'//routineN @@ -1951,261 +1872,252 @@ SUBROUTINE create_helium_section(section,error) subsubsection failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) IF (failure) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CALL section_create(section,name="HELIUM",& description="The section that controls optional helium solvent"// & " environment (highly experimental, not for general use yet)",& - n_keywords=11, n_subsections=4, repeats=.FALSE., error=error) + n_keywords=11, n_subsections=4, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Whether or not to actually use this section",& - usage="silent",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="silent",default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="HELIUM_ONLY",& description="Simulate helium solvent only, "//& "disregard solute entirely",& repeats=.FALSE., default_l_val=.FALSE.,& - lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUM_ENV", & description="Number of independent helium environments"// & " (only for restarts, do not set explicitly)",& - repeats=.FALSE., default_i_val=1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POTENTIAL_FILE_NAME",& description="Name of the Helium interaction potential file",& - repeats=.FALSE., default_lc_val="HELIUM.POT",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_lc_val="HELIUM.POT") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NATOMS", & description="Number of helium atoms",& - repeats=.FALSE., default_i_val=64,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=64) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NBEADS", & description="Number of helium path integral beads",& - repeats=.FALSE., default_i_val=25,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=25) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INOROT", & description="Number of MC iterations at the same time slice(s)",& - repeats=.FALSE., default_i_val=10000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=10000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IROT", & description="how often to reselect the time slice(s) to work on",& - repeats=.FALSE., default_i_val=10000,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=10000) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BISECTION", & description="how many time slices to change at once (+1). "//& "Must be a power of 2 currently",& - repeats=.FALSE., default_i_val=8,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=8) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_PERM_CYCLE", & description="how large cyclic permutations to try",& - repeats=.FALSE., default_i_val=6,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_i_val=6) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) NULLIFY(subsection) CALL section_create(subsection,name="M-SAMPLING",& description="Permutation cycle length sampling settings",& - n_keywords=2, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="M-VALUE", & description="Value of m treated in a special way",& repeats=.FALSE.,& - default_i_val=1,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="M-RATIO", & description="Probability ratio betw M-VALUE and other cycle lengths",& repeats=.FALSE.,& - default_r_val=1.0_dp,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL keyword_create(keyword, name="PERIODIC", & description="Use periodic boundary conditions for helium",& - repeats=.FALSE., default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CELL_SIZE", & description="PBC unit cell size (NOTE 1: density, number of atoms"//& " and volume are interdependent - give only two of them; "//& "NOTE 2: for small cell sizes specify NATOMS instead)",& - repeats=.FALSE.,type_of_var=real_t,unit_str="angstrom",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE.,type_of_var=real_t,unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CELL_SHAPE", & description="PBC unit cell shape for helium",& usage="CELL_SHAPE (CUBE|OCTAHEDRON)",& default_i_val=helium_cell_shape_cube,& enum_c_vals=s2a("CUBE","OCTAHEDRON"),& - enum_i_vals=(/helium_cell_shape_cube,helium_cell_shape_octahedron/),& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/helium_cell_shape_cube,helium_cell_shape_octahedron/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DENSITY", & description="trial density of helium for determining the helium "//& "box size",& repeats=.FALSE., & - default_r_val=cp_unit_to_cp2k(0.02186_dp,"angstrom^-3",error=error),& - unit_str="angstrom^-3",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=cp_unit_to_cp2k(0.02186_dp,"angstrom^-3"),& + unit_str="angstrom^-3") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PRESAMPLE", & description="Presample He coordinates before first PIMD step",& - repeats=.FALSE., default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DROP_UNUSED_ENVS", & description="Drop He environments if N_restart > N_runtime "//& "(Warning: this will cause data loss in the restart file!)",& - repeats=.FALSE., default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + repeats=.FALSE., default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL section_create(subsection,name="RDF",& description="Radial distribution function generation settings",& - n_keywords=2, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="MAXR", & description="Maximum RDF range, defaults to unit cell size",& repeats=.FALSE.,type_of_var=real_t,& - unit_str="angstrom",error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + unit_str="angstrom") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NBIN", & description="Number of bins",& repeats=.FALSE.,& - default_i_val=700,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + default_i_val=700) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) NULLIFY(subsection) CALL section_create(subsection,name="RHO",& description="Density distribution settings",& - n_keywords=2, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=2, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Whether or not to actually calculate densities "//& "(requires significant amount of memory, depending on the value of NBIN)",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NBIN", & description="Number of bins",& repeats=.FALSE.,& - default_i_val=100,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=100) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="IWEIGHT", & description="Weight the restarted density should be given " // & "(number of MC steps used to average the restarted density, " // & "negative value - the same weight as the run-time density, " // & "usually should not be changed)",& repeats=.FALSE.,& - default_i_val=-1,& - error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) NULLIFY(subsubsection) CALL section_create(subsubsection,name="CUBE_DATA",& description="Density data used for restarts",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Cubefile data", & repeats=.TRUE., usage="{Real} ...",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(subsubsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,subsubsection,error=error) - CALL section_release(subsubsection,error=error) - - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsubsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,subsubsection) + CALL section_release(subsubsection) + + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) ! end of subsection RHO - CALL create_coord_section(subsection,"HELIUM",error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL create_coord_section(subsection,"HELIUM") + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PERM",& description="Permutation state used for restart",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify particle index permutation for every "// & "helium atom",repeats=.TRUE.,usage="{Integer} ...",& - type_of_var=integer_t, n_var=-1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="FORCE",& description="Forces exerted by the helium on the solute system"//& " (used for restarts)",& - n_keywords=0, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=0, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_", & description="Number of real values should be 3 * "//& " * ", repeats=.TRUE., & usage="{Real} ...", type_of_var=real_t, & - n_var=-1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="RNG_STATE",& description="Random number generator state for all processors",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Three real arrays of DIMENSION(3,2) times two RNG "//& "streams - 36 real values per processor",& repeats=.TRUE.,usage="automatically filled, do not edit by hand",& - type_of_var=real_t, n_var=-1, error=error) - CALL section_add_keyword(subsection,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) CALL section_create(subsection,name="PRINT",& description="The section that controls the output of the helium code",& - n_keywords=1, n_subsections=0, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=0, repeats=.FALSE.) ! ************************************************************************* !> Printkeys for properites output @@ -2220,21 +2132,21 @@ SUBROUTINE create_helium_section(section,error) CALL cp_print_key_section_create(print_key,"ENERGY",& description="Controls the output of the helium energies"//& " (averaged over MC step)", & - print_level=low_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"SDENSITY",& description="Controls the output of the helium superfluid density",& - print_level=low_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=low_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) ! Properties printed at MEDIUM print level ! CALL cp_print_key_section_create(print_key,"COORDINATES",& description="Controls the output of helium coordinates",& - print_level=medium_print_level,common_iter_levels=1,error=error) + print_level=medium_print_level,common_iter_levels=1) CALL keyword_create(keyword, name="FORMAT",& description="Output file format for the coordinates",& usage="FORMAT (PDB|XYZ)",& @@ -2242,76 +2154,75 @@ SUBROUTINE create_helium_section(section,error) enum_c_vals=s2a("PDB","XYZ"),& enum_i_vals= (/fmt_id_pdb,fmt_id_xyz/),& enum_desc=s2a( "Bead coordinates and connectivity is written in PDB format",& - "Only bead coordinates are written in XYZ format"),& - error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + "Only bead coordinates are written in XYZ format")) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RDF",& description="Controls the output of the helium radial distribution function",& - print_level=medium_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"RHO",& description="Controls the output of the helium density "//& "(Gaussian cube file format)",& each_iter_names=s2a("MD"),each_iter_values=(/100/),& print_level=medium_print_level, common_iter_levels=1,& - add_last=add_last_numeric, error=error) + add_last=add_last_numeric) CALL keyword_create(keyword, name="BACKUP_COPIES",& description="Specifies the maximum number of backup copies.",& usage="BACKUP_COPIES {int}",& - default_i_val=1, error=error) - CALL section_add_keyword(print_key,keyword,error=error) - CALL keyword_release(keyword,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + default_i_val=1) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PLENGTH",& description="Controls the output of the helium permutation length",& - print_level=medium_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=medium_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) ! Properties printed at HIGH print level ! CALL cp_print_key_section_create(print_key,"ACCEPTS",& description="Controls the output of the helium acceptance data",& - print_level=high_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"PERM",& description="Controls the output of the helium permutation state",& - print_level=high_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"FORCES",& description="Controls the output of the helium forces on the solute",& - print_level=high_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=high_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) ! Properties printed at DEBUG print level ! CALL cp_print_key_section_create(print_key,"FORCES_INST",& description="Controls the output of the instantaneous helium forces on the solute",& - print_level=debug_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) CALL cp_print_key_section_create(print_key,"WNUMBER",& description="Controls the output of the helium winding number",& - print_level=debug_print_level,common_iter_levels=1,error=error) - CALL section_add_subsection(subsection,print_key,error=error) - CALL section_release(print_key,error=error) + print_level=debug_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) - CALL section_add_subsection(section,subsection,error=error) - CALL section_release(subsection,error=error) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) RETURN END SUBROUTINE create_helium_section diff --git a/src/statistical_methods.F b/src/statistical_methods.F index 6922bf9f35..abbc36e0a7 100644 --- a/src/statistical_methods.F +++ b/src/statistical_methods.F @@ -39,15 +39,13 @@ MODULE statistical_methods !> \param n ... !> \param w ... !> \param pw ... -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE sw_test ( ix, n, w, pw, error) + SUBROUTINE sw_test ( ix, n, w, pw) REAL(KIND=dp), DIMENSION(:), POINTER :: ix INTEGER, INTENT(IN) :: n REAL(KIND=dp), INTENT(OUT) :: w, pw - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'sw_test', & routineP = moduleN//':'//routineN @@ -78,7 +76,7 @@ SUBROUTINE sw_test ( ix, n, w, pw, error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) ! Check for N < 3 IF (n < 3 .OR. n > 5000) THEN @@ -95,11 +93,11 @@ SUBROUTINE sw_test ( ix, n, w, pw, error) n2 = (n-1)/2 END IF ALLOCATE(x(n),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ALLOCATE(itmp(n),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ALLOCATE(a(n2),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) x(:) = ix CALL sort(x, n, itmp) ! Check for zero range @@ -204,11 +202,11 @@ SUBROUTINE sw_test ( ix, n, w, pw, error) END IF END IF DEALLOCATE(x,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DEALLOCATE(itmp,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DEALLOCATE(a,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE sw_test @@ -368,7 +366,6 @@ END FUNCTION poly !> \param tau ... !> \param z ... !> \param prob ... -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] !> \note @@ -376,11 +373,10 @@ END FUNCTION poly !> z: number of std devs from 0 of tau !> prob: tau's probability ! ***************************************************************************** - SUBROUTINE k_test(xdata,istart,n,tau,z,prob,error) + SUBROUTINE k_test(xdata,istart,n,tau,z,prob) REAL(KIND=dp), DIMENSION(:), POINTER :: xdata INTEGER, INTENT(IN) :: istart, n REAL(KIND=dp) :: tau, z, prob - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'k_test', & routineP = moduleN//':'//routineN @@ -419,15 +415,13 @@ END SUBROUTINE k_test !> \param r ... !> \param u ... !> \param prob ... -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE vn_test(xdata,n,r,u,prob,error) + SUBROUTINE vn_test(xdata,n,r,u,prob) REAL(KIND=dp), DIMENSION(:), POINTER :: xdata INTEGER, INTENT(IN) :: n REAL(KIND=dp) :: r, u, prob - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vn_test', & routineP = moduleN//':'//routineN @@ -467,14 +461,12 @@ END SUBROUTINE vn_test !> Debug use only !> \param xdata ... !> \param globenv ... -!> \param error ... !> \par History !> Teodoro Laino (02.2007) [tlaino] ! ***************************************************************************** - SUBROUTINE tests(xdata, globenv, error) + SUBROUTINE tests(xdata, globenv) REAL(KIND=dp), DIMENSION(:), POINTER :: xdata TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tests', & routineP = moduleN//':'//routineN @@ -489,19 +481,19 @@ SUBROUTINE tests(xdata, globenv, error) n = 50 ! original sample size NULLIFY(xdata) ALLOCATE(xdata(n), stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DO i = 1, 10 xdata(i) = 5.0_dp - REAL(i,KIND=dp)/2.0_dp + 0.1*& - next_random_number(globenv%gaussian_rng_stream,error=error) + next_random_number(globenv%gaussian_rng_stream) WRITE(3,*)xdata(i) END DO DO i = 11, n - xdata(i) = 0.1*next_random_number(globenv%gaussian_rng_stream,error=error) + xdata(i) = 0.1*next_random_number(globenv%gaussian_rng_stream) END DO ! Test for trend DO i = 1, n - CALL k_test(xdata,i,n,tau,z,prob,error) + CALL k_test(xdata,i,n,tau,z,prob) IF (prob<=0.2_dp) EXIT END DO WRITE(*,*)"Mann-Kendall test",i @@ -509,18 +501,18 @@ SUBROUTINE tests(xdata, globenv, error) ! Test for normality distribution and for serial correlation DO i = 1,n ALLOCATE(ydata(n-i+1), stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ydata = xdata(i:n) - CALL sw_test ( ydata, n-i+1, w, pw, error) - CALL vn_test(ydata,n-i+1,r,u,prob,error) + CALL sw_test ( ydata, n-i+1, w, pw) + CALL vn_test(ydata,n-i+1,r,u,prob) WRITE(*,*)"Shapiro Wilks test",i,w,pw WRITE(*,*)"Von Neu",i,r,u,prob DEALLOCATE(ydata, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END DO DEALLOCATE(xdata, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END SUBROUTINE tests diff --git a/src/stm_images.F b/src/stm_images.F index 82c4d16006..cc1ad1e6fa 100644 --- a/src/stm_images.F +++ b/src/stm_images.F @@ -78,7 +78,6 @@ MODULE stm_images !> \param particles ... !> \param unoccupied_orbs ... !> \param unoccupied_evals ... -!> \param error ... !> \param !> \par History !> 02.2009 Created [MI] @@ -92,7 +91,7 @@ MODULE stm_images ! ***************************************************************************** SUBROUTINE th_stm_image(qs_env, stm_section, particles, unoccupied_orbs, & - unoccupied_evals, error) + unoccupied_evals) TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: stm_section @@ -101,7 +100,6 @@ SUBROUTINE th_stm_image(qs_env, stm_section, particles, unoccupied_orbs, & POINTER :: unoccupied_orbs TYPE(cp_1d_r_p_type), DIMENSION(:), & POINTER :: unoccupied_evals - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'th_stm_image', & routineP = moduleN//':'//routineN @@ -137,7 +135,7 @@ SUBROUTINE th_stm_image(qs_env, stm_section, particles, unoccupied_orbs, & CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) NULLIFY (ks_env, mos, rho, rho_ao, pw_env, stm_th_torb, fm_struct_tmp) @@ -147,45 +145,44 @@ SUBROUTINE th_stm_image(qs_env, stm_section, particles, unoccupied_orbs, & ks_env=ks_env,& mos=mos,& rho=rho,& - pw_env=pw_env,& - error=error) + pw_env=pw_env) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) - CALL section_vals_val_get(stm_section,"APPEND", l_val=append_cube,error=error) - CALL section_vals_val_get(stm_section,"BIAS", r_vals=stm_biases,error=error) - CALL section_vals_val_get(stm_section,"REF_ENERGY",r_val=ref_energy,explicit=use_ref_energy,error=error) - CALL section_vals_val_get(stm_section,"TH_TORB", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(stm_section,"APPEND", l_val=append_cube) + CALL section_vals_val_get(stm_section,"BIAS", r_vals=stm_biases) + CALL section_vals_val_get(stm_section,"REF_ENERGY",r_val=ref_energy,explicit=use_ref_energy) + CALL section_vals_val_get(stm_section,"TH_TORB", n_rep_val=n_rep) IF(n_rep==0) THEN ALLOCATE (stm_th_torb(1), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) stm_th_torb(1) = 0 ELSE ALLOCATE (stm_th_torb(n_rep), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DO irep = 1,n_rep CALL section_vals_val_get(stm_section,"TH_TORB",& - i_rep_val=irep,i_val=stm_th_torb(irep), error=error) + i_rep_val=irep,i_val=stm_th_torb(irep)) END DO END IF ALLOCATE(stm_density_ao) - CALL cp_dbcsr_init(stm_density_ao, error=error) + CALL cp_dbcsr_init(stm_density_ao) CALL cp_dbcsr_copy(stm_density_ao,rho_ao(1)%matrix,& - name="stm_density_ao",error=error) + name="stm_density_ao") CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,wf_g%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) nspin = SIZE(mos,1) ALLOCATE(nadd_unocc(nspin),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) nadd_unocc=0 IF(ASSOCIATED(unoccupied_orbs)) THEN DO ispin =1,nspin @@ -194,9 +191,9 @@ SUBROUTINE th_stm_image(qs_env, stm_section, particles, unoccupied_orbs, & END IF ALLOCATE(mo_arrays(nspin), STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(evals(nspin),STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(occupation(nspin),STAT=istat) DO ispin=1,nspin IF(nadd_unocc(ispin)==0) THEN @@ -216,9 +213,9 @@ SUBROUTINE th_stm_image(qs_env, stm_section, particles, unoccupied_orbs, & occupation(ispin)%array(1:nmo)=mo_occ(1:nmo) occupation(ispin)%array(1+nmo:ndim)=0.0_dp CALL cp_fm_struct_create(fm_struct_tmp, ncol_global=ndim, & - template_fmstruct=mo_coeff%matrix_struct, error=error) - CALL cp_fm_create(mo_arrays(ispin)%matrix,fm_struct_tmp, name="mo_arrays",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + template_fmstruct=mo_coeff%matrix_struct) + CALL cp_fm_create(mo_arrays(ispin)%matrix,fm_struct_tmp, name="mo_arrays") + CALL cp_fm_struct_release(fm_struct_tmp) CALL cp_fm_to_fm(mo_coeff, mo_arrays(ispin)%matrix, nmo, 1, 1) CALL cp_fm_to_fm(unoccupied_orbs(ispin)%matrix, mo_arrays(ispin)%matrix, & nadd_unocc(ispin), 1, nmo+1) @@ -228,31 +225,31 @@ SUBROUTINE th_stm_image(qs_env, stm_section, particles, unoccupied_orbs, & CALL stm_cubes(ks_env, stm_section, stm_density_ao, wf_r, wf_g, mo_arrays, evals, & occupation, efermi, stm_biases, stm_th_torb, particles, & - output_unit, append_cube, error=error) + output_unit, append_cube) DO ispin = 1,nspin IF(nadd_unocc(ispin)>0) THEN DEALLOCATE(evals(ispin)%array,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(occupation(ispin)%array,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) - CALL cp_fm_release( mo_arrays(ispin)%matrix, error=error) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) + CALL cp_fm_release( mo_arrays(ispin)%matrix) END IF END DO DEALLOCATE(mo_arrays,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(evals,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(occupation,STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_deallocate_matrix(stm_density_ao,error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw, error=error) + CALL cp_dbcsr_deallocate_matrix(stm_density_ao) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_g%pw) DEALLOCATE (stm_th_torb, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (nadd_unocc, STAT=istat) - CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -274,7 +271,6 @@ END SUBROUTINE th_stm_image !> \param particles ... !> \param output_unit ... !> \param append_cube ... -!> \param error ... !> \param !> \par History !> 7.2008 Created [Joost VandeVondele] @@ -285,7 +281,7 @@ END SUBROUTINE th_stm_image ! ***************************************************************************** SUBROUTINE stm_cubes(ks_env, stm_section, stm_density_ao, wf_r, wf_g, mo_arrays, evals, & occupation, efermi, stm_biases, stm_th_torb, particles, & - output_unit, append_cube, error) + output_unit, append_cube) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(section_vals_type), POINTER :: stm_section @@ -301,7 +297,6 @@ SUBROUTINE stm_cubes(ks_env, stm_section, stm_density_ao, wf_r, wf_g, mo_arrays, TYPE(particle_list_type), POINTER :: particles INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN) :: append_cube - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), DIMENSION(0:9), PARAMETER :: torb_string = (/" s"," px"& ," py", " pz", "dxy", "dyz", "dzx", "dx2", "dy2", "dz2"/) @@ -324,7 +319,7 @@ SUBROUTINE stm_cubes(ks_env, stm_section, stm_density_ao, wf_r, wf_g, mo_arrays, CALL timeset(routineN,handle) failure=.FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() NULLIFY(fm_struct_tmp) nspin = SIZE(mo_arrays) @@ -370,10 +365,10 @@ SUBROUTINE stm_cubes(ks_env, stm_section, stm_density_ao, wf_r, wf_g, mo_arrays, IF(istates==0) CYCLE CALL cp_fm_struct_create(fm_struct_tmp, ncol_global=istates, & - template_fmstruct=mo_arrays(1)%matrix%matrix_struct, error=error) - CALL cp_fm_create(matrix_v,fm_struct_tmp, name="matrix_v",error=error) - CALL cp_fm_create(matrix_vf,fm_struct_tmp, name="matrix_vf",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + template_fmstruct=mo_arrays(1)%matrix%matrix_struct) + CALL cp_fm_create(matrix_v,fm_struct_tmp, name="matrix_v") + CALL cp_fm_create(matrix_vf,fm_struct_tmp, name="matrix_vf") + CALL cp_fm_struct_release(fm_struct_tmp) ALLOCATE(occ_tot(istates),STAT=istat) @@ -397,15 +392,15 @@ SUBROUTINE stm_cubes(ks_env, stm_section, stm_density_ao, wf_r, wf_g, mo_arrays, CALL cp_fm_column_scale(matrix_vf,occ_tot(1:istates)) alpha=1.0_dp - CALL cp_dbcsr_set(stm_density_ao,0.0_dp,error=error) + CALL cp_dbcsr_set(stm_density_ao,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(stm_density_ao,matrix_v=matrix_v, matrix_g=matrix_vf,ncol=istates,& - alpha=alpha,error=error) + alpha=alpha) DO i = 1,SIZE(stm_th_torb) iorb=stm_th_torb(i) CALL calculate_rho_elec(matrix_p=stm_density_ao,& rho=wf_r,rho_gspace=wf_g, total_rho=total_rho,& - ks_env=ks_env, der_type=iorb, error=error) + ks_env=ks_env, der_type=iorb) oname = torb_string(iorb) ! fname = "STM_"//TRIM(torb_string(iorb)) @@ -417,16 +412,16 @@ SUBROUTINE stm_cubes(ks_env, stm_section, stm_density_ao, wf_r, wf_g, mo_arrays, unit_nr=cp_print_key_unit_nr(logger,stm_section,extension=".cube",& middle_name=TRIM(filename),file_position=my_pos, file_action="WRITE",& - log_filename=.FALSE.,error=error) + log_filename=.FALSE.) WRITE(title,'(A,I0,A,I0,A,F16.8)') "STM cube ",ibias," wfn deriv. ",iorb," at bias ",stm_biases(ibias) CALL cp_pw_to_cube(wf_r%pw,unit_nr,title,particles=particles,& - stride=section_get_ivals(stm_section,"STRIDE",error=error),zero_tails=.TRUE., error=error) + stride=section_get_ivals(stm_section,"STRIDE"),zero_tails=.TRUE.) - CALL cp_print_key_finished_output(unit_nr,logger,stm_section,error=error) + CALL cp_print_key_finished_output(unit_nr,logger,stm_section) END DO - CALL cp_fm_release(matrix_v, error=error) - CALL cp_fm_release(matrix_vf, error=error) + CALL cp_fm_release(matrix_v) + CALL cp_fm_release(matrix_vf) DEALLOCATE(occ_tot,STAT=istat) ENDDO diff --git a/src/subcell_types.F b/src/subcell_types.F index b36164220b..545c064c65 100644 --- a/src/subcell_types.F +++ b/src/subcell_types.F @@ -45,19 +45,17 @@ MODULE subcell_types !> \param nsubcell ... !> \param maxatom ... !> \param cell ... -!> \param error ... !> \date 12.06.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_subcell(subcell,nsubcell,maxatom,cell,error) + SUBROUTINE allocate_subcell(subcell,nsubcell,maxatom,cell) TYPE(subcell_type), DIMENSION(:, :, :), & POINTER :: subcell INTEGER, DIMENSION(3), INTENT(IN) :: nsubcell INTEGER, INTENT(IN), OPTIONAL :: maxatom TYPE(cell_type), OPTIONAL, POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_subcell', & routineP = moduleN//':'//routineN @@ -74,7 +72,7 @@ SUBROUTINE allocate_subcell(subcell,nsubcell,maxatom,cell,error) nc = nsubcell(3) ALLOCATE (subcell(na,nb,nc),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) delta_a = 1.0_dp/REAL(na,dp) delta_b = 1.0_dp/REAL(nb,dp) @@ -109,7 +107,7 @@ SUBROUTINE allocate_subcell(subcell,nsubcell,maxatom,cell,error) END IF IF (PRESENT(maxatom)) THEN ALLOCATE (subcell(i,j,k)%atom_list(maxatom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF a_min = a_max END DO @@ -123,16 +121,14 @@ END SUBROUTINE allocate_subcell ! ***************************************************************************** !> \brief Deallocate a subcell grid structure. !> \param subcell ... -!> \param error ... !> \date 16.06.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_subcell(subcell,error) + SUBROUTINE deallocate_subcell(subcell) TYPE(subcell_type), DIMENSION(:, :, :), & POINTER :: subcell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_subcell', & routineP = moduleN//':'//routineN @@ -147,15 +143,15 @@ SUBROUTINE deallocate_subcell(subcell,error) DO j=1,SIZE(subcell,2) DO i=1,SIZE(subcell,1) DEALLOCATE (subcell(i,j,k)%atom_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO END DO END DO DEALLOCATE (subcell,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_subcell diff --git a/src/subsys/atomic_kind_list_types.F b/src/subsys/atomic_kind_list_types.F index c0d3602480..284622327b 100644 --- a/src/subsys/atomic_kind_list_types.F +++ b/src/subsys/atomic_kind_list_types.F @@ -92,21 +92,18 @@ MODULE atomic_kind_list_types !> will deallocate it (defaults to true) !> \param n_els number of elements in the list (at least one els_ptr or !> n_els should be given) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE atomic_kind_list_create(list, els_ptr, & - owns_els, n_els, error) + owns_els, n_els) TYPE(atomic_kind_list_type), OPTIONAL, & POINTER :: list TYPE(atomic_kind_type), DIMENSION(:), & OPTIONAL, POINTER :: els_ptr LOGICAL, INTENT(in), OPTIONAL :: owns_els INTEGER, INTENT(in), OPTIONAL :: n_els - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atomic_kind_list_create', & routineP = moduleN//':'//routineN @@ -116,10 +113,10 @@ SUBROUTINE atomic_kind_list_create(list, els_ptr, & failure=.FALSE. - CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,failure) ALLOCATE(list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_atomic_kind_list_id=last_atomic_kind_list_id+1 list%id_nr=last_atomic_kind_list_id list%ref_count=1 @@ -136,23 +133,20 @@ SUBROUTINE atomic_kind_list_create(list, els_ptr, & IF (PRESENT(n_els)) list%n_els=n_els IF (.NOT.ASSOCIATED(list%els)) THEN ALLOCATE(list%els(list%n_els),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP) END IF END SUBROUTINE atomic_kind_list_create ! ***************************************************************************** !> \brief retains a list (see doc/ReferenceCounting.html) !> \param list the list to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE atomic_kind_list_retain(list, error) +SUBROUTINE atomic_kind_list_retain(list) TYPE(atomic_kind_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atomic_kind_list_retain', & routineP = moduleN//':'//routineN @@ -161,23 +155,20 @@ SUBROUTINE atomic_kind_list_retain(list, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,error,failure) - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count+1 END SUBROUTINE atomic_kind_list_retain ! ***************************************************************************** !> \brief releases a list (see doc/ReferenceCounting.html) !> \param list the list to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE atomic_kind_list_release(list, error) +SUBROUTINE atomic_kind_list_release(list) TYPE(atomic_kind_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atomic_kind_list_release', & routineP = moduleN//':'//routineN @@ -188,17 +179,17 @@ SUBROUTINE atomic_kind_list_release(list, error) failure=.FALSE. IF (ASSOCIATED(list)) THEN - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count-1 IF (list%ref_count==0) THEN IF (list%owns_els) THEN IF (ASSOCIATED(list%els)) THEN - CALL deallocate_atomic_kind_set(list%els,error=error) + CALL deallocate_atomic_kind_set(list%els) END IF END IF NULLIFY(list%els) DEALLOCATE(list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(list) diff --git a/src/subsys/atomic_kind_types.F b/src/subsys/atomic_kind_types.F index e6bf03179a..f8c428567c 100644 --- a/src/subsys/atomic_kind_types.F +++ b/src/subsys/atomic_kind_types.F @@ -80,16 +80,14 @@ MODULE atomic_kind_types ! ***************************************************************************** !> \brief Destructor routine for a set of atomic kinds !> \param atomic_kind_set ... -!> \param error ... !> \date 02.01.2002 !> \author Matthias Krack (MK) !> \version 2.0 ! ***************************************************************************** - SUBROUTINE deallocate_atomic_kind_set(atomic_kind_set,error) + SUBROUTINE deallocate_atomic_kind_set(atomic_kind_set) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_atomic_kind_set', & routineP = moduleN//':'//routineN @@ -104,18 +102,18 @@ SUBROUTINE deallocate_atomic_kind_set(atomic_kind_set,error) DO ikind=1,nkind IF (ASSOCIATED(atomic_kind_set(ikind)%fist_potential)) THEN - CALL deallocate_potential(atomic_kind_set(ikind)%fist_potential,error) + CALL deallocate_potential(atomic_kind_set(ikind)%fist_potential) END IF IF (ASSOCIATED(atomic_kind_set(ikind)%atom_list)) THEN DEALLOCATE (atomic_kind_set(ikind)%atom_list,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) END IF - CALL shell_release(atomic_kind_set(ikind)%shell,error) + CALL shell_release(atomic_kind_set(ikind)%shell) - CALL damping_p_release(atomic_kind_set(ikind)%damping,error) + CALL damping_p_release(atomic_kind_set(ikind)%damping) END DO DEALLOCATE (atomic_kind_set,STAT=stat) - CPPostcondition(stat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(stat==0, cp_failure_level, routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer atomic_kind_set is not associated and "//& @@ -346,12 +344,11 @@ END SUBROUTINE get_atomic_kind_set !> \param shell ... !> \param shell_active ... !> \param damping ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_atomic_kind(atomic_kind,element_symbol,name,mass,kind_number,& natom,atom_list,& fist_potential,shell,& - shell_active,damping,error) + shell_active,damping) TYPE(atomic_kind_type), POINTER :: atomic_kind CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: element_symbol, name @@ -364,8 +361,6 @@ SUBROUTINE set_atomic_kind(atomic_kind,element_symbol,name,mass,kind_number,& TYPE(shell_kind_type), OPTIONAL, POINTER :: shell LOGICAL, INTENT(IN), OPTIONAL :: shell_active TYPE(damping_p_type), OPTIONAL, POINTER :: damping - TYPE(cp_error_type), INTENT(inout), & - OPTIONAL :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_atomic_kind', & routineP = moduleN//':'//routineN @@ -387,10 +382,10 @@ SUBROUTINE set_atomic_kind(atomic_kind,element_symbol,name,mass,kind_number,& IF (n > 0) THEN IF (ASSOCIATED(atomic_kind%atom_list)) THEN DEALLOCATE (atomic_kind%atom_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE (atomic_kind%atom_list(n),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) atomic_kind%atom_list(:) = atom_list(:) atomic_kind%natom = n ELSE @@ -401,7 +396,7 @@ SUBROUTINE set_atomic_kind(atomic_kind,element_symbol,name,mass,kind_number,& IF (PRESENT(fist_potential)) atomic_kind%fist_potential => fist_potential IF (PRESENT(shell)) THEN atomic_kind%shell => shell - CALL shell_retain(shell,error) + CALL shell_retain(shell) END IF IF (PRESENT(shell_active)) atomic_kind%shell_active=shell_active diff --git a/src/subsys/atprop_types.F b/src/subsys/atprop_types.F index a3821fdbea..71f422d515 100644 --- a/src/subsys/atprop_types.F +++ b/src/subsys/atprop_types.F @@ -45,11 +45,9 @@ MODULE atprop_types ! ***************************************************************************** !> \brief ... !> \param atprop_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atprop_create(atprop_env,error) + SUBROUTINE atprop_create(atprop_env) TYPE(atprop_type), POINTER :: atprop_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atprop_create', & routineP = moduleN//':'//routineN @@ -58,9 +56,9 @@ SUBROUTINE atprop_create(atprop_env,error) LOGICAL :: failure failure=.FALSE. - CALL atprop_release(atprop_env,error) + CALL atprop_release(atprop_env) ALLOCATE(atprop_env,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) NULLIFY(atprop_env%atener,atprop_env%atstress) NULLIFY(atprop_env%ateb,atprop_env%atevdw,atprop_env%atecc,atprop_env%atecoul) NULLIFY(atprop_env%ateself,atprop_env%atexc,atprop_env%ate1c) @@ -73,12 +71,10 @@ END SUBROUTINE atprop_create !> \brief ... !> \param atprop_env ... !> \param natom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atprop_init(atprop_env,natom,error) + SUBROUTINE atprop_init(atprop_env,natom) TYPE(atprop_type), POINTER :: atprop_env INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atprop_init', & routineP = moduleN//':'//routineN @@ -87,25 +83,25 @@ SUBROUTINE atprop_init(atprop_env,natom,error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(atprop_env),cp_warning_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atprop_env),cp_warning_level,routineP,failure) IF(atprop_env%energy) THEN - CALL atprop_array_init(atprop_env%atener,natom,error) - CALL atprop_array_release(atprop_env%ateb,error) - CALL atprop_array_release(atprop_env%atevdw,error) - CALL atprop_array_release(atprop_env%atecc,error) - CALL atprop_array_release(atprop_env%atecoul,error) - CALL atprop_array_release(atprop_env%ateself,error) - CALL atprop_array_release(atprop_env%atexc,error) - CALL atprop_array_release(atprop_env%ate1c,error) + CALL atprop_array_init(atprop_env%atener,natom) + CALL atprop_array_release(atprop_env%ateb) + CALL atprop_array_release(atprop_env%atevdw) + CALL atprop_array_release(atprop_env%atecc) + CALL atprop_array_release(atprop_env%atecoul) + CALL atprop_array_release(atprop_env%ateself) + CALL atprop_array_release(atprop_env%atexc) + CALL atprop_array_release(atprop_env%ate1c) END IF IF(atprop_env%stress) THEN IF(ASSOCIATED(atprop_env%atstress)) THEN - CPPrecondition(SIZE(atprop_env%atstress,3)==natom,cp_warning_level,routineP,error,failure) + CPPrecondition(SIZE(atprop_env%atstress,3)==natom,cp_warning_level,routineP,failure) ELSE ALLOCATE(atprop_env%atstress(3,3,natom),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF atprop_env%atstress = 0._dp END IF @@ -116,12 +112,10 @@ END SUBROUTINE atprop_init !> \brief ... !> \param atarray ... !> \param natom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atprop_array_init(atarray,natom,error) + SUBROUTINE atprop_array_init(atarray,natom) REAL(KIND=dp), DIMENSION(:), POINTER :: atarray INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atprop_array_init', & routineP = moduleN//':'//routineN @@ -132,10 +126,10 @@ SUBROUTINE atprop_array_init(atarray,natom,error) failure=.FALSE. IF(ASSOCIATED(atarray)) THEN - CPPrecondition(SIZE(atarray)==natom,cp_warning_level,routineP,error,failure) + CPPrecondition(SIZE(atarray)==natom,cp_warning_level,routineP,failure) ELSE ALLOCATE(atarray(natom),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF atarray = 0._dp @@ -144,11 +138,9 @@ END SUBROUTINE atprop_array_init ! ***************************************************************************** !> \brief ... !> \param atarray ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atprop_array_release(atarray,error) + SUBROUTINE atprop_array_release(atarray) REAL(KIND=dp), DIMENSION(:), POINTER :: atarray - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atprop_array_release', & routineP = moduleN//':'//routineN @@ -160,7 +152,7 @@ SUBROUTINE atprop_array_release(atarray,error) IF(ASSOCIATED(atarray)) THEN DEALLOCATE(atarray,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) NULLIFY(atarray) END IF @@ -170,11 +162,9 @@ END SUBROUTINE atprop_array_release !> \brief ... !> \param array_a ... !> \param array_b ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE atprop_array_add(array_a,array_b,error) + SUBROUTINE atprop_array_add(array_a,array_b) REAL(KIND=dp), DIMENSION(:), POINTER :: array_a, array_b - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atprop_array_add', & routineP = moduleN//':'//routineN @@ -184,7 +174,7 @@ SUBROUTINE atprop_array_add(array_a,array_b,error) failure=.FALSE. IF(ASSOCIATED(array_b)) THEN - CPPrecondition(ASSOCIATED(array_a),cp_warning_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(array_a),cp_warning_level,routineP,failure) array_a = array_a + array_b END IF @@ -193,13 +183,10 @@ END SUBROUTINE atprop_array_add ! ***************************************************************************** !> \brief releases the atprop !> \param atprop_env the object to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE atprop_release(atprop_env,error) +SUBROUTINE atprop_release(atprop_env) TYPE(atprop_type), POINTER :: atprop_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'atprop_release', & routineP = moduleN//':'//routineN @@ -210,22 +197,22 @@ SUBROUTINE atprop_release(atprop_env,error) failure=.FALSE. IF (ASSOCIATED(atprop_env)) THEN ! energy - CALL atprop_array_release(atprop_env%atener,error) - CALL atprop_array_release(atprop_env%ateb,error) - CALL atprop_array_release(atprop_env%ateself,error) - CALL atprop_array_release(atprop_env%atexc,error) - CALL atprop_array_release(atprop_env%atevdw,error) - CALL atprop_array_release(atprop_env%atecc,error) - CALL atprop_array_release(atprop_env%ate1c,error) - CALL atprop_array_release(atprop_env%atecoul,error) + CALL atprop_array_release(atprop_env%atener) + CALL atprop_array_release(atprop_env%ateb) + CALL atprop_array_release(atprop_env%ateself) + CALL atprop_array_release(atprop_env%atexc) + CALL atprop_array_release(atprop_env%atevdw) + CALL atprop_array_release(atprop_env%atecc) + CALL atprop_array_release(atprop_env%ate1c) + CALL atprop_array_release(atprop_env%atecoul) ! stress IF (ASSOCIATED(atprop_env%atstress)) THEN DEALLOCATE(atprop_env%atstress,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF ! atprop type DEALLOCATE(atprop_env,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF NULLIFY(atprop_env) END SUBROUTINE atprop_release diff --git a/src/subsys/cell_types.F b/src/subsys/cell_types.F index a055960170..489c3628be 100644 --- a/src/subsys/cell_types.F +++ b/src/subsys/cell_types.F @@ -93,12 +93,10 @@ MODULE cell_types !> \brief ... !> \param cell_in ... !> \param cell_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cell_clone (cell_in, cell_out, error) + SUBROUTINE cell_clone (cell_in, cell_out) TYPE(cell_type), POINTER :: cell_in, cell_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_clone', & routineP = moduleN//':'//routineN @@ -106,8 +104,8 @@ SUBROUTINE cell_clone (cell_in, cell_out, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(cell_in),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(cell_out),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell_in),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(cell_out),cp_failure_level,routineP,failure) cell_out%deth = cell_in%deth cell_out%perd = cell_in%perd @@ -125,12 +123,10 @@ END SUBROUTINE cell_clone !> \brief ... !> \param cell_in ... !> \param cell_out ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cell_copy (cell_in, cell_out, error) + SUBROUTINE cell_copy (cell_in, cell_out) TYPE(cell_type), POINTER :: cell_in, cell_out - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_copy', & routineP = moduleN//':'//routineN @@ -138,8 +134,8 @@ SUBROUTINE cell_copy (cell_in, cell_out, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(cell_in),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(cell_out),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell_in),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(cell_out),cp_failure_level,routineP,failure) cell_out%deth = cell_in%deth cell_out%perd = cell_in%perd @@ -157,19 +153,17 @@ END SUBROUTINE cell_copy !> \param cell_time ... !> \param h ... !> \param vol ... -!> \param error ... !> \date 19.02.2008 !> \author Teodoro Laino [tlaino] - University of Zurich !> \version 1.0 ! ***************************************************************************** - SUBROUTINE parse_cell_line(input_line, cell_itimes, cell_time, h, vol, error) + SUBROUTINE parse_cell_line(input_line, cell_itimes, cell_time, h, vol) CHARACTER(LEN=*), INTENT(IN) :: input_line INTEGER, INTENT(OUT) :: cell_itimes REAL(KIND=dp), INTENT(OUT) :: cell_time REAL(KIND=dp), DIMENSION(3, 3), & INTENT(OUT) :: h REAL(KIND=dp), INTENT(OUT) :: vol - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'parse_cell_line', & routineP = moduleN//':'//routineN @@ -182,7 +176,7 @@ SUBROUTINE parse_cell_line(input_line, cell_itimes, cell_time, h, vol, error) h(1,1),h(2,1),h(3,1), h(1,2),h(2,2),h(3,2), h(1,3),h(2,3),h(3,3),vol DO i = 1, 3 DO j = 1, 3 - h(j,i) = cp_unit_to_cp2k(h(j,i), "angstrom", error=error) + h(j,i) = cp_unit_to_cp2k(h(j,i), "angstrom") END DO END DO @@ -257,13 +251,11 @@ END SUBROUTINE get_cell !> \param cell_angle ... !> \param units_angle ... !> \param periodic ... -!> \param error ... !> \date 04.04.2002 !> \author Matthias Krack !> \version 1.0 ! ***************************************************************************** - SUBROUTINE get_cell_param(cell,cell_length,cell_angle,units_angle,periodic,& - error) + SUBROUTINE get_cell_param(cell,cell_length,cell_angle,units_angle,periodic) TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: cell_length @@ -272,7 +264,6 @@ SUBROUTINE get_cell_param(cell,cell_length,cell_angle,units_angle,periodic,& INTEGER, INTENT(IN), OPTIONAL :: units_angle INTEGER, DIMENSION(3), INTENT(OUT), & OPTIONAL :: periodic - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_cell_param', & routineP = moduleN//':'//routineN @@ -303,19 +294,16 @@ END SUBROUTINE get_cell_param !> \param cell_angle ... !> \param periodic ... !> \param do_init_cell ... -!> \param error ... !> \date 03.2008 !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE set_cell_param(cell,cell_length,cell_angle,periodic,do_init_cell,& - error) + SUBROUTINE set_cell_param(cell,cell_length,cell_angle,periodic,do_init_cell) TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: cell_length, cell_angle INTEGER, DIMENSION(3), INTENT(IN), & OPTIONAL :: periodic LOGICAL, INTENT(IN) :: do_init_cell - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_cell_param', & routineP = moduleN//':'//routineN @@ -325,7 +313,7 @@ SUBROUTINE set_cell_param(cell,cell_length,cell_angle,periodic,do_init_cell,& cos_gamma, eps, sin_gamma failure = .FALSE. - CPPrecondition(ALL(cell_angle/=0.0_dp),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(cell_angle/=0.0_dp),cp_failure_level,routineP,failure) eps = EPSILON(0.0_dp) cos_gamma = COS(cell_angle(3)); IF (ABS(cos_gamma) \param cell the cell to initialize !> \param hmat the h matrix that defines the cell !> \param periodic periodicity of the cell -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cell_create(cell,hmat,periodic,error) + SUBROUTINE cell_create(cell,hmat,periodic) TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN), OPTIONAL :: hmat INTEGER, DIMENSION(3), INTENT(IN), & OPTIONAL :: periodic - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_create', & routineP = moduleN//':'//routineN @@ -803,9 +788,9 @@ SUBROUTINE cell_create(cell,hmat,periodic,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(cell),cp_failure_level,routineP,failure) ALLOCATE (cell,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_cell_id = last_cell_id + 1 cell%id_nr = last_cell_id cell%ref_count = 1 @@ -824,16 +809,13 @@ END SUBROUTINE cell_create ! ***************************************************************************** !> \brief retains the given cell (see doc/ReferenceCounting.html) !> \param cell the cell to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cell_retain(cell,error) + SUBROUTINE cell_retain(cell) TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_retain', & routineP = moduleN//':'//routineN @@ -842,8 +824,8 @@ SUBROUTINE cell_retain(cell,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(cell%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) + CPPreconditionNoFail(cell%ref_count>0,cp_failure_level,routineP) cell%ref_count=cell%ref_count+1 END SUBROUTINE cell_retain @@ -851,16 +833,13 @@ END SUBROUTINE cell_retain ! ***************************************************************************** !> \brief releases the given cell (see doc/ReferenceCounting.html) !> \param cell the cell to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cell_release(cell,error) + SUBROUTINE cell_release(cell) TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cell_release', & routineP = moduleN//':'//routineN @@ -871,11 +850,11 @@ SUBROUTINE cell_release(cell,error) failure = .FALSE. IF (ASSOCIATED(cell)) THEN - CPPreconditionNoFail(cell%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(cell%ref_count>0,cp_failure_level,routineP) cell%ref_count=cell%ref_count-1 IF (cell%ref_count==0) THEN DEALLOCATE(cell,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF NULLIFY(cell) END IF diff --git a/src/subsys/colvar_types.F b/src/subsys/colvar_types.F index ac1937fffb..1109e134cd 100644 --- a/src/subsys/colvar_types.F +++ b/src/subsys/colvar_types.F @@ -373,14 +373,11 @@ MODULE colvar_types !> \brief initializes a colvar_param type !> \param colvar the colvat to initialize !> \param colvar_id ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author alessandro laio and fawzi mohamed ! ***************************************************************************** - SUBROUTINE colvar_create(colvar,colvar_id,error) + SUBROUTINE colvar_create(colvar,colvar_id) TYPE(colvar_type), POINTER :: colvar INTEGER, INTENT(in) :: colvar_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_create', & routineP = moduleN//':'//routineN @@ -389,9 +386,9 @@ SUBROUTINE colvar_create(colvar,colvar_id,error) LOGICAL :: failure failure=.FALSE. - CPPostcondition(.NOT.ASSOCIATED(colvar),cp_warning_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(colvar),cp_warning_level,routineP,failure) ALLOCATE(colvar, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ! Nullify all available COLVAR types NULLIFY(colvar%dist_param) NULLIFY(colvar%angle_param) @@ -423,83 +420,83 @@ SUBROUTINE colvar_create(colvar,colvar_id,error) SELECT CASE (colvar_id) CASE(dist_colvar_id) ALLOCATE(colvar%dist_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar%dist_param%axis_id = do_clv_xyz CASE(coord_colvar_id) ALLOCATE(colvar%coord_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(population_colvar_id) ALLOCATE(colvar%population_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(gyration_colvar_id) ALLOCATE(colvar%gyration_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(angle_colvar_id) ALLOCATE(colvar%angle_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(torsion_colvar_id) ALLOCATE(colvar%torsion_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(plane_distance_colvar_id) ALLOCATE(colvar%plane_distance_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(plane_plane_angle_colvar_id) ALLOCATE(colvar%plane_plane_angle_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(rotation_colvar_id) ALLOCATE(colvar%rotation_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(dfunct_colvar_id) ALLOCATE(colvar%dfunct_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(qparm_colvar_id) ALLOCATE(colvar%qparm_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(xyz_diag_colvar_id) ALLOCATE(colvar%xyz_diag_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ! Initialize r0 with dummy.. colvar%xyz_diag_param%r0=HUGE(0.0_dp) CASE(xyz_outerdiag_colvar_id) ALLOCATE(colvar%xyz_outerdiag_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ! Initialize r0 with dummy.. colvar%xyz_outerdiag_param%r0=HUGE(0.0_dp) CASE(u_colvar_id) ALLOCATE(colvar%u_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) NULLIFY(colvar%u_param%mixed_energy_section) CASE(hydronium_colvar_id) ALLOCATE(colvar%hydronium_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(reaction_path_colvar_id) ALLOCATE(colvar%reaction_path_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(distance_from_path_colvar_id) ALLOCATE(colvar%reaction_path_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(combine_colvar_id) ALLOCATE(colvar%combine_cvs_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(rmsd_colvar_id) ALLOCATE(colvar%rmsd_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(Wc_colvar_id) ALLOCATE(colvar%Wc, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(HBP_colvar_id) ALLOCATE(colvar%HBP, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(ring_puckering_colvar_id) ALLOCATE(colvar%ring_puckering_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(mindist_colvar_id) ALLOCATE(colvar%mindist_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE(no_colvar_id) ! Do nothing CASE DEFAULT - CPPostcondition(.FALSE.,cp_warning_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_warning_level,routineP,failure) END SELECT END SUBROUTINE colvar_create @@ -507,13 +504,10 @@ END SUBROUTINE colvar_create ! ***************************************************************************** !> \brief Finalize the setup of the collective variable !> \param colvar the colvar to initialize -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino, [teo] 09.03.2006 ! ***************************************************************************** - SUBROUTINE colvar_setup(colvar,error) + SUBROUTINE colvar_setup(colvar) TYPE(colvar_type), POINTER :: colvar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_setup', & routineP = moduleN//':'//routineN @@ -523,7 +517,7 @@ SUBROUTINE colvar_setup(colvar,error) INTEGER, DIMENSION(:), POINTER :: list LOGICAL :: failure - CPPostcondition(ASSOCIATED(colvar),cp_warning_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(colvar),cp_warning_level,routineP,failure) failure=.FALSE. SELECT CASE(colvar%type_id) CASE(dist_colvar_id) @@ -535,7 +529,7 @@ SUBROUTINE colvar_setup(colvar,error) COLV_SIZE(colvar,j) ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) list(1) = colvar%dist_param%i_at list(2) = colvar%dist_param%j_at CASE(coord_colvar_id) @@ -559,7 +553,7 @@ SUBROUTINE colvar_setup(colvar,error) END IF ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%coord_param%n_atoms_from idum = idum + 1 @@ -578,7 +572,7 @@ SUBROUTINE colvar_setup(colvar,error) list(idum) = i ENDDO END IF - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(population_colvar_id) np = colvar%population_param%n_atoms_from+colvar%population_param%n_atoms_to ! Number of real atoms involved in the colvar @@ -593,7 +587,7 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%population_param%n_atoms_from idum = idum + 1 @@ -605,7 +599,7 @@ SUBROUTINE colvar_setup(colvar,error) i = colvar%population_param%i_at_to(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(gyration_colvar_id) np = colvar%gyration_param%n_atoms ! Number of real atoms involved in the colvar @@ -616,14 +610,14 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%gyration_param%n_atoms idum = idum + 1 i = colvar%gyration_param%i_at(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(angle_colvar_id) np = 3 ! Number of real atoms involved in the colvar @@ -634,14 +628,14 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1, 3 idum = idum + 1 i = colvar%angle_param%i_at_angle(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(torsion_colvar_id) np = 4 ! Number of real atoms involved in the colvar @@ -652,14 +646,14 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1, 4 idum = idum + 1 i = colvar%torsion_param%i_at_tors(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(plane_distance_colvar_id) np = 4 ! Number of real atoms involved in the colvar @@ -672,7 +666,7 @@ SUBROUTINE colvar_setup(colvar,error) colvar%n_atom_s=colvar%n_atom_s+COLV_SIZE(colvar,i) ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1, 3 idum = idum + 1 @@ -682,7 +676,7 @@ SUBROUTINE colvar_setup(colvar,error) i = colvar%plane_distance_param%point list(4) = i idum = idum + 1 - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(plane_plane_angle_colvar_id) np = 0 IF (colvar%plane_plane_angle_param%plane1%type_of_def==plane_def_atoms) np = np +3 @@ -711,7 +705,7 @@ SUBROUTINE colvar_setup(colvar,error) ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 IF (colvar%plane_plane_angle_param%plane1%type_of_def==plane_def_atoms) THEN DO ii=1, 3 @@ -727,7 +721,7 @@ SUBROUTINE colvar_setup(colvar,error) list(idum) = i ENDDO END IF - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(dfunct_colvar_id) np = 4 ! Number of real atoms involved in the colvar @@ -738,14 +732,14 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1, 4 idum = idum + 1 i = colvar%dfunct_param%i_at_dfunct(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(rotation_colvar_id) np = 4 ! Number of real atoms involved in the colvar @@ -760,7 +754,7 @@ SUBROUTINE colvar_setup(colvar,error) colvar%n_atom_s=colvar%n_atom_s+COLV_SIZE(colvar,i) ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) i = colvar%rotation_param%i_at1_bond1 list(1) = i i = colvar%rotation_param%i_at2_bond1 @@ -783,7 +777,7 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%qparm_param%n_atoms_from idum = idum + 1 @@ -795,7 +789,7 @@ SUBROUTINE colvar_setup(colvar,error) i = colvar%qparm_param%i_at_to(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(hydronium_colvar_id) np = colvar%hydronium_param%n_oxygens+colvar%hydronium_param%n_hydrogens ! Number of real atoms involved in the colvar @@ -810,7 +804,7 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%hydronium_param%n_oxygens idum = idum + 1 @@ -822,7 +816,7 @@ SUBROUTINE colvar_setup(colvar,error) i = colvar%hydronium_param%i_hydrogens(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(rmsd_colvar_id) np = colvar%rmsd_param%n_atoms ! Number of real atoms involved in the colvar @@ -833,7 +827,7 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%rmsd_param%n_atoms idum = idum+1 @@ -873,7 +867,7 @@ SUBROUTINE colvar_setup(colvar,error) colvar%n_atom_s=colvar%n_atom_s+COLV_SIZE(colvar,i) ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) i = colvar%xyz_diag_param%i_atom list(1) = i CASE(xyz_outerdiag_colvar_id) @@ -886,14 +880,14 @@ SUBROUTINE colvar_setup(colvar,error) colvar%n_atom_s=colvar%n_atom_s+COLV_SIZE(colvar,i) ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) i = colvar%xyz_outerdiag_param%i_atoms(1) list(1) = i i = colvar%xyz_outerdiag_param%i_atoms(2) list(2) = i CASE(u_colvar_id) np = 1; ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) colvar%n_atom_s=np; list(1)=1 CASE(Wc_colvar_id) np = 3 @@ -905,14 +899,14 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1, 3 idum = idum + 1 i = colvar%Wc%ids(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(HBP_colvar_id) np = 3*colvar%HBP%nPoints ! Number of real atoms involved in the colvar @@ -925,7 +919,7 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO j=1,colvar%HBP%nPoints DO ii=1, 3 @@ -934,7 +928,7 @@ SUBROUTINE colvar_setup(colvar,error) list(idum) = i ENDDO ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(ring_puckering_colvar_id) np = colvar%ring_puckering_param%nring ! Number of real atoms involved in the colvar @@ -945,14 +939,14 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%ring_puckering_param%nring idum = idum + 1 i = colvar%ring_puckering_param%atoms(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(mindist_colvar_id) np =colvar%mindist_param%n_dist_from +& colvar%mindist_param%n_coord_from+colvar%mindist_param%n_coord_to @@ -972,7 +966,7 @@ SUBROUTINE colvar_setup(colvar,error) ENDDO ! Create a List of points... ALLOCATE(list(np),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) idum = 0 DO ii=1,colvar%mindist_param%n_dist_from idum = idum + 1 @@ -989,7 +983,7 @@ SUBROUTINE colvar_setup(colvar,error) i = colvar%mindist_param%i_coord_to(ii) list(idum) = i ENDDO - CPPostcondition(idum==np,cp_failure_level,routinep,error,failure) + CPPostcondition(idum==np,cp_failure_level,routinep,failure) CASE(combine_colvar_id) colvar%n_atom_s=0 DO ii=1,SIZE(colvar%combine_cvs_param%colvar_p) @@ -1007,16 +1001,16 @@ SUBROUTINE colvar_setup(colvar,error) IF (ASSOCIATED(colvar%dsdr)) THEN DEALLOCATE(colvar%dsdr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%i_atom)) THEN DEALLOCATE(colvar%i_atom, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF ALLOCATE(colvar%dsdr(3,colvar%n_atom_s), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ALLOCATE(colvar%i_atom(colvar%n_atom_s), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ! And now map real atoms istart = 0 iend = 0 @@ -1033,9 +1027,9 @@ SUBROUTINE colvar_setup(colvar,error) END IF END IF END DO - CPPostcondition(iend==colvar%n_atom_s,cp_failure_level,routinep,error,failure) + CPPostcondition(iend==colvar%n_atom_s,cp_failure_level,routinep,failure) DEALLOCATE(list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END SUBROUTINE colvar_setup @@ -1063,13 +1057,10 @@ END FUNCTION colv_size ! ***************************************************************************** !> \brief releases the memory that might have been allocated by the colvar !> \param colvar the colvar to deallocate -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author alessandro laio and fawzi mohamed ! ***************************************************************************** - RECURSIVE SUBROUTINE colvar_release(colvar,error) + RECURSIVE SUBROUTINE colvar_release(colvar) TYPE(colvar_type), POINTER :: colvar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_release', & routineP = moduleN//':'//routineN @@ -1078,217 +1069,217 @@ RECURSIVE SUBROUTINE colvar_release(colvar,error) LOGICAL :: failure failure=.FALSE. - CPPostcondition(ASSOCIATED(colvar),cp_warning_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(colvar),cp_warning_level,routineP,failure) IF (ASSOCIATED(colvar%dsdr)) THEN DEALLOCATE(colvar%dsdr, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%i_atom)) THEN DEALLOCATE(colvar%i_atom, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%points)) THEN DO i = 1, SIZE(colvar%points) IF (ASSOCIATED(colvar%points(i)%atoms)) THEN DEALLOCATE(colvar%points(i)%atoms, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%points(i)%weights)) THEN DEALLOCATE(colvar%points(i)%weights, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF END DO DEALLOCATE(colvar%points, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF SELECT CASE(colvar%type_id) CASE (dist_colvar_id) DEALLOCATE(colvar%dist_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (coord_colvar_id) IF (ASSOCIATED(colvar%coord_param%i_at_from)) THEN DEALLOCATE(colvar%coord_param%i_at_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%coord_param%i_at_to)) THEN DEALLOCATE(colvar%coord_param%i_at_to,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(colvar%coord_param%c_kinds_from)) THEN DEALLOCATE(colvar%coord_param%c_kinds_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%coord_param%c_kinds_to)) THEN DEALLOCATE(colvar%coord_param%c_kinds_to,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(colvar%coord_param%i_at_to_b)) THEN DEALLOCATE(colvar%coord_param%i_at_to_b,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(colvar%coord_param%c_kinds_to_b)) THEN DEALLOCATE(colvar%coord_param%c_kinds_to_b,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF DEALLOCATE(colvar%coord_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (population_colvar_id) IF (ASSOCIATED(colvar%population_param%i_at_from)) THEN DEALLOCATE(colvar%population_param%i_at_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%population_param%i_at_to)) THEN DEALLOCATE(colvar%population_param%i_at_to,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(colvar%population_param%c_kinds_from)) THEN DEALLOCATE(colvar%population_param%c_kinds_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%population_param%c_kinds_to)) THEN DEALLOCATE(colvar%population_param%c_kinds_to,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF DEALLOCATE(colvar%population_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (gyration_colvar_id) IF (ASSOCIATED(colvar%gyration_param%i_at)) THEN DEALLOCATE(colvar%gyration_param%i_at, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%gyration_param%c_kinds)) THEN DEALLOCATE(colvar%gyration_param%c_kinds, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF DEALLOCATE(colvar%gyration_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE(angle_colvar_id) DEALLOCATE(colvar%angle_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (torsion_colvar_id) DEALLOCATE(colvar%torsion_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE(plane_distance_colvar_id) DEALLOCATE(colvar%plane_distance_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE(plane_plane_angle_colvar_id) DEALLOCATE(colvar%plane_plane_angle_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE(dfunct_colvar_id) DEALLOCATE(colvar%dfunct_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (rotation_colvar_id) DEALLOCATE(colvar%rotation_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (qparm_colvar_id) DEALLOCATE(colvar%qparm_param%i_at_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%qparm_param%i_at_to,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DEALLOCATE(colvar%qparm_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (xyz_diag_colvar_id) DEALLOCATE(colvar%xyz_diag_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (xyz_outerdiag_colvar_id) DEALLOCATE(colvar%xyz_outerdiag_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (u_colvar_id) NULLIFY(colvar%u_param%mixed_energy_section) DEALLOCATE(colvar%u_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (hydronium_colvar_id) DEALLOCATE(colvar%hydronium_param%i_oxygens, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%hydronium_param%i_hydrogens,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DEALLOCATE(colvar%hydronium_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (reaction_path_colvar_id, distance_from_path_colvar_id) IF(colvar%reaction_path_param%dist_rmsd .OR. colvar%reaction_path_param%rmsd) THEN DEALLOCATE(colvar%reaction_path_param%r_ref,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%reaction_path_param%i_rmsd,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) ELSE DO i=1,SIZE(colvar%reaction_path_param%colvar_p) - CALL colvar_release(colvar%reaction_path_param%colvar_p(i)%colvar,error) + CALL colvar_release(colvar%reaction_path_param%colvar_p(i)%colvar) END DO DEALLOCATE(colvar%reaction_path_param%colvar_p, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%reaction_path_param%f_vals, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF DEALLOCATE(colvar%reaction_path_param,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (combine_colvar_id) DO i=1,SIZE(colvar%combine_cvs_param%colvar_p) - CALL colvar_release(colvar%combine_cvs_param%colvar_p(i)%colvar,error) + CALL colvar_release(colvar%combine_cvs_param%colvar_p(i)%colvar) END DO DEALLOCATE(colvar%combine_cvs_param%colvar_p, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%combine_cvs_param%c_parameters, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%combine_cvs_param%v_parameters, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%combine_cvs_param%variables, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%combine_cvs_param,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (rmsd_colvar_id) DEALLOCATE(colvar%rmsd_param%weights, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%rmsd_param%r_ref, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%rmsd_param%i_rmsd, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%rmsd_param,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE(Wc_colvar_id) DEALLOCATE(colvar%Wc, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE(HBP_colvar_id) DEALLOCATE(colvar%HBP%ewc, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%HBP%ids, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%HBP, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE (ring_puckering_colvar_id) DEALLOCATE(colvar%ring_puckering_param%atoms, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) DEALLOCATE(colvar%ring_puckering_param, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) CASE (mindist_colvar_id) IF (ASSOCIATED(colvar%mindist_param%i_dist_from)) THEN DEALLOCATE(colvar%mindist_param%i_dist_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%mindist_param%i_coord_from)) THEN DEALLOCATE(colvar%mindist_param%i_coord_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%mindist_param%i_coord_to)) THEN DEALLOCATE(colvar%mindist_param%i_coord_to,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF IF (ASSOCIATED(colvar%mindist_param%k_coord_from)) THEN DEALLOCATE(colvar%mindist_param%k_coord_from, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) END IF IF (ASSOCIATED(colvar%mindist_param%k_coord_to)) THEN DEALLOCATE(colvar%mindist_param%k_coord_to,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF DEALLOCATE(colvar%mindist_param, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routinep,error,failure) + CPPostcondition(stat==0,cp_failure_level,routinep,failure) CASE(no_colvar_id) ! Do nothing CASE default - CPAssert(.FALSE.,cp_failure_level,routinep,error,failure) + CPAssert(.FALSE.,cp_failure_level,routinep,failure) END SELECT DEALLOCATE(colvar, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE colvar_release @@ -1297,14 +1288,11 @@ END SUBROUTINE colvar_release !> \param colvar_out ... !> \param colvar_in the colvar to deallocate !> \param i_atom_offset ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 04.2006 ! ***************************************************************************** - RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) + RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset) TYPE(colvar_type), POINTER :: colvar_out, colvar_in INTEGER, INTENT(IN), OPTIONAL :: i_atom_offset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_clone', & routineP = moduleN//':'//routineN @@ -1315,11 +1303,11 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) my_offset = 0 failure=.FALSE. - CPPostcondition(ASSOCIATED(colvar_in),cp_warning_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(colvar_out),cp_warning_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(colvar_in),cp_warning_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(colvar_out),cp_warning_level,routineP,failure) IF (PRESENT(i_atom_offset)) my_offset = i_atom_offset - CALL colvar_create(colvar_out, colvar_in%type_id, error) - CALL colvar_clone_points(colvar_out, colvar_in, my_offset, error) + CALL colvar_create(colvar_out, colvar_in%type_id) + CALL colvar_clone_points(colvar_out, colvar_in, my_offset) IF (colvar_in%use_points) my_offset = 0 SELECT CASE(colvar_out%type_id) CASE(dist_colvar_id) @@ -1346,39 +1334,39 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) ! KINDS ndim = SIZE(colvar_in%coord_param%c_kinds_from) ALLOCATE(colvar_out%coord_param%c_kinds_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%coord_param%c_kinds_from = colvar_in%coord_param%c_kinds_from ELSE ! INDEX ndim = SIZE(colvar_in%coord_param%i_at_from) ALLOCATE(colvar_out%coord_param%i_at_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%coord_param%i_at_from = colvar_in%coord_param%i_at_from + my_offset END IF IF(colvar_in%coord_param%use_kinds_to) THEN ! KINDS ndim = SIZE(colvar_in%coord_param%c_kinds_to) ALLOCATE(colvar_out%coord_param%c_kinds_to(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%coord_param%c_kinds_to = colvar_in%coord_param%c_kinds_to ELSE ! INDEX ndim = SIZE(colvar_in%coord_param%i_at_to) ALLOCATE(colvar_out%coord_param%i_at_to(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%coord_param%i_at_to = colvar_in%coord_param%i_at_to + my_offset END IF IF(colvar_in%coord_param%use_kinds_to_b) THEN ! KINDS ndim = SIZE(colvar_in%coord_param%c_kinds_to_b) ALLOCATE(colvar_out%coord_param%c_kinds_to_b(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%coord_param%c_kinds_to_b = colvar_in%coord_param%c_kinds_to_b ELSEIF(ASSOCIATED(colvar_in%coord_param%i_at_to_b)) THEN ! INDEX ndim = SIZE(colvar_in%coord_param%i_at_to_b) ALLOCATE(colvar_out%coord_param%i_at_to_b(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%coord_param%i_at_to_b = colvar_in%coord_param%i_at_to_b + my_offset END IF @@ -1397,26 +1385,26 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) ! KINDS ndim = SIZE(colvar_in%population_param%c_kinds_from) ALLOCATE(colvar_out%population_param%c_kinds_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%population_param%c_kinds_from = colvar_in%population_param%c_kinds_from ELSE ! INDEX ndim = SIZE(colvar_in%population_param%i_at_from) ALLOCATE(colvar_out%population_param%i_at_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%population_param%i_at_from = colvar_in%population_param%i_at_from + my_offset END IF IF(colvar_in%population_param%use_kinds_to) THEN ! KINDS ndim = SIZE(colvar_in%population_param%c_kinds_to) ALLOCATE(colvar_out%population_param%c_kinds_to(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%population_param%c_kinds_to = colvar_in%population_param%c_kinds_to ELSE ! INDEX ndim = SIZE(colvar_in%population_param%i_at_to) ALLOCATE(colvar_out%population_param%i_at_to(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%population_param%i_at_to = colvar_in%population_param%i_at_to + my_offset END IF @@ -1428,13 +1416,13 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) ! KINDS ndim = SIZE(colvar_in%gyration_param%c_kinds) ALLOCATE(colvar_out%gyration_param%c_kinds(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%gyration_param%c_kinds = colvar_in%gyration_param%c_kinds ELSE ! INDEX ndim = SIZE(colvar_in%gyration_param%i_at) ALLOCATE(colvar_out%gyration_param%i_at(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%gyration_param%i_at = colvar_in%gyration_param%i_at + my_offset END IF CASE(angle_colvar_id) @@ -1477,10 +1465,10 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) colvar_out%qparm_param%alpha = colvar_in%qparm_param%alpha ndim = SIZE(colvar_in%qparm_param%i_at_from) ALLOCATE(colvar_out%qparm_param%i_at_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ndim = SIZE(colvar_in%qparm_param%i_at_to) ALLOCATE(colvar_out%qparm_param%i_at_to(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%qparm_param%i_at_from = colvar_in%qparm_param%i_at_from + my_offset colvar_out%qparm_param%i_at_to = colvar_in%qparm_param%i_at_from + my_offset CASE(xyz_diag_colvar_id) @@ -1510,10 +1498,10 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) colvar_out%hydronium_param%r_OH = colvar_in%hydronium_param%r_OH ndim = SIZE(colvar_in%hydronium_param%i_oxygens) ALLOCATE(colvar_out%hydronium_param%i_oxygens(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ndim = SIZE(colvar_in%hydronium_param%i_hydrogens) ALLOCATE(colvar_out%hydronium_param%i_hydrogens(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%hydronium_param%i_oxygens = colvar_in%hydronium_param%i_oxygens + my_offset colvar_out%hydronium_param%i_hydrogens = colvar_in%hydronium_param%i_oxygens + my_offset CASE(reaction_path_colvar_id, distance_from_path_colvar_id) @@ -1535,19 +1523,19 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) ELSE ndim=SIZE(colvar_in%reaction_path_param%colvar_p) ALLOCATE(colvar_out%reaction_path_param%colvar_p(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DO i=1,ndim NULLIFY(colvar_out%reaction_path_param%colvar_p(i)%colvar) CALL colvar_clone(colvar_out%reaction_path_param%colvar_p(i)%colvar,& colvar_in%reaction_path_param%colvar_p(i)%colvar,& - my_offset,error) + my_offset) END DO colvar_out%reaction_path_param% function_bounds = colvar_in%reaction_path_param% function_bounds NULLIFY(colvar_out%reaction_path_param%f_vals) ndim=SIZE(colvar_in%reaction_path_param%f_vals,1) ndim2=SIZE(colvar_in%reaction_path_param%f_vals,2) ALLOCATE(colvar_out%reaction_path_param%f_vals(ndim,ndim2),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%reaction_path_param%f_vals = colvar_in%reaction_path_param%f_vals END IF colvar_out%reaction_path_param%step_size = colvar_in%reaction_path_param%step_size @@ -1556,12 +1544,12 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) CASE(combine_colvar_id) ndim=SIZE(colvar_in%combine_cvs_param%colvar_p) ALLOCATE(colvar_out%combine_cvs_param%colvar_p(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) DO i=1,ndim NULLIFY(colvar_out%combine_cvs_param%colvar_p(i)%colvar) CALL colvar_clone(colvar_out%combine_cvs_param%colvar_p(i)%colvar,& colvar_in%combine_cvs_param%colvar_p(i)%colvar,& - my_offset,error) + my_offset) END DO colvar_out%combine_cvs_param%lerr = colvar_in%combine_cvs_param%lerr colvar_out%combine_cvs_param%dx = colvar_in%combine_cvs_param%dx @@ -1569,17 +1557,17 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) ! ndim = SIZE(colvar_in%combine_cvs_param%c_parameters) ALLOCATE(colvar_out%combine_cvs_param%c_parameters(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%combine_cvs_param%c_parameters = colvar_in%combine_cvs_param%c_parameters ! ndim = SIZE(colvar_in%combine_cvs_param%v_parameters) ALLOCATE(colvar_out%combine_cvs_param%v_parameters(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%combine_cvs_param%v_parameters = colvar_in%combine_cvs_param%v_parameters ! ndim = SIZE(colvar_in%combine_cvs_param%variables) ALLOCATE(colvar_out%combine_cvs_param%variables(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%combine_cvs_param%variables = colvar_in%combine_cvs_param%variables CASE(rmsd_colvar_id) colvar_out%rmsd_param%n_atoms = colvar_in%rmsd_param%n_atoms @@ -1592,17 +1580,17 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) ! INDEX ndim = SIZE(colvar_in%rmsd_param%i_rmsd) ALLOCATE(colvar_out%rmsd_param%i_rmsd(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%rmsd_param%i_rmsd = colvar_in%rmsd_param%i_rmsd + my_offset ! A and Bconfigurations and weights ndim = SIZE(colvar_in%rmsd_param%weights) ALLOCATE(colvar_out%rmsd_param%weights(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%rmsd_param%weights = colvar_in%rmsd_param%weights ndim = SIZE(colvar_in%rmsd_param%r_ref,1) ndim2 = SIZE(colvar_in%rmsd_param%r_ref,2) ALLOCATE(colvar_out%rmsd_param%r_ref(ndim,ndim2),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%rmsd_param%r_ref = colvar_in%rmsd_param%r_ref CASE(Wc_colvar_id) colvar_out%Wc%ids = colvar_in%Wc%ids + my_offset @@ -1610,9 +1598,9 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) CASE(HBP_colvar_id) ndim=colvar_out%HBP%nPoints ALLOCATE(colvar_out%HBP%ids(ndim,3),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) ALLOCATE(colvar_out%HBP%ewc(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%HBP%ids = colvar_in%HBP%ids + my_offset colvar_out%HBP%ewc = colvar_in%HBP%ewc + my_offset colvar_out%HBP%nPoints = colvar_in%HBP%nPoints @@ -1623,7 +1611,7 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) colvar_out%ring_puckering_param%nring = colvar_in%ring_puckering_param%nring colvar_out%ring_puckering_param%iq = colvar_in%ring_puckering_param%iq ALLOCATE(colvar_out%ring_puckering_param%atoms(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%ring_puckering_param%atoms = colvar_in%ring_puckering_param%atoms + my_offset CASE(mindist_colvar_id) colvar_out%mindist_param%n_dist_from = colvar_in%mindist_param%n_dist_from @@ -1641,37 +1629,37 @@ RECURSIVE SUBROUTINE colvar_clone(colvar_out, colvar_in, i_atom_offset, error) ! INDEX ndim = SIZE(colvar_in%mindist_param%i_dist_from) ALLOCATE(colvar_out%mindist_param%i_dist_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%mindist_param%i_dist_from = colvar_in%mindist_param%i_dist_from + my_offset IF(colvar_in%mindist_param%use_kinds_from) THEN ! KINDS ndim = SIZE(colvar_in%mindist_param%k_coord_from) ALLOCATE(colvar_out%mindist_param%k_coord_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%mindist_param%k_coord_from = colvar_in%mindist_param%k_coord_from ELSE ! INDEX ndim = SIZE(colvar_in%mindist_param%i_coord_from) ALLOCATE(colvar_out%mindist_param%i_coord_from(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%mindist_param%i_coord_from = colvar_in%mindist_param%i_coord_from + my_offset END IF IF(colvar_in%mindist_param%use_kinds_to) THEN ! KINDS ndim = SIZE(colvar_in%mindist_param%k_coord_to) ALLOCATE(colvar_out%mindist_param%k_coord_to(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%mindist_param%k_coord_to = colvar_in%mindist_param%k_coord_to ELSE ! INDEX ndim = SIZE(colvar_in%mindist_param%i_coord_to) ALLOCATE(colvar_out%mindist_param%i_coord_to(ndim),stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) colvar_out%mindist_param%i_coord_to = colvar_in%mindist_param%i_coord_to + my_offset END IF END SELECT - CALL colvar_setup(colvar_out, error) + CALL colvar_setup(colvar_out) END SUBROUTINE colvar_clone ! ***************************************************************************** @@ -1679,14 +1667,11 @@ END SUBROUTINE colvar_clone !> \param colvar_out ... !> \param colvar_in the colvar to deallocate !> \param offset ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 03.2007 ! ***************************************************************************** - SUBROUTINE colvar_clone_points(colvar_out, colvar_in, offset, error) + SUBROUTINE colvar_clone_points(colvar_out, colvar_in, offset) TYPE(colvar_type), POINTER :: colvar_out, colvar_in INTEGER, INTENT(IN) :: offset - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_clone_points', & routineP = moduleN//':'//routineN @@ -1697,15 +1682,15 @@ SUBROUTINE colvar_clone_points(colvar_out, colvar_in, offset, error) failure=.FALSE. colvar_out%use_points = colvar_in%use_points IF (colvar_in%use_points) THEN - CPPostcondition(ASSOCIATED(colvar_in%points),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(colvar_in%points),cp_failure_level,routineP,failure) npoints = SIZE(colvar_in%points) ALLOCATE(colvar_out%points(npoints),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, npoints IF (ASSOCIATED(colvar_in%points(i)%atoms)) THEN natoms = SIZE(colvar_in%points(i)%atoms) ALLOCATE(colvar_out%points(i)%atoms(natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) colvar_out%points(i)%atoms = colvar_in%points(i)%atoms+offset ELSE NULLIFY(colvar_out%points(i)%atoms) @@ -1713,7 +1698,7 @@ SUBROUTINE colvar_clone_points(colvar_out, colvar_in, offset, error) IF (ASSOCIATED(colvar_in%points(i)%weights)) THEN natoms = SIZE(colvar_in%points(i)%weights) ALLOCATE(colvar_out%points(i)%weights(natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) colvar_out%points(i)%weights = colvar_in%points(i)%weights ELSE NULLIFY(colvar_out%points(i)%weights) @@ -1732,15 +1717,12 @@ END SUBROUTINE colvar_clone_points !> \param colvar_set ... !> \param lb1_new ... !> \param ub1_new ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Teodoro Laino [tlaino] 04.2006 ! ***************************************************************************** - SUBROUTINE colvar_p_reallocate(colvar_set,lb1_new,ub1_new, error) + SUBROUTINE colvar_p_reallocate(colvar_set,lb1_new,ub1_new) TYPE(colvar_p_type), DIMENSION(:), & POINTER :: colvar_set INTEGER, INTENT(IN) :: lb1_new, ub1_new - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'colvar_p_reallocate', & routineP = moduleN//':'//routineN @@ -1759,21 +1741,21 @@ SUBROUTINE colvar_p_reallocate(colvar_set,lb1_new,ub1_new, error) lb1 = MAX(lb1_new,lb1_old) ub1 = MIN(ub1_new,ub1_old) ALLOCATE (work(lb1:ub1),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = lb1, ub1 NULLIFY(work(j)%colvar) - CALL colvar_clone(work(j)%colvar, colvar_set(j)%colvar, error=error) + CALL colvar_clone(work(j)%colvar, colvar_set(j)%colvar) END DO DO j = lb1, ub1 - CALL colvar_release(colvar_set(j)%colvar, error) + CALL colvar_release(colvar_set(j)%colvar) NULLIFY(colvar_set(j)%colvar) END DO DEALLOCATE(colvar_set, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ALLOCATE (colvar_set(lb1_new:ub1_new),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = lb1_new, ub1_new NULLIFY(colvar_set(j)%colvar) @@ -1782,14 +1764,14 @@ SUBROUTINE colvar_p_reallocate(colvar_set,lb1_new,ub1_new, error) lb1 = MAX(lb1_new,lb1_old) ub1 = MIN(ub1_new,ub1_old) DO j = lb1, ub1 - CALL colvar_clone(colvar_set(j)%colvar, work(j)%colvar, error=error) + CALL colvar_clone(colvar_set(j)%colvar, work(j)%colvar) END DO DO j = lb1, ub1 - CALL colvar_release(work(j)%colvar, error) + CALL colvar_release(work(j)%colvar) NULLIFY(work(j)%colvar) END DO DEALLOCATE (work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE colvar_p_reallocate @@ -1797,16 +1779,14 @@ END SUBROUTINE colvar_p_reallocate ! ***************************************************************************** !> \brief Deallocate a set of colvar_p_type !> \param colvar_p ... -!> \param error ... !> \par History !> 07.2003 created [fawzi] !> 01.2014 moved from cp_subsys_release() into separate routine. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE colvar_p_release(colvar_p, error) + SUBROUTINE colvar_p_release(colvar_p) TYPE(colvar_p_type), DIMENSION(:), & POINTER :: colvar_p - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i @@ -1815,7 +1795,7 @@ SUBROUTINE colvar_p_release(colvar_p, error) IF(ASSOCIATED(colvar_p)) THEN DO i=1,SIZE(colvar_p) IF (ASSOCIATED(colvar_p(i)%colvar)) & - CALL colvar_release(colvar_p(i)%colvar,error) + CALL colvar_release(colvar_p(i)%colvar) ENDDO DEALLOCATE(colvar_p) END IF diff --git a/src/subsys/cp_subsys_types.F b/src/subsys/cp_subsys_types.F index 706b338460..b6faddee0e 100644 --- a/src/subsys/cp_subsys_types.F +++ b/src/subsys/cp_subsys_types.F @@ -128,15 +128,12 @@ MODULE cp_subsys_types ! ***************************************************************************** !> \brief retains a subsys (see doc/ReferenceCounting.html) !> \param subsys the subsys to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_subsys_retain(subsys, error) + SUBROUTINE cp_subsys_retain(subsys) TYPE(cp_subsys_type), POINTER :: subsys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_subsys_retain', & routineP = moduleN//':'//routineN @@ -145,47 +142,44 @@ SUBROUTINE cp_subsys_retain(subsys, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,failure) + CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP) subsys%ref_count=subsys%ref_count+1 END SUBROUTINE cp_subsys_retain ! ***************************************************************************** !> \brief releases a subsys (see doc/ReferenceCounting.html) !> \param subsys the subsys to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_subsys_release(subsys, error) + SUBROUTINE cp_subsys_release(subsys) TYPE(cp_subsys_type), POINTER :: subsys - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_subsys_release', & routineP = moduleN//':'//routineN IF (ASSOCIATED(subsys)) THEN - CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(subsys%ref_count>0,cp_failure_level,routineP) subsys%ref_count=subsys%ref_count-1 IF (subsys%ref_count==0) THEN - CALL atomic_kind_list_release(subsys%atomic_kinds,error=error) - CALL particle_list_release(subsys%particles, error=error) - CALL particle_list_release(subsys%shell_particles, error=error) - CALL particle_list_release(subsys%core_particles, error=error) - CALL distribution_1d_release(subsys%local_particles, error=error) - CALL mol_kind_new_list_release(subsys%molecule_kinds_new, error=error) - CALL mol_new_list_release(subsys%molecules_new, error=error) - CALL distribution_1d_release(subsys%local_molecules_new,error=error) - CALL cp_para_env_release(subsys%para_env, error=error) - CALL release_multipole_type(subsys%multipoles, error) - CALL colvar_p_release(subsys%colvar_p, error) - CALL deallocate_global_constraint(subsys%gci, error) - CALL atprop_release(subsys%atprop,error=error) - CALL virial_release(subsys%virial,error=error) - CALL cp_result_release(subsys%results,error=error) - CALL cell_release(subsys%cell,error=error) + CALL atomic_kind_list_release(subsys%atomic_kinds) + CALL particle_list_release(subsys%particles) + CALL particle_list_release(subsys%shell_particles) + CALL particle_list_release(subsys%core_particles) + CALL distribution_1d_release(subsys%local_particles) + CALL mol_kind_new_list_release(subsys%molecule_kinds_new) + CALL mol_new_list_release(subsys%molecules_new) + CALL distribution_1d_release(subsys%local_molecules_new) + CALL cp_para_env_release(subsys%para_env) + CALL release_multipole_type(subsys%multipoles) + CALL colvar_p_release(subsys%colvar_p) + CALL deallocate_global_constraint(subsys%gci) + CALL atprop_release(subsys%atprop) + CALL virial_release(subsys%virial) + CALL cp_result_release(subsys%results) + CALL cell_release(subsys%cell) DEALLOCATE(subsys) END IF NULLIFY(subsys) @@ -209,17 +203,13 @@ END SUBROUTINE cp_subsys_release !> \param multipoles ... !> \param results ... !> \param cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> For the description of the other arguments see cp_subsys_type -!> attributes. !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_subsys_set(subsys, atomic_kinds, particles, local_particles,& molecules_new, molecule_kinds_new, local_molecules_new, para_env,& - colvar_p, shell_particles, core_particles, gci, multipoles, results, cell, error) + colvar_p, shell_particles, core_particles, gci, multipoles, results, cell) TYPE(cp_subsys_type), POINTER :: subsys TYPE(atomic_kind_list_type), OPTIONAL, & POINTER :: atomic_kinds @@ -245,7 +235,6 @@ SUBROUTINE cp_subsys_set(subsys, atomic_kinds, particles, local_particles,& TYPE(multipole_type), OPTIONAL, POINTER :: multipoles TYPE(cp_result_type), OPTIONAL, POINTER :: results TYPE(cell_type), OPTIONAL, POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_subsys_set', & routineP = moduleN//':'//routineN @@ -254,82 +243,82 @@ SUBROUTINE cp_subsys_set(subsys, atomic_kinds, particles, local_particles,& failure=.FALSE. - CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) - CPPrecondition(subsys%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,failure) + CPPrecondition(subsys%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(multipoles)) THEN - CALL retain_multipole_type(multipoles, error) - CALL release_multipole_type(subsys%multipoles, error) + CALL retain_multipole_type(multipoles) + CALL release_multipole_type(subsys%multipoles) subsys%multipoles => multipoles END IF IF (PRESENT(atomic_kinds)) THEN - CALL atomic_kind_list_retain(atomic_kinds,error=error) - CALL atomic_kind_list_release(subsys%atomic_kinds, error=error) + CALL atomic_kind_list_retain(atomic_kinds) + CALL atomic_kind_list_release(subsys%atomic_kinds) subsys%atomic_kinds => atomic_kinds END IF IF (PRESENT(particles)) THEN - CALL particle_list_retain(particles, error=error) - CALL particle_list_release(subsys%particles, error=error) + CALL particle_list_retain(particles) + CALL particle_list_release(subsys%particles) subsys%particles => particles END IF IF (PRESENT(local_particles)) THEN !CALL mp_abort() - CALL distribution_1d_retain(local_particles,error=error) - CALL distribution_1d_release(subsys%local_particles,error=error) + CALL distribution_1d_retain(local_particles) + CALL distribution_1d_release(subsys%local_particles) subsys%local_particles => local_particles END IF IF (PRESENT(local_molecules_new)) THEN - CALL distribution_1d_retain(local_molecules_new,error=error) - CALL distribution_1d_release(subsys%local_molecules_new,error=error) + CALL distribution_1d_retain(local_molecules_new) + CALL distribution_1d_release(subsys%local_molecules_new) subsys%local_molecules_new => local_molecules_new END IF IF (PRESENT(molecule_kinds_new)) THEN - CALL mol_kind_new_list_retain(molecule_kinds_new, error=error) - CALL mol_kind_new_list_release(subsys%molecule_kinds_new, error=error) + CALL mol_kind_new_list_retain(molecule_kinds_new) + CALL mol_kind_new_list_release(subsys%molecule_kinds_new) subsys%molecule_kinds_new => molecule_kinds_new END IF IF (PRESENT(molecules_new)) THEN - CALL mol_new_list_retain(molecules_new, error=error) - CALL mol_new_list_release(subsys%molecules_new, error=error) + CALL mol_new_list_retain(molecules_new) + CALL mol_new_list_release(subsys%molecules_new) subsys%molecules_new => molecules_new END IF IF (PRESENT(para_env)) THEN - CALL cp_para_env_retain(para_env, error=error) - CALL cp_para_env_release(subsys%para_env, error=error) + CALL cp_para_env_retain(para_env) + CALL cp_para_env_release(subsys%para_env) subsys%para_env => para_env END IF IF (PRESENT(colvar_p)) THEN - CPPrecondition(.NOT.ASSOCIATED(subsys%colvar_p),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(subsys%colvar_p),cp_failure_level,routineP,failure) subsys%colvar_p=>colvar_p ENDIF IF (PRESENT(shell_particles)) THEN IF(ASSOCIATED(shell_particles)) THEN - CALL particle_list_retain(shell_particles, error=error) - CALL particle_list_release(subsys%shell_particles, error=error) + CALL particle_list_retain(shell_particles) + CALL particle_list_release(subsys%shell_particles) subsys%shell_particles => shell_particles END IF END IF IF (PRESENT(core_particles)) THEN IF(ASSOCIATED(core_particles)) THEN - CALL particle_list_retain(core_particles, error=error) - CALL particle_list_release(subsys%core_particles, error=error) + CALL particle_list_retain(core_particles) + CALL particle_list_release(subsys%core_particles) subsys%core_particles => core_particles END IF END IF IF (PRESENT(gci)) THEN - CPPrecondition(.NOT.ASSOCIATED(subsys%gci),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(subsys%gci),cp_failure_level,routineP,failure) subsys%gci => gci ENDIF IF (PRESENT(results)) THEN IF(ASSOCIATED(results)) THEN - CALL cp_result_retain(results, error=error) - CALL cp_result_release(subsys%results, error=error) + CALL cp_result_retain(results) + CALL cp_result_release(subsys%results) subsys%results => results END IF END IF IF (PRESENT(cell)) THEN IF(ASSOCIATED(cell)) THEN - CALL cell_retain(cell, error=error) - CALL cell_release(subsys%cell, error=error) + CALL cell_retain(cell) + CALL cell_release(subsys%cell) subsys%cell => cell END IF END IF @@ -364,10 +353,6 @@ END SUBROUTINE cp_subsys_set !> \param virial ... !> \param results ... !> \param cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> For the description of the other arguments see cp_subsys_type -!> attributes. !> \par History !> 08.2003 created [fawzi] !> 22.11.2010 (MK) @@ -379,7 +364,7 @@ SUBROUTINE cp_subsys_get(subsys, ref_count, atomic_kinds, atomic_kind_set, & molecule_kind_set, local_molecules_new, para_env, colvar_p,& shell_particles, core_particles, gci, multipoles,& natom, nparticle, ncore, nshell, nkind, atprop, virial, & - results, cell, error) + results, cell) TYPE(cp_subsys_type), POINTER :: subsys INTEGER, INTENT(out), OPTIONAL :: ref_count TYPE(atomic_kind_list_type), OPTIONAL, & @@ -418,7 +403,6 @@ SUBROUTINE cp_subsys_get(subsys, ref_count, atomic_kinds, atomic_kind_set, & TYPE(virial_type), OPTIONAL, POINTER :: virial TYPE(cp_result_type), OPTIONAL, POINTER :: results TYPE(cell_type), OPTIONAL, POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_subsys_get', & routineP = moduleN//':'//routineN @@ -431,8 +415,8 @@ SUBROUTINE cp_subsys_get(subsys, ref_count, atomic_kinds, atomic_kind_set, & n_core = 0 n_shell = 0 - CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) - CPPrecondition(subsys%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,failure) + CPPrecondition(subsys%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(ref_count)) ref_count = subsys%ref_count IF (PRESENT(atomic_kinds)) atomic_kinds => subsys%atomic_kinds @@ -459,18 +443,18 @@ SUBROUTINE cp_subsys_get(subsys, ref_count, atomic_kinds, atomic_kind_set, & IF (PRESENT(natom).OR.PRESENT(nparticle).OR.PRESENT(nshell)) THEN ! An atomic particle set should be present in each subsystem at the moment - CPPrecondition(ASSOCIATED(subsys%particles),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(subsys%particles),cp_failure_level,routineP,failure) n_atom = subsys%particles%n_els ! Check if we have other kinds of particles in this subsystem IF (ASSOCIATED(subsys%shell_particles)) THEN n_shell = subsys%shell_particles%n_els - CPPrecondition(ASSOCIATED(subsys%core_particles),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(subsys%core_particles),cp_failure_level,routineP,failure) n_core = subsys%core_particles%n_els ! The same number of shell and core particles is assumed - CPPrecondition((n_core == n_shell),cp_failure_level,routineP,error,failure) + CPPrecondition((n_core == n_shell),cp_failure_level,routineP,failure) ELSE IF (ASSOCIATED(subsys%core_particles)) THEN ! This case should not occur at the moment - CPPrecondition(ASSOCIATED(subsys%shell_particles),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(subsys%shell_particles),cp_failure_level,routineP,failure) ELSE n_core = 0 n_shell = 0 @@ -492,20 +476,18 @@ END SUBROUTINE cp_subsys_get !> \param v ... !> \param fscale ... !> \param cell ... -!> \param error ... !> \date 19.11.10 !> \author Matthias Krack (MK) !> \version 1.0 !> \note It is assumed that f, r, s, or v are properly allocated already ! ***************************************************************************** - SUBROUTINE pack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) + SUBROUTINE pack_subsys_particles(subsys,f,r,s,v,fscale,cell) TYPE(cp_subsys_type), POINTER :: subsys REAL(KIND=dp), DIMENSION(:), & INTENT(OUT), OPTIONAL :: f, r, s, v REAL(KIND=dp), INTENT(IN), OPTIONAL :: fscale TYPE(cell_type), OPTIONAL, POINTER :: cell - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pack_subsys_particles', & routineP = moduleN//':'//routineN @@ -518,10 +500,10 @@ SUBROUTINE pack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) shell_particles failure = .FALSE. - CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,failure) IF (PRESENT(s)) THEN - CPPrecondition(PRESENT(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(cell),cp_failure_level,routineP,failure) END IF NULLIFY (core_particles) @@ -533,15 +515,14 @@ SUBROUTINE pack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) natom=natom,& nparticle=nparticle,& particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) nsize = 3*nparticle ! Pack forces IF (PRESENT(f)) THEN - CPPrecondition((SIZE(f) >= nsize),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(f) >= nsize),cp_failure_level,routineP,failure) j = 0 DO iatom=1,natom shell_index = particles%els(iatom)%shell_index @@ -567,7 +548,7 @@ SUBROUTINE pack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) ! Pack coordinates IF (PRESENT(r)) THEN - CPPrecondition((SIZE(r) >= nsize),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(r) >= nsize),cp_failure_level,routineP,failure) j = 0 DO iatom=1,natom shell_index = particles%els(iatom)%shell_index @@ -592,8 +573,8 @@ SUBROUTINE pack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) ! Pack as scaled coordinates IF (PRESENT(s)) THEN - CPPrecondition((SIZE(s) >= nsize),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(cell),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(s) >= nsize),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(cell),cp_failure_level,routineP,failure) j = 0 DO iatom=1,natom shell_index = particles%els(iatom)%shell_index @@ -621,7 +602,7 @@ SUBROUTINE pack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) ! Pack velocities IF (PRESENT(v)) THEN - CPPrecondition((SIZE(v) >= nsize),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(v) >= nsize),cp_failure_level,routineP,failure) j = 0 DO iatom=1,natom shell_index = particles%els(iatom)%shell_index @@ -654,19 +635,17 @@ END SUBROUTINE pack_subsys_particles !> \param v ... !> \param fscale ... !> \param cell ... -!> \param error ... !> \date 19.11.10 !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE unpack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) + SUBROUTINE unpack_subsys_particles(subsys,f,r,s,v,fscale,cell) TYPE(cp_subsys_type), POINTER :: subsys REAL(KIND=dp), DIMENSION(:), & INTENT(IN), OPTIONAL :: f, r, s, v REAL(KIND=dp), INTENT(IN), OPTIONAL :: fscale TYPE(cell_type), OPTIONAL, POINTER :: cell - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'unpack_subsys_particles', & routineP = moduleN//':'//routineN @@ -680,7 +659,7 @@ SUBROUTINE unpack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) shell_particles failure = .FALSE. - CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(subsys),cp_failure_level,routineP,failure) NULLIFY (core_particles) NULLIFY (particles) @@ -691,15 +670,14 @@ SUBROUTINE unpack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) natom=natom,& nparticle=nparticle,& particles=particles,& - shell_particles=shell_particles,& - error=error) + shell_particles=shell_particles) nsize = 3*nparticle ! Unpack forces IF (PRESENT(f)) THEN - CPPrecondition((SIZE(f) >= nsize),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(f) >= nsize),cp_failure_level,routineP,failure) IF (PRESENT(fscale)) THEN my_fscale = fscale ELSE @@ -729,7 +707,7 @@ SUBROUTINE unpack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) ! Unpack coordinates IF (PRESENT(r)) THEN - CPPrecondition((SIZE(r) >= nsize),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(r) >= nsize),cp_failure_level,routineP,failure) j = 0 DO iatom=1,natom shell_index = particles%els(iatom)%shell_index @@ -760,8 +738,8 @@ SUBROUTINE unpack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) ! Unpack scaled coordinates IF (PRESENT(s)) THEN - CPPrecondition((SIZE(s) >= nsize),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(cell),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(s) >= nsize),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(cell),cp_failure_level,routineP,failure) j = 0 DO iatom=1,natom shell_index = particles%els(iatom)%shell_index @@ -795,7 +773,7 @@ SUBROUTINE unpack_subsys_particles(subsys,f,r,s,v,fscale,cell,error) ! Unpack velocities IF (PRESENT(v)) THEN - CPPrecondition((SIZE(v) >= nsize),cp_failure_level,routineP,error,failure) + CPPrecondition((SIZE(v) >= nsize),cp_failure_level,routineP,failure) j = 0 DO iatom=1,natom shell_index = particles%els(iatom)%shell_index diff --git a/src/subsys/damping_dipole_types.F b/src/subsys/damping_dipole_types.F index 01df3e265a..32621ff0f7 100644 --- a/src/subsys/damping_dipole_types.F +++ b/src/subsys/damping_dipole_types.F @@ -60,13 +60,11 @@ MODULE damping_dipole_types !> \brief Creates Data-structure that contains damping information !> \param damping ... !> \param nkinds ... -!> \param error ... !> \author Rodolphe Vuilleumier ! ***************************************************************************** - SUBROUTINE damping_p_create(damping,nkinds,error) + SUBROUTINE damping_p_create(damping,nkinds) TYPE(damping_p_type), POINTER :: damping INTEGER, INTENT(IN) :: nkinds - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'damping_p_create', & routineP = moduleN//':'//routineN @@ -75,11 +73,11 @@ SUBROUTINE damping_p_create(damping,nkinds,error) LOGICAL :: failure failure=.FALSE. - CPPostcondition(.NOT.ASSOCIATED(damping),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(damping),cp_failure_level,routineP,failure) ALLOCATE ( damping, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( damping%damp( nkinds ), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nkinds CALL init_damping ( damping%damp(i) ) END DO @@ -89,12 +87,10 @@ END SUBROUTINE damping_p_create ! ***************************************************************************** !> \brief Release Data-structure that contains damping information !> \param damping ... -!> \param error ... !> \author Rodolphe Vuilleumier [RV] ! ***************************************************************************** - SUBROUTINE damping_p_release(damping,error) + SUBROUTINE damping_p_release(damping) TYPE(damping_p_type), POINTER :: damping - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'damping_p_release', & routineP = moduleN//':'//routineN @@ -106,10 +102,10 @@ SUBROUTINE damping_p_release(damping,error) IF(ASSOCIATED(damping)) THEN IF (ASSOCIATED(damping%damp)) THEN DEALLOCATE(damping%damp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(damping,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(damping) diff --git a/src/subsys/external_potential_types.F b/src/subsys/external_potential_types.F index 3fd0aa5453..2e80c9cbc6 100644 --- a/src/subsys/external_potential_types.F +++ b/src/subsys/external_potential_types.F @@ -245,14 +245,12 @@ MODULE external_potential_types ! ***************************************************************************** !> \brief Allocate an atomic all-electron potential data set. !> \param potential ... -!> \param error ... !> \date 25.07.2000, !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_all_potential(potential,error) + SUBROUTINE allocate_all_potential(potential) TYPE(all_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_all_potential', & routineP = moduleN//':'//routineN @@ -261,10 +259,10 @@ SUBROUTINE allocate_all_potential(potential,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(potential)) CALL deallocate_potential(potential,error) + IF (ASSOCIATED(potential)) CALL deallocate_potential(potential) ALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (potential%elec_conf) @@ -276,13 +274,11 @@ END SUBROUTINE allocate_all_potential ! ***************************************************************************** !> \brief Allocate an effective charge and inducible dipole potential data set. !> \param potential ... -!> \param error ... !> \date 05.03.2010 !> \author Toon.Verstraelen@gmail.com ! ***************************************************************************** - SUBROUTINE allocate_fist_potential(potential,error) + SUBROUTINE allocate_fist_potential(potential) TYPE(fist_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_fist_potential', & routineP = moduleN//':'//routineN @@ -291,10 +287,10 @@ SUBROUTINE allocate_fist_potential(potential,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(potential)) CALL deallocate_potential(potential,error) + IF (ASSOCIATED(potential)) CALL deallocate_potential(potential) ALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) potential%apol = 0.0_dp potential%cpol = 0.0_dp @@ -310,14 +306,12 @@ END SUBROUTINE allocate_fist_potential ! ***************************************************************************** !> \brief Allocate an atomic local potential data set. !> \param potential ... -!> \param error ... !> \date 24.01.2014 !> \author JGH !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_local_potential(potential,error) + SUBROUTINE allocate_local_potential(potential) TYPE(local_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_local_potential', & routineP = moduleN//':'//routineN @@ -326,10 +320,10 @@ SUBROUTINE allocate_local_potential(potential,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(potential)) CALL deallocate_potential(potential,error) + IF (ASSOCIATED(potential)) CALL deallocate_potential(potential) ALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (potential%alpha) NULLIFY (potential%cval) @@ -344,14 +338,12 @@ END SUBROUTINE allocate_local_potential ! ***************************************************************************** !> \brief Allocate an atomic GTH potential data set. !> \param potential ... -!> \param error ... !> \date 25.07.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_gth_potential(potential,error) + SUBROUTINE allocate_gth_potential(potential) TYPE(gth_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_gth_potential', & routineP = moduleN//':'//routineN @@ -360,10 +352,10 @@ SUBROUTINE allocate_gth_potential(potential,error) LOGICAL :: failure failure = .FALSE. - IF (ASSOCIATED(potential)) CALL deallocate_potential(potential,error) + IF (ASSOCIATED(potential)) CALL deallocate_potential(potential) ALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) NULLIFY (potential%alpha_ppnl) NULLIFY (potential%cexp_ppl) @@ -394,14 +386,12 @@ END SUBROUTINE allocate_gth_potential ! ***************************************************************************** !> \brief Deallocate an atomic all-electron potential data set. !> \param potential ... -!> \param error ... !> \date 03.11.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_all_potential(potential,error) + SUBROUTINE deallocate_all_potential(potential) TYPE(all_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_all_potential', & routineP = moduleN//':'//routineN @@ -412,9 +402,9 @@ SUBROUTINE deallocate_all_potential(potential,error) failure = .FALSE. IF (ASSOCIATED(potential)) THEN DEALLOCATE (potential%elec_conf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer potential is not associated.") @@ -425,13 +415,11 @@ END SUBROUTINE deallocate_all_potential ! ***************************************************************************** !> \brief Deallocate an effective charge and inducible dipole potential data set. !> \param potential ... -!> \param error ... !> \date 05.03.2010 !> \author Toon.Verstraelen@gmail.com ! ***************************************************************************** - SUBROUTINE deallocate_fist_potential(potential,error) + SUBROUTINE deallocate_fist_potential(potential) TYPE(fist_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_fist_potential', & routineP = moduleN//':'//routineN @@ -443,7 +431,7 @@ SUBROUTINE deallocate_fist_potential(potential,error) IF (ASSOCIATED(potential)) THEN ! Nothing exciting here yet. DEALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer potential is not associated.") @@ -454,14 +442,12 @@ END SUBROUTINE deallocate_fist_potential ! ***************************************************************************** !> \brief Deallocate an atomic local potential data set. !> \param potential ... -!> \param error ... !> \date 24.01.2014 !> \author JGH !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_local_potential(potential,error) + SUBROUTINE deallocate_local_potential(potential) TYPE(local_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_local_potential', & routineP = moduleN//':'//routineN @@ -475,15 +461,15 @@ SUBROUTINE deallocate_local_potential(potential,error) IF (ASSOCIATED(potential%alpha)) THEN DEALLOCATE (potential%alpha,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(potential%cval)) THEN DEALLOCATE (potential%cval,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE @@ -497,14 +483,12 @@ END SUBROUTINE deallocate_local_potential ! ***************************************************************************** !> \brief Deallocate an atomic GTH potential data set. !> \param potential ... -!> \param error ... !> \date 03.11.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_gth_potential(potential,error) + SUBROUTINE deallocate_gth_potential(potential) TYPE(gth_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_gth_potential', & routineP = moduleN//':'//routineN @@ -517,59 +501,59 @@ SUBROUTINE deallocate_gth_potential(potential,error) IF (ASSOCIATED(potential)) THEN DEALLOCATE (potential%elec_conf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! *** Deallocate the parameters of the local part *** IF (ASSOCIATED(potential%cexp_ppl)) THEN DEALLOCATE (potential%cexp_ppl,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF ! *** Deallocate the parameters of the non-local part *** IF (ASSOCIATED(potential%alpha_ppnl)) THEN DEALLOCATE (potential%alpha_ppnl,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%cprj,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%cprj_ppnl,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%hprj_ppnl,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%nprj_ppnl,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%vprj_ppnl,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(potential%alpha_lpot)) THEN DEALLOCATE (potential%alpha_lpot,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%nct_lpot,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%cval_lpot,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(potential%alpha_lsd)) THEN DEALLOCATE (potential%alpha_lsd,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%nct_lsd,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%cval_lsd,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(potential%alpha_nlcc)) THEN DEALLOCATE (potential%alpha_nlcc,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%nct_nlcc,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (potential%cval_nlcc,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE (potential,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& @@ -886,14 +870,12 @@ END SUBROUTINE get_gth_potential !> for Cartesian overlap integrals between the orbital basis !> functions and the projector functions. !> \param potential ... -!> \param error ... !> \date 16.10.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE init_cprj_ppnl(potential,error) + SUBROUTINE init_cprj_ppnl(potential) TYPE(gth_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_cprj_ppnl', & routineP = moduleN//':'//routineN @@ -939,14 +921,12 @@ END SUBROUTINE init_cprj_ppnl ! ***************************************************************************** !> \brief Initialise a GTH potential data set structure. !> \param potential ... -!> \param error ... !> \date 27.10.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE init_gth_potential(potential,error) + SUBROUTINE init_gth_potential(potential) TYPE(gth_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_gth_potential', & routineP = moduleN//':'//routineN @@ -963,12 +943,12 @@ SUBROUTINE init_gth_potential(potential,error) ! *** non-local part of the GTH pseudopotential and *** ! *** the transformation matrices "pgf" -> "prj_ppnl" *** - CALL init_cprj_ppnl(potential,error) + CALL init_cprj_ppnl(potential) ! *** Initialise the h(i,j) projector coefficients of *** ! *** the non-local part of the GTH pseudopotential *** - CALL init_vprj_ppnl(potential,error) + CALL init_vprj_ppnl(potential) END IF @@ -980,14 +960,12 @@ END SUBROUTINE init_gth_potential !> \brief Initialise the h(i,j) projector coefficients of the non-local part !> of the GTH pseudopotential. !> \param potential ... -!> \param error ... !> \date 24.10.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE init_vprj_ppnl(potential,error) + SUBROUTINE init_vprj_ppnl(potential) TYPE(gth_potential_type), POINTER :: potential - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_vprj_ppnl', & routineP = moduleN//':'//routineN @@ -1029,14 +1007,12 @@ END SUBROUTINE init_vprj_ppnl !> \param itype ... !> \param zeff ... !> \param zeff_correction ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE init_all_potential(potential,itype,zeff,zeff_correction,error) + SUBROUTINE init_all_potential(potential,itype,zeff,zeff_correction) TYPE(all_potential_type), POINTER :: potential CHARACTER(LEN=*), OPTIONAL :: itype REAL(KIND=dp), OPTIONAL :: zeff, zeff_correction - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'init_all_potential', & routineP = moduleN//':'//routineN @@ -1135,20 +1111,18 @@ END SUBROUTINE init_all_potential !> \param para_env ... !> \param dft_section ... !> \param potential_section ... -!> \param error ... !> \date 14.05.2000 !> \author MK !> \version 1.0 ! ***************************************************************************** SUBROUTINE read_all_potential(element_symbol,potential_name,potential,zeff_correction,& - para_env, dft_section, potential_section, error) + para_env, dft_section, potential_section) CHARACTER(LEN=*), INTENT(IN) :: element_symbol, potential_name TYPE(all_potential_type), POINTER :: potential REAL(KIND=dp) :: zeff_correction TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: dft_section, potential_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_all_potential', & routineP = moduleN//':'//routineN @@ -1180,11 +1154,10 @@ SUBROUTINE read_all_potential(element_symbol,potential_name,potential,zeff_corre potential%name = potential_name read_from_input = .FALSE. - CALL section_vals_get(potential_section,explicit=read_from_input, error=error) + CALL section_vals_get(potential_section,explicit=read_from_input) IF (.NOT.read_from_input) THEN - CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",c_val=potential_file_name,& - error=error) - CALL parser_create(parser,potential_file_name,para_env=para_env,error=error) + CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",c_val=potential_file_name) + CALL parser_create(parser,potential_file_name,para_env=para_env) END IF ! *** Search for the requested potential in the potential file *** @@ -1197,9 +1170,9 @@ SUBROUTINE read_all_potential(element_symbol,potential_name,potential,zeff_corre IF (read_from_input) THEN NULLIFY(list, val) found = .TRUE. - CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list) ELSE - CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line,error=error) + CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line) END IF IF (found) THEN CALL uppercase(symbol) @@ -1226,10 +1199,10 @@ SUBROUTINE read_all_potential(element_symbol,potential_name,potential,zeff_corre l = 0 CALL reallocate(elec_conf,0,l) IF (read_from_input) THEN - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN, __LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)elec_conf(l) CALL remove_word(line_att) DO WHILE (LEN_TRIM(line_att) /= 0) @@ -1239,16 +1212,16 @@ SUBROUTINE read_all_potential(element_symbol,potential_name,potential,zeff_corre CALL remove_word(line_att) END DO ELSE - CALL parser_get_object(parser,elec_conf(l),newline=.TRUE.,error=error) - DO WHILE (parser_test_next_token(parser,error=error) == "INT") + CALL parser_get_object(parser,elec_conf(l),newline=.TRUE.) + DO WHILE (parser_test_next_token(parser) == "INT") l = l + 1 CALL reallocate(elec_conf,0,l) - CALL parser_get_object(parser,elec_conf(l),error=error) + CALL parser_get_object(parser,elec_conf(l)) END DO irep = irep + 1 WRITE(line_att,'(100(1X,I0))')elec_conf CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF CALL reallocate(potential%elec_conf,0,l) @@ -1258,23 +1231,23 @@ SUBROUTINE read_all_potential(element_symbol,potential_name,potential,zeff_corre potential%zeff = REAL(SUM(elec_conf),dp)+zeff_correction DEALLOCATE (elec_conf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Read r(loc) to define the exponent of the core charge ! distribution and calculate the corresponding coefficient IF (read_from_input) THEN - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)r ELSE - CALL parser_get_object(parser,r,newline=.TRUE.,error=error) + CALL parser_get_object(parser,r,newline=.TRUE.) irep = irep + 1 WRITE(line_att,'(E24.16)')r CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF alpha = 1.0_dp/(2.0_dp*r**2) @@ -1301,13 +1274,13 @@ SUBROUTINE read_all_potential(element_symbol,potential_name,potential,zeff_corre irep = irep + 1 WRITE(line_att,'(A)')" # Potential name: "//apname2(:strlen2)//" for symbol: "//symbol2(:strlen1) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) irep = irep + 1 WRITE(line_att,'(A)')" # Potential read from the potential filename: "//TRIM(potential_file_name) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF END SUBROUTINE read_all_potential @@ -1319,19 +1292,17 @@ END SUBROUTINE read_all_potential !> \param para_env ... !> \param dft_section ... !> \param potential_section ... -!> \param error ... !> \date 24.12.2014 !> \author JGH !> \version 1.0 ! ***************************************************************************** SUBROUTINE read_local_potential(element_symbol,potential_name,potential,& - para_env, dft_section, potential_section, error) + para_env, dft_section, potential_section) CHARACTER(LEN=*), INTENT(IN) :: element_symbol, potential_name TYPE(local_potential_type), POINTER :: potential TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: dft_section, potential_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_local_potential', & routineP = moduleN//':'//routineN @@ -1363,11 +1334,10 @@ SUBROUTINE read_local_potential(element_symbol,potential_name,potential,& potential%name = potential_name read_from_input = .FALSE. - CALL section_vals_get(potential_section,explicit=read_from_input, error=error) + CALL section_vals_get(potential_section,explicit=read_from_input) IF (.NOT.read_from_input) THEN - CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",c_val=potential_file_name,& - error=error) - CALL parser_create(parser,potential_file_name,para_env=para_env,error=error) + CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",c_val=potential_file_name) + CALL parser_create(parser,potential_file_name,para_env=para_env) END IF ! *** Search for the requested potential in the potential file *** @@ -1380,9 +1350,9 @@ SUBROUTINE read_local_potential(element_symbol,potential_name,potential,& IF (read_from_input) THEN NULLIFY(list, val) found = .TRUE. - CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list) ELSE - CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line,error=error) + CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line) END IF IF (found) THEN CALL uppercase(symbol) @@ -1407,39 +1377,39 @@ SUBROUTINE read_local_potential(element_symbol,potential_name,potential,& ! Read ngau and npol IF (read_from_input) THEN - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*) ngau, npol CALL remove_word(line_att) ELSE - CALL parser_get_object(parser,ngau,newline=.TRUE.,error=error) - CALL parser_get_object(parser,npol,error=error) + CALL parser_get_object(parser,ngau,newline=.TRUE.) + CALL parser_get_object(parser,npol) irep = irep + 1 WRITE(line_att,'(2(1X,I0))') ngau, npol CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF CALL reallocate(alpha,1,ngau) CALL reallocate(cval,1,ngau,1,npol) DO igau=1,ngau IF (read_from_input) THEN - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*) alpha(igau),(cval(igau,ipol),ipol=1,npol) ELSE - CALL parser_get_object(parser,alpha(igau),newline=.TRUE.,error=error) + CALL parser_get_object(parser,alpha(igau),newline=.TRUE.) DO ipol=1,npol - CALL parser_get_object(parser,cval(igau,ipol),newline=.FALSE.,error=error) + CALL parser_get_object(parser,cval(igau,ipol),newline=.FALSE.) END DO irep = irep + 1 WRITE(line_att,'(8(E24.16))') alpha(igau),(cval(igau,ipol),ipol=1,npol) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF END DO alpha = 1.0_dp/(2.0_dp*alpha**2) @@ -1479,13 +1449,13 @@ SUBROUTINE read_local_potential(element_symbol,potential_name,potential,& irep = irep + 1 WRITE(line_att,'(A)')" # Potential name: "//apname2(:strlen2)//" for symbol: "//symbol2(:strlen1) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) irep = irep + 1 WRITE(line_att,'(A)')" # Potential read from the potential filename: "//TRIM(potential_file_name) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF END SUBROUTINE read_local_potential @@ -1499,7 +1469,6 @@ END SUBROUTINE read_local_potential !> \param para_env ... !> \param dft_section ... !> \param potential_section ... -!> \param error ... !> \date 14.05.2000 !> \par Literature !> - S. Goedecker, M. Teter and J. Hutter, @@ -1510,14 +1479,13 @@ END SUBROUTINE read_local_potential !> \version 1.0 ! ***************************************************************************** SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_correction,& - para_env, dft_section, potential_section, error) + para_env, dft_section, potential_section) CHARACTER(LEN=*), INTENT(IN) :: element_symbol, potential_name TYPE(gth_potential_type), POINTER :: potential REAL(KIND=dp), INTENT(IN) :: zeff_correction TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: dft_section, potential_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_gth_potential', & routineP = moduleN//':'//routineN @@ -1554,11 +1522,10 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre potential%name = potential_name read_from_input = .FALSE. - CALL section_vals_get(potential_section,explicit=read_from_input, error=error) + CALL section_vals_get(potential_section,explicit=read_from_input) IF (.NOT.read_from_input) THEN - CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",c_val=potential_file_name,& - error=error) - CALL parser_create(parser,potential_file_name,para_env=para_env,error=error) + CALL section_vals_val_get(dft_section,"POTENTIAL_FILE_NAME",c_val=potential_file_name) + CALL parser_create(parser,potential_file_name,para_env=para_env) END IF !initialize extended form @@ -1579,9 +1546,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre IF (read_from_input) THEN NULLIFY(list, val) found = .TRUE. - CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list,error=error) + CALL section_vals_list_get(potential_section,"_DEFAULT_KEYWORD_",list=list) ELSE - CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line,error=error) + CALL parser_search_string(parser,TRIM(apname),.TRUE.,found,line) END IF IF (found) THEN CALL uppercase(symbol) @@ -1607,10 +1574,10 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre l = 0 CALL reallocate(elec_conf,0,l) IF (read_from_input) THEN - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)elec_conf(l) CALL remove_word(line_att) DO WHILE (LEN_TRIM(line_att) /= 0) @@ -1620,16 +1587,16 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre CALL remove_word(line_att) END DO ELSE - CALL parser_get_object(parser,elec_conf(l),newline=.TRUE.,error=error) - DO WHILE (parser_test_next_token(parser,error=error) == "INT") + CALL parser_get_object(parser,elec_conf(l),newline=.TRUE.) + DO WHILE (parser_test_next_token(parser) == "INT") l = l + 1 CALL reallocate(elec_conf,0,l) - CALL parser_get_object(parser,elec_conf(l),error=error) + CALL parser_get_object(parser,elec_conf(l)) END DO irep = irep + 1 WRITE(line_att,'(100(1X,I0))')elec_conf CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF CALL reallocate(potential%elec_conf,0,l) @@ -1639,21 +1606,21 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre potential%zeff = REAL(SUM(elec_conf),dp)+zeff_correction DEALLOCATE (elec_conf,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! *** Read r(loc) to define the exponent of the core charge *** ! *** distribution and calculate the corresponding coefficient *** IF (read_from_input) THEN - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)r CALL remove_word(line_att) ELSE line_att = "" - CALL parser_get_object(parser,r,newline=.TRUE.,error=error) + CALL parser_get_object(parser,r,newline=.TRUE.) istr=LEN_TRIM(line_att)+1 WRITE(line_att(istr:),'(E24.16)')r END IF @@ -1672,7 +1639,7 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre READ(line_att,*)n CALL remove_word(line_att) ELSE - CALL parser_get_object(parser,n,error=error) + CALL parser_get_object(parser,n) istr=LEN_TRIM(line_att)+1 WRITE(line_att(istr:),'(1X,I0)')n END IF @@ -1684,7 +1651,7 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre READ(line_att,*) ci CALL remove_word(line_att) ELSE - CALL parser_get_object(parser,ci,error=error) + CALL parser_get_object(parser,ci) istr=LEN_TRIM(line_att)+1 WRITE(line_att(istr:),'(E24.16)') ci END IF @@ -1695,7 +1662,7 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre IF (.NOT.read_from_input) THEN irep = irep + 1 CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) line_att = "" ELSE IF (LEN_TRIM(line_att)/= 0) THEN @@ -1711,9 +1678,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre ! local potential, NLCC, LSD potential IF (read_from_input) THEN DO - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) IF(INDEX(line_att,"LPOT") /= 0) THEN potential%lpotextended = .TRUE. CALL remove_word(line_att) @@ -1726,9 +1693,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre CALL reallocate(potential%nct_lpot,1,n) CALL reallocate(potential%cval_lpot,1,4,1,n) DO ipot=1,potential%nexp_lpot - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) r potential%alpha_lpot(ipot) = 0.5_dp/(r*r) CALL remove_word(line_att) @@ -1751,9 +1718,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre CALL reallocate(potential%nct_nlcc,1,n) CALL reallocate(potential%cval_nlcc,1,4,1,n) DO ipot=1,potential%nexp_nlcc - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) potential%alpha_nlcc(ipot) CALL remove_word(line_att) READ(line_att,*) potential%nct_nlcc(ipot) @@ -1775,9 +1742,9 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre CALL reallocate(potential%nct_lsd,1,n) CALL reallocate(potential%cval_lsd,1,4,1,n) DO ipot=1,potential%nexp_lsd - is_ok=cp_sll_val_next(list,val,error=error) - CPPostcondition(is_ok, cp_failure_level, routineP, error, failure) - CALL val_get(val,c_val=line_att,error=error) + is_ok=cp_sll_val_next(list,val) + CPPostcondition(is_ok, cp_failure_level, routineP,failure) + CALL val_get(val,c_val=line_att) READ(line_att,*) r potential%alpha_lsd(ipot) = 0.5_dp/(r*r) CALL remove_word(line_att) @@ -1796,15 +1763,15 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre END DO ELSE DO - CALL parser_get_next_line(parser,1,error=error) - IF(parser_test_next_token(parser,error=error) == "INT") THEN + CALL parser_get_next_line(parser,1) + IF(parser_test_next_token(parser) == "INT") THEN EXIT - ELSEIF(parser_test_next_token(parser,error=error) == "STR") THEN - CALL parser_get_object(parser,line,error=error) + ELSEIF(parser_test_next_token(parser) == "STR") THEN + CALL parser_get_object(parser,line) IF(INDEX(LINE,"LPOT") /= 0) THEN ! local potential potential%lpotextended = .TRUE. - CALL parser_get_object(parser,potential%nexp_lpot,error=error) + CALL parser_get_object(parser,potential%nexp_lpot) n = potential%nexp_lpot NULLIFY(potential%alpha_lpot,potential%nct_lpot,potential%cval_lpot) CALL reallocate(potential%alpha_lpot,1,n) @@ -1814,14 +1781,14 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre WRITE(line_att,'(A,1X,I0)') "LPOT",n irep = irep + 1 CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) DO ipot=1,potential%nexp_lpot - CALL parser_get_object(parser,r,newline=.TRUE.,error=error) + CALL parser_get_object(parser,r,newline=.TRUE.) potential%alpha_lpot(ipot) = 0.5_dp/(r*r) - CALL parser_get_object(parser,potential%nct_lpot(ipot),error=error) + CALL parser_get_object(parser,potential%nct_lpot(ipot)) CALL reallocate(tmp_vals,1,potential%nct_lpot(ipot)) DO ic=1,potential%nct_lpot(ipot) - CALL parser_get_object(parser,ci,error=error) + CALL parser_get_object(parser,ci) tmp_vals(ic)=ci rc2 = (2._dp*potential%alpha_lpot(ipot))**(ic-1) potential%cval_lpot(ic,ipot) = ci*rc2 @@ -1831,12 +1798,12 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre WRITE(line_att,'(E24.16,1X,I0,100(1X,E24.16))') r,potential%nct_lpot(ipot), & tmp_vals(1:potential%nct_lpot(ipot)) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END DO ELSEIF(INDEX(LINE,"NLCC") /= 0) THEN ! NLCC potential%nlcc = .TRUE. - CALL parser_get_object(parser,potential%nexp_nlcc,error=error) + CALL parser_get_object(parser,potential%nexp_nlcc) n = potential%nexp_nlcc NULLIFY(potential%alpha_nlcc,potential%nct_nlcc,potential%cval_nlcc) CALL reallocate(potential%alpha_nlcc,1,n) @@ -1846,13 +1813,13 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre WRITE(line_att,'(A,1X,I0)') "NLCC",n irep = irep + 1 CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) DO ipot=1,potential%nexp_nlcc - CALL parser_get_object(parser,potential%alpha_nlcc(ipot),newline=.TRUE.,error=error) - CALL parser_get_object(parser,potential%nct_nlcc(ipot),error=error) + CALL parser_get_object(parser,potential%alpha_nlcc(ipot),newline=.TRUE.) + CALL parser_get_object(parser,potential%nct_nlcc(ipot)) CALL reallocate(tmp_vals,1,potential%nct_nlcc(ipot)) DO ic=1,potential%nct_nlcc(ipot) - CALL parser_get_object(parser,potential%cval_nlcc(ic,ipot),error=error) + CALL parser_get_object(parser,potential%cval_nlcc(ic,ipot)) tmp_vals(ic)=potential%cval_nlcc(ic,ipot) !make it compatible with bigdft style potential%cval_nlcc(ic,ipot)=potential%cval_nlcc(ic,ipot)/(4.0_dp*pi) @@ -1862,12 +1829,12 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre WRITE(line_att,'(E24.16,1X,I0,100(1X,E24.16))') potential%alpha_nlcc(ipot), potential%nct_nlcc(ipot), & tmp_vals(1:potential%nct_nlcc(ipot)) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END DO ELSEIF(INDEX(LINE,"LSD") /= 0) THEN ! LSD potential potential%lsdpot = .TRUE. - CALL parser_get_object(parser,potential%nexp_lsd,error=error) + CALL parser_get_object(parser,potential%nexp_lsd) n = potential%nexp_lsd NULLIFY(potential%alpha_lsd,potential%nct_lsd,potential%cval_lsd) CALL reallocate(potential%alpha_lsd,1,n) @@ -1877,14 +1844,14 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre WRITE(line_att,'(A,1X,I0)') "LSD",n irep = irep + 1 CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) DO ipot=1,potential%nexp_lsd - CALL parser_get_object(parser,r,newline=.TRUE.,error=error) + CALL parser_get_object(parser,r,newline=.TRUE.) potential%alpha_lsd(ipot) = 0.5_dp/(r*r) - CALL parser_get_object(parser,potential%nct_lsd(ipot),error=error) + CALL parser_get_object(parser,potential%nct_lsd(ipot)) CALL reallocate(tmp_vals,1,potential%nct_lsd(ipot)) DO ic=1,potential%nct_lsd(ipot) - CALL parser_get_object(parser,ci,error=error) + CALL parser_get_object(parser,ci) tmp_vals(ic)=ci rc2 = (2._dp*potential%alpha_lsd(ipot))**(ic-1) potential%cval_lsd(ic,ipot) = ci*rc2 @@ -1894,13 +1861,13 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre WRITE(line_att,'(E24.16,1X,I0,100(1X,E24.16))') r,potential%nct_lsd(ipot), & tmp_vals(1:potential%nct_lsd(ipot)) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END DO ELSE - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END IF ELSE - CPPostcondition(.FALSE., cp_failure_level, routineP, error, failure) + CPPostcondition(.FALSE., cp_failure_level, routineP,failure) END IF END DO END IF @@ -1910,11 +1877,11 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre READ(line_att,*)n CALL remove_word(line_att) ELSE - CALL parser_get_object(parser,n,error=error) + CALL parser_get_object(parser,n) irep = irep + 1 WRITE(line_att,'(1X,I0)')n CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF potential%lppnl = n - 1 potential%nppnl = 0 @@ -1941,18 +1908,18 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre DO l=0,lppnl IF (read_from_input) THEN - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)r CALL remove_word(line_att) READ(line_att,*)nprj_ppnl CALL remove_word(line_att) ELSE line_att ="" - CALL parser_get_object(parser,r,newline=.TRUE.,error=error) - CALL parser_get_object(parser,nprj_ppnl,error=error) + CALL parser_get_object(parser,r,newline=.TRUE.) + CALL parser_get_object(parser,nprj_ppnl) istr=LEN_TRIM(line_att)+1 WRITE(line_att(istr:),'(E24.16,1X,I0)')r, nprj_ppnl END IF @@ -1979,7 +1946,7 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre READ(line_att,*)hprj_ppnl(i,i,l) CALL remove_word(line_att) ELSE - CALL parser_get_object(parser,hprj_ppnl(i,i,l),error=error) + CALL parser_get_object(parser,hprj_ppnl(i,i,l)) istr=LEN_TRIM(line_att)+1 WRITE(line_att(istr:),'(E24.16)')hprj_ppnl(i,i,l) END IF @@ -1987,18 +1954,18 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre IF (read_from_input) THEN IF (LEN_TRIM(line_att)/=0) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - is_ok=cp_sll_val_next(list,val,error=error) + is_ok=cp_sll_val_next(list,val) IF (.NOT.is_ok) CALL stop_program(routineN,moduleN,__LINE__,& "Error reading the Potential from input file!!") - CALL val_get(val,c_val=line_att,error=error) + CALL val_get(val,c_val=line_att) READ(line_att,*)hprj_ppnl(i,i,l) CALL remove_word(line_att) ELSE irep = irep + 1 CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) line_att ="" - CALL parser_get_object(parser,hprj_ppnl(i,i,l),newline=.TRUE.,error=error) + CALL parser_get_object(parser,hprj_ppnl(i,i,l),newline=.TRUE.) istr=LEN_TRIM(line_att)+1 WRITE(line_att(istr:),'(E24.16)')hprj_ppnl(i,i,l) END IF @@ -2008,7 +1975,7 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre READ(line_att,*)hprj_ppnl(i,j,l) CALL remove_word(line_att) ELSE - CALL parser_get_object(parser,hprj_ppnl(i,j,l),error=error) + CALL parser_get_object(parser,hprj_ppnl(i,j,l)) istr=LEN_TRIM(line_att)+1 WRITE(line_att(istr:),'(E24.16)')hprj_ppnl(i,j,l) END IF @@ -2017,7 +1984,7 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre IF (.NOT.read_from_input) THEN irep = irep + 1 CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) line_att ="" ELSE IF (LEN_TRIM(line_att) /= 0) THEN @@ -2046,7 +2013,7 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre CALL reallocate(potential%vprj_ppnl,1,nppnl,1,nppnl) DEALLOCATE (hprj_ppnl,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF EXIT search_loop END IF @@ -2068,13 +2035,13 @@ SUBROUTINE read_gth_potential(element_symbol,potential_name,potential,zeff_corre irep = irep + 1 WRITE(line_att,'(A)')" # Potential name: "//apname2(:strlen2)//" for symbol: "//symbol2(:strlen1) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) irep = irep + 1 WRITE(line_att,'(A)')" # Potential read from the potential filename: "//TRIM(potential_file_name) CALL section_vals_val_set(potential_section,"_DEFAULT_KEYWORD_",i_rep_val=irep,& - c_val=TRIM(line_att), error=error) + c_val=TRIM(line_att)) END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) END IF IF (ASSOCIATED(tmp_vals)) DEALLOCATE(tmp_vals) @@ -2086,14 +2053,12 @@ END SUBROUTINE read_gth_potential !> \param potential ... !> \param z ... !> \param zeff_correction ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE set_default_all_potential(potential,z,zeff_correction,error) + SUBROUTINE set_default_all_potential(potential,z,zeff_correction) TYPE(all_potential_type), POINTER :: potential INTEGER, INTENT(IN) :: z REAL(KIND=dp) :: zeff_correction - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_default_all_potential', & routineP = moduleN//':'//routineN @@ -2371,9 +2336,8 @@ END SUBROUTINE set_gth_potential !> \brief ... !> \param potential ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_all_potential(potential,output_unit,error) + SUBROUTINE write_all_potential(potential,output_unit) ! Write an atomic all-electron potential data set to the output unit. @@ -2381,7 +2345,6 @@ SUBROUTINE write_all_potential(potential,output_unit,error) TYPE(all_potential_type), POINTER :: potential INTEGER, INTENT(in) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=20) :: string @@ -2406,9 +2369,8 @@ END SUBROUTINE write_all_potential !> \brief ... !> \param potential ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_local_potential(potential,output_unit,error) + SUBROUTINE write_local_potential(potential,output_unit) ! Write an atomic local potential data set to the output unit. @@ -2416,7 +2378,6 @@ SUBROUTINE write_local_potential(potential,output_unit,error) TYPE(local_potential_type), POINTER :: potential INTEGER, INTENT(in) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: igau, ipol @@ -2438,16 +2399,14 @@ END SUBROUTINE write_local_potential !> \brief ... !> \param potential ... !> \param output_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_gth_potential(potential,output_unit,error) + SUBROUTINE write_gth_potential(potential,output_unit) ! Write an atomic GTH potential data set to the output unit. ! - Creation (09.02.2002,MK) TYPE(gth_potential_type), POINTER :: potential INTEGER, INTENT(in) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=20) :: string INTEGER :: i, j, l diff --git a/src/subsys/force_field_kind_types.F b/src/subsys/force_field_kind_types.F index 3e99fc9997..2062ae3762 100644 --- a/src/subsys/force_field_kind_types.F +++ b/src/subsys/force_field_kind_types.F @@ -110,14 +110,12 @@ MODULE force_field_kind_types !> \brief Allocate and initialize a bend kind set. !> \param bend_kind_set ... !> \param nkind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_bend_kind_set(bend_kind_set,nkind,error) + SUBROUTINE allocate_bend_kind_set(bend_kind_set,nkind) TYPE(bend_kind_type), DIMENSION(:), & POINTER :: bend_kind_set INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_bend_kind_set', & routineP = moduleN//':'//routineN @@ -128,7 +126,7 @@ SUBROUTINE allocate_bend_kind_set(bend_kind_set,nkind,error) failure = .FALSE. NULLIFY(bend_kind_set) ALLOCATE (bend_kind_set(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind bend_kind_set(ikind)%id_type = do_ff_undef bend_kind_set(ikind)%k = 0.0_dp @@ -147,14 +145,12 @@ END SUBROUTINE allocate_bend_kind_set !> \brief Allocate and initialize a bond kind set. !> \param bond_kind_set ... !> \param nkind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_bond_kind_set(bond_kind_set,nkind,error) + SUBROUTINE allocate_bond_kind_set(bond_kind_set,nkind) TYPE(bond_kind_type), DIMENSION(:), & POINTER :: bond_kind_set INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_bond_kind_set', & routineP = moduleN//':'//routineN @@ -165,7 +161,7 @@ SUBROUTINE allocate_bond_kind_set(bond_kind_set,nkind,error) failure = .FALSE. NULLIFY(bond_kind_set) ALLOCATE (bond_kind_set(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind bond_kind_set(ikind)%id_type = do_ff_undef bond_kind_set(ikind)%k(:) = 0.0_dp @@ -179,14 +175,12 @@ END SUBROUTINE allocate_bond_kind_set !> \brief Allocate and initialize a torsion kind set. !> \param torsion_kind_set ... !> \param nkind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_torsion_kind_set(torsion_kind_set,nkind,error) + SUBROUTINE allocate_torsion_kind_set(torsion_kind_set,nkind) TYPE(torsion_kind_type), DIMENSION(:), & POINTER :: torsion_kind_set INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_torsion_kind_set', & routineP = moduleN//':'//routineN @@ -197,7 +191,7 @@ SUBROUTINE allocate_torsion_kind_set(torsion_kind_set,nkind,error) failure = .FALSE. NULLIFY(torsion_kind_set) ALLOCATE (torsion_kind_set(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind torsion_kind_set(ikind)%id_type = do_ff_undef @@ -213,14 +207,12 @@ END SUBROUTINE allocate_torsion_kind_set !> \brief Allocate and initialize a ub kind set. !> \param ub_kind_set ... !> \param nkind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_ub_kind_set(ub_kind_set,nkind,error) + SUBROUTINE allocate_ub_kind_set(ub_kind_set,nkind) TYPE(ub_kind_type), DIMENSION(:), & POINTER :: ub_kind_set INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_ub_kind_set', & routineP = moduleN//':'//routineN @@ -231,7 +223,7 @@ SUBROUTINE allocate_ub_kind_set(ub_kind_set,nkind,error) failure = .FALSE. NULLIFY(ub_kind_set) ALLOCATE (ub_kind_set(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind ub_kind_set(ikind)%id_type = do_ff_undef ub_kind_set(ikind)%k = 0.0_dp @@ -244,14 +236,12 @@ END SUBROUTINE allocate_ub_kind_set !> \brief Allocate and initialize a impr kind set. !> \param impr_kind_set ... !> \param nkind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_impr_kind_set(impr_kind_set,nkind,error) + SUBROUTINE allocate_impr_kind_set(impr_kind_set,nkind) TYPE(impr_kind_type), DIMENSION(:), & POINTER :: impr_kind_set INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_impr_kind_set', & routineP = moduleN//':'//routineN @@ -262,7 +252,7 @@ SUBROUTINE allocate_impr_kind_set(impr_kind_set,nkind,error) failure = .FALSE. NULLIFY(impr_kind_set) ALLOCATE (impr_kind_set(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind impr_kind_set(ikind)%id_type = do_ff_undef impr_kind_set(ikind)%k = 0.0_dp @@ -275,14 +265,12 @@ END SUBROUTINE allocate_impr_kind_set !> \brief Allocate and initialize a opbend kind set. !> \param opbend_kind_set ... !> \param nkind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE allocate_opbend_kind_set(opbend_kind_set,nkind,error) + SUBROUTINE allocate_opbend_kind_set(opbend_kind_set,nkind) TYPE(opbend_kind_type), DIMENSION(:), & POINTER :: opbend_kind_set INTEGER, INTENT(IN) :: nkind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_opbend_kind_set', & routineP = moduleN//':'//routineN @@ -293,7 +281,7 @@ SUBROUTINE allocate_opbend_kind_set(opbend_kind_set,nkind,error) failure = .FALSE. NULLIFY(opbend_kind_set) ALLOCATE (opbend_kind_set(nkind),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ikind=1,nkind opbend_kind_set(ikind)%id_type = do_ff_undef opbend_kind_set(ikind)%k = 0.0_dp @@ -305,13 +293,11 @@ END SUBROUTINE allocate_opbend_kind_set ! ***************************************************************************** !> \brief Deallocate a bend kind set. !> \param bend_kind_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_bend_kind_set(bend_kind_set,error) + SUBROUTINE deallocate_bend_kind_set(bend_kind_set) TYPE(bend_kind_type), DIMENSION(:), & POINTER :: bend_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_bend_kind_set', & routineP = moduleN//':'//routineN @@ -321,19 +307,17 @@ SUBROUTINE deallocate_bend_kind_set(bend_kind_set,error) failure = .FALSE. DEALLOCATE (bend_kind_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_bend_kind_set ! ***************************************************************************** !> \brief Deallocate a bond kind set. !> \param bond_kind_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE deallocate_bond_kind_set(bond_kind_set,error) + SUBROUTINE deallocate_bond_kind_set(bond_kind_set) TYPE(bond_kind_type), DIMENSION(:), & POINTER :: bond_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_bond_kind_set', & routineP = moduleN//':'//routineN @@ -343,19 +327,17 @@ SUBROUTINE deallocate_bond_kind_set(bond_kind_set,error) failure = .FALSE. DEALLOCATE (bond_kind_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_bond_kind_set ! ***************************************************************************** !> \brief Deallocate a torsion kind element !> \param torsion_kind ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE torsion_kind_dealloc_ref(torsion_kind,error) + SUBROUTINE torsion_kind_dealloc_ref(torsion_kind) TYPE(torsion_kind_type), INTENT(INOUT) :: torsion_kind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'torsion_kind_dealloc_ref', & routineP = moduleN//':'//routineN @@ -367,15 +349,15 @@ SUBROUTINE torsion_kind_dealloc_ref(torsion_kind,error) IF(ASSOCIATED(torsion_kind%k)) THEN DEALLOCATE(torsion_kind%k,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(torsion_kind%m)) THEN DEALLOCATE(torsion_kind%m,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(torsion_kind%phi0)) THEN DEALLOCATE(torsion_kind%phi0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE torsion_kind_dealloc_ref @@ -383,12 +365,10 @@ END SUBROUTINE torsion_kind_dealloc_ref ! ***************************************************************************** !> \brief Deallocate a ub kind set. !> \param ub_kind_set ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ub_kind_dealloc_ref(ub_kind_set, error) + SUBROUTINE ub_kind_dealloc_ref(ub_kind_set) TYPE(ub_kind_type), DIMENSION(:), & POINTER :: ub_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ub_kind_dealloc_ref', & routineP = moduleN//':'//routineN @@ -398,17 +378,15 @@ SUBROUTINE ub_kind_dealloc_ref(ub_kind_set, error) failure = .FALSE. DEALLOCATE(ub_kind_set, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE ub_kind_dealloc_ref ! ***************************************************************************** !> \brief Deallocate a impr kind element -!> \param error ... ! ***************************************************************************** - SUBROUTINE impr_kind_dealloc_ref(error) + SUBROUTINE impr_kind_dealloc_ref() - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'impr_kind_dealloc_ref', & routineP = moduleN//':'//routineN diff --git a/src/subsys/mol_kind_new_list_types.F b/src/subsys/mol_kind_new_list_types.F index 416b4ef872..85992639ae 100644 --- a/src/subsys/mol_kind_new_list_types.F +++ b/src/subsys/mol_kind_new_list_types.F @@ -92,21 +92,18 @@ MODULE mol_kind_new_list_types !> will deallocate it (defaults to true) !> \param n_els number of elements in the list (at least one els_ptr or !> n_els should be given) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE mol_kind_new_list_create(list, els_ptr, & - owns_els, n_els, error) + owns_els, n_els) TYPE(mol_kind_new_list_type), OPTIONAL, & POINTER :: list TYPE(molecule_kind_type), DIMENSION(:), & OPTIONAL, POINTER :: els_ptr LOGICAL, INTENT(in), OPTIONAL :: owns_els INTEGER, INTENT(in), OPTIONAL :: n_els - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mol_kind_new_list_create', & routineP = moduleN//':'//routineN @@ -116,10 +113,10 @@ SUBROUTINE mol_kind_new_list_create(list, els_ptr, & failure=.FALSE. - CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,failure) ALLOCATE(list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_mol_kind_new_list_id=last_mol_kind_new_list_id+1 list%id_nr=last_mol_kind_new_list_id list%ref_count=1 @@ -136,23 +133,20 @@ SUBROUTINE mol_kind_new_list_create(list, els_ptr, & IF (PRESENT(n_els)) list%n_els=n_els IF (.NOT.ASSOCIATED(list%els)) THEN ALLOCATE(list%els(list%n_els),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP) END IF END SUBROUTINE mol_kind_new_list_create ! ***************************************************************************** !> \brief retains a list (see doc/ReferenceCounting.html) !> \param list the list to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE mol_kind_new_list_retain(list, error) +SUBROUTINE mol_kind_new_list_retain(list) TYPE(mol_kind_new_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mol_kind_new_list_retain', & routineP = moduleN//':'//routineN @@ -161,23 +155,20 @@ SUBROUTINE mol_kind_new_list_retain(list, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,error,failure) - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count+1 END SUBROUTINE mol_kind_new_list_retain ! ***************************************************************************** !> \brief releases a list (see doc/ReferenceCounting.html) !> \param list the list to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE mol_kind_new_list_release(list, error) +SUBROUTINE mol_kind_new_list_release(list) TYPE(mol_kind_new_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mol_kind_new_list_release', & routineP = moduleN//':'//routineN @@ -188,17 +179,17 @@ SUBROUTINE mol_kind_new_list_release(list, error) failure=.FALSE. IF (ASSOCIATED(list)) THEN - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count-1 IF (list%ref_count==0) THEN IF (list%owns_els) THEN IF (ASSOCIATED(list%els)) THEN - CALL deallocate_molecule_kind_set(list%els,error=error) + CALL deallocate_molecule_kind_set(list%els) END IF END IF NULLIFY(list%els) DEALLOCATE(list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(list) diff --git a/src/subsys/mol_new_list_types.F b/src/subsys/mol_new_list_types.F index f053ab64ce..3ef187bb3c 100644 --- a/src/subsys/mol_new_list_types.F +++ b/src/subsys/mol_new_list_types.F @@ -92,21 +92,18 @@ MODULE mol_new_list_types !> will deallocate it (defaults to true) !> \param n_els number of elements in the list (at least one els_ptr or !> n_els should be given) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE mol_new_list_create(list, els_ptr, & - owns_els, n_els, error) + owns_els, n_els) TYPE(mol_new_list_type), OPTIONAL, & POINTER :: list TYPE(molecule_type), DIMENSION(:), & OPTIONAL, POINTER :: els_ptr LOGICAL, INTENT(in), OPTIONAL :: owns_els INTEGER, INTENT(in), OPTIONAL :: n_els - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mol_new_list_create', & routineP = moduleN//':'//routineN @@ -116,10 +113,10 @@ SUBROUTINE mol_new_list_create(list, els_ptr, & failure=.FALSE. - CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,failure) ALLOCATE(list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_mol_new_list_id=last_mol_new_list_id+1 list%id_nr=last_mol_new_list_id list%ref_count=1 @@ -136,23 +133,20 @@ SUBROUTINE mol_new_list_create(list, els_ptr, & IF (PRESENT(n_els)) list%n_els=n_els IF (.NOT.ASSOCIATED(list%els)) THEN ALLOCATE(list%els(list%n_els),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP) END IF END SUBROUTINE mol_new_list_create ! ***************************************************************************** !> \brief retains a list (see doc/ReferenceCounting.html) !> \param list the list to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE mol_new_list_retain(list, error) +SUBROUTINE mol_new_list_retain(list) TYPE(mol_new_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mol_new_list_retain', & routineP = moduleN//':'//routineN @@ -161,23 +155,20 @@ SUBROUTINE mol_new_list_retain(list, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,error,failure) - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count+1 END SUBROUTINE mol_new_list_retain ! ***************************************************************************** !> \brief releases a list (see doc/ReferenceCounting.html) !> \param list the list to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE mol_new_list_release(list, error) +SUBROUTINE mol_new_list_release(list) TYPE(mol_new_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'mol_new_list_release', & routineP = moduleN//':'//routineN @@ -188,17 +179,17 @@ SUBROUTINE mol_new_list_release(list, error) failure=.FALSE. IF (ASSOCIATED(list)) THEN - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count-1 IF (list%ref_count==0) THEN IF (list%owns_els) THEN IF (ASSOCIATED(list%els)) THEN - CALL deallocate_molecule_set(list%els,error=error) + CALL deallocate_molecule_set(list%els) END IF END IF NULLIFY(list%els) DEALLOCATE(list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(list) diff --git a/src/subsys/molecule_kind_types.F b/src/subsys/molecule_kind_types.F index cb0a1bc2f9..f8a5b17e2c 100644 --- a/src/subsys/molecule_kind_types.F +++ b/src/subsys/molecule_kind_types.F @@ -233,13 +233,11 @@ MODULE molecule_kind_types !> \brief ... !> \param colv_list ... !> \param ncolv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE setup_colvar_counters(colv_list, ncolv,error) + SUBROUTINE setup_colvar_counters(colv_list, ncolv) TYPE(colvar_constraint_type), & DIMENSION(:), POINTER :: colv_list TYPE(colvar_counters) :: ncolv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_colvar_counters', & routineP = moduleN//':'//routineN @@ -303,7 +301,7 @@ SUBROUTINE setup_colvar_counters(colv_list, ncolv,error) CASE(combine_colvar_id) ncolv%ncombinecvs = ncolv%ncombinecvs + 1 CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO END IF @@ -331,16 +329,14 @@ END SUBROUTINE setup_colvar_counters !> \brief Allocate and initialize a molecule kind set. !> \param molecule_kind_set ... !> \param nmolecule_kind ... -!> \param error ... !> \date 22.08.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_molecule_kind_set(molecule_kind_set,nmolecule_kind,error) + SUBROUTINE allocate_molecule_kind_set(molecule_kind_set,nmolecule_kind) TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set INTEGER, INTENT(IN) :: nmolecule_kind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_molecule_kind_set', & routineP = moduleN//':'//routineN @@ -350,11 +346,11 @@ SUBROUTINE allocate_molecule_kind_set(molecule_kind_set,nmolecule_kind,error) failure = .FALSE. IF (ASSOCIATED(molecule_kind_set)) THEN - CALL deallocate_molecule_kind_set(molecule_kind_set,error=error) + CALL deallocate_molecule_kind_set(molecule_kind_set) END IF ALLOCATE (molecule_kind_set(nmolecule_kind),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DO imolecule_kind=1,nmolecule_kind NULLIFY (molecule_kind_set(imolecule_kind)%atom_list) @@ -388,7 +384,7 @@ SUBROUTINE allocate_molecule_kind_set(molecule_kind_set,nmolecule_kind,error) molecule_kind_set(imolecule_kind)%nopbend = 0 molecule_kind_set(imolecule_kind)%nub = 0 CALL setup_colvar_counters(molecule_kind_set(imolecule_kind)%colv_list,& - molecule_kind_set(imolecule_kind)%ncolv,error) + molecule_kind_set(imolecule_kind)%ncolv) molecule_kind_set(imolecule_kind)%ng3x3 = 0 molecule_kind_set(imolecule_kind)%ng4x6 = 0 molecule_kind_set(imolecule_kind)%nvsite = 0 @@ -408,16 +404,14 @@ END SUBROUTINE allocate_molecule_kind_set ! ***************************************************************************** !> \brief Deallocate a molecule kind set. !> \param molecule_kind_set ... -!> \param error ... !> \date 22.08.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_molecule_kind_set(molecule_kind_set,error) + SUBROUTINE deallocate_molecule_kind_set(molecule_kind_set) TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_molecule_kind_set', & routineP = moduleN//':'//routineN @@ -435,97 +429,97 @@ SUBROUTINE deallocate_molecule_kind_set(molecule_kind_set,error) IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%atom_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%atom_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_kind_set)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_kind_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bend_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%bend_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%ub_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%ub_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%ub_kind_set)) THEN - CALL ub_kind_dealloc_ref(molecule_kind_set(imolecule_kind)%ub_kind_set,error=error) + CALL ub_kind_dealloc_ref(molecule_kind_set(imolecule_kind)%ub_kind_set) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%impr_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%impr_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%impr_kind_set)) THEN DO i = 1, SIZE(molecule_kind_set(imolecule_kind)%impr_kind_set) - CALL impr_kind_dealloc_ref(error=error) !This Subroutine doesn't deallocate anything, maybe needs to be implemented + CALL impr_kind_dealloc_ref() !This Subroutine doesn't deallocate anything, maybe needs to be implemented END DO DEALLOCATE (molecule_kind_set(imolecule_kind)%impr_kind_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%opbend_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%opbend_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%opbend_kind_set)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%opbend_kind_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bond_kind_set)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%bond_kind_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%bond_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%bond_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%colv_list)) THEN DO j = 1, SIZE(molecule_kind_set(imolecule_kind)%colv_list) DEALLOCATE (molecule_kind_set(imolecule_kind)%colv_list(j)%i_atoms,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE (molecule_kind_set(imolecule_kind)%colv_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%g3x3_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%g3x3_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%g4x6_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%g4x6_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%vsite_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%vsite_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%fixd_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%fixd_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%torsion_kind_set)) THEN DO i = 1, SIZE(molecule_kind_set(imolecule_kind)%torsion_kind_set) - CALL torsion_kind_dealloc_ref(molecule_kind_set(imolecule_kind)%torsion_kind_set(i),error=error) + CALL torsion_kind_dealloc_ref(molecule_kind_set(imolecule_kind)%torsion_kind_set(i)) END DO DEALLOCATE (molecule_kind_set(imolecule_kind)%torsion_kind_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%shell_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%shell_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%torsion_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%torsion_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(molecule_kind_set(imolecule_kind)%molecule_list)) THEN DEALLOCATE (molecule_kind_set(imolecule_kind)%molecule_list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF END DO DEALLOCATE (molecule_kind_set,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer molecule_kind_set is not associated and cannot be deallocated") @@ -1039,15 +1033,13 @@ END SUBROUTINE set_molecule_kind !> \brief Write a molecule kind data set to the output unit. !> \param molecule_kind ... !> \param output_unit ... -!> \param error ... !> \date 24.09.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_molecule_kind(molecule_kind,output_unit,error) + SUBROUTINE write_molecule_kind(molecule_kind,output_unit) TYPE(molecule_kind_type), POINTER :: molecule_kind INTEGER, INTENT(in) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_molecule_kind', & routineP = moduleN//':'//routineN @@ -1113,7 +1105,7 @@ SUBROUTINE write_molecule_kind(molecule_kind,output_unit,error) END IF ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF @@ -1123,16 +1115,14 @@ END SUBROUTINE write_molecule_kind !> \brief Write a moleculeatomic kind set data set to the output unit. !> \param molecule_kind_set ... !> \param subsys_section ... -!> \param error ... !> \date 24.09.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE write_molecule_kind_set(molecule_kind_set,subsys_section,error) + SUBROUTINE write_molecule_kind_set(molecule_kind_set,subsys_section) TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_molecule_kind_set', & routineP = moduleN//':'//routineN @@ -1147,9 +1137,9 @@ SUBROUTINE write_molecule_kind_set(molecule_kind_set,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,subsys_section,& - "PRINT%MOLECULES",extension=".Log",error=error) + "PRINT%MOLECULES",extension=".Log") IF (output_unit>0) THEN IF (ASSOCIATED(molecule_kind_set)) THEN WRITE (UNIT=output_unit,FMT="(/,/,T2,A)") "MOLECULE KIND INFORMATION" @@ -1169,7 +1159,7 @@ SUBROUTINE write_molecule_kind_set(molecule_kind_set,subsys_section,error) ELSE DO imolecule_kind=1,nmolecule_kind molecule_kind => molecule_kind_set(imolecule_kind) - CALL write_molecule_kind(molecule_kind,output_unit,error) + CALL write_molecule_kind(molecule_kind,output_unit) END DO ENDIF @@ -1197,12 +1187,12 @@ SUBROUTINE write_molecule_kind_set(molecule_kind_set,subsys_section,error) "Total Number of opbends: ",nopbend END IF ELSE - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,subsys_section,& - "PRINT%MOLECULES",error=error) + "PRINT%MOLECULES") CALL timestop(handle) diff --git a/src/subsys/molecule_types_new.F b/src/subsys/molecule_types_new.F index 6a951e0996..d27c8d9c70 100644 --- a/src/subsys/molecule_types_new.F +++ b/src/subsys/molecule_types_new.F @@ -138,15 +138,13 @@ MODULE molecule_types_new ! ***************************************************************************** !> \brief Deallocate a global constraint. !> \param gci ... -!> \param error ... !> \par History !> 07.2003 created [fawzi] !> 01.2014 moved from cp_subsys_release() into separate routine. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE deallocate_global_constraint(gci, error) + SUBROUTINE deallocate_global_constraint(gci) TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i @@ -168,8 +166,8 @@ SUBROUTINE deallocate_global_constraint(gci, error) ! Local information IF (ASSOCIATED(gci%lcolv)) THEN DO i=1, SIZE(gci%lcolv) - CALL colvar_release(gci%lcolv(i)%colvar,error=error) - CALL colvar_release(gci%lcolv(i)%colvar_old,error=error) + CALL colvar_release(gci%lcolv(i)%colvar) + CALL colvar_release(gci%lcolv(i)%colvar_old) NULLIFY(gci%lcolv(i)%colvar, gci%lcolv(i)%colvar_old) END DO DEALLOCATE (gci%lcolv) @@ -193,23 +191,21 @@ END SUBROUTINE deallocate_global_constraint !> \brief Allocate a molecule set. !> \param molecule_set ... !> \param nmolecule ... -!> \param error ... !> \date 29.08.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_molecule_set(molecule_set,nmolecule,error) + SUBROUTINE allocate_molecule_set(molecule_set,nmolecule) TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set INTEGER, INTENT(IN) :: nmolecule - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_molecule_set', & routineP = moduleN//':'//routineN INTEGER :: imolecule, istat - IF (ASSOCIATED(molecule_set)) CALL deallocate_molecule_set(molecule_set,error) + IF (ASSOCIATED(molecule_set)) CALL deallocate_molecule_set(molecule_set) ALLOCATE (molecule_set(nmolecule),STAT=istat) IF (istat /= 0) CALL stop_memory(routineN,moduleN,__LINE__,& @@ -231,15 +227,13 @@ END SUBROUTINE allocate_molecule_set ! ***************************************************************************** !> \brief Deallocate a molecule set. !> \param molecule_set ... -!> \param error ... !> \date 29.08.2003 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_molecule_set(molecule_set,error) + SUBROUTINE deallocate_molecule_set(molecule_set) TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_molecule_set', & routineP = moduleN//':'//routineN @@ -262,8 +256,8 @@ SUBROUTINE deallocate_molecule_set(molecule_set,error) IF (ASSOCIATED(molecule_set(imolecule)%lci)) THEN IF (ASSOCIATED(molecule_set(imolecule)%lci%lcolv)) THEN DO j = 1, SIZE(molecule_set(imolecule)%lci%lcolv) - CALL colvar_release(molecule_set(imolecule)%lci%lcolv(j)%colvar,error=error) - CALL colvar_release(molecule_set(imolecule)%lci%lcolv(j)%colvar_old,error=error) + CALL colvar_release(molecule_set(imolecule)%lci%lcolv(j)%colvar) + CALL colvar_release(molecule_set(imolecule)%lci%lcolv(j)%colvar_old) NULLIFY(molecule_set(imolecule)%lci%lcolv(j)%colvar) NULLIFY(molecule_set(imolecule)%lci%lcolv(j)%colvar_old) END DO @@ -514,13 +508,11 @@ END SUBROUTINE set_molecule_set !> \brief finds for each atom the molecule it belongs to !> \param molecule_set ... !> \param atom_to_mol ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE molecule_of_atom(molecule_set,atom_to_mol,error) + SUBROUTINE molecule_of_atom(molecule_set,atom_to_mol) TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set INTEGER, DIMENSION(:), INTENT(OUT) :: atom_to_mol - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'molecule_of_atom', & routineP = moduleN//':'//routineN @@ -549,21 +541,19 @@ END SUBROUTINE molecule_of_atom !> \param mol_to_nbasis ... !> \param mol_to_charge ... !> \param mol_to_multiplicity ... -!> \param error ... !> \par History !> 2011.06 created [Rustam Z Khaliullin] !> \author Rustam Z Khaliullin ! ***************************************************************************** SUBROUTINE get_molecule_set_info(molecule_set,atom_to_mol,mol_to_first_atom,& mol_to_last_atom,mol_to_nelectrons,mol_to_nbasis,mol_to_charge,& - mol_to_multiplicity,error) + mol_to_multiplicity) TYPE(molecule_type), DIMENSION(:), & POINTER :: molecule_set INTEGER, DIMENSION(:), INTENT(OUT), OPTIONAL :: atom_to_mol, & mol_to_first_atom, mol_to_last_atom, mol_to_nelectrons, mol_to_nbasis, & mol_to_charge, mol_to_multiplicity - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_molecule_set_info', & routineP = moduleN//':'//routineN diff --git a/src/subsys/multipole_types.F b/src/subsys/multipole_types.F index dde55552f1..a65b3ce397 100644 --- a/src/subsys/multipole_types.F +++ b/src/subsys/multipole_types.F @@ -60,18 +60,16 @@ MODULE multipole_types !> \param particle_set ... !> \param subsys_section ... !> \param max_multipole ... -!> \param error ... !> \par History !> 12.2007 created [tlaino] - Teodoro Laino - University of Zurich !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE create_multipole_type(multipoles, particle_set, subsys_section, max_multipole, error) + SUBROUTINE create_multipole_type(multipoles, particle_set, subsys_section, max_multipole) TYPE(multipole_type), POINTER :: multipoles TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(section_vals_type), POINTER :: subsys_section INTEGER, INTENT(IN) :: max_multipole - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_multipole_type', & routineP = moduleN//':'//routineN @@ -85,7 +83,7 @@ SUBROUTINE create_multipole_type(multipoles, particle_set, subsys_section, max_m failure = .FALSE. ALLOCATE(multipoles, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_multipole_id_nr=last_multipole_id_nr+1 multipoles%id_nr=last_multipole_id_nr @@ -105,14 +103,14 @@ SUBROUTINE create_multipole_type(multipoles, particle_set, subsys_section, max_m CASE(do_multipole_quadrupole) multipoles%task(1:3) = .TRUE. CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT nparticles = SIZE(particle_set) IF (multipoles%task(1)) THEN ALLOCATE(multipoles%charges(nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(multipoles%radii(nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Fill in charge array DO iparticle = 1, nparticles !atomic_kind => @@ -124,15 +122,15 @@ SUBROUTINE create_multipole_type(multipoles, particle_set, subsys_section, max_m END IF IF (multipoles%task(2)) THEN ALLOCATE(multipoles%dipoles(3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Fill in dipole array (if specified) - work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%DIPOLES",error=error) - CALL section_vals_get(work_section, explicit=explicit, error=error) + work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%DIPOLES") + CALL section_vals_get(work_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",n_rep_val=n_rep, error=error) - CPPostcondition(n_rep==nparticles,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",n_rep_val=n_rep) + CPPostcondition(n_rep==nparticles,cp_failure_level,routineP,failure) DO iparticle = 1, n_rep - CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",i_rep_val=iparticle, r_vals=work, error=error) + CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",i_rep_val=iparticle, r_vals=work) multipoles%dipoles(1:3,iparticle) = work END DO ELSE @@ -141,15 +139,15 @@ SUBROUTINE create_multipole_type(multipoles, particle_set, subsys_section, max_m END IF IF (multipoles%task(3)) THEN ALLOCATE(multipoles%quadrupoles(3,3,nparticles),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Fill in quadrupole array (if specified) - work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%QUADRUPOLES",error=error) - CALL section_vals_get(work_section, explicit=explicit, error=error) + work_section => section_vals_get_subs_vals(subsys_section,"MULTIPOLES%QUADRUPOLES") + CALL section_vals_get(work_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",n_rep_val=n_rep, error=error) - CPPostcondition(n_rep==nparticles,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",n_rep_val=n_rep) + CPPostcondition(n_rep==nparticles,cp_failure_level,routineP,failure) DO iparticle = 1, n_rep - CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",i_rep_val=iparticle, r_vals=work, error=error) + CALL section_vals_val_get(work_section,"_DEFAULT_KEYWORD_",i_rep_val=iparticle, r_vals=work) DO i = 1, 3 DO j = 1, 3 ind2 = 3*(MIN(i,j)-1)-(MIN(i,j)*(MIN(i,j)-1))/2+MAX(i,j) @@ -166,15 +164,12 @@ END SUBROUTINE create_multipole_type ! ***************************************************************************** !> \brief ... !> \param multipoles ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2007 created [tlaino] - Teodoro Laino - University of Zurich !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE release_multipole_type(multipoles, error) + SUBROUTINE release_multipole_type(multipoles) TYPE(multipole_type), POINTER :: multipoles - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'release_multipole_type', & routineP = moduleN//':'//routineN @@ -184,27 +179,27 @@ SUBROUTINE release_multipole_type(multipoles, error) failure =.FALSE. IF (ASSOCIATED(multipoles)) THEN - CPPostcondition(multipoles%ref_count>0,cp_failure_level,routineP,error,failure) + CPPostcondition(multipoles%ref_count>0,cp_failure_level,routineP,failure) multipoles%ref_count=multipoles%ref_count-1 IF (multipoles%ref_count==0) THEN IF (ASSOCIATED(multipoles%charges)) THEN DEALLOCATE(multipoles%charges, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(multipoles%radii)) THEN DEALLOCATE(multipoles%radii, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(multipoles%dipoles)) THEN DEALLOCATE(multipoles%dipoles, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(multipoles%quadrupoles)) THEN DEALLOCATE(multipoles%quadrupoles, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(multipoles, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF END SUBROUTINE release_multipole_type @@ -212,15 +207,12 @@ END SUBROUTINE release_multipole_type ! ***************************************************************************** !> \brief ... !> \param multipoles ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2007 created [tlaino] - Teodoro Laino - University of Zurich !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE retain_multipole_type(multipoles, error) + SUBROUTINE retain_multipole_type(multipoles) TYPE(multipole_type), POINTER :: multipoles - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'retain_multipole_type', & routineP = moduleN//':'//routineN @@ -229,7 +221,7 @@ SUBROUTINE retain_multipole_type(multipoles, error) failure=.FALSE. IF (ASSOCIATED(multipoles)) THEN - CPPreconditionNoFail(multipoles%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(multipoles%ref_count>0,cp_failure_level,routineP) multipoles%ref_count=multipoles%ref_count+1 END IF END SUBROUTINE retain_multipole_type diff --git a/src/subsys/particle_list_types.F b/src/subsys/particle_list_types.F index 3ce447000d..baec81c169 100644 --- a/src/subsys/particle_list_types.F +++ b/src/subsys/particle_list_types.F @@ -92,21 +92,18 @@ MODULE particle_list_types !> will deallocate it (defaults to true) !> \param n_els number of elements in the list (at least one els_ptr or !> n_els should be given) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE particle_list_create(list, els_ptr, & - owns_els, n_els, error) + owns_els, n_els) TYPE(particle_list_type), OPTIONAL, & POINTER :: list TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: els_ptr LOGICAL, INTENT(in), OPTIONAL :: owns_els INTEGER, INTENT(in), OPTIONAL :: n_els - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'particle_list_create', & routineP = moduleN//':'//routineN @@ -116,10 +113,10 @@ SUBROUTINE particle_list_create(list, els_ptr, & failure=.FALSE. - CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(els_ptr).OR.PRESENT(n_els),cp_failure_level,routineP,failure) ALLOCATE(list, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) last_particle_list_id=last_particle_list_id+1 list%id_nr=last_particle_list_id list%ref_count=1 @@ -136,23 +133,20 @@ SUBROUTINE particle_list_create(list, els_ptr, & IF (PRESENT(n_els)) list%n_els=n_els IF (.NOT.ASSOCIATED(list%els)) THEN ALLOCATE(list%els(list%n_els),stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) + CPPreconditionNoFail(list%owns_els,cp_warning_level,routineP) END IF END SUBROUTINE particle_list_create ! ***************************************************************************** !> \brief retains a list (see doc/ReferenceCounting.html) !> \param list the list to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE particle_list_retain(list, error) +SUBROUTINE particle_list_retain(list) TYPE(particle_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'particle_list_retain', & routineP = moduleN//':'//routineN @@ -161,23 +155,20 @@ SUBROUTINE particle_list_retain(list, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,error,failure) - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(list),cp_failure_level,routineP,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count+1 END SUBROUTINE particle_list_retain ! ***************************************************************************** !> \brief releases a list (see doc/ReferenceCounting.html) !> \param list the list to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 08.2003 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -SUBROUTINE particle_list_release(list, error) +SUBROUTINE particle_list_release(list) TYPE(particle_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'particle_list_release', & routineP = moduleN//':'//routineN @@ -188,17 +179,17 @@ SUBROUTINE particle_list_release(list, error) failure=.FALSE. IF (ASSOCIATED(list)) THEN - CPPrecondition(list%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(list%ref_count>0,cp_failure_level,routineP,failure) list%ref_count=list%ref_count-1 IF (list%ref_count==0) THEN IF (list%owns_els) THEN IF (ASSOCIATED(list%els)) THEN - CALL deallocate_particle_set(list%els,error=error) + CALL deallocate_particle_set(list%els) END IF END IF NULLIFY(list%els) DEALLOCATE(list,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(list) diff --git a/src/subsys/particle_types.F b/src/subsys/particle_types.F index 8c119a85df..1bd3be1fcb 100644 --- a/src/subsys/particle_types.F +++ b/src/subsys/particle_types.F @@ -60,16 +60,14 @@ MODULE particle_types !> \brief Allocate a particle set. !> \param particle_set ... !> \param nparticle ... -!> \param error ... !> \date 14.01.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE allocate_particle_set(particle_set,nparticle,error) + SUBROUTINE allocate_particle_set(particle_set,nparticle) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set INTEGER, INTENT(IN) :: nparticle - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_particle_set', & routineP = moduleN//':'//routineN @@ -79,10 +77,10 @@ SUBROUTINE allocate_particle_set(particle_set,nparticle,error) failure = .FALSE. IF (ASSOCIATED(particle_set)) THEN - CALL deallocate_particle_set(particle_set,error=error) + CALL deallocate_particle_set(particle_set) END IF ALLOCATE (particle_set(nparticle),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iparticle=1,nparticle NULLIFY (particle_set(iparticle)%atomic_kind) @@ -99,15 +97,13 @@ END SUBROUTINE allocate_particle_set ! ***************************************************************************** !> \brief Deallocate a particle set. !> \param particle_set ... -!> \param error ... !> \date 14.01.2002 !> \author MK !> \version 1.0 ! ***************************************************************************** - SUBROUTINE deallocate_particle_set(particle_set,error) + SUBROUTINE deallocate_particle_set(particle_set) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_particle_set', & routineP = moduleN//':'//routineN @@ -118,7 +114,7 @@ SUBROUTINE deallocate_particle_set(particle_set,error) failure = .FALSE. IF (ASSOCIATED(particle_set)) THEN DEALLOCATE (particle_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL stop_program(routineN,moduleN,__LINE__,& "The pointer particle_set is not associated and "//& @@ -135,16 +131,14 @@ END SUBROUTINE deallocate_particle_set !> \param vel ... !> \param for ... !> \param add ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE update_particle_set ( particle_set, int_group, pos, vel, for, add, error ) + SUBROUTINE update_particle_set ( particle_set, int_group, pos, vel, for, add) TYPE(particle_type), POINTER :: particle_set( : ) INTEGER, INTENT(IN) :: int_group REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: pos( :, : ), vel( :, : ), & for(:,:) LOGICAL, INTENT(IN), OPTIONAL :: add - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'update_particle_set', & routineP = moduleN//':'//routineN diff --git a/src/subsys/shell_potential_types.F b/src/subsys/shell_potential_types.F index de704888f4..79fcda092e 100644 --- a/src/subsys/shell_potential_types.F +++ b/src/subsys/shell_potential_types.F @@ -65,17 +65,14 @@ MODULE shell_potential_types !> \param k4_spring ... !> \param max_dist ... !> \param shell_cutoff ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_shell(shell,charge,charge_core,charge_shell,mass_core,& - mass_shell,k2_spring,k4_spring,max_dist,shell_cutoff,& - error) + mass_shell,k2_spring,k4_spring,max_dist,shell_cutoff) TYPE(shell_kind_type), POINTER :: shell REAL(KIND=dp), INTENT(OUT), OPTIONAL :: charge, charge_core, & charge_shell, mass_core, mass_shell, k2_spring, k4_spring, max_dist, & shell_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_shell', & routineP = moduleN//':'//routineN @@ -96,12 +93,10 @@ SUBROUTINE get_shell(shell,charge,charge_core,charge_shell,mass_core,& ! ***************************************************************************** !> \brief ... !> \param shell ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE shell_create(shell,error) + SUBROUTINE shell_create(shell) TYPE(shell_kind_type), POINTER :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shell_create', & routineP = moduleN//':'//routineN @@ -110,9 +105,9 @@ SUBROUTINE shell_create(shell,error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(shell),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(shell),cp_failure_level,routineP,failure) ALLOCATE(shell,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) shell%ref_count = 1 END SUBROUTINE shell_create @@ -121,14 +116,12 @@ END SUBROUTINE shell_create !> \brief ... !> \param shell_list ... !> \param ndim ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE shell_p_create(shell_list,ndim,error) + SUBROUTINE shell_p_create(shell_list,ndim) TYPE(shell_p_type), DIMENSION(:), & POINTER :: shell_list INTEGER, INTENT(IN) :: ndim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shell_p_create', & routineP = moduleN//':'//routineN @@ -138,13 +131,13 @@ SUBROUTINE shell_p_create(shell_list,ndim,error) failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(shell_list),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(shell_list),cp_failure_level,routineP,failure) ALLOCATE(shell_list(ndim), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i = 1,ndim NULLIFY (shell_list(i)%shell) - CALL shell_create(shell_list(i)%shell,error) + CALL shell_create(shell_list(i)%shell) shell_list(i)%atm_name='' END DO @@ -153,12 +146,10 @@ END SUBROUTINE shell_p_create ! ***************************************************************************** !> \brief ... !> \param shell ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE shell_retain(shell,error) + SUBROUTINE shell_retain(shell) TYPE(shell_kind_type), POINTER :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shell_retain', & routineP = moduleN//':'//routineN @@ -167,8 +158,8 @@ SUBROUTINE shell_retain(shell,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(shell),cp_failure_level,routineP,error,failure) - CPPrecondition(shell%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(shell),cp_failure_level,routineP,failure) + CPPrecondition(shell%ref_count>0,cp_failure_level,routineP,failure) shell%ref_count=shell%ref_count+1 END SUBROUTINE shell_retain @@ -176,12 +167,10 @@ END SUBROUTINE shell_retain ! ***************************************************************************** !> \brief ... !> \param shell ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE shell_release(shell,error) + SUBROUTINE shell_release(shell) TYPE(shell_kind_type), POINTER :: shell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shell_release', & routineP = moduleN//':'//routineN @@ -191,11 +180,11 @@ SUBROUTINE shell_release(shell,error) failure = .FALSE. IF(ASSOCIATED(shell)) THEN - CPPrecondition(shell%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(shell%ref_count>0,cp_failure_level,routineP,failure) shell%ref_count=shell%ref_count-1 IF(shell%ref_count==0) THEN DEALLOCATE(shell,STAT=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END IF END IF NULLIFY(shell) @@ -205,12 +194,10 @@ END SUBROUTINE shell_release ! ***************************************************************************** !> \brief ... !> \param shell_list ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE shell_p_release(shell_list, error) + SUBROUTINE shell_p_release(shell_list) TYPE(shell_p_type), DIMENSION(:), & POINTER :: shell_list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'shell_p_release', & routineP = moduleN//':'//routineN @@ -219,10 +206,10 @@ SUBROUTINE shell_p_release(shell_list, error) IF (ASSOCIATED(shell_list)) THEN DO i = 1,SIZE(shell_list) - CALL shell_release(shell_list(i)%shell,error=error) + CALL shell_release(shell_list(i)%shell) END DO DEALLOCATE(shell_list,stat=istat) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) END IF NULLIFY (shell_list) diff --git a/src/subsys/virial_types.F b/src/subsys/virial_types.F index afb1831f6d..cfecfc4d3e 100644 --- a/src/subsys/virial_types.F +++ b/src/subsys/virial_types.F @@ -71,12 +71,10 @@ END SUBROUTINE cp_virial ! ***************************************************************************** !> \brief symmetrize the virial components !> \param virial ... -!> \param error ... !> \version 1.0 ! ***************************************************************************** - SUBROUTINE sym_virial (virial, error) + SUBROUTINE sym_virial (virial) TYPE(virial_type), POINTER :: virial - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'sym_virial', & routineP = moduleN//':'//routineN @@ -226,12 +224,10 @@ END SUBROUTINE virial_get ! ***************************************************************************** !> \brief ... !> \param virial ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE virial_create ( virial, error ) + SUBROUTINE virial_create ( virial) TYPE(virial_type), POINTER :: virial - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'virial_create', & routineP = moduleN//':'//routineN @@ -239,7 +235,7 @@ SUBROUTINE virial_create ( virial, error ) INTEGER :: istat ALLOCATE ( virial, stat=istat ) - CPPostconditionNoFail(istat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(istat==0,cp_warning_level,routineP) CALL zero_virial ( virial ) last_virial_id_nr=last_virial_id_nr+1 @@ -250,17 +246,14 @@ END SUBROUTINE virial_create ! ***************************************************************************** !> \brief retains the given virial_type !> \param virial the virial_type to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE virial_retain ( virial, error) + SUBROUTINE virial_retain ( virial) TYPE(virial_type), POINTER :: virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'virial_retain', & routineP = moduleN//':'//routineN @@ -269,25 +262,22 @@ SUBROUTINE virial_retain ( virial, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(virial),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(virial%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(virial),cp_failure_level,routineP,failure) + CPPreconditionNoFail(virial%ref_count>0,cp_failure_level,routineP) virial%ref_count=virial%ref_count+1 END SUBROUTINE virial_retain ! ***************************************************************************** !> \brief releases the given virial_type !> \param virial the virial_type to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 04.2003 created [fawzi] !> \author fawzi !> \note !> see doc/ReferenceCounting.html ! ***************************************************************************** - SUBROUTINE virial_release(virial, error) + SUBROUTINE virial_release(virial) TYPE(virial_type), POINTER :: virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'virial_release', & routineP = moduleN//':'//routineN @@ -297,11 +287,11 @@ SUBROUTINE virial_release(virial, error) failure=.FALSE. IF (ASSOCIATED(virial)) THEN - CPPreconditionNoFail(virial%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(virial%ref_count>0,cp_failure_level,routineP) virial%ref_count=virial%ref_count-1 IF (virial%ref_count.EQ.0) THEN DEALLOCATE(virial,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF NULLIFY(virial) END IF diff --git a/src/surface_dipole.F b/src/surface_dipole.F index 189507e618..9da9735ee7 100644 --- a/src/surface_dipole.F +++ b/src/surface_dipole.F @@ -51,19 +51,16 @@ MODULE surface_dipole !> \brief compute the surface dipole and the correction to the hartree potential !> \param qs_env the qs environment !> \param energy ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2014 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE calc_dipsurf_potential(qs_env,energy,error) + SUBROUTINE calc_dipsurf_potential(qs_env,energy) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_energy_type), POINTER :: energy - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'calc_dipsurf_potential', & routineP = moduleN//':'//routineN @@ -105,29 +102,28 @@ SUBROUTINE calc_dipsurf_potential(qs_env,energy,error) cell=cell,& pw_env=pw_env,& subsys=subsys,& - v_hartree_rspace=v_hartree_rspace,& - error=error) + v_hartree_rspace=v_hartree_rspace) CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool,& - pw_pools=pw_pools,error=error) + pw_pools=pw_pools) CALL pw_pool_create_pw(auxbas_pw_pool,wf_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,vdip_r%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) IF (dft_control%qs_control%gapw) THEN - CALL pw_transfer(rho0_s_gs%pw,wf_r%pw,error=error) + CALL pw_transfer(rho0_s_gs%pw,wf_r%pw) IF(dft_control%qs_control%gapw_control%nopaw_as_gpw) THEN - CALL pw_axpy(rho_core%pw,wf_r%pw, error=error) + CALL pw_axpy(rho_core%pw,wf_r%pw) END IF ELSE - CALL pw_transfer(rho_core%pw,wf_r%pw,error=error) + CALL pw_transfer(rho_core%pw,wf_r%pw) END IF - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) DO ispin=1,dft_control%nspins - CALL pw_axpy(rho_r(ispin)%pw,wf_r%pw, error=error) + CALL pw_axpy(rho_r(ispin)%pw,wf_r%pw) END DO ngrid(1:3) = wf_r%pw%pw_grid%npts(1:3) @@ -139,7 +135,7 @@ SUBROUTINE calc_dipsurf_potential(qs_env,energy,error) ! stop surface dipole defined only for slab perpendigular to one of the Cartesian axis CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP, " Dipole correction only for surface perpendicular to "//& - " one Cartesian axis",error, only_ionode=.TRUE.) + " one Cartesian axis",only_ionode=.TRUE.) ! not properly general, we assume that vectors A, B, and C are along x y and z respectively, ! in the ortorhombic cell, but in principle it does not need to be this way, importan ! is that the cell angles are 90 degrees. @@ -152,7 +148,7 @@ SUBROUTINE calc_dipsurf_potential(qs_env,energy,error) iup = wf_r%pw%pw_grid%bounds(2,idir_surfdip) ALLOCATE (rhoavsurf(ilow:iup),stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) rhoavsurf = 0.0_dp bo => wf_r%pw%pw_grid%bounds_local @@ -199,7 +195,7 @@ SUBROUTINE calc_dipsurf_potential(qs_env,energy,error) rhoav_min = ABS(rhoavsurf(ilayer_min)) CALL cp_assert(rhoav_min<1.E-5_dp, cp_failure_level,cp_assertion_failed,& routineP, " Dipole correction needs more vacuum space above the surface ",& - error, only_ionode=.TRUE.) + only_ionode=.TRUE.) height_min = REAL((ilayer_min - ilow),dp)*dh(idir_surfdip,idir_surfdip) @@ -219,10 +215,10 @@ SUBROUTINE calc_dipsurf_potential(qs_env,energy,error) END DO DEALLOCATE(rhoavsurf,stat=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! Calculation of the dipole potential as a function of the perpendicular coordinate - CALL pw_zero(vdip_r%pw, error=error) + CALL pw_zero(vdip_r%pw) vdip_fac = dip_hh*4.0_dp*pi DO i = ilayer_min+1,ilayer_min+ngrid(idir_surfdip) @@ -260,8 +256,8 @@ SUBROUTINE calc_dipsurf_potential(qs_env,energy,error) ! Add the dipole potential to the hartree potential on the realspace grid v_hartree_rspace%cr3d = v_hartree_rspace%cr3d + vdip_r%pw%cr3d - CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool,vdip_r%pw, error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool,wf_r%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool,vdip_r%pw) CALL timestop(handle) diff --git a/src/swarm/glbopt_history.F b/src/swarm/glbopt_history.F index 99daa76343..5d32a144a6 100644 --- a/src/swarm/glbopt_history.F +++ b/src/swarm/glbopt_history.F @@ -61,21 +61,19 @@ MODULE glbopt_history !> \param history ... !> \param history_section ... !> \param iw ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE history_init(history, history_section, iw, error) + SUBROUTINE history_init(history, history_section, iw) TYPE(history_type), INTENT(INOUT) :: history TYPE(section_vals_type), POINTER :: history_section INTEGER :: iw - TYPE(cp_error_type), INTENT(inout) :: error ALLOCATE(history%entries(history_grow_unit)) history%iw = iw CALL section_vals_val_get(history_section, "ENERGY_PRECISION",& - r_val=history%E_precision, error=error) + r_val=history%E_precision) CALL section_vals_val_get(history_section, "FINGERPRINT_PRECISION",& - r_val=history%FP_precision,error=error) + r_val=history%FP_precision) IF(iw>0) THEN WRITE (iw,'(A,T66,E15.3)')& diff --git a/src/swarm/glbopt_input.F b/src/swarm/glbopt_input.F index a14e6c0173..174f358202 100644 --- a/src/swarm/glbopt_input.F +++ b/src/swarm/glbopt_input.F @@ -41,12 +41,10 @@ MODULE glbopt_input ! ***************************************************************************** !> \brief Declares the SWARM%GLOBAL_OPT input section !> \param swarm_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE glbopt_declare_input(swarm_section,error) + SUBROUTINE glbopt_declare_input(swarm_section) TYPE(section_type), POINTER :: swarm_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(keyword_type), POINTER :: keyword TYPE(section_type), POINTER :: glbopt_section, printkey @@ -55,7 +53,7 @@ SUBROUTINE glbopt_declare_input(swarm_section,error) CALL section_create(glbopt_section,name="GLOBAL_OPT",& description="Section to control global geometry optimizations.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="METHOD",& description="Methods to use for optimization.",& @@ -63,73 +61,70 @@ SUBROUTINE glbopt_declare_input(swarm_section,error) enum_c_vals=s2a("MINIMA_HOPPING","MINIMA_CRAWLING"),& enum_desc=s2a("Runs Minima-Hopping algorithm.",& "Runs Minima-Crawling algorithm."),& - enum_i_vals=(/glbopt_do_minhop, glbopt_do_mincrawl/),& - error=error) - CALL section_add_keyword(glbopt_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/glbopt_do_minhop, glbopt_do_mincrawl/)) + CALL section_add_keyword(glbopt_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="E_TARGET",& description="Target Energy, the optimization will quit once a lower potential energy is reached.",& - default_r_val=-1*HUGE(1.0_dp),type_of_var=real_t,unit_str="hartree",error=error) - CALL section_add_keyword(glbopt_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=-1*HUGE(1.0_dp),type_of_var=real_t,unit_str="hartree") + CALL section_add_keyword(glbopt_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MD_BUMPS_MAX",& description="Number of bumps in potential energy after which MD runs ends.",& - type_of_var=integer_t,default_i_val=3,error=error) - CALL section_add_keyword(glbopt_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + type_of_var=integer_t,default_i_val=3) + CALL section_add_keyword(glbopt_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BUMP_STEPS_UPWARDS",& description="Number of MD steps with potential energy increases required for a bump.",& - type_of_var=integer_t,default_i_val=2,error=error) - CALL section_add_keyword(glbopt_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + type_of_var=integer_t,default_i_val=2) + CALL section_add_keyword(glbopt_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BUMP_STEPS_DOWNWARDS",& description="Number of MD steps with potential energy decreases required for a bump.",& - type_of_var=integer_t,default_i_val=2,error=error) - CALL section_add_keyword(glbopt_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + type_of_var=integer_t,default_i_val=2) + CALL section_add_keyword(glbopt_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FRAGMENTATION_THRESHOLD",& description="Threshold for atom distance used for detecting fragmentation of clusters.", & - default_r_val=2.0_dp, unit_str="angstrom",type_of_var=real_t,error=error) - CALL section_add_keyword(glbopt_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=2.0_dp, unit_str="angstrom",type_of_var=real_t) + CALL section_add_keyword(glbopt_section, keyword) + CALL keyword_release(keyword) !CALL keyword_create(keyword, name="MD_ADAPTIVE_TIMESTEP",& ! description="Make MD timesteps longer for lower temperatures.", & - ! default_r_val=0.0_dp, type_of_var=real_t,error=error) - !CALL section_add_keyword(glbopt_section, keyword, error=error) - !CALL keyword_release(keyword, error=error) + ! default_r_val=0.0_dp, type_of_var=real_t) + !CALL section_add_keyword(glbopt_section, keyword) + !CALL keyword_release(keyword) CALL cp_print_key_section_create(printkey,"PROGRESS_TRAJECTORY",& description="Printkey to controll the writting of the progress trajectory. "//& "This trajectory contains the minima, which are lower in energy than the by then lowerest.",& print_level=low_print_level, common_iter_levels=1,& - filename="",unit_str="angstrom",error=error) - CALL section_add_subsection(glbopt_section,printkey,error=error) - CALL section_release(printkey,error=error) + filename="",unit_str="angstrom") + CALL section_add_subsection(glbopt_section,printkey) + CALL section_release(printkey) - CALL history_declare_input(glbopt_section, error=error) - CALL minhop_declare_input(glbopt_section, error=error) - CALL mincrawl_declare_input(glbopt_section, error=error) + CALL history_declare_input(glbopt_section) + CALL minhop_declare_input(glbopt_section) + CALL mincrawl_declare_input(glbopt_section) - CALL section_add_subsection(swarm_section, glbopt_section,error=error) - CALL section_release(glbopt_section,error=error) + CALL section_add_subsection(swarm_section, glbopt_section) + CALL section_release(glbopt_section) END SUBROUTINE glbopt_declare_input ! ***************************************************************************** !> \brief Declares the SWARM%GLOBAL_OPT%HISTORY input section !> \param glbopt_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE history_declare_input(glbopt_section,error) + SUBROUTINE history_declare_input(glbopt_section) TYPE(section_type), POINTER :: glbopt_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(keyword_type), POINTER :: keyword TYPE(section_type), POINTER :: history_section @@ -139,36 +134,34 @@ SUBROUTINE history_declare_input(glbopt_section,error) CALL section_create(history_section,name="HISTORY",& description="Section controling the history of visited minima and "//& "how minima are recognized at a later point.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="ENERGY_PRECISION",& description="If the difference of two energies is below this threshold "//& "they are considert equal.", & - default_r_val=1.0e-5_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(history_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=1.0e-5_dp, type_of_var=real_t) + CALL section_add_keyword(history_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FINGERPRINT_PRECISION",& description="If the euclidean distance of two fingerprints is below "//& "this threshold, they are considert equal.", & - default_r_val=1.0e-2_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(history_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=1.0e-2_dp, type_of_var=real_t) + CALL section_add_keyword(history_section, keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(glbopt_section,history_section,error=error) - CALL section_release(history_section,error=error) + CALL section_add_subsection(glbopt_section,history_section) + CALL section_release(history_section) END SUBROUTINE history_declare_input ! ***************************************************************************** !> \brief Declares the SWARM%GLOBAL_OPT%MINIMA_HOPPING input section !> \param glbopt_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE minhop_declare_input(glbopt_section,error) + SUBROUTINE minhop_declare_input(glbopt_section) TYPE(section_type), POINTER :: glbopt_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(keyword_type), POINTER :: keyword TYPE(section_type), POINTER :: minhop_section @@ -178,75 +171,73 @@ SUBROUTINE minhop_declare_input(glbopt_section,error) CALL section_create(minhop_section,name="MINIMA_HOPPING",& description="Section controlling the Minima Hopping method.",& citations=(/Goedecker2004/),& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="BETA_1",& description="Factor used to increase temperature when escape failed, "//& "should be larger than 1.", & - default_r_val=1.1_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(minhop_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=1.1_dp, type_of_var=real_t) + CALL section_add_keyword(minhop_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BETA_2",& description="Factor used to increase temperature when escape found "//& "known minima, should be larger than 1.", & - default_r_val=1.1_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(minhop_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=1.1_dp, type_of_var=real_t) + CALL section_add_keyword(minhop_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="BETA_3",& description="Factor used to decrease temperature when escape succeeded"//& ", should be smaller than 1.", & - default_r_val=1.0/1.1_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(minhop_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=1.0/1.1_dp, type_of_var=real_t) + CALL section_add_keyword(minhop_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA_1",& description="Factor used to decrease acceptance energy, when minima was accepted"//& ", should be smaller than 1.", & - default_r_val=0.98_dp,type_of_var=real_t,error=error) - CALL section_add_keyword(minhop_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=0.98_dp,type_of_var=real_t) + CALL section_add_keyword(minhop_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALPHA_2",& description="Factor used to increase acceptance energy, when minima was rejected"//& ", should be larger than 1.", & - default_r_val=1.0/0.98_dp,type_of_var=real_t,error=error) - CALL section_add_keyword(minhop_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=1.0/0.98_dp,type_of_var=real_t) + CALL section_add_keyword(minhop_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="E_ACCEPT_INIT",& description="Initial value of acceptance energy", & - default_r_val=0.005_dp, type_of_var=real_t,unit_str="hartree",error=error) - CALL section_add_keyword(minhop_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=0.005_dp, type_of_var=real_t,unit_str="hartree") + CALL section_add_keyword(minhop_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE_INIT",& description="Initially temperature in Kelvin", & - default_r_val=100.0_dp,type_of_var=real_t,error=error) - CALL section_add_keyword(minhop_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=100.0_dp,type_of_var=real_t) + CALL section_add_keyword(minhop_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SHARE_HISTORY",& description="If set all worker will use a single share history of visited minima.",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.,error=error) - CALL section_add_keyword(minhop_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(minhop_section,keyword) + CALL keyword_release(keyword) - CALL section_add_subsection(glbopt_section,minhop_section,error=error) - CALL section_release(minhop_section,error=error) + CALL section_add_subsection(glbopt_section,minhop_section) + CALL section_release(minhop_section) END SUBROUTINE minhop_declare_input ! ***************************************************************************** !> \brief Declares the SWARM%GLOBAL_OPT%MINIMA_CRAWLING input section !> \param glbopt_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE mincrawl_declare_input(glbopt_section,error) + SUBROUTINE mincrawl_declare_input(glbopt_section) TYPE(section_type), POINTER :: glbopt_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(keyword_type), POINTER :: keyword TYPE(section_type), POINTER :: mincrawl_section, printkey @@ -255,66 +246,66 @@ SUBROUTINE mincrawl_declare_input(glbopt_section,error) CALL section_create(mincrawl_section,name="MINIMA_CRAWLING",& description="Section controls Minima Crawling run.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="TEMPSTEP_BASE",& description="Base used to calculate temperature steps base**n", & - default_r_val=1.1_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=1.1_dp, type_of_var=real_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPSTEP_MAX",& description="Maximum number of temperature steps.", & - default_i_val=100, type_of_var=integer_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_i_val=100, type_of_var=integer_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPDIST_UPDATE_WIDTH",& description="Width of gaussian used to update temperature distribution.", & - default_r_val=2.0_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=2.0_dp, type_of_var=real_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPDIST_UPDATE_HEIGHT",& description="Height of gaussian used to update temperature distribution.", & - default_r_val=0.1_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=0.1_dp, type_of_var=real_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPERATURE_INIT",& description="Initial temperature in Kelvin", & - default_r_val=100.0_dp,type_of_var=real_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=100.0_dp,type_of_var=real_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="TEMPDIST_INIT_WIDTH",& description="Initial width of temperature distribution.", & - default_r_val=5.0_dp, type_of_var=real_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_r_val=5.0_dp, type_of_var=real_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="WORKER_PER_MINIMA",& description="Maximum number of active workers per Minima.", & - default_i_val=3, type_of_var=integer_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_i_val=3, type_of_var=integer_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ESCAPE_HISTORY_LENGTH",& description="Number of escapes averaged for scoring of minima.", & - default_i_val=10, type_of_var=integer_t,error=error) - CALL section_add_keyword(mincrawl_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + default_i_val=10, type_of_var=integer_t) + CALL section_add_keyword(mincrawl_section, keyword) + CALL keyword_release(keyword) CALL cp_print_key_section_create(printkey,"MINIMA_TRAJECTORY",& description="Printkey to controll the writting of the minima trajectory. "//& "This trajectory contains all encountered local minima.",& print_level=low_print_level, common_iter_levels=1,& - filename="",unit_str="angstrom",error=error) - CALL section_add_subsection(mincrawl_section,printkey,error=error) - CALL section_release(printkey,error=error) + filename="",unit_str="angstrom") + CALL section_add_subsection(mincrawl_section,printkey) + CALL section_release(printkey) - CALL section_add_subsection(glbopt_section,mincrawl_section,error=error) - CALL section_release(mincrawl_section,error=error) + CALL section_add_subsection(glbopt_section,mincrawl_section) + CALL section_release(mincrawl_section) END SUBROUTINE mincrawl_declare_input END MODULE glbopt_input diff --git a/src/swarm/glbopt_master.F b/src/swarm/glbopt_master.F index 81016796fb..cb10d74850 100644 --- a/src/swarm/glbopt_master.F +++ b/src/swarm/glbopt_master.F @@ -78,7 +78,6 @@ MODULE glbopt_master TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set => Null() TYPE(particle_type), DIMENSION(:), POINTER :: particle_set => Null() TYPE(section_vals_type), POINTER :: glbopt_section => Null() - TYPE(cp_error_type) :: error END TYPE glbopt_master_type CONTAINS @@ -91,44 +90,41 @@ MODULE glbopt_master !> \param root_section ... !> \param n_walkers ... !> \param iw ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE glbopt_master_init(this, para_env, root_section, n_walkers, iw, error) + SUBROUTINE glbopt_master_init(this, para_env, root_section, n_walkers, iw) TYPE(glbopt_master_type), INTENT(INOUT) :: this TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: root_section INTEGER, INTENT(IN) :: n_walkers, iw - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) this%iw = iw - this%error = error - this%glbopt_section => section_vals_get_subs_vals(root_section, "SWARM%GLOBAL_OPT", error=error) - CALL section_vals_retain(this%glbopt_section,error=error) + this%glbopt_section => section_vals_get_subs_vals(root_section, "SWARM%GLOBAL_OPT") + CALL section_vals_retain(this%glbopt_section) - CALL section_vals_val_get(this%glbopt_section,"E_TARGET", r_val=this%E_target, error=error) - CALL section_vals_val_get(this%glbopt_section,"METHOD", i_val=this%method, error=error) + CALL section_vals_val_get(this%glbopt_section,"E_TARGET", r_val=this%E_target) + CALL section_vals_val_get(this%glbopt_section,"METHOD", i_val=this%method) - CALL glbopt_read_particle_set(this, para_env, root_section, error) + CALL glbopt_read_particle_set(this, para_env, root_section) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() this%progress_traj_unit = cp_print_key_unit_nr(logger, & this%glbopt_section,"PROGRESS_TRAJECTORY", & middle_name="progress", extension=".xyz", & - file_action="WRITE", file_position="REWIND", error=error) + file_action="WRITE", file_position="REWIND") SELECT CASE (this%method) CASE(glbopt_do_minhop) ALLOCATE(this%minhop) - CALL minhop_init(this%minhop, this%glbopt_section, n_walkers, iw, error) + CALL minhop_init(this%minhop, this%glbopt_section, n_walkers, iw) CASE(glbopt_do_mincrawl) ALLOCATE(this%mincrawl) - CALL mincrawl_init(this%mincrawl, this%glbopt_section, n_walkers, iw, this%particle_set, error) + CALL mincrawl_init(this%mincrawl, this%glbopt_section, n_walkers, iw, this%particle_set) CASE DEFAULT STOP "Unknown glbopt_method" END SELECT @@ -140,14 +136,12 @@ END SUBROUTINE glbopt_master_init !> \param this ... !> \param para_env ... !> \param root_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE glbopt_read_particle_set(this, para_env, root_section, error) + SUBROUTINE glbopt_read_particle_set(this, para_env, root_section) TYPE(glbopt_master_type), INTENT(INOUT) :: this TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -168,8 +162,8 @@ SUBROUTINE glbopt_read_particle_set(this, para_env, root_section, error) NULLIFY(atomic_kind_set, particle_set, molecule_kind_set, molecule_set) NULLIFY(colvar_p, gci, exclusions, force_env_section, subsys_section) - force_env_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL", error=error) - subsys_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL%SUBSYS", error=error) + force_env_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL") + subsys_section => section_vals_get_subs_vals(root_section, "FORCE_EVAL%SUBSYS") CALL topology_control(atomic_kind_set, & @@ -183,17 +177,16 @@ SUBROUTINE glbopt_read_particle_set(this, para_env, root_section, error) force_env_section=force_env_section, & subsys_section=subsys_section, & use_motion_section=.FALSE., & - exclusions=exclusions, & - error=error) + exclusions=exclusions) !This is the only thing we need to write trajectories. this%atomic_kind_set => atomic_kind_set this%particle_set => particle_set - CALL exclusion_release(exclusions, error) - CALL deallocate_molecule_set(molecule_set, error) - CALL deallocate_molecule_kind_set(molecule_kind_set, error) - CALL deallocate_global_constraint(gci, error) - CALL colvar_p_release(colvar_p, error) + CALL exclusion_release(exclusions) + CALL deallocate_molecule_set(molecule_set) + CALL deallocate_molecule_kind_set(molecule_kind_set) + CALL deallocate_global_constraint(gci) + CALL colvar_p_release(colvar_p) END SUBROUTINE glbopt_read_particle_set @@ -307,16 +300,15 @@ SUBROUTINE write_progress_traj(this, report) !get the conversion factor for the length unit CALL section_vals_val_get(this%glbopt_section,"PROGRESS_TRAJECTORY%UNIT",& - c_val=unit_str,error=this%error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=this%error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) CALL write_particle_coordinates(this%particle_set,& iunit=this%progress_traj_unit, & output_format=dump_xmol, & content="POS", & title=TRIM(title), & array=report_positions,& - unit_conv=unit_conv,& - error=this%error) + unit_conv=unit_conv) DEALLOCATE(report_positions) END SUBROUTINE write_progress_traj @@ -344,13 +336,13 @@ SUBROUTINE glbopt_master_finalize(this) STOP "Unknown glbopt_method" END SELECT - logger => cp_error_get_logger(this%error) + logger => cp_get_default_logger() CALL cp_print_key_finished_output(this%progress_traj_unit, logger, & - this%glbopt_section, "PROGRESS_TRAJECTORY", error=this%error) + this%glbopt_section, "PROGRESS_TRAJECTORY") - CALL section_vals_release(this%glbopt_section, error=this%error) - CALL deallocate_particle_set(this%particle_set, this%error) - CALL deallocate_atomic_kind_set(this%atomic_kind_set, this%error) + CALL section_vals_release(this%glbopt_section) + CALL deallocate_particle_set(this%particle_set) + CALL deallocate_atomic_kind_set(this%atomic_kind_set) END SUBROUTINE glbopt_master_finalize diff --git a/src/swarm/glbopt_mincrawl.F b/src/swarm/glbopt_mincrawl.F index 4853169a9a..7c886279a9 100644 --- a/src/swarm/glbopt_mincrawl.F +++ b/src/swarm/glbopt_mincrawl.F @@ -89,7 +89,6 @@ MODULE glbopt_mincrawl TYPE(section_vals_type), POINTER :: mincrawl_section => Null() TYPE(rng_stream_type),POINTER :: rng_stream => Null() TYPE(particle_type), DIMENSION(:), POINTER :: particle_set => Null() - TYPE(cp_error_type) :: error END TYPE mincrawl_type CONTAINS @@ -102,16 +101,14 @@ MODULE glbopt_mincrawl !> \param n_workers ... !> \param iw ... !> \param particle_set ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE mincrawl_init(this, glbopt_section, n_workers, iw, particle_set, error) + SUBROUTINE mincrawl_init(this, glbopt_section, n_workers, iw, particle_set) TYPE(mincrawl_type) :: this TYPE(section_vals_type), POINTER :: glbopt_section INTEGER, INTENT(IN) :: n_workers, iw TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i REAL(kind=dp) :: temp_in_kelvin @@ -121,27 +118,27 @@ SUBROUTINE mincrawl_init(this, glbopt_section, n_workers, iw, particle_set, erro NULLIFY(logger, history_section) ! read input - this%mincrawl_section => section_vals_get_subs_vals(glbopt_section, "MINIMA_CRAWLING", error=error) - CALL section_vals_val_get(this%mincrawl_section,"TEMPSTEP_BASE", r_val=this%tempstep_base,error=error) - CALL section_vals_val_get(this%mincrawl_section,"TEMPSTEP_MAX", i_val=this%tempstep_max,error=error) - CALL section_vals_val_get(this%mincrawl_section,"TEMPDIST_INIT_WIDTH", r_val=this%tempdist_init_width,error=error) - CALL section_vals_val_get(this%mincrawl_section,"TEMPDIST_UPDATE_WIDTH", r_val=this%tempdist_update_width,error=error) - CALL section_vals_val_get(this%mincrawl_section,"TEMPDIST_UPDATE_HEIGHT",r_val=this%tempdist_update_height,error=error) - CALL section_vals_val_get(this%mincrawl_section,"TEMPERATURE_INIT", r_val=temp_in_kelvin,error=error) + this%mincrawl_section => section_vals_get_subs_vals(glbopt_section, "MINIMA_CRAWLING") + CALL section_vals_val_get(this%mincrawl_section,"TEMPSTEP_BASE", r_val=this%tempstep_base) + CALL section_vals_val_get(this%mincrawl_section,"TEMPSTEP_MAX", i_val=this%tempstep_max) + CALL section_vals_val_get(this%mincrawl_section,"TEMPDIST_INIT_WIDTH", r_val=this%tempdist_init_width) + CALL section_vals_val_get(this%mincrawl_section,"TEMPDIST_UPDATE_WIDTH", r_val=this%tempdist_update_width) + CALL section_vals_val_get(this%mincrawl_section,"TEMPDIST_UPDATE_HEIGHT",r_val=this%tempdist_update_height) + CALL section_vals_val_get(this%mincrawl_section,"TEMPERATURE_INIT", r_val=temp_in_kelvin) this%tempstep_init = temp2tempstep(this, temp_in_kelvin / kelvin) - CALL section_vals_val_get(this%mincrawl_section,"WORKER_PER_MINIMA", i_val=this%worker_per_min, error=error) - CALL section_vals_val_get(this%mincrawl_section,"ESCAPE_HISTORY_LENGTH", i_val=this%esc_hist_len, error=error) + CALL section_vals_val_get(this%mincrawl_section,"WORKER_PER_MINIMA", i_val=this%worker_per_min) + CALL section_vals_val_get(this%mincrawl_section,"ESCAPE_HISTORY_LENGTH", i_val=this%esc_hist_len) !init minima trajectory - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() this%minima_traj_unit = cp_print_key_unit_nr(logger, & this%mincrawl_section,"MINIMA_TRAJECTORY", & middle_name="minima", extension=".xyz", & - file_action="WRITE", file_position="REWIND", error=error) + file_action="WRITE", file_position="REWIND") !init history - history_section => section_vals_get_subs_vals(glbopt_section, "HISTORY", error=error) - CALL history_init(this%history, history_section, iw=iw, error=error) + history_section => section_vals_get_subs_vals(glbopt_section, "HISTORY") + CALL history_init(this%history, history_section, iw=iw) !allocate data structures ALLOCATE(this%minimas(1000)) !will be grown if needed @@ -150,7 +147,6 @@ SUBROUTINE mincrawl_init(this, glbopt_section, n_workers, iw, particle_set, erro this%n_workers = n_workers this%iw = iw this%particle_set => particle_set - this%error = error ! call fermi-like stepfunction for initial temp-dist ALLOCATE(this%tempdist_init(this%tempstep_max)) @@ -159,7 +155,7 @@ SUBROUTINE mincrawl_init(this, glbopt_section, n_workers, iw, particle_set, erro this%tempdist_init(i) = 1.0 / (1.0 + EXP((this%tempstep_init - i)/this%tempdist_init_width)) ENDDO - CALL create_rng_stream(this%rng_stream, name="mincrawl", error=this%error) + CALL create_rng_stream(this%rng_stream, name="mincrawl") END SUBROUTINE mincrawl_init @@ -284,10 +280,10 @@ FUNCTION choose_tempstep(this, minima) RESULT(step) REAL(KIND=dp) :: a, r DO - r = next_random_number(this%rng_stream, error=this%error) + r = next_random_number(this%rng_stream) step = INT(r*SIZE(minima%tempdist)) + 1 a = 1.0 - 2.0*ABS(minima%tempdist(step)-0.5) - r = next_random_number(this%rng_stream, error=this%error) + r = next_random_number(this%rng_stream) IF(r < a) EXIT END DO @@ -493,8 +489,8 @@ SUBROUTINE write_minima_traj(this, worker_id, minimum_id, Epot, positions) !get the conversion factor for the length unit CALL section_vals_val_get(this%mincrawl_section,"MINIMA_TRAJECTORY%UNIT",& - c_val=unit_str,error=this%error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=this%error) + c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) CALL write_particle_coordinates(this%particle_set,& iunit=this%minima_traj_unit, & @@ -502,8 +498,7 @@ SUBROUTINE write_minima_traj(this, worker_id, minimum_id, Epot, positions) content="POS", & title=TRIM(title), & array=positions,& - unit_conv=unit_conv,& - error=this%error) + unit_conv=unit_conv) END SUBROUTINE write_minima_traj @@ -525,12 +520,12 @@ SUBROUTINE mincrawl_finalize(this) DEALLOCATE(this%minimas(i)%p) ENDDO - logger => cp_error_get_logger(this%error) + logger => cp_get_default_logger() CALL cp_print_key_finished_output(this%minima_traj_unit, logger, & - this%mincrawl_section, "MINIMA_TRAJECTORY", error=this%error) + this%mincrawl_section, "MINIMA_TRAJECTORY") CALL history_finalize(this%history) - CALL delete_rng_stream(this%rng_stream, error=this%error) + CALL delete_rng_stream(this%rng_stream) END SUBROUTINE mincrawl_finalize diff --git a/src/swarm/glbopt_minhop.F b/src/swarm/glbopt_minhop.F index 74329853a2..7fb71871df 100644 --- a/src/swarm/glbopt_minhop.F +++ b/src/swarm/glbopt_minhop.F @@ -94,14 +94,12 @@ MODULE glbopt_minhop !> \param glbopt_section ... !> \param n_workers ... !> \param iw ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE minhop_init(this, glbopt_section, n_workers, iw, error) + SUBROUTINE minhop_init(this, glbopt_section, n_workers, iw) TYPE(minhop_type) :: this TYPE(section_vals_type), POINTER :: glbopt_section INTEGER, INTENT(IN) :: n_workers, iw - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i, n_histories REAL(kind=dp) :: temp_in_kelvin @@ -111,27 +109,27 @@ SUBROUTINE minhop_init(this, glbopt_section, n_workers, iw, error) CALL cite_reference(Goedecker2004) ! read input - minhop_section => section_vals_get_subs_vals(glbopt_section, "MINIMA_HOPPING", error=error) - CALL section_vals_val_get(minhop_section,"BETA_1", r_val=this%beta1,error=error) - CALL section_vals_val_get(minhop_section,"BETA_2", r_val=this%beta2,error=error) - CALL section_vals_val_get(minhop_section,"BETA_3", r_val=this%beta3,error=error) - CALL section_vals_val_get(minhop_section,"ALPHA_1", r_val=this%alpha1,error=error) - CALL section_vals_val_get(minhop_section,"ALPHA_2", r_val=this%alpha2,error=error) - CALL section_vals_val_get(minhop_section,"E_ACCEPT_INIT", r_val=this%Eaccept0,error=error) - CALL section_vals_val_get(minhop_section,"TEMPERATURE_INIT", r_val=temp_in_kelvin,error=error) + minhop_section => section_vals_get_subs_vals(glbopt_section, "MINIMA_HOPPING") + CALL section_vals_val_get(minhop_section,"BETA_1", r_val=this%beta1) + CALL section_vals_val_get(minhop_section,"BETA_2", r_val=this%beta2) + CALL section_vals_val_get(minhop_section,"BETA_3", r_val=this%beta3) + CALL section_vals_val_get(minhop_section,"ALPHA_1", r_val=this%alpha1) + CALL section_vals_val_get(minhop_section,"ALPHA_2", r_val=this%alpha2) + CALL section_vals_val_get(minhop_section,"E_ACCEPT_INIT", r_val=this%Eaccept0) + CALL section_vals_val_get(minhop_section,"TEMPERATURE_INIT", r_val=temp_in_kelvin) this%temp_init = temp_in_kelvin / kelvin - CALL section_vals_val_get(minhop_section,"SHARE_HISTORY", l_val=this%share_history,error=error) + CALL section_vals_val_get(minhop_section,"SHARE_HISTORY", l_val=this%share_history) ! allocate history / histories - history_section => section_vals_get_subs_vals(glbopt_section, "HISTORY", error=error) + history_section => section_vals_get_subs_vals(glbopt_section, "HISTORY") n_histories = n_workers IF(this%share_history) n_histories = 1 ALLOCATE(this%history(n_histories)) !only the first history shall write to iw - CALL history_init(this%history(1), history_section, iw=iw, error=error) + CALL history_init(this%history(1), history_section, iw=iw) DO i=2, n_histories - CALL history_init(this%history(i), history_section, iw=-1, error=error) + CALL history_init(this%history(i), history_section, iw=-1) END DO ALLOCATE(this%worker_state(n_workers)) diff --git a/src/swarm/glbopt_worker.F b/src/swarm/glbopt_worker.F index f61f04fb32..3676df5c46 100644 --- a/src/swarm/glbopt_worker.F +++ b/src/swarm/glbopt_worker.F @@ -53,7 +53,6 @@ MODULE glbopt_worker PRIVATE INTEGER :: id INTEGER :: iw - TYPE(cp_error_type) :: error INTEGER :: f_env_id TYPE(f_env_type), POINTER :: f_env TYPE(force_env_type), POINTER :: force_env @@ -82,18 +81,16 @@ MODULE glbopt_worker !> \param input_path ... !> \param worker_id ... !> \param iw ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** SUBROUTINE glbopt_worker_init(worker, input_declaration, para_env, root_section,& - input_path, worker_id, iw, error) + input_path, worker_id, iw) TYPE(glbopt_worker_type), INTENT(INOUT) :: worker TYPE(section_type), POINTER :: input_declaration TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: root_section CHARACTER(LEN=*), INTENT(IN) :: input_path INTEGER, INTENT(in) :: worker_id, iw - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: i LOGICAL :: failure @@ -103,7 +100,6 @@ SUBROUTINE glbopt_worker_init(worker, input_declaration, para_env, root_section, failure = .FALSE. - worker%error = error worker%root_section => root_section worker%id = worker_id worker%iw = iw @@ -118,27 +114,27 @@ SUBROUTINE glbopt_worker_init(worker, input_declaration, para_env, root_section, ! ======= More setup stuff ======= - CALL f_env_add_defaults(worker%f_env_id, worker%f_env, worker%error, failure) + CALL f_env_add_defaults(worker%f_env_id, worker%f_env,failure) IF(failure) STOP "glbopt_drive_worker: f_env_add_defaults failed" worker%force_env => worker%f_env%force_env - CALL force_env_get(worker%force_env, globenv=worker%globenv, subsys=worker%subsys, error=worker%error) + CALL force_env_get(worker%force_env, globenv=worker%globenv, subsys=worker%subsys) ! We want different random-number-streams for each worker DO i = 1, worker_id - CALL reset_to_next_rng_substream(worker%globenv%gaussian_rng_stream, worker%error) + CALL reset_to_next_rng_substream(worker%globenv%gaussian_rng_stream) END DO - CALL cp_subsys_get(worker%subsys, natom=worker%n_atoms, error=worker%error) + CALL cp_subsys_get(worker%subsys, natom=worker%n_atoms) ! fetch original value from input - CALL section_vals_val_get(root_section, "MOTION%GEO_OPT%MAX_ITER", i_val=worker%gopt_max_iter, error=worker%error) - glbopt_section => section_vals_get_subs_vals(root_section, "SWARM%GLOBAL_OPT", error=error) - - CALL section_vals_val_get(glbopt_section,"BUMP_STEPS_UPWARDS", i_val=worker%bump_steps_upwards, error=error) - CALL section_vals_val_get(glbopt_section,"BUMP_STEPS_DOWNWARDS", i_val=worker%bump_steps_downwards, error=error) - CALL section_vals_val_get(glbopt_section,"MD_BUMPS_MAX", i_val=worker%md_bumps_max, error=error) - CALL section_vals_val_get(glbopt_section,"FRAGMENTATION_THRESHOLD", r_val=dist_in_angstrom, error=error) - !CALL section_vals_val_get(glbopt_section,"MD_ADAPTIVE_TIMESTEP", r_val=worker%adaptive_timestep, error=error) + CALL section_vals_val_get(root_section, "MOTION%GEO_OPT%MAX_ITER", i_val=worker%gopt_max_iter) + glbopt_section => section_vals_get_subs_vals(root_section, "SWARM%GLOBAL_OPT") + + CALL section_vals_val_get(glbopt_section,"BUMP_STEPS_UPWARDS", i_val=worker%bump_steps_upwards) + CALL section_vals_val_get(glbopt_section,"BUMP_STEPS_DOWNWARDS", i_val=worker%bump_steps_downwards) + CALL section_vals_val_get(glbopt_section,"MD_BUMPS_MAX", i_val=worker%md_bumps_max) + CALL section_vals_val_get(glbopt_section,"FRAGMENTATION_THRESHOLD", r_val=dist_in_angstrom) + !CALL section_vals_val_get(glbopt_section,"MD_ADAPTIVE_TIMESTEP", r_val=worker%adaptive_timestep) worker%fragmentation_threshold = dist_in_angstrom/angstrom END SUBROUTINE glbopt_worker_init @@ -193,7 +189,7 @@ SUBROUTINE run_mdgopt(worker, cmd, report) CALL swarm_message_get(cmd, "iframe", iframe) IF(iframe > 1) THEN CALL swarm_message_get(cmd, "positions", positions) - CALL unpack_subsys_particles(worker%subsys, r=positions, error=worker%error) + CALL unpack_subsys_particles(worker%subsys, r=positions) ENDIF ! setup mdctrl callback @@ -213,15 +209,15 @@ SUBROUTINE run_mdgopt(worker, cmd, report) ! timestep = 4.0 * ( boltz - 1.0 ) / boltz / femtoseconds ! !timestep = 0.01_dp / femtoseconds ! !timestep = SQRT(MIN(0.5, 2.0/(1+exp(-300.0/(temperature*kelvin))))) / femtoseconds - ! CALL section_vals_val_set(worker%root_section, "MOTION%MD%TIMESTEP", r_val=timestep, error=worker%error) + ! CALL section_vals_val_set(worker%root_section, "MOTION%MD%TIMESTEP", r_val=timestep) ! IF(worker%iw>0)& ! WRITE (worker%iw,'(A,35X,F20.3)') ' GLBOPT| MD timestep [fs]',timestep*femtoseconds !ENDIF prev_iframe = iframe IF(iframe==0) iframe = 1 ! qs_mol_dyn behaves differently for STEP_START_VAL=0 - CALL section_vals_val_set(worker%root_section, "MOTION%MD%STEP_START_VAL", i_val=iframe-1, error=worker%error) - CALL section_vals_val_set(worker%root_section, "MOTION%MD%TEMPERATURE", r_val=temperature, error=worker%error) + CALL section_vals_val_set(worker%root_section, "MOTION%MD%STEP_START_VAL", i_val=iframe-1) + CALL section_vals_val_set(worker%root_section, "MOTION%MD%TEMPERATURE", r_val=temperature) IF (worker%iw>0) THEN WRITE (worker%iw,'(A,33X,F20.3)') ' GLBOPT| MD temperature [K]',temperature*kelvin @@ -229,7 +225,7 @@ SUBROUTINE run_mdgopt(worker, cmd, report) END IF ! run MD - CALL qs_mol_dyn(worker%force_env, worker%globenv, mdctrl=mdctrl_p, error=worker%error) + CALL qs_mol_dyn(worker%force_env, worker%globenv, mdctrl=mdctrl_p) iframe = mdctrl_data%itimes + 1 md_steps = iframe - prev_iframe @@ -237,32 +233,32 @@ SUBROUTINE run_mdgopt(worker, cmd, report) ! fix fragmentation IF(.NOT. ASSOCIATED(positions)) ALLOCATE(positions(3*worker%n_atoms)) - CALL pack_subsys_particles(worker%subsys, r=positions, error=worker%error) + CALL pack_subsys_particles(worker%subsys, r=positions) n_fragments=0 DO n_fragments=n_fragments+1 IF(fix_fragmentation(positions, worker%fragmentation_threshold)) EXIT END DO - CALL unpack_subsys_particles(worker%subsys, r=positions, error=worker%error) + CALL unpack_subsys_particles(worker%subsys, r=positions) IF (n_fragments>0 .AND. worker%iw>0)& WRITE (worker%iw,'(A,13X,I10)') " GLBOPT| Ran fix_fragmentation times:", n_fragments ! setup geometry optimization IF (worker%iw>0) WRITE (worker%iw,'(A,13X,I10)') " GLBOPT| Starting local optimisation at trajectory frame ", iframe - CALL section_vals_val_set(worker%root_section, "MOTION%GEO_OPT%STEP_START_VAL", i_val=iframe-1, error=worker%error) + CALL section_vals_val_set(worker%root_section, "MOTION%GEO_OPT%STEP_START_VAL", i_val=iframe-1) CALL section_vals_val_set(worker%root_section, "MOTION%GEO_OPT%MAX_ITER",& - i_val=iframe+worker%gopt_max_iter, error=worker%error) + i_val=iframe+worker%gopt_max_iter) ! run geometry optimization - CALL cp_geo_opt(worker%force_env, worker%globenv, rm_restart_info=.FALSE., error=worker%error) + CALL cp_geo_opt(worker%force_env, worker%globenv, rm_restart_info=.FALSE.) prev_iframe = iframe - CALL section_vals_val_get(worker%root_section, "MOTION%GEO_OPT%STEP_START_VAL", i_val=iframe, error=worker%error) + CALL section_vals_val_get(worker%root_section, "MOTION%GEO_OPT%STEP_START_VAL", i_val=iframe) iframe = iframe + 2 ! Compensates for different START_VAL interpretation. gopt_steps = iframe - prev_iframe -1 IF (worker%iw>0) WRITE (worker%iw,'(A,I4,A)') " GLBOPT| gopt ended after ", gopt_steps, " steps." - CALL force_env_get(worker%force_env, potential_energy=Epot, error=worker%error) + CALL force_env_get(worker%force_env, potential_energy=Epot) IF (worker%iw>0) WRITE (worker%iw,'(A,25X,E20.10)')' GLBOPT| Potential Energy [Hartree]',Epot ! assemble report @@ -270,7 +266,7 @@ SUBROUTINE run_mdgopt(worker, cmd, report) CALL swarm_message_add(report, "iframe", iframe) CALL swarm_message_add(report, "md_steps", md_steps) CALL swarm_message_add(report, "gopt_steps", gopt_steps) - CALL pack_subsys_particles(worker%subsys, r=positions, error=worker%error) + CALL pack_subsys_particles(worker%subsys, r=positions) CALL swarm_message_add(report, "positions", positions) DEALLOCATE(positions) @@ -388,7 +384,7 @@ SUBROUTINE glbopt_worker_finalize(worker) INTEGER :: ierr - CALL f_env_rm_defaults(worker%f_env, worker%error) + CALL f_env_rm_defaults(worker%f_env) CALL destroy_force_env(worker%f_env_id, ierr) IF(ierr /= 0) STOP "glbopt_worker_finalize: destroy_force_env failed" END SUBROUTINE glbopt_worker_finalize diff --git a/src/swarm/swarm.F b/src/swarm/swarm.F index 65c9036211..3321bb26e4 100644 --- a/src/swarm/swarm.F +++ b/src/swarm/swarm.F @@ -55,16 +55,14 @@ MODULE swarm !> \param para_env ... !> \param globenv ... !> \param input_path ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE run_swarm(input_declaration, root_section, para_env, globenv, input_path, error) + SUBROUTINE run_swarm(input_declaration, root_section, para_env, globenv, input_path) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv CHARACTER(LEN=*), INTENT(IN) :: input_path - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'run_swarm', & routineP = moduleN//':'//routineN @@ -74,22 +72,22 @@ SUBROUTINE run_swarm(input_declaration, root_section, para_env, globenv, input_p CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,root_section,& - "SWARM%PRINT%MASTER_RUN_INFO",extension=".masterLog",error=error) + "SWARM%PRINT%MASTER_RUN_INFO",extension=".masterLog") IF(iw > 0) WRITE(iw,"(A)") " SWARM| Ready to roll :-)" CALL section_vals_val_get(root_section,"SWARM%NUMBER_OF_WORKERS",& - i_val=n_workers,error=error) + i_val=n_workers) IF(n_workers==1 .AND. para_env%num_pe==1) THEN IF(iw > 0) WRITE(iw,"(A)") " SWARM| Running in single worker mode." - CALL swarm_serial_driver(input_declaration, root_section, input_path, para_env, globenv, error) + CALL swarm_serial_driver(input_declaration, root_section, input_path, para_env, globenv) ELSE IF(iw > 0) WRITE(iw,"(A)") " SWARM| Running in master / workers mode." !printkey iw passed on for output from swarm_mpi_init() - CALL swarm_parallel_driver(n_workers, input_declaration, root_section, input_path, para_env, globenv, iw, error) + CALL swarm_parallel_driver(n_workers, input_declaration, root_section, input_path, para_env, globenv, iw) ENDIF CALL timestop(handle) @@ -103,16 +101,14 @@ END SUBROUTINE run_swarm !> \param input_path ... !> \param para_env ... !> \param globenv ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_serial_driver(input_declaration, root_section, input_path, para_env, globenv, error) + SUBROUTINE swarm_serial_driver(input_declaration, root_section, input_path, para_env, globenv) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section CHARACTER(LEN=*), INTENT(IN) :: input_path TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: handle LOGICAL :: should_stop @@ -120,9 +116,9 @@ SUBROUTINE swarm_serial_driver(input_declaration, root_section, input_path, para TYPE(swarm_message_type) :: cmd, report TYPE(swarm_worker_type) :: worker - CALL swarm_master_init(master, para_env, globenv, root_section, n_workers=1, error=error) + CALL swarm_master_init(master, para_env, globenv, root_section, n_workers=1) CALL swarm_worker_init(worker, para_env, input_declaration, root_section, & - input_path, worker_id=1, error=error) + input_path, worker_id=1) CALL swarm_message_add(report, "worker_id", 1) CALL swarm_message_add(report, "status", "initial_hello") @@ -153,10 +149,9 @@ END SUBROUTINE swarm_serial_driver !> \param para_env ... !> \param globenv ... !> \param iw ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_parallel_driver(n_workers, input_declaration, root_section, input_path, para_env, globenv, iw, error) + SUBROUTINE swarm_parallel_driver(n_workers, input_declaration, root_section, input_path, para_env, globenv, iw) INTEGER, INTENT(IN) :: n_workers TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section @@ -164,20 +159,19 @@ SUBROUTINE swarm_parallel_driver(n_workers, input_declaration, root_section, inp TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: worker_id TYPE(swarm_mpi_type) :: swarm_mpi - CALL swarm_mpi_init(swarm_mpi, para_env, root_section, n_workers, worker_id, iw, error=error) + CALL swarm_mpi_init(swarm_mpi, para_env, root_section, n_workers, worker_id, iw) IF(ASSOCIATED(swarm_mpi%worker)) THEN - CALL swarm_parallel_worker_driver(swarm_mpi, input_declaration, worker_id, root_section, input_path, error) + CALL swarm_parallel_worker_driver(swarm_mpi, input_declaration, worker_id, root_section, input_path) ELSE - CALL swarm_parallel_master_driver(swarm_mpi, n_workers, root_section, globenv, error) + CALL swarm_parallel_master_driver(swarm_mpi, n_workers, root_section, globenv) END IF - CALL swarm_mpi_finalize(swarm_mpi, root_section, error) + CALL swarm_mpi_finalize(swarm_mpi, root_section) END SUBROUTINE swarm_parallel_driver @@ -189,16 +183,14 @@ END SUBROUTINE swarm_parallel_driver !> \param worker_id ... !> \param root_section ... !> \param input_path ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_parallel_worker_driver(swarm_mpi, input_declaration, worker_id, root_section, input_path, error) + SUBROUTINE swarm_parallel_worker_driver(swarm_mpi, input_declaration, worker_id, root_section, input_path) TYPE(swarm_mpi_type), INTENT(IN) :: swarm_mpi TYPE(section_type), POINTER :: input_declaration INTEGER, INTENT(IN) :: worker_id TYPE(section_vals_type), POINTER :: root_section CHARACTER(LEN=*), INTENT(IN) :: input_path - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: handle LOGICAL :: should_stop @@ -206,7 +198,7 @@ SUBROUTINE swarm_parallel_worker_driver(swarm_mpi, input_declaration, worker_id, TYPE(swarm_worker_type) :: worker CALL swarm_worker_init(worker, swarm_mpi%worker, input_declaration, & - root_section, input_path, worker_id=worker_id, error=error) + root_section, input_path, worker_id=worker_id) CALL swarm_message_add(report, "worker_id", worker_id) CALL swarm_message_add(report, "status", "initial_hello") @@ -234,15 +226,13 @@ END SUBROUTINE swarm_parallel_worker_driver !> \param n_workers ... !> \param root_section ... !> \param globenv ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_parallel_master_driver(swarm_mpi, n_workers, root_section, globenv, error) + SUBROUTINE swarm_parallel_master_driver(swarm_mpi, n_workers, root_section, globenv) TYPE(swarm_mpi_type), INTENT(IN) :: swarm_mpi INTEGER, INTENT(IN) :: n_workers TYPE(section_vals_type), POINTER :: root_section TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=default_string_length) :: command INTEGER :: i_shutdowns, j, wid @@ -252,7 +242,7 @@ SUBROUTINE swarm_parallel_master_driver(swarm_mpi, n_workers, root_section, glob is_waiting(:) = .FALSE. - CALL swarm_master_init(master, swarm_mpi%master, globenv, root_section, n_workers, error) + CALL swarm_master_init(master, swarm_mpi%master, globenv, root_section, n_workers) i_shutdowns = 0 j = 0 diff --git a/src/swarm/swarm_input.F b/src/swarm/swarm_input.F index a567e4c903..b4397cc700 100644 --- a/src/swarm/swarm_input.F +++ b/src/swarm/swarm_input.F @@ -38,12 +38,10 @@ MODULE swarm_input ! ***************************************************************************** !> \brief Declares the SWARM input section !> \param swarm_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE create_swarm_section(swarm_section,error) + SUBROUTINE create_swarm_section(swarm_section) TYPE(section_type), POINTER :: swarm_section - TYPE(cp_error_type), INTENT(inout) :: error TYPE(keyword_type), POINTER :: keyword TYPE(section_type), POINTER :: print_section, printkey @@ -53,7 +51,7 @@ SUBROUTINE create_swarm_section(swarm_section,error) CALL section_create(swarm_section,name="SWARM",& description="Section to control swarm runs. "//& "The swarm framework provides a common ground for master/worker algorithms.",& - repeats=.FALSE., error=error) + repeats=.FALSE.) CALL keyword_create(keyword, name="BEHAVIOR",& description="Which behaviour should control the swarm.",& @@ -61,63 +59,59 @@ SUBROUTINE create_swarm_section(swarm_section,error) default_i_val=swarm_do_glbopt,& enum_c_vals=s2a("GLOBAL_OPT"),& enum_desc=s2a("Runs global geometry optimisation"),& - enum_i_vals=(/swarm_do_glbopt/),& - error=error) - CALL section_add_keyword(swarm_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + enum_i_vals=(/swarm_do_glbopt/)) + CALL section_add_keyword(swarm_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NUMBER_OF_WORKERS",& description="Number of workers used for swarm. "//& "Of the total number of processors one is used for the master, "//& "the remaining processors should be divisible by the number of workers.",& - type_of_var=integer_t,error=error) - CALL section_add_keyword(swarm_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + type_of_var=integer_t) + CALL section_add_keyword(swarm_section, keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="REPLAY_COMMUNICATION_LOG",& description="Filename of communication log of previous run. Use this to restart a swarm.",& repeats=.FALSE.,& - usage="REPLAY_COMMUNICATION_LOG ", default_lc_val="swarm_translog_replay.xyz", & - error=error) - CALL section_add_keyword(swarm_section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="REPLAY_COMMUNICATION_LOG ", default_lc_val="swarm_translog_replay.xyz") + CALL section_add_keyword(swarm_section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="MAX_ITER",& description="The maximum number iterations the master should perform",& - type_of_var=integer_t,default_i_val=HUGE(1),error=error) - CALL section_add_keyword(swarm_section, keyword, error=error) - CALL keyword_release(keyword, error=error) + type_of_var=integer_t,default_i_val=HUGE(1)) + CALL section_add_keyword(swarm_section, keyword) + CALL keyword_release(keyword) CALL section_create(print_section,name="PRINT",& description="Controls the printing properties during a global optimization run",& - n_keywords=0, n_subsections=1, repeats=.TRUE., error=error) + n_keywords=0, n_subsections=1, repeats=.TRUE.) CALL cp_print_key_section_create(printkey,"WORKER_RUN_INFO",& description="Controls the printing of the worker's basic information during the global optimization", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(print_section,printkey,error=error) - CALL section_release(printkey,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(print_section,printkey) + CALL section_release(printkey) CALL cp_print_key_section_create(printkey,"MASTER_RUN_INFO",& description="Controls the printing of the masters's basic information during the global optimization", & - print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__",& - error=error) - CALL section_add_subsection(print_section,printkey,error=error) - CALL section_release(printkey,error=error) + print_level=low_print_level,add_last=add_last_numeric,filename="__STD_OUT__") + CALL section_add_subsection(print_section,printkey) + CALL section_release(printkey) CALL cp_print_key_section_create(printkey,"COMMUNICATION_LOG",& description="Log all the communication between workers and master. Needed for restart.",& print_level=low_print_level, common_iter_levels=1,& - filename="",unit_str="angstrom",error=error) - CALL section_add_subsection(print_section,printkey,error=error) - CALL section_release(printkey,error=error) + filename="",unit_str="angstrom") + CALL section_add_subsection(print_section,printkey) + CALL section_release(printkey) - CALL section_add_subsection(swarm_section,print_section,error=error) - CALL section_release(print_section,error=error) + CALL section_add_subsection(swarm_section,print_section) + CALL section_release(print_section) - CALL glbopt_declare_input(swarm_section, error) + CALL glbopt_declare_input(swarm_section) END SUBROUTINE create_swarm_section diff --git a/src/swarm/swarm_master.F b/src/swarm/swarm_master.F index a197d6f819..49db2a7fde 100644 --- a/src/swarm/swarm_master.F +++ b/src/swarm/swarm_master.F @@ -64,7 +64,6 @@ MODULE swarm_master LOGICAL :: should_stop = .FALSE. INTEGER :: n_workers = -1 INTEGER :: comlog_unit - TYPE(cp_error_type) :: error TYPE(section_vals_type), POINTER :: swarm_section => Null() TYPE(cp_para_env_type), POINTER :: para_env => Null() TYPE(swarm_message_p_type), DIMENSION(:), POINTER :: queued_commands => Null() @@ -84,44 +83,41 @@ MODULE swarm_master !> \param globenv ... !> \param root_section ... !> \param n_workers ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_master_init(master, para_env, globenv, root_section, n_workers, error) + SUBROUTINE swarm_master_init(master, para_env, globenv, root_section, n_workers) TYPE(swarm_master_type) :: master TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv TYPE(section_vals_type), POINTER :: root_section INTEGER, INTENT(IN) :: n_workers - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_logger_type), POINTER :: logger - master%swarm_section => section_vals_get_subs_vals(root_section, "SWARM", error=error) + master%swarm_section => section_vals_get_subs_vals(root_section, "SWARM") - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() master%n_workers = n_workers - master%error = error master%para_env => para_env master%globenv => globenv ALLOCATE(master%queued_commands(master%n_workers)) master%iw = cp_print_key_unit_nr(logger, master%swarm_section,& - "PRINT%MASTER_RUN_INFO",extension=".masterLog",error=error) + "PRINT%MASTER_RUN_INFO",extension=".masterLog") - CALL section_vals_val_get(master%swarm_section,"BEHAVIOR", i_val=master%behavior, error=error) + CALL section_vals_val_get(master%swarm_section,"BEHAVIOR", i_val=master%behavior) ! uses logger%iter_info%project_name to construct filename master%comlog_unit = cp_print_key_unit_nr(logger,master%swarm_section,"PRINT%COMMUNICATION_LOG",& !middle_name="comlog", extension=".xyz", & extension=".comlog", & - file_action="WRITE", file_position="REWIND", error=error) + file_action="WRITE", file_position="REWIND") - CALL section_vals_val_get(master%swarm_section,"MAX_ITER", i_val=master%max_iter, error=error) + CALL section_vals_val_get(master%swarm_section,"MAX_ITER", i_val=master%max_iter) SELECT CASE(master%behavior) CASE(swarm_do_glbopt) ALLOCATE(master%glbopt) - CALL glbopt_master_init(master%glbopt, para_env, root_section, n_workers, master%iw, error) + CALL glbopt_master_init(master%glbopt, para_env, root_section, n_workers, master%iw) CASE DEFAULT STOP "swarm_master_init: got unknown behavior" END SELECT @@ -152,21 +148,21 @@ SUBROUTINE replay_comlog(master) ! Initialize parser for trajectory CALL section_vals_val_get(master%swarm_section,"REPLAY_COMMUNICATION_LOG",& - c_val=filename, explicit=explicit, error=master%error) + c_val=filename, explicit=explicit) IF(.NOT. explicit) RETURN IF(master%iw>0) WRITE(master%iw,'(A,A)') & " SWARM| Starting replay of communication-log: ", TRIM(filename) CALL timeset("swarm_master_replay_comlog", handle) - CALL parser_create(parser, filename, para_env=master%para_env, error=master%error) + CALL parser_create(parser, filename, para_env=master%para_env) at_end = .FALSE. DO - CALL swarm_message_file_read(report_log, parser, at_end, master%error) + CALL swarm_message_file_read(report_log, parser, at_end) IF(at_end) EXIT - CALL swarm_message_file_read(cmd_log, parser, at_end, master%error) + CALL swarm_message_file_read(cmd_log, parser, at_end) IF(at_end) EXIT ALLOCATE(cmd_now) @@ -197,7 +193,7 @@ SUBROUTINE replay_comlog(master) master%queued_commands(i)%p = last_commands(i) END DO - CALL parser_release(parser, error=master%error) + CALL parser_release(parser) CALL timestop(handle) END SUBROUTINE replay_comlog @@ -273,7 +269,7 @@ SUBROUTINE swarm_master_steer(master, report, cmd) ENDIF IF(.NOT. master%should_stop) THEN - CALL external_control(master%should_stop,"SWARM",master%globenv,error=master%error) + CALL external_control(master%should_stop,"SWARM",master%globenv) IF(master%should_stop .AND. master%iw>0) & WRITE (master%iw, *) " SWARM| Received stop from external_control. Quitting." END IF @@ -347,11 +343,11 @@ SUBROUTINE swarm_master_finalize(master) DEALLOCATE(master%queued_commands) - logger => cp_error_get_logger(master%error) + logger => cp_get_default_logger() CALL cp_print_key_finished_output(master%iw, logger,& - master%swarm_section, "PRINT%MASTER_RUN_INFO", error=master%error) + master%swarm_section, "PRINT%MASTER_RUN_INFO") CALL cp_print_key_finished_output(master%comlog_unit, logger,& - master%swarm_section, "PRINT%COMMUNICATION_LOG", error=master%error) + master%swarm_section, "PRINT%COMMUNICATION_LOG") !CALL rm_timer_env() !pops the top-most timer END SUBROUTINE swarm_master_finalize diff --git a/src/swarm/swarm_message.F b/src/swarm/swarm_message.F index 39a0ca6a00..be5577f61c 100644 --- a/src/swarm/swarm_message.F +++ b/src/swarm/swarm_message.F @@ -308,19 +308,17 @@ END SUBROUTINE swarm_message_file_write !> \param msg ... !> \param parser ... !> \param at_end ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_message_file_read(msg, parser, at_end, error) + SUBROUTINE swarm_message_file_read(msg, parser, at_end) TYPE(swarm_message_type), INTENT(OUT) :: msg TYPE(cp_parser_type), POINTER :: parser LOGICAL, INTENT(INOUT) :: at_end - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: handle CALL timeset("swarm_message_file_read", handle) - CALL swarm_message_file_read_low(msg, parser, at_end, error) + CALL swarm_message_file_read_low(msg, parser, at_end) CALL timestop(handle) END SUBROUTINE swarm_message_file_read @@ -330,14 +328,12 @@ END SUBROUTINE swarm_message_file_read !> \param msg ... !> \param parser ... !> \param at_end ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_message_file_read_low(msg, parser, at_end, error) + SUBROUTINE swarm_message_file_read_low(msg, parser, at_end) TYPE(swarm_message_type), INTENT(OUT) :: msg TYPE(cp_parser_type), POINTER :: parser LOGICAL, INTENT(INOUT) :: at_end - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=20) :: label INTEGER :: i, length @@ -345,12 +341,12 @@ SUBROUTINE swarm_message_file_read_low(msg, parser, at_end, error) !IF(ASSOCIATED(msg%root)) STOP "swarm_message_file_read: message not empty" - CALL parser_get_next_line(parser, 1, at_end, error) + CALL parser_get_next_line(parser, 1, at_end) at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10))==0 IF(at_end) RETURN IF(TRIM(parser%input_line(1:20))/="BEGIN SWARM_MESSAGE") STOP "swarm_message_file_read failed (1)" - CALL parser_get_next_line(parser, 1, at_end, error) + CALL parser_get_next_line(parser, 1, at_end) at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10))==0 IF(at_end) RETURN READ (parser%input_line(1:40),*) label, length @@ -358,12 +354,12 @@ SUBROUTINE swarm_message_file_read_low(msg, parser, at_end, error) DO i=1, length ALLOCATE(new_entry) - CALL swarm_message_entry_file_read(new_entry, parser, at_end, error) + CALL swarm_message_entry_file_read(new_entry, parser, at_end) new_entry%next => msg%root msg%root => new_entry END DO - CALL parser_get_next_line(parser, 1, at_end, error) + CALL parser_get_next_line(parser, 1, at_end) at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10))==0 IF(at_end) RETURN IF(TRIM(parser%input_line(1:20))/="END SWARM_MESSAGE") STOP "swarm_message_file_read failed (3)" @@ -744,32 +740,30 @@ END SUBROUTINE swarm_message_entry_file_write !> \param ENTRY ... !> \param parser ... !> \param at_end ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_message_entry_file_read(ENTRY, parser, at_end, error) + SUBROUTINE swarm_message_entry_file_read(ENTRY, parser, at_end) TYPE(message_entry_type), INTENT(INOUT) :: ENTRY TYPE(cp_parser_type), POINTER :: parser LOGICAL, INTENT(INOUT) :: at_end - TYPE(cp_error_type) :: error CHARACTER(LEN=15) :: datatype, label INTEGER :: arr_size, i LOGICAL :: is_scalar - CALL parser_get_next_line(parser, 1, at_end, error) + CALL parser_get_next_line(parser, 1, at_end) at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10))==0 IF(at_end) RETURN READ (parser%input_line(1:key_length+10),*) label, entry%key IF(TRIM(label)/="key:") STOP "swarm_message_entry_file_read failed (1)" - CALL parser_get_next_line(parser, 1, at_end, error) + CALL parser_get_next_line(parser, 1, at_end) at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10))==0 IF(at_end) RETURN READ (parser%input_line(1:30),*) label, datatype IF(TRIM(label)/="datatype:") STOP "swarm_message_entry_file_read failed (2)" - CALL parser_get_next_line(parser, 1, at_end, error) + CALL parser_get_next_line(parser, 1, at_end) at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10))==0 IF(at_end) RETURN @@ -817,7 +811,7 @@ SUBROUTINE swarm_message_entry_file_read(ENTRY, parser, at_end, error) END SELECT DO i=1, arr_size - CALL parser_get_next_line(parser, 1, at_end, error) + CALL parser_get_next_line(parser, 1, at_end) at_end = at_end .OR. LEN_TRIM(parser%input_line(1:10))==0 IF(at_end) RETURN diff --git a/src/swarm/swarm_mpi.F b/src/swarm/swarm_mpi.F index b32f5d4ba2..d5b7e7fdbc 100644 --- a/src/swarm/swarm_mpi.F +++ b/src/swarm/swarm_mpi.F @@ -65,17 +65,15 @@ MODULE swarm_mpi !> \param n_workers ... !> \param worker_id ... !> \param iw ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_mpi_init(swarm_mpi, world_para_env, root_section, n_workers, worker_id, iw, error) + SUBROUTINE swarm_mpi_init(swarm_mpi, world_para_env, root_section, n_workers, worker_id, iw) TYPE(swarm_mpi_type) :: swarm_mpi TYPE(cp_para_env_type), POINTER :: world_para_env TYPE(section_vals_type), POINTER :: root_section INTEGER, INTENT(IN) :: n_workers INTEGER, INTENT(OUT) :: worker_id INTEGER, INTENT(IN) :: iw - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: n_groups_created, & pe_per_worker, subgroup, & @@ -112,7 +110,7 @@ SUBROUTINE swarm_mpi_init(swarm_mpi, world_para_env, root_section, n_workers, wo CALL mp_comm_split_direct(swarm_mpi%world%group, subgroup, 1) CALL mp_environ(subgroup_size, subgroup_rank, subgroup) IF(subgroup_size/=1) STOP "swarm: mp_comm_split_direct failed (master)" - CALL cp_para_env_create(swarm_mpi%master, group=subgroup, error=error) + CALL cp_para_env_create(swarm_mpi%master, group=subgroup) !WRITE (*,*) "this is a master ", swarm_mpi%master%mepos, swarm_mpi%master%num_pe ELSE CALL mp_comm_split_direct(swarm_mpi%world%group, subgroup, 2) @@ -130,7 +128,7 @@ SUBROUTINE swarm_mpi_init(swarm_mpi, world_para_env, root_section, n_workers, wo CALL mp_comm_split(subgroup, worker_group, n_groups_created, group_distribution_p, n_subgroups=n_workers) worker_id = group_distribution(subgroup_rank) + 1 ! shall start by 1 IF(n_groups_created/=n_workers) STOP "swarm: mp_comm_split failed." - CALL cp_para_env_create(swarm_mpi%worker, group=worker_group, error=error) + CALL cp_para_env_create(swarm_mpi%worker, group=worker_group) CALL mp_comm_free(subgroup) !WRITE (*,*) "this is worker ", worker_id, swarm_mpi%worker%mepos, swarm_mpi%worker%num_pe @@ -145,20 +143,18 @@ SUBROUTINE swarm_mpi_init(swarm_mpi, world_para_env, root_section, n_workers, wo !WRITE (*,*), "wid2group table: ",swarm_mpi%wid2group - CALL logger_init_master(swarm_mpi, error) - CALL logger_init_worker(swarm_mpi, root_section, worker_id, error) + CALL logger_init_master(swarm_mpi) + CALL logger_init_worker(swarm_mpi, root_section, worker_id) END SUBROUTINE swarm_mpi_init ! ***************************************************************************** !> \brief Helper routine for swarm_mpi_init, configures the master's logger. !> \param swarm_mpi ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE logger_init_master(swarm_mpi, error) + SUBROUTINE logger_init_master(swarm_mpi) TYPE(swarm_mpi_type) :: swarm_mpi - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: output_unit TYPE(cp_logger_type), POINTER :: logger @@ -166,7 +162,7 @@ SUBROUTINE logger_init_master(swarm_mpi, error) ! broadcast master_output_path to all ranks IF(swarm_mpi%world%mepos == swarm_mpi%world%source) THEN - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr swarm_mpi%master_output_path = output_unit2path(output_unit) IF(output_unit/=default_output_unit) & @@ -176,7 +172,7 @@ SUBROUTINE logger_init_master(swarm_mpi, error) CALL mp_bcast(swarm_mpi%master_output_path, swarm_mpi%world%source, swarm_mpi%world%group) IF(ASSOCIATED(swarm_mpi%master)) & - CALL error_add_new_logger(swarm_mpi%master, swarm_mpi%master_output_path, error=error) + CALL error_add_new_logger(swarm_mpi%master, swarm_mpi%master_output_path) END SUBROUTINE logger_init_master @@ -201,14 +197,12 @@ END FUNCTION output_unit2path !> \param swarm_mpi ... !> \param root_section ... !> \param worker_id ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE logger_init_worker(swarm_mpi, root_section, worker_id, error) + SUBROUTINE logger_init_worker(swarm_mpi, root_section, worker_id) TYPE(swarm_mpi_type) :: swarm_mpi TYPE(section_vals_type), POINTER :: root_section INTEGER :: worker_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_path_length) :: output_path CHARACTER(len=default_string_length) :: new_project_name, & @@ -218,7 +212,7 @@ SUBROUTINE logger_init_worker(swarm_mpi, root_section, worker_id, error) NULLIFY(old_logger, new_iter_info) IF(ASSOCIATED(swarm_mpi%worker)) THEN - old_logger => cp_error_get_logger(error) + old_logger => cp_get_default_logger() project_name = old_logger%iter_info%project_name IF(worker_id > 99999) & STOP "logger_init_worker: Did not expect so many workers." @@ -227,9 +221,9 @@ SUBROUTINE logger_init_worker(swarm_mpi, root_section, worker_id, error) STOP "logger_init_worker: project name too long" output_path = TRIM(project_name) // "-"// TRIM(worker_name) // ".out" new_project_name = TRIM(project_name) // "-"// TRIM(worker_name) - CALL section_vals_val_set(root_section, "GLOBAL%PROJECT_NAME", c_val=new_project_name,error=error) + CALL section_vals_val_set(root_section, "GLOBAL%PROJECT_NAME", c_val=new_project_name) CALL cp_iteration_info_create(new_iter_info, new_project_name) - CALL error_add_new_logger(swarm_mpi%worker, output_path, new_iter_info, error) + CALL error_add_new_logger(swarm_mpi%worker, output_path, new_iter_info) CALL cp_iteration_info_release(new_iter_info) ENDIF END SUBROUTINE logger_init_worker @@ -240,15 +234,13 @@ END SUBROUTINE logger_init_worker !> \param para_env ... !> \param output_path ... !> \param iter_info ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE error_add_new_logger(para_env, output_path, iter_info, error) + SUBROUTINE error_add_new_logger(para_env, output_path, iter_info) TYPE(cp_para_env_type), POINTER :: para_env CHARACTER(LEN=default_path_length) :: output_path TYPE(cp_iteration_info_type), OPTIONAL, & POINTER :: iter_info - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: output_unit TYPE(cp_logger_type), POINTER :: new_logger, old_logger @@ -263,7 +255,7 @@ SUBROUTINE error_add_new_logger(para_env, output_path, iter_info, error) file_action="WRITE", file_position="APPEND", unit_number=output_unit) ENDIF - old_logger => cp_error_get_logger(error) + old_logger => cp_get_default_logger() CALL cp_logger_create(new_logger, para_env=para_env,& default_global_unit_nr=output_unit, close_global_unit_on_dealloc=.FALSE.,& template_logger=old_logger, iter_info=iter_info) @@ -277,19 +269,17 @@ END SUBROUTINE error_add_new_logger !> \brief Finalizes the MPI communicators of a swarm run. !> \param swarm_mpi ... !> \param root_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE swarm_mpi_finalize(swarm_mpi, root_section, error) + SUBROUTINE swarm_mpi_finalize(swarm_mpi, root_section) TYPE(swarm_mpi_type) :: swarm_mpi TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(inout) :: error CALL mp_sync(swarm_mpi%world%group) - CALL logger_finalize(swarm_mpi, root_section, error) + CALL logger_finalize(swarm_mpi, root_section) - IF(ASSOCIATED(swarm_mpi%worker)) CALL cp_para_env_release(swarm_mpi%worker, error) - IF(ASSOCIATED(swarm_mpi%master)) CALL cp_para_env_release(swarm_mpi%master, error) + IF(ASSOCIATED(swarm_mpi%worker)) CALL cp_para_env_release(swarm_mpi%worker) + IF(ASSOCIATED(swarm_mpi%master)) CALL cp_para_env_release(swarm_mpi%master) NULLIFY(swarm_mpi%worker, swarm_mpi%master) DEALLOCATE(swarm_mpi%wid2group) END SUBROUTINE swarm_mpi_finalize @@ -299,30 +289,28 @@ END SUBROUTINE swarm_mpi_finalize !> \brief Helper routine for swarm_mpi_finalize, restores the original loggers !> \param swarm_mpi ... !> \param root_section ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE logger_finalize(swarm_mpi, root_section, error) + SUBROUTINE logger_finalize(swarm_mpi, root_section) TYPE(swarm_mpi_type) :: swarm_mpi TYPE(section_vals_type), POINTER :: root_section - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: output_unit LOGICAL :: I_am_rank0 TYPE(cp_logger_type), POINTER :: logger, old_logger NULLIFY(logger, old_logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = logger%default_local_unit_nr IF(output_unit>0 .AND. output_unit/=default_output_unit)& CALL close_file(output_unit) CALL cp_rm_default_logger() !pops the top-most logger - old_logger => cp_error_get_logger(error) + old_logger => cp_get_default_logger() ! restore GLOBAL%PROJECT_NAME CALL section_vals_val_set(root_section, "GLOBAL%PROJECT_NAME", & - c_val=old_logger%iter_info%project_name, error=error) + c_val=old_logger%iter_info%project_name) CALL mp_sync(swarm_mpi%world%group) diff --git a/src/swarm/swarm_worker.F b/src/swarm/swarm_worker.F index 89371ef152..dd9f48c587 100644 --- a/src/swarm/swarm_worker.F +++ b/src/swarm/swarm_worker.F @@ -38,7 +38,6 @@ MODULE swarm_worker PRIVATE INTEGER :: id = -1 INTEGER :: iw = -1 - TYPE(cp_error_type) :: error INTEGER :: behavior = -1 TYPE(glbopt_worker_type), POINTER :: glbopt => Null() !possbily more behaviors... @@ -56,36 +55,33 @@ MODULE swarm_worker !> \param root_section ... !> \param input_path ... !> \param worker_id ... -!> \param error ... !> \author Ole Schuett ! ***************************************************************************** SUBROUTINE swarm_worker_init(worker, para_env, input_declaration, root_section,& - input_path, worker_id, error) + input_path, worker_id) TYPE(swarm_worker_type), INTENT(INOUT) :: worker TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section CHARACTER(LEN=*), INTENT(IN) :: input_path INTEGER, INTENT(in) :: worker_id - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_logger_type), POINTER :: logger - worker%error = error worker%id = worker_id ! getting an output unit for logging - logger => cp_error_get_logger(worker%error) + logger => cp_get_default_logger() worker%iw = cp_print_key_unit_nr(logger,root_section,& - "SWARM%PRINT%WORKER_RUN_INFO",extension=".workerLog", error=worker%error) + "SWARM%PRINT%WORKER_RUN_INFO",extension=".workerLog") - CALL section_vals_val_get(root_section,"SWARM%BEHAVIOR", i_val=worker%behavior, error=error) + CALL section_vals_val_get(root_section,"SWARM%BEHAVIOR", i_val=worker%behavior) SELECT CASE(worker%behavior) CASE(swarm_do_glbopt) ALLOCATE(worker%glbopt) CALL glbopt_worker_init(worker%glbopt, input_declaration, para_env,& - root_section, input_path, worker_id, worker%iw, error) + root_section, input_path, worker_id, worker%iw) CASE DEFAULT STOP "swarm_worker_init: got unknown behavior" END SELECT diff --git a/src/taper_types.F b/src/taper_types.F index 36b97ae21b..b1c886792e 100644 --- a/src/taper_types.F +++ b/src/taper_types.F @@ -37,12 +37,10 @@ MODULE taper_types !> \param taper ... !> \param rc ... !> \param range ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE taper_create(taper, rc, range, error) + SUBROUTINE taper_create(taper, rc, range) TYPE(taper_type), POINTER :: taper REAL(KIND=dp), INTENT(IN) :: rc, range - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'taper_create', & routineP = moduleN//':'//routineN @@ -51,12 +49,12 @@ SUBROUTINE taper_create(taper, rc, range, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(taper),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(taper),cp_failure_level,routineP,failure) ALLOCATE (taper,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (range > EPSILON(0.0_dp)) THEN taper%apply_taper = .TRUE. - CPPrecondition(range>0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(range>0.0_dp,cp_failure_level,routineP,failure) taper%r0 = 2.0_dp*rc - 20.0_dp * range taper%rscale = 1.0_dp/range ELSE @@ -68,11 +66,9 @@ END SUBROUTINE taper_create ! ***************************************************************************** !> \brief Releases taper type !> \param taper ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE taper_release(taper, error) + SUBROUTINE taper_release(taper) TYPE(taper_type), POINTER :: taper - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'taper_release', & routineP = moduleN//':'//routineN @@ -83,7 +79,7 @@ SUBROUTINE taper_release(taper, error) failure = .FALSE. IF (ASSOCIATED(taper)) THEN DEALLOCATE (taper,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE taper_release @@ -91,13 +87,11 @@ END SUBROUTINE taper_release !> \brief Taper functions !> \param taper ... !> \param rij ... -!> \param error ... !> \retval ft ... ! ***************************************************************************** - FUNCTION taper_eval (taper, rij, error) RESULT(ft) + FUNCTION taper_eval (taper, rij) RESULT(ft) TYPE(taper_type), POINTER :: taper REAL(KIND=dp), INTENT(IN) :: rij - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: ft CHARACTER(len=*), PARAMETER :: routineN = 'taper_eval', & @@ -116,13 +110,11 @@ END FUNCTION taper_eval !> \brief Analytical derivatives for taper function !> \param taper ... !> \param rij ... -!> \param error ... !> \retval dft ... ! ***************************************************************************** - FUNCTION dtaper_eval (taper, rij, error ) RESULT(dft) + FUNCTION dtaper_eval (taper, rij) RESULT(dft) TYPE(taper_type), POINTER :: taper REAL(KIND=dp), INTENT(IN) :: rij - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: dft CHARACTER(len=*), PARAMETER :: routineN = 'dtaper_eval', & diff --git a/src/task_list_methods.F b/src/task_list_methods.F index 8f284c7a62..f7b405d536 100644 --- a/src/task_list_methods.F +++ b/src/task_list_methods.F @@ -94,7 +94,6 @@ MODULE task_list_methods !> \param basis_type ... !> \param pw_env_external ... !> \param sab_orb_external ... -!> \param error ... !> \par History !> 01.2008 factored out of calculate_rho_elec [Joost VandeVondele] !> 04.2010 divides tasks into grid levels and atom pairs for integrate/collocate [Iain Bethune] @@ -108,7 +107,7 @@ MODULE task_list_methods ! ***************************************************************************** SUBROUTINE generate_qs_task_list(ks_env, task_list,& reorder_rs_grid_ranks, skip_load_balance_distributed, & - soft_valid, basis_type, pw_env_external, sab_orb_external, error) + soft_valid, basis_type, pw_env_external, sab_orb_external) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(task_list_type), POINTER :: task_list @@ -119,7 +118,6 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& TYPE(pw_env_type), OPTIONAL, POINTER :: pw_env_external TYPE(neighbor_list_set_p_type), & DIMENSION(:), OPTIONAL, POINTER :: sab_orb_external - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'generate_qs_task_list', & routineP = moduleN//':'//routineN @@ -179,8 +177,7 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& qs_kind_set=qs_kind_set,& cell=cell,& particle_set=particle_set,& - dft_control=dft_control,& - error=error) + dft_control=dft_control) IF( PRESENT(basis_type)) THEN my_basis_type = basis_type @@ -188,12 +185,12 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& my_basis_type = "ORB" END IF - CALL get_ks_env(ks_env,sab_orb=sab_orb,error=error) + CALL get_ks_env(ks_env,sab_orb=sab_orb) IF (PRESENT(sab_orb_external)) sab_orb=>sab_orb_external - CALL get_ks_env(ks_env,pw_env=pw_env,error=error) + CALL get_ks_env(ks_env,pw_env=pw_env) IF (PRESENT(pw_env_external)) pw_env=>pw_env_external - CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_grids, error=error) + CALL pw_env_get(pw_env, rs_descs=rs_descs, rs_grids=rs_grids) ! *** assign from pw_env gridlevel_info=>pw_env%gridlevel_info @@ -208,7 +205,7 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& qs_kind => qs_kind_set(ikind) CALL get_qs_kind(qs_kind=qs_kind,& softb = my_soft, & - basis_set=orb_basis_set, basis_type=my_basis_type, error=error) + basis_set=orb_basis_set, basis_type=my_basis_type) IF (.NOT.ASSOCIATED(orb_basis_set)) CYCLE CALL get_gto_basis_set(gto_basis_set=orb_basis_set, npgf=npgfa, nset=nseta ) @@ -222,8 +219,8 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& IF(nimages > 1) THEN dokp = .TRUE. NULLIFY(kpoints) - CALL get_ks_env(ks_env=ks_env,kpoints=kpoints,error=error) - CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index,error=error) + CALL get_ks_env(ks_env=ks_env,kpoints=kpoints) + CALL get_kpoint_info(kpoint=kpoints,cell_to_index=cell_to_index) ELSE dokp = .FALSE. NULLIFY(cell_to_index) @@ -245,7 +242,7 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& DO ikind=1,nkind qs_kind => qs_kind_set(ikind) CALL get_qs_kind(qs_kind=qs_kind,softb=my_soft,basis_set=basis_set_a,& - basis_type=my_basis_type,error=error) + basis_type=my_basis_type) IF (ASSOCIATED(basis_set_a)) THEN basis_set_list(ikind)%gto_basis_set => basis_set_a ELSE @@ -289,7 +286,7 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& CALL task_list_inner_loop(task_list%tasks,task_list%dist_ab,task_list%ntasks,curr_tasks,& rs_descs,dft_control,cube_info,gridlevel_info,cindex,& iatom,jatom,rpgfa,rpgfb,zeta,zetb,kind_radius_b,set_radius_a,set_radius_b,ra,rab,& - la_max,la_min,lb_max,lb_min,npgfa,npgfb,maxpgf,maxset,natoms,nimages,nseta,nsetb,error) + la_max,la_min,lb_max,lb_min,npgfa,npgfb,maxpgf,maxset,natoms,nimages,nseta,nsetb) END DO CALL neighbor_list_iterator_release(nl_iterator) @@ -300,17 +297,16 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& CALL distribute_tasks (rs_descs, task_list%ntasks, natoms, maxset, maxpgf, nimages,& task_list%tasks, rval=task_list%dist_ab, atom_pair_send=task_list%atom_pair_send,& atom_pair_recv=task_list%atom_pair_recv, symmetric=.TRUE., & - reorder_rs_grid_ranks=reorder_rs_grid_ranks, skip_load_balance_distributed=skip_load_balance_distributed,& - error=error) + reorder_rs_grid_ranks=reorder_rs_grid_ranks, skip_load_balance_distributed=skip_load_balance_distributed) ! If the rank order has changed, reallocate any of the distributed rs_grids IF (reorder_rs_grid_ranks) THEN DO i=1,gridlevel_info%ngrid_levels IF (rs_descs(i)%rs_desc%distributed) THEN - CALL rs_grid_release(rs_grids(i)%rs_grid, error) + CALL rs_grid_release(rs_grids(i)%rs_grid) NULLIFY(rs_grids(i)%rs_grid) - CALL rs_grid_create(rs_grids(i)%rs_grid, rs_descs(i)%rs_desc, error) + CALL rs_grid_create(rs_grids(i)%rs_grid, rs_descs(i)%rs_desc) END IF END DO END IF @@ -320,21 +316,21 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& IF (ASSOCIATED(task_list%taskstart)) THEN DEALLOCATE (task_list%taskstart,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(task_list%taskstop)) THEN DEALLOCATE (task_list%taskstop,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(task_list%npairs)) THEN DEALLOCATE (task_list%npairs,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! First, count the number of unique atom pairs per grid level ALLOCATE (task_list%npairs(SIZE(rs_descs)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iatom_old = -1 ; jatom_old = -1 ; igrid_level_old = -1 ; img_old = -1 ipair = 0 @@ -369,9 +365,9 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& ! Array sized for worst case ALLOCATE (task_list%taskstart(MAXVAL(task_list%npairs),SIZE(rs_descs)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (task_list%taskstop(MAXVAL(task_list%npairs),SIZE(rs_descs)), STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iatom_old = -1 ; jatom_old = -1 ; igrid_level_old = -1 ; img_old = -1 ipair = 0 @@ -418,7 +414,7 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& DO igrid_level = 1, gridlevel_info%ngrid_levels ALLOCATE (blocks(natoms,natoms,nimages),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) blocks = -1 DO ipair = 1, task_list%npairs(igrid_level) itask = task_list%taskstart(ipair,igrid_level) @@ -448,7 +444,7 @@ SUBROUTINE generate_qs_task_list(ks_env, task_list,& END DO END DO DEALLOCATE (blocks,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO @@ -492,14 +488,13 @@ END SUBROUTINE generate_qs_task_list !> \param nimages ... !> \param nseta ... !> \param nsetb ... -!> \param error ... !> \par History !> Joost VandeVondele: 10.2008 refactored ! ***************************************************************************** SUBROUTINE task_list_inner_loop(tasks, dist_ab, ntasks, curr_tasks, rs_descs,dft_control,& cube_info,gridlevel_info,cindex,& iatom,jatom,rpgfa,rpgfb,zeta,zetb,kind_radius_b,set_radius_a,set_radius_b,ra,rab,& - la_max,la_min,lb_max,lb_min,npgfa,npgfb,maxpgf,maxset,natoms,nimages,nseta,nsetb,error) + la_max,la_min,lb_max,lb_min,npgfa,npgfb,maxpgf,maxset,natoms,nimages,nseta,nsetb) INTEGER(KIND=int_8), DIMENSION(:, :), & POINTER :: tasks @@ -520,7 +515,6 @@ SUBROUTINE task_list_inner_loop(tasks, dist_ab, ntasks, curr_tasks, rs_descs,dft lb_min, npgfa, npgfb INTEGER :: maxpgf, maxset, natoms, & nimages, nseta, nsetb - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'task_list_inner_loop', & routineP = moduleN//':'//routineN @@ -556,13 +550,13 @@ SUBROUTINE task_list_inner_loop(tasks, dist_ab, ntasks, curr_tasks, rs_descs,dft rs_descs(igrid_level)%rs_desc,cube_info(igrid_level),& la_max(iset),zeta(ipgf,iset),la_min(iset),& lb_max(jset),zetb(jpgf,jset),lb_min(jset),& - ra,rab,rab2,dft_control%qs_control%eps_rho_rspace,error) + ra,rab,rab2,dft_control%qs_control%eps_rho_rspace) CALL pgf_to_tasks(tasks,dist_ab,ntasks,curr_tasks,& rab,cindex,iatom,jatom,iset,jset,ipgf,jpgf,nimages,natoms,maxset,maxpgf,& la_max(iset),lb_max(jset),rs_descs(igrid_level)%rs_desc,& igrid_level,gridlevel_info%ngrid_levels,cube_center,& - lb_cube,ub_cube,error) + lb_cube,ub_cube) END DO loop_jpgf @@ -595,7 +589,6 @@ END SUBROUTINE task_list_inner_loop !> \param rab ... !> \param rab2 ... !> \param eps ... -!> \param error ... !> \par History !> 10.2008 refactored [Joost VandeVondele] !> \note @@ -610,7 +603,7 @@ END SUBROUTINE task_list_inner_loop !> a*(l+b)(r+c)**3+d which is based on the innerloop of the collocating routines ! ***************************************************************************** SUBROUTINE compute_pgf_properties(cube_center,lb_cube,ub_cube,radius, & - rs_desc,cube_info,la_max,zeta,la_min,lb_max,zetb,lb_min,ra,rab,rab2,eps,error) + rs_desc,cube_info,la_max,zeta,la_min,lb_max,zetb,lb_min,ra,rab,rab2,eps) INTEGER, DIMENSION(3), INTENT(OUT) :: cube_center, lb_cube, ub_cube REAL(KIND=dp), INTENT(OUT) :: radius @@ -622,7 +615,6 @@ SUBROUTINE compute_pgf_properties(cube_center,lb_cube,ub_cube,radius, & REAL(KIND=dp), INTENT(IN) :: zetb INTEGER, INTENT(IN) :: lb_min REAL(KIND=dp), INTENT(IN) :: ra(3), rab(3), rab2, eps - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_pgf_properties', & routineP = moduleN//':'//routineN @@ -736,13 +728,12 @@ END FUNCTION cost_model !> \param cube_center ... !> \param lb_cube ... !> \param ub_cube ... -!> \param error ... !> \par History !> 10.2008 Refactored based on earlier routines by MattW [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE pgf_to_tasks(tasks,dist_ab,ntasks,curr_tasks,& rab,cindex,iatom,jatom,iset,jset,ipgf,jpgf,nimages,natoms,maxset,maxpgf,& - la_max,lb_max,rs_desc,igrid_level,n_levels,cube_center,lb_cube,ub_cube,error) + la_max,lb_max,rs_desc,igrid_level,n_levels,cube_center,lb_cube,ub_cube) INTEGER(KIND=int_8), DIMENSION(:, :), & POINTER :: tasks @@ -756,7 +747,6 @@ SUBROUTINE pgf_to_tasks(tasks,dist_ab,ntasks,curr_tasks,& TYPE(realspace_grid_desc_type), POINTER :: rs_desc INTEGER, INTENT(IN) :: igrid_level, n_levels INTEGER, DIMENSION(3), INTENT(IN) :: cube_center, lb_cube, ub_cube - TYPE(cp_error_type), INTENT(inout) :: error INTEGER, PARAMETER :: add_tasks = 1000 REAL(kind=dp), PARAMETER :: mult_tasks = 2.0_dp @@ -776,7 +766,7 @@ SUBROUTINE pgf_to_tasks(tasks,dist_ab,ntasks,curr_tasks,& ! finds the node(s) that need to process this task ! on exit tasks(4,:) is 1 for distributed tasks and 2 for generalised tasks CALL rs_find_node(rs_desc,igrid_level,n_levels,cube_center, & - ntasks=ntasks,tasks=tasks,lb_cube=lb_cube,ub_cube=ub_cube,added_tasks=added_tasks,error=error) + ntasks=ntasks,tasks=tasks,lb_cube=lb_cube,ub_cube=ub_cube,added_tasks=added_tasks) ELSE tasks(1,ntasks) = encode_rank(rs_desc % my_pos, igrid_level, n_levels) @@ -923,12 +913,11 @@ END SUBROUTINE int2pair !> \param natoms ... !> \param maxset ... !> \param maxpgf ... -!> \param error ... !> \par History !> created 2008-10-03 [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE load_balance_distributed (tasks, ntasks, rs_descs, grid_level, & - nimages, natoms, maxset, maxpgf, error) + nimages, natoms, maxset, maxpgf) INTEGER(KIND=int_8), DIMENSION(:, :), & POINTER :: tasks @@ -937,7 +926,6 @@ SUBROUTINE load_balance_distributed (tasks, ntasks, rs_descs, grid_level, & DIMENSION(:), POINTER :: rs_descs INTEGER :: grid_level, nimages, natoms, & maxset, maxpgf - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'load_balance_distributed', & routineP = moduleN//':'//routineN @@ -952,21 +940,21 @@ SUBROUTINE load_balance_distributed (tasks, ntasks, rs_descs, grid_level, & NULLIFY(list) ! here we create for each cpu (0:ncpu-1) a list of possible destinations. ! if a destination would not be in this list, it is a bug - CALL create_destination_list(list,rs_descs,grid_level,error) + CALL create_destination_list(list,rs_descs,grid_level) ! now, walk over the tasks, filling in the loads of each destination CALL compute_load_list(list, rs_descs, grid_level, tasks, ntasks, nimages, natoms, maxset, maxpgf,& - create_list=.TRUE., error=error) + create_list=.TRUE.) ! optimize loads & fluxes - CALL optimize_load_list(list,rs_descs(1)%rs_desc%group,rs_descs(1)%rs_desc%my_pos, error) + CALL optimize_load_list(list,rs_descs(1)%rs_desc%group,rs_descs(1)%rs_desc%my_pos) ! now, walk over the tasks, using the list to set the destinations CALL compute_load_list(list, rs_descs,grid_level, tasks, ntasks, nimages, natoms, maxset, maxpgf,& - create_list=.FALSE., error=error) + create_list=.FALSE.) DEALLOCATE (list,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1130,14 +1118,12 @@ END SUBROUTINE balance_global_list !> \param list ... !> \param group ... !> \param my_pos ... -!> \param error ... !> \par History !> created 2008-10-06 [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE optimize_load_list(list,group,my_pos,error) + SUBROUTINE optimize_load_list(list,group,my_pos) INTEGER, DIMENSION(:, :, 0:) :: list INTEGER, INTENT(IN) :: group, my_pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'optimize_load_list', & routineP = moduleN//':'//routineN @@ -1156,14 +1142,14 @@ SUBROUTINE optimize_load_list(list,group,my_pos,error) maxdest=SIZE(list,2) ALLOCATE (load_all(maxdest*ncpu),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! ! XXXXX this allocation can cause an out-of-memory if the number of MPI tasks is sufficient ! ALLOCATE (load_per_source(maxdest*ncpu*ncpu),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (list_global(2,maxdest,ncpu),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) load_all(:)=RESHAPE(list(2,:,:),(/maxdest*ncpu/)) @@ -1203,11 +1189,11 @@ SUBROUTINE optimize_load_list(list,group,my_pos,error) list(2,:,:)=RESHAPE(load_all,(/maxdest,ncpu/)) DEALLOCATE (load_all,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (load_per_source,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (list_global,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1229,12 +1215,11 @@ END SUBROUTINE optimize_load_list !> \param maxset ... !> \param maxpgf ... !> \param create_list ... -!> \param error ... !> \par History !> created 2008-10-06 [Joost VandeVondele] ! ***************************************************************************** SUBROUTINE compute_load_list(list,rs_descs,grid_level,tasks,& - ntasks,nimages,natoms,maxset,maxpgf,create_list,error) + ntasks,nimages,natoms,maxset,maxpgf,create_list) INTEGER, DIMENSION(:, :, 0:) :: list TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs @@ -1244,7 +1229,6 @@ SUBROUTINE compute_load_list(list,rs_descs,grid_level,tasks,& INTEGER :: ntasks, nimages, natoms, & maxset, maxpgf LOGICAL :: create_list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_load_list', & routineP = moduleN//':'//routineN @@ -1264,7 +1248,7 @@ SUBROUTINE compute_load_list(list,rs_descs,grid_level,tasks,& ALLOCATE (loads(0:rs_descs(grid_level)%rs_desc%group_size-1)) CALL get_current_loads(loads, rs_descs, grid_level, ntasks, nimages, natoms, maxset, maxpgf, & - tasks, use_reordered_ranks=.FALSE. , error=error) + tasks, use_reordered_ranks=.FALSE.) failure=.FALSE. @@ -1422,7 +1406,7 @@ SUBROUTINE compute_load_list(list,rs_descs,grid_level,tasks,& ENDIF ENDIF CASE DEFAULT - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT @@ -1459,16 +1443,14 @@ END FUNCTION list_index !> \param list ... !> \param rs_descs ... !> \param grid_level ... -!> \param error ... !> \par History !> created 2008-10-06 [Joost VandeVondele] ! ***************************************************************************** - SUBROUTINE create_destination_list(list,rs_descs,grid_level,error) + SUBROUTINE create_destination_list(list,rs_descs,grid_level) INTEGER, DIMENSION(:, :, :), POINTER :: list TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs INTEGER, INTENT(IN) :: grid_level - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_destination_list', & routineP = moduleN//':'//routineN @@ -1482,17 +1464,17 @@ SUBROUTINE create_destination_list(list,rs_descs,grid_level,error) CALL timeset(routineN,handle) - CPPrecondition(.NOT.ASSOCIATED(list),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(list),cp_failure_level,routineP,failure) ncpu=rs_descs(grid_level)%rs_desc%group_size ultimate_max=7 ALLOCATE (list(2,ultimate_max,0:ncpu-1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (INDEX(ultimate_max),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (sublist(ultimate_max),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) sublist=HUGE(sublist) maxcount=1 @@ -1539,13 +1521,12 @@ END SUBROUTINE create_destination_list !> \param maxpgf ... !> \param tasks ... !> \param use_reordered_ranks ... -!> \param error ... !> \par History !> none !> \author MattW 21/11/2007 ! ***************************************************************************** SUBROUTINE get_current_loads(loads, rs_descs, grid_level, ntasks, nimages, natom, maxset, & - maxpgf, tasks, use_reordered_ranks, error) + maxpgf, tasks, use_reordered_ranks) INTEGER(KIND=int_8), DIMENSION(:) :: loads TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs @@ -1554,7 +1535,6 @@ SUBROUTINE get_current_loads(loads, rs_descs, grid_level, ntasks, nimages, natom INTEGER(KIND=int_8), DIMENSION(:, :), & POINTER :: tasks LOGICAL, INTENT(IN) :: use_reordered_ranks - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_current_loads', & routineP = moduleN//':'//routineN @@ -1576,9 +1556,9 @@ SUBROUTINE get_current_loads(loads, rs_descs, grid_level, ntasks, nimages, natom ! allocate local arrays ALLOCATE (send_buf_i(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_buf_i(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! communication step 1 : compute the total local cost of the tasks ! each proc needs to know the amount of work he will receive @@ -1620,12 +1600,11 @@ END SUBROUTINE get_current_loads !> \param natoms ... !> \param maxset ... !> \param maxpgf ... -!> \param error ... !> \par History !> none !> \author MattW 21/11/2007 ! ***************************************************************************** - SUBROUTINE load_balance_replicated ( rs_descs, ntasks, tasks, nimages, natoms, maxset, maxpgf, error) + SUBROUTINE load_balance_replicated ( rs_descs, ntasks, tasks, nimages, natoms, maxset, maxpgf) TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs @@ -1634,7 +1613,6 @@ SUBROUTINE load_balance_replicated ( rs_descs, ntasks, tasks, nimages, natoms, m POINTER :: tasks INTEGER, INTENT(IN) :: nimages, natoms, maxset, & maxpgf - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'load_balance_replicated', & routineP = moduleN//':'//routineN @@ -1659,14 +1637,14 @@ SUBROUTINE load_balance_replicated ( rs_descs, ntasks, tasks, nimages, natoms, m ! allocate local arrays ALLOCATE (recv_buf_i(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (loads(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) recv_buf_i = 0 DO i = 1, SIZE(rs_descs) CALL get_current_loads ( loads, rs_descs, i, ntasks, nimages, natoms, maxset, maxpgf, & - tasks, use_reordered_ranks=.TRUE. ,error=error ) + tasks, use_reordered_ranks=.TRUE.) recv_buf_i(:) = recv_buf_i + loads END DO @@ -1680,9 +1658,9 @@ SUBROUTINE load_balance_replicated ( rs_descs, ntasks, tasks, nimages, natoms, m ! load imbalance measures the load of a given CPU relative ! to the optimal load distribution (load=average) ALLOCATE (load_imbalance(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (INDEX(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) load_imbalance(:) = recv_buf_i - average_cost no_overloaded = 0 @@ -1774,9 +1752,9 @@ SUBROUTINE load_balance_replicated ( rs_descs, ntasks, tasks, nimages, natoms, m ENDIF DEALLOCATE (index,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (load_imbalance,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1792,13 +1770,12 @@ END SUBROUTINE load_balance_replicated !> \param ntasks_recv ... !> \param tasks_recv ... !> \param rval_recv ... -!> \param error ... !> \par History !> none !> \author MattW 21/11/2007 ! ***************************************************************************** SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & - ntasks_recv, tasks_recv, rval_recv, error) + ntasks_recv, tasks_recv, rval_recv) TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs @@ -1810,7 +1787,6 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & INTEGER(KIND=int_8), DIMENSION(:, :), & POINTER :: tasks_recv REAL(KIND=dp), DIMENSION(:, :), POINTER :: rval_recv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_local_tasks', & routineP = moduleN//':'//routineN @@ -1833,17 +1809,17 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & ! allocate local arrays ALLOCATE (send_sizes(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_sizes(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (send_disps(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_disps(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (send_buf_i(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_buf_i(desc%group_size),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! fill send buffer, now counting how many tasks will be send (stored in an int8 array for convenience only). send_buf_i=0 @@ -1874,15 +1850,15 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & ! deallocate old send/recv buffers DEALLOCATE (send_buf_i,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_buf_i,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! allocate them with new sizes ALLOCATE (send_buf_i(SUM(send_sizes)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_buf_i(SUM(recv_sizes)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! do packing send_buf_i = 0 @@ -1899,11 +1875,11 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & CALL mp_alltoall(send_buf_i, send_sizes, send_disps, recv_buf_i, recv_sizes, recv_disps, desc % group) DEALLOCATE (send_buf_i,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ntasks_recv=SUM(recv_sizes)/task_dim ALLOCATE (tasks_recv(task_dim,ntasks_recv),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! do unpacking l = 0 @@ -1917,7 +1893,7 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & ENDDO DEALLOCATE (recv_buf_i,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! send rvals (to be removed :-) @@ -1929,9 +1905,9 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & task_dim=SIZE(rval,1) ALLOCATE (send_buf_r(SUM(send_sizes)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_buf_r(SUM(recv_sizes)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) !do packing send_sizes = 0 @@ -1948,9 +1924,9 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & recv_buf_r, recv_sizes, recv_disps, desc % group) DEALLOCATE (send_buf_r,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (rval_recv(task_dim,SUM(recv_sizes)/task_dim),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! do unpacking l = 0 @@ -1964,15 +1940,15 @@ SUBROUTINE create_local_tasks ( rs_descs, ntasks, tasks, rval, & ENDDO DEALLOCATE (recv_buf_r,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (send_sizes,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_sizes,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (send_disps,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_disps,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -1993,14 +1969,13 @@ END SUBROUTINE create_local_tasks !> \param symmetric ... !> \param reorder_rs_grid_ranks ... !> \param skip_load_balance_distributed ... -!> \param error ... !> \par History !> none !> \author MattW 21/11/2007 ! ***************************************************************************** SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages,& tasks, rval, atom_pair_send, atom_pair_recv,& - symmetric, reorder_rs_grid_ranks, skip_load_balance_distributed, error) + symmetric, reorder_rs_grid_ranks, skip_load_balance_distributed) TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs @@ -2014,7 +1989,6 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, LOGICAL, INTENT(IN) :: symmetric, & reorder_rs_grid_ranks, & skip_load_balance_distributed - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'distribute_tasks', & routineP = moduleN//':'//routineN @@ -2038,7 +2012,7 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, CALL timeset(routineN,handle) failure = .FALSE. - CPPrecondition(ASSOCIATED(tasks),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tasks),cp_failure_level,routineP,failure) ! *** figure out if we have distributed grids distributed_grids=.FALSE. @@ -2052,9 +2026,9 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, IF (distributed_grids) THEN ALLOCATE (loads(0:desc%group_size-1,SIZE(rs_descs)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (total_loads(0:desc%group_size-1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) total_loads = 0 @@ -2065,10 +2039,10 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, IF ( rs_descs(igrid_level)%rs_desc%distributed ) THEN IF (.NOT.skip_load_balance_distributed) & - CALL load_balance_distributed(tasks, ntasks, rs_descs, igrid_level, nimages, natoms, maxset,maxpgf, error) + CALL load_balance_distributed(tasks, ntasks, rs_descs, igrid_level, nimages, natoms, maxset,maxpgf) CALL get_current_loads( loads(:,igrid_level), rs_descs, igrid_level, ntasks, nimages, natoms, maxset,maxpgf, & - tasks, use_reordered_ranks=.FALSE. , error=error) + tasks, use_reordered_ranks=.FALSE.) total_loads(:)=total_loads+loads(:,igrid_level) @@ -2082,7 +2056,7 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, DO igrid_level=1,SIZE(rs_descs) IF (.NOT. rs_descs(igrid_level)%rs_desc%distributed) THEN CALL get_current_loads( loads(:,igrid_level), rs_descs, igrid_level, ntasks, nimages, natoms, maxset,maxpgf, & - tasks, use_reordered_ranks=.FALSE., error=error) + tasks, use_reordered_ranks=.FALSE.) replicated_load = replicated_load + SUM(loads(:,igrid_level)) END IF END DO @@ -2102,7 +2076,7 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, fixed_first_grid = .TRUE. ELSE ALLOCATE (trial_loads(0:desc%group_size-1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) trial_loads(:) = total_loads + loads(:,igrid_level) max_load = MAXVAL(trial_loads) @@ -2116,13 +2090,13 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, IF (load_gap > replicated_load * 1.05_dp) THEN ALLOCATE (INDEX(0:desc%group_size-1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (total_index(0:desc%group_size-1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (total_loads_tmp(0:desc%group_size-1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (real2virtual(0:desc%group_size-1),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) total_loads_tmp(:) = total_loads CALL sort(total_loads_tmp, desc%group_size, total_index) @@ -2136,22 +2110,22 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, real2virtual(total_index(irank)-1)=INDEX(desc%group_size - irank - 1) - 1 END DO - CALL rs_grid_reorder_ranks(rs_descs(igrid_level)%rs_desc, real2virtual, error) + CALL rs_grid_reorder_ranks(rs_descs(igrid_level)%rs_desc, real2virtual) DEALLOCATE (index,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (total_index,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (total_loads_tmp,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (real2virtual,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE total_loads(:) = trial_loads ENDIF DEALLOCATE (trial_loads,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDIF @@ -2159,12 +2133,12 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, END IF ! Now we use the replicated tasks to balance out the rest of the load - CALL load_balance_replicated(rs_descs, ntasks, tasks, nimages, natoms, maxset, maxpgf, error) + CALL load_balance_replicated(rs_descs, ntasks, tasks, nimages, natoms, maxset, maxpgf) !total_loads = 0 !DO igrid_level=1,SIZE(rs_descs) ! CALL get_current_loads(loads(:,igrid_level), rs_descs, igrid_level, ntasks, nimages, natoms, maxset,maxpgf, & - ! tasks, use_reordered_ranks=.TRUE. , error=error) + ! tasks, use_reordered_ranks=.TRUE.) ! total_loads = total_loads + loads(:, igrid_level) !END DO @@ -2177,17 +2151,17 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, !ENDIF ! given a list of tasks, this will do the needed reshuffle so that all tasks will be local - CALL create_local_tasks ( rs_descs, ntasks, tasks, rval, ntasks_recv, tasks_recv, rval_recv, error) + CALL create_local_tasks ( rs_descs, ntasks, tasks, rval, ntasks_recv, tasks_recv, rval_recv) ! ! tasks list are complete, we can compute the list of atomic blocks (atom pairs) ! we will be sending. These lists are needed for redistribute_matrix. ! ALLOCATE (atom_pair_send(ntasks),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL get_atom_pair ( atom_pair_send, tasks, send=.TRUE.,& symmetric=symmetric, natoms=natoms, maxset=maxset, maxpgf=maxpgf, & - nimages=nimages, rs_descs=rs_descs, error=error ) + nimages=nimages, rs_descs=rs_descs) ! natom_send=SIZE(atom_pair_send) ! CALL mp_sum(natom_send,desc%group) @@ -2197,20 +2171,20 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, ! ENDIF ALLOCATE (atom_pair_recv(ntasks_recv),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) CALL get_atom_pair ( atom_pair_recv, tasks_recv, send=.FALSE.,& symmetric=symmetric, natoms=natoms, maxset=maxset, maxpgf=maxpgf, & - nimages=nimages, rs_descs=rs_descs, error=error ) + nimages=nimages, rs_descs=rs_descs) ! cleanup, at this point we don't need the original tasks & rvals anymore DEALLOCATE (tasks,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (rval,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (loads,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (total_loads,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ELSE @@ -2227,9 +2201,9 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, rval => rval_recv ALLOCATE (taskid(ntasks_recv),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (INDEX(ntasks_recv),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) taskid(:)=tasks_recv(3,1:ntasks_recv) CALL sort(taskid,SIZE(taskid),index) @@ -2243,9 +2217,9 @@ SUBROUTINE distribute_tasks ( rs_descs, ntasks, natoms, maxset, maxpgf, nimages, ENDDO DEALLOCATE (taskid,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (index,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! ! final lists are ready @@ -2269,10 +2243,9 @@ END SUBROUTINE distribute_tasks !> \param maxpgf ... !> \param nimages ... !> \param rs_descs ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_atom_pair ( atom_pair, my_tasks, send, symmetric, natoms, maxset, & - maxpgf, nimages, rs_descs, error) + maxpgf, nimages, rs_descs) INTEGER(KIND=int_8), DIMENSION(:), & POINTER :: atom_pair @@ -2283,7 +2256,6 @@ SUBROUTINE get_atom_pair ( atom_pair, my_tasks, send, symmetric, natoms, maxset, nimages TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_atom_pair', & routineP = moduleN//':'//routineN @@ -2332,13 +2304,13 @@ SUBROUTINE get_atom_pair ( atom_pair, my_tasks, send, symmetric, natoms, maxset, ENDDO ALLOCATE (INDEX(SIZE(atom_pair)),STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) ! find unique atom pairs that I'm sending/receiving CALL sort(atom_pair,SIZE(atom_pair),index) DEALLOCATE (index,STAT=stat) - CPPrecondition(stat==0,cp_failure_level,routineP,error,failure) + CPPrecondition(stat==0,cp_failure_level,routineP,failure) IF (SIZE(atom_pair)>1) THEN j=1 @@ -2367,10 +2339,9 @@ END SUBROUTINE get_atom_pair !> \param nimages ... !> \param scatter ... !> \param hmats ... -!> \param error ... ! ***************************************************************************** SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv, & - natoms, nimages, scatter, hmats, error ) + natoms, nimages, scatter, hmats) TYPE(realspace_grid_desc_p_type), & DIMENSION(:), POINTER :: rs_descs @@ -2382,7 +2353,6 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv LOGICAL :: scatter TYPE(cp_dbcsr_p_type), DIMENSION(:), & OPTIONAL, POINTER :: hmats - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rs_distribute_matrix', & routineP = moduleN//':'//routineN @@ -2405,7 +2375,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv failure = .FALSE. IF (.not.scatter) THEN - CPPrecondition(PRESENT(hmats),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(hmats),cp_failure_level,routineP,failure) END IF desc => rs_descs(1)%rs_desc @@ -2413,21 +2383,21 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv ! allocate local arrays ALLOCATE (send_sizes(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_sizes(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (send_disps(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_disps(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (send_pair_count(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_pair_count(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (send_pair_disps(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (recv_pair_disps(desc%group_size),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) pmat => pmats(1)%matrix CALL cp_dbcsr_get_info (pmat, & @@ -2435,7 +2405,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv nblkcols_total=nblkcols_total) ALLOCATE (first_row(nblkrows_total), last_row(nblkrows_total),& first_col(nblkcols_total), last_col(nblkcols_total),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL convert_sizes_to_offsets (cp_dbcsr_row_block_sizes(pmat), first_row, last_row) CALL convert_sizes_to_offsets (cp_dbcsr_col_block_sizes(pmat), first_col, last_col) ! set up send buffer sizes @@ -2470,7 +2440,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv ENDDO ALLOCATE (send_buf_r(SUM(send_sizes)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! set up recv buffer @@ -2501,7 +2471,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv recv_pair_disps(i) = recv_pair_disps(i-1) + recv_pair_count(i-1) ENDDO ALLOCATE (recv_buf_r(SUM(recv_sizes)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$omp parallel default(none), & !$omp shared(desc,send_pair_count,send_pair_disps,natom8,nim8,nimages),& @@ -2511,7 +2481,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv !$omp shared(atom_pair_recv,recv_buf_r,scatter,recv_pair_disps), & !$omp shared(recv_sizes,recv_disps,recv_pair_count,locks), & !$omp private(i,img,pair,arow,acol,nrow,ncol,p_block,found,j,k,l),& -!$omp private(nthread,h_block,error,nthread_left,hmat,pmat,failure),& +!$omp private(nthread,h_block,nthread_left,hmat,pmat,failure),& !$omp private(stat) nthread = 1 @@ -2537,7 +2507,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv pmat => pmats(img)%matrix CALL cp_dbcsr_get_block_p(matrix=pmat,row=arow,col=acol,& block=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) DO k = 1, ncol DO j = 1, nrow @@ -2588,10 +2558,10 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv pmat => pmats(img)%matrix CALL cp_dbcsr_get_block_p(matrix=hmat,row=arow,col=acol,& BLOCK=h_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) CALL cp_dbcsr_get_block_p(matrix=pmat,row=arow,col=acol,& BLOCK=p_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) !$ call omp_set_lock(locks((arow-1)*nthread*10/nblkrows_total+1)) DO k = 1, ncol @@ -2608,7 +2578,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv pmat => pmats(img)%matrix CALL cp_dbcsr_work_create(pmat,work_mutable=.TRUE.,& nblks_guess=SIZE(atom_pair_recv)/nthread,sizedata_guess=SIZE(recv_buf_r)/nthread,& - n=nthread,error=error) + n=nthread) END DO END IF @@ -2639,7 +2609,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv hmat => hmats(img)%matrix CALL cp_dbcsr_get_block_p(matrix=hmat,row=arow,col=acol,& BLOCK=h_block,found=found) - CPPostcondition(found,cp_failure_level,routineP,error,failure) + CPPostcondition(found,cp_failure_level,routineP,failure) ENDIF IF(scatter .AND. .NOT. ASSOCIATED(p_block)) THEN @@ -2671,7 +2641,7 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv !$omp single !$ IF (.not.scatter) THEN !$ DEALLOCATE (locks,STAT=stat) -!$ CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) +!$ CPPostcondition(stat==0,cp_failure_level,routineP,failure) !$ END IF !$omp end single nowait @@ -2679,35 +2649,35 @@ SUBROUTINE rs_distribute_matrix( rs_descs, pmats, atom_pair_send, atom_pair_recv ! Blocks were added to P DO img=1,nimages pmat => pmats(img)%matrix - CALL cp_dbcsr_finalize(pmat, error=error) + CALL cp_dbcsr_finalize(pmat) END DO END IF !$omp end parallel DEALLOCATE (send_buf_r,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_buf_r,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (send_sizes,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_sizes,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (send_disps,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_disps,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (send_pair_count,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_pair_count,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (send_pair_disps,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (recv_pair_disps,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE (first_row, last_row, first_col, last_col, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -2724,14 +2694,13 @@ END SUBROUTINE rs_distribute_matrix !> \param lb_cube ... !> \param ub_cube ... !> \param added_tasks ... -!> \param error ... !> \par History !> 11.2007 created [MattW] !> 10.2008 rewritten [Joost VandeVondele] !> \author MattW ! ***************************************************************************** SUBROUTINE rs_find_node(rs_desc,igrid_level,n_levels,cube_center,ntasks,tasks,& - lb_cube,ub_cube,added_tasks,error) + lb_cube,ub_cube,added_tasks) TYPE(realspace_grid_desc_type), POINTER :: rs_desc INTEGER, INTENT(IN) :: igrid_level, n_levels @@ -2741,7 +2710,6 @@ SUBROUTINE rs_find_node(rs_desc,igrid_level,n_levels,cube_center,ntasks,tasks,& POINTER :: tasks INTEGER, DIMENSION(3), INTENT(IN) :: lb_cube, ub_cube INTEGER, INTENT(OUT) :: added_tasks - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rs_find_node', & routineP = moduleN//':'//routineN diff --git a/src/task_list_types.F b/src/task_list_types.F index 717a394055..4e42792e9e 100644 --- a/src/task_list_types.F +++ b/src/task_list_types.F @@ -41,13 +41,11 @@ MODULE task_list_types ! ***************************************************************************** !> \brief allocates and initialised the components of the task_list_type !> \param task_list ... -!> \param error ... !> \par History !> 01.2008 created [Joost VandeVondele] ! ***************************************************************************** -SUBROUTINE allocate_task_list(task_list,error) +SUBROUTINE allocate_task_list(task_list) TYPE(task_list_type), POINTER :: task_list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_task_list', & routineP = moduleN//':'//routineN @@ -56,7 +54,7 @@ SUBROUTINE allocate_task_list(task_list,error) LOGICAL :: failure ALLOCATE(task_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(task_list%tasks) NULLIFY(task_list%dist_ab) @@ -71,13 +69,11 @@ END SUBROUTINE allocate_task_list ! ***************************************************************************** !> \brief deallocates the components and the object itself !> \param task_list ... -!> \param error ... !> \par History !> 01.2008 created [Joost VandeVondele] ! ***************************************************************************** -SUBROUTINE deallocate_task_list(task_list,error) +SUBROUTINE deallocate_task_list(task_list) TYPE(task_list_type), POINTER :: task_list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_task_list', & routineP = moduleN//':'//routineN @@ -87,34 +83,34 @@ SUBROUTINE deallocate_task_list(task_list,error) IF (ASSOCIATED(task_list%tasks)) THEN DEALLOCATE(task_list%tasks,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(task_list%dist_ab)) THEN DEALLOCATE(task_list%dist_ab,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(task_list%atom_pair_send)) THEN DEALLOCATE(task_list%atom_pair_send,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(task_list%atom_pair_recv)) THEN DEALLOCATE(task_list%atom_pair_recv,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(task_list%taskstart)) THEN DEALLOCATE(task_list%taskstart,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(task_list%taskstop)) THEN DEALLOCATE(task_list%taskstop,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF IF (ASSOCIATED(task_list%npairs)) THEN DEALLOCATE(task_list%npairs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DEALLOCATE(task_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE deallocate_task_list END MODULE task_list_types diff --git a/src/tmc/input_cp2k_tmc.F b/src/tmc/input_cp2k_tmc.F index 148c234adb..405244b557 100644 --- a/src/tmc/input_cp2k_tmc.F +++ b/src/tmc/input_cp2k_tmc.F @@ -39,13 +39,10 @@ MODULE input_cp2k_tmc ! ***************************************************************************** !> \brief creates the TreeMonteCarlo subsection !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes ! ***************************************************************************** - SUBROUTINE create_TMC_section(section, error) + SUBROUTINE create_TMC_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_TMC_section', & routineP = moduleN//':'//routineN @@ -56,10 +53,10 @@ SUBROUTINE create_TMC_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="TMC",& description="A parallelized MC algorithm, presampling the configurations, espacially the Markov chain elements",& - n_keywords=1, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) NULLIFY(keyword, subsection) @@ -68,71 +65,70 @@ SUBROUTINE create_TMC_section(section, error) name="GROUP_ENERGY_SIZE",& description="amount of CPUs per group for energy calculation",& usage="GROUP_ENERGY_SIZE {INTEGER}",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! size of a group calculating the exact energy CALL keyword_create(keyword=keyword,& name="GROUP_ENERGY_NR",& description="amount of groups for exact energy calculation",& usage="GROUP_ENERGY_NR {INTEGER}",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! size of a group calculating the exact energy CALL keyword_create(keyword=keyword,& name="GROUP_CC_SIZE",& description="amount of of CPUs per group for configurational change",& usage="GROUP_CC_SIZE {INTEGER}",& - default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! size of a group calculating the exact energy CALL keyword_create(keyword=keyword,& name="GROUP_ANLYSIS_NR",& description="amount of groups (cores) for analysing the configurations",& usage="GROUP_ANALYSIS_NR {INTEGER}",& - default_i_val=1, lone_keyword_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1, lone_keyword_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="NUM_MC_ELEM",& description="the minimum Markov Chain elements, to be sampled",& usage="NUM_MC_ELEM {INTEGER}",& - default_i_val=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! the start value for the random number generator CALL keyword_create(keyword=keyword,& name="RND_DETERMINISTIC",& description="the initialisation number for the random number generator",& usage="RND_INIT {INTEGER}",& - default_i_val=-1,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="TASK_TYPE",& description="Select specialized types. Selectable:"//& "IDEAL_GAS (constant configuration energy E=0.0), ",& usage="TASK_TYPE {OPTION}",& - default_c_val="", lone_keyword_c_val=tmc_default_unspecified_name,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="", lone_keyword_c_val=tmc_default_unspecified_name) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="NR_TEMPERATURE",& description="the number of different temperature for parallel tempering",& usage="NR_TEMP {INTEGER}",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, & name="TEMPERATURE",& @@ -142,9 +138,9 @@ SUBROUTINE create_TMC_section(section, error) "do NOT use keyword NR_TEMPERATURE",& usage="TEMPERATURE {REAL} |OR| TEMPERATURE {REAL} {REAL} ...",& default_r_vals=(/330.0_dp/), & - n_var=-1,type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="NUM_MV_ELEM_IN_CELL",& @@ -152,28 +148,28 @@ SUBROUTINE create_TMC_section(section, error) "moves in cell or sub box."//& "if 0 all elements are moved once in a MC move",& usage="NUM_MV_ELEM_IN_CELL {INTEGER}",& - default_i_val=0, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=0) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword=keyword,& ! name="NR_NMC_STEPS",& ! description="the number of Nested Mont Carlo moves with in one MC move "//& ! "should be huge enough to reach euilibrium state", & ! usage="NR_NMC_STEPS {INTEGER}",& -! default_i_val=-1, error=error) -! CALL section_add_keyword(section,keyword,error=error) -! CALL keyword_release(keyword,error=error) +! default_i_val=-1) +! CALL section_add_keyword(section,keyword) +! CALL keyword_release(keyword) ! the moves MOVE_TYPE on exact potential - CALL create_TMC_move_type_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_TMC_move_type_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) ! the moves MOVE_TYPE on approx potential - CALL create_TMC_NMC_move_type_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_TMC_NMC_move_type_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword, & name="SUB_BOX",& @@ -182,84 +178,83 @@ SUBROUTINE create_TMC_section(section, error) "to compensate the potential difference of the approximate potential.", & usage="SUB_BOX {REAL} {REAL} {REAL} OR SUB_BOX {REAL} for cubic",& default_r_vals=(/-1.0_dp/), & - n_var=-1,type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRESSURE",& description="enables NPT calculation with specified constant pressure [bar]", & usage="PRESSURE {REAL}",& - default_r_val=-1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="VOLUME_ISOTROPIC",& description="volume move is equal in each direction", & usage="VOLUME_ISOTROPIC {LOGICAL}",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="MOVE_CENTER_OF_MASS",& description="Moves the center of mass of defined molecules (in volume moves)", & usage="MOVE_CENTER_OF_MASS {LOGICAL}",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, & name="ESIMATE_ACC_PROB",& description="set the estimation of the acceptance probability using run time information of the energy", & usage="ESIMATE_ACC_PROB {LOGICAL}",& - default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="SPECULATIVE_CANCELING",& description="enables or disables the speculative canceling. If we have further knowledge of "//& "acceptance probabilities using parent acceptance or the estimated energy.",& usage="SPECULATIVE_CANCELING {LOGICAL}",& - default_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="USE_SCF_ENERGY_INFO",& description="enables or disables the usage of SCF energy information for "//& " estimating the acceptance probability. ",& usage="USE_SCF_ENERGY_INFO {LOGICAL}",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="RESULT_LIST_IN_MEMORY",& description="enables the storing of the whole Markov Chain", & usage="RESULT_LIST_IN_MEMORY {LOGICAL}",& - default_l_val=.FALSE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="INFO_OUT_STEP_SIZE",& description="the number the amount of calculated configurations between to output printings.",& usage="INFO_OUT_STEP_SIZE {INTEGER}",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="RESTART_IN",& description="if existing use the last restart file", & usage="RESTART or RSTART {FILENAME}",& - default_c_val="", lone_keyword_c_val=tmc_default_unspecified_name,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="", lone_keyword_c_val=tmc_default_unspecified_name) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="RESTART_OUT",& @@ -270,104 +265,102 @@ SUBROUTINE create_TMC_section(section, error) "The frequency specifies is related "//& "to the calculated Markov chain elements",& usage="RESTART or RESTART {INTEGER}",& - default_i_val=-1, lone_keyword_i_val=-9,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1, lone_keyword_i_val=-9) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ENERGY_FILE_NAME",& description="input file name for the exact potential energy calculation.",& usage="ENERGY_FILE_NAME {filename}",& - default_c_val="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! CALL keyword_create(keyword, name="NMC_FILE_NAME",& ! description="input file name for the approximate potential for Nested Monte Carlo.",& ! usage="NMC_FILE_NAME {filename}",& -! default_c_val="",lone_keyword_c_val=tmc_default_unspecified_name,& -! error=error) -! CALL section_add_keyword(section,keyword,error=error) -! CALL keyword_release(keyword,error=error) +! default_c_val="",lone_keyword_c_val=tmc_default_unspecified_name) +! CALL section_add_keyword(section,keyword) +! CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRINT_ONLY_ACC",& description="printing only accepted elements of the Markov Chain.", & usage="PRINT_ONLY_ACC {LOGICAL}",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRINT_COORDS",& description="printing coordinates of the Markov Chain elements", & usage="PRINT_COORDS {LOGICAL}",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRINT_FORCES",& description="printing forces of the Markov Chain elements", & usage="PRINT_FORCES {LOGICAL}",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRINT_DIPOLE",& description="enables the calculation and printing the exact cell dipoles"//& " (only for QS methods)", & usage="PRINT_DIPOLE {LOGICAL}",& - default_l_val=.FALSE.,lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRINT_CELL",& description="printing the cell vectors of the Markov Chain elements", & usage="PRINT_CELL {LOGICAL}",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRINT_ENERGIES",& description="printing the different calculated energies (approximated, scf and exact)", & usage="PRINT_ENERGIES {LOGICAL}",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DOT_TREE",& description="file name for GrapgViz dot file",& usage="DOT_TREE {filename}",& - default_c_val="", lone_keyword_c_val=tmc_default_dot_file_name,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="", lone_keyword_c_val=tmc_default_dot_file_name) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ALL_CONF_FILE_NAME",& description="file name for printing every single calculated configuration (e.g. for fitting).",& usage="ALL_CONF_FILE_NAME {filename}",& - default_lc_val="",error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_lc_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="PRINT_TEST_OUTPUT",& description="printing different values for regtest comparison", & usage="PRINT_TEST_OUTPUT {LOGICAL}",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) - CALL create_TMC_ana_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_TMC_ana_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) - CALL create_TMC_ana_files(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_TMC_ana_files(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_TMC_section @@ -375,13 +368,10 @@ END SUBROUTINE create_TMC_section !> \brief creates the TMC section to select the move types performed within the !> NMC (on approximate potential) !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes ! ***************************************************************************** - SUBROUTINE create_TMC_NMC_move_type_section(section, error) + SUBROUTINE create_TMC_NMC_move_type_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'create_TMC_NMC_move_type_section', & @@ -394,13 +384,12 @@ SUBROUTINE create_TMC_NMC_move_type_section(section, error) failure=.FALSE. NULLIFY(subsection) - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="NMC_MOVES",& description="This section specifies the TMC move types, "//& "which are performed within the nested Monte Carlo (NMC). "//& "thus using the approximate potential.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) @@ -409,17 +398,16 @@ SUBROUTINE create_TMC_NMC_move_type_section(section, error) description="the number of Nested Mont Carlo moves with in one MC move "//& "should be huge enough to reach euilibrium state", & usage="NR_NMC_STEPS {INTEGER}",& - default_i_val=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="NMC_FILE_NAME",& description="input file name for the approximate potential for Nested Monte Carlo.",& usage="NMC_FILE_NAME {filename}",& - default_c_val="",lone_keyword_c_val=tmc_default_unspecified_name,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="",lone_keyword_c_val=tmc_default_unspecified_name) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROB",& description="Defines the probability of the NMC move "//& @@ -427,33 +415,30 @@ SUBROUTINE create_TMC_NMC_move_type_section(section, error) "the probabilities of the move types in the NMC section "//& "defines only the weight within the NMC steps",& usage="PROB {real}", type_of_var=real_t,& - default_r_val=1.0_dp, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INIT_ACC_PROB",& description="Defines the initial probability of accepting the move. ",& usage="INIT_ACC_PROB {real}", type_of_var=real_t,& - default_r_val=0.5_dp, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.5_dp, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! the moves types - CALL create_TMC_move_type_section(subsection, error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_TMC_move_type_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) END SUBROUTINE create_TMC_NMC_move_type_section ! ***************************************************************************** !> \brief creates the TMC section to select the move types !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes ! ***************************************************************************** - SUBROUTINE create_TMC_move_type_section(section, error) + SUBROUTINE create_TMC_move_type_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_TMC_move_type_section', & routineP = moduleN//':'//routineN @@ -463,7 +448,7 @@ SUBROUTINE create_TMC_move_type_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="MOVE_TYPE",& description="This section specifies the TMC move type, "//& "and its properties. "//& @@ -475,16 +460,15 @@ SUBROUTINE create_TMC_move_type_section(section, error) "PT_SWAP Parallel Tempering swap, "//& "VOL_MOVE volume change, "//& "ATOM_SWAP swaps two atoms of different type.",& - n_keywords=1, n_subsections=0, repeats=.TRUE., & - error=error) + n_keywords=1, n_subsections=0, repeats=.TRUE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="The name of the move type described in this section.",& - usage="ATOM_TRANS", default_c_val="DEFAULT", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + usage="ATOM_TRANS", default_c_val="DEFAULT") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="SIZE",& description="Defines the size of the move:"//& @@ -495,32 +479,32 @@ SUBROUTINE create_TMC_move_type_section(section, error) "VOL_MOVE [A], "//& "ATOM_SWAP",& usage="SIZE {real}", type_of_var=real_t,& - default_r_val=-1.0_dp, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=-1.0_dp, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PROB",& description="Defines the probability of the move "//& "(considering the ration between the selected moves)",& usage="PROB {real}", type_of_var=real_t,& - default_r_val=1.0_dp, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=1.0_dp, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="INIT_ACC_PROB",& description="Defines the initial probability of accepting the move. ",& usage="INIT_ACC_PROB {real}", type_of_var=real_t,& - default_r_val=0.23_dp, n_var=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_r_val=0.23_dp, n_var=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="ATOMS",& description="Defines the atomic kinds involved in the move. "//& "Up to now only used for the atom swap.",& usage="ATOMS {KIND1} {KIND2} ... ", type_of_var=char_t,& - n_var=-1, repeats=.TRUE., error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1, repeats=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) @@ -529,13 +513,10 @@ END SUBROUTINE create_TMC_move_type_section ! ***************************************************************************** !> \brief creates the TreeMonteCarlo subsection !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes ! ***************************************************************************** - SUBROUTINE create_TMC_ana_section(section, error) + SUBROUTINE create_TMC_ana_section(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_TMC_ana_section', & routineP = moduleN//':'//routineN @@ -544,25 +525,22 @@ SUBROUTINE create_TMC_ana_section(section, error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="TMC_ANALYSIS",& description="Analysing the Markov Chain elments with the specified methods",& - n_keywords=1, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) - CALL create_TMC_ana_kinds(section=section, error=error) + CALL create_TMC_ana_kinds(section=section) END SUBROUTINE create_TMC_ana_section ! ***************************************************************************** !> \brief creates the TreeMonteCarlo subsection !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes ! ***************************************************************************** - SUBROUTINE create_TMC_ana_files(section, error) + SUBROUTINE create_TMC_ana_files(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_TMC_ana_files', & routineP = moduleN//':'//routineN @@ -573,21 +551,21 @@ SUBROUTINE create_TMC_ana_files(section, error) NULLIFY(keyword) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(section),cp_failure_level,routineP,failure) CALL section_create(section,name="TMC_ANALYSIS_FILES",& description="Analysing the Markov Chain elments with the specified methods, "//& "reading form default or specified files",& - n_keywords=1, n_subsections=1, repeats=.FALSE., error=error) + n_keywords=1, n_subsections=1, repeats=.FALSE.) - CALL create_TMC_ana_kinds(section=section, error=error) + CALL create_TMC_ana_kinds(section=section) CALL keyword_create(keyword=keyword,& name="NR_TEMPERATURE",& description="the number of different temperature for parallel tempering",& usage="NR_TEMP {INTEGER}",& - default_i_val=1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, & name="TEMPERATURE",& @@ -597,9 +575,9 @@ SUBROUTINE create_TMC_ana_files(section, error) "do NOT use keyword NR_TEMPERATURE",& usage="TEMPERATURE {REAL} |OR| TEMPERATURE {REAL} {REAL} ...",& default_r_vals=(/330.0_dp/), & - n_var=-1,type_of_var=real_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=real_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, & name="DIRECTORIES",& @@ -607,71 +585,64 @@ SUBROUTINE create_TMC_ana_files(section, error) "created by standard parallel MC (e.g. using TMC farming ",& usage="DIRECTORIES {DIR1/} {DIR2/} ...",& default_c_vals=(/"./"/), & - n_var=-1,type_of_var=char_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=char_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="FORCE_ENV_FILE",& description="input file name for force env, "//& "to get initial configuration with dimensions and cell",& usage="FORCE_ENV_FILE {filename}",& - default_c_val="",lone_keyword_c_val="",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="",lone_keyword_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="POSITION_FILE",& description="file name for analysing the position file",& usage="POSITION_FILE {filename}",& - default_c_val="",lone_keyword_c_val="",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="",lone_keyword_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="CELL_FILE",& description="file name for analysing the cell file",& usage="CELL_FILE {filename}",& - default_c_val="",lone_keyword_c_val="",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="",lone_keyword_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="DIPOLE_FILE",& description="file name for analysing the dipole file",& usage="DIPOLE_FILE {filename}",& - default_c_val="",lone_keyword_c_val="",& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="",lone_keyword_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="START_ELEM",& description="start analysis at element with number #",& usage="START_ELEM {INTEGER}",& - default_i_val=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="END_ELEM",& description="end analysis at element with number #",& usage="END_ELEM {INTEGER}",& - default_i_val=-1, error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_TMC_ana_files ! ***************************************************************************** !> \brief creates the TreeMonteCarlo subsection !> \param section the section to be created -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes ! ***************************************************************************** - SUBROUTINE create_TMC_ana_kinds(section, error) + SUBROUTINE create_TMC_ana_kinds(section) TYPE(section_type), POINTER :: section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_TMC_ana_kinds', & routineP = moduleN//':'//routineN @@ -689,36 +660,34 @@ SUBROUTINE create_TMC_ana_kinds(section, error) description="Enables/disables the reading and writing of "//& " analysis restart files ", & usage="RESTART {LOGICAL}",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="PREFIX_ANA_FILES",& description="specifies a prefix for all analysis files.",& usage="ANA_FILES_PREFIX {prefix}",& - default_c_val="", error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="DENSITY",& description="Mass density in the simulation cell, or if specified in sub cubes",& usage="DENSITY or DENSITY {INTEGER} {INTEGER} {INTEGER}",& default_i_vals=(/1/), & - n_var=-1,type_of_var=integer_t,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + n_var=-1,type_of_var=integer_t) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="G_R",& description="Radial Distribution Function for each pair of atoms"//& "using the amount of specified bins within MAX(cell_lenght)/2",& usage="G_R or G_R {INTEGER}",& - default_i_val=-1, lone_keyword_i_val=-1, & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_i_val=-1, lone_keyword_i_val=-1) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="CLASSICAL_DIPOLE_MOMENTS",& @@ -726,15 +695,14 @@ SUBROUTINE create_TMC_ana_kinds(section, error) "Following flag specifies if they should be written. "//& "Class. Dip. Mom. are also used to unfold the exact dipole moment. ",& usage="CLASSICAL_DIPOLE_MOMENTS or CLASSICAL_DIPOLE_MOMENTS {LOGICAL}",& - default_l_val=.TRUE., lone_keyword_l_val=.TRUE., & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.TRUE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) ! for calculating the classical dipole moment we need charges - CALL create_CHARGE_section(subsection, error=error) - CALL section_add_subsection(section, subsection, error=error) - CALL section_release(subsection,error=error) + CALL create_CHARGE_section(subsection) + CALL section_add_subsection(section, subsection) + CALL section_release(subsection) CALL keyword_create(keyword=keyword,& name="DIPOLE_ANALYSIS",& @@ -744,19 +712,17 @@ SUBROUTINE create_TMC_ana_kinds(section, error) "are regarded, only use it if this configurations have "//& "all the same energy. ", & usage="DIPOLE_ANALYSIS or DIPOLE_ANALYSIS {type}",& - default_c_val="", lone_keyword_c_val=tmc_default_unspecified_name,& - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_c_val="", lone_keyword_c_val=tmc_default_unspecified_name) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword=keyword,& name="DEVIATION",& description="Calculates the deviation of the position from the last configuration",& usage="DEVIATION {LOGICAL}",& - default_l_val=.FALSE., lone_keyword_l_val=.TRUE., & - error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) + default_l_val=.FALSE., lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_TMC_ana_kinds END MODULE input_cp2k_tmc diff --git a/src/tmc/tmc_analysis.F b/src/tmc/tmc_analysis.F index c576ced126..c5da9b190a 100644 --- a/src/tmc/tmc_analysis.F +++ b/src/tmc/tmc_analysis.F @@ -81,14 +81,11 @@ MODULE tmc_analysis !> \brief creates a new para environment for tmc analysis !> \param tmc_ana_section ... !> \param tmc_ana TMC analysis environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_read_ana_input(tmc_ana_section, tmc_ana, error) + SUBROUTINE tmc_read_ana_input(tmc_ana_section, tmc_ana) TYPE(section_vals_type), POINTER :: tmc_ana_section TYPE(tmc_analysis_env), POINTER :: tmc_ana - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tmc_read_ana_input', & routineP = moduleN//':'//routineN @@ -106,38 +103,38 @@ SUBROUTINE tmc_read_ana_input(tmc_ana_section, tmc_ana, error) NULLIFY(tmp_section, charge_atm, i_arr_tmp, charge) - CPPrecondition(ASSOCIATED(tmc_ana_section),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_ana_section),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) - CALL section_vals_get(tmc_ana_section,explicit=explicit,error=error) + CALL section_vals_get(tmc_ana_section,explicit=explicit) IF(explicit) THEN - CALL tmc_ana_env_create(tmc_ana=tmc_ana, error=error) + CALL tmc_ana_env_create(tmc_ana=tmc_ana) ! restarting - CALL section_vals_val_get(tmc_ana_section,"RESTART",l_val=tmc_ana%restart,error=error) + CALL section_vals_val_get(tmc_ana_section,"RESTART",l_val=tmc_ana%restart) ! file name prefix CALL section_vals_val_get(tmc_ana_section,"PREFIX_ANA_FILES",& - c_val=tmc_ana%out_file_prefix, error=error) + c_val=tmc_ana%out_file_prefix) IF(tmc_ana%out_file_prefix .NE. "")THEN tmc_ana%out_file_prefix = TRIM(tmc_ana%out_file_prefix)//"_" END IF ! density calculation - CALL section_vals_val_get(tmc_ana_section,"DENSITY" ,explicit=explicit_key,error=error) + CALL section_vals_val_get(tmc_ana_section,"DENSITY" ,explicit=explicit_key) IF(explicit_key)THEN - CALL section_vals_val_get(tmc_ana_section,"DENSITY",i_vals=i_arr_tmp,error=error) + CALL section_vals_val_get(tmc_ana_section,"DENSITY",i_vals=i_arr_tmp) IF(SIZE(i_arr_tmp(:)).EQ.3)THEN CALL cp_assert(ALL(i_arr_tmp(:).GT.0),& cp_failure_level,cp_assertion_failed,routineP,& "The amount of intervals in each direction has to be greater than 0.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) nr_bins(:) = i_arr_tmp(:) ELSE IF(SIZE(i_arr_tmp(:)).EQ.1) THEN CALL cp_assert(ALL(i_arr_tmp(:).GT.0),& cp_failure_level,cp_assertion_failed,routineP,& "The amount of intervals has to be greater than 0.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) nr_bins(:) = i_arr_tmp(1) ELSE IF(SIZE(i_arr_tmp(:)).EQ.0) THEN nr_bins(:) = 1 @@ -145,49 +142,49 @@ SUBROUTINE tmc_read_ana_input(tmc_ana_section, tmc_ana, error) CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "unknown amount of dimentions for the binning.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) END IF - CALL tmc_ana_density_create(tmc_ana%density_3d, nr_bins, error) + CALL tmc_ana_density_create(tmc_ana%density_3d, nr_bins) END IF ! radial distribution function calculation - CALL section_vals_val_get(tmc_ana_section,"G_R" ,explicit=explicit_key,error=error) + CALL section_vals_val_get(tmc_ana_section,"G_R" ,explicit=explicit_key) IF(explicit_key)THEN - CALL section_vals_val_get(tmc_ana_section,"G_R",i_val=i_tmp,error=error) + CALL section_vals_val_get(tmc_ana_section,"G_R",i_val=i_tmp) CALL tmc_ana_pair_correl_create(ana_pair_correl=tmc_ana%pair_correl, & - nr_bins=i_tmp, error=error) + nr_bins=i_tmp) END IF ! radial distribution function calculation - CALL section_vals_val_get(tmc_ana_section,"CLASSICAL_DIPOLE_MOMENTS" ,explicit=explicit_key,error=error) + CALL section_vals_val_get(tmc_ana_section,"CLASSICAL_DIPOLE_MOMENTS" ,explicit=explicit_key) IF(explicit_key)THEN ! charges for dipoles needed - tmp_section => section_vals_get_subs_vals(tmc_ana_section,"CHARGE",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=i_tmp,error=error) + tmp_section => section_vals_get_subs_vals(tmc_ana_section,"CHARGE") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=i_tmp) IF (explicit) THEN ntot=0 ALLOCATE(charge_atm(i_tmp)) ALLOCATE(charge(i_tmp)) - CALL read_chrg_section(charge_atm,charge,tmp_section,ntot,error) + CALL read_chrg_section(charge_atm,charge,tmp_section,ntot) ELSE CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "to calculate the classical cell dipole moment "// & "the charges has to be specified",& - error, failure=flag) + failure=flag) END IF CALL tmc_ana_dipole_moment_create(tmc_ana%dip_mom, charge_atm,charge,& - tmc_ana%dim_per_elem, error) + tmc_ana%dim_per_elem) IF(ASSOCIATED(charge_atm)) DEALLOCATE(charge_atm) IF(ASSOCIATED(charge)) DEALLOCATE(charge) END IF ! dipole moment analysis - CALL section_vals_val_get(tmc_ana_section,"DIPOLE_ANALYSIS" ,explicit=explicit_key,error=error) + CALL section_vals_val_get(tmc_ana_section,"DIPOLE_ANALYSIS" ,explicit=explicit_key) IF(explicit_key)THEN - CALL tmc_ana_dipole_analysis_create(tmc_ana%dip_ana, error) - CALL section_vals_val_get(tmc_ana_section,"DIPOLE_ANALYSIS",c_val=c_tmp,error=error) + CALL tmc_ana_dipole_analysis_create(tmc_ana%dip_ana) + CALL section_vals_val_get(tmc_ana_section,"DIPOLE_ANALYSIS",c_val=c_tmp) SELECT CASE (TRIM(c_tmp)) CASE (TRIM(tmc_default_unspecified_name)) tmc_ana%dip_ana%ana_type = ana_type_default @@ -200,7 +197,7 @@ SUBROUTINE tmc_read_ana_input(tmc_ana_section, tmc_ana, error) cp_warning_level,cp_assertion_failed,routineP,& 'unknown analysis type "'//TRIM(c_tmp)//'" specified. '//& " Set to default.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) tmc_ana%dip_ana%ana_type = ana_type_default END SELECT END IF @@ -208,10 +205,10 @@ SUBROUTINE tmc_read_ana_input(tmc_ana_section, tmc_ana, error) END IF ! cell displacement (deviation) - CALL section_vals_val_get(tmc_ana_section,"DEVIATION",l_val=flag,error=error) + CALL section_vals_val_get(tmc_ana_section,"DEVIATION",l_val=flag) IF(flag) THEN CALL tmc_ana_displacement_create(ana_disp=tmc_ana%displace, & - dim_per_elem=tmc_ana%dim_per_elem, error=error) + dim_per_elem=tmc_ana%dim_per_elem) END IF END SUBROUTINE tmc_read_ana_input @@ -219,14 +216,11 @@ END SUBROUTINE tmc_read_ana_input !> \brief initialize all the necessarry analysis structures !> \param ana_env ... !> \param nr_dim dimension of the pos, frc etc. array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE analysis_init(ana_env, nr_dim, error) + SUBROUTINE analysis_init(ana_env, nr_dim) TYPE(tmc_analysis_env), POINTER :: ana_env INTEGER :: nr_dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'analysis_init', & routineP = moduleN//':'//routineN @@ -237,8 +231,8 @@ SUBROUTINE analysis_init(ana_env, nr_dim, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(nr_dim>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(nr_dim>0,cp_failure_level,routineP,failure) ana_env%nr_dim = nr_dim @@ -284,25 +278,21 @@ SUBROUTINE analysis_init(ana_env, nr_dim, error) ! init radial distribution function IF(ASSOCIATED(ana_env%pair_correl)) & CALL ana_pair_correl_init(ana_pair_correl=ana_env%pair_correl, & - atoms=ana_env%atoms, cell=ana_env%cell, & - error=error) + atoms=ana_env%atoms, cell=ana_env%cell) ! init classical dipole moment calculations IF(ASSOCIATED(ana_env%dip_mom)) & CALL ana_dipole_moment_init(ana_dip_mom=ana_env%dip_mom, & - atoms=ana_env%atoms, error=error) + atoms=ana_env%atoms) END SUBROUTINE analysis_init ! ***************************************************************************** !> \brief print analysis restart file !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE analysis_restart_print(ana_env, error) + SUBROUTINE analysis_restart_print(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'analysis_restart_print', & routineP = moduleN//':'//routineN @@ -313,22 +303,22 @@ SUBROUTINE analysis_restart_print(ana_env, error) LOGICAL :: failure, l_tmp failure = .FALSE. - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%last_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%last_elem),cp_failure_level,routineP,failure) IF(.NOT.ana_env%restart) RETURN WRITE(file_name, FMT='(I9.9)') ana_env%last_elem%nr file_name_tmp = TRIM(expand_file_name_temp(expand_file_name_char(& TRIM(ana_env%out_file_prefix)//& tmc_default_restart_out_file_name,& - "ana",error), ana_env%temperature, error)) + "ana"), ana_env%temperature)) restart_file_name = expand_file_name_char(file_name_tmp, & - file_name, error) + file_name) CALL open_file(file_name=restart_file_name, file_status="REPLACE", & file_action="WRITE", file_form="UNFORMATTED", & unit_number=file_ptr) WRITE(file_ptr) ana_env%temperature - CALL write_subtree_elem_unformated(ana_env%last_elem, file_ptr, error) + CALL write_subtree_elem_unformated(ana_env%last_elem, file_ptr) ! first mention the different kind of anlysis types initialized ! then the variables for each calculation type @@ -385,9 +375,9 @@ SUBROUTINE analysis_restart_print(ana_env, error) CALL close_file(unit_number=file_ptr) file_name_tmp = expand_file_name_char(TRIM(ana_env%out_file_prefix)//& - tmc_default_restart_in_file_name, "ana",error) + tmc_default_restart_in_file_name, "ana") file_name = expand_file_name_temp(file_name_tmp, & - ana_env%temperature, error) + ana_env%temperature) CALL open_file(file_name=file_name, & file_action="WRITE", file_status="REPLACE", & unit_number=file_ptr) @@ -399,15 +389,12 @@ END SUBROUTINE analysis_restart_print !> \brief read analysis restart file !> \param ana_env ... !> \param elem ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE analysis_restart_read(ana_env, elem, error) + SUBROUTINE analysis_restart_read(ana_env, elem) TYPE(tmc_analysis_env), POINTER :: ana_env TYPE(tree_type), POINTER :: elem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'analysis_restart_read', & routineP = moduleN//':'//routineN @@ -418,14 +405,14 @@ SUBROUTINE analysis_restart_read(ana_env, elem, error) REAL(KIND=dp) :: temp failure = .FALSE. - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) IF(.NOT.ana_env%restart) RETURN file_name_tmp = expand_file_name_char(TRIM(ana_env%out_file_prefix)//& - tmc_default_restart_in_file_name, "ana",error) + tmc_default_restart_in_file_name, "ana") file_name = expand_file_name_temp(file_name_tmp, & - ana_env%temperature, error) + ana_env%temperature) INQUIRE(FILE=file_name, EXIST=l_tmp) IF(l_tmp) THEN CALL open_file(file_name=file_name, file_status="OLD", & @@ -436,14 +423,14 @@ SUBROUTINE analysis_restart_read(ana_env, elem, error) CALL open_file(file_name=file_name_tmp, file_status="OLD", file_form="UNFORMATTED", & file_action="READ", unit_number=file_ptr) READ(file_ptr) temp - CPPrecondition(ana_env%temperature.EQ.temp,cp_failure_level,routineP,error,failure) + CPPrecondition(ana_env%temperature.EQ.temp,cp_failure_level,routineP,failure) ana_env%last_elem => elem - CALL read_subtree_elem_unformated(elem, file_ptr, error) + CALL read_subtree_elem_unformated(elem, file_ptr) ! first mention the different kind of anlysis types initialized ! then the variables for each calculation type READ(file_ptr) l_tmp - CPPrecondition(ASSOCIATED(ana_env%density_3d).EQV.l_tmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env%density_3d).EQV.l_tmp,cp_failure_level,routineP,failure) IF(l_tmp)THEN READ(file_ptr) ana_env%density_3d%conf_counter, & ana_env%density_3d%nr_bins, & @@ -456,7 +443,7 @@ SUBROUTINE analysis_restart_read(ana_env, elem, error) END IF READ(file_ptr) l_tmp - CPPrecondition(ASSOCIATED(ana_env%pair_correl).EQV.l_tmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env%pair_correl).EQV.l_tmp,cp_failure_level,routineP,failure) IF(l_tmp)THEN READ(file_ptr) ana_env%pair_correl%conf_counter, & ana_env%pair_correl%nr_bins, & @@ -466,7 +453,7 @@ SUBROUTINE analysis_restart_read(ana_env, elem, error) END IF READ(file_ptr) l_tmp - CPPrecondition(ASSOCIATED(ana_env%dip_mom).EQV.l_tmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env%dip_mom).EQV.l_tmp,cp_failure_level,routineP,failure) IF(l_tmp)THEN READ(file_ptr) ana_env%dip_mom%conf_counter, & ana_env%dip_mom%charges, & @@ -474,7 +461,7 @@ SUBROUTINE analysis_restart_read(ana_env, elem, error) END IF READ(file_ptr) l_tmp - CPPrecondition(ASSOCIATED(ana_env%dip_ana).EQV.l_tmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env%dip_ana).EQV.l_tmp,cp_failure_level,routineP,failure) IF(l_tmp)THEN READ(file_ptr) ana_env%dip_ana%conf_counter, & ana_env%dip_ana%ana_type,& @@ -486,7 +473,7 @@ SUBROUTINE analysis_restart_read(ana_env, elem, error) END IF READ(file_ptr) l_tmp - CPPrecondition(ASSOCIATED(ana_env%displace).EQV.l_tmp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env%displace).EQV.l_tmp,cp_failure_level,routineP,failure) IF(l_tmp)THEN READ(file_ptr)ana_env%displace%conf_counter, & ana_env%displace%disp @@ -505,15 +492,12 @@ END SUBROUTINE analysis_restart_read !> afterwards the previous configuration can be deallocated (outside) !> \param elem ... !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE do_tmc_analysis(elem, ana_env, error) + SUBROUTINE do_tmc_analysis(elem, ana_env) TYPE(tree_type), POINTER :: elem TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_tmc_analysis', & routineP = moduleN//':'//routineN @@ -525,8 +509,8 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -537,16 +521,15 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%density_3d)) & CALL calc_density_3d(elem=ana_env%last_elem, & weight=weight_act, atoms=ana_env%atoms, & - ana_env=ana_env, error=error) + ana_env=ana_env) ! calculated the radial distribution function for each atom type IF(ASSOCIATED(ana_env%pair_correl)) & CALL calc_paircorrelation(elem=ana_env%last_elem, weight=weight_act,& - atoms=ana_env%atoms, ana_env=ana_env, & - error=error) + atoms=ana_env%atoms, ana_env=ana_env) ! calculates the classical dipole moments IF(ASSOCIATED(ana_env%dip_mom)) & CALL calc_dipole_moment(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! calculates the dipole moments analysis and dielectric constant IF(ASSOCIATED(ana_env%dip_ana)) THEN ! in symmetric case use also the dipoles @@ -558,7 +541,7 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! (-x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) @@ -566,7 +549,7 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! (-x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(3) = -ana_env%last_elem%dipole(3) @@ -574,7 +557,7 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(3) = -ana_env%dip_mom%last_dip_cl(3) CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! (x,-y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) @@ -582,7 +565,7 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! (x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) @@ -590,7 +573,7 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! (-x,y,-z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(1) = -ana_env%last_elem%dipole(1) @@ -598,7 +581,7 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(1) = -ana_env%dip_mom%last_dip_cl(1) CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! (x,-y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(:) = -ana_env%last_elem%dipole(:) @@ -606,7 +589,7 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) IF(ASSOCIATED(ana_env%dip_mom)) & ana_env%dip_mom%last_dip_cl(:) = -ana_env%dip_mom%last_dip_cl(:) CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) ! back to (x,y,z) ana_env%last_elem%dipole(:) = dip_tmp(:) ana_env%last_elem%dipole(2) = -ana_env%last_elem%dipole(2) @@ -615,14 +598,14 @@ SUBROUTINE do_tmc_analysis(elem, ana_env, error) ana_env%dip_mom%last_dip_cl(2) = -ana_env%dip_mom%last_dip_cl(2) END IF CALL calc_dipole_analysis(elem=ana_env%last_elem, weight=weight_act,& - ana_env=ana_env, error=error) + ana_env=ana_env) CALL print_act_dipole_analysis(elem=ana_env%last_elem, & - ana_env=ana_env, error=error) + ana_env=ana_env) END IF ! calculates the cell displacement from last cell IF(ASSOCIATED(ana_env%displace).AND.weight_act.GT.0) & - CALL calc_displacement(elem=elem, ana_env=ana_env, error=error) + CALL calc_displacement(elem=elem, ana_env=ana_env) END IF ! swap elem with last elem, to delete original last element and store the actual one elem_tmp => ana_env%last_elem @@ -635,14 +618,11 @@ END SUBROUTINE do_tmc_analysis ! ***************************************************************************** !> \brief call all the necessarry analysis printing routines !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE finalize_tmc_analysis(ana_env, error) + SUBROUTINE finalize_tmc_analysis(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'finalize_tmc_analysis', & routineP = moduleN//':'//routineN @@ -650,29 +630,29 @@ SUBROUTINE finalize_tmc_analysis(ana_env, error) INTEGER :: handle LOGICAL :: failure - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) IF(ASSOCIATED(ana_env%density_3d)) THEN IF(ana_env%density_3d%conf_counter.GT.0) & - CALL print_density_3d(ana_env=ana_env, error=error) + CALL print_density_3d(ana_env=ana_env) END IF IF(ASSOCIATED(ana_env%pair_correl)) THEN IF(ana_env%pair_correl%conf_counter.GT.0) & - CALL print_paircorrelation(ana_env=ana_env, error=error) + CALL print_paircorrelation(ana_env=ana_env) END IF IF(ASSOCIATED(ana_env%dip_mom)) THEN IF(ana_env%dip_mom%conf_counter.GT.0) & - CALL print_dipole_moment(ana_env, error) + CALL print_dipole_moment(ana_env) END IF IF(ASSOCIATED(ana_env%dip_ana)) THEN IF(ana_env%dip_ana%conf_counter.GT.0) & - CALL print_dipole_analysis(ana_env, error) + CALL print_dipole_analysis(ana_env) END IF IF(ASSOCIATED(ana_env%displace)) THEN IF(ana_env%displace%conf_counter.GT.0) & - CALL print_average_displacement(ana_env, error) + CALL print_average_displacement(ana_env) END IF ! end the timing @@ -686,17 +666,14 @@ END SUBROUTINE finalize_tmc_analysis !> \param dir_ind ... !> \param ana_env ... !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 03.2013 ! ***************************************************************************** SUBROUTINE analyze_file_configurations(start_id, end_id, dir_ind, & - ana_env, tmc_params, error) + ana_env, tmc_params) INTEGER :: start_id, end_id INTEGER, OPTIONAL :: dir_ind TYPE(tmc_analysis_env), POINTER :: ana_env TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'analyze_file_configurations', & routineP = moduleN//':'//routineN @@ -708,15 +685,14 @@ SUBROUTINE analyze_file_configurations(start_id, end_id, dir_ind, & NULLIFY(elem) conf_nr = -1 stat = TMC_STATUS_WAIT_FOR_NEW_TASK - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) ! open the files - CALL analyse_files_open(tmc_ana=ana_env, stat=stat, dir_ind=dir_ind, & - error=error) + CALL analyse_files_open(tmc_ana=ana_env, stat=stat, dir_ind=dir_ind) ! set the existence of exact dipoles (from file) IF(ana_env%id_dip .GT. 0) THEN tmc_params%print_dipole = .TRUE. @@ -726,7 +702,7 @@ SUBROUTINE analyze_file_configurations(start_id, end_id, dir_ind, & ! allocate the actual element structure CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem,& - nr_dim=ana_env%nr_dim, error=error) + nr_dim=ana_env%nr_dim) IF(ASSOCIATED(ana_env%last_elem)) conf_nr = ana_env%last_elem%nr nr_dim = SIZE(elem%pos) @@ -734,34 +710,34 @@ SUBROUTINE analyze_file_configurations(start_id, end_id, dir_ind, & IF(stat .EQ. TMC_STATUS_OK) THEN conf_loop: DO CALL read_element_from_file(elem=elem, tmc_ana=ana_env, conf_nr=conf_nr, & - stat=stat, error=error) + stat=stat) IF(stat.EQ.TMC_STATUS_WAIT_FOR_NEW_TASK) THEN - CALL deallocate_sub_tree_node(tree_elem=elem,error=error) + CALL deallocate_sub_tree_node(tree_elem=elem) EXIT conf_loop END IF ! if we want just a certain part of the trajectory IF(start_id.LT.0 .OR. conf_nr.GE.start_id) THEN IF(end_id.LT.0 .OR. conf_nr.LE.end_id) THEN ! do the analysis calculations - CALL do_tmc_analysis(elem=elem, ana_env=ana_env, error=error) + CALL do_tmc_analysis(elem=elem, ana_env=ana_env) END IF END IF ! clean temporary element (already analyzed) IF(ASSOCIATED(elem)) THEN - CALL deallocate_sub_tree_node(tree_elem=elem,error=error) + CALL deallocate_sub_tree_node(tree_elem=elem) END IF ! if there was no previous element, create a new temp element to write in IF(.NOT.ASSOCIATED(elem)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem, & - nr_dim=nr_dim, error=error) + nr_dim=nr_dim) END DO conf_loop END IF ! close the files - CALL analyse_files_close(tmc_ana=ana_env, error=error) + CALL analyse_files_close(tmc_ana=ana_env) IF(ASSOCIATED(elem)) & - CALL deallocate_sub_tree_node(tree_elem=elem, error=error) + CALL deallocate_sub_tree_node(tree_elem=elem) ! end the timing CALL timestop(handle) @@ -779,18 +755,15 @@ END SUBROUTINE analyze_file_configurations !> \param weight ... !> \param atoms ... !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE calc_density_3d(elem, weight, atoms, ana_env, error) + SUBROUTINE calc_density_3d(elem, weight, atoms, ana_env) TYPE(tree_type), POINTER :: elem INTEGER :: weight TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_density_3d', & routineP = moduleN//':'//routineN @@ -808,15 +781,15 @@ SUBROUTINE calc_density_3d(elem, weight, atoms, ana_env, error) NULLIFY(mass_bin) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,error,failure) - CPPrecondition(weight.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%cell),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%density_3d),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_density),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_dens2),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,failure) + CPPrecondition(weight.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%cell),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%density_3d),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_density),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_dens2),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -836,7 +809,7 @@ SUBROUTINE calc_density_3d(elem, weight, atoms, ana_env, error) ! ATTENTION then the sub box middle points are not correct in the output ! espacially if we use multiple sub boxes CALL get_scaled_cell(cell=ana_env%cell, box_scale=elem%box_scale, & - abc=cell_size, vol=vol_cell, error=error) + abc=cell_size, vol=vol_cell) ! volume summed over configurations for average volume [A] ana_env%density_3d%sum_vol = ana_env%density_3d%sum_vol + & vol_cell*(au2a)**3 *weight @@ -864,17 +837,17 @@ SUBROUTINE calc_density_3d(elem, weight, atoms, ana_env, error) atom_pos(:) = elem%pos(atom:atom+2) ! fold into box CALL get_scaled_cell(cell=ana_env%cell, box_scale=elem%box_scale, & - vec=atom_pos, error=error) + vec=atom_pos) ! shifts the box to positive values (before 0,0,0 is the center) atom_pos(:) = atom_pos(:)+0.5_dp*cell_size(:) ! calculate the index of the sub box bin_x = INT(atom_pos(1)/interval_size(1))+1 bin_y = INT(atom_pos(2)/interval_size(2))+1 bin_z = INT(atom_pos(3)/interval_size(3))+1 - CPPostcondition(bin_x.GT.0.AND.bin_y.GT.0.AND.bin_z.GT.0,cp_failure_level,routineP,error,failure) - CPPostcondition(bin_x.LE.SIZE(ana_env%density_3d%sum_density(:,1,1)),cp_failure_level,routineP,error,failure) - CPPostcondition(bin_y.LE.SIZE(ana_env%density_3d%sum_density(1,:,1)),cp_failure_level,routineP,error,failure) - CPPostcondition(bin_z.LE.SIZE(ana_env%density_3d%sum_density(1,1,:)),cp_failure_level,routineP,error,failure) + CPPostcondition(bin_x.GT.0.AND.bin_y.GT.0.AND.bin_z.GT.0,cp_failure_level,routineP,failure) + CPPostcondition(bin_x.LE.SIZE(ana_env%density_3d%sum_density(:,1,1)),cp_failure_level,routineP,failure) + CPPostcondition(bin_y.LE.SIZE(ana_env%density_3d%sum_density(1,:,1)),cp_failure_level,routineP,failure) + CPPostcondition(bin_z.LE.SIZE(ana_env%density_3d%sum_density(1,1,:)),cp_failure_level,routineP,failure) ! sum mass in [g] (in bins and total) mass_bin(bin_x,bin_y,bin_z) = mass_bin(bin_x,bin_y,bin_z) + & @@ -890,7 +863,7 @@ SUBROUTINE calc_density_3d(elem, weight, atoms, ana_env, error) END DO ! check total cell density r_tmp = mass_total/vol_cell - SUM(mass_bin(:,:,:))/vol_sub_box/SIZE(mass_bin(:,:,:)) - CPPostcondition(ABS(r_tmp).LT.1E-5,cp_failure_level,routineP,error,failure) + CPPostcondition(ABS(r_tmp).LT.1E-5,cp_failure_level,routineP,failure) ! calculate density (mass per volume) and sum up for average value ana_env%density_3d%sum_density(:,:,:) = ana_env%density_3d%sum_density(:,:,:) +& @@ -906,9 +879,9 @@ SUBROUTINE calc_density_3d(elem, weight, atoms, ana_env, error) IF(ana_env%density_3d%print_dens) THEN file_name_tmp = expand_file_name_temp(TRIM(ana_env%out_file_prefix)//& tmc_default_trajectory_file_name, & - ana_env%temperature, error) + ana_env%temperature) file_name = TRIM(expand_file_name_char(file_name_tmp,& - "dens",error)) + "dens")) INQUIRE(FILE=file_name, EXIST=flag) CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & @@ -953,14 +926,11 @@ END SUBROUTINE calc_density_3d !> \brief print the density in rectantangulares !> defined by the number of bins in each direction !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE print_density_3d(ana_env, error) + SUBROUTINE print_density_3d(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: fmt_my = '(T2,A,"| ",A,T41,A40)', & plabel = "TMC_ANA", routineN = 'print_density_3d', & @@ -973,10 +943,10 @@ SUBROUTINE print_density_3d(ana_env, error) LOGICAL :: failure REAL(KIND=dp), DIMENSION(3) :: cell_size, interval_size - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%density_3d),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_density),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_dens2),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%density_3d),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_density),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%density_3d%sum_dens2),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -995,7 +965,7 @@ SUBROUTINE print_density_3d(ana_env, error) file_name = expand_file_name_temp(TRIM(ana_env%out_file_prefix)//& tmc_ana_density_file_name, & - ana_env%temperature, error) + ana_env%temperature) CALL open_file(file_name=file_name, file_status="REPLACE", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr_dens) @@ -1006,8 +976,8 @@ SUBROUTINE print_density_3d(ana_env, error) file_name_vari = expand_file_name_temp(expand_file_name_char(& TRIM(ana_env%out_file_prefix)//& - tmc_ana_density_file_name,"vari",error),& - ana_env%temperature, error) + tmc_ana_density_file_name,"vari"),& + ana_env%temperature) CALL open_file(file_name=file_name_vari, file_status="REPLACE", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr_vari) @@ -1070,17 +1040,14 @@ END SUBROUTINE print_density_3d !> \param ana_pair_correl ... !> \param atoms ... !> \param cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE ana_pair_correl_init(ana_pair_correl, atoms, cell, error) + SUBROUTINE ana_pair_correl_init(ana_pair_correl, atoms, cell) TYPE(pair_correl_type), POINTER :: ana_pair_correl TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ana_pair_correl_init', & routineP = moduleN//':'//routineN @@ -1094,12 +1061,12 @@ SUBROUTINE ana_pair_correl_init(ana_pair_correl, atoms, cell, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(ana_pair_correl),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(ana_pair_correl%g_r),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(ana_pair_correl%pairs),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(atoms).GT.1,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_pair_correl),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_pair_correl%g_r),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_pair_correl%pairs),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(atoms).GT.1,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1119,8 +1086,7 @@ SUBROUTINE ana_pair_correl_init(ana_pair_correl, atoms, cell, error) DO s_n=f_n+1, SIZE(atoms) ! search if atom pair is already selected list_ind = search_pair_in_list(pair_list=pairs_tmp, n1=atoms(f_n)%name,& - n2=atoms(s_n)%name, list_end=counter-1,& - error=error) + n2=atoms(s_n)%name, list_end=counter-1) ! add to list IF(list_ind.LT.0) THEN pairs_tmp(counter)%f_n = atoms(f_n)%name @@ -1153,18 +1119,15 @@ END SUBROUTINE ana_pair_correl_init !> \param weight ... !> \param atoms ... !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE calc_paircorrelation(elem, weight, atoms, ana_env, error) + SUBROUTINE calc_paircorrelation(elem, weight, atoms, ana_env) TYPE(tree_type), POINTER :: elem INTEGER :: weight TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_paircorrelation', & routineP = moduleN//':'//routineN @@ -1175,16 +1138,16 @@ SUBROUTINE calc_paircorrelation(elem, weight, atoms, ana_env, error) REAL(KIND=dp), DIMENSION(3) :: cell_size failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(elem%box_scale(:).GT.0.0_dp),cp_failure_level,routineP,error,failure) - CPPrecondition(weight.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%cell),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%pair_correl),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%pair_correl%g_r),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%pair_correl%pairs),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,failure) + CPPrecondition(ALL(elem%box_scale(:).GT.0.0_dp),cp_failure_level,routineP,failure) + CPPrecondition(weight.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%cell),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%pair_correl),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%pair_correl%g_r),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%pair_correl%pairs),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1195,15 +1158,13 @@ SUBROUTINE calc_paircorrelation(elem, weight, atoms, ana_env, error) second_elem_loop:DO j=i+3, SIZE(elem%pos), ana_env%dim_per_elem dist = nearest_distance(x1=elem%pos(i:i+ana_env%dim_per_elem-1), & x2=elem%pos(j:j+ana_env%dim_per_elem-1), & - cell=ana_env%cell, box_scale=elem%box_scale, & - error=error) + cell=ana_env%cell, box_scale=elem%box_scale) ind = CEILING(dist/ana_env%pair_correl%step_lenght) IF(ind.LE.ana_env%pair_correl%nr_bins)THEN pair_ind = search_pair_in_list(pair_list=ana_env%pair_correl%pairs, & n1=atoms(INT(i/REAL(ana_env%dim_per_elem,KIND=dp))+1)%name, & - n2=atoms(INT(j/REAL(ana_env%dim_per_elem,KIND=dp))+1)%name, & - error=error) - CPPostcondition(pair_ind.GT.0,cp_failure_level,routineP,error,failure) + n2=atoms(INT(j/REAL(ana_env%dim_per_elem,KIND=dp))+1)%name) + CPPostcondition(pair_ind.GT.0,cp_failure_level,routineP,failure) ana_env%pair_correl%g_r(pair_ind,ind) = & ana_env%pair_correl%g_r(pair_ind,ind) + weight END IF @@ -1220,14 +1181,11 @@ END SUBROUTINE calc_paircorrelation ! ***************************************************************************** !> \brief print the radial distribution function for each pair of atoms !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE print_paircorrelation(ana_env, error) + SUBROUTINE print_paircorrelation(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_paircorrelation', & routineP = moduleN//':'//routineN @@ -1240,8 +1198,8 @@ SUBROUTINE print_paircorrelation(ana_env, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%pair_correl),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%pair_correl),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1255,11 +1213,11 @@ SUBROUTINE print_paircorrelation(ana_env, error) DO pair=1, SIZE(ana_env%pair_correl%pairs) file_name = expand_file_name_temp(TRIM(ana_env%out_file_prefix)//& tmc_ana_pair_correl_file_name, & - ana_env%temperature, error) + ana_env%temperature) CALL open_file(file_name=expand_file_name_char(& expand_file_name_char(file_name,& - ana_env%pair_correl%pairs(pair)%f_n,error),& - ana_env%pair_correl%pairs(pair)%s_n, error),& + ana_env%pair_correl%pairs(pair)%f_n),& + ana_env%pair_correl%pairs(pair)%s_n),& file_status="REPLACE", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) @@ -1299,16 +1257,13 @@ END SUBROUTINE print_paircorrelation !> \brief init radial distribution function structures !> \param ana_dip_mom ... !> \param atoms ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE ana_dipole_moment_init(ana_dip_mom, atoms, error) + SUBROUTINE ana_dipole_moment_init(ana_dip_mom, atoms) TYPE(dipole_moment_type), POINTER :: ana_dip_mom TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ana_dipole_moment_init', & routineP = moduleN//':'//routineN @@ -1318,9 +1273,9 @@ SUBROUTINE ana_dipole_moment_init(ana_dip_mom, atoms, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(ana_dip_mom),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_dip_mom%charges_inp),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_dip_mom),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_dip_mom%charges_inp),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1347,16 +1302,13 @@ END SUBROUTINE ana_dipole_moment_init !> \param elem ... !> \param weight ... !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE calc_dipole_moment(elem, weight, ana_env, error) + SUBROUTINE calc_dipole_moment(elem, weight, ana_env) TYPE(tree_type), POINTER :: elem INTEGER :: weight TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_dipole_moment', & routineP = moduleN//':'//routineN @@ -1366,11 +1318,11 @@ SUBROUTINE calc_dipole_moment(elem, weight, ana_env, error) LOGICAL :: failure REAL(KIND=dp), DIMENSION(:), POINTER :: dip_cl - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%dip_mom),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%dip_mom%charges),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%dip_mom),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%dip_mom%charges),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1391,10 +1343,10 @@ SUBROUTINE calc_dipole_moment(elem, weight, ana_env, error) IF(ana_env%dip_mom%print_cl_dip) THEN file_name = expand_file_name_temp(tmc_default_trajectory_file_name, & - ana_env%temperature, error) + ana_env%temperature) CALL write_dipoles_in_file(file_name=file_name, & conf_nr=ana_env%dip_mom%conf_counter+1, dip=dip_cl, & - file_ext="dip_cl", error=error) + file_ext="dip_cl") END IF ana_env%dip_mom%conf_counter = ana_env%dip_mom%conf_counter + weight ana_env%dip_mom%last_dip_cl(:) = dip_cl @@ -1408,14 +1360,11 @@ END SUBROUTINE calc_dipole_moment ! ***************************************************************************** !> \brief prints final values for classical cell dipole moment calculation !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE print_dipole_moment(ana_env, error) + SUBROUTINE print_dipole_moment(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_dipole_moment', & routineP = moduleN//':'//routineN @@ -1430,16 +1379,13 @@ END SUBROUTINE print_dipole_moment !> \param elem ... !> \param weight ... !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE calc_dipole_analysis(elem, weight, ana_env, error) + SUBROUTINE calc_dipole_analysis(elem, weight, ana_env) TYPE(tree_type), POINTER :: elem INTEGER :: weight TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_dipole_analysis', & routineP = moduleN//':'//routineN @@ -1451,10 +1397,10 @@ SUBROUTINE calc_dipole_analysis(elem, weight, ana_env, error) NULLIFY(scaled_cell) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem%dipole),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%dip_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem%dipole),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%dip_ana),cp_failure_level,routineP,failure) weight_act = weight IF(ana_env%dip_ana%ana_type .EQ. ana_type_sym_xyz) & @@ -1463,7 +1409,7 @@ SUBROUTINE calc_dipole_analysis(elem, weight, ana_env, error) ! get the volume ALLOCATE(scaled_cell) CALL get_scaled_cell(cell=ana_env%cell, box_scale=elem%box_scale, vol=vol,& - scaled_cell=scaled_cell, error=error) + scaled_cell=scaled_cell) ! fold exact dipole moments using the classical ones IF(ASSOCIATED(ana_env%dip_mom)) THEN @@ -1505,15 +1451,12 @@ END SUBROUTINE calc_dipole_analysis !> \brief prints the actual dipole moment analysis (trajectories) !> \param elem ... !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE print_act_dipole_analysis(elem, ana_env, error) + SUBROUTINE print_act_dipole_analysis(elem, ana_env) TYPE(tree_type), POINTER :: elem TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_act_dipole_analysis', & routineP = moduleN//':'//routineN @@ -1534,33 +1477,33 @@ SUBROUTINE print_act_dipole_analysis(elem, ana_env, error) file_name = expand_file_name_temp(TRIM(ana_env%out_file_prefix)//& tmc_default_trajectory_file_name, & - ana_env%temperature, error) + ana_env%temperature) CALL write_dipoles_in_file(file_name=file_name, & conf_nr=INT(ana_env%dip_ana%conf_counter)+1, dip=elem%dipole, & - file_ext="dip_folded", error=error) + file_ext="dip_folded") ! set ouput file name file_name_tmp = expand_file_name_temp(TRIM(ana_env%out_file_prefix)//& tmc_default_trajectory_file_name, & - ana_env%temperature, error) + ana_env%temperature) SELECT CASE (ana_env%dip_ana%ana_type) CASE (ana_type_default) file_name = TRIM(expand_file_name_char(file_name_tmp,& - "diel_const",error)) + "diel_const")) file_name_tmp = TRIM(expand_file_name_char(file_name_tmp,& - "diel_const_tensor",error)) + "diel_const_tensor")) CASE (ana_type_sym_xyz) file_name = TRIM(expand_file_name_char(file_name_tmp,& - "diel_const_sym",error)) + "diel_const_sym")) file_name_tmp = TRIM(expand_file_name_char(file_name_tmp,& - "diel_const_tensor_sym",error)) + "diel_const_tensor_sym")) CASE DEFAULT CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& 'unknown analysis type "'//cp_to_string(ana_env%dip_ana%ana_type)//& '" used. ',& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) END SELECT ! calc the dielectric constant @@ -1613,14 +1556,11 @@ END SUBROUTINE print_act_dipole_analysis ! ***************************************************************************** !> \brief prints the dipole moment analysis !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE print_dipole_analysis(ana_env, error) + SUBROUTINE print_dipole_analysis(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: fmt_my = '(T2,A,"| ",A,T41,A40)', & plabel = "TMC_ANA", routineN = 'print_dipole_analysis', & @@ -1634,8 +1574,8 @@ SUBROUTINE print_dipole_analysis(ana_env, error) kB = boltzmann/joule - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%dip_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%dip_ana),cp_failure_level,routineP,failure) tmp_dip(:,:) = 0.0_dp diel_const(:,:) = 0.0_dp @@ -1707,15 +1647,12 @@ END SUBROUTINE print_dipole_analysis !> \brief calculates the mean square displacement !> \param elem ... !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE calc_displacement(elem, ana_env, error) + SUBROUTINE calc_displacement(elem, ana_env) TYPE(tree_type), POINTER :: elem TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_displacement', & routineP = moduleN//':'//routineN @@ -1729,11 +1666,11 @@ SUBROUTINE calc_displacement(elem, ana_env, error) failure = .FALSE. disp = 0.0_dp - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%displace),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_env%last_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%displace),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_env%last_elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1742,7 +1679,7 @@ SUBROUTINE calc_displacement(elem, ana_env, error) ! fold into box atom_disp(:) = elem%pos(ind:ind+2)-ana_env%last_elem%pos(ind:ind+2) CALL get_scaled_cell(cell=ana_env%cell, box_scale=elem%box_scale, & - vec=atom_disp, error=error) + vec=atom_disp) disp = disp + SUM((atom_disp(:)*au2a)**2) END DO ana_env%displace%disp = ana_env%displace%disp + disp @@ -1751,9 +1688,9 @@ SUBROUTINE calc_displacement(elem, ana_env, error) IF(ana_env%displace%print_disp) THEN file_name_tmp = expand_file_name_temp(TRIM(ana_env%out_file_prefix)//& tmc_default_trajectory_file_name, & - ana_env%temperature, error) + ana_env%temperature) file_name = TRIM(expand_file_name_char(file_name_tmp,& - "devi",error)) + "devi")) INQUIRE(FILE=file_name, EXIST=flag) CALL open_file(file_name=file_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & @@ -1772,14 +1709,11 @@ END SUBROUTINE calc_displacement ! ***************************************************************************** !> \brief prints final values for the displacement calculations !> \param ana_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE print_average_displacement(ana_env, error) + SUBROUTINE print_average_displacement(ana_env) TYPE(tmc_analysis_env), POINTER :: ana_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: fmt_my = '(T2,A,"| ",A,T41,A40)', & plabel = "TMC_ANA", routineN = 'print_average_displacement', & diff --git a/src/tmc/tmc_analysis_types.F b/src/tmc/tmc_analysis_types.F index 5ee4fe03b7..2cad84f7be 100644 --- a/src/tmc/tmc_analysis_types.F +++ b/src/tmc/tmc_analysis_types.F @@ -135,13 +135,10 @@ MODULE tmc_analysis_types ! ***************************************************************************** !> \brief creates a new structure environment for TMC analysis !> \param tmc_ana structure with parameters for TMC analysis -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_env_create(tmc_ana,error) + SUBROUTINE tmc_ana_env_create(tmc_ana) TYPE(tmc_analysis_env), POINTER :: tmc_ana - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_env_create', & routineP = moduleN//':'//routineN @@ -151,10 +148,10 @@ SUBROUTINE tmc_ana_env_create(tmc_ana,error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) ALLOCATE(tmc_ana,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(tmc_ana%dirs, tmc_ana%cell, tmc_ana%atoms, tmc_ana%density_3d, & tmc_ana%pair_correl, tmc_ana%dip_mom, tmc_ana%last_elem, & @@ -190,13 +187,10 @@ END SUBROUTINE tmc_ana_env_create ! ***************************************************************************** !> \brief releases the structure environment for TMC analysis !> \param tmc_ana structure with parameters for TMC analysis -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_env_release(tmc_ana,error) + SUBROUTINE tmc_ana_env_release(tmc_ana) TYPE(tmc_analysis_env), POINTER :: tmc_ana - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_env_release', & routineP = moduleN//':'//routineN @@ -206,27 +200,27 @@ SUBROUTINE tmc_ana_env_release(tmc_ana,error) failure=.FALSE. - CPPostcondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) IF(ASSOCIATED(tmc_ana%dirs)) & DEALLOCATE(tmc_ana%dirs) IF(ASSOCIATED(tmc_ana%density_3d)) & - CALL tmc_ana_dens_release(tmc_ana%density_3d, error) + CALL tmc_ana_dens_release(tmc_ana%density_3d) IF(ASSOCIATED(tmc_ana%pair_correl)) & - CALL tmc_ana_pair_correl_release(tmc_ana%pair_correl, error) + CALL tmc_ana_pair_correl_release(tmc_ana%pair_correl) IF(ASSOCIATED(tmc_ana%dip_mom)) & - CALL tmc_ana_dipole_moment_release(tmc_ana%dip_mom, error) + CALL tmc_ana_dipole_moment_release(tmc_ana%dip_mom) IF(ASSOCIATED(tmc_ana%dip_ana)) & - CALL tmc_ana_dipole_analysis_release(tmc_ana%dip_ana, error) + CALL tmc_ana_dipole_analysis_release(tmc_ana%dip_ana) IF(ASSOCIATED(tmc_ana%displace)) & - CALL tmc_ana_displacement_release(ana_disp=tmc_ana%displace, error=error) + CALL tmc_ana_displacement_release(ana_disp=tmc_ana%displace) DEALLOCATE(tmc_ana,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE tmc_ana_env_release @@ -238,14 +232,11 @@ END SUBROUTINE tmc_ana_env_release !> \brief creates a new structure environment for TMC analysis !> \param ana_dens structure with parameters for TMC density analysis !> \param nr_bins ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_density_create(ana_dens, nr_bins, error) + SUBROUTINE tmc_ana_density_create(ana_dens, nr_bins) TYPE(density_3d_type), POINTER :: ana_dens INTEGER, DIMENSION(3) :: nr_bins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_density_create', & routineP = moduleN//':'//routineN @@ -255,10 +246,10 @@ SUBROUTINE tmc_ana_density_create(ana_dens, nr_bins, error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(ana_dens),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_dens),cp_failure_level,routineP,failure) ALLOCATE(ana_dens,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(ana_dens%sum_density, ana_dens%sum_dens2) @@ -279,13 +270,10 @@ END SUBROUTINE tmc_ana_density_create ! ***************************************************************************** !> \brief releases the structure environment for TMC analysis !> \param ana_dens structure with parameters for TMC analysis -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_dens_release(ana_dens,error) + SUBROUTINE tmc_ana_dens_release(ana_dens) TYPE(density_3d_type), POINTER :: ana_dens - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_dens_release', & routineP = moduleN//':'//routineN @@ -295,12 +283,12 @@ SUBROUTINE tmc_ana_dens_release(ana_dens,error) failure=.FALSE. - CPPostcondition(ASSOCIATED(ana_dens),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ana_dens),cp_failure_level,routineP,failure) DEALLOCATE(ana_dens%sum_density) DEALLOCATE(ana_dens%sum_dens2) DEALLOCATE(ana_dens,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE tmc_ana_dens_release !============================================================================ @@ -311,15 +299,12 @@ END SUBROUTINE tmc_ana_dens_release !> \brief creates a new structure environment for TMC analysis !> \param ana_pair_correl ... !> \param nr_bins ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_pair_correl_create(ana_pair_correl, nr_bins, error) + SUBROUTINE tmc_ana_pair_correl_create(ana_pair_correl, nr_bins) TYPE(pair_correl_type), POINTER :: ana_pair_correl INTEGER :: nr_bins - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_pair_correl_create', & routineP = moduleN//':'//routineN @@ -329,9 +314,9 @@ SUBROUTINE tmc_ana_pair_correl_create(ana_pair_correl, nr_bins, error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(ana_pair_correl),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_pair_correl),cp_failure_level,routineP,failure) ALLOCATE(ana_pair_correl,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(ana_pair_correl%g_r, ana_pair_correl%pairs) ana_pair_correl%conf_counter = 0 @@ -344,14 +329,11 @@ END SUBROUTINE tmc_ana_pair_correl_create ! ***************************************************************************** !> \brief releases the structure environment for TMC analysis !> \param ana_pair_correl ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_pair_correl_release(ana_pair_correl,error) + SUBROUTINE tmc_ana_pair_correl_release(ana_pair_correl) TYPE(pair_correl_type), POINTER :: ana_pair_correl - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_pair_correl_release', & routineP = moduleN//':'//routineN @@ -361,12 +343,12 @@ SUBROUTINE tmc_ana_pair_correl_release(ana_pair_correl,error) failure=.FALSE. - CPPostcondition(ASSOCIATED(ana_pair_correl),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ana_pair_correl),cp_failure_level,routineP,failure) DEALLOCATE(ana_pair_correl%g_r) DEALLOCATE(ana_pair_correl%pairs) DEALLOCATE(ana_pair_correl, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE tmc_ana_pair_correl_release ! ***************************************************************************** @@ -375,17 +357,14 @@ END SUBROUTINE tmc_ana_pair_correl_release !> \param n1 atom names !> \param n2 atom names !> \param list_end ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval ind ... !> \author Mandes 02.2013 ! ***************************************************************************** - FUNCTION search_pair_in_list(pair_list, n1, n2, list_end, error) RESULT(ind) + FUNCTION search_pair_in_list(pair_list, n1, n2, list_end) RESULT(ind) TYPE(atom_pairs_type), DIMENSION(:), & POINTER :: pair_list CHARACTER(LEN=default_string_length) :: n1, n2 INTEGER, OPTIONAL :: list_end - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ind CHARACTER(LEN=*), PARAMETER :: routineN = 'search_pair_in_list', & @@ -394,9 +373,9 @@ FUNCTION search_pair_in_list(pair_list, n1, n2, list_end, error) RESULT(ind) INTEGER :: last, list_nr LOGICAL :: failure - CPPrecondition(ASSOCIATED(pair_list),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pair_list),cp_failure_level,routineP,failure) IF(PRESENT(list_end)) THEN - CPPrecondition(list_end.LE.SIZE(pair_list),cp_failure_level,routineP,error,failure) + CPPrecondition(list_end.LE.SIZE(pair_list),cp_failure_level,routineP,failure) last = list_end ELSE last = SIZE(pair_list) @@ -425,19 +404,16 @@ END FUNCTION search_pair_in_list !> \param charge_atm ... !> \param charge ... !> \param dim_per_elem ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** SUBROUTINE tmc_ana_dipole_moment_create(ana_dip_mom, charge_atm, charge, & - dim_per_elem, error) + dim_per_elem) TYPE(dipole_moment_type), POINTER :: ana_dip_mom CHARACTER(LEN=default_string_length), & POINTER :: charge_atm(:) REAL(KIND=dp), POINTER :: charge(:) INTEGER :: dim_per_elem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_dipole_moment_create', & routineP = moduleN//':'//routineN @@ -447,9 +423,9 @@ SUBROUTINE tmc_ana_dipole_moment_create(ana_dip_mom, charge_atm, charge, & failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(ana_dip_mom),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_dip_mom),cp_failure_level,routineP,failure) ALLOCATE(ana_dip_mom,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(ana_dip_mom%charges_inp, ana_dip_mom%charges) @@ -468,14 +444,11 @@ END SUBROUTINE tmc_ana_dipole_moment_create ! ***************************************************************************** !> \brief releases the structure environment for TMC analysis !> \param ana_dip_mom ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_dipole_moment_release(ana_dip_mom, error) + SUBROUTINE tmc_ana_dipole_moment_release(ana_dip_mom) TYPE(dipole_moment_type), POINTER :: ana_dip_mom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'tmc_ana_dipole_moment_release', & @@ -486,26 +459,23 @@ SUBROUTINE tmc_ana_dipole_moment_release(ana_dip_mom, error) failure=.FALSE. - CPPostcondition(ASSOCIATED(ana_dip_mom),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ana_dip_mom),cp_failure_level,routineP,failure) IF(ASSOCIATED(ana_dip_mom%charges_inp)) DEALLOCATE(ana_dip_mom%charges_inp) IF(ASSOCIATED(ana_dip_mom%charges)) DEALLOCATE(ana_dip_mom%charges) DEALLOCATE(ana_dip_mom%last_dip_cl) DEALLOCATE(ana_dip_mom, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE tmc_ana_dipole_moment_release ! ***************************************************************************** !> \brief creates a new structure environment for TMC analysis !> \param ana_dip_ana ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_dipole_analysis_create(ana_dip_ana, error) + SUBROUTINE tmc_ana_dipole_analysis_create(ana_dip_ana) TYPE(dipole_analysis_type), POINTER :: ana_dip_ana - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'tmc_ana_dipole_analysis_create', & @@ -516,9 +486,9 @@ SUBROUTINE tmc_ana_dipole_analysis_create(ana_dip_ana, error) failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(ana_dip_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_dip_ana),cp_failure_level,routineP,failure) ALLOCATE(ana_dip_ana,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ana_dip_ana%conf_counter = 0 ana_dip_ana%ana_type = -1 @@ -536,14 +506,11 @@ END SUBROUTINE tmc_ana_dipole_analysis_create ! ***************************************************************************** !> \brief releases the structure environment for TMC analysis !> \param ana_dip_ana ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_dipole_analysis_release(ana_dip_ana, error) + SUBROUTINE tmc_ana_dipole_analysis_release(ana_dip_ana) TYPE(dipole_analysis_type), POINTER :: ana_dip_ana - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'tmc_ana_dipole_analysis_release', & @@ -554,7 +521,7 @@ SUBROUTINE tmc_ana_dipole_analysis_release(ana_dip_ana, error) failure=.FALSE. - CPPostcondition(ASSOCIATED(ana_dip_ana),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ana_dip_ana),cp_failure_level,routineP,failure) DEALLOCATE(ana_dip_ana%mu_psv) DEALLOCATE(ana_dip_ana%mu_pv) @@ -562,7 +529,7 @@ SUBROUTINE tmc_ana_dipole_analysis_release(ana_dip_ana, error) DEALLOCATE(ana_dip_ana%mu2_pv_mat) DEALLOCATE(ana_dip_ana, STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE tmc_ana_dipole_analysis_release !============================================================================ @@ -573,15 +540,12 @@ END SUBROUTINE tmc_ana_dipole_analysis_release !> \brief creates a new structure environment for TMC analysis !> \param ana_disp ... !> \param dim_per_elem ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_displacement_create(ana_disp, dim_per_elem, error) + SUBROUTINE tmc_ana_displacement_create(ana_disp, dim_per_elem) TYPE(displacement_type), POINTER :: ana_disp INTEGER :: dim_per_elem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_displacement_create', & routineP = moduleN//':'//routineN @@ -590,11 +554,11 @@ SUBROUTINE tmc_ana_displacement_create(ana_disp, dim_per_elem, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(ana_disp),cp_failure_level,routineP,error,failure) - CPPrecondition(dim_per_elem.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_disp),cp_failure_level,routineP,failure) + CPPrecondition(dim_per_elem.GT.0,cp_failure_level,routineP,failure) ALLOCATE(ana_disp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ana_disp%disp = 0.0_dp ana_disp%conf_counter = 0 @@ -604,14 +568,11 @@ END SUBROUTINE tmc_ana_displacement_create ! ***************************************************************************** !> \brief releases a structure environment for TMC analysis !> \param ana_disp ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE tmc_ana_displacement_release(ana_disp, error) + SUBROUTINE tmc_ana_displacement_release(ana_disp) TYPE(displacement_type), POINTER :: ana_disp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_ana_displacement_release', & routineP = moduleN//':'//routineN @@ -620,9 +581,9 @@ SUBROUTINE tmc_ana_displacement_release(ana_disp, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(ana_disp),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_disp),cp_failure_level,routineP,failure) DEALLOCATE(ana_disp,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE tmc_ana_displacement_release END MODULE tmc_analysis_types diff --git a/src/tmc/tmc_calculations.F b/src/tmc/tmc_calculations.F index 49ca0dee93..39b9691c1a 100644 --- a/src/tmc/tmc_calculations.F +++ b/src/tmc/tmc_calculations.F @@ -63,17 +63,14 @@ MODULE tmc_calculations !> \param exact_approx_pot flag if result should be stores in exact or approx !> energy variable !> \param tmc_env TMC environment parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** SUBROUTINE calc_potential_energy(conf, env_id, exact_approx_pot, & - tmc_env, error) + tmc_env) TYPE(tree_type), POINTER :: conf INTEGER :: env_id LOGICAL :: exact_approx_pot TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_potential_energy', & routineP = moduleN//':'//routineN @@ -86,9 +83,9 @@ SUBROUTINE calc_potential_energy(conf, env_id, exact_approx_pot, & rnd = 0.0_dp failure = .FALSE. - CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,error,failure) - CPPrecondition(env_id.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,failure) + CPPrecondition(env_id.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) SELECT CASE(tmc_env%params%task_type) CASE(task_type_gaussian_adaptation) @@ -97,9 +94,9 @@ SUBROUTINE calc_potential_energy(conf, env_id, exact_approx_pot, & IF(tmc_env%params%pressure.GE.0.0_dp) THEN ALLOCATE(tmp_cell) CALL get_scaled_cell(cell=tmc_env%params%cell , box_scale=conf%box_scale, & - scaled_cell=tmp_cell , error=error) + scaled_cell=tmp_cell) CALL set_cell(env_id=env_id, new_cell=tmp_cell%hmat, ierr=ierr) - CPPostcondition(ierr.EQ.0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr.EQ.0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_cell) END IF @@ -125,11 +122,11 @@ SUBROUTINE calc_potential_energy(conf, env_id, exact_approx_pot, & CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "worker task typ is unknown "//& - cp_to_string(tmc_env%params%task_type), error) + cp_to_string(tmc_env%params%task_type)) END SELECT ! --- wait a bit - rnd = next_random_number(rng_stream=tmc_env%rng_stream, error=error) + rnd = next_random_number(rng_stream=tmc_env%rng_stream) !rnd = 0.5 !TODO IF(worker_random_wait.AND.exact_approx_pot)THEN ! CALL SYSTEM_CLOCK(time0, time_rate, time_max) @@ -156,12 +153,10 @@ END SUBROUTINE calc_potential_energy !> \param vol returns the cell volume !> \param abc ... !> \param vec a vector, which will be folded (pbc) in the cell -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE get_scaled_cell(cell, box_scale, scaled_hmat, scaled_cell, vol, & - abc, vec, error) + abc, vec) TYPE(cell_type), INTENT(IN), POINTER :: cell REAL(KIND=dp), DIMENSION(:), POINTER :: box_scale REAL(KIND=dp), DIMENSION(3, 3), OPTIONAL :: scaled_hmat @@ -170,7 +165,6 @@ SUBROUTINE get_scaled_cell(cell, box_scale, scaled_hmat, scaled_cell, vol, & REAL(KIND=dp), DIMENSION(3), & INTENT(OUT), OPTIONAL :: abc REAL(KIND=dp), DIMENSION(3), OPTIONAL :: vec - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_scaled_cell', & routineP = moduleN//':'//routineN @@ -179,8 +173,8 @@ SUBROUTINE get_scaled_cell(cell, box_scale, scaled_hmat, scaled_cell, vol, & TYPE(cell_type), POINTER :: tmp_cell failure = .FALSE. - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(box_scale),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(box_scale),cp_failure_level,routineP,failure) new_scaled_cell = .FALSE. @@ -190,7 +184,7 @@ SUBROUTINE get_scaled_cell(cell, box_scale, scaled_hmat, scaled_cell, vol, & ELSE tmp_cell => scaled_cell END IF - CALL cell_copy(cell_in=cell, cell_out=tmp_cell, error=error) + CALL cell_copy(cell_in=cell, cell_out=tmp_cell) tmp_cell%hmat(:,1) = tmp_cell%hmat(:,1) * box_scale(1) tmp_cell%hmat(:,2) = tmp_cell%hmat(:,2) * box_scale(2) tmp_cell%hmat(:,3) = tmp_cell%hmat(:,3) * box_scale(3) @@ -213,16 +207,13 @@ END SUBROUTINE get_scaled_cell !> \param cell .. original cell !> \param scaled_hmat returns the scaled h matrix (matrix of cell vectors) !> \param box_scale scaling factors for each direction -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE get_cell_scaling(cell, scaled_hmat, box_scale, error) + SUBROUTINE get_cell_scaling(cell, scaled_hmat, box_scale) TYPE(cell_type), INTENT(IN), POINTER :: cell REAL(KIND=dp), DIMENSION(3, 3), & INTENT(IN) :: scaled_hmat REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: box_scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_cell_scaling', & routineP = moduleN//':'//routineN @@ -232,10 +223,10 @@ SUBROUTINE get_cell_scaling(cell, scaled_hmat, box_scale, error) TYPE(cell_type), POINTER :: tmp_cell failure = .FALSE. - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) ALLOCATE(tmp_cell) - CALL cell_copy(cell_in=cell, cell_out=tmp_cell, error=error) + CALL cell_copy(cell_in=cell, cell_out=tmp_cell) tmp_cell%hmat(:,:) = scaled_hmat(:,:) CALL init_cell(cell=tmp_cell) CALL get_cell(cell=cell, abc=abc_orig) @@ -252,17 +243,14 @@ END SUBROUTINE get_cell_scaling !> \param x2 ... !> \param cell ... !> \param box_scale ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION nearest_distance(x1, x2, cell, box_scale, error) RESULT(res) + FUNCTION nearest_distance(x1, x2, cell, box_scale) RESULT(res) REAL(KIND=dp), DIMENSION(:) :: x1, x2 TYPE(cell_type), POINTER :: cell REAL(KIND=dp), DIMENSION(:), OPTIONAL, & POINTER :: box_scale - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: res CHARACTER(LEN=*), PARAMETER :: routineN = 'nearest_distance', & @@ -275,19 +263,19 @@ FUNCTION nearest_distance(x1, x2, cell, box_scale, error) RESULT(res) failure = .FALSE. NULLIFY(tmp_box_scale) - CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(x1).EQ.3,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(x2).EQ.3,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(cell),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(x1).EQ.3,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(x2).EQ.3,cp_failure_level,routineP,failure) dist_vec(:) = x2(:)-x1(:) ! distance vector between atoms ALLOCATE(tmp_box_scale(3)) IF(PRESENT(box_scale)) THEN - CPPrecondition(SIZE(box_scale).EQ.3,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(box_scale).EQ.3,cp_failure_level,routineP,failure) tmp_box_scale(:) = box_scale ELSE tmp_box_scale(:) = 1.0_dp END IF - CALL get_scaled_cell(cell=cell, box_scale=box_scale, vec=dist_vec, error=error) + CALL get_scaled_cell(cell=cell, box_scale=box_scale, vec=dist_vec) res = SQRT(SUM(dist_vec(:)*dist_vec(:))) DEALLOCATE(tmp_box_scale) END FUNCTION nearest_distance @@ -297,14 +285,11 @@ END FUNCTION nearest_distance !> array size should be multiple of dim_per_elem !> \param pos list of atoms !> \param center return value, the geometrical center -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE geometrical_center(pos, center, error) + SUBROUTINE geometrical_center(pos, center) REAL(KIND=dp), DIMENSION(:) :: pos REAL(KIND=dp), DIMENSION(:), POINTER :: center - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'geometrical_center', & routineP = moduleN//':'//routineN @@ -313,8 +298,8 @@ SUBROUTINE geometrical_center(pos, center, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(center),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(pos).GE.SIZE(center),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(center),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(pos).GE.SIZE(center),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -334,18 +319,15 @@ END SUBROUTINE geometrical_center !> \param pos ... !> \param atoms ... !> \param center ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \param !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE center_of_mass(pos, atoms, center, error) + SUBROUTINE center_of_mass(pos, atoms, center) REAL(KIND=dp), DIMENSION(:) :: pos TYPE(tmc_atom_type), DIMENSION(:), & OPTIONAL :: atoms REAL(KIND=dp), DIMENSION(:), POINTER :: center - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'center_of_mass', & routineP = moduleN//':'//routineN @@ -355,8 +337,8 @@ SUBROUTINE center_of_mass(pos, atoms, center, error) REAL(KIND=dp) :: mass_sum, mass_tmp failure = .FALSE. - CPPrecondition(ASSOCIATED(center),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(pos).GE.SIZE(center),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(center),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(pos).GE.SIZE(center),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -365,7 +347,7 @@ SUBROUTINE center_of_mass(pos, atoms, center, error) mass_sum = 0.0_dp DO i=1, SIZE(pos), SIZE(center) IF(PRESENT(atoms)) THEN - CPPrecondition(SIZE(atoms).EQ.SIZE(pos)/SIZE(center),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(atoms).EQ.SIZE(pos)/SIZE(center),cp_failure_level,routineP,failure) mass_tmp = atoms(INT(i/REAL(SIZE(center),KIND=dp))+1)%mass center(:) = center(:) + pos(i:i+SIZE(center)-1)/& (SIZE(pos)/REAL(SIZE(center),KIND=dp))*mass_tmp @@ -373,7 +355,7 @@ SUBROUTINE center_of_mass(pos, atoms, center, error) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "try to calculate center of mass without any mass.",& - error,failure) + failure) center(:) = center(:) + pos(i:i+SIZE(center)-1)/& (SIZE(pos)/REAL(SIZE(center),KIND=dp)) mass_sum = 1.0_dp @@ -392,18 +374,15 @@ END SUBROUTINE center_of_mass !> \param temerature ... !> \param rng_stream ... !> \param rnd_seed ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE init_vel(vel, atoms, temerature, rng_stream, rnd_seed, error) + SUBROUTINE init_vel(vel, atoms, temerature, rng_stream, rnd_seed) REAL(KIND=dp), DIMENSION(:), POINTER :: vel TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms REAL(KIND=dp) :: temerature TYPE(rng_stream_type), POINTER :: rng_stream REAL(KIND=dp), DIMENSION(3, 2, 3) :: rnd_seed - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_vel', & routineP = moduleN//':'//routineN @@ -413,14 +392,14 @@ SUBROUTINE init_vel(vel, atoms, temerature, rng_stream, rnd_seed, error) kB = boltzmann/joule - CPPreconditionNoFail(ASSOCIATED(vel),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(atoms),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(vel),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(atoms),cp_failure_level,routineP) CALL set_rng_stream(rng_stream=rng_stream, bg=rnd_seed(:,:,1), & - cg=rnd_seed(:,:,2), ig=rnd_seed(:,:,3), error=error) + cg=rnd_seed(:,:,2), ig=rnd_seed(:,:,3)) DO i=1, SIZE(vel) - rnd1 = next_random_number(rng_stream, error=error) - rnd2 = next_random_number(rng_stream, error=error) + rnd1 = next_random_number(rng_stream) + rnd2 = next_random_number(rng_stream) mass_tmp = atoms(INT(i/REAL(3,KIND=dp))+1)%mass @@ -428,7 +407,7 @@ SUBROUTINE init_vel(vel, atoms, temerature, rng_stream, rnd_seed, error) SQRT(kB*temerature/mass_tmp) END DO CALL get_rng_stream(rng_stream=rng_stream, bg=rnd_seed(:,:,1), & - cg=rnd_seed(:,:,2), ig=rnd_seed(:,:,3), error=error) + cg=rnd_seed(:,:,2), ig=rnd_seed(:,:,3)) END SUBROUTINE init_vel @@ -437,16 +416,13 @@ END SUBROUTINE init_vel !> and atom mass, both in atomic units !> \param vel ... !> \param atoms ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval ekin ... !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION calc_e_kin(vel, atoms, error) RESULT(ekin) + FUNCTION calc_e_kin(vel, atoms) RESULT(ekin) REAL(KIND=dp), DIMENSION(:), POINTER :: vel TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: ekin CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_e_kin', & @@ -455,8 +431,8 @@ FUNCTION calc_e_kin(vel, atoms, error) RESULT(ekin) INTEGER :: i REAL(KIND=dp) :: mass_tmp - CPPreconditionNoFail(ASSOCIATED(vel),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(atoms),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(vel),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(atoms),cp_failure_level,routineP) ekin = 0.0_dp DO i=1, SIZE(vel) @@ -473,14 +449,11 @@ END FUNCTION calc_e_kin !> \param v3 function values !> \param extrapolate extrapolated final value (result) !> \param res_err error of the result -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE three_point_extrapolate(v1,v2,v3, extrapolate, res_err, error) + SUBROUTINE three_point_extrapolate(v1,v2,v3, extrapolate, res_err) REAL(KIND=dp) :: v1,v2,v3 REAL(KIND=dp), INTENT(OUT) :: extrapolate, res_err - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'three_point_extrapolate', & routineP = moduleN//':'//routineN @@ -522,7 +495,7 @@ SUBROUTINE three_point_extrapolate(v1,v2,v3, extrapolate, res_err, error) extrapolate=a**7*b+c res_err=e3-extrapolate ENDIF - CPPostcondition(extrapolate.NE.HUGE(extrapolate),cp_failure_level,routineP,error,failure) + CPPostcondition(extrapolate.NE.HUGE(extrapolate),cp_failure_level,routineP,failure) CONTAINS ! ***************************************************************************** !> \brief ... @@ -557,18 +530,15 @@ END SUBROUTINE three_point_extrapolate !> energies !> \param p the random number, the criteria has to be smaller than this !> \param beta ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval prob return probability of acceptance !> \author Mandes 12.2012 ! ***************************************************************************** FUNCTION compute_prob(E_n_mu,E_n_sigma,E_o_mu,E_o_sigma,E_classical_diff,& - prior_mu,prior_sigma,p,beta,error) RESULT(prob) + prior_mu,prior_sigma,p,beta) RESULT(prob) REAL(KIND=dp) :: E_n_mu, E_n_sigma, E_o_mu, & E_o_sigma, E_classical_diff, & - prior_mu, prior_sigma, p, beta - TYPE(cp_error_type), INTENT(inout) :: error - REAL(KIND=dp) :: prob + prior_mu, prior_sigma, p, & + beta, prob ! INTEGER :: io,in ! REAL(KIND=dp) :: diff,E_n,E_o,surface,lower_bound,upper_bound,delta @@ -592,17 +562,14 @@ END FUNCTION compute_prob !> \param rnd_nr random number acceptance check will be done with !> \param beta 1/(kB*T) can differ for different acceptance checks !> \param tmc_params TMC environment parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval prob estimated acceptance probability !> \author Mandes 12.2012 ! ***************************************************************************** FUNCTION compute_estimated_prob(elem_old, elem_new, E_classical_diff, & - rnd_nr, beta, tmc_params, error) RESULT(prob) + rnd_nr, beta, tmc_params) RESULT(prob) TYPE(tree_type), POINTER :: elem_old, elem_new REAL(KIND=dp) :: E_classical_diff, rnd_nr, beta TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: prob CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_estimated_prob', & @@ -615,9 +582,9 @@ FUNCTION compute_estimated_prob(elem_old, elem_new, E_classical_diff, & E_sigma_tmp, prior_sigma failure = .FALSE. - CPPrecondition(ASSOCIATED(elem_old),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem_new),cp_failure_level,routineP,error,failure) - CPPrecondition(rnd_nr.GT.0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem_old),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem_new),cp_failure_level,routineP,failure) + CPPrecondition(rnd_nr.GT.0.0_dp,cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -633,12 +600,12 @@ FUNCTION compute_estimated_prob(elem_old, elem_new, E_classical_diff, & CALL three_point_extrapolate(v1=elem_new%scf_energies(MOD(elem_new%scf_energies_count-3,4)+1), & v2=elem_new%scf_energies(MOD(elem_new%scf_energies_count-2,4)+1), & v3=elem_new%scf_energies(MOD(elem_new%scf_energies_count-1,4)+1), & - extrapolate=E_mu_tmp,res_err=E_sigma_tmp, error=error) + extrapolate=E_mu_tmp,res_err=E_sigma_tmp) IF((elem_new%scf_energies_count.GT.3))THEN CALL three_point_extrapolate(v1=elem_new%scf_energies(MOD(elem_new%scf_energies_count-4,4)+1), & v2=elem_new%scf_energies(MOD(elem_new%scf_energies_count-3,4)+1), & v3=elem_new%scf_energies(MOD(elem_new%scf_energies_count-2,4)+1), & - extrapolate=E_n_mu,res_err=E_n_sigma, error=error) + extrapolate=E_n_mu,res_err=E_n_sigma) E_n_sigma = MAX(E_n_sigma, ABS(E_n_mu-E_mu_tmp)) ELSE E_n_sigma = E_sigma_tmp @@ -649,12 +616,12 @@ FUNCTION compute_estimated_prob(elem_old, elem_new, E_classical_diff, & CALL three_point_extrapolate(v1=elem_old%scf_energies(MOD(elem_old%scf_energies_count-3,4)+1), & v2=elem_old%scf_energies(MOD(elem_old%scf_energies_count-2,4)+1), & v3=elem_old%scf_energies(MOD(elem_old%scf_energies_count-1,4)+1), & - extrapolate=E_mu_tmp,res_err=E_sigma_tmp, error=error) + extrapolate=E_mu_tmp,res_err=E_sigma_tmp) IF((elem_old%scf_energies_count.GT.3))THEN CALL three_point_extrapolate(v1=elem_old%scf_energies(MOD(elem_old%scf_energies_count-4,4)+1), & v2=elem_old%scf_energies(MOD(elem_old%scf_energies_count-3,4)+1), & v3=elem_old%scf_energies(MOD(elem_old%scf_energies_count-2,4)+1), & - extrapolate=E_o_mu,res_err=E_o_sigma, error=error) + extrapolate=E_o_mu,res_err=E_o_sigma) E_o_sigma = MAX(E_o_sigma, ABS(E_o_mu-E_mu_tmp)) ELSE E_o_sigma = E_sigma_tmp @@ -670,7 +637,7 @@ FUNCTION compute_estimated_prob(elem_old, elem_new, E_classical_diff, & prob = compute_prob(E_n_mu=E_n_mu,E_n_sigma=E_n_sigma,E_o_mu=E_o_mu,E_o_sigma=E_o_sigma,& E_classical_diff=E_classical_diff,& prior_mu=tmc_params%prior_NMC_acc%aver,prior_sigma=prior_sigma, & - p=rnd_nr, beta=beta, error=error) + p=rnd_nr, beta=beta) END IF ! end the timing CALL timestop(handle) @@ -681,14 +648,11 @@ END FUNCTION compute_estimated_prob !> for every temperature !> \param tmc_env TMC environment variables !> \param eff result efficiency -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - SUBROUTINE get_subtree_efficiency(tmc_env, eff, error) + SUBROUTINE get_subtree_efficiency(tmc_env, eff) TYPE(tmc_env_type), POINTER :: tmc_env REAL(KIND=dp), DIMENSION(:), POINTER :: eff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_subtree_efficiency', & routineP = moduleN//':'//routineN @@ -697,9 +661,9 @@ SUBROUTINE get_subtree_efficiency(tmc_env, eff, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) eff(:) = 0.0_dp diff --git a/src/tmc/tmc_cancelation.F b/src/tmc/tmc_cancelation.F index 6834c5db03..fc64ea6c7c 100644 --- a/src/tmc/tmc_cancelation.F +++ b/src/tmc/tmc_cancelation.F @@ -50,14 +50,11 @@ MODULE tmc_cancelation !> \brief add a certain element to the cancelation list !> \param elem the sub tree element, to be added !> \param tmc_env tmc environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE add_to_canceling_list(elem, tmc_env ,error) + SUBROUTINE add_to_canceling_list(elem, tmc_env) TYPE(tree_type), POINTER :: elem TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'add_to_canceling_list', & routineP = moduleN//':'//routineN @@ -67,10 +64,10 @@ SUBROUTINE add_to_canceling_list(elem, tmc_env ,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -98,20 +95,20 @@ SUBROUTINE add_to_canceling_list(elem, tmc_env ,error) ! if deallocation is deactivated, should not be CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"try to add deleted element cancelation list ",& - error,failure) + failure) WRITE(*,*)"WARNING: try to cancel subtree, element ",elem%sub_tree_nr, elem%nr, ", with status ", elem%stat CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"try to add element with unknown status to cancelation list (stat="& - //cp_to_string(elem%stat),error,failure) + //cp_to_string(elem%stat),failure) END SELECT ! set dot color IF(tmc_env%params%DRAW_TREE) & - CALL create_dot_color(tree_element=elem, tmc_params=tmc_env%params, error=error) + CALL create_dot_color(tree_element=elem, tmc_params=tmc_env%params) ! add to list IF(need_to_cancel) THEN - CALL add_to_list(elem=elem, list=tmc_env%m_env%cancelation_list, error=error) + CALL add_to_list(elem=elem, list=tmc_env%m_env%cancelation_list) END IF END IF ! end the timing @@ -121,14 +118,11 @@ END SUBROUTINE add_to_canceling_list ! ***************************************************************************** !> \brief for correct finalizing deallocate the cancelation list !> \param cancel_list ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE free_cancelation_list(cancel_list, error) + SUBROUTINE free_cancelation_list(cancel_list) TYPE(elem_list_type), POINTER :: cancel_list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'free_cancelation_list', & routineP = moduleN//':'//routineN diff --git a/src/tmc/tmc_dot_tree.F b/src/tmc/tmc_dot_tree.F index a4b9b89d60..f45591125e 100644 --- a/src/tmc/tmc_dot_tree.F +++ b/src/tmc/tmc_dot_tree.F @@ -49,15 +49,12 @@ MODULE tmc_dot_tree !> \brief returns extended filename for global and sub trees !> \param tmc_params param environment for creating the file name !> \param ind index of the subtree (0 = global tree) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval filename ... !> \author Mandes 12.2012 ! ***************************************************************************** - FUNCTION get_dot_file_name(tmc_params, ind, error) RESULT(filename) + FUNCTION get_dot_file_name(tmc_params, ind) RESULT(filename) TYPE(tmc_param_type), POINTER :: tmc_params INTEGER :: ind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=50) :: filename CHARACTER(LEN=*), PARAMETER :: routineN = 'get_dot_file_name', & @@ -68,30 +65,27 @@ FUNCTION get_dot_file_name(tmc_params, ind, error) RESULT(filename) failure = .FALSE. filename = "" - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ind.GE.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params%Temp),cp_failure_level,routineP,error,failure) - CPPrecondition(ind.LE.SIZE(tmc_params%Temp),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ind.GE.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params%Temp),cp_failure_level,routineP,failure) + CPPrecondition(ind.LE.SIZE(tmc_params%Temp),cp_failure_level,routineP,failure) IF(ind.EQ.0) THEN - filename = TRIM(expand_file_name_char(tmc_params%dot_file_name,"global",error)) + filename = TRIM(expand_file_name_char(tmc_params%dot_file_name,"global")) ELSE filename = TRIM(expand_file_name_temp(file_name=tmc_params%dot_file_name,& - rvalue=tmc_params%Temp(ind),error=error)) + rvalue=tmc_params%Temp(ind))) END IF - CPPostcondition(filename.NE."",cp_failure_level,routineP,error,failure) + CPPostcondition(filename.NE."",cp_failure_level,routineP,failure) END FUNCTION get_dot_file_name ! ***************************************************************************** !> \brief initializes the dot files (open and write headers) !> \param tmc_params param environment for creating the file name -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE init_draw_trees(tmc_params, error) + SUBROUTINE init_draw_trees(tmc_params) TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_draw_trees', & routineP = moduleN//':'//routineN @@ -100,23 +94,23 @@ SUBROUTINE init_draw_trees(tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! global tree - CALL open_file(file_name=get_dot_file_name(tmc_params, 0, error), file_status="REPLACE", & + CALL open_file(file_name=get_dot_file_name(tmc_params, 0), file_status="REPLACE", & file_action="WRITE", unit_number=file_ptr) WRITE(file_ptr,*)"digraph G {" WRITE(file_ptr,*)' size="8.27,11.69"' - CALL write_legend(file_ptr, error) + CALL write_legend(file_ptr) CALL close_file(unit_number=file_ptr, keep_preconnection=.TRUE.) ! subtrees DO i=1, SIZE(tmc_params%Temp) - CALL open_file(file_name=get_dot_file_name(tmc_params, i, error), file_status="REPLACE", & + CALL open_file(file_name=get_dot_file_name(tmc_params, i), file_status="REPLACE", & file_action="WRITE", unit_number=file_ptr) WRITE(file_ptr,*)"digraph G {" WRITE(file_ptr,*)' size="8.27,11.69"' - CALL write_legend(file_ptr, error) + CALL write_legend(file_ptr) CALL close_file(unit_number=file_ptr, keep_preconnection=.TRUE.) END DO END SUBROUTINE init_draw_trees @@ -124,13 +118,10 @@ END SUBROUTINE init_draw_trees ! ***************************************************************************** !> \brief close the dot files (write tails) !> \param tmc_params param environment for creating the file name -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE finalize_draw_tree(tmc_params, error) + SUBROUTINE finalize_draw_tree(tmc_params) TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'finalize_draw_tree', & routineP = moduleN//':'//routineN @@ -139,17 +130,17 @@ SUBROUTINE finalize_draw_tree(tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! global tree - CALL open_file(file_name=get_dot_file_name(tmc_params, 0, error), & + CALL open_file(file_name=get_dot_file_name(tmc_params, 0), & file_status="OLD", file_action="WRITE", & file_position="APPEND", unit_number=file_ptr) WRITE(file_ptr,*)"}" CALL close_file(unit_number=file_ptr) DO i=1, SIZE(tmc_params%Temp) - CALL open_file(file_name=get_dot_file_name(tmc_params, i, error), file_status="OLD", & + CALL open_file(file_name=get_dot_file_name(tmc_params, i), file_status="OLD", & file_action="WRITE", file_position="APPEND", unit_number=file_ptr) WRITE(file_ptr,*)"}" CALL close_file(unit_number=file_ptr) @@ -159,13 +150,10 @@ END SUBROUTINE finalize_draw_tree ! ***************************************************************************** !> \brief writes the legend in the file !> \param file_ptr file pointer -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE write_legend(file_ptr, error) + SUBROUTINE write_legend(file_ptr) INTEGER, INTENT(IN) :: file_ptr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_legend', & routineP = moduleN//':'//routineN @@ -173,7 +161,7 @@ SUBROUTINE write_legend(file_ptr, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(file_ptr.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(file_ptr.GT.0,cp_failure_level,routineP,failure) WRITE(file_ptr,*)'//LEGEND' WRITE(file_ptr,*)'subgraph clusterLegend {' @@ -215,14 +203,11 @@ END SUBROUTINE write_legend !> \param node_nr the index of the tree node !> \param stat tree element status !> \param filename the filename for the grapgviz dot files -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE write_color(node_nr, stat, filename, error) + SUBROUTINE write_color(node_nr, stat, filename) INTEGER :: node_nr, stat CHARACTER(LEN=50) :: filename - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_color', & routineP = moduleN//':'//routineN @@ -232,8 +217,8 @@ SUBROUTINE write_color(node_nr, stat, filename, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(filename.NE."",cp_failure_level,routineP,error,failure) - CPPrecondition(node_nr.GE.0,cp_failure_level,routineP,error,failure) + CPPrecondition(filename.NE."",cp_failure_level,routineP,failure) + CPPrecondition(node_nr.GE.0,cp_failure_level,routineP,failure) CALL open_file(file_name=filename, file_status="OLD", & file_action="WRITE", file_position="APPEND", unit_number=file_ptr) @@ -273,7 +258,7 @@ SUBROUTINE write_color(node_nr, stat, filename, error) WRITE(file_ptr,*) TRIM(label),'style=filled, color=peru]' CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"element status"//cp_to_string(stat),error,failure) + routineP,"element status"//cp_to_string(stat),failure) END SELECT CALL close_file(unit_number=file_ptr, keep_preconnection=.TRUE.) END SUBROUTINE write_color @@ -285,16 +270,13 @@ END SUBROUTINE write_color !> \param acc flag for accepted or not accepted branch (left,right) !> \param tmc_params param environment for creating the file name !> \param tree index of the tree (0=global tree) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_dot_branch(parent_nr,child_nr,acc,tmc_params,tree,error) + SUBROUTINE create_dot_branch(parent_nr,child_nr,acc,tmc_params,tree) INTEGER :: parent_nr, child_nr LOGICAL :: acc TYPE(tmc_param_type), POINTER :: tmc_params INTEGER :: tree - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_dot_branch', & routineP = moduleN//':'//routineN @@ -303,9 +285,9 @@ SUBROUTINE create_dot_branch(parent_nr,child_nr,acc,tmc_params,tree,error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) - CALL open_file(file_name=get_dot_file_name(tmc_params, tree, error), & + CALL open_file(file_name=get_dot_file_name(tmc_params, tree), & file_status="OLD", file_action="WRITE", & file_position="APPEND", unit_number=file_ptr) IF(acc) THEN @@ -321,15 +303,12 @@ END SUBROUTINE create_dot_branch !> \param new_element the actual subtree element !> \param conf the subtree index and hence the index for filename !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_dot(new_element, conf, tmc_params, error) + SUBROUTINE create_dot(new_element, conf, tmc_params) TYPE(tree_type), POINTER :: new_element INTEGER :: conf TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_dot', & routineP = moduleN//':'//routineN @@ -337,14 +316,14 @@ SUBROUTINE create_dot(new_element, conf, tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(new_element),cp_failure_level,routineP,error,failure) - CPPrecondition(conf.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(new_element),cp_failure_level,routineP,failure) + CPPrecondition(conf.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) CALL create_dot_branch(parent_nr=new_element%parent%nr,& child_nr=new_element%nr,& acc=ASSOCIATED(new_element%parent%acc,new_element), & - tmc_params=tmc_params, tree=conf, error=error) + tmc_params=tmc_params, tree=conf) END SUBROUTINE create_dot ! ***************************************************************************** @@ -352,14 +331,11 @@ END SUBROUTINE create_dot !> additional handling of nodes with swaped elements !> \param new_element the actual global element !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_global_tree_dot(new_element, tmc_params, error) + SUBROUTINE create_global_tree_dot(new_element, tmc_params) TYPE(global_tree_type), POINTER :: new_element TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_global_tree_dot', & routineP = moduleN//':'//routineN @@ -372,8 +348,8 @@ SUBROUTINE create_global_tree_dot(new_element, tmc_params, error) failure = .FALSE. NULLIFY(tmp_pt_list_elem) - CPPrecondition(ASSOCIATED(new_element),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(new_element),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! creating list with configuration numbers (of subtrees) list_of_nr = "" @@ -409,16 +385,15 @@ SUBROUTINE create_global_tree_dot(new_element, tmc_params, error) CALL cp_assert(new_element%nr.LE.1,& cp_warning_level,cp_assertion_failed,routineP,& "try to create dot, but no parent on node "//& - cp_to_string(new_element%nr)//"exists",& - error) + cp_to_string(new_element%nr)//"exists") ELSE CALL create_dot_branch(parent_nr=new_element%parent%nr,& child_nr=new_element%nr,& acc=ASSOCIATED(new_element%parent%acc,new_element),& - tmc_params=tmc_params, tree=0, error=error) + tmc_params=tmc_params, tree=0) END IF ! write in dot file - CALL open_file(file_name=get_dot_file_name(tmc_params, 0, error), & + CALL open_file(file_name=get_dot_file_name(tmc_params, 0), & file_status="OLD", file_action="WRITE", & file_position="APPEND", unit_number=file_ptr) IF(new_element%swaped)THEN @@ -438,14 +413,11 @@ END SUBROUTINE create_global_tree_dot !> on the basis of the element status !> \param tree_element the actual global element !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_dot_color(tree_element, tmc_params, error) + SUBROUTINE create_dot_color(tree_element, tmc_params) TYPE(tree_type), POINTER :: tree_element TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_dot_color', & routineP = moduleN//':'//routineN @@ -456,8 +428,8 @@ SUBROUTINE create_dot_color(tree_element, tmc_params, error) TYPE(gt_elem_list_type), POINTER :: tmp_pt_list_elem failure = .FALSE. - CPPrecondition(ASSOCIATED(tree_element),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tree_element),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) IF(DEBUG.GT.8)THEN list_of_nr = "" @@ -479,7 +451,7 @@ SUBROUTINE create_dot_color(tree_element, tmc_params, error) END IF CALL write_color(node_nr=tree_element%nr, stat=tree_element%stat, & - filename=get_dot_file_name(tmc_params,tree_element%sub_tree_nr,error), error=error) + filename=get_dot_file_name(tmc_params,tree_element%sub_tree_nr)) END SUBROUTINE create_dot_color ! ***************************************************************************** @@ -487,14 +459,11 @@ END SUBROUTINE create_dot_color !> on the basis of the element status !> \param gt_tree_element the actual global element !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_global_tree_dot_color(gt_tree_element, tmc_params, error) + SUBROUTINE create_global_tree_dot_color(gt_tree_element, tmc_params) TYPE(global_tree_type), POINTER :: gt_tree_element TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_global_tree_dot_color', & routineP = moduleN//':'//routineN @@ -502,12 +471,12 @@ SUBROUTINE create_global_tree_dot_color(gt_tree_element, tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(gt_tree_element),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_tree_element),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) IF(DEBUG.GT.8) WRITE(*,*)"mark global tree node color", gt_tree_element%nr, gt_tree_element%stat CALL write_color(node_nr=gt_tree_element%nr, stat=gt_tree_element%stat, & - filename=get_dot_file_name(tmc_params,0,error), error=error) + filename=get_dot_file_name(tmc_params,0)) END SUBROUTINE create_global_tree_dot_color !! ***************************************************************************** @@ -518,16 +487,15 @@ END SUBROUTINE create_global_tree_dot_color !!> see module cp_error_handling !!> \author Mandes 12.2012 !! ***************************************************************************** -! RECURSIVE SUBROUTINE create_tree(current, conf, filename, error) +! RECURSIVE SUBROUTINE create_tree(current, conf, filename) ! TYPE (tree_type), POINTER :: current ! INTEGER :: conf ! CHARACTER(LEN=*) :: filename -! TYPE(cp_error_type), INTENT(inout) :: error ! ! CHARACTER(LEN=*), PARAMETER :: routineN = 'create_tree', & ! routineP = moduleN//':'//routineN ! -! CALL create_dot_color(current, tmc_params, error) +! CALL create_dot_color(current, tmc_params) ! IF(ASSOCIATED(current%acc))THEN ! CALL create_dot_branch(parent_nr=current%nr, child_nr=current%acc%nr, & ! acc=.TRUE.,tmc_params=tmc_params, file_single_tree_ptr) diff --git a/src/tmc/tmc_file_io.F b/src/tmc/tmc_file_io.F index 62dccd58a0..9f440e00f6 100644 --- a/src/tmc/tmc_file_io.F +++ b/src/tmc/tmc_file_io.F @@ -67,14 +67,11 @@ MODULE tmc_file_io !> (instead of the ending) !> \param file_name original file name !> \param extra string to be added before the file extention -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval result_file_name the new filename !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION expand_file_name_ending(file_name, extra, error) RESULT(result_file_name) + FUNCTION expand_file_name_ending(file_name, extra) RESULT(result_file_name) CHARACTER(LEN=*) :: file_name, extra - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_path_length) :: result_file_name CHARACTER(LEN=*), PARAMETER :: routineN = 'expand_file_name_ending', & @@ -84,7 +81,7 @@ FUNCTION expand_file_name_ending(file_name, extra, error) RESULT(result_file_nam LOGICAL :: failure failure = .FALSE. - CPPrecondition(file_name.NE."",cp_failure_level,routineP,error,failure) + CPPrecondition(file_name.NE."",cp_failure_level,routineP,failure) ind = INDEX(file_name,".",BACK = .TRUE.) IF(.NOT.ind.EQ.0) THEN @@ -94,7 +91,7 @@ FUNCTION expand_file_name_ending(file_name, extra, error) RESULT(result_file_nam WRITE(result_file_name,*)TRIM(file_name),".",extra END IF result_file_name=TRIM(ADJUSTL(result_file_name)) - CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,error,failure) + CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,failure) END FUNCTION expand_file_name_ending ! ***************************************************************************** @@ -102,14 +99,11 @@ END FUNCTION expand_file_name_ending !> (before the file extention) !> \param file_name original file name !> \param extra string to be added before the file extention -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval result_file_name the new filename !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION expand_file_name_char(file_name, extra, error) RESULT(result_file_name) + FUNCTION expand_file_name_char(file_name, extra) RESULT(result_file_name) CHARACTER(LEN=*) :: file_name, extra - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_path_length) :: result_file_name CHARACTER(LEN=*), PARAMETER :: routineN = 'expand_file_name_char', & @@ -119,7 +113,7 @@ FUNCTION expand_file_name_char(file_name, extra, error) RESULT(result_file_name) LOGICAL :: failure failure = .FALSE. - CPPrecondition(file_name.NE."",cp_failure_level,routineP,error,failure) + CPPrecondition(file_name.NE."",cp_failure_level,routineP,failure) ind = INDEX(file_name,".",BACK = .TRUE.) IF(.NOT.ind.EQ.0) THEN @@ -129,7 +123,7 @@ FUNCTION expand_file_name_char(file_name, extra, error) RESULT(result_file_name) WRITE(result_file_name,*)TRIM(file_name),"_",extra END IF result_file_name=TRIM(ADJUSTL(result_file_name)) - CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,error,failure) + CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,failure) END FUNCTION expand_file_name_char ! ***************************************************************************** @@ -137,15 +131,12 @@ END FUNCTION expand_file_name_char !> (before the file extention) !> \param file_name original file name !> \param rvalue temperature to be added -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval result_file_name the new filename !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION expand_file_name_temp(file_name,rvalue, error) RESULT(result_file_name) + FUNCTION expand_file_name_temp(file_name,rvalue) RESULT(result_file_name) CHARACTER(LEN=*) :: file_name REAL(KIND=dp) :: rvalue - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_path_length) :: result_file_name CHARACTER(LEN=*), PARAMETER :: routineN = 'expand_file_name_temp', & @@ -156,7 +147,7 @@ FUNCTION expand_file_name_temp(file_name,rvalue, error) RESULT(result_file_name) LOGICAL :: failure failure = .FALSE. - CPPrecondition(file_name.NE."",cp_failure_level,routineP,error,failure) + CPPrecondition(file_name.NE."",cp_failure_level,routineP,failure) rval_to_string = "" @@ -174,7 +165,7 @@ FUNCTION expand_file_name_temp(file_name,rvalue, error) RESULT(result_file_name) END IF END IF result_file_name=TRIM(ADJUSTL(result_file_name)) - CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,error,failure) + CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,failure) END FUNCTION expand_file_name_temp ! ***************************************************************************** @@ -182,15 +173,12 @@ END FUNCTION expand_file_name_temp !> (before the file extention) !> \param file_name original file name !> \param ivalue number to be added -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval result_file_name the new filename !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION expand_file_name_int(file_name,ivalue, error) RESULT(result_file_name) + FUNCTION expand_file_name_int(file_name,ivalue) RESULT(result_file_name) CHARACTER(LEN=*) :: file_name INTEGER :: ivalue - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=default_path_length) :: result_file_name CHARACTER(LEN=*), PARAMETER :: routineN = 'expand_file_name_int', & @@ -201,7 +189,7 @@ FUNCTION expand_file_name_int(file_name,ivalue, error) RESULT(result_file_name) LOGICAL :: failure failure = .FALSE. - CPPrecondition(file_name.NE."",cp_failure_level,routineP,error,failure) + CPPrecondition(file_name.NE."",cp_failure_level,routineP,failure) rval_to_string = "" @@ -220,7 +208,7 @@ FUNCTION expand_file_name_int(file_name,ivalue, error) RESULT(result_file_name) END IF END IF result_file_name=TRIM(ADJUSTL(result_file_name)) - CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,error,failure) + CPPostcondition(result_file_name.NE."",cp_failure_level,routineP,failure) END FUNCTION expand_file_name_int !------------------------------------------------------------------------------ @@ -233,15 +221,12 @@ END FUNCTION expand_file_name_int !> temperatures !> \param job_counts the counters for counting the submitted different job types !> \param timings ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE print_restart_file(tmc_env, job_counts, timings, error) + SUBROUTINE print_restart_file(tmc_env, job_counts, timings) TYPE(tmc_env_type), POINTER :: tmc_env INTEGER, DIMENSION(:) :: job_counts REAL(KIND=dp), DIMENSION(4) :: timings - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_restart_file', & routineP = moduleN//':'//routineN @@ -252,17 +237,17 @@ SUBROUTINE print_restart_file(tmc_env, job_counts, timings, error) failure = .FALSE. c_tmp="" - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error, failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error, failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error, failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,error, failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,failure) IF(failure) RETURN WRITE(c_tmp, FMT='(I9.9)') tmc_env%m_env%result_count(0) file_name=TRIM(expand_file_name_char(& file_name=tmc_default_restart_out_file_name, & - extra=c_tmp, error=error)) + extra=c_tmp)) CALL open_file(file_name=file_name, file_status="REPLACE", & file_action="WRITE", file_form="UNFORMATTED", & unit_number=f_unit) @@ -312,16 +297,13 @@ END SUBROUTINE print_restart_file !> \param job_counts the counters for counting the submitted different job types !> \param timings ... !> \param file_name the restart file name -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE read_restart_file(tmc_env, job_counts, timings, file_name, error) + SUBROUTINE read_restart_file(tmc_env, job_counts, timings, file_name) TYPE(tmc_env_type), POINTER :: tmc_env INTEGER, DIMENSION(:) :: job_counts REAL(KIND=dp), DIMENSION(4) :: timings CHARACTER(LEN=*) :: file_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_restart_file', & routineP = moduleN//':'//routineN @@ -332,15 +314,15 @@ SUBROUTINE read_restart_file(tmc_env, job_counts, timings, file_name, error) REAL(KIND=dp), DIMENSION(nr_mv_types) :: mv_weight_tmp failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error, failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error, failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error, failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,error, failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,failure) IF(failure) RETURN IF(file_name.EQ.tmc_default_restart_in_file_name) THEN INQUIRE(FILE=tmc_default_restart_in_file_name, EXIST=flag) - CPPrecondition(flag,cp_failure_level,routineP,error, failure) + CPPrecondition(flag,cp_failure_level,routineP,failure) CALL open_file(file_name=tmc_default_restart_in_file_name, file_status="OLD", & file_action="READ", unit_number=file_ptr) READ(file_ptr,*) file_name @@ -354,7 +336,7 @@ SUBROUTINE read_restart_file(tmc_env, job_counts, timings, file_name, error) cp_failure_level,cp_assertion_failed,routineP,& "the actual specified temperatures does not "//& "fit in amount with the one from restart file ",& - error, failure=flag) + failure=flag) ALLOCATE(tmp_temp(temp_size)) READ(file_ptr) tmp_temp(:), & tmc_env%m_env%gt_act%nr, & @@ -376,11 +358,11 @@ SUBROUTINE read_restart_file(tmc_env, job_counts, timings, file_name, error) CALL cp_assert(ALL(ABS(tmc_env%params%Temp(:)-tmp_temp(:)) .LT. 0.005),& cp_failure_level,cp_assertion_failed,routineP,& "the temperatures differ from the previous calculation. There were the following temperatures used:",& - error, failure=flag) + failure=flag) CALL cp_assert(ALL(mv_weight_tmp(:).EQ.tmc_env%params%move_types%mv_weight(:)),& cp_warning_level,cp_assertion_failed,routineP,& "The amount of mv types differs between the original and the restart run. ",& - error, failure=flag) + failure=flag) DO i=1, SIZE(tmc_env%params%Temp) tmc_env%m_env%gt_act%conf(i)%elem => tmc_env%m_env%result_list(i)%elem @@ -411,19 +393,16 @@ END SUBROUTINE read_restart_file !> \param conf_updated index of the updated (modified element) !> \param accepted acceptance flag !> \param tmc_params TMC environment parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** SUBROUTINE write_result_list_element(result_list, result_count,conf_updated,& - accepted, tmc_params, error) + accepted, tmc_params) TYPE(elem_array_type), DIMENSION(:), & POINTER :: result_list INTEGER, DIMENSION(:), POINTER :: result_count INTEGER :: conf_updated LOGICAL, INTENT(IN) :: accepted TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_result_list_element', & routineP = moduleN//':'//routineN @@ -435,12 +414,12 @@ SUBROUTINE write_result_list_element(result_list, result_count,conf_updated,& failure = .FALSE. file_name = "" - CPPrecondition(ASSOCIATED(result_list),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(result_count),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params%Temp),cp_failure_level,routineP,error,failure) - CPPrecondition(conf_updated.GE.0,cp_failure_level,routineP,error,failure) - CPPrecondition(conf_updated.LE.SIZE(tmc_params%Temp),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(result_list),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(result_count),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params%Temp),cp_failure_level,routineP,failure) + CPPrecondition(conf_updated.GE.0,cp_failure_level,routineP,failure) + CPPrecondition(conf_updated.LE.SIZE(tmc_params%Temp),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -451,8 +430,7 @@ SUBROUTINE write_result_list_element(result_list, result_count,conf_updated,& WRITE(file_name,*)"every_step_",TRIM(tmc_default_trajectory_file_name) CALL write_element_in_file(elem=result_list(i)%elem, & tmc_params=tmc_params, conf_nr=result_count(0),& - file_name=expand_file_name_temp(file_name=file_name,rvalue=tmc_params%Temp(i), error=error), & - error=error) + file_name=expand_file_name_temp(file_name=file_name,rvalue=tmc_params%Temp(i))) END DO ELSE IF((.NOT.tmc_params%print_only_diff_conf).OR.& @@ -460,8 +438,7 @@ SUBROUTINE write_result_list_element(result_list, result_count,conf_updated,& CALL write_element_in_file(elem=result_list(conf_updated)%elem, & tmc_params=tmc_params, conf_nr=result_count(conf_updated),& file_name=expand_file_name_temp(file_name=TRIM(tmc_default_trajectory_file_name),& - rvalue=tmc_params%Temp(conf_updated), error=error),& - error=error) + rvalue=tmc_params%Temp(conf_updated))) END IF END IF ! end the timing @@ -476,19 +453,16 @@ END SUBROUTINE write_result_list_element !> \param file_name file name will be extended by type of file (pos, cell,...) !> \param conf_nr Markov chain element number !> \param conf_info whole header line -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_nr, & - conf_info, error) + conf_info) TYPE(tree_type), POINTER :: elem TYPE(tmc_param_type), POINTER :: tmc_params INTEGER, OPTIONAL :: temp_index CHARACTER(LEN=*), OPTIONAL :: file_name INTEGER, OPTIONAL :: conf_nr CHARACTER(LEN=*), OPTIONAL :: conf_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_element_in_file', & routineP = moduleN//':'//routineN @@ -506,10 +480,10 @@ SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_n header = "" print_it = .TRUE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(conf_nr).OR.PRESENT(conf_info),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(conf_nr).OR.PRESENT(conf_info),cp_failure_level,routineP,failure) IF(print_it) THEN ! start the timing @@ -517,13 +491,13 @@ SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_n ! set default file name IF(PRESENT(file_name)) THEN - CPPrecondition(file_name.NE."",cp_failure_level,routineP,error,failure) + CPPrecondition(file_name.NE."",cp_failure_level,routineP,failure) file_name_act = file_name ELSE - CPPrecondition(ASSOCIATED(tmc_params%Temp),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(temp_index),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params%Temp),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(temp_index),cp_failure_level,routineP,failure) file_name_act = expand_file_name_temp(file_name=tmc_default_trajectory_file_name, & - rvalue=tmc_params%Temp(temp_index), error=error) + rvalue=tmc_params%Temp(temp_index)) END IF nr_atoms=SIZE(elem%pos)/tmc_params%dim_per_elem @@ -541,7 +515,7 @@ SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_n ! write the coordinates IF(tmc_params%print_trajectory) THEN - tmp_name = expand_file_name_ending(file_name_act,"xyz",error) + tmp_name = expand_file_name_ending(file_name_act,"xyz") CALL open_file(file_name=tmp_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) @@ -557,7 +531,7 @@ SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_n ! write the forces IF(tmc_params%print_forces) THEN - tmp_name = expand_file_name_ending(file_name_act,"frc",error) + tmp_name = expand_file_name_ending(file_name_act,"frc") CALL open_file(file_name=tmp_name, file_status="UNKNOWN", & file_action="WRITE", file_position="APPEND", & unit_number=file_ptr) @@ -574,12 +548,12 @@ SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_n ! write the cell dipoles IF(tmc_params%print_dipole) THEN CALL write_dipoles_in_file(file_name=file_name_act, & - conf_nr=conf_nr, dip=elem%dipole, error=error) + conf_nr=conf_nr, dip=elem%dipole) END IF ! write the cell file IF(tmc_params%print_cell) THEN - tmp_name = expand_file_name_ending(file_name_act,"cell",error) + tmp_name = expand_file_name_ending(file_name_act,"cell") ! header INQUIRE(FILE=tmp_name, EXIST=file_exists) ! file_exists will be TRUE if the file exist IF(.NOT.file_exists) THEN @@ -595,7 +569,7 @@ SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_n END IF CALL get_scaled_cell(cell=tmc_params%cell, & box_scale=elem%box_scale, scaled_hmat=hmat_scaled, & - vol=vol, error=error) + vol=vol) WRITE (file_ptr,FMT="(I8,9(1X,F19.10),1X,F24.10)") conf_nr, & hmat_scaled(:,:)*au2a, vol* au2a**3 !TODO better cell output e.g. using cell_types routine @@ -604,7 +578,7 @@ SUBROUTINE write_element_in_file(elem, tmc_params, temp_index, file_name, conf_n ! write the different energies IF(tmc_params%print_energies) THEN - tmp_name = expand_file_name_ending(file_name_act,"ener",error) + tmp_name = expand_file_name_ending(file_name_act,"ener") ! header INQUIRE(FILE=tmp_name, EXIST=file_exists) ! file_exists will be TRUE if the file exist IF(.NOT.file_exists) THEN @@ -633,17 +607,14 @@ END SUBROUTINE write_element_in_file !> \param conf_nr ... !> \param dip ... !> \param file_ext ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE write_dipoles_in_file(file_name, conf_nr, dip, file_ext, error) + SUBROUTINE write_dipoles_in_file(file_name, conf_nr, dip, file_ext) CHARACTER(LEN=default_path_length) :: file_name INTEGER :: conf_nr REAL(KIND=dp), DIMENSION(:), POINTER :: dip CHARACTER(LEN=*), INTENT(in), OPTIONAL :: file_ext - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_dipoles_in_file', & routineP = moduleN//':'//routineN @@ -652,13 +623,13 @@ SUBROUTINE write_dipoles_in_file(file_name, conf_nr, dip, file_ext, error) INTEGER :: file_ptr LOGICAL :: failure, file_exists - CPPrecondition(ASSOCIATED(dip),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(dip),cp_failure_level,routineP,failure) IF(PRESENT(file_ext)) THEN - CPPrecondition(file_ext.NE."",cp_failure_level,routineP,error,failure) - file_name_tmp = expand_file_name_ending(file_name,TRIM(file_ext),error) + CPPrecondition(file_ext.NE."",cp_failure_level,routineP,failure) + file_name_tmp = expand_file_name_ending(file_name,TRIM(file_ext)) ELSE - file_name_tmp = expand_file_name_ending(file_name,"dip",error) + file_name_tmp = expand_file_name_ending(file_name,"dip") END IF INQUIRE(FILE=file_name_tmp, EXIST=file_exists) IF(.NOT.file_exists) THEN @@ -686,15 +657,12 @@ END SUBROUTINE write_dipoles_in_file !> \param conf_nr Markov chain element number !> (input the old number and read only if conf nr from file is greater !> \param stat ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE read_element_from_file(elem, tmc_ana, conf_nr, stat, error) + SUBROUTINE read_element_from_file(elem, tmc_ana, conf_nr, stat) TYPE(tree_type), POINTER :: elem TYPE(tmc_analysis_env), POINTER :: tmc_ana INTEGER :: conf_nr, stat - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_element_from_file', & routineP = moduleN//':'//routineN @@ -708,9 +676,9 @@ SUBROUTINE read_element_from_file(elem, tmc_ana, conf_nr, stat, error) conf_nr_old = conf_nr files_conf_missmatch = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_ana%atoms),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_ana%atoms),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -719,16 +687,16 @@ SUBROUTINE read_element_from_file(elem, tmc_ana, conf_nr, stat, error) IF(tmc_ana%id_traj.GT.0) THEN i_tmp = conf_nr_old CALL read_pos_from_file(elem=elem, tmc_ana=tmc_ana, stat=stat, & - conf_nr=i_tmp, error=error) + conf_nr=i_tmp) IF(stat.EQ.TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& 'end of position file reached at line '//& cp_to_string(REAL(tmc_ana%lc_traj,KIND=dp))//", last element "//& cp_to_string(tmc_ana%last_elem%nr),& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) ELSE - CPPostcondition(i_tmp.GT.conf_nr_old,cp_failure_level,routineP,error,failure) + CPPostcondition(i_tmp.GT.conf_nr_old,cp_failure_level,routineP,failure) conf_nr = i_tmp elem%nr = i_tmp END IF @@ -742,13 +710,13 @@ SUBROUTINE read_element_from_file(elem, tmc_ana, conf_nr, stat, error) i_tmp = conf_nr_old search_conf_dip: DO CALL read_dipole_from_file(elem=elem, tmc_ana=tmc_ana, stat=stat, & - conf_nr=i_tmp, error=error) + conf_nr=i_tmp) IF(stat.EQ.TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& 'end of dipole file reached at line'//& cp_to_string(REAL(tmc_ana%lc_dip,KIND=dp)),& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) EXIT search_conf_dip END IF ! check consitence with pos file @@ -774,13 +742,13 @@ SUBROUTINE read_element_from_file(elem, tmc_ana, conf_nr, stat, error) IF(tmc_ana%id_cell.GT.0 .AND. stat.EQ.TMC_STATUS_OK) THEN search_conf_cell: DO CALL read_cell_from_file(elem=elem, tmc_ana=tmc_ana, stat=stat, & - conf_nr=i_tmp, error=error) + conf_nr=i_tmp) IF(stat.EQ.TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& 'end of cell file reached at line at line'//& cp_to_string(REAL(tmc_ana%lc_cell, KIND=dp)),& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) EXIT search_conf_cell END IF ! check consitence with pos file @@ -813,7 +781,7 @@ SUBROUTINE read_element_from_file(elem, tmc_ana, conf_nr, stat, error) cp_to_string(tmc_ana%lc_traj)//"|"//& cp_to_string(tmc_ana%lc_cell)//"|"//& cp_to_string(tmc_ana%lc_dip), & - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) ! end the timing CALL timestop(handle) @@ -827,16 +795,13 @@ END SUBROUTINE read_element_from_file !> \param conf_nr Markov chain element number !> (input the old number and read only if conf nr from file is greater !> \param header_info ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE read_pos_from_file(elem, tmc_ana, stat, conf_nr, header_info, error) + SUBROUTINE read_pos_from_file(elem, tmc_ana, stat, conf_nr, header_info) TYPE(tree_type), POINTER :: elem TYPE(tmc_analysis_env), POINTER :: tmc_ana INTEGER :: stat, conf_nr CHARACTER(LEN=*), OPTIONAL :: header_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_pos_from_file', & routineP = moduleN//':'//routineN @@ -848,10 +813,10 @@ SUBROUTINE read_pos_from_file(elem, tmc_ana, stat, conf_nr, header_info, error) failure = .FALSE. stat = TMC_STATUS_FAILED - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) - CPPrecondition(tmc_ana%id_traj.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem%pos),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) + CPPrecondition(tmc_ana%id_traj.GT.0,cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -863,7 +828,7 @@ SUBROUTINE read_pos_from_file(elem, tmc_ana, stat, conf_nr, header_info, error) CALL cp_assert(status.LE.0,& cp_failure_level,cp_assertion_failed,routineP,& "configuration header read error at line: "//& - cp_to_string(tmc_ana%lc_traj)//": "//c_tmp, error) + cp_to_string(tmc_ana%lc_traj)//": "//c_tmp) IF(status .LT. 0) THEN ! end of file reached stat = TMC_STATUS_WAIT_FOR_NEW_TASK EXIT search_next_conf @@ -873,7 +838,7 @@ SUBROUTINE read_pos_from_file(elem, tmc_ana, stat, conf_nr, header_info, error) CALL cp_assert(status.EQ.0,& cp_failure_level,cp_assertion_failed,routineP,& "configuration header read error (for conf nr) at line: "//& - cp_to_string(tmc_ana%lc_traj), error) + cp_to_string(tmc_ana%lc_traj)) IF(i_tmp .GT. conf_nr) THEN ! TODO we could also read the energy ... conf_nr = i_tmp @@ -893,7 +858,7 @@ SUBROUTINE read_pos_from_file(elem, tmc_ana, stat, conf_nr, header_info, error) CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "configuration pos read error at line: "//& - cp_to_string(tmc_ana%lc_traj), error) + cp_to_string(tmc_ana%lc_traj)) END IF END DO pos_loop elem%pos(:) = elem%pos(:)/au2a @@ -910,15 +875,12 @@ END SUBROUTINE read_pos_from_file !> \param stat ... !> \param conf_nr Markov chain element number !> (input the old number and read only if conf nr from file is greater -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE read_dipole_from_file(elem, tmc_ana, stat, conf_nr, error) + SUBROUTINE read_dipole_from_file(elem, tmc_ana, stat, conf_nr) TYPE(tree_type), POINTER :: elem TYPE(tmc_analysis_env), POINTER :: tmc_ana INTEGER :: stat, conf_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_dipole_from_file', & routineP = moduleN//':'//routineN @@ -930,10 +892,10 @@ SUBROUTINE read_dipole_from_file(elem, tmc_ana, stat, conf_nr, error) failure = .FALSE. stat = TMC_STATUS_FAILED - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem%dipole),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) - CPPrecondition(tmc_ana%id_dip.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem%dipole),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) + CPPrecondition(tmc_ana%id_dip.GT.0,cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -957,7 +919,7 @@ SUBROUTINE read_dipole_from_file(elem, tmc_ana, stat, conf_nr, error) ELSE CALL cp_assert(status.EQ.0,& cp_warning_level,cp_assertion_failed,routineP,& - "configuration dipole read error at line: "//cp_to_string(tmc_ana%lc_dip), error) + "configuration dipole read error at line: "//cp_to_string(tmc_ana%lc_dip)) stat = TMC_STATUS_FAILED END IF @@ -972,15 +934,12 @@ END SUBROUTINE read_dipole_from_file !> \param stat ... !> \param conf_nr Markov chain element number !> (input the old number and read only if conf nr from file is greater -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE read_cell_from_file(elem, tmc_ana, stat, conf_nr, error) + SUBROUTINE read_cell_from_file(elem, tmc_ana, stat, conf_nr) TYPE(tree_type), POINTER :: elem TYPE(tmc_analysis_env), POINTER :: tmc_ana INTEGER :: stat, conf_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_cell_from_file', & routineP = moduleN//':'//routineN @@ -994,10 +953,10 @@ SUBROUTINE read_cell_from_file(elem, tmc_ana, stat, conf_nr, error) failure = .FALSE. stat = TMC_STATUS_FAILED - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_ana%cell),cp_failure_level,routineP,error,failure) - CPPrecondition(tmc_ana%id_cell.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_ana%cell),cp_failure_level,routineP,failure) + CPPrecondition(tmc_ana%id_cell.GT.0,cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1021,14 +980,14 @@ SUBROUTINE read_cell_from_file(elem, tmc_ana, stat, conf_nr, error) ELSE IF(status.GT.0) THEN CALL cp_assert(status.EQ.0,& cp_failure_level,cp_assertion_failed,routineP,& - "configuration cell read error at line: "//cp_to_string(tmc_ana%lc_cell), error) + "configuration cell read error at line: "//cp_to_string(tmc_ana%lc_cell)) stat = TMC_STATUS_FAILED ELSE IF(elem%nr.LT.0) elem%nr=conf_nr hmat(:,:) = hmat(:,:)/au2a ! get the box scaling CALL get_cell_scaling(cell=tmc_ana%cell, scaled_hmat=hmat, & - box_scale=elem%box_scale, error=error) + box_scale=elem%box_scale) stat = TMC_STATUS_OK END IF ! end the timing @@ -1044,16 +1003,13 @@ END SUBROUTINE read_cell_from_file !> \param tmc_ana ... !> \param stat ... !> \param dir_ind ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind, error) + SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind) TYPE(tmc_analysis_env), POINTER :: tmc_ana INTEGER :: stat INTEGER, OPTIONAL :: dir_ind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'analyse_files_open', & routineP = moduleN//':'//routineN @@ -1064,7 +1020,7 @@ SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind, error) LOGICAL :: failure, file_exists failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) stat = TMC_STATUS_WAIT_FOR_NEW_TASK @@ -1072,9 +1028,9 @@ SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind, error) CALL timeset(routineN,handle) IF(PRESENT(dir_ind)) THEN - CPPrecondition(ASSOCIATED(tmc_ana%dirs),cp_failure_level,routineP,error,failure) - CPPrecondition(dir_ind.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(dir_ind.LE.SIZE(tmc_ana%dirs),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_ana%dirs),cp_failure_level,routineP,failure) + CPPrecondition(dir_ind.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(dir_ind.LE.SIZE(tmc_ana%dirs),cp_failure_level,routineP,failure) IF(INDEX(tmc_ana%dirs(dir_ind),"/", BACK=.TRUE.).EQ.& LEN_TRIM(tmc_ana%dirs(dir_ind))) THEN @@ -1089,13 +1045,13 @@ SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind, error) ! open the files file_name_temp = expand_file_name_temp(& file_name=tmc_default_trajectory_file_name, & - rvalue=tmc_ana%temperature, error=error) + rvalue=tmc_ana%temperature) ! position file IF(tmc_ana%costum_pos_file_name.NE."") THEN file_name_act = TRIM(dir_name)//tmc_ana%costum_pos_file_name ELSE file_name_act = TRIM(dir_name)//& - expand_file_name_ending(file_name_temp,"xyz",error) + expand_file_name_ending(file_name_temp,"xyz") END IF INQUIRE(FILE=file_name_act, EXIST=file_exists) IF(file_exists) THEN @@ -1110,7 +1066,7 @@ SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind, error) file_name_act = TRIM(dir_name)//tmc_ana%costum_cell_file_name ELSE file_name_act = TRIM(dir_name)//& - expand_file_name_ending(file_name_temp,"cell",error) + expand_file_name_ending(file_name_temp,"cell") END IF INQUIRE(FILE=file_name_act, EXIST=file_exists) IF(file_exists) THEN @@ -1125,7 +1081,7 @@ SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind, error) file_name_act = TRIM(dir_name)//tmc_ana%costum_dip_file_name ELSE file_name_act = TRIM(dir_name)//& - expand_file_name_ending(file_name_temp,"dip",error) + expand_file_name_ending(file_name_temp,"dip") END IF INQUIRE(FILE=file_name_act, EXIST=file_exists) IF(file_exists) THEN @@ -1142,8 +1098,7 @@ SUBROUTINE analyse_files_open(tmc_ana, stat, dir_ind, error) CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& "There is no file to open for temperature "//cp_to_string(tmc_ana%temperature)//& - "K in directory "//TRIM(dir_name),& - error) + "K in directory "//TRIM(dir_name)) END IF ! end the timing CALL timestop(handle) @@ -1152,14 +1107,11 @@ END SUBROUTINE analyse_files_open ! ***************************************************************************** !> \brief close the files for reading configurations data to analyze !> \param tmc_ana ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE analyse_files_close(tmc_ana, error) + SUBROUTINE analyse_files_close(tmc_ana) TYPE(tmc_analysis_env), POINTER :: tmc_ana - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'analyse_files_close', & routineP = moduleN//':'//routineN @@ -1168,7 +1120,7 @@ SUBROUTINE analyse_files_close(tmc_ana, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_ana),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) diff --git a/src/tmc/tmc_master.F b/src/tmc/tmc_master.F index cc662f46bd..f2f3a8ffd0 100644 --- a/src/tmc/tmc_master.F +++ b/src/tmc/tmc_master.F @@ -96,19 +96,16 @@ MODULE tmc_master !> \param cancel_count counter of canceled elements !> \param para_env communication environment !> \param tmc_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE cancel_calculations(cancel_list, work_list, cancel_count,& - para_env, tmc_env, error) + para_env, tmc_env) TYPE(elem_list_type), POINTER :: cancel_list TYPE(elem_array_type), DIMENSION(:), & POINTER :: work_list INTEGER :: cancel_count TYPE(cp_para_env_type), POINTER :: para_env TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cancel_calculations', & routineP = moduleN//':'//routineN @@ -121,11 +118,11 @@ SUBROUTINE cancel_calculations(cancel_list, work_list, cancel_count,& IF(.NOT.ASSOCIATED(cancel_list)) RETURN NULLIFY(tmp_element) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(work_list),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(work_list),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) stat = TMC_STATUS_FAILED @@ -145,16 +142,16 @@ SUBROUTINE cancel_calculations(cancel_list, work_list, cancel_count,& END IF END DO working_elem_loop - CPPostcondition(wg.GE.0,cp_failure_level,routineP,error,failure) - CPPostcondition(stat.NE.TMC_STATUS_FAILED,cp_failure_level,routineP,error,failure) - CPPostcondition(work_list(wg)%elem%stat.NE.status_calc_approx_ener,cp_failure_level,routineP,error,failure) + CPPostcondition(wg.GE.0,cp_failure_level,routineP,failure) + CPPostcondition(stat.NE.TMC_STATUS_FAILED,cp_failure_level,routineP,failure) + CPPostcondition(work_list(wg)%elem%stat.NE.status_calc_approx_ener,cp_failure_level,routineP,failure) IF(DEBUG.GE.1) & WRITE(tmc_env%m_env%io_unit,*)& "TMC|master: cancel group "//cp_to_string(wg) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & - para_env=para_env, tmc_params=tmc_env%params, error=error) + para_env=para_env, tmc_params=tmc_env%params) work_list(wg)%canceled = .TRUE. ! counting the amount of canceled elements @@ -179,17 +176,14 @@ END SUBROUTINE cancel_calculations !> \param ana_worker_info ... !> \param para_env communication environment !> \param tmc_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE send_analysis_tasks(ana_list, ana_worker_info, para_env, tmc_env, error) + SUBROUTINE send_analysis_tasks(ana_list, ana_worker_info, para_env, tmc_env) TYPE(elem_list_type), POINTER :: ana_list TYPE(elem_array_type), DIMENSION(:), & POINTER :: ana_worker_info TYPE(cp_para_env_type), POINTER :: para_env TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'send_analysis_tasks', & routineP = moduleN//':'//routineN @@ -200,8 +194,8 @@ SUBROUTINE send_analysis_tasks(ana_list, ana_worker_info, para_env, tmc_env, err NULLIFY(list_tmp) - CPPrecondition(ASSOCIATED(ana_worker_info),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ana_worker_info),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) wg_loop:DO wg=1, SIZE(ana_worker_info) @@ -211,7 +205,7 @@ SUBROUTINE send_analysis_tasks(ana_list, ana_worker_info, para_env, tmc_env, err dest = wg CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=dest, & para_env=para_env, tmc_params=tmc_env%params, & - list_elem=ana_list, error=error) + list_elem=ana_list) IF(.NOT.ASSOCIATED(ana_list%next)) THEN DEALLOCATE(ana_list) ana_list => NULL() @@ -229,14 +223,11 @@ END SUBROUTINE send_analysis_tasks !> distribution with workers !> \param tmc_env structure for storing all the tmc parameters !> \param globenv global environment for external control -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE do_tmc_master(tmc_env, globenv, error) + SUBROUTINE do_tmc_master(tmc_env, globenv) TYPE(tmc_env_type), POINTER :: tmc_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_tmc_master', & routineP = moduleN//':'//routineN @@ -263,13 +254,13 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) restarted_elem_nr = 0 NULLIFY(init_conf, worker_info, ana_worker_info, gt_elem_tmp, tree_elem_counters) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) - CPPrecondition(tmc_env%tmc_comp_set%group_nr==0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_w),cp_failure_level,routineP,error,failure) + CPPrecondition(tmc_env%tmc_comp_set%group_nr==0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_w),cp_failure_level,routineP,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) !-- run time measurment, to end just in time ! start the timing @@ -280,7 +271,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! initialize the different modules IF(tmc_env%params%DRAW_TREE) & - CALL init_draw_trees(tmc_params=tmc_env%params, error=error) + CALL init_draw_trees(tmc_params=tmc_env%params) !-- initialize variables ! nr_of_job: counting the differnt task send / received @@ -309,44 +300,42 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - wait_for_message=.TRUE., error=error) + wait_for_message=.TRUE.) !-- wait for start configuration results and number of dimentions !-- get start configuration (init_conf element should not be allocated already) CALL tmc_message(msg_type=stat, send_recv=recv_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - elem=init_conf, success=flag, wait_for_message=.TRUE.,& - error=error) + elem=init_conf, success=flag, wait_for_message=.TRUE.) CALL cp_assert(stat.EQ.TMC_STAT_START_CONF_RESULT, cp_failure_level,& cp_assertion_failed,routineP,& "receiving start configuration failed, received stat "//& - cp_to_string(stat), error, failure=failure) + cp_to_string(stat),failure=failure) IF(failure)THEN CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_m_w, & worker_info=worker_info, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_m_ana, & worker_info=ana_worker_info, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CALL timestop(handle) RETURN END IF ! get the atom names from first energy worker CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1,& - para_env=tmc_env%tmc_comp_set%para_env_m_first_w, & - error=error) + para_env=tmc_env%tmc_comp_set%para_env_m_first_w) CALL init_cell(cell=tmc_env%params%cell) ! check the configuration consitency with selected moves CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%move_types, & - mol_array=init_conf%mol, error=error) + mol_array=init_conf%mol) IF(ASSOCIATED(tmc_env%params%nmc_move_types)) & CALL check_moves(tmc_params=tmc_env%params, & move_types=tmc_env%params%nmc_move_types, & - mol_array=init_conf%mol, error=error) + mol_array=init_conf%mol) ! set initial configuration ! set initial random number generator seed (rng seed) @@ -354,7 +343,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! seting the subtrees CALL init_tree_mod(start_elem=init_conf, tmc_env=tmc_env, & job_counts=nr_of_job, & - worker_timings=worker_timings_aver, error=error) + worker_timings=worker_timings_aver) ! init restart counter (espacially for restart case) IF(tmc_env%m_env%restart_out_step .NE. 0) THEN @@ -370,8 +359,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) stat = TMC_STATUS_WORKER_INIT CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& - tmc_params=tmc_env%params, & - error=error) + tmc_params=tmc_env%params) END DO ! send the atom informations to all analysis workers @@ -383,15 +371,14 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) result_count=tmc_env%m_env%result_count, & tmc_params=tmc_env%params, & elem=init_conf, & - wait_for_message=.TRUE., error=error) + wait_for_message=.TRUE.) END DO CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=0,& - para_env=tmc_env%tmc_comp_set%para_env_m_ana, & - error=error) + para_env=tmc_env%tmc_comp_set%para_env_m_ana) END IF - CALL deallocate_sub_tree_node(tree_elem=init_conf, error=error) + CALL deallocate_sub_tree_node(tree_elem=init_conf) ! regtest output IF(tmc_env%params%print_test_output.OR.DEBUG.GT.0)& @@ -407,8 +394,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - elem=tmc_env%m_env%gt_head%conf(1)%elem, & - error=error) + elem=tmc_env%m_env%gt_head%conf(1)%elem) worker_info(wg)%busy = .TRUE. worker_info(wg)%elem => tmc_env%m_env%gt_head%conf(1)%elem init_conf => tmc_env%m_env%gt_head%conf(1)%elem @@ -433,7 +419,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL tmc_message(msg_type=stat,send_recv=recv_msg,dest=wg,& para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - elem_array=worker_info(:), success=flag, error=error) + elem_array=worker_info(:), success=flag) IF(flag.EQV..FALSE.) EXIT worker_request_loop ! messages from worker group could be faster then the canceling request @@ -451,7 +437,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) cp_failure_level,cp_assertion_failed,routineP,& "no tree elem exist when receiving stat "//& cp_to_string(stat)//"of group"//cp_to_string(wg),& - error, failure=flag) + failure=flag) IF(DEBUG.GE.1) & WRITE(tmc_env%m_env%io_unit,*)& @@ -467,7 +453,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! -- CANCEL_RECEIPT ------------------ CASE(TMC_CANCELING_RECEIPT) ! worker should got cancel message before - CPPrecondition(worker_info(wg)%canceled ,cp_failure_level,routineP,error,failure) + CPPrecondition(worker_info(wg)%canceled ,cp_failure_level,routineP,failure) worker_info(wg)%canceled = .FALSE. worker_info(wg)%busy = .FALSE. @@ -483,7 +469,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) worker_info(wg)%elem%potential = 8000.0_dp IF(tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF CASE(status_cancel_nmc) !-- timings @@ -495,7 +481,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) worker_info(wg)%elem%potential = 8000.0_dp IF(tmc_env%params%DRAW_TREE) THEN CALL create_dot_color(tree_element=worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF CASE DEFAULT ! the subtree element is again in use (reactivated) @@ -505,7 +491,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! -- START_CONF_RESULT --------------- CASE(TMC_STAT_START_CONF_RESULT) ! start configuration should already be handeled - CPPrecondition(.FALSE. ,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE. ,cp_failure_level,routineP,failure) ! -- ENERGY RESULT ----------------- CASE(TMC_STAT_APPROX_ENERGY_RESULT) nr_of_job(3) = nr_of_job(3) +1 @@ -513,7 +499,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) worker_info(wg)%elem%stat = status_created IF(tmc_env%params%DRAW_TREE)THEN CALL create_dot_color(tree_element=worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF worker_info(wg)%elem => NULL() ! nothing to do, the approximate potential @@ -527,11 +513,11 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) nr_of_job(3) = nr_of_job(3) +1 worker_info(wg)%start_time = m_walltime() - worker_info(wg)%start_time - CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay, error) + CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay) worker_info(wg)%elem%stat = status_created IF(tmc_env%params%DRAW_TREE)THEN CALL create_dot_color(tree_element=worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF !-- send energy request ! in case of one singe input file, energy is already calculated @@ -541,18 +527,18 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! check acceptance of depending nodes IF(.NOT.(ASSOCIATED(worker_info(wg)%elem,init_conf))) THEN CALL check_acceptance_of_depending_subtree_nodes(tree_elem=worker_info(wg)%elem, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) END IF IF(tmc_env%params%DRAW_TREE)THEN CALL create_dot_color(tree_element=worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF !-- CANCELING the calculations of the elements, which are definetively not needed anymore CALL cancel_calculations(cancel_list=tmc_env%m_env%cancelation_list, & work_list=worker_info, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & - cancel_count=cancel_count, error=error) + cancel_count=cancel_count) worker_info(wg)%elem => NULL() ELSE ! if all working groups are equal, the same group calculates the energy @@ -564,12 +550,12 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_params=tmc_env%params, & - elem=worker_info(wg)%elem, error=error) + elem=worker_info(wg)%elem) worker_info(wg)%busy = .TRUE. nr_of_job(2) = nr_of_job(2) +1 IF(tmc_env%params%DRAW_TREE)THEN CALL create_dot_color(tree_element=worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF !-- set start time for energy calculation worker_info(wg)%start_time = m_walltime() @@ -585,7 +571,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) nr_of_job(4) = nr_of_job(4) +1 worker_info(wg)%start_time = m_walltime()-worker_info(wg)%start_time - CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay, error) + CALL set_walltime_delay(worker_info(wg)%start_time, walltime_delay) IF(.NOT.worker_info(wg)%canceled)& worker_info(wg)%busy = .FALSE. @@ -593,30 +579,30 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) IF(ASSOCIATED(worker_info(wg)%elem, init_conf)) THEN !-- distribute energy of first element to all subtrees CALL finalize_init(gt_tree_ptr=tmc_env%m_env%gt_head, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) IF(tmc_env%params%DRAW_TREE) THEN CALL create_global_tree_dot_color(gt_tree_element=tmc_env%m_env%gt_act, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CALL create_dot_color(tree_element=worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF init_conf => NULL() ELSE worker_info(wg)%elem%stat = status_calculated IF(tmc_env%params%DRAW_TREE) & CALL create_dot_color(worker_info(wg)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) ! check acceptance of depending nodes ! first (initial) configuration do not have to be checked CALL check_acceptance_of_depending_subtree_nodes(tree_elem=worker_info(wg)%elem, & - tmc_env=tmc_env,error=error) + tmc_env=tmc_env) END IF !-- write out all configurations (not only Markov Chain) e.g. for fitting IF(tmc_env%params%all_conf_file_name.NE."")THEN CALL write_element_in_file(elem=worker_info(wg)%elem, & file_name=tmc_env%params%all_conf_file_name, & tmc_params=tmc_env%params, & - conf_nr=nr_of_job(4), error=error) + conf_nr=nr_of_job(4)) END IF !-- CANCELING the calculations of the elements, @@ -625,7 +611,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) work_list=worker_info, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & - cancel_count=cancel_count, error=error) + cancel_count=cancel_count) IF(DEBUG.GE.9) & WRITE(tmc_env%m_env%io_unit,*) & "TMC|master: handled energy result of sub tree ", & @@ -640,14 +626,14 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) worker_info(wg)%elem%stat.NE.status_cancel_nmc) THEN ! update the acceptance probability and the canceling list CALL check_elements_for_acc_prob_update(tree_elem=worker_info(wg)%elem, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) END IF ! cancel inlikely elements CALL cancel_calculations(cancel_list=tmc_env%m_env%cancelation_list, & work_list=worker_info, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & tmc_env=tmc_env, & - cancel_count=cancel_count,error=error) + cancel_count=cancel_count) CASE(TMC_STAT_ANALYSIS_RESULT) ana_worker_info(wg)%busy = .FALSE. ana_worker_info(wg)%elem => NULL() @@ -655,12 +641,12 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "received message with unknown info/stat type", & - error, failure=flag) + failure=flag) END SELECT END DO worker_request_loop !-- do tree update (check new results) CALL tree_update(tmc_env=tmc_env, result_acc=flag, & - something_updated=l_update_tree, error=error) + something_updated=l_update_tree) IF(DEBUG.GE.2 .AND. l_update_tree) & WRITE(tmc_env%m_env%io_unit,*) & "TMC|master: tree updated "//cp_to_string(l_update_tree)// & @@ -670,7 +656,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL send_analysis_tasks(ana_list=tmc_env%m_env%analysis_list, & ana_worker_info=ana_worker_info, & para_env=tmc_env%tmc_comp_set%para_env_m_ana, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) ! ======================================================================= !-- ALL CALCULATIONS DONE (check) --- @@ -678,8 +664,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! if enough configurations are sampled or walltime is exeeded, ! finish building trees !TODO set correct logger para_env to use this - CALL external_control(should_stop=external_stop,flag="TMC",globenv=globenv,& - error=error) + CALL external_control(should_stop=external_stop,flag="TMC",globenv=globenv) IF((ANY(tmc_env%m_env%result_count(1:).GE.tmc_env%m_env%num_MC_elem)& .AND.flag).OR.& (m_walltime()-run_time_start .GT. & @@ -700,7 +685,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) END IF IF(tmc_env%m_env%restart_out_step.NE.0)& CALL print_restart_file(tmc_env=tmc_env,job_counts=nr_of_job, & - timings=worker_timings_aver, error=error) + timings=worker_timings_aver) EXIT task_loop END IF @@ -714,8 +699,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) !-- CLEANING tree nodes beside the path through the tree from ! end_of_clean_tree to tree_ptr ! --> getting back the end of clean tree - CALL remove_all_trees(working_elem_list=worker_info, tmc_env=tmc_env, & - error=error) + CALL remove_all_trees(working_elem_list=worker_info, tmc_env=tmc_env) !-- CANCELING the calculations of the elements, ! which are definetively not needed anymore ! elements are added to canceling list if no global tree reference @@ -724,7 +708,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) work_list=worker_info, & cancel_count=cancel_count, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) END IF ! ===================================================================== @@ -745,13 +729,11 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! search next element to calculate the energy CALL search_next_energy_calc(gt_head=tmc_env%m_env%gt_act, & new_gt_elem=gt_elem_tmp, stat=stat,& - react_count=reactivation_ener_count, & - error=error) + react_count=reactivation_ener_count) IF(stat.EQ.TMC_STATUS_WAIT_FOR_NEW_TASK) THEN CALL create_new_gt_tree_node(tmc_env=tmc_env, stat=stat, & new_elem=gt_elem_tmp, & - reactivation_cc_count=reactivation_cc_count, & - error=error) + reactivation_cc_count=reactivation_cc_count) END IF ELSEIF(wg.GT.tmc_env%tmc_comp_set%group_ener_nr) THEN ! specialized groups (groups for exact energy and groups for configurational change) @@ -759,8 +741,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) !-- crate new node, configurational change is handled in tmc_tree module CALL create_new_gt_tree_node(tmc_env=tmc_env, stat=stat, & new_elem=gt_elem_tmp, & - reactivation_cc_count=reactivation_cc_count, & - error=error) + reactivation_cc_count=reactivation_cc_count) ! element could be already created, hence CC worker has nothing to do for this element ! in next round he will get a task IF(stat.EQ.status_created .OR. stat.EQ.status_calculate_energy) & @@ -769,8 +750,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ! search next element to calculate the energy CALL search_next_energy_calc(gt_head=tmc_env%m_env%gt_act, & new_gt_elem=gt_elem_tmp, stat=stat, & - react_count=reactivation_ener_count, & - error=error) + react_count=reactivation_ener_count) END IF IF(DEBUG.GE.10)& @@ -792,8 +772,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & - error=error) + elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem) nr_of_job(1) = nr_of_job(1) +1 CASE(status_created, status_calculate_energy) ! in case of parallel tempering the node can be already be calculating (related to another global tree node @@ -801,22 +780,20 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem%stat = status_calculate_energy IF(tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) stat = TMC_STAT_ENERGY_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & - error=error) + elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem) nr_of_job(2) = nr_of_job(2) +1 CASE(status_calculate_MD) stat = TMC_STAT_MD_REQUEST CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & + elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem) ! temperature=tmc_env%params%Temp(gt_elem_tmp%mv_conf), & - error=error) nr_of_job(1) = nr_of_job(1) +1 CASE(status_calculate_NMC_steps) !-- send information of element, which should be calculated @@ -824,8 +801,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=wg, & para_env=tmc_env%tmc_comp_set%para_env_m_w,& tmc_params=tmc_env%params, & - elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem, & - error=error) + elem=gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem) nr_of_job(1) = nr_of_job(1) +1 CASE(status_cancel_nmc, status_cancel_ener) ! skip that task until receipt is received @@ -835,7 +811,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) routineP,"new task of tree element"//& cp_to_string(gt_elem_tmp%nr)//& "has unknown status"//cp_to_string(stat), & - error, failure=flag) + failure=flag) END SELECT worker_info(wg)%elem => gt_elem_tmp%conf(gt_elem_tmp%mv_conf)%elem worker_info(wg)%busy = .TRUE. @@ -857,18 +833,17 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) ", sub trees", tmc_env%m_env%result_count(1:) CALL print_move_types(init=.FALSE., file_io=tmc_env%m_env%io_unit, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) ALLOCATE(tree_elem_counters(0:SIZE(tmc_env%params%Temp))) ALLOCATE(tree_elem_heads(0:SIZE(tmc_env%params%Temp))) CALL count_nodes_in_trees(global_tree_ptr=tmc_env%m_env%gt_act, & end_of_clean_trees=tmc_env%m_env%st_clean_ends,& - counters=tree_elem_counters, head_elements_nr=tree_elem_heads, & - error=error) + counters=tree_elem_counters, head_elements_nr=tree_elem_heads) WRITE(tmc_env%m_env%io_unit,*) "nodes in trees", tree_elem_counters(:) WRITE(tmc_env%m_env%io_unit,*) "tree heads ", tree_elem_heads(:) IF(tmc_env%params%NMC_inp_file.NE."") THEN CALL count_prepared_nodes_in_trees(global_tree_ptr=tmc_env%m_env%gt_act, & - counters=tree_elem_counters, error=error) + counters=tree_elem_counters) WRITE(tmc_env%m_env%io_unit,FMT=*)& "ener prepared ", tree_elem_counters END IF @@ -909,7 +884,7 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) tmc_env%m_env%result_count(0).GT.& restart_count*tmc_env%m_env%restart_out_step) THEN CALL print_restart_file(tmc_env=tmc_env, job_counts=nr_of_job, & - timings=worker_timings_aver, error=error) + timings=worker_timings_aver) restart_count = restart_count +1 END IF @@ -922,11 +897,11 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) "finalizing TMC","=" WRITE(tmc_env%m_env%io_unit,*) "acceptance rates:" CALL print_move_types(init=.FALSE., file_io=tmc_env%m_env%io_unit, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) WRITE(tmc_env%m_env%io_unit,FMT="(/,T2,A)") REPEAT("-",79) ! program efficency result outputs ALLOCATE(efficiency(0:tmc_env%params%nr_temp)) - CALL get_subtree_efficiency(tmc_env=tmc_env, eff=efficiency, error=error) + CALL get_subtree_efficiency(tmc_env=tmc_env, eff=efficiency) WRITE(tmc_env%m_env%io_unit,*) "Efficiencies:" WRITE(tmc_env%m_env%io_unit,FMT="(A,F5.2,A,1000F5.2)")& " (MC elements/calculated configuration) global:", & @@ -959,21 +934,21 @@ SUBROUTINE do_tmc_master(tmc_env, globenv, error) WRITE(tmc_env%m_env%io_unit,*) "stopping workers" CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_m_w, & worker_info=worker_info, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) DEALLOCATE(worker_info) CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_m_ana, & worker_info=ana_worker_info, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) DEALLOCATE(ana_worker_info) !-- deallocating everything in tree module - CALL finalize_trees(tmc_env=tmc_env, error=error) + CALL finalize_trees(tmc_env=tmc_env) - CALL free_cancelation_list(tmc_env%m_env%cancelation_list, error) + CALL free_cancelation_list(tmc_env%m_env%cancelation_list) ! -- write final configuration IF(tmc_env%params%DRAW_TREE) & - CALL finalize_draw_tree(tmc_params=tmc_env%params, error=error) + CALL finalize_draw_tree(tmc_params=tmc_env%params) WRITE(tmc_env%m_env%io_unit,*) "TMC master: all work done." @@ -987,14 +962,11 @@ END SUBROUTINE do_tmc_master !> hence the program can stop with a proper finailze !> \param time actual calculation time !> \param walltime_delay the actual biggest calculation time -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE set_walltime_delay(time, walltime_delay, error) + SUBROUTINE set_walltime_delay(time, walltime_delay) REAL(KIND=dp) :: time INTEGER :: walltime_delay - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_walltime_delay', & routineP = moduleN//':'//routineN @@ -1002,7 +974,7 @@ SUBROUTINE set_walltime_delay(time, walltime_delay, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(time.GE.0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(time.GE.0.0_dp,cp_failure_level,routineP,failure) IF(time.GT.walltime_delay)THEN walltime_delay = INT(time)+1 diff --git a/src/tmc/tmc_messages.F b/src/tmc/tmc_messages.F index de3ef0475d..15ac239384 100644 --- a/src/tmc/tmc_messages.F +++ b/src/tmc/tmc_messages.F @@ -82,14 +82,11 @@ MODULE tmc_messages ! ***************************************************************************** !> \brief checks if the core is the group master !> \param para_env defines the mpi communicator -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval master return value, logical !> \author Mandes 01.2013 ! ***************************************************************************** - FUNCTION check_if_group_master(para_env, error) RESULT(master) + FUNCTION check_if_group_master(para_env) RESULT(master) TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: master CHARACTER(LEN=*), PARAMETER :: routineN = 'check_if_group_master', & @@ -98,7 +95,7 @@ FUNCTION check_if_group_master(para_env, error) RESULT(master) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error, failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) master = .FALSE. IF(para_env%mepos.EQ.MASTER_COMM_ID) & @@ -121,13 +118,11 @@ END FUNCTION check_if_group_master !> \param result_count ... !> \param wait_for_message ... !> \param success ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & elem, elem_array, list_elem, result_count, & - wait_for_message, success, error) + wait_for_message, success) INTEGER :: msg_type LOGICAL :: send_recv INTEGER :: dest @@ -139,7 +134,6 @@ SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & TYPE(elem_list_type), OPTIONAL, POINTER :: list_elem INTEGER, DIMENSION(:), OPTIONAL, POINTER :: result_count LOGICAL, OPTIONAL :: wait_for_message, success - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_message', & routineP = moduleN//':'//routineN @@ -148,8 +142,8 @@ SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & LOGICAL :: act_send_recv, failure, flag TYPE(message_send), POINTER :: m_send - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ALLOCATE(m_send) @@ -187,29 +181,29 @@ SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & TMC_CANCELING_RECEIPT, TMC_STATUS_STOP_RECEIPT, & TMC_STATUS_WAIT_FOR_NEW_TASK, TMC_STATUS_CALCULATING, & TMC_STAT_ANALYSIS_RESULT) - CALL create_status_message(m_send, error) + CALL create_status_message(m_send) CASE(TMC_STATUS_WORKER_INIT) - CALL create_worker_init_message(tmc_params, m_send, error) + CALL create_worker_init_message(tmc_params, m_send) CASE(TMC_STAT_START_CONF_RESULT, TMC_STAT_INIT_ANALYSIS) - CALL create_start_conf_message(msg_type, elem, result_count, tmc_params, m_send, error) + CALL create_start_conf_message(msg_type, elem, result_count, tmc_params, m_send) CASE(TMC_STAT_ENERGY_REQUEST, TMC_STAT_APPROX_ENERGY_REQUEST) - CALL create_energy_request_message(elem, m_send, tmc_params, error) + CALL create_energy_request_message(elem, m_send, tmc_params) CASE(TMC_STAT_APPROX_ENERGY_RESULT) - CALL create_approx_energy_result_message(elem, m_send, tmc_params, error) + CALL create_approx_energy_result_message(elem, m_send, tmc_params) CASE(TMC_STAT_ENERGY_RESULT) - CALL create_energy_result_message(elem, m_send, tmc_params, error) + CALL create_energy_result_message(elem, m_send, tmc_params) CASE(TMC_STAT_NMC_REQUEST, TMC_STAT_NMC_BROADCAST, & TMC_STAT_MD_REQUEST, TMC_STAT_MD_BROADCAST) - CALL create_NMC_request_massage(msg_type, elem, m_send, tmc_params, error) + CALL create_NMC_request_massage(msg_type, elem, m_send, tmc_params) CASE(TMC_STAT_MD_RESULT, TMC_STAT_NMC_RESULT) - CALL create_NMC_result_massage(msg_type, elem, m_send, tmc_params, error) + CALL create_NMC_result_massage(msg_type, elem, m_send, tmc_params) CASE(TMC_STAT_ANALYSIS_REQUEST) - CPPrecondition(PRESENT(list_elem),cp_failure_level,routineP,error,failure) - CALL create_analysis_request_message(list_elem, m_send, tmc_params, error) + CPPrecondition(PRESENT(list_elem),cp_failure_level,routineP,failure) + CALL create_analysis_request_message(list_elem, m_send, tmc_params) CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "try to send unknown message type "//cp_to_string(msg_type),& - error, failure=flag) + failure=flag) END SELECT !set message info message_tag = msg_type @@ -230,7 +224,7 @@ SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & CALL mp_send(m_send%task_real, dest, message_tag, para_env%group) END IF IF(m_send%info(4).GT.0) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !TODO send characters CALL mp_send(m_send%task_char, dest, message_tag, para_env%group) END IF IF(DEBUG.GE.1) & @@ -260,7 +254,7 @@ SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & END IF IF(m_send%info(4).GT.0) THEN IF(.NOT.act_send_recv) ALLOCATE(m_send%task_char(m_send%info(3))) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !TODO bcast char CALL mp_bcast(m_send%task_char, MASTER_COMM_ID, para_env%group) END IF END IF @@ -329,7 +323,7 @@ SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & !-- receive message character part IF(m_send%info(4).GT.0) THEN ALLOCATE(m_send%task_char(m_send%info(4))) - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) !TODO recv characters CALL mp_recv(m_send%task_char, dest, message_tag, para_env%group) END IF END IF @@ -358,39 +352,39 @@ SUBROUTINE tmc_message(msg_type, send_recv, dest, para_env, tmc_params, & TMC_STATUS_CALCULATING, TMC_STAT_ANALYSIS_RESULT) ! nothing to do here CASE(TMC_STATUS_WORKER_INIT) - CALL read_worker_init_message(tmc_params, m_send, error) + CALL read_worker_init_message(tmc_params, m_send) CASE(TMC_STAT_START_CONF_RESULT, TMC_STAT_INIT_ANALYSIS) IF(PRESENT(elem_array)) THEN CALL read_start_conf_message(msg_type, elem_array(dest)%elem, & - result_count, m_send, tmc_params, error) + result_count, m_send, tmc_params) ELSE CALL read_start_conf_message(msg_type, elem, result_count, m_send, & - tmc_params, error) + tmc_params) END IF CASE(TMC_STAT_APPROX_ENERGY_RESULT) - CALL read_approx_energy_result(elem_array(dest)%elem, m_send, tmc_params, error) + CALL read_approx_energy_result(elem_array(dest)%elem, m_send, tmc_params) CASE(TMC_STAT_ENERGY_REQUEST, TMC_STAT_APPROX_ENERGY_REQUEST) - CALL read_energy_request_message(elem, m_send, tmc_params, error) + CALL read_energy_request_message(elem, m_send, tmc_params) CASE(TMC_STAT_ENERGY_RESULT) IF(PRESENT(elem_array)) & - CALL read_energy_result_message(elem_array(dest)%elem, m_send, tmc_params, error) + CALL read_energy_result_message(elem_array(dest)%elem, m_send, tmc_params) CASE(TMC_STAT_NMC_REQUEST, TMC_STAT_NMC_BROADCAST, & TMC_STAT_MD_REQUEST, TMC_STAT_MD_BROADCAST) - CALL read_NMC_request_massage(msg_type, elem, m_send, tmc_params, error) + CALL read_NMC_request_massage(msg_type, elem, m_send, tmc_params) CASE(TMC_STAT_NMC_RESULT, TMC_STAT_MD_RESULT) IF(PRESENT(elem_array)) & - CALL read_NMC_result_massage(msg_type, elem_array(dest)%elem, m_send, tmc_params, error) + CALL read_NMC_result_massage(msg_type, elem_array(dest)%elem, m_send, tmc_params) CASE(TMC_STATUS_FAILED, TMC_STATUS_STOP_RECEIPT) ! if task is failed, handle situation in outer routine CASE(TMC_STAT_SCF_STEP_ENER_RECEIVE) - CALL read_scf_step_ener(elem_array(dest)%elem, m_send, error) + CALL read_scf_step_ener(elem_array(dest)%elem, m_send) CASE(TMC_STAT_ANALYSIS_REQUEST) - CALL read_analysis_request_message(elem, m_send, tmc_params, error) + CALL read_analysis_request_message(elem, m_send, tmc_params) CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "try to receive unknown message type "//cp_to_string(msg_type)//& "from source "//cp_to_string(dest),& - error, failure=flag) + failure=flag) END SELECT IF(m_send%info(2).GT.0) DEALLOCATE(m_send%task_int) IF(m_send%info(3).GT.0) DEALLOCATE(m_send%task_real) @@ -405,14 +399,11 @@ END SUBROUTINE tmc_message ! ***************************************************************************** !> \brief set the messege just with an status tag !> \param m_send the message structure -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_status_message(m_send, error) + SUBROUTINE create_status_message(m_send) TYPE(message_send), POINTER :: m_send - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_status_message', & routineP = moduleN//':'//routineN @@ -420,12 +411,12 @@ SUBROUTINE create_status_message(m_send, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) ! nothing to do, send just the message tag - CPPostconditionNoFail(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error) - CPPostconditionNoFail(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error) + CPPostconditionNoFail(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP) + CPPostconditionNoFail(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP) END SUBROUTINE create_status_message @@ -443,10 +434,9 @@ END SUBROUTINE create_status_message !!> see module cp_error_handling !!> \author Mandes 02.2013 !! ***************************************************************************** -! SUBROUTINE create_atom_mass_message(m_send, atoms,error) +! SUBROUTINE create_atom_mass_message(m_send, atoms) ! TYPE(tmc_atom_type), DIMENSION(:), POINTER :: atoms ! TYPE(message_send), POINTER :: m_send -! TYPE(cp_error_type), INTENT(inout) :: error ! ! CHARACTER(LEN=*), PARAMETER :: routineN = 'create_atom_mass_message', & ! routineP = moduleN//':'//routineN @@ -457,10 +447,10 @@ END SUBROUTINE create_status_message ! ! failure = .FALSE. ! -! CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) -! CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) -! CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) -! CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,error,failure) +! CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) +! CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) +! CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) +! CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,failure) ! ! counter =1 ! msg_size_real = 1+SIZE(tmc_params%cell%hmat)+ 1+SIZE(atoms) +1 @@ -472,7 +462,7 @@ END SUBROUTINE create_status_message ! END DO ! counter = counter + 1+INT(m_send%task_real(counter)) ! m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end -! CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) +! CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) ! END SUBROUTINE create_atom_mass_message ! !! ***************************************************************************** @@ -486,11 +476,10 @@ END SUBROUTINE create_status_message !!> see module cp_error_handling !!> \author Mandes 02.2013 !! ***************************************************************************** -! SUBROUTINE read_atom_mass_message(m_send, atoms,error) +! SUBROUTINE read_atom_mass_message(m_send, atoms) ! TYPE(tmc_atom_type), DIMENSION(:), & ! POINTER :: atoms ! TYPE(message_send), POINTER :: m_send -! TYPE(cp_error_type), INTENT(inout) :: error ! ! CHARACTER(LEN=*), PARAMETER :: routineN = 'read_atom_mass_message', & ! routineP = moduleN//':'//routineN @@ -500,33 +489,30 @@ END SUBROUTINE create_status_message ! ! failure = .FALSE. ! -! CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) -! CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) -! CPPrecondition(ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) -! CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,error,failure) +! CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) +! CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) +! CPPrecondition(ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) +! CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,failure) ! ! counter =1 ! nr_atoms = m_send%task_real(counter) -! IF(.NOT.ASSOCIATED(atoms)) CALL allocate_tmc_atom_type(atoms, nr_atoms, error) +! IF(.NOT.ASSOCIATED(atoms)) CALL allocate_tmc_atom_type(atoms, nr_atoms) ! DO i=1, SIZE(atoms) ! atoms(i)%mass = m_send%task_real(counter+i) ! END DO ! counter = counter + 1+INT(m_send%task_real(counter)) -! CPPostconditionNoFail(INT(m_send%task_real(counter)).EQ.message_end_flag,cp_failure_level,routineP,error) +! CPPostconditionNoFail(INT(m_send%task_real(counter)).EQ.message_end_flag,cp_failure_level,routineP) ! END SUBROUTINE read_atom_mass_message ! ***************************************************************************** !> \brief the message for the initial values (cell size) to the workers !> \param tmc_params to send the cell properties !> \param m_send the message structure -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 07.2013 ! ***************************************************************************** - SUBROUTINE create_worker_init_message(tmc_params, m_send, error) + SUBROUTINE create_worker_init_message(tmc_params, m_send) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(message_send), POINTER :: m_send - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_worker_init_message', & routineP = moduleN//':'//routineN @@ -537,12 +523,12 @@ SUBROUTINE create_worker_init_message(tmc_params, m_send, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params%cell),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params%cell),cp_failure_level,routineP,failure) counter = 1 msg_size_int = 1+SIZE(tmc_params%cell%perd) +1+1 +1 +1 @@ -556,7 +542,7 @@ SUBROUTINE create_worker_init_message(tmc_params, m_send, error) IF(tmc_params%cell%orthorhombic) m_send%task_int(counter+2) = 1 counter = counter +3 m_send%task_int(counter) = message_end_flag - CPPostconditionNoFail(counter.EQ.SIZE(m_send%task_int),cp_failure_level,routineP,error) + CPPostconditionNoFail(counter.EQ.SIZE(m_send%task_int),cp_failure_level,routineP) !float array with cell vectors msg_size_real = 1+SIZE(tmc_params%cell%hmat) +1 @@ -568,22 +554,19 @@ SUBROUTINE create_worker_init_message(tmc_params, m_send, error) (/SIZE(tmc_params%cell%hmat)/)) counter = counter + 1+INT(m_send%task_real(counter)) m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_worker_init_message ! ***************************************************************************** !> \brief the message for the initial values (cell size) to the workers !> \param tmc_params to send the cell properties !> \param m_send the message structure -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 07.2013 ! ***************************************************************************** - SUBROUTINE read_worker_init_message(tmc_params, m_send, error) + SUBROUTINE read_worker_init_message(tmc_params, m_send) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(message_send), POINTER :: m_send - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_worker_init_message', & routineP = moduleN//':'//routineN @@ -592,35 +575,35 @@ SUBROUTINE read_worker_init_message(tmc_params, m_send, error) LOGICAL :: failure, flag failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(3).GE.4,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(3).GE.4,cp_failure_level,routineP,failure) IF(.NOT.ASSOCIATED(tmc_params%cell)) ALLOCATE(tmc_params%cell) counter = 1 !int array flag = INT(m_send%task_int(1)) .EQ.SIZE(tmc_params%cell%perd) - CPPrecondition(flag,cp_failure_level,routineP,error,failure) + CPPrecondition(flag,cp_failure_level,routineP,failure) counter = 1+ m_send%task_int(1)+1 tmc_params%cell%perd = m_send%task_int(2:counter-1) tmc_params%cell%symmetry_id = m_send%task_int(counter+1) tmc_params%cell%orthorhombic = .FALSE. IF(m_send%task_int(counter+2).EQ.1) tmc_params%cell%orthorhombic = .TRUE. counter = counter +3 - CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,error, failure) - CPPostcondition(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP,error, failure) + CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,failure) + CPPostcondition(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP,failure) !float array with cell vectors counter = 1 flag = INT(m_send%task_real(counter)).EQ.SIZE(tmc_params%cell%hmat) - CPPrecondition(flag,cp_failure_level,routineP,error,failure) + CPPrecondition(flag,cp_failure_level,routineP,failure) tmc_params%cell%hmat = & RESHAPE(m_send%task_real(counter+1:counter+& SIZE(tmc_params%cell%hmat)),(/3,3/) ) counter = counter + 1+INT(m_send%task_real(counter)) - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_worker_init_message @@ -632,18 +615,15 @@ END SUBROUTINE read_worker_init_message !> \param result_count ... !> \param tmc_params to send the cell properties !> \param m_send the message structure -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE create_start_conf_message(msg_type, elem, result_count, & - tmc_params, m_send, error) + tmc_params, m_send) INTEGER :: msg_type TYPE(tree_type), POINTER :: elem INTEGER, DIMENSION(:), OPTIONAL, POINTER :: result_count TYPE(tmc_param_type), POINTER :: tmc_params TYPE(message_send), POINTER :: m_send - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_start_conf_message', & routineP = moduleN//':'//routineN @@ -653,19 +633,19 @@ SUBROUTINE create_start_conf_message(msg_type, elem, result_count, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_char),cp_failure_level,routineP,failure) counter = 1 msg_size_int = 1+SIZE(tmc_params%cell%perd) +1+1 +1 +1+SIZE(elem%mol) +1 IF(msg_type.EQ.TMC_STAT_INIT_ANALYSIS) THEN - CPPrecondition(PRESENT(result_count),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(result_count),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(result_count),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(result_count),cp_failure_level,routineP,failure) msg_size_int = msg_size_int + 1+ SIZE(result_count(1:)) END IF ALLOCATE(m_send%task_int(msg_size_int)) @@ -687,7 +667,7 @@ SUBROUTINE create_start_conf_message(msg_type, elem, result_count, & counter = counter +1+m_send%task_int(counter) END IF m_send%task_int(counter) = message_end_flag - CPPostconditionNoFail(counter.EQ.SIZE(m_send%task_int),cp_failure_level,routineP,error) + CPPostconditionNoFail(counter.EQ.SIZE(m_send%task_int),cp_failure_level,routineP) counter = 0 !float array with pos, cell vectors, atom_mass @@ -708,8 +688,8 @@ SUBROUTINE create_start_conf_message(msg_type, elem, result_count, & END DO counter = counter + 1+INT(m_send%task_real(counter)) m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_start_conf_message @@ -721,18 +701,15 @@ END SUBROUTINE create_start_conf_message !> \param result_count ... !> \param m_send the message structure !> \param tmc_params the param struct with necessary values for allocation -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE read_start_conf_message(msg_type, elem, result_count, m_send, & - tmc_params, error) + tmc_params) INTEGER :: msg_type TYPE(tree_type), POINTER :: elem INTEGER, DIMENSION(:), OPTIONAL, POINTER :: result_count TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_start_conf_message', & routineP = moduleN//':'//routineN @@ -741,19 +718,19 @@ SUBROUTINE read_start_conf_message(msg_type, elem, result_count, m_send, & LOGICAL :: failure, flag failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(3).GE.4,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(3).GE.4,cp_failure_level,routineP,failure) IF(.NOT.ASSOCIATED(tmc_params%cell)) ALLOCATE(tmc_params%cell) CALL allocate_new_sub_tree_node(tmc_params=tmc_params, next_el=elem, & - nr_dim=NINT(m_send%task_real(1)), error=error) + nr_dim=NINT(m_send%task_real(1))) counter = 1 !int array flag = INT(m_send%task_int(1)) .EQ.SIZE(tmc_params%cell%perd) - CPPrecondition(flag,cp_failure_level,routineP,error,failure) + CPPrecondition(flag,cp_failure_level,routineP,failure) counter = 1+ m_send%task_int(1)+1 tmc_params%cell%perd = m_send%task_int(2:counter-1) tmc_params%cell%symmetry_id = m_send%task_int(counter+1) @@ -763,36 +740,35 @@ SUBROUTINE read_start_conf_message(msg_type, elem, result_count, m_send, & elem%mol(:) = m_send%task_int(counter+1:counter+m_send%task_int(counter)) counter = counter +1+m_send%task_int(counter) IF(msg_type.EQ.TMC_STAT_INIT_ANALYSIS) THEN - CPPrecondition(PRESENT(result_count),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(result_count),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(result_count),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(result_count),cp_failure_level,routineP,failure) ALLOCATE(result_count(m_send%task_int(counter))) result_count(:) = m_send%task_int(counter+1:counter+m_send%task_int(counter)) counter = counter +1+m_send%task_int(counter) END IF - CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,error, failure) - CPPostcondition(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP,error, failure) + CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,failure) + CPPostcondition(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP,failure) counter = 0 !float array with pos, cell vectors, atom_mass counter = 2 + INT(m_send%task_real(1)) elem%pos = m_send%task_real(2:counter-1) flag = INT(m_send%task_real(counter)).EQ.SIZE(tmc_params%cell%hmat) - CPPrecondition(flag,cp_failure_level,routineP,error,failure) + CPPrecondition(flag,cp_failure_level,routineP,failure) tmc_params%cell%hmat = & RESHAPE(m_send%task_real(counter+1:counter+& SIZE(tmc_params%cell%hmat)),(/3,3/) ) counter = counter + 1+INT(m_send%task_real(counter)) CALL allocate_tmc_atom_type(atoms=tmc_params%atoms, & - nr_atoms=INT(m_send%task_real(counter)), & - error=error) + nr_atoms=INT(m_send%task_real(counter))) DO i=1, SIZE(tmc_params%atoms) tmc_params%atoms(i)%mass = m_send%task_real(counter+i) END DO counter = counter + 1+INT(m_send%task_real(counter)) - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_start_conf_message @@ -804,16 +780,13 @@ END SUBROUTINE read_start_conf_message !> \param elem tree element with new coordinates !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE create_energy_request_message(elem, m_send, & - tmc_params, error) + tmc_params) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'create_energy_request_message', & @@ -824,11 +797,11 @@ SUBROUTINE create_energy_request_message(elem, m_send, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) counter = 0 !first integer array @@ -842,8 +815,8 @@ SUBROUTINE create_energy_request_message(elem, m_send, & m_send%task_int(counter+1:counter+m_send%task_int(counter)) = elem%nr counter = counter + 1+m_send%task_int(counter) m_send%task_int(counter) = message_end_flag - CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP,error) - CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP) + CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP) !then float array with pos msg_size_real = 1+SIZE(elem%pos) +1 @@ -859,8 +832,8 @@ SUBROUTINE create_energy_request_message(elem, m_send, & END IF m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_energy_request_message ! ***************************************************************************** @@ -868,15 +841,12 @@ END SUBROUTINE create_energy_request_message !> \param elem tree element with new coordinates !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE read_energy_request_message(elem, m_send, tmc_params, error) + SUBROUTINE read_energy_request_message(elem, m_send, tmc_params) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_energy_request_message', & routineP = moduleN//':'//routineN @@ -885,24 +855,24 @@ SUBROUTINE read_energy_request_message(elem, m_send, tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(3).GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(3).GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,failure) ! initialize the new sub tree element IF(.NOT.ASSOCIATED(elem))THEN CALL allocate_new_sub_tree_node(next_el=elem, nr_dim=NINT(m_send%task_real(1)),& - tmc_params=tmc_params, error=error) + tmc_params=tmc_params) END IF ! read the integer values - CPPrecondition(m_send%info(2).GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(m_send%info(2).GT.0,cp_failure_level,routineP,failure) counter = 1 elem%sub_tree_nr = m_send%task_int(counter+1) counter = counter + 1+m_send%task_int(counter) elem%nr = m_send%task_int(counter+1) counter = counter + 1+m_send%task_int(counter) - CPPostconditionNoFail(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP) !float array with pos counter = 0 @@ -914,8 +884,8 @@ SUBROUTINE read_energy_request_message(elem, m_send, tmc_params, error) counter = counter +1+INT(m_send%task_real(counter)) END IF - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_energy_request_message ! ***************************************************************************** @@ -923,15 +893,12 @@ END SUBROUTINE read_energy_request_message !> \param elem tree element with calculated energy !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_energy_result_message(elem, m_send, tmc_params, error) + SUBROUTINE create_energy_result_message(elem, m_send, tmc_params) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_energy_result_message', & routineP = moduleN//':'//routineN @@ -941,11 +908,11 @@ SUBROUTINE create_energy_result_message(elem, m_send, tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) counter = 0 !first integer array @@ -986,8 +953,8 @@ SUBROUTINE create_energy_result_message(elem, m_send, tmc_params, error) m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_energy_result_message ! ***************************************************************************** @@ -995,15 +962,12 @@ END SUBROUTINE create_energy_result_message !> \param elem tree element for storing new energy !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE read_energy_result_message(elem, m_send, tmc_params, error) + SUBROUTINE read_energy_result_message(elem, m_send, tmc_params) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_energy_result_message', & routineP = moduleN//':'//routineN @@ -1012,10 +976,10 @@ SUBROUTINE read_energy_result_message(elem, m_send, tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(3).GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(3).GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! read the integer values ! for checking the tree element mapping, check the tree numbers @@ -1029,7 +993,7 @@ SUBROUTINE read_energy_result_message(elem, m_send, tmc_params, error) STOP "read_energy_result: got energy result from unexpected tree element." END IF ELSE - CPPrecondition(m_send%info(2).EQ.0,cp_failure_level,routineP,error,failure) + CPPrecondition(m_send%info(2).EQ.0,cp_failure_level,routineP,failure) END IF !then float array with energy of exact potential @@ -1044,8 +1008,8 @@ SUBROUTINE read_energy_result_message(elem, m_send, tmc_params, error) counter = counter + 1+NINT(m_send%task_real(counter)) END IF - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_energy_result_message ! ***************************************************************************** @@ -1053,16 +1017,13 @@ END SUBROUTINE read_energy_result_message !> \param elem tree element with calculated approx energy !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE create_approx_energy_result_message(elem, m_send, & - tmc_params, error) + tmc_params) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'create_approx_energy_result_message', & @@ -1072,11 +1033,11 @@ SUBROUTINE create_approx_energy_result_message(elem, m_send, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) counter = 0 @@ -1096,8 +1057,8 @@ SUBROUTINE create_approx_energy_result_message(elem, m_send, & END IF m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_approx_energy_result_message ! ***************************************************************************** @@ -1105,15 +1066,12 @@ END SUBROUTINE create_approx_energy_result_message !> \param elem tree element for storing new energy !> \param m_send the message structure !> \param tmc_params the param struct with necessary parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE read_approx_energy_result(elem, m_send, tmc_params, error) + SUBROUTINE read_approx_energy_result(elem, m_send, tmc_params) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_approx_energy_result', & routineP = moduleN//':'//routineN @@ -1122,10 +1080,10 @@ SUBROUTINE read_approx_energy_result(elem, m_send, tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(2).EQ.0.AND.m_send%info(3).GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(2).EQ.0.AND.m_send%info(3).GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) !then float array with energy of exact potential elem%e_pot_approx = m_send%task_real(2) @@ -1135,8 +1093,8 @@ SUBROUTINE read_approx_energy_result(elem, m_send, tmc_params, error) counter = counter +1+INT(m_send%task_real(counter)) END IF - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_approx_energy_result !============================================================================ @@ -1148,17 +1106,14 @@ END SUBROUTINE read_approx_energy_result !> \param elem tree element with calculated energy !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE create_NMC_request_massage(msg_type, elem, m_send, & - tmc_params, error) + tmc_params) INTEGER :: msg_type TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_NMC_request_massage', & routineP = moduleN//':'//routineN @@ -1168,11 +1123,11 @@ SUBROUTINE create_NMC_request_massage(msg_type, elem, m_send, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) counter = 0 !first integer array with element status,mol_info, move type, sub tree, element nr, temp index @@ -1232,10 +1187,10 @@ SUBROUTINE create_NMC_request_massage(msg_type, elem, m_send, & END IF m_send%task_real(counter) = message_end_flag !message end - CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP,error) - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_NMC_request_massage ! ***************************************************************************** @@ -1244,17 +1199,14 @@ END SUBROUTINE create_NMC_request_massage !> \param elem tree element with new coordinates !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE read_NMC_request_massage(msg_type, elem, m_send, & - tmc_params, error) + tmc_params) INTEGER :: msg_type TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_NMC_request_massage', & routineP = moduleN//':'//routineN @@ -1264,10 +1216,10 @@ SUBROUTINE read_NMC_request_massage(msg_type, elem, m_send, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(2).GT.5.AND.m_send%info(3).GT.8,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(2).GT.5.AND.m_send%info(3).GT.8,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) counter = 0 !first integer array with number of dimentions and random seed size @@ -1275,7 +1227,7 @@ SUBROUTINE read_NMC_request_massage(msg_type, elem, m_send, & IF(.NOT.ASSOCIATED(elem))THEN CALL allocate_new_sub_tree_node(next_el=elem, nr_dim=NINT(m_send%task_real(1)), & - tmc_params=tmc_params, error=error) + tmc_params=tmc_params) END IF ! element status counter = 2 + m_send%task_int(1) @@ -1291,7 +1243,7 @@ SUBROUTINE read_NMC_request_massage(msg_type, elem, m_send, & counter = counter +2 elem%temp_created = m_send%task_int(counter+1) counter = counter +2 - CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,error, failure) + CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,failure) counter = 0 !then float array with pos, (vel), subbox_center and temp @@ -1316,9 +1268,9 @@ SUBROUTINE read_NMC_request_massage(msg_type, elem, m_send, & elem%box_scale(:) = 1.0_dp END IF - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(m_send%task_int(m_send%info(2)).EQ.message_end_flag,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(m_send%task_int(m_send%info(2)).EQ.message_end_flag,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_NMC_request_massage !============================================================================ @@ -1330,17 +1282,13 @@ END SUBROUTINE read_NMC_request_massage !> \param elem tree element with calculated energy !> \param m_send the message structure !> \param tmc_params environment with move types and sizes -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_NMC_result_massage(msg_type, elem, m_send, tmc_params,& - error) + SUBROUTINE create_NMC_result_massage(msg_type, elem, m_send, tmc_params) INTEGER :: msg_type TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_NMC_result_massage', & routineP = moduleN//':'//routineN @@ -1350,11 +1298,11 @@ SUBROUTINE create_NMC_result_massage(msg_type, elem, m_send, tmc_params,& LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) !first integer array with status, nmc_acc_counts, subbox_acc_count and (subbox rejectance) msg_size_int = 1+SIZE(elem%mol) & @@ -1454,10 +1402,10 @@ SUBROUTINE create_NMC_result_massage(msg_type, elem, m_send, tmc_params,& END IF m_send%task_real(counter) = message_end_flag ! message end - CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP,error) - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_NMC_result_massage ! ***************************************************************************** @@ -1466,17 +1414,13 @@ END SUBROUTINE create_NMC_result_massage !> \param elem tree element with calculated energy !> \param m_send the message structure !> \param tmc_params environment with move types and sizes -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE read_NMC_result_massage(msg_type, elem, m_send, tmc_params, & - error) + SUBROUTINE read_NMC_result_massage(msg_type, elem, m_send, tmc_params) INTEGER :: msg_type TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_NMC_result_massage', & routineP = moduleN//':'//routineN @@ -1490,10 +1434,10 @@ SUBROUTINE read_NMC_result_massage(msg_type, elem, m_send, tmc_params, & failure = .FALSE. NULLIFY(mv_counter, subbox_counter, acc_counter, subbox_acc_counter) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(2).GT.0.AND.m_send%info(3).GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(2).GT.0.AND.m_send%info(3).GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) !first integer array with element status, random number seed, and move type counter = 1 @@ -1534,7 +1478,7 @@ SUBROUTINE read_NMC_result_massage(msg_type, elem, m_send, tmc_params, & SIZE(tmc_params%nmc_move_types%subbox_acc_count(1,:))/)) counter = counter +1 +m_send%task_int(counter) END IF - CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,error, failure) + CPPostcondition(counter.EQ.m_send%info(2),cp_failure_level,routineP,failure) counter = 0 !then float array with pos, (vel, e_kin_befor_md, ekin), (forces), rng_seed, potential, e_pot_approx @@ -1564,18 +1508,18 @@ SUBROUTINE read_NMC_result_massage(msg_type, elem, m_send, tmc_params, & END IF CALL add_mv_prob(move_types=tmc_params%nmc_move_types, prob_opt=tmc_params%esimate_acc_prob, & - mv_counter=mv_counter,acc_counter=acc_counter, error=error) + mv_counter=mv_counter,acc_counter=acc_counter) IF(.NOT.ANY(tmc_params%sub_box_size.LE.0.1_dp)) THEN CALL add_mv_prob(move_types=tmc_params%nmc_move_types, prob_opt=tmc_params%esimate_acc_prob, & - subbox_counter=subbox_counter, subbox_acc_counter=subbox_acc_counter, error=error) + subbox_counter=subbox_counter, subbox_acc_counter=subbox_acc_counter) END IF DEALLOCATE(mv_counter, acc_counter) IF(.NOT.ANY(tmc_params%sub_box_size.LE.0.1_dp)) & DEALLOCATE(subbox_counter, subbox_acc_counter) - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(m_send%task_int(m_send%info(2)).EQ.message_end_flag,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(m_send%task_int(m_send%info(2)).EQ.message_end_flag,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_NMC_result_massage !============================================================================ @@ -1588,16 +1532,13 @@ END SUBROUTINE read_NMC_result_massage !> \param list_elem ... !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE create_analysis_request_message(list_elem, m_send, & - tmc_params, error) + tmc_params) TYPE(elem_list_type), POINTER :: list_elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'create_analysis_request_message', & @@ -1608,11 +1549,11 @@ SUBROUTINE create_analysis_request_message(list_elem, m_send, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(list_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_int),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ALLOCATED(m_send%task_real),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(list_elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) counter = 0 !first integer array @@ -1626,8 +1567,8 @@ SUBROUTINE create_analysis_request_message(list_elem, m_send, & m_send%task_int(counter+1:counter+m_send%task_int(counter)) = list_elem%nr counter = counter + 1+m_send%task_int(counter) m_send%task_int(counter) = message_end_flag - CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP,error) - CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_int).EQ.msg_size_int,cp_failure_level,routineP) + CPPostconditionNoFail(m_send%task_int(msg_size_int).EQ.message_end_flag,cp_failure_level,routineP) !then float array with pos msg_size_real = 1+SIZE(list_elem%elem%pos) +1 @@ -1643,8 +1584,8 @@ SUBROUTINE create_analysis_request_message(list_elem, m_send, & END IF m_send%task_real(counter) = REAL(message_end_flag, KIND=dp) !message end - CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP,error) - CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(SIZE(m_send%task_real).EQ.msg_size_real,cp_failure_level,routineP) + CPPostconditionNoFail(INT(m_send%task_real(msg_size_real)).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE create_analysis_request_message ! ***************************************************************************** @@ -1652,15 +1593,12 @@ END SUBROUTINE create_analysis_request_message !> \param elem tree element with new coordinates !> \param m_send the message structure !> \param tmc_params stuct with parameters (global settings) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE read_analysis_request_message(elem, m_send, tmc_params, error) + SUBROUTINE read_analysis_request_message(elem, m_send, tmc_params) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'read_analysis_request_message', & @@ -1670,24 +1608,24 @@ SUBROUTINE read_analysis_request_message(elem, m_send, tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) - CPPrecondition(m_send%info(3).GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) + CPPrecondition(m_send%info(3).GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,failure) ! initialize the new sub tree element IF(.NOT.ASSOCIATED(elem))THEN CALL allocate_new_sub_tree_node(next_el=elem, nr_dim=NINT(m_send%task_real(1)),& - tmc_params=tmc_params, error=error) + tmc_params=tmc_params) END IF ! read the integer values - CPPrecondition(m_send%info(2).GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(m_send%info(2).GT.0,cp_failure_level,routineP,failure) counter = 1 elem%sub_tree_nr = m_send%task_int(counter+1) counter = counter + 1+m_send%task_int(counter) elem%nr = m_send%task_int(counter+1) counter = counter + 1+m_send%task_int(counter) - CPPostconditionNoFail(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostconditionNoFail(m_send%task_int(counter).EQ.message_end_flag,cp_failure_level,routineP) !float array with pos counter = 0 @@ -1699,8 +1637,8 @@ SUBROUTINE read_analysis_request_message(elem, m_send, tmc_params, error) counter = counter +1+INT(m_send%task_real(counter)) END IF - CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,error, failure) - CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP,error) + CPPostcondition(counter.EQ.m_send%info(3),cp_failure_level,routineP,failure) + CPPostconditionNoFail(INT(m_send%task_real(m_send%info(3))).EQ.message_end_flag,cp_failure_level,routineP) END SUBROUTINE read_analysis_request_message !============================================================================ @@ -1710,14 +1648,11 @@ END SUBROUTINE read_analysis_request_message !> \brief routine cancel the other group participants !> \param elem tree element with approximated energy !> \param m_send the message structure -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE read_scf_step_ener(elem, m_send, error) + SUBROUTINE read_scf_step_ener(elem, m_send) TYPE(tree_type), POINTER :: elem TYPE(message_send), POINTER :: m_send - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_scf_step_ener', & routineP = moduleN//':'//routineN @@ -1725,8 +1660,8 @@ SUBROUTINE read_scf_step_ener(elem, m_send, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(m_send),cp_failure_level,routineP,failure) elem%scf_energies(MOD(elem%scf_energies_count,4)+1) = m_send%task_real(1) elem%scf_energies_count = elem%scf_energies_count +1 @@ -1743,16 +1678,13 @@ END SUBROUTINE read_scf_step_ener !> \param atoms ... !> \param source ... !> \param para_env the communicator environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE communicate_atom_types(atoms, source, para_env, error) + SUBROUTINE communicate_atom_types(atoms, source, para_env) TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms INTEGER :: source TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'communicate_atom_types', & routineP = moduleN//':'//routineN @@ -1762,9 +1694,9 @@ SUBROUTINE communicate_atom_types(atoms, source, para_env, error) INTEGER :: i LOGICAL :: failure - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(source.GE.0,cp_failure_level,routineP,error,failure) - CPPrecondition(source.LT.para_env%num_pe,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(source.GE.0,cp_failure_level,routineP,failure) + CPPrecondition(source.LT.para_env%num_pe,cp_failure_level,routineP,failure) ALLOCATE(msg(SIZE(atoms))) IF(para_env%mepos.EQ.source) THEN @@ -1789,18 +1721,15 @@ END SUBROUTINE communicate_atom_types !> \param para_env ... !> \param worker_info ... !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \param !> \author Mandes 01.2013 ! ***************************************************************************** - SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params, error) + SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params) TYPE(cp_para_env_type), POINTER :: para_env TYPE(elem_array_type), DIMENSION(:), & OPTIONAL, POINTER :: worker_info TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'stop_whole_group', & routineP = moduleN//':'//routineN @@ -1812,8 +1741,8 @@ SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params, error) ! INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status_single failure = .FALSE. - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ALLOCATE(rank_stoped(0:para_env%num_pe-1)) rank_stoped(:) = .FALSE. @@ -1821,7 +1750,7 @@ SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params, error) ! global master IF(PRESENT(worker_info)) THEN - CPPrecondition(ASSOCIATED(worker_info),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(worker_info),cp_failure_level,routineP,failure) ! canceling running jobs and stop workers worker_group_loop: DO dest_rank=1, para_env%num_pe-1 ! busy workers have to be canceled @@ -1829,23 +1758,20 @@ SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params, error) stat = TMC_CANCELING_MESSAGE act_rank = dest_rank CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=act_rank, & - para_env=para_env, tmc_params=tmc_params, & - error=error) + para_env=para_env, tmc_params=tmc_params) ELSE ! send stop message stat = TMC_STATUS_FAILED act_rank = dest_rank CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=act_rank, & - para_env=para_env, tmc_params=tmc_params, & - error=error) + para_env=para_env, tmc_params=tmc_params) END IF END DO worker_group_loop ELSE ! group master send stop message to all participants stat = TMC_STATUS_FAILED CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=bcast_group, & - para_env=para_env, tmc_params=tmc_params, & - error=error) + para_env=para_env, tmc_params=tmc_params) END IF ! receive stop message receipt @@ -1858,11 +1784,10 @@ SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params, error) ! mast have to be able to receive results, if canceling was too late CALL tmc_message(msg_type=stat, send_recv=recv_msg, dest=dest_rank,& para_env=para_env, tmc_params=tmc_params, & - elem_array=worker_info(:), success=flag, error=error) + elem_array=worker_info(:), success=flag) ELSE CALL tmc_message(msg_type=stat, send_recv=recv_msg, dest=dest_rank, & - para_env=para_env, tmc_params=tmc_params, & - error=error) + para_env=para_env, tmc_params=tmc_params) END IF SELECT CASE (stat) CASE(TMC_STATUS_WAIT_FOR_NEW_TASK) @@ -1873,8 +1798,7 @@ SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params, error) stat = TMC_STATUS_FAILED ! send stop message CALL tmc_message(msg_type=stat, send_recv=send_msg, dest=dest_rank,& - para_env=para_env, tmc_params=tmc_params, & - error=error) + para_env=para_env, tmc_params=tmc_params) ELSE STOP "group master should not receive cancel receipt" END IF @@ -1887,14 +1811,14 @@ SUBROUTINE stop_whole_group(para_env, worker_info, tmc_params, error) CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "master received status "//cp_to_string(stat)//& " while stopping workers",& - error, failure=flag) + failure=flag) END SELECT IF(ALL(rank_stoped)) EXIT wait_for_receipts END DO wait_for_receipts ELSE CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "only (group) master should stop other participants",& - error, failure=flag) + failure=flag) END IF END SUBROUTINE stop_whole_group diff --git a/src/tmc/tmc_move_handle.F b/src/tmc/tmc_move_handle.F index 559f040f59..2258e3668b 100644 --- a/src/tmc/tmc_move_handle.F +++ b/src/tmc/tmc_move_handle.F @@ -67,14 +67,11 @@ MODULE tmc_move_handle !> \brief initialization of the different moves, with sizes and probabilities !> \param tmc_params ... !> \param tmc_section ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 10.2013 ! ***************************************************************************** - SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) + SUBROUTINE read_init_move_types(tmc_params, tmc_section) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(section_vals_type), POINTER :: tmc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_init_move_types', & routineP = moduleN//':'//routineN @@ -103,53 +100,52 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) init_acc_prob = 0.0_dp ! the move types on exact potential - move_type_section => section_vals_get_subs_vals(tmc_section,"MOVE_TYPE",error=error) - CALL section_vals_get(move_type_section, explicit=explicit, error=error) + move_type_section => section_vals_get_subs_vals(tmc_section,"MOVE_TYPE") + CALL section_vals_get(move_type_section, explicit=explicit) IF(explicit) THEN - CALL section_vals_get(move_type_section,n_repetition=n_items,error=error) + CALL section_vals_get(move_type_section,n_repetition=n_items) mv_prob_sum = 0.0_dp DO i_rep = 1, n_items CALL section_vals_val_get(move_type_section,"PROB",i_rep_section=i_rep,& - r_val=mv_prob,error=error) + r_val=mv_prob) mv_prob_sum = mv_prob_sum + mv_prob END DO END IF ! get the NMC prameters - nmc_section => section_vals_get_subs_vals(tmc_section,"NMC_MOVES",error=error) - CALL section_vals_get(nmc_section, explicit=explicit, error=error) + nmc_section => section_vals_get_subs_vals(tmc_section,"NMC_MOVES") + CALL section_vals_get(nmc_section, explicit=explicit) IF(explicit) THEN ! check the approx potential file, already read CALL cp_assert(tmc_params%NMC_inp_file.NE."",& cp_failure_level,cp_assertion_failed,routineP,& "Please specify a valid approximate potential.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) CALL section_vals_val_get(nmc_section,"NR_NMC_STEPS",& - i_val=nmc_steps,error=error) + i_val=nmc_steps) CALL cp_assert(nmc_steps.GT.0,& cp_failure_level,cp_assertion_failed,routineP,& "Please specify a valid amount of NMC steps (NR_NMC_STEPS {INTEGER}).",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) - CALL section_vals_val_get(nmc_section,"PROB", r_val=nmc_prob,error=error) + CALL section_vals_val_get(nmc_section,"PROB", r_val=nmc_prob) CALL section_vals_val_get(move_type_section,"INIT_ACC_PROB",& - r_val=nmc_init_acc_prob,error=error) + r_val=nmc_init_acc_prob) CALL cp_assert(nmc_init_acc_prob.GT.0.0_dp,& cp_failure_level,cp_assertion_failed,routineP,& "Please select a valid initial acceptance probability (>0.0) "//& - "for INIT_ACC_PROB",& - error) + "for INIT_ACC_PROB") - move_type_section => section_vals_get_subs_vals(nmc_section,"MOVE_TYPE",error=error) - CALL section_vals_get(move_type_section,n_repetition=n_NMC_items,error=error) + move_type_section => section_vals_get_subs_vals(nmc_section,"MOVE_TYPE") + CALL section_vals_get(move_type_section,n_repetition=n_NMC_items) ! get the NMC move probability sum nmc_prob_sum = 0.0_dp DO i_rep = 1, n_NMC_items CALL section_vals_val_get(move_type_section,"PROB",i_rep_section=i_rep,& - r_val=mv_prob,error=error) + r_val=mv_prob) nmc_prob_sum = nmc_prob_sum + mv_prob END DO END IF @@ -160,12 +156,12 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) IF(n_items+n_NMC_items.GT.0) THEN ! initilaize the move array with related sizes, probs, etc. - CALL move_types_create(tmc_params%move_types, tmc_params%nr_temp, error) + CALL move_types_create(tmc_params%move_types, tmc_params%nr_temp) CALL cp_assert(mv_prob_sum.GT.0.0,& cp_failure_level,cp_assertion_failed,routineP,& "The probabilities to perform the moves are "//& - "in total less equal 0", error) + "in total less equal 0") ! get the sizes, probs, etc. for each move type and convert units @@ -180,40 +176,37 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) tmc_params%move_types%mv_size(mv_type_NMC_moves,:) = nmc_steps tmc_params%move_types%acc_prob(mv_type_NMC_moves,:) = nmc_init_acc_prob - move_type_section => section_vals_get_subs_vals(tmc_section,"NMC_MOVES%MOVE_TYPE",error=error) + move_type_section => section_vals_get_subs_vals(tmc_section,"NMC_MOVES%MOVE_TYPE") mv_prob_sum = nmc_prob_sum ! allocate the NMC move types - CALL move_types_create(tmc_params%nmc_move_types, tmc_params%nr_temp, error) + CALL move_types_create(tmc_params%nmc_move_types, tmc_params%nr_temp) move_types => tmc_params%nmc_move_types END IF ELSE ! the moves on exact potential - move_type_section => section_vals_get_subs_vals(tmc_section,"MOVE_TYPE",error=error) + move_type_section => section_vals_get_subs_vals(tmc_section,"MOVE_TYPE") i_rep = i_tmp move_types => tmc_params%move_types END IF CALL section_vals_val_get(move_type_section, "_SECTION_PARAMETERS_",& - c_val=inp_kind_name, i_rep_section=i_rep, & - error=error) + c_val=inp_kind_name, i_rep_section=i_rep) CALL uppercase(inp_kind_name) CALL section_vals_val_get(move_type_section,"SIZE",i_rep_section=i_rep,& - r_val=delta_x,error=error) + r_val=delta_x) ! move sizes are checked afterwards, because not all moves require a valid move size CALL section_vals_val_get(move_type_section,"PROB",i_rep_section=i_rep,& - r_val=mv_prob,error=error) + r_val=mv_prob) CALL cp_assert(mv_prob.GE.0.0_dp,& cp_failure_level,cp_assertion_failed,routineP,& "Please select a valid move probability (>0.0) "//& - "for the move type "//inp_kind_name,& - error) + "for the move type "//inp_kind_name) CALL section_vals_val_get(move_type_section,"INIT_ACC_PROB",i_rep_section=i_rep,& - r_val=init_acc_prob,error=error) + r_val=init_acc_prob) CALL cp_assert(init_acc_prob.GE.0.0_dp,& cp_failure_level,cp_assertion_failed,routineP,& "Please select a valid initial acceptance probability (>0.0) "//& - "for the move type "//inp_kind_name,& - error) + "for the move type "//inp_kind_name) ! set the related index and perform unit conversion of move sizes SELECT CASE(inp_kind_name) ! atom / molecule translation @@ -226,8 +219,7 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) CASE DEFAULT CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& - "move type is not defined in the translation types",& - error) + "move type is not defined in the translation types") END SELECT ! convert units SELECT CASE(tmc_params%task_type) @@ -238,8 +230,7 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) CASE DEFAULT CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& - "move type atom / mol trans is not defined for this TMC run type",& - error) + "move type atom / mol trans is not defined for this TMC run type") END SELECT ! molecule rotation CASE("MOL_ROT") @@ -251,8 +242,7 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) CASE DEFAULT CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& - "move type MOL_ROT is not defined for this TMC run type",& - error) + "move type MOL_ROT is not defined for this TMC run type") END SELECT ! proton reordering CASE("PROT_REORDER") @@ -275,8 +265,7 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& "Configurational swap disabled, because "//& - "Parallel Tempering requires more than one temperature.",& - error) + "Parallel Tempering requires more than one temperature.") END IF ! volume moves CASE("VOL_MOVE") @@ -289,8 +278,7 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& "no valid pressure defined, but volume move defined. "//& - "Consequently, the volume move is disabled.",& - error) + "Consequently, the volume move is disabled.") mv_prob = 0.0_dp END IF ! parallel tempering swap move @@ -300,18 +288,16 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) delta_x = 0.0_dp ! select the types of atoms swapped CALL section_vals_val_get(move_type_section,"ATOMS",i_rep_section=i_rep,& - n_rep_val=n_rep_val, error=error) + n_rep_val=n_rep_val) IF(n_rep_val.GT.0) THEN ALLOCATE(move_types%atom_lists(n_rep_val)) DO i= 1, n_rep_val CALL section_vals_val_get(move_type_section,"ATOMS",& i_rep_section=i_rep, i_rep_val=i, & - c_vals=move_types%atom_lists(i)%atoms, & - error=error) + c_vals=move_types%atom_lists(i)%atoms) CALL cp_assert(SIZE(move_types%atom_lists(i)%atoms).GT.1,& cp_failure_level,cp_assertion_failed,routineP,& - "ATOM_SWAP requires minimum two atom kinds selected. ",& - error) + "ATOM_SWAP requires minimum two atom kinds selected. ") END DO END IF ! gaussian adaptation @@ -321,21 +307,18 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) CASE DEFAULT CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& - "A unknown move type is selected: "//inp_kind_name,& - error) + "A unknown move type is selected: "//inp_kind_name) END SELECT ! check for valid move sizes CALL cp_assert(delta_x.GE.0.0_dp,& cp_failure_level,cp_assertion_failed,routineP,& "Please select a valid move size (>0.0) "//& - "for the move type "//inp_kind_name,& - error) + "for the move type "//inp_kind_name) ! check if not already set IF(move_types%mv_weight(ind).GT.0.0) THEN CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& - "TMC: Each move type can be set only once. ",& - error) + "TMC: Each move type can be set only once. ") END IF ! set the move size @@ -348,15 +331,14 @@ SUBROUTINE read_init_move_types(tmc_params, tmc_section, error) ELSE CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& - "No move type selected, please select at least one.", & - error) + "No move type selected, please select at least one.") END IF mv_prob_sum = SUM(tmc_params%move_types%mv_weight(:)) flag = .TRUE. - CPPostcondition(ABS(mv_prob_sum-1.0_dp).LT.0.01_dp,cp_failure_level,routineP,error,failure=flag) + CPPostcondition(ABS(mv_prob_sum-1.0_dp).LT.0.01_dp,cp_failure_level,routineP,failure=flag) IF(ASSOCIATED(tmc_params%nmc_move_types)) THEN mv_prob_sum = SUM(tmc_params%nmc_move_types%mv_weight(:)) - CPPostcondition(ABS(mv_prob_sum-1.0_dp)<10*EPSILON(1.0_dp),cp_failure_level,routineP,error,failure=flag) + CPPostcondition(ABS(mv_prob_sum-1.0_dp)<10*EPSILON(1.0_dp),cp_failure_level,routineP,failure=flag) END IF END SUBROUTINE read_init_move_types @@ -365,15 +347,12 @@ END SUBROUTINE read_init_move_types !> \param tmc_params ... !> \param move_types ... !> \param mol_array ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 10.2013 ! ***************************************************************************** - SUBROUTINE check_moves(tmc_params, move_types, mol_array, error) + SUBROUTINE check_moves(tmc_params, move_types, mol_array) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(tmc_move_type), POINTER :: move_types INTEGER, DIMENSION(:), POINTER :: mol_array - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_moves', & routineP = moduleN//':'//routineN @@ -381,8 +360,8 @@ SUBROUTINE check_moves(tmc_params, move_types, mol_array, error) INTEGER :: atom_j, list_i, ref_k LOGICAL :: found - CPPreconditionNoFail(ASSOCIATED(tmc_params),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(move_types),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(tmc_params),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(move_types),cp_failure_level,routineP) ! molecule moves need molecule info IF(move_types%mv_weight(mv_type_mol_trans).GT.0.0_dp .OR. & @@ -394,8 +373,7 @@ SUBROUTINE check_moves(tmc_params, move_types, mol_array, error) cp_failure_level,cp_assertion_failed,& routineP, "molecule move: there is no molecule "//& "information available. Please specify molecules when "//& - "using molecule moves.", & - error) + "using molecule moves.") END IF ! for the atom swap move @@ -416,15 +394,14 @@ SUBROUTINE check_moves(tmc_params, move_types, mol_array, error) CALL cp_assert(found, cp_failure_level,cp_assertion_failed,& routineP, "ATOM_SWAP: The selected atom type ("//& TRIM(move_types%atom_lists(list_i)%atoms(atom_j))//& - ") is not contained in the system. ",& - error) + ") is not contained in the system. ") ! check if not be swapped with the same atom type IF(ANY(move_types%atom_lists(list_i)%atoms(atom_j).EQ.& move_types%atom_lists(list_i)%atoms(atom_j+1:))) THEN CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP, "ATOM_SWAP can not swap two atoms of same kind ("//& TRIM(move_types%atom_lists(list_i)%atoms(atom_j))//& - ")", error) + ")") END IF END DO END DO @@ -441,7 +418,7 @@ SUBROUTINE check_moves(tmc_params, move_types, mol_array, error) END IF CALL cp_assert(found, cp_failure_level,cp_assertion_failed,& routineP, "The system contains only a single atom type,"//& - " atom_swap is not possible.", error) + " atom_swap is not possible.") END IF END IF END SUBROUTINE check_moves @@ -449,14 +426,11 @@ END SUBROUTINE check_moves ! ***************************************************************************** !> \brief deallocating the module variables !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 !> \note deallocating the module variables ! ***************************************************************************** - SUBROUTINE finalize_mv_types(tmc_params, error) + SUBROUTINE finalize_mv_types(tmc_params) TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'finalize_mv_types', & routineP = moduleN//':'//routineN @@ -464,10 +438,10 @@ SUBROUTINE finalize_mv_types(tmc_params, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CALL move_types_release(tmc_params%move_types, error) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CALL move_types_release(tmc_params%move_types) IF(ASSOCIATED(tmc_params%nmc_move_types)) & - CALL move_types_release(tmc_params%nmc_move_types, error) + CALL move_types_release(tmc_params%nmc_move_types) END SUBROUTINE finalize_mv_types ! ***************************************************************************** @@ -479,15 +453,12 @@ END SUBROUTINE finalize_mv_types !> \param init ... !> \param file_io ... !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE print_move_types(init, file_io, tmc_params, error) + SUBROUTINE print_move_types(init, file_io, tmc_params) LOGICAL :: init INTEGER :: file_io TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'print_move_types', & routineP = moduleN//':'//routineN @@ -511,8 +482,8 @@ SUBROUTINE print_move_types(init, file_io, tmc_params, error) subbox_out = .FALSE. type_title = .FALSE. failure = .FALSE. - CPPrecondition(file_io.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params%move_types),cp_failure_level,routineP,error,failure) + CPPrecondition(file_io.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params%move_types),cp_failure_level,routineP,failure) FLUSH(file_io) @@ -673,8 +644,7 @@ SUBROUTINE print_move_types(init, file_io, tmc_params, error) CASE(mv_type_MD) CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& -"md_time_step and nr md_steps not implemented...",& -error) +"md_time_step and nr md_steps not implemented...") ! IF(type_title) WRITE(c_tit,TRIM(FMT_c)) TRIM(c_tit), "HybridMC" ! IF(init) WRITE(c_c,TRIM(FMT_c)) TRIM(c_c), "s.above" ! IF(init) THEN @@ -744,8 +714,7 @@ SUBROUTINE print_move_types(init, file_io, tmc_params, error) CASE DEFAULT CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& "unknown move type "//cp_to_string(typ)//" with weight"//& - cp_to_string(move_types%mv_weight(typ)),& - error) + cp_to_string(move_types%mv_weight(typ))) END SELECT END IF END IF @@ -771,18 +740,15 @@ END SUBROUTINE print_move_types !> \param acc input if the element is accepted !> \param subbox logical if move was with respect to the sub box !> \param prob_opt if the average probability should be adapted -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE prob_update(move_types, pt_el, elem, acc, subbox, prob_opt, error) + SUBROUTINE prob_update(move_types, pt_el, elem, acc, subbox, prob_opt) TYPE(tmc_move_type), POINTER :: move_types TYPE(global_tree_type), OPTIONAL, & POINTER :: pt_el TYPE(tree_type), OPTIONAL, POINTER :: elem LOGICAL, INTENT(IN), OPTIONAL :: acc, subbox LOGICAL, INTENT(IN) :: prob_opt - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'prob_update', & routineP = moduleN//':'//routineN @@ -793,8 +759,8 @@ SUBROUTINE prob_update(move_types, pt_el, elem, acc, subbox, prob_opt, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.(PRESENT(pt_el).AND.PRESENT(subbox)),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.(PRESENT(pt_el).AND.PRESENT(subbox)),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -807,7 +773,7 @@ SUBROUTINE prob_update(move_types, pt_el, elem, acc, subbox, prob_opt, error) change_sb_type = 0 ! updating probability of the trajectory IF(PRESENT(pt_el)) THEN - CPPrecondition(ASSOCIATED(pt_el),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pt_el),cp_failure_level,routineP,failure) conf_moved = pt_el%mv_conf SELECT CASE(pt_el%stat) CASE(status_accepted_result) @@ -827,18 +793,17 @@ SUBROUTINE prob_update(move_types, pt_el, elem, acc, subbox, prob_opt, error) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"global elem"//cp_to_string(pt_el%nr)//& - "has unknown status"//cp_to_string(pt_el%stat),& - error) + "has unknown status"//cp_to_string(pt_el%stat)) END SELECT END IF IF(PRESENT(elem)) THEN - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) !conf_moved = elem%sub_tree_nr conf_moved = elem%temp_created mv_type = elem%move_type ! for NMC prob update the acceptance is needed - CPPrecondition(PRESENT(acc),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(acc),cp_failure_level,routineP,failure) IF(PRESENT(subbox)) THEN ! only update subbox acceptance IF(acc) & @@ -890,18 +855,15 @@ END SUBROUTINE prob_update !> \param acc_counter counters of acceptance for these moves !> \param subbox_counter same for sub box moves !> \param subbox_acc_counter same for sub box moves -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE add_mv_prob(move_types, prob_opt, mv_counter, acc_counter, & - subbox_counter, subbox_acc_counter, error) + subbox_counter, subbox_acc_counter) TYPE(tmc_move_type), POINTER :: move_types LOGICAL :: prob_opt INTEGER, DIMENSION(:, :), OPTIONAL :: mv_counter, acc_counter, & subbox_counter, & subbox_acc_counter - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'add_mv_prob', & routineP = moduleN//':'//routineN @@ -909,11 +871,11 @@ SUBROUTINE add_mv_prob(move_types, prob_opt, mv_counter, acc_counter, & LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(mv_counter).OR.PRESENT(subbox_counter),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(mv_counter).OR.PRESENT(subbox_counter),cp_failure_level,routineP,failure) IF(PRESENT(mv_counter)) THEN - CPPrecondition(PRESENT(acc_counter),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(acc_counter),cp_failure_level,routineP,failure) move_types%mv_count(:,:) = move_types%mv_count(:,:) + mv_counter(:,:) move_types%acc_count(:,:)= move_types%acc_count(:,:) + acc_counter(:,:) IF(prob_opt) THEN @@ -923,7 +885,7 @@ SUBROUTINE add_mv_prob(move_types, prob_opt, mv_counter, acc_counter, & END IF IF(PRESENT(subbox_counter)) THEN - CPPrecondition(PRESENT(subbox_acc_counter),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(subbox_acc_counter),cp_failure_level,routineP,failure) move_types%subbox_count(:,:) = move_types%subbox_count(:,:) + subbox_counter(:,:) move_types%subbox_acc_count(:,:) = move_types%subbox_acc_count(:,:) + subbox_acc_counter(:,:) END IF @@ -933,20 +895,17 @@ END SUBROUTINE add_mv_prob !> \brief clear the statistics of accepting/rejection moves !> because worker statistics will be add seperatelly on masters counters !> \param move_types counters for acceptance/rejection -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 02.2013 ! ***************************************************************************** - SUBROUTINE clear_move_probs(move_types, error) + SUBROUTINE clear_move_probs(move_types) TYPE(tmc_move_type), POINTER :: move_types - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'clear_move_probs', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) move_types%acc_prob(:,:) = 0.5_dp move_types%acc_count(:,:) = 0 @@ -959,17 +918,14 @@ END SUBROUTINE clear_move_probs !> \brief selects a move type related to the weighings and the entered rnd nr !> \param move_types structure for storing sizes and probabilities of moves !> \param rnd random number -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval mv_type (result) move type !> \author Mandes 12.2012 !> \note function returns a possible move type without the PT swap moves !> \note (are selected in global tree, this routine is for sub tree elements) ! ***************************************************************************** - FUNCTION select_random_move_type(move_types, rnd, error) RESULT(mv_type) + FUNCTION select_random_move_type(move_types, rnd) RESULT(mv_type) TYPE(tmc_move_type), POINTER :: move_types REAL(KIND=dp) :: rnd - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: mv_type CHARACTER(LEN=*), PARAMETER :: routineN = 'select_random_move_type', & @@ -980,8 +936,8 @@ FUNCTION select_random_move_type(move_types, rnd, error) RESULT(mv_type) REAL(KIND=dp) :: rnd_mv, total_moves failure = .FALSE. - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) - CPPrecondition(rnd.GE.0.0_dp.AND.rnd.LT.1.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) + CPPrecondition(rnd.GE.0.0_dp.AND.rnd.LT.1.0_dp,cp_failure_level,routineP,failure) CALL timeset(routineN,handle) diff --git a/src/tmc/tmc_move_types.F b/src/tmc/tmc_move_types.F index 4f8d3a0232..ca5e7c7103 100644 --- a/src/tmc/tmc_move_types.F +++ b/src/tmc/tmc_move_types.F @@ -77,20 +77,17 @@ MODULE tmc_move_types !> \brief allocating the module variables !> \param move_types pointer to the structure which should be deallocated !> \param nr_temp ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 !> \note deallocating the module variables ! ***************************************************************************** - SUBROUTINE move_types_create(move_types, nr_temp, error) + SUBROUTINE move_types_create(move_types, nr_temp) TYPE(tmc_move_type), POINTER :: move_types INTEGER :: nr_temp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'move_types_create', & routineP = moduleN//':'//routineN - CPPreconditionNoFail(.NOT.ASSOCIATED(move_types),cp_failure_level,routineP,error) + CPPreconditionNoFail(.NOT.ASSOCIATED(move_types),cp_failure_level,routineP) ALLOCATE(move_types) ALLOCATE(move_types%mv_weight(nr_mv_types)) @@ -113,19 +110,16 @@ END SUBROUTINE move_types_create ! ***************************************************************************** !> \brief deallocating the module variables !> \param move_types pointer to the structure which should be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 !> \note deallocating the module variables ! ***************************************************************************** - SUBROUTINE move_types_release(move_types, error) + SUBROUTINE move_types_release(move_types) TYPE(tmc_move_type), POINTER :: move_types - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'move_types_release', & routineP = moduleN//':'//routineN - CPPreconditionNoFail(ASSOCIATED(move_types),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(move_types),cp_failure_level,routineP) IF(ASSOCIATED(move_types%atom_lists)) DEALLOCATE(move_types%atom_lists) DEALLOCATE(move_types%mv_weight) diff --git a/src/tmc/tmc_moves.F b/src/tmc/tmc_moves.F index cae98cca49..0a47a4b6c1 100644 --- a/src/tmc/tmc_moves.F +++ b/src/tmc/tmc_moves.F @@ -66,19 +66,16 @@ MODULE tmc_moves !> \param move_rejected return flag if during configurational change !> configuration should still be accepted (not if e.g. atom/molecule !> leave the sub box -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & - new_subbox, move_rejected, error) + new_subbox, move_rejected) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(tmc_move_type), POINTER :: move_types TYPE(rng_stream_type), POINTER :: rng_stream TYPE(tree_type), POINTER :: elem INTEGER :: mv_conf LOGICAL :: new_subbox, move_rejected - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'change_pos', & routineP = moduleN//':'//routineN @@ -94,28 +91,28 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & failure = .FALSE. NULLIFY(direction, elem_center, mol_in_sb) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) move_rejected = .FALSE. CALL set_rng_stream(rng_stream=rng_stream, bg=elem%rng_seed(:,:,1), & - cg=elem%rng_seed(:,:,2), ig=elem%rng_seed(:,:,3), error=error) + cg=elem%rng_seed(:,:,2), ig=elem%rng_seed(:,:,3)) IF(new_subbox) THEN IF(ALL(tmc_params%sub_box_size.GT.0.0_dp)) THEN CALL elements_in_new_subbox(tmc_params=tmc_params, & rng_stream=rng_stream, elem=elem, & - nr_of_sub_box_elements=nr_sub_box_elem, error=error) + nr_of_sub_box_elements=nr_sub_box_elem) ELSE elem%elem_stat(:) = status_ok END IF END IF ! at least one atom should be in the sub box - CPPrecondition(ANY(elem%elem_stat(:).EQ.status_ok),cp_warning_level,routineP,error,failure) + CPPrecondition(ANY(elem%elem_stat(:).EQ.status_ok),cp_warning_level,routineP,failure) IF(failure) THEN act_nr_elem_mv = -1 ELSE IF(tmc_params%nr_elem_mv.EQ.0) THEN @@ -134,7 +131,7 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & ! just for Gaussian Adaptation CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "gaussian adaptation is not imlemented yet.",& - error,failure) + failure) !TODO CALL new_pos_gauss_adapt(acc=ASSOCIATED(elem%parent%acc, elem), & ! pos=elem%pos, covari=elem%frc, pot=elem%potential, & ! step_size=elem%ekin, pos_aver=elem%vel, temp=elem%ekin_before_md, & @@ -150,7 +147,7 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & IF(tmc_params%nr_elem_mv.EQ.0) THEN ind = (i-1) * (tmc_params%dim_per_elem) +1 ELSE - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number ind = tmc_params%dim_per_elem*& INT(rnd*(SIZE(elem%pos)/tmc_params%dim_per_elem))+1 END IF @@ -158,7 +155,7 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & IF(elem%elem_stat(ind).EQ.status_ok)THEN ! displace atom DO d=0, tmc_params%dim_per_elem-1 - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number elem%pos(ind+d) = elem%pos(ind+d) + (rnd-0.5)*2.0*& move_types%mv_size(mv_type_atom_trans,mv_conf) END DO @@ -166,8 +163,8 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & elem_center = elem%pos(ind:ind+tmc_params%dim_per_elem-1) IF(.NOT.check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & - box_scale=elem%box_scale, tmc_params=tmc_params, & - error=error)) THEN + box_scale=elem%box_scale, tmc_params=tmc_params)& + ) THEN move_rejected = .TRUE. EXIT move_elements_loop END IF @@ -192,13 +189,13 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & ! check if any molecule is in sub_box DO m=1, nr_molec CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, mol=m, & - start_ind=ind, end_ind=ind_e, error=error) + start_ind=ind, end_ind=ind_e) CALL geometrical_center(pos=elem%pos(ind:ind_e+tmc_params%dim_per_elem-1), & - center=elem_center, error=error) + center=elem_center) IF(check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & - box_scale=elem%box_scale, tmc_params=tmc_params, & - error=error)) & + box_scale=elem%box_scale, tmc_params=tmc_params)& + ) & mol_in_sb(m) = status_ok END DO ! displace the selected amount of molecules @@ -210,11 +207,11 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & IF(tmc_params%nr_elem_mv.EQ.0) THEN m = counter ELSE - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number m = INT(rnd*nr_molec)+1 END IF CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, mol=m, & - start_ind=ind, end_ind=ind_e, error=error) + start_ind=ind, end_ind=ind_e) ! when "molecule" is single atom, search a new one IF(ind .EQ. ind_e) CYCLE move_molecule_loop @@ -223,7 +220,7 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & IF(mol_in_sb(m) .EQ. status_ok) THEN ! calculate displacement DO d=1, tmc_params%dim_per_elem - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number direction(d) = (rnd-0.5)* 2.0_dp*move_types%mv_size(& mv_type_mol_trans,mv_conf) END DO @@ -231,8 +228,8 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & elem_center(:) = elem_center(:) + direction(:) IF(check_pos_in_subbox(pos=elem_center,& subbox_center=elem%subbox_center, & - box_scale=elem%box_scale, tmc_params=tmc_params, & - error=error)) THEN + box_scale=elem%box_scale, tmc_params=tmc_params)& + ) THEN ! apply move atom_in_mol_loop:DO i=ind, ind_e+tmc_params%dim_per_elem-1, tmc_params%dim_per_elem dim_loop:DO d=0, tmc_params%dim_per_elem-1 @@ -267,13 +264,13 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & ! check if any molecule is in sub_box DO m=1, nr_molec CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, mol=m, & - start_ind=ind, end_ind=ind_e, error=error) + start_ind=ind, end_ind=ind_e) CALL geometrical_center(pos=elem%pos(ind:ind_e+tmc_params%dim_per_elem-1), & - center=elem_center, error=error) + center=elem_center) IF(check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & - box_scale=elem%box_scale, tmc_params=tmc_params, & - error=error)) & + box_scale=elem%box_scale, tmc_params=tmc_params)& + ) & mol_in_sb(m) = status_ok END DO ! rotate the selected amount of molecules @@ -284,11 +281,11 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & IF(tmc_params%nr_elem_mv.EQ.0) THEN m = counter ELSE - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number m = INT(rnd*nr_molec)+1 END IF CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, mol=m, & - start_ind=ind, end_ind=ind_e, error=error) + start_ind=ind, end_ind=ind_e) ! when "molecule" is single atom, search a new one IF(ind .EQ. ind_e) CYCLE rot_molecule_loop @@ -298,14 +295,14 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & max_angle=move_types%mv_size(& mv_type_mol_rot,mv_conf), & move_types=move_types, rng_stream=rng_stream, & - dim_per_elem=tmc_params%dim_per_elem, error=error) + dim_per_elem=tmc_params%dim_per_elem) ! update sub box status of single atom DO i=ind, ind_e+tmc_params%dim_per_elem-1, tmc_params%dim_per_elem elem_center = elem%pos(i:i+tmc_params%dim_per_elem-1) IF(check_pos_in_subbox(pos=elem_center, & subbox_center=elem%subbox_center, & - box_scale=elem%box_scale, tmc_params=tmc_params, & - error=error))THEN + box_scale=elem%box_scale, tmc_params=tmc_params)& + )THEN elem%elem_stat(i:i+tmc_params%dim_per_elem-1) = status_ok ELSE elem%elem_stat(i:i+tmc_params%dim_per_elem-1) = status_frozen @@ -325,7 +322,7 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & !-- velocity changes for MD !-- here all velocities are changed CASE(mv_type_MD) - CPPreconditionNoFail(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP) change_all_velocities_loop: DO i=1, SIZE(elem%pos) !-- attention, move type size is in atomic units of velocity IF(elem%elem_stat(i).NE.status_frozen) THEN @@ -334,7 +331,7 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & phi=move_types%mv_size(mv_type_MD,1),& ! TODO parallel tempering move sizes for vel_change temp=tmc_params%Temp(mv_conf), & rnd_sign_change=.TRUE., &! MD_vel_invert, & - rng_stream=rng_stream, error=error) + rng_stream=rng_stream) END IF END DO change_all_velocities_loop @@ -344,30 +341,30 @@ SUBROUTINE change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, & CASE(mv_type_proton_reorder) CALL search_and_do_proton_displace_loop(elem=elem, & short_loop=move_rejected, rng_stream=rng_stream, & - tmc_params=tmc_params, error=error) + tmc_params=tmc_params) !-- volume move ! the box is increased or decreased and with it the coordinates CASE(mv_type_volume_move) CALL change_volume(conf=elem, T_ind=mv_conf, move_types=move_types, & rng_stream=rng_stream, tmc_params=tmc_params, & - mv_cen_of_mass=tmc_params%mv_cen_of_mass, error=error) + mv_cen_of_mass=tmc_params%mv_cen_of_mass) !-- atom swap ! two atoms of different types are swapped CASE(mv_type_atom_swap) CALL swap_atoms(conf=elem, move_types=move_types, rng_stream=rng_stream,& - tmc_params=tmc_params, error=error) + tmc_params=tmc_params) CASE DEFAULT CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "unknown move type "//& - cp_to_string(elem%move_type),error) + cp_to_string(elem%move_type)) END SELECT CALL get_rng_stream(rng_stream=rng_stream, bg=elem%rng_seed(:,:,1), & - cg=elem%rng_seed(:,:,2), ig=elem%rng_seed(:,:,3), error=error) + cg=elem%rng_seed(:,:,2), ig=elem%rng_seed(:,:,3)) END SUBROUTINE change_pos @@ -378,17 +375,14 @@ END SUBROUTINE change_pos !> \param mol the selected molecule number !> \param start_ind start index of the first atom in molecule !> \param end_ind index of the last atom in molecule -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 10.2013 ! ***************************************************************************** - SUBROUTINE get_mol_indeces(tmc_params, mol_arr, mol, start_ind, end_ind, error) + SUBROUTINE get_mol_indeces(tmc_params, mol_arr, mol, start_ind, end_ind) TYPE(tmc_param_type), POINTER :: tmc_params INTEGER, DIMENSION(:), INTENT(IN), & POINTER :: mol_arr INTEGER, INTENT(IN) :: mol INTEGER, INTENT(OUT) :: start_ind, end_ind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_mol_indeces', & routineP = moduleN//':'//routineN @@ -401,8 +395,8 @@ SUBROUTINE get_mol_indeces(tmc_params, mol_arr, mol, start_ind, end_ind, error) start_ind = -1 end_ind = -1 - CPPrecondition(ASSOCIATED(mol_arr),cp_failure_level,routineP,error,failure) - CPPrecondition(mol.LE.MAXVAL(mol_arr(:)),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(mol_arr),cp_failure_level,routineP,failure) + CPPrecondition(mol.LE.MAXVAL(mol_arr(:)),cp_failure_level,routineP,failure) ! get start index loop_start: DO i=1, SIZE(mol_arr) IF(mol_arr(i) .EQ. mol) THEN @@ -418,9 +412,9 @@ SUBROUTINE get_mol_indeces(tmc_params, mol_arr, mol, start_ind, end_ind, error) END IF END DO loop_end ! check if all atoms inbetween attend to molecule - CPPostcondition(ALL(mol_arr(start_ind:end_ind).EQ.mol),cp_failure_level,routineP,error,failure) - CPPostcondition(start_ind.GT.0,cp_failure_level,routineP,error,failure) - CPPostcondition(end_ind.GT.0,cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(mol_arr(start_ind:end_ind).EQ.mol),cp_failure_level,routineP,failure) + CPPostcondition(start_ind.GT.0,cp_failure_level,routineP,failure) + CPPostcondition(end_ind.GT.0,cp_failure_level,routineP,failure) ! convert to indeces mapped for the position array (multiple dim per atom) start_ind = (start_ind-1)*tmc_params%dim_per_elem+1 end_ind = (end_ind-1)*tmc_params%dim_per_elem+1 @@ -433,16 +427,13 @@ SUBROUTINE get_mol_indeces(tmc_params, mol_arr, mol, start_ind, end_ind, error) !> \param subbox_center actual center of sub box !> \param box_scale scaling factors for the cell !> \param tmc_params TMC parameters with sub box size and cell -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval inside ... !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION check_pos_in_subbox(pos, subbox_center, box_scale, tmc_params, error)& + FUNCTION check_pos_in_subbox(pos, subbox_center, box_scale, tmc_params)& RESULT(inside) REAL(KIND=dp), DIMENSION(:), POINTER :: pos, subbox_center, box_scale TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: inside CHARACTER(LEN=*), PARAMETER :: routineN = 'check_pos_in_subbox', & @@ -454,14 +445,14 @@ FUNCTION check_pos_in_subbox(pos, subbox_center, box_scale, tmc_params, error)& failure = .FALSE. - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(subbox_center),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(box_scale),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(subbox_center),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(box_scale),cp_failure_level,routineP,failure) ! if pressure is defined, no scale should be 0 flag = .NOT.((tmc_params%pressure.GT.0.0_dp).AND.(ANY(box_scale.EQ.0.0_dp))) - CPPrecondition(flag,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(pos).EQ.3,cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(pos).EQ.SIZE(subbox_center),cp_failure_level,routineP,error,failure) + CPPrecondition(flag,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(pos).EQ.3,cp_failure_level,routineP,failure) + CPPrecondition(SIZE(pos).EQ.SIZE(subbox_center),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -473,7 +464,7 @@ FUNCTION check_pos_in_subbox(pos, subbox_center, box_scale, tmc_params, error)& IF(.NOT.ANY(tmc_params%sub_box_size(:).LE.0.1_dp)) THEN pos_tmp(:) = pos(:)-subbox_center(:) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=box_scale, & - vec=pos_tmp, error=error) + vec=pos_tmp) ! check IF(ANY(pos_tmp(:).GE.tmc_params%sub_box_size(:)/2.0) .OR. & ANY(pos_tmp(:).LE.-tmc_params%sub_box_size(:)/2.0)) THEN @@ -491,19 +482,16 @@ END FUNCTION check_pos_in_subbox !> \param rng_stream ... !> \param elem ... !> \param nr_of_sub_box_elements ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \param !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE elements_in_new_subbox(tmc_params, rng_stream, elem, & - nr_of_sub_box_elements, error) + nr_of_sub_box_elements) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(rng_stream_type), POINTER :: rng_stream TYPE(tree_type), POINTER :: elem INTEGER, INTENT(OUT) :: nr_of_sub_box_elements - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'elements_in_new_subbox', & routineP = moduleN//':'//routineN @@ -517,8 +505,8 @@ SUBROUTINE elements_in_new_subbox(tmc_params, rng_stream, elem, & failure = .FALSE. NULLIFY(center_of_sub_box, atom_tmp) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -526,7 +514,7 @@ SUBROUTINE elements_in_new_subbox(tmc_params, rng_stream, elem, & IF(ANY(tmc_params%sub_box_size(:).LE.0.1_dp)) THEN !CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,routineP,& ! "try to count elements in sub box without sub box.",& - ! error,failure) + ! failure) elem%elem_stat = status_ok nr_of_sub_box_elements = SIZE(elem%elem_stat) ELSE @@ -536,25 +524,25 @@ SUBROUTINE elements_in_new_subbox(tmc_params, rng_stream, elem, & ! -- define the center of the sub box CALL set_rng_stream(rng_stream=rng_stream, & bg=elem%rng_seed(:,:,1), cg=elem%rng_seed(:,:,2), & - ig=elem%rng_seed(:,:,3), error=error) + ig=elem%rng_seed(:,:,3)) CALL get_cell(cell=tmc_params%cell, abc=box_size) DO i=1, SIZE(tmc_params%sub_box_size) - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number center_of_sub_box(i) = rnd * box_size(i) END DO elem%subbox_center(:) = center_of_sub_box(:) CALL get_rng_stream(rng_stream=rng_stream, & bg=elem%rng_seed(:,:,1), cg=elem%rng_seed(:,:,2), & - ig=elem%rng_seed(:,:,3), error=error) + ig=elem%rng_seed(:,:,3)) ! check all elements if they are in subbox DO i=1, SIZE(elem%pos), tmc_params%dim_per_elem atom_tmp(:) = elem%pos(i:i+tmc_params%dim_per_elem-1) IF(check_pos_in_subbox(pos=atom_tmp, & subbox_center=center_of_sub_box, box_scale=elem%box_scale, & - tmc_params=tmc_params, error=error)) THEN + tmc_params=tmc_params)) THEN elem%elem_stat(i:i+tmc_params%dim_per_elem-1) = status_ok nr_of_sub_box_elements = nr_of_sub_box_elements + 1 ELSE @@ -577,19 +565,16 @@ END SUBROUTINE elements_in_new_subbox !> \param move_types ... !> \param rng_stream ramdon stream !> \param dim_per_elem dimension per atom -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE do_mol_rot(pos, ind_start, ind_end, max_angle, move_types, & - rng_stream, dim_per_elem, error) + rng_stream, dim_per_elem) REAL(KIND=dp), DIMENSION(:), POINTER :: pos INTEGER :: ind_start, ind_end REAL(KIND=dp) :: max_angle TYPE(tmc_move_type), POINTER :: move_types TYPE(rng_stream_type), POINTER :: rng_stream INTEGER :: dim_per_elem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_mol_rot', & routineP = moduleN//':'//routineN @@ -604,18 +589,18 @@ SUBROUTINE do_mol_rot(pos, ind_start, ind_end, max_angle, move_types, & failure = .FALSE. NULLIFY(elem_center) - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CPPrecondition(dim_per_elem.EQ.3,cp_failure_level,routineP,error,failure) - CPPrecondition(ind_start.GT.0.AND.ind_start.LT.SIZE(pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ind_end.GT.0.AND.ind_end.LT.SIZE(pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CPPrecondition(dim_per_elem.EQ.3,cp_failure_level,routineP,failure) + CPPrecondition(ind_start.GT.0.AND.ind_start.LT.SIZE(pos),cp_failure_level,routineP,failure) + CPPrecondition(ind_end.GT.0.AND.ind_end.LT.SIZE(pos),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) ! calculate rotation matrix (using quanternions) - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number a1 = (rnd-0.5)*2.0*max_angle !move_types%mv_size(mv_type_mol_rot,mv_conf) - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number a2 = (rnd-0.5)*2.0*max_angle !move_types%mv_size(mv_type_mol_rot,mv_conf) - rnd = next_random_number(rng_stream, error=error) ! next random number + rnd = next_random_number(rng_stream) ! next random number a3 = (rnd-0.5)*2.0*max_angle !move_types%mv_size(mv_type_mol_rot,mv_conf) q0 = COS(a2/2)*COS((a1+a3)/2.0_dp) q1 = SIN(a2/2)*COS((a1-a3)/2.0_dp) @@ -628,7 +613,7 @@ SUBROUTINE do_mol_rot(pos, ind_start, ind_end, max_angle, move_types, & ALLOCATE(elem_center(dim_per_elem)) ! calculate geometrical center CALL geometrical_center(pos=pos(ind_start:ind_end+dim_per_elem-1), & - center=elem_center, error=error) + center=elem_center) ! proceed rotation atom_loop:DO i=ind_start, ind_end+dim_per_elem-1, dim_per_elem @@ -648,18 +633,14 @@ END SUBROUTINE do_mol_rot !> \param temp temperature for gaussian distributed velocity !> \param rnd_sign_change if sign of old velocity should change randomly !> \param rng_stream random number stream -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE vel_change(vel, atom_kind, phi, temp, rnd_sign_change, rng_stream, & - error) + SUBROUTINE vel_change(vel, atom_kind, phi, temp, rnd_sign_change, rng_stream) REAL(KIND=dp), INTENT(INOUT) :: vel TYPE(tmc_atom_type) :: atom_kind REAL(KIND=dp), INTENT(IN) :: phi, temp LOGICAL :: rnd_sign_change TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'vel_change', & routineP = moduleN//':'//routineN @@ -672,12 +653,12 @@ SUBROUTINE vel_change(vel, atom_kind, phi, temp, rnd_sign_change, rng_stream, & failure = .FALSE. kB = boltzmann/joule - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) !phi = move_types%mv_size(mv_type_MD,1) ! TODO parallel tempering move sizes for vel_change ! hence first producing a gaussian random number - rnd1 = next_random_number(rng_stream, error=error) - rnd2 = next_random_number(rng_stream, error=error) + rnd1 = next_random_number(rng_stream) + rnd2 = next_random_number(rng_stream) rnd_g = SQRT(-2.0_dp*LOG(rnd1))*COS(2.0_dp*PI*rnd2) !we can also produce a second one in the same step: @@ -691,7 +672,7 @@ SUBROUTINE vel_change(vel, atom_kind, phi, temp, rnd_sign_change, rng_stream, & ! can be switched of using MD_vel_invert ! without still the balance condition should be fullfilled - rnd3 = next_random_number(rng_stream, error=error) + rnd3 = next_random_number(rng_stream) IF(rnd3.GE.0.5.AND.rnd_sign_change) THEN d = -1 ELSE @@ -711,17 +692,14 @@ END SUBROUTINE vel_change !> \param rng_stream random number stream !> \param tmc_params TMC parameters with numbers of dimensions per element !> number of atoms per molecule -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE search_and_do_proton_displace_loop(elem, short_loop, rng_stream, & - tmc_params, error) + tmc_params) TYPE(tree_type), POINTER :: elem LOGICAL :: short_loop TYPE(rng_stream_type), POINTER :: rng_stream TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'search_and_do_proton_displace_loop', & @@ -737,9 +715,9 @@ SUBROUTINE search_and_do_proton_displace_loop(elem, short_loop, rng_stream, & failure = .FALSE. NULLIFY(mol_arr) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -752,7 +730,7 @@ SUBROUTINE search_and_do_proton_displace_loop(elem, short_loop, rng_stream, & mol_arr(:) = -1 donor_acceptor = not_selected ! select randomly if neighboring molecule is donor / acceptor - IF(next_random_number(rng_stream, error=error).LT.0.5_dp) THEN + IF(next_random_number(rng_stream).LT.0.5_dp) THEN donor_acceptor = proton_acceptor ELSE donor_acceptor = proton_donor @@ -760,7 +738,7 @@ SUBROUTINE search_and_do_proton_displace_loop(elem, short_loop, rng_stream, & ! first step build loop ! select randomly one atom - rnd = next_random_number(rng_stream, error=error) + rnd = next_random_number(rng_stream) ! the randomly selected first atom mol = INT(rnd*nr_mol) +1 counter = counter +1 @@ -774,7 +752,7 @@ SUBROUTINE search_and_do_proton_displace_loop(elem, short_loop, rng_stream, & ! (with same state, in the chain, proton donator or proton accptor) CALL find_nearest_proton_acceptor_donator(elem=elem, mol=mol, & donor_acceptor=donor_acceptor, tmc_params=tmc_params, & - rng_stream=rng_stream, error=error) + rng_stream=rng_stream) IF(ANY(mol_arr(:).EQ.mol))& EXIT chain_completition_loop mol_arr(counter) = mol @@ -792,20 +770,19 @@ SUBROUTINE search_and_do_proton_displace_loop(elem, short_loop, rng_stream, & ! check if loop is minimum size of 6 molecules CALL cp_assert(counter.GE.6,cp_warning_level,cp_assertion_failed,& routineP,"short proton loop with"//cp_to_string(counter)//& - "molecules.", error,failure) + "molecules.",failure) IF(failure) THEN tmp_chr="" WRITE(tmp_chr, *) mol_arr(1:counter) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"selected molecules:"//TRIM(tmp_chr),& - error,failure) + failure) short_loop = .TRUE. END IF ! rotate the molecule along the not involved O-H bond ! (about the angle in of the neighboring chain elements) CALL rotate_molecules_in_chain(tmc_params=tmc_params, elem=elem, & - mol_arr_in=mol_arr(1:counter), donor_acceptor=donor_acceptor, & - error=error) + mol_arr_in=mol_arr(1:counter), donor_acceptor=donor_acceptor) DEALLOCATE(mol_arr) ! end the timing @@ -822,17 +799,14 @@ END SUBROUTINE search_and_do_proton_displace_loop !> \param tmc_params TMC parameters with numbers of dimensions per element !> number of atoms per molecule !> \param rng_stream random number stream -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE find_nearest_proton_acceptor_donator(elem, mol, donor_acceptor, & - tmc_params, rng_stream, error) + tmc_params, rng_stream) TYPE(tree_type), POINTER :: elem INTEGER :: mol, donor_acceptor TYPE(tmc_param_type), POINTER :: tmc_params TYPE(rng_stream_type), POINTER :: rng_stream - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'find_nearest_proton_acceptor_donator', & @@ -847,8 +821,8 @@ SUBROUTINE find_nearest_proton_acceptor_donator(elem, mol, donor_acceptor, & failure = .FALSE. NULLIFY(distO, distH1, distH2) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -867,7 +841,7 @@ SUBROUTINE find_nearest_proton_acceptor_donator(elem, mol, donor_acceptor, & ! get the indices of the old O atom (assuming the first atom of the molecule the first atom) CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, mol=mol, & - start_ind=ind, end_ind=ind_e, error=error) + start_ind=ind, end_ind=ind_e) ! calculate distances to all molecules list_distances: DO mol_tmp=1, nr_mol @@ -875,47 +849,47 @@ SUBROUTINE find_nearest_proton_acceptor_donator(elem, mol, donor_acceptor, & ! index of the molecule (the O atom) ! assume the first atom of the molecule the first atom CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, & - mol=mol_tmp, start_ind=ind_n, end_ind=ind_e, error=error) + mol=mol_tmp, start_ind=ind_n, end_ind=ind_e) ! check if selected molecule is water respectively consists of 3 atoms IF(MOD(ind_e-ind_n,3).GT.0) THEN CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"selected a molecule with more than 3 atoms, "//& "the proton reordering does not support, skip molecule",& - error,failure) + failure) CYCLE list_distances END IF IF(donor_acceptor.EQ.proton_acceptor) THEN IF(check_donor_acceptor(elem=elem, i_orig=ind, i_neighbor=ind_n, & - tmc_params=tmc_params, error=error).EQ.proton_acceptor) THEN + tmc_params=tmc_params).EQ.proton_acceptor) THEN !distance of fist proton to certain O distH1(mol_tmp) = nearest_distance(& x1=elem%pos(ind+tmc_params%dim_per_elem:& ind+2*tmc_params%dim_per_elem-1), & x2=elem%pos(ind_n:ind_n+tmc_params%dim_per_elem-1),& - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) !distance of second proton to certain O distH2(mol_tmp) = nearest_distance(& x1=elem%pos(ind+2*tmc_params%dim_per_elem:& ind+3*tmc_params%dim_per_elem-1), & x2=elem%pos(ind_n:ind_n+tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) END IF END IF !check for neighboring proton donors IF(donor_acceptor.EQ.proton_donor) THEN IF(check_donor_acceptor(elem=elem, i_orig=ind, i_neighbor=ind_n, & - tmc_params=tmc_params, error=error).EQ.proton_donor) THEN + tmc_params=tmc_params).EQ.proton_donor) THEN !distance of selected O to all first protons of other melecules distO(mol_tmp) = nearest_distance(& x1=elem%pos(ind:ind+tmc_params%dim_per_elem-1), & x2=elem%pos(ind_n+tmc_params%dim_per_elem:& ind_n+2*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) dist_tmp = nearest_distance(& x1=elem%pos(ind:ind+tmc_params%dim_per_elem-1), & x2=elem%pos(ind_n+2*tmc_params%dim_per_elem:& ind_n+3*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) IF(dist_tmp.LT.distO(mol_tmp)) distO(mol_tmp) = dist_tmp END IF END IF @@ -948,7 +922,7 @@ SUBROUTINE find_nearest_proton_acceptor_donator(elem, mol, donor_acceptor, & END IF ! select randomly the next neighboring molecule - rnd = next_random_number(rng_stream, error=error) + rnd = next_random_number(rng_stream) ! the randomly selected atom: return value! mol_tmp = neighbor_mol(INT(rnd*SIZE(neighbor_mol(:)))+1) mol = mol_tmp @@ -968,17 +942,14 @@ END SUBROUTINE find_nearest_proton_acceptor_donator !> \param i_orig ... !> \param i_neighbor ... !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval donor_acceptor ... !> \author Mandes 11.2012 ! ***************************************************************************** - FUNCTION check_donor_acceptor(elem, i_orig, i_neighbor, tmc_params, error) & + FUNCTION check_donor_acceptor(elem, i_orig, i_neighbor, tmc_params) & RESULT(donor_acceptor) TYPE(tree_type), POINTER :: elem INTEGER :: i_orig, i_neighbor TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: donor_acceptor CHARACTER(LEN=*), PARAMETER :: routineN = 'check_donor_acceptor', & @@ -988,35 +959,35 @@ FUNCTION check_donor_acceptor(elem, i_orig, i_neighbor, tmc_params, error) & REAL(KIND=dp), DIMENSION(4) :: distances failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(i_orig.GE.1.AND.i_orig.LE.SIZE(elem%pos),cp_failure_level,routineP,error,failure) - CPPrecondition(i_neighbor.GE.1.AND.i_neighbor.LE.SIZE(elem%pos),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(i_orig.GE.1.AND.i_orig.LE.SIZE(elem%pos),cp_failure_level,routineP,failure) + CPPrecondition(i_neighbor.GE.1.AND.i_neighbor.LE.SIZE(elem%pos),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! 1. proton of orig with neighbor O distances(1) = nearest_distance(& x1=elem%pos(i_neighbor:i_neighbor+tmc_params%dim_per_elem-1), & x2=elem%pos(i_orig+tmc_params%dim_per_elem:& i_orig+2*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) ! 2. proton of orig with neighbor O distances(2) = nearest_distance(& x1=elem%pos(i_neighbor:i_neighbor+tmc_params%dim_per_elem-1), & x2=elem%pos(i_orig+2*tmc_params%dim_per_elem:& i_orig+3*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) ! 1. proton of neighbor with orig O distances(3) = nearest_distance(& x1=elem%pos(i_orig:i_orig+tmc_params%dim_per_elem-1), & x2=elem%pos(i_neighbor+tmc_params%dim_per_elem:& i_neighbor+2*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) ! 2. proton of neigbor with orig O distances(4) = nearest_distance(& x1=elem%pos(i_orig:i_orig+tmc_params%dim_per_elem-1), & x2=elem%pos(i_neighbor+2*tmc_params%dim_per_elem:& i_neighbor+3*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) IF(MINLOC(distances(:),1).LE.2) THEN donor_acceptor = proton_acceptor @@ -1033,17 +1004,14 @@ END FUNCTION check_donor_acceptor !> changed by rotating !> \param mol_arr_in array of indeces of molecules, should be rotated !> \param donor_acceptor gives the direction of rotation -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE rotate_molecules_in_chain(tmc_params, elem, mol_arr_in, & - donor_acceptor, error) + donor_acceptor) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(tree_type), POINTER :: elem INTEGER, DIMENSION(:) :: mol_arr_in INTEGER :: donor_acceptor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rotate_molecules_in_chain', & routineP = moduleN//':'//routineN @@ -1061,8 +1029,8 @@ SUBROUTINE rotate_molecules_in_chain(tmc_params, elem, mol_arr_in, & failure = .FALSE. NULLIFY(ind_arr, tmp_cell) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1071,7 +1039,7 @@ SUBROUTINE rotate_molecules_in_chain(tmc_params, elem, mol_arr_in, & DO i=1, SIZE(mol_arr_in) CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=elem%mol, & mol=mol_arr_in(i), & - start_ind=ind_arr(i), end_ind=ind, error=error) + start_ind=ind_arr(i), end_ind=ind) END DO ind_arr(0) = ind_arr(SIZE(ind_arr)-2) ind_arr(SIZE(ind_arr)-1) = ind_arr(1) @@ -1079,7 +1047,7 @@ SUBROUTINE rotate_molecules_in_chain(tmc_params, elem, mol_arr_in, & ! get the scaled cell ALLOCATE(tmp_cell) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=elem%box_scale, & - scaled_cell=tmp_cell, error=error) + scaled_cell=tmp_cell) ! rotate single molecules DO i=1, SIZE(ind_arr)-2 @@ -1096,15 +1064,15 @@ SUBROUTINE rotate_molecules_in_chain(tmc_params, elem, mol_arr_in, & ind_arr(i+donor_acceptor)+tmc_params%dim_per_elem-1),& x2=elem%pos(ind_arr(i)+tmc_params%dim_per_elem:& ind_arr(i)+2*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, & - error=error) .LT. & + cell=tmc_params%cell, box_scale=elem%box_scale)& + .LT. & nearest_distance(& x1=elem%pos(ind_arr(i+donor_acceptor):& ind_arr(i+donor_acceptor)+tmc_params%dim_per_elem-1),& x2=elem%pos(ind_arr(i)+2*tmc_params%dim_per_elem:& ind_arr(i)+3*tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, & - error=error)) THEN + cell=tmc_params%cell, box_scale=elem%box_scale)& + ) THEN vec_2H_m = elem%pos(ind_arr(i)+tmc_params%dim_per_elem:& ind_arr(i)+2*tmc_params%dim_per_elem-1) vec_2H_f = elem%pos(ind_arr(i)+2*tmc_params%dim_per_elem:& @@ -1148,8 +1116,7 @@ SUBROUTINE rotate_molecules_in_chain(tmc_params, elem, mol_arr_in, & IF(ind.EQ.ind_arr(i)) CYCLE search_O_loop tmp = nearest_distance(x1=vec_2H_f, & x2=elem%pos(ind:ind+tmc_params%dim_per_elem-1), & - cell=tmc_params%cell, box_scale=elem%box_scale, & - error=error) + cell=tmc_params%cell, box_scale=elem%box_scale) IF(dist_near .GT. tmp) THEN dist_near = tmp vec_4O = elem%pos(ind:ind+tmc_params%dim_per_elem-1) @@ -1193,19 +1160,16 @@ END SUBROUTINE rotate_molecules_in_chain !> \param rng_stream random number generator stream !> \param tmc_params TMC parameters with e.g. dimensions of atoms and molecules !> \param mv_cen_of_mass ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE change_volume(conf, T_ind, move_types, rng_stream, tmc_params, & - mv_cen_of_mass, error) + mv_cen_of_mass) TYPE(tree_type), POINTER :: conf INTEGER :: T_ind TYPE(tmc_move_type), POINTER :: move_types TYPE(rng_stream_type), POINTER :: rng_stream TYPE(tmc_param_type), POINTER :: tmc_params LOGICAL :: mv_cen_of_mass - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'change_volume', & routineP = moduleN//':'//routineN @@ -1221,13 +1185,13 @@ SUBROUTINE change_volume(conf, T_ind, move_types, rng_stream, tmc_params, & failure = .FALSE. NULLIFY(scaling, disp) - CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(T_ind.GT.0.AND.T_ind.LE.tmc_params%nr_temp,cp_failure_level,routineP,error,failure) - CPPrecondition(tmc_params%dim_per_elem.EQ.3,cp_failure_level,routineP,error,failure) - CPPrecondition(tmc_params%cell%orthorhombic,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(T_ind.GT.0.AND.T_ind.LE.tmc_params%nr_temp,cp_failure_level,routineP,failure) + CPPrecondition(tmc_params%dim_per_elem.EQ.3,cp_failure_level,routineP,failure) + CPPrecondition(tmc_params%cell%orthorhombic,cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1238,22 +1202,22 @@ SUBROUTINE change_volume(conf, T_ind, move_types, rng_stream, tmc_params, & box_scale_old(:) = conf%box_scale ! get the cell vector length of the configuration (before move) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=conf%box_scale, & - abc=box_length_new, error=error) + abc=box_length_new) IF(.FALSE.)THEN ! the volume move in volume space (dV) IF(tmc_params%v_isotropic) THEN CALL get_scaled_cell(cell=tmc_params%cell, box_scale=conf%box_scale, & - abc=box_length_new, vol=vol, error=error) - rnd = next_random_number(rng_stream, error=error) + abc=box_length_new, vol=vol) + rnd = next_random_number(rng_stream) vol=vol+(rnd-0.5_dp)*2.0_dp*move_types%mv_size(mv_type_volume_move, T_ind) box_length_new(:) = vol**(1/REAL(3,KIND=dp)) ELSE CALL get_scaled_cell(cell=tmc_params%cell, box_scale=conf%box_scale, & - abc=box_length_new, vol=vol, error=error) - rnd = next_random_number(rng_stream, error=error) + abc=box_length_new, vol=vol) + rnd = next_random_number(rng_stream) vol=vol+(rnd-0.5_dp)*2.0_dp*move_types%mv_size(mv_type_volume_move, T_ind) - rnd = next_random_number(rng_stream, error=error) + rnd = next_random_number(rng_stream) dir = 1+INT(rnd*3) box_length_new(dir) = 1.0_dp box_length_new(dir) = vol/PRODUCT(box_length_new(:)) @@ -1263,15 +1227,15 @@ SUBROUTINE change_volume(conf, T_ind, move_types, rng_stream, tmc_params, & ! increase / decrease box lenght in this direction ! l_n = l_o +- rnd * mv_size IF(tmc_params%v_isotropic) THEN - rnd = next_random_number(rng_stream, error=error) + rnd = next_random_number(rng_stream) box_length_new(:) = box_length_new(:) + & (rnd-0.5_dp)*2.0_dp*& move_types%mv_size(mv_type_volume_move, T_ind) ELSE ! select a random direction - rnd = next_random_number(rng_stream, error=error) + rnd = next_random_number(rng_stream) dir = 1+INT(rnd*3) - rnd = next_random_number(rng_stream, error=error) + rnd = next_random_number(rng_stream) box_length_new(dir) = box_length_new(dir) + & (rnd-0.5_dp)*2.0_dp*& move_types%mv_size(mv_type_volume_move, T_ind) @@ -1282,7 +1246,7 @@ SUBROUTINE change_volume(conf, T_ind, move_types, rng_stream, tmc_params, & scaling(:) = 1.0_dp CALL get_scaled_cell(cell=tmc_params%cell, & box_scale=scaling,& - abc=box_length_orig, error=error) + abc=box_length_orig) ! get the new box scale conf%box_scale(:) = box_length_new(:)/box_length_orig(:) ! molecule scaling @@ -1299,15 +1263,15 @@ SUBROUTINE change_volume(conf, T_ind, move_types, rng_stream, tmc_params, & DO mol=1, MAXVAL(conf%mol(:)) ! move the molecule related to the molecule center of mass ! get center of mass - CPPreconditionNoFail(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP) CALL get_mol_indeces(tmc_params=tmc_params, mol_arr=conf%mol, mol=mol, & - start_ind=ind, end_ind=ind_e, error=error) + start_ind=ind, end_ind=ind_e) CALL center_of_mass(& pos=conf%pos(ind:ind_e+tmc_params%dim_per_elem-1),& atoms=tmc_params%atoms(INT(ind/REAL(tmc_params%dim_per_elem,KIND=dp))+1:& INT(ind_e/REAL(tmc_params%dim_per_elem,KIND=dp))+1),& - center=disp, error=error) + center=disp) ! calculate the center of mass DISPLACEMENT disp(:) = disp(:) * (scaling(:)-1.0_dp) ! displace all atoms of the molecule @@ -1332,16 +1296,13 @@ END SUBROUTINE change_volume !> \param move_types ... !> \param rng_stream random number generator stream !> \param tmc_params TMC parameters with e.g. dimensions of atoms and molecules -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE swap_atoms(conf, move_types, rng_stream, tmc_params, error) + SUBROUTINE swap_atoms(conf, move_types, rng_stream, tmc_params) TYPE(tree_type), POINTER :: conf TYPE(tmc_move_type), POINTER :: move_types TYPE(rng_stream_type), POINTER :: rng_stream TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'swap_atoms', & routineP = moduleN//':'//routineN @@ -1352,20 +1313,20 @@ SUBROUTINE swap_atoms(conf, move_types, rng_stream, tmc_params, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(move_types),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rng_stream),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params%atoms),cp_failure_level,routineP,failure) ! loop until two different atoms are found atom_search_loop: DO ! select one atom randomly a_1 = INT(SIZE(conf%pos)/REAL(tmc_params%dim_per_elem,KIND=dp)* & - next_random_number(rng_stream, error=error))+1 + next_random_number(rng_stream))+1 ! select the second atom randomly a_2 = INT(SIZE(conf%pos)/REAL(tmc_params%dim_per_elem,KIND=dp)* & - next_random_number(rng_stream, error=error))+1 + next_random_number(rng_stream))+1 ! check if they have different kinds IF(tmc_params%atoms(a_1)%name .NE. tmc_params%atoms(a_2)%name) THEN ! if present, check if atoms have different type related to the specified table diff --git a/src/tmc/tmc_setup.F b/src/tmc/tmc_setup.F index dc694445d2..19400ab772 100644 --- a/src/tmc/tmc_setup.F +++ b/src/tmc/tmc_setup.F @@ -94,16 +94,13 @@ MODULE tmc_setup !> \param root_section ... !> \param para_env ... !> \param globenv the global environment for the simulation -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) + SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(global_environment_type), POINTER :: globenv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_tmc', & routineP = moduleN//':'//routineN @@ -124,7 +121,7 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) CALL timeset(routineN,handle) NULLIFY(logger, logger_sub, tmc_env, tmc_ana_env_list) - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) ! write header, on the 'rank 0' of the global communicator @@ -149,22 +146,22 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) CALL mp_bcast(bcast_output_unit,para_env%source,para_env%group) ! create tmc_env - CALL tmc_env_create(tmc_env, error) - CALL tmc_preread_input(root_section,tmc_env,error=error) + CALL tmc_env_create(tmc_env) + CALL tmc_preread_input(root_section,tmc_env) CALL tmc_redistributing_cores(tmc_env%tmc_comp_set, para_env, & ana_on_the_fly=tmc_env%tmc_comp_set%ana_on_the_fly, & - success=success, error=error) + success=success) IF(success) THEN ! initialize master and worker environment IF(tmc_env%tmc_comp_set%group_nr.EQ.0) THEN - CALL tmc_master_env_create(tmc_env, error) ! create master env + CALL tmc_master_env_create(tmc_env) ! create master env ELSE IF(tmc_env%tmc_comp_set%group_nr.NE.0) THEN - CALL tmc_worker_env_create(tmc_env, error) ! create worker env + CALL tmc_worker_env_create(tmc_env) ! create worker env END IF - CALL tmc_read_input(root_section,tmc_env,error=error) - !CALL init_move_types(tmc_params=tmc_env%params, error=error) + CALL tmc_read_input(root_section,tmc_env) + !CALL init_move_types(tmc_params=tmc_env%params) ! init random number generator: use determistic random numbers IF(tmc_env%tmc_comp_set%group_nr.EQ.0.AND.& @@ -181,12 +178,12 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) CALL create_rng_stream(rng_stream=tmc_env%rng_stream, & name="TMC_deterministic_rng_stream",& seed=init_rng_seed(:,:), & - distribution_type=UNIFORM, error=error) + distribution_type=UNIFORM) DEALLOCATE(init_rng_seed) ELSE CALL create_rng_stream(rng_stream=tmc_env%rng_stream,& name="TMC_rng_stream",& - distribution_type=UNIFORM,error=error) + distribution_type=UNIFORM) END IF @@ -211,10 +208,10 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) CALL tmc_header(tmc_env%m_env%io_unit) ENDIF ! print the intresting parameters and starting values - CALL tmc_print_params(tmc_env, error) + CALL tmc_print_params(tmc_env) CALL print_move_types(init=.TRUE., file_io=tmc_env%m_env%io_unit, & - tmc_params=tmc_env%params, error=error) - CALL do_tmc_master(tmc_env=tmc_env, globenv=globenv, error=error) ! start the master routine + tmc_params=tmc_env%params) + CALL do_tmc_master(tmc_env=tmc_env, globenv=globenv) ! start the master routine IF (bcast_output_unit .NE. tmc_env%m_env%io_unit) THEN CALL close_file(unit_number=tmc_env%m_env%io_unit) @@ -240,11 +237,10 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) input_path=tmc_env%params%energy_inp_file, & mpi_comm=tmc_env%tmc_comp_set%para_env_sub_group%group, & output_path=TRIM(expand_file_name_int(file_name=tmc_energy_worker_out_file_name, & - ivalue=tmc_env%tmc_comp_set%group_nr, error=error)), & + ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) CALL cp_assert(ierr.EQ.0, cp_failure_level,cp_assertion_failed, routineP,& - "creating force env result in error "//cp_to_string(ierr),& - error) + "creating force env result in error "//cp_to_string(ierr)) END IF ! worker for configurational change IF(tmc_env%params%NMC_inp_file.NE."" .AND. & @@ -255,13 +251,12 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) input_path=tmc_env%params%NMC_inp_file, & mpi_comm=tmc_env%tmc_comp_set%para_env_sub_group%group, & output_path=TRIM(expand_file_name_int(file_name=tmc_NMC_worker_out_file_name, & - ivalue=tmc_env%tmc_comp_set%group_nr, error=error)), & + ivalue=tmc_env%tmc_comp_set%group_nr)), & ierr=ierr) CALL cp_assert(ierr.EQ.0, cp_failure_level,cp_assertion_failed, routineP,& - "creating approx force env result in error "//cp_to_string(ierr),& - error) + "creating approx force env result in error "//cp_to_string(ierr)) END IF - CALL do_tmc_worker(tmc_env=tmc_env, error=error) ! start the worker routine + CALL do_tmc_worker(tmc_env=tmc_env) ! start the worker routine IF(tmc_env%w_env%env_id_ener.GT.0) & CALL destroy_force_env(tmc_env%w_env%env_id_ener, ierr) @@ -294,16 +289,16 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) ENDIF ALLOCATE(tmc_ana_env_list(tmc_env%params%nr_temp)) - tmc_ana_section => section_vals_get_subs_vals(root_section,"MOTION%TMC%TMC_ANALYSIS",error=error) + tmc_ana_section => section_vals_get_subs_vals(root_section,"MOTION%TMC%TMC_ANALYSIS") DO i=1, tmc_env%params%nr_temp - CALL tmc_read_ana_input(tmc_ana_section, tmc_ana_env_list(i)%temp, error) + CALL tmc_read_ana_input(tmc_ana_section, tmc_ana_env_list(i)%temp) tmc_ana_env_list(i)%temp%io_unit = output_unit END DO - CALL do_tmc_worker(tmc_env=tmc_env, ana_list=tmc_ana_env_list, error=error) ! start the worker routine for analysis + CALL do_tmc_worker(tmc_env=tmc_env, ana_list=tmc_ana_env_list) ! start the worker routine for analysis DO i=1, tmc_env%params%nr_temp IF(ASSOCIATED(tmc_ana_env_list(i)%temp%last_elem)) & - CALL deallocate_sub_tree_node(tree_elem=tmc_ana_env_list(i)%temp%last_elem, error=error) - CALL tmc_ana_env_release(tmc_ana_env_list(i)%temp, error) + CALL deallocate_sub_tree_node(tree_elem=tmc_ana_env_list(i)%temp%last_elem) + CALL tmc_ana_env_release(tmc_ana_env_list(i)%temp) END DO DEALLOCATE(tmc_ana_env_list) IF (bcast_output_unit .NE. output_unit) THEN @@ -315,17 +310,17 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) END IF ! unused worker groups have nothing to do ! delete the random numbers - CPPrecondition(ASSOCIATED(tmc_env%rng_stream),cp_failure_level,routineP,error,failure) - CALL delete_rng_stream(tmc_env%rng_stream,error=error) + CPPrecondition(ASSOCIATED(tmc_env%rng_stream),cp_failure_level,routineP,failure) + CALL delete_rng_stream(tmc_env%rng_stream) ! deallocate the move types - CALL finalize_mv_types(tmc_env%params, error) + CALL finalize_mv_types(tmc_env%params) ! finalize master and worker environment IF(tmc_env%tmc_comp_set%group_nr.EQ.0) THEN - CALL tmc_master_env_release(tmc_env, error) ! release master env + CALL tmc_master_env_release(tmc_env) ! release master env ELSE IF(tmc_env%tmc_comp_set%group_nr.NE.0) THEN - CALL tmc_worker_env_release(tmc_env, error) ! release worker env + CALL tmc_worker_env_release(tmc_env) ! release worker env END IF ! unused worker groups have nothing to do ELSE @@ -335,7 +330,7 @@ SUBROUTINE do_tmc (input_declaration, root_section, para_env, globenv, error ) END IF END IF ! finalize / deallocate everthing - CALL tmc_env_release(tmc_env, error) + CALL tmc_env_release(tmc_env) ! end the timing CALL timestop(handle) @@ -347,16 +342,13 @@ END SUBROUTINE do_tmc !> \param input_declaration ... !> \param root_section ... !> \param para_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE do_analyze_files(input_declaration, root_section, para_env, error) + SUBROUTINE do_analyze_files(input_declaration, root_section, para_env) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_analyze_files', & routineP = moduleN//':'//routineN @@ -378,34 +370,33 @@ SUBROUTINE do_analyze_files(input_declaration, root_section, para_env, error) CALL timeset(routineN,handle) ! create a TMC environment (also to have a params environment) - CALL tmc_env_create(tmc_env, error) + CALL tmc_env_create(tmc_env) ! duplicate communicator CALL mp_comm_dup(para_env%group, my_mpi_world) ! -- spiltting communicators CALL mp_comm_split_direct(my_mpi_world,comm,para_env%mepos, 0) CALL cp_para_env_create(para_env=tmc_env%tmc_comp_set%para_env_m_ana,& - group=comm,error=error) + group=comm) CALL cp_assert(para_env%num_pe.EQ.1, & cp_warning_level,cp_assertion_failed, routineP,& - "just one out of "//cp_to_string(para_env%num_pe)//"cores is used ",& - error) + "just one out of "//cp_to_string(para_env%num_pe)//"cores is used ") ! distribute work to availuble cores IF(para_env%mepos.EQ.0) THEN !TODO get the correct usage of creating and handling the logger... - logger=>cp_error_get_logger(error) + logger=>cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CPPostconditionNoFail(output_unit.GT.0,cp_failure_level,routineP,error) + CPPostconditionNoFail(output_unit.GT.0,cp_failure_level,routineP) ! write the header CALL tmc_ana_header(output_unit) ! read the input and create the ana environments for each temp CALL tmc_read_ana_files_input(input_declaration=input_declaration,& input=root_section,ana_list=ana_list,& - elem=elem, tmc_env=tmc_env,error=error) + elem=elem, tmc_env=tmc_env) nr_dim = SIZE(elem%pos) ! we need a new tree element with all neccessay arrays, (e.g. dipoles could not be allocated already) - CALL deallocate_sub_tree_node(tree_elem=elem, error=error) - CPPostconditionNoFail(SIZE(ana_list).GT.0,cp_failure_level,routineP,error) + CALL deallocate_sub_tree_node(tree_elem=elem) + CPPostconditionNoFail(SIZE(ana_list).GT.0,cp_failure_level,routineP) ! print initial test output (for single core tests, where no data is produced) IF(tmc_env%params%print_test_output) THEN @@ -416,7 +407,7 @@ SUBROUTINE do_analyze_files(input_declaration, root_section, para_env, error) DO temp=1, SIZE(ana_list) ! initialize the structures ana_list(temp)%temp%io_unit = output_unit - CALL analysis_init(ana_env=ana_list(temp)%temp, nr_dim=nr_dim, error=error) + CALL analysis_init(ana_env=ana_list(temp)%temp, nr_dim=nr_dim) ! to allocate the dipole array in tree elements IF(ana_list(temp)%temp%costum_dip_file_name.NE.& tmc_default_unspecified_name)& @@ -424,15 +415,13 @@ SUBROUTINE do_analyze_files(input_declaration, root_section, para_env, error) IF(.NOT.ASSOCIATED(elem)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & - next_el=elem, nr_dim=nr_dim, & - error=error) + next_el=elem, nr_dim=nr_dim) CALL analysis_restart_read(ana_env=ana_list(temp)%temp, & - elem=elem, error=error) + elem=elem) CALL cp_assert(ASSOCIATED(elem).OR.& ASSOCIATED(ana_list(temp)%temp%last_elem), & cp_failure_level,cp_assertion_failed, routineP,& - "uncorrect initialization of the initial configuration ",& - error) + "uncorrect initialization of the initial configuration ") ! do for all directories DO dir_ind=1, SIZE(ana_list(temp)%temp%dirs) WRITE(output_unit,FMT='(T2,A,"| ",A,T41,A40)')"TMC_ANA",& @@ -442,38 +431,37 @@ SUBROUTINE do_analyze_files(input_declaration, root_section, para_env, error) end_id=ana_list(temp)%temp%to_elem, & dir_ind=dir_ind, & ana_env=ana_list(temp)%temp,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) ! remove the last saved element to start with a new file ! there is no weight for this element IF(dir_ind.LT.SIZE(ana_list(temp)%temp%dirs) .AND. & ASSOCIATED(ana_list(temp)%temp%last_elem)) & - CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem, error=error) + CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) IF(ASSOCIATED(ana_list(temp)%temp%last_elem)) & ana_list(temp)%temp%conf_offset = ana_list(temp)%temp%conf_offset& + ana_list(temp)%temp%last_elem%nr END DO - CALL finalize_tmc_analysis(ana_env=ana_list(temp)%temp, error=error) + CALL finalize_tmc_analysis(ana_env=ana_list(temp)%temp) ! write analysis restart file ! if there is somthing to write ! shifts the last element to actual element IF(ASSOCIATED(ana_list(temp)%temp%last_elem)) & - CALL analysis_restart_print(ana_env=ana_list(temp)%temp, & - error=error) + CALL analysis_restart_print(ana_env=ana_list(temp)%temp) IF(ASSOCIATED(ana_list(temp)%temp%last_elem)) & - CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem, error=error) + CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) IF(ASSOCIATED(elem)) & - CALL deallocate_sub_tree_node(tree_elem=elem, error=error) + CALL deallocate_sub_tree_node(tree_elem=elem) IF(ASSOCIATED(ana_list(temp)%temp%last_elem)) & - CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem, error=error) + CALL deallocate_sub_tree_node(tree_elem=ana_list(temp)%temp%last_elem) - CALL tmc_ana_env_release(ana_list(temp)%temp, error) + CALL tmc_ana_env_release(ana_list(temp)%temp) END DO DEALLOCATE(ana_list) END IF CALL mp_comm_free(my_mpi_world) - CALL tmc_env_release(tmc_env, error) + CALL tmc_env_release(tmc_env) ! end the timing CALL timestop(handle) @@ -486,18 +474,15 @@ END SUBROUTINE do_analyze_files !> \param ana_list ... !> \param elem ... !> \param tmc_env TMC analysis environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 03.2013 ! ***************************************************************************** - SUBROUTINE tmc_read_ana_files_input(input_declaration, input, ana_list, elem, tmc_env, error) + SUBROUTINE tmc_read_ana_files_input(input_declaration, input, ana_list, elem, tmc_env) TYPE(section_type), POINTER :: input_declaration TYPE(section_vals_type), POINTER :: input TYPE(tmc_ana_list_type), DIMENSION(:), & POINTER :: ana_list TYPE(tree_type), POINTER :: elem TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tmc_read_ana_files_input', & routineP = moduleN//':'//routineN @@ -512,29 +497,29 @@ SUBROUTINE tmc_read_ana_files_input(input_declaration, input, ana_list, elem, tm NULLIFY(tmc_section, inp_Temp, Temps) failure = .FALSE. - CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(ana_list),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(ana_list),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! first global TMC stuff - tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC",error=error) - CALL section_vals_val_get(tmc_section,"PRINT_TEST_OUTPUT",l_val=tmc_env%params%print_test_output,error=error) + tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC") + CALL section_vals_val_get(tmc_section,"PRINT_TEST_OUTPUT",l_val=tmc_env%params%print_test_output) ! TMC analysis stuff - tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC%TMC_ANALYSIS_FILES",error=error) - CALL section_vals_get(tmc_section,explicit=flag,error=error) - CPPostconditionNoFail(flag,cp_failure_level,routineP,error) + tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC%TMC_ANALYSIS_FILES") + CALL section_vals_get(tmc_section,explicit=flag) + CPPostconditionNoFail(flag,cp_failure_level,routineP) CALL section_vals_val_get(tmc_section,"FORCE_ENV_FILE",& - c_val=tmc_env%params%energy_inp_file,error=error) + c_val=tmc_env%params%energy_inp_file) - CALL section_vals_val_get(tmc_section,"NR_TEMPERATURE",i_val=nr_temp,error=error) + CALL section_vals_val_get(tmc_section,"NR_TEMPERATURE",i_val=nr_temp) - CALL section_vals_val_get(tmc_section,"TEMPERATURE",r_vals=inp_Temp,error=error) + CALL section_vals_val_get(tmc_section,"TEMPERATURE",r_vals=inp_Temp) CALL cp_assert(.NOT.((nr_temp .GT. 1).AND.(SIZE(inp_Temp).NE.2)),& cp_failure_level,cp_assertion_failed,routineP,& "specify each temperature, skip keyword NR_TEMPERATURE",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) IF(nr_temp .EQ. 1) THEN nr_temp = SIZE(inp_Temp) ALLOCATE(Temps(nr_temp)) @@ -551,11 +536,11 @@ SUBROUTINE tmc_read_ana_files_input(input_declaration, input, ana_list, elem, tm cp_failure_level,cp_assertion_failed,routineP,& "The temperatures are negative. Should be specified using "//& "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) END IF ! get multiple directories - CALL section_vals_val_get(tmc_section,"DIRECTORIES",c_vals=directories,error=error) + CALL section_vals_val_get(tmc_section,"DIRECTORIES",c_vals=directories) ! get init configuration (for sizes) CALL create_force_env(new_env_id=env_id, & @@ -564,15 +549,15 @@ SUBROUTINE tmc_read_ana_files_input(input_declaration, input, ana_list, elem, tm mpi_comm=tmc_env%tmc_comp_set%para_env_m_ana%group, & output_path="tmc_ana.out", ierr=ierr) CALL get_initial_conf(tmc_params=tmc_env%params, init_conf=elem, & - env_id=env_id, error=error) + env_id=env_id) CALL get_atom_kinds_and_cell(env_id=env_id, atoms=tmc_env%params%atoms, & - cell=tmc_env%params%cell, error=error) + cell=tmc_env%params%cell) CALL destroy_force_env(env_id, ierr) ALLOCATE(ana_list(SIZE(Temps))) DO t_act=1, SIZE(Temps) ana_list(t_act)%temp => NULL() - CALL tmc_read_ana_input(tmc_section, ana_list(t_act)%temp, error) + CALL tmc_read_ana_input(tmc_section, ana_list(t_act)%temp) ana_list(t_act)%temp%temperature = Temps(t_act) ALLOCATE(ana_list(t_act)%temp%dirs(SIZE(directories))) ana_list(t_act)%temp%dirs(:) = directories(:) @@ -581,13 +566,13 @@ SUBROUTINE tmc_read_ana_files_input(input_declaration, input, ana_list, elem, tm ana_list(t_act)%temp%print_test_output = tmc_env%params%print_test_output CALL section_vals_val_get(tmc_section,"POSITION_FILE",& - c_val=ana_list(t_act)%temp%costum_pos_file_name,error=error) + c_val=ana_list(t_act)%temp%costum_pos_file_name) CALL section_vals_val_get(tmc_section,"DIPOLE_FILE",& - c_val=ana_list(t_act)%temp%costum_dip_file_name,error=error) + c_val=ana_list(t_act)%temp%costum_dip_file_name) CALL section_vals_val_get(tmc_section,"CELL_FILE",& - c_val=ana_list(t_act)%temp%costum_cell_file_name,error=error) - CALL section_vals_val_get(tmc_section,"START_ELEM",i_val=ana_list(t_act)%temp%from_elem,error=error) - CALL section_vals_val_get(tmc_section,"END_ELEM",i_val=ana_list(t_act)%temp%to_elem,error=error) + c_val=ana_list(t_act)%temp%costum_cell_file_name) + CALL section_vals_val_get(tmc_section,"START_ELEM",i_val=ana_list(t_act)%temp%from_elem) + CALL section_vals_val_get(tmc_section,"END_ELEM",i_val=ana_list(t_act)%temp%to_elem) END DO DEALLOCATE(Temps) END SUBROUTINE tmc_read_ana_files_input @@ -596,14 +581,11 @@ END SUBROUTINE tmc_read_ana_files_input !> \brief read the variables for distributing cores !> \param input ... !> \param tmc_env structure for storing all the tmc parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_preread_input(input,tmc_env, error) + SUBROUTINE tmc_preread_input(input,tmc_env) TYPE(section_vals_type), POINTER :: input TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tmc_preread_input', & routineP = moduleN//':'//routineN @@ -618,27 +600,27 @@ SUBROUTINE tmc_preread_input(input,tmc_env, error) failure = .FALSE. NULLIFY(tmc_section, inp_Temp) - CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,failure) tmc_env%tmc_comp_set%ana_on_the_fly = 0 - tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC%TMC_ANALYSIS",error=error) - CALL section_vals_get(tmc_section,explicit=flag,error=error) + tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC%TMC_ANALYSIS") + CALL section_vals_get(tmc_section,explicit=flag) IF(flag) THEN tmc_env%tmc_comp_set%ana_on_the_fly = 1 END IF - tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC",error=error) - CALL section_vals_get(tmc_section,explicit=flag,error=error) - CPPostconditionNoFail(flag,cp_failure_level,routineP,error) + tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC") + CALL section_vals_get(tmc_section,explicit=flag) + CPPostconditionNoFail(flag,cp_failure_level,routineP) - CALL section_vals_val_get(tmc_section,"PRINT_TEST_OUTPUT",l_val=tmc_env%params%print_test_output,error=error) + CALL section_vals_val_get(tmc_section,"PRINT_TEST_OUTPUT",l_val=tmc_env%params%print_test_output) - CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,failure) ! read the parameters for the computational setup - CALL section_vals_val_get(tmc_section,"GROUP_ENERGY_SIZE",i_val=tmc_env%tmc_comp_set%group_ener_size,error=error) - CALL section_vals_val_get(tmc_section,"GROUP_ENERGY_NR",i_val=tmc_env%tmc_comp_set%group_ener_nr,error=error) - CALL section_vals_val_get(tmc_section,"GROUP_CC_SIZE",i_val=tmc_env%tmc_comp_set%group_cc_size,error=error) - CALL section_vals_val_get(tmc_section,"GROUP_ANLYSIS_NR",i_val=itmp, error=error) + CALL section_vals_val_get(tmc_section,"GROUP_ENERGY_SIZE",i_val=tmc_env%tmc_comp_set%group_ener_size) + CALL section_vals_val_get(tmc_section,"GROUP_ENERGY_NR",i_val=tmc_env%tmc_comp_set%group_ener_nr) + CALL section_vals_val_get(tmc_section,"GROUP_CC_SIZE",i_val=tmc_env%tmc_comp_set%group_cc_size) + CALL section_vals_val_get(tmc_section,"GROUP_ANLYSIS_NR",i_val=itmp) IF(tmc_env%tmc_comp_set%ana_on_the_fly.GT.0) & tmc_env%tmc_comp_set%ana_on_the_fly = itmp CALL cp_assert(tmc_env%tmc_comp_set%ana_on_the_fly.LE.1,& @@ -646,27 +628,27 @@ SUBROUTINE tmc_preread_input(input,tmc_env, error) "analysing on the fly is up to now not supported for multiple cores. "//& " Restart file witing for this case and temperature "//& "distribution has to be solved.!.",& - error, failure=flag, only_ionode=.TRUE.) - CALL section_vals_val_get(tmc_section,"RESULT_LIST_IN_MEMORY",l_val=tmc_env%params%USE_REDUCED_TREE,error=error) + failure=flag, only_ionode=.TRUE.) + CALL section_vals_val_get(tmc_section,"RESULT_LIST_IN_MEMORY",l_val=tmc_env%params%USE_REDUCED_TREE) ! swap the variable, because of oposit meaning tmc_env%params%USE_REDUCED_TREE = .NOT.tmc_env%params%USE_REDUCED_TREE - CALL section_vals_val_get(tmc_section,"NR_TEMPERATURE",i_val=tmc_env%params%nr_temp,error=error) + CALL section_vals_val_get(tmc_section,"NR_TEMPERATURE",i_val=tmc_env%params%nr_temp) ! stuff everyone needs to know - CALL section_vals_val_get(tmc_section,"NMC_MOVES%NMC_FILE_NAME",c_val=tmc_env%params%NMC_inp_file,error=error) + CALL section_vals_val_get(tmc_section,"NMC_MOVES%NMC_FILE_NAME",c_val=tmc_env%params%NMC_inp_file) IF(tmc_env%params%NMC_inp_file.EQ.tmc_default_unspecified_name)THEN ! file name keyword without file name CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "no or a valid NMC input file has to be specified ",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) ELSE IF(tmc_env%params%NMC_inp_file.EQ."") THEN ! no keyword CALL cp_assert(tmc_env%tmc_comp_set%group_cc_size.LE.0,& cp_warning_level,cp_assertion_failed,routineP,& "The configurational groups are deactivated, "//& "because no approximated energy input is specified.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) tmc_env%tmc_comp_set%group_cc_size = 0 ELSE ! check file existance @@ -674,14 +656,14 @@ SUBROUTINE tmc_preread_input(input,tmc_env, error) CALL cp_assert(flag .AND. itmp.EQ.0,& cp_failure_level,cp_assertion_failed,routineP,& "a valid NMC input file has to be specified ",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) END IF - CALL section_vals_val_get(tmc_section,"TEMPERATURE",r_vals=inp_Temp,error=error) + CALL section_vals_val_get(tmc_section,"TEMPERATURE",r_vals=inp_Temp) CALL cp_assert(.NOT.((tmc_env%params%nr_temp .GT. 1).AND.(SIZE(inp_Temp).NE.2)),& cp_failure_level,cp_assertion_failed,routineP,& "specify each temperature, skip keyword NR_TEMPERATURE",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) IF(tmc_env%params%nr_temp .EQ. 1) THEN tmc_env%params%nr_temp = SIZE(inp_Temp) ALLOCATE(tmc_env%params%Temp(tmc_env%params%nr_temp)) @@ -698,12 +680,12 @@ SUBROUTINE tmc_preread_input(input,tmc_env, error) cp_failure_level,cp_assertion_failed,routineP,& "The temperatures are negative. Should be specified using "//& "TEMPERATURE {T_min} {T_max} and NR_TEMPERATURE {#temperatures}",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) END IF - CALL section_vals_val_get(tmc_section,"TASK_TYPE" ,explicit=explicit_key,error=error) + CALL section_vals_val_get(tmc_section,"TASK_TYPE" ,explicit=explicit_key) IF(explicit_key)THEN - CALL section_vals_val_get(tmc_section,"TASK_TYPE",c_val=c_tmp,error=error) + CALL section_vals_val_get(tmc_section,"TASK_TYPE",c_val=c_tmp) SELECT CASE (TRIM(c_tmp)) CASE (TRIM(tmc_default_unspecified_name)) tmc_env%params%task_type = task_type_MC @@ -714,7 +696,7 @@ SUBROUTINE tmc_preread_input(input,tmc_env, error) cp_warning_level,cp_assertion_failed,routineP,& 'unknown TMC task type "'//TRIM(c_tmp)//'" specified. '//& " Set to default.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) tmc_env%params%task_type = task_type_MC END SELECT END IF @@ -726,14 +708,11 @@ END SUBROUTINE tmc_preread_input !> \brief read the tmc subsection from the input file !> \param input points to the tmc subsection in the input file !> \param tmc_env structure for storing all the tmc parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_read_input(input,tmc_env, error) + SUBROUTINE tmc_read_input(input,tmc_env) TYPE(section_vals_type), POINTER :: input TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tmc_read_input', & routineP = moduleN//':'//routineN @@ -748,29 +727,29 @@ SUBROUTINE tmc_read_input(input,tmc_env, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(input),cp_failure_level,routineP,failure) - tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC",error=error) - CALL section_vals_get(tmc_section,explicit=flag,error=error) - CPPostconditionNoFail(flag,cp_failure_level,routineP,error) + tmc_section => section_vals_get_subs_vals(input,"MOTION%TMC") + CALL section_vals_get(tmc_section,explicit=flag) + CPPostconditionNoFail(flag,cp_failure_level,routineP) ! only for the master IF(tmc_env%tmc_comp_set%group_nr == 0) THEN - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) ! the walltime input can be done as HH:MM:SS or just in seconds. CALL cp2k_get_walltime(section=input, keyword_name="GLOBAL%WALLTIME", & - walltime=tmc_env%m_env%walltime, error=error) + walltime=tmc_env%m_env%walltime) - CALL section_vals_val_get(tmc_section,"NUM_MC_ELEM",i_val=tmc_env%m_env%num_MC_elem,error=error) - CALL section_vals_val_get(tmc_section,"RND_DETERMINISTIC",i_val=tmc_env%m_env%rnd_init,error=error) + CALL section_vals_val_get(tmc_section,"NUM_MC_ELEM",i_val=tmc_env%m_env%num_MC_elem) + CALL section_vals_val_get(tmc_section,"RND_DETERMINISTIC",i_val=tmc_env%m_env%rnd_init) ! restarting - CALL section_vals_val_get(tmc_section,"RESTART_IN",c_val=tmc_env%m_env%restart_in_file_name,error=error) + CALL section_vals_val_get(tmc_section,"RESTART_IN",c_val=tmc_env%m_env%restart_in_file_name) IF(tmc_env%m_env%restart_in_file_name.EQ.tmc_default_unspecified_name) THEN tmc_env%m_env%restart_in_file_name = tmc_default_restart_in_file_name INQUIRE(FILE=tmc_env%m_env%restart_in_file_name, EXIST=flag) IF(.NOT.flag) tmc_env%m_env%restart_in_file_name = "" END IF - CALL section_vals_val_get(tmc_section,"RESTART_OUT",i_val=tmc_env%m_env%restart_out_step,error=error) + CALL section_vals_val_get(tmc_section,"RESTART_OUT",i_val=tmc_env%m_env%restart_out_step) ! restart just at the end (lone keyword) IF(tmc_env%m_env%restart_out_step.EQ.-9) THEN tmc_env%m_env%restart_out_file_name = tmc_default_restart_out_file_name @@ -783,52 +762,52 @@ SUBROUTINE tmc_read_input(input,tmc_env, error) "# > 0 to define the amount of Markov chain elements in between, "//& "or 0 to deactivate the restart file writing. "//& "Lonely keyword writes restart file only at the end of the run.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) - CALL section_vals_val_get(tmc_section,"INFO_OUT_STEP_SIZE",i_val=tmc_env%m_env%info_out_step_size,error=error) - CALL section_vals_val_get(tmc_section,"DOT_TREE",c_val=tmc_env%params%dot_file_name,error=error) - CALL section_vals_val_get(tmc_section,"ALL_CONF_FILE_NAME",c_val=tmc_env%params%all_conf_file_name,error=error) + CALL section_vals_val_get(tmc_section,"INFO_OUT_STEP_SIZE",i_val=tmc_env%m_env%info_out_step_size) + CALL section_vals_val_get(tmc_section,"DOT_TREE",c_val=tmc_env%params%dot_file_name) + CALL section_vals_val_get(tmc_section,"ALL_CONF_FILE_NAME",c_val=tmc_env%params%all_conf_file_name) IF(tmc_env%params%dot_file_name.NE."") tmc_env%params%DRAW_TREE = .TRUE. ! everything for the worker group ELSE IF(tmc_env%tmc_comp_set%group_nr .NE. 0) THEN - CPPrecondition(ASSOCIATED(tmc_env%w_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env%w_env),cp_failure_level,routineP,failure) END IF ! stuff everyone needs to know ! the NMC_FILE_NAME is already read in tmc_preread_input - CALL section_vals_val_get(tmc_section,"ENERGY_FILE_NAME",c_val=tmc_env%params%energy_inp_file,error=error) + CALL section_vals_val_get(tmc_section,"ENERGY_FILE_NAME",c_val=tmc_env%params%energy_inp_file) ! file name keyword without file name CALL cp_assert(tmc_env%params%energy_inp_file.NE."",& cp_failure_level,cp_assertion_failed,routineP,& "a valid exact energy input file has to be specified ",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) ! check file existance INQUIRE (FILE=TRIM(tmc_env%params%energy_inp_file),EXIST=flag,IOSTAT=itmp) CALL cp_assert(flag.AND.itmp.EQ.0,& cp_failure_level,cp_assertion_failed,routineP,& "a valid exact energy input file has to be specified, "//& TRIM(tmc_env%params%energy_inp_file)//" does not exist.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) - CALL section_vals_val_get(tmc_section,"NUM_MV_ELEM_IN_CELL",i_val=tmc_env%params%nr_elem_mv,error=error) + CALL section_vals_val_get(tmc_section,"NUM_MV_ELEM_IN_CELL",i_val=tmc_env%params%nr_elem_mv) - CALL section_vals_val_get(tmc_section,"VOLUME_ISOTROPIC",l_val=tmc_env%params%v_isotropic,error=error) - CALL section_vals_val_get(tmc_section,"PRESSURE",r_val=tmc_env%params%pressure,error=error) + CALL section_vals_val_get(tmc_section,"VOLUME_ISOTROPIC",l_val=tmc_env%params%v_isotropic) + CALL section_vals_val_get(tmc_section,"PRESSURE",r_val=tmc_env%params%pressure) tmc_env%params%pressure = tmc_env%params%pressure/au2bar - CALL section_vals_val_get(tmc_section,"MOVE_CENTER_OF_MASS",l_val=tmc_env%params%mv_cen_of_mass,error=error) + CALL section_vals_val_get(tmc_section,"MOVE_CENTER_OF_MASS",l_val=tmc_env%params%mv_cen_of_mass) - CALL section_vals_val_get(tmc_section,"SUB_BOX",r_vals=r_arr_tmp,error=error) + CALL section_vals_val_get(tmc_section,"SUB_BOX",r_vals=r_arr_tmp) IF(SIZE(r_arr_tmp).GT.1) THEN CALL cp_assert(SIZE(r_arr_tmp).EQ.tmc_env%params%dim_per_elem,& cp_failure_level,cp_assertion_failed,routineP,& "The entered sub box sizes does not fit in number of dimensions.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) CALL cp_assert(ALL(r_arr_tmp.GT.0.0_dp),& cp_failure_level,cp_assertion_failed,routineP,& "The entered sub box lenghts should be greater than 0.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) DO itmp=1, SIZE(tmc_env%params%sub_box_size) tmc_env%params%sub_box_size(itmp) = r_arr_tmp(itmp)/au2a END DO @@ -839,24 +818,24 @@ SUBROUTINE tmc_read_input(input,tmc_env, error) ! read all the distinct moves CALL read_init_move_types(tmc_params=tmc_env%params, & - tmc_section=tmc_section, error=error) + tmc_section=tmc_section) - CALL section_vals_val_get(tmc_section,"ESIMATE_ACC_PROB",l_val=tmc_env%params%esimate_acc_prob,error=error) - CALL section_vals_val_get(tmc_section,"SPECULATIVE_CANCELING",l_val=tmc_env%params%SPECULATIVE_CANCELING,error=error) - CALL section_vals_val_get(tmc_section,"USE_SCF_ENERGY_INFO",l_val=tmc_env%params%use_scf_energy_info,error=error) + CALL section_vals_val_get(tmc_section,"ESIMATE_ACC_PROB",l_val=tmc_env%params%esimate_acc_prob) + CALL section_vals_val_get(tmc_section,"SPECULATIVE_CANCELING",l_val=tmc_env%params%SPECULATIVE_CANCELING) + CALL section_vals_val_get(tmc_section,"USE_SCF_ENERGY_INFO",l_val=tmc_env%params%use_scf_energy_info) ! printing - CALL section_vals_val_get(tmc_section,"PRINT_ONLY_ACC",l_val=tmc_env%params%print_only_diff_conf,error=error) - CALL section_vals_val_get(tmc_section,"PRINT_COORDS",l_val=tmc_env%params%print_trajectory,error=error) - CALL section_vals_val_get(tmc_section,"PRINT_DIPOLE" ,explicit=explicit,error=error) + CALL section_vals_val_get(tmc_section,"PRINT_ONLY_ACC",l_val=tmc_env%params%print_only_diff_conf) + CALL section_vals_val_get(tmc_section,"PRINT_COORDS",l_val=tmc_env%params%print_trajectory) + CALL section_vals_val_get(tmc_section,"PRINT_DIPOLE" ,explicit=explicit) IF(explicit) & - CALL section_vals_val_get(tmc_section,"PRINT_DIPOLE",l_val=tmc_env%params%print_dipole,error=error) - CALL section_vals_val_get(tmc_section,"PRINT_FORCES" ,explicit=explicit,error=error) + CALL section_vals_val_get(tmc_section,"PRINT_DIPOLE",l_val=tmc_env%params%print_dipole) + CALL section_vals_val_get(tmc_section,"PRINT_FORCES" ,explicit=explicit) IF(explicit) & - CALL section_vals_val_get(tmc_section,"PRINT_FORCES",l_val=tmc_env%params%print_forces,error=error) - CALL section_vals_val_get(tmc_section,"PRINT_CELL" ,explicit=explicit,error=error) + CALL section_vals_val_get(tmc_section,"PRINT_FORCES",l_val=tmc_env%params%print_forces) + CALL section_vals_val_get(tmc_section,"PRINT_CELL" ,explicit=explicit) IF(explicit) & - CALL section_vals_val_get(tmc_section,"PRINT_CELL",l_val=tmc_env%params%print_cell,error=error) - CALL section_vals_val_get(tmc_section,"PRINT_ENERGIES",l_val=tmc_env%params%print_energies,error=error) + CALL section_vals_val_get(tmc_section,"PRINT_CELL",l_val=tmc_env%params%print_cell) + CALL section_vals_val_get(tmc_section,"PRINT_ENERGIES",l_val=tmc_env%params%print_energies) END SUBROUTINE tmc_read_input @@ -866,17 +845,14 @@ END SUBROUTINE tmc_read_input !> \param para_env the old parallel environment !> \param ana_on_the_fly ... !> \param success ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & - success, error) + success) TYPE(tmc_comp_set_type), POINTER :: tmc_comp_set TYPE(cp_para_env_type), POINTER :: para_env INTEGER :: ana_on_the_fly LOGICAL :: success - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tmc_redistributing_cores', & routineP = moduleN//':'//routineN @@ -887,8 +863,8 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & my_mpi_world, total_used LOGICAL :: failure, flag, master - CPPrecondition(ASSOCIATED(tmc_comp_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_comp_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(para_env),cp_failure_level,routineP,failure) ! colors and positions for new communicators ! variables for printing @@ -912,21 +888,21 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& "TMC need at least 2 cores (one for master, one for worker)",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) success = .FALSE. ELSE ! check if there are enougth cores available CALL cp_assert(tmc_comp_set%group_ener_size*tmc_comp_set%group_ener_nr.LE.(para_env%num_pe-1),& cp_warning_level,cp_assertion_failed,routineP,& "The selected energy group size is too huge. ",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) IF(flag)THEN tmc_comp_set%group_ener_nr = INT((para_env%num_pe-1)/& REAL(tmc_comp_set%group_ener_size,KIND=dp)) CALL cp_assert(tmc_comp_set%group_ener_nr.GE.1,& cp_warning_level,cp_assertion_failed,routineP,& "The selected energy group size is too huge. ",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) IF(flag) success = .FALSE. END IF @@ -940,7 +916,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & CALL cp_assert(tmc_comp_set%group_cc_nr.GE.1,& cp_warning_level,cp_assertion_failed,routineP,& "There are not enougth cores left for creating groups for configurational change.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) IF(flag) success = .FALSE. END IF @@ -951,7 +927,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & cp_warning_level,cp_assertion_failed,routineP,& cp_to_string(para_env%num_pe-1-total_used)//& " mpi ranks are unused, but can be used for analysis.",& - error, failure=flag, only_ionode=.TRUE.) + failure=flag, only_ionode=.TRUE.) ! duplicate communicator CALL mp_comm_dup(para_env%group, my_mpi_world) @@ -1001,7 +977,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & ! up to now we use just one core for doing the analysis IF(para_env%mepos .EQ. para_env%num_pe-2) THEN tmc_comp_set%group_nr = para_env%mepos - (para_env%num_pe-1) ! negative - CPPostcondition(tmc_comp_set%group_nr.LT.0,cp_failure_level,routineP,error,failure) + CPPostcondition(tmc_comp_set%group_nr.LT.0,cp_failure_level,routineP,failure) IF(para_env%mepos.GE.para_env%num_pe-1-ana_on_the_fly) THEN master_ana_group = para_env%num_pe +4 master_ana_rank = -tmc_comp_set%group_nr @@ -1018,7 +994,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & ! not the unused cores IF(cc_group_rank.GE.0) THEN CALL cp_para_env_create(para_env=tmc_comp_set%para_env_sub_group,& - group=comm_tmp,error=error) + group=comm_tmp) ELSE CALL mp_comm_free(comm_tmp) ENDIF @@ -1029,7 +1005,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & ! not the unused cores IF(master_worker_rank.GE.0) THEN CALL cp_para_env_create(para_env=tmc_comp_set%para_env_m_w,& - group=comm_tmp,error=error) + group=comm_tmp) ELSE CALL mp_comm_free(comm_tmp) ENDIF @@ -1040,7 +1016,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & ! not the unused cores IF(master_first_e_worker_r.GE.0) THEN CALL cp_para_env_create(para_env=tmc_comp_set%para_env_m_first_w,& - group=comm_tmp,error=error) + group=comm_tmp) ELSE CALL mp_comm_free(comm_tmp) ENDIF @@ -1050,7 +1026,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & NULLIFY(tmc_comp_set%para_env_m_ana) IF(master_ana_rank.GE.0) THEN CALL cp_para_env_create(para_env=tmc_comp_set%para_env_m_ana,& - group=comm_tmp,error=error) + group=comm_tmp) ELSE CALL mp_comm_free(comm_tmp) ENDIF @@ -1066,7 +1042,7 @@ SUBROUTINE tmc_redistributing_cores(tmc_comp_set,para_env, ana_on_the_fly, & NULLIFY(tmc_comp_set%para_env_m_only) IF(master_ana_rank.GE.0) THEN CALL cp_para_env_create(para_env=tmc_comp_set%para_env_m_only,& - group=comm_tmp,error=error) + group=comm_tmp) ELSE CALL mp_comm_free(comm_tmp) ENDIF @@ -1078,13 +1054,10 @@ END SUBROUTINE tmc_redistributing_cores ! ***************************************************************************** !> \brief prints the most important parameters used for TMC !> \param tmc_env tructure with parameters for TMC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_print_params(tmc_env, error) + SUBROUTINE tmc_print_params(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: fmt_my = '(T2,A,"| ",A,T41,A40)', & plabel = "TMC", routineN = 'tmc_print_params', & @@ -1095,13 +1068,13 @@ SUBROUTINE tmc_print_params(tmc_env, error) LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,failure) ! only the master prints out IF(tmc_env%tmc_comp_set%group_nr == 0) THEN file_nr = tmc_env%m_env%io_unit - CPPostcondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_w),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_w),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) CALL m_flush(file_nr) WRITE ( file_nr, * ) diff --git a/src/tmc/tmc_tree_acceptance.F b/src/tmc/tmc_tree_acceptance.F index bdf7c6818f..328d557f92 100644 --- a/src/tmc/tmc_tree_acceptance.F +++ b/src/tmc/tmc_tree_acceptance.F @@ -76,20 +76,17 @@ MODULE tmc_tree_acceptance !> \param accept result (configuration accepted of rejected) !> \param rnd_nr random number for acceptance check !> \param approx_ener for NMC the approximated energies schould be used -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE acceptance_check(tree_element, parent_element, tmc_params, & temperature, diff_pot_check, accept, rnd_nr, & - approx_ener, error) + approx_ener) TYPE(tree_type), POINTER :: tree_element, parent_element TYPE(tmc_param_type), POINTER :: tmc_params REAL(KIND=dp) :: temperature LOGICAL :: diff_pot_check, accept REAL(KIND=dp) :: rnd_nr LOGICAL, OPTIONAL :: approx_ener - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'acceptance_check', & routineP = moduleN//':'//routineN @@ -100,11 +97,11 @@ SUBROUTINE acceptance_check(tree_element, parent_element, tmc_params, & parent_ener failure = .FALSE. - CPPrecondition(ASSOCIATED(tree_element),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(parent_element),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(temperature.GT.0.0_dp,cp_failure_level,routineP,error,failure) - CPPrecondition(rnd_nr.GE.0.0_dp.AND.rnd_nr.LE.1.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tree_element),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(parent_element),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(temperature.GT.0.0_dp,cp_failure_level,routineP,failure) + CPPrecondition(rnd_nr.GE.0.0_dp.AND.rnd_nr.LE.1.0_dp,cp_failure_level,routineP,failure) kB = boltzmann/joule @@ -112,7 +109,7 @@ SUBROUTINE acceptance_check(tree_element, parent_element, tmc_params, & CALL timeset(routineN,handle) IF(tmc_params%task_type.EQ.task_type_gaussian_adaptation) THEN -CPPrecondition(.FALSE. ,cp_failure_level,routineP,error,failure) +CPPrecondition(.FALSE. ,cp_failure_level,routineP,failure) !TODO CALL acc_check_gauss_adapt(f=tree_element%potential, ct=tree_element%ekin_before_md, acc=accept) !DO NOT DO RETURN END IF @@ -184,7 +181,7 @@ SUBROUTINE acceptance_check(tree_element, parent_element, tmc_params, & ! update the estimated energy acceptance probability distribution IF(diff_pot_check) THEN - CPPrecondition(ASSOCIATED(tmc_params%prior_NMC_acc),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_params%prior_NMC_acc),cp_failure_level,routineP,failure) tmc_params%prior_NMC_acc%counter = tmc_params%prior_NMC_acc%counter +1 tmc_params%prior_NMC_acc%aver = (tmc_params%prior_NMC_acc%aver*(tmc_params%prior_NMC_acc%counter-1)+& ((elem_ener-parent_ener)))/REAL(tmc_params%prior_NMC_acc%counter,KIND=dp) @@ -208,16 +205,13 @@ END SUBROUTINE acceptance_check !> \param conf2 sub tree element of higher temperature !> \param tmc_params TMC environment parameters !> \param accept acceptance of configurational change -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE swap_acceptance_check(tree_elem, conf1, conf2, tmc_params, accept, error) + SUBROUTINE swap_acceptance_check(tree_elem, conf1, conf2, tmc_params, accept) TYPE(global_tree_type), POINTER :: tree_elem TYPE(tree_type), POINTER :: conf1, conf2 TYPE(tmc_param_type), POINTER :: tmc_params LOGICAL :: accept - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'swap_acceptance_check', & routineP = moduleN//':'//routineN @@ -230,11 +224,11 @@ SUBROUTINE swap_acceptance_check(tree_elem, conf1, conf2, tmc_params, accept, er failure = .FALSE. kB = boltzmann/joule - CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(tree_elem%rnd_nr.GE.0.0_dp,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(conf1),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(conf2),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,failure) + CPPrecondition(tree_elem%rnd_nr.GE.0.0_dp,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(conf1),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(conf2),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -257,9 +251,9 @@ SUBROUTINE swap_acceptance_check(tree_elem, conf1, conf2, tmc_params, accept, er ELSE ! pt-NpT (parallel Tempering with constant pressure, temperature and num. particle) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=conf1%box_scale, & - vol=vol1, error=error) + vol=vol1) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=conf2%box_scale, & - vol=vol2, error=error) + vol=vol2) ! delta= (beta_m-beta_n)(U_n-U_m) + (beta_m*P_m-beta_n*P_n)(V_n-V_m) delta = ( 1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf)) & - 1.0_dp/(kB*tmc_params%Temp(tree_elem%mv_conf+1)) ) * & @@ -288,17 +282,14 @@ END SUBROUTINE swap_acceptance_check !> \param rnd_nr random number to check with !> \param tmc_params TMC environment parameters !> \param accept Monte Carlo move acceptance (result) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE volume_acceptance_check(parent_elem, new_elem, temperature, & - rnd_nr, tmc_params, accept, error) + rnd_nr, tmc_params, accept) TYPE(tree_type), POINTER :: parent_elem, new_elem REAL(KIND=dp) :: temperature, rnd_nr TYPE(tmc_param_type), POINTER :: tmc_params LOGICAL :: accept - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'volume_acceptance_check', & routineP = moduleN//':'//routineN @@ -310,20 +301,20 @@ SUBROUTINE volume_acceptance_check(parent_elem, new_elem, temperature, & failure = .FALSE. kB = boltzmann/joule - CPPrecondition(ASSOCIATED(parent_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(new_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(temperature.GT.0.0_dp,cp_failure_level,routineP,error,failure) - CPPrecondition(rnd_nr.GT.0.0_dp,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) - CPPrecondition(tmc_params%pressure.GE.0.0_dp,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(parent_elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(new_elem),cp_failure_level,routineP,failure) + CPPrecondition(temperature.GT.0.0_dp,cp_failure_level,routineP,failure) + CPPrecondition(rnd_nr.GT.0.0_dp,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) + CPPrecondition(tmc_params%pressure.GE.0.0_dp,cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=parent_elem%box_scale,& - vol=p_vol, error=error) + vol=p_vol) CALL get_scaled_cell(cell=tmc_params%cell, box_scale=new_elem%box_scale, & - vol=n_vol, error=error) + vol=n_vol) ! H=enthalpy, U=energy, P=pressure, V=volume, kB=Boltzmann constant, T=temperature, N=amount particle ! delta_H = delta_U + P*delta_V - kB*T*N*ln(V_n/V_p) IF(.FALSE.) THEN @@ -370,14 +361,11 @@ END SUBROUTINE volume_acceptance_check !> when ready !> \param tree_elem actual tree element with calculated energy !> \param tmc_env TMC environment parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE check_acceptance_of_depending_subtree_nodes(tree_elem, tmc_env, error) + SUBROUTINE check_acceptance_of_depending_subtree_nodes(tree_elem, tmc_env) TYPE(tree_type), POINTER :: tree_elem TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'check_acceptance_of_depending_subtree_nodes', & @@ -390,10 +378,10 @@ SUBROUTINE check_acceptance_of_depending_subtree_nodes(tree_elem, tmc_env, error failure = .FALSE. NULLIFY(parent_elem, act_elem) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(tree_elem%stat.EQ.status_calculated,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tree_elem%parent),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,failure) + CPPrecondition(tree_elem%stat.EQ.status_calculated,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tree_elem%parent),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -402,8 +390,8 @@ SUBROUTINE check_acceptance_of_depending_subtree_nodes(tree_elem, tmc_env, error ! ------------------------------------------------------ ! check this element - parent_elem => search_parent_element(act_elem, error) - CPPostconditionNoFail(.NOT.ASSOCIATED(act_elem, parent_elem),cp_failure_level,routineP,error) + parent_elem => search_parent_element(act_elem) + CPPostconditionNoFail(.NOT.ASSOCIATED(act_elem, parent_elem),cp_failure_level,routineP) ! check status of parent element SELECT CASE(parent_elem%stat) @@ -416,14 +404,14 @@ SUBROUTINE check_acceptance_of_depending_subtree_nodes(tree_elem, tmc_env, error parent_ready = .TRUE. CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& - routineP,"unknown parent element status"//cp_to_string(parent_elem%stat),error,failure) + routineP,"unknown parent element status"//cp_to_string(parent_elem%stat),failure) END SELECT ! ready ? IF(parent_ready) THEN ! acceptance check CALL check_and_change_status_of_subtree_elem(act_elem=act_elem, & - parent_elem=parent_elem, tmc_env=tmc_env,error=error) + parent_elem=parent_elem, tmc_env=tmc_env) END IF !------------------------------------------------------ ! check acc child @@ -432,7 +420,7 @@ SUBROUTINE check_acceptance_of_depending_subtree_nodes(tree_elem, tmc_env, error act_elem => tree_elem%acc IF(act_elem%stat .EQ. status_calculated) THEN CALL check_and_change_status_of_subtree_elem(act_elem=act_elem, & - parent_elem=parent_elem, tmc_env=tmc_env,error=error) + parent_elem=parent_elem, tmc_env=tmc_env) END IF !------------------------------------------------------ ! check all nacc childs @@ -441,7 +429,7 @@ SUBROUTINE check_acceptance_of_depending_subtree_nodes(tree_elem, tmc_env, error act_elem => act_elem%nacc IF(act_elem%stat .EQ. status_calculated) THEN CALL check_and_change_status_of_subtree_elem(act_elem=act_elem, & - parent_elem=parent_elem, tmc_env=tmc_env, error=error) + parent_elem=parent_elem, tmc_env=tmc_env) END IF END DO nacc_loop END IF @@ -455,14 +443,11 @@ END SUBROUTINE check_acceptance_of_depending_subtree_nodes !> \param act_elem actual tree element (new configuration) !> \param parent_elem parent tree element (old configuration) !> \param tmc_env TMC environment parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE check_and_change_status_of_subtree_elem(act_elem, parent_elem, tmc_env, error) + SUBROUTINE check_and_change_status_of_subtree_elem(act_elem, parent_elem, tmc_env) TYPE(tree_type), POINTER :: act_elem, parent_elem TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'check_and_change_status_of_subtree_elem', & @@ -479,11 +464,11 @@ SUBROUTINE check_and_change_status_of_subtree_elem(act_elem, parent_elem, tmc_en ! start the timing CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(act_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(parent_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(act_elem%stat.EQ.status_calculated,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(act_elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(parent_elem),cp_failure_level,routineP,failure) + CPPrecondition(act_elem%stat.EQ.status_calculated,cp_failure_level,routineP,failure) flag = .FALSE. @@ -491,15 +476,15 @@ SUBROUTINE check_and_change_status_of_subtree_elem(act_elem, parent_elem, tmc_en ! check for all global tree elements refering to this subtree element ! same subtree element can be accepted at a certain temperature and rejected at another one DO WHILE(ASSOCIATED(tmp_gt_list_ptr)) - CPPrecondition(tmp_gt_list_ptr%gt_elem%stat.NE.status_accepted_result,cp_failure_level,routineP,error,failure) - CPPrecondition(tmp_gt_list_ptr%gt_elem%stat.NE.status_rejected_result,cp_failure_level,routineP,error,failure) + CPPrecondition(tmp_gt_list_ptr%gt_elem%stat.NE.status_accepted_result,cp_failure_level,routineP,failure) + CPPrecondition(tmp_gt_list_ptr%gt_elem%stat.NE.status_rejected_result,cp_failure_level,routineP,failure) CALL check_elements(gt_act_elem=tmp_gt_list_ptr%gt_elem, tmc_env=tmc_env,& - check_done=flag, result_acc=result_acc, error=error) + check_done=flag, result_acc=result_acc) IF(flag)THEN ! probability update CALL prob_update(move_types=tmc_env%params%move_types, elem=act_elem, & - acc=result_acc, prob_opt=tmc_env%params%esimate_acc_prob, error=error) + acc=result_acc, prob_opt=tmc_env%params%esimate_acc_prob) ! change status ! accepted case: delete (and cancel) not accepted branch @@ -509,7 +494,7 @@ SUBROUTINE check_and_change_status_of_subtree_elem(act_elem, parent_elem, tmc_en tmp_gt_ptr => tmp_gt_list_ptr%gt_elem%nacc CALL remove_unused_g_tree(begin_ptr=tmp_gt_ptr, & end_ptr=tmp_gt_list_ptr%gt_elem, removed=flag, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) END IF ELSE ! not accepted case: delete (and cancel) accepted branch @@ -518,13 +503,13 @@ SUBROUTINE check_and_change_status_of_subtree_elem(act_elem, parent_elem, tmc_en tmp_gt_ptr => tmp_gt_list_ptr%gt_elem%acc CALL remove_unused_g_tree(begin_ptr=tmp_gt_ptr, & end_ptr=tmp_gt_list_ptr%gt_elem, removed=flag, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) END IF END IF IF(tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot_color(gt_tree_element=tmp_gt_list_ptr%gt_elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF tmp_gt_list_ptr => tmp_gt_list_ptr%next END DO @@ -539,15 +524,12 @@ END SUBROUTINE check_and_change_status_of_subtree_elem !> should change status !> \param stat the status of the global tree element !> \param tmc_params TMC emvironment parameters for drawing -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE subtree_configuration_stat_change(gt_ptr, stat, tmc_params, error) + SUBROUTINE subtree_configuration_stat_change(gt_ptr, stat, tmc_params) TYPE(global_tree_type), POINTER :: gt_ptr INTEGER :: stat TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'subtree_configuration_stat_change', & @@ -560,8 +542,8 @@ SUBROUTINE subtree_configuration_stat_change(gt_ptr, stat, tmc_params, error) failure = .FALSE. NULLIFY(ptr) - CPPrecondition(ASSOCIATED(gt_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -582,12 +564,11 @@ SUBROUTINE subtree_configuration_stat_change(gt_ptr, stat, tmc_params, error) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown global tree status"//& - cp_to_string(stat),error,failure) + cp_to_string(stat),failure) END SELECT IF(tmc_params%DRAW_TREE) & - CALL create_dot_color(tree_element=ptr, tmc_params=tmc_params, & - error=error) + CALL create_dot_color(tree_element=ptr, tmc_params=tmc_params) END IF ! end the timing @@ -598,14 +579,11 @@ END SUBROUTINE subtree_configuration_stat_change !> \brief checks if the element is ready for an acceptance check !> \param elem sub tree element !> \param ready return value -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE elem_ready_to_check(elem, ready, error) + SUBROUTINE elem_ready_to_check(elem, ready) TYPE(tree_type), POINTER :: elem LOGICAL :: ready - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'elem_ready_to_check', & routineP = moduleN//':'//routineN @@ -614,7 +592,7 @@ SUBROUTINE elem_ready_to_check(elem, ready, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -631,7 +609,7 @@ SUBROUTINE elem_ready_to_check(elem, ready, error) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"status of actual tree node is unknown"& - //cp_to_string(elem%stat),error,failure) + //cp_to_string(elem%stat),failure) END SELECT ! end the timing CALL timestop(handle) @@ -643,15 +621,12 @@ END SUBROUTINE elem_ready_to_check !> \param tmc_env TMC environment !> \param check_done successful checked? (result) !> \param result_acc checked configuration accepted? (result) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE check_elements(gt_act_elem, tmc_env, check_done, result_acc, error) + SUBROUTINE check_elements(gt_act_elem, tmc_env, check_done, result_acc) TYPE(global_tree_type), POINTER :: gt_act_elem TYPE(tmc_env_type), POINTER :: tmc_env LOGICAL :: check_done, result_acc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'check_elements', & routineP = moduleN//':'//routineN @@ -664,9 +639,9 @@ SUBROUTINE check_elements(gt_act_elem, tmc_env, check_done, result_acc, error) NULLIFY(act_element, tmp_element) check_done = .FALSE. - CPPrecondition(ASSOCIATED(gt_act_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_act_elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -683,7 +658,7 @@ SUBROUTINE check_elements(gt_act_elem, tmc_env, check_done, result_acc, error) ELSE CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"undefinite status of already checked elements:"& - //cp_to_string(gt_act_elem%stat),error,failure) + //cp_to_string(gt_act_elem%stat),failure) END IF CASE DEFAULT END SELECT @@ -692,13 +667,13 @@ SUBROUTINE check_elements(gt_act_elem, tmc_env, check_done, result_acc, error) !==================================================================================== ! get elements related to global tree element to check CALL get_subtree_elements_to_check(gt_act_elem=gt_act_elem, elem1=act_element, & - elem2=tmp_element, error=error) - CPPostcondition(ASSOCIATED(act_element),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tmp_element),cp_failure_level,routineP,error,failure) + elem2=tmp_element) + CPPostcondition(ASSOCIATED(act_element),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tmp_element),cp_failure_level,routineP,failure) ! check status of both elements (if they are already calculated and hence ready to check) - CALL elem_ready_to_check(elem=act_element, ready=act_ready, error=error) - CALL elem_ready_to_check(elem=tmp_element, ready=tmp_ready, error=error) + CALL elem_ready_to_check(elem=act_element, ready=act_ready) + CALL elem_ready_to_check(elem=tmp_element, ready=tmp_ready) ! both ready ? check IF(act_ready .AND. tmp_ready) THEN @@ -706,26 +681,25 @@ SUBROUTINE check_elements(gt_act_elem, tmc_env, check_done, result_acc, error) IF(gt_act_elem%swaped)THEN CALL swap_acceptance_check(tree_elem=gt_act_elem, conf1=act_element, & conf2=tmp_element, tmc_params=tmc_env%params, & - accept=result_acc, error=error) + accept=result_acc) ! volume move check ELSE IF(act_element%move_type.EQ.mv_type_volume_move) THEN CALL volume_acceptance_check(parent_elem=tmp_element, new_elem=act_element, & temperature=tmc_env%params%Temp(gt_act_elem%mv_conf),& rnd_nr=gt_act_elem%rnd_nr, & - tmc_params=tmc_env%params, accept=result_acc, & - error=error) + tmc_params=tmc_env%params, accept=result_acc) ELSE IF(tmc_env%m_env%temp_decrease.NE.1.0_dp)THEN CALL acceptance_check(tree_element=act_element, parent_element=tmp_element, & tmc_params=tmc_env%params, temperature=gt_act_elem%Temp, & diff_pot_check=.TRUE., accept=result_acc, & - rnd_nr=gt_act_elem%rnd_nr, error=error) + rnd_nr=gt_act_elem%rnd_nr) ELSE CALL acceptance_check(tree_element=act_element, parent_element=tmp_element, & tmc_params=tmc_env%params, & temperature=tmc_env%params%Temp(gt_act_elem%mv_conf), & diff_pot_check=.TRUE., accept=result_acc, & - rnd_nr=gt_act_elem%rnd_nr, error=error) + rnd_nr=gt_act_elem%rnd_nr) END IF END IF check_done = .TRUE. @@ -743,7 +717,7 @@ SUBROUTINE check_elements(gt_act_elem, tmc_env, check_done, result_acc, error) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"status of actual checked node is unknown"& - //cp_to_string(gt_act_elem%stat),error,failure) + //cp_to_string(gt_act_elem%stat),failure) END SELECT END IF END IF @@ -757,17 +731,13 @@ END SUBROUTINE check_elements !> \param tmc_env TMC environment !> \param result_acc checked configuration accepted? (result) !> \param something_updated ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \param !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE tree_update(tmc_env, result_acc, something_updated, & - error) + SUBROUTINE tree_update(tmc_env, result_acc, something_updated) TYPE(tmc_env_type), POINTER :: tmc_env LOGICAL :: result_acc, something_updated - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tree_update', & routineP = moduleN//':'//routineN @@ -780,7 +750,7 @@ SUBROUTINE tree_update(tmc_env, result_acc, something_updated, & failure = .FALSE. NULLIFY(gt_act_elem, tmp_element, act_element) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -792,19 +762,18 @@ SUBROUTINE tree_update(tmc_env, result_acc, something_updated, & search_calculated_element_loop: DO NULLIFY(act_element, tmp_element) ! search for element to check - CALL search_next_gt_element_to_check(ptr=gt_act_elem, found=found, error=error) + CALL search_next_gt_element_to_check(ptr=gt_act_elem, found=found) IF(.NOT.found) EXIT search_calculated_element_loop ! check the elements status end, if possible, do acceptance check CALL check_elements(gt_act_elem=gt_act_elem, tmc_env=tmc_env, & - check_done=found, result_acc=result_acc,error=error) + check_done=found, result_acc=result_acc) ! if check was not possible, update the status of the global tree element and return IF(.NOT.found) EXIT search_calculated_element_loop ! get elements related to global tree element, which were checked CALL get_subtree_elements_to_check(gt_act_elem=gt_act_elem, & - elem1=act_element, elem2=tmp_element,& - error=error) + elem1=act_element, elem2=tmp_element) !======================================================================== !-- set result counters @@ -878,44 +847,39 @@ SUBROUTINE tree_update(tmc_env, result_acc, something_updated, & IF(.NOT.gt_act_elem%swaped) & CALL subtree_configuration_stat_change(gt_ptr=gt_act_elem, & stat=gt_act_elem%stat, & - tmc_params=tmc_env%params, & - error=error) + tmc_params=tmc_env%params) IF(tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot_color(gt_tree_element=gt_act_elem, & - tmc_params=tmc_env%params, & - error=error) + tmc_params=tmc_env%params) ! probability update CALL prob_update(move_types=tmc_env%params%move_types,& pt_el=gt_act_elem, & - prob_opt=tmc_env%params%esimate_acc_prob, & - error=error) + prob_opt=tmc_env%params%esimate_acc_prob) !writes only different configurations with repetition file if possible CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & result_count=tmc_env%m_env%result_count,& conf_updated=gt_act_elem%mv_conf, accepted=result_acc, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) IF(gt_act_elem%swaped)& CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & result_count=tmc_env%m_env%result_count,& conf_updated=gt_act_elem%mv_conf+1, accepted=result_acc, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) ! save for analysis IF(tmc_env%tmc_comp_set%para_env_m_ana%num_pe.GT.1.AND.result_acc) THEN CALL add_to_list(elem=tmc_env%m_env%result_list(gt_act_elem%mv_conf)%elem, & list=tmc_env%m_env%analysis_list, & temp_ind=gt_act_elem%mv_conf, & - nr=tmc_env%m_env%result_count(gt_act_elem%mv_conf),& - error=error) + nr=tmc_env%m_env%result_count(gt_act_elem%mv_conf)) IF(gt_act_elem%swaped) THEN CALL add_to_list(elem=tmc_env%m_env%result_list(gt_act_elem%mv_conf+1)%elem, & list=tmc_env%m_env%analysis_list, & temp_ind=gt_act_elem%mv_conf+1, & - nr=tmc_env%m_env%result_count(gt_act_elem%mv_conf+1),& - error=error) + nr=tmc_env%m_env%result_count(gt_act_elem%mv_conf+1)) END IF END IF END DO search_calculated_element_loop @@ -933,14 +897,11 @@ END SUBROUTINE tree_update !> \brief checks if element is ready for accaptance probability update !> checks status and the amount of already received intermediate energies !> \param elem sub tree element to update -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval ready return value !> \author Mandes 12.2012 ! ***************************************************************************** - FUNCTION ready_for_update_acc_prob(elem, error) RESULT(ready) + FUNCTION ready_for_update_acc_prob(elem) RESULT(ready) TYPE(tree_type), POINTER :: elem - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: ready CHARACTER(LEN=*), PARAMETER :: routineN = 'ready_for_update_acc_prob', & @@ -949,7 +910,7 @@ FUNCTION ready_for_update_acc_prob(elem, error) RESULT(ready) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) ready = .FALSE. IF((elem%scf_energies_count.GE.4)& .AND.(elem%stat.NE.status_deleted).AND.(elem%stat.NE.status_deleted_result)& @@ -963,14 +924,11 @@ END FUNCTION ready_for_update_acc_prob !> global tree elements (pt references) !> \param tree_elem sub tree element to update !> \param tmc_env TMC environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE check_elements_for_acc_prob_update(tree_elem, tmc_env, error) + SUBROUTINE check_elements_for_acc_prob_update(tree_elem, tmc_env) TYPE(tree_type), POINTER :: tree_elem TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'check_elements_for_acc_prob_update', & @@ -983,8 +941,8 @@ SUBROUTINE check_elements_for_acc_prob_update(tree_elem, tmc_env, error) failure = .FALSE. NULLIFY(parent_elem, act_elem) - CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing @@ -993,16 +951,16 @@ SUBROUTINE check_elements_for_acc_prob_update(tree_elem, tmc_env, error) act_elem => tree_elem !-- nothing to do if option is disabled or element not ready IF(tmc_env%params%esimate_acc_prob.AND.& - ready_for_update_acc_prob(act_elem,error=error))THEN + ready_for_update_acc_prob(act_elem))THEN ! ------------------------------------------------------ ! check this element ! for usual moves and swapping ! get parent subtree elment for case of not swapped configurations - parent_elem => search_parent_element(act_elem, error=error) + parent_elem => search_parent_element(act_elem) ! update the prob of accaptance CALL update_prob_gt_node_list(reference_list=act_elem%gt_nodes_references, & act_elem=act_elem, parent_elem=parent_elem, act_parent=.TRUE., & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) !------------------------------------------------------ ! check the childs of this element @@ -1014,7 +972,7 @@ SUBROUTINE check_elements_for_acc_prob_update(tree_elem, tmc_env, error) ! update the prob of accaptance CALL update_prob_gt_node_list(reference_list=act_elem%gt_nodes_references, & act_elem=act_elem, parent_elem=parent_elem, act_parent=.FALSE.,& - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) END IF ! check all NACC childs of next accepted one @@ -1023,7 +981,7 @@ SUBROUTINE check_elements_for_acc_prob_update(tree_elem, tmc_env, error) act_elem => act_elem%nacc CALL update_prob_gt_node_list(reference_list=act_elem%gt_nodes_references,& act_elem=act_elem, parent_elem=parent_elem, act_parent=.FALSE.,& - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) END DO nacc_loop END IF ! end the timing @@ -1040,16 +998,13 @@ END SUBROUTINE check_elements_for_acc_prob_update !> \param act_parent flag if updated element is the actual (TRUE) or !> the parent (FALSE) element !> \param tmc_env TMC environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE update_prob_gt_node_list(reference_list, act_elem, parent_elem, act_parent, tmc_env, error) + SUBROUTINE update_prob_gt_node_list(reference_list, act_elem, parent_elem, act_parent, tmc_env) TYPE(gt_elem_list_type), POINTER :: reference_list TYPE(tree_type), POINTER :: act_elem, parent_elem LOGICAL :: act_parent TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'update_prob_gt_node_list', & routineP = moduleN//':'//routineN @@ -1067,15 +1022,15 @@ SUBROUTINE update_prob_gt_node_list(reference_list, act_elem, parent_elem, act_p IF(.NOT.ASSOCIATED(reference_list)) RETURN ! could be canceled already - CPPrecondition(ASSOCIATED(reference_list%gt_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(act_elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(parent_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(reference_list%gt_elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(act_elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(parent_elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) ! check if element is ready - IF(ready_for_update_acc_prob(act_elem, error)) THEN + IF(ready_for_update_acc_prob(act_elem)) THEN ! set the number of integration steps used for 3 point approximation ! of the exact energy, using the sub step energies ! still fixed value @@ -1089,10 +1044,10 @@ SUBROUTINE update_prob_gt_node_list(reference_list, act_elem, parent_elem, act_p NULLIFY(tmp_elem,tmp_parent_elem) ! in case of swap use the other swaped configuration as related one CALL get_subtree_elements_to_check(gt_act_elem=tmp_pt_ptr%gt_elem, & - elem1=tmp_elem, elem2=tmp_parent_elem, error=error) + elem1=tmp_elem, elem2=tmp_parent_elem) ! NOT if parent is the updated one, and check for correct elements ready IF(act_parent .AND. ASSOCIATED(act_elem, tmp_elem) .AND. & - ready_for_update_acc_prob(elem=tmp_parent_elem, error=error)) THEN + ready_for_update_acc_prob(elem=tmp_parent_elem)) THEN ! using ln(rnd)/-(beta_i-beta_j) < U_j-U_i) tmp_prob = compute_estimated_prob(elem_old=tmp_parent_elem, & elem_new=act_elem, & @@ -1100,20 +1055,20 @@ SUBROUTINE update_prob_gt_node_list(reference_list, act_elem, parent_elem, act_p rnd_nr=tmp_pt_ptr%gt_elem%rnd_nr, & beta=1.0_dp/(kB*(tmc_env%params%Temp(tmp_pt_ptr%gt_elem%mv_conf)-& tmc_env%params%Temp(tmp_pt_ptr%gt_elem%mv_conf+1))), & - tmc_params=tmc_env%params,error=error) + tmc_params=tmc_env%params) ELSE tmp_pt_ptr => tmp_pt_ptr%next CYCLE reference_loop END IF ELSE ! if no swap, use the parent configuration as related one - IF(ready_for_update_acc_prob(parent_elem, error=error)) THEN + IF(ready_for_update_acc_prob(parent_elem)) THEN tmp_prob = compute_estimated_prob(elem_old=parent_elem, & elem_new=act_elem, & E_classical_diff=act_elem%e_pot_approx-parent_elem%e_pot_approx, & rnd_nr=tmp_pt_ptr%gt_elem%rnd_nr, & beta=1.0_dp/(kB*tmc_env%params%Temp(tmp_pt_ptr%gt_elem%mv_conf)), & - tmc_params=tmc_env%params,error=error) + tmc_params=tmc_env%params) END IF END IF !successfull probability update @@ -1122,7 +1077,7 @@ SUBROUTINE update_prob_gt_node_list(reference_list, act_elem, parent_elem, act_p !-- speculative canceling for the related direction IF(tmc_env%params%SPECULATIVE_CANCELING) & CALL search_canceling_elements(pt_elem_in=tmp_pt_ptr%gt_elem, & - prob=tmp_pt_ptr%gt_elem%prob_acc, tmc_env=tmc_env, error=error) + prob=tmp_pt_ptr%gt_elem%prob_acc, tmc_env=tmc_env) END IF ! get next related global tree pointer diff --git a/src/tmc/tmc_tree_build.F b/src/tmc/tmc_tree_build.F index 58f5808033..4aa13c9c6c 100644 --- a/src/tmc/tmc_tree_build.F +++ b/src/tmc/tmc_tree_build.F @@ -100,14 +100,11 @@ MODULE tmc_tree_build !> \brief allocates an elements of the global element structure !> \param next_el ... !> \param nr_temp ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE allocate_new_global_tree_node(next_el, nr_temp, error) + SUBROUTINE allocate_new_global_tree_node(next_el, nr_temp) TYPE(global_tree_type), POINTER :: next_el INTEGER :: nr_temp - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'allocate_new_global_tree_node', & @@ -117,7 +114,7 @@ SUBROUTINE allocate_new_global_tree_node(next_el, nr_temp, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(next_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(next_el),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -141,13 +138,10 @@ END SUBROUTINE allocate_new_global_tree_node ! ***************************************************************************** !> \brief deallocates an elements of the global element structure !> \param gt_elem ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE deallocate_global_tree_node(gt_elem, error) + SUBROUTINE deallocate_global_tree_node(gt_elem) TYPE(global_tree_type), POINTER :: gt_elem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_global_tree_node', & routineP = moduleN//':'//routineN @@ -156,7 +150,7 @@ SUBROUTINE deallocate_global_tree_node(gt_elem, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(gt_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -175,15 +169,12 @@ END SUBROUTINE deallocate_global_tree_node !> \param tmc_params structure for storing all (global) parameters !> \param next_el ... !> \param nr_dim ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE allocate_new_sub_tree_node(tmc_params, next_el, nr_dim, error) + SUBROUTINE allocate_new_sub_tree_node(tmc_params, next_el, nr_dim) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(tree_type), POINTER :: next_el INTEGER :: nr_dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_new_sub_tree_node', & routineP = moduleN//':'//routineN @@ -192,7 +183,7 @@ SUBROUTINE allocate_new_sub_tree_node(tmc_params, next_el, nr_dim, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(next_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(next_el),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -241,13 +232,10 @@ END SUBROUTINE allocate_new_sub_tree_node ! ***************************************************************************** !> \brief deallocates an elements of the subtree element structure !> \param tree_elem ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE deallocate_sub_tree_node(tree_elem, error) + SUBROUTINE deallocate_sub_tree_node(tree_elem) TYPE(tree_type), POINTER :: tree_elem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_sub_tree_node', & routineP = moduleN//':'//routineN @@ -256,7 +244,7 @@ SUBROUTINE deallocate_sub_tree_node(tree_elem, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tree_elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -264,7 +252,7 @@ SUBROUTINE deallocate_sub_tree_node(tree_elem, error) ! reference handling ! should be not necessary, subtree element should be only deallocated, ! if no global tree element points to anymore - CALL remove_subtree_element_of_all_references(ptr=tree_elem, error=error) + CALL remove_subtree_element_of_all_references(ptr=tree_elem) IF(ASSOCIATED(tree_elem%box_scale)) DEALLOCATE(tree_elem%box_scale) IF(ASSOCIATED(tree_elem%frc)) DEALLOCATE(tree_elem%frc) @@ -291,16 +279,13 @@ END SUBROUTINE deallocate_sub_tree_node !> \param tmc_env structure for storing all (global) parameters !> \param job_counts ... !> \param worker_timings ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings, error) + SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings) TYPE(tree_type), POINTER :: start_elem TYPE(tmc_env_type), POINTER :: tmc_env INTEGER, DIMENSION(:) :: job_counts REAL(KIND=dp), DIMENSION(4) :: worker_timings - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_tree_mod', & routineP = moduleN//':'//routineN @@ -310,35 +295,35 @@ SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings, error) NULLIFY(global_tree) - CPPreconditionNoFail(ASSOCIATED(start_elem),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(tmc_env),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(start_elem),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(tmc_env),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP) ! start the timing CALL timeset(routineN,handle) ! allocate everything CALL allocate_new_global_tree_node(next_el=tmc_env%m_env%gt_act, & - nr_temp=tmc_env%params%nr_temp, error=error) + nr_temp=tmc_env%params%nr_temp) ! use initial/default values CALL get_rng_stream(rng_stream=tmc_env%rng_stream, & bg=tmc_env%m_env%gt_act%rng_seed(:,:,1), & cg=tmc_env%m_env%gt_act%rng_seed(:,:,2), & - ig=tmc_env%m_env%gt_act%rng_seed(:,:,3), error=error) + ig=tmc_env%m_env%gt_act%rng_seed(:,:,3)) global_tree => tmc_env%m_env%gt_act tmc_env%m_env%gt_head => tmc_env%m_env%gt_act ! set global random seed CALL set_rng_stream(rng_stream=tmc_env%rng_stream, bg=global_tree%rng_seed(:,:,1), & - cg=global_tree%rng_seed(:,:,2), ig=global_tree%rng_seed(:,:,3), error=error) - global_tree%rnd_nr = next_random_number(tmc_env%rng_stream, error=error) + cg=global_tree%rng_seed(:,:,2), ig=global_tree%rng_seed(:,:,3)) + global_tree%rnd_nr = next_random_number(tmc_env%rng_stream) !-- SUBTREES: set initial values DO i=1, SIZE(global_tree%conf) CALL allocate_new_sub_tree_node(tmc_env%params, next_el=global_tree%conf(i)%elem, & - nr_dim=SIZE(start_elem%pos), error=error) + nr_dim=SIZE(start_elem%pos)) global_tree%conf(i)%elem%move_type = 0 global_tree%conf(i)%elem%next_elem_nr => tmc_env%m_env%tree_node_count(i) global_tree%conf(i)%elem%parent => NULL() @@ -360,10 +345,10 @@ SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings, error) END IF !-- different random seeds for every subtree - CALL reset_to_next_rng_substream(tmc_env%rng_stream, error=error) + CALL reset_to_next_rng_substream(tmc_env%rng_stream) CALL get_rng_stream(rng_stream=tmc_env%rng_stream, bg=global_tree%conf(i)%elem%rng_seed(:,:,1), & cg=global_tree%conf(i)%elem%rng_seed(:,:,2), & - ig=global_tree%conf(i)%elem%rng_seed(:,:,3), error=error) + ig=global_tree%conf(i)%elem%rng_seed(:,:,3)) !-- gaussian distributed velocities !-- calculating the kinetic energy of the initial configuration velocity @@ -372,9 +357,9 @@ SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings, error) CALL init_vel(vel=global_tree%conf(i)%elem%vel, atoms=tmc_env%params%atoms, & temerature=tmc_env%params%Temp(i), & rng_stream=tmc_env%rng_stream, & - rnd_seed=global_tree%conf(i)%elem%rng_seed, error=error) + rnd_seed=global_tree%conf(i)%elem%rng_seed) global_tree%conf(i)%elem%ekin = calc_e_kin(vel=global_tree%conf(i)%elem%vel, & - atoms=tmc_env%params%atoms, error=error) + atoms=tmc_env%params%atoms) END IF END IF @@ -405,14 +390,13 @@ SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings, error) cp_failure_level,cp_assertion_failed,routineP,& "there is no parallel tempering implementation for simulated annealing implemented "//& "(just one Temp per global tree element.",& - error, only_ionode=.TRUE.) + only_ionode=.TRUE.) !-- IF program is restarted, read restart file IF(tmc_env%m_env%restart_in_file_name.NE."") THEN CALL read_restart_file(tmc_env=tmc_env, job_counts=job_counts, & timings=worker_timings, & - file_name=tmc_env%m_env%restart_in_file_name, & - error=error) + file_name=tmc_env%m_env%restart_in_file_name) tmc_env%m_env%tree_node_count(0) = global_tree%nr @@ -436,14 +420,14 @@ SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings, error) END IF !-- set reference of global tree node - CALL add_to_references(gt_elem=global_tree, error=error) + CALL add_to_references(gt_elem=global_tree) !-- draw the first global tree node IF(tmc_env%params%DRAW_TREE)THEN CALL create_global_tree_dot(new_element=global_tree, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CALL create_global_tree_dot_color(gt_tree_element=global_tree, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF ! end the timing @@ -456,14 +440,11 @@ END SUBROUTINE init_tree_mod !> \param gt_tree_ptr global tree head (initial configuration) !> \param tmc_env master environment for restart !> (if restart the subtree heads are not equal), result counts and lists -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE finalize_init(gt_tree_ptr, tmc_env, error) + SUBROUTINE finalize_init(gt_tree_ptr, tmc_env) TYPE(global_tree_type), POINTER :: gt_tree_ptr TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'finalize_init', & routineP = moduleN//':'//routineN @@ -472,11 +453,11 @@ SUBROUTINE finalize_init(gt_tree_ptr, tmc_env, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(gt_tree_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(gt_tree_ptr%parent),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_tree_ptr),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(gt_tree_ptr%parent),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -499,19 +480,19 @@ SUBROUTINE finalize_init(gt_tree_ptr, tmc_env, error) CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & result_count=tmc_env%m_env%result_count,& conf_updated=i, accepted=.TRUE., & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) ! save for analysis IF(tmc_env%tmc_comp_set%para_env_m_ana%num_pe.GT.1) THEN CALL add_to_list(elem=tmc_env%m_env%result_list(i)%elem, & list=tmc_env%m_env%analysis_list, & nr=tmc_env%m_env%result_count(i), & - temp_ind=i, error=error) + temp_ind=i) END IF END DO !CALL write_result_list_element(result_list=tmc_env%m_env%result_list, & ! result_count=tmc_env%m_env%result_count,& ! conf_updated=0, accepted=.TRUE., & - ! tmc_params=tmc_env%params, error=error) + ! tmc_params=tmc_env%params) END IF ! end the timing CALL timestop(handle) @@ -526,18 +507,15 @@ END SUBROUTINE finalize_init !> \param stat return status value !> \param new_elem return gt element !> \param reactivation_cc_count counting the reactivation of subtree elements -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & - reactivation_cc_count, error) + reactivation_cc_count) TYPE(tmc_env_type), POINTER :: tmc_env INTEGER, INTENT(OUT) :: stat TYPE(global_tree_type), INTENT(OUT), & POINTER :: new_elem INTEGER :: reactivation_cc_count - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_new_gt_tree_node', & routineP = moduleN//':'//routineN @@ -551,10 +529,10 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & failure = .FALSE. NULLIFY(tmp_elem, tree_elem, new_elem) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -565,7 +543,7 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & n_acc = .TRUE. !-- search most probable end to create new element - CALL most_prob_end(global_tree_elem=tmp_elem, prob=prob, n_acc=n_acc, error=error) + CALL most_prob_end(global_tree_elem=tmp_elem, prob=prob, n_acc=n_acc) keep_on = .TRUE. IF(ASSOCIATED(tmp_elem).AND.(EXP(prob).LT.1.0E-10)) THEN @@ -595,13 +573,13 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & new_elem => tmp_elem%nacc ! check for existing subtree element - CPPrecondition(ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem),cp_failure_level,routineP,failure) SELECT CASE(new_elem%conf(new_elem%mv_conf)%elem%stat) CASE(status_cancel_nmc,status_cancel_ener,status_canceled_nmc,& status_canceled_ener) ! reactivating subtree element ! (but global tree element already exist) - CALL add_to_references(gt_elem=new_elem, error=error) + CALL add_to_references(gt_elem=new_elem) reactivation_cc_count = reactivation_cc_count+1 CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& @@ -611,7 +589,7 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%nr)//& " with stat "//& cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat),& - error,failure) + failure) END SELECT ! change the status of the reactivated subtree element ! move is only done by the master, @@ -626,7 +604,7 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & status_canceled_nmc, cp_warning_level,cp_assertion_failed,& routineP,"reactivating tree element with wrong status"//& cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat),& - error,failure) + failure) new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_NMC_steps !IF(DEBUG.GE.1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", & @@ -638,18 +616,17 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & routineP,"reactivated st element has no NMC or MD move type, "//& "but seems to be canceled. Move type"//& cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%move_type), & - error,failure) + failure) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"Unknown move type while reactivating subtree element.",& - error,failure) + failure) END SELECT ELSE !-- if end is found (NOT already existing element), create new elem at the end and if nessecarry new subtree element ! set initial values CALL allocate_new_global_tree_node(next_el=new_elem, & - nr_temp=tmc_env%params%nr_temp, & - error=error) + nr_temp=tmc_env%params%nr_temp) tmc_env%m_env%tree_node_count(0) = tmc_env%m_env%tree_node_count(0) +1 new_elem%nr = tmc_env%m_env%tree_node_count(0) @@ -659,13 +636,13 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & CALL cp_assert(.NOT.ASSOCIATED(tmp_elem%acc),cp_failure_level,& cp_assertion_failed, routineP,& "creating new subtree element on an occupied acc branch",& - error,failure) + failure) tmp_elem%acc => new_elem ELSE CALL cp_assert(.NOT.ASSOCIATED(tmp_elem%nacc),cp_failure_level,& cp_assertion_failed, routineP,& "creating new subtree element on an occupied nacc branch", & - error,failure) + failure) tmp_elem%nacc => new_elem END IF new_elem%parent => tmp_elem @@ -703,11 +680,10 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & CALL set_rng_stream(rng_stream=tmc_env%rng_stream, & bg=new_elem%parent%rng_seed(:,:,1), & cg=new_elem%parent%rng_seed(:,:,2), & - ig=new_elem%parent%rng_seed(:,:,3), & - error=error) - CALL reset_to_next_rng_substream(tmc_env%rng_stream, error) + ig=new_elem%parent%rng_seed(:,:,3)) + CALL reset_to_next_rng_substream(tmc_env%rng_stream) ! the random number for acceptance check - new_elem%rnd_nr = next_random_number(tmc_env%rng_stream, error=error) + new_elem%rnd_nr = next_random_number(tmc_env%rng_stream) ! the next configuration index to move !rnd = next_random_number(tmc_env%rng_stream) @@ -721,13 +697,12 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & IF(n_acc) new_elem%Temp = tmp_elem%Temp * (1-tmc_env%m_env%temp_decrease) !-- rnd for swap - rnd = next_random_number(tmc_env%rng_stream, error=error) - rnd2= next_random_number(tmc_env%rng_stream, error=error) + rnd = next_random_number(tmc_env%rng_stream) + rnd2= next_random_number(tmc_env%rng_stream) CALL get_rng_stream(rng_stream=tmc_env%rng_stream, & bg=new_elem%rng_seed(:,:,1), & cg=new_elem%rng_seed(:,:,2), & - ig=new_elem%rng_seed(:,:,3), & - error=error) + ig=new_elem%rng_seed(:,:,3)) ! swap moves are not part of the subtree structure, ! because exisiting elements from DIFFERENT subtrees are swaped @@ -750,10 +725,10 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & new_elem%swaped = .TRUE. new_elem%prob_acc = tmc_env%params%move_types%acc_prob(& mv_type_swap_conf,new_elem%mv_conf) - CALL add_to_references(gt_elem=new_elem, error=error) + CALL add_to_references(gt_elem=new_elem) IF(tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot(new_element=new_elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) ! nothing to do for the workers stat = status_calculated keep_on = .FALSE. @@ -773,11 +748,11 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & ELSE !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) IF(tmc_env%params%DRAW_TREE) & CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem,& conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF ELSE !-- check if child element in REJECTED direction already exist @@ -788,11 +763,11 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & ELSE !-- if not exist create new subtree element CALL create_new_subtree_node(act_gt_el=new_elem, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) IF(tmc_env%params%DRAW_TREE) & CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem,& conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF END IF ! set approximate probability of acceptance @@ -801,10 +776,10 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & new_elem%prob_acc = tmc_env%params%move_types%acc_prob(& new_elem%conf(new_elem%mv_conf)%elem%move_type, new_elem%mv_conf) ! add refence and dot - CALL add_to_references(gt_elem=new_elem, error=error) + CALL add_to_references(gt_elem=new_elem) IF(tmc_env%params%DRAW_TREE) & CALL create_global_tree_dot(new_element=new_elem, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF ! swap or no swap END IF ! global tree node already exist. Hence the Subtree node also (it is speculative canceled) END IF ! keep on (checking and creating) @@ -817,7 +792,7 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & new_elem%stat.NE.status_rejected_result, & cp_failure_level, cp_assertion_failed, routineP,& "selected existing RESULT gt node",& - error,failure) + failure) !-- set status of global tree element for decision in master routine SELECT CASE(new_elem%conf(new_elem%mv_conf)%elem%stat) CASE(status_rejected_result,status_rejected,status_accepted,& @@ -827,14 +802,14 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF(tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CASE(status_calc_approx_ener) new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF(stat.NE.status_calculated)THEN stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF(tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF CASE(status_calculate_MD,status_calculate_energy,& status_calculate_NMC_steps, status_created) @@ -844,7 +819,7 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & stat = new_elem%conf(new_elem%mv_conf)%elem%stat IF(tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF CASE(status_cancel_ener,status_canceled_ener) ! configuration is already created, @@ -856,7 +831,7 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & stat = status_calculated IF(tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CASE(status_cancel_nmc, status_canceled_nmc) ! reactivation canceled element (but with new global tree element) new_elem%conf(new_elem%mv_conf)%elem%stat = & @@ -866,14 +841,14 @@ SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, & reactivation_cc_count = reactivation_cc_count+1 IF(tmc_env%params%DRAW_TREE) & CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP, "unknown stat "//& cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat)//& "of subtree element "//& "for creating new gt element", & - error,failure) + failure) END SELECT ! set stat TMC_STATUS_WAIT_FOR_NEW_TASK if no new calculation neccessary @@ -890,14 +865,11 @@ END SUBROUTINE create_new_gt_tree_node !> \brief create new subtree element using pointer of global tree !> \param act_gt_el global tree element !> \param tmc_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) + SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env) TYPE(global_tree_type), POINTER :: act_gt_el TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'create_new_subtree_node', & routineP = moduleN//':'//routineN @@ -911,18 +883,17 @@ SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) failure = .FALSE. NULLIFY(new_elem, parent_elem) - CPPrecondition(ASSOCIATED(act_gt_el),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(act_gt_el%conf(act_gt_el%mv_conf)%elem),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(act_gt_el),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(act_gt_el%conf(act_gt_el%mv_conf)%elem),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) conf = act_gt_el%mv_conf CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params,& - next_el=new_elem,nr_dim=SIZE(act_gt_el%parent%conf(conf)%elem%pos), & - error=error) + next_el=new_elem,nr_dim=SIZE(act_gt_el%parent%conf(conf)%elem%pos)) !-- node one level up parent_elem => act_gt_el%conf(conf)%elem @@ -942,7 +913,7 @@ SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) !-- real parent node (taking the configuration from) ! search parent - parent_elem => search_parent_element(current=new_elem, error=error) + parent_elem => search_parent_element(current=new_elem) new_elem%pos(:) = parent_elem%pos(:) new_elem%mol(:) = parent_elem%mol(:) new_elem%vel(:) = parent_elem%vel(:) @@ -963,12 +934,11 @@ SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) CALL set_rng_stream(rng_stream=tmc_env%rng_stream, & bg=new_elem%rng_seed(:,:,1), & cg=new_elem%rng_seed(:,:,2), & - ig=new_elem%rng_seed(:,:,3), & - error=error) - CALL reset_to_next_rng_substream(tmc_env%rng_stream, error=error) + ig=new_elem%rng_seed(:,:,3)) + CALL reset_to_next_rng_substream(tmc_env%rng_stream) ! set the temperature for the NMC moves - rnd =next_random_number(tmc_env%rng_stream, error=error) + rnd =next_random_number(tmc_env%rng_stream) IF(tmc_env%params%NMC_inp_file.NE."") THEN new_elem%temp_created = INT(tmc_env%params%nr_temp*rnd)+1 ELSE @@ -976,16 +946,15 @@ SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) END IF ! rnd nr for selecting move - rnd= next_random_number(tmc_env%rng_stream, error=error) + rnd= next_random_number(tmc_env%rng_stream) !-- set move type new_elem%move_type = select_random_move_type(& move_types=tmc_env%params%move_types, & - rnd=rnd, error=error) + rnd=rnd) CALL get_rng_stream(rng_stream=tmc_env%rng_stream, & bg=new_elem%rng_seed(:,:,1), & cg=new_elem%rng_seed(:,:,2), & - ig=new_elem%rng_seed(:,:,3), & - error=error) + ig=new_elem%rng_seed(:,:,3)) ! move is only done by the master, ! when standard MC moves with single potential are done @@ -1001,14 +970,14 @@ SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) !-- set the subbox (elements in subbox) CALL elements_in_new_subbox(tmc_params=tmc_env%params, & rng_stream=tmc_env%rng_stream, elem=new_elem, & - nr_of_sub_box_elements=itmp, error=error) + nr_of_sub_box_elements=itmp) ! the move is performed on a worker group CASE(mv_type_NMC_moves) new_elem%stat = status_calculate_NMC_steps !-- set the subbox (elements in subbox) CALL elements_in_new_subbox(tmc_params=tmc_env%params, & rng_stream=tmc_env%rng_stream, elem=new_elem, & - nr_of_sub_box_elements=itmp, error=error) + nr_of_sub_box_elements=itmp) ! the move is performed on a worker group ! the following moves new no force_env and can be performed on the master directly CASE(mv_type_atom_trans, mv_type_atom_swap, mv_type_mol_trans, & @@ -1023,7 +992,7 @@ SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) move_types=tmc_env%params%move_types, & rng_stream=tmc_env%rng_stream, elem=new_elem, & mv_conf=conf, new_subbox=new_subbox, & - move_rejected=mv_rejected, error=error) + move_rejected=mv_rejected) IF(mv_rejected) THEN new_elem%potential = HUGE(new_elem%potential) new_elem%e_pot_approx = HUGE(new_elem%e_pot_approx) @@ -1039,14 +1008,13 @@ SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env, error) CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "unknown move type ("//cp_to_string(new_elem%move_type)//& - "), while creating subtree element.",& - error) + "), while creating subtree element.") END SELECT act_gt_el%conf(act_gt_el%mv_conf)%elem => new_elem ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(act_gt_el%conf(act_gt_el%mv_conf)%elem),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(act_gt_el%conf(act_gt_el%mv_conf)%elem),cp_failure_level,routineP,failure) END SUBROUTINE create_new_subtree_node !============================================================================ @@ -1058,15 +1026,12 @@ END SUBROUTINE create_new_subtree_node !> \param gt_ptr the global tree element !> \param draw if present, changes the coleor in the dot file !> \param tmc_env tmc environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE remove_gt_elem(gt_ptr, draw, tmc_env, error) + SUBROUTINE remove_gt_elem(gt_ptr, draw, tmc_env) TYPE(global_tree_type), POINTER :: gt_ptr LOGICAL, OPTIONAL :: draw TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_gt_elem', & routineP = moduleN//':'//routineN @@ -1076,13 +1041,13 @@ SUBROUTINE remove_gt_elem(gt_ptr, draw, tmc_env, error) failure = .FALSE. - CPPrecondition(ASSOCIATED(gt_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) - CALL remove_gt_references(gt_ptr=gt_ptr, tmc_env=tmc_env, error=error) + CALL remove_gt_references(gt_ptr=gt_ptr, tmc_env=tmc_env) ! set status and draw in tree IF((gt_ptr%stat.EQ.status_accepted_result).OR.(gt_ptr%stat.EQ.status_rejected_result))THEN @@ -1091,7 +1056,7 @@ SUBROUTINE remove_gt_elem(gt_ptr, draw, tmc_env, error) gt_ptr%stat = status_deleted END IF IF(tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) & - CALL create_global_tree_dot_color(gt_tree_element=gt_ptr, tmc_params=tmc_env%params, error=error) + CALL create_global_tree_dot_color(gt_tree_element=gt_ptr, tmc_params=tmc_env%params) !remove pointer from tree parent IF(ASSOCIATED(gt_ptr%parent)) THEN @@ -1112,11 +1077,11 @@ SUBROUTINE remove_gt_elem(gt_ptr, draw, tmc_env, error) gt_ptr%nacc%parent => NULL() END IF - CALL deallocate_global_tree_node(gt_elem=gt_ptr, error=error) + CALL deallocate_global_tree_node(gt_elem=gt_ptr) ! end the timing CALL timestop(handle) - CPPostcondition(.NOT.ASSOCIATED(gt_ptr),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(gt_ptr),cp_failure_level,routineP,failure) END SUBROUTINE remove_gt_elem ! ***************************************************************************** @@ -1125,15 +1090,12 @@ END SUBROUTINE remove_gt_elem !> \param ptr the sub tree element !> \param draw if present, changes the coleor in the dot file !> \param tmc_env tmc environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE remove_st_elem(ptr, draw, tmc_env, error) + SUBROUTINE remove_st_elem(ptr, draw, tmc_env) TYPE(tree_type), POINTER :: ptr LOGICAL, OPTIONAL :: draw TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_st_elem', & routineP = moduleN//':'//routineN @@ -1143,8 +1105,8 @@ SUBROUTINE remove_st_elem(ptr, draw, tmc_env, error) failure = .FALSE. ready = .TRUE. - CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1156,8 +1118,8 @@ SUBROUTINE remove_st_elem(ptr, draw, tmc_env, error) cp_to_string(ptr%sub_tree_nr)//cp_to_string(ptr%nr)//& " still with global tree element references e.g."//& cp_to_string(ptr%gt_nodes_references%gt_elem%nr),& - error,failure) - CPPrecondition(ASSOCIATED(ptr%gt_nodes_references%gt_elem),cp_failure_level,routineP,error,failure) + failure) + CPPrecondition(ASSOCIATED(ptr%gt_nodes_references%gt_elem),cp_failure_level,routineP,failure) ELSE SELECT CASE(ptr%stat) ! if element is still in progress, do not delete, wait for responding @@ -1165,7 +1127,7 @@ SUBROUTINE remove_st_elem(ptr, draw, tmc_env, error) status_calculate_NMC_steps, status_calculate_MD) ! in case of speculative canceling: should be already canceled ! try to deallocate subtree element (still in progress) - CPPrecondition(tmc_env%params%SPECULATIVE_CANCELING,cp_failure_level,routineP,error,failure) + CPPrecondition(tmc_env%params%SPECULATIVE_CANCELING,cp_failure_level,routineP,failure) CASE(status_cancel_nmc, status_cancel_ener) ! do not return in case of finalizing (do not wait for canceling receipt) IF(PRESENT(draw)) ready = .FALSE. @@ -1175,7 +1137,7 @@ SUBROUTINE remove_st_elem(ptr, draw, tmc_env, error) ! check if real top to bottom or bottom to top deallocation (no middle element deallocation) IF(ASSOCIATED(ptr%parent).AND.& (ASSOCIATED(ptr%acc).OR.ASSOCIATED(ptr%nacc)))THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF IF(ready) THEN @@ -1187,8 +1149,7 @@ SUBROUTINE remove_st_elem(ptr, draw, tmc_env, error) ptr%stat = status_deleted END IF IF(tmc_env%params%DRAW_TREE.AND.PRESENT(draw))& - CALL create_dot_color(tree_element=ptr,tmc_params=tmc_env%params, & - error=error) + CALL create_dot_color(tree_element=ptr,tmc_params=tmc_env%params) !remove pointer from tree parent IF(ASSOCIATED(ptr%parent)) THEN @@ -1201,7 +1162,7 @@ SUBROUTINE remove_st_elem(ptr, draw, tmc_env, error) IF(ASSOCIATED(ptr%nacc)) ptr%nacc%parent => NULL() ! deallocate - CALL deallocate_sub_tree_node(tree_elem=ptr, error=error) + CALL deallocate_sub_tree_node(tree_elem=ptr) END IF END IF ! end the timing @@ -1215,15 +1176,12 @@ END SUBROUTINE remove_st_elem !> \param end_ptr end of the tree region to be cleaned !> \param removed retun value if brance is clean !> \param tmc_env tmc environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - RECURSIVE SUBROUTINE remove_unused_g_tree(begin_ptr, end_ptr, removed, tmc_env, error) + RECURSIVE SUBROUTINE remove_unused_g_tree(begin_ptr, end_ptr, removed, tmc_env) TYPE(global_tree_type), POINTER :: begin_ptr, end_ptr LOGICAL :: removed TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_unused_g_tree', & routineP = moduleN//':'//routineN @@ -1236,9 +1194,9 @@ RECURSIVE SUBROUTINE remove_unused_g_tree(begin_ptr, end_ptr, removed, tmc_env, failure = .FALSE. NULLIFY(acc_ptr, nacc_ptr, tmp_ptr) - CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(end_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(end_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1252,13 +1210,13 @@ RECURSIVE SUBROUTINE remove_unused_g_tree(begin_ptr, end_ptr, removed, tmc_env, !-- check if child nodes exist and possibly deallocate child node IF(ASSOCIATED(begin_ptr%acc))THEN acc_ptr => begin_ptr%acc - CALL remove_unused_g_tree(acc_ptr, end_ptr, acc_removed, tmc_env, error) + CALL remove_unused_g_tree(acc_ptr, end_ptr, acc_removed, tmc_env) ELSE acc_removed = .TRUE. END IF IF(ASSOCIATED(begin_ptr%nacc))THEN nacc_ptr => begin_ptr%nacc - CALL remove_unused_g_tree(nacc_ptr, end_ptr, nacc_removed, tmc_env, error) + CALL remove_unused_g_tree(nacc_ptr, end_ptr, nacc_removed, tmc_env) ELSE nacc_removed = .TRUE. END IF @@ -1272,19 +1230,19 @@ RECURSIVE SUBROUTINE remove_unused_g_tree(begin_ptr, end_ptr, removed, tmc_env, ! delete references, cancel elements calculation and deallocate global tree element tmp_ptr => begin_ptr - CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env, error=error) + CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env) IF(.NOT.ASSOCIATED(tmp_ptr)) removed = .TRUE. CASE(status_accepted_result, status_rejected_result) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"try to dealloc unused tree element with status of begin element"& - //cp_to_string(begin_ptr%stat),error,failure) + //cp_to_string(begin_ptr%stat),failure) END SELECT END IF END IF ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(end_ptr),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(end_ptr),cp_failure_level,routineP,failure) END SUBROUTINE remove_unused_g_tree ! ***************************************************************************** @@ -1295,19 +1253,16 @@ END SUBROUTINE remove_unused_g_tree !> \param working_elem_list ... !> \param removed retun value if brance is clean !> \param tmc_env tmc environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** RECURSIVE SUBROUTINE remove_unused_s_tree(begin_ptr, end_ptr,working_elem_list,& - removed, tmc_env, error) + removed, tmc_env) TYPE(tree_type), POINTER :: begin_ptr TYPE(tree_type), INTENT(IN), POINTER :: end_ptr TYPE(elem_array_type), DIMENSION(:), & POINTER :: working_elem_list LOGICAL :: removed TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_unused_s_tree', & routineP = moduleN//':'//routineN @@ -1327,10 +1282,10 @@ RECURSIVE SUBROUTINE remove_unused_s_tree(begin_ptr, end_ptr,working_elem_list,& ! start the timing CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(end_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(working_elem_list),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(end_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(working_elem_list),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) !-- if element is last checked in trajectory, go back IF(.NOT.ASSOCIATED(begin_ptr, end_ptr)) THEN @@ -1339,14 +1294,14 @@ RECURSIVE SUBROUTINE remove_unused_s_tree(begin_ptr, end_ptr,working_elem_list,& IF(ASSOCIATED(begin_ptr%acc))THEN acc_ptr => begin_ptr%acc CALL remove_unused_s_tree(acc_ptr, end_ptr, working_elem_list, & - acc_removed, tmc_env, error) + acc_removed, tmc_env) ELSE acc_removed = .TRUE. END IF IF(ASSOCIATED(begin_ptr%nacc))THEN nacc_ptr => begin_ptr%nacc CALL remove_unused_s_tree(nacc_ptr, end_ptr, working_elem_list, & - nacc_removed, tmc_env, error) + nacc_removed, tmc_env) ELSE nacc_removed = .TRUE. END IF @@ -1375,7 +1330,7 @@ RECURSIVE SUBROUTINE remove_unused_s_tree(begin_ptr, end_ptr,working_elem_list,& "unknown status "//cp_to_string(begin_ptr%stat)//& "of sub tree element "//& cp_to_string(begin_ptr%sub_tree_nr)//" "//& - cp_to_string(begin_ptr%nr),error) + cp_to_string(begin_ptr%nr)) END SELECT ! delete element @@ -1386,7 +1341,7 @@ RECURSIVE SUBROUTINE remove_unused_s_tree(begin_ptr, end_ptr,working_elem_list,& "try to remove unused subtree element "//& cp_to_string(begin_ptr%sub_tree_nr)//" "//& cp_to_string(begin_ptr%nr)//& - " but parent does not exist", error) + " but parent does not exist") tmp_ptr => begin_ptr ! check if a working group is still working on this element removed = .TRUE. @@ -1399,8 +1354,7 @@ RECURSIVE SUBROUTINE remove_unused_s_tree(begin_ptr, end_ptr,working_elem_list,& IF(removed) THEN !IF (DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"deallocation of node ", begin_ptr%nr, "with status ", begin_ptr%stat ! if all groups are finished with this element, we can deallocate - CALL remove_st_elem(ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env, & - error=error) + CALL remove_st_elem(ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env) IF(.NOT.ASSOCIATED(tmp_ptr))THEN removed = .TRUE. ELSE @@ -1420,15 +1374,12 @@ END SUBROUTINE remove_unused_s_tree !> \param end_of_clean_tree ... !> \param actual_ptr ... !> \param tmc_env TMC environment for deallocation -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** RECURSIVE SUBROUTINE remove_result_g_tree(end_of_clean_tree, actual_ptr, & - tmc_env, error) + tmc_env) TYPE(global_tree_type), POINTER :: end_of_clean_tree, actual_ptr TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_result_g_tree', & routineP = moduleN//':'//routineN @@ -1438,8 +1389,8 @@ RECURSIVE SUBROUTINE remove_result_g_tree(end_of_clean_tree, actual_ptr, & TYPE(global_tree_type), POINTER :: tmp_ptr failure = .FALSE. - CPPrecondition(ASSOCIATED(end_of_clean_tree),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(actual_ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(end_of_clean_tree),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(actual_ptr),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1448,13 +1399,13 @@ RECURSIVE SUBROUTINE remove_result_g_tree(end_of_clean_tree, actual_ptr, & IF(ASSOCIATED(actual_ptr%parent))& CALL remove_result_g_tree(end_of_clean_tree=end_of_clean_tree, & actual_ptr=actual_ptr%parent, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) !-- new tree head has no parent IF(.NOT.ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN !-- deallocate node !IF(DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"dealloc gt result tree element: ",actual_ptr%nr tmp_ptr => actual_ptr - CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env, error=error) + CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.TRUE., tmc_env=tmc_env) actual_ptr => tmp_ptr END IF ! end the timing @@ -1468,15 +1419,12 @@ END SUBROUTINE remove_result_g_tree !> \param end_of_clean_tree ... !> \param actual_ptr ... !> \param tmc_env TMC environment for deallocation -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** RECURSIVE SUBROUTINE remove_result_s_tree(end_of_clean_tree, actual_ptr,& - tmc_env,error) + tmc_env) TYPE(tree_type), POINTER :: end_of_clean_tree, actual_ptr TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_result_s_tree', & routineP = moduleN//':'//routineN @@ -1486,9 +1434,9 @@ RECURSIVE SUBROUTINE remove_result_s_tree(end_of_clean_tree, actual_ptr,& TYPE(tree_type), POINTER :: tmp_ptr failure = .FALSE. - CPPrecondition(ASSOCIATED(end_of_clean_tree),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(actual_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(end_of_clean_tree),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(actual_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -1496,20 +1444,20 @@ RECURSIVE SUBROUTINE remove_result_s_tree(end_of_clean_tree, actual_ptr,& !-- going up to the head ot the subtree IF(ASSOCIATED(actual_ptr%parent)) & CALL remove_result_s_tree(end_of_clean_tree, actual_ptr%parent, & - tmc_env, error) + tmc_env) !-- new tree head has no parent IF(.NOT.ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN ! in trajectory just one direction should exist IF(ASSOCIATED(actual_ptr%acc).AND.ASSOCIATED(actual_ptr%nacc)) THEN - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END IF ! the parent should be deleted already, but global tree is allocated to the second last accepted, & ! hence there could be still a reference to an element... IF(.NOT.ASSOCIATED(actual_ptr%parent)) THEN !-- deallocate node tmp_ptr => actual_ptr - CALL remove_st_elem(ptr=tmp_ptr,draw=.TRUE.,tmc_env=tmc_env,error=error) + CALL remove_st_elem(ptr=tmp_ptr,draw=.TRUE.,tmc_env=tmc_env) actual_ptr => tmp_ptr END IF END IF @@ -1523,15 +1471,12 @@ END SUBROUTINE remove_result_s_tree !> in global and subtrees !> \param working_elem_list list of actual calculating elements for canceling !> \param tmc_env TMC environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE remove_all_trees(working_elem_list, tmc_env, error) + SUBROUTINE remove_all_trees(working_elem_list, tmc_env) TYPE(elem_array_type), DIMENSION(:), & POINTER :: working_elem_list TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_all_trees', & routineP = moduleN//':'//routineN @@ -1544,13 +1489,13 @@ SUBROUTINE remove_all_trees(working_elem_list, tmc_env, error) failure = .FALSE. NULLIFY(last_acc_st_elem, tmp_ptr, tmp_gt_ptr) - CPPrecondition(ASSOCIATED(working_elem_list),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_clean_end),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env%result_list),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env%st_clean_ends),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(working_elem_list),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env%gt_clean_end),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env%result_list),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env%st_clean_ends),cp_failure_level,routineP,failure) flag = .FALSE. change_trajec = .FALSE. @@ -1561,22 +1506,21 @@ SUBROUTINE remove_all_trees(working_elem_list, tmc_env, error) !-- deallocate unused pt tree CALL remove_unused_g_tree(begin_ptr=tmc_env%m_env%gt_clean_end, & end_ptr=tmc_env%m_env%gt_act, removed=flag, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) tmp_gt_ptr => tmc_env%m_env%gt_clean_end CALL search_end_of_clean_g_tree(last_acc=tmc_env%m_env%gt_clean_end, & - tree_ptr=tmp_gt_ptr, error=error) + tree_ptr=tmp_gt_ptr) !-- deallocate unused pt trajectory tree elements IF(tmc_env%params%USE_REDUCED_TREE)THEN tmp_gt_ptr => tmc_env%m_env%gt_clean_end CALL remove_result_g_tree(end_of_clean_tree=tmc_env%m_env%gt_clean_end,& - actual_ptr=tmp_gt_ptr, tmc_env=tmc_env, & - error=error) + actual_ptr=tmp_gt_ptr, tmc_env=tmc_env) !check if something changed, if not no deallocation of result subtree necessary IF(.NOT.ASSOCIATED(tmc_env%m_env%gt_head,tmc_env%m_env%gt_clean_end)) & change_trajec=.TRUE. tmc_env%m_env%gt_head => tmc_env%m_env%gt_clean_end - CPPostcondition(.NOT.ASSOCIATED(tmc_env%m_env%gt_head%parent),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(tmc_env%m_env%gt_head%parent),cp_failure_level,routineP,failure) !IF (DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr END IF @@ -1589,21 +1533,20 @@ SUBROUTINE remove_all_trees(working_elem_list, tmc_env, error) IF(last_acc_st_elem%sub_tree_nr .EQ. tree) & EXIT conf_loop END DO conf_loop - CPPostcondition(last_acc_st_elem%sub_tree_nr.EQ.tree,cp_failure_level,routineP,error,failure) + CPPostcondition(last_acc_st_elem%sub_tree_nr.EQ.tree,cp_failure_level,routineP,failure) CALL remove_unused_s_tree(begin_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, & end_ptr=last_acc_st_elem, working_elem_list=working_elem_list, & - removed=flag, tmc_env=tmc_env,error=error) + removed=flag, tmc_env=tmc_env) CALL search_end_of_clean_tree(tree_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, & - last_acc=last_acc_st_elem, & - error=error) + last_acc=last_acc_st_elem) END DO !-- deallocate the trajectory subtree elements IF(tmc_env%params%USE_REDUCED_TREE .AND. change_trajec)THEN DO tree=1, tmc_env%params%nr_temp tmp_ptr => tmc_env%m_env%st_clean_ends(tree)%elem - CPPostcondition(tmp_ptr%sub_tree_nr.EQ.tree,cp_failure_level,routineP,error,failure) + CPPostcondition(tmp_ptr%sub_tree_nr.EQ.tree,cp_failure_level,routineP,failure) CALL remove_result_s_tree(end_of_clean_tree=tmc_env%m_env%st_clean_ends(tree)%elem,& - actual_ptr=tmp_ptr, tmc_env=tmc_env, error=error) + actual_ptr=tmp_ptr, tmc_env=tmc_env) tmc_env%m_env%st_heads(tree)%elem => tmc_env%m_env%st_clean_ends(tree)%elem !IF(DEBUG.GE.20) & ! WRITE(tmc_out_file_nr,*)"new head of tree ",tree," is ",& @@ -1613,8 +1556,8 @@ SUBROUTINE remove_all_trees(working_elem_list, tmc_env, error) ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tmc_env%m_env%gt_clean_end),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tmc_env%m_env%gt_act),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tmc_env%m_env%gt_clean_end),cp_failure_level,routineP,failure) END SUBROUTINE remove_all_trees ! ***************************************************************************** @@ -1622,15 +1565,12 @@ END SUBROUTINE remove_all_trees !> \param begin_ptr pointer to global tree head !> \param removed flag, if the this element is removed !> \param tmc_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - RECURSIVE SUBROUTINE dealloc_whole_g_tree(begin_ptr, removed, tmc_env,error) + RECURSIVE SUBROUTINE dealloc_whole_g_tree(begin_ptr, removed, tmc_env) TYPE(global_tree_type), POINTER :: begin_ptr LOGICAL :: removed TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dealloc_whole_g_tree', & routineP = moduleN//':'//routineN @@ -1640,18 +1580,18 @@ RECURSIVE SUBROUTINE dealloc_whole_g_tree(begin_ptr, removed, tmc_env,error) TYPE(global_tree_type), POINTER :: acc_ptr, nacc_ptr, tmp_ptr failure = .FALSE. - CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) IF(ASSOCIATED(begin_ptr%acc))THEN acc_ptr => begin_ptr%acc - CALL dealloc_whole_g_tree(acc_ptr, acc_removed, tmc_env, error) + CALL dealloc_whole_g_tree(acc_ptr, acc_removed, tmc_env) ELSE acc_removed = .TRUE. END IF IF(ASSOCIATED(begin_ptr%nacc))THEN nacc_ptr => begin_ptr%nacc - CALL dealloc_whole_g_tree(nacc_ptr, nacc_removed, tmc_env, error) + CALL dealloc_whole_g_tree(nacc_ptr, nacc_removed, tmc_env) ELSE nacc_removed = .TRUE. END IF @@ -1659,11 +1599,10 @@ RECURSIVE SUBROUTINE dealloc_whole_g_tree(begin_ptr, removed, tmc_env,error) !-- deallocate node if no child node exist IF(acc_removed.AND.nacc_removed)THEN CALL search_and_remove_reference_in_list(gt_ptr=begin_ptr, & - elem=begin_ptr%conf(begin_ptr%mv_conf)%elem, tmc_env=tmc_env, & - error=error) + elem=begin_ptr%conf(begin_ptr%mv_conf)%elem, tmc_env=tmc_env) tmp_ptr => begin_ptr - CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.FALSE., tmc_env=tmc_env, error=error) - !CALL deallocate_global_tree_node(gt_elem=tmp_ptr, error=error) + CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.FALSE., tmc_env=tmc_env) + !CALL deallocate_global_tree_node(gt_elem=tmp_ptr) removed = .TRUE. END IF END SUBROUTINE dealloc_whole_g_tree @@ -1672,15 +1611,12 @@ END SUBROUTINE dealloc_whole_g_tree !> \param begin_ptr pointer to sub tree head !> \param removed flag, if the this element is removed !> \param tmc_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - RECURSIVE SUBROUTINE dealloc_whole_subtree(begin_ptr, removed, tmc_params, error) + RECURSIVE SUBROUTINE dealloc_whole_subtree(begin_ptr, removed, tmc_params) TYPE(tree_type), POINTER :: begin_ptr LOGICAL :: removed TYPE(tmc_param_type), POINTER :: tmc_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'dealloc_whole_subtree', & routineP = moduleN//':'//routineN @@ -1690,18 +1626,18 @@ RECURSIVE SUBROUTINE dealloc_whole_subtree(begin_ptr, removed, tmc_params, error TYPE(tree_type), POINTER :: acc_ptr, nacc_ptr, tmp_ptr failure = .FALSE. - CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(begin_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_params),cp_failure_level,routineP,failure) IF(ASSOCIATED(begin_ptr%acc))THEN acc_ptr => begin_ptr%acc - CALL dealloc_whole_subtree(acc_ptr, acc_removed, tmc_params, error) + CALL dealloc_whole_subtree(acc_ptr, acc_removed, tmc_params) ELSE acc_removed = .TRUE. END IF IF(ASSOCIATED(begin_ptr%nacc))THEN nacc_ptr => begin_ptr%nacc - CALL dealloc_whole_subtree(nacc_ptr, nacc_removed, tmc_params, error) + CALL dealloc_whole_subtree(nacc_ptr, nacc_removed, tmc_params) ELSE nacc_removed = .TRUE. END IF @@ -1709,7 +1645,7 @@ RECURSIVE SUBROUTINE dealloc_whole_subtree(begin_ptr, removed, tmc_params, error !-- deallocate node if no child node exist IF(acc_removed.AND.nacc_removed)THEN tmp_ptr => begin_ptr - CALL deallocate_sub_tree_node(tree_elem=begin_ptr, error=error) + CALL deallocate_sub_tree_node(tree_elem=begin_ptr) removed = .TRUE. END IF END SUBROUTINE dealloc_whole_subtree @@ -1720,13 +1656,10 @@ END SUBROUTINE dealloc_whole_subtree ! ***************************************************************************** !> \brief deallocating every tree node of every trees (clean up) !> \param tmc_env TMC environment structure -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - SUBROUTINE finalize_trees(tmc_env, error) + SUBROUTINE finalize_trees(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'finalize_trees', & routineP = moduleN//':'//routineN @@ -1736,8 +1669,8 @@ SUBROUTINE finalize_trees(tmc_env, error) TYPE(global_tree_type), POINTER :: global_tree failure = .FALSE. - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) global_tree => tmc_env%m_env%gt_act !-- deallocate pt tree @@ -1746,7 +1679,7 @@ SUBROUTINE finalize_trees(tmc_env, error) global_tree => global_tree%parent END DO CALL dealloc_whole_g_tree(begin_ptr=global_tree, removed=flag, & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) !-- deallocate subtrees trees_loop: DO i=1, SIZE(tmc_env%m_env%st_clean_ends(:)) @@ -1755,7 +1688,7 @@ SUBROUTINE finalize_trees(tmc_env, error) tmc_env%m_env%st_clean_ends(i)%elem%parent END DO CALL dealloc_whole_subtree(begin_ptr=tmc_env%m_env%st_clean_ends(i)%elem,& - removed=flag, tmc_params=tmc_env%params, error=error) + removed=flag, tmc_params=tmc_env%params) END DO trees_loop DEALLOCATE(tmc_env%params%atoms) END SUBROUTINE finalize_trees diff --git a/src/tmc/tmc_tree_references.F b/src/tmc/tmc_tree_references.F index 489f253a3f..11098af754 100644 --- a/src/tmc/tmc_tree_references.F +++ b/src/tmc/tmc_tree_references.F @@ -42,13 +42,10 @@ MODULE tmc_tree_references ! ***************************************************************************** !> \brief adds global tree reference to the modified sub tree element(s) !> \param gt_elem actual global tree element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE add_to_references(gt_elem, error) + SUBROUTINE add_to_references(gt_elem) TYPE(global_tree_type), POINTER :: gt_elem - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'add_to_references', & routineP = moduleN//':'//routineN @@ -60,7 +57,7 @@ SUBROUTINE add_to_references(gt_elem, error) failure = .FALSE. NULLIFY(tmp_pt_list_elem) - CPPrecondition(ASSOCIATED(gt_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -97,14 +94,11 @@ END SUBROUTINE add_to_references !> from all related sub tree elements !> \param gt_ptr actual global tree element !> \param tmc_env ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE remove_gt_references(gt_ptr, tmc_env, error) + SUBROUTINE remove_gt_references(gt_ptr, tmc_env) TYPE(global_tree_type), POINTER :: gt_ptr TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'remove_gt_references', & routineP = moduleN//':'//routineN @@ -113,19 +107,19 @@ SUBROUTINE remove_gt_references(gt_ptr, tmc_env, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(gt_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) CALL search_and_remove_reference_in_list(gt_ptr=gt_ptr, & - elem=gt_ptr%conf(gt_ptr%mv_conf)%elem, tmc_env=tmc_env,error=error) + elem=gt_ptr%conf(gt_ptr%mv_conf)%elem, tmc_env=tmc_env) ! in case of parallel tempering also the reference in the second swaped configuration has to be removed IF(gt_ptr%swaped) THEN CALL search_and_remove_reference_in_list(gt_ptr=gt_ptr, & - elem=gt_ptr%conf(gt_ptr%mv_conf+1)%elem, tmc_env=tmc_env, error=error) + elem=gt_ptr%conf(gt_ptr%mv_conf+1)%elem, tmc_env=tmc_env) END IF ! end the timing CALL timestop(handle) @@ -135,13 +129,10 @@ END SUBROUTINE remove_gt_references !> \brief removes the pointers to a certain subtree element from every related !> global tree element !> \param ptr sub tree element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE remove_subtree_element_of_all_references(ptr, error) + SUBROUTINE remove_subtree_element_of_all_references(ptr) TYPE(tree_type), POINTER :: ptr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'remove_subtree_element_of_all_references', & @@ -155,20 +146,20 @@ SUBROUTINE remove_subtree_element_of_all_references(ptr, error) failure = .FALSE. NULLIFY(tmp_gt_list_ptr) - CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) pt_node_ref_loop: DO WHILE(ASSOCIATED(ptr%gt_nodes_references)) tmp_gt_list_ptr => ptr%gt_nodes_references - CPPrecondition(ASSOCIATED(tmp_gt_list_ptr%gt_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmp_gt_list_ptr%gt_elem),cp_failure_level,routineP,failure) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"found reference of global tree node "//& cp_to_string(tmp_gt_list_ptr%gt_elem%nr)//& ", while removing sub tree node "//& cp_to_string(ptr%sub_tree_nr)//cp_to_string(ptr%nr),& - error,failure) + failure) ! check if configurations exist IF(ASSOCIATED(tmp_gt_list_ptr%gt_elem%conf(tmp_gt_list_ptr%gt_elem%mv_conf)%elem)) THEN IF(ASSOCIATED(ptr, tmp_gt_list_ptr%gt_elem%conf(tmp_gt_list_ptr%gt_elem%mv_conf)%elem)) THEN @@ -191,14 +182,14 @@ SUBROUTINE remove_subtree_element_of_all_references(ptr, error) "moved elem"//cp_to_string(tmp_gt_list_ptr%gt_elem%mv_conf)//& "with the related subtree, elements: "//& TRIM(ADJUSTL(list_of_nr)), & - error,failure) + failure) END IF ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"for subtree "//cp_to_string(ptr%sub_tree_nr)//& "element "//cp_to_string(ptr%nr)//& " is not related to global tree node "//cp_to_string(tmp_gt_list_ptr%gt_elem%nr)//& - "(anymore).",error,failure) + "(anymore).",failure) END IF ptr%gt_nodes_references => ptr%gt_nodes_references%next DEALLOCATE(tmp_gt_list_ptr) @@ -208,7 +199,7 @@ SUBROUTINE remove_subtree_element_of_all_references(ptr, error) ! end the timing CALL timestop(handle) - CPPostcondition(.NOT.ASSOCIATED(ptr%gt_nodes_references),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(ptr%gt_nodes_references),cp_failure_level,routineP,failure) END SUBROUTINE remove_subtree_element_of_all_references ! ***************************************************************************** @@ -217,15 +208,12 @@ END SUBROUTINE remove_subtree_element_of_all_references !> \param gt_ptr actual global tree element !> \param elem ... !> \param tmc_env TMC environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE search_and_remove_reference_in_list(gt_ptr, elem, tmc_env, error) + SUBROUTINE search_and_remove_reference_in_list(gt_ptr, elem, tmc_env) TYPE(global_tree_type), POINTER :: gt_ptr TYPE(tree_type), POINTER :: elem TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'search_and_remove_reference_in_list', & @@ -243,7 +231,7 @@ SUBROUTINE search_and_remove_reference_in_list(gt_ptr, elem, tmc_env, error) IF(.NOT.ASSOCIATED(elem)) RETURN IF(.NOT.ASSOCIATED(gt_ptr)) RETURN - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -261,7 +249,7 @@ SUBROUTINE search_and_remove_reference_in_list(gt_ptr, elem, tmc_env, error) ! additionally last reference (the only one)? IF(.NOT.ASSOCIATED(tmp_gt_list_ptr%next)) THEN ! last element in list -> cancel calculation - CALL add_to_canceling_list(elem=elem, tmc_env=tmc_env, error=error) + CALL add_to_canceling_list(elem=elem, tmc_env=tmc_env) elem%gt_nodes_references => NULL() tmp_gt_list_last_ptr => NULL() ELSE diff --git a/src/tmc/tmc_tree_search.F b/src/tmc/tmc_tree_search.F index dc0a0059be..35e7d44515 100644 --- a/src/tmc/tmc_tree_search.F +++ b/src/tmc/tmc_tree_search.F @@ -60,19 +60,16 @@ MODULE tmc_tree_search !> \param prob return value, the probability of reaching the tree node !> \param n_acc drection of branch the next tree node should extend !> \param search_energy_node ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \parma search_energy_node flag if configuration for calculating exact !> energy sould be searched !> \author Mandes 12.2012 ! ***************************************************************************** RECURSIVE SUBROUTINE most_prob_end(global_tree_elem, prob, n_acc, & - search_energy_node, error) + search_energy_node) TYPE(global_tree_type), POINTER :: global_tree_elem REAL(KIND=dp), INTENT(OUT) :: prob LOGICAL, INTENT(INOUT) :: n_acc LOGICAL, OPTIONAL :: search_energy_node - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'most_prob_end', & routineP = moduleN//':'//routineN @@ -94,9 +91,9 @@ RECURSIVE SUBROUTINE most_prob_end(global_tree_elem, prob, n_acc, & check_rejected = .FALSE. keep_on = .TRUE. - CPPrecondition(ASSOCIATED(global_tree_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(global_tree_elem),cp_failure_level,routineP,failure) st_elem => global_tree_elem%conf(global_tree_elem%mv_conf)%elem - CPPrecondition(ASSOCIATED(st_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(st_elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -150,7 +147,7 @@ RECURSIVE SUBROUTINE most_prob_end(global_tree_elem, prob, n_acc, & CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "unknown sub tree element status "//& - cp_to_string(st_elem%stat),error) + cp_to_string(st_elem%stat)) END SELECT END SELECT @@ -165,11 +162,10 @@ RECURSIVE SUBROUTINE most_prob_end(global_tree_elem, prob, n_acc, & IF(PRESENT(search_energy_node)) THEN CALL most_prob_end(global_tree_elem=ptr_acc, prob=prob_n_acc, & n_acc=tmp_acc, & - search_energy_node=search_energy_node, & - error=error) + search_energy_node=search_energy_node) ELSE CALL most_prob_end(global_tree_elem=ptr_acc, prob=prob_n_acc, & - n_acc=tmp_acc, error=error) + n_acc=tmp_acc) END IF !-- do probability multiplication ! (in logscale because of realy small probabilities) @@ -192,11 +188,10 @@ RECURSIVE SUBROUTINE most_prob_end(global_tree_elem, prob, n_acc, & IF(PRESENT(search_energy_node)) THEN CALL most_prob_end(global_tree_elem=ptr_nacc, prob=prob_n_nacc, & n_acc=tmp_nacc, & - search_energy_node=search_energy_node, & - error=error) + search_energy_node=search_energy_node) ELSE CALL most_prob_end(global_tree_elem=ptr_nacc, prob=prob_n_nacc, & - n_acc=tmp_nacc, error=error) + n_acc=tmp_nacc) END IF !-- do probability multiplication ! (in logscale because of realy small probabilities) @@ -233,15 +228,11 @@ END SUBROUTINE most_prob_end !> \param new_gt_elem return value the energy should be calculated for !> \param stat routine status return value !> \param react_count reactivation counter -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE search_next_energy_calc(gt_head, new_gt_elem, stat, react_count, & - error) + SUBROUTINE search_next_energy_calc(gt_head, new_gt_elem, stat, react_count) TYPE(global_tree_type), POINTER :: gt_head, new_gt_elem INTEGER :: stat, react_count - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'search_next_energy_calc', & routineP = moduleN//':'//routineN @@ -253,7 +244,7 @@ SUBROUTINE search_next_energy_calc(gt_head, new_gt_elem, stat, react_count, & prob = 0.0_dp flag = .FALSE. failure = .FALSE. - CPPrecondition(ASSOCIATED(gt_head),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_head),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -261,7 +252,7 @@ SUBROUTINE search_next_energy_calc(gt_head, new_gt_elem, stat, react_count, & new_gt_elem => gt_head CALL most_prob_end(global_tree_elem=new_gt_elem, prob=prob, n_acc=flag, & - search_energy_node=.TRUE., error=error) + search_energy_node=.TRUE.) stat = status_created ! set status for master @@ -272,7 +263,7 @@ SUBROUTINE search_next_energy_calc(gt_head, new_gt_elem, stat, react_count, & ! reactivate canceled elements IF(new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat.EQ.& status_canceled_ener)THEN - CALL add_to_references(gt_elem=new_gt_elem, error=error) + CALL add_to_references(gt_elem=new_gt_elem) react_count = react_count+1 new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat = status_created END IF @@ -288,16 +279,12 @@ END SUBROUTINE search_next_energy_calc ! ***************************************************************************** !> \brief searching the parent element (last accepted configuration before) !> \param current actual tree element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval parent parent tree element (last accepted one) !> \author Mandes 12.2012 !> \note routine searches last (assumed) accepted element in subtree ! ***************************************************************************** - RECURSIVE FUNCTION search_parent_element(current, error) RESULT(parent) - TYPE(tree_type), POINTER :: current - TYPE(cp_error_type), INTENT(inout) :: error - TYPE(tree_type), POINTER :: parent + RECURSIVE FUNCTION search_parent_element(current) RESULT(parent) + TYPE(tree_type), POINTER :: current, parent CHARACTER(LEN=*), PARAMETER :: routineN = 'search_parent_element', & routineP = moduleN//':'//routineN @@ -306,7 +293,7 @@ RECURSIVE FUNCTION search_parent_element(current, error) RESULT(parent) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(current),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(current),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -315,7 +302,7 @@ RECURSIVE FUNCTION search_parent_element(current, error) RESULT(parent) ! the result value if the child (we came from) is in acc direction parent => current%parent IF(ASSOCIATED(parent%nacc, current)) THEN - parent => search_parent_element(parent, error) + parent => search_parent_element(parent) END IF ELSE ! if parent not exist, we are at the head of the tree @@ -323,21 +310,18 @@ RECURSIVE FUNCTION search_parent_element(current, error) RESULT(parent) END IF ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(parent),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(parent),cp_failure_level,routineP,failure) END FUNCTION search_parent_element ! ***************************************************************************** !> \brief search the next global element in the Markov Chain to check !> \param ptr start point for search, should be on the known Markov Chain !> \param found flag if routine was successful -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - RECURSIVE SUBROUTINE search_next_gt_element_to_check(ptr, found, error) + RECURSIVE SUBROUTINE search_next_gt_element_to_check(ptr, found) TYPE(global_tree_type), POINTER :: ptr LOGICAL :: found - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'search_next_gt_element_to_check', & @@ -349,7 +333,7 @@ RECURSIVE SUBROUTINE search_next_gt_element_to_check(ptr, found, error) found = .FALSE. failure = .FALSE. - CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -360,12 +344,12 @@ RECURSIVE SUBROUTINE search_next_gt_element_to_check(ptr, found, error) CASE(status_accepted_result) IF(ASSOCIATED(ptr%acc))THEN ptr => ptr%acc - CALL search_next_gt_element_to_check(ptr, found, error) + CALL search_next_gt_element_to_check(ptr, found) END IF CASE(status_rejected_result) IF(ASSOCIATED(ptr%nacc))THEN ptr => ptr%nacc - CALL search_next_gt_element_to_check(ptr, found, error) + CALL search_next_gt_element_to_check(ptr, found) END IF CASE(status_calculate_energy, status_created, & status_calculate_MD,status_calculated,status_calculate_NMC_steps, & @@ -378,12 +362,12 @@ RECURSIVE SUBROUTINE search_next_gt_element_to_check(ptr, found, error) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unexpected status "//cp_to_string(ptr%stat)//& "of global tree elem "//cp_to_string(ptr%nr), & - error,failure) + failure) END SELECT ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(ptr),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ptr),cp_failure_level,routineP,failure) END SUBROUTINE search_next_gt_element_to_check ! ***************************************************************************** @@ -392,14 +376,11 @@ END SUBROUTINE search_next_gt_element_to_check !> \param gt_act_elem actual global tree element !> \param elem1 two subtree elements which should be compared !> \param elem2 two subtree elements which should be compared -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - SUBROUTINE get_subtree_elements_to_check(gt_act_elem, elem1, elem2, error) + SUBROUTINE get_subtree_elements_to_check(gt_act_elem, elem1, elem2) TYPE(global_tree_type), POINTER :: gt_act_elem TYPE(tree_type), INTENT(OUT), POINTER :: elem1, elem2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'get_subtree_elements_to_check', & @@ -409,7 +390,7 @@ SUBROUTINE get_subtree_elements_to_check(gt_act_elem, elem1, elem2, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(gt_act_elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(gt_act_elem),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -421,25 +402,25 @@ SUBROUTINE get_subtree_elements_to_check(gt_act_elem, elem1, elem2, error) IF(gt_act_elem%conf_n_acc(gt_act_elem%conf(gt_act_elem%mv_conf)%elem%sub_tree_nr))THEN elem1 => gt_act_elem%conf(gt_act_elem%mv_conf)%elem ELSE - elem1 => search_parent_element(gt_act_elem%conf(gt_act_elem%mv_conf)%elem, error) + elem1 => search_parent_element(gt_act_elem%conf(gt_act_elem%mv_conf)%elem) END IF ! second element IF(gt_act_elem%conf_n_acc(gt_act_elem%conf(gt_act_elem%mv_conf+1)%elem%sub_tree_nr))THEN elem2 => gt_act_elem%conf(gt_act_elem%mv_conf+1)%elem ELSE - elem2 => search_parent_element(gt_act_elem%conf(gt_act_elem%mv_conf+1)%elem, error) + elem2 => search_parent_element(gt_act_elem%conf(gt_act_elem%mv_conf+1)%elem) END IF ELSE elem1 => gt_act_elem%conf(gt_act_elem%mv_conf)%elem - elem2 => search_parent_element(elem1, error) + elem2 => search_parent_element(elem1) END IF ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(gt_act_elem),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(elem1),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(elem2),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(gt_act_elem),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(elem1),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(elem2),cp_failure_level,routineP,failure) END SUBROUTINE get_subtree_elements_to_check ! ***************************************************************************** @@ -448,13 +429,10 @@ END SUBROUTINE get_subtree_elements_to_check !> also found the last accepted element before !> \param last_acc returns last accepted element in cleaned tree part !> \param tree_ptr end point of search -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - RECURSIVE SUBROUTINE search_end_of_clean_g_tree(last_acc, tree_ptr, error) + RECURSIVE SUBROUTINE search_end_of_clean_g_tree(last_acc, tree_ptr) TYPE(global_tree_type), POINTER :: last_acc, tree_ptr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'search_end_of_clean_g_tree', & routineP = moduleN//':'//routineN @@ -463,8 +441,8 @@ RECURSIVE SUBROUTINE search_end_of_clean_g_tree(last_acc, tree_ptr, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(last_acc),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(last_acc),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -474,12 +452,12 @@ RECURSIVE SUBROUTINE search_end_of_clean_g_tree(last_acc, tree_ptr, error) IF(ASSOCIATED(tree_ptr%acc).AND..NOT.ASSOCIATED(tree_ptr%nacc))THEN last_acc => tree_ptr tree_ptr => tree_ptr%acc - CALL search_end_of_clean_g_tree(last_acc, tree_ptr, error) + CALL search_end_of_clean_g_tree(last_acc, tree_ptr) END IF CASE(status_rejected_result) IF(ASSOCIATED(tree_ptr%nacc).AND..NOT.ASSOCIATED(tree_ptr%acc))THEN tree_ptr => tree_ptr%nacc - CALL search_end_of_clean_g_tree(last_acc, tree_ptr, error) + CALL search_end_of_clean_g_tree(last_acc, tree_ptr) END IF CASE(status_calculated, status_calculate_energy, status_created, status_accepted, status_rejected, & status_calculate_MD, status_calculate_NMC_steps, status_calc_approx_ener, & @@ -490,12 +468,12 @@ RECURSIVE SUBROUTINE search_end_of_clean_g_tree(last_acc, tree_ptr, error) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"the global tree element "//cp_to_string(tree_ptr%nr)//& " stat "//cp_to_string(tree_ptr%stat)//" is UNknown",& - error,failure) + failure) END SELECT ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(last_acc),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(last_acc),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,failure) END SUBROUTINE search_end_of_clean_g_tree ! ***************************************************************************** @@ -506,14 +484,11 @@ END SUBROUTINE search_end_of_clean_g_tree !> node in the tree branch !> \param tree_ptr ... !> \param last_acc ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - RECURSIVE SUBROUTINE search_end_of_clean_tree(tree_ptr, last_acc, error) + RECURSIVE SUBROUTINE search_end_of_clean_tree(tree_ptr, last_acc) TYPE(tree_type), POINTER :: tree_ptr TYPE(tree_type), INTENT(IN), POINTER :: last_acc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'search_end_of_clean_tree', & routineP = moduleN//':'//routineN @@ -522,8 +497,8 @@ RECURSIVE SUBROUTINE search_end_of_clean_tree(tree_ptr, last_acc, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(last_acc),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(last_acc),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -531,16 +506,16 @@ RECURSIVE SUBROUTINE search_end_of_clean_tree(tree_ptr, last_acc, error) IF(.NOT.ASSOCIATED(last_acc, tree_ptr)) THEN IF(ASSOCIATED(tree_ptr%acc).AND..NOT.ASSOCIATED(tree_ptr%nacc))THEN tree_ptr => tree_ptr%acc - CALL search_end_of_clean_tree(tree_ptr, last_acc, error) + CALL search_end_of_clean_tree(tree_ptr, last_acc) ELSE IF(ASSOCIATED(tree_ptr%nacc).AND..NOT.ASSOCIATED(tree_ptr%acc))THEN tree_ptr => tree_ptr%nacc - CALL search_end_of_clean_tree(tree_ptr, last_acc, error) + CALL search_end_of_clean_tree(tree_ptr, last_acc) END IF END IF ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(last_acc),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(last_acc),cp_failure_level,routineP,failure) END SUBROUTINE search_end_of_clean_tree ! ***************************************************************************** @@ -551,17 +526,13 @@ END SUBROUTINE search_end_of_clean_tree !> \param prob the acceptance probability of the tree element to define !> the direction to start with !> \param tmc_env TMC environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 12.2012 ! ***************************************************************************** - RECURSIVE SUBROUTINE search_canceling_elements(pt_elem_in, prob, tmc_env,& - error) + RECURSIVE SUBROUTINE search_canceling_elements(pt_elem_in, prob, tmc_env) TYPE(global_tree_type), INTENT(IN), & POINTER :: pt_elem_in REAL(KIND=dp), OPTIONAL :: prob TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'search_canceling_elements', & routineP = moduleN//':'//routineN @@ -572,8 +543,8 @@ RECURSIVE SUBROUTINE search_canceling_elements(pt_elem_in, prob, tmc_env,& failure = .FALSE. NULLIFY(pt_elem, act_pt_ptr) - CPPrecondition(ASSOCIATED(pt_elem_in),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pt_elem_in),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -603,47 +574,41 @@ RECURSIVE SUBROUTINE search_canceling_elements(pt_elem_in, prob, tmc_env,& CASE(status_calculate_NMC_steps, status_calculate_MD, & status_calculate_energy) CALL search_and_remove_reference_in_list(gt_ptr=pt_elem, & - elem=pt_elem%conf(pt_elem%mv_conf)%elem, tmc_env=tmc_env, & - error=error) + elem=pt_elem%conf(pt_elem%mv_conf)%elem, tmc_env=tmc_env) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown status of subtree element"//& cp_to_string(pt_elem%conf(pt_elem%mv_conf)%elem%stat),& - error,failure) + failure) END SELECT END IF !-- go until the ends ot he tree, to search for elements to cancel !-- check if child nodes exist IF(ASSOCIATED(pt_elem%acc))THEN act_pt_ptr => pt_elem%acc - CALL search_canceling_elements(pt_elem_in=act_pt_ptr,tmc_env=tmc_env,& - error=error) + CALL search_canceling_elements(pt_elem_in=act_pt_ptr,tmc_env=tmc_env) END IF IF(ASSOCIATED(pt_elem%nacc))THEN act_pt_ptr => pt_elem%nacc - CALL search_canceling_elements(pt_elem_in=act_pt_ptr,tmc_env=tmc_env,& - error=error) + CALL search_canceling_elements(pt_elem_in=act_pt_ptr,tmc_env=tmc_env) END IF END IF ! end the timing CALL timestop(handle) - CPPostcondition(ASSOCIATED(pt_elem_in),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(pt_elem_in),cp_failure_level,routineP,failure) END SUBROUTINE search_canceling_elements ! ***************************************************************************** !> \brief searches for created configurations in all subtrees !> \param global_tree_ptr pointer to one global tree element !> \param counters array returning the counters for each subtree -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - SUBROUTINE count_prepared_nodes_in_trees(global_tree_ptr, counters, error) + SUBROUTINE count_prepared_nodes_in_trees(global_tree_ptr, counters) TYPE(global_tree_type), INTENT(IN), & POINTER :: global_tree_ptr INTEGER, DIMENSION(:), POINTER :: counters - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'count_prepared_nodes_in_trees', & @@ -656,9 +621,9 @@ SUBROUTINE count_prepared_nodes_in_trees(global_tree_ptr, counters, error) failure = .FALSE. NULLIFY(begin_ptr) - CPPrecondition(ASSOCIATED(global_tree_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(counters),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(counters(1:)).EQ.SIZE(global_tree_ptr%conf(:)),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(global_tree_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(counters),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(counters(1:)).EQ.SIZE(global_tree_ptr%conf(:)),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -667,7 +632,7 @@ SUBROUTINE count_prepared_nodes_in_trees(global_tree_ptr, counters, error) DO i=1, SIZE(global_tree_ptr%conf(:)) begin_ptr => global_tree_ptr%conf(i)%elem CALL count_prepared_nodes_in_subtree(tree_ptr=begin_ptr, & - counter=counters(i), error=error) + counter=counters(i)) END DO ! end the timing @@ -679,14 +644,11 @@ END SUBROUTINE count_prepared_nodes_in_trees !> \param tree_ptr pointer to one subtree element !> \param counter returning the amount of prepared !> (ready for energy calculation) elements ind certain sub tree -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - RECURSIVE SUBROUTINE count_prepared_nodes_in_subtree(tree_ptr, counter,error) + RECURSIVE SUBROUTINE count_prepared_nodes_in_subtree(tree_ptr, counter) TYPE(tree_type), POINTER :: tree_ptr INTEGER :: counter - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'count_prepared_nodes_in_subtree', & @@ -698,29 +660,29 @@ RECURSIVE SUBROUTINE count_prepared_nodes_in_subtree(tree_ptr, counter,error) failure = .FALSE. NULLIFY(tmp_ptr) - CPPrecondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tree_ptr),cp_failure_level,routineP,failure) SELECT CASE(tree_ptr%stat) CASE(status_accepted, status_accepted_result) IF(ASSOCIATED(tree_ptr%acc)) THEN tmp_ptr => tree_ptr%acc - CALL count_prepared_nodes_in_subtree(tmp_ptr, counter, error) + CALL count_prepared_nodes_in_subtree(tmp_ptr, counter) END IF CASE(status_rejected, status_rejected_result) IF(ASSOCIATED(tree_ptr%nacc)) THEN tmp_ptr => tree_ptr%nacc - CALL count_prepared_nodes_in_subtree(tmp_ptr, counter, error) + CALL count_prepared_nodes_in_subtree(tmp_ptr, counter) END IF CASE(status_created, status_calculate_MD, status_calculate_NMC_steps, & status_calc_approx_ener, status_calculated, status_calculate_energy) IF(tree_ptr%stat.EQ.status_created) counter = counter + 1 IF(ASSOCIATED(tree_ptr%acc)) THEN tmp_ptr => tree_ptr%acc - CALL count_prepared_nodes_in_subtree(tmp_ptr, counter, error) + CALL count_prepared_nodes_in_subtree(tmp_ptr, counter) END IF IF(ASSOCIATED(tree_ptr%nacc)) THEN tmp_ptr => tree_ptr%nacc - CALL count_prepared_nodes_in_subtree(tmp_ptr, counter, error) + CALL count_prepared_nodes_in_subtree(tmp_ptr, counter) END IF CASE(status_cancel_nmc, status_cancel_ener, status_canceled_nmc, & status_canceled_ener) @@ -729,8 +691,7 @@ RECURSIVE SUBROUTINE count_prepared_nodes_in_subtree(tree_ptr, counter,error) CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "stat "//cp_to_string(tree_ptr%stat)//& "of elem "//cp_to_string(tree_ptr%nr)//& - "unknown.",& - error) + "unknown.") END SELECT END SUBROUTINE count_prepared_nodes_in_subtree @@ -741,17 +702,14 @@ END SUBROUTINE count_prepared_nodes_in_subtree !> \param counters array returning the counters for each subtree !> \param head_elements_nr node number of the existing !> global and sub tree heads -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** SUBROUTINE count_nodes_in_trees(global_tree_ptr, end_of_clean_trees, & - counters, head_elements_nr, error) + counters, head_elements_nr) TYPE(global_tree_type), POINTER :: global_tree_ptr TYPE(elem_array_type), DIMENSION(:), & POINTER :: end_of_clean_trees INTEGER, DIMENSION(:), POINTER :: counters, head_elements_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'count_nodes_in_trees', & routineP = moduleN//':'//routineN @@ -764,10 +722,10 @@ SUBROUTINE count_nodes_in_trees(global_tree_ptr, end_of_clean_trees, & failure = .FALSE. NULLIFY(begin_gt_ptr, begin_ptr) - CPPrecondition(ASSOCIATED(global_tree_ptr),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(end_of_clean_trees),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(counters),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(counters(1:)).EQ.SIZE(global_tree_ptr%conf(:)),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(global_tree_ptr),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(end_of_clean_trees),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(counters),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(counters(1:)).EQ.SIZE(global_tree_ptr%conf(:)),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) @@ -779,7 +737,7 @@ SUBROUTINE count_nodes_in_trees(global_tree_ptr, end_of_clean_trees, & begin_gt_ptr => begin_gt_ptr%parent END DO head_elements_nr(0) = begin_gt_ptr%nr - CALL count_nodes_in_global_tree(begin_gt_ptr, counters(0), error) + CALL count_nodes_in_global_tree(begin_gt_ptr, counters(0)) DO i=1, SIZE(end_of_clean_trees(:)) begin_ptr => end_of_clean_trees(i)%elem DO @@ -787,7 +745,7 @@ SUBROUTINE count_nodes_in_trees(global_tree_ptr, end_of_clean_trees, & begin_ptr => begin_ptr%parent END DO head_elements_nr(i) = begin_ptr%nr - CALL count_nodes_in_tree(begin_ptr, counters(i), error) + CALL count_nodes_in_tree(begin_ptr, counters(i)) END DO ! end the timing @@ -798,15 +756,12 @@ END SUBROUTINE count_nodes_in_trees !> \brief counts existing nodes in global tree !> \param ptr global tree head !> \param counter return value with the amount of existing global tree elements -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - RECURSIVE SUBROUTINE count_nodes_in_global_tree(ptr, counter, error) + RECURSIVE SUBROUTINE count_nodes_in_global_tree(ptr, counter) TYPE(global_tree_type), INTENT(IN), & POINTER :: ptr INTEGER, INTENT(INOUT) :: counter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'count_nodes_in_global_tree', & routineP = moduleN//':'//routineN @@ -814,28 +769,25 @@ RECURSIVE SUBROUTINE count_nodes_in_global_tree(ptr, counter, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,failure) counter = counter +1 IF(ASSOCIATED(ptr%acc)) & - CALL count_nodes_in_global_tree(ptr%acc, counter, error) + CALL count_nodes_in_global_tree(ptr%acc, counter) IF(ASSOCIATED(ptr%nacc)) & - CALL count_nodes_in_global_tree(ptr%nacc, counter, error) + CALL count_nodes_in_global_tree(ptr%nacc, counter) END SUBROUTINE count_nodes_in_global_tree ! ***************************************************************************** !> \brief counts existing nodes in certain sub tree !> \param ptr subtree tree head !> \param counter return value with the amount of existing sub tree elements -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - RECURSIVE SUBROUTINE count_nodes_in_tree(ptr, counter, error) + RECURSIVE SUBROUTINE count_nodes_in_tree(ptr, counter) TYPE(tree_type), POINTER :: ptr INTEGER :: counter - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'count_nodes_in_tree', & routineP = moduleN//':'//routineN @@ -843,13 +795,13 @@ RECURSIVE SUBROUTINE count_nodes_in_tree(ptr, counter, error) LOGICAL :: failure failure = .FALSE. - CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(ptr),cp_failure_level,routineP,failure) counter = counter +1 IF(ASSOCIATED(ptr%acc)) & - CALL count_nodes_in_tree(ptr%acc, counter, error) + CALL count_nodes_in_tree(ptr%acc, counter) IF(ASSOCIATED(ptr%nacc)) & - CALL count_nodes_in_tree(ptr%nacc, counter, error) + CALL count_nodes_in_tree(ptr%nacc, counter) END SUBROUTINE count_nodes_in_tree END MODULE tmc_tree_search diff --git a/src/tmc/tmc_tree_types.F b/src/tmc/tmc_tree_types.F index 394b08528a..07f23eaf6c 100644 --- a/src/tmc/tmc_tree_types.F +++ b/src/tmc/tmc_tree_types.F @@ -172,15 +172,12 @@ MODULE tmc_tree_types !> \param list ... !> \param temp_ind ... !> \param nr ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE add_to_list(elem, list, temp_ind, nr, error) + SUBROUTINE add_to_list(elem, list, temp_ind, nr) TYPE(tree_type), POINTER :: elem TYPE(elem_list_type), POINTER :: list INTEGER, OPTIONAL :: temp_ind, nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'add_to_list', & routineP = moduleN//':'//routineN @@ -190,7 +187,7 @@ SUBROUTINE add_to_list(elem, list, temp_ind, nr, error) NULLIFY(list_elem_tmp, last) - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) ALLOCATE(list_elem_tmp) list_elem_tmp%elem => elem @@ -222,13 +219,10 @@ END SUBROUTINE add_to_list ! ***************************************************************************** !> \brief clean a certain element element list !> \param list ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE clean_list(list, error) + SUBROUTINE clean_list(list) TYPE(elem_list_type), POINTER :: list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'clean_list', & routineP = moduleN//':'//routineN @@ -248,15 +242,12 @@ END SUBROUTINE clean_list !> \brief prints out the TMC sub tree structure element unformated in file !> \param elem ... !> \param io_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE write_subtree_elem_unformated(elem, io_unit, error) + SUBROUTINE write_subtree_elem_unformated(elem, io_unit) TYPE(tree_type), POINTER :: elem INTEGER :: io_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'write_subtree_elem_unformated', & @@ -264,8 +255,8 @@ SUBROUTINE write_subtree_elem_unformated(elem, io_unit, error) LOGICAL :: failure - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(io_unit.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(io_unit.GT.0,cp_failure_level,routineP,failure) WRITE(io_unit) elem%nr, & elem%sub_tree_nr, & elem%stat, & @@ -276,34 +267,31 @@ SUBROUTINE write_subtree_elem_unformated(elem, io_unit, error) elem%e_pot_approx, & elem%ekin, & elem%ekin_before_md - CALL write_subtree_elem_darray(elem%pos, io_unit, error) - CALL write_subtree_elem_darray(elem%vel, io_unit, error) - CALL write_subtree_elem_darray(elem%frc, io_unit, error) - CALL write_subtree_elem_darray(elem%box_scale, io_unit, error) - CALL write_subtree_elem_darray(elem%dipole, io_unit, error) + CALL write_subtree_elem_darray(elem%pos, io_unit) + CALL write_subtree_elem_darray(elem%vel, io_unit) + CALL write_subtree_elem_darray(elem%frc, io_unit) + CALL write_subtree_elem_darray(elem%box_scale, io_unit) + CALL write_subtree_elem_darray(elem%dipole, io_unit) END SUBROUTINE write_subtree_elem_unformated ! ***************************************************************************** !> \brief reads the TMC sub tree structure element unformated in file !> \param elem ... !> \param io_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE read_subtree_elem_unformated(elem, io_unit, error) + SUBROUTINE read_subtree_elem_unformated(elem, io_unit) TYPE(tree_type), POINTER :: elem INTEGER :: io_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_subtree_elem_unformated', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,error,failure) - CPPrecondition(io_unit.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(elem),cp_failure_level,routineP,failure) + CPPrecondition(io_unit.GT.0,cp_failure_level,routineP,failure) READ(io_unit) elem%nr, & elem%sub_tree_nr, & @@ -315,23 +303,21 @@ SUBROUTINE read_subtree_elem_unformated(elem, io_unit, error) elem%e_pot_approx, & elem%ekin, & elem%ekin_before_md - CALL read_subtree_elem_darray(elem%pos, io_unit, error) - CALL read_subtree_elem_darray(elem%vel, io_unit, error) - CALL read_subtree_elem_darray(elem%frc, io_unit, error) - CALL read_subtree_elem_darray(elem%box_scale, io_unit, error) - CALL read_subtree_elem_darray(elem%dipole, io_unit, error) + CALL read_subtree_elem_darray(elem%pos, io_unit) + CALL read_subtree_elem_darray(elem%vel, io_unit) + CALL read_subtree_elem_darray(elem%frc, io_unit) + CALL read_subtree_elem_darray(elem%box_scale, io_unit) + CALL read_subtree_elem_darray(elem%dipole, io_unit) END SUBROUTINE read_subtree_elem_unformated ! ***************************************************************************** !> \brief ... !> \param array ... !> \param io_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_subtree_elem_darray(array, io_unit, error) + SUBROUTINE write_subtree_elem_darray(array, io_unit) REAL(KIND=dp), DIMENSION(:), POINTER :: array INTEGER :: io_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_subtree_elem_darray', & routineP = moduleN//':'//routineN @@ -347,12 +333,10 @@ END SUBROUTINE write_subtree_elem_darray !> \brief ... !> \param array ... !> \param io_unit ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_subtree_elem_darray(array, io_unit, error) + SUBROUTINE read_subtree_elem_darray(array, io_unit) REAL(KIND=dp), DIMENSION(:), POINTER :: array INTEGER :: io_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_subtree_elem_darray', & routineP = moduleN//':'//routineN @@ -364,7 +348,7 @@ SUBROUTINE read_subtree_elem_darray(array, io_unit, error) IF(l_tmp) THEN READ(io_unit) i_tmp IF(ASSOCIATED(array)) THEN - CPPostcondition(SIZE(array).EQ.i_tmp,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(array).EQ.i_tmp,cp_failure_level,routineP,failure) ELSE ALLOCATE(array(i_tmp)) END IF diff --git a/src/tmc/tmc_types.F b/src/tmc/tmc_types.F index a3d4885b29..1848ea1971 100644 --- a/src/tmc/tmc_types.F +++ b/src/tmc/tmc_types.F @@ -173,13 +173,10 @@ MODULE tmc_types ! ***************************************************************************** !> \brief creates a new structure environment for TMC !> \param tmc_env structure with parameters for TMC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_env_create(tmc_env,error) + SUBROUTINE tmc_env_create(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_env_create', & routineP = moduleN//':'//routineN @@ -191,13 +188,13 @@ SUBROUTINE tmc_env_create(tmc_env,error) CALL timeset(routineN,handle) - CPPrecondition(.NOT.ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ALLOCATE(tmc_env,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmc_env%tmc_comp_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmc_env%tmc_comp_set%group_ener_size = 0 tmc_env%tmc_comp_set%group_ener_nr = 0 @@ -217,7 +214,7 @@ SUBROUTINE tmc_env_create(tmc_env,error) ! initialize the parameter section ALLOCATE(tmc_env%params,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmc_env%params%task_type = task_type_MC ! dim_per_elem can be variable somewhen, @@ -249,13 +246,10 @@ END SUBROUTINE tmc_env_create ! ***************************************************************************** !> \brief releases the structure environment for TMC !> \param tmc_env structure with parameters for TMC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_env_release(tmc_env,error) + SUBROUTINE tmc_env_release(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_env_release', & routineP = moduleN//':'//routineN @@ -267,8 +261,8 @@ SUBROUTINE tmc_env_release(tmc_env,error) CALL timeset(routineN,handle) - CPPostcondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) DEALLOCATE(tmc_env%params%sub_box_size) IF(ASSOCIATED(tmc_env%params%Temp)) & @@ -276,24 +270,24 @@ SUBROUTINE tmc_env_release(tmc_env,error) IF(ASSOCIATED(tmc_env%params%cell)) & DEALLOCATE(tmc_env%params%cell) IF(ASSOCIATED(tmc_env%params%atoms)) & - CALL deallocate_tmc_atom_type(tmc_env%params%atoms, error) + CALL deallocate_tmc_atom_type(tmc_env%params%atoms) DEALLOCATE(tmc_env%params,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_sub_group,error) - CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_w,error) + CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_sub_group) + CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_w) IF(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w))& - CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_first_w,error) + CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_first_w) IF(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana))& - CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_ana,error) + CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_ana) IF(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_only))& - CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_only,error) + CALL cp_para_env_release(tmc_env%tmc_comp_set%para_env_m_only) DEALLOCATE(tmc_env%tmc_comp_set,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmc_env,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -302,13 +296,10 @@ END SUBROUTINE tmc_env_release ! ***************************************************************************** !> \brief creates a new structure environment for TMC master !> \param tmc_env structure with parameters for TMC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_master_env_create(tmc_env,error) + SUBROUTINE tmc_master_env_create(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_master_env_create', & routineP = moduleN//':'//routineN @@ -320,11 +311,11 @@ SUBROUTINE tmc_master_env_create(tmc_env,error) CALL timeset(routineN,handle) - CPPostcondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) - CPPostcondition(tmc_env%params%nr_temp.GT.0,cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPostcondition(tmc_env%params%nr_temp.GT.0,cp_failure_level,routineP,failure) - CPPostcondition(.NOT.ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) ALLOCATE(tmc_env%m_env) NULLIFY(tmc_env%m_env%gt_head, tmc_env%m_env%gt_act, tmc_env%m_env%tree_node_count, & @@ -368,13 +359,10 @@ END SUBROUTINE tmc_master_env_create ! ***************************************************************************** !> \brief releases the structure environment for TMC master !> \param tmc_env structure with parameters for TMC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_master_env_release(tmc_env,error) + SUBROUTINE tmc_master_env_release(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_master_env_release', & routineP = moduleN//':'//routineN @@ -386,11 +374,11 @@ SUBROUTINE tmc_master_env_release(tmc_env,error) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%m_env),cp_failure_level,routineP,failure) - CALL clean_list(tmc_env%m_env%analysis_list, error) - CALL clean_list(tmc_env%m_env%cancelation_list, error) + CALL clean_list(tmc_env%m_env%analysis_list) + CALL clean_list(tmc_env%m_env%cancelation_list) DEALLOCATE(tmc_env%m_env%tree_node_count) DEALLOCATE(tmc_env%m_env%result_count) @@ -408,13 +396,10 @@ END SUBROUTINE tmc_master_env_release ! ***************************************************************************** !> \brief creates a new structure environment for TMC master !> \param tmc_env structure with parameters for TMC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_worker_env_create(tmc_env,error) + SUBROUTINE tmc_worker_env_create(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_worker_env_create', & routineP = moduleN//':'//routineN @@ -426,8 +411,8 @@ SUBROUTINE tmc_worker_env_create(tmc_env,error) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(tmc_env%w_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(tmc_env%w_env),cp_failure_level,routineP,failure) ALLOCATE(tmc_env%w_env) @@ -443,13 +428,10 @@ END SUBROUTINE tmc_worker_env_create ! ***************************************************************************** !> \brief releases the structure environment for TMC master !> \param tmc_env structure with parameters for TMC -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE tmc_worker_env_release(tmc_env,error) + SUBROUTINE tmc_worker_env_release(tmc_env) TYPE(tmc_env_type), POINTER :: tmc_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'tmc_worker_env_release', & routineP = moduleN//':'//routineN @@ -461,8 +443,8 @@ SUBROUTINE tmc_worker_env_release(tmc_env,error) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%w_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%w_env),cp_failure_level,routineP,failure) DEALLOCATE(tmc_env%w_env) @@ -474,54 +456,48 @@ END SUBROUTINE tmc_worker_env_release !> \brief creates a structure for storing the atom informations !> \param atoms pointer to a list of tmc_atoms_type !> \param nr_atoms the amount of atoms -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - SUBROUTINE allocate_tmc_atom_type(atoms, nr_atoms, error) + SUBROUTINE allocate_tmc_atom_type(atoms, nr_atoms) TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms INTEGER, INTENT(IN) :: nr_atoms - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_tmc_atom_type', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(.NOT.ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(nr_atoms.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(atoms),cp_failure_level,routineP,failure) + CPPrecondition(nr_atoms.GT.0,cp_failure_level,routineP,failure) ALLOCATE(atoms(nr_atoms)) atoms%name = "" atoms%mass = 0.0_dp - CPPostcondition(ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(atoms),cp_failure_level,routineP,failure) END SUBROUTINE allocate_tmc_atom_type ! ***************************************************************************** !> \brief releases the structure for storing the atom informations !> \param atoms pointer to a list of tmc_atoms_type -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - SUBROUTINE deallocate_tmc_atom_type(atoms, error) + SUBROUTINE deallocate_tmc_atom_type(atoms) TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_tmc_atom_type', & routineP = moduleN//':'//routineN LOGICAL :: failure - CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(atoms),cp_failure_level,routineP,failure) DEALLOCATE(atoms) - CPPostcondition(.NOT.ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(atoms),cp_failure_level,routineP,failure) END SUBROUTINE deallocate_tmc_atom_type END MODULE tmc_types diff --git a/src/tmc/tmc_worker.F b/src/tmc/tmc_worker.F index 08fdd1049f..3a78f9e6a1 100644 --- a/src/tmc/tmc_worker.F +++ b/src/tmc/tmc_worker.F @@ -112,15 +112,12 @@ MODULE tmc_worker !> \brief worker get tasks form master and fulfill them !> \param tmc_env structure for storing all the tmc parameters !> \param ana_list ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) + SUBROUTINE do_tmc_worker(tmc_env, ana_list) TYPE(tmc_env_type), POINTER :: tmc_env TYPE(tmc_ana_list_type), DIMENSION(:), & OPTIONAL, POINTER :: ana_list - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'do_tmc_worker', & routineP = moduleN//':'//routineN @@ -139,14 +136,14 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) i2 = -1 NULLIFY(conf, para_env_m_w, ana_restart_conf) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) ! initialize IF(tmc_env%tmc_comp_set%group_nr.GT.0) THEN - CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group),cp_failure_level,routineP,failure) IF(tmc_env%w_env%env_id_ener.GT.0) THEN itmp = tmc_env%w_env%env_id_ener ELSE @@ -154,14 +151,13 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) END IF CALL get_atom_kinds_and_cell(env_id=itmp, & - atoms=tmc_env%params%atoms, cell=tmc_env%params%cell, error=error) + atoms=tmc_env%params%atoms, cell=tmc_env%params%cell) para_env_m_w => tmc_env%tmc_comp_set%para_env_m_w - master = check_if_group_master(tmc_env%tmc_comp_set%para_env_sub_group, & - error) -! CALL get_mimal_distances( , error) + master = check_if_group_master(tmc_env%tmc_comp_set%para_env_sub_group) +! CALL get_mimal_distances() ELSE ! analysis group - CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana),cp_failure_level,routineP,failure) para_env_m_w => tmc_env%tmc_comp_set%para_env_m_ana master = .TRUE. END IF @@ -180,11 +176,11 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) ! and sending additional information (e.g. the intermediate scf energies) IF(tmc_env%params%use_scf_energy_info) & CALL set_intermediate_info_comm(env_id=itmp, & - comm=tmc_env%tmc_comp_set%para_env_m_w%group, error=error) + comm=tmc_env%tmc_comp_set%para_env_m_w%group) IF(tmc_env%params%SPECULATIVE_CANCELING) & CALL set_external_comm(comm=tmc_env%tmc_comp_set%para_env_m_w%group, & in_external_master_id=MASTER_COMM_ID, & - in_exit_tag=TMC_CANCELING_MESSAGE, error=error) + in_exit_tag=TMC_CANCELING_MESSAGE) END IF !-- WORKING LOOP --! master_work_time: DO @@ -196,8 +192,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) dest=itmp, & para_env=para_env_m_w, & result_count=ana_restart_conf,& - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) IF(DEBUG.GE.1.AND.work_stat.NE.TMC_STATUS_WAIT_FOR_NEW_TASK) & WRITE(tmc_env%w_env%io_unit,*)"worker: group master of group ", & @@ -211,15 +206,14 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & para_env=tmc_env%tmc_comp_set%para_env_sub_group,& - tmc_params=tmc_env%params, & - error=error) + tmc_params=tmc_env%params) CASE(TMC_CANCELING_MESSAGE) work_stat = TMC_CANCELING_RECEIPT itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & para_env=para_env_m_w, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) CASE(TMC_STATUS_FAILED) IF(DEBUG.GE.1) & WRITE(tmc_env%w_env%io_unit,*) "master worker of group", & @@ -233,7 +227,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) itmp = tmc_env%w_env%env_id_approx END IF CALL get_initial_conf(tmc_params=tmc_env%params,init_conf=conf,& - env_id=itmp, error=error) + env_id=itmp) ! send start configuration back to master work_stat = TMC_STAT_START_CONF_RESULT itmp = MASTER_COMM_ID @@ -241,62 +235,57 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) dest=itmp, & para_env=para_env_m_w, & tmc_params=tmc_env%params, elem=conf, & - wait_for_message=.TRUE., error=error) + wait_for_message=.TRUE.) IF(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_first_w))& CALL communicate_atom_types(atoms=tmc_env%params%atoms, & source=1, & - para_env=tmc_env%tmc_comp_set%para_env_m_first_w, & - error=error) + para_env=tmc_env%tmc_comp_set%para_env_m_first_w) !-- calculate the approximate energy CASE(TMC_STAT_APPROX_ENERGY_REQUEST) - CPPrecondition(tmc_env%w_env%env_id_approx.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(tmc_env%w_env%env_id_approx.GT.0,cp_failure_level,routineP,failure) itmp = bcast_group !-- DISTRIBUTING WORK (group master) to all other group members CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & para_env=tmc_env%tmc_comp_set%para_env_sub_group,& - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & exact_approx_pot=.FALSE., & - tmc_env=tmc_env, & - error=error) + tmc_env=tmc_env) work_stat = TMC_STAT_APPROX_ENERGY_RESULT itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & para_env=para_env_m_w, & - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) ! -- Nested Monte Carlo routines CASE(TMC_STAT_MD_REQUEST, TMC_STAT_NMC_REQUEST) - CALL clear_move_probs(tmc_env%params%nmc_move_types, error) + CALL clear_move_probs(tmc_env%params%nmc_move_types) itmp = bcast_group CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & para_env=tmc_env%tmc_comp_set%para_env_sub_group,& - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) !-- collective calculation for MD/NMC steps IF(work_stat.EQ.TMC_STAT_NMC_REQUEST)THEN !-- calculate MD steps, in case of 2 different potentials do nested Monte Carlo CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx,& - tmc_env=tmc_env, calc_status=calc_stat, error=error) + tmc_env=tmc_env, calc_status=calc_stat) ELSEIF(work_stat.EQ.TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "there is no Hybrid MC implemented yet.",& - error, only_ionode=.TRUE.) + only_ionode=.TRUE.) ELSE CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "unknown task type for workers.",& - error, only_ionode=.TRUE.) + only_ionode=.TRUE.) END IF !-- in case of cancelation send receipt itmp = MASTER_COMM_ID @@ -304,7 +293,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) dest=itmp, & para_env=para_env_m_w, & tmc_params=tmc_env%params, & - success=flag, error=error) + success=flag) SELECT CASE(calc_stat) CASE(TMC_STATUS_CALCULATING) SELECT CASE(work_stat) @@ -316,8 +305,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,& "unknown work status after possible NMC subgroup "//& - "cancelation, work_stat="//cp_to_string(work_stat),& - error) + "cancelation, work_stat="//cp_to_string(work_stat)) END SELECT CASE(TMC_CANCELING_MESSAGE) work_stat = TMC_CANCELING_RECEIPT @@ -325,38 +313,34 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,& "unknown calc status before sending NMC result "//& - cp_to_string(calc_stat),error) + cp_to_string(calc_stat)) END SELECT ! send message back to master itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & para_env=para_env_m_w, & - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) CASE(TMC_STAT_ENERGY_REQUEST) - CPPrecondition(tmc_env%w_env%env_id_ener.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(tmc_env%w_env%env_id_ener.GT.0,cp_failure_level,routineP,failure) !-- DISTRIBUTING WORK (group master) to all other group members itmp = bcast_group CALL tmc_message(msg_type=work_stat, send_recv=send_msg, & dest=itmp, & para_env=tmc_env%tmc_comp_set%para_env_sub_group,& - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_ener, & exact_approx_pot=.TRUE., & - tmc_env=tmc_env, & - error=error) + tmc_env=tmc_env) !-- in case of cancelation send receipt flag = .FALSE. itmp = MASTER_COMM_ID CALL tmc_message(msg_type=calc_stat, send_recv=recv_msg, & dest=itmp, & para_env=para_env_m_w,& - tmc_params=tmc_env%params, success=flag,& - error=error) + tmc_params=tmc_env%params, success=flag) SELECT CASE(calc_stat) CASE(TMC_STATUS_CALCULATING) SELECT CASE(work_stat) @@ -373,13 +357,13 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL cp_assert(flag, cp_failure_level,cp_assertion_failed,& routineP,& "TMC: The requested dipoles are not porvided by the "//& - "force environment.", error) + "force environment.") END IF CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,& "energy worker should handle unknown stat "//& - cp_to_string(work_stat),error) + cp_to_string(work_stat)) END SELECT CASE(TMC_CANCELING_MESSAGE) work_stat = TMC_CANCELING_RECEIPT @@ -387,7 +371,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,& "worker while energy calc is in unknown state "//& - cp_to_string(work_stat),error) + cp_to_string(work_stat)) END SELECT !-- send information back to master @@ -399,17 +383,15 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL tmc_message(msg_type=work_stat, send_recv=send_msg,& dest=itmp, & para_env=para_env_m_w,& - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) CASE(TMC_STAT_INIT_ANALYSIS) - CPPostcondition(ASSOCIATED(ana_restart_conf),cp_failure_level,routineP,error,failure) - CPPostcondition(SIZE(ana_restart_conf).EQ.tmc_env%params%nr_temp,cp_failure_level,routineP,error,failure) - CPPrecondition(PRESENT(ana_list),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_list),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ana_restart_conf),cp_failure_level,routineP,failure) + CPPostcondition(SIZE(ana_restart_conf).EQ.tmc_env%params%nr_temp,cp_failure_level,routineP,failure) + CPPrecondition(PRESENT(ana_list),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_list),cp_failure_level,routineP,failure) itmp = MASTER_COMM_ID CALL communicate_atom_types(atoms=tmc_env%params%atoms, & - source=itmp, para_env=tmc_env%tmc_comp_set%para_env_m_ana,& - error=error) + source=itmp, para_env=tmc_env%tmc_comp_set%para_env_m_ana) num_dim = SIZE(conf%pos) DO itmp=1, tmc_env%params%nr_temp @@ -419,15 +401,13 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) ana_list(itmp)%temp%cell => tmc_env%params%cell ! ana_list(itmp)%temp%io_unit = tmc_env%w_env%io_unit - CALL analysis_init(ana_env=ana_list(itmp)%temp, nr_dim=num_dim,& - error=error) + CALL analysis_init(ana_env=ana_list(itmp)%temp, nr_dim=num_dim) ana_list(itmp)%temp%print_test_output = tmc_env%params%print_test_output IF(.NOT.ASSOCIATED(conf)) & CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & - next_el=conf, nr_dim=num_dim, & - error=error) + next_el=conf, nr_dim=num_dim) CALL analysis_restart_read(ana_env=ana_list(itmp)%temp, & - elem=conf, error=error) + elem=conf) !check if we have the read the file flag = .FALSE. IF((.NOT.ASSOCIATED(ana_list(itmp)%temp%last_elem)) .AND. & @@ -440,7 +420,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) routineP,& "analysis old trajectory up to "//& "elem "//cp_to_string(ana_restart_conf(itmp))//& - ". Read trajectory file.",error) + ". Read trajectory file.") ELSE IF(ASSOCIATED(ana_list(itmp)%temp%last_elem))THEN IF(.NOT.(ana_list(itmp)%temp%last_elem%nr.EQ.ana_restart_conf(itmp))) THEN flag = .TRUE. @@ -452,34 +432,32 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) "analysis restart with the incorrect configuration "//& "TMC "//cp_to_string(ana_restart_conf(itmp))//& " ana "//cp_to_string(ana_list(itmp)%temp%last_elem%nr)//& - ". REread trajectory file.",error) + ". REread trajectory file.") END IF END IF IF(flag) THEN CALL analyze_file_configurations(start_id=i1, & end_id=i2, & ana_env=ana_list(itmp)%temp, & - tmc_params=tmc_env%params,& - error=error) + tmc_params=tmc_env%params) END IF END DO CASE(TMC_STAT_ANALYSIS_REQUEST) - CPPrecondition(PRESENT(ana_list),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(ana_list(conf%sub_tree_nr)%temp),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(ana_list),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(ana_list(conf%sub_tree_nr)%temp),cp_failure_level,routineP,failure) CALL do_tmc_analysis(elem=conf, & - ana_env=ana_list(conf%sub_tree_nr)%temp, error=error) + ana_env=ana_list(conf%sub_tree_nr)%temp) work_stat = TMC_STAT_ANALYSIS_RESULT itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg,& dest=itmp, & para_env=para_env_m_w,& - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,& "worker received unknown message task type "//& - cp_to_string(work_stat),error) + cp_to_string(work_stat)) END SELECT IF(DEBUG.GE.1.AND.work_stat.NE.TMC_STATUS_WAIT_FOR_NEW_TASK) & @@ -487,7 +465,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) tmc_env%tmc_comp_set%group_nr, & "send back status:", work_stat IF(ASSOCIATED(conf)) & - CALL deallocate_sub_tree_node(tree_elem=conf, error=error) + CALL deallocate_sub_tree_node(tree_elem=conf) END DO master_work_time !-- every other group paricipants---------------------------------------- ELSE @@ -498,8 +476,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL tmc_message(msg_type=work_stat, send_recv=recv_msg, & dest=itmp, & para_env=tmc_env%tmc_comp_set%para_env_sub_group,& - tmc_params=tmc_env%params, elem=conf, & - error=error) + tmc_params=tmc_env%params, elem=conf) calc_stat = TMC_STATUS_CALCULATING SELECT CASE(work_stat) CASE(TMC_STATUS_WORKER_INIT) @@ -510,7 +487,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) EXIT worker_work_time ! all group members have to calculate the (MD potential) energy together CASE(TMC_STAT_START_CONF_RESULT) - CPPrecondition(tmc_env%w_env%env_id_approx.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(tmc_env%w_env%env_id_approx.GT.0,cp_failure_level,routineP,failure) !-- collective calculation of the potential energy of MD potential SELECT CASE(tmc_env%params%task_type) CASE(task_type_MC, task_type_ideal_gas) @@ -519,14 +496,13 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & exact_approx_pot=.FALSE., & - tmc_env=tmc_env, & - error=error) + tmc_env=tmc_env) END IF CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,& "unknown task_type for participants in "//& - "START_CONF_RESULT request ",error) + "START_CONF_RESULT request ") END SELECT !-- HMC - calculating MD steps CASE(TMC_STAT_NMC_REQUEST, TMC_STAT_MD_REQUEST) @@ -535,56 +511,53 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) !-- calculate MD steps, in case of 2 different potentials do nested Monte Carlo CALL nested_markov_chain_MC(conf=conf, & env_id=tmc_env%w_env%env_id_approx,& - tmc_env=tmc_env, calc_status=calc_stat, error=error) + tmc_env=tmc_env, calc_status=calc_stat) ELSEIF(work_stat.EQ.TMC_STAT_MD_REQUEST) THEN !TODO Hybrid MC routine CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "there is no Hybrid MC implemented yet.",& - error, only_ionode=.TRUE.) + only_ionode=.TRUE.) ELSE CALL cp_assert(.FALSE.,& cp_failure_level,cp_assertion_failed,routineP,& "unknown task type for workers.",& - error, only_ionode=.TRUE.) + only_ionode=.TRUE.) END IF !-- energy calculations CASE(TMC_STAT_APPROX_ENERGY_REQUEST) !--- do calculate energy - CPPrecondition(tmc_env%w_env%env_id_approx.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(tmc_env%w_env%env_id_approx.GT.0,cp_failure_level,routineP,failure) CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_approx, & exact_approx_pot=.FALSE., & - tmc_env=tmc_env, & - error=error) + tmc_env=tmc_env) CASE(TMC_STAT_ENERGY_REQUEST) !--- do calculate energy - CPPrecondition(tmc_env%w_env%env_id_ener.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(tmc_env%w_env%env_id_ener.GT.0,cp_failure_level,routineP,failure) CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_ener, & exact_approx_pot=.TRUE., & - tmc_env=tmc_env, & - error=error) + tmc_env=tmc_env) CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,& routineP,& "group participant got unknown working type "//& - cp_to_string(work_stat),error) + cp_to_string(work_stat)) END SELECT IF(ASSOCIATED(conf)) & - CALL deallocate_sub_tree_node(tree_elem=conf, error=error) + CALL deallocate_sub_tree_node(tree_elem=conf) END DO worker_work_time END IF ! -------------------------------------------------------------------- ! finalizing analysis, writing files etc. IF(ASSOCIATED(tmc_env%tmc_comp_set%para_env_m_ana))THEN DO itmp=1, tmc_env%params%nr_temp - CALL analysis_restart_print(ana_env=ana_list(itmp)%temp, & - error=error) + CALL analysis_restart_print(ana_env=ana_list(itmp)%temp) IF(ASSOCIATED(conf)) & - CALL deallocate_sub_tree_node(tree_elem=ana_list(itmp)%temp%last_elem, error=error) - CALL finalize_tmc_analysis(ana_list(itmp)%temp, error) + CALL deallocate_sub_tree_node(tree_elem=ana_list(itmp)%temp%last_elem) + CALL finalize_tmc_analysis(ana_list(itmp)%temp) END DO END IF !-- stopping and finalizing @@ -600,24 +573,24 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) ELSE itmp = tmc_env%w_env%env_id_approx END IF - CALL remove_intermediate_info_comm(env_id=itmp, error=error) + CALL remove_intermediate_info_comm(env_id=itmp) END IF END IF IF(ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group)) & CALL stop_whole_group(para_env=tmc_env%tmc_comp_set%para_env_sub_group,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) work_stat = TMC_STATUS_STOP_RECEIPT itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, dest=itmp,& para_env=para_env_m_w,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) ELSE IF(ASSOCIATED(tmc_env%tmc_comp_set%para_env_sub_group))THEN work_stat = TMC_STATUS_STOP_RECEIPT itmp = MASTER_COMM_ID CALL tmc_message(msg_type=work_stat, send_recv=send_msg, dest=itmp,& para_env=tmc_env%tmc_comp_set%para_env_sub_group,& - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) END IF IF(DEBUG.GE.5)& @@ -632,7 +605,7 @@ SUBROUTINE do_tmc_worker(tmc_env, ana_list, error) END DO END IF IF(ASSOCIATED(conf)) & - CALL deallocate_sub_tree_node(tree_elem=conf, error=error) + CALL deallocate_sub_tree_node(tree_elem=conf) IF(ASSOCIATED(ana_restart_conf)) DEALLOCATE(ana_restart_conf) ! end the timing @@ -648,17 +621,14 @@ END SUBROUTINE do_tmc_worker !> \param env_id ... !> \param tmc_env ... !> \param calc_status ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) + SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status) TYPE(tree_type), POINTER :: conf INTEGER, INTENT(IN) :: env_id TYPE(tmc_env_type), POINTER :: tmc_env INTEGER, INTENT(OUT) :: calc_status - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'nested_markov_chain_MC', & routineP = moduleN//':'//routineN @@ -671,20 +641,20 @@ SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) NULLIFY(last_acc_conf) - CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tmc_env%rng_stream),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,error,failure) - CPPrecondition(conf%temp_created.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(conf%temp_created.LE.tmc_env%params%nr_temp,cp_failure_level,routineP,error,failure) - CPPrecondition(env_id.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tmc_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%params),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%tmc_comp_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tmc_env%rng_stream),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(conf),cp_failure_level,routineP,failure) + CPPrecondition(conf%temp_created.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(conf%temp_created.LE.tmc_env%params%nr_temp,cp_failure_level,routineP,failure) + CPPrecondition(env_id.GT.0,cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, & - next_el=last_acc_conf, nr_dim=SIZE(conf%pos), error=error) + next_el=last_acc_conf, nr_dim=SIZE(conf%pos)) last_acc_conf%pos = conf%pos last_acc_conf%box_scale = conf%box_scale @@ -692,7 +662,7 @@ SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) ! energy of the last accepted configuration CALL calc_potential_energy(conf=last_acc_conf, & env_id=tmc_env%w_env%env_id_approx,exact_approx_pot=.FALSE.,& - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) NMC_steps: DO substeps=1, INT(tmc_env%params%move_types%mv_size(mv_type_NMC_moves,1)) ! check for canceling message @@ -703,13 +673,13 @@ SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) CALL tmc_message(msg_type=calc_status, send_recv=recv_msg, & dest=comm_dest, & para_env=tmc_env%tmc_comp_set%para_env_m_w, & - tmc_params=tmc_env%params, success=flag, error=error) + tmc_params=tmc_env%params, success=flag) END IF comm_dest = bcast_group CALL tmc_message(msg_type=calc_status, send_recv=send_msg, & dest=comm_dest, & para_env=tmc_env%tmc_comp_set%para_env_sub_group, & - tmc_params=tmc_env%params, error=error) + tmc_params=tmc_env%params) SELECT CASE(calc_status) CASE(TMC_STATUS_CALCULATING) ! keep on working @@ -719,29 +689,26 @@ SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) CASE DEFAULT CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "unknown status "//cp_to_string(calc_status)//& - "in the NMC routine, expect only caneling status. ",& - error) + "in the NMC routine, expect only caneling status. ") END SELECT ! set move type CALL set_rng_stream(rng_stream=tmc_env%rng_stream,& bg=conf%rng_seed(:,:,1), cg=conf%rng_seed(:,:,2),& - ig=conf%rng_seed(:,:,3), error=error) + ig=conf%rng_seed(:,:,3)) conf%move_type = select_random_move_type(& move_types=tmc_env%params%nmc_move_types, & - rnd=next_random_number(tmc_env%rng_stream, & - error=error), & - error=error) + rnd=next_random_number(tmc_env%rng_stream)) CALL get_rng_stream(rng_stream=tmc_env%rng_stream,& bg=conf%rng_seed(:,:,1), cg=conf%rng_seed(:,:,2),& - ig=conf%rng_seed(:,:,3), error=error) + ig=conf%rng_seed(:,:,3)) ! do move CALL change_pos(tmc_params=tmc_env%params, & move_types=tmc_env%params%nmc_move_types, & rng_stream=tmc_env%rng_stream,& elem=conf, mv_conf=1, new_subbox=.FALSE., & - move_rejected=change_rejected, error=error) + move_rejected=change_rejected) ! for Hybrid MC the change_pos is only velocity change, ! the actual MD step hast to be done in this module for communication reason IF(conf%move_type .EQ. mv_type_MD)THEN @@ -750,20 +717,19 @@ SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) !CALL calc_calc_e_kin(...) CALL cp_assert(.FALSE., cp_failure_level,cp_assertion_failed,routineP,& "Hybrid MC is not implemented yet, "//& - "(no MD section in TMC yet). ",& - error) + "(no MD section in TMC yet). ") END IF ! update the subbox acceptance probabilities CALL prob_update(move_types=tmc_env%params%nmc_move_types, elem=conf, & acc=.NOT.change_rejected, subbox=.TRUE., & - prob_opt=tmc_env%params%esimate_acc_prob, error=error) + prob_opt=tmc_env%params%esimate_acc_prob) ! calculate potential energy if neccessary IF(.NOT.change_rejected) THEN CALL calc_potential_energy(conf=conf, & env_id=tmc_env%w_env%env_id_approx, exact_approx_pot=.FALSE., & - tmc_env=tmc_env, error=error) + tmc_env=tmc_env) ELSE conf%e_pot_approx = HUGE(conf%e_pot_approx) END IF @@ -771,25 +737,24 @@ SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) !check NMC step CALL set_rng_stream(rng_stream=tmc_env%rng_stream, & bg=conf%rng_seed(:,:,1), cg=conf%rng_seed(:,:,2), & - ig=conf%rng_seed(:,:,3), error=error) - rnd_nr = next_random_number(tmc_env%rng_stream, error=error) + ig=conf%rng_seed(:,:,3)) + rnd_nr = next_random_number(tmc_env%rng_stream) CALL get_rng_stream(rng_stream=tmc_env%rng_stream, & bg=conf%rng_seed(:,:,1), cg=conf%rng_seed(:,:,2), & - ig=conf%rng_seed(:,:,3), error=error) + ig=conf%rng_seed(:,:,3)) IF(.NOT.change_rejected) THEN CALL acceptance_check(tree_element=conf, parent_element=last_acc_conf,& tmc_params=tmc_env%params, & temperature=tmc_env%params%Temp(conf%temp_created), & diff_pot_check=.FALSE.,& - accept=accept, approx_ener=.TRUE., rnd_nr=rnd_nr, error=error) + accept=accept, approx_ener=.TRUE., rnd_nr=rnd_nr) ELSE accept=.FALSE. END IF ! update the NMC accpetance per move CALL prob_update(move_types=tmc_env%params%nmc_move_types, elem=conf, & - acc=accept, prob_opt=tmc_env%params%esimate_acc_prob, & - error=error) + acc=accept, prob_opt=tmc_env%params%esimate_acc_prob) ! update last accepted configuration or actual configuration IF(accept.AND.(.NOT.change_rejected))THEN @@ -815,7 +780,7 @@ SUBROUTINE nested_markov_chain_MC(conf, env_id, tmc_env, calc_status, error) conf%ekin = last_acc_conf%ekin conf%ekin_before_md = last_acc_conf%ekin_before_md - CALL deallocate_sub_tree_node(tree_elem=last_acc_conf, error=error) + CALL deallocate_sub_tree_node(tree_elem=last_acc_conf) ! end the timing CALL timestop(handle) @@ -827,15 +792,12 @@ END SUBROUTINE nested_markov_chain_MC !> \param init_conf the structure the data should be stored !> force_env !> \param env_id ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 11.2012 ! ***************************************************************************** - SUBROUTINE get_initial_conf(tmc_params, init_conf, env_id, error) + SUBROUTINE get_initial_conf(tmc_params, init_conf, env_id) TYPE(tmc_param_type), POINTER :: tmc_params TYPE(tree_type), POINTER :: init_conf INTEGER :: env_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_initial_conf', & routineP = moduleN//':'//routineN @@ -848,27 +810,25 @@ SUBROUTINE get_initial_conf(tmc_params, init_conf, env_id, error) TYPE(mol_new_list_type), POINTER :: molecule_new failure = .FALSE. - CPPrecondition(.NOT.ASSOCIATED(init_conf),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(init_conf),cp_failure_level,routineP,failure) ! start the timing CALL timeset(routineN,handle) ! get positions CALL get_natom(env_id=env_id, n_atom=nr_atoms, ierr=ierr) - CPPostcondition(ierr.EQ.0,cp_failure_level,routineP,error,failure) + CPPostcondition(ierr.EQ.0,cp_failure_level,routineP,failure) ndim = 3*nr_atoms CALL allocate_new_sub_tree_node(tmc_params=tmc_params, & - next_el=init_conf, nr_dim=ndim, & - error=error) + next_el=init_conf, nr_dim=ndim) CALL get_pos(env_id=env_id, pos=init_conf%pos, n_el=SIZE(init_conf%pos), & ierr=ierr) ! get the molecule info - CALL f_env_get_from_id(env_id,f_env,error) - CALL force_env_get(f_env%force_env,subsys=subsys,error=error) + CALL f_env_get_from_id(env_id,f_env) + CALL force_env_get(f_env%force_env,subsys=subsys) - CALL cp_subsys_get(subsys=subsys, molecules_new=molecule_new,& - error=error) + CALL cp_subsys_get(subsys=subsys, molecules_new=molecule_new) loop_mol: DO mol=1, SIZE(molecule_new%els(:)) init_conf%mol(molecule_new%els(mol)%first_atom:& molecule_new%els(mol)%last_atom) = mol @@ -884,16 +844,13 @@ END SUBROUTINE get_initial_conf !> \param env_id ... !> \param atoms pointer to atomic_kind !> \param cell ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 01.2013 ! ***************************************************************************** - SUBROUTINE get_atom_kinds_and_cell(env_id, atoms, cell, error) + SUBROUTINE get_atom_kinds_and_cell(env_id, atoms, cell) INTEGER :: env_id TYPE(tmc_atom_type), DIMENSION(:), & POINTER :: atoms TYPE(cell_type), POINTER :: cell - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'get_atom_kinds_and_cell', & routineP = moduleN//':'//routineN @@ -910,26 +867,26 @@ SUBROUTINE get_atom_kinds_and_cell(env_id, atoms, cell, error) NULLIFY (f_env, subsys, particles) nr_atoms = 0 - CPPrecondition(env_id.GT.0,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(atoms),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(cell),cp_failure_level,routineP,error,failure) + CPPrecondition(env_id.GT.0,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(atoms),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(cell),cp_failure_level,routineP,failure) - CALL f_env_get_from_id(env_id,f_env,error) - nr_atoms = force_env_get_natom(f_env%force_env,error=error) - CALL force_env_get(f_env%force_env,subsys=subsys,cell=cell_tmp,error=error) + CALL f_env_get_from_id(env_id,f_env) + nr_atoms = force_env_get_natom(f_env%force_env) + CALL force_env_get(f_env%force_env,subsys=subsys,cell=cell_tmp) ALLOCATE(cell) - CALL cell_copy(cell_in=cell_tmp, cell_out=cell, error=error) + CALL cell_copy(cell_in=cell_tmp, cell_out=cell) !get atom kinds - CALL allocate_tmc_atom_type(atoms, nr_atoms, error) - CALL cp_subsys_get(subsys, particles=particles, error=error) + CALL allocate_tmc_atom_type(atoms, nr_atoms) + CALL cp_subsys_get(subsys, particles=particles) nunits_tot=SIZE(particles%els(:)) IF(nunits_tot .GT. 0) THEN DO iparticle=1, nunits_tot atoms(iparticle)%name = particles%els(iparticle)%atomic_kind%name atoms(iparticle)%mass = particles%els(iparticle)%atomic_kind%mass END DO - CPPostcondition(iparticle-1.EQ.nr_atoms,cp_failure_level,routineP,error,failure) + CPPostcondition(iparticle-1.EQ.nr_atoms,cp_failure_level,routineP,failure) ENDIF END SUBROUTINE get_atom_kinds_and_cell @@ -938,14 +895,11 @@ END SUBROUTINE get_atom_kinds_and_cell !> to receive the intermediate energies on the (global) master side !> \param comm the master-worker communicator !> \param env_id the ID of the related force environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 10.2013 ! ***************************************************************************** - SUBROUTINE set_intermediate_info_comm(comm, env_id, error) + SUBROUTINE set_intermediate_info_comm(comm, env_id) INTEGER, INTENT(IN) :: comm INTEGER :: env_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'set_intermediate_info_comm', & routineP = moduleN//':'//routineN @@ -959,16 +913,16 @@ SUBROUTINE set_intermediate_info_comm(comm, env_id, error) failure = .FALSE. NULLIFY(results,subsys) - CPPrecondition(env_id.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(env_id.GT.0,cp_failure_level,routineP,failure) - CALL f_env_get_from_id(env_id,f_env,error) + CALL f_env_get_from_id(env_id,f_env) - CPPostcondition(ASSOCIATED(f_env),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(f_env%force_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(f_env),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(f_env%force_env),cp_failure_level,routineP,failure) CALL cp_assert(ASSOCIATED(f_env%force_env%qs_env), & cp_failure_level,cp_assertion_failed,routineP,& "the intermediate SCF energy request can not be set "//& - "employing this force environment! ", error) + "employing this force environment! ") ! set the information values(1) = REAL(comm, KIND=dp) @@ -977,22 +931,19 @@ SUBROUTINE set_intermediate_info_comm(comm, env_id, error) description = "[EXT_SCF_ENER_COMM]" ! set the communicator information in the qs_env result container - CALL force_env_get(f_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, results=results, error=error) - CALL put_results(results, description=description, values=values, error=error) + CALL force_env_get(f_env%force_env, subsys=subsys) + CALL cp_subsys_get(subsys, results=results) + CALL put_results(results, description=description, values=values) END SUBROUTINE set_intermediate_info_comm ! ***************************************************************************** !> \brief set the communicator in the SCF environment !> to receive the intermediate energies on the (global) master side !> \param env_id the ID of the related force environment -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Mandes 10.2013 ! ***************************************************************************** - SUBROUTINE remove_intermediate_info_comm(env_id, error) + SUBROUTINE remove_intermediate_info_comm(env_id) INTEGER :: env_id - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'remove_intermediate_info_comm', & @@ -1006,23 +957,23 @@ SUBROUTINE remove_intermediate_info_comm(env_id, error) failure = .FALSE. NULLIFY(subsys,results) - CPPrecondition(env_id.GT.0,cp_failure_level,routineP,error,failure) + CPPrecondition(env_id.GT.0,cp_failure_level,routineP,failure) - CALL f_env_get_from_id(env_id,f_env,error) + CALL f_env_get_from_id(env_id,f_env) - CPPostcondition(ASSOCIATED(f_env),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(f_env%force_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(f_env),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(f_env%force_env),cp_failure_level,routineP,failure) CALL cp_assert(ASSOCIATED(f_env%force_env%qs_env), & cp_failure_level,cp_assertion_failed,routineP,& "the SCF intermediate energy communicator can not be "//& - "removed! ", error) + "removed! ") description = "[EXT_SCF_ENER_COMM]" ! set the communicator information in the qs_env result container - CALL force_env_get(f_env%force_env, subsys=subsys, error=error) - CALL cp_subsys_get(subsys, results=results, error=error) - CALL cp_results_erase(results, description=description, error=error) + CALL force_env_get(f_env%force_env, subsys=subsys) + CALL cp_subsys_get(subsys, results=results) + CALL cp_results_erase(results, description=description) END SUBROUTINE remove_intermediate_info_comm @@ -1034,11 +985,10 @@ END SUBROUTINE remove_intermediate_info_comm !!> see module cp_error_handling !!> \author Mandes 03.2013 !! ***************************************************************************** -! SUBROUTINE get_mimal_distances(env_id, rlist_lowsq, error) +! SUBROUTINE get_mimal_distances(env_id, rlist_lowsq) ! INTEGER :: env_id ! REAL(KIND=dp), DIMENSION(:, :), & ! OPTIONAL, POINTER :: rlist_lowsq -! TYPE(cp_error_type), INTENT(inout) :: error ! ! CHARACTER(LEN=*), PARAMETER :: routineN = 'get_mimal_distances', & ! routineP = moduleN//':'//routineN @@ -1046,15 +996,15 @@ END SUBROUTINE remove_intermediate_info_comm ! LOGICAL :: failure ! TYPE(f_env_type), POINTER :: f_env ! -! CPPrecondition(env_id.GT.0,cp_failure_level,routineP,error,failure) -! CPPrecondition(.NOT.ASSOCIATED(rlist_lowsq),cp_failure_level,routineP,error,failure) +! CPPrecondition(env_id.GT.0,cp_failure_level,routineP,failure) +! CPPrecondition(.NOT.ASSOCIATED(rlist_lowsq),cp_failure_level,routineP,failure) ! -! CALL f_env_get_from_id(env_id,f_env,error) +! CALL f_env_get_from_id(env_id,f_env) ! IF (.NOT.failure) THEN ! IF(ASSOCIATED(f_env%force_env)) THEN ! IF(ASSOCIATED(f_env%force_env%fist_env)) THEN ! CALL fist_nonbond_env_get(f_env%force_env%fist_env%fist_nonbond_env, & -! rlist_lowsq=rlist_lowsq, error) +! rlist_lowsq=rlist_lowsq) ! END IF ! END IF ! END IF diff --git a/src/topology.F b/src/topology.F index 8c884ce9d1..89d213e9e7 100644 --- a/src/topology.F +++ b/src/topology.F @@ -117,11 +117,10 @@ MODULE topology !> \param subsys_section ... !> \param use_motion_section ... !> \param exclusions ... -!> \param error ... ! ***************************************************************************** SUBROUTINE topology_control(atomic_kind_set, particle_set, molecule_kind_set,& molecule_set, colvar_p, gci, root_section, para_env, qmmm, qmmm_env,& - force_env_section, subsys_section, use_motion_section, exclusions, error) + force_env_section, subsys_section, use_motion_section, exclusions) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -144,7 +143,6 @@ SUBROUTINE topology_control(atomic_kind_set, particle_set, molecule_kind_set,& LOGICAL, INTENT(IN) :: use_motion_section TYPE(exclusion_type), DIMENSION(:), & OPTIONAL, POINTER :: exclusions - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'topology_control', & routineP = moduleN//':'//routineN @@ -160,55 +158,55 @@ SUBROUTINE topology_control(atomic_kind_set, particle_set, molecule_kind_set,& failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL timeset(routineN,handle) NULLIFY(cell_section, constraint_section, topology_section) - cell_section => section_vals_get_subs_vals(subsys_section,"CELL",error=error) + cell_section => section_vals_get_subs_vals(subsys_section,"CELL") IF (use_motion_section) THEN - constraint_section => section_vals_get_subs_vals(root_section,"MOTION%CONSTRAINT",error=error) + constraint_section => section_vals_get_subs_vals(root_section,"MOTION%CONSTRAINT") END IF - topology_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY",error=error) + topology_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY") iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") my_qmmm = .FALSE. IF (PRESENT(qmmm).AND.PRESENT(qmmm_env)) my_qmmm = qmmm ! 1. Initialize the topology structure type - CALL init_topology(topology, error) + CALL init_topology(topology) ! 2. Get the cell info CALL read_cell (topology%cell, topology%cell_ref, cell_section=cell_section,& - para_env=para_env, error=error) - CALL write_cell(topology%cell, subsys_section, label="CELL_TOP|", error=error) - CALL setup_cell_muc(topology%cell_muc, topology%cell, subsys_section, error) + para_env=para_env) + CALL write_cell(topology%cell, subsys_section, label="CELL_TOP|") + CALL setup_cell_muc(topology%cell_muc, topology%cell, subsys_section) ! 3. Read in the topology section in the input file if any - CALL read_topology_section(topology,topology_section,error) + CALL read_topology_section(topology,topology_section) ! 4. Read in the constraints section - CALL read_constraints_section(topology,colvar_p,constraint_section,error) + CALL read_constraints_section(topology,colvar_p,constraint_section) ! 5. Read in the coordinates CALL read_binary_coordinates(topology,root_section,para_env,subsys_section,& - binary_coord_read,error) + binary_coord_read) IF (.NOT.binary_coord_read) THEN - CALL coordinate_control(topology,root_section,para_env,subsys_section,error) + CALL coordinate_control(topology,root_section,para_env,subsys_section) END IF ! 6. Read in or generate the molecular connectivity CALL connectivity_control(topology,para_env,my_qmmm, qmmm_env,subsys_section,& - force_env_section,error) + force_env_section) ! 7. Pack everything into the molecular types CALL topology_connectivity_pack(molecule_kind_set,molecule_set,& - topology,subsys_section,error) + topology,subsys_section) ! 8. Set up the QM/MM linkage (if any) ! This part takes care of the molecule in which QM atoms were defined. ! Preliminary setup for QM/MM link region IF (my_qmmm) THEN - CALL qmmm_connectivity_control(molecule_set, qmmm_env, subsys_section, error) + CALL qmmm_connectivity_control(molecule_set, qmmm_env, subsys_section) END IF ! 9. Pack everything into the atomic types @@ -216,51 +214,49 @@ SUBROUTINE topology_control(atomic_kind_set, particle_set, molecule_kind_set,& CALL topology_coordinate_pack(particle_set,atomic_kind_set,& molecule_kind_set,molecule_set,& topology, my_qmmm, qmmm_env, subsys_section,& - force_env_section=force_env_section, exclusions=exclusions,& - error=error) + force_env_section=force_env_section, exclusions=exclusions) ELSE CALL topology_coordinate_pack(particle_set,atomic_kind_set,& molecule_kind_set,molecule_set,& topology,subsys_section=subsys_section,& - force_env_section=force_env_section, exclusions=exclusions, & - error=error) + force_env_section=force_env_section, exclusions=exclusions) END IF !10. Post-Process colvar definitions (if needed) - CALL topology_post_proc_colvar(colvar_p, particle_set, error) + CALL topology_post_proc_colvar(colvar_p, particle_set) !11. Deal with the constraint stuff if requested IF (my_qmmm) THEN CALL topology_constraint_pack(molecule_kind_set,molecule_set,& topology,qmmm_env,particle_set,root_section,subsys_section,& - gci,error) + gci) ELSE CALL topology_constraint_pack(molecule_kind_set,molecule_set,& topology,particle_set=particle_set,input_file=root_section, & - subsys_section=subsys_section,gci=gci,error=error) + subsys_section=subsys_section,gci=gci) END IF !12. Dump the topology informations iw2 = cp_print_key_unit_nr(logger,subsys_section,"TOPOLOGY%DUMP_PDB",& - file_status="REPLACE",extension=".pdb",error=error) + file_status="REPLACE",extension=".pdb") IF (iw2>0) THEN - CALL write_coordinate_pdb(iw2,topology,subsys_section,error) + CALL write_coordinate_pdb(iw2,topology,subsys_section) END IF CALL cp_print_key_finished_output(iw2,logger,subsys_section,& - "TOPOLOGY%DUMP_PDB",error=error) + "TOPOLOGY%DUMP_PDB") iw2 = cp_print_key_unit_nr(logger,subsys_section,"TOPOLOGY%DUMP_PSF",& - file_status="REPLACE",extension=".psf",error=error) + file_status="REPLACE",extension=".psf") IF (iw2>0) THEN - CALL write_topology_psf(iw2,topology,subsys_section,force_env_section,error) + CALL write_topology_psf(iw2,topology,subsys_section,force_env_section) END IF CALL cp_print_key_finished_output(iw2,logger,subsys_section,& - "TOPOLOGY%DUMP_PSF",error=error) + "TOPOLOGY%DUMP_PSF") !13. Cleanup the topology structure type - CALL deallocate_topology(topology, error) + CALL deallocate_topology(topology) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO",error=error) + "PRINT%TOPOLOGY_INFO") END SUBROUTINE topology_control ! ***************************************************************************** @@ -272,13 +268,12 @@ END SUBROUTINE topology_control !> \param qmmm_env ... !> \param subsys_section ... !> \param force_env_section ... -!> \param error ... !> \par History !> none !> \author IKUO 08.01.2003 ! ***************************************************************************** SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& - force_env_section, error) + force_env_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology @@ -288,7 +283,6 @@ SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& POINTER :: qmmm_env TYPE(section_vals_type), POINTER :: subsys_section, & force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'connectivity_control', & routineP = moduleN//':'//routineN @@ -306,9 +300,9 @@ SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") CALL timeset(routineN,handle) my_qmmm = .FALSE. @@ -320,16 +314,16 @@ SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& ! Do nothing for the time being.. after we check element and proceed with the workflow.. CASE DEFAULT ! Prepare arrays - CALL pre_read_topology(topology,error) + CALL pre_read_topology(topology) ! Read connectivity from file CALL read_topology_conn(topology, topology%conn_type, topology%conn_file_name, & - para_env, subsys_section, error) + para_env, subsys_section) ! Post process of PSF and AMBER information SELECT CASE (topology%conn_type) CASE (do_conn_mol_set, do_conn_psf, do_conn_psf_u, do_conn_amb7) - CALL psf_post_process(topology,subsys_section,error) + CALL psf_post_process(topology,subsys_section) END SELECT END SELECT @@ -337,7 +331,7 @@ SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& ! with the atom_name IF (topology%aa_element) THEN check = SIZE(topology%atom_info%id_element)==SIZE(topology%atom_info%id_atmname) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) topology%atom_info%id_element = topology%atom_info%id_atmname END IF @@ -352,12 +346,12 @@ SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& CASE DEFAULT use_mm_map_first=.FALSE. END SELECT - CALL create_ff_map("AMBER",error) - CALL create_ff_map("CHARMM",error) - CALL create_ff_map("GROMOS",error) + CALL create_ff_map("AMBER") + CALL create_ff_map("CHARMM") + CALL create_ff_map("GROMOS") ALLOCATE(elements(SIZE(topology%atom_info%id_element)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(elements) elements(i) = id2str(topology%atom_info%id_element(i)) ENDDO @@ -378,7 +372,7 @@ SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& element0 = elements(i)(1:j) ! ALWAYS check for elements.. CALL check_subsys_element(element0,id2str(topology%atom_info%id_atmname(i)),my_element,& - subsys_section,use_mm_map_first,error) + subsys_section,use_mm_map_first) ! Earn time fixing same element labels for same atoms element0 = elements(i) DO k = i, topology%natoms @@ -389,57 +383,57 @@ SUBROUTINE connectivity_control(topology,para_env,qmmm,qmmm_env,subsys_section,& END DO END DO DEALLOCATE(elements,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL destroy_ff_map("GROMOS",error) - CALL destroy_ff_map("CHARMM",error) - CALL destroy_ff_map("AMBER",error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL destroy_ff_map("GROMOS") + CALL destroy_ff_map("CHARMM") + CALL destroy_ff_map("AMBER") CALL timestop(handle2) ! 4. Generate the connectivity information otherwise SELECT CASE (topology%conn_type) CASE (do_conn_generate) - CALL topology_set_atm_mass(topology,subsys_section,error) - CALL topology_generate_bond(topology,para_env,subsys_section,error) + CALL topology_set_atm_mass(topology,subsys_section) + CALL topology_generate_bond(topology,para_env,subsys_section) IF(topology%reorder_atom) THEN ! If we generate connectivity we can save memory reordering the molecules ! in this case once a first connectivity has been created we match according ! molecule names provided in the PDB and reorder the connectivity according to that. CALL topology_reorder_atoms(topology,qmmm,qmmm_env,subsys_section,& - force_env_section,error=error) - CALL topology_set_atm_mass(topology,subsys_section,error) - CALL topology_generate_bond(topology,para_env,subsys_section,error) + force_env_section) + CALL topology_set_atm_mass(topology,subsys_section) + CALL topology_generate_bond(topology,para_env,subsys_section) END IF - CALL topology_generate_bend(topology,subsys_section,error) - CALL topology_generate_ub(topology,subsys_section,error) - CALL topology_generate_dihe(topology,subsys_section,error) - CALL topology_generate_impr(topology,subsys_section,error) - CALL topology_generate_onfo(topology,subsys_section,error) + CALL topology_generate_bend(topology,subsys_section) + CALL topology_generate_ub(topology,subsys_section) + CALL topology_generate_dihe(topology,subsys_section) + CALL topology_generate_impr(topology,subsys_section) + CALL topology_generate_onfo(topology,subsys_section) CASE (do_conn_off, do_conn_user) - CALL topology_set_atm_mass(topology,subsys_section,error) - CALL topology_generate_bend(topology,subsys_section,error) - CALL topology_generate_ub(topology,subsys_section,error) - CALL topology_generate_dihe(topology,subsys_section,error) - CALL topology_generate_impr(topology,subsys_section,error) - CALL topology_generate_onfo(topology,subsys_section,error) + CALL topology_set_atm_mass(topology,subsys_section) + CALL topology_generate_bend(topology,subsys_section) + CALL topology_generate_ub(topology,subsys_section) + CALL topology_generate_dihe(topology,subsys_section) + CALL topology_generate_impr(topology,subsys_section) + CALL topology_generate_onfo(topology,subsys_section) END SELECT ! 5. Handle multiple unit_cell - Update atoms_info - CALL topology_muc(topology, subsys_section, error=error) + CALL topology_muc(topology, subsys_section) ! 6. Handle multiple unit_cell - Update conn_info - CALL topology_conn_multiple(topology, subsys_section, error) + CALL topology_conn_multiple(topology, subsys_section) ! 7. Generate Molecules - CALL topology_generate_molecule(topology,my_qmmm,qmmm_env,subsys_section,error) - IF(topology%molecules_check) CALL topology_molecules_check(topology,subsys_section,error) + CALL topology_generate_molecule(topology,my_qmmm,qmmm_env,subsys_section) + IF(topology%molecules_check) CALL topology_molecules_check(topology,subsys_section) ! 8. Modify for QM/MM IF (my_qmmm) THEN - CALL qmmm_coordinate_control(topology, qmmm_env,subsys_section, error) + CALL qmmm_coordinate_control(topology, qmmm_env,subsys_section) END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO",error=error) + "PRINT%TOPOLOGY_INFO") END SUBROUTINE connectivity_control @@ -450,11 +444,10 @@ END SUBROUTINE connectivity_control !> \param conn_file_name ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 10.2009 ! ***************************************************************************** RECURSIVE SUBROUTINE read_topology_conn(topology, conn_type, conn_file_name, para_env,& - subsys_section, error) + subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology @@ -463,7 +456,6 @@ RECURSIVE SUBROUTINE read_topology_conn(topology, conn_type, conn_file_name, par INTENT(IN) :: conn_file_name TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_topology_conn', & routineP = moduleN//':'//routineN @@ -479,26 +471,25 @@ RECURSIVE SUBROUTINE read_topology_conn(topology, conn_type, conn_file_name, par SELECT CASE (conn_type) CASE (do_conn_mol_set) - section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%MOL_SET",error=error) - section => section_vals_get_subs_vals(section,"MOLECULE",error=error) - CALL section_vals_get(section,n_repetition=n_rep,error=error) + section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%MOL_SET") + section => section_vals_get_subs_vals(section,"MOLECULE") + CALL section_vals_get(section,n_repetition=n_rep) DO i_rep=1,n_rep - CALL section_vals_val_get(section,"NMOL",i_val=nmol,i_rep_section=i_rep,error=error) - CALL section_vals_val_get(section,"CONN_FILE_NAME",c_val=filename,i_rep_section=i_rep,error=error) - CALL section_vals_val_get(section,"CONN_FILE_FORMAT",i_val=loc_conn_type,i_rep_section=i_rep,error=error) + CALL section_vals_val_get(section,"NMOL",i_val=nmol,i_rep_section=i_rep) + CALL section_vals_val_get(section,"CONN_FILE_NAME",c_val=filename,i_rep_section=i_rep) + CALL section_vals_val_get(section,"CONN_FILE_FORMAT",i_val=loc_conn_type,i_rep_section=i_rep) SELECT CASE (loc_conn_type) CASE (do_conn_psf, do_conn_psf_u, do_conn_g96, do_conn_g87, do_conn_amb7) DO imol=1,nmol - CALL read_topology_conn(topology,loc_conn_type,filename,para_env,subsys_section,& - error) + CALL read_topology_conn(topology,loc_conn_type,filename,para_env,subsys_section) END DO CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& "MOL_SET feature implemented only for PSF/UPSF, G87/G96 and AMBER "//& "connectivity type."//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) END SELECT END DO CALL cp_assert(SIZE(topology%atom_info%id_molname)==topology%natoms,& @@ -507,18 +498,18 @@ RECURSIVE SUBROUTINE read_topology_conn(topology, conn_type, conn_file_name, par "number of atoms in coordinate control. check coordinates and "//& "connectivity. "//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) ! Merge defined structures - section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%MOL_SET%MERGE_MOLECULES",error=error) - CALL idm_psf(topology,section,subsys_section,error) + section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%MOL_SET%MERGE_MOLECULES") + CALL idm_psf(topology,section,subsys_section) CASE (do_conn_g96,do_conn_g87) - CALL read_topology_gromos(conn_file_name,topology,para_env,subsys_section,error) + CALL read_topology_gromos(conn_file_name,topology,para_env,subsys_section) CASE (do_conn_psf, do_conn_psf_u) - CALL read_topology_psf(conn_file_name,topology,para_env,subsys_section,conn_type, error) + CALL read_topology_psf(conn_file_name,topology,para_env,subsys_section,conn_type) CASE (do_conn_amb7) - CALL read_connectivity_amber(conn_file_name,topology,para_env,subsys_section,error) + CALL read_connectivity_amber(conn_file_name,topology,para_env,subsys_section) END SELECT END SUBROUTINE read_topology_conn @@ -530,20 +521,18 @@ END SUBROUTINE read_topology_conn !> \param root_section ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \par History !> - Teodoro Laino [tlaino] - University of Zurich 10.2008 !> adding support for AMBER coordinates !> \author IKUO 08.11.2003 ! ***************************************************************************** - SUBROUTINE coordinate_control(topology,root_section,para_env,subsys_section,error) + SUBROUTINE coordinate_control(topology,root_section,para_env,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: root_section TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'coordinate_control', & routineP = moduleN//':'//routineN @@ -556,14 +545,14 @@ SUBROUTINE coordinate_control(topology,root_section,para_env,subsys_section,erro failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO",& - extension=".mmLog",error=error) + extension=".mmLog") CALL timeset(routineN,handle) NULLIFY(global_section) - global_section => section_vals_get_subs_vals(root_section,"GLOBAL",error=error) - CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem,error=error) + global_section => section_vals_get_subs_vals(root_section,"GLOBAL") + CALL section_vals_val_get(global_section,"SAVE_MEM",l_val=save_mem) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -592,58 +581,56 @@ SUBROUTINE coordinate_control(topology,root_section,para_env,subsys_section,erro CASE (do_coord_off) ! Do nothing.. we will parse later from the &COORD section.. CASE (do_coord_g96) - CALL read_coordinate_g96 (topology,para_env,subsys_section,error) + CALL read_coordinate_g96 (topology,para_env,subsys_section) CASE (do_coord_crd) - CALL read_coordinate_crd (topology,para_env,subsys_section,error) + CALL read_coordinate_crd (topology,para_env,subsys_section) CASE (do_coord_pdb) - CALL read_coordinate_pdb (topology,para_env,subsys_section,error) + CALL read_coordinate_pdb (topology,para_env,subsys_section) CASE (do_coord_xyz) - CALL read_coordinate_xyz (topology,para_env,subsys_section,error) + CALL read_coordinate_xyz (topology,para_env,subsys_section) CASE (do_coord_cif) - CALL read_coordinate_cif (topology,para_env,subsys_section,error) + CALL read_coordinate_cif (topology,para_env,subsys_section) CASE (do_coord_xtl) - CALL read_coordinate_xtl (topology,para_env,subsys_section,error) + CALL read_coordinate_xtl (topology,para_env,subsys_section) CASE (do_coord_cp2k) - CALL read_coordinate_cp2k(topology,para_env,subsys_section,error) + CALL read_coordinate_cp2k(topology,para_env,subsys_section) CASE DEFAULT ! We should never reach this point.. - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Parse &COORD section and in case overwrite IF (topology%coord_type /= do_coord_cp2k) THEN CALL read_atoms_input(topology,overwrite=(topology%coord_type /= do_coord_off),& - subsys_section=subsys_section,save_mem=save_mem,error=error) + subsys_section=subsys_section,save_mem=save_mem) END IF CALL section_vals_val_set(subsys_section,"TOPOLOGY%NUMBER_OF_ATOMS",& - i_val=topology%natoms,error=error) + i_val=topology%natoms) CALL timestop(handle2) ! Check on atom numbers CALL cp_assert(topology%natoms>0,cp_fatal_level,cp_assertion_failed,routineP,& "No atomic coordinates have been found! "//& CPSourceFileRef,& - error,failure) + failure) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO",error=error) + "PRINT%TOPOLOGY_INFO") END SUBROUTINE coordinate_control ! ***************************************************************************** !> \brief ... !> \param colvar_p ... !> \param particle_set ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] - 07.2007 ! ***************************************************************************** - SUBROUTINE topology_post_proc_colvar(colvar_p, particle_set, error) + SUBROUTINE topology_post_proc_colvar(colvar_p, particle_set) TYPE(colvar_p_type), DIMENSION(:), & POINTER :: colvar_p TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_post_proc_colvar', & routineP = moduleN//':'//routineN @@ -652,7 +639,7 @@ SUBROUTINE topology_post_proc_colvar(colvar_p, particle_set, error) IF (ASSOCIATED(colvar_p)) THEN DO i = 1, SIZE(colvar_p) - CALL post_process_colvar(colvar_p(i)%colvar, particle_set, error) + CALL post_process_colvar(colvar_p(i)%colvar, particle_set) END DO END IF END SUBROUTINE topology_post_proc_colvar @@ -662,14 +649,12 @@ END SUBROUTINE topology_post_proc_colvar !> \param cell_muc ... !> \param cell ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 06.2009 ! ***************************************************************************** - SUBROUTINE setup_cell_muc(cell_muc, cell, subsys_section, error) + SUBROUTINE setup_cell_muc(cell_muc, cell, subsys_section) TYPE(cell_type), POINTER :: cell_muc, cell TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_cell_muc', & routineP = moduleN//':'//routineN @@ -679,10 +664,10 @@ SUBROUTINE setup_cell_muc(cell_muc, cell, subsys_section, error) REAL(KIND=dp), DIMENSION(3, 3) :: hmat_ref failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(cell_muc),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(cell_muc),cp_failure_level,routineP,failure) CALL section_vals_val_get(subsys_section, "CELL%MULTIPLE_UNIT_CELL",& - i_vals=multiple_unit_cell, error=error) + i_vals=multiple_unit_cell) IF (ANY(multiple_unit_cell/=1)) THEN ! Restore the original cell hmat_ref(:,1) = cell%hmat(:,1)/multiple_unit_cell(1) @@ -690,11 +675,11 @@ SUBROUTINE setup_cell_muc(cell_muc, cell, subsys_section, error) hmat_ref(:,3) = cell%hmat(:,3)/multiple_unit_cell(3) ! Create the MUC cell - CALL cell_create(cell_muc,hmat=hmat_ref,periodic=cell%perd,error=error) - CALL write_cell(cell_muc,subsys_section,label="CELL_UC|",error=error) + CALL cell_create(cell_muc,hmat=hmat_ref,periodic=cell%perd) + CALL write_cell(cell_muc,subsys_section,label="CELL_UC|") ELSE ! If a multiple_unit_cell was not requested just point to the original cell - CALL cell_retain(cell, error) + CALL cell_retain(cell) cell_muc => cell END IF diff --git a/src/topology_amber.F b/src/topology_amber.F index 2bd155ce93..7295ce9f3f 100644 --- a/src/topology_amber.F +++ b/src/topology_amber.F @@ -93,14 +93,12 @@ MODULE topology_amber !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) + SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section) TYPE(topology_parameters_type) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_coordinate_crd', & routineP = moduleN//':'//routineN @@ -116,9 +114,9 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) TYPE(section_vals_type), POINTER :: velocity_section NULLIFY(parser, logger, velocity) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/CRD_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) atom_info => topology%atom_info @@ -126,16 +124,16 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) ! Title Section IF(iw>0) WRITE(iw,'(T2,A)') 'CRD_INFO| Parsing the TITLE section' - CALL parser_create(parser,topology%coord_file_name,para_env=para_env,error=error) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_create(parser,topology%coord_file_name,para_env=para_env) + CALL parser_get_next_line(parser,1) ! Title may be missing - IF (parser_test_next_token(parser,error=error)=="STR") THEN - CALL parser_get_object(parser,string,string_length=default_string_length,error=error) + IF (parser_test_next_token(parser)=="STR") THEN + CALL parser_get_object(parser,string,string_length=default_string_length) IF(iw>0) WRITE(iw,'(T2,A)') 'CRD_INFO| '//TRIM(string) ! Natom and Time (which we ignore) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) END IF - CALL parser_get_object(parser,natom,error=error) + CALL parser_get_object(parser,natom) topology%natoms = natom IF(iw>0) WRITE(iw,'(T2,A,I0)') 'CRD_INFO| Number of atoms: ',natom CALL reallocate(atom_info%id_molname, 1, natom) @@ -153,7 +151,7 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) topology%aa_element = .TRUE. ! Coordinates - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) DO j = 1, natom-MOD(natom,2), 2 IF (my_end) EXIT READ(parser%input_line,*)atom_info%r(1,j ),atom_info%r(2,j ),atom_info%r(3,j ),& @@ -167,9 +165,9 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) atom_info%resid (j ) = HUGE(0) atom_info%atm_mass (j ) = HUGE(0.0_dp) atom_info%atm_charge (j ) = -HUGE(0.0_dp) - atom_info%r(1,j ) = cp_unit_to_cp2k(atom_info%r(1,j ),"angstrom",error=error) - atom_info%r(2,j ) = cp_unit_to_cp2k(atom_info%r(2,j ),"angstrom",error=error) - atom_info%r(3,j ) = cp_unit_to_cp2k(atom_info%r(3,j ),"angstrom",error=error) + atom_info%r(1,j ) = cp_unit_to_cp2k(atom_info%r(1,j ),"angstrom") + atom_info%r(2,j ) = cp_unit_to_cp2k(atom_info%r(2,j ),"angstrom") + atom_info%r(3,j ) = cp_unit_to_cp2k(atom_info%r(3,j ),"angstrom") atom_info%id_atmname(j+1) = str2id(s2s("__UNDEF__")) atom_info%id_molname(j+1) = str2id(s2s("__UNDEF__")) @@ -178,11 +176,11 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) atom_info%resid (j+1) = HUGE(0) atom_info%atm_mass (j+1) = HUGE(0.0_dp) atom_info%atm_charge (j+1) = -HUGE(0.0_dp) - atom_info%r(1,j+1) = cp_unit_to_cp2k(atom_info%r(1,j+1),"angstrom",error=error) - atom_info%r(2,j+1) = cp_unit_to_cp2k(atom_info%r(2,j+1),"angstrom",error=error) - atom_info%r(3,j+1) = cp_unit_to_cp2k(atom_info%r(3,j+1),"angstrom",error=error) + atom_info%r(1,j+1) = cp_unit_to_cp2k(atom_info%r(1,j+1),"angstrom") + atom_info%r(2,j+1) = cp_unit_to_cp2k(atom_info%r(2,j+1),"angstrom") + atom_info%r(3,j+1) = cp_unit_to_cp2k(atom_info%r(3,j+1),"angstrom") - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) END DO ! Trigger error IF ((my_end).AND.(j/=natom-MOD(natom,2)+1)) THEN @@ -203,11 +201,11 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) atom_info%resid (j ) = HUGE(0) atom_info%atm_mass (j ) = HUGE(0.0_dp) atom_info%atm_charge (j ) = -HUGE(0.0_dp) - atom_info%r(1,j ) = cp_unit_to_cp2k(atom_info%r(1,j ),"angstrom",error=error) - atom_info%r(2,j ) = cp_unit_to_cp2k(atom_info%r(2,j ),"angstrom",error=error) - atom_info%r(3,j ) = cp_unit_to_cp2k(atom_info%r(3,j ),"angstrom",error=error) + atom_info%r(1,j ) = cp_unit_to_cp2k(atom_info%r(1,j ),"angstrom") + atom_info%r(2,j ) = cp_unit_to_cp2k(atom_info%r(2,j ),"angstrom") + atom_info%r(3,j ) = cp_unit_to_cp2k(atom_info%r(3,j ),"angstrom") - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) END IF IF (my_end) THEN @@ -223,17 +221,17 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) READ(parser%input_line,*)velocity(1,j ),velocity(2,j ),velocity(3,j ),& velocity(1,j+1),velocity(2,j+1),velocity(3,j+1) - velocity(1,j ) = cp_unit_to_cp2k(velocity(1,j ),"angstrom*ps^-1",error=error) - velocity(2,j ) = cp_unit_to_cp2k(velocity(2,j ),"angstrom*ps^-1",error=error) - velocity(3,j ) = cp_unit_to_cp2k(velocity(3,j ),"angstrom*ps^-1",error=error) + velocity(1,j ) = cp_unit_to_cp2k(velocity(1,j ),"angstrom*ps^-1") + velocity(2,j ) = cp_unit_to_cp2k(velocity(2,j ),"angstrom*ps^-1") + velocity(3,j ) = cp_unit_to_cp2k(velocity(3,j ),"angstrom*ps^-1") velocity(1:3,j ) = velocity(1:3,j )*amber_conv_factor - velocity(1,j+1) = cp_unit_to_cp2k(velocity(1,j+1),"angstrom*ps^-1",error=error) - velocity(2,j+1) = cp_unit_to_cp2k(velocity(2,j+1),"angstrom*ps^-1",error=error) - velocity(3,j+1) = cp_unit_to_cp2k(velocity(3,j+1),"angstrom*ps^-1",error=error) + velocity(1,j+1) = cp_unit_to_cp2k(velocity(1,j+1),"angstrom*ps^-1") + velocity(2,j+1) = cp_unit_to_cp2k(velocity(2,j+1),"angstrom*ps^-1") + velocity(3,j+1) = cp_unit_to_cp2k(velocity(3,j+1),"angstrom*ps^-1") velocity(1:3,j+1) = velocity(1:3,j+1)*amber_conv_factor - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) END DO setup_velocities = .TRUE. IF ((my_end).AND.(j/=natom-MOD(natom,2)+1)) THEN @@ -248,20 +246,20 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) j = natom READ(parser%input_line,*)velocity(1,j ),velocity(2,j ),velocity(3,j ) - velocity(1,j ) = cp_unit_to_cp2k(velocity(1,j ),"angstrom*ps^-1",error=error) - velocity(2,j ) = cp_unit_to_cp2k(velocity(2,j ),"angstrom*ps^-1",error=error) - velocity(3,j ) = cp_unit_to_cp2k(velocity(3,j ),"angstrom*ps^-1",error=error) + velocity(1,j ) = cp_unit_to_cp2k(velocity(1,j ),"angstrom*ps^-1") + velocity(2,j ) = cp_unit_to_cp2k(velocity(2,j ),"angstrom*ps^-1") + velocity(3,j ) = cp_unit_to_cp2k(velocity(3,j ),"angstrom*ps^-1") velocity(1:3,j ) = velocity(1:3,j )*amber_conv_factor - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) END IF IF (setup_velocities) THEN - velocity_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) + velocity_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") CALL section_velocity_val_set(velocity_section, velocity=velocity, & - conv_factor=1.0_dp, error=error) + conv_factor=1.0_dp) END IF DEALLOCATE(velocity,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (my_end) THEN CALL cp_assert(j==natom,cp_warning_level,cp_assertion_failed,routineP,& @@ -275,9 +273,9 @@ SUBROUTINE read_coordinate_crd (topology,para_env,subsys_section,error) CPSourceFileRef,& only_ionode=.TRUE.) END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/CRD_INFO",error=error) + "PRINT%TOPOLOGY_INFO/CRD_INFO") CALL timestop(handle) END SUBROUTINE read_coordinate_crd @@ -291,16 +289,14 @@ END SUBROUTINE read_coordinate_crd !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE read_connectivity_amber (filename, topology, para_env, subsys_section, error) + SUBROUTINE read_connectivity_amber (filename, topology, para_env, subsys_section) CHARACTER(LEN=*), INTENT(IN) :: filename TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_connectivity_amber', & routineP = moduleN//':'//routineN @@ -314,22 +310,22 @@ SUBROUTINE read_connectivity_amber (filename, topology, para_env, subsys_section NULLIFY(logger) failure = .FALSE. CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/AMBER_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") atom_info => topology%atom_info conn_info => topology%conn_info ! Read the Amber topology file CALL rdparm_amber_8(filename, iw, para_env, do_connectivity=.TRUE., do_forcefield=.FALSE.,& - atom_info=atom_info, conn_info=conn_info, error=error) + atom_info=atom_info, conn_info=conn_info) ! Molnames have been internally generated topology%molname_generated = .TRUE. CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/AMBER_INFO",error=error) + "PRINT%TOPOLOGY_INFO/AMBER_INFO") CALL timestop(handle) END SUBROUTINE read_connectivity_amber @@ -378,11 +374,10 @@ END SUBROUTINE read_connectivity_amber !> \param conn_info ... !> \param amb_info ... !> \param particle_set ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& - do_forcefield, atom_info, conn_info, amb_info, particle_set, error) + do_forcefield, atom_info, conn_info, amb_info, particle_set) CHARACTER(LEN=*), INTENT(IN) :: filename INTEGER, INTENT(IN) :: output_unit @@ -394,7 +389,6 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& TYPE(amber_info_type), OPTIONAL, POINTER :: amb_info TYPE(particle_type), DIMENSION(:), & OPTIONAL, POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rdparm_amber_8', & routineP = moduleN//':'//routineN @@ -422,16 +416,16 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& NULLIFY(parser) IF (output_unit>0) WRITE(output_unit,'(/,A)')" AMBER_INFO| Reading Amber Topology File: "//& TRIM(filename) - CALL parser_create(parser,filename,para_env=para_env,parse_white_lines=.TRUE.,error=error) - valid_format = check_amber_8_std(parser, output_unit, error) + CALL parser_create(parser,filename,para_env=para_env,parse_white_lines=.TRUE.) + valid_format = check_amber_8_std(parser, output_unit) IF (valid_format) THEN - DO WHILE (get_section_parmtop(parser, section, input_format, error)) + DO WHILE (get_section_parmtop(parser, section, input_format)) SELECT CASE (TRIM(section)) CASE("TITLE") ! Who cares about the title? CYCLE CASE("POINTERS") - CALL rd_amber_section(parser, section, info, 31, error) + CALL rd_amber_section(parser, section, info, 31) ! Assign pointers to the corresponding labels ! just for convenience to have something more human readable natom = info( 1) @@ -479,93 +473,93 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& ! Allocate temporary arrays IF (do_connectivity) THEN check = PRESENT(atom_info).AND.PRESENT(conn_info) - CPPrecondition(check,cp_failure_level,routineP,error,failure) + CPPrecondition(check,cp_failure_level,routineP,failure) natom_prev = 0 IF(ASSOCIATED(atom_info%id_molname)) natom_prev = SIZE(atom_info%id_molname) ! Allocate for extracting connectivity infos ALLOCATE(labres (nres ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ipres (nres ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (do_forcefield) THEN ! Allocate for extracting forcefield infos ALLOCATE(iac (natom ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ico (ntypes*ntypes ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(rk (numbnd ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(req (numbnd ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tk (numang ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(teq (numang ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pk (nptra ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pn (nptra ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(phase (nptra ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cn1 (ntypes*(ntypes+1)/2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cn2 (ntypes*(ntypes+1)/2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(asol (ntypes*(ntypes+1)/2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(bsol (ntypes*(ntypes+1)/2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Always Allocate ALLOCATE(ibh (nbonh ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(jbh (nbonh ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(icbh (nbonh ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ib (nbona ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(jb (nbona ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(icb (nbona ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ith (ntheth ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(jth (ntheth ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kth (ntheth ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(icth (ntheth ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(it (ntheta ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(jt (ntheta ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kt (ntheta ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ict (ntheta ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(iph (nphih ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(jph (nphih ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kph (nphih ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(lph (nphih ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(icph (nphih ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(ip (nphia ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(jp (nphia ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(kp (nphia ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(lp (nphia ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(icp (nphia ),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE("ATOM_NAME") ! Atom names are just ignored according the CP2K philosophy CYCLE @@ -573,99 +567,99 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& IF (.NOT.do_connectivity) CYCLE CALL reallocate(atom_info%id_atmname,1,natom_prev+natom) ALLOCATE(strtmp_a(natom), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL rd_amber_section(parser, section, strtmp_a , natom, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL rd_amber_section(parser, section, strtmp_a , natom) DO i=1,natom atom_info%id_atmname(natom_prev+i)=str2id(strtmp_a(i)) ENDDO DEALLOCATE(strtmp_a, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE("CHARGE") IF (.NOT.do_connectivity) CYCLE CALL reallocate(atom_info%atm_charge,1,natom_prev+natom) - CALL rd_amber_section(parser, section, atom_info%atm_charge(natom_prev+1:), natom, error) + CALL rd_amber_section(parser, section, atom_info%atm_charge(natom_prev+1:), natom) ! Convert charges into atomic units atom_info%atm_charge(natom_prev+1:) = atom_info%atm_charge(natom_prev+1:)/amber_conv_charge CASE("MASS") IF (.NOT.do_connectivity) CYCLE CALL reallocate(atom_info%atm_mass,1,natom_prev+natom) - CALL rd_amber_section(parser, section, atom_info%atm_mass(natom_prev+1:), natom, error) + CALL rd_amber_section(parser, section, atom_info%atm_mass(natom_prev+1:), natom) CASE("RESIDUE_LABEL") IF (.NOT.do_connectivity) CYCLE CALL reallocate(atom_info%id_resname,1,natom_prev+natom) - CALL rd_amber_section(parser, section, labres, nres, error) + CALL rd_amber_section(parser, section, labres, nres) CASE("RESIDUE_POINTER") IF (.NOT.do_connectivity) CYCLE CALL reallocate(atom_info%resid,1,natom_prev+natom) - CALL rd_amber_section(parser, section, ipres, nres, error) + CALL rd_amber_section(parser, section, ipres, nres) CASE("ATOM_TYPE_INDEX") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, iac, natom, error) + CALL rd_amber_section(parser, section, iac, natom) CASE("NONBONDED_PARM_INDEX") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, ico, ntypes**2, error) + CALL rd_amber_section(parser, section, ico, ntypes**2) CASE("BOND_FORCE_CONSTANT") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, rk, numbnd, error) + CALL rd_amber_section(parser, section, rk, numbnd) CASE("BOND_EQUIL_VALUE") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, req, numbnd, error) + CALL rd_amber_section(parser, section, req, numbnd) CASE("ANGLE_FORCE_CONSTANT") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, tk, numang, error) + CALL rd_amber_section(parser, section, tk, numang) CASE("ANGLE_EQUIL_VALUE") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, teq, numang, error) + CALL rd_amber_section(parser, section, teq, numang) CASE("DIHEDRAL_FORCE_CONSTANT") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, pk, nptra, error) + CALL rd_amber_section(parser, section, pk, nptra) CASE("DIHEDRAL_PERIODICITY") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, pn, nptra, error) + CALL rd_amber_section(parser, section, pn, nptra) CASE("DIHEDRAL_PHASE") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, phase, nptra, error) + CALL rd_amber_section(parser, section, phase, nptra) CASE("LENNARD_JONES_ACOEF") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, cn1, ntypes*(ntypes+1)/2, error) + CALL rd_amber_section(parser, section, cn1, ntypes*(ntypes+1)/2) CASE("LENNARD_JONES_BCOEF") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, cn2, ntypes*(ntypes+1)/2, error) + CALL rd_amber_section(parser, section, cn2, ntypes*(ntypes+1)/2) CASE("HBOND_ACOEF") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, asol, nphb, error) + CALL rd_amber_section(parser, section, asol, nphb) CASE("HBOND_BCOEF") IF (.NOT.do_forcefield) CYCLE - CALL rd_amber_section(parser, section, bsol, nphb, error) + CALL rd_amber_section(parser, section, bsol, nphb) CASE("BONDS_INC_HYDROGEN") ! We always need to parse this information both for connectivity and forcefields - CALL rd_amber_section(parser, section, ibh, jbh, icbh, nbonh, error) + CALL rd_amber_section(parser, section, ibh, jbh, icbh, nbonh) ! Conver to an atomic index ibh(:) = ibh(:)/3+1 jbh(:) = jbh(:)/3+1 CASE("BONDS_WITHOUT_HYDROGEN") ! We always need to parse this information both for connectivity and forcefields - CALL rd_amber_section(parser, section, ib, jb, icb, nbona, error) + CALL rd_amber_section(parser, section, ib, jb, icb, nbona) ! Conver to an atomic index ib(:) = ib(:)/3+1 jb(:) = jb(:)/3+1 CASE("ANGLES_INC_HYDROGEN") ! We always need to parse this information both for connectivity and forcefields - CALL rd_amber_section(parser, section, ith, jth, kth, icth, ntheth, error) + CALL rd_amber_section(parser, section, ith, jth, kth, icth, ntheth) ! Conver to an atomic index ith(:) = ith(:)/3+1 jth(:) = jth(:)/3+1 kth(:) = kth(:)/3+1 CASE("ANGLES_WITHOUT_HYDROGEN") ! We always need to parse this information both for connectivity and forcefields - CALL rd_amber_section(parser, section, it, jt, kt, ict, ntheta, error) + CALL rd_amber_section(parser, section, it, jt, kt, ict, ntheta) ! Conver to an atomic index it(:) = it(:)/3+1 jt(:) = jt(:)/3+1 kt(:) = kt(:)/3+1 CASE("DIHEDRALS_INC_HYDROGEN") ! We always need to parse this information both for connectivity and forcefields - CALL rd_amber_section(parser, section, iph, jph, kph, lph, icph, nphih, error) + CALL rd_amber_section(parser, section, iph, jph, kph, lph, icph, nphih) ! Conver to an atomic index iph(:) = iph(:)/3+1 jph(:) = jph(:)/3+1 @@ -673,7 +667,7 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& lph(:) = ABS(lph(:))/3+1 CASE("DIHEDRALS_WITHOUT_HYDROGEN") ! We always need to parse this information both for connectivity and forcefields - CALL rd_amber_section(parser, section, ip, jp, kp, lp, icp, nphia, error) + CALL rd_amber_section(parser, section, ip, jp, kp, lp, icp, nphia) ! Conver to an atomic index ip(:) = ip(:)/3+1 jp(:) = jp(:)/3+1 @@ -692,9 +686,9 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& ! Conform Amber Names with CHARMM convention (kind<->charge) ! ---------------------------------------------------------- ALLOCATE(isymbl(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,SIZE(isymbl) isymbl(i) = id2str(atom_info%id_atmname(natom_prev+i)) @@ -706,11 +700,11 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& istart = 1 DO i = 2, natom IF (TRIM(isymbl(i))/=TRIM(isymbl(istart))) THEN - CALL conform_atom_type_low(isymbl, iwork, i, istart, atom_info%atm_charge(natom_prev+1:), error) + CALL conform_atom_type_low(isymbl, iwork, i, istart, atom_info%atm_charge(natom_prev+1:)) istart = i END IF END DO - CALL conform_atom_type_low(isymbl, iwork, i, istart, atom_info%atm_charge(natom_prev+1:), error) + CALL conform_atom_type_low(isymbl, iwork, i, istart, atom_info%atm_charge(natom_prev+1:)) ! Copy back the modified and conformed atom types DO i = 1, natom @@ -729,13 +723,13 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& ! Deallocate when extracting connectivity infos DEALLOCATE(iwork,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(isymbl,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(labres,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ipres,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! ---------------------------------------------------------- ! Copy connectivity @@ -790,9 +784,9 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& IF (nphih+nphia /= 0) THEN ALLOCATE(full_torsions(4,nphih+nphia),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(nphih+nphia),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nphih full_torsions(1,i) = iph(i) @@ -831,9 +825,9 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& CALL reallocate(conn_info%phi_d,1,unique_torsions) DEALLOCATE(full_torsions,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(iwork,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! IMPROPERS CALL reallocate(conn_info%impr_a,1,0) @@ -847,7 +841,7 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& CALL reallocate(atom_info%id_molname,1,natom_prev+natom) atom_info%id_molname(natom_prev+1:natom_prev+natom) = str2id(s2s("__UNDEF__")) CALL topology_generate_molname(conn_info, natom, natom_prev, nbond_prev,& - atom_info%id_molname(natom_prev+1:natom_prev+natom), error) + atom_info%id_molname(natom_prev+1:natom_prev+natom)) CALL timestop(handle2) END IF @@ -865,11 +859,11 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& ! Bonds containing hydrogens CALL post_process_bonds_info(amb_info%bond_a, amb_info%bond_b,& amb_info%bond_k, amb_info%bond_r0, particle_set, nsize, & - nbonh, ibh, jbh, icbh, rk, req, error) + nbonh, ibh, jbh, icbh, rk, req) ! Bonds non-containing hydrogens CALL post_process_bonds_info(amb_info%bond_a, amb_info%bond_b,& amb_info%bond_k, amb_info%bond_r0, particle_set, nsize, & - nbona, ib, jb, icb, rk, req, error) + nbona, ib, jb, icb, rk, req) ! Shrink arrays size to the minimal request CALL reallocate(amb_info%bond_a, 1,nsize) CALL reallocate(amb_info%bond_b, 1,nsize) @@ -888,11 +882,11 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& ! Bends containing hydrogens CALL post_process_bends_info(amb_info%bend_a, amb_info%bend_b,& amb_info%bend_c, amb_info%bend_k, amb_info%bend_theta0, & - particle_set, nsize, ntheth, ith, jth, kth, icth, tk, teq, error) + particle_set, nsize, ntheth, ith, jth, kth, icth, tk, teq) ! Bends non-containing hydrogens CALL post_process_bends_info(amb_info%bend_a, amb_info%bend_b,& amb_info%bend_c, amb_info%bend_k, amb_info%bend_theta0, & - particle_set, nsize, ntheta, it, jt, kt, ict, tk, teq, error) + particle_set, nsize, ntheta, it, jt, kt, ict, tk, teq) ! Shrink arrays size to the minimal request CALL reallocate(amb_info%bend_a, 1,nsize) CALL reallocate(amb_info%bend_b, 1,nsize) @@ -916,12 +910,12 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& CALL post_process_torsions_info(amb_info%torsion_a, amb_info%torsion_b,& amb_info%torsion_c, amb_info%torsion_d, amb_info%torsion_k, & amb_info%torsion_m, amb_info%torsion_phi0, particle_set, nsize,& - nphih, iph, jph, kph, lph, icph, pk, pn, phase, error) + nphih, iph, jph, kph, lph, icph, pk, pn, phase) ! Torsions non-containing hydrogens CALL post_process_torsions_info(amb_info%torsion_a, amb_info%torsion_b,& amb_info%torsion_c, amb_info%torsion_d, amb_info%torsion_k, & amb_info%torsion_m, amb_info%torsion_phi0, particle_set, nsize,& - nphia, ip, jp, kp, lp, icp, pk, pn, phase, error) + nphia, ip, jp, kp, lp, icp, pk, pn, phase) ! Shrink arrays size to the minimal request CALL reallocate(amb_info%torsion_a, 1,nsize) CALL reallocate(amb_info%torsion_b, 1,nsize) @@ -941,7 +935,7 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& nsize = 0 CALL post_process_LJ_info(amb_info%nonbond_a, amb_info%nonbond_eps,& amb_info%nonbond_rmin2, particle_set, ntypes, nsize, iac, ico,& - cn1, cn2, natom, error) + cn1, cn2, natom) ! Shrink arrays size to the minimal request CALL reallocate(amb_info%nonbond_a, 1, nsize) @@ -950,83 +944,83 @@ SUBROUTINE rdparm_amber_8(filename, output_unit, para_env, do_connectivity,& ! Deallocate at the end of the dirty job DEALLOCATE(iac,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ico,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(req,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(teq,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pn,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(phase,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cn1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cn2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(asol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bsol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle2) END IF ! Always Deallocate DEALLOCATE(ibh,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(jbh,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(icbh,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ib,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(jb,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(icb,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ith,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(jth,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kth,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(icth,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(it,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(jt,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kt,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ict,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(iph,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(jph,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kph,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(lph,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(icph,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ip,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(jp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(kp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(lp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(icp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL parser_release(parser,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL parser_release(parser) CALL timestop(handle) RETURN ! Output info Format @@ -1046,17 +1040,15 @@ END SUBROUTINE rdparm_amber_8 !> \param i ... !> \param istart ... !> \param charges ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE conform_atom_type_low(isymbl, iwork, i, istart, charges, error) + SUBROUTINE conform_atom_type_low(isymbl, iwork, i, istart, charges) CHARACTER(LEN=default_string_length), & DIMENSION(:) :: isymbl INTEGER, DIMENSION(:) :: iwork INTEGER, INTENT(IN) :: i INTEGER, INTENT(INOUT) :: istart REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: charges - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'conform_atom_type_low', & routineP = moduleN//':'//routineN @@ -1074,11 +1066,11 @@ SUBROUTINE conform_atom_type_low(isymbl, iwork, i, istart, charges, error) iend = i - 1 isize= iend-istart+1 ALLOCATE(cwork(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(lindx(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cindx(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ind = 0 DO k = istart, iend ind = ind + 1 @@ -1118,11 +1110,11 @@ SUBROUTINE conform_atom_type_low(isymbl, iwork, i, istart, charges, error) END DO END IF DEALLOCATE(cwork, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(lindx, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(cindx, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE conform_atom_type_low @@ -1133,16 +1125,14 @@ END SUBROUTINE conform_atom_type_low !> \param section ... !> \param array1 ... !> \param dim ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE rd_amber_section_i1(parser, section, array1, dim, error) + SUBROUTINE rd_amber_section_i1(parser, section, array1, dim) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=default_string_length), & INTENT(IN) :: section INTEGER, DIMENSION(:) :: array1 INTEGER, INTENT(IN) :: dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rd_amber_section_i1', & routineP = moduleN//':'//routineN @@ -1152,19 +1142,19 @@ SUBROUTINE rd_amber_section_i1(parser, section, array1, dim, error) failure = .FALSE. - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) i = 1 DO WHILE ((i<=dim).AND.(.NOT.my_end)) - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object(parser,array1(i),error=error) + CALL parser_get_object(parser,array1(i)) i = i + 1 END DO ! Trigger end of file aborting CALL cp_assert(.NOT.my_end.OR.(i>dim), cp_fatal_level, cp_assertion_failed, routineP,& "End of file while reading section "//TRIM(section)//" in amber topology file!"//& - CPSourceFileRef,error=error,failure=failure) + CPSourceFileRef,failure=failure) END SUBROUTINE rd_amber_section_i1 ! ***************************************************************************** @@ -1176,16 +1166,14 @@ END SUBROUTINE rd_amber_section_i1 !> \param array2 ... !> \param array3 ... !> \param dim ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE rd_amber_section_i3(parser, section, array1, array2, array3, dim, error) + SUBROUTINE rd_amber_section_i3(parser, section, array1, array2, array3, dim) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=default_string_length), & INTENT(IN) :: section INTEGER, DIMENSION(:) :: array1, array2, array3 INTEGER, INTENT(IN) :: dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rd_amber_section_i3', & routineP = moduleN//':'//routineN @@ -1194,31 +1182,31 @@ SUBROUTINE rd_amber_section_i3(parser, section, array1, array2, array3, dim, err LOGICAL :: failure, my_end failure = .FALSE. - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) i = 1 DO WHILE ((i<=dim).AND.(.NOT.my_end)) !array1 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array1(i),error=error) + CALL parser_get_object (parser,array1(i)) !array2 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array2(i),error=error) + CALL parser_get_object (parser,array2(i)) !array3 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array3(i),error=error) + CALL parser_get_object (parser,array3(i)) i = i + 1 END DO ! Trigger end of file aborting CALL cp_assert(.NOT.my_end.OR.(i>dim), cp_fatal_level, cp_assertion_failed, routineP,& "End of file while reading section "//TRIM(section)//" in amber topology file!"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) END SUBROUTINE rd_amber_section_i3 ! ***************************************************************************** @@ -1231,16 +1219,14 @@ END SUBROUTINE rd_amber_section_i3 !> \param array3 ... !> \param array4 ... !> \param dim ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE rd_amber_section_i4(parser, section, array1, array2, array3, array4, dim, error) + SUBROUTINE rd_amber_section_i4(parser, section, array1, array2, array3, array4, dim) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=default_string_length), & INTENT(IN) :: section INTEGER, DIMENSION(:) :: array1, array2, array3, array4 INTEGER, INTENT(IN) :: dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rd_amber_section_i4', & routineP = moduleN//':'//routineN @@ -1249,36 +1235,36 @@ SUBROUTINE rd_amber_section_i4(parser, section, array1, array2, array3, array4, LOGICAL :: failure, my_end failure = .FALSE. - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) i = 1 DO WHILE ((i<=dim).AND.(.NOT.my_end)) !array1 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array1(i),error=error) + CALL parser_get_object (parser,array1(i)) !array2 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array2(i),error=error) + CALL parser_get_object (parser,array2(i)) !array3 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array3(i),error=error) + CALL parser_get_object (parser,array3(i)) !array4 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array4(i),error=error) + CALL parser_get_object (parser,array4(i)) i = i + 1 END DO ! Trigger end of file aborting CALL cp_assert(.NOT.my_end.OR.(i>dim), cp_fatal_level, cp_assertion_failed, routineP,& "End of file while reading section "//TRIM(section)//" in amber topology file!"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) END SUBROUTINE rd_amber_section_i4 ! ***************************************************************************** @@ -1292,18 +1278,16 @@ END SUBROUTINE rd_amber_section_i4 !> \param array4 ... !> \param array5 ... !> \param dim ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** SUBROUTINE rd_amber_section_i5(parser, section, array1, array2, array3, array4, & - array5, dim, error) + array5, dim) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=default_string_length), & INTENT(IN) :: section INTEGER, DIMENSION(:) :: array1, array2, array3, & array4, array5 INTEGER, INTENT(IN) :: dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rd_amber_section_i5', & routineP = moduleN//':'//routineN @@ -1312,41 +1296,41 @@ SUBROUTINE rd_amber_section_i5(parser, section, array1, array2, array3, array4, LOGICAL :: failure, my_end failure = .FALSE. - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) i = 1 DO WHILE ((i<=dim).AND.(.NOT.my_end)) !array1 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array1(i),error=error) + CALL parser_get_object (parser,array1(i)) !array2 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array2(i),error=error) + CALL parser_get_object (parser,array2(i)) !array3 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array3(i),error=error) + CALL parser_get_object (parser,array3(i)) !array4 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array4(i),error=error) + CALL parser_get_object (parser,array4(i)) !array5 - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object (parser,array5(i),error=error) + CALL parser_get_object (parser,array5(i)) i = i + 1 END DO ! Trigger end of file aborting CALL cp_assert(.NOT.my_end.OR.(i>dim), cp_fatal_level, cp_assertion_failed, routineP,& "End of file while reading section "//TRIM(section)//" in amber topology file!"//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) END SUBROUTINE rd_amber_section_i5 ! ***************************************************************************** @@ -1356,17 +1340,15 @@ END SUBROUTINE rd_amber_section_i5 !> \param section ... !> \param array1 ... !> \param dim ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE rd_amber_section_c1(parser, section, array1, dim, error) + SUBROUTINE rd_amber_section_c1(parser, section, array1, dim) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=default_string_length), & INTENT(IN) :: section CHARACTER(LEN=default_string_length), & DIMENSION(:) :: array1 INTEGER, INTENT(IN) :: dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rd_amber_section_c1', & routineP = moduleN//':'//routineN @@ -1376,19 +1358,19 @@ SUBROUTINE rd_amber_section_c1(parser, section, array1, dim, error) failure = .FALSE. - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) i = 1 DO WHILE ((i<=dim).AND.(.NOT.my_end)) - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object(parser,array1(i),lower_to_upper=.TRUE.,error=error) + CALL parser_get_object(parser,array1(i),lower_to_upper=.TRUE.) i = i + 1 END DO ! Trigger end of file aborting CALL cp_assert(.NOT.my_end.OR.(i>dim), cp_fatal_level, cp_assertion_failed, routineP,& "End of file while reading section "//TRIM(section)//" in amber topology file!"//& - CPSourceFileRef,error=error,failure=failure) + CPSourceFileRef,failure=failure) END SUBROUTINE rd_amber_section_c1 ! ***************************************************************************** @@ -1398,16 +1380,14 @@ END SUBROUTINE rd_amber_section_c1 !> \param section ... !> \param array1 ... !> \param dim ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - SUBROUTINE rd_amber_section_r1(parser, section, array1, dim, error) + SUBROUTINE rd_amber_section_r1(parser, section, array1, dim) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=default_string_length), & INTENT(IN) :: section REAL(KIND=dp), DIMENSION(:) :: array1 INTEGER, INTENT(IN) :: dim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'rd_amber_section_r1', & routineP = moduleN//':'//routineN @@ -1417,19 +1397,19 @@ SUBROUTINE rd_amber_section_r1(parser, section, array1, dim, error) failure = .FALSE. - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) i = 1 DO WHILE ((i<=dim).AND.(.NOT.my_end)) - IF (parser_test_next_token(parser,error=error)=="EOL")& - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + IF (parser_test_next_token(parser)=="EOL")& + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT - CALL parser_get_object(parser,array1(i),error=error) + CALL parser_get_object(parser,array1(i)) i = i + 1 END DO ! Trigger end of file aborting CALL cp_assert(.NOT.my_end.OR.(i>dim), cp_fatal_level, cp_assertion_failed, routineP,& "End of file while reading section "//TRIM(section)//" in amber topology file!"//& - CPSourceFileRef,error=error,failure=failure) + CPSourceFileRef,failure=failure) END SUBROUTINE rd_amber_section_r1 ! ***************************************************************************** @@ -1437,15 +1417,13 @@ END SUBROUTINE rd_amber_section_r1 !> \param parser ... !> \param section ... !> \param input_format ... -!> \param error ... !> \retval another_section ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - FUNCTION get_section_parmtop(parser, section, input_format, error) RESULT(another_section) + FUNCTION get_section_parmtop(parser, section, input_format) RESULT(another_section) TYPE(cp_parser_type), POINTER :: parser CHARACTER(LEN=default_string_length), & INTENT(OUT) :: section, input_format - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: another_section CHARACTER(len=*), PARAMETER :: routineN = 'get_section_parmtop', & @@ -1455,7 +1433,7 @@ FUNCTION get_section_parmtop(parser, section, input_format, error) RESULT(anoth LOGICAL :: failure, found, my_end failure = .FALSE. - CALL parser_search_string(parser,"%FLAG",.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,"%FLAG",.TRUE.,found,begin_line=.TRUE.) IF (found) THEN ! section label indflag = INDEX(parser%input_line,"%FLAG")+LEN_TRIM("%FLAG") @@ -1464,12 +1442,12 @@ FUNCTION get_section_parmtop(parser, section, input_format, error) RESULT(anoth END DO section = TRIM(parser%input_line(indflag:)) ! Input format - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) CALL cp_assert((INDEX(parser%input_line,"%FORMAT")/=0).AND.(.NOT.my_end),& cp_fatal_level, cp_assertion_failed, routineP,& "Expecting %FORMAT. Not found! Abort reading of AMBER topology file! "//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) start_f = INDEX(parser%input_line,"(") end_f = INDEX(parser%input_line,")") @@ -1484,14 +1462,12 @@ END FUNCTION get_section_parmtop !> \brief Check the version of the AMBER topology file (we can handle from v8 on) !> \param parser ... !> \param output_unit ... -!> \param error ... !> \retval found_AMBER_V8 ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - FUNCTION check_amber_8_std(parser, output_unit, error) RESULT(found_AMBER_V8) + FUNCTION check_amber_8_std(parser, output_unit) RESULT(found_AMBER_V8) TYPE(cp_parser_type), POINTER :: parser INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: found_AMBER_V8 CHARACTER(len=*), PARAMETER :: routineN = 'check_amber_8_std', & @@ -1500,12 +1476,12 @@ FUNCTION check_amber_8_std(parser, output_unit, error) RESULT(found_AMBER_V8) LOGICAL :: failure failure = .FALSE. - CALL parser_search_string(parser,"%VERSION ",.TRUE.,found_AMBER_V8,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,"%VERSION ",.TRUE.,found_AMBER_V8,begin_line=.TRUE.) CALL cp_assert(found_AMBER_V8, cp_failure_level, cp_assertion_failed, routineP,& "This is not an AMBER V.8 PRMTOP format file. Cannot interpret older "//& "AMBER file formats. "//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) IF (output_unit>0) WRITE(output_unit,'(" AMBER_INFO| ",A)')"Amber PrmTop V.8 or greater.",& TRIM(parser%input_line) @@ -1525,11 +1501,10 @@ END FUNCTION check_amber_8_std !> \param icb ... !> \param rk ... !> \param req ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 11.2008 ! ***************************************************************************** SUBROUTINE post_process_bonds_info(label_a, label_b, k, r0, particle_set, ibond, & - nbond, ib, jb, icb, rk, req, error) + nbond, ib, jb, icb, rk, req) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: label_a, label_b REAL(KIND=dp), DIMENSION(:), POINTER :: k, r0 @@ -1539,7 +1514,6 @@ SUBROUTINE post_process_bonds_info(label_a, label_b, k, r0, particle_set, ibond, INTEGER, INTENT(IN) :: nbond INTEGER, DIMENSION(:), INTENT(IN) :: ib, jb, icb REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rk, req - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_process_bonds_info', & routineP = moduleN//':'//routineN @@ -1555,9 +1529,9 @@ SUBROUTINE post_process_bonds_info(label_a, label_b, k, r0, particle_set, ibond, CALL timeset(routineN, handle) IF (nbond/=0) THEN ALLOCATE(work_label(2,nbond),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(nbond),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nbond name_atm_a = particle_set(ib(i))%atomic_kind%name name_atm_b = particle_set(jb(i))%atomic_kind%name @@ -1599,9 +1573,9 @@ SUBROUTINE post_process_bonds_info(label_a, label_b, k, r0, particle_set, ibond, END DO DEALLOCATE(work_label,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(iwork, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE post_process_bonds_info @@ -1622,11 +1596,10 @@ END SUBROUTINE post_process_bonds_info !> \param ict ... !> \param tk ... !> \param teq ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 11.2008 ! ***************************************************************************** SUBROUTINE post_process_bends_info(label_a, label_b, label_c, k, theta0, & - particle_set, itheta, ntheta, it, jt, kt, ict, tk, teq, error) + particle_set, itheta, ntheta, it, jt, kt, ict, tk, teq) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: label_a, label_b, label_c REAL(KIND=dp), DIMENSION(:), POINTER :: k, theta0 @@ -1636,7 +1609,6 @@ SUBROUTINE post_process_bends_info(label_a, label_b, label_c, k, theta0, & INTEGER, INTENT(IN) :: ntheta INTEGER, DIMENSION(:), INTENT(IN) :: it, jt, kt, ict REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: tk, teq - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_process_bends_info', & routineP = moduleN//':'//routineN @@ -1653,9 +1625,9 @@ SUBROUTINE post_process_bends_info(label_a, label_b, label_c, k, theta0, & CALL timeset(routineN,handle) IF (ntheta/=0) THEN ALLOCATE(work_label(3,ntheta),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(ntheta),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, ntheta name_atm_a = particle_set(it(i))%atomic_kind%name name_atm_b = particle_set(jt(i))%atomic_kind%name @@ -1706,9 +1678,9 @@ SUBROUTINE post_process_bends_info(label_a, label_b, label_c, k, theta0, & END DO DEALLOCATE(work_label,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(iwork, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE post_process_bends_info @@ -1733,12 +1705,10 @@ END SUBROUTINE post_process_bends_info !> \param pk ... !> \param pn ... !> \param phase ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 11.2008 ! ***************************************************************************** SUBROUTINE post_process_torsions_info(label_a, label_b, label_c, label_d, k,& - m, phi0, particle_set, iphi, nphi, ip, jp, kp, lp, icp, pk, pn, phase,& - error) + m, phi0, particle_set, iphi, nphi, ip, jp, kp, lp, icp, pk, pn, phase) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: label_a, label_b, label_c, & label_d @@ -1751,7 +1721,6 @@ SUBROUTINE post_process_torsions_info(label_a, label_b, label_c, label_d, k,& INTEGER, INTENT(IN) :: nphi INTEGER, DIMENSION(:), INTENT(IN) :: ip, jp, kp, lp, icp REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: pk, pn, phase - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_process_torsions_info', & routineP = moduleN//':'//routineN @@ -1768,9 +1737,9 @@ SUBROUTINE post_process_torsions_info(label_a, label_b, label_c, label_d, k,& CALL timeset(routineN, handle) IF (nphi/=0) THEN ALLOCATE(work_label(6,nphi),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(nphi),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, nphi name_atm_a = particle_set(ip(i))%atomic_kind%name name_atm_b = particle_set(jp(i))%atomic_kind%name @@ -1809,7 +1778,7 @@ SUBROUTINE post_process_torsions_info(label_a, label_b, label_c, label_d, k,& m(iphi) = NINT(pn (icp(iwork(1)))) IF (m(iphi)-pn (icp(iwork(1))).GT.EPSILON(1.0_dp)) THEN ! non integer torsions not supported - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF phi0(iphi) = phase(icp(iwork(1))) @@ -1843,16 +1812,16 @@ SUBROUTINE post_process_torsions_info(label_a, label_b, label_c, label_d, k,& m(iphi) = NINT(pn (icp(iwork(i)))) IF (m(iphi)-pn (icp(iwork(i))).GT.EPSILON(1.0_dp)) THEN ! non integer torsions not supported - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) ENDIF phi0(iphi) = phase(icp(iwork(i))) END IF END DO DEALLOCATE(work_label,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(iwork, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle) END SUBROUTINE post_process_torsions_info @@ -1870,11 +1839,10 @@ END SUBROUTINE post_process_torsions_info !> \param cn1 ... !> \param cn2 ... !> \param natom ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 11.2008 ! ***************************************************************************** SUBROUTINE post_process_LJ_info(atom_label, eps, sigma, particle_set,& - ntypes, nsize, iac, ico, cn1, cn2, natom, error) + ntypes, nsize, iac, ico, cn1, cn2, natom) CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: atom_label REAL(KIND=dp), DIMENSION(:), POINTER :: eps, sigma @@ -1885,7 +1853,6 @@ SUBROUTINE post_process_LJ_info(atom_label, eps, sigma, particle_set,& INTEGER, DIMENSION(:), INTENT(IN) :: iac, ico REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: cn1, cn2 INTEGER, INTENT(IN) :: natom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'post_process_LJ_info', & routineP = moduleN//':'//routineN @@ -1902,9 +1869,9 @@ SUBROUTINE post_process_LJ_info(atom_label, eps, sigma, particle_set,& failure = .FALSE. CALL timeset(routineN, handle) ALLOCATE(work_label(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(iwork(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natom name_atm_a = particle_set(i)%atomic_kind%name l_dum = qmmm_ff_precond_only_qm(id1=name_atm_a) @@ -1921,7 +1888,7 @@ SUBROUTINE post_process_LJ_info(atom_label, eps, sigma, particle_set,& F12 = cn1( ico(ntypes*(iac(iwork(1))-1) + iac(iwork(1)))) F6 = cn2( ico(ntypes*(iac(iwork(1))-1) + iac(iwork(1)))) check = (F6==0.0_dp).EQV.(F12==0.0_dp) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) my_sigma = 0.0_dp my_eps = 0.0_dp IF (F6/=0.0_dp) THEN @@ -1945,7 +1912,7 @@ SUBROUTINE post_process_LJ_info(atom_label, eps, sigma, particle_set,& F12 = cn1( ico(ntypes*(iac(iwork(i))-1) + iac(iwork(i)))) F6 = cn2( ico(ntypes*(iac(iwork(i))-1) + iac(iwork(i)))) check = (F6==0.0_dp).EQV.(F12==0.0_dp) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) my_sigma = 0.0_dp my_eps = 0.0_dp IF (F6/=0.0_dp) THEN @@ -1960,9 +1927,9 @@ SUBROUTINE post_process_LJ_info(atom_label, eps, sigma, particle_set,& END DO DEALLOCATE(work_label,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(iwork,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE post_process_LJ_info diff --git a/src/topology_cif.F b/src/topology_cif.F index 9ecd33817c..fdc92ae582 100644 --- a/src/topology_cif.F +++ b/src/topology_cif.F @@ -61,7 +61,6 @@ MODULE topology_cif !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \date 12.2008 !> \par Format Information implemented: !> _chemical_name @@ -83,11 +82,10 @@ MODULE topology_cif !> !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) + SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section) TYPE(topology_parameters_type) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_coordinate_cif', & routineP = moduleN//':'//routineN @@ -111,11 +109,11 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) NULLIFY(parser, logger) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/CIF_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) - pfactor=section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR",error) + pfactor=section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR") ! Element is assigned on the basis of the atm_name topology%aa_element = .TRUE. @@ -134,18 +132,18 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) IF (iw>0) WRITE(iw,*) " Reading in CIF file ",TRIM(topology%coord_file_name) CALL parser_create(parser,topology%coord_file_name,& - para_env=para_env,apply_preprocessing=.FALSE.,error=error) + para_env=para_env,apply_preprocessing=.FALSE.) ! Check for _chemical_name CALL parser_search_string(parser,"_chemical_name",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) IF (found) THEN IF (iw>0) WRITE(iw,'(/,A)')" CIF_INFO| _chemical_name :: "//TRIM(parser%input_line(parser%icol:)) END IF ! Check for _chemical_formula_sum CALL parser_search_string(parser,"_chemical_formula_sum",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) IF (found) THEN IF (iw>0) WRITE(iw,'(A)')" CIF_INFO| _chemical_formula_sum :: "//TRIM(parser%input_line(parser%icol:)) END IF @@ -154,79 +152,79 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) periodic = 1 ! Check for _cell_length_a CALL parser_search_string(parser,"_cell_length_a",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field (_cell_length_a) was not found in CIF file! "//& CPSourceFileRef) - CALL cif_get_real(parser,cell_lengths(1),error) - cell_lengths(1) = cp_unit_to_cp2k(cell_lengths(1),"angstrom",error=error) + CALL cif_get_real(parser,cell_lengths(1)) + cell_lengths(1) = cp_unit_to_cp2k(cell_lengths(1),"angstrom") ! Check for _cell_length_b CALL parser_search_string(parser,"_cell_length_b",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field (_cell_length_b) was not found in CIF file! "//& CPSourceFileRef) - CALL cif_get_real(parser,cell_lengths(2),error) - cell_lengths(2) = cp_unit_to_cp2k(cell_lengths(2),"angstrom",error=error) + CALL cif_get_real(parser,cell_lengths(2)) + cell_lengths(2) = cp_unit_to_cp2k(cell_lengths(2),"angstrom") ! Check for _cell_length_c CALL parser_search_string(parser,"_cell_length_c",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field (_cell_length_c) was not found in CIF file! "//& CPSourceFileRef) - CALL cif_get_real(parser,cell_lengths(3),error) - cell_lengths(3) = cp_unit_to_cp2k(cell_lengths(3),"angstrom",error=error) + CALL cif_get_real(parser,cell_lengths(3)) + cell_lengths(3) = cp_unit_to_cp2k(cell_lengths(3),"angstrom") ! Check for _cell_angle_alpha CALL parser_search_string(parser,"_cell_angle_alpha",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field (_cell_angle_alpha) was not found in CIF file! "//& CPSourceFileRef) - CALL cif_get_real(parser,cell_angles(1),error) - cell_angles(1) = cp_unit_to_cp2k(cell_angles(1),"deg",error=error) + CALL cif_get_real(parser,cell_angles(1)) + cell_angles(1) = cp_unit_to_cp2k(cell_angles(1),"deg") ! Check for _cell_angle_beta CALL parser_search_string(parser,"_cell_angle_beta",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field (_cell_angle_beta) was not found in CIF file! "//& CPSourceFileRef) - CALL cif_get_real(parser,cell_angles(2),error) - cell_angles(2) = cp_unit_to_cp2k(cell_angles(2),"deg",error=error) + CALL cif_get_real(parser,cell_angles(2)) + cell_angles(2) = cp_unit_to_cp2k(cell_angles(2),"deg") ! Check for _cell_angle_gamma CALL parser_search_string(parser,"_cell_angle_gamma",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field (_cell_angle_gamma) was not found in CIF file! "//& CPSourceFileRef) - CALL cif_get_real(parser,cell_angles(3),error) - cell_angles(3) = cp_unit_to_cp2k(cell_angles(3),"deg",error=error) + CALL cif_get_real(parser,cell_angles(3)) + cell_angles(3) = cp_unit_to_cp2k(cell_angles(3),"deg") ! Create cell NULLIFY (cell) - CALL cell_create(cell,error=error) + CALL cell_create(cell) CALL set_cell_param(cell,cell_lengths,cell_angles,periodic=periodic,& - do_init_cell=.TRUE.,error=error) - CALL write_cell(cell,subsys_section,label="CELL_CIF|",error=error) + do_init_cell=.TRUE.) + CALL write_cell(cell,subsys_section,label="CELL_CIF|") ! Parse atoms info and fractional coordinates ! Check for _atom_site_label CALL parser_search_string(parser,"_atom_site_label",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field _atom_site_label was not found in CIF file! "//& CPSourceFileRef) ifield = 0 ii = 1 ifield(ii) = 0 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) DO WHILE (INDEX(parser%input_line,"_atom_site_")/=0) ii = ii + 1 - CPPostcondition(ii<=20,cp_failure_level,routineP,error,failure) + CPPostcondition(ii<=20,cp_failure_level,routineP,failure) ifield (ii) = -1 ! Check for _atom_site_type_symbol @@ -237,7 +235,7 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) IF (INDEX(parser%input_line,"_atom_site_fract_y")/=0) ifield(ii) = 2 ! Check for _atom_site_fract_z IF (INDEX(parser%input_line,"_atom_site_fract_z")/=0) ifield(ii) = 3 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) END DO ! Parse real info natom = 0 @@ -263,29 +261,29 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) SELECT CASE (ifield(ii)) CASE (-1) ! Skip this field - CALL parser_get_object (parser,s_tag,error=error) + CALL parser_get_object (parser,s_tag) CASE (0) - CALL parser_get_object (parser,strtmp,error=error) + CALL parser_get_object (parser,strtmp) atom_info%id_atmname(natom) = str2id(strtmp) atom_info%id_molname(natom) = str2id(s2s("MOL"//TRIM(ADJUSTL(cp_to_string(natom))))) atom_info%id_resname(natom) = atom_info%id_molname(natom) atom_info%resid(natom) = 1 atom_info%id_element(natom) = atom_info%id_atmname(natom) CASE (1) - CALL cif_get_real(parser,atom_info%r(1,natom),error) + CALL cif_get_real(parser,atom_info%r(1,natom)) CASE (2) - CALL cif_get_real(parser,atom_info%r(2,natom),error) + CALL cif_get_real(parser,atom_info%r(2,natom)) CASE (3) - CALL cif_get_real(parser,atom_info%r(3,natom),error) + CALL cif_get_real(parser,atom_info%r(3,natom)) CASE DEFAULT ! Never reach this point.. - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT ii = ii + 1 END DO s = atom_info%r(1:3,natom) CALL scaled_to_real(atom_info%r(1:3,natom),s,cell) - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT END DO ! Preliminary check: check if atoms provided are really unique.. this is a paranoic @@ -296,13 +294,13 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) r2 = atom_info%r(1:3,jj) r = pbc(r1-r2,cell) check = (SQRT(DOT_PRODUCT(r,r))>=threshold) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END DO END DO ! Parse Symmetry Group and generation elements.. ! Check for _symmetry_space_group_name_h-m CALL parser_search_string(parser,"_symmetry_space_group_name_h-m",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) IF (found) THEN IF (iw>0) WRITE(iw,'(A)')" CIF_INFO| _symmetry_space_group_name_h-m :: "//TRIM(parser%input_line(parser%icol:)) END IF @@ -310,10 +308,10 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) ! Check for _symmetry_equiv_pos_as_xyz ! Check for _space_group_symop_operation_xyz CALL parser_search_string(parser,"_symmetry_equiv_pos_as_xyz",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) IF (.NOT. found) THEN CALL parser_search_string(parser,"_space_group_symop_operation_xyz",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) END IF CALL cp_assert(found,cp_warning_level,cp_assertion_failed,routineP,& "The fields (_symmetry_equiv_pos_as_xyz) or (_space_group_symop_operation_xyz) were not found in CIF file! "//& @@ -324,7 +322,7 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) isym = 0 IF (found) THEN ! Apply symmetry elements and generate the whole set of atoms in the unit cell - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) isym = 0 natom_orig = natom DO WHILE ((INDEX(parser%input_line,"loop_")==0).AND.(parser%input_line(1:1)/="_")) @@ -337,9 +335,9 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) ELSE iln3 = INDEX(parser%input_line(iln2+1:),"'")+iln2 END IF - CPPostcondition(iln1/=0,cp_failure_level,routineP,error,failure) - CPPostcondition(iln2/=iln1,cp_failure_level,routineP,error,failure) - CPPostcondition(iln3/=iln2,cp_failure_level,routineP,error,failure) + CPPostcondition(iln1/=0,cp_failure_level,routineP,failure) + CPPostcondition(iln2/=iln1,cp_failure_level,routineP,failure) + CPPostcondition(iln3/=iln2,cp_failure_level,routineP,failure) CALL initf(3) CALL parsef(1,TRIM(parser%input_line(iln0+1:iln1-1)),s2a("x","y","z")) CALL parsef(2,TRIM(parser%input_line(iln1+1:iln2-1)),s2a("x","y","z")) @@ -385,7 +383,7 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) END IF END DO Loop_over_unique_atoms CALL finalizef() - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT END DO END IF @@ -394,8 +392,8 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) IF (iw>0) WRITE(iw,'(A10,1X,3F12.6)')(TRIM(id2str(atom_info%id_atmname(ii))),atom_info%r(1:3,ii),ii=1,natom) ! Releasse local cell type and parser - CALL cell_release(cell,error=error) - CALL parser_release(parser,error=error) + CALL cell_release(cell) + CALL parser_release(parser) ! Reallocate all structures with the exact NATOM size CALL reallocate(atom_info%id_molname,1,natom) @@ -412,7 +410,7 @@ SUBROUTINE read_coordinate_cif (topology,para_env,subsys_section,error) topology%natoms = natom topology%molname_generated = .TRUE. CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/CIF_INFO",error=error) + "PRINT%TOPOLOGY_INFO/CIF_INFO") CALL timestop(handle) END SUBROUTINE read_coordinate_cif @@ -421,14 +419,12 @@ END SUBROUTINE read_coordinate_cif !> treat properly the accuracy specified in the CIF file, i.e. 3.45(6) !> \param parser ... !> \param r ... -!> \param error ... !> \date 12.2008 !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE cif_get_real(parser, r, error) + SUBROUTINE cif_get_real(parser, r) TYPE(cp_parser_type), POINTER :: parser REAL(KIND=dp), INTENT(OUT) :: r - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cif_get_real', & routineP = moduleN//':'//routineN @@ -436,7 +432,7 @@ SUBROUTINE cif_get_real(parser, r, error) CHARACTER(LEN=default_string_length) :: s_tag INTEGER :: iln - CALL parser_get_object (parser,s_tag,error=error) + CALL parser_get_object (parser,s_tag) iln = LEN_TRIM(s_tag) IF (INDEX(s_tag,"(")/=0) iln = INDEX(s_tag,"(")-1 READ(s_tag(1:iln),*) r diff --git a/src/topology_connectivity_util.F b/src/topology_connectivity_util.F index 4d31b64310..49bca49067 100644 --- a/src/topology_connectivity_util.F +++ b/src/topology_connectivity_util.F @@ -56,12 +56,11 @@ MODULE topology_connectivity_util !> \param molecule_set ... !> \param topology ... !> \param subsys_section ... -!> \param error ... !> \par History 11/2009 (Louis Vanduyhuys): added Out of Plane bends based on !> impropers in topology ! ***************************************************************************** SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& - topology,subsys_section,error) + topology,subsys_section) TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set TYPE(molecule_type), DIMENSION(:), & @@ -69,7 +68,6 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_connectivity_pack', & routineP = moduleN//':'//routineN @@ -103,18 +101,18 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) atom_info => topology%atom_info conn_info => topology%conn_info ALLOCATE(map_atom_mol(topology%natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_atom_type(topology%natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 1. Set the topology%[nmol_type,nmol,nmol_conn] @@ -178,7 +176,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& ELSE NULLIFY(molecule_kind_set) i = topology%nmol_type - CALL allocate_molecule_kind_set(molecule_kind_set,i,error=error) + CALL allocate_molecule_kind_set(molecule_kind_set,i) IF(iw>0) WRITE(iw,*) " Allocated molecule_kind_set, Dimenstion of ",& SIZE(molecule_kind_set) END IF @@ -193,7 +191,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& ELSE NULLIFY(molecule_set) i = topology%nmol - CALL allocate_molecule_set(molecule_set,i,error=error) + CALL allocate_molecule_set(molecule_set,i) IF(iw>0) WRITE(iw,*) " Allocated molecule_set, dimension of ",& topology%nmol END IF @@ -246,7 +244,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& IF (found) THEN ALLOCATE(molecule_list(imol-counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,SIZE(molecule_list) molecule_list(j)=j+counter END DO @@ -264,7 +262,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& imol = ABS(map_atom_mol(natom)) ! Last atom is also a molecule by itself ALLOCATE(molecule_list(imol-counter),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,SIZE(molecule_list) molecule_list(j)=j+counter END DO @@ -294,9 +292,9 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& ! 7. Set the molecule_set(imol)%[first_atom,last_atom] via set_molecule_set !----------------------------------------------------------------------------- ALLOCATE(first_list(SIZE(molecule_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(last_list(SIZE(molecule_set)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timeset(routineN//"_7",handle2) first_list(:) = 0 last_list (:) = 0 @@ -316,7 +314,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& first_list(imol)=j END IF END DO - CPPostcondition(imol==topology%nmol,cp_failure_level,routineP,error,failure) + CPPostcondition(imol==topology%nmol,cp_failure_level,routineP,failure) DO ikind=1,topology%nmol-1 last_list(ikind)=first_list(ikind+1)-1 END DO @@ -352,7 +350,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& natom = 0 IF(first/=0 .AND. last/=0) natom = last-first+1 ALLOCATE(atom_list(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i=1,natom !Atomic kind information will be filled in (PART 2) NULLIFY(atom_list(i)%atomic_kind) @@ -378,9 +376,9 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& nval_tot1 = nvar1 nval_tot2 = 0 ALLOCATE(map_var_mol(nvar1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_cvar_mol(nvar2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_var_mol = -1 map_cvar_mol = -1 DO i = 1, nvar1 @@ -395,8 +393,8 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& j1 = map_atom_mol(min_index) IF ( j1 > 0 ) map_cvar_mol(i) = map_atom_type(min_index) END DO - CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1, error) - CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2, error) + CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1) + CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2) DO i = 1, topology%nmol_type intra_bonds = 0 inter_bonds = 0 @@ -416,7 +414,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& nval_tot2 = nval_tot2 + ibond*SIZE(molecule_kind%molecule_list) ALLOCATE(bond_list(ibond),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ibond = 0 DO j=bnd_type(1,i),bnd_type(2,i) IF (j==0) CYCLE @@ -480,19 +478,19 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& WRITE(output_unit,'(T5,A)')"ERROR| One example could be two same kind of molecules have" WRITE(output_unit,'(T5,A)')"ERROR| a different number of atoms. Check the connectivity!" END IF - CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,error,failure) + CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,failure) DEALLOCATE(map_var_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvar_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_vars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_ctype,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle2) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -502,15 +500,15 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL timeset(routineN//"_11_pre",handle2) idim = 0 ALLOCATE(c_var_a(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_b(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_c(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) found = ASSOCIATED(conn_info%theta_type) IF (found) THEN ALLOCATE(c_var_type(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(conn_info%c_bond_a).AND.ASSOCIATED(conn_info%theta_a)) THEN DO j=1,SIZE(conn_info%theta_a) @@ -554,9 +552,9 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& nval_tot1 = nvar1 nval_tot2 = 0 ALLOCATE(map_var_mol(nvar1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_cvar_mol(nvar2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_var_mol = -1 map_cvar_mol = -1 DO i = 1, nvar1 @@ -572,8 +570,8 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& j1 = map_atom_mol(min_index) IF ( j1 > 0 ) map_cvar_mol(i) = map_atom_type(min_index) END DO - CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1, error) - CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2, error) + CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1) + CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2) DO i=1,topology%nmol_type intra_bends = 0 inter_bends = 0 @@ -592,7 +590,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& molecule_kind => molecule_kind_set(i) nval_tot2 = nval_tot2 + ibend*SIZE(molecule_kind%molecule_list) ALLOCATE(bend_list(ibend),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ibend = 0 DO j=bnd_type(1,i),bnd_type(2,i) IF (j==0) CYCLE @@ -652,28 +650,28 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL set_molecule_kind(molecule_kind=molecule_kind,& nbend=SIZE(bend_list),bend_list=bend_list) END DO - CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,error,failure) + CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,failure) DEALLOCATE(map_var_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvar_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_vars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_ctype,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_a,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_c,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (found) THEN DEALLOCATE(c_var_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -683,11 +681,11 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL timeset(routineN//"_12_pre",handle2) idim = 0 ALLOCATE(c_var_a(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_b(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_c(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ASSOCIATED(conn_info%c_bond_a).AND.ASSOCIATED(conn_info%ub_a)) THEN DO j=1,SIZE(conn_info%ub_a) j1 = map_atom_mol(conn_info%ub_a(j)) @@ -724,9 +722,9 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& nval_tot1 = nvar1 nval_tot2 = 0 ALLOCATE(map_var_mol(nvar1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_cvar_mol(nvar2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_var_mol = -1 map_cvar_mol = -1 DO i = 1, nvar1 @@ -742,8 +740,8 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& j1 = map_atom_mol(min_index) IF ( j1 > 0 ) map_cvar_mol(i) = map_atom_type(min_index) END DO - CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1, error) - CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2, error) + CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1) + CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2) DO i=1,topology%nmol_type intra_ubs = 0 inter_ubs = 0 @@ -762,7 +760,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& molecule_kind => molecule_kind_set(i) nval_tot2 = nval_tot2 + iub*SIZE(molecule_kind%molecule_list) ALLOCATE(ub_list(iub),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iub = 0 DO j=bnd_type(1,i),bnd_type(2,i) IF (j==0) CYCLE @@ -814,25 +812,25 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL set_molecule_kind(molecule_kind=molecule_kind,& nub=SIZE(ub_list),ub_list=ub_list) END DO - CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,error,failure) + CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,failure) DEALLOCATE(map_var_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvar_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_vars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_ctype,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_a,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_c,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle2) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -842,17 +840,17 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL timeset(routineN//"_13_pre",handle2) idim = 0 ALLOCATE(c_var_a(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_b(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_c(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_d(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) found = ASSOCIATED(conn_info%phi_type) IF (found) THEN ALLOCATE(c_var_type(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(conn_info%c_bond_a).AND.ASSOCIATED(conn_info%phi_a)) THEN DO j=1,SIZE(conn_info%phi_a) @@ -900,9 +898,9 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& nval_tot1 = nvar1 nval_tot2 = 0 ALLOCATE(map_var_mol(nvar1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_cvar_mol(nvar2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_var_mol = -1 map_cvar_mol = -1 DO i = 1, nvar1 @@ -919,8 +917,8 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& j1 = map_atom_mol(min_index) IF ( j1 > 0 ) map_cvar_mol(i) = map_atom_type(min_index) END DO - CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1, error) - CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2, error) + CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1) + CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2) DO i=1,topology%nmol_type intra_torsions = 0 inter_torsions = 0 @@ -939,7 +937,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& molecule_kind => molecule_kind_set(i) nval_tot2 = nval_tot2 + itorsion*SIZE(molecule_kind%molecule_list) ALLOCATE(torsion_list(itorsion),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) itorsion = 0 DO j=bnd_type(1,i),bnd_type(2,i) IF (j==0) CYCLE @@ -1005,30 +1003,30 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL set_molecule_kind(molecule_kind=molecule_kind,& ntorsion=SIZE(torsion_list),torsion_list=torsion_list) END DO - CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,error,failure) + CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,failure) DEALLOCATE(map_var_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvar_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_vars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_ctype,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_a,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_c,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_d,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (found) THEN DEALLOCATE(c_var_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -1040,17 +1038,17 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL timeset(routineN//"_14_pre",handle2) idim = 0 ALLOCATE(c_var_a(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_b(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_c(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(c_var_d(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) found = ASSOCIATED(conn_info%impr_type) IF (found) THEN ALLOCATE(c_var_type(idim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(conn_info%c_bond_a).AND.ASSOCIATED(conn_info%impr_a)) THEN DO j=1,SIZE(conn_info%impr_a) @@ -1098,9 +1096,9 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& nval_tot1 = nvar1 nval_tot2 = 0 ALLOCATE(map_var_mol(nvar1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_cvar_mol(nvar2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) map_var_mol = -1 map_cvar_mol = -1 DO i = 1, nvar1 @@ -1117,8 +1115,8 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& j1 = map_atom_mol(min_index) IF ( j1 > 0 ) map_cvar_mol(i) = map_atom_type(min_index) END DO - CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1, error) - CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2, error) + CALL find_bnd_typ(topology%nmol_type, map_vars, map_var_mol, bnd_type, nvar1) + CALL find_bnd_typ(topology%nmol_type, map_cvars, map_cvar_mol, bnd_ctype, nvar2) DO i=1,topology%nmol_type intra_imprs = 0 inter_imprs = 0 @@ -1141,7 +1139,7 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& nval_tot2 = nval_tot2 + iimpr*SIZE(molecule_kind%molecule_list) ALLOCATE(impr_list(iimpr),STAT=stat) ALLOCATE(opbend_list(iimpr),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iimpr = 0 DO j=bnd_type(1,i),bnd_type(2,i) IF (j==0) CYCLE @@ -1249,30 +1247,30 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& CALL set_molecule_kind(molecule_kind=molecule_kind,& nopbend=SIZE(opbend_list),opbend_list=opbend_list) END DO - CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,error,failure) + CPPostcondition(nval_tot1==nval_tot2,cp_failure_level,routineP,failure) DEALLOCATE(map_var_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvar_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_vars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_cvars,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bnd_ctype,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_a,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_c,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(c_var_d,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (found) THEN DEALLOCATE(c_var_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -1280,16 +1278,16 @@ SUBROUTINE topology_connectivity_pack(molecule_kind_set,molecule_set,& ! Finally deallocate some stuff. !----------------------------------------------------------------------------- DEALLOCATE(first_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(last_list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_atom_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_atom_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") END SUBROUTINE topology_connectivity_pack ! ***************************************************************************** @@ -1299,16 +1297,14 @@ END SUBROUTINE topology_connectivity_pack !> \param map_var_mol ... !> \param bnd_type ... !> \param nvar1 ... -!> \param error ... !> \par History !> Teodoro Laino ! ***************************************************************************** - SUBROUTINE find_bnd_typ(nmol_type, map_vars, map_var_mol, bnd_type, nvar1, error) + SUBROUTINE find_bnd_typ(nmol_type, map_vars, map_var_mol, bnd_type, nvar1) INTEGER, INTENT(IN) :: nmol_type INTEGER, DIMENSION(:), POINTER :: map_vars, map_var_mol INTEGER, DIMENSION(:, :), POINTER :: bnd_type INTEGER, INTENT(IN) :: nvar1 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'find_bnd_typ', & routineP = moduleN//':'//routineN @@ -1318,10 +1314,10 @@ SUBROUTINE find_bnd_typ(nmol_type, map_vars, map_var_mol, bnd_type, nvar1, error failure = .FALSE. ALLOCATE(map_vars(nvar1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL sort(map_var_mol,nvar1,map_vars) ALLOCATE(bnd_type(2,nmol_type),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) bnd_type = 0 IF (nvar1==0) RETURN DO j = 1, nvar1 @@ -1345,14 +1341,12 @@ END SUBROUTINE find_bnd_typ !> \brief Handles the multiple unit cell option for the connectivity !> \param topology ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 06.2009 ! ***************************************************************************** - SUBROUTINE topology_conn_multiple(topology, subsys_section, error) + SUBROUTINE topology_conn_multiple(topology, subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_conn_multiple', & routineP = moduleN//':'//routineN @@ -1368,7 +1362,7 @@ SUBROUTINE topology_conn_multiple(topology, subsys_section, error) failure = .FALSE. NULLIFY(multiple_unit_cell) CALL section_vals_val_get(subsys_section, "TOPOLOGY%MULTIPLE_UNIT_CELL",& - i_vals=multiple_unit_cell, error=error) + i_vals=multiple_unit_cell) IF (ANY(multiple_unit_cell/=1)) THEN fac = PRODUCT(multiple_unit_cell) conn_info => topology%conn_info diff --git a/src/topology_constraint_util.F b/src/topology_constraint_util.F index ecf40c5e50..62b065fd4e 100644 --- a/src/topology_constraint_util.F +++ b/src/topology_constraint_util.F @@ -80,11 +80,9 @@ MODULE topology_constraint_util !> \param input_file ... !> \param subsys_section ... !> \param gci ... -!> \param error ... ! ***************************************************************************** SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& - topology,qmmm_env,particle_set,input_file,subsys_section,gci,& - error) + topology,qmmm_env,particle_set,input_file,subsys_section,gci) TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set TYPE(molecule_type), DIMENSION(:), & @@ -97,7 +95,6 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& POINTER :: particle_set TYPE(section_vals_type), POINTER :: input_file, subsys_section TYPE(global_constraint_type), POINTER :: gci - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_constraint_pack', & routineP = moduleN//':'//routineN @@ -154,24 +151,24 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& failure = .FALSE. NULLIFY(logger, constr_x_mol, constr_x_glob) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) CALL timeset(routineN//"_1",handle2) cons_info => topology%cons_info hbonds_section => section_vals_get_subs_vals(input_file,& - "MOTION%CONSTRAINT%HBONDS",error=error) + "MOTION%CONSTRAINT%HBONDS") fixd_restr_rest => section_vals_get_subs_vals(input_file,& - "MOTION%CONSTRAINT%FIX_ATOM_RESTART",error=error) - CALL section_vals_get(fixd_restr_rest,explicit=restart_restraint_pos, error=error) + "MOTION%CONSTRAINT%FIX_ATOM_RESTART") + CALL section_vals_get(fixd_restr_rest,explicit=restart_restraint_pos) colvar_rest => section_vals_get_subs_vals(input_file,& - "MOTION%CONSTRAINT%COLVAR_RESTART",error=error) - CALL section_vals_get(colvar_rest,explicit=restart_restraint_clv, error=error) + "MOTION%CONSTRAINT%COLVAR_RESTART") + CALL section_vals_get(colvar_rest,explicit=restart_restraint_clv) colvar_func_info => section_vals_get_subs_vals(subsys_section,& - "COLVAR%COLVAR_FUNC_INFO",error=error) - CALL section_vals_get(colvar_func_info,explicit=use_clv_info, error=error) + "COLVAR%COLVAR_FUNC_INFO") + CALL section_vals_get(colvar_func_info,explicit=use_clv_info) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! 1. NULLIFY the molecule_set(imol)%lci via set_molecule_set @@ -184,7 +181,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& topology%const_33 .OR. topology%const_46 .OR. & topology%const_colv ) THEN ALLOCATE(lci,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(lci%lcolv) NULLIFY(lci%lg3x3) NULLIFY(lci%lg4x6) @@ -192,7 +189,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& CALL set_molecule(molecule,lci=lci) END DO ALLOCATE(gci,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(gci%lcolv,& gci%lg3x3,& gci%lg4x6,& @@ -208,7 +205,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& gci%ng3x3_restraint = 0 gci%ng4x6_restraint = 0 gci%nvsite_restraint = 0 - CALL setup_colvar_counters(gci%colv_list,gci%ncolv,error) + CALL setup_colvar_counters(gci%colv_list,gci%ncolv) gci%nrestraint = gci%ng3x3_restraint +& gci%ng4x6_restraint +& gci%nvsite_restraint +& @@ -223,30 +220,30 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& topology%const_colv = .TRUE. NULLIFY(atom_typeh, hdist) ALLOCATE(constr_x_mol(SIZE(molecule_kind_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, SIZE(molecule_kind_set) ALLOCATE(constr_x_mol(i)%constr(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) constr_x_mol(i)%constr(1) = 1 END DO - CALL section_vals_val_get(hbonds_section,"MOLECULE",n_rep_val=nrep,error=error) + CALL section_vals_val_get(hbonds_section,"MOLECULE",n_rep_val=nrep) IF (nrep/=0) THEN NULLIFY(inds) DO i = 1, SIZE(molecule_kind_set) constr_x_mol(i)%constr(1) = 0 END DO - CALL section_vals_val_get(hbonds_section,"MOLECULE",i_vals=inds,error=error) + CALL section_vals_val_get(hbonds_section,"MOLECULE",i_vals=inds) DO i = 1, SIZE(inds) constr_x_mol(inds(i))%constr(1) = 1 END DO ELSE - CALL section_vals_val_get(hbonds_section,"MOLNAME",n_rep_val=nrep,error=error) + CALL section_vals_val_get(hbonds_section,"MOLNAME",n_rep_val=nrep) IF (nrep/=0) THEN NULLIFY(cnds) DO i = 1, SIZE(molecule_kind_set) constr_x_mol(i)%constr(1) = 0 END DO - CALL section_vals_val_get(hbonds_section,"MOLNAME",c_vals=cnds,error=error) + CALL section_vals_val_get(hbonds_section,"MOLNAME",c_vals=cnds) DO i = 1, SIZE(cnds) found_molname = .FALSE. DO k = 1, SIZE(molecule_kind_set) @@ -258,21 +255,21 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& found_molname = .TRUE. END IF END DO - CALL print_warning_molname(found_molname, cnds(i), error) + CALL print_warning_molname(found_molname, cnds(i)) END DO END IF END IF - CALL section_vals_val_get(hbonds_section,"ATOM_TYPE",n_rep_val=nrep,error=error) + CALL section_vals_val_get(hbonds_section,"ATOM_TYPE",n_rep_val=nrep) IF (nrep/=0) & - CALL section_vals_val_get(hbonds_section,"ATOM_TYPE",c_vals=atom_typeh,error=error) - CALL section_vals_val_get(hbonds_section,"TARGETS",n_rep_val=nrep,error=error) + CALL section_vals_val_get(hbonds_section,"ATOM_TYPE",c_vals=atom_typeh) + CALL section_vals_val_get(hbonds_section,"TARGETS",n_rep_val=nrep) IF (nrep/=0) & - CALL section_vals_val_get(hbonds_section,"TARGETS",r_vals=hdist,error=error) + CALL section_vals_val_get(hbonds_section,"TARGETS",r_vals=hdist) IF (ASSOCIATED(hdist)) THEN - CPPostcondition(SIZE(hdist)==SIZE(atom_typeh),cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(hdist)==SIZE(atom_typeh),cp_failure_level,routineP,failure) END IF - CALL section_vals_val_get(hbonds_section,"exclude_qm",l_val=exclude_qm,error=error) - CALL section_vals_val_get(hbonds_section,"exclude_mm",l_val=exclude_mm,error=error) + CALL section_vals_val_get(hbonds_section,"exclude_qm",l_val=exclude_qm) + CALL section_vals_val_get(hbonds_section,"exclude_mm",l_val=exclude_mm) nhdist = 0 DO i=1,SIZE(molecule_kind_set) molecule_kind => molecule_kind_set(i) @@ -316,7 +313,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& CALL reallocate(cons_info%const_colv_molname,1,cons_info%nconst_colv) CALL reallocate(cons_info%const_colv_target,1,cons_info%nconst_colv) CALL reallocate(cons_info%const_colv_target_growth,1,cons_info%nconst_colv) - CALL colvar_p_reallocate(cons_info%colvar_set,1,cons_info%nconst_colv,error=error) + CALL colvar_p_reallocate(cons_info%colvar_set,1,cons_info%nconst_colv) ! Fill in Restraints info CALL reallocate(cons_info%colv_intermolecular,1,cons_info%nconst_colv) CALL reallocate(cons_info%colv_restraint,1,cons_info%nconst_colv) @@ -386,19 +383,19 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& cons_info%const_colv_target(nhdist+n_start_colv) = rmod cons_info%const_colv_target_growth(nhdist+n_start_colv) = 0.0_dp CALL colvar_create(cons_info%colvar_set(nhdist+n_start_colv)%colvar,& - dist_colvar_id, error) + dist_colvar_id) cons_info%colvar_set(nhdist+n_start_colv)%colvar%dist_param%i_at = bond_list(k)%a cons_info%colvar_set(nhdist+n_start_colv)%colvar%dist_param%j_at = bond_list(k)%b - CALL colvar_setup(cons_info%colvar_set(nhdist+n_start_colv)%colvar, error) + CALL colvar_setup(cons_info%colvar_set(nhdist+n_start_colv)%colvar) END IF END DO END DO DO j = 1, SIZE(constr_x_mol) DEALLOCATE(constr_x_mol(j)%constr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(constr_x_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle2) @@ -410,7 +407,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& IF(topology%const_colv) THEN ! Post Process of COLVARS.. DO ii = 1, SIZE(cons_info%colvar_set) - CALL post_process_colvar(cons_info%colvar_set(ii)%colvar, particle_set, error) + CALL post_process_colvar(cons_info%colvar_set(ii)%colvar, particle_set) END DO ! Real constraint/restraint part.. CALL give_constraint_array(cons_info%const_colv_mol,& @@ -420,8 +417,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& constr_x_glob,& molecule_kind_set,& cons_info%colv_exclude_qm,& - cons_info%colv_exclude_mm,& - error) + cons_info%colv_exclude_mm) ! Intramolecular constraints gind = 0 cind = 0 @@ -431,7 +427,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& nmolecule=nmolecule, molecule_list=molecule_list) ncolv_mol = SIZE(constr_x_mol(ii)%constr) ALLOCATE(colv_list(ncolv_mol),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Starting index of the first molecule of this kind. ! We need the index if no target is provided in the input file ! for the collective variable.. The target will be computed on the @@ -440,46 +436,46 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& CALL get_molecule ( molecule, first_atom = first_atom) CALL setup_colv_list(colv_list, constr_x_mol(ii)%constr, gind,& cons_info, topology, particle_set, restart_restraint_clv,& - colvar_rest, first_atom, error) - CALL setup_colvar_counters(colv_list,ncolv,error) + colvar_rest, first_atom) + CALL setup_colvar_counters(colv_list,ncolv) CALL set_molecule_kind(molecule_kind,colv_list=colv_list,ncolv=ncolv) DO j=1,nmolecule molecule => molecule_set(molecule_list(j)) CALL get_molecule ( molecule, first_atom = first_atom, last_atom= last_atom) ALLOCATE(lcolv(ncolv_mol),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL setup_lcolv(lcolv, constr_x_mol(ii)%constr, first_atom, last_atom,& - cons_info, particle_set, colvar_func_info, use_clv_info, cind, error) + cons_info, particle_set, colvar_func_info, use_clv_info, cind) CALL set_molecule(molecule=molecule,lcolv=lcolv) END DO END DO DO j = 1, SIZE(constr_x_mol) DEALLOCATE(constr_x_mol(j)%constr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(constr_x_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Intermolecular constraints ncolv_glob = 0 IF (ASSOCIATED(constr_x_glob)) THEN ncolv_glob = SIZE(constr_x_glob) ALLOCATE(colv_list(ncolv_glob),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL setup_colv_list(colv_list, constr_x_glob, gind, cons_info,& topology, particle_set, restart_restraint_clv, colvar_rest,& - first_atom=1, error=error) - CALL setup_colvar_counters(colv_list,ncolv,error) + first_atom=1) + CALL setup_colvar_counters(colv_list,ncolv) ALLOCATE(lcolv(ncolv_glob),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL setup_lcolv(lcolv, constr_x_glob, 1, SIZE(particle_set), cons_info,& - particle_set, colvar_func_info, use_clv_info, cind, error) + particle_set, colvar_func_info, use_clv_info, cind) gci%colv_list => colv_list gci%lcolv => lcolv gci%ncolv = ncolv ! Total number of Intermolecular constraints gci%ntot = gci%ncolv%ntot + gci%ntot DEALLOCATE(constr_x_glob,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -497,8 +493,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& constr_x_glob,& molecule_kind_set,& cons_info%g33_exclude_qm,& - cons_info%g33_exclude_mm,& - error) + cons_info%g33_exclude_mm) ! Intramolecular constraints DO ii = 1, SIZE(molecule_kind_set) molecule_kind => molecule_kind_set(ii) @@ -507,33 +502,33 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& molecule_list=molecule_list) ng3x3 = SIZE(constr_x_mol(ii)%constr) ALLOCATE(g3x3_list(ng3x3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_g3x3_list(g3x3_list, constr_x_mol(ii)%constr, cons_info, ng3x3_restraint, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_g3x3_list(g3x3_list, constr_x_mol(ii)%constr, cons_info, ng3x3_restraint) CALL set_molecule_kind(molecule_kind,ng3x3=ng3x3,ng3x3_restraint=ng3x3_restraint,g3x3_list=g3x3_list) DO j=1,nmolecule molecule => molecule_set(molecule_list(j)) CALL get_molecule ( molecule, first_atom = first_atom, last_atom= last_atom) ALLOCATE(lg3x3(ng3x3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_lg3x3(lg3x3, g3x3_list, first_atom, last_atom, error ) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_lg3x3(lg3x3, g3x3_list, first_atom, last_atom) CALL set_molecule(molecule=molecule,lg3x3=lg3x3) END DO END DO DO j = 1, SIZE(constr_x_mol) DEALLOCATE(constr_x_mol(j)%constr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(constr_x_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Intermolecular constraints IF (ASSOCIATED(constr_x_glob)) THEN ng3x3 = SIZE(constr_x_glob) ALLOCATE(g3x3_list(ng3x3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_g3x3_list(g3x3_list, constr_x_glob, cons_info, ng3x3_restraint, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_g3x3_list(g3x3_list, constr_x_glob, cons_info, ng3x3_restraint) ALLOCATE(lg3x3(ng3x3),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_lg3x3(lg3x3, g3x3_list, first_atom,last_atom, error ) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_lg3x3(lg3x3, g3x3_list, first_atom,last_atom) gci%g3x3_list => g3x3_list gci%lg3x3 => lg3x3 gci%ng3x3 = ng3x3 @@ -541,7 +536,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& ! Total number of Intermolecular constraints gci%ntot = 3*gci%ng3x3 + gci%ntot DEALLOCATE(constr_x_glob,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -559,8 +554,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& constr_x_glob,& molecule_kind_set,& cons_info%g46_exclude_qm,& - cons_info%g46_exclude_mm,& - error) + cons_info%g46_exclude_mm) ! Intramolecular constraints DO ii = 1, SIZE(molecule_kind_set) molecule_kind => molecule_kind_set(ii) @@ -568,33 +562,33 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& nmolecule=nmolecule,molecule_list=molecule_list) ng4x6 = SIZE(constr_x_mol(ii)%constr) ALLOCATE(g4x6_list(ng4x6),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_g4x6_list(g4x6_list, constr_x_mol(ii)%constr, cons_info, ng4x6_restraint, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_g4x6_list(g4x6_list, constr_x_mol(ii)%constr, cons_info, ng4x6_restraint) CALL set_molecule_kind(molecule_kind,ng4x6=ng4x6,ng4x6_restraint=ng4x6_restraint,g4x6_list=g4x6_list) DO j=1,nmolecule molecule => molecule_set(molecule_list(j)) CALL get_molecule ( molecule, first_atom = first_atom, last_atom= last_atom) ALLOCATE(lg4x6(ng4x6),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_lg4x6(lg4x6, g4x6_list, first_atom, last_atom, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_lg4x6(lg4x6, g4x6_list, first_atom, last_atom) CALL set_molecule(molecule=molecule,lg4x6=lg4x6) END DO END DO DO j = 1, SIZE(constr_x_mol) DEALLOCATE(constr_x_mol(j)%constr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(constr_x_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Intermolecular constraints IF (ASSOCIATED(constr_x_glob)) THEN ng4x6 = SIZE(constr_x_glob) ALLOCATE(g4x6_list(ng4x6),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_g4x6_list(g4x6_list, constr_x_glob, cons_info, ng4x6_restraint, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_g4x6_list(g4x6_list, constr_x_glob, cons_info, ng4x6_restraint) ALLOCATE(lg4x6(ng4x6),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_lg4x6(lg4x6, g4x6_list, first_atom,last_atom, error ) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_lg4x6(lg4x6, g4x6_list, first_atom,last_atom) gci%g4x6_list => g4x6_list gci%lg4x6 => lg4x6 gci%ng4x6 = ng4x6 @@ -602,7 +596,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& ! Total number of Intermolecular constraints gci%ntot = 6*gci%ng4x6 + gci%ntot DEALLOCATE(constr_x_glob,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -620,8 +614,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& constr_x_glob,& molecule_kind_set,& cons_info%vsite_exclude_qm,& - cons_info%vsite_exclude_mm,& - error) + cons_info%vsite_exclude_mm) ! Intramolecular constraints DO ii = 1, SIZE(molecule_kind_set) molecule_kind => molecule_kind_set(ii) @@ -629,30 +622,30 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& nmolecule=nmolecule,molecule_list=molecule_list) nvsite = SIZE(constr_x_mol(ii)%constr) ALLOCATE(vsite_list(nvsite),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_vsite_list(vsite_list, constr_x_mol(ii)%constr, cons_info, nvsite_restraint, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_vsite_list(vsite_list, constr_x_mol(ii)%constr, cons_info, nvsite_restraint) CALL set_molecule_kind(molecule_kind,nvsite=nvsite,nvsite_restraint=nvsite_restraint,& vsite_list=vsite_list) END DO DO j = 1, SIZE(constr_x_mol) DEALLOCATE(constr_x_mol(j)%constr,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(constr_x_mol,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Intermolecular constraints IF (ASSOCIATED(constr_x_glob)) THEN nvsite = SIZE(constr_x_glob) ALLOCATE(vsite_list(nvsite),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL setup_vsite_list(vsite_list, constr_x_glob, cons_info, nvsite_restraint, error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL setup_vsite_list(vsite_list, constr_x_glob, cons_info, nvsite_restraint) gci%vsite_list => vsite_list gci%nvsite = nvsite gci%nvsite_restraint = nvsite_restraint ! Total number of Intermolecular constraints gci%ntot = gci%nvsite + gci%ntot DEALLOCATE(constr_x_glob,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF CALL timestop(handle2) @@ -663,10 +656,10 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& !----------------------------------------------------------------------------- IF(topology%const_atom) THEN ALLOCATE(fixd_list_gci(SIZE(particle_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nfixd_list_gci = 0 ALLOCATE(missed_molname(SIZE(cons_info%fixed_molnames,1)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) missed_molname=.TRUE. nfixd_restart = 0 DO i=1,SIZE(molecule_kind_set) @@ -714,7 +707,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& END DO END DO ALLOCATE(fixd_list(nfixed_atoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) kk = 0 nfixd_restraint = 0 IF (nfixed_atoms/=0) THEN @@ -810,7 +803,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& fixd_list(kk)%restraint%k0 = cons_info%fixed_mol_k0(k1loc) ELSE ! Should never reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF IF (fixd_list(kk)%restraint%active) THEN nfixd_restraint = nfixd_restraint+ 1 @@ -836,31 +829,31 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& IF (restart_restraint_pos) THEN ! Read coord0 value for restraint CALL section_vals_val_get(fixd_restr_rest,"_DEFAULT_KEYWORD_",& - i_rep_val=nfixd_restart, r_vals=r, error=error) + i_rep_val=nfixd_restart, r_vals=r) SELECT CASE(itype) CASE(use_perd_x) - CPPostcondition(SIZE(r)==1,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==1,cp_failure_level,routineP,failure) fixd_list(kk)%coord(1) = r(1) CASE(use_perd_y) - CPPostcondition(SIZE(r)==1,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==1,cp_failure_level,routineP,failure) fixd_list(kk)%coord(2) = r(1) CASE(use_perd_z) - CPPostcondition(SIZE(r)==1,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==1,cp_failure_level,routineP,failure) fixd_list(kk)%coord(3) = r(1) CASE(use_perd_xy) - CPPostcondition(SIZE(r)==2,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==2,cp_failure_level,routineP,failure) fixd_list(kk)%coord(1) = r(1) fixd_list(kk)%coord(2) = r(2) CASE(use_perd_xz) - CPPostcondition(SIZE(r)==2,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==2,cp_failure_level,routineP,failure) fixd_list(kk)%coord(1) = r(1) fixd_list(kk)%coord(3) = r(2) CASE(use_perd_yz) - CPPostcondition(SIZE(r)==2,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==2,cp_failure_level,routineP,failure) fixd_list(kk)%coord(2) = r(1) fixd_list(kk)%coord(3) = r(2) CASE(use_perd_xyz) - CPPostcondition(SIZE(r)==3,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r)==3,cp_failure_level,routineP,failure) fixd_list(kk)%coord(1:3) = r(1:3) END SELECT ELSE @@ -868,38 +861,38 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& SELECT CASE(itype) CASE(use_perd_x) ALLOCATE(r(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r(1) = fixd_list(kk)%coord(1) CASE(use_perd_y) ALLOCATE(r(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r(1) = fixd_list(kk)%coord(2) CASE(use_perd_z) ALLOCATE(r(1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r(1) = fixd_list(kk)%coord(3) CASE(use_perd_xy) ALLOCATE(r(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r(1) = fixd_list(kk)%coord(1) r(2) = fixd_list(kk)%coord(2) CASE(use_perd_xz) ALLOCATE(r(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r(1) = fixd_list(kk)%coord(1) r(2) = fixd_list(kk)%coord(3) CASE(use_perd_yz) ALLOCATE(r(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r(1) = fixd_list(kk)%coord(1) r(2) = fixd_list(kk)%coord(3) CASE(use_perd_xyz) ALLOCATE(r(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) r(1:3) = fixd_list(kk)%coord(1:3) END SELECT CALL section_vals_val_set(fixd_restr_rest,"_DEFAULT_KEYWORD_",& - i_rep_val=nfixd_restart, r_vals_ptr=r, error=error) + i_rep_val=nfixd_restart, r_vals_ptr=r) END IF END IF END IF @@ -917,18 +910,18 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& IF (iw>0) THEN WRITE(iw,*)"TOTAL NUMBER OF FIXED ATOMS:",nfixd_list_gci END IF - CPPostcondition(COUNT(missed_molname)==0,cp_failure_level,routineP,error,failure) + CPPostcondition(COUNT(missed_molname)==0,cp_failure_level,routineP,failure) DEALLOCATE(missed_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Intermolecular constraints IF (gci%ntot /=0) THEN ALLOCATE(fixd_list(nfixd_list_gci),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fixd_list(1:nfixd_list_gci)=fixd_list_gci(1:nfixd_list_gci) gci%fixd_list=>fixd_list END IF DEALLOCATE(fixd_list_gci,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Final setup of the number of possible restraints gci%nrestraint = gci%ng3x3_restraint +& @@ -936,7 +929,7 @@ SUBROUTINE topology_constraint_pack ( molecule_kind_set, molecule_set,& gci%nvsite_restraint +& gci%ncolv%nrestraint CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") CALL timestop(handle2) CALL timestop(handle) END SUBROUTINE topology_constraint_pack @@ -952,13 +945,12 @@ END SUBROUTINE topology_constraint_pack !> \param restart_restraint_clv ... !> \param colvar_rest ... !> \param first_atom ... -!> \param error ... !> \par History !> Updated 2007 for intermolecular constraints !> \author Teodoro Laino [2007] ! ***************************************************************************** SUBROUTINE setup_colv_list(colv_list, ilist, gind, cons_info, topology,& - particle_set, restart_restraint_clv, colvar_rest, first_atom, error) + particle_set, restart_restraint_clv, colvar_rest, first_atom) TYPE(colvar_constraint_type), & DIMENSION(:), POINTER :: colv_list @@ -972,7 +964,6 @@ SUBROUTINE setup_colv_list(colv_list, ilist, gind, cons_info, topology,& LOGICAL, INTENT(IN) :: restart_restraint_clv TYPE(section_vals_type), POINTER :: colvar_rest INTEGER, INTENT(IN) :: first_atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_colv_list', & routineP = moduleN//':'//routineN @@ -989,7 +980,7 @@ SUBROUTINE setup_colv_list(colv_list, ilist, gind, cons_info, topology,& ncolv_mol = ncolv_mol + 1 kdim = SIZE(cons_info%colvar_set(j)%colvar%i_atom) ALLOCATE(colv_list(ncolv_mol)%i_atoms(kdim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) colv_list(ncolv_mol)%inp_seq_num = j colv_list(ncolv_mol)%type_id = cons_info%colvar_set(j)%colvar%type_id colv_list(ncolv_mol)%i_atoms = cons_info%colvar_set(j)%colvar%i_atom @@ -1001,10 +992,10 @@ SUBROUTINE setup_colv_list(colv_list, ilist, gind, cons_info, topology,& ! Let's compute the value.. NULLIFY(local_colvar) CALL colvar_clone(local_colvar, cons_info%colvar_set(j)%colvar,& - i_atom_offset=first_atom-1, error=error) - CALL colvar_eval_mol_f(local_colvar, topology%cell, particle_set, error=error) + i_atom_offset=first_atom-1) + CALL colvar_eval_mol_f(local_colvar, topology%cell, particle_set) colv_list(ncolv_mol)%expected_value = local_colvar%ss - CALL colvar_release(local_colvar, error=error) + CALL colvar_release(local_colvar) ELSE colv_list(ncolv_mol)%expected_value = cons_info%const_colv_target(j) END IF @@ -1015,12 +1006,12 @@ SUBROUTINE setup_colv_list(colv_list, ilist, gind, cons_info, topology,& gind = gind + 1 IF (restart_restraint_clv) THEN CALL section_vals_val_get(colvar_rest,"_DEFAULT_KEYWORD_",& - i_rep_val=gind, r_val=rmod, error=error) + i_rep_val=gind, r_val=rmod) colv_list(ncolv_mol)%expected_value = rmod ELSE rmod = colv_list(ncolv_mol)%expected_value CALL section_vals_val_set(colvar_rest,"_DEFAULT_KEYWORD_",& - i_rep_val=gind, r_val=rmod, error=error) + i_rep_val=gind, r_val=rmod) END IF END IF ! Only if torsion let's take into account the singularity in the definition @@ -1037,18 +1028,16 @@ END SUBROUTINE setup_colv_list !> \param ilist ... !> \param cons_info ... !> \param ng3x3_restraint ... -!> \param error ... !> \par History !> Updated 2007 for intermolecular constraints !> \author Teodoro Laino [2007] ! ***************************************************************************** - SUBROUTINE setup_g3x3_list(g3x3_list, ilist, cons_info, ng3x3_restraint, error) + SUBROUTINE setup_g3x3_list(g3x3_list, ilist, cons_info, ng3x3_restraint) TYPE(g3x3_constraint_type), & DIMENSION(:), POINTER :: g3x3_list INTEGER, DIMENSION(:), POINTER :: ilist TYPE(constraint_info_type), POINTER :: cons_info INTEGER, INTENT(OUT) :: ng3x3_restraint - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_g3x3_list', & routineP = moduleN//':'//routineN @@ -1080,18 +1069,16 @@ END SUBROUTINE setup_g3x3_list !> \param ilist ... !> \param cons_info ... !> \param ng4x6_restraint ... -!> \param error ... !> \par History !> Updated 2007 for intermolecular constraints !> \author Teodoro Laino [2007] ! ***************************************************************************** - SUBROUTINE setup_g4x6_list(g4x6_list, ilist, cons_info, ng4x6_restraint, error) + SUBROUTINE setup_g4x6_list(g4x6_list, ilist, cons_info, ng4x6_restraint) TYPE(g4x6_constraint_type), & DIMENSION(:), POINTER :: g4x6_list INTEGER, DIMENSION(:), POINTER :: ilist TYPE(constraint_info_type), POINTER :: cons_info INTEGER, INTENT(OUT) :: ng4x6_restraint - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_g4x6_list', & routineP = moduleN//':'//routineN @@ -1128,17 +1115,15 @@ END SUBROUTINE setup_g4x6_list !> \param ilist ... !> \param cons_info ... !> \param nvsite_restraint ... -!> \param error ... !> \par History !> \author Marcel Baer [2008] ! ***************************************************************************** - SUBROUTINE setup_vsite_list(vsite_list, ilist, cons_info, nvsite_restraint, error) + SUBROUTINE setup_vsite_list(vsite_list, ilist, cons_info, nvsite_restraint) TYPE(vsite_constraint_type), & DIMENSION(:), POINTER :: vsite_list INTEGER, DIMENSION(:), POINTER :: ilist TYPE(constraint_info_type), POINTER :: cons_info INTEGER, INTENT(OUT) :: nvsite_restraint - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_vsite_list', & routineP = moduleN//':'//routineN @@ -1175,14 +1160,13 @@ END SUBROUTINE setup_vsite_list !> \param colvar_func_info ... !> \param use_clv_info ... !> \param cind ... -!> \param error ... !> \par History !> Updated 2007 for intermolecular constraints !> \author Teodoro Laino [2007] ! ***************************************************************************** SUBROUTINE setup_lcolv(lcolv, ilist, first_atom, last_atom, cons_info,& particle_set, colvar_func_info, use_clv_info,& - cind, error) + cind) TYPE(local_colvar_constraint_type), & DIMENSION(:), POINTER :: lcolv INTEGER, DIMENSION(:), POINTER :: ilist @@ -1193,7 +1177,6 @@ SUBROUTINE setup_lcolv(lcolv, ilist, first_atom, last_atom, cons_info,& TYPE(section_vals_type), POINTER :: colvar_func_info LOGICAL, INTENT(IN) :: use_clv_info INTEGER, INTENT(INOUT) :: cind - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_lcolv', & routineP = moduleN//':'//routineN @@ -1213,7 +1196,7 @@ SUBROUTINE setup_lcolv(lcolv, ilist, first_atom, last_atom, cons_info,& NULLIFY(lcolv(kk)%colvar, lcolv(kk)%colvar_old) ! Colvar CALL colvar_clone(lcolv(kk)%colvar, cons_info%colvar_set(k)%colvar,& - i_atom_offset=first_atom-1,error=error) + i_atom_offset=first_atom-1) ! Some COLVARS may need additional information for evaluating the ! functional form: this is the case for COLVARS which depend on the @@ -1224,13 +1207,13 @@ SUBROUTINE setup_lcolv(lcolv, ilist, first_atom, last_atom, cons_info,& cind = cind + 1 IF (use_clv_info) THEN CALL section_vals_val_get(colvar_func_info,"_DEFAULT_KEYWORD_",& - i_rep_val=cind, r_vals=r_vals, error=error) + i_rep_val=cind, r_vals=r_vals) SELECT CASE(lcolv(kk)%colvar%type_id) CASE(xyz_diag_colvar_id) - CPPostcondition(SIZE(r_vals)==3,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r_vals)==3,cp_failure_level,routineP,failure) lcolv(kk)%colvar%xyz_diag_param%r0=r_vals CASE(xyz_outerdiag_colvar_id) - CPPostcondition(SIZE(r_vals)==6,cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(r_vals)==6,cp_failure_level,routineP,failure) lcolv(kk)%colvar%xyz_outerdiag_param%r0(:,1)=r_vals(1:3) lcolv(kk)%colvar%xyz_outerdiag_param%r0(:,2)=r_vals(4:6) END SELECT @@ -1238,13 +1221,13 @@ SUBROUTINE setup_lcolv(lcolv, ilist, first_atom, last_atom, cons_info,& SELECT CASE(lcolv(kk)%colvar%type_id) CASE(xyz_diag_colvar_id) ALLOCATE(r_vals(3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ind=first_atom-1+lcolv(kk)%colvar%xyz_diag_param%i_atom r_vals=particle_set(ind)%r lcolv(kk)%colvar%xyz_diag_param%r0=r_vals CASE(xyz_outerdiag_colvar_id) ALLOCATE(r_vals(6),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ind=first_atom-1+lcolv(kk)%colvar%xyz_outerdiag_param%i_atoms(1) r_vals(1:3)=particle_set(ind)%r ind=first_atom-1+lcolv(kk)%colvar%xyz_outerdiag_param%i_atoms(2) @@ -1253,12 +1236,12 @@ SUBROUTINE setup_lcolv(lcolv, ilist, first_atom, last_atom, cons_info,& lcolv(kk)%colvar%xyz_outerdiag_param%r0(:,2)=r_vals(4:6) END SELECT CALL section_vals_val_set(colvar_func_info,"_DEFAULT_KEYWORD_",& - i_rep_val=cind, r_vals_ptr=r_vals, error=error) + i_rep_val=cind, r_vals_ptr=r_vals) END IF END IF ! Setup Colvar_old - CALL colvar_clone(lcolv(kk)%colvar_old,lcolv(kk)%colvar,error=error) + CALL colvar_clone(lcolv(kk)%colvar_old,lcolv(kk)%colvar) ! Check for consistency in the constraint definition IF (ANY(lcolv(kk)%colvar%i_atom > last_atom).OR.& @@ -1270,7 +1253,7 @@ SUBROUTINE setup_lcolv(lcolv, ilist, first_atom, last_atom, cons_info,& "This could be very probable due to a wrong connectivity, or an error",& " in the constraint specification in the input file.",& " Please check it carefully!" - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END SUBROUTINE setup_lcolv @@ -1281,18 +1264,16 @@ END SUBROUTINE setup_lcolv !> \param g3x3_list ... !> \param first_atom ... !> \param last_atom ... -!> \param error ... !> \par History !> Updated 2007 for intermolecular constraints !> \author Teodoro Laino [2007] ! ***************************************************************************** - SUBROUTINE setup_lg3x3(lg3x3, g3x3_list, first_atom, last_atom, error) + SUBROUTINE setup_lg3x3(lg3x3, g3x3_list, first_atom, last_atom) TYPE(local_g3x3_constraint_type), & DIMENSION(:), POINTER :: lg3x3 TYPE(g3x3_constraint_type), & DIMENSION(:), POINTER :: g3x3_list INTEGER, INTENT(IN) :: first_atom, last_atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_lg3x3', & routineP = moduleN//':'//routineN @@ -1328,7 +1309,7 @@ SUBROUTINE setup_lg3x3(lg3x3, g3x3_list, first_atom, last_atom, error) "This could be very probable due to a wrong connectivity, or an error",& " in the constraint specification in the input file.",& " Please check it carefully!" - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO @@ -1340,18 +1321,16 @@ END SUBROUTINE setup_lg3x3 !> \param g4x6_list ... !> \param first_atom ... !> \param last_atom ... -!> \param error ... !> \par History !> Updated 2007 for intermolecular constraints !> \author Teodoro Laino [2007] ! ***************************************************************************** - SUBROUTINE setup_lg4x6(lg4x6, g4x6_list, first_atom, last_atom, error) + SUBROUTINE setup_lg4x6(lg4x6, g4x6_list, first_atom, last_atom) TYPE(local_g4x6_constraint_type), & DIMENSION(:), POINTER :: lg4x6 TYPE(g4x6_constraint_type), & DIMENSION(:), POINTER :: g4x6_list INTEGER, INTENT(IN) :: first_atom, last_atom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_lg4x6', & routineP = moduleN//':'//routineN @@ -1398,7 +1377,7 @@ SUBROUTINE setup_lg4x6(lg4x6, g4x6_list, first_atom, last_atom, error) "This could be very probable due to a wrong connectivity, or an error",& " in the constraint specification in the input file.",& " Please check it carefully!" - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO @@ -1414,13 +1393,12 @@ END SUBROUTINE setup_lg4x6 !> \param molecule_kind_set ... !> \param exclude_qm ... !> \param exclude_mm ... -!> \param error ... !> \par History !> Updated 2007 for intermolecular constraints !> \author Teodoro Laino [2006] ! ***************************************************************************** SUBROUTINE give_constraint_array(const_mol, const_molname, const_intermolecular,& - constr_x_mol, constr_x_glob, molecule_kind_set, exclude_qm, exclude_mm, error) + constr_x_mol, constr_x_glob, molecule_kind_set, exclude_qm, exclude_mm) INTEGER, DIMENSION(:), POINTER :: const_mol CHARACTER(LEN=default_string_length), & @@ -1432,7 +1410,6 @@ SUBROUTINE give_constraint_array(const_mol, const_molname, const_intermolecular, TYPE(molecule_kind_type), DIMENSION(:), & POINTER :: molecule_kind_set LOGICAL, DIMENSION(:), POINTER :: exclude_qm, exclude_mm - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'give_constraint_array', & routineP = moduleN//':'//routineN @@ -1447,13 +1424,13 @@ SUBROUTINE give_constraint_array(const_mol, const_molname, const_intermolecular, CALL timeset(routineN,handle) NULLIFY(molecule_kind) ALLOCATE(constr_x_mol(SIZE(molecule_kind_set)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, SIZE(constr_x_mol) NULLIFY(constr_x_mol(i)%constr) ALLOCATE(constr_x_mol(i)%constr(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO - CPPostcondition(SIZE(const_mol)==SIZE(const_molname),cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(const_mol)==SIZE(const_molname),cp_failure_level,routineP,failure) iglob = 0 DO i = 1, SIZE(const_mol) IF (const_intermolecular(i)) THEN @@ -1471,7 +1448,7 @@ SUBROUTINE give_constraint_array(const_mol, const_molname, const_intermolecular, " molecule index ("//cp_to_string(k)//") is out of range of the possible"//& " molecule kinds ("//cp_to_string(SIZE(molecule_kind_set))//")."//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) isize = SIZE(constr_x_mol(k)%constr) CALL reallocate(constr_x_mol(k)%constr, 1, isize+1) constr_x_mol(k)%constr(isize+1) = i @@ -1491,7 +1468,7 @@ SUBROUTINE give_constraint_array(const_mol, const_molname, const_intermolecular, found_molname = .TRUE. END IF END DO - CALL print_warning_molname(found_molname, myname, error) + CALL print_warning_molname(found_molname, myname) END IF END IF END DO @@ -1502,13 +1479,11 @@ END SUBROUTINE give_constraint_array !> \brief Prints a warning message if undefined molnames are used to define constraints !> \param found ... !> \param name ... -!> \param error ... !> \author Teodoro Laino [2007] - Zurich University ! ***************************************************************************** - SUBROUTINE print_warning_molname(found, name, error) + SUBROUTINE print_warning_molname(found, name) LOGICAL, INTENT(IN) :: found CHARACTER(LEN=*), INTENT(IN) :: name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'print_warning_molname', & routineP = moduleN//':'//routineN diff --git a/src/topology_coordinate_util.F b/src/topology_coordinate_util.F index b7a6fcd2b9..03481da783 100644 --- a/src/topology_coordinate_util.F +++ b/src/topology_coordinate_util.F @@ -75,14 +75,13 @@ MODULE topology_coordinate_util !> \param force_env_section ... !> \param exclusions ... !> \param ignore_outside_box ... -!> \param error ... !> \par History !> Teodoro Laino - modified in order to optimize the list of molecules !> to build the exclusion lists ! ***************************************************************************** SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& molecule_kind_set,molecule_set,topology,qmmm,qmmm_env,& - subsys_section,force_env_section,exclusions,ignore_outside_box,error) + subsys_section,force_env_section,exclusions,ignore_outside_box) TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set TYPE(atomic_kind_type), DIMENSION(:), & @@ -101,7 +100,6 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& TYPE(exclusion_type), DIMENSION(:), & OPTIONAL, POINTER :: exclusions LOGICAL, INTENT(IN), OPTIONAL :: ignore_outside_box - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_coordinate_pack', & routineP = moduleN//':'//routineN @@ -138,10 +136,10 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) - topology_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY",error=error) + extension=".subsysLog") + topology_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY") CALL timeset(routineN,handle) my_qmmm = .FALSE. @@ -157,13 +155,13 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& counter=0 NULLIFY(id_work,mass,id_element,charge) ALLOCATE(id_work(topology%natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mass(topology%natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(id_element(topology%natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(charge(topology%natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) id_work=str2id(s2s("")) IF (iw>0) WRITE(iw,*)"molecule_kind_set ::",SIZE(molecule_kind_set) DO i = 1, SIZE(molecule_kind_set) @@ -207,12 +205,12 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& END DO topology%natom_type = counter ALLOCATE(atom_info%id_atom_names(topology%natom_type),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO k=1,counter atom_info%id_atom_names(k)=id_work(k) ENDDO DEALLOCATE(id_work,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL reallocate(mass,1,counter) CALL reallocate(id_element,1,counter) CALL reallocate(charge,1,counter) @@ -235,7 +233,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& !----------------------------------------------------------------------------- CALL timeset(routineN//'_3',handle2) NULLIFY(particle_set) - CALL allocate_particle_set(particle_set,topology%natoms,error) + CALL allocate_particle_set(particle_set,topology%natoms) CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -256,9 +254,9 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& END IF END DO DEALLOCATE(mass,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(id_element,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -267,9 +265,9 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& !----------------------------------------------------------------------------- CALL timeset(routineN//'_5',handle2) ALLOCATE(kind_of(topology%natoms),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(natom_of_kind(topology%natom_type),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) kind_of(:) = 0 natom_of_kind(:) = 0 DO i=1,topology%natom_type @@ -287,7 +285,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& WRITE(*,*)"Two molecules have been defined as identical molecules but atoms mismatch charges!!" END IF END DO - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF CALL timestop(handle2) @@ -300,7 +298,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& atomic_kind => atomic_kind_set(i) NULLIFY (iatomlist) ALLOCATE(iatomlist(natom_of_kind(i)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) counter=0 DO j=1,topology%natoms IF(kind_of(j)==i) THEN @@ -322,10 +320,10 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& CALL set_atomic_kind(atomic_kind=atomic_kind,& natom=natom_of_kind(i),atom_list=iatomlist) DEALLOCATE(iatomlist,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(natom_of_kind,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -333,8 +331,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& ! 7. Possibly center the coordinates and fill in coordinates in particle_set !----------------------------------------------------------------------------- CALL section_vals_val_get(subsys_section,& - "TOPOLOGY%CENTER_COORDINATES%_SECTION_PARAMETERS_",l_val=do_center,& - error=error) + "TOPOLOGY%CENTER_COORDINATES%_SECTION_PARAMETERS_",l_val=do_center) CALL timeset(routineN//'_7a',handle2) bounds(1,1) = MINVAL(atom_info%r(1,:)) bounds(2,1) = MAXVAL(atom_info%r(1,:)) @@ -367,12 +364,10 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& only_ionode=.TRUE.) IF (do_center) THEN CALL section_vals_val_get(subsys_section,& - "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT",explicit=explicit,& - error=error) + "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT",explicit=explicit) IF (explicit) THEN CALL section_vals_val_get(subsys_section,& - "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT",r_vals=cpoint,& - error=error) + "TOPOLOGY%CENTER_COORDINATES%CENTER_POINT",r_vals=cpoint) vec = cpoint ELSE vec = cdims/2.0_dp @@ -394,7 +389,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& END DO CALL timestop(handle2) DEALLOCATE(kind_of,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- @@ -403,15 +398,15 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& ! 10. Fill in the exclusions%list_onfo !----------------------------------------------------------------------------- CALL timeset(routineN//'_89',handle2) - CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id,error=error) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id) CALL section_vals_val_get(subsys_section,"TOPOLOGY%DISABLE_EXCLUSION_LISTS",& - l_val=disable_exclusion_lists,error=error) + l_val=disable_exclusion_lists) IF ((method_name_id == do_fist).AND.(.NOT.disable_exclusion_lists)) THEN - CPPostcondition(PRESENT(exclusions),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(exclusions),cp_failure_level,routineP,failure) natom=topology%natoms ! allocate exclusions. Most likely they would only be needed for the local_particles ALLOCATE(exclusions(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom NULLIFY(exclusions(i)%list_exclude_vdw) NULLIFY(exclusions(i)%list_exclude_ei) @@ -419,69 +414,69 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& ENDDO ! Reorder bonds ALLOCATE(ex_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%bond_a)) THEN N = SIZE(conn_info%bond_a) - CALL reorder_structure(ex_bond_list, conn_info%bond_a, conn_info%bond_b, N, error) + CALL reorder_structure(ex_bond_list, conn_info%bond_a, conn_info%bond_b, N) END IF ! Check if a list of 1-2 exclusion bonds is defined.. if not use all bonds NULLIFY(ex_bond_list_vdw, ex_bond_list_ei) ! VdW - exclude_section => section_vals_get_subs_vals(topology_section,"EXCLUDE_VDW_LIST",error=error) - CALL section_vals_get(exclude_section, explicit=explicit, error=error) + exclude_section => section_vals_get_subs_vals(topology_section,"EXCLUDE_VDW_LIST") + CALL section_vals_get(exclude_section, explicit=explicit) present_12_excl_vdw_list = .FALSE. IF (explicit) present_12_excl_vdw_list = .TRUE. IF (present_12_excl_vdw_list) THEN ALLOCATE(ex_bond_list_vdw(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_bond_list_vdw(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO CALL setup_exclusion_list(exclude_section,"BOND", ex_bond_list, ex_bond_list_vdw,& - particle_set, error) + particle_set) ELSE ex_bond_list_vdw => ex_bond_list END IF ! EI - exclude_section => section_vals_get_subs_vals(topology_section,"EXCLUDE_EI_LIST",error=error) - CALL section_vals_get(exclude_section, explicit=explicit, error=error) + exclude_section => section_vals_get_subs_vals(topology_section,"EXCLUDE_EI_LIST") + CALL section_vals_get(exclude_section, explicit=explicit) present_12_excl_ei_list = .FALSE. IF (explicit) present_12_excl_ei_list = .TRUE. IF (present_12_excl_ei_list) THEN ALLOCATE(ex_bond_list_ei(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_bond_list_ei(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO CALL setup_exclusion_list(exclude_section,"BOND", ex_bond_list, ex_bond_list_ei,& - particle_set, error) + particle_set) ELSE ex_bond_list_ei => ex_bond_list END IF CALL section_vals_val_get(topology_section, "AUTOGEN_EXCLUDE_LISTS", & - l_val=autogen, error=error) + l_val=autogen) ! Reorder bends ALLOCATE(ex_bend_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_bend_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO IF (autogen) THEN ! Construct autogenerated 1-3 pairs, i.e. all possible 1-3 pairs instead ! of only the bends that are present in the topology. ALLOCATE(pairs(0,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) N = 0 DO iatom = 1, natom DO i = 1, SIZE(ex_bond_list(iatom)%array1) @@ -511,28 +506,28 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& END DO END DO END DO - CALL reorder_structure(ex_bend_list, pairs(:,1), pairs(:,2), N, error) + CALL reorder_structure(ex_bend_list, pairs(:,1), pairs(:,2), N) DEALLOCATE(pairs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF (ASSOCIATED(conn_info%theta_a)) THEN N = SIZE(conn_info%theta_a) - CALL reorder_structure(ex_bend_list, conn_info%theta_a, conn_info%theta_c, N, error) + CALL reorder_structure(ex_bend_list, conn_info%theta_a, conn_info%theta_c, N) END IF END IF ! Reorder onfo ALLOCATE(ex_onfo_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_onfo_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO IF (autogen) THEN ! Construct autogenerated 1-4 pairs, i.e. all possible 1-4 pairs instead ! of only the onfo's that are present in the topology. ALLOCATE(pairs(0,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) N = 0 DO iatom = 1, natom DO i = 1, SIZE(ex_bond_list(iatom)%array1) @@ -572,13 +567,13 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& END DO END DO END DO - CALL reorder_structure(ex_onfo_list, pairs(:,1), pairs(:,2), N, error) + CALL reorder_structure(ex_onfo_list, pairs(:,1), pairs(:,2), N) DEALLOCATE(pairs,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE IF(ASSOCIATED(conn_info%onfo_a)) THEN N = SIZE(conn_info%onfo_a) - CALL reorder_structure(ex_onfo_list, conn_info%onfo_a, conn_info%onfo_b, N, error) + CALL reorder_structure(ex_onfo_list, conn_info%onfo_a, conn_info%onfo_b, N) END IF END IF @@ -602,7 +597,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& IF (dim3 /= 0) THEN NULLIFY(list, wlist) ALLOCATE(wlist(dim3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wlist( dim0:dim0) = iatom IF (dim1>dim0) wlist(dim0+1:dim1) = ex_bond_list_vdw(iatom)%array1 IF (dim2>dim1) wlist(dim1+1:dim2) = ex_bend_list(iatom)%array1 @@ -616,7 +611,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& END DO dim3 = SIZE(wlist)-COUNT(wlist==0) ALLOCATE(list(dim3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) j = 0 DO i = 1, SIZE(wlist) IF (wlist(i)==0)CYCLE @@ -624,7 +619,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& list(j)=wlist(i) END DO DEALLOCATE(wlist,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Unique list completed NULLIFY(list2) IF((topology%exclude_vdw==topology%exclude_ei).AND.& @@ -649,7 +644,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& IF (dim3 /= 0) THEN ALLOCATE(wlist(dim3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wlist( dim0:dim0) = iatom IF (dim1>dim0) wlist(dim0+1:dim1) = ex_bond_list_ei(iatom)%array1 IF (dim2>dim1) wlist(dim1+1:dim2) = ex_bend_list(iatom)%array1 @@ -663,7 +658,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& END DO dim3 = SIZE(wlist)-COUNT(wlist==0) ALLOCATE(list2(dim3),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) j = 0 DO i = 1, SIZE(wlist) IF (wlist(i)==0)CYCLE @@ -671,7 +666,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& list2(j)=wlist(i) END DO DEALLOCATE(wlist,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Unique list completed END IF END IF @@ -681,7 +676,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& ! Keep a list of onfo atoms for proper selection of specialized 1-4 ! potentials instead of conventional nonbonding potentials. ALLOCATE(exclusions(iatom)%list_onfo(SIZE(ex_onfo_list(iatom)%array1))) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! copy of data, not copy of pointer exclusions(iatom)%list_onfo = ex_onfo_list(iatom)%array1 IF (iw>0) THEN @@ -704,44 +699,44 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& ! deallocate onfo DO I=1,natom DEALLOCATE(ex_onfo_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_onfo_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! deallocate bends DO I=1,natom DEALLOCATE(ex_bend_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bend_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! deallocate bonds IF (present_12_excl_ei_list) THEN DO I=1,natom DEALLOCATE(ex_bond_list_ei(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bond_list_ei,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE NULLIFY(ex_bond_list_ei) END IF IF (present_12_excl_vdw_list) THEN DO I=1,natom DEALLOCATE(ex_bond_list_vdw(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bond_list_vdw,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE NULLIFY(ex_bond_list_vdw) END IF DO I=1,natom DEALLOCATE(ex_bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -749,20 +744,20 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& ! 11. Set the atomic_kind_set()%fist_potentail%[qeff] (PART 1) !----------------------------------------------------------------------------- CALL timeset(routineN//'_10',handle2) - CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id,error=error) + CALL section_vals_val_get(force_env_section,"METHOD",i_val=method_name_id) IF(method_name_id == do_fist) THEN DO i=1,SIZE(atomic_kind_set) atomic_kind => atomic_kind_set(i) CALL get_atomic_kind(atomic_kind=atomic_kind,name=atmname) qeff = charge(i) NULLIFY(fist_potential) - CALL allocate_potential(fist_potential,error) + CALL allocate_potential(fist_potential) CALL set_potential(potential=fist_potential,qeff=qeff) CALL set_atomic_kind(atomic_kind=atomic_kind,fist_potential=fist_potential) END DO END IF DEALLOCATE(charge,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle2) !----------------------------------------------------------------------------- @@ -803,7 +798,7 @@ SUBROUTINE topology_coordinate_pack (particle_set,atomic_kind_set,& CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") END SUBROUTINE topology_coordinate_pack ! ***************************************************************************** @@ -814,19 +809,17 @@ END SUBROUTINE topology_coordinate_pack !> \param ex_bond_list ... !> \param ex_bond_list_w ... !> \param particle_set ... -!> \param error ... !> \par History !> Teodoro Laino [tlaino] - 12.2009 ! ***************************************************************************** SUBROUTINE setup_exclusion_list(exclude_section, keyword, ex_bond_list,& - ex_bond_list_w, particle_set, error) + ex_bond_list_w, particle_set) TYPE(section_vals_type), POINTER :: exclude_section CHARACTER(LEN=*), INTENT(IN) :: keyword TYPE(array1_list_type), DIMENSION(:), & POINTER :: ex_bond_list, ex_bond_list_w TYPE(particle_type), DIMENSION(:), & POINTER :: particle_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_exclusion_list', & routineP = moduleN//':'//routineN @@ -838,14 +831,14 @@ SUBROUTINE setup_exclusion_list(exclude_section, keyword, ex_bond_list,& LOGICAL :: failure failure = .FALSE. - CPPostcondition(ASSOCIATED(ex_bond_list),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(ex_bond_list_w),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ex_bond_list),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(ex_bond_list_w),cp_failure_level,routineP,failure) SELECT CASE(keyword) CASE ("BOND") - CALL section_vals_val_get(exclude_section,keyword,n_rep_val=n_rep,error=error) + CALL section_vals_val_get(exclude_section,keyword,n_rep_val=n_rep) DO j=1, SIZE(ex_bond_list) - CPPostcondition(ASSOCIATED(ex_bond_list(j)%array1),cp_failure_level,routineP,error,failure) - CPPostcondition(ASSOCIATED(ex_bond_list_w(j)%array1),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(ex_bond_list(j)%array1),cp_failure_level,routineP,failure) + CPPostcondition(ASSOCIATED(ex_bond_list_w(j)%array1),cp_failure_level,routineP,failure) flag1=particle_set(j)%atomic_kind%name m = SIZE(ex_bond_list(j)%array1) @@ -857,7 +850,7 @@ SUBROUTINE setup_exclusion_list(exclude_section, keyword, ex_bond_list,& flag2=particle_set(ind)%atomic_kind%name DO i=1, n_rep CALL section_vals_val_get(exclude_section,keyword,i_rep_val=i,& - c_vals=names,error=error) + c_vals=names) IF (((TRIM(names(1))==TRIM(flag1)).AND.(TRIM(names(2))==TRIM(flag2))).OR.& ((TRIM(names(1))==TRIM(flag2)).AND.(TRIM(names(2))==TRIM(flag1)))) THEN l = l + 1 @@ -868,7 +861,7 @@ SUBROUTINE setup_exclusion_list(exclude_section, keyword, ex_bond_list,& CALL reallocate(ex_bond_list_w(j)%array1,1,l) END DO CASE DEFAULT - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE setup_exclusion_list diff --git a/src/topology_cp2k.F b/src/topology_cp2k.F index ce95edf9e8..8af9ebb92c 100644 --- a/src/topology_cp2k.F +++ b/src/topology_cp2k.F @@ -50,17 +50,15 @@ MODULE topology_cp2k !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \date 17.01.2011 (Creation, MK) !> \author Matthias Krack (MK) !> \version 1.0 ! ***************************************************************************** - SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) + SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section) TYPE(topology_parameters_type) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_coordinate_cp2k', & routineP = moduleN//':'//routineN @@ -84,22 +82,22 @@ SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) NULLIFY (logger) NULLIFY (parser) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/XYZ_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") ! Check if there is a &COORD section - coord_section => section_vals_get_subs_vals(subsys_section,"COORD",error=error) - CALL section_vals_get(coord_section,explicit=explicit,error=error) + coord_section => section_vals_get_subs_vals(subsys_section,"COORD") + CALL section_vals_get(coord_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(coord_section,"UNIT",c_val=string,error=error) - CALL section_vals_val_get(coord_section,"SCALED",l_val=scaled_coordinates,error=error) + CALL section_vals_val_get(coord_section,"UNIT",c_val=string) + CALL section_vals_val_get(coord_section,"SCALED",l_val=scaled_coordinates) ELSE ! The default is Cartesian coordinates in Angstrom scaled_coordinates = .FALSE. string = "angstrom" END IF - unit_conv = cp_unit_to_cp2k(1.0_dp,TRIM(string),error=error) + unit_conv = cp_unit_to_cp2k(1.0_dp,TRIM(string)) atom_info => topology%atom_info cell => topology%cell_muc @@ -109,8 +107,8 @@ SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) "BEGIN of COORD section data read from file "//TRIM(topology%coord_file_name) END IF - pfactor = section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR",error) - number_of_atoms = section_get_ival(subsys_section,"TOPOLOGY%NUMBER_OF_ATOMS",error) + pfactor = section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR") + number_of_atoms = section_get_ival(subsys_section,"TOPOLOGY%NUMBER_OF_ATOMS") IF (number_of_atoms < 1) THEN newsize = 1000 ELSE @@ -132,11 +130,11 @@ SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) ! Element is assigned on the basis of the atm_name topology%aa_element = .TRUE. - CALL parser_create(parser,topology%coord_file_name,para_env=para_env,error=error) + CALL parser_create(parser,topology%coord_file_name,para_env=para_env) natom = 0 DO - CALL parser_get_object(parser,object=string,newline=.TRUE.,at_end=eof,error=error) + CALL parser_get_object(parser,object=string,newline=.TRUE.,at_end=eof) IF (eof) EXIT natom = natom + 1 IF (natom > SIZE(atom_info%id_atmname)) THEN @@ -154,18 +152,18 @@ SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) END IF atom_info%id_atmname(natom) = str2id(s2s(string)) DO i=1,3 - CALL parser_get_object(parser,object=r(i),error=error) + CALL parser_get_object(parser,object=r(i)) END DO IF (scaled_coordinates) THEN CALL scaled_to_real(atom_info%r(1:3,natom),r,cell) ELSE atom_info%r(1:3,natom) = r(1:3)*unit_conv END IF - IF (parser_test_next_token(parser,error=error) /= "EOL") THEN - CALL parser_get_object(parser,object=string,error=error) + IF (parser_test_next_token(parser) /= "EOL") THEN + CALL parser_get_object(parser,object=string) atom_info%id_molname(natom) = str2id(s2s(string)) - IF (parser_test_next_token(parser,error=error) /= "EOL") THEN - CALL parser_get_object(parser,object=string,error=error) + IF (parser_test_next_token(parser) /= "EOL") THEN + CALL parser_get_object(parser,object=string) atom_info%id_resname(natom) = str2id(s2s(string)) ELSE atom_info%id_resname(natom) = atom_info%id_molname(natom) @@ -190,7 +188,7 @@ SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) IF (natom == number_of_atoms) EXIT END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) topology%natoms = natom CALL reallocate(atom_info%id_molname,1,natom) @@ -204,7 +202,7 @@ SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) CALL reallocate(atom_info%beta,1,natom) CALL reallocate(atom_info%id_element,1,natom) - CALL section_vals_val_set(subsys_section,"TOPOLOGY%NUMBER_OF_ATOMS",i_val=natom,error=error) + CALL section_vals_val_set(subsys_section,"TOPOLOGY%NUMBER_OF_ATOMS",i_val=natom) IF (iw > 0) THEN WRITE (UNIT=iw,FMT="(T2,A)")& @@ -212,8 +210,7 @@ SUBROUTINE read_coordinate_cp2k(topology,para_env,subsys_section,error) END IF CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/XYZ_INFO",& - error=error) + "PRINT%TOPOLOGY_INFO/XYZ_INFO") CALL timestop(handle) diff --git a/src/topology_generate_util.F b/src/topology_generate_util.F index 8a809a0bd9..111a8ed703 100644 --- a/src/topology_generate_util.F +++ b/src/topology_generate_util.F @@ -86,15 +86,13 @@ MODULE topology_generate_util !> \param natom_prev ... !> \param nbond_prev ... !> \param id_molname ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** SUBROUTINE topology_generate_molname(conn_info, natom, natom_prev, nbond_prev,& - id_molname, error) + id_molname) TYPE(connectivity_info_type), POINTER :: conn_info INTEGER, INTENT(IN) :: natom, natom_prev, nbond_prev INTEGER, DIMENSION(:), INTENT(INOUT) :: id_molname - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_molname', & routineP = moduleN//':'//routineN @@ -111,32 +109,32 @@ SUBROUTINE topology_generate_molname(conn_info, natom, natom_prev, nbond_prev,& ! convert a simple list of bonds to a list of bonds per atom ! (each bond is present in the forward and backward direction ALLOCATE(atom_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(atom_bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%bond_a)) N = SIZE(conn_info%bond_a) - nbond_prev CALL reorder_structure(atom_bond_list, conn_info%bond_a(nbond_prev+1:)-natom_prev, & - conn_info%bond_b(nbond_prev+1:)-natom_prev, N, error) + conn_info%bond_b(nbond_prev+1:)-natom_prev, N) nmol=0 check=ALL(id_molname==str2id(s2s("__UNDEF__"))).OR.ALL(id_molname/=str2id(s2s("__UNDEF__"))) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) DO i = 1, natom IF (id2str(id_molname(i))=="__UNDEF__") THEN molname = TRIM(basename)//ADJUSTL(cp_to_string(nmol)) - CALL generate_molname_low(i, atom_bond_list, molname, id_molname, error) + CALL generate_molname_low(i, atom_bond_list, molname, id_molname) nmol = nmol + 1 END IF END DO DO I=1,natom DEALLOCATE(atom_bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(atom_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE topology_generate_molname @@ -147,16 +145,14 @@ END SUBROUTINE topology_generate_molname !> \param atom_bond_list ... !> \param molname ... !> \param id_molname ... -!> \param error ... !> \author Teodoro Laino [tlaino] - University of Zurich 10.2008 ! ***************************************************************************** - RECURSIVE SUBROUTINE generate_molname_low(i, atom_bond_list, molname, id_molname, error) + RECURSIVE SUBROUTINE generate_molname_low(i, atom_bond_list, molname, id_molname) INTEGER, INTENT(IN) :: i TYPE(array1_list_type), DIMENSION(:) :: atom_bond_list CHARACTER(LEN=default_string_length), & INTENT(IN) :: molname INTEGER, DIMENSION(:), INTENT(INOUT) :: id_molname - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'generate_molname_low', & routineP = moduleN//':'//routineN @@ -173,7 +169,7 @@ RECURSIVE SUBROUTINE generate_molname_low(i, atom_bond_list, molname, id_molname WRITE(*,*)"Atom (",i,") has already a molecular name assigned ! ("//TRIM(id2str(id_molname(i)))//")." WRITE(*,*)"New molecular name would be: ("//TRIM(molname)//")." WRITE(*,*)"Detecting something wrong in the molecular setup!" - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF id_molname(i) = str2id(molname) @@ -183,7 +179,7 @@ RECURSIVE SUBROUTINE generate_molname_low(i, atom_bond_list, molname, id_molname IF (k==-1) CYCLE atom_bond_list(i)%array1(j)=-1 WHERE (atom_bond_list(k)%array1==i) atom_bond_list(k)%array1=-1 - CALL generate_molname_low(k, atom_bond_list, molname, id_molname, error) + CALL generate_molname_low(k, atom_bond_list, molname, id_molname) END DO END SUBROUTINE generate_molname_low @@ -193,16 +189,14 @@ END SUBROUTINE generate_molname_low !> \param qmmm ... !> \param qmmm_env ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,error) + SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology LOGICAL, INTENT(in), OPTIONAL :: qmmm TYPE(qmmm_env_mm_type), OPTIONAL, & POINTER :: qmmm_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_molecule', & routineP = moduleN//':'//routineN @@ -223,9 +217,9 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) NULLIFY (qm_atom_index) NULLIFY (wrk1) @@ -242,19 +236,19 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro natom = topology%natoms stat = 0 IF (ASSOCIATED(atom_info%map_mol_typ)) DEALLOCATE(atom_info%map_mol_typ,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom_info%map_mol_typ(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(atom_info%map_mol_num)) DEALLOCATE(atom_info%map_mol_num,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom_info%map_mol_num(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (ASSOCIATED(atom_info%map_mol_res)) DEALLOCATE(atom_info%map_mol_res,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE (atom_info%map_mol_res(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Initialisation atom_info%map_mol_typ(:) = 0 @@ -312,37 +306,37 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro END IF END DO DEALLOCATE (wrk1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (iw > 0) WRITE (iw,'(/,T2,A)') "Start of molecule generation" ! convert a simple list of bonds to a list of bonds per atom ! (each bond is present in the forward and backward direction ALLOCATE(atom_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(atom_bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%bond_a)) N = SIZE(conn_info%bond_a) - CALL reorder_structure(atom_bond_list, conn_info%bond_a, conn_info%bond_b, N, error) + CALL reorder_structure(atom_bond_list, conn_info%bond_a, conn_info%bond_b, N) CALL find_molecule(atom_bond_list,atom_info%map_mol_num,atom_info%id_molname) DO I=1,natom DEALLOCATE(atom_bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(atom_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (iw > 0) WRITE (iw,'(/,T2,A)') "End of molecule generation" ! Modify according map_mol_typ the array map_mol_num IF (iw > 0) WRITE (iw,'(/,T2,A)') "Checking for non-continuous generated molecules" ! Check molecule number ALLOCATE(wrk1(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wrk2(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wrk1 = atom_info%map_mol_num IF (debug_this_module) THEN @@ -389,9 +383,9 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro "It may help to fix this issue.") END IF DEALLOCATE(wrk1, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (iw > 0) WRITE (iw,'(/,T2,A)') "End of check" IF (iw > 0) WRITE (UNIT=iw,FMT="(/,T2,A)") "Start of renumbering molecules" @@ -412,7 +406,7 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro DO i=2,natom IF (atom_info%map_mol_typ(i) /= mol_typ) THEN myind = atom_info%map_mol_num(i) - mol_num + 1 - CPPostcondition(myind/=atom_info%map_mol_num(i-1),cp_failure_level,routineP,error,failure) + CPPostcondition(myind/=atom_info%map_mol_num(i-1),cp_failure_level,routineP,failure) mol_typ = atom_info%map_mol_typ(i) mol_num = atom_info%map_mol_num(i) END IF @@ -481,9 +475,9 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro IF (iw>0) WRITE(iw,*)"MAP_MOL_TYP ",atom_info%map_mol_typ IF (iw>0) WRITE(iw,*)"MAP_MOL_RES ",atom_info%map_mol_res ALLOCATE(qm_atom_index(SIZE(qmmm_env%qm_atom_index)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) qm_atom_index = qmmm_env%qm_atom_index - CPPostcondition(ALL(qm_atom_index /= 0),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(qm_atom_index /= 0),cp_failure_level,routineP,failure) DO myind = 1, SIZE(qm_atom_index) IF (qm_atom_index(myind) ==0) CYCLE CALL find_boundary(atom_info%map_mol_typ,natom,ifirst,ilast,& @@ -491,7 +485,7 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro CALL find_boundary(atom_info%map_mol_typ,atom_info%map_mol_num,natom,ifirst,ilast,& atom_info%map_mol_typ(qm_atom_index(myind)),atom_info%map_mol_num(qm_atom_index(myind))) IF (iw>0) WRITE(iw,*)"qm fragment:: ifirst, ilast",ifirst,ilast - CPPostcondition(((ifirst/=0).OR.(ilast/=natom)),cp_failure_level,routineP,error,failure) + CPPostcondition(((ifirst/=0).OR.(ilast/=natom)),cp_failure_level,routineP,failure) DO iatm = ifirst, ilast atom_info%id_molname(iatm) = str2id(s2s("_QM_"//& TRIM(id2str(atom_info%id_molname(iatm))))) @@ -507,14 +501,14 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro IF (iw>0) WRITE(iw,*)" Another QM fragment? :: ",do_again IF (ifirst /= 1) THEN jump1 = atom_info%map_mol_typ(ifirst) - atom_info%map_mol_typ(ifirst-1) - CPPostcondition(jump1<=1.AND.jump1>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(jump1<=1.AND.jump1>=0,cp_failure_level,routineP,failure) jump1 = ABS(jump1-1) ELSE jump1 = 0 END IF IF (ilast /= natom) THEN jump2 = atom_info%map_mol_typ(ilast+1) - atom_info%map_mol_typ(ilast) - CPPostcondition(jump2<=1.AND.jump2>=0,cp_failure_level,routineP,error,failure) + CPPostcondition(jump2<=1.AND.jump2>=0,cp_failure_level,routineP,failure) jump2 = ABS(jump2-1) ELSE jump2 = 0 @@ -548,7 +542,7 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro IF (.NOT.do_again) EXIT END DO DEALLOCATE(qm_atom_index,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(iw>0) THEN WRITE(iw,*)"After the QM/MM Setup:" @@ -570,7 +564,7 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro IF (atom_in_kind <= 1) CYCLE CALL find_boundary(atom_info%map_mol_typ,natom,first,last,i) WRITE(iw,*) "Boundary atoms:",first,last - CPPostcondition(last-first+1==atom_in_kind,cp_failure_level,routineP,error,failure) + CPPostcondition(last-first+1==atom_in_kind,cp_failure_level,routineP,failure) max_mol_num = MAXVAL(atom_info%map_mol_num(first:last)) WRITE(iw,*)"Number of molecules of kind",i,"is ::",max_mol_num atom_in_mol = atom_in_kind / max_mol_num @@ -592,7 +586,7 @@ SUBROUTINE topology_generate_molecule(topology,qmmm,qmmm_env,subsys_section,erro END DO END IF CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") CALL timestop(handle) END SUBROUTINE topology_generate_molecule @@ -601,16 +595,13 @@ END SUBROUTINE topology_generate_molecule !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& - error) + SUBROUTINE topology_generate_bond(topology,para_env,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_bond', & routineP = moduleN//':'//routineN @@ -649,20 +640,20 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& NULLIFY(logger, particle_set, atomic_kind_set, nonbonded, bond_section, generate_section) NULLIFY(isolated_atoms, tmp_v) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/GENERATE_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") ! Get atoms that one considers isolated (like ions in solution) ALLOCATE(isolated_atoms(0), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - generate_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE",error=error) - isolated_section => section_vals_get_subs_vals(generate_section,"ISOLATED_ATOMS",error=error) - CALL section_vals_get(isolated_section, explicit=explicit, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + generate_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE") + isolated_section => section_vals_get_subs_vals(generate_section,"ISOLATED_ATOMS") + CALL section_vals_get(isolated_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(isolated_section,"LIST", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(isolated_section,"LIST", n_rep_val=n_rep) DO i = 1, n_rep - CALL section_vals_val_get(isolated_section,"LIST", i_vals=tmp_v, i_rep_val=i, error=error) + CALL section_vals_val_get(isolated_section,"LIST", i_vals=tmp_v, i_rep_val=i) CALL reallocate(isolated_atoms, 1, SIZE(isolated_atoms)+SIZE(tmp_v)) isolated_atoms(SIZE(isolated_atoms)-SIZE(tmp_v)+1:SIZE(isolated_atoms)) = tmp_v END DO @@ -675,13 +666,13 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& NULLIFY(radius) ! Allocate temporary arrays ALLOCATE(radius(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(list(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(h_list(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(pbc_coord(3,natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) h_list = .FALSE. CALL timeset(TRIM(routineN)//"_1",handle2) DO iatom=1,natom @@ -698,7 +689,7 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& IF (upper_sym_1=="H ") h_list(iatom) = .TRUE. ! isolated atoms? put the radius to 0.0_dp IF (ANY(isolated_atoms==iatom)) radius(iatom) = 0.0_dp - radius(iatom) = cp_unit_to_cp2k(radius(iatom),"angstrom",error=error) + radius(iatom) = cp_unit_to_cp2k(radius(iatom),"angstrom") IF(iw>0) WRITE(iw,'(T2,"GENERATE|",5X,A,T50,A5,T60,A,T69,F12.6)') & "In topology_generate_bond :: iatom = ",upper_sym_1,& "radius:",radius(iatom) @@ -708,14 +699,13 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& ! Initialize fake particle_set and atomic_kinds to generate the bond list ! using the neighboring list routine ALLOCATE(atomic_kind_set(1)) - CALL allocate_particle_set(particle_set,natom,error) + CALL allocate_particle_set(particle_set,natom) ! my_maxrad = MAXVAL(radius)*2.0_dp atomic_kind => atomic_kind_set(1) CALL set_atomic_kind(atomic_kind=atomic_kind,kind_number=1,& name="XXX",element_symbol="XXX",mass=0.0_dp,atom_list=list) - CALL section_vals_val_get(subsys_section,"TOPOLOGY%GENERATE%BONDLENGTH_MAX",r_val=tmp,& - error=error) + CALL section_vals_val_get(subsys_section,"TOPOLOGY%GENERATE%BONDLENGTH_MAX",r_val=tmp) r_max = tmp IF (my_maxrad*bondparm_factor>r_max(1,1).AND.(.NOT.topology%molname_generated)) THEN IF (output_unit>0) THEN @@ -727,7 +717,7 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& " Present THRESHOLD (",my_maxrad*bondparm_factor," ). "//& " Present BONDLENGTH_MAX (",r_max(1,1)," )" END IF - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF DO i=1,natom particle_set(i)%atomic_kind => atomic_kind_set(1) @@ -736,8 +726,7 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& particle_set(i)%r(3) = atom_info%r(3,i) pbc_coord(:,i) = pbc(atom_info%r(:,i),topology%cell) END DO - CALL section_vals_val_get(subsys_section,"TOPOLOGY%GENERATE%BONDLENGTH_MIN",r_val=tmp,& - error=error) + CALL section_vals_val_get(subsys_section,"TOPOLOGY%GENERATE%BONDLENGTH_MIN",r_val=tmp) r_minsq = tmp*tmp CALL timestop(handle2) CALL timeset(TRIM(routineN)//"_3",handle2) @@ -745,7 +734,7 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& cell=topology%cell, r_max=r_max, r_minsq=r_minsq, & ei_scale14=1.0_dp, vdw_scale14=1.0_dp, nonbonded=nonbonded, & para_env=para_env, build_from_scratch=.TRUE., geo_check=.TRUE., & - mm_section=generate_section, error=error) + mm_section=generate_section) IF (iw>0) THEN WRITE(iw,'(T2,"GENERATE| Number of prescreened bonds (neighbors):",T71,I10)')& nonbonded%neighbor_kind_pairs(1)%npairs @@ -755,11 +744,11 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& npairs = npairs + nonbonded%neighbor_kind_pairs(i)%npairs END DO ALLOCATE(bond_a(npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(bond_b(npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_nb(npairs),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) idim = 0 DO j = 1, SIZE(nonbonded%neighbor_kind_pairs) DO i = 1, nonbonded%neighbor_kind_pairs(j)%npairs @@ -773,21 +762,20 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& CALL timeset(TRIM(routineN)//"_4",handle2) ! We have a list of neighbors let's order the list w.r.t. the particle number ALLOCATE(bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I = 1, natom ALLOCATE(bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(bond_list(I)%array2(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO - CALL reorder_structure(bond_list, bond_a, bond_b, map_nb, SIZE(bond_a),& - error=error) + CALL reorder_structure(bond_list, bond_a, bond_b, map_nb, SIZE(bond_a)) DEALLOCATE(bond_a,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bond_b,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_nb,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Find the Real bonds in the system ! Let's start with heavy atoms.. hydrogens will be treated only later on... ! Heavy atoms loop @@ -893,14 +881,13 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& " Preliminary Number of Bonds generated:",n_bonds END IF ! External defined bonds (useful for complex connectivity) - bond_section => section_vals_get_subs_vals(generate_section,"BOND",error=error) + bond_section => section_vals_get_subs_vals(generate_section,"BOND") CALL connectivity_external_control(section=bond_section,& Iarray1=conn_info%bond_a,& Iarray2=conn_info%bond_b,& nvar=n_bonds,& topology=topology,& - output_unit=output_unit,& - error=error) + output_unit=output_unit) ! Resize arrays to their proper size.. CALL reallocate(conn_info%bond_a,1,n_bonds) CALL reallocate(conn_info%bond_b,1,n_bonds) @@ -917,7 +904,7 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& ELSE ! Check created connectivity and possibly give the OK to proceed connectivity_ok = check_generate_mol(conn_info%bond_a,conn_info%bond_b,& - atom_info, bondparm_factor, output_unit, error) + atom_info, bondparm_factor, output_unit) END IF IF (my_maxrad*bondparm_factor>r_max(1,1).AND.(.NOT.topology%molname_generated)) THEN IF (output_unit>0) THEN @@ -929,33 +916,33 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& " Present THRESHOLD (",my_maxrad*bondparm_factor," ). "//& " Present BONDLENGTH_MAX (",r_max(1,1)," )" END IF - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO IF (connectivity_ok.AND.(output_unit>0)) THEN WRITE(output_unit,'(T2,"GENERATE|",A)')& " Achieved consistency in connectivity generation." END IF - CALL fist_neighbor_deallocate(nonbonded,error) + CALL fist_neighbor_deallocate(nonbonded) CALL timestop(handle2) CALL timeset(TRIM(routineN)//"_6",handle2) ! Deallocate temporary working arrays DO I = 1, natom DEALLOCATE(bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(bond_list(I)%array2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(pbc_coord,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(radius,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(list,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL deallocate_particle_set(particle_set,error) - CALL deallocate_atomic_kind_set(atomic_kind_set,error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL deallocate_particle_set(particle_set) + CALL deallocate_atomic_kind_set(atomic_kind_set) ! CALL timestop(handle2) IF (output_unit>0 .AND. n_bonds > 0) THEN @@ -990,10 +977,10 @@ SUBROUTINE topology_generate_bond(topology,para_env,subsys_section,& END IF CALL timestop(handle2) DEALLOCATE(isolated_atoms,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/GENERATE_INFO",error=error) + "PRINT%TOPOLOGY_INFO/GENERATE_INFO") END SUBROUTINE topology_generate_bond ! ***************************************************************************** @@ -1003,17 +990,15 @@ END SUBROUTINE topology_generate_bond !> \param atom_info ... !> \param bondparm_factor ... !> \param output_unit ... -!> \param error ... !> \retval conn_ok ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - FUNCTION check_generate_mol(bond_a,bond_b,atom_info,bondparm_factor,output_unit,error) & + FUNCTION check_generate_mol(bond_a,bond_b,atom_info,bondparm_factor,output_unit) & RESULT(conn_ok) INTEGER, DIMENSION(:), POINTER :: bond_a, bond_b TYPE(atom_info_type), POINTER :: atom_info REAL(KIND=dp), INTENT(INOUT) :: bondparm_factor INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: conn_ok CHARACTER(len=*), PARAMETER :: routineN = 'check_generate_mol', & @@ -1035,19 +1020,18 @@ FUNCTION check_generate_mol(bond_a,bond_b,atom_info,bondparm_factor,output_unit, failure = .FALSE. natom = SIZE(atom_info%id_atmname) ALLOCATE(bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I = 1, natom ALLOCATE(bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO - CALL reorder_structure(bond_list, bond_a, bond_b, SIZE(bond_a),& - error=error) + CALL reorder_structure(bond_list, bond_a, bond_b, SIZE(bond_a)) ALLOCATE(mol_map(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mol_map_o(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wrk(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natom mol_map(i) = atom_info%id_molname(i) @@ -1069,7 +1053,7 @@ FUNCTION check_generate_mol(bond_a,bond_b,atom_info,bondparm_factor,output_unit, ! ALLOCATE(mol_info_tmp(natom,2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) itype = mol_map(1) nsize = 1 @@ -1089,10 +1073,10 @@ FUNCTION check_generate_mol(bond_a,bond_b,atom_info,bondparm_factor,output_unit, mol_info_tmp(nsize,2) = idim ALLOCATE(mol_info(nsize,4),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mol_info(1:nsize,1:2) = mol_info_tmp(1:nsize,1:2) DEALLOCATE(mol_info_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i =1, nsize mol_info(i,3) = 0 @@ -1100,7 +1084,7 @@ FUNCTION check_generate_mol(bond_a,bond_b,atom_info,bondparm_factor,output_unit, END DO ! ALLOCATE(icheck(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) icheck = .FALSE. DO i = 1, natom IF (icheck(i)) CYCLE @@ -1141,21 +1125,21 @@ FUNCTION check_generate_mol(bond_a,bond_b,atom_info,bondparm_factor,output_unit, END DO DEALLOCATE(icheck,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mol_info,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mol_map,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mol_map_o,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I = 1, natom DEALLOCATE(bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END FUNCTION check_generate_mol @@ -1171,11 +1155,10 @@ END FUNCTION check_generate_mol !> \param topology ... !> \param output_unit ... !> \param is_impr ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE connectivity_external_control(section, Iarray1, Iarray2, Iarray3, Iarray4, nvar,& - topology, output_unit, is_impr, error) + topology, output_unit, is_impr) TYPE(section_vals_type), POINTER :: section INTEGER, DIMENSION(:), POINTER :: Iarray1, Iarray2 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: Iarray3, Iarray4 @@ -1184,7 +1167,6 @@ SUBROUTINE connectivity_external_control(section, Iarray1, Iarray2, Iarray3, Iar INTENT(INOUT) :: topology INTEGER, INTENT(IN) :: output_unit LOGICAL, INTENT(IN), OPTIONAL :: is_impr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'connectivity_external_control', & @@ -1207,46 +1189,45 @@ SUBROUTINE connectivity_external_control(section, Iarray1, Iarray2, Iarray3, Iar IF (ip3) nsize = nsize + 1 IF (ip3.AND.ip4) nsize = nsize + 1 ! Put the lists always in the canonical order - CALL reorder_list_array(Iarray1, Iarray2, Iarray3, Iarray4, nsize, nvar, error) + CALL reorder_list_array(Iarray1, Iarray2, Iarray3, Iarray4, nsize, nvar) ! Go on with external control - CALL section_vals_get(section,explicit=explicit,n_repetition=n_rep,error=error) + CALL section_vals_get(section,explicit=explicit,n_repetition=n_rep) IF (explicit) THEN NULLIFY(Ilist1, Ilist2, Ilist3, Ilist4, atlist) ALLOCATE(Ilist1(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Ilist2(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Ilist1 = Iarray1(1:nvar) Ilist2 = Iarray2(1:nvar) SELECT CASE(nsize) CASE(2) !do nothing CASE(3) ALLOCATE(Ilist3(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Ilist3 = Iarray3(1:nvar) CASE(4) ALLOCATE(Ilist3(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(Ilist4(nvar),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) Ilist3 = Iarray3(1:nvar) Ilist4 = Iarray4(1:nvar) CASE DEFAULT ! Should never reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL list_canonical_order(Ilist1, Ilist2, Ilist3, Ilist4, nsize, is_impr) ! DO i = 1, n_rep - CALL section_vals_val_get(section,"ATOMS",i_rep_section=i,n_rep_val=n_rep_val,& - error=error) + CALL section_vals_val_get(section,"ATOMS",i_rep_section=i,n_rep_val=n_rep_val) CALL section_vals_val_get(section,"_SECTION_PARAMETERS_",i_rep_section=i,& - i_val=do_action, error=error) + i_val=do_action) ! DO j = 1, n_rep_val CALL section_vals_val_get(section,"ATOMS",i_rep_section=i,i_rep_val=j,& - i_vals=atlist,error=error) - CPPostcondition(SIZE(atlist)==nsize,cp_failure_level,routineP,error,failure) + i_vals=atlist) + CPPostcondition(SIZE(atlist)==nsize,cp_failure_level,routineP,failure) CALL integer_to_string(nsize-1,fmt) CALL check_element_list(do_it,do_action,atlist,Ilist1,Ilist2,Ilist3,Ilist4,& is_impr) @@ -1328,22 +1309,22 @@ SUBROUTINE connectivity_external_control(section, Iarray1, Iarray2, Iarray3, Iar END DO END DO DEALLOCATE(Ilist1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Ilist2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) SELECT CASE(nsize) CASE(2) ! do nothing CASE(3) DEALLOCATE(Ilist3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(4) DEALLOCATE(Ilist3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(Ilist4,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE DEFAULT ! Should never reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF END SUBROUTINE connectivity_external_control @@ -1609,14 +1590,12 @@ END SUBROUTINE add_bonds_list !> \brief Using a list of bonds, generate a list of bends !> \param topology ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE topology_generate_bend(topology,subsys_section,error) + SUBROUTINE topology_generate_bend(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_bend', & routineP = moduleN//':'//routineN @@ -1633,9 +1612,9 @@ SUBROUTINE topology_generate_bend(topology,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/GENERATE_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) output_unit= cp_logger_get_default_io_unit(logger) conn_info => topology%conn_info @@ -1656,12 +1635,12 @@ SUBROUTINE topology_generate_bend(topology,subsys_section,error) CALL reallocate(conn_info%theta_c,1,nsize) ! Get list of bonds to pre-process theta ALLOCATE(bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I = 1, natom ALLOCATE(bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO - CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond, error) + CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond) ! All the dirty job is handled by this routine.. for bends it_levl is equal 3 CALL timeset(routineN//"_1",handle2) CALL match_iterative_path(Iarray1=bond_list,& @@ -1670,29 +1649,27 @@ SUBROUTINE topology_generate_bend(topology,subsys_section,error) nvar=ntheta,& Oarray1 =conn_info%theta_a,& Oarray2 =conn_info%theta_b,& - Oarray3 =conn_info%theta_c,& - error=error) + Oarray3 =conn_info%theta_c) CALL timestop(handle2) DO I = 1, natom DEALLOCATE(bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (output_unit>0) THEN WRITE(output_unit,'(T2,"GENERATE|",1X,A,T71,I10)')" Preliminary Number of Bends generated:",& ntheta END IF ! External defined bends (useful for complex connectivity) - bend_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE%ANGLE",error=error) + bend_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE%ANGLE") CALL connectivity_external_control(section=bend_section,& Iarray1=conn_info%theta_a,& Iarray2=conn_info%theta_b,& Iarray3=conn_info%theta_c,& nvar=ntheta,& topology=topology,& - output_unit=output_unit,& - error=error) + output_unit=output_unit) END IF ! Resize arrays to their proper size.. CALL reallocate(conn_info%theta_a,1,ntheta) @@ -1704,7 +1681,7 @@ SUBROUTINE topology_generate_bend(topology,subsys_section,error) END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/GENERATE_INFO",error=error) + "PRINT%TOPOLOGY_INFO/GENERATE_INFO") END SUBROUTINE topology_generate_bend ! @@ -1722,12 +1699,10 @@ END SUBROUTINE topology_generate_bend !> \param Ilist ... !> \param it_levl ... !> \param nvar ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** RECURSIVE SUBROUTINE match_iterative_path(Iarray1, Iarray2, Iarray3,& - max_levl, Oarray1, Oarray2, Oarray3, Oarray4, Ilist, it_levl, nvar,& - error) + max_levl, Oarray1, Oarray2, Oarray3, Oarray4, Ilist, it_levl, nvar) TYPE(array1_list_type), DIMENSION(:), & POINTER :: Iarray1 TYPE(array1_list_type), DIMENSION(:), & @@ -1739,7 +1714,6 @@ RECURSIVE SUBROUTINE match_iterative_path(Iarray1, Iarray2, Iarray3,& OPTIONAL :: Ilist INTEGER, INTENT(IN), OPTIONAL :: it_levl INTEGER, INTENT(INOUT) :: nvar - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'match_iterative_path', & routineP = moduleN//':'//routineN @@ -1753,31 +1727,31 @@ RECURSIVE SUBROUTINE match_iterative_path(Iarray1, Iarray2, Iarray3,& failure = .FALSE. check = max_levl>=2.AND.max_levl<=4 - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) IF (.NOT.PRESENT(Ilist)) THEN SELECT CASE(max_levl) CASE(2) - CPPostcondition(.NOT.PRESENT(Iarray2),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.PRESENT(Iarray3),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.PRESENT(Oarray3),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.PRESENT(Oarray4),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.PRESENT(Iarray2),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.PRESENT(Iarray3),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.PRESENT(Oarray3),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.PRESENT(Oarray4),cp_failure_level,routineP,failure) CASE(3) - CPPostcondition(PRESENT(Iarray2),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.PRESENT(Iarray3),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(Oarray3),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.PRESENT(Oarray4),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(Iarray2),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.PRESENT(Iarray3),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(Oarray3),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.PRESENT(Oarray4),cp_failure_level,routineP,failure) CASE(4) - CPPostcondition(PRESENT(Iarray2),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(Iarray3),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(Oarray3),cp_failure_level,routineP,error,failure) - CPPostcondition(PRESENT(Oarray4),cp_failure_level,routineP,error,failure) + CPPostcondition(PRESENT(Iarray2),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(Iarray3),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(Oarray3),cp_failure_level,routineP,failure) + CPPostcondition(PRESENT(Oarray4),cp_failure_level,routineP,failure) END SELECT END IF natom = SIZE(Iarray1) IF (.NOT.PRESENT(Ilist)) THEN ! Start a new loop.. Only the first time the routine is called ALLOCATE(my_list(max_levl),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natom my_levl = 1 my_list = -1 @@ -1792,11 +1766,10 @@ RECURSIVE SUBROUTINE match_iterative_path(Iarray1, Iarray2, Iarray3,& Oarray3=Oarray3,& Oarray4=Oarray4,& nvar =nvar,& - Ilist =my_list,& - error =error) + Ilist =my_list) END DO DEALLOCATE(my_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE SELECT CASE(it_levl) CASE(2) @@ -1822,8 +1795,7 @@ RECURSIVE SUBROUTINE match_iterative_path(Iarray1, Iarray2, Iarray3,& Oarray3=Oarray3,& Oarray4=Oarray4,& nvar =nvar,& - Ilist =Ilist,& - error =error) + Ilist =Ilist) Ilist(it_levl) = -1 ELSEIF (it_levl==max_levl) THEN IF (Ilist(1)>ind) CYCLE @@ -1859,12 +1831,12 @@ RECURSIVE SUBROUTINE match_iterative_path(Iarray1, Iarray2, Iarray3,& Oarray4(nvar) = Ilist(4) CASE DEFAULT !should never reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT Ilist(it_levl) = -1 ELSE !should never reach this point - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END IF @@ -1876,13 +1848,11 @@ END SUBROUTINE match_iterative_path !> \brief The list of Urey-Bradley is equal to the list of bends !> \param topology ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE topology_generate_ub(topology,subsys_section,error) + SUBROUTINE topology_generate_ub(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_ub', & routineP = moduleN//':'//routineN @@ -1895,9 +1865,9 @@ SUBROUTINE topology_generate_ub(topology,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/GENERATE_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") output_unit= cp_logger_get_default_io_unit(logger) CALL timeset(routineN,handle) conn_info => topology%conn_info @@ -1917,7 +1887,7 @@ SUBROUTINE topology_generate_ub(topology,subsys_section,error) END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/GENERATE_INFO",error=error) + "PRINT%TOPOLOGY_INFO/GENERATE_INFO") END SUBROUTINE topology_generate_ub @@ -1925,14 +1895,12 @@ END SUBROUTINE topology_generate_ub !> \brief Generate a list of torsions from bonds !> \param topology ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE topology_generate_dihe(topology,subsys_section,error) + SUBROUTINE topology_generate_dihe(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_dihe', & routineP = moduleN//':'//routineN @@ -1948,9 +1916,9 @@ SUBROUTINE topology_generate_dihe(topology,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/GENERATE_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") output_unit= cp_logger_get_default_io_unit(logger) CALL timeset(routineN,handle) conn_info => topology%conn_info @@ -1965,12 +1933,12 @@ SUBROUTINE topology_generate_dihe(topology,subsys_section,error) ! Get list of bonds to pre-process phi natom = topology%natoms ALLOCATE(bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I = 1, natom ALLOCATE(bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO - CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond, error) + CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond) ! All the dirty job is handled by this routine.. for torsions it_levl is equal 4 CALL match_iterative_path(Iarray1=bond_list,& Iarray2=bond_list,& @@ -1980,20 +1948,19 @@ SUBROUTINE topology_generate_dihe(topology,subsys_section,error) Oarray1 =conn_info%phi_a,& Oarray2 =conn_info%phi_b,& Oarray3 =conn_info%phi_c,& - Oarray4 =conn_info%phi_d,& - error=error) + Oarray4 =conn_info%phi_d) DO I = 1, natom DEALLOCATE(bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (output_unit>0) THEN WRITE(output_unit,'(T2,"GENERATE|",1X,A,T71,I10)')" Preliminary Number of Torsions generated:",& nphi END IF ! External defined torsions (useful for complex connectivity) - torsion_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE%TORSION",error=error) + torsion_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE%TORSION") CALL connectivity_external_control(section=torsion_section,& Iarray1=conn_info%phi_a,& Iarray2=conn_info%phi_b,& @@ -2001,8 +1968,7 @@ SUBROUTINE topology_generate_dihe(topology,subsys_section,error) Iarray4=conn_info%phi_d,& nvar=nphi,& topology=topology,& - output_unit=output_unit,& - error=error) + output_unit=output_unit) END IF ! Resize arrays to their proper size.. CALL reallocate(conn_info%phi_a,1,nphi) @@ -2015,7 +1981,7 @@ SUBROUTINE topology_generate_dihe(topology,subsys_section,error) END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/GENERATE_INFO",error=error) + "PRINT%TOPOLOGY_INFO/GENERATE_INFO") END SUBROUTINE topology_generate_dihe @@ -2023,14 +1989,12 @@ END SUBROUTINE topology_generate_dihe !> \brief Using a list of bends, generate a list of impr !> \param topology ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE topology_generate_impr(topology,subsys_section,error) + SUBROUTINE topology_generate_impr(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_impr', & routineP = moduleN//':'//routineN @@ -2049,9 +2013,9 @@ SUBROUTINE topology_generate_impr(topology,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/GENERATE_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") output_unit= cp_logger_get_default_io_unit(logger) CALL timeset(routineN,handle) atom_info => topology%atom_info @@ -2067,12 +2031,12 @@ SUBROUTINE topology_generate_impr(topology,subsys_section,error) CALL reallocate(conn_info%impr_d,1,nsize) ! Get list of bonds to pre-process phi ALLOCATE(bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I = 1, natom ALLOCATE(bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO - CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond, error) + CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond) DO I = 1, natom ! Count all atoms with three bonds IF (SIZE(bond_list(I)%array1)==3) THEN @@ -2107,12 +2071,12 @@ SUBROUTINE topology_generate_impr(topology,subsys_section,error) END DO DO I = 1, natom DEALLOCATE(bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! External defined impropers (useful for complex connectivity) - impr_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE%IMPROPER",error=error) + impr_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE%IMPROPER") CALL connectivity_external_control(section=impr_section,& Iarray1=conn_info%impr_a,& Iarray2=conn_info%impr_b,& @@ -2121,8 +2085,7 @@ SUBROUTINE topology_generate_impr(topology,subsys_section,error) nvar=nimpr,& topology=topology,& output_unit=output_unit,& - is_impr=.TRUE.,& - error=error) + is_impr=.TRUE.) END IF ! Resize arrays to their proper size.. CALL reallocate(conn_info%impr_a,1,nimpr) @@ -2135,7 +2098,7 @@ SUBROUTINE topology_generate_impr(topology,subsys_section,error) END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/GENERATE_INFO",error=error) + "PRINT%TOPOLOGY_INFO/GENERATE_INFO") END SUBROUTINE topology_generate_impr @@ -2143,13 +2106,11 @@ END SUBROUTINE topology_generate_impr !> \brief Using a list of torsion, generate a list of onfo !> \param topology ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE topology_generate_onfo(topology,subsys_section,error) + SUBROUTINE topology_generate_onfo(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_generate_onfo', & routineP = moduleN//':'//routineN @@ -2167,9 +2128,9 @@ SUBROUTINE topology_generate_onfo(topology,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/GENERATE_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") output_unit= cp_logger_get_default_io_unit(logger) CALL timeset(routineN,handle) @@ -2178,33 +2139,33 @@ SUBROUTINE topology_generate_onfo(topology,subsys_section,error) ! Get list of bonds (sic). Get a list of bonded neighbors for every atom. ALLOCATE(bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natom ALLOCATE(bond_list(i)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO nbond = SIZE(conn_info%bond_a) - CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond, error) + CALL reorder_structure(bond_list, conn_info%bond_a, conn_info%bond_b, nbond) ! Get a list of next nearest neighbors for every atom. ALLOCATE(theta_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natom ALLOCATE(theta_list(i)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO ntheta = SIZE(conn_info%theta_a) - CALL reorder_structure(theta_list, conn_info%theta_a, conn_info%theta_c, ntheta, error) + CALL reorder_structure(theta_list, conn_info%theta_a, conn_info%theta_c, ntheta) ! Get a list of next next nearest neighbors for every atom. ALLOCATE(phi_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, natom ALLOCATE(phi_list(i)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO nphi = SIZE(conn_info%phi_a) - CALL reorder_structure(phi_list, conn_info%phi_a, conn_info%phi_d, nphi, error) + CALL reorder_structure(phi_list, conn_info%phi_a, conn_info%phi_d, nphi) ! Allocate enough (possible too much) CALL reallocate(conn_info%onfo_a,1,nphi) @@ -2235,24 +2196,24 @@ SUBROUTINE topology_generate_onfo(topology,subsys_section,error) ! Deallocate bond_list DO i = 1, natom DEALLOCATE(bond_list(i)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Deallocate theta_list DO i = 1, natom DEALLOCATE(theta_list(i)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(theta_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Deallocate phi_list DO i = 1, natom DEALLOCATE(phi_list(i)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(phi_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Final output IF (output_unit>0 .AND. ionfo > 0) THEN @@ -2261,7 +2222,7 @@ SUBROUTINE topology_generate_onfo(topology,subsys_section,error) END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/GENERATE_INFO",error=error) + "PRINT%TOPOLOGY_INFO/GENERATE_INFO") END SUBROUTINE topology_generate_onfo diff --git a/src/topology_gromos.F b/src/topology_gromos.F index c13b355ec1..c6bcbcb95b 100644 --- a/src/topology_gromos.F +++ b/src/topology_gromos.F @@ -46,15 +46,13 @@ MODULE topology_gromos !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, error) + SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section) CHARACTER(LEN=*), INTENT(IN) :: file_name TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_topology_gromos', & routineP = moduleN//':'//routineN @@ -79,9 +77,9 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err NULLIFY(parser, logger) NULLIFY(namearray1,namearray2) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/GTOP_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) avail_section( 1) = "TITLE" @@ -113,87 +111,87 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err IF(ASSOCIATED(atom_info%id_molname)) natom_prev = SIZE(atom_info%id_molname) ! TITLE SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the TITLE section' - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) label = TRIM(avail_section(1)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN DO - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,string_length=80,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string,string_length=80) IF(string == TRIM("END")) EXIT IF(iw>0) WRITE(iw,*) "GTOP_INFO| ",TRIM(string) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! TOPPHYSCON SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the TOPPHYSCON section' - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) label = TRIM(avail_section(2)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN DO - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string) IF(string == TRIM("END")) EXIT IF(iw>0) WRITE(iw,*) "GTOP_INFO| ",TRIM(string) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! TOPVERSION SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the TOPVERSION section' - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) label = TRIM(avail_section(3)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN DO - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string) IF(string == TRIM("END")) EXIT IF(iw>0) WRITE(iw,*) "GTOP_INFO| ",TRIM(string) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! ATOMTYPENAME SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the ATOMTYPENAME section' - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) label = TRIM(avail_section(4)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) CALL reallocate(namearray1,1,ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,namearray1(itype),error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,namearray1(itype)) IF(iw>0) WRITE(iw,*) "GTOP_INFO| ",TRIM(namearray1(itype)) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! RESNAME SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the RESNAME section' - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) label = TRIM(avail_section(5)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) CALL reallocate(namearray2,1,ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,namearray2(itype),error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,namearray2(itype)) IF(iw>0) WRITE(iw,*) "GTOP_INFO| ",TRIM(namearray2(itype)) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! SOLUTEATOM SECTION iresid=1 IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the SOLUTEATOM section' - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) label = TRIM(avail_section(6)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,natom,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,natom) CALL reallocate(atom_info%id_molname,1,natom_prev+natom) CALL reallocate(atom_info%resid,1,natom_prev+natom) CALL reallocate(atom_info%id_resname,1,natom_prev+natom) @@ -201,23 +199,23 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err CALL reallocate(atom_info%id_element,1,natom_prev+natom) CALL reallocate(atom_info%atm_charge,1,natom_prev+natom) CALL reallocate(atom_info%atm_mass,1,natom_prev+natom) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) DO iatom=1,natom index_now = iatom + natom_prev - CALL parser_get_object(parser,itemp,error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_object(parser,itemp) + CALL parser_get_object(parser,itemp) atom_info%resid(index_now)=itemp atom_info%id_molname(index_now)=str2id(s2s(namearray2(itemp))) atom_info%id_resname(index_now)=str2id(s2s(namearray2(itemp))) - CALL parser_get_object(parser,string,error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_object(parser,string) + CALL parser_get_object(parser,itemp) atom_info%id_atmname(index_now)=str2id(s2s(namearray1(itemp))) atom_info%id_element(index_now)=str2id(s2s(namearray1(itemp))) - CALL parser_get_object(parser,atom_info%atm_mass(index_now),error=error) - CALL parser_get_object(parser,atom_info%atm_charge(index_now),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_object(parser,atom_info%atm_mass(index_now)) + CALL parser_get_object(parser,atom_info%atm_charge(index_now)) + CALL parser_get_object(parser,itemp) IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT SOLUTEATOM INFO HERE!!!!" - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_object(parser,ntype) DO i=1,50 ii(i)=-1 END DO @@ -229,7 +227,7 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err READ(parser%input_line,iostat=stat,FMT=*) itemp,itemp,ctemp,itemp,ftemp,ftemp,& itemp,itemp,(ii(i),i=begin,ntype) ELSE IF (begin.gt.1) THEN - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) READ(parser%input_line,iostat=stat,FMT=*) (ii(i),i=begin,ntype) END IF DO i=ntype,1,-1 @@ -241,8 +239,8 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err END DO END IF ! 1-4 list - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) IF(ntype/=0) THEN itemp=(itemp-1)/6+1 offset = 0 @@ -260,7 +258,7 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err IF (begin.eq.1) THEN READ(parser%input_line,iostat=stat,FMT=*) itemp,(ii(i),i=begin,ntype) ELSE IF (begin.gt.1) THEN - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) READ(parser%input_line,iostat=stat,FMT=*) (ii(i),i=begin,ntype) END IF DO i=ntype,1,-1 @@ -274,33 +272,33 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err conn_info%onfo_b(offset+i)=ii(i) END DO END IF - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) ELSE - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) END IF END DO END IF nsolute = natom - CALL parser_release(parser,error=error) + CALL parser_release(parser) - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) ! BONDH SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the BONDH section' label = TRIM(avail_section(8)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%bond_a)) offset = SIZE(conn_info%bond_a) CALL reallocate(conn_info%bond_a,1,offset+ntype) CALL reallocate(conn_info%bond_b,1,offset+ntype) CALL reallocate(conn_info%bond_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%bond_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%bond_b(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%bond_a(offset+itype)) + CALL parser_get_object(parser,conn_info%bond_b(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%bond_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT BONDH INFO HERE!!!!" END DO @@ -310,20 +308,20 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err ! BOND SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the BOND section' label = TRIM(avail_section(9)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%bond_a)) offset = SIZE(conn_info%bond_a) CALL reallocate(conn_info%bond_a,1,offset+ntype) CALL reallocate(conn_info%bond_b,1,offset+ntype) CALL reallocate(conn_info%bond_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%bond_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%bond_b(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%bond_a(offset+itype)) + CALL parser_get_object(parser,conn_info%bond_b(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%bond_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT BOND INFO HERE!!!!" END DO @@ -333,10 +331,10 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err ! BONDANGLEH SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the BONDANGLEH section' label = TRIM(avail_section(11)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%theta_a)) offset = SIZE(conn_info%theta_a) CALL reallocate(conn_info%theta_a,1,offset+ntype) @@ -344,11 +342,11 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err CALL reallocate(conn_info%theta_c,1,offset+ntype) CALL reallocate(conn_info%theta_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%theta_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%theta_b(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%theta_c(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%theta_a(offset+itype)) + CALL parser_get_object(parser,conn_info%theta_b(offset+itype)) + CALL parser_get_object(parser,conn_info%theta_c(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%theta_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT BONDANGLEH INFO HERE!!!!" END DO @@ -359,10 +357,10 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err ! BONDANGLE SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the BONDANGLE section' label = TRIM(avail_section(12)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%theta_a)) offset = SIZE(conn_info%theta_a) CALL reallocate(conn_info%theta_a,1,offset+ntype) @@ -370,11 +368,11 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err CALL reallocate(conn_info%theta_c,1,offset+ntype) CALL reallocate(conn_info%theta_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%theta_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%theta_b(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%theta_c(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%theta_a(offset+itype)) + CALL parser_get_object(parser,conn_info%theta_b(offset+itype)) + CALL parser_get_object(parser,conn_info%theta_c(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%theta_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT BONDANGLE INFO HERE!!!!" END DO @@ -385,10 +383,10 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err ! IMPDIHEDRALH SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the IMPDIHEDRALH section' label = TRIM(avail_section(14)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%impr_a)) offset = SIZE(conn_info%impr_a) CALL reallocate(conn_info%impr_a,1,offset+ntype) @@ -397,12 +395,12 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err CALL reallocate(conn_info%impr_d,1,offset+ntype) CALL reallocate(conn_info%impr_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%impr_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%impr_b(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%impr_c(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%impr_d(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%impr_a(offset+itype)) + CALL parser_get_object(parser,conn_info%impr_b(offset+itype)) + CALL parser_get_object(parser,conn_info%impr_c(offset+itype)) + CALL parser_get_object(parser,conn_info%impr_d(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%impr_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT IMPDIHEDRALH INFO HERE!!!!" END DO @@ -414,10 +412,10 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err ! IMPDIHEDRAL SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the IMPDIHEDRAL section' label = TRIM(avail_section(15)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%impr_a)) offset = SIZE(conn_info%impr_a) CALL reallocate(conn_info%impr_a,1,offset+ntype) @@ -426,12 +424,12 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err CALL reallocate(conn_info%impr_d,1,offset+ntype) CALL reallocate(conn_info%impr_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%impr_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%impr_b(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%impr_c(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%impr_d(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%impr_a(offset+itype)) + CALL parser_get_object(parser,conn_info%impr_b(offset+itype)) + CALL parser_get_object(parser,conn_info%impr_c(offset+itype)) + CALL parser_get_object(parser,conn_info%impr_d(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%impr_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT IMPDIHEDRAL INFO HERE!!!!" END DO @@ -443,10 +441,10 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err ! DIHEDRALH SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the DIHEDRALH section' label = TRIM(avail_section(17)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%phi_a)) offset = SIZE(conn_info%phi_a) CALL reallocate(conn_info%phi_a,1,offset+ntype) @@ -455,12 +453,12 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err CALL reallocate(conn_info%phi_d,1,offset+ntype) CALL reallocate(conn_info%phi_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%phi_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%phi_b(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%phi_c(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%phi_d(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%phi_a(offset+itype)) + CALL parser_get_object(parser,conn_info%phi_b(offset+itype)) + CALL parser_get_object(parser,conn_info%phi_c(offset+itype)) + CALL parser_get_object(parser,conn_info%phi_d(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%phi_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT DIHEDRALH INFO HERE!!!!" END DO @@ -472,10 +470,10 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err ! DIHEDRAL SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the DIHEDRAL section' label = TRIM(avail_section(18)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ntype,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ntype) offset = 0 IF(ASSOCIATED(conn_info%phi_a)) offset = SIZE(conn_info%phi_a) CALL reallocate(conn_info%phi_a,1,offset+ntype) @@ -484,12 +482,12 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err CALL reallocate(conn_info%phi_d,1,offset+ntype) CALL reallocate(conn_info%phi_type,1,offset+ntype) DO itype=1,ntype - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,conn_info%phi_a(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%phi_b(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%phi_c(offset+itype),error=error) - CALL parser_get_object(parser,conn_info%phi_d(offset+itype),error=error) - CALL parser_get_object(parser,itemp,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,conn_info%phi_a(offset+itype)) + CALL parser_get_object(parser,conn_info%phi_b(offset+itype)) + CALL parser_get_object(parser,conn_info%phi_c(offset+itype)) + CALL parser_get_object(parser,conn_info%phi_d(offset+itype)) + CALL parser_get_object(parser,itemp) conn_info%phi_type(offset+itype)=itemp IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT DIHEDRAL INFO HERE!!!!" END DO @@ -498,47 +496,47 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err conn_info%phi_c(offset+1:offset+ntype) = conn_info%phi_c(offset+1:offset+ntype) + natom_prev conn_info%phi_d(offset+1:offset+ntype) = conn_info%phi_d(offset+1:offset+ntype) + natom_prev END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! SOLVENTATOM and SOLVENTCONSTR SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'GTOP_INFO| Parsing the SOLVENTATOM section' nsolvent=( SIZE(atom_info%r(1,:))-nsolute ) / 3 NULLIFY(na,am,ac,ba,bb) - CALL parser_create(parser,file_name,para_env=para_env,error=error) + CALL parser_create(parser,file_name,para_env=para_env) label = TRIM(avail_section(20)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,natom,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,natom) CALL reallocate(na,1,natom) CALL reallocate(am,1,natom) CALL reallocate(ac,1,natom) DO iatom=1,natom - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,itemp,error=error) - CALL parser_get_object(parser,string,error=error) - CALL parser_get_object(parser,na(iatom),error=error) - CALL parser_get_object(parser,am(iatom),error=error) - CALL parser_get_object(parser,ac(iatom),error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,itemp) + CALL parser_get_object(parser,string) + CALL parser_get_object(parser,na(iatom)) + CALL parser_get_object(parser,am(iatom)) + CALL parser_get_object(parser,ac(iatom)) IF(iw>0) WRITE(iw,*) "GTOP_INFO| PUT SOLVENTATOM INFO HERE!!!!" END DO END IF label = TRIM(avail_section(21)) ncon = 0 - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ncon,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ncon) CALL reallocate(ba,1,ncon) CALL reallocate(bb,1,ncon) DO icon=1,ncon - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,ba(icon),error=error) - CALL parser_get_object(parser,bb(icon),error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,ba(icon)) + CALL parser_get_object(parser,bb(icon)) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) offset = 0 IF(ASSOCIATED(atom_info%id_molname)) offset=SIZE(atom_info%id_molname) @@ -602,31 +600,31 @@ SUBROUTINE read_topology_gromos (file_name,topology,para_env,subsys_section, err END IF ELSE IF(atom_info%id_molname(iatom)/=atom_info%id_molname(jatom)) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF END DO DEALLOCATE(namearray1,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(namearray2,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(na,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(am,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(ac,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ASSOCIATED(ba)) & DEALLOCATE(ba,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF(ASSOCIATED(bb)) & DEALLOCATE(bb,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/GTOP_INFO",error=error) + "PRINT%TOPOLOGY_INFO/GTOP_INFO") END SUBROUTINE read_topology_gromos @@ -635,13 +633,11 @@ END SUBROUTINE read_topology_gromos !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE read_coordinate_g96 (topology,para_env,subsys_section,error) + SUBROUTINE read_coordinate_g96 (topology,para_env,subsys_section) TYPE(topology_parameters_type) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_coordinate_g96', & routineP = moduleN//':'//routineN @@ -661,12 +657,12 @@ SUBROUTINE read_coordinate_g96 (topology,para_env,subsys_section,error) TYPE(section_vals_type), POINTER :: velocity_section NULLIFY(parser, logger, velocity) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/G96_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) - pfactor=section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR",error) + pfactor=section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR") atom_info => topology%atom_info IF (iw>0) WRITE(iw,*) " Reading in G96 file ",TRIM(topology%coord_file_name) avail_section( 1) = "TITLE" @@ -690,27 +686,27 @@ SUBROUTINE read_coordinate_g96 (topology,para_env,subsys_section,error) CALL reallocate(atom_info%beta,1,nblock) ! TITLE SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'G96_INFO| Parsing the TITLE section' - CALL parser_create(parser,topology%coord_file_name,para_env=para_env,error=error) + CALL parser_create(parser,topology%coord_file_name,para_env=para_env) label = TRIM(avail_section(1)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN DO - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,string_length=default_string_length,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string,string_length=default_string_length) IF(string == TRIM("END")) EXIT IF(iw>0) WRITE(iw,*) "G96_INFO| ",TRIM(string) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) ! POSITION SECTION IF(iw>0) WRITE(iw,'(T2,A)') 'G96_INFO| Parsing the POSITION section' - CALL parser_create(parser,topology%coord_file_name,para_env=para_env,error=error) + CALL parser_create(parser,topology%coord_file_name,para_env=para_env) label = TRIM(avail_section(3)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN natom=0 - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,string_length=default_string_length,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string,string_length=default_string_length) DO IF (string == TRIM("END")) EXIT natom = natom + 1 @@ -734,26 +730,26 @@ SUBROUTINE read_coordinate_g96 (topology,para_env,subsys_section,error) atom_info%id_atmname(natom)=str2id(s2s(strtmp2)) atom_info%id_molname(natom) = atom_info%id_resname(natom) atom_info%id_element(natom) = atom_info%id_atmname(natom) - atom_info%r(1,natom) = cp_unit_to_cp2k(atom_info%r(1,natom),"nm",error=error) - atom_info%r(2,natom) = cp_unit_to_cp2k(atom_info%r(2,natom),"nm",error=error) - atom_info%r(3,natom) = cp_unit_to_cp2k(atom_info%r(3,natom),"nm",error=error) + atom_info%r(1,natom) = cp_unit_to_cp2k(atom_info%r(1,natom),"nm") + atom_info%r(2,natom) = cp_unit_to_cp2k(atom_info%r(2,natom),"nm") + atom_info%r(3,natom) = cp_unit_to_cp2k(atom_info%r(3,natom),"nm") IF(iw>0) WRITE(iw,*) "G96_INFO| PUT POSITION INFO HERE!!!!" - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,string_length=default_string_length,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string,string_length=default_string_length) END DO END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) CALL reallocate(velocity,1,3,1,natom) ! VELOCITY SECTION IF(topology%use_g96_velocity) THEN IF(iw>0) WRITE(iw,'(T2,A)') 'G96_INFO| Parsing the VELOCITY section' - CALL parser_create(parser,topology%coord_file_name,para_env=para_env,error=error) + CALL parser_create(parser,topology%coord_file_name,para_env=para_env) label = TRIM(avail_section(4)) - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF(found) THEN natom=0 - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,string_length=default_string_length,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string,string_length=default_string_length) DO IF(string == TRIM("END")) EXIT natom=natom+1 @@ -764,21 +760,21 @@ SUBROUTINE read_coordinate_g96 (topology,para_env,subsys_section,error) atom_info%id_atmname(natom)=str2id(strtmp2) atom_info%id_molname(natom)=atom_info%id_resname(natom) atom_info%id_element(natom)=atom_info%id_atmname(natom) - velocity(1,natom) = cp_unit_to_cp2k(velocity(1,natom),"nm*ps^-1",error=error) - velocity(2,natom) = cp_unit_to_cp2k(velocity(2,natom),"nm*ps^-1",error=error) - velocity(3,natom) = cp_unit_to_cp2k(velocity(3,natom),"nm*ps^-1",error=error) + velocity(1,natom) = cp_unit_to_cp2k(velocity(1,natom),"nm*ps^-1") + velocity(2,natom) = cp_unit_to_cp2k(velocity(2,natom),"nm*ps^-1") + velocity(3,natom) = cp_unit_to_cp2k(velocity(3,natom),"nm*ps^-1") IF(iw>0) WRITE(iw,*) "G96_INFO| PUT VELOCITY INFO HERE!!!!" - CALL parser_get_next_line(parser,1,error=error) - CALL parser_get_object(parser,string,string_length=default_string_length,error=error) + CALL parser_get_next_line(parser,1) + CALL parser_get_object(parser,string,string_length=default_string_length) END DO - CALL parser_release(parser,error=error) - velocity_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) + CALL parser_release(parser) + velocity_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") CALL section_velocity_val_set(velocity_section, velocity=velocity, & - conv_factor=1.0_dp, error=error) + conv_factor=1.0_dp) END IF END IF DEALLOCATE(velocity,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL reallocate(atom_info%id_molname,1,natom) CALL reallocate(atom_info%id_resname,1,natom) @@ -795,7 +791,7 @@ SUBROUTINE read_coordinate_g96 (topology,para_env,subsys_section,error) topology%natoms = natom CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/G96_INFO",error=error) + "PRINT%TOPOLOGY_INFO/G96_INFO") CALL timestop(handle) END SUBROUTINE read_coordinate_g96 diff --git a/src/topology_input.F b/src/topology_input.F index aeebf81375..2e1b193ca7 100644 --- a/src/topology_input.F +++ b/src/topology_input.F @@ -45,15 +45,13 @@ MODULE topology_input !> \brief reads the input section topology !> \param topology ... !> \param topology_section ... -!> \param error ... !> \par History !> none !> \author JGH (26-01-2002) ! ***************************************************************************** -SUBROUTINE read_topology_section ( topology, topology_section, error ) +SUBROUTINE read_topology_section ( topology, topology_section) TYPE(topology_parameters_type) :: topology TYPE(section_vals_type), POINTER :: topology_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_topology_section', & routineP = moduleN//':'//routineN @@ -63,38 +61,38 @@ SUBROUTINE read_topology_section ( topology, topology_section, error ) CALL timeset(routineN,handle) failure = .FALSE. - CALL section_vals_val_get(topology_section,"CHARGE_OCCUP",l_val=topology%charge_occup,error=error) - CALL section_vals_val_get(topology_section,"CHARGE_BETA",l_val=topology%charge_beta,error=error) - CALL section_vals_val_get(topology_section,"CHARGE_EXTENDED",l_val=topology%charge_extended,error=error) + CALL section_vals_val_get(topology_section,"CHARGE_OCCUP",l_val=topology%charge_occup) + CALL section_vals_val_get(topology_section,"CHARGE_BETA",l_val=topology%charge_beta) + CALL section_vals_val_get(topology_section,"CHARGE_EXTENDED",l_val=topology%charge_extended) ival = COUNT((/topology%charge_occup,topology%charge_beta,topology%charge_extended/)) CALL cp_assert(ival<=1,cp_failure_level,cp_assertion_failed,routineP,& "Only one between can be defined! "//& CPSourceFileRef,& only_ionode=.TRUE.) - CALL section_vals_val_get(topology_section,"PARA_RES",l_val=topology%para_res,error=error) - CALL section_vals_val_get(topology_section,"GENERATE%REORDER",l_val=topology%reorder_atom,error=error) - CALL section_vals_val_get(topology_section,"GENERATE%CREATE_MOLECULES",l_val=topology%create_molecules,error=error) - CALL section_vals_val_get(topology_section,"MOL_CHECK",l_val=topology%molecules_check,error=error) - CALL section_vals_val_get(topology_section,"USE_G96_VELOCITY",l_val=topology%use_g96_velocity,error=error) - CALL section_vals_val_get(topology_section,"COORD_FILE_FORMAT",i_val=topology%coord_type ,error=error) + CALL section_vals_val_get(topology_section,"PARA_RES",l_val=topology%para_res) + CALL section_vals_val_get(topology_section,"GENERATE%REORDER",l_val=topology%reorder_atom) + CALL section_vals_val_get(topology_section,"GENERATE%CREATE_MOLECULES",l_val=topology%create_molecules) + CALL section_vals_val_get(topology_section,"MOL_CHECK",l_val=topology%molecules_check) + CALL section_vals_val_get(topology_section,"USE_G96_VELOCITY",l_val=topology%use_g96_velocity) + CALL section_vals_val_get(topology_section,"COORD_FILE_FORMAT",i_val=topology%coord_type) SELECT CASE(topology%coord_type) CASE(do_coord_off) ! Do Nothing CASE DEFAULT topology%coordinate = .TRUE. - CALL section_vals_val_get(topology_section,"COORD_FILE_NAME",c_val=topology%coord_file_name, error=error) + CALL section_vals_val_get(topology_section,"COORD_FILE_NAME",c_val=topology%coord_file_name) END SELECT - CALL section_vals_val_get(topology_section,"CONN_FILE_FORMAT",i_val=topology%conn_type,error=error) + CALL section_vals_val_get(topology_section,"CONN_FILE_FORMAT",i_val=topology%conn_type) SELECT CASE(topology%conn_type) CASE(do_conn_off,do_conn_generate,do_conn_mol_set,do_conn_user) ! Do Nothing CASE DEFAULT - CALL section_vals_val_get(topology_section,"CONN_FILE_NAME",c_val=topology%conn_file_name,error=error) + CALL section_vals_val_get(topology_section,"CONN_FILE_NAME",c_val=topology%conn_file_name) END SELECT - CALL section_vals_val_get(topology_section,"EXCLUDE_VDW",i_val=topology%exclude_vdw,error=error) - CALL section_vals_val_get(topology_section,"EXCLUDE_EI",i_val=topology%exclude_ei,error=error) - CALL section_vals_val_get(topology_section,"GENERATE%BONDPARM",i_val=topology%bondparm_type,error=error) - CALL section_vals_val_get(topology_section,"GENERATE%BONDPARM_FACTOR",r_val=topology%bondparm_factor,error=error) + CALL section_vals_val_get(topology_section,"EXCLUDE_VDW",i_val=topology%exclude_vdw) + CALL section_vals_val_get(topology_section,"EXCLUDE_EI",i_val=topology%exclude_ei) + CALL section_vals_val_get(topology_section,"GENERATE%BONDPARM",i_val=topology%bondparm_type) + CALL section_vals_val_get(topology_section,"GENERATE%BONDPARM_FACTOR",r_val=topology%bondparm_factor) CALL timestop(handle) END SUBROUTINE read_topology_section @@ -104,21 +102,19 @@ END SUBROUTINE read_topology_section !> \param topology ... !> \param colvar_p ... !> \param constraint_section ... -!> \param error ... !> \par History !> JGH (26-01-2002) Distance parameters are now stored in tables. The position !> within the table is used as handle for the topology !> teo Read the CONSTRAINT section within the new input style !> \author teo ! ***************************************************************************** -SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, error) +SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(colvar_p_type), DIMENSION(:), & POINTER :: colvar_p TYPE(section_vals_type), POINTER :: constraint_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_constraints_section', & routineP = moduleN//':'//routineN @@ -139,98 +135,96 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro cons_info => topology%cons_info failure = .FALSE. IF (ASSOCIATED(constraint_section)) THEN - hbonds_section => section_vals_get_subs_vals(constraint_section,"HBONDS",error=error) - g3x3_section => section_vals_get_subs_vals(constraint_section,"G3X3",error=error) - g4x6_section => section_vals_get_subs_vals(constraint_section,"G4X6",error=error) - vsite_section => section_vals_get_subs_vals(constraint_section,"VIRTUAL_SITE",error=error) - fix_atom_section => section_vals_get_subs_vals(constraint_section,"FIXED_ATOMS",error=error) - collective_section => section_vals_get_subs_vals(constraint_section,"COLLECTIVE",error=error) + hbonds_section => section_vals_get_subs_vals(constraint_section,"HBONDS") + g3x3_section => section_vals_get_subs_vals(constraint_section,"G3X3") + g4x6_section => section_vals_get_subs_vals(constraint_section,"G4X6") + vsite_section => section_vals_get_subs_vals(constraint_section,"VIRTUAL_SITE") + fix_atom_section => section_vals_get_subs_vals(constraint_section,"FIXED_ATOMS") + collective_section => section_vals_get_subs_vals(constraint_section,"COLLECTIVE") ! HBONDS - CALL section_vals_get(hbonds_section, explicit=topology%const_hydr, error=error) + CALL section_vals_get(hbonds_section, explicit=topology%const_hydr) CALL check_restraint(hbonds_section,& is_restraint=cons_info%hbonds_restraint, & k0=cons_info%hbonds_k0,& - label="HBONDS",& - error=error) + label="HBONDS") ! G3X3 - CALL section_vals_get(g3x3_section,explicit=explicit, n_repetition=ncons, error=error) + CALL section_vals_get(g3x3_section,explicit=explicit, n_repetition=ncons) IF (explicit) THEN topology%const_33 = .TRUE. cons_info%nconst_g33 = ncons ! ALLOCATE(cons_info%const_g33_mol(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g33_molname(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g33_a(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g33_b(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g33_c(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g33_dab(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g33_dac(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g33_dbc(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g33_intermolecular(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g33_restraint(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g33_k0(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g33_exclude_qm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g33_exclude_mm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ig = 1, ncons CALL check_restraint(g3x3_section,& is_restraint=cons_info%g33_restraint(ig), & k0=cons_info%g33_k0(ig),& i_rep_section=ig,& - label="G3X3",& - error=error) + label="G3X3") cons_info%const_g33_mol(ig) = 0 cons_info%const_g33_molname(ig) = "UNDEF" ! Exclude QM or MM CALL section_vals_val_get(g3x3_section,"EXCLUDE_QM",i_rep_section=ig,& - l_val=cons_info%g33_exclude_qm(ig),error=error) + l_val=cons_info%g33_exclude_qm(ig)) CALL section_vals_val_get(g3x3_section,"EXCLUDE_MM",i_rep_section=ig,& - l_val=cons_info%g33_exclude_mm(ig),error=error) + l_val=cons_info%g33_exclude_mm(ig)) ! Intramolecular restraint CALL section_vals_val_get(g3x3_section,"INTERMOLECULAR",i_rep_section=ig,& - l_val=cons_info%g33_intermolecular(ig),error=error) + l_val=cons_info%g33_intermolecular(ig)) ! If it is intramolecular let's unset (in case user did it) ! the molecule and molname field IF (cons_info%g33_intermolecular(ig)) THEN - CALL section_vals_val_unset(g3x3_section,"MOLECULE",i_rep_section=ig,error=error) - CALL section_vals_val_unset(g3x3_section,"MOLNAME",i_rep_section=ig,error=error) + CALL section_vals_val_unset(g3x3_section,"MOLECULE",i_rep_section=ig) + CALL section_vals_val_unset(g3x3_section,"MOLNAME",i_rep_section=ig) END IF ! Let's tag to which molecule we want to apply constraints CALL section_vals_val_get(g3x3_section,"MOLECULE",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(g3x3_section,"MOLECULE",i_rep_section=ig,& - i_val=cons_info%const_g33_mol(ig),error=error) + i_val=cons_info%const_g33_mol(ig)) END IF CALL section_vals_val_get(g3x3_section,"MOLNAME",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(g3x3_section,"MOLNAME",i_rep_section=ig,& - c_val=cons_info%const_g33_molname(ig),error=error) + c_val=cons_info%const_g33_molname(ig)) END IF IF ((cons_info%const_g33_mol(ig)/=0).AND.(cons_info%const_g33_molname(ig)/="UNDEF")) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF IF ((cons_info%const_g33_mol(ig)==0).AND.(cons_info%const_g33_molname(ig)=="UNDEF").AND.& (.NOT.cons_info%g33_intermolecular(ig))) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF CALL section_vals_val_get(g3x3_section,"ATOMS",i_rep_section=ig,& - i_vals=ilist,error=error) + i_vals=ilist) CALL section_vals_val_get(g3x3_section,"DISTANCES",i_rep_section=ig,& - r_vals=rlist,error=error) + r_vals=rlist) cons_info%const_g33_a(ig) = ilist(1) cons_info%const_g33_b(ig) = ilist(2) cons_info%const_g33_c(ig) = ilist(3) @@ -241,92 +235,91 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro END DO END IF ! G4X6 - CALL section_vals_get(g4x6_section,explicit=explicit, n_repetition=ncons, error=error) + CALL section_vals_get(g4x6_section,explicit=explicit, n_repetition=ncons) IF (explicit) THEN topology%const_46 =.TRUE. cons_info%nconst_g46 = ncons ! ALLOCATE(cons_info%const_g46_mol(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_molname(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_a(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_b(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_c(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_d(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_dab(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_dac(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_dbc(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_dad(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_dbd(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_g46_dcd(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g46_intermolecular(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g46_restraint(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g46_k0(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g46_exclude_qm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%g46_exclude_mm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ig = 1, ncons CALL check_restraint(g4x6_section,& is_restraint=cons_info%g46_restraint(ig), & k0=cons_info%g46_k0(ig),& i_rep_section=ig,& - label="G4X6",& - error=error) + label="G4X6") cons_info%const_g46_mol(ig) = 0 cons_info%const_g46_molname(ig) = "UNDEF" ! Exclude QM or MM CALL section_vals_val_get(g4x6_section,"EXCLUDE_QM",i_rep_section=ig,& - l_val=cons_info%g46_exclude_qm(ig),error=error) + l_val=cons_info%g46_exclude_qm(ig)) CALL section_vals_val_get(g4x6_section,"EXCLUDE_MM",i_rep_section=ig,& - l_val=cons_info%g46_exclude_mm(ig),error=error) + l_val=cons_info%g46_exclude_mm(ig)) ! Intramolecular restraint CALL section_vals_val_get(g4x6_section,"INTERMOLECULAR",i_rep_section=ig,& - l_val=cons_info%g46_intermolecular(ig),error=error) + l_val=cons_info%g46_intermolecular(ig)) ! If it is intramolecular let's unset (in case user did it) ! the molecule and molname field IF (cons_info%g46_intermolecular(ig)) THEN - CALL section_vals_val_unset(g4x6_section,"MOLECULE",i_rep_section=ig,error=error) - CALL section_vals_val_unset(g4x6_section,"MOLNAME",i_rep_section=ig,error=error) + CALL section_vals_val_unset(g4x6_section,"MOLECULE",i_rep_section=ig) + CALL section_vals_val_unset(g4x6_section,"MOLNAME",i_rep_section=ig) END IF ! Let's tag to which molecule we want to apply constraints CALL section_vals_val_get(g4x6_section,"MOLECULE",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(g4x6_section,"MOLECULE",i_rep_section=ig,& - i_val=cons_info%const_g46_mol(ig),error=error) + i_val=cons_info%const_g46_mol(ig)) END IF CALL section_vals_val_get(g4x6_section,"MOLNAME",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(g4x6_section,"MOLNAME",i_rep_section=ig,& - c_val=cons_info%const_g46_molname(ig),error=error) + c_val=cons_info%const_g46_molname(ig)) END IF IF ((cons_info%const_g46_mol(ig)/=0).AND.(cons_info%const_g46_molname(ig)/="UNDEF")) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF IF ((cons_info%const_g46_mol(ig)==0).AND.(cons_info%const_g46_molname(ig)=="UNDEF").AND.& (.NOT.cons_info%g46_intermolecular(ig))) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF CALL section_vals_val_get(g4x6_section,"ATOMS",i_rep_section=ig,& - i_vals=ilist,error=error) + i_vals=ilist) CALL section_vals_val_get(g4x6_section,"DISTANCES",i_rep_section=ig,& - r_vals=rlist,error=error) + r_vals=rlist) cons_info%const_g46_a(ig) = ilist(1) cons_info%const_g46_b(ig) = ilist(2) cons_info%const_g46_c(ig) = ilist(3) @@ -340,84 +333,83 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro END DO END IF ! virtual - CALL section_vals_get(vsite_section,explicit=explicit, n_repetition=ncons, error=error) + CALL section_vals_get(vsite_section,explicit=explicit, n_repetition=ncons) IF (explicit) THEN topology%const_vsite =.TRUE. cons_info%nconst_vsite = ncons ! ALLOCATE(cons_info%const_vsite_mol(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_vsite_molname(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_vsite_a(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_vsite_b(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_vsite_c(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_vsite_d(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_vsite_wbc(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_vsite_wdc(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%vsite_intermolecular(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%vsite_restraint(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%vsite_k0(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%vsite_exclude_qm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%vsite_exclude_mm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ig = 1, ncons CALL check_restraint(vsite_section,& is_restraint=cons_info%vsite_restraint(ig), & k0=cons_info%vsite_k0(ig),& i_rep_section=ig,& - label="Virtual_SITE",& - error=error) + label="Virtual_SITE") cons_info%const_vsite_mol(ig) = 0 cons_info%const_vsite_molname(ig) = "UNDEF" ! Exclude QM or MM CALL section_vals_val_get(vsite_section,"EXCLUDE_QM",i_rep_section=ig,& - l_val=cons_info%vsite_exclude_qm(ig),error=error) + l_val=cons_info%vsite_exclude_qm(ig)) CALL section_vals_val_get(vsite_section,"EXCLUDE_MM",i_rep_section=ig,& - l_val=cons_info%vsite_exclude_mm(ig),error=error) + l_val=cons_info%vsite_exclude_mm(ig)) ! Intramolecular restraint CALL section_vals_val_get(vsite_section,"INTERMOLECULAR",i_rep_section=ig,& - l_val=cons_info%vsite_intermolecular(ig),error=error) + l_val=cons_info%vsite_intermolecular(ig)) ! If it is intramolecular let's unset (in case user did it) ! the molecule and molname field IF (cons_info%vsite_intermolecular(ig)) THEN - CALL section_vals_val_unset(vsite_section,"MOLECULE",i_rep_section=ig,error=error) - CALL section_vals_val_unset(vsite_section,"MOLNAME",i_rep_section=ig,error=error) + CALL section_vals_val_unset(vsite_section,"MOLECULE",i_rep_section=ig) + CALL section_vals_val_unset(vsite_section,"MOLNAME",i_rep_section=ig) END IF ! Let's tag to which molecule we want to apply constraints CALL section_vals_val_get(vsite_section,"MOLECULE",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(vsite_section,"MOLECULE",i_rep_section=ig,& - i_val=cons_info%const_vsite_mol(ig),error=error) + i_val=cons_info%const_vsite_mol(ig)) END IF CALL section_vals_val_get(vsite_section,"MOLNAME",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(vsite_section,"MOLNAME",i_rep_section=ig,& - c_val=cons_info%const_vsite_molname(ig),error=error) + c_val=cons_info%const_vsite_molname(ig)) END IF IF ((cons_info%const_vsite_mol(ig)/=0).AND.(cons_info%const_vsite_molname(ig)/="UNDEF")) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF IF ((cons_info%const_vsite_mol(ig)==0).AND.(cons_info%const_vsite_molname(ig)=="UNDEF").AND.& (.NOT.cons_info%vsite_intermolecular(ig))) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF CALL section_vals_val_get(vsite_section,"ATOMS",i_rep_section=ig,& - i_vals=ilist,error=error) + i_vals=ilist) CALL section_vals_val_get(vsite_section,"PARAMETERS",i_rep_section=ig,& - r_vals=rlist,error=error) + r_vals=rlist) cons_info%const_vsite_a(ig) = ilist(1) cons_info%const_vsite_b(ig) = ilist(2) cons_info%const_vsite_c(ig) = ilist(3) @@ -427,41 +419,41 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro END DO END IF ! FIXED ATOMS - CALL section_vals_get(fix_atom_section,explicit=explicit, n_repetition=ncons, error=error) + CALL section_vals_get(fix_atom_section,explicit=explicit, n_repetition=ncons) IF (explicit) THEN NULLIFY(tmplist,tmpstringlist) isize = 0 msize = 0 ALLOCATE(cons_info%fixed_atoms(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_type(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_restraint(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_k0(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_molnames(msize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_mol_type(isize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_mol_restraint(msize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_mol_k0(msize),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_exclude_qm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%fixed_exclude_mm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ig = 1, ncons isize_old = isize msize_old = msize CALL section_vals_val_get(fix_atom_section,"COMPONENTS_TO_FIX", i_rep_section=ig,& - i_val=itype, error=error) + i_val=itype) CALL section_vals_val_get(fix_atom_section,"LIST", i_rep_section=ig,& - n_rep_val=n_rep, error=error) + n_rep_val=n_rep) DO jg = 1, n_rep CALL section_vals_val_get(fix_atom_section,"LIST", i_rep_section=ig, & - i_rep_val=jg,i_vals=tmplist, error=error) + i_rep_val=jg,i_vals=tmplist) CALL reallocate(cons_info%fixed_atoms,1,isize+SIZE(tmplist)) cons_info%fixed_atoms(isize+1:isize+SIZE(tmplist)) = tmplist CALL reallocate(cons_info%fixed_restraint,1,isize+SIZE(tmplist)) @@ -476,17 +468,16 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro is_restraint=cons_info%fixed_restraint(isize_old+1), & k0=cons_info%fixed_k0(isize_old+1),& i_rep_section=ig,& - label="FIXED ATOM",& - error=error) + label="FIXED ATOM") cons_info%fixed_restraint(isize_old+1:isize)=cons_info%fixed_restraint(isize_old+1) cons_info%fixed_k0(isize_old+1:isize)=cons_info%fixed_k0(isize_old+1) END IF CALL section_vals_val_get(fix_atom_section,"MOLNAME", i_rep_section=ig,& - n_rep_val=n_rep, error=error) + n_rep_val=n_rep) IF (n_rep /= 0) THEN DO jg = 1, n_rep CALL section_vals_val_get(fix_atom_section,"MOLNAME", i_rep_section=ig, & - i_rep_val=jg, c_vals=tmpstringlist, error=error) + i_rep_val=jg, c_vals=tmpstringlist) CALL reallocate(cons_info%fixed_molnames,1,msize+SIZE(tmpstringlist,1)) CALL reallocate(cons_info%fixed_mol_type,1,msize+SIZE(tmpstringlist,1)) CALL reallocate(cons_info%fixed_mol_restraint,1,msize+SIZE(tmpstringlist,1)) @@ -499,9 +490,9 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro CALL reallocate(cons_info%fixed_exclude_qm,1,msize) CALL reallocate(cons_info%fixed_exclude_mm,1,msize) CALL section_vals_val_get(fix_atom_section,"EXCLUDE_QM",i_rep_section=ig,& - l_val=cons_info%fixed_exclude_qm(msize_old+1),error=error) + l_val=cons_info%fixed_exclude_qm(msize_old+1)) CALL section_vals_val_get(fix_atom_section,"EXCLUDE_MM",i_rep_section=ig,& - l_val=cons_info%fixed_exclude_mm(msize_old+1),error=error) + l_val=cons_info%fixed_exclude_mm(msize_old+1)) cons_info%fixed_exclude_qm(msize_old+1:msize) = cons_info%fixed_exclude_qm(msize_old+1) cons_info%fixed_exclude_mm(msize_old+1:msize) = cons_info%fixed_exclude_mm(msize_old+1) END IF @@ -511,25 +502,24 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro is_restraint=cons_info%fixed_mol_restraint(msize_old+1), & k0=cons_info%fixed_mol_k0(msize_old+1),& i_rep_section=ig,& - label="FIXED ATOM",& - error=error) + label="FIXED ATOM") cons_info%fixed_mol_restraint(msize_old+1:msize)=cons_info%fixed_mol_restraint(msize_old+1) cons_info%fixed_mol_k0(msize_old+1:msize)=cons_info%fixed_mol_k0(msize_old+1) END IF CALL section_vals_val_get(fix_atom_section,"MM_SUBSYS",i_rep_section=ig,& - n_rep_val=nrep,explicit=explicit,error=error) + n_rep_val=nrep,explicit=explicit) IF (nrep==1 .AND. explicit) THEN - CPPostcondition(cons_info%freeze_mm==do_constr_none,cp_failure_level,routineP,error,failure) + CPPostcondition(cons_info%freeze_mm==do_constr_none,cp_failure_level,routineP,failure) CALL section_vals_val_get(fix_atom_section,"MM_SUBSYS",i_val=cons_info%freeze_mm,& - i_rep_section=ig,error=error) + i_rep_section=ig) cons_info%freeze_mm_type = itype END IF CALL section_vals_val_get(fix_atom_section,"QM_SUBSYS",i_rep_section=ig,& - n_rep_val=nrep,explicit=explicit,error=error) + n_rep_val=nrep,explicit=explicit) IF (nrep==1 .AND. explicit) THEN - CPPostcondition(cons_info%freeze_qm==do_constr_none,cp_failure_level,routineP,error,failure) + CPPostcondition(cons_info%freeze_qm==do_constr_none,cp_failure_level,routineP,failure) CALL section_vals_val_get(fix_atom_section,"QM_SUBSYS",i_val=cons_info%freeze_qm,& - i_rep_section=ig,error=error) + i_rep_section=ig) cons_info%freeze_qm_type = itype END IF IF (cons_info%freeze_mm/=do_constr_none) THEN @@ -537,16 +527,14 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro is_restraint=cons_info%fixed_mm_restraint, & k0=cons_info%fixed_mm_k0,& i_rep_section=ig,& - label="FIXED ATOM",& - error=error) + label="FIXED ATOM") END IF IF (cons_info%freeze_qm/=do_constr_none) THEN CALL check_restraint(fix_atom_section,& is_restraint=cons_info%fixed_qm_restraint, & k0=cons_info%fixed_qm_k0,& i_rep_section=ig,& - label="FIXED ATOM",& - error=error) + label="FIXED ATOM") END IF END DO @@ -557,70 +545,68 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro END IF END IF ! Collective Constraints - CALL section_vals_get(collective_section,explicit=explicit, n_repetition=ncons, error=error) + CALL section_vals_get(collective_section,explicit=explicit, n_repetition=ncons) IF (explicit) THEN topology%const_colv = .TRUE. DO ig = 1, ncons - CALL section_vals_val_get(collective_section,"COLVAR",i_rep_section=ig, i_val=icolvar,& - error=error) - CPPostcondition(icolvar<=SIZE(colvar_p),cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(collective_section,"COLVAR",i_rep_section=ig, i_val=icolvar) + CPPostcondition(icolvar<=SIZE(colvar_p),cp_failure_level,routineP,failure) END DO cons_info%nconst_colv = ncons ALLOCATE(cons_info%const_colv_mol(ncons), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_colv_molname(ncons), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_colv_target(ncons), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%const_colv_target_growth(ncons), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%colvar_set(ncons), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%colv_intermolecular(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%colv_restraint(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%colv_k0(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%colv_exclude_qm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(cons_info%colv_exclude_mm(ncons),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ig = 1, ncons CALL check_restraint(collective_section,& is_restraint=cons_info%colv_restraint(ig), & k0=cons_info%colv_k0(ig),& i_rep_section=ig,& - label="COLLECTIVE",& - error=error) + label="COLLECTIVE") cons_info%const_colv_mol(ig) = 0 cons_info%const_colv_molname(ig) = "UNDEF" ! Exclude QM or MM CALL section_vals_val_get(collective_section,"EXCLUDE_QM",i_rep_section=ig,& - l_val=cons_info%colv_exclude_qm(ig),error=error) + l_val=cons_info%colv_exclude_qm(ig)) CALL section_vals_val_get(collective_section,"EXCLUDE_MM",i_rep_section=ig,& - l_val=cons_info%colv_exclude_mm(ig),error=error) + l_val=cons_info%colv_exclude_mm(ig)) ! Intramolecular restraint CALL section_vals_val_get(collective_section,"INTERMOLECULAR",i_rep_section=ig,& - l_val=cons_info%colv_intermolecular(ig),error=error) + l_val=cons_info%colv_intermolecular(ig)) ! If it is intramolecular let's unset (in case user did it) ! the molecule and molname field IF (cons_info%colv_intermolecular(ig)) THEN - CALL section_vals_val_unset(collective_section,"MOLECULE",i_rep_section=ig,error=error) - CALL section_vals_val_unset(collective_section,"MOLNAME",i_rep_section=ig,error=error) + CALL section_vals_val_unset(collective_section,"MOLECULE",i_rep_section=ig) + CALL section_vals_val_unset(collective_section,"MOLNAME",i_rep_section=ig) END IF ! Let's tag to which molecule we want to apply constraints CALL section_vals_val_get(collective_section,"MOLECULE",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(collective_section,"MOLECULE",i_rep_section=ig,& - i_val=cons_info%const_colv_mol(ig),error=error) + i_val=cons_info%const_colv_mol(ig)) END IF CALL section_vals_val_get(collective_section,"MOLNAME",i_rep_section=ig,& - n_rep_val=nrep,error=error) + n_rep_val=nrep) IF (nrep/=0) THEN CALL section_vals_val_get(collective_section,"MOLNAME",i_rep_section=ig,& - c_val=cons_info%const_colv_molname(ig),error=error) + c_val=cons_info%const_colv_molname(ig)) END IF IF (((cons_info%const_colv_mol(ig)/=0).AND.(cons_info%const_colv_molname(ig)/="UNDEF"))) THEN CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& @@ -638,19 +624,19 @@ SUBROUTINE read_constraints_section(topology, colvar_p, constraint_section, erro END IF NULLIFY(cons_info%colvar_set(ig)%colvar) CALL section_vals_val_get(collective_section,"COLVAR",i_rep_section=ig,& - i_val=icolvar, error=error) + i_val=icolvar) CALL colvar_clone(cons_info%colvar_set(ig)%colvar,& - colvar_p(icolvar)%colvar, error=error) + colvar_p(icolvar)%colvar) CALL section_vals_val_get(collective_section,"TARGET",& - n_rep_val=n_rep,i_rep_section=ig, error=error) + n_rep_val=n_rep,i_rep_section=ig) IF (n_rep /=0) THEN CALL section_vals_val_get(collective_section,"TARGET",& - r_val=cons_info%const_colv_target(ig),i_rep_section=ig, error=error) + r_val=cons_info%const_colv_target(ig),i_rep_section=ig) ELSE cons_info%const_colv_target(ig) = -HUGE(0.0_dp) END IF CALL section_vals_val_get(collective_section,"TARGET_GROWTH",& - r_val=cons_info%const_colv_target_growth(ig),i_rep_section=ig, error=error) + r_val=cons_info%const_colv_target_growth(ig),i_rep_section=ig) END DO END IF END IF @@ -664,16 +650,14 @@ END SUBROUTINE read_constraints_section !> \param k0 ... !> \param i_rep_section ... !> \param label ... -!> \param error ... !> \author teo ! ***************************************************************************** -SUBROUTINE check_restraint(cons_section, is_restraint, k0, i_rep_section, label, error) +SUBROUTINE check_restraint(cons_section, is_restraint, k0, i_rep_section, label) TYPE(section_vals_type), POINTER :: cons_section LOGICAL, INTENT(OUT) :: is_restraint REAL(KIND=dp), INTENT(OUT) :: k0 INTEGER, INTENT(IN), OPTIONAL :: i_rep_section CHARACTER(LEN=*), INTENT(IN) :: label - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'check_restraint', & routineP = moduleN//':'//routineN @@ -686,15 +670,15 @@ SUBROUTINE check_restraint(cons_section, is_restraint, k0, i_rep_section, label, failure = .FALSE. is_restraint = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) - CALL section_vals_get(cons_section,explicit=explicit, error=error) + CALL section_vals_get(cons_section,explicit=explicit) IF (explicit) THEN restraint_section => section_vals_get_subs_vals(cons_section,"RESTRAINT",& - i_rep_section=i_rep_section,error=error) - CALL section_vals_get(restraint_section,explicit=is_restraint, error=error) + i_rep_section=i_rep_section) + CALL section_vals_get(restraint_section,explicit=is_restraint) IF (is_restraint) THEN - CALL section_vals_val_get(restraint_section,"K",r_val=k0,error=error) + CALL section_vals_val_get(restraint_section,"K",r_val=k0) IF (output_unit>0) THEN nlabel = cp_to_string(i_rep_section) WRITE(output_unit,FMT='(T2,"RESTRAINT|",1X,A,F9.6)')& diff --git a/src/topology_multiple_unit_cell.F b/src/topology_multiple_unit_cell.F index 2ddb016046..692aa5828d 100644 --- a/src/topology_multiple_unit_cell.F +++ b/src/topology_multiple_unit_cell.F @@ -38,14 +38,12 @@ MODULE topology_multiple_unit_cell !> \brief Handles the multiple_unit_cell for the atomic coordinates.. !> \param topology ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino [tlaino] - 05.2009 ! ***************************************************************************** - SUBROUTINE topology_muc(topology, subsys_section, error) + SUBROUTINE topology_muc(topology, subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_muc', & routineP = moduleN//':'//routineN @@ -64,7 +62,7 @@ SUBROUTINE topology_muc(topology, subsys_section, error) CALL timeset(routineN,handle) NULLIFY(multiple_unit_cell,iwork,cell) CALL section_vals_val_get(subsys_section, "TOPOLOGY%MULTIPLE_UNIT_CELL",& - i_vals=multiple_unit_cell, error=error) + i_vals=multiple_unit_cell) ! Fail is one of the value is set to zero.. CALL cp_assert(ALL(multiple_unit_cell>0),cp_fatal_level,cp_assertion_failed,routineP,& "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL accepts only integer values larger than 0! "//& @@ -73,7 +71,7 @@ SUBROUTINE topology_muc(topology, subsys_section, error) IF (ANY(multiple_unit_cell/=1)) THEN ! Check that the setup between CELL and TOPOLOGY is the same.. CALL section_vals_val_get(subsys_section, "CELL%MULTIPLE_UNIT_CELL",& - i_vals=iwork, error=error) + i_vals=iwork) CALL cp_assert(ALL(iwork==multiple_unit_cell),cp_fatal_level,cp_assertion_failed,routineP,& "SUBSYS%TOPOLOGY%MULTIPLE_UNIT_CELL and SUBSYS%CELL%MULTIPLE_UNIT_CELL have been "//& "setup to two different values!! Correct this error!!"//& @@ -82,10 +80,10 @@ SUBROUTINE topology_muc(topology, subsys_section, error) natoms = topology%natoms*PRODUCT(multiple_unit_cell) ! Check, if velocities are provided, that they are consistent in number with the atoms... - work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY",error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + work_section => section_vals_get_subs_vals(subsys_section,"VELOCITY") + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(work_section,'_DEFAULT_KEYWORD_',n_rep_val=nrep,error=error) + CALL section_vals_val_get(work_section,'_DEFAULT_KEYWORD_',n_rep_val=nrep) check = nrep==natoms CALL cp_assert(check,cp_fatal_level,cp_assertion_failed,routineP,& "Number of available entries in VELOCITY section is not compatible with the number "//& @@ -134,16 +132,16 @@ SUBROUTINE topology_muc(topology, subsys_section, error) topology%natoms = natoms ! Deallocate the coordinate section (will be rebuilt later with the whole atomic set) - work_section => section_vals_get_subs_vals(subsys_section,"COORD",error=error) - CALL section_vals_get(work_section,explicit=explicit,error=error) + work_section => section_vals_get_subs_vals(subsys_section,"COORD") + CALL section_vals_get(work_section,explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_get(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_get(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_get(work_section,"SCALED",l_val=scale) END IF - CALL section_vals_remove_values(work_section, error) + CALL section_vals_remove_values(work_section) IF (explicit) THEN - CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str,error=error) - CALL section_vals_val_set(work_section,"SCALED",l_val=scale,error=error) + CALL section_vals_val_set(work_section,"UNIT",c_val=unit_str) + CALL section_vals_val_set(work_section,"SCALED",l_val=scale) END IF END IF CALL timestop(handle) diff --git a/src/topology_pdb.F b/src/topology_pdb.F index 873b8ff74e..2ddb9340f6 100644 --- a/src/topology_pdb.F +++ b/src/topology_pdb.F @@ -93,15 +93,13 @@ MODULE topology_pdb !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \par History !> TLAINO 05.2004 - Added the TER option to use different non-bonded molecules ! ***************************************************************************** - SUBROUTINE read_coordinate_pdb (topology,para_env,subsys_section,error) + SUBROUTINE read_coordinate_pdb (topology,para_env,subsys_section) TYPE(topology_parameters_type) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_coordinate_pdb', & routineP = moduleN//':'//routineN @@ -118,12 +116,12 @@ SUBROUTINE read_coordinate_pdb (topology,para_env,subsys_section,error) TYPE(cp_parser_type), POINTER :: parser NULLIFY(parser, logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/PDB_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) - pfactor = section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR",error) + pfactor = section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR") atom_info => topology%atom_info CALL reallocate(atom_info%id_molname,1,nblock) CALL reallocate(atom_info%id_resname,1,nblock) @@ -144,14 +142,14 @@ SUBROUTINE read_coordinate_pdb (topology,para_env,subsys_section,error) id0 = str2id(s2s("")) topology%molname_generated = .FALSE. - CALL parser_create(parser,topology%coord_file_name,para_env=para_env,error=error) + CALL parser_create(parser,topology%coord_file_name,para_env=para_env) natom = 0 inum_mol = 1 WRITE (UNIT=root_mol_name,FMT='(A3,I0)') "MOL",inum_mol DO line = "" - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) IF(my_end) EXIT line = parser%input_line(1:default_path_length) record = line(1:6) @@ -230,9 +228,9 @@ SUBROUTINE read_coordinate_pdb (topology,para_env,subsys_section,error) ADJUSTL(TRIM(id2str(atom_info%id_molname(natom)))),& ADJUSTR(TRIM(id2str(atom_info%id_element(natom)))) END IF - atom_info%r(1,natom) = cp_unit_to_cp2k(atom_info%r(1,natom),"angstrom",error=error) - atom_info%r(2,natom) = cp_unit_to_cp2k(atom_info%r(2,natom),"angstrom",error=error) - atom_info%r(3,natom) = cp_unit_to_cp2k(atom_info%r(3,natom),"angstrom",error=error) + atom_info%r(1,natom) = cp_unit_to_cp2k(atom_info%r(1,natom),"angstrom") + atom_info%r(2,natom) = cp_unit_to_cp2k(atom_info%r(2,natom),"angstrom") + atom_info%r(3,natom) = cp_unit_to_cp2k(atom_info%r(3,natom),"angstrom") CASE ("TER") inum_mol = inum_mol + 1 WRITE (UNIT=root_mol_name,FMT='(A3,I0)') "MOL",inum_mol @@ -243,7 +241,7 @@ SUBROUTINE read_coordinate_pdb (topology,para_env,subsys_section,error) CASE DEFAULT END SELECT END DO - CALL parser_release(parser,error=error) + CALL parser_release(parser) CALL reallocate(atom_info%id_molname,1,natom) CALL reallocate(atom_info%id_resname,1,natom) @@ -267,7 +265,7 @@ SUBROUTINE read_coordinate_pdb (topology,para_env,subsys_section,error) topology%natoms = natom CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/PDB_INFO",error=error) + "PRINT%TOPOLOGY_INFO/PDB_INFO") CALL timestop(handle) END SUBROUTINE read_coordinate_pdb @@ -277,14 +275,12 @@ END SUBROUTINE read_coordinate_pdb !> \param file_unit ... !> \param topology ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_coordinate_pdb (file_unit,topology,subsys_section,error) + SUBROUTINE write_coordinate_pdb (file_unit,topology,subsys_section) INTEGER, INTENT(IN) :: file_unit TYPE(topology_parameters_type) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_coordinate_pdb', & routineP = moduleN//':'//routineN @@ -304,15 +300,15 @@ SUBROUTINE write_coordinate_pdb (file_unit,topology,subsys_section,error) TYPE(section_vals_type), POINTER :: print_key NULLIFY (logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/PDB_INFO",& - extension=".subsysLog",error=error) - print_key => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%DUMP_PDB",error=error) + extension=".subsysLog") + print_key => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%DUMP_PDB") CALL timeset(routineN,handle) - CALL section_vals_val_get(print_key,"CHARGE_OCCUP",l_val=charge_occup,error=error) - CALL section_vals_val_get(print_key,"CHARGE_BETA",l_val=charge_beta,error=error) - CALL section_vals_val_get(print_key,"CHARGE_EXTENDED",l_val=charge_extended,error=error) + CALL section_vals_val_get(print_key,"CHARGE_OCCUP",l_val=charge_occup) + CALL section_vals_val_get(print_key,"CHARGE_BETA",l_val=charge_beta) + CALL section_vals_val_get(print_key,"CHARGE_EXTENDED",l_val=charge_extended) i = COUNT((/charge_occup,charge_beta,charge_extended/)) CALL cp_assert((i <= 1),cp_failure_level,cp_assertion_failed,routineP,& "Either only CHARGE_OCCUP, CHARGE_BETA, or CHARGE_EXTENDED can be selected, "//& @@ -322,8 +318,7 @@ SUBROUTINE write_coordinate_pdb (file_unit,topology,subsys_section,error) atom_info => topology%atom_info record = cp_print_key_generate_filename(logger,print_key,& extension=".pdb",& - my_local=.FALSE.,& - error=error) + my_local=.FALSE.) IF (iw > 0) WRITE (UNIT=iw,FMT=*) " Writing out PDB file ",TRIM(record) @@ -401,7 +396,7 @@ SUBROUTINE write_coordinate_pdb (file_unit,topology,subsys_section,error) IF (iw > 0) WRITE (UNIT=iw,FMT=*) " Exiting "//routineN CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/PDB_INFO",error=error) + "PRINT%TOPOLOGY_INFO/PDB_INFO") CALL timestop(handle) diff --git a/src/topology_psf.F b/src/topology_psf.F index 9d42176ea8..2713349c54 100644 --- a/src/topology_psf.F +++ b/src/topology_psf.F @@ -68,20 +68,18 @@ MODULE topology_psf !> \param para_env ... !> \param subsys_section ... !> \param psf_type ... -!> \param error ... !> \par History !> 04-2007 Teodoro Laino - Zurich University [tlaino] !> This routine should contain only information read from the PSF format !> and all post_process should be performef in the psf_post_process ! ***************************************************************************** - SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_type, error) + SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_type) CHARACTER(LEN=*), INTENT(IN) :: filename TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section INTEGER, INTENT(IN) :: psf_type - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_topology_psf', & routineP = moduleN//':'//routineN @@ -101,12 +99,12 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ NULLIFY(parser, logger) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/PSF_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) - CALL parser_create(parser,filename,para_env=para_env,error=error) + CALL parser_create(parser,filename,para_env=para_env) atom_info => topology%atom_info conn_info => topology%conn_info @@ -114,15 +112,15 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ IF(ASSOCIATED(atom_info%id_molname)) natom_prev = SIZE(atom_info%id_molname) c_int = 'I8' label = 'PSF' - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF (.NOT. found) THEN IF (output_unit>0) THEN WRITE(output_unit,'(A)')"ERROR| Missing PSF specification line" END IF - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF - DO WHILE (parser_test_next_token(parser,error=error)/="EOL") - CALL parser_get_object (parser,field,error=error) + DO WHILE (parser_test_next_token(parser)/="EOL") + CALL parser_get_object (parser,field) SELECT CASE(field(1:3)) CASE ("PSF") IF (psf_type==do_conn_psf) THEN @@ -148,19 +146,19 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ ! ATOM section ! label = '!NATOM' - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF ( .NOT. found ) THEN IF(iw>0) WRITE (iw,'(T2,A)') 'PSF_INFO| No NATOM section ' natom = 0 ELSE - CALL parser_get_object (parser,natom,error=error) + CALL parser_get_object (parser,natom) CALL cp_assert(natom_prev+natom<=topology%natoms,& cp_failure_level,cp_assertion_failed,routineP,& "Number of atoms in connectivity control is larger than the "//& "number of atoms in coordinate control. check coordinates and "//& "connectivity. "//& CPSourceFileRef,& - error=error,failure=failure) + failure=failure) IF(iw>0) WRITE(iw,'(T2,A,'//TRIM(c_int)//')') 'PSF_INFO| NATOM = ',natom !malloc the memory that we need CALL reallocate(atom_info%id_molname,1,natom_prev+natom) @@ -173,7 +171,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ IF (psf_type==do_conn_psf_u) THEN DO iatom=1,natom index_now=iatom+natom_prev - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) READ(parser%input_line,FMT=*,ERR=9)i,& strtmp1,& atom_info%resid(index_now),& @@ -189,7 +187,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ ELSE DO iatom=1,natom index_now=iatom+natom_prev - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) READ(parser%input_line,FMT=psf_format)& i,& strtmp1,& @@ -216,12 +214,12 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ IF(iw>0) WRITE(iw,'(T2,A)') 'PSF_INFO| Parsing the NBOND section' IF(iw>0) WRITE(iw,'(T2,A,I8)') 'PSF_INFO| Previous number of allocated BOND: ',nbond_prev label = '!NBOND' - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF ( .NOT. found ) THEN IF(iw>0) WRITE (iw,'(T2,A)')'PSF_INFO| No NBOND section ' nbond = 0 ELSE - CALL parser_get_object (parser,nbond,error=error) + CALL parser_get_object (parser,nbond) IF(iw>0) WRITE(iw,'(T2,A,'//TRIM(c_int)//')')'PSF_INFO| NBOND = ',nbond !malloc the memory that we need CALL reallocate(conn_info%bond_a,1,nbond_prev+nbond) @@ -229,7 +227,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ !Read in the bond info IF (psf_type==do_conn_psf_u) THEN DO ibond=1,nbond,4 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=nbond_prev+ibond-1 READ(parser%input_line,FMT=*,ERR=9)(conn_info%bond_a(index_now+i),& conn_info%bond_b(index_now+i),& @@ -237,7 +235,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ END DO ELSE DO ibond=1,nbond,4 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=nbond_prev+ibond-1 READ(parser%input_line,FMT='(8'//TRIM(c_int)//')')& (conn_info%bond_a(index_now+i),& @@ -249,7 +247,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ ANY(conn_info%bond_a(nbond_prev+1:)>natom) .OR. & ANY(conn_info%bond_b(nbond_prev+1:)<=0) .OR. & ANY(conn_info%bond_b(nbond_prev+1:)>natom)) THEN - CPAssert(.FALSE.,cp_failure_level,"topology_read, invalid bond",error,failure) + CPAssert(.FALSE.,cp_failure_level,"topology_read, invalid bond",failure) END IF conn_info%bond_a(nbond_prev+1:)=conn_info%bond_a(nbond_prev+1:)+natom_prev conn_info%bond_b(nbond_prev+1:)=conn_info%bond_b(nbond_prev+1:)+natom_prev @@ -263,12 +261,12 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ IF(iw>0) WRITE(iw,'(T2,A)')'PSF_INFO| Parsing the NTHETA section' IF(iw>0) WRITE(iw,'(T2,A,I8)') 'PSF_INFO| Previous number of allocated THETA: ',ntheta_prev label = '!NTHETA' - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF ( .NOT. found ) THEN IF(iw>0) WRITE (iw,'(T2,A)')'PSF_INFO| No NTHETA section ' ntheta = 0 ELSE - CALL parser_get_object (parser,ntheta,error=error) + CALL parser_get_object (parser,ntheta) IF(iw>0) WRITE(iw,'(T2,A,'//TRIM(c_int)//')')'PSF_INFO| NTHETA = ',ntheta !malloc the memory that we need CALL reallocate(conn_info%theta_a,1,ntheta_prev+ntheta) @@ -277,7 +275,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ !Read in the bend info IF (psf_type==do_conn_psf_u) THEN DO itheta=1,ntheta,3 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=ntheta_prev+itheta-1 READ(parser%input_line,FMT=*,ERR=9)(conn_info%theta_a(index_now+i),& conn_info%theta_b(index_now+i),& @@ -286,7 +284,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ END DO ELSE DO itheta=1,ntheta,3 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=ntheta_prev+itheta-1 READ(parser%input_line,FMT='(9'//TRIM(c_int)//')')& (conn_info%theta_a(index_now+i),& @@ -308,12 +306,12 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ IF(iw>0) WRITE(iw,'(T2,A)') 'PSF_INFO| Parsing the NPHI section' IF(iw>0) WRITE(iw,'(T2,A,I8)') 'PSF_INFO| Previous number of allocated PHI: ',nphi_prev label = '!NPHI' - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF ( .NOT. found ) THEN IF(iw>0) WRITE (iw,'(T2,A)') 'PSF_INFO| No NPHI section ' nphi = 0 ELSE - CALL parser_get_object (parser,nphi,error=error) + CALL parser_get_object (parser,nphi) IF(iw>0) WRITE(iw,'(T2,A,'//TRIM(c_int)//')') 'PSF_INFO| NPHI = ',nphi !malloc the memory that we need CALL reallocate(conn_info%phi_a,1,nphi_prev+nphi) @@ -323,7 +321,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ !Read in the torsion info IF (psf_type==do_conn_psf_u) THEN DO iphi=1,nphi,2 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=nphi_prev+iphi-1 READ(parser%input_line,FMT=*,ERR=9)(conn_info%phi_a(index_now+i),& conn_info%phi_b(index_now+i),& @@ -333,7 +331,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ END DO ELSE DO iphi=1,nphi,2 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=nphi_prev+iphi-1 READ(parser%input_line,FMT='(8'//TRIM(c_int)//')')& (conn_info%phi_a(index_now+i),& @@ -357,12 +355,12 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ IF(iw>0) WRITE(iw,'(T2,A)')'PSF_INFO| Parsing the NIMPHI section' IF(iw>0) WRITE(iw,'(T2,A,I8)') 'PSF_INFO| Previous number of allocated IMPHI: ',nphi_prev label = '!NIMPHI' - CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.,error=error) + CALL parser_search_string(parser,label,.TRUE.,found,begin_line=.TRUE.) IF ( .NOT. found ) THEN IF(iw>0) WRITE (iw,'(T2,A)')'PSF_INFO| No NIMPHI section ' nphi = 0 ELSE - CALL parser_get_object (parser,nphi,error=error) + CALL parser_get_object (parser,nphi) IF(iw>0) WRITE(iw,'(T2,A,'//TRIM(c_int)//')')'PSF_INFO| NIMPR = ',nphi !malloc the memory that we need CALL reallocate(conn_info%impr_a,1,nphi_prev+nphi) @@ -372,7 +370,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ !Read in the improper torsion info IF (psf_type==do_conn_psf_u) THEN DO iphi=1,nphi,2 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=nphi_prev+iphi-1 READ(parser%input_line,FMT=*,ERR=9)(conn_info%impr_a(index_now+i),& conn_info%impr_b(index_now+i),& @@ -382,7 +380,7 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ END DO ELSE DO iphi=1,nphi,2 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) index_now=nphi_prev+iphi-1 READ(parser%input_line,FMT='(8'//TRIM(c_int)//')')& (conn_info%impr_a(index_now+i),& @@ -398,10 +396,10 @@ SUBROUTINE read_topology_psf (filename,topology,para_env,subsys_section, psf_typ conn_info%impr_d(nphi_prev+1:)=conn_info%impr_d(nphi_prev+1:)+natom_prev END IF - CALL parser_release(parser,error=error) + CALL parser_release(parser) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/PSF_INFO",error=error) + "PRINT%TOPOLOGY_INFO/PSF_INFO") RETURN 9 CONTINUE ! Print error and exit @@ -419,13 +417,11 @@ END SUBROUTINE read_topology_psf !> \brief Post processing of PSF informations !> \param topology ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE psf_post_process(topology,subsys_section,error) + SUBROUTINE psf_post_process(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'psf_post_process', & routineP = moduleN//':'//routineN @@ -443,9 +439,9 @@ SUBROUTINE psf_post_process(topology,subsys_section,error) NULLIFY(logger) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/PSF_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) atom_info => topology%atom_info conn_info => topology%conn_info @@ -475,7 +471,7 @@ SUBROUTINE psf_post_process(topology,subsys_section,error) END IF ELSE IF(atom_info%id_molname(iatom)/=atom_info%id_molname(jatom)) THEN - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END IF END IF END DO @@ -502,24 +498,24 @@ SUBROUTINE psf_post_process(topology,subsys_section,error) conn_info%onfo_b(1:) = conn_info%phi_d(1:) ! Reorder bonds ALLOCATE(ex_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%bond_a)) N = SIZE(conn_info%bond_a) - CALL reorder_structure(ex_bond_list, conn_info%bond_a, conn_info%bond_b, N, error) + CALL reorder_structure(ex_bond_list, conn_info%bond_a, conn_info%bond_b, N) ! Reorder bends ALLOCATE(ex_bend_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_bend_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%theta_a)) N = SIZE(conn_info%theta_a) - CALL reorder_structure(ex_bend_list, conn_info%theta_a, conn_info%theta_c, N, error) + CALL reorder_structure(ex_bend_list, conn_info%theta_a, conn_info%theta_c, N) DO ionfo=1, nphi ! Check if the torsion is not shared between angles or bonds IF ( ANY(ex_bond_list(conn_info%onfo_a(ionfo))%array1==conn_info%onfo_b(ionfo)).OR.& @@ -531,27 +527,27 @@ SUBROUTINE psf_post_process(topology,subsys_section,error) ! deallocate bends DO I=1,natom DEALLOCATE(ex_bend_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bend_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! deallocate bonds DO I=1,natom DEALLOCATE(ex_bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Get unique onfo ALLOCATE(ex_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(ex_bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%onfo_a)) N = nonfo - CALL reorder_structure(ex_bond_list, conn_info%onfo_a, conn_info%onfo_b, N, error) + CALL reorder_structure(ex_bond_list, conn_info%onfo_a, conn_info%onfo_b, N) nonfo = 0 DO I=1,natom DO ionfo = 1, SIZE(ex_bond_list(I)%array1) @@ -567,16 +563,16 @@ SUBROUTINE psf_post_process(topology,subsys_section,error) END DO DO I=1,natom DEALLOCATE(ex_bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL reallocate(conn_info%onfo_a,1,nonfo) CALL reallocate(conn_info%onfo_b,1,nonfo) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/PSF_INFO",error=error) + "PRINT%TOPOLOGY_INFO/PSF_INFO") END SUBROUTINE psf_post_process ! ***************************************************************************** @@ -584,14 +580,12 @@ END SUBROUTINE psf_post_process !> \param topology ... !> \param section ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino - Zurich University 04.2007 ! ***************************************************************************** - SUBROUTINE idm_psf(topology,section,subsys_section,error) + SUBROUTINE idm_psf(topology,section,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: section, subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'idm_psf', & routineP = moduleN//':'//routineN @@ -609,11 +603,11 @@ SUBROUTINE idm_psf(topology,section,subsys_section,error) NULLIFY(logger) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/PSF_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) - CALL section_vals_get(section, explicit=explicit, error=error) + CALL section_vals_get(section, explicit=explicit) IF (explicit) THEN atom_info => topology%atom_info conn_info => topology%conn_info @@ -628,29 +622,29 @@ SUBROUTINE idm_psf(topology,section,subsys_section,error) nimpr = 0 IF (ASSOCIATED(conn_info%impr_a)) nimpr = SIZE(conn_info%impr_a) ! Any new defined bond - subsection => section_vals_get_subs_vals(section,"BONDS",error=error) - CALL section_vals_get(subsection, explicit=explicit, error=error) + subsection => section_vals_get_subs_vals(section,"BONDS") + CALL section_vals_get(subsection, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep) CALL reallocate(conn_info%bond_a,1,n_rep+nbond) CALL reallocate(conn_info%bond_b,1,n_rep+nbond) DO i = 1, n_rep - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp) conn_info%bond_a(nbond+i)=tmp(1) conn_info%bond_b(nbond+i)=tmp(2) END DO ! And now modify the molecule name if two molecules have been bridged ALLOCATE(ex_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tag_mols(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(wrk(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j=1,natom ALLOCATE(ex_bond_list(j)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO - CALL reorder_structure(ex_bond_list, conn_info%bond_a, conn_info%bond_b, nbond+n_rep, error) + CALL reorder_structure(ex_bond_list, conn_info%bond_a, conn_info%bond_b, nbond+n_rep) ! Loop over atoms to possiblyt change molecule name tag_mols=-1 mol_id = 1 @@ -671,7 +665,7 @@ SUBROUTINE idm_psf(topology,section,subsys_section,error) noe = iend-istart+1 istart1 = MINVAL(wrk(istart:iend)) iend1 = MAXVAL(wrk(istart:iend)) - CPPostcondition(iend1-istart1+1==noe,cp_failure_level,routineP,error,failure) + CPPostcondition(iend1-istart1+1==noe,cp_failure_level,routineP,failure) atom_info%id_molname(istart1:iend1)=str2id(s2s("MOL"//cp_to_string(item))) item = tag_mols(i) istart = i @@ -680,46 +674,46 @@ SUBROUTINE idm_psf(topology,section,subsys_section,error) noe = iend-istart+1 istart1 = MINVAL(wrk(istart:iend)) iend1 = MAXVAL(wrk(istart:iend)) - CPPostcondition(iend1-istart1+1==noe,cp_failure_level,routineP,error,failure) + CPPostcondition(iend1-istart1+1==noe,cp_failure_level,routineP,failure) atom_info%id_molname(istart1:iend1)=str2id(s2s("MOL"//cp_to_string(item))) ! Deallocate bonds DO i=1,natom DEALLOCATE(ex_bond_list(i)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(ex_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tag_mols,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Any new defined angle - subsection => section_vals_get_subs_vals(section,"ANGLES",error=error) - CALL section_vals_get(subsection, explicit=explicit, error=error) + subsection => section_vals_get_subs_vals(section,"ANGLES") + CALL section_vals_get(subsection, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep) CALL reallocate(conn_info%theta_a,1,n_rep+ntheta) CALL reallocate(conn_info%theta_b,1,n_rep+ntheta) CALL reallocate(conn_info%theta_c,1,n_rep+ntheta) DO i = 1, n_rep - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp) conn_info%theta_a(ntheta+i)=tmp(1) conn_info%theta_b(ntheta+i)=tmp(2) conn_info%theta_c(ntheta+i)=tmp(3) END DO END IF ! Any new defined torsion - subsection => section_vals_get_subs_vals(section,"TORSIONS",error=error) - CALL section_vals_get(subsection, explicit=explicit, error=error) + subsection => section_vals_get_subs_vals(section,"TORSIONS") + CALL section_vals_get(subsection, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep) CALL reallocate(conn_info%phi_a,1,n_rep+nphi) CALL reallocate(conn_info%phi_b,1,n_rep+nphi) CALL reallocate(conn_info%phi_c,1,n_rep+nphi) CALL reallocate(conn_info%phi_d,1,n_rep+nphi) DO i = 1, n_rep - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp) conn_info%phi_a(nphi+i)=tmp(1) conn_info%phi_b(nphi+i)=tmp(2) conn_info%phi_c(nphi+i)=tmp(3) @@ -727,16 +721,16 @@ SUBROUTINE idm_psf(topology,section,subsys_section,error) END DO END IF ! Any new defined improper - subsection => section_vals_get_subs_vals(section,"IMPROPERS",error=error) - CALL section_vals_get(subsection, explicit=explicit, error=error) + subsection => section_vals_get_subs_vals(section,"IMPROPERS") + CALL section_vals_get(subsection, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",n_rep_val=n_rep) CALL reallocate(conn_info%impr_a,1,n_rep+nimpr) CALL reallocate(conn_info%impr_b,1,n_rep+nimpr) CALL reallocate(conn_info%impr_c,1,n_rep+nimpr) CALL reallocate(conn_info%impr_d,1,n_rep+nimpr) DO i = 1, n_rep - CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp, error=error) + CALL section_vals_val_get(subsection,"_DEFAULT_KEYWORD_",i_rep_val=i, i_vals=tmp) conn_info%impr_a(nimpr+i)=tmp(1) conn_info%impr_b(nimpr+i)=tmp(2) conn_info%impr_c(nimpr+i)=tmp(3) @@ -746,7 +740,7 @@ SUBROUTINE idm_psf(topology,section,subsys_section,error) END IF CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/PSF_INFO",error=error) + "PRINT%TOPOLOGY_INFO/PSF_INFO") END SUBROUTINE idm_psf @@ -757,15 +751,13 @@ END SUBROUTINE idm_psf !> \param topology ... !> \param subsys_section ... !> \param force_env_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE write_topology_psf (file_unit,topology,subsys_section,force_env_section,error) + SUBROUTINE write_topology_psf (file_unit,topology,subsys_section,force_env_section) INTEGER, INTENT(IN) :: file_unit TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section, & force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'write_topology_psf', & routineP = moduleN//':'//routineN @@ -786,10 +778,10 @@ SUBROUTINE write_topology_psf (file_unit,topology,subsys_section,force_env_secti failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) - print_key => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%DUMP_PSF",error=error) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%DUMP_PSF") iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/PSF_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) atom_info => topology%atom_info @@ -797,18 +789,18 @@ SUBROUTINE write_topology_psf (file_unit,topology,subsys_section,force_env_secti ! Check for charges.. (need to dump them in the PSF..) ALLOCATE(charges(topology%natoms),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) charges = atom_info%atm_charge ! Collect charges from Input file.. NULLIFY(tmp_section) - tmp_section => section_vals_get_subs_vals(force_env_section,"MM%FORCEFIELD%CHARGE",error=error) - CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg,error=error) + tmp_section => section_vals_get_subs_vals(force_env_section,"MM%FORCEFIELD%CHARGE") + CALL section_vals_get(tmp_section,explicit=explicit,n_repetition=nchg) IF (explicit) THEN ALLOCATE(charge_atm(nchg),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(charge_inp(nchg),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL read_chrg_section(charge_atm,charge_inp,section=tmp_section,start=0,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL read_chrg_section(charge_atm,charge_inp,section=tmp_section,start=0) DO j = 1, topology%natoms record = id2str(atom_info%id_atmname(j)) ldum = qmmm_ff_precond_only_qm(record) @@ -821,16 +813,16 @@ SUBROUTINE write_topology_psf (file_unit,topology,subsys_section,force_env_secti END DO END DO DEALLOCATE(charge_atm,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(charge_inp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! fixup for topology output DO j = 1, topology%natoms IF (charges(j).EQ.-HUGE(0.0_dp)) charges(j)=-99.0_dp ENDDO record = cp_print_key_generate_filename(logger,print_key,& - extension=".psf",my_local=.FALSE.,error=error) + extension=".psf",my_local=.FALSE.) ! build the EXT format c_int="I10" psf_format = '(I10,T12,A,T21,I0,T30,A,T39,A,T47,A,T53,F10.6,T69,F8.3,T88,I1)' @@ -884,7 +876,7 @@ SUBROUTINE write_topology_psf (file_unit,topology,subsys_section,force_env_secti END DO WRITE(file_unit,FMT='(/)') DEALLOCATE(charges,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) WRITE(file_unit,FMT='('//TRIM(c_int)//',A)')SIZE(conn_info%bond_a)," !NBOND" DO i=1,SIZE(conn_info%bond_a),4 @@ -945,7 +937,7 @@ SUBROUTINE write_topology_psf (file_unit,topology,subsys_section,force_env_secti WRITE(file_unit,FMT='(/)') CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/PSF_INFO",error=error) + "PRINT%TOPOLOGY_INFO/PSF_INFO") CALL timestop(handle) END SUBROUTINE write_topology_psf diff --git a/src/topology_types.F b/src/topology_types.F index 2298c4deb8..9ab33139d1 100644 --- a/src/topology_types.F +++ b/src/topology_types.F @@ -196,14 +196,12 @@ MODULE topology_types ! ***************************************************************************** !> \brief 1. Just NULLIFY and zero all the stuff !> \param topology ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE init_topology (topology, error) + SUBROUTINE init_topology (topology) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_topology', & routineP = moduleN//':'//routineN @@ -216,11 +214,11 @@ SUBROUTINE init_topology (topology, error) ! 1. Nullify and allocate things in topology !----------------------------------------------------------------------------- ALLOCATE(topology%atom_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(topology%conn_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(topology%cons_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !----------------------------------------------------------------------------- ! 2. Initialize and Nullify things in topology !----------------------------------------------------------------------------- @@ -302,19 +300,17 @@ SUBROUTINE init_topology (topology, error) !----------------------------------------------------------------------------- ! 5. Initialize and Nullify things in topology%cons_info !----------------------------------------------------------------------------- - CALL init_constraint(topology%cons_info, error) + CALL init_constraint(topology%cons_info) END SUBROUTINE init_topology ! ***************************************************************************** !> \brief 1. Just NULLIFY and zero all the stuff !> \param constraint_info ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE init_constraint(constraint_info, error) + SUBROUTINE init_constraint(constraint_info) TYPE(constraint_info_type), POINTER :: constraint_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'init_constraint', & routineP = moduleN//':'//routineN @@ -401,14 +397,12 @@ END SUBROUTINE init_constraint ! ***************************************************************************** !> \brief 1. Just DEALLOCATE all the stuff !> \param topology ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE deallocate_topology (topology, error) + SUBROUTINE deallocate_topology (topology) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_topology', & routineP = moduleN//':'//routineN @@ -422,185 +416,185 @@ SUBROUTINE deallocate_topology (topology, error) !----------------------------------------------------------------------------- IF(ASSOCIATED(topology%atom_info%id_molname)) THEN DEALLOCATE(topology%atom_info%id_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%id_resname)) THEN DEALLOCATE(topology%atom_info%id_resname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%resid)) THEN DEALLOCATE(topology%atom_info%resid,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%id_atmname)) THEN DEALLOCATE(topology%atom_info%id_atmname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%id_atom_names)) THEN DEALLOCATE(topology%atom_info%id_atom_names,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%r)) THEN DEALLOCATE(topology%atom_info%r,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%map_mol_typ)) THEN DEALLOCATE(topology%atom_info%map_mol_typ,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%map_mol_num)) THEN DEALLOCATE(topology%atom_info%map_mol_num,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%map_mol_res)) THEN DEALLOCATE(topology%atom_info%map_mol_res,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%atm_charge)) THEN DEALLOCATE(topology%atom_info%atm_charge,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%atm_mass)) THEN DEALLOCATE(topology%atom_info%atm_mass,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%occup)) THEN DEALLOCATE(topology%atom_info%occup,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%beta)) THEN DEALLOCATE(topology%atom_info%beta,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%atom_info%id_element)) THEN DEALLOCATE(topology%atom_info%id_element,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !----------------------------------------------------------------------------- ! 2. DEALLOCATE things in topology%conn_info !----------------------------------------------------------------------------- IF(ASSOCIATED(topology%conn_info%bond_a)) THEN DEALLOCATE(topology%conn_info%bond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%bond_b)) THEN DEALLOCATE(topology%conn_info%bond_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%bond_type)) THEN DEALLOCATE(topology%conn_info%bond_type,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%ub_a)) THEN DEALLOCATE(topology%conn_info%ub_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%ub_b)) THEN DEALLOCATE(topology%conn_info%ub_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%ub_c)) THEN DEALLOCATE(topology%conn_info%ub_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%theta_a)) THEN DEALLOCATE(topology%conn_info%theta_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%theta_b)) THEN DEALLOCATE(topology%conn_info%theta_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%theta_c)) THEN DEALLOCATE(topology%conn_info%theta_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%theta_type)) THEN DEALLOCATE(topology%conn_info%theta_type,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%phi_a)) THEN DEALLOCATE(topology%conn_info%phi_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%phi_b)) THEN DEALLOCATE(topology%conn_info%phi_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%phi_c)) THEN DEALLOCATE(topology%conn_info%phi_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%phi_d)) THEN DEALLOCATE(topology%conn_info%phi_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%phi_type)) THEN DEALLOCATE(topology%conn_info%phi_type,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%impr_a)) THEN DEALLOCATE(topology%conn_info%impr_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%impr_b)) THEN DEALLOCATE(topology%conn_info%impr_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%impr_c)) THEN DEALLOCATE(topology%conn_info%impr_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%impr_d)) THEN DEALLOCATE(topology%conn_info%impr_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%impr_type)) THEN DEALLOCATE(topology%conn_info%impr_type,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%onfo_a)) THEN DEALLOCATE(topology%conn_info%onfo_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%onfo_b)) THEN DEALLOCATE(topology%conn_info%onfo_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%c_bond_a)) THEN DEALLOCATE(topology%conn_info%c_bond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%c_bond_b)) THEN DEALLOCATE(topology%conn_info%c_bond_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info%c_bond_type)) THEN DEALLOCATE(topology%conn_info%c_bond_type,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF !----------------------------------------------------------------------------- ! 3. DEALLOCATE things in topology%cons_info !----------------------------------------------------------------------------- IF (ASSOCIATED(topology%cons_info)) & - CALL deallocate_constraint(topology%cons_info, error) + CALL deallocate_constraint(topology%cons_info) !----------------------------------------------------------------------------- ! 4. DEALLOCATE things in topology !----------------------------------------------------------------------------- - CALL cell_release(topology%cell,error=error) - CALL cell_release(topology%cell_ref,error=error) - CALL cell_release(topology%cell_muc,error=error) + CALL cell_release(topology%cell) + CALL cell_release(topology%cell_ref) + CALL cell_release(topology%cell_muc) IF(ASSOCIATED(topology%atom_info)) THEN DEALLOCATE(topology%atom_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%conn_info)) THEN DEALLOCATE(topology%conn_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(topology%cons_info)) THEN DEALLOCATE(topology%cons_info,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_topology @@ -608,13 +602,11 @@ END SUBROUTINE deallocate_topology ! ***************************************************************************** !> \brief 1. Just DEALLOCATE all the stuff !> \param constraint_info ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE deallocate_constraint(constraint_info, error) + SUBROUTINE deallocate_constraint(constraint_info) TYPE(constraint_info_type), POINTER :: constraint_info - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_constraint', & routineP = moduleN//':'//routineN @@ -626,279 +618,277 @@ SUBROUTINE deallocate_constraint(constraint_info, error) ! Fixed Atoms IF(ASSOCIATED(constraint_info%fixed_atoms)) THEN DEALLOCATE(constraint_info%fixed_atoms, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_type)) THEN DEALLOCATE(constraint_info%fixed_type, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_molnames)) THEN DEALLOCATE(constraint_info%fixed_molnames, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_mol_type)) THEN DEALLOCATE(constraint_info%fixed_mol_type, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_restraint)) THEN DEALLOCATE(constraint_info%fixed_restraint, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_k0)) THEN DEALLOCATE(constraint_info%fixed_k0, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_mol_restraint)) THEN DEALLOCATE(constraint_info%fixed_mol_restraint, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_mol_k0)) THEN DEALLOCATE(constraint_info%fixed_mol_k0, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_exclude_qm)) THEN DEALLOCATE(constraint_info%fixed_exclude_qm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%fixed_exclude_mm)) THEN DEALLOCATE(constraint_info%fixed_exclude_mm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! Collective Constraint IF (ASSOCIATED(constraint_info%colvar_set)) THEN DO i = 1, SIZE(constraint_info%colvar_set) IF (ASSOCIATED(constraint_info%colvar_set(i)%colvar)) THEN - CALL colvar_release(constraint_info%colvar_set(i)%colvar,error) + CALL colvar_release(constraint_info%colvar_set(i)%colvar) NULLIFY(constraint_info%colvar_set(i)%colvar) END IF END DO DEALLOCATE(constraint_info%colvar_set, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_colv_mol)) THEN DEALLOCATE(constraint_info%const_colv_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_colv_molname)) THEN DEALLOCATE(constraint_info%const_colv_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_colv_target)) THEN DEALLOCATE(constraint_info%const_colv_target,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_colv_target_growth)) THEN DEALLOCATE(constraint_info%const_colv_target_growth,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%colv_intermolecular)) THEN DEALLOCATE(constraint_info%colv_intermolecular,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%colv_restraint)) THEN DEALLOCATE(constraint_info%colv_restraint,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%colv_k0)) THEN DEALLOCATE(constraint_info%colv_k0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%colv_exclude_qm)) THEN DEALLOCATE(constraint_info%colv_exclude_qm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%colv_exclude_mm)) THEN DEALLOCATE(constraint_info%colv_exclude_mm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! G3x3 IF(ASSOCIATED(constraint_info%const_g33_mol)) THEN DEALLOCATE(constraint_info%const_g33_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g33_molname)) THEN DEALLOCATE(constraint_info%const_g33_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g33_a)) THEN DEALLOCATE(constraint_info%const_g33_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g33_b)) THEN DEALLOCATE(constraint_info%const_g33_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g33_c)) THEN DEALLOCATE(constraint_info%const_g33_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g33_dab)) THEN DEALLOCATE(constraint_info%const_g33_dab,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g33_dac)) THEN DEALLOCATE(constraint_info%const_g33_dac,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g33_dbc)) THEN DEALLOCATE(constraint_info%const_g33_dbc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g33_intermolecular)) THEN DEALLOCATE(constraint_info%g33_intermolecular,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g33_restraint)) THEN DEALLOCATE(constraint_info%g33_restraint,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g33_k0)) THEN DEALLOCATE(constraint_info%g33_k0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g33_exclude_qm)) THEN DEALLOCATE(constraint_info%g33_exclude_qm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g33_exclude_mm)) THEN DEALLOCATE(constraint_info%g33_exclude_mm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! G4x6 IF(ASSOCIATED(constraint_info%const_g46_mol)) THEN DEALLOCATE(constraint_info%const_g46_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_molname)) THEN DEALLOCATE(constraint_info%const_g46_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_a)) THEN DEALLOCATE(constraint_info%const_g46_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_b)) THEN DEALLOCATE(constraint_info%const_g46_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_c)) THEN DEALLOCATE(constraint_info%const_g46_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_d)) THEN DEALLOCATE(constraint_info%const_g46_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_dab)) THEN DEALLOCATE(constraint_info%const_g46_dab,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_dac)) THEN DEALLOCATE(constraint_info%const_g46_dac,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_dbc)) THEN DEALLOCATE(constraint_info%const_g46_dbc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_dad)) THEN DEALLOCATE(constraint_info%const_g46_dad,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_dbd)) THEN DEALLOCATE(constraint_info%const_g46_dbd,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_g46_dcd)) THEN DEALLOCATE(constraint_info%const_g46_dcd,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g46_intermolecular)) THEN DEALLOCATE(constraint_info%g46_intermolecular,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g46_restraint)) THEN DEALLOCATE(constraint_info%g46_restraint,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g46_k0)) THEN DEALLOCATE(constraint_info%g46_k0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g46_exclude_qm)) THEN DEALLOCATE(constraint_info%g46_exclude_qm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%g46_exclude_mm)) THEN DEALLOCATE(constraint_info%g46_exclude_mm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF ! virtual_site IF(ASSOCIATED(constraint_info%const_vsite_mol)) THEN DEALLOCATE(constraint_info%const_vsite_mol,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_vsite_molname)) THEN DEALLOCATE(constraint_info%const_vsite_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_vsite_a)) THEN DEALLOCATE(constraint_info%const_vsite_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_vsite_b)) THEN DEALLOCATE(constraint_info%const_vsite_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_vsite_c)) THEN DEALLOCATE(constraint_info%const_vsite_c,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_vsite_d)) THEN DEALLOCATE(constraint_info%const_vsite_d,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_vsite_wbc)) THEN DEALLOCATE(constraint_info%const_vsite_wbc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%const_vsite_wdc)) THEN DEALLOCATE(constraint_info%const_vsite_wdc,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%vsite_intermolecular)) THEN DEALLOCATE(constraint_info%vsite_intermolecular,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%vsite_restraint)) THEN DEALLOCATE(constraint_info%vsite_restraint,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%vsite_k0)) THEN DEALLOCATE(constraint_info%vsite_k0,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%vsite_exclude_qm)) THEN DEALLOCATE(constraint_info%vsite_exclude_qm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF(ASSOCIATED(constraint_info%vsite_exclude_mm)) THEN DEALLOCATE(constraint_info%vsite_exclude_mm, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE deallocate_constraint ! ***************************************************************************** !> \brief Deallocate possibly allocated arrays before reading topology !> \param topology ... -!> \param error ... !> \par History !> none ! ***************************************************************************** - SUBROUTINE pre_read_topology (topology, error) + SUBROUTINE pre_read_topology (topology) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pre_read_topology', & routineP = moduleN//':'//routineN @@ -912,32 +902,32 @@ SUBROUTINE pre_read_topology (topology, error) IF (ASSOCIATED(atom_info%id_molname)) THEN DEALLOCATE(atom_info%id_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom_info%resid)) THEN DEALLOCATE(atom_info%resid,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom_info%id_resname)) THEN DEALLOCATE(atom_info%id_resname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom_info%id_atmname)) THEN DEALLOCATE(atom_info%id_atmname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom_info%atm_charge)) THEN DEALLOCATE(atom_info%atm_charge,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(atom_info%atm_mass)) THEN DEALLOCATE(atom_info%atm_mass,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE pre_read_topology diff --git a/src/topology_util.F b/src/topology_util.F index aa0e72b2aa..5bef0050bb 100644 --- a/src/topology_util.F +++ b/src/topology_util.F @@ -80,11 +80,10 @@ MODULE topology_util !> \param qmmm_env_mm ... !> \param subsys_section ... !> \param force_env_section ... -!> \param error ... !> \par History !> Teodoro Laino 09.2006 - Rewritten with a graph matching algorithm ! ***************************************************************************** - SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force_env_section,error) + SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force_env_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology LOGICAL, INTENT(in), OPTIONAL :: qmmm @@ -92,7 +91,6 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force POINTER :: qmmm_env_mm TYPE(section_vals_type), POINTER :: subsys_section, & force_env_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_reorder_atoms', & routineP = moduleN//':'//routineN @@ -130,9 +128,9 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force failure = .FALSE. NULLIFY(logger,generate_section,isolated_section,tmp_v,tmp_n) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) output_unit= cp_logger_get_default_io_unit(logger) IF (output_unit>0) WRITE(output_unit,'(T2,"REORDER | ")') @@ -149,62 +147,62 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force NULLIFY(tr, tatm_charge, tatm_mass, atm_map1, atm_map2, atm_map3) ! This routine can be called only at a very high level where these structures are still ! not even taken into account... - CPPostcondition(.NOT.ASSOCIATED(atom_info%map_mol_num),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(atom_info%map_mol_typ),cp_failure_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(atom_info%map_mol_res),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(atom_info%map_mol_num),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(atom_info%map_mol_typ),cp_failure_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(atom_info%map_mol_res),cp_failure_level,routineP,failure) !ALLOCATE all the temporary arrays needed for this routine ALLOCATE(new_position(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mol_num(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(molname(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tlabel_atmname(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tlabel_molname(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tlabel_resname(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tr(3,natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tatm_charge(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tatm_mass(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(telement(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(atm_map1(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(atm_map2(natom),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! The only information we have at this level is the connectivity of the system. ! 0. Build a list of mapping atom types ALLOCATE(map_atom_type(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! 1. Build a list of bonds ALLOCATE(atom_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom map_atom_type(I) = atom_info%id_atmname(i) ALLOCATE(atom_bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%bond_a)) N = SIZE(conn_info%bond_a) - CALL reorder_structure(atom_bond_list, conn_info%bond_a, conn_info%bond_b, N, error) + CALL reorder_structure(atom_bond_list, conn_info%bond_a, conn_info%bond_b, N) ALLOCATE(atom_info%map_mol_num(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) atom_info%map_mol_num = -1 CALL find_molecule(atom_bond_list,atom_info%map_mol_num, atom_info%id_molname) max_mol_num = MAXVAL(atom_info%map_mol_num) ! In atom_info%map_mol_num have already been mapped molecules ALLOCATE(mol_bnd(2,max_mol_num),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mol_hash(max_mol_num),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(map_mol_hash(max_mol_num),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! 2. Sort the map_mol_num array.. atm_map1 contains now the mapped index ! of the reordered array CALL sort(atom_info%map_mol_num, natom, atm_map1) @@ -233,20 +231,20 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force ! This is the real matching of graphs DO j = 1, max_mol_num CALL setup_graph(j, reference, map_atom_type,& - atom_bond_list, mol_bnd, atm_map1, atm_map2, error=error) + atom_bond_list, mol_bnd, atm_map1, atm_map2) ALLOCATE(order(SIZE(reference)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL hash_molecule(reference, order, mol_hash(j)) DEALLOCATE(order,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,SIZE(reference) DEALLOCATE(reference(I)%bonds,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(reference, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO ! Reorder molecules hashes CALL sort(mol_hash, max_mol_num, map_mol_hash) @@ -266,7 +264,7 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force old_hash=mol_hash(j) CALL setup_graph_set(reference_set,unique_mol,map_mol_hash(j),& map_atom_type,atom_bond_list, mol_bnd, atm_map1, atm_map2,& - atm_map3, error) + atm_map3) ! Reorder Last added reference mol_id = TRIM(ADJUSTL(cp_to_string(unique_mol))) DO i=1,SIZE(atm_map3) @@ -276,25 +274,24 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force mol_num(natom_loc) = unique_mol END DO DEALLOCATE(atm_map3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE CALL setup_graph(map_mol_hash(j), unordered, map_atom_type,& - atom_bond_list, mol_bnd, atm_map1, atm_map2, atm_map3,& - error) + atom_bond_list, mol_bnd, atm_map1, atm_map2, atm_map3) DO imol_ref=1,unique_mol ! reference => reference_set(imol_ref)%graph ALLOCATE(order(SIZE(reference)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL reorder_graph(reference, unordered, order, matches) IF (matches) EXIT DEALLOCATE(order,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO IF (matches) THEN ! Reorder according the correct index ALLOCATE(wrk(SIZE(order)),STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL sort(order, SIZE(order), wrk) DO i=1,SIZE(order) natom_loc=natom_loc+1 @@ -304,14 +301,14 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force END DO ! DEALLOCATE(order,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(wrk,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE unique_mol=unique_mol+1 CALL setup_graph_set(reference_set,unique_mol,map_mol_hash(j),& map_atom_type,atom_bond_list, mol_bnd, atm_map1, atm_map2,& - atm_map3, error) + atm_map3) ! Reorder Last added reference mol_id = TRIM(ADJUSTL(cp_to_string(unique_mol))) DO i=1,SIZE(atm_map3) @@ -321,54 +318,54 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force mol_num(natom_loc) = unique_mol END DO DEALLOCATE(atm_map3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF DO I=1,SIZE(unordered) DEALLOCATE(unordered(I)%bonds,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(unordered, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(atm_map3, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDIF ENDDO IF (output_unit>0) THEN WRITE(output_unit,'(T2,"REORDER | ",A,I7,A)')"Number of unique molecules found:",unique_mol,"." END IF - CPPostcondition(natom_loc==natom,cp_failure_level,routineP,error,failure) + CPPostcondition(natom_loc==natom,cp_failure_level,routineP,failure) DEALLOCATE(map_atom_type,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(atm_map1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(atm_map2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mol_bnd,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mol_hash,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(map_mol_hash,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Deallocate working arrays DO I=1,natom DEALLOCATE(atom_bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(atom_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(atom_info%map_mol_num,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Deallocate reference_set DO i = 1,SIZE(reference_set) DO j = 1, SIZE(reference_set(i)%graph) DEALLOCATE(reference_set(i)%graph(j)%bonds,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(reference_set(i)%graph,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(reference_set,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !Lets swap the atoms now DO iatm=1,natom location = new_position(iatm) @@ -404,7 +401,7 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force ! Let's reorder all the list provided in the input.. ALLOCATE(wrk(SIZE(new_position)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL sort(new_position, SIZE(new_position), wrk) ! NOTE: In the future the whole list of possible integers should be updated at this level.. @@ -412,114 +409,113 @@ SUBROUTINE topology_reorder_atoms(topology,qmmm,qmmm_env_mm,subsys_section,force ! from where qmmm_env_qm will be read. IF (my_qmmm) THEN ! Update the qmmm_env_mm - CPPrecondition(SIZE(qmmm_env_mm%qm_atom_index)/=0,cp_failure_level,routineP,error,failure) - CPPrecondition(ALL(qmmm_env_mm%qm_atom_index /= 0),cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(qmmm_env_mm%qm_atom_index)/=0,cp_failure_level,routineP,failure) + CPPrecondition(ALL(qmmm_env_mm%qm_atom_index /= 0),cp_failure_level,routineP,failure) ALLOCATE(qm_atom_index(SIZE(qmmm_env_mm%qm_atom_index)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iatm=1,SIZE(qmmm_env_mm%qm_atom_index) qm_atom_index(iatm) = wrk(qmmm_env_mm%qm_atom_index(iatm)) END DO qmmm_env_mm%qm_atom_index = qm_atom_index - CPPostcondition(ALL(qmmm_env_mm%qm_atom_index /= 0),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(qmmm_env_mm%qm_atom_index /= 0),cp_failure_level,routineP,failure) DEALLOCATE(qm_atom_index,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Update the qmmm_section: MM_INDEX of the QM_KIND - qmmm_section => section_vals_get_subs_vals(force_env_section,"QMMM",error=error) - qm_kinds => section_vals_get_subs_vals(qmmm_section,"QM_KIND",error=error) - CALL section_vals_get(qm_kinds,n_repetition=nkind,error=error) + qmmm_section => section_vals_get_subs_vals(force_env_section,"QMMM") + qm_kinds => section_vals_get_subs_vals(qmmm_section,"QM_KIND") + CALL section_vals_get(qm_kinds,n_repetition=nkind) DO ikind=1,nkind - CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,n_rep_val=n_var,& - error=error) + CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,n_rep_val=n_var) DO k = 1, n_var CALL section_vals_val_get(qm_kinds,"MM_INDEX",i_rep_section=ikind,i_rep_val=k,& - i_vals=mm_indexes_v,error=error) + i_vals=mm_indexes_v) ALLOCATE(mm_indexes_n(SIZE(mm_indexes_v)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, SIZE(mm_indexes_v) mm_indexes_n(j) = wrk(mm_indexes_v(j)) END DO CALL section_vals_val_set(qm_kinds,"MM_INDEX", i_rep_section=ikind, & - i_vals_ptr=mm_indexes_n, i_rep_val=k, error=error) + i_vals_ptr=mm_indexes_n, i_rep_val=k) END DO END DO ! Handle the link atoms IF (qmmm_env_mm%qmmm_link) THEN ! Update the qmmm_env_mm - CPPrecondition(SIZE(qmmm_env_mm%mm_link_atoms)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(qmmm_env_mm%mm_link_atoms)>0,cp_failure_level,routineP,failure) ALLOCATE(mm_link_atoms(SIZE(qmmm_env_mm%mm_link_atoms)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO iatm=1,SIZE(qmmm_env_mm%mm_link_atoms) mm_link_atoms(iatm) = wrk(qmmm_env_mm%mm_link_atoms(iatm)) END DO qmmm_env_mm%mm_link_atoms = mm_link_atoms - CPPostcondition(ALL(qmmm_env_mm%mm_link_atoms /= 0),cp_failure_level,routineP,error,failure) + CPPostcondition(ALL(qmmm_env_mm%mm_link_atoms /= 0),cp_failure_level,routineP,failure) DEALLOCATE(mm_link_atoms,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Update the qmmm_section: MM_INDEX,QM_INDEX of the LINK atom list - qmmm_link_section => section_vals_get_subs_vals(qmmm_section,"LINK",error=error) - CALL section_vals_get(qmmm_link_section,n_repetition=nlinks,error=error) - CPPostcondition(nlinks /= 0,cp_failure_level,routineP,error,failure) + qmmm_link_section => section_vals_get_subs_vals(qmmm_section,"LINK") + CALL section_vals_get(qmmm_link_section,n_repetition=nlinks) + CPPostcondition(nlinks /= 0,cp_failure_level,routineP,failure) DO ikind= 1, nlinks - CALL section_vals_val_get(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index,error=error) - CALL section_vals_val_get(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index,error=error) + CALL section_vals_val_get(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index) + CALL section_vals_val_get(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index) mm_index = wrk(mm_index) qm_index = wrk(qm_index) - CALL section_vals_val_set(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index,error=error) - CALL section_vals_val_set(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index,error=error) + CALL section_vals_val_set(qmmm_link_section,"MM_INDEX",i_rep_section=ikind,i_val=mm_index) + CALL section_vals_val_set(qmmm_link_section,"QM_INDEX",i_rep_section=ikind,i_val=qm_index) END DO END IF END IF ! !LIST of ISOLATED atoms ! - generate_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE",error=error) - isolated_section => section_vals_get_subs_vals(generate_section,"ISOLATED_ATOMS",error=error) - CALL section_vals_get(isolated_section, explicit=explicit, error=error) + generate_section => section_vals_get_subs_vals(subsys_section,"TOPOLOGY%GENERATE") + isolated_section => section_vals_get_subs_vals(generate_section,"ISOLATED_ATOMS") + CALL section_vals_get(isolated_section, explicit=explicit) IF (explicit) THEN - CALL section_vals_val_get(isolated_section,"LIST", n_rep_val=n_rep, error=error) + CALL section_vals_val_get(isolated_section,"LIST", n_rep_val=n_rep) DO i = 1, n_rep - CALL section_vals_val_get(isolated_section,"LIST", i_vals=tmp_v, i_rep_val=i, error=error) + CALL section_vals_val_get(isolated_section,"LIST", i_vals=tmp_v, i_rep_val=i) ALLOCATE(tmp_n(SIZE(tmp_v)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, SIZE(tmp_v) tmp_n(j) = wrk(tmp_v(j)) END DO - CALL section_vals_val_set(isolated_section,"LIST", i_vals_ptr=tmp_n, i_rep_val=i, error=error) + CALL section_vals_val_set(isolated_section,"LIST", i_vals_ptr=tmp_n, i_rep_val=i) END DO END IF DEALLOCATE(wrk,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) !DEALLOCATE all the temporary arrays needed for this routine DEALLOCATE(new_position,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tlabel_atmname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tlabel_molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tlabel_resname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(telement,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tr,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tatm_charge,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tatm_mass,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(molname,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mol_num,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! DEALLOCATE the bond structures in the connectivity DEALLOCATE(conn_info%bond_a,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(conn_info%bond_b,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (output_unit>0) WRITE(output_unit,'(T2,"REORDER | ")') CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") END SUBROUTINE topology_reorder_atoms ! ***************************************************************************** @@ -533,11 +529,10 @@ END SUBROUTINE topology_reorder_atoms !> \param atm_map1 ... !> \param atm_map2 ... !> \param atm_map3 ... -!> \param error ... !> \author Teodoro Laino 10.2006 ! ***************************************************************************** SUBROUTINE setup_graph_set(graph_set, idim, ind, array2, atom_bond_list, map_mol,& - atm_map1, atm_map2, atm_map3, error) + atm_map1, atm_map2, atm_map3) TYPE(graph_type), DIMENSION(:), POINTER :: graph_set INTEGER, INTENT(IN) :: idim, ind INTEGER, DIMENSION(:), POINTER :: array2 @@ -545,7 +540,6 @@ SUBROUTINE setup_graph_set(graph_set, idim, ind, array2, atom_bond_list, map_mol INTENT(IN) :: atom_bond_list INTEGER, DIMENSION(:, :), POINTER :: map_mol INTEGER, DIMENSION(:), POINTER :: atm_map1, atm_map2, atm_map3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_graph_set', & routineP = moduleN//':'//routineN @@ -559,14 +553,13 @@ SUBROUTINE setup_graph_set(graph_set, idim, ind, array2, atom_bond_list, map_mol NULLIFY(tmp_graph_set) IF (ASSOCIATED(graph_set)) THEN ldim = SIZE(graph_set) - CPPostcondition(ldim+1==idim,cp_failure_level,routineP,error,failure) + CPPostcondition(ldim+1==idim,cp_failure_level,routineP,failure) NULLIFY(tmp_graph_set) - CALL allocate_graph_set(graph_set, tmp_graph_set, error=error) + CALL allocate_graph_set(graph_set, tmp_graph_set) END IF - CALL allocate_graph_set(tmp_graph_set, graph_set, ldim, ldim+1, error) + CALL allocate_graph_set(tmp_graph_set, graph_set, ldim, ldim+1) CALL setup_graph(ind, graph_set(ldim+1)%graph, array2,& - atom_bond_list, map_mol, atm_map1, atm_map2, atm_map3,& - error=error) + atom_bond_list, map_mol, atm_map1, atm_map2, atm_map3) END SUBROUTINE setup_graph_set @@ -576,13 +569,11 @@ END SUBROUTINE setup_graph_set !> \param graph_set_out ... !> \param ldim_in ... !> \param ldim_out ... -!> \param error ... !> \author Teodoro Laino 10.2006 ! ***************************************************************************** - SUBROUTINE allocate_graph_set(graph_set_in, graph_set_out, ldim_in, ldim_out, error) + SUBROUTINE allocate_graph_set(graph_set_in, graph_set_out, ldim_in, ldim_out) TYPE(graph_type), DIMENSION(:), POINTER :: graph_set_in, graph_set_out INTEGER, INTENT(IN), OPTIONAL :: ldim_in, ldim_out - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'allocate_graph_set', & routineP = moduleN//':'//routineN @@ -592,7 +583,7 @@ SUBROUTINE allocate_graph_set(graph_set_in, graph_set_out, ldim_in, ldim_out, e LOGICAL :: failure failure = .FALSE. - CPPostcondition(.NOT.ASSOCIATED(graph_set_out),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(graph_set_out),cp_failure_level,routineP,failure) mydim_in = 0 mydim_out = 0 IF (ASSOCIATED(graph_set_in)) THEN @@ -602,7 +593,7 @@ SUBROUTINE allocate_graph_set(graph_set_in, graph_set_out, ldim_in, ldim_out, e IF (PRESENT(ldim_in)) mydim_in = ldim_in IF (PRESENT(ldim_out)) mydim_out = ldim_out ALLOCATE(graph_set_out(mydim_out),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO i = 1, mydim_out NULLIFY(graph_set_out(i)%graph) END DO @@ -610,22 +601,22 @@ SUBROUTINE allocate_graph_set(graph_set_in, graph_set_out, ldim_in, ldim_out, e DO i = 1, mydim_in v_dim = SIZE(graph_set_in(i)%graph) ALLOCATE(graph_set_out(i)%graph(v_dim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, v_dim graph_set_out(i)%graph(j)%kind = graph_set_in(i)%graph(j)%kind b_dim = SIZE(graph_set_in(i)%graph(j)%bonds) ALLOCATE(graph_set_out(i)%graph(j)%bonds(b_dim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) graph_set_out(i)%graph(j)%bonds = graph_set_in(i)%graph(j)%bonds DEALLOCATE(graph_set_in(i)%graph(j)%bonds,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(graph_set_in(i)%graph,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO IF (ASSOCIATED(graph_set_in)) THEN DEALLOCATE(graph_set_in,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END SUBROUTINE allocate_graph_set @@ -640,11 +631,10 @@ END SUBROUTINE allocate_graph_set !> \param atm_map1 ... !> \param atm_map2 ... !> \param atm_map3 ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** SUBROUTINE setup_graph(ind, graph, array2, atom_bond_list, map_mol,& - atm_map1, atm_map2, atm_map3, error) + atm_map1, atm_map2, atm_map3) INTEGER, INTENT(IN) :: ind TYPE(vertex), DIMENSION(:), POINTER :: graph INTEGER, DIMENSION(:), POINTER :: array2 @@ -653,7 +643,6 @@ SUBROUTINE setup_graph(ind, graph, array2, atom_bond_list, map_mol,& INTEGER, DIMENSION(:, :), POINTER :: map_mol INTEGER, DIMENSION(:), POINTER :: atm_map1, atm_map2 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: atm_map3 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'setup_graph', & routineP = moduleN//':'//routineN @@ -664,26 +653,26 @@ SUBROUTINE setup_graph(ind, graph, array2, atom_bond_list, map_mol,& failure = .FALSE. IF (PRESENT(atm_map3)) THEN - CPPostcondition(.NOT.ASSOCIATED(atm_map3),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(atm_map3),cp_failure_level,routineP,failure) END IF - CPPostcondition(.NOT.ASSOCIATED(graph),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(graph),cp_failure_level,routineP,failure) ! Setup reference graph idim = 0 ifirst = map_mol(1,ind) ilast = map_mol(2,ind) nelement = ilast-ifirst+1 ALLOCATE(graph(nelement),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) IF (PRESENT(atm_map3)) THEN ALLOCATE(atm_map3(nelement),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DO i = ifirst, ilast idim = idim + 1 graph(idim)%kind = array2(atm_map1(i)) nbonds = SIZE(atom_bond_list(atm_map1(i))%array1) ALLOCATE(graph(idim)%bonds(nbonds),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO j = 1, nbonds graph(idim)%bonds(j) = atm_map2(atom_bond_list(atm_map1(i))%array1(j)) END DO @@ -702,14 +691,12 @@ END SUBROUTINE setup_graph !> \param Ilist4 ... !> \param nsize ... !> \param ndim ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - RECURSIVE SUBROUTINE reorder_list_array(Ilist1, Ilist2, Ilist3, Ilist4, nsize, ndim, error) + RECURSIVE SUBROUTINE reorder_list_array(Ilist1, Ilist2, Ilist3, Ilist4, nsize, ndim) INTEGER, DIMENSION(:), POINTER :: Ilist1 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: Ilist2, Ilist3, Ilist4 INTEGER, INTENT(IN) :: nsize, ndim - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reorder_list_array', & routineP = moduleN//':'//routineN @@ -719,13 +706,13 @@ RECURSIVE SUBROUTINE reorder_list_array(Ilist1, Ilist2, Ilist3, Ilist4, nsize, n LOGICAL :: failure failure = .FALSE. - CPPostcondition(nsize>0,cp_failure_level,routineP,error,failure) + CPPostcondition(nsize>0,cp_failure_level,routineP,failure) ALLOCATE(wrk(Ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL sort(Ilist1,Ndim,wrk) IF (nsize/=1) THEN ALLOCATE(tmp(Ndim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp = Ilist2(1:Ndim) DO i = 1,Ndim Ilist2(i)=tmp(wrk(i)) @@ -747,14 +734,14 @@ RECURSIVE SUBROUTINE reorder_list_array(Ilist1, Ilist2, Ilist3, Ilist4, nsize, n END DO END SELECT DEALLOCATE(tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) istart = 1 DO i = 1,Ndim IF (Ilist1(i)/=Ilist1(istart)) THEN iend = i-1 ldim = iend-istart+1 CALL reorder_list_array_low(Ilist2, Ilist3, Ilist4, nsize,& - ldim, istart, iend, error) + ldim, istart, iend) istart = i END IF END DO @@ -762,10 +749,10 @@ RECURSIVE SUBROUTINE reorder_list_array(Ilist1, Ilist2, Ilist3, Ilist4, nsize, n iend = Ndim ldim = iend-istart+1 CALL reorder_list_array_low(Ilist2, Ilist3, Ilist4, nsize,& - ldim, istart, iend, error) + ldim, istart, iend) END IF DEALLOCATE(wrk,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE reorder_list_array ! ***************************************************************************** @@ -777,14 +764,12 @@ END SUBROUTINE reorder_list_array !> \param ldim ... !> \param istart ... !> \param iend ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** RECURSIVE SUBROUTINE reorder_list_array_low(Ilist2, Ilist3, Ilist4, nsize,& - ldim, istart, iend, error) + ldim, istart, iend) INTEGER, DIMENSION(:), OPTIONAL, POINTER :: Ilist2, Ilist3, Ilist4 INTEGER, INTENT(IN) :: nsize, ldim, istart, iend - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reorder_list_array_low', & routineP = moduleN//':'//routineN @@ -797,49 +782,46 @@ RECURSIVE SUBROUTINE reorder_list_array_low(Ilist2, Ilist3, Ilist4, nsize,& SELECT CASE(nsize) CASE(2) ALLOCATE(tmp_2(ldim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_2(:) = Ilist2(istart:iend) - CALL reorder_list_array(tmp_2,nsize=nsize-1,ndim=ldim,& - error=error) + CALL reorder_list_array(tmp_2,nsize=nsize-1,ndim=ldim) Ilist2(istart:iend) = tmp_2(:) DEALLOCATE(tmp_2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(3) ALLOCATE(tmp_2(ldim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_3(ldim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_2(:) = Ilist2(istart:iend) tmp_3(:) = Ilist3(istart:iend) - CALL reorder_list_array(tmp_2,tmp_3,nsize=nsize-1,ndim=ldim,& - error=error) + CALL reorder_list_array(tmp_2,tmp_3,nsize=nsize-1,ndim=ldim) Ilist2(istart:iend) = tmp_2(:) Ilist3(istart:iend) = tmp_3(:) DEALLOCATE(tmp_2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CASE(4) ALLOCATE(tmp_2(ldim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_3(ldim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_4(ldim),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_2(:) = Ilist2(istart:iend) tmp_3(:) = Ilist3(istart:iend) tmp_4(:) = Ilist4(istart:iend) - CALL reorder_list_array(tmp_2, tmp_3, tmp_4, nsize=nsize-1,ndim=ldim,& - error=error) + CALL reorder_list_array(tmp_2, tmp_3, tmp_4, nsize=nsize-1,ndim=ldim) Ilist2(istart:iend) = tmp_2(:) Ilist3(istart:iend) = tmp_3(:) Ilist4(istart:iend) = tmp_4(:) DEALLOCATE(tmp_2,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_3,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_4,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SELECT END SUBROUTINE reorder_list_array_low @@ -912,15 +894,13 @@ END SUBROUTINE tag_molecule !> \param list1 ... !> \param list2 ... !> \param N ... -!> \param error ... !> \author Teodoro Laino 08.2006 ! ***************************************************************************** - SUBROUTINE reorder_structure1d(work, list1, list2, N, error) + SUBROUTINE reorder_structure1d(work, list1, list2, N) TYPE(array1_list_type), DIMENSION(:), & INTENT(INOUT) :: work INTEGER, DIMENSION(:), INTENT(IN) :: list1, list2 INTEGER, INTENT(IN) :: N - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reorder_structure1d', & routineP = moduleN//':'//routineN @@ -937,20 +917,20 @@ SUBROUTINE reorder_structure1d(work, list1, list2, N, error) wrk_tmp => work(index1)%array1 Nsize=SIZE(wrk_tmp) ALLOCATE(work(index1)%array1(Nsize+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work(index1)%array1(1:Nsize) = wrk_tmp work(index1)%array1(Nsize+1) = index2 DEALLOCATE(wrk_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wrk_tmp => work(index2)%array1 Nsize=SIZE(wrk_tmp) ALLOCATE(work(index2)%array1(Nsize+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work(index2)%array1(1:Nsize) = wrk_tmp work(index2)%array1(Nsize+1) = index1 DEALLOCATE(wrk_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO END SUBROUTINE reorder_structure1d @@ -963,15 +943,13 @@ END SUBROUTINE reorder_structure1d !> \param list2 ... !> \param list3 ... !> \param N ... -!> \param error ... !> \author Teodoro Laino 09.2006 ! ***************************************************************************** - SUBROUTINE reorder_structure2d(work, list1, list2, list3, N, error) + SUBROUTINE reorder_structure2d(work, list1, list2, list3, N) TYPE(array2_list_type), DIMENSION(:), & INTENT(INOUT) :: work INTEGER, DIMENSION(:), INTENT(IN) :: list1, list2, list3 INTEGER, INTENT(IN) :: N - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'reorder_structure2d', & routineP = moduleN//':'//routineN @@ -990,38 +968,38 @@ SUBROUTINE reorder_structure2d(work, list1, list2, list3, N, error) wrk_tmp => work(index1)%array1 Nsize=SIZE(wrk_tmp) ALLOCATE(work(index1)%array1(Nsize+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work(index1)%array1(1:Nsize) = wrk_tmp work(index1)%array1(Nsize+1) = index2 DEALLOCATE(wrk_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wrk_tmp => work(index2)%array1 Nsize=SIZE(wrk_tmp) ALLOCATE(work(index2)%array1(Nsize+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work(index2)%array1(1:Nsize) = wrk_tmp work(index2)%array1(Nsize+1) = index1 DEALLOCATE(wrk_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wrk_tmp => work(index1)%array2 Nsize=SIZE(wrk_tmp) ALLOCATE(work(index1)%array2(Nsize+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work(index1)%array2(1:Nsize) = wrk_tmp work(index1)%array2(Nsize+1) = index3 DEALLOCATE(wrk_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) wrk_tmp => work(index2)%array2 Nsize=SIZE(wrk_tmp) ALLOCATE(work(index2)%array2(Nsize+1),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) work(index2)%array2(1:Nsize) = wrk_tmp work(index2)%array2(Nsize+1) = -index3 DEALLOCATE(wrk_tmp,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO END SUBROUTINE reorder_structure2d @@ -1091,13 +1069,11 @@ END SUBROUTINE spread_mol !> \brief Use info from periodic table and set atm_mass !> \param topology ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE topology_set_atm_mass(topology,subsys_section,error) + SUBROUTINE topology_set_atm_mass(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_set_atm_mass', & routineP = moduleN//':'//routineN @@ -1117,30 +1093,30 @@ SUBROUTINE topology_set_atm_mass(topology,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) atom_info => topology%atom_info natom = topology%natoms ! Available external info - kind_section => section_vals_get_subs_vals(subsys_section,"KIND",error=error) - CALL section_vals_get(kind_section,n_repetition=n_rep,error=error) + kind_section => section_vals_get_subs_vals(subsys_section,"KIND") + CALL section_vals_get(kind_section,n_repetition=n_rep) ALLOCATE(keyword(n_rep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(mass(n_rep),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) mass = HUGE(0.0_dp) DO i_rep=1,n_rep CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",& - c_val=keyword(i_rep),i_rep_section=i_rep,error=error) + c_val=keyword(i_rep),i_rep_section=i_rep) CALL uppercase(keyword(i_rep)) CALL section_vals_val_get(kind_section,i_rep_section=i_rep,& - keyword_name="MASS",n_rep_val=i,error=error) + keyword_name="MASS",n_rep_val=i) IF (i>0) CALL section_vals_val_get(kind_section,i_rep_section=i_rep,& - keyword_name="MASS",r_val=mass(i_rep),error=error) + keyword_name="MASS",r_val=mass(i_rep)) END DO ! DO iatom=1,natom @@ -1165,13 +1141,13 @@ SUBROUTINE topology_set_atm_mass(topology,subsys_section,error) id2str(atom_info%id_element(iatom))," a_mass ", atom_info%atm_mass(iatom) END DO DEALLOCATE(keyword,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(mass,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") END SUBROUTINE topology_set_atm_mass @@ -1179,13 +1155,11 @@ END SUBROUTINE topology_set_atm_mass !> \brief Check and verify that all molecules of the same kind are bonded the same !> \param topology ... !> \param subsys_section ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE topology_molecules_check(topology,subsys_section,error) + SUBROUTINE topology_molecules_check(topology,subsys_section) TYPE(topology_parameters_type), & INTENT(INOUT) :: topology TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'topology_molecules_check', & routineP = moduleN//':'//routineN @@ -1204,9 +1178,9 @@ SUBROUTINE topology_molecules_check(topology,subsys_section,error) failure = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/UTIL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) atom_info => topology%atom_info @@ -1217,14 +1191,14 @@ SUBROUTINE topology_molecules_check(topology,subsys_section,error) " Checking consistency between the generated molecules" ALLOCATE(atom_bond_list(natom),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO I=1,natom ALLOCATE(atom_bond_list(I)%array1(0),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO N = 0 IF(ASSOCIATED(conn_info%bond_a)) N = SIZE(conn_info%bond_a) - CALL reorder_structure(atom_bond_list, conn_info%bond_a, conn_info%bond_b, N, error) + CALL reorder_structure(atom_bond_list, conn_info%bond_a, conn_info%bond_b, N) mol_typ = atom_info%map_mol_typ(1) mol_num = atom_info%map_mol_num(1) @@ -1308,13 +1282,13 @@ SUBROUTINE topology_molecules_check(topology,subsys_section,error) DO I=1,natom DEALLOCATE(atom_bond_list(I)%array1,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ENDDO DEALLOCATE(atom_bond_list,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/UTIL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/UTIL_INFO") END SUBROUTINE topology_molecules_check @@ -1325,18 +1299,16 @@ END SUBROUTINE topology_molecules_check !> \param element_out ... !> \param subsys_section ... !> \param use_mm_map_first ... -!> \param error ... !> \par History !> 12.2005 created [teo] !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE check_subsys_element(element_in, atom_name_in, element_out, subsys_section, use_mm_map_first, error) + SUBROUTINE check_subsys_element(element_in, atom_name_in, element_out, subsys_section, use_mm_map_first) CHARACTER(len=*), INTENT(IN) :: element_in, atom_name_in CHARACTER(len=default_string_length), & INTENT(OUT) :: element_out TYPE(section_vals_type), POINTER :: subsys_section LOGICAL :: use_mm_map_first - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'check_subsys_element', & routineP = moduleN//':'//routineN @@ -1358,18 +1330,18 @@ SUBROUTINE check_subsys_element(element_in, atom_name_in, element_out, subsys_se ! First check if a KIND section is overriding the element ! definition CALL uppercase(atom_name) - kind_section => section_vals_get_subs_vals(subsys_section,"KIND",error=error) - CALL section_vals_get(kind_section,n_repetition=n_rep,error=error) + kind_section => section_vals_get_subs_vals(subsys_section,"KIND") + CALL section_vals_get(kind_section,n_repetition=n_rep) DO i_rep=1,n_rep CALL section_vals_val_get(kind_section,"_SECTION_PARAMETERS_",& - c_val=keyword,i_rep_section=i_rep,error=error) + c_val=keyword,i_rep_section=i_rep) CALL uppercase(keyword) IF (TRIM(keyword)==TRIM(atom_name)) THEN CALL section_vals_val_get(kind_section,i_rep_section=i_rep,& - keyword_name="ELEMENT",n_rep_val=i,error=error) + keyword_name="ELEMENT",n_rep_val=i) IF (i>0) THEN CALL section_vals_val_get(kind_section,i_rep_section=i_rep,& - keyword_name="ELEMENT",c_val=element_symbol,error=error) + keyword_name="ELEMENT",c_val=element_symbol) defined_kind_section = .TRUE. EXIT ELSE diff --git a/src/topology_xtl.F b/src/topology_xtl.F index 41290cd3c5..ad4807c8b0 100644 --- a/src/topology_xtl.F +++ b/src/topology_xtl.F @@ -56,7 +56,6 @@ MODULE topology_xtl !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \date 05.2009 !> \par Format Information implemented: !> TITLE @@ -69,11 +68,10 @@ MODULE topology_xtl !> !> \author Teodoro Laino [tlaino] ! ***************************************************************************** - SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) + SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section) TYPE(topology_parameters_type) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_coordinate_xtl', & routineP = moduleN//':'//routineN @@ -97,12 +95,12 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) NULLIFY(parser, logger) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/XTL_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") CALL timeset(routineN,handle) - pfactor=section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR",error) + pfactor=section_get_rval(subsys_section,"TOPOLOGY%MEMORY_PROGRESSION_FACTOR") ! Element is assigned on the basis of the atm_name topology%aa_element = .TRUE. @@ -119,25 +117,25 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) CALL reallocate(atom_info%id_element,1,nblock) IF (iw>0) WRITE(iw,*) " Reading in XTL file ",TRIM(topology%coord_file_name) - CALL parser_create(parser,topology%coord_file_name,para_env=para_env,error=error) + CALL parser_create(parser,topology%coord_file_name,para_env=para_env) ! Check for TITLE CALL parser_search_string(parser,"TITLE",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) IF (found) THEN IF (iw>0) WRITE(iw,'(/,A)')" XTL_INFO| TITLE :: "//TRIM(parser%input_line(parser%icol:)) END IF ! Check for _chemical_formula_sum CALL parser_search_string(parser,"DIMENSION",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) IF (found) THEN IF (iw>0) WRITE(iw,'(A)')" XTL_INFO| DIMENSION :: "//TRIM(parser%input_line(parser%icol:)) - CALL parser_get_object(parser,dimensions,error=error) + CALL parser_get_object(parser,dimensions) IF (dimensions/=3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="XTL file with working DIMENSION different from 3 cannot be parsed! ", & - error=error, error_level=cp_fatal_level) + error_level=cp_fatal_level) END IF ELSE ! Assuming by default we work in 3D-periodic systems @@ -148,52 +146,52 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) periodic = 1 ! Check for _cell_length_a CALL parser_search_string(parser,"CELL",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field CELL was not found in XTL file! "//& CPSourceFileRef) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) ! CELL LENGTH A - CALL parser_get_object(parser,cell_lengths(1),error=error) - cell_lengths(1) = cp_unit_to_cp2k(cell_lengths(1),"angstrom",error=error) + CALL parser_get_object(parser,cell_lengths(1)) + cell_lengths(1) = cp_unit_to_cp2k(cell_lengths(1),"angstrom") ! CELL LENGTH B - CALL parser_get_object(parser,cell_lengths(2),error=error) - cell_lengths(2) = cp_unit_to_cp2k(cell_lengths(2),"angstrom",error=error) + CALL parser_get_object(parser,cell_lengths(2)) + cell_lengths(2) = cp_unit_to_cp2k(cell_lengths(2),"angstrom") ! CELL LENGTH C - CALL parser_get_object(parser,cell_lengths(3),error=error) - cell_lengths(3) = cp_unit_to_cp2k(cell_lengths(3),"angstrom",error=error) + CALL parser_get_object(parser,cell_lengths(3)) + cell_lengths(3) = cp_unit_to_cp2k(cell_lengths(3),"angstrom") ! CELL ANGLE ALPHA - CALL parser_get_object(parser,cell_angles(1),error=error) - cell_angles(1) = cp_unit_to_cp2k(cell_angles(1),"deg",error=error) + CALL parser_get_object(parser,cell_angles(1)) + cell_angles(1) = cp_unit_to_cp2k(cell_angles(1),"deg") ! CELL ANGLE BETA - CALL parser_get_object(parser,cell_angles(2),error=error) - cell_angles(2) = cp_unit_to_cp2k(cell_angles(2),"deg",error=error) + CALL parser_get_object(parser,cell_angles(2)) + cell_angles(2) = cp_unit_to_cp2k(cell_angles(2),"deg") ! CELL ANGLE GAMMA - CALL parser_get_object(parser,cell_angles(3),error=error) - cell_angles(3) = cp_unit_to_cp2k(cell_angles(3),"deg",error=error) + CALL parser_get_object(parser,cell_angles(3)) + cell_angles(3) = cp_unit_to_cp2k(cell_angles(3),"deg") ! Create cell NULLIFY (cell) - CALL cell_create(cell,error=error) + CALL cell_create(cell) CALL set_cell_param(cell,cell_lengths,cell_angles,periodic=periodic,& - do_init_cell=.TRUE.,error=error) - CALL write_cell(cell,subsys_section,label="CELL_XTL|",error=error) + do_init_cell=.TRUE.) + CALL write_cell(cell,subsys_section,label="CELL_XTL|") ! Parse atoms info and fractional coordinates ! Check for _atom_site_label CALL parser_search_string(parser,"ATOMS",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field ATOMS was not found in XTL file! "//& CPSourceFileRef) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) ! Paranoic syntax check.. if this fails one should improve the description of XTL files found = (INDEX(parser%input_line,"NAME X Y Z")/=0) CALL cp_assert(found,cp_fatal_level,cp_assertion_failed,routineP,& "The field ATOMS in XTL file, is not followed by name and coordinates tags! "//& CPSourceFileRef) - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) ! Parse real info natom = 0 DO WHILE (INDEX(parser%input_line,"EOF")==0) @@ -213,21 +211,21 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) CALL reallocate(atom_info%id_element,1,newsize) END IF ! NAME - CALL parser_get_object (parser,strtmp,error=error) + CALL parser_get_object (parser,strtmp) atom_info%id_atmname(natom) = str2id(strtmp) atom_info%id_molname(natom) = str2id(s2s("MOL"//TRIM(ADJUSTL(cp_to_string(natom))))) atom_info%id_resname(natom) = atom_info%id_molname(natom) atom_info%resid(natom) = 1 atom_info%id_element(natom) = atom_info%id_atmname(natom) ! X - CALL parser_get_object(parser,atom_info%r(1,natom),error=error) + CALL parser_get_object(parser,atom_info%r(1,natom)) ! Y - CALL parser_get_object(parser,atom_info%r(2,natom),error=error) + CALL parser_get_object(parser,atom_info%r(2,natom)) ! Z - CALL parser_get_object(parser,atom_info%r(3,natom),error=error) + CALL parser_get_object(parser,atom_info%r(3,natom)) s = atom_info%r(1:3,natom) CALL scaled_to_real(atom_info%r(1:3,natom),s,cell) - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) IF (my_end) EXIT END DO ! Preliminary check: check if atoms provided are really unique.. this is a paranoic @@ -238,20 +236,20 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) r2 = atom_info%r(1:3,jj) r = pbc(r1-r2,cell) check = (SQRT(DOT_PRODUCT(r,r))>=threshold) - CPPostcondition(check,cp_failure_level,routineP,error,failure) + CPPostcondition(check,cp_failure_level,routineP,failure) END DO END DO ! Parse Symmetry Group and generation elements.. ! Check for SYMMETRY CALL parser_search_string(parser,"SYMMETRY",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) IF (found) THEN IF (iw>0) WRITE(iw,'(A)')" XTL_INFO| Symmetry Infos :: "//TRIM(parser%input_line(parser%icol:)) END IF ! Check for SYM MAT CALL parser_search_string(parser,"SYM MAT",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.TRUE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.TRUE.) CALL cp_assert(found,cp_warning_level,cp_assertion_failed,routineP,& "The field SYM MAT was not found in XTL file! "//& CPSourceFileRef,& @@ -306,7 +304,7 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) END IF END DO Loop_over_unique_atoms CALL parser_search_string(parser,"SYM MAT",ignore_case=.FALSE.,found=found,& - begin_line=.FALSE.,search_from_begin_of_file=.FALSE.,error=error) + begin_line=.FALSE.,search_from_begin_of_file=.FALSE.) END DO END IF IF (iw>0) WRITE(iw,'(A,I0)')" XTL_INFO| Number of symmetry operations :: ",isym @@ -314,8 +312,8 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) IF (iw>0) WRITE(iw,'(A10,1X,3F12.6)')(TRIM(id2str(atom_info%id_atmname(ii))),atom_info%r(1:3,ii),ii=1,natom) ! Releasse local cell type and parser - CALL cell_release(cell,error=error) - CALL parser_release(parser,error=error) + CALL cell_release(cell) + CALL parser_release(parser) ! Reallocate all structures with the exact NATOM size CALL reallocate(atom_info%id_molname,1,natom) @@ -332,7 +330,7 @@ SUBROUTINE read_coordinate_xtl (topology,para_env,subsys_section,error) topology%natoms = natom topology%molname_generated = .TRUE. CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/XTL_INFO",error=error) + "PRINT%TOPOLOGY_INFO/XTL_INFO") CALL timestop(handle) END SUBROUTINE read_coordinate_xtl diff --git a/src/topology_xyz.F b/src/topology_xyz.F index 65c263f29b..57e84f7ec1 100644 --- a/src/topology_xyz.F +++ b/src/topology_xyz.F @@ -41,14 +41,12 @@ MODULE topology_xyz !> \param topology ... !> \param para_env ... !> \param subsys_section ... -!> \param error ... !> \author Teodoro Laino ! ***************************************************************************** - SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section,error) + SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section) TYPE(topology_parameters_type) :: topology TYPE(cp_para_env_type), POINTER :: para_env TYPE(section_vals_type), POINTER :: subsys_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'read_coordinate_xyz', & routineP = moduleN//':'//routineN @@ -64,9 +62,9 @@ SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section,error) NULLIFY (parser,logger) failure = .FALSE. - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() iw = cp_print_key_unit_nr(logger,subsys_section,"PRINT%TOPOLOGY_INFO/XYZ_INFO",& - extension=".subsysLog",error=error) + extension=".subsysLog") atom_info => topology%atom_info @@ -76,17 +74,17 @@ SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section,error) END IF CALL parser_create(parser,topology%coord_file_name, para_env=para_env,& - parse_white_lines=.TRUE.,error=error) + parse_white_lines=.TRUE.) ! Element is assigned on the basis of the atm_name topology%aa_element = .TRUE. natom = 0 frame = 0 - CALL parser_get_next_line(parser,1,error=error) + CALL parser_get_next_line(parser,1) Frames: DO ! Atom numbers - CALL parser_get_object(parser,natom,error=error) + CALL parser_get_object(parser,natom) frame = frame + 1 IF (frame == 1) THEN CALL reallocate(atom_info%id_molname,1,natom) @@ -104,7 +102,7 @@ SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section,error) "Atom number differs in different frames!") END IF ! Dummy line - CALL parser_get_next_line(parser,2,error=error) + CALL parser_get_next_line(parser,2) DO j=1,natom ! Atom coordinates READ (parser%input_line,*) strtmp,& @@ -128,12 +126,12 @@ SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section,error) atom_info%r(3,j),& ADJUSTL(TRIM(id2str(atom_info%id_molname(j)))) END IF - atom_info%r(1,j) = cp_unit_to_cp2k(atom_info%r(1,j),"angstrom",error=error) - atom_info%r(2,j) = cp_unit_to_cp2k(atom_info%r(2,j),"angstrom",error=error) - atom_info%r(3,j) = cp_unit_to_cp2k(atom_info%r(3,j),"angstrom",error=error) + atom_info%r(1,j) = cp_unit_to_cp2k(atom_info%r(1,j),"angstrom") + atom_info%r(2,j) = cp_unit_to_cp2k(atom_info%r(2,j),"angstrom") + atom_info%r(3,j) = cp_unit_to_cp2k(atom_info%r(3,j),"angstrom") ! If there's a white line or end of file exit.. otherwise read other available ! snapshots - CALL parser_get_next_line(parser,1,at_end=my_end,error=error) + CALL parser_get_next_line(parser,1,at_end=my_end) my_end = my_end.OR.(LEN_TRIM(parser%input_line) == 0) IF (my_end) THEN CALL cp_assert(j==natom,cp_fatal_level,cp_assertion_failed,routineP,& @@ -146,7 +144,7 @@ SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section,error) END IF END DO END DO Frames - CALL parser_release(parser,error=error) + CALL parser_release(parser) IF (iw > 0) THEN WRITE (UNIT=iw,FMT="(T2,A)")& @@ -157,8 +155,7 @@ SUBROUTINE read_coordinate_xyz (topology,para_env,subsys_section,error) topology%molname_generated = .TRUE. CALL cp_print_key_finished_output(iw,logger,subsys_section,& - "PRINT%TOPOLOGY_INFO/XYZ_INFO",& - error=error) + "PRINT%TOPOLOGY_INFO/XYZ_INFO") CALL timestop(handle) diff --git a/src/transport.F b/src/transport.F index 22842902b2..8637d0b1e4 100644 --- a/src/transport.F +++ b/src/transport.F @@ -82,12 +82,10 @@ END SUBROUTINE c_scf_routine ! ***************************************************************************** !> \brief creates the transport environment !> \param[inout] qs_env the qs_env containing the transport_env -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE transport_env_create(qs_env,error) + SUBROUTINE transport_env_create(qs_env) TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'transport_env_create', & routineP = moduleN//':'//routineN @@ -101,17 +99,17 @@ SUBROUTINE transport_env_create(qs_env,error) CALL timeset(routineN,handle) - CALL get_qs_env(qs_env, transport_env=transport_env, input=input, error=error) + CALL get_qs_env(qs_env, transport_env=transport_env, input=input) - CPPostcondition(.NOT.ASSOCIATED(transport_env),cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(transport_env),cp_failure_level,routineP,failure) ALLOCATE(transport_env,STAT=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL transport_init_read_input(input,transport_env,error) - CALL cp_dbcsr_init(transport_env%template_matrix_sym, error) - CALL cp_dbcsr_init(transport_env%template_matrix_nosym, error) - CALL cp_dbcsr_init(transport_env%csr_sparsity, error) - CALL set_qs_env(qs_env,transport_env=transport_env,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL transport_init_read_input(input,transport_env) + CALL cp_dbcsr_init(transport_env%template_matrix_sym) + CALL cp_dbcsr_init(transport_env%template_matrix_nosym) + CALL cp_dbcsr_init(transport_env%csr_sparsity) + CALL set_qs_env(qs_env,transport_env=transport_env) CALL timestop(handle) @@ -122,13 +120,11 @@ END SUBROUTINE transport_env_create !> the corresponding input section !> \param[inout] input the input file !> \param[inout] transport_env the transport_env to be initialized -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE transport_init_read_input(input,transport_env,error) + SUBROUTINE transport_init_read_input(input,transport_env) TYPE(section_vals_type), POINTER :: input TYPE(transport_env_type), INTENT(INOUT) :: transport_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'transport_init_read_input', & routineP = moduleN//':'//routineN @@ -138,31 +134,31 @@ SUBROUTINE transport_init_read_input(input,transport_env,error) CALL timeset(routineN,handle) - transport_section => section_vals_get_subs_vals(input,"DFT%TRANSPORT",error=error) + transport_section => section_vals_get_subs_vals(input,"DFT%TRANSPORT") ! read from input - CALL section_vals_val_get(transport_section,"DENSITY_MATRIX_CONSTRUCTION_METHOD",i_val=transport_env%params%method,error=error) - CALL section_vals_val_get(transport_section,"BANDWIDTH",i_val=transport_env%params%bandwidth,error=error) - CALL section_vals_val_get(transport_section,"N_CELLS",i_val=transport_env%params%n_cells,error=error) - CALL section_vals_val_get(transport_section,"N_ABSCISSAE",i_val=transport_env%params%n_abscissae,error=error) - CALL section_vals_val_get(transport_section,"N_KPOINTS",i_val=transport_env%params%n_kpoint,error=error) - CALL section_vals_val_get(transport_section,"NUM_INTERVAL",i_val=transport_env%params%num_interval,error=error) - CALL section_vals_val_get(transport_section,"NUM_CONTACTS",i_val=transport_env%params%num_contacts,error=error) - CALL section_vals_val_get(transport_section,"N_DOF",i_val=transport_env%params%ndof,error=error) - CALL section_vals_val_get(transport_section,"TASKS_PER_POINT",i_val=transport_env%params%tasks_per_point,error=error) - CALL section_vals_val_get(transport_section,"CORES_PER_NODE",i_val=transport_env%params%cores_per_node,error=error) - CALL section_vals_val_get(transport_section,"COLZERO_THRESHOLD",r_val=transport_env%params%colzero_threshold,error=error) - CALL section_vals_val_get(transport_section,"EPS_LIMIT",r_val=transport_env%params%eps_limit,error=error) - CALL section_vals_val_get(transport_section,"EPS_DECAY",r_val=transport_env%params%eps_decay,error=error) + CALL section_vals_val_get(transport_section,"DENSITY_MATRIX_CONSTRUCTION_METHOD",i_val=transport_env%params%method) + CALL section_vals_val_get(transport_section,"BANDWIDTH",i_val=transport_env%params%bandwidth) + CALL section_vals_val_get(transport_section,"N_CELLS",i_val=transport_env%params%n_cells) + CALL section_vals_val_get(transport_section,"N_ABSCISSAE",i_val=transport_env%params%n_abscissae) + CALL section_vals_val_get(transport_section,"N_KPOINTS",i_val=transport_env%params%n_kpoint) + CALL section_vals_val_get(transport_section,"NUM_INTERVAL",i_val=transport_env%params%num_interval) + CALL section_vals_val_get(transport_section,"NUM_CONTACTS",i_val=transport_env%params%num_contacts) + CALL section_vals_val_get(transport_section,"N_DOF",i_val=transport_env%params%ndof) + CALL section_vals_val_get(transport_section,"TASKS_PER_POINT",i_val=transport_env%params%tasks_per_point) + CALL section_vals_val_get(transport_section,"CORES_PER_NODE",i_val=transport_env%params%cores_per_node) + CALL section_vals_val_get(transport_section,"COLZERO_THRESHOLD",r_val=transport_env%params%colzero_threshold) + CALL section_vals_val_get(transport_section,"EPS_LIMIT",r_val=transport_env%params%eps_limit) + CALL section_vals_val_get(transport_section,"EPS_DECAY",r_val=transport_env%params%eps_decay) CALL section_vals_val_get(transport_section,"EPS_SINGULARITY_CURVATURES",& - r_val=transport_env%params%eps_singularity_curvatures,error=error) - CALL section_vals_val_get(transport_section,"EPS_MU",r_val=transport_env%params%eps_mu,error=error) - CALL section_vals_val_get(transport_section,"EPS_EIGVAL_DEGEN",r_val=transport_env%params%eps_eigval_degen,error=error) - CALL section_vals_val_get(transport_section,"ENERGY_INTERVAL",r_val=transport_env%params%energy_interval,error=error) - CALL section_vals_val_get(transport_section,"MIN_INTERVAL",r_val=transport_env%params%min_interval,error=error) - CALL section_vals_val_get(transport_section,"TEMPERATURE",r_val=transport_env%params%temperature,error=error) - CALL section_vals_val_get(transport_section,"ROW_DISTRIBUTION",i_val=transport_env%row_dist,error=error) - CALL section_vals_val_get(transport_section,"CSR_SCREENING",l_val=transport_env%csr_screening,error=error) + r_val=transport_env%params%eps_singularity_curvatures) + CALL section_vals_val_get(transport_section,"EPS_MU",r_val=transport_env%params%eps_mu) + CALL section_vals_val_get(transport_section,"EPS_EIGVAL_DEGEN",r_val=transport_env%params%eps_eigval_degen) + CALL section_vals_val_get(transport_section,"ENERGY_INTERVAL",r_val=transport_env%params%energy_interval) + CALL section_vals_val_get(transport_section,"MIN_INTERVAL",r_val=transport_env%params%min_interval) + CALL section_vals_val_get(transport_section,"TEMPERATURE",r_val=transport_env%params%temperature) + CALL section_vals_val_get(transport_section,"ROW_DISTRIBUTION",i_val=transport_env%row_dist) + CALL section_vals_val_get(transport_section,"CSR_SCREENING",l_val=transport_env%csr_screening) CALL timestop(handle) @@ -173,14 +169,12 @@ END SUBROUTINE transport_init_read_input !> \param ks_env ... !> \param[inout] transport_env the transport env to be initialized !> \param[in] template_matrix template matrix to keep the sparsity of matrices fixed -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE transport_initialize(ks_env, transport_env, template_matrix, error) + SUBROUTINE transport_initialize(ks_env, transport_env, template_matrix) TYPE(qs_ks_env_type), POINTER :: ks_env TYPE(transport_env_type), INTENT(INOUT) :: transport_env TYPE(cp_dbcsr_type), INTENT(IN) :: template_matrix - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'transport_initialize', & routineP = moduleN//':'//routineN @@ -191,7 +185,7 @@ SUBROUTINE transport_initialize(ks_env, transport_env, template_matrix, error) CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (logger%para_env%mepos==logger%para_env%source) THEN unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.) ELSE @@ -213,34 +207,33 @@ SUBROUTINE transport_initialize(ks_env, transport_env, template_matrix, error) ENDDO IF (cp_dbcsr_has_symmetry(template_matrix)) THEN - CALL cp_dbcsr_copy(transport_env%template_matrix_sym, template_matrix, error=error) - CALL cp_dbcsr_desymmetrize(transport_env%template_matrix_sym, transport_env%template_matrix_nosym, error) + CALL cp_dbcsr_copy(transport_env%template_matrix_sym, template_matrix) + CALL cp_dbcsr_desymmetrize(transport_env%template_matrix_sym, transport_env%template_matrix_nosym) ELSE - CALL cp_dbcsr_copy(transport_env%template_matrix_nosym, template_matrix, error=error) - CALL cp_dbcsr_copy(transport_env%template_matrix_sym, template_matrix, error=error) + CALL cp_dbcsr_copy(transport_env%template_matrix_nosym, template_matrix) + CALL cp_dbcsr_copy(transport_env%template_matrix_sym, template_matrix) END IF CALL cp_dbcsr_create(transport_env%csr_sparsity, "CSR sparsity", & template = transport_env%template_matrix_sym, & - data_type=dbcsr_type_real_4, error=error) - CALL cp_dbcsr_copy(transport_env%csr_sparsity, transport_env%template_matrix_sym, error=error) + data_type=dbcsr_type_real_4) + CALL cp_dbcsr_copy(transport_env%csr_sparsity, transport_env%template_matrix_sym) - CALL cp_dbcsr_to_csr_screening(ks_env, transport_env%csr_sparsity, error) + CALL cp_dbcsr_to_csr_screening(ks_env, transport_env%csr_sparsity) - IF (.NOT. transport_env%csr_screening) CALL cp_dbcsr_set (transport_env%csr_sparsity, 1.0, error) + IF (.NOT. transport_env%csr_screening) CALL cp_dbcsr_set (transport_env%csr_sparsity, 1.0) CALL cp_csr_create_from_dbcsr(transport_env%template_matrix_nosym, & transport_env%s_matrix, & transport_env%row_dist, & csr_sparsity = transport_env%csr_sparsity, & - numnodes = transport_env%params%tasks_per_point, & - error = error) + numnodes = transport_env%params%tasks_per_point) - CALL cp_csr_print_sparsity(transport_env%s_matrix, unit_nr, error) + CALL cp_csr_print_sparsity(transport_env%s_matrix, unit_nr) - CALL cp_convert_dbcsr_to_csr(transport_env%template_matrix_nosym, transport_env%s_matrix, error=error) + CALL cp_convert_dbcsr_to_csr(transport_env%template_matrix_nosym, transport_env%s_matrix) - CALL cp_csr_create(transport_env%ks_matrix, transport_env%s_matrix, error) - CALL cp_csr_create(transport_env%p_matrix , transport_env%s_matrix, error) + CALL cp_csr_create(transport_env%ks_matrix, transport_env%s_matrix) + CALL cp_csr_create(transport_env%p_matrix , transport_env%s_matrix) CALL timestop(handle) @@ -254,19 +247,17 @@ END SUBROUTINE transport_initialize !> \param[inout] matrix_p DBCSR density matrix !> \param[in] nelectron_spin number of electrons !> \param[in] natoms number of atoms -!> \param[inout] error CP2K error !> \par History !> 12.2012 created [Hossein Bani-Hashemian] !> 12.2014 revised [Hossein Bani-Hashemian] !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE external_scf_method(transport_env, matrix_s, matrix_ks, matrix_p, nelectron_spin, natoms, error) + SUBROUTINE external_scf_method(transport_env, matrix_s, matrix_ks, matrix_p, nelectron_spin, natoms) TYPE(transport_env_type), INTENT(INOUT) :: transport_env TYPE(cp_dbcsr_type), INTENT(IN) :: matrix_s, matrix_ks TYPE(cp_dbcsr_type), INTENT(INOUT) :: matrix_p INTEGER, INTENT(IN) :: nelectron_spin, natoms - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'external_scf_method', & routineP = moduleN//':'//routineN @@ -283,29 +274,29 @@ SUBROUTINE external_scf_method(transport_env, matrix_s, matrix_ks, matrix_p, nel CALL cp_assert(C_ASSOCIATED(transport_env%ext_c_method_ptr),cp_fatal_level,cp_assertion_failed,routineP,& "MISSING C/C++ ROUTINE: The TRANSPORT section is meant to be used together with an external "//& "program, e.g. the quantum transport code OMEN, that provides CP2K with a density matrix.",& - error, failure) + failure) transport_env%params%n_occ = nelectron_spin transport_env%params%n_atoms = natoms transport_env%params%evoltfactor = evolt - CALL csr_interop_nullify(s_mat, error) - CALL csr_interop_nullify(ks_mat, error) - CALL csr_interop_nullify(p_mat, error) + CALL csr_interop_nullify(s_mat) + CALL csr_interop_nullify(ks_mat) + CALL csr_interop_nullify(p_mat) - CALL cp_dbcsr_copy_into_existing(transport_env%template_matrix_sym, matrix_s, error) - CALL convert_dbcsr_to_csr_interop(transport_env%template_matrix_sym, transport_env%s_matrix, s_mat, error=error) + CALL cp_dbcsr_copy_into_existing(transport_env%template_matrix_sym, matrix_s) + CALL convert_dbcsr_to_csr_interop(transport_env%template_matrix_sym, transport_env%s_matrix, s_mat) - CALL cp_dbcsr_copy_into_existing(transport_env%template_matrix_sym, matrix_ks, error) - CALL convert_dbcsr_to_csr_interop(transport_env%template_matrix_sym, transport_env%ks_matrix, ks_mat, error=error) + CALL cp_dbcsr_copy_into_existing(transport_env%template_matrix_sym, matrix_ks) + CALL convert_dbcsr_to_csr_interop(transport_env%template_matrix_sym, transport_env%ks_matrix, ks_mat) - CALL cp_dbcsr_copy_into_existing(transport_env%template_matrix_sym, matrix_s, error) - CALL convert_dbcsr_to_csr_interop(transport_env%template_matrix_sym, transport_env%p_matrix, p_mat, error=error) + CALL cp_dbcsr_copy_into_existing(transport_env%template_matrix_sym, matrix_s) + CALL convert_dbcsr_to_csr_interop(transport_env%template_matrix_sym, transport_env%p_matrix, p_mat) CALL c_method(transport_env%params, s_mat, ks_mat, p_mat) - CALL convert_csr_interop_to_dbcsr(p_mat, transport_env%p_matrix, transport_env%template_matrix_nosym, error) - CALL cp_dbcsr_copy(matrix_p, transport_env%template_matrix_nosym, error=error) + CALL convert_csr_interop_to_dbcsr(p_mat, transport_env%p_matrix, transport_env%template_matrix_nosym) + CALL cp_dbcsr_copy(matrix_p, transport_env%template_matrix_nosym) CALL timestop(handle) @@ -316,15 +307,13 @@ END SUBROUTINE external_scf_method !> \param[in] dbcsr_mat DBCSR matrix to be converted !> \param[inout] csr_mat auxiliary CSR matrix !> \param[inout] csr_interop_mat C-interoperable CSR matrix -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE convert_dbcsr_to_csr_interop(dbcsr_mat, csr_mat, csr_interop_mat, error) + SUBROUTINE convert_dbcsr_to_csr_interop(dbcsr_mat, csr_mat, csr_interop_mat) TYPE(cp_dbcsr_type), INTENT(IN) :: dbcsr_mat TYPE(csr_type), INTENT(INOUT) :: csr_mat TYPE(cp2k_csr_interop_type), INTENT(INOUT) :: csr_interop_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_dbcsr_to_csr_interop', & routineP = moduleN//':'//routineN @@ -338,13 +327,13 @@ SUBROUTINE convert_dbcsr_to_csr_interop(dbcsr_mat, csr_mat, csr_interop_mat, err CALL timeset(routineN,handle) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() mp_group = logger%para_env%group mepos = logger%para_env%mepos num_pe = logger%para_env%num_pe ! dbcsr to csr - CALL cp_convert_dbcsr_to_csr(dbcsr_mat, csr_mat, error=error) + CALL cp_convert_dbcsr_to_csr(dbcsr_mat, csr_mat) ! csr to csr_interop rowptr_local => csr_mat%rowptr_local @@ -392,7 +381,7 @@ SUBROUTINE convert_dbcsr_to_csr_interop(dbcsr_mat, csr_mat, csr_interop_mat, err ! overflow in nze CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,CPSourceFileRef,& - error, failure) + failure) ENDIF csr_interop_mat%nze_total = INT(csr_mat%nze_total,KIND=KIND(csr_interop_mat%nze_total)) csr_interop_mat%nrows_local = csr_mat%nrows_local @@ -426,15 +415,13 @@ END SUBROUTINE convert_dbcsr_to_csr_interop !> \param[in] csr_interop_mat C-interoperable CSR matrix !> \param[inout] csr_mat auxiliary CSR matrix !> \param[inout] dbcsr_mat DBCSR matrix -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE convert_csr_interop_to_dbcsr(csr_interop_mat, csr_mat, dbcsr_mat, error) + SUBROUTINE convert_csr_interop_to_dbcsr(csr_interop_mat, csr_mat, dbcsr_mat) TYPE(cp2k_csr_interop_type), INTENT(IN) :: csr_interop_mat TYPE(csr_type), INTENT(INOUT) :: csr_mat TYPE(cp_dbcsr_type), INTENT(INOUT) :: dbcsr_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_csr_interop_to_dbcsr', & routineP = moduleN//':'//routineN @@ -454,8 +441,7 @@ SUBROUTINE convert_csr_interop_to_dbcsr(csr_interop_mat, csr_mat, dbcsr_mat, err nrows_total = nrows_total, ncols_total = ncols_total, nze_local = nze_local, & nze_total = nze_total, nrows_local = nrows_local, data_type = data_type,& rowptr_local = rowptr_local, colind_local = colind_local, & - nzerow_local = nzerow_local, nzvals_local = nzvals_local, & - error=error) + nzerow_local = nzerow_local, nzvals_local = nzvals_local) csr_mat%nrows_total = nrows_total csr_mat%ncols_total = ncols_total @@ -470,7 +456,7 @@ SUBROUTINE convert_csr_interop_to_dbcsr(csr_interop_mat, csr_mat, dbcsr_mat, err csr_mat%nzval_local%r_dp = nzvals_local ! csr to dbcsr - CALL cp_convert_csr_to_dbcsr(dbcsr_mat, csr_mat, error=error) + CALL cp_convert_csr_to_dbcsr(dbcsr_mat, csr_mat) CALL timestop(handle) diff --git a/src/transport_env_types.F b/src/transport_env_types.F index 24eb8096b7..d64afcc9ce 100644 --- a/src/transport_env_types.F +++ b/src/transport_env_types.F @@ -102,12 +102,10 @@ MODULE transport_env_types ! ***************************************************************************** !> \brief releases the transport_env !> \param[inout] transport_env the transport_env to be released -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE transport_env_release(transport_env,error) + SUBROUTINE transport_env_release(transport_env) TYPE(transport_env_type), POINTER :: transport_env - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'transport_env_release', & routineP = moduleN//':'//routineN @@ -118,18 +116,18 @@ SUBROUTINE transport_env_release(transport_env,error) CALL timeset(routineN,handle) failure=.FALSE. - CPPostcondition(ASSOCIATED(transport_env),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(transport_env),cp_failure_level,routineP,failure) - CALL cp_csr_destroy(transport_env%s_matrix, error) - CALL cp_csr_destroy(transport_env%ks_matrix, error) - CALL cp_csr_destroy(transport_env%p_matrix, error) - CALL cp_dbcsr_release(transport_env%template_matrix_sym, error) - CALL cp_dbcsr_release(transport_env%template_matrix_nosym, error) + CALL cp_csr_destroy(transport_env%s_matrix) + CALL cp_csr_destroy(transport_env%ks_matrix) + CALL cp_csr_destroy(transport_env%p_matrix) + CALL cp_dbcsr_release(transport_env%template_matrix_sym) + CALL cp_dbcsr_release(transport_env%template_matrix_nosym) transport_env%ext_c_method_ptr = C_NULL_FUNPTR DEALLOCATE(transport_env, stat=istat) - CPPostcondition(istat==0, cp_failure_level, routineP, error, failure) + CPPostcondition(istat==0, cp_failure_level, routineP,failure) CALL timestop(handle) @@ -138,14 +136,12 @@ END SUBROUTINE transport_env_release ! ***************************************************************************** !> \brief nullifies (and zeroizes) a C-interoperable CSR matrix !> \param[inout] csr_interop_mat the matrix to be nullified -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** - SUBROUTINE csr_interop_nullify(csr_interop_mat, error) + SUBROUTINE csr_interop_nullify(csr_interop_mat) TYPE(cp2k_csr_interop_type), & INTENT(INOUT) :: csr_interop_mat - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_interop_nullify', & routineP = moduleN//':'//routineN @@ -184,12 +180,11 @@ END SUBROUTINE csr_interop_nullify !> \param[out] colind_local column index (local - Fortran indexing) !> \param[out] nzerow_local number of nunzeros per row (index-i, local - Fortran indexing) !> \param[out] nzvals_local nonzero elements (local) -!> \param[inout] error CP2K error !> \author Mohammad Hossein Bani-Hashemian ! ***************************************************************************** SUBROUTINE csr_interop_matrix_get_info(csr_interop_mat, & nrows_total, ncols_total, nze_local, nze_total, nrows_local, data_type, & - first_row, rowptr_local, colind_local, nzerow_local, nzvals_local, error) + first_row, rowptr_local, colind_local, nzerow_local, nzvals_local) TYPE(cp2k_csr_interop_type), INTENT(IN) :: csr_interop_mat INTEGER, INTENT(OUT), OPTIONAL :: nrows_total, ncols_total, & @@ -201,7 +196,6 @@ SUBROUTINE csr_interop_matrix_get_info(csr_interop_mat, & nzerow_local REAL(dp), DIMENSION(:), INTENT(OUT), & OPTIONAL, POINTER :: nzvals_local - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_interop_matrix_get_info', & routineP = moduleN//':'//routineN diff --git a/src/virial_methods.F b/src/virial_methods.F index 04883fffaf..d5b09bf317 100644 --- a/src/virial_methods.F +++ b/src/virial_methods.F @@ -38,16 +38,14 @@ MODULE virial_methods !> \param virial ... !> \param subsys ... !> \param para_env ... -!> \param error ... !> \par History !> none !> \author Teodoro Laino [tlaino] - 03.2008 - Zurich University ! ***************************************************************************** - SUBROUTINE virial_update(virial, subsys, para_env, error) + SUBROUTINE virial_update(virial, subsys, para_env) TYPE(virial_type), INTENT(INOUT) :: virial TYPE(cp_subsys_type), POINTER :: subsys TYPE(cp_para_env_type), POINTER :: para_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'virial_update', & routineP = moduleN//':'//routineN @@ -57,10 +55,10 @@ SUBROUTINE virial_update(virial, subsys, para_env, error) TYPE(particle_list_type), POINTER :: particles CALL cp_subsys_get(subsys, local_particles=local_particles, atomic_kinds=atomic_kinds,& - particles=particles, error=error) + particles=particles) CALL virial_evaluate(atomic_kinds%els, particles%els, local_particles,& - virial, para_env%group, error) + virial, para_env%group) END SUBROUTINE virial_update @@ -72,13 +70,12 @@ END SUBROUTINE virial_update !> \param local_particles ... !> \param virial ... !> \param igroup ... -!> \param error ... !> \par History !> none !> \author CJM ! ***************************************************************************** SUBROUTINE virial_evaluate ( atomic_kind_set, particle_set, local_particles,& - virial, igroup, error) + virial, igroup) TYPE(atomic_kind_type), DIMENSION(:), & POINTER :: atomic_kind_set @@ -87,7 +84,6 @@ SUBROUTINE virial_evaluate ( atomic_kind_set, particle_set, local_particles,& TYPE(distribution_1d_type), POINTER :: local_particles TYPE(virial_type), INTENT(INOUT) :: virial INTEGER, INTENT(IN) :: igroup - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'virial_evaluate', & routineP = moduleN//':'//routineN @@ -139,17 +135,15 @@ END SUBROUTINE virial_evaluate !> \param f0 ... !> \param force ... !> \param rab ... -!> \param error ... !> \par History !> none !> \author JGH ! ***************************************************************************** - SUBROUTINE virial_pair_force ( pv_virial, f0, force, rab, error) + SUBROUTINE virial_pair_force ( pv_virial, f0, force, rab) REAL(KIND=dp), DIMENSION(3, 3) :: pv_virial REAL(KIND=dp) :: f0 REAL(KIND=dp), DIMENSION(3) :: force, rab - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'virial_pair_force', & routineP = moduleN//':'//routineN diff --git a/src/wannier_states.F b/src/wannier_states.F index 8dac20be91..e8fb87c005 100644 --- a/src/wannier_states.F +++ b/src/wannier_states.F @@ -62,10 +62,9 @@ MODULE wannier_states !> \param WannierCentres ... !> \param ns ... !> \param states ... -!> \param error ... ! ***************************************************************************** SUBROUTINE construct_wannier_states(mo_localized, & - Hks, qs_env,loc_print_section,WannierCentres,ns,states,error) + Hks, qs_env,loc_print_section,WannierCentres,ns,states) TYPE(cp_fm_type), INTENT(in), POINTER :: mo_localized TYPE(cp_dbcsr_type), POINTER :: Hks @@ -75,7 +74,6 @@ SUBROUTINE construct_wannier_states(mo_localized, & INTENT(INOUT) :: WannierCentres INTEGER, INTENT(IN) :: ns INTEGER, INTENT(IN), POINTER :: states(:) - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'construct_wannier_states', & routineP = moduleN//':'//routineN @@ -100,57 +98,57 @@ SUBROUTINE construct_wannier_states(mo_localized, & NULLIFY(logger, para_env) failure = .FALSE. - CALL get_qs_env(qs_env, para_env=para_env, error=error) + CALL get_qs_env(qs_env, para_env=para_env) nproc = para_env%num_pe - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_logger_get_default_io_unit(logger) CALL cp_fm_get_info(mo_localized, & ncol_global=ncol_global, & - nrow_global=nrow_global ,error=error) + nrow_global=nrow_global) nstates(1)= ns nstates(2) = para_env%mepos iproc=nstates(2) NULLIFY(b,c,d,fm_struct_tmp,print_key) - print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_CENTERS",error=error) - CALL section_vals_val_get(print_key,"UNIT",c_val=unit_str,error=error) - unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str),error=error) + print_key => section_vals_get_subs_vals(loc_print_section,"WANNIER_CENTERS") + CALL section_vals_val_get(print_key,"UNIT",c_val=unit_str) + unit_conv = cp_unit_from_cp2k(1.0_dp,TRIM(unit_str)) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nrow_global, & ncol_global=1, & para_env=mo_localized%matrix_struct%para_env, & - context=mo_localized%matrix_struct%context,error=error) + context=mo_localized%matrix_struct%context) - CALL cp_fm_create(b,fm_struct_tmp, name="b",error=error) - CALL cp_fm_create(c,fm_struct_tmp, name="c",error=error) + CALL cp_fm_create(b,fm_struct_tmp, name="b") + CALL cp_fm_create(c,fm_struct_tmp, name="c") - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_struct_release(fm_struct_tmp) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=1, ncol_global=1, & para_env=mo_localized%matrix_struct%para_env, & - context=mo_localized%matrix_struct%context,error=error) + context=mo_localized%matrix_struct%context) - CALL cp_fm_create(d,fm_struct_tmp, name="d",error=error) - CALL cp_fm_struct_release(fm_struct_tmp,error=error) + CALL cp_fm_create(d,fm_struct_tmp, name="d") + CALL cp_fm_struct_release(fm_struct_tmp) WannierCentres%WannierHamDiag=0.0_dp ! try to print the matrix unit_mat=cp_print_key_unit_nr(logger,loc_print_section,& "WANNIER_STATES",extension=".whks",& - ignore_should_output=.FALSE.,error=error) + ignore_should_output=.FALSE.) IF (unit_mat > 0) THEN WRITE(unit_mat,'(a16,1(i0,1x))')"Wannier states: ",ns WRITE(unit_mat,'(a16)')"#No x y z energy " ENDIF DO i=1,ns CALL cp_fm_to_fm ( mo_localized, b, 1, states ( i ), 1) - CALL cp_dbcsr_sm_fm_multiply(Hks,b,c,1,error=error) + CALL cp_dbcsr_sm_fm_multiply(Hks,b,c,1) CALL cp_gemm('T','N',1,1,nrow_global,1.0_dp, & - b,c,0.0_dp,d,error=error) + b,c,0.0_dp,d) CALL cp_fm_get_element(d,1,1,WannierCentres%WannierHamDiag(i)) ! if (iproc==para_env%mepos) WRITE(unit_mat,'(f16.8,2x)', advance='no')WannierCentres%WannierHamDiag(i) IF (unit_mat > 0)WRITE(unit_mat,'(i0,1x,4(f16.8,2x))')states(i),& @@ -159,7 +157,7 @@ SUBROUTINE construct_wannier_states(mo_localized, & IF (unit_mat > 0) WRITE(unit_mat,*) CALL cp_print_key_finished_output(unit_mat,logger,loc_print_section,& - "WANNIER_STATES",error=error) + "WANNIER_STATES") IF (output_unit>0) THEN WRITE(output_unit,*)"" WRITE(output_unit,*)"NUMBER OF Wannier STATES ", ns @@ -168,9 +166,9 @@ SUBROUTINE construct_wannier_states(mo_localized, & WRITE(output_unit,'(f16.8,2x,i0)')WannierCentres%WannierHamDiag(i),states(i) ENDDO ENDIF - CALL cp_fm_release ( b ,error=error) - CALL cp_fm_release ( c ,error=error) - CALL cp_fm_release ( d ,error=error) + CALL cp_fm_release ( b) + CALL cp_fm_release ( c) + CALL cp_fm_release ( d) CALL timestop(handle) END SUBROUTINE construct_wannier_states diff --git a/src/xas_control.F b/src/xas_control.F index a40bb3749e..1cdcc6a801 100644 --- a/src/xas_control.F +++ b/src/xas_control.F @@ -72,15 +72,13 @@ MODULE xas_control !> \param xas_control control variables !> error !> \param xas_section ... -!> \param error ... !> \par History !> 04.2005 created [MI] ! ***************************************************************************** - SUBROUTINE read_xas_control(xas_control,xas_section,error) + SUBROUTINE read_xas_control(xas_control,xas_section) TYPE(xas_control_type) :: xas_control TYPE(section_vals_type), POINTER :: xas_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'read_xas_control', & routineP = moduleN//':'//routineN @@ -96,31 +94,31 @@ SUBROUTINE read_xas_control(xas_control,xas_section,error) NULLIFY(list) CALL section_vals_val_get(xas_section,"METHOD",& - i_val=xas_control%xas_method,error=error) + i_val=xas_control%xas_method) CALL section_vals_val_get(xas_section,"DIPOLE_FORM",& - i_val=xas_control%dipole_form,error=error) + i_val=xas_control%dipole_form) CALL section_vals_val_get(xas_section,"RESTART",& - l_val=xas_control%xas_restart,error=error) + l_val=xas_control%xas_restart) CALL section_vals_val_get(xas_section,"STATE_TYPE",& - i_val=xas_control%state_type,error=error) + i_val=xas_control%state_type) CALL section_vals_val_get(xas_section,"STATE_SEARCH",& - i_val=xas_control%nexc_search,error=error) + i_val=xas_control%nexc_search) CALL section_vals_val_get(xas_section,"XAS_CORE", & - r_val=xas_control%xas_core_occupation,error=error) + r_val=xas_control%xas_core_occupation) CALL section_vals_val_get(xas_section,"XAS_TOT_EL", & - r_val=xas_control%nel_tot,error=error) + r_val=xas_control%nel_tot) CALL section_vals_val_get(xas_section,"XES_CORE", & - r_val=xas_control%xes_core_occupation,error=error) + r_val=xas_control%xes_core_occupation) CALL section_vals_val_get(xas_section,"XES_EMPTY_HOMO", & - l_val=hempty,error=error) + l_val=hempty) IF(hempty) THEN xas_control%xes_homo_occupation = 0 ELSE @@ -130,14 +128,14 @@ SUBROUTINE read_xas_control(xas_control,xas_section,error) ! It should be further generalized IF(.NOT. ASSOCIATED(xas_control%exc_atoms)) THEN CALL section_vals_val_get(xas_section,"ATOMS_LIST",& - n_rep_val=n_rep, error=error) + n_rep_val=n_rep) IF(n_rep > 0) THEN nex_at = 0 DO ir = 1,n_rep NULLIFY(list) CALL section_vals_val_get(xas_section,"ATOMS_LIST",& - i_rep_val=ir,i_vals=list,error=error) + i_rep_val=ir,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(xas_control%exc_atoms,1,nex_at+SIZE(list)) @@ -154,21 +152,21 @@ SUBROUTINE read_xas_control(xas_control,xas_section,error) IF(.NOT. ASSOCIATED(xas_control%exc_atoms)) THEN xas_control%nexc_atoms = 1 ALLOCATE(xas_control%exc_atoms(1),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) xas_control%exc_atoms(1) = 1 END IF CALL section_vals_val_get(xas_section,"ADDED_MOS",& - i_val=xas_control%added_mos,error=error) + i_val=xas_control%added_mos) CALL section_vals_val_get(xas_section,"MAX_ITER_ADDED",& - i_val=xas_control%max_iter_added,error=error) + i_val=xas_control%max_iter_added) CALL section_vals_val_get(xas_section,"EPS_ADDED", & - r_val=xas_control%eps_added,error=error) + r_val=xas_control%eps_added) CALL section_vals_val_get(xas_section,"NGAUSS",& - i_val=xas_control%ngauss,error=error) + i_val=xas_control%ngauss) END SUBROUTINE read_xas_control @@ -178,15 +176,13 @@ END SUBROUTINE read_xas_control !> \param xas_control control variables !> error !> \param dft_section ... -!> \param error ... !> \par History !> 12.2005 created [MI] ! ***************************************************************************** - SUBROUTINE write_xas_control(xas_control,dft_section, error) + SUBROUTINE write_xas_control(xas_control,dft_section) TYPE(xas_control_type) :: xas_control TYPE(section_vals_type), POINTER :: dft_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'write_xas_control', & routineP = moduleN//':'//routineN @@ -195,9 +191,9 @@ SUBROUTINE write_xas_control(xas_control,dft_section, error) LOGICAL :: failure TYPE(cp_logger_type), POINTER :: logger - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log",error=error) + "PRINT%DFT_CONTROL_PARAMETERS",extension=".Log") IF (output_unit>0) THEN SELECT CASE(xas_control%xas_method) CASE(xas_tp_hh) @@ -231,7 +227,7 @@ SUBROUTINE write_xas_control(xas_control,dft_section, error) CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown xas method "//TRIM(ADJUSTL(cp_to_string(xas_control%xas_method))),& - error,failure) + failure) END SELECT IF(xas_control%xas_restart) THEN WRITE (UNIT=output_unit,FMT="(/,T2,A,T30,A)")& @@ -239,7 +235,7 @@ SUBROUTINE write_xas_control(xas_control,dft_section, error) END IF END IF CALL cp_print_key_finished_output(output_unit,logger,dft_section,& - "PRINT%DFT_CONTROL_PARAMETERS",error=error) + "PRINT%DFT_CONTROL_PARAMETERS") END SUBROUTINE write_xas_control !****f* xas_control/xas_control_create/retain/release * @@ -247,14 +243,12 @@ END SUBROUTINE write_xas_control ! ***************************************************************************** !> \brief create retain release the xas_control_type !> \param xas_control ... -!> \param error ... !> \par History !> 04.2005 created [MI] ! ***************************************************************************** - SUBROUTINE xas_control_create(xas_control,error) + SUBROUTINE xas_control_create(xas_control) TYPE(xas_control_type), POINTER :: xas_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_control_create', & routineP = moduleN//':'//routineN @@ -264,9 +258,9 @@ SUBROUTINE xas_control_create(xas_control,error) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(xas_control),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(xas_control),cp_failure_level,routineP,failure) ALLOCATE(xas_control,stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) xas_control%ref_count= 1 xas_control%xas_method = xas_tp_hh @@ -287,12 +281,10 @@ END SUBROUTINE xas_control_create ! ***************************************************************************** !> \brief ... !> \param xas_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xas_control_release(xas_control,error) + SUBROUTINE xas_control_release(xas_control) TYPE(xas_control_type), POINTER :: xas_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_control_release', & routineP = moduleN//':'//routineN @@ -302,19 +294,19 @@ SUBROUTINE xas_control_release(xas_control,error) failure=.FALSE. IF(ASSOCIATED(xas_control)) THEN - CPPrecondition(xas_control%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(xas_control%ref_count>0,cp_failure_level,routineP,failure) xas_control%ref_count=xas_control%ref_count-1 IF (xas_control%ref_count==0) THEN IF (ASSOCIATED(xas_control%exc_atoms)) THEN DEALLOCATE(xas_control%exc_atoms,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(xas_control%list_cubes)) THEN DEALLOCATE(xas_control%list_cubes,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(xas_control,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF END IF @@ -323,12 +315,10 @@ END SUBROUTINE xas_control_release ! ***************************************************************************** !> \brief ... !> \param xas_control ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xas_control_retain(xas_control,error) + SUBROUTINE xas_control_retain(xas_control) TYPE(xas_control_type), POINTER :: xas_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_control_retain', & routineP = moduleN//':'//routineN @@ -337,7 +327,7 @@ SUBROUTINE xas_control_retain(xas_control,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(xas_control),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_control),cp_failure_level,routineP,failure) xas_control%ref_count=xas_control%ref_count+1 END SUBROUTINE xas_control_retain diff --git a/src/xas_env_types.F b/src/xas_env_types.F index 913be4953e..8e93363750 100644 --- a/src/xas_env_types.F +++ b/src/xas_env_types.F @@ -145,7 +145,6 @@ MODULE xas_env_types !> \param nexc_search ... !> \param scf_env ... !> \param scf_control ... -!> \param error ... ! ***************************************************************************** SUBROUTINE get_xas_env(xas_env,iter_count,exc_state,nao,nvirtual,nvirtual2,& centers_wfn,atom_of_state, exc_atoms, type_of_state,mykind_of_atom,mykind_of_kind,& @@ -153,7 +152,7 @@ SUBROUTINE get_xas_env(xas_env,iter_count,exc_state,nao,nvirtual,nvirtual2,& dip_fm_set,excvec_coeff,excvec_overlap,fm_work,& unoccupied_orbs, unoccupied_evals,unoccupied_max_iter,unoccupied_eps,& all_vectors,all_evals, my_gto_basis,qs_loc_env,& - stogto_overlap,occ_estate,xas_nelectron,xas_estate,nexc_atoms,nexc_search,scf_env,scf_control,error) + stogto_overlap,occ_estate,xas_nelectron,xas_estate,nexc_atoms,nexc_search,scf_env,scf_control) TYPE(xas_environment_type), POINTER :: xas_env INTEGER, INTENT(OUT), OPTIONAL :: iter_count, exc_state, nao, & @@ -191,7 +190,6 @@ SUBROUTINE get_xas_env(xas_env,iter_count,exc_state,nao,nvirtual,nvirtual2,& TYPE(qs_scf_env_type), OPTIONAL, POINTER :: scf_env TYPE(scf_control_type), OPTIONAL, & POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'get_xas_env', & routineP = moduleN//':'//routineN @@ -199,7 +197,7 @@ SUBROUTINE get_xas_env(xas_env,iter_count,exc_state,nao,nvirtual,nvirtual2,& LOGICAL :: failure failure =.FALSE. - CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,failure) IF(PRESENT(iter_count)) iter_count=xas_env%iter_count @@ -255,11 +253,10 @@ END SUBROUTINE get_xas_env !> \param homo_occ ... !> \param scf_env ... !> \param scf_control ... -!> \param error ... ! ***************************************************************************** SUBROUTINE set_xas_env(xas_env,iter_count,nexc_search,nexc_atoms,& nvirtual,nvirtual2, ip_energy, occ_estate, qs_loc_env,& - xas_estate, xas_nelectron, homo_occ, scf_env, scf_control,error) + xas_estate, xas_nelectron, homo_occ, scf_env, scf_control) TYPE(xas_environment_type), POINTER :: xas_env INTEGER, INTENT(IN), OPTIONAL :: iter_count, nexc_search, & @@ -273,7 +270,6 @@ SUBROUTINE set_xas_env(xas_env,iter_count,nexc_search,nexc_atoms,& TYPE(qs_scf_env_type), OPTIONAL, POINTER :: scf_env TYPE(scf_control_type), OPTIONAL, & POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'set_xas_env', & routineP = moduleN//':'//routineN @@ -282,7 +278,7 @@ SUBROUTINE set_xas_env(xas_env,iter_count,nexc_search,nexc_atoms,& failure =.FALSE. - CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,failure) IF (PRESENT(iter_count)) xas_env%iter_count = iter_count @@ -296,19 +292,19 @@ SUBROUTINE set_xas_env(xas_env,iter_count,nexc_search,nexc_atoms,& IF (PRESENT(xas_estate)) xas_env%xas_estate = xas_estate IF (PRESENT(ip_energy)) xas_env%ip_energy = ip_energy IF (PRESENT(qs_loc_env)) THEN - CALL qs_loc_env_retain(qs_loc_env, error=error) + CALL qs_loc_env_retain(qs_loc_env) IF(ASSOCIATED(xas_env%qs_loc_env)) & - CALL qs_loc_env_release(xas_env%qs_loc_env,error=error) + CALL qs_loc_env_release(xas_env%qs_loc_env) xas_env%qs_loc_env => qs_loc_env END IF IF (PRESENT(scf_env)) THEN ! accept also null pointers ? - CALL scf_env_retain(scf_env,error=error) - CALL scf_env_release(xas_env%scf_env, error=error) + CALL scf_env_retain(scf_env) + CALL scf_env_release(xas_env%scf_env) xas_env%scf_env => scf_env END IF IF (PRESENT(scf_control)) THEN ! accept also null pointers? - CALL scf_c_retain(scf_control,error=error) - CALL scf_c_release(xas_env%scf_control,error=error) + CALL scf_c_retain(scf_control) + CALL scf_c_release(xas_env%scf_control) xas_env%scf_control => scf_control END IF @@ -318,12 +314,10 @@ END SUBROUTINE set_xas_env ! ***************************************************************************** !> \brief ... !> \param xas_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xas_env_create(xas_env, error) + SUBROUTINE xas_env_create(xas_env) TYPE(xas_environment_type), POINTER :: xas_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_env_create', & routineP = moduleN//':'//routineN @@ -333,7 +327,7 @@ SUBROUTINE xas_env_create(xas_env, error) failure=.FALSE. ALLOCATE(xas_env,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) xas_env%ref_count=1 @@ -362,12 +356,10 @@ END SUBROUTINE xas_env_create ! ***************************************************************************** !> \brief ... !> \param xas_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xas_env_release(xas_env, error) + SUBROUTINE xas_env_release(xas_env) TYPE(xas_environment_type), POINTER :: xas_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_env_release', & routineP = moduleN//':'//routineN @@ -378,80 +370,80 @@ SUBROUTINE xas_env_release(xas_env, error) failure=.FALSE. IF (ASSOCIATED(xas_env)) THEN - CPPreconditionNoFail(xas_env%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(xas_env%ref_count>0,cp_failure_level,routineP) xas_env%ref_count = xas_env%ref_count -1 IF (xas_env%ref_count==0) THEN DEALLOCATE(xas_env%state_of_atom,xas_env%atom_of_state,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) DEALLOCATE(xas_env%type_of_state,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) DEALLOCATE(xas_env%mykind_of_atom,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(xas_env%mykind_of_kind,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(xas_env%exc_atoms,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) DEALLOCATE(xas_env%centers_wfn,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) IF(ASSOCIATED(xas_env%all_evals)) THEN DEALLOCATE(xas_env%all_evals,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF IF(ASSOCIATED(xas_env%unoccupied_evals)) THEN DEALLOCATE(xas_env%unoccupied_evals,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF IF(ASSOCIATED(xas_env%groundstate_coeff)) THEN DO i = 1,SIZE(xas_env%groundstate_coeff) CALL fm_pool_give_back_fm(xas_env%ao_mo_fm_pools(i)%pool,& - xas_env%groundstate_coeff(i)%matrix, error=error) + xas_env%groundstate_coeff(i)%matrix) END DO DEALLOCATE(xas_env%groundstate_coeff,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF IF(ASSOCIATED(xas_env%dip_fm_set)) THEN DO i = 1,SIZE(xas_env%dip_fm_set,2) DO j = 1,SIZE(xas_env%dip_fm_set,1) - CALL cp_fm_release(xas_env%dip_fm_set(j,i)%matrix, error=error) + CALL cp_fm_release(xas_env%dip_fm_set(j,i)%matrix) END DO END DO DEALLOCATE(xas_env%dip_fm_set,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF IF(ASSOCIATED(xas_env%excvec_coeff)) THEN - CALL cp_fm_release(xas_env%excvec_coeff,error=error) + CALL cp_fm_release(xas_env%excvec_coeff) END IF IF(ASSOCIATED(xas_env%excvec_overlap)) THEN - CALL cp_fm_release(xas_env%excvec_overlap,error=error) + CALL cp_fm_release(xas_env%excvec_overlap) END IF IF(ASSOCIATED(xas_env%unoccupied_orbs)) THEN - CALL cp_fm_release(xas_env%unoccupied_orbs,error=error) + CALL cp_fm_release(xas_env%unoccupied_orbs) END IF IF(ASSOCIATED(xas_env%fm_work)) THEN - CALL cp_fm_release(xas_env%fm_work,error=error) + CALL cp_fm_release(xas_env%fm_work) END IF NULLIFY(xas_env%ao_mo_fm_pools) IF(ASSOCIATED(xas_env%all_vectors).AND.xas_env%nvirtual .GT. 0) THEN - CALL cp_fm_release(xas_env%all_vectors,error=error) + CALL cp_fm_release(xas_env%all_vectors) ELSE NULLIFY(xas_env%all_vectors) END IF IF(ASSOCIATED(xas_env%ostrength_sm)) THEN - CALL cp_dbcsr_deallocate_matrix_set(xas_env%ostrength_sm,error=error) + CALL cp_dbcsr_deallocate_matrix_set(xas_env%ostrength_sm) END IF IF(ASSOCIATED(xas_env%qs_loc_env)) THEN - CALL qs_loc_env_release(xas_env%qs_loc_env, error=error) + CALL qs_loc_env_release(xas_env%qs_loc_env) END IF IF(ASSOCIATED(xas_env%my_gto_basis)) THEN DO ik = 1,SIZE(xas_env%my_gto_basis,1) - CALL deallocate_gto_basis_set(xas_env%my_gto_basis(ik)%gto_basis_set,error) + CALL deallocate_gto_basis_set(xas_env%my_gto_basis(ik)%gto_basis_set) END DO DEALLOCATE(xas_env%my_gto_basis,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF IF(ASSOCIATED(xas_env%stogto_overlap)) THEN @@ -459,15 +451,15 @@ SUBROUTINE xas_env_release(xas_env, error) DEALLOCATE(xas_env%stogto_overlap(ik)%array) END DO DEALLOCATE(xas_env%stogto_overlap,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) END IF - CALL scf_env_release(xas_env%scf_env, error=error) - CALL scf_c_release(xas_env%scf_control, error=error) + CALL scf_env_release(xas_env%scf_env) + CALL scf_c_release(xas_env%scf_control) DEALLOCATE(xas_env,STAT=istat) - CPPostcondition(istat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(istat==0,cp_warning_level,routineP,failure) NULLIFY(xas_env) END IF END IF @@ -477,12 +469,10 @@ END SUBROUTINE xas_env_release ! ***************************************************************************** !> \brief ... !> \param xas_env ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xas_env_retain(xas_env, error) + SUBROUTINE xas_env_retain(xas_env) TYPE(xas_environment_type), POINTER :: xas_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_env_retain', & routineP = moduleN//':'//routineN @@ -491,8 +481,8 @@ SUBROUTINE xas_env_retain(xas_env, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,error,failure) - CPPrecondition(xas_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,failure) + CPPrecondition(xas_env%ref_count>0,cp_failure_level,routineP,failure) xas_env%ref_count=xas_env%ref_count+1 END SUBROUTINE xas_env_retain diff --git a/src/xas_methods.F b/src/xas_methods.F index 6db4f467c7..617011aabf 100644 --- a/src/xas_methods.F +++ b/src/xas_methods.F @@ -140,8 +140,6 @@ MODULE xas_methods !> to evaluate the spectral energies and oscillator strengths !> \param qs_env the qs_env, the xas_env lives in !> \param dft_control ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2005 created [MI] !> \author MI @@ -153,11 +151,10 @@ MODULE xas_methods !> The number of states to be localized is xas_control%nexc_search !> In general only the core states are needed ! ***************************************************************************** - SUBROUTINE xas(qs_env, dft_control, error) + SUBROUTINE xas(qs_env, dft_control) TYPE(qs_environment_type), POINTER :: qs_env TYPE(dft_control_type), POINTER :: dft_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xas', & routineP = moduleN//':'//routineN @@ -210,7 +207,7 @@ SUBROUTINE xas(qs_env, dft_control, error) ch_method_flags = .FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) NULLIFY(xas_env, groundstate_coeff, ostrength_sm, op_sm) @@ -219,14 +216,14 @@ SUBROUTINE xas(qs_env, dft_control, error) NULLIFY(all_vectors,state_of_atom,xas_control) NULLIFY(vecbuffer,op_sm,mo_coeff_b) NULLIFY(dft_section, xas_section,scf_section , loc_section, print_loc_section) - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) - xas_section => section_vals_get_subs_vals(dft_section,"XAS",error=error) - scf_section => section_vals_get_subs_vals(xas_section,"SCF",error=error) - loc_section => section_vals_get_subs_vals(xas_section,"LOCALIZE",error=error) - print_loc_section => section_vals_get_subs_vals(loc_section,"PRINT",error=error) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") + xas_section => section_vals_get_subs_vals(dft_section,"XAS") + scf_section => section_vals_get_subs_vals(xas_section,"SCF") + loc_section => section_vals_get_subs_vals(xas_section,"LOCALIZE") + print_loc_section => section_vals_get_subs_vals(loc_section,"PRINT") output_unit = cp_print_key_unit_nr(logger,xas_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".Log",error=error) + extension=".Log") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T3,A,/,T25,A,/,T3,A,/)")& REPEAT("=",77),& @@ -235,18 +232,18 @@ SUBROUTINE xas(qs_env, dft_control, error) END IF ! Create the xas environment - CALL get_qs_env(qs_env,xas_env=xas_env,error=error) + CALL get_qs_env(qs_env,xas_env=xas_env) IF (.NOT.ASSOCIATED(xas_env)) THEN IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T5,A)")& "Create and initialize the xas environment" END IF - CALL xas_env_create(xas_env, error=error) - CALL xas_env_init(xas_env, qs_env, dft_section, logger, error=error) + CALL xas_env_create(xas_env) + CALL xas_env_init(xas_env, qs_env, dft_section, logger) xas_control => dft_control%xas_control - CALL set_qs_env(qs_env,xas_env=xas_env, error=error) - CALL xas_env_release(xas_env,error=error) - CALL get_qs_env(qs_env,xas_env=xas_env,error=error) + CALL set_qs_env(qs_env,xas_env=xas_env) + CALL xas_env_release(xas_env) + CALL get_qs_env(qs_env,xas_env=xas_env) END IF ! Initialize the type of calculation @@ -254,7 +251,7 @@ SUBROUTINE xas(qs_env, dft_control, error) CALL get_qs_env(qs_env=qs_env, atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set,& cell = cell, scf_control=scf_control,& matrix_ks=matrix_ks,mos=mos, para_env=para_env, & - particle_set=particle_set ,error=error) + particle_set=particle_set) ! The eigenstate of the KS Hamiltonian are nedeed NULLIFY(mo_coeff,eigenvalues) @@ -268,14 +265,14 @@ SUBROUTINE xas(qs_env, dft_control, error) eigenvalues=eigenvalues,homo=homo) CALL calculate_subspace_eigenvalues(mo_coeff,& matrix_ks(ispin)%matrix,eigenvalues, & - do_rotation=.TRUE.,error=error) + do_rotation=.TRUE.) END DO END IF ! In xas SCF we need to use the same number of MOS as for GS added_mos = scf_control%added_mos NULLIFY(scf_control) ! Consider to use get function for this - CALL get_xas_env(xas_env, scf_control=scf_control, error=error) + CALL get_xas_env(xas_env, scf_control=scf_control) scf_control%added_mos = added_mos ! Set initial occupation numbers, and store the original ones @@ -306,12 +303,12 @@ SUBROUTINE xas(qs_env, dft_control, error) CALL get_xas_env(xas_env=xas_env,& state_of_atom=state_of_atom,all_vectors=all_vectors,& groundstate_coeff=groundstate_coeff,excvec_coeff=excvec_coeff,& - nexc_atoms=nexc_atoms,occ_estate=occ_estate,xas_nelectron=xas_nelectron,error=error) + nexc_atoms=nexc_atoms,occ_estate=occ_estate,xas_nelectron=xas_nelectron) - CALL set_xas_env(xas_env=xas_env,nexc_search=nexc_search,error=error) + CALL set_xas_env(xas_env=xas_env,nexc_search=nexc_search) !Define the qs_loc_env : to find centers, spread and possibly localize them - CALL get_xas_env(xas_env=xas_env, qs_loc_env=qs_loc_env,error=error) + CALL get_xas_env(xas_env=xas_env, qs_loc_env=qs_loc_env) IF (qs_loc_env%do_localize) THEN IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T10,A,/)")& @@ -327,10 +324,10 @@ SUBROUTINE xas(qs_env, dft_control, error) END IF END IF - CALL qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin=1,error=error) + CALL qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin=1) END IF - CPPrecondition(ASSOCIATED(groundstate_coeff),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(groundstate_coeff),cp_failure_level,routineP,failure) DO ispin = 1,nspins CALL get_mo_set(mos(ispin)%mo_set, mo_coeff=mo_coeff, mo_coeff_b=mo_coeff_b, nmo=nmo) CALL cp_fm_to_fm(mo_coeff,groundstate_coeff(ispin)%matrix,nmo,1,1) @@ -357,9 +354,8 @@ SUBROUTINE xas(qs_env, dft_control, error) END IF skip_scf = .TRUE. - CALL set_xas_env(xas_env=xas_env,xas_estate=-1, homo_occ=xas_control%xes_homo_occupation, & - error=error) - CALL xes_scf_once(qs_env,xas_env,converged,should_stop,error=error) + CALL set_xas_env(xas_env=xas_env,xas_estate=-1, homo_occ=xas_control%xes_homo_occupation) + CALL xes_scf_once(qs_env,xas_env,converged,should_stop) IF(converged .AND. .NOT. should_stop .AND. xas_control%xes_homo_occupation == 0) THEN IF (output_unit>0) WRITE(UNIT=output_unit,FMT='(/,T10,A,I6)') & @@ -370,14 +366,14 @@ SUBROUTINE xas(qs_env, dft_control, error) ! Release what has to be released IF(ASSOCIATED(vecbuffer)) THEN DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(op_sm,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DO ispin = 1,dft_control%nspins CALL set_mo_set(mos(ispin)%mo_set, homo=my_homo(ispin),& - uniform_occupation=my_uocc(ispin), nelectron= my_nelectron(ispin), error=error) + uniform_occupation=my_uocc(ispin), nelectron= my_nelectron(ispin)) CALL get_mo_set(mos(ispin)%mo_set, mo_coeff=mo_coeff, nmo=nmo) CALL cp_fm_to_fm(groundstate_coeff(ispin)%matrix,mos(ispin)%mo_set%mo_coeff,nmo,1,1) END DO @@ -389,10 +385,10 @@ SUBROUTINE xas(qs_env, dft_control, error) REPEAT("=",77) END IF - CALL xas_env_release(qs_env%xas_env, error=error) + CALL xas_env_release(qs_env%xas_env) CALL cp_print_key_finished_output(output_unit,logger,xas_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) RETURN END IF @@ -401,7 +397,7 @@ SUBROUTINE xas(qs_env, dft_control, error) ! Assign the character of the selected core states ! through the overlap with atomic-like states CALL cls_assign_core_states(xas_control,xas_env,qs_loc_env%localized_wfn_control,& - qs_env,error=error) + qs_env) IF(skip_scf) THEN CALL get_mo_set(mos(1)%mo_set,mo_coeff=mo_coeff) @@ -410,21 +406,21 @@ SUBROUTINE xas(qs_env, dft_control, error) END IF ALLOCATE(vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (op_sm(3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! copy the coefficients of the mos in a temporary fm with the right structure IF(transition_potential) THEN ! Calculate the operator - CALL get_xas_env(xas_env=xas_env,ostrength_sm=ostrength_sm,error=error) + CALL get_xas_env(xas_env=xas_env,ostrength_sm=ostrength_sm) DO i = 1,3 NULLIFY(op_sm(i)%matrix) op_sm(i)%matrix => ostrength_sm(i)%matrix END DO IF(xas_control%dipole_form==xas_dip_vel) THEN - CALL p_xyz_ao(op_sm,qs_env,error=error) + CALL p_xyz_ao(op_sm,qs_env) END IF END IF @@ -436,10 +432,10 @@ SUBROUTINE xas(qs_env, dft_control, error) ! Take the state_to_be_excited vector from the full set and copy into excvec_coeff CALL get_mo_set(mos(1)%mo_set, nmo=nmo) - CALL get_xas_env(xas_env, occ_estate=occ_estate,xas_nelectron=xas_nelectron,error=error) + CALL get_xas_env(xas_env, occ_estate=occ_estate,xas_nelectron=xas_nelectron) tmp = xas_nelectron + 1.0_dp - occ_estate CALL cp_assert(nmo>=tmp,cp_failure_level,cp_assertion_failed,& - routineP,"CLS: the required method needs added_mos to the ground state",error,failure) + routineP,"CLS: the required method needs added_mos to the ground state",failure) ! If the restart file for this atom exists, the mos and the ! occupation numbers are overwritten ! It is necessary that the restart is for the same xas method @@ -447,16 +443,16 @@ SUBROUTINE xas(qs_env, dft_control, error) ! may not be consistent IF(xas_control%xas_restart) THEN CALL xas_read_restart(xas_env,xas_section, qs_env, xas_control%xas_method, iatom,& - state_to_be_excited,error=error) + state_to_be_excited) END IF - CALL set_xas_env(xas_env=xas_env,xas_estate=state_to_be_excited,error=error) + CALL set_xas_env(xas_env=xas_env,xas_estate=state_to_be_excited) CALL get_mo_set(mos(1)%mo_set, mo_coeff=mo_coeff) - CPPrecondition(ASSOCIATED(excvec_coeff),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(excvec_coeff),cp_failure_level,routineP,failure) CALL cp_fm_get_submatrix(mo_coeff,vecbuffer,1,state_to_be_excited,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) CALL cp_fm_set_submatrix(excvec_coeff,vecbuffer,1,1,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) IF (transition_potential) THEN @@ -476,38 +472,38 @@ SUBROUTINE xas(qs_env, dft_control, error) END IF END IF - CALL get_xas_env(xas_env=xas_env, scf_env=scf_env, error=error) + CALL get_xas_env(xas_env=xas_env, scf_env=scf_env) IF(.NOT. ASSOCIATED(scf_env)) THEN - CALL qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section,error=error) + CALL qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section) ! Moved here from qs_scf_env_initialize to be able to have more scf_env - CALL set_xas_env(xas_env,scf_env=scf_env,error=error) - CALL scf_env_release(scf_env,error=error) - CALL get_xas_env(xas_env=xas_env,scf_env=scf_env,error=error) + CALL set_xas_env(xas_env,scf_env=scf_env) + CALL scf_env_release(scf_env) + CALL get_xas_env(xas_env=xas_env,scf_env=scf_env) ELSE - CALL qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section,error=error) + CALL qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section) ENDIF DO ispin=1,SIZE(mos) IF(ASSOCIATED(mos(ispin)%mo_set%mo_coeff_b))THEN!fm->dbcsr CALL copy_fm_to_dbcsr(mos(ispin)%mo_set%mo_coeff,& - mos(ispin)%mo_set%mo_coeff_b,error=error)!fm->dbcsr + mos(ispin)%mo_set%mo_coeff_b)!fm->dbcsr ENDIF!fm->dbcsr ENDDO!fm->dbcsr IF(.NOT.scf_env%skip_diis) THEN IF (.NOT.ASSOCIATED(scf_env%scf_diis_buffer)) THEN - CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis,error=error) + CALL qs_diis_b_create(scf_env%scf_diis_buffer,nbuffer=scf_control%max_diis) END IF - CALL qs_diis_b_clear(scf_env%scf_diis_buffer,error=error) + CALL qs_diis_b_clear(scf_env%scf_diis_buffer) END IF CALL xas_do_tp_scf(dft_control,xas_env,iatom,scf_env,qs_env,& - xas_section,scf_section,converged,should_stop,error=error) + xas_section,scf_section,converged,should_stop) CALL external_control(should_stop,"CLS",target_time=qs_env%target_time,& - start_time=qs_env%start_time,error=error) + start_time=qs_env%start_time) IF(should_stop)THEN - CALL scf_env_cleanup(scf_env,error=error) + CALL scf_env_cleanup(scf_env) EXIT END IF @@ -517,7 +513,7 @@ SUBROUTINE xas(qs_env, dft_control, error) ! *** Write last wavefunction to screen *** DO ispin=1,nspins CALL write_mo_set(mos(ispin)%mo_set,atomic_kind_set,qs_kind_set,particle_set,4,& - dft_section,error=error) + dft_section) ENDDO ELSE @@ -529,7 +525,7 @@ SUBROUTINE xas(qs_env, dft_control, error) IF(converged) THEN CALL cls_calculate_spectrum(xas_control,xas_env,qs_env,xas_section,& - iatom,error=error) + iatom) ELSE IF (output_unit>0) WRITE(UNIT=output_unit,FMT='(/,/,T10,A,I6)') & "SCF with core hole NOT converged for ATOM ", iatom @@ -539,14 +535,14 @@ SUBROUTINE xas(qs_env, dft_control, error) ! Reset the initial core orbitals. ! The valence orbitals are taken from the last SCF, ! it should be a better initial guess - CALL get_qs_env(qs_env,mos=mos,error=error) + CALL get_qs_env(qs_env,mos=mos) DO ispin = 1,nspins CALL get_mo_set(mos(ispin)%mo_set, mo_coeff=mo_coeff, nmo=nmo) CALL cp_fm_to_fm(groundstate_coeff(ispin)%matrix,mos(ispin)%mo_set%mo_coeff,nmo,1,1) END DO IF(iat == nexc_atoms) THEN - CALL scf_env_cleanup(scf_env,error=error) - CALL scf_env_release(xas_env%scf_env,error=error) + CALL scf_env_cleanup(scf_env) + CALL scf_env_release(xas_env%scf_env) END IF END IF @@ -557,14 +553,14 @@ SUBROUTINE xas(qs_env, dft_control, error) ! Release what has to be released IF(ASSOCIATED(vecbuffer)) THEN DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(op_sm,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF DO ispin = 1,dft_control%nspins CALL set_mo_set(mos(ispin)%mo_set, homo=my_homo(ispin),& - uniform_occupation=my_uocc(ispin), nelectron= my_nelectron(ispin), error=error) + uniform_occupation=my_uocc(ispin), nelectron= my_nelectron(ispin)) CALL get_mo_set(mos(ispin)%mo_set, mo_coeff=mo_coeff, nmo=nmo) CALL cp_fm_to_fm(groundstate_coeff(ispin)%matrix,mos(ispin)%mo_set%mo_coeff,nmo,1,1) END DO @@ -576,10 +572,10 @@ SUBROUTINE xas(qs_env, dft_control, error) REPEAT("=",77) END IF - CALL xas_env_release(qs_env%xas_env, error=error) + CALL xas_env_release(qs_env%xas_env) CALL cp_print_key_finished_output(output_unit,logger,xas_section,& - "PRINT%PROGRAM_RUN_INFO",error=error) + "PRINT%PROGRAM_RUN_INFO") CALL timestop(handle) END SUBROUTINE xas @@ -590,19 +586,16 @@ END SUBROUTINE xas !> \param qs_env the qs_env, the xas_env lives in !> \param dft_section ... !> \param logger ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) + SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger) TYPE(xas_environment_type), POINTER :: xas_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: dft_section TYPE(cp_logger_type), POINTER :: logger - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_env_init', & routineP = moduleN//':'//routineN @@ -650,7 +643,7 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) failure=.FALSE. n_mo(1:2) = 0 - CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,failure) IF(.NOT. failure) THEN @@ -666,19 +659,18 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) matrix_s=matrix_s, mos=mos, & para_env=para_env, particle_set=particle_set,& sab_orb=sab_orb,& - dbcsr_dist=dbcsr_dist,& - error=error) + dbcsr_dist=dbcsr_dist) - xas_section => section_vals_get_subs_vals(dft_section,"XAS",error=error) - CALL xas_control_create(dft_control%xas_control,error=error) - CALL read_xas_control(dft_control%xas_control,xas_section,error=error) - CALL write_xas_control(dft_control%xas_control,dft_section,error=error) + xas_section => section_vals_get_subs_vals(dft_section,"XAS") + CALL xas_control_create(dft_control%xas_control) + CALL read_xas_control(dft_control%xas_control,xas_section) + CALL write_xas_control(dft_control%xas_control,dft_section) xas_control => dft_control%xas_control - CALL scf_c_create(scf_control,error=error) - CALL scf_c_read_parameters(scf_control,xas_section,error=error) - CALL set_xas_env(xas_env, scf_control=scf_control, error=error) - CALL scf_c_release(scf_control,error=error) - CALL get_xas_env(xas_env,scf_control=scf_control, error=error) + CALL scf_c_create(scf_control) + CALL scf_c_read_parameters(scf_control,xas_section) + CALL set_xas_env(xas_env, scf_control=scf_control) + CALL scf_c_release(scf_control) + CALL get_xas_env(xas_env,scf_control=scf_control) nexc_search = xas_control%nexc_search @@ -689,12 +681,12 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) END IF nexc_atoms = xas_control%nexc_atoms ALLOCATE(xas_env%exc_atoms(nexc_atoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) xas_env%exc_atoms = xas_control%exc_atoms CALL set_xas_env(xas_env=xas_env,nexc_search=nexc_search,& - nexc_atoms=nexc_atoms,error=error) + nexc_atoms=nexc_atoms) - CALL mpools_get(mpools, ao_mo_fm_pools= xas_env%ao_mo_fm_pools,error=error) + CALL mpools_get(mpools, ao_mo_fm_pools= xas_env%ao_mo_fm_pools) NULLIFY(mo_coeff) CALL get_mo_set(mos(1)%mo_set,nao=nao,homo=homo,nmo=nmo,mo_coeff=mo_coeff, nelectron=nelectron) @@ -710,33 +702,33 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) n_mo(1:2) = nmo ALLOCATE(xas_env%centers_wfn(3,nexc_search),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(xas_env%atom_of_state(nexc_search),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(xas_env%type_of_state(nexc_search),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(xas_env%state_of_atom(nexc_atoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(xas_env%mykind_of_atom(nexc_atoms),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) nkind = SIZE(atomic_kind_set,1) ALLOCATE(xas_env%mykind_of_kind(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) xas_env%mykind_of_kind = 0 ! create a new matrix structure nao x 1 NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& - ncol_global=1,para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create (xas_env%excvec_coeff, tmp_fm_struct ,error=error) - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + ncol_global=1,para_env=para_env,context=mo_coeff%matrix_struct%context) + CALL cp_fm_create (xas_env%excvec_coeff, tmp_fm_struct) + CALL cp_fm_struct_release ( tmp_fm_struct) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=1,& ncol_global=nexc_search,para_env=para_env,& - context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create (xas_env%excvec_overlap, tmp_fm_struct ,error=error) - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + context=mo_coeff%matrix_struct%context) + CALL cp_fm_create (xas_env%excvec_overlap, tmp_fm_struct) + CALL cp_fm_struct_release ( tmp_fm_struct) nspins = SIZE(mos,1) @@ -777,19 +769,19 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) occ_homo = 1.0_dp ENDIF CALL set_xas_env(xas_env=xas_env,occ_estate=occ_estate,xas_nelectron=nele,& - nvirtual2=nvirtual2,nvirtual=nvirtual,homo_occ=occ_homo,error=error) + nvirtual2=nvirtual2,nvirtual=nvirtual,homo_occ=occ_homo) ! Initialize the list of orbitals for cube files printing IF (BTEST(cp_print_key_should_output(logger%iter_info,xas_section,& - "PRINT%CLS_FUNCTION_CUBES",error=error),cp_p_file)) THEN + "PRINT%CLS_FUNCTION_CUBES"),cp_p_file)) THEN NULLIFY(bounds,list) CALL section_vals_val_get(xas_section,& "PRINT%CLS_FUNCTION_CUBES%CUBES_LU_BOUNDS",& - i_vals=bounds,error=error) + i_vals=bounds) ncubes = bounds(2) - bounds(1) + 1 IF(ncubes > 0 ) THEN ALLOCATE( xas_control%list_cubes(ncubes),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ik = 1,ncubes xas_control%list_cubes(ik) = bounds(1) + (ik-1) @@ -799,13 +791,13 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) IF(.NOT. ASSOCIATED(xas_control%list_cubes)) THEN CALL section_vals_val_get(xas_section, & "PRINT%CLS_FUNCTION_CUBES%CUBES_LIST",& - n_rep_val=n_rep,error=error) + n_rep_val=n_rep) ncubes = 0 DO ik = 1,n_rep NULLIFY(list) CALL section_vals_val_get(xas_section,& "PRINT%CLS_FUNCTION_CUBES%CUBES_LIST",& - i_rep_val=ik,i_vals=list,error=error) + i_rep_val=ik,i_vals=list) IF(ASSOCIATED(list)) THEN CALL reallocate(xas_control%list_cubes,1,ncubes+ SIZE(list)) DO i = 1, SIZE(list) @@ -820,7 +812,7 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) ncubes = MAX(10,xas_control%added_mos/10) ncubes = MIN(ncubes,xas_control%added_mos) ALLOCATE( xas_control%list_cubes(ncubes),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ik = 1,ncubes xas_control%list_cubes(ik) = homo + ik END DO @@ -832,106 +824,105 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) NULLIFY(tmp_fm_struct) nwork = nvirtual CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,ncol_global=nwork,& - para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) - CALL cp_fm_create (xas_env%fm_work,tmp_fm_struct,error=error) - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + para_env=para_env,context=mo_coeff%matrix_struct%context) + CALL cp_fm_create (xas_env%fm_work,tmp_fm_struct) + CALL cp_fm_struct_release ( tmp_fm_struct) ALLOCATE (xas_env%groundstate_coeff(nspins), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1,nspins NULLIFY(xas_env%groundstate_coeff(ispin)%matrix) CALL get_mo_set(mos(ispin)%mo_set,nao=nao,nmo=nmo) CALL fm_pool_create_fm(xas_env%ao_mo_fm_pools(ispin)%pool,& xas_env%groundstate_coeff(ispin)%matrix,& - name="xas_env%mo0"//TRIM(ADJUSTL(cp_to_string(ispin))),error=error) + name="xas_env%mo0"//TRIM(ADJUSTL(cp_to_string(ispin)))) END DO ! ispin NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=1,& ncol_global=nvirtual,para_env=para_env,& - context=mo_coeff%matrix_struct%context,error=error) + context=mo_coeff%matrix_struct%context) ALLOCATE (xas_env%dip_fm_set(2,3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO i = 1,3 DO j = 1,2 NULLIFY(xas_env%dip_fm_set(j,i)%matrix) - CALL cp_fm_create (xas_env%dip_fm_set(j,i)%matrix, tmp_fm_struct ,error=error) + CALL cp_fm_create (xas_env%dip_fm_set(j,i)%matrix, tmp_fm_struct) END DO END DO - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + CALL cp_fm_struct_release ( tmp_fm_struct) !Array to store all the eigenstates: occupied and the required not occupied IF(nvirtual2 .GT. 0) THEN ALLOCATE(xas_env%unoccupied_evals(nvirtual2), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao,& ncol_global=nvirtual2,& - para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) + para_env=para_env,context=mo_coeff%matrix_struct%context) NULLIFY(xas_env%unoccupied_orbs) - CALL cp_fm_create (xas_env%unoccupied_orbs,tmp_fm_struct,error=error) - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + CALL cp_fm_create (xas_env%unoccupied_orbs,tmp_fm_struct) + CALL cp_fm_struct_release ( tmp_fm_struct) END IF NULLIFY(tmp_fm_struct) CALL cp_fm_struct_create(tmp_fm_struct,nrow_global=nao, & ncol_global=nvirtual,& - para_env=para_env,context=mo_coeff%matrix_struct%context,error=error) + para_env=para_env,context=mo_coeff%matrix_struct%context) NULLIFY(xas_env%all_vectors) - CALL cp_fm_create (xas_env%all_vectors,tmp_fm_struct,error=error) - CALL cp_fm_struct_release ( tmp_fm_struct ,error=error) + CALL cp_fm_create (xas_env%all_vectors,tmp_fm_struct) + CALL cp_fm_struct_release ( tmp_fm_struct) ! Array to store all the energies needed for the spectrum ALLOCATE(xas_env%all_evals(nvirtual), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) IF(xas_control%dipole_form==xas_dip_len2) THEN - CALL cp_dbcsr_allocate_matrix_set(xas_env%ostrength_sm,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(xas_env%ostrength_sm,3) DO i = 1,3 ALLOCATE(xas_env%ostrength_sm(i)%matrix) - CALL cp_dbcsr_init(xas_env%ostrength_sm(i)%matrix,error=error) + CALL cp_dbcsr_init(xas_env%ostrength_sm(i)%matrix) CALL cp_dbcsr_copy(xas_env%ostrength_sm(i)%matrix,matrix_s(1)%matrix,& "xas_env%ostrength_sm"//& - "-"//TRIM(ADJUSTL(cp_to_string(i))),error=error) - CALL cp_dbcsr_set(xas_env%ostrength_sm(i)%matrix,0.0_dp,error=error) + "-"//TRIM(ADJUSTL(cp_to_string(i)))) + CALL cp_dbcsr_set(xas_env%ostrength_sm(i)%matrix,0.0_dp) END DO ELSEIF(xas_control%dipole_form==xas_dip_vel) THEN ! ! prepare for allocation natom = SIZE(particle_set,1) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (last_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_particle_set(particle_set, qs_kind_set,& first_sgf=first_sgf,& - last_sgf=last_sgf,error=error) + last_sgf=last_sgf) ALLOCATE (row_blk_sizes(natom), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL convert_offsets_to_sizes (first_sgf, row_blk_sizes, last_sgf) DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (last_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! ! - CALL cp_dbcsr_allocate_matrix_set(xas_env%ostrength_sm,3,error=error) + CALL cp_dbcsr_allocate_matrix_set(xas_env%ostrength_sm,3) ALLOCATE(xas_env%ostrength_sm(1)%matrix) - CALL cp_dbcsr_init(xas_env%ostrength_sm(1)%matrix,error=error) + CALL cp_dbcsr_init(xas_env%ostrength_sm(1)%matrix) CALL cp_dbcsr_create(matrix=xas_env%ostrength_sm(1)%matrix, & name="xas_env%ostrength_sm", & dist=dbcsr_dist, matrix_type=dbcsr_type_antisymmetric,& row_blk_size=row_blk_sizes, col_blk_size=row_blk_sizes, & - nze=0, mutable_work=.TRUE., & - error=error) - CALL cp_dbcsr_alloc_block_from_nbl(xas_env%ostrength_sm(1)%matrix,sab_orb,error=error) - CALL cp_dbcsr_set(xas_env%ostrength_sm(1)%matrix,0.0_dp,error=error) + nze=0, mutable_work=.TRUE.) + CALL cp_dbcsr_alloc_block_from_nbl(xas_env%ostrength_sm(1)%matrix,sab_orb) + CALL cp_dbcsr_set(xas_env%ostrength_sm(1)%matrix,0.0_dp) DO i = 2,3 ALLOCATE(xas_env%ostrength_sm(i)%matrix) - CALL cp_dbcsr_init(xas_env%ostrength_sm(i)%matrix,error=error) + CALL cp_dbcsr_init(xas_env%ostrength_sm(i)%matrix) CALL cp_dbcsr_copy(xas_env%ostrength_sm(i)%matrix,xas_env%ostrength_sm(1)%matrix,& - "xas_env%ostrength_sm-"//TRIM(ADJUSTL(cp_to_string(i))),error=error) - CALL cp_dbcsr_set(xas_env%ostrength_sm(i)%matrix,0.0_dp,error=error) + "xas_env%ostrength_sm-"//TRIM(ADJUSTL(cp_to_string(i)))) + CALL cp_dbcsr_set(xas_env%ostrength_sm(i)%matrix,0.0_dp) END DO DEALLOCATE(row_blk_sizes) @@ -939,21 +930,21 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) !Define the qs_loc_env : to find centers, spread and possibly localize them IF(.NOT.(ASSOCIATED(xas_env%qs_loc_env))) THEN - CALL qs_loc_env_create(qs_loc_env,error=error) - CALL set_xas_env(xas_env=xas_env, qs_loc_env=qs_loc_env,error=error) - CALL qs_loc_env_release(qs_loc_env,error=error) - CALL get_xas_env(xas_env=xas_env, qs_loc_env=qs_loc_env,error=error) - loc_section => section_vals_get_subs_vals(xas_section,"LOCALIZE",error=error) + CALL qs_loc_env_create(qs_loc_env) + CALL set_xas_env(xas_env=xas_env, qs_loc_env=qs_loc_env) + CALL qs_loc_env_release(qs_loc_env) + CALL get_xas_env(xas_env=xas_env, qs_loc_env=qs_loc_env) + loc_section => section_vals_get_subs_vals(xas_section,"LOCALIZE") CALL qs_loc_control_init(qs_loc_env,loc_section,do_homo=.TRUE.,& - do_xas=.TRUE.,nloc_xas=nexc_search,error=error) + do_xas=.TRUE.,nloc_xas=nexc_search) IF(.NOT. qs_loc_env%do_localize) THEN qs_loc_env%localized_wfn_control%localization_method = do_loc_none ELSE nmoloc = qs_loc_env%localized_wfn_control%nloc_states - CALL set_loc_wfn_lists(qs_loc_env%localized_wfn_control,nmoloc,n_mo,nspins,error=error) - CALL set_loc_centers(qs_loc_env%localized_wfn_control,nmoloc,nspins,error=error) + CALL set_loc_wfn_lists(qs_loc_env%localized_wfn_control,nmoloc,n_mo,nspins) + CALL set_loc_centers(qs_loc_env%localized_wfn_control,nmoloc,nspins) CALL qs_loc_env_init(qs_loc_env,qs_loc_env%localized_wfn_control,& - qs_env,myspin=1,do_localize=qs_loc_env%do_localize,error=error) + qs_env,myspin=1,do_localize=qs_loc_env%do_localize) END IF END IF @@ -983,7 +974,7 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) ! Find core orbitals of right angular momentum ALLOCATE(kind_type_tmp(nkind),STAT=istat) ALLOCATE(kind_z_tmp(nkind),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) kind_type_tmp = 0 kind_z_tmp = 0 nk=0 @@ -992,7 +983,7 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) NULLIFY(atomic_kind) atomic_kind => particle_set(iatom)%atomic_kind CALL get_atomic_kind(atomic_kind=atomic_kind, kind_number=ikind) - CALL get_qs_kind(qs_kind_set(ikind), zeff=zatom, error=error) + CALL get_qs_kind(qs_kind_set(ikind), zeff=zatom) ihavethis = .FALSE. DO ik = 1,nk IF(ikind==kind_type_tmp(ik)) THEN @@ -1011,9 +1002,9 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) END DO ! iat ALLOCATE(xas_env%my_gto_basis(nk),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(xas_env%stogto_overlap(nk),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ik = 1,nk NULLIFY(xas_env%my_gto_basis(ik)%gto_basis_set,sto_basis_set) ne = 0 @@ -1027,31 +1018,31 @@ SUBROUTINE xas_env_init(xas_env, qs_env, dft_section, logger, error) END DO sto_zet(1) = srules(kind_z_tmp(ik),ne,nq(1),lq(1)) - CALL allocate_sto_basis_set(sto_basis_set,error) + CALL allocate_sto_basis_set(sto_basis_set) name_sto='xas_tmp_sto' CALL set_sto_basis_set(sto_basis_set,nshell=1,nq=nq,& lq=lq,zet=sto_zet,name=name_sto) CALL create_gto_from_sto_basis(sto_basis_set,& - xas_env%my_gto_basis(ik)%gto_basis_set,xas_control%ngauss,error=error) - CALL deallocate_sto_basis_set(sto_basis_set,error) + xas_env%my_gto_basis(ik)%gto_basis_set,xas_control%ngauss) + CALL deallocate_sto_basis_set(sto_basis_set) xas_env%my_gto_basis(ik)%gto_basis_set%norm_type = 2 - CALL init_orb_basis_set(xas_env%my_gto_basis(ik)%gto_basis_set,error=error) + CALL init_orb_basis_set(xas_env%my_gto_basis(ik)%gto_basis_set) ikind = kind_type_tmp(ik) - CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, error=error) + CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set) CALL get_gto_basis_set(gto_basis_set=orb_basis_set,nsgf=nsgf_gto) CALL get_gto_basis_set(gto_basis_set=xas_env%my_gto_basis(ik)%gto_basis_set,nsgf=nsgf_sto) ALLOCATE(xas_env%stogto_overlap(ik)%array(nsgf_sto,nsgf_gto),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL calc_stogto_overlap(xas_env%my_gto_basis(ik)%gto_basis_set,orb_basis_set,& - xas_env%stogto_overlap(ik)%array,error=error) + xas_env%stogto_overlap(ik)%array) END DO DEALLOCATE(nq,lq,sto_zet,STAT=istat) DEALLOCATE(kind_type_tmp,kind_z_tmp,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! failure END SUBROUTINE xas_env_init @@ -1065,8 +1056,6 @@ END SUBROUTINE xas_env_init !> \param qs_env ... !> \param xas_section ... !> \param iatom index of the excited atom -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 03.2006 created [MI] !> \author MI @@ -1074,14 +1063,13 @@ END SUBROUTINE xas_env_init !> for the tddft calculation should be re-thought ! ***************************************************************************** SUBROUTINE cls_calculate_spectrum(xas_control,xas_env,qs_env,xas_section,& - iatom,error) + iatom) TYPE(xas_control_type) :: xas_control TYPE(xas_environment_type), POINTER :: xas_env TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: xas_section INTEGER, INTENT(IN) :: iatom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cls_calculate_spectrum', & routineP = moduleN//':'//routineN @@ -1107,29 +1095,29 @@ SUBROUTINE cls_calculate_spectrum(xas_control,xas_env,qs_env,xas_section,& failure =.FALSE. NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) NULLIFY(fm_work,ostrength_sm,op_sm, dip_fm_set) NULLIFY(all_evals,all_vectors,excvec_coeff) NULLIFY(mos,particle_set,sp_em,sp_ab) ALLOCATE (op_sm(3),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env, & - mos=mos,particle_set=particle_set,error=error) + mos=mos,particle_set=particle_set) CALL get_mo_set(mos(1)%mo_set, homo=homo,lfomo=lfomo,nmo=nmo) CALL get_xas_env(xas_env=xas_env,all_vectors=all_vectors,xas_estate=xas_estate,& all_evals=all_evals,dip_fm_set=dip_fm_set,excvec_coeff=excvec_coeff,& - fm_work=fm_work, ostrength_sm=ostrength_sm,nvirtual=nvirtual,error=error) + fm_work=fm_work, ostrength_sm=ostrength_sm,nvirtual=nvirtual) nabs = nvirtual -lfomo + 1 ALLOCATE (sp_em(6,homo),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (sp_ab(6,nabs),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(excvec_coeff),cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(excvec_coeff),cp_failure_level,routineP,failure) IF(.NOT. failure) THEN @@ -1141,12 +1129,12 @@ SUBROUTINE cls_calculate_spectrum(xas_control,xas_env,qs_env,xas_section,& NULLIFY(op_sm(i)%matrix) op_sm(i)%matrix => ostrength_sm(i)%matrix END DO - CALL rRc_xyz_ao(op_sm,qs_env,rc,order=1,minimum_image=.TRUE.,error=error) + CALL rRc_xyz_ao(op_sm,qs_env,rc,order=1,minimum_image=.TRUE.) CALL spectrum_dip_vel(dip_fm_set,op_sm,mos,excvec_coeff,& all_vectors,all_evals,fm_work,& - sp_em,sp_ab,xas_estate,nvirtual,error=error) + sp_em,sp_ab,xas_estate,nvirtual) DO i = 1,SIZE(ostrength_sm,1) - CALL cp_dbcsr_set(ostrength_sm(i)%matrix,0.0_dp,error=error) + CALL cp_dbcsr_set(ostrength_sm(i)%matrix,0.0_dp) END DO ELSE DO i = 1,3 @@ -1155,7 +1143,7 @@ SUBROUTINE cls_calculate_spectrum(xas_control,xas_env,qs_env,xas_section,& END DO CALL spectrum_dip_vel(dip_fm_set,op_sm,mos,excvec_coeff,& all_vectors,all_evals,fm_work,& - sp_em,sp_ab,xas_estate,nvirtual,error=error) + sp_em,sp_ab,xas_estate,nvirtual) END IF END IF @@ -1164,23 +1152,23 @@ SUBROUTINE cls_calculate_spectrum(xas_control,xas_env,qs_env,xas_section,& IF( .NOT. xas_control%xas_method == xas_dscf) THEN length = (.NOT. xas_control%dipole_form==xas_dip_vel) CALL xas_write(sp_em,sp_ab, xas_estate, & - xas_section, iatom, lfomo, length=length, error=error) + xas_section, iatom, lfomo, length=length) END IF DEALLOCATE(sp_em,STAT=istat) DEALLOCATE(sp_ab,STAT=istat) IF(BTEST(cp_print_key_should_output(logger%iter_info,xas_section,& - "PRINT%CLS_FUNCTION_CUBES",error=error),cp_p_file)) THEN - append_cube= section_get_lval(xas_section,"PRINT%CLS_FUNCTION_CUBES%APPEND",error=error) + "PRINT%CLS_FUNCTION_CUBES"),cp_p_file)) THEN + append_cube= section_get_lval(xas_section,"PRINT%CLS_FUNCTION_CUBES%APPEND") CALL xas_print_cubes(xas_control,qs_env,xas_section,mos,all_vectors,& - iatom,append_cube,error=error) + iatom,append_cube) END IF END IF ! failure DEALLOCATE (op_sm,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE cls_calculate_spectrum @@ -1193,8 +1181,6 @@ END SUBROUTINE cls_calculate_spectrum !> \param iatom index of the excited atom !> \param lfomo ... !> \param length ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2005 created [MI] !> \author MI @@ -1202,14 +1188,13 @@ END SUBROUTINE cls_calculate_spectrum !> the iteration counter is not finilized yet ! ***************************************************************************** SUBROUTINE xas_write(sp_em, sp_ab, estate, xas_section, iatom, & - lfomo, length, error) + lfomo, length) REAL(dp), DIMENSION(:, :), POINTER :: sp_em, sp_ab INTEGER, INTENT(IN) :: estate TYPE(section_vals_type), POINTER :: xas_section INTEGER, INTENT(IN) :: iatom, lfomo LOGICAL, INTENT(IN) :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_write', & routineP = moduleN//':'//routineN @@ -1223,7 +1208,7 @@ SUBROUTINE xas_write(sp_em, sp_ab, estate, xas_section, iatom, & TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() failure = .FALSE. @@ -1233,8 +1218,7 @@ SUBROUTINE xas_write(sp_em, sp_ab, estate, xas_section, iatom, & mittle_em = "xes_at"//TRIM(ADJUSTL(cp_to_string(iatom))) out_sp_em = cp_print_key_unit_nr(logger,xas_section,"PRINT%XES_SPECTRUM",& extension=".spectrum", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(mittle_em), & - error=error) + file_form="FORMATTED", middle_name=TRIM(mittle_em)) IF(out_sp_em>0) THEN WRITE(out_sp_em,'(A,I6,A,I6,A,I6)') " Emission spectrum for atom ", iatom,& @@ -1248,13 +1232,12 @@ SUBROUTINE xas_write(sp_em, sp_ab, estate, xas_section, iatom, & END DO END IF CALL cp_print_key_finished_output(out_sp_em,logger,xas_section,& - "PRINT%XES_SPECTRUM", error=error) + "PRINT%XES_SPECTRUM") mittle_ab = "xas_at"//TRIM(ADJUSTL(cp_to_string(iatom))) out_sp_ab = cp_print_key_unit_nr(logger,xas_section,"PRINT%XAS_SPECTRUM",& extension=".spectrum", file_position=my_pos, file_action=my_act,& - file_form="FORMATTED", middle_name=TRIM(mittle_ab), & - error=error) + file_form="FORMATTED", middle_name=TRIM(mittle_ab)) IF(out_sp_ab>0) THEN WRITE(out_sp_ab,'(A,I6,A,I6,A,I6)') " Absorption spectrum for atom ", iatom,& @@ -1270,7 +1253,7 @@ SUBROUTINE xas_write(sp_em, sp_ab, estate, xas_section, iatom, & END IF CALL cp_print_key_finished_output(out_sp_ab,logger,xas_section,& - "PRINT%XAS_SPECTRUM", error=error) + "PRINT%XAS_SPECTRUM") END SUBROUTINE xas_write @@ -1283,13 +1266,12 @@ END SUBROUTINE xas_write !> \param all_vectors ... !> \param iatom index of the atom that has been excited !> \param append_cube ... -!> \param error ... !> \par History !> 08.2005 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE xas_print_cubes(xas_control,qs_env,xas_section,& - mos,all_vectors,iatom,append_cube, error) + mos,all_vectors,iatom,append_cube) TYPE(xas_control_type) :: xas_control TYPE(qs_environment_type), POINTER :: qs_env @@ -1299,7 +1281,6 @@ SUBROUTINE xas_print_cubes(xas_control,qs_env,xas_section,& TYPE(cp_fm_type), POINTER :: all_vectors INTEGER, INTENT(IN) :: iatom LOGICAL, INTENT(IN) :: append_cube - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xas_print_cubes', & routineP = moduleN//':'//routineN @@ -1314,7 +1295,7 @@ SUBROUTINE xas_print_cubes(xas_control,qs_env,xas_section,& failure = .FALSE. nspins = SIZE(mos) - print_key => section_vals_get_subs_vals(xas_section,"PRINT%CLS_FUNCTION_CUBES",error=error) + print_key => section_vals_get_subs_vals(xas_section,"PRINT%CLS_FUNCTION_CUBES") my_mittle = 'at'//TRIM(ADJUSTL(cp_to_string(iatom))) nstates = SIZE(xas_control%list_cubes,1) @@ -1322,7 +1303,7 @@ SUBROUTINE xas_print_cubes(xas_control,qs_env,xas_section,& ! one might like to calculate the centers of the xas orbital (without localizing them) ELSE ALLOCATE(centers(6,nstates),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) centers = 0.0_dp END IF @@ -1335,10 +1316,10 @@ SUBROUTINE xas_print_cubes(xas_control,qs_env,xas_section,& END IF CALL qs_print_cubes(qs_env,all_vectors,nstates,xas_control%list_cubes,& - centers,print_key,my_mittle,state0=istate0,file_position=my_pos,error=error) + centers,print_key,my_mittle,state0=istate0,file_position=my_pos) DEALLOCATE(centers,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE xas_print_cubes @@ -1363,14 +1344,12 @@ END SUBROUTINE xas_print_cubes !> \param sp_ab ... !> \param estate index of the excited state !> \param nstate ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2005 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE spectrum_dip_len(fm_set,op_sm,mos,excvec,& - all_vectors,all_evals,fm_work,cell, sp_em, sp_ab,estate, nstate,error) + all_vectors,all_evals,fm_work,cell, sp_em, sp_ab,estate, nstate) TYPE(cp_fm_p_type), DIMENSION(:, :), & POINTER :: fm_set @@ -1384,7 +1363,6 @@ SUBROUTINE spectrum_dip_len(fm_set,op_sm,mos,excvec,& TYPE(cell_type), POINTER :: cell REAL(dp), DIMENSION(:, :), POINTER :: sp_em, sp_ab INTEGER, INTENT(IN) :: estate, nstate - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'spectrum_dip_len', & routineP = moduleN//':'//routineN @@ -1400,20 +1378,20 @@ SUBROUTINE spectrum_dip_len(fm_set,op_sm,mos,excvec,& failure = .FALSE. - CPPrecondition(ASSOCIATED(fm_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fm_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,failure) NULLIFY(eigenvalues, occupation_numbers) CALL get_mo_set(mos(1)%mo_set, eigenvalues=eigenvalues, occupation_numbers=occupation_numbers,& nao=nao, nmo=nmo, homo =homo, lfomo=lfomo) DO i=1,SIZE(fm_set,2) DO j = 1,SIZE(fm_set,1) - CPPrecondition(ASSOCIATED(fm_set(j,i)%matrix),cp_failure_level,routineP,error,failure) - CALL cp_fm_set_all(fm_set(j,i)%matrix, 0.0_dp, error=error) - CALL cp_fm_set_all(fm_work, 0.0_dp, error=error) - CALL cp_dbcsr_sm_fm_multiply(op_sm(j,i)%matrix,all_vectors,fm_work,ncol=nstate,error=error) + CPPrecondition(ASSOCIATED(fm_set(j,i)%matrix),cp_failure_level,routineP,failure) + CALL cp_fm_set_all(fm_set(j,i)%matrix, 0.0_dp) + CALL cp_fm_set_all(fm_work, 0.0_dp) + CALL cp_dbcsr_sm_fm_multiply(op_sm(j,i)%matrix,all_vectors,fm_work,ncol=nstate) CALL cp_gemm("T","N",1,nstate,nao,1.0_dp,excvec,& - fm_work,0.0_dp, fm_set(j,i)%matrix,b_first_col=1,error=error) + fm_work,0.0_dp, fm_set(j,i)%matrix,b_first_col=1) END DO END DO @@ -1468,14 +1446,12 @@ END SUBROUTINE spectrum_dip_len !> \param sp_ab ... !> \param estate index of the excited state !> \param nstate ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 06.2005 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE spectrum_dip_vel(fm_set,op_sm,mos,excvec, & - all_vectors,all_evals,fm_work,sp_em, sp_ab,estate, nstate,error) + all_vectors,all_evals,fm_work,sp_em, sp_ab,estate, nstate) TYPE(cp_fm_p_type), DIMENSION(:, :), & POINTER :: fm_set @@ -1488,7 +1464,6 @@ SUBROUTINE spectrum_dip_vel(fm_set,op_sm,mos,excvec, & TYPE(cp_fm_type), POINTER :: fm_work REAL(dp), DIMENSION(:, :), POINTER :: sp_em, sp_ab INTEGER, INTENT(IN) :: estate, nstate - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'spectrum_dip_vel', & routineP = moduleN//':'//routineN @@ -1502,20 +1477,20 @@ SUBROUTINE spectrum_dip_vel(fm_set,op_sm,mos,excvec, & failure = .FALSE. - CPPrecondition(ASSOCIATED(fm_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(fm_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,failure) NULLIFY(eigenvalues, occupation_numbers) CALL get_mo_set(mos(1)%mo_set, eigenvalues=eigenvalues,occupation_numbers=occupation_numbers,& nao=nao, nmo=nmo, homo =homo, lfomo=lfomo) DO i=1,SIZE(fm_set,2) - CPPrecondition(ASSOCIATED(fm_set(1,i)%matrix),cp_failure_level,routineP,error,failure) - CALL cp_fm_set_all(fm_set(1,i)%matrix, 0.0_dp, error=error) - CALL cp_fm_set_all(fm_work, 0.0_dp, error=error) - CALL cp_dbcsr_sm_fm_multiply(op_sm(i)%matrix,all_vectors,fm_work,ncol=nstate,error=error) + CPPrecondition(ASSOCIATED(fm_set(1,i)%matrix),cp_failure_level,routineP,failure) + CALL cp_fm_set_all(fm_set(1,i)%matrix, 0.0_dp) + CALL cp_fm_set_all(fm_work, 0.0_dp) + CALL cp_dbcsr_sm_fm_multiply(op_sm(i)%matrix,all_vectors,fm_work,ncol=nstate) CALL cp_gemm("T","N",1,nstate,nao,1.0_dp,excvec,& - fm_work,0.0_dp, fm_set(1,i)%matrix,b_first_col=1,error=error) + fm_work,0.0_dp, fm_set(1,i)%matrix,b_first_col=1) END DO sp_em = 0.0_dp @@ -1555,13 +1530,11 @@ END SUBROUTINE spectrum_dip_vel !> \param base_a ... !> \param base_b ... !> \param matrix ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE calc_stogto_overlap(base_a, base_b, matrix,error) + SUBROUTINE calc_stogto_overlap(base_a, base_b, matrix) TYPE(gto_basis_set_type), POINTER :: base_a, base_b REAL(dp), DIMENSION(:, :), POINTER :: matrix - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_stogto_overlap', & routineP = moduleN//':'//routineN @@ -1602,9 +1575,9 @@ SUBROUTINE calc_stogto_overlap(base_a, base_b, matrix,error) maxl = MAX(maxla,maxlb) ALLOCATE(sab(ldsab,ldsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE(work(ldsab,ldsab),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO iset=1,nseta @@ -1618,16 +1591,16 @@ SUBROUTINE calc_stogto_overlap(base_a, base_b, matrix,error) CALL overlap_ab(la_max(iset),la_min(iset),npgfa(iset),rpgfa(:,iset),zeta(:,iset),& lb_max(jset),lb_min(jset),npgfb(jset),rpgfb(:,jset),zetb(:,jset),& - rab,sab,error=error) + rab,sab) CALL contraction(sab,work,ca=scon_a(:,sgfa:),na=na,ma=nsgfa_set(iset),& - cb=scon_b(:,sgfb:),nb=nb,mb=nsgfb_set(jset),error=error) - CALL block_add("IN",work,nsgfa_set(iset),nsgfb_set(jset),matrix,sgfa,sgfb,error=error) + cb=scon_b(:,sgfb:),nb=nb,mb=nsgfb_set(jset)) + CALL block_add("IN",work,nsgfa_set(iset),nsgfb_set(jset),matrix,sgfa,sgfb) END DO ! jset END DO ! iset DEALLOCATE(sab,work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE calc_stogto_overlap @@ -1646,19 +1619,17 @@ END SUBROUTINE calc_stogto_overlap !> \param xas_env ... !> \param localized_wfn_control ... !> \param qs_env ... -!> \param error ... !> \par History !> 03.2006 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE cls_assign_core_states(xas_control,xas_env,localized_wfn_control,qs_env,error) + SUBROUTINE cls_assign_core_states(xas_control,xas_env,localized_wfn_control,qs_env) TYPE(xas_control_type) :: xas_control TYPE(xas_environment_type), POINTER :: xas_env TYPE(localized_wfn_control_type), & POINTER :: localized_wfn_control TYPE(qs_environment_type), POINTER :: qs_env - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cls_assign_core_states', & routineP = moduleN//':'//routineN @@ -1697,11 +1668,11 @@ SUBROUTINE cls_assign_core_states(xas_control,xas_env,localized_wfn_control,qs_e NULLIFY(state_of_mytype,type_of_state,sto_state_overlap) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) CALL get_qs_env(qs_env=qs_env, cell=cell, mos=mos, particle_set=particle_set,& - qs_kind_set=qs_kind_set, error=error) + qs_kind_set=qs_kind_set) ! The Berry operator can be used only for periodic systems ! If an isolated system is used the periodicity is overimposed @@ -1714,23 +1685,23 @@ SUBROUTINE cls_assign_core_states(xas_control,xas_env,localized_wfn_control,qs_e centers_wfn=centers_wfn,atom_of_state=atom_of_state,& mykind_of_kind=mykind_of_kind,& type_of_state=type_of_state, state_of_atom=state_of_atom,& - stogto_overlap=stogto_overlap,nexc_atoms=nexc_atoms, nexc_search=nexc_search,error=error) + stogto_overlap=stogto_overlap,nexc_atoms=nexc_atoms, nexc_search=nexc_search) ! scratch array for the state ALLOCATE(vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) natom = SIZE(particle_set) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf,error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf) ALLOCATE (sto_state_overlap(nexc_search),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ALLOCATE (max_overlap(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) max_overlap = 0.0_dp ALLOCATE (state_of_mytype(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) state_of_mytype = 0 atom_of_state = 0 @@ -1757,7 +1728,7 @@ SUBROUTINE cls_assign_core_states(xas_control,xas_env,localized_wfn_control,qs_e IF(atom_of_state(istate) /= 0) THEN !Character of the state CALL cp_fm_get_submatrix(mo_coeff,vecbuffer,1,istate,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) iatom = atom_of_state(istate) @@ -1807,15 +1778,15 @@ SUBROUTINE cls_assign_core_states(xas_control,xas_env,localized_wfn_control,qs_e cell%perd(1:3) = perd0(1:3) DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (sto_state_overlap,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (max_overlap,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE (state_of_mytype,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE cls_assign_core_states diff --git a/src/xas_restart.F b/src/xas_restart.F index 72c5e4f5e4..7787f3a84f 100644 --- a/src/xas_restart.F +++ b/src/xas_restart.F @@ -87,19 +87,17 @@ MODULE xas_restart !> \param iatom index of the absorbing atom !> \param estate index of the core-hole orbital !> error: -!> \param error ... !> \par History !> 09.2006 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate,error) + SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate) TYPE(xas_environment_type), POINTER :: xas_env TYPE(section_vals_type), POINTER :: xas_section TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: xas_method, iatom INTEGER, INTENT(OUT) :: estate - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xas_read_restart', & routineP = moduleN//':'//routineN @@ -133,18 +131,18 @@ SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate, NULLIFY(eigenvalues, matrix_s, mos, occupation_numbers, vecbuffer) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit = cp_print_key_unit_nr(logger,xas_section,& - "PRINT%PROGRAM_RUN_INFO", extension=".Log",error=error) + "PRINT%PROGRAM_RUN_INFO", extension=".Log") - CALL get_qs_env( qs_env=qs_env, para_env=para_env ,error=error) + CALL get_qs_env( qs_env=qs_env, para_env=para_env) group = para_env%group source = para_env%source IF (para_env%ionode) THEN CALL wfn_restart_file_name(filename,file_exists,xas_section,logger,& - xas=.TRUE.,error=error) + xas=.TRUE.) CALL xstring (filename, ia, ie ) filename = filename(ia:ie)//'-at'//& @@ -173,11 +171,10 @@ SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate, CALL mp_bcast(file_exists,source,group) CALL get_xas_env(xas_env=xas_env,occ_estate=occ_estate,xas_estate=xas_estate, & - xas_nelectron=xas_nelectron, nexc_search=nexc_search, nexc_atoms=nexc_atoms,error=error) + xas_nelectron=xas_nelectron, nexc_search=nexc_search, nexc_atoms=nexc_atoms) IF(file_exists) THEN - CALL get_qs_env(qs_env=qs_env, mos=mos, matrix_s=matrix_s,& - error=error) + CALL get_qs_env(qs_env=qs_env, mos=mos, matrix_s=matrix_s) IF(rst_unit>0) THEN READ(rst_unit) xas_method_read @@ -196,19 +193,19 @@ SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate, ENDIF CALL mp_bcast(xas_estate_read,source,group) - CALL set_xas_env(xas_env=xas_env,xas_estate=xas_estate_read,error=error) + CALL set_xas_env(xas_env=xas_env,xas_estate=xas_estate_read) estate = xas_estate_read CALL get_mo_set(mo_set=mos(1)%mo_set,nao=nao) ALLOCATE (vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DO ispin = 1, SIZE(mos) CALL get_mo_set(mo_set=mos(ispin)%mo_set, nmo=nmo, eigenvalues=eigenvalues,& occupation_numbers=occupation_numbers,mo_coeff=mo_coeff,nelectron=nelectron) eigenvalues = 0.0_dp occupation_numbers = 0.0_dp - CALL cp_fm_set_all(mo_coeff,0.0_dp,error=error) + CALL cp_fm_set_all(mo_coeff,0.0_dp) IF (para_env%ionode) THEN READ (rst_unit) nao_read, nmo_read CALL cp_assert(nao==nao_read,cp_failure_level,cp_assertion_failed,routineP,& @@ -216,7 +213,7 @@ SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate, CPSourceFileRef,& only_ionode=.TRUE.) ALLOCATE(eig_read(nmo_read), occ_read(nmo_read), STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) eig_read = 0.0_dp occ_read = 0.0_dp nmo = MIN(nmo,nmo_read) @@ -233,7 +230,7 @@ SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate, END IF DEALLOCATE(eig_read, occ_read, STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ENDIF CALL mp_bcast(eigenvalues,source,group) CALL mp_bcast(occupation_numbers,source,group) @@ -246,7 +243,7 @@ SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate, END IF CALL mp_bcast(vecbuffer,source,group) CALL cp_fm_set_submatrix(mo_coeff,& - vecbuffer,1,i,nao,1,transpose=.TRUE.,error=error) + vecbuffer,1,i,nao,1,transpose=.TRUE.) END DO ! Skip extra MOs if there any IF (para_env%ionode) THEN @@ -258,14 +255,14 @@ SUBROUTINE xas_read_restart(xas_env,xas_section,qs_env, xas_method,iatom,estate, END DO ! ispin DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) ! nspin = SIZE(mos,1) ! DO ispin = 1,nspin ! ! ortho so that one can restart for different positions (basis sets?) ! NULLIFY(mo_coeff) ! CALL get_mo_set(mo_set=mos(ispin)%mo_set, mo_coeff=mo_coeff,homo=homo) -! CALL make_basis_sm(mo_coeff,homo,matrix_s(1)%matrix,error=error) +! CALL make_basis_sm(mo_coeff,homo,matrix_s(1)%matrix) ! END DO END IF !file_exist @@ -284,15 +281,13 @@ END SUBROUTINE xas_read_restart !> \param qs_env ... !> \param xas_method ... !> \param iatom ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xas_write_restart(xas_env,xas_section,qs_env,xas_method,iatom,error) + SUBROUTINE xas_write_restart(xas_env,xas_section,qs_env,xas_method,iatom) TYPE(xas_environment_type), POINTER :: xas_env TYPE(section_vals_type), POINTER :: xas_section TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: xas_method, iatom - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xas_write_restart', & routineP = moduleN//':'//routineN @@ -316,30 +311,30 @@ SUBROUTINE xas_write_restart(xas_env,xas_section,qs_env,xas_method,iatom,error) CALL timeset(routineN,handle) failure = .FALSE. NULLIFY(mos,logger,print_key) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() CALL get_xas_env(xas_env=xas_env,occ_estate=occ_estate,xas_estate=xas_estate, & - xas_nelectron=xas_nelectron, nexc_search=nexc_search, nexc_atoms=nexc_atoms, error=error) + xas_nelectron=xas_nelectron, nexc_search=nexc_search, nexc_atoms=nexc_atoms) IF (BTEST(cp_print_key_should_output(logger%iter_info,& - xas_section,"PRINT%RESTART",used_print_key=print_key,error=error),& + xas_section,"PRINT%RESTART",used_print_key=print_key),& cp_p_file)) THEN output_unit = cp_print_key_unit_nr(logger,xas_section,& - "PRINT%PROGRAM_RUN_INFO",extension=".Log",error=error) + "PRINT%PROGRAM_RUN_INFO",extension=".Log") - CALL get_qs_env( qs_env=qs_env, mos=mos, error=error) + CALL get_qs_env( qs_env=qs_env, mos=mos) ! Open file rst_unit = -1 my_middle= 'at'//TRIM(ADJUSTL(cp_to_string(iatom))) rst_unit = cp_print_key_unit_nr(logger,xas_section,"PRINT%RESTART",& extension=".rst", file_status="REPLACE", file_action="WRITE",& - file_form="UNFORMATTED",middle_name=TRIM(my_middle), error=error) + file_form="UNFORMATTED",middle_name=TRIM(my_middle)) filename = cp_print_key_generate_filename(logger,print_key,& middle_name=TRIM(my_middle),extension=".rst",& - my_local=.FALSE.,error=error) + my_local=.FALSE.) IF(output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,T10,A,I5,A,A,/)")& @@ -362,12 +357,12 @@ SUBROUTINE xas_write_restart(xas_env,xas_section,qs_env,xas_method,iatom,error) WRITE (rst_unit) eigenvalues(1:nmo),& occupation_numbers(1:nmo) END IF - CALL cp_fm_write_unformatted(mo_coeff,rst_unit,error) + CALL cp_fm_write_unformatted(mo_coeff,rst_unit) END DO ! Close file CALL cp_print_key_finished_output(rst_unit,logger,xas_section,& - "PRINT%RESTART", error=error) + "PRINT%RESTART") END IF CALL timestop(handle) @@ -381,17 +376,15 @@ END SUBROUTINE xas_write_restart !> \param qs_env ... !> \param scf_env ... !> \param scf_control ... -!> \param error ... !> \par History !> 09-2006 MI created !> \author MI ! ***************************************************************************** - SUBROUTINE xas_initialize_rho(qs_env,scf_env,scf_control,error) + SUBROUTINE xas_initialize_rho(qs_env,scf_env,scf_control) TYPE(qs_environment_type), POINTER :: qs_env TYPE(qs_scf_env_type), POINTER :: scf_env TYPE(scf_control_type), POINTER :: scf_control - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xas_initialize_rho', & routineP = moduleN//':'//routineN @@ -417,35 +410,32 @@ SUBROUTINE xas_initialize_rho(qs_env,scf_env,scf_control,error) mos=mos,& rho=rho,& xas_env=xas_env,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho, rho_ao=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao=rho_ao) DO ispin=1,SIZE(mos) IF(ispin==1) THEN IF(xas_env%homo_occ == 0) THEN CALL get_mo_set(mos(ispin)%mo_set,nelectron=nelectron) nelectron = nelectron - 1 - CALL set_mo_set(mos(ispin)%mo_set,nelectron=nelectron,error=error) + CALL set_mo_set(mos(ispin)%mo_set,nelectron=nelectron) END IF CALL set_mo_occupation(mo_set=qs_env%mos(ispin)%mo_set, smear=scf_control%smear,& - xas_env=xas_env, error=error) + xas_env=xas_env) ELSE - CALL set_mo_occupation(mo_set=qs_env%mos(ispin)%mo_set, smear=scf_control%smear,& - error=error) + CALL set_mo_occupation(mo_set=qs_env%mos(ispin)%mo_set, smear=scf_control%smear) END IF CALL calculate_density_matrix(mo_set=mos(ispin)%mo_set,& - density_matrix=rho_ao(ispin)%matrix,error=error) + density_matrix=rho_ao(ispin)%matrix) END DO - CALL qs_rho_update_rho(rho,qs_env=qs_env, error=error) - CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.,& - error=error) + CALL qs_rho_update_rho(rho,qs_env=qs_env) + CALL qs_ks_did_change(qs_env%ks_env,rho_changed=.TRUE.) IF(scf_env%mixing_method>1) THEN - CALL get_qs_env(qs_env=qs_env,rho_atom_set=rho_atom,error=error) + CALL get_qs_env(qs_env=qs_env,rho_atom_set=rho_atom) CALL mixing_init(scf_env%mixing_method,rho,scf_env%mixing_store,& - para_env,rho_atom=rho_atom,error=error) + para_env,rho_atom=rho_atom) END IF CALL timestop(handle) @@ -457,20 +447,18 @@ END SUBROUTINE xas_initialize_rho !> \param xas_env ... !> \param mos ... !> \param matrix_s ... -!> \param error ... !> \par History !> 03-2010 MI created !> \author MI ! ***************************************************************************** - SUBROUTINE find_excited_core_orbital(xas_env,mos,matrix_s,error) + SUBROUTINE find_excited_core_orbital(xas_env,mos,matrix_s) TYPE(xas_environment_type), POINTER :: xas_env TYPE(mo_set_p_type), DIMENSION(:), & POINTER :: mos TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: matrix_s - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'find_excited_core_orbital', & routineP = moduleN//':'//routineN @@ -493,26 +481,26 @@ SUBROUTINE find_excited_core_orbital(xas_env,mos,matrix_s,error) ! Some elements from the xas_env CALL get_xas_env(xas_env=xas_env,excvec_coeff=excvec_coeff,& excvec_overlap=excvec_overlap,fm_work=fm_work,nexc_search=nexc_search,& - xas_estate=xas_estate,occ_estate=occ_estate,error=error) - CPPrecondition(ASSOCIATED(excvec_overlap),cp_failure_level,routineP,error,failure) + xas_estate=xas_estate,occ_estate=occ_estate) + CPPrecondition(ASSOCIATED(excvec_overlap),cp_failure_level,routineP,failure) CALL get_mo_set(mos(1)%mo_set, mo_coeff=mo_coeff,nao=nao,nmo=nmo,& eigenvalues=eigenvalues,occupation_numbers=occupation_numbers) ALLOCATE(vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vecbuffer = 0.0_dp ALLOCATE(vecbuffer2(1,nexc_search),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vecbuffer2 = 0.0_dp ! ** use the maximum overlap criterion to find the index of the excited orbital - CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,mo_coeff,fm_work,ncol=nmo,error=error) + CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix,mo_coeff,fm_work,ncol=nmo) CALL cp_gemm("T","N",1,xas_env%nexc_search,nao,1.0_dp,excvec_coeff,& - fm_work,0.0_dp,excvec_overlap,b_first_col=1,error=error) + fm_work,0.0_dp,excvec_overlap,b_first_col=1) CALL cp_fm_get_info ( matrix=excvec_overlap, col_indices = col_indices,& - nrow_global = m, ncol_global = n ,error=error) + nrow_global = m, ncol_global = n) CALL cp_fm_get_submatrix(excvec_overlap,vecbuffer2,1,1,& - 1,nexc_search,transpose=.FALSE.,error=error) + 1,nexc_search,transpose=.FALSE.) b_max = 0.0_dp ic_max = xas_estate @@ -533,15 +521,15 @@ SUBROUTINE find_excited_core_orbital(xas_env,mos,matrix_s,error) ! Ionization Potential iP_energy = eigenvalues(xas_estate) - CALL set_xas_env(xas_env=xas_env, xas_estate=xas_estate, ip_energy=ip_energy,error=error) + CALL set_xas_env(xas_env=xas_env, xas_estate=xas_estate, ip_energy=ip_energy) CALL cp_fm_get_submatrix(mo_coeff,vecbuffer,1,xas_estate,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) CALL cp_fm_set_submatrix(excvec_coeff,vecbuffer,1,1,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) DEALLOCATE(vecbuffer,vecbuffer2,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END SUBROUTINE find_excited_core_orbital diff --git a/src/xas_tp_scf.F b/src/xas_tp_scf.F index 1873d0831a..378e29bc57 100644 --- a/src/xas_tp_scf.F +++ b/src/xas_tp_scf.F @@ -123,14 +123,12 @@ MODULE xas_tp_scf !> \param scf_section ... !> \param converged ... !> \param should_stop ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2005 created [MI] !> \author MI ! ***************************************************************************** SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& - xas_section,scf_section,converged,should_stop,error) + xas_section,scf_section,converged,should_stop) TYPE(dft_control_type), POINTER :: dft_control TYPE(xas_environment_type), POINTER :: xas_env @@ -139,7 +137,6 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& TYPE(qs_environment_type), POINTER :: qs_env TYPE(section_vals_type), POINTER :: xas_section, scf_section LOGICAL, INTENT(OUT) :: converged, should_stop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xas_do_tp_scf', & routineP = moduleN//':'//routineN @@ -171,44 +168,43 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& NULLIFY(rho,energy,scf_control,logger, ks_env,mos,atomic_kind_set) NULLIFY(qs_charges) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() t1 = m_walltime() failure=.FALSE. converged = .TRUE. - CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,error,failure) - CPPrecondition(xas_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,error,failure) - CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,failure) + CPPrecondition(xas_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(scf_env),cp_failure_level,routineP,failure) + CPPrecondition(scf_env%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(qs_env%ref_count>0,cp_failure_level,routineP,failure) CALL get_qs_env(qs_env=qs_env,& atomic_kind_set=atomic_kind_set,& matrix_s=matrix_s,energy=energy,& qs_charges=qs_charges,& - ks_env=ks_env,para_env=para_env,& - error=error) + ks_env=ks_env,para_env=para_env) - CALL get_xas_env(xas_env, scf_control=scf_control, error=error) + CALL get_xas_env(xas_env, scf_control=scf_control) energy_only = .FALSE. output_unit=cp_print_key_unit_nr(logger,xas_section,"PRINT%PROGRAM_RUN_INFO",& - extension=".xasLog",error=error) + extension=".xasLog") IF (output_unit>0) THEN WRITE (UNIT=output_unit,FMT="(/,/,T2,A)") "XAS_TP_SCF WAVEFUNCTION OPTIMIZATION" END IF ! GAPW method must be used gapw = dft_control%qs_control%gapw - CPPrecondition(gapw,cp_failure_level,routineP,error,failure) + CPPrecondition(gapw,cp_failure_level,routineP,failure) xas_control => dft_control%xas_control - CALL cp_add_iter_level(logger%iter_info,"XAS_SCF",error=error) + CALL cp_add_iter_level(logger%iter_info,"XAS_SCF") - CALL get_qs_env(qs_env,matrix_ks=matrix_ks,rho=rho,mos=mos,error=error) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp, error=error) + CALL get_qs_env(qs_env,matrix_ks=matrix_ks,rho=rho,mos=mos) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao_kp) iter_count = 0 diis_step = .FALSE. @@ -231,36 +227,33 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& IF (output_unit > 0) CALL m_flush(output_unit) iter_count = iter_count + 1 - CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_count,error=error) + CALL cp_iterate(logger%iter_info,last=.FALSE.,iter_nr=iter_count) ! ** here qs_env%rho%rho_r and qs_env%rho%rho_g should be up to date - CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=energy_only, error=error) + CALL qs_ks_update_qs_env(qs_env, calculate_forces=.FALSE., just_energy=energy_only) SELECT CASE (scf_env%method) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown scf method method for core level spectroscopy"//& - cp_to_string(scf_env%method),error,failure) + cp_to_string(scf_env%method),failure) CASE(general_diag_method_nr) ! diagonalisation (default) scf_env%iter_count=iter_count CALL general_eigenproblem(scf_env,mos,matrix_ks,& matrix_s,scf_control,scf_section, & - diis_step,error) - CALL find_excited_core_orbital(xas_env,mos,matrix_s,error=error) + diis_step) + CALL find_excited_core_orbital(xas_env,mos,matrix_s) CALL set_mo_occupation(mo_set=mos(1)%mo_set,& smear=scf_control%smear,& - xas_env=xas_env,& - error=error) + xas_env=xas_env) CALL set_mo_occupation(mo_set=mos(2)%mo_set,& - smear=scf_control%smear,& - error=error) + smear=scf_control%smear) DO ispin=1,nspin ! does not yet handle k-points CALL calculate_density_matrix(mos(ispin)%mo_set,& - scf_env%p_mix_new(ispin,1)%matrix,& - error=error) + scf_env%p_mix_new(ispin,1)%matrix) END DO energy%kTS = 0.0_dp energy%efermi = 0.0_dp @@ -276,17 +269,17 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& CASE(direct_mixing_nr) CALL scf_env_density_mixing(scf_env%p_mix_new,& scf_env%mixing_store, rho_ao_kp, para_env, scf_env%iter_delta, scf_env%iter_count, & - diis=diis_step, error=error) + diis=diis_step) CASE(gspace_mixing_nr,pulay_mixing_nr,broyden_mixing_nr,& broyden_mixing_new_nr,multisecant_mixing_nr) ! Compute the difference p_out-p_in CALL self_consistency_check(rho_ao_kp,scf_env%p_delta,para_env,scf_env%p_mix_new,& - delta= scf_env%iter_delta, error=error) + delta= scf_env%iter_delta) CASE(no_mixing_nr) CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"unknown scf mixing method: "//& - cp_to_string(scf_env%mixing_method),error,failure) + cp_to_string(scf_env%mixing_method),failure) END SELECT t2 = m_walltime() @@ -302,7 +295,7 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& ! ** convergence check CALL external_control(should_stop,"XASSCF",target_time=qs_env%target_time,& - start_time=qs_env%start_time,error=error) + start_time=qs_env%start_time) IF (scf_env%iter_delta < scf_control%eps_scf) THEN IF (output_unit>0) THEN WRITE(UNIT=output_unit,FMT="(/,T3,A,I5,A/)")& @@ -321,13 +314,13 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& IF (exit_loop) THEN ! now, print out energies and charges corresponding to the obtained wfn ! (this actually is not 100% consistent at this point)! - CALL qs_scf_print_summary(output_unit,qs_env,error=error) - CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=iter_count,error=error) + CALL qs_scf_print_summary(output_unit,qs_env) + CALL cp_iterate(logger%iter_info,last=.TRUE.,iter_nr=iter_count) END IF ! ** Write restart file ** CALL xas_write_restart(xas_env, xas_section, qs_env, xas_control%xas_method,& - iatom,error=error) + iatom) IF (exit_loop) THEN CALL timestop(handle2) @@ -335,25 +328,24 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& END IF IF (.NOT.BTEST(cp_print_key_should_output(logger%iter_info,& - xas_section,"PRINT%ITERATION_INFO/TIME_CUMUL",error=error),cp_p_file)) t1 = m_walltime() + xas_section,"PRINT%ITERATION_INFO/TIME_CUMUL"),cp_p_file)) t1 = m_walltime() ! *** mixing methods have the new density matrix in p_mix_new IF (scf_env%mixing_method > 0) THEN DO ispin=1,nspin ! does not yet handle k-points - CALL cp_dbcsr_copy(rho_ao_kp(ispin,1)%matrix,scf_env%p_mix_new(ispin,1)%matrix,& - error=error) + CALL cp_dbcsr_copy(rho_ao_kp(ispin,1)%matrix,scf_env%p_mix_new(ispin,1)%matrix) END DO ENDIF ! ** update qs_env%rho - CALL qs_rho_update_rho(rho, qs_env=qs_env, error=error) + CALL qs_rho_update_rho(rho, qs_env=qs_env) IF(scf_env%mixing_method>=gspace_mixing_nr) THEN CALL gspace_mixing(qs_env, scf_env%mixing_method, scf_env%mixing_store, rho, para_env, & - scf_env%iter_count, error=error) + scf_env%iter_count) END IF - CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.,error=error) + CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.) CALL timestop(handle2) END DO scf_loop @@ -365,15 +357,15 @@ SUBROUTINE xas_do_tp_scf (dft_control,xas_env,iatom,scf_env,qs_env,& END IF CALL mp_sync(para_env%group) - CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.,error=error) + CALL qs_ks_did_change(ks_env,rho_changed=.TRUE.) - CALL cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,output_unit,error=error) + CALL cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,output_unit) CALL mp_sync(para_env%group) CALL cp_print_key_finished_output(output_unit,logger,xas_section,& - "PRINT%PROGRAM_RUN_INFO", error=error) - CALL cp_rm_iter_level(logger%iter_info,"XAS_SCF",error=error) + "PRINT%PROGRAM_RUN_INFO") + CALL cp_rm_iter_level(logger%iter_info,"XAS_SCF") CALL timestop(handle) @@ -387,13 +379,11 @@ END SUBROUTINE xas_do_tp_scf !> \param iatom index of the excited atom !> \param xas_section ... !> \param output_unit ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,output_unit,error) + SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,output_unit) TYPE(xas_control_type) :: xas_control TYPE(xas_environment_type), POINTER :: xas_env @@ -401,7 +391,6 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu INTEGER, INTENT(IN) :: iatom TYPE(section_vals_type), POINTER :: xas_section INTEGER, INTENT(IN) :: output_unit - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'cls_prepare_states', & routineP = moduleN//':'//routineN @@ -453,7 +442,7 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu failure=.FALSE. - CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,failure) CALL get_qs_env(qs_env,& cell=cell,& @@ -465,32 +454,31 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu particle_set=particle_set,& qs_kind_set=qs_kind_set,& para_env=para_env,& - blacs_env=blacs_env,& - error=error) + blacs_env=blacs_env) ! Some elements from the xas_env CALL get_xas_env(xas_env=xas_env,& all_vectors=all_vectors,all_evals=all_evals,& excvec_coeff=excvec_coeff,& nvirtual2=nvirtual2,xas_estate=xas_estate,& - excvec_overlap=excvec_overlap,nexc_search=nexc_search,scf_control=scf_control,error=error) - CPPrecondition(ASSOCIATED(excvec_overlap),cp_failure_level,routineP,error,failure) + excvec_overlap=excvec_overlap,nexc_search=nexc_search,scf_control=scf_control) + CPPrecondition(ASSOCIATED(excvec_overlap),cp_failure_level,routineP,failure) CALL get_mo_set(mos(1)%mo_set, mo_coeff=mo_coeff,nao=nao,& eigenvalues=eigenvalues) ALLOCATE(vecbuffer(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vecbuffer = 0.0_dp ALLOCATE(vecbuffer2(1,nao),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) vecbuffer2 = 0.0_dp natom=SIZE(particle_set,1) ALLOCATE (first_sgf(natom),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) - CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf, error=error) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) + CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf) ALLOCATE(centers_wfn(3,nexc_search),STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) centers_wfn=0.0_dp ! Possible only for emission only @@ -503,12 +491,12 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu CALL get_xas_env(xas_env=xas_env, & mykind_of_kind=mykind_of_kind, qs_loc_env=qs_loc_env,& - stogto_overlap=stogto_overlap,error=error) + stogto_overlap=stogto_overlap) CALL get_qs_loc_env(qs_loc_env=qs_loc_env,& - localized_wfn_control=localized_wfn_control,error=error) - loc_section => section_vals_get_subs_vals(xas_section,"LOCALIZE",error=error) - print_loc_section => section_vals_get_subs_vals(loc_section,"PRINT",error=error) - CALL qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin=1,error=error) + localized_wfn_control=localized_wfn_control) + loc_section => section_vals_get_subs_vals(xas_section,"LOCALIZE") + print_loc_section => section_vals_get_subs_vals(loc_section,"PRINT") + CALL qs_loc_driver(qs_env,qs_loc_env,print_loc_section,myspin=1) ra(1:3) = particle_set(iatom)%r(1:3) NULLIFY(atomic_kind) @@ -519,7 +507,7 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu CALL cp_fm_get_submatrix(mo_coeff,vecbuffer2,1,my_state,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) ! Rotate the wfn to get the eigenstate of the KS hamiltonian ! Only ispin=1 should be needed @@ -528,7 +516,7 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu eigenvalues=eigenvalues) CALL calculate_subspace_eigenvalues(mo_coeff,& matrix_ks(ispin)%matrix,eigenvalues, & - do_rotation=.TRUE.,error=error) + do_rotation=.TRUE.) END DO ! ispin !Search for the core state to be excited @@ -544,7 +532,7 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu IF(dist < 1.0_dp) THEN CALL cp_fm_get_submatrix(mo_coeff,vecbuffer,1,istate,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) sto_state_overlap=0.0_dp DO i = 1,SIZE(stogto_overlap(my_kind)%array,1) component = 0.0_dp @@ -565,9 +553,9 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu CALL get_mo_set(mos(1)%mo_set, mo_coeff=mo_coeff) CALL cp_fm_get_submatrix(mo_coeff,vecbuffer,1,xas_estate,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) CALL cp_fm_set_submatrix(excvec_coeff,vecbuffer2,1,1,& - nao,1,transpose=.TRUE.,error=error) + nao,1,transpose=.TRUE.) ! END IF @@ -584,9 +572,9 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu NULLIFY(uno_orbs,uno_evals,local_preconditioner) ALLOCATE(local_preconditioner,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL init_preconditioner(local_preconditioner,para_env=para_env,& - blacs_env=blacs_env,error=error) + blacs_env=blacs_env) CALL make_preconditioner(local_preconditioner, & precon_type=ot_precond_full_kinetic, & @@ -595,23 +583,23 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu matrix_s=matrix_s(1)%matrix,& matrix_t=kinetic(1)%matrix, & convert_precond_to_dbcsr=.TRUE.,& - mo_set=mos(1)%mo_set,energy_gap=0.2_dp,error=error) + mo_set=mos(1)%mo_set,energy_gap=0.2_dp) CALL get_xas_env(xas_env=xas_env,unoccupied_orbs=uno_orbs,& - unoccupied_evals=uno_evals,unoccupied_eps=uno_eps,unoccupied_max_iter=uno_iter,error=error) - CALL cp_fm_init_random(uno_orbs,nvirtual2,error=error) + unoccupied_evals=uno_evals,unoccupied_eps=uno_eps,unoccupied_max_iter=uno_iter) + CALL cp_fm_init_random(uno_orbs,nvirtual2) CALL ot_eigensolver(matrix_h=matrix_ks(1)%matrix,matrix_s=matrix_s(1)%matrix, & matrix_c_fm=uno_orbs,matrix_orthogonal_space_fm=mo_coeff,& preconditioner=local_preconditioner,eps_gradient=uno_eps,& - iter_max=uno_iter,size_ortho_space=nmo,error=error) + iter_max=uno_iter,size_ortho_space=nmo) CALL calculate_subspace_eigenvalues(uno_orbs,matrix_ks(1)%matrix,& - uno_evals,do_rotation=.TRUE.,error=error) - CALL destroy_preconditioner(local_preconditioner,error=error) + uno_evals,do_rotation=.TRUE.) + CALL destroy_preconditioner(local_preconditioner) DEALLOCATE(local_preconditioner,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL mp_sync(para_env%group) @@ -620,7 +608,7 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu ! Copy the final vectors in the array NULLIFY(all_vectors,all_evals) CALL get_xas_env(xas_env=xas_env,all_vectors=all_vectors,& - all_evals=all_evals,error=error) + all_evals=all_evals) CALL get_mo_set(mos(1)%mo_set, eigenvalues=eigenvalues,mo_coeff=mo_coeff,& nmo=nmo) @@ -639,11 +627,11 @@ SUBROUTINE cls_prepare_states(xas_control,xas_env,qs_env,iatom,xas_section,outpu END IF DEALLOCATE(vecbuffer,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(vecbuffer2,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) DEALLOCATE(centers_wfn,first_sgf,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) CALL timestop(handle) @@ -655,18 +643,15 @@ END SUBROUTINE cls_prepare_states !> \param xas_env the environment for XAS calculations !> \param converged ... !> \param should_stop ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2005 created [MI] !> \author MI ! ***************************************************************************** - SUBROUTINE xes_scf_once(qs_env,xas_env,converged,should_stop,error) + SUBROUTINE xes_scf_once(qs_env,xas_env,converged,should_stop) TYPE(qs_environment_type), POINTER :: qs_env TYPE(xas_environment_type), POINTER :: xas_env LOGICAL, INTENT(OUT) :: converged, should_stop - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xes_scf_once', & routineP = moduleN//':'//routineN @@ -694,42 +679,41 @@ SUBROUTINE xes_scf_once(qs_env,xas_env,converged,should_stop,error) NULLIFY(dft_control,scf_control,scf_env,matrix_ks,mos,para_env,xas_control) NULLIFY(dft_section, xas_section,scf_section,all_vectors,mo_coeff,all_evals, eigenvalues) NULLIFY(logger) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() output_unit= cp_logger_get_default_io_unit(logger) CALL timeset(routineN,handle) - CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xas_env),cp_failure_level,routineP,failure) IF(.NOT. failure) THEN CALL get_qs_env(qs_env=qs_env,dft_control=dft_control, & - matrix_ks=matrix_ks,mos=mos,para_env=para_env,error=error) + matrix_ks=matrix_ks,mos=mos,para_env=para_env) xas_control => dft_control%xas_control - CALL get_xas_env(xas_env, scf_control=scf_control, error=error) + CALL get_xas_env(xas_env, scf_control=scf_control) - dft_section => section_vals_get_subs_vals(qs_env%input,"DFT",error=error) - xas_section => section_vals_get_subs_vals(dft_section,"XAS",error=error) - scf_section => section_vals_get_subs_vals(xas_section,"SCF",error=error) + dft_section => section_vals_get_subs_vals(qs_env%input,"DFT") + xas_section => section_vals_get_subs_vals(dft_section,"XAS") + scf_section => section_vals_get_subs_vals(xas_section,"SCF") IF(xas_env%homo_occ == 0) THEN NULLIFY(scf_env) - CALL get_xas_env(xas_env,scf_env=scf_env,error=error) + CALL get_xas_env(xas_env,scf_env=scf_env) IF(.NOT. ASSOCIATED(scf_env)) THEN - CALL qs_scf_env_initialize(qs_env,scf_env, scf_control,scf_section,& - error=error) - CALL set_xas_env(xas_env,scf_env=scf_env,error=error) - CALL scf_env_release(scf_env,error=error) - CALL get_xas_env(xas_env=xas_env,scf_env=scf_env,error=error) + CALL qs_scf_env_initialize(qs_env,scf_env, scf_control,scf_section) + CALL set_xas_env(xas_env,scf_env=scf_env) + CALL scf_env_release(scf_env) + CALL get_xas_env(xas_env=xas_env,scf_env=scf_env) ELSE - CALL qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section,error=error) + CALL qs_scf_env_initialize(qs_env,scf_env,scf_control,scf_section) ENDIF CALL scf_env_do_scf(scf_env=scf_env, scf_control=scf_control, qs_env=qs_env, & - converged=converged, should_stop=should_stop, error=error) - CALL scf_env_cleanup(scf_env,error=error) + converged=converged, should_stop=should_stop) + CALL scf_env_cleanup(scf_env) END IF @@ -745,11 +729,11 @@ SUBROUTINE xes_scf_once(qs_env,xas_env,converged,should_stop,error) eigenvalues=eigenvalues) CALL calculate_subspace_eigenvalues(mo_coeff,& matrix_ks(ispin)%matrix,eigenvalues, & - do_rotation=.TRUE.,error=error) + do_rotation=.TRUE.) END DO END IF CALL get_xas_env(xas_env=xas_env,all_vectors=all_vectors,& - all_evals=all_evals,nvirtual2=nvirtual2,error=error) + all_evals=all_evals,nvirtual2=nvirtual2) CALL get_mo_set(mos(1)%mo_set, eigenvalues=eigenvalues,mo_coeff=mo_coeff, nmo=nmo) CALL cp_fm_to_fm(mo_coeff,all_vectors,ncol=nmo,& @@ -765,7 +749,7 @@ SUBROUTINE xes_scf_once(qs_env,xas_env,converged,should_stop,error) END IF nvirtual2=0 nvirtual = nmo - CALL set_xas_env(xas_env=xas_env,nvirtual=nvirtual,nvirtual2=nvirtual2,error=error) + CALL set_xas_env(xas_env=xas_env,nvirtual=nvirtual,nvirtual2=nvirtual2) END IF END IF ! failure diff --git a/src/xc/cp_linked_list_xc_deriv.F b/src/xc/cp_linked_list_xc_deriv.F index 618e95e14e..d99679848f 100644 --- a/src/xc/cp_linked_list_xc_deriv.F +++ b/src/xc/cp_linked_list_xc_deriv.F @@ -3,8 +3,8 @@ ! Copyright (C) 2000 - 2015 CP2K developers group ! !-----------------------------------------------------------------------------! -#define CP_SLL_DERIV_LESS_Q(el1,el2,error) cp_sll_deriv_less_q(el1,el2,error) -#define CP_SLL_DERIV_EQUAL_Q(el1,el2,error) ( el1%desc == el2%desc ) +#define CP_SLL_DERIV_LESS_Q(el1,el2) cp_sll_deriv_less_q(el1,el2) +#define CP_SLL_DERIV_EQUAL_Q(el1,el2) ( el1%desc == el2%desc ) ! ***************************************************************************** @@ -205,21 +205,19 @@ MODULE cp_linked_list_xc_deriv !> \brief private compare function !> \param el1 ... !> \param el2 ... -!> \param error ... !> \retval res ... ! ***************************************************************************** -FUNCTION cp_sll_deriv_less_q(el1,el2,error) RESULT(res) +FUNCTION cp_sll_deriv_less_q(el1,el2) RESULT(res) TYPE(xc_derivative_type), POINTER :: el1, el2 - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_deriv_less_q', & routineP = moduleN//':'//routineN - CPPreconditionNoFail(ASSOCIATED(el1),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(el1%split_desc),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(el2),cp_failure_level,routineP,error) - CPPreconditionNoFail(ASSOCIATED(el2%split_desc),cp_failure_level,routineP,error) + CPPreconditionNoFail(ASSOCIATED(el1),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(el1%split_desc),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(el2),cp_failure_level,routineP) + CPPreconditionNoFail(ASSOCIATED(el2%split_desc),cp_failure_level,routineP) res=SIZE(el1%split_desc) \param sll the single linked list to initialize !> \param first_el the first element of this list !> \param rest the following elements (if not given: empty) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_create(sll,first_el,rest,error) + SUBROUTINE cp_sll_xc_deriv_create(sll,first_el,rest) TYPE(cp_sll_xc_deriv_type), POINTER :: sll TYPE(xc_derivative_type), OPTIONAL, & POINTER :: first_el TYPE(cp_sll_xc_deriv_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_create', & routineP = moduleN//':'//routineN @@ -258,7 +253,7 @@ SUBROUTINE cp_sll_xc_deriv_create(sll,first_el,rest,error) IF (PRESENT(rest)) sll => rest ELSE ALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) sll%first_el => first_el NULLIFY(sll%rest) IF (PRESENT(rest)) sll%rest => rest @@ -269,8 +264,6 @@ END SUBROUTINE cp_sll_xc_deriv_create !> \brief deallocates the singly linked list starting at sll. !> Does not work if loops are present! !> \param sll the list to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed @@ -278,14 +271,13 @@ END SUBROUTINE cp_sll_xc_deriv_create !> does not deallocate the elments that are stored in the list !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_dealloc(sll,error) + SUBROUTINE cp_sll_xc_deriv_dealloc(sll) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_dealloc', & routineP = moduleN//':'//routineN - CALL cp_sll_xc_deriv_rm_all_el(sll,error) + CALL cp_sll_xc_deriv_rm_all_el(sll) END SUBROUTINE cp_sll_xc_deriv_dealloc ! * low-level * @@ -293,15 +285,12 @@ END SUBROUTINE cp_sll_xc_deriv_dealloc ! ***************************************************************************** !> \brief deallocates a node of a singly linked list (low level) !> \param sll the node to be deallocated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_dealloc_node(sll,error) + SUBROUTINE cp_sll_xc_deriv_dealloc_node(sll) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_dealloc_node', & routineP = moduleN//':'//routineN @@ -312,7 +301,7 @@ SUBROUTINE cp_sll_xc_deriv_dealloc_node(sll,error) failure=.FALSE. DEALLOCATE(sll, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END SUBROUTINE cp_sll_xc_deriv_dealloc_node ! ============= get/set ============ @@ -324,19 +313,16 @@ END SUBROUTINE cp_sll_xc_deriv_dealloc_node !> \param sll the single linked list to change !> \param first_el the element to replace the first element of this list !> \param rest the rest of the list (can be unassociated) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_set(sll,first_el,rest,error) + SUBROUTINE cp_sll_xc_deriv_set(sll,first_el,rest) TYPE(cp_sll_xc_deriv_type), POINTER :: sll TYPE(xc_derivative_type), OPTIONAL, & POINTER :: first_el TYPE(cp_sll_xc_deriv_type), OPTIONAL, & POINTER :: rest - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_set', & routineP = moduleN//':'//routineN @@ -347,9 +333,9 @@ SUBROUTINE cp_sll_xc_deriv_set(sll,first_el,rest,error) IF (.NOT.ASSOCIATED(sll)) THEN IF (PRESENT(first_el)) THEN - CALL cp_sll_xc_deriv_create(sll,first_el,rest,error) + CALL cp_sll_xc_deriv_create(sll,first_el,rest) ELSE - CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,error,failure) + CPAssert(.NOT.PRESENT(rest),cp_failure_level,routineP,failure) END IF ELSE IF (PRESENT(first_el)) sll%first_el => first_el @@ -364,13 +350,11 @@ END SUBROUTINE cp_sll_xc_deriv_set !> \param rest the rest of the list (can be unassociated) !> \param empty ... !> \param length the length of the list -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_get(sll,first_el,rest,empty,length,error) + SUBROUTINE cp_sll_xc_deriv_get(sll,first_el,rest,empty,length) TYPE(cp_sll_xc_deriv_type), POINTER :: sll TYPE(xc_derivative_type), OPTIONAL, & POINTER :: first_el @@ -378,7 +362,6 @@ SUBROUTINE cp_sll_xc_deriv_get(sll,first_el,rest,empty,length,error) POINTER :: rest LOGICAL, INTENT(out), OPTIONAL :: empty INTEGER, INTENT(out), OPTIONAL :: length - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get', & routineP = moduleN//':'//routineN @@ -388,7 +371,7 @@ SUBROUTINE cp_sll_xc_deriv_get(sll,first_el,rest,empty,length,error) failure=.FALSE. IF (.NOT.ASSOCIATED(sll)) THEN - CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.PRESENT(first_el),cp_failure_level,routineP,failure) IF (PRESENT(rest)) NULLIFY(rest) IF (PRESENT(empty)) empty=.TRUE. IF (PRESENT(length)) length=0 @@ -397,23 +380,20 @@ SUBROUTINE cp_sll_xc_deriv_get(sll,first_el,rest,empty,length,error) IF (PRESENT(rest)) rest => sll%rest IF (PRESENT(empty)) empty = .FALSE. IF (PRESENT(length)) & - length = cp_sll_xc_deriv_get_length(sll,error=error) + length = cp_sll_xc_deriv_get_length(sll) END IF END SUBROUTINE cp_sll_xc_deriv_get ! ***************************************************************************** !> \brief returns the first element stored in the list !> \param sll the single linked list to get the element from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_xc_deriv_get_first_el(sll,error) RESULT(res) + FUNCTION cp_sll_xc_deriv_get_first_el(sll) RESULT(res) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(xc_derivative_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_first_el', & @@ -424,7 +404,7 @@ FUNCTION cp_sll_xc_deriv_get_first_el(sll,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sll),cp_failure_level,routineP,failure) END IF res => sll%first_el @@ -435,8 +415,6 @@ END FUNCTION cp_sll_xc_deriv_get_first_el !> \param sll the single linked list to get the rest from !> \param iter how many times the call to rest should be iterated, !> defaults to 1; -1 means till end of the list. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -444,10 +422,9 @@ END FUNCTION cp_sll_xc_deriv_get_first_el !> \note !> split the case iter=1 to make it more optimized? ! ***************************************************************************** - FUNCTION cp_sll_xc_deriv_get_rest(sll, iter, error) RESULT(res) + FUNCTION cp_sll_xc_deriv_get_rest(sll, iter) RESULT(res) TYPE(cp_sll_xc_deriv_type), POINTER :: sll INTEGER, OPTIONAL :: iter - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_xc_deriv_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_rest', & @@ -470,7 +447,7 @@ FUNCTION cp_sll_xc_deriv_get_rest(sll, iter, error) RESULT(res) CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP, "tried to go past end in "// & CPSourceFileRef,& - error,failure) + failure) END IF END DO IF (iter==-1) THEN @@ -488,16 +465,13 @@ END FUNCTION cp_sll_xc_deriv_get_rest ! ***************************************************************************** !> \brief ... !> \param sll the single linked list to get the rest from -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_xc_deriv_get_empty(sll,error) RESULT(res) + FUNCTION cp_sll_xc_deriv_get_empty(sll) RESULT(res) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_empty', & @@ -509,8 +483,6 @@ END FUNCTION cp_sll_xc_deriv_get_empty ! ***************************************************************************** !> \brief returns the length of the list !> \param sll the list you want to know the length of -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -518,9 +490,8 @@ END FUNCTION cp_sll_xc_deriv_get_empty !> \note !> slow (O(n)) ! ***************************************************************************** - FUNCTION cp_sll_xc_deriv_get_length(sll,error) RESULT(res) + FUNCTION cp_sll_xc_deriv_get_length(sll) RESULT(res) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_length', & @@ -544,8 +515,6 @@ END FUNCTION cp_sll_xc_deriv_get_length !> \brief returns the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none @@ -553,10 +522,9 @@ END FUNCTION cp_sll_xc_deriv_get_length !> \note !> slow (O(index)) ! ***************************************************************************** - FUNCTION cp_sll_xc_deriv_get_el_at(sll,index,error) RESULT(res) + FUNCTION cp_sll_xc_deriv_get_el_at(sll,index) RESULT(res) TYPE(cp_sll_xc_deriv_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error TYPE(xc_derivative_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_get_el_at', & @@ -568,14 +536,14 @@ FUNCTION cp_sll_xc_deriv_get_el_at(sll,index,error) RESULT(res) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==-1) THEN - pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=-1) ELSE - pos => cp_sll_xc_deriv_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) res => pos%first_el END FUNCTION cp_sll_xc_deriv_get_el_at @@ -586,19 +554,16 @@ END FUNCTION cp_sll_xc_deriv_get_el_at !> \param index the position of the element (stating at 1) !> -1 means at the end !> \param value the new element -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_set_el_at(sll,index,value,error) + SUBROUTINE cp_sll_xc_deriv_set_el_at(sll,index,value) TYPE(cp_sll_xc_deriv_type), POINTER :: sll INTEGER, INTENT(in) :: index TYPE(xc_derivative_type), POINTER :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_set_el_at', & routineP = moduleN//':'//routineN @@ -609,11 +574,11 @@ SUBROUTINE cp_sll_xc_deriv_set_el_at(sll,index,value,error) failure=.FALSE. IF (index==-1) THEN - pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=-1) ELSE - pos => cp_sll_xc_deriv_get_rest(sll, iter=index-1,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=index-1) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) pos%first_el => value END SUBROUTINE cp_sll_xc_deriv_set_el_at @@ -625,18 +590,15 @@ END SUBROUTINE cp_sll_xc_deriv_set_el_at !> moves the iterator to the next element !> \param iterator iterator that moves along the list !> \param el_att the actual element (valid only if the function returns true) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> none !> \author Fawzi Mohamed ! ***************************************************************************** - FUNCTION cp_sll_xc_deriv_next(iterator,el_att,error) RESULT(res) + FUNCTION cp_sll_xc_deriv_next(iterator,el_att) RESULT(res) TYPE(cp_sll_xc_deriv_type), POINTER :: iterator TYPE(xc_derivative_type), OPTIONAL, & POINTER :: el_att - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_next', & @@ -658,18 +620,15 @@ END FUNCTION cp_sll_xc_deriv_next !> \param sll the single linked list point at the beginning of which !> you want to add the element !> \param el the element to add -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_insert_el(sll,el,error) + SUBROUTINE cp_sll_xc_deriv_insert_el(sll,el) TYPE(cp_sll_xc_deriv_type), POINTER :: sll TYPE(xc_derivative_type), POINTER :: el - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_insert_el', & routineP = moduleN//':'//routineN @@ -679,24 +638,21 @@ SUBROUTINE cp_sll_xc_deriv_insert_el(sll,el,error) NULLIFY(newSlot) CALL cp_sll_xc_deriv_create(newSlot,first_el=el,& - rest=sll,error=error) + rest=sll) sll => newSlot END SUBROUTINE cp_sll_xc_deriv_insert_el ! ***************************************************************************** !> \brief remove the first element of the linked list !> \param sll the list whose first element has to be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> fast (O(1)) ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_rm_first_el(sll,error) + SUBROUTINE cp_sll_xc_deriv_rm_first_el(sll) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_rm_first_el', & routineP = moduleN//':'//routineN @@ -709,12 +665,12 @@ SUBROUTINE cp_sll_xc_deriv_rm_first_el(sll,error) IF (ASSOCIATED(sll)) THEN sll => sll%rest - CALL cp_sll_xc_deriv_dealloc_node(node_to_rm,error=error) + CALL cp_sll_xc_deriv_dealloc_node(node_to_rm) ELSE CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& routineP,"tried to remove first el of an empty list in "//& CPSourceFileRef,& - error,failure) + failure) END IF END SUBROUTINE cp_sll_xc_deriv_rm_first_el @@ -724,19 +680,16 @@ END SUBROUTINE cp_sll_xc_deriv_rm_first_el !> \param el the new element !> \param index the position of the element (stating at 1). !> If it is -1, it means at end -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_insert_el_at(sll,el,index,error) + SUBROUTINE cp_sll_xc_deriv_insert_el_at(sll,el,index) TYPE(cp_sll_xc_deriv_type), POINTER :: sll TYPE(xc_derivative_type), POINTER :: el INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_insert_el_at', & routineP = moduleN//':'//routineN @@ -747,15 +700,15 @@ SUBROUTINE cp_sll_xc_deriv_insert_el_at(sll,el,index,error) failure=.FALSE. IF (index==1) THEN - CALL cp_sll_xc_deriv_insert_el(sll,el,error=error) + CALL cp_sll_xc_deriv_insert_el(sll,el) ELSE IF (index==-1) THEN - pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=-1) ELSE - pos => cp_sll_xc_deriv_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_xc_deriv_insert_el(pos%rest,el,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_xc_deriv_insert_el(pos%rest,el) END IF END SUBROUTINE cp_sll_xc_deriv_insert_el_at @@ -763,18 +716,15 @@ END SUBROUTINE cp_sll_xc_deriv_insert_el_at !> \brief removes the element at the given index !> \param sll the list you get the element from !> \param index the position of the element (stating at 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> slow (O(index)) ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_rm_el_at(sll,index,error) + SUBROUTINE cp_sll_xc_deriv_rm_el_at(sll,index) TYPE(cp_sll_xc_deriv_type), POINTER :: sll INTEGER, INTENT(in) :: index - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_rm_el_at', & routineP = moduleN//':'//routineN @@ -785,35 +735,32 @@ SUBROUTINE cp_sll_xc_deriv_rm_el_at(sll,index,error) failure=.FALSE. IF (cp_debug) THEN - CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,error,failure) + CPPrecondition(index>0.OR.index==-1,cp_failure_level,routineP,failure) END IF IF (index==1) THEN - CALL cp_sll_xc_deriv_rm_first_el(sll,error=error) + CALL cp_sll_xc_deriv_rm_first_el(sll) ELSE IF (index==-1) THEN - pos => cp_sll_xc_deriv_get_rest(sll, iter=-1,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=-1) ELSE - pos => cp_sll_xc_deriv_get_rest(sll, iter=index-2,error=error) + pos => cp_sll_xc_deriv_get_rest(sll, iter=index-2) END IF - CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,error,failure) - CALL cp_sll_xc_deriv_rm_first_el(pos%rest,error=error) + CPPrecondition(ASSOCIATED(pos),cp_failure_level,routineP,failure) + CALL cp_sll_xc_deriv_rm_first_el(pos%rest) END IF END SUBROUTINE cp_sll_xc_deriv_rm_el_at ! ***************************************************************************** !> \brief removes all the elements from the list !> \param sll the list that should be removed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> none !> \author Fawzi Mohamed !> \note !> check more? ! ***************************************************************************** - SUBROUTINE cp_sll_xc_deriv_rm_all_el(sll,error) + SUBROUTINE cp_sll_xc_deriv_rm_all_el(sll) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_rm_all_el', & routineP = moduleN//':'//routineN @@ -824,7 +771,7 @@ SUBROUTINE cp_sll_xc_deriv_rm_all_el(sll,error) DO IF (.NOT.ASSOCIATED(actual_node)) EXIT next_node => actual_node%rest - CALL cp_sll_xc_deriv_dealloc_node(actual_node,error=error) + CALL cp_sll_xc_deriv_dealloc_node(actual_node) actual_node => next_node END DO NULLIFY(sll) @@ -834,16 +781,13 @@ END SUBROUTINE cp_sll_xc_deriv_rm_all_el !> \brief returns a newly allocated array with the same contents as !> the linked list !> \param sll the list to trasform in array -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_xc_deriv_to_array(sll,error) RESULT(res) +FUNCTION cp_sll_xc_deriv_to_array(sll) RESULT(res) TYPE(cp_sll_xc_deriv_type), POINTER :: sll - TYPE(cp_error_type), INTENT(inout) :: error TYPE(xc_derivative_p_type), & DIMENSION(:), POINTER :: res @@ -856,14 +800,14 @@ FUNCTION cp_sll_xc_deriv_to_array(sll,error) RESULT(res) failure=.FALSE. - len=cp_sll_xc_deriv_get_length(sll,error) + len=cp_sll_xc_deriv_get_length(sll) ALLOCATE(res(len),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) iter => sll DO i=1,len res(i)%deriv => iter%first_el - IF (.NOT.(cp_sll_xc_deriv_next(iter,error=error).OR.i==len)) THEN - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (.NOT.(cp_sll_xc_deriv_next(iter).OR.i==len)) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF END DO END FUNCTION cp_sll_xc_deriv_to_array @@ -871,17 +815,14 @@ END FUNCTION cp_sll_xc_deriv_to_array ! ***************************************************************************** !> \brief returns a linked list with the same contents as the given array !> \param array the array you want to copy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** -FUNCTION cp_sll_xc_deriv_from_array(array,error) RESULT(res) +FUNCTION cp_sll_xc_deriv_from_array(array) RESULT(res) TYPE(xc_derivative_p_type), & DIMENSION(:), INTENT(in) :: array - TYPE(cp_error_type), INTENT(inout) :: error TYPE(cp_sll_xc_deriv_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'cp_sll_xc_deriv_from_array', & @@ -893,14 +834,12 @@ FUNCTION cp_sll_xc_deriv_from_array(array,error) RESULT(res) NULLIFY(res,last_el) IF (SIZE(array)>0) THEN CALL cp_sll_xc_deriv_create(res,& - first_el=array(1)%deriv,& - error=error) + first_el=array(1)%deriv) last_el => res END IF DO i=2,SIZE(array) CALL cp_sll_xc_deriv_create(last_el%rest,& - first_el=array(i)%deriv,& - error=error) + first_el=array(i)%deriv) last_el => last_el%rest END DO END FUNCTION cp_sll_xc_deriv_from_array @@ -914,21 +853,18 @@ END FUNCTION cp_sll_xc_deriv_from_array !> \param did_insert true if it did insert the element !> \param pos node where the element has been inserted (or of the same !> element that was already in the list) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_xc_deriv_insert_ordered(sll,el,insert_equals,& - did_insert,pos,error) + did_insert,pos) TYPE(cp_sll_xc_deriv_type), POINTER :: sll TYPE(xc_derivative_type), POINTER :: el LOGICAL, INTENT(in), OPTIONAL :: insert_equals LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_xc_deriv_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_sll_xc_deriv_insert_ordered', & @@ -945,13 +881,13 @@ SUBROUTINE cp_sll_xc_deriv_insert_ordered(sll,el,insert_equals,& IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_xc_deriv_create(sll,first_el=el,error=error) + CALL cp_sll_xc_deriv_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll - ELSE IF (.NOT.cp_sll_deriv_less_q(sll%first_el,el,error=error)) THEN + ELSE IF (.NOT.cp_sll_deriv_less_q(sll%first_el,el)) THEN IF (PRESENT(pos)) pos=>sll - IF (i_eq.OR.cp_sll_deriv_less_q(el,sll%first_el,error=error)) THEN - CALL cp_sll_xc_deriv_insert_el(sll,el,error=error) + IF (i_eq.OR.cp_sll_deriv_less_q(el,sll%first_el)) THEN + CALL cp_sll_xc_deriv_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll END IF @@ -959,22 +895,22 @@ SUBROUTINE cp_sll_xc_deriv_insert_ordered(sll,el,insert_equals,& iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) + CALL cp_sll_xc_deriv_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT - ELSE IF (.NOT.cp_sll_deriv_less_q(iter%rest%first_el,el,error=error)) THEN + ELSE IF (.NOT.cp_sll_deriv_less_q(iter%rest%first_el,el)) THEN IF (PRESENT(pos)) pos=>iter - IF (i_eq.OR. cp_sll_deriv_less_q(el,iter%rest%first_el,error=error)) THEN - CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) + IF (i_eq.OR. cp_sll_deriv_less_q(el,iter%rest%first_el)) THEN + CALL cp_sll_xc_deriv_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_xc_deriv_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_xc_deriv_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_xc_deriv_insert_ordered @@ -989,14 +925,12 @@ END SUBROUTINE cp_sll_xc_deriv_insert_ordered !> (defaults to false) !> \param did_insert ... !> \param pos ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 07.2002 created [fawzi] !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE cp_sll_xc_deriv_insert_ordered2(sll,el,compare_function,& - insert_equals,did_insert,pos,error) + insert_equals,did_insert,pos) TYPE(cp_sll_xc_deriv_type), POINTER :: sll TYPE(xc_derivative_type), POINTER :: el INTERFACE @@ -1012,7 +946,6 @@ END FUNCTION compare_function LOGICAL, INTENT(out), OPTIONAL :: did_insert TYPE(cp_sll_xc_deriv_type), OPTIONAL, & POINTER :: pos - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'cp_sll_xc_deriv_insert_ordered2', & @@ -1030,7 +963,7 @@ END FUNCTION compare_function IF (PRESENT(insert_equals)) i_eq=insert_equals IF (.NOT.ASSOCIATED(sll)) THEN - CALL cp_sll_xc_deriv_create(sll,first_el=el,error=error) + CALL cp_sll_xc_deriv_create(sll,first_el=el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest RETURN @@ -1038,7 +971,7 @@ END FUNCTION compare_function comp=compare_function(sll%first_el,el) IF (comp>=0) THEN IF (i_eq.OR.comp/=0) THEN - CALL cp_sll_xc_deriv_insert_el(sll,el,error=error) + CALL cp_sll_xc_deriv_insert_el(sll,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>sll%rest END IF @@ -1046,7 +979,7 @@ END FUNCTION compare_function iter => sll DO IF (.NOT.ASSOCIATED(iter%rest)) THEN - CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) + CALL cp_sll_xc_deriv_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest EXIT @@ -1054,15 +987,15 @@ END FUNCTION compare_function comp=compare_function(iter%rest%first_el,el) IF (comp>=0) THEN IF (i_eq.OR. comp/=0) THEN - CALL cp_sll_xc_deriv_insert_el(iter%rest,el,error=error) + CALL cp_sll_xc_deriv_insert_el(iter%rest,el) IF (PRESENT(did_insert)) did_insert=.TRUE. IF (PRESENT(pos)) pos=>iter%rest END IF EXIT END IF - CPInvariant(cp_sll_xc_deriv_next(iter,error=error),cp_failure_level,routineP,error,failure) + CPInvariant(cp_sll_xc_deriv_next(iter),cp_failure_level,routineP,failure) END DO - CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(iter),cp_failure_level,routineP,failure) END IF END SUBROUTINE cp_sll_xc_deriv_insert_ordered2 @@ -1078,8 +1011,8 @@ END SUBROUTINE cp_sll_xc_deriv_insert_ordered2 ! arrayEl = "%deriv" ! common_dir = "../common" ! defines = -! "#define CP_SLL_DERIV_LESS_Q(el1,el2,error) cp_sll_deriv_less_q(el1,el2,error) -! #define CP_SLL_DERIV_EQUAL_Q(el1,el2,error) ( el1%desc == el2%desc ) +! "#define CP_SLL_DERIV_LESS_Q(el1,el2) cp_sll_deriv_less_q(el1,el2) +! #define CP_SLL_DERIV_EQUAL_Q(el1,el2) ( el1%desc == el2%desc ) ! " ! equalQ = "CP_SLL_DERIV_EQUAL_Q" ! lessQ = "cp_sll_deriv_less_q" @@ -1101,10 +1034,10 @@ END SUBROUTINE cp_sll_xc_deriv_insert_ordered2 ! character(len=*),parameter :: routineN='cp_sll_deriv_less_q',& ! routineP=moduleN//':'//routineN ! -! CPPreconditionNoFail(associated(el1),cp_failure_level,routineP,error) -! CPPreconditionNoFail(associated(el1%split_desc),cp_failure_level,routineP,error) -! CPPreconditionNoFail(associated(el2),cp_failure_level,routineP,error) -! CPPreconditionNoFail(associated(el2%split_desc),cp_failure_level,routineP,error) +! CPPreconditionNoFail(associated(el1),cp_failure_level,routineP) +! CPPreconditionNoFail(associated(el1%split_desc),cp_failure_level,routineP) +! CPPreconditionNoFail(associated(el2),cp_failure_level,routineP) +! CPPreconditionNoFail(associated(el2%split_desc),cp_failure_level,routineP) ! res=size(el1%split_desc) \param xc_section parameters selecting the xc and the method used to !> calculate it !> \param pw_pool the pool for the grids -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param compute_virial should the virial be computed... if so virial_xc must be present !> \param virial_xc for calculating the GGA part of the stress !> \author fawzi ! ***************************************************************************** SUBROUTINE xc_vxc_pw_create1(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,xc_section,& - pw_pool,error,compute_virial,virial_xc) + pw_pool,compute_virial,virial_xc) TYPE(pw_p_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau, rho_r, & rho_g, tau REAL(KIND=dp), INTENT(out) :: exc TYPE(section_vals_type), POINTER :: xc_section TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: compute_virial REAL(KIND=dp), DIMENSION(3, 3), & INTENT(OUT) :: virial_xc @@ -132,27 +129,26 @@ SUBROUTINE xc_vxc_pw_create1(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,xc_section,& failure=.FALSE. - CPPrecondition(ASSOCIATED(rho_r),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(vxc_rho),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(vxc_tau),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_r),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(vxc_rho),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(vxc_tau),cp_failure_level,routineP,failure) CALL section_vals_val_get(xc_section,"FUNCTIONAL_ROUTINE",& - i_val=f_routine,error=error) + i_val=f_routine) SELECT CASE(f_routine) CASE(xc_new_f_routine) CALL xc_vxc_pw_create(vxc_rho=vxc_rho, vxc_tau=vxc_tau,tau=tau,& rho_r=rho_r, rho_g=rho_g, exc=exc, xc_section=xc_section,& - pw_pool=pw_pool,error=error,compute_virial=compute_virial,virial_xc=virial_xc) + pw_pool=pw_pool,compute_virial=compute_virial,virial_xc=virial_xc) CASE(xc_debug_new_routine) CALL xc_vxc_pw_create_debug(vxc_rho=vxc_rho, vxc_tau=vxc_tau,tau=tau,& rho_r=rho_r, rho_g=rho_g, exc=exc, xc_section=xc_section,& - pw_pool=pw_pool, error=error) + pw_pool=pw_pool) CASE(xc_test_lsd_f_routine) CALL xc_vxc_pw_create_test_lsd(vxc_rho=vxc_rho, vxc_tau=vxc_tau,& tau=tau, rho_r=rho_r, rho_g=rho_g, exc=exc, & - xc_section=xc_section, pw_pool=pw_pool,& - error=error) + xc_section=xc_section, pw_pool=pw_pool) CASE default END SELECT @@ -175,20 +171,17 @@ END SUBROUTINE xc_vxc_pw_create1 !> \param exc the xc energy !> \param xc_section which functional to calculate, and how !> \param pw_pool the pool for the grids -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed !> \note !> for debugging only: leaks, and non parallel ! ***************************************************************************** SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& - exc,xc_section, pw_pool, error) + exc,xc_section, pw_pool) TYPE(pw_p_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau, rho_r, & rho_g, tau REAL(KIND=dp), INTENT(out) :: exc TYPE(section_vals_type), POINTER :: xc_section TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_vxc_pw_create_test_lsd', & routineP = moduleN//':'//routineN @@ -218,11 +211,11 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& bo = rho_r(1)%pw%pw_grid%bounds_local ALLOCATE(rho2_r(2), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,2 NULLIFY(rho2_r(ispin)%pw) CALL pw_pool_create_pw(pw_pool,rho2_r(ispin)%pw,in_space=REALSPACE,& - use_data=REALDATA3D, error=error) + use_data=REALDATA3D) END DO DO k=bo(1,3),bo(2,3) DO j=bo(1,2),bo(2,2) @@ -236,11 +229,11 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& IF (ASSOCIATED(tau)) THEN ALLOCATE(tau2(2),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,2 NULLIFY(tau2(ispin)%pw) CALL pw_pool_create_pw(pw_pool,tau2(ispin)%pw,in_space=REALSPACE,& - use_data=REALDATA3D, error=error) + use_data=REALDATA3D) END DO DO k=bo(1,3),bo(2,3) @@ -259,20 +252,20 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& tau=tau,xc_section=xc_section,& pw_pool=pw_pool,rho_set=rho_set1,& deriv_set=dSet1, deriv_order=1,& - needs_basic_components=.FALSE.,error=error) + needs_basic_components=.FALSE.) CALL xc_vxc_pw_create(rho_r=rho_r, rho_g=rho_g,tau=tau,& vxc_rho=vxc_rho,vxc_tau=vxc_tau, exc=exc, xc_section=xc_section,& pw_pool=pw_pool, & - error=error, compute_virial=compute_virial,virial_xc=virial_xc) + compute_virial=compute_virial,virial_xc=virial_xc) PRINT *, "did calculate xc (lda)" PRINT *, "about to calculate xc (lsd)" CALL xc_rho_set_and_dset_create(rho_set=rho_set2,deriv_set=dSet2,& rho_r=rho2_r, rho_g=rho2_g,tau=tau2, xc_section=xc_section,& pw_pool=pw_pool, deriv_order=1,& - needs_basic_components=.FALSE.,error=error) + needs_basic_components=.FALSE.) CALL xc_vxc_pw_create(rho_r=rho2_r, rho_g=rho2_g,tau=tau2,& vxc_rho=vxc_rho2,vxc_tau=vxc_tau2,exc=exc2, xc_section=xc_section,& - pw_pool=pw_pool, error=error, compute_virial=compute_virial, virial_xc=virial_xc) + pw_pool=pw_pool,compute_virial=compute_virial, virial_xc=virial_xc) PRINT *, "did calculate xc (new)" PRINT *, "at (0,0,0) rho_r=",rho_r(1)%pw%cr3d(0,0,0),& "rho2_r(1)=",rho2_r(1)%pw%cr3d(0,0,0),& @@ -382,8 +375,8 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& END DO END DO PRINT *,"diff exc=",ABS(exc-exc2),"diff vxc=",maxdiff -! CPPostcondition(maxdiff<5.e-11,cp_failure_level,routineP,error,failure) -! CPPostcondition(ABS(exc-exc2)<1.e-14,cp_failure_level,routineP,error,failure) +! CPPostcondition(maxdiff<5.e-11,cp_failure_level,routineP,failure) +! CPPostcondition(ABS(exc-exc2)<1.e-14,cp_failure_level,routineP,failure) IF (ASSOCIATED(vxc_tau)) THEN PRINT *,"calc diff on vxc_tau" @@ -412,31 +405,28 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& PRINT *,"diff exc=",ABS(exc-exc2),"diff vxc_tau=",maxdiff END IF deriv_iter => dSet1%derivs - DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv,error=error)) + DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv)) CALL xc_derivative_get(deriv,& - split_desc=split_desc,deriv_data=pot,& - error=error) + split_desc=split_desc,deriv_data=pot) SELECT CASE (SIZE(split_desc)) CASE(0) filename="e_0.bindata" - deriv2 => xc_dset_get_derivative(dSet2, "", error=error) + deriv2 => xc_dset_get_derivative(dSet2, "") CASE(1) filename="e_"//TRIM(split_desc(1))//".bindata" IF (split_desc(1)=="rho") THEN - deriv2 => xc_dset_get_derivative(dSet2, "(rhoa)", error=error) + deriv2 => xc_dset_get_derivative(dSet2, "(rhoa)") ELSEIF (split_desc(1)=="tau") THEN - deriv2 => xc_dset_get_derivative(dSet2,"(tau_a)",error=error) + deriv2 => xc_dset_get_derivative(dSet2,"(tau_a)") ELSEIF (split_desc(1)=="norm_drho") THEN - deriv2 => xc_dset_get_derivative(dSet2, "(norm_drhoa)", error=error) - deriv3 => xc_dset_get_derivative(dSet2, "(norm_drho)", error=error) + deriv2 => xc_dset_get_derivative(dSet2, "(norm_drhoa)") + deriv3 => xc_dset_get_derivative(dSet2, "(norm_drho)") IF (ASSOCIATED(deriv3)) THEN IF (ASSOCIATED(deriv2)) THEN CALL xc_derivative_get(deriv2,& - deriv_data=pot2,& - error=error) + deriv_data=pot2) CALL xc_derivative_get(deriv3,& - deriv_data=pot3,& - error=error) + deriv_data=pot3) pot2=pot2+pot3 ELSE deriv2 => deriv3 @@ -444,14 +434,13 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& NULLIFY(deriv3,pot2,pot3) END IF ELSE - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END IF CASE default - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT CALL xc_derivative_get(deriv2,& - deriv_data=pot2,& - error=error) + deriv_data=pot2) PRINT *, "checking ",filename maxDiff=0.0_dp DO k=bo(1,3),bo(2,3) @@ -475,17 +464,16 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& CLOSE (unit=120) END DO deriv_iter => dSet2%derivs - DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv,error=error)) + DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv)) CALL xc_derivative_get(deriv,& - split_desc=split_desc,deriv_data=pot,& - error=error) + split_desc=split_desc,deriv_data=pot) SELECT CASE (SIZE(split_desc)) CASE(0) filename="e_0-2.bindata" CASE(1) filename="e_"//TRIM(split_desc(1))//"-2.bindata" CASE default - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT OPEN (unit=120,file=TRIM(filename),status="unknown",& access='sequential',& @@ -493,25 +481,22 @@ SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho,vxc_tau,rho_r,rho_g,tau,& WRITE (unit=120) pot(:,:,bo(2,3)) CLOSE (unit=120) END DO - CALL xc_rho_set_release(rho_set1,error=error) - CALL xc_rho_set_release(rho_set2,error=error) - CALL xc_dset_release(dSet2,error=error) - CALL xc_dset_release(dSet1, error=error) + CALL xc_rho_set_release(rho_set1) + CALL xc_rho_set_release(rho_set2) + CALL xc_dset_release(dSet2) + CALL xc_dset_release(dSet1) DO ispin=1,2 - CALL pw_pool_give_back_pw(pw_pool,rho2_r(ispin)%pw,& - error=error) - CALL pw_pool_give_back_pw(pw_pool,vxc_rho2(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(pw_pool,rho2_r(ispin)%pw) + CALL pw_pool_give_back_pw(pw_pool,vxc_rho2(ispin)%pw) IF (ASSOCIATED(vxc_tau2)) THEN - CALL pw_pool_give_back_pw(pw_pool,vxc_tau2(ispin)%pw,& - error=error) + CALL pw_pool_give_back_pw(pw_pool,vxc_tau2(ispin)%pw) END IF END DO DEALLOCATE(vxc_rho2,rho2_r,rho2_g, stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) IF (ASSOCIATED(vxc_tau2)) THEN DEALLOCATE(vxc_tau2,stat=stat) - CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) + CPPostcondition(stat==0,cp_warning_level,routineP,failure) END IF END SUBROUTINE xc_vxc_pw_create_test_lsd @@ -533,20 +518,17 @@ END SUBROUTINE xc_vxc_pw_create_test_lsd !> \param exc the xc energy !> \param xc_section which functional should be used, and how to do it !> \param pw_pool the pool for the grids -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed !> \note !> for debugging only. ! ***************************************************************************** SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& - xc_section, pw_pool,error) + xc_section, pw_pool) TYPE(pw_p_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau, rho_r, & rho_g, tau REAL(KIND=dp), INTENT(out) :: exc TYPE(section_vals_type), POINTER :: xc_section TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_vxc_pw_create_debug', & routineP = moduleN//':'//routineN @@ -570,7 +552,7 @@ SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& failure=.FALSE. NULLIFY(dSet1,rho_set1,split_desc,pot,& deriv) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() bo = rho_r(1)%pw%pw_grid%bounds_local @@ -578,7 +560,7 @@ SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& tau=tau,xc_section=xc_section,& pw_pool=pw_pool,rho_set=rho_set1,& deriv_set=dSet1, deriv_order=1,& - needs_basic_components=.FALSE.,error=error) + needs_basic_components=.FALSE.) ! outputs 0,:,: plane IF (bo(1,1)<=0.AND.0<=bo(2,1)) THEN @@ -641,17 +623,16 @@ SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& END IF deriv_iter => dSet1%derivs - DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv,error=error)) + DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv)) CALL xc_derivative_get(deriv,& - split_desc=split_desc,deriv_data=pot,& - error=error) + split_desc=split_desc,deriv_data=pot) SELECT CASE (SIZE(split_desc)) CASE(0) filename="e_0.bindata" CASE(1) filename="e_"//TRIM(split_desc(1))//".bindata" CASE default - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT OPEN (unit=120,file=TRIM(filename),status="unknown",& access='sequential',& @@ -665,7 +646,7 @@ SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& rho_r=rho_r, rho_g=rho_g,tau=tau,& exc=exc, xc_section=xc_section,& pw_pool=pw_pool,& - error=error,compute_virial=compute_virial,virial_xc=virial_xc) + compute_virial=compute_virial,virial_xc=virial_xc) ! outputs 0,:,: plane IF (bo(1,1)<=0.AND.0<=bo(2,1)) THEN @@ -714,17 +695,16 @@ SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& END IF deriv_iter => dSet1%derivs - DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv,error=error)) + DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv)) CALL xc_derivative_get(deriv,& - split_desc=split_desc,deriv_data=pot,& - error=error) + split_desc=split_desc,deriv_data=pot) SELECT CASE (SIZE(split_desc)) CASE(0) filename=" e_0" CASE(1) filename=" e_"//TRIM(split_desc(1)) CASE default - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT WRITE (unit=cp_logger_get_default_unit_nr(logger),& fmt="(a,'=',e11.4)",advance="no") & @@ -784,17 +764,16 @@ SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& END IF deriv_iter => dSet1%derivs - DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv,error=error)) + DO WHILE (cp_sll_xc_deriv_next(deriv_iter,el_att=deriv)) CALL xc_derivative_get(deriv,& - split_desc=split_desc,deriv_data=pot,& - error=error) + split_desc=split_desc,deriv_data=pot) SELECT CASE (SIZE(split_desc)) CASE(0) filename=" e_0" CASE(1) filename=" e_"//TRIM(split_desc(1)) CASE default - CPPrecondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT WRITE (unit=cp_logger_get_default_unit_nr(logger),& fmt="(a,'=',e11.4)",advance="no") & @@ -810,8 +789,8 @@ SUBROUTINE xc_vxc_pw_create_debug(vxc_rho,vxc_tau,rho_r,rho_g,tau,exc,& END IF END IF - CALL xc_dset_release(dSet1, error=error) - CALL xc_rho_set_release(rho_set1,error=error) + CALL xc_dset_release(dSet1) + CALL xc_rho_set_release(rho_set1) END SUBROUTINE xc_vxc_pw_create_debug ! ***************************************************************************** @@ -833,8 +812,6 @@ END SUBROUTINE xc_vxc_pw_create_debug !> \param needs_basic_components if the basic components of the arguments !> should be kept in rho set (a basic component is for example drho !> when with lda a functional needs norm_drho) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> if any of the functionals is gradient corrected the full gradient is @@ -842,7 +819,7 @@ END SUBROUTINE xc_vxc_pw_create_debug ! ***************************************************************************** SUBROUTINE xc_rho_set_and_dset_create(rho_set,deriv_set,deriv_order,& rho_r,rho_g,tau,xc_section,pw_pool,& - needs_basic_components,error) + needs_basic_components) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set @@ -851,7 +828,6 @@ SUBROUTINE xc_rho_set_and_dset_create(rho_set,deriv_set,deriv_order,& TYPE(section_vals_type), POINTER :: xc_section TYPE(pw_pool_type), POINTER :: pw_pool LOGICAL, INTENT(in) :: needs_basic_components - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_set_and_dset_create', & routineP = moduleN//':'//routineN @@ -863,38 +839,35 @@ SUBROUTINE xc_rho_set_and_dset_create(rho_set,deriv_set,deriv_order,& CALL timeset(routineN,handle) failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) nspins=SIZE(rho_r) lsd=(nspins/=1) - xc_fun_sections => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL",& - error=error) + xc_fun_sections => section_vals_get_subs_vals(xc_section,"XC_FUNCTIONAL") - CALL xc_dset_create(deriv_set, pw_pool, error=error) + CALL xc_dset_create(deriv_set, pw_pool) CALL xc_rho_set_create(rho_set,& rho_r(1)%pw%pw_grid%bounds_local,& - rho_cutoff=section_get_rval(xc_section,"density_cutoff",error),& - drho_cutoff=section_get_rval(xc_section,"gradient_cutoff",error),& - tau_cutoff=section_get_rval(xc_section,"tau_cutoff",error),& - error=error) + rho_cutoff=section_get_rval(xc_section,"density_cutoff"),& + drho_cutoff=section_get_rval(xc_section,"gradient_cutoff"),& + tau_cutoff=section_get_rval(xc_section,"tau_cutoff")) CALL xc_rho_set_update(rho_set, rho_r, rho_g, tau, & - xc_functionals_get_needs(xc_fun_sections,lsd,needs_basic_components,error),& - section_get_ival(xc_section,"XC_GRID%XC_DERIV",error),& - section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO",error),& - pw_pool, error=error) + xc_functionals_get_needs(xc_fun_sections,lsd,needs_basic_components),& + section_get_ival(xc_section,"XC_GRID%XC_DERIV"),& + section_get_ival(xc_section,"XC_GRID%XC_SMOOTH_RHO"),& + pw_pool) CALL xc_functionals_eval(xc_fun_sections, & lsd=lsd,& rho_set=rho_set, & deriv_set=deriv_set,& - deriv_order=deriv_order, & - error=error) + deriv_order=deriv_order) CALL timestop(handle) @@ -915,12 +888,10 @@ END SUBROUTINE xc_rho_set_and_dset_create !> \param e_0 value of e_0, if given it is assumed that pot is the derivative !> wrt. to rho, and needs the dsmooth*e_0 contribution !> \param e_0_scale_factor ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** SUBROUTINE smooth_cutoff(pot,rho,rhoa,rhob,rho_cutoff,& - rho_smooth_cutoff_range, e_0, e_0_scale_factor,error) + rho_smooth_cutoff_range, e_0, e_0_scale_factor) REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: pot, rho, rhoa, rhob REAL(kind=dp), INTENT(in) :: rho_cutoff, & @@ -928,7 +899,6 @@ SUBROUTINE smooth_cutoff(pot,rho,rhoa,rhob,rho_cutoff,& REAL(kind=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: e_0 REAL(kind=dp), INTENT(in), OPTIONAL :: e_0_scale_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'smooth_cutoff', & routineP = moduleN//':'//routineN @@ -940,7 +910,7 @@ SUBROUTINE smooth_cutoff(pot,rho,rhoa,rhob,rho_cutoff,& rho_smooth_cutoff, rho_smooth_cutoff_2, rho_smooth_cutoff_range_2 failure=.FALSE. - CPPrecondition(ASSOCIATED(pot),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(pot),cp_failure_level,routineP,failure) bo(1,:)=LBOUND(pot) bo(2,:)=UBOUND(pot) my_e_0_scale_factor=1.0_dp @@ -951,7 +921,7 @@ SUBROUTINE smooth_cutoff(pot,rho,rhoa,rhob,rho_cutoff,& IF (rho_smooth_cutoff_range>0.0_dp) THEN IF (PRESENT(e_0)) THEN - CPPrecondition(ASSOCIATED(e_0),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(e_0),cp_failure_level,routineP,failure) IF (ASSOCIATED(rho)) THEN !$omp parallel do default(none) shared(bo,e_0,pot,rho,& !$omp rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2,& @@ -1048,8 +1018,8 @@ SUBROUTINE smooth_cutoff(pot,rho,rhoa,rhob,rho_cutoff,& END DO END DO ELSE - CPPrecondition(ASSOCIATED(rhoa),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rhob),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rhoa),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rhob),cp_failure_level,routineP,failure) !$omp parallel do default(none) shared(bo,pot,& !$omp rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2,& !$omp rho_smooth_cutoff_range_2,rhoa,rhob)& @@ -1097,8 +1067,6 @@ END SUBROUTINE smooth_cutoff !> used only with meta functionals) !> \param xc_section which functional to calculate, and how to do it !> \param pw_pool the pool for the grids -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \param compute_virial ... !> \param virial_xc ... !> \par History @@ -1115,13 +1083,12 @@ END SUBROUTINE smooth_cutoff !> energy should be kept consistent with xc_exc_calc ! ***************************************************************************** SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& - pw_pool,error,compute_virial,virial_xc) + pw_pool,compute_virial,virial_xc) TYPE(pw_p_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau REAL(KIND=dp), INTENT(out) :: exc TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_r, rho_g, tau TYPE(section_vals_type), POINTER :: xc_section TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: compute_virial REAL(KIND=dp), DIMENSION(3, 3), & INTENT(OUT) :: virial_xc @@ -1172,15 +1139,15 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& pw_grid => rho_r(1)%pw%pw_grid - CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(vxc_rho),cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.ASSOCIATED(vxc_tau),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(vxc_rho),cp_failure_level,routineP,failure) + CPPrecondition(.NOT.ASSOCIATED(vxc_tau),cp_failure_level,routineP,failure) nspins=SIZE(rho_r) - CPPrecondition(ASSOCIATED(rho_r(SIZE(rho_r))%pw),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_r(SIZE(rho_r))%pw),cp_failure_level,routineP,failure) lsd=(nspins/=1) IF (lsd) THEN - CPPrecondition(nspins==2,cp_failure_level,routineP,error,failure) + CPPrecondition(nspins==2,cp_failure_level,routineP,failure) END IF use_virial=compute_virial @@ -1193,29 +1160,27 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& deriv_order=1, rho_r=rho_r, rho_g=rho_g, tau=tau,& xc_section=xc_section,& pw_pool=pw_pool,& - needs_basic_components=.TRUE.,& - error=error) + needs_basic_components=.TRUE.) CALL section_vals_val_get(xc_section,"XC_GRID%XC_DERIV",& - i_val=xc_deriv_method_id,error=error) + i_val=xc_deriv_method_id) CALL section_vals_val_get(xc_section,"XC_GRID%XC_SMOOTH_RHO",& - i_val=xc_rho_smooth_id,error=error) + i_val=xc_rho_smooth_id) CALL section_vals_val_get(xc_section,"DENSITY_SMOOTH_CUTOFF_RANGE",& - r_val=density_smooth_cut_range,error=error) + r_val=density_smooth_cut_range) CALL xc_rho_set_get(rho_set,rho_cutoff=rho_cutoff,& - drho_cutoff=drho_cutoff, error=error) + drho_cutoff=drho_cutoff) has_tau=.FALSE. has_laplace = .FALSE. ! check for unknown derivatives n_deriv=0 pos => deriv_set%derivs - DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att,error=error)) + DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att)) CALL xc_derivative_get(deriv_att,order=order,& - desc=desc,& - error=error) + desc=desc) IF (order==1) THEN IF (lsd) THEN SELECT CASE(desc) @@ -1238,7 +1203,7 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& "unknown functional derivative (LSD): '"//& TRIM(desc)//"' in "//& CPSourceFileRef,& - error,failure) + failure) END SELECT ELSE SELECT CASE(desc) @@ -1255,7 +1220,7 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& "unknown functional derivative (LDA): '"//& TRIM(desc)//"' in "//& CPSourceFileRef,& - error,failure) + failure) END SELECT END IF END IF @@ -1263,62 +1228,58 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& IF (.NOT.failure) THEN ALLOCATE(vxc_rho(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(vxc_rho(ispin)%pw) END DO CALL xc_rho_set_get(rho_set,rho=rho,rhoa=rhoa,rhob=rhob,& - can_return_null=.TRUE., error=error) + can_return_null=.TRUE.) ! recover the vxc arrays IF (lsd) THEN - deriv_att => xc_dset_get_derivative(deriv_set, "(rhoa)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rhoa)") IF (ASSOCIATED(deriv_att)) THEN CALL pw_create(vxc_rho(1)%pw,pw_grid=pw_grid,& cr3d_ptr=deriv_att%deriv_data,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) NULLIFY(deriv_att%deriv_data) ELSE CALL pw_pool_create_pw(pw_pool,vxc_rho(1)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_zero(vxc_rho(1)%pw, error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(vxc_rho(1)%pw) END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(rhob)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rhob)") IF (ASSOCIATED(deriv_att)) THEN CALL pw_create(vxc_rho(2)%pw,pw_grid=pw_grid,& cr3d_ptr=deriv_att%deriv_data,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) NULLIFY(deriv_att%deriv_data) ELSE CALL pw_pool_create_pw(pw_pool,vxc_rho(2)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_zero(vxc_rho(2)%pw, error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(vxc_rho(2)%pw) END IF ELSE - deriv_att => xc_dset_get_derivative(deriv_set, "(rho)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rho)") IF (ASSOCIATED(deriv_att)) THEN CALL pw_create(vxc_rho(1)%pw,pw_grid=pw_grid,& cr3d_ptr=deriv_att%deriv_data,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) NULLIFY(deriv_att%deriv_data) ELSE CALL pw_pool_create_pw(pw_pool,vxc_rho(1)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,error=error) - CALL pw_zero(vxc_rho(1)%pw, error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(vxc_rho(1)%pw) END IF END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(rho)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rho)") IF (ASSOCIATED(deriv_att)) THEN IF (lsd) THEN ! otherwise already taken care in vxc recovery - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) !$omp parallel do default(none) shared(bo,vxc_rho,deriv_data)& !$omp private(k,j,i) DO k = bo(1,3), bo(2,3) @@ -1329,23 +1290,21 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& END DO END DO END DO - CALL pw_pool_give_back_cr3d(pw_pool,deriv_att%deriv_data,& - error=error) + CALL pw_pool_give_back_cr3d(pw_pool,deriv_att%deriv_data) NULLIFY(deriv_att%deriv_data) END IF END IF ! rhoa,rhob already taken care of in vxc recovery - deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drho)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) CALL xc_rho_set_get(rho_set,norm_drho=norm_drho,& drho=drho,drhoa=drhoa,drhob=drhob,rho_cutoff=rho_cutoff,& drho_cutoff=drho_cutoff,& - can_return_null=.TRUE., error=error) + can_return_null=.TRUE.) IF (ASSOCIATED(norm_drho)) THEN !$omp parallel do default(none) shared(bo,deriv_data,norm_drho,drho_cutoff)& @@ -1371,8 +1330,8 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& END DO END DO ELSE - CPPrecondition(ASSOCIATED(drhoa),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(drhob),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(drhoa),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(drhob),cp_failure_level,routineP,failure) !$omp parallel do default(none) shared(bo,deriv_data,drhoa,drhob,drho_cutoff)& !$omp private(k,j,i,ndr) DO k = bo(1,3), bo(2,3) @@ -1388,13 +1347,12 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& END IF IF (ASSOCIATED(drho).AND.ASSOCIATED(drho(1)%array)) THEN - CPPrecondition(ASSOCIATED(deriv_data),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(deriv_data),cp_failure_level,routineP,failure) IF (use_virial) THEN CALL pw_pool_create_pw(pw_pool,virial_pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_zero(virial_pw, error=error) + in_space=REALSPACE) + CALL pw_zero(virial_pw) DO idir=1,3 DO k=bo(1,3),bo(2,3) DO j=bo(1,2),bo(2,2) @@ -1410,14 +1368,13 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& virial_xc(jdir,idir) = virial_xc(idir,jdir) END DO END DO - CALL pw_pool_give_back_pw(pw_pool,virial_pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,virial_pw) END IF ! use_virial DO idir=1,3 CALL pw_create(pw_to_deriv_rho(idir)%pw,pw_grid=pw_grid,& cr3d_ptr=drho(idir)%array,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) - CPPrecondition(ASSOCIATED(drho(idir)%array),cp_failure_level,routineP,error,failure) + use_data=REALDATA3D,in_space=REALSPACE) + CPPrecondition(ASSOCIATED(drho(idir)%array),cp_failure_level,routineP,failure) !$omp parallel do default(none) shared(bo,deriv_data,drho,idir)& !$omp private(k,j,i) DO k=bo(1,3),bo(2,3) @@ -1433,9 +1390,8 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& IF (use_virial) THEN CALL pw_pool_create_pw(pw_pool,virial_pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_zero(virial_pw, error=error) + in_space=REALSPACE) + CALL pw_zero(virial_pw) DO idir=1,3 DO k=bo(1,3),bo(2,3) DO j=bo(1,2),bo(2,2) @@ -1451,12 +1407,11 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& virial_xc(jdir,idir) = virial_xc(idir,jdir) END DO END DO - CALL pw_pool_give_back_pw(pw_pool,virial_pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,virial_pw) END IF ! use_virial DO idir=1,3 CALL pw_pool_create_pw(pw_pool,pw_to_deriv_rho(idir)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) !$omp parallel do default(none) shared(bo,deriv_data,& !$omp pw_to_deriv_rho,drhoa,drhob,idir)& !$omp private(k,j,i,my_rho) @@ -1471,7 +1426,7 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& END DO END IF - CALL pw_pool_give_back_cr3d(pw_pool, deriv_att%deriv_data, error=error) + CALL pw_pool_give_back_cr3d(pw_pool, deriv_att%deriv_data) END IF @@ -1480,24 +1435,23 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& IF (lsd) THEN IF (ispin==1) THEN CALL xc_rho_set_get(rho_set,drhoa=drho_spin,& - can_return_null=.TRUE.,error=error) + can_return_null=.TRUE.) CALL xc_rho_set_get(rho_set,norm_drhoa=norm_drho_spin,& - can_return_null=.TRUE., error=error) + can_return_null=.TRUE.) ELSE CALL xc_rho_set_get(rho_set,drhob=drho_spin,& - can_return_null=.TRUE.,error=error) + can_return_null=.TRUE.) CALL xc_rho_set_get(rho_set,norm_drhob=norm_drho_spin,& - can_return_null=.TRUE., error=error) + can_return_null=.TRUE.) END IF - deriv_att => xc_dset_get_derivative(deriv_set, norm_drho_spin_name(ispin),error=error) + deriv_att => xc_dset_get_derivative(deriv_set, norm_drho_spin_name(ispin)) IF (ASSOCIATED(deriv_att)) THEN - CPPrecondition(lsd,cp_failure_level,routineP,error,failure) - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + CPPrecondition(lsd,cp_failure_level,routineP,failure) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) CALL pw_create(tmp_r,pw_grid,& use_data=REALDATA3D,in_space=REALSPACE,& - cr3d_ptr=deriv_data, error=error) + cr3d_ptr=deriv_data) IF (ASSOCIATED(norm_drho_spin)) THEN !$omp parallel do default(none) shared(bo,deriv_data,norm_drho_spin,drho_cutoff)& @@ -1528,9 +1482,8 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& IF (use_virial) THEN CALL pw_pool_create_pw(pw_pool,virial_pw,& use_data=REALDATA3D,& - in_space=REALSPACE,& - error=error) - CALL pw_zero(virial_pw, error=error) + in_space=REALSPACE) + CALL pw_zero(virial_pw) DO idir=1,3 DO k=bo(1,3),bo(2,3) DO j=bo(1,2),bo(2,2) @@ -1546,15 +1499,15 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& virial_xc(jdir,idir) = virial_xc(idir,jdir) END DO END DO - CALL pw_pool_give_back_pw(pw_pool,virial_pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,virial_pw) END IF ! use_virial vxc_to_deriv(ispin)%pw => tmp_r NULLIFY(tmp_r,deriv_att%deriv_data) DO idir=1,3 - CPPrecondition(ASSOCIATED(drho_spin(idir)%array),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(vxc_to_deriv(ispin)%pw%cr3d),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(drho_spin(idir)%array),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(vxc_to_deriv(ispin)%pw%cr3d),cp_failure_level,routineP,failure) !$omp parallel do default(none) shared(bo,deriv_data,drho_spin,& !$omp ispin,idir,vxc_to_deriv,drho_cutoff)& !$omp private(k,j,i) @@ -1569,13 +1522,12 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& CALL pw_create(pw_to_deriv(idir)%pw,pw_grid=pw_grid,& cr3d_ptr=drho_spin(idir)%array,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) + use_data=REALDATA3D,in_space=REALSPACE) NULLIFY(drho_spin(idir)%array) END DO dealloc_pw_to_deriv=.TRUE. - CALL pw_pool_give_back_pw(pw_pool,vxc_to_deriv(ispin)%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,vxc_to_deriv(ispin)%pw) END IF ! deriv_att END IF ! LSD @@ -1593,10 +1545,9 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& END IF ELSE DO idir=1,3 - CALL pw_axpy(pw_to_deriv_rho(idir)%pw,pw_to_deriv(idir)%pw, error=error) + CALL pw_axpy(pw_to_deriv_rho(idir)%pw,pw_to_deriv(idir)%pw) IF (ispin==2) THEN - CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv_rho(idir)%pw,& - error=error) + CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv_rho(idir)%pw) END IF END DO END IF @@ -1606,8 +1557,7 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& ! partial integration IF (xc_deriv_method_id/=xc_deriv_pw) THEN CALL pw_spline_scale_deriv(pw_to_deriv,& - transpose=.TRUE.,& - error=error) + transpose=.TRUE.) END IF IF (xc_deriv_method_id==xc_deriv_pw.OR.& @@ -1616,8 +1566,7 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& IF (.NOT.ASSOCIATED(vxc_g)) THEN CALL pw_pool_create_pw(pw_pool,vxc_g,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) zero_result=.TRUE. ELSE zero_result=.FALSE. @@ -1628,43 +1577,41 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& tmp_g => vxc_g ELSE CALL pw_pool_create_pw(pw_pool,tmp_g,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) END IF - CALL pw_transfer ( pw_to_deriv(idir)%pw, tmp_g , error=error) + CALL pw_transfer ( pw_to_deriv(idir)%pw, tmp_g) SELECT CASE(xc_deriv_method_id) CASE (xc_deriv_pw) - CALL pw_derive ( tmp_g, nd(:,idir) , error=error) + CALL pw_derive ( tmp_g, nd(:,idir)) CASE (xc_deriv_spline2) - CALL pw_spline2_interpolate_values_g(tmp_g,error=error) - CALL pw_spline2_deriv_g ( tmp_g, idir=idir, error=error ) + CALL pw_spline2_interpolate_values_g(tmp_g) + CALL pw_spline2_deriv_g ( tmp_g, idir=idir) CASE (xc_deriv_spline3) - CALL pw_spline3_interpolate_values_g(tmp_g,error=error) - CALL pw_spline3_deriv_g ( tmp_g, idir=idir, error=error ) + CALL pw_spline3_interpolate_values_g(tmp_g) + CALL pw_spline3_deriv_g ( tmp_g, idir=idir) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (zero_result .AND. idir==1) THEN NULLIFY(tmp_g) ELSE - CALL pw_axpy ( tmp_g, vxc_g , error=error) - CALL pw_pool_give_back_pw(pw_pool,tmp_g,error=error) + CALL pw_axpy ( tmp_g, vxc_g) + CALL pw_pool_give_back_pw(pw_pool,tmp_g) END IF IF(dealloc_pw_to_deriv) THEN - CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv(idir)%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv(idir)%pw) END IF END DO ! transfer vxc in real space CALL pw_pool_create_pw(pw_pool, tmp_r,& - use_data=REALDATA3D, in_space=REALSPACE,& - error=error) - CALL pw_transfer ( vxc_g, tmp_r , error=error) - CALL pw_axpy ( tmp_r, vxc_rho(ispin)%pw , error=error) - CALL pw_pool_give_back_pw(pw_pool, tmp_r, error=error) - CALL pw_pool_give_back_pw(pw_pool,vxc_g,error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_transfer ( vxc_g, tmp_r) + CALL pw_axpy ( tmp_r, vxc_rho(ispin)%pw) + CALL pw_pool_give_back_pw(pw_pool, tmp_r) + CALL pw_pool_give_back_pw(pw_pool,vxc_g) ELSE tmp_r => vxc_rho(ispin)%pw DO idir=1,3 @@ -1672,24 +1619,24 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& CASE (xc_deriv_spline2_smooth) CALL pw_nn_deriv_r ( pw_in=pw_to_deriv(idir)%pw,& pw_out=tmp_r,coeffs=spline2_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_spline3_smooth) CALL pw_nn_deriv_r ( pw_in=pw_to_deriv(idir)%pw,& pw_out=tmp_r,coeffs=spline3_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_nn10_smooth) CALL pw_nn_deriv_r ( pw_in=pw_to_deriv(idir)%pw,& pw_out=tmp_r,coeffs=nn10_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_nn50_smooth) CALL pw_nn_deriv_r ( pw_in=pw_to_deriv(idir)%pw,& pw_out=tmp_r,coeffs=nn50_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (dealloc_pw_to_deriv) THEN - CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv(idir)%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv(idir)%pw) END IF END DO NULLIFY(tmp_r) @@ -1701,33 +1648,29 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Stress tensor not available for Laplace functionals.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF nd_laplace = RESHAPE((/2,0,0,0,2,0,0,0,2/),(/3,3/)) IF(lsd) THEN IF( ispin == 1) THEN - deriv_att => xc_dset_get_derivative(deriv_set, "(laplace_rhoa)", error=error) - CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,error,failure) - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(laplace_rhoa)") + CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,failure) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) ELSE - deriv_att => xc_dset_get_derivative(deriv_set, "(laplace_rhob)", error=error) - CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,error,failure) - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(laplace_rhob)") + CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,failure) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) END IF ELSE - deriv_att => xc_dset_get_derivative(deriv_set, "(laplace_rho)", error=error) - CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,error,failure) - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(laplace_rho)") + CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,failure) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) END IF DO idir=1,3 CALL pw_pool_create_pw(pw_pool,pw_to_deriv(idir)%pw,& - use_data=REALDATA3D,in_space=REALSPACE,& - error=error) - CALL pw_zero(pw_to_deriv(idir)%pw, error=error) + use_data=REALDATA3D,in_space=REALSPACE) + CALL pw_zero(pw_to_deriv(idir)%pw) !$omp parallel do default(none) shared(bo,deriv_data,& !$omp pw_to_deriv,idir)& !$omp private(k,j,i) @@ -1739,28 +1682,26 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& END DO END DO CALL pw_pool_create_pw(pw_pool,tmp_g,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(tmp_g, error=error) - CALL pw_transfer ( pw_to_deriv(idir)%pw, tmp_g , error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL pw_zero(tmp_g) + CALL pw_transfer ( pw_to_deriv(idir)%pw, tmp_g) SELECT CASE(xc_deriv_method_id) CASE (xc_deriv_pw) - CALL pw_derive ( tmp_g, nd_laplace(:,idir) , error=error) + CALL pw_derive ( tmp_g, nd_laplace(:,idir)) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT ! Add this to the potential CALL pw_pool_create_pw(pw_pool, tmp_r,& - use_data=REALDATA3D, in_space=REALSPACE,& - error=error) - CALL pw_zero(tmp_r, error=error) - CALL pw_transfer ( tmp_g, tmp_r , error=error) - - CALL pw_axpy ( tmp_r, vxc_rho(ispin)%pw , error=error) - CALL pw_pool_give_back_pw(pw_pool, tmp_r, error=error) - CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv(idir)%pw,error=error) - CALL pw_pool_give_back_pw(pw_pool,tmp_g,error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(tmp_r) + CALL pw_transfer ( tmp_g, tmp_r) + + CALL pw_axpy ( tmp_r, vxc_rho(ispin)%pw) + CALL pw_pool_give_back_pw(pw_pool, tmp_r) + CALL pw_pool_give_back_pw(pw_pool,pw_to_deriv(idir)%pw) + CALL pw_pool_give_back_pw(pw_pool,tmp_g) END DO END IF @@ -1768,69 +1709,64 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& IF (pw_grid%spherical) THEN ! filter vxc CALL pw_pool_create_pw(pw_pool,vxc_g,& - use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE,& - error=error) - CALL pw_transfer ( vxc_rho(ispin)%pw, vxc_g , error=error) - CALL pw_transfer ( vxc_g,vxc_rho(ispin)%pw , error=error) - CALL pw_pool_give_back_pw(pw_pool,vxc_g,error=error) + use_data=COMPLEXDATA1D,in_space=RECIPROCALSPACE) + CALL pw_transfer ( vxc_rho(ispin)%pw, vxc_g) + CALL pw_transfer ( vxc_g,vxc_rho(ispin)%pw) + CALL pw_pool_give_back_pw(pw_pool,vxc_g) END IF CALL smooth_cutoff(pot=vxc_rho(ispin)%pw%cr3d,rho=rho,rhoa=rhoa,rhob=rhob,& rho_cutoff=rho_cutoff*density_smooth_cut_range,& - rho_smooth_cutoff_range=density_smooth_cut_range,& - error=error) + rho_smooth_cutoff_range=density_smooth_cut_range) ! final smoothing if rho was smoothed IF (xc_rho_smooth_id/=xc_rho_no_smooth) THEN CALL pw_pool_create_pw(pw_pool, tmp_r,& - use_data=REALDATA3D, in_space=REALSPACE,& - error=error) - CALL pw_zero(tmp_r, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(tmp_r) SELECT CASE(xc_rho_smooth_id) CASE (xc_rho_spline2_smooth) CALL pw_nn_smear_r(pw_in=vxc_rho(ispin)%pw,pw_out=tmp_r,& - coeffs=spline2_coeffs,error=error) + coeffs=spline2_coeffs) CASE (xc_rho_spline3_smooth) CALL pw_nn_smear_r(pw_in=vxc_rho(ispin)%pw,pw_out=tmp_r,& - coeffs=spline3_coeffs,error=error) + coeffs=spline3_coeffs) CASE (xc_rho_nn10) CALL pw_nn_smear_r(pw_in=vxc_rho(ispin)%pw,pw_out=tmp_r,& - coeffs=nn10_coeffs,error=error) + coeffs=nn10_coeffs) CASE (xc_rho_nn50) CALL pw_nn_smear_r(pw_in=vxc_rho(ispin)%pw,pw_out=tmp_r,& - coeffs=nn50_coeffs,error=error) + coeffs=nn50_coeffs) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT deriv_data => vxc_rho(ispin)%pw%cr3d vxc_rho(ispin)%pw%cr3d => tmp_r%cr3d tmp_r%cr3d => deriv_data - CALL pw_pool_give_back_pw(pw_pool,tmp_r,error=error) + CALL pw_pool_give_back_pw(pw_pool,tmp_r) END IF END DO DO idir=1,3 - CPPostcondition(.NOT.ASSOCIATED(pw_to_deriv(idir)%pw),cp_warning_level,routineP,error,failure) - CPPostcondition(.NOT.ASSOCIATED(pw_to_deriv_rho(idir)%pw),cp_warning_level,routineP,error,failure) + CPPostcondition(.NOT.ASSOCIATED(pw_to_deriv(idir)%pw),cp_warning_level,routineP,failure) + CPPostcondition(.NOT.ASSOCIATED(pw_to_deriv_rho(idir)%pw),cp_warning_level,routineP,failure) END DO ! 0-deriv -> value of exc ! this has to be kept consistent with xc_exc_calc IF (n_deriv>0) THEN - deriv_att => xc_dset_get_derivative(deriv_set, "", error=error) - CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,error,failure) - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "") + CPPrecondition(ASSOCIATED(deriv_att),cp_failure_level,routineP,failure) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) CALL pw_create(tmp_r,pw_grid,& use_data=REALDATA3D,in_space=REALSPACE,& - cr3d_ptr=deriv_data, error=error) + cr3d_ptr=deriv_data) NULLIFY(tmp_r%cr3d) - CALL pw_release(tmp_r,error=error) + CALL pw_release(tmp_r) CALL smooth_cutoff(pot=deriv_data,rho=rho,rhoa=rhoa,rhob=rhob,& rho_cutoff=rho_cutoff,& - rho_smooth_cutoff_range=density_smooth_cut_range,& - error=error) + rho_smooth_cutoff_range=density_smooth_cut_range) exc = accurate_sum ( deriv_data )*pw_grid%dvol IF ( pw_grid%para%mode == PW_MODE_DISTRIBUTED ) THEN @@ -1840,76 +1776,71 @@ SUBROUTINE xc_vxc_pw_create(vxc_rho,vxc_tau,exc,rho_r,rho_g,tau,xc_section,& exc=0.0_dp END IF - CALL xc_rho_set_release(rho_set, pw_pool=pw_pool, error=error) + CALL xc_rho_set_release(rho_set, pw_pool=pw_pool) ! tau part IF (has_tau) THEN IF (use_virial) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Stress tensor not available for Meta-functionals.", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF ALLOCATE(vxc_tau(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspins NULLIFY(vxc_tau(ispin)%pw) END DO IF (lsd) THEN - deriv_att => xc_dset_get_derivative(deriv_set, "(tau_a)", error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(tau_a)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) CALL pw_create(vxc_tau(1)%pw,pw_grid,& use_data=REALDATA3D,in_space=REALSPACE,& - cr3d_ptr=deriv_data, error=error) + cr3d_ptr=deriv_data) NULLIFY(deriv_att%deriv_data) END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(tau_b)", error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(tau_b)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) CALL pw_create(vxc_tau(2)%pw,pw_grid,& use_data=REALDATA3D,in_space=REALSPACE,& - cr3d_ptr=deriv_data, error=error) + cr3d_ptr=deriv_data) NULLIFY(deriv_att%deriv_data) END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(tau)", error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(tau)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) IF (ASSOCIATED(vxc_tau(1)%pw)) THEN DO ispin=1,2 - CPPrecondition(ASSOCIATED(vxc_tau(ispin)%pw),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(vxc_tau(ispin)%pw),cp_failure_level,routineP,failure) tmp_cr3d => vxc_tau(ispin)%pw%cr3d CALL daxpy(npoints,1.0_dp,deriv_data,1,tmp_cr3d,1) END DO ELSE CALL pw_create(vxc_tau(1)%pw,pw_grid,& use_data=REALDATA3D,in_space=REALSPACE,& - cr3d_ptr=deriv_data, error=error) + cr3d_ptr=deriv_data) NULLIFY(deriv_att%deriv_data) CALL pw_pool_create_pw(pw_pool, vxc_tau(2)%pw,& - use_data=REALDATA3D, in_space=REALSPACE,& - error=error) - CALL pw_copy(vxc_tau(1)%pw,vxc_tau(2)%pw, error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy(vxc_tau(1)%pw,vxc_tau(2)%pw) END IF END IF ELSE - deriv_att => xc_dset_get_derivative(deriv_set, "(tau)", error=error) - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,& - error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(tau)") + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) CALL pw_create(vxc_tau(1)%pw,pw_grid,& use_data=REALDATA3D,in_space=REALSPACE,& - cr3d_ptr=deriv_data, error=error) + cr3d_ptr=deriv_data) NULLIFY(deriv_att%deriv_data) END IF DO ispin=1,nspins - CPPostcondition(ASSOCIATED(vxc_tau(ispin)%pw),cp_failure_level,routineP,error,failure) + CPPostcondition(ASSOCIATED(vxc_tau(ispin)%pw),cp_failure_level,routineP,failure) END DO END IF - CALL xc_dset_release(deriv_set, error=error) + CALL xc_dset_release(deriv_set) END IF CALL timestop(handle) @@ -1924,8 +1855,6 @@ END SUBROUTINE xc_vxc_pw_create !> \param tau ... !> \param xc_section ... !> \param pw_pool ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval exc ... !> \par History !> 11.2003 created [fawzi] @@ -1933,12 +1862,11 @@ END SUBROUTINE xc_vxc_pw_create !> \note !> has to be kept consistent with xc_vxc_create ! ***************************************************************************** -FUNCTION xc_exc_calc(rho_r,rho_g,tau,xc_section, pw_pool,& - error) RESULT(exc) +FUNCTION xc_exc_calc(rho_r,rho_g,tau,xc_section, pw_pool)& + RESULT(exc) TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_r, rho_g, tau TYPE(section_vals_type), POINTER :: xc_section TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error REAL(kind=dp) :: exc CHARACTER(len=*), PARAMETER :: routineN = 'xc_exc_calc', & @@ -1963,29 +1891,28 @@ FUNCTION xc_exc_calc(rho_r,rho_g,tau,xc_section, pw_pool,& deriv_set=deriv_set,deriv_order=0,& rho_r=rho_r,rho_g=rho_g,tau=tau,xc_section=xc_section,& pw_pool=pw_pool,& - needs_basic_components=.FALSE.,error=error) - deriv => xc_dset_get_derivative(deriv_set,"",error=error) + needs_basic_components=.FALSE.) + deriv => xc_dset_get_derivative(deriv_set,"") IF (ASSOCIATED(deriv)) THEN - CALL xc_derivative_get(deriv, deriv_data=e_0, error=error) + CALL xc_derivative_get(deriv, deriv_data=e_0) CALL section_vals_val_get(xc_section,"DENSITY_CUTOFF",& - r_val=rho_cutoff,error=error) + r_val=rho_cutoff) CALL section_vals_val_get(xc_section,"DENSITY_SMOOTH_CUTOFF_RANGE",& - r_val=density_smooth_cut_range,error=error) + r_val=density_smooth_cut_range) CALL smooth_cutoff(pot=e_0,rho=rho_set%rho,& rhoa=rho_set%rhoa,rhob=rho_set%rhob,& rho_cutoff=rho_cutoff,& - rho_smooth_cutoff_range=density_smooth_cut_range,& - error=error) + rho_smooth_cutoff_range=density_smooth_cut_range) exc = accurate_sum ( e_0 )*rho_r(1)%pw%pw_grid%dvol IF ( rho_r(1)%pw%pw_grid%para%mode == PW_MODE_DISTRIBUTED ) THEN CALL mp_sum ( exc, rho_r(1)%pw%pw_grid%para%group ) END IF - CALL xc_rho_set_release(rho_set, pw_pool=pw_pool, error=error) - CALL xc_dset_release(deriv_set, error=error) + CALL xc_rho_set_release(rho_set, pw_pool=pw_pool) + CALL xc_dset_release(deriv_set) END IF CALL timestop(handle) END FUNCTION xc_exc_calc @@ -2008,8 +1935,6 @@ END FUNCTION xc_exc_calc !> \param vxg ... !> \param tddfpt_fac factor that multiplies the crossterms (tddfpt triplets !> on a closed shell sistem it should be -1, defaults to 1) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \note !> The old version of this routine was smarter: it handled split_desc(1) !> and split_desc(2) separatly, thus the code automatically handled all @@ -2028,7 +1953,7 @@ END FUNCTION xc_exc_calc !> look to the old version. [fawzi] ! ***************************************************************************** SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & - pw_pool, xc_section, gapw, vxg, tddfpt_fac, error) + pw_pool, xc_section, gapw, vxg, tddfpt_fac) TYPE(pw_p_type), DIMENSION(:), POINTER :: v_xc TYPE(xc_derivative_set_type), POINTER :: deriv_set @@ -2039,7 +1964,6 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & REAL(kind=dp), DIMENSION(:, :, :, :), & OPTIONAL, POINTER :: vxg REAL(kind=dp), INTENT(in), OPTIONAL :: tddfpt_fac - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_calc_2nd_deriv', & routineP = moduleN//':'//routineN @@ -2078,24 +2002,24 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & my_gapw = .FALSE. IF (PRESENT(gapw)) my_gapw = gapw - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho1_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(v_xc),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho1_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(v_xc),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,failure) IF (my_gapw) THEN - CPPrecondition(PRESENT(vxg),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(vxg),cp_failure_level,routineP,failure) END IF CALL section_vals_val_get(xc_section,"XC_GRID%XC_DERIV",& - i_val=xc_deriv_method_id,error=error) - CALL xc_rho_set_get(rho_set,drho_cutoff=gradient_cut,error=error) + i_val=xc_deriv_method_id) + CALL xc_rho_set_get(rho_set,drho_cutoff=gradient_cut) nspins = SIZE(v_xc) lsd = ASSOCIATED(rho_set%rhoa) fac = 0.0_dp IF (PRESENT(tddfpt_fac)) fac=tddfpt_fac ALLOCATE(tmp_r(nspins), tmp_r2(nspins), tmp_a(nspins), tmp_b(nspins),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1, nspins NULLIFY(tmp_r(ispin)%pw, tmp_r2(ispin)%pw, tmp_a(ispin)%pw, tmp_b(nspins)%pw) END DO @@ -2106,10 +2030,10 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & gradient_f=.FALSE. ! check for unknown derivatives pos => deriv_set%derivs - DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att,error=error)) + DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att)) unknown_deriv=.FALSE. CALL xc_derivative_get(deriv_att,order=order,& - desc=desc, split_desc=split_desc, error=error) + desc=desc, split_desc=split_desc) SELECT CASE(order) CASE(1) IF (lsd) THEN @@ -2177,7 +2101,7 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & "unknown functional derivative (LSD="//TRIM(cp_to_string(lsd))//& "): '"//TRIM(desc)//"' in "//& CPSourceFileRef,& - error,failure) + failure) END DO IF (lsd) THEN @@ -2186,44 +2110,42 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & ! UNrestricted case ! !-------------------! - CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b, error=error) + CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b) IF (gradient_f) THEN - CALL xc_rho_set_get(rho_set, drhoa=drhoa, drhob=drhob, error=error) - CALL xc_rho_set_get(rho1_set,drhoa=drho1a, drhob=drho1b, error=error) + CALL xc_rho_set_get(rho_set, drhoa=drhoa, drhob=drhob) + CALL xc_rho_set_get(rho1_set,drhoa=drho1a, drhob=drho1b) DO ispin=1, nspins IF (ASSOCIATED(pw_pool)) THEN CALL pw_pool_create_pw(pw_pool,tmp_a(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(tmp_a(ispin)%pw, error=error) + in_space = REALSPACE) + CALL pw_zero(tmp_a(ispin)%pw) CALL pw_pool_create_pw(pw_pool,tmp_b(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(tmp_b(ispin)%pw, error=error) + in_space = REALSPACE) + CALL pw_zero(tmp_b(ispin)%pw) CALL pw_pool_create_pw(pw_pool,tmp_r(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(tmp_r(ispin)%pw, error=error) + in_space = REALSPACE) + CALL pw_zero(tmp_r(ispin)%pw) ELSE ALLOCATE(tmp_a(ispin)%pw, tmp_b(ispin)%pw, tmp_r(ispin)%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_a(ispin)%pw%cr3d(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)), & tmp_b(ispin)%pw%cr3d(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)), & tmp_r(ispin)%pw%cr3d(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)), & stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) tmp_a(ispin)%pw%cr3d = 0.0_dp tmp_b(ispin)%pw%cr3d = 0.0_dp END IF END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(rhoa)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(rhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i) shared(v_xc,bo,rho1a,deriv_data) default(none) DO k = bo(1,3), bo(2,3) DO j = bo(1,2), bo(2,2) @@ -2236,11 +2158,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF IF (nspins /= 1) THEN - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(rhob)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(rhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i) default(none) shared(bo,v_xc,deriv_data,rho1b) DO k = bo(1,3), bo(2,3) DO j = bo(1,2), bo(2,2) @@ -2253,11 +2173,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(rhob)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(rhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i) default(none) shared(bo,v_xc,deriv_data,rho1b,rho1a,nspins,fac) DO k = bo(1,3), bo(2,3) DO j = bo(1,2), bo(2,2) @@ -2276,11 +2194,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(norm_drhoa)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(norm_drhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) shared(drhoa,drho1a,v_xc,tmp_a,bo,deriv_data,rho1a) DO k = bo(1,3), bo(2,3) DO j = bo(1,2), bo(2,2) @@ -2299,10 +2215,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF IF (nspins /= 1) THEN - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(norm_drhob)", error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(norm_drhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) shared(v_xc,tmp_b,deriv_data,rho1b,bo,drhob,drho1b) DO k = bo(1,3), bo(2,3) DO j = bo(1,2), bo(2,2) @@ -2321,11 +2236,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(norm_drhob)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(norm_drhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) shared(bo,drhob,drho1b,v_xc,tmp_b,deriv_data,nspins,rho1a,fac) DO k = bo(1,3), bo(2,3) DO j = bo(1,2), bo(2,2) @@ -2348,11 +2261,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(norm_drhoa)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(norm_drhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) shared(bo,nspins,drhoa,drho1a,v_xc,tmp_a,fac,deriv_data,rho1b) DO k = bo(1,3), bo(2,3) DO j = bo(1,2), bo(2,2) @@ -2375,11 +2286,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhoa)(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none)& !$omp shared(bo,drhob,drho1a,deriv_data,v_xc,drhoa,drho1b,tmp_a,tmp_b,nspins,rho1a,fac) DO k = bo(1,3), bo(2,3) @@ -2418,11 +2327,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) & !$omp shared(bo,nspins,drhob,drho1a,deriv_data,drhoa,drho1b,tmp_a,tmp_b,fac) DO k = bo(1,3), bo(2,3) @@ -2473,11 +2380,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rhob)(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) & !$omp shared(bo,nspins,drhob,drho1a,deriv_data,drhoa,drho1b,tmp_a,tmp_b,fac,v_xc,rho1b) DO k = bo(1,3), bo(2,3) @@ -2509,11 +2414,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhob)(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhob)(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) & !$omp shared(bo,nspins,drhob,drho1a,deriv_data,drhoa,drho1b,tmp_a,tmp_b,fac) DO k = bo(1,3), bo(2,3) @@ -2557,11 +2460,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)(norm_drhoa)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)(norm_drhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) & !$omp shared(bo,nspins,drhoa,drho1a,deriv_data,tmp_a) DO k = bo(1,3), bo(2,3) @@ -2579,10 +2480,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF IF (nspins /= 1) THEN - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhob)(norm_drhob)", error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhob)(norm_drhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none)& !$omp shared(drhob,drho1b,tmp_b,deriv_data,bo) DO k = bo(1,3), bo(2,3) @@ -2600,11 +2500,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)(norm_drhob)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)(norm_drhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) & !$omp shared(bo,nspins,drhob,drho1a,deriv_data,drhoa,drho1b,tmp_a,tmp_b,fac) DO k = bo(1,3), bo(2,3) @@ -2632,13 +2530,10 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) - CALL xc_derivative_get(deriv_att, deriv_data=e_drhoa, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) + CALL xc_derivative_get(deriv_att, deriv_data=e_drhoa) !$omp parallel do private(k,j,i,dr1dr,idir) default(none)& !$omp shared(bo,drhoa,drho1a,tmp_a,deriv_data) DO k = bo(1,3), bo(2,3) @@ -2656,13 +2551,10 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF IF (nspins /= 1) THEN - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhob)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) - CALL xc_derivative_get(deriv_att, deriv_data=e_drhob, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) + CALL xc_derivative_get(deriv_att, deriv_data=e_drhob) !$omp parallel do private(k,j,i,dr1dr,idir) default(none) & !$omp shared(bo,drhob,drho1b,tmp_b,deriv_data) DO k = bo(1,3), bo(2,3) @@ -2680,11 +2572,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,dr1dr,idir) default(none)& !$omp shared(bo,nspins,drhob,drho1a,drhoa,drho1b,tmp_a,tmp_b,fac,deriv_data) DO k = bo(1,3), bo(2,3) @@ -2721,11 +2611,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=e_norm_drho, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=e_norm_drho) END IF IF (gradient_f) THEN @@ -2830,23 +2718,23 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & CASE (xc_deriv_spline2_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(ispin)%pw,& pw_out=v_xc(ispin)%pw,coeffs=spline2_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_spline3_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(ispin)%pw,& pw_out=v_xc(ispin)%pw,coeffs=spline3_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_nn10_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(ispin)%pw,& pw_out=v_xc(ispin)%pw,coeffs=nn10_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_nn50_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(ispin)%pw,& pw_out=v_xc(ispin)%pw,coeffs=nn50_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE default CALL cp_unimplemented_error(fromWhere=routineP, & message="XC_DERIV method not implemented for GPW-LSD!",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END DO ! ispin @@ -2856,14 +2744,14 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & DO ispin=1, nspins IF (ASSOCIATED(pw_pool)) THEN - CALL pw_pool_give_back_pw(pw_pool,tmp_a(ispin)%pw,error=error) - CALL pw_pool_give_back_pw(pw_pool,tmp_b(ispin)%pw,error=error) - CALL pw_pool_give_back_pw(pw_pool,tmp_r(ispin)%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,tmp_a(ispin)%pw) + CALL pw_pool_give_back_pw(pw_pool,tmp_b(ispin)%pw) + CALL pw_pool_give_back_pw(pw_pool,tmp_r(ispin)%pw) ELSE DEALLOCATE(tmp_a(ispin)%pw%cr3d, tmp_b(ispin)%pw%cr3d, tmp_r(ispin)%pw%cr3d, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_a(ispin)%pw, tmp_b(ispin)%pw, tmp_r(ispin)%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END DO @@ -2875,31 +2763,29 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & ! restricted case ! !-----------------! - CALL xc_rho_set_get(rho1_set,rho=rho1, error=error) + CALL xc_rho_set_get(rho1_set,rho=rho1) IF (gradient_f) THEN - CALL xc_rho_set_get(rho_set,drho=drho, error=error) - CALL xc_rho_set_get(rho1_set,drho=drho1, error=error) + CALL xc_rho_set_get(rho_set,drho=drho) + CALL xc_rho_set_get(rho1_set,drho=drho1) IF (ASSOCIATED(pw_pool)) THEN CALL pw_pool_create_pw(pw_pool,v_drho%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) - CALL pw_zero(v_drho%pw, error=error) + in_space = REALSPACE) + CALL pw_zero(v_drho%pw) ELSE ALLOCATE(v_drho%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(v_drho%pw%cr3d(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)), & stat=stat) v_drho%pw%cr3d = 0.0_dp - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rho)(rho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rho)(rho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i) default(none) & !$omp shared(bo,v_xc,deriv_data,rho1) DO k = bo(1,3), bo(2,3) @@ -2912,11 +2798,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(rho)(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(rho)(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,idir,dr1dr) default(none)& !$omp shared(bo,drho,drho1,v_xc,deriv_data,v_drho,rho1) DO k = bo(1,3), bo(2,3) @@ -2934,11 +2818,9 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) !$omp parallel do private(k,j,i,idir,dr1dr) default(none)& !$omp shared(bo,drho,drho1,v_drho,deriv_data) DO k = bo(1,3), bo(2,3) @@ -2954,13 +2836,10 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END DO END IF - deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)", & - error=error) + deriv_att=> xc_dset_get_derivative(deriv_set, "(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att, deriv_data=deriv_data, & - error=error) - CALL xc_derivative_get(deriv_att, deriv_data=e_norm_drho, & - error=error) + CALL xc_derivative_get(deriv_att, deriv_data=deriv_data) + CALL xc_derivative_get(deriv_att, deriv_data=e_norm_drho) !$omp parallel do private(k,j,i,idir,dr1dr) default(none)& !$omp shared(bo,drho,drho1,gradient_cut,rho_set,v_drho,deriv_data) DO k = bo(1,3), bo(2,3) @@ -3004,13 +2883,13 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & IF (ASSOCIATED(pw_pool)) THEN CALL pw_pool_create_pw(pw_pool,tmp_r(1)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) ELSE ALLOCATE(tmp_r(1)%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(tmp_r(1)%pw%cr3d(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)), & stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DO idir=1,3 @@ -3029,43 +2908,43 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & CASE (xc_deriv_spline2_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(1)%pw,& pw_out=v_xc(1)%pw,coeffs=spline2_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_spline3_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(1)%pw,& pw_out=v_xc(1)%pw,coeffs=spline3_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_nn10_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(1)%pw,& pw_out=v_xc(1)%pw,coeffs=nn10_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE (xc_deriv_nn50_smooth) CALL pw_nn_deriv_r ( pw_in=tmp_r(1)%pw,& pw_out=v_xc(1)%pw,coeffs=nn50_deriv_coeffs,& - idir=idir, error=error ) + idir=idir) CASE default CALL cp_unimplemented_error(fromWhere=routineP, & message="XC_DERIV method not implemented for GPW!",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END SELECT END DO IF (ASSOCIATED(pw_pool)) THEN - CALL pw_pool_give_back_pw(pw_pool,tmp_r(1)%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,tmp_r(1)%pw) ELSE DEALLOCATE(tmp_r(1)%pw%cr3d, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(tmp_r(1)%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF IF (ASSOCIATED(pw_pool)) THEN - CALL pw_pool_give_back_pw(pw_pool,v_drho%pw,error=error) + CALL pw_pool_give_back_pw(pw_pool,v_drho%pw) ELSE DEALLOCATE(v_drho%pw%cr3d, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(v_drho%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF END IF @@ -3073,7 +2952,7 @@ SUBROUTINE xc_calc_2nd_deriv(v_xc, deriv_set, rho_set, rho1_set, & END IF DEALLOCATE(tmp_r, tmp_r2, tmp_a, tmp_b, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL timestop(handle) END SUBROUTINE xc_calc_2nd_deriv @@ -3093,18 +2972,15 @@ END SUBROUTINE xc_calc_2nd_deriv !> \param rho_r the place where you evaluate the derivative !> \param pw_pool the pool for the grids !> \param xc_section which functional should be used and how to calculate it -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE xc_prep_2nd_deriv(deriv_set, & - rho_set, rho_r, pw_pool, xc_section, error) + rho_set, rho_r, pw_pool, xc_section) TYPE(xc_derivative_set_type), POINTER :: deriv_set TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_r TYPE(pw_pool_type), POINTER :: pw_pool TYPE(section_vals_type), POINTER :: xc_section - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_prep_2nd_deriv', & routineP = moduleN//':'//routineN @@ -3117,15 +2993,15 @@ SUBROUTINE xc_prep_2nd_deriv(deriv_set, & failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(xc_section),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,failure) nspins = SIZE(rho_r) lsd = (nspins /= 1) ALLOCATE(rho_r_pw(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1, nspins rho_r_pw(ispin)%pw => rho_r(ispin)%pw END DO @@ -3133,12 +3009,12 @@ SUBROUTINE xc_prep_2nd_deriv(deriv_set, & NULLIFY(rho_g, tau) CALL xc_rho_set_and_dset_create(rho_set,deriv_set,2,& rho_r_pw,rho_g,tau,xc_section,pw_pool,& - needs_basic_components=.TRUE.,error=error) + needs_basic_components=.TRUE.) DEALLOCATE(rho_r_pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL divide_by_norm_drho(deriv_set, rho_set, lsd, error) + CALL divide_by_norm_drho(deriv_set, rho_set, lsd) CALL timestop(handle) @@ -3149,14 +3025,12 @@ END SUBROUTINE xc_prep_2nd_deriv !> \param deriv_set ... !> \param rho_set ... !> \param lsd ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE divide_by_norm_drho(deriv_set, rho_set, lsd, error) + SUBROUTINE divide_by_norm_drho(deriv_set, rho_set, lsd) TYPE(xc_derivative_set_type), POINTER :: deriv_set TYPE(xc_rho_set_type), POINTER :: rho_set LOGICAL, INTENT(IN) :: lsd - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'divide_by_norm_drho', & routineP = moduleN//':'//routineN @@ -3177,13 +3051,12 @@ SUBROUTINE divide_by_norm_drho(deriv_set, rho_set, lsd, error) failure = .FALSE. bo = rho_set%local_bounds - CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff, error=error) + CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff) pos => deriv_set%derivs - DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att,error=error)) + DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att)) CALL xc_derivative_get(deriv_att,order=order,& - desc=desc, split_desc=split_desc,& - error=error) + desc=desc, split_desc=split_desc) IF (order==1 .OR. order==2) THEN DO idesc=1,SIZE(split_desc) SELECT CASE(split_desc(idesc)) @@ -3222,7 +3095,7 @@ SUBROUTINE divide_by_norm_drho(deriv_set, rho_set, lsd, error) "rho not handled in lsd: '"//& TRIM(desc)//"' in "//& CPSourceFileRef,& - error,failure) + failure) CASE("rhoa","rhob") CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& @@ -3230,7 +3103,7 @@ SUBROUTINE divide_by_norm_drho(deriv_set, rho_set, lsd, error) TRIM(split_desc(idesc))//"' in '"//& TRIM(desc)//"' in "//& CPSourceFileRef,& - error,failure) + failure) END SELECT END DO END IF diff --git a/src/xc/xc_atom.F b/src/xc/xc_atom.F index c0516af1cd..8809dde34f 100644 --- a/src/xc/xc_atom.F +++ b/src/xc/xc_atom.F @@ -55,10 +55,9 @@ MODULE xc_atom !> \param energy_only ... !> \param epr_xc ... !> \param adiabatic_rescale_factor ... -!> \param error ... ! ***************************************************************************** SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& - lsd,na,nr,exc,vxc,vxg,vtau,energy_only,epr_xc,adiabatic_rescale_factor,error) + lsd,na,nr,exc,vxc,vxg,vtau,energy_only,epr_xc,adiabatic_rescale_factor) ! This routine updates rho_set by giving to it the rho and drho that are needed. ! Since for the local densities rho1_h and rho1_s local grids are used it is not possible @@ -84,7 +83,6 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& REAL(dp), DIMENSION(:, :, :), POINTER :: vtau LOGICAL, INTENT(IN), OPTIONAL :: energy_only, epr_xc REAL(dp), INTENT(IN), OPTIONAL :: adiabatic_rescale_factor - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'vxc_of_r_new', & routineP = moduleN//':'//routineN @@ -123,10 +121,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& lsd=lsd,& rho_set=rho_set, & deriv_set=deriv_set,& - deriv_order=my_deriv_order, & - error=error) + deriv_order=my_deriv_order) - CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff, error=error) + CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff) NULLIFY (deriv_data) @@ -134,9 +131,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& ! nabla v_xc (using the vxg arrays) ! there's no point doing this when lsd = false IF(lsd) THEN - deriv_att => xc_dset_get_derivative(deriv_set, "(rhoa)(rhoa)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rhoa)(rhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) DO ir = 1,nr DO ia = 1,na DO idir = 1,3 @@ -147,9 +144,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& END DO !ir NULLIFY(deriv_data) END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(rhob)(rhob)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rhob)(rhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) DO ir = 1,nr DO ia = 1,na DO idir = 1,3 @@ -162,9 +159,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& END IF END IF ! EXC energy ! is that needed for epr? - deriv_att => xc_dset_get_derivative(deriv_set,"", error=error) + deriv_att => xc_dset_get_derivative(deriv_set,"") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) exc = 0.0_dp DO ir = 1, nr DO ia = 1, na @@ -175,9 +172,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& END IF ELSE ! EXC energy - deriv_att => xc_dset_get_derivative(deriv_set,"", error=error) + deriv_att => xc_dset_get_derivative(deriv_set,"") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) exc = 0.0_dp DO ir = 1, nr DO ia = 1, na @@ -190,29 +187,29 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& IF(.NOT.my_only_energy) THEN ! Derivative with respect to the density IF(lsd) THEN - deriv_att => xc_dset_get_derivative(deriv_set, "(rhoa)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) vxc(:,:,1) = deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor NULLIFY (deriv_data) END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(rhob)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) vxc(:,:,2) = deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor NULLIFY(deriv_data) END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(rho)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rho)") IF(ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) vxc(:,:,1) = vxc(:,:,1) + deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor vxc(:,:,2) = vxc(:,:,2) + deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor NULLIFY (deriv_data) END IF ELSE - deriv_att => xc_dset_get_derivative(deriv_set, "(rho)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(rho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data, error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) vxc(:,:,1) = deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor NULLIFY (deriv_data) END IF @@ -220,9 +217,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& ! Derivatives with respect to the gradient IF (lsd) THEN - deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drhoa)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drhoa)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) DO ir = 1, nr DO ia = 1, na DO idir=1, 3 @@ -238,9 +235,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& END DO NULLIFY(deriv_data) END IF - deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drhob)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drhob)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) DO ir = 1, nr DO ia = 1, na DO idir=1, 3 @@ -257,9 +254,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& NULLIFY(deriv_data) END IF ! Cross Terms - deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drho)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set, "(norm_drho)") IF(ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) DO ir = 1, nr DO ia = 1, na DO idir = 1, 3 @@ -274,9 +271,9 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& NULLIFY (deriv_data) END IF ELSE - deriv_att => xc_dset_get_derivative(deriv_set,"(norm_drho)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set,"(norm_drho)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) DO ir = 1, nr DO ia = 1, na IF (rho_set%norm_drho(ia,ir,1) > drho_cutoff) THEN @@ -295,22 +292,22 @@ SUBROUTINE vxc_of_r_new(xc_fun_section,rho_set,deriv_set,deriv_order,needs,w,& END IF ! lsd ! Derivative with respect to tau IF (lsd) THEN - deriv_att => xc_dset_get_derivative(deriv_set,"(taua)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set,"(taua)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) vtau(:,:,1) = deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor NULLIFY (deriv_data) END IF - deriv_att => xc_dset_get_derivative(deriv_set,"(taub)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set,"(taub)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) vtau(:,:,2) = deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor NULLIFY (deriv_data) END IF ELSE - deriv_att => xc_dset_get_derivative(deriv_set,"(tau)",error=error) + deriv_att => xc_dset_get_derivative(deriv_set,"(tau)") IF (ASSOCIATED(deriv_att)) THEN - CALL xc_derivative_get(deriv_att,deriv_data=deriv_data,error=error) + CALL xc_derivative_get(deriv_att,deriv_data=deriv_data) vtau(:,:,1) = deriv_data(:,:,1)*w(:,:) * my_adiabatic_rescale_factor NULLIFY (deriv_data) END IF @@ -331,10 +328,9 @@ END SUBROUTINE vxc_of_r_new !> \param w ... !> \param vxc ... !> \param vxg ... -!> \param error ... ! ***************************************************************************** SUBROUTINE xc_2nd_deriv_of_r(rho_set, rho1_set,xc_section,& - deriv_set, w, vxc, vxg, error) + deriv_set, w, vxc, vxg) ! As input of this routine one gets rho and drho on a one dimensional grid. ! The grid is the angular grid corresponding to a given point ir on the radial grid. @@ -349,7 +345,6 @@ SUBROUTINE xc_2nd_deriv_of_r(rho_set, rho1_set,xc_section,& REAL(dp), DIMENSION(:, :), POINTER :: w REAL(dp), DIMENSION(:, :, :), POINTER :: vxc REAL(dp), DIMENSION(:, :, :, :), POINTER :: vxg - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_2nd_deriv_of_r', & routineP = moduleN//':'//routineN @@ -371,49 +366,48 @@ SUBROUTINE xc_2nd_deriv_of_r(rho_set, rho1_set,xc_section,& IF (ASSOCIATED(rho_set%rhoa)) THEN lsd = .TRUE. END IF - CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff, error=error) + CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff) xc_fun_section => section_vals_get_subs_vals(xc_section,& - "XC_FUNCTIONAL",error=error) + "XC_FUNCTIONAL") ! Calculate the derivatives CALL xc_functionals_eval(xc_fun_section, & lsd=lsd,& rho_set=rho_set, & deriv_set=deriv_set,& - deriv_order=2, & - error=error) + deriv_order=2) - CALL divide_by_norm_drho(deriv_set, rho_set, lsd, error) + CALL divide_by_norm_drho(deriv_set, rho_set, lsd) ! multiply by -w pos => deriv_set%derivs - DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att,error=error)) + DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att)) !deriv_att%deriv_data(:,:,1) = -w(:,:)*deriv_att%deriv_data(:,:,1) deriv_att%deriv_data(:,:,1) = w(:,:)*deriv_att%deriv_data(:,:,1) END DO NULLIFY(pw_pool) ALLOCATE(vxc_pw(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1, nspins ALLOCATE(vxc_pw(ispin)%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) vxc_pw(ispin)%pw%cr3d => vxc(:,:,ispin:ispin) END DO CALL xc_calc_2nd_deriv(vxc_pw, deriv_set, rho_set, rho1_set, pw_pool, & - xc_section,gapw=.TRUE., vxg=vxg, error=error) + xc_section,gapw=.TRUE., vxg=vxg) DO ispin=1, nspins DEALLOCATE(vxc_pw(ispin)%pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END DO DEALLOCATE(vxc_pw, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! zero the derivative data for the next call pos => deriv_set%derivs - DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att,error=error)) + DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att)) deriv_att%deriv_data = 0.0_dp END DO @@ -582,9 +576,8 @@ END SUBROUTINE xc_rho_set_atom_update !> \param tau ... !> \param na ... !> \param ir ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE fill_rho_set(rho_set,lsd,nspins,needs,rho,drho,tau,na,ir,error) + SUBROUTINE fill_rho_set(rho_set,lsd,nspins,needs,rho,drho,tau,na,ir) TYPE(xc_rho_set_type), POINTER :: rho_set LOGICAL, INTENT(IN) :: lsd @@ -594,7 +587,6 @@ SUBROUTINE fill_rho_set(rho_set,lsd,nspins,needs,rho,drho,tau,na,ir,error) REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho REAL(dp), DIMENSION(:, :), POINTER :: tau INTEGER, INTENT(IN) :: na, ir - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'fill_rho_set', & routineP = moduleN//':'//routineN @@ -615,18 +607,18 @@ SUBROUTINE fill_rho_set(rho_set,lsd,nspins,needs,rho,drho,tau,na,ir,error) ! some checks IF (lsd) THEN ELSE - CPPrecondition(SIZE(rho,2)==1,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(rho,2)==1,cp_failure_level,routineP,failure) END IF SELECT CASE(my_nspins) CASE(1) - CPPrecondition(.NOT.needs%rho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%norm_drho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%rho_spin_1_3,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.needs%rho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%norm_drho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%rho_spin_1_3,cp_failure_level,routineP,failure) CASE(2) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT gradient_f=(needs%drho_spin.OR.needs%norm_drho_spin.OR.& @@ -831,8 +823,8 @@ SUBROUTINE fill_rho_set(rho_set,lsd,nspins,needs,rho,drho,tau,na,ir,error) ! tau part IF (needs%tau.OR.needs%tau_spin) THEN - CPPrecondition(ASSOCIATED(tau),cp_failure_level,routineP,error,failure) - CPPrecondition(SIZE(tau,2)==my_nspins,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tau),cp_failure_level,routineP,failure) + CPPrecondition(SIZE(tau,2)==my_nspins,cp_failure_level,routineP,failure) END IF IF (needs%tau) THEN IF (my_nspins==2) THEN diff --git a/src/xc/xc_b97.F b/src/xc/xc_b97.F index 807675770b..5cb07d3c39 100644 --- a/src/xc/xc_b97.F +++ b/src/xc/xc_b97.F @@ -66,14 +66,12 @@ MODULE xc_b97 !> \param sc ... !> \param reference ... !> \param shortform ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE b97_ref(param,lda,sx,sc,reference,shortform,error) + SUBROUTINE b97_ref(param,lda,sx,sc,reference,shortform) INTEGER :: param LOGICAL :: lda REAL(dp), INTENT(in) :: sx, sc CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'b97_ref', & routineP = moduleN//':'//routineN @@ -146,10 +144,10 @@ SUBROUTINE b97_ref(param,lda,sx,sc,reference,shortform,error) shortform = "wB97X-V, HFX+B97+VV10 functional (NOT TESTED)"//pol END IF ELSE - CPAssertNoFail(.FALSE.,cp_failure_level,routineP,error) + CPAssertNoFail(.FALSE.,cp_failure_level,routineP) END IF CASE default - CPAssertNoFail(.FALSE.,cp_failure_level,routineP,error) + CPAssertNoFail(.FALSE.,cp_failure_level,routineP) END SELECT END SUBROUTINE b97_ref @@ -161,18 +159,14 @@ END SUBROUTINE b97_ref !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE b97_lda_info(b97_params,reference,shortform, needs, max_deriv,& - error) + SUBROUTINE b97_lda_info(b97_params,reference,shortform, needs, max_deriv) TYPE(section_vals_type), POINTER :: b97_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'b97_lda_info', & routineP = moduleN//':'//routineN @@ -182,11 +176,11 @@ SUBROUTINE b97_lda_info(b97_params,reference,shortform, needs, max_deriv,& REAL(kind=dp) :: sc, sx failure=.FALSE. - CALL section_vals_val_get(b97_params,"parametrization",i_val=param,error=error) - CALL section_vals_val_get(b97_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(b97_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(b97_params,"parametrization",i_val=param) + CALL section_vals_val_get(b97_params,"scale_x",r_val=sx) + CALL section_vals_val_get(b97_params,"scale_c",r_val=sc) - CALL b97_ref(param,.TRUE.,sx,sc,reference,shortform,error) + CALL b97_ref(param,.TRUE.,sx,sc,reference,shortform) IF (PRESENT(needs)) THEN needs%rho=.TRUE. needs%norm_drho=.TRUE. @@ -203,18 +197,14 @@ END SUBROUTINE b97_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE b97_lsd_info(b97_params,reference,shortform, needs, max_deriv,& - error) + SUBROUTINE b97_lsd_info(b97_params,reference,shortform, needs, max_deriv) TYPE(section_vals_type), POINTER :: b97_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'b97_lsd_info', & routineP = moduleN//':'//routineN @@ -224,11 +214,11 @@ SUBROUTINE b97_lsd_info(b97_params,reference,shortform, needs, max_deriv,& REAL(kind=dp) :: sc, sx failure=.FALSE. - CALL section_vals_val_get(b97_params,"parametrization",i_val=param,error=error) - CALL section_vals_val_get(b97_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(b97_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(b97_params,"parametrization",i_val=param) + CALL section_vals_val_get(b97_params,"scale_x",r_val=sx) + CALL section_vals_val_get(b97_params,"scale_c",r_val=sc) - CALL b97_ref(param,.FALSE.,sx,sc,reference,shortform,error) + CALL b97_ref(param,.FALSE.,sx,sc,reference,shortform) IF (PRESENT(needs)) THEN needs%rho_spin=.TRUE. needs%norm_drho_spin=.TRUE. @@ -246,16 +236,13 @@ END SUBROUTINE b97_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param b97_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE b97_lda_eval(rho_set,deriv_set,grad_deriv,b97_params,error) + SUBROUTINE b97_lda_eval(rho_set,deriv_set,grad_deriv,b97_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: b97_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'b97_lda_eval', & routineP = moduleN//':'//routineN @@ -275,20 +262,20 @@ SUBROUTINE b97_lda_eval(rho_set,deriv_set,grad_deriv,b97_params,error) failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_norm_drho,error=error) + drho_cutoff=epsilon_norm_drho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -306,58 +293,57 @@ SUBROUTINE b97_lda_eval(rho_set,deriv_set,grad_deriv,b97_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho,error=error) + "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho,error=error) + "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_val_get(b97_params,"parametrization",i_val=param,error=error) - CALL section_vals_val_get(b97_params,"scale_c",r_val=scale_c,error=error) - CALL section_vals_val_get(b97_params,"scale_x",r_val=scale_x,error=error) + CALL section_vals_val_get(b97_params,"parametrization",i_val=param) + CALL section_vals_val_get(b97_params,"scale_c",r_val=scale_c) + CALL section_vals_val_get(b97_params,"scale_x",r_val=scale_x) !$omp parallel default(none) & !$omp shared(rho, norm_drho, e_0, e_rho, e_ndrho, e_rho_rho) & !$omp shared(e_ndrho_rho, e_ndrho_ndrho) & !$omp shared(grad_deriv, npoints, epsilon_rho) & - !$omp shared(epsilon_norm_drho, param, scale_c, scale_x, error) + !$omp shared(epsilon_norm_drho, param, scale_c, scale_x) CALL b97_lda_calc(rho_tot=rho, norm_drho=norm_drho,& e_0=e_0,e_r=e_rho,e_ndr=e_ndrho,e_r_r=e_rho_rho,& @@ -366,13 +352,13 @@ SUBROUTINE b97_lda_eval(rho_set,deriv_set,grad_deriv,b97_params,error) ! e_ndrho_ndrho_rho=e_ndrho_ndrho_rho,e_ndrho_ndrho_ndrho=e_ndrho_ndrho_ndrho,& grad_deriv=grad_deriv,& npoints=npoints,epsilon_rho=epsilon_rho,& - param=param,scale_c_in=scale_c,scale_x_in=scale_x,error=error) + param=param,scale_c_in=scale_c,scale_x_in=scale_x) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -385,16 +371,13 @@ END SUBROUTINE b97_lda_eval !> \param deriv_set ... !> \param grad_deriv ... !> \param b97_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params,error) + SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: b97_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'b97_lsd_eval', & routineP = moduleN//':'//routineN @@ -413,22 +396,22 @@ SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params,error) failure=.FALSE. NULLIFY(deriv, bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,& rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa, & norm_drhob=norm_drhob, & rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -453,62 +436,62 @@ SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra_ra) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra_rb) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_ra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ra) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndra,error=error) + "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndra) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndrb,error=error) + "(norm_drhoa)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndrb) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ndrb,error=error) + "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ndrb) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN ! to do END IF - CALL section_vals_val_get(b97_params,"parametrization",i_val=param,error=error) - CALL section_vals_val_get(b97_params,"scale_x",r_val=scale_x,error=error) - CALL section_vals_val_get(b97_params,"scale_c",r_val=scale_c,error=error) + CALL section_vals_val_get(b97_params,"parametrization",i_val=param) + CALL section_vals_val_get(b97_params,"scale_x",r_val=scale_x) + CALL section_vals_val_get(b97_params,"scale_c",r_val=scale_c) !$omp parallel default (none) & !$omp shared(rhoa, rhob, norm_drhoa, norm_drhob, e_0, e_ra) & @@ -516,7 +499,7 @@ SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params,error) !$omp shared(e_ndra_ra, e_ndrb_ra, e_ndrb_rb, e_ndra_rb) & !$omp shared(e_ndra_ndra, e_ndrb_ndrb, e_ndra_ndrb) & !$omp shared(grad_deriv, npoints, param, scale_c, scale_x) & - !$omp shared(epsilon_rho, error) + !$omp shared(epsilon_rho) CALL b97_lsd_calc(& rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa,& @@ -530,13 +513,13 @@ SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params,error) e_ndra_ndrb=e_ndra_ndrb,& grad_deriv=grad_deriv, npoints=npoints, & epsilon_rho=epsilon_rho,& - param=param,scale_c_in=scale_c,scale_x_in=scale_x,error=error) + param=param,scale_c_in=scale_c,scale_x_in=scale_x) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -546,12 +529,10 @@ END SUBROUTINE b97_lsd_eval ! ***************************************************************************** !> \brief ... !> \param param ... -!> \param error ... !> \retval res ... ! ***************************************************************************** - FUNCTION b97_coeffs(param, error) RESULT(res) + FUNCTION b97_coeffs(param) RESULT(res) INTEGER, INTENT(in) :: param - TYPE(cp_error_type), INTENT(inout) :: error REAL(dp), DIMENSION(10) :: res CHARACTER(len=*), PARAMETER :: routineN = 'b97_coeffs', & @@ -565,7 +546,7 @@ FUNCTION b97_coeffs(param, error) RESULT(res) CASE(xc_b97_mardirossian) res = params_b97_mardirossian CASE default - CPAssertNoFail(.FALSE.,cp_failure_level,routineP,error) + CPAssertNoFail(.FALSE.,cp_failure_level,routineP) res=0.0_dp END SELECT END FUNCTION b97_coeffs @@ -597,8 +578,6 @@ END FUNCTION b97_coeffs !> \param param ... !> \param scale_c_in derivative of the functional with respect to c_in !> \param scale_x_in derivative of the functional with respect to x_in -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE b97_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob,& @@ -607,7 +586,7 @@ SUBROUTINE b97_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob,& e_ndra_ndra, e_ndrb_ndrb, e_ndra_ndrb, & e_ra_ra, e_ra_rb, e_rb_rb,& grad_deriv,npoints,epsilon_rho, & - param, scale_c_in, scale_x_in, error) + param, scale_c_in, scale_x_in) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rhoa, rhob, norm_drhoa, & norm_drhob REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_ra, e_rb, e_ndra, & @@ -617,7 +596,6 @@ SUBROUTINE b97_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob,& REAL(kind=dp), INTENT(in) :: epsilon_rho INTEGER, INTENT(in) :: param REAL(kind=dp), INTENT(in) :: scale_c_in, scale_x_in - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'b97_lsd_calc', & routineP = moduleN//':'//routineN @@ -732,7 +710,7 @@ SUBROUTINE b97_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob,& beta_3_3 = 0.88026e0_dp beta_4_3 = 0.49671e0_dp - coeffs=b97_coeffs(param,error) + coeffs=b97_coeffs(param) c_x_0=coeffs(1) c_x_1=coeffs(2) c_x_2=coeffs(3) @@ -1643,15 +1621,13 @@ END SUBROUTINE b97_lsd_calc !> \param param ... !> \param scale_c_in ... !> \param scale_x_in ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note slow version ! ***************************************************************************** SUBROUTINE b97_lda_calc(rho_tot, norm_drho,& e_0, e_r, e_r_r, e_ndr, e_r_ndr, e_ndr_ndr, & grad_deriv,npoints,epsilon_rho,& - param, scale_c_in, scale_x_in, error) + param, scale_c_in, scale_x_in) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rho_tot, norm_drho REAL(kind=dp), DIMENSION(*), & INTENT(inout) :: e_0, e_r, e_r_r, e_ndr, & @@ -1660,7 +1636,6 @@ SUBROUTINE b97_lda_calc(rho_tot, norm_drho,& REAL(kind=dp), INTENT(in) :: epsilon_rho INTEGER, INTENT(in) :: param REAL(kind=dp), INTENT(in) :: scale_c_in, scale_x_in - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'b97_lda_calc', & routineP = moduleN//':'//routineN @@ -1775,7 +1750,7 @@ SUBROUTINE b97_lda_calc(rho_tot, norm_drho,& beta_3_3 = 0.88026e0_dp beta_4_3 = 0.49671e0_dp - coeffs=b97_coeffs(param,error) + coeffs=b97_coeffs(param) c_x_0=coeffs(1) c_x_1=coeffs(2) c_x_2=coeffs(3) diff --git a/src/xc/xc_cs1.F b/src/xc/xc_cs1.F index 4de6dcb8eb..85beda7343 100644 --- a/src/xc/xc_cs1.F +++ b/src/xc/xc_cs1.F @@ -63,15 +63,12 @@ MODULE xc_cs1 !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE cs1_lda_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE cs1_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cs1_lda_info', & routineP = moduleN//':'//routineN @@ -99,15 +96,12 @@ END SUBROUTINE cs1_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE cs1_lsd_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE cs1_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cs1_lsd_info', & routineP = moduleN//':'//routineN @@ -155,13 +149,11 @@ END SUBROUTINE cs1_init !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cs1_lda_eval (rho_set,deriv_set,order,error) + SUBROUTINE cs1_lda_eval (rho_set,deriv_set,order) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cs1_lda_eval', & routineP = moduleN//':'//routineN @@ -183,71 +175,69 @@ SUBROUTINE cs1_lda_eval (rho_set,deriv_set,order,error) e_rho_rho_rho, e_rho_rho_ndrho, e_rho_ndrho_ndrho, & e_ndrho_ndrho_ndrho) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=rho13,rho=rho,& - norm_drho=grho,local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + norm_drho=grho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) m=ABS(order) CALL cs1_init(epsilon_rho) IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) - CALL cs1_u_0 ( rho, grho, rho13, e_0,npoints, error) + CALL cs1_u_0 ( rho, grho, rho13, e_0,npoints) END IF IF ( order>=1 .OR. order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) CALL cs1_u_1 ( rho, grho, rho13, e_rho, e_ndrho,& - npoints,error) + npoints) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(rho)(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CALL cs1_u_2 ( rho, grho, rho13, e_rho_rho, e_rho_ndrho, & - e_ndrho_ndrho, npoints, error ) + e_ndrho_ndrho, npoints) END IF IF ( order>=3.OR.order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho,error=error) + "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho,error=error) + "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) CALL cs1_u_3 ( rho, grho, rho13, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints, error) + e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL timestop(handle) @@ -258,13 +248,11 @@ END SUBROUTINE cs1_lda_eval !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cs1_lsd_eval (rho_set,deriv_set,order,error) + SUBROUTINE cs1_lsd_eval (rho_set,deriv_set,order) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cs1_lsd_eval', & routineP = moduleN//':'//routineN @@ -284,47 +272,47 @@ SUBROUTINE cs1_lsd_eval (rho_set,deriv_set,order,error) failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=rhoa,rhob=rhob,& rhoa_1_3=rhoa_1_3,rhob_1_3=rhob_1_3,& norm_drhoa=norm_drhoa,norm_drhob=norm_drhob,& - local_bounds=bo,rho_cutoff=epsilon_rho, error=error) + local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL cs1_init(epsilon_rho) IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) CALL cs1_ss_0 ( rhoa, rhob, norm_drhoa, norm_drhob,& - rhoa_1_3, rhob_1_3, e_0,npoints,error) + rhoa_1_3, rhob_1_3, e_0,npoints) END IF IF ( order>=1.OR.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) CALL cs1_ss_1 ( rhoa, rhob, norm_drhoa, norm_drhob,& rhoa_1_3, rhob_1_3, e_rhoa, e_rhob, e_ndrhoa, e_ndrhob,& - npoints,error) + npoints) END IF IF ( order>1 .OR. order<1 ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL timestop(handle) END SUBROUTINE cs1_lsd_eval @@ -336,15 +324,13 @@ END SUBROUTINE cs1_lsd_eval !> \param r13 ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cs1_u_0 ( rho, grho, r13, e_0, npoints, error ) + SUBROUTINE cs1_u_0 ( rho, grho, r13, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, r13 REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: c2p, c3p, c4p, cp, dpv, F1, & @@ -393,15 +379,13 @@ END SUBROUTINE cs1_u_0 !> \param e_rho ... !> \param e_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE cs1_u_1 ( rho, grho, r13, e_rho, e_ndrho, npoints, error ) + SUBROUTINE cs1_u_1 ( rho, grho, r13, e_rho, e_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, r13 REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho, e_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: c2p, c3p, c4p, cp, dF1, dF3, & @@ -457,17 +441,15 @@ END SUBROUTINE cs1_u_1 !> \param e_rho_ndrho ... !> \param e_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cs1_u_2 ( rho, grho, r13, e_rho_rho, e_rho_ndrho, e_ndrho_ndrho,& - npoints, error) + npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, r13 REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho, e_rho_ndrho, & e_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: c2p, c3p, c4p, cp, d2F1, & @@ -534,10 +516,9 @@ END SUBROUTINE cs1_u_2 !> \param e_rho_ndrho_ndrho ... !> \param e_ndrho_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cs1_u_3 ( rho, grho, r13, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints, error) + e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, r13 REAL(KIND=dp), DIMENSION(*), & @@ -546,7 +527,6 @@ SUBROUTINE cs1_u_3 ( rho, grho, r13, e_rho_rho_rho, e_rho_rho_ndrho,& e_rho_ndrho_ndrho, & e_ndrho_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: c2p, c3p, c4p, cp, d2rgF2, d2rgF4, d3F1, d3F3, d3gF2, & @@ -646,17 +626,15 @@ END SUBROUTINE cs1_u_3 !> \param r13b ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cs1_ss_0 ( rhoa, rhob, grhoa, grhob, r13a, r13b, e_0,& - npoints,error) + npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, rhob, grhoa, grhob, & r13a, r13b REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cs1_ss_0', & routineP = moduleN//':'//routineN @@ -670,8 +648,7 @@ SUBROUTINE cs1_ss_0 ( rhoa, rhob, grhoa, grhob, r13a, r13b, e_0,& CALL cp_assert(.FALSE.,cp_warning_level, cp_assertion_failed,routineP,& "not tested!"//& - CPSourceFileRef,& - error) + CPSourceFileRef) !$omp parallel do default(none) & !$omp shared(npoints, rhoa, eps_rho, r13a, grhoa, rhob) & @@ -729,10 +706,9 @@ END SUBROUTINE cs1_ss_0 !> \param e_ndrhoa ... !> \param e_ndrhob ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE cs1_ss_1 ( rhoa, rhob, grhoa, grhob, r13a, r13b, e_rhoa,& - e_rhob, e_ndrhoa, e_ndrhob, npoints, error ) + e_rhob, e_ndrhoa, e_ndrhob, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, rhob, grhoa, grhob, & r13a, r13b @@ -740,7 +716,6 @@ SUBROUTINE cs1_ss_1 ( rhoa, rhob, grhoa, grhob, r13a, r13b, e_rhoa,& INTENT(INOUT) :: e_rhoa, e_rhob, e_ndrhoa, & e_ndrhob INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'cs1_ss_1', & routineP = moduleN//':'//routineN @@ -753,8 +728,7 @@ SUBROUTINE cs1_ss_1 ( rhoa, rhob, grhoa, grhob, r13a, r13b, e_rhoa,& CALL cp_assert(.FALSE.,cp_warning_level, cp_assertion_failed,routineP,& "not tested!"//& - CPSourceFileRef,& - error) + CPSourceFileRef) !$omp parallel do default(none) & !$omp shared(npoints, rhoa, eps_rho, r13a, grhoa, rhob) & diff --git a/src/xc/xc_derivative_desc.F b/src/xc/xc_derivative_desc.F index 3e8e951fd5..0cf202b635 100644 --- a/src/xc/xc_derivative_desc.F +++ b/src/xc/xc_derivative_desc.F @@ -51,15 +51,12 @@ MODULE xc_derivative_desc !> \param deriv_desc input string which describes the derivative and !> should be standardized !> \param res ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE standardize_derivative_desc(deriv_desc,res,error) + SUBROUTINE standardize_derivative_desc(deriv_desc,res) CHARACTER(len=*), INTENT(in) :: deriv_desc CHARACTER& (LEN=MAX_DERIVATIVE_DESC_LENGTH), & INTENT(OUT) :: res - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'standardize_derivative_desc', & routineP = moduleN//':'//routineN @@ -70,7 +67,7 @@ SUBROUTINE standardize_derivative_desc(deriv_desc,res,error) INTEGER :: i, l_label, pos, stat LOGICAL :: ordered - CALL create_split_derivative_desc(deriv_desc,deriv_array,error=error) + CALL create_split_derivative_desc(deriv_desc,deriv_array) ordered=.FALSE. DO WHILE(.not.ordered) @@ -94,7 +91,7 @@ SUBROUTINE standardize_derivative_desc(deriv_desc,res,error) END DO DEALLOCATE(deriv_array, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END SUBROUTINE standardize_derivative_desc @@ -102,14 +99,11 @@ END SUBROUTINE standardize_derivative_desc !> \brief returns an array of 1st order derivative descriptions !> \param deriv_desc input string which describes the derivative !> \param res ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE create_split_derivative_desc(deriv_desc,res,error) + SUBROUTINE create_split_derivative_desc(deriv_desc,res) CHARACTER(len=*), INTENT(in) :: deriv_desc CHARACTER(len=MAX_LABEL_LENGTH), & DIMENSION(:), POINTER :: res - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'create_split_derivative_desc', & routineP = moduleN//':'//routineN @@ -125,7 +119,7 @@ SUBROUTINE create_split_derivative_desc(deriv_desc,res,error) END DO ALLOCATE(res(nderiv),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) nderiv=0 DO i=1,LEN(deriv_desc) diff --git a/src/xc/xc_derivative_set_types.F b/src/xc/xc_derivative_set_types.F index 14cd316706..77ee0ca2f4 100644 --- a/src/xc/xc_derivative_set_types.F +++ b/src/xc/xc_derivative_set_types.F @@ -61,17 +61,14 @@ MODULE xc_derivative_set_types !> \param description the description of the derivative you want to have !> \param allocate_deriv if the derivative should be allocated when not present !> Defaults to false. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval res ... ! ***************************************************************************** - FUNCTION xc_dset_get_derivative(derivative_set, description, allocate_deriv, error) & + FUNCTION xc_dset_get_derivative(derivative_set, description, allocate_deriv) & RESULT(res) TYPE(xc_derivative_set_type), POINTER :: derivative_set CHARACTER(len=*), INTENT(in) :: description LOGICAL, INTENT(in), OPTIONAL :: allocate_deriv - TYPE(cp_error_type), INTENT(inout) :: error TYPE(xc_derivative_type), POINTER :: res CHARACTER(len=*), PARAMETER :: routineN = 'xc_dset_get_derivative', & @@ -88,27 +85,26 @@ FUNCTION xc_dset_get_derivative(derivative_set, description, allocate_deriv, err failure=.FALSE. NULLIFY(pos,deriv_att,cr3d_ptr) - CPPrecondition(ASSOCIATED(derivative_set),cp_failure_level,routineP,error,failure) - CPPrecondition(derivative_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(derivative_set),cp_failure_level,routineP,failure) + CPPrecondition(derivative_set%ref_count>0,cp_failure_level,routineP,failure) my_allocate_deriv=.FALSE. IF (PRESENT(allocate_deriv)) my_allocate_deriv=allocate_deriv NULLIFY(res) - CALL standardize_derivative_desc(description,std_deriv_desc,error=error) + CALL standardize_derivative_desc(description,std_deriv_desc) pos => derivative_set%derivs - DO WHILE(cp_sll_xc_deriv_next(pos,el_att=deriv_att,error=error)) + DO WHILE(cp_sll_xc_deriv_next(pos,el_att=deriv_att)) IF (deriv_att%desc == std_deriv_desc) THEN res => deriv_att EXIT END IF END DO IF (.NOT.ASSOCIATED(res).AND.my_allocate_deriv) THEN - CALL pw_pool_create_cr3d(derivative_set%pw_pool,cr3d_ptr,error=error) + CALL pw_pool_create_cr3d(derivative_set%pw_pool,cr3d_ptr) cr3d_ptr=0.0_dp CALL xc_derivative_create(res, std_deriv_desc, & - cr3d_ptr=cr3d_ptr, error=error) - CALL cp_sll_xc_deriv_insert_ordered(derivative_set%derivs,res,& - error=error) + cr3d_ptr=cr3d_ptr) + CALL cp_sll_xc_deriv_insert_ordered(derivative_set%derivs,res) END IF END FUNCTION xc_dset_get_derivative @@ -118,15 +114,12 @@ END FUNCTION xc_dset_get_derivative !> \param pw_pool pool where to get the cr3d arrays needed to store the !> derivatives !> \param local_bounds ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_dset_create(derivative_set, pw_pool, local_bounds, error) + SUBROUTINE xc_dset_create(derivative_set, pw_pool, local_bounds) TYPE(xc_derivative_set_type), POINTER :: derivative_set TYPE(pw_pool_type), OPTIONAL, POINTER :: pw_pool INTEGER, DIMENSION(2, 3), OPTIONAL :: local_bounds - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_dset_create', & routineP = moduleN//':'//routineN @@ -137,10 +130,10 @@ SUBROUTINE xc_dset_create(derivative_set, pw_pool, local_bounds, error) failure=.FALSE. NULLIFY(pw_grid) - CPPrecondition(.not.ASSOCIATED(derivative_set),cp_failure_level,routineP,error,failure) + CPPrecondition(.not.ASSOCIATED(derivative_set),cp_failure_level,routineP,failure) ALLOCATE(derivative_set, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) NULLIFY(derivative_set%derivs) derivative_set%ref_count = 1 @@ -148,20 +141,20 @@ SUBROUTINE xc_dset_create(derivative_set, pw_pool, local_bounds, error) derivative_set%id_nr = derivative_set_last_id_nr IF (PRESENT(pw_pool)) THEN derivative_set%pw_pool => pw_pool - CALL pw_pool_retain(pw_pool, error=error) + CALL pw_pool_retain(pw_pool) IF (PRESENT(local_bounds)) THEN CALL cp_assert(ALL(pw_pool%pw_grid%bounds_local==local_bounds),& cp_failure_level,cp_assertion_failed,routineP,& - "incompatible local_bounds and pw_pool",error,failure) + "incompatible local_bounds and pw_pool",failure) END IF ELSE !FM ugly hack, should be replaced by a pool only for 3d arrays - CPPrecondition(PRESENT(local_bounds),cp_failure_level,routineP,error,failure) - CALL pw_grid_create(pw_grid,MPI_COMM_SELF,error=error) + CPPrecondition(PRESENT(local_bounds),cp_failure_level,routineP,failure) + CALL pw_grid_create(pw_grid,MPI_COMM_SELF) pw_grid%bounds_local=local_bounds NULLIFY(derivative_set%pw_pool) - CALL pw_pool_create(derivative_set%pw_pool, pw_grid, error=error) - CALL pw_grid_release(pw_grid,error=error) + CALL pw_pool_create(derivative_set%pw_pool, pw_grid) + CALL pw_grid_release(pw_grid) END IF END SUBROUTINE xc_dset_create @@ -169,13 +162,10 @@ END SUBROUTINE xc_dset_create ! ***************************************************************************** !> \brief releases a derivative set !> \param derivative_set the set to release -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_dset_release(derivative_set, error) + SUBROUTINE xc_dset_release(derivative_set) TYPE(xc_derivative_set_type), POINTER :: derivative_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_dset_release', & routineP = moduleN//':'//routineN @@ -188,21 +178,20 @@ SUBROUTINE xc_dset_release(derivative_set, error) failure=.FALSE. NULLIFY(deriv_att,pos) - CPPrecondition(ASSOCIATED(derivative_set),cp_failure_level,routineP,error,failure) - CPPrecondition(derivative_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(derivative_set),cp_failure_level,routineP,failure) + CPPrecondition(derivative_set%ref_count>0,cp_failure_level,routineP,failure) derivative_set%ref_count = derivative_set%ref_count - 1 IF (derivative_set%ref_count == 0) THEN pos => derivative_set%derivs - DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att,error=error)) - CALL xc_derivative_release(deriv_att, pw_pool=derivative_set%pw_pool,& - error=error) + DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att)) + CALL xc_derivative_release(deriv_att, pw_pool=derivative_set%pw_pool) END DO - CALL cp_sll_xc_deriv_dealloc(derivative_set%derivs,error=error) - CALL pw_pool_release(derivative_set%pw_pool,error=error) + CALL cp_sll_xc_deriv_dealloc(derivative_set%derivs) + CALL pw_pool_release(derivative_set%pw_pool) DEALLOCATE(derivative_set, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(derivative_set) @@ -211,15 +200,12 @@ END SUBROUTINE xc_dset_release ! ***************************************************************************** !> \brief retains the given derivative set !> \param deriv_set the derivative set to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE xc_dset_retain(deriv_set,error) +SUBROUTINE xc_dset_retain(deriv_set) TYPE(xc_derivative_set_type), POINTER :: deriv_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_dset_retain', & routineP = moduleN//':'//routineN @@ -228,20 +214,18 @@ SUBROUTINE xc_dset_retain(deriv_set,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(deriv_set%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPreconditionNoFail(deriv_set%ref_count>0,cp_failure_level,routineP) deriv_set%ref_count=deriv_set%ref_count+1 END SUBROUTINE xc_dset_retain ! ***************************************************************************** !> \brief ... !> \param deriv_set ... -!> \param error ... ! ***************************************************************************** -SUBROUTINE xc_dset_zero_all(deriv_set, error) +SUBROUTINE xc_dset_zero_all(deriv_set) TYPE(xc_derivative_set_type), POINTER :: deriv_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_dset_zero_all', & routineP = moduleN//':'//routineN @@ -253,9 +237,9 @@ SUBROUTINE xc_dset_zero_all(deriv_set, error) failure = .FALSE. NULLIFY(pos, deriv_att) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) pos => deriv_set%derivs - DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att, error=error)) + DO WHILE (cp_sll_xc_deriv_next(pos,el_att=deriv_att)) deriv_att%deriv_data = 0.0_dp END DO diff --git a/src/xc/xc_derivative_types.F b/src/xc/xc_derivative_types.F index 47242be30a..9af8059c11 100644 --- a/src/xc/xc_derivative_types.F +++ b/src/xc/xc_derivative_types.F @@ -59,16 +59,13 @@ MODULE xc_derivative_types !> \param desc the derivative description !> \param cr3d_ptr the data array (the ownership of it passes to the !> derivative type), the array is not zeroed -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_derivative_create(derivative, desc, cr3d_ptr, error) + SUBROUTINE xc_derivative_create(derivative, desc, cr3d_ptr) TYPE(xc_derivative_type), POINTER :: derivative CHARACTER(len=*), INTENT(in) :: desc REAL(kind=dp), DIMENSION(:, :, :), & POINTER :: cr3d_ptr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_derivative_create', & routineP = moduleN//':'//routineN @@ -81,13 +78,13 @@ SUBROUTINE xc_derivative_create(derivative, desc, cr3d_ptr, error) failure=.FALSE. ALLOCATE(derivative, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) derivative%ref_count = 1 derivative%id_nr = derivative_id_nr derivative_id_nr = derivative_id_nr + 1 - CALL standardize_derivative_desc(desc,my_desc,error=error) - CALL create_split_derivative_desc(my_desc,derivative%split_desc,error=error) + CALL standardize_derivative_desc(desc,my_desc) + CALL create_split_derivative_desc(my_desc,derivative%split_desc) derivative%desc = my_desc derivative%deriv_data => cr3d_ptr @@ -96,15 +93,12 @@ END SUBROUTINE xc_derivative_create ! ***************************************************************************** !> \brief retains the given derivative (see doc/ReferenceCounting.html) !> \param deriv the object you want to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE xc_derivative_retain(deriv,error) +SUBROUTINE xc_derivative_retain(deriv) TYPE(xc_derivative_type), POINTER :: deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_derivative_retain', & routineP = moduleN//':'//routineN @@ -113,8 +107,8 @@ SUBROUTINE xc_derivative_retain(deriv,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(deriv),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(deriv%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(deriv),cp_failure_level,routineP,failure) + CPPreconditionNoFail(deriv%ref_count>0,cp_failure_level,routineP) deriv%ref_count=deriv%ref_count+1 END SUBROUTINE xc_derivative_retain @@ -123,14 +117,11 @@ END SUBROUTINE xc_derivative_retain !> \param derivative the object to create !> \param pw_pool if given gives back the cr3d array %deriv_data back to it !> instead of deallocating it -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_derivative_release(derivative, pw_pool, error) + SUBROUTINE xc_derivative_release(derivative, pw_pool) TYPE(xc_derivative_type), POINTER :: derivative TYPE(pw_pool_type), OPTIONAL, POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_derivative_release', & routineP = moduleN//':'//routineN @@ -140,26 +131,26 @@ SUBROUTINE xc_derivative_release(derivative, pw_pool, error) failure=.FALSE. - CPPrecondition(ASSOCIATED(derivative),cp_failure_level,routineP,error,failure) - CPPrecondition(derivative%ref_count>=1,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(derivative),cp_failure_level,routineP,failure) + CPPrecondition(derivative%ref_count>=1,cp_failure_level,routineP,failure) derivative%ref_count = derivative%ref_count - 1 IF (derivative%ref_count == 0) THEN IF (PRESENT(pw_pool)) THEN IF (ASSOCIATED(pw_pool)) THEN CALL pw_pool_give_back_cr3d(pw_pool, derivative%deriv_data,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) END IF END IF IF (ASSOCIATED(derivative%deriv_data)) THEN DEALLOCATE(derivative%deriv_data, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF DEALLOCATE(derivative%split_desc, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE(derivative, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END IF NULLIFY(derivative) @@ -177,11 +168,9 @@ END SUBROUTINE xc_derivative_release !> \param order the order of the derivative !> \param deriv_data the 3d real array with the derivative !> \param accept_null_data if deriv_data can be unassociated (defaults to no) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE xc_derivative_get(deriv,desc,split_desc,& - order,deriv_data,accept_null_data, error) + order,deriv_data,accept_null_data) TYPE(xc_derivative_type), POINTER :: deriv CHARACTER& (len=MAX_DERIVATIVE_DESC_LENGTH), & @@ -192,7 +181,6 @@ SUBROUTINE xc_derivative_get(deriv,desc,split_desc,& REAL(kind=dp), DIMENSION(:, :, :), & OPTIONAL, POINTER :: deriv_data LOGICAL, INTENT(in), OPTIONAL :: accept_null_data - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_derivative_get', & routineP = moduleN//':'//routineN @@ -203,14 +191,14 @@ SUBROUTINE xc_derivative_get(deriv,desc,split_desc,& my_accept_null_data=.FALSE. IF (PRESENT(accept_null_data)) my_accept_null_data=accept_null_data - CPPrecondition(ASSOCIATED(deriv),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(deriv),cp_failure_level,routineP,failure) + CPPrecondition(deriv%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(desc)) desc = deriv%desc IF (PRESENT(split_desc)) split_desc => deriv%split_desc IF (PRESENT(deriv_data)) THEN deriv_data => deriv%deriv_data IF (.NOT.my_accept_null_data) THEN - CPPrecondition(ASSOCIATED(deriv_data),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(deriv_data),cp_failure_level,routineP,failure) END IF END IF IF (PRESENT(order)) order=SIZE(deriv%split_desc) diff --git a/src/xc/xc_derivatives.F b/src/xc/xc_derivatives.F index 6c435841c3..e9be9a3ce9 100644 --- a/src/xc/xc_derivatives.F +++ b/src/xc/xc_derivatives.F @@ -142,12 +142,10 @@ MODULE xc_derivatives !> functional are set to true (the flags not needed aren't touched) !> \param max_deriv the maximal derivative available !> \param ifunc_name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE xc_functional_get_info(functional,lsd,reference,shortform,& - needs, max_deriv, ifunc_name, error) + needs, max_deriv, ifunc_name) TYPE(section_vals_type), POINTER :: functional LOGICAL, INTENT(in) :: lsd CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -155,7 +153,6 @@ SUBROUTINE xc_functional_get_info(functional,lsd,reference,shortform,& INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv INTEGER, INTENT(in), OPTIONAL :: ifunc_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_functional_get_info', & routineP = moduleN//':'//routineN @@ -166,199 +163,176 @@ SUBROUTINE xc_functional_get_info(functional,lsd,reference,shortform,& failure=.FALSE. - CPPrecondition(ASSOCIATED(functional),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(functional),cp_failure_level,routineP,failure) SELECT CASE(functional%section%name) CASE("BECKE97") IF (lsd) THEN CALL b97_lsd_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, b97_params=functional, error=error) + needs=needs, max_deriv=max_deriv, b97_params=functional) ELSE CALL b97_lda_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, b97_params=functional, error=error) + needs=needs, max_deriv=max_deriv, b97_params=functional) END IF CASE("BECKE88_LR_ADIABATIC") IF (lsd) THEN CALL xb88_lr_adiabatic_lsd_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) ELSE CALL xb88_lr_adiabatic_lda_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) END IF CASE("LYP_ADIABATIC") IF (lsd) THEN CALL lyp_adiabatic_lsd_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) ELSE CALL lyp_adiabatic_lda_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) END IF CASE("BEEF") IF (lsd) THEN CALL xbeef_lsd_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) ELSE CALL xbeef_lda_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) END IF CASE("BECKE88") IF (lsd) THEN CALL xb88_lsd_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) ELSE CALL xb88_lda_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) END IF CASE("BECKE88_LR") IF (lsd) THEN CALL xb88_lr_lsd_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) ELSE CALL xb88_lr_lda_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) END IF CASE("LYP") IF (lsd) THEN CALL lyp_lsd_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) ELSE CALL lyp_lda_info(reference=reference,shortform=shortform,& - needs=needs, max_deriv=max_deriv, error=error) + needs=needs, max_deriv=max_deriv) END IF CASE("PADE") - CALL pade(reference, shortform, lsd=lsd, needs=needs, error=error) + CALL pade(reference, shortform, lsd=lsd, needs=needs) CASE("HCTH") - CALL section_vals_val_get(functional,"PARAMETER_SET",i_val=i_param,& - error=error) - CPPrecondition(.NOT.lsd,cp_warning_level,routineP,error,failure) - CALL hcth_lda_info(i_param,reference,shortform,needs,max_deriv,error=error) + CALL section_vals_val_get(functional,"PARAMETER_SET",i_val=i_param) + CPPrecondition(.NOT.lsd,cp_warning_level,routineP,failure) + CALL hcth_lda_info(i_param,reference,shortform,needs,max_deriv) CASE("OPTX") IF (lsd) THEN - CALL optx_lsd_info(reference,shortform,needs,max_deriv,error=error) + CALL optx_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL optx_lda_info(reference,shortform,needs,max_deriv,error=error) + CALL optx_lda_info(reference,shortform,needs,max_deriv) ENDIF CASE("LIBXC","KE_LIBXC") IF (lsd) THEN CALL libxc_lsd_info(functional,reference,shortform,needs,max_deriv,& - ifunc_name,error=error) + ifunc_name) ELSE CALL libxc_lda_info(functional,reference,shortform,needs,max_deriv,& - ifunc_name,error=error) + ifunc_name) ENDIF CASE("CS1") IF (lsd) THEN - CALL cs1_lsd_info(reference,shortform,needs,max_deriv,error=error) + CALL cs1_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL cs1_lda_info(reference, shortform, needs=needs, max_deriv=max_deriv,& - error=error) + CALL cs1_lda_info(reference, shortform, needs=needs, max_deriv=max_deriv) ENDIF CASE("XGGA") - CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param,& - error=error) - CALL xgga_info(i_param,lsd,reference,shortform,needs,max_deriv,error=error) + CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param) + CALL xgga_info(i_param,lsd,reference,shortform,needs,max_deriv) CASE("KE_GGA") - CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param,& - error=error) - CALL ke_gga_info(i_param,lsd,reference,shortform,needs,max_deriv,error=error) + CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param) + CALL ke_gga_info(i_param,lsd,reference,shortform,needs,max_deriv) CASE("P86C") - CPPrecondition(.NOT.lsd,cp_warning_level,routineP,error,failure) + CPPrecondition(.NOT.lsd,cp_warning_level,routineP,failure) IF(failure) THEN CALL stop_program(routineN,moduleN,__LINE__,& "BP functional not implemented with LSD") END IF - CALL p86_lda_info(reference,shortform,needs,max_deriv,error=error) + CALL p86_lda_info(reference,shortform,needs,max_deriv) CASE("PW92") - CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param,& - error=error) - CALL section_vals_val_get(functional,"SCALE",r_val=r_param,& - error=error) + CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param) + CALL section_vals_val_get(functional,"SCALE",r_val=r_param) CALL perdew_wang_info(i_param,lsd,reference,shortform,needs,max_deriv,& - r_param,error=error) + r_param) CASE("PZ81") - CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param,& - error=error) - CALL pz_info(i_param,lsd,reference,shortform,needs,max_deriv,error=error) + CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param) + CALL pz_info(i_param,lsd,reference,shortform,needs,max_deriv) CASE("TFW") IF (lsd) THEN - CALL tfw_lsd_info(reference,shortform,needs,max_deriv,error=error) + CALL tfw_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL tfw_lda_info(reference,shortform,needs,max_deriv,error=error) + CALL tfw_lda_info(reference,shortform,needs,max_deriv) END IF CASE("TF") - CALL thomas_fermi_info(lsd,reference,shortform,needs,max_deriv,error=error) + CALL thomas_fermi_info(lsd,reference,shortform,needs,max_deriv) CASE("VWN") IF (lsd) THEN - CALL vwn_lda_info(reference,shortform,needs,max_deriv,error=error) + CALL vwn_lda_info(reference,shortform,needs,max_deriv) ELSE - CALL vwn_lda_info(reference,shortform,needs,max_deriv,error=error) + CALL vwn_lda_info(reference,shortform,needs,max_deriv) END IF CASE("XALPHA") - CALL section_vals_val_get(functional,"XA",r_val=r_param,& - error=error) + CALL section_vals_val_get(functional,"XA",r_val=r_param) CALL xalpha_info(lsd,reference,shortform,needs,max_deriv,& - xa_parameter=r_param,error=error) + xa_parameter=r_param) CASE("TPSS") IF (lsd) THEN - CALL tpss_lsd_info(functional,reference,shortform,needs,max_deriv,& - error=error) + CALL tpss_lsd_info(functional,reference,shortform,needs,max_deriv) ELSE - CALL tpss_lda_info(functional,reference,shortform,needs,max_deriv,& - error=error) + CALL tpss_lda_info(functional,reference,shortform,needs,max_deriv) END IF CASE("PBE") IF (lsd) THEN - CALL pbe_lsd_info(functional,reference,shortform,needs,max_deriv,& - error=error) + CALL pbe_lsd_info(functional,reference,shortform,needs,max_deriv) ELSE - CALL pbe_lda_info(functional,reference,shortform,needs,max_deriv,& - error=error) + CALL pbe_lda_info(functional,reference,shortform,needs,max_deriv) END IF CASE("XWPBE") IF (lsd) THEN - CALL xwpbe_lsd_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xwpbe_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL xwpbe_lda_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xwpbe_lda_info(reference,shortform,needs,max_deriv) END IF CASE("BECKE_ROUSSEL") IF (lsd) THEN - CALL xbecke_roussel_lsd_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xbecke_roussel_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL xbecke_roussel_lda_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xbecke_roussel_lda_info(reference,shortform,needs,max_deriv) END IF CASE("LDA_HOLE_T_C_LR") IF (lsd) THEN - CALL xlda_hole_t_c_lr_lsd_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xlda_hole_t_c_lr_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL xlda_hole_t_c_lr_lda_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xlda_hole_t_c_lr_lda_info(reference,shortform,needs,max_deriv) END IF CASE("PBE_HOLE_T_C_LR") IF (lsd) THEN - CALL xpbe_hole_t_c_lr_lsd_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xpbe_hole_t_c_lr_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL xpbe_hole_t_c_lr_lda_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xpbe_hole_t_c_lr_lda_info(reference,shortform,needs,max_deriv) END IF CASE("GV09") IF (lsd) THEN - CALL xbr_pbe_lda_hole_tc_lr_lsd_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xbr_pbe_lda_hole_tc_lr_lsd_info(reference,shortform,needs,max_deriv) ELSE - CALL xbr_pbe_lda_hole_tc_lr_lda_info(reference,shortform,needs,max_deriv,& - error=error) + CALL xbr_pbe_lda_hole_tc_lr_lda_info(reference,shortform,needs,max_deriv) END IF CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& message="unknown functional '"//TRIM(functional%section%name)//& "' in "//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) END SELECT END SUBROUTINE xc_functional_get_info @@ -378,14 +352,12 @@ END SUBROUTINE xc_functional_get_info !> them when adding derivatives of various functionals they might contain !> the derivative of just one functional) !> \param ifunc_name ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** SUBROUTINE xc_functional_eval(functional, lsd, rho_set, deriv_set, & - deriv_order, ifunc_name, error) + deriv_order, ifunc_name) TYPE(section_vals_type), POINTER :: functional LOGICAL, INTENT(in) :: lsd @@ -393,7 +365,6 @@ SUBROUTINE xc_functional_eval(functional, lsd, rho_set, deriv_set, & TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: deriv_order INTEGER, INTENT(in), OPTIONAL :: ifunc_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_functional_eval', & routineP = moduleN//':'//routineN @@ -407,9 +378,9 @@ SUBROUTINE xc_functional_eval(functional, lsd, rho_set, deriv_set, & failure=.FALSE. CALL xc_rho_set_get(rho_set,rho_cutoff=density_cut,& - drho_cutoff=gradient_cut,error=error) + drho_cutoff=gradient_cut) CALL section_vals_val_get(functional,"_SECTION_PARAMETERS_",& - l_val=fun_active,error=error) + l_val=fun_active) IF (.NOT.fun_active) THEN CALL timestop(handle) RETURN @@ -418,189 +389,181 @@ SUBROUTINE xc_functional_eval(functional, lsd, rho_set, deriv_set, & SELECT CASE(functional%section%name) CASE("BECKE97") IF (lsd) THEN - CALL b97_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL b97_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL b97_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL b97_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("BECKE88_LR_ADIABATIC") IF (lsd) THEN - CALL xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("LYP_ADIABATIC") IF (lsd) THEN - CALL lyp_adiabatic_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL lyp_adiabatic_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL lyp_adiabatic_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL lyp_adiabatic_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("BECKE88") IF (lsd) THEN - CALL xb88_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xb88_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xb88_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xb88_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("BEEF") IF (lsd) THEN - CALL xbeef_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xbeef_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xbeef_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xbeef_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("BECKE88_LR") IF (lsd) THEN - CALL xb88_lr_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xb88_lr_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xb88_lr_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xb88_lr_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("LYP") IF (lsd) THEN - CALL lyp_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL lyp_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL lyp_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL lyp_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("PADE") CALL pade(density_cut) IF (lsd) THEN - CALL pade_lsd_pw_eval(deriv_set, rho_set, deriv_order, error=error) + CALL pade_lsd_pw_eval(deriv_set, rho_set, deriv_order) ELSE - CALL pade_lda_pw_eval(deriv_set, rho_set, deriv_order, error=error) + CALL pade_lda_pw_eval(deriv_set, rho_set, deriv_order) END IF CASE("HCTH") - CPPrecondition(.NOT.lsd,cp_warning_level,routineP,error,failure) - CALL section_vals_val_get(functional,"PARAMETER_SET",i_val=i_param,& - error=error) - CALL hcth_lda_eval(i_param,rho_set,deriv_set,deriv_order,error=error) + CPPrecondition(.NOT.lsd,cp_warning_level,routineP,failure) + CALL section_vals_val_get(functional,"PARAMETER_SET",i_val=i_param) + CALL hcth_lda_eval(i_param,rho_set,deriv_set,deriv_order) CASE("OPTX") IF (lsd) THEN - CALL optx_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL optx_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL optx_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL optx_lda_eval(rho_set,deriv_set,deriv_order,functional) ENDIF CASE("LIBXC","KE_LIBXC") IF (lsd) THEN - CALL libxc_lsd_eval(rho_set,deriv_set,deriv_order,functional,ifunc_name,error=error) + CALL libxc_lsd_eval(rho_set,deriv_set,deriv_order,functional,ifunc_name) ELSE - CALL libxc_lda_eval(rho_set,deriv_set,deriv_order,functional,ifunc_name,error=error) + CALL libxc_lda_eval(rho_set,deriv_set,deriv_order,functional,ifunc_name) ENDIF CASE("CS1") IF (lsd) THEN - CALL cs1_lsd_eval(rho_set,deriv_set,deriv_order,error=error) + CALL cs1_lsd_eval(rho_set,deriv_set,deriv_order) ELSE - CALL cs1_lda_eval(rho_set,deriv_set,deriv_order,error=error) + CALL cs1_lda_eval(rho_set,deriv_set,deriv_order) ENDIF CASE("XGGA") - CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param,& - error=error) - CALL xgga_eval(i_param,lsd,rho_set,deriv_set,deriv_order,error=error) + CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param) + CALL xgga_eval(i_param,lsd,rho_set,deriv_set,deriv_order) CASE("KE_GGA") - CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param,& - error=error) + CALL section_vals_val_get(functional,"FUNCTIONAL",i_val=i_param) IF (lsd) THEN - CALL ke_gga_lsd_eval(i_param,rho_set,deriv_set,deriv_order,error=error) + CALL ke_gga_lsd_eval(i_param,rho_set,deriv_set,deriv_order) ELSE - CALL ke_gga_lda_eval(i_param,rho_set,deriv_set,deriv_order,error=error) + CALL ke_gga_lda_eval(i_param,rho_set,deriv_set,deriv_order) END IF CASE("P86C") - CPPrecondition(.NOT.lsd,cp_warning_level,routineP,error,failure) - CALL p86_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CPPrecondition(.NOT.lsd,cp_warning_level,routineP,failure) + CALL p86_lda_eval(rho_set,deriv_set,deriv_order,functional) CASE("PW92") - CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param,& - error=error) - CALL section_vals_val_get(functional,"SCALE",r_val=r_param,& - error=error) + CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param) + CALL section_vals_val_get(functional,"SCALE",r_val=r_param) IF (lsd) THEN CALL perdew_wang_lsd_eval(i_param,rho_set,deriv_set,deriv_order,& - r_param,error=error) + r_param) ELSE CALL perdew_wang_lda_eval(i_param,rho_set,deriv_set,deriv_order,& - r_param,error=error) + r_param) END IF CASE("PZ81") - CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param,& - error=error) + CALL section_vals_val_get(functional,"PARAMETRIZATION",i_val=i_param) IF (lsd) THEN - CALL pz_lsd_eval(i_param,rho_set,deriv_set,deriv_order,functional,error=error) + CALL pz_lsd_eval(i_param,rho_set,deriv_set,deriv_order,functional) ELSE - CALL pz_lda_eval(i_param,rho_set,deriv_set,deriv_order,functional,error=error) + CALL pz_lda_eval(i_param,rho_set,deriv_set,deriv_order,functional) END IF CASE("TFW") IF (lsd) THEN - CALL tfw_lsd_eval(rho_set,deriv_set,deriv_order,error=error) + CALL tfw_lsd_eval(rho_set,deriv_set,deriv_order) ELSE - CALL tfw_lda_eval(rho_set,deriv_set,deriv_order,error=error) + CALL tfw_lda_eval(rho_set,deriv_set,deriv_order) END IF CASE ("TF") IF (lsd) THEN - CALL thomas_fermi_lsd_eval(rho_set,deriv_set,deriv_order,error=error) + CALL thomas_fermi_lsd_eval(rho_set,deriv_set,deriv_order) ELSE - CALL thomas_fermi_lda_eval(rho_set,deriv_set,deriv_order,error=error) + CALL thomas_fermi_lda_eval(rho_set,deriv_set,deriv_order) END IF CASE("VWN") IF (lsd) THEN - CALL vwn_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL vwn_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL vwn_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL vwn_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("XALPHA") - CALL section_vals_val_get(functional,"XA",r_val=r_param,& - error=error) + CALL section_vals_val_get(functional,"XA",r_val=r_param) IF (lsd) THEN CALL xalpha_lsd_eval(rho_set,deriv_set,deriv_order,& - xa_parameter=r_param,xa_params=functional,error=error) + xa_parameter=r_param,xa_params=functional) ELSE CALL xalpha_lda_eval(rho_set,deriv_set,deriv_order,& - xa_parameter=r_param,xa_params=functional,error=error) + xa_parameter=r_param,xa_params=functional) END IF CASE("TPSS") IF (lsd) THEN - CALL tpss_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL tpss_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL tpss_lda_eval(rho_set,deriv_set,deriv_order,functional, error=error) + CALL tpss_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("PBE") IF (lsd) THEN - CALL pbe_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL pbe_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL pbe_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL pbe_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("XWPBE") IF (lsd) THEN - CALL xwpbe_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xwpbe_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xwpbe_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xwpbe_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("BECKE_ROUSSEL") IF (lsd) THEN - CALL xbecke_roussel_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xbecke_roussel_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xbecke_roussel_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xbecke_roussel_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("LDA_HOLE_T_C_LR") IF (lsd) THEN - CALL xlda_hole_t_c_lr_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xlda_hole_t_c_lr_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xlda_hole_t_c_lr_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xlda_hole_t_c_lr_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("PBE_HOLE_T_C_LR") IF (lsd) THEN - CALL xpbe_hole_t_c_lr_lsd_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xpbe_hole_t_c_lr_lsd_eval(rho_set,deriv_set,deriv_order,functional) ELSE - CALL xpbe_hole_t_c_lr_lda_eval(rho_set,deriv_set,deriv_order,functional,error=error) + CALL xpbe_hole_t_c_lr_lda_eval(rho_set,deriv_set,deriv_order,functional) END IF CASE("GV09") IF (lsd) THEN CALL xbr_pbe_lda_hole_tc_lr_lsd_eval(rho_set,deriv_set,deriv_order, & - functional,error=error) + functional) ELSE CALL xbr_pbe_lda_hole_tc_lr_lda_eval(rho_set,deriv_set,deriv_order, & - functional,error=error) + functional) END IF CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& message="unknown functional '"//TRIM(functional%section%name)//& "' in "//& -CPSourceFileRef,& - error=error) +CPSourceFileRef) END SELECT CALL timestop(handle) @@ -622,18 +585,15 @@ END SUBROUTINE xc_functional_eval !> the code all the derivatives might be calculated, you should ignore !> them when adding derivatives of various functionals they might contain !> the derivative of just one functional) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE xc_functionals_eval(functionals, lsd, rho_set, deriv_set, & - deriv_order, error) + deriv_order) TYPE(section_vals_type), POINTER :: functionals LOGICAL, INTENT(in) :: lsd TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: deriv_order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_functionals_eval', & routineP = moduleN//':'//routineN @@ -646,29 +606,27 @@ SUBROUTINE xc_functionals_eval(functionals, lsd, rho_set, deriv_set, & failure=.FALSE. - CPPrecondition(ASSOCIATED(functionals),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(functionals),cp_failure_level,routineP,failure) ifun=0 DO ifun=ifun+1 - xc_fun => section_vals_get_subs_vals2(functionals,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(functionals,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT CALL xc_functional_eval(xc_fun, & lsd=lsd,& rho_set=rho_set, & deriv_set=deriv_set,& deriv_order=deriv_order, & - ifunc_name=1, & - error=error) + ifunc_name=1) IF (TRIM(xc_fun%section%name) == "LIBXC") THEN - CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name,error=error) + CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name) DO ifunc_name=2, SIZE(func_name) CALL xc_functional_eval(xc_fun, & lsd=lsd,& rho_set=rho_set, & deriv_set=deriv_set,& deriv_order=deriv_order, & - ifunc_name=ifunc_name, & - error=error) + ifunc_name=ifunc_name) END DO END IF END DO @@ -682,17 +640,14 @@ END SUBROUTINE xc_functionals_eval !> \param add_basic_components makes sure that if some gradient combination !> is needed also the gradient components are requested, and if lsd !> is true rho_spin is requested. Defaults to false. -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval needs ... !> \author fawzi ! ***************************************************************************** -FUNCTION xc_functionals_get_needs(functionals, lsd, add_basic_components,& - error) RESULT(needs) +FUNCTION xc_functionals_get_needs(functionals, lsd, add_basic_components)& + RESULT(needs) TYPE(section_vals_type), POINTER :: functionals LOGICAL, INTENT(in) :: lsd LOGICAL, INTENT(in), OPTIONAL :: add_basic_components - TYPE(cp_error_type), INTENT(inout) :: error TYPE(xc_rho_cflags_type) :: needs CHARACTER(len=*), PARAMETER :: routineN = 'xc_functionals_get_needs', & @@ -708,18 +663,18 @@ FUNCTION xc_functionals_get_needs(functionals, lsd, add_basic_components,& my_add_basic_components=.FALSE. IF (PRESENT(add_basic_components)) my_add_basic_components=add_basic_components - CPPrecondition(ASSOCIATED(functionals),cp_failure_level,routineP,error,failure) - CALL xc_rho_cflags_setall(needs,.FALSE.,error=error) + CPPrecondition(ASSOCIATED(functionals),cp_failure_level,routineP,failure) + CALL xc_rho_cflags_setall(needs,.FALSE.) ifun=0 DO ifun=ifun+1 - xc_fun => section_vals_get_subs_vals2(functionals,i_section=ifun,error=error) + xc_fun => section_vals_get_subs_vals2(functionals,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT - CALL xc_functional_get_info(xc_fun,lsd=lsd,needs=needs,ifunc_name=1,error=error) + CALL xc_functional_get_info(xc_fun,lsd=lsd,needs=needs,ifunc_name=1) IF (TRIM(xc_fun%section%name) == "LIBXC") THEN - CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name,error=error) + CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name) DO ifunc_name=2, SIZE(func_name) - CALL xc_functional_get_info(xc_fun,lsd=lsd,needs=needs,ifunc_name=ifunc_name,error=error) + CALL xc_functional_get_info(xc_fun,lsd=lsd,needs=needs,ifunc_name=ifunc_name) END DO END IF END DO diff --git a/src/xc/xc_exchange_gga.F b/src/xc/xc_exchange_gga.F index 855c938bcb..d510a4d58d 100644 --- a/src/xc/xc_exchange_gga.F +++ b/src/xc/xc_exchange_gga.F @@ -66,18 +66,15 @@ MODULE xc_exchange_gga !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE xgga_info(functional,lsd,reference,shortform, needs, max_deriv, error) + SUBROUTINE xgga_info(functional,lsd,reference,shortform, needs, max_deriv) INTEGER, INTENT(in) :: functional LOGICAL, INTENT(in) :: lsd CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xgga_info', & routineP = moduleN//':'//routineN @@ -100,8 +97,7 @@ SUBROUTINE xgga_info(functional,lsd,reference,shortform, needs, max_deriv, error reference = "E. Engel and S.H. Vosko, Phys. Rev. B, 47, 13164 (1993)" CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Invalid functional requested ("//cp_to_string(functional)//")",& - error) + "Invalid functional requested ("//cp_to_string(functional)//")") END SELECT IF (.not.lsd) THEN IF (LEN_TRIM(reference)+6 \param deriv_set place where to store the functional derivatives (they are !> added to the derivatives) !> \param order ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE xgga_eval(functional,lsd,rho_set,deriv_set,order,error) + SUBROUTINE xgga_eval(functional,lsd,rho_set,deriv_set,order) INTEGER, INTENT(in) :: functional LOGICAL, INTENT(in) :: lsd TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xgga_eval', & routineP = moduleN//':'//routineN @@ -198,23 +190,23 @@ SUBROUTINE xgga_eval(functional,lsd,rho_set,deriv_set,order,error) NULLIFY(norm_drho(ispin)%array, rho(ispin)%array, rho_1_3(ispin)%array) END DO - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) IF (lsd) THEN CALL xc_rho_set_get(rho_set,rhoa_1_3=rho_1_3(1)%array,& rhob_1_3=rho_1_3(2)%array,rhoa=rho(1)%array,& rhob=rho(2)%array,norm_drhoa=norm_drho(1)%array, & norm_drhob=norm_drho(2)%array,rho_cutoff=rho_cutoff,& - drho_cutoff=drho_cutoff, local_bounds=bo, error=error) + drho_cutoff=drho_cutoff, local_bounds=bo) nspin=2 rho_spin_name=(/"(rhoa)","(rhob)"/) norm_drho_spin_name=(/"(norm_drhoa)","(norm_drhob)"/) ELSE CALL xc_rho_set_get(rho_set,rho=rho(1)%array,rho_1_3=rho_1_3(1)%array,& norm_drho=norm_drho(1)%array,local_bounds=bo,rho_cutoff=rho_cutoff,& - drho_cutoff=drho_cutoff,error=error) + drho_cutoff=drho_cutoff) nspin=1 rho_spin_name=(/"(rho) ","(---) "/) norm_drho_spin_name=(/"(norm_drho) ","(----_----) "/) @@ -224,9 +216,9 @@ SUBROUTINE xgga_eval(functional,lsd,rho_set,deriv_set,order,error) CALL xgga_init(rho_cutoff) ALLOCATE ( s(npoints), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( fs(npoints,m+1), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,nspin IF (lsd) THEN @@ -270,77 +262,77 @@ SUBROUTINE xgga_eval(functional,lsd,rho_set,deriv_set,order,error) CALL efactor_ev93 ( s, fs, m ) IF (lsd) tact = 1.0_dp CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) CALL x_p_0 ( rho(ispin)%array, rho_1_3(ispin)%array, fs, e_0,& - npoints, error) + npoints) END IF IF ( order>=1 .OR. order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) CALL x_p_1 ( rho(ispin)%array, & - rho_1_3(ispin)%array, s, fs, e_rho, e_ndrho, npoints, error ) + rho_1_3(ispin)%array, s, fs, e_rho, e_ndrho, npoints) END IF IF ( order>=2 .OR. order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - rho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + rho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - norm_drho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho,error=error) + norm_drho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin)//& - norm_drho_spin_name(ispin), allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + norm_drho_spin_name(ispin), allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CALL x_p_2 ( rho(ispin)%array, & rho_1_3(ispin)%array, s, fs, e_rho_rho, e_rho_ndrho,& - e_ndrho_ndrho, npoints, error ) + e_ndrho_ndrho, npoints) END IF IF ( order>=3 .OR. order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& norm_drho_spin_name(ispin)//norm_drho_spin_name(ispin), & - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin)//& norm_drho_spin_name(ispin)//norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) CALL x_p_3 ( rho(ispin)%array,& rho_1_3(ispin)%array, s, fs, e_rho_rho_rho, & e_rho_rho_ndrho, e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho,& - npoints, error ) + npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO DEALLOCATE ( s, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE ( fs, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE xgga_eval @@ -372,9 +364,8 @@ END SUBROUTINE xgga_init !> \param fs ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE x_p_0 ( rho, r13, fs, e_0, npoints, error ) + SUBROUTINE x_p_0 ( rho, r13, fs, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13 REAL(KIND=dp), DIMENSION(:, :), & @@ -382,7 +373,6 @@ SUBROUTINE x_p_0 ( rho, r13, fs, e_0, npoints, error ) REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip @@ -411,9 +401,8 @@ END SUBROUTINE x_p_0 !> \param e_rho ... !> \param e_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE x_p_1 ( rho, r13, s, fs, e_rho,e_ndrho,npoints,error ) + SUBROUTINE x_p_1 ( rho, r13, s, fs, e_rho,e_ndrho,npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13, s REAL(KIND=dp), DIMENSION(:, :), & @@ -421,7 +410,6 @@ SUBROUTINE x_p_1 ( rho, r13, s, fs, e_rho,e_ndrho,npoints,error ) REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho, e_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: a0, a1, sx, sy @@ -460,10 +448,9 @@ END SUBROUTINE x_p_1 !> \param e_rho_ndrho ... !> \param e_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE x_p_2 ( rho, r13, s, fs, e_rho_rho, e_rho_ndrho, & - e_ndrho_ndrho, npoints, error ) + e_ndrho_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13, s REAL(KIND=dp), DIMENSION(:, :), & @@ -472,7 +459,6 @@ SUBROUTINE x_p_2 ( rho, r13, s, fs, e_rho_rho, e_rho_ndrho, & INTENT(INOUT) :: e_rho_rho, e_rho_ndrho, & e_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: a0, a1, a2, sx, sxx, sxy, sy @@ -518,10 +504,9 @@ END SUBROUTINE x_p_2 !> \param e_rho_ndrho_ndrho ... !> \param e_ndrho_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE x_p_3 ( rho, r13, s, fs, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints,error ) + e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13, s REAL(KIND=dp), DIMENSION(:, :), & @@ -532,7 +517,6 @@ SUBROUTINE x_p_3 ( rho, r13, s, fs, e_rho_rho_rho, e_rho_rho_ndrho,& e_rho_ndrho_ndrho, & e_ndrho_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: a0, a1, a2, a3, sx, sxx, & diff --git a/src/xc/xc_hcth.F b/src/xc/xc_hcth.F index 5177fe4c63..3e9f9e8981 100644 --- a/src/xc/xc_hcth.F +++ b/src/xc/xc_hcth.F @@ -38,17 +38,14 @@ MODULE xc_hcth !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE hcth_lda_info(iparset,reference,shortform, needs, max_deriv, error) + SUBROUTINE hcth_lda_info(iparset,reference,shortform, needs, max_deriv) INTEGER, INTENT(in) :: iparset CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hcth_lda_info', & routineP = moduleN//':'//routineN @@ -88,8 +85,7 @@ SUBROUTINE hcth_lda_info(iparset,reference,shortform, needs, max_deriv, error) END IF CASE default CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Invalid HCTH parameter set requested ("//cp_to_string(iparset)//")",& - error) + "Invalid HCTH parameter set requested ("//cp_to_string(iparset)//")") END SELECT IF (PRESENT(needs)) THEN needs%rho=.TRUE. @@ -108,16 +104,13 @@ END SUBROUTINE hcth_lda_info !> \param grad_deriv degree of the derivative that should be evalated, !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE hcth_lda_eval(iparset,rho_set,deriv_set,grad_deriv,error) + SUBROUTINE hcth_lda_eval(iparset,rho_set,deriv_set,grad_deriv) INTEGER, INTENT(in) :: iparset TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hcth_lda_eval', & routineP = moduleN//':'//routineN @@ -134,34 +127,34 @@ SUBROUTINE hcth_lda_eval(iparset,rho_set,deriv_set,grad_deriv,error) failure=.FALSE. NULLIFY(bo,e_0, e_ndrho, e_rho, norm_drho, rho) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,error=error) + norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL hcth_lda_calc(iparset=iparset,rho=rho, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,& - npoints=npoints,epsilon_rho=epsilon_rho,error=error) + npoints=npoints,epsilon_rho=epsilon_rho) END SUBROUTINE hcth_lda_eval ! ***************************************************************************** @@ -176,8 +169,6 @@ END SUBROUTINE hcth_lda_eval !> \param e_ndrho the derivative of the functional wrt. norm_drho !> \param epsilon_rho the cutoff on rho !> \param npoints ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi (copying from the routine of Matthias Krack in functionals.F) !> \note !> Literature:- F. A. Hamprecht, A. J. Cohen, D. J. Tozer, and N. C. Handy, @@ -190,14 +181,13 @@ END SUBROUTINE hcth_lda_eval !> Phys. Rev. B 45, 13244 (1992) -> PW92 ! ***************************************************************************** SUBROUTINE hcth_lda_calc(iparset,rho,norm_drho,e_0,e_rho,e_ndrho,& - epsilon_rho,npoints,error) + epsilon_rho,npoints) INTEGER, INTENT(IN) :: iparset REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, norm_drho REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0, e_rho, e_ndrho REAL(kind=dp), INTENT(in) :: epsilon_rho INTEGER, INTENT(IN) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'hcth_lda_calc', & routineP = moduleN//':'//routineN @@ -296,8 +286,7 @@ SUBROUTINE hcth_lda_calc(iparset,rho,norm_drho,e_0,e_rho,e_ndrho,& ccab(4) = -0.420052E+02_dp CASE DEFAULT CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,routineP,& - "Invalid HCTH parameter set requested ("//cp_to_string(iparset)//")",& - error) + "Invalid HCTH parameter set requested ("//cp_to_string(iparset)//")") END SELECT !$omp parallel do default(none) shared(rho,norm_drho,cxss,ccss,& diff --git a/src/xc/xc_ke_gga.F b/src/xc/xc_ke_gga.F index 3bf0286774..b484bb1a81 100644 --- a/src/xc/xc_ke_gga.F +++ b/src/xc/xc_ke_gga.F @@ -82,16 +82,14 @@ END SUBROUTINE ke_gga_init !> \param shortform ... !> \param needs ... !> \param max_deriv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ke_gga_info ( functional,lsd,reference, shortform, needs, max_deriv, error ) + SUBROUTINE ke_gga_info ( functional,lsd,reference, shortform, needs, max_deriv) INTEGER, INTENT(in) :: functional LOGICAL, INTENT(in) :: lsd CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ke_gga_info', & routineP = moduleN//':'//routineN @@ -173,16 +171,14 @@ END SUBROUTINE ke_gga_info !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ke_gga_lda_eval ( functional, rho_set, deriv_set, order, error ) + SUBROUTINE ke_gga_lda_eval ( functional, rho_set, deriv_set, order) INTEGER, INTENT(IN) :: functional TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'ke_gga_lda_eval', & routineP = moduleN//':'//routineN @@ -207,21 +203,21 @@ SUBROUTINE ke_gga_lda_eval ( functional, rho_set, deriv_set, order, error ) e_rho_rho_rho, e_rho_rho_ndrho, e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho) m = ABS(order) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=rho13,rho=rho,& norm_drho=grho,local_bounds=bo,rho_cutoff=rho_cutoff,& - drho_cutoff=drho_cutoff,error=error) + drho_cutoff=drho_cutoff) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL ke_gga_init(rho_cutoff) ALLOCATE ( s(npoints), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( fs(npoints,m+1), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! s = norm_drho/(rho^(4/3)*2*(pi*pi*3)^(1/3)) CALL calc_wave_vector ( "p", rho, grho, s ) @@ -237,12 +233,12 @@ SUBROUTINE ke_gga_lda_eval ( functional, rho_set, deriv_set, order, error ) CALL efactor_ol1 ( s, fs, m ) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"OL1 functional currently not working properly",& - error,failure) + failure) CASE (ke_ol2) CALL efactor_ol2 ( s, fs, m ) CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& routineP,"OL2 functional currently not working properly",& - error,failure) + failure) CASE (ke_llp) CALL efactor_llp ( s, fs, m ) CASE (ke_pw86) @@ -258,72 +254,70 @@ SUBROUTINE ke_gga_lda_eval ( functional, rho_set, deriv_set, order, error ) CASE (ke_revpbe) CALL efactor_pbex (s, fs, m, 2) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) - CALL kex_p_0 ( rho, rho13, fs, e_0, npoints, error=error ) + CALL kex_p_0 ( rho, rho13, fs, e_0, npoints) END IF IF ( order>=1 .OR. order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) CALL kex_p_1 ( rho, rho13, s, fs, e_rho=e_rho, e_ndrho=e_ndrho,& - npoints=npoints, error=error) + npoints=npoints) END IF IF ( order>=2 .OR. order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(rho)(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CALL kex_p_2 ( rho, rho13, s, fs, e_rho_rho=e_rho_rho,& - e_rho_ndrho=e_rho_ndrho, e_ndrho_ndrho=e_ndrho_ndrho, npoints=npoints,& - error=error ) + e_rho_ndrho=e_rho_ndrho, e_ndrho_ndrho=e_ndrho_ndrho, npoints=npoints) END IF IF ( order>=3 .OR. order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho,error=error) + "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho,error=error) + "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) CALL kex_p_3 ( rho, rho13, s, fs, e_rho_rho_rho=e_rho_rho_rho,& e_rho_rho_ndrho=e_rho_rho_ndrho, e_rho_ndrho_ndrho=e_rho_ndrho_ndrho,& - e_ndrho_ndrho_ndrho=e_ndrho_ndrho_ndrho,npoints=npoints,error=error) + e_ndrho_ndrho_ndrho=e_ndrho_ndrho_ndrho,npoints=npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DEALLOCATE ( s, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE ( fs, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) @@ -335,17 +329,14 @@ END SUBROUTINE ke_gga_lda_eval !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE ke_gga_lsd_eval ( functional, rho_set, deriv_set, order, & - error ) + SUBROUTINE ke_gga_lsd_eval ( functional, rho_set, deriv_set, order) INTEGER, INTENT(IN) :: functional TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN), OPTIONAL :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'ke_gga_lsd_eval', & routineP = moduleN//':'//routineN @@ -376,24 +367,24 @@ SUBROUTINE ke_gga_lsd_eval ( functional, rho_set, deriv_set, order, & NULLIFY(norm_drho(ispin)%array, rho(ispin)%array, rho_1_3(ispin)%array) END DO - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa_1_3=rho_1_3(1)%array,& rhob_1_3=rho_1_3(2)%array,rhoa=rho(1)%array,& rhob=rho(2)%array,norm_drhoa=norm_drho(1)%array, & norm_drhob=norm_drho(2)%array,rho_cutoff=rho_cutoff,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) m=ABS(order) CALL ke_gga_init(rho_cutoff) ALLOCATE ( s(npoints), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE ( fs(npoints,m+1), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) fact = flsd b = b_lsd @@ -433,77 +424,77 @@ SUBROUTINE ke_gga_lsd_eval ( functional, rho_set, deriv_set, order, & CASE (ke_t92) CALL efactor_t92 ( s, fs, m ) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) CALL kex_p_0 ( rho(ispin)%array, rho_1_3(ispin)%array, fs, & - e_0=e_0, npoints=npoints, error=error ) + e_0=e_0, npoints=npoints) END IF IF ( order>=1.or.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) CALL kex_p_1 ( rho=rho(ispin)%array, & r13=rho_1_3(ispin)%array, s=s, fs=fs, e_rho=e_rho, & - e_ndrho=e_ndrho, npoints=npoints, error=error ) + e_ndrho=e_ndrho, npoints=npoints) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - rho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + rho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - norm_drho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho,error=error) + norm_drho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin)//& - norm_drho_spin_name(ispin), allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + norm_drho_spin_name(ispin), allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CALL kex_p_2 ( rho(ispin)%array, rho_1_3(ispin)%array,& - s, fs, e_rho_rho,e_rho_ndrho,e_ndrho_ndrho,npoints,error=error ) + s, fs, e_rho_rho,e_rho_ndrho,e_ndrho_ndrho,npoints) END IF IF ( order>=3 .OR. order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& norm_drho_spin_name(ispin)//norm_drho_spin_name(ispin), & - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin)//& norm_drho_spin_name(ispin)//norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) CALL kex_p_3 ( rho(ispin)%array, & rho_1_3(ispin)%array, s, fs, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints, error) + e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO DEALLOCATE ( s, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) DEALLOCATE ( fs, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE ke_gga_lsd_eval @@ -514,9 +505,8 @@ END SUBROUTINE ke_gga_lsd_eval !> \param fs ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kex_p_0 ( rho, r13, fs, e_0, npoints, error ) + SUBROUTINE kex_p_0 ( rho, r13, fs, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13 REAL(KIND=dp), DIMENSION(:, :), & @@ -524,7 +514,6 @@ SUBROUTINE kex_p_0 ( rho, r13, fs, e_0, npoints, error ) REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip @@ -553,9 +542,8 @@ END SUBROUTINE kex_p_0 !> \param e_rho ... !> \param e_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE kex_p_1 ( rho, r13, s, fs, e_rho, e_ndrho, npoints, error ) + SUBROUTINE kex_p_1 ( rho, r13, s, fs, e_rho, e_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13, s REAL(KIND=dp), DIMENSION(:, :), & @@ -563,7 +551,6 @@ SUBROUTINE kex_p_1 ( rho, r13, s, fs, e_rho, e_ndrho, npoints, error ) REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho, e_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: a0, a1, sx, sy @@ -602,10 +589,9 @@ END SUBROUTINE kex_p_1 !> \param e_rho_ndrho ... !> \param e_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE kex_p_2 ( rho, r13, s, fs, e_rho_rho, e_rho_ndrho,e_ndrho_ndrho,& - npoints,error) + npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13, s REAL(KIND=dp), DIMENSION(:, :), & @@ -614,7 +600,6 @@ SUBROUTINE kex_p_2 ( rho, r13, s, fs, e_rho_rho, e_rho_ndrho,e_ndrho_ndrho,& INTENT(INOUT) :: e_rho_rho, e_rho_ndrho, & e_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: a0, a1, a2, sx, sxx, sxy, sy @@ -661,10 +646,9 @@ END SUBROUTINE kex_p_2 !> \param e_rho_ndrho_ndrho ... !> \param e_ndrho_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE kex_p_3 ( rho, r13, s, fs, e_rho_rho_rho,e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints, error ) + e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13, s REAL(KIND=dp), DIMENSION(:, :), & @@ -675,7 +659,6 @@ SUBROUTINE kex_p_3 ( rho, r13, s, fs, e_rho_rho_rho,e_rho_rho_ndrho,& e_rho_ndrho_ndrho, & e_ndrho_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: a0, a1, a2, a3, sx, sxx, & diff --git a/src/xc/xc_libxc.F b/src/xc/xc_libxc.F index 3ca4bac746..beee802271 100644 --- a/src/xc/xc_libxc.F +++ b/src/xc/xc_libxc.F @@ -124,11 +124,9 @@ MODULE xc_libxc !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param ifunc_name the index of the functional as given in the input file -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author F. Tran ! ***************************************************************************** - SUBROUTINE libxc_lda_info(libxc_params,reference,shortform,needs,max_deriv,ifunc_name,error) + SUBROUTINE libxc_lda_info(libxc_params,reference,shortform,needs,max_deriv,ifunc_name) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -136,7 +134,6 @@ SUBROUTINE libxc_lda_info(libxc_params,reference,shortform,needs,max_deriv,ifunc INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv INTEGER, INTENT(in) :: ifunc_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lda_info', & routineP = moduleN//':'//routineN @@ -150,8 +147,8 @@ SUBROUTINE libxc_lda_info(libxc_params,reference,shortform,needs,max_deriv,ifunc REAL(KIND=dp), DIMENSION(:), POINTER :: scale TYPE(xc_f90_pointer_t) :: xc_func, xc_info - CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name,error=error) - CALL section_vals_val_get(libxc_params,"scale",r_vals=scale,error=error) + CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name) + CALL section_vals_val_get(libxc_params,"scale",r_vals=scale) CALL cite_reference(Marques2012) @@ -162,7 +159,7 @@ SUBROUTINE libxc_lda_info(libxc_params,reference,shortform,needs,max_deriv,ifunc ENDIF func_id = xc_libxc_wrap_functional_get_number(func_name(ifunc_name)) - CALL xc_libxc_wrap_functional_buggy(func_id, error=error) + CALL xc_libxc_wrap_functional_buggy(func_id) !$OMP CRITICAL(libxc_init) CALL xc_f90_func_init(xc_func,xc_info,func_id,XC_UNPOLARIZED) !$OMP END CRITICAL(libxc_init) @@ -232,11 +229,9 @@ END SUBROUTINE libxc_lda_info !> true (does not set the unneeded components to false) !> \param max_deriv maximum implemented derivative of the xc functional !> \param ifunc_name the index of the functional as given in the input file -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author F. Tran ! ***************************************************************************** - SUBROUTINE libxc_lsd_info(libxc_params,reference,shortform,needs,max_deriv,ifunc_name,error) + SUBROUTINE libxc_lsd_info(libxc_params,reference,shortform,needs,max_deriv,ifunc_name) TYPE(section_vals_type), POINTER :: libxc_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -244,7 +239,6 @@ SUBROUTINE libxc_lsd_info(libxc_params,reference,shortform,needs,max_deriv,ifunc INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv INTEGER, INTENT(in) :: ifunc_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lsd_info', & routineP = moduleN//':'//routineN @@ -258,8 +252,8 @@ SUBROUTINE libxc_lsd_info(libxc_params,reference,shortform,needs,max_deriv,ifunc REAL(KIND=dp), DIMENSION(:), POINTER :: scale TYPE(xc_f90_pointer_t) :: xc_func, xc_info - CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name,error=error) - CALL section_vals_val_get(libxc_params,"scale",r_vals=scale,error=error) + CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name) + CALL section_vals_val_get(libxc_params,"scale",r_vals=scale) CALL cite_reference(Marques2012) @@ -270,7 +264,7 @@ SUBROUTINE libxc_lsd_info(libxc_params,reference,shortform,needs,max_deriv,ifunc ENDIF func_id = xc_libxc_wrap_functional_get_number(func_name(ifunc_name)) - CALL xc_libxc_wrap_functional_buggy(func_id, error=error) + CALL xc_libxc_wrap_functional_buggy(func_id) !$OMP CRITICAL(libxc_init) CALL xc_f90_func_init(xc_func,xc_info,func_id,XC_POLARIZED) !$OMP END CRITICAL(libxc_init) @@ -363,18 +357,15 @@ END SUBROUTINE libxc_version_info !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) !> \param ifunc_name the index of the functional as given in the input file -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author F. Tran ! ***************************************************************************** - SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,error) + SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params INTEGER, INTENT(in) :: ifunc_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lda_eval', & routineP = moduleN//':'//routineN @@ -402,15 +393,15 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e NULLIFY(bo, dummy) NULLIFY(rho, norm_drho, laplace_rho, tau) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT. failure) THEN - CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name,error=error) - CALL section_vals_val_get(libxc_params,"scale",r_vals=scale,error=error) - CALL section_vals_val_get(libxc_params,"parameters",r_vals=params,error=error) + CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name) + CALL section_vals_val_get(libxc_params,"scale",r_vals=scale) + CALL section_vals_val_get(libxc_params,"parameters",r_vals=params) IF ((SIZE(scale) == 1) .AND. (ABS(SCALE(1)-1.0_dp) < 1.0e-10_dp)) THEN sc = 1.0_dp @@ -419,7 +410,7 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e ENDIF func_id = xc_libxc_wrap_functional_get_number(func_name(ifunc_name)) - CALL xc_libxc_wrap_functional_buggy(func_id, grad_deriv=grad_deriv, error=error) + CALL xc_libxc_wrap_functional_buggy(func_id, grad_deriv=grad_deriv) !$OMP CRITICAL(libxc_init) CALL xc_f90_func_init(xc_func,xc_info,func_id,XC_UNPOLARIZED) !$OMP END CRITICAL(libxc_init) @@ -428,13 +419,13 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e CALL xc_rho_set_get(rho_set, can_return_null=.TRUE.,& rho=rho,norm_drho=norm_drho, laplace_rho=laplace_rho,& rho_cutoff=epsilon_rho, tau_cutoff=epsilon_tau,& - tau=tau, local_bounds=bo, error=error) + tau=tau, local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy => rho END IF @@ -467,36 +458,36 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN SELECT CASE (xc_f90_info_family(xc_info)) CASE(XC_FAMILY_LDA) deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) CASE(XC_FAMILY_GGA, XC_FAMILY_HYB_GGA) deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) CASE(XC_FAMILY_MGGA) deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(tau)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau) IF (has_laplace) THEN deriv => xc_dset_get_derivative(deriv_set,"(laplace_rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho) END IF CASE default CALL stop_program(routineN,moduleN,__LINE__,& @@ -507,55 +498,55 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e SELECT CASE (xc_f90_info_family(xc_info)) CASE(XC_FAMILY_LDA) deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) CASE(XC_FAMILY_GGA, XC_FAMILY_HYB_GGA) deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CASE(XC_FAMILY_MGGA) ! not implemented ... CALL cp_unimplemented_error(fromWhere=routineP,& message="derivatives larger than 1 not implemented or checked",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ! deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drho)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) ! deriv => xc_dset_get_derivative(deriv_set,"(rho)(tau)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rho_tau,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rho_tau) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(tau)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_tau,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_tau) ! deriv => xc_dset_get_derivative(deriv_set,"(tau)(tau)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_tau_tau,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_tau_tau) ! IF (has_laplace) THEN ! deriv => xc_dset_get_derivative(deriv_set,"(rho)(laplace_rho)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rho_laplace_rho,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rho_laplace_rho) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_rho)(laplace_rho)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_laplace_rho,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_laplace_rho) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rho)(laplace_rho)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho_laplace_rho,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho_laplace_rho) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rho)(tau)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho_tau,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho_tau) ! END IF CASE default CALL stop_program(routineN,moduleN,__LINE__,& @@ -566,12 +557,12 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e SELECT CASE (xc_f90_info_family(xc_info)) CASE(XC_FAMILY_LDA) deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) CASE(XC_FAMILY_GGA, XC_FAMILY_HYB_GGA, XC_FAMILY_MGGA) CALL cp_unimplemented_error(fromWhere=routineP,& message="derivatives larger than 2 not implemented",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE default CALL stop_program(routineN,moduleN,__LINE__,& TRIM(func_name(ifunc_name))//": this XC_FAMILY is currently not supported.") @@ -580,7 +571,7 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e IF (grad_deriv>=4.OR.grad_deriv<=-4) THEN CALL cp_unimplemented_error(fromWhere=routineP,& message="derivatives larger than 3 not implemented",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none), & @@ -590,7 +581,7 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e !$omp shared(e_laplace_rho_tau,e_tau_tau,e_rho_rho_rho),& !$omp shared(grad_deriv,npoints),& !$omp shared(epsilon_rho,epsilon_tau),& - !$omp shared(func_name,ifunc_name,sc,params,error) + !$omp shared(func_name,ifunc_name,sc,params) CALL libxc_lda_calc(rho=rho,norm_drho=norm_drho,& laplace_rho=laplace_rho,tau=tau,& @@ -604,13 +595,13 @@ SUBROUTINE libxc_lda_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e grad_deriv=grad_deriv,npoints=npoints,& epsilon_rho=epsilon_rho,& epsilon_tau=epsilon_tau,func_name=func_name(ifunc_name),& - sc=sc,params=params,error=error) + sc=sc,params=params) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -636,18 +627,15 @@ END SUBROUTINE libxc_lda_eval !> if negative only the given degree is calculated !> \param libxc_params input parameter (functional name, scaling and parameters) !> \param ifunc_name the index of the functional as given in the input file -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author F. Tran ! ***************************************************************************** - SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,error) + SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: libxc_params INTEGER, INTENT(in) :: ifunc_name - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lsd_eval', & routineP = moduleN//':'//routineN @@ -690,15 +678,15 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e NULLIFY(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob, laplace_rhoa, & laplace_rhob, tau_a, tau_b) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) IF (.NOT. failure) THEN - CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name,error=error) - CALL section_vals_val_get(libxc_params,"scale",r_vals=scale,error=error) - CALL section_vals_val_get(libxc_params,"parameters",r_vals=params,error=error) + CALL section_vals_val_get(libxc_params,"functional",c_vals=func_name) + CALL section_vals_val_get(libxc_params,"scale",r_vals=scale) + CALL section_vals_val_get(libxc_params,"parameters",r_vals=params) IF ((SIZE(scale) == 1) .AND. (ABS(SCALE(1)-1.0_dp) < 1.0e-10_dp)) THEN sc = 1.0_dp @@ -707,7 +695,7 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e ENDIF func_id = xc_libxc_wrap_functional_get_number(func_name(ifunc_name)) - CALL xc_libxc_wrap_functional_buggy(func_id, grad_deriv=grad_deriv, error=error) + CALL xc_libxc_wrap_functional_buggy(func_id, grad_deriv=grad_deriv) !$OMP CRITICAL(libxc_init) CALL xc_f90_func_init(xc_func,xc_info,func_id,XC_POLARIZED) !$OMP END CRITICAL(libxc_init) @@ -718,14 +706,13 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e norm_drhoa=norm_drhoa, norm_drhob=norm_drhob,& laplace_rhoa=laplace_rhoa, laplace_rhob=laplace_rhob,& rho_cutoff=epsilon_rho, tau_cutoff=epsilon_tau,& - tau_a=tau_a, tau_b=tau_b, local_bounds=bo,& - error=error) + tau_a=tau_a, tau_b=tau_b, local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -805,63 +792,63 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN SELECT CASE (xc_f90_info_family(xc_info)) CASE(XC_FAMILY_LDA) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) CASE(XC_FAMILY_GGA, XC_FAMILY_HYB_GGA) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) CASE(XC_FAMILY_MGGA) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) deriv => xc_dset_get_derivative(deriv_set,"(tau_a)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_a,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_a) deriv => xc_dset_get_derivative(deriv_set,"(tau_b)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_b,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_b) IF (has_laplace) THEN deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob) END IF CASE default CALL stop_program(routineN,moduleN,__LINE__,& @@ -872,202 +859,202 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e SELECT CASE (xc_f90_info_family(xc_info)) CASE(XC_FAMILY_LDA) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob) CASE(XC_FAMILY_GGA, XC_FAMILY_HYB_GGA) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_ndrhob) CASE(XC_FAMILY_MGGA) ! not implemented ... CALL cp_unimplemented_error(fromWhere=routineP,& message="derivatives larger than 1 not implemented or checked",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) ! deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drho)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(norm_drhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(norm_drhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(norm_drhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(norm_drhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_ndrhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_ndrhob) ! deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_tau_b) ! deriv => xc_dset_get_derivative(deriv_set,"(rhob)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhob_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhob_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(rhob)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhob_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhob_tau_b) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_tau_b) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_tau_b) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_tau_b) ! deriv => xc_dset_get_derivative(deriv_set,"(tau_a)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_tau_a_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_tau_a_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(tau_a)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_tau_a_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_tau_a_tau_b) ! deriv => xc_dset_get_derivative(deriv_set,"(tau_b)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_tau_b_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_tau_b_tau_b) ! IF (has_laplace) THEN ! deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(laplace_rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_laplace_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_laplace_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(laplace_rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_laplace_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhoa_laplace_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(rhob)(laplace_rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhob_laplace_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhob_laplace_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(rhob)(laplace_rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_rhob_laplace_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_rhob_laplace_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(laplace_rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_laplace_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_laplace_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(laplace_rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_laplace_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrho_laplace_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(laplace_rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_laplace_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_laplace_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(laplace_rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_laplace_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_laplace_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(laplace_rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_laplace_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_laplace_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(laplace_rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_laplace_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_laplace_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhoa)(laplace_rhoa)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_laplace_rhoa,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_laplace_rhoa) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhoa)(laplace_rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_laplace_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_laplace_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhob)(laplace_rhob)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob_laplace_rhob,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob_laplace_rhob) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhoa)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhoa)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa_tau_b) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhob)(tau_a)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob_tau_a,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob_tau_a) ! deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhob)(tau_b)",& -! allocate_deriv=.TRUE.,error=error) -! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob_tau_b,error=error) +! allocate_deriv=.TRUE.) +! CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob_tau_b) ! END IF CASE default CALL stop_program(routineN,moduleN,__LINE__,& @@ -1078,21 +1065,21 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e SELECT CASE (xc_f90_info_family(xc_info)) CASE(XC_FAMILY_LDA) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa_rhob) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhob_rhob) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob_rhob) CASE(XC_FAMILY_GGA, XC_FAMILY_HYB_GGA, XC_FAMILY_MGGA) CALL cp_unimplemented_error(fromWhere=routineP,& message="derivatives larger than 2 not implemented",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE default CALL stop_program(routineN,moduleN,__LINE__,& TRIM(func_name(ifunc_name))//": this XC_FAMILY is currently not supported.") @@ -1101,7 +1088,7 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e IF (grad_deriv>=4.OR.grad_deriv<=-4) THEN CALL cp_unimplemented_error(fromWhere=routineP,& message="derivatives larger than 3 not implemented",& - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none), & @@ -1126,7 +1113,7 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e !$omp shared(e_rhoa_rhoa_rhoa,e_rhoa_rhoa_rhob,e_rhoa_rhob_rhob,e_rhob_rhob_rhob),& !$omp shared(grad_deriv,npoints),& !$omp shared(epsilon_rho,epsilon_tau),& - !$omp shared(func_name,ifunc_name,sc,params,error) + !$omp shared(func_name,ifunc_name,sc,params) CALL libxc_lsd_calc(rhoa=rhoa,rhob=rhob,norm_drho=norm_drho,& norm_drhoa=norm_drhoa,norm_drhob=norm_drhob,laplace_rhoa=laplace_rhoa,& @@ -1173,13 +1160,13 @@ SUBROUTINE libxc_lsd_eval(rho_set,deriv_set,grad_deriv,libxc_params,ifunc_name,e grad_deriv=grad_deriv,npoints=npoints,& epsilon_rho=epsilon_rho,& epsilon_tau=epsilon_tau,func_name=func_name(ifunc_name),& - sc=sc,params=params,error=error) + sc=sc,params=params) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -1226,8 +1213,6 @@ END SUBROUTINE libxc_lsd_eval !> \param func_name name of the functional !> \param sc scaling factor !> \param params parameters of the functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author F. Tran ! ***************************************************************************** SUBROUTINE libxc_lda_calc(rho,norm_drho,laplace_rho,tau,& @@ -1236,7 +1221,7 @@ SUBROUTINE libxc_lda_calc(rho,norm_drho,laplace_rho,tau,& e_ndrho_tau,e_laplace_rho_laplace_rho,e_laplace_rho_tau,& e_tau_tau,e_rho_rho_rho,& grad_deriv,npoints,epsilon_rho,& - epsilon_tau,func_name,sc,params,error) + epsilon_tau,func_name,sc,params) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, norm_drho, laplace_rho, & tau @@ -1249,7 +1234,6 @@ SUBROUTINE libxc_lda_calc(rho,norm_drho,laplace_rho,tau,& CHARACTER(LEN=80), INTENT(IN) :: func_name REAL(KIND=dp), INTENT(in) :: sc REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lda_calc', & routineP = moduleN//':'//routineN @@ -1637,8 +1621,6 @@ END SUBROUTINE libxc_lda_calc !> \param func_name name of the functional !> \param sc scaling factor !> \param params parameters of the functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author F. Tran ! ***************************************************************************** SUBROUTINE libxc_lsd_calc(rhoa,rhob,norm_drho,norm_drhoa,& @@ -1668,7 +1650,7 @@ SUBROUTINE libxc_lsd_calc(rhoa,rhob,norm_drho,norm_drhoa,& e_rhoa_rhoa_rhoa,e_rhoa_rhoa_rhob,& e_rhoa_rhob_rhob,e_rhob_rhob_rhob,& grad_deriv,npoints,epsilon_rho,& - epsilon_tau,func_name,sc,params,error) + epsilon_tau,func_name,sc,params) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, rhob, norm_drho, & norm_drhoa, norm_drhob, & @@ -1696,7 +1678,6 @@ SUBROUTINE libxc_lsd_calc(rhoa,rhob,norm_drho,norm_drhoa,& CHARACTER(LEN=80), INTENT(IN) :: func_name REAL(KIND=dp), INTENT(in) :: sc REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'libxc_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_libxc_wrap.F b/src/xc/xc_libxc_wrap.F index 552266541e..62224fcae1 100644 --- a/src/xc/xc_libxc_wrap.F +++ b/src/xc/xc_libxc_wrap.F @@ -519,11 +519,9 @@ END SUBROUTINE xc_libxc_wrap_functional_set_params !> \brief Wrapper for known buggy functionals. !> \param func_id ... !> \param grad_deriv ... -!> \param error ... -!> !> \author A. Gloessa (agloess) ! ***************************************************************************** - SUBROUTINE xc_libxc_wrap_functional_buggy(func_id, grad_deriv, error) + SUBROUTINE xc_libxc_wrap_functional_buggy(func_id, grad_deriv) ! ! BugFix information was taken from: ! @@ -560,7 +558,6 @@ SUBROUTINE xc_libxc_wrap_functional_buggy(func_id, grad_deriv, error) ! INTEGER, INTENT(IN) :: func_id INTEGER, INTENT(IN), OPTIONAL :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: & routineN = 'xc_libxc_wrap_functional_buggy', & diff --git a/src/xc/xc_lyp.F b/src/xc/xc_lyp.F index 566d1a187a..82d989d297 100644 --- a/src/xc/xc_lyp.F +++ b/src/xc/xc_lyp.F @@ -45,18 +45,15 @@ MODULE xc_lyp !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE lyp_lda_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE lyp_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_lda_info', & routineP = moduleN//':'//routineN @@ -83,18 +80,15 @@ END SUBROUTINE lyp_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** -SUBROUTINE lyp_lsd_info(reference,shortform, needs, max_deriv, error) +SUBROUTINE lyp_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_lsd_info', & routineP = moduleN//':'//routineN @@ -123,19 +117,16 @@ END SUBROUTINE lyp_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param lyp_params input parameters (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> 01.2007 added scaling [Manuel Guidon] !> \author fawzi ! ***************************************************************************** -SUBROUTINE lyp_lda_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) +SUBROUTINE lyp_lda_eval(rho_set,deriv_set,grad_deriv,lyp_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: lyp_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_lda_eval', & routineP = moduleN//':'//routineN @@ -155,23 +146,23 @@ SUBROUTINE lyp_lda_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(lyp_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(lyp_params,"scale_c",r_val=sc) CALL cite_reference(Lee1988) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=rho_1_3,rho=rho,& norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_norm_drho,error=error) + drho_cutoff=epsilon_norm_drho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -188,47 +179,47 @@ SUBROUTINE lyp_lda_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho,error=error) + "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho,error=error) + "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho) !FM deriv => xc_dset_get_derivative(deriv_set,& !FM "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& -!FM error=error) -!FM call xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) +!FM +!FM call xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & @@ -236,7 +227,7 @@ SUBROUTINE lyp_lda_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) !$omp shared(e_rho_rho, e_ndrho_rho, e_ndrho_ndrho) & !$omp shared(e_rho_rho_rho, e_ndrho_rho_rho) & !$omp shared(e_ndrho_ndrho_rho, grad_deriv, npoints) & - !$omp shared(epsilon_rho, sc, error) + !$omp shared(epsilon_rho, sc) CALL lyp_lda_calc(rho=rho, rho_1_3=rho_1_3, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,e_rho_rho=e_rho_rho,& @@ -244,14 +235,13 @@ SUBROUTINE lyp_lda_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) e_rho_rho_rho=e_rho_rho_rho, e_ndrho_rho_rho=e_ndrho_rho_rho,& e_ndrho_ndrho_rho=e_ndrho_ndrho_rho,& grad_deriv=grad_deriv,& - npoints=npoints,epsilon_rho=epsilon_rho,sc=sc,& - error=error) + npoints=npoints,epsilon_rho=epsilon_rho,sc=sc) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -278,8 +268,6 @@ END SUBROUTINE lyp_lda_eval !> \param npoints ... !> \param epsilon_rho ... !> \param sc scaling-parameter for correlation -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> 01.2007 added scaling [Manuel Guidon] @@ -288,7 +276,7 @@ END SUBROUTINE lyp_lda_eval SUBROUTINE lyp_lda_calc(rho, rho_1_3, norm_drho,& e_0,e_rho,e_ndrho,e_rho_rho,e_ndrho_rho,& e_ndrho_ndrho, e_rho_rho_rho, e_ndrho_rho_rho, e_ndrho_ndrho_rho,& - grad_deriv,npoints,epsilon_rho,sc,error) + grad_deriv,npoints,epsilon_rho,sc) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), INTENT(inout) :: e_ndrho_ndrho_rho, & e_ndrho_rho_rho, e_rho_rho_rho, e_ndrho_ndrho, e_ndrho_rho, e_rho_rho, & @@ -296,7 +284,6 @@ SUBROUTINE lyp_lda_calc(rho, rho_1_3, norm_drho,& REAL(kind=dp), DIMENSION(1:npoints), & INTENT(in) :: norm_drho, rho_1_3, rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_lda_calc', & routineP = moduleN//':'//routineN @@ -762,19 +749,16 @@ END SUBROUTINE lyp_lda_calc !> \param deriv_set ... !> \param grad_deriv ... !> \param lyp_params input parameter (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> 01.2007 added scaling [Manuel Guidon] !> \author fawzi ! ***************************************************************************** -SUBROUTINE lyp_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) +SUBROUTINE lyp_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: lyp_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_lsd_eval', & routineP = moduleN//':'//routineN @@ -793,25 +777,25 @@ SUBROUTINE lyp_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) failure=.FALSE. NULLIFY(deriv, bo) - CALL section_vals_val_get(lyp_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(lyp_params,"scale_c",r_val=sc) CALL cite_reference(Lee1988) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,& rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa, & norm_drhob=norm_drhob, norm_drho=norm_drho, & rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_drho, local_bounds=bo, error=error) + drho_cutoff=epsilon_drho, local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -836,60 +820,60 @@ SUBROUTINE lyp_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra_ra) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra_rb) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr_ra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_ra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb_rb) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr_ndr,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr_ndr) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndra,error=error) + "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndra) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ndrb,error=error) + "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ndrb) END IF !$omp parallel default(none) & @@ -898,7 +882,7 @@ SUBROUTINE lyp_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) !$omp shared(e_ndrb_rb, e_ndr_ndr, e_ndra_ndra, e_ndrb_ndrb) & !$omp shared(e_ndr, e_ndra, e_ndrb, e_ra_ra, e_ra_rb, e_rb_rb) & !$omp shared(e_ndr_ra, e_ndr_rb, grad_deriv) & - !$omp shared(npoints, epsilon_rho, sc, error) + !$omp shared(npoints, epsilon_rho, sc) CALL lyp_lsd_calc(& rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, norm_drhoa=norm_drhoa,& @@ -910,13 +894,13 @@ SUBROUTINE lyp_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_params,error) e_ra_rb=e_ra_rb, e_rb_rb=e_rb_rb, e_ndr_ra=e_ndr_ra,& e_ndr_rb=e_ndr_rb,& grad_deriv=grad_deriv, npoints=npoints, & - epsilon_rho=epsilon_rho,sc=sc,error=error) + epsilon_rho=epsilon_rho,sc=sc) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -953,8 +937,6 @@ END SUBROUTINE lyp_lsd_eval !> \param npoints ... !> \param epsilon_rho ... !> \param sc scaling parameter for correlation -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2004 created [fawzi] !> \author fawzi @@ -963,7 +945,7 @@ SUBROUTINE lyp_lsd_calc(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob,& e_0, e_ra, e_rb, e_ndra_ra, e_ndra_rb, e_ndrb_ra, e_ndrb_rb, e_ndr_ndr,& e_ndra_ndra, e_ndrb_ndrb, e_ndr,& e_ndra, e_ndrb, e_ra_ra, e_ra_rb, e_rb_rb, e_ndr_ra, e_ndr_rb,& - grad_deriv,npoints,epsilon_rho,sc,error) + grad_deriv,npoints,epsilon_rho,sc) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rhoa, rhob, norm_drho, & norm_drhoa, norm_drhob REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_ra, e_rb, e_ndra_ra, & @@ -971,7 +953,6 @@ SUBROUTINE lyp_lsd_calc(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob,& e_ndr, e_ndra, e_ndrb, e_ra_ra, e_ra_rb, e_rb_rb, e_ndr_ra, e_ndr_rb INTEGER, INTENT(in) :: grad_deriv, npoints REAL(kind=dp), INTENT(in) :: epsilon_rho, sc - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_lyp_adiabatic.F b/src/xc/xc_lyp_adiabatic.F index 91d81ebee7..de3656cacc 100644 --- a/src/xc/xc_lyp_adiabatic.F +++ b/src/xc/xc_lyp_adiabatic.F @@ -51,18 +51,15 @@ MODULE xc_lyp_adiabatic !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE lyp_adiabatic_lda_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE lyp_adiabatic_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_adiabatic_lda_info', & routineP = moduleN//':'//routineN @@ -89,18 +86,15 @@ END SUBROUTINE lyp_adiabatic_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE lyp_adiabatic_lsd_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE lyp_adiabatic_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_adiabatic_lsd_info', & routineP = moduleN//':'//routineN @@ -125,17 +119,15 @@ END SUBROUTINE lyp_adiabatic_lsd_info !> \param deriv_set ... !> \param grad_deriv ... !> \param lyp_adiabatic_params ... -!> \param error ... !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE lyp_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_params,error) + SUBROUTINE lyp_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: lyp_adiabatic_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_adiabatic_lda_eval', & routineP = moduleN//':'//routineN @@ -155,23 +147,23 @@ SUBROUTINE lyp_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_par failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(lyp_adiabatic_params,"LAMBDA",r_val=lambda,error=error) + CALL section_vals_val_get(lyp_adiabatic_params,"LAMBDA",r_val=lambda) CALL cite_reference(Lee1988) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=rho_1_3,rho=rho,& norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_norm_drho,error=error) + drho_cutoff=epsilon_norm_drho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -182,39 +174,38 @@ SUBROUTINE lyp_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_par IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(rho, norm_drho, e_0, e_rho, e_ndrho) & !$omp shared(grad_deriv, npoints) & - !$omp shared(epsilon_rho, lambda, error) + !$omp shared(epsilon_rho, lambda) CALL lyp_adiabatic_lda_calc(rho=rho, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,& grad_deriv=grad_deriv,& - npoints=npoints,epsilon_rho=epsilon_rho,lambda=lambda,& - error=error) + npoints=npoints,epsilon_rho=epsilon_rho,lambda=lambda) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -232,21 +223,19 @@ END SUBROUTINE lyp_adiabatic_lda_eval !> \param npoints ... !> \param epsilon_rho ... !> \param lambda ... -!> \param error ... !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE lyp_adiabatic_lda_calc(rho, norm_drho,& e_0,e_rho,e_ndrho, & - grad_deriv,npoints,epsilon_rho, lambda,error) + grad_deriv,npoints,epsilon_rho, lambda) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), & INTENT(inout) :: e_ndrho, e_rho, e_0 REAL(kind=dp), DIMENSION(1:npoints), & INTENT(in) :: norm_drho, rho REAL(kind=dp), INTENT(in) :: epsilon_rho, lambda - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_adiabatic_lda_calc', & routineP = moduleN//':'//routineN @@ -361,17 +350,15 @@ END SUBROUTINE lyp_adiabatic_lda_calc !> \param deriv_set ... !> \param grad_deriv ... !> \param lyp_adiabatic_params ... -!> \param error ... !> \par History !> 01.2008 created [fawzi] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE lyp_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_params,error) + SUBROUTINE lyp_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: lyp_adiabatic_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_adiabatic_lsd_eval', & routineP = moduleN//':'//routineN @@ -390,25 +377,25 @@ SUBROUTINE lyp_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_par failure=.FALSE. NULLIFY(deriv, bo) - CALL section_vals_val_get(lyp_adiabatic_params,"LAMBDA",r_val=lambda,error=error) + CALL section_vals_val_get(lyp_adiabatic_params,"LAMBDA",r_val=lambda) CALL cite_reference(Lee1988) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,& rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa, & norm_drhob=norm_drhob, norm_drho=norm_drho, & rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -433,37 +420,37 @@ SUBROUTINE lyp_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_par IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv==1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob) & !$omp shared(e_0, e_ra, e_rb, e_ndr, e_ndra, e_ndrb) & !$omp shared(grad_deriv, npoints) & - !$omp shared(epsilon_rho, lambda, error) + !$omp shared(epsilon_rho, lambda) CALL lyp_adiabatic_lsd_calc(& rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, norm_drhoa=norm_drhoa,& @@ -471,13 +458,13 @@ SUBROUTINE lyp_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,lyp_adiabatic_par e_ndr=e_ndr,& e_ndra=e_ndra, e_ndrb=e_ndrb,& grad_deriv=grad_deriv, npoints=npoints, & - epsilon_rho=epsilon_rho,lambda=lambda,error=error) + epsilon_rho=epsilon_rho,lambda=lambda) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -501,7 +488,6 @@ END SUBROUTINE lyp_adiabatic_lsd_eval !> \param npoints ... !> \param epsilon_rho ... !> \param lambda ... -!> \param error ... !> \par History !> 08.2008 created [mguidon] !> \author Manuel Guidon @@ -510,7 +496,7 @@ SUBROUTINE lyp_adiabatic_lsd_calc(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob, e_0, e_ra, e_rb,& e_ndr,& e_ndra, e_ndrb, & - grad_deriv,npoints,epsilon_rho,lambda,error) + grad_deriv,npoints,epsilon_rho,lambda) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rhoa, rhob, norm_drho, & norm_drhoa, norm_drhob REAL(kind=dp), DIMENSION(*), & @@ -518,7 +504,6 @@ SUBROUTINE lyp_adiabatic_lsd_calc(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob, e_ndra, e_ndrb INTEGER, INTENT(in) :: grad_deriv, npoints REAL(kind=dp), INTENT(in) :: epsilon_rho, lambda - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'lyp_adiabatic_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_optx.F b/src/xc/xc_optx.F index bdb26845e5..f5181a3d3c 100644 --- a/src/xc/xc_optx.F +++ b/src/xc/xc_optx.F @@ -38,16 +38,13 @@ MODULE xc_optx !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv implemented derivative of the xc functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost ! ***************************************************************************** - SUBROUTINE optx_lda_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE optx_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'optx_lda_info', & routineP = moduleN//':'//routineN @@ -72,16 +69,13 @@ END SUBROUTINE optx_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv implemented derivative of the xc functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Joost ! ***************************************************************************** - SUBROUTINE optx_lsd_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE optx_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'optx_lsd_info', & routineP = moduleN//':'//routineN @@ -108,18 +102,15 @@ END SUBROUTINE optx_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param optx_params input parameter (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2007 added scaling [Manuel Guidon] !> \author Joost ! ***************************************************************************** - SUBROUTINE optx_lda_eval(rho_set,deriv_set,grad_deriv,optx_params,error) + SUBROUTINE optx_lda_eval(rho_set,deriv_set,grad_deriv,optx_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: optx_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'optx_lda_eval', & routineP = moduleN//':'//routineN @@ -136,36 +127,36 @@ SUBROUTINE optx_lda_eval(rho_set,deriv_set,grad_deriv,optx_params,error) failure=.FALSE. NULLIFY(bo,e_0, e_ndrho, e_rho, norm_drho, rho) - CALL section_vals_val_get(optx_params,"scale_x",r_val=sx,error=error) + CALL section_vals_val_get(optx_params,"scale_x",r_val=sx) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_drho,error=error) + drho_cutoff=epsilon_drho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL optx_lda_calc(rho=rho, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,& npoints=npoints,epsilon_rho=epsilon_rho,& - epsilon_drho=epsilon_drho,sx=sx,error=error) + epsilon_drho=epsilon_drho,sx=sx) END SUBROUTINE optx_lda_eval ! ***************************************************************************** @@ -177,18 +168,15 @@ END SUBROUTINE optx_lda_eval !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param optx_params input parameter (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2007 added scaling [Manuel Guidon] !> \author Joost ! ***************************************************************************** - SUBROUTINE optx_lsd_eval(rho_set,deriv_set,grad_deriv,optx_params,error) + SUBROUTINE optx_lsd_eval(rho_set,deriv_set,grad_deriv,optx_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: optx_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'optx_lsd_eval', & routineP = moduleN//':'//routineN @@ -211,45 +199,45 @@ SUBROUTINE optx_lsd_eval(rho_set,deriv_set,grad_deriv,optx_params,error) NULLIFY(ndrho(ispin)%array) ENDDO - CALL section_vals_val_get(optx_params,"scale_x",r_val=sx,error=error) + CALL section_vals_val_get(optx_params,"scale_x",r_val=sx) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=rho(1)%array,rhob=rho(2)%array,& norm_drhoa=ndrho(1)%array, & norm_drhob=ndrho(2)%array,rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_drho, local_bounds=bo, error=error) + drho_cutoff=epsilon_drho, local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array) IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DO ispin=1,2 CALL optx_lsd_calc(rho=rho(ispin)%array, norm_drho=ndrho(ispin)%array,& e_0=e_0,e_rho=e_rho(ispin)%array,e_ndrho=e_ndrho(ispin)%array,& npoints=npoints,epsilon_rho=epsilon_rho,& - epsilon_drho=epsilon_drho,sx=sx,error=error) + epsilon_drho=epsilon_drho,sx=sx) ENDDO END SUBROUTINE optx_lsd_eval @@ -264,21 +252,18 @@ END SUBROUTINE optx_lsd_eval !> \param epsilon_drho ... !> \param npoints ... !> \param sx scaling-parameter for exchange -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2007 added scaling [Manuel Guidon] !> \author Joost VandeVondele ! ***************************************************************************** SUBROUTINE optx_lda_calc(rho,norm_drho,e_0,e_rho,e_ndrho,& - epsilon_rho,epsilon_drho,npoints,sx,error) + epsilon_rho,epsilon_drho,npoints,sx) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, norm_drho REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0, e_rho, e_ndrho REAL(kind=dp), INTENT(in) :: epsilon_rho, epsilon_drho INTEGER, INTENT(in) :: npoints REAL(kind=dp), INTENT(in) :: sx - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), PARAMETER :: a1cx = 0.9784571170284421_dp, & a2 = 1.43169_dp, gam = 0.006_dp, o43 = 4.0_dp/3.0_dp @@ -327,21 +312,18 @@ END SUBROUTINE optx_lda_calc !> \param epsilon_drho ... !> \param npoints ... !> \param sx scaling parameter for exchange -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2007 added scaling [Manuel Guidon] !> \author Joost VandeVondele ! ***************************************************************************** SUBROUTINE optx_lsd_calc(rho,norm_drho,e_0,e_rho,e_ndrho,& - epsilon_rho,epsilon_drho,npoints,sx,error) + epsilon_rho,epsilon_drho,npoints,sx) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, norm_drho REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0, e_rho, e_ndrho REAL(kind=dp), INTENT(in) :: epsilon_rho, epsilon_drho INTEGER, INTENT(in) :: npoints REAL(kind=dp), INTENT(in) :: sx - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp), PARAMETER :: a1cx = 0.9784571170284421_dp, & a2 = 1.43169_dp, gam = 0.006_dp, o43 = 4.0_dp/3.0_dp diff --git a/src/xc/xc_pade.F b/src/xc/xc_pade.F index 5b36453627..7037fd3e5f 100644 --- a/src/xc/xc_pade.F +++ b/src/xc/xc_pade.F @@ -101,16 +101,14 @@ END SUBROUTINE pade_init !> \param lsd ... !> \param needs ... !> \param max_deriv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pade_info ( reference, shortform, lsd, needs, max_deriv, error ) + SUBROUTINE pade_info ( reference, shortform, lsd, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform LOGICAL, INTENT(IN), OPTIONAL :: lsd TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pade_info', & routineP = moduleN//':'//routineN @@ -143,16 +141,14 @@ END SUBROUTINE pade_info !> \param rho ... !> \param pot ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pade_lda(derivative_set, rho, pot, order, error) + SUBROUTINE pade_lda(derivative_set, rho, pot, order) TYPE(xc_derivative_set_type), POINTER :: derivative_set REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: rho REAL(KIND=dp), DIMENSION(:, :), & INTENT(INOUT) :: pot INTEGER, INTENT(IN), OPTIONAL :: order - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pade_lda', & routineP = moduleN//':'//routineN @@ -172,7 +168,7 @@ SUBROUTINE pade_lda(derivative_set, rho, pot, order, error) n = SIZE ( rho ) ALLOCATE ( rs(n), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL calc_rs ( rho, rs ) IF ( calc(0) .AND. calc(1) ) THEN @@ -195,7 +191,7 @@ SUBROUTINE pade_lda(derivative_set, rho, pot, order, error) END IF DEALLOCATE ( rs, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE pade_lda @@ -204,14 +200,12 @@ END SUBROUTINE pade_lda !> \param deriv_set ... !> \param rho_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pade_lda_pw_eval(deriv_set, rho_set, order, error) + SUBROUTINE pade_lda_pw_eval(deriv_set, rho_set, order) TYPE(xc_derivative_set_type), POINTER :: deriv_set TYPE(xc_rho_set_type), POINTER :: rho_set INTEGER, INTENT(IN), OPTIONAL :: order - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'pade_lda_pw_eval', & routineP = moduleN//':'//routineN @@ -230,43 +224,43 @@ SUBROUTINE pade_lda_pw_eval(deriv_set, rho_set, order, error) n = PRODUCT(rho_set%local_bounds(2,:)-rho_set%local_bounds(1,:)+(/1,1,1/)) ALLOCATE ( rs(n), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL calc_rs_pw ( rho_set%rho, rs, n ) IF ( calc(0) .AND. calc(1) ) THEN deriv => xc_dset_get_derivative(deriv_set, "", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) deriv => xc_dset_get_derivative(deriv_set, "(rho)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_r,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_r) CALL pade_lda_01(n, rho_set%rho, rs, e_0, e_r) ELSE IF ( calc(0) ) THEN deriv => xc_dset_get_derivative(deriv_set, "", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) CALL pade_lda_0(n, rho_set%rho, rs, e_0) ELSE IF ( calc(1) ) THEN deriv => xc_dset_get_derivative(deriv_set, "(rho)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_r,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_r) CALL pade_lda_1(n, rho_set%rho, rs, e_r) END IF IF ( calc(2) ) THEN deriv => xc_dset_get_derivative(deriv_set, "(rho)(rho)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rr,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rr) CALL pade_lda_2(n, rho_set%rho, rs, e_rr) END IF IF ( calc(3) ) THEN deriv => xc_dset_get_derivative(deriv_set, "(rho)(rho)(rho)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rrr,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rrr) CALL pade_lda_3(n, rho_set%rho, rs, e_rrr) END IF DEALLOCATE ( rs, STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) END SUBROUTINE pade_lda_pw_eval @@ -349,14 +343,12 @@ END SUBROUTINE pade_lsd !> \param deriv_set ... !> \param rho_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE pade_lsd_pw_eval ( deriv_set, rho_set, order, error ) + SUBROUTINE pade_lsd_pw_eval ( deriv_set, rho_set, order) TYPE(xc_derivative_set_type), POINTER :: deriv_set TYPE(xc_rho_set_type), POINTER :: rho_set INTEGER, INTENT(IN), OPTIONAL :: order - TYPE(cp_error_type), INTENT(INOUT) :: error INTEGER :: i, j, k LOGICAL :: calc(0:4) @@ -374,41 +366,41 @@ SUBROUTINE pade_lsd_pw_eval ( deriv_set, rho_set, order, error ) IF (calc(0)) THEN deriv => xc_dset_get_derivative(deriv_set, "", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (calc(1)) THEN deriv => xc_dset_get_derivative(deriv_set, "(rhoa)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra) deriv => xc_dset_get_derivative(deriv_set, "(rhob)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb) END IF IF (calc(2)) THEN deriv => xc_dset_get_derivative(deriv_set, "(rhoa)(rhoa)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rara,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rara) deriv => xc_dset_get_derivative(deriv_set, "(rhoa)(rhob)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rarb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rarb) deriv => xc_dset_get_derivative(deriv_set, "(rhob)(rhob)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rbrb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rbrb) END IF IF (calc(3)) THEN deriv => xc_dset_get_derivative(deriv_set, "(rhoa)(rhoa)(rhoa)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rarara,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rarara) deriv => xc_dset_get_derivative(deriv_set, "(rhoa)(rhoa)(rhob)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rararb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rararb) deriv => xc_dset_get_derivative(deriv_set, "(rhoa)(rhob)(rhob)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rarbrb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rarbrb) deriv => xc_dset_get_derivative(deriv_set, "(rhob)(rhob)(rhob)", & - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rbrbrb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rbrbrb) END IF !$omp parallel do private(i,j,k,fx,rhoa,rhob,rs) default(none)& diff --git a/src/xc/xc_pbe.F b/src/xc/xc_pbe.F index ccea76e62e..dc4e5f9d44 100644 --- a/src/xc/xc_pbe.F +++ b/src/xc/xc_pbe.F @@ -58,18 +58,14 @@ MODULE xc_pbe !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE pbe_lda_info(pbe_params,reference,shortform, needs, max_deriv,& - error) + SUBROUTINE pbe_lda_info(pbe_params,reference,shortform, needs, max_deriv) TYPE(section_vals_type), POINTER :: pbe_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pbe_lda_info', & routineP = moduleN//':'//routineN @@ -79,9 +75,9 @@ SUBROUTINE pbe_lda_info(pbe_params,reference,shortform, needs, max_deriv,& REAL(kind=dp) :: sc, sx failure=.FALSE. - CALL section_vals_val_get(pbe_params,"parametrization",i_val=param,error=error) - CALL section_vals_val_get(pbe_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(pbe_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(pbe_params,"parametrization",i_val=param) + CALL section_vals_val_get(pbe_params,"scale_x",r_val=sx) + CALL section_vals_val_get(pbe_params,"scale_c",r_val=sc) SELECT CASE(param) CASE(xc_pbe_orig) @@ -156,7 +152,7 @@ SUBROUTINE pbe_lda_info(pbe_params,reference,shortform, needs, max_deriv,& END IF END IF CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (PRESENT(needs)) THEN needs%rho=.TRUE. @@ -174,18 +170,14 @@ END SUBROUTINE pbe_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE pbe_lsd_info(pbe_params,reference,shortform, needs, max_deriv,& - error) +SUBROUTINE pbe_lsd_info(pbe_params,reference,shortform, needs, max_deriv) TYPE(section_vals_type), POINTER :: pbe_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pbe_lsd_info', & routineP = moduleN//':'//routineN @@ -195,9 +187,9 @@ SUBROUTINE pbe_lsd_info(pbe_params,reference,shortform, needs, max_deriv,& REAL(kind=dp) :: sc, sx failure=.FALSE. - CALL section_vals_val_get(pbe_params,"parametrization",i_val=param,error=error) - CALL section_vals_val_get(pbe_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(pbe_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(pbe_params,"parametrization",i_val=param) + CALL section_vals_val_get(pbe_params,"scale_x",r_val=sx) + CALL section_vals_val_get(pbe_params,"scale_c",r_val=sc) SELECT CASE(param) CASE(xc_pbe_orig) @@ -272,7 +264,7 @@ SUBROUTINE pbe_lsd_info(pbe_params,reference,shortform, needs, max_deriv,& END IF END IF CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT IF (PRESENT(needs)) THEN needs%rho_spin=.TRUE. @@ -292,16 +284,13 @@ END SUBROUTINE pbe_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param pbe_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE pbe_lda_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) +SUBROUTINE pbe_lda_eval(rho_set,deriv_set,grad_deriv,pbe_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: pbe_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pbe_lda_eval', & routineP = moduleN//':'//routineN @@ -321,19 +310,19 @@ SUBROUTINE pbe_lda_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,error=error) + norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -351,60 +340,59 @@ SUBROUTINE pbe_lda_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho,error=error) + "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho,error=error) + "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_val_get(pbe_params,"scale_c",r_val=scale_ec,error=error) - CALL section_vals_val_get(pbe_params,"scale_x",r_val=scale_ex,error=error) - CALL section_vals_val_get(pbe_params,"parametrization",i_val=param,error=error) + CALL section_vals_val_get(pbe_params,"scale_c",r_val=scale_ec) + CALL section_vals_val_get(pbe_params,"scale_x",r_val=scale_ex) + CALL section_vals_val_get(pbe_params,"parametrization",i_val=param) !$omp parallel default(none), & !$omp shared(rho,norm_drho,e_0,e_rho,e_ndrho,e_rho_rho,e_ndrho_rho),& !$omp shared(e_ndrho_ndrho,e_rho_rho_rho,e_ndrho_rho_rho,e_ndrho_ndrho_rho),& !$omp shared(e_ndrho_ndrho_ndrho,grad_deriv,npoints,epsilon_rho),& !$omp shared(pbe_params),& -!$omp shared(error,param,scale_ec,scale_ex) +!$omp shared(param,scale_ec,scale_ex) CALL pbe_lda_calc(rho=rho,norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,e_rho_rho=e_rho_rho,& e_ndrho_rho=e_ndrho_rho, e_ndrho_ndrho=e_ndrho_ndrho, & @@ -412,12 +400,12 @@ SUBROUTINE pbe_lda_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) e_ndrho_ndrho_rho=e_ndrho_ndrho_rho,e_ndrho_ndrho_ndrho=e_ndrho_ndrho_ndrho,& grad_deriv=grad_deriv,& npoints=npoints,epsilon_rho=epsilon_rho,& - param=param,scale_ec=scale_ec,scale_ex=scale_ex,error=error) + param=param,scale_ec=scale_ec,scale_ex=scale_ex) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -446,16 +434,14 @@ END SUBROUTINE pbe_lda_eval !> \param epsilon_rho ... !> \param ! ... !> \param pbe_params parameters for the pbe functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE pbe_lda_calc(rho, norm_drho,& e_0,e_rho,e_ndrho,e_rho_rho,e_ndrho_rho,& e_ndrho_ndrho, e_rho_rho_rho, e_ndrho_rho_rho, e_ndrho_ndrho_rho,& e_ndrho_ndrho_ndrho,grad_deriv,npoints,epsilon_rho,& -! pbe_params,error) - param,scale_ec,scale_ex,error) +! pbe_params) + param,scale_ec,scale_ex) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), INTENT(inout) :: & e_ndrho_ndrho_ndrho, e_ndrho_ndrho_rho, e_ndrho_rho_rho, e_rho_rho_rho, & @@ -465,7 +451,6 @@ SUBROUTINE pbe_lda_calc(rho, norm_drho,& REAL(kind=dp), INTENT(in) :: epsilon_rho INTEGER, INTENT(in) :: param REAL(kind=dp), INTENT(in) :: scale_ec, scale_ex - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pbe_lda_calc', & routineP = moduleN//':'//routineN @@ -554,7 +539,7 @@ SUBROUTINE pbe_lda_calc(rho, norm_drho,& beta = 0.46e-1_dp mu = 0.1e2_dp / 0.81e2_dp CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT gamma_var = (0.1e1_dp - LOG(0.2e1_dp)) / pi ** 2 @@ -1391,16 +1376,13 @@ END SUBROUTINE pbe_lda_calc !> \param deriv_set ... !> \param grad_deriv ... !> \param pbe_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** -SUBROUTINE pbe_lsd_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) +SUBROUTINE pbe_lsd_eval(rho_set,deriv_set,grad_deriv,pbe_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: pbe_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pbe_lsd_eval', & routineP = moduleN//':'//routineN @@ -1420,22 +1402,22 @@ SUBROUTINE pbe_lsd_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) failure=.FALSE. NULLIFY(deriv, bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,& rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa, & norm_drhob=norm_drhob, norm_drho=norm_drho, & rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -1458,71 +1440,71 @@ SUBROUTINE pbe_lsd_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra_ra) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ra_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ra_rb) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rb_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rb_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr_ra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr_rb) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_ra,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_ra) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb_rb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb_rb) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndr_ndr,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndr_ndr) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndra,error=error) + "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndra_ndra) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ndrb,error=error) + "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrb_ndrb) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN ! to do END IF - CALL section_vals_val_get(pbe_params,"scale_c",r_val=scale_ec,error=error) - CALL section_vals_val_get(pbe_params,"scale_x",r_val=scale_ex,error=error) - CALL section_vals_val_get(pbe_params,"parametrization",i_val=param,error=error) + CALL section_vals_val_get(pbe_params,"scale_c",r_val=scale_ec) + CALL section_vals_val_get(pbe_params,"scale_x",r_val=scale_ex) + CALL section_vals_val_get(pbe_params,"parametrization",i_val=param) !$omp parallel default(none),& !$omp shared(rhoa,rhob,norm_drho,norm_drhoa,norm_drhob,e_0,e_ra,e_rb,e_ndra_ra),& !$omp shared(e_ndrb_rb,e_ndr_ndr,e_ndra_ndra,e_ndrb_ndrb,e_ndr,e_ndra,e_ndrb),& !$omp shared(e_ra_ra,e_ra_rb,e_rb_rb,e_ndr_ra,e_ndr_rb,grad_deriv,npoints),& -!$omp shared(epsilon_rho,error,param,scale_ec,scale_ex) +!$omp shared(epsilon_rho,param,scale_ec,scale_ex) CALL pbe_lsd_calc(& rhoa=rhoa, rhob=rhob, norm_drho=norm_drho, norm_drhoa=norm_drhoa,& norm_drhob=norm_drhob, e_0=e_0, e_ra=e_ra, e_rb=e_rb,& @@ -1534,12 +1516,12 @@ SUBROUTINE pbe_lsd_eval(rho_set,deriv_set,grad_deriv,pbe_params,error) e_rb_ndr=e_ndr_rb,& grad_deriv=grad_deriv, npoints=npoints, & epsilon_rho=epsilon_rho,& - param=param,scale_ec=scale_ec,scale_ex=scale_ex,error=error) + param=param,scale_ec=scale_ec,scale_ex=scale_ex) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -1577,15 +1559,13 @@ END SUBROUTINE pbe_lsd_eval !> \param param ... !> \param scale_ec ... !> \param scale_ex ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** SUBROUTINE pbe_lsd_calc(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob,& e_0, e_ra, e_rb, e_ra_ndra, e_rb_ndrb, e_ndr_ndr,& e_ndra_ndra, e_ndrb_ndrb, e_ndr,& e_ndra, e_ndrb, e_ra_ra, e_ra_rb, e_rb_rb, e_ra_ndr, e_rb_ndr,& - grad_deriv,npoints,epsilon_rho,param,scale_ec,scale_ex,error) + grad_deriv,npoints,epsilon_rho,param,scale_ec,scale_ex) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rhoa, rhob, norm_drho, & norm_drhoa, norm_drhob REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_ra, e_rb, e_ra_ndra, & @@ -1595,7 +1575,6 @@ SUBROUTINE pbe_lsd_calc(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob,& REAL(kind=dp), INTENT(in) :: epsilon_rho INTEGER, INTENT(in) :: param REAL(kind=dp), INTENT(in) :: scale_ec, scale_ex - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pbe_lsd_calc', & routineP = moduleN//':'//routineN @@ -1685,7 +1664,7 @@ SUBROUTINE pbe_lsd_calc(rhoa, rhob, norm_drho, norm_drhoa, norm_drhob,& beta = 0.46e-1_dp mu = 0.1e2_dp / 0.81e2_dp CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT gamma_var = (0.1e1_dp - LOG(0.2e1_dp)) / pi ** 2 diff --git a/src/xc/xc_perdew86.F b/src/xc/xc_perdew86.F index 52449b861d..64048be9e8 100644 --- a/src/xc/xc_perdew86.F +++ b/src/xc/xc_perdew86.F @@ -88,14 +88,12 @@ END SUBROUTINE p86_init !> \param shortform ... !> \param needs ... !> \param max_deriv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE p86_lda_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE p86_lda_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "J. P. Perdew, Phys. Rev. B, 33, 8822 (1986) {LDA version}" @@ -117,16 +115,14 @@ END SUBROUTINE p86_lda_info !> \param deriv_set ... !> \param order ... !> \param p86_params ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE p86_lda_eval ( rho_set, deriv_set, order, p86_params, error ) + SUBROUTINE p86_lda_eval ( rho_set, deriv_set, order, p86_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order TYPE(section_vals_type), POINTER :: p86_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'p86_lda_eval', & routineP = moduleN//':'//routineN @@ -146,83 +142,82 @@ SUBROUTINE p86_lda_eval ( rho_set, deriv_set, order, p86_params, error ) NULLIFY(bo,rho,e_0,e_rho,e_ndrho,& e_rho_rho, e_rho_ndrho, e_ndrho_ndrho,& e_rho_rho_rho, e_rho_rho_ndrho, e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) ! calculate the perdew_zunger correlation - CALL pz_lda_eval( pz_orig, rho_set, deriv_set, order, p86_params, error) + CALL pz_lda_eval( pz_orig, rho_set, deriv_set, order, p86_params) CALL xc_rho_set_get(rho_set,rho=rho,& norm_drho=grho,local_bounds=bo,rho_cutoff=rho_cutoff,& - drho_cutoff=drho_cutoff,error=error) + drho_cutoff=drho_cutoff) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL p86_init(rho_cutoff) m = ABS(order) ALLOCATE ( rs(npoints), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL calc_rs_pw ( rho, rs, npoints ) IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) - CALL p86_u_0 ( rho, rs, grho, e_0, npoints, error ) + CALL p86_u_0 ( rho, rs, grho, e_0, npoints) END IF IF ( order>=1 .OR. order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) CALL p86_u_1 ( rho, grho, rs, e_rho,& - e_ndrho, npoints, error ) + e_ndrho, npoints) END IF IF ( order>=2 .OR. order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(rho)(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CALL p86_u_2 ( rho, grho, rs, e_rho_rho,& - e_rho_ndrho, e_ndrho_ndrho, npoints, error ) + e_rho_ndrho, e_ndrho_ndrho, npoints) END IF IF ( order>=3 .OR. order ==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho,error=error) + "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho,error=error) + "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) CALL p86_u_3 ( rho, grho, rs, e_rho_rho_rho,& e_rho_rho_ndrho, e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho,& - npoints, error ) + npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DEALLOCATE ( rs, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE p86_lda_eval @@ -234,15 +229,13 @@ END SUBROUTINE p86_lda_eval !> \param grho ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE p86_u_0 ( rho, rs, grho, e_0, npoints, error ) + SUBROUTINE p86_u_0 ( rho, rs, grho, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, rs, grho REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: cr, ep, g, or, phi, r, x @@ -274,15 +267,13 @@ END SUBROUTINE p86_u_0 !> \param e_rho ... !> \param e_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE p86_u_1 ( rho, grho, rs, e_rho, e_ndrho, npoints, error ) + SUBROUTINE p86_u_1 ( rho, grho, rs, e_rho, e_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, rs REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho, e_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: cr, dcr, dphig, dphir, dpv, & @@ -326,17 +317,15 @@ END SUBROUTINE p86_u_1 !> \param e_rho_ndrho ... !> \param e_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE p86_u_2 ( rho, grho, rs, e_rho_rho, e_rho_ndrho, e_ndrho_ndrho,& - npoints, error) + npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, rs REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho, e_rho_ndrho, & e_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: cr, d2cr, d2p, d2phir, d2q, & @@ -396,11 +385,10 @@ END SUBROUTINE p86_u_2 !> \param e_rho_ndrho_ndrho ... !> \param e_ndrho_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE p86_u_3 ( rho, grho, rs, e_rho_rho_rho,& e_rho_rho_ndrho, e_rho_ndrho_ndrho, e_ndrho_ndrho_ndrho,& - npoints, error) + npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, rs REAL(KIND=dp), DIMENSION(*), & @@ -409,7 +397,6 @@ SUBROUTINE p86_u_3 ( rho, grho, rs, e_rho_rho_rho,& e_rho_ndrho_ndrho, & e_ndrho_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: cr, d2cr, d2p, d2phir, d2phirg, d2pq, d2q, d2z, d3cr, & diff --git a/src/xc/xc_perdew_wang.F b/src/xc/xc_perdew_wang.F index 8e9c31a195..47bb200401 100644 --- a/src/xc/xc_perdew_wang.F +++ b/src/xc/xc_perdew_wang.F @@ -60,10 +60,9 @@ MODULE xc_perdew_wang !> \param needs ... !> \param max_deriv ... !> \param scale ... -!> \param error ... ! ***************************************************************************** SUBROUTINE perdew_wang_info ( method, lsd, reference, shortform, needs, & - max_deriv, scale, error) + max_deriv, scale) INTEGER, INTENT(in) :: method LOGICAL, INTENT(in) :: lsd CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform @@ -71,7 +70,6 @@ SUBROUTINE perdew_wang_info ( method, lsd, reference, shortform, needs, & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv REAL(kind=dp), INTENT(in) :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'perdew_wang_info', & routineP = moduleN//':'//routineN @@ -80,7 +78,7 @@ SUBROUTINE perdew_wang_info ( method, lsd, reference, shortform, needs, & SELECT CASE (method) CASE DEFAULT - CPAssertNoFail(.FALSE.,cp_failure_level,routineP,error) + CPAssertNoFail(.FALSE.,cp_failure_level,routineP) CASE (pw_orig) p_string='PWO' CASE (pw_dmc) @@ -215,16 +213,14 @@ END SUBROUTINE perdew_wang_init !> that order will be calculated, otherwise all derivatives up to !> that order will be calculated. !> \param scale ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE perdew_wang_lda_eval( method, rho_set, deriv_set, order, scale, error ) + SUBROUTINE perdew_wang_lda_eval( method, rho_set, deriv_set, order, scale) INTEGER, INTENT(in) :: method TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order REAL(kind=dp), INTENT(in) :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'perdew_wang_lda_eval', & routineP = moduleN//':'//routineN @@ -241,12 +237,12 @@ SUBROUTINE perdew_wang_lda_eval( method, rho_set, deriv_set, order, scale, error CALL timeset(routineN,timer_handle) failure=.FALSE. NULLIFY(bo,rho, e_0,e_rho,e_rho_rho,e_rho_rho_rho, dummy) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - local_bounds=bo,rho_cutoff=rho_cutoff,error=error) + local_bounds=bo,rho_cutoff=rho_cutoff) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL perdew_wang_init(method, rho_cutoff) @@ -255,7 +251,7 @@ SUBROUTINE perdew_wang_lda_eval( method, rho_set, deriv_set, order, scale, error ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -267,28 +263,28 @@ SUBROUTINE perdew_wang_lda_eval( method, rho_set, deriv_set, order, scale, error IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) END IF IF (order>=2.OR.order==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) END IF IF (order>=3.OR.order==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) END IF IF (order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL perdew_wang_lda_calc(rho,e_0,e_rho, e_rho_rho, e_rho_rho_rho, & @@ -296,7 +292,7 @@ SUBROUTINE perdew_wang_lda_eval( method, rho_set, deriv_set, order, scale, error IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -374,15 +370,13 @@ END SUBROUTINE perdew_wang_lda_calc !> that order will be calculated, otherwise all derivatives up to !> that order will be calculated. !> \param scale ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE perdew_wang_lsd_eval( method, rho_set, deriv_set, order, scale, error ) + SUBROUTINE perdew_wang_lsd_eval( method, rho_set, deriv_set, order, scale) INTEGER, INTENT(in) :: method TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN), OPTIONAL :: order REAL(kind=dp), INTENT(in) :: scale - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'perdew_wang_lsd_eval', & routineP = moduleN//':'//routineN @@ -400,12 +394,12 @@ SUBROUTINE perdew_wang_lsd_eval( method, rho_set, deriv_set, order, scale, error CALL timeset(routineN,timer_handle) failure=.FALSE. NULLIFY(bo,a,b,e_0,ea,eb,eaa,eab,ebb,eaaa,eaab,eabb,ebbb) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=a,rhob=b,& - local_bounds=bo,rho_cutoff=rho_cutoff,error=error) + local_bounds=bo,rho_cutoff=rho_cutoff) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL perdew_wang_init(method, rho_cutoff) @@ -414,7 +408,7 @@ SUBROUTINE perdew_wang_lsd_eval( method, rho_set, deriv_set, order, scale, error ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> a END IF @@ -426,46 +420,46 @@ SUBROUTINE perdew_wang_lsd_eval( method, rho_set, deriv_set, order, scale, error IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=ea,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=ea) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eb) END IF IF (order>=2.OR.order==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eaa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eaa) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eab,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eab) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=ebb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=ebb) END IF IF (order>=3.OR.order==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eaaa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eaaa) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eaab,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eaab) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eabb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eabb) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=ebbb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=ebbb) END IF IF (order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL perdew_wang_lsd_calc(a,b,e_0,ea,eb,eaa,eab,ebb,eaaa,eaab,eabb,& @@ -473,7 +467,7 @@ SUBROUTINE perdew_wang_lsd_eval( method, rho_set, deriv_set, order, scale, error IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF diff --git a/src/xc/xc_perdew_zunger.F b/src/xc/xc_perdew_zunger.F index e3bcab0560..b747fa5983 100644 --- a/src/xc/xc_perdew_zunger.F +++ b/src/xc/xc_perdew_zunger.F @@ -61,18 +61,16 @@ MODULE xc_perdew_zunger !> \param shortform CHARACTER(*), INTENT(OUT), OPTIONAL - short reference !> \param needs ... !> \param max_deriv ... -!> \param error ... !> \par History !> 18-MAR-2002, TCH, working version ! ***************************************************************************** - SUBROUTINE pz_info ( method, lsd, reference, shortform, needs, max_deriv, error) + SUBROUTINE pz_info ( method, lsd, reference, shortform, needs, max_deriv) INTEGER, INTENT(in) :: method LOGICAL, INTENT(in) :: lsd CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pz_info', & routineP = moduleN//':'//routineN @@ -83,7 +81,7 @@ SUBROUTINE pz_info ( method, lsd, reference, shortform, needs, max_deriv, error) failure=.FALSE. SELECT CASE (method) CASE DEFAULT - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) CASE (pz_orig) p_string='ORIG' CASE (pz_dmc) @@ -136,18 +134,16 @@ END SUBROUTINE pz_info !> that order will be calculated, otherwise all derivatives up to !> that order will be calculated. !> \param pz_params input paramter (scaling) -!> \param error ... !> \par History !> 01.2007 added scaling [Manuel Guidon] ! ***************************************************************************** - SUBROUTINE pz_lda_eval ( method, rho_set, deriv_set, order, pz_params, error ) + SUBROUTINE pz_lda_eval ( method, rho_set, deriv_set, order, pz_params) INTEGER, INTENT(in) :: method TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order TYPE(section_vals_type), POINTER :: pz_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pz_lda_eval', & routineP = moduleN//':'//routineN @@ -165,14 +161,14 @@ SUBROUTINE pz_lda_eval ( method, rho_set, deriv_set, order, pz_params, error ) failure=.FALSE. NULLIFY(bo,rho, e_0,e_rho,e_rho_rho,e_rho_rho_rho, dummy) - CALL section_vals_val_get(pz_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(pz_params,"scale_c",r_val=sc) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - local_bounds=bo,rho_cutoff=rho_cutoff,error=error) + local_bounds=bo,rho_cutoff=rho_cutoff) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL pz_init(method, rho_cutoff) @@ -181,7 +177,7 @@ SUBROUTINE pz_lda_eval ( method, rho_set, deriv_set, order, pz_params, error ) ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -193,35 +189,35 @@ SUBROUTINE pz_lda_eval ( method, rho_set, deriv_set, order, pz_params, error ) IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) END IF IF (order>=2.OR.order==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) END IF IF (order>=3.OR.order==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) END IF IF (order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL pz_lda_calc(rho,e_0,e_rho, e_rho_rho, e_rho_rho_rho, npoints, order, sc) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -295,17 +291,15 @@ END SUBROUTINE pz_lda_calc !> that order will be calculated, otherwise all derivatives up to !> that order will be calculated. !> \param pz_params input paramter (scaling) -!> \param error ... !> \par History !> 01.2007 added scaling [Manuel Guidon] ! ***************************************************************************** - SUBROUTINE pz_lsd_eval ( method, rho_set, deriv_set, order,pz_params, error ) + SUBROUTINE pz_lsd_eval ( method, rho_set, deriv_set, order,pz_params) INTEGER, INTENT(in) :: method TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN), OPTIONAL :: order TYPE(section_vals_type), POINTER :: pz_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'pz_lsd_eval', & routineP = moduleN//':'//routineN @@ -324,14 +318,14 @@ SUBROUTINE pz_lsd_eval ( method, rho_set, deriv_set, order,pz_params, error ) failure=.FALSE. NULLIFY(bo,a,b,e_0,ea,eaa,eab,ebb,eaaa,eaab,eabb,ebbb) - CALL section_vals_val_get(pz_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(pz_params,"scale_c",r_val=sc) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=a,rhob=b,& - local_bounds=bo,rho_cutoff=rho_cutoff,error=error) + local_bounds=bo,rho_cutoff=rho_cutoff) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL pz_init(method, rho_cutoff) @@ -340,7 +334,7 @@ SUBROUTINE pz_lsd_eval ( method, rho_set, deriv_set, order,pz_params, error ) ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> a END IF @@ -352,43 +346,43 @@ SUBROUTINE pz_lsd_eval ( method, rho_set, deriv_set, order,pz_params, error ) IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=ea,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=ea) END IF IF (order>=2.OR.order==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eaa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eaa) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eab,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eab) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=ebb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=ebb) END IF IF (order>=3.OR.order==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eaaa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eaaa) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eaab,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eaab) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=eabb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=eabb) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=ebbb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=ebbb) END IF IF (order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL pz_lsd_calc(a,b,e_0,ea,eaa,eab,ebb,eaaa,eaab,eabb,& @@ -396,7 +390,7 @@ SUBROUTINE pz_lsd_eval ( method, rho_set, deriv_set, order,pz_params, error ) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF diff --git a/src/xc/xc_rho_cflags_types.F b/src/xc/xc_rho_cflags_types.F index 6e74546c83..db04a71169 100644 --- a/src/xc/xc_rho_cflags_types.F +++ b/src/xc/xc_rho_cflags_types.F @@ -58,13 +58,10 @@ MODULE xc_rho_cflags_types !> \brief sets all the flags to the given value !> \param cflags the flags to set !> \param value the value to set -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_rho_cflags_setall(cflags, value, error) + SUBROUTINE xc_rho_cflags_setall(cflags, value) TYPE(xc_rho_cflags_type), INTENT(out) :: cflags LOGICAL, INTENT(in) :: value - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_cflags_setall', & routineP = moduleN//':'//routineN @@ -91,13 +88,10 @@ END SUBROUTINE xc_rho_cflags_setall !> \brief performs an OR on all the flags (cflags1=cflag1.or.cflags2) !> \param cflags1 the flags to change !> \param cflags2 the flags to OR with -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_rho_cflags_or(cflags1, cflags2, error) + SUBROUTINE xc_rho_cflags_or(cflags1, cflags2) TYPE(xc_rho_cflags_type), INTENT(inout) :: cflags1 TYPE(xc_rho_cflags_type), INTENT(in) :: cflags2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_cflags_or', & routineP = moduleN//':'//routineN @@ -127,13 +121,10 @@ END SUBROUTINE xc_rho_cflags_or !> \brief performs an AND on all the flags (cflags1=cflag1.and.cflags2) !> \param cflags1 the flags to change !> \param cflags2 the flags to and with -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_rho_cflags_and(cflags1, cflags2, error) + SUBROUTINE xc_rho_cflags_and(cflags1, cflags2) TYPE(xc_rho_cflags_type), INTENT(inout) :: cflags1 TYPE(xc_rho_cflags_type), INTENT(in) :: cflags2 - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_cflags_and', & routineP = moduleN//':'//routineN @@ -162,14 +153,11 @@ END SUBROUTINE xc_rho_cflags_and !> \brief return true if the two cflags are equal !> \param cflags1 the flags to compare !> \param cflags2 the flags to compare -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval equal ... ! ***************************************************************************** - FUNCTION xc_rho_cflags_equal(cflags1, cflags2, error) RESULT(equal) + FUNCTION xc_rho_cflags_equal(cflags1, cflags2) RESULT(equal) TYPE(xc_rho_cflags_type), INTENT(inout) :: cflags1 TYPE(xc_rho_cflags_type), INTENT(in) :: cflags2 - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: equal CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_cflags_equal', & @@ -199,16 +187,13 @@ END FUNCTION xc_rho_cflags_equal !> \brief return true if all the true flags in cflags2 are also true in cflags1 !> \param cflags1 the flags to compare !> \param cflags2 the flags to compare -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \retval contain ... !> \note !> defines a partial ordering on the cflags (cflags1>cflags2) ! ***************************************************************************** - FUNCTION xc_rho_cflags_contain(cflags1, cflags2, error) RESULT(contain) + FUNCTION xc_rho_cflags_contain(cflags1, cflags2) RESULT(contain) TYPE(xc_rho_cflags_type), INTENT(inout) :: cflags1 TYPE(xc_rho_cflags_type), INTENT(in) :: cflags2 - TYPE(cp_error_type), INTENT(inout) :: error LOGICAL :: contain CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_cflags_contain', & @@ -238,16 +223,13 @@ END FUNCTION xc_rho_cflags_contain !> \brief writes out the values of the cflags !> \param cflags the flags to be written out !> \param unit_nr the unit to write to -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE xc_rho_cflags_write(cflags,unit_nr,error) + SUBROUTINE xc_rho_cflags_write(cflags,unit_nr) TYPE(xc_rho_cflags_type), INTENT(in) :: cflags INTEGER, INTENT(in) :: unit_nr - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_cflags_write', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_rho_set_types.F b/src/xc/xc_rho_set_types.F index 89e14ddcff..e528717e26 100644 --- a/src/xc/xc_rho_set_types.F +++ b/src/xc/xc_rho_set_types.F @@ -119,16 +119,13 @@ MODULE xc_rho_set_types !> \param rho_cutoff ... !> \param drho_cutoff ... !> \param tau_cutoff ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE xc_rho_set_create(rho_set,local_bounds,rho_cutoff,drho_cutoff,& - tau_cutoff,error) + tau_cutoff) TYPE(xc_rho_set_type), POINTER :: rho_set INTEGER, DIMENSION(2, 3), INTENT(in) :: local_bounds REAL(kind=dp), INTENT(in), OPTIONAL :: rho_cutoff, drho_cutoff, & tau_cutoff - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_set_create', & routineP = moduleN//':'//routineN @@ -138,9 +135,9 @@ SUBROUTINE xc_rho_set_create(rho_set,local_bounds,rho_cutoff,drho_cutoff,& failure=.FALSE. - CPPrecondition(.NOT.ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.ASSOCIATED(rho_set),cp_failure_level,routineP,failure) ALLOCATE(rho_set, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) rho_set%ref_count=1 last_rho_set_id=last_rho_set_id+1 rho_set%id_nr=last_rho_set_id @@ -151,8 +148,8 @@ SUBROUTINE xc_rho_set_create(rho_set,local_bounds,rho_cutoff,drho_cutoff,& rho_set%tau_cutoff=EPSILON(0.0_dp) IF (PRESENT(tau_cutoff)) rho_set%tau_cutoff=tau_cutoff rho_set%local_bounds=local_bounds - CALL xc_rho_cflags_setall(rho_set%owns,.TRUE.,error=error) - CALL xc_rho_cflags_setall(rho_set%has,.FALSE.,error=error) + CALL xc_rho_cflags_setall(rho_set%owns,.TRUE.) + CALL xc_rho_cflags_setall(rho_set%has,.FALSE.) NULLIFY(rho_set%rho) DO i=1,3 NULLIFY(rho_set%drho(i)%array) @@ -171,12 +168,9 @@ END SUBROUTINE xc_rho_set_create ! ***************************************************************************** !> \brief retains the given rho_set !> \param rho_set the object to retain -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_rho_set_retain(rho_set, error) + SUBROUTINE xc_rho_set_retain(rho_set) TYPE(xc_rho_set_type), POINTER :: rho_set - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_set_retain', & routineP = moduleN//':'//routineN @@ -184,8 +178,8 @@ SUBROUTINE xc_rho_set_retain(rho_set, error) LOGICAL :: failure failure=.FALSE. - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPreconditionNoFail(rho_set%ref_count>0,cp_failure_level,routineP,error) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPreconditionNoFail(rho_set%ref_count>0,cp_failure_level,routineP) rho_set%ref_count=rho_set%ref_count+1 END SUBROUTINE xc_rho_set_retain @@ -193,13 +187,10 @@ END SUBROUTINE xc_rho_set_retain !> \brief releases the given rho_set !> \param rho_set the structure to release !> \param pw_pool the plae where to give back the arrays -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** - SUBROUTINE xc_rho_set_release(rho_set, pw_pool, error) + SUBROUTINE xc_rho_set_release(rho_set, pw_pool) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(pw_pool_type), OPTIONAL, POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_set_release', & routineP = moduleN//':'//routineN @@ -210,16 +201,16 @@ SUBROUTINE xc_rho_set_release(rho_set, pw_pool, error) failure=.FALSE. IF (ASSOCIATED(rho_set)) THEN - CPPreconditionNoFail(rho_set%ref_count>0,cp_failure_level,routineP,error) + CPPreconditionNoFail(rho_set%ref_count>0,cp_failure_level,routineP) rho_set%ref_count=rho_set%ref_count-1 IF (rho_set%ref_count==0) THEN IF (PRESENT(pw_pool)) THEN IF (ASSOCIATED(pw_pool)) THEN rho_set%ref_count=1 - CALL xc_rho_set_clean(rho_set,pw_pool,error) + CALL xc_rho_set_clean(rho_set,pw_pool) rho_set%ref_count=0 ELSE - CPPrecondition(.FALSE.,cp_warning_level,routineP,error,failure) + CPPrecondition(.FALSE.,cp_warning_level,routineP,failure) END IF END IF @@ -227,37 +218,37 @@ SUBROUTINE xc_rho_set_release(rho_set, pw_pool, error) rho_set%local_bounds(1,:)=HUGE(0) IF (rho_set%owns%rho .AND. ASSOCIATED(rho_set%rho)) THEN DEALLOCATE(rho_set%rho, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (rho_set%owns%rho_spin) THEN IF (ASSOCIATED(rho_set%rhoa)) THEN DEALLOCATE(rho_set%rhoa, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rho_set%rhob)) THEN DEALLOCATE(rho_set%rhob, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF IF (rho_set%owns%rho_1_3.AND.ASSOCIATED(rho_set%rho_1_3)) THEN DEALLOCATE(rho_set%rho_1_3, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (rho_set%owns%rho_spin) THEN IF (ASSOCIATED(rho_set%rhoa_1_3)) THEN DEALLOCATE(rho_set%rhoa_1_3, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rho_set%rhob_1_3)) THEN DEALLOCATE(rho_set%rhob_1_3, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF IF (rho_set%owns%drho) THEN DO i=1,3 IF (ASSOCIATED(rho_set%drho(i)%array)) THEN DEALLOCATE(rho_set%drho(i)%array, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END IF @@ -265,64 +256,64 @@ SUBROUTINE xc_rho_set_release(rho_set, pw_pool, error) DO i=1,3 IF (ASSOCIATED(rho_set%drhoa(i)%array)) THEN DEALLOCATE(rho_set%drhoa(i)%array, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rho_set%drhob(i)%array)) THEN DEALLOCATE(rho_set%drhob(i)%array, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END DO END IF IF (rho_set%owns%laplace_rho.AND.ASSOCIATED(rho_set%laplace_rho)) THEN DEALLOCATE(rho_set%laplace_rho, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (rho_set%owns%norm_drho.AND.ASSOCIATED(rho_set%norm_drho)) THEN DEALLOCATE(rho_set%norm_drho, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (rho_set%owns%laplace_rho_spin) THEN IF (ASSOCIATED(rho_set%laplace_rhoa)) THEN DEALLOCATE(rho_set%laplace_rhoa, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rho_set%laplace_rhob)) THEN DEALLOCATE(rho_set%laplace_rhob, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF IF (rho_set%owns%norm_drho_spin) THEN IF (ASSOCIATED(rho_set%norm_drhoa)) THEN DEALLOCATE(rho_set%norm_drhoa, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rho_set%norm_drhob)) THEN DEALLOCATE(rho_set%norm_drhob, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF IF (rho_set%owns%drhoa_drhob.AND.ASSOCIATED(rho_set%drhoa_drhob)) THEN DEALLOCATE(rho_set%drhoa_drhob, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (rho_set%owns%tau.AND.ASSOCIATED(rho_set%tau)) THEN DEALLOCATE(rho_set%tau, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (rho_set%owns%tau_spin) THEN IF (ASSOCIATED(rho_set%tau_a)) THEN DEALLOCATE(rho_set%tau_a, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF IF (ASSOCIATED(rho_set%tau_b)) THEN DEALLOCATE(rho_set%tau_b, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF DEALLOCATE(rho_set, stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) END IF END IF NULLIFY(rho_set) @@ -357,15 +348,11 @@ END SUBROUTINE xc_rho_set_release !> \param tau_a ... !> \param tau_b ... !> \param local_bounds ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling -!> -!> for the other components see the attributes of xc_rho_set ! ***************************************************************************** SUBROUTINE xc_rho_set_get(rho_set, can_return_null, rho, drho, norm_drho,& rhoa, rhob, norm_drhoa, norm_drhob, drhoa_drhob,rho_1_3,rhoa_1_3,& rhob_1_3,laplace_rho,laplace_rhoa,laplace_rhob,drhoa,drhob,rho_cutoff,& - drho_cutoff,tau_cutoff,tau,tau_a,tau_b,local_bounds,error) + drho_cutoff,tau_cutoff,tau,tau_a,tau_b,local_bounds) TYPE(xc_rho_set_type), POINTER :: rho_set LOGICAL, INTENT(in), OPTIONAL :: can_return_null REAL(KIND=dp), DIMENSION(:, :, :), & @@ -383,7 +370,6 @@ SUBROUTINE xc_rho_set_get(rho_set, can_return_null, rho, drho, norm_drho,& OPTIONAL, POINTER :: tau, tau_a, tau_b INTEGER, DIMENSION(:, :), OPTIONAL, & POINTER :: local_bounds - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_set_get', & routineP = moduleN//':'//routineN @@ -395,41 +381,41 @@ SUBROUTINE xc_rho_set_get(rho_set, can_return_null, rho, drho, norm_drho,& my_can_return_null=.FALSE. IF (PRESENT(can_return_null)) my_can_return_null=can_return_null - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) IF (PRESENT(rho)) THEN rho => rho_set%rho - CPPrecondition(my_can_return_null.OR.ASSOCIATED(rho),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(rho),cp_failure_level,routineP,failure) END IF IF (PRESENT(drho)) THEN drho => rho_set%drho IF (.NOT.my_can_return_null) THEN DO i=1,3 - CPPrecondition(ASSOCIATED(rho_set%drho(i)%array),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set%drho(i)%array),cp_failure_level,routineP,failure) END DO END IF END IF IF (PRESENT(norm_drho)) THEN norm_drho => rho_set%norm_drho - CPPrecondition(my_can_return_null.OR.ASSOCIATED(norm_drho),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(norm_drho),cp_failure_level,routineP,failure) END IF IF (PRESENT(laplace_rho)) THEN laplace_rho => rho_set%laplace_rho - CPPrecondition(my_can_return_null.OR.ASSOCIATED(laplace_rho),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(laplace_rho),cp_failure_level,routineP,failure) END IF IF (PRESENT(rhoa)) THEN rhoa => rho_set%rhoa - CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhoa),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhoa),cp_failure_level,routineP,failure) END IF IF (PRESENT(rhob)) THEN rhob => rho_set%rhob - CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhob),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhob),cp_failure_level,routineP,failure) END IF IF (PRESENT(drhoa)) THEN drhoa => rho_set%drhoa IF (.NOT.my_can_return_null) THEN DO i=1,3 - CPAssert(ASSOCIATED(rho_set%drhoa(i)%array),cp_failure_level,routineP,error,failure) + CPAssert(ASSOCIATED(rho_set%drhoa(i)%array),cp_failure_level,routineP,failure) END DO END IF END IF @@ -437,53 +423,53 @@ SUBROUTINE xc_rho_set_get(rho_set, can_return_null, rho, drho, norm_drho,& drhob => rho_set%drhob IF (.NOT.my_can_return_null) THEN DO i=1,3 - CPPrecondition(ASSOCIATED(rho_set%drhob(i)%array),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set%drhob(i)%array),cp_failure_level,routineP,failure) END DO END IF END IF IF (PRESENT(laplace_rhoa)) THEN laplace_rhoa => rho_set%laplace_rhoa - CPPrecondition(my_can_return_null.OR.ASSOCIATED(laplace_rhoa),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(laplace_rhoa),cp_failure_level,routineP,failure) END IF IF (PRESENT(laplace_rhob)) THEN laplace_rhob => rho_set%laplace_rhob - CPPrecondition(my_can_return_null.OR.ASSOCIATED(laplace_rhob),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(laplace_rhob),cp_failure_level,routineP,failure) END IF IF (PRESENT(norm_drhoa)) THEN norm_drhoa => rho_set%norm_drhoa - CPPrecondition(my_can_return_null.OR.ASSOCIATED(norm_drhoa),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(norm_drhoa),cp_failure_level,routineP,failure) END IF IF (PRESENT(norm_drhob)) THEN norm_drhob => rho_set%norm_drhob - CPPrecondition(my_can_return_null.OR.ASSOCIATED(norm_drhob),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(norm_drhob),cp_failure_level,routineP,failure) END IF IF (PRESENT(drhoa_drhob)) THEN drhoa_drhob => rho_set%drhoa_drhob - CPPrecondition(my_can_return_null.OR.ASSOCIATED(drhoa_drhob),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(drhoa_drhob),cp_failure_level,routineP,failure) END IF IF (PRESENT(rho_1_3)) THEN rho_1_3 => rho_set%rho_1_3 - CPPrecondition(my_can_return_null.OR.ASSOCIATED(rho_1_3),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(rho_1_3),cp_failure_level,routineP,failure) END IF IF (PRESENT(rhoa_1_3)) THEN rhoa_1_3 => rho_set%rhoa_1_3 - CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhoa_1_3),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhoa_1_3),cp_failure_level,routineP,failure) END IF IF (PRESENT(rhob_1_3)) THEN rhob_1_3 => rho_set%rhob_1_3 - CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhob_1_3),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(rhob_1_3),cp_failure_level,routineP,failure) END IF IF (PRESENT(tau)) THEN tau => rho_set%tau - CPPrecondition(my_can_return_null.OR.ASSOCIATED(tau),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(tau),cp_failure_level,routineP,failure) END IF IF (PRESENT(tau_a)) THEN tau_a => rho_set%tau_a - CPPrecondition(my_can_return_null.OR.ASSOCIATED(tau_a),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(tau_a),cp_failure_level,routineP,failure) END IF IF (PRESENT(tau_b)) THEN tau_b => rho_set%tau_b - CPPrecondition(my_can_return_null.OR.ASSOCIATED(tau_b),cp_failure_level,routineP,error,failure) + CPPrecondition(my_can_return_null.OR.ASSOCIATED(tau_b),cp_failure_level,routineP,failure) END IF IF (PRESENT(rho_cutoff)) rho_cutoff=rho_set%rho_cutoff IF (PRESENT(drho_cutoff)) drho_cutoff=rho_set%drho_cutoff @@ -496,14 +482,11 @@ END SUBROUTINE xc_rho_set_get !> what it can to the pw_pool !> \param rho_set the rho_set to be cleaned !> \param pw_pool place to give back 3d arrays,... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author Fawzi Mohamed ! ***************************************************************************** - SUBROUTINE xc_rho_set_clean(rho_set,pw_pool,error) + SUBROUTINE xc_rho_set_clean(rho_set,pw_pool) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_set_clean', & routineP = moduleN//':'//routineN @@ -513,26 +496,26 @@ SUBROUTINE xc_rho_set_clean(rho_set,pw_pool,error) failure=.FALSE. - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) IF (rho_set%owns%rho) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%rho, & - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%rho) END IF IF (rho_set%owns%rho_1_3) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%rho_1_3,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%rho_1_3) END IF IF (rho_set%owns%drho) THEN DO idir=1,3 CALL pw_pool_give_back_cr3d(pw_pool,rho_set%drho(idir)%array,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) END DO ELSE DO idir=1,3 @@ -541,44 +524,44 @@ SUBROUTINE xc_rho_set_clean(rho_set,pw_pool,error) END IF IF (rho_set%owns%norm_drho) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%norm_drho,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%norm_drho) END IF IF (rho_set%owns%laplace_rho) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%laplace_rho,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%laplace_rho) END IF IF (rho_set%owns%tau) THEN CALL pw_pool_give_back_cr3d(pw_pool, rho_set%tau,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%tau) END IF IF (rho_set%owns%rho_spin) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%rhoa,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_cr3d(pw_pool,rho_set%rhob,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%rhoa,rho_set%rhob) END IF IF (rho_set%owns%rho_spin_1_3) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%rhoa_1_3,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_cr3d(pw_pool,rho_set%rhob_1_3,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%rhoa_1_3,rho_set%rhob_1_3) END IF IF (rho_set%owns%drho_spin) THEN DO idir=1,3 CALL pw_pool_give_back_cr3d(pw_pool,rho_set%drhoa(idir)%array,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_cr3d(pw_pool,rho_set%drhob(idir)%array,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) END DO ELSE DO idir=1,3 @@ -587,37 +570,37 @@ SUBROUTINE xc_rho_set_clean(rho_set,pw_pool,error) END IF IF (rho_set%owns%laplace_rho_spin) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%laplace_rhoa,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_cr3d(pw_pool,rho_set%laplace_rhob,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%laplace_rhoa, rho_set%laplace_rhob) END IF IF (rho_set%owns%norm_drho_spin) THEN CALL pw_pool_give_back_cr3d(pw_pool,rho_set%norm_drhoa,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_cr3d(pw_pool,rho_set%norm_drhob,& - accept_non_compatible=.TRUE.,error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%norm_drhoa, rho_set%norm_drhob) END IF IF (rho_set%owns%drhoa_drhob) THEN CALL pw_pool_give_back_cr3d(pw_pool, rho_set%drhoa_drhob,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%drhoa_drhob) END IF IF (rho_set%owns%tau_spin) THEN CALL pw_pool_give_back_cr3d(pw_pool, rho_set%tau_a,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) CALL pw_pool_give_back_cr3d(pw_pool, rho_set%tau_b,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) ELSE NULLIFY(rho_set%tau_a,rho_set%tau_b) END IF - CALL xc_rho_cflags_setall(rho_set%has,.FALSE.,error=error) - CALL xc_rho_cflags_setall(rho_set%owns,.FALSE.,error=error) + CALL xc_rho_cflags_setall(rho_set%has,.FALSE.) + CALL xc_rho_cflags_setall(rho_set%owns,.FALSE.) END SUBROUTINE xc_rho_set_clean @@ -634,18 +617,15 @@ END SUBROUTINE xc_rho_set_clean !> \param xc_deriv_method_id ... !> \param xc_rho_smooth_id ... !> \param pw_pool pool for the allocation of pw and cr3d -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling ! ***************************************************************************** SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& - xc_deriv_method_id,xc_rho_smooth_id,pw_pool,error) + xc_deriv_method_id,xc_rho_smooth_id,pw_pool) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_r, rho_g, tau TYPE(xc_rho_cflags_type), INTENT(in) :: needs INTEGER, INTENT(IN) :: xc_deriv_method_id, & xc_rho_smooth_id TYPE(pw_pool_type), POINTER :: pw_pool - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_rho_set_update', & routineP = moduleN//':'//routineN @@ -676,11 +656,11 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& nd = RESHAPE ((/1,0,0,0,1,0,0,0,1/),(/3,3/)) nd_laplace = RESHAPE((/2,0,0,0,2,0,0,0,2/),(/3,3/)) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) CALL cp_assert(ALL(rho_set%local_bounds==pw_pool%pw_grid%bounds_local),& cp_failure_level,cp_assertion_failed,routineP,& - "pw_pool cr3d have different size than expected",error,failure) + "pw_pool cr3d have different size than expected",failure) nspins = SIZE(rho_r) rho_set%local_bounds=rho_r(1)%pw%pw_grid%bounds_local rho_cutoff=0.5*rho_set%rho_cutoff @@ -689,25 +669,25 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& ! some checks SELECT CASE(nspins) CASE(1) - CPPrecondition(SIZE(rho_r)==1,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho_r(1)%pw),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_r(1)%pw%in_use==REALDATA3D,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%rho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%norm_drho_spin,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,error,failure) - CPPrecondition(.NOT.needs%rho_spin_1_3,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(rho_r)==1,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho_r(1)%pw),cp_failure_level,routineP,failure) + CPPrecondition(rho_r(1)%pw%in_use==REALDATA3D,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%rho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%norm_drho_spin,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%drhoa_drhob,cp_failure_level,routineP,failure) + CPPrecondition(.NOT.needs%rho_spin_1_3,cp_failure_level,routineP,failure) CASE(2) - CPPrecondition(SIZE(rho_r)==2,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho_r(1)%pw),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(rho_r(2)%pw),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_r(1)%pw%in_use==REALDATA3D,cp_failure_level,routineP,error,failure) - CPPrecondition(rho_r(2)%pw%in_use==REALDATA3D,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(rho_r)==2,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho_r(1)%pw),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(rho_r(2)%pw),cp_failure_level,routineP,failure) + CPPrecondition(rho_r(1)%pw%in_use==REALDATA3D,cp_failure_level,routineP,failure) + CPPrecondition(rho_r(2)%pw%in_use==REALDATA3D,cp_failure_level,routineP,failure) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL xc_rho_set_clean(rho_set,pw_pool=pw_pool,error=error) + CALL xc_rho_set_clean(rho_set,pw_pool=pw_pool) gradient_f=(needs%drho_spin.OR.needs%norm_drho_spin.OR.& needs%drhoa_drhob.OR.needs%drho.OR.needs%norm_drho.OR.needs%laplace_rho & @@ -729,40 +709,38 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& my_rho_r_local=.TRUE. CALL pw_pool_create_pw(pw_pool, my_rho_r(ispin)%pw,& - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) - CALL pw_copy(rho_r(ispin)%pw,my_rho_r(ispin)%pw,error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy(rho_r(ispin)%pw,my_rho_r(ispin)%pw) ELSE my_rho_r_local=.TRUE. CALL pw_pool_create_pw(pw_pool, my_rho_r(ispin)%pw,& - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) SELECT CASE(xc_rho_smooth_id) CASE (xc_rho_no_smooth) - CALL pw_copy(rho_r(ispin)%pw,my_rho_r(ispin)%pw,error=error) + CALL pw_copy(rho_r(ispin)%pw,my_rho_r(ispin)%pw) CASE (xc_rho_spline2_smooth) - CALL pw_zero(my_rho_r(ispin)%pw,error=error) + CALL pw_zero(my_rho_r(ispin)%pw) CALL pw_nn_smear_r(pw_in=rho_r(ispin)%pw,& pw_out=my_rho_r(ispin)%pw,& - coeffs=spline2_coeffs, error=error) + coeffs=spline2_coeffs) CASE (xc_rho_spline3_smooth) - CALL pw_zero(my_rho_r(ispin)%pw,error=error) + CALL pw_zero(my_rho_r(ispin)%pw) CALL pw_nn_smear_r(pw_in=rho_r(ispin)%pw,& pw_out=my_rho_r(ispin)%pw,& - coeffs=spline3_coeffs, error=error) + coeffs=spline3_coeffs) CASE (xc_rho_nn10) - CALL pw_zero(my_rho_r(ispin)%pw,error=error) + CALL pw_zero(my_rho_r(ispin)%pw) CALL pw_nn_smear_r(pw_in=rho_r(ispin)%pw,& pw_out=my_rho_r(ispin)%pw,& - coeffs=nn10_coeffs, error=error) + coeffs=nn10_coeffs) CASE (xc_rho_nn50) - CALL pw_zero(my_rho_r(ispin)%pw,error=error) + CALL pw_zero(my_rho_r(ispin)%pw) CALL pw_nn_smear_r(pw_in=rho_r(ispin)%pw,& pw_out=my_rho_r(ispin)%pw,& - coeffs=nn50_coeffs, error=error) + coeffs=nn50_coeffs) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF @@ -773,124 +751,118 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& DO idir=1,3 NULLIFY(drho_r(idir,ispin)%pw) CALL pw_pool_create_pw(pw_pool,drho_r(idir,ispin)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) + use_data=REALDATA3D, in_space=REALSPACE) END DO IF (needs_rho_g) THEN IF (.NOT.ASSOCIATED(my_rho_g)) THEN my_rho_g_local=.TRUE. CALL pw_pool_create_pw(pw_pool, my_rho_g,& - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) - CALL pw_transfer(my_rho_r(ispin)%pw,my_rho_g,error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_transfer(my_rho_r(ispin)%pw,my_rho_g) END IF CALL pw_pool_create_pw(pw_pool, tmp_g,& - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) SELECT CASE(xc_deriv_method_id) CASE (xc_deriv_pw) DO idir=1,3 - CALL pw_copy ( my_rho_g, tmp_g ,error=error) - CALL pw_derive ( tmp_g, nd(:,idir) ,error=error) - CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw ,error=error) + CALL pw_copy ( my_rho_g, tmp_g) + CALL pw_derive ( tmp_g, nd(:,idir)) + CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw) END DO IF(needs%laplace_rho.OR.needs%laplace_rho_spin) THEN DO idir=1,3 NULLIFY(laplace_rho_r(idir,ispin)%pw) CALL pw_pool_create_pw(pw_pool,laplace_rho_r(idir,ispin)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) - CALL pw_copy ( my_rho_g, tmp_g ,error=error) - CALL pw_derive ( tmp_g, nd_laplace(:,idir) ,error=error) - CALL pw_transfer ( tmp_g, laplace_rho_r(idir,ispin)%pw ,error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_copy ( my_rho_g, tmp_g) + CALL pw_derive ( tmp_g, nd_laplace(:,idir)) + CALL pw_transfer ( tmp_g, laplace_rho_r(idir,ispin)%pw) END DO END IF CASE (xc_deriv_spline2) IF (.NOT.my_rho_g_local) THEN CALL pw_pool_create_pw(pw_pool, my_rho_g,& - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) my_rho_g_local=.TRUE. - CALL pw_copy(rho_g(ispin)%pw, my_rho_g,error=error) + CALL pw_copy(rho_g(ispin)%pw, my_rho_g) END IF - CALL pw_spline2_interpolate_values_g(my_rho_g,error=error) + CALL pw_spline2_interpolate_values_g(my_rho_g) DO idir=1,3 - CALL pw_copy ( my_rho_g, tmp_g ,error=error) - CALL pw_spline2_deriv_g ( tmp_g, idir=idir, error=error ) - CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw ,error=error) + CALL pw_copy ( my_rho_g, tmp_g) + CALL pw_spline2_deriv_g ( tmp_g, idir=idir) + CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw) END DO CASE (xc_deriv_spline3) IF (.NOT.my_rho_g_local) THEN CALL pw_pool_create_pw(pw_pool, my_rho_g,& - use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE, & - error=error) - CALL pw_copy(rho_g(ispin)%pw, my_rho_g,error=error) + use_data=COMPLEXDATA1D, in_space=RECIPROCALSPACE) + CALL pw_copy(rho_g(ispin)%pw, my_rho_g) my_rho_g_local=.TRUE. END IF - CALL pw_spline3_interpolate_values_g(my_rho_g,error=error) + CALL pw_spline3_interpolate_values_g(my_rho_g) DO idir=1,3 - CALL pw_copy ( my_rho_g, tmp_g ,error=error) - CALL pw_spline3_deriv_g ( tmp_g, idir=idir, error=error ) - CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw ,error=error) + CALL pw_copy ( my_rho_g, tmp_g) + CALL pw_spline3_deriv_g ( tmp_g, idir=idir) + CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw) END DO CASE (xc_deriv_collocate) DO idir=1,3 - CALL pw_copy ( my_rho_g, tmp_g ,error=error) - CALL pw_derive ( tmp_g, nd(:,idir) ,error=error) - CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw ,error=error) + CALL pw_copy ( my_rho_g, tmp_g) + CALL pw_derive ( tmp_g, nd(:,idir)) + CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw) END DO CALL cp_unimplemented_error(fromWhere=routineP, & message="Drho collocation not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT - CALL pw_pool_give_back_pw(pw_pool, tmp_g ,error=error) + CALL pw_pool_give_back_pw(pw_pool, tmp_g) IF (my_rho_g_local) THEN my_rho_g_local=.FALSE. - CALL pw_pool_give_back_pw(pw_pool, my_rho_g ,error=error) + CALL pw_pool_give_back_pw(pw_pool, my_rho_g) END IF ELSE SELECT CASE(xc_deriv_method_id) CASE (xc_deriv_spline2_smooth) DO idir=1,3 - CALL pw_zero(drho_r(idir,ispin)%pw,error=error) + CALL pw_zero(drho_r(idir,ispin)%pw) CALL pw_nn_deriv_r(pw_in=my_rho_r(ispin)%pw,& pw_out=drho_r(idir,ispin)%pw,& - coeffs=spline2_deriv_coeffs, idir=idir, error=error) + coeffs=spline2_deriv_coeffs, idir=idir) END DO CASE (xc_deriv_spline3_smooth) DO idir=1,3 - CALL pw_zero(drho_r(idir,ispin)%pw,error=error) + CALL pw_zero(drho_r(idir,ispin)%pw) CALL pw_nn_deriv_r(pw_in=my_rho_r(ispin)%pw,& pw_out=drho_r(idir,ispin)%pw,& - coeffs=spline3_deriv_coeffs, idir=idir, error=error) + coeffs=spline3_deriv_coeffs, idir=idir) END DO CASE (xc_deriv_nn10_smooth) DO idir=1,3 - CALL pw_zero(drho_r(idir,ispin)%pw,error=error) + CALL pw_zero(drho_r(idir,ispin)%pw) CALL pw_nn_deriv_r(pw_in=my_rho_r(ispin)%pw,& pw_out=drho_r(idir,ispin)%pw,& - coeffs=nn10_deriv_coeffs, idir=idir, error=error) + coeffs=nn10_deriv_coeffs, idir=idir) END DO CASE (xc_deriv_nn50_smooth) DO idir=1,3 - CALL pw_zero(drho_r(idir,ispin)%pw,error=error) + CALL pw_zero(drho_r(idir,ispin)%pw) CALL pw_nn_deriv_r(pw_in=my_rho_r(ispin)%pw,& pw_out=drho_r(idir,ispin)%pw,& - coeffs=nn50_deriv_coeffs, idir=idir, error=error) + coeffs=nn50_deriv_coeffs, idir=idir) END DO CASE (xc_deriv_collocate) DO idir=1,3 - CALL pw_copy ( my_rho_g, tmp_g ,error=error) - CALL pw_derive ( tmp_g, nd(:,idir) ,error=error) - CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw ,error=error) + CALL pw_copy ( my_rho_g, tmp_g) + CALL pw_derive ( tmp_g, nd(:,idir)) + CALL pw_transfer ( tmp_g, drho_r(idir,ispin)%pw) END DO CALL cp_unimplemented_error(fromWhere=routineP, & message="Drho collocation not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) CASE default - CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + CPAssert(.FALSE.,cp_failure_level,routineP,failure) END SELECT END IF @@ -898,7 +870,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& DO idir=1,3 drho_r_att(idir)%pw => drho_r(idir,ispin)%pw END DO - CALL pw_spline_scale_deriv(drho_r_att, error=error) + CALL pw_spline_scale_deriv(drho_r_att) END IF END IF @@ -908,8 +880,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& SELECT CASE(nspins) CASE(1) IF (needs%rho_1_3) THEN - CALL pw_pool_create_cr3d(pw_pool, rho_set%rho_1_3, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%rho_1_3) !$omp parallel do default(none) private(i,j,k) shared(rho_set,my_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -928,8 +899,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& rho_set%has%rho=.TRUE. END IF IF (needs%norm_drho) THEN - CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drho, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drho) !$omp parallel do default(none) private(i,j,k) shared(rho_set,drho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -945,8 +915,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& rho_set%has%norm_drho=.TRUE. END IF IF (needs%laplace_rho) THEN - CALL pw_pool_create_cr3d(pw_pool, rho_set%laplace_rho, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%laplace_rho) !$omp parallel do default(none) private(i,j,k) shared(rho_set,laplace_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -975,7 +944,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& ! this should basically never be the case unless you use LDA functionals ! with LSD - CALL pw_pool_create_cr3d(pw_pool,rho_set%rho,error=error) + CALL pw_pool_create_cr3d(pw_pool,rho_set%rho) !assume that the bounds are the same? !$omp parallel do default(none) private(i,j,k) shared(rho_set,my_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) @@ -990,7 +959,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& rho_set%has%rho=.TRUE. END IF IF (needs%rho_1_3) THEN - CALL pw_pool_create_cr3d(pw_pool,rho_set%rho_1_3,error=error) + CALL pw_pool_create_cr3d(pw_pool,rho_set%rho_1_3) !assume that the bounds are the same? !$omp parallel do default(none) private(i,j,k) shared(rho_set,my_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) @@ -1005,7 +974,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& rho_set%has%rho_1_3=.TRUE. END IF IF (needs%rho_spin_1_3) THEN - CALL pw_pool_create_cr3d(pw_pool,rho_set%rhoa_1_3,error=error) + CALL pw_pool_create_cr3d(pw_pool,rho_set%rhoa_1_3) !assume that the bounds are the same? !$omp parallel do default(none) private(i,j,k) shared(rho_set,my_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) @@ -1015,7 +984,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& END DO END DO END DO - CALL pw_pool_create_cr3d(pw_pool,rho_set%rhob_1_3,error=error) + CALL pw_pool_create_cr3d(pw_pool,rho_set%rhob_1_3) !assume that the bounds are the same? !$omp parallel do default(none) private(i,j,k) shared(rho_set,my_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) @@ -1041,8 +1010,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& END IF IF (needs%norm_drho) THEN - CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drho, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drho) !$omp parallel do default(none) private(i,j,k) shared(rho_set,drho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -1060,8 +1028,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& END IF IF (needs%norm_drho_spin) THEN - CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drhoa, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drhoa) !$omp parallel do default(none) private(i,j,k) shared(rho_set,drho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -1074,8 +1041,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& END DO END DO - CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drhob, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%norm_drhob) rho_set%owns%norm_drho_spin=.TRUE. !$omp parallel do default(none) private(i,j,k) shared(rho_set,drho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) @@ -1093,8 +1059,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& rho_set%has%norm_drho_spin=.TRUE. END IF IF (needs%laplace_rho_spin) THEN - CALL pw_pool_create_cr3d(pw_pool, rho_set%laplace_rhoa, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%laplace_rhoa) !$omp parallel do default(none) private(i,j,k) shared(rho_set,laplace_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -1107,8 +1072,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& END DO END DO - CALL pw_pool_create_cr3d(pw_pool, rho_set%laplace_rhob, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%laplace_rhob) rho_set%owns%laplace_rho_spin=.TRUE. !$omp parallel do default(none) private(i,j,k) shared(rho_set,laplace_rho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) @@ -1126,8 +1090,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& rho_set%has%laplace_rho_spin=.TRUE. END IF IF (needs%drhoa_drhob) THEN - CALL pw_pool_create_cr3d(pw_pool, rho_set%drhoa_drhob, & - error=error) + CALL pw_pool_create_cr3d(pw_pool, rho_set%drhoa_drhob) !$omp parallel do default(none) private(i,j,k) shared(rho_set,drho_r) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -1146,8 +1109,7 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& ! this should basically never be the case unless you use LDA functionals ! with LSD DO idir=1,3 - CALL pw_pool_create_cr3d(pw_pool,rho_set%drho(idir)%array,& - error=error) + CALL pw_pool_create_cr3d(pw_pool,rho_set%drho(idir)%array) !assume that the bounds are the same? !$omp parallel do default(none) private(i,j,k) shared(rho_set,drho_r,idir) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) @@ -1179,31 +1141,30 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& DO idir=1,3 IF(needs%laplace_rho.OR.needs%laplace_rho_spin) THEN CALL pw_pool_give_back_pw(pw_pool, laplace_rho_r(idir,ispin)%pw, & - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) END IF CALL pw_pool_give_back_pw(pw_pool, drho_r(idir,ispin)%pw, & - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) END DO END DO IF (my_rho_r_local) THEN DO ispin=1,nspins CALL pw_pool_give_back_pw(pw_pool, my_rho_r(ispin)%pw,& - accept_non_compatible=.TRUE., error=error) + accept_non_compatible=.TRUE.) END DO END IF ! tau part IF (needs%tau.OR.needs%tau_spin) THEN - CPPrecondition(ASSOCIATED(tau),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tau),cp_failure_level,routineP,failure) DO ispin=1,nspins - CPPrecondition(ASSOCIATED(tau(ispin)%pw),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(tau(ispin)%pw%cr3d),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(tau(ispin)%pw),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(tau(ispin)%pw%cr3d),cp_failure_level,routineP,failure) END DO END IF IF (needs%tau) THEN IF (nspins==2) THEN - CALL pw_pool_create_cr3d(pw_pool,rho_set%tau,& - error=error) + CALL pw_pool_create_cr3d(pw_pool,rho_set%tau) !$omp parallel do default(none) private(i,j,k) shared(rho_set,tau) DO k=rho_set%local_bounds(1,3),rho_set%local_bounds(2,3) DO j=rho_set%local_bounds(1,2),rho_set%local_bounds(2,2) @@ -1224,14 +1185,14 @@ SUBROUTINE xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs,& rho_set%has%tau=.TRUE. END IF IF (needs%tau_spin) THEN - CPPrecondition(nspins==2,cp_failure_level,routineP,error,failure) + CPPrecondition(nspins==2,cp_failure_level,routineP,failure) rho_set%tau_a => tau(1)%pw%cr3d rho_set%tau_b => tau(2)%pw%cr3d rho_set%owns%tau_spin=.FALSE. rho_set%has%tau_spin=.TRUE. END IF - CPPostcondition(xc_rho_cflags_equal(rho_set%has,needs,error=error),cp_failure_level,routineP,error,failure) + CPPostcondition(xc_rho_cflags_equal(rho_set%has,needs),cp_failure_level,routineP,failure) END SUBROUTINE xc_rho_set_update diff --git a/src/xc/xc_tfw.F b/src/xc/xc_tfw.F index 0c1b1d27ac..e99ac99f9b 100644 --- a/src/xc/xc_tfw.F +++ b/src/xc/xc_tfw.F @@ -70,14 +70,12 @@ END SUBROUTINE tfw_init !> \param shortform ... !> \param needs ... !> \param max_deriv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_lda_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE tfw_lda_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "Thomas-Fermi-Weizsaecker kinetic energy functional {LDA version}" @@ -100,14 +98,12 @@ END SUBROUTINE tfw_lda_info !> \param shortform ... !> \param needs ... !> \param max_deriv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_lsd_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE tfw_lsd_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "Thomas-Fermi-Weizsaecker kinetic energy functional" @@ -129,13 +125,11 @@ END SUBROUTINE tfw_lsd_info !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_lda_eval (rho_set,deriv_set,order,error) + SUBROUTINE tfw_lda_eval (rho_set,deriv_set,order) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tfw_lda_eval', & routineP = moduleN//':'//routineN @@ -154,73 +148,72 @@ SUBROUTINE tfw_lda_eval (rho_set,deriv_set,order,error) failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=r13,rho=rho,& - norm_drho=grho,local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + norm_drho=grho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL tfw_init(epsilon_rho) ALLOCATE ( s(npoints), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL calc_s(rho,grho,s, npoints) IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) - CALL tfw_u_0 ( rho, r13, s, e_0, npoints, error ) + CALL tfw_u_0 ( rho, r13, s, e_0, npoints) END IF IF ( order>=1.OR.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) - CALL tfw_u_1 ( rho, grho, r13, s, e_rho, e_ndrho, npoints, error ) + CALL tfw_u_1 ( rho, grho, r13, s, e_rho, e_ndrho, npoints) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(rho)(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CALL tfw_u_2 ( rho, grho, r13, s, e_rho_rho, e_rho_ndrho,& - e_ndrho_ndrho, npoints, error ) + e_ndrho_ndrho, npoints) END IF IF ( order>=3.OR.order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho,error=error) + "(rho)(rho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,& - "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho,error=error) + "(rho)(norm_drho)(norm_drho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho) CALL tfw_u_3 ( rho, grho, r13, s, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, npoints, error ) + e_rho_ndrho_ndrho, npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DEALLOCATE ( s, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE tfw_lda_eval @@ -254,13 +247,11 @@ END SUBROUTINE calc_s !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_lsd_eval(rho_set,deriv_set,order,error) + SUBROUTINE tfw_lsd_eval(rho_set,deriv_set,order) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tfw_lsd_eval', & routineP = moduleN//':'//routineN @@ -288,85 +279,85 @@ SUBROUTINE tfw_lsd_eval(rho_set,deriv_set,order,error) NULLIFY(norm_drho(i)%array, rho(i)%array, rho_1_3(i)%array) END DO - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa_1_3=rho_1_3(1)%array,& rhob_1_3=rho_1_3(2)%array,rhoa=rho(1)%array,& rhob=rho(2)%array,norm_drhoa=norm_drho(1)%array, & norm_drhob=norm_drho(2)%array,rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL tfw_init(epsilon_rho) ALLOCATE ( s(npoints), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1,2 CALL calc_s(rho(ispin)%array, norm_drho(ispin)%array, s, npoints) IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) CALL tfw_p_0 ( rho(ispin)%array, & - rho_1_3(ispin)%array, s, e_0, npoints,error ) + rho_1_3(ispin)%array, s, e_0, npoints) END IF IF ( order>=1.OR.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) CALL tfw_p_1 ( rho(ispin)%array, norm_drho(ispin)%array, & - rho_1_3(ispin)%array, s, e_rho, e_ndrho, npoints,error ) + rho_1_3(ispin)%array, s, e_rho, e_ndrho, npoints) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - rho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + rho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - norm_drho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho,error=error) + norm_drho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,norm_drho_spin_name(ispin)//& - norm_drho_spin_name(ispin), allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + norm_drho_spin_name(ispin), allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) CALL tfw_p_2 ( rho(ispin)%array, norm_drho(ispin)%array, & rho_1_3(ispin)%array, s, e_rho_rho, e_rho_ndrho,& - e_ndrho_ndrho, npoints,error ) + e_ndrho_ndrho, npoints) END IF IF ( order>=3 .OR. order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//norm_drho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_ndrho) deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& norm_drho_spin_name(ispin)//norm_drho_spin_name(ispin), & - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_ndrho_ndrho) CALL tfw_p_3 ( rho(ispin)%array, norm_drho(ispin)%array, & rho_1_3(ispin)%array, s, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, npoints,error ) + e_rho_ndrho_ndrho, npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO DEALLOCATE ( s, STAT=stat ) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE tfw_lsd_eval @@ -377,15 +368,13 @@ END SUBROUTINE tfw_lsd_eval !> \param s ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_u_0 ( rho, r13, s, e_0, npoints, error ) + SUBROUTINE tfw_u_0 ( rho, r13, s, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13, s REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip @@ -412,15 +401,13 @@ END SUBROUTINE tfw_u_0 !> \param e_rho ... !> \param e_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_u_1 ( rho, grho, r13, s, e_rho, e_ndrho, npoints, error ) + SUBROUTINE tfw_u_1 ( rho, grho, r13, s, e_rho, e_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, r13, s REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho, e_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -452,17 +439,15 @@ END SUBROUTINE tfw_u_1 !> \param e_rho_ndrho ... !> \param e_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE tfw_u_2 ( rho, grho, r13, s, e_rho_rho, e_rho_ndrho, e_ndrho_ndrho,& - npoints, error) + npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, r13, s REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho, e_rho_ndrho, & e_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -495,10 +480,9 @@ END SUBROUTINE tfw_u_2 !> \param e_rho_rho_ndrho ... !> \param e_rho_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE tfw_u_3 ( rho, grho, r13, s, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, npoints, error) + e_rho_ndrho_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, grho, r13, s REAL(KIND=dp), DIMENSION(*), & @@ -506,7 +490,6 @@ SUBROUTINE tfw_u_3 ( rho, grho, r13, s, e_rho_rho_rho, e_rho_rho_ndrho,& e_rho_rho_ndrho, & e_rho_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -538,15 +521,13 @@ END SUBROUTINE tfw_u_3 !> \param sa ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_p_0 ( rhoa, r13a, sa, e_0, npoints, error ) + SUBROUTINE tfw_p_0 ( rhoa, r13a, sa, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, r13a, sa REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip @@ -571,16 +552,13 @@ END SUBROUTINE tfw_p_0 !> \param e_rho ... !> \param e_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE tfw_p_1 ( rhoa, grhoa, r13a, sa, e_rho, e_ndrho, npoints,& - error ) + SUBROUTINE tfw_p_1 ( rhoa, grhoa, r13a, sa, e_rho, e_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, grhoa, r13a, sa REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho, e_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -610,17 +588,15 @@ END SUBROUTINE tfw_p_1 !> \param e_rho_ndrho ... !> \param e_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE tfw_p_2 ( rhoa, grhoa, r13a, sa, e_rho_rho, e_rho_ndrho,& - e_ndrho_ndrho, npoints, error ) + e_ndrho_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, grhoa, r13a, sa REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho, e_rho_ndrho, & e_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -653,10 +629,9 @@ END SUBROUTINE tfw_p_2 !> \param e_rho_rho_ndrho ... !> \param e_rho_ndrho_ndrho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** SUBROUTINE tfw_p_3 ( rhoa, grhoa, r13a, sa, e_rho_rho_rho, e_rho_rho_ndrho,& - e_rho_ndrho_ndrho, npoints, error ) + e_rho_ndrho_ndrho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, grhoa, r13a, sa REAL(KIND=dp), DIMENSION(*), & @@ -664,7 +639,6 @@ SUBROUTINE tfw_p_3 ( rhoa, grhoa, r13a, sa, e_rho_rho_rho, e_rho_rho_ndrho,& e_rho_rho_ndrho, & e_rho_ndrho_ndrho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f diff --git a/src/xc/xc_thomas_fermi.F b/src/xc/xc_thomas_fermi.F index 33755247f3..c7564d7929 100644 --- a/src/xc/xc_thomas_fermi.F +++ b/src/xc/xc_thomas_fermi.F @@ -73,15 +73,13 @@ END SUBROUTINE thomas_fermi_init !> \param shortform ... !> \param needs ... !> \param max_deriv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_info ( lsd, reference, shortform, needs, max_deriv, error) + SUBROUTINE thomas_fermi_info ( lsd, reference, shortform, needs, max_deriv) LOGICAL, INTENT(in) :: lsd CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "Thomas-Fermi kinetic energy functional: see Parr and Yang" @@ -117,13 +115,11 @@ END SUBROUTINE thomas_fermi_info !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lda_eval(rho_set,deriv_set,order,error) + SUBROUTINE thomas_fermi_lda_eval(rho_set,deriv_set,order) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'thomas_fermi_lda_eval', & routineP = moduleN//':'//routineN @@ -141,49 +137,47 @@ SUBROUTINE thomas_fermi_lda_eval(rho_set,deriv_set,order,error) failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=r13,rho=rho,& - local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL thomas_fermi_init(epsilon_rho) IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) - CALL thomas_fermi_lda_0 ( rho, r13, e_0,npoints,error ) + CALL thomas_fermi_lda_0 ( rho, r13, e_0,npoints) END IF IF ( order>=1.OR.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) - CALL thomas_fermi_lda_1 ( rho, r13, e_rho, npoints, error ) + CALL thomas_fermi_lda_1 ( rho, r13, e_rho, npoints) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) - CALL thomas_fermi_lda_2 ( rho, r13, e_rho_rho, npoints, error ) + CALL thomas_fermi_lda_2 ( rho, r13, e_rho_rho, npoints) END IF IF ( order>=3.OR.order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) - CALL thomas_fermi_lda_3 ( rho, r13, e_rho_rho_rho, npoints,& - error) + CALL thomas_fermi_lda_3 ( rho, r13, e_rho_rho_rho, npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL timestop(handle) END SUBROUTINE thomas_fermi_lda_eval @@ -193,13 +187,11 @@ END SUBROUTINE thomas_fermi_lda_eval !> \param rho_set ... !> \param deriv_set ... !> \param order ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lsd_eval(rho_set,deriv_set,order,error) + SUBROUTINE thomas_fermi_lsd_eval(rho_set,deriv_set,order) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'thomas_fermi_lsd_eval', & routineP = moduleN//':'//routineN @@ -223,57 +215,57 @@ SUBROUTINE thomas_fermi_lsd_eval(rho_set,deriv_set,order,error) NULLIFY(rho(i)%array, rho_1_3(i)%array) END DO - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa_1_3=rho_1_3(1)%array,& rhob_1_3=rho_1_3(2)%array,rhoa=rho(1)%array,& rhob=rho(2)%array,& rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL thomas_fermi_init(epsilon_rho) DO ispin=1,2 IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) CALL thomas_fermi_lsd_0 ( rho(ispin)%array, rho_1_3(ispin)%array,& - e_0, npoints, error ) + e_0, npoints) END IF IF ( order>=1.OR.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) CALL thomas_fermi_lsd_1( rho(ispin)%array, rho_1_3(ispin)%array,& - e_rho, npoints, error ) + e_rho, npoints) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - rho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + rho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) CALL thomas_fermi_lsd_2( rho(ispin)%array, rho_1_3(ispin)%array,& - e_rho_rho, npoints, error ) + e_rho_rho, npoints) END IF IF ( order>=3 .OR. order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) CALL thomas_fermi_lsd_3( rho(ispin)%array, rho_1_3(ispin)%array,& - e_rho_rho_rho, npoints, error ) + e_rho_rho_rho, npoints) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO CALL timestop(handle) @@ -285,15 +277,13 @@ END SUBROUTINE thomas_fermi_lsd_eval !> \param r13 ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lda_0 ( rho, r13, e_0, npoints, error ) + SUBROUTINE thomas_fermi_lda_0 ( rho, r13, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13 REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip @@ -317,15 +307,13 @@ END SUBROUTINE thomas_fermi_lda_0 !> \param r13 ... !> \param e_rho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lda_1 ( rho, r13, e_rho, npoints, error ) + SUBROUTINE thomas_fermi_lda_1 ( rho, r13, e_rho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13 REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -352,15 +340,13 @@ END SUBROUTINE thomas_fermi_lda_1 !> \param r13 ... !> \param e_rho_rho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lda_2 ( rho, r13, e_rho_rho, npoints, error ) + SUBROUTINE thomas_fermi_lda_2 ( rho, r13, e_rho_rho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13 REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -387,15 +373,13 @@ END SUBROUTINE thomas_fermi_lda_2 !> \param r13 ... !> \param e_rho_rho_rho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lda_3 ( rho, r13, e_rho_rho_rho, npoints, error ) + SUBROUTINE thomas_fermi_lda_3 ( rho, r13, e_rho_rho_rho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, r13 REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho_rho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -422,15 +406,13 @@ END SUBROUTINE thomas_fermi_lda_3 !> \param r13a ... !> \param e_0 ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lsd_0 ( rhoa, r13a, e_0, npoints, error ) + SUBROUTINE thomas_fermi_lsd_0 ( rhoa, r13a, e_0, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, r13a REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip @@ -452,15 +434,13 @@ END SUBROUTINE thomas_fermi_lsd_0 !> \param r13a ... !> \param e_rho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lsd_1 ( rhoa, r13a, e_rho, npoints, error ) + SUBROUTINE thomas_fermi_lsd_1 ( rhoa, r13a, e_rho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, r13a REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -485,15 +465,13 @@ END SUBROUTINE thomas_fermi_lsd_1 !> \param r13a ... !> \param e_rho_rho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lsd_2 ( rhoa, r13a, e_rho_rho, npoints, error ) + SUBROUTINE thomas_fermi_lsd_2 ( rhoa, r13a, e_rho_rho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, r13a REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f @@ -519,15 +497,13 @@ END SUBROUTINE thomas_fermi_lsd_2 !> \param r13a ... !> \param e_rho_rho_rho ... !> \param npoints ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE thomas_fermi_lsd_3 ( rhoa, r13a, e_rho_rho_rho, npoints, error ) + SUBROUTINE thomas_fermi_lsd_3 ( rhoa, r13a, e_rho_rho_rho, npoints) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rhoa, r13a REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho_rho INTEGER, INTENT(in) :: npoints - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: f diff --git a/src/xc/xc_tpss.F b/src/xc/xc_tpss.F index 5878ca6778..261e7503af 100644 --- a/src/xc/xc_tpss.F +++ b/src/xc/xc_tpss.F @@ -50,25 +50,22 @@ MODULE xc_tpss !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv the highest derivative available -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE tpss_lda_info(tpss_params,reference,shortform, needs, max_deriv, error) + SUBROUTINE tpss_lda_info(tpss_params,reference,shortform, needs, max_deriv) TYPE(section_vals_type), POINTER :: tpss_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tpss_lda_info', & routineP = moduleN//':'//routineN REAL(kind=dp) :: sc, sx - CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=sc,error=error) - CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=sx,error=error) + CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=sc) + CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=sx) IF ( PRESENT ( reference ) ) THEN IF (sx==1._dp.AND.sc==1._dp) THEN @@ -105,25 +102,22 @@ END SUBROUTINE tpss_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv the highest derivative available -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE tpss_lsd_info(tpss_params,reference,shortform, needs, max_deriv, error) + SUBROUTINE tpss_lsd_info(tpss_params,reference,shortform, needs, max_deriv) TYPE(section_vals_type), POINTER :: tpss_params CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tpss_lsd_info', & routineP = moduleN//':'//routineN REAL(kind=dp) :: sc, sx - CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=sc,error=error) - CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=sx,error=error) + CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=sc) + CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=sx) IF ( PRESENT ( reference ) ) THEN IF (sx==1._dp.AND.sc==1._dp) THEN @@ -162,16 +156,13 @@ END SUBROUTINE tpss_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param tpss_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE tpss_lda_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) + SUBROUTINE tpss_lda_eval(rho_set,deriv_set,grad_deriv,tpss_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: tpss_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tpss_lda_eval', & routineP = moduleN//':'//routineN @@ -194,21 +185,20 @@ SUBROUTINE tpss_lda_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) CALL cite_reference(tao2003) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - tau=tau,tau_cutoff=epsilon_tau,& - error=error) + tau=tau,tau_cutoff=epsilon_tau) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -220,44 +210,44 @@ SUBROUTINE tpss_lda_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(tau)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF non_coer = 0 - CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=scale_ec,error=error) - CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=scale_ex,error=error) + CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=scale_ec) + CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=scale_ex) !$omp parallel default(none) & !$omp shared(rho, tau, norm_drho, e_0, e_rho, e_ndrho, e_tau) & !$omp shared(epsilon_rho, epsilon_tau, npoints, grad_deriv) & - !$omp shared(scale_ec, scale_ex, error) & + !$omp shared(scale_ec, scale_ex) & !$omp reduction(+: non_coer) CALL tpss_lda_calc(rho=rho, norm_drho=norm_drho,& tau=tau,e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,e_tau=e_tau,& grad_deriv=grad_deriv, npoints=npoints,epsilon_rho=epsilon_rho,& - epsilon_tau=epsilon_tau,scale_ec=scale_ec,scale_ex=scale_ex,non_coer=non_coer,error=error) + epsilon_tau=epsilon_tau,scale_ec=scale_ec,scale_ex=scale_ex,non_coer=non_coer) !$omp end parallel - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (cp_debug) THEN unit_nr=cp_logger_get_default_io_unit(logger) @@ -272,7 +262,7 @@ SUBROUTINE tpss_lda_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -288,16 +278,13 @@ END SUBROUTINE tpss_lda_eval !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param tpss_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi ! ***************************************************************************** - SUBROUTINE tpss_lsd_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) + SUBROUTINE tpss_lsd_eval(rho_set,deriv_set,grad_deriv,tpss_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: tpss_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tpss_lsd_eval', & routineP = moduleN//':'//routineN @@ -320,20 +307,20 @@ SUBROUTINE tpss_lsd_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) CALL cite_reference(tao2003) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=rhoa,rhob=rhob,norm_drhoa=norm_drhoa,& norm_drhob=norm_drhob,norm_drho=norm_drho,tau_a=tau_a,tau_b=tau_b,& - local_bounds=bo,rho_cutoff=epsilon_rho,tau_cutoff=epsilon_tau,error=error) + local_bounds=bo,rho_cutoff=epsilon_rho,tau_cutoff=epsilon_tau) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -349,48 +336,48 @@ SUBROUTINE tpss_lsd_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) deriv => xc_dset_get_derivative(deriv_set,"(tau_a)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_a,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_a) deriv => xc_dset_get_derivative(deriv_set,"(tau_b)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_b,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_b) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF non_coer = 0 - CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=scale_ec,error=error) - CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=scale_ex,error=error) + CALL section_vals_val_get(tpss_params,"SCALE_C",r_val=scale_ec) + CALL section_vals_val_get(tpss_params,"SCALE_X",r_val=scale_ex) !$omp parallel default(none) & !$omp shared(rhoa, rhob,norm_drhoa, norm_drhob, norm_drho) & !$omp shared(tau_a, tau_b, e_0, e_rhoa, e_rhob, e_ndrhoa) & !$omp shared(e_ndrhob, e_ndrho, e_tau_a, e_tau_b, npoints) & !$omp shared(grad_deriv, epsilon_rho) & - !$omp shared(epsilon_tau, scale_ec, scale_ex, error) & + !$omp shared(epsilon_tau, scale_ec, scale_ex) & !$omp reduction(+: non_coer) CALL tpss_lsd_calc(rhoa=rhoa,rhob=rhob, norm_drhoa=norm_drhoa, & @@ -400,11 +387,11 @@ SUBROUTINE tpss_lsd_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) e_tau_a=e_tau_a,e_tau_b=e_tau_b,& grad_deriv=grad_deriv, npoints=npoints,epsilon_rho=epsilon_rho,& epsilon_tau=epsilon_tau,& - scale_ec=scale_ec,scale_ex=scale_ex,non_coer=non_coer,error=error) + scale_ec=scale_ec,scale_ex=scale_ex,non_coer=non_coer) !$omp end parallel - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() IF (cp_debug) THEN unit_nr=cp_logger_get_default_io_unit(logger) @@ -419,7 +406,7 @@ SUBROUTINE tpss_lsd_eval(rho_set,deriv_set,grad_deriv,tpss_params,error) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -442,8 +429,6 @@ END SUBROUTINE tpss_lsd_eval !> \param scale_ec ... !> \param scale_ex ... !> \param non_coer ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> maple is nice, but if you want the uman readable version of the code @@ -451,7 +436,7 @@ END SUBROUTINE tpss_lsd_eval ! ***************************************************************************** SUBROUTINE tpss_lda_calc(rho,norm_drho,tau,e_0,e_rho,e_ndrho,e_tau,& npoints,grad_deriv,epsilon_rho,epsilon_tau,& - scale_ec,scale_ex,non_coer,error) + scale_ec,scale_ex,non_coer) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rho, norm_drho, tau REAL(kind=dp), DIMENSION(*), & INTENT(inout) :: e_0, e_rho, e_ndrho, e_tau @@ -459,7 +444,6 @@ SUBROUTINE tpss_lda_calc(rho,norm_drho,tau,e_0,e_rho,e_ndrho,e_tau,& REAL(kind=dp), INTENT(in) :: epsilon_rho, epsilon_tau, & scale_ec, scale_ex INTEGER, INTENT(inout) :: non_coer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tpss_lda_calc', & routineP = moduleN//':'//routineN @@ -994,8 +978,6 @@ END SUBROUTINE tpss_lda_calc !> \param scale_ec ... !> \param scale_ex ... !> \param non_coer ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author fawzi !> \note !> maple is nice, but if you want the uman readable version of the code @@ -1004,7 +986,7 @@ END SUBROUTINE tpss_lda_calc SUBROUTINE tpss_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob, norm_drho,& tau_a,tau_b,e_0,e_rhoa,e_rhob,e_ndrhoa,e_ndrhob,e_ndrho,e_tau_a,e_tau_b,& npoints,grad_deriv,epsilon_rho,epsilon_tau,& - scale_ec,scale_ex,non_coer,error) + scale_ec,scale_ex,non_coer) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rhoa, rhob, norm_drhoa, & norm_drhob, norm_drho, tau_a, & tau_b @@ -1016,7 +998,6 @@ SUBROUTINE tpss_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob, norm_drho,& REAL(kind=dp), INTENT(in) :: epsilon_rho, epsilon_tau, & scale_ec, scale_ex INTEGER, INTENT(inout) :: non_coer - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'tpss_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_vwn.F b/src/xc/xc_vwn.F index 7a7861d013..9154393da3 100644 --- a/src/xc/xc_vwn.F +++ b/src/xc/xc_vwn.F @@ -59,13 +59,11 @@ MODULE xc_vwn !> \brief ... !> \param cutoff ... !> \param vwn_params ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_init ( cutoff, vwn_params, error ) + SUBROUTINE vwn_init ( cutoff, vwn_params) REAL(KIND=dp), INTENT(IN) :: cutoff TYPE(section_vals_type), POINTER :: vwn_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'vwn_init', & routineP = moduleN//':'//routineN @@ -73,7 +71,7 @@ SUBROUTINE vwn_init ( cutoff, vwn_params, error ) INTEGER :: TYPE LOGICAL :: failure - CALL section_vals_val_get(vwn_params,"functional_type",i_val=TYPE,error=error) + CALL section_vals_val_get(vwn_params,"functional_type",i_val=TYPE) eps_rho = cutoff CALL set_util ( cutoff ) @@ -103,7 +101,7 @@ SUBROUTINE vwn_init ( cutoff, vwn_params, error ) CASE DEFAULT failure = .FALSE. CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& - " Only functionals VWN3 and VWN5 are supported" ,error,failure) + " Only functionals VWN3 and VWN5 are supported",failure) END SELECT @@ -115,14 +113,12 @@ END SUBROUTINE vwn_init !> \param shortform ... !> \param needs ... !> \param max_deriv ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lda_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE vwn_lda_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "S. H. Vosko, L. Wilk and M. Nusair,"// & @@ -144,14 +140,12 @@ END SUBROUTINE vwn_lda_info !> \param deriv_set ... !> \param order ... !> \param vwn_params ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lda_eval(rho_set,deriv_set,order,vwn_params,error) + SUBROUTINE vwn_lda_eval(rho_set,deriv_set,order,vwn_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order TYPE(section_vals_type), POINTER :: vwn_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vwn_lda_eval', & routineP = moduleN//':'//routineN @@ -170,67 +164,65 @@ SUBROUTINE vwn_lda_eval(rho_set,deriv_set,order,vwn_params,error) failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(vwn_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(vwn_params,"scale_c",r_val=sc) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) - CALL vwn_init(epsilon_rho, vwn_params, error) + CALL vwn_init(epsilon_rho, vwn_params) ALLOCATE ( x(npoints), STAT=stat ) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) CALL calc_srs_pw ( rho, x, npoints ) IF (order>=1) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) - CALL vwn_lda_01 ( rho, x, e_0,e_rho,npoints, sc, error ) + CALL vwn_lda_01 ( rho, x, e_0,e_rho,npoints, sc) ELSEIF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) - CALL vwn_lda_0 ( rho, x, e_0, npoints, sc, error ) + CALL vwn_lda_0 ( rho, x, e_0, npoints, sc) ELSEIF ( order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) - CALL vwn_lda_1 ( rho, x, e_rho, npoints, sc, error ) + CALL vwn_lda_1 ( rho, x, e_rho, npoints, sc) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) - CALL vwn_lda_2 ( rho, x, e_rho_rho, npoints, sc, error ) + CALL vwn_lda_2 ( rho, x, e_rho_rho, npoints, sc) END IF IF ( order>=3.OR.order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) - CALL vwn_lda_3 ( rho, x, e_rho_rho_rho, npoints, sc,& - error) + CALL vwn_lda_3 ( rho, x, e_rho_rho_rho, npoints, sc) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DEALLOCATE(x,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) CALL timestop(handle) END SUBROUTINE vwn_lda_eval @@ -242,16 +234,14 @@ END SUBROUTINE vwn_lda_eval !> \param e_0 ... !> \param npoints ... !> \param sc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lda_0 ( rho, x, e_0, npoints, sc, error ) + SUBROUTINE vwn_lda_0 ( rho, x, e_0, npoints, sc) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, x REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0 INTEGER, INTENT(in) :: npoints REAL(KIND=dp) :: sc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: at, dpx, ln1, ln2, px, px0, & @@ -290,16 +280,14 @@ END SUBROUTINE vwn_lda_0 !> \param e_rho ... !> \param npoints ... !> \param sc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lda_1 ( rho, x, e_rho, npoints, sc, error ) + SUBROUTINE vwn_lda_1 ( rho, x, e_rho, npoints, sc) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, x REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho INTEGER, INTENT(in) :: npoints REAL(KIND=dp) :: sc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: at, dat, dex, dln1, dln2, & @@ -346,16 +334,14 @@ END SUBROUTINE vwn_lda_1 !> \param e_rho ... !> \param npoints ... !> \param sc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lda_01 ( rho, x, e_0, e_rho, npoints, sc, error ) + SUBROUTINE vwn_lda_01 ( rho, x, e_0, e_rho, npoints, sc) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, x REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_0, e_rho INTEGER, INTENT(in) :: npoints REAL(KIND=dp) :: sc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: at, dat, dex, dln1, dln2, & @@ -402,16 +388,14 @@ END SUBROUTINE vwn_lda_01 !> \param e_rho_rho ... !> \param npoints ... !> \param sc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lda_2 ( rho, x, e_rho_rho, npoints, sc, error ) + SUBROUTINE vwn_lda_2 ( rho, x, e_rho_rho, npoints, sc) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, x REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho INTEGER, INTENT(in) :: npoints REAL(KIND=dp) :: sc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: at, d2at, d2ex, d2ln1, d2ln2, & @@ -464,16 +448,14 @@ END SUBROUTINE vwn_lda_2 !> \param e_rho_rho_rho ... !> \param npoints ... !> \param sc ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lda_3 ( rho, x, e_rho_rho_rho, npoints, sc, error ) + SUBROUTINE vwn_lda_3 ( rho, x, e_rho_rho_rho, npoints, sc) REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, x REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: e_rho_rho_rho INTEGER, INTENT(in) :: npoints REAL(KIND=dp) :: sc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: at, ax, bx, cx, d2at, d2bx, d2dx, d2ex, d2ln1, d2ln2, & @@ -536,14 +518,12 @@ END SUBROUTINE vwn_lda_3 !> \param deriv_set ... !> \param order ... !> \param vwn_params ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE vwn_lsd_eval(rho_set,deriv_set,order,vwn_params,error) + SUBROUTINE vwn_lsd_eval(rho_set,deriv_set,order,vwn_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order TYPE(section_vals_type), POINTER :: vwn_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'vwn_lsd_eval', & routineP = moduleN//':'//routineN @@ -562,21 +542,20 @@ SUBROUTINE vwn_lsd_eval(rho_set,deriv_set,order,vwn_params,error) failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(vwn_params,"scale_c",r_val=sc,error=error) + CALL section_vals_val_get(vwn_params,"scale_c",r_val=sc) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=rhoa,rhob=rhob,& - local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) - CALL vwn_init(epsilon_rho, vwn_params, error) + CALL vwn_init(epsilon_rho, vwn_params) IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -594,63 +573,63 @@ SUBROUTINE vwn_lsd_eval(rho_set,deriv_set,order,vwn_params,error) IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_a,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_a) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_b,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_b) END IF IF (order>=2.OR.order==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_aa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_aa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_bb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_bb) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ab,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ab) END IF IF (order>=3.OR.order==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_aaa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_aaa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_bbb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_bbb) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_aab,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_aab) deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_abb,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_abb) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_val_get(vwn_params,"functional_type",i_val=TYPE,error=error) + CALL section_vals_val_get(vwn_params,"functional_type",i_val=TYPE) SELECT CASE(TYPE) CASE(do_vwn3) !$omp parallel default(none) & !$omp shared(rhoa, rhob, e_0, e_a, e_b, e_aa, e_bb, e_ab) & !$omp shared(e_aaa, e_bbb, e_aab, e_abb, order, npoints) & - !$omp shared(sc, error) + !$omp shared(sc) CALL vwn3_lsd_calc(& rhoa=rhoa, rhob=rhob, e_0=e_0, & @@ -658,7 +637,7 @@ SUBROUTINE vwn_lsd_eval(rho_set,deriv_set,order,vwn_params,error) e_aa=e_aa, e_bb=e_bb,e_ab=e_ab,& e_aaa=e_aaa, e_bbb=e_bbb, e_aab=e_aab, e_abb=e_abb,& order=order, npoints=npoints, & - sc=sc, error=error) + sc=sc) !$omp end parallel @@ -667,7 +646,7 @@ SUBROUTINE vwn_lsd_eval(rho_set,deriv_set,order,vwn_params,error) !$omp parallel default(none) & !$omp shared(rhoa, rhob, e_0, e_a, e_b, e_aa, e_bb, e_ab) & !$omp shared(e_aaa, e_bbb, e_aab, e_abb, order, npoints) & - !$omp shared(sc, error) + !$omp shared(sc) CALL vwn5_lsd_calc(& rhoa=rhoa, rhob=rhob, e_0=e_0, & @@ -675,19 +654,19 @@ SUBROUTINE vwn_lsd_eval(rho_set,deriv_set,order,vwn_params,error) e_aa=e_aa, e_bb=e_bb,e_ab=e_ab,& e_aaa=e_aaa, e_bbb=e_bbb, e_aab=e_aab, e_abb=e_abb,& order=order, npoints=npoints, & - sc=sc, error=error) + sc=sc) !$omp end parallel CASE DEFAULT failure = .FALSE. CALL cp_assert( .FALSE. , cp_failure_level,cp_assertion_failed,routineP,& - " Only functionals VWN3 and VWN5 are supported" ,error,failure) + " Only functionals VWN3 and VWN5 are supported",failure) END SELECT IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -713,10 +692,9 @@ END SUBROUTINE vwn_lsd_eval !> \param order ... !> \param npoints ... !> \param sc ... -!> \param error ... ! ***************************************************************************** SUBROUTINE vwn3_lsd_calc ( rhoa, rhob, e_0, e_a, e_b, e_aa, e_bb, e_ab,& - e_aaa, e_bbb, e_aab, e_abb, order, npoints, sc, error ) + e_aaa, e_bbb, e_aab, e_abb, order, npoints, sc) REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: rhoa, rhob, e_0, e_a, e_b, & @@ -724,7 +702,6 @@ SUBROUTINE vwn3_lsd_calc ( rhoa, rhob, e_0, e_a, e_b, e_aa, e_bb, e_ab,& e_bbb, e_aab, e_abb INTEGER, INTENT(in) :: order, npoints REAL(KIND=dp) :: sc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: ap, bp, cp, myrho, myrhoa, myrhob, Qf, Qp, t1, t10, & @@ -1279,10 +1256,9 @@ END SUBROUTINE vwn3_lsd_calc !> \param order ... !> \param npoints ... !> \param sc ... -!> \param error ... ! ***************************************************************************** SUBROUTINE vwn5_lsd_calc ( rhoa, rhob, e_0, e_a, e_b, e_aa, e_bb, e_ab,& - e_aaa, e_bbb, e_aab, e_abb, order, npoints, sc, error ) + e_aaa, e_bbb, e_aab, e_abb, order, npoints, sc) REAL(KIND=dp), DIMENSION(*), & INTENT(INOUT) :: rhoa, rhob, e_0, e_a, e_b, & @@ -1290,7 +1266,6 @@ SUBROUTINE vwn5_lsd_calc ( rhoa, rhob, e_0, e_a, e_b, e_aa, e_bb, e_ab,& e_bbb, e_aab, e_abb INTEGER, INTENT(in) :: order, npoints REAL(KIND=dp) :: sc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: ip REAL(KIND=dp) :: ap, bp, cp, d2f0, myrho, myrhoa, myrhob, Qa, Qf, Qp, t1, & diff --git a/src/xc/xc_xalpha.F b/src/xc/xc_xalpha.F index 740675a4f3..703c40ebfc 100644 --- a/src/xc/xc_xalpha.F +++ b/src/xc/xc_xalpha.F @@ -82,17 +82,15 @@ END SUBROUTINE xalpha_init !> \param max_deriv ... !> \param xa_parameter ... !> \param scaling ... -!> \param error ... ! ***************************************************************************** SUBROUTINE xalpha_info ( lsd, reference, shortform, needs, max_deriv, & - xa_parameter,scaling,error) + xa_parameter,scaling) LOGICAL, INTENT(in) :: lsd CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv REAL(KIND=dp), INTENT(in), OPTIONAL :: xa_parameter, scaling - TYPE(cp_error_type), INTENT(inout) :: error REAL(KIND=dp) :: my_scaling, my_xparam @@ -147,15 +145,13 @@ END SUBROUTINE xalpha_info !> \param order ... !> \param xa_params ... !> \param xa_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xalpha_lda_eval(rho_set,deriv_set,order,xa_params,xa_parameter,error) + SUBROUTINE xalpha_lda_eval(rho_set,deriv_set,order,xa_params,xa_parameter) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order TYPE(section_vals_type), POINTER :: xa_params REAL(KIND=dp), INTENT(in), OPTIONAL :: xa_parameter - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xalpha_lda_eval', & routineP = moduleN//':'//routineN @@ -173,51 +169,50 @@ SUBROUTINE xalpha_lda_eval(rho_set,deriv_set,order,xa_params,xa_parameter,error) failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(xa_params,"scale_x",r_val=sx,error=error) + CALL section_vals_val_get(xa_params,"scale_x",r_val=sx) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=r13,rho=rho,& - local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL xalpha_init(epsilon_rho,xa_parameter) IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) CALL xalpha_lda_0 ( npoints, rho, r13, e_0, sx ) END IF IF ( order>=1.OR.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) CALL xalpha_lda_1 ( npoints, rho, r13, e_rho, sx ) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) CALL xalpha_lda_2 ( npoints, rho, r13, e_rho_rho, sx ) END IF IF ( order>=3.OR.order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) CALL xalpha_lda_3 ( npoints, rho, r13, e_rho_rho_rho, sx ) END IF IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL timestop(handle) @@ -230,15 +225,13 @@ END SUBROUTINE xalpha_lda_eval !> \param order ... !> \param xa_params ... !> \param xa_parameter ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xalpha_lsd_eval (rho_set,deriv_set,order,xa_params,xa_parameter,error) + SUBROUTINE xalpha_lsd_eval (rho_set,deriv_set,order,xa_params,xa_parameter) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: order TYPE(section_vals_type), POINTER :: xa_params REAL(KIND=dp), INTENT(in), OPTIONAL :: xa_parameter - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xalpha_lsd_eval', & routineP = moduleN//':'//routineN @@ -262,40 +255,40 @@ SUBROUTINE xalpha_lsd_eval (rho_set,deriv_set,order,xa_params,xa_parameter,error NULLIFY(rho(i)%array, rho_1_3(i)%array) END DO - CALL section_vals_val_get(xa_params,"scale_x",r_val=sx,error=error) + CALL section_vals_val_get(xa_params,"scale_x",r_val=sx) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa_1_3=rho_1_3(1)%array,& rhob_1_3=rho_1_3(2)%array,rhoa=rho(1)%array,& rhob=rho(2)%array, rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) CALL xalpha_init(epsilon_rho,xa_parameter) DO ispin=1,2 IF ( order>=0 ) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) CALL xalpha_lsd_0 ( npoints,rho(ispin)%array, rho_1_3(ispin)%array,& e_0, sx ) END IF IF ( order>=1.OR.order==-1 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) CALL xalpha_lsd_1( npoints, rho(ispin)%array, rho_1_3(ispin)%array,& e_rho, sx ) END IF IF ( order>=2.OR.order==-2 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& - rho_spin_name(ispin),allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + rho_spin_name(ispin),allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) CALL xalpha_lsd_2( npoints, rho(ispin)%array, rho_1_3(ispin)%array,& e_rho_rho, sx ) @@ -303,8 +296,8 @@ SUBROUTINE xalpha_lsd_eval (rho_set,deriv_set,order,xa_params,xa_parameter,error IF ( order>=3 .OR. order==-3 ) THEN deriv => xc_dset_get_derivative(deriv_set,rho_spin_name(ispin)//& rho_spin_name(ispin)//rho_spin_name(ispin),& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) CALL xalpha_lsd_3( npoints, rho(ispin)%array, rho_1_3(ispin)%array,& e_rho_rho_rho, sx ) @@ -312,7 +305,7 @@ SUBROUTINE xalpha_lsd_eval (rho_set,deriv_set,order,xa_params,xa_parameter,error IF ( order>3.OR.order<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF END DO CALL timestop(handle) diff --git a/src/xc/xc_xbecke88.F b/src/xc/xc_xbecke88.F index 1c6dfae0b8..dfb573f677 100644 --- a/src/xc/xc_xbecke88.F +++ b/src/xc/xc_xbecke88.F @@ -45,18 +45,15 @@ MODULE xc_xbecke88 !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE xb88_lda_info(reference,shortform, needs, max_deriv,error) + SUBROUTINE xb88_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lda_info', & routineP = moduleN//':'//routineN @@ -83,18 +80,15 @@ END SUBROUTINE xb88_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> \author fawzi ! ***************************************************************************** - SUBROUTINE xb88_lsd_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE xb88_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lsd_info', & routineP = moduleN//':'//routineN @@ -123,19 +117,16 @@ END SUBROUTINE xb88_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param xb88_params input parameters (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> 01.2007 added scaling [Manuel Guidon] !> \author fawzi ! ***************************************************************************** - SUBROUTINE xb88_lda_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) + SUBROUTINE xb88_lda_eval(rho_set,deriv_set,grad_deriv,xb88_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xb88_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lda_eval', & routineP = moduleN//':'//routineN @@ -154,24 +145,23 @@ SUBROUTINE xb88_lda_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(xb88_params,"scale_x",r_val=sx,error=error) + CALL section_vals_val_get(xb88_params,"scale_x",r_val=sx) CALL cite_reference(Becke1988) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=rho_1_3,rho=rho,& - norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -189,47 +179,46 @@ SUBROUTINE xb88_lda_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho,error=error) + "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho,error=error) + "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & @@ -238,7 +227,7 @@ SUBROUTINE xb88_lda_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) !$omp shared(e_ndrho_ndrho, e_rho_rho_rho) & !$omp shared(e_ndrho_rho_rho, e_ndrho_ndrho_rho) & !$omp shared(e_ndrho_ndrho_ndrho, grad_deriv, npoints) & - !$omp shared(epsilon_rho, sx, error) + !$omp shared(epsilon_rho, sx) CALL xb88_lda_calc(rho=rho, rho_1_3=rho_1_3, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,e_rho_rho=e_rho_rho,& @@ -246,13 +235,13 @@ SUBROUTINE xb88_lda_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) e_rho_rho_rho=e_rho_rho_rho, e_ndrho_rho_rho=e_ndrho_rho_rho,& e_ndrho_ndrho_rho=e_ndrho_ndrho_rho,& e_ndrho_ndrho_ndrho=e_ndrho_ndrho_ndrho,grad_deriv=grad_deriv,& - npoints=npoints,epsilon_rho=epsilon_rho,sx=sx,error=error) + npoints=npoints,epsilon_rho=epsilon_rho,sx=sx) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -280,8 +269,6 @@ END SUBROUTINE xb88_lda_eval !> \param npoints ... !> \param epsilon_rho ... !> \param sx scaling-parameter for exchange -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> 01.2007 added scaling [Manuel Guidon] @@ -290,7 +277,7 @@ END SUBROUTINE xb88_lda_eval SUBROUTINE xb88_lda_calc(rho, rho_1_3, norm_drho,& e_0,e_rho,e_ndrho,e_rho_rho,e_ndrho_rho,& e_ndrho_ndrho, e_rho_rho_rho, e_ndrho_rho_rho, e_ndrho_ndrho_rho,& - e_ndrho_ndrho_ndrho,grad_deriv,npoints,epsilon_rho,sx,error) + e_ndrho_ndrho_ndrho,grad_deriv,npoints,epsilon_rho,sx) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), INTENT(inout) :: & e_ndrho_ndrho_ndrho, e_ndrho_ndrho_rho, e_ndrho_rho_rho, e_rho_rho_rho, & @@ -298,7 +285,6 @@ SUBROUTINE xb88_lda_calc(rho, rho_1_3, norm_drho,& REAL(kind=dp), DIMENSION(1:npoints), & INTENT(in) :: norm_drho, rho_1_3, rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lda_calc', & routineP = moduleN//':'//routineN @@ -675,19 +661,16 @@ END SUBROUTINE xb88_lda_calc !> \param deriv_set ... !> \param grad_deriv ... !> \param xb88_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 11.2003 created [fawzi] !> 01.2007 added scaling [Manuel Guidon] !> \author fawzi ! ***************************************************************************** - SUBROUTINE xb88_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) + SUBROUTINE xb88_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xb88_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lsd_eval', & routineP = moduleN//':'//routineN @@ -714,23 +697,23 @@ SUBROUTINE xb88_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) NULLIFY(norm_drho(i)%array, rho(i)%array, rho_1_3(i)%array) END DO - CALL section_vals_val_get(xb88_params,"scale_x",r_val=sx,error=error) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(xb88_params,"scale_x",r_val=sx) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa_1_3=rho_1_3(1)%array,& rhob_1_3=rho_1_3(2)%array,rhoa=rho(1)%array,& rhob=rho(2)%array,norm_drhoa=norm_drho(1)%array, & norm_drhob=norm_drho(2)%array,rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho(1)%array END IF @@ -750,75 +733,73 @@ SUBROUTINE xb88_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(2)%array,error=error) + "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(2)%array) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(rhoa)(rhoa)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(1)%array,error=error) + "(norm_drhoa)(rhoa)(rhoa)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(rhob)(rhob)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(2)%array,error=error) + "(norm_drhob)(rhob)(rhob)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)(rhoa)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)(rhoa)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)(rhob)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(2)%array,error=error) + "(norm_drhob)(norm_drhob)(rhob)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(2)%array,error=error) + "(norm_drhob)(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(2)%array) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DO ispin=1,2 @@ -829,7 +810,7 @@ SUBROUTINE xb88_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) !$omp shared(e_ndrho_ndrho, e_rho_rho_rho) & !$omp shared(e_ndrho_rho_rho, e_ndrho_ndrho_rho) & !$omp shared(e_ndrho_ndrho_ndrho, grad_deriv, npoints) & - !$omp shared(epsilon_rho, sx, error) + !$omp shared(epsilon_rho, sx) CALL xb88_lsd_calc(& rho_spin=rho(ispin)%array,& @@ -846,7 +827,7 @@ SUBROUTINE xb88_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) e_ndrho_ndrho_rho_spin=e_ndrho_ndrho_rho(ispin)%array,& e_ndrho_ndrho_ndrho_spin=e_ndrho_ndrho_ndrho(ispin)%array,& grad_deriv=grad_deriv, npoints=npoints,& - epsilon_rho=epsilon_rho, sx=sx, error=error) + epsilon_rho=epsilon_rho, sx=sx) !$omp end parallel @@ -854,7 +835,7 @@ SUBROUTINE xb88_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_params,error) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -882,8 +863,6 @@ END SUBROUTINE xb88_lsd_eval !> \param npoints ... !> \param epsilon_rho ... !> \param sx scaling-parameter for exchange -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2004 created [fawzi] !> 01.2007 added scaling [Manuel Guidon] @@ -893,8 +872,7 @@ SUBROUTINE xb88_lsd_calc(rho_spin, rho_1_3_spin, norm_drho_spin,e_0,& e_rho_spin,e_ndrho_spin,e_rho_rho_spin,e_ndrho_rho_spin,& e_ndrho_ndrho_spin, e_rho_rho_rho_spin, e_ndrho_rho_rho_spin,& e_ndrho_ndrho_rho_spin,& - e_ndrho_ndrho_ndrho_spin,grad_deriv,npoints,epsilon_rho,sx,& - error) + e_ndrho_ndrho_ndrho_spin,grad_deriv,npoints,epsilon_rho,sx) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rho_spin, rho_1_3_spin, & norm_drho_spin REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_rho_spin, & @@ -903,7 +881,6 @@ SUBROUTINE xb88_lsd_calc(rho_spin, rho_1_3_spin, norm_drho_spin,e_0,& e_ndrho_ndrho_ndrho_spin INTEGER, INTENT(in) :: grad_deriv, npoints REAL(kind=dp), INTENT(in) :: epsilon_rho, sx - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_xbecke88_long_range.F b/src/xc/xc_xbecke88_long_range.F index 0745f0114c..f9dc70f0b7 100644 --- a/src/xc/xc_xbecke88_long_range.F +++ b/src/xc/xc_xbecke88_long_range.F @@ -47,18 +47,15 @@ MODULE xc_xbecke88_long_range !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_lda_info(reference,shortform, needs, max_deriv,error) + SUBROUTINE xb88_lr_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_lda_info', & routineP = moduleN//':'//routineN @@ -84,18 +81,15 @@ END SUBROUTINE xb88_lr_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_lsd_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE xb88_lr_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_lsd_info', & routineP = moduleN//':'//routineN @@ -124,18 +118,15 @@ END SUBROUTINE xb88_lr_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param xb88_lr_params input parameters (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) + SUBROUTINE xb88_lr_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xb88_lr_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_lda_eval', & routineP = moduleN//':'//routineN @@ -153,25 +144,24 @@ SUBROUTINE xb88_lr_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(xb88_lr_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(xb88_lr_params, "omega",r_val=omega, error=error) + CALL section_vals_val_get(xb88_lr_params,"scale_x",r_val=sx) + CALL section_vals_val_get(xb88_lr_params, "omega",r_val=omega) CALL cite_reference(Becke1988) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -189,47 +179,46 @@ SUBROUTINE xb88_lr_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho,error=error) + "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho,error=error) + "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & @@ -237,7 +226,7 @@ SUBROUTINE xb88_lr_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) !$omp shared(e_ndrho_rho, e_ndrho_ndrho, e_rho_rho_rho) & !$omp shared(e_ndrho_rho_rho, e_ndrho_ndrho_rho) & !$omp shared(e_ndrho_ndrho_ndrho, grad_deriv, npoints) & - !$omp shared(epsilon_rho, sx, omega, error) + !$omp shared(epsilon_rho, sx, omega) CALL xb88_lr_lda_calc(rho=rho, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,e_rho_rho=e_rho_rho,& @@ -246,13 +235,13 @@ SUBROUTINE xb88_lr_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) e_ndrho_ndrho_rho=e_ndrho_ndrho_rho,& e_ndrho_ndrho_ndrho=e_ndrho_ndrho_ndrho,grad_deriv=grad_deriv,& npoints=npoints,epsilon_rho=epsilon_rho,& - sx=sx,omega=omega,error=error) + sx=sx,omega=omega) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -279,8 +268,6 @@ END SUBROUTINE xb88_lr_lda_eval !> \param epsilon_rho ... !> \param sx scaling-parameter for exchange !> \param omega parameter for erfc -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon @@ -292,7 +279,7 @@ SUBROUTINE xb88_lr_lda_calc(rho, norm_drho,& e_0,e_rho,e_ndrho,e_rho_rho,e_ndrho_rho,& e_ndrho_ndrho, e_rho_rho_rho, e_ndrho_rho_rho, e_ndrho_ndrho_rho,& e_ndrho_ndrho_ndrho,grad_deriv,npoints,epsilon_rho, sx,& - omega, error) + omega) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), INTENT(inout) :: & e_ndrho_ndrho_ndrho, e_ndrho_ndrho_rho, e_ndrho_rho_rho, e_rho_rho_rho, & @@ -300,7 +287,6 @@ SUBROUTINE xb88_lr_lda_calc(rho, norm_drho,& REAL(kind=dp), DIMENSION(1:npoints), & INTENT(in) :: norm_drho, rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, omega - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_lda_calc', & routineP = moduleN//':'//routineN @@ -880,18 +866,15 @@ END SUBROUTINE xb88_lr_lda_calc !> \param deriv_set ... !> \param grad_deriv ... !> \param xb88_lr_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) + SUBROUTINE xb88_lr_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xb88_lr_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_lsd_eval', & routineP = moduleN//':'//routineN @@ -918,25 +901,25 @@ SUBROUTINE xb88_lr_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) NULLIFY(norm_drho(i)%array, rho(i)%array) END DO - CALL section_vals_val_get(xb88_lr_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(xb88_lr_params, "omega",r_val=omega, error=error) + CALL section_vals_val_get(xb88_lr_params,"scale_x",r_val=sx) + CALL section_vals_val_get(xb88_lr_params, "omega",r_val=omega) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,& rhoa=rho(1)%array,& rhob=rho(2)%array,norm_drhoa=norm_drho(1)%array, & norm_drhob=norm_drho(2)%array,rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho(1)%array END IF @@ -956,75 +939,73 @@ SUBROUTINE xb88_lr_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(2)%array,error=error) + "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(2)%array) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(rhoa)(rhoa)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(1)%array,error=error) + "(norm_drhoa)(rhoa)(rhoa)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(rhob)(rhob)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(2)%array,error=error) + "(norm_drhob)(rhob)(rhob)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)(rhoa)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)(rhoa)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)(rhob)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(2)%array,error=error) + "(norm_drhob)(norm_drhob)(rhob)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(2)%array,error=error) + "(norm_drhob)(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(2)%array) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DO ispin=1,2 @@ -1035,7 +1016,7 @@ SUBROUTINE xb88_lr_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) !$omp shared(e_rho_rho_rho, e_ndrho_rho_rho) & !$omp shared(e_ndrho_ndrho_rho, e_ndrho_ndrho_ndrho) & !$omp shared(grad_deriv, npoints, epsilon_rho, sx, omega) & - !$omp shared(error, ispin) + !$omp shared(ispin) CALL xb88_lr_lsd_calc(& rho_spin=rho(ispin)%array,& @@ -1052,8 +1033,7 @@ SUBROUTINE xb88_lr_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) e_ndrho_ndrho_ndrho_spin=e_ndrho_ndrho_ndrho(ispin)%array,& grad_deriv=grad_deriv, npoints=npoints,& epsilon_rho=epsilon_rho, & - sx=sx, omega=omega,& - error=error) + sx=sx, omega=omega) !$omp end parallel @@ -1061,7 +1041,7 @@ SUBROUTINE xb88_lr_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_params,error) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -1089,8 +1069,6 @@ END SUBROUTINE xb88_lr_lsd_eval !> \param epsilon_rho ... !> \param sx scaling-parameter for exchange !> \param omega ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon @@ -1102,7 +1080,7 @@ SUBROUTINE xb88_lr_lsd_calc(rho_spin, norm_drho_spin,e_0,& e_ndrho_ndrho_spin, e_rho_rho_rho_spin, e_ndrho_rho_rho_spin,& e_ndrho_ndrho_rho_spin,& e_ndrho_ndrho_ndrho_spin,grad_deriv,npoints,epsilon_rho, sx,& - omega, error) + omega) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rho_spin, norm_drho_spin REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_rho_spin, & e_ndrho_spin, e_rho_rho_spin, e_ndrho_rho_spin, e_ndrho_ndrho_spin, & @@ -1110,7 +1088,6 @@ SUBROUTINE xb88_lr_lsd_calc(rho_spin, norm_drho_spin,e_0,& e_ndrho_ndrho_ndrho_spin INTEGER, INTENT(in) :: grad_deriv, npoints REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, omega - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_xbecke88_lr_adiabatic.F b/src/xc/xc_xbecke88_lr_adiabatic.F index 25cc7b0813..18f7268990 100644 --- a/src/xc/xc_xbecke88_lr_adiabatic.F +++ b/src/xc/xc_xbecke88_lr_adiabatic.F @@ -54,18 +54,15 @@ MODULE xc_xbecke88_lr_adiabatic !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_adiabatic_lda_info(reference,shortform, needs, max_deriv,error) + SUBROUTINE xb88_lr_adiabatic_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_adiabatic_lda_info', & routineP = moduleN//':'//routineN @@ -91,18 +88,15 @@ END SUBROUTINE xb88_lr_adiabatic_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_adiabatic_lsd_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE xb88_lr_adiabatic_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_adiabatic_lsd_info', & routineP = moduleN//':'//routineN @@ -131,18 +125,15 @@ END SUBROUTINE xb88_lr_adiabatic_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param xb88_lr_ad_params input parameters (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_params,error) + SUBROUTINE xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xb88_lr_ad_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_adiabatic_lda_eval', & routineP = moduleN//':'//routineN @@ -160,26 +151,25 @@ SUBROUTINE xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(xb88_lr_ad_params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(xb88_lr_ad_params, "OMEGA",r_val=omega, error=error) - CALL section_vals_val_get(xb88_lr_ad_params, "LAMBDA",r_val=lambda, error=error) + CALL section_vals_val_get(xb88_lr_ad_params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(xb88_lr_ad_params, "OMEGA",r_val=omega) + CALL section_vals_val_get(xb88_lr_ad_params, "LAMBDA",r_val=lambda) CALL cite_reference(Becke1988) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -197,47 +187,46 @@ SUBROUTINE xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho,error=error) + "(norm_drho)(rho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho,error=error) + "(norm_drho)(norm_drho)(rho)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & @@ -245,7 +234,7 @@ SUBROUTINE xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa !$omp shared(e_ndrho_rho, e_ndrho_ndrho, e_rho_rho_rho) & !$omp shared(e_ndrho_rho_rho, e_ndrho_ndrho_rho) & !$omp shared(e_ndrho_ndrho_ndrho, grad_deriv, npoints) & - !$omp shared(epsilon_rho, sx, omega, lambda, error) + !$omp shared(epsilon_rho, sx, omega, lambda) CALL xb88_lr_adiabatic_lda_calc(rho=rho, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,e_rho_rho=e_rho_rho,& @@ -254,13 +243,13 @@ SUBROUTINE xb88_lr_adiabatic_lda_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa e_ndrho_ndrho_rho=e_ndrho_ndrho_rho,& e_ndrho_ndrho_ndrho=e_ndrho_ndrho_ndrho,grad_deriv=grad_deriv,& npoints=npoints,epsilon_rho=epsilon_rho,& - sx=sx,omega=omega,lambda=lambda,error=error) + sx=sx,omega=omega,lambda=lambda) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -288,8 +277,6 @@ END SUBROUTINE xb88_lr_adiabatic_lda_eval !> \param sx scaling-parameter for exchange !> \param omega parameter for erfc !> \param lambda ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon @@ -300,7 +287,7 @@ SUBROUTINE xb88_lr_adiabatic_lda_calc(rho, norm_drho,& e_0,e_rho,e_ndrho,e_rho_rho,e_ndrho_rho,& e_ndrho_ndrho, e_rho_rho_rho, e_ndrho_rho_rho, e_ndrho_ndrho_rho,& e_ndrho_ndrho_ndrho,grad_deriv,npoints,epsilon_rho, sx,& - omega, lambda, error) + omega, lambda) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), INTENT(inout) :: & e_ndrho_ndrho_ndrho, e_ndrho_ndrho_rho, e_ndrho_rho_rho, e_rho_rho_rho, & @@ -308,7 +295,6 @@ SUBROUTINE xb88_lr_adiabatic_lda_calc(rho, norm_drho,& REAL(kind=dp), DIMENSION(1:npoints), & INTENT(in) :: norm_drho, rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, omega, lambda - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_adiabatic_lda_calc', & routineP = moduleN//':'//routineN @@ -2924,18 +2910,15 @@ END SUBROUTINE xb88_lr_adiabatic_lda_calc !> \param deriv_set ... !> \param grad_deriv ... !> \param xb88_lr_ad_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_params,error) + SUBROUTINE xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xb88_lr_ad_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_adiabatic_lsd_eval', & routineP = moduleN//':'//routineN @@ -2962,26 +2945,26 @@ SUBROUTINE xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa NULLIFY(norm_drho(i)%array, rho(i)%array) END DO - CALL section_vals_val_get(xb88_lr_ad_params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(xb88_lr_ad_params, "OMEGA",r_val=omega, error=error) - CALL section_vals_val_get(xb88_lr_ad_params, "LAMBDA",r_val=lambda, error=error) + CALL section_vals_val_get(xb88_lr_ad_params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(xb88_lr_ad_params, "OMEGA",r_val=omega) + CALL section_vals_val_get(xb88_lr_ad_params, "LAMBDA",r_val=lambda) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,& rhoa=rho(1)%array,& rhob=rho(2)%array,norm_drhoa=norm_drho(1)%array, & norm_drhob=norm_drho(2)%array,rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho(1)%array END IF @@ -3001,75 +2984,73 @@ SUBROUTINE xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array) END IF IF (grad_deriv>=2.OR.grad_deriv==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(2)%array,error=error) + "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho(2)%array) END IF IF (grad_deriv>=3.OR.grad_deriv==-3) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(rhoa)(rhoa)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(1)%array,error=error) + "(norm_drhoa)(rhoa)(rhoa)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(rhob)(rhob)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(2)%array,error=error) + "(norm_drhob)(rhob)(rhob)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)(rhoa)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)(rhoa)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)(rhob)",allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(2)%array,error=error) + "(norm_drhob)(norm_drhob)(rhob)",allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(1)%array,error=error) + "(norm_drhoa)(norm_drhoa)(norm_drhoa)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,& - error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(2)%array,error=error) + "(norm_drhob)(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho_ndrho(2)%array) END IF IF (grad_deriv>3.OR.grad_deriv<-3) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 3 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DO ispin=1,2 @@ -3080,7 +3061,7 @@ SUBROUTINE xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa !$omp shared(e_rho_rho_rho, e_ndrho_rho_rho) & !$omp shared(e_ndrho_ndrho_rho, e_ndrho_ndrho_ndrho) & !$omp shared(grad_deriv, npoints, epsilon_rho, sx, omega) & - !$omp shared(lambda, error) + !$omp shared(lambda) CALL xb88_lr_adiabatic_lsd_calc(& rho_spin=rho(ispin)%array,& @@ -3097,8 +3078,7 @@ SUBROUTINE xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa e_ndrho_ndrho_ndrho_spin=e_ndrho_ndrho_ndrho(ispin)%array,& grad_deriv=grad_deriv, npoints=npoints,& epsilon_rho=epsilon_rho, & - sx=sx, omega=omega, lambda=lambda, & - error=error) + sx=sx, omega=omega, lambda=lambda) !$omp end parallel @@ -3106,7 +3086,7 @@ SUBROUTINE xb88_lr_adiabatic_lsd_eval(rho_set,deriv_set,grad_deriv,xb88_lr_ad_pa IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -3135,8 +3115,6 @@ END SUBROUTINE xb88_lr_adiabatic_lsd_eval !> \param sx scaling-parameter for exchange !> \param omega ... !> \param lambda ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2008 created [mguidon] !> \author Manuel Guidon @@ -3146,7 +3124,7 @@ SUBROUTINE xb88_lr_adiabatic_lsd_calc(rho_spin, norm_drho_spin,e_0,& e_ndrho_ndrho_spin, e_rho_rho_rho_spin, e_ndrho_rho_rho_spin,& e_ndrho_ndrho_rho_spin,& e_ndrho_ndrho_ndrho_spin,grad_deriv,npoints,epsilon_rho, sx,& - omega, lambda, error) + omega, lambda) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rho_spin, norm_drho_spin REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_rho_spin, & e_ndrho_spin, e_rho_rho_spin, e_ndrho_rho_spin, e_ndrho_ndrho_spin, & @@ -3154,7 +3132,6 @@ SUBROUTINE xb88_lr_adiabatic_lsd_calc(rho_spin, norm_drho_spin,e_0,& e_ndrho_ndrho_ndrho_spin INTEGER, INTENT(in) :: grad_deriv, npoints REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, omega, lambda - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xb88_lr_adiabatic_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_xbecke_roussel.F b/src/xc/xc_xbecke_roussel.F index 0cba92a29d..adf7180381 100644 --- a/src/xc/xc_xbecke_roussel.F +++ b/src/xc/xc_xbecke_roussel.F @@ -80,19 +80,15 @@ MODULE xc_xbecke_roussel !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv controls the number of derivatives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xbecke_roussel_lda_info(reference,shortform, needs, max_deriv,& - error) + SUBROUTINE xbecke_roussel_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbecke_roussel_lda_info', & routineP = moduleN//':'//routineN @@ -129,19 +125,15 @@ END SUBROUTINE xbecke_roussel_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xbecke_roussel_lsd_info(reference,shortform, needs, max_deriv,& - error) + SUBROUTINE xbecke_roussel_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbecke_roussel_lsd_info', & routineP = moduleN//':'//routineN @@ -179,18 +171,15 @@ END SUBROUTINE xbecke_roussel_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param br_params parameters for the becke roussel functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xbecke_roussel_lda_eval(rho_set,deriv_set,grad_deriv,br_params,error) + SUBROUTINE xbecke_roussel_lda_eval(rho_set,deriv_set,grad_deriv,br_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: br_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbecke_roussel_lda_eval', & routineP = moduleN//':'//routineN @@ -212,20 +201,20 @@ SUBROUTINE xbecke_roussel_lda_eval(rho_set,deriv_set,grad_deriv,br_params,error) failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set, rho=rho, norm_drho=norm_drho, & tau=tau,laplace_rho=laplace_rho,local_bounds=bo,& - rho_cutoff=epsilon_rho,error=error) + rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -238,50 +227,50 @@ SUBROUTINE xbecke_roussel_lda_eval(rho_set,deriv_set,grad_deriv,br_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(tau)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau) deriv => xc_dset_get_derivative(deriv_set,"(laplace_rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_val_get(br_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(br_params,"CUTOFF_RADIUS",r_val=R,error=error) - CALL section_vals_val_get(br_params,"GAMMA",r_val=gamma,error=error) + CALL section_vals_val_get(br_params,"scale_x",r_val=sx) + CALL section_vals_val_get(br_params,"CUTOFF_RADIUS",r_val=R) + CALL section_vals_val_get(br_params,"GAMMA",r_val=gamma) !$omp parallel default(none) & !$omp shared(rho, norm_drho, laplace_rho, tau, e_0, e_rho) & !$omp shared(e_ndrho, e_tau, e_laplace_rho, grad_deriv) & !$omp shared(npoints, epsilon_rho) & - !$omp shared(sx, r, gamma, error) + !$omp shared(sx, r, gamma) CALL xbecke_roussel_lda_calc(rho=rho, norm_drho=norm_drho,& laplace_rho=laplace_rho,tau=tau,e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,& e_tau=e_tau,e_laplace_rho=e_laplace_rho,grad_deriv=grad_deriv, & npoints=npoints,epsilon_rho=epsilon_rho,& - sx=sx,R=R,gamma=gamma,error=error) + sx=sx,R=R,gamma=gamma) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -311,15 +300,13 @@ END SUBROUTINE xbecke_roussel_lda_eval !> \param sx scales the exchange potential and energies !> \param R cutoff Radius for truncated case !> \param gamma paramter from original publication, usually set to 1 -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE xbecke_roussel_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_ndrho,e_tau,e_laplace_rho,grad_deriv,npoints,& - epsilon_rho,sx,R,gamma,error) + epsilon_rho,sx,R,gamma) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), & @@ -329,7 +316,6 @@ SUBROUTINE xbecke_roussel_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& INTENT(in) :: tau, laplace_rho, norm_drho, & rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R, gamma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbecke_roussel_lda_calc', & routineP = moduleN//':'//routineN @@ -367,7 +353,7 @@ SUBROUTINE xbecke_roussel_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_old = e_0(ip) CALL x_br_lsd_y_lte_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_diff = e_0(ip) - e_old e_0(ip) = e_0(ip) + e_diff @@ -375,7 +361,7 @@ SUBROUTINE xbecke_roussel_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_old = e_0(ip) CALL x_br_lsd_y_gt_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_diff = e_0(ip) - e_old e_0(ip) = e_0(ip) + e_diff @@ -385,7 +371,7 @@ SUBROUTINE xbecke_roussel_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_old = e_0(ip) CALL x_br_lsd_y_lte_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_diff = e_0(ip) - e_old e_0(ip) = e_0(ip) + e_diff @@ -393,7 +379,7 @@ SUBROUTINE xbecke_roussel_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_old = e_0(ip) CALL x_br_lsd_y_gt_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_diff = e_0(ip) - e_old e_0(ip) = e_0(ip) + e_diff @@ -415,18 +401,15 @@ END SUBROUTINE xbecke_roussel_lda_calc !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param br_params parameters for the becke roussel functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xbecke_roussel_lsd_eval(rho_set,deriv_set,grad_deriv,br_params,error) + SUBROUTINE xbecke_roussel_lsd_eval(rho_set,deriv_set,grad_deriv,br_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: br_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbecke_roussel_lsd_eval', & routineP = moduleN//':'//routineN @@ -447,21 +430,21 @@ SUBROUTINE xbecke_roussel_lsd_eval(rho_set,deriv_set,grad_deriv,br_params,error) failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set, rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa, & norm_drhob=norm_drhob, tau_a=tau_a, tau_b=tau_b, laplace_rhoa=laplace_rhoa,& laplace_rhob=laplace_rhob,local_bounds=bo,& - rho_cutoff=epsilon_rho,error=error) + rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -478,53 +461,53 @@ SUBROUTINE xbecke_roussel_lsd_eval(rho_set,deriv_set,grad_deriv,br_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) deriv => xc_dset_get_derivative(deriv_set,"(tau_a)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_a,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_a) deriv => xc_dset_get_derivative(deriv_set,"(tau_b)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_b,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_b) deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_val_get(br_params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(br_params,"CUTOFF_RADIUS",r_val=R,error=error) - CALL section_vals_val_get(br_params,"GAMMA",r_val=gamma,error=error) + CALL section_vals_val_get(br_params,"scale_x",r_val=sx) + CALL section_vals_val_get(br_params,"CUTOFF_RADIUS",r_val=R) + CALL section_vals_val_get(br_params,"GAMMA",r_val=gamma) !$omp parallel default (none) & !$omp shared(rhoa, norm_drhoa, laplace_rhoa, tau_a, e_0) & !$omp shared(e_rhoa, e_ndrhoa, e_tau_a, e_laplace_rhoa) & !$omp shared(grad_deriv, npoints, epsilon_rho) & - !$omp shared(sx, r, gamma, error) & + !$omp shared(sx, r, gamma) & !$omp shared(rhob, norm_drhob, laplace_rhob, tau_b, e_rhob) & !$omp shared(e_ndrhob, e_tau_b, e_laplace_rhob) @@ -532,19 +515,19 @@ SUBROUTINE xbecke_roussel_lsd_eval(rho_set,deriv_set,grad_deriv,br_params,error) laplace_rho=laplace_rhoa,tau=tau_a,e_0=e_0,e_rho=e_rhoa,e_ndrho=e_ndrhoa,& e_tau=e_tau_a,e_laplace_rho=e_laplace_rhoa,grad_deriv=grad_deriv, & npoints=npoints,epsilon_rho=epsilon_rho,& - sx=sx,R=R,gamma=gamma,error=error) + sx=sx,R=R,gamma=gamma) CALL xbecke_roussel_lsd_calc(rho=rhob, norm_drho=norm_drhob,& laplace_rho=laplace_rhob,tau=tau_b,e_0=e_0,e_rho=e_rhob,e_ndrho=e_ndrhob,& e_tau=e_tau_b,e_laplace_rho=e_laplace_rhob,grad_deriv=grad_deriv, & npoints=npoints,epsilon_rho=epsilon_rho,& - sx=sx,R=R,gamma=gamma,error=error) + sx=sx,R=R,gamma=gamma) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -572,15 +555,13 @@ END SUBROUTINE xbecke_roussel_lsd_eval !> \param sx scales the exchange potential and energies !> \param R cutoff Radius for truncated case !> \param gamma paramter from original publication, usually set to 1 -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE xbecke_roussel_lsd_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_ndrho,e_tau,e_laplace_rho,grad_deriv,npoints,& - epsilon_rho,sx,R,gamma,error) + epsilon_rho,sx,R,gamma) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), & @@ -590,7 +571,6 @@ SUBROUTINE xbecke_roussel_lsd_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& INTENT(in) :: tau, laplace_rho, norm_drho, & rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R, gamma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbecke_roussel_lsd_calc', & routineP = moduleN//':'//routineN @@ -626,21 +606,21 @@ SUBROUTINE xbecke_roussel_lsd_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& IF( yval <= 0.0_dp) THEN CALL x_br_lsd_y_lte_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) ELSE CALL x_br_lsd_y_gt_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) END IF ELSE IF( yval <= 0.0_dp) THEN CALL x_br_lsd_y_lte_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ELSE CALL x_br_lsd_y_gt_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0(ip), & e_rho(ip), e_ndrho(ip), e_tau(ip), e_laplace_rho(ip),& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) END IF END IF END IF @@ -664,20 +644,18 @@ END SUBROUTINE xbecke_roussel_lsd_calc !> \param sx ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_lte_0(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'x_br_lsd_y_lte_0', & routineP = moduleN//':'//routineN @@ -916,20 +894,18 @@ END SUBROUTINE x_br_lsd_y_lte_0 !> \param sx ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_gt_0(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'x_br_lsd_y_gt_0', & routineP = moduleN//':'//routineN @@ -1183,20 +1159,18 @@ END SUBROUTINE x_br_lsd_y_gt_0 !> \param R ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_lte_0_cutoff(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, R, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'x_br_lsd_y_lte_0_cutoff', & routineP = moduleN//':'//routineN @@ -1247,11 +1221,11 @@ SUBROUTINE x_br_lsd_y_lte_0_cutoff(rho, ndrho, tau, laplace_rho, e_0, & IF(R>brval) THEN CALL x_br_lsd_y_lte_0_cutoff_R_gt_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ELSE CALL x_br_lsd_y_lte_0_cutoff_R_lte_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) END IF END SUBROUTINE x_br_lsd_y_lte_0_cutoff @@ -1271,20 +1245,18 @@ END SUBROUTINE x_br_lsd_y_lte_0_cutoff !> \param R ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_lte_0_cutoff_R_gt_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, R, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'x_br_lsd_y_lte_0_cutoff_R_gt_b', & @@ -1621,20 +1593,18 @@ END SUBROUTINE x_br_lsd_y_lte_0_cutoff_R_gt_b !> \param R ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_lte_0_cutoff_R_lte_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, R, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'x_br_lsd_y_lte_0_cutoff_R_lte_b', & @@ -1969,20 +1939,18 @@ END SUBROUTINE x_br_lsd_y_lte_0_cutoff_R_lte_b !> \param R ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_gt_0_cutoff(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, R, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'x_br_lsd_y_gt_0_cutoff', & routineP = moduleN//':'//routineN @@ -2040,11 +2008,11 @@ SUBROUTINE x_br_lsd_y_gt_0_cutoff(rho, ndrho, tau, laplace_rho, e_0, & IF(R>brval) THEN CALL x_br_lsd_y_gt_0_cutoff_R_gt_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ELSE CALL x_br_lsd_y_gt_0_cutoff_R_lte_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) END IF END SUBROUTINE x_br_lsd_y_gt_0_cutoff @@ -2064,21 +2032,19 @@ END SUBROUTINE x_br_lsd_y_gt_0_cutoff !> \param R ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_gt_0_cutoff_R_gt_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, R, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'x_br_lsd_y_gt_0_cutoff_R_gt_b', & @@ -2429,20 +2395,18 @@ END SUBROUTINE x_br_lsd_y_gt_0_cutoff_R_gt_b !> \param R ... !> \param gamma ... !> \param grad_deriv ... -!> \param error ... !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** SUBROUTINE x_br_lsd_y_gt_0_cutoff_R_lte_b(rho, ndrho, tau, laplace_rho, e_0, & e_rho, e_ndrho, e_tau, e_laplace_rho,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) REAL(dp), INTENT(IN) :: rho, ndrho, tau, laplace_rho REAL(dp), INTENT(INOUT) :: e_0, e_rho, e_ndrho, e_tau, & e_laplace_rho REAL(dp), INTENT(IN) :: sx, R, gamma INTEGER, INTENT(IN) :: grad_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'x_br_lsd_y_gt_0_cutoff_R_lte_b', & diff --git a/src/xc/xc_xbeef.F b/src/xc/xc_xbeef.F index c783d2b9b2..c0d6b11072 100644 --- a/src/xc/xc_xbeef.F +++ b/src/xc/xc_xbeef.F @@ -58,19 +58,16 @@ MODULE xc_xbeef !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2014 created !> \author rkoitz ! ***************************************************************************** - SUBROUTINE xbeef_lda_info(reference,shortform, needs, max_deriv,error) + SUBROUTINE xbeef_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbeef_lda_info', & routineP = moduleN//':'//routineN @@ -97,18 +94,15 @@ END SUBROUTINE xbeef_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2014 created !> \author rkoitz ! ***************************************************************************** - SUBROUTINE xbeef_lsd_info(reference,shortform, needs, max_deriv, error) + SUBROUTINE xbeef_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbeef_lsd_info', & routineP = moduleN//':'//routineN @@ -137,18 +131,15 @@ END SUBROUTINE xbeef_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param xbeef_params input parameters (scaling) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2014 created !> \author rkoitz ! ***************************************************************************** - SUBROUTINE xbeef_lda_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) + SUBROUTINE xbeef_lda_eval(rho_set,deriv_set,grad_deriv,xbeef_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xbeef_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbeef_lda_eval', & routineP = moduleN//':'//routineN @@ -166,23 +157,23 @@ SUBROUTINE xbeef_lda_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) failure=.FALSE. NULLIFY(bo) - CALL section_vals_val_get(xbeef_params,"scale_x",r_val=sx,error=error) + CALL section_vals_val_get(xbeef_params,"scale_x",r_val=sx) CALL cite_reference(Wellendorff2012) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho_1_3=rho_1_3,rho=rho,& - norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,error=error) + norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -193,37 +184,37 @@ SUBROUTINE xbeef_lda_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives greater than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(rho, rho_1_3, norm_drho, e_0, e_rho) & !$omp shared(e_ndrho) & !$omp shared( grad_deriv, npoints) & - !$omp shared(epsilon_rho,sx, error) + !$omp shared(epsilon_rho,sx) CALL xbeef_lda_calc(rho=rho, rho_1_3=rho_1_3, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,& grad_deriv=grad_deriv,& - npoints=npoints,epsilon_rho=epsilon_rho,sx=sx,error=error) + npoints=npoints,epsilon_rho=epsilon_rho,sx=sx) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -244,22 +235,19 @@ END SUBROUTINE xbeef_lda_eval !> \param npoints ... !> \param epsilon_rho ... !> \param sx scaling-parameter for exchange -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2014 created based on xc_xbecke88 !> \author rkoitz ! ***************************************************************************** SUBROUTINE xbeef_lda_calc(rho, rho_1_3, norm_drho,& e_0,e_rho,e_ndrho,& - grad_deriv,npoints,epsilon_rho,sx,error) + grad_deriv,npoints,epsilon_rho,sx) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), & INTENT(inout) :: e_ndrho, e_rho, e_0 REAL(kind=dp), DIMENSION(1:npoints), & INTENT(in) :: norm_drho, rho_1_3, rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbeef_lda_calc', & routineP = moduleN//':'//routineN @@ -348,18 +336,15 @@ END SUBROUTINE xbeef_lda_calc !> \param deriv_set ... !> \param grad_deriv ... !> \param xbeef_params ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 2/2014 rkoitz [created based on Becke 88] !> \author rkoitz ! ***************************************************************************** - SUBROUTINE xbeef_lsd_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) + SUBROUTINE xbeef_lsd_eval(rho_set,deriv_set,grad_deriv,xbeef_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: xbeef_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbeef_lsd_eval', & routineP = moduleN//':'//routineN @@ -385,23 +370,23 @@ SUBROUTINE xbeef_lsd_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) NULLIFY(norm_drho(i)%array, rho(i)%array, rho_1_3(i)%array) END DO - CALL section_vals_val_get(xbeef_params,"scale_x",r_val=sx,error=error) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CALL section_vals_val_get(xbeef_params,"scale_x",r_val=sx) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa_1_3=rho_1_3(1)%array,& rhob_1_3=rho_1_3(2)%array,rhoa=rho(1)%array,& rhob=rho(2)%array,norm_drhoa=norm_drho(1)%array, & norm_drhob=norm_drho(2)%array,rho_cutoff=epsilon_rho,& - local_bounds=bo, error=error) + local_bounds=bo) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho(1)%array END IF @@ -414,27 +399,27 @@ SUBROUTINE xbeef_lsd_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv, deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv, deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho(2)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(1)%array) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho(2)%array) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives greater than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF DO ispin=1,2 @@ -443,7 +428,7 @@ SUBROUTINE xbeef_lsd_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) !$omp shared(rho, ispin, rho_1_3, norm_drho, e_0) & !$omp shared(e_rho, e_ndrho) & !$omp shared(grad_deriv, npoints) & - !$omp shared(epsilon_rho, sx, error) + !$omp shared(epsilon_rho, sx) CALL xbeef_lsd_calc(& rho_spin=rho(ispin)%array,& @@ -452,8 +437,7 @@ SUBROUTINE xbeef_lsd_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) e_0=e_0,e_rho_spin=e_rho(ispin)%array,& e_ndrho_spin=e_ndrho(ispin)%array,& grad_deriv=grad_deriv, npoints=npoints,& - epsilon_rho=epsilon_rho,sx=sx,& - error=error) + epsilon_rho=epsilon_rho,sx=sx) !$omp end parallel @@ -461,7 +445,7 @@ SUBROUTINE xbeef_lsd_eval(rho_set,deriv_set,grad_deriv,xbeef_params,error) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -481,21 +465,18 @@ END SUBROUTINE xbeef_lsd_eval !> \param npoints ... !> \param epsilon_rho ... !> \param sx scaling-parameter for exchange -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 02.2014 created based on Becke88 !> \author rkoitz ! ***************************************************************************** SUBROUTINE xbeef_lsd_calc(rho_spin, rho_1_3_spin, norm_drho_spin,e_0,& - e_rho_spin,e_ndrho_spin,grad_deriv,npoints,epsilon_rho,sx,error) + e_rho_spin,e_ndrho_spin,grad_deriv,npoints,epsilon_rho,sx) REAL(kind=dp), DIMENSION(*), INTENT(in) :: rho_spin, rho_1_3_spin, & norm_drho_spin REAL(kind=dp), DIMENSION(*), & INTENT(inout) :: e_0, e_rho_spin, e_ndrho_spin INTEGER, INTENT(in) :: grad_deriv, npoints REAL(kind=dp), INTENT(in) :: epsilon_rho, sx - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xbeef_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_xbr_pbe_lda_hole_t_c_lr.F b/src/xc/xc_xbr_pbe_lda_hole_t_c_lr.F index 78d4491ce5..b1408d256f 100644 --- a/src/xc/xc_xbr_pbe_lda_hole_t_c_lr.F +++ b/src/xc/xc_xbr_pbe_lda_hole_t_c_lr.F @@ -105,17 +105,13 @@ MODULE xc_xbr_pbe_lda_hole_t_c_lr !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author mguidon (01.2009) ! ***************************************************************************** - SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_info(reference,shortform, needs, max_deriv,& - error) + SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'xbr_pbe_lda_hole_tc_lr_lda_info', & @@ -150,17 +146,13 @@ END SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author mguidon (01.2009) ! ***************************************************************************** - SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_info(reference,shortform, needs, max_deriv,& - error) + SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_info(reference,shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'xbr_pbe_lda_hole_tc_lr_lsd_info', & @@ -196,16 +188,13 @@ END SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param params parameters for functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author mguidon (01.2009) ! ***************************************************************************** - SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_eval(rho_set,deriv_set,grad_deriv,params,error) + SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_eval(rho_set,deriv_set,grad_deriv,params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'xbr_pbe_lda_hole_tc_lr_lda_eval', & @@ -228,20 +217,20 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_eval(rho_set,deriv_set,grad_deriv,params,e failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set, rho=rho, norm_drho=norm_drho, & tau=tau,laplace_rho=laplace_rho,local_bounds=bo,& - rho_cutoff=epsilon_rho,error=error) + rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -254,55 +243,55 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_eval(rho_set,deriv_set,grad_deriv,params,e IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) deriv => xc_dset_get_derivative(deriv_set,"(tau)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau) deriv => xc_dset_get_derivative(deriv_set,"(laplace_rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rho) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_val_get(params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R,error=error) - CALL section_vals_val_get(params,"GAMMA",r_val=gamma,error=error) + CALL section_vals_val_get(params,"scale_x",r_val=sx) + CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R) + CALL section_vals_val_get(params,"GAMMA",r_val=gamma) IF ( R == 0.0_dp ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Cutoff_Radius 0.0 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(rho, norm_drho, laplace_rho, tau, e_0, e_rho) & !$omp shared(e_ndrho, e_tau, e_laplace_rho, grad_deriv) & !$omp shared(npoints, epsilon_rho) & - !$omp shared(sx, r, gamma, error) + !$omp shared(sx, r, gamma) CALL xbr_pbe_lda_hole_tc_lr_lda_calc(rho=rho, norm_drho=norm_drho,& laplace_rho=laplace_rho,tau=tau,e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,& e_tau=e_tau,e_laplace_rho=e_laplace_rho,grad_deriv=grad_deriv, & - npoints=npoints,epsilon_rho=epsilon_rho,sx=sx,R=R,gamma=gamma,error=error) + npoints=npoints,epsilon_rho=epsilon_rho,sx=sx,R=R,gamma=gamma) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -329,13 +318,11 @@ END SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_eval !> \param sx parameters for functional !> \param R parameters for functional !> \param gamma parameters for functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author mguidon (01.2009) ! ***************************************************************************** SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_ndrho,e_tau,e_laplace_rho,grad_deriv,npoints,& - epsilon_rho,sx,R,gamma,error) + epsilon_rho,sx,R,gamma) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), & @@ -345,7 +332,6 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_r INTENT(in) :: tau, laplace_rho, norm_drho, & rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R, gamma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'xbr_pbe_lda_hole_tc_lr_lda_calc', & @@ -389,13 +375,13 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_r IF( yval <= 0.0_dp) THEN CALL x_br_lsd_y_lte_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_0_br = 2.0_dp * e_0_br ELSE CALL x_br_lsd_y_gt_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_0_br = 2.0_dp * e_0_br END IF @@ -403,13 +389,13 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_r IF( yval <= 0.0_dp) THEN CALL x_br_lsd_y_lte_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_0_br = 2.0_dp * e_0_br ELSE CALL x_br_lsd_y_gt_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ! VERY UGLY HACK e_0 has to multiplied by the factor 2 e_0_br = 2.0_dp * e_0_br END IF @@ -453,7 +439,7 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_calc(rho,norm_drho,laplace_rho,tau,e_0,e_r e_0_lda = 0.0_dp e_rho_lda = 0.0_dp CALL xlda_hole_t_c_lr_lda_calc_0(grad_deriv, my_rho, e_0_lda, e_rho_lda,& - sx, R, error) + sx, R) Fx = e_0_br/e_0_lda @@ -500,16 +486,13 @@ END SUBROUTINE xbr_pbe_lda_hole_tc_lr_lda_calc !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param params parameters for functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author mguidon (01.2009) ! ***************************************************************************** - SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_eval(rho_set,deriv_set,grad_deriv,params,error) + SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_eval(rho_set,deriv_set,grad_deriv,params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(in) :: grad_deriv TYPE(section_vals_type), POINTER :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'xbr_pbe_lda_hole_tc_lr_lsd_eval', & @@ -531,21 +514,21 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_eval(rho_set,deriv_set,grad_deriv,params,e failure=.FALSE. NULLIFY(bo) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set, rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa, & norm_drhob=norm_drhob, tau_a=tau_a, tau_b=tau_b, laplace_rhoa=laplace_rhoa,& laplace_rhob=laplace_rhob,local_bounds=bo,& - rho_cutoff=epsilon_rho,error=error) + rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -562,59 +545,59 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_eval(rho_set,deriv_set,grad_deriv,params,e IF (grad_deriv>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (grad_deriv>=1.OR.grad_deriv==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) deriv => xc_dset_get_derivative(deriv_set,"(tau_a)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_a,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_a) deriv => xc_dset_get_derivative(deriv_set,"(tau_b)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_tau_b,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_tau_b) deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(laplace_rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_laplace_rhob) END IF IF (grad_deriv>1.OR.grad_deriv<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF - CALL section_vals_val_get(params,"scale_x",r_val=sx,error=error) - CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R,error=error) - CALL section_vals_val_get(params,"GAMMA",r_val=gamma,error=error) + CALL section_vals_val_get(params,"scale_x",r_val=sx) + CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R) + CALL section_vals_val_get(params,"GAMMA",r_val=gamma) IF ( R == 0.0_dp ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Cutoff_Radius 0.0 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(rhoa, norm_drhoa, laplace_rhoa, tau_a, e_0) & !$omp shared(e_rhoa, e_ndrhoa, e_tau_a, e_laplace_rhoa) & !$omp shared(grad_deriv, npoints, epsilon_rho) & - !$omp shared(sx, r, gamma, error) & + !$omp shared(sx, r, gamma) & !$omp shared(rhob, norm_drhob, laplace_rhob, tau_b, e_rhob) & !$omp shared(e_ndrhob, e_tau_b, e_laplace_rhob) @@ -622,19 +605,19 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_eval(rho_set,deriv_set,grad_deriv,params,e laplace_rho=laplace_rhoa,tau=tau_a,e_0=e_0,e_rho=e_rhoa,e_ndrho=e_ndrhoa,& e_tau=e_tau_a,e_laplace_rho=e_laplace_rhoa,grad_deriv=grad_deriv, & npoints=npoints,epsilon_rho=epsilon_rho,& - sx=sx,R=R,gamma=gamma,error=error) + sx=sx,R=R,gamma=gamma) CALL xbr_pbe_lda_hole_tc_lr_lsd_calc(rho=rhob, norm_drho=norm_drhob,& laplace_rho=laplace_rhob,tau=tau_b,e_0=e_0,e_rho=e_rhob,e_ndrho=e_ndrhob,& e_tau=e_tau_b,e_laplace_rho=e_laplace_rhob,grad_deriv=grad_deriv, & npoints=npoints,epsilon_rho=epsilon_rho,& - sx=sx,R=R,gamma=gamma,error=error) + sx=sx,R=R,gamma=gamma) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -660,13 +643,11 @@ END SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_eval !> \param sx parameters for functional !> \param R parameters for functional !> \param gamma parameters for functional -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \author mguidon (01.2009) ! ***************************************************************************** SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_calc(rho,norm_drho,laplace_rho,tau,e_0,e_rho,& e_ndrho,e_tau,e_laplace_rho,grad_deriv,npoints,& - epsilon_rho,sx,R,gamma,error) + epsilon_rho,sx,R,gamma) INTEGER, INTENT(in) :: npoints, grad_deriv REAL(kind=dp), DIMENSION(1:npoints), & @@ -676,7 +657,6 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_calc(rho,norm_drho,laplace_rho,tau,e_0,e_r INTENT(in) :: tau, laplace_rho, norm_drho, & rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R, gamma - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: & routineN = 'xbr_pbe_lda_hole_tc_lr_lsd_calc', & @@ -719,21 +699,21 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_calc(rho,norm_drho,laplace_rho,tau,e_0,e_r IF( yval <= 0.0_dp) THEN CALL x_br_lsd_y_lte_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) ELSE CALL x_br_lsd_y_gt_0(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, gamma, grad_deriv, error) + sx, gamma, grad_deriv) END IF ELSE IF( yval <= 0.0_dp) THEN CALL x_br_lsd_y_lte_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) ELSE CALL x_br_lsd_y_gt_0_cutoff(my_rho, my_ndrho, my_tau, my_laplace_rho, e_0_br, & e_rho_br, e_ndrho_br, e_tau_br, e_laplace_rho_br,& - sx, R, gamma, grad_deriv, error) + sx, R, gamma, grad_deriv) END IF END IF @@ -777,7 +757,7 @@ SUBROUTINE xbr_pbe_lda_hole_tc_lr_lsd_calc(rho,norm_drho,laplace_rho,tau,e_0,e_r e_0_lda = 0.0_dp e_rho_lda = 0.0_dp CALL xlda_hole_t_c_lr_lda_calc_0(grad_deriv, my_rho, e_0_lda, e_rho_lda,& - sx, R, error) + sx, R) e_0_lda = 0.5_dp * e_0_lda Fx = e_0_br/e_0_lda diff --git a/src/xc/xc_xlda_hole_t_c_lr.F b/src/xc/xc_xlda_hole_t_c_lr.F index 417084ba89..ad7b9f9d4d 100644 --- a/src/xc/xc_xlda_hole_t_c_lr.F +++ b/src/xc/xc_xlda_hole_t_c_lr.F @@ -56,18 +56,15 @@ MODULE xc_xlda_hole_t_c_lr !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv controls the number of derivatives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xlda_hole_t_c_lr_lda_info (reference, shortform, needs, max_deriv, error) + SUBROUTINE xlda_hole_t_c_lr_lda_info (reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "{LDA version}" @@ -89,18 +86,15 @@ END SUBROUTINE xlda_hole_t_c_lr_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv controls the number of derivatives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xlda_hole_t_c_lr_lsd_info (reference, shortform, needs, max_deriv, error) + SUBROUTINE xlda_hole_t_c_lr_lsd_info (reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "{LSD version}" @@ -124,19 +118,16 @@ END SUBROUTINE xlda_hole_t_c_lr_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param params input parameters (scaling, cutoff_radius) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xlda_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params, error ) + SUBROUTINE xlda_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order TYPE(section_vals_type), POINTER :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xlda_hole_t_c_lr_lda_eval', & routineP = moduleN//':'//routineN @@ -154,26 +145,25 @@ SUBROUTINE xlda_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params, error NULLIFY(bo) - CALL section_vals_val_get(params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R,error=error) + CALL section_vals_val_get(params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -183,33 +173,33 @@ SUBROUTINE xlda_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params, error IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) END IF IF (order>1.OR.order<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 1 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF ( R == 0.0_dp ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Cutoff_Radius 0.0 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF CALL xlda_hole_t_c_lr_lda_calc(npoints,order,rho=rho,& e_0=e_0,e_rho=e_rho,& epsilon_rho=epsilon_rho,& - sx=sx,R=R,error=error) + sx=sx,R=R) IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -227,20 +217,17 @@ END SUBROUTINE xlda_hole_t_c_lr_lda_eval !> \param epsilon_rho ... !> \param sx ... !> \param R ... -!> \param error ... !> \par History !> 12.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE xlda_hole_t_c_lr_lda_calc(npoints, order, rho, e_0, e_rho,& - epsilon_rho,sx, R,& - error) + epsilon_rho,sx, R) INTEGER, INTENT(in) :: npoints, order REAL(kind=dp), DIMENSION(1:npoints), & INTENT(inout) :: rho, e_0, e_rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xlda_hole_t_c_lr_lda_calc', & routineP = moduleN//':'//routineN @@ -250,14 +237,14 @@ SUBROUTINE xlda_hole_t_c_lr_lda_calc(npoints, order, rho, e_0, e_rho,& !$omp parallel do default(none) & !$omp shared(npoints, rho, epsilon_rho, order, e_0, e_rho) & - !$omp shared(sx, r, error) & + !$omp shared(sx, r) & !$omp private(ip, my_rho) DO ip =1,npoints my_rho = MAX(rho(ip),0.0_dp) IF(my_rho > epsilon_rho) THEN CALL xlda_hole_t_c_lr_lda_calc_0(order, my_rho, e_0(ip), e_rho(ip),& - sx, R, error) + sx, R) END IF END DO @@ -273,19 +260,16 @@ END SUBROUTINE xlda_hole_t_c_lr_lda_calc !> \param e_rho ... !> \param sx ... !> \param R ... -!> \param error ... !> \par History !> 12.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE xlda_hole_t_c_lr_lda_calc_0(order, rho, e_0, e_rho,& - sx, R,& - error) + sx, R) INTEGER, INTENT(IN) :: order REAL(KIND=dp), INTENT(IN) :: rho REAL(kind=dp), INTENT(INOUT) :: e_0, e_rho REAL(KIND=dp), INTENT(IN) :: sx, R - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xlda_hole_t_c_lr_lda_calc_0', & routineP = moduleN//':'//routineN @@ -351,19 +335,16 @@ END SUBROUTINE xlda_hole_t_c_lr_lda_calc_0 !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param params input parameters (scaling, cutoff_radius) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 12.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xlda_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params, error ) + SUBROUTINE xlda_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order TYPE(section_vals_type), POINTER :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xlda_hole_t_c_lr_lsd_eval', & routineP = moduleN//':'//routineN @@ -382,26 +363,25 @@ SUBROUTINE xlda_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params, error NULLIFY(bo) - CALL section_vals_val_get(params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R,error=error) + CALL section_vals_val_get(params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=rhoa, rhob=rhob,& - local_bounds=bo,rho_cutoff=epsilon_rho,& - error=error) + local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -412,46 +392,46 @@ SUBROUTINE xlda_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params, error IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) END IF IF (order>1.OR.order<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF ( R == 0.0_dp ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Cutoff_Radius 0.0 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(npoints, order, rhoa, e_0, e_rhoa, epsilon_rho) & - !$omp shared(sx, r, error, rhob, e_rhob) + !$omp shared(sx, r,rhob, e_rhob) CALL xlda_hole_t_c_lr_lsd_calc(npoints,order,rho=rhoa,& e_0=e_0,e_rho=e_rhoa,& epsilon_rho=epsilon_rho,& - sx=sx,R=R,error=error) + sx=sx,R=R) CALL xlda_hole_t_c_lr_lsd_calc(npoints,order,rho=rhob,& e_0=e_0,e_rho=e_rhob,& epsilon_rho=epsilon_rho,& - sx=sx,R=R,error=error) + sx=sx,R=R) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -469,20 +449,17 @@ END SUBROUTINE xlda_hole_t_c_lr_lsd_eval !> \param epsilon_rho ... !> \param sx ... !> \param R ... -!> \param error ... !> \par History !> 12.2008 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** SUBROUTINE xlda_hole_t_c_lr_lsd_calc(npoints, order, rho, e_0, e_rho,& - epsilon_rho,sx, R,& - error) + epsilon_rho,sx, R) INTEGER, INTENT(in) :: npoints, order REAL(kind=dp), DIMENSION(1:npoints), & INTENT(inout) :: rho, e_0, e_rho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xlda_hole_t_c_lr_lsd_calc', & routineP = moduleN//':'//routineN @@ -497,7 +474,7 @@ SUBROUTINE xlda_hole_t_c_lr_lsd_calc(npoints, order, rho, e_0, e_rho,& IF(my_rho > epsilon_rho) THEN e_tmp = 0.0_dp CALL xlda_hole_t_c_lr_lda_calc_0(order, my_rho, e_tmp , e_rho(ip),& - sx, R, error) + sx, R) e_0(ip) = e_0(ip) + 0.5_dp * e_tmp END IF END DO diff --git a/src/xc/xc_xpbe_hole_t_c_lr.F b/src/xc/xc_xpbe_hole_t_c_lr.F index 99810fb778..83cc7d13b3 100644 --- a/src/xc/xc_xpbe_hole_t_c_lr.F +++ b/src/xc/xc_xpbe_hole_t_c_lr.F @@ -79,18 +79,15 @@ MODULE xc_xpbe_hole_t_c_lr !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv controls the number of derivatives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2009 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xpbe_hole_t_c_lr_lda_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE xpbe_hole_t_c_lr_lda_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "{LDA version}" @@ -113,18 +110,15 @@ END SUBROUTINE xpbe_hole_t_c_lr_lda_info !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv controls the number of derivatives -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2009 created [mguidon] !> \author mguidon ! ***************************************************************************** - SUBROUTINE xpbe_hole_t_c_lr_lsd_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE xpbe_hole_t_c_lr_lsd_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "{LSD version}" @@ -149,20 +143,17 @@ END SUBROUTINE xpbe_hole_t_c_lr_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param params input parameters (scaling,cutoff) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2009 created [Manuel Guidon] !> \author Manuel Guidon !> \note ! ***************************************************************************** - SUBROUTINE xpbe_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params, error ) + SUBROUTINE xpbe_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order TYPE(section_vals_type), POINTER :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xpbe_hole_t_c_lr_lda_eval', & routineP = moduleN//':'//routineN @@ -181,25 +172,25 @@ SUBROUTINE xpbe_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params, error NULLIFY(bo) - CALL section_vals_val_get(params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R,error=error) + CALL section_vals_val_get(params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& - norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,error=error) + norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -210,44 +201,44 @@ SUBROUTINE xpbe_hole_t_c_lr_lda_eval ( rho_set, deriv_set, order, params, error IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (order>1.OR.order<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF ( R == 0.0_dp ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Cutoff_Radius 0.0 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(npoints, order, rho, norm_drho, e_0, e_rho) & !$omp shared(e_ndrho, epsilon_rho) & - !$omp shared(sx, r, error) + !$omp shared(sx, r) CALL xpbe_hole_t_c_lr_lda_calc(npoints,order,rho=rho, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,& epsilon_rho=epsilon_rho,& - sx=sx,R=R,error=error) + sx=sx,R=R) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -268,8 +259,6 @@ END SUBROUTINE xpbe_hole_t_c_lr_lda_eval !> \param epsilon_rho cutoffs !> \param sx functional parameters !> \param R functional parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2009 created [Manuel Guidon] !> \author Manuel Guidon @@ -277,15 +266,13 @@ END SUBROUTINE xpbe_hole_t_c_lr_lda_eval !> ! ***************************************************************************** SUBROUTINE xpbe_hole_t_c_lr_lda_calc(npoints, order, rho, norm_drho, e_0, e_rho, e_ndrho,& - epsilon_rho, sx, R,& - error) + epsilon_rho, sx, R) INTEGER, INTENT(in) :: npoints, order REAL(kind=dp), DIMENSION(1:npoints), & INTENT(inout) :: rho, norm_drho, e_0, e_rho, & e_ndrho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xpbe_hole_t_c_lr_lda_calc', & routineP = moduleN//':'//routineN @@ -340,20 +327,17 @@ END SUBROUTINE xpbe_hole_t_c_lr_lda_calc !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param params input parameters (scaling,cutoff) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2009 created [Manuel Guidon] !> \author Manuel Guidon !> \note ! ***************************************************************************** - SUBROUTINE xpbe_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params, error ) + SUBROUTINE xpbe_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order TYPE(section_vals_type), POINTER :: params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xpbe_hole_t_c_lr_lsd_eval', & routineP = moduleN//':'//routineN @@ -374,25 +358,25 @@ SUBROUTINE xpbe_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params, error NULLIFY(bo) - CALL section_vals_val_get(params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R,error=error) + CALL section_vals_val_get(params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(params,"CUTOFF_RADIUS",r_val=R) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=rhoa,rhob=rhob,& - norm_drhoa=norm_drhoa,norm_drhob=norm_drhob,local_bounds=bo,rho_cutoff=epsilon_rho,error=error) + norm_drhoa=norm_drhoa,norm_drhob=norm_drhob,local_bounds=bo,rho_cutoff=epsilon_rho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -405,52 +389,52 @@ SUBROUTINE xpbe_hole_t_c_lr_lsd_eval ( rho_set, deriv_set, order, params, error IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) END IF IF (order>1.OR.order<-1) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF IF ( R == 0.0_dp ) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="Cutoff_Radius 0.0 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(npoints, order, rhoa, norm_drhoa, e_0, e_rhoa) & - !$omp shared(epsilon_rho, sx, r, error) & + !$omp shared(epsilon_rho, sx, r) & !$omp shared(rhob, norm_drhob, e_rhob, e_ndrhoa, e_ndrhob) CALL xpbe_hole_t_c_lr_lsd_calc(npoints,order,rho=rhoa, norm_drho=norm_drhoa,& e_0=e_0,e_rho=e_rhoa,e_ndrho=e_ndrhoa,& - epsilon_rho=epsilon_rho,sx=sx,R=R,error=error) + epsilon_rho=epsilon_rho,sx=sx,R=R) CALL xpbe_hole_t_c_lr_lsd_calc(npoints,order,rho=rhob, norm_drho=norm_drhob,& e_0=e_0,e_rho=e_rhob,e_ndrho=e_ndrhob,& - epsilon_rho=epsilon_rho,sx=sx,R=R,error=error) + epsilon_rho=epsilon_rho,sx=sx,R=R) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -471,8 +455,6 @@ END SUBROUTINE xpbe_hole_t_c_lr_lsd_eval !> \param epsilon_rho cutoffs !> \param sx functional parameters !> \param R functional parameters -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 01.2009 created [Manuel Guidon] !> \author Manuel Guidon @@ -480,15 +462,13 @@ END SUBROUTINE xpbe_hole_t_c_lr_lsd_eval !> the lda version applying spin scaling relations ! ***************************************************************************** SUBROUTINE xpbe_hole_t_c_lr_lsd_calc(npoints, order, rho, norm_drho, e_0, e_rho, e_ndrho,& - epsilon_rho, sx, R,& - error) + epsilon_rho, sx, R) INTEGER, INTENT(in) :: npoints, order REAL(kind=dp), DIMENSION(1:npoints), & INTENT(inout) :: rho, norm_drho, e_0, e_rho, & e_ndrho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, R - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xpbe_hole_t_c_lr_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc/xc_xwpbe.F b/src/xc/xc_xwpbe.F index 7a5e4b3317..1ca55feeda 100644 --- a/src/xc/xc_xwpbe.F +++ b/src/xc/xc_xwpbe.F @@ -100,18 +100,15 @@ MODULE xc_xwpbe !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xwpbe_lda_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE xwpbe_lda_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "Jochen Heyd and Gustavo E. Scuseria, J. Chem. Phys., 120, 7274 {LDA version}" @@ -135,8 +132,6 @@ END SUBROUTINE xwpbe_lda_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param xwpbe_params input parameters (scaling,omega) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -145,13 +140,12 @@ END SUBROUTINE xwpbe_lda_info !> Using the maple sheet in cp2k/doc it is straightforward to produce routines !> for higher derivatives. ! ***************************************************************************** - SUBROUTINE xwpbe_lda_eval ( rho_set, deriv_set, order, xwpbe_params, error ) + SUBROUTINE xwpbe_lda_eval ( rho_set, deriv_set, order, xwpbe_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order TYPE(section_vals_type), POINTER :: xwpbe_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xwpbe_lda_eval', & routineP = moduleN//':'//routineN @@ -174,26 +168,26 @@ SUBROUTINE xwpbe_lda_eval ( rho_set, deriv_set, order, xwpbe_params, error ) NULLIFY(bo) CALL cite_reference(Heyd2004) - CALL section_vals_val_get(xwpbe_params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(xwpbe_params,"SCALE_X0",r_val=sx0,error=error) - CALL section_vals_val_get(xwpbe_params,"OMEGA",r_val=omega,error=error) + CALL section_vals_val_get(xwpbe_params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(xwpbe_params,"SCALE_X0",r_val=sx0) + CALL section_vals_val_get(xwpbe_params,"OMEGA",r_val=omega) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rho=rho,& norm_drho=norm_drho,local_bounds=bo,rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_norm_drho,error=error) + drho_cutoff=epsilon_norm_drho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rho END IF @@ -207,49 +201,49 @@ SUBROUTINE xwpbe_lda_eval ( rho_set, deriv_set, order, xwpbe_params, error ) IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho) END IF IF (order>=2.OR.order==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rho_rho) deriv => xc_dset_get_derivative(deriv_set,"(norm_drho)(rho)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_rho) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho,error=error) + "(norm_drho)(norm_drho)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrho_ndrho) END IF IF (order>2.OR.order<-2) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(npoints, order, rho, norm_drho, e_0, e_rho, e_ndrho) & !$omp shared(e_rho_rho, e_ndrho_rho, e_ndrho_ndrho, epsilon_rho) & - !$omp shared(sx, sx0, omega, error) + !$omp shared(sx, sx0, omega) CALL xwpbe_lda_calc(npoints,order,rho=rho, norm_drho=norm_drho,& e_0=e_0,e_rho=e_rho,e_ndrho=e_ndrho,e_rho_rho=e_rho_rho,& e_ndrho_rho=e_ndrho_rho, e_ndrho_ndrho=e_ndrho_ndrho, & - epsilon_rho=epsilon_rho,sx=sx,sx0=sx0,omega=omega,error=error) + epsilon_rho=epsilon_rho,sx=sx,sx0=sx0,omega=omega) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -275,8 +269,6 @@ END SUBROUTINE xwpbe_lda_eval !> \param sx , sx0: scaling factor for omega!=0 and omega=0 !> \param sx0 ... !> \param omega screening parameter -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -287,8 +279,7 @@ END SUBROUTINE xwpbe_lda_eval ! ***************************************************************************** SUBROUTINE xwpbe_lda_calc(npoints, order, rho, norm_drho, e_0, e_rho, e_ndrho,& e_rho_rho, e_ndrho_rho, e_ndrho_ndrho,& - epsilon_rho, sx, sx0, omega,& - error) + epsilon_rho, sx, sx0, omega) INTEGER, INTENT(in) :: npoints, order REAL(kind=dp), DIMENSION(1:npoints), & @@ -296,7 +287,6 @@ SUBROUTINE xwpbe_lda_calc(npoints, order, rho, norm_drho, e_0, e_rho, e_ndrho,& e_ndrho, e_rho_rho, & e_ndrho_rho, e_ndrho_ndrho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, sx0, omega - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xwpbe_lda_calc', & routineP = moduleN//':'//routineN @@ -5314,18 +5304,15 @@ END SUBROUTINE xwpbe_lda_calc_4 !> \param needs the components needed by this functional are set to !> true (does not set the unneeded components to false) !> \param max_deriv ... -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2007 created [Manuel Guidon] !> \author Manuel Guidon ! ***************************************************************************** - SUBROUTINE xwpbe_lsd_info ( reference, shortform, needs, max_deriv, error) + SUBROUTINE xwpbe_lsd_info ( reference, shortform, needs, max_deriv) CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: reference, shortform TYPE(xc_rho_cflags_type), & INTENT(inout), OPTIONAL :: needs INTEGER, INTENT(out), OPTIONAL :: max_deriv - TYPE(cp_error_type), INTENT(inout) :: error IF ( PRESENT ( reference ) ) THEN reference = "Jochen Heyd and Gustavo E. Scuseria, J. Chem. Phys., 120, 7274 {LSD version}" @@ -5349,8 +5336,6 @@ END SUBROUTINE xwpbe_lsd_info !> if positive all the derivatives up to the given degree are evaluated, !> if negative only the given degree is calculated !> \param xwpbe_params input parameters (scaling,omega) -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -5359,13 +5344,12 @@ END SUBROUTINE xwpbe_lsd_info !> Using the maple sheet in cp2k/doc it is straightforward to produce routines !> for higher derivatives. ! ***************************************************************************** - SUBROUTINE xwpbe_lsd_eval ( rho_set, deriv_set, order, xwpbe_params, error ) + SUBROUTINE xwpbe_lsd_eval ( rho_set, deriv_set, order, xwpbe_params) TYPE(xc_rho_set_type), POINTER :: rho_set TYPE(xc_derivative_set_type), POINTER :: deriv_set INTEGER, INTENT(IN) :: order TYPE(section_vals_type), POINTER :: xwpbe_params - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xwpbe_lsd_eval', & routineP = moduleN//':'//routineN @@ -5388,25 +5372,25 @@ SUBROUTINE xwpbe_lsd_eval ( rho_set, deriv_set, order, xwpbe_params, error ) CALL cite_reference(Heyd2004) - CALL section_vals_val_get(xwpbe_params,"SCALE_X",r_val=sx,error=error) - CALL section_vals_val_get(xwpbe_params,"SCALE_X0",r_val=sx0,error=error) - CALL section_vals_val_get(xwpbe_params,"OMEGA",r_val=omega,error=error) + CALL section_vals_val_get(xwpbe_params,"SCALE_X",r_val=sx) + CALL section_vals_val_get(xwpbe_params,"SCALE_X0",r_val=sx0) + CALL section_vals_val_get(xwpbe_params,"OMEGA",r_val=omega) - CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,error,failure) - CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,error,failure) - CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(rho_set),cp_failure_level,routineP,failure) + CPPrecondition(rho_set%ref_count>0,cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(deriv_set),cp_failure_level,routineP,failure) + CPPrecondition(deriv_set%ref_count>0,cp_failure_level,routineP,failure) CALL xc_rho_set_get(rho_set,rhoa=rhoa,rhob=rhob,norm_drhoa=norm_drhoa,& norm_drhob=norm_drhob,local_bounds=bo,rho_cutoff=epsilon_rho,& - drho_cutoff=epsilon_norm_drho,error=error) + drho_cutoff=epsilon_norm_drho) npoints=(bo(2,1)-bo(1,1)+1)*(bo(2,2)-bo(1,2)+1)*(bo(2,3)-bo(1,3)+1) ! meaningful default for the arrays we don't need: let us make compiler ! and debugger happy... IF (cp_debug) THEN ALLOCATE(dummy(bo(1,1):bo(2,1),bo(1,2):bo(2,2),bo(1,3):bo(2,3)),stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ELSE dummy=> rhoa END IF @@ -5425,53 +5409,53 @@ SUBROUTINE xwpbe_lsd_eval ( rho_set, deriv_set, order, xwpbe_params, error ) IF (order>=0) THEN deriv => xc_dset_get_derivative(deriv_set,"",& - allocate_deriv=.TRUE., error=error) - CALL xc_derivative_get(deriv,deriv_data=e_0,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_0) END IF IF (order>=1.OR.order==-1) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob) END IF IF (order>=2.OR.order==-2) THEN deriv => xc_dset_get_derivative(deriv_set,"(rhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhoa_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(rhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_rhob_rhob) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhoa)(rhoa)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhoa,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_rhoa) deriv => xc_dset_get_derivative(deriv_set,"(norm_drhob)(rhob)",& - allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhob,error=error) + allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_rhob) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhoa)(norm_drha)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhoa,error=error) + "(norm_drhoa)(norm_drha)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhoa_ndrhoa) deriv => xc_dset_get_derivative(deriv_set,& - "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.,error=error) - CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_ndrhob,error=error) + "(norm_drhob)(norm_drhob)", allocate_deriv=.TRUE.) + CALL xc_derivative_get(deriv,deriv_data=e_ndrhob_ndrhob) END IF IF (order>2.OR.order<-2) THEN CALL cp_unimplemented_error(fromWhere=routineP, & message="derivatives bigger than 2 not implemented", & - error=error, error_level=cp_failure_level) + error_level=cp_failure_level) END IF !$omp parallel default(none) & !$omp shared(npoints, order, rhoa, norm_drhoa, e_0, e_rhoa, e_ndrhoa) & !$omp shared(e_rhoa_rhoa, e_ndrhoa_rhoa, e_ndrhoa_ndrhoa, epsilon_rho) & - !$omp shared(sx, sx0, omega, error) & + !$omp shared(sx, sx0, omega) & !$omp shared(rhob, norm_drhob, e_rhob, e_ndrhob, e_rhob_rhob) & !$omp shared(e_ndrhob_rhob, e_ndrhob_ndrhob) @@ -5481,18 +5465,18 @@ SUBROUTINE xwpbe_lsd_eval ( rho_set, deriv_set, order, xwpbe_params, error ) e_0=e_0,e_rho=e_rhoa,e_ndrho=e_ndrhoa,e_rho_rho=e_rhoa_rhoa, & e_ndrho_rho=e_ndrhoa_rhoa, e_ndrho_ndrho=e_ndrhoa_ndrhoa, & epsilon_rho=epsilon_rho, & - sx=sx,sx0=sx0,omega=omega,error=error) + sx=sx,sx0=sx0,omega=omega) CALL xwpbe_lsd_calc(npoints,order, rho=rhob, norm_drho=norm_drhob, & e_0=e_0,e_rho=e_rhob,e_ndrho=e_ndrhob,e_rho_rho=e_rhob_rhob, & e_ndrho_rho=e_ndrhob_rhob, e_ndrho_ndrho=e_ndrhob_ndrhob, & epsilon_rho=epsilon_rho,& - sx=sx,sx0=sx0,omega=omega,error=error) + sx=sx,sx0=sx0,omega=omega) !$omp end parallel IF (cp_debug) THEN DEALLOCATE(dummy,stat=stat) - CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) + CPPostconditionNoFail(stat==0,cp_warning_level,routineP) ELSE NULLIFY(dummy) END IF @@ -5518,8 +5502,6 @@ END SUBROUTINE xwpbe_lsd_eval !> \param sx , sx0: scaling factor for omega!=0 and omega=0 !> \param sx0 ... !> \param omega screening parameter -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 05.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -5535,8 +5517,7 @@ END SUBROUTINE xwpbe_lsd_eval ! ***************************************************************************** SUBROUTINE xwpbe_lsd_calc(npoints, order, rho, norm_drho, e_0, e_rho, e_ndrho, & e_rho_rho, e_ndrho_rho, e_ndrho_ndrho, & - epsilon_rho,sx, sx0, omega, & - error) + epsilon_rho,sx, sx0, omega) INTEGER, INTENT(in) :: npoints, order REAL(kind=dp), DIMENSION(1:npoints), & @@ -5544,7 +5525,6 @@ SUBROUTINE xwpbe_lsd_calc(npoints, order, rho, norm_drho, e_0, e_rho, e_ndrho, & e_ndrho, e_rho_rho, & e_ndrho_rho, e_ndrho_ndrho REAL(kind=dp), INTENT(in) :: epsilon_rho, sx, sx0, omega - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xwpbe_lsd_calc', & routineP = moduleN//':'//routineN diff --git a/src/xc_adiabatic_methods.F b/src/xc_adiabatic_methods.F index 77e1c97001..040e3744fc 100644 --- a/src/xc_adiabatic_methods.F +++ b/src/xc_adiabatic_methods.F @@ -40,8 +40,6 @@ MODULE xc_adiabatic_methods !> \param scale_dDFA scaling coefficient for xc-potentials to be calculated !> \param scale_dEx2 scaling coefficient for xc-potentials to be calculated !> \param total_energy_xc will contain the full xc energy -!> \param error variable to control error logging, stopping,... -!> see module cp_error_handling !> \par History !> 09.2007 created [Manuel Guidon] !> \author Manuel Guidon @@ -56,7 +54,7 @@ MODULE xc_adiabatic_methods ! ***************************************************************************** SUBROUTINE rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & adiabatic_omega, scale_dEx1, scale_ddW0, scale_dDFA,& - scale_dEx2, total_energy_xc, error) + scale_dEx2, total_energy_xc) TYPE(qs_environment_type), POINTER :: qs_env REAL(dp), INTENT(INOUT) :: hf_energy(*) @@ -66,7 +64,6 @@ SUBROUTINE rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & REAL(dp), INTENT(INOUT) :: scale_dEx1, scale_ddW0, & scale_dDFA, scale_dEx2, & total_energy_xc - TYPE(cp_error_type), INTENT(inout) :: error INTEGER :: nelec_a, nelec_b, nelectron, & nspins @@ -89,7 +86,7 @@ SUBROUTINE rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & c1 = 0.23163_dp - CALL get_qs_env(qs_env=qs_env, mos=mos, error=error) + CALL get_qs_env(qs_env=qs_env, mos=mos) CALL get_mo_set(mo_set=mos(1)%mo_set,nelectron=nelec_a) nspins = SIZE(mos) IF(nspins == 2 ) THEN diff --git a/src/xc_adiabatic_utils.F b/src/xc_adiabatic_utils.F index 1502452d73..86831a0a9d 100644 --- a/src/xc_adiabatic_utils.F +++ b/src/xc_adiabatic_utils.F @@ -63,10 +63,9 @@ MODULE xc_adiabatic_utils !> \param just_energy ... !> \param calculate_forces ... !> \param use_virial ... -!> \param error ... ! ***************************************************************************** SUBROUTINE rescale_xc_potential(qs_env,ks_matrix,rho,energy,v_rspace_new,v_tau_rspace,& - hf_energy, just_energy,calculate_forces,use_virial,error) + hf_energy, just_energy,calculate_forces,use_virial) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_dbcsr_p_type), DIMENSION(:, :), & @@ -77,7 +76,6 @@ SUBROUTINE rescale_xc_potential(qs_env,ks_matrix,rho,energy,v_rspace_new,v_tau_ REAL(dp), DIMENSION(:) :: hf_energy LOGICAL, INTENT(in) :: just_energy, & calculate_forces, use_virial - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'rescale_xc_potential', & routineP = moduleN//':'//routineN @@ -109,31 +107,30 @@ SUBROUTINE rescale_xc_potential(qs_env,ks_matrix,rho,energy,v_rspace_new,v_tau_ para_env=para_env,& input=input,& rho_xc=rho_xc,& - ks_env=ks_env,& - error=error) + ks_env=ks_env) nimages = dft_control%nimages - CPPrecondition(nimages==1,cp_failure_level,routineP,error,failure) + CPPrecondition(nimages==1,cp_failure_level,routineP,failure) - CALL qs_rho_get(rho, rho_ao_kp=rho_ao, error=error) + CALL qs_rho_get(rho, rho_ao_kp=rho_ao) - adiabatic_rescaling_section => section_vals_get_subs_vals(input,"DFT%XC%ADIABATIC_RESCALING",error=error) - CALL section_vals_get(adiabatic_rescaling_section,explicit=do_adiabatic_rescaling,error=error) - hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF",error=error) - CALL section_vals_get(hfx_sections,explicit=do_hfx,error=error) - CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf,error=error) + adiabatic_rescaling_section => section_vals_get_subs_vals(input,"DFT%XC%ADIABATIC_RESCALING") + CALL section_vals_get(adiabatic_rescaling_section,explicit=do_adiabatic_rescaling) + hfx_sections => section_vals_get_subs_vals(input,"DFT%XC%HF") + CALL section_vals_get(hfx_sections,explicit=do_hfx) + CALL section_vals_get(hfx_sections,n_repetition=n_rep_hf) gapw=dft_control%qs_control%gapw gapw_xc=dft_control%qs_control%gapw_xc CALL section_vals_val_get(adiabatic_rescaling_section, "FUNCTIONAL_TYPE",& - i_val=adiabatic_functional,error=error) + i_val=adiabatic_functional) CALL section_vals_val_get(adiabatic_rescaling_section, "FUNCTIONAL_MODEL",& - i_val=adiabatic_model,error=error) + i_val=adiabatic_model) CALL section_vals_val_get(adiabatic_rescaling_section, "LAMBDA",& - r_val=adiabatic_lambda,error=error) + r_val=adiabatic_lambda) CALL section_vals_val_get(adiabatic_rescaling_section, "OMEGA",& - r_val=adiabatic_omega,error=error) + r_val=adiabatic_omega) SELECT CASE(adiabatic_functional) CASE (do_adiabatic_hybrid_mcy3) SELECT CASE(adiabatic_model) @@ -141,43 +138,42 @@ SUBROUTINE rescale_xc_potential(qs_env,ks_matrix,rho,energy,v_rspace_new,v_tau_ CALL cp_assert( n_rep_hf == 2 , cp_failure_level,cp_assertion_failed,routineP,& " For this kind of adiababatic hybrid functional 2 HF sections have to be provided. "//& " Please check your input file.",& - error,failure) + failure) CALL rescale_MCY3_pade(qs_env, hf_energy, energy, adiabatic_lambda, & adiabatic_omega, scale_dEx1, scale_ddW0, scale_dDFA,& - scale_dEx2, total_energy_xc, error) + scale_dEx2, total_energy_xc) !! Scale and add Fock matrix to KS matrix IF(do_hfx) THEN CALL scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, 1 ,& - scale_dEx1, error) + scale_dEx1) CALL scale_and_add_fock_to_ks_matrix(para_env, qs_env, ks_matrix, 2 ,& - scale_dEx2, error) + scale_dEx2) END IF IF( calculate_forces ) THEN - CPPrecondition(.NOT.use_virial,cp_failure_level,routineP,error,failure) + CPPrecondition(.NOT.use_virial,cp_failure_level,routineP,failure) !! we also have to scale the forces!!!! CALL derivatives_four_center(qs_env, rho_ao, hfx_sections, para_env, 1, use_virial, & - adiabatic_rescale_factor=scale_dEx1, error=error) + adiabatic_rescale_factor=scale_dEx1) CALL derivatives_four_center(qs_env, rho_ao, hfx_sections, para_env, 2, use_virial, & - adiabatic_rescale_factor=scale_dEx2, error=error) + adiabatic_rescale_factor=scale_dEx2) END IF ! Calculate vxc and rescale it - xc_section => section_vals_get_subs_vals(input,"DFT%XC",error=error) + xc_section => section_vals_get_subs_vals(input,"DFT%XC") IF (gapw_xc) THEN CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho_xc, xc_section=xc_section, & vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=energy%exc, & - just_energy=just_energy ,adiabatic_rescale_factor=scale_dDFA, error=error) + just_energy=just_energy ,adiabatic_rescale_factor=scale_dDFA) ELSE CALL qs_vxc_create(ks_env=ks_env, rho_struct=rho, xc_section=xc_section, & vxc_rho=v_rspace_new, vxc_tau=v_tau_rspace, exc=energy%exc, & - just_energy=just_energy, adiabatic_rescale_factor=scale_dDFA, error=error) + just_energy=just_energy, adiabatic_rescale_factor=scale_dDFA) END IF ! Calculate vxc and rescale it IF (gapw .OR. gapw_xc) THEN - CALL calculate_vxc_atom(qs_env,just_energy,adiabatic_rescale_factor=scale_dDFA,& - error=error) + CALL calculate_vxc_atom(qs_env,just_energy,adiabatic_rescale_factor=scale_dDFA) END IF !! Hack for the total energy expression energy%ex = 0.0_dp diff --git a/src/xc_pot_saop.F b/src/xc_pot_saop.F index f1273ec81a..47b3a6049e 100644 --- a/src/xc_pot_saop.F +++ b/src/xc_pot_saop.F @@ -120,15 +120,13 @@ MODULE xc_pot_saop !> \param ks_matrix ... !> \param qs_env ... !> \param oe_corr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) + SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr) TYPE(cp_dbcsr_p_type), DIMENSION(:), & POINTER :: ks_matrix TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: oe_corr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'add_saop_pot', & routineP = moduleN//':'//routineN @@ -183,7 +181,7 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) NULLIFY(vxc_GLLB, vxc_LB, vxc_tmp, vxc_SAOP, vxc_tau) NULLIFY(mo_eigenvalues, deriv_set, deriv, rho_struct_r, rho_struct_ao) NULLIFY(orbital_density_matrix, dummy,xc_section_tmp,xc_fun_section_tmp) - logger => cp_error_get_logger(error) + logger => cp_get_default_logger() ionode = (logger%para_env%mepos==logger%para_env%source) output_unit = cp_logger_get_default_io_unit(logger) @@ -195,25 +193,25 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) pw_env=pw_env,& input=input,& virial=virial,& - mos=molecular_orbitals,error=error) + mos=molecular_orbitals) compute_virial=virial%pv_calculate.AND.(.NOT.virial%pv_numer) - CALL section_vals_val_get(input,"DFT%QS%METHOD",i_val=dft_method_id,error=error) + CALL section_vals_val_get(input,"DFT%QS%METHOD",i_val=dft_method_id) gapw = (dft_method_id==do_method_gapw) - xc_section_orig => section_vals_get_subs_vals(input,"DFT%XC",error=error) - CALL section_vals_retain(xc_section_orig,error=error) - CALL section_vals_duplicate(xc_section_orig,xc_section_tmp,error=error) + xc_section_orig => section_vals_get_subs_vals(input,"DFT%XC") + CALL section_vals_retain(xc_section_orig) + CALL section_vals_duplicate(xc_section_orig,xc_section_tmp) CALL section_vals_val_get(xc_section_orig,"DENSITY_CUTOFF",& - r_val=density_cut,error=error) + r_val=density_cut) CALL section_vals_val_get(xc_section_orig,"GRADIENT_CUTOFF",& - r_val=gradient_cut,error=error) + r_val=gradient_cut) CALL section_vals_val_get(xc_section_orig,"TAU_CUTOFF",& - r_val=tau_cut,error=error) + r_val=tau_cut) - CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool,error=error) + CALL pw_env_get(pw_env,auxbas_pw_pool=auxbas_pw_pool) - CALL section_vals_val_get(input,"DFT%LSD",l_val=lsd,error=error) + CALL section_vals_val_get(input,"DFT%LSD",l_val=lsd) IF (lsd) THEN nspins=2 ELSE @@ -221,15 +219,15 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) END IF ALLOCATE(rho_r(nspins), single_mo_coeff(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_allocate_matrix_set(orbital_density_matrix,nspins,error=error) - CALL qs_rho_get(rho_struct, rho_r=rho_struct_r, rho_ao=rho_struct_ao, error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_allocate_matrix_set(orbital_density_matrix,nspins) + CALL qs_rho_get(rho_struct, rho_r=rho_struct_r, rho_ao=rho_struct_ao) DO ispin=1,nspins rho_r(ispin)%pw => rho_struct_r(ispin)%pw ALLOCATE(orbital_density_matrix(ispin)%matrix) - CALL cp_dbcsr_init(orbital_density_matrix(ispin)%matrix, error=error) + CALL cp_dbcsr_init(orbital_density_matrix(ispin)%matrix) CALL cp_dbcsr_copy(orbital_density_matrix(ispin)%matrix,& - rho_struct_ao(ispin)%matrix,"orbital density",error=error) + rho_struct_ao(ispin)%matrix,"orbital density") END DO bo = rho_r(1)%pw%pw_grid%bounds_local @@ -239,53 +237,50 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) CALL xc_rho_set_create(rho_set, bo, & density_cut, & gradient_cut, & - tau_cut, & - error=error) - CALL xc_rho_cflags_setall(needs,.FALSE.,error) + tau_cut) + CALL xc_rho_cflags_setall(needs,.FALSE.) IF (lsd) THEN - CALL xb88_lsd_info(needs=needs,error=error) + CALL xb88_lsd_info(needs=needs) needs%norm_drho = .TRUE. ELSE - CALL xb88_lda_info(needs=needs,error=error) + CALL xb88_lda_info(needs=needs) END IF CALL section_vals_val_get(xc_section_orig,"XC_GRID%XC_DERIV",& - i_val=xc_deriv_method_id,error=error) + i_val=xc_deriv_method_id) CALL section_vals_val_get(xc_section_orig,"XC_GRID%XC_SMOOTH_RHO",& - i_val=xc_rho_smooth_id,error=error) + i_val=xc_rho_smooth_id) CALL xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs, & xc_deriv_method_id,& xc_rho_smooth_id,& - auxbas_pw_pool, error) + auxbas_pw_pool) !----------------------------------------! ! Construct the LB94 potential in vxc_LB ! !----------------------------------------! xc_fun_section_orig => section_vals_get_subs_vals(xc_section_orig,& - "XC_FUNCTIONAL",error=error) - CALL section_vals_create(xc_fun_section_tmp,xc_fun_section_orig%section,& - error=error) + "XC_FUNCTIONAL") + CALL section_vals_create(xc_fun_section_tmp,xc_fun_section_orig%section) CALL section_vals_val_set(xc_fun_section_tmp,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CALL section_vals_val_set(xc_fun_section_tmp,"XALPHA%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_set_subs_vals(xc_section_tmp,"XC_FUNCTIONAL",& - xc_fun_section_tmp,error=error) + xc_fun_section_tmp) - CPPostcondition(.NOT.compute_virial,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.compute_virial,cp_failure_level,routineP,failure) CALL xc_vxc_pw_create(vxc_tmp, vxc_tau, xc_energy, rho_r, rho_g, tau,& xc_section_tmp, auxbas_pw_pool, & - error,compute_virial=.FALSE.,virial_xc=virial_xc_tmp) + compute_virial=.FALSE.,virial_xc=virial_xc_tmp) CALL section_vals_val_set(xc_fun_section_tmp,"XALPHA%_SECTION_PARAMETERS_",& - l_val=.FALSE.,error=error) + l_val=.FALSE.) CALL section_vals_val_set(xc_fun_section_tmp,"PZ81%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) - CPPostcondition(.NOT.compute_virial,cp_failure_level,routineP,error,failure) + CPPostcondition(.NOT.compute_virial,cp_failure_level,routineP,failure) CALL xc_vxc_pw_create(vxc_LB, vxc_tau, xc_energy, rho_r, rho_g, tau,& xc_section_tmp, auxbas_pw_pool, & - compute_virial=.FALSE.,virial_xc=virial_xc_tmp,& - error=error) + compute_virial=.FALSE.,virial_xc=virial_xc_tmp) DO ispin=1, nspins vxc_LB(ispin)%pw%cr3d = vxc_LB(ispin)%pw%cr3d + alpha*vxc_tmp(ispin)%pw%cr3d @@ -293,7 +288,7 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) DO ispin=1, nspins dummy => vxc_tmp(ispin)%pw%cr3d - CALL add_lb_pot(dummy, rho_set, lsd, ispin, error) + CALL add_lb_pot(dummy, rho_set, lsd, ispin) vxc_LB(ispin)%pw%cr3d = vxc_LB(ispin)%pw%cr3d - vxc_tmp(ispin)%pw%cr3d END DO NULLIFY(dummy) @@ -301,22 +296,21 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) !-----------------------------------------------------------------------------------! ! Construct 2 times PBE one particle density from the PZ correlation energy density ! !-----------------------------------------------------------------------------------! - CALL xc_dset_create(deriv_set, local_bounds=bo, error=error) + CALL xc_dset_create(deriv_set, local_bounds=bo) CALL xc_functionals_eval(xc_fun_section_tmp, & lsd=lsd,& rho_set=rho_set, & deriv_set=deriv_set,& - deriv_order=0, & - error=error) + deriv_order=0) - deriv => xc_dset_get_derivative(deriv_set, "", error=error) - CALL xc_derivative_get(deriv,deriv_data=e_uniform,error=error) + deriv => xc_dset_get_derivative(deriv_set, "") + CALL xc_derivative_get(deriv,deriv_data=e_uniform) ALLOCATE(vxc_GLLB(nspins)) DO ispin=1, nspins CALL pw_pool_create_pw(auxbas_pw_pool, vxc_GLLB(ispin)%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) END DO DO ispin=1, nspins @@ -325,14 +319,14 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) END DO NULLIFY(dummy) - CALL xc_dset_release(deriv_set, error=error) + CALL xc_dset_release(deriv_set) CALL pw_pool_create_pw(auxbas_pw_pool,orbital%pw,& use_data = REALDATA3D,& - in_space = REALSPACE, error=error) + in_space = REALSPACE) CALL pw_pool_create_pw(auxbas_pw_pool,orbital_g%pw,& use_data = COMPLEXDATA1D,& - in_space = RECIPROCALSPACE, error=error) + in_space = RECIPROCALSPACE) DO ispin=1, nspins @@ -342,35 +336,35 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) homo=homo) CALL cp_fm_create(single_mo_coeff(ispin)%matrix, & mo_coeff%matrix_struct, & - "orbital density matrix", error=error) + "orbital density matrix") CALL cp_fm_get_info(single_mo_coeff(ispin)%matrix, & - nrow_global=nrow(ispin), ncol_global=ncol(ispin),error=error) + nrow_global=nrow(ispin), ncol_global=ncol(ispin)) ALLOCATE(coeff_col(nrow(ispin),1)) - CALL pw_zero(vxc_tmp(ispin)%pw,error=error) + CALL pw_zero(vxc_tmp(ispin)%pw) DO orb=1, homo-1 efac = K_rho*SQRT(mo_eigenvalues(homo)-mo_eigenvalues(orb)) IF (.NOT.lsd) efac = 2.0_dp * efac - CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp,error=error) + CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp) CALL cp_fm_get_submatrix(mo_coeff, coeff_col, & - 1, orb, nrow(ispin), 1, error=error) + 1, orb, nrow(ispin), 1) CALL cp_fm_set_submatrix(single_mo_coeff(ispin)%matrix, coeff_col, & - 1, orb, error=error) - CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp,error=error) + 1, orb) + CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(orbital_density_matrix(ispin)%matrix,& matrix_v=single_mo_coeff(ispin)%matrix,& matrix_g=single_mo_coeff(ispin)%matrix,& ncol=ncol(ispin), & - alpha=1.0_dp,error=error) - CALL pw_zero(orbital%pw,error=error) - CALL pw_zero(orbital_g%pw,error=error) + alpha=1.0_dp) + CALL pw_zero(orbital%pw) + CALL pw_zero(orbital_g%pw) CALL calculate_rho_elec(matrix_p=orbital_density_matrix(ispin)%matrix, & rho=orbital, rho_gspace=orbital_g, & - total_rho=tot_rho_psi, ks_env=ks_env, error=error) + total_rho=tot_rho_psi, ks_env=ks_env) vxc_tmp(ispin)%pw%cr3d = vxc_tmp(ispin)%pw%cr3d + & efac * orbital%pw%cr3d @@ -399,7 +393,7 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) ! Assemble SAOP ! !---------------! ALLOCATE(vxc_SAOP(nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DO ispin=1, nspins @@ -408,9 +402,8 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) eigenvalues=mo_eigenvalues,& homo=homo) CALL pw_pool_create_pw(auxbas_pw_pool, vxc_SAOP(ispin)%pw, & - use_data=REALDATA3D, in_space=REALSPACE, & - error=error) - CALL pw_zero(vxc_SAOP(ispin)%pw,error=error) + use_data=REALDATA3D, in_space=REALSPACE) + CALL pw_zero(vxc_SAOP(ispin)%pw) ALLOCATE(coeff_col(nrow(ispin),1)) @@ -426,24 +419,24 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) vxc_tmp(ispin)%pw%cr3d = we_LB*vxc_LB(ispin)%pw%cr3d + & we_GLLB*vxc_GLLB(ispin)%pw%cr3d - CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp,error=error) + CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp) CALL cp_fm_get_submatrix(mo_coeff, coeff_col, & - 1, orb, nrow(ispin), 1, error=error) + 1, orb, nrow(ispin), 1) CALL cp_fm_set_submatrix(single_mo_coeff(ispin)%matrix, coeff_col, & - 1, orb, error=error) - CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp,error=error) + 1, orb) + CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(orbital_density_matrix(ispin)%matrix,& matrix_v=single_mo_coeff(ispin)%matrix,& matrix_g=single_mo_coeff(ispin)%matrix,& ncol=ncol(ispin), & - alpha=1.0_dp,error=error) - CALL pw_zero(orbital%pw,error=error) - CALL pw_zero(orbital_g%pw,error=error) + alpha=1.0_dp) + CALL pw_zero(orbital%pw) + CALL pw_zero(orbital_g%pw) CALL calculate_rho_elec(matrix_p=orbital_density_matrix(ispin)%matrix, & rho=orbital, rho_gspace=orbital_g, & - total_rho=tot_rho_psi, ks_env=ks_env, error=error) + total_rho=tot_rho_psi, ks_env=ks_env) -!TC CALL calculate_wavefunction(mo_coeff,orb,orbital2,orbital2_g,qs_env,error) +!TC CALL calculate_wavefunction(mo_coeff,orb,orbital2,orbital2_g,qs_env) !TC write (*,*) orb, maxval(abs(orbital2%pw%cr3d-orbital%pw%cr3d)) vxc_SAOP(ispin)%pw%cr3d = vxc_SAOP(ispin)%pw%cr3d + & @@ -451,8 +444,8 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) END DO - CALL cp_fm_release(single_mo_coeff(ispin)%matrix, error=error) - CALL cp_dbcsr_deallocate_matrix(orbital_density_matrix(ispin)%matrix,error=error) + CALL cp_fm_release(single_mo_coeff(ispin)%matrix) + CALL cp_dbcsr_deallocate_matrix(orbital_density_matrix(ispin)%matrix) DEALLOCATE(coeff_col) @@ -471,9 +464,9 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) END DO - CALL xc_rho_set_release(rho_set, auxbas_pw_pool, error) - CALL pw_pool_give_back_pw(auxbas_pw_pool, orbital%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool, orbital_g%pw, error=error) + CALL xc_rho_set_release(rho_set, auxbas_pw_pool) + CALL pw_pool_give_back_pw(auxbas_pw_pool, orbital%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool, orbital_g%pw) !--------------------! ! Do the integration ! @@ -490,31 +483,31 @@ SUBROUTINE add_saop_pot(ks_matrix, qs_env, oe_corr, error) CALL integrate_v_rspace(v_rspace=vxc_SAOP(ispin), pmat=rho_struct_ao(ispin), & hmat=ks_matrix(ispin), qs_env=qs_env, & calculate_forces=.FALSE.,& - gapw=gapw, error=error) + gapw=gapw) END DO DO ispin=1, nspins - CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_SAOP(ispin)%pw, error=error) - CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_GLLB(ispin)%pw, error=error) - CALL pw_release(vxc_LB(ispin)%pw,error=error) - CALL pw_release(vxc_tmp(ispin)%pw,error=error) + CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_SAOP(ispin)%pw) + CALL pw_pool_give_back_pw(auxbas_pw_pool, vxc_GLLB(ispin)%pw) + CALL pw_release(vxc_LB(ispin)%pw) + CALL pw_release(vxc_tmp(ispin)%pw) END DO DEALLOCATE(vxc_GLLB, vxc_LB, vxc_tmp, orbital_density_matrix, single_mo_coeff, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(rho_r, vxc_SAOP, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL section_vals_release(xc_fun_section_tmp,error=error) - CALL section_vals_release(xc_section_tmp,error=error) - CALL section_vals_release(xc_section_orig,error=error) + CALL section_vals_release(xc_fun_section_tmp) + CALL section_vals_release(xc_section_tmp) + CALL section_vals_release(xc_section_orig) !-----------------------! ! Call the GAPW routine ! !-----------------------! IF (gapw) THEN - CALL gapw_add_atomic_saop_pot(qs_env, oe_corr, error) + CALL gapw_add_atomic_saop_pot(qs_env, oe_corr) END IF END SUBROUTINE add_saop_pot @@ -523,13 +516,11 @@ END SUBROUTINE add_saop_pot !> \brief ... !> \param qs_env ... !> \param oe_corr ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) + SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: oe_corr - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'gapw_add_atomic_saop_pot', & routineP = moduleN//':'//routineN @@ -611,16 +602,15 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) qs_kind_set=qs_kind_set, & rho_atom_set=rho_atom_set,& matrix_ks=matrix_ks,& - para_env=para_env,& - error=error) + para_env=para_env) - CALL qs_rho_get(rho_structure, rho_ao=rho_struct_ao, error=error) + CALL qs_rho_get(rho_structure, rho_ao=rho_struct_ao) - xc_section_orig => section_vals_get_subs_vals(input,"DFT%XC",error=error) - CALL section_vals_retain(xc_section_orig,error=error) - CALL section_vals_duplicate(xc_section_orig,xc_section_tmp,error=error) + xc_section_orig => section_vals_get_subs_vals(input,"DFT%XC") + CALL section_vals_retain(xc_section_orig) + CALL section_vals_duplicate(xc_section_orig,xc_section_tmp) - CALL section_vals_val_get(input,"DFT%LSD",l_val=lsd,error=error) + CALL section_vals_val_get(input,"DFT%LSD",l_val=lsd) IF (lsd) THEN nspins=2 ELSE @@ -628,24 +618,24 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) END IF CALL section_vals_val_get(xc_section_orig,"DENSITY_CUTOFF",& - r_val=density_cut,error=error) + r_val=density_cut) CALL section_vals_val_get(xc_section_orig,"GRADIENT_CUTOFF",& - r_val=gradient_cut,error=error) + r_val=gradient_cut) CALL section_vals_val_get(xc_section_orig,"TAU_CUTOFF",& - r_val=tau_cut,error=error) + r_val=tau_cut) ! remap pointer ns = SIZE(rho_struct_ao) psmat(1:ns,1:1) => rho_struct_ao(1:ns) - CALL calculate_rho_atom_coeff(qs_env,psmat,error=error) - CALL prepare_gapw_den(qs_env, error=error) + CALL calculate_rho_atom_coeff(qs_env,psmat) + CALL prepare_gapw_den(qs_env) ALLOCATE(mo_coeff(nspins), single_mo_coeff(nspins), & mo_eigenvalues(nspins),& stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL cp_dbcsr_allocate_matrix_set(orbital_density_matrix,nspins,error=error) + CALL cp_dbcsr_allocate_matrix_set(orbital_density_matrix,nspins) DO ispin=1, nspins CALL get_mo_set(molecular_orbitals(ispin)%mo_set, & @@ -654,23 +644,23 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) homo=homo(ispin)) CALL cp_fm_create(single_mo_coeff(ispin)%matrix, & mo_coeff(ispin)%matrix%matrix_struct, & - "orbital density matrix", error=error) + "orbital density matrix") CALL cp_fm_get_info(single_mo_coeff(ispin)%matrix, & - nrow_global=nrow(ispin), ncol_global=ncol(ispin),error=error) + nrow_global=nrow(ispin), ncol_global=ncol(ispin)) ALLOCATE(orbital_density_matrix(ispin)%matrix) - CALL cp_dbcsr_init(orbital_density_matrix(ispin)%matrix, error=error) + CALL cp_dbcsr_init(orbital_density_matrix(ispin)%matrix) CALL cp_dbcsr_copy(orbital_density_matrix(ispin)%matrix,& rho_struct_ao(ispin)%matrix, & - "orbital density", error=error) + "orbital density") END DO - CALL local_rho_set_create(local_rho_set, error=error) - CALL allocate_rho_atom_internals(qs_env, local_rho_set%rho_atom_set,error=error) + CALL local_rho_set_create(local_rho_set) + CALL allocate_rho_atom_internals(qs_env, local_rho_set%rho_atom_set) DO ikind=1, SIZE(atomic_kind_set) CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom) CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom,& - harmonics=harmonics, grid_atom=atomic_grid, error=error) + harmonics=harmonics, grid_atom=atomic_grid) IF(.NOT. paw_atom) CYCLE nr = atomic_grid%nr @@ -679,50 +669,46 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) bounds(2,1) = na bounds(2,2) = nr - CALL xc_dset_create(deriv_set, local_bounds=bounds, error=error) + CALL xc_dset_create(deriv_set, local_bounds=bounds) CALL xc_rho_set_create(rho_set_h, bounds, density_cut,& - gradient_cut, tau_cut,& - error=error) + gradient_cut, tau_cut) CALL xc_rho_set_create(rho_set_s, bounds, density_cut,& - gradient_cut, tau_cut,& - error=error) + gradient_cut, tau_cut) CALL xc_rho_set_create(orb_rho_set_h, bounds, density_cut,& - gradient_cut, tau_cut,& - error=error) + gradient_cut, tau_cut) CALL xc_rho_set_create(orb_rho_set_s, bounds, density_cut,& - gradient_cut, tau_cut,& - error=error) + gradient_cut, tau_cut) - CALL xc_rho_cflags_setall(needs, .FALSE., error=error) + CALL xc_rho_cflags_setall(needs, .FALSE.) IF (lsd) THEN - CALL xb88_lsd_info(needs=needs,error=error) + CALL xb88_lsd_info(needs=needs) needs%norm_drho = .TRUE. ELSE - CALL xb88_lda_info(needs=needs,error=error) + CALL xb88_lda_info(needs=needs) END IF CALL xc_rho_set_atom_update(rho_set_h, needs, nspins, bounds) CALL xc_rho_set_atom_update(rho_set_s, needs, nspins, bounds) - CALL xc_rho_cflags_setall(needs_orbs, .FALSE., error=error) + CALL xc_rho_cflags_setall(needs_orbs, .FALSE.) needs_orbs%rho = .TRUE. IF (lsd) needs_orbs%rho_spin = .TRUE. CALL xc_rho_set_atom_update(orb_rho_set_h, needs, nspins, bounds) CALL xc_rho_set_atom_update(orb_rho_set_s, needs, nspins, bounds) ALLOCATE(rho_h(1:na,1:nspins), rho_s(1:na,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(weight(1:na,1:nr), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vxc_LB_h(1:na,1:nr,1:nspins), vxc_LB_s(1:na,1:nr,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vxc_GLLB_h(1:na,1:nr,1:nspins), vxc_GLLB_s(1:na,1:nr,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vxc_tmp_h(1:na,1:nr,1:nspins), vxc_tmp_s(1:na,1:nr,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(vxc_SAOP_h(1:na,1:nr,1:nspins), vxc_SAOP_s(1:na,1:nr,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ALLOCATE(drho_h(1:4,1:na,1:nr,1:nspins), drho_s(1:4,1:na,1:nr,1:nspins), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! Distribute the atoms of this kind num_pe = para_env%num_pe @@ -744,9 +730,9 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) DO ir=1, nr CALL calc_rho_angular(atomic_grid, harmonics, nspins, .TRUE., & ir, r_h, r_s, rho_h, rho_s, & - dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s, error) - CALL fill_rho_set(rho_set_h,lsd,nspins,needs,rho_h,drho_h,tau,na,ir,error) - CALL fill_rho_set(rho_set_s,lsd,nspins,needs,rho_s,drho_s,tau,na,ir,error) + dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s) + CALL fill_rho_set(rho_set_h,lsd,nspins,needs,rho_h,drho_h,tau,na,ir) + CALL fill_rho_set(rho_set_s,lsd,nspins,needs,rho_s,drho_s,tau,na,ir) DO ia=1, na weight(ia,ir) = atomic_grid%wr(ir)*atomic_grid%wa(ia) END DO @@ -756,52 +742,51 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) ! 1. Slater exchange for LB94 ! !-----------------------------! xc_fun_section_orig => section_vals_get_subs_vals(xc_section_orig,& - "XC_FUNCTIONAL",error=error) - CALL section_vals_create(xc_fun_section_tmp,xc_fun_section_orig%section,& - error=error) + "XC_FUNCTIONAL") + CALL section_vals_create(xc_fun_section_tmp,xc_fun_section_orig%section) CALL section_vals_val_set(xc_fun_section_tmp,"_SECTION_PARAMETERS_",& - i_val=xc_funct_no_shortcut,error=error) + i_val=xc_funct_no_shortcut) CALL section_vals_val_set(xc_fun_section_tmp,"XALPHA%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) CALL section_vals_set_subs_vals(xc_section_tmp,"XC_FUNCTIONAL",& - xc_fun_section_tmp,error=error) + xc_fun_section_tmp) !---------------------! ! Both: hard and soft ! !---------------------! - CALL xc_dset_zero_all(deriv_set, error) + CALL xc_dset_zero_all(deriv_set) CALL vxc_of_r_new(xc_fun_section_tmp, rho_set_h, deriv_set, 1, needs,& - weight, lsd, na, nr, exc, vxc_tmp_h, vxg, vtau, error=error) - CALL xc_dset_zero_all(deriv_set, error) + weight, lsd, na, nr, exc, vxc_tmp_h, vxg, vtau) + CALL xc_dset_zero_all(deriv_set) CALL vxc_of_r_new(xc_fun_section_tmp, rho_set_s, deriv_set, 1, needs,& - weight, lsd, na, nr, exc, vxc_tmp_s, vxg, vtau, error=error) + weight, lsd, na, nr, exc, vxc_tmp_s, vxg, vtau) !-------------------------------------------! ! 2. PZ correlation for LB94 and ec_uniform ! !-------------------------------------------! CALL section_vals_val_set(xc_fun_section_tmp,"XALPHA%_SECTION_PARAMETERS_",& - l_val=.FALSE.,error=error) + l_val=.FALSE.) CALL section_vals_val_set(xc_fun_section_tmp,"PZ81%_SECTION_PARAMETERS_",& - l_val=.TRUE.,error=error) + l_val=.TRUE.) !------! ! Hard ! !------! - CALL xc_dset_zero_all(deriv_set, error) + CALL xc_dset_zero_all(deriv_set) CALL vxc_of_r_new(xc_fun_section_tmp, rho_set_h, deriv_set, 1, needs,& - weight, lsd, na, nr, exc, vxc_LB_h, vxg, vtau, error=error) + weight, lsd, na, nr, exc, vxc_LB_h, vxg, vtau) vxc_LB_h = vxc_LB_h + alpha*vxc_tmp_h DO ispin=1, nspins dummy => vxc_tmp_h(:,:,ispin:ispin) - CALL add_lb_pot(dummy, rho_set_h, lsd, ispin, error) + CALL add_lb_pot(dummy, rho_set_h, lsd, ispin) vxc_LB_h(:,:,ispin) = vxc_LB_h(:,:,ispin) - weight(:,:)*vxc_tmp_h(:,:,ispin) END DO NULLIFY(dummy) vxc_GLLB_h = 0.0_dp - deriv => xc_dset_get_derivative(deriv_set, "", error=error) - CPPostcondition(ASSOCIATED(deriv),cp_failure_level,routineP,error,failure) - CALL xc_derivative_get(deriv,deriv_data=e_uniform,error=error) + deriv => xc_dset_get_derivative(deriv_set, "") + CPPostcondition(ASSOCIATED(deriv),cp_failure_level,routineP,failure) + CALL xc_derivative_get(deriv,deriv_data=e_uniform) DO ispin=1, nspins dummy => vxc_GLLB_h(:,:,ispin:ispin) CALL calc_2excpbe(dummy, rho_set_h, e_uniform, lsd) @@ -812,22 +797,22 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) !------! ! Soft ! !------! - CALL xc_dset_zero_all(deriv_set, error) + CALL xc_dset_zero_all(deriv_set) CALL vxc_of_r_new(xc_fun_section_tmp, rho_set_s, deriv_set, 1, needs,& - weight, lsd, na, nr, exc, vxc_LB_s, vxg, vtau, error=error) + weight, lsd, na, nr, exc, vxc_LB_s, vxg, vtau) vxc_LB_s = vxc_LB_s + alpha*vxc_tmp_s DO ispin=1, nspins dummy => vxc_tmp_s(:,:,ispin:ispin) - CALL add_lb_pot(dummy, rho_set_s, lsd, ispin, error) + CALL add_lb_pot(dummy, rho_set_s, lsd, ispin) vxc_LB_s(:,:,ispin) = vxc_LB_s(:,:,ispin) - weight(:,:)*vxc_tmp_s(:,:,ispin) END DO NULLIFY(dummy) vxc_GLLB_s = 0.0_dp - deriv => xc_dset_get_derivative(deriv_set, "", error=error) - CPPostcondition(ASSOCIATED(deriv),cp_failure_level,routineP,error,failure) - CALL xc_derivative_get(deriv,deriv_data=e_uniform,error=error) + deriv => xc_dset_get_derivative(deriv_set, "") + CPPostcondition(ASSOCIATED(deriv),cp_failure_level,routineP,failure) + CALL xc_derivative_get(deriv,deriv_data=e_uniform) DO ispin=1, nspins dummy => vxc_GLLB_s(:,:,ispin:ispin) CALL calc_2excpbe(dummy, rho_set_s, e_uniform, lsd) @@ -845,26 +830,26 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) DO orb=1, homo(ispin)-1 ALLOCATE(coeff_col(nrow(ispin),1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) efac = K_rho * SQRT(mo_eigenvalues(ispin)%array(homo(ispin)) - & mo_eigenvalues(ispin)%array(orb)) IF (.not.lsd) efac = 2.0_dp * efac - CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp,error=error) + CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp) CALL cp_fm_get_submatrix(mo_coeff(ispin)%matrix, coeff_col, & - 1, orb, nrow(ispin), 1, error=error) + 1, orb, nrow(ispin), 1) CALL cp_fm_set_submatrix(single_mo_coeff(ispin)%matrix, coeff_col, & - 1, orb, error=error) - CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp,error=error) + 1, orb) + CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(orbital_density_matrix(ispin)%matrix,& matrix_v=single_mo_coeff(ispin)%matrix,& matrix_g=single_mo_coeff(ispin)%matrix,& ncol=ncol(ispin), & - alpha=1.0_dp,error=error) + alpha=1.0_dp) DEALLOCATE(coeff_col, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! This calculates the CPC and density on the grids for every atom even though ! we need it only for iatom at the moment. It seems that to circumvent this, @@ -873,8 +858,8 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) ns = SIZE(orbital_density_matrix) psmat(1:ns,1:1) => orbital_density_matrix(1:ns) CALL calculate_rho_atom_coeff(qs_env,psmat, & - local_rho_set%rho_atom_set,error=error) - CALL prepare_gapw_den(qs_env,local_rho_set,.FALSE.,error) + local_rho_set%rho_atom_set) + CALL prepare_gapw_den(qs_env,local_rho_set,.FALSE.) rho_atom => local_rho_set%rho_atom_set(iatom) NULLIFY(r_h,r_s,dr_h,dr_s,r_h_d,r_s_d) @@ -883,9 +868,9 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) DO ir=1, nr CALL calc_rho_angular(atomic_grid, harmonics, nspins, .FALSE., & ir, r_h, r_s, rho_h, rho_s, & - dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s, error) - CALL fill_rho_set(orb_rho_set_h,lsd,nspins,needs_orbs,rho_h,drho_h,tau,na,ir,error=error) - CALL fill_rho_set(orb_rho_set_s,lsd,nspins,needs_orbs,rho_s,drho_s,tau,na,ir,error=error) + dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s) + CALL fill_rho_set(orb_rho_set_h,lsd,nspins,needs_orbs,rho_h,drho_h,tau,na,ir) + CALL fill_rho_set(orb_rho_set_s,lsd,nspins,needs_orbs,rho_s,drho_s,tau,na,ir) END DO IF (lsd) THEN @@ -942,7 +927,7 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) DO orb=1, homo(ispin) ALLOCATE(coeff_col(nrow(ispin),1), stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) we_LB = EXP(-2.0_dp*(mo_eigenvalues(ispin)%array(homo(ispin)) - & mo_eigenvalues(ispin)%array(orb))**2) @@ -957,20 +942,20 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) vxc_tmp_s(:,:,ispin) = we_LB*vxc_LB_s(:,:,ispin) + & we_GLLB*vxc_GLLB_s(:,:,ispin) - CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp,error=error) + CALL cp_fm_set_all(single_mo_coeff(ispin)%matrix, 0.0_dp) CALL cp_fm_get_submatrix(mo_coeff(ispin)%matrix, coeff_col, & - 1, orb, nrow(ispin), 1, error=error) + 1, orb, nrow(ispin), 1) CALL cp_fm_set_submatrix(single_mo_coeff(ispin)%matrix, coeff_col, & - 1, orb, error=error) - CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp,error=error) + 1, orb) + CALL cp_dbcsr_set(orbital_density_matrix(ispin)%matrix,0.0_dp) CALL cp_dbcsr_plus_fm_fm_t(orbital_density_matrix(ispin)%matrix,& matrix_v=single_mo_coeff(ispin)%matrix,& matrix_g=single_mo_coeff(ispin)%matrix,& ncol=ncol(ispin), & - alpha=1.0_dp,error=error) + alpha=1.0_dp) DEALLOCATE(coeff_col, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) ! This calculates the CPC and density on the grids for every atom even though ! we need it only for iatom at the moment. It seems that to circumvent this, @@ -979,8 +964,8 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) ns = SIZE(orbital_density_matrix) psmat(1:ns,1:1) => orbital_density_matrix(1:ns) CALL calculate_rho_atom_coeff(qs_env,psmat, & - local_rho_set%rho_atom_set,error=error) - CALL prepare_gapw_den(qs_env,local_rho_set,.FALSE.,error) + local_rho_set%rho_atom_set) + CALL prepare_gapw_den(qs_env,local_rho_set,.FALSE.) rho_atom => local_rho_set%rho_atom_set(iatom) NULLIFY(r_h,r_s,dr_h,dr_s,r_h_d,r_s_d) @@ -989,9 +974,9 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) DO ir=1, nr CALL calc_rho_angular(atomic_grid, harmonics, nspins, .FALSE., & ir, r_h, r_s, rho_h, rho_s, & - dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s, error) - CALL fill_rho_set(orb_rho_set_h,lsd,nspins,needs_orbs,rho_h,drho_h,tau,na,ir,error=error) - CALL fill_rho_set(orb_rho_set_s,lsd,nspins,needs_orbs,rho_s,drho_s,tau,na,ir,error=error) + dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s) + CALL fill_rho_set(orb_rho_set_h,lsd,nspins,needs_orbs,rho_h,drho_h,tau,na,ir) + CALL fill_rho_set(orb_rho_set_s,lsd,nspins,needs_orbs,rho_s,drho_s,tau,na,ir) END DO IF (lsd) THEN @@ -1056,35 +1041,35 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) rho_atom => rho_atom_set(iatom) SELECT CASE (oe_corr) CASE(oe_lb) - CALL gaVxcgb_noGC(vxc_LB_h,vxc_LB_s,qs_kind_set(ikind),rho_atom,nspins,error=error) + CALL gaVxcgb_noGC(vxc_LB_h,vxc_LB_s,qs_kind_set(ikind),rho_atom,nspins) CASE (oe_gllb) - CALL gaVxcgb_noGC(vxc_GLLB_h,vxc_GLLB_s,qs_kind_set(ikind),rho_atom,nspins,error=error) + CALL gaVxcgb_noGC(vxc_GLLB_h,vxc_GLLB_s,qs_kind_set(ikind),rho_atom,nspins) CASE (oe_saop) - CALL gaVxcgb_noGC(vxc_SAOP_h,vxc_SAOP_s,qs_kind_set(ikind),rho_atom,nspins,error=error) + CALL gaVxcgb_noGC(vxc_SAOP_h,vxc_SAOP_s,qs_kind_set(ikind),rho_atom,nspins) CASE default - CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) + CPPostcondition(.FALSE.,cp_failure_level,routineP,failure) END SELECT END DO DEALLOCATE(rho_h, rho_s, weight, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(vxc_LB_h, vxc_LB_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(vxc_GLLB_h, vxc_GLLB_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(vxc_tmp_h, vxc_tmp_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(vxc_SAOP_h, vxc_SAOP_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) DEALLOCATE(drho_h, drho_s, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) - CALL xc_dset_release(deriv_set, error=error) - CALL xc_rho_set_release(rho_set_h, error=error) - CALL xc_rho_set_release(rho_set_s, error=error) - CALL xc_rho_set_release(orb_rho_set_h, error=error) - CALL xc_rho_set_release(orb_rho_set_s, error=error) + CALL xc_dset_release(deriv_set) + CALL xc_rho_set_release(rho_set_h) + CALL xc_rho_set_release(rho_set_s) + CALL xc_rho_set_release(orb_rho_set_h) + CALL xc_rho_set_release(orb_rho_set_s) END DO @@ -1094,22 +1079,22 @@ SUBROUTINE gapw_add_atomic_saop_pot(qs_env, oe_corr, error) ns = SIZE(rho_struct_ao) psmat(1:ns,1:1) => rho_struct_ao(1:ns) - CALL update_ks_atom(qs_env,ksmat,psmat,.FALSE.,error=error) + CALL update_ks_atom(qs_env,ksmat,psmat,.FALSE.) !---------! ! Cleanup ! !---------! - CALL section_vals_release(xc_fun_section_tmp,error=error) - CALL section_vals_release(xc_section_tmp,error=error) - CALL section_vals_release(xc_section_orig,error=error) + CALL section_vals_release(xc_fun_section_tmp) + CALL section_vals_release(xc_section_tmp) + CALL section_vals_release(xc_section_orig) - CALL local_rho_set_release(local_rho_set,error) + CALL local_rho_set_release(local_rho_set) DO ispin=1, nspins - CALL cp_fm_release(single_mo_coeff(ispin)%matrix, error=error) + CALL cp_fm_release(single_mo_coeff(ispin)%matrix) END DO DEALLOCATE(mo_coeff, single_mo_coeff, mo_eigenvalues, stat=stat) - CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CALL cp_dbcsr_deallocate_matrix_set(orbital_density_matrix,error=error) + CPPostcondition(stat==0,cp_failure_level,routineP,failure) + CALL cp_dbcsr_deallocate_matrix_set(orbital_density_matrix) END SUBROUTINE gapw_add_atomic_saop_pot @@ -1119,16 +1104,14 @@ END SUBROUTINE gapw_add_atomic_saop_pot !> \param rho_set ... !> \param lsd ... !> \param spin ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE add_lb_pot(pot, rho_set, lsd, spin, error) + SUBROUTINE add_lb_pot(pot, rho_set, lsd, spin) REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: pot TYPE(xc_rho_set_type), POINTER :: rho_set LOGICAL, INTENT(IN) :: lsd INTEGER, INTENT(IN) :: spin - TYPE(cp_error_type), INTENT(INOUT) :: error REAL(KIND=dp), PARAMETER :: ob3 = 1.0_dp/3.0_dp diff --git a/src/xc_write_output.F b/src/xc_write_output.F index 0e77483ec4..a03607790d 100644 --- a/src/xc_write_output.F +++ b/src/xc_write_output.F @@ -34,13 +34,11 @@ MODULE xc_write_output !> \param output_unit ... !> \param xc_section ... !> \param lsd ... -!> \param error ... ! ***************************************************************************** - SUBROUTINE xc_write(output_unit, xc_section, lsd, error) + SUBROUTINE xc_write(output_unit, xc_section, lsd) INTEGER, INTENT(IN) :: output_unit TYPE(section_vals_type), POINTER :: xc_section LOGICAL, INTENT(IN) :: lsd - TYPE(cp_error_type), INTENT(inout) :: error CHARACTER(len=*), PARAMETER :: routineN = 'xc_write', & routineP = moduleN//':'//routineN @@ -58,26 +56,24 @@ SUBROUTINE xc_write(output_unit, xc_section, lsd, error) IF (output_unit>0) THEN xc_fun_section => section_vals_get_subs_vals(xc_section,& - "XC_FUNCTIONAL",error=error) - CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun,error=error) + "XC_FUNCTIONAL") + CALL section_vals_val_get(xc_fun_section,"_SECTION_PARAMETERS_",i_val=myfun) IF (myfun/=xc_none) THEN CALL section_vals_val_get(xc_section,"FUNCTIONAL_ROUTINE",& - c_val=tmpStr,error=error) + c_val=tmpStr) WRITE (output_unit, fmt="(' FUNCTIONAL| ROUTINE=',a)")& TRIM(tmpStr) - CALL xc_functionals_expand(xc_fun_section,xc_section,error=error) + CALL xc_functionals_expand(xc_fun_section,xc_section) ifun=0 DO ifun=ifun+1 - xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun,& - error=error) + xc_fun => section_vals_get_subs_vals2(xc_fun_section,i_section=ifun) IF (.NOT.ASSOCIATED(xc_fun)) EXIT CALL xc_functional_get_info(xc_fun,& lsd=lsd,& reference=reference,& shortform=shortform,& - ifunc_name=1,& - error=error) + ifunc_name=1) IF (TRIM(xc_fun%section%name) == "LIBXC") THEN CALL libxc_version_info(tmpStr) WRITE (output_unit, fmt="(A,A,A)") ' FUNCTIONAL| LIBXC Vers. ', TRIM(tmpStr(1:5)), & @@ -86,14 +82,13 @@ SUBROUTINE xc_write(output_unit, xc_section, lsd, error) DO il=1,LEN_TRIM(reference),67 WRITE (output_unit, fmt="(' FUNCTIONAL| ',a67)") reference(il:) END DO - CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name,error=error) + CALL section_vals_val_get(xc_fun,"functional",c_vals=func_name) DO ifunc_name=2, SIZE(func_name) CALL xc_functional_get_info(xc_fun,& lsd=lsd,& reference=reference,& shortform=shortform,& - ifunc_name=ifunc_name,& - error=error) + ifunc_name=ifunc_name) WRITE (output_unit, fmt="(A,A,A)") ' FUNCTIONAL| LIBXC Vers. ', TRIM(tmpStr(1:5)), & ' (Marques, Oliveira, Burnus, CPC 183, 2272 (2012))' WRITE (output_unit, fmt="(' FUNCTIONAL| ',a,':')") TRIM(shortform) diff --git a/src/xray_diffraction.F b/src/xray_diffraction.F index a59f68cc99..82c5093e01 100644 --- a/src/xray_diffraction.F +++ b/src/xray_diffraction.F @@ -84,16 +84,14 @@ MODULE xray_diffraction !> \param qs_env ... !> \param unit_number ... !> \param q_max ... -!> \param error ... !> \date 30.11.2005 !> \author Matthias Krack ! ***************************************************************************** - SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) + SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max) TYPE(qs_environment_type), POINTER :: qs_env INTEGER, INTENT(IN) :: unit_number REAL(KIND=dp), INTENT(IN) :: q_max - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'xray_diffraction_spectrum', & routineP = moduleN//':'//routineN @@ -130,7 +128,7 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) IF (.NOT.failure) THEN @@ -172,12 +170,10 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) particle_set=particle_set,& pw_env=pw_env,& rho=rho,& - rho_atom_set=rho_atom_set,& - error=error) + rho_atom_set=rho_atom_set) CALL pw_env_get(pw_env=pw_env,& - auxbas_pw_pool=auxbas_pw_pool,& - error=error) + auxbas_pw_pool=auxbas_pw_pool) group = para_env%group npe = para_env%num_pe @@ -188,17 +184,15 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=rhotot_elec_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) - CALL pw_zero(rhotot_elec_gspace%pw,error=error) + in_space=RECIPROCALSPACE) + CALL pw_zero(rhotot_elec_gspace%pw) CALL get_pw_grid_info(pw_grid=rhotot_elec_gspace%pw%pw_grid,& dr=dr,& npts=npts,& cutoff=cutoff,& ngpts=ngpts,& - gsquare=gsq,& - error=error) + gsquare=gsq) dg(:) = twopi/(npts(:)*dr(:)) @@ -209,8 +203,7 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) rhotot_elec_gspace=rhotot_elec_gspace,& q_max=q_max,& rho_hard=rho_hard,& - rho_soft=rho_soft,& - error=error) + rho_soft=rho_soft) rho_total = rho_hard + rho_soft @@ -232,7 +225,7 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) ng_shell(1) = 1 DO ig=2,ng - CPPostcondition(gsq(ig)>=gsq(jg),cp_failure_level,routineP,error,failure) + CPPostcondition(gsq(ig)>=gsq(jg),cp_failure_level,routineP,failure) IF (ABS(gsq(ig) - gsq(jg)) > 1.0E-12_dp) THEN nshell = nshell + 1 IF (nshell > SIZE(q_shell)) THEN @@ -317,12 +310,12 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) IF (ASSOCIATED(offset_pe)) THEN DEALLOCATE (offset_pe,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(nshell_pe)) THEN DEALLOCATE (nshell_pe,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! Print X-ray diffraction spectrum (I/O node only) @@ -383,7 +376,7 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) IF (ASSOCIATED(aux_index)) THEN DEALLOCATE (aux_index,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF ! Allocate the final arrays for printing with their real size @@ -441,77 +434,76 @@ SUBROUTINE xray_diffraction_spectrum(qs_env,unit_number,q_max,error) IF (ASSOCIATED(fmin)) THEN DEALLOCATE (fmin,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fmax)) THEN DEALLOCATE (fmax,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fsum)) THEN DEALLOCATE (fsum,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(f2sum)) THEN DEALLOCATE (f2sum,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(f4sum)) THEN DEALLOCATE (f4sum,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(ng_shell)) THEN DEALLOCATE (ng_shell,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(q_shell)) THEN DEALLOCATE (q_shell,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fmin_gather)) THEN DEALLOCATE (fmin_gather,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fmax_gather)) THEN DEALLOCATE (fmax_gather,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(fsum_gather)) THEN DEALLOCATE (fsum_gather,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(f2sum_gather)) THEN DEALLOCATE (f2sum_gather,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(f4sum_gather)) THEN DEALLOCATE (f4sum_gather,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(ng_shell_gather)) THEN DEALLOCATE (ng_shell_gather,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(q_shell_gather)) THEN DEALLOCATE (q_shell_gather,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL pw_pool_give_back_pw(auxbas_pw_pool,& - rhotot_elec_gspace%pw,& - error=error) + rhotot_elec_gspace%pw) CALL timestop(handle) @@ -529,14 +521,13 @@ END SUBROUTINE xray_diffraction_spectrum !> \param rho_hard ... !> \param rho_soft ... !> \param fsign ... -!> \param error ... !> \date 14.03.2008 (splitted from the routine xray_diffraction_spectrum) !> \author Matthias Krack !> \note This code assumes that the g-vectors are ordered (in gsq and %cc) ! ***************************************************************************** SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& rhotot_elec_gspace,q_max,rho_hard,& - rho_soft,fsign,error) + rho_soft,fsign) TYPE(qs_environment_type), POINTER :: qs_env TYPE(pw_pool_type), POINTER :: auxbas_pw_pool @@ -544,7 +535,6 @@ SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& REAL(KIND=dp), INTENT(IN) :: q_max REAL(KIND=dp), INTENT(OUT) :: rho_hard, rho_soft REAL(KIND=dp), INTENT(IN), OPTIONAL :: fsign - TYPE(cp_error_type), INTENT(INOUT) :: error CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_rhotot_elec_gspace', & routineP = moduleN//':'//routineN @@ -583,8 +573,8 @@ SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& failure = .FALSE. - CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,error,failure) - CPPrecondition(ASSOCIATED(auxbas_pw_pool),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(qs_env),cp_failure_level,routineP,failure) + CPPrecondition(ASSOCIATED(auxbas_pw_pool),cp_failure_level,routineP,failure) IF (.NOT.failure) THEN @@ -617,10 +607,9 @@ SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& dft_control=dft_control,& particle_set=particle_set,& rho=rho,& - rho_atom_set=rho_atom_set,& - error=error) + rho_atom_set=rho_atom_set) - CALL qs_rho_get(rho, rho_r=rho_r, error=error) + CALL qs_rho_get(rho, rho_r=rho_r) eps_rho_gspace = dft_control%qs_control%eps_rho_gspace nkind = SIZE(atomic_kind_set) nspin = dft_control%nspins @@ -630,38 +619,35 @@ SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& CALL pw_pool_create_pw(pool=auxbas_pw_pool,& pw=rho_elec_gspace%pw,& use_data=COMPLEXDATA1D,& - in_space=RECIPROCALSPACE,& - error=error) + in_space=RECIPROCALSPACE) - CALL pw_zero(rhotot_elec_gspace%pw,error=error) + CALL pw_zero(rhotot_elec_gspace%pw) DO ispin=1,nspin - CALL pw_zero(rho_elec_gspace%pw,error=error) - CALL pw_transfer(rho_r(ispin)%pw,rho_elec_gspace%pw,debug=.FALSE.,error=error) + CALL pw_zero(rho_elec_gspace%pw) + CALL pw_transfer(rho_r(ispin)%pw,rho_elec_gspace%pw,debug=.FALSE.) IF (PRESENT(fsign).AND.(ispin == 2)) THEN alpha = fsign ELSE alpha = 1.0_dp END IF - CALL pw_axpy(rho_elec_gspace%pw,rhotot_elec_gspace%pw,alpha=alpha,error=error) + CALL pw_axpy(rho_elec_gspace%pw,rhotot_elec_gspace%pw,alpha=alpha) END DO ! Release the auxiliary PW grid for the calculation of the soft ! contribution CALL pw_pool_give_back_pw(pool=auxbas_pw_pool,& - pw=rho_elec_gspace%pw,& - error=error) + pw=rho_elec_gspace%pw) - rho_soft = pw_integrate_function(rhotot_elec_gspace%pw,isign=-1,error=error) + rho_soft = pw_integrate_function(rhotot_elec_gspace%pw,isign=-1) CALL get_pw_grid_info(pw_grid=rhotot_elec_gspace%pw%pw_grid,& vol=volume,& - orthorhombic=orthorhombic,& - error=error) - CPPostcondition(orthorhombic,cp_failure_level,routineP,error,failure) + orthorhombic=orthorhombic) + CPPostcondition(orthorhombic,cp_failure_level,routineP,failure) - CALL pw_scale(rhotot_elec_gspace%pw,volume,error=error) + CALL pw_scale(rhotot_elec_gspace%pw,volume) ! Add the hard contribution of the electronic density @@ -677,7 +663,7 @@ SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& CALL get_qs_kind(qs_kind_set(ikind),& basis_set=orb_basis_set,& paw_proj_set=paw_proj,& - paw_atom=paw_atom, error=error) + paw_atom=paw_atom) IF (.NOT.paw_atom) CYCLE ! no PAW atom: nothing to do @@ -793,7 +779,7 @@ SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& END DO ! next atom "iatom" of atomic kind "ikind" END DO ! next atomic kind "ikind" - rho_total = pw_integrate_function(rhotot_elec_gspace%pw,isign=-1,error=error)/volume + rho_total = pw_integrate_function(rhotot_elec_gspace%pw,isign=-1)/volume rho_hard = rho_total - rho_soft @@ -801,17 +787,17 @@ SUBROUTINE calculate_rhotot_elec_gspace(qs_env,auxbas_pw_pool,& IF (ASSOCIATED(delta_cpc)) THEN DEALLOCATE (delta_cpc,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(work)) THEN DEALLOCATE (work,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF IF (ASSOCIATED(pab)) THEN DEALLOCATE (pab,STAT=istat) - CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) + CPPostcondition(istat==0,cp_failure_level,routineP,failure) END IF CALL timestop(handle)